Tcl Source Code

Changes On Branch kennykb-numerics-branch
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch kennykb-numerics-branch Excluding Merge-Ins

This is equivalent to a diff from ad35750c6d to 1b902ae45a

2005-10-08
13:44
merge updates from HEAD Closed-Leaf check-in: 1b902ae45a user: dgp tags: kennykb-numerics-branch
06:43
more WIDE support check-in: 936ff6a20a user: dgp tags: kennykb-numerics-branch
2004-12-02
19:24
merge to kennykb-numerics-branch-20041202a check-in: ac3b922388 user: kennykb tags: kennykb-numerics-branch
18:40
workaround for a bug in cygpath that made safe-8.5-8.7 fail check-in: 1f8af3a1ac user: kennykb tags: trunk
15:31
Remove a global mutex/state by using lists instead of hashtables to store the collection of aliases ... check-in: ad35750c6d user: dkf tags: trunk
11:10
Upgrade more of the file to tcltest2, and collect constraint definitions to the top. check-in: 067ebb1583 user: dkf tags: trunk

Changes to ChangeLog.












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17











































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































2004-12-02  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (Alias,Target,Master): Rewrote these so that
	the aliases that refer to an interpreter are stored in a list and
	not a hashtable (which was only ever a convenience, and forced the
	use of a global mutex to generate keys!) [FRQ 1077210]
	* generic/tclNamesp.c (numNsCreated): Moved into thread-local
	storage to remove a global mutex. [FRQ 1077210]

2004-12-01  Don Porter  <[email protected]>

	* generic/tclUtil.c (TclGetProcessGlobalValue):	Narrowed the scope
	of mutex locks.

	* generic/tclUtil.c:		Updated Tcl_GetNameOfExecutable() to
	* generic/tclEncoding.c:	make use of a ProcessGlobalValue for
	* generic/tclEvent.c:		storing the executable name.
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
2005-10-08  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD

	* generic/tclExecute.c:	More performance macros and special
	handling of the wide integer type for performance on 32-bit
	systems.

2005-10-07  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Macro GetNumberFromObj() is version of
	TclGetNumberFromObj() that saves a function call for common uses.

	* generic/tclInt.h:	Made #undef NO_WIDE_TYPE the default on
	32-bit systems.  Being able to use 64-bit values without leaping
	to mp_int should help with performance.
	* generic/tclObj.c:	Bug fixes in the #undef NO_WIDE_TYPE
	* generic/tclExecute.c:	configuration.

	* generic/tclExecute.c:	Improved performance of comparison opcodes
	and bitwise operations and removed yet more dead code.

2005-10-07  Jeff Hobbs  <[email protected]>

	* unix/tclUnixFCmd.c (TraverseUnixTree): Adjust 2004-11-11 change to
	* tests/fCmd.test (fCmd-20.2):           account for NFS special
	files with a readdir rewind threshold. [Bug 1034337]

2005-10-06  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Improved performance of INST_RSHIFT and
	INST_LSHIFT.

2005-10-05  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Improved performance of INST_MULT, INST_DIV,
	INST_ADD, and INST_SUB and replaced a "goto... label" with a
	"break from loop" in TclIncrObj() and removed some dead code.

2005-10-05  Andreas Kupries <[email protected]>

	* generic/tclPipe.c (TclCreatePipeline): Fixed [SF Tcl Bug
	  1109294]. Applied the patch provided by David Gravereaux.

	* doc/CrtChannel.3: Fixed [SF Tcl Bug 1104682], by application of
	  David Welton's patch for it, and added a note about
	  wideSeekProc.

	* generic/tclIORChan.c (RcClose): Removed unreachable panic/return
	  statements. This fixes the remainder of [SF Tcl Bug 1286256].

2005-10-05  Jeff Hobbs  <[email protected]>

	* tests/env.test (env-6.1):
	* win/tclWinPort.h: define USE_PUTENV_FOR_UNSET 1
	* generic/tclEnv.c (TclSetEnv, TclUnsetEnv): add
	USE_PUTENV_FOR_UNSET to existing USE_PUTENV define to account for
	various systems that have putenv(), but can't unset env vars with
	it.  Note difference between Windows and Linux for actually
	unsetting the env var (use of '=').
	Correct the resizing of the environ array.  We assume that we are
	in full ownership, but that's not correct.[Bug 979640]

2005-10-04  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Updated TclIncrObj() to more efficiently
	add native long integers.  Also updated IllegalExprOperandType
	and the INST_UMINUS, INST_UPLUS, INST_BITNOT, and
	INST_TRY_CVT_TO_NUMERIC sections for performance.

	* generic/tclBasic.c:	Updated more callers to make use of
	TclGetNumberFromObj.  Removed some dead code.

2005-10-04  Jeff Hobbs  <[email protected]>

	* win/tclWinSerial.c (SerialSetOptionProc): free argv [Bug 1067708]

	* tests/http.test:              do not URI encode -._~ according
	* library/http/http.tcl (init): to RFC3986. [Bug 1182373] (aho)

	* unix/tclLoadShl.c (TclpDlopen): use DYNAMIC_PATH on second
	shl_load only.  [Bug 1204237]

	* doc/scan.n: scan %[] requires "one or more chars" [Bug 1277503]

	* tests/winFile.test (getuser): allow valid Windows usernames.
	[Bug 1311285]

	* generic/tclParse.c (Tcl_ParseCommand): add code that recognizes
	{} in addition to {expand} for word expansion (make with
	-DALLOW_EMPTY_EXPAND).

2005-10-04  Zoran Vasiljevic <[email protected]>

	* generic/tclIO.c (Tcl_ClearChannelHandlers): now deletes any
	outstanding timer for the channel. Also, prevents events still
	in the event queue from triggering on the current channel.

	* generic/tclTimer.c (Tcl_DeleteTimerHandler): bail out early
	if passed NULL argument.

2005-10-03  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclBasic.c:	Re-implemented ExprRoundFunc and ExprEntierFunc
	to use TclGetNumberFromObj.

	* generic/tclInt.h:	Added new routine TclGetNumberFromObj to
	* generic/tclObj.c:	provide efficient access to the actual
	internal rep of a numeric Tcl_Obj without conversions.

2005-10-03  Kevin Kenny  <[email protected]>

	* tools/loadICU.tcl:  Changed the file names of message catalogs
	                      to lowercase.
	* tools/makeTestCases.tcl:
	* library/tzdata/*:   Olson's tzdata2005n.tar.gz.  
	                      Includes new DST rules for USA and a
	                      number of changes to other locales.
	* tests/clock.test:   Regenerated for new US DST rules.
	
2005-09-30  Don Porter  <[email protected]>

	* generic/tclMain.c: Separate encoding conversion of command line
	arguments from list formatting.	 [Bug 1306162].

2005-09-30  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclStringObj.c:	Bug fix: Missing cast to large enough
	integral size before << operations led to broken [format %llx] results.
	Thanks to Robert Henry for reporting the bug.

2005-09-29  Jeff Hobbs  <[email protected]>

	* doc/mathfunc.n:   implementation for TIP #255, expr min/max
	* library/init.tcl:
	* tests/info.test, tests/expr-old.test: 

2005-09-27  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tcl.h:	Changed name of the new Tcl_Obj intrep field
	* generic/tclObj.c:	from "bignumValue" to "ptrAndLongRep" as
	* generic/tclProc.c:	described in TIP 237, and more suitable for
	other more general uses.

2005-09-27  Donal K. Fellows  <[email protected]>

	* tests/binary.test (binary-14.18): Added test for [Bug 1116542]
	though the bug itself was already fixed by unrelated changes.

2005-09-26  Kevin Kenny  <[email protected]>

	[kennykb-numerics-branch] Merge updates from HEAD.
	
2005-09-26  Kevin Kenny  <[email protected]>

	* libtommath/:                   Updated to release 0.36.
	* generic/tommath.h:             Regenerated.
	* generic/tclTomMathInterface.h: Added ten missing aliases for mp_*
	functions to avoid namespace pollution in Tcl's exported symbols.
	[Bug 1263012]
	
2005-09-23  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* unix/Makefile.in:	Added -DMP_PREC=4 switch to all compiles so
	* win/Makefile.in:	that minimum memory requirements of mp_int's
	* win/makefile.vc:	will not be quite so large.  [Bug 1299153].

	* generic/tclStrToD.c:	Fixed memory leak.  [Bug 1299803].
	* generic/tclObj.c:	

2005-09-20  Don Porter  <[email protected]>

	[kennykb-numerics-branch]
	
	* generic/tclExecute.c:	Revise TclIncrObj() to call
	Tcl_GetBignumAndClearObj.

	* generic/tcl.decls:	Add Tcl_GetBignumAndClearObj.
	* generic/tclObj.c:

	* generic/tclDecls.h:	make genstubs
	* generic/tclStubInit.c:

2005-09-16  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclInt.h:		Added TclBNInitBigNumFromWideInt()
	* generic/tclTomMathInterface.c:	so that every caller isn't
	required to duplicate the sign logic to use the unsigned interface.

	* generic/tclBasic.c:	Reduce the number of places where Tcl
	* generic/tclExecute.c:	intrudes into the internal format details
	* generic/tclObj.c:	of the mp_int struct.
	* generic/tclStrToD.c:
	* generic/tcLStringObj.c:

	* generic/tclTomMath.h:	Added mp_cmp_d to routines from
	* unix/Makefile.in:	libtommath used by Tcl.
	* win/Makefile.in:
	* win/makefile.vc:

	* libtommath/bn_mp_add_d.c:	Bug fix.  For mp_add_d(&a, d, &c),
	when &a has the value -d, then the value &c computed should be zero,
	but mp_add_d was producing an inconsistent zero value with a sign
	field of MP_NEG, something like a value of -0, which other routines
	in libtommath can't handle.

	* generic/tclExecute.c:	Dropped all creation of "bigOne" values
	and just use tommath routines that accept the value "1" directly.

2005-09-15  Miguel Sofer <[email protected]>

	* doc/ParseCmd.3: copy/paste fix [Bug 1292427]

2005-09-15  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclStringObj.c (TclAppendFormattedObjs):	Revision
	to eliminate one round of string copying.

	* generic/tclBasic.c:	More callers of TclObjPrintf and
	* generic/tclCkalloc.c:	TclFormatToErrorInfo.
	* generic/tclCmdMZ.c:
	* generic/tclExecute.c:
	* generic/tclIORChan.c:
	* generic/tclMain.c:
	* generic/tclProc.c:
	* generic/tclTimer.c:
	* generic/tclUtil.c:
	* unix/tclUnixFCmd.c

	* unix/configure:	autoconf-2.59

2005-09-15  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl
	to transparently open large files on RHEL 3. [Bug 1287638]

2005-09-14  Don Porter  <[email protected]>

	* generic/tclStringObj.c:	Bug fixes: ObjPrintfVA needed to
	support "*" fields and needed to interpret precision limits on
	%s conversions as a maximum number of bytes, not Tcl_UniChars, to
	take from the (char *) argument.

	* generic/tclBasic.c:	Updated several callers to use
	* generic/tclCkalloc.c: TclFormatToErrorInfo() and/or
	* generic/tclCmdAH.c:	TclObjPrintf().
	* generic/tclCmdIL.c:
	* generic/tclCmdMZ.c:
	* generic/tclDictObj.c:
	* generic/tclExecute.c:
	* generic/tclIORChan.c:
	* generic/tclIOUtil.c:
	* generic/tclNamesp.c:
	* generic/tclProc.c:

	* library/init.tcl:	Keep [unknown] in sync with errorInfo
	formatting rules.

2005-09-13  Don Porter  <[email protected]>

	* generic/tclBasic.c:	First caller of TclFormatToErrorInfo.

	* generic/tclInt.h:		Using stdarg.h conventions, add more
	* generic/tclStringObj.c:	fixed arguments to TclFormatObj() and
	TclObjPrintf().  Added new routine TclFormatToErrorInfo().

	* generic/tcl.h:	Explicitly standardized on the use of stdarg.h
	* generic/tclBasic.c:	conventions for functions with variable number
	* generic/tclInt.h:	of arguments.  Support for varargs.h has been
	* generic/tclPanic.c:	implicitly gone for some time now.  All
	* generic/tclResult.c:	TCL_VARARGS* macros purged from Tcl sources,
	* generic/tclStringObj.c:	leaving only some deprecated #define's
	* tools/genStubs.tcl:	in tcl.h for the sake of older extensions.

	* generic/tclDecls.h:	make genstubs

	* doc/AddErrInfo.3:	Replaced all documented requirement for use
	* doc/Eval.3:		of TCL_VARARGS_START() with requirement for
	* doc/Panic.3:		use of va_start().
	* doc/SetResult.3:
	* doc/StringObj.3:

2005-09-12  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclCmdAH.c:		Added support for the "ll" width	
	* generic/tclStringObj.c:	specifier to [format].

	* generic/tclStringObj.c (TclAppendFormattedObjs):	Bug fix:
	make sure %ld formats force the collection of a wide value, when
	the value could be a different long.

2005-09-09  Andreas Kupries <[email protected]>

	* generic/tclIORChan.c (RcDecodeEventMask): Added missing type
	  declaration for the parameter 'mask'. This fixes the [SF Tcl Bug
	  1286256]. The other warning can be removed only by removing the
	  panic/return code.

2005-09-09  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

2005-09-09  Kevin Kenny  <[email protected]>

	* generic/tclStringObj.c:  Added two missing casts to silence
	messages from MSVC6.

2005-09-09  Don Porter  <[email protected]>

	* generic/tclInt.h:		New internal routine TclObjPrintf()
	* generic/tclStringObj.c:	is similar to TclFormatObj() but
	accepts arguments in non-Tcl_Obj format.

	* generic/tclInt.h:		New internal routines TclFormatObj()
	* generic/tclStringObj.c:	and TclAppendFormattedObjs() to offer
	sprintf()-like means to append to Tcl_Obj.  Work in progress toward
	[RFE 572392].

	* generic/tclCmdAH.c:	Compiler directive NEW_FORMAT when #define'd
	directs the [format] command to be implemented in terms of the new
	TclAppendFormattedObjs() routine.

2005-09-08  Donal K. Fellows  <[email protected]>

	TIP#254 IMPLEMENTATION

	* generic/tclLink.c (LinkTraceProc,ObjValue): Added many new of C var
	* generic/tcl.h:			      to link to, making it
	* doc/LinkVar.3:			      easier to seamlessly
	* generic/tclTest.c (TestlinkCmd):	      couple C code and Tcl
	* tests/link.test:			      scripts in an
	application. [Patch 1242844]

2005-09-07  Don Porter  <[email protected]>

	* generic/tclUtf.c (Tcl_UniCharToUtf):	Corrected handling of negative
	* tests/utf.test (utf-1.5):	Tcl_UniChar input value.  Incorrect
	handling was producing byte sequences outside of Tcl's legal internal
	encoding.  [Bug 1283976].

2005-09-06  Donal K. Fellows  <[email protected]>

	* generic/tclInt.h (List): Added flag to keep track of whether a list
	* generic/tclListObj.c:    with a string rep is provably canonical.
	* generic/tclUtil.c (Tcl_ConcatObj):  Do efficient concatenation and
	* generic/tclBasic.c (Tcl_EvalObjEx): evaluation when the list is
	canonical, and not just when the list is pure. This should make the
	"pure list" hacking introduced in 8.3 much more robust.

2005-09-05  Donal K. Fellows  <[email protected]>

	* generic/tclObj.c (pendingObjDataKey): Added missing 'static' to stop
	symbol from leaking outside the Tcl library. [Bug 1263012]

2005-09-02  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclScan.c:	Bug fix: The %o, %x, %i formats of [scan]
	must not accept any 0b or 0o prefixes.  [scan $s %o] must continue
	to work even with KILL_OCTAL enabled.

	* generic/tclInt.h:	Added TCL_PARSE_SCAN_PREFIXES to the flags
	* generic/tclStrToD.c:	accepted by TclParseNumber.

2005-09-01  Andreas Kupries <[email protected]>

	* unix/tclUnixSock.c (InitializeHostName): Synchronized use of
	  static modifier in declaration and definition of function.

	* unix/tclUnixChan.c (FileTruncateProc): Synchronized use of
	  static modifier in declaration and definition of function.

	* generic/tclResult.c (ReleaseKeys): Synchronized use of static
	  modifier in declaration and definition of function.

	* generic/tclListObj.c (NewListIntRep): Synchronized use of static
	  modifier in declaration and definition of function.

	* generic/tclEncoding.c (InitializeEncodingSearchPath):
	  Synchronized use of static modifier in declaration and
	  definition of function.

	* generic/tclEncoding.c (FillEncodingFileMap): Synchronized use of
	  static modifier in declaration and definition of function.

	* generic/tclIORChan.c (RcNewHandle): Synchronized use of static
	  modifier in declaration and definition of function.

2005-09-01  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	TclParseNumber calls meant to parse an
	integer value now pass the TCL_PARSE_INTEGER_ONLY flag.

	* generic/tclScan.c:	Extended [scan] to accept the %lld,
	%llo, %llx, and %lli formats.  Numeric scanning is now done
	via TclParseNumber calls.

	* generic/tclInt.h:	Extended TclParseNumber to accept new flag
	* generic/tclStrToD.c:	values TCL_PARSE_INTEGER_ONLY,
	TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller
	more control over the parsing rules.

2005-08-31  Vince Darley <[email protected]>

	* doc/FileSystem.3:
	* unix/tclUnixFile.c:
	* windows/tclWinFile.c: clarify that Tcl_FSMatchInDirectory may
	be called with a NULL interpreter, and fix the code so this is
	allowed.  Tcl's core itself (tclEncoding.c:FillEncodingFileMap())
	calls this with a NULL interpreter.

2005-08-30  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	Extended bignum support to include bignums
	so large they will not pack into a Tcl_Obj.  When they outgrow Tcl's
	string rep length limits, a panic will result.

	* generic/tclTomMath.h:	Added mp_sqrt to routines from
	* unix/Makefile.in:	libtommath used by Tcl.
	* win/Makefile.in:
	* win/makefile.vc:

	* generic/tclBasic.c:	Extended sqrt(.) so that range covers
	the entire double range, accepting as many bignums in the domain
	as that will allow.

2005-08-29  Andreas Kupries <[email protected]>

	* library/tm.tcl (::tcl::tm::roots): Accepted Don Porter's patch
	  for [Tcl SF Bug 1189657]. Syncs the implementation to the
	  specification (TIP #189).

2005-08-29  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Merge updates from HEAD.

	* generic/tclBasic.c:	Restored round(.) to the Tcl 8.4 rules.

2005-08-29  Kevin Kenny  <[email protected]>

	* generic/tclBasic.c (ExprMathFunc): Restored "round away from
	* tests/expr.test (expr-46.*):       zero" behaviour to the
	                                     "round" function.  Added
	test cases for the behavior, including the awkward case of a
	number whose fractional part is 1/2-1/2ulp. [Bug 1275043]

2005-08-26  Andreas Kupries <[email protected]>

	* generic/tclIO.c: Moved Tcl_{Cut,Splice}Channel to
	  {Cut,Splice}Channel for internal use, and created new public
	  functions for Tcl_{Cut,Splice}Channel which walk the whole stack
	  of transformations and invoke the necessary thread actions.
	  Added code to Tcl_(Un)StackChannel to properly invoke the thread
	  actions when pushing and popping transformations on/from a
	  channel.

2005-08-26  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (NamespaceEnsembleCmd): Reset the result after
	creating an ensemble to clear any result object sharing (potentially
	caused by delete traces) so that we can safely return the name of the
	ensemble. Previously, this caused crashes in Snit's test suite.

2005-08-25  Donal K. Fellows  <[email protected]>

	* generic/tclListObj.c (UpdateStringOfList): Stop uncontrolled and
	unsafe crashes from happening when working with very large string
	representations. [Bug 1267380]

	* generic/tclExecute.c (TEBC:INST_DICT_LAPPEND): Stop dropping a
	duplicated object on the floor, which was a memory leak (and a wrong
	result too). Thanks to Andreas Kupries for reporting this.

2005-08-25  Don Porter  <[email protected]>

	[kennykb-numerics-branch] Merge updates from HEAD

	* generic/tclExecute.c: Bug fix.  INST_RSHIFT: shift of negative
	values produced incorrect results.

	* generic/tclExecute.c:	Bug fix.  INST_*SHIFT opcodes stack
	management. [expr 0<<6] should be 0, not 6.

	* generic/tclBasic.c:	Extended the domain of round(.) to all
	non-Inf, non-NaN doubles, using bignums for the result as needed.

2005-08-24  Andreas Kupries <[email protected]>

	TIP#219 IMPLEMENTATION

	* doc/SetChanErr.3: ** New File **. Documentation of the new
	  channel API functions.
	* generic/tcl.decls:  Stub declarations of the new channel API.
	* generic/tclDecls.h: Regenerated
	* generic/tclStubInit.c:

	* tclIORChan.c: ** New File **. Implementation of the reflected
	  channel.
	* generic/tclInt.h: Integration of reflected channel and new error
	* generic/tclIO.c:  propagation into the generic I/O core.
	* generic/tclIOCmd.c:
	* generic/tclIO.h:
	* library/init.tcl:

	* tests/io.test:    Extended testsuite.
	* tests/ioCmd.test:
	* tests/chan.test:
	* generic/tclTest.c:
	* generic/tclThreadTest.c:

	* unix/Makefile.in: Integration into the build machinery.
	* win/Makefile.in:
	* win/Makefile.vc:

2005-08-24  Kevin Kenny  <[email protected]>

	* generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of
	* tests/binary.test (binary-65.*)         formatting floating
	point numbers with the largest and smallest possible significands,
	and added test cases for them.

2005-08-24  Kevin Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c: Corrected some TRACE bugs that prevented
	compilation with --enable-symbols=all.
	* generic/tclStrToD.c: Revised commentary to prepare for a
	renaming of the file, removed some dead code, and fixed a bug
	where TclBignumToDouble failed on huge negative numbers.
	* tests/binary.test (binary-65.*): Added missing 'ieeeFloatingPoint' to
	large/small significand tests.
	* tests/expr.test (expr-45.*) Added missing braces around expressions.
	
2005-08-24  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclBasic.c:	Revised implementation of the ceil(.) and
	* generic/tclInt.h:	floor(.) math functions in light of the
	* generic/tclStrToD.c:	revised comparison operators, so that it
	is always true that ($x <= ceil($x)) and ($x >= floor($x)).  The	
	simple approach of "convert to double and call ceil() or floor()"
	could not guarantee that.

	* generic/tclExecute.c:	Bug fix: TclBignumToDouble return -Inf when
	appropriate.  Removed declarations of removed routines.

	* generic/tclExecute.c:	Revised the type promotion rules of the
	comparison operators so that they form proper equivalence classes
	over the set of numeric strings.

2005-08-23  Mo DeJong  <[email protected]>

	* unix/configure.in:
	* win/configure: Regen.
	* win/configure.in: Update minimum autoconf version
	to 2.59.

2005-08-23  Kevin Kenny  <[email protected]>

	[kennykb-numerics-branch]
	
	* generic/tclCmdMZ.c (Tcl_StringObjCmd):
	* generic/tclInt.h:
	* generic/tclObj.c (Tcl_GetBooleanFromObj, SetDoubleFromAny,
	Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetBignumFromObj):
	* generic/tclParseExpr.c (GetLexeme):
	* generic/tclScan.c (Tcl_ScanObjCmd):
	* generic/tclStrToD.c (TclParseNumber):
	* tests/binary.test (binary-62.1-65.7):
	* tests/expr.test (expr-40.1-42.1):
	* scan.test (scan-14.1,14.2):
	Modified Tcl_ParseNumber to accept an argument to force
	interpretation as decimal, and modified [scan] to use it.
	Corrected a bug where Not a Number with hexadecimal information
	bits returned consistently incorrect values. #ifdef-ed out
	some code that is needed only for IBM hexadecimal floating point.
	Fixed bugs in code to handle the corner cases of smallest and
	largest significands.  Added test cases to improve test coverage
	in generic/tclStrToD.c.	Added test cases for 0b notation (TIP
	#114).  Removed TclStrToD, and the static functions that it calls,
	which are now dead code (TclParseNumber	now does all input 
	floating-point conversions.)
	
2005-08-23  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclStrToD.c:	Bug fix: set shift magnitude properly whether
	we're expanding to mp_int type or not.

	* generic/tclExecute.c:	Bug fix: ACCEPT_NAN under INST_UMINUS.

	* generic/tclStrToD.c:	New macros TIP_114_FORMATS and KILL_OCTAL to
	configure acceptance of 0o and 0b numbers and rejection of "leading
	zero as octal".

	* generic/tclBasic.c:	Re-used the guts of int(.) and wide(.) math
	functions to perform conversions in OldMathFuncProc.

	* generic/tclBasic.c:	Support for ACCEPT_NAN.
	* generic/tclExecute.c:

	* generic/tclInt.decls:	Restored TclExprFloatError to internal stubs
	* generic/tclBasic.c:	table, and moved definition back to tclExecute.c
	* generic/tclExecute.c:	from tclBasic.c to handle #undef ACCEPT_NAN.

	* generic/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:

	* generic/tclInt.h:	New internal macros TclIsNaN and TclIsInfinite
	* generic/tclBasic.c:	replace the IS_NAN and IS_INF macros scattered
	* generic/tclExecute.c:	here and there.
	* generic/tclObj.c:
	* generic/tclStrToD.c:
	* generic/tclUtil.c:

2005-08-22  Daniel Steffen  <[email protected]>

	* unix/tclConfig.h.in: autoheader-2.59.

2005-08-22  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclInt.h:	New ACCEPT_NAN macro to mark code that supports
	* generic/tclCmdAH.c:	or disables accepting of the NaN value at 
	* generic/tclExecute.c:	various points.
	* generic/tclLink.c:

	* generic/tclStrToD.c:	Bug fix.  Parsing of +/- Infinity was reversed.

	* generic/tclTestObj.c:	Disabled unused [testconvertobj] command.

	* generic/tclBasic:	Added [expr {entier(.)}].  Rewrote int(.)
	and wide(.) to use the same guts, accepting all non-Inf doubles as
	arguments.

	* generic/tclInt.h:	New routine TclInitBignumFromDouble.
	* generic/tclStrToD.c:	Modified to return code and write error message.

	* generic/tclInt.h:	TCL_WIDE_INT_IS_LONG implies NO_WIDE_TYPE.
	* generic/tclObj.c:	Removed now unnecessary tests of the
	* generic/tclStrToD.c:	TCL_WIDE_INT_IS_LONG definition.

	* generic/tclInt.h:	New internal routine TclSetBignumIntRep
	* generic/tclObj.c:	consolidates packing of bignum value into
	* generic/tclStrToD.c:	a Tcl_Obj within one source code file.

	* tests/expr.test:	Corrected the wideIs64bit constraint.
	* tests/format.test:
	* tests/scan.test:

2005-08-21  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclInt.h:		Moved TclParseInteger to tclUtil.c
	* generic/tclParseExpr.c:	and made it static.
	* generic/tclUtil.c:

	* generic/tclInt.decls:	Moved TclExprFloatError to tclBasic.c and
	* generic/tclBasic.c:	made it static.
	* generic/tclExecute.c:

	* generitc/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:

	* generic/tclExecute.c:	errno, IS_NAN, IS_INF, LLD no longer called in
	this file; dropped/disabled support for them.

	* generic/tclCompExpr.c:	errno no longer used in these files;
	* generic/tclParseExpr.c:	dropped support "hack" for it.

	* generic/tclStrToD.c:	Disabled out of date support "hack" for errno.

	* generic/tclBasic.c:	Eliminated VerifyExprObjType.  Initialize
	errno to zero in OldMathFuncProc.

2005-08-19  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclBasic.c:	Updated OldMathFuncProc and ExprAbsFunc to
	do less invasion into numeric Tcl_Obj internals.  Made ExprDoubleFunc,
	ExprIntFunc, ExprWideFunc, and ExprRoundFunc bignum-aware.  Revised
	ExprSrandFunc error message.

	* generic/tclProc.c:	Wrapped a few tclWideIntType uses in 
	* generic/tclCmdMZ.c:	#ifndef NO_WIDE_TYPE.

	* generic/tclInt.h:	#define'd NO_WIDE_TYPE.

	* generic/tclVar.c:	Replaced TclPtrIncrVar and TclPtrIncrWideVar
	* generic/tclInt.h:	with TclPtrIncrObjVar and replaced TclIncrVar2
	* generic/tclInt.decls:	and TclIncrWideVar2 with TclIncrObjVar2.  New
	routines call on TclIncrObj to do the work.

	* generic/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:

	* generic/tclCmdIL.c:	Rework Tcl_IncrObjCmd and the INST_*INCR*
	* generic/tclExecute.c:	opcodes to use the new routines.

2005-08-18  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:		Fixed string rep invalidation bug in
	* tests/dict.test (dict-11.17):	INST_DICT_INCR_IMM rewrite.

	* generic/tclDictObj.c:	DictIncrCmd rewrite to use TclIncrObj.

	* generic/tclInt.h:	TclIncrObj static -> internal
	* generic/tclExecute.c:

2005-08-17  George Peter Staplin <[email protected]>

	* generic/tclBasic.c: eliminate a namespace clash caused by
	BuiltinFuncTable not being static.

	* generic/tclObj.c: fix a namespace clash caused by a missing
	static for pendingObjData.

2005-08-17  Kevin Kenny  <[email protected]>

	* generic/tclEvent.c (Tcl_Finalize): Removed a copy-and-paste
	accident that caused a (mostly harmless) double finalize of the
	load and filesystem subsystems.
	* tests/clock.test: Eliminated the bad test clock-43.1, and split
	clock-50.1 into two tests, with a more permissive check on the
	error message for an out-of-range value.

2005-08-17  Kevin Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclBasic.c (Tcl_Expr{Long,Double}{,Obj}): Updated to
	* generic/tclTest.c:                                deal with
	* tests/expr-old.test:                              bignums (well, 
	* tests/expr.test:                                  mostly).
	Added a missing "errno=0;" in ExprUnaryFunc so that spurious
	error returns aren't detected. 
	Added test cases for Tcl_Expr* and Tcl_Expr*Obj because
	there was very poor test coverage in those areas.
	* generic/tclParseExpr.c: Reworked parsing of numbers to call
	TclParseNumber rather than trying to do things locally.
	* generic/tclStrToD.c: Corrected a comment. Changed so that
	*endPtrPtr does not include any trailing whitespace.
	
2005-08-17  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	New routine TclIncrObj to centralize the
	increment operation needed in many places.  Updated
	INST_DICT_INCR_IMM to make use of it.

2005-08-16  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Made bit shifting opcodes and INST_MOD
	bignum-aware.

	* tests/scan.test:	Making << bignum-aware means that repeated
	* tests/string.test:	left shifting cannot turn a positive into
	a negative.  Revised [int_range] and [largest_int] utility commands
	in the test suite that relied on that happening.  Without revision
	they became infinite loops.

	* generic/tclExecute.c:	Made binary bitwise opcodes bignum-aware.

	* generic/tclTomMath.h:	Added mp_or and mp_xor to routines from
	* unix/Makefile.in:	libtommath used by Tcl.
	* win/Makefile.in:
	* win/makefile.vc:

2005-08-15  Don Porter  <[email protected]>

	[kennykb-numerics-branch]	Updates from HEAD.
	* generic/tclExecute.c:	More revisions to IllegalExprOperandType.
	Merged INST_BITNOT with INST_UMINUS and make it bignum-aware
	according to the rule: ~a = -a - 1.  Disabled unused code and
	noted more TODOs.

	* generic/tclInt.decls: Disabled TclLooksLikeInt() and all callers.
	* generic/tclUtil.c:
	* generic/tclCompCmds.c:

	* generic/tclBasic.c:	Rewrite of VerifyExprObjType().

	* generic/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:

	* generic/tclExecute.c:	Updated execution of comparison bytecodes
	to be bignum-aware, routing string compares through INST_STR_CMP.

2005-08-14  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Updated execution of arithmetic bytecodes
	to be bignum-aware, and to allow calculations on NaN to produce
	a NaN result.  INST_UMINUS updated to call mp_neg.

	* generic/tclTomMath.h:	Added mp_and, mp_expt_d, and mp_neg to
	* unix/Makefile.in:	routines from libtommath used by Tcl.
	* win/Makefile.in:
	* win/makefile.vc:

2005-08-13  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	Extended Bignum auto-narrowing to auto-narrow
	to tclWideIntType when appropriate; this helps keep things working as
	the bytecode execution code is migrated to supporting bignums.

	* generic/tclExecute.c:	Major overhaul of IllegalExprOperandType.
	Changed several TclNewFooObj() calls to more logically appropriate
	ones.  Added several TODO comments marking opportunies for future
	work.  Made more use of the eePtr->constants.  Made INST_UMINUS
	bignum aware.

2005-08-12  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Simplify doCondJump.  Use eePtr->constants
	as result of INST_DICT_NEXT, INST_LAND, and INST_LOR.  Separate
	INST_LNOT from INST_UMINUS and simplify.

2004-08-12  Kevin Kenny  <[email protected]>

	* generic/tclClock.c (MktimeObjCmd):
	* library/clock.tcl (GetSystemTimeZone, LoadZoneinfoFile,
	ReadZoneinfoFile):
	* tests/clock.test (clock-50.1):
	Added functionality to read /etc/localtime if it exists, so that
	Tcl's time can track system time on Linux even if TZ is not set.
	Changed ::tcl::clock::Mktime to check for failure, and added a
	test case that mimics failure but is really success.
	
2005-08-11  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Rewrite of INST_LAND/INST_LOR to take
	advantage of loss of "pure double" issues.  Merged INST_UPLUS
	with INST_TRY_CVT_TO_NUMERIC and updated to use improved rules
	for impure "double"s as well.

	* generic/tclStrToD.c:	Restored conditional generation of
	tclWideIntType values by TclParseNumber so that Tcl's not
	completely broken while bignum calculation support is incomplete.
	The NO_WIDE_TYPE macro can be used to disable this.

	* generic/tclBasic.c (ExprAbsFunc):	First pass making [expr abs(.)]
	bignum-aware.

2004-08-11  Kevin Kenny  <[email protected]>

	* generic/tclEvent.c:          Eliminated the USE_THREAD_STORAGE
	* generic/tclInt.h:            option (which is on in every build
	* generic/tclThread.c:         generated by the standard configurator).
	* generic/tclThreadStorage.c:  Eliminated the code for thread
	* unix/configure:              specific data without USE_THREAD_STORAGE
	* unix/tcl.m4:                 and radically refactored the code
	* unix/tclConfig.h.in:         for USE_THREAD_STORAGE so that it
	* unix/tclUnixThrd.c:          has fewer dependencies on the order
	* win/configure:               of finalization.  (Also, made
	* win/Makefile.in:             'make distclean' on Windows clean
	* win/rules.vc:                just a little bit cleaner.)
	* win/tcl.m4:
	* win/tclWinThrd.c:
	
2005-08-10  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclTomMath.h:	Added mp_shrink, mp_to_unsigned_bin,
	* unix/Makefile.in:	mp_to_unsigned_bin_n, and mp_unsigned_bin_size
	* win/Makefile.in:	to routines from libtommath used by Tcl.
	* win/makefile.vc:

	* generic/tommath.h:	make gentommath_h

	* generic/tclObj.c:	Substantial rewrite to make all number
	parsing flow through TclParseNumber().  Also established the
	NO_WIDE_TYPE and BIGNUM_AUTO_NARROW #ifdef's to help track the
	assumptions of different portions of the code.

	* generic/tclInt.h:	Added NO_WIDE_TYPE #ifdefs

2005-08-10  Kevin Kenny  <[email protected]>

	* generic/tclEvent.c (Tcl_Finalize): Pushed Tcl_FinalizeLoad and
	Tcl_ResetFilesystem down after Tcl_FinalizeThreadAlloc because
	we can't unload DLL's until after their TSD keys are finalized.
	(Note that we'll still see aborts if an unloaded DLL has TSD -
	that still needs to be fixed.

	* tests/compExpr-old.test (compExpr-3.8): Made tests conditional on
	* tests/expr.test (expr-3.8):             'unix' because they get
	                                          stack overflows on Win32
	                                          threaded builds,

2005-08-09  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix to [file rootname] bug in optimized
	code path reported on comp.lang.tcl.

2005-08-08  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	Replaced some goto's with loops and started
	use of BIGNUM_AUTO_NARROW and NO_WIDE_TYPE.

2005-08-06  Donal K. Fellows  <[email protected]>

	* generic/tclThreadStorage.c: Stop exposing the guts of the thread
	storage system through the internal stubs table. Client code
	should always use the standard API.

2005-08-05  Don Porter  <[email protected]>

	[kennykb-numerics-branch]
	* generic/tclObj.c:	Rewrote Tcl_GetDoubleFromObj().

2005-08-05  Donal K. Fellows  <[email protected]>

	* unix/tclUnixInit.c (localeTable): Solaris uses a non-standard
	name for the cp1251 charset. Thanks to Victor Wagner for reporting
	this. [Bug 1252475]

2005-08-05  Kevin Kenny  <[email protected]>

	* win/makefile.vc: Removed unused file ldAout.tcl.
	* win/makefile.bc: [Bug #1244361]

	* tests/binary.test: Cleaned up testing for scanning of NaN.
			     [Bug #1246264]

	* generic/tclBasic.c (ExprAbsFunc): Added code to handle the
	* tests/expr.test (expr-38.1):      corner case of applying
	'abs' to the smallest 32-bit integer. [Bug #1241572]

2005-08-04  Andreas Kupries <[email protected]>

	* generic/tclIO.c (CloseChannel): Fixed comment nit, added
	  apparently missing word to complete a sentence.

	* generic/tclObj.c (Tcl_DbDecrRefCount): Fixed whitespace nit in
	  panic message.

2005-08-04  Don Porter  <[email protected]>

	[kennykb-numerics-branch] Updated from HEAD

	* generic/tclObj.c:	Rewrote Tcl_GetBooleanFromObj() and supporting
	routines to make use of TclParseNumber.  This reduces the potential
	number of times a string value must be scanned.

	* generic/tclObj.c:	Simplified routines that manage the typeTable.
	Deleted the UpdateStringOfBoolean() routine, that can never be called.

2005-08-03  Don Porter  <[email protected]>

	* generic/tclCompExpr.c:	Untangled some dependencies in the
	* generic/tclEvent.c:		order of finalization routines.
	* generic/tclInt.h:		[Bug 1251399]
	* generic/tclObj.c:

2005-08-02  Don Porter	<[email protected]>

	[kennykb-numerics-branch] Updated from HEAD

2005-07-30  Daniel Steffen  <[email protected]>

	* unix/tclLoadDyld.c (TclpDlopen, TclpLoadMemory): workarounds
	for bugs/changes in behaviour in Mac OS X 10.4 Tiger.

2005-07-29  Donal K. Fellows  <[email protected]>

	* generic/tclCmdIL.c (InfoGlobalsCmd): Even in high-speed mode,
	still have to take care with non-existant variables. [Bug 1247135]

2005-07-28  Mo DeJong  <[email protected]>

	* win/README: Update link to msys_mingw8.zip.

2005-07-28  Don Porter	<[email protected]>

	* tests/compExpr-old.test:	Still more conversion of "nonPortable"
	* tests/error.test:		tests into tests with constraints that
	* tests/expr-old.test:		describe the limits of their
	* tests/expr.test:		portability.  Also more consolidation
	* tests/fileName.test:		of constraint synonyms.
	* tests/format.test:		wideis64bit, 64bitInts => wideIs64bit
	* tests/get.test:		wideIntegerUnparsed => wideIs32bit
	* tests/load.test:		wideIntExpressions => wideBiggerThanInt
	* tests/obj.test:
	* tests/parseExpr.test:		Dropped "roundOffBug" constraint that
	* tests/string.test:		protected from buggy sprintf.

2005-07-28  Donal K. Fellows  <[email protected]>

	* generic/tclPipe.c (TclCreatePipeline): Arrange for POSIX systems to
	* unix/tclUnixPipe.c (TclpOpenFile):	 use the O_APPEND flag for
	* tests/exec.test (exec-19.1):		 files opened in a pipeline
	like ">>this".	Note that Windows cannot support such access; there is
	no equivalent flag on the handle that can be set at the kernel-call
	level. The test is unix-specific in every way. [Bug 1245953]

2005-07-27  Don Porter	<[email protected]>

	* generic/tclUtil.c:	Converted the $::tcl_precision value to be
	kept per-thread to prevent different threads from stomping on each
	others' formatting prescriptions.

	***POTENTIAL INCOMPATIBILITY*** Multi-threaded programs that set
	the value of ::tcl_precision will now have to set it in each thread.

	* tests/expr.test:	Consolidated equivalent constraints into
	* tests/fileName.test:	single definitions and (more precise) names:
	* tests/get.test:	longis32bit, 32bit, !intsAre64bit => longIs32bit
	* tests/listObj.test:	empty => emptyTest; winOnly => win
	* tests/obj.test:	intsAre64bit => longIs64bit
	Also updated some "nonPortable" tests to use constraints that mark
	precisely what about them isn't portable, so the tests can run where
	they work.

	* library/init.tcl ([unknown]):	Corrected return code handling
	in the portions of [unknown] that expand incomplete commands
	during interactive operations.	[Bug 1214462].

2005-07-26  Mo DeJong  <[email protected]>

	* unix/configure: Regen.
	* unix/configure.in: Check for a $prefix/share
	directory and add it the the package if found.
	This will check for Tcl packages in /usr/local/share
	when Tcl is configured with the default dist install.
	[patch 1231015]

2005-07-26  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_CallWhenDeleted):	Converted to use
	per-thread counter, rather than a process global one that required
	mutex protection.  [RFE 1077194]

	* generic/tclNamesp.c (TclTeardownNamespace):	Re-ordering so that
	* tests/trace.test (trace-34.4):	command delete traces fire
	while the command still exists.	 [Bug 1047286]

2005-07-24  Mo DeJong  <[email protected]>

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH):
	* win/configure: Regen.
	* win/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH):
	Split confused search for tclsh on PATH and
	build and install locations into two macros.
	SC_PROG_TCLSH searches just the PATH.
	SC_BUILD_TCLSH determines the name of the tclsh
	executable in the Tcl build directory.
	[Tcl bug 1160114]
	[Tcl patch 1244153]

2005-07-23  Don Porter	<[email protected]>

	* library/auto.tcl:	Updates to the Tcl script library to make
	* library/history.tcl:	use of Tcl 8.4 features.  Forward port of
	* library/init.tcl:	appropriate portions of [Patch 1237755].
	* library/package.tcl:
	* library/safe.tcl:
	* library/word.tcl:

2005-07-23  Mo DeJong  <[email protected]>

	* tests/string.test: Add string is tests for
	functionality that was not tested.
	* win/README: Update msys + mingw URL.
	Remove old Cygwin + mingw info.

2005-07-23  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (INST_DICT_*): stop 2 compiler
	warnings for uninitialised variables.

2005-07-23  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TEBC:INST_DICT_INCR_IMM): Fix the
	incrementor to work correctly with wide values.

2005-07-21  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileDictCmd): First run at a compiler
	* generic/tclExecute.c (TclExecuteByteCode): for dictionaries.
	Also added an instruction to support 'finally'-like clauses, exposed
	more of the dict guts to the rest of the core, and defined a few
	tests to exercise more obscure parts of the compiler's operation that
	were bugs during development.

2005-07-21  Kevin B. Kenny  <[email protected]>

	* library/ldAout.tcl (***REMOVED***):	Removed support for ancient
	* unix/configure:			BSD's, IRIX 4, RISCos and
	* unix/Makefile.in:			Ultrix.	 Removed two files
	* unix/tcl.m4:				whose code is used only on
	* unix/tclLoadAout.c (***REMOVED***):	those antique platforms.

	***POTENTIAL INCOMPATIBILITY*** if anyone actually uses those
	platforms; it is to be noted though, that an error in the
	installer has actually not caused a necessary file to be installed
	on those platforms in several releases, and nobody's complained.

2005-07-16  Kevin B. Kenny  <[email protected]>

	* generic/tclStrToD.c (RefineResult):  Plugged a stupid memory
	leak in RefineResult (called from Tcl_StrToD).	[Tk Bug 1227781]

2005-07-15  Kevin B. Kenny  <[email protected]>

	* generic/tclClock.c (TclClockLocaltimeObjCmd,ThreadSafeLocalTime):
	* library/clock.tcl (GuessWindowsTimeZone, ClearCaches):
	* tests/clock.test (clock-49.1, clock-49.2):
	Handle correctly the case where localtime() returns NULL to
	report a conversion error.  Also handle the case where the Windows
	registry contains timezone values that can be mapped to a tzdata
	file name but the corresponding file does not exist or is
	corrupted, by falling back on a Posix timezone string instead;
	this last case will avoid calls to localtime() in starpacks on
	Windows. [Bug 1237907]

2005-07-14  Donal K. Fellows  <[email protected]>

	* generic/tclCompile.c: Update to follow style guidelines.
	(TclPrintInstruction): Reorganize to do better printing out of
	bytecode with far fewer "special hacks" for particular opcodes.
	* generic/tclCompile.h: Requires two new opcode types.

2005-07-13  Don Porter	<[email protected]>

	* unix/tclUnixSock.c:	Use a ProcessGlobalValue to store the
	* win/tclWinSock.c:	value returned by Tcl_GetHostName()
	([info hostname]).  Also re-order initialization of the value
	on Windows to favor GetComputerName() over gethostname() as
	a source of the information.

2005-07-12  Kevin Kenny  <[email protected]>

	[kennykb-numerics-branch] Updated from HEAD

	* generic/tclCmdMZ.c (Tcl_StringObjCmd):
	* generic/tclInt.h:
	* generic/tclObj.c (Tcl_GetDoubleFromObj, SetDoubleFromAny,
	                    Tcl_GetIntFromObj, SetIntOrWideFromAny):
	* generic/tclStrToD.c (TclParseNumber, etc.):
	* tclTomMathInterface.c (TclBNInitBignumFromWideUInt):
	* tests/obj.test (obj-1.1, obj-2.2, obj-3.1, obj-3.2):
	
	Initial attempt at an implementation of TIP #249, comprising
	a unified parser and modifications to the Tcl_Get*FromObj
	routines to use it.  Further integration of the parser is
	necessary and planned.
	
2005-07-12  Donal K. Fellows  <[email protected]>

	* doc/lsearch.n: Clarify documentation of -exact option; wording was
	open to misinterpretation by non-English speakers.

2005-07-11  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c: General style cleanup.

2005-07-08  Mo DeJong  <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): Reimplement long and wide
	type integer division and modulus operations so that the smallest and
	largest integer values are handled properly.  The divide operation is
	more efficient since it no longer does a modulus or negation and only
	checks for a remainder when the quotient will be a negative number.
	The modulus operation is now a bit more complex because of a number of
	special cases dealing with the smallest and largest integers.
	* tests/expr.test: Add test cases for division and modulus operations
	on the smallest and largest integer values for 32 and 64 bit types.
	[Patch 1230205]

2005-07-06  Don Porter	<[email protected]>

	* generic/tclLink.c:	Simplified LinkTraceProc [Bug 1208108].

2005-07-05  Don Porter	<[email protected]>

	* unix/Makefile.in:	Purged use of TCLTESTARGS [RFE 1161550].

	* generic/tclUtil.c:	Converted TclFormatInt() into a macro.
	* generic/tclInt.decls:	[RFE 1194015]
	* generic/tclInt.h:

	* generic/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:

	* generic/tclNamesp.c:	Allow for [namespace import] of a command
	* tests/namespace.test:	over a previous [namespace import] of itself
	without throwing an error.  [RFE 1230597]

2005-07-04  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (DictForCmd, DictFilterCmd): Interlocking of
	dictionary internal representations is now done in the core of the
	dict iterator. Purge the last attempts at doing it at a higher level
	as they didn't work and were no longer needed.

2005-07-01  Zoran Vasiljevic <[email protected]>

	* unix/tclUnixNotfy.c: protect against spurious wake-ups while
	waiting on the condition variable when tearing down the notifier
	thread [Bug# 1222872].

2005-06-28  Mo DeJong  <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): When parsing an integer
	operand for a unary minus expression operator, check for a wide
	integer that is actually LONG_MIN. If found, convert it back to a long
	int type.
	* tests/expr.test: Add constraint for 32bit long int type and 64bit
	wide int type. Add tests that parse the smallest/largest long int and
	wide int values.

2004-06-24  Kevin Kenny	 <[email protected]>

	* generic/tclEvent.c (Tcl_Finalize):
	* generic/tclInt.h:
	* generic/tclPreserve.c (TclFinalizePreserve): Changed the
	finalization logic so that Tcl_Preserve finalizes after exit handlers
	run; a lot of code called from Tk's exit handlers presumes that
	Tcl_Preserve will still work even from an exit handler.

2005-06-24  Don Porter	<[email protected]>

	* library/auto.tcl:	Make file safe to re-[source] without
	destroying registered auto_mkindex_parser hooks.

2005-06-23  Kevin Kenny	 <[email protected]>

	* win/tclWinChan.c: More rewriting of __asm__ blocks that implement
	* win/tclWinFCmd.c: SEH in GCC, because mingw's gcc 3.4.2 is not as
	forgiving of violations committed by the old code and caused panics.
	[Bug #1225957]

2005-06-23  Daniel Steffen  <[email protected]>

	* tools/tcltk-man2html.tcl: fixed useversion glob pattern to accept
	multi-digit patchlevels.

2005-06-22  Don Porter	<[email protected]>

	* win/tclWinFile.c: Potential buffer overflow.	[Bug 1225571]
	Thanks to Pat Thoyts for discovery and fix.

2005-06-22  Kevin Kenny <[email protected]>

	* generic/tclInt.h:			    Changed the finalization
	* generic/tclEvent.c (Tcl_Finalize):	    logic to defer the
	* generic/tclIO.c (TclFinalizeIOSubsystem): shutdown of the pipe
	* unix/tclUnixPipe.c (TclFinalizePipes):    management until after
	* win/tclWinPipe.c (TclFinalizePipes):	    all channels have been
	closed, in order to avoid a situation where the Windows PipeCloseProc2
	would re-establish the exit handler after exit handlers had already
	run, corrupting the heap. [Bug #1225727]
	Also corrected a potential read of uninitialized memory in
	PipeClose2Proc [Bug #1225044]

2005-06-21  Andreas Kupries <[email protected]>

	* generic/tclInt.h: Followup to change made on 2005-06-18 by Daniel
	Steffen. There are compilers (*) who error out on the redefinition of
	WORDS_BIGENDIAN. We have to undef the previous definition (on the
	command line) first to make this acceptable. (*): AIX native.

2005-06-21  Kevin B. Kenny  <[email protected]>

	* generic/tclFileName.c: Changed [file split] and [file join] to treat
	Windows drive letters similarly to ~ syntax and make sure that they
	appear with "./" in front when they are in intermediate components of
	the path. [Bug 1194458]
	* tests/fileName.test: Added test for the above bug.

2005-06-21  Don Porter	<[email protected]>

	* generic/tclBasic.c:	Added missing walk of the list of active traces
	* generic/tclTrace.c:	to cleanup references to traces being deleted.
	* generic/tclInt.h:	[Bug 1201035] Made the walk of the active trace
	* tests/trace.test (trace-34.*): list aware of the direction of trace
	scanning, so the proper correction can be made. [Bug 1224585]

2005-06-21  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_ENABLE_SYMBOLS): Only enable the 'compile' special
	debugging feature when requested in configure.in; removes irrelevant
	junk from the configure files of extensions that use Tcl's tcl.m4.

2005-06-20  Donal K. Fellows  <[email protected]>

	* generic/tclCompile.h (INST_PUSH_RETURN_OPTIONS): New opcode to allow
	* generic/tclCompCmds.c (TclCompileCatchCmd):	   compilation of TIP90
	* generic/tclCompile.c:				   catch [Bug 1219112]
	* generic/tclExecute.c (TclExecuteByteCode):

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Ensure we spill to the
	command form in all cases where it generates an error.

2005-06-20  Mo DeJong  <[email protected]>

	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Generate an error if a mode
	argument like -exact is passed more than once to the switch command.
	The previous implementation silently accepted invalid switch
	invocations like [switch -exact -glob $str ...].
	* tests/for.test: Check some error cases when invoking continue and
	break inside a for loop next script.
	* tests/switch.test: Add checks for shortened version of a mode
	argument like -exact. Add test for more than one mode argument. Add
	test for odd case of passing a variable as a body script.

2005-06-18  Daniel Steffen  <[email protected]>

	* generic/tclInt.h: ensure WORDS_BIGENDIAN is defined correctly with
	fat compiles on Darwin (i.e. ppc and i386 at the same time), the
	configure AC_C_BIGENDIAN check is not sufficient in this case because
	a single run of the compiler builds for two architectures with
	different endianness.

	* unix/tcl.m4 (Darwin): add -headerpad_max_install_names to LDFLAGS to
	ensure we can always relocate binaries with install_name_tool.

	* unix/configure: autoconf-2.59

2005-06-18  Donal K. Fellows  <[email protected]>

	* generic/tclCmdAH.c (Tcl_FormatObjCmd): Fix for [Bug 1154163]; only
	* tests/format.test: insert 'l' modifier when it is needed.

2005-06-17  Donal K. Fellows  <[email protected]>

	* generic/tclTimer.c (AfterDelay): Split out the code to manage
	synchronous-delay [after] commands.
	* tests/interp.test (interp-34.10): Time limits and synch-delay
	[after] did not mix well... [Bug 1221395]

2005-06-14  Donal K. Fellows  <[email protected]>

	* generic/tclBasic.c (Tcl_DeleteCommandFromToken): Only delete a
	* tests/namespace.test (namespace-49.2): command from the hashtable on
	reentrant processing if it has not been already deleted; at least
	three deletes of the same command are possible. [Bug 1220058]
	* generic/tclTrace.c (TraceCommandProc): Remove bogus error message
	creation when traces trigger in situations where the command has
	already been deleted.

2005-06-13  Vince Darley  <[email protected]>

	* generic/tclFCmd.c: correct fix to file mkdir 2005-06-09, [Bug 1219176]

2005-06-12  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c: Factor out some common idioms into named
	forms for greater clarity.

2005-06-10  Donal K. Fellows  <[email protected]>

	* doc/chan.n: Fold in the descriptive parts of the documentation
	for all the commands that [chan] builds on top of.

2005-06-09  Vince Darley  <[email protected]>

	* generic/tclFCmd.c: fix to race condition in file mkdir [Bug 1217375]
	* doc/glob.n: improve glob documentation [Bug 1190891]

2005-06-09  Donal K. Fellows  <[email protected]>

	* doc/expr.n, doc/mathfunc.n: Fix minor typos [Bug 1211078] and
	add mention of distinctly-relevant [namespace path] subcommand.

2005-06-07  Don Porter	<[email protected]>

	* generic/tclInt.h:		Reduced the Tcl_ObjTypes "index",
	* generic/tclIndexObj.c:	"ensembleCmd", "localVarName", and
	* generic/tclNamesp.c:		"levelReference" to file static scope.
	* generic/tclProc.c:
	* generic/tclVar.c:

	* generic/tclObj.c:	Restored registration of the "procbody"
	Tcl_ObjType, as required by the tclcompiler application.

	* generic/tclDecls.h:		make genstubs
	* generic/tclStubInit.c:

2005-06-07  Donal K. Fellows  <[email protected]>

	* generic/tclIO.c (Tcl_ChannelTruncateProc): Stop proliferation of
	* generic/tcl.h:			     channel type versions
	* doc/CrtChannel.3:			     following advice from AKu

	Bump patchlevel to a4 to distinguish from a3 release.

	* generic/tclInt.h (INTERP_TRACE_IN_PROGRESS): Add flag so the error
	* generic/tclIndexObj.c (Tcl_WrongNumArgs):    messages from ensembles
	* generic/tclIOCmd.c (Tcl_ReadObjCmd):	       can be correct.

	TIP#208 IMPLEMENTATION

	* library/init.tcl: Create the chan ensemble.
	* tests/chan.test: Rudimentary test suite.
	* doc/chan.n: General documentation.

	TRUNCATION API (part of TIP#208)
	* generic/tcl.h, generic/tcl.decls: Declaration of the API.
	* doc/CrtChannel.3, doc/OpenFileChnl.3: Documentation of the API.
	* generic/tclBasic.c (Tcl_CreateInterp): Create the mapping into Tcl.
	* generic/tclIOCmd.c (TclChanTruncateObjCmd): Implementation of
	Tcl-level truncation API.
	* generic/tclIO.c (Tcl_TruncateChannel): Generic C-level
	truncation API implementation.
	* unix/tclUnixChan.c (FileTruncateProc): Basic implementation of
	truncating driver.

	* win/tclWinChan.c (FileTruncateProc): Added implementation of
	file truncation for Windows.
	* tests/chan.test (chan-15.2): Added real test of truncation.

2005-06-06  Kevin B. Kenny  <[email protected]>

	* win/tclWin32Dll.c: Corrected another buglet in the assembly code for
	stack probing on Win32/gcc. [Bug #1213678]
	* generic/tclObj,c: Added missing 'static' on definition of
	UpdateStringOfBignum, and removed a 'switch' on a 'long long' operand
	(which HP-UX native 'cc' seems unable to handle). [Bug #1215775]

2005-06-04  Jeff Hobbs	<[email protected]>

	*** 8.5a3 TAGGED FOR RELEASE ***

	* unix/Makefile.in (dist): add libtommath

2005-06-03  Donal K. Fellows  <[email protected]>

	* library/parray.tcl (parray): Only generate the sorted list of
	element names once. Thanks to Andreas Leitgeb for spotting this.

2005-06-03  Daniel Steffen  <[email protected]>

	* macosx/Makefile: fixed 'embedded' target.

2005-06-02  Jeff Hobbs	<[email protected]>

	* unix/Makefile.in (html): add BUILD_HTML_FLAGS optional var
	* tools/tcltk-man2html.tcl: add a --useversion to prevent
	confusion when multiple Tcl source dirs exist.

2005-06-01  Don Porter	<[email protected]>

	* generic/tclBasic.c:	For compatibility with earlier Tcl releases,
	* generic/tclResult.c:	when a command procedure simply does a
	* generic/tclTest.c:	"return TCL_RETURN;" we must interpret that
	* tests/result.test:	the same as
	"return Tcl_SetReturnOptions(interp, Tcl_NewObj());"  [Bug 1209759].

2005-06-01  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Allow compilation
	of -nocase -glob [switch]es (only one we know how to compile).

	TIP#241 IMPLEMENTATION from Joe Mistachkin

	* generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd):
	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Implementation of -nocase
	option for [lsearch], [lsort] and [switch] commands.
	* win/tclWinPort.h: Win uses nonstandard function names...
	* tests/cmdIL.test, tests/lsearch.test, tests/switch.test: Tests
	* doc/lsearch.n, doc/lsort.n, doc/switch.n: Docs

	* generic/tclCompCmds.c (TclCompileLindexCmd): Compile the most
	common case of [lindex] more efficiently.

	* unix/tclUnixNotfy.c (Tcl_FinalizeNotifier): Pass the correct
	number of arguments to Tcl_JoinThread.

2005-05-31  Donal K. Fellows  <[email protected]>

	* unix/configure.in, unix/tcl.m4: Standardize generation of help
	messages to always use AC_HELP_STRING and always (except for
	--with-tcl and --with-tk, where the default is complex) say what
	the default is.

2005-05-31  Zoran Vasiljevic <[email protected]>

	* unix/tclUnixNotfy.c: the notifier thread is now created as
	joinable thread and it is properly joined in Tcl_FinalizeNotifier.
	This is an attempt to fix the Tcl Bug #1082283.

2005-05-30  Zoran Vasiljevic <[email protected]>

	* win/tclWinThrd.c: Fixed Tcl Bug #1204064.

2005-05-30  Donal K. Fellows  <[email protected]>

	TIP #229 IMPLEMENTATION

	* generic/tclNamesp.c (Tcl_FindCommand, TclResetShadowedCmdRefs)
	(NamespacePathCmd, SetNsPath, UnlinkNsPath, TclInvalidateNsPath):
	Implementation of the [namespace path] command and the command
	name resolution engine.
	* doc/info.n, doc/namespace.n: Doc updates.
	* tests/namespace.test (namespace-51.*): Test updates.
	* generic/tclResolve.c (BumpCmdRefEpochs, Tcl_SetNamespaceResolvers):
	* generic/tclBasic.c (Tcl_CreateCommand, Tcl_CreateObjCommand):
	Ensure that people don't see stale paths.
	* generic/tclInt.h (Namespace, NamespacePathEntry): Structure defs.
	* generic/tclCmdIL.c (InfoCommandsCmd): Updates to [info commands].

2005-05-26  Daniel Steffen  <[email protected]>

	* macosx/Makefile: moved & corrected EMBEDDED_BUILD check.

	* unix/configure.in: corrected framework finalization to softlink
	stub library to Versions/8.x subdir instead of Versions/Current.
	* unix/configure: autoconf-2.59

2005-05-25  Jeff Hobbs	<[email protected]>

	* generic/tclCmdMZ.c (Tcl_TimeObjCmd): add necessary cast

2005-05-25  Don Porter	<[email protected]>

	TIP#182 IMPLEMENTATION	[Patch 1165062]

	* doc/mathfunc.n:	New built-in math function bool().
	* generic/tclBasic.c:
	* tests/expr.test:
	* tests/info.test:

2005-05-24  Don Porter	<[email protected]>

	* library/init.tcl:	Updated [unknown] to be sure the [return]
	* tests/init.test:	options from an auto-loaded command are
	seen correctly by the caller.

2005-05-24  Daniel Steffen  <[email protected]>

	* tests/env.test: added DYLD_FRAMEWORK_PATH to the list of env vars
	that need to be handled specially.

	* macosx/Makefile:
	* macosx/README:
	* macosx/Tcl-Info.plist.in (new file):
	* unix/Makefile.in:
	* unix/configure.in:
	* unix/tcl.m4:
	* unix/tclUnixInit.c: moved all Darwin framework build support from
	macosx/Makefile into the standard unix configure/make buildsystem, the
	macosx/Makefile is no longer required to build Tcl.framework (but its
	functionality is still available for backwards compatibility).
	* unix/configure: autoconf-2.59

	* generic/tclIOUtil.c (TclLoadFile):
	* generic/tclInt.h:
	* unix/tcl.m4:
	* unix/tclLoadDyld.c: added support for [load]ing .bundle binaries in
	addition to .dylib's: .bundle's can be [unload]ed (unlike .dylib's),
	and can be [load]ed from memory, e.g. directly from VFS without
	needing to be written out to a temporary location first. [Bug 1202209]
	* unix/configure: autoconf-2.59
	* unix/tclConfig.h.in: autoheader-2.59

	* generic/tclCmdMZ.c (Tcl_TimeObjCmd): change [time] called with a
	count > 1 to return a string with a float value instead of a rounded
	off integer. [Bug 1202178]

	* doc/expr.n:
	* doc/string.n: fixed roff syntax complaints from 'make html'.

2005-05-20  Don Porter	<[email protected]>

	* generic/tclParseExpr.c:	Corrected parser to recognize all
	boolean literals accepted by Tcl_GetBoolean, including prefixes
	like "y" and "f", and to allow "eq" and "ne" as function names
	in the proper context.	[Bug 1201589].

2005-05-19  Donal K. Fellows  <[email protected]>

	* generic/tclBasic.c (TclEvalObjvInternal): Rewrite for greater
	clarity; although 'goto' is Bad, the contortions you have to go
	through to avoid it can be worse...

2005-05-19  Daniel Steffen  <[email protected]>

	* macosx/tclMacOSXNotify.c (Tcl_InitNotifier): fixed crashing
	CFRelease of runLoopSource in Tcl_InitNotifier (reported by Zoran):
	CFRunLoopAddSource doesn't CFRetain, so can only CFRelease the
	runLoopSource in Tcl_FinalizeNotifier.

2005-05-18  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_ExprBoolean):	Rewrite as wrapper around
	Tcl_ExprBooleanObj.

	* generic/tclCmdMZ.c ([string is boolean/true/false]):	Rewrite
	dropping string-based Tcl_GetBoolean call, so that internal reps
	are kept for subsequent quick boolean operations.

	* generic/tclExecute.c:	Dropped most special handling of the
	"boolean" Tcl_ObjType, since that type should now be rarely
	encountered.

	* doc/BoolObj.3:	Rewrite of documentation dropping many details
	about the internals of Tcl_Objs.  Shorter documentation focuses on
	the function and use of the routines.

	* generic/tclInt.h:	Revision to the "boolean" Tcl_ObjType, so
	* generic/tclObj.c:	that only string values like "yes" and "false"
	* tests/obj.test:	are kept as the "boolean" Tcl_ObjType.	The
	string values "0" and "1" are kept as "int" Tcl_ObjType, which also
	produce quick calls to Tcl_GetBooleanFromObj().	 Since this internal
	change means a Tcl_ConvertToType to a "boolean" Tcl_ObjType might
	not produce a Tcl_Obj of type "boolean", the registration of the
	"boolean" type is also removed.
	***POTENTIAL INCOMPATIBILITY***
	For callers of Tcl_GetObjType on the type name "boolean".

2005-05-17  Don Porter	<[email protected]>

	* generic/tclObj.c (TclInitObjSubsystem):	Removed the
	* tests/listObj.test:	registration of the Tcl_ObjType's "list",
	* tests/obj.test:	"procbody", "index", "ensembleCommand",
	"localVarName", and "levelReference".  The only reason to register
	a Tcl_ObjType is to have it returned by Tcl_GetObjType, and the
	only reason for that is to retrieve a (Tcl_ObjType *) to pass to
	Tcl_ConvertToType().  None of the types above can support a
	Tcl_ConvertToType() call; they panic.  Better not to offer something
	than to lead users into a panic.
	***POTENTIAL INCOMPATIBILITY***
	For callers of Tcl_GetObjType on the type names listed above.

2005-05-15  Kevin Kenny	 <[email protected]>

	* win/tclWin32Dll.c: conditioned definition of
	EXCEPTION_REGISTRATION structures on HAVE_NO_SEH, to fix a bug in
	buildability on MSVC.

2005-05-14  Daniel Steffen  <[email protected]>

	* generic/tclInt.decls:
	* generic/tclTest.c:
	* generic/tclUtil.c:
	* win/tclWin32Dll.c: fixed link error due to direct access by
	tclTest.c to the MODULE_SCOPE tclPlatform global: renamed existing
	TclWinGetPlatform() accessor to TclGetPlatform() and moved it to
	generic code so that it can be used by on all platforms where
	MODULE_SCOPE is enforced.

	* macosx/tclMacOSXBundle.c:
	* unix/tclUnixInit.c:
	* unix/tcl.m4 (Darwin): made use of CoreFoundation API configurable
	and added test of CoreFoundation availablility to allow building on
	ppc64, replaced HAVE_CFBUNDLE by HAVE_COREFOUNDATION; test for
	availability of Tiger or later OSSpinLockLock API.

	* unix/tclUnixNotfy.c:
	* unix/Makefile.in:
	* macosx/tclMacOSXNotify.c (new file): when CoreFoundation is
	available, use new CFRunLoop based notifier: allows easy integration
	with other event loops on Mac OS X, in particular the TkAqua Carbon
	event loop is now integrated via a standard tcl event source (instead
	of TkAqua upon loading having to finalize the exsting notifier and
	replace it with its custom version). [Patch 1202052]

	* tests/unixNotfy.test: don't run unthreaded tests on Darwin
	since notifier may be using threads even in unthreaded core.

	* unix/tclUnixPort.h:
	* unix/tcl.m4 (Darwin): test for thread-unsafe realpath durning
	configure, as Darwin 7 and later realpath is threadsafe.

	* macosx/Makefile: enable configure caching.

	* unix/configure.in: wrap tclConfig.h header in #ifndef _TCLCONFIG so
	that it can be included more than once without warnings from gcc4.0
	(as happens e.g. when including both tclInt.h and tclPort.h)

	* macosx/tclMacOSXBundle.c:
	* unix/tclUnixChan.c:
	* unix/tclLoadDyld.c:
	* unix/tclUnixInit.c: fixed gcc 4.0 warnings.

	* unix/configure: autoconf-2.59
	* unix/tclConfig.h.in: autoheader-2.59

	* generic/tclIntDecls.h:
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: make genstubs

2005-05-13  Kevin Kenny	 <[email protected]>

	* win/tclWin32Dll.c: Further rework of the SEH logic.  All
			     EXCEPTION_REGISTRATION records are now
			     in the activation record rather than pushed
			     on the stack.

2005-05-13  Don Porter	<[email protected]>

	* generic/tclBasic.c:	Dropped the TCL_NO_MATH configuration.
	* generic/tclBinary.c:	It's believed this has not been working
	* generic/tclExecute.c: in a long time.	 Tcl needs math.h.
	* unix/Makefile.in:	[RFE 1200680].

2005-05-12  Kevin Kenny	 <[email protected]>

	* doc/mathfunc.n: Changed NAME line to match the name of the page.
	
2005-05-11  Kevin Kenny <[email protected]>

	[kennykb-numerics-branch] Resynchronized with the HEAD; at this
	checkpoint [-rkennykb-numerics-branch-20050511], the HEAD and
	kennykb-numerics-branch contain identical code.
	
2005-05-11  Kevin Kenny  <[email protected]>

	* generic/tclStrToD.c (TclStrToD, RefineResult, ParseNaN):
	Changed the code to cast 'char' to UCHAR explicitly when
	using ctype macros, to silence complaints from the Solaris
	compiler.

2005-05-10  Jeff Hobbs	<[email protected]>

	* unix/tclUnixFCmd.c: add lint attr to enum to satisfy strictly
	compliant compilers that don't like trailing ,s.

	* tests/string.test: string-10.[21-30]
	* generic/tclCmdMZ.c (Tcl_StringObjCmd): add extra checks to
	prevent possible UMR in unichar cmp function for string map.

2005-05-10  Kevin Kenny	 <[email protected]>

	* generic/tclBinary.c (FormatNumber): Fixed a bug where NaN's
	resulted in reads of uninitialized memory when using 'd',
	'q', or 'Q' format.
	* generic/tclStrToD.c (ParseNaN, TclFormatNaN): Added code to
	handle the peculiarities of HP's PA_RISC, which uses a different
	'quiet' bit in NaN from everyone else.
	* libtommath/tommath_superclass.h: Corrected C++-style comment.

2005-05-10  Kevin Kenny	 <[email protected]>

	Merged all changes on kennykb-numerics-branch back into the
	HEAD.  TIP's 132 and 232 are now Final.

2005-05-10  Kevin Kenny	 <[email protected]>

	[kennykb-numerics-branch] Merged changes from HEAD.

2005-05-10  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (ExponLong, ExponWide):
	* tests/expr.test (expr-23.34/35): fixed special case 'i**0' for
	i>0 [Bug 1198892]

2005-05-09  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]
	* win/tclWin32Dll.c (TclpCheckStackSpace, TclWinCPUID):
		Reworked structured event handling to function even
		with -fomit-frame-pointers.

2005-05-08  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]
	* generic/tclStrToD.c: Made code more portable by finding a
			       workaround for MSVC's 'volatile' issue that
			       does not require conditional compilation.
	* win/tclWin32Dll.c (TclWinCPUID): Removed structured event
					   handling from the GCC code
					   since (a) bad code is generated
					   by the instruction scheduling
					   with -O2, and (b) it's not
					   needed on any reasonably modern
					   CPU.

2005-05-07  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]
	* generic/tclEvent.c:  Moved initialization of tclStrToD.c's
	* generic/tclInt.h:    static constants into a procedure called
	* generic/tclStrToD.c: from TclInitSubsystems to avoid double
			       checked locking protocol. Cleaned up
			       an issue where MSVC ignored the 'volatile'
			       specifier, causing incorrect comparison
			       of an underflowed number against zero.

2005-05-06  Jeff Hobbs	<[email protected]>

	* unix/tcl.m4, unix/configure: correct Solaris 10 (5.10) check and
	add support for x86_64 Solaris cc builds.

2005-05-05  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch] Merged with HEAD.

2005-05-05  Kevin B. Kenny  <[email protected]>

	* win/tclWinThrd.c:  Corrected a compilation error on the
			     --enable-threads configuration.

2005-05-05  Don Porter	<[email protected]>

	* generic/tclInt.decls:	Converted TclMatchIsTrivial to a macro.
	* generic/tclInt.h:
	* generic/tclUtil.c:
	* generic/tclIntDecls.h:	`make genstubs`
	* generic/tclStubInit.c:
	* generic/tclBasic.c:	Added callers of TclMatchIsTrivial where
	* generic/tclCmdIL.c:	a search can be done more efficiently
	* generic/tclCompCmds.c:when it is recognized that a pattern match
	* generic/tclDictObj.c:	is really an exact match. [Patch 1076088]
	* generic/tclIO.c:
	* generic/tclNamesp.c:
	* generic/tclVar.c:

	* generic/tclCompCmds.c:	Factored common efficiency trick into
	a macro named CompileWord.

	* generic/tclCompCmds.c:	Replaced all instance of
	* generic/tclCompile.c:		TCL_OUT_LINE_COMPILE with TCL_ERROR.
	* generic/tclInt.h:		Now that we've eradicated the mistaken
	* tests/appendComp.test:	notion of a "compile-time error", we
	can use the TCL_ERROR return code to signal any failure to produce
	bytecode.

2005-05-03  Don Porter	<[email protected]>

	* doc/DString.3:	Eliminated use of identifier "string" in Tcl's
	* doc/Environment.3:	public C API to avoid conflict/confusion with
	* doc/Eval.3:		the std::string of C++.
	* doc/ExprLong.3, doc/ExprLongObj.3, doc/GetInt.3, doc/GetOpnFl.3:
	* doc/ParseCmd.3, doc/RegExp.3, doc/SetResult.3, doc/StrMatch.3:
	* doc/Utf.3, generic/tcl.decls, generic/tclBasic.c, generic/tclEnv.c:
	* generic/tclGet.c, generic/tclParse.c, generic/tclParseExpr.c:
	* generic/tclRegexp.c, generic/tclResult.c, generic/tclUtf.c:
	* generic/tclUtil.c, unix/tclUnixChan.c:

	* generic/tclDecls.h:	`make genstubs`

2005-05-02  Don Porter	<[email protected]>

	* generic/tcl.decls:
	* generic/tclBasic.c:	Simplified implementation of Tcl_ExprString.
	* tests/expr-old.test:

	* generic/tclDecls.h:	`make genstubs`

2005-04-30  Daniel Steffen  <[email protected]>

	* unix/tclUnixNotfy.c: applied dkf's tkMacOSXNotify.c cleanup changes.

2005-04-29  Don Porter	<[email protected]>

	TIP#176 IMPLEMENTATION	[Patch 1165695]

	* generic/tclUtil.c:	Extended TclGetIntForIndex to recognize
	index formats including end+integer and integer+/-integer.

	* generic/tclCmdMZ.c:	Extended the -start switch of [regexp]
	and [regsub] to accept all index formats known by TclGetIntForIndex.

	* doc/lindex.n:		Updated docs to note new index formats.
	* doc/linsert.n, doc/lrange.n, doc/lreplace.n, doc/lsearch.n:
	* doc/lset.n, doc/lsort.n, doc/regexp.n, doc/regsub.n, doc/string.n:

	* tests/cmdIL.test:	Updated tests.
	* tests/compile.test, tests/lindex.test, tests/linsert.test:
	* tests/lrange.test, tests/lreplace.test, tests/lsearch.test:
	* tests/lset.test, tests/regexp.test, tests/regexpComp.test:
	* tests/string.test, tests/stringComp.test, tests/util.test:

2005-04-28  Don Porter	<[email protected]>

	* tests/unixInit.test (7.1): Alternative fix for the 2004-11-11 commit.

2005-04-27  Don Porter	<[email protected]>

	* library/init.tcl:	Corrected flaw in interactive command
	* tests/main.test:	auto-completion.  [Bug 1191409].

	TIP#183 IMPLEMENTATION	[Patch 577093]

	* generic/tclIOUtil.c (TclGetOpenModeEx):	New routine.
	* generic/tclInt.h:

	* generic/tclIO.c (Tcl_OpenObjCmd):	Support for "b" and
	* doc/open.n:		"BINARY" in "access" argument to [open].
	* tests/ioCmd.test:

2005-04-26  Kevin B. Kenny  <[email protected]>

	* generic/tclBinary.c (FormatNumber):
	Dredge the NaN out of the internal representation if
	Tcl_GetDoubleFromObj returns TCL_ERROR on a NaN.

	* generic/tclObj.c (Tcl_GetDoubleFromObj):
	Restored silent overflow/underflow behaviour that the merge
	of 2004-04-25 messed up.  Thanks to Don Porter for calling
	attention to this bug. Also removed an uninitialised memory
	reference in this function that valgrind caught. Also changed
	to return TCL_ERROR on a pure NaN.

	* generic/tclStrToD.c (RefineResult):
	Added a test for the initial approximation being HUGE_VAL;
	this test avoids EDOM being returned from ldexp on some platforms
	on input values exceeding the floating point range.

	* tests/expr.test (expr-29.*, expr-30.*):
	Added further tests of overflow/underflow on input conversions.

2005-04-25  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch] Merged with HEAD.

	* doc/CrtMathFunc.n:		Revised documentation for TIP 232

2005-04-25  Daniel Steffen  <[email protected]>

	* compat/string.h: fixed memchr() protoype for __APPLE__ so that we
	build on Mac OS X 10.1 again.

	* generic/tclNotify.c (TclFinalizeNotifier): fixed notifier not being
	finalized in unthreaded core (was testing for notifier initialization in
	current thread by checking thread id != 0 but thread id is always 0 in
	untreaded core).

	* win/tclWinNotify.c (Tcl_WaitForEvent):
	* unix/tclUnixNotfy.c (Tcl_WaitForEvent): don't call ScaleTimeProc for
	zero wait times (as specified in TIP 233).

	* unix/Makefile.in: added @PLAT_SRCS@ to SRCS and split out NOTIFY_SRCS
	from UNIX_SRCS for parity with UNIX_OBJS & NOTIFY_OBJS.

	* unix/tcl.m4 (Darwin): added configure checks for recently added linker
	flags -single_module and -search_paths_first to allow building with
	older tools (and on Mac OS X 10.1), use -single_module in SHLIB_LD and
	not just T{CL,K}_SHLIB_LD_EXTRAS, added unexporting from Tk of symbols
	from libtclstub to avoid duplicate symbol warnings, added PLAT_SRCS
	definition for Mac OS X, defined MODULE_SCOPE to __private_extern__.
	(SC_MISSING_POSIX_HEADERS): added caching of dirent.h check.

	* unix/configure: autoconf-2.59

2005-04-25  Kevin B. Kenny  <[email protected]>

	* library/tzdata/America/Boise:
	* library/tzdata/America/Chicago:
	* library/tzdata/America/Denver
	* library/tzdata/America/Indianapolis:
	* library/tzdata/America/Los_Angeles:
	* library/tzdata/America/Louisville:
	* library/tzdata/America/Managua:
	* library/tzdata/America/New_York:
	* library/tzdata/America/Phoenix:
	* library/tzdata/America/Port-au-Prince:
	* library/tzdata/America/Indiana/Knox:
	* library/tzdata/America/Indiana/Marengo:
	* library/tzdata/America/Indiana/Vevay:
	* library/tzdata/America/Kentucky/Monticello:
	* library/tzdata/America/North_Dakota/Center:
	* library/tzdata/Asia/Tehran:
	Olson's tzdata2005i.  Corrects exact time at which Standard Time
	was adopted in the US (generally, noon, Standard Time, rather than
	noon, Local Mean Time).	 Adopts new civil rules for Nicaragua
	and Iran.

2005-04-25  Don Porter	<[email protected]>

	* library/init.tcl:	Use "ni" and "in" operators.

2005-04-25  Miguel Sofer <[email protected]>

	* generic/tclExecute.c: fix for [Bug 1189274].

2005-04-24  Don Porter	<[email protected]>

	* generic/tclLiteral.c:	Silence compiler warnings.
	* generic/tclObj.c:	[Bug 1188863].

2005-04-22  Don Porter	<[email protected]>

	The 2005-04-21 changes to Tcl_GetBooleanFromObj were done to bring
	it into agreement with its docs.  Further investigation reveals it
	was the docs that were incorrect.

	* doc/BoolObj.3:	Corrections to the documentation of
	Tcl_GetBooleanFromObj to bring it into agreement with what this
	public interface has always done, including noting the difference
	in function between Tcl_GetBooleanFromObj and Tcl_GetBoolean.

	* generic/tclGet.c:	Revised Tcl_GetBoolean to no longer be a
	wrapper around Tcl_GetBooleanFromObj (different function!).

	* generic/tclObj.c:	Removed TclGetTruthValueFromObj routine
	that was added yesterday.  Revisions so that only
	Tcl_GetBoolean-approved values get the "boolean" Tcl_ObjType.
	This retains the fix for [Bug 1187123].
	* tests/string.test:	Test string-23.0 for Bug 1187123.

	* generic/tclInt.h:	Revert most recent change.
	* generic/tclBasic.c:
	* generic/tclCompCmds.c:
	* generic/tclDictObj.c:
	* generic/tclExecute.c:
	* tests/obj.test:

2005-04-21  Don Porter	<[email protected]>

	* doc/GetInt.3:	Convert argument "string" to "str" to agree with code.
	Also clarified a few details on int and double formats.
	* generic/tclGet.c:	Radical code simplification.  Converted
	Tcl_GetFoo() routines into wrappers around Tcl_GetFooFromObj().
	Reduces code duplication, and the resulting potential for inconsistency.

	* generic/tclObj.c:	Several changes:

	  - Re-ordered error detection code so all values with trailing
	    garbage receive a "not an integer" message instead of an
	    "integer too large" message.
	  - Removed inactive code meant to deal with strtoul* routines that
	    fail to parse leading signs.  All of them do, and if any are
	    detected that do not, the correct fix is replacement with
	    compat/strtoul*.c, not a lot of special care by the callers.
	  - Tcl_GetDoubleFromObj now avoids shimmering away a "wideInt" intrep.
	  - Fixed Tcl_GetBooleanFromObj to agree with its documentation and
	    with Tcl_GetBoolean, accepting only "0" and "1" and not other
	    numeric strings.  [Bug 1187123]
	  - Added new private routine TclGetTruthValueFromObj to perform
	    the more permissive conversion of numeric values to boolean
	    that is needed by the [expr] machinery.

	* generic/tclInt.h (TclGetTruthValueFromObj):	New routine.
	* generic/tclExecute.c:	Updated callers to call new routine.
	* generic/tclBasic.c:	Updated callers to call new routine.
	* generic/tclCompCmds.c:	Updated callers to call new routine.
	* generic/tclDictObj.c:	Updated callers to call new routine.
	* tests/obj.test:	Corrected bad tests that actually expected
	values like "47" and "0xac" to be accepted as booleans.

	* generic/tclLiteral.c:	Disabled the code that forces some literals
	into the "int" Tcl_ObjType during registration.	 We can re-enable it
	if this change causes trouble, but it seems more sensible to let
	Tcl's "on-demand" shimmering rule, and not try to pre-guess things.

2005-04-20  Kevin B. Kenny <[email protected]>

	[kennykb-numerics-branch]
	* doc/expr.n:
	* doc/mathfunc.n (new file):	Revised documentation for TIP 232

2005-04-20  Don Porter	<[email protected]>

	* generic/tclGet.c (Tcl_GetInt):	Corrected error that did not
	* generic/tclObj.c (Tcl_GetIntFromObj): permit 0x80000000 to be
	recognized as an integer on TCL_WIDE_INT_IS_LONG systems [Bug 1090869].

2005-04-20  Kevin B. Kenny  <[email protected]>

	* generic/tclFileName.c: Silenced a compiler warning about
	'/*' within a comment.

2005-04-19  Don Porter	<[email protected]>

	* generic/tclBasic.c:	Added unsupported command
	* generic/tclCmdAH.c:	[::tcl::unsupported::EncodingDirs] to permit
	* generic/tclInt.h:	query/set of the encoding search path at
	* generic/tclInterp.c:	the script level.  Updated init.tcl to make
	* library/init.tcl:	use of the new command.	 Also updated several
	coding practices in init.tcl ("eq" for [string equal], etc.)

2005-04-19  Kevin B. Kenny  <[email protected]>

	* library/clock.tcl (Initialize): Put initialization code into a
	proc to avoid inadvertently clobbering global variables.
	[Bug 1185933]
	* tests/clock.test (clock-48.1): Added regression test for the
	above bug.
	Thanks to Ulrich Ring for reporting this bug.

2005-04-16  Miguel Sofer <[email protected]>

	* generic/Var.c (Tcl_ArrayObjCmd - ARRAY_NAMES): fix Tcl_Obj leak
	[Bug 1084111]

2005-04-16  Zoran Vasiljevic <[email protected]>

	* generic/tclIOUtil.c: force clenaup of the interp result
	in TclLoadFile(). Some implementations of TclpFindSymbol()
	will seed the interp result with error message when unable
	to find the requested symbol (this is not considered to
	be an error).

	Set of changes correcting huge memory waste (not a leak)
	when a thread exits. This has been introduced in 8.4.7
	within an attempt to correctly cleanup after ourselves when
	Tcl library is being unloaded with the Tcl_Finalize() call.

	This fixes the Tcl Bug #1178445.

	* generic/tclInt.h: added prototypes for TclpFreeAllocCache()
	and TclFreeAllocCache()

	* generic/tclThreadAlloc.c: modified TclFinalizeThreadAlloc()
	to explicitly call TclpFreeAllocCache with the NULL-ptr as
	argument signalling cleanup of private tsd key used only by
	the threading allocator.

	* unix/tclUnixThrd.c: fixed TclpFreeAllocCache() to recognize
	when being called with NULL argument. This is a signal for it
	to clean up the tsd key associated with the threading allocator.

	* win/tclWinThrd.c: renamed TclWinFreeAllocCache to TclpFreeAllocCache
	and fixed to recognize when being called with NULL argument.
	This is a signal for it to clean up the tsd key associated with the
	threading allocator.

2005-04-13  Don Porter	<[email protected]>

	* tests/unixInit.test:	Disabled obsolete tests and removed code
	* tests/encoding.test:	that supported them.
	* generic/tclInterp.c:

	* library/init.tcl:	Use auto-loading to bring in Tcl Module
	* library/tclIndex:	support as needed.  This reduces startup
	* library/tm.tcl:	time by delaying this initialization to
	a later time.

2005-04-15  Miguel Sofer <[email protected]>

	* generic/tclExecute.c: missing semicolons caused failure to
	compile with TCL_COMPILE_DEBUG.

2005-04-13  David Gravereaux <[email protected]>

	* generic/tclIO.c (Tcl_SetChannelBufferSize): Lowest size limit
	* tests/io.test:	changed from ten bytes to one byte.  Need
	* tests/iogt.test:	for this change was proven by
	Ross Cartlidge <[email protected]> where [read stdin 1] was grabbing
	10 bytes followed by starting a child process that was intended to
	continue reading from stdin.  Even with -buffersize set to one,
	nine chars were getting lost by the buffersize over reading for
	the native read() caused by [read].

2005-04-13  Don Porter	<[email protected]>

	* unix/tclUnixInit.c (TclpGetEncodingNameFromEnvironment):  Reversed
	order of verifying candidate [encoding system] value, checking against
	a table in memory first before calling Tcl_GetEncoding and potentially
	scanning through the filesystem.  Also ordered the table so that a
	binary search could be used within it.	Improves startup time a bit
	more on some systems.

2004-04-13  Kevin B. Kenny  <[email protected]>

	* library/clock.n: Added a missing '--' on several [switch]
	commands to improve performance of [clock format] and related
	operations.  [Feature Request 1182459]

2005-04-13  Donal K. Fellows  <[email protected]>

	* doc/fcopy.n: Improved documentation on copying binary files,
	added an example and mentioned the use of [file copy].
	* doc/fconfigure.n: Improved documentation of -encoding binary
	option.
	This is all following comments from Steve Manning <[email protected]>
	on comp.lang.tcl that the current documentation was not clear.

2005-04-13  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:Commented out the functions
	TclPrintInstruction(), TclPrintObject() and TclPrintSource() when
	not debugging the compiler, as they are never called in that case.

2005-04-12  Don Porter	<[email protected]>

	* generic/tclInterp.c:	Corrected bad syntax of Tcl_Panic() call.

	* generic/tclUtil.c (TclGetProcessGlobalValue):	More robust handling
	of bad TclInitProcessGlobalValueProc behavior; an immediate panic
	rather than a mysterious crash later.

	* generic/tclEncoding.c:	Several changes to the way the
	encodingFileMap cache is maintained.  Previously, it was attempted
	to keep the file map filled and up to date with changes in the
	encoding search path.  This contributed to slow startup times since
	it required an expensive "glob" operation to fill the cache.  Now the
	validity of items in the cache are checked at the time they are
	used, so the cache is permitted to fall out of sync with the
	encoding search path.  Only [encoding names] and Tcl_GetEncodingNames()
	now pay the full expense.  [Bug 1177363]

2005-04-12  Kevin B. Kenny  <[email protected]>

	* compat/strstr.c: Added default definition of NULL to
	accommodate building on systems with badly broken headers.
	[Bug #1175161]

2005-04-11  Donal K. Fellows  <[email protected]>

	* tools/tclZIC.tcl: Rewrote to take advantage of more features of
	Tcl 8.5 (on which it was dependent anyway). Also added a [package
	require] line to formalize the relationship.

2005-04-11  Kevin Kenny <[email protected]>

	[kennykb-numerics-branch] Merged with HEAD. Updated to libtommath 0.35.

	* generic/tclBasic.c: Attempted to repeat changes that applied
	to tclExecute.c in Miguel Sofer's commit of 2005-04-01, together
	with (possibly) a few more uses of his new object creation macros.
	Also plugged a memory leak in TclObjInvoke. [Bug 1180368]

2005-04-10  Kevin Kenny	 <[email protected]>

	* library/tzdata/America/Montevideo:
	* library/tzdata/Asia/Almaty:
	* library/tzdata/Asia/Aqtau:
	* library/tzdata/Asia/Aqtobe:
	* library/tzdata/Asia/Baku:
	* library/tzdata/Asia/Jerusalem:
	* library/tzdata/Asia/Oral:
	* library/tzdata/Asia/Qyzylorda:
	* library/tzdata/Indian/Chagos:
	* library/tzdata/Indian/Cocos:		Olson's tzdata2005h

2005-04-10  Don Porter	<[email protected]>

	* generic/tclBasic.c (TclObjInvoke):	Plug memory leak. [Bug 1180368]

2005-04-09  Miguel Sofer <[email protected]>

	* generic/tclExecute.c: fix possible leak of expansion Tcl_Objs

2005-04-09  Daniel Steffen  <[email protected]>

	* macosx/README: updated requirements for OS & developer tool
	versions + other small fixes/cleanup.

	* generic/tclListObj.c (Tcl_ListObjIndex): added missing NULL return
	when getting index from an empty list.

	* unix/tcl.m4 (Darwin): added -single_module linker flag to
	TCL_SHLIB_LD_EXTRAS and TK_SHLIB_LD_EXTRAS.
	* unix/configure: autoconf-2.59

2005-04-08  Don Porter	<[email protected]>

	* generic/tclInt.h (TclGetEncodingFromObj):	New function to
	* generic/tclEncoding.c (TclGetEncodingFromObj): retrieve a
	Tcl_Encoding value, as well as cache it in the internal rep
	of a new "encoding" Tcl_ObjType.
	* generic/tclCmdAH.c (Tcl_EncodingObjCmd):	Updated to call
	new function so that Tcl_Encoding's used by [encoding convert*]
	routines are not freed too quickly.  [Bug 1077262]

2005-04-08  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Rewritten to be
	able to handle the other form of [switch] and generate slightly
	simpler (but longer) code.

2005-04-06  Donal K. Fellows  <[email protected]>

	* doc/upvar.n, doc/unset.n, doc/tell.n, doc/tclvars.n, doc/subst.n:
	* doc/seek.n, doc/scan.n, doc/regsub.n, doc/registry.n, doc/regexp.n:
	* doc/read.n, doc/puts.n, doc/pkgMkIndex.n, doc/open.n, doc/lreplace.n:
	* doc/lrange.n, doc/load.n, doc/llength.n, doc/linsert.n, doc/lindex.n:
	* doc/lappend.n, doc/info.n, doc/gets.n, doc/format.n, doc/flush.n:
	* doc/fileevent.n, doc/file.n, doc/fblocked.n, doc/close.n:
	* doc/array.n, doc/Utf.3, doc/TraceVar.3, doc/StrMatch.3, doc/RegExp.3:
	* doc/PrintDbl.3, doc/OpenTcp.3, doc/OpenFileChnl.3, doc/Object.3:
	* doc/Notifier.3, doc/LinkVar.3, doc/IntObj.3, doc/Interp.3:
	* doc/GetOpnFl.3, doc/GetIndex.3, doc/Eval.3, doc/CrtMathFnc.3:
	* doc/CrtFileHdlr.3, doc/CrtCommand.3, doc/CrtChannel.3:
	* doc/Backslash.3: Purge old .VS/.VE macro instances.

	* tools/man2html2.tcl (IPmacro): Rewrote to understand what .IP
	really is (.IP and .TP are really just two ways of doing the same
	thing). Change below made this relevant.
	* doc/re_syntax.n: Change some uses of .TP to .IP to work around
	bugs in various *roff implementations. Also reworded the atom
	descriptions slightly.

2005-04-05  Don Porter	<[email protected]>

	* generic/tclExecute.c (ExprSrandFunc): Replaced incursions into the
	* generic/tclUtil.c (TclGetIntForIndex): intreps of numeric types
	with simpler calls of Tcl_GetIntFromObj and Tcl_GetLongFromObj,
	now that those routines are better behaved wrt shimmering.
	[Patch 1177219]

2005-04-05  Miguel Sofer <[email protected]>

	* generic/tclInt.h:
	* generic/tclObj.c: Change in TclDecrRefCount and TclFreeObj, to
	speed up the freeing of simple Tcl_Obj [Patch 1174551]

2005-04-04  Miguel Sofer <[email protected]>

	* generic/tclExecute.c: small opts in obj handling

2005-04-02  Miguel Sofer <[email protected]>

	* generic/tclVar.c: converted a few function calls to macros.

2005-04-01  Miguel Sofer <[email protected]>

	* doc/ListObj.3:
	* generic/tclBasic.c:
	* generic/tclCmdIL.c:
	* generic/tclConfig.c:
	* generic/tclExecute.c:
	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclIntDecls.h:
	* generic/tclListObj.c:
	* generic/tclStubInit.c:
	* generic/tclVar.c: Changed the internal representation of lists
	to (a) reduce the malloc/free calls at list creation (from 2 to
	1), (b) reduce the cost of handling empty lists (we now never
	create a list internal rep for them), (c) allow refcounting of the
	list internal rep. The latter permits insuring that the pointers
	returned by Tcl_ListObjGetElements remain valid even if the object
	shimmers away from its original list type. This is [Patch 1158008]

	* generic/tclExecute.c:
	* generic/tclInt.h:
	* generic/tclObj.c:
	* generic/tclStringObj.c:
	(1) defined new internal macros for creating and setting
	frequently used obj types (int,long, wideInt, double,
	string). Changed TEBC to use eg 'TclNewIntObj(objPtr, i)' to avoid
	the function call in 'objPtr = Tcl_NewIntObj(i)'
	(2) ExecEnv now stores two Tcl_Obj* pointing to the constants "0"
	and "1", for use by TEBC.
	(3) slight reduction in cost of INST_START_CMD

2005-03-31  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (INST_JUMP_TRUE/FALSE): replaced
	"test and branch" with "compute index into table"

2005-03-30  Donal K. Fellows  <[email protected]>

	* doc/FileSystem.3: Defined loadHandle argument. [Bug 1172401]

2005-03-29  Jeff Hobbs	<[email protected]>

	* win/tcl.m4, win/configure: do not require cygpath in macros to
	allow msys alone as an alternative.

2005-03-24  Don Porter	<[email protected]>

	* generic/tclCompile.h:	Move the TclInterpReady() declaration from
	* generic/tclInt.h:	tclCompile.h to tclInt.h.  Should have
	been done as part of the 1115904 bug fix on 2005-03-18.

	* generic/tclThreadTest.c:	Stop providing the phony package
	"Thread 1.0" when the [::testthread] command is defined.  It's
	never used by anything, and conflicts with loading the real
	"Thread" package.

2005-03-18  Don Porter	<[email protected]>

	* generic/tclCompCmds.c (TclCompileIncrCmd):	Corrected checks
	for immediate operand usage to permit leading space and sign
	characters.  Restores more efficient bytecode for [incr x -1]
	that got lost in the CONST string reforms of Tcl 8.4.  [Bug 1165671]

	* generic/tclBasic.c (Tcl_EvalEx):	Restored recursion limit
	* generic/tclParse.c (TclSubstTokens):	testing in nested command
	* tests/basic.test (basic-46.4):	substitutions within direct
	* tests/parse.test (parse-19.*):	script evaluation (Tcl_EvalEx)
	that got lost in the parser reforms of Tcl 8.1.	 Added tests for
	correct behavior.  [Bug 1115904]

2005-03-15  Vince Darley  <[email protected]>

	* generic/tclFileName.c:
	* win/tclWinFile.c:
	* tests/winFCMd.test: fix to 'file pathtype' and 'file norm'
	failures on reserved filenames like 'COM1:', etc.

2005-03-15  Pat Thoyts	<[email protected]>

	* unix/tcl.m4:	  Updated the OpenBSD configuration and regenerated
	* unix/configure: the configure script.

2005-03-15  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch] Merged with HEAD.

	* generic/tclBasic.c (many):
	* generic/tclCompExpr.c (CompileMathFuncCall):
	* generic/tclCompile.h:
	* generic/tclExecute.c (many):
	* generic/tclParseExpr.c (ParsePrimaryExpr):
	* tests/compExpr-old.test:
	* tests/compExpr.test:
	* tests/compile.test:
	* tests/expr-old.test:
	* tests/expr.test:
	* tests/for.test:
	* tests/parseExpr.test:
	Initial implementation of TIP #232.

	* generic/tclObj.c (Tcl_DbNewBignumObj): Fixed typo that broke
	--enable-symbols=mem build
	* tests/binary.test (binary-40.3, binary-40.6): Corrected tests
	to allow NaN(7ffffffffffff).

2005-03-14  Miguel Sofer <[email protected]>

	* generic/tclExecute.c: fixed INST_PUSH1's debugging code (wrong
	obj ref passed to TRACE_WITH_OBJ).

2005-03-14  Miguel Sofer <[email protected]>

	* generic/tclCompile.c: fixed INST_RETURN's stack effect in
	tclInstructionTable (-1 instead of -2)

2005-03-10  Miguel Sofer <[email protected]>

	* generic/tclCompCmds.c: removed debugging line

2005-03-10  Don Porter	<[email protected]>

	* generic/tclTrace.c (TclCheckInterpTraces):	Corrected mistaken
	cast of ClientData to (TraceCommandInfo *) when not warranted.
	Thanks to Yuri Victorovich for the report.  [Bug 1153871]
	* generic/tcl.h:	Moved flag values TCL_TRACE_ENTER_EXEC and
	* generic/tclInt.h:	TCL_TRACE_LEAVE_EXEC from public interface
	into private.  Should be used only by internal workings of
	execution traces.

2005-03-09  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch] Merged from HEAD.

	* doc/PrintDbl.3:
	* doc/tclVars.n: Documented new semantics for tcl_precision.
	* generic/tclExecute.c (Tcl_ExecuteByteCode): Removed the check
	for division-by-zero on IEEE-754 machines.
	* generic/tclUtil.c (Tcl_PrintDouble): Corrected bug where numbers
	in the range [1e-4 .. 1.) were printed incorrectly.
	* tests/compExpr-old.test (compExpr-old-11.13): Revised test
	case for division by zero
	* tests/expr-old.test (expr-34.11, expr-34.12): Revised test
	cases for overflow in pow() to deal with infinities.
	* tests/expr.test (expr-11.13, expr-29.1, expr-29.2): Revised
	test case for division by zero and for underflow on input
	conversions.
	* tests/parseExpr.test (parseExpr-16.11): Revised test case for
	overflow on input conversion.
	* tests/string.test (string-6.38 deleted): Removed test case
	for underflow on input conversion, which is no longer an error.
	* tests/util.test (util-10.*): Added test case for the bug in
	tclUtil.c.

2005-03-08  Jeff Hobbs	<[email protected]>

	* win/makefile.vc: clarify necessary defined vars that can come
	from MSVC or the Platform SDK.

2005-03-07  Donal K. Fellows  <[email protected]>

	* doc/string.n: Minor typo. [Bug 1158247]

2005-03-07  Miguel Sofer <[email protected]>

	* generic/tclExecute.c: new peephole optimisation for INST_PUSH1;
	fixed the peephole opt in INST_POP so that it is not used when
	TCL_COMPILE_DEBUG is defined.

2005-03-04  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclCmdMZ.c: Changed [scan] to treat out-of-range
	floating point values as infinities and zeroes.
	* generic/tclExecute.c: Changed [expr] to be permissive about
	infinities, allowing them to propagate.
	* generic/tclGet.c: Changed Tcl_GetDouble to be permissive about
	over/underflow.
	* generic/tclObj.c: Changed SetDoubleFromAny to be permissive
	about over/underflow.
	* generic/tclParseExpr.c: Made [expr] permissive about input
	numbers out of range.

2005-03-03  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclInt.h:
	* generic/tclStrToD.c (Tcl_DoubleDigits, TclFormatNaN):
	* generic/tclUtil.c (Tcl_PrintDouble):
		Changed the signature of TclDoubleDigits so that it
		accepts a pointer to the signum of the argument, and
		returns the signum via that pointer.  Added very
		hacky code to handle IEEE signed zeroes in Tcl_DoubleDigits.
		(It can't be done other than as a hack until C9x;
		C89 simply doesn't deal with the concept of -0.0).
		Added output conversion of tagged NaN values.
	* generic/tclBinary.c (FormatNumber):
		Changed to allow [binary format] to handle NaN.
	* tests/binary.test (binary-60.1):
		Added a quick-n-dirty test to make sure that NaN's
		can be scanned and formatted.
	* generic/tclParseExpr.c (GetLexeme, ParseMaxDoubleLength):
		Modified so that tagged NaN (e.g., NaN(DEADBEEF)) can
		be recognized.

2005-03-02  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch] Merged with HEAD as of 2005-02-23.

	* generic/tclExecute.c:
		Broadened test for NaN to work on Windows.
	* generic/tclInt.h:
	* generic/tclStrToD.c (Tcl_DoubleDigits):
	* generic/tclUtil.c (Tcl_PrintDouble, TclPrecTraceProc):
		Added Tcl_DoubleDigits to format 'double' numbers
		with the minimum number of significant digits to
		yield correct rounding.	 Modified tcl_precision to
		accept 0 as a precision (meaning "minimum digits"), and
		made 0 the default.  [TIP #132]
	* generic/tclObj.c:
		Made NaN's throw an error in Tcl_GetDoubleFromObj.
	* unix/Makefile.in:
	* win/Makefile.in:
	* win/makefile.vc:
		Added libtommath/bn_mp_init_set.c to the build.
	* libtommath/tommath.h (mp_iseven):
		Fixed a bug that caused zero to test 'odd'.
	* generic/tommath.h:
		Regenerated.
	* tests/binary.test:
	* tests/expr-old.test:
	* tests/expr.test:
	* tests/scan.test:
		Corrected a number of tests that depended on
		tcl_precision, and removed the {eformat} condition
		from tests that no longer require it.
	* tests/util.test:
		Corrected a number of tests that depended on
		tcl_precision, and removed the {eformat} condition
		from tests that no longer require it.  Added a series
		of tests for correct rounding in Tcl_PrintDouble. [TIP
		#132].

2005-03-01  David N. Welton  <[email protected]>

	* doc/CrtSlave.3: Changed to Tcl_Object to Tcl_Obj in the man
	page.

2005-02-24  Don Porter	<[email protected]>

	* library/tcltest/tcltest.tcl:	Better use of [glob -types] to avoid
	* tests/tcltest.test:	failed attempts to [source] a directory, and
	similar matters.  Thanks to "mpettigr".	 [Bug 1119798]

	* library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.8
	* unix/Makefile.in:
	* win/Makefile.in:

2005-02-23  Donal K. Fellows  <[email protected]>

	* doc/CrtChannel.3 (THREADACTIONPROC): Formatting fix. [Bug 1149605]

2005-02-17  Jeff Hobbs	<[email protected]>

	* win/tclWinFCmd.c (TraverseWinTree): use wcslen on wchar, not
	Tcl_UniCharLen.

2005-02-16  Miguel Sofer <[email protected]>

	* doc/variable.n: fix for [Bug 1124160], variables are detected
	by [info vars] but not by [info locals].

2005-02-11  Jeff Hobbs	<[email protected]>

	* unix/Makefile.in: remove SHLIB_LD_FLAGS (only for AIX, inlined
	* unix/tcl.m4:	    into SHLIB_LD).  Combine AIX-* and AIX-5
	* unix/configure:   branches in SC_CONFIG_CFLAGS.
	Correct gcc builds for AIX-4+ and HP-UX-11.  autoconf-2.59 gen'd.

2005-02-11  Miguel Sofer <[email protected]>

	* tests/basic.test (basic-26.3): new test

2005-02-10  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (Tcl_EvalObjEx):
	* tests/basic.test (basic-26.2): preserve the arguments passed to
	TEOV in the pure-list branch, in case the list shimmers away. Fix
	for [Bug 1119369], reported by Peter MacDonald.

2005-02-10  Vince Darley  <[email protected]>

	* generic/tclFileName.c: fix for test failures introduced
	on 2005-01-17 [Bug 1119092]

2005-02-10  Donal K. Fellows  <[email protected]>

	* doc/binary.n: Made the documentation of sign bit masking and
	[binary scan] consistent. [Bug 1117017]

2005-02-08  David N. Welton  <[email protected]>

	* doc/CrtChannel.3: Typo: return->returns.

2005-02-06  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclStrToD.c (TclStrToD, SafeLdExp):
	    Added code to manage the FPU precision on gcc+x86.
	    Enabled fast conversion of floats with small exponents
	    now that precision is correct.
	* tests/expr.test: Corrected test for the smallest representible
	    value to the right IEEE values.

2005-02-06  David N. Welton  <[email protected]>

	* doc/Thread.3: One-word grammar fix.

2005-02-05  David N. Welton  <[email protected]>

	* doc/Thread.3: Fixed sentence describing flags for
	Tcl_CreateThread.

	* doc/FileSystem.3: Cleaned up typo in Tcl_FSNewNativePath
	documentation.

	* generic/tclPathObj.c: Cleaned up typo in comment.

2005-02-03  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclStrToD.c (TclStrToD, RefineResult, SafeLdExp):
	    Added code to ensure that 'ldexp' is never called with
	    a value that will underflow.
	* tests/expr.test: Added tests for the smallest representible
	    value, and rounding between it and zero. (The tests reflect
	    current behaviour; plan is to change the specification of
	    Tcl so that input conversion of doubles underflows silently.)

2005-02-02  Mo DeJong  <[email protected]>

	* generic/tclProc.c (TclInitCompiledLocals):
	Add check for type of the framePtr->procPtr->bodyPtr
	passed to TclInitCompiledLocals and panic if
	it is not the correct type. If the body of the proc
	is not of the compiled byte code type then the
	code will crash. This was discovered while tracking
	down a crash in Itcl, that crash is fixed by
	Itcl patch 1115085.

2005-02-01  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]  Merged with HEAD as of today.

	* generic/tclInt.decls:
	    Changed numbers of new stubs to resolve a conflict.
	* generic/tclInt.h:
	    Added new TclStrToD routine that replaces the native
	    'strtod' thro
	ughout Tcl.
	* generic/tclCmdMZ (Tcl_StringObjCmd):
	* generic/tclGet.c (Tcl_GetDouble):
	* generic/tclObj.c (SetBooleanFromAny, SetDoubleFromAny):
	* generic/tclParseExpr.c (GetLexeme):
	* generic/tclScan.c (Tcl_ScanObjCmd):
	    Replaced all uses of the native 'strtod' with a TclStrToD
	    routine that performs correct rounding and handles denormals.
	* generic/tclStrToD.c: (new file)
	    New scanning function for extracting 'double' from a string
	    that rounds correctly, and handles denormals and infinities.
	* unix/Makefile.in:
	* win/Makefile.in:
	* win/makefile.vc:
	    Added tclStrToD.c and the tommath routines that support it.

	These changes represent a partial implementation of TIP #132.
	Output conversion of floating point numbers, and proper handling
	of infinities within expressions, still need to be addressed.

2005-02-01  Don Porter	<[email protected]>

	* generic/tclExecute.c (TclCompEvalObj): Removed stray statement
	left behind in prior code reorganization.

2005-01-31  Don Porter	<[email protected]>

	* unix/configure:	autoconf-2.57

2005-01-30  Joe English	 <[email protected]>

	* unix/configure.in: Restored two double-evals that were
	removed in the DBGX purge; these are still needed on some
	platforms to account for TCL_TRIM_DOTS.	 [Bug 1112654]

	* unix/configure: NOT REGENERATED: only have autoconf 2.59 here,
	need to find someone with autoconf 2.57.

2005-01-28  Jeff Hobbs	<[email protected]>

	* unix/configure, unix/tcl.m4: add solaris 64-bit gcc build
	support. [Bug 1021871]

2005-01-28  Donal K. Fellows  <[email protected]>

	* tests/expr-old.test (expr-old-37.2): Added test for [Bug 1109484]

2005-01-27  Jeff Hobbs	<[email protected]>

	* generic/tclBasic.c (Tcl_ExprBoolean, Tcl_ExprDouble)
	(Tcl_ExprLong): Fix to recognize Tcl_WideInt type. [Bug 1109484]

2005-01-26  Andreas Kupries <[email protected]>

	TIP#218 IMPLEMENTATION

	* generic/tclDecls.h:	Regenerated from tcl.decls.
	* generic/tclStubInit.c:

	* doc/CrtChannel.3:	Documentation of extended API,
	* generic/tcl.decls:	extended testsuite, and
	* generic/tcl.h:	implementation. Removal of old
	* generic/tclIO.c:	driver-specific TclpCut/Splice
	* generic/tclInt.h:	functions. Replaced with generic
	* tests/io.test:	thread-action calls through the
	* unix/tclUnixChan.c:	new hooks. Update of all builtin
	* unix/tclUnixPipe.c:	channel drivers to version 4.
	* unix/tclUnixSock.c:	Windows drivers extended to
	* win/tclWinChan.c:	manage thread state in a thread
	* win/tclWinConsole.c:	action handler.
	* win/tclWinPipe.c:
	* win/tclWinSerial.c:
	* win/tclWinSock.c:

2005-01-25  Don Porter	<[email protected]>

	* library/auto.tcl:	Updated [auto_reset] to clear auto-loaded
	commands in namespaces other than :: and to clear auto-loaded commands
	that do not happen to be procs.	 [Bug 1101670]
	***POTENTIAL INCOMPATIBILITY***

2005-01-25  Daniel Steffen  <[email protected]>

	* unix/tcl.m4 (Darwin): fixed bug with static build linking to
	dynamic library in /usr/lib etc instead of linking to static library
	earlier in search path. [Tcl Bug 956908]
	Removed obsolete references to Rhapsody.
	* unix/configure: autoconf-2.57

2005-01-21  Andreas Kupries <[email protected]>

	* generic/tclStubInit.c: Regenerated the stubs support code from
	* generic/tclDecls.h:	 the modified tcl.decls (TIP #233, see below).

	* doc/GetTime.3:       Implemented TIP #233, i.e. the
	* generic/tcl.decls:   'Virtualization of Tcl's Sense of Time'.
	* generic/tcl.h:       Declared, implemented, and documented the
	* generic/tclInt.h:    specified new API functions. Moved the
	* unix/tclUnixEvent.c: native (OS) access to time information
	* unix/tclUnixNotfy.c: into standard handler functions. Inserted
	* unix/tclUnixTime.c:  hooks calling on the handlers where native
	* win/tclWinNotify.c:  access was done before, and where scaling
	* win/tclWinTime.c:    between domains (real/virtual) is required.

2005-01-21  Andreas Kupries <[email protected]>

	* generic/tclThread.c: Typo police. Fixed some nits
	* generic/tclCmdAH.c:  in header comments of functions.
	* generic/tclBasic.c:  (Missing --).
	* generic/tclFileName.c:

2005-01-21  Donal K. Fellows  <[email protected]>

	* doc/FileSystem.3: Add missing ARGUMENTS section definitions for
	arguments to Tcl_FSLink. [Bug 1106272]

2005-01-21  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch]

	* unix/Makefile.in:	Updated Makefile to build libtommath on
				Unix as well as Windows. [Bug 1106865]

	* generic/tclTestObj.c (TestbignumobjCmd):
	Silenced a compiler warning about a mismatched 'const'.

2005-01-20  Kevin B. Kenny  <[email protected]>

	[kennykb-numerics-branch] Development checkpoint.

	* compat/strtoll.c:	Reverted to HEAD.
	* compat/strtoull.c:
	* doc/Ensemble.3:
	* generic/tclBasic.c:
	* generic/tclCmdIL.c:
	* generic/tclNamesp.c:
	* generic/tclPathObj.c:
	* generic/tclPort.h:
	* unix/configure:
	* unix/configure.in:
	* unix/tcl.m4:
	* win/configure:
	* win/configure.in:
	* win/rules.vc:
	* win/tcl.m4:

	* generic/tcl.h: Added declarations for bignum types, and
			 for a 'bignumValue' in the Tcl_Obj structure.
	* generic/tclInt.h: Added declarations of interface procedures
			    for memory allocation in libtommath.

	* generic/tcl.decls: Added new interface to bignum objects.
	* generic/tclInt.decls: Added internal stubs for bignum routines
				used by the test code in tclTestObj.c.

	* generic/tclDecls/h:		Regen.
	* generic/tclIntDecls.h:
	* generic/tclStubInit.h:

	* tools/fix_tommath_h.tcl: (New file) Script to edit
				   libtommath/tommath.h and produce
				   generic/tommath.h so that storage
				   classes, allocation routines, and
				   data types conform to Tcl's
				   conventions.
	* generic/tommath.h: (New file) Generated by the above.

	* generic/tclTomMath.h: (New file) Additional declarations
				to be included in tommath.h when building
				Tcl.

	* generic/tclTomMathInterface.c: (New file) Small 'glue' routines
					 adapting tommath's API to Tcl.

	* libtommath/bn_fast_s_mp_mul_digs.c:
	* libtommath/bn_mp_mul_d.c:
	* libtommath/bn_mp_read_radix.c:
	* libtommath/tommath.h: Applied suggested changes from Tom St
	Denis that correct an off-by-one error in single-digit
	multiplication (leading to a pointer smash if uncorrected) and
	change the string argument to 'mp_read_radix' from 'char*' to
	'const char*'.

	* libtommath/bn_mp_radix_size.c:
	Local patch to ensure that sufficient memory is requested
	even if the number has a single digit.

	* libtommath/bn_mp_read_radix.c:
	Local patch to return MP_VAL if the input string contains
	an invalid character.

	* generic/tclObj.c: Added accessor functions for bignums.
	* generic/tclTestObj.c: Added a 'testbignumobj' command to
	exercise the accessor functions for bignums.

	* win/Makefile.in: Added rules for making libtommath.

2005-01-19  Donal K. Fellows  <[email protected]>

	TIP#235 IMPLEMENTATION

	* doc/Ensemble.3: Documentation for the new public API.
	* generic/tclNamesp.c (Tcl_CreateEnsemble,...): Rename of
	* generic/tcl.decls:		existing API into TIPped form.

2005-01-19  Mo DeJong  <[email protected]>

	* win/tclWinChan.c (FileCloseProc): Invoke TclpCutFileChannel() to
	remove a FileInfo from the thread local list before deallocating
	it.  This should have been done via an earlier call to
	Tcl_CutChannel, but I was running into a crash in the next call to
	Tcl_CutChannel during the IO finalization stage.

2005-01-18  Kevin Kenny	 <[email protected]>

	* library/tzdata/GMT+0:
	* library/tzdata/GMT-0:
	* library/tzdata/GMT0:
	* library/tzdata/Greenwich:
	* library/tzdata/Navajo:
	* library/tzdata/Universal:
	* library/tzdata/Zulu:
	* library/tzdata/America/Asuncion:
	* library/tzdata/America/Rosario:
	* library/tzdata/Asia/Jerusalem:
	* library/tzdata/Brazil/Acre:
	Routine update per Olson's tzdata2005c.	 Removed links to links
	(Greenwich in several aliases; Navajo; Acre). Updated Paraguayan
	DST rules and "best guess" at this year's Israeli rules.

2005-01-17  Vince Darley  <[email protected]>

	* generic/tclFileName.c: fix for glob failure on Windows shares
	[Bug 1100542].

	* doc/pkgMkIndex.n: added documentation that 'pkg_mkIndex -lazy' is
	not a good idea. [Bug 1101678]

2005-01-14  Donal K. Fellows  <[email protected]>

	* tests/compile.test (compile-17.1): Document known issue with
	binding time of compiled command interpretations in [expr].

	* generic/tclIOUtil.c (TclFSFileAttrIndex): New helper function so
	that we don't need to hard-code attribute indexes. [Bug 1100671]

2005-01-13  Donal K. Fellows  <[email protected]>

	* doc/string.n: Removed the term 'set' from the documentation of
	the [string trim] commands, as it caused confusion.

2005-01-12  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_PATH_{TCL,TK}CONFIG): Added code to detect the
	case when the --with-tcl/--with-tk arguments point to the config
	scripts themselves and not their directory. If this is the case,
	they now complain but keep working. [FRQ 951247]
	* unix/configure:	autoconf-2.57

2005-01-10  Joe English	 <[email protected]>

	* unix/Makefile.in, unix/configure.in, unix/tcl.m4,
	* unix/tclConfig.sh.in, unix/dltest/Makefile.in:
	Remove ${DBGX}, ${TCL_DBGX} from Tcl build system [Patch 1081595].
	* unix/configure: regenerated

2005-01-10  Donal K. Fellows  <[email protected]>

	* unix/tclUnixFCmd.c (TclUnixCopyFile): Convert u_int to unsigned
	to make clashes with types in standard C headers less of a
	problem. [Bug 1098829]

2005-01-09  Joe English	 <[email protected]>

	* unix/tclUnixThrd.c, unix/tclUnixPort.h: Remove readdir_r()
	and related #ifdeffery (see #1095909).
	* unix/tcl.m4, unix/tclConfig.h.in: Don't check for HAVE_READDIR_R.
	* unix/configure: Regenerated.

2005-01-06  Donal K. Fellows  <[email protected]>

	* library/http/http.tcl (http::mapReply): Significant performance
	enhancement by using [string map] instead of [regsub]/[subst], and
	update version requirement to Tcl8.4. [Bug 1020491]

2005-01-05  Donal K. Fellows  <[email protected]>

	* doc/lsearch.n, doc/re_syntax.n: Convert to other form of emacs
	mode control comment to prevent problems with old versions of
	man. [Bug 1085127]

2005-01-05  Pat Thoyts	<[email protected]>

	* tests/winDde.test: Fixed broken test result.

2005-01-05  Donal K. Fellows  <[email protected]>

	* generic/tclInt.h, generic/tclPort.h: Move the #include of
	tclConfig.h *first* before any reference to tcl.h so that the
	build configuration is loaded before the first reference to any
	system headers. Issue reported by Art Haas on tcl-core.

2005-01-04  Don Porter	<[email protected]>

	* tests/fCmd.test (fCmd-18.10):	Added notNetworkFilesystem constraint.
	[Bug 456665]

2004-12-29  Jeff Hobbs	<[email protected]>

	* win/tcl.m4, win/configure: update MSVC CFLAGS_OPT to -O2, remove
	-Gs (included in -O2) and -GD (outdated).  Use "link -lib" instead
	of "lib" binary and remove -YX for MSVC7 portability.  Add
	-fomit-frame-pointer for gcc OPT compiles. [Bug 1092952, 1091967]
	Align LIBS_GUI with Tk head needs.

2004-12-29  Kevin B. Kenny  <[email protected]>

	* generic/tclDate.c: Regen
	* generic/tclGetDate.y (TclDatelex):
		Fixed a problem where a four-digit group with >=2
		leading zeroes appeared to be a	two-digit group, leading to
		misinterpreting the time 0012 as 1200.	[Bug # 1090413]
	* library/clock.tcl: Added code to interpret correctly months
			     outside the range 01-12 as reduced modulo 12
			     with a corresponding adjustment to the year.
			     [Bug 1092789]
	* tests/clock.test: Added regression test cases for the above two
			    bugs.
	* unix/Makefile.in: Added --no-lines to the 'bison' command line
	* win/Makefile.in:  to help constrain the number of diffs in a cvs
			    checkin.

2004-12-24  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclInt.h:
	* generic/tclLiteral.c:
	* generic/tclProc.c:
	Avoid sharing cmdName literals accross namespaces, and generalise
	usage of the TclRegisterNewLiteral macro [Patch 1090905]

2004-12-20  Miguel Sofer <[email protected]>

	* generic/tclCompile.c: moved TclInitCompiledLocals to tclProc.c
	* generic/tclProc.c: new static InitCompiledLocals to allow for a
	single pass over the proc's arguments at proc load time (instead of
	two as previously). TclObjInterpProc() now allocates the
	compiledLocals on the tcl execution stack, using the new
	TclStackAlloc/Free functions.

2004-12-16  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (Tcl_LimitSetTime, TimeLimitCallback):
	(TclLimitRemoveAllHandlers, TclInitLimitSupport): Set a timer
	event to trigger when the time limit runs out. All the time limit
	actually does is check to see if the time limit has been exceeded,
	but this is enough to fix [Bug 1085023].
	* generic/tclInt.h (struct Interp): Added a field to hold the token
	for the timer event handler associated with the current time limit.
	* generic/tclEvent.c (Tcl_UpdateObjCmd, Tcl_VwaitObjCmd): Add
	error message when limit exceeded.
	* tests/interp.test (interp-34.[89]): Check that time limits
	handle the two cases reported in [Bug 1085023]

	* generic/tclTimer.c (TclCreateAbsoluteTimerHandler): New internal
	function that allows setting a timer handler that will be
	triggered at (or after) a specific time instead of at some number
	of milliseconds in the future. This is a candidate for future
	exposure via a TIP.

2004-12-15  Miguel Sofer <[email protected]>

	* generic/tclBasic.c:
	* generic/tclExecute.c:
	* generic/tclInt.decls:
	* generic/tclIntDecls.h:
	* generic/tclNamesp.c:
	* generic/tclProc.c:
	* generic/tclStubInit.c:
	* generic/tclTest.c: Added two new functions to allocate memory
	from the execution stack (TclStackAlloc, TclStackFree). Added
	functions TclPushStackFrame and TclPopStackFrame that do the work
	of Tcl_PushCallFrame and Tcl_PopCallFrame, but using frames
	allocated in the execution stack - i.e., heap instead of
	C-stack. The core uses these two new functions exclusively; the
	old ones remain for backwards compat, as at least two popular
	extensions (itcl, xotcl) are known to use them.

2004-12-14  Miguel Sofer <[email protected]>

	* generic/tclCmdIL.c:
	* generic/tclInt.h:
	* generic/tclProc.c:
	* generic/tclVar.c: changing the isProcCallFrame field of the
	CallFrame struct from a 0/1 field to flags. Should be perfectly
	backwards compatible.

2004-12-14  Don Porter	<[email protected]>

	* unix/configure.in:	Added special processing to remove "$U"
	from libraries in the LIBOBJS value.  This is an auto-make-ism
	we need to avoid.  [Bug 1081541]

	* unix/configure:	autoconf-2.57

2004-12-13  Don Porter	<[email protected]>

	* generic/tcl.h:	Restored extern "C" guards so that C++ code
	sees function pointer typedef linkage consistent with earlier Tcl
	releases. [Bug 1082349].

	* generic/tclEncoding.c:	Plugged some memory leaks.  Thanks to
	* generic/tclUtil.c:	 Rolf Ade for reports and testing [Bug 1083082]

2004-12-13  Kevin B. Kenny  <[email protected]>

	* doc/clock.n: Clarify that the [clock scan] command does not
	accept the full range of ISO8601 point-in-time formats
	[Bug 1075433].

2004-12-12  Miguel Sofer <[email protected]>

	* generic/tclVar.c (TclArrayObjCmd - ARRAY_NAMES): leaking an
	object [Bug 1084111] - thanks to Rolf Ade.

2004-12-12  Miguel Sofer <[email protected]>

	* generic/tclObj.c (TclSetCmdNameObj): special handling for fully
	qualified command names (as in fix [Patch 456668]).

2004-12-11  Miguel Sofer <[email protected]>

	* generic/tclInt.h:
	* generic/tclNamesp.c: converting the static function
	GetNamespaceFromObj() to MODULE_SCOPE TclGetNamespaceFromObj().

2004-12-10  Donal K. Fellows  <[email protected]>

	* tools/tcl.wse.in, unix/tcl.spec, win/README.binary, README:
	* win/configure.in, unix/configure.in, generic/tcl.h:
	Bumped version number to 8.5a3 to distinguish HEAD of CVS
	development from the recent 8.5a2 release.

2004-12-10  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclInitCompiledLocals):
	* generic/tclCompile.h:
	* generic/tclInt.h:
	* generic/tclProc.c (TclObjInterpProc, TclCreateProc): optimised
	loops that initialise a proc's arguments and compiled local
	variables, removing tests from inner loops.

2004-12-10  Donal K. Fellows  <[email protected]>

	* generic/tclInt.h: Move ensemble API decls here from tclNamesp.c

2004-12-09  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (TclMakeEnsembleCmd, TclSetEnsemble*)
	(TclSetEnsemble*, TclFindEnsemble): Build an internal API for
	creating and manipulating ensembles; they can be deleted using the
	normal command-deletion API.

	* doc/Async.3: Reword for better grammar, better nroff and get the
	flag name right. (Reported by David Welton.)

2004-12-07  Don Porter	<[email protected]>

	* tests/unixInit.test (2.1-4):	Added constraints so that when a
	value of TCL_LIBRARY is required for process initialization, we skip
	the tests that mess with that value.

2004-12-07  Donal K. Fellows  <[email protected]>

	*** 8.5a2 TAGGED FOR RELEASE ***

	* unix/Makefile.in: add library/{tzdata,msgs} to dist target (kbk)

	* doc/foreach.n: Adjust tabs to be friendlier to some HTML
	converters. [Bug 1078760]

2004-12-06  Jeff Hobbs	<[email protected]>

	* unix/tclUnixNotfy.c (NotifierThreadProc): init numFdBits
	[Bug 1079286]

	* doc/error.n, doc/SaveResult.3, doc/Thread.3: minor nroff typos

2004-12-06  Don Porter	<[email protected]>

	* tests/safe.test:	Trim auto_path to improve performance [1080039]

	* tests/msgcat.test:	makeFile/removeFile cleanup [1079117]

2004-12-04  Don Porter	<[email protected]>

	* generic/tclEncoding.c:	Different fix for [Bug 1077005].
	* generic/tclEvent.c:	Broke apart TclpSetInitialEncodings() on
	* generic/tclInt.h:	Windows into TclpSetInterfaces(), that is
	* unix/tclUnixInit.c:	fundamentally essential, and the initialization
	* win/tclWinInit.c:	of the system encoding, which is not.  Made
	the TclpSetInterfaces call part of TclInitSubsystems so it cannot be
	overlooked.

2004-12-03  Jeff Hobbs	<[email protected]>

	* changes: updated for 8.5a2 release

2004-12-02  Don Porter	<[email protected]>

	* generic/tclUtil.c (TclSetProcessGlobalValue):	 Handle the case
	where a ProcessGlobalValue might be assigned to itself.

	* generic/tclEncoding.c (MakeFileMap):	Correct refcounting errors
	managing values returned by TclPathPart (with refCount of 1!) that
	led to a memory leak.  [Bug 1077474].

2004-12-02  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix and new tests for [Bug 1074671] to
	* tests/fileSystem.test:   ensure tilde paths are not returned
	specially by 'glob'.

2004-12-02  Kevin B. Kenny  <[email protected]>

	* win/Makefile.in: Added a 'sed' in the setting of ROOT_DIR_NATIVE
	to compensate for a bug in cygpath (at least version 1.36) that
	leaves a trailing backslash on the end of the converted path.

2004-12-02  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (Alias,Target,Master): Rewrote these so that
	the aliases that refer to an interpreter are stored in a list and
	not a hashtable (which was only ever a convenience, and forced the
	use of a global mutex to generate keys!) [FRQ 1077210]
	* generic/tclNamesp.c (numNsCreated): Moved into thread-local
	storage to remove a global mutex. [FRQ 1077210]

2004-12-01  Don Porter	<[email protected]>

	* generic/tclUtil.c (TclGetProcessGlobalValue):	Narrowed the scope
	of mutex locks.

	* generic/tclUtil.c:		Updated Tcl_GetNameOfExecutable() to
	* generic/tclEncoding.c:	make use of a ProcessGlobalValue for
	* generic/tclEvent.c:		storing the executable name.
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166

2004-12-01  Donal K. Fellows  <[email protected]>

	* tests/winDde.test: Rewritten to use tcltest2 features more
	thoroughly (reducing the [catch] count!) and fix the problem with
	winDde-6.1 being out of synch with the implementation.

2004-11-30  Don Porter  <[email protected]>

	* library/init.tcl ([unknown]):	Restored the save/restore of
	the variables ::errorCode and ::errorInfo.  This is needed when
	the [::bgerror] command is auto-loaded (as it is by Tk).

	Patch 976520 reworks several of the details involved with
	startup/initialization of the Tcl library, focused on the
	activities of Tcl_FindExecutable().

	* generic/tclIO.c:	Removed bogus claim in comment that
	encoding "iso8859-1" is "built-in" to Tcl.
	
	* generic/tclInt.h:	Created a new struct ProcessGlobalValue,
	* generic/tclUtil.c:	routines Tcl(Get|Set)ProcessGlobalValue,
	and function type TclInitProcessGlobalValueProc.  Together, these
	take care of the housekeeping for "values" (things that can be
	held in a Tcl_Obj) that are global across a whole process.  That is,
	they are shared among multiple threads, and epoch and mutex
	protection must govern the validity of cached copies maintained
	in each thread.

	* generic/tclNotify.c:	Modified TclInitNotifier() to tolerate
	being called multiple times in the same thread.

	* generic/tclEvent.c:	Dropped the unused argv0 argument to
	TclInitSubsystems().  Removed machinery to unsure only one
	TclInitNotifier() call per thread, now that that is safe.
	Converted Tcl(Get|Set)LibraryPath to use a ProcessGlobalValue,
	and moved them to tclEncoding.c.
	* generic/tclBasic.c:	Updated caller.

	* generic/tclInt.h:	TclpFindExecutable now returns void.
	* unix/tclUnixFile.c:	
	* win/tclWinFile.c:
	* win/tclWinPipe.c:

	* generic/tclEncoding.c: Built new encoding search initialization
	on a foundation of ProcessGlobalValues, exposing new routines
	Tcl(Get|Set)EncodingSearchPath.  A cache of a map from encoding name
	to directory pathname keeps track of where encodings are available
	for loading.  Tcl_FindExecutable greatly simplified into just
	three function calls.  The "library path" is now misnamed, as its
	only remaining purpose is as a foundation for the default encoding
	search path.

	* generic/tclInterp.c:	Inlined the initScript that is evaluated
	by Tcl_Init().  Added verification after initScript evaluation
	that Tcl can find its installed *.enc files, and that it has
	initialized [encoding system] in agreement with what the environment
	expects.  [tclInit] no longer driven by the value of $::tcl_libPath;
	it largely constructs its own search path now, rather than attempt
	to share one with the encoding system.

	* unix/tclUnixInit.c:	TclpSetInitialEncodings factored so that a new
	* win/tclWinInit.c:	routine TclpGetEncodingNameFromEnvironment
	can reveal that Tcl thinks the [encoding system] should be, even
	when an incomplete encoding search path, or a missing *.enc file
	won't allow that initialization to succeed.  TclpInitLibraryPath
	reworked as an initializer of a ProcessGlobalValue.

	* unix/tclUnixTest.c:	Update implementations of [testfindexecutable],
	[testgetdefenc], and [testsetdefenc].

	* tests/unixInit.test:	Corrected tests to operate properly even
	when a value of TCL_LIBRARY is required to find encodings.
	 
	* generic/tclInt.decls:	New internal stubs: TclGetEncodingSearchPath,
	TclSetEncodingSearchPath, TclpGetEncodingNameFromEnvironment.  These
	are candidates for public exposure by future TIPs.

	* generic/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:
	
	* generic/tclTest.c:	Updated [testencoding] to use
	* tests/encoding.test:	Tcl(Get|Set)EncodingSearchPath.  Updated tests.

2004-11-30  Kevin B. Kenny  <[email protected]>

	* library/clock.tcl: Corrected the regular expressions that match
	a time zone to allow for time zones specified as +HH or -HH.
	* tests/clock.test: Added regression test case for the above issue.
	Thanks to Rolf Ade for reporting this issue
	[http://wiki.tcl.tk/13094]
	* win/tclWinDde.c (Tcl_DdeObjCmd): Corrected a typo that caused a
	compilation failure on VC++.
	
2004-11-29  Andreas Kupries <[email protected]>

	* win/Makefile.in (install-libraries): Brought entry '2004-10-26
	  Don Porter (Tcl Modules)' into the windows world, actually the
	  win/configure buildsystem. The other windows buildsystems (.vc,
	  .bc) still have to be updated as well.

2004-11-26  Andreas Kupries <[email protected]>

	* win/tclWinDde.c (ExecuteRemoteObject): Removed bogus semicolon
	  found at the end of the header for the function definition,
	  terminating it early and preventing a compile. This is likely a
	  fix for '2004-11-25 Donal'. I have to conclude that it is also
	  unknown if the other changes to this file actually pass the
	  testsuite. Running testsuite ... They don't. winDde-6.1
	  fails. This is only a message discrepance, i.e. not too
	  bad. Leaving resolution of that to Pat and Donal.

2004-11-26  Don Porter  <[email protected]>

	* library/auto.tcl (tcl_findLibrary):   Made sure the uniquifying
	operations on the search path does not also normalize.  [Bug 1072136]

2004-11-26  Donal K. Fellows  <[email protected]>

	* unix/configure.in: Simplify the code to check for correctness of
	strstr, strtoul and strtod.
	* unix/tcl.m4 (SC_TCL_CHECK_BROKEN_FUNC): Split a complex stanza
	out of configure.in into its own function. Also force it to do the







|











|




















|





|







|


















|






|

|










|


















|

|
|







3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409

2004-12-01  Donal K. Fellows  <[email protected]>

	* tests/winDde.test: Rewritten to use tcltest2 features more
	thoroughly (reducing the [catch] count!) and fix the problem with
	winDde-6.1 being out of synch with the implementation.

2004-11-30  Don Porter	<[email protected]>

	* library/init.tcl ([unknown]):	Restored the save/restore of
	the variables ::errorCode and ::errorInfo.  This is needed when
	the [::bgerror] command is auto-loaded (as it is by Tk).

	Patch 976520 reworks several of the details involved with
	startup/initialization of the Tcl library, focused on the
	activities of Tcl_FindExecutable().

	* generic/tclIO.c:	Removed bogus claim in comment that
	encoding "iso8859-1" is "built-in" to Tcl.

	* generic/tclInt.h:	Created a new struct ProcessGlobalValue,
	* generic/tclUtil.c:	routines Tcl(Get|Set)ProcessGlobalValue,
	and function type TclInitProcessGlobalValueProc.  Together, these
	take care of the housekeeping for "values" (things that can be
	held in a Tcl_Obj) that are global across a whole process.  That is,
	they are shared among multiple threads, and epoch and mutex
	protection must govern the validity of cached copies maintained
	in each thread.

	* generic/tclNotify.c:	Modified TclInitNotifier() to tolerate
	being called multiple times in the same thread.

	* generic/tclEvent.c:	Dropped the unused argv0 argument to
	TclInitSubsystems().  Removed machinery to unsure only one
	TclInitNotifier() call per thread, now that that is safe.
	Converted Tcl(Get|Set)LibraryPath to use a ProcessGlobalValue,
	and moved them to tclEncoding.c.
	* generic/tclBasic.c:	Updated caller.

	* generic/tclInt.h:	TclpFindExecutable now returns void.
	* unix/tclUnixFile.c:
	* win/tclWinFile.c:
	* win/tclWinPipe.c:

	* generic/tclEncoding.c: Built new encoding search initialization
	on a foundation of ProcessGlobalValues, exposing new routines
	Tcl(Get|Set)EncodingSearchPath.	 A cache of a map from encoding name
	to directory pathname keeps track of where encodings are available
	for loading.  Tcl_FindExecutable greatly simplified into just
	three function calls.  The "library path" is now misnamed, as its
	only remaining purpose is as a foundation for the default encoding
	search path.

	* generic/tclInterp.c:	Inlined the initScript that is evaluated
	by Tcl_Init().	Added verification after initScript evaluation
	that Tcl can find its installed *.enc files, and that it has
	initialized [encoding system] in agreement with what the environment
	expects.  [tclInit] no longer driven by the value of $::tcl_libPath;
	it largely constructs its own search path now, rather than attempt
	to share one with the encoding system.

	* unix/tclUnixInit.c:	TclpSetInitialEncodings factored so that a new
	* win/tclWinInit.c:	routine TclpGetEncodingNameFromEnvironment
	can reveal that Tcl thinks the [encoding system] should be, even
	when an incomplete encoding search path, or a missing *.enc file
	won't allow that initialization to succeed.  TclpInitLibraryPath
	reworked as an initializer of a ProcessGlobalValue.

	* unix/tclUnixTest.c:	Update implementations of [testfindexecutable],
	[testgetdefenc], and [testsetdefenc].

	* tests/unixInit.test:	Corrected tests to operate properly even
	when a value of TCL_LIBRARY is required to find encodings.

	* generic/tclInt.decls:	New internal stubs: TclGetEncodingSearchPath,
	TclSetEncodingSearchPath, TclpGetEncodingNameFromEnvironment.  These
	are candidates for public exposure by future TIPs.

	* generic/tclIntDecls.h:	make genstubs
	* generic/tclStubInit.c:

	* generic/tclTest.c:	Updated [testencoding] to use
	* tests/encoding.test:	Tcl(Get|Set)EncodingSearchPath.	 Updated tests.

2004-11-30  Kevin B. Kenny  <[email protected]>

	* library/clock.tcl: Corrected the regular expressions that match
	a time zone to allow for time zones specified as +HH or -HH.
	* tests/clock.test: Added regression test case for the above issue.
	Thanks to Rolf Ade for reporting this issue
	[http://wiki.tcl.tk/13094]
	* win/tclWinDde.c (Tcl_DdeObjCmd): Corrected a typo that caused a
	compilation failure on VC++.

2004-11-29  Andreas Kupries <[email protected]>

	* win/Makefile.in (install-libraries): Brought entry '2004-10-26
	  Don Porter (Tcl Modules)' into the windows world, actually the
	  win/configure buildsystem. The other windows buildsystems (.vc,
	  .bc) still have to be updated as well.

2004-11-26  Andreas Kupries <[email protected]>

	* win/tclWinDde.c (ExecuteRemoteObject): Removed bogus semicolon
	  found at the end of the header for the function definition,
	  terminating it early and preventing a compile. This is likely a
	  fix for '2004-11-25 Donal'. I have to conclude that it is also
	  unknown if the other changes to this file actually pass the
	  testsuite. Running testsuite ... They don't. winDde-6.1
	  fails. This is only a message discrepance, i.e. not too
	  bad. Leaving resolution of that to Pat and Donal.

2004-11-26  Don Porter	<[email protected]>

	* library/auto.tcl (tcl_findLibrary):	Made sure the uniquifying
	operations on the search path does not also normalize.	[Bug 1072136]

2004-11-26  Donal K. Fellows  <[email protected]>

	* unix/configure.in: Simplify the code to check for correctness of
	strstr, strtoul and strtod.
	* unix/tcl.m4 (SC_TCL_CHECK_BROKEN_FUNC): Split a complex stanza
	out of configure.in into its own function. Also force it to do the
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
	be fixed as well. Done with a load of #ifdef-ery because this hack
	is so ugly nobody should keep it around once Itcl's fixed.

2004-11-25  Reinhard Max  <[email protected]>

	* tests/tcltest.test: The order in which [glob] returns the file
	names is undefined, so tests should not depend on it.
	
2004-11-25  Zoran Vasiljevic <[email protected]>

	* doc/Thread.3:
	* doc/Notifier.3: Added changes from the core-8-4-branch

2004-11-25  Donal K. Fellows  <[email protected]>








|







3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
	be fixed as well. Done with a load of #ifdef-ery because this hack
	is so ugly nobody should keep it around once Itcl's fixed.

2004-11-25  Reinhard Max  <[email protected]>

	* tests/tcltest.test: The order in which [glob] returns the file
	names is undefined, so tests should not depend on it.

2004-11-25  Zoran Vasiljevic <[email protected]>

	* doc/Thread.3:
	* doc/Notifier.3: Added changes from the core-8-4-branch

2004-11-25  Donal K. Fellows  <[email protected]>

211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
	* unix/tclUnixNotfy.c: Corrected all uses of 'select' to
	manage their masks using the FD_CLR, FD_ISSET, FD_SET, and
	FD_ZERO macros rather than bit-whacking that failed under
	Solaris-Sparc-64.  [Bug 1071807]
	* win/tclWinInit.c (TclpInitLibraryPath): Removed unused
	vars 'pathc' and 'pathv' that caused compilation problems
	on VC++ with --enable-symbols.
	
2004-11-24  Don Porter  <[email protected]>

	* unix/tcl.m4 (SC_ENABLE_THREADS):	Corrected failure to determine
	the number of arguments for readdir_r on SunOS systems.  [Bug 1071701]

	* unix/configure:	autoconf-2.57

	* generic/tclCmdIL.c (InfoVarsCmd):	Corrected segfault in new
	* tests/info.test (info-19.6):	trivial matching branch [Bug 1072654]

2004-11-24  Donal K. Fellows  <[email protected]>







|
|


|







3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
	* unix/tclUnixNotfy.c: Corrected all uses of 'select' to
	manage their masks using the FD_CLR, FD_ISSET, FD_SET, and
	FD_ZERO macros rather than bit-whacking that failed under
	Solaris-Sparc-64.  [Bug 1071807]
	* win/tclWinInit.c (TclpInitLibraryPath): Removed unused
	vars 'pathc' and 'pathv' that caused compilation problems
	on VC++ with --enable-symbols.

2004-11-24  Don Porter	<[email protected]>

	* unix/tcl.m4 (SC_ENABLE_THREADS):	Corrected failure to determine
	the number of arguments for readdir_r on SunOS systems.	 [Bug 1071701]

	* unix/configure:	autoconf-2.57

	* generic/tclCmdIL.c (InfoVarsCmd):	Corrected segfault in new
	* tests/info.test (info-19.6):	trivial matching branch [Bug 1072654]

2004-11-24  Donal K. Fellows  <[email protected]>
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
	* unix/tcl.m4 (SC_ENABLE_THREADS): Check for a 2
	argument version of readdir_r that is known to
	exists under IRIX 5.3.
	* unix/tclUnixThrd.c (TclpReaddir): Use either
	2 arg or 3 arg version of readdir_r.
	[Bug 1001325]

2004-11-22  Don Porter  <[email protected]>

	* unix/tclUnixInit.c (TclpInitLibraryPath):	Purged dead code that
	* win/tclWinInit.c (TclpInitLibraryPath):	used to extend the
	"library path".  Search path construction for init.tcl is now done
	within the [tclInit] proc.

	* generic/tclInterp.c:	Restored several directories to the search
	* tests/unixInit.test:	path used to locate init.tcl within [tclInit].
	This change does not restore any directories to the encoding search
	path, so should still avoid the price of an unreasonably large number
	of filesystem accesses during encoding initialization at startup
	[Bug 976438]

2004-11-22  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix and new test for [Bug 1043129] in
	* tests/fileSystem.test: the treatment of backslashes in file
	join on Windows.

2004-11-21  Don Porter  <[email protected]>

	* doc/AddErrInfo.3:	Typo corrections (Thanks Daniel South).
	* doc/interp.n:

2004-11-19  Don Porter  <[email protected]>

	* doc/AddErrInfo.3:	Docs for Tcl_(Get|Set)ReturnOptions.  [TIP 227]

	* doc/AddErrInfo.3:
	* doc/Async.3:		Documentation updates to replace references
	* doc/BackgdErr.3:	to global variable ::errorInfo and ::errorCode
	* doc/SaveResult.3:	and to the ::bgerror command with references







|



|















|




|







3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
	* unix/tcl.m4 (SC_ENABLE_THREADS): Check for a 2
	argument version of readdir_r that is known to
	exists under IRIX 5.3.
	* unix/tclUnixThrd.c (TclpReaddir): Use either
	2 arg or 3 arg version of readdir_r.
	[Bug 1001325]

2004-11-22  Don Porter	<[email protected]>

	* unix/tclUnixInit.c (TclpInitLibraryPath):	Purged dead code that
	* win/tclWinInit.c (TclpInitLibraryPath):	used to extend the
	"library path".	 Search path construction for init.tcl is now done
	within the [tclInit] proc.

	* generic/tclInterp.c:	Restored several directories to the search
	* tests/unixInit.test:	path used to locate init.tcl within [tclInit].
	This change does not restore any directories to the encoding search
	path, so should still avoid the price of an unreasonably large number
	of filesystem accesses during encoding initialization at startup
	[Bug 976438]

2004-11-22  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix and new test for [Bug 1043129] in
	* tests/fileSystem.test: the treatment of backslashes in file
	join on Windows.

2004-11-21  Don Porter	<[email protected]>

	* doc/AddErrInfo.3:	Typo corrections (Thanks Daniel South).
	* doc/interp.n:

2004-11-19  Don Porter	<[email protected]>

	* doc/AddErrInfo.3:	Docs for Tcl_(Get|Set)ReturnOptions.  [TIP 227]

	* doc/AddErrInfo.3:
	* doc/Async.3:		Documentation updates to replace references
	* doc/BackgdErr.3:	to global variable ::errorInfo and ::errorCode
	* doc/SaveResult.3:	and to the ::bgerror command with references
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
	* doc/update.n:

	* tests/unixInit.test:	Removed "knownBug" constraints to prompt
	bug fixing before 8.5a2 release.

2004-11-19  Daniel Steffen  <[email protected]>

	* macosx/Makefile: 
	* unix/configure.in: 
	* unix/tclUnixInit.c (MacOSXGetLibraryPath): changed detection
	of tcl framework build when determining tclLibPath from overloaded
	TCL_LIBRARY to configuration define TCL_FRAMEWORK. [Bug 1068088]

	* unix/configure: autoconf-2.57
	* unix/tclConfig.h.in: autoheader-2.57

2004-11-18  Don Porter  <[email protected]>

	* doc/SaveResult.3:	Documentation for Tcl_*InterpState (TIP 226).

	* generic/tclEvent.c (HandleBgErrors):	Simplified program flow.

	* tests/basic.test:	Updated functional (not testing) uses of
	* tests/io.test:	[bgerror] to make use of [interp bgerror].
	* tests/socket.test:
	* tests/timer.test:

	* tests/interp.test (interp-36.*):	[interp bgerror] tests.

	* generic/tclInterp.c:	Corrected [interp bgerror] error messages.

2004-11-18  Reinhard Max  <[email protected]>

	* unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of
	* unix/configure.in:                patch #996085, that introduces
	* unix/Makefile.in:                 --enable-man-suffix.

	* unix/installManPage:              added
	* unix/mkLinks.tcl:                 removed
	* unix/mkLinks:                     removed
	* unix/configure:                   generated

	* unix/Makefile.in:                 Don't install tclConfig.h .

2004-11-17  Don Porter  <[email protected]>

	* unix/configure.in:	The change below reveals that the public
	data type Tcl_StatBuf relies on config information.  For now,
	disabled the use of the tclConfig.h file until its full impact
	on Tcl's interface can be assessed.

	* unix/configure:	autoconf-2.57

	* generic/tcl.h:	Moved the #include "tclConfig.h" out of
	* generic/tclInt.h:	tcl.h.  The config settings are not part of
	* generic/tclPort.:	the public interface, and having it there
	breaks compiled against uninstalled Tcl and extensions using
	autoconf-2.5*.

2004-11-16  Jeff Hobbs  <[email protected]>

	* unix/tclUnixChan.c (TtySetOptionProc): fixed crash configuring
	-ttycontrol on a channel. [Bug 1067708]

2004-11-16  Don Porter  <[email protected]>

	* generic/tclIOUtil.c (TclFSEpochOk):	There were two code paths
	via which the thread copy of filesystemEpoch could be synched with
	the master copy, but only one kept the filesystem list cache up
	to date.  Fix routes everything through  a single code path.
	[Bug 1035775].

2004-11-16  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Stop architecture flags to 'ld'
	from getting lost when [load] is disabled. [Bug 1016796]

2004-11-16  Daniel Steffen  <[email protected]>

	* generic/tcl.h:
	* unix/configure.in: changed HAVE_CONFIG_H to HAVE_TCL_CONFIG_H.

	* unix/configure: autoconf-2.57

2004-11-15  Don Porter  <[email protected]>

	* generic/tclInt.h:	Added comment warning that the old
	ERR_IN_PROGRESS and ERROR_CODE_SET flag values should not be re-used
	for the sake of those extensions that have accessed them.

	* generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed
	* tests/trace.test (trace-33.1):        to permit a variable trace
	created with [trace variable] to be destroyed with [trace remove].
	Thanks to Keith Vetter for the report.

2004-11-15  Donal K. Fellows  <[email protected]>

	* doc/tclvars.n: Added section to documentation on global
	variables that are specific to tclsh and wish. [Patch 1065732]

2004-11-12  Jeff Hobbs  <[email protected]>

	* generic/tclEncoding.c (TableFromUtfProc): correct crash
	condition when TCL_UTF_MAX == 6. [Bug 1004065]

2004-11-12  Donal K. Fellows  <[email protected]>

	* doc/interp.n: Basic documentation of the TIP#221 API.

2004-11-12  Don Porter  <[email protected]>

	TIP #221 IMPLEMENTATION
	* generic/tclBasic.c:	Define [::tcl::Bgerror] in new interps.
	* generic/tclEvent.c:	Update Tcl_BackgroundError to make use
				of the registered [interp bgerror] command.
	* generic/tclInterp.c:	New [interp bgerror] subcommand.
	* tests/interp.test:	syntax tests updated.

	TIP #226 IMPLEMENTATION
	* generic/tcl.decls:	Stubs for Tcl_(Save|Restore|Discard)InterpState
	* generic/tcl.h:	New public opaque type, Tcl_InterpState.
	* generic/tclInt.h:	Drop old private declarations.  Add
				Tcl(Get|Set)BgErrorHandler
	* generic/tclResult.c:	Tcl_*InterpState implementations.
	* generic/tclDictObj.c:	Update callers.
	* generic/tclIOGT.c:
	* generic/tclTrace.c:

	TIP #227 IMPLEMENTATION







|
|







|

















|
|

|
|
|
|

|

|









|




|




|




|














|






|








|








|











|







3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
	* doc/update.n:

	* tests/unixInit.test:	Removed "knownBug" constraints to prompt
	bug fixing before 8.5a2 release.

2004-11-19  Daniel Steffen  <[email protected]>

	* macosx/Makefile:
	* unix/configure.in:
	* unix/tclUnixInit.c (MacOSXGetLibraryPath): changed detection
	of tcl framework build when determining tclLibPath from overloaded
	TCL_LIBRARY to configuration define TCL_FRAMEWORK. [Bug 1068088]

	* unix/configure: autoconf-2.57
	* unix/tclConfig.h.in: autoheader-2.57

2004-11-18  Don Porter	<[email protected]>

	* doc/SaveResult.3:	Documentation for Tcl_*InterpState (TIP 226).

	* generic/tclEvent.c (HandleBgErrors):	Simplified program flow.

	* tests/basic.test:	Updated functional (not testing) uses of
	* tests/io.test:	[bgerror] to make use of [interp bgerror].
	* tests/socket.test:
	* tests/timer.test:

	* tests/interp.test (interp-36.*):	[interp bgerror] tests.

	* generic/tclInterp.c:	Corrected [interp bgerror] error messages.

2004-11-18  Reinhard Max  <[email protected]>

	* unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of
	* unix/configure.in:		    patch #996085, that introduces
	* unix/Makefile.in:		    --enable-man-suffix.

	* unix/installManPage:		    added
	* unix/mkLinks.tcl:		    removed
	* unix/mkLinks:			    removed
	* unix/configure:		    generated

	* unix/Makefile.in:		    Don't install tclConfig.h .

2004-11-17  Don Porter	<[email protected]>

	* unix/configure.in:	The change below reveals that the public
	data type Tcl_StatBuf relies on config information.  For now,
	disabled the use of the tclConfig.h file until its full impact
	on Tcl's interface can be assessed.

	* unix/configure:	autoconf-2.57

	* generic/tcl.h:	Moved the #include "tclConfig.h" out of
	* generic/tclInt.h:	tcl.h.	The config settings are not part of
	* generic/tclPort.:	the public interface, and having it there
	breaks compiled against uninstalled Tcl and extensions using
	autoconf-2.5*.

2004-11-16  Jeff Hobbs	<[email protected]>

	* unix/tclUnixChan.c (TtySetOptionProc): fixed crash configuring
	-ttycontrol on a channel. [Bug 1067708]

2004-11-16  Don Porter	<[email protected]>

	* generic/tclIOUtil.c (TclFSEpochOk):	There were two code paths
	via which the thread copy of filesystemEpoch could be synched with
	the master copy, but only one kept the filesystem list cache up
	to date.  Fix routes everything through	 a single code path.
	[Bug 1035775].

2004-11-16  Donal K. Fellows  <[email protected]>

	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Stop architecture flags to 'ld'
	from getting lost when [load] is disabled. [Bug 1016796]

2004-11-16  Daniel Steffen  <[email protected]>

	* generic/tcl.h:
	* unix/configure.in: changed HAVE_CONFIG_H to HAVE_TCL_CONFIG_H.

	* unix/configure: autoconf-2.57

2004-11-15  Don Porter	<[email protected]>

	* generic/tclInt.h:	Added comment warning that the old
	ERR_IN_PROGRESS and ERROR_CODE_SET flag values should not be re-used
	for the sake of those extensions that have accessed them.

	* generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed
	* tests/trace.test (trace-33.1):	to permit a variable trace
	created with [trace variable] to be destroyed with [trace remove].
	Thanks to Keith Vetter for the report.

2004-11-15  Donal K. Fellows  <[email protected]>

	* doc/tclvars.n: Added section to documentation on global
	variables that are specific to tclsh and wish. [Patch 1065732]

2004-11-12  Jeff Hobbs	<[email protected]>

	* generic/tclEncoding.c (TableFromUtfProc): correct crash
	condition when TCL_UTF_MAX == 6. [Bug 1004065]

2004-11-12  Donal K. Fellows  <[email protected]>

	* doc/interp.n: Basic documentation of the TIP#221 API.

2004-11-12  Don Porter	<[email protected]>

	TIP #221 IMPLEMENTATION
	* generic/tclBasic.c:	Define [::tcl::Bgerror] in new interps.
	* generic/tclEvent.c:	Update Tcl_BackgroundError to make use
				of the registered [interp bgerror] command.
	* generic/tclInterp.c:	New [interp bgerror] subcommand.
	* tests/interp.test:	syntax tests updated.

	TIP #226 IMPLEMENTATION
	* generic/tcl.decls:	Stubs for Tcl_(Save|Restore|Discard)InterpState
	* generic/tcl.h:	New public opaque type, Tcl_InterpState.
	* generic/tclInt.h:	Drop old private declarations.	Add
				Tcl(Get|Set)BgErrorHandler
	* generic/tclResult.c:	Tcl_*InterpState implementations.
	* generic/tclDictObj.c:	Update callers.
	* generic/tclIOGT.c:
	* generic/tclTrace.c:

	TIP #227 IMPLEMENTATION
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
	* generic/tclVar.c:	it is verifiably after tclConfig.h inclusion.

2004-11-12  Daniel Steffen  <[email protected]>

	* generic/tcl.h:
	* generic/tclInt.h:
	* unix/Makefile.in: include tclConfig.h from tcl.h and install it
	as a public header. Normalized compiler include path order to 
	-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR}.

	* unix/dltest/Makefile.in: add ${BUILD_DIR}/.. to include path
	to pick up tclConfig.h.

	* unix/tclUnixInit.c: moved check for HAVE_CFBUNDLE define after
	#include "tclInt.h" to ensure tclConfig.h has been included.

2004-11-12  Reinhard Max  <[email protected]>

	* unix/config.h.in:
	* unix/tclConfig.h.in:	renamed

	* unix/Makefile.in:	Completed support for config header,
	* unix/configure.in:	fixed building outside of the unix dir,
	* unix/tclAppinit.c:	and reflected the name change of config.h.
	* generic/tclInt.h:

	* unix/configure:       generated

2004-11-12  Donal K. Fellows  <[email protected]>

	* unix/config.h.in:	Allow configure to put all the C #defs into
	* unix/configure.in:	a file (called config.h) so that Unix builds
	* unix/tcl.m4:		now take far fewer lines of scrollback to
	* unix/Makefile.in:	proceed (making it less likely that any errors







|


















|







3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
	* generic/tclVar.c:	it is verifiably after tclConfig.h inclusion.

2004-11-12  Daniel Steffen  <[email protected]>

	* generic/tcl.h:
	* generic/tclInt.h:
	* unix/Makefile.in: include tclConfig.h from tcl.h and install it
	as a public header. Normalized compiler include path order to
	-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR}.

	* unix/dltest/Makefile.in: add ${BUILD_DIR}/.. to include path
	to pick up tclConfig.h.

	* unix/tclUnixInit.c: moved check for HAVE_CFBUNDLE define after
	#include "tclInt.h" to ensure tclConfig.h has been included.

2004-11-12  Reinhard Max  <[email protected]>

	* unix/config.h.in:
	* unix/tclConfig.h.in:	renamed

	* unix/Makefile.in:	Completed support for config header,
	* unix/configure.in:	fixed building outside of the unix dir,
	* unix/tclAppinit.c:	and reflected the name change of config.h.
	* generic/tclInt.h:

	* unix/configure:	generated

2004-11-12  Donal K. Fellows  <[email protected]>

	* unix/config.h.in:	Allow configure to put all the C #defs into
	* unix/configure.in:	a file (called config.h) so that Unix builds
	* unix/tcl.m4:		now take far fewer lines of scrollback to
	* unix/Makefile.in:	proceed (making it less likely that any errors
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
	are still very cryptic, but they appear to have to be that way.
	The number of skipped tests has increased, but now the skipped
	tests have much more meaningful content.

	* tests/tm.test (genpaths): Add a [file normalize] so we pick up
	Windows drive letters, etc. [Bug 1053568]

2004-11-04  Don Porter  <[email protected]>

	* changes:	Updates toward an 8.5a2 release.

2004-11-03  Kevin B. Kenny  <[email protected]>

	* library/clock.tcl (FreeScan): Fixed a bug where scanning
	"Monday" with a base time other than midnight incorrectly carried







|







3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
	are still very cryptic, but they appear to have to be that way.
	The number of skipped tests has increased, but now the skipped
	tests have much more meaningful content.

	* tests/tm.test (genpaths): Add a [file normalize] so we pick up
	Windows drive letters, etc. [Bug 1053568]

2004-11-04  Don Porter	<[email protected]>

	* changes:	Updates toward an 8.5a2 release.

2004-11-03  Kevin B. Kenny  <[email protected]>

	* library/clock.tcl (FreeScan): Fixed a bug where scanning
	"Monday" with a base time other than midnight incorrectly carried
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
	* win/tclWinPort.h:		to prior the inclusion of the Stubs
	headers as they are now resetting TCL_STORAGE_CLASS.  Removed
	extrainious reset from tclWinPort.h.  [Patch 1055668]

	* generic/tclCompile.h: Removed	extrainious reset of
	TCL_STORAGE_CLASS missed in my last edit.

2004-11-03  Don Porter  <[email protected]>

	* library/init.tcl ([unknown]):	Corrections to the 2004-10-25 mods
	to Aunt ??? in [unknown].  Flaws revealed by Itcl test suite, which
	still apparently relies on this brokenness.  Also added comment
	suggesting the error message that any code using this hack *ought*
	to receive in reply.








|







3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
	* win/tclWinPort.h:		to prior the inclusion of the Stubs
	headers as they are now resetting TCL_STORAGE_CLASS.  Removed
	extrainious reset from tclWinPort.h.  [Patch 1055668]

	* generic/tclCompile.h: Removed	extrainious reset of
	TCL_STORAGE_CLASS missed in my last edit.

2004-11-03  Don Porter	<[email protected]>

	* library/init.tcl ([unknown]):	Corrections to the 2004-10-25 mods
	to Aunt ??? in [unknown].  Flaws revealed by Itcl test suite, which
	still apparently relies on this brokenness.  Also added comment
	suggesting the error message that any code using this hack *ought*
	to receive in reply.

624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669

	* generic/tclInt.h: added a check for #ifdef __cplusplus around
	the #define of MODULE_SCOPE.  About the only time it would be
	problem is when someone is statically linking to Tcl and accessing
	internals from a C++ file and has name mangling issues from the
	lack of "C" after 'extern' [Patch 1055668].
	* generic/tclCompile.h: Exchanged use of the EXTERN macro to the
	new MODULE_SCOPE macro.  Lowered exported internals count by 35.
	[Patch 1055668]
	* win/tclWinInt.h:
	* win/tclWinPort.h: exported internals dropped by a count of 14.
	* generic/tclFileSystem.h: Added use of MODULE_SCOPE on protos.
	* generic/tclRegexp.h: manipulating TCL_STORAGE_CLASS unnecessary.

2004-11-02  Don Porter  <[email protected]>

	* library/tcltest/tcltest.tcl:		Corrected some misleading
	* tests/tcltest.test (tcltest-26.1,2):	displays of ::errorInfo and
	::errorCode information when the -setup, -body, and/or -cleanup scripts
	return an unexpected return code.  Thanks to Robert Seeger for the
	fix. [RFE 1017151].

2004-11-02  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): Improved version of
	the NaN fix from Miguel Sofer. [Bug 761471]

2004-11-02  Kevin Kenny  <[email protected]>

	* library/tzdata/America/Cuiaba: Change to DST rules for
	* library/tzdata/America/Havana: autumn of 2004. 
	[ftp://elsie.nci.nih.gov/pub/tzdata2004g.tar.gz]

	* tools/tclZIC.tcl: Updated to be compatible with recent
	changes in library/clock.tcl.

2004-11-02  Vince Darley  <[email protected]>

	* win/tclWinFile.c: Simplify TclpUtime to use Tcl_FSGetNativePath, 
	and add comments.

2004-11-02  Donal K. Fellows  <[email protected]>

	* generic/tclInt.h: Change uses of EXTERN to MODULE_SCOPE (defined
	in this file too to be 'extern' if not overridden) as nothing
	declared in tclInt.h is supposed to be visible outside the Tcl







|






|












|


|







|







3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912

	* generic/tclInt.h: added a check for #ifdef __cplusplus around
	the #define of MODULE_SCOPE.  About the only time it would be
	problem is when someone is statically linking to Tcl and accessing
	internals from a C++ file and has name mangling issues from the
	lack of "C" after 'extern' [Patch 1055668].
	* generic/tclCompile.h: Exchanged use of the EXTERN macro to the
	new MODULE_SCOPE macro.	 Lowered exported internals count by 35.
	[Patch 1055668]
	* win/tclWinInt.h:
	* win/tclWinPort.h: exported internals dropped by a count of 14.
	* generic/tclFileSystem.h: Added use of MODULE_SCOPE on protos.
	* generic/tclRegexp.h: manipulating TCL_STORAGE_CLASS unnecessary.

2004-11-02  Don Porter	<[email protected]>

	* library/tcltest/tcltest.tcl:		Corrected some misleading
	* tests/tcltest.test (tcltest-26.1,2):	displays of ::errorInfo and
	::errorCode information when the -setup, -body, and/or -cleanup scripts
	return an unexpected return code.  Thanks to Robert Seeger for the
	fix. [RFE 1017151].

2004-11-02  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): Improved version of
	the NaN fix from Miguel Sofer. [Bug 761471]

2004-11-02  Kevin Kenny	 <[email protected]>

	* library/tzdata/America/Cuiaba: Change to DST rules for
	* library/tzdata/America/Havana: autumn of 2004.
	[ftp://elsie.nci.nih.gov/pub/tzdata2004g.tar.gz]

	* tools/tclZIC.tcl: Updated to be compatible with recent
	changes in library/clock.tcl.

2004-11-02  Vince Darley  <[email protected]>

	* win/tclWinFile.c: Simplify TclpUtime to use Tcl_FSGetNativePath,
	and add comments.

2004-11-02  Donal K. Fellows  <[email protected]>

	* generic/tclInt.h: Change uses of EXTERN to MODULE_SCOPE (defined
	in this file too to be 'extern' if not overridden) as nothing
	declared in tclInt.h is supposed to be visible outside the Tcl
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
	* tests/io.test (io-40.3): Convert umask2 test constraint into a
	form that most people will be able to satisfy.

	* tests/cmdAH.test (cmdAH-8.45): Removed broken test constraint.
	It didn't do what it was intended to do, and it implied the other
	correct constraint. [Bug 1053908]

	* generic/tclCmdIL.c (InfoGlobalsCmd): 
	* tests/info.test (info-8.4): Strip leading global-namespace
	specifiers from the pattern argument. [Bug 1057461]

2004-10-30  Kevin Kenny  <[email protected]>

	* generic/clock.c: Replaced WIN32 macro with __WIN32__.
	[Bug 1054357].  Thanks to David Gravereaux for the patch.
	* win/tclWinFile.c: Removed a long-standing bug that causes
	incorrect conversion between file time and UTC time if
	the file time is recorded in a different Daylight Saving Time
	status than the current one. [Bug 926106]

2004-10-29  Don Porter  <[email protected]>

	* library/tcltest/tcltest.tcl:	Correct reaction to errors in the
	obsolete processCmdLineArgsHook.	[Bug 1055673]
	* library/tcltest/pkgIndex.tcl:	Bump to tcltest 2.2.7
	* unix/Makefile.in:
	* tests/all.tcl:	Update to use [tcltest::configure].








|



|


|





|







3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
	* tests/io.test (io-40.3): Convert umask2 test constraint into a
	form that most people will be able to satisfy.

	* tests/cmdAH.test (cmdAH-8.45): Removed broken test constraint.
	It didn't do what it was intended to do, and it implied the other
	correct constraint. [Bug 1053908]

	* generic/tclCmdIL.c (InfoGlobalsCmd):
	* tests/info.test (info-8.4): Strip leading global-namespace
	specifiers from the pattern argument. [Bug 1057461]

2004-10-30  Kevin Kenny	 <[email protected]>

	* generic/clock.c: Replaced WIN32 macro with __WIN32__.
	[Bug 1054357].	Thanks to David Gravereaux for the patch.
	* win/tclWinFile.c: Removed a long-standing bug that causes
	incorrect conversion between file time and UTC time if
	the file time is recorded in a different Daylight Saving Time
	status than the current one. [Bug 926106]

2004-10-29  Don Porter	<[email protected]>

	* library/tcltest/tcltest.tcl:	Correct reaction to errors in the
	obsolete processCmdLineArgsHook.	[Bug 1055673]
	* library/tcltest/pkgIndex.tcl:	Bump to tcltest 2.2.7
	* unix/Makefile.in:
	* tests/all.tcl:	Update to use [tcltest::configure].

734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
	in doing this.

	* tests/namespace.test (namespace-50.*): Tests of ensemble
	subcommand error message rewriting.
	* generic/tclProc.c (TclObjInterpProc): Make procedures implement
	their wrong-num-args message using Tcl_WrongNumArgs instead of
	something baked-at-home.
	* generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd): 
	Added test of ensemble-hood (available to rest of core) and made
	ensembles set up the rewriting for Tcl_WrongNumArgs to take
	advantage of.
	* generic/tclInt.h (Interp.ensembleRewrite): Extra fields.
	* generic/tclIndexObj.c (Tcl_WrongNumArgs): Add knowledge of what
	is going on in ensembles' command rewriting so this command can
	generate the right error message itself.
	* generic/tclBasic.c (Tcl_CreateInterp, TclEvalObjvInternal):
	Added code to initialize (as empty) the rewriting fields and reset
	them when we leak outside an ensemble implementation.

2004-10-28  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (INST_START_CMD):
	* tests/execute.test (execute-8.3): fix for execution stack
	corruption [Bug 1055676]. Credit dgp for detective work and fix. 

2004-10-27  Don Porter  <[email protected]>

	* tests/socket.test (socket-13.1):      Balanced [makeFile] and
	[removeFile] commands.

	* tests/clock.test:	Correct duplicate test names.
	* tests/namespace.test:
	* tests/string.test:
	* tests/io.test (io-50.4):	Use namespace variables.








|















|

|

|







3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
	in doing this.

	* tests/namespace.test (namespace-50.*): Tests of ensemble
	subcommand error message rewriting.
	* generic/tclProc.c (TclObjInterpProc): Make procedures implement
	their wrong-num-args message using Tcl_WrongNumArgs instead of
	something baked-at-home.
	* generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd):
	Added test of ensemble-hood (available to rest of core) and made
	ensembles set up the rewriting for Tcl_WrongNumArgs to take
	advantage of.
	* generic/tclInt.h (Interp.ensembleRewrite): Extra fields.
	* generic/tclIndexObj.c (Tcl_WrongNumArgs): Add knowledge of what
	is going on in ensembles' command rewriting so this command can
	generate the right error message itself.
	* generic/tclBasic.c (Tcl_CreateInterp, TclEvalObjvInternal):
	Added code to initialize (as empty) the rewriting fields and reset
	them when we leak outside an ensemble implementation.

2004-10-28  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (INST_START_CMD):
	* tests/execute.test (execute-8.3): fix for execution stack
	corruption [Bug 1055676]. Credit dgp for detective work and fix.

2004-10-27  Don Porter	<[email protected]>

	* tests/socket.test (socket-13.1):	Balanced [makeFile] and
	[removeFile] commands.

	* tests/clock.test:	Correct duplicate test names.
	* tests/namespace.test:
	* tests/string.test:
	* tests/io.test (io-50.4):	Use namespace variables.

804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841

	* tests/tm.test:  Expanded on the testsuite entered by Donal.
	* library/tm.tcl: Even found bugs, these have been corrected.

2004-10-26  Kevin Kenny <[email protected]>

	* tests/format.test (format-19.1): Additional regression test for
	                                   Bug 868489.

2004-10-27  Donal K. Fellows  <[email protected]>

	* doc/*.n: Many small general documentation fixes.

2004-10-26  David Gravereaux <[email protected]>

	* generic/tclPipe.c (TclCleanupChildren): bad cast of resolvedPid
	caused PIDs on win95 to go negative.  winpipe-4.2 brought this to
	the surface.  Fixed with sprintf in place of TclFormatInt.  Thanks
	to hgiese [Patch 767676]

2004-10-26  Andreas Kupries <[email protected]>

	* library/tm.tcl (::tcl::tm::Defaults): Added a second [file
	  dirname] around the location of the executable. This fixes [Tcl
	  SF Bug 1038705]. Instable of a bogus "foo/bin/lib" we now have
	  the correct "foo/lib" as a base path for modules.

2004-10-26  Don Porter  <[email protected]>

	* generic/tclParse.c (Tcl_SubstObj):	Fix for failed subst-12.3 test.
	* tests/subst.test (subst-12.3-5):      More tests for Bug 1036649.

	* unix/Makefile.in (install-libraries): Updated the installation
	of the http, msgcat, and tcltest packages to install as Tcl Modules
	on Unix systems.  Other platform Makefiles still need updating.
	[Patch 1054370]

	* tests/basic.test:	Added missing constraints.







|



















|


|







4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084

	* tests/tm.test:  Expanded on the testsuite entered by Donal.
	* library/tm.tcl: Even found bugs, these have been corrected.

2004-10-26  Kevin Kenny <[email protected]>

	* tests/format.test (format-19.1): Additional regression test for
					   Bug 868489.

2004-10-27  Donal K. Fellows  <[email protected]>

	* doc/*.n: Many small general documentation fixes.

2004-10-26  David Gravereaux <[email protected]>

	* generic/tclPipe.c (TclCleanupChildren): bad cast of resolvedPid
	caused PIDs on win95 to go negative.  winpipe-4.2 brought this to
	the surface.  Fixed with sprintf in place of TclFormatInt.  Thanks
	to hgiese [Patch 767676]

2004-10-26  Andreas Kupries <[email protected]>

	* library/tm.tcl (::tcl::tm::Defaults): Added a second [file
	  dirname] around the location of the executable. This fixes [Tcl
	  SF Bug 1038705]. Instable of a bogus "foo/bin/lib" we now have
	  the correct "foo/lib" as a base path for modules.

2004-10-26  Don Porter	<[email protected]>

	* generic/tclParse.c (Tcl_SubstObj):	Fix for failed subst-12.3 test.
	* tests/subst.test (subst-12.3-5):	More tests for Bug 1036649.

	* unix/Makefile.in (install-libraries): Updated the installation
	of the http, msgcat, and tcltest packages to install as Tcl Modules
	on Unix systems.  Other platform Makefiles still need updating.
	[Patch 1054370]

	* tests/basic.test:	Added missing constraints.
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
	single characters. [Bug 1048005]
	* doc/info.n (procs): Clarified that the pattern argument may have
	namespace separators in it. [Bug 1047928]

	* tests/cmdAH.test (cmdAH-8.45): Simplify in the hope that the
	reasons for [Bug 1053908] will become clearer.

2004-10-25  Don Porter  <[email protected]>

	* generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode):
	Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer
	needed for protection because routines like Tcl_SetErrorCode() and
	Tcl_AddErrorInfo() can no longer re-enter bytecode execution.

	* generic/tclResult.c (TclProcessReturn): Bug fix.  Be sure that







|







4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
	single characters. [Bug 1048005]
	* doc/info.n (procs): Clarified that the pattern argument may have
	namespace separators in it. [Bug 1047928]

	* tests/cmdAH.test (cmdAH-8.45): Simplify in the hope that the
	reasons for [Bug 1053908] will become clearer.

2004-10-25  Don Porter	<[email protected]>

	* generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode):
	Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer
	needed for protection because routines like Tcl_SetErrorCode() and
	Tcl_AddErrorInfo() can no longer re-enter bytecode execution.

	* generic/tclResult.c (TclProcessReturn): Bug fix.  Be sure that
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
	* library/clock.tcl	remaining references to global vars
	* library/init.tcl	::errorInfo and ::errorCode.

	* generic/tclMain.c (Tcl_Main):	Updated to make use of
	TclGetReturnOptions instead of ::errorInfo variable.

	* generic/tclInterp.c (tclInit): Bug fix.  Access dict variables
	with [dict get], not array syntax.  

2004-10-25  Donal K. Fellows  <[email protected]>

	* tests/tm.test: Rewrote the tests to actually perform syntax
	checks on the public API. Added a new test (currently failing) to
	indicate that the test suite is not complete yet.
	* library/tm.tcl (path): Rewrote to turn this command into an
	ensemble to make it faster and simpler.

2004-10-24  Miguel Sofer <[email protected]>

	* generic/tclCmdIL.c:
	* generic/tclExecute.c:
	* generic/tclInt.h:
	* generic/tclTrace.c: defined new macros to get/set the flags of 
	variables. The only files that still access the flag values
	directly are tclCompCmds.c, tclCompile.c, tclProc.c and tclVar.c

2004-10-24  Don Porter  <[email protected]>

	* generic/tclBasic.c (Tcl_LogCommandInfo,Tcl_AddObjErrorInfo):
	Shift the initialization of errorCode to NONE to more central
	location.

	* generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors):
	Rewrite to build on the new TclGet/SetReturnOptions routines.







|














|



|







4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
	* library/clock.tcl	remaining references to global vars
	* library/init.tcl	::errorInfo and ::errorCode.

	* generic/tclMain.c (Tcl_Main):	Updated to make use of
	TclGetReturnOptions instead of ::errorInfo variable.

	* generic/tclInterp.c (tclInit): Bug fix.  Access dict variables
	with [dict get], not array syntax.

2004-10-25  Donal K. Fellows  <[email protected]>

	* tests/tm.test: Rewrote the tests to actually perform syntax
	checks on the public API. Added a new test (currently failing) to
	indicate that the test suite is not complete yet.
	* library/tm.tcl (path): Rewrote to turn this command into an
	ensemble to make it faster and simpler.

2004-10-24  Miguel Sofer <[email protected]>

	* generic/tclCmdIL.c:
	* generic/tclExecute.c:
	* generic/tclInt.h:
	* generic/tclTrace.c: defined new macros to get/set the flags of
	variables. The only files that still access the flag values
	directly are tclCompCmds.c, tclCompile.c, tclProc.c and tclVar.c

2004-10-24  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_LogCommandInfo,Tcl_AddObjErrorInfo):
	Shift the initialization of errorCode to NONE to more central
	location.

	* generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors):
	Rewrite to build on the new TclGet/SetReturnOptions routines.
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
	* tests/clock.test: Added regression test cases that covers
	both bugs.
	Thanks to Todd M. Helfter <[email protected]> for
	finding these bugs.

2004-10-22  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclCompEvalObj, Tcl_ExprObj): 
	* generic/tclProc.c (TclProcCompileProc): Always call object
	freeIntRepProc's in the same way.

2004-10-22  Miguel Sofer <[email protected]>

	* generic/tclVar.c: fixed bug in commit of 2004-07-23, which was
	causing a leak of Proc structures and failure of compile-12.1. Two
	lines were 'zombies' from the previous way localVarNames
	worked. Credit dgp for finding this.

2004-10-21  Don Porter  <[email protected]>

	* generic/tclInt.h (Interp):
	* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp):
	* generic/tclResult.c (GetKeys,ReleaseKeys,etc.):
	Moved the key values of the return options dictionary out of
	private fields of the Interp struct and into thread-static
	values managed in tclResult.c.







|










|







4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
	* tests/clock.test: Added regression test cases that covers
	both bugs.
	Thanks to Todd M. Helfter <[email protected]> for
	finding these bugs.

2004-10-22  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclCompEvalObj, Tcl_ExprObj):
	* generic/tclProc.c (TclProcCompileProc): Always call object
	freeIntRepProc's in the same way.

2004-10-22  Miguel Sofer <[email protected]>

	* generic/tclVar.c: fixed bug in commit of 2004-07-23, which was
	causing a leak of Proc structures and failure of compile-12.1. Two
	lines were 'zombies' from the previous way localVarNames
	worked. Credit dgp for finding this.

2004-10-21  Don Porter	<[email protected]>

	* generic/tclInt.h (Interp):
	* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp):
	* generic/tclResult.c (GetKeys,ReleaseKeys,etc.):
	Moved the key values of the return options dictionary out of
	private fields of the Interp struct and into thread-static
	values managed in tclResult.c.
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
	* generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions):
	Move internal utility routines from tclCmdMZ.c to tclResult.c.

	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp):
	* generic/tclResult.c (TclTransferResult):	Rework so that
	iPtr->returnOpts can be NULL when there are no special options.

	* generic/tclResult.c (TclRestoreInterpState):  Plug potential
	memory leak.

2004-10-21  Kevin B. Kenny  <[email protected]>

	* generic/tclBasic.c: Various changes to [clock format] that,
	* generic/tclClock.c: together, make it roughly twice as fast
	* generic/tclInt.h:   while all tests in the test suite
	* library/clock.tcl:  continue to pass.

2004-10-20  Andreas Kupries <[email protected]>

	* win/Makefile.in (install-msgs):   Fixed a problem with the
	* win/Makefile.in (install-tzdata): installation of timezone data
	  and message catalogs. They used the installed tcl library
	  directory, not the source library. Before it was installed.
	  Switched to source lib dir. Thanks to Kevin for the help in
	  figuring this out.

2004-10-20  Don Porter  <[email protected]>

	* generic/tclThreadTest.c (ThreadEventProc):	Corrected subtle
	bug where the returned (char *) from Tcl_GetStringResult(interp)
	continued to be used without copying or refcounting, while
	activity on the interp continued.  That's not safe, and recent
	changes demonstrated the lack of safety with failing tests
	thread-4.3 and thread-4.5.

2004-10-19  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (DictWithCmd): Make sure all paths (that
	are not themselves error paths) do not lose the result code.

2004-10-19  Don Porter  <[email protected]>

	* generic/tclInt.h (Tcl*InterpState):		New internal routines
	* generic/tclResult.c (Tcl*InterpState):	TclSaveInterpState,
	TclRestoreInterpState, and TclDiscardInterpState are superior
	replacements for Tcl_(Save|Restore|Discard)Result.  Intent is that
	these routines will be converted to public routines after TIP approval.
	Interfaces for these routines were shamelessly stolen from Itcl.







|


















|













|







4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
	* generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions):
	Move internal utility routines from tclCmdMZ.c to tclResult.c.

	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp):
	* generic/tclResult.c (TclTransferResult):	Rework so that
	iPtr->returnOpts can be NULL when there are no special options.

	* generic/tclResult.c (TclRestoreInterpState):	Plug potential
	memory leak.

2004-10-21  Kevin B. Kenny  <[email protected]>

	* generic/tclBasic.c: Various changes to [clock format] that,
	* generic/tclClock.c: together, make it roughly twice as fast
	* generic/tclInt.h:   while all tests in the test suite
	* library/clock.tcl:  continue to pass.

2004-10-20  Andreas Kupries <[email protected]>

	* win/Makefile.in (install-msgs):   Fixed a problem with the
	* win/Makefile.in (install-tzdata): installation of timezone data
	  and message catalogs. They used the installed tcl library
	  directory, not the source library. Before it was installed.
	  Switched to source lib dir. Thanks to Kevin for the help in
	  figuring this out.

2004-10-20  Don Porter	<[email protected]>

	* generic/tclThreadTest.c (ThreadEventProc):	Corrected subtle
	bug where the returned (char *) from Tcl_GetStringResult(interp)
	continued to be used without copying or refcounting, while
	activity on the interp continued.  That's not safe, and recent
	changes demonstrated the lack of safety with failing tests
	thread-4.3 and thread-4.5.

2004-10-19  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (DictWithCmd): Make sure all paths (that
	are not themselves error paths) do not lose the result code.

2004-10-19  Don Porter	<[email protected]>

	* generic/tclInt.h (Tcl*InterpState):		New internal routines
	* generic/tclResult.c (Tcl*InterpState):	TclSaveInterpState,
	TclRestoreInterpState, and TclDiscardInterpState are superior
	replacements for Tcl_(Save|Restore|Discard)Result.  Intent is that
	these routines will be converted to public routines after TIP approval.
	Interfaces for these routines were shamelessly stolen from Itcl.
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076

	* generic/tclEvent.c (HandleBgErrors):
	* generic/tclFCmd.c (CopyRenameOneFile):
	Calls to Tcl_*Result that were eliminated because they appeared
	to serve no useful purpose, typically saving/restoring an error
	message, only to throw it away.

2004-10-18  Don Porter  <[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp):
	* generic/tclCmdAH.c (Tcl_CatchObjCmd):
	* generic/tclCmdMZ.c (TclMergeReturnOptions,TclProcessReturn):
	* generic/tclCompCmds.c (TclCompileReturnCmd):
	* generic/tclExecute.c (TclCompEvalObj):
	* generic/tclInt.h (Interp):
	* generic/tclProc.c (TclUpdateReturnInfo):
	Place primary storage of the -level and -code information in private
	fields of the Interp struct, rather than in a DictObj.  This should
	significantly improve performance of TclUpdateReturnInfo.

2004-10-17  Miguel Sofer <[email protected]>

	* generic/tclResult.c: removed unused variable [Bug 1048588]. 
	Thanks to Daniel South.

2004-10-15  Don Porter  <[email protected]>

	* generic/tclCmdMZ.c (TclProcessReturn):	Now that primary
	* generic/tclProc.c (TclUpdateReturnInfo):	storage for the
	errorInfo and errorCode values are internal fields, we can set
	them at the time of the [return] command, and not have to wait
	until the specified number of "-level"s have popped.








|









|




|


|







4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319

	* generic/tclEvent.c (HandleBgErrors):
	* generic/tclFCmd.c (CopyRenameOneFile):
	Calls to Tcl_*Result that were eliminated because they appeared
	to serve no useful purpose, typically saving/restoring an error
	message, only to throw it away.

2004-10-18  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp):
	* generic/tclCmdAH.c (Tcl_CatchObjCmd):
	* generic/tclCmdMZ.c (TclMergeReturnOptions,TclProcessReturn):
	* generic/tclCompCmds.c (TclCompileReturnCmd):
	* generic/tclExecute.c (TclCompEvalObj):
	* generic/tclInt.h (Interp):
	* generic/tclProc.c (TclUpdateReturnInfo):
	Place primary storage of the -level and -code information in private
	fields of the Interp struct, rather than in a DictObj.	This should
	significantly improve performance of TclUpdateReturnInfo.

2004-10-17  Miguel Sofer <[email protected]>

	* generic/tclResult.c: removed unused variable [Bug 1048588].
	Thanks to Daniel South.

2004-10-15  Don Porter	<[email protected]>

	* generic/tclCmdMZ.c (TclProcessReturn):	Now that primary
	* generic/tclProc.c (TclUpdateReturnInfo):	storage for the
	errorInfo and errorCode values are internal fields, we can set
	them at the time of the [return] command, and not have to wait
	until the specified number of "-level"s have popped.

1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
		(Tcl_ResetResult,TclTransferResult):
	* generic/tclTrace.c (CallVarTraces):
	Reworked management of the "errorInfo" data of an interp.
	That information is now primarily stored in a new private
	(Tcl_Obj *) field of the Interp struct, rather than using a
	global variable ::errorInfo as the primary storage.  The
	ERR_IN_PROGRESS flag bit value is no longer required to manage
	the value in its new location, and is removed.  Variable traces
	are established to support compatibility for any code expecting
	the ::errorInfo variable to hold the information.

	***POTENTIAL INCOMPATIBILITY***
	Code that sets traces on the ::errorInfo variable may notice a
	difference in timing of the firing of those traces.  Code that
	uses the value ERR_IN_PROGRESS.







|







4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
		(Tcl_ResetResult,TclTransferResult):
	* generic/tclTrace.c (CallVarTraces):
	Reworked management of the "errorInfo" data of an interp.
	That information is now primarily stored in a new private
	(Tcl_Obj *) field of the Interp struct, rather than using a
	global variable ::errorInfo as the primary storage.  The
	ERR_IN_PROGRESS flag bit value is no longer required to manage
	the value in its new location, and is removed.	Variable traces
	are established to support compatibility for any code expecting
	the ::errorInfo variable to hold the information.

	***POTENTIAL INCOMPATIBILITY***
	Code that sets traces on the ::errorInfo variable may notice a
	difference in timing of the firing of those traces.  Code that
	uses the value ERR_IN_PROGRESS.
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
	* generic/tclExecute.c (TclExecuteByteCode): Implementation of the
	INST_LIST_IN and INST_LIST_NOT_IN bytecodes.
	* generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni'
	operators for TIP#201.
	* generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of
	implementation of TIP#212; docs and tests still to do...

2004-10-07  Don Porter  <[email protected]>

	* generic/tclTest.c (TestsetobjerrorcodeCmd):  Simplified.

2004-10-07  Vince Darley  <[email protected]>

	* generic/tclFileName.c:
	* generic/tclFileSystem.h:
	* generic/tclIOUtil.c:
	* generic/tclPathObj.c:
	* unix/tclUnixFile.c:
	* win/tclWinFile.c:
	* tests/fileName.test:
	* tests/winFCmd.test: code reorganization for better generic/
	platform code splitting [Bug 925620] removing the need for
	several #ifdef's, and tests and fix for an unreported Windows 
	glob problem ('glob -dir C: -tails *').

2004-10-07  Donal K. Fellows  <[email protected]>

	* *.3: Convert CONST to const and VOID to void so we document how
	people should actually use the Tcl API and not the compatability
	hacks that it has to have.







|














|







4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
	* generic/tclExecute.c (TclExecuteByteCode): Implementation of the
	INST_LIST_IN and INST_LIST_NOT_IN bytecodes.
	* generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni'
	operators for TIP#201.
	* generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of
	implementation of TIP#212; docs and tests still to do...

2004-10-07  Don Porter	<[email protected]>

	* generic/tclTest.c (TestsetobjerrorcodeCmd):  Simplified.

2004-10-07  Vince Darley  <[email protected]>

	* generic/tclFileName.c:
	* generic/tclFileSystem.h:
	* generic/tclIOUtil.c:
	* generic/tclPathObj.c:
	* unix/tclUnixFile.c:
	* win/tclWinFile.c:
	* tests/fileName.test:
	* tests/winFCmd.test: code reorganization for better generic/
	platform code splitting [Bug 925620] removing the need for
	several #ifdef's, and tests and fix for an unreported Windows
	glob problem ('glob -dir C: -tails *').

2004-10-07  Donal K. Fellows  <[email protected]>

	* *.3: Convert CONST to const and VOID to void so we document how
	people should actually use the Tcl API and not the compatability
	hacks that it has to have.
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
	the Engineering Manual more closely, and also take advantage of
	the internal object manipulation macros more.

	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reorganized to have fewer
	magic flag variables and to separate the code that scans for a
	match from the code that processes a match body.

2004-10-06  Don Porter  <[email protected]>

	* generic/tclBasic.c:
	* generic/tclBinary.c:
	* generic/tclCmdAH.c:
	* generic/tclCmdIL.c:
	* generic/tclCmdMZ.c:
	* generic/tclCompExpr.c:







|







4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
	the Engineering Manual more closely, and also take advantage of
	the internal object manipulation macros more.

	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reorganized to have fewer
	magic flag variables and to separate the code that scans for a
	match from the code that processes a match body.

2004-10-06  Don Porter	<[email protected]>

	* generic/tclBasic.c:
	* generic/tclBinary.c:
	* generic/tclCmdAH.c:
	* generic/tclCmdIL.c:
	* generic/tclCmdMZ.c:
	* generic/tclCompExpr.c:
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
	* win/tclWinDde.c:
	* win/tclWinFCmd.c:
	* win/tclWinPipe.c:
	* win/tclWinReg.c:
	It is a poor practice to directly set or append to the value
	of the objResult of an interp, because that value might be
	shared, and in that circumstance a Tcl_Panic() will be the
	result.  Searched for example of this practice and replaced
	with safer alternatives, often using the Tcl_AppendResult()
	routine that dkf just rehabilitated.
	* library/dde/pkgIndex.tcl: Bump to dde 1.3.1
	* library/reg/pkgIndex.tcl: Bump to registry 1.1.5

2004-10-06  Donal K. Fellows  <[email protected]>

	* doc/SetResult.3: Made Tcl_AppendResult non-deprecated; better
	that people use it than most of the common alternatives!
	* generic/tclResult.c (Tcl_AppendResultVA): Make this work better
	with Tcl_Objs. [Patch 1041072]
	(Tcl_SetResult, Tcl_AppendElement): Change string to stringPtr to
	avoid C++ keywords.

2004-10-05  Don Porter  <[email protected]>

	* generic/tclBasic.c (TclObjInvoke): More simplification of the
	TclObjInvoke routine toward unification with the rest of the
	evaluation stack.

	* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp,
		TclEvalObjvInternal,Tcl_LogCommandInfo):
	* generic/tclCmdAH.c (Tcl_CatchObjCmd):
	* generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors):
	* generic/tclInt.h (Interp, ERROR_CODE_SET):
	* generic/tclNamesp.c
		(Tcl_CreateNamespace,Tcl_DeleteNamespace,TclTeardownNamespace):
	* generic/tclResult.c
		(Tcl_ResetResult,Tcl_SetObjErrorCode,TclTransferResult):
	* generic/tclTrace.c (CallVarTraces):
	Reworked management of the "errorCode" data of an interp.
	That information is now primarily stored in a new private
	(Tcl_Obj *) field of the Interp struct, rather than using a
	global variable ::errorCode as the primary storage.  The
	ERROR_CODE_SET flag bit value is no longer required to manage
	the value in its new location, and is removed.  Variable traces
	are established to support compatibility for any code expecting
	the ::errorCode variable to hold the information.

	***POTENTIAL INCOMPATIBILITY***
	Code that sets traces on the ::errorCode variable may notice a
	difference in timing of the firing of those traces.








|














|




















|







4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
	* win/tclWinDde.c:
	* win/tclWinFCmd.c:
	* win/tclWinPipe.c:
	* win/tclWinReg.c:
	It is a poor practice to directly set or append to the value
	of the objResult of an interp, because that value might be
	shared, and in that circumstance a Tcl_Panic() will be the
	result.	 Searched for example of this practice and replaced
	with safer alternatives, often using the Tcl_AppendResult()
	routine that dkf just rehabilitated.
	* library/dde/pkgIndex.tcl: Bump to dde 1.3.1
	* library/reg/pkgIndex.tcl: Bump to registry 1.1.5

2004-10-06  Donal K. Fellows  <[email protected]>

	* doc/SetResult.3: Made Tcl_AppendResult non-deprecated; better
	that people use it than most of the common alternatives!
	* generic/tclResult.c (Tcl_AppendResultVA): Make this work better
	with Tcl_Objs. [Patch 1041072]
	(Tcl_SetResult, Tcl_AppendElement): Change string to stringPtr to
	avoid C++ keywords.

2004-10-05  Don Porter	<[email protected]>

	* generic/tclBasic.c (TclObjInvoke): More simplification of the
	TclObjInvoke routine toward unification with the rest of the
	evaluation stack.

	* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp,
		TclEvalObjvInternal,Tcl_LogCommandInfo):
	* generic/tclCmdAH.c (Tcl_CatchObjCmd):
	* generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors):
	* generic/tclInt.h (Interp, ERROR_CODE_SET):
	* generic/tclNamesp.c
		(Tcl_CreateNamespace,Tcl_DeleteNamespace,TclTeardownNamespace):
	* generic/tclResult.c
		(Tcl_ResetResult,Tcl_SetObjErrorCode,TclTransferResult):
	* generic/tclTrace.c (CallVarTraces):
	Reworked management of the "errorCode" data of an interp.
	That information is now primarily stored in a new private
	(Tcl_Obj *) field of the Interp struct, rather than using a
	global variable ::errorCode as the primary storage.  The
	ERROR_CODE_SET flag bit value is no longer required to manage
	the value in its new location, and is removed.	Variable traces
	are established to support compatibility for any code expecting
	the ::errorCode variable to hold the information.

	***POTENTIAL INCOMPATIBILITY***
	Code that sets traces on the ::errorCode variable may notice a
	difference in timing of the firing of those traces.

1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
2004-10-04  Donal K. Fellows  <[email protected]>

	* generic/tclParseExpr.c (GetLexeme): Ensure that the 'eq' and
	'ne' operators are followed by non-alphabetic characters so
	lexemes can't run together. [Bug 884830]

	* doc/DictObj.3, doc/dict.n: Clarified that a dictionary is not
	order-preserving. [Bug 1032243]  Also added another example to
	show off more ways of using a dictionary and a few other
	formatting improvements.

2004-10-02  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (TraceDictPath, Tcl_DictObjPutKeyList): Add
	support for automatic creation of dictionary paths since that is
	what everyone seems to actually expect of the API! [Bug 1037235]
	(Tcl_DictObjNext): Make calling this after Tcl_DictObjDone non-fatal
	as that simplifies a number of internal APIs. This doesn't break any
	existing working code as it is a case which previously caused a panic.

2004-10-02  Don Porter  <[email protected]>

	* tests/namespace.test (namespace-8.7):	Another test for save/restore
	of ::errorInfo and ::errorCode during global namespace teardown.

2004-10-01  Donal K. Fellows  <[email protected]>

	* generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd): 
	* generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level
	references in the level object for speed.

2004-09-30  Don Porter  <[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp): Removed the flag bit value
	* generic/tclInt.h (Interp):	EXPR_INITIALIZED.  It was set during
	interp creation and never tested.  Whatever purpose it had is in
	the past.

	* generic/tclBasic.c (Tcl_EvalObjEx):	Removed the flag bit value
	* generic/tclInt.h (Interp):	USE_EVAL_DIRECT.  It was used only
	* generic/tcLTest.c (TestevalexObjCmd):	in the testing command
	* tests/parser.test (parse-9.2): [testevalex] and nothing in the
	test suite made use of the capability it enabled.

	* generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization
	* generic/tclCmdAH.c (Tcl_ErrorObjCmd):     of the management of
	* generic/tclCmdMZ.c (TclProcessReturn):    the errorCode value.
	* tests/error.test (error-6.4-9):

	* generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified
	* tests/namespace.test (namespace-8.5,6):	the save/restore
	of ::errorInfo and ::errorCode during global namespace teardown.
	Revised the comment to clarify why this is done, and added tests







|












|






|



|













|







4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
2004-10-04  Donal K. Fellows  <[email protected]>

	* generic/tclParseExpr.c (GetLexeme): Ensure that the 'eq' and
	'ne' operators are followed by non-alphabetic characters so
	lexemes can't run together. [Bug 884830]

	* doc/DictObj.3, doc/dict.n: Clarified that a dictionary is not
	order-preserving. [Bug 1032243]	 Also added another example to
	show off more ways of using a dictionary and a few other
	formatting improvements.

2004-10-02  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (TraceDictPath, Tcl_DictObjPutKeyList): Add
	support for automatic creation of dictionary paths since that is
	what everyone seems to actually expect of the API! [Bug 1037235]
	(Tcl_DictObjNext): Make calling this after Tcl_DictObjDone non-fatal
	as that simplifies a number of internal APIs. This doesn't break any
	existing working code as it is a case which previously caused a panic.

2004-10-02  Don Porter	<[email protected]>

	* tests/namespace.test (namespace-8.7):	Another test for save/restore
	of ::errorInfo and ::errorCode during global namespace teardown.

2004-10-01  Donal K. Fellows  <[email protected]>

	* generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd):
	* generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level
	references in the level object for speed.

2004-09-30  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp): Removed the flag bit value
	* generic/tclInt.h (Interp):	EXPR_INITIALIZED.  It was set during
	interp creation and never tested.  Whatever purpose it had is in
	the past.

	* generic/tclBasic.c (Tcl_EvalObjEx):	Removed the flag bit value
	* generic/tclInt.h (Interp):	USE_EVAL_DIRECT.  It was used only
	* generic/tcLTest.c (TestevalexObjCmd):	in the testing command
	* tests/parser.test (parse-9.2): [testevalex] and nothing in the
	test suite made use of the capability it enabled.

	* generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization
	* generic/tclCmdAH.c (Tcl_ErrorObjCmd):	    of the management of
	* generic/tclCmdMZ.c (TclProcessReturn):    the errorCode value.
	* tests/error.test (error-6.4-9):

	* generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified
	* tests/namespace.test (namespace-8.5,6):	the save/restore
	of ::errorInfo and ::errorCode during global namespace teardown.
	Revised the comment to clarify why this is done, and added tests
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
	* tests/var.test (var-16.1):	values that define part of the
	interpreter state during variable traces.  [Bug 1038021].

2004-09-30  Miguel Sofer <[email protected]>

	* tests/subst.test (12.1-2): added tests for [Bug 1036649]

2004-09-29  Don Porter  <[email protected]>

	* tests/basic.test (49.*):	New tests for TCL_EVAL_GLOBAL.

2004-09-29  Donal K. Fellows  <[email protected]>

	* generic/tclVar.c (TclObjLookupVar, TclObjLookupVar): 
	(TclObjUnsetVar2, SetArraySearchObj): 
	* generic/tclUtil.c (SetEndOffsetFromAny): 
	* generic/tclStringObj.c (Tcl_SetStringObj): 
	(Tcl_SetUnicodeObj, SetStringFromAny): 
	* generic/tclResult.c (ResetObjResult): 
	* generic/tclRegexp.c (Tcl_GetRegExpFromObj): 
	* generic/tclPathObj.c (TclFSMakePathRelative, SetFsPathFromAny): 
	(TclFSMakePathFromNormalized, Tcl_FSNewNativePath): 
	* generic/tclObj.c (TclFreeObj, Tcl_SetBooleanObj, SetBooleanFromAny): 
	(Tcl_SetDoubleObj, SetDoubleFromAny, Tcl_SetIntObj): 
	(SetIntOrWideFromAny, Tcl_SetLongObj, SetWideIntFromAny): 
	(Tcl_SetWideIntObj, TclSetCmdNameObj, SetCmdNameFromAny): 
	* generic/tclNamesp.c (SetNsNameFromAny, MakeCachedEnsembleCommand): 
	* generic/tclListObj.c (Tcl_SetListObj, SetListFromAny): 
	* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): 
	* generic/tclDictObj.c (SetDictFromAny): 
	* generic/tclCompile.c (TclInitByteCodeObj): 
	* generic/tclBinary.c (Tcl_SetByteArrayObj, SetByteArrayFromAny): 
	* generic/tclInt.h (TclFreeIntRep): Factorize out deletion of object
	internal representation to a shared macro, so simplifying much code.

2004-09-27  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (TclObjInvoke): fix for bogus gcc warning
	about uninitialised variable.

2004-09-27  Don Porter  <[email protected]>

	* generic/tclBasic.c:	Removed internal routines TclInvoke,
	* generic/tclInt.decls: TclGlobalInvoke, TclObjInvokeGlobal and
	* tests/basic.test:	the portion of TclObjInvoke that handles
	calls without TCL_INVOKE_HIDDEN enabled.  None of this code is
	called any longer within the core, and the superior public
	interface, Tcl_EvalObjv, is available for any external callers.







|





|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|








|







4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
	* tests/var.test (var-16.1):	values that define part of the
	interpreter state during variable traces.  [Bug 1038021].

2004-09-30  Miguel Sofer <[email protected]>

	* tests/subst.test (12.1-2): added tests for [Bug 1036649]

2004-09-29  Don Porter	<[email protected]>

	* tests/basic.test (49.*):	New tests for TCL_EVAL_GLOBAL.

2004-09-29  Donal K. Fellows  <[email protected]>

	* generic/tclVar.c (TclObjLookupVar, TclObjLookupVar):
	(TclObjUnsetVar2, SetArraySearchObj):
	* generic/tclUtil.c (SetEndOffsetFromAny):
	* generic/tclStringObj.c (Tcl_SetStringObj):
	(Tcl_SetUnicodeObj, SetStringFromAny):
	* generic/tclResult.c (ResetObjResult):
	* generic/tclRegexp.c (Tcl_GetRegExpFromObj):
	* generic/tclPathObj.c (TclFSMakePathRelative, SetFsPathFromAny):
	(TclFSMakePathFromNormalized, Tcl_FSNewNativePath):
	* generic/tclObj.c (TclFreeObj, Tcl_SetBooleanObj, SetBooleanFromAny):
	(Tcl_SetDoubleObj, SetDoubleFromAny, Tcl_SetIntObj):
	(SetIntOrWideFromAny, Tcl_SetLongObj, SetWideIntFromAny):
	(Tcl_SetWideIntObj, TclSetCmdNameObj, SetCmdNameFromAny):
	* generic/tclNamesp.c (SetNsNameFromAny, MakeCachedEnsembleCommand):
	* generic/tclListObj.c (Tcl_SetListObj, SetListFromAny):
	* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct):
	* generic/tclDictObj.c (SetDictFromAny):
	* generic/tclCompile.c (TclInitByteCodeObj):
	* generic/tclBinary.c (Tcl_SetByteArrayObj, SetByteArrayFromAny):
	* generic/tclInt.h (TclFreeIntRep): Factorize out deletion of object
	internal representation to a shared macro, so simplifying much code.

2004-09-27  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (TclObjInvoke): fix for bogus gcc warning
	about uninitialised variable.

2004-09-27  Don Porter	<[email protected]>

	* generic/tclBasic.c:	Removed internal routines TclInvoke,
	* generic/tclInt.decls: TclGlobalInvoke, TclObjInvokeGlobal and
	* tests/basic.test:	the portion of TclObjInvoke that handles
	calls without TCL_INVOKE_HIDDEN enabled.  None of this code is
	called any longer within the core, and the superior public
	interface, Tcl_EvalObjv, is available for any external callers.
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
	* tests/winFCmd.test: fix to bad error message with 'cd' on
	windows, when permissions are inadequate [Bug 1035462] and
	to treatment of a volume-relative pwd on Windows [Bug 1018980].

	* doc/FileSystem.3: added missing Tcl_GlobTypeData documentation
	[Bug 935853]

2004-09-27  Kevin Kenny  <[email protected]>

	* compat/strftime.c (Removed):
	* generic/tclClock.c (removed TclClockOldscanObjCmd):
	* generic/tclDate.c (Regenerated):
	* generic/tclGetDate.y:
	* generic/tclInt.decls (removed TclGetDate and TclpStrftime):
	* generic/tclInt.h (removed TclGetDateInfo):
	* generic/tclIntDecls.h (Regenerated):
	* generic/tclStubInit.c (Regenerated):
	* library/clock.tcl: 
	* unix/tclUnixTime.c (removed TclpStrftime):
	* win/Makefile.in:
	* win/makefile.bc:
	* win/makefile.bc:
	* win/tcl.dsp:
	Continued refactoring of [clock] for TIP 173 changes.
	Broke the free-form parser apart so that the Bison parser







|









|







4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
	* tests/winFCmd.test: fix to bad error message with 'cd' on
	windows, when permissions are inadequate [Bug 1035462] and
	to treatment of a volume-relative pwd on Windows [Bug 1018980].

	* doc/FileSystem.3: added missing Tcl_GlobTypeData documentation
	[Bug 935853]

2004-09-27  Kevin Kenny	 <[email protected]>

	* compat/strftime.c (Removed):
	* generic/tclClock.c (removed TclClockOldscanObjCmd):
	* generic/tclDate.c (Regenerated):
	* generic/tclGetDate.y:
	* generic/tclInt.decls (removed TclGetDate and TclpStrftime):
	* generic/tclInt.h (removed TclGetDateInfo):
	* generic/tclIntDecls.h (Regenerated):
	* generic/tclStubInit.c (Regenerated):
	* library/clock.tcl:
	* unix/tclUnixTime.c (removed TclpStrftime):
	* win/Makefile.in:
	* win/makefile.bc:
	* win/makefile.bc:
	* win/tcl.dsp:
	Continued refactoring of [clock] for TIP 173 changes.
	Broke the free-form parser apart so that the Bison parser
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
	have been removed.  The refactoring also has the benefit
	that all storage in the Bison parser is now on the C stack,
	eliminating any need for mutex protection around [clock scan].
	Also, changed the Makefiles so that 'make gendate' is
	available on Windows as well as Unix.

	* generic/tclCmdAH.c (Tcl_FormatObjCmd): Removed some grubby
	* generic/tclObj.c (SetBooleanFromAny):  work-around code
					         that was needed only
	                                         because of Bug 868489.

	* generic/tclBasic.c (TclObjInvoke): Removed three unused
	variables to silence a compiler warning in VC++.

2004-09-27  Vince Darley  <[email protected]>

	* doc/FileSystem.3: fix to small typo.







|
|
|







4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
	have been removed.  The refactoring also has the benefit
	that all storage in the Bison parser is now on the C stack,
	eliminating any need for mutex protection around [clock scan].
	Also, changed the Makefiles so that 'make gendate' is
	available on Windows as well as Unix.

	* generic/tclCmdAH.c (Tcl_FormatObjCmd): Removed some grubby
	* generic/tclObj.c (SetBooleanFromAny):	 work-around code
						 that was needed only
						 because of Bug 868489.

	* generic/tclBasic.c (TclObjInvoke): Removed three unused
	variables to silence a compiler warning in VC++.

2004-09-27  Vince Darley  <[email protected]>

	* doc/FileSystem.3: fix to small typo.
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
	* generic/tclProc.c:
	* tests/compExpr-old.test:
	* tests/compExpr.test:
	* tests/expr.test:
	* tests/for.test:
	* tests/if.test:
	* tests/incr.test:
	* tests/while.test: 
	Report compilation errors at runtime, [Patch 1033689] by dgp. 

2004-09-23  Mo DeJong  <[email protected]>

	* unix/dltest/Makefile.in (clean): Fixup make clean
	rule so that it does not delete all files when
	SHLIB_SUFFIX is set to the empty string in a static build.
	[Bug 1016726]

2004-09-23  Don Porter  <[email protected]>

	* generic/tclBasic.c:	Corrections to the 2004-09-21 commit
	* generic/tclExecute.c:	regarding ERR_ALREADY_LOGGED.  That commit
	* generic/tclNamesp.c:	caused Tk test send-10.7 to fail.  Added
	* tests/namespace.test (25.7,8):	tests in the Tcl test suite
	* tests/pkg.test (2.25,26):	to catch this error without the
	aid of Tk in the future.

	* generic/tclCmdAH.c (Tcl_ExprObjCmd):	Simplified the TclObjCmdProc
	of [expr] with a call to Tcl_ConcatObj.

2004-09-22  Don Porter  <[email protected]>

	* generic/tclCmdMZ.c (TclProcessReturn):	Support the -errorline
	* generic/tclCompile.c (TclCompileScript):	option to [return].
	* tests/compile.test (16.23.*):	Use that capability to defer reporting
	* tests/misc.test (1.2):	of parse errors until runtime.
	Updated tests to reflect change. [Bug 1032805]








|
|








|











|







4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
	* generic/tclProc.c:
	* tests/compExpr-old.test:
	* tests/compExpr.test:
	* tests/expr.test:
	* tests/for.test:
	* tests/if.test:
	* tests/incr.test:
	* tests/while.test:
	Report compilation errors at runtime, [Patch 1033689] by dgp.

2004-09-23  Mo DeJong  <[email protected]>

	* unix/dltest/Makefile.in (clean): Fixup make clean
	rule so that it does not delete all files when
	SHLIB_SUFFIX is set to the empty string in a static build.
	[Bug 1016726]

2004-09-23  Don Porter	<[email protected]>

	* generic/tclBasic.c:	Corrections to the 2004-09-21 commit
	* generic/tclExecute.c:	regarding ERR_ALREADY_LOGGED.  That commit
	* generic/tclNamesp.c:	caused Tk test send-10.7 to fail.  Added
	* tests/namespace.test (25.7,8):	tests in the Tcl test suite
	* tests/pkg.test (2.25,26):	to catch this error without the
	aid of Tk in the future.

	* generic/tclCmdAH.c (Tcl_ExprObjCmd):	Simplified the TclObjCmdProc
	of [expr] with a call to Tcl_ConcatObj.

2004-09-22  Don Porter	<[email protected]>

	* generic/tclCmdMZ.c (TclProcessReturn):	Support the -errorline
	* generic/tclCompile.c (TclCompileScript):	option to [return].
	* tests/compile.test (16.23.*):	Use that capability to defer reporting
	* tests/misc.test (1.2):	of parse errors until runtime.
	Updated tests to reflect change. [Bug 1032805]

1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551

	* library/tzdata/America/Montevideo: Updated to reflect
	ftp://elsie.nci.nih.gov/pub/tzdata2004d.tar.gz. (Changes
	to Asia/Jerusalem were in the comments only.) [Routine
	maintenance - no bug] Spanish-language description of the
	change at http://www.presidencia.gub.uy/decretos/2004091502.htm

2004-09-21  Don Porter  <[email protected]>

	* generic/tclCompCmds.c:	Tolerate [append] syntax errors
	* tests/appendComp.test (8.1):	at compile time, and allow runtime
	to raise the error (or succeed if a redefined [append] allows).

	* generic/tclBasic.c:	Reworked management of the interp
	* generic/tclCompile.c:	flag ERR_ALREADY_LOGGED, to reduce
	* generic/tclExecute.c: its exposure.  Still left several
	* generic/tclNamesp.c:	references that are just too nice
	on performace to do away with.  These changes also resolve
	an inconsistency in the ::errorInfo values produced by
	[namespace eval x error foo bar] and
	[namespace eval x {error foo bar}].

	* generic/tclExecute.c (TclCompEvalObj):	Simplified
	the TclCompEvalObj routine.  Much housekeeping now reliably
	happens elsewhere.  [Patch 1031949]

2004-09-21  Donal K. Fellows  <[email protected]>

	* doc/interp.n: Tighten up wording on how [interp eval] and
	[interp invokehidden] operate w.r.t. stack frames. [Bug 926590]

2004-09-20  Don Porter  <[email protected]>

	* tests/error.test (error-6.2,3):	Added more tests to verify
	::errorCode setting by/after a [catch].

2004-09-19  Miguel Sofer <[email protected]>

	* generic/tclCmdAH.c: removed outdated comment [Bug 1029518].







|









|













|







4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794

	* library/tzdata/America/Montevideo: Updated to reflect
	ftp://elsie.nci.nih.gov/pub/tzdata2004d.tar.gz. (Changes
	to Asia/Jerusalem were in the comments only.) [Routine
	maintenance - no bug] Spanish-language description of the
	change at http://www.presidencia.gub.uy/decretos/2004091502.htm

2004-09-21  Don Porter	<[email protected]>

	* generic/tclCompCmds.c:	Tolerate [append] syntax errors
	* tests/appendComp.test (8.1):	at compile time, and allow runtime
	to raise the error (or succeed if a redefined [append] allows).

	* generic/tclBasic.c:	Reworked management of the interp
	* generic/tclCompile.c:	flag ERR_ALREADY_LOGGED, to reduce
	* generic/tclExecute.c: its exposure.  Still left several
	* generic/tclNamesp.c:	references that are just too nice
	on performace to do away with.	These changes also resolve
	an inconsistency in the ::errorInfo values produced by
	[namespace eval x error foo bar] and
	[namespace eval x {error foo bar}].

	* generic/tclExecute.c (TclCompEvalObj):	Simplified
	the TclCompEvalObj routine.  Much housekeeping now reliably
	happens elsewhere.  [Patch 1031949]

2004-09-21  Donal K. Fellows  <[email protected]>

	* doc/interp.n: Tighten up wording on how [interp eval] and
	[interp invokehidden] operate w.r.t. stack frames. [Bug 926590]

2004-09-20  Don Porter	<[email protected]>

	* tests/error.test (error-6.2,3):	Added more tests to verify
	::errorCode setting by/after a [catch].

2004-09-19  Miguel Sofer <[email protected]>

	* generic/tclCmdAH.c: removed outdated comment [Bug 1029518].
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
	* generic/tclExecute.c (TEBC-INST_LSHIFT,INST_RSHIFT): Ensure that
	large shifts end up shifting correctly. [Bug 868467]

	* doc/FileSystem.3, doc/OpenFileChnl.3: More documentation fixes
	from Mikhail Kolesnitchenko. [Patch 1022527]
	* doc/*: Standardize highlighting of symbols defined in tcl.h

2004-09-17  Don Porter  <[email protected]>

	* generic/tclBasic.c (Tcl_AddObjErrorInfo, Tcl_LogCommandInfo):
	* generic/tclCmdAH.c ([catch], [error]):
	* generic/tclCmdMZ.c ([return]):
	* generic/tclProc.c (TclUpdateReturnInfo):
	* generic/tclResult.c (Tcl_SetErrorCodeVA, Tcl_SetObjErrorCode)
	(TclTransferResult): 	Refactored so that all errorCode setting
	flows through Tcl_SetObjErrorCode().  This greatly reduces the
	number of different places in the code that need to know details
	about an internal bitflag field of the Interp struct.  Also
	places errorCode setting in one place for easier future mods.

2004-09-17  Kevin B.Kenny  <[email protected]>

	* generic/tclDate.c:    Revised tclGetDate.y to use bison instead
	* generic/tclGetDate.y: of yacc to build the parser, eliminating
	* generic/tclInt.h:     all the complicated hackery involving
	* unix/Makefile.in:     'sed' postprocessing.  Rebuilt the parser.

2004-09-14  Kevin B. Kenny  <[email protected]>

	* generic/tclClock.c (ClockOldscanObjCmd): Silenced a compiler
	warning (long passed as a param where unsigend long was
	expected).  'Unsigned long' is wrong, but the fix is really
	to change the signature of TclGetDate to return a structure of
	its 'yy' variables and then do the remaining work inside
	clock.tcl. But, as I said on 2004-09-08, that's a job for
	another day.  [Bug 1027993]

2004-09-10  Miguel Sofer <[email protected]>

	* doc/interp.n:
	* generic/tclInterp.c (TclPreventAliasLoop, AliasCreate):
	* tests/interp.test (17.4-6, 19.3-4): fixing problems with
	renaming of aliases [Bugs 707104 1026493]. Fix designed by dgp. 

2004-09-13  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (NsEnsembleImplementationCmd): Add token
	field to internal rep of EnsembleCmdRep structure so that we can
	check it to see if the subcommand object is really being used with
	the same ensemble. [Bug 1026903]







|






|







|

|
|
















|







4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
	* generic/tclExecute.c (TEBC-INST_LSHIFT,INST_RSHIFT): Ensure that
	large shifts end up shifting correctly. [Bug 868467]

	* doc/FileSystem.3, doc/OpenFileChnl.3: More documentation fixes
	from Mikhail Kolesnitchenko. [Patch 1022527]
	* doc/*: Standardize highlighting of symbols defined in tcl.h

2004-09-17  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_AddObjErrorInfo, Tcl_LogCommandInfo):
	* generic/tclCmdAH.c ([catch], [error]):
	* generic/tclCmdMZ.c ([return]):
	* generic/tclProc.c (TclUpdateReturnInfo):
	* generic/tclResult.c (Tcl_SetErrorCodeVA, Tcl_SetObjErrorCode)
	(TclTransferResult):	Refactored so that all errorCode setting
	flows through Tcl_SetObjErrorCode().  This greatly reduces the
	number of different places in the code that need to know details
	about an internal bitflag field of the Interp struct.  Also
	places errorCode setting in one place for easier future mods.

2004-09-17  Kevin B.Kenny  <[email protected]>

	* generic/tclDate.c:	Revised tclGetDate.y to use bison instead
	* generic/tclGetDate.y: of yacc to build the parser, eliminating
	* generic/tclInt.h:	all the complicated hackery involving
	* unix/Makefile.in:	'sed' postprocessing.  Rebuilt the parser.

2004-09-14  Kevin B. Kenny  <[email protected]>

	* generic/tclClock.c (ClockOldscanObjCmd): Silenced a compiler
	warning (long passed as a param where unsigend long was
	expected).  'Unsigned long' is wrong, but the fix is really
	to change the signature of TclGetDate to return a structure of
	its 'yy' variables and then do the remaining work inside
	clock.tcl. But, as I said on 2004-09-08, that's a job for
	another day.  [Bug 1027993]

2004-09-10  Miguel Sofer <[email protected]>

	* doc/interp.n:
	* generic/tclInterp.c (TclPreventAliasLoop, AliasCreate):
	* tests/interp.test (17.4-6, 19.3-4): fixing problems with
	renaming of aliases [Bugs 707104 1026493]. Fix designed by dgp.

2004-09-13  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (NsEnsembleImplementationCmd): Add token
	field to internal rep of EnsembleCmdRep structure so that we can
	check it to see if the subcommand object is really being used with
	the same ensemble. [Bug 1026903]
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690

2004-09-10  Andreas Kupries  <[email protected]>

	* generic/tcl.h: Micro formatting fixes.
	* generic/tclIOGT.c: Channel version fixed, must be 3, to have
	  wideseekProc. Thanks to David Graveraux <[email protected]>.

2004-09-11  Don Porter  <[email protected]>

	* generic/tclNamespace.c (TclGetNamespaceForQualName):	Resolved
	longstanding inconsistency in the treatment of the TCL_NAMESPACE_ONLY
	flag revealed by testing the 2004-09-09 commits against Itcl.
	TCL_NAMESPACE_ONLY now acts as specified in the pre-function
	comment, forcing resolution in the passed in context namespace.
	It has been incorrectly forcing resolution in the interp's current
	namespace.

2004-09-10  Kevin Kenny  <[email protected]>

	* library/clock.tcl: Fixed a bug where %z always put a plus
	sign on the time zone in :localtime.
	* tests/clock.test: Added test case for the above bug.

2004-09-10  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (INST_CONCAT1): added a peephole
	optimisation for concatting an empty string. This enables
	replacing the idiom 'K $x [set x {}]' by '$x[set x {}]' for
	fastest execution.

2004-09-09  David Gravereaux <[email protected]>

	* win/tclWinConsole.c: Calls to WriteFile and WriteConsoleA
	changed to WriteConsole for simplicity.

2004-09-09  Don Porter  <[email protected]>

	* generic/tclNamesp.c (Tcl_ForgetImport):	Corrected faulty
	* tests/namespace.test:	logic that relied exclusively on string
	matching and failed in the presence of [rename]s.  [Bug 560297]
	Also corrected faulty prevention of [namespace import] cycles.
	[Bug 1017299]

2004-09-08  Don Porter  <[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp):	Removed obsolete
	field for storing the string-based command procedure of built-in
	commands.  We no longer have any string-based built-in commands!

2004-09-08  Kevin B. Kenny <[email protected]>








|









|

















|







|







4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933

2004-09-10  Andreas Kupries  <[email protected]>

	* generic/tcl.h: Micro formatting fixes.
	* generic/tclIOGT.c: Channel version fixed, must be 3, to have
	  wideseekProc. Thanks to David Graveraux <[email protected]>.

2004-09-11  Don Porter	<[email protected]>

	* generic/tclNamespace.c (TclGetNamespaceForQualName):	Resolved
	longstanding inconsistency in the treatment of the TCL_NAMESPACE_ONLY
	flag revealed by testing the 2004-09-09 commits against Itcl.
	TCL_NAMESPACE_ONLY now acts as specified in the pre-function
	comment, forcing resolution in the passed in context namespace.
	It has been incorrectly forcing resolution in the interp's current
	namespace.

2004-09-10  Kevin Kenny	 <[email protected]>

	* library/clock.tcl: Fixed a bug where %z always put a plus
	sign on the time zone in :localtime.
	* tests/clock.test: Added test case for the above bug.

2004-09-10  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (INST_CONCAT1): added a peephole
	optimisation for concatting an empty string. This enables
	replacing the idiom 'K $x [set x {}]' by '$x[set x {}]' for
	fastest execution.

2004-09-09  David Gravereaux <[email protected]>

	* win/tclWinConsole.c: Calls to WriteFile and WriteConsoleA
	changed to WriteConsole for simplicity.

2004-09-09  Don Porter	<[email protected]>

	* generic/tclNamesp.c (Tcl_ForgetImport):	Corrected faulty
	* tests/namespace.test:	logic that relied exclusively on string
	matching and failed in the presence of [rename]s.  [Bug 560297]
	Also corrected faulty prevention of [namespace import] cycles.
	[Bug 1017299]

2004-09-08  Don Porter	<[email protected]>

	* generic/tclBasic.c (Tcl_CreateInterp):	Removed obsolete
	field for storing the string-based command procedure of built-in
	commands.  We no longer have any string-based built-in commands!

2004-09-08  Kevin B. Kenny <[email protected]>

1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
	clock-34.* test cases so that the consistency check is performed
	in :localtime rather than the current time zone.  This change
	allows dealing with issues where the C library has a different
	idea of DST conversion than Tcl. (Real fix would be to break
	TclGetDate into separate parser and time converter, and do
	the time conversion in clock.tcl. That's for another day.)
	Added regression test case for the bug where month was scanned
	incorrectly in -timezone :localtime. [Bug 1023779] Added 
	regression test case for %k at the zero hour.

2004-09-07  David Gravereaux <[email protected]>

	* win/makefile.vc: some quoting needed to be removed as it was
	breaking with VC7. [Bug 1023150]








|







4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
	clock-34.* test cases so that the consistency check is performed
	in :localtime rather than the current time zone.  This change
	allows dealing with issues where the C library has a different
	idea of DST conversion than Tcl. (Real fix would be to break
	TclGetDate into separate parser and time converter, and do
	the time conversion in clock.tcl. That's for another day.)
	Added regression test case for the bug where month was scanned
	incorrectly in -timezone :localtime. [Bug 1023779] Added
	regression test case for %k at the zero hour.

2004-09-07  David Gravereaux <[email protected]>

	* win/makefile.vc: some quoting needed to be removed as it was
	breaking with VC7. [Bug 1023150]

1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
	its imports.  [Bug 1016167]
	* library/clock.tcl (InitTZData, ClearCaches): Changed so that the
	in-memory time zone :UTC (and its aliases) always gets
	reinitialised, in case tzdata is absent. [Bug 1019537, 1023779]
	* library/tzdata/*: Regenerated.
	* tests/clock.test (clock-31.*, clock-39.1): Corrected a problem
	where the 'system' locale tests fail on a non-English Windows
	machine. [Bug 1023761].  Added a test to make sure that alias
	time zones load correctly. [Bug 1023779].
	* tests/timer.test (timer-1.1, timer-2.1): Changed to (one hopes!)
	be more resilient on an overloaded system, if [after 200] sleeps
	for 300 ms or longer.
	* tools/tclZIC.tcl (writeLinks): Corrected a problem where
	alias time zone names were written incorrectly, causing them
	to fail to load at run time. [Bug 1023779].







|







4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
	its imports.  [Bug 1016167]
	* library/clock.tcl (InitTZData, ClearCaches): Changed so that the
	in-memory time zone :UTC (and its aliases) always gets
	reinitialised, in case tzdata is absent. [Bug 1019537, 1023779]
	* library/tzdata/*: Regenerated.
	* tests/clock.test (clock-31.*, clock-39.1): Corrected a problem
	where the 'system' locale tests fail on a non-English Windows
	machine. [Bug 1023761].	 Added a test to make sure that alias
	time zones load correctly. [Bug 1023779].
	* tests/timer.test (timer-1.1, timer-2.1): Changed to (one hopes!)
	be more resilient on an overloaded system, if [after 200] sleeps
	for 300 ms or longer.
	* tools/tclZIC.tcl (writeLinks): Corrected a problem where
	alias time zone names were written incorrectly, causing them
	to fail to load at run time. [Bug 1023779].
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795

	* doc/lsearch.n: Clarified meaning of -dictionary. [Bug 759545]

2004-09-02  Vince Darley  <[email protected]>

	* win/makefile.vc: clock.tcl needs to be installed.

2004-09-01  Jeff Hobbs  <[email protected]>

	* win/tclWinReg.c (BroadcastValue): WIN64 cast corrections

	* win/tclWinDde.c (DdeClientWindowProc): 
	(DdeServicesOnAck, DdeEnumWindowsCallback): WIN64 corrections

	* win/tclWin32Dll.c (TclWinCPUID): need _asm for WIN64 (Itanium),
	until we have it, just return unknown. [Bug 1020445]

2004-09-01  Donal K. Fellows  <[email protected]>

	* doc/regsub.n, doc/RegConfig.3, doc/Environment.3: 
	* doc/CrtChannel.3, doc/safe.n: Use correct abbreviations.

2004-08-31  Donal K. Fellows  <[email protected]>

	* doc/trace.n, doc/socket.n, doc/registry.n, doc/pid.n: 
	* doc/namespace.n, doc/msgcat.n, doc/lsort.n, doc/lsearch.n: 
	* doc/linsert.n, doc/info.n, doc/http.n, doc/history.n: 
	* doc/format.n, doc/file.n, doc/exec.n, doc/dde.n, doc/clock.n: 
	* doc/catch.n, doc/binary.n: More spelling and grammar fixes from
	Mikhail Kolesnitchenko. [Patch 1018486]

2004-08-31  Vince Darley  <[email protected]>

	* doc/FileSystem.3:
	* generic/tclIOUtil.c: Clarified documentation regarding ability







|



|







|




|
|
|
|







5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038

	* doc/lsearch.n: Clarified meaning of -dictionary. [Bug 759545]

2004-09-02  Vince Darley  <[email protected]>

	* win/makefile.vc: clock.tcl needs to be installed.

2004-09-01  Jeff Hobbs	<[email protected]>

	* win/tclWinReg.c (BroadcastValue): WIN64 cast corrections

	* win/tclWinDde.c (DdeClientWindowProc):
	(DdeServicesOnAck, DdeEnumWindowsCallback): WIN64 corrections

	* win/tclWin32Dll.c (TclWinCPUID): need _asm for WIN64 (Itanium),
	until we have it, just return unknown. [Bug 1020445]

2004-09-01  Donal K. Fellows  <[email protected]>

	* doc/regsub.n, doc/RegConfig.3, doc/Environment.3:
	* doc/CrtChannel.3, doc/safe.n: Use correct abbreviations.

2004-08-31  Donal K. Fellows  <[email protected]>

	* doc/trace.n, doc/socket.n, doc/registry.n, doc/pid.n:
	* doc/namespace.n, doc/msgcat.n, doc/lsort.n, doc/lsearch.n:
	* doc/linsert.n, doc/info.n, doc/http.n, doc/history.n:
	* doc/format.n, doc/file.n, doc/exec.n, doc/dde.n, doc/clock.n:
	* doc/catch.n, doc/binary.n: More spelling and grammar fixes from
	Mikhail Kolesnitchenko. [Patch 1018486]

2004-08-31  Vince Darley  <[email protected]>

	* doc/FileSystem.3:
	* generic/tclIOUtil.c: Clarified documentation regarding ability
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
	* unix/Makefile.in: added customization of default module path roots
	via TCL_MODULE_PATH makefile variable.
	* macosx/Makefile: add platform standard locations to default
	module path roots. [Patch 942881]

	* tests/env.test: macosx fixes.

2004-08-25  Don Porter  <[email protected]>

	* tests/timer.test (timer-10.1):	Test for Bug 1016167.
	* generic/tclTimer.c:	Workaround for situation when a
	[namespace import] causes the objv[0] value to be something
	other than what Tcl_AfterObjCmd expects.  [Bug 1016167].

2004-08-25  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (NsEnsembleImplementationCmd): Use the
	ensemble command token to get the name of the ensemble for passing
	to the -unknown handler instead of relying on objv[0], which may
	contain useless info in the presence of [namespace import].
	Problem found by Don Porter when investigating [Bug 1016167].

2004-08-24  Don Porter  <[email protected]>

	* generic/tclProc.c:		The routine TclProcInterpProc was a
	* generic/tclTestProcBodyObj.c:	specific instance of the general
	service already provided by TclObjInvokeProc.  Removed
	TclProcInterpProc and TclGetInterpProc from the code...

	* generic/tclInt.decls	...and from the internal stubs table.
	* generic/tclIntDecls.h
	* generic/tclStubInit.c

2004-08-24  Donal K. Fellows  <[email protected]>

	* doc/string.n: Added clarifying note.

2004-08-23  Don Porter  <[email protected]>

	* library/auto.tcl:	Updated [tcl_findLibrary] search path
	to include any [<pkg>::pkgconfig get scriptdir,runtime] directory,
	as well as the $::auto_path.  [RFE 695441]

2004-08-21  Kevin B. Kenny  <[email protected]>

	* tests/clock.test (clock-38.1): Changed TZ setting to specify
	CET in excruciating detail to deal with systems that lack the
	Posix defaults for DST changes (and to be formally correct with
	the change dates for CET).

2004-08-19  Donal K. Fellows  <[email protected]>

	* generic/tclScan.c (Tcl_ScanObjCmd, ValidateFormat): Ensure that
	the %ld conversion works correctly on 64-bit platforms. [Bug 1011860]

2004-08-19  Kevin Kenny  <[email protected]>

	* library/clock.tcl (format): Changed default timezone format
	from alphabetic to numeric to produce scannable times in more
	locales.
	* tests/clock.test (clock-37.1): Removed now-unused 'needPST'
	constraint and the comments that refer to it.








|














|














|

















|







5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
	* unix/Makefile.in: added customization of default module path roots
	via TCL_MODULE_PATH makefile variable.
	* macosx/Makefile: add platform standard locations to default
	module path roots. [Patch 942881]

	* tests/env.test: macosx fixes.

2004-08-25  Don Porter	<[email protected]>

	* tests/timer.test (timer-10.1):	Test for Bug 1016167.
	* generic/tclTimer.c:	Workaround for situation when a
	[namespace import] causes the objv[0] value to be something
	other than what Tcl_AfterObjCmd expects.  [Bug 1016167].

2004-08-25  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (NsEnsembleImplementationCmd): Use the
	ensemble command token to get the name of the ensemble for passing
	to the -unknown handler instead of relying on objv[0], which may
	contain useless info in the presence of [namespace import].
	Problem found by Don Porter when investigating [Bug 1016167].

2004-08-24  Don Porter	<[email protected]>

	* generic/tclProc.c:		The routine TclProcInterpProc was a
	* generic/tclTestProcBodyObj.c:	specific instance of the general
	service already provided by TclObjInvokeProc.  Removed
	TclProcInterpProc and TclGetInterpProc from the code...

	* generic/tclInt.decls	...and from the internal stubs table.
	* generic/tclIntDecls.h
	* generic/tclStubInit.c

2004-08-24  Donal K. Fellows  <[email protected]>

	* doc/string.n: Added clarifying note.

2004-08-23  Don Porter	<[email protected]>

	* library/auto.tcl:	Updated [tcl_findLibrary] search path
	to include any [<pkg>::pkgconfig get scriptdir,runtime] directory,
	as well as the $::auto_path.  [RFE 695441]

2004-08-21  Kevin B. Kenny  <[email protected]>

	* tests/clock.test (clock-38.1): Changed TZ setting to specify
	CET in excruciating detail to deal with systems that lack the
	Posix defaults for DST changes (and to be formally correct with
	the change dates for CET).

2004-08-19  Donal K. Fellows  <[email protected]>

	* generic/tclScan.c (Tcl_ScanObjCmd, ValidateFormat): Ensure that
	the %ld conversion works correctly on 64-bit platforms. [Bug 1011860]

2004-08-19  Kevin Kenny	 <[email protected]>

	* library/clock.tcl (format): Changed default timezone format
	from alphabetic to numeric to produce scannable times in more
	locales.
	* tests/clock.test (clock-37.1): Removed now-unused 'needPST'
	constraint and the comments that refer to it.

1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910

	* doc/tm.n: New file, documentation for Tcl Modules, based on the
	  TIP.

	* unix/mkLinks: Regenerated.
	* win/makefile.vc: Added tm.tcl to list of files to install.

2004-08-18  Kevin Kenny  <[email protected]>

	* tests/httpd (httpdRespond): Corrected an abuse of the [clock]
	command that caused test failures for some values of [clock clicks].

	* doc/clock.n
	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_HideUnsafeCommands):
	* generic/tclClock.c (all):







|







5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153

	* doc/tm.n: New file, documentation for Tcl Modules, based on the
	  TIP.

	* unix/mkLinks: Regenerated.
	* win/makefile.vc: Added tm.tcl to list of files to install.

2004-08-18  Kevin Kenny	 <[email protected]>

	* tests/httpd (httpdRespond): Corrected an abuse of the [clock]
	command that caused test failures for some values of [clock clicks].

	* doc/clock.n
	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_HideUnsafeCommands):
	* generic/tclClock.c (all):
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114

	* doc/SetVar.3:
	* generic/tclTest.c (TestseterrorcodeCmd):
	* generic/tclVar.c (TclPtrSetVar):
	* tests/result.test (result-4.*, result-5.*): [Bug 1008314]
	detected and fixed by dgp.

2004-08-13  Don Porter  <[email protected]>

	* library/msgcat/msgcat.tcl:	Added checks to prevent [mclocale]
	* tests/msgcat.test:	from registering filesystem paths to possibly
	malicious code to be evaluated by a later [mcload].

2004-08-10  Zoran Vasiljevic <[email protected]>

	* unix/tclUnixThrd.c (TclpThreadCreate): changed handling of
	the returned thread ID since broken on 64-bit systems (Cray).
	Thanks to Rob Ratcliff for reporting the bug.

2004-08-03  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (MakeCachedEnsembleCommand): Initialize the
	epoch field cached in the subcommand. [Bug 989298]
	(NsEnsembleImplementationCmd): Plug a leak (thanks to Miguel Sofer
	for spotting it with valgrind) and reduce the number of goto
	labels to make the code clearer.

2004-08-02  Don Porter  <[email protected]>

	* library/package.tcl (pkg_mkIndex):	Updated [pkg_mkIndex] to
	make use of [glob -directory $dir -tails] and return options.

	TIP#207 IMPLEMENTATION

	* doc/interp.n:		Added support for a -namespace option to the
	* generic/tclBasic.c:	[interp invokehidden] command.  Also added an
	* generic/tclInt.h:	internal routine TclObjInvokeNamespace() and
	* generic/tclInterp.c:	corrected the flag names TCL_FIND_ONLY_NS and
	* generic/tclNamesp.c:	TCL_CREATE_NS_IF_UNKNOWN that are passed to the
	* generic/tclTrace.c:	internal routine TclGetNamespaceForQualName().
	* tests/interp.test:	[Patch 981841]

	* generic/tclLiteral.c (TclCleanupLiteralTable):	Corrected
	* tests/compile.test (compile-12.4):	flawed deletion of literal
	internal reps that could lead to accessing of freed memory.
	Thanks to Kevin Kenny for test case and fix [Bug 1001997].

2004-07-30  Don Porter  <[email protected]>

	* tests/safe.test (safe-2.1):  Disabled senseless test.  [Bug 999612]

	* library/auto.tcl (auto_reset):  Removed "protected" list of commands 
	from [auto_reset].  All entries in the auto_index can be re-loaded.
	* library/package.tcl: Updated comment to reflect 2004-07-28 commit.

	* generic/tclEvent.c (Tcl_Finalize):	Re-organized Tcl_Finalize
	so that Tcl_ExitProc's that call Tcl_Finalize recursively do not
	cause deadlock.  [Patch 999084 fixes Tk Bug 714956]

2004-07-30  Daniel Steffen  <[email protected]>

	* unix/configure:
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS 
	to explict object files in tcl.m4, refer to MAC_OSX_OBJS makefile var.
	* unix/Makefile.in: added MAC_OSX_OBJS variable.

2004-07-29  Don Porter  <[email protected]>

	* library/package.tcl:	[::pkg::create] is now an alias.  Test
	safe-2.1 will now fail until Bug 999612 is corrected.

2004-07-28  Don Porter  <[email protected]>

	* library/package.tcl:		Moved private command
	* library/tclIndex:		[pkg_compareExtension] into ::tcl::Pkg.
	* tests/pkg_mkIndex.test:	Also moved implementation of
	[::pkg::create] to [::tcl::Pkg::Create].

2004-07-25  Pat Thoyts  <[email protected]>

	* tests/io.test: Make io-61.1 create file as binary to pass on Win32

2004-07-23  Miguel Sofer <[email protected]>

	* generic/tclVar.c: simplify tclLocalVarNameType, removing the
	reference to the corresponding proc. The reference is now seen as
	unnecessary, and it may cause leaking circular references under
	some circumstances (see for example [Bug 994838]).

2004-07-22  Don Porter  <[email protected]>

	* tests/eofchar.data (removed): Test io-61.1 now generates its own
	* tests/io.test:        file of test data as needed.

2004-07-20  Jeff Hobbs  <[email protected]>

	* generic/tclEvent.c:       Correct threaded obj allocator to
	* generic/tclInt.h:         fully cleanup on exit and allow for
	* generic/tclThreadAlloc.c: reinitialization. [Bug #736426]
	* unix/tclUnixThrd.c:       (mistachkin, kenny)
	* win/tclWinThrd.c:

2004-07-21  Kevin Kenny  <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc):
	* generic/tclLiteral.c (TclCleanupLiteralTable):
	* generic/tclInt.h: added a TclCleanupLiteralTable function,
	called from DeleteInterpProc, that frees internal representations
	of shared literals early when an interpreter is being deleted.
	This change corrects a number of memory mismanagement issues in
	the cases where the internal representation of one literal
	contains a reference to another, and avoids conditions such as
	resolved variable names referring to procedure and namespace
	contexts that no longer exist.  [Bug 994838]

2004-07-20  Daniel Steffen  <[email protected]>

	* unix/Makefile.in:
	* win/Makefile.in: added 'install-private-headers' makefile target
	to allow optionally installing private tcl headers. [FR 922727]

	* macosx/Makefile: use new 'install-private-headers' target
	to install private headers into framework. [FR 922727]

	* unix/tclUnixFile.c (NativeMatchType): added support for
	readonly matching of user immutable files (where available).

	* macosx/tclMacOSXBundle.c: dynamically acquire address for
	CFBundleOpenBundleResourceMap symbol, since it is only present in
	full CoreFoundation on Mac OS X and not in CFLite on pure Darwin.

2004-07-19  Zoran Vasiljevic <[email protected]>

	* win/tclwinThrd.c: redefined MASTER_LOCK to call 
	TclpMasterLock. Fixes Bug #987967

2004-07-17  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to rare 'cd' infinite loop in
	normalization with vfs [Bug 991420].
	* tests/fileSystem.test: added test for above bug.

	* doc/FileSystem.3: clarified documentation of posix error
	codes in 'remove directory' FS proc - 'EEXIST' is used to
	signify a non-empty directory error (bug reported against
	tclvfs).

2004-07-16  Jeff Hobbs  <[email protected]>

	* unix/Makefile.in, unix/tcl.m4:     move (C|LD)FLAGS after their
	* unix/configure.in, unix/configure: _DEFAULT to allow for env
	setting to override m4 switches.  Move SC_MISSING_POSIX_HEADERS up
	and consolidate calls to limit redundancy in configure.
	(CFLAGS_WARNING): Remove -Wconversion
	(SC_ENABLE_THREADS): Set m4 to force threaded build when built







|



















|







|











|

|

|





|




|



|




|






|










|


|

|

|
|

|


|










|



















|













|







5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357

	* doc/SetVar.3:
	* generic/tclTest.c (TestseterrorcodeCmd):
	* generic/tclVar.c (TclPtrSetVar):
	* tests/result.test (result-4.*, result-5.*): [Bug 1008314]
	detected and fixed by dgp.

2004-08-13  Don Porter	<[email protected]>

	* library/msgcat/msgcat.tcl:	Added checks to prevent [mclocale]
	* tests/msgcat.test:	from registering filesystem paths to possibly
	malicious code to be evaluated by a later [mcload].

2004-08-10  Zoran Vasiljevic <[email protected]>

	* unix/tclUnixThrd.c (TclpThreadCreate): changed handling of
	the returned thread ID since broken on 64-bit systems (Cray).
	Thanks to Rob Ratcliff for reporting the bug.

2004-08-03  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (MakeCachedEnsembleCommand): Initialize the
	epoch field cached in the subcommand. [Bug 989298]
	(NsEnsembleImplementationCmd): Plug a leak (thanks to Miguel Sofer
	for spotting it with valgrind) and reduce the number of goto
	labels to make the code clearer.

2004-08-02  Don Porter	<[email protected]>

	* library/package.tcl (pkg_mkIndex):	Updated [pkg_mkIndex] to
	make use of [glob -directory $dir -tails] and return options.

	TIP#207 IMPLEMENTATION

	* doc/interp.n:		Added support for a -namespace option to the
	* generic/tclBasic.c:	[interp invokehidden] command.	Also added an
	* generic/tclInt.h:	internal routine TclObjInvokeNamespace() and
	* generic/tclInterp.c:	corrected the flag names TCL_FIND_ONLY_NS and
	* generic/tclNamesp.c:	TCL_CREATE_NS_IF_UNKNOWN that are passed to the
	* generic/tclTrace.c:	internal routine TclGetNamespaceForQualName().
	* tests/interp.test:	[Patch 981841]

	* generic/tclLiteral.c (TclCleanupLiteralTable):	Corrected
	* tests/compile.test (compile-12.4):	flawed deletion of literal
	internal reps that could lead to accessing of freed memory.
	Thanks to Kevin Kenny for test case and fix [Bug 1001997].

2004-07-30  Don Porter	<[email protected]>

	* tests/safe.test (safe-2.1):  Disabled senseless test.	 [Bug 999612]

	* library/auto.tcl (auto_reset):  Removed "protected" list of commands
	from [auto_reset].  All entries in the auto_index can be re-loaded.
	* library/package.tcl: Updated comment to reflect 2004-07-28 commit.

	* generic/tclEvent.c (Tcl_Finalize):	Re-organized Tcl_Finalize
	so that Tcl_ExitProc's that call Tcl_Finalize recursively do not
	cause deadlock.	 [Patch 999084 fixes Tk Bug 714956]

2004-07-30  Daniel Steffen  <[email protected]>

	* unix/configure:
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS
	to explict object files in tcl.m4, refer to MAC_OSX_OBJS makefile var.
	* unix/Makefile.in: added MAC_OSX_OBJS variable.

2004-07-29  Don Porter	<[email protected]>

	* library/package.tcl:	[::pkg::create] is now an alias.  Test
	safe-2.1 will now fail until Bug 999612 is corrected.

2004-07-28  Don Porter	<[email protected]>

	* library/package.tcl:		Moved private command
	* library/tclIndex:		[pkg_compareExtension] into ::tcl::Pkg.
	* tests/pkg_mkIndex.test:	Also moved implementation of
	[::pkg::create] to [::tcl::Pkg::Create].

2004-07-25  Pat Thoyts	<[email protected]>

	* tests/io.test: Make io-61.1 create file as binary to pass on Win32

2004-07-23  Miguel Sofer <[email protected]>

	* generic/tclVar.c: simplify tclLocalVarNameType, removing the
	reference to the corresponding proc. The reference is now seen as
	unnecessary, and it may cause leaking circular references under
	some circumstances (see for example [Bug 994838]).

2004-07-22  Don Porter	<[email protected]>

	* tests/eofchar.data (removed): Test io-61.1 now generates its own
	* tests/io.test:	file of test data as needed.

2004-07-20  Jeff Hobbs	<[email protected]>

	* generic/tclEvent.c:	    Correct threaded obj allocator to
	* generic/tclInt.h:	    fully cleanup on exit and allow for
	* generic/tclThreadAlloc.c: reinitialization. [Bug #736426]
	* unix/tclUnixThrd.c:	    (mistachkin, kenny)
	* win/tclWinThrd.c:

2004-07-21  Kevin Kenny	 <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc):
	* generic/tclLiteral.c (TclCleanupLiteralTable):
	* generic/tclInt.h: added a TclCleanupLiteralTable function,
	called from DeleteInterpProc, that frees internal representations
	of shared literals early when an interpreter is being deleted.
	This change corrects a number of memory mismanagement issues in
	the cases where the internal representation of one literal
	contains a reference to another, and avoids conditions such as
	resolved variable names referring to procedure and namespace
	contexts that no longer exist.	[Bug 994838]

2004-07-20  Daniel Steffen  <[email protected]>

	* unix/Makefile.in:
	* win/Makefile.in: added 'install-private-headers' makefile target
	to allow optionally installing private tcl headers. [FR 922727]

	* macosx/Makefile: use new 'install-private-headers' target
	to install private headers into framework. [FR 922727]

	* unix/tclUnixFile.c (NativeMatchType): added support for
	readonly matching of user immutable files (where available).

	* macosx/tclMacOSXBundle.c: dynamically acquire address for
	CFBundleOpenBundleResourceMap symbol, since it is only present in
	full CoreFoundation on Mac OS X and not in CFLite on pure Darwin.

2004-07-19  Zoran Vasiljevic <[email protected]>

	* win/tclwinThrd.c: redefined MASTER_LOCK to call
	TclpMasterLock. Fixes Bug #987967

2004-07-17  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to rare 'cd' infinite loop in
	normalization with vfs [Bug 991420].
	* tests/fileSystem.test: added test for above bug.

	* doc/FileSystem.3: clarified documentation of posix error
	codes in 'remove directory' FS proc - 'EEXIST' is used to
	signify a non-empty directory error (bug reported against
	tclvfs).

2004-07-16  Jeff Hobbs	<[email protected]>

	* unix/Makefile.in, unix/tcl.m4:     move (C|LD)FLAGS after their
	* unix/configure.in, unix/configure: _DEFAULT to allow for env
	setting to override m4 switches.  Move SC_MISSING_POSIX_HEADERS up
	and consolidate calls to limit redundancy in configure.
	(CFLAGS_WARNING): Remove -Wconversion
	(SC_ENABLE_THREADS): Set m4 to force threaded build when built
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162

	* unix/tclUnixThrd.c (TclpFinalizeMutex): Accepted Joe
	  Mistachkin's patch for [Tcl SF Bug 990453], closing leakage of
	  mutexes. They were not destroyed properly upon finalization.

2004-07-15  Andreas Kupries  <[email protected]>

	* generic/tclIO.h (CHANNEL_INCLOSE):       New flag. Set in
	* generic/tclIO.c (Tcl_UnregisterChannel): 'Tcl_Close' while the
	* generic/tclIO.c (Tcl_Close):             close callbacks are
	  run. Checked in 'Tcl_Close' and 'Tcl_Unregister' to prevent
	  recursive call of 'close' in the close-callbacks. This is a
	  possible error made by implementors of virtual filesystems based
	  on 'tclvfs', thinking that they have to close the channel in the
	  close handler for the filesystem.

2004-07-14  Andreas Kupries  <[email protected]>







|

|







5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405

	* unix/tclUnixThrd.c (TclpFinalizeMutex): Accepted Joe
	  Mistachkin's patch for [Tcl SF Bug 990453], closing leakage of
	  mutexes. They were not destroyed properly upon finalization.

2004-07-15  Andreas Kupries  <[email protected]>

	* generic/tclIO.h (CHANNEL_INCLOSE):	   New flag. Set in
	* generic/tclIO.c (Tcl_UnregisterChannel): 'Tcl_Close' while the
	* generic/tclIO.c (Tcl_Close):		   close callbacks are
	  run. Checked in 'Tcl_Close' and 'Tcl_Unregister' to prevent
	  recursive call of 'close' in the close-callbacks. This is a
	  possible error made by implementors of virtual filesystems based
	  on 'tclvfs', thinking that they have to close the channel in the
	  close handler for the filesystem.

2004-07-14  Andreas Kupries  <[email protected]>
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
	  <[email protected]>.

2004-07-15  Zoran Vasiljevic <[email protected]>

	* generic/tclEvent.c (Tcl_Finalize): stuffed memory leak
	incurred by re-initializing of TSD slots after the last call to
	TclFinalizeThreadData (done from within Tcl_FinalizeThread()).
	We basically just repeat the TclFinalizeThreadData() once more 
	before tearing down TSD keys in TclFinalizeSynchronization().  
	There should be more elaborate mechanism in place for handling
	such issues, based on thread cleanup handlers registered on the
	OS level. Such change requires much more work and would also
	require TIP because some visible parts of Tcl API would have to
	be modified. In the meantime, this will do.

	* generic/tclNotify.c (TclFinalizeNotifier): Added conditional
	notifier finalization based on the fact that an TclInitNotifier
	has been called for the current thread. This fixes the Tcl
	Bug #770053 again. Hopefully this time w/o unwanted side-effects.

2004-07-15  Kevin Kenny  <[email protected]>

	* generic/tclLiteral.c (TclReleaseLiteral): Removed unused
	variable 'codePtr' to silence a message from VC++.

2004-07-15  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclCompileScript): 
	* generic/tclLiteral.c (TclReleaseLiteral): fix for [Bug 467523],
	which resurfaced with the latest changes. The previous strategy
	was to have special code in TclReleaseLiteral to handle the
	self-references generated by empty scripts. The new approach
	avoids the self-reference altogether, by having empty scripts
	return an unshared literal.








|
|











|






|







5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
	  <[email protected]>.

2004-07-15  Zoran Vasiljevic <[email protected]>

	* generic/tclEvent.c (Tcl_Finalize): stuffed memory leak
	incurred by re-initializing of TSD slots after the last call to
	TclFinalizeThreadData (done from within Tcl_FinalizeThread()).
	We basically just repeat the TclFinalizeThreadData() once more
	before tearing down TSD keys in TclFinalizeSynchronization().
	There should be more elaborate mechanism in place for handling
	such issues, based on thread cleanup handlers registered on the
	OS level. Such change requires much more work and would also
	require TIP because some visible parts of Tcl API would have to
	be modified. In the meantime, this will do.

	* generic/tclNotify.c (TclFinalizeNotifier): Added conditional
	notifier finalization based on the fact that an TclInitNotifier
	has been called for the current thread. This fixes the Tcl
	Bug #770053 again. Hopefully this time w/o unwanted side-effects.

2004-07-15  Kevin Kenny	 <[email protected]>

	* generic/tclLiteral.c (TclReleaseLiteral): Removed unused
	variable 'codePtr' to silence a message from VC++.

2004-07-15  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclCompileScript):
	* generic/tclLiteral.c (TclReleaseLiteral): fix for [Bug 467523],
	which resurfaced with the latest changes. The previous strategy
	was to have special code in TclReleaseLiteral to handle the
	self-references generated by empty scripts. The new approach
	avoids the self-reference altogether, by having empty scripts
	return an unshared literal.

2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
	* generic/tclNamesp.c (BuildEnsembleConfig): Don't forget to clean
	out references when deleting the hash table.
	* generic/tclDictObj.c (Tcl_DictObjRemoveKeyList): Oops, forgot to
	delete value object when removing the hash entry. [Bug 989093 in part]

2004-07-11  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (TEBC): fixed leak of expandNestList objs 
	when there is an error while an expansion is in progress (code
	added at checkForCatch).

2004-07-11  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to 'cd' bug when vfs is active
	[Bug 986944 in tclvfs project] - this bug recently introduced
	by some threading fixes.  Need to work out how to add
	tests for this.

2004-07-10  Kevin Kenny  <[email protected]>

	* tests/clock.test (clock-2.11): Changed the test so that
	it isn't an infinite loop when run under valgrind on a slow
	virtual machine.  Thanks to Miguel Sofer for the bug report.
	Also put in code to restore env(LC_TIME) after tests complete,
	silencing a warning from 'make TESTFLAGS="-debug 1" test'.

2004-07-08  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc): reverted the modification
	of 3 days ago, as the leak of [Bug 983660] is now handled by the
	change in TclCleanupByteCode.
	* generic/tclCompile.c (TclCleanupByteCode): let each bytecode
	remove its references to literals at interp deletion, without
	updating the dying literal table.
	* generic/tclLiteral.c (TclDeleteLiteralTable): with the above
	change to TclCleanupByteCode, this function now removes a single
	reference to the literal object and cleans up its own structures.

2004-07-08  Kevin Kenny  <[email protected]>

	* win/tclWinInit.c (AppendEnvironment): Silenced a compilation
	warning about a type mismatch.

2004-07-07  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclCompileScript): fix for [Bug 458361]. 
	Single-word scripts are compiled with an unshared cmdName to avoid
	shimmering between bytecode and cmdName reps.

2004-07-07  Don Porter  <[email protected]>

	* generic/tclCmdMZ.c (TclMergeReturnOptions):  Simplified logic and
	removed potential memory leak.  [Bug 986257].

2004-07-07  Donal K. Fellows  <[email protected]>

	* tools/man2help2.tcl (setTabs, IPmacro): Added support for the
	more advanced *roff macros used in Tk's doc/bind.n

	* generic/tclObj.c (TclInitObjSubsystem): Declare all current
	object types.

2004-07-06  Don Porter  <[email protected]>

	* tests/cmdMZ.test (cmdMZ-return-2.17):  Added a test that a word
	containing backslash-quoted value is treated correctly.

	* generic/tclCompile.c (TclWordKnownAtCompileTime):  [Bug 986196]
	Corrected flaw above and the flaw that caused TCL_TOKEN_SIMPLE_WORDs
	to have their original word value copied ( "{a b}" ) rather than the
	actual value ( "a b" ).  Thanks to Kevin Kenny for report and tests.

2004-07-06  Kevin B. Kenny  <[email protected]>

	* tests/cmdMZ.test (cmdMZ-return-2.15,cmdMZ-return-2.16):
	Added a test that a return code containing spaces is correctly
	returned.

2004-07-06  Donal K. Fellows  <[email protected]>

	* tools/man2html2.tcl (IPmacro, setTabs): Added support for the
	more advanced *roff macros used in Tk's doc/bind.n

2004-07-05  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc): fix for [Bug 983660],
	found by pspjuth. Tear down the global namespace before freeing
	the interp handle, to allow the bytecodes to free their non-shared
	literals. 
	* generic/tclLiteral.c (TclReleaseLiteral): moved special code for
	self-ref so that it is also used for non-shared literals. Possible
	bug found by inspection.

2004-07-03  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (ExprRoundFunc):
	* tests/expr-old.test (39.1): added support for wide integers to
	round(); [Bug 908375], reported by Hemang Lavana. 

2004-07-03  Miguel Sofer <[email protected]>

	* generic/tclCompile.h:
	* generic/tclInt.decls:
	* generic/tclIntDecls.h:
	* generic/tclStubInit.c: Moved declaration of TclCompEvalObj()
	from tclCompile.h to the internal stubs table, for compiler
	experimentation. 

2004-07-02  Jeff Hobbs  <[email protected]>

	* generic/regcomp.c (stid): correct minor pointer size error

	* generic/tclPipe.c (TclCreatePipeline): applied TIP #202 patch
	* doc/exec.n, tests/exec.test:           that adds 2>@1 as a
	special case redirection of stderr to the result output.

2004-07-02  Kevin B. Kenny  <[email protected]>

	* tests/io.test: Changed several tests to run the event
	loop rather than just calling [update] periodically, avoiding
	intermittent failures (usually in io-29.32) that stemmed from 
	unreaped processes on Windows.
	* tests/winPipe.test (winpipe-1.11): Fixed a bug that caused
	test to fail if the path name of the working directory contained
	whitespace [Bug 678430]

2004-07-01  Vince Darley  <[email protected]>

	* tests/fileSystem.test: Added test for [Bug 970529]

2004-07-01  Donal K. Fellows  <[email protected]>

	* win/README.binary, win/README: Updated references to Tcl and Tk
	8.4 to point to 8.5 instead.  Thanks to Theo Verelst for spotting
	this.
	* generic/tcl.h: Added note to help prevent those changes from
	getting missed in the future.

	* doc/Namespace.3, doc/load.n, doc/Limit.3: Typo fixes and remove
	duplicate documentation. [Bug 983146]

2004-06-30  Don Porter  <[email protected]>

	* tests/fileSystem.test: Minor correction to new fileSystem-9.X
	tests so that they clean up temporary directories correctly.

2004-06-30  Vince Darley  <[email protected]>

	* doc/filename.n: clarified behaviour concerning trailing
	slashes in filenames [Bug 971976]

	* win/tclWinFile.c:
	* tests/fileSystem.test: fix and tests for [Bug 979879]

2004-06-30  Donal K. Fellows  <[email protected]>

	TIP#188 IMPLEMENTATION

	* doc/string.n, tests/string.test:	 Add 'wideinteger' to things
	* generic/tclCmdMZ.c (Tcl_StringObjCmd): that can be tested for with
	the [string is] subcommand. [Patch 940915, by Kevin Kenny]

2004-06-29  Don Porter  <[email protected]>

	* win/tclWinInit.c:	Corrected reference counting flaw in
	recent changes.  Thanks to Pat Thoyts. [Bug 981893].

2004-06-29  Vince Darley  <[email protected]>

	* win/tclWin32Dll.c: fix to compilation with VC++ 5.2

2004-06-29  Donal K. Fellows  <[email protected]>

	* library/safe.tcl: Make sure that the temporary variable is
	local to the namespace and not inadvertently global. [Bug 981733]

2004-06-24  Donal K. Fellows  <[email protected]>

	* tests/unixNotfy.test: Modified constraints so that testing with
	a threaded tclsh (not tcltest) will not hang.

2004-06-23  Don Porter  <[email protected]>

	* generic/tclThreadStorage.c:	Corrected type casting errors that led
	to calculation of a negative index value, thus accesses outside the
	threadStorageCache array, thus memory corruption.  Crash observed on
	Mac OS X platform.

2004-06-23  Joe Mistachkin  <[email protected]>







|










|



















|






|



|


|









|

|





|

















|








|








|

|




|






|




















|




















|


|















|







5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
	* generic/tclNamesp.c (BuildEnsembleConfig): Don't forget to clean
	out references when deleting the hash table.
	* generic/tclDictObj.c (Tcl_DictObjRemoveKeyList): Oops, forgot to
	delete value object when removing the hash entry. [Bug 989093 in part]

2004-07-11  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (TEBC): fixed leak of expandNestList objs
	when there is an error while an expansion is in progress (code
	added at checkForCatch).

2004-07-11  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to 'cd' bug when vfs is active
	[Bug 986944 in tclvfs project] - this bug recently introduced
	by some threading fixes.  Need to work out how to add
	tests for this.

2004-07-10  Kevin Kenny	 <[email protected]>

	* tests/clock.test (clock-2.11): Changed the test so that
	it isn't an infinite loop when run under valgrind on a slow
	virtual machine.  Thanks to Miguel Sofer for the bug report.
	Also put in code to restore env(LC_TIME) after tests complete,
	silencing a warning from 'make TESTFLAGS="-debug 1" test'.

2004-07-08  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc): reverted the modification
	of 3 days ago, as the leak of [Bug 983660] is now handled by the
	change in TclCleanupByteCode.
	* generic/tclCompile.c (TclCleanupByteCode): let each bytecode
	remove its references to literals at interp deletion, without
	updating the dying literal table.
	* generic/tclLiteral.c (TclDeleteLiteralTable): with the above
	change to TclCleanupByteCode, this function now removes a single
	reference to the literal object and cleans up its own structures.

2004-07-08  Kevin Kenny	 <[email protected]>

	* win/tclWinInit.c (AppendEnvironment): Silenced a compilation
	warning about a type mismatch.

2004-07-07  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclCompileScript): fix for [Bug 458361].
	Single-word scripts are compiled with an unshared cmdName to avoid
	shimmering between bytecode and cmdName reps.

2004-07-07  Don Porter	<[email protected]>

	* generic/tclCmdMZ.c (TclMergeReturnOptions):  Simplified logic and
	removed potential memory leak.	[Bug 986257].

2004-07-07  Donal K. Fellows  <[email protected]>

	* tools/man2help2.tcl (setTabs, IPmacro): Added support for the
	more advanced *roff macros used in Tk's doc/bind.n

	* generic/tclObj.c (TclInitObjSubsystem): Declare all current
	object types.

2004-07-06  Don Porter	<[email protected]>

	* tests/cmdMZ.test (cmdMZ-return-2.17):	 Added a test that a word
	containing backslash-quoted value is treated correctly.

	* generic/tclCompile.c (TclWordKnownAtCompileTime):  [Bug 986196]
	Corrected flaw above and the flaw that caused TCL_TOKEN_SIMPLE_WORDs
	to have their original word value copied ( "{a b}" ) rather than the
	actual value ( "a b" ).	 Thanks to Kevin Kenny for report and tests.

2004-07-06  Kevin B. Kenny  <[email protected]>

	* tests/cmdMZ.test (cmdMZ-return-2.15,cmdMZ-return-2.16):
	Added a test that a return code containing spaces is correctly
	returned.

2004-07-06  Donal K. Fellows  <[email protected]>

	* tools/man2html2.tcl (IPmacro, setTabs): Added support for the
	more advanced *roff macros used in Tk's doc/bind.n

2004-07-05  Miguel Sofer <[email protected]>

	* generic/tclBasic.c (DeleteInterpProc): fix for [Bug 983660],
	found by pspjuth. Tear down the global namespace before freeing
	the interp handle, to allow the bytecodes to free their non-shared
	literals.
	* generic/tclLiteral.c (TclReleaseLiteral): moved special code for
	self-ref so that it is also used for non-shared literals. Possible
	bug found by inspection.

2004-07-03  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (ExprRoundFunc):
	* tests/expr-old.test (39.1): added support for wide integers to
	round(); [Bug 908375], reported by Hemang Lavana.

2004-07-03  Miguel Sofer <[email protected]>

	* generic/tclCompile.h:
	* generic/tclInt.decls:
	* generic/tclIntDecls.h:
	* generic/tclStubInit.c: Moved declaration of TclCompEvalObj()
	from tclCompile.h to the internal stubs table, for compiler
	experimentation.

2004-07-02  Jeff Hobbs	<[email protected]>

	* generic/regcomp.c (stid): correct minor pointer size error

	* generic/tclPipe.c (TclCreatePipeline): applied TIP #202 patch
	* doc/exec.n, tests/exec.test:		 that adds 2>@1 as a
	special case redirection of stderr to the result output.

2004-07-02  Kevin B. Kenny  <[email protected]>

	* tests/io.test: Changed several tests to run the event
	loop rather than just calling [update] periodically, avoiding
	intermittent failures (usually in io-29.32) that stemmed from
	unreaped processes on Windows.
	* tests/winPipe.test (winpipe-1.11): Fixed a bug that caused
	test to fail if the path name of the working directory contained
	whitespace [Bug 678430]

2004-07-01  Vince Darley  <[email protected]>

	* tests/fileSystem.test: Added test for [Bug 970529]

2004-07-01  Donal K. Fellows  <[email protected]>

	* win/README.binary, win/README: Updated references to Tcl and Tk
	8.4 to point to 8.5 instead.  Thanks to Theo Verelst for spotting
	this.
	* generic/tcl.h: Added note to help prevent those changes from
	getting missed in the future.

	* doc/Namespace.3, doc/load.n, doc/Limit.3: Typo fixes and remove
	duplicate documentation. [Bug 983146]

2004-06-30  Don Porter	<[email protected]>

	* tests/fileSystem.test: Minor correction to new fileSystem-9.X
	tests so that they clean up temporary directories correctly.

2004-06-30  Vince Darley  <[email protected]>

	* doc/filename.n: clarified behaviour concerning trailing
	slashes in filenames [Bug 971976]

	* win/tclWinFile.c:
	* tests/fileSystem.test: fix and tests for [Bug 979879]

2004-06-30  Donal K. Fellows  <[email protected]>

	TIP#188 IMPLEMENTATION

	* doc/string.n, tests/string.test:	 Add 'wideinteger' to things
	* generic/tclCmdMZ.c (Tcl_StringObjCmd): that can be tested for with
	the [string is] subcommand. [Patch 940915, by Kevin Kenny]

2004-06-29  Don Porter	<[email protected]>

	* win/tclWinInit.c:	Corrected reference counting flaw in
	recent changes.	 Thanks to Pat Thoyts. [Bug 981893].

2004-06-29  Vince Darley  <[email protected]>

	* win/tclWin32Dll.c: fix to compilation with VC++ 5.2

2004-06-29  Donal K. Fellows  <[email protected]>

	* library/safe.tcl: Make sure that the temporary variable is
	local to the namespace and not inadvertently global. [Bug 981733]

2004-06-24  Donal K. Fellows  <[email protected]>

	* tests/unixNotfy.test: Modified constraints so that testing with
	a threaded tclsh (not tcltest) will not hang.

2004-06-23  Don Porter	<[email protected]>

	* generic/tclThreadStorage.c:	Corrected type casting errors that led
	to calculation of a negative index value, thus accesses outside the
	threadStorageCache array, thus memory corruption.  Crash observed on
	Mac OS X platform.

2004-06-23  Joe Mistachkin  <[email protected]>
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
	* unix/tcl.m4:
	* win/makefile.vc:
	* win/rules.vc:
	* win/Makefile.in: Modified the unix, VC++, and Cygwin build systems
	* win/configure: to include the new "tclThreadStorage.c" and the new
	* win/tcl.m4: USE_THREAD_STORAGE define.

2004-06-23  Pat Thoyts  <[email protected]>

	* tests/io.test: Added -force to 18.1 and 18.2. This was failing
	on WinXP.

	* tests/winFCmd.test: Added a cleanup to winFCmd-16.11 to avoid a
	failure in 16.12.








|







5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
	* unix/tcl.m4:
	* win/makefile.vc:
	* win/rules.vc:
	* win/Makefile.in: Modified the unix, VC++, and Cygwin build systems
	* win/configure: to include the new "tclThreadStorage.c" and the new
	* win/tcl.m4: USE_THREAD_STORAGE define.

2004-06-23  Pat Thoyts	<[email protected]>

	* tests/io.test: Added -force to 18.1 and 18.2. This was failing
	on WinXP.

	* tests/winFCmd.test: Added a cleanup to winFCmd-16.11 to avoid a
	failure in 16.12.

2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
	winDde-4.2, -6.5, and -6.6 appear to be much less frequent.
	[Bug #957449]

2004-06-23  Donal K. Fellows  <[email protected]>

	* tests/*.test: Standardize use of platform constraints.

	* unix/tclUnixInit.c (GetStackSize, TclpCheckStackSpace): 
	* unix/tclUnixThrd.c (TclpThreadGetStackSize): Added code to check
	whether the C stack is about to be exceeded, from [Patch 746378]
	by Joe Mistachkin but with substantial revisions.

2004-06-22  Kevin Kenny  <[email protected]>

	* generic/tclEvent.c (NewThreadProc): Fixed broken build on
	Windows caused by missing TCL_THREAD_CREATE_RETURN.

	* tests/stack.test (stack-3.1): Corrected nuisance error in
	threaded builds.








|




|







5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
	winDde-4.2, -6.5, and -6.6 appear to be much less frequent.
	[Bug #957449]

2004-06-23  Donal K. Fellows  <[email protected]>

	* tests/*.test: Standardize use of platform constraints.

	* unix/tclUnixInit.c (GetStackSize, TclpCheckStackSpace):
	* unix/tclUnixThrd.c (TclpThreadGetStackSize): Added code to check
	whether the C stack is about to be exceeded, from [Patch 746378]
	by Joe Mistachkin but with substantial revisions.

2004-06-22  Kevin Kenny	 <[email protected]>

	* generic/tclEvent.c (NewThreadProc): Fixed broken build on
	Windows caused by missing TCL_THREAD_CREATE_RETURN.

	* tests/stack.test (stack-3.1): Corrected nuisance error in
	threaded builds.

2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524

2004-06-21  Donal K. Fellows  <[email protected]>

	* generic/tclThreadAlloc.c (Ptr2Block): Rewrote so as to maximize
	the chance of detecting and reporting a memory inconsistency without
	relying on things being consistent. [Bug 975895]

2004-06-18  Don Porter  <[email protected]>

	* tests/load.test:	Relaxed strictness of error message matching
	for test load-2.3 so that it will pass on Mac OSX.

	* generic/tclEncoding.c: Static TclFindEncodings -> FindEncodings.
	* generic/tclInt.h:	Updated TclpFindExecutable() so that failed
	* generic/tclUtil.c:	attempts to find the executable are saved







|







5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767

2004-06-21  Donal K. Fellows  <[email protected]>

	* generic/tclThreadAlloc.c (Ptr2Block): Rewrote so as to maximize
	the chance of detecting and reporting a memory inconsistency without
	relying on things being consistent. [Bug 975895]

2004-06-18  Don Porter	<[email protected]>

	* tests/load.test:	Relaxed strictness of error message matching
	for test load-2.3 so that it will pass on Mac OSX.

	* generic/tclEncoding.c: Static TclFindEncodings -> FindEncodings.
	* generic/tclInt.h:	Updated TclpFindExecutable() so that failed
	* generic/tclUtil.c:	attempts to find the executable are saved
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
	* unix/configure: autoconf-2.57

2004-06-18  Donal K. Fellows  <[email protected]>

	* unix/tclUnixInit.c (localeTable): Added some more locale to
	encoding mapping info from Jim Huang <[email protected]>

	* generic/tclInt.h (PendingObjData,TclFreeObjMacro,etc): 
	* generic/tclObj.c (TclFreeObj): Added scheme for making TclFreeObj()
	avoid blowing up the C stack when freeing up very large object
	trees. [Bug 886231]

	* win/tclWinInit.c (SetDefaultLibraryDir): Fix logic, simplify and
	add comments.

2004-06-17  Don Porter  <[email protected]>

	* generic/tclObj.c:	Added missing space in panic message.

	* win/tclWinInit.c:	Inform [tclInit] about the default library
	directory via the ::tclDefaultLibrary variable.  This should correct
	a problem with my 2004-06-11 commit.  Better solutions still in the
	works.  Thanks to Joe Mistachkin for pointing out the breakage.

2004-06-16  Don Porter  <[email protected]>

	* doc/library.n:	Moved variables ::auto_oldpath and
	* library/auto.tcl:	::unknown_pending into ::tcl namespace.
	* library/init.tcl:	[Bugs 808319, 948794]

2004-06-15  Donal K. Fellows  <[email protected]>

	* doc/binary.n: Added some notes to the documentation of the 'a'
	format to address the point raised in [RFE 768852].

2004-06-15  Jeff Hobbs  <[email protected]>

	* unix/tclConfig.sh.in (TCL_EXTRA_CFLAGS): set to @CFLAGS@, which
	is the configure-time CFLAGS. Addendum to m4 change on 2004-05-26.

2004-06-14  Kevin Kenny  <[email protected]>

	* win/Makefile.in: Corrected compilation flags for tclPkgConfig.c
	so that it doesn't require Stubs.
	* generic/tclBasic.c (Tcl_CreateInterp): Removed comment stating
	that TclInitEmbeddedConfigurationInformation needs Stubs; with the
	change above, the comment is now erroneous.

2004-06-11  Don Porter  <[email protected]>

	* doc/Encoding.3:	Removed bogus claims about tcl_libPath.

	* generic/tclInterp.c (Tcl_Init):	Stopped setting the
	tcl_libPath variable.  [tclInit] can get all its directories
	without it.








|







|




|

|

|










|




|







|







5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
	* unix/configure: autoconf-2.57

2004-06-18  Donal K. Fellows  <[email protected]>

	* unix/tclUnixInit.c (localeTable): Added some more locale to
	encoding mapping info from Jim Huang <[email protected]>

	* generic/tclInt.h (PendingObjData,TclFreeObjMacro,etc):
	* generic/tclObj.c (TclFreeObj): Added scheme for making TclFreeObj()
	avoid blowing up the C stack when freeing up very large object
	trees. [Bug 886231]

	* win/tclWinInit.c (SetDefaultLibraryDir): Fix logic, simplify and
	add comments.

2004-06-17  Don Porter	<[email protected]>

	* generic/tclObj.c:	Added missing space in panic message.

	* win/tclWinInit.c:	Inform [tclInit] about the default library
	directory via the ::tclDefaultLibrary variable.	 This should correct
	a problem with my 2004-06-11 commit.  Better solutions still in the
	works.	Thanks to Joe Mistachkin for pointing out the breakage.

2004-06-16  Don Porter	<[email protected]>

	* doc/library.n:	Moved variables ::auto_oldpath and
	* library/auto.tcl:	::unknown_pending into ::tcl namespace.
	* library/init.tcl:	[Bugs 808319, 948794]

2004-06-15  Donal K. Fellows  <[email protected]>

	* doc/binary.n: Added some notes to the documentation of the 'a'
	format to address the point raised in [RFE 768852].

2004-06-15  Jeff Hobbs	<[email protected]>

	* unix/tclConfig.sh.in (TCL_EXTRA_CFLAGS): set to @CFLAGS@, which
	is the configure-time CFLAGS. Addendum to m4 change on 2004-05-26.

2004-06-14  Kevin Kenny	 <[email protected]>

	* win/Makefile.in: Corrected compilation flags for tclPkgConfig.c
	so that it doesn't require Stubs.
	* generic/tclBasic.c (Tcl_CreateInterp): Removed comment stating
	that TclInitEmbeddedConfigurationInformation needs Stubs; with the
	change above, the comment is now erroneous.

2004-06-11  Don Porter	<[email protected]>

	* doc/Encoding.3:	Removed bogus claims about tcl_libPath.

	* generic/tclInterp.c (Tcl_Init):	Stopped setting the
	tcl_libPath variable.  [tclInit] can get all its directories
	without it.

2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
	* win/configure.in:

	* generic/tclBasic.c (Tcl_CreateInterp): Moved call to
	TclInitEmbeddedConfigurationInformation() earlier in
	Tcl_CreateInterp() so that other parts of interp creation
	and initialization may access and use the config values.

2004-06-11  Kevin Kenny  <[email protected]>

	* win/tclAppInit.c: Restored the 'setargv' procedure when
	compiling with mingw.  Apparently, the command line parsing in
	mingw doesn't work as well as that in vc++, and the result was
	(1) that winPipe-8.19 failed, and (2) that 'make test' would
	work at all only with TESTFLAGS='-singleproc 1'. [Bug 967195]

2004-06-10  Zoran Vasiljevic <[email protected]>

	* generic/tclIOUtil.c: removed forceful setting of the
	  private cached current working directory rep from 
	  within the Tcl_FSChdir(). We delegate this task to
	  the Tcl_FSGetCwd() which does this task anyway.
	  The relevant code is still present but disabled 
	  temporarily until the change proves correct. The Tcl
	  test suite passes all test with the given change so
	  I suppose it is good enough.

2004-06-10  Don Porter  <[email protected]>

	* unix/tclUnixInit.c (TclpInitLibraryPath):	Disabled addition of
	* win/tclWinInit.c (TclpInitLibraryPath):	relative-to-executable
	directories to the library search path.  A first step in reform of
	Tcl's startup process.

	***POTENTIAL INCOMPATIBILITY***
	Attempts to directly run ./tclsh or ./tcltest out of a build
	directory will either fail, or will make use of an installed
	script library in preference to the one in the source tree.
	Use `make shell` or `make runtest` instead.

	* tests/unixInit.test:  Modified tests to suit above changes.

	* generic/tclPathObj.c:	Corrected [file tail] results when operating
	on a path produced by TclNewFSPathObj(). [Bug 970529]

2004-06-09  Zoran Vasiljevic <[email protected]>

	* generic/tclIOUtil.c: partially corrected [Bug 932314].
	  Also, corrected return values of Tcl_FSChdir() to 
	  reflect those of the underlying platform-specific call.
	  Originally, return codes were mixed with those of Tcl.

2004-06-08  Miguel Sofer <[email protected]>

	* generic/tclCompile.c: 
	* generic/tclExecute.c: handle warning [Bug 969066]

2004-06-08  Donal K. Fellows  <[email protected]>

	* generic/tclHash.c (RebuildTable): Move declaration of variable
	so it is only declared when it is used. [Bug 969068]








|










|


|




|



|








|







|





|







5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
	* win/configure.in:

	* generic/tclBasic.c (Tcl_CreateInterp): Moved call to
	TclInitEmbeddedConfigurationInformation() earlier in
	Tcl_CreateInterp() so that other parts of interp creation
	and initialization may access and use the config values.

2004-06-11  Kevin Kenny	 <[email protected]>

	* win/tclAppInit.c: Restored the 'setargv' procedure when
	compiling with mingw.  Apparently, the command line parsing in
	mingw doesn't work as well as that in vc++, and the result was
	(1) that winPipe-8.19 failed, and (2) that 'make test' would
	work at all only with TESTFLAGS='-singleproc 1'. [Bug 967195]

2004-06-10  Zoran Vasiljevic <[email protected]>

	* generic/tclIOUtil.c: removed forceful setting of the
	  private cached current working directory rep from
	  within the Tcl_FSChdir(). We delegate this task to
	  the Tcl_FSGetCwd() which does this task anyway.
	  The relevant code is still present but disabled
	  temporarily until the change proves correct. The Tcl
	  test suite passes all test with the given change so
	  I suppose it is good enough.

2004-06-10  Don Porter	<[email protected]>

	* unix/tclUnixInit.c (TclpInitLibraryPath):	Disabled addition of
	* win/tclWinInit.c (TclpInitLibraryPath):	relative-to-executable
	directories to the library search path.	 A first step in reform of
	Tcl's startup process.

	***POTENTIAL INCOMPATIBILITY***
	Attempts to directly run ./tclsh or ./tcltest out of a build
	directory will either fail, or will make use of an installed
	script library in preference to the one in the source tree.
	Use `make shell` or `make runtest` instead.

	* tests/unixInit.test:	Modified tests to suit above changes.

	* generic/tclPathObj.c:	Corrected [file tail] results when operating
	on a path produced by TclNewFSPathObj(). [Bug 970529]

2004-06-09  Zoran Vasiljevic <[email protected]>

	* generic/tclIOUtil.c: partially corrected [Bug 932314].
	  Also, corrected return values of Tcl_FSChdir() to
	  reflect those of the underlying platform-specific call.
	  Originally, return codes were mixed with those of Tcl.

2004-06-08  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:
	* generic/tclExecute.c: handle warning [Bug 969066]

2004-06-08  Donal K. Fellows  <[email protected]>

	* generic/tclHash.c (RebuildTable): Move declaration of variable
	so it is only declared when it is used. [Bug 969068]

2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
	* generic/tclInt.decls:			clock frequency in
	* generic/tclIntDecls.h:		Tcl_WinTime
	* generic/tclIntPlatDecls.h:		so that any clock frequency
	* generic/tclPlatDecls.h:		is accepted provided that
	* generic/tclStubInit.c:		all CPU's in the system share
	* tests/platform.test (platform-1.3):	a common chip, and hence,
	* win/tclWin32Dll.c (TclWinCPUID):	presumably, a common clock.
	* win/tclWinTest.c (TestwincpuidCmd)	This change necessitated a 
	* win/tclWinTime.c (Tcl_GetTime):	small burst of assembly code 
	to read CPU ID information, which was added as TclWinCPUID in the
	internal Stubs.  To test this code in the common case of a
	single-processor machine, a 'testwincpuid' command was added to
	tclWinTest.c, and a test case in platform.test.  Thanks to Jeff
	Godfrey and Richard Suchenwirth for reporting this bug. [Bug
	#976722]

2004-06-04  Don Porter  <[email protected]>

	* generic/tcl.h:	Restored #include <stdio.h> to tcl.h,
	rejecting the "fix" for "Bug" 945570.  Tcl_FSSeek() needs the
	values of SEEK_SET, etc. and too many extensions rely on tcl.h
	providing stdio.h for them.

2004-06-02  Jeff Hobbs  <[email protected]>

	* win/tclWinFile.c (TclpFindExecutable): when using
	GetModuleFileNameA (Win9x), convert from CP_ACP to WCHAR then
	convert back to utf8.  Adjunct to 2004-04-07 fix.

2004-06-02  David Gravereaux <[email protected]>

	* tests/winPipe.test (winpipe-6.1): blocking set to 1 before
	closing to ensure we get an exitcode.  The windows pipe channel
	driver doesn't differentiate between a blocking and non-blocking
	close just yet, but will soon.  Part of [Bug 947693]

2004-06-02  Vince Darley  <[email protected]>

	* doc/file.n: fix to documentation of 'file volumes' (Bug 962435)

2004-06-01  David Gravereaux <[email protected]>








|
|

|

|



|






|










|







5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
	* generic/tclInt.decls:			clock frequency in
	* generic/tclIntDecls.h:		Tcl_WinTime
	* generic/tclIntPlatDecls.h:		so that any clock frequency
	* generic/tclPlatDecls.h:		is accepted provided that
	* generic/tclStubInit.c:		all CPU's in the system share
	* tests/platform.test (platform-1.3):	a common chip, and hence,
	* win/tclWin32Dll.c (TclWinCPUID):	presumably, a common clock.
	* win/tclWinTest.c (TestwincpuidCmd)	This change necessitated a
	* win/tclWinTime.c (Tcl_GetTime):	small burst of assembly code
	to read CPU ID information, which was added as TclWinCPUID in the
	internal Stubs.	 To test this code in the common case of a
	single-processor machine, a 'testwincpuid' command was added to
	tclWinTest.c, and a test case in platform.test.	 Thanks to Jeff
	Godfrey and Richard Suchenwirth for reporting this bug. [Bug
	#976722]

2004-06-04  Don Porter	<[email protected]>

	* generic/tcl.h:	Restored #include <stdio.h> to tcl.h,
	rejecting the "fix" for "Bug" 945570.  Tcl_FSSeek() needs the
	values of SEEK_SET, etc. and too many extensions rely on tcl.h
	providing stdio.h for them.

2004-06-02  Jeff Hobbs	<[email protected]>

	* win/tclWinFile.c (TclpFindExecutable): when using
	GetModuleFileNameA (Win9x), convert from CP_ACP to WCHAR then
	convert back to utf8.  Adjunct to 2004-04-07 fix.

2004-06-02  David Gravereaux <[email protected]>

	* tests/winPipe.test (winpipe-6.1): blocking set to 1 before
	closing to ensure we get an exitcode.  The windows pipe channel
	driver doesn't differentiate between a blocking and non-blocking
	close just yet, but will soon.	Part of [Bug 947693]

2004-06-02  Vince Darley  <[email protected]>

	* doc/file.n: fix to documentation of 'file volumes' (Bug 962435)

2004-06-01  David Gravereaux <[email protected]>

2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
	each function in the limit implementation and rewrote the names of
	some non-public functions for greater clarity of purpose.
	* doc/interp.n: Added note about what happens when a limited
	interpreter creates a slave interpreter.
	* doc/Limit.3: Added manual page for the resource limit
	subsystem's C API. [Bug 953903]

2004-05-29  Joe English  <[email protected]>

	* doc/global.n, doc/interp.n, doc/lrange.n:
	Fix minor markup errors.

2004-05-28  Donal K. Fellows  <[email protected]>

	* doc/*.n: Added examples to many (too many to list) more man pages.







|







5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
	each function in the limit implementation and rewrote the names of
	some non-public functions for greater clarity of purpose.
	* doc/interp.n: Added note about what happens when a limited
	interpreter creates a slave interpreter.
	* doc/Limit.3: Added manual page for the resource limit
	subsystem's C API. [Bug 953903]

2004-05-29  Joe English	 <[email protected]>

	* doc/global.n, doc/interp.n, doc/lrange.n:
	Fix minor markup errors.

2004-05-28  Donal K. Fellows  <[email protected]>

	* doc/*.n: Added examples to many (too many to list) more man pages.
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
	* generic/tclCmdMZ.c (Tcl_StringObjCmd):	uses are performed.

	The overall effect is to make building with gcc with the
	additional flags -Wstrict-prototypes -Wmissing-prototypes produce
	no increase in the total number of warnings (except for main(),
	which is undeclared for traditional reasons.)

2004-05-26  Jeff Hobbs  <[email protected]>

	* unix/Makefile.in:  Rework configure ordering to TCL_LINK_LIBS,
	* unix/tcl.m4:       ENABLE_SHARED, CONFIG_CFLAGS, & ENABLE_SYMBOLS
	* unix/configure:    before TCL_EARLY_FLAGS and TCL_64BIT_FLAGS
	* unix/configure.in: (about 400 lines earlier) in configure.in.
	This forces CFLAGS configuration to be done before many tests,
	which is needed for 64-bit builds and may affect other builds.
	Also make CONFIG_CFLAGS append to CFLAGS directly instead of using
	EXTRA_CFLAGS, and have LDFLAGS append to any existing value.
	[Bug #874058]
	* unix/dltest/Makefile.in: change EXTRA_CFLAGS to DEFS

2004-05-26  Don Porter  <[email protected]>

	* library/tcltest/tcltest.tcl:	Correction to debug prints and testing
	* library/tcltest/pkgIndex.tcl:	if TCLTEST_OPTIONS value.  Corrected
	* tests/tcltest.test:		double increment of numTestFiles in
	-singleproc 1 configurations.  Updated tcltest-19.1 to tcltest 2.1
	behavior.  Corrected tcltest-25.3 to not falsely report a failure
	in tcltest.test.  Bumped to tcltest 2.2.6.  [Bugs 960560, 960926]

2004-05-25  Jeff Hobbs  <[email protected]>

	* doc/http.n (http::config): add -urlencoding option (default utf-8)
	* library/http/http.tcl:     that specifies encoding conversion of
	* library/http/pkgIndex.tcl: args for http::formatQuery.  Previously
	* tests/http.test:           undefined, RFC 2718 says it should be
	utf-8. 'http::config -urlencoding {}' returns previous behavior,
	which will throw errors processing non-latin-1 chars.
	Bumped http package to 2.5.0.

2004-05-25  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (DeleteScriptLimitCallback): Move all
	deletion of script callback hash table entries to happen here so
	the entries are correctly removed at the right time.  [Bug 960410]

2004-05-25  Miguel Sofer <[email protected]>

	* docs/global.n: added details for qualified variable names 
	[Bug 959831]

2004-05-25  Miguel Sofer <[email protected]>

	* generic/tclNamesp.c (Tcl_FindNamespaceVar):
	* tests/namespace.test (namespace-17.10-12): reverted commit of
	2004-05-23 and removed the tests, as it interferes with the
	varname resolver and there are apps that break (AlphaTk). A fix
	will have to wait for Tcl9.

	* generic/tclVar.c: Caching of namespace variables disabled: no
	simple way was found to avoid interfering with the resolver's idea
	of variable existence. A cached varName may keep a variable's name
	in the namespace's hash table, which is the resolver's criterion
	for existence.

	* tests/namespace.c (namespace-17.10): testing for interference
	between varname caching and name resolver.

2004-05-25  Kevin Kenny  <[email protected]>

	* tests/winFCmd.test: Correct test for the presence of a CD-ROM so
	                      that it doesn't misdetect some other sort
	                      of filesystem with a write-protected root as
	                      being a CD-ROM drive. [Bug 918267]

2004-05-25  Don Porter  <[email protected]>

	* tests/winPipe.test:	Protect against path being set 
	* tests/unixInit.test:	Unset path when done.
	* tests/unload.test (unload-3.1): Verify [pkgb_sub] does not exist.
	Delete interps when done.
	* tests/stringComp.test:	stop re-use of string.test test names
	* tests/regexpComp.test:	stop re-use of regexp.test test names
	* tests/namespace.test (namespace-46.3): Verify [p] does not exist.
	* tests/http.test:	Clear away the custom [bgerror] when done.







|


|









|








|




|












|



















|


|
|
|

|

|







6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
	* generic/tclCmdMZ.c (Tcl_StringObjCmd):	uses are performed.

	The overall effect is to make building with gcc with the
	additional flags -Wstrict-prototypes -Wmissing-prototypes produce
	no increase in the total number of warnings (except for main(),
	which is undeclared for traditional reasons.)

2004-05-26  Jeff Hobbs	<[email protected]>

	* unix/Makefile.in:  Rework configure ordering to TCL_LINK_LIBS,
	* unix/tcl.m4:	     ENABLE_SHARED, CONFIG_CFLAGS, & ENABLE_SYMBOLS
	* unix/configure:    before TCL_EARLY_FLAGS and TCL_64BIT_FLAGS
	* unix/configure.in: (about 400 lines earlier) in configure.in.
	This forces CFLAGS configuration to be done before many tests,
	which is needed for 64-bit builds and may affect other builds.
	Also make CONFIG_CFLAGS append to CFLAGS directly instead of using
	EXTRA_CFLAGS, and have LDFLAGS append to any existing value.
	[Bug #874058]
	* unix/dltest/Makefile.in: change EXTRA_CFLAGS to DEFS

2004-05-26  Don Porter	<[email protected]>

	* library/tcltest/tcltest.tcl:	Correction to debug prints and testing
	* library/tcltest/pkgIndex.tcl:	if TCLTEST_OPTIONS value.  Corrected
	* tests/tcltest.test:		double increment of numTestFiles in
	-singleproc 1 configurations.  Updated tcltest-19.1 to tcltest 2.1
	behavior.  Corrected tcltest-25.3 to not falsely report a failure
	in tcltest.test.  Bumped to tcltest 2.2.6.  [Bugs 960560, 960926]

2004-05-25  Jeff Hobbs	<[email protected]>

	* doc/http.n (http::config): add -urlencoding option (default utf-8)
	* library/http/http.tcl:     that specifies encoding conversion of
	* library/http/pkgIndex.tcl: args for http::formatQuery.  Previously
	* tests/http.test:	     undefined, RFC 2718 says it should be
	utf-8. 'http::config -urlencoding {}' returns previous behavior,
	which will throw errors processing non-latin-1 chars.
	Bumped http package to 2.5.0.

2004-05-25  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (DeleteScriptLimitCallback): Move all
	deletion of script callback hash table entries to happen here so
	the entries are correctly removed at the right time.  [Bug 960410]

2004-05-25  Miguel Sofer <[email protected]>

	* docs/global.n: added details for qualified variable names
	[Bug 959831]

2004-05-25  Miguel Sofer <[email protected]>

	* generic/tclNamesp.c (Tcl_FindNamespaceVar):
	* tests/namespace.test (namespace-17.10-12): reverted commit of
	2004-05-23 and removed the tests, as it interferes with the
	varname resolver and there are apps that break (AlphaTk). A fix
	will have to wait for Tcl9.

	* generic/tclVar.c: Caching of namespace variables disabled: no
	simple way was found to avoid interfering with the resolver's idea
	of variable existence. A cached varName may keep a variable's name
	in the namespace's hash table, which is the resolver's criterion
	for existence.

	* tests/namespace.c (namespace-17.10): testing for interference
	between varname caching and name resolver.

2004-05-25  Kevin Kenny	 <[email protected]>

	* tests/winFCmd.test: Correct test for the presence of a CD-ROM so
			      that it doesn't misdetect some other sort
			      of filesystem with a write-protected root as
			      being a CD-ROM drive. [Bug 918267]

2004-05-25  Don Porter	<[email protected]>

	* tests/winPipe.test:	Protect against path being set
	* tests/unixInit.test:	Unset path when done.
	* tests/unload.test (unload-3.1): Verify [pkgb_sub] does not exist.
	Delete interps when done.
	* tests/stringComp.test:	stop re-use of string.test test names
	* tests/regexpComp.test:	stop re-use of regexp.test test names
	* tests/namespace.test (namespace-46.3): Verify [p] does not exist.
	* tests/http.test:	Clear away the custom [bgerror] when done.
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
	* generic/tcl.h:      comments. [Bug 848440, second part]

	* tests/fCmd.test: Rewrote tests that failed consistently on NFS
	so they either succeed (through slightly more liberal matching of
	the results) or are constrained to not run. [Bug 931312]

	* doc/bgerror.n: Use idiomatic open flags for working with log
	files.  [Bug 959602]

2004-05-24  Jeff Hobbs  <[email protected]>

	* generic/tclExecute.c (VerifyExprObjType): use GET_WIDE_OR_INT to
	properly have tclIntType used for smaller values.  This corrects
	TclX bug 896727 and any other 3rd party extension that created
	math functions but was not yet WIDE_INT aware in them.

2004-05-24  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (TclInitLimitSupport): Made limits work on
	platforms where sizeof(void*)!=sizeof(int). [Bug 959193]

2004-05-24 Miguel Sofer <[email protected]>

	* doc/set.n: accurate description of name resolution process,
	referring to namespace.n for details [Bug 959180]

2004-05-23  Miguel Sofer <[email protected]>

	* generic/tclNamesp.c (Tcl_FindNamespaceVar): [Bug 959052] fixed,
	insuring that no "zombie" variables are found.
	* generic/tclVar.c (TclLookupSimpleVar): comments re [Bug 736729] 
	(predecessor of [Bug 959052]) removed.
	* tests/namespace.test: added tests 17.10-12 

	The patch modifies non-documented behaviour, and passes every test
	in the testsuite. However, scripts relying on the old behaviour
	may break.
	Note that the only behaviour change concerns the creative writing
	of unset variables. More precisely, which variable will be created
	when neither a namespace variable nor a global variable by that
	name exists, as defined by [info vars]. The new behaviour is that
	the namespace resolution process deems a variable to exist exactly
	when [info vars] finds it - ie, either it has value, or else it
	was "fixed" by a call to [variable].
	Note: this patch was removed on 2002-05-25. 

2004-05-22  Miguel Sofer <[email protected]>

	* generic/tclVar.c (TclObjLookupVar, TclObjUnsetVar2): fix for new
	(in tcl8.4) exteriorisations of [Bug 736729] due to the use of
	tclNsVarNameType obj types. Reenabling the use of this objType
	("VAR ref absolute" benchmark down to 66 ms, from 230). 
	Added comments in TclLookupSimpleVar explaining my current
	understanding of [Bug 736729].

2004-05-22  Miguel Sofer <[email protected]>

	* generic/tclVar.c: fix for [Bug 735335]. The use of
	tclNsVarNameType objs is still disabled, pending resolution of
	[Bug 736729].

2004-05-21  Miguel Sofer <[email protected]>

	* tests/namespace.test (namespace-41.3): removed the {knownBug}
	constraint: [Bug 231259] is closed since nov 2001, and the fix of 
	[Bug 729692] (INST_START_CMD) makes the test succeed.

2004-05-21  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): Move a few
	declarations a short distance so pre-C99 compilers can cope.  Also
	fix so TCL_COMPILE_DEBUG path compiles...

2004-05-21  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): reorganised TEBC
	automatic variables, defining them in tight blocks instead of at
	the function level. This has three purposes:
	- it simplifies the analysis of individual instructions
	- it is preliminary work to the non-recursive engine
	- it allows a better register allocation by the optimiser; under
	gcc3.3, this results in up to 10% runtime in some tests

2004-05-20  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (TclLimitRemoveAllHandlers): 
	* generic/tclBasic.c (DeleteInterpProc): 
	* tests/interp.test (interp-34.7): 
	Ensure that all limit callbacks are deleted when their interpreters
	are deleted. [Bug 956083]

2004-05-19  Kevin B. Kenny  <[email protected]>

	* win/tclWinFile.c (TclpMatchInDirectory): fix for an issue
	where there was a sneak path from Tcl_DStringFree to







|

|




















|

|











|






|












|




















|
|
|







6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
	* generic/tcl.h:      comments. [Bug 848440, second part]

	* tests/fCmd.test: Rewrote tests that failed consistently on NFS
	so they either succeed (through slightly more liberal matching of
	the results) or are constrained to not run. [Bug 931312]

	* doc/bgerror.n: Use idiomatic open flags for working with log
	files.	[Bug 959602]

2004-05-24  Jeff Hobbs	<[email protected]>

	* generic/tclExecute.c (VerifyExprObjType): use GET_WIDE_OR_INT to
	properly have tclIntType used for smaller values.  This corrects
	TclX bug 896727 and any other 3rd party extension that created
	math functions but was not yet WIDE_INT aware in them.

2004-05-24  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (TclInitLimitSupport): Made limits work on
	platforms where sizeof(void*)!=sizeof(int). [Bug 959193]

2004-05-24 Miguel Sofer <[email protected]>

	* doc/set.n: accurate description of name resolution process,
	referring to namespace.n for details [Bug 959180]

2004-05-23  Miguel Sofer <[email protected]>

	* generic/tclNamesp.c (Tcl_FindNamespaceVar): [Bug 959052] fixed,
	insuring that no "zombie" variables are found.
	* generic/tclVar.c (TclLookupSimpleVar): comments re [Bug 736729]
	(predecessor of [Bug 959052]) removed.
	* tests/namespace.test: added tests 17.10-12

	The patch modifies non-documented behaviour, and passes every test
	in the testsuite. However, scripts relying on the old behaviour
	may break.
	Note that the only behaviour change concerns the creative writing
	of unset variables. More precisely, which variable will be created
	when neither a namespace variable nor a global variable by that
	name exists, as defined by [info vars]. The new behaviour is that
	the namespace resolution process deems a variable to exist exactly
	when [info vars] finds it - ie, either it has value, or else it
	was "fixed" by a call to [variable].
	Note: this patch was removed on 2002-05-25.

2004-05-22  Miguel Sofer <[email protected]>

	* generic/tclVar.c (TclObjLookupVar, TclObjUnsetVar2): fix for new
	(in tcl8.4) exteriorisations of [Bug 736729] due to the use of
	tclNsVarNameType obj types. Reenabling the use of this objType
	("VAR ref absolute" benchmark down to 66 ms, from 230).
	Added comments in TclLookupSimpleVar explaining my current
	understanding of [Bug 736729].

2004-05-22  Miguel Sofer <[email protected]>

	* generic/tclVar.c: fix for [Bug 735335]. The use of
	tclNsVarNameType objs is still disabled, pending resolution of
	[Bug 736729].

2004-05-21  Miguel Sofer <[email protected]>

	* tests/namespace.test (namespace-41.3): removed the {knownBug}
	constraint: [Bug 231259] is closed since nov 2001, and the fix of
	[Bug 729692] (INST_START_CMD) makes the test succeed.

2004-05-21  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): Move a few
	declarations a short distance so pre-C99 compilers can cope.  Also
	fix so TCL_COMPILE_DEBUG path compiles...

2004-05-21  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (TclExecuteByteCode): reorganised TEBC
	automatic variables, defining them in tight blocks instead of at
	the function level. This has three purposes:
	- it simplifies the analysis of individual instructions
	- it is preliminary work to the non-recursive engine
	- it allows a better register allocation by the optimiser; under
	gcc3.3, this results in up to 10% runtime in some tests

2004-05-20  Donal K. Fellows  <[email protected]>

	* generic/tclInterp.c (TclLimitRemoveAllHandlers):
	* generic/tclBasic.c (DeleteInterpProc):
	* tests/interp.test (interp-34.7):
	Ensure that all limit callbacks are deleted when their interpreters
	are deleted. [Bug 956083]

2004-05-19  Kevin B. Kenny  <[email protected]>

	* win/tclWinFile.c (TclpMatchInDirectory): fix for an issue
	where there was a sneak path from Tcl_DStringFree to
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
	* generic/tclInterp.c (Tcl_LimitCheck): Fix the sense of checks to
	see whether a time limit has been extended.

	* tests/*.test: Many minor fixes, including ensuring that every
	test is run (so constraints control whether the test is doing
	anything) and making sure that constraints are always set using
	the API instead of poking around inside tcltest's internal
	datastructures.  Also got rid of all trailing whitespace lines
	from the test suite!

2004-05-19  Andreas Kupries  <[email protected]>

	* generic/tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem
	* generic/tclIO.h: as [SF Tcl Bug 462317], see ChangeLog entry
	           2001-09-26. The fix done at that time is incomplete. It
	           is possible to get around it if the actual read
	           operation is defered and not executed in the event
	           handler itself. Instead of tracking if we are in an
	           read caused by a synthesized fileevent we now track if
	           the OS has delivered a true event = actual data and
	           bypass the driver if a read finds that there is no
	           actual data waiting. The flag is cleared by a short or
	           full read.

	  ***POTENTIAL INCOMPATIBILITY*** for channel drivers.

2004-05-17  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix to (Bug 956063) in 'file dirname'.
	* tests/cmdAH.test: added test for this bug.

	* doc/FileSystem.3: better documentation of refCount requirements 
	of some FS functions (Bug 956126)

2004-05-19  Donal K. Fellows  <[email protected]>

	* generic/tclTest.c (TestgetintCmd): Made the tests in get.test check
	* tests/get.test:		     Tcl_GetInt() since the core now
					     avoids that function.







|






|
|
|
|
|
|
|
|
|








|







6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
	* generic/tclInterp.c (Tcl_LimitCheck): Fix the sense of checks to
	see whether a time limit has been extended.

	* tests/*.test: Many minor fixes, including ensuring that every
	test is run (so constraints control whether the test is doing
	anything) and making sure that constraints are always set using
	the API instead of poking around inside tcltest's internal
	datastructures.	 Also got rid of all trailing whitespace lines
	from the test suite!

2004-05-19  Andreas Kupries  <[email protected]>

	* generic/tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem
	* generic/tclIO.h: as [SF Tcl Bug 462317], see ChangeLog entry
		   2001-09-26. The fix done at that time is incomplete. It
		   is possible to get around it if the actual read
		   operation is defered and not executed in the event
		   handler itself. Instead of tracking if we are in an
		   read caused by a synthesized fileevent we now track if
		   the OS has delivered a true event = actual data and
		   bypass the driver if a read finds that there is no
		   actual data waiting. The flag is cleared by a short or
		   full read.

	  ***POTENTIAL INCOMPATIBILITY*** for channel drivers.

2004-05-17  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix to (Bug 956063) in 'file dirname'.
	* tests/cmdAH.test: added test for this bug.

	* doc/FileSystem.3: better documentation of refCount requirements
	of some FS functions (Bug 956126)

2004-05-19  Donal K. Fellows  <[email protected]>

	* generic/tclTest.c (TestgetintCmd): Made the tests in get.test check
	* tests/get.test:		     Tcl_GetInt() since the core now
					     avoids that function.
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
	* generic/tclCompile.c:
	* generic/tclExecute.c: changed implementation of {expand}, last
	chance while in alpha as ...

	***POTENTIAL INCOMPATIBILITY***
	Scripts precompiled with ProComp under previous tcl8.5a versions
	may malfunction due to changed instruction numbers for
	INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM and INST_START_CMD. 

2004-05-14  Kevin B. Kenny  <[email protected]>

	* generic/tclInt.decls:      Promoted TclpLocaltime and TclpGmtime
	* generic/tclIntDecls.h:     from Unix-specific stubs to the generic
	* generic/tclIntPlatDecls.h: internal Stubs table.  Reran 'genstubs'
	* generic/tclStubInit.c:
	* unix/tclUnixPort.h:

	* generic/tclClock.c: Changed a buggy 'GMT' timezone specification
	                      to the correct 'GMT0'. [Bug #922848]

	* unix/tclUnixThrd.c: Moved TclpGmtime and TclpLocaltime to
	                      unix/tclUnixTime.c where they belong.

	* unix/tclUnixTime.c (TclpGmtime, TclpLocaltime, TclpGetTimeZone,
	                      ThreadSafeGMTime [removed],
	                      ThreadSafeLocalTime [removed],
	                      SetTZIfNecessary, CleanupMemory):
	    Restructured to make sure that the same mutex protects
	    all calls to localtime, gmtime, and tzset.  Added a check
	    in front of those calls to make sure that the TZ env var
	    hasn't changed since the last call to tzset, and repeat
	    tzset if necessary. [Bug #942078]  Removed a buggy test
	    of the Daylight Saving Time information in 'gettimeofday'
	    in favor of applying 'localtime' to a known value.
	    [Bug #922848]








|



|






|


|


|
|
|

|







6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
	* generic/tclCompile.c:
	* generic/tclExecute.c: changed implementation of {expand}, last
	chance while in alpha as ...

	***POTENTIAL INCOMPATIBILITY***
	Scripts precompiled with ProComp under previous tcl8.5a versions
	may malfunction due to changed instruction numbers for
	INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM and INST_START_CMD.

2004-05-14  Kevin B. Kenny  <[email protected]>

	* generic/tclInt.decls:	     Promoted TclpLocaltime and TclpGmtime
	* generic/tclIntDecls.h:     from Unix-specific stubs to the generic
	* generic/tclIntPlatDecls.h: internal Stubs table.  Reran 'genstubs'
	* generic/tclStubInit.c:
	* unix/tclUnixPort.h:

	* generic/tclClock.c: Changed a buggy 'GMT' timezone specification
			      to the correct 'GMT0'. [Bug #922848]

	* unix/tclUnixThrd.c: Moved TclpGmtime and TclpLocaltime to
			      unix/tclUnixTime.c where they belong.

	* unix/tclUnixTime.c (TclpGmtime, TclpLocaltime, TclpGetTimeZone,
			      ThreadSafeGMTime [removed],
			      ThreadSafeLocalTime [removed],
			      SetTZIfNecessary, CleanupMemory):
	    Restructured to make sure that the same mutex protects
	    all calls to localtime, gmtime, and tzset.	Added a check
	    in front of those calls to make sure that the TZ env var
	    hasn't changed since the last call to tzset, and repeat
	    tzset if necessary. [Bug #942078]  Removed a buggy test
	    of the Daylight Saving Time information in 'gettimeofday'
	    in favor of applying 'localtime' to a known value.
	    [Bug #922848]

3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
	(eePtr). First step towards a change in the execution stack
	management - it is now only used within TEBC.

2004-05-13  Donal K. Fellows  <[email protected]>

	TIP#143 IMPLEMENTATION

	* generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode): 
	* generic/tclBasic.c (TclEvalObjvInternal): Enable limit checking.
	* generic/tclInterp.c (Tcl_Limit*): Public limit API.
	* generic/tcl.decls: 
	* tests/interp.test: Basic tests of command limits.

	* doc/binary.n:		TIP#129 IMPLEMENTATION [Patch 858211]
	* generic/tclBinary.c:	Note that the test suite probably has many more
	* tests/binary.test:	failures now due to alterations in constraints.

2004-05-12  Miguel Sofer <[email protected]>







|


|







6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
	(eePtr). First step towards a change in the execution stack
	management - it is now only used within TEBC.

2004-05-13  Donal K. Fellows  <[email protected]>

	TIP#143 IMPLEMENTATION

	* generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode):
	* generic/tclBasic.c (TclEvalObjvInternal): Enable limit checking.
	* generic/tclInterp.c (Tcl_Limit*): Public limit API.
	* generic/tcl.decls:
	* tests/interp.test: Basic tests of command limits.

	* doc/binary.n:		TIP#129 IMPLEMENTATION [Patch 858211]
	* generic/tclBinary.c:	Note that the test suite probably has many more
	* tests/binary.test:	failures now due to alterations in constraints.

2004-05-12  Miguel Sofer <[email protected]>
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209

2004-05-11  Donal K. Fellows  <[email protected]>

	* doc/split.n, doc/join.n: Updated examples and added more.

2004-05-11  Vince Darley  <[email protected]>

	* doc/glob.n: documented behaviour of symbolic links with 
	'glob -types d' (Bug 951489)

2004-05-11  Donal K. Fellows  <[email protected]>

	* doc/scan.n: Updated the examples to be clearer about their
	relevance to the scan command.








|







6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452

2004-05-11  Donal K. Fellows  <[email protected]>

	* doc/split.n, doc/join.n: Updated examples and added more.

2004-05-11  Vince Darley  <[email protected]>

	* doc/glob.n: documented behaviour of symbolic links with
	'glob -types d' (Bug 951489)

2004-05-11  Donal K. Fellows  <[email protected]>

	* doc/scan.n: Updated the examples to be clearer about their
	relevance to the scan command.

3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313

	(TclpCreateProcess): When under NT, with no console, and executing a
	DOS application, the path priming does not need an ending space as
	BuildCommandLine() will do this for us.

2004-05-08  Vince Darley  <[email protected]>

	* generic/tclFileName.c: 
	* generic/tclIOUtil.c: remove some compiler warnings on MacOS X.

2004-05-07  Chengye Mao <[email protected]>

	* win/tclWinPipe.c: refixed bug 789040 re-entered in rev 1.41.
	Let's be careful and don't re-enter previously fixed bugs.

2004-05-08  Donal K. Fellows  <[email protected]>

	* doc/format.n: Added examples.

2004-05-07  Miguel Sofer <[email protected]>

	* doc/unset.n: added upvar.n to the "see also" list

2004-05-07  Reinhard Max  <[email protected]>

	* generic/tclEncoding.c: 
	* tests/encoding.test: added support and tests for translating
	embedded null characters between real nullbytes and the internal
	representation on input/output (Bug #949905).

2004-05-07  Vince Darley  <[email protected]>

	* generic/tclFileName.c: 
	* generic/tclIOUtil.c: 
	* generic/tclFileSystem.h:
	* tests/fileSystem.test: fix for [Bug 943995], in which vfs-
	registered root volumes were not handled correctly as glob
	patterns in all circumstances.

2004-05-06  Miguel Sofer <[email protected]>

	* generic/tclInt.h:
	* generic/tclObj.c (TclFreeObj): made TclFreeObj use the new macro
	TclFreeObjMacro(), so that the allocation and freeing of Tcl_Obj
	is defined in a single spot (the macros in tclInt.h), with the
	exception of the TCL_MEM_DEBUG case.
	The #ifdef logic for the corresponding macros has been reformulated
	to make it clearer.

2004-05-05  Donal K. Fellows  <[email protected]>

	* doc/break.n, doc/continue.n, doc/for.n, doc/while.n: More examples.

2004-05-05  Don Porter  <[email protected]>

	* tests/unixInit.test (unixInit-2.10):	Test correction for Mac OSX.
	Be sure to consistently compare normalized path names.  Thanks to
	Steven Abner (tauvan).  [Bug 948177]

2004-05-05  Donal K. Fellows  <[email protected]>

	* doc/CrtObjCmd.3: Remove reference to Tcl_RenameCommand; there is
	no such API. [Bug 848440]

2004-05-05  David Gravereaux <[email protected]>

	* win/tclWinSock.c (SocketEventProc) : connect errors should
	fire both the readable and writable handlers because this is
	how it works on UNIX [Bug 794839]

	* generic/tclEncoding.c (TclFinalizeEncodingSubsystem):
	FreeEncoding(systemEncoding); moved to before the hash table
	itereation as it was causing a double free attempt under some
	conditions.

	* win/coffbase.txt: Added the tls extension to the list of
	preferred load addresses.

2004-05-04  Jeff Hobbs  <[email protected]>

	* tests/fileSystem.test (filesystem-1.39): replace 'file volumes'
	* tests/fileName.test (filename-12.9,10):  lindex with direct C:/
	hard-coded because A:/ was being used and that is empty for most.

	* tests/winFCmd.test (winFCmd-16.12): test volumerelative $HOME

2004-05-04  Don Porter  <[email protected]>

	* generic/tclAlloc.c:		Make sure Tclp*Alloc* routines get
	* generic/tclInt.h:		declared in the TCL_MEM_DEBUG and
	* generic/tclThreadAlloc.c:	TCL_THREADS configuration. [Bug 947564]

	* tests/tcltest.test:	Test corrections for Mac OSX.  Thanks
	to Steven Abner (tauvan).  [Bug 947440]







|

















|






|
|



















|


|
|




















|







|







6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556

	(TclpCreateProcess): When under NT, with no console, and executing a
	DOS application, the path priming does not need an ending space as
	BuildCommandLine() will do this for us.

2004-05-08  Vince Darley  <[email protected]>

	* generic/tclFileName.c:
	* generic/tclIOUtil.c: remove some compiler warnings on MacOS X.

2004-05-07  Chengye Mao <[email protected]>

	* win/tclWinPipe.c: refixed bug 789040 re-entered in rev 1.41.
	Let's be careful and don't re-enter previously fixed bugs.

2004-05-08  Donal K. Fellows  <[email protected]>

	* doc/format.n: Added examples.

2004-05-07  Miguel Sofer <[email protected]>

	* doc/unset.n: added upvar.n to the "see also" list

2004-05-07  Reinhard Max  <[email protected]>

	* generic/tclEncoding.c:
	* tests/encoding.test: added support and tests for translating
	embedded null characters between real nullbytes and the internal
	representation on input/output (Bug #949905).

2004-05-07  Vince Darley  <[email protected]>

	* generic/tclFileName.c:
	* generic/tclIOUtil.c:
	* generic/tclFileSystem.h:
	* tests/fileSystem.test: fix for [Bug 943995], in which vfs-
	registered root volumes were not handled correctly as glob
	patterns in all circumstances.

2004-05-06  Miguel Sofer <[email protected]>

	* generic/tclInt.h:
	* generic/tclObj.c (TclFreeObj): made TclFreeObj use the new macro
	TclFreeObjMacro(), so that the allocation and freeing of Tcl_Obj
	is defined in a single spot (the macros in tclInt.h), with the
	exception of the TCL_MEM_DEBUG case.
	The #ifdef logic for the corresponding macros has been reformulated
	to make it clearer.

2004-05-05  Donal K. Fellows  <[email protected]>

	* doc/break.n, doc/continue.n, doc/for.n, doc/while.n: More examples.

2004-05-05  Don Porter	<[email protected]>

	* tests/unixInit.test (unixInit-2.10):	Test correction for Mac OSX.
	Be sure to consistently compare normalized path names.	Thanks to
	Steven Abner (tauvan).	[Bug 948177]

2004-05-05  Donal K. Fellows  <[email protected]>

	* doc/CrtObjCmd.3: Remove reference to Tcl_RenameCommand; there is
	no such API. [Bug 848440]

2004-05-05  David Gravereaux <[email protected]>

	* win/tclWinSock.c (SocketEventProc) : connect errors should
	fire both the readable and writable handlers because this is
	how it works on UNIX [Bug 794839]

	* generic/tclEncoding.c (TclFinalizeEncodingSubsystem):
	FreeEncoding(systemEncoding); moved to before the hash table
	itereation as it was causing a double free attempt under some
	conditions.

	* win/coffbase.txt: Added the tls extension to the list of
	preferred load addresses.

2004-05-04  Jeff Hobbs	<[email protected]>

	* tests/fileSystem.test (filesystem-1.39): replace 'file volumes'
	* tests/fileName.test (filename-12.9,10):  lindex with direct C:/
	hard-coded because A:/ was being used and that is empty for most.

	* tests/winFCmd.test (winFCmd-16.12): test volumerelative $HOME

2004-05-04  Don Porter	<[email protected]>

	* generic/tclAlloc.c:		Make sure Tclp*Alloc* routines get
	* generic/tclInt.h:		declared in the TCL_MEM_DEBUG and
	* generic/tclThreadAlloc.c:	TCL_THREADS configuration. [Bug 947564]

	* tests/tcltest.test:	Test corrections for Mac OSX.  Thanks
	to Steven Abner (tauvan).  [Bug 947440]
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
2004-05-03  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:
	* generic/tclInt.h: reverted fix for [Bug 926445] of 2004-04-02,
	restoring TCL_ALIGN to the header file. Todd Helfter reported that
	the macro is required by tbcload.

2004-05-03  Kevin Kenny  <[email protected]>

	* win/tclWin32Dll.c (TclpCheckStackSpace):
	* tests/stack.test (stack-3.1): Fix for undetected stack
	overflow in TclReExec on Windows. [Bug 947070]

2004-05-03  Don Porter  <[email protected]>

	* library/init.tcl:	Corrected unique prefix matching of
	interactive command completion in [unknown].  [Bug 946952]

2004-05-02  Miguel Sofer <[email protected]>

	* generic/tclProc.c (TclObjInvokeProc):
	* tests/proc.test (proc-3.6): fix for bad quoting of multi-word
	proc names in error messages [Bug 942757]

2004-04-30  Donal K. Fellows  <[email protected]>

	* doc/glob.n, doc/incr.n, doc/set.n:	More examples.
	* doc/if.n, doc/rename.n, doc/time.n:

2004-04-30  Don Porter  <[email protected]>

	* generic/tclInt.h:		Replaced Kevin Kenny's temporary
	* generic/tclThreadAlloc.c:	fix for Bug 945447 with a cleaner,
	more permanent replacement.  

2004-04-30  Kevin B. Kenny   <[email protected]>

	* generic/tclThreadAlloc.c: Added a temporary (or so I hope!)
	inclusion of "tclWinInt.h" to avoid problems when compiling
	on Win32-VC++ with --enable-threads.  [Bug 945447]

2004-04-30  Donal K. Fellows  <[email protected]>

	* doc/puts.n: Added a few examples.

2004-04-29  Don Porter  <[email protected]>

	* tests/execute.test (execute-8.2):	Avoid crashes when there
	is limited system stack space (threads-enabled).

2004-04-28  Miguel Sofer <[email protected]>

	* doc/global.n:
	* doc/upvar.n:
	* generic/tclVar.c (ObjMakeUpvar):
	* tests/upvar.test (upvar-8.11):
	* tests/var.test (var-3.11): Avoid creation of unusable variables:
	[Bug 600812] [TIP 184].

2004-04-28  Donal K. Fellows  <[email protected]>

	* doc/lsearch.n: Fixed fault in documentation of -index option [943448]

2004-04-26  Don Porter  <[email protected]>

	* unix/tclUnixFCmd.c (TclpObjNormalizePath):  Corrected improper
	positioning of returned checkpoint.  [Bug 941108]

2004-04-26  Donal K. Fellows  <[email protected]>

	* doc/open.n, doc/close.n: Updated (thanks to David Welton) to be
	clearer about pipeline errors and added example to open(n) that shows
	simple pipeline use.  [Patches 941377,941380]

	* doc/DictObj.3: Added warning about the use of Tcl_DictObjDone and an
	example of use of iteration. [Bug 940843]

	* doc/Thread.3: Reworked to remove references to testing interfaces
	and instead promote the use of the Thread package. [Patch 932527]
	Also reworked and reordered the page for better readability.

2004-04-25  Don Porter  <[email protected]>

	* generic/tcl.h:	Removed obsolete declarations and #include's.
	* generic/tclInt.h:	[Bugs 926459, 926486]

2004-04-24  David Gravereaux <[email protected]>

	* win/tclWin32Dll.c (DllMain): Added DisableThreadLibraryCalls()







|





|















|



|











|

















|

















|







6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
2004-05-03  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:
	* generic/tclInt.h: reverted fix for [Bug 926445] of 2004-04-02,
	restoring TCL_ALIGN to the header file. Todd Helfter reported that
	the macro is required by tbcload.

2004-05-03  Kevin Kenny	 <[email protected]>

	* win/tclWin32Dll.c (TclpCheckStackSpace):
	* tests/stack.test (stack-3.1): Fix for undetected stack
	overflow in TclReExec on Windows. [Bug 947070]

2004-05-03  Don Porter	<[email protected]>

	* library/init.tcl:	Corrected unique prefix matching of
	interactive command completion in [unknown].  [Bug 946952]

2004-05-02  Miguel Sofer <[email protected]>

	* generic/tclProc.c (TclObjInvokeProc):
	* tests/proc.test (proc-3.6): fix for bad quoting of multi-word
	proc names in error messages [Bug 942757]

2004-04-30  Donal K. Fellows  <[email protected]>

	* doc/glob.n, doc/incr.n, doc/set.n:	More examples.
	* doc/if.n, doc/rename.n, doc/time.n:

2004-04-30  Don Porter	<[email protected]>

	* generic/tclInt.h:		Replaced Kevin Kenny's temporary
	* generic/tclThreadAlloc.c:	fix for Bug 945447 with a cleaner,
	more permanent replacement.

2004-04-30  Kevin B. Kenny   <[email protected]>

	* generic/tclThreadAlloc.c: Added a temporary (or so I hope!)
	inclusion of "tclWinInt.h" to avoid problems when compiling
	on Win32-VC++ with --enable-threads.  [Bug 945447]

2004-04-30  Donal K. Fellows  <[email protected]>

	* doc/puts.n: Added a few examples.

2004-04-29  Don Porter	<[email protected]>

	* tests/execute.test (execute-8.2):	Avoid crashes when there
	is limited system stack space (threads-enabled).

2004-04-28  Miguel Sofer <[email protected]>

	* doc/global.n:
	* doc/upvar.n:
	* generic/tclVar.c (ObjMakeUpvar):
	* tests/upvar.test (upvar-8.11):
	* tests/var.test (var-3.11): Avoid creation of unusable variables:
	[Bug 600812] [TIP 184].

2004-04-28  Donal K. Fellows  <[email protected]>

	* doc/lsearch.n: Fixed fault in documentation of -index option [943448]

2004-04-26  Don Porter	<[email protected]>

	* unix/tclUnixFCmd.c (TclpObjNormalizePath):  Corrected improper
	positioning of returned checkpoint.  [Bug 941108]

2004-04-26  Donal K. Fellows  <[email protected]>

	* doc/open.n, doc/close.n: Updated (thanks to David Welton) to be
	clearer about pipeline errors and added example to open(n) that shows
	simple pipeline use.  [Patches 941377,941380]

	* doc/DictObj.3: Added warning about the use of Tcl_DictObjDone and an
	example of use of iteration. [Bug 940843]

	* doc/Thread.3: Reworked to remove references to testing interfaces
	and instead promote the use of the Thread package. [Patch 932527]
	Also reworked and reordered the page for better readability.

2004-04-25  Don Porter	<[email protected]>

	* generic/tcl.h:	Removed obsolete declarations and #include's.
	* generic/tclInt.h:	[Bugs 926459, 926486]

2004-04-24  David Gravereaux <[email protected]>

	* win/tclWin32Dll.c (DllMain): Added DisableThreadLibraryCalls()
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
	* doc/gets.n: Added example based on [Patch 935911].

2004-04-15  Donal K. Fellows  <[email protected]>

	* generic/tclClock.c (Tcl_ClockObjCmd): Minor fault in a [clock
	clicks] error message.

2004-04-07  Jeff Hobbs  <[email protected]>

	* win/tclWinInit.c (TclpSetInitialEncodings): note that WIN32_CE
	is also a unicode platform.
	* generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable): 
	* generic/tclInt.h:                         Correct handling of UTF
	* unix/tclUnixInit.c (TclpInitLibraryPath): data that is actually
	* win/tclWinFile.c (TclpFindExecutable):    "clean", allowing the
	* win/tclWinInit.c (TclpInitLibraryPath):   loading of Tcl from
	paths that contain multi-byte chars on Windows [Bug 920667]

	* win/configure:    define TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC,
	* win/configure.in: TCL_LIB_SPEC, TCL_PACKAGE_PATH in tclConfig.sh.

2004-04-06  Don Porter  <[email protected]>

	Patch 922727 committed.  Implements three changes:

	* generic/tclInt.h:	Reworked the Tcl header files into a clean
	* unix/tclUnixPort.h:	hierarchy where tcl.h < tclPort.h < tclInt.h 
	* win/tclWinInt.h:	and every C source file should #include
	* win/tclWinPort.h:	at most one of those files to satisfy its
	declaration needs.  tclWinInt.h and tclWinPort.h also better organized
	so that tclWinPort.h includes the Windows implementation of
	cross-platform declarations, while tclWinInt.h makes declarations that
	are available on Windows only.








|



|
|








|

|


|







6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
	* doc/gets.n: Added example based on [Patch 935911].

2004-04-15  Donal K. Fellows  <[email protected]>

	* generic/tclClock.c (Tcl_ClockObjCmd): Minor fault in a [clock
	clicks] error message.

2004-04-07  Jeff Hobbs	<[email protected]>

	* win/tclWinInit.c (TclpSetInitialEncodings): note that WIN32_CE
	is also a unicode platform.
	* generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable):
	* generic/tclInt.h:			    Correct handling of UTF
	* unix/tclUnixInit.c (TclpInitLibraryPath): data that is actually
	* win/tclWinFile.c (TclpFindExecutable):    "clean", allowing the
	* win/tclWinInit.c (TclpInitLibraryPath):   loading of Tcl from
	paths that contain multi-byte chars on Windows [Bug 920667]

	* win/configure:    define TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC,
	* win/configure.in: TCL_LIB_SPEC, TCL_PACKAGE_PATH in tclConfig.sh.

2004-04-06  Don Porter	<[email protected]>

	Patch 922727 committed.	 Implements three changes:

	* generic/tclInt.h:	Reworked the Tcl header files into a clean
	* unix/tclUnixPort.h:	hierarchy where tcl.h < tclPort.h < tclInt.h
	* win/tclWinInt.h:	and every C source file should #include
	* win/tclWinPort.h:	at most one of those files to satisfy its
	declaration needs.  tclWinInt.h and tclWinPort.h also better organized
	so that tclWinPort.h includes the Windows implementation of
	cross-platform declarations, while tclWinInt.h makes declarations that
	are available on Windows only.

3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
	* tests/unixInit.test (unixInit-3.1):	Default encoding on Darwin
	systems is utf-8.  Thanks to Steven Abner (tauvan).  [Bug 928808]

2004-04-06  Donal K. Fellows  <[email protected]>

	* tests/cmdAH.test (cmdAH-18.2): Added constraint because
	access(...,X_OK) is defined to be permitted to be meaningless when
	running as root, and OSX exhibits this.  [Bug 929892]

2004-04-02  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:
	* generic/tclInt.h: removed the macro TCL_ALIGN() from tclInt.h,
	replaced by the static macro ALIGN() in tclCompile.c [Bug 926445]

2004-04-02  Miguel Sofer <[email protected]>

	* generic/tclCompile.h: removed redundant #ifdef _TCLINT 
	[Bug 928415], reported by tauvan.

2004-04-02  Don Porter  <[email protected]>

	* tests/tcltest.test: Corrected constraint typos: "nonRoot" ->
	"notRoot".  Thanks to Steven Abner (tauvan).  [Bug 928353]

2004-04-01  Don Porter  <[email protected]>

	* generic/tclInt.h:  Removed obsolete tclBlockTime* declarations.
	[Bug 926454]

2004-04-01  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c:	 Fix to privately reported vfs bug with
	'glob -type d -dir . *' across a vfs boundary.	No tests for
	this are currently possible without effectively moving tclvfs
	into Tcl's test suite.

2004-03-31  Don Porter  <[email protected]>

	* doc/msgcat.n:	Clarified message catalog file encodings. [Bug 811457]
	* library/msgcat/msgcat.tcl:
	Updated internals to make use of [dict]s to store message catalog
	data and to use [source -encoding utf-8] to access catalog files.
	Thanks to Michael Sclenker.  [Patch 875055, RFE 811459]
	Corrected [mcset] to be able to successfully set a translation to
	the empty string.  [mcset $loc $src {}] was incorrectly set the
	$loc translation of $src back to $src.	Also changed [ConvertLocale]
	to minimally require a non-empty "language" part in the locale value.
	If not, an error raised prompts [Init] to keep looking for a valid
	locale value, or ultimately fall back on the "C" locale. [Bug 811461].
	* library/msgcat/pkgIndex.tcl:	Bump to msgcat 1.4.1.  

2004-03-30  Donal K. Fellows  <[email protected]>

	* generic/tclHash.c (HashStringKey): Cleaned up. This function is
	not faster, but it is a little bit clearer.
	* generic/tclLiteral.c (HashString): Applied logic from HashObjKey.
	* generic/tclObj.c (HashObjKey): Rewrote to fix fault which hashed
	every single-character object to the same hash bucket.  The new
	code is shorter, simpler, clearer, and (happily) faster.

2004-03-30  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (TEBC): reverting to the previous method
	for async tests in TEBC, as the new method turned out to be too
	costly. Async tests now run every 64 instructions.

2004-03-30  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:     New instruction code INST_START_CMD
	* generic/tclCompile.h:     that allows checking the bytecode's
	* generic/tclExecute.c:     validity [Bug 729692] and the interp's
	* tests/interp.test (18.9): readyness [Bug 495830] before running
	* tests/proc.test (7.1):    the command. It also changes the
	* tests/rename.test (6.1):  mechanics of the async tests in TEBC,
	doing it now at command start instead of every 16 instructions.

2004-03-30  Vince Darley  <[email protected]>

	* generic/tclFileName.c:  Fix to Windows glob where the pattern is
	* generic/tclIOUtil.c:	  a volume relative path or a network
	* tests/fileName.test:	  share [Bug 898238]. On windows 'glob'
	* tests/fileSystem.test:  will now return the results of 
	'glob /foo/bar' and 'glob \\foo\\bar' as 'C:/foo/bar', i.e. a 
	correct absolute path (rather than a volume relative path).

	Note that the test suite does not test commands like 
	'glob //Machine/Shared/*' (on a network share).	 

2004-03-30  Vince Darley  <[email protected]>

	* generic/tclPathObj.c:	  Fix to filename bugs recently
	* tests/fileName.test:	  introduced [Bug 918320].

2004-03-29  Don Porter  <[email protected]>

	* generic/tclMain.c (Tcl_Main, StdinProc):	Append newline only
	* tests/basic.test (basic-46.1):		to incomplete scripts
	as part of multi-line script construction.  Do not add an extra
	trailing newline to the complete script.  [Bug 833150]

2004-03-28  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclCompileScript): corrected possible
	segfault when a compilation returns TCL_OUTLINE_COMPILE after
	having grown the compile environment [Bug 925121].

2004-03-27  Miguel Sofer <[email protected]>

	* doc/array.n: added documentation for trace-realted behaviour of
	'array get' [Bug 449893]

2004-03-26  Don Porter  <[email protected]>

	* README:		Bumped version number to 8.5a2 to
	* tools/tcl.wse.in:	distinguish HEAD of CVS development
	* unix/configure.in:	from the recent 8.5a1 release.
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure.in:







|









|


|




|











|












|







|










|
|
|










|
|


|
|






|

















|







6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
6906
6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
	* tests/unixInit.test (unixInit-3.1):	Default encoding on Darwin
	systems is utf-8.  Thanks to Steven Abner (tauvan).  [Bug 928808]

2004-04-06  Donal K. Fellows  <[email protected]>

	* tests/cmdAH.test (cmdAH-18.2): Added constraint because
	access(...,X_OK) is defined to be permitted to be meaningless when
	running as root, and OSX exhibits this.	 [Bug 929892]

2004-04-02  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:
	* generic/tclInt.h: removed the macro TCL_ALIGN() from tclInt.h,
	replaced by the static macro ALIGN() in tclCompile.c [Bug 926445]

2004-04-02  Miguel Sofer <[email protected]>

	* generic/tclCompile.h: removed redundant #ifdef _TCLINT
	[Bug 928415], reported by tauvan.

2004-04-02  Don Porter	<[email protected]>

	* tests/tcltest.test: Corrected constraint typos: "nonRoot" ->
	"notRoot".  Thanks to Steven Abner (tauvan).  [Bug 928353]

2004-04-01  Don Porter	<[email protected]>

	* generic/tclInt.h:  Removed obsolete tclBlockTime* declarations.
	[Bug 926454]

2004-04-01  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c:	 Fix to privately reported vfs bug with
	'glob -type d -dir . *' across a vfs boundary.	No tests for
	this are currently possible without effectively moving tclvfs
	into Tcl's test suite.

2004-03-31  Don Porter	<[email protected]>

	* doc/msgcat.n:	Clarified message catalog file encodings. [Bug 811457]
	* library/msgcat/msgcat.tcl:
	Updated internals to make use of [dict]s to store message catalog
	data and to use [source -encoding utf-8] to access catalog files.
	Thanks to Michael Sclenker.  [Patch 875055, RFE 811459]
	Corrected [mcset] to be able to successfully set a translation to
	the empty string.  [mcset $loc $src {}] was incorrectly set the
	$loc translation of $src back to $src.	Also changed [ConvertLocale]
	to minimally require a non-empty "language" part in the locale value.
	If not, an error raised prompts [Init] to keep looking for a valid
	locale value, or ultimately fall back on the "C" locale. [Bug 811461].
	* library/msgcat/pkgIndex.tcl:	Bump to msgcat 1.4.1.

2004-03-30  Donal K. Fellows  <[email protected]>

	* generic/tclHash.c (HashStringKey): Cleaned up. This function is
	not faster, but it is a little bit clearer.
	* generic/tclLiteral.c (HashString): Applied logic from HashObjKey.
	* generic/tclObj.c (HashObjKey): Rewrote to fix fault which hashed
	every single-character object to the same hash bucket.	The new
	code is shorter, simpler, clearer, and (happily) faster.

2004-03-30  Miguel Sofer <[email protected]>

	* generic/tclExecute.c (TEBC): reverting to the previous method
	for async tests in TEBC, as the new method turned out to be too
	costly. Async tests now run every 64 instructions.

2004-03-30  Miguel Sofer <[email protected]>

	* generic/tclCompile.c:	    New instruction code INST_START_CMD
	* generic/tclCompile.h:	    that allows checking the bytecode's
	* generic/tclExecute.c:	    validity [Bug 729692] and the interp's
	* tests/interp.test (18.9): readyness [Bug 495830] before running
	* tests/proc.test (7.1):    the command. It also changes the
	* tests/rename.test (6.1):  mechanics of the async tests in TEBC,
	doing it now at command start instead of every 16 instructions.

2004-03-30  Vince Darley  <[email protected]>

	* generic/tclFileName.c:  Fix to Windows glob where the pattern is
	* generic/tclIOUtil.c:	  a volume relative path or a network
	* tests/fileName.test:	  share [Bug 898238]. On windows 'glob'
	* tests/fileSystem.test:  will now return the results of
	'glob /foo/bar' and 'glob \\foo\\bar' as 'C:/foo/bar', i.e. a
	correct absolute path (rather than a volume relative path).

	Note that the test suite does not test commands like
	'glob //Machine/Shared/*' (on a network share).

2004-03-30  Vince Darley  <[email protected]>

	* generic/tclPathObj.c:	  Fix to filename bugs recently
	* tests/fileName.test:	  introduced [Bug 918320].

2004-03-29  Don Porter	<[email protected]>

	* generic/tclMain.c (Tcl_Main, StdinProc):	Append newline only
	* tests/basic.test (basic-46.1):		to incomplete scripts
	as part of multi-line script construction.  Do not add an extra
	trailing newline to the complete script.  [Bug 833150]

2004-03-28  Miguel Sofer <[email protected]>

	* generic/tclCompile.c (TclCompileScript): corrected possible
	segfault when a compilation returns TCL_OUTLINE_COMPILE after
	having grown the compile environment [Bug 925121].

2004-03-27  Miguel Sofer <[email protected]>

	* doc/array.n: added documentation for trace-realted behaviour of
	'array get' [Bug 449893]

2004-03-26  Don Porter	<[email protected]>

	* README:		Bumped version number to 8.5a2 to
	* tools/tcl.wse.in:	distinguish HEAD of CVS development
	* unix/configure.in:	from the recent 8.5a1 release.
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure.in:
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
	* compat/strtoll.c:
	* compat/strtoull.c:
	* generic/tclIntDecls.h:
	* generic/tclMain.c:
	* generic/tclObj.c:
	* win/tclWinDde.c:
	* win/tclWinReg.c:
	* win/tclWinTime.c:        Made HEAD build on Windows VC++ again.

2004-03-19  Donal K. Fellows  <[email protected]>

	* generic/tclIntDecls.h: Made HEAD build on Solaris again by
	applying fix recommended by Don Porter.

2004-03-18  Reinhard Max  <[email protected]>

	* generic/tclIntDecls.h: Removed TclpTime_t. It wasn't really needed,
	* generic/tclInt.h:      but caused warnings related to
	* generic/tclInt.decls:  strict aliasing with GCC 3.3.
	* generic/tclClock.c:
	* generic/tclDate.c:
	* generic/tclGetDate.y: 
	* win/tclWinTime.c: 
	* unix/tclUnixTime.c: 

	* generic/tclNamesp.c:   Added temporary pointer variables to work
	* generic/tclStubLib.c:  around warnings related to
	* unix/tclUnixChan.c:    strict aliasing with GCC 3.3.

	* unix/tcl.m4:           Removed -Wno-strict-aliasing.

2004-03-18  Daniel Steffen  <[email protected]>

	Removed support for Mac OS Classic platform [Patch 918142]

	* README:
	* compat/string.h:







|









|
|


|
|
|

|
|
|

|







6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
	* compat/strtoll.c:
	* compat/strtoull.c:
	* generic/tclIntDecls.h:
	* generic/tclMain.c:
	* generic/tclObj.c:
	* win/tclWinDde.c:
	* win/tclWinReg.c:
	* win/tclWinTime.c:	   Made HEAD build on Windows VC++ again.

2004-03-19  Donal K. Fellows  <[email protected]>

	* generic/tclIntDecls.h: Made HEAD build on Solaris again by
	applying fix recommended by Don Porter.

2004-03-18  Reinhard Max  <[email protected]>

	* generic/tclIntDecls.h: Removed TclpTime_t. It wasn't really needed,
	* generic/tclInt.h:	 but caused warnings related to
	* generic/tclInt.decls:	 strict aliasing with GCC 3.3.
	* generic/tclClock.c:
	* generic/tclDate.c:
	* generic/tclGetDate.y:
	* win/tclWinTime.c:
	* unix/tclUnixTime.c:

	* generic/tclNamesp.c:	 Added temporary pointer variables to work
	* generic/tclStubLib.c:	 around warnings related to
	* unix/tclUnixChan.c:	 strict aliasing with GCC 3.3.

	* unix/tcl.m4:		 Removed -Wno-strict-aliasing.

2004-03-18  Daniel Steffen  <[email protected]>

	Removed support for Mac OS Classic platform [Patch 918142]

	* README:
	* compat/string.h:
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919

2004-03-17  Donal K. Fellows  <[email protected]>

	* doc/lsearch.n: Improved examples on the advanced capabilities of
	lsearch (with the right options, set element removal can be done)
	following discussion on tkchat.

2004-03-16  Don Porter  <[email protected]>

	* doc/catch.n:	Compiled [catch] no longer fails to catch syntax
	errors.  Removed the claims in the documentation that it does.
	* doc/return.n:	Updated example to use [dict merge].

2004-03-16  Jeff Hobbs  <[email protected]>

	* unix/configure, unix/tcl.m4: add -Wno-strict-aliasing for GCC to
	suppress useless type puning warnings.

2004-03-16  Donal K. Fellows  <[email protected]>

	* doc/file.n: *roff formatting fix. [Bug 917171]







|


|


|







7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162

2004-03-17  Donal K. Fellows  <[email protected]>

	* doc/lsearch.n: Improved examples on the advanced capabilities of
	lsearch (with the right options, set element removal can be done)
	following discussion on tkchat.

2004-03-16  Don Porter	<[email protected]>

	* doc/catch.n:	Compiled [catch] no longer fails to catch syntax
	errors.	 Removed the claims in the documentation that it does.
	* doc/return.n:	Updated example to use [dict merge].

2004-03-16  Jeff Hobbs	<[email protected]>

	* unix/configure, unix/tcl.m4: add -Wno-strict-aliasing for GCC to
	suppress useless type puning warnings.

2004-03-16  Donal K. Fellows  <[email protected]>

	* doc/file.n: *roff formatting fix. [Bug 917171]
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
	IMPLEMENTATION OF TIP#163
	* generic/tclDictObj.c (DictMergeCmd):	This is based on work by Joe
	* tests/dict.test (dict-20.*):		English in Tcl [FRQ 745851]
	* doc/dict.n:				but not exactly.

2004-03-10  Kevin B. Kenny <[email protected]>

	* generic/tclGetDate.y (TclGetDate): Fix so that 
	[clock scan <timeOfDay> -gmt true] uses the GMT base date
	instead of the local one. [Bug 913513]
	* tests/clock.test: Added test cases for wrong ISO8601 week number
	[Bug 500285] and wrong GMT base date [Bug 913513].  Several tests
	still fail on Windows, and these are actual faults in [clock scan].
	Fix is still pending.
	* generic/tclDate.c: Regenerated.

2004-03-08  Vince Darley  <[email protected]>

	* generic/tclFileName.c:  Fix to 'glob -path' near the root
	* tests/fileName.test:    of the filesystem. [Bug 910525]

2004-03-08  Don Porter  <[email protected]>

	* generic/tclParse.c (TclParseInit):	Modified TclParseInit so
	* generic/tclTest.c ([testexprparser]): that Tcl_Parse initialization
	conforms to documented promised about what fields will not be
	modified by what Tcl_Parse* routines. [Bug 910595]

2004-03-05  Mo DeJong  <[email protected]>







|











|

|







7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
	IMPLEMENTATION OF TIP#163
	* generic/tclDictObj.c (DictMergeCmd):	This is based on work by Joe
	* tests/dict.test (dict-20.*):		English in Tcl [FRQ 745851]
	* doc/dict.n:				but not exactly.

2004-03-10  Kevin B. Kenny <[email protected]>

	* generic/tclGetDate.y (TclGetDate): Fix so that
	[clock scan <timeOfDay> -gmt true] uses the GMT base date
	instead of the local one. [Bug 913513]
	* tests/clock.test: Added test cases for wrong ISO8601 week number
	[Bug 500285] and wrong GMT base date [Bug 913513].  Several tests
	still fail on Windows, and these are actual faults in [clock scan].
	Fix is still pending.
	* generic/tclDate.c: Regenerated.

2004-03-08  Vince Darley  <[email protected]>

	* generic/tclFileName.c:  Fix to 'glob -path' near the root
	* tests/fileName.test:	  of the filesystem. [Bug 910525]

2004-03-08  Don Porter	<[email protected]>

	* generic/tclParse.c (TclParseInit):	Modified TclParseInit so
	* generic/tclTest.c ([testexprparser]): that Tcl_Parse initialization
	conforms to documented promised about what fields will not be
	modified by what Tcl_Parse* routines. [Bug 910595]

2004-03-05  Mo DeJong  <[email protected]>
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
2004-03-05  Kevin B. Kenny <[email protected]>

	* tests/registry.test: Applied fix from Patch #910174 to
	make the test for an English-language system include any
	country code, rather than just English-United States.1252.
	Thanks to Pat Thoyts for the changes.

2004-03-04  Pat Thoyts  <[email protected]>

	* tests/registry.test: Applied fixed from #766159 to skip two
	tests on Win98 that depend on a Unicode registry (NT specific).

2004-03-04  Don Porter  <[email protected]>

	* generic/tclInt.h (TclParseInit):	Factored the common code
	* generic/tclParse.c (TclParseInit):	for initializing a Tcl_Parse
	* generic/tclParseExpr.c:		struct into one routine.

2004-03-04  Pat Thoyts  <[email protected]>

	* library/reg/pkgIndex.tcl:  Added TIP #100 support to the
	* win/tclWinReg.c:           registry package (patch #903831)
	This provides a Windows test of the TIP #100 mechanism and 
	a sample to show how unloading an extension can be done.

2004-03-04  Donal K. Fellows  <[email protected]>

	* unix/dltest/pkgua.c: Fix minor syntax problems. [Bug 909288]

2004-03-03  Jeff Hobbs  <[email protected]>

	*** 8.5a1 TAGGED FOR RELEASE ***

	* changes: updated for 8.5a1

2004-03-03  David Gravereaux <[email protected]>

	* win/makefile.vc: default environment variable for VC++ is
	%MSDevDir% not %MSVCDir%, although vcvars32.bat sets both.

	* win/tclWinNotify.c (Tcl_WaitForEvent) : Allows an idling
	notifier to service "Asynchronous Procedure Calls" from its wait
	state.  Only useful for extension authors who decide they might
	want to try "completion routines" with WriteFileEx(), as an
	example.  From experience, I recommend that "completion	ports"
	should be used instead as the execution of the callbacks are more
	managable.

2004-03-01  Jeff Hobbs  <[email protected]>

	* README:           update patchlevel to 8.5a1
	* generic/tcl.h:
	* tools/tcl.wse.in, tools/tclSplash.bmp:
	* unix/configure, unix/configure.in, unix/tcl.spec:
	* win/README.binary, win/configure, win/configure.in:

	* unix/tcl.m4: update HP-11 build libs setup

2004-03-01  Don Porter  <[email protected]>

	* unix/tcl.m4 (SC_CONFIG_CFLAGS):	Allow 64-bit enabling on
	IRIX64-6.5* systems.  [Bug 218561]
	* unix/configure:	autoconf-2.57

	* generic/tclTrace.c (TclCheckInterpTraces):	The TIP 62
	* generic/tclTest.c (TestcmdtraceCmd):	implementation introduced a







|




|





|


|
|






|












|





|

|







|







7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
2004-03-05  Kevin B. Kenny <[email protected]>

	* tests/registry.test: Applied fix from Patch #910174 to
	make the test for an English-language system include any
	country code, rather than just English-United States.1252.
	Thanks to Pat Thoyts for the changes.

2004-03-04  Pat Thoyts	<[email protected]>

	* tests/registry.test: Applied fixed from #766159 to skip two
	tests on Win98 that depend on a Unicode registry (NT specific).

2004-03-04  Don Porter	<[email protected]>

	* generic/tclInt.h (TclParseInit):	Factored the common code
	* generic/tclParse.c (TclParseInit):	for initializing a Tcl_Parse
	* generic/tclParseExpr.c:		struct into one routine.

2004-03-04  Pat Thoyts	<[email protected]>

	* library/reg/pkgIndex.tcl:  Added TIP #100 support to the
	* win/tclWinReg.c:	     registry package (patch #903831)
	This provides a Windows test of the TIP #100 mechanism and
	a sample to show how unloading an extension can be done.

2004-03-04  Donal K. Fellows  <[email protected]>

	* unix/dltest/pkgua.c: Fix minor syntax problems. [Bug 909288]

2004-03-03  Jeff Hobbs	<[email protected]>

	*** 8.5a1 TAGGED FOR RELEASE ***

	* changes: updated for 8.5a1

2004-03-03  David Gravereaux <[email protected]>

	* win/makefile.vc: default environment variable for VC++ is
	%MSDevDir% not %MSVCDir%, although vcvars32.bat sets both.

	* win/tclWinNotify.c (Tcl_WaitForEvent) : Allows an idling
	notifier to service "Asynchronous Procedure Calls" from its wait
	state.	Only useful for extension authors who decide they might
	want to try "completion routines" with WriteFileEx(), as an
	example.  From experience, I recommend that "completion	ports"
	should be used instead as the execution of the callbacks are more
	managable.

2004-03-01  Jeff Hobbs	<[email protected]>

	* README:	    update patchlevel to 8.5a1
	* generic/tcl.h:
	* tools/tcl.wse.in, tools/tclSplash.bmp:
	* unix/configure, unix/configure.in, unix/tcl.spec:
	* win/README.binary, win/configure, win/configure.in:

	* unix/tcl.m4: update HP-11 build libs setup

2004-03-01  Don Porter	<[email protected]>

	* unix/tcl.m4 (SC_CONFIG_CFLAGS):	Allow 64-bit enabling on
	IRIX64-6.5* systems.  [Bug 218561]
	* unix/configure:	autoconf-2.57

	* generic/tclTrace.c (TclCheckInterpTraces):	The TIP 62
	* generic/tclTest.c (TestcmdtraceCmd):	implementation introduced a
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086

	* generic/tclLoad.c (Tcl_LoadObjCmd): Missing dereference caused
	segfault with non-loadable extension. [Bug 904307]

	* unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with
	very long hostnames.  [Bug 888777]

2004-02-25  Pat Thoyts  <[email protected]>

	* win/tclWinDde.c: Removed some gcc warnings - except for the 
	-Wconversion warning for GetGlobalAtomName. gcc is just wrong
	about this.

2004-02-24  Donal K. Fellows  <[email protected]>

	IMPLEMENTATION OF TIP#100 FROM GEORGIOS PETASIS
	* generic/tclLoad.c (Tcl_UnloadObjCmd): Implementation.







|

|







7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329

	* generic/tclLoad.c (Tcl_LoadObjCmd): Missing dereference caused
	segfault with non-loadable extension. [Bug 904307]

	* unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with
	very long hostnames.  [Bug 888777]

2004-02-25  Pat Thoyts	<[email protected]>

	* win/tclWinDde.c: Removed some gcc warnings - except for the
	-Wconversion warning for GetGlobalAtomName. gcc is just wrong
	about this.

2004-02-24  Donal K. Fellows  <[email protected]>

	IMPLEMENTATION OF TIP#100 FROM GEORGIOS PETASIS
	* generic/tclLoad.c (Tcl_UnloadObjCmd): Implementation.
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
2004-02-17  Don Porter	<[email protected]>

	* doc/tcltest.n:
	* library/tcltest/tcltest.tcl:	Changed -verbose default value to
	{body error} so that detailed information on unexpected errors in
	tests is provided by default, even after the fix for [Bug 725253]

2004-02-17  Jeff Hobbs  <[email protected]>

	* tests/unixInit.test (unixInit-7.1):
	* unix/tclUnixInit.c (TclpInitPlatform): ensure the std fds exist
	to prevent crash condition [Bug #772288]

2004-02-17  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Bozo mistake in
	memory releasing order when in an error case.  [Bug 898910]

2004-02-16  Jeff Hobbs  <[email protected]>

	* generic/tclTrace.c (TclTraceExecutionObjCmd) 
	(TclTraceCommandObjCmd): fix possible mem leak in trace info.

2004-02-12  Mo DeJong  <[email protected]>

	* win/tclWinInit.c (AppendEnvironment):
	Use the tail component of the passed in
	lib path instead of just blindly using
	lib+4. That worked when lib was "lib/..."
	but fails for other values. Thanks go to
	Patrick Samson for pointing this out.

2004-02-10  David Gravereaux  <[email protected]>

	* win/nmakehlp.c: better macro grepping logic.

2004-02-07  David Gravereaux  <[email protected]>

	* win/makefile.vc:
	* win/rules.vc:
	* win/tcl.rc:
	* win/tclsh.rc:  Added an 'unchecked' option to the OPTS macro so a
	core built with symbols can be linked to the non-debug enabled C
	run-time.  As per discussion with Kevin Kenny.  Called like this:

		nmake -af makefile.vc OPTS=unchecked,symbols

	This clarifies the meaning of the 'g' naming suffix to mean only that
	the binary requires the debug enabled C run-time.  Whether the binary
	contains symbols or not is a different condition.








|










|

|




















|

|







7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
2004-02-17  Don Porter	<[email protected]>

	* doc/tcltest.n:
	* library/tcltest/tcltest.tcl:	Changed -verbose default value to
	{body error} so that detailed information on unexpected errors in
	tests is provided by default, even after the fix for [Bug 725253]

2004-02-17  Jeff Hobbs	<[email protected]>

	* tests/unixInit.test (unixInit-7.1):
	* unix/tclUnixInit.c (TclpInitPlatform): ensure the std fds exist
	to prevent crash condition [Bug #772288]

2004-02-17  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileSwitchCmd): Bozo mistake in
	memory releasing order when in an error case.  [Bug 898910]

2004-02-16  Jeff Hobbs	<[email protected]>

	* generic/tclTrace.c (TclTraceExecutionObjCmd)
	(TclTraceCommandObjCmd): fix possible mem leak in trace info.

2004-02-12  Mo DeJong  <[email protected]>

	* win/tclWinInit.c (AppendEnvironment):
	Use the tail component of the passed in
	lib path instead of just blindly using
	lib+4. That worked when lib was "lib/..."
	but fails for other values. Thanks go to
	Patrick Samson for pointing this out.

2004-02-10  David Gravereaux  <[email protected]>

	* win/nmakehlp.c: better macro grepping logic.

2004-02-07  David Gravereaux  <[email protected]>

	* win/makefile.vc:
	* win/rules.vc:
	* win/tcl.rc:
	* win/tclsh.rc:	 Added an 'unchecked' option to the OPTS macro so a
	core built with symbols can be linked to the non-debug enabled C
	run-time.  As per discussion with Kevin Kenny.	Called like this:

		nmake -af makefile.vc OPTS=unchecked,symbols

	This clarifies the meaning of the 'g' naming suffix to mean only that
	the binary requires the debug enabled C run-time.  Whether the binary
	contains symbols or not is a different condition.

4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236

2004-01-29  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix to [Bug 883143] in file normalization

2004-01-29  Vince Darley  <[email protected]>

	* doc/file.n: 
	* generic/tclFCmd.c
	* generic/tclTest.c
	* library/init.tcl
	* mac/tclMacFile.c
	* tests/fileSystem.test: fix to [Bug 886352] where 'file copy
	-force' had inconsistent behaviour wrt target files with
	insufficient permissions, particular from vfs->native fs.







|







7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476
7477
7478
7479

2004-01-29  Vince Darley  <[email protected]>

	* generic/tclPathObj.c: fix to [Bug 883143] in file normalization

2004-01-29  Vince Darley  <[email protected]>

	* doc/file.n:
	* generic/tclFCmd.c
	* generic/tclTest.c
	* library/init.tcl
	* mac/tclMacFile.c
	* tests/fileSystem.test: fix to [Bug 886352] where 'file copy
	-force' had inconsistent behaviour wrt target files with
	insufficient permissions, particular from vfs->native fs.
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
	Many other minor whitespace/style fixes to this file too.

2004-01-27  David Gravereaux <[email protected]>

	* win/nmakehlp.c: Use '.\nul' as the sourcefile name instead of
	'nul' so VC 5.2 doesn't try searching the path for it and failing
	with a possible dialogbox popping up about having to add a CD to
	an empty drive.  Also added a SetErrorMode() call to disable any
	dialogs that cl.exe or link.exe might create.  [Bug 885537]

2004-01-22  Vince Darley  <[email protected]>

	* doc/file.n: clarified documentation of 'file system' [Bug 883825]
	* tests/fCmd.test: improved test result in failure case.

2004-01-22  Vince Darley  <[email protected]>

	* tests/fileSystem.test: 3 new tests
	* generic/tclPathObj.c: fix to [Bug 879555] in file normalization. 
	* doc/filename.n: small clarification to Windows behaviour with
	filenames like '.....', 'a.....', '.....a'.

	* generic/tclIOUtil.c: slight improvement to native cwd caching
	on Windows.

2004-01-21  David Gravereaux <[email protected]>

	* doc/Panic.3:  Mentions of 'panic' and 'panicVA' removed from
	the documentation.

2004-01-21  Vince Darley  <[email protected]>

	* doc/FileSystem.3: 
	* generic/tcl.decls: 
	* generic/tclCmdAH.c
	* generic/tclDecls.h
	* generic/tclFCmd.c
	* generic/tclFileName.c
	* generic/tclFileSystem.h
	* generic/tclIOUtil.c
	* generic/tclInt.decls







|










|








|




|
|







7498
7499
7500
7501
7502
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
7525
7526
7527
7528
7529
7530
7531
7532
7533
7534
7535
7536
7537
7538
	Many other minor whitespace/style fixes to this file too.

2004-01-27  David Gravereaux <[email protected]>

	* win/nmakehlp.c: Use '.\nul' as the sourcefile name instead of
	'nul' so VC 5.2 doesn't try searching the path for it and failing
	with a possible dialogbox popping up about having to add a CD to
	an empty drive.	 Also added a SetErrorMode() call to disable any
	dialogs that cl.exe or link.exe might create.  [Bug 885537]

2004-01-22  Vince Darley  <[email protected]>

	* doc/file.n: clarified documentation of 'file system' [Bug 883825]
	* tests/fCmd.test: improved test result in failure case.

2004-01-22  Vince Darley  <[email protected]>

	* tests/fileSystem.test: 3 new tests
	* generic/tclPathObj.c: fix to [Bug 879555] in file normalization.
	* doc/filename.n: small clarification to Windows behaviour with
	filenames like '.....', 'a.....', '.....a'.

	* generic/tclIOUtil.c: slight improvement to native cwd caching
	on Windows.

2004-01-21  David Gravereaux <[email protected]>

	* doc/Panic.3:	Mentions of 'panic' and 'panicVA' removed from
	the documentation.

2004-01-21  Vince Darley  <[email protected]>

	* doc/FileSystem.3:
	* generic/tcl.decls:
	* generic/tclCmdAH.c
	* generic/tclDecls.h
	* generic/tclFCmd.c
	* generic/tclFileName.c
	* generic/tclFileSystem.h
	* generic/tclIOUtil.c
	* generic/tclInt.decls
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
	applied a round of filesystem optimisation with better handling
	and caching of relative and absolute paths, requiring fewer
	conversions.  (3) clarifications to the documentation,
	particularly regarding the acceptable refCounts of objects.
	Some new tests added.  Tcl benchmarks show a significant
	improvement over 8.4.5, and on Windows typically a small
	improvement over 8.3.5 (Unix still appears to require
	optimisation).  TCL_FILESYSTEM_VERSION_2 introduced, but for
	internal use only.  There should be no public incompatibilities
	from these changes.  Thanks to dgp for extensive testing.

2004-01-19  David Gravereaux <[email protected]>

	* win/tclWinPipe.c (Tcl_WaitPid): Fixed a thread-safety problem
	with the process list.  The delayed cut operation after the wait
	was going stale by being outside the list lock.  It now cuts
	within the lock and does a locked splice for when it needs to
	instead.  [Bug 859820]

2004-01-18  Donal K. Fellows  <[email protected]>

	* generic/tclCompile.c, generic/tclCompile.h: Two new opcodes,
	INST_LIST_INDEX_IMM and INST_LIST_RANGE_IMM, that have operand(s)







|






|
|







7556
7557
7558
7559
7560
7561
7562
7563
7564
7565
7566
7567
7568
7569
7570
7571
7572
7573
7574
7575
7576
7577
7578
	applied a round of filesystem optimisation with better handling
	and caching of relative and absolute paths, requiring fewer
	conversions.  (3) clarifications to the documentation,
	particularly regarding the acceptable refCounts of objects.
	Some new tests added.  Tcl benchmarks show a significant
	improvement over 8.4.5, and on Windows typically a small
	improvement over 8.3.5 (Unix still appears to require
	optimisation).	TCL_FILESYSTEM_VERSION_2 introduced, but for
	internal use only.  There should be no public incompatibilities
	from these changes.  Thanks to dgp for extensive testing.

2004-01-19  David Gravereaux <[email protected]>

	* win/tclWinPipe.c (Tcl_WaitPid): Fixed a thread-safety problem
	with the process list.	The delayed cut operation after the wait
	was going stale by being outside the list lock.	 It now cuts
	within the lock and does a locked splice for when it needs to
	instead.  [Bug 859820]

2004-01-18  Donal K. Fellows  <[email protected]>

	* generic/tclCompile.c, generic/tclCompile.h: Two new opcodes,
	INST_LIST_INDEX_IMM and INST_LIST_RANGE_IMM, that have operand(s)
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
2004-01-15  David Gravereaux <[email protected]>

	* win/tclWinReg.c:  Placed the requirement for advapi.lib into
	the object file itself with #paragma comment (lib, ...) when
	built with VC++.  This will simplify linking for users of the
	static library.

	* win/rules.vc:  Added new 'fullwarn' to the CHECKS commandline
	macro; sets $(FULLWARNINGS).

	* win/makefile.vc:  Removed 'advapi.lib' from $(baselibs).
	Added new logic to crank-up the warning levels for both compile
	and link when $(FULLWARNINGS) is set.  Some clean-up with how
	the resource files are built and how -DTCL_USE_STATIC_PACKAGES
	is sent when compiling the shells.

	* win/tclAppInit.c: Small change in how TCL_USE_STATIC_PACKAGES
	is used.

	* win/tcl.rc:
	* win/tclsh.rc: Some clean-up with how the resource files are
	built.  Fixed 'OriginalFilename' problem that still thought
	a debug suffix was still 'd', now is 'g'.

2004-01-14  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (TraceDictPath, DictExistsCmd): Adjusted
	behaviour of [dict exists] so a failure to look up a dictionary
	along the path of dicts doesn't trigger an error.  This is how it
	was documented to behave previously...  [Bug 871387]

	* generic/tclDictObj.c: Assorted dict fixes from Peter Spjuth
	relating to [Bug 876170].
	(SetDictFromAny): Make sure that lists retain their ordering even
	when converted to dictionaries and back.
	(TraceDictPath): Correct object reference count handling!
	(DictReplaceCmd, DictRemoveCmd): Stop object leak.
	(DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd): 
	Simpler handling of reference counts when assigning to variables.
	* tests/dict.test (dict-19.2): Memory leak stress test

2004-01-13  Don Porter	<[email protected]>

	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd):  Silence compiler warnings.

	Patch 876451: restores performance of [return].  Also allows forms
	such as [return -code error $msg] to be bytecompiled.

	* generic/tclInt.h:	Factored Tcl_ReturnObjCmd() into two pieces:
	* generic/tclCmdMZ.c:	TclMergeReturnOptions(), which can parse the
	options to [return], check their validity, and create the
	corresponding return options dictionary, and TclProcessReturn(),
	which takes that return options dictionary and performs the







|













|







|







|







|







7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627
7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
7649
7650
7651
7652
7653
7654
7655
7656
7657
7658
2004-01-15  David Gravereaux <[email protected]>

	* win/tclWinReg.c:  Placed the requirement for advapi.lib into
	the object file itself with #paragma comment (lib, ...) when
	built with VC++.  This will simplify linking for users of the
	static library.

	* win/rules.vc:	 Added new 'fullwarn' to the CHECKS commandline
	macro; sets $(FULLWARNINGS).

	* win/makefile.vc:  Removed 'advapi.lib' from $(baselibs).
	Added new logic to crank-up the warning levels for both compile
	and link when $(FULLWARNINGS) is set.  Some clean-up with how
	the resource files are built and how -DTCL_USE_STATIC_PACKAGES
	is sent when compiling the shells.

	* win/tclAppInit.c: Small change in how TCL_USE_STATIC_PACKAGES
	is used.

	* win/tcl.rc:
	* win/tclsh.rc: Some clean-up with how the resource files are
	built.	Fixed 'OriginalFilename' problem that still thought
	a debug suffix was still 'd', now is 'g'.

2004-01-14  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (TraceDictPath, DictExistsCmd): Adjusted
	behaviour of [dict exists] so a failure to look up a dictionary
	along the path of dicts doesn't trigger an error.  This is how it
	was documented to behave previously...	[Bug 871387]

	* generic/tclDictObj.c: Assorted dict fixes from Peter Spjuth
	relating to [Bug 876170].
	(SetDictFromAny): Make sure that lists retain their ordering even
	when converted to dictionaries and back.
	(TraceDictPath): Correct object reference count handling!
	(DictReplaceCmd, DictRemoveCmd): Stop object leak.
	(DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd):
	Simpler handling of reference counts when assigning to variables.
	* tests/dict.test (dict-19.2): Memory leak stress test

2004-01-13  Don Porter	<[email protected]>

	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd):  Silence compiler warnings.

	Patch 876451: restores performance of [return].	 Also allows forms
	such as [return -code error $msg] to be bytecompiled.

	* generic/tclInt.h:	Factored Tcl_ReturnObjCmd() into two pieces:
	* generic/tclCmdMZ.c:	TclMergeReturnOptions(), which can parse the
	options to [return], check their validity, and create the
	corresponding return options dictionary, and TclProcessReturn(),
	which takes that return options dictionary and performs the
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
	Create fresh objects instead of using the one currently in the
	interpreter, which isn't guaranteed to be fresh and unshared. The
	cost for the core will be minimal because of the object cache, and
	this fixes [Bug 875395].

2004-01-12  Miguel Sofer <[email protected]>

	* generic/tclCompExpr.c (CompileLandOrLorExpr): cosmetic changes. 

2004-01-12  Miguel Sofer <[email protected]>

	* generic/tclCompExpr.c (CompileLandOrLorExpr): new logic, fewer
	instructions. As a side effect, the instructions INST_LOR and
	INST_LAND are now never used.
	* generic/tclExecute.c (INST_JUMP*): small optimisation; fix a
	bug in debug code.

2004-01-11  David Gravereaux <[email protected]>

	* win/tclWinThrd.c (Tcl_ConditionNotify): condPtr must be
	dereferenced to see if there are waiters else uninitialized
	datum is manipulated.  [Bug 849007 789338 745068]

2004-01-09  David Gravereaux <[email protected]>

	* generic/tcl.h: Renamed and deprecated #defines moved to within
	the #ifndef TCL_NO_DEPRECATED block.  This allows us to build Tcl
	to check for deprecated functions in use, such as panic() and
	Tcl_Ckalloc().  By request from DKF.  Extensions that build
	with -DTCL_NO_DEPRECATED now have these macros as restricted.
	***POTENTIAL INCOMPATIBILITY***

	* win/makefile.vc:
	* win/rules.vc:  Added -DTCL_NO_DEPRECATED usage to makefile.vc.
	Called like this:   nmake -af makefile.vc CHECKS=nodep

2004-01-09  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to infinite loop in 
	TclFinalizeFilesystem [Bug 873311]

	******************************************************************
	*** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003"             ***
	*** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002"             ***
	*** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001"             ***
	*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000"             ***
	*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
	******************************************************************







|




















|




|




|



|
|
|
|


7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
	Create fresh objects instead of using the one currently in the
	interpreter, which isn't guaranteed to be fresh and unshared. The
	cost for the core will be minimal because of the object cache, and
	this fixes [Bug 875395].

2004-01-12  Miguel Sofer <[email protected]>

	* generic/tclCompExpr.c (CompileLandOrLorExpr): cosmetic changes.

2004-01-12  Miguel Sofer <[email protected]>

	* generic/tclCompExpr.c (CompileLandOrLorExpr): new logic, fewer
	instructions. As a side effect, the instructions INST_LOR and
	INST_LAND are now never used.
	* generic/tclExecute.c (INST_JUMP*): small optimisation; fix a
	bug in debug code.

2004-01-11  David Gravereaux <[email protected]>

	* win/tclWinThrd.c (Tcl_ConditionNotify): condPtr must be
	dereferenced to see if there are waiters else uninitialized
	datum is manipulated.  [Bug 849007 789338 745068]

2004-01-09  David Gravereaux <[email protected]>

	* generic/tcl.h: Renamed and deprecated #defines moved to within
	the #ifndef TCL_NO_DEPRECATED block.  This allows us to build Tcl
	to check for deprecated functions in use, such as panic() and
	Tcl_Ckalloc().	By request from DKF.  Extensions that build
	with -DTCL_NO_DEPRECATED now have these macros as restricted.
	***POTENTIAL INCOMPATIBILITY***

	* win/makefile.vc:
	* win/rules.vc:	 Added -DTCL_NO_DEPRECATED usage to makefile.vc.
	Called like this:   nmake -af makefile.vc CHECKS=nodep

2004-01-09  Vince Darley  <[email protected]>

	* generic/tclIOUtil.c: fix to infinite loop in
	TclFinalizeFilesystem [Bug 873311]

	******************************************************************
	*** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003"	       ***
	*** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002"	       ***
	*** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001"	       ***
	*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000"	       ***
	*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
	******************************************************************

Changes to README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
README:  Tcl
    This is the Tcl 8.5a2 source distribution.
    Tcl/Tk is also available through NetCVS:
	http://tcl.sourceforge.net/
    You can get any source release of Tcl from the file distributions
    link at the above URL.

RCS: @(#) $Id: README,v 1.53 2004/03/26 19:47:28 dgp Exp $

Contents
--------
    1. Introduction
    2. Documentation
    3. Compiling and installing Tcl
    4. Development tools

|





|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
README:  Tcl
    This is the Tcl 8.5a4 source distribution.
    Tcl/Tk is also available through NetCVS:
	http://tcl.sourceforge.net/
    You can get any source release of Tcl from the file distributions
    link at the above URL.

RCS: @(#) $Id: README,v 1.53.2.2 2005/07/12 20:36:11 kennykb Exp $

Contents
--------
    1. Introduction
    2. Documentation
    3. Compiling and installing Tcl
    4. Development tools

Changes to changes.

1
2
3
4
5
6
7
8
9
10
Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.92 2004/11/18 18:34:10 dgp Exp $

1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.

2. Semi-colon now available for grouping commands on a line.

3. For a command to span multiple lines, must now use backslash-return


|







1
2
3
4
5
6
7
8
9
10
Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.92.2.2 2005/07/12 20:36:11 kennykb Exp $

1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.

2. Semi-colon now available for grouping commands on a line.

3. For a command to span multiple lines, must now use backslash-return
6195
6196
6197
6198
6199
6200
6201
6202

6203
6204
6205
6206

6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220

6221
6222
6223
6224

6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237

6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251

6252
6253
6254
6255
6256
6257
6258
6259
6260
6261

6262
6263
6264
6265

6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296

6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307

































6308
6309
6310
6311


















































































































































2004-09-07 (bug fix)[1016167] [after] overwrites its imports (kenny)

2004-09-08 (bug fix) fixed [clock format 0 -format %k] (kenny)

2004-09-09 (bug fix)[560297] fixed broken [namespace forget] logic (porter)

2004-09-09 (bug fix)[1017299] fixed [namespace import] cycle prevention (porter)


2004-09-10 (performance) $x[set x {}] is now fast [K $x [set x {}]] (sofer)

2004-09-10 (bug fix)[868489] better control over int <-> wideInt (fellows,kenny)


2004-09-10 (bug fix)[1025359] POSIX errorCode from wide seeks (kupries,fellows)

2004-09-10 (bug fix)[707104,1026493] fix [rename] of [interp alias] (porter)

2004-09-18 (bug fix)[868467] fix [expr 5>>32] => 0, not 5 (hintermayer,fellows)

2004-09-21 (bug fix) consistent errorinfo from [namespace eval x error foo bar]
		and [namespace eval c {error foo bar}] (porter)

2004-09-22 (feature change) syntax errors not reported at compile time;
		deferred to runtime.  Support [return -errorline]. (porter)

2004-09-23 (bug fix)[1016726] fix `make clean` in static config (leitgeb,dejong)


2004-09-22 (feature change) report all compile errors at runtime (porter)

2004-09-29 (bug fix)[1036649] syntax error in [subst] => buffer overflow (sofer)


2004-09-30 (bug fix)[1038021] save/restore error state: var traces (porter)

2004-10-01 (performance) stackframe level values in internal reps (fellows)

2004-10-01 (feature change)[1037235] auto-create [dict] key paths (fellows)

2004-10-04 (bug fix)[884830] eq and ne parse in expr (fellows)

2004-10-05 (reform) errorInfo, errorCode management (porter)
	*** POTENTIAL INCOMPATIBILITY for traces on those vars ***

2004-10-06 (feature change)[1041072] re-bless and enhance Tcl_AppendResult (dkf)


2004-10-06 (reform) more robust interp result appends (porter)
=> dde 1.3.1
=> registry 1.1.5

2004-10-06 (reform) re-write of [glob] guts (fellows)

2004-10-07 (reform)[925620] improved platform split of VFS code (darley)

2004-10-08 (new feature)[TIP 201] "in" and "ni" expr operators (fellows)

2004-10-08 (new feature)[TIP 212] [dict update]; [dict with] (fellows)

2004-10-08 (bug fix)[954263] case insensitive [file exec] for Win (hobbs,darley)


2004-10-14 (performance) [info commands/globals/procs/vars $pattern] faster
                when $pattern is trivial (fellows)

2004-10-14 (new feature)[TIP 217] [lsort -indices] (salsman,fellows)

2004-10-24 (reform) replaced bit flag values with macros for Var handling
	*** POTENTIAL INCOMPATIBILITY for accesses to Var internals ***

2004-10-26 (new feature)[1054370] install msgcat, http, tcltest as TM's (porter)


2004-10-26 (bug fix)[767676] negative PIDs with pipes (giese,gravereaux)

2004-10-27 (bug fix)[731778] stop critical section leaks (mistachkin,gravereaux)


2004-10-27 (bug fix)[926088] -load option to find tested packages (gravereaux)

2004-10-28 (bug fix)[1030548] restore the --enable-symbols --enable-threads
                build on Win (mistachkin,kenny,kupries)

2004-10-29 (bug fix)[1055673] fix command line syntax error message (porter)
=> tcltest 2.2.7

2004-10-30 (bug fix)[926106] fix [file mtime] DST anomaly (kenny)

2004-10-31 (bug fix)[1057461] fix [info globals ::varName] (fellows)

2004-11-02 (bug fix)[761471] fix [expr {NaN == NaN}] (sofer)

2004-11-02 (bug fix)[1017151] misleading errorInfo after tests (seeger,porter)

2004-11-03 (bug fix)[527164] preserve errorinfo from var traces (porter)

2004-11-08 (bug fix){947693] Made -blocking option of channel during [close]
	consistent on Windows with Unix (gravereaux)
	*** POTENTIAL INCOMPATIBILITY ***

2004-11-11 (bug fix)[1034337] recursive file delete, MacOSX (steffen)

2004-11-12 (feature)[TIP 34] make use of a configuration header file (fellows)
	*** POTENTIAL INCOMPATIBILITY ***

2004-11-12 (new feature)[TIP 221] [interp bgerror] (porter)

2004-11-12 (new feature)[TIP 226] Tcl_(Save|Restore|Discard)InterpState (porter)


2004-11-12 (new feature)[TIP 227] Tcl_(Get|Set)ReturnOptions (porter)

2004-11-12 (bug fix)[1004065] stop crash when TCL_UTF_MAX==6 (hobbs,porter)

2004-11-15 (bug fix)[10653678] [trace variable],[trace remove] interop (porter)

2004-11-16 (bug fix)[1067709] crash in [fconfigure -ttycontrol] (hobbs)

2004-11-18 (new feature) configure options --enable-man-suffix (max)


































Doc improvements [759545,926590,935853,1017072,1018486,1022527,1027849,
			1032243,1047928,1048005,1058446,1062647,1065732,etc.]
Test suite expansion [1036649,1001997,etc.]

























































































































































|
>



|
>













|
>



|
>












|
>













|
>









|
>



|
>




|















|




<
<
<


|
>











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298



6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495

2004-09-07 (bug fix)[1016167] [after] overwrites its imports (kenny)

2004-09-08 (bug fix) fixed [clock format 0 -format %k] (kenny)

2004-09-09 (bug fix)[560297] fixed broken [namespace forget] logic (porter)

2004-09-09 (bug fix)[1017299] fixed [namespace import] cycle prevention
(porter)

2004-09-10 (performance) $x[set x {}] is now fast [K $x [set x {}]] (sofer)

2004-09-10 (bug fix)[868489] better control over int <-> wideInt
(fellows,kenny)

2004-09-10 (bug fix)[1025359] POSIX errorCode from wide seeks (kupries,fellows)

2004-09-10 (bug fix)[707104,1026493] fix [rename] of [interp alias] (porter)

2004-09-18 (bug fix)[868467] fix [expr 5>>32] => 0, not 5 (hintermayer,fellows)

2004-09-21 (bug fix) consistent errorinfo from [namespace eval x error foo bar]
		and [namespace eval c {error foo bar}] (porter)

2004-09-22 (feature change) syntax errors not reported at compile time;
		deferred to runtime.  Support [return -errorline]. (porter)

2004-09-23 (bug fix)[1016726] fix `make clean` in static config
(leitgeb,dejong)

2004-09-22 (feature change) report all compile errors at runtime (porter)

2004-09-29 (bug fix)[1036649] syntax error in [subst] => buffer overflow
(sofer)

2004-09-30 (bug fix)[1038021] save/restore error state: var traces (porter)

2004-10-01 (performance) stackframe level values in internal reps (fellows)

2004-10-01 (feature change)[1037235] auto-create [dict] key paths (fellows)

2004-10-04 (bug fix)[884830] eq and ne parse in expr (fellows)

2004-10-05 (reform) errorInfo, errorCode management (porter)
	*** POTENTIAL INCOMPATIBILITY for traces on those vars ***

2004-10-06 (feature change)[1041072] re-bless and enhance Tcl_AppendResult
(dkf)

2004-10-06 (reform) more robust interp result appends (porter)
=> dde 1.3.1
=> registry 1.1.5

2004-10-06 (reform) re-write of [glob] guts (fellows)

2004-10-07 (reform)[925620] improved platform split of VFS code (darley)

2004-10-08 (new feature)[TIP 201] "in" and "ni" expr operators (fellows)

2004-10-08 (new feature)[TIP 212] [dict update]; [dict with] (fellows)

2004-10-08 (bug fix)[954263] case insensitive [file exec] for Win
(hobbs,darley)

2004-10-14 (performance) [info commands/globals/procs/vars $pattern] faster
                when $pattern is trivial (fellows)

2004-10-14 (new feature)[TIP 217] [lsort -indices] (salsman,fellows)

2004-10-24 (reform) replaced bit flag values with macros for Var handling
	*** POTENTIAL INCOMPATIBILITY for accesses to Var internals ***

2004-10-26 (new feature)[1054370] install msgcat, http, tcltest as TM's
(porter)

2004-10-26 (bug fix)[767676] negative PIDs with pipes (giese,gravereaux)

2004-10-27 (bug fix)[731778] stop critical section leaks
(mistachkin,gravereaux)

2004-10-27 (bug fix)[926088] -load option to find tested packages (gravereaux)

2004-10-28 (bug fix)[1030548] restore the --enable-symbols --enable-threads
build on Win (mistachkin,kenny,kupries)

2004-10-29 (bug fix)[1055673] fix command line syntax error message (porter)
=> tcltest 2.2.7

2004-10-30 (bug fix)[926106] fix [file mtime] DST anomaly (kenny)

2004-10-31 (bug fix)[1057461] fix [info globals ::varName] (fellows)

2004-11-02 (bug fix)[761471] fix [expr {NaN == NaN}] (sofer)

2004-11-02 (bug fix)[1017151] misleading errorInfo after tests (seeger,porter)

2004-11-03 (bug fix)[527164] preserve errorinfo from var traces (porter)

2004-11-08 (bug fix){947693] Made -blocking option of channel during [close]
consistent on Windows with Unix (gravereaux)
	*** POTENTIAL INCOMPATIBILITY ***

2004-11-11 (bug fix)[1034337] recursive file delete, MacOSX (steffen)




2004-11-12 (new feature)[TIP 221] [interp bgerror] (porter)

2004-11-12 (new feature)[TIP 226] Tcl_(Save|Restore|Discard)InterpState
(porter)

2004-11-12 (new feature)[TIP 227] Tcl_(Get|Set)ReturnOptions (porter)

2004-11-12 (bug fix)[1004065] stop crash when TCL_UTF_MAX==6 (hobbs,porter)

2004-11-15 (bug fix)[10653678] [trace variable],[trace remove] interop (porter)

2004-11-16 (bug fix)[1067709] crash in [fconfigure -ttycontrol] (hobbs)

2004-11-18 (new feature) configure options --enable-man-suffix (max)

2004-11-22 (bug fix)[1030465] Improve HAVE_TYPE_OFF64_T check (dejong)

2004-11-22 (bug fix)[1043129] Fixed the treatment of backslashes in file
join on Windows (darley)

2004-11-22 (bug fix)[976438] Move init.tcl search path construction to
tclInit (porter)

2004-11-24 (bug fix)[1072654] Fixed segfault in info vars trivial
matching branch (new in 8.4.8) (porter)

2004-11-24 (bug fix)[1001325, 1071701] Fixed readdir_r detection and usage
(dejong, kenny, porter)

2004-11-24 (bug fix)[1071807] Fixed all uses of 'select' to use standard
macros rather than older bit-whacking style (kenny)

2004-11-26 (bug fix)[1073524] Simplify the code to check for correctness of
strstr, strtoul and strtod on unix (fellows)

2004-11-26 (bug fix)[1072136] Remove file normalize on tcl_findLibrary
search path uniqification added in 8.4.8 (porter)

2004-11-30 (bug fix)[976520] Rework startup/initialization of the Tcl
library, encoding search initialization, and Tcl_FindExecutable structure.
[tclInit] no longer driven by the value of $::tcl_libPath (TCLLIBPATH).
(porter)
	*** POTENTIAL INCOMPATIBILITY : makes encoding names case sensitive
	    on Windows, where they have been case insensitive ***

2004-12-02 (bug fix)[1074671] Ensure tilde paths are not returned specially
by 'glob' (darley)

Doc improvements [759545,926590,935853,1017072,1018486,1022527,1027849,
	1032243,1047928,1048005,1058446,1062647,1065732,1073334,etc.]
Test suite expansion [1036649,1001997,etc.]

--- Released 8.5a2, December 7, 2004 --- See ChangeLog for details ---

2004-12-13 (bug fix)[1083082] encoding memory leaks (ade,porter)

2004-12-13 (bug fix)[1082349] restored C++ extension support (porter)

2004-12-14 (bug fix)[1081541] workaround automake-ism "$U" (porter)

2004-12-15 (new feature) CallFrames on execution, not C, stack (sofer)

2004-12-16 (bug fix)[1085023] [interp limit] support in [vwait], etc. (fellows)

2004-12-29 (bug fix)[1090413] make [clock scan 0030] work (morian,kenny)

2004-12-29 (bug fix)[1092789] make [clock scan 10000] work (porter,kenny)

2004-12-29 (platform support)[1092952,1091967] MSVC7, gcc OPT compiles (hobbs)

2005-01-06 (performance)[1020491] [http::mapReply] (fellows)
=> http 2.5.1

2005-01-09 (bug fix)[1095909] stopped use of readdir_r (english)

2005-01-10 (enhancement)[1081595] stopped use of TCL_DBGX (english)

2005-01-17 (bug fix)[1100542] [glob] of Windows shares (schar,darley)

2005-01-19 (new feature)[TIP 235] C API for ensembles (fellows)

2005-01-21 (new feature)[TIP 233] virtual time (kupries)

2005-01-25 (bug fix)[1101670] [auto_reset] update for [namespace] (porter)
***POTENTIAL INCOMPATIBILITY***
May cause re-[source]-ing of files that have not anticipated that before.

2005-01-27 (new feature)[TIP 218] Tcl_Channel API update for threads (kupries)

2005-01-27 (bug fix)[1109484] Tcl_Expr* updates for Tcl_WideInt (hobbs)

2005-01-28 (platform support)[1021871] Solaris gcc 64-bit support (hobbs)

2005-02-10 (bug fix)[1119369] Tcl_EvalObjEx: avoid shimmer loss of List intrep
(sofer,macdonald)

2005-02-11 (platform support) correct gcc builds for AIX-4+, HP-UX-11 (hobbs)

2005-02-24 (bug fix)[1119798] prevent [source $directory] (porter,mpettigr)
=> tcltest 2.2.8

2005-03-10 (bug fix)[1153871] bad ClientData cast (porter,victorovich)

2005-03-15 (platform support) OpenBSD ports patch (thoyts)

2005-03-18 (bug fix)[1115904] restore recursion limit in direct eval (porter)

2005-03-24 (bug fix) stop conflict between Tcltest and Thread packages (porter)

2005-03-29 (platform support) allow msys builds without cygwin (hobbs)

2005-04-01 (internal change)[1158008]  internal rep of "list" Tcl_Obj's
now uses a refcounted struct (sofer)
***POTENTIAL INCOMPATIBILITY***
For any code that goes poking into the internals of "list" Tcl_Obj's

2005-04-05 (performance)[1174551] Tcl_DecrRefCount of Tcl_Obj "chains" (sofer)

2005-04-08 (performance)[1077262] better Tcl_Encoding cache lifetimes (porter)

2005-04-10 (bug fix)[1180368] [interp invokehidden] mem leak (kenny,porter)

2005-04-12 (performance)[1177363] startup encoding file scan (porter)

2005-04-12 (performance)[1182459] [clock format] (kenny)

2005-04-13 (bug fix) min buffer size dropped from 10 to 1 byte (gravereaux)

2005-04-16 (bug fix)[1178445] fix memory waste at thread exit (vasiljevic)

2004-04-16 (bug fix)[1084111] [array names] memory leak (ade,sofer)

2005-04-19 (bug fix)[1185933] [clock] init clobbered global vars (ring,kenny)

2005-04-19 (new feature) [::tcl::unsupported::EncodingDirs] - unsupported
command to set search path for encoding files (porter)

2005-04-20 (bug fix)[1090869] Tcl_GetInt accept 0x80000000, 64-bit
(porter,singh)

2005-04-22 (bug fix)[1187123] [string is boolean] respect EIAS (porter)

2005-04-25 (enhancement) update to tzdata2005i (kenny)

2005-04-25 (platform support) builds on Mac OS X 10.1 (steffen)

2005-04-27 (new feature)[TIP 183] [open $f {... BINARY ...}] (porter)

2005-04-29 (new feature)[TIP 176] simple index arithmetic (porter)

2005-05-06 (platform support) x86_64 Solarix cc and Solaris 10 builds (hobbs)

2005-05-10 (bug fix)[1198892] [expr {i**0}] error (kaitschu,markus)

2005-05-10 (new feature)[TIP 132] floating-point conversion to string (kenny)
***POTENTIAL INCOMPATIBILITY***
For scripts that rely on (tcl_precision==12) number formatting

2005-05-10 (new feature)[TIP 232] math functions as commands (kenny)
***POTENTIAL INCOMPATIBILITY***
Tcl_GetMathFuncInfo functioning is reduced; routine is now deprecated

2005-05-13 (feature removed) TCL_NO_MATH compiler directive (porter)

2005-05-14 (platform support) Mac OSX: configurable CoreFoundation API
(steffen)

2005-05-14 (platform support) Mac OSX: use realpath when threadsafe (steffen)

2005-05-17 (feature removed) Tcl_ObjType's "list", "procbody", "index",
"ensembleCommand", "localVarName", "levelReference, "boolean" are no
longer registered (porter)
***POTENTIAL INCOMPATIBILITY***
For any callers of Tcl_GetObjType on those strings

2005-05-20 (bug fix)[1201589] boolean literal prefix in expressions (porter)

2005-05-24 (platform support) Darwin build support merged into unix (steffen)

2005-05-24 (new feature)[1202209] Mac OSX: support [load] of .bundle binaries
Can support [load] from memory as well (steffen)

2005-05-24 (new feature)[1202178] [time] returns non-integer result (steffen)

2005-05-25 (new feature)[TIP 182] [expr {bool(...)}] (mistachkin,porter)

2005-05-30 (new feature)[TIP 229] [namespace path] (fellows)

2005-05-31 (bug fix)[1082283] Unix: notifier thread now joinable (vasiljevic)

2005-06-01 (new feature)[TIP 241] -nocase: lsort, lsearch, switch (mistachkin)

2005-06-01 (bug fix)[1209759] "return TCL_RETURN;" could cause panic (porter)

Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.]

--- Released 8.5a3, June 4, 2004 --- See ChangeLog for details ---

Changes to compat/string.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28



29

30
31
32
33
34
35
36
/*
 * string.h --
 *
 *	Declarations of ANSI C library procedures for string handling.
 *
 * Copyright (c) 1991-1993 The Regents of the University of California.
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: string.h,v 1.5 2004/03/17 18:14:12 das Exp $
 */

#ifndef _STRING
#define _STRING

#include <tcl.h>

/*
 * The following #include is needed to define size_t. (This used to
 * include sys/stdtypes.h but that doesn't exist on older versions
 * of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully
 * it exists everywhere)
 */

#include <sys/types.h>




extern char *		memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n));

extern int		memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2,
			    size_t n));
extern char *		memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n));
#ifdef NO_MEMMOVE
#define memmove(d, s, n) bcopy ((s), (d), (n))
#else
extern char *		memmove _ANSI_ARGS_((VOID *t, CONST VOID *f,











|
















>
>
>

>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
/*
 * string.h --
 *
 *	Declarations of ANSI C library procedures for string handling.
 *
 * Copyright (c) 1991-1993 The Regents of the University of California.
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: string.h,v 1.5.2.1 2005/05/05 17:55:18 kennykb Exp $
 */

#ifndef _STRING
#define _STRING

#include <tcl.h>

/*
 * The following #include is needed to define size_t. (This used to
 * include sys/stdtypes.h but that doesn't exist on older versions
 * of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully
 * it exists everywhere)
 */

#include <sys/types.h>

#ifdef __APPLE__
extern VOID *		memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n));
#else
extern char *		memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n));
#endif
extern int		memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2,
			    size_t n));
extern char *		memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n));
#ifdef NO_MEMMOVE
#define memmove(d, s, n) bcopy ((s), (d), (n))
#else
extern char *		memmove _ANSI_ARGS_((VOID *t, CONST VOID *f,

Changes to compat/strstr.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15



16
17
18
19
20
21
22
/* 
 * strstr.c --
 *
 *	Source code for the "strstr" library routine.
 *
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: strstr.c,v 1.4 2004/04/06 22:25:48 dgp Exp $
 */

#include "tcl.h"




/*
 *----------------------------------------------------------------------
 *
 * strstr --
 *
 *	Locate the first instance of a substring in a string.











|



>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
/* 
 * strstr.c --
 *
 *	Source code for the "strstr" library routine.
 *
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: strstr.c,v 1.4.2.1 2005/04/25 21:37:18 kennykb Exp $
 */

#include "tcl.h"
#ifndef NULL
#define NULL 0
#endif

/*
 *----------------------------------------------------------------------
 *
 * strstr --
 *
 *	Locate the first instance of a substring in a string.

Changes to compat/strtoll.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * strtoll.c --
 *
 *	Source code for the "strtoll" library procedure.
 *
 * Copyright (c) 1988 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: strtoll.c,v 1.7 2004/04/06 22:25:48 dgp Exp $
 */

#include "tclInt.h"
#include <ctype.h>

#define TCL_WIDEINT_MAX	(((Tcl_WideUInt)Tcl_LongAsWide(-1))>>1)












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * strtoll.c --
 *
 *	Source code for the "strtoll" library procedure.
 *
 * Copyright (c) 1988 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: strtoll.c,v 1.7.2.2 2005/01/20 19:12:26 kennykb Exp $
 */

#include "tclInt.h"
#include <ctype.h>

#define TCL_WIDEINT_MAX	(((Tcl_WideUInt)Tcl_LongAsWide(-1))>>1)

Changes to compat/strtoull.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * strtoull.c --
 *
 *	Source code for the "strtoull" library procedure.
 *
 * Copyright (c) 1988 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: strtoull.c,v 1.7 2004/04/06 22:25:48 dgp Exp $
 */

#include "tclInt.h"
#include <ctype.h>

/*
 * The table below is used to convert from ASCII digits to a











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * strtoull.c --
 *
 *	Source code for the "strtoull" library procedure.
 *
 * Copyright (c) 1988 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: strtoull.c,v 1.7.2.2 2005/01/20 19:12:27 kennykb Exp $
 */

#include "tclInt.h"
#include <ctype.h>

/*
 * The table below is used to convert from ASCII digits to a

Changes to doc/AddErrInfo.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13 2004/11/21 23:17:50 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS 8.5







|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.2 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS 8.5
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
.AP Tcl_Obj *errorObjPtr in
The \fB-errorcode\fR return option will be set to this value.
.AP char *element in
String to record as one element of the \fB-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE

.SH DESCRIPTION
.PP
.VS 8.5
The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR
routines expose the same capabilities as the \fBreturn\fR and
\fBcatch\fR commands, respectively, in the form of a C interface.
.PP
\fBTcl_GetObjResult\fR retrieves the dictionary of return options
from an interpreter following a script evaluation.
Routines such as \fBTcl_Eval\fR are called to evaluate a
script in an interpreter.  These routines return an integer
completion code.  These routines also leave in the interpreter
both a result and a dictionary of return options generated
by script evaluation.  Just as \fBTcl_GetObjResult\fR retrieves
the result, \fBTcl_GetReturnOptions\fR retrieves the dictionary
of return options.  The integer completion code should be
passed as the \fIcode\fR argument to \fBTcl_GetObjResult\fR
so that all required options will be present in the dictionary.
Specifically, a \fIcode\fR value of \fBTCL_ERROR\fR will
ensure that entries for the keys \fB-errorinfo\fR,
\fB-errorcode\fR, and \fB-errorline\fR will appear in the
dictionary.  Also, the entries for the keys \fB-code\fR
and \fB-level\fR will be adjusted if necessary to agree
with the value of \fIcode\fR.  The \fB(Tcl_Obj *)\fR returned







|















|








|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
.AP Tcl_Obj *errorObjPtr in
The \fB-errorcode\fR return option will be set to this value.
.AP char *element in
String to record as one element of the \fB-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE

.SH DESCRIPTION
.PP
.VS 8.5
The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR
routines expose the same capabilities as the \fBreturn\fR and
\fBcatch\fR commands, respectively, in the form of a C interface.
.PP
\fBTcl_GetReturnOptions\fR retrieves the dictionary of return options
from an interpreter following a script evaluation.
Routines such as \fBTcl_Eval\fR are called to evaluate a
script in an interpreter.  These routines return an integer
completion code.  These routines also leave in the interpreter
both a result and a dictionary of return options generated
by script evaluation.  Just as \fBTcl_GetObjResult\fR retrieves
the result, \fBTcl_GetReturnOptions\fR retrieves the dictionary
of return options.  The integer completion code should be
passed as the \fIcode\fR argument to \fBTcl_GetReturnOptions\fR
so that all required options will be present in the dictionary.
Specifically, a \fIcode\fR value of \fBTCL_ERROR\fR will
ensure that entries for the keys \fB-errorinfo\fR,
\fB-errorcode\fR, and \fB-errorline\fR will appear in the
dictionary.  Also, the entries for the keys \fB-code\fR
and \fB-level\fR will be adjusted if necessary to agree
with the value of \fIcode\fR.  The \fB(Tcl_Obj *)\fR returned
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
The best time to call \fBTcl_AddErrorInfo\fR is just after
a script evaluation routine has returned \fBTCL_ERROR\fR.
The value of the \fB-errorline\fR return option (retrieved
via a call to \fBTcl_GetReturnOptions\fR) often makes up
a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR.
.PP
\fBTcl_AddObjErrorInfo\fR is nearly identical
to \fBTcl_AddObjErrorInfo\fR, except that it has an additional \fIlength\fR
argument.  This allows the \fImessage\fR string to contain 
embedded null bytes.  This is essentially never a good idea.
If the \fImessage\fR needs to contain the null character \fBU+0000\fR,
Tcl's usual internal encoding rules should be used to avoid
the need for a null byte.  If the \fBTcl_AddObjErrorInfo\fR
interface is used at all, it should be with a negative \fIlength\fR value.
.PP







|







197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
The best time to call \fBTcl_AddErrorInfo\fR is just after
a script evaluation routine has returned \fBTCL_ERROR\fR.
The value of the \fB-errorline\fR return option (retrieved
via a call to \fBTcl_GetReturnOptions\fR) often makes up
a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR.
.PP
\fBTcl_AddObjErrorInfo\fR is nearly identical
to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR
argument.  This allows the \fImessage\fR string to contain 
embedded null bytes.  This is essentially never a good idea.
If the \fImessage\fR needs to contain the null character \fBU+0000\fR,
Tcl's usual internal encoding rules should be used to avoid
the need for a null byte.  If the \fBTcl_AddObjErrorInfo\fR
interface is used at all, it should be with a negative \fIlength\fR value.
.PP
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
corresponding return options.  It has long been emphasized
in this manual page that it is important to 
call the procedures described here rather than
setting \fBerrorInfo\fR or \fBerrorCode\fR directly with
\fBTcl_ObjSetVar2\fR.
.PP
If the procedure \fBTcl_ResetResult\fR is called,
it clears all of the state of ther interpreter associated with
script evaluation, including the entire return options dictionary.
In particular, the \fB-errorinfo\fR and \fB-errorcode\fR options
are reset.  
If an error had occurred, the \fBTcl_ResetResult\fR call will
clear the error state to make it appear as if no error had
occurred after all.
The global variables \fBerrorInfo\fR and
\fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR
so they continue to hold a record of information about the
more recent error seen in an interpreter.

.SH "SEE ALSO"
Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno

.SH KEYWORDS
error, object, object result, stack, trace, variable







|









|






263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
corresponding return options.  It has long been emphasized
in this manual page that it is important to 
call the procedures described here rather than
setting \fBerrorInfo\fR or \fBerrorCode\fR directly with
\fBTcl_ObjSetVar2\fR.
.PP
If the procedure \fBTcl_ResetResult\fR is called,
it clears all of the state of the interpreter associated with
script evaluation, including the entire return options dictionary.
In particular, the \fB-errorinfo\fR and \fB-errorcode\fR options
are reset.  
If an error had occurred, the \fBTcl_ResetResult\fR call will
clear the error state to make it appear as if no error had
occurred after all.
The global variables \fBerrorInfo\fR and
\fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR
so they continue to hold a record of information about the
most recent error seen in an interpreter.

.SH "SEE ALSO"
Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno

.SH KEYWORDS
error, object, object result, stack, trace, variable

Changes to doc/Async.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Async.3,v 1.7 2004/11/20 00:17:31 dgp Exp $
'\" 
.so man.macros
.TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Async.3,v 1.7.2.1 2004/12/13 22:03:09 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events
.SH SYNOPSIS
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
allocation could have been in progress when the event occurred.
The only safe approach is to set a flag indicating that the event
occurred, then handle the event later when the world has returned
to a clean state, such as after the current Tcl command completes.
.PP
\fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR
are thread sensitive.  They access and/or set a thread-specific data
structure in the event of an --enable-thread built core.  The token
created by Tcl_AsyncCreate contains the needed thread information it
was called from so that calling Tcl_AsyncMark(token) will only yield
the origin thread into the AsyncProc.
.PP 
\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns
a token for it.
The asynchronous handler must be created before
any occurrences of the asynchronous event that it is intended
to handle (it is not safe to create a handler at the time of
an event).
When an asynchronous event occurs the code that detects the event







|
|
|
|
|







58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
allocation could have been in progress when the event occurred.
The only safe approach is to set a flag indicating that the event
occurred, then handle the event later when the world has returned
to a clean state, such as after the current Tcl command completes.
.PP
\fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR
are thread sensitive.  They access and/or set a thread-specific data
structure in the event of a core built with \fI\-\-enable\-threads\fR.  The token
created by \fBTcl_AsyncCreate\fR contains the needed thread information it
was called from so that calling \fBTcl_AsyncMark\fR(\fItoken\fR) will only yield
the origin thread into the asynchronous handler.
.PP
\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns
a token for it.
The asynchronous handler must be created before
any occurrences of the asynchronous event that it is intended
to handle (it is not safe to create a handler at the time of
an event).
When an asynchronous event occurs the code that detects the event

Changes to doc/Backslash.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Backslash.3,v 1.5 2004/10/07 14:44:31 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Backslash \- parse a backslash sequence
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Backslash.3,v 1.5.2.1 2005/04/10 23:14:39 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Backslash \- parse a backslash sequence
.SH SYNOPSIS
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled
in with number of characters in the backslash sequence, including
the backslash character.
.BE

.SH DESCRIPTION
.PP
.VS 8.1
The use of \fBTcl_Backslash\fR is deprecated in favor of
\fBTcl_UtfBackslash\fR.
.PP
This is a utility procedure provided for backwards compatibility with
non-internationalized Tcl extensions.  It parses a backslash sequence and
returns the low byte of the Unicode character corresponding to the sequence. 
.VE
\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of
characters in the backslash sequence.
.PP
See the Tcl manual entry for information on the valid backslash sequences.
All of the sequences described in the Tcl manual entry are supported by
\fBTcl_Backslash\fR.
.VS 8.1 br
.SH "SEE ALSO"
Tcl(n), Tcl_UtfBackslash(3)
.VE

.SH KEYWORDS
backslash, parse







<






<






<


<



26
27
28
29
30
31
32

33
34
35
36
37
38

39
40
41
42
43
44

45
46

47
48
49
If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled
in with number of characters in the backslash sequence, including
the backslash character.
.BE

.SH DESCRIPTION
.PP

The use of \fBTcl_Backslash\fR is deprecated in favor of
\fBTcl_UtfBackslash\fR.
.PP
This is a utility procedure provided for backwards compatibility with
non-internationalized Tcl extensions.  It parses a backslash sequence and
returns the low byte of the Unicode character corresponding to the sequence. 

\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of
characters in the backslash sequence.
.PP
See the Tcl manual entry for information on the valid backslash sequences.
All of the sequences described in the Tcl manual entry are supported by
\fBTcl_Backslash\fR.

.SH "SEE ALSO"
Tcl(n), Tcl_UtfBackslash(3)


.SH KEYWORDS
backslash, parse

Changes to doc/BoolObj.3.

1
2

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

59

60

61


62


63


64










65



66
67
68
69
70
71
72
73

74
75
76
77
78
79
80
81
82
83

84
85
86
87
88
89
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: BoolObj.3,v 1.5 2004/10/07 15:37:43 dkf Exp $
'\" 
.so man.macros
.TH Tcl_BooleanObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- manipulate Tcl objects as boolean values
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewBooleanObj\fR(\fIboolValue\fR)
.sp
\fBTcl_SetBooleanObj\fR(\fIobjPtr, boolValue\fR)
.sp
int
\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp boolValue in/out
.AP int boolValue in
Integer value used to initialize or set a boolean object.
If the integer is nonzero, the boolean object is set to 1;
otherwise the boolean object is set to 0.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetBooleanObj\fR, this points to the object to be converted
to boolean type.
For \fBTcl_GetBooleanFromObj\fR, this refers to the object
from which to get a boolean value; 
if \fIobjPtr\fR does not already point to a boolean object,
an attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP int *boolPtr out
Points to place where \fBTcl_GetBooleanFromObj\fR
stores the boolean value (0 or 1) obtained from \fIobjPtr\fR.
.BE

.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
boolean Tcl objects from C code.
\fBTcl_NewBooleanObj\fR and \fBTcl_SetBooleanObj\fR
will create a new object of boolean type
or modify an existing object to have boolean type. 
Both of these procedures set the object to have the
boolean value (0 or 1) specified by \fIboolValue\fR;
if \fIboolValue\fR is nonzero, the object is set to 1,
otherwise to 0.
\fBTcl_NewBooleanObj\fR returns a pointer to a newly created object

with reference count zero.

Both procedures set the object's type to be boolean

and assign the boolean value to the object's internal representation


\fIlongValue\fR member.


\fBTcl_SetBooleanObj\fR invalidates any old string representation


and, if the object is not already a boolean object,










frees any old internal representation.



.PP
\fBTcl_GetBooleanFromObj\fR attempts to return a boolean value
from the Tcl object \fIobjPtr\fR.
If the object is not already a boolean object,
it will attempt to convert it to one.
If an error occurs during conversion, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.

Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR
and stores the boolean value in the address given by \fIboolPtr\fR.
If the object is not already a boolean object,
the conversion will free any old internal representation.
Objects having a string representation equal to any of \fB0\fR,
\fBfalse\fR, \fBno\fR, or \fBoff\fR have a boolean value 0; if the
string representation is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or
\fBon\fR the boolean value is 1.
Any of these string values may be abbreviated, and upper-case spellings
are also acceptable.


.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult

.SH KEYWORDS
boolean, boolean object, boolean type, internal representation, object, object type, string representation


>




|


|


|














|
<
<

|
<
<
|
<
<

|









|
|
|
|
<
<
|
<
|
|
>
|
>
|
>
|
>
>
|
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>

|
|
|
<
<
<
|
>
|
|
<
<
<
<
<
|
<
<
>


|


|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29


30
31


32


33
34
35
36
37
38
39
40
41
42
43
44
45
46
47


48

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83



84
85
86
87





88


89
90
91
92
93
94
95
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\" Contributions from Don Porter, NIST, 2005.  (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: BoolObj.3,v 1.5.2.2 2005/05/21 15:10:25 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewBooleanObj\fR(\fIboolValue\fR)
.sp
\fBTcl_SetBooleanObj\fR(\fIobjPtr, boolValue\fR)
.sp
int
\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp boolValue in/out
.AP int boolValue in
Integer value to be stored as a boolean value in a Tcl_Obj.


.AP Tcl_Obj *objPtr in/out
Points to the Tcl_Obj in which to store, or from which to


retrieve a boolean value.


.AP Tcl_Interp *interp in/out
If a boolean value cannot be retrieved,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP int *boolPtr out
Points to place where \fBTcl_GetBooleanFromObj\fR
stores the boolean value (0 or 1) obtained from \fIobjPtr\fR.
.BE

.SH DESCRIPTION
.PP
These procedures are used to pass boolean values to and from
Tcl as Tcl_Obj's.  When storing a boolean value into a Tcl_Obj,
any non-zero integer value in \fIboolValue\fR is taken to be
the boolean value \fB1\fR, and the integer value \fB0\fR is


taken to be the boolean value \fB0\fR.

.PP
\fBTcl_NewBooleanObj\fR creates a new Tcl_Obj, stores the boolean
value \fIboolValue\fR in it, and returns a pointer to the new Tcl_Obj.
The new Tcl_Obj has reference count of zero.
.PP
\fBTcl_SetBooleanObj\fR accepts \fIobjPtr\fR, a pointer to
an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR 
the boolean value \fIboolValue\fR.  This is a write operation
on \fI*objPtr\fR, so \fIobjPtr\fR must be unshared.  Attempts to
write to a shared Tcl_Obj will panic.  A successful write
of \fIboolValue\fR into \fI*objPtr\fR implies the freeing of
any former value stored in \fI*objPtr\fR.
.PP
\fBTcl_GetBooleanFromObj\fR attempts to retrive a boolean value
from the value stored in \fI*objPtr\fR.
If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR,
then the recognized boolean value is written at the address given
by \fIboolPtr\fR.  
If \fIobjPtr\fR holds any value recognized as
a number by Tcl, then if that value is zero a 0 is written at
the address given by \fIboolPtr\fR and if that
value is non-zero a 1 is written at the address given by \fIboolPtr\fR.
In all cases where a value is written at the address given
by \fIboolPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR.
If the value of \fIobjPtr\fR does not meet any of the conditions
above, then \fBTCL_ERROR\fR is returned and an error message is 
left in the interpreter's result unless \fIinterp\fR is NULL.
\fBTcl_GetBooleanFromObj\fR may also make changes to the internal
fields of \fI*objPtr\fR so that future calls to 
\fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be
performed more efficiently.
.PP
Note that the routines \fBTcl_GetBooleanFromObj\fR and
\fBTcl_GetBoolean\fR are not functional equivalents.
The set of values for which \fBTcl_GetBooleanFromObj\fR



will return \fBTCL_OK\fR is strictly larger than
the set of values for which \fBTcl_GetBoolean\fR will do the same.
For example, the value "5" passed to \fBTcl_GetBooleanFromObj\fR
will lead to a \fBTCL_OK\fR return (and the boolean value 1),





while the same value passed to \fBTcl_GetBoolean\fR will lead to


a \fBTCL_ERROR\fR return.

.SH "SEE ALSO"
Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean

.SH KEYWORDS
boolean, object

Changes to doc/Concat.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Concat.3,v 1.7 2004/10/07 15:15:35 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Concat \- concatenate a collection of strings
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Concat.3,v 1.7.2.1 2005/04/10 23:14:39 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Concat \- concatenate a collection of strings
.SH SYNOPSIS
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
.PP
\fBTcl_Concat\fR eliminates leading and trailing white space as it
copies strings from \fBargv\fR to the result.  If an element of
\fBargv\fR consists of nothing but white space, then that string
is ignored entirely.  This white-space removal was added to make
the output of the \fBconcat\fR command cleaner-looking.
.PP
.VS
The result string is dynamically allocated
using \fBTcl_Alloc\fR;  the caller must eventually release the space
by calling \fBTcl_Free\fR.
.VE
.VS
.SH "SEE ALSO"
Tcl_ConcatObj
.SH KEYWORDS
concatenate, strings







<



<
<




40
41
42
43
44
45
46

47
48
49


50
51
52
53
.PP
\fBTcl_Concat\fR eliminates leading and trailing white space as it
copies strings from \fBargv\fR to the result.  If an element of
\fBargv\fR consists of nothing but white space, then that string
is ignored entirely.  This white-space removal was added to make
the output of the \fBconcat\fR command cleaner-looking.
.PP

The result string is dynamically allocated
using \fBTcl_Alloc\fR;  the caller must eventually release the space
by calling \fBTcl_Free\fR.


.SH "SEE ALSO"
Tcl_ConcatObj
.SH KEYWORDS
concatenate, strings

Changes to doc/CrtChannel.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1997-2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtChannel.3,v 1.24 2004/11/12 09:01:25 das Exp $
.so man.macros
.TH Tcl_CreateChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Channel
\fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR)
.sp
ClientData
\fBTcl_GetChannelInstanceData\fR(\fIchannel\fR)
.sp
Tcl_ChannelType *
\fBTcl_GetChannelType\fR(\fIchannel\fR)
.sp
const char *
\fBTcl_GetChannelName\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR)
.sp
.VS 8.4
Tcl_ThreadId
\fBTcl_GetChannelThread\fR(\fIchannel\fR)
.VE 8.4
.sp
int
\fBTcl_GetChannelMode\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR)
.sp
\fBTcl_NotifyChannel\fR(\fIchannel, mask\fR)
.sp
int
\fBTcl_BadChannelOption\fR(\fIinterp, optionName, optionList\fR)
.VS 8.4
.sp
int
\fBTcl_IsChannelShared\fR(\fIchannel\fR)
.sp
int
\fBTcl_IsChannelRegistered\fR(\fIinterp, channel\fR)
.sp
int
\fBTcl_IsChannelExisting\fR(\fIchannelName\fR)
.sp
void
\fBTcl_CutChannel\fR(\fIchannel\fR)
.sp
void
\fBTcl_SpliceChannel\fR(\fIchannel\fR)
.sp
void
\fBTcl_ClearChannelHandlers\fR(\fIchannel\fR)
.VE 8.4
.sp
int
\fBTcl_ChannelBuffered\fR(\fIchannel\fR)
.sp
const char *
\fBTcl_ChannelName\fR(\fItypePtr\fR)
.sp







|

|



|



















<


<













<


















<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35

36
37
38
39
40
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1997-2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtChannel.3,v 1.24.2.5 2005/10/08 13:44:37 dgp Exp $
.so man.macros
.TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Channel
\fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR)
.sp
ClientData
\fBTcl_GetChannelInstanceData\fR(\fIchannel\fR)
.sp
Tcl_ChannelType *
\fBTcl_GetChannelType\fR(\fIchannel\fR)
.sp
const char *
\fBTcl_GetChannelName\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR)
.sp

Tcl_ThreadId
\fBTcl_GetChannelThread\fR(\fIchannel\fR)

.sp
int
\fBTcl_GetChannelMode\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR)
.sp
\fBTcl_NotifyChannel\fR(\fIchannel, mask\fR)
.sp
int
\fBTcl_BadChannelOption\fR(\fIinterp, optionName, optionList\fR)

.sp
int
\fBTcl_IsChannelShared\fR(\fIchannel\fR)
.sp
int
\fBTcl_IsChannelRegistered\fR(\fIinterp, channel\fR)
.sp
int
\fBTcl_IsChannelExisting\fR(\fIchannelName\fR)
.sp
void
\fBTcl_CutChannel\fR(\fIchannel\fR)
.sp
void
\fBTcl_SpliceChannel\fR(\fIchannel\fR)
.sp
void
\fBTcl_ClearChannelHandlers\fR(\fIchannel\fR)

.sp
int
\fBTcl_ChannelBuffered\fR(\fIchannel\fR)
.sp
const char *
\fBTcl_ChannelName\fR(\fItypePtr\fR)
.sp
92
93
94
95
96
97
98
99
100
101







102
103
104
105
106
107
108
109
.sp
Tcl_DriverOutputProc *
\fBTcl_ChannelOutputProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverSeekProc *
\fBTcl_ChannelSeekProc\fR(\fItypePtr\fR)
.sp
.VS 8.4
Tcl_DriverWideSeekProc *
\fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR)







.VE 8.4
.sp
Tcl_DriverSetOptionProc *
\fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverGetOptionProc *
\fBTcl_ChannelGetOptionProc\fR(\fItypePtr\fR)
.sp







<


>
>
>
>
>
>
>
|







88
89
90
91
92
93
94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
.sp
Tcl_DriverOutputProc *
\fBTcl_ChannelOutputProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverSeekProc *
\fBTcl_ChannelSeekProc\fR(\fItypePtr\fR)
.sp

Tcl_DriverWideSeekProc *
\fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverThreadActionProc *
\fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR)
.sp
.VS 8.5
Tcl_DriverTruncateProc *
\fBTcl_ChannelTruncateProc\fR(\fItypePtr\fR)
.VE 8.5
.sp
Tcl_DriverSetOptionProc *
\fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverGetOptionProc *
\fBTcl_ChannelGetOptionProc\fR(\fItypePtr\fR)
.sp
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
\fBTcl_GetChannelHandle\fR places the OS-specific device handle
associated with \fIchannel\fR for the given \fIdirection\fR in the
location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR.  If
the channel does not have a device handle for the specified direction,
then \fBTCL_ERROR\fR is returned instead.  Different channel drivers
will return different types of handle.  Refer to the manual entries
for each driver to determine what type of handle is returned.
.VS 8.4
.PP
\fBTcl_GetChannelThread\fR returns the id of the thread currently managing
the specified \fIchannel\fR. This allows channel drivers to send their file
events to the correct event queue even for a multi-threaded core.
.VE 8.4
.PP
\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.
.PP
\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
allocated to store input or output in \fIchannel\fR. If the value was not set







<




<







233
234
235
236
237
238
239

240
241
242
243

244
245
246
247
248
249
250
\fBTcl_GetChannelHandle\fR places the OS-specific device handle
associated with \fIchannel\fR for the given \fIdirection\fR in the
location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR.  If
the channel does not have a device handle for the specified direction,
then \fBTCL_ERROR\fR is returned instead.  Different channel drivers
will return different types of handle.  Refer to the manual entries
for each driver to determine what type of handle is returned.

.PP
\fBTcl_GetChannelThread\fR returns the id of the thread currently managing
the specified \fIchannel\fR. This allows channel drivers to send their file
events to the correct event queue even for a multi-threaded core.

.PP
\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.
.PP
\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
allocated to store input or output in \fIchannel\fR. If the value was not set
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292





293
294
295
296





297
298
299
300
301
302
303
304
305
306
307
308
error message.
.PP
\fBTcl_ChannelBuffered\fR returns the number of bytes of input
currently buffered in the internal buffer (push back area) of the
channel itself. It does not report about the data in the overall
buffers for the stack of channels the supplied channel is part of.
.PP
.VS 8.4
\fBTcl_IsChannelShared\fR checks the refcount of the specified
\fIchannel\fR and returns whether the \fIchannel\fR was shared among
multiple interpreters (result == 1) or not (result == 0).
.PP
\fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is
registered in the given \fIinterp\fRreter (result == 1) or not
(result == 0).
.PP
\fBTcl_IsChannelExisting\fR checks whether a channel with the specified
name is registered in the (thread)-global list of all channels (result
== 1) or not (result == 0).
.PP
\fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the
(thread)global list of all channels (of the current thread).
Application to a channel still registered in some interpreter
is not allowed.





.PP
\fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the
(thread)global list of all channels (of the current thread).
Application to a channel registered in some interpreter is not allowed.





.PP
\fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event
scripts associated with the specified \fIchannel\fR, thus shutting
down all event processing for this channel.
.VE 8.4
.SH TCL_CHANNELTYPE
.PP
A channel driver provides a \fBTcl_ChannelType\fR structure that contains
pointers to functions that implement the various operations on a channel;
these operations are invoked as needed by the generic layer.  The structure
was versioned starting in Tcl 8.3.2/8.4 to correct a problem with stacked
channel drivers.  See the \fBOLD CHANNEL TYPES\fR section below for







<
















>
>
>
>
>




>
>
>
>
>




<







269
270
271
272
273
274
275

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309

310
311
312
313
314
315
316
error message.
.PP
\fBTcl_ChannelBuffered\fR returns the number of bytes of input
currently buffered in the internal buffer (push back area) of the
channel itself. It does not report about the data in the overall
buffers for the stack of channels the supplied channel is part of.
.PP

\fBTcl_IsChannelShared\fR checks the refcount of the specified
\fIchannel\fR and returns whether the \fIchannel\fR was shared among
multiple interpreters (result == 1) or not (result == 0).
.PP
\fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is
registered in the given \fIinterp\fRreter (result == 1) or not
(result == 0).
.PP
\fBTcl_IsChannelExisting\fR checks whether a channel with the specified
name is registered in the (thread)-global list of all channels (result
== 1) or not (result == 0).
.PP
\fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the
(thread)global list of all channels (of the current thread).
Application to a channel still registered in some interpreter
is not allowed.
.VS 8.5
Also notifies the driver if the \fBTcl_ChannelType\fR version is
\fBTCL_CHANNEL_VERSION_4\fR (or higher), and
\fBTcl_DriverThreadActionProc\fR is defined for it.
.VE 8.5
.PP
\fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the
(thread)global list of all channels (of the current thread).
Application to a channel registered in some interpreter is not allowed.
.VS 8.5
Also notifies the driver if the \fBTcl_ChannelType\fR version is
\fBTCL_CHANNEL_VERSION_4\fR (or higher), and
\fBTcl_DriverThreadActionProc\fR is defined for it.
.VE 8.5
.PP
\fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event
scripts associated with the specified \fIchannel\fR, thus shutting
down all event processing for this channel.

.SH TCL_CHANNELTYPE
.PP
A channel driver provides a \fBTcl_ChannelType\fR structure that contains
pointers to functions that implement the various operations on a channel;
these operations are invoked as needed by the generic layer.  The structure
was versioned starting in Tcl 8.3.2/8.4 to correct a problem with stacked
channel drivers.  See the \fBOLD CHANNEL TYPES\fR section below for
322
323
324
325
326
327
328




329
330
331
332

333
334

335
336
337
338
339
340
341
342
343
344
345
346

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367

368



369




370
371
372
373
374
375

376
377
378

379
380
381
382
383
384
385
        Tcl_DriverWatchProc *\fIwatchProc\fR;
        Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
        Tcl_DriverClose2Proc *\fIclose2Proc\fR;
        Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
        Tcl_DriverFlushProc *\fIflushProc\fR;
        Tcl_DriverHandlerProc *\fIhandlerProc\fR;
        Tcl_DriverWideSeekProc *\fIwideSeekProc\fR;




} Tcl_ChannelType;
.CE
.PP
The driver must provide implementations for all functions except

\fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR,
\fIgetOptionProc\fR, and \fIclose2Proc\fR, which may be specified as

NULL.  Other functions that can not be implemented for this type of
device should return \fBEINVAL\fR when invoked to indicate that they
are not implemented, except in the case of \fIflushProc\fR and
\fIhandlerProc\fR, which should specified as NULL if not otherwise defined.
.PP
The user should only use the above structure for \fBTcl_ChannelType\fR
instantiation.  When referencing fields in a \fBTcl_ChannelType\fR
structure, the following functions should be used to obtain the values:
\fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR,
\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR,
\fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR,
\fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR,

.VS 8.4
\fBTcl_ChannelWideSeekProc\fR,
.VE 8.4
\fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR,
\fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR,
\fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR.
.PP
The change to the structures was made in such a way that standard channel
types are binary compatible.  However, channel types that use stacked
channels (i.e. TLS, Trf) have new versions to correspond to the above change
since the previous code for stacked channels had problems.
.SS TYPENAME
.PP
The \fItypeName\fR field contains a null-terminated string that
identifies the type of the device implemented by this driver, e.g.
\fBfile\fR or \fBsocket\fR.
.PP
This value can be retrieved with \fBTcl_ChannelName\fR, which returns
a pointer to the string.
.SS VERSION
.PP

The \fIversion\fR field should be set to \fBTCL_CHANNEL_VERSION_2\fR.



If it is not set to this value \fBTCL_CHANNEL_VERSION_3\fR, then this




\fBTcl_ChannelType\fR is assumed to have the older structure.  See
\fBOLD CHANNEL TYPES\fR for more details.  While Tcl will recognize
and function with either structure, stacked channels must be of at
least \fBTCL_CHANNEL_VERSION_2\fR to function correctly.
.PP
This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns

.VS 8.4
one of \fBTCL_CHANNEL_VERSION_3\fR,
.VE 8.4

\fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR.
.SS BLOCKMODEPROC
.PP
The \fIblockModeProc\fR field contains the address of a function called by
the generic layer to set blocking and nonblocking mode on the device.
\fIBlockModeProc\fR should match the following prototype:
.PP







>
>
>
>



|
>
|
|
>
|
|
|
|








>
|
|
|


















>
|
>
>
>
|
>
>
>
>
|

|



>
|
|
|
>







330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
        Tcl_DriverWatchProc *\fIwatchProc\fR;
        Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
        Tcl_DriverClose2Proc *\fIclose2Proc\fR;
        Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
        Tcl_DriverFlushProc *\fIflushProc\fR;
        Tcl_DriverHandlerProc *\fIhandlerProc\fR;
        Tcl_DriverWideSeekProc *\fIwideSeekProc\fR;
        Tcl_DriverThreadActionProc *\fIthreadActionProc\fR;
.VS 8.5
        Tcl_DriverTruncateProc *\fItruncateProc\fR;
.VE 8.5
} Tcl_ChannelType;
.CE
.PP
It is not necessary to provide implementations for all channel
operations.  Those which are not necessary may be set to NULL in the
struct: \fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR,
\fIgetOptionProc\fR, and \fIclose2Proc\fR, in addition to
\fIflushProc\fR, \fIhandlerProc\fR, \fIthreadActionProc\fR, and
\fItruncateProc\fR.  Other functions that cannot be implemented in a
meaningful way should return \fBEINVAL\fR when called, to indicate
that the operations they represent are not available. Also note that
\fIwideSeekProc\fR can be NULL if \fIseekProc\fR is.
.PP
The user should only use the above structure for \fBTcl_ChannelType\fR
instantiation.  When referencing fields in a \fBTcl_ChannelType\fR
structure, the following functions should be used to obtain the values:
\fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR,
\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR,
\fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR,
\fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR,
\fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR,
.VS 8.5
\fBTcl_ChannelTruncateProc\fR,
.VE 8.5
\fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR,
\fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR,
\fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR.
.PP
The change to the structures was made in such a way that standard channel
types are binary compatible.  However, channel types that use stacked
channels (i.e. TLS, Trf) have new versions to correspond to the above change
since the previous code for stacked channels had problems.
.SS TYPENAME
.PP
The \fItypeName\fR field contains a null-terminated string that
identifies the type of the device implemented by this driver, e.g.
\fBfile\fR or \fBsocket\fR.
.PP
This value can be retrieved with \fBTcl_ChannelName\fR, which returns
a pointer to the string.
.SS VERSION
.PP

The \fIversion\fR field should be set to the version of the structure
that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended.
\fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member.
.VS 8.5
\fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the
\fIthreadActionProc\fR and \fItruncateProc\fR members (includes
\fIwideSeekProc\fR).
.VE 8.5
If it is not set to any of these, then this
\fBTcl_ChannelType\fR is assumed to have the original structure.  See
\fBOLD CHANNEL TYPES\fR for more details.  While Tcl will recognize
and function with either structures, stacked channels must be of at
least \fBTCL_CHANNEL_VERSION_2\fR to function correctly.
.PP
This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns
one of
.VS 8.5
\fBTCL_CHANNEL_VERSION_4\fR,
.VE 8.5
\fBTCL_CHANNEL_VERSION_3\fR,
\fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR.
.SS BLOCKMODEPROC
.PP
The \fIblockModeProc\fR field contains the address of a function called by
the generic layer to set blocking and nonblocking mode on the device.
\fIBlockModeProc\fR should match the following prototype:
.PP
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
function should set this variable to a POSIX error code if an error occurs.
The function should store an \fBEINVAL\fR error code if the channel type
does not implement seeking.
.PP
The return value is the new access point or -1 in case of error. If an
error occurred, the function should not move the access point.
.PP
.VS 8.4
If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR
field may contain the address of an alternative function to use which
handles wide (i.e. larger than 32-bit) offsets, so allowing seeks
within files larger than 2GB.  The \fIwideSeekProc\fR will be called
in preference to the \fIseekProc\fR, but both must be defined if the
\fIwideSeekProc\fR is defined.  \fIWideSeekProc\fR must match the
following prototype:







<







597
598
599
600
601
602
603

604
605
606
607
608
609
610
function should set this variable to a POSIX error code if an error occurs.
The function should store an \fBEINVAL\fR error code if the channel type
does not implement seeking.
.PP
The return value is the new access point or -1 in case of error. If an
error occurred, the function should not move the access point.
.PP

If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR
field may contain the address of an alternative function to use which
handles wide (i.e. larger than 32-bit) offsets, so allowing seeks
within files larger than 2GB.  The \fIwideSeekProc\fR will be called
in preference to the \fIseekProc\fR, but both must be defined if the
\fIwideSeekProc\fR is defined.  \fIWideSeekProc\fR must match the
following prototype:
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
\fIseekProc\fR above, except that the type of offsets and the return
type are different.
.PP
The \fIseekProc\fR value can be retrieved with
\fBTcl_ChannelSeekProc\fR, which returns a pointer to the function,
and similarly the \fIwideSeekProc\fR can be retrieved with
\fBTcl_ChannelWideSeekProc\fR.
.VE 8.4
.SS SETOPTIONPROC
.PP
The \fIsetOptionProc\fR field contains the address of a function called by
the generic layer to set a channel type specific option on a channel.
\fIsetOptionProc\fR must match the following prototype:
.PP
.CS







<







621
622
623
624
625
626
627

628
629
630
631
632
633
634
\fIseekProc\fR above, except that the type of offsets and the return
type are different.
.PP
The \fIseekProc\fR value can be retrieved with
\fBTcl_ChannelSeekProc\fR, which returns a pointer to the function,
and similarly the \fIwideSeekProc\fR can be retrieved with
\fBTcl_ChannelWideSeekProc\fR.

.SS SETOPTIONPROC
.PP
The \fIsetOptionProc\fR field contains the address of a function called by
the generic layer to set a channel type specific option on a channel.
\fIsetOptionProc\fR must match the following prototype:
.PP
.CS
771
772
773
774
775
776
777















































778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created.  The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
.PP
This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns
a pointer to the function.















































.SH TCL_BADCHANNELOPTION
.PP
This procedure generates a "bad option" error message in an
(optional) interpreter.  It is used by channel drivers when 
an invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
the generic options error message string.
.PP
It always return \fBTCL_ERROR\fR
.PP
An error message is generated in \fIinterp\fR's result object to
indicate that a command was invoked with a bad option.
The message has the form
.CS
    bad option "blah": should be one of 
    <...generic options...>+<...specific options...>







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created.  The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
.PP
This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns
a pointer to the function.

.SS "THREADACTIONPROC"
.PP
The \fIthreadActionProc\fR field contains the address of the function
called by the generic layer when a channel is created, closed, or
going to move to a different thread, i.e. whenever thread-specific
driver state might have to initialized or updated. It can be NULL.
The action \fITCL_CHANNEL_THREAD_REMOVE\fR is used to notify the
driver that it should update or remove any thread-specific data it
might be maintaining for the channel.
.PP
The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the
driver that it should update or initialize any thread-specific data it
might be maintaining using the calling thread as the associate. See
\fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail.
.PP
.CS
typedef void Tcl_DriverThreadActionProc(
        ClientData \fIinstanceData\fR,
        int        \fIaction\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created.
.PP
These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR,
which returns a pointer to the function.
.SS "TRUNCATEPROC"
.PP
The \fItruncateProc\fR field contains the address of the function
called by the generic layer when a channel is truncated to some
length. It can be NULL.
.PP
.CS
typedef int Tcl_DriverTruncateProc(
        ClientData \fIinstanceData\fR,
        Tcl_WideInt \fIlength\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created, and
\fIlength\fR is the new length of the underlying file, which should
not be negative. The result should be 0 on success or an errno code
(suitable for use with \fBTcl_SetErrno\fR) on failure.
.PP
These values can be retrieved with \fBTcl_ChannelTruncateProc\fR,
which returns a pointer to the function.
.SH TCL_BADCHANNELOPTION
.PP
This procedure generates a "bad option" error message in an
(optional) interpreter.  It is used by channel drivers when 
an invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
the generic options error message string.
.PP
It always returns \fBTCL_ERROR\fR
.PP
An error message is generated in \fIinterp\fR's result object to
indicate that a command was invoked with a bad option.
The message has the form
.CS
    bad option "blah": should be one of 
    <...generic options...>+<...specific options...>
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853

854
855
856
857
858
859
860
861
862
863
864
865
.PP
It is still possible to create channel with the above structure.  The
internal channel code will determine the version.  It is imperative to use
the new \fBTcl_ChannelType\fR structure if you are creating a stacked
channel driver, due to problems with the earlier stacked channel
implementation (in 8.2.0 to 8.3.1).
.PP
.VS 8.4
Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part
of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure
contained the following fields:
.PP
.CS
typedef struct Tcl_ChannelType {
        char *\fItypeName\fR;
        Tcl_ChannelTypeVersion \fIversion\fR;
        Tcl_DriverCloseProc *\fIcloseProc\fR;
        Tcl_DriverInputProc *\fIinputProc\fR;
        Tcl_DriverOutputProc *\fIoutputProc\fR;
        Tcl_DriverSeekProc *\fIseekProc\fR;
        Tcl_DriverSetOptionProc *\fIsetOptionProc\fR;
        Tcl_DriverGetOptionProc *\fIgetOptionProc\fR;
        Tcl_DriverWatchProc *\fIwatchProc\fR;
        Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
        Tcl_DriverClose2Proc *\fIclose2Proc\fR;
        Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
        Tcl_DriverFlushProc *\fIflushProc\fR;
        Tcl_DriverHandlerProc *\fIhandlerProc\fR;

} Tcl_ChannelType;
.CE
.PP
When the above structure is registered as a channel type, the
\fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR.
.VE 8.4

.SH "SEE ALSO"
Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3)

.SH KEYWORDS
blocking, channel driver, channel registration, channel type, nonblocking







<




















>





<






896
897
898
899
900
901
902

903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928

929
930
931
932
933
934
.PP
It is still possible to create channel with the above structure.  The
internal channel code will determine the version.  It is imperative to use
the new \fBTcl_ChannelType\fR structure if you are creating a stacked
channel driver, due to problems with the earlier stacked channel
implementation (in 8.2.0 to 8.3.1).
.PP

Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part
of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure
contained the following fields:
.PP
.CS
typedef struct Tcl_ChannelType {
        char *\fItypeName\fR;
        Tcl_ChannelTypeVersion \fIversion\fR;
        Tcl_DriverCloseProc *\fIcloseProc\fR;
        Tcl_DriverInputProc *\fIinputProc\fR;
        Tcl_DriverOutputProc *\fIoutputProc\fR;
        Tcl_DriverSeekProc *\fIseekProc\fR;
        Tcl_DriverSetOptionProc *\fIsetOptionProc\fR;
        Tcl_DriverGetOptionProc *\fIgetOptionProc\fR;
        Tcl_DriverWatchProc *\fIwatchProc\fR;
        Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
        Tcl_DriverClose2Proc *\fIclose2Proc\fR;
        Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
        Tcl_DriverFlushProc *\fIflushProc\fR;
        Tcl_DriverHandlerProc *\fIhandlerProc\fR;
        Tcl_DriverTruncateProc *\fItruncateProc\fR;
} Tcl_ChannelType;
.CE
.PP
When the above structure is registered as a channel type, the
\fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR.


.SH "SEE ALSO"
Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3)

.SH KEYWORDS
blocking, channel driver, channel registration, channel type, nonblocking

Changes to doc/CrtCommand.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtCommand.3,v 1.10 2004/10/07 15:15:35 dkf Exp $
'\" 
.so man.macros
.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateCommand \- implement new commands in C
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtCommand.3,v 1.10.2.1 2005/04/10 23:14:40 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateCommand \- implement new commands in C
.SH SYNOPSIS
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
data structure that describes what to do when the command procedure
is invoked.  \fIArgc\fR and \fIargv\fR describe the arguments to
the command, \fIargc\fR giving the number of arguments (including
the command name) and \fIargv\fR giving the values of the arguments
as strings.  The \fIargv\fR array will contain \fIargc\fR+1 values;
the first \fIargc\fR values point to the argument strings, and the
last value is NULL.  
.VS
Note that the argument strings should not be modified as they may
point to constant strings or may be shared with other parts of the
interpreter.
.VE
.PP
.VS
Note that the argument strings are encoded in normalized UTF-8 since
version 8.1 of Tcl.
.VE
.PP
\fIProc\fR must return an integer code that is expected to be one of
\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or
\fBTCL_CONTINUE\fR.  See the Tcl overview man page
for details on what these codes mean.  Most normal commands will only
return \fBTCL_OK\fR or \fBTCL_ERROR\fR.  In addition, \fIproc\fR must set
the interpreter result to point to a string value;







<



<

<


<







91
92
93
94
95
96
97

98
99
100

101

102
103

104
105
106
107
108
109
110
data structure that describes what to do when the command procedure
is invoked.  \fIArgc\fR and \fIargv\fR describe the arguments to
the command, \fIargc\fR giving the number of arguments (including
the command name) and \fIargv\fR giving the values of the arguments
as strings.  The \fIargv\fR array will contain \fIargc\fR+1 values;
the first \fIargc\fR values point to the argument strings, and the
last value is NULL.  

Note that the argument strings should not be modified as they may
point to constant strings or may be shared with other parts of the
interpreter.

.PP

Note that the argument strings are encoded in normalized UTF-8 since
version 8.1 of Tcl.

.PP
\fIProc\fR must return an integer code that is expected to be one of
\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or
\fBTCL_CONTINUE\fR.  See the Tcl overview man page
for details on what these codes mean.  Most normal commands will only
return \fBTCL_OK\fR or \fBTCL_ERROR\fR.  In addition, \fIproc\fR must set
the interpreter result to point to a string value;

Changes to doc/CrtFileHdlr.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
'\"
'\" Copyright (c) 1990-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtFileHdlr.3,v 1.3 2004/10/07 14:44:31 dkf Exp $
'\" 
.so man.macros
.TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only)
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.VS
.sp
\fBTcl_CreateFileHandler\fR(\fIfd, mask, proc, clientData\fR)
.sp
\fBTcl_DeleteFileHandler\fR(\fIfd\fR)
.VE
.SH ARGUMENTS
.AS Tcl_FileProc clientData
.AP int fd in
Unix file descriptor for an open file or device.
.AP int mask in
Conditions under which \fIproc\fR should be called:
OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR,
and \fBTCL_EXCEPTION\fR.  May be set to 0 to temporarily disable
a handler.
.AP Tcl_FileProc *proc in
Procedure to invoke whenever the file or device indicated
by \fIfile\fR meets the conditions specified by \fImask\fR.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE

.SH DESCRIPTION
.PP
.VS
\fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be
invoked in the future whenever I/O becomes possible on a file
or an exceptional condition exists for the file.  The file
is indicated by \fIfd\fR, and the conditions of interest
.VE
are indicated by \fImask\fR.  For example, if \fImask\fR
is \fBTCL_READABLE\fR, \fIproc\fR will be called when
the file is readable.
The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so
\fBTcl_CreateFileHandler\fR is only useful in programs that dispatch
events through \fBTcl_DoOneEvent\fR or through Tcl commands such
as \fBvwait\fR.







|









<




<


















<




<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

40
41
42
43

44
45
46
47
48
49
50
'\"
'\" Copyright (c) 1990-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtFileHdlr.3,v 1.3.2.1 2005/04/10 23:14:41 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only)
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR

.sp
\fBTcl_CreateFileHandler\fR(\fIfd, mask, proc, clientData\fR)
.sp
\fBTcl_DeleteFileHandler\fR(\fIfd\fR)

.SH ARGUMENTS
.AS Tcl_FileProc clientData
.AP int fd in
Unix file descriptor for an open file or device.
.AP int mask in
Conditions under which \fIproc\fR should be called:
OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR,
and \fBTCL_EXCEPTION\fR.  May be set to 0 to temporarily disable
a handler.
.AP Tcl_FileProc *proc in
Procedure to invoke whenever the file or device indicated
by \fIfile\fR meets the conditions specified by \fImask\fR.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE

.SH DESCRIPTION
.PP

\fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be
invoked in the future whenever I/O becomes possible on a file
or an exceptional condition exists for the file.  The file
is indicated by \fIfd\fR, and the conditions of interest

are indicated by \fImask\fR.  For example, if \fImask\fR
is \fBTCL_READABLE\fR, \fIproc\fR will be called when
the file is readable.
The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so
\fBTcl_CreateFileHandler\fR is only useful in programs that dispatch
events through \fBTcl_DoOneEvent\fR or through Tcl commands such
as \fBvwait\fR.
85
86
87
88
89
90
91
92
93
94
95
96
97
98
correctly, the application may need to use non-blocking I/O operations on
the files for which handlers are declared.  Otherwise the application may
block if it reads or writes too much data; while waiting for the I/O to
complete the application won't be able to service other events. Use
\fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into
blocking or nonblocking mode as required.
.PP
.VS
Note that these interfaces are only supported by the Unix
implementation of the Tcl notifier.   
.VE

.SH KEYWORDS
callback, file, handler







<


<



81
82
83
84
85
86
87

88
89

90
91
92
correctly, the application may need to use non-blocking I/O operations on
the files for which handlers are declared.  Otherwise the application may
block if it reads or writes too much data; while waiting for the I/O to
complete the application won't be able to service other events. Use
\fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into
blocking or nonblocking mode as required.
.PP

Note that these interfaces are only supported by the Unix
implementation of the Tcl notifier.   


.SH KEYWORDS
callback, file, handler

Changes to doc/CrtMathFnc.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtMathFnc.3,v 1.11 2004/10/07 15:15:35 dkf Exp $
'\" 
.so man.macros
.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
void
\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR)
.sp
.VS 8.4
int
\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr,
                    clientDataPtr\fR)
.sp
Tcl_Obj *
\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR)
.VE
.SH ARGUMENTS
.AS Tcl_ValueType *clientDataPtr out
.AP Tcl_Interp *interp in
Interpreter in which new function will be defined.
.AP "const char" *name in
Name for new function.
.AP int numArgs in







|













<






<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27

28
29
30
31
32
33
34
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtMathFnc.3,v 1.11.2.2 2005/04/25 19:59:45 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
void
\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR)
.sp

int
\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr,
                    clientDataPtr\fR)
.sp
Tcl_Obj *
\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR)

.SH ARGUMENTS
.AS Tcl_ValueType *clientDataPtr out
.AP Tcl_Interp *interp in
Interpreter in which new function will be defined.
.AP "const char" *name in
Name for new function.
.AP int numArgs in
62
63
64
65
66
67
68


69
70





71
72

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

145
146
147



148
149
150
151
152
153
154
155
156
157
158
159
160
passing to \fITcl_StringMatch\fR), or NULL to not apply any filter.
.BE

.SH DESCRIPTION
.PP
Tcl allows a number of mathematical functions to be used in
expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR.


\fBTcl_CreateMathFunc\fR allows applications to add additional functions
to those already provided by Tcl or to replace existing functions.





\fIName\fR is the name of the function as it will appear in expressions.
If \fIname\fR doesn't already exist as a function then a new function

is created.  If it does exist, then the existing function is replaced.
\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function.
Each entry in the \fIargTypes\fR array must be
.VS 8.4
one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR,
or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an
integer, a double-precision floating value, a wide (64-bit) integer,
or any, respectively.
.VE 8.4
.PP
Whenever the function is invoked in an expression Tcl will invoke
\fIproc\fR.  \fIProc\fR should have arguments and result that match
the type \fBTcl_MathProc\fR:
.CS
typedef int Tcl_MathProc(
        ClientData \fIclientData\fR,
        Tcl_Interp *\fIinterp\fR,
        Tcl_Value *\fIargs\fR,
        Tcl_Value *\fIresultPtr\fR);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR.
\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures,
which describe the actual arguments to the function:
.VS 8.4
.CS
typedef struct Tcl_Value {
        Tcl_ValueType \fItype\fR;
        long \fIintValue\fR;
        double \fIdoubleValue\fR;
        Tcl_WideInt \fIwideValue\fR;
} Tcl_Value;
.CE
.PP
The \fItype\fR field indicates the type of the argument and is
one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR.
.VE 8.4
It will match the \fIargTypes\fR value specified for the function unless
the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts
the argument supplied in the expression to the type requested in
\fIargTypes\fR, if that is necessary.
Depending on the value of the \fItype\fR field, the \fIintValue\fR,
.VS 8.4
\fIdoubleValue\fR or \fIwideValue\fR
.VE 8.4
field will contain the actual value of the argument.
.PP
\fIProc\fR should compute its result and store it either as an integer
in \fIresultPtr->intValue\fR or as a floating value in
\fIresultPtr->doubleValue\fR.
It should set also \fIresultPtr->type\fR to one of
.VS 8.4
\fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR
.VE 8.4
to indicate which value was set.
Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR.
If an error occurs while executing the function, \fIproc\fR should
return \fBTCL_ERROR\fR and leave an error message in the interpreter's result.
.PP
.VS 8.4
\fBTcl_GetMathFuncInfo\fR retrieves the values associated with
function \fIname\fR that were passed to a preceding
\fBTcl_CreateMathFunc\fR call.  Normally, the return code is
\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR
is returned and an error message is placed in the interpreter's
result.
.PP
If an error did not occur, the array reference placed in the variable
pointed to by \fIargTypesPtr\fR is newly allocated, and should be
released by passing it to \fBTcl_Free\fR.  Some functions (the
standard set implemented in the core) are implemented directly at the

bytecode level; attempting to retrieve values for them causes a NULL
to be stored in the variable pointed to by \fIprocPtr\fR and the
variable pointed to by \fIclientDataPtr\fR will not be modified.



.PP
\fBTcl_ListMathFuncs\fR returns a Tcl object containing a list of all
the math functions defined in the interpreter whose name matches
\fIpattern\fR.  In the case of an error, NULL is returned and an error
message is left in the interpreter result, and otherwise the returned
object will have a reference count of zero.
.VE

.SH KEYWORDS
expression, mathematical function

.SH "SEE ALSO"
expr(n), info(n), Tcl_Free(3), Tcl_NewListObj(3)







>
>
|

>
>
>
>
>

|
>
|


<




<
















<











<





<

<






<

<





<










|
>
|
|
|
>
>
>






<





|
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101

102
103
104
105
106
107
108
109
110
111
112

113
114
115
116
117

118

119
120
121
122
123
124

125

126
127
128
129
130

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154

155
156
157
158
159
160
passing to \fITcl_StringMatch\fR), or NULL to not apply any filter.
.BE

.SH DESCRIPTION
.PP
Tcl allows a number of mathematical functions to be used in
expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR.
These functions are represented by commands in the namespace,
\fBtcl::mathfunc\fR.  The \fBTcl_CreateMathFunc\fR function is
an obsolete way for applications to add additional functions
to those already provided by Tcl or to replace existing functions.
It should not be used by new applications, which should create
math functions using \fBTcl_CreateObjCommand\fR to create a command
in the \fBtcl::mathfunc\fR namespace.
.PP
In the \fBTcl_CreateMathFunc\fR interface,
\fIName\fR is the name of the function as it will appear in expressions.
If \fIname\fR doesn't already exist in the \fB::tcl::mathfunc\fR
namespace, then a new command is created in that namespace.
If \fIname\fR does exist, then the existing function is replaced.
\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function.
Each entry in the \fIargTypes\fR array must be

one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR,
or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an
integer, a double-precision floating value, a wide (64-bit) integer,
or any, respectively.

.PP
Whenever the function is invoked in an expression Tcl will invoke
\fIproc\fR.  \fIProc\fR should have arguments and result that match
the type \fBTcl_MathProc\fR:
.CS
typedef int Tcl_MathProc(
        ClientData \fIclientData\fR,
        Tcl_Interp *\fIinterp\fR,
        Tcl_Value *\fIargs\fR,
        Tcl_Value *\fIresultPtr\fR);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR.
\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures,
which describe the actual arguments to the function:

.CS
typedef struct Tcl_Value {
        Tcl_ValueType \fItype\fR;
        long \fIintValue\fR;
        double \fIdoubleValue\fR;
        Tcl_WideInt \fIwideValue\fR;
} Tcl_Value;
.CE
.PP
The \fItype\fR field indicates the type of the argument and is
one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR.

It will match the \fIargTypes\fR value specified for the function unless
the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts
the argument supplied in the expression to the type requested in
\fIargTypes\fR, if that is necessary.
Depending on the value of the \fItype\fR field, the \fIintValue\fR,

\fIdoubleValue\fR or \fIwideValue\fR

field will contain the actual value of the argument.
.PP
\fIProc\fR should compute its result and store it either as an integer
in \fIresultPtr->intValue\fR or as a floating value in
\fIresultPtr->doubleValue\fR.
It should set also \fIresultPtr->type\fR to one of

\fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR

to indicate which value was set.
Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR.
If an error occurs while executing the function, \fIproc\fR should
return \fBTCL_ERROR\fR and leave an error message in the interpreter's result.
.PP

\fBTcl_GetMathFuncInfo\fR retrieves the values associated with
function \fIname\fR that were passed to a preceding
\fBTcl_CreateMathFunc\fR call.  Normally, the return code is
\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR
is returned and an error message is placed in the interpreter's
result.
.PP
If an error did not occur, the array reference placed in the variable
pointed to by \fIargTypesPtr\fR is newly allocated, and should be
released by passing it to \fBTcl_Free\fR.  Some functions (the
standard set implemented in the core, and those defined by placing
commands in the \fBtcl::mathfunc\fR namespace) do not have
argument type information; attempting to retrieve values for
them causes a NULL to be stored in the variable pointed to by 
\fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR
will not be modified.  The variable pointed to by \fInumArgsPointer\fR
will contain -1, and no argument types will be stored in the variable
pointed to by \fIargTypesPointer\fR.
.PP
\fBTcl_ListMathFuncs\fR returns a Tcl object containing a list of all
the math functions defined in the interpreter whose name matches
\fIpattern\fR.  In the case of an error, NULL is returned and an error
message is left in the interpreter result, and otherwise the returned
object will have a reference count of zero.


.SH KEYWORDS
expression, mathematical function

.SH "SEE ALSO"
expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3)

Changes to doc/CrtObjCmd.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.11 2004/10/07 15:15:36 dkf Exp $
'\" 
.so man.macros
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.11.2.1 2005/04/10 23:14:41 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C
.SH SYNOPSIS
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
.sp
int
\fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
int
\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
.VS 8.4
int
\fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
.sp
int
\fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
.VE
.sp
.VS 8.4
const char *
.VE
\fBTcl_GetCommandName\fR(\fIinterp, token\fR)
.sp
void
\fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR)
.sp
Tcl_Command
\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)







<





<

<

<







26
27
28
29
30
31
32

33
34
35
36
37

38

39

40
41
42
43
44
45
46
.sp
int
\fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
int
\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp

int
\fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
.sp
int
\fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)

.sp

const char *

\fBTcl_GetCommandName\fR(\fIinterp, token\fR)
.sp
void
\fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR)
.sp
Tcl_Command
\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
\fIproc\fR should have arguments and result that match the type
\fBTcl_ObjCmdProc\fR:
.CS
typedef int Tcl_ObjCmdProc(
        ClientData \fIclientData\fR,
        Tcl_Interp *\fIinterp\fR,
        int \fIobjc\fR,
.VS
        Tcl_Obj *const \fIobjv\fR[]);
.CE
When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters
will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to
\fBTcl_CreateObjCommand\fR.  Typically, \fIclientData\fR points to an
application-specific data structure that describes what to do when the
command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the







<







91
92
93
94
95
96
97

98
99
100
101
102
103
104
\fIproc\fR should have arguments and result that match the type
\fBTcl_ObjCmdProc\fR:
.CS
typedef int Tcl_ObjCmdProc(
        ClientData \fIclientData\fR,
        Tcl_Interp *\fIinterp\fR,
        int \fIobjc\fR,

        Tcl_Obj *const \fIobjv\fR[]);
.CE
When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters
will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to
\fBTcl_CreateObjCommand\fR.  Typically, \fIclientData\fR points to an
application-specific data structure that describes what to do when the
command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
compilers to report any such attempted assignment as an error.  However,
it is acceptable to modify the internal representation of any individual
object argument.  For instance, the user may call
\fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer
representation of that object; that call may change the type of the object
that \fIobjv\fR[\fB2\fR] points at, but will not change where
\fIobjv\fR[\fB2\fR] points.
.VE
.PP
\fIproc\fR must return an integer code that is either \fBTCL_OK\fR,
\fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR.
See the Tcl overview man page
for details on what these codes mean.  Most normal commands will only
return \fBTCL_OK\fR or \fBTCL_ERROR\fR.
In addition, if \fIproc\fR needs to return a non-empty result,







<







116
117
118
119
120
121
122

123
124
125
126
127
128
129
compilers to report any such attempted assignment as an error.  However,
it is acceptable to modify the internal representation of any individual
object argument.  For instance, the user may call
\fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer
representation of that object; that call may change the type of the object
that \fIobjv\fR[\fB2\fR] points at, but will not change where
\fIobjv\fR[\fB2\fR] points.

.PP
\fIproc\fR must return an integer code that is either \fBTCL_OK\fR,
\fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR.
See the Tcl overview man page
for details on what these codes mean.  Most normal commands will only
return \fBTCL_OK\fR or \fBTCL_ERROR\fR.
In addition, if \fIproc\fR needs to return a non-empty result,

Changes to doc/CrtSlave.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtSlave.3,v 1.14 2004/10/07 15:37:43 dkf Exp $
'\" 
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtSlave.3,v 1.14.2.1 2005/03/09 15:57:15 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands
.SH SYNOPSIS
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
.AP int argc in
Count of additional arguments to pass to the alias command.
.AP "const char *const" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP int objc in
Count of additional object arguments to pass to the alias object command.
.AP Tcl_Object **objv in
Vector of Tcl_Obj structures, the additional object arguments to pass to
the alias object command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target
command is defined for an alias.
.AP "const char" **targetCmdPtr out







|







75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
.AP int argc in
Count of additional arguments to pass to the alias command.
.AP "const char *const" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP int objc in
Count of additional object arguments to pass to the alias object command.
.AP Tcl_Obj **objv in
Vector of Tcl_Obj structures, the additional object arguments to pass to
the alias object command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target
command is defined for an alias.
.AP "const char" **targetCmdPtr out

Changes to doc/DString.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: DString.3,v 1.11 2004/10/07 15:15:36 dkf Exp $
'\" 
.so man.macros
.TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_DStringInit\fR(\fIdsPtr\fR)
.sp
char *
\fBTcl_DStringAppend\fR(\fIdsPtr, string, length\fR)
.sp
char *
\fBTcl_DStringAppendElement\fR(\fIdsPtr, string\fR)
.sp
\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR)
.sp
int
\fBTcl_DStringLength\fR(\fIdsPtr\fR)







|













|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: DString.3,v 1.11.2.1 2005/05/05 17:55:20 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_DStringInit\fR(\fIdsPtr\fR)
.sp
char *
\fBTcl_DStringAppend\fR(\fIdsPtr, bytes, length\fR)
.sp
char *
\fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR)
.sp
\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR)
.sp
int
\fBTcl_DStringLength\fR(\fIdsPtr\fR)
43
44
45
46
47
48
49
50
51


52
53
54
55
56
57
58
59
60
\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR)
.sp
\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR)
.SH ARGUMENTS
.AS Tcl_DString newLength in/out
.AP Tcl_DString *dsPtr in/out
Pointer to structure that is used to manage a dynamic string.
.AP "const char" *string in
Pointer to characters to add to dynamic string.


.AP int length in
Number of characters from string to add to dynamic string.  If -1,
add all characters up to null terminating character.
.AP int newLength in
New length for dynamic string, not including null terminating
character.
.AP Tcl_Interp *interp in/out
Interpreter whose result is to be set from or moved to the
dynamic string.







|
|
>
>

|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR)
.sp
\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR)
.SH ARGUMENTS
.AS Tcl_DString newLength in/out
.AP Tcl_DString *dsPtr in/out
Pointer to structure that is used to manage a dynamic string.
.AP "const char" *bytes in
Pointer to characters to append to dynamic string.
.AP "const char" *element in
Pointer to characters to append as list element to dynamic string.
.AP int length in
Number of bytes from \fIbytes\fR to add to dynamic string.  If -1,
add all characters up to null terminating character.
.AP int newLength in
New length for dynamic string, not including null terminating
character.
.AP Tcl_Interp *interp in/out
Interpreter whose result is to be set from or moved to the
dynamic string.
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
anything already in it is discarded.
If the structure has been used previously, \fBTcl_DStringFree\fR should
be called first to free up any memory allocated for the old
string.
.PP
\fBTcl_DStringAppend\fR adds new information to a dynamic string,
allocating more memory for the string if needed.
If \fIlength\fR is less than zero then everything in \fIstring\fR
is appended to the dynamic string;  otherwise \fIlength\fR
specifies the number of bytes to append.
\fBTcl_DStringAppend\fR returns a pointer to the characters of
the new string.  The string can also be retrieved from the
\fIstring\fR field of the Tcl_DString structure.
.PP
\fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR
except that it doesn't take a \fIlength\fR argument (it appends
all of \fIstring\fR) and it converts the string to a proper list element
before appending.
\fBTcl_DStringAppendElement\fR adds a separator space before the
new list element unless the new list element is the first in a
list or sub-list (i.e. either the current string is empty, or it
contains the single character ``{'', or the last two characters of
the current string are `` {'').
\fBTcl_DStringAppendElement\fR returns a pointer to the







|








|







75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
anything already in it is discarded.
If the structure has been used previously, \fBTcl_DStringFree\fR should
be called first to free up any memory allocated for the old
string.
.PP
\fBTcl_DStringAppend\fR adds new information to a dynamic string,
allocating more memory for the string if needed.
If \fIlength\fR is less than zero then everything in \fIbytes\fR
is appended to the dynamic string;  otherwise \fIlength\fR
specifies the number of bytes to append.
\fBTcl_DStringAppend\fR returns a pointer to the characters of
the new string.  The string can also be retrieved from the
\fIstring\fR field of the Tcl_DString structure.
.PP
\fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR
except that it doesn't take a \fIlength\fR argument (it appends
all of \fIelement\fR) and it converts the string to a proper list element
before appending.
\fBTcl_DStringAppendElement\fR adds a separator space before the
new list element unless the new list element is the first in a
list or sub-list (i.e. either the current string is empty, or it
contains the single character ``{'', or the last two characters of
the current string are `` {'').
\fBTcl_DStringAppendElement\fR returns a pointer to the

Added doc/Ensemble.3.





















































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
'\"
'\" Copyright (c) 2005 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Ensemble.3,v 1.1.2.1 2005/01/20 19:12:28 kennykb Exp $
'\" 
'\" This documents the C API introduced in TIP#235
'\" 
.so man.macros
.TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsmelbeSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Command
\fBTcl_CreateEnsemble\fR(\fIinterp, name, namespacePtr, ensFlags\fR)
.sp
Tcl_Command
\fBTcl_FindEnsemble\fR(\fIinterp, cmdNameObj, flags\fR)
.sp
int
\fBTcl_IsEnsemble\fR(\fItoken\fR)
.sp
int
\fBTcl_GetEnsembleFlags\fR(\fIinterp, token, ensFlagsPtr\fR)
.sp
int
\fBTcl_SetEnsembleFlags\fR(\fIinterp, token, ensFlags\fR)
.sp
int
\fBTcl_GetEnsembleMappingDict\fR(\fIinterp, token, dictObjPtr\fR)
.sp
int
\fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR)
.sp
int
\fBTcl_GetEnsembleSubcommandList\fR(\fIinterp, token, listObjPtr\fR)
.sp
int
\fBTcl_SetEnsembleSubcommandList\fR(\fIinterp, token, listObj\fR)
.sp
int
\fBTcl_GetEnsembleUnknownHandler\fR(\fIinterp, token, listObjPtr\fR)
.sp
int
\fBTcl_SetEnsembleUnknownHandler\fR(\fIinterp, token, listObj\fR)
.sp
int
\fBTcl_GetEnsembleNamespace\fR(\fIinterp, token, namespacePtrPtr\fR)
.SH ARGUMENTS
.AS Tcl_Namespace **namespacePtrPtr in/out
.AP Tcl_Interp *interp in/out
The interpreter in which the ensemble is to be created or found. Also
where error result messages are written.
.AP "const char" *name in
The name of the ensemble command to be created.
.AP Tcl_Namespace *namespacePtr in
The namespace to which the ensemble command is to be bound, or NULL
for the current namespace.
.AP int ensFlags in
An ORed set of flag bits describing the basic configuration of the
ensemble. Currently only one bit has meaning, TCL_ENSEMBLE_PREFIX,
which is present when the ensemble command should also match
unambiguous prefixes of subcommands.
.AP Tcl_Obj *cmdNameObj in
A value holding the name of the ensemble command to look up.
.AP int flags in
An ORed set of flag bits controlling the behavior of
\fBTcl_FindEnsemble\fR. Currently only TCL_LEAVE_ERR_MSG is supported.
.AP Tcl_Command token in
A normal command token that refers to an ensemble command, or which
you wish to use for testing as an ensemble command in \fBTcl_IsEnsemble\fR.
.AP int *ensFlagsPtr out
Pointer to a variable into which to write the current ensemble flag
bits; currently only the bit TCL_ENSEMBLE_PREFIX is defined.
.AP Tcl_Obj *dictObj in
A dictionary value to use for the subcommand to implementation command
prefix mapping dictionary in the ensemble. May be NULL if the mapping
dictionary is to be removed.
.AP Tcl_Obj **dictObjPtr out
Pointer to a variable into which to write the current ensemble mapping
dictionary.
.AP Tcl_Obj *listObj in
A list value to use for the defined list of subcommands in the
dictionary or the unknown subcommmand handler command prefix. May be
NULL if the subcommand list or unknown handler are to be removed.
.AP Tcl_Obj **listObjPtr out
Pointer to a variable into which to write the current defiend list of
subcommands or the current unknown handler prefix.
.AP Tcl_Namespace **namespacePtrPtr out
Pointer to a variable into which to write the handle of the namespace
to which the ensemble is bound.
.BE

.SH DESCRIPTION
An ensemble is a command, bound to some namespace, which consists of a
collection of subcommands implemented by other Tcl commands. The first
argument to the ensemble command is always interpreted as a selector
that states what subcommand to execute.
.PP
Ensembles are created using \fBTcl_CreateEnsemble\fR, which takes four
arguments: the interpreter to work within, the name of the ensemble to
create, the namespace within the interpreter to bind the ensemble to,
and the default set of ensemble flags. The result of the function is
the command token for the ensemble, which may be used to further
configure the ensemble using the API descibed below in \fBENSEMBLE
PROPERTIES\fR.
.PP
Given the name of an ensemble command, the token for that command may
be retrieved using \fBTcl_FindEnsemble\fR. If the given command name
(in \fIcmdNameObj\fR) does not refer to an ensemble command, the
result of the function is NULL and (if the TCL_LEAVE_ERR_MSG bit is
set in \fIflags\fR) an error message is left in the interpreter
result.
.PP
A command token may be checked to see if it refers to an ensemble
using \fBTcl_IsEnsemble\fR. This returns 1 if the token refers to an
ensemble, or 0 otherwise.
.SS "ENSEMBLE PROPERTIES"
Every ensemble has four read-write properties and a read-only
property. The properties are:
.TP
\fBflags\fR (read-write)
The set of flags for the ensemble, expressed as a
bit-field. Currently, the only public flag is TCL_ENSEMBLE_PREFIX
which is set when unambiguous prefixes of subcommands are permitted to
be resolved to implementations as well as exact matches. The flags may
be read and written using \fBTcl_GetEnsembleFlags\fR and
\fBTcl_SetEnsembleFlags\fR respectively. The result of both of those
functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does
not refer to an ensemble).
.TP
\fBmapping dictionary\fR (read-write)
A dictionary containing a mapping from subcommand names to lists of
words to use as a command prefix (replacing the first two words of the
command which are the ensemble command itself and the subcommand
name), or NULL if every subcommand is to be mapped to the command with
the same unqualified name in the ensemble's bound namespace. Defaults
to NULL. May be read and written using
\fBTcl_GetEnsembleMappingDict\fR and \fBTcl_SetEnsembleMappingDict\fR
respectively. The result of both of those functions is a Tcl result
code (TCL_OK, or TCL_ERROR if the token does not refer to an
ensemble) and the dictionary obtained from
\fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable
even if it is unshared.
.TP
\fBsubcommand list\fR (read-write)
A list of all the subcommand names for the ensemble, or NULL if this
is to be derived from either the keys of the mapping dictionary (see
above) or (if that is also NULL) from the set of commands exported by
the bound namespace. May be read and written using
\fBTcl_GetEnsembleSubcommandList\fR and
\fBTcl_SetEnsembleSubcommandList\fR respectively. The result of both
of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the
token does not refer to an ensemble) and the list obtained from
\fBTcl_GetEnsembleSubcommandList\fR should alays be treated as
immutable even if it is unshared.
.TP
\fBunknown subcommand handler command prefix\fR (read-write)
A list of words to prepend on the front of any subcommand when the
subcommand is unknown to the ensemble (according to the current prefix
handling rule); see the \fBnamespace ensemble\fR command for more
details. If NULL, the default behavior \- generate a suitable error
message \- will be used when an unknown subcommand is encountered. May
be read and written using \fBTcl_GetEnsembleUnknownHandler\fR and
\fBTcl_SetEnsembleUnknownHandler\fR respectively. The result of both
functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does
not refer to an ensemble) and the list obtained from
\fBTcl_GetEnsembleUnknownHandler\fR should always be treated as
immutable even if it is unshared.
.TP
\fBbound namespace\fR (read-only)
The namespace to which the ensemble is bound; when the namespace is
deleted, so too will the ensemble, and this namespace is also the
namespace whose list of exported commands is used if both the mapping
dictionary and the subcommand list properties are NULL. May be read
using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code
(TCL_OK, or TCL_ERROR if the token does not refer to an ensemble).

.SH "SEE ALSO"
namespace(n), Tcl_DeleteCommandFromToken(3)

Changes to doc/Environment.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
'\"
'\" Copyright (c) 1997-1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Environment.3,v 1.4 2004/10/07 15:15:37 dkf Exp $
'\" 
.so man.macros
.TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PutEnv \- procedures to manipulate the environment
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_PutEnv\fR(\fIstring\fR)
.SH ARGUMENTS
.AS "const char" *string
.AP "const char" *string in
Info about environment variable in the form NAME=value. The string is
in native format.
.BE

.SH DESCRIPTION
.PP
\fBTcl_PutEnv\fR sets an environment variable. The information is
passed in a single string of the form NAME=value.  This procedure is
intended to be a stand-in for the UNIX \fBputenv\fR system call. All






|











|

|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
'\"
'\" Copyright (c) 1997-1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Environment.3,v 1.4.2.1 2005/05/05 17:55:20 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PutEnv \- procedures to manipulate the environment
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_PutEnv\fR(\fIassignment\fR)
.SH ARGUMENTS
.AS "const char" *assignment
.AP "const char" *assignnment in
Info about environment variable in the format NAME=value.
The \fIassignment\fR argument is in the system encoding.
.BE

.SH DESCRIPTION
.PP
\fBTcl_PutEnv\fR sets an environment variable. The information is
passed in a single string of the form NAME=value.  This procedure is
intended to be a stand-in for the UNIX \fBputenv\fR system call. All

Changes to doc/Eval.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.18 2004/10/07 15:15:37 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.18.2.3 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
int
\fBTcl_GlobalEval\fR(\fIinterp, script\fR)
.sp
int
\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR)
.sp
int
\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR)
.SH ARGUMENTS
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the script.  The interpreter's result is







|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
int
\fBTcl_GlobalEval\fR(\fIinterp, script\fR)
.sp
int
\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR)
.sp
int
\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR)
.SH ARGUMENTS
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the script.  The interpreter's result is
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any
null terminating character.  If \-1, then all characters up to the
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *string in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.







|



|







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any
null terminating character.  If \-1, then all characters up to the
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *part in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
result; it can be retrieved using \fBTcl_GetObjResult\fR.
.PP
\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates
its contents as a Tcl script.  It returns the same information as
\fBTcl_EvalObjEx\fR.
If the file couldn't be read then a Tcl error is returned to describe
why the file couldn't be read.
.VS 8.4
The eofchar for files is '\\32' (^Z) for all platforms.
If you require a ``^Z'' in code for string comparison, you can use
``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
interpreter into ``^Z''.
.VE 8.4
.PP
\fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a
script.  The \fIobjc\fR and \fIobjv\fR arguments contain the values
of the words for the Tcl command, one word in each object in
\fIobjv\fR.  \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
.PP







<




<







96
97
98
99
100
101
102

103
104
105
106

107
108
109
110
111
112
113
result; it can be retrieved using \fBTcl_GetObjResult\fR.
.PP
\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates
its contents as a Tcl script.  It returns the same information as
\fBTcl_EvalObjEx\fR.
If the file couldn't be read then a Tcl error is returned to describe
why the file couldn't be read.

The eofchar for files is '\\32' (^Z) for all platforms.
If you require a ``^Z'' in code for string comparison, you can use
``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
interpreter into ``^Z''.

.PP
\fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a
script.  The \fIobjc\fR and \fIobjv\fR arguments contain the values
of the words for the Tcl command, one word in each object in
\fIobjv\fR.  \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
.PP

Changes to doc/ExprLong.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ExprLong.3,v 1.9 2004/10/07 16:05:13 dkf Exp $
'\" 
.so man.macros
.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR)
.sp
int
\fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR)
.sp
int
\fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR)
.sp
int
\fBTcl_ExprString\fR(\fIinterp, string\fR)
.SH ARGUMENTS
.AS Tcl_Interp *booleanPtr out
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
.AP "const char" *string in
Expression to be evaluated.  
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the
expression.
.AP int *booleanPtr out
Pointer to location in which to store the 0/1 boolean value of the
expression.
.BE

.SH DESCRIPTION
.PP
These four procedures all evaluate the expression
given by the \fIstring\fR argument
and return the result in one of four different forms.
The expression can have any of the forms accepted by the \fBexpr\fR command.
Note that these procedures have been largely replaced by the
object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR,
\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR.
Those object-based procedures evaluate an expression held in a Tcl object
instead of a string.







|











|


|


|


|



|
|















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ExprLong.3,v 1.9.2.1 2005/05/05 17:55:21 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_ExprLong\fR(\fIinterp, expr, longPtr\fR)
.sp
int
\fBTcl_ExprDouble\fR(\fIinterp, expr, doublePtr\fR)
.sp
int
\fBTcl_ExprBoolean\fR(\fIinterp, expr, booleanPtr\fR)
.sp
int
\fBTcl_ExprString\fR(\fIinterp, expr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *booleanPtr out
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIexpr\fR.
.AP "const char" *expr in
Expression to be evaluated.  
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the
expression.
.AP int *booleanPtr out
Pointer to location in which to store the 0/1 boolean value of the
expression.
.BE

.SH DESCRIPTION
.PP
These four procedures all evaluate the expression
given by the \fIexpr\fR argument
and return the result in one of four different forms.
The expression can have any of the forms accepted by the \fBexpr\fR command.
Note that these procedures have been largely replaced by the
object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR,
\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR.
Those object-based procedures evaluate an expression held in a Tcl object
instead of a string.
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
the value was zero and 1 otherwise.
If the expression's actual value is a non-numeric string then
it must be one of the values accepted by \fBTcl_GetBoolean\fR
such as ``yes'' or ``no'', or else an error occurs.
.PP
\fBTcl_ExprString\fR returns the value of the expression as a
string stored in the interpreter's result.
If the expression's actual value is an integer
then \fBTcl_ExprString\fR converts it to a string using \fBsprintf\fR
with a ``%d'' converter.
If the expression's actual value is a floating-point
number, then \fBTcl_ExprString\fR calls \fBTcl_PrintDouble\fR
to convert it to a string.

.SH "SEE ALSO"
Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj

.SH KEYWORDS
boolean, double, evaluate, expression, integer, object, string







<
<
<
<
<
<






92
93
94
95
96
97
98






99
100
101
102
103
104
the value was zero and 1 otherwise.
If the expression's actual value is a non-numeric string then
it must be one of the values accepted by \fBTcl_GetBoolean\fR
such as ``yes'' or ``no'', or else an error occurs.
.PP
\fBTcl_ExprString\fR returns the value of the expression as a
string stored in the interpreter's result.







.SH "SEE ALSO"
Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj

.SH KEYWORDS
boolean, double, evaluate, expression, integer, object, string

Changes to doc/ExprLongObj.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ExprLongObj.3,v 1.3 2001/09/03 09:38:50 dkf Exp $
'\" 
.so man.macros
.TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ExprLongObj.3,v 1.3.16.1 2005/05/05 17:55:21 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression
.SH SYNOPSIS
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
\fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR)
.sp
int
\fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp **resultPtrPtr out
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
.AP Tcl_Obj *objPtr in
Pointer to an object containing the expression to evaluate.
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
\fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR)
.sp
int
\fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp **resultPtrPtr out
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIobjPtr\fR.
.AP Tcl_Obj *objPtr in
Pointer to an object containing the expression to evaluate.
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the

Changes to doc/FileSystem.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2001 Vincent Darley
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: FileSystem.3,v 1.50 2004/10/07 15:15:37 dkf Exp $
'\" 
.so man.macros
.TH Filesystem 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2001 Vincent Darley
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: FileSystem.3,v 1.50.2.4 2005/09/09 18:48:40 dgp Exp $
'\" 
.so man.macros
.TH Filesystem 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem
.SH SYNOPSIS
205
206
207
208
209
210
211


212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230











231
232
233
234
235
236
237
.AP Tcl_PackageInitProc **proc1Ptr out
Filled with the init function for this code.
.AP Tcl_PackageInitProc **proc2Ptr out
Filled with the safe-init function for this code.
.AP ClientData *clientDataPtr out
Filled with the clientData value to pass to this code's unload
function when it is called.


.AP Tcl_FSUnloadFileProc **unloadProcPtr out
Filled with the function to use to unload this piece of code.
.AP utimbuf *tval in
The access and modification times in this structure are read and
used to set those values for a given file.
.AP "const char" *modeString in
Specifies how the file is to be accessed.  May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644.  If a new file is created, these
permissions will be set on the created file.
.AP int *lenPtr out
If non-NULL, filled with the number of elements in the split path.
.AP Tcl_Obj *basePtr in
The base path on to which to join the given elements.  May be NULL.
.AP int objc in
The number of elements in \fIobjv\fR.
.AP "Tcl_Obj *const" objv[] in
The elements to join to the given base path.











.BE

.SH DESCRIPTION
.PP
There are several reasons for calling the \fBTcl_FS\fR API functions
(e.g. \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR)
rather than calling system level functions like \fBaccess\fR and







>
>



















>
>
>
>
>
>
>
>
>
>
>







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
.AP Tcl_PackageInitProc **proc1Ptr out
Filled with the init function for this code.
.AP Tcl_PackageInitProc **proc2Ptr out
Filled with the safe-init function for this code.
.AP ClientData *clientDataPtr out
Filled with the clientData value to pass to this code's unload
function when it is called.
.AP Tcl_LoadHandle *handlePtr out
Filled with an abstract token representing the loaded file.
.AP Tcl_FSUnloadFileProc **unloadProcPtr out
Filled with the function to use to unload this piece of code.
.AP utimbuf *tval in
The access and modification times in this structure are read and
used to set those values for a given file.
.AP "const char" *modeString in
Specifies how the file is to be accessed.  May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644.  If a new file is created, these
permissions will be set on the created file.
.AP int *lenPtr out
If non-NULL, filled with the number of elements in the split path.
.AP Tcl_Obj *basePtr in
The base path on to which to join the given elements.  May be NULL.
.AP int objc in
The number of elements in \fIobjv\fR.
.AP "Tcl_Obj *const" objv[] in
The elements to join to the given base path.
.AP Tcl_Obj *linkNamePtr in
The name of the link to be created or read.
.AP Tcl_Obj *toPtr in
What the link called \fIlinkNamePtr\fR should be linked to, or NULL if
the symbolic link specified by \fIlinkNamePtr\fR is to be read.
.AP int linkAction in
OR-ed combination of flags indicating what kind of link should be
created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set
are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR.
When both flags are set and the underlying filesystem can do either,
symbolic links are preferred.
.BE

.SH DESCRIPTION
.PP
There are several reasons for calling the \fBTcl_FS\fR API functions
(e.g. \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR)
rather than calling system level functions like \fBaccess\fR and
359
360
361
362
363
364
365
366

367
368
369
370
371
372
373
374
message is left in the \fIinterp\fR's result.
.PP
\fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a
directory for all files which match a given pattern.  The appropriate
function for the filesystem to which \fIpathPtr\fR belongs will be called.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in globbing.  Error messages are placed in interp, but good

results are placed in the resultPtr given.
.PP
Note that the \fBglob\fR code implements recursive patterns internally, so
this function will only ever be passed simple patterns, which can be
matched using the logic of \fBstring match\fR.  To handle recursion, Tcl
will call this function frequently asking only for directories to be
returned.
.PP







|
>
|







372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
message is left in the \fIinterp\fR's result.
.PP
\fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a
directory for all files which match a given pattern.  The appropriate
function for the filesystem to which \fIpathPtr\fR belongs will be called.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in globbing.  Error messages are placed in interp (unless 
interp is NULL, which is allowed), but good results are placed in the 
resultPtr given.
.PP
Note that the \fBglob\fR code implements recursive patterns internally, so
this function will only ever be passed simple patterns, which can be
matched using the logic of \fBstring match\fR.  To handle recursion, Tcl
will call this function frequently asking only for directories to be
returned.
.PP
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
\fBTcl_FSGetTranslatedStringPath\fR does the same as
\fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL.
The string returned is dynamically allocated and owned by the caller,
which must store it or call \fBckfree\fR to ensure it is freed.  Again,
\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually
better functions to use for most purposes.
.PP
\fBTcl_FSNewNativePath\fR performs something like that reverse of the
usual obj->path->nativerep conversions.  If some code retrieves a path
in native form (from, e.g. \fBreadlink\fR or a native dialog), and that path
is to be used at the Tcl level, then calling this function is an
efficient way of creating the appropriate path object type.
.PP
The resulting object is a pure 'path' object, which will only receive
a Utf-8 string representation if that is required by some Tcl code.







|







617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
\fBTcl_FSGetTranslatedStringPath\fR does the same as
\fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL.
The string returned is dynamically allocated and owned by the caller,
which must store it or call \fBckfree\fR to ensure it is freed.  Again,
\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually
better functions to use for most purposes.
.PP
\fBTcl_FSNewNativePath\fR performs something like the reverse of the
usual obj->path->nativerep conversions.  If some code retrieves a path
in native form (from, e.g. \fBreadlink\fR or a native dialog), and that path
is to be used at the Tcl level, then calling this function is an
efficient way of creating the appropriate path object type.
.PP
The resulting object is a pure 'path' object, which will only receive
a Utf-8 string representation if that is required by some Tcl code.
1078
1079
1080
1081
1082
1083
1084

1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
which have the correct type.  In either case, \fIpathPtr\fR can be
assumed to be both non-NULL and non-empty.  It is not currently
documented whether \fIpathPtr\fR will have a file separator at its end of
not, so code should be flexible to both possibilities.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the matching process.  Error messages are placed in

\fIinterp\fR; on a \fBTCL_OK\fR result, results should be added to the
\fIresultPtr\fR object given (which can be assumed to be a valid
unshared Tcl list).  The matches added
to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR
(this usually means they will be absolute path specifications).
Note that if no matches are found, that simply leads to an empty
result; errors are only signaled for actual file or filesystem
problems which may occur during the matching process.
.PP
The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR 







>
|
|
|







1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
which have the correct type.  In either case, \fIpathPtr\fR can be
assumed to be both non-NULL and non-empty.  It is not currently
documented whether \fIpathPtr\fR will have a file separator at its end of
not, so code should be flexible to both possibilities.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the matching process.  Error messages are placed in
\fIinterp\fR, unless \fIinterp\fR in NULL in which case no error
message need be generated; on a \fBTCL_OK\fR result, results should be 
added to the \fIresultPtr\fR object given (which can be assumed to be a 
valid unshared Tcl list).  The matches added
to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR
(this usually means they will be absolute path specifications).
Note that if no matches are found, that simply leads to an empty
result; errors are only signaled for actual file or filesystem
problems which may occur during the matching process.
.PP
The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR 
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
.CE
.PP
Returns a standard Tcl completion code.  If an error occurs, an error
message is left in the \fIinterp\fR's result.  The function dynamically loads a
binary code file into memory.  On a successful load, the \fIhandlePtr\fR
should be filled with a token for the dynamically loaded file, and the
\fIunloadProcPtr\fR should be filled in with the address of a procedure.
The unload procedure will be called with the given Tcl_LoadHandle as its
only parameter when Tcl needs to unload the file.  For example, for the
native filesystem, the \fBTcl_LoadHandle\fR returned is currently a token
which can be used in the private \fBTclpFindSymbol\fR to access functions
in the new code.  Each filesystem is free to define the
\fBTcl_LoadHandle\fR as it requires.  Finally, if the
filesystem determines it cannot support the file load action,
calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR







|







1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
.CE
.PP
Returns a standard Tcl completion code.  If an error occurs, an error
message is left in the \fIinterp\fR's result.  The function dynamically loads a
binary code file into memory.  On a successful load, the \fIhandlePtr\fR
should be filled with a token for the dynamically loaded file, and the
\fIunloadProcPtr\fR should be filled in with the address of a procedure.
The unload procedure will be called with the given \fBTcl_LoadHandle\fR as its
only parameter when Tcl needs to unload the file.  For example, for the
native filesystem, the \fBTcl_LoadHandle\fR returned is currently a token
which can be used in the private \fBTclpFindSymbol\fR to access functions
in the new code.  Each filesystem is free to define the
\fBTcl_LoadHandle\fR as it requires.  Finally, if the
filesystem determines it cannot support the file load action,
calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR

Changes to doc/GetIndex.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: GetIndex.3,v 1.16 2004/10/07 16:05:13 dkf Exp $
'\" 
.so man.macros
.TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags,
indexPtr\fR)
.VS
.sp
int
\fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset,
                          msg, flags, indexPtr\fR)
.VE
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this object is used to search through \fItablePtr\fR.






|













<




<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24

25
26
27
28
29
30
31
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: GetIndex.3,v 1.16.2.1 2005/04/10 23:14:41 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags,
indexPtr\fR)

.sp
int
\fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset,
                          msg, flags, indexPtr\fR)

.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this object is used to search through \fItablePtr\fR.
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
arguments (e.g. during a reinvocation of a Tcl command), it returns
the matching index immediately without having to redo the lookup
operation.  Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between
invocations.  If the value of \fIobjPtr\fR is the empty string,
\fBTcl_GetIndexFromObj\fR will treat it as a non-matching value
and return \fBTCL_ERROR\fR.
.VS
.PP
\fBTcl_GetIndexFromObjStruct\fR works just like
\fBTcl_GetIndexFromObj\fR, except that instead of treating
\fItablePtr\fR as an array of string pointers, it treats it as a
pointer to the first string in a series of strings that have
\fIoffset\fR bytes between them (i.e. that there is a pointer to the
first array of characters at \fItablePtr\fR, a pointer to the second
array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.)
This is particularly useful when processing things like
\fBTk_ConfigurationSpec\fR, whose string keys are in the same place in
each of several array elements.
.VE

.SH "SEE ALSO"
Tcl_WrongNumArgs

.SH KEYWORDS
index, object, table lookup







<











<






80
81
82
83
84
85
86

87
88
89
90
91
92
93
94
95
96
97

98
99
100
101
102
103
arguments (e.g. during a reinvocation of a Tcl command), it returns
the matching index immediately without having to redo the lookup
operation.  Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between
invocations.  If the value of \fIobjPtr\fR is the empty string,
\fBTcl_GetIndexFromObj\fR will treat it as a non-matching value
and return \fBTCL_ERROR\fR.

.PP
\fBTcl_GetIndexFromObjStruct\fR works just like
\fBTcl_GetIndexFromObj\fR, except that instead of treating
\fItablePtr\fR as an array of string pointers, it treats it as a
pointer to the first string in a series of strings that have
\fIoffset\fR bytes between them (i.e. that there is a pointer to the
first array of characters at \fItablePtr\fR, a pointer to the second
array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.)
This is particularly useful when processing things like
\fBTk_ConfigurationSpec\fR, whose string keys are in the same place in
each of several array elements.


.SH "SEE ALSO"
Tcl_WrongNumArgs

.SH KEYWORDS
index, object, table lookup

Changes to doc/GetInt.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: GetInt.3,v 1.7 2004/10/07 15:15:38 dkf Exp $
'\" 
.so man.macros
.TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR)
.sp
int
\fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR)
.sp
int
\fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *doublePtr out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
.AP "const char" *string in
Textual value to be converted.
.AP int *intPtr out
Points to place to store integer value converted from \fIstring\fR.
.AP double *doublePtr out
Points to place to store double-precision floating-point
value converted from \fIstring\fR.
.AP int *boolPtr out
Points to place to store boolean value (0 or 1) converted from \fIstring\fR.
.BE

.SH DESCRIPTION
.PP
These procedures convert from strings to integers or double-precision
floating-point values or booleans (represented as 0- or 1-valued
integers).  Each of the procedures takes a \fIstring\fR argument,
converts it to an internal form of a particular type, and stores
the converted value at the location indicated by the procedure's
third argument.  If all goes well, each of the procedures returns
\fBTCL_OK\fR.  If \fIstring\fR doesn't have the proper syntax for the
desired type then \fBTCL_ERROR\fR is returned, an error message is left
in the interpreter's result, and nothing is stored at *\fIintPtr\fR
or *\fIdoublePtr\fR or *\fIboolPtr\fR.
.PP
\fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection
of integer digits, optionally signed and optionally preceded by
white space.  If the first two characters of \fIstring\fR are ``0x''

then \fIstring\fR is expected to be in hexadecimal form;  otherwise,
if the first character of \fIstring\fR is ``0'' then \fIstring\fR
is expected to be in octal form;  otherwise, \fIstring\fR is
expected to be in decimal form.
.PP
\fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point
number, which is:  white space;  a sign; a sequence of digits;  a
decimal point;  a sequence of digits;  the letter ``e'';  and a

signed decimal exponent.  Any of the fields may be omitted, except that
the digits either before or after the decimal point must be present
and if the ``e'' is present then it must be followed by the
exponent number.
.PP
\fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean
value.  If \fIstring\fR is any of \fB0\fR, \fBfalse\fR,
\fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero
value at \fI*boolPtr\fR.
If \fIstring\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR,
then 1 is stored at \fI*boolPtr\fR.
Any of these values may be abbreviated, and upper-case spellings
are also acceptable.

.SH KEYWORDS
boolean, conversion, double, floating-point, integer







|











|


|


|




|


|


|

|






|



|




|

|
>
|
|
|


|

|
>
|




|
|


|






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: GetInt.3,v 1.7.2.2 2005/05/05 17:55:21 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_GetInt\fR(\fIinterp, src, intPtr\fR)
.sp
int
\fBTcl_GetDouble\fR(\fIinterp, src, doublePtr\fR)
.sp
int
\fBTcl_GetBoolean\fR(\fIinterp, src, boolPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *doublePtr out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
.AP "const char" *src in
Textual value to be converted.
.AP int *intPtr out
Points to place to store integer value converted from \fIsrc\fR.
.AP double *doublePtr out
Points to place to store double-precision floating-point
value converted from \fIsrc\fR.
.AP int *boolPtr out
Points to place to store boolean value (0 or 1) converted from \fIsrc\fR.
.BE

.SH DESCRIPTION
.PP
These procedures convert from strings to integers or double-precision
floating-point values or booleans (represented as 0- or 1-valued
integers).  Each of the procedures takes a \fIsrc\fR argument,
converts it to an internal form of a particular type, and stores
the converted value at the location indicated by the procedure's
third argument.  If all goes well, each of the procedures returns
\fBTCL_OK\fR.  If \fIsrc\fR doesn't have the proper syntax for the
desired type then \fBTCL_ERROR\fR is returned, an error message is left
in the interpreter's result, and nothing is stored at *\fIintPtr\fR
or *\fIdoublePtr\fR or *\fIboolPtr\fR.
.PP
\fBTcl_GetInt\fR expects \fIsrc\fR to consist of a collection
of integer digits, optionally signed and optionally preceded by
white space.  If the first two characters of \fIsrc\fR
after the optional white space and sign are ``0x''
then \fIsrc\fR is expected to be in hexadecimal form;  otherwise,
if the first such character is ``0'' then \fIsrc\fR
is expected to be in octal form;  otherwise, \fIsrc\fR is
expected to be in decimal form.
.PP
\fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point
number, which is:  white space;  a sign; a sequence of digits;  a
decimal point;  a sequence of digits;  the letter ``e'';  a
signed decimal exponent ; and more white space.
Any of the fields may be omitted, except that
the digits either before or after the decimal point must be present
and if the ``e'' is present then it must be followed by the
exponent number.
.PP
\fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean
value.  If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR,
\fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero
value at \fI*boolPtr\fR.
If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR,
then 1 is stored at \fI*boolPtr\fR.
Any of these values may be abbreviated, and upper-case spellings
are also acceptable.

.SH KEYWORDS
boolean, conversion, double, floating-point, integer

Changes to doc/GetOpnFl.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: GetOpnFl.3,v 1.8 2004/10/07 15:15:38 dkf Exp $
.so man.macros
.TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only)
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR)
.sp
.SH ARGUMENTS
.AS Tcl_Interp checkUsage out
.AP Tcl_Interp *interp in
Tcl interpreter from which file handle is to be obtained.
.AP "const char" *string in
String identifying channel, such as \fBstdin\fR or \fBfile4\fR.
.AP int write in
Non-zero means the file will be used for writing, zero means it will
be used for reading.
.AP int checkUsage in
If non-zero, then an error will be generated if the file wasn't opened
for the access indicated by \fIwrite\fR.
.AP ClientData *filePtr out
Points to word in which to store pointer to FILE structure for
the file given by \fIstring\fR.
.BE

.SH DESCRIPTION
.PP
\fBTcl_GetOpenFile\fR takes as argument a file identifier of the form
returned by the \fBopen\fR command and
returns at \fI*filePtr\fR a pointer to the FILE structure for
the file.
The \fIwrite\fR argument indicates whether the FILE pointer will
be used for reading or writing.
In some cases, such as a channel that connects to a pipeline of
subprocesses, different FILE pointers will be returned for reading
and writing.
\fBTcl_GetOpenFile\fR normally returns \fBTCL_OK\fR.
If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIstring\fR didn't
make any sense or \fIcheckUsage\fR was set and the file wasn't opened
for the access specified by \fIwrite\fR) then \fBTCL_ERROR\fR is returned
and the interpreter's result will contain an error message.
In the current implementation \fIcheckUsage\fR is ignored and consistency
checks are always performed.
.VS
.PP
Note that this interface is only supported on the Unix platform.
.VE

.SH KEYWORDS
channel, file handle, permissions, pipeline, read, write






|










|





|









|














|





<


<



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

55
56

57
58
59
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: GetOpnFl.3,v 1.8.2.2 2005/05/05 17:55:22 kennykb Exp $
.so man.macros
.TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only)
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_GetOpenFile\fR(\fIinterp, chanID, write, checkUsage, filePtr\fR)
.sp
.SH ARGUMENTS
.AS Tcl_Interp checkUsage out
.AP Tcl_Interp *interp in
Tcl interpreter from which file handle is to be obtained.
.AP "const char" *chanID in
String identifying channel, such as \fBstdin\fR or \fBfile4\fR.
.AP int write in
Non-zero means the file will be used for writing, zero means it will
be used for reading.
.AP int checkUsage in
If non-zero, then an error will be generated if the file wasn't opened
for the access indicated by \fIwrite\fR.
.AP ClientData *filePtr out
Points to word in which to store pointer to FILE structure for
the file given by \fIchanID\fR.
.BE

.SH DESCRIPTION
.PP
\fBTcl_GetOpenFile\fR takes as argument a file identifier of the form
returned by the \fBopen\fR command and
returns at \fI*filePtr\fR a pointer to the FILE structure for
the file.
The \fIwrite\fR argument indicates whether the FILE pointer will
be used for reading or writing.
In some cases, such as a channel that connects to a pipeline of
subprocesses, different FILE pointers will be returned for reading
and writing.
\fBTcl_GetOpenFile\fR normally returns \fBTCL_OK\fR.
If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIchanID\fR didn't
make any sense or \fIcheckUsage\fR was set and the file wasn't opened
for the access specified by \fIwrite\fR) then \fBTCL_ERROR\fR is returned
and the interpreter's result will contain an error message.
In the current implementation \fIcheckUsage\fR is ignored and consistency
checks are always performed.

.PP
Note that this interface is only supported on the Unix platform.


.SH KEYWORDS
channel, file handle, permissions, pipeline, read, write

Changes to doc/GetTime.3.

12
13
14
15
16
17
18




19
20
21
22



















23
24
25
26
27
28
29
.SH NAME
Tcl_GetTime \- get date and time
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_GetTime\fR(\fItimePtr\fR)




.SH ARGUMENTS
.AS "Tcl_Time *" timePtr out
.AP "Tcl_Time *" timePtr out
Points to memory in which to store the date and time information.



















.BE
.SH DESCRIPTION
.PP
The \fBTcl_GetTime\fR function retrieves the current time as a
\fITcl_Time\fR structure in memory the caller provides.  This
structure has the following definition:
.CS







>
>
>
>




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
.SH NAME
Tcl_GetTime \- get date and time
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_GetTime\fR(\fItimePtr\fR)
.sp
\fBTcl_SetTimeProc\fR(\fIgetProc, scaleProc, clientData\fR)
.sp
\fBTcl_QueryTimeProc\fR(\fIgetProcPtr, scaleProcPtr, clientDataPtr\fR)
.SH ARGUMENTS
.AS "Tcl_Time *" timePtr out
.AP "Tcl_Time *" timePtr out
Points to memory in which to store the date and time information.
.AS "Tcl_GetTimeProc *" getProc in
.AP "Tcl_GetTimeProc *" getProc in
Pointer to handler function replacing Tcl_GetTime's access to the OS.
.AS "Tcl_ScaleTimeProc *" scaleProc in
.AP "Tcl_ScaleTimeProc *" scaleProc in
Pointer to handler function for the conversion of time delays in the
virtual domain to real-time.
.AS "ClientData *" clientData in
.AP "ClientData *" clientData in
Value passed through to the two handler functions.
.AS "Tcl_GetTimeProc **" getProcPtr inout
.AP "Tcl_GetTimeProc **" getProcPtr inout
Pointer to place the currently registered get handler function into.
.AS "Tcl_ScaleTimeProc **" scaleProcPtr inout
.AP "Tcl_ScaleTimeProc **" scaleProcPtr inout
Pointer to place the currently registered scale handler function into.
.AS "ClientData **" clientDataPtr inout
.AP "ClientData **" clientDataPtr inout
Pointer to place the currently registered pass-through value into.
.BE
.SH DESCRIPTION
.PP
The \fBTcl_GetTime\fR function retrieves the current time as a
\fITcl_Time\fR structure in memory the caller provides.  This
structure has the following definition:
.CS
43
44
45
46
47
48
49


























50
51
52
53
microseconds that have elapsed since the start of the second
designated by \fIsec\fR.  The Tcl library makes every effort to keep
this number as precise as possible, subject to the limitations of the
computer system.  On multiprocessor variants of Windows, this number
may be limited to the 10- or 20-ms granularity of the system clock.
(On single-processor Windows systems, the \fIusec\fR field is derived
from a performance counter and is highly precise.)


























.SH "SEE ALSO"
clock
.SH KEYWORDS
date, time







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
microseconds that have elapsed since the start of the second
designated by \fIsec\fR.  The Tcl library makes every effort to keep
this number as precise as possible, subject to the limitations of the
computer system.  On multiprocessor variants of Windows, this number
may be limited to the 10- or 20-ms granularity of the system clock.
(On single-processor Windows systems, the \fIusec\fR field is derived
from a performance counter and is highly precise.)
.PP
The \fBTcl_SetTime\fR function registers two related handler functions
with the core. The first handler function is a replacement for
\fBTcl_GetTime\fR, or rather the OS access made by
\fBTcl_GetTime\fR. The other handler function is used by the Tcl
notifier to convert wait/block times from the virtual domain into real
time.
.PP
The \fBTcl_QueryTime\fR function returns the currently registered
handler functions. If no external handlers were set then this will
return the standard handlers accessing and processing the native time
of the OS. The arguments to the function are allowed to be NULL; and
any argument which is NULL is ignored and not set.
.PP
Any handler pair specified has to return data which is consistent
between them. In other words, setting one handler of the pair to
something assuming a 10-times slowdown, and the other handler of the
pair to something assuming a two-times slowdown is wrong and not
allowed.
.PP
The set handler functions are allowed to run the delivered time
backwards, however this should be avoided. We have to allow it as the
native time can run backwards as the user can fiddle with the system
time one way or other. Note that the insertion of the hooks will not
change the behaviour of the Tcl core with regard to this situation,
i.e. the existing behaviour is retained.
.SH "SEE ALSO"
clock
.SH KEYWORDS
date, time

Changes to doc/IntObj.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: IntObj.3,v 1.6 2004/10/07 15:37:43 dkf Exp $
'\" 
.so man.macros
.TH Tcl_IntObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj \- manipulate Tcl objects as integers and wide integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewIntObj\fR(\fIintValue\fR)
.sp
Tcl_Obj *
\fBTcl_NewLongObj\fR(\fIlongValue\fR)
.sp
.VS 8.4
Tcl_Obj *
\fBTcl_NewWideIntObj\fR(\fIwideValue\fR)
.VE 8.4
.sp
\fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR)
.sp
\fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR)
.sp
.VS 8.4
\fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR)
.VE 8.4
.sp
int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp
int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp
.VS 8.4
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.VE 8.4
.SH ARGUMENTS
.AS Tcl_WideInt longValue in/out
.AP int intValue in
Integer value used to initialize or set an integer object.
.AP long longValue in
Long integer value used to initialize or set an integer object.
.AP Tcl_WideInt wideValue in
.VS 8.4
Wide integer value (minimum 64-bits wide where supported by the
compiler) used to initialize or set a wide integer object.
.VE 8.4
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, and
.VS 8.4
\fBTcl_SetWideIntObj\fR, this points to the object to be converted to
integer type.  For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
and \fBTcl_GetWideIntFromObj\fR, this refers to the object from which
to get an integer or long integer value; if \fIobjPtr\fR does not
already point to an integer object (or a wide integer object in the
case of \fBTcl_SetWideIntObj\fR and \fBTcl_GetWideIntFromObj\fR), an
.VE 8.4
attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP int *intPtr out
Points to place to store the integer value
obtained by \fBTcl_GetIntFromObj\fR from \fIobjPtr\fR.
.AP long *longPtr out
Points to place to store the long integer value
obtained by \fBTcl_GetLongFromObj\fR from \fIobjPtr\fR.
.AP Tcl_WideInt *widePtr out
.VS 8.4
Points to place to store the wide integer value
obtained by \fBTcl_GetWideIntFromObj\fR from \fIobjPtr\fR.
.VE 8.4
.BE

.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
integer and wide integer Tcl objects from C code.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR,
\fBTcl_SetIntObj\fR, and \fBTcl_SetLongObj\fR
create a new object of integer type
or modify an existing object to have integer type,
.VS 8.4
and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR create a new
object of wide integer type or modify an existing object to have wide
integer type. 
.VE 8.4
\fBTcl_NewIntObj\fR and \fBTcl_SetIntObj\fR set the object to have the
integer value given by \fIintValue\fR,
\fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR
set the object to have the
long integer value given by \fIlongValue\fR,
.VS 8.4
and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR set the object
to have the wide integer value given by \fIwideValue\fR.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR and \fBTcl_NewWideIntObj\fR
return a pointer to a newly created object with reference count zero.
These procedures set the object's type to be integer
and assign the integer value to the object's internal representation
\fIlongValue\fR or \fIwideValue\fR member (as appropriate).
\fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR
and \fBTcl_SetWideIntObj\fR
.VE 8.4
invalidate any old string representation and,
if the object is not already an integer object,
free any old internal representation.
.PP
\fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR
attempt to return an integer value from the Tcl object \fIobjPtr\fR,
.VS 8.4
and \fBTcl_GetWideIntFromObj\fR attempts to return a wide integer
value from the Tcl object \fIobjPtr\fR.
If the object is not already an integer object,
or a wide integer object in the case of \fBTcl_GetWideIntFromObj\fR
.VE 8.4
they will attempt to convert it to one.
If an error occurs during conversion, they return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Also, if the long integer held in the object's internal representation
\fIlongValue\fR member can not be represented in a (non-long) integer,
\fBTcl_GetIntFromObj\fR returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, all three procedures return \fBTCL_OK\fR and
store the integer, long integer value
.VS 8.4
or wide integer in the address given by \fIintPtr\fR, \fIlongPtr\fR
and \fIwidePtr\fR
.VE 8.4
respectively.  If the object is not already an integer or wide integer
object, the conversion will free any old internal representation.

.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult

.SH KEYWORDS
integer, integer object, integer type, internal representation, object, object type, string representation






|
















<


<





<

<







<


<







<


<


<






<












<


<










<



<





<









<






<




<











<


<








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25

26
27
28
29
30

31

32
33
34
35
36
37
38

39
40

41
42
43
44
45
46
47

48
49

50
51

52
53
54
55
56
57

58
59
60
61
62
63
64
65
66
67
68
69

70
71

72
73
74
75
76
77
78
79
80
81

82
83
84

85
86
87
88
89

90
91
92
93
94
95
96
97
98

99
100
101
102
103
104

105
106
107
108

109
110
111
112
113
114
115
116
117
118
119

120
121

122
123
124
125
126
127
128
129
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: IntObj.3,v 1.6.2.1 2005/04/10 23:14:41 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_IntObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj \- manipulate Tcl objects as integers and wide integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewIntObj\fR(\fIintValue\fR)
.sp
Tcl_Obj *
\fBTcl_NewLongObj\fR(\fIlongValue\fR)
.sp

Tcl_Obj *
\fBTcl_NewWideIntObj\fR(\fIwideValue\fR)

.sp
\fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR)
.sp
\fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR)
.sp

\fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR)

.sp
int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp
int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp

int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)

.SH ARGUMENTS
.AS Tcl_WideInt longValue in/out
.AP int intValue in
Integer value used to initialize or set an integer object.
.AP long longValue in
Long integer value used to initialize or set an integer object.
.AP Tcl_WideInt wideValue in

Wide integer value (minimum 64-bits wide where supported by the
compiler) used to initialize or set a wide integer object.

.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, and

\fBTcl_SetWideIntObj\fR, this points to the object to be converted to
integer type.  For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
and \fBTcl_GetWideIntFromObj\fR, this refers to the object from which
to get an integer or long integer value; if \fIobjPtr\fR does not
already point to an integer object (or a wide integer object in the
case of \fBTcl_SetWideIntObj\fR and \fBTcl_GetWideIntFromObj\fR), an

attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP int *intPtr out
Points to place to store the integer value
obtained by \fBTcl_GetIntFromObj\fR from \fIobjPtr\fR.
.AP long *longPtr out
Points to place to store the long integer value
obtained by \fBTcl_GetLongFromObj\fR from \fIobjPtr\fR.
.AP Tcl_WideInt *widePtr out

Points to place to store the wide integer value
obtained by \fBTcl_GetWideIntFromObj\fR from \fIobjPtr\fR.

.BE

.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
integer and wide integer Tcl objects from C code.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR,
\fBTcl_SetIntObj\fR, and \fBTcl_SetLongObj\fR
create a new object of integer type
or modify an existing object to have integer type,

and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR create a new
object of wide integer type or modify an existing object to have wide
integer type. 

\fBTcl_NewIntObj\fR and \fBTcl_SetIntObj\fR set the object to have the
integer value given by \fIintValue\fR,
\fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR
set the object to have the
long integer value given by \fIlongValue\fR,

and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR set the object
to have the wide integer value given by \fIwideValue\fR.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR and \fBTcl_NewWideIntObj\fR
return a pointer to a newly created object with reference count zero.
These procedures set the object's type to be integer
and assign the integer value to the object's internal representation
\fIlongValue\fR or \fIwideValue\fR member (as appropriate).
\fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR
and \fBTcl_SetWideIntObj\fR

invalidate any old string representation and,
if the object is not already an integer object,
free any old internal representation.
.PP
\fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR
attempt to return an integer value from the Tcl object \fIobjPtr\fR,

and \fBTcl_GetWideIntFromObj\fR attempts to return a wide integer
value from the Tcl object \fIobjPtr\fR.
If the object is not already an integer object,
or a wide integer object in the case of \fBTcl_GetWideIntFromObj\fR

they will attempt to convert it to one.
If an error occurs during conversion, they return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Also, if the long integer held in the object's internal representation
\fIlongValue\fR member can not be represented in a (non-long) integer,
\fBTcl_GetIntFromObj\fR returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, all three procedures return \fBTCL_OK\fR and
store the integer, long integer value

or wide integer in the address given by \fIintPtr\fR, \fIlongPtr\fR
and \fIwidePtr\fR

respectively.  If the object is not already an integer or wide integer
object, the conversion will free any old internal representation.

.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult

.SH KEYWORDS
integer, integer object, integer type, internal representation, object, object type, string representation

Changes to doc/Interp.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Interp.3,v 1.7 2004/11/12 09:01:25 das Exp $
'\" 
.so man.macros
.TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Interp \- client-visible fields of interpreter structures
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Interp.3,v 1.7.2.1 2005/04/10 23:14:41 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Interp \- client-visible fields of interpreter structures
.SH SYNOPSIS
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
being returned by the command.
The \fIresult\fR field must always point to a valid string.
If a command wishes to return no result then \fIinterp->result\fR
should point to an empty string.
Normally, results are assumed to be statically allocated,
which means that the contents will not change before the next time
\fBTcl_Eval\fR is called or some other command procedure is invoked.
.VS
In this case, the \fIfreeProc\fR field must be zero.
Alternatively, a command procedure may dynamically
allocate its return value (e.g. using \fBTcl_Alloc\fR)
and store a pointer to it in \fIinterp->result\fR.
In this case, the command procedure must also set \fIinterp->freeProc\fR
to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR
if the storage was allocated directly by Tcl or by a call to
\fBTcl_Alloc\fR. 
.VE
If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR
to free the space pointed to by \fIinterp->result\fR before it
invokes the next command.
If a client procedure overwrites \fIinterp->result\fR when
\fIinterp->freeProc\fR is non-zero, then it is responsible for calling
\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR
macro should be used for this purpose).
.PP
\fIFreeProc\fR should have arguments and result that match the
\fBTcl_FreeProc\fR declaration above:  it receives a single
argument which is a pointer to the result value to free.
.VS
In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever
used for \fIfreeProc\fR.
.VE
However, an application may store a different procedure address
in \fIfreeProc\fR in order to use an alternate memory allocator
or in order to do other cleanup when the result memory is freed.
.PP
As part of processing each command, \fBTcl_Eval\fR initializes
\fIinterp->result\fR
and \fIinterp->freeProc\fR just before calling the command procedure for







<








<











<


<







56
57
58
59
60
61
62

63
64
65
66
67
68
69
70

71
72
73
74
75
76
77
78
79
80
81

82
83

84
85
86
87
88
89
90
being returned by the command.
The \fIresult\fR field must always point to a valid string.
If a command wishes to return no result then \fIinterp->result\fR
should point to an empty string.
Normally, results are assumed to be statically allocated,
which means that the contents will not change before the next time
\fBTcl_Eval\fR is called or some other command procedure is invoked.

In this case, the \fIfreeProc\fR field must be zero.
Alternatively, a command procedure may dynamically
allocate its return value (e.g. using \fBTcl_Alloc\fR)
and store a pointer to it in \fIinterp->result\fR.
In this case, the command procedure must also set \fIinterp->freeProc\fR
to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR
if the storage was allocated directly by Tcl or by a call to
\fBTcl_Alloc\fR. 

If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR
to free the space pointed to by \fIinterp->result\fR before it
invokes the next command.
If a client procedure overwrites \fIinterp->result\fR when
\fIinterp->freeProc\fR is non-zero, then it is responsible for calling
\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR
macro should be used for this purpose).
.PP
\fIFreeProc\fR should have arguments and result that match the
\fBTcl_FreeProc\fR declaration above:  it receives a single
argument which is a pointer to the result value to free.

In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever
used for \fIfreeProc\fR.

However, an application may store a different procedure address
in \fIfreeProc\fR in order to use an alternate memory allocator
or in order to do other cleanup when the result memory is freed.
.PP
As part of processing each command, \fBTcl_Eval\fR initializes
\fIinterp->result\fR
and \fIinterp->freeProc\fR just before calling the command procedure for

Changes to doc/LinkVar.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: LinkVar.3,v 1.9 2004/10/07 15:15:38 dkf Exp $
'\" 
.so man.macros
.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: LinkVar.3,v 1.9.2.2 2005/09/09 18:48:40 dgp Exp $
'\" 
.so man.macros
.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable
.SH SYNOPSIS
24
25
26
27
28
29
30
31
32
33
34
35
36




37


38

39
40
41
42
43
44
45
46
47
\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR)
.SH ARGUMENTS
.AS Tcl_Interp writable
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
.AP "const char" *varName in
Name of global variable.  
.AP char *addr in
Address of C variable that is to be linked to \fIvarName\fR.
.AP int type in
Type of C variable.  Must be one of \fBTCL_LINK_INT\fR, \fBTCL_LINK_DOUBLE\fR,
.VS 8.4




\fBTCL_LINK_WIDE_INT\fR,


.VE 8.4

\fBTCL_LINK_BOOLEAN\fR, or \fBTCL_LINK_STRING\fR, optionally OR'ed with
\fBTCL_LINK_READ_ONLY\fR to make Tcl variable read-only.
.BE

.SH DESCRIPTION
.PP
\fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable
named by \fIvarName\fR in sync with the C variable at the address
given by \fIaddr\fR.







|



|
|
>
>
>
>

>
>
|
>
|
|







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR)
.SH ARGUMENTS
.AS Tcl_Interp writable
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
.AP "const char" *varName in
Name of global variable.
.AP char *addr in
Address of C variable that is to be linked to \fIvarName\fR.
.AP int type in
Type of C variable.  Must be one of \fBTCL_LINK_INT\fR,
.VS 8.5
\fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR,
\fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR,
\fBTCL_LINK_ULONG\fR,
.VE 8.5
\fBTCL_LINK_WIDE_INT\fR,
.VS 8.5
\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR,
.VE 8.5
\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or
\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR
to make Tcl variable read-only.
.BE

.SH DESCRIPTION
.PP
\fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable
named by \fIvarName\fR in sync with the C variable at the address
given by \fIaddr\fR.
59
60
61
62
63
64
65

66






















































67
68
69
70
71
72

73
74






75


76
77
78
79
80
81












82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
.TP
\fBTCL_LINK_INT\fR
The C variable is of type \fBint\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR;  attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.

.TP






















































\fBTCL_LINK_DOUBLE\fR
The C variable is of type \fBdouble\fR.
Any value written into the Tcl variable must have a proper real
form acceptable to \fBTcl_GetDoubleFromObj\fR;  attempts to write
non-real values into \fIvarName\fR will be rejected with
Tcl errors.

.TP
\fBTCL_LINK_WIDE_INT\fR






.VS 8.4


The C variable is of type \fBTcl_WideInt\fR (which is an integer type
at least 64-bits wide on all platforms that can support it.)
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetWideIntFromObj\fR;  attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.












.VE 8.4
.TP
\fBTCL_LINK_BOOLEAN\fR
The C variable is of type \fBint\fR.
If its value is zero then it will read from Tcl as ``0'';
otherwise it will read from Tcl as ``1''.
Whenever \fIvarName\fR is
modified, the C variable will be set to a 0 or 1 value.
Any value written into the Tcl variable must have a proper boolean
form acceptable to \fBTcl_GetBooleanFromObj\fR;  attempts to write
non-boolean values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_STRING\fR
The C variable is of type \fBchar *\fR.
.VS
If its value is not NULL then it must be a pointer to a string
allocated with \fBTcl_Alloc\fR or \fBckalloc\fR.
.VE
Whenever the Tcl variable is modified the current C string will be
freed and new memory will be allocated to hold a copy of the variable's
new value.
If the C variable contains a NULL pointer then the Tcl variable
will read as ``NULL''.
.PP
If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the







>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>

|
>
>
>
>
>
>
|
>
>






>
>
>
>
>
>
>
>
>
>
>
>
|














<


<







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

180
181

182
183
184
185
186
187
188
.TP
\fBTCL_LINK_INT\fR
The C variable is of type \fBint\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR;  attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.
.VS 8.5
.TP
\fBTCL_LINK_UINT\fR
The C variable is of type \fBunsigned int\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the
platform's defined range for the \fBunsigned int\fR type; attempts to
write non-integer values (or values outside the range) into
\fIvarName\fR will be rejected with Tcl errors.
.TP
\fBTCL_LINK_CHAR\fR
The C variable is of type \fBchar\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the
\fBchar\fR datatype; attempts to write non-integer or out-of-range
values into \fIvarName\fR will be rejected with Tcl errors.
.TP
\fBTCL_LINK_UCHAR\fR
The C variable is of type \fBunsigned char\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetIntFromObj\fR and in the
platform's defined range for the \fBunsigned char\fR type; attempts to
write non-integer values (or values outside the range) into
\fIvarName\fR will be rejected with Tcl errors.
.TP
\fBTCL_LINK_SHORT\fR
The C variable is of type \fBshort\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the
\fBshort\fR datatype; attempts to write non-integer or out-of-range
values into \fIvarName\fR will be rejected with Tcl errors.
.TP
\fBTCL_LINK_USHORT\fR
The C variable is of type \fBunsigned short\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetIntFromObj\fR and in the
platform's defined range for the \fBunsigned short\fR type; attempts to
write non-integer values (or values outside the range) into
\fIvarName\fR will be rejected with Tcl errors.
.TP
\fBTCL_LINK_LONG\fR
The C variable is of type \fBlong\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write
non-integer or out-of-range
values into \fIvarName\fR will be rejected with Tcl errors.
.TP
\fBTCL_LINK_ULONG\fR
The C variable is of type \fBunsigned long\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the
platform's defined range for the \fBunsigned long\fR type; attempts to
write non-integer values (or values outside the range) into
\fIvarName\fR will be rejected with Tcl errors.
.VE 8.5
.TP
\fBTCL_LINK_DOUBLE\fR
The C variable is of type \fBdouble\fR.
Any value written into the Tcl variable must have a proper real
form acceptable to \fBTcl_GetDoubleFromObj\fR;  attempts to write
non-real values into \fIvarName\fR will be rejected with
Tcl errors.
.VS 8.5
.TP
\fBTCL_LINK_FLOAT\fR
The C variable is of type \fBfloat\fR.
Any value written into the Tcl variable must have a proper real
form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the
range acceptable for a \fBfloat\fR; attempts to
write non-real values (or values outside the range) into
\fIvarName\fR will be rejected with Tcl errors.
.VE 8.5
.TP
\fBTCL_LINK_WIDE_INT\fR
The C variable is of type \fBTcl_WideInt\fR (which is an integer type
at least 64-bits wide on all platforms that can support it.)
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetWideIntFromObj\fR;  attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.
.VS 8.5
.TP
\fBTCL_LINK_WIDE_UINT\fR
The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned
integer type at least 64-bits wide on all platforms that can support
it.)
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be
cast to unsigned);
'\" FIXME! Use bignums instead.
attempts to write non-integer values into \fIvarName\fR will be
rejected with Tcl errors.
.VE 8.5
.TP
\fBTCL_LINK_BOOLEAN\fR
The C variable is of type \fBint\fR.
If its value is zero then it will read from Tcl as ``0'';
otherwise it will read from Tcl as ``1''.
Whenever \fIvarName\fR is
modified, the C variable will be set to a 0 or 1 value.
Any value written into the Tcl variable must have a proper boolean
form acceptable to \fBTcl_GetBooleanFromObj\fR;  attempts to write
non-boolean values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_STRING\fR
The C variable is of type \fBchar *\fR.

If its value is not NULL then it must be a pointer to a string
allocated with \fBTcl_Alloc\fR or \fBckalloc\fR.

Whenever the Tcl variable is modified the current C string will be
freed and new memory will be allocated to hold a copy of the variable's
new value.
If the C variable contains a NULL pointer then the Tcl variable
will read as ``NULL''.
.PP
If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the

Changes to doc/ListObj.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ListObj.3,v 1.8 2004/10/07 16:05:14 dkf Exp $
'\" 
.so man.macros
.TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ListObj.3,v 1.8.2.1 2005/04/10 23:14:41 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists
.SH SYNOPSIS
147
148
149
150
151
152
153
154
155

156
157
158
159
160
161
162
The new list object returned by \fBTcl_NewListObj\fR
has reference count zero.
.PP
\fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of
the elements in a list object.  It returns the count by storing it in the
address \fIobjcPtr\fR.  Similarly, it returns the array pointer by storing
it in the address \fIobjvPtr\fR.
The memory pointed to is managed by Tcl and should not be freed by the
caller.

If \fIlistPtr\fR is not already a list object, \fBTcl_ListObjGetElements\fR
will attempt to convert it to one; if the conversion fails, it returns
\fBTCL_ERROR\fR and leaves an error message in the interpreter's result
object if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer.
.PP
\fBTcl_ListObjLength\fR returns the number of elements in the list object







|
|
>







147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
The new list object returned by \fBTcl_NewListObj\fR
has reference count zero.
.PP
\fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of
the elements in a list object.  It returns the count by storing it in the
address \fIobjcPtr\fR.  Similarly, it returns the array pointer by storing
it in the address \fIobjvPtr\fR.
The memory pointed to is managed by Tcl and should not be freed or written
to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR
and NULL at \fIobjvPtr\fR.
If \fIlistPtr\fR is not already a list object, \fBTcl_ListObjGetElements\fR
will attempt to convert it to one; if the conversion fails, it returns
\fBTCL_ERROR\fR and leaves an error message in the interpreter's result
object if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer.
.PP
\fBTcl_ListObjLength\fR returns the number of elements in the list object

Changes to doc/Notifier.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Notifier.3,v 1.13 2004/11/25 16:01:16 vasiljevic Exp $
'\" 
.so man.macros
.TH Notifier 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Notifier.3,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Notifier 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces
.SH SYNOPSIS
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
\fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fR)
.sp
void
\fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR)
.sp
void
\fBTcl_QueueEvent\fR(\fIevPtr, position\fR)
.VS 8.1
.sp
void
\fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR)
.sp
void
\fBTcl_ThreadAlert\fR(\fIthreadId\fR)
.sp







<







23
24
25
26
27
28
29

30
31
32
33
34
35
36
\fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fR)
.sp
void
\fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR)
.sp
void
\fBTcl_QueueEvent\fR(\fIevPtr, position\fR)

.sp
void
\fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR)
.sp
void
\fBTcl_ThreadAlert\fR(\fIthreadId\fR)
.sp
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
\fBTcl_ServiceEvent\fR(\fIflags\fR)
.sp
int
\fBTcl_GetServiceMode\fR()
.sp
int
\fBTcl_SetServiceMode\fR(\fImode\fR)
.VE

.SH ARGUMENTS
.AS Tcl_EventDeleteProc *deleteProc
.AP Tcl_EventSetupProc *setupProc in
Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR.
.AP Tcl_EventCheckProc *checkProc in
Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for







<







62
63
64
65
66
67
68

69
70
71
72
73
74
75
\fBTcl_ServiceEvent\fR(\fIflags\fR)
.sp
int
\fBTcl_GetServiceMode\fR()
.sp
int
\fBTcl_SetServiceMode\fR(\fImode\fR)


.SH ARGUMENTS
.AS Tcl_EventDeleteProc *deleteProc
.AP Tcl_EventSetupProc *setupProc in
Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR.
.AP Tcl_EventCheckProc *checkProc in
Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for

Changes to doc/Object.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Object.3,v 1.10 2004/10/07 15:15:38 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Obj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Object.3,v 1.10.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_Obj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects
.SH SYNOPSIS
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
                        void *\fIptr1\fR;
                        void *\fIptr2\fR;
                } \fItwoPtrValue\fR;
        } \fIinternalRep\fR;
} Tcl_Obj;
.CE
The \fIbytes\fR and the \fIlength\fR members together hold
.VS 8.1
an object's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
this allows string representations
to be treated as conventional null-terminated C strings.
.VE 8.1
C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
an object's string representation.
If \fIbytes\fR is NULL,
the string representation is invalid.
.PP
An object's type manages its internal representation.
The member \fItypePtr\fR points to the Tcl_ObjType structure







<









<







125
126
127
128
129
130
131

132
133
134
135
136
137
138
139
140

141
142
143
144
145
146
147
                        void *\fIptr1\fR;
                        void *\fIptr2\fR;
                } \fItwoPtrValue\fR;
        } \fIinternalRep\fR;
} Tcl_Obj;
.CE
The \fIbytes\fR and the \fIlength\fR members together hold

an object's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
this allows string representations
to be treated as conventional null-terminated C strings.

C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
an object's string representation.
If \fIbytes\fR is NULL,
the string representation is invalid.
.PP
An object's type manages its internal representation.
The member \fItypePtr\fR points to the Tcl_ObjType structure

Changes to doc/OpenFileChnl.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.29 2004/10/07 15:37:44 dkf Exp $
.so man.macros
.TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Channel
\fBTcl_OpenFileChannel\fR(\fIinterp, fileName, mode, permissions\fR)
.sp






|





|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.29.2.2 2005/07/12 20:36:15 kennykb Exp $
.so man.macros
.TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Channel
\fBTcl_OpenFileChannel\fR(\fIinterp, fileName, mode, permissions\fR)
.sp
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102





103
104
105
106
107
108
109
\fBTcl_Flush\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBlocked\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBuffered\fR(\fIchannel\fR)
.VS 8.4
.sp
int
\fBTcl_OutputBuffered\fR(\fIchannel\fR)
.VE
.sp
Tcl_WideInt
\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR)
.sp
Tcl_WideInt
\fBTcl_Tell\fR(\fIchannel\fR)





.sp
int
\fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR)
.sp
int
\fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR)
.sp







<



<






>
>
>
>
>







85
86
87
88
89
90
91

92
93
94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
\fBTcl_Flush\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBlocked\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBuffered\fR(\fIchannel\fR)

.sp
int
\fBTcl_OutputBuffered\fR(\fIchannel\fR)

.sp
Tcl_WideInt
\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR)
.sp
Tcl_WideInt
\fBTcl_Tell\fR(\fIchannel\fR)
.sp
.VS 8.5
int
\fBTcl_TruncateChannel\fR(\fIchannel, length\fR)
.VE 8.5
.sp
int
\fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR)
.sp
int
\fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR)
.sp
194
195
196
197
198
199
200


201
202
203
204
205
206
207
How far to move the access point in the channel at which the next input or
output operation will be applied, measured in bytes from the position
given by \fIseekMode\fR.  May be either positive or negative.
.AP int seekMode in
Relative to which point to seek; used with \fIoffset\fR to calculate the new
access point for the channel. Legal values are \fBSEEK_SET\fR,
\fBSEEK_CUR\fR, and \fBSEEK_END\fR.


.AP "const char" *optionName in
The name of an option applicable to this channel, such as \fB\-blocking\fR.
May have any of the values accepted by the \fBfconfigure\fR command.
.AP Tcl_DString *optionValue in
Where to store the value of an option or a list of all options and their
values. Must have been initialized by the caller.
.AP "const char" *newValue in







>
>







197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
How far to move the access point in the channel at which the next input or
output operation will be applied, measured in bytes from the position
given by \fIseekMode\fR.  May be either positive or negative.
.AP int seekMode in
Relative to which point to seek; used with \fIoffset\fR to calculate the new
access point for the channel. Legal values are \fBSEEK_SET\fR,
\fBSEEK_CUR\fR, and \fBSEEK_END\fR.
.AP Tcl_WideInt length in
The (non-negative) length to truncate the channel the channel to.
.AP "const char" *optionName in
The name of an option applicable to this channel, such as \fB\-blocking\fR.
May have any of the values accepted by the \fBfconfigure\fR command.
.AP Tcl_DString *optionValue in
Where to store the value of an option or a list of all options and their
values. Must have been initialized by the caller.
.AP "const char" *newValue in
589
590
591
592
593
594
595








596
597
598
599
600
601
602
code that can be retrieved with \fBTcl_GetErrno\fR.
After an error, the access point may or may not have been moved.

.SH TCL_TELL
.PP
\fBTcl_Tell\fR returns the current access point for a channel. The returned
value is \-1 if the channel does not support seeking.









.SH TCL_GETCHANNELOPTION
.PP
\fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of
the options currently in effect for a channel, or a list of all options and
their values.  The \fIchannel\fR argument identifies the channel for which
to query an option or retrieve all options and their values.







>
>
>
>
>
>
>
>







594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
code that can be retrieved with \fBTcl_GetErrno\fR.
After an error, the access point may or may not have been moved.

.SH TCL_TELL
.PP
\fBTcl_Tell\fR returns the current access point for a channel. The returned
value is \-1 if the channel does not support seeking.

.SH TCL_TRUNCATECHANNEL
.PP
.VS 8.5
\fBTcl_TruncateChannel\fR truncates the file underlying \fIchannel\fR
to a given \fIlength\fR of bytes. It returns \fBTCL_OK\fR if the
operation succeeded, and \fBTCL_ERROR\fR otherwise.
.VE 8.5

.SH TCL_GETCHANNELOPTION
.PP
\fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of
the options currently in effect for a channel, or a list of all options and
their values.  The \fIchannel\fR argument identifies the channel for which
to query an option or retrieve all options and their values.
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
.SH TCL_INPUTBUFFERED
.PP
\fBTcl_InputBuffered\fR returns the number of bytes of input currently
buffered in the internal buffers for a channel. If the channel is not open
for reading, this function always returns zero.

.SH TCL_OUTPUTBUFFERED
.VS 8.4
\fBTcl_OutputBuffered\fR returns the number of bytes of output
currently buffered in the internal buffers for a channel. If the
channel is not open for writing, this function always returns zero.
.VE

.SH "PLATFORM ISSUES"
.PP
The handles returned from \fBTcl_GetChannelHandle\fR depend on the
platform and the channel type.  On Unix platforms, the handle is
always a Unix file descriptor as returned from the \fBopen\fR system
call.  On Windows platforms, the handle is a file \fBHANDLE\fR when







<



<







652
653
654
655
656
657
658

659
660
661

662
663
664
665
666
667
668
.SH TCL_INPUTBUFFERED
.PP
\fBTcl_InputBuffered\fR returns the number of bytes of input currently
buffered in the internal buffers for a channel. If the channel is not open
for reading, this function always returns zero.

.SH TCL_OUTPUTBUFFERED

\fBTcl_OutputBuffered\fR returns the number of bytes of output
currently buffered in the internal buffers for a channel. If the
channel is not open for writing, this function always returns zero.


.SH "PLATFORM ISSUES"
.PP
The handles returned from \fBTcl_GetChannelHandle\fR depend on the
platform and the channel type.  On Unix platforms, the handle is
always a Unix file descriptor as returned from the \fBopen\fR system
call.  On Windows platforms, the handle is a file \fBHANDLE\fR when

Changes to doc/OpenTcp.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-7 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: OpenTcp.3,v 1.8 2004/10/07 15:15:42 dkf Exp $
.so man.macros
.TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-7 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: OpenTcp.3,v 1.8.2.1 2005/04/10 23:14:42 kennykb Exp $
.so man.macros
.TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets
.SH SYNOPSIS
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.

.VS
.SH "PLATFORM ISSUES"
.PP
On Unix platforms, the socket handle is a Unix file descriptor as
returned by the \fBsocket\fR system call.  On the Windows platform, the
socket handle is a \fBSOCKET\fR as defined in the WinSock API.
.VE

.SH "SEE ALSO"
Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n)

.SH KEYWORDS
client, server, TCP







<





<






159
160
161
162
163
164
165

166
167
168
169
170

171
172
173
174
175
176
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.


.SH "PLATFORM ISSUES"
.PP
On Unix platforms, the socket handle is a Unix file descriptor as
returned by the \fBsocket\fR system call.  On the Windows platform, the
socket handle is a \fBSOCKET\fR as defined in the WinSock API.


.SH "SEE ALSO"
Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n)

.SH KEYWORDS
client, server, TCP

Changes to doc/Panic.3.

1
2
3
4
5
6
7
8
9
10
11
12
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Panic.3,v 1.7 2004/10/07 15:15:47 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\"  Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort




|







1
2
3
4
5
6
7
8
9
10
11
12
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Panic.3,v 1.7.2.1 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\"  Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBTCL_VARARGS_START\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.

.BE

.SH DESCRIPTION







|







27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBva_start\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.

.BE

.SH DESCRIPTION

Changes to doc/ParseCmd.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ParseCmd.3,v 1.18 2004/10/07 16:05:15 dkf Exp $
'\" 
.so man.macros
.TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_ParseCommand\fR(\fIinterp, string, numBytes, nested, parsePtr\fR)
.sp
int
\fBTcl_ParseExpr\fR(\fIinterp, string, numBytes, parsePtr\fR)
.sp
int
\fBTcl_ParseBraces\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR)
.sp
int
\fBTcl_ParseQuotedString\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR)
.sp
int
\fBTcl_ParseVarName\fR(\fIinterp, string, numBytes, parsePtr, append\fR)
.sp
const char *
\fBTcl_ParseVar\fR(\fIinterp, string, termPtr\fR)
.sp
\fBTcl_FreeParse\fR(\fIusedParsePtr\fR)
.sp
Tcl_Obj *
\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR)
.sp
int
\fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR)
.SH ARGUMENTS
.AS Tcl_Interp *usedParsePtr out
.AP Tcl_Interp *interp out
For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR
and \fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR,
determines the context for evaluating the
script and also is used for error reporting; must not be NULL.
.AP "const char" *string in
Pointer to first character in string to parse.
.AP int numBytes in
Number of bytes in \fIstring\fR, not including any terminating null
character.  If less than 0 then the script consists of all characters
in \fIstring\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an
unquoted close bracket should be treated as a command terminator.  If zero,
close brackets have no special meaning. 
.AP int append in
Non-zero means that \fI*parsePtr\fR already contains valid tokens; the new
tokens should be appended to those already present.  Zero means that






|











|


|


|


|


|


|

















|


|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ParseCmd.3,v 1.18.2.3 2005/09/26 20:16:53 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_ParseCommand\fR(\fIinterp, start, numBytes, nested, parsePtr\fR)
.sp
int
\fBTcl_ParseExpr\fR(\fIinterp, start, numBytes, parsePtr\fR)
.sp
int
\fBTcl_ParseBraces\fR(\fIinterp, start, numBytes, parsePtr, append, termPtr\fR)
.sp
int
\fBTcl_ParseQuotedString\fR(\fIinterp, start, numBytes, parsePtr, append, termPtr\fR)
.sp
int
\fBTcl_ParseVarName\fR(\fIinterp, start, numBytes, parsePtr, append\fR)
.sp
const char *
\fBTcl_ParseVar\fR(\fIinterp, start, termPtr\fR)
.sp
\fBTcl_FreeParse\fR(\fIusedParsePtr\fR)
.sp
Tcl_Obj *
\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR)
.sp
int
\fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR)
.SH ARGUMENTS
.AS Tcl_Interp *usedParsePtr out
.AP Tcl_Interp *interp out
For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR
and \fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR,
determines the context for evaluating the
script and also is used for error reporting; must not be NULL.
.AP "const char" *start in
Pointer to first character in string to parse.
.AP int numBytes in
Number of bytes in string to parse, not including any terminating null
character.  If less than 0 then the script consists of all characters
following \fIstart\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an
unquoted close bracket should be treated as a command terminator.  If zero,
close brackets have no special meaning. 
.AP int append in
Non-zero means that \fI*parsePtr\fR already contains valid tokens; the new
tokens should be appended to those already present.  Zero means that
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
structure of the command (see below for details).
If an error occurred in parsing the command then
\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's
result, and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseExpr\fR parses Tcl expressions.
Given a pointer to a script containing an expression,
\fBTcl_ParseCommand\fR parses the expression.
If the expression was parsed successfully,
\fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the
structure pointed to by \fIparsePtr\fR with information about the
structure of the expression (see below for details).
If an error occurred in parsing the command then
\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's
result, and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseBraces\fR parses a string or command argument
enclosed in braces such as
\fB{hello}\fR or \fB{string \\t with \\t tabs}\fR
from the beginning of its argument \fIstring\fR.
The first character of \fIstring\fR must be \fB{\fR. 
If the braced string was parsed successfully,
\fBTcl_ParseBraces\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB}\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseQuotedString\fR parses a double-quoted string such as
\fB"sum is [expr $a+$b]"\fR
from the beginning of the argument \fIstring\fR.
The first character of \fIstring\fR must be \fB"\fR. 
If the double-quoted string was parsed successfully,
\fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB"\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseVarName\fR parses a Tcl variable reference such as
\fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its
\fIstring\fR argument.
The first character of \fIstring\fR must be \fB$\fR. 
If a variable name was parsed successfully, \fBTcl_ParseVarName\fR
returns \fBTCL_OK\fR and fills in the structure pointed to by
\fIparsePtr\fR with information about the structure of the variable name
(see below for details).  If an error
occurs while parsing the command then \fBTCL_ERROR\fR is returned, an
error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't
NULL), and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR
or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR
argument.  The first character of \fIstring\fR must be \fB$\fR.  If
the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a
pointer to the string value of the variable.  If an error occurs while
parsing, then NULL is returned and an error message is left in
\fIinterp\fR's result.
.PP
The information left at \fI*parsePtr\fR
by \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,







|











|
|














|
|














|
|









|
|







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
structure of the command (see below for details).
If an error occurred in parsing the command then
\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's
result, and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseExpr\fR parses Tcl expressions.
Given a pointer to a script containing an expression,
\fBTcl_ParseExpr\fR parses the expression.
If the expression was parsed successfully,
\fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the
structure pointed to by \fIparsePtr\fR with information about the
structure of the expression (see below for details).
If an error occurred in parsing the command then
\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's
result, and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseBraces\fR parses a string or command argument
enclosed in braces such as
\fB{hello}\fR or \fB{string \\t with \\t tabs}\fR
from the beginning of its argument \fIstart\fR.
The first character of \fIstart\fR must be \fB{\fR. 
If the braced string was parsed successfully,
\fBTcl_ParseBraces\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB}\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseQuotedString\fR parses a double-quoted string such as
\fB"sum is [expr $a+$b]"\fR
from the beginning of the argument \fIstart\fR.
The first character of \fIstart\fR must be \fB"\fR. 
If the double-quoted string was parsed successfully,
\fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB"\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseVarName\fR parses a Tcl variable reference such as
\fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its
\fIstart\fR argument.
The first character of \fIstart\fR must be \fB$\fR. 
If a variable name was parsed successfully, \fBTcl_ParseVarName\fR
returns \fBTCL_OK\fR and fills in the structure pointed to by
\fIparsePtr\fR with information about the structure of the variable name
(see below for details).  If an error
occurs while parsing the command then \fBTCL_ERROR\fR is returned, an
error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't
NULL), and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR
or \fB$x([expr $index + 1])\fR from the beginning of its \fIstart\fR
argument.  The first character of \fIstart\fR must be \fB$\fR.  If
the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a
pointer to the string value of the variable.  If an error occurs while
parsing, then NULL is returned and an error message is left in
\fIinterp\fR's result.
.PP
The information left at \fI*parsePtr\fR
by \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
.VS 8.5
This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that
the command parser notes this word began with the expansion
prefix \fB{expand}\fR, indicating that after substitution,
the list value of this word should be expanded to form multiple
arguments in command evaluation.  This
token type can only be created by Tcl_ParseCommand.
.VE
.TP
\fBTCL_TOKEN_TEXT\fR
The token describes a range of literal text that is part of a word.
The \fInumComponents\fR field is always 0.
.TP
\fBTCL_TOKEN_BS\fR
The token describes a backslash sequence such as \fB\en\fR or \fB\e0xa3\fR.







|







291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
.VS 8.5
This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that
the command parser notes this word began with the expansion
prefix \fB{expand}\fR, indicating that after substitution,
the list value of this word should be expanded to form multiple
arguments in command evaluation.  This
token type can only be created by Tcl_ParseCommand.
.VE 8.5
.TP
\fBTCL_TOKEN_TEXT\fR
The token describes a range of literal text that is part of a word.
The \fInumComponents\fR field is always 0.
.TP
\fBTCL_TOKEN_BS\fR
The token describes a backslash sequence such as \fB\en\fR or \fB\e0xa3\fR.
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
.PP
After \fBTcl_ParseQuotedString\fR returns,
the array of tokens pointed to by the \fItokenPtr\fR field of the
Tcl_Parse structure depends on the contents of the quoted string.
It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR,
\fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens.
The array always contains at least one token;
for example, if the argument \fIstring\fR is empty,
the array returned consists of a single \fBTCL_TOKEN_TEXT\fR token
with a zero \fIsize\fR field.
Only the token information in the Tcl_Parse structure
is modified: the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified.
.PP
After \fBTcl_ParseVarName\fR returns, the first token pointed to by
the \fItokenPtr\fR field of the
Tcl_Parse structure always has type \fBTCL_TOKEN_VARIABLE\fR.  It
is followed by the sub-tokens that make up the variable name as
described above.  The total length of the variable name is
contained in the \fIsize\fR field of the first token.
As in \fBTcl_ParseExpr\fR,
only the token information in the Tcl_Parse structure
is modified by \fBTcl_ParseVarName\fR:
the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified.
.PP
All of the character pointers in the
Tcl_Parse and Tcl_Token structures refer
to characters in the \fIstring\fR argument passed to
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR.
.PP
There are additional fields in the Tcl_Parse structure after the
\fInumTokens\fR field, but these are for the private use of
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be
referenced by code outside of these procedures.

.SH KEYWORDS
backslash substitution, braces, command, expression, parse, token, variable substitution







|




















|











427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
.PP
After \fBTcl_ParseQuotedString\fR returns,
the array of tokens pointed to by the \fItokenPtr\fR field of the
Tcl_Parse structure depends on the contents of the quoted string.
It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR,
\fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens.
The array always contains at least one token;
for example, if the argument \fIstart\fR is empty,
the array returned consists of a single \fBTCL_TOKEN_TEXT\fR token
with a zero \fIsize\fR field.
Only the token information in the Tcl_Parse structure
is modified: the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified.
.PP
After \fBTcl_ParseVarName\fR returns, the first token pointed to by
the \fItokenPtr\fR field of the
Tcl_Parse structure always has type \fBTCL_TOKEN_VARIABLE\fR.  It
is followed by the sub-tokens that make up the variable name as
described above.  The total length of the variable name is
contained in the \fIsize\fR field of the first token.
As in \fBTcl_ParseExpr\fR,
only the token information in the Tcl_Parse structure
is modified by \fBTcl_ParseVarName\fR:
the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified.
.PP
All of the character pointers in the
Tcl_Parse and Tcl_Token structures refer
to characters in the \fIstart\fR argument passed to
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR.
.PP
There are additional fields in the Tcl_Parse structure after the
\fInumTokens\fR field, but these are for the private use of
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be
referenced by code outside of these procedures.

.SH KEYWORDS
backslash substitution, braces, command, expression, parse, token, variable substitution

Changes to doc/PrintDbl.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44









45
46
47
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: PrintDbl.3,v 1.5 2004/10/07 14:44:33 dkf Exp $
'\" 
.so man.macros
.TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PrintDouble \- Convert floating value to string
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp out
.AP Tcl_Interp *interp in
.VS
Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter
controlled the conversion.  As of Tcl 8.0, this argument is ignored and
the conversion is controlled by the \fBtcl_precision\fR variable
that is now shared by all interpreters.
.VE
.AP double value in
Floating-point value to be converted.
.AP char *dst out
Where to store the string representing \fIvalue\fR.  Must have at
least \fBTCL_DOUBLE_SPACE\fR characters of storage.
.BE

.SH DESCRIPTION
.PP
\fBTcl_PrintDouble\fR generates a string that represents the value
of \fIvalue\fR and stores it in memory at the location given by
\fIdst\fR.  It uses \fB%g\fR format to generate the string, with one
special twist: the string is guaranteed to contain either
a ``.'' or an ``e'' so that it doesn't look like an integer.  Where
\fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR
adds ``.0''.










.SH KEYWORDS
conversion, double-precision, floating-point, string







|














<




<
















>
>
>
>
>
>
>
>
>



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: PrintDbl.3,v 1.5.2.2 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PrintDouble \- Convert floating value to string
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp out
.AP Tcl_Interp *interp in

Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter
controlled the conversion.  As of Tcl 8.0, this argument is ignored and
the conversion is controlled by the \fBtcl_precision\fR variable
that is now shared by all interpreters.

.AP double value in
Floating-point value to be converted.
.AP char *dst out
Where to store the string representing \fIvalue\fR.  Must have at
least \fBTCL_DOUBLE_SPACE\fR characters of storage.
.BE

.SH DESCRIPTION
.PP
\fBTcl_PrintDouble\fR generates a string that represents the value
of \fIvalue\fR and stores it in memory at the location given by
\fIdst\fR.  It uses \fB%g\fR format to generate the string, with one
special twist: the string is guaranteed to contain either
a ``.'' or an ``e'' so that it doesn't look like an integer.  Where
\fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR
adds ``.0''.
.VS 8.5
.PP
If the \fBtcl_precision\fR value is non-zero, the result will have
precisely that many digits of significance.  If the value is zero
(the default), the result will have the fewest digits needed to
represent the number in such a way that \fBTcl_NewDoubleObj\fR
will generate the same number when presented with the given string.
IEEE semantics of rounding to even apply to the conversion.
.VE

.SH KEYWORDS
conversion, double-precision, floating-point, string

Changes to doc/RegExp.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: RegExp.3,v 1.20 2004/10/07 16:22:16 dkf Exp $
'\" 
.so man.macros
.TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_RegExpMatchObj\fR(\fIinterp\fR, \fIstrObj\fR, \fIpatObj\fR)
.sp
int
\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR)
.sp
Tcl_RegExp
\fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR)
.sp
int
\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fIstring\fR, \fIstart\fR)
.sp
void
\fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR)
.sp
Tcl_RegExp
\fBTcl_GetRegExpFromObj\fR(\fIinterp\fR, \fIpatObj\fR, \fIcflags\fR)
.sp
int
\fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fIobjPtr\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR)
.sp
void
\fBTcl_RegExpGetInfo\fR(\fIregexp\fR, \fIinfoPtr\fR)

.SH ARGUMENTS
.AS Tcl_RegExpInfo *interp in/out
.AP Tcl_Interp *interp in
Tcl interpreter to use for error reporting.  The interpreter may be
NULL if no error reporting is desired.
.AP Tcl_Obj *strObj in/out
Refers to the object from which to get the string to search.  The
internal representation of the object may be converted to a form that
can be efficiently searched.
.AP Tcl_Obj *patObj in/out
Refers to the object from which to get a regular expression. The
compiled regular expression is cached in the object.
.AP char *string in
String to check for a match with a regular expression.
.AP "const char" *pattern in
String in the form of a regular expression pattern.
.AP Tcl_RegExp regexp in
Compiled regular expression.  Must have been returned previously
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP char *start in
If \fIstring\fR is just a portion of some other string, this argument
identifies the beginning of the larger string.
If it isn't the same as \fIstring\fR, then no \fB^\fR matches
will be allowed.
.AP int index in
Specifies which range is desired:  0 means the range of the entire
match, 1 or greater means the range that matched a parenthesized
sub-expression.
.AP "const char" **startPtr out
.VS 8.4
The address of the first character in the range is stored here, or
NULL if there is no such range.
.VE 8.4
.AP "const char" **endPtr out
.VS 8.4
The address of the character just after the last one in the range
is stored here, or NULL if there is no such range.
.VE 8.4
.AP int cflags in
OR-ed combination of compilation flags. See below for more information.
.AP Tcl_Obj *objPtr in/out
An object which contains the string to check for a match with a
regular expression.
.AP int offset in
The character offset into the string where matching should begin.
The value of the offset has no impact on \fB^\fR matches.  This
behavior is controlled by \fIeflags\fR.
.AP int nmatches in
The number of matching subexpressions that should be remembered for
later use.  If this value is 0, then no subexpression match
information will be computed.  If the value is -1, then
all of the matching subexpressions will be remembered.  Any other








|











|


|





|








|









|
|





|
|






|

|






<


<

<


<


<
<
<

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

73
74

75

76
77

78
79



80
81
82
83
84
85
86
87
88
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: RegExp.3,v 1.20.2.2 2005/05/05 17:55:22 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_RegExpMatchObj\fR(\fIinterp\fR, \fItextObj\fR, \fIpatObj\fR)
.sp
int
\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fItext\fR, \fIpattern\fR)
.sp
Tcl_RegExp
\fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR)
.sp
int
\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fItext\fR, \fIstart\fR)
.sp
void
\fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR)
.sp
Tcl_RegExp
\fBTcl_GetRegExpFromObj\fR(\fIinterp\fR, \fIpatObj\fR, \fIcflags\fR)
.sp
int
\fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fItextObj\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR)
.sp
void
\fBTcl_RegExpGetInfo\fR(\fIregexp\fR, \fIinfoPtr\fR)

.SH ARGUMENTS
.AS Tcl_RegExpInfo *interp in/out
.AP Tcl_Interp *interp in
Tcl interpreter to use for error reporting.  The interpreter may be
NULL if no error reporting is desired.
.AP Tcl_Obj *textObj in/out
Refers to the object from which to get the text to search.  The
internal representation of the object may be converted to a form that
can be efficiently searched.
.AP Tcl_Obj *patObj in/out
Refers to the object from which to get a regular expression. The
compiled regular expression is cached in the object.
.AP char *text in
Text to search for a match with a regular expression.
.AP "const char" *pattern in
String in the form of a regular expression pattern.
.AP Tcl_RegExp regexp in
Compiled regular expression.  Must have been returned previously
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP char *start in
If \fItext\fR is just a portion of some other string, this argument
identifies the beginning of the larger string.
If it isn't the same as \fItext\fR, then no \fB^\fR matches
will be allowed.
.AP int index in
Specifies which range is desired:  0 means the range of the entire
match, 1 or greater means the range that matched a parenthesized
sub-expression.
.AP "const char" **startPtr out

The address of the first character in the range is stored here, or
NULL if there is no such range.

.AP "const char" **endPtr out

The address of the character just after the last one in the range
is stored here, or NULL if there is no such range.

.AP int cflags in
OR-ed combination of compilation flags. See below for more information.



.AP int offset in
The character offset into the text where matching should begin.
The value of the offset has no impact on \fB^\fR matches.  This
behavior is controlled by \fIeflags\fR.
.AP int nmatches in
The number of matching subexpressions that should be remembered for
later use.  If this value is 0, then no subexpression match
information will be computed.  If the value is -1, then
all of the matching subexpressions will be remembered.  Any other
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
reference page. 
If there is a match then \fBTcl_RegExpMatch\fR returns 1.
If there is no match then \fBTcl_RegExpMatch\fR returns 0.
If an error occurs in the matching process (e.g. \fIpattern\fR
is not a valid regular expression) then \fBTcl_RegExpMatch\fR
returns \-1 and leaves an error message in the interpreter result.
\fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it
operates on the Tcl objects \fIstrObj\fR and \fIpatObj\fR instead of
UTF strings. 
\fBTcl_RegExpMatchObj\fR is generally more efficient than
\fBTcl_RegExpMatch\fR, so it is the preferred interface.
.PP
\fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR
provide lower-level access to the regular expression pattern matcher.
\fBTcl_RegExpCompile\fR compiles a regular expression string into
the internal form used for efficient pattern matching.
The return value is a token for this compiled form, which can be
used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR.
If an error occurs while compiling the regular expression then
\fBTcl_RegExpCompile\fR returns NULL and leaves an error message
in the interpreter result.
Note:  the return value from \fBTcl_RegExpCompile\fR is only valid
up to the next call to \fBTcl_RegExpCompile\fR;  it is not safe to
retain these values for long periods of time.
.PP
\fBTcl_RegExpExec\fR executes the regular expression pattern matcher.
It returns 1 if \fIstring\fR contains a range of characters that
match \fIregexp\fR, 0 if no match is found, and
\-1 if an error occurs.
In the case of an error, \fBTcl_RegExpExec\fR leaves an error
message in the interpreter result.
When searching a string for multiple matches of a pattern,
it is important to distinguish between the start of the original
string and the start of the current search.
For example, when searching for the second occurrence of a
match, the \fIstring\fR argument might point to the character
just after the first match;  however, it is important for the
pattern matcher to know that this is not the start of the entire string,
so that it doesn't allow \fB^\fR atoms in the pattern to match.
The \fIstart\fR argument provides this information by pointing
to the start of the overall string containing \fIstring\fR.
\fIStart\fR will be less than or equal to \fIstring\fR;  if it
is less than \fIstring\fR then no \fB^\fR matches will be allowed.
.PP
\fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR
returns;  it provides detailed information about what ranges of
the string matched what parts of the pattern.
\fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR
and \fI*endPtr\fR that identify a range of characters in
the source string for the most recent call to \fBTcl_RegExpExec\fR.







|


















|








|




|
|
|







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
reference page. 
If there is a match then \fBTcl_RegExpMatch\fR returns 1.
If there is no match then \fBTcl_RegExpMatch\fR returns 0.
If an error occurs in the matching process (e.g. \fIpattern\fR
is not a valid regular expression) then \fBTcl_RegExpMatch\fR
returns \-1 and leaves an error message in the interpreter result.
\fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it
operates on the Tcl objects \fItextObj\fR and \fIpatObj\fR instead of
UTF strings. 
\fBTcl_RegExpMatchObj\fR is generally more efficient than
\fBTcl_RegExpMatch\fR, so it is the preferred interface.
.PP
\fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR
provide lower-level access to the regular expression pattern matcher.
\fBTcl_RegExpCompile\fR compiles a regular expression string into
the internal form used for efficient pattern matching.
The return value is a token for this compiled form, which can be
used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR.
If an error occurs while compiling the regular expression then
\fBTcl_RegExpCompile\fR returns NULL and leaves an error message
in the interpreter result.
Note:  the return value from \fBTcl_RegExpCompile\fR is only valid
up to the next call to \fBTcl_RegExpCompile\fR;  it is not safe to
retain these values for long periods of time.
.PP
\fBTcl_RegExpExec\fR executes the regular expression pattern matcher.
It returns 1 if \fItext\fR contains a range of characters that
match \fIregexp\fR, 0 if no match is found, and
\-1 if an error occurs.
In the case of an error, \fBTcl_RegExpExec\fR leaves an error
message in the interpreter result.
When searching a string for multiple matches of a pattern,
it is important to distinguish between the start of the original
string and the start of the current search.
For example, when searching for the second occurrence of a
match, the \fItext\fR argument might point to the character
just after the first match;  however, it is important for the
pattern matcher to know that this is not the start of the entire string,
so that it doesn't allow \fB^\fR atoms in the pattern to match.
The \fIstart\fR argument provides this information by pointing
to the start of the overall string containing \fItext\fR.
\fIStart\fR will be less than or equal to \fItext\fR;  if it
is less than \fItext\fR then no \fB^\fR matches will be allowed.
.PP
\fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR
returns;  it provides detailed information about what ranges of
the string matched what parts of the pattern.
\fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR
and \fI*endPtr\fR that identify a range of characters in
the source string for the most recent call to \fBTcl_RegExpExec\fR.

Changes to doc/SaveResult.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
'\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SaveResult.3,v 1.4 2004/11/20 00:17:31 dgp Exp $
'\" 
.so man.macros
.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_InterpState
\fBTcl_SaveInterpState(\fIinterp, status\fB)\fR
.sp
int
\fBTcl_RestoreInterpState(\fIinterp, state\fB)\fR
.sp
\fBTcl_DiscardInterpState(\fIstate\fB)\fR
.sp
\fBTcl_SaveResult(\fIinterp, savedPtr\fB)\fR
.sp
\fBTcl_RestoreResult(\fIinterp, savedPtr\fB)\fR
.sp
\fBTcl_DiscardResult(\fIsavedPtr\fB)\fR
.SH ARGUMENTS
.AS Tcl_InterpState savedPtr
.AP Tcl_Interp *interp in
Interpreter for which state should be saved.
.AP int status in
Return code value to save as part of interpreter state.
.AP Tcl_InterpState state in







|











|


|

|

|

|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
'\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SaveResult.3,v 1.4.2.2 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_InterpState
\fBTcl_SaveInterpState\fR(\fIinterp, status\fR)
.sp
int
\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR)
.sp
\fBTcl_DiscardInterpState\fR(\fIstate\fR)
.sp
\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR)
.sp
\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR)
.sp
\fBTcl_DiscardResult\fR(\fIsavedPtr\fR)
.SH ARGUMENTS
.AS Tcl_InterpState savedPtr
.AP Tcl_Interp *interp in
Interpreter for which state should be saved.
.AP int status in
Return code value to save as part of interpreter state.
.AP Tcl_InterpState state in
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
that is used to store enough information to restore the interpreter result.
This structure can be allocated on the stack of the calling
procedure.  These routines do not save the state of any error
information in the interpreter (e.g. the \fB-errorcode\fR or
\fB-errorinfo\fR return options, when an error is in progress).
.PP
Because the routines \fBTcl_SaveInterpState\fR,
\fBTcl_RestoreInterpState\fB, and \fBTcl_DiscardInterpState\fR perform
a superset of the functions provided by the other routines,
any new code should only make use of the more powerful routines.
The older, weaker routines \fBTcl_SaveResult\fB, \fBTcl_RestoreResult\fB,
and \fBTcl_DiscardResult\fB continue to exist only for the sake
of existing programs that may already be using them.  
.PP
\fBTcl_SaveInterpState\fR takes a snapshot of those portions of
interpreter state that make up the full result of script evaluation.
This include the interpreter result, the return code (passed in
as the \fIstatus\fR argument, and any return options, including
\fB-errorinfo\fR and \fB-errorcode\fR when an error is in progress.







|


|
|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
that is used to store enough information to restore the interpreter result.
This structure can be allocated on the stack of the calling
procedure.  These routines do not save the state of any error
information in the interpreter (e.g. the \fB-errorcode\fR or
\fB-errorinfo\fR return options, when an error is in progress).
.PP
Because the routines \fBTcl_SaveInterpState\fR,
\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform
a superset of the functions provided by the other routines,
any new code should only make use of the more powerful routines.
The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR,
and \fBTcl_DiscardResult\fR continue to exist only for the sake
of existing programs that may already be using them.  
.PP
\fBTcl_SaveInterpState\fR takes a snapshot of those portions of
interpreter state that make up the full result of script evaluation.
This include the interpreter result, the return code (passed in
as the \fIstatus\fR argument, and any return options, including
\fB-errorinfo\fR and \fB-errorcode\fR when an error is in progress.
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
snapshot is not to be restored to an interp.
.PP
The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR
must eventually be passed to either \fBTcl_RestoreInterpState\fR
or \fBTcl_DiscardInterpState\fR to avoid a memory leak.  Once
the \fBTcl_InterpState\fR token is passed to one of them, the
token is no longer valid and should not be used anymore.
.VE
.PP
\fBTcl_SaveResult\fR moves the string and object results
of \fIinterp\fR into the location specified by \fIstatePtr\fR.
\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and
leaves the result in its normal empty initialized state.
.PP
\fBTcl_RestoreResult\fR moves the string and object results from







|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
snapshot is not to be restored to an interp.
.PP
The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR
must eventually be passed to either \fBTcl_RestoreInterpState\fR
or \fBTcl_DiscardInterpState\fR to avoid a memory leak.  Once
the \fBTcl_InterpState\fR token is passed to one of them, the
token is no longer valid and should not be used anymore.
.VE 8.5
.PP
\fBTcl_SaveResult\fR moves the string and object results
of \fIinterp\fR into the location specified by \fIstatePtr\fR.
\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and
leaves the result in its normal empty initialized state.
.PP
\fBTcl_RestoreResult\fR moves the string and object results from

Added doc/SetChanErr.3.























































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
'\"
'\" Copyright (c) 2005 Andreas Kupries <[email protected]>
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: SetChanErr.3,v 1.1.2.2 2005/08/25 15:46:30 dgp Exp $
.so man.macros
.TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
void
\fBTcl_SetChannelError\fR(\fIchan, msg\fR)
.sp
void
\fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR)
.sp
void
\fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR)
.sp
void
\fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR)
.sp
.SH ARGUMENTS
.AS Tcl_Channel chan
.AP Tcl_Channel chan in
Refers to the Tcl channel whose bypass area is accessed.
.AP Tcl_Interp* interp in
Refers to the Tcl interpreter whose bypass area is accessed.
.AP Tcl_Obj* msg in
Error message put into a bypass area.  A list of return options and
values, followed by a string message.  Both message and the
option/value information are optional.
.AP Tcl_Obj** msgPtr out
Reference to a place where the message stored in the accessed bypass
area can be stored in.
.BE
.SH DESCRIPTION
.PP
The current definition of a Tcl channel driver does not permit the
direct return of arbitrary error messages, except for the setting and
retrieval of channel options. All other functions are restricted to
POSIX error codes.
.PP
The functions described here overcome this limitation. Channel drivers
are allowed to use \fBTcl_SetChannelError\fR and
\fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in
\fBbypass areas\fI defined for channels and interpreters. And the
generic I/O layer uses \fBTcl_GetChannelError\fR and
\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass
areas and arrange for their return as errors. The posix error codes
set by a driver are used now if and only if no messages are present.
.PP
\fBTcl_SetChannelError\fR stores error information in the bypass area
of the specified channel. The number of references to the \fBmsg\fI
object goes up by one. Previously stored information will be
discarded, by releasing the reference held by the channel. The channel
reference must not be NULL.
.PP
\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass
area of the specified interpreter. The number of references to the
\fBmsg\fI object goes up by one. Previously stored information will be
discarded, by releasing the reference held by the interpreter. The
interpreter reference must not be NULL.
.PP
\fBTcl_GetChannelError\fR places either the error message held in the
bypass area of the specified channel into \fImsgPtr\fR, or NULL; and
resets the bypass. I.e. after an invokation all following invokations
will return NULL, until an intervening invokation of
\fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR
must not be NULL. The reference count of the message is not touched.
The reference previously held by the channel is now held by the caller
of the function and it is its responsibility to release that reference
when it is done with the object.
.PP
\fBTcl_GetChannelErrorInterp\fR places either the error message held
in the bypass area of the specified interpreter into \fImsgPtr\fR, or
NULL; and resets the bypass. I.e. after an invokation all following
invokations will return NULL, until an intervening invokation of
\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The
\fImsgPtr\fR must not be NULL. The reference count of the message is
not touched.  The reference previously held by the interpreter is now
held by the caller of the function and it is its responsibility to
release that reference when it is done with the object.
.PP
Which functions of a channel driver are allowed to use which bypass
function is listed below, as is which functions of the public channel
API may leave a messages in the bypass areas.
.PP
.IP \fBTcl_DriverCloseProc\fR
May use \fBTcl_SetChannelErrorInterp\fR, and only this function.
.IP \fBTcl_DriverInputProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverOutputProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverSeekProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverWideSeekProc
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverSetOptionProc\fR
Has already the ability to pass arbitrary error messages. Must
\fBnot\fR use any of the new functions.
.IP \fBTcl_DriverGetOptionProc\fR
Has already the ability to pass arbitrary error messages. Must
\fBnot\fR use any of the new functions.
.IP \fBTcl_DriverWatchProc\fR
Must \fBnot\fR use any of the new functions. Is internally called and
has no ability to return any type of error whatsoever.
.IP \fBTcl_DriverBlockModeProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverGetHandleProc\fR
Must \fBnot\fR use any of the new functions. It is only a low-level
function, and not used by Tcl commands.
.IP \fBTcl_DriverHandlerProc\fR
Must \fBnot\fR use any of the new functions. Is internally called and
has no ability to return any type of error whatsoever.
.PP
Given the information above the following public functions of the Tcl
C API are affected by these changes. I.e. when these functions are
called the channel may now contain a stored arbitrary error message
requiring processing by the caller.
.PP
.IP \fBTcl_StackChannel\fR
.IP \fBTcl_Seek\fR
.IP \fBTcl_Tell\fR
.IP \fBTcl_ReadRaw\fR
.IP \fBTcl_Read\fR
.IP \fBTcl_ReadChars\fR
.IP \fBTcl_Gets\fR
.IP \fBTcl_GetsObj\fR
.IP \fBTcl_Flush\fR
.IP \fBTcl_WriteRaw\fR
.IP \fBTcl_WriteObj\fR
.IP \fBTcl_Write\fR
.IP \fBTcl_WriteChars\fR
.PP
All other API functions are unchanged. Especially the functions below
leave all their error information in the interpreter result.
.PP
.IP \fBTcl_Close\fR
.IP \fBTcl_UnregisterChannel\fR
.IP \fBTcl_UnstackChannel\fR
.PP

.SH "SEE ALSO"
Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3)

.SH KEYWORDS
channel driver, error messages, channel type

Changes to doc/SetResult.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46



47
48
49
50
51
52
53
54
55
56
57
58
59
60
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetResult.3,v 1.11 2004/10/07 15:15:48 dkf Exp $
'\" 
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetObjResult\fR(\fIinterp\fR)
.sp
\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR)
.sp
const char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, string, string, ... , \fB(char *) NULL\fR)
.sp
\fBTcl_AppendResultVA\fR(\fIinterp, argList\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, string\fR)
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
\fBTcl_FreeResult\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_FreeProc freeProc out
.AP Tcl_Interp *interp out
Interpreter whose result is to be modified or read.
.AP Tcl_Obj *objPtr in
Object value to become result for \fIinterp\fR.
.AP char *string in
String value to become result for \fIinterp\fR or to be
appended to the existing result.



.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl object or a string.







|















|




|



|










|


>
>
>


|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.2 2005/09/15 20:58:38 dgp Exp $
'\" 
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetObjResult\fR(\fIinterp\fR)
.sp
\fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR)
.sp
const char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR)
.sp
\fBTcl_AppendResultVA\fR(\fIinterp, argList\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
\fBTcl_FreeResult\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_FreeProc freeProc out
.AP Tcl_Interp *interp out
Interpreter whose result is to be modified or read.
.AP Tcl_Obj *objPtr in
Object value to become result for \fIinterp\fR.
.AP char *result in
String value to become result for \fIinterp\fR or to be
appended to the existing result.
.AP char *element in
String value to append as a list element
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.BE

.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl object or a string.
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as an object.
The object's reference count is not incremented;
if the caller needs to retain a long-term pointer to the object
they should use \fBTcl_IncrRefCount\fR to increment its reference count
in order to keep it from being freed too early or accidentally changed.
.PP
\fBTcl_SetResult\fR
arranges for \fIstring\fR to be the result for the current Tcl
command in \fIinterp\fR, replacing any existing result.
The \fIfreeProc\fR argument specifies how to manage the storage
for the \fIstring\fR argument;
it is discussed in the section
\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below.
If \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored
and \fBTcl_SetResult\fR
re-initializes \fIinterp\fR's result to point to an empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as an string.
If the result was set to an object by a \fBTcl_SetObjResult\fR call,
the object form will be converted to a string and returned.
If the object's string representation contains null bytes,
this conversion will lose information.
For this reason, programmers are encouraged to
write their code to use the new object API procedures
and to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR clears the result for \fIinterp\fR
and leaves the result in its normal empty initialized state.
If the result is an object,
its reference count is decremented and the result is left
pointing to an unshared object representing an empty string.
If the result is a dynamically allocated string, its memory is free*d
and the result is left as a empty string.
\fBTcl_ResetResult\fR also clears the error state managed by
\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR,
and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
It takes each of its \fIstring\fR arguments and appends them in order
to the current result associated with \fIinterp\fR.
If the result is in its initialized empty state (e.g. a command procedure
was just invoked or \fBTcl_ResetResult\fR was just called),
then \fBTcl_AppendResult\fR sets the result to the concatenation of
its \fIstring\fR arguments.
\fBTcl_AppendResult\fR may be called repeatedly as additional pieces
of the result are produced.
\fBTcl_AppendResult\fR takes care of all the
storage management issues associated with managing \fIinterp\fR's
result, such as allocating a larger result area if necessary.
It also manages conversion to and from the \fIresult\fR field of the
\fIinterp\fR so as to handle backward-compatability with old-style
extensions.
Any number of \fIstring\fR arguments may be passed in a single
call; the last argument in the list must be a NULL pointer.
.PP
\fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that
instead of taking a variable number of arguments it takes an argument list.

.SH "OLD STRING PROCEDURES"
.PP
Use of the following procedures (is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as an object
can be significantly more efficient.
.PP
\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in
that it allows results to be built up in pieces.
However, \fBTcl_AppendElement\fR takes only a single \fIstring\fR
argument and it appends that argument to the current result
as a proper Tcl list element.
\fBTcl_AppendElement\fR adds backslashes or braces if necessary
to ensure that \fIinterp\fR's result can be parsed as a list and that
\fIstring\fR will be extracted as a single element.
Under normal conditions, \fBTcl_AppendElement\fR will add a space
character to \fIinterp\fR's result just before adding the new
list element, so that the list elements in the result are properly
separated.
However if the new list element is the first in a list or sub-list
(i.e. \fIinterp\fR's current result is empty, or consists of the
single character ``{'', or ends in the characters `` {'') then no







|


|


|



|




















|




|








|















|




|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as an object.
The object's reference count is not incremented;
if the caller needs to retain a long-term pointer to the object
they should use \fBTcl_IncrRefCount\fR to increment its reference count
in order to keep it from being freed too early or accidentally changed.
.PP
\fBTcl_SetResult\fR
arranges for \fIresult\fR to be the result for the current Tcl
command in \fIinterp\fR, replacing any existing result.
The \fIfreeProc\fR argument specifies how to manage the storage
for the \fIresult\fR argument;
it is discussed in the section
\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below.
If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored
and \fBTcl_SetResult\fR
re-initializes \fIinterp\fR's result to point to an empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string.
If the result was set to an object by a \fBTcl_SetObjResult\fR call,
the object form will be converted to a string and returned.
If the object's string representation contains null bytes,
this conversion will lose information.
For this reason, programmers are encouraged to
write their code to use the new object API procedures
and to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR clears the result for \fIinterp\fR
and leaves the result in its normal empty initialized state.
If the result is an object,
its reference count is decremented and the result is left
pointing to an unshared object representing an empty string.
If the result is a dynamically allocated string, its memory is free*d
and the result is left as a empty string.
\fBTcl_ResetResult\fR also clears the error state managed by
\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR,
and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
It takes each of its \fIresult\fR arguments and appends them in order
to the current result associated with \fIinterp\fR.
If the result is in its initialized empty state (e.g. a command procedure
was just invoked or \fBTcl_ResetResult\fR was just called),
then \fBTcl_AppendResult\fR sets the result to the concatenation of
its \fIresult\fR arguments.
\fBTcl_AppendResult\fR may be called repeatedly as additional pieces
of the result are produced.
\fBTcl_AppendResult\fR takes care of all the
storage management issues associated with managing \fIinterp\fR's
result, such as allocating a larger result area if necessary.
It also manages conversion to and from the \fIresult\fR field of the
\fIinterp\fR so as to handle backward-compatability with old-style
extensions.
Any number of \fIresult\fR arguments may be passed in a single
call; the last argument in the list must be a NULL pointer.
.PP
\fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that
instead of taking a variable number of arguments it takes an argument list.

.SH "OLD STRING PROCEDURES"
.PP
Use of the following procedures (is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as an object
can be significantly more efficient.
.PP
\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in
that it allows results to be built up in pieces.
However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR
argument and it appends that argument to the current result
as a proper Tcl list element.
\fBTcl_AppendElement\fR adds backslashes or braces if necessary
to ensure that \fIinterp\fR's result can be parsed as a list and that
\fIelement\fR will be extracted as a single element.
Under normal conditions, \fBTcl_AppendElement\fR will add a space
character to \fIinterp\fR's result just before adding the new
list element, so that the list elements in the result are properly
separated.
However if the new list element is the first in a list or sub-list
(i.e. \fIinterp\fR's current result is empty, or consists of the
single character ``{'', or ends in the characters `` {'') then no
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
Programs should always read the result
using the procedures \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR,
and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR.

.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how 
the Tcl system is to manage the storage for the \fIstring\fR argument.
If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called
at a time when \fIinterp\fR holds a string result,
they do whatever is necessary to dispose of the old string result
(see the \fBTcl_Interp\fR manual entry for details on this).
.PP
If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR
refers to an area of static storage that is guaranteed not to be
modified until at least the next call to \fBTcl_Eval\fR.
If \fIfreeProc\fR
is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call
to \fBTcl_Alloc\fR and is now the property of the Tcl system.
\fBTcl_SetResult\fR will arrange for the string's storage to be
released by calling \fBTcl_Free\fR when it is no longer needed.
If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR
points to an area of memory that is likely to be overwritten when
\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).
In this case \fBTcl_SetResult\fR will make a copy of the string in
dynamically allocated storage and arrange for the copy to be the
result for the current Tcl command.
.PP
If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR,
\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address
of a procedure that Tcl should call to free the string.
This allows applications to use non-standard storage allocators.
When Tcl no longer needs the storage for the string, it will
call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and
result that match the type \fBTcl_FreeProc\fR:
.CS
typedef void Tcl_FreeProc(char *\fIblockPtr\fR);
.CE
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIstring\fR passed to \fBTcl_SetResult\fR.

.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp

.SH KEYWORDS
append, command, element, list, object, result, return value, interpreter







|





|



|



|

















|






184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
Programs should always read the result
using the procedures \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR,
and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR.

.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how 
the Tcl system is to manage the storage for the \fIresult\fR argument.
If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called
at a time when \fIinterp\fR holds a string result,
they do whatever is necessary to dispose of the old string result
(see the \fBTcl_Interp\fR manual entry for details on this).
.PP
If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR
refers to an area of static storage that is guaranteed not to be
modified until at least the next call to \fBTcl_Eval\fR.
If \fIfreeProc\fR
is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call
to \fBTcl_Alloc\fR and is now the property of the Tcl system.
\fBTcl_SetResult\fR will arrange for the string's storage to be
released by calling \fBTcl_Free\fR when it is no longer needed.
If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR
points to an area of memory that is likely to be overwritten when
\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).
In this case \fBTcl_SetResult\fR will make a copy of the string in
dynamically allocated storage and arrange for the copy to be the
result for the current Tcl command.
.PP
If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR,
\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address
of a procedure that Tcl should call to free the string.
This allows applications to use non-standard storage allocators.
When Tcl no longer needs the storage for the string, it will
call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and
result that match the type \fBTcl_FreeProc\fR:
.CS
typedef void Tcl_FreeProc(char *\fIblockPtr\fR);
.CE
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIresult\fR passed to \fBTcl_SetResult\fR.

.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp

.SH KEYWORDS
append, command, element, list, object, result, return value, interpreter

Changes to doc/StrMatch.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StrMatch.3,v 1.6 2004/10/07 15:15:48 dkf Exp $
'\" 
.so man.macros
.TH Tcl_StringMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR)
.sp
int
\fBTcl_StringCaseMatch\fR(\fIstring\fR, \fIpattern\fR, \fInocase\fR)
.SH ARGUMENTS
.AS "const char" *pattern
.AP "const char" *string in
String to test.
.AP "const char" *pattern in
Pattern to match against string.  May contain special
characters from the set *?\e[].
.AP int nocase in
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
.BE

.SH DESCRIPTION
.PP
This utility procedure determines whether a string matches
a given pattern.  If it does, then \fBTcl_StringMatch\fR returns
1.  Otherwise \fBTcl_StringMatch\fR returns 0.  The algorithm
used for matching is the same algorithm used in the ``string match''
Tcl command and is similar to the algorithm used by the C-shell
for file name matching;  see the Tcl manual entry for details.
.VS 8.1
.PP
In \fBTcl_StringCaseMatch\fR, the algorithm is the same, but you have
the option to make the matching case-insensitive.  If you choose this
(by passing \fBnocase\fR as 1), then the string and pattern are
essentially matched in the lower case.
.VE 8.1

.SH KEYWORDS
match, pattern, string







|











|


|


|

















<





<



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

44
45
46
47
48

49
50
51
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StrMatch.3,v 1.6.2.2 2005/05/05 17:55:24 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_StringMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_StringMatch\fR(\fIstr\fR, \fIpattern\fR)
.sp
int
\fBTcl_StringCaseMatch\fR(\fIstr\fR, \fIpattern\fR, \fInocase\fR)
.SH ARGUMENTS
.AS "const char" *pattern
.AP "const char" *str in
String to test.
.AP "const char" *pattern in
Pattern to match against string.  May contain special
characters from the set *?\e[].
.AP int nocase in
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
.BE

.SH DESCRIPTION
.PP
This utility procedure determines whether a string matches
a given pattern.  If it does, then \fBTcl_StringMatch\fR returns
1.  Otherwise \fBTcl_StringMatch\fR returns 0.  The algorithm
used for matching is the same algorithm used in the ``string match''
Tcl command and is similar to the algorithm used by the C-shell
for file name matching;  see the Tcl manual entry for details.

.PP
In \fBTcl_StringCaseMatch\fR, the algorithm is the same, but you have
the option to make the matching case-insensitive.  If you choose this
(by passing \fBnocase\fR as 1), then the string and pattern are
essentially matched in the lower case.


.SH KEYWORDS
match, pattern, string

Changes to doc/StringObj.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.17 2004/10/07 15:15:48 dkf Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.2 2005/09/15 20:58:39 dgp Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
\fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
Tcl_Obj *
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *appendObjPtr in/out
.AP "const char" *bytes in
.VS 8.1
Points to the first byte of an array of UTF-8-encoded bytes
used to set or append to a string object.
This byte array may contain embedded null characters
unless \fInumChars\fR is negative.  (Applications needing null bytes
should represent them as the two-byte sequence \fI\\700\\600\fR, use
\fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if
the string is a collection of uninterpreted bytes.)
.VE 8.1
.AP int length in
The number of bytes to copy from \fIbytes\fR when
initializing, setting, or appending to a string object.
If negative, all bytes up to the first null are used.
.AP "const Tcl_UniChar" *unicode in
Points to the first byte of an array of Unicode characters
used to set or append to a string object.







<







<







70
71
72
73
74
75
76

77
78
79
80
81
82
83

84
85
86
87
88
89
90
\fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
Tcl_Obj *
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *appendObjPtr in/out
.AP "const char" *bytes in

Points to the first byte of an array of UTF-8-encoded bytes
used to set or append to a string object.
This byte array may contain embedded null characters
unless \fInumChars\fR is negative.  (Applications needing null bytes
should represent them as the two-byte sequence \fI\\700\\600\fR, use
\fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if
the string is a collection of uninterpreted bytes.)

.AP int length in
The number of bytes to copy from \fIbytes\fR when
initializing, setting, or appending to a string object.
If negative, all bytes up to the first null are used.
.AP "const Tcl_UniChar" *unicode in
Points to the first byte of an array of Unicode characters
used to set or append to a string object.
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the length of an object's string representation.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.







|







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the length of an object's string representation.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.

Changes to doc/Thread.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Thread.3,v 1.20 2004/11/25 16:01:17 vasiljevic Exp $
'\" 
.so man.macros
.TH Threads 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Thread.3,v 1.20.2.2 2005/03/02 21:25:19 kennykb Exp $
'\" 
.so man.macros
.TH Threads 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support
.SH SYNOPSIS
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
and use multiple interpreters.)
.SH DESCRIPTION
Tcl provides \fBTcl_CreateThread\fR for creating threads. The
caller can determine the size of the stack given to the new thread and
modify the behaviour through the supplied \fIflags\fR. The value
\fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that
the default size as specified by the operating system is to be used
for the new thread. As for the flags, currently are only the values
\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The
first of them invokes the default behaviour with no
specialties. Using the second value marks the new thread as
\fIjoinable\fR. This means that another thread can wait for the such
marked thread to exit and join it.
.PP
Restrictions: On some UNIX systems the pthread-library does not
contain the functionality to specify the stack size of a thread. The
specified value for the stack size is ignored on these systems.
Windows currently does not support joinable threads. This
flag value is therefore ignored on this platform.
.PP
Tcl does provide \fBTcl_ExitThread\fR and \fBTcl_FinalizeThread\fR
for terminating threads and invoking optional per-thread exit
handlers.  See the \fBTcl_Exit\fR page for more information on these
procedures.
.PP
The \fBTcl_JoinThread\fR function is provided to allow threads to wait
upon the exit of another thread, which must have been marked as
joinable through usage of the \fBTCL_THREAD_JOINABLE\fR-flag during







|
|











|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
and use multiple interpreters.)
.SH DESCRIPTION
Tcl provides \fBTcl_CreateThread\fR for creating threads. The
caller can determine the size of the stack given to the new thread and
modify the behaviour through the supplied \fIflags\fR. The value
\fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that
the default size as specified by the operating system is to be used
for the new thread. As for the flags, currently only the values
\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR are defined. The
first of them invokes the default behaviour with no
specialties. Using the second value marks the new thread as
\fIjoinable\fR. This means that another thread can wait for the such
marked thread to exit and join it.
.PP
Restrictions: On some UNIX systems the pthread-library does not
contain the functionality to specify the stack size of a thread. The
specified value for the stack size is ignored on these systems.
Windows currently does not support joinable threads. This
flag value is therefore ignored on this platform.
.PP
Tcl provides the \fBTcl_ExitThread\fR and \fBTcl_FinalizeThread\fR functions
for terminating threads and invoking optional per-thread exit
handlers.  See the \fBTcl_Exit\fR page for more information on these
procedures.
.PP
The \fBTcl_JoinThread\fR function is provided to allow threads to wait
upon the exit of another thread, which must have been marked as
joinable through usage of the \fBTCL_THREAD_JOINABLE\fR-flag during
187
188
189
190
191
192
193
194
195
196
197
198
manage, or join threads, nor any script-level access to mutex or
condition variables.  It provides such facilities only via C
interfaces, and leaves it up to packages to expose these matters to
the script level.  One such package is the \fBThread\fR package.
.VE 8.5
.SH "SEE ALSO"
Tcl_GetCurrentThread(3), Tcl_ThreadQueueEvent(3), Tcl_ThreadAlert(3),
Tcl_ExitThread(3), Tcl_FinalizeThread(3),
Tcl_CreateThreadExitHandler(3), Tcl_DeleteThreadExitHandler(3),
\fBThread\fR package
.SH KEYWORDS
thread, mutex, condition variable, thread local storage







|
|
<


187
188
189
190
191
192
193
194
195

196
197
manage, or join threads, nor any script-level access to mutex or
condition variables.  It provides such facilities only via C
interfaces, and leaves it up to packages to expose these matters to
the script level.  One such package is the \fBThread\fR package.
.VE 8.5
.SH "SEE ALSO"
Tcl_GetCurrentThread(3), Tcl_ThreadQueueEvent(3), Tcl_ThreadAlert(3),
Tcl_ExitThread(3), Tcl_FinalizeThread(3), Tcl_CreateThreadExitHandler(3),
Tcl_DeleteThreadExitHandler(3), Thread

.SH KEYWORDS
thread, mutex, condition variable, thread local storage

Changes to doc/TraceVar.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: TraceVar.3,v 1.13 2004/10/07 16:05:15 dkf Exp $
'\" 
.so man.macros
.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: TraceVar.3,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable
.SH SYNOPSIS
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
\fBTCL_TRACE_ARRAY\fR
Invoke \fIproc\fR whenever the array command is invoked.
This gives the trace procedure a chance to update the array before
array names or array get is called.  Note that this is called
before an array set, but that will trigger write traces.
.TP
\fBTCL_TRACE_RESULT_DYNAMIC\fR
.VS 8.4
The result of invoking the \fIproc\fR is a dynamically allocated
string that will be released by the Tcl library via a call to
\fBckfree\fR.  Must not be specified at the same time as
\fBTCL_TRACE_RESULT_OBJECT\fR.
.VE 8.4
.TP
\fBTCL_TRACE_RESULT_OBJECT\fR
.VS 8.4
The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*)
with a reference count of at least one.  The ownership of that
reference will be transferred to the Tcl core for release (when the
core has finished with it) via a call to \fBTcl_DecrRefCount\fR.  Must
not be specified at the same time as \fBTCL_TRACE_RESULT_DYNAMIC\fR.
.VE 8.4
.PP
Whenever one of the specified operations occurs on the variable,
\fIproc\fR will be invoked.
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.CS
typedef char *Tcl_VarTraceProc(







<




<


<





<







104
105
106
107
108
109
110

111
112
113
114

115
116

117
118
119
120
121

122
123
124
125
126
127
128
\fBTCL_TRACE_ARRAY\fR
Invoke \fIproc\fR whenever the array command is invoked.
This gives the trace procedure a chance to update the array before
array names or array get is called.  Note that this is called
before an array set, but that will trigger write traces.
.TP
\fBTCL_TRACE_RESULT_DYNAMIC\fR

The result of invoking the \fIproc\fR is a dynamically allocated
string that will be released by the Tcl library via a call to
\fBckfree\fR.  Must not be specified at the same time as
\fBTCL_TRACE_RESULT_OBJECT\fR.

.TP
\fBTCL_TRACE_RESULT_OBJECT\fR

The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*)
with a reference count of at least one.  The ownership of that
reference will be transferred to the Tcl core for release (when the
core has finished with it) via a call to \fBTcl_DecrRefCount\fR.  Must
not be specified at the same time as \fBTCL_TRACE_RESULT_DYNAMIC\fR.

.PP
Whenever one of the specified operations occurs on the variable,
\fIproc\fR will be invoked.
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.CS
typedef char *Tcl_VarTraceProc(
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
.PP
The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and
\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR,
\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively,
except that the name of the variable consists of two parts.
\fIName1\fR gives the name of a scalar variable or array,
and \fIname2\fR gives the name of an element within an array.
.VS 8.1
When \fIname2\fR is NULL, 
\fIname1\fR may contain both an array and an element name:
if the name contains an open parenthesis and ends with a
close parenthesis, then the value between the parentheses is
treated as an element name (which can have any string value) and
the characters before the first open
parenthesis are treated as the name of an array variable.
If \fIname2\fR is NULL and \fIname1\fR does not refer
to an array element 
.VE
it means that either the variable is
a scalar or the trace is to be set on the entire array rather
than an individual element (see WHOLE-ARRAY TRACES below for
more information). 


.SH "ACCESSING VARIABLES DURING TRACES"







<









<







201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216

217
218
219
220
221
222
223
.PP
The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and
\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR,
\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively,
except that the name of the variable consists of two parts.
\fIName1\fR gives the name of a scalar variable or array,
and \fIname2\fR gives the name of an element within an array.

When \fIname2\fR is NULL, 
\fIname1\fR may contain both an array and an element name:
if the name contains an open parenthesis and ends with a
close parenthesis, then the value between the parentheses is
treated as an element name (which can have any string value) and
the characters before the first open
parenthesis are treated as the name of an array variable.
If \fIname2\fR is NULL and \fIname1\fR does not refer
to an array element 

it means that either the variable is
a scalar or the trace is to be set on the entire array rather
than an individual element (see WHOLE-ARRAY TRACES below for
more information). 


.SH "ACCESSING VARIABLES DURING TRACES"
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
.PP
Under normal conditions trace procedures should return NULL, indicating
successful completion.
If \fIproc\fR returns a non-NULL value it signifies that an
error occurred.
The return value must be a pointer to a static character string
containing an error message,
.VS 8.4
unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and
\fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is
either a dynamic string (to be released with \fBckfree\fR) or a
Tcl_Obj* (cast to char* and to be released with
\fBTcl_DecrRefCount\fR) containing the error message.
.VE 8.4
If a trace procedure returns an error, no further traces are
invoked for the access and the traced access aborts with the
given message.
Trace procedures can use this facility to make variables
read-only, for example (but note that the value of the variable
will already have been modified before the trace procedure is
called, so the trace procedure will have to restore the correct







<





<







315
316
317
318
319
320
321

322
323
324
325
326

327
328
329
330
331
332
333
.PP
Under normal conditions trace procedures should return NULL, indicating
successful completion.
If \fIproc\fR returns a non-NULL value it signifies that an
error occurred.
The return value must be a pointer to a static character string
containing an error message,

unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and
\fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is
either a dynamic string (to be released with \fBckfree\fR) or a
Tcl_Obj* (cast to char* and to be released with
\fBTcl_DecrRefCount\fR) containing the error message.

If a trace procedure returns an error, no further traces are
invoked for the access and the traced access aborts with the
given message.
Trace procedures can use this facility to make variables
read-only, for example (but note that the value of the variable
will already have been modified before the trace procedure is
called, so the trace procedure will have to restore the correct

Changes to doc/Utf.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94




95




96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Utf.3,v 1.20 2004/10/07 16:05:15 dkf Exp $
'\" 
.so man.macros
.TH Utf 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
typedef ... Tcl_UniChar;
.sp
int
\fBTcl_UniCharToUtf\fR(\fIch, buf\fR)
.sp
int
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)
.VS 8.4
.sp
char *
\fBTcl_UniCharToUtfDString\fR(\fIuniStr, numChars, dstPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_UtfToUniCharDString\fR(\fIsrc, len, dstPtr\fR)
.VE 8.4
.sp
int
\fBTcl_UniCharLen\fR(\fIuniStr\fR)
.sp
int
\fBTcl_UniCharNcmp\fR(\fIuniStr, uniStr, num\fR)
.VS 8.4
.sp
int
\fBTcl_UniCharNcasecmp\fR(\fIuniStr, uniStr, num\fR)
.sp
int
\fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR)
.VE 8.4
.sp
int
\fBTcl_UtfNcmp\fR(\fIsrc, src, num\fR)
.sp
int
\fBTcl_UtfNcasecmp\fR(\fIsrc, src, num\fR)
.sp
int
\fBTcl_UtfCharComplete\fR(\fIsrc, len\fR)
.sp
int 
\fBTcl_NumUtfChars\fR(\fIsrc, len\fR)
.VS 8.4
.sp
const char *
\fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR)
.sp
const char *
\fBTcl_UtfFindLast\fR(\fIsrc, ch\fR)
.sp
const char *
\fBTcl_UtfNext\fR(\fIsrc\fR)
.sp
const char *
\fBTcl_UtfPrev\fR(\fIsrc, start\fR)
.VE 8.4
.sp
Tcl_UniChar
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
.VS 8.4
.sp
const char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)
.VE 8.4
.sp
int
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *uniPattern in/out
.AP char *buf out
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored.  At most
\fBTCL_UTF_MAX\fR bytes are stored in the buffer.
.AP int ch in
The Tcl_UniChar to be converted or examined.
.AP Tcl_UniChar *chPtr out
Filled with the Tcl_UniChar represented by the head of the UTF-8 string.
.AP "const char" *src in
Pointer to a UTF-8 string.




.AP "const Tcl_UniChar" *uniStr in




A null-terminated Unicode string.
.AP "const Tcl_UniChar" *uniPattern in
A null-terminated Unicode string.
.AP int len in
The length of the UTF-8 string in bytes (not UTF-8 characters).  If
negative, all bytes up to the first null byte are used.
.AP int numChars in
The length of the Unicode string in characters.  Must be greater than or
equal to 0.
.AP "Tcl_DString" *dstPtr in/out
A pointer to a previously initialized \fBTcl_DString\fR.
.AP "unsigned long" num in
The number of characters to compare.
.AP "const char" *start in
Pointer to the beginning of a UTF-8 string.
.AP int index in
The index of a character (not byte) in the UTF-8 string.
.AP int *readPtr out
If non-NULL, filled with the number of bytes in the backslash sequence, 
including the backslash character.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
.AP int nocase in
.VS 8.4
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
.VE 8.4
.BE

.SH DESCRIPTION
.PP
These routines convert between UTF-8 strings and Tcl_UniChars.  A
Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size
quantity.  A UTF-8 character is a Unicode character represented as






|

















<


|


|
<





|
<


|



<


|


|


|


|
<












<



<



<














>
>
>
>

>
>
>
>



|


|


|

|












<


<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30

31
32
33
34
35
36

37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53
54

55
56
57
58
59
60
61
62
63
64
65
66

67
68
69

70
71
72

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

120
121

122
123
124
125
126
127
128
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Utf.3,v 1.20.2.2 2005/05/05 17:55:24 kennykb Exp $
'\" 
.so man.macros
.TH Utf 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
typedef ... Tcl_UniChar;
.sp
int
\fBTcl_UniCharToUtf\fR(\fIch, buf\fR)
.sp
int
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)

.sp
char *
\fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR)

.sp
int
\fBTcl_UniCharLen\fR(\fIuniStr\fR)
.sp
int
\fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR)

.sp
int
\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR)
.sp
int
\fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR)

.sp
int
\fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR)
.sp
int
\fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR)
.sp
int
\fBTcl_UtfCharComplete\fR(\fIsrc, length\fR)
.sp
int 
\fBTcl_NumUtfChars\fR(\fIsrc, length\fR)

.sp
const char *
\fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR)
.sp
const char *
\fBTcl_UtfFindLast\fR(\fIsrc, ch\fR)
.sp
const char *
\fBTcl_UtfNext\fR(\fIsrc\fR)
.sp
const char *
\fBTcl_UtfPrev\fR(\fIsrc, start\fR)

.sp
Tcl_UniChar
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)

.sp
const char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)

.sp
int
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *uniPattern in/out
.AP char *buf out
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored.  At most
\fBTCL_UTF_MAX\fR bytes are stored in the buffer.
.AP int ch in
The Tcl_UniChar to be converted or examined.
.AP Tcl_UniChar *chPtr out
Filled with the Tcl_UniChar represented by the head of the UTF-8 string.
.AP "const char" *src in
Pointer to a UTF-8 string.
.AP "const char" *cs in
Pointer to a UTF-8 string.
.AP "const char" *ct in
Pointer to a UTF-8 string.
.AP "const Tcl_UniChar" *uniStr in
A null-terminated Unicode string.
.AP "const Tcl_UniChar" *ucs in
A null-terminated Unicode string.
.AP "const Tcl_UniChar" *uct in
A null-terminated Unicode string.
.AP "const Tcl_UniChar" *uniPattern in
A null-terminated Unicode string.
.AP int length in
The length of the UTF-8 string in bytes (not UTF-8 characters).  If
negative, all bytes up to the first null byte are used.
.AP int uniLength in
The length of the Unicode string in characters.  Must be greater than or
equal to 0.
.AP "Tcl_DString" *dsPtr in/out
A pointer to a previously initialized \fBTcl_DString\fR.
.AP "unsigned long" numChars in
The number of characters to compare.
.AP "const char" *start in
Pointer to the beginning of a UTF-8 string.
.AP int index in
The index of a character (not byte) in the UTF-8 string.
.AP int *readPtr out
If non-NULL, filled with the number of bytes in the backslash sequence, 
including the backslash character.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
.AP int nocase in

Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).

.BE

.SH DESCRIPTION
.PP
These routines convert between UTF-8 strings and Tcl_UniChars.  A
Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size
quantity.  A UTF-8 character is a Unicode character represented as
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
is known to be null-terminated, this will not happen.  If the input is
not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first
byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and
0x00ff and return 1.  
.PP
\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR.
You must specify the length of the given Unicode string.
The return value is a pointer to the UTF-8 representation of the
Unicode string.  Storage for the return value is appended to the
end of the \fBTcl_DString\fR.
.PP
\fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode,
storing the result in the previously initialized \fBTcl_DString\fR.
You may either specify the length of the given UTF-8 string or "-1",

in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
calculate the length.  The return value is a pointer to the Unicode
representation of the UTF-8 string.  Storage for the return value
is appended to the end of the \fBTcl_DString\fR.  The Unicode string
is terminated with a Unicode null character.
.PP
\fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode
characters.  It accepts a null-terminated Unicode string and returns
the number of Unicode characters (not bytes) in that string.
.PP
\fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to
\fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters.
They accept two null-terminated Unicode strings and the number of characters
to compare.  Both strings are assumed to be at least \fIlen\fR characters
long. \fBTcl_UniCharNcmp\fR  compares the two strings character-by-character
according to the Unicode character ordering.  It returns an integer greater
than, equal to, or less than 0 if the first string is greater than, equal
to, or less than the second string respectively.  \fBTcl_UniCharNcasecmp\fR
is the Unicode case insensitive version.
.PP
.VS 8.4
\fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to
\fBTcl_StringCaseMatch\fR.  It accepts a null-terminated Unicode string,
a Unicode pattern, and a boolean value specifying whether the match should
be case sensitive and returns whether the string matches the pattern.
.VE 8.4
.PP
\fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It
accepts two null-terminated UTF-8 strings and the number of characters
to compare.  (Both strings are assumed to be at least \fIlen\fR
characters long.)  \fBTcl_UtfNcmp\fR compares the two strings
character-by-character according to the Unicode character ordering.
It returns an integer greater than, equal to, or less than 0 if the
first string is greater than, equal to, or less than the second string
respectively.
.PP
\fBTcl_UtfNcasecmp\fR corresponds to \fBstrncasecmp\fR for UTF-8
strings.  It is similar to \fBTcl_UtfNcmp\fR except comparisons ignore
differences in case when comparing upper, lower or title case
characters.
.PP
\fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR
of length \fIlen\fR bytes is long enough to be decoded by
\fBTcl_UtfToUniChar\fR, or 0 otherwise.  This function does not guarantee
that the UTF-8 string is properly formed.  This routine is used by
procedures that are operating on a byte at a time and need to know if a
full Tcl_UniChar has been seen.
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR.  The length of the source string is \fIlen\fR bytes.  If the
length is negative, all bytes up to the first null byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR
in the null-terminated UTF-8 string \fIsrc\fR.  The null terminator is
considered part of the UTF-8 string.  
.PP







|






|
>
|












|






<




<



|












|







|







144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

180
181
182
183

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
is known to be null-terminated, this will not happen.  If the input is
not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first
byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and
0x00ff and return 1.  
.PP
\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR.
You must specify \fIuniLength\fR, the length of the given Unicode string.
The return value is a pointer to the UTF-8 representation of the
Unicode string.  Storage for the return value is appended to the
end of the \fBTcl_DString\fR.
.PP
\fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode,
storing the result in the previously initialized \fBTcl_DString\fR.
In the argument \fIlength\fR, you may either specify the length of
the given UTF-8 string in bytes or "-1", in which
case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
calculate the length.  The return value is a pointer to the Unicode
representation of the UTF-8 string.  Storage for the return value
is appended to the end of the \fBTcl_DString\fR.  The Unicode string
is terminated with a Unicode null character.
.PP
\fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode
characters.  It accepts a null-terminated Unicode string and returns
the number of Unicode characters (not bytes) in that string.
.PP
\fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to
\fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters.
They accept two null-terminated Unicode strings and the number of characters
to compare.  Both strings are assumed to be at least \fInumChars\fR characters
long. \fBTcl_UniCharNcmp\fR  compares the two strings character-by-character
according to the Unicode character ordering.  It returns an integer greater
than, equal to, or less than 0 if the first string is greater than, equal
to, or less than the second string respectively.  \fBTcl_UniCharNcasecmp\fR
is the Unicode case insensitive version.
.PP

\fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to
\fBTcl_StringCaseMatch\fR.  It accepts a null-terminated Unicode string,
a Unicode pattern, and a boolean value specifying whether the match should
be case sensitive and returns whether the string matches the pattern.

.PP
\fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It
accepts two null-terminated UTF-8 strings and the number of characters
to compare.  (Both strings are assumed to be at least \fInumChars\fR
characters long.)  \fBTcl_UtfNcmp\fR compares the two strings
character-by-character according to the Unicode character ordering.
It returns an integer greater than, equal to, or less than 0 if the
first string is greater than, equal to, or less than the second string
respectively.
.PP
\fBTcl_UtfNcasecmp\fR corresponds to \fBstrncasecmp\fR for UTF-8
strings.  It is similar to \fBTcl_UtfNcmp\fR except comparisons ignore
differences in case when comparing upper, lower or title case
characters.
.PP
\fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR
of \fIlength\fR bytes is long enough to be decoded by
\fBTcl_UtfToUniChar\fR, or 0 otherwise.  This function does not guarantee
that the UTF-8 string is properly formed.  This routine is used by
procedures that are operating on a byte at a time and need to know if a
full Tcl_UniChar has been seen.
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR.  The length of the source string is \fIlength\fR bytes.  If the
length is negative, all bytes up to the first null byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR
in the null-terminated UTF-8 string \fIsrc\fR.  The null terminator is
considered part of the UTF-8 string.  
.PP

Changes to doc/array.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: array.n,v 1.13 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH array n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
array \- Manipulate array variables







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: array.n,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH array n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
array \- Manipulate array variables
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
search identifier that must be used in \fBarray nextelement\fR
and \fBarray donesearch\fR commands; it allows multiple
searches to be underway simultaneously for the same array.
It is currently more efficient and easier to use either the \fBarray
get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate
over all but very large arrays.  See the examples below for how to do
this.
.VS 8.4
.TP
\fBarray statistics \fIarrayName\fR
Returns statistics about the distribution of data within the hashtable
that represents the array.  This information includes the number of
entries in the table, the number of buckets, and the utilization of
the buckets.
.VE 8.4
.VS 8.3
.TP
\fBarray unset \fIarrayName\fR ?\fIpattern\fR?
Unsets all of the elements in the array that match \fIpattern\fR (using the
matching rules of \fBstring match\fR).  If \fIarrayName\fR isn't the name
of an array variable or there are no matching elements in the array, no
error will be raised.  If \fIpattern\fR is omitted and \fIarrayName\fR is
an array variable, then the command unsets the entire array.
The command always returns an empty string.
.VE 8.3
.SH EXAMPLES
.CS
\fBarray set\fR colorcount {
   red   1
   green 5
   blue  4
   white 9







<






<
<








<







118
119
120
121
122
123
124

125
126
127
128
129
130


131
132
133
134
135
136
137
138

139
140
141
142
143
144
145
search identifier that must be used in \fBarray nextelement\fR
and \fBarray donesearch\fR commands; it allows multiple
searches to be underway simultaneously for the same array.
It is currently more efficient and easier to use either the \fBarray
get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate
over all but very large arrays.  See the examples below for how to do
this.

.TP
\fBarray statistics \fIarrayName\fR
Returns statistics about the distribution of data within the hashtable
that represents the array.  This information includes the number of
entries in the table, the number of buckets, and the utilization of
the buckets.


.TP
\fBarray unset \fIarrayName\fR ?\fIpattern\fR?
Unsets all of the elements in the array that match \fIpattern\fR (using the
matching rules of \fBstring match\fR).  If \fIarrayName\fR isn't the name
of an array variable or there are no matching elements in the array, no
error will be raised.  If \fIpattern\fR is omitted and \fIarrayName\fR is
an array variable, then the command unsets the entire array.
The command always returns an empty string.

.SH EXAMPLES
.CS
\fBarray set\fR colorcount {
   red   1
   green 5
   blue  4
   white 9

Changes to doc/binary.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: binary.n,v 1.24 2004/11/12 11:03:16 dkf Exp $
'\" 
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
binary \- Insert and extract fields from binary strings






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: binary.n,v 1.24.2.1 2005/03/02 21:25:20 kennykb Exp $
'\" 
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
binary \- Insert and extract fields from binary strings
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR
.CE
If you want to produce an unsigned value, then you can mask the return 
value to the desired size.  For example, to produce an unsigned short 
value:
.CS
set val [expr {$val & 0xFFFF}]; \fI# val == 0x8000\fR
.CE
.PP
Each type-count pair moves an imaginary cursor through the binary data,
reading bytes from the current position.  The cursor is initially
at position 0 at the beginning of the data.  The type may be any one of
the following characters:
.IP \fBa\fR 5







|







427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR
.CE
If you want to produce an unsigned value, then you can mask the return 
value to the desired size.  For example, to produce an unsigned short 
value:
.CS
set val [expr { $val & 0xFFFF }]; \fI# val == 0x8000\fR
.CE
.PP
Each type-count pair moves an imaginary cursor through the binary data,
reading bytes from the current position.  The cursor is initially
at position 0 at the beginning of the data.  The type may be any one of
the following characters:
.IP \fBa\fR 5
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
\fBbinary scan\fR \\x07\\x86\\x05 c2c* var1 var2
.CE
will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR
stored in \fIvar2\fR.  Note that the integers returned are signed, but
they can be converted to unsigned 8-bit quantities using an expression
like:
.CS
expr { ( $num + 0x100 ) % 0x100 }
.CE
.RE
.IP \fBs\fR 5
The data is interpreted as \fIcount\fR 16-bit signed integers
represented in little-endian byte order.  The integers are stored in
the corresponding variable as a list.  If \fIcount\fR is \fB*\fR, then
all of the remaining bytes in \fIstring\fR will be scanned.  If
\fIcount\fR is omitted, then one 16-bit integer will be scanned.  For
example,
.RS
.CS
\fBbinary scan\fR \\x05\\x00\\x07\\x00\\xf0\\xff s2s* var1 var2
.CE
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR
stored in \fIvar2\fR.  Note that the integers returned are signed, but
they can be converted to unsigned 16-bit quantities using an expression
like:
.CS
expr { ( $num + 0x10000 ) % 0x10000 }
.CE
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that the data is interpreted
as \fIcount\fR 16-bit signed integers represented in big-endian byte
order.  For example,
.RS







|


















|







525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
\fBbinary scan\fR \\x07\\x86\\x05 c2c* var1 var2
.CE
will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR
stored in \fIvar2\fR.  Note that the integers returned are signed, but
they can be converted to unsigned 8-bit quantities using an expression
like:
.CS
set num [expr { $num & 0xff }]
.CE
.RE
.IP \fBs\fR 5
The data is interpreted as \fIcount\fR 16-bit signed integers
represented in little-endian byte order.  The integers are stored in
the corresponding variable as a list.  If \fIcount\fR is \fB*\fR, then
all of the remaining bytes in \fIstring\fR will be scanned.  If
\fIcount\fR is omitted, then one 16-bit integer will be scanned.  For
example,
.RS
.CS
\fBbinary scan\fR \\x05\\x00\\x07\\x00\\xf0\\xff s2s* var1 var2
.CE
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR
stored in \fIvar2\fR.  Note that the integers returned are signed, but
they can be converted to unsigned 16-bit quantities using an expression
like:
.CS
set num [expr { $num & 0xffff }]
.CE
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that the data is interpreted
as \fIcount\fR 16-bit signed integers represented in big-endian byte
order.  For example,
.RS
579
580
581
582
583
584
585
586
587




588
589
590
591
592
593
594
example,
.RS
.CS
set str \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff
\fBbinary scan\fR $str i2i* var1 var2
.CE
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR
stored in \fIvar2\fR.  Note that the integers returned are signed and
cannot be represented by Tcl as unsigned values.




.RE
.IP \fBI\fR 5
This form is the same as \fBI\fR except that the data is interpreted
as \fIcount\fR 32-bit signed integers represented in big-endian byte
order.  For example,
.RS
.CS







|
|
>
>
>
>







579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
example,
.RS
.CS
set str \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff
\fBbinary scan\fR $str i2i* var1 var2
.CE
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR
stored in \fIvar2\fR.  Note that the integers returned are signed, but
they can be converted to unsigned 32-bit quantities using an expression
like:
.CS
set num [expr { $num & 0xffffffff }]
.CE
.RE
.IP \fBI\fR 5
This form is the same as \fBI\fR except that the data is interpreted
as \fIcount\fR 32-bit signed integers represented in big-endian byte
order.  For example,
.RS
.CS

Added doc/chan.n.

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
'\" 
'\" Copyright (c) 2005 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: chan.n,v 1.2.6.2 2005/07/12 20:36:15 kennykb Exp $
.so man.macros
.TH chan n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
chan \- Read, write and manipulate channels
.SH SYNOPSIS
\fBchan \fIoption\fR ?\fIarg arg ...\fR?
.BE

.SH DESCRIPTION
.PP
This command provides several operations for reading from, writing to
and otherwise manipulating open channels (such as have been created
with the \fBopen\fR and \fBsocket\fR commands, or the default named
channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to
the process's standard input, output and error streams respectively).
\fIOption\fR indicates what to do with the channel; any unique
abbreviation for \fIoption\fR is acceptable. Valid options are:
.TP
\fBchan blocked \fIchannelId\fR
.
This tests whether the last input operation on the channel called
\fIchannelId\fR failed because it would have otherwise caused the
process to block, and returns 1 if that was the case. It returns 0
otherwise. Note that this only ever returns 1 when the channel has
been configured to be non-blocking; all Tcl channels have blocking
turned on by default.
.TP
\fBchan close \fIchannelId\fR
.
Close and destroy the channel called \fIchannelId\fR. Note that this
deletes all existing file-events registered on the channel.
.RS
.PP
As part of closing the channel, all buffered output is flushed to the
channel's outpuot device, any buffered input is discarded, the
underlying operating system resource is closed and \fIchannelId\fR
becomes unavailable for future use.
.PP
If the channel is blocking, the command does not return until all
output is flushed.  If the channel is nonblocking and there is
unflushed output, the channel remains open and the command returns
immediately; output will be flushed in the background and the channel
will be closed when all the flushing is complete.
.PP
If \fIchannelId\fR is a blocking channel for a command pipeline then
\fBchan close\fR waits for the child processes to complete.
.PP
If the channel is shared between interpreters, then \fBchan close\fR
makes \fIchannelId\fR unavailable in the invoking interpreter but has
no other effect until all of the sharing interpreters have closed the
channel. When the last interpreter in which the channel is registered
invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions
described above occur. See the \fBinterp\fR command for a description
of channel sharing.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.  Channels are switched to blocking mode, to
ensure that all output is correctly flushed before the process exits.
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output.  If a command in a command
pipeline created with \fBopen\fR returns an error, \fBchan close\fR
generates an error (similar to the \fBexec\fR command.)
.RE
.TP
\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
.
Query or set the configuration options of the channel named
\fIchannelId\fR.
.RS
.PP
If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the
command returns a list containing alternating option names and values
for the channel.  If \fIoptionName\fR is supplied but no \fIvalue\fR
then the command returns the current value of the given option.  If
one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied,
the command sets each of the named options to the corresponding
\fIvalue\fR; in this case the return value is an empty string.
.PP
The options described below are supported for all channels. In
addition, each channel type may add options that only it supports. See
the manual entry for the command that creates each type of channels
for the options that that specific type of channel supports. For
example, see the manual entry for the \fBsocket\fR command for its
additional options.
.TP
\fB\-blocking\fR \fIboolean\fR
.
The \fB\-blocking\fR option determines whether I/O operations on the
channel can cause the process to block indefinitely.  The value of the
option must be a proper boolean value.  Channels are normally in
blocking mode; if a channel is placed into nonblocking mode it will
affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan
puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the
documentation for those commands for details.  For nonblocking mode to
work correctly, the application must be using the Tcl event loop
(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR
command).
.TP
\fB\-buffering\fR \fInewValue\fR
.
If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output
until its internal buffer is full or until the \fBchan flush\fR
command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O
system will automatically flush output for the channel whenever a
newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O
system will flush automatically after every output operation.  The
default is for \fB\-buffering\fR to be set to \fBfull\fR except for
channels that connect to terminal-like devices; for these channels the
initial setting is \fBline\fR.  Additionally, \fBstdin\fR and
\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set
to \fBnone\fR.
.TP
\fB\-buffersize\fR \fInewSize\fR
.
\fINewvalue\fR must be an integer; its value is used to set the size
of buffers, in bytes, subsequently allocated for this channel to store
input or output. \fINewvalue\fR must be a number of no more than one
million, allowing buffers of up to one million bytes in size.
.TP
\fB\-encoding\fR \fIname\fR
.
This option is used to specify the encoding of the channel as one of
the named encodings returned by \fBencoding names\fR or the special
value \fBbinary\fR, so that the data can be converted to and from
Unicode for use in Tcl.  For instance, in order for Tcl to read
characters from a Japanese file in \fBshiftjis\fR and properly process
and display the contents, the encoding would be set to \fBshiftjis\fR.
Thereafter, when reading from the channel, the bytes in the Japanese
file would be converted to Unicode as they are read.  Writing is also
supported \- as Tcl strings are written to the channel they will
automatically be converted to the specified encoding on output.
.RS
.PP
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be \fBbinary\fR.  Tcl
will then assign no interpretation to the data in the file and simply
read or write raw bytes.  The Tcl \fBbinary\fR command can be used to
manipulate this byte-oriented data.  It is usually better to set the
\fB\-translation\fR option to \fBbinary\fR when you want to transfer
binary data, as this turns off the other automatic interpretations of
the bytes in the stream as well.
.PP
The default encoding for newly opened channels is the same platform-
and locale-dependent system encoding used for interfacing with the
operating system, as returned by \fBencoding system\fR.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
.
This option supports DOS file systems that use Control-z (\ex1a) as an
end of file marker.  If \fIchar\fR is not an empty string, then this
character signals end-of-file when it is encountered during input.
For output, the end-of-file character is output when the channel is
closed.  If \fIchar\fR is the empty string, then there is no special
end of file character marker.  For read-write channels, a two-element
list specifies the end of file marker for input and output,
respectively.  As a convenience, when setting the end-of-file
character for a read-write channel you can specify a single value that
will apply to both reading and writing.  When querying the end-of-file
character of a read-write channel, a two-element list will always be
returned.  The default value for \fB\-eofchar\fR is the empty string
in all cases except for files under Windows.  In that case the
\fB\-eofchar\fR is Control-z (\ex1a) for reading and the empty string
for writing.
.TP
\fB\-translation\fR \fImode\fR
.TP
\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR 
.
In Tcl scripts the end of a line is always represented using a single
newline character (\en).  However, in actual files and devices the end
of a line may be represented differently on different platforms, or
even for different devices on the same platform.  For example, under
UNIX newlines are used in files, whereas carriage-return-linefeed
sequences are normally used in network connections.  On input (i.e.,
with \fBchan gets\fP and \fBchan read\fP) the Tcl I/O system
automatically translates the external end-of-line representation into
newline characters.  Upon output (i.e., with \fBchan puts\fP), the I/O
system translates newlines to the external end-of-line representation.
The default translation mode, \fBauto\fP, handles all the common cases
automatically, but the \fB\-translation\fR option provides explicit
control over the end of line translations.
.RS
.PP
The value associated with \fB\-translation\fR is a single item for
read-only and write-only channels.  The value is a two-element list for
read-write channels; the read translation mode is the first element of
the list, and the write translation mode is the second element.  As a
convenience, when setting the translation mode for a read-write channel
you can specify a single value that will apply to both reading and
writing.  When querying the translation mode of a read-write channel, a
two-element list will always be returned.  The following values are
currently supported:
.TP
\fBauto\fR
.
As the input translation mode, \fBauto\fR treats any of newline
(\fBlf\fP), carriage return (\fBcr\fP), or carriage return followed by
a newline (\fBcrlf\fP) as the end of line representation.  The end of
line representation can even change from line-to-line, and all cases
are translated to a newline.  As the output translation mode,
\fBauto\fR chooses a platform specific representation; for sockets on
all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses
\fBlf\fR, and for the various flavors of Windows it chooses
\fBcrlf\fR.  The default setting for \fB\-translation\fR is \fBauto\fR
for both input and output.
.TP
\fBbinary\fR 
.
No end-of-line translations are performed.  This is nearly identical
to \fBlf\fP mode, except that in addition \fBbinary\fP mode also sets
the end-of-file character to the empty string (which disables it) and
sets the encoding to \fBbinary\fR (which disables encoding filtering).
See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more
information.
.TP
\fBcr\fR
.
The end of a line in the underlying file or device is represented by a
single carriage return character.  As the input translation mode,
\fBcr\fP mode converts carriage returns to newline characters.  As the
output translation mode, \fBcr\fP mode translates newline characters
to carriage returns.
.TP
\fBcrlf\fR
.
The end of a line in the underlying file or device is represented by a
carriage return character followed by a linefeed character.  As the
input translation mode, \fBcrlf\fP mode converts
carriage-return-linefeed sequences to newline characters.  As the
output translation mode, \fBcrlf\fP mode translates newline characters
to carriage-return-linefeed sequences.  This mode is typically used on
Windows platforms and for network connections.
.TP
\fBlf\fR
.
The end of a line in the underlying file or device is represented by a
single newline (linefeed) character.  In this mode no translations
occur during either input or output.  This mode is typically used on
UNIX platforms.
.RE
.RE
.TP
\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.
Copy data from the channel \fIinputChan\fR, which must have been
opened for reading, to the channel \fIoutputChan\fR, which must have
been opened for writing. The \fBchan copy\fR command leverages the
buffering in the Tcl I/O system to avoid extra copies and to avoid
buffering too much data in main memory when copying large files to
slow destinations like network sockets.
.RS
.PP
The \fBchan copy\fP command transfers data from \fIinputChan\fR until
end of file or \fIsize\fP bytes have been transferred. If no
\fB\-size\fP argument is given, then the copy goes until end of file.
All the data read from \fIinputChan\fR is copied to \fIoutputChan\fR.
Without the \fB\-command\fP option, \fBchan copy\fP blocks until the
copy is complete and returns the number of bytes written to
\fIoutputChan\fR.
.PP
The \fB\-command\fP argument makes \fBchan copy\fP work in the
background.  In this case it returns immediately and the
\fIcallback\fP is invoked later when the copy completes.  The
\fIcallback\fP is called with one or two additional arguments that
indicates how many bytes were written to \fIoutputChan\fR.  If an
error occurred during the background copy, the second argument is the
error string associated with the error.  With a background copy, it is
not necessary to put \fIinputChan\fR or \fIoutputChan\fR into
non-blocking mode; the \fBchan copy\fP command takes care of that
automatically.  However, it is necessary to enter the event loop by
using the \fBvwait\fP command or by using Tk.
.PP
You are not allowed to do other I/O operations with \fIinputChan\fR or
\fIoutputChan\fR during a background \fBchan copy\fR.  If either
\fIinputChan\fR or \fIoutputChan\fR get closed while the copy is in
progress, the current copy is stopped and the command callback is
\fInot\fP made.  If \fIinputChan\fR is closed, then all data already
queued for \fIoutputChan\fR is written out.
.PP
Note that \fIinputChan\fR can become readable during a background
copy.  You should turn off any \fBchan event\fP or \fBfileevent\fR
handlers during a background copy so those handlers do not interfere
with the copy.  Any I/O attempted by a \fBchan event\fR or
\fBfileevent\fP handler will get a "channel busy" error.
.PP
\fBChan copy\fR translates end-of-line sequences in \fIinputChan\fR
and \fIoutputChan\fR according to the \fB\-translation\fR option for
these channels (see \fBchan configure\fR above).  The translations
mean that the number of bytes read from \fIinputChan\fR can be
different than the number of bytes written to \fIoutputChan\fR.  Only
the number of bytes written to \fIoutputChan\fR is reported, either as
the return value of a synchronous \fBchan copy\fP or as the argument
to the callback for an asynchronous \fBchan copy\fP.
.PP
\fBChan copy\fR obeys the encodings and character translations
configured for the channels. This means that the incoming characters
are converted internally first UTF-8 and then into the encoding of the
channel \fBchan copy\fR writes to (see \fBchan configure\fR above for
details on the \fB\-encoding\fR and \fB\-translation\fR options). No
conversion is done if both channels are set to encoding \fBbinary\fR
and have matching translations. If only the output channel is set to
encoding \fBbinary\fR the system will write the internal UTF-8
representation of the incoming characters. If only the input channel
is set to encoding \fBbinary\fR the system will assume that the
incoming bytes are valid UTF-8 characters and convert them according
to the output encoding. The behaviour of the system for bytes which
are not valid UTF-8 characters is undefined in this case.
.RE
.TP
\fBchan eof \fIchannelId\fR
.
Test whether the last input operation on the channel called
\fIchannelId\fR failed because the end of the data stream was reached,
returning 1 if end-fo-file was reached, and 0 otherwise.
.TP
\fBchan event \fIchannelId event\fR ?\fIscript\fR?
.
Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile
event handler\fR to be called whenever the channel called
\fIchannelId\fR enters the state described by \fIevent\fR (which must
be either \fBreadable\fR or \fBwritable\fR); only one such handler may
be installed per event per channel at a time.  If \fIscript\fR is the
empty string, the current handler is deleted (this also happens if the
channel is closed or the interpreter deleted).  If \fIscript\fR is
omitted, the currently installed script is returned (or an empty
string if no such handler is installed).  The callback is only
performed if the event loop is being serviced (e.g. via \fBvwait\fR or
\fBupdate\fR).
.RS
.PP
A file event handler is a binding between a channel and a script, such
that the script is evaluated whenever the channel becomes readable or
writable.  File event handlers are most commonly used to allow data to
be received from another process on an event-driven basis, so that the
receiver can continue to interact with the user or with other channels
while waiting for the data to arrive.  If an application invokes
\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is
no input data available, the process will block; until the input data
arrives, it will not be able to service other events, so it will
appear to the user to ``freeze up''.  With \fBchan event\fR, the
process can tell when data is present and only invoke \fBchan gets\fR
or \fBchan read\fR when they won't block.
.PP
A channel is considered to be readable if there is unread data
available on the underlying device.  A channel is also considered to
be readable if there is unread data in an input buffer, except in the
special case where the most recent attempt to read from the channel
was a \fBchan gets\fR call that could not find a complete line in the
input buffer.  This feature allows a file to be read a line at a time
in nonblocking mode using events.  A channel is also considered to be
readable if an end of file or error condition is present on the
underlying file or device.  It is important for \fIscript\fR to check
for these conditions and handle them appropriately; for example, if
there is no special check for end of file, an infinite loop may occur
where \fIscript\fR reads no data, returns, and is immediately invoked
again.
.PP
A channel is considered to be writable if at least one byte of data
can be written to the underlying file or device without blocking, or
if an error condition is present on the underlying file or device.
Note that client sockets opened in asynchronous mode become writable
when they become connected or if the connection fails.
.PP
Event-driven I/O works best for channels that have been placed into
nonblocking mode with the \fBchan configure\fR command.  In blocking
mode, a \fBchan puts\fR command may block if you give it more data
than the underlying file or device can accept, and a \fBchan gets\fR
or \fBchan read\fR command will block if you attempt to read more data
than is ready; no events will be processed while the commands block.
In nonblocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan
gets\fR never block.
.PP
The script for a file event is executed at global level (outside the
context of any Tcl procedure) in the interpreter in which the \fBchan
event\fR command was invoked.  If an error occurs while executing the
script then the command registered with \fBinterp bgerror\fR is used
to report the error.  In addition, the file event handler is deleted
if it ever returns an error; this is done in order to prevent infinite
loops due to buggy handlers.
.RE
.TP
\fBchan flush \fIchannelId\fR
.
Ensures that all pending output for the channel called \fIchannelId\fR
is written.
.RS
.PP
If the channel is in blocking mode the command does not return until
all the buffered output has been flushed to the channel. If the
channel is in nonblocking mode, the command may return before all
buffered output has been flushed; the remainder will be flushed in the
background as fast as the underlying file or device is able to absorb
it.
.RE
.TP
\fBchan gets \fIchannelId\fR ?\fIvarName\fR?
.
Reads the next line from the channel called \fIchannelId\fR. If
\fIvarName\fR is not specified, the result of the command will be the
line that has been read (without a trailing newline character) or an
empty string upon end-of-file or, in non-blocking mode, if the data
available is exhausted. If \fIvarName\fR is specified, the line that
has been read will be written to the variable called \fIvarName\fR and
result will be the number of characters that have been read or -1 if
end-of-file was reached or, in non-blocking mode, if the data
available is exhausted.
.RS
.PP
If an end-of-file occurs while part way through reading a line, the
partial line will be returned (or written into \fIvarName\fR). When
\fIvarName\fR is not specified, the end-of-file case can be
distinguished from an empty line using the \fBchan eof\fR command, and
the partial-line-but-nonblocking case can be distinguished with the
\fBchan blocked\fR command.
.RE
.TP
\fBchan names\fR ?\fIpattern\fR?
.
Produces a list of all channel names. If \fIpattern\fR is specified,
only those channel names that match it (according to the rules of
\fBstring match\fR) will be returned.
.TP
\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR
.
Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a
newline character. A trailing newline character is written unless the
optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is
omitted, the string is written to the standard output channel,
\fBstdout\fR.
.RS
.PP
Newline characters in the output are translated by \fBchan puts\fR to
platform-specific end-of-line sequences according to the currently
configured value of the \fB\-translation\fR option for the channel
(for example, on PCs newlines are normally replaced with
carriage-return-linefeed sequences; see \fBchan configure\fR above for
details).
.PP
Tcl buffers output internally, so characters written with \fBchan
puts\fR may not appear immediately on the output file or device; Tcl
will normally delay output until the buffer is full or the channel is
closed.  You can force output to appear immediately with the \fBchan
flush\fR command.
.PP
When the output buffer fills up, the \fBchan puts\fR command will
normally block until all the buffered data has been accepted for
output by the operating system.  If \fIchannelId\fR is in nonblocking
mode then the \fBchan puts\fR command will not block even if the
operating system cannot accept the data.  Instead, Tcl continues to
buffer the data and writes it in the background as fast as the
underlying file or device can accept it.  The application must use the
Tcl event loop for nonblocking output to work; otherwise Tcl never
finds out that the file or device is ready for more output data.  It
is possible for an arbitrarily large amount of data to be buffered for
a channel in nonblocking mode, which could consume a large amount of
memory.  To avoid wasting memory, nonblocking I/O should normally be
used in an event-driven fashion with the \fBchan event\fR command
(don't invoke \fBchan puts\fR unless you have recently been notified
via a file event that the channel is ready for more output data).
.RE
.TP
\fBchan read \fIchannelId\fR ?\fInumChars\fR?
.TP
\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR
.
In the first form, the result will be the next \fInumChars\fR
characters read from the channel named \fIchannelId\fR; if
\fInumChars\fR is omitted, all characters up to the point when the
channel would signal a failure (whether an end-of-file, blocked or
other error condition) are read. In the second form (i.e. when
\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be
given to indicate that any trailing newline in the string that has
been read should be trimmed.
.RS
.PP
If \fIchannelId\fR is in nonblocking mode, \fBchan read\fR may not
read as many characters as requested: once all available input has
been read, the command will return the data that is available rather
than blocking for more input.  If the channel is configured to use a
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character.  These
bytes will not be returned until a complete character is available or
end-of-file is reached.  The \fB\-nonewline\fR switch is ignored if
the command returns before reaching the end of the file.
.PP
\fBChan read\fR translates end-of-line sequences in the input into
newline characters according to the \fB\-translation\fR option for the
channel (see \fBchan configure\fR above for a discussion on the ways
in which \fBchan configure\fR will alter input).
.PP
When reading from a serial port, most applications should configure
the serial port channel to be nonblocking, like this:
.CS
\fBchan configure \fIchannelId \fB\-blocking \fI0\fR.
.CE
Then \fBchan read\fR behaves much like described above.  Note that
most serial ports are comparatively slow; it is entirely possible to
get a \fBreadable\fR event for each character read from them. Care
must be taken when using \fBchan read\fR on blocking serial ports:
.TP
\fBchan read \fIchannelId numChars\fR 
.
In this form \fBchan read\fR blocks until \fInumChars\fR have been
received from the serial port.
.TP
\fBchan read \fIchannelId\fR 
.
In this form \fBchan read\fR blocks until the reception of the
end-of-file character, see \fBchan configure -eofchar\fR. If there no
end-of-file character has been configured for the channel, then
\fBchan read\fR will block forever.
.RE
.TP
\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR?
.
Sets the current access position within the underlying data stream for
the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to
\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative)
and \fIorigin\fR must be one of the following:
.RS
.TP 10
\fBstart\fR
.
The new access position will be \fIoffset\fR bytes from the start
of the underlying file or device.
.TP 10
\fBcurrent\fR
.
The new access position will be \fIoffset\fR bytes from the current
access position; a negative \fIoffset\fR moves the access position
backwards in the underlying file or device.
.TP 10
\fBend\fR
.
The new access position will be \fIoffset\fR bytes from the end of the
file or device.  A negative \fIoffset\fR places the access position
before the end of file, and a positive \fIoffset\fR places the access
position after the end of file.
.PP
The \fIorigin\fR argument defaults to \fBstart\fR.
.PP
\fBChan seek\fR flushes all buffered output for the channel before the
command returns, even if the channel is in nonblocking mode.  It also
discards any buffered and unread input.  This command returns an empty
string.  An error occurs if this command is applied to channels whose
underlying file or device does not support seeking.
.PP
Note that \fIoffset\fR values are byte offsets, not character offsets.
Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes,
not characters, unlike \fBchan read\fR.
.RE
.TP
\fBchan tell \fIchannelId\fR
.
Returns a number giving the current access position within the
underlying data stream for the channel named \fIchannelId\fR. This
value returned is a byte offset that can be passed to \fBchan seek\fR
in order to set the channel to a particular position.  Note that this
value is in terms of bytes, not characters like \fBchan read\fR.  The
value returned is -1 for channels that do not support seeking.
.TP
\fBchan truncate \fIchannelId\fR ?\fIlength\fR?
.
Sets the byte length of the underlying data stream for the channel
named \fIchannelId\fR to be \fIlength\fR (or to the current byte
offset within the underlying data stream if \fIlength\fR is
omitted). The channel is flushed before truncation.

.SH "SEE ALSO"
close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n),
fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n),
socket(n), tell(n)

.SH KEYWORDS
channel, input, output, events, offset

Changes to doc/clock.n.

815
816
817
818
819
820
821
822



823
824
825
826

827
828
829
830
831
832
833
than 100, we treat the years 00-68 as 2000-2068 and the years 69-99
as 1969-1999.  Not all platforms can represent the years 38-70, so
an error may result if these years are used.
.TP
\fIISO 8601 point-in-time\fR
An ISO 8601 point-in-time specification, such as \fBCCyymmddThhmmss\fR,
where \fBT\fR is the literal T, "\fBCCyymmdd hhmmss\fR", or
\fBCCyymmddThh:mm:ss\fR.



.TP
\fIrelative time\fR
A specification relative to the current time.  The format is \fBnumber
unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR,

\fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR).  The
unit can be specified as a singular or plural, as in \fB3 weeks\fR.
These modifiers may also be specified:
\fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR,
\fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR.
The actual date is calculated according to the following steps.
.PP







|
>
>
>



|
>







815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
than 100, we treat the years 00-68 as 2000-2068 and the years 69-99
as 1969-1999.  Not all platforms can represent the years 38-70, so
an error may result if these years are used.
.TP
\fIISO 8601 point-in-time\fR
An ISO 8601 point-in-time specification, such as \fBCCyymmddThhmmss\fR,
where \fBT\fR is the literal T, "\fBCCyymmdd hhmmss\fR", or
\fBCCyymmddThh:mm:ss\fR. Note that only these three formats are accepted.
The command does \fInot\fR accept the full range of point-in-time
specifications specified in ISO8601.  Other formats can be recognized by
giving an explicit \fI-format\fR option to the \fBclock scan\fR command.
.TP
\fIrelative time\fR
A specification relative to the current time.  The format is \fBnumber
unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, 
\fBmonth\fR, \fBweek\fR, \fBday\fR,
\fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR).  The
unit can be specified as a singular or plural, as in \fB3 weeks\fR.
These modifiers may also be specified:
\fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR,
\fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR.
The actual date is calculated according to the following steps.
.PP

Changes to doc/close.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: close.n,v 1.8 2004/10/27 09:36:58 dkf Exp $
'\" 
.so man.macros
.TH close n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
close \- Close an open channel
.SH SYNOPSIS
\fBclose \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
Closes the channel given by \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.PP
All buffered output is flushed to the channel's output device,
any buffered input is discarded, the underlying file or device is closed,
and \fIchannelId\fR becomes unavailable for use.
.VS "" br
.PP
If the channel is blocking, the command does not return until all output
is flushed.
If the channel is nonblocking and there is unflushed output, the
channel remains open and the command
returns immediately; output will be flushed in the background and the
channel will be closed when all the flushing is complete.
.VE
.PP
If \fIchannelId\fR is a blocking channel for a command pipeline then
\fBclose\fR waits for the child processes to complete.
.VS "" br
.PP
If the channel is shared between interpreters, then \fBclose\fR
makes \fIchannelId\fR unavailable in the invoking interpreter but has no
other effect until all of the sharing interpreters have closed the
channel.
When the last interpreter in which the channel is registered invokes
\fBclose\fR, the cleanup actions described above occur. See the
\fBinterp\fR command for a description of channel sharing.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.  Channels are switched to blocking mode, to ensure
that all output is correctly flushed before the process exits.
.VE
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output.  If a command in a command
pipeline created with \fBopen\fR returns an error, \fBclose\fR
generates an error (similar to the \fBexec\fR command.)
.SH EXAMPLE
This illustrates how you can use Tcl to ensure that files get closed







|















<




<




<







<



<












<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27

28
29
30
31

32
33
34
35
36
37
38

39
40
41

42
43
44
45
46
47
48
49
50
51
52
53

54
55
56
57
58
59
60
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: close.n,v 1.8.2.1 2005/04/10 23:14:42 kennykb Exp $
'\" 
.so man.macros
.TH close n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
close \- Close an open channel
.SH SYNOPSIS
\fBclose \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
Closes the channel given by \fIchannelId\fR.
.PP

\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.

.PP
All buffered output is flushed to the channel's output device,
any buffered input is discarded, the underlying file or device is closed,
and \fIchannelId\fR becomes unavailable for use.

.PP
If the channel is blocking, the command does not return until all output
is flushed.
If the channel is nonblocking and there is unflushed output, the
channel remains open and the command
returns immediately; output will be flushed in the background and the
channel will be closed when all the flushing is complete.

.PP
If \fIchannelId\fR is a blocking channel for a command pipeline then
\fBclose\fR waits for the child processes to complete.

.PP
If the channel is shared between interpreters, then \fBclose\fR
makes \fIchannelId\fR unavailable in the invoking interpreter but has no
other effect until all of the sharing interpreters have closed the
channel.
When the last interpreter in which the channel is registered invokes
\fBclose\fR, the cleanup actions described above occur. See the
\fBinterp\fR command for a description of channel sharing.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.  Channels are switched to blocking mode, to ensure
that all output is correctly flushed before the process exits.

.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output.  If a command in a command
pipeline created with \fBopen\fR returns an error, \fBclose\fR
generates an error (similar to the \fBexec\fR command.)
.SH EXAMPLE
This illustrates how you can use Tcl to ensure that files get closed

Changes to doc/error.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: error.n,v 1.7 2004/11/20 00:17:31 dgp Exp $
'\" 
.so man.macros
.TH error n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
error \- Generate an error
.SH SYNOPSIS
\fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR?
.BE

.SH DESCRIPTION
.PP
Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be
unwound.  \fIMessage\fR is a string that is returned to the application
to indicate what went wrong.
.PP
The \fB-errorinfo\fB return option of an interpreter is used
to accumulate a stack trace of what was in progress when an
error occurred; as nested commands unwind,
the Tcl interpreter adds information to the \fB-errorinfo\fR
return option.  If the \fIinfo\fR argument is present, it is
used to initialize the \fB-errorinfo\fR return options and
the first increment of unwind information
will not be added by the Tcl interpreter.  







|

















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: error.n,v 1.7.2.1 2004/12/08 18:24:35 kennykb Exp $
'\" 
.so man.macros
.TH error n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
error \- Generate an error
.SH SYNOPSIS
\fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR?
.BE

.SH DESCRIPTION
.PP
Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be
unwound.  \fIMessage\fR is a string that is returned to the application
to indicate what went wrong.
.PP
The \fB-errorinfo\fR return option of an interpreter is used
to accumulate a stack trace of what was in progress when an
error occurred; as nested commands unwind,
the Tcl interpreter adds information to the \fB-errorinfo\fR
return option.  If the \fIinfo\fR argument is present, it is
used to initialize the \fB-errorinfo\fR return options and
the first increment of unwind information
will not be added by the Tcl interpreter.  

Changes to doc/expr.n.

1
2
3

4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: expr.n,v 1.18 2004/10/27 09:36:58 dkf Exp $
'\" 
.so man.macros
.TH expr n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
expr \- Evaluate an expression



>




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\" Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. All rights reserved
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: expr.n,v 1.18.2.2 2005/07/12 20:36:15 kennykb Exp $
'\" 
.so man.macros
.TH expr n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
expr \- Evaluate an expression
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
will be used as the operand without any substitutions.
.IP [6]
As a Tcl command enclosed in brackets.
The command will be executed and its result will be used as
the operand.
.IP [7]
As a mathematical function whose arguments have any of the above
forms for operands, such as \fBsin($x)\fR.  See below for a list of defined
functions.
.LP
Where the above substitutions occur (e.g. inside quoted strings), they
are performed by the expression's instructions.
However, the command parser may already have performed one round of
substitution before the expression processor was called.
As discussed below, it is usually best to enclose expressions
in braces to prevent the command parser from performing substitutions







|
|







81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
will be used as the operand without any substitutions.
.IP [6]
As a Tcl command enclosed in brackets.
The command will be executed and its result will be used as
the operand.
.IP [7]
As a mathematical function whose arguments have any of the above
forms for operands, such as \fBsin($x)\fR.  See MATH FUNCTIONS below for
a discussion of how mathematical functions are handled.
.LP
Where the above substitutions occur (e.g. inside quoted strings), they
are performed by the expression's instructions.
However, the command parser may already have performed one round of
substitution before the expression processor was called.
As discussed below, it is usually best to enclose expressions
in braces to prevent the command parser from performing substitutions
207
208
209
210
211
212
213

214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279


280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338


339
340
341
342
343
344
345
only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated,
depending on the value of \fB$v\fR.  Note, however, that this is
only true if the entire expression is enclosed in braces;  otherwise
the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before
invoking the \fBexpr\fR command.
.SS "MATH FUNCTIONS"
.PP

Tcl supports the following mathematical functions in expressions, all
of which work solely with floating-point numbers unless otherwise noted:
.DS
.ta 3c 6c 9c
\fBabs\fR	\fBcosh\fR	\fBlog\fR	\fBsqrt\fR
\fBacos\fR	\fBdouble\fR	\fBlog10\fR	\fBsrand\fR
\fBasin\fR	\fBexp\fR	\fBpow\fR	\fBtan\fR
\fBatan\fR	\fBfloor\fR	\fBrand\fR	\fBtanh\fR
\fBatan2\fR	\fBfmod\fR	\fBround\fR	\fBwide\fR
\fBceil\fR	\fBhypot\fR	\fBsin\fR
\fBcos\fR	\fBint\fR	\fBsinh\fR
.DE
.PP
.TP
\fBabs(\fIarg\fB)\fR
Returns the absolute value of \fIarg\fR.  \fIArg\fR may be either
integer or floating-point, and the result is returned in the same form.
.TP
\fBacos(\fIarg\fB)\fR
Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR]
radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBasin(\fIarg\fB)\fR
Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
radians.  \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBatan(\fIarg\fB)\fR
Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
radians.
.TP
\fBatan2(\fIy, x\fB)\fR
Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR]
radians.  \fIx\fR and \fIy\fR cannot both be 0.  If \fIx\fR is greater
than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR.
.TP
\fBceil(\fIarg\fB)\fR
Returns the smallest integral floating-point value (i.e. with a zero
fractional part) not less than \fIarg\fR.
.TP
\fBcos(\fIarg\fB)\fR
Returns the cosine of \fIarg\fR, measured in radians.
.TP
\fBcosh(\fIarg\fB)\fR
Returns the hyperbolic cosine of \fIarg\fR.  If the result would cause

an overflow, an error is returned.
.TP
\fBdouble(\fIarg\fB)\fR
If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts
\fIarg\fR to floating-point and returns the converted value.
.TP
\fBexp(\fIarg\fB)\fR
Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR.
If the result would cause an overflow, an error is returned.
.TP
\fBfloor(\fIarg\fB)\fR
Returns the largest integral floating-point value (i.e. with a zero
fractional part) not greater than \fIarg\fR.
.TP
\fBfmod(\fIx, y\fB)\fR
Returns the floating-point remainder of the division of \fIx\fR by
\fIy\fR.  If \fIy\fR is 0, an error is returned.
.TP
\fBhypot(\fIx, y\fB)\fR
Computes the length of the hypotenuse of a right-angled triangle
\fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR.
.TP


\fBint(\fIarg\fB)\fR
If \fIarg\fR is an integer value of the same width as the machine
word, returns \fIarg\fR, otherwise
converts \fIarg\fR to an integer (of the same size as a machine word,
i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by
truncation and returns the converted value.
.TP
\fBlog(\fIarg\fB)\fR
Returns the natural logarithm of \fIarg\fR.  \fIArg\fR must be a
positive value.
.TP
\fBlog10(\fIarg\fB)\fR
Returns the base 10 logarithm of \fIarg\fR.  \fIArg\fR must be a
positive value.
.TP
\fBpow(\fIx, y\fB)\fR
Computes the value of \fIx\fR raised to the power \fIy\fR.  If \fIx\fR
is negative, \fIy\fR must be an integer value.
.TP
\fBrand()\fR
Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR).  
The generator algorithm is a simple linear congruential generator that
is not cryptographically secure.  Each result from \fBrand\fR completely
determines all future results from subsequent calls to \fBrand\fR, so
\fBrand\fR should not be used to generate a sequence of secrets, such as
one-time passwords.  The seed of the generator is initialized from the
internal clock of the machine or may be set with the \fBsrand\fR function.
.TP
\fBround(\fIarg\fB)\fR
If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts
\fIarg\fR to integer by rounding and returns the converted value.
.TP
\fBsin(\fIarg\fB)\fR
Returns the sine of \fIarg\fR, measured in radians.
.TP
\fBsinh(\fIarg\fB)\fR
Returns the hyperbolic sine of \fIarg\fR.  If the result would cause
an overflow, an error is returned.
.TP
\fBsqrt(\fIarg\fB)\fR
Returns the square root of \fIarg\fR.  \fIArg\fR must be non-negative.
.TP
\fBsrand(\fIarg\fB)\fR
The \fIarg\fR, which must be an integer, is used to reset the seed for
the random number generator of \fBrand\fR.  Returns the first random
number (see \fBrand()\fR) from that seed.  Each interpreter has its own seed.
.TP
\fBtan(\fIarg\fB)\fR
Returns the tangent of \fIarg\fR, measured in radians.
.TP
\fBtanh(\fIarg\fB)\fR
Returns the hyperbolic tangent of \fIarg\fR.
.TP
\fBwide(\fIarg\fB)\fR
Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension
if \fIarg\fR is a 32-bit number) if it is not one already.
.PP
In addition to these predefined functions, applications may
define additional functions using \fBTcl_CreateMathFunc\fR().


.SS "TYPES, OVERFLOW, AND PRECISION"
.PP
All internal computations involving integers are done with the C type
\fIlong\fR, and all internal computations involving floating-point are
done with the C type \fIdouble\fR.
When converting a string to floating-point, exponent overflow is
detected and results in a Tcl error.







>
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
|
<
<
<
<
|
<
<
|
<
|
<
|
<
<
<
<
|
<
<
|
>
>
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
|
>
>







208
209
210
211
212
213
214
215
216









217

































218
219
220




221


222

223

224




225


226
227
228
229
230
231





















































232

233
234
235
236
237
238
239
240
241
242
only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated,
depending on the value of \fB$v\fR.  Note, however, that this is
only true if the entire expression is enclosed in braces;  otherwise
the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before
invoking the \fBexpr\fR command.
.SS "MATH FUNCTIONS"
.PP
.VS 8.5
When the expression parser encounters a mathematical function









such as \fBsin($x)\fR, it replaces it with a call to an ordinary

































Tcl function in the \fBtcl::mathfunc\fR namespace.  The processing
of an expression such as:
.CS




\fBexpr {sin($x+$y)}\fR


.CE

is the same in every way as the processing of:

.CS




\fBexpr {[tcl::mathfunc::sin [expr {$x+$y}]]}\fR


.CE
The executor will search for \fBtcl::mathfunc::sin\fR using the usual
rules for resolving functions in namespaces. Either
\fB::tcl::mathfunc::sin\fR or \fB[namespace
current]::tcl::mathfunc::sin\fR will satisfy the request, and others
may as well (depending on the current \fBnamespace path\fR setting).





















































.PP

See the \fBmathfunc\fR(n) manual page for the math functions that are
available by default.
.VE 8.5
.SS "TYPES, OVERFLOW, AND PRECISION"
.PP
All internal computations involving integers are done with the C type
\fIlong\fR, and all internal computations involving floating-point are
done with the C type \fIdouble\fR.
When converting a string to floating-point, exponent overflow is
detected and results in a Tcl error.
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
.SH EXAMPLES
Define a procedure that computes an "interesting" mathematical
function:
.CS
proc calc {x y} {
    \fBexpr\fR { ($x**2 - $y**2) / exp($x**2 + $y**2) }
}
.CE
.PP
Convert polar coordinates into cartesian coordinates:
.CS
# convert from ($radius,$angle)







|







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
.SH EXAMPLES
Define a procedure that computes an "interesting" mathematical
function:
.CS
proc tcl::mathfunc::calc {x y} {
    \fBexpr\fR { ($x**2 - $y**2) / exp($x**2 + $y**2) }
}
.CE
.PP
Convert polar coordinates into cartesian coordinates:
.CS
# convert from ($radius,$angle)
466
467
468
469
470
471
472
473
474
475
476







.PP
Generate a random integer in the range 0..99 inclusive:
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE

.SH "SEE ALSO"
array(n), for(n), if(n), string(n), Tcl(n), while(n)

.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison














|



>
>
>
>
>
>
>
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
.PP
Generate a random integer in the range 0..99 inclusive:
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE

.SH "SEE ALSO"
array(n), for(n), if(n), mathfunc(n), namespace(n), proc(n), string(n), Tcl(n), while(n)

.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison

.SH COPYRIGHT
Copyright (c) 1993 The Regents of the University of California.
.br
Copyright (c) 1994-2000 Sun Microsystems Incorporated.
.br
Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. All rights reserved.

Changes to doc/fblocked.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
'\" 
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: fblocked.n,v 1.6 2004/10/27 12:53:22 dkf Exp $
.so man.macros
.TH fblocked n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fblocked \- Test whether the last input operation exhausted all available input
.SH SYNOPSIS
\fBfblocked \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
The \fBfblocked\fR command returns 1 if the most recent input operation
on \fIchannelId\fR returned less information than requested because all
available input was exhausted.
For example, if \fBgets\fR is invoked when there are only three
characters available for input and no end-of-line sequence, \fBgets\fR
returns an empty string and a subsequent call to \fBfblocked\fR will
return 1.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.SH EXAMPLE
The \fBfblocked\fR command is particularly useful when writing network
servers, as it allows you to write your code in a line-by-line style
without preventing the servicing of other connections.  This can be
seen in this simple echo-service:
.PP
.CS






|




















<




<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31

32
33
34
35
36
37
38
'\" 
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: fblocked.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $
.so man.macros
.TH fblocked n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fblocked \- Test whether the last input operation exhausted all available input
.SH SYNOPSIS
\fBfblocked \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
The \fBfblocked\fR command returns 1 if the most recent input operation
on \fIchannelId\fR returned less information than requested because all
available input was exhausted.
For example, if \fBgets\fR is invoked when there are only three
characters available for input and no end-of-line sequence, \fBgets\fR
returns an empty string and a subsequent call to \fBfblocked\fR will
return 1.
.PP

\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.

.SH EXAMPLE
The \fBfblocked\fR command is particularly useful when writing network
servers, as it allows you to write your code in a line-by-line style
without preventing the servicing of other connections.  This can be
seen in this simple echo-service:
.PP
.CS

Changes to doc/fconfigure.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\" 
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: fconfigure.n,v 1.11 2004/10/27 12:53:22 dkf Exp $
'\"
.so man.macros
.TH fconfigure n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fconfigure \- Set and get options on a channel






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\" 
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: fconfigure.n,v 1.11.2.1 2005/04/25 21:37:18 kennykb Exp $
'\"
.so man.macros
.TH fconfigure n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fconfigure \- Set and get options on a channel
87
88
89
90
91
92
93
94



95
96
97
98
99
100
101
102
103
104
105
will automatically be converted to the specified encoding on output.
.RS
.PP
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be \fBbinary\fR.  Tcl
will then assign no interpretation to the data in the file and simply read or
write raw bytes.  The Tcl \fBbinary\fR command can be used to manipulate this
byte-oriented data.



.PP
The default encoding for newly opened channels is the same platform- and
locale-dependent system encoding used for interfacing with the operating
system.  
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
.
This option supports DOS file systems that use Control-z (\ex1a) as an







|
>
>
>



|







87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
will automatically be converted to the specified encoding on output.
.RS
.PP
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be \fBbinary\fR.  Tcl
will then assign no interpretation to the data in the file and simply read or
write raw bytes.  The Tcl \fBbinary\fR command can be used to manipulate this
byte-oriented data.  It is usually better to set the
\fB\-translation\fR option to \fBbinary\fR when you want to transfer
binary data, as this turns off the other automatic interpretations of
the bytes in the stream as well.
.PP
The default encoding for newly opened channels is the same platform- and
locale-dependent system encoding used for interfacing with the operating
system, as returned by \fBencoding system\fR.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
.
This option supports DOS file systems that use Control-z (\ex1a) as an

Changes to doc/fcopy.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: fcopy.n,v 1.4 2004/09/06 09:44:56 dkf Exp $
'\" 
.so man.macros
.TH fcopy n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fcopy \- Copy data from one channel to another







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: fcopy.n,v 1.4.2.1 2005/04/25 21:37:19 kennykb Exp $
'\" 
.so man.macros
.TH fcopy n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fcopy \- Copy data from one channel to another
68
69
70
71
72
73
74

75
76
77
78

79

80
81
82
83
84
85
86
87
88
89










90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
\fB\-translation\fR option.
The translations mean that the number of bytes read from \fIinchan\fR
can be different than the number of bytes written to \fIoutchan\fR.
Only the number of bytes written to \fIoutchan\fR is reported,
either as the return value of a synchronous \fBfcopy\fP or
as the argument to the callback for an asynchronous \fBfcopy\fP.
.PP

\fBFcopy\fR obeys the encodings configured for the channels. This
means that the incoming characters are converted internally first
UTF-8 and then into the encoding of the channel \fBfcopy\fR writes
to. See the manual entry for \fBfconfigure\fR for details on the

\fB\-encoding\fR option. No conversion is done if both channels are

set to encoding "binary". If only the output channel is set to
encoding "binary" the system will write the internal UTF-8
representation of the incoming characters. If only the input channel
is set to encoding "binary" the system will assume that the incoming
bytes are valid UTF-8 characters and convert them according to the
output encoding. The behaviour of the system for bytes which are not
valid UTF-8 characters is undefined in this case.

.SH EXAMPLE
.PP










This first example shows how the callback gets
passed the number of bytes transferred.
It also uses vwait to put the application into the event loop.
Of course, this simplified example could be done without the command 
callback.
.DS
proc Cleanup {in out bytes {error {}}} {
    global total
    set total $bytes
    close $in
    close $out
    if {[string length $error] != 0} {
	# error occurred during the copy
    }
}
set in [open $file1]
set out [socket $server $port]
fcopy $in $out -command [list Cleanup $in $out]
vwait total

.DE
.PP
The second example copies in chunks and tests for end of file
in the command callback
.DS
proc CopyMore {in out chunk bytes {error {}}} {
    global total done
    incr total $bytes
    if {([string length $error] != 0) || [eof $in] {
	set done $total
	close $in
	close $out
    } else {
	fcopy $in $out -command [list CopyMore $in $out $chunk] \\
	    -size $chunk
    }
}
set in [open $file1]
set out [socket $server $port]
set chunk 1024
set total 0
fcopy $in $out -command [list CopyMore $in $out $chunk] -size $chunk
vwait done

.DE

.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n)

.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation







>
|



>
|
>
|







|

>
>
>
>
>
>
>
>
>
>
|
















|

<


|










|







|

<



|



68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

145
146
147
148
149
150
151
\fB\-translation\fR option.
The translations mean that the number of bytes read from \fIinchan\fR
can be different than the number of bytes written to \fIoutchan\fR.
Only the number of bytes written to \fIoutchan\fR is reported,
either as the return value of a synchronous \fBfcopy\fP or
as the argument to the callback for an asynchronous \fBfcopy\fP.
.PP
\fBFcopy\fR obeys the encodings and character translations configured
for the channels. This
means that the incoming characters are converted internally first
UTF-8 and then into the encoding of the channel \fBfcopy\fR writes
to. See the manual entry for \fBfconfigure\fR for details on the
\fB\-encoding\fR and \fB\-translation\fR options. No conversion is
done if both channels are
set to encoding "binary" and have matching translations. If only the
output channel is set to
encoding "binary" the system will write the internal UTF-8
representation of the incoming characters. If only the input channel
is set to encoding "binary" the system will assume that the incoming
bytes are valid UTF-8 characters and convert them according to the
output encoding. The behaviour of the system for bytes which are not
valid UTF-8 characters is undefined in this case.

.SH EXAMPLES
.PP
The first example transfers the contents of one channel exactly to
another. Note that when copying one file to another, it is better to
use \fBfile copy\fR which also copies file metadata (e.g. the file
access permissions) where possible.
.DS
fconfigure $in -translation binary
fconfigure $out -translation binary
\fBfcopy\fR $in $out
.DE
.PP
This second example shows how the callback gets
passed the number of bytes transferred.
It also uses vwait to put the application into the event loop.
Of course, this simplified example could be done without the command 
callback.
.DS
proc Cleanup {in out bytes {error {}}} {
    global total
    set total $bytes
    close $in
    close $out
    if {[string length $error] != 0} {
	# error occurred during the copy
    }
}
set in [open $file1]
set out [socket $server $port]
\fBfcopy\fR $in $out -command [list Cleanup $in $out]
vwait total

.DE
.PP
The third example copies in chunks and tests for end of file
in the command callback
.DS
proc CopyMore {in out chunk bytes {error {}}} {
    global total done
    incr total $bytes
    if {([string length $error] != 0) || [eof $in] {
	set done $total
	close $in
	close $out
    } else {
	\fBfcopy\fR $in $out -command [list CopyMore $in $out $chunk] \\
	    -size $chunk
    }
}
set in [open $file1]
set out [socket $server $port]
set chunk 1024
set total 0
\fBfcopy\fR $in $out -command [list CopyMore $in $out $chunk] -size $chunk
vwait done

.DE

.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n), file(n)

.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation

Changes to doc/file.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: file.n,v 1.38 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
file \- Manipulate file names and attributes







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: file.n,v 1.38.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
file \- Manipulate file names and attributes
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
Finder creator type of the file. \fB-hidden\fR gives or sets or clears
the hidden attribute of the file. \fB-readonly\fR gives or sets or
clears the readonly attribute of the file. \fB-rsrclength\fR gives
the length of the resource fork of the file, this attribute can only be
set to the value 0, which results in the resource fork being stripped
off the file.
.RE
.VS
.TP
\fBfile channels ?\fIpattern\fR?
.
If \fIpattern\fR isn't specified, returns a list of names of all
registered open channels in this interpreter.  If \fIpattern\fR is
specified, only those names matching \fIpattern\fR are returned.  Matching
is determined using the same rules as for \fBstring match\fR.
.VE
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form makes a copy of the file or directory \fIsource\fR under
the pathname \fItarget\fR. If \fItarget\fR is an existing directory,







<







<







77
78
79
80
81
82
83

84
85
86
87
88
89
90

91
92
93
94
95
96
97
Finder creator type of the file. \fB-hidden\fR gives or sets or clears
the hidden attribute of the file. \fB-readonly\fR gives or sets or
clears the readonly attribute of the file. \fB-rsrclength\fR gives
the length of the resource fork of the file, this attribute can only be
set to the value 0, which results in the resource fork being stripped
off the file.
.RE

.TP
\fBfile channels ?\fIpattern\fR?
.
If \fIpattern\fR isn't specified, returns a list of names of all
registered open channels in this interpreter.  If \fIpattern\fR is
specified, only those names matching \fIpattern\fR are returned.  Matching
is determined using the same rules as for \fBstring match\fR.

.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form makes a copy of the file or directory \fIsource\fR under
the pathname \fItarget\fR. If \fItarget\fR is an existing directory,

Changes to doc/fileevent.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: fileevent.n,v 1.7 2004/11/20 00:17:32 dgp Exp $
'\" 
.so man.macros
.TH fileevent n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fileevent \- Execute a script when a channel becomes readable or writable







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: fileevent.n,v 1.7.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH fileevent n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fileevent \- Execute a script when a channel becomes readable or writable
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
application invokes \fBgets\fR or \fBread\fR on a blocking channel when
there is no input data available, the process will block; until the input
data arrives, it will not be able to service other events, so it will
appear to the user to ``freeze up''.  With \fBfileevent\fR, the process can
tell when data is present and only invoke \fBgets\fR or \fBread\fR when
they won't block.
.PP
.VS
The \fIchannelId\fR argument to \fBfileevent\fR refers to an open
channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR,
or \fBstderr\fR), the return value from an invocation of \fBopen\fR
or \fBsocket\fR, or the result of a channel creation command provided
by a Tcl extension.
.VE
.PP
If the \fIscript\fR argument is specified, then \fBfileevent\fR
creates a new event handler:  \fIscript\fR will be evaluated
whenever the channel becomes readable or writable (depending on the
second argument to \fBfileevent\fR).
In this case \fBfileevent\fR returns an empty string.
The \fBreadable\fR and \fBwritable\fR event handlers for a file







<





<







30
31
32
33
34
35
36

37
38
39
40
41

42
43
44
45
46
47
48
application invokes \fBgets\fR or \fBread\fR on a blocking channel when
there is no input data available, the process will block; until the input
data arrives, it will not be able to service other events, so it will
appear to the user to ``freeze up''.  With \fBfileevent\fR, the process can
tell when data is present and only invoke \fBgets\fR or \fBread\fR when
they won't block.
.PP

The \fIchannelId\fR argument to \fBfileevent\fR refers to an open
channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR,
or \fBstderr\fR), the return value from an invocation of \fBopen\fR
or \fBsocket\fR, or the result of a channel creation command provided
by a Tcl extension.

.PP
If the \fIscript\fR argument is specified, then \fBfileevent\fR
creates a new event handler:  \fIscript\fR will be evaluated
whenever the channel becomes readable or writable (depending on the
second argument to \fBfileevent\fR).
In this case \fBfileevent\fR returns an empty string.
The \fBreadable\fR and \fBwritable\fR event handlers for a file

Changes to doc/flush.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: flush.n,v 1.6 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH flush n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
flush \- Flush buffered output for a channel
.SH SYNOPSIS
\fBflush \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
Flushes any output that has been buffered for \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension.  The
channel must have been opened for writing.
.VE
.PP
If the channel is in blocking mode the command does not return until all the
buffered output has been flushed to the channel. If the channel is in
nonblocking mode, the command may return before all buffered output has been
flushed; the remainder will be flushed in the background as fast as the
underlying file or device is able to absorb it.
.SH EXAMPLE







|















<





<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28

29
30
31
32
33
34
35
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: flush.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH flush n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
flush \- Flush buffered output for a channel
.SH SYNOPSIS
\fBflush \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
Flushes any output that has been buffered for \fIchannelId\fR.
.PP

\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension.  The
channel must have been opened for writing.

.PP
If the channel is in blocking mode the command does not return until all the
buffered output has been flushed to the channel. If the channel is in
nonblocking mode, the command may return before all buffered output has been
flushed; the remainder will be flushed in the background as fast as the
underlying file or device is able to absorb it.
.SH EXAMPLE

Changes to doc/foreach.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: foreach.n,v 1.5 2004/11/26 10:02:23 dkf Exp $
'\" 
.so man.macros
.TH foreach n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
foreach \- Iterate over all elements in one or more lists







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: foreach.n,v 1.5.2.1 2004/12/08 18:24:35 kennykb Exp $
'\" 
.so man.macros
.TH foreach n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
foreach \- Iterate over all elements in one or more lists
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR
command.  \fBForeach\fR returns an empty string.
.SH EXAMPLES
This loop prints every value in a list together with the square and
cube of the value:
.CS
'\" Maintainers: notice the tab hacking below!
.ta 32
set values {1 3 5 7 2 4 6 8}	;# Odd numbers first, for fun!
puts "Value\\tSquare\\tCube"	;# Neat-looking header
\fBforeach\fR x $values {	;# Now loop and print...
    puts " $x\\t [expr {$x**2}]\\t [expr {$x**3}]"
}
.CE
.PP







|







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR
command.  \fBForeach\fR returns an empty string.
.SH EXAMPLES
This loop prints every value in a list together with the square and
cube of the value:
.CS
'\" Maintainers: notice the tab hacking below!
.ta 3i
set values {1 3 5 7 2 4 6 8}	;# Odd numbers first, for fun!
puts "Value\\tSquare\\tCube"	;# Neat-looking header
\fBforeach\fR x $values {	;# Now loop and print...
    puts " $x\\t [expr {$x**2}]\\t [expr {$x**3}]"
}
.CE
.PP

Changes to doc/format.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: format.n,v 1.10 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH format n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
format \- Format a string in the style of sprintf







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: format.n,v 1.10.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH format n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
format \- Format a string in the style of sprintf
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
it must be a numeric string.
.PP
The fifth part of a conversion specifier is a length modifier,
which must be \fBh\fR or \fBl\fR.
If it is \fBh\fR it specifies that the numeric value should be
truncated to a 16-bit value before converting.
This option is rarely useful.
.VS 8.4
If it is \fBl\fR it specifies that the numeric value should be (at
least) a 64-bit value.  If neither \fBh\fR nor \fBl\fR are present,
numeric values are interpreted as being values of the width of the
native machine word, as described by \fBtcl_platform(wordSize)\fR.
.VE
.PP
The last thing in a conversion specifier is an alphabetic character
that determines what kind of conversion to perform.
The following conversion characters are currently supported:
.TP 10
\fBd\fR
Convert integer to signed decimal string.







<




<







126
127
128
129
130
131
132

133
134
135
136

137
138
139
140
141
142
143
it must be a numeric string.
.PP
The fifth part of a conversion specifier is a length modifier,
which must be \fBh\fR or \fBl\fR.
If it is \fBh\fR it specifies that the numeric value should be
truncated to a 16-bit value before converting.
This option is rarely useful.

If it is \fBl\fR it specifies that the numeric value should be (at
least) a 64-bit value.  If neither \fBh\fR nor \fBl\fR are present,
numeric values are interpreted as being values of the width of the
native machine word, as described by \fBtcl_platform(wordSize)\fR.

.PP
The last thing in a conversion specifier is an alphabetic character
that determines what kind of conversion to perform.
The following conversion characters are currently supported:
.TP 10
\fBd\fR
Convert integer to signed decimal string.
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
.TP 10
\fBo\fR
Convert integer to unsigned octal string.
.TP 10
\fBx\fR or \fBX\fR
Convert integer to unsigned hexadecimal string, using digits
``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR).
.VS
.TP 10
\fBc\fR
Convert integer to the Unicode character it represents.
.VE
.TP 10
\fBs\fR
No conversion; just insert string.
.TP 10
\fBf\fR
Convert floating-point number to signed decimal string of 
the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by 







<



<







152
153
154
155
156
157
158

159
160
161

162
163
164
165
166
167
168
.TP 10
\fBo\fR
Convert integer to unsigned octal string.
.TP 10
\fBx\fR or \fBX\fR
Convert integer to unsigned hexadecimal string, using digits
``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR).

.TP 10
\fBc\fR
Convert integer to the Unicode character it represents.

.TP 10
\fBs\fR
No conversion; just insert string.
.TP 10
\fBf\fR
Convert floating-point number to signed decimal string of 
the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by 
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
.IP [1]
\fB%p\fR and \fB%n\fR specifiers are not currently supported.
.IP [2]
For \fB%c\fR conversions the argument must be a decimal string,
which will then be converted to the corresponding character value.
.IP [3]
The \fBl\fR modifier
.VS 8.4
is ignored for real values and on 64-bit platforms, which are always
converted as if the \fBl\fR modifier were present (i.e. the types
\fBdouble\fR and \fBlong\fR are used for the internal representation
of real and integer values, respectively).
.VE 8.4
If the \fBh\fR modifier is specified then integer values are truncated
to \fBshort\fR before conversion.  Both \fBh\fR and \fBl\fR modifiers
are ignored on all other conversions.
.SH EXAMPLES
Convert the output of \fBtime\fR into seconds to an accuracy of
hundredths of a second:
.CS







<




<







199
200
201
202
203
204
205

206
207
208
209

210
211
212
213
214
215
216
.IP [1]
\fB%p\fR and \fB%n\fR specifiers are not currently supported.
.IP [2]
For \fB%c\fR conversions the argument must be a decimal string,
which will then be converted to the corresponding character value.
.IP [3]
The \fBl\fR modifier

is ignored for real values and on 64-bit platforms, which are always
converted as if the \fBl\fR modifier were present (i.e. the types
\fBdouble\fR and \fBlong\fR are used for the internal representation
of real and integer values, respectively).

If the \fBh\fR modifier is specified then integer values are truncated
to \fBshort\fR before conversion.  Both \fBh\fR and \fBl\fR modifiers
are ignored on all other conversions.
.SH EXAMPLES
Convert the output of \fBtime\fR into seconds to an accuracy of
hundredths of a second:
.CS

Changes to doc/gets.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: gets.n,v 1.6 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH gets n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
gets \- Read a line from a channel
.SH SYNOPSIS
\fBgets \fIchannelId\fR ?\fIvarName\fR?
.BE

.SH DESCRIPTION
.PP
This command reads the next line from \fIchannelId\fR, returns everything
in the line up to (but not including) the end-of-line character(s), and
discards the end-of-line character(s).
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as the
Tcl standard input channel (\fBstdin\fR), the return value from an
invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
creation command provided by a Tcl extension. The channel must have
been opened for input.
.VE
.PP
If \fIvarName\fR is omitted the line is returned as the result of the
command.
If \fIvarName\fR is specified then the line is placed in the variable by
that name and the return value is a count of the number of characters
returned.
.PP







|

















<





<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30

31
32
33
34
35
36
37
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: gets.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH gets n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
gets \- Read a line from a channel
.SH SYNOPSIS
\fBgets \fIchannelId\fR ?\fIvarName\fR?
.BE

.SH DESCRIPTION
.PP
This command reads the next line from \fIchannelId\fR, returns everything
in the line up to (but not including) the end-of-line character(s), and
discards the end-of-line character(s).
.PP

\fIChannelId\fR must be an identifier for an open channel such as the
Tcl standard input channel (\fBstdin\fR), the return value from an
invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
creation command provided by a Tcl extension. The channel must have
been opened for input.

.PP
If \fIvarName\fR is omitted the line is returned as the result of the
command.
If \fIvarName\fR is specified then the line is placed in the variable by
that name and the return value is a count of the number of characters
returned.
.PP

Changes to doc/glob.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24


25
26
27
28
29
30
31
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: glob.n,v 1.17 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH glob n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
glob \- Return names of files that match patterns
.SH SYNOPSIS
\fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR?
.BE

.SH DESCRIPTION
.PP
This command performs file name ``globbing'' in a fashion similar to
the csh shell.  It returns a list of the files whose names match any
of the \fIpattern\fR arguments.


.LP
If the initial arguments to \fBglob\fR start with \fB\-\fR then
they are treated as switches.  The following switches are
currently supported:
.TP
\fB\-directory\fR \fIdirectory\fR
Search for files which match the given patterns starting in the given







|















|
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: glob.n,v 1.17.2.1 2005/07/12 20:36:15 kennykb Exp $
'\" 
.so man.macros
.TH glob n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
glob \- Return names of files that match patterns
.SH SYNOPSIS
\fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR?
.BE

.SH DESCRIPTION
.PP
This command performs file name ``globbing'' in a fashion similar to
the csh shell.  It returns a list of the files whose names match any
of the \fIpattern\fR arguments.  No particular order is guaranteed
in the list, so if a sorted list is required the caller should use 
\fBlsort\fR.
.LP
If the initial arguments to \fBglob\fR start with \fB\-\fR then
they are treated as switches.  The following switches are
currently supported:
.TP
\fB\-directory\fR \fIdirectory\fR
Search for files which match the given patterns starting in the given
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
start with a tilde ``~'' (for example through \fBglob *\fR or 
\fBglob -tails\fR, the returned list will not quote the tilde with
``./''.  This means care must be taken if those names are later to
be used with \fBfile join\fR, to avoid them being interpreted as
absolute paths pointing to a given user's home directory.
.SH "PORTABILITY ISSUES"
.PP
Unlike other Tcl commands that will accept both network and native
style names (see the \fBfilename\fR manual entry for details on how
native and network names are specified), the \fBglob\fR command only
accepts native names.  
.TP
\fBWindows\fR
.
For Windows UNC names, the servername and sharename components of the path
may not contain ?, *, or [] constructs.  On Windows NT, if \fIpattern\fR is
of the form ``\fB~\fIusername\fB@\fIdomain\fR'' it refers to the home
directory of the user whose account information resides on the specified NT
domain server.  Otherwise, user account information is obtained from







<
<
<
<
<







155
156
157
158
159
160
161





162
163
164
165
166
167
168
start with a tilde ``~'' (for example through \fBglob *\fR or 
\fBglob -tails\fR, the returned list will not quote the tilde with
``./''.  This means care must be taken if those names are later to
be used with \fBfile join\fR, to avoid them being interpreted as
absolute paths pointing to a given user's home directory.
.SH "PORTABILITY ISSUES"
.PP





\fBWindows\fR
.
For Windows UNC names, the servername and sharename components of the path
may not contain ?, *, or [] constructs.  On Windows NT, if \fIpattern\fR is
of the form ``\fB~\fIusername\fB@\fIdomain\fR'' it refers to the home
directory of the user whose account information resides on the specified NT
domain server.  Otherwise, user account information is obtained from

Changes to doc/info.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1998-2000 Ajuba Solutions
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: info.n,v 1.14 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
info \- Return information about the state of the Tcl interpreter









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1998-2000 Ajuba Solutions
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: info.n,v 1.14.2.2 2005/07/12 20:36:15 kennykb Exp $
'\" 
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
info \- Return information about the state of the Tcl interpreter
36
37
38
39
40
41
42


43

44
45
46
47
48
49
50
51
52
53
54
55
56




57
58
59
60
61
62
63
.TP
\fBinfo cmdcount\fR
Returns a count of the total number of commands that have been invoked
in this interpreter.
.TP
\fBinfo commands \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified,


returns a list of names of all the Tcl commands in the current namespace,

including both the built-in commands written in C and
the command procedures defined using the \fBproc\fR command.
If \fIpattern\fR is specified,
only those names matching \fIpattern\fR are returned.
Matching is determined using the same rules as for \fBstring match\fR.
\fIpattern\fR can be a qualified name like \fBFoo::print*\fR.
That is, it may specify a particular namespace
using a sequence of namespace names separated by double colons (\fB::\fR),
and may have pattern matching special characters
at the end to specify a set of commands in that namespace.
If \fIpattern\fR is a qualified name,
the resulting list of command names has each one qualified with the name
of the specified namespace.




.TP
\fBinfo complete \fIcommand\fR
Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of
having no unclosed quotes, braces, brackets or array element names.
If the command doesn't appear to be complete then 0 is returned.
This command is typically used in line-oriented input environments
to allow users to type in commands that span multiple lines;  if the







>
>
|
>












|
>
>
>
>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
.TP
\fBinfo cmdcount\fR
Returns a count of the total number of commands that have been invoked
in this interpreter.
.TP
\fBinfo commands \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified,
'\" Do not move this .VS above the .TP
.VS 8.5
returns a list of names of all the Tcl commands visible
(i.e. executable without using a qualified name) to the current namespace,
including both the built-in commands written in C and
the command procedures defined using the \fBproc\fR command.
If \fIpattern\fR is specified,
only those names matching \fIpattern\fR are returned.
Matching is determined using the same rules as for \fBstring match\fR.
\fIpattern\fR can be a qualified name like \fBFoo::print*\fR.
That is, it may specify a particular namespace
using a sequence of namespace names separated by double colons (\fB::\fR),
and may have pattern matching special characters
at the end to specify a set of commands in that namespace.
If \fIpattern\fR is a qualified name,
the resulting list of command names has each one qualified with the name
of the specified namespace, and only the commands defined in the named
namespace are returned.
'\" Technically, most of this hasn't changed; that's mostly just the
'\" way it always worked. Hardly anyone knew that though.
.VE 8.5
.TP
\fBinfo complete \fIcommand\fR
Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of
having no unclosed quotes, braces, brackets or array element names.
If the command doesn't appear to be complete then 0 is returned.
This command is typically used in line-oriented input environments
to allow users to type in commands that span multiple lines;  if the
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
into variable \fIvarname\fR.
.TP
\fBinfo exists \fIvarName\fR
Returns \fB1\fR if the variable named \fIvarName\fR exists in the
current context (either as a global or local variable) and has been
defined by being given a value, returns \fB0\fR otherwise.
.VS 8.4
.TP
\fBinfo functions \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the math
functions currently defined.
If \fIpattern\fR is specified, only those functions whose name matches
\fIpattern\fR are returned.  Matching is determined using the same
rules as for \fBstring match\fR.
.VE
.TP
\fBinfo globals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined global variables.
Global variables are variables in the global namespace.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned.  Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo hostname\fR
Returns the name of the computer on which this invocation is being
executed.
.VS
Note that this name is not guaranteed to be the fully qualified domain
name of the host.  Where machines have several different names (as is
common on systems with both TCP/IP (DNS) and NetBIOS-based networking
installed,) it is the name that is suitable for TCP/IP networking that
is returned.
.VE
.TP
\fBinfo level\fR ?\fInumber\fR?
If \fInumber\fR is not specified, this command returns a number
giving the stack level of the invoking procedure, or 0 if the
command is invoked at top-level.  If \fInumber\fR is specified,
then the result is a list consisting of the name and arguments for the
procedure call at level \fInumber\fR on the stack.  If \fInumber\fR







<







<












<





<







78
79
80
81
82
83
84

85
86
87
88
89
90
91

92
93
94
95
96
97
98
99
100
101
102
103

104
105
106
107
108

109
110
111
112
113
114
115
Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
into variable \fIvarname\fR.
.TP
\fBinfo exists \fIvarName\fR
Returns \fB1\fR if the variable named \fIvarName\fR exists in the
current context (either as a global or local variable) and has been
defined by being given a value, returns \fB0\fR otherwise.

.TP
\fBinfo functions \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the math
functions currently defined.
If \fIpattern\fR is specified, only those functions whose name matches
\fIpattern\fR are returned.  Matching is determined using the same
rules as for \fBstring match\fR.

.TP
\fBinfo globals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined global variables.
Global variables are variables in the global namespace.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned.  Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo hostname\fR
Returns the name of the computer on which this invocation is being
executed.

Note that this name is not guaranteed to be the fully qualified domain
name of the host.  Where machines have several different names (as is
common on systems with both TCP/IP (DNS) and NetBIOS-based networking
installed,) it is the name that is suitable for TCP/IP networking that
is returned.

.TP
\fBinfo level\fR ?\fInumber\fR?
If \fInumber\fR is not specified, this command returns a number
giving the stack level of the invoking procedure, or 0 if the
command is invoked at top-level.  If \fInumber\fR is specified,
then the result is a list consisting of the name and arguments for the
procedure call at level \fInumber\fR on the stack.  If \fInumber\fR

Changes to doc/interp.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2004 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: interp.n,v 1.22 2004/11/21 23:17:50 dgp Exp $
'\" 
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
interp \- Create and manipulate Tcl interpreters







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2004 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: interp.n,v 1.22.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
interp \- Create and manipulate Tcl interpreters
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
a command in a slave interpreter which, when invoked, causes a
command to be invoked in its master interpreter or in another slave
interpreter.  The only other connections between interpreters are
through environment variables (the \fBenv\fR variable), which are
normally shared among all interpreters in the application,
.VS 8.5
and by resource limit exceeded callbacks.
.VE
Note that the
name space for files (such as the names returned by the \fBopen\fR command)
is no longer shared between interpreters. Explicit commands are provided to
share files and to transfer references to open files from one interpreter
to another.
.PP
The \fBinterp\fR command also provides support for \fIsafe\fR







|







34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
a command in a slave interpreter which, when invoked, causes a
command to be invoked in its master interpreter or in another slave
interpreter.  The only other connections between interpreters are
through environment variables (the \fBenv\fR variable), which are
normally shared among all interpreters in the application,
.VS 8.5
and by resource limit exceeded callbacks.
.VE 8.5
Note that the
name space for files (such as the names returned by the \fBopen\fR command)
is no longer shared between interpreters. Explicit commands are provided to
share files and to transfer references to open files from one interpreter
to another.
.PP
The \fBinterp\fR command also provides support for \fIsafe\fR

Changes to doc/lappend.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lappend.n,v 1.9 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH lappend n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lappend \- Append list elements onto a variable








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lappend.n,v 1.9.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH lappend n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lappend \- Append list elements onto a variable
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
% \fBlappend\fR var 2
1 2
% \fBlappend\fR var 3 4 5
1 2 3 4 5
.CE

.SH "SEE ALSO"
list(n), lindex(n), linsert(n), llength(n), 
.VS 8.4
lset(n)
.VE
lsort(n), lrange(n)

.SH KEYWORDS
append, element, list, variable







|
<
<
<




39
40
41
42
43
44
45
46



47
48
49
50
% \fBlappend\fR var 2
1 2
% \fBlappend\fR var 3 4 5
1 2 3 4 5
.CE

.SH "SEE ALSO"
list(n), lindex(n), linsert(n), llength(n), lset(n),



lsort(n), lrange(n)

.SH KEYWORDS
append, element, list, variable

Changes to doc/lindex.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

51
52
53


54
55
56
57
58
59
60
61
62
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lindex.n,v 1.8 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH lindex n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lindex \- Retrieve an element from a list
.SH SYNOPSIS
\fBlindex \fIlist ?index...?\fR
.BE
.SH DESCRIPTION
.PP
.VS 8.4
The \fBlindex\fP command accepts a parameter, \fIlist\fP, which
it treats as a Tcl list. It also accepts zero or more \fIindices\fP into
the list.  The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
.PP
If no indices are presented, the command takes the form:
.CS
lindex list
.CE
or
.CS
lindex list {}
.CE
In this case, the return value of \fBlindex\fR is simply the value of the
\fIlist\fR parameter.
.PP
When presented with a single index, the \fBlindex\fR command
treats \fIlist\fR as a Tcl list and returns the
.VE
\fIindex\fR'th element from it (0 refers to the first element of the list).
In extracting the element, \fBlindex\fR observes the same rules
concerning braces and quotes and backslashes as the Tcl command
interpreter; however, variable
substitution and command substitution do not occur.
If \fIindex\fR is negative or greater than or equal to the number
of elements in \fIvalue\fR, then an empty
string is returned.

If \fIindex\fR has the value \fBend\fR, it refers to the last element
in the list, and \fBend\-\fIinteger\fR refers to the last element in
the list minus the specified integer offset.


.PP
.VS 8.4
If additional \fIindex\fR arguments are supplied, then each argument is
used in turn to select an element from the previous indexing operation,
allowing the script to select elements from sublists.  The command,
.CS
lindex $a 1 2 3
.CE
or








|












<



















<








>
|
|
<
>
>

<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51

52
53
54

55
56
57
58
59
60
61
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lindex.n,v 1.8.2.2 2005/05/05 17:55:24 kennykb Exp $
'\" 
.so man.macros
.TH lindex n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lindex \- Retrieve an element from a list
.SH SYNOPSIS
\fBlindex \fIlist ?index...?\fR
.BE
.SH DESCRIPTION
.PP

The \fBlindex\fP command accepts a parameter, \fIlist\fP, which
it treats as a Tcl list. It also accepts zero or more \fIindices\fP into
the list.  The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
.PP
If no indices are presented, the command takes the form:
.CS
lindex list
.CE
or
.CS
lindex list {}
.CE
In this case, the return value of \fBlindex\fR is simply the value of the
\fIlist\fR parameter.
.PP
When presented with a single index, the \fBlindex\fR command
treats \fIlist\fR as a Tcl list and returns the

\fIindex\fR'th element from it (0 refers to the first element of the list).
In extracting the element, \fBlindex\fR observes the same rules
concerning braces and quotes and backslashes as the Tcl command
interpreter; however, variable
substitution and command substitution do not occur.
If \fIindex\fR is negative or greater than or equal to the number
of elements in \fIvalue\fR, then an empty
string is returned.
.VS 8.5
The interpretation of each simple \fIindex\fR value is the same as 
for the command \fBstring index\fR, supporting simple index

arithmetic and indices relative to the end of the list.
.VE 8.5
.PP

If additional \fIindex\fR arguments are supplied, then each argument is
used in turn to select an element from the previous indexing operation,
allowing the script to select elements from sublists.  The command,
.CS
lindex $a 1 2 3
.CE
or
76
77
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
\fBlindex\fR {a b c} end \fI=> c\fR
\fBlindex\fR {a b c} end-1 \fI=> b\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR
.CE
.VE
.SH "SEE ALSO"
list(n), lappend(n), linsert(n), llength(n), lsearch(n), 

.VS 8.4
lset(n),
.VE
lsort(n),
lrange(n), lreplace(n)

.SH KEYWORDS
element, index, list







<


>
|
|

<
<



75
76
77
78
79
80
81

82
83
84
85
86
87


88
89
90
\fBlindex\fR {a b c} end \fI=> c\fR
\fBlindex\fR {a b c} end-1 \fI=> b\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR
.CE

.SH "SEE ALSO"
list(n), lappend(n), linsert(n), llength(n), lsearch(n), 
lset(n), lsort(n), lrange(n), lreplace(n),
.VS 8.5
string(n)
.VE



.SH KEYWORDS
element, index, list

Changes to doc/linsert.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46


47
48
49
50
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: linsert.n,v 1.10 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH linsert n 8.2 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
linsert \- Insert elements into a list
.SH SYNOPSIS
\fBlinsert \fIlist index element \fR?\fIelement element ...\fR?
.BE

.SH DESCRIPTION
.PP
This command produces a new list from \fIlist\fR by inserting all of the
\fIelement\fR arguments just before the \fIindex\fR'th element of
\fIlist\fR.  Each \fIelement\fR argument will become a separate element of
the new list.  If \fIindex\fR is less than or equal to zero, then the new
elements are inserted at the beginning of the list.  If \fIindex\fR has the

value \fBend\fR, or if it is greater than or equal to the number of
elements in the list, then the new elements are appended to the list.
\fBend\-\fIinteger\fR refers to the last element in the list minus the
specified integer offset.

.SH EXAMPLE
Putting some values into a list, first indexing from the start and
then indexing from the end, and then chaining them together:
.CS
set oldList {the fox jumps over the dog}
set midList [\fBlinsert\fR $oldList 1 quick]
set newList [\fBlinsert\fR $midList end-1 lazy]
# The old lists still exist though...
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE

.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), llength(n), lsearch(n), 
lset(n), lsort(n), lrange(n), lreplace(n)


.VE

.SH KEYWORDS
element, insert, list








|

















|
>
|
<
|
|
>












<

|
>
>




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

45
46
47
48
49
50
51
52
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: linsert.n,v 1.10.2.2 2005/05/05 17:55:24 kennykb Exp $
'\" 
.so man.macros
.TH linsert n 8.2 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
linsert \- Insert elements into a list
.SH SYNOPSIS
\fBlinsert \fIlist index element \fR?\fIelement element ...\fR?
.BE

.SH DESCRIPTION
.PP
This command produces a new list from \fIlist\fR by inserting all of the
\fIelement\fR arguments just before the \fIindex\fR'th element of
\fIlist\fR.  Each \fIelement\fR argument will become a separate element of
the new list.  If \fIindex\fR is less than or equal to zero, then the new
elements are inserted at the beginning of the list.  
.VS 8.5
The interpretation of the \fIindex\fR value is the same as

for the command \fBstring index\fR, supporting simple index
arithmetic and indices relative to the end of the list.
.VE
.SH EXAMPLE
Putting some values into a list, first indexing from the start and
then indexing from the end, and then chaining them together:
.CS
set oldList {the fox jumps over the dog}
set midList [\fBlinsert\fR $oldList 1 quick]
set newList [\fBlinsert\fR $midList end-1 lazy]
# The old lists still exist though...
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE

.SH "SEE ALSO"

list(n), lappend(n), lindex(n), llength(n), lsearch(n), 
lset(n), lsort(n), lrange(n), lreplace(n),
.VS 8.5
string(n)
.VE

.SH KEYWORDS
element, insert, list

Changes to doc/llength.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: llength.n,v 1.8 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH llength n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
llength \- Count the number of elements in a list








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: llength.n,v 1.8.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH llength n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
llength \- Count the number of elements in a list
46
47
48
49
50
51
52
53
54
55
56
57
58
59
An empty list is not necessarily an empty string:
.CS
% set var { }; puts "[string length $var],[\fBllength\fR $var]"
1,0
.CE

.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), lsearch(n), 
lset(n), lsort(n), lrange(n), lreplace(n)
.VE

.SH KEYWORDS
element, list, length







<


<



46
47
48
49
50
51
52

53
54

55
56
57
An empty list is not necessarily an empty string:
.CS
% set var { }; puts "[string length $var],[\fBllength\fR $var]"
1,0
.CE

.SH "SEE ALSO"

list(n), lappend(n), lindex(n), linsert(n), lsearch(n), 
lset(n), lsort(n), lrange(n), lreplace(n)


.SH KEYWORDS
element, list, length

Changes to doc/load.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: load.n,v 1.12 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH load n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
load \- Load machine code and initialize new commands






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: load.n,v 1.12.2.2 2005/05/21 15:10:25 kennykb Exp $
'\" 
.so man.macros
.TH load n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
load \- Load machine code and initialize new commands
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
.PP
If \fIpackageName\fR is omitted or specified as an empty string,
Tcl tries to guess the name of the package.
This may be done differently on different platforms.
The default guess, which is used on most UNIX platforms, is to
take the last element of \fIfileName\fR, strip off the first
three characters if they are \fBlib\fR, and use any following
.VS
alphabetic and underline characters as the module name.
.VE
For example, the command \fBload libxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the
module name \fBlast\fR.
.VS "" br
.PP
If \fIfileName\fR is an empty string, then \fIpackageName\fR must
be specified.
The \fBload\fR command first searches for a statically loaded package
(one that has been registered by calling the \fBTcl_StaticPackage\fR
procedure) by that name; if one is found, it is used.
Otherwise, the \fBload\fR command searches for a dynamically loaded
package by that name, and uses it if it is found.  If several
different files have been \fBload\fRed with different versions of
the package, Tcl picks the file that was loaded first.
.VE
.SH "PORTABILITY ISSUES"
.TP
\fBWindows\fR\0\0\0\0\0
.
When a load fails with "library not found" error, it is also possible
that a dependent library was not found.  To see the dependent libraries,
type ``dumpbin -imports <dllname>'' in a DOS console to see what the







<

<



<










<







88
89
90
91
92
93
94

95

96
97
98

99
100
101
102
103
104
105
106
107
108

109
110
111
112
113
114
115
.PP
If \fIpackageName\fR is omitted or specified as an empty string,
Tcl tries to guess the name of the package.
This may be done differently on different platforms.
The default guess, which is used on most UNIX platforms, is to
take the last element of \fIfileName\fR, strip off the first
three characters if they are \fBlib\fR, and use any following

alphabetic and underline characters as the module name.

For example, the command \fBload libxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the
module name \fBlast\fR.

.PP
If \fIfileName\fR is an empty string, then \fIpackageName\fR must
be specified.
The \fBload\fR command first searches for a statically loaded package
(one that has been registered by calling the \fBTcl_StaticPackage\fR
procedure) by that name; if one is found, it is used.
Otherwise, the \fBload\fR command searches for a dynamically loaded
package by that name, and uses it if it is found.  If several
different files have been \fBload\fRed with different versions of
the package, Tcl picks the file that was loaded first.

.SH "PORTABILITY ISSUES"
.TP
\fBWindows\fR\0\0\0\0\0
.
When a load fails with "library not found" error, it is also possible
that a dependent library was not found.  To see the dependent libraries,
type ``dumpbin -imports <dllname>'' in a DOS console to see what the
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
.SH EXAMPLE
The following is a minimal extension:
.PP
.CS
#include <tcl.h>
#include <stdio.h>
static int fooCmd(ClientData clientData,
        Tcl_Interp *interp, int objc, char * CONST objv[]) {
    printf("called with %d arguments\\n", objc);
    return TCL_OK;
}
int Foo_Init(Tcl_Interp *interp) {
    if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
	return TCL_ERROR;
    }







|







129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
.SH EXAMPLE
The following is a minimal extension:
.PP
.CS
#include <tcl.h>
#include <stdio.h>
static int fooCmd(ClientData clientData,
        Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
    printf("called with %d arguments\\n", objc);
    return TCL_OK;
}
int Foo_Init(Tcl_Interp *interp) {
    if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
	return TCL_ERROR;
    }
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
(e.g. \fBfoo.dll\fR on Windows, \fBlibfoo.so\fR on Solaris and Linux)
it can then be loaded into Tcl with the following:
.PP
.CS
# Load the extension
switch $tcl_platform(platform) {
   windows {
      \fBload\fR ./foo.dll
   }
   unix {
      \fBload\fR ./libfoo[info sharedlibextension]
   }
}

# Now execute the command defined by the extension







|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
(e.g. \fBfoo.dll\fR on Windows, \fBlibfoo.so\fR on Solaris and Linux)
it can then be loaded into Tcl with the following:
.PP
.CS
# Load the extension
switch $tcl_platform(platform) {
   windows {
      \fBload\fR [file join [pwd] foo.dll]
   }
   unix {
      \fBload\fR ./libfoo[info sharedlibextension]
   }
}

# Now execute the command defined by the extension

Changes to doc/lrange.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27


28

29
30
31
32
33
34
35
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lrange.n,v 1.9 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH lrange n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lrange \- Return one or more adjacent elements from a list
.SH SYNOPSIS
\fBlrange \fIlist first last\fR
.BE

.SH DESCRIPTION
.PP
\fIList\fR must be a valid Tcl list.  This command will
return a new list consisting of elements
\fIfirst\fR through \fIlast\fR, inclusive.

\fIFirst\fR or \fIlast\fR
may be \fBend\fR (or any abbreviation of it) to refer to the last


element of the list.

If \fIfirst\fR is less than zero, it is treated as if it were zero.
If \fIlast\fR is greater than or equal to the number of elements
in the list, then it is treated as if it were \fBend\fR.
If \fIfirst\fR is greater than \fIlast\fR then an empty string
is returned.
Note: ``\fBlrange \fIlist first first\fR'' does not always produce the
same result as ``\fBlindex \fIlist first\fR'' (although it often does








|
















>
|
<
>
>
|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lrange.n,v 1.9.2.2 2005/05/05 17:55:25 kennykb Exp $
'\" 
.so man.macros
.TH lrange n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lrange \- Return one or more adjacent elements from a list
.SH SYNOPSIS
\fBlrange \fIlist first last\fR
.BE

.SH DESCRIPTION
.PP
\fIList\fR must be a valid Tcl list.  This command will
return a new list consisting of elements
\fIfirst\fR through \fIlast\fR, inclusive.
.VS 8.5
The index values \fIfirst\fR and \fIlast\fR are interpreted

the same as index values for the command \fBstring index\fR,
supporting simple index arithmetic and indices relative to the
end of the list.
.VE
If \fIfirst\fR is less than zero, it is treated as if it were zero.
If \fIlast\fR is greater than or equal to the number of elements
in the list, then it is treated as if it were \fBend\fR.
If \fIfirst\fR is greater than \fIlast\fR then an empty string
is returned.
Note: ``\fBlrange \fIlist first first\fR'' does not always produce the
same result as ``\fBlindex \fIlist first\fR'' (although it often does
62
63
64
65
66
67
68
69
70
71


72
73
74
75
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE

.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lset(n), lreplace(n), lsort(n)


.VE

.SH KEYWORDS
element, list, range, sublist







<

|
>
>




65
66
67
68
69
70
71

72
73
74
75
76
77
78
79
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE

.SH "SEE ALSO"

list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lset(n), lreplace(n), lsort(n),
.VS 8.5
string(n)
.VE

.SH KEYWORDS
element, list, range, sublist

Changes to doc/lreplace.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24



25



26
27
28
29

30
31
32
33
34
35
36
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lreplace.n,v 1.10 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH lreplace n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lreplace \- Replace elements in a list with new elements
.SH SYNOPSIS
\fBlreplace \fIlist first last \fR?\fIelement element ...\fR?
.BE

.SH DESCRIPTION
.PP
\fBlreplace\fR returns a new list formed by replacing one or more elements of
\fIlist\fR with the \fIelement\fR arguments.



\fIfirst\fR and \fIlast\fR specify the first and last index of the



range of elements to replace.  0 refers to the first element of the
list, and \fBend\fR (or any abbreviation of it) may be used to refer
to the last element of the list.  If \fIlist\fR is empty, then
\fIfirst\fR and \fIlast\fR are ignored.


If \fIfirst\fR is less than zero, it is considered to refer to the
first element of the list.  For non-empty lists, the element indicated
by \fIfirst\fR must exist.

If \fIlast\fR is less than zero but greater than \fIfirst\fR, then any
specified elements will be prepended to the list.  If \fIlast\fR is








|















>
>
>
|
>
>
>
|
<
|
|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
40
41
42
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lreplace.n,v 1.10.2.2 2005/05/05 17:55:25 kennykb Exp $
'\" 
.so man.macros
.TH lreplace n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lreplace \- Replace elements in a list with new elements
.SH SYNOPSIS
\fBlreplace \fIlist first last \fR?\fIelement element ...\fR?
.BE

.SH DESCRIPTION
.PP
\fBlreplace\fR returns a new list formed by replacing one or more elements of
\fIlist\fR with the \fIelement\fR arguments.
.VS 8.5
\fIfirst\fR and \fIlast\fR are index values specifying the first and
last elements of the range to replace.  
The index values \fIfirst\fR and \fIlast\fR are interpreted
the same as index values for the command \fBstring index\fR,
supporting simple index arithmetic and indices relative to the
end of the list.
0 refers to the first element of the

list, and \fBend\fR refers to the last element of the list.
If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored.
.VE

If \fIfirst\fR is less than zero, it is considered to refer to the
first element of the list.  For non-empty lists, the element indicated
by \fIfirst\fR must exist.

If \fIlast\fR is less than zero but greater than \fIfirst\fR, then any
specified elements will be prepended to the list.  If \fIlast\fR is
61
62
63
64
65
66
67
68
69
70


71

72
73
74
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var end end]
a b c d
.CE

.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lset(n), lrange(n), lsort(n)


.VE


.SH KEYWORDS
element, list, replace







<

|
>
>

>



67
68
69
70
71
72
73

74
75
76
77
78
79
80
81
82
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var end end]
a b c d
.CE

.SH "SEE ALSO"

list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lset(n), lrange(n), lsort(n),
.VS 8.5
string(n)
.VE


.SH KEYWORDS
element, list, replace

Changes to doc/lsearch.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\" -*- nroff -*-
'\" 
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\" Copyright (c) 2003-2004 Donal K. Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lsearch.n,v 1.21 2004/09/02 13:55:55 dkf Exp $
'\" 
.so man.macros
.TH lsearch n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lsearch \- See if a list contains a particular element
<









|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

'\" 
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\" Copyright (c) 2003-2004 Donal K. Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lsearch.n,v 1.21.2.3 2005/07/12 20:36:15 kennykb Exp $
'\" 
.so man.macros
.TH lsearch n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lsearch \- See if a list contains a particular element
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
\fIpattern\fR and must have one of the values below:
.SS "MATCHING STYLE OPTIONS"
If all matching style options are omitted, the default matching style
is \fB\-glob\fR.  If more than one matching style is specified, the
last matching style given takes precedence.
.TP
\fB\-exact\fR

The list element must contain exactly the same string as \fIpattern\fR.
.TP
\fB\-glob\fR
\fIPattern\fR is a glob-style pattern which is matched against each list
element using the same rules as the \fBstring match\fR command.
.TP
\fB\-regexp\fR
\fIPattern\fR is treated as a regular expression and matched against







>
|







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
\fIpattern\fR and must have one of the values below:
.SS "MATCHING STYLE OPTIONS"
If all matching style options are omitted, the default matching style
is \fB\-glob\fR.  If more than one matching style is specified, the
last matching style given takes precedence.
.TP
\fB\-exact\fR
\fIPattern\fR is a literal string that is compared for exact equality
against each list element.
.TP
\fB\-glob\fR
\fIPattern\fR is a glob-style pattern which is matched against each list
element using the same rules as the \fBstring match\fR command.
.TP
\fB\-regexp\fR
\fIPattern\fR is treated as a regular expression and matched against
67
68
69
70
71
72
73
74

75
76
77

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96







97
98
99
100
101
102
103
the result of the command is the list of all values that matched.
.TP
\fB\-not\fR
This negates the sense of the match, returning the index of the first
non-matching value in the list.
.TP
\fB\-start\fR\0\fIindex\fR
The list is searched starting at position \fIindex\fR.  If \fIindex\fR

has the value \fBend\fR, it refers to the last element in the list,
and \fBend\-\fIinteger\fR refers to the last element in the list minus
the specified integer offset.

.SS "CONTENTS DESCRIPTION OPTIONS"
These options describe how to interpret the items in the list being
searched.  They are only meaningful when used with the \fB\-exact\fR
and \fB\-sorted\fR options.  If more than one is specified, the last
one takes precedence.  The default is \fB\-ascii\fR.
.TP
\fB\-ascii\fR
The list elements are to be examined as Unicode strings (the name is
for backward-compatibility reasons.)
.TP
\fB\-dictionary\fR
The list elements are to be compared using dictionary-style
comparisons (see \fBlsort\fR for a fuller description). Note that this
only makes a meaningful difference from the \fB\-ascii\fR option when
the \fB\-sorted\fR option is given, because values are only
dictionary-equal when exactly equal.
.TP
\fB\-integer\fR
The list elements are to be compared as integers.







.TP
\fB\-real\fR
The list elements are to be compared as floating-point values.
.SS "SORTED LIST OPTIONS"
These options (only meaningful with the \fB\-sorted\fR option) specify
how the list is sorted.  If more than one is given, the last one takes
precedence.  The default option is \fB\-increasing\fR.







|
>
|
|
|
>



















>
>
>
>
>
>
>







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
the result of the command is the list of all values that matched.
.TP
\fB\-not\fR
This negates the sense of the match, returning the index of the first
non-matching value in the list.
.TP
\fB\-start\fR\0\fIindex\fR
The list is searched starting at position \fIindex\fR.  
.VS 8.5
The interpretation of the \fIindex\fR value is the same as
for the command \fBstring index\fR, supporting simple index
arithmetic and indices relative to the end of the list.
.VE 8.5
.SS "CONTENTS DESCRIPTION OPTIONS"
These options describe how to interpret the items in the list being
searched.  They are only meaningful when used with the \fB\-exact\fR
and \fB\-sorted\fR options.  If more than one is specified, the last
one takes precedence.  The default is \fB\-ascii\fR.
.TP
\fB\-ascii\fR
The list elements are to be examined as Unicode strings (the name is
for backward-compatibility reasons.)
.TP
\fB\-dictionary\fR
The list elements are to be compared using dictionary-style
comparisons (see \fBlsort\fR for a fuller description). Note that this
only makes a meaningful difference from the \fB\-ascii\fR option when
the \fB\-sorted\fR option is given, because values are only
dictionary-equal when exactly equal.
.TP
\fB\-integer\fR
The list elements are to be compared as integers.
.VS 8.5
.TP
\fB\-nocase\fR
Causes comparisons to be handled in a case-insensitive manner.  Has no
effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or 
\fB\-real\fR options.
.VE 8.5
.TP
\fB\-real\fR
The list elements are to be compared as floating-point values.
.SS "SORTED LIST OPTIONS"
These options (only meaningful with the \fB\-sorted\fR option) specify
how the list is sorted.  If more than one is given, the last one takes
precedence.  The default option is \fB\-increasing\fR.
163
164
165
166
167
168
169
170




171
172
173




.CS
\fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc*
      => {a abc} {b bcd}
.CE

.SH "SEE ALSO"
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), 
lset(n), lsort(n), lrange(n), lreplace(n)





.SH KEYWORDS
list, match, pattern, regular expression, search, string











|
>
>
>
>



>
>
>
>
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
.CS
\fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc*
      => {a abc} {b bcd}
.CE

.SH "SEE ALSO"
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), 
lset(n), lsort(n), lrange(n), lreplace(n),
.VS 8.5
string(n)
.VE


.SH KEYWORDS
list, match, pattern, regular expression, search, string

'\" Local Variables:
'\" mode: nroff
'\" End:

Changes to doc/lset.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lset.n,v 1.7 2003/12/01 21:27:14 msofer Exp $
'\" 
.so man.macros
.TH lset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lset \- Change an element in a list






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lset.n,v 1.7.2.1 2005/05/05 17:55:26 kennykb Exp $
'\" 
.so man.macros
.TH lset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lset \- Change an element in a list
48
49
50
51
52
53
54

55
56
57


58
59
60
61
62
63
64
replaced with \fInewValue\fR.  This new list is stored in the
variable \fIvarName\fR, and is also the return value from the \fBlset\fR
command.
.PP
If \fIindex\fR is negative or greater than or equal to the number
of elements in \fI$varName\fR, then an error occurs.
.PP

If \fIindex\fR has the value \fBend\fR, it refers to the last element
in the list, and \fBend\-\fIinteger\fR refers to the last element in
the list minus the specified integer offset.


.PP
If additional \fIindex\fR arguments are supplied, then each argument is
used in turn to address an element within a sublist designated
by the previous indexing operation,
allowing the script to alter elements in sublists.  The command,
.CS
lset a 1 2 newValue







>
|
|
<
>
>







48
49
50
51
52
53
54
55
56
57

58
59
60
61
62
63
64
65
66
replaced with \fInewValue\fR.  This new list is stored in the
variable \fIvarName\fR, and is also the return value from the \fBlset\fR
command.
.PP
If \fIindex\fR is negative or greater than or equal to the number
of elements in \fI$varName\fR, then an error occurs.
.PP
.VS 8.5
The interpretation of each simple \fIindex\fR value is the same as
for the command \fBstring index\fR, supporting simple index

arithmetic and indices relative to the end of the list.
.VE 8.5
.PP
If additional \fIindex\fR arguments are supplied, then each argument is
used in turn to address an element within a sublist designated
by the previous indexing operation,
allowing the script to alter elements in sublists.  The command,
.CS
lset a 1 2 newValue
103
104
105
106
107
108
109
110




111
112
113
The indicated return value also becomes the new value of \fIx\fR.
.CS
lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}}
lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lsort(n), lrange(n), lreplace(n)





.SH KEYWORDS
element, index, list, replace, set







|
>
>
>
>



105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
The indicated return value also becomes the new value of \fIx\fR.
.CS
lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}}
lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lsort(n), lrange(n), lreplace(n),
.VS 8.5
string(n)
.VE


.SH KEYWORDS
element, index, list, replace, set

Changes to doc/lsort.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lsort.n,v 1.18 2004/10/27 12:53:22 dkf Exp $
'\" 
.so man.macros
.TH lsort n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lsort \- Sort the elements of a list
.SH SYNOPSIS
\fBlsort \fR?\fIoptions\fR? \fIlist\fR
.BE









|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lsort.n,v 1.18.2.2 2005/07/12 20:36:16 kennykb Exp $
'\" 
.so man.macros
.TH lsort n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lsort \- Sort the elements of a list
.SH SYNOPSIS
\fBlsort \fR?\fIoptions\fR? \fIlist\fR
.BE
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
\fB\-index\0\fIindexList\fR
If this option is specified, each of the elements of \fIlist\fR must
itself be a proper Tcl sublist.  Instead of sorting based on whole
sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from
each sublist
.VS 8.5
(as if the overall element and the \fIindexList\fR were passed to
\fBlindex\fR) and sort based on the given element.  The keyword
\fBend\fP is allowed for each element of the \fIindexList\fR to sort
on the last sublist element, and \fBend-\fIindex\fR sorts on a sublist
element offset from the end.
.VE 8.5
For example,
.RS
.CS
lsort -integer -index 1 {{First 24} {Second 18} {Third 30}}
.CE
returns \fB{Second 18} {First 24} {Third 30}\fR, and







|
<
<
<







74
75
76
77
78
79
80
81



82
83
84
85
86
87
88
\fB\-index\0\fIindexList\fR
If this option is specified, each of the elements of \fIlist\fR must
itself be a proper Tcl sublist.  Instead of sorting based on whole
sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from
each sublist
.VS 8.5
(as if the overall element and the \fIindexList\fR were passed to
\fBlindex\fR) and sort based on the given element.  



.VE 8.5
For example,
.RS
.CS
lsort -integer -index 1 {{First 24} {Second 18} {Third 30}}
.CE
returns \fB{Second 18} {First 24} {Third 30}\fR, and
103
104
105
106
107
108
109







110
111
112
113
114
115
116
.CE
returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR
(because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.)
.VE 8.5
This option is much more efficient than using \fB\-command\fR
to achieve the same effect.
.RE







.TP 20
\fB\-unique\fR
If this option is specified, then only the last set of duplicate
elements found in the list will be retained.  Note that duplicates are
determined relative to the comparison used in the sort.  Thus if 
\fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
considered duplicates and only the second element, \fB{1 b}\fR, would







>
>
>
>
>
>
>







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
.CE
returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR
(because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.)
.VE 8.5
This option is much more efficient than using \fB\-command\fR
to achieve the same effect.
.RE
.VS 8.5
.TP 20
\fB\-nocase\fR
Causes comparisons to be handled in a case-insensitive manner.  Has no
effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or 
\fB\-real\fR options.
.VE 8.5
.TP 20
\fB\-unique\fR
If this option is specified, then only the last set of duplicate
elements found in the list will be retained.  Note that duplicates are
determined relative to the comparison used in the sort.  Thus if 
\fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
considered duplicates and only the second element, \fB{1 b}\fR, would

Added doc/mathfunc.n.



































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\" Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. All rights reserved
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: mathfunc.n,v 1.1.2.4 2005/10/08 13:44:37 dgp Exp $
'\" 
.so man.macros
.TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
mathfunc \- Mathematical functions for Tcl expressions
.SH SYNOPSIS
package require \fBTcl 8.5\fR
.sp
\fB::tcl::mathfunc::abs\fR \fIarg\fR
.br
\fB::tcl::mathfunc::acos\fR \fIarg\fR
.br
\fB::tcl::mathfunc::asin\fR \fIarg\fR
.br
\fB::tcl::mathfunc::atan\fR \fIarg\fR
.br
\fB::tcl::mathfunc::atan2\fR \fIy\fR \fIx\fR
.br
\fB::tcl::mathfunc::bool\fR \fIarg\fR
.br
\fB::tcl::mathfunc::ceil\fR \fIarg\fR
.br
\fB::tcl::mathfunc::cos\fR \fIarg\fR
.br
\fB::tcl::mathfunc::cosh\fR \fIarg\fR
.br
\fB::tcl::mathfunc::double\fR \fIarg\fR
.br
\fB::tcl::mathfunc::exp\fR \fIarg\fR
.br
\fB::tcl::mathfunc::floor\fR \fIarg\fR
.br
\fB::tcl::mathfunc::fmod\fR \fIx\fR \fIy\fR
.br
\fB::tcl::mathfunc::hypot\fR \fIx\fR \fIy\fR
.br
\fB::tcl::mathfunc::int\fR \fIarg\fR
.br
\fB::tcl::mathfunc::log\fR \fIarg\fR
.br
\fB::tcl::mathfunc::log10\fR \fIarg\fR
.br
\fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...?
.br
\fB::tcl::mathfunc::min\fR \fIarg\fR ?\fIarg\fR ...?
.br
\fB::tcl::mathfunc::pow\fR \fIx\fR \fIy\fR
.br
\fB::tcl::mathfunc::rand\fR
.br
\fB::tcl::mathfunc::round\fR \fIarg\fR
.br
\fB::tcl::mathfunc::sin\fR \fIarg\fR
.br
\fB::tcl::mathfunc::sinh\fR \fIarg\fR
.br
\fB::tcl::mathfunc::sqrt\fR \fIarg\fR
.br
\fB::tcl::mathfunc::srand\fR \fIarg\fR
.br
\fB::tcl::mathfunc::tan\fR \fIarg\fR
.br
\fB::tcl::mathfunc::tanh\fR \fIarg\fR
.br
\fB::tcl::mathfunc::wide\fR \fIarg\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
The \fBexpr\fR command handles mathematical functions of the form
\fBsin($x)\fR or \fBatan2($y,$x)\fR by converting them to calls of the
form \fB[tcl::math::sin [expr {$x}]]\fR or
\fB[tcl::math::atan2 [expr {$y}] [expr {$x}]]\fR.
A number of math functions are available by default within the
namespace \fB::tcl::mathfunc\fR; these functions are also available
for code apart from \fBexpr\fR, by invoking the given commands
directly.
.PP
Tcl supports the following mathematical functions in expressions, all
of which work solely with floating-point numbers unless otherwise noted:
.DS
.ta 3c 6c 9c
\fBabs\fR	\fBacos\fR	\fBasin\fR	\fBatan\fR
\fBatan2\fR	\fBbool\fR	\fBceil\fR	\fBcos\fR
\fBcosh\fR	\fBdouble\fR	\fBexp\fR	\fBfloor\fR
\fBfmod\fR	\fBhypot\fR	\fBint\fR	\fBlog\fR
\fBlog10\fR	\fBmax\fR	\fBmin\fR	\fBpow\fR
\fBrand\fR	\fBround\fR	\fBsin\fR	\fBsinh\fR
\fBsqrt\fR	\fBsrand\fR	\fBtan\fR	\fBtanh\fR
\fBwide\fR
.DE
.PP
.TP
\fBabs(\fIarg\fB)\fR
Returns the absolute value of \fIarg\fR.  \fIArg\fR may be either
integer or floating-point, and the result is returned in the same form.
.TP
\fBacos(\fIarg\fB)\fR
Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR]
radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBasin(\fIarg\fB)\fR
Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
radians.  \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBatan(\fIarg\fB)\fR
Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
radians.
.TP
\fBatan2(\fIy, x\fB)\fR
Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR]
radians.  \fIx\fR and \fIy\fR cannot both be 0.  If \fIx\fR is greater
than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR.
.TP
\fBbool(\fIarg\fB)\fR
Accepts any numerical value, or any string acceptable to
\fBstring is boolean\fR, and returns the corresponding 
boolean value \fB0\fR or \fB1\fR.  Non-zero numbers are true.
Other numbers are false.  Non-numeric strings produce boolean value in
agreement with \fBstring is true\fR and \fBstring is false\fR.
.TP
\fBceil(\fIarg\fB)\fR
Returns the smallest integral floating-point value (i.e. with a zero
fractional part) not less than \fIarg\fR.
.TP
\fBcos(\fIarg\fB)\fR
Returns the cosine of \fIarg\fR, measured in radians.
.TP
\fBcosh(\fIarg\fB)\fR
Returns the hyperbolic cosine of \fIarg\fR.  If the result would cause
an overflow, an error is returned.
.TP
\fBdouble(\fIarg\fB)\fR
If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts
\fIarg\fR to floating-point and returns the converted value.
.TP
\fBexp(\fIarg\fB)\fR
Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR.
If the result would cause an overflow, an error is returned.
.TP
\fBfloor(\fIarg\fB)\fR
Returns the largest integral floating-point value (i.e. with a zero
fractional part) not greater than \fIarg\fR.
.TP
\fBfmod(\fIx, y\fB)\fR
Returns the floating-point remainder of the division of \fIx\fR by
\fIy\fR.  If \fIy\fR is 0, an error is returned.
.TP
\fBhypot(\fIx, y\fB)\fR
Computes the length of the hypotenuse of a right-angled triangle
\fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR.
.TP
\fBint(\fIarg\fB)\fR
If \fIarg\fR is an integer value of the same width as the machine
word, returns \fIarg\fR, otherwise
converts \fIarg\fR to an integer (of the same size as a machine word,
i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by
truncation and returns the converted value.
.TP
\fBlog(\fIarg\fB)\fR
Returns the natural logarithm of \fIarg\fR.  \fIArg\fR must be a
positive value.
.TP
\fBlog10(\fIarg\fB)\fR
Returns the base 10 logarithm of \fIarg\fR.  \fIArg\fR must be a
positive value.
.TP
\fBmax(\fIarg\fB, \fI...\fB)\fR
Returns the maximum value of all given numeric arguments.
.TP
\fBmin(\fIarg\fB, \fI...\fB)\fR
Returns the minimum value of all given numeric arguments.
.TP
\fBpow(\fIx, y\fB)\fR
Computes the value of \fIx\fR raised to the power \fIy\fR.  If \fIx\fR
is negative, \fIy\fR must be an integer value.
.TP
\fBrand()\fR
Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR).  
The generator algorithm is a simple linear congruential generator that
is not cryptographically secure.  Each result from \fBrand\fR completely
determines all future results from subsequent calls to \fBrand\fR, so
\fBrand\fR should not be used to generate a sequence of secrets, such as
one-time passwords.  The seed of the generator is initialized from the
internal clock of the machine or may be set with the \fBsrand\fR function.
.TP
\fBround(\fIarg\fB)\fR
If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts
\fIarg\fR to integer by rounding and returns the converted value.
.TP
\fBsin(\fIarg\fB)\fR
Returns the sine of \fIarg\fR, measured in radians.
.TP
\fBsinh(\fIarg\fB)\fR
Returns the hyperbolic sine of \fIarg\fR.  If the result would cause
an overflow, an error is returned.
.TP
\fBsqrt(\fIarg\fB)\fR
Returns the square root of \fIarg\fR.  \fIArg\fR must be non-negative.
.TP
\fBsrand(\fIarg\fB)\fR
The \fIarg\fR, which must be an integer, is used to reset the seed for
the random number generator of \fBrand\fR.  Returns the first random
number (see \fBrand()\fR) from that seed.  Each interpreter has its own seed.
.TP
\fBtan(\fIarg\fB)\fR
Returns the tangent of \fIarg\fR, measured in radians.
.TP
\fBtanh(\fIarg\fB)\fR
Returns the hyperbolic tangent of \fIarg\fR.
.TP
\fBwide(\fIarg\fB)\fR
Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension
if \fIarg\fR is a 32-bit number) if it is not one already.
.PP
In addition to these predefined functions, applications may
define additional functions by using \fBproc\fR (or any other method,
such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define
new commands in the \fBtcl::mathfunc\fR namespace.  In addition, an
obsolete interface named \fBTcl_CreateMathFunc\fR() is available to
extensions that are written in C. The latter interface is not recommended
for new implementations..
.SH "SEE ALSO"
expr(n), namespace(n)
.SH "COPYRIGHT"
Copyright (c) 1993 The Regents of the University of California.
.br
Copyright (c) 1994-2000 Sun Microsystems Incorporated.
.br
Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. All rights reserved.

Changes to doc/msgcat.n.

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
The list is ordered from most specific to least
preference.  The list is derived from the current
locale set in msgcat by \fB::msgcat::mclocale\fR, and
cannot be set independently.  For example, if the
current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
.VS 1.4
returns \fB{en_US_funky en_US en {}}\fR.
.VE
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcpreferences\fR
(note that these are all lowercase), extended by the file
extension ``.msg''.  Each matching file is 
read in order, assuming a UTF-8 encoding.  The file contents are







|







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
The list is ordered from most specific to least
preference.  The list is derived from the current
locale set in msgcat by \fB::msgcat::mclocale\fR, and
cannot be set independently.  For example, if the
current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
.VS 1.4
returns \fB{en_US_funky en_US en {}}\fR.
.VE 1.4
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcpreferences\fR
(note that these are all lowercase), extended by the file
extension ``.msg''.  Each matching file is 
read in order, assuming a UTF-8 encoding.  The file contents are
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
locale of ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation.  For example, if a user specifies
.VS 1.4
en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', ``en'' and ``''
(the empty string)
.VE
are searched in order until a matching translation
string is found.  If no translation string is available, then
\fB::msgcat::unknown\fR is called.
.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
to the namespace from which they were added.  This allows







|







166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
locale of ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation.  For example, if a user specifies
.VS 1.4
en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', ``en'' and ``''
(the empty string)
.VE 1.4
are searched in order until a matching translation
string is found.  If no translation string is available, then
\fB::msgcat::unknown\fR is called.
.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
to the namespace from which they were added.  This allows
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
.IP [2]
The message file name is a msgcat locale specifier (all lowercase)
followed by ``.msg''.  For example:
.CS
es.msg    -- spanish
en_gb.msg -- United Kingdom English
.CE
.VS
\fIException:\fR The message file for the root locale ``'' is
called \fBROOT.msg\fR.  This exception is made so as not to
cause peculiar behavior, such as marking the message file as
``hidden'' on Unix file systems.
.VE
.IP [3]
The file contains a series of calls to \fBmcset\fR and
\fBmcmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.CS







|




|







236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
.IP [2]
The message file name is a msgcat locale specifier (all lowercase)
followed by ``.msg''.  For example:
.CS
es.msg    -- spanish
en_gb.msg -- United Kingdom English
.CE
.VS 1.4
\fIException:\fR The message file for the root locale ``'' is
called \fBROOT.msg\fR.  This exception is made so as not to
cause peculiar behavior, such as marking the message file as
``hidden'' on Unix file systems.
.VE 1.4
.IP [3]
The file contains a series of calls to \fBmcset\fR and
\fBmcmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.CS

Changes to doc/namespace.n.

1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: namespace.n,v 1.16 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH namespace n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
namespace \- create and manipulate contexts for commands and variables




>




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\" Copyright (c) 2004-2005 Donal K. Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: namespace.n,v 1.16.2.2 2005/07/12 20:36:16 kennykb Exp $
'\" 
.so man.macros
.TH namespace n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
namespace \- create and manipulate contexts for commands and variables
211
212
213
214
215
216
217











218
219
220
221
222
223
224
the command's own fully-qualified name is returned.
.TP
\fBnamespace parent\fR ?\fInamespace\fR?
Returns the fully-qualified name of the parent namespace
for namespace \fInamespace\fR.
If \fInamespace\fR is not specified,
the fully-qualified name of the current namespace's parent is returned.











.TP
\fBnamespace qualifiers\fR \fIstring\fR
Returns any leading namespace qualifiers for \fIstring\fR.
Qualifiers are namespace names separated by double colons (\fB::\fR).
For the \fIstring\fR \fB::foo::bar::x\fR,
this command returns \fB::foo::bar\fR,
and for \fB::\fR it returns an empty string.







>
>
>
>
>
>
>
>
>
>
>







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
the command's own fully-qualified name is returned.
.TP
\fBnamespace parent\fR ?\fInamespace\fR?
Returns the fully-qualified name of the parent namespace
for namespace \fInamespace\fR.
If \fInamespace\fR is not specified,
the fully-qualified name of the current namespace's parent is returned.
.TP
\fBnamespace path\fR ?\fInamespaceList\fR?
'\" Should really have the .TP inside the .VS, but that triggers a groff bug
.VS 8.5
Returns the command resolution path of the current namespace. If
\fInamespaceList\fR is specified as a list of named namespaces, the
current namespace's command resolution path is set to those namespaces
and returns the empty list. The default command resolution path is
always empty. See the section \fBNAME RESOLUTION\fR below for an
explanation of the rules regarding name resolution.
.VE 8.5
.TP
\fBnamespace qualifiers\fR \fIstring\fR
Returns any leading namespace qualifiers for \fIstring\fR.
Qualifiers are namespace names separated by double colons (\fB::\fR).
For the \fIstring\fR \fB::foo::bar::x\fR,
this command returns \fB::foo::bar\fR,
and for \fB::\fR it returns an empty string.
383
384
385
386
387
388
389
390
391
392
393








394
395
396
397
398
399
400
This means you can give qualified names to such commands as
\fBset\fR, \fBproc\fR, \fBrename\fR, and \fBinterp alias\fR.
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR), 
Tcl follows a fixed rule for looking it up:
Command and variable names are always resolved
by looking first in the current namespace,
and then in the global namespace.








Namespace names, on the other hand, are always resolved
by looking in only the current namespace.
.PP
In the following example,
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {







|
|


>
>
>
>
>
>
>
>







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
This means you can give qualified names to such commands as
\fBset\fR, \fBproc\fR, \fBrename\fR, and \fBinterp alias\fR.
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR), 
Tcl follows basic rules for looking it up:
Variable names are always resolved
by looking first in the current namespace,
and then in the global namespace.
.VS 8.5
Command names are also always resolved by looking in the current
namespace first. If not found there, they are searched for in every
namespace on the current namespace's command path (which is empty by
default). If not found there, command names are looked up in the
global namespace (or, failing that, are processed by the \fBunknown\fR
command.)
.VE 8.5
Namespace names, on the other hand, are always resolved
by looking in only the current namespace.
.PP
In the following example,
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {
760
761
762
763
764
765
766
767
768






769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
   \fBnamespace export\fR grill
}
.CE
.PP
Call the command defined in the previous example in various ways.
.CS
# Direct call
foo::grill







# Import into current namespace, then call local alias
namespace import foo::grill
grill

# Create two ensembles, one with the default name and one with a
# specified name.  Then call through the ensembles.
\fBnamespace eval\fR foo {
   \fBnamespace ensemble\fR create
   \fBnamespace ensemble\fR create -command ::foobar
}
foo grill
foobar grill
.CE
.PP
Look up where the command imported in the previous example came from:
.CS
puts "grill came from [\fBnamespace which\fR grill]"
.CE

.SH "SEE ALSO"
interp(n), variable(n)

.SH KEYWORDS
command, ensemble, exported, internal, variable







|

>
>
>
>
>
>

|














|







780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
   \fBnamespace export\fR grill
}
.CE
.PP
Call the command defined in the previous example in various ways.
.CS
# Direct call
::foo::grill

# Use the command resolution path to find the name
\fBnamespace eval\fR boo {
   \fBnamespace path\fR ::foo
   grill
}

# Import into current namespace, then call local alias
\fBnamespace import\fR foo::grill
grill

# Create two ensembles, one with the default name and one with a
# specified name.  Then call through the ensembles.
\fBnamespace eval\fR foo {
   \fBnamespace ensemble\fR create
   \fBnamespace ensemble\fR create -command ::foobar
}
foo grill
foobar grill
.CE
.PP
Look up where the command imported in the previous example came from:
.CS
puts "grill came from [\fBnamespace origin\fR grill]"
.CE

.SH "SEE ALSO"
interp(n), variable(n)

.SH KEYWORDS
command, ensemble, exported, internal, variable

Changes to doc/open.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: open.n,v 1.22 2004/11/09 04:51:31 davygrvy Exp $
'\" 
.so man.macros
.TH open n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
open \- Open a file-based or command pipeline channel







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: open.n,v 1.22.2.2 2005/05/05 17:55:27 kennykb Exp $
'\" 
.so man.macros
.TH open n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
open \- Open a file-based or command pipeline channel
57
58
59
60
61
62
63








64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79





80
81
82
83
84
85
86
create a new empty file.
Set the initial access position  to the end of the file.
.TP 15
\fBa+\fR
Open the file for reading and writing.  If the file doesn't exist,
create a new empty file.
Set the initial access position  to the end of the file.








.PP
In the second form, \fIaccess\fR consists of a list of any of the
following flags, all of which have the standard POSIX meanings.
One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR.
.TP 15
\fBRDONLY\fR
Open the file for reading only.
.TP 15
\fBWRONLY\fR
Open the file for writing only.
.TP 15
\fBRDWR\fR
Open the file for both reading and writing.
.TP 15
\fBAPPEND\fR
Set the file pointer to the end of the file prior to each write.





.TP 15
\fBCREAT\fR
Create the file if it doesn't already exist (without this flag it
is an error for the file not to exist).
.TP 15
\fBEXCL\fR
If \fBCREAT\fR is also specified, an error is returned if the







>
>
>
>
>
>
>
>
















>
>
>
>
>







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
create a new empty file.
Set the initial access position  to the end of the file.
.TP 15
\fBa+\fR
Open the file for reading and writing.  If the file doesn't exist,
create a new empty file.
Set the initial access position  to the end of the file.
.VS 8.5
.PP
All of the legal \fIaccess\fR values above may have the character
\fBb\fR added as the second or third character in the value to
indicate that the opened channel should be configured with the
\fB-translation binary\fR option, making the channel suitable for 
reading or writing of binary data.
.VE 8.5
.PP
In the second form, \fIaccess\fR consists of a list of any of the
following flags, all of which have the standard POSIX meanings.
One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR.
.TP 15
\fBRDONLY\fR
Open the file for reading only.
.TP 15
\fBWRONLY\fR
Open the file for writing only.
.TP 15
\fBRDWR\fR
Open the file for both reading and writing.
.TP 15
\fBAPPEND\fR
Set the file pointer to the end of the file prior to each write.
.TP 15
.VS 8.5
\fBBINARY\fR
Configure the opened channed with the \fB-translation binary\fR option.
.VE 8.5
.TP 15
\fBCREAT\fR
Create the file if it doesn't already exist (without this flag it
is an error for the file not to exist).
.TP 15
\fBEXCL\fR
If \fBCREAT\fR is also specified, an error is returned if the
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
\fBTRUNC\fR
If the file exists it is truncated to zero length.
.PP
If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.
.PP
Note that if you are going to be reading or writing binary data from
the channel created by this command, you should use the
\fBfconfigure\fR command to change the \fB-translation\fR option of
the channel to \fBbinary\fR before transferring any binary data.  This
is in contrast to the ``b'' character passed as part of the equivalent
of the \fIaccess\fR parameter to some versions of the C library
\fIfopen()\fR function.

.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is ``|'' then the
remaining characters of \fIfileName\fR are treated as a list of arguments
that describe a command pipeline to invoke, in the same style as the
arguments for \fBexec\fR.







<
<
<
<
<
<
<
<







115
116
117
118
119
120
121








122
123
124
125
126
127
128
\fBTRUNC\fR
If the file exists it is truncated to zero length.
.PP
If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.









.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is ``|'' then the
remaining characters of \fIfileName\fR are treated as a list of arguments
that describe a command pipeline to invoke, in the same style as the
arguments for \fBexec\fR.
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
a Tcl error is generated when \fBclose\fR is called on the channel
unless the pipeline is in non-blocking mode then no exit status is
returned (a silent \fBclose\fR with -blocking 0).
.PP
It is often useful to use the \fBfileevent\fR command with pipelines
so other processing may happen at the same time as running the command
in the background.
.VS 8.4
.SH "SERIAL COMMUNICATIONS"
.PP
If \fIfileName\fR refers to a serial port, then the specified serial port
is opened and initialized in a platform-dependent manner.  Acceptable
values for the \fIfileName\fR to use to open a serial port are described in
the PORTABILITY ISSUES section.
.PP







<







143
144
145
146
147
148
149

150
151
152
153
154
155
156
a Tcl error is generated when \fBclose\fR is called on the channel
unless the pipeline is in non-blocking mode then no exit status is
returned (a silent \fBclose\fR with -blocking 0).
.PP
It is often useful to use the \fBfileevent\fR command with pipelines
so other processing may happen at the same time as running the command
in the background.

.SH "SERIAL COMMUNICATIONS"
.PP
If \fIfileName\fR refers to a serial port, then the specified serial port
is opened and initialized in a platform-dependent manner.  Acceptable
values for the \fIfileName\fR to use to open a serial port are described in
the PORTABILITY ISSUES section.
.PP
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
\fBFRAME\fR
A stop-bit error has been detected by your UART.
Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
may cause this error.
.TP 10
\fBBREAK\fR
A BREAK condition has been detected by your UART (see above).
.VE

.SH "PORTABILITY ISSUES"
.TP
\fBWindows \fR(all versions)
Valid values for \fIfileName\fR to open a serial port are of the form
\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4.
This notation only works for serial ports from 1 to 9, if the system







<







322
323
324
325
326
327
328

329
330
331
332
333
334
335
\fBFRAME\fR
A stop-bit error has been detected by your UART.
Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
may cause this error.
.TP 10
\fBBREAK\fR
A BREAK condition has been detected by your UART (see above).


.SH "PORTABILITY ISSUES"
.TP
\fBWindows \fR(all versions)
Valid values for \fIfileName\fR to open a serial port are of the form
\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4.
This notation only works for serial ports from 1 to 9, if the system
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
until the pipe is actually closed.  This problem occurs because 16-bit DOS
applications are run synchronously, as described above.  
.TP
\fBUnix\fR\0\0\0\0\0\0\0
Valid values for \fIfileName\fR to open a serial port are generally of the
form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name
of any pseudo-file that maps to a serial port may be used.
.VS 8.4
Advanced configuration options are only supported for serial ports
when Tcl is built to use the POSIX serial interface.
.VE 8.4
.sp
When running Tcl interactively, there may be some strange interactions
between the console, if one is present, and a command pipeline that uses
standard input.  If a command pipeline is opened for reading, some
of the lines entered at the console will be sent to the command pipeline and
some will be sent to the Tcl evaluator.  This problem only occurs because
both Tcl and the child application are competing for the console at the







<


<







383
384
385
386
387
388
389

390
391

392
393
394
395
396
397
398
until the pipe is actually closed.  This problem occurs because 16-bit DOS
applications are run synchronously, as described above.  
.TP
\fBUnix\fR\0\0\0\0\0\0\0
Valid values for \fIfileName\fR to open a serial port are generally of the
form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name
of any pseudo-file that maps to a serial port may be used.

Advanced configuration options are only supported for serial ports
when Tcl is built to use the POSIX serial interface.

.sp
When running Tcl interactively, there may be some strange interactions
between the console, if one is present, and a command pipeline that uses
standard input.  If a command pipeline is opened for reading, some
of the lines entered at the console will be sent to the command pipeline and
some will be sent to the Tcl evaluator.  This problem only occurs because
both Tcl and the child application are competing for the console at the

Changes to doc/pkgMkIndex.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
'\"
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.14 2003/02/25 23:58:09 dgp Exp $
'\" 
.so man.macros
.TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
pkg_mkIndex \- Build an index for automatic loading of packages
.SH SYNOPSIS
.nf
.VS 8.3.0
\fBpkg_mkIndex ?\fI\-direct\fR?  ?\fI\-lazy\fR?  ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR?
.VE
.fi
.BE

.SH DESCRIPTION
.PP
\fBPkg_mkIndex\fR is a utility procedure that is part of the standard
Tcl library.






|









<

<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

17

18
19
20
21
22
23
24
'\"
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.14.6.2 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
pkg_mkIndex \- Build an index for automatic loading of packages
.SH SYNOPSIS
.nf

\fBpkg_mkIndex ?\fI\-direct\fR?  ?\fI\-lazy\fR?  ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR?

.fi
.BE

.SH DESCRIPTION
.PP
\fBPkg_mkIndex\fR is a utility procedure that is part of the standard
Tcl library.
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
the package and version number, and each binary file must contain
a call to \fBTcl_PkgProvide\fR.
.IP [2]
Create the index by invoking \fBpkg_mkIndex\fR.
The \fIdir\fR argument gives the name of a directory and each
\fIpattern\fR argument is a \fBglob\fR-style pattern that selects
script or binary files in \fIdir\fR.
.VS 8.0.3
The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR.
.VE
.br
\fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR
with package information about all the files given by the \fIpattern\fR
arguments.
It does this by loading each file into a slave
interpreter and seeing what packages
and new commands appear (this is why it is essential to have







<

<







35
36
37
38
39
40
41

42

43
44
45
46
47
48
49
the package and version number, and each binary file must contain
a call to \fBTcl_PkgProvide\fR.
.IP [2]
Create the index by invoking \fBpkg_mkIndex\fR.
The \fIdir\fR argument gives the name of a directory and each
\fIpattern\fR argument is a \fBglob\fR-style pattern that selects
script or binary files in \fIdir\fR.

The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR.

.br
\fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR
with package information about all the files given by the \fIpattern\fR
arguments.
It does this by loading each file into a slave
interpreter and seeing what packages
and new commands appear (this is why it is essential to have
105
106
107
108
109
110
111
112

113
114
115
116
117
118
119
\fB\-direct\fR
The generated index will implement direct loading of the package
upon \fBpackage require\fR.  This is the default.
.TP 15
\fB\-lazy\fR
The generated index will manage to delay loading the package until the
use of one of the commands provided by the package, instead of loading
it immediately upon \fBpackage require\fR.

.TP 15
\fB\-load \fIpkgPat\fR
The index process will pre-load any packages that exist in the
current interpreter and match \fIpkgPat\fP into the slave interpreter used to
generate the index.  The pattern match uses string match rules, but without
making case distinctions.
See COMPLEX CASES below.







|
>







101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
\fB\-direct\fR
The generated index will implement direct loading of the package
upon \fBpackage require\fR.  This is the default.
.TP 15
\fB\-lazy\fR
The generated index will manage to delay loading the package until the
use of one of the commands provided by the package, instead of loading
it immediately upon \fBpackage require\fR.  This is not compatible with
the use of \fIauto_reset\fR, and therefore its use is discouraged.
.TP 15
\fB\-load \fIpkgPat\fR
The index process will pre-load any packages that exist in the
current interpreter and match \fIpkgPat\fP into the slave interpreter used to
generate the index.  The pattern match uses string match rules, but without
making case distinctions.
See COMPLEX CASES below.
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
evaluates all of the \fBpkgIndex.tcl\fR files in the
\fBauto_path\fR.
The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR
commands for each version of each available package;  these commands
invoke \fBpackage provide\fR commands to announce the
availability of the package, and they setup auto-loader
information to load the files of the package.
.VS 8.3
If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR
was generated,
.VE
a given file of a given version of a given package isn't
actually loaded until the first time one of its commands
is invoked.
Thus, after invoking \fBpackage require\fR you may
not see the package's commands in the interpreter, but you will be able
to invoke the commands and they will be auto-loaded.

.VS 8.3
.SH "DIRECT LOADING"
.PP
Some packages, for instance packages which use namespaces and export
commands or those which require special initialization, might select
that their package files be loaded immediately upon \fBpackage require\fR
instead of delaying the actual loading to the first use of one of the
package's command. This is the default mode when generating the package
index.  It can be overridden by specifying the \fI\-lazy\fR argument.
.VE

.SH "COMPLEX CASES"
Most complex cases of dependencies among scripts
and binary files, and packages being split among scripts and
binary files are handled OK.  However, you may have to adjust
the order in which files are processed by \fBpkg_mkIndex\fR.
These issues are described in detail below.







<


<







<








<







152
153
154
155
156
157
158

159
160

161
162
163
164
165
166
167

168
169
170
171
172
173
174
175

176
177
178
179
180
181
182
evaluates all of the \fBpkgIndex.tcl\fR files in the
\fBauto_path\fR.
The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR
commands for each version of each available package;  these commands
invoke \fBpackage provide\fR commands to announce the
availability of the package, and they setup auto-loader
information to load the files of the package.

If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR
was generated,

a given file of a given version of a given package isn't
actually loaded until the first time one of its commands
is invoked.
Thus, after invoking \fBpackage require\fR you may
not see the package's commands in the interpreter, but you will be able
to invoke the commands and they will be auto-loaded.


.SH "DIRECT LOADING"
.PP
Some packages, for instance packages which use namespaces and export
commands or those which require special initialization, might select
that their package files be loaded immediately upon \fBpackage require\fR
instead of delaying the actual loading to the first use of one of the
package's command. This is the default mode when generating the package
index.  It can be overridden by specifying the \fI\-lazy\fR argument.


.SH "COMPLEX CASES"
Most complex cases of dependencies among scripts
and binary files, and packages being split among scripts and
binary files are handled OK.  However, you may have to adjust
the order in which files are processed by \fBpkg_mkIndex\fR.
These issues are described in detail below.

Changes to doc/puts.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: puts.n,v 1.8 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH puts n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
puts \- Write to a channel
.SH SYNOPSIS
\fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR
.BE

.SH DESCRIPTION
.PP
Writes the characters given by \fIstring\fR to the channel given
by \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension. The channel
must have been opened for output.
.VE
.PP
If no \fIchannelId\fR is specified then it defaults to
\fBstdout\fR. \fBPuts\fR normally outputs a newline character after
\fIstring\fR, but this feature may be suppressed by specifying the
\fB\-nonewline\fR switch.
.PP
Newline characters in the output are translated by \fBputs\fR to







|
















<





<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29

30
31
32
33
34
35
36
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: puts.n,v 1.8.2.1 2005/04/10 23:14:43 kennykb Exp $
'\" 
.so man.macros
.TH puts n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
puts \- Write to a channel
.SH SYNOPSIS
\fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR
.BE

.SH DESCRIPTION
.PP
Writes the characters given by \fIstring\fR to the channel given
by \fIchannelId\fR.
.PP

\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension. The channel
must have been opened for output.

.PP
If no \fIchannelId\fR is specified then it defaults to
\fBstdout\fR. \fBPuts\fR normally outputs a newline character after
\fIstring\fR, but this feature may be suppressed by specifying the
\fB\-nonewline\fR switch.
.PP
Newline characters in the output are translated by \fBputs\fR to

Changes to doc/re_syntax.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\" -*- nroff -*-
'\"
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: re_syntax.n,v 1.5 2004/10/31 16:01:54 dkf Exp $
'\"
.so man.macros
.TH re_syntax n "8.1" Tcl "Tcl Built-In Commands"
.BS
.SH NAME
re_syntax \- Syntax of Tcl regular expressions
.BE
<







|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

'\"
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: re_syntax.n,v 1.5.2.2 2005/04/10 23:14:43 kennykb Exp $
'\"
.so man.macros
.TH re_syntax n "8.1" Tcl "Tcl Built-In Commands"
.BS
.SH NAME
re_syntax \- Syntax of Tcl regular expressions
.BE
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR,
concatenated.
It matches a match for the first, followed by a match for the second, etc;
an empty branch matches the empty string.
.PP
A quantified atom is an \fIatom\fR possibly followed
by a single \fIquantifier\fR.
Without a quantifier, it matches a match for the atom.
The quantifiers,
and what a so-quantified atom matches, are:
.RS 2
.TP 6
\fB*\fR
a sequence of 0 or more matches of the atom
.TP







|







44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR,
concatenated.
It matches a match for the first, followed by a match for the second, etc;
an empty branch matches the empty string.
.PP
A quantified atom is an \fIatom\fR possibly followed
by a single \fIquantifier\fR.
Without a quantifier, it matches a single match for the atom.
The quantifiers,
and what a so-quantified atom matches, are:
.RS 2
.TP 6
\fB*\fR
a sequence of 0 or more matches of the atom
.TP
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
.PP
The forms using \fB{\fR and \fB}\fR are known as \fIbound\fRs.  The
numbers \fIm\fR and \fIn\fR are unsigned decimal integers with
permissible values from 0 to 255 inclusive.
.PP
An atom is one of:
.RS 2
.TP 6
\fB(\fIre\fB)\fR
(where \fIre\fR is any regular expression) matches a match for
\fIre\fR, with the match noted for possible reporting
.TP
\fB(?:\fIre\fB)\fR
as previous, but does no reporting (a ``non-capturing'' set of
parentheses)
.TP
\fB()\fR
matches an empty string, noted for possible reporting
.TP
\fB(?:)\fR
matches an empty string, without reporting
.TP
\fB[\fIchars\fB]\fR
a \fIbracket expression\fR, matching any one of the \fIchars\fR (see
\fBBRACKET EXPRESSIONS\fR for more detail)
.TP
\fB.\fR
matches any single character
.TP
\fB\e\fIk\fR
(where \fIk\fR is a non-alphanumeric character) matches that character
taken as an ordinary character, e.g. \e\e matches a backslash
character
.TP
\fB\e\fIc\fR
where \fIc\fR is alphanumeric (possibly followed by other characters),
an \fIescape\fR (AREs only), see \fBESCAPES\fR below
.TP
\fB{\fR
when followed by a character other than a digit, matches the
left-brace character `\fB{\fR'; when followed by a digit, it is the
beginning of a \fIbound\fR (see above)
.TP
\fIx\fR
where \fIx\fR is a single character with no other significance,
matches that character.
.RE
.PP
A \fIconstraint\fR matches an empty string when specific conditions
are met.  A constraint may not be followed by a quantifier.  The
simple constraints are as follows; some more constraints are described







<
|
|
|
<
|


<
|

<
|

<
|


<
|

<
|
|
|

<
|


<
|



<
|







81
82
83
84
85
86
87

88
89
90

91
92
93

94
95

96
97

98
99
100

101
102

103
104
105
106

107
108
109

110
111
112
113

114
115
116
117
118
119
120
121
.PP
The forms using \fB{\fR and \fB}\fR are known as \fIbound\fRs.  The
numbers \fIm\fR and \fIn\fR are unsigned decimal integers with
permissible values from 0 to 255 inclusive.
.PP
An atom is one of:
.RS 2

.IP \fB(\fIre\fB)\fR 6
matches a match for \fIre\fR (\fIre\fR is any regular expression) with
the match noted for possible reporting

.IP \fB(?:\fIre\fB)\fR
as previous, but does no reporting (a ``non-capturing'' set of
parentheses)

.IP \fB()\fR
matches an empty string, noted for possible reporting

.IP \fB(?:)\fR
matches an empty string, without reporting

.IP \fB[\fIchars\fB]\fR
a \fIbracket expression\fR, matching any one of the \fIchars\fR (see
\fBBRACKET EXPRESSIONS\fR for more detail)

.IP \fB.\fR
matches any single character

.IP \fB\e\fIk\fR
matches the non-alphanumeric character \fIk\fR
taken as an ordinary character, e.g. \fB\e\e\fR matches a backslash
character

.IP \fB\e\fIc\fR
where \fIc\fR is alphanumeric (possibly followed by other characters),
an \fIescape\fR (AREs only), see \fBESCAPES\fR below

.IP \fB{\fR
when followed by a character other than a digit, matches the
left-brace character `\fB{\fR'; when followed by a digit, it is the
beginning of a \fIbound\fR (see above)

.IP \fIx\fR
where \fIx\fR is a single character with no other significance,
matches that character.
.RE
.PP
A \fIconstraint\fR matches an empty string when specific conditions
are met.  A constraint may not be followed by a quantifier.  The
simple constraints are as follows; some more constraints are described
650
651
652
653
654
655
656




respectively; no other escapes are available.

.SH "SEE ALSO"
RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n)

.SH KEYWORDS
match, regular expression, string











>
>
>
>
639
640
641
642
643
644
645
646
647
648
649
respectively; no other escapes are available.

.SH "SEE ALSO"
RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n)

.SH KEYWORDS
match, regular expression, string

'\" Local Variables:
'\" mode: nroff
'\" End:

Changes to doc/read.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: read.n,v 1.9 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH read n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
read \- Read from a channel







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: read.n,v 1.9.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH read n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
read \- Read from a channel
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
how many characters to read.  Exactly that many characters will be
read and returned, unless there are fewer than \fInumChars\fR left in
the file; in this case all the remaining characters are returned.  If
the channel is configured to use a multi-byte encoding, then the
number of characters read may not be the same as the number of bytes
read.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as the
Tcl standard input channel (\fBstdin\fR), the return value from an
invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
creation command provided by a Tcl extension. The channel must have
been opened for input.
.VE
.PP
If \fIchannelId\fR is in nonblocking mode, the command may not read as
many characters as requested: once all available input has been read,
the command will return the data that is available rather than
blocking for more input.  If the channel is configured to use a
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character.  These







<





<







28
29
30
31
32
33
34

35
36
37
38
39

40
41
42
43
44
45
46
how many characters to read.  Exactly that many characters will be
read and returned, unless there are fewer than \fInumChars\fR left in
the file; in this case all the remaining characters are returned.  If
the channel is configured to use a multi-byte encoding, then the
number of characters read may not be the same as the number of bytes
read.
.PP

\fIChannelId\fR must be an identifier for an open channel such as the
Tcl standard input channel (\fBstdin\fR), the return value from an
invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
creation command provided by a Tcl extension. The channel must have
been opened for input.

.PP
If \fIchannelId\fR is in nonblocking mode, the command may not read as
many characters as requested: once all available input has been read,
the command will return the data that is available rather than
blocking for more input.  If the channel is configured to use a
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character.  These

Changes to doc/regexp.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: regexp.n,v 1.16 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH regexp n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
regexp \- Match a regular expression against a string






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: regexp.n,v 1.16.2.2 2005/05/05 17:55:27 kennykb Exp $
'\" 
.so man.macros
.TH regexp n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
regexp \- Match a regular expression against a string
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
beginning and end of a line respectively.  This is the same as
specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR
manual page).
.TP 15
\fB\-nocase\fR
Causes upper-case characters in \fIstring\fR to be treated as
lower case during the matching process.
.VS 8.3
.TP 15
\fB\-all\fR
Causes the regular expression to be matched as many times as possible
in the string, returning the total number of matches found.  If this
is specified with match variables, they will contain information for
the last match only.
.TP 15







<







79
80
81
82
83
84
85

86
87
88
89
90
91
92
beginning and end of a line respectively.  This is the same as
specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR
manual page).
.TP 15
\fB\-nocase\fR
Causes upper-case characters in \fIstring\fR to be treated as
lower case during the matching process.

.TP 15
\fB\-all\fR
Causes the regular expression to be matched as many times as possible
in the string, returning the total number of matches found.  If this
is specified with match variables, they will contain information for
the last match only.
.TP 15
104
105
106
107
108
109
110
111





112
113
114
115
116
117
118
119
120
121
122
123
124
 => {in n}
    regexp -all -inline -- {\\w(\\w)} " inlined "
 => {in n li i ne e}
.CE
.TP 15
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
matching the regular expression at.  When using this switch, `^'





will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR.  If \fB\-indices\fR
is specified, the indices will be indexed starting from the
absolute beginning of the input string.
\fIindex\fR will be constrained to the bounds of the input string.
.VE 8.3
.TP 15
\fB\-\|\-\fR
Marks the end of switches.  The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP
If there are more \fIsubMatchVar\fR's than parenthesized
subexpressions within \fIexp\fR, or if a particular subexpression







|
>
>
>
>
>





<







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

121
122
123
124
125
126
127
 => {in n}
    regexp -all -inline -- {\\w(\\w)} " inlined "
 => {in n li i ne e}
.CE
.TP 15
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
matching the regular expression at.  
.VS 8.5
The \fIindex\fR value is interpreted in the same manner
as the \fIindex\fR argument to \fBstring index\fR.
.VE 8.5
When using this switch, `^'
will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR.  If \fB\-indices\fR
is specified, the indices will be indexed starting from the
absolute beginning of the input string.
\fIindex\fR will be constrained to the bounds of the input string.

.TP 15
\fB\-\|\-\fR
Marks the end of switches.  The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP
If there are more \fIsubMatchVar\fR's than parenthesized
subexpressions within \fIexp\fR, or if a particular subexpression
151
152
153
154
155
156
157
158




159
160
161
List all words (consisting of all sequences of non-whitespace
characters) in a string:
.CS
\fBregexp\fR \-all \-inline {\\S+} $string
.CE

.SH "SEE ALSO"
re_syntax(n), regsub(n)





.SH KEYWORDS
match, regular expression, string







|
>
>
>
>



154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
List all words (consisting of all sequences of non-whitespace
characters) in a string:
.CS
\fBregexp\fR \-all \-inline {\\S+} $string
.CE

.SH "SEE ALSO"
re_syntax(n), regsub(n),
.VS 8.5
string(n)
.VE


.SH KEYWORDS
match, regular expression, string

Changes to doc/registry.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2002 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: registry.n,v 1.12 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH registry n 1.1 registry "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2002 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: registry.n,v 1.12.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH registry n 1.1 registry "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
\fIrootname\fB\e\fIkeypath\fR
.IP
\fIrootname\fR
.PP
\fIHostname\fR specifies the name of any valid Windows
host that exports its registry.  The \fIrootname\fR component must be
one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR,
.VS
\fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR,
\fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or
\fBHKEY_DYN_DATA\fR.  The \fIkeypath\fR can be one or more
.VE
registry key names separated by backslash (\fB\e\fR) characters.
.PP
\fIOption\fR indicates what to do with the registry key name.  Any
unique abbreviation for \fIoption\fR is acceptable.  The valid options
are:
.VS 8.4
.TP
\fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR?
.
Sends a broadcast message to the system and running programs to notify them
of certain updates.  This is necessary to propagate changes to key registry
keys like Environment.  The timeout specifies the amount of time, in
milliseconds, to wait for applications to respond to the broadcast message.
It defaults to 3000.  The following example demonstrates how to add a path
to the global Environment and notify applications of the change without
requiring a logoff/logon step (assumes admin privileges):
.CS
set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment}
set curPath [registry get $regPath "Path"]
registry set $regPath "Path" "$curPath;$addPath"
registry broadcast "Environment"
.CE
.VE 8.4
.TP
\fBregistry delete \fIkeyName\fR ?\fIvalueName\fR?
.
If the optional \fIvalueName\fR argument is present, the specified
value under \fIkeyName\fR will be deleted from the registry.  If the
optional \fIvalueName\fR is omitted, the specified key and any subkeys
or values beneath it in the registry hierarchy will be deleted.  If







<



<





<
















<







36
37
38
39
40
41
42

43
44
45

46
47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
\fIrootname\fB\e\fIkeypath\fR
.IP
\fIrootname\fR
.PP
\fIHostname\fR specifies the name of any valid Windows
host that exports its registry.  The \fIrootname\fR component must be
one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR,

\fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR,
\fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or
\fBHKEY_DYN_DATA\fR.  The \fIkeypath\fR can be one or more

registry key names separated by backslash (\fB\e\fR) characters.
.PP
\fIOption\fR indicates what to do with the registry key name.  Any
unique abbreviation for \fIoption\fR is acceptable.  The valid options
are:

.TP
\fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR?
.
Sends a broadcast message to the system and running programs to notify them
of certain updates.  This is necessary to propagate changes to key registry
keys like Environment.  The timeout specifies the amount of time, in
milliseconds, to wait for applications to respond to the broadcast message.
It defaults to 3000.  The following example demonstrates how to add a path
to the global Environment and notify applications of the change without
requiring a logoff/logon step (assumes admin privileges):
.CS
set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment}
set curPath [registry get $regPath "Path"]
registry set $regPath "Path" "$curPath;$addPath"
registry broadcast "Environment"
.CE

.TP
\fBregistry delete \fIkeyName\fR ?\fIvalueName\fR?
.
If the optional \fIvalueName\fR argument is present, the specified
value under \fIkeyName\fR will be deleted from the registry.  If the
optional \fIvalueName\fR is omitted, the specified key and any subkeys
or values beneath it in the registry hierarchy will be deleted.  If

Changes to doc/regsub.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: regsub.n,v 1.12 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH regsub n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
regsub \- Perform substitutions based on regular expression pattern matching
.SH SYNOPSIS
.VS 8.4
\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec \fR?\fIvarName\fR?
.VE 8.4
.BE

.SH DESCRIPTION
.PP
This command matches the regular expression \fIexp\fR against
\fIstring\fR,
.VS 8.4
and either copies \fIstring\fR to the variable whose name is
given by \fIvarName\fR or returns \fIstring\fR if \fIvarName\fR is not
present.
.VE 8.4
(Regular expression matching is described in the \fBre_syntax\fR
reference page.)
If there is a match, then while copying \fIstring\fR to \fIvarName\fR
.VS 8.4
(or to the result of this command if \fIvarName\fR is not present)
.VE 8.4
the portion of \fIstring\fR that
matched \fIexp\fR is replaced with \fIsubSpec\fR.
If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced
in the substitution with the portion of \fIstring\fR that
matched \fIexp\fR.
If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit
between 1 and 9, then it is replaced in the substitution with








|








<

<






<



<



<

<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

18

19
20
21
22
23
24

25
26
27

28
29
30

31

32
33
34
35
36
37
38
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: regsub.n,v 1.12.2.2 2005/05/05 17:55:28 kennykb Exp $
'\" 
.so man.macros
.TH regsub n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
regsub \- Perform substitutions based on regular expression pattern matching
.SH SYNOPSIS

\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec \fR?\fIvarName\fR?

.BE

.SH DESCRIPTION
.PP
This command matches the regular expression \fIexp\fR against
\fIstring\fR,

and either copies \fIstring\fR to the variable whose name is
given by \fIvarName\fR or returns \fIstring\fR if \fIvarName\fR is not
present.

(Regular expression matching is described in the \fBre_syntax\fR
reference page.)
If there is a match, then while copying \fIstring\fR to \fIvarName\fR

(or to the result of this command if \fIvarName\fR is not present)

the portion of \fIstring\fR that
matched \fIexp\fR is replaced with \fIsubSpec\fR.
If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced
in the substitution with the portion of \fIstring\fR that
matched \fIexp\fR.
If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit
between 1 and 9, then it is replaced in the substitution with
94
95
96
97
98
99
100
101





102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
\fB\-nocase\fR
Upper-case characters in \fIstring\fR will be converted to lower-case
before matching against \fIexp\fR;  however, substitutions specified
by \fIsubSpec\fR use the original unconverted form of \fIstring\fR.
.TP 10
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
matching the regular expression at.  When using this switch, `^'





will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR.
\fIindex\fR will be constrained to the bounds of the input string.
.TP 10
\fB\-\|\-\fR
Marks the end of switches.  The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP
.VS 8.4
If \fIvarName\fR is supplied, the command returns a count of the
number of matching ranges that were found and replaced, otherwise the
string after replacement is returned.
.VE 8.4
See the manual entry for \fBregexp\fR for details on the interpretation
of regular expressions.
.SH EXAMPLES
Replace (in the string in variable \fIstring\fR) every instance of
\fBfoo\fR which is a word by itself with \fBbar\fR:
.CS
\fBregsub\fR -all {\e<foo\e>} $string bar string







|
>
>
>
>
>








<



<







88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108

109
110
111

112
113
114
115
116
117
118
\fB\-nocase\fR
Upper-case characters in \fIstring\fR will be converted to lower-case
before matching against \fIexp\fR;  however, substitutions specified
by \fIsubSpec\fR use the original unconverted form of \fIstring\fR.
.TP 10
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
matching the regular expression at.  
.VS 8.5
The \fIindex\fR value is interpreted in the same manner
as the \fIindex\fR argument to \fBstring index\fR.
.VE 8.5
When using this switch, `^'
will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR.
\fIindex\fR will be constrained to the bounds of the input string.
.TP 10
\fB\-\|\-\fR
Marks the end of switches.  The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP

If \fIvarName\fR is supplied, the command returns a count of the
number of matching ranges that were found and replaced, otherwise the
string after replacement is returned.

See the manual entry for \fBregexp\fR for details on the interpretation
of regular expressions.
.SH EXAMPLES
Replace (in the string in variable \fIstring\fR) every instance of
\fBfoo\fR which is a word by itself with \fBbar\fR:
.CS
\fBregsub\fR -all {\e<foo\e>} $string bar string
138
139
140
141
142
143
144
145




146
147
148

# Now we apply the substitution to get a subst-string that
# will perform the computational parts of the conversion.
set quoted [subst [\fBregsub\fR -all $RE $string $substitution]]
.CE

.SH "SEE ALSO"
regexp(n), re_syntax(n), subst(n)





.SH KEYWORDS
match, pattern, regular expression, substitute







|
>
>
>
>



135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

# Now we apply the substitution to get a subst-string that
# will perform the computational parts of the conversion.
set quoted [subst [\fBregsub\fR -all $RE $string $substitution]]
.CE

.SH "SEE ALSO"
regexp(n), re_syntax(n), subst(n),
.VS 8.5
string(n)
.VE


.SH KEYWORDS
match, pattern, regular expression, substitute

Changes to doc/scan.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: scan.n,v 1.12 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH scan n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
scan \- Parse string using conversion specifiers in the style of sscanf








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: scan.n,v 1.12.2.2 2005/10/08 13:44:37 dgp Exp $
'\" 
.so man.macros
.TH scan n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
scan \- Parse string using conversion specifiers in the style of sscanf
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
If the next character in \fIformat\fR is a blank or tab then it
matches any number of white space characters in \fIstring\fR (including
zero).
Otherwise, if it isn't a \fB%\fR character then it 
must match the next character of \fIstring\fR.
When a \fB%\fR is encountered in \fIformat\fR, it indicates
the start of a conversion specifier.
.VS 8.4
A conversion specifier contains up to four fields after the \fB%\fR:
a \fB*\fR, which indicates that the converted value is to be discarded 
instead of assigned to a variable; a XPG3 position specifier; a number
indicating a maximum field width; a field size modifier; and a
conversion character.
.VE 8.4
All of these fields are optional except for the conversion character.
The fields that are present must appear in the order given above.
.PP
When \fBscan\fR finds a conversion specifier in \fIformat\fR, it
first skips any white-space characters in \fIstring\fR (unless the
specifier is \fB[\fR or \fBc\fR).
Then it converts the next input characters according to the 







<





<







39
40
41
42
43
44
45

46
47
48
49
50

51
52
53
54
55
56
57
If the next character in \fIformat\fR is a blank or tab then it
matches any number of white space characters in \fIstring\fR (including
zero).
Otherwise, if it isn't a \fB%\fR character then it 
must match the next character of \fIstring\fR.
When a \fB%\fR is encountered in \fIformat\fR, it indicates
the start of a conversion specifier.

A conversion specifier contains up to four fields after the \fB%\fR:
a \fB*\fR, which indicates that the converted value is to be discarded 
instead of assigned to a variable; a XPG3 position specifier; a number
indicating a maximum field width; a field size modifier; and a
conversion character.

All of these fields are optional except for the conversion character.
The fields that are present must appear in the order given above.
.PP
When \fBscan\fR finds a conversion specifier in \fIformat\fR, it
first skips any white-space characters in \fIstring\fR (unless the
specifier is \fB[\fR or \fBc\fR).
Then it converts the next input characters according to the 
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
at most once and the empty positions will be filled in with empty strings.
.PP
The following conversion characters are supported:
.TP 10
\fBd\fR
The input field must be a decimal integer.
It is read in and the value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
.VE 8.4
.TP 10
\fBo\fR
The input field must be an octal integer. It is read in and the 
value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
If the value exceeds MAX_INT (017777777777 on platforms using 32-bit
integers when the \fBl\fR and \fBL\fR modifiers are not given), it
will be truncated to a signed integer.  Hence, 037777777777 will
appear as -1 on a 32-bit machine by default.
.VE 8.4
.TP 10
\fBx\fR
The input field must be a hexadecimal integer. It is read in 
and the value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
If the value exceeds MAX_INT (0x7FFFFFFF on platforms using 32-bit
integers when the \fBl\fR and \fBL\fR modifiers are not given), it
will be truncated to a signed integer.  Hence, 0xFFFFFFFF will appear
as -1 on a 32-bit machine.
.VE 8.4
.TP 10
\fBu\fR
The input field must be a decimal integer.  The value is stored in the
variable as an unsigned decimal integer string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
.VE 8.4
.TP 10
\fBi\fR 
The input field must be an integer.  The base (i.e. decimal, octal, or
hexadecimal) is determined in the same fashion as described in
\fBexpr\fR.  The value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
.VE 8.4
.TP 10
\fBc\fR
A single character is read in and its binary value is stored in 
the variable as a decimal string.
Initial white space is not skipped in this case, so the input
field may be a white-space character.
This conversion is different from the ANSI standard in that the







<



<




<







<




<







<




<



<





<



<







69
70
71
72
73
74
75

76
77
78

79
80
81
82

83
84
85
86
87
88
89

90
91
92
93

94
95
96
97
98
99
100

101
102
103
104

105
106
107

108
109
110
111
112

113
114
115

116
117
118
119
120
121
122
at most once and the empty positions will be filled in with empty strings.
.PP
The following conversion characters are supported:
.TP 10
\fBd\fR
The input field must be a decimal integer.
It is read in and the value is stored in the variable as a decimal string.

If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.

.TP 10
\fBo\fR
The input field must be an octal integer. It is read in and the 
value is stored in the variable as a decimal string.

If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
If the value exceeds MAX_INT (017777777777 on platforms using 32-bit
integers when the \fBl\fR and \fBL\fR modifiers are not given), it
will be truncated to a signed integer.  Hence, 037777777777 will
appear as -1 on a 32-bit machine by default.

.TP 10
\fBx\fR
The input field must be a hexadecimal integer. It is read in 
and the value is stored in the variable as a decimal string.

If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
If the value exceeds MAX_INT (0x7FFFFFFF on platforms using 32-bit
integers when the \fBl\fR and \fBL\fR modifiers are not given), it
will be truncated to a signed integer.  Hence, 0xFFFFFFFF will appear
as -1 on a 32-bit machine.

.TP 10
\fBu\fR
The input field must be a decimal integer.  The value is stored in the
variable as an unsigned decimal integer string.

If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.

.TP 10
\fBi\fR 
The input field must be an integer.  The base (i.e. decimal, octal, or
hexadecimal) is determined in the same fashion as described in
\fBexpr\fR.  The value is stored in the variable as a decimal string.

If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.

.TP 10
\fBc\fR
A single character is read in and its binary value is stored in 
the variable as a decimal string.
Initial white space is not skipped in this case, so the input
field may be a white-space character.
This conversion is different from the ANSI standard in that the
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
of an optional sign, a string of decimal digits possibly
containing a decimal point, and an optional exponent consisting 
of an \fBe\fR or \fBE\fR followed by an optional sign and a string of 
decimal digits.
It is read in and stored in the variable as a floating-point string.
.TP 10
\fB[\fIchars\fB]\fR
The input field consists of any number of characters in 
\fIchars\fR.
The matching string is stored in the variable.
If the first character between the brackets is a \fB]\fR then
it is treated as part of \fIchars\fR rather than the closing
bracket for the set.
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will match.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
.TP 10
\fB[^\fIchars\fB]\fR
The input field consists of any number of characters not in 
\fIchars\fR.
The matching string is stored in the variable.
If the character immediately following the \fB^\fR is a \fB]\fR then it is 
treated as part of the set rather than the closing bracket for 
the set.
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will be excluded







|
<











|
<







132
133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
148
149
150
151

152
153
154
155
156
157
158
of an optional sign, a string of decimal digits possibly
containing a decimal point, and an optional exponent consisting 
of an \fBe\fR or \fBE\fR followed by an optional sign and a string of 
decimal digits.
It is read in and stored in the variable as a floating-point string.
.TP 10
\fB[\fIchars\fB]\fR
The input field consists of one or more characters in \fIchars\fR.

The matching string is stored in the variable.
If the first character between the brackets is a \fB]\fR then
it is treated as part of \fIchars\fR rather than the closing
bracket for the set.
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will match.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
.TP 10
\fB[^\fIchars\fB]\fR
The input field consists of one or more characters not in \fIchars\fR.

The matching string is stored in the variable.
If the character immediately following the \fB^\fR is a \fB]\fR then it is 
treated as part of the set rather than the closing bracket for 
the set.
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will be excluded
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
\fB%p\fR conversion specifier is not currently supported.
.IP [2]
For \fB%c\fR conversions a single character value is
converted to a decimal string, which is then assigned to the
corresponding \fIvarName\fR;
no field width may be specified for this conversion.
.IP [3]
.VS 8.4
The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR
modifiers are ignored when converting real values (i.e. type
\fBdouble\fR is used for the internal representation).
.VE 8.4
.IP [4]
If the end of the input string is reached before any conversions have been
performed and no variables are given, an empty string is returned.
.SH EXAMPLES
Parse a simple color specification of the form \fI#RRGGBB\fR using
hexadecimal conversions with field sizes:
.CS







<



<







181
182
183
184
185
186
187

188
189
190

191
192
193
194
195
196
197
\fB%p\fR conversion specifier is not currently supported.
.IP [2]
For \fB%c\fR conversions a single character value is
converted to a decimal string, which is then assigned to the
corresponding \fIvarName\fR;
no field width may be specified for this conversion.
.IP [3]

The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR
modifiers are ignored when converting real values (i.e. type
\fBdouble\fR is used for the internal representation).

.IP [4]
If the end of the input string is reached before any conversions have been
performed and no variables are given, an empty string is returned.
.SH EXAMPLES
Parse a simple color specification of the form \fI#RRGGBB\fR using
hexadecimal conversions with field sizes:
.CS

Changes to doc/seek.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: seek.n,v 1.7 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH seek n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
seek \- Change the access position for an open channel
.SH SYNOPSIS
\fBseek \fIchannelId offset \fR?\fIorigin\fR?
.BE

.SH DESCRIPTION
.PP
Changes the current access position for \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.PP
The \fIoffset\fR and \fIorigin\fR
arguments specify the position at which the next read or write will occur
for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be
negative) and \fIorigin\fR must be one of the following:
.TP 10
\fBstart\fR







|















<




<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27

28
29
30
31
32
33
34
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: seek.n,v 1.7.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH seek n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
seek \- Change the access position for an open channel
.SH SYNOPSIS
\fBseek \fIchannelId offset \fR?\fIorigin\fR?
.BE

.SH DESCRIPTION
.PP
Changes the current access position for \fIchannelId\fR.
.PP

\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.

.PP
The \fIoffset\fR and \fIorigin\fR
arguments specify the position at which the next read or write will occur
for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be
negative) and \fIorigin\fR must be one of the following:
.TP 10
\fBstart\fR
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
The command flushes all buffered output for the channel before the command
returns, even if the channel is in nonblocking mode.
It also discards any buffered and unread input.
This command returns an empty string.
An error occurs if this command is applied to channels whose underlying
file or device does not support seeking.
.PP
.VS 8.1
Note that \fIoffset\fR values are byte offsets, not character
offsets.  Both \fBseek\fR and \fBtell\fR operate in terms of bytes,
not characters, unlike \fBread\fR.
.VE 8.1
.SH EXAMPLES
Read a file twice:
.CS
set f [open file.txt]
set data1 [read $f]
\fBseek\fR $f 0
set data2 [read $f]







<



<







51
52
53
54
55
56
57

58
59
60

61
62
63
64
65
66
67
The command flushes all buffered output for the channel before the command
returns, even if the channel is in nonblocking mode.
It also discards any buffered and unread input.
This command returns an empty string.
An error occurs if this command is applied to channels whose underlying
file or device does not support seeking.
.PP

Note that \fIoffset\fR values are byte offsets, not character
offsets.  Both \fBseek\fR and \fBtell\fR operate in terms of bytes,
not characters, unlike \fBread\fR.

.SH EXAMPLES
Read a file twice:
.CS
set f [open file.txt]
set data1 [read $f]
\fBseek\fR $f 0
set data2 [read $f]

Changes to doc/string.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: string.n,v 1.24 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH string n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
string \- Manipulate strings







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: string.n,v 1.24.2.4 2005/07/12 20:36:16 kennykb Exp $
'\" 
.so man.macros
.TH string n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
string \- Manipulate strings
68
69
70
71
72
73
74

75
76

77

78
79

80
81







82




83




84
85
86

87
88
89
90
91
92
93
94
95
96
97
98
will return \fB\-1\fR.
.RE
.TP
\fBstring index \fIstring charIndex\fR
Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument.
A \fIcharIndex\fR of 0 corresponds to the first character of the
string.  \fIcharIndex\fR may be specified as follows:

.RS
.IP \fIinteger\fR 10

The char specified at this integral index.

.IP \fBend\fR 10
The last char of the string.

.IP \fBend\-\fIinteger\fR 10
The last char of the string minus the specified integer offset







(e.g. \fBend\-1\fR would refer to the "c" in "abcd").




.PP




If \fIcharIndex\fR is less than 0 or greater than or equal to the
length of the string then an empty string is returned.
.RE

.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
Returns 1 if \fIstring\fR is a valid member of the specified character
class, otherwise returns 0.  If \fB\-strict\fR is specified, then an
empty string returns 0, otherwise and empty string will return 1 on
any class.  If \fB\-failindex\fR is specified, then if the function
returns 0, the index in the string where the class was no longer valid
will be stored in the variable named \fIvarname\fR.  The \fIvarname\fR
will not be set if the function returns 1.  The following character
classes are recognized (the class name can be abbreviated):
.RS
.IP \fBalnum\fR 12







>


>
|
>

|
>
|
|
>
>
>
>
>
>
>
|
>
>
>
>

>
>
>
>

|

>




|







68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
will return \fB\-1\fR.
.RE
.TP
\fBstring index \fIstring charIndex\fR
Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument.
A \fIcharIndex\fR of 0 corresponds to the first character of the
string.  \fIcharIndex\fR may be specified as follows:
.VS 8.5
.RS
.IP \fIinteger\fR 10
For any index value that passes \fBstring is integer -strict\fR,
the char specified at this integral index
(e.g. \fB2\fR would refer to the "c" in "abcd").
.IP \fBend\fR 10
The last char of the string
(e.g. \fBend\fR would refer to the "d" in "abcd").
.IP \fBend\fR\-\fIN\fR 10
The last char of the string minus the specified integer offset \fIN\fR
(e.g. \fBend\fR\-1 would refer to the "c" in "abcd").
.IP \fBend\fR+\fIN\fR 10
The last char of the string plus the specified integer offset \fIN\fR
(e.g. \fBend\fR+\-1 would refer to the "c" in "abcd").
.IP \fIM\fR+\fIN\fR 10
The char specified at the integral index that is the sum of 
integer values \fIM\fR and \fIN\fR
(e.g. \fB1+1\fR would refer to the "c" in "abcd").
.IP \fIM\fR\-\fIN\fR 10
The char specified at the integral index that is the difference of 
integer values \fIM\fR and \fIN\fR
(e.g. \fB2\-1\fR would refer to the "b" in "abcd").
.PP
In the specifications above, the integer value \fIM\fR contains no
trailing whitespace and the integer value \fIN\fR contains no
leading whitespace.
.PP
If \fIcharIndex\fR is less than 0 or greater than or equal to the
length of the string then this command returns an empty string.
.RE
.VE
.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
Returns 1 if \fIstring\fR is a valid member of the specified character
class, otherwise returns 0.  If \fB\-strict\fR is specified, then an
empty string returns 0, otherwise an empty string will return 1 on
any class.  If \fB\-failindex\fR is specified, then if the function
returns 0, the index in the string where the class was no longer valid
will be stored in the variable named \fIvarname\fR.  The \fIvarname\fR
will not be set if the function returns 1.  The following character
classes are recognized (the class name can be abbreviated):
.RS
.IP \fBalnum\fR 12
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
specified, it refers to the first char index in the string to start
modifying.  If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive).  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading or
trailing characters from the set given by \fIchars\fR are removed.  If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading
characters from the set given by \fIchars\fR are removed.  If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any trailing
characters from the set given by \fIchars\fR are removed.  If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR
may be specified as for the \fBindex\fR method.  A word is







|





|





|







302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
specified, it refers to the first char index in the string to start
modifying.  If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive).  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading or
trailing characters present in the string given by \fIchars\fR are removed.  If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading
characters present in the string given by \fIchars\fR are removed.  If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any trailing
characters present in the string given by \fIchars\fR are removed.  If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR
may be specified as for the \fBindex\fR method.  A word is
330
331
332
333
334
335
336




.CE

.SH "SEE ALSO"
expr(n), list(n)

.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype











>
>
>
>
350
351
352
353
354
355
356
357
358
359
360
.CE

.SH "SEE ALSO"
expr(n), list(n)

.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype

'\" Local Variables:
'\" mode: nroff
'\" End:

Changes to doc/subst.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: subst.n,v 1.6 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH subst n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
subst \- Perform backslash, command, and variable substitutions








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: subst.n,v 1.6.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH subst n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
subst \- Perform backslash, command, and variable substitutions
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or
\fB\-novariables\fR are specified, then the corresponding substitutions
are not performed.
For example, if \fB\-nocommands\fR is specified, command substitution
is not performed:  open and close brackets are treated as ordinary characters
with no special interpretation.
.PP
.VS 8.4
Note that the substitution of one kind can include substitution of 
other kinds.  For example, even when the \fB-novariables\fR option
is specified, command substitution is performed without restriction.
This means that any variable substitution necessary to complete the
command substitution will still take place.  Likewise, any command
substitution necessary to complete a variable substitution will
take place, even when \fB-nocommands\fR is specified.  See the







<







32
33
34
35
36
37
38

39
40
41
42
43
44
45
If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or
\fB\-novariables\fR are specified, then the corresponding substitutions
are not performed.
For example, if \fB\-nocommands\fR is specified, command substitution
is not performed:  open and close brackets are treated as ordinary characters
with no special interpretation.
.PP

Note that the substitution of one kind can include substitution of 
other kinds.  For example, even when the \fB-novariables\fR option
is specified, command substitution is performed without restriction.
This means that any variable substitution necessary to complete the
command substitution will still take place.  Likewise, any command
substitution necessary to complete a variable substitution will
take place, even when \fB-nocommands\fR is specified.  See the
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
will be substituted for that entire command or variable substitution
(as long as it is well-formed Tcl.)  If a return exception occurs,
or any other return code is returned during command or variable
substitution, then the returned value is substituted for that
substitution.  See the EXAMPLES below.  In this way, all exceptional
return codes are ``caught'' by \fBsubst\fR.  The \fBsubst\fR command
itself will either return an error, or will complete successfully.
.VE
.SH EXAMPLES
.PP
When it performs its substitutions, \fIsubst\fR does not give any
special treatment to double quotes or curly braces (except within
command substitutions) so the script
.CS
set a 44
\fBsubst\fR {xyz {$a}}
.CE
returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''
.VS 8.4
and the script
.CS
set a "p\\} q \\{r"
\fBsubst\fR {xyz {$a}}
.CE
return ``\fBxyz {p} q {r}\fR'', not ``\fBxyz {p\\} q \\{r}\fR''.
.PP







<










<







54
55
56
57
58
59
60

61
62
63
64
65
66
67
68
69
70

71
72
73
74
75
76
77
will be substituted for that entire command or variable substitution
(as long as it is well-formed Tcl.)  If a return exception occurs,
or any other return code is returned during command or variable
substitution, then the returned value is substituted for that
substitution.  See the EXAMPLES below.  In this way, all exceptional
return codes are ``caught'' by \fBsubst\fR.  The \fBsubst\fR command
itself will either return an error, or will complete successfully.

.SH EXAMPLES
.PP
When it performs its substitutions, \fIsubst\fR does not give any
special treatment to double quotes or curly braces (except within
command substitutions) so the script
.CS
set a 44
\fBsubst\fR {xyz {$a}}
.CE
returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''

and the script
.CS
set a "p\\} q \\{r"
\fBsubst\fR {xyz {$a}}
.CE
return ``\fBxyz {p} q {r}\fR'', not ``\fBxyz {p\\} q \\{r}\fR''.
.PP
112
113
114
115
116
117
118
119
120
121
122
123
124
125
\fBsubst\fR {abc,[return foo;expr 1+2],def}
.CE
returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and
.CS
\fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def}
.CE
also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''.
.VE

.SH "SEE ALSO"
Tcl(n), eval(n), break(n), continue(n)

.SH KEYWORDS
backslash substitution, command substitution, variable substitution







<






109
110
111
112
113
114
115

116
117
118
119
120
121
\fBsubst\fR {abc,[return foo;expr 1+2],def}
.CE
returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and
.CS
\fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def}
.CE
also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''.


.SH "SEE ALSO"
Tcl(n), eval(n), break(n), continue(n)

.SH KEYWORDS
backslash substitution, command substitution, variable substitution

Changes to doc/switch.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: switch.n,v 1.8 2004/10/27 14:24:37 dkf Exp $
'\" 
.so man.macros
.TH switch n 7.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
switch \- Evaluate one of several scripts, depending on a given value
.SH SYNOPSIS
\fBswitch \fR?\fIoptions\fR?\fI string pattern body \fR?\fIpattern body \fR...?
.sp







|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: switch.n,v 1.8.2.1 2005/07/12 20:36:16 kennykb Exp $
'\" 
.so man.macros
.TH switch n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
switch \- Evaluate one of several scripts, depending on a given value
.SH SYNOPSIS
\fBswitch \fR?\fIoptions\fR?\fI string pattern body \fR?\fIpattern body \fR...?
.sp
47
48
49
50
51
52
53



54
55
56
57
58
59
60
\fB\-regexp\fR
When matching \fIstring\fR to the patterns, use regular
expression matching
(as described in the \fBre_syntax\fR reference page).
'\" Options defined by TIP#75
.VS 8.5
.TP 10



\fB\-matchvar\fR \fIvarName\fR
This option (only legal when \fB\-regexp\fR is also specified)
specifies the name of a variable into which the list of matches
found by the regular expression engine will be written.  The first
element of the list written will be the overall substring of the input
string (i.e. the \fIstring\fR argument to \fBswitch\fR) matched, the
second element of the list will be the substring matched by the first







>
>
>







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
\fB\-regexp\fR
When matching \fIstring\fR to the patterns, use regular
expression matching
(as described in the \fBre_syntax\fR reference page).
'\" Options defined by TIP#75
.VS 8.5
.TP 10
\fB\-nocase\fR
Causes comparisons to be handled in a case-insensitive manner.
.TP 10
\fB\-matchvar\fR \fIvarName\fR
This option (only legal when \fB\-regexp\fR is also specified)
specifies the name of a variable into which the list of matches
found by the regular expression engine will be written.  The first
element of the list written will be the overall substring of the input
string (i.e. the \fIstring\fR argument to \fBswitch\fR) matched, the
second element of the list will be the substring matched by the first

Changes to doc/tclvars.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tclvars.n,v 1.20 2004/11/20 00:17:32 dgp Exp $
'\" 
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tclvars \- Variables used by Tcl







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tclvars.n,v 1.20.2.3 2005/10/08 13:44:37 dgp Exp $
'\" 
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tclvars \- Variables used by Tcl
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
environment variable.
Changes to the \fBenv\fR array will affect the environment
passed to children by commands like \fBexec\fR.
If the entire \fBenv\fR array is unset then Tcl will stop
monitoring \fBenv\fR accesses and will not update environment
variables.
.RS
.VS 8.0 
Under Windows, the environment variables PATH and COMSPEC in any
capitalization are converted automatically to upper case.  For instance, the
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases.  All other environment variables inherited by
Tcl are left unmodified.  Setting an env array variable to blank is the
same as unsetting it as this is the behavior of the underlying Windows OS.
It should be noted that relying on an existing and empty environment variable
won't work on windows and is discouraged for cross-platform usage.
.VE
.RE
.TP
\fBerrorCode\fR
This variable holds the value of the \fB-errorcode\fR return option
set by the most recent error that occurred in this interpreter.
This list value represents additional information about the error
in a form that is easy to process with programs.







<









<







33
34
35
36
37
38
39

40
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
environment variable.
Changes to the \fBenv\fR array will affect the environment
passed to children by commands like \fBexec\fR.
If the entire \fBenv\fR array is unset then Tcl will stop
monitoring \fBenv\fR accesses and will not update environment
variables.
.RS

Under Windows, the environment variables PATH and COMSPEC in any
capitalization are converted automatically to upper case.  For instance, the
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases.  All other environment variables inherited by
Tcl are left unmodified.  Setting an env array variable to blank is the
same as unsetting it as this is the behavior of the underlying Windows OS.
It should be noted that relying on an existing and empty environment variable
won't work on windows and is discouraged for cross-platform usage.

.RE
.TP
\fBerrorCode\fR
This variable holds the value of the \fB-errorcode\fR return option
set by the most recent error that occurred in this interpreter.
This list value represents additional information about the error
in a form that is easy to process with programs.
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
\fBtcl_patchLevel\fR
When an interpreter is created Tcl initializes this variable to
hold a string giving the current patch level for Tcl, such as
\fB7.3p2\fR for Tcl 7.3 with the first two official patches, or
\fB7.4b4\fR for the fourth beta release of Tcl 7.4.
The value of this variable is returned by the \fBinfo patchlevel\fR
command.
.VS 8.0 br
.TP
\fBtcl_pkgPath\fR
This variable holds a list of directories indicating where packages are
normally installed.  It is not used on Windows.  It typically contains
either one or two entries; if it contains two entries, the first is
normally a directory for platform-dependent packages (e.g., shared library
binaries) and the second is normally a directory for platform-independent
packages (e.g., script files). Typically a package is installed as a
subdirectory of one of the entries in \fB$tcl_pkgPath\fR. The directories
in \fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR
variable, so they and their immediate subdirectories are automatically
searched for packages during \fBpackage require\fR commands.  Note:
\fBtcl_pkgPath\fR it not intended to be modified by the application.  Its
value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR
are not reflected in \fBauto_path\fR.  If you want Tcl to search additional
directories for packages you should add the names of those directories to
\fBauto_path\fR, not \fBtcl_pkgPath\fR.
.VE
.TP
\fBtcl_platform\fR
This is an associative array whose elements contain information about
the platform on which the application is running, such as the name of
the operating system, its current release number, and the machine's
instruction set.  The elements listed below will always
be defined, but they may have empty strings as values if Tcl couldn't
retrieve any relevant information.  In addition, extensions
and applications may add additional values to the array.  The
predefined elements are:
.RS
.VS
.TP
\fBbyteOrder\fR
The native byte order of this machine: either \fBlittleEndian\fR or
\fBbigEndian\fR. 
.VE
.TP
\fBdebug\fR
If this variable exists, then the interpreter was compiled with and linked
to a debug-enabled C run-time.  This variable will only exist on Windows,
so extension writers can specify which package to load depending on the
C run-time library that is in use.  This is not an indication that this core
contains symbols.







<












|




<











<




<







157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180

181
182
183
184
185
186
187
188
189
190
191

192
193
194
195

196
197
198
199
200
201
202
\fBtcl_patchLevel\fR
When an interpreter is created Tcl initializes this variable to
hold a string giving the current patch level for Tcl, such as
\fB7.3p2\fR for Tcl 7.3 with the first two official patches, or
\fB7.4b4\fR for the fourth beta release of Tcl 7.4.
The value of this variable is returned by the \fBinfo patchlevel\fR
command.

.TP
\fBtcl_pkgPath\fR
This variable holds a list of directories indicating where packages are
normally installed.  It is not used on Windows.  It typically contains
either one or two entries; if it contains two entries, the first is
normally a directory for platform-dependent packages (e.g., shared library
binaries) and the second is normally a directory for platform-independent
packages (e.g., script files). Typically a package is installed as a
subdirectory of one of the entries in \fB$tcl_pkgPath\fR. The directories
in \fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR
variable, so they and their immediate subdirectories are automatically
searched for packages during \fBpackage require\fR commands.  Note:
\fBtcl_pkgPath\fR is not intended to be modified by the application.  Its
value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR
are not reflected in \fBauto_path\fR.  If you want Tcl to search additional
directories for packages you should add the names of those directories to
\fBauto_path\fR, not \fBtcl_pkgPath\fR.

.TP
\fBtcl_platform\fR
This is an associative array whose elements contain information about
the platform on which the application is running, such as the name of
the operating system, its current release number, and the machine's
instruction set.  The elements listed below will always
be defined, but they may have empty strings as values if Tcl couldn't
retrieve any relevant information.  In addition, extensions
and applications may add additional values to the array.  The
predefined elements are:
.RS

.TP
\fBbyteOrder\fR
The native byte order of this machine: either \fBlittleEndian\fR or
\fBbigEndian\fR. 

.TP
\fBdebug\fR
If this variable exists, then the interpreter was compiled with and linked
to a debug-enabled C run-time.  This variable will only exist on Windows,
so extension writers can specify which package to load depending on the
C run-time library that is in use.  This is not an indication that this core
contains symbols.
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253



254










255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
\fBuser\fR
This identifies the
current user based on the login information available on the platform.
This comes from the USER or LOGNAME environment variable on Unix,
and the value from GetUserName on Windows.
.TP
\fBwordSize\fR
.VS 8.4
This gives the size of the native-machine word in bytes (strictly, it
is same as the result of evaluating \fIsizeof(long)\fR in C.)
.VE 8.4
.RE
.TP
\fBtcl_precision\fR
.VS
This variable controls the number of digits to generate
when converting floating-point values to strings.  It defaults



to 12.










17 digits is ``perfect'' for IEEE floating-point in that it allows
double-precision values to be converted to strings and back to
binary with no loss of information.  However, using 17 digits prevents
any rounding, which produces longer, less intuitive results.  For example,
\fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR
set to 17, vs. 1.4 if \fBtcl_precision\fR is 12.
.RS
All interpreters in a process share a single \fBtcl_precision\fR value:
changing it in one interpreter will affect all other interpreters as
well.  However, safe interpreters are not allowed to modify the
variable.
.RE
.VE
.TP
\fBtcl_rcFileName\fR
This variable is used during initialization to indicate the name of a
user-specific startup file.  If it is set by application-specific
initialization, then the Tcl startup code will check for the existence
of this file and \fBsource\fR it if it exists.  For example, for \fBwish\fR
the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR







<


<



<


>
>
>
|
>
>
>
>
>
>
>
>
>
>












<







231
232
233
234
235
236
237

238
239

240
241
242

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

271
272
273
274
275
276
277
\fBuser\fR
This identifies the
current user based on the login information available on the platform.
This comes from the USER or LOGNAME environment variable on Unix,
and the value from GetUserName on Windows.
.TP
\fBwordSize\fR

This gives the size of the native-machine word in bytes (strictly, it
is same as the result of evaluating \fIsizeof(long)\fR in C.)

.RE
.TP
\fBtcl_precision\fR

This variable controls the number of digits to generate
when converting floating-point values to strings.  It defaults
.VS 8.5
to 0.  \fIApplications should not change this value;\fR it is
provided for compatibility with legacy code.
.PP
The default value of 0 is special, meaning that Tcl should
convert numbers using as few digits as possible while still
distinguishing any floating point number from its nearest
neighbours.  It differs from using an arbitrarily high value
for \fItcl_precision\fR in that an inexact number like \fI1.4\fR
will convert as \fI1.4\fR rather than \fI1.3999999999999999\fR
even though the latter is nearer to the exact value of the
binary number.
.VE 8.5
.PP
17 digits is ``perfect'' for IEEE floating-point in that it allows
double-precision values to be converted to strings and back to
binary with no loss of information.  However, using 17 digits prevents
any rounding, which produces longer, less intuitive results.  For example,
\fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR
set to 17, vs. 1.4 if \fBtcl_precision\fR is 12.
.RS
All interpreters in a process share a single \fBtcl_precision\fR value:
changing it in one interpreter will affect all other interpreters as
well.  However, safe interpreters are not allowed to modify the
variable.
.RE

.TP
\fBtcl_rcFileName\fR
This variable is used during initialization to indicate the name of a
user-specific startup file.  If it is set by application-specific
initialization, then the Tcl startup code will check for the existence
of this file and \fBsource\fR it if it exists.  For example, for \fBwish\fR
the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR

Changes to doc/tell.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tell.n,v 1.7 2004/10/27 14:43:54 dkf Exp $
'\" 
.so man.macros
.TH tell n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tell \- Return current access position for an open channel
.SH SYNOPSIS
\fBtell \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP
.VS 8.1
Returns an integer string giving the current access position in
\fIchannelId\fR.  This value returned is a byte offset that can be passed to
\fBseek\fR in order to set the channel to a particular position.  Note
that this value is in terms of bytes, not characters like \fBread\fR.
.VE 8.1
The value returned is -1 for channels that do not support
seeking.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.SH EXAMPLE
Read a line from a file channel only if it starts with \fBfoobar\fR:
.CS
# Save the offset in case we need to undo the read...
set offset [\fBtell\fR $chan]
if {[read $chan 6] eq "foobar"} {
    gets $chan line







|













<




<



<




<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25

26
27
28

29
30
31
32

33
34
35
36
37
38
39
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tell.n,v 1.7.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH tell n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tell \- Return current access position for an open channel
.SH SYNOPSIS
\fBtell \fIchannelId\fR
.BE

.SH DESCRIPTION
.PP

Returns an integer string giving the current access position in
\fIchannelId\fR.  This value returned is a byte offset that can be passed to
\fBseek\fR in order to set the channel to a particular position.  Note
that this value is in terms of bytes, not characters like \fBread\fR.

The value returned is -1 for channels that do not support
seeking.
.PP

\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.

.SH EXAMPLE
Read a line from a file channel only if it starts with \fBfoobar\fR:
.CS
# Save the offset in case we need to undo the read...
set offset [\fBtell\fR $chan]
if {[read $chan 6] eq "foobar"} {
    gets $chan line

Changes to doc/unload.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2003 George Petasis, [email protected].
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: unload.n,v 1.6 2004/09/18 17:01:06 dkf Exp $
'\" 
.so man.macros
.TH unload n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
unload \- Unload machine code






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2003 George Petasis, [email protected].
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: unload.n,v 1.6.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH unload n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
unload \- Unload machine code
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
.PP
If \fIpackageName\fR is omitted or specified as an empty string,
Tcl tries to guess the name of the package.
This may be done differently on different platforms.
The default guess, which is used on most UNIX platforms, is to
take the last element of \fIfileName\fR, strip off the first
three characters if they are \fBlib\fR, and use any following
.VS
alphabetic and underline characters as the module name.
.VE
For example, the command \fBunload libxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBunload bin/last.so {}\fR uses the
module name \fBlast\fR.
.SH "PORTABILITY ISSUES"
.TP
\fBUnix\fR\0\0\0\0\0
.







<

<







112
113
114
115
116
117
118

119

120
121
122
123
124
125
126
.PP
If \fIpackageName\fR is omitted or specified as an empty string,
Tcl tries to guess the name of the package.
This may be done differently on different platforms.
The default guess, which is used on most UNIX platforms, is to
take the last element of \fIfileName\fR, strip off the first
three characters if they are \fBlib\fR, and use any following

alphabetic and underline characters as the module name.

For example, the command \fBunload libxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBunload bin/last.so {}\fR uses the
module name \fBlast\fR.
.SH "PORTABILITY ISSUES"
.TP
\fBUnix\fR\0\0\0\0\0
.

Changes to doc/unset.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: unset.n,v 1.8 2004/10/27 14:43:54 dkf Exp $
'\" 
.so man.macros
.TH unset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
unset \- Delete variables








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: unset.n,v 1.8.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH unset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
unset \- Delete variables
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Each \fIname\fR is a variable name, specified in any of the
ways acceptable to the \fBset\fR command.
If a \fIname\fR refers to an element of an array then that
element is removed without affecting the rest of the array.
If a \fIname\fR consists of an array name with no parenthesized
index, then the entire array is deleted.
The \fBunset\fR command returns an empty string as result.
.VS 8.4
If \fI\-nocomplain\fR is specified as the first argument, any possible
errors are suppressed.  The option may not be abbreviated, in order to
disambiguate it from possible variable names.  The option \fI\-\-\fR
indicates the end of the options, and should be used if you wish to
remove a variable with the same name as any of the options.
.VE 8.4
If an error occurs, any variables after the named one causing the error not
deleted.  An error can occur when the named variable doesn't exist, or the
name refers to an array element but the variable is a scalar, or the name
refers to a variable in a non-existent namespace.
.SH EXAMPLE
Create an array containing a mapping from some numbers to their
squares and remove the array elements for non-prime numbers:







<





<







24
25
26
27
28
29
30

31
32
33
34
35

36
37
38
39
40
41
42
Each \fIname\fR is a variable name, specified in any of the
ways acceptable to the \fBset\fR command.
If a \fIname\fR refers to an element of an array then that
element is removed without affecting the rest of the array.
If a \fIname\fR consists of an array name with no parenthesized
index, then the entire array is deleted.
The \fBunset\fR command returns an empty string as result.

If \fI\-nocomplain\fR is specified as the first argument, any possible
errors are suppressed.  The option may not be abbreviated, in order to
disambiguate it from possible variable names.  The option \fI\-\-\fR
indicates the end of the options, and should be used if you wish to
remove a variable with the same name as any of the options.

If an error occurs, any variables after the named one causing the error not
deleted.  An error can occur when the named variable doesn't exist, or the
name refers to an array element but the variable is a scalar, or the name
refers to a variable in a non-existent namespace.
.SH EXAMPLE
Create an array containing a mapping from some numbers to their
squares and remove the array elements for non-prime numbers:

Changes to doc/upvar.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: upvar.n,v 1.10 2004/11/12 11:03:16 dkf Exp $
'\" 
.so man.macros
.TH upvar n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
upvar \- Create link to variable in a different stack frame







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: upvar.n,v 1.10.2.1 2005/04/10 23:14:44 kennykb Exp $
'\" 
.so man.macros
.TH upvar n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
upvar \- Create link to variable in a different stack frame
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
For example, \fBinfo level 1\fR will return a list
describing a command that is either
the outermost procedure call or the outermost \fBnamespace eval\fR command.
Also, \fBuplevel #0\fR evaluates a script
at top-level in the outermost namespace (the global namespace).
.PP
.VS
If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the
\fBunset\fR operation affects the variable it is linked to, not the
upvar variable.  There is no way to unset an upvar variable except
by exiting the procedure in which it is defined.  However, it is
possible to retarget an upvar variable by executing another \fBupvar\fR
command.
.SH "TRACES AND UPVAR"







<







64
65
66
67
68
69
70

71
72
73
74
75
76
77
counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
For example, \fBinfo level 1\fR will return a list
describing a command that is either
the outermost procedure call or the outermost \fBnamespace eval\fR command.
Also, \fBuplevel #0\fR evaluates a script
at top-level in the outermost namespace (the global namespace).
.PP

If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the
\fBunset\fR operation affects the variable it is linked to, not the
upvar variable.  There is no way to unset an upvar variable except
by exiting the procedure in which it is defined.  However, it is
possible to retarget an upvar variable by executing another \fBupvar\fR
command.
.SH "TRACES AND UPVAR"
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
.CE
.PP
If \fIotherVar\fR refers to an element of an array, then variable
traces set for the entire array will not be invoked when \fImyVar\fR
is accessed (but traces on the particular element will still be
invoked).  In particular, if the array is \fBenv\fR, then changes
made to \fImyVar\fR will not be passed to subprocesses correctly.
.VE
.SH EXAMPLE
A \fBdecr\fR command that works like \fBincr\fR except it subtracts
the value from the variable instead of adding it:
.CS
proc decr {varName {decrement 1}} {
    \fBupvar\fR 1 $varName var
    incr var [expr {-$decrement}]







<







96
97
98
99
100
101
102

103
104
105
106
107
108
109
.CE
.PP
If \fIotherVar\fR refers to an element of an array, then variable
traces set for the entire array will not be invoked when \fImyVar\fR
is accessed (but traces on the particular element will still be
invoked).  In particular, if the array is \fBenv\fR, then changes
made to \fImyVar\fR will not be passed to subprocesses correctly.

.SH EXAMPLE
A \fBdecr\fR command that works like \fBincr\fR except it subtracts
the value from the variable instead of adding it:
.CS
proc decr {varName {decrement 1}} {
    \fBupvar\fR 1 $varName var
    incr var [expr {-$decrement}]

Changes to doc/variable.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: variable.n,v 1.6 2004/10/27 14:43:54 dkf Exp $
'\" 
.so man.macros
.TH variable n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
variable \- create and initialize a namespace variable







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: variable.n,v 1.6.2.1 2005/03/02 21:25:20 kennykb Exp $
'\" 
.so man.macros
.TH variable n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
variable \- create and initialize a namespace variable
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
the variable is created in the specified namespace.  If the variable
is not defined, it will be visible to the \fBnamespace which\fR
command, but not to the \fBinfo exists\fR command.
.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo locals\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
it is created and optionally initialized.







|







39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
the variable is created in the specified namespace.  If the variable
is not defined, it will be visible to the \fBnamespace which\fR
command, but not to the \fBinfo exists\fR command.
.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
it is created and optionally initialized.

Changes to generic/tcl.decls.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# tcl.decls --
#
#	This file contains the declarations for all supported public
#	functions that are exported by the Tcl library via the stubs table.
#	This file is used to generate the tclDecls.h, tclPlatDecls.h,
#	tclStub.c, and tclPlatStub.c files.
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tcl.decls,v 1.105 2004/11/13 00:19:05 dgp Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# tcl.decls --
#
#	This file contains the declarations for all supported public
#	functions that are exported by the Tcl library via the stubs table.
#	This file is used to generate the tclDecls.h, tclPlatDecls.h,
#	tclStub.c, and tclPlatStub.c files.
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tcl.decls,v 1.105.2.9 2005/09/20 14:11:51 dgp Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
declare 29 generic {
    Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
declare 30 generic {
    void TclFreeObj(Tcl_Obj *objPtr)
}
declare 31 generic {
    int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *str, int *boolPtr)
}
declare 32 generic {
    int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    int *boolPtr)
}
declare 33 generic {
    unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 generic {
    int Tcl_GetDouble(Tcl_Interp *interp, CONST char *str, double *doublePtr)
}
declare 35 generic {
    int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    double *doublePtr)
}
declare 36 generic {
    int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr)
}
declare 37 generic {
    int Tcl_GetInt(Tcl_Interp *interp, CONST char *str, int *intPtr)
}
declare 38 generic {
    int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 generic {
    int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}







|









|










|







132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
declare 29 generic {
    Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
declare 30 generic {
    void TclFreeObj(Tcl_Obj *objPtr)
}
declare 31 generic {
    int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src, int *boolPtr)
}
declare 32 generic {
    int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    int *boolPtr)
}
declare 33 generic {
    unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 generic {
    int Tcl_GetDouble(Tcl_Interp *interp, CONST char *src, double *doublePtr)
}
declare 35 generic {
    int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    double *doublePtr)
}
declare 36 generic {
    int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr)
}
declare 37 generic {
    int Tcl_GetInt(Tcl_Interp *interp, CONST char *src, int *intPtr)
}
declare 38 generic {
    int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 generic {
    int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
    void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message,
	    int length)
}
declare 68 generic {
    void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 generic {
    void Tcl_AppendElement(Tcl_Interp *interp, CONST char *string)
}
declare 70 generic {
    void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
declare 71 generic {
    Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
	    ClientData clientData)







|







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
    void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message,
	    int length)
}
declare 68 generic {
    void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 generic {
    void Tcl_AppendElement(Tcl_Interp *interp, CONST char *element)
}
declare 70 generic {
    void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
declare 71 generic {
    Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
	    ClientData clientData)
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
declare 115 generic {
    int Tcl_DoOneEvent(int flags)
}
declare 116 generic {
    void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
}
declare 117 generic {
    char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, int length)
}
declare 118 generic {
    char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *string)
}
declare 119 generic {
    void Tcl_DStringEndSublist(Tcl_DString *dsPtr)
}
declare 120 generic {
    void Tcl_DStringFree(Tcl_DString *dsPtr)
}







|


|







427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
declare 115 generic {
    int Tcl_DoOneEvent(int flags)
}
declare 116 generic {
    void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
}
declare 117 generic {
    char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *bytes, int length)
}
declare 118 generic {
    char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *element)
}
declare 119 generic {
    void Tcl_DStringEndSublist(Tcl_DString *dsPtr)
}
declare 120 generic {
    void Tcl_DStringFree(Tcl_DString *dsPtr)
}
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
declare 127 generic {
    CONST84_RETURN char * Tcl_ErrnoId(void)
}
declare 128 generic {
    CONST84_RETURN char * Tcl_ErrnoMsg(int err)
}
declare 129 generic {
    int Tcl_Eval(Tcl_Interp *interp, CONST char *string)
}
# This is obsolete, use Tcl_FSEvalFile
declare 130 generic {
    int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
}
declare 131 generic {
    int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 generic {
    void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
}
declare 133 generic {
    void Tcl_Exit(int status)
}
declare 134 generic {
    int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken,
	    CONST char *cmdName)
}
declare 135 generic {
    int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *str, int *ptr)
}
declare 136 generic {
    int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
declare 137 generic {
    int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *str, double *ptr)
}
declare 138 generic {
    int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
declare 139 generic {
    int Tcl_ExprLong(Tcl_Interp *interp, CONST char *str, long *ptr)
}
declare 140 generic {
    int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
}
declare 141 generic {
    int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    Tcl_Obj **resultPtrPtr)
}
declare 142 generic {
    int Tcl_ExprString(Tcl_Interp *interp, CONST char *string)
}
declare 143 generic {
    void Tcl_Finalize(void)
}
declare 144 generic {
    void Tcl_FindExecutable(CONST char *argv0)
}







|



















|





|





|









|







463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
declare 127 generic {
    CONST84_RETURN char * Tcl_ErrnoId(void)
}
declare 128 generic {
    CONST84_RETURN char * Tcl_ErrnoMsg(int err)
}
declare 129 generic {
    int Tcl_Eval(Tcl_Interp *interp, CONST char *script)
}
# This is obsolete, use Tcl_FSEvalFile
declare 130 generic {
    int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
}
declare 131 generic {
    int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 generic {
    void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
}
declare 133 generic {
    void Tcl_Exit(int status)
}
declare 134 generic {
    int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken,
	    CONST char *cmdName)
}
declare 135 generic {
    int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *expr, int *ptr)
}
declare 136 generic {
    int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
declare 137 generic {
    int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *expr, double *ptr)
}
declare 138 generic {
    int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
declare 139 generic {
    int Tcl_ExprLong(Tcl_Interp *interp, CONST char *expr, long *ptr)
}
declare 140 generic {
    int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
}
declare 141 generic {
    int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    Tcl_Obj **resultPtrPtr)
}
declare 142 generic {
    int Tcl_ExprString(Tcl_Interp *interp, CONST char *expr)
}
declare 143 generic {
    void Tcl_Finalize(void)
}
declare 144 generic {
    void Tcl_FindExecutable(CONST char *argv0)
}
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
    Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp)
}

# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we inlcude it here for compatibility reasons.

declare 167 unix {
    int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *str, int forWriting,
	    int checkUsage, ClientData *filePtr)
}
# Obsolete.  Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
declare 168 generic {
    Tcl_PathType Tcl_GetPathType(CONST char *path)
}







|







595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
    Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp)
}

# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we inlcude it here for compatibility reasons.

declare 167 unix {
    int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *chanID, int forWriting,
	    int checkUsage, ClientData *filePtr)
}
# Obsolete.  Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
declare 168 generic {
    Tcl_PathType Tcl_GetPathType(CONST char *path)
}
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
declare 201 generic {
    void Tcl_Preserve(ClientData data)
}
declare 202 generic {
    void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 generic {
    int Tcl_PutEnv(CONST char *string)
}
declare 204 generic {
    CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 generic {
    void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}







|







723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
declare 201 generic {
    void Tcl_Preserve(ClientData data)
}
declare 202 generic {
    void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 generic {
    int Tcl_PutEnv(CONST char *assignment)
}
declare 204 generic {
    CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 generic {
    void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
declare 210 generic {
    void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 211 generic {
    void Tcl_RegisterObjType(Tcl_ObjType *typePtr)
}
declare 212 generic {
    Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *string)
}
declare 213 generic {
    int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
	    CONST char *str, CONST char *start)
}
declare 214 generic {
    int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *str,
	    CONST char *pattern)
}
declare 215 generic {
    void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
	    CONST84 char **startPtr, CONST84 char **endPtr)
}
declare 216 generic {







|



|


|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
declare 210 generic {
    void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 211 generic {
    void Tcl_RegisterObjType(Tcl_ObjType *typePtr)
}
declare 212 generic {
    Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *pattern)
}
declare 213 generic {
    int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
	    CONST char *text, CONST char *start)
}
declare 214 generic {
    int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *text,
	    CONST char *pattern)
}
declare 215 generic {
    void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
	    CONST84 char **startPtr, CONST84 char **endPtr)
}
declare 216 generic {
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
declare 230 generic {
    void Tcl_SetPanicProc(Tcl_PanicProc *panicProc)
}
declare 231 generic {
    int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
declare 232 generic {
    void Tcl_SetResult(Tcl_Interp *interp, char *str,
	    Tcl_FreeProc *freeProc)
}
declare 233 generic {
    int Tcl_SetServiceMode(int mode)
}
declare 234 generic {
    void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)







|







817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
declare 230 generic {
    void Tcl_SetPanicProc(Tcl_PanicProc *panicProc)
}
declare 231 generic {
    int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
declare 232 generic {
    void Tcl_SetResult(Tcl_Interp *interp, char *result,
	    Tcl_FreeProc *freeProc)
}
declare 233 generic {
    int Tcl_SetServiceMode(int mode)
}
declare 234 generic {
    void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
declare 268 generic {
    void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
    CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
    CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *str,
	    CONST84 char **termPtr)
}
declare 271 generic {
    CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact)
}
declare 272 generic {







|







952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
declare 268 generic {
    void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
    CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
    CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *start,
	    CONST84 char **termPtr)
}
declare 271 generic {
    CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact)
}
declare 272 generic {
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
    void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
declare 311 generic {
    void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
	    Tcl_Time *timePtr)
}
declare 312 generic {
    int Tcl_NumUtfChars(CONST char *src, int len)
}
declare 313 generic {
    int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead,
	    int appendFlag)
}
declare 314 generic {
    void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)







|







1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
    void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
declare 311 generic {
    void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
	    Tcl_Time *timePtr)
}
declare 312 generic {
    int Tcl_NumUtfChars(CONST char *src, int length)
}
declare 313 generic {
    int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead,
	    int appendFlag)
}
declare 314 generic {
    void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
declare 324 generic {
    int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
    CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index)
}
declare 326 generic {
    int Tcl_UtfCharComplete(CONST char *src, int len)
}
declare 327 generic {
    int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
}
declare 328 generic {
    CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch)
}







|







1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
declare 324 generic {
    int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
    CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index)
}
declare 326 generic {
    int Tcl_UtfCharComplete(CONST char *src, int length)
}
declare 327 generic {
    int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
}
declare 328 generic {
    CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch)
}
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
declare 350 generic {
    int Tcl_UniCharIsUpper(int ch)
}
declare 351 generic {
    int Tcl_UniCharIsWordChar(int ch)
}
declare 352 generic {
    int Tcl_UniCharLen(CONST Tcl_UniChar *str)
}
declare 353 generic {
    int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,
	    unsigned long n)
}
declare 354 generic {
    char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string,
	    int numChars, Tcl_DString *dsPtr)
}
declare 355 generic {
    Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string,
	    int length, Tcl_DString *dsPtr)
}
declare 356 generic {
    Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
	    int flags)
}

declare 357 generic {
    Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
	    int count)
}
declare 358 generic {
    void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 generic {
    void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
	    CONST char *command, int length)
}
declare 360 generic {
    int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *string, int numBytes,
	    Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
declare 361 generic {
    int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *string, int numBytes,
	    int nested, Tcl_Parse *parsePtr)
}
declare 362 generic {
    int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *string, int numBytes,
	    Tcl_Parse *parsePtr)	 
}
declare 363 generic {
    int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *string,
	    int numBytes, Tcl_Parse *parsePtr, int append,
	    CONST84 char **termPtr)
}
declare 364 generic {
    int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *string, int numBytes,
	    Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 generic {
    char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}







|


|
|


|
|


|



















|



|



|



|




|







1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
declare 350 generic {
    int Tcl_UniCharIsUpper(int ch)
}
declare 351 generic {
    int Tcl_UniCharIsWordChar(int ch)
}
declare 352 generic {
    int Tcl_UniCharLen(CONST Tcl_UniChar *uniStr)
}
declare 353 generic {
    int Tcl_UniCharNcmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct,
	    unsigned long numChars)
}
declare 354 generic {
    char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *uniStr,
	    int uniLength, Tcl_DString *dsPtr)
}
declare 355 generic {
    Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *src,
	    int length, Tcl_DString *dsPtr)
}
declare 356 generic {
    Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
	    int flags)
}

declare 357 generic {
    Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
	    int count)
}
declare 358 generic {
    void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 generic {
    void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
	    CONST char *command, int length)
}
declare 360 generic {
    int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *start, int numBytes,
	    Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
declare 361 generic {
    int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *start, int numBytes,
	    int nested, Tcl_Parse *parsePtr)
}
declare 362 generic {
    int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *start, int numBytes,
	    Tcl_Parse *parsePtr)	 
}
declare 363 generic {
    int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *start,
	    int numBytes, Tcl_Parse *parsePtr, int append,
	    CONST84 char **termPtr)
}
declare 364 generic {
    int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *start, int numBytes,
	    Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 generic {
    char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
    int Tcl_UniCharIsPrint(int ch)
}
declare 375 generic {
    int Tcl_UniCharIsPunct(int ch)
}
declare 376 generic {
    int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
	    Tcl_Obj *objPtr, int offset, int nmatches, int flags)
}
declare 377 generic {
    void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 generic {
    Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, int numChars)
}







|







1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
    int Tcl_UniCharIsPrint(int ch)
}
declare 375 generic {
    int Tcl_UniCharIsPunct(int ch)
}
declare 376 generic {
    int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
	    Tcl_Obj *textObj, int offset, int nmatches, int flags)
}
declare 377 generic {
    void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 generic {
    Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, int numChars)
}
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
    Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
declare 384 generic {
    void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
	    int length)
}
declare 385 generic {
    int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj,
	    Tcl_Obj *patternObj)
}
declare 386 generic {
    void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 generic {
    Tcl_Mutex * Tcl_GetAllocMutex(void)







|







1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
    Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
declare 384 generic {
    void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
	    int length)
}
declare 385 generic {
    int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
	    Tcl_Obj *patternObj)
}
declare 386 generic {
    void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 generic {
    Tcl_Mutex * Tcl_GetAllocMutex(void)
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
    void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 generic {
    int Tcl_IsChannelExisting(CONST char* channelName)
}

declare 419 generic {
    int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,
	    unsigned long n)
}
declare 420 generic {
    int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr,
	    CONST Tcl_UniChar *pattern, int nocase)
}

declare 421 generic {
    Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key)
}

declare 422 generic {







|
|


|
|







1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
    void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 generic {
    int Tcl_IsChannelExisting(CONST char* channelName)
}

declare 419 generic {
    int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct,
	    unsigned long numChars)
}
declare 420 generic {
    int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *uniStr,
	    CONST Tcl_UniChar *uniPattern, int nocase)
}

declare 421 generic {
    Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key)
}

declare 422 generic {
1922
1923
1924
1925
1926
1927
1928








































































































1929
1930
1931
1932
1933
1934
1935
# TIP#227 API
declare 538 generic {
    int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options)
}
declare 539 generic {
    Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result)
}









































































































##############################################################################

# Define the platform specific public Tcl interface.  These functions are
# only available on the designated platform.

interface tclPlat







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
# TIP#227 API
declare 538 generic {
    int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options)
}
declare 539 generic {
    Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result)
}
# TIP#235
declare 540 generic {
    int Tcl_IsEnsemble(Tcl_Command token)
}
declare 541 generic {
    Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp, CONST char *name,
	    Tcl_Namespace *namespacePtr, int flags)
}
declare 542 generic {
    Tcl_Command Tcl_FindEnsemble(Tcl_Interp *interp, Tcl_Obj *cmdNameObj,
	    int flags)
}
declare 543 generic {
    int Tcl_SetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Obj *subcmdList)
}
declare 544 generic {
    int Tcl_SetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Obj *mapDict)
}
declare 545 generic {
    int Tcl_SetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Obj *unknownList)
}
declare 546 generic {
    int Tcl_SetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int flags)
}
declare 547 generic {
    int Tcl_GetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Obj **subcmdListPtr)
}
declare 548 generic {
    int Tcl_GetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Obj **mapDictPtr)
}
declare 549 generic {
    int Tcl_GetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Obj **unknownListPtr)
}
declare 550 generic {
    int Tcl_GetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token,
	    int *flagsPtr)
}
declare 551 generic {
    int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token,
	    Tcl_Namespace **namespacePtrPtr)
}
# TIP#233 (Virtualized Time)
declare 552 generic {
    void Tcl_SetTimeProc (Tcl_GetTimeProc* getProc,
	    Tcl_ScaleTimeProc* scaleProc,
	    ClientData clientData)
}
declare 553 generic {
    void Tcl_QueryTimeProc (Tcl_GetTimeProc** getProc,
	    Tcl_ScaleTimeProc** scaleProc,
	    ClientData* clientData)
}
# TIP#218 (Driver Thread Actions) davygrvy/akupries ChannelType ver 4
declare 554 generic {
    Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr)
}

# TIP #237:

declare 555 generic {
    Tcl_Obj* Tcl_NewBignumObj( mp_int* value )
}
declare 556 generic {
    Tcl_Obj* Tcl_DbNewBignumObj( mp_int* value, CONST char* file, int line )
}
declare 557 generic {
    void Tcl_SetBignumObj( Tcl_Obj* obj, mp_int* value )
}
declare 558 generic {
    int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
}
declare 559 generic {
    int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
}

# TIP #208:
declare 560 generic {
    int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
declare 561 generic {
    Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
	    Tcl_ChannelType *chanTypePtr)
}

# TIP#219 (Tcl Channel Reflection API) akupries

declare 562 generic {
    void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg)
}
declare 563 generic {
    void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg)
}
declare 564 generic {
    void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg)
}
declare 565 generic {
    void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg)
}

##############################################################################

# Define the platform specific public Tcl interface.  These functions are
# only available on the designated platform.

interface tclPlat

Changes to generic/tcl.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21








22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84
85
86

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

141
142
143
144

145
146
147
148
149
150


151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200

201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

217
218
219
220
221
222
223
/*
 * tcl.h --
 *
 *	This header file describes the externally-visible facilities
 *	of the Tcl interpreter.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1993-1996 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191 2004/11/17 17:53:01 dgp Exp $
 */

#ifndef _TCL
#define _TCL









/*
 * The following defines are used to indicate the various release levels.
 */

#define TCL_ALPHA_RELEASE	0
#define TCL_BETA_RELEASE	1
#define TCL_FINAL_RELEASE	2

/*
 * When version numbers change here, must also go into the following files
 * and update the version numbers:
 *
 * library/init.tcl	(only if Major.minor changes, not patchlevel) 1 LOC
 * unix/configure.in	(2 LOC Major, 2 LOC minor, 1 LOC patch)
 * win/configure.in	(as above)
 * win/tcl.m4		(not patchlevel)
 * win/makefile.bc	(not patchlevel) 2 LOC
 * README		(sections 0 and 2, with and without separator)
 * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 2 LOC
 * win/README.binary	(sections 0-4, with and without separator)
 * win/README		(not patchlevel) (sections 0 and 2)
 * unix/tcl.spec	(2 LOC Major/Minor, 1 LOC patch)
 * tests/basic.test	(1 LOC M/M, not patchlevel)
 * tools/tcl.hpj.in	(not patchlevel, for windows installer)
 * tools/tcl.wse.in	(for windows installer)
 * tools/tclSplash.bmp	(not patchlevel)
 */

#define TCL_MAJOR_VERSION   8
#define TCL_MINOR_VERSION   5
#define TCL_RELEASE_LEVEL   TCL_ALPHA_RELEASE
#define TCL_RELEASE_SERIAL  2

#define TCL_VERSION	    "8.5"
#define TCL_PATCH_LEVEL	    "8.5a2"

/*
 * The following definitions set up the proper options for Windows
 * compilers.  We use this method because there is no autoconf equivalent.
 */

#ifndef __WIN32__
#   if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__))
#	define __WIN32__
#	ifndef WIN32
#	    define WIN32
#	endif
#	ifndef _WIN32
#	    define _WIN32
#	endif
#   endif
#endif

/*
 * STRICT: See MSDN Article Q83456
 */

#ifdef __WIN32__
#   ifndef STRICT
#	define STRICT
#   endif
#endif /* __WIN32__ */

/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */

#ifndef STRINGIFY
#  define STRINGIFY(x) STRINGIFY1(x)
#  define STRINGIFY1(x) #x
#endif
#ifndef JOIN
#  define JOIN(a,b) JOIN1(a,b)
#  define JOIN1(a,b) a##b
#endif

/* 
 * A special definition used to allow this header file to be included
 * from windows resource files so that they can obtain version
 * information.  RC_INVOKED is defined by default by the windows RC tool.
 *
 * Resource compilers don't like all the C stuff, like typedefs and
 * procedure declarations, that occur below, so block them out.
 */

#ifndef RC_INVOKED

/*
 * Special macro to define mutexes, that doesn't do anything
 * if we are not using threads.
 */

#ifdef TCL_THREADS
#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
#else
#define TCL_DECLARE_MUTEX(name)
#endif

/*
 * Macros that eliminate the overhead of the thread synchronization
 * functions when compiling without thread support.
 */

#ifndef TCL_THREADS
#define Tcl_MutexLock(mutexPtr)
#define Tcl_MutexUnlock(mutexPtr)
#define Tcl_MutexFinalize(mutexPtr)
#define Tcl_ConditionNotify(condPtr)
#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */

/*
 * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET,
 * SEEK_CUR, and SEEK_END, all #define'd by stdio.h .
 *
 * Also, many extensions need stdio.h, and they've grown accustomed
 * to tcl.h providing it for them rather than #include-ing it themselves
 * as they should, so also for their sake, we keep the #include to be
 * consistent with prior Tcl releases.
 */

#include <stdio.h>

/*
 * Definitions that allow Tcl functions with variable numbers of

 * arguments to be used with either varargs.h or stdarg.h.  TCL_VARARGS
 * is used in procedure prototypes.  TCL_VARARGS_DEF is used to declare
 * the arguments in a function definiton: it takes the type and name of
 * the first argument and supplies the appropriate argument declaration
 * string for use in the function definition.  TCL_VARARGS_START
 * initializes the va_list data structure and returns the first argument.


 */
#if !defined(NO_STDARG)
#   include <stdarg.h>

#   define TCL_VARARGS(type, name) (type name, ...)
#   define TCL_VARARGS_DEF(type, name) (type name, ...)
#   define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
#   include <varargs.h>
#      define TCL_VARARGS(type, name) ()
#      define TCL_VARARGS_DEF(type, name) (va_alist)
#   define TCL_VARARGS_START(type, name, list) \
	(va_start(list), va_arg(list, type))
#endif

/*
 * Macros used to declare a function to be exported by a DLL.
 * Used by Windows, maps to no-op declarations on non-Windows systems.
 * The default build on windows is for a DLL, which causes the DLLIMPORT
 * and DLLEXPORT macros to be nonempty. To build a static library, the
 * macro STATIC_BUILD should be defined.
 */

#ifdef STATIC_BUILD
#   define DLLIMPORT
#   define DLLEXPORT
#else
#   if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
#	define DLLIMPORT __declspec(dllimport)
#	define DLLEXPORT __declspec(dllexport)
#   else
#	define DLLIMPORT
#	define DLLEXPORT
#   endif
#endif

/*
 * These macros are used to control whether functions are being declared for
 * import or export.  If a function is being declared while it is being built
 * to be included in a shared library, then it should have the DLLEXPORT
 * storage class.  If is being declared for use by a module that is going to
 * link against the shared library, then it should have the DLLIMPORT storage
 * class.  If the symbol is beind declared for a static build or for use from a
 * stub library, then the storage class should be empty.
 *
 * The convention is that a macro called BUILD_xxxx, where xxxx is the
 * name of a library we are building, is set on the compile line for sources
 * that are to be placed in the library.  When this macro is set, the
 * storage class will be set to DLLEXPORT.  At the end of the header file, the
 * storage class will be reset to DLLIMPORT.
 */

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TCL_STORAGE_CLASS DLLEXPORT
#else
#   ifdef USE_TCL_STUBS
#      define TCL_STORAGE_CLASS
#   else
#      define TCL_STORAGE_CLASS DLLIMPORT
#   endif
#endif


/*
 * Definitions that allow this header file to be used either with or
 * without ANSI C features like function prototypes.
 */

#undef _ANSI_ARGS_
#undef CONST
#ifndef INLINE
#   define INLINE
#endif

#ifndef NO_CONST



|
|







|
|

|





>
>
>
>
>
>
>
>









|
|
















>



|


|


|
|

















>










>









|
|
|
|

|
|





|
|









|
|












|
|

|
|
|
|

>



|
>
|
<
<
|
|
<
>
>

|
|
>
|
|
|
<
<
<
<
<
<



|
|
|
|
|

















|

|

|


|
|
|
|
|

>











<

|
|

>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158


159
160

161
162
163
164
165
166
167
168
169






170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219

220
221
222
223
224
225
226
227
228
229
230
231
/*
 * tcl.h --
 *
 *	This header file describes the externally-visible facilities of the
 *	Tcl interpreter.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1993-1996 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191.2.11 2005/09/27 18:42:54 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
 */

#ifdef __cplusplus
extern "C" {
#endif

/*
 * The following defines are used to indicate the various release levels.
 */

#define TCL_ALPHA_RELEASE	0
#define TCL_BETA_RELEASE	1
#define TCL_FINAL_RELEASE	2

/*
 * When version numbers change here, must also go into the following files and
 * update the version numbers:
 *
 * library/init.tcl	(only if Major.minor changes, not patchlevel) 1 LOC
 * unix/configure.in	(2 LOC Major, 2 LOC minor, 1 LOC patch)
 * win/configure.in	(as above)
 * win/tcl.m4		(not patchlevel)
 * win/makefile.bc	(not patchlevel) 2 LOC
 * README		(sections 0 and 2, with and without separator)
 * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 2 LOC
 * win/README.binary	(sections 0-4, with and without separator)
 * win/README		(not patchlevel) (sections 0 and 2)
 * unix/tcl.spec	(2 LOC Major/Minor, 1 LOC patch)
 * tests/basic.test	(1 LOC M/M, not patchlevel)
 * tools/tcl.hpj.in	(not patchlevel, for windows installer)
 * tools/tcl.wse.in	(for windows installer)
 * tools/tclSplash.bmp	(not patchlevel)
 */

#define TCL_MAJOR_VERSION   8
#define TCL_MINOR_VERSION   5
#define TCL_RELEASE_LEVEL   TCL_ALPHA_RELEASE
#define TCL_RELEASE_SERIAL  4

#define TCL_VERSION	    "8.5"
#define TCL_PATCH_LEVEL	    "8.5a4"

/*
 * The following definitions set up the proper options for Windows compilers.
 * We use this method because there is no autoconf equivalent.
 */

#ifndef __WIN32__
#   if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__))
#	define __WIN32__
#	ifndef WIN32
#	    define WIN32
#	endif
#	ifndef _WIN32
#	    define _WIN32
#	endif
#   endif
#endif

/*
 * STRICT: See MSDN Article Q83456
 */

#ifdef __WIN32__
#   ifndef STRICT
#	define STRICT
#   endif
#endif /* __WIN32__ */

/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */

#ifndef STRINGIFY
#  define STRINGIFY(x) STRINGIFY1(x)
#  define STRINGIFY1(x) #x
#endif
#ifndef JOIN
#  define JOIN(a,b) JOIN1(a,b)
#  define JOIN1(a,b) a##b
#endif

/*
 * A special definition used to allow this header file to be included from
 * windows resource files so that they can obtain version information.
 * RC_INVOKED is defined by default by the windows RC tool.
 *
 * Resource compilers don't like all the C stuff, like typedefs and function
 * declarations, that occur below, so block them out.
 */

#ifndef RC_INVOKED

/*
 * Special macro to define mutexes, that doesn't do anything if we are not
 * using threads.
 */

#ifdef TCL_THREADS
#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
#else
#define TCL_DECLARE_MUTEX(name)
#endif

/*
 * Macros that eliminate the overhead of the thread synchronization functions
 * when compiling without thread support.
 */

#ifndef TCL_THREADS
#define Tcl_MutexLock(mutexPtr)
#define Tcl_MutexUnlock(mutexPtr)
#define Tcl_MutexFinalize(mutexPtr)
#define Tcl_ConditionNotify(condPtr)
#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */

/*
 * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and
 * SEEK_END, all #define'd by stdio.h .
 *
 * Also, many extensions need stdio.h, and they've grown accustomed to tcl.h
 * providing it for them rather than #include-ing it themselves as they
 * should, so also for their sake, we keep the #include to be consistent with
 * prior Tcl releases.
 */

#include <stdio.h>

/*
 * Support for functions with a variable number of arguments.
 *
 * The following TCL_VARARGS* macros are to support old extensions


 * written for older versions of Tcl where the macros permitted
 * support for the varargs.h system as well as stdarg.h .  

 *
 * New code should just directly be written to use stdarg.h conventions.
 */

#include <stdarg.h>
#ifndef TCL_NO_DEPRECATED
#    define TCL_VARARGS(type, name) (type name, ...)
#    define TCL_VARARGS_DEF(type, name) (type name, ...)
#    define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)






#endif

/*
 * Macros used to declare a function to be exported by a DLL. Used by Windows,
 * maps to no-op declarations on non-Windows systems. The default build on
 * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be
 * nonempty. To build a static library, the macro STATIC_BUILD should be
 * defined.
 */

#ifdef STATIC_BUILD
#   define DLLIMPORT
#   define DLLEXPORT
#else
#   if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
#	define DLLIMPORT __declspec(dllimport)
#	define DLLEXPORT __declspec(dllexport)
#   else
#	define DLLIMPORT
#	define DLLEXPORT
#   endif
#endif

/*
 * These macros are used to control whether functions are being declared for
 * import or export. If a function is being declared while it is being built
 * to be included in a shared library, then it should have the DLLEXPORT
 * storage class. If is being declared for use by a module that is going to
 * link against the shared library, then it should have the DLLIMPORT storage
 * class. If the symbol is beind declared for a static build or for use from a
 * stub library, then the storage class should be empty.
 *
 * The convention is that a macro called BUILD_xxxx, where xxxx is the name of
 * a library we are building, is set on the compile line for sources that are
 * to be placed in the library. When this macro is set, the storage class will
 * be set to DLLEXPORT. At the end of the header file, the storage class will
 * be reset to DLLIMPORT.
 */

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TCL_STORAGE_CLASS DLLEXPORT
#else
#   ifdef USE_TCL_STUBS
#      define TCL_STORAGE_CLASS
#   else
#      define TCL_STORAGE_CLASS DLLIMPORT
#   endif
#endif


/*
 * Definitions that allow this header file to be used either with or without
 * ANSI C features like function prototypes.
 */

#undef _ANSI_ARGS_
#undef CONST
#ifndef INLINE
#   define INLINE
#endif

#ifndef NO_CONST
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254

255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297

298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
#   ifdef USE_COMPAT_CONST
#      error define at most one of USE_NON_CONST and USE_COMPAT_CONST
#   endif
#   define CONST84
#   define CONST84_RETURN
#else
#   ifdef USE_COMPAT_CONST
#      define CONST84 
#      define CONST84_RETURN CONST
#   else
#      define CONST84 CONST
#      define CONST84_RETURN CONST
#   endif
#endif


/*
 * Make sure EXTERN isn't defined elsewhere
 */

#ifdef EXTERN
#   undef EXTERN
#endif /* EXTERN */

#ifdef __cplusplus
#   define EXTERN extern "C" TCL_STORAGE_CLASS
#else
#   define EXTERN extern TCL_STORAGE_CLASS
#endif


/*
 * The following code is copied from winnt.h.
 * If we don't replicate it here, then <windows.h> can't be included 
 * after tcl.h, since tcl.h also defines VOID.
 * This block is skipped under Cygwin and Mingw.
 * 
 * 
 */
#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */

/*
 * Macro to use instead of "void" for arguments that must have
 * type "void *" in ANSI C;  maps them to type "char *" in
 * non-ANSI systems.
 */

#ifndef NO_VOID
#         define VOID void
#else
#         define VOID char
#endif

/*
 * Miscellaneous declarations.
 */

#ifndef NULL
#   define NULL 0
#endif

#ifndef _CLIENTDATA
#   ifndef NO_VOID
	typedef void *ClientData;
#   else
	typedef int *ClientData;
#   endif
#   define _CLIENTDATA
#endif

/*
 * Define Tcl_WideInt to be a type that is (at least) 64-bits wide,
 * and define Tcl_WideUInt to be the unsigned variant of that type
 * (assuming that where we have one, we can have the other.)
 *
 * Also defines the following macros:
 * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on
 *	a real 64-bit system.)
 * Tcl_WideAsLong - forgetful converter from wideInt to long.
 * Tcl_LongAsWide - sign-extending converter from long to wideInt.
 * Tcl_WideAsDouble - converter from wideInt to double.
 * Tcl_DoubleAsWide - converter from double to wideInt.
 *
 * The following invariant should hold for any long value 'longVal':
 *	longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
 *
 * Note on converting between Tcl_WideInt and strings.  This
 * implementation (in tclObj.c) depends on the functions strtoull()
 * and sprintf(...,"%" TCL_LL_MODIFIER "d",...).  TCL_LL_MODIFIER_SIZE
 * is the length of the modifier string, which is "ll" on most 32-bit
 * Unix systems.  It has to be split up like this to allow for the more
 * complex formats sometimes needed (e.g. in the format(n) command.)
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   if defined(__GNUC__)
#      define TCL_WIDE_INT_TYPE long long
#      if defined(__WIN32__) && !defined(__CYGWIN__)
#         define TCL_LL_MODIFIER        "I64"







|







<



>










<

|
<
|
|
|
|
<










|
|
<



|

|





>














|
|
|


|
|








|
|
|
|
|
|







244
245
246
247
248
249
250
251
252
253
254
255
256
257
258

259
260
261
262
263
264
265
266
267
268
269
270
271
272

273
274

275
276
277
278

279
280
281
282
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
#   ifdef USE_COMPAT_CONST
#      error define at most one of USE_NON_CONST and USE_COMPAT_CONST
#   endif
#   define CONST84
#   define CONST84_RETURN
#else
#   ifdef USE_COMPAT_CONST
#      define CONST84
#      define CONST84_RETURN CONST
#   else
#      define CONST84 CONST
#      define CONST84_RETURN CONST
#   endif
#endif


/*
 * Make sure EXTERN isn't defined elsewhere
 */

#ifdef EXTERN
#   undef EXTERN
#endif /* EXTERN */

#ifdef __cplusplus
#   define EXTERN extern "C" TCL_STORAGE_CLASS
#else
#   define EXTERN extern TCL_STORAGE_CLASS
#endif


/*
 * The following code is copied from winnt.h. If we don't replicate it here,

 * then <windows.h> can't be included after tcl.h, since tcl.h also defines
 * VOID. This block is skipped under Cygwin and Mingw.
 */


#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */

/*
 * Macro to use instead of "void" for arguments that must have type "void *"
 * in ANSI C; maps them to type "char *" in non-ANSI systems.

 */

#ifndef NO_VOID
#define VOID	void
#else
#define VOID	char
#endif

/*
 * Miscellaneous declarations.
 */

#ifndef NULL
#   define NULL 0
#endif

#ifndef _CLIENTDATA
#   ifndef NO_VOID
	typedef void *ClientData;
#   else
	typedef int *ClientData;
#   endif
#   define _CLIENTDATA
#endif

/*
 * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, and define
 * Tcl_WideUInt to be the unsigned variant of that type (assuming that where
 * we have one, we can have the other.)
 *
 * Also defines the following macros:
 * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a real
 *	64-bit system.)
 * Tcl_WideAsLong - forgetful converter from wideInt to long.
 * Tcl_LongAsWide - sign-extending converter from long to wideInt.
 * Tcl_WideAsDouble - converter from wideInt to double.
 * Tcl_DoubleAsWide - converter from double to wideInt.
 *
 * The following invariant should hold for any long value 'longVal':
 *	longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
 *
 * Note on converting between Tcl_WideInt and strings. This implementation (in
 * tclObj.c) depends on the functions strtoull() and sprintf(...,"%"
 * TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE is the length of the
 * modifier string, which is "ll" on most 32-bit Unix systems. It has to be
 * split up like this to allow for the more complex formats sometimes needed
 * (e.g. in the format(n) command.)
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   if defined(__GNUC__)
#      define TCL_WIDE_INT_TYPE long long
#      if defined(__WIN32__) && !defined(__CYGWIN__)
#         define TCL_LL_MODIFIER        "I64"
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
#      else /* __BORLANDC__ */
typedef struct _stati64	Tcl_StatBuf;
#         define TCL_LL_MODIFIER	"I64"
#         define TCL_LL_MODIFIER_SIZE	3
#      endif /* __BORLANDC__ */
#   else /* __WIN32__ */
/*
 * Don't know what platform it is and configure hasn't discovered what
 * is going on for us.  Try to guess...
 */
#      ifdef NO_LIMITS_H
#	  error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
#      else /* !NO_LIMITS_H */
#	  include <limits.h>
#	  if (INT_MAX < LONG_MAX)
#	     define TCL_WIDE_INT_IS_LONG	1







|
|







357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
#      else /* __BORLANDC__ */
typedef struct _stati64	Tcl_StatBuf;
#         define TCL_LL_MODIFIER	"I64"
#         define TCL_LL_MODIFIER_SIZE	3
#      endif /* __BORLANDC__ */
#   else /* __WIN32__ */
/*
 * Don't know what platform it is and configure hasn't discovered what is
 * going on for us. Try to guess...
 */
#      ifdef NO_LIMITS_H
#	  error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
#      else /* !NO_LIMITS_H */
#	  include <limits.h>
#	  if (INT_MAX < LONG_MAX)
#	     define TCL_WIDE_INT_IS_LONG	1
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417

418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
#   define Tcl_DoubleAsWide(val)	((long)((double)(val)))
#   ifndef TCL_LL_MODIFIER
#      define TCL_LL_MODIFIER		"l"
#      define TCL_LL_MODIFIER_SIZE	1
#   endif /* !TCL_LL_MODIFIER */
#else /* TCL_WIDE_INT_IS_LONG */
/*
 * The next short section of defines are only done when not running on
 * Windows or some other strange platform.
 */
#   ifndef TCL_LL_MODIFIER
#      ifdef HAVE_STRUCT_STAT64
typedef struct stat64	Tcl_StatBuf;
#      else
typedef struct stat	Tcl_StatBuf;
#      endif /* HAVE_STRUCT_STAT64 */
#      define TCL_LL_MODIFIER		"ll"
#      define TCL_LL_MODIFIER_SIZE	2
#   endif /* !TCL_LL_MODIFIER */
#   define Tcl_WideAsLong(val)		((long)((Tcl_WideInt)(val)))
#   define Tcl_LongAsWide(val)		((Tcl_WideInt)((long)(val)))
#   define Tcl_WideAsDouble(val)	((double)((Tcl_WideInt)(val)))
#   define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */


/*
 * This flag controls whether binary compatability is maintained with
 * extensions built against a previous version of Tcl. This is true
 * by default.
 */

#ifndef TCL_PRESERVE_BINARY_COMPATABILITY
#   define TCL_PRESERVE_BINARY_COMPATABILITY 1
#endif


/*
 * Data structures defined opaquely in this module. The definitions below
 * just provide dummy types. A few fields are made visible in Tcl_Interp
 * structures, namely those used for returning a string result from
 * commands. Direct access to the result field is discouraged in Tcl 8.0.
 * The interpreter result is either an object or a string, and the two
 * values are kept consistent unless some C code sets interp->result
 * directly. Programmers should use either the procedure Tcl_GetObjResult()
 * or Tcl_GetStringResult() to read the interpreter's result. See the
 * SetResult man page for details.
 * 
 * Note: any change to the Tcl_Interp definition below must be mirrored
 * in the "real" definition in tclInt.h.
 *
 * Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc.
 * Instead, they set a Tcl_Obj member in the "real" structure that can be
 * accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
 */

typedef struct Tcl_Interp {
    char *result;		/* If the last command returned a string
				 * result, this points to it. */
    void (*freeProc) _ANSI_ARGS_((char *blockPtr));
				/* Zero means the string result is
				 * statically allocated. TCL_DYNAMIC means
				 * it was allocated with ckalloc and should
				 * be freed with ckfree. Other values give
				 * the address of procedure to invoke to
				 * free the result. Tcl_Eval must free it
				 * before executing next command. */
    int errorLine;              /* When TCL_ERROR is returned, this gives
                                 * the line number within the command where
                                 * the error occurred (1 if first line). */
} Tcl_Interp;

typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;







|
|
















<


|
|

>




<

|
|
|
|
|
|
|
|
|
|
|
|

|








|
|
|
|
|
|
|
|
|
|







392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426

427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
#   define Tcl_DoubleAsWide(val)	((long)((double)(val)))
#   ifndef TCL_LL_MODIFIER
#      define TCL_LL_MODIFIER		"l"
#      define TCL_LL_MODIFIER_SIZE	1
#   endif /* !TCL_LL_MODIFIER */
#else /* TCL_WIDE_INT_IS_LONG */
/*
 * The next short section of defines are only done when not running on Windows
 * or some other strange platform.
 */
#   ifndef TCL_LL_MODIFIER
#      ifdef HAVE_STRUCT_STAT64
typedef struct stat64	Tcl_StatBuf;
#      else
typedef struct stat	Tcl_StatBuf;
#      endif /* HAVE_STRUCT_STAT64 */
#      define TCL_LL_MODIFIER		"ll"
#      define TCL_LL_MODIFIER_SIZE	2
#   endif /* !TCL_LL_MODIFIER */
#   define Tcl_WideAsLong(val)		((long)((Tcl_WideInt)(val)))
#   define Tcl_LongAsWide(val)		((Tcl_WideInt)((long)(val)))
#   define Tcl_WideAsDouble(val)	((double)((Tcl_WideInt)(val)))
#   define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */


/*
 * This flag controls whether binary compatability is maintained with
 * extensions built against a previous version of Tcl. This is true by
 * default.
 */

#ifndef TCL_PRESERVE_BINARY_COMPATABILITY
#   define TCL_PRESERVE_BINARY_COMPATABILITY 1
#endif


/*
 * Data structures defined opaquely in this module. The definitions below just
 * provide dummy types. A few fields are made visible in Tcl_Interp
 * structures, namely those used for returning a string result from commands.
 * Direct access to the result field is discouraged in Tcl 8.0. The
 * interpreter result is either an object or a string, and the two values are
 * kept consistent unless some C code sets interp->result directly.
 * Programmers should use either the function Tcl_GetObjResult() or
 * Tcl_GetStringResult() to read the interpreter's result. See the SetResult
 * man page for details.
 *
 * Note: any change to the Tcl_Interp definition below must be mirrored in the
 * "real" definition in tclInt.h.
 *
 * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc.
 * Instead, they set a Tcl_Obj member in the "real" structure that can be
 * accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
 */

typedef struct Tcl_Interp {
    char *result;		/* If the last command returned a string
				 * result, this points to it. */
    void (*freeProc) _ANSI_ARGS_((char *blockPtr));
				/* Zero means the string result is statically
				 * allocated. TCL_DYNAMIC means it was
				 * allocated with ckalloc and should be freed
				 * with ckfree. Other values give the address
				 * of function to invoke to free the result.
				 * Tcl_Eval must free it before executing next
				 * command. */
    int errorLine;		/* When TCL_ERROR is returned, this gives the
				 * line number within the command where the
				 * error occurred (1 if first line). */
} Tcl_Interp;

typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
472
473
474
475
476
477
478
479
480
481
482
483

484
485
486
487
488
489
490
491
492
493
494
495

496
497
498
499
500
501
502
503
504
505
506
507
508

509
510
511
512
513
514
515

516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534

535
536
537
538
539
540
541

542
543
544
545
546
547
548
549

550
551

552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600
601
602
603

604
605
606
607
608
609
610
611
612

613
614
615

616
617
618
619
620
621
622
623
624
625
626
627
628

629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689

690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762






763
764
765
766
767
768
769
770
771
772
773
774
775
776

777
778
779
780
781
782
783
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;

/*
 * Definition of the interface to procedures implementing threads.
 * A procedure following this definition is given to each call of
 * 'Tcl_CreateThread' and will be called as the main fuction of
 * the new thread created by that call.
 */

#if defined __WIN32__
typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#else
typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#endif


/*
 * Threading function return types used for abstracting away platform
 * differences when writing a Tcl_ThreadCreateProc.  See the NewThread
 * function in generic/tclThreadTest.c for it's usage.
 */

#if defined __WIN32__
#   define Tcl_ThreadCreateType		unsigned __stdcall
#   define TCL_THREAD_CREATE_RETURN	return 0
#else
#   define Tcl_ThreadCreateType		void
#   define TCL_THREAD_CREATE_RETURN	
#endif


/*
 * Definition of values for default stacksize and the possible flags to be
 * given to Tcl_CreateThread.
 */

#define TCL_THREAD_STACK_DEFAULT (0)    /* Use default size for stack */
#define TCL_THREAD_NOFLAGS       (0000) /* Standard flags, default behaviour */
#define TCL_THREAD_JOINABLE      (0001) /* Mark the thread as joinable */

/*
 * Flag values passed to Tcl_GetRegExpFromObj.
 */

#define	TCL_REG_BASIC		000000	/* BREs (convenience) */
#define	TCL_REG_EXTENDED	000001	/* EREs */
#define	TCL_REG_ADVF		000002	/* advanced features in EREs */
#define	TCL_REG_ADVANCED	000003	/* AREs (which are also EREs) */
#define	TCL_REG_QUOTE		000004	/* no special characters, none */
#define	TCL_REG_NOCASE		000010	/* ignore case */
#define	TCL_REG_NOSUB		000020	/* don't care about subexpressions */
#define	TCL_REG_EXPANDED	000040	/* expanded format, white space &
					 * comments */
#define	TCL_REG_NLSTOP		000100  /* \n doesn't match . or [^ ] */
#define	TCL_REG_NLANCH		000200  /* ^ matches after \n, $ before */
#define	TCL_REG_NEWLINE		000300  /* newlines are line terminators */
#define	TCL_REG_CANMATCH	001000  /* report details on partial/limited
					 * matches */

/*
 * The following flag is experimental and only intended for use by Expect.  It
 * will probably go away in a later release.
 */

#define TCL_REG_BOSONLY		002000	/* prepend \A to pattern so it only
					 * matches at the beginning of the
					 * string. */

/*
 * Flags values passed to Tcl_RegExpExecObj.
 */

#define	TCL_REG_NOTBOL	0001	/* Beginning of string does not match ^.  */
#define	TCL_REG_NOTEOL	0002	/* End of string does not match $. */

/*
 * Structures filled in by Tcl_RegExpInfo.  Note that all offset values are
 * relative to the start of the match string, not the beginning of the
 * entire string.
 */

typedef struct Tcl_RegExpIndices {
    long start;		/* character offset of first character in match */

    long end;		/* character offset of first character after the
			 * match. */
} Tcl_RegExpIndices;

typedef struct Tcl_RegExpInfo {
    int nsubs;			/* number of subexpressions in the
				 * compiled expression */
    Tcl_RegExpIndices *matches;	/* array of nsubs match offset
				 * pairs */
    long extendStart;		/* The offset at which a subsequent
				 * match might begin. */
    long reserved;		/* Reserved for later use. */
} Tcl_RegExpInfo;

/*
 * Picky compilers complain if this typdef doesn't appear before the
 * struct's reference in tclDecls.h.
 */

typedef Tcl_StatBuf *Tcl_Stat_;
typedef struct stat *Tcl_OldStat_;

/*
 * When a TCL command returns, the interpreter contains a result from the
 * command. Programmers are strongly encouraged to use one of the
 * procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the
 * interpreter's result. See the SetResult man page for details. Besides
 * this result, the command procedure returns an integer code, which is 
 * one of the following:
 *
 * TCL_OK		Command completed normally; the interpreter's
 *			result contains	the command's result.
 * TCL_ERROR		The command couldn't be completed successfully;
 *			the interpreter's result describes what went wrong.
 * TCL_RETURN		The command requests that the current procedure
 *			return; the interpreter's result contains the
 *			procedure's return value.
 * TCL_BREAK		The command requests that the innermost loop
 *			be exited; the interpreter's result is meaningless.
 * TCL_CONTINUE		Go on to the next iteration of the current loop;
 *			the interpreter's result is meaningless.
 */

#define TCL_OK		0
#define TCL_ERROR	1
#define TCL_RETURN	2
#define TCL_BREAK	3
#define TCL_CONTINUE	4

#define TCL_RESULT_SIZE 200

/*
 * Flags to control what substitutions are performed by Tcl_SubstObj():
 */

#define TCL_SUBST_COMMANDS	001
#define TCL_SUBST_VARIABLES	002
#define TCL_SUBST_BACKSLASHES	004
#define TCL_SUBST_ALL		007


/*
 * Argument descriptors for math function callbacks in expressions:
 */

typedef enum {
    TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;

typedef struct Tcl_Value {
    Tcl_ValueType type;		/* Indicates intValue or doubleValue is
				 * valid, or both. */
    long intValue;		/* Integer value. */
    double doubleValue;		/* Double-precision floating value. */
    Tcl_WideInt wideValue;	/* Wide (min. 64-bit) integer value. */
} Tcl_Value;

/*
 * Forward declaration of Tcl_Obj to prevent an error when the forward
 * reference to Tcl_Obj is encountered in the procedure types declared 
 * below.
 */

struct Tcl_Obj;


/*
 * Procedure types defined by Tcl:
 */

typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int code));
typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int argc, CONST84 char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
	ClientData cmdClientData, int argc, CONST84 char *argv[]));
typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, CONST char *command,
	Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, 
        struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
	CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
	char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr,
	int *dstCharsPtr));
typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
	int flags));
typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr,
        ClientData clientData));
typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
	int flags));
typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp));
typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
                                                 int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
        Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags));

typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
	int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
	Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));


/*
 * The following structure represents a type of object, which is a
 * particular internal representation for an object plus a set of
 * procedures that provide standard operations on objects of that type.
 */

typedef struct Tcl_ObjType {
    char *name;			/* Name of the type, e.g. "int". */
    Tcl_FreeInternalRepProc *freeIntRepProc;
				/* Called to free any storage for the type's
				 * internal rep. NULL if the internal rep
				 * does not need freeing. */
    Tcl_DupInternalRepProc *dupIntRepProc;
    				/* Called to create a new object as a copy
				 * of an existing object. */
    Tcl_UpdateStringProc *updateStringProc;
    				/* Called to update the string rep from the
				 * type's internal representation. */
    Tcl_SetFromAnyProc *setFromAnyProc;
    				/* Called to convert the object's internal
				 * rep to this type. Frees the internal rep
				 * of the old type. Returns TCL_ERROR on
				 * failure. */
} Tcl_ObjType;


/*
 * One of the following structures exists for each object in the Tcl
 * system. An object stores a value as either a string, some internal
 * representation, or both.
 */

typedef struct Tcl_Obj {
    int refCount;		/* When 0 the object will be freed. */
    char *bytes;		/* This points to the first byte of the
				 * object's string representation. The array
				 * must be followed by a null byte (i.e., at
				 * offset length) but may also contain
				 * embedded null characters. The array's
				 * storage is allocated by ckalloc. NULL
				 * means the string rep is invalid and must
				 * be regenerated from the internal rep.
				 * Clients should use Tcl_GetStringFromObj
				 * or Tcl_GetString to get a pointer to the
				 * byte array as a readonly value. */
    int length;			/* The number of bytes at *bytes, not
				 * including the terminating null. */
    Tcl_ObjType *typePtr;	/* Denotes the object's type. Always
				 * corresponds to the type of the object's
				 * internal rep. NULL indicates the object
				 * has no internal rep (has no type). */
    union {			/* The internal representation: */
	long longValue;		/*   - an long integer value */
	double doubleValue;	/*   - a double-precision floating value */
	VOID *otherValuePtr;	/*   - another, type-specific value */
	Tcl_WideInt wideValue;	/*   - a long long value */
	struct {		/*   - internal rep as two pointers */
	    VOID *ptr1;
	    VOID *ptr2;
	} twoPtrValue;






    } internalRep;
} Tcl_Obj;


/*
 * Macros to increment and decrement a Tcl_Obj's reference count, and to
 * test whether an object is shared (i.e. has reference count > 1).
 * Note: clients should use Tcl_DecrRefCount() when they are finished using
 * an object, and should never call TclFreeObj() directly. TclFreeObj() is
 * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro
 * definition. Note also that Tcl_DecrRefCount() refers to the parameter
 * "obj" twice. This means that you should avoid calling it with an
 * expression that is expensive to compute or has side effects.
 */

void		Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
void		Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
int		Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));

#ifdef TCL_MEM_DEBUG
#   define Tcl_IncrRefCount(objPtr) \
	Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)







|
|
|
<

>






<


|
|

>





|

<





>

|
|




>
















|


>







>




|
|
|

>

|
>
|
|



|
|
|
<
|
|




|
|

>





|
|
|
|
<

|
|
|
|
|
|
|
|
|
|
|

>











>





<



>



>

|
|







|
<

>


<

|

















|
|









|

















|
|

|





|
>












<

|
|
|






|
|

|
|

|


|
|
|
<


<

|
|
|









|
|
|
|
|
|




|
|









>
>
>
>
>
>



<

|
|
|
|
|
|
|
|

>







476
477
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493

494
495
496
497
498
499
500
501
502
503
504
505
506

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568

569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587

588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618

619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637

638
639
640
641

642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712

713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734

735
736

737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779

780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;

/*
 * Definition of the interface to functions implementing threads. A function
 * following this definition is given to each call of 'Tcl_CreateThread' and
 * will be called as the main fuction of the new thread created by that call.

 */

#if defined __WIN32__
typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#else
typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#endif


/*
 * Threading function return types used for abstracting away platform
 * differences when writing a Tcl_ThreadCreateProc. See the NewThread function
 * in generic/tclThreadTest.c for it's usage.
 */

#if defined __WIN32__
#   define Tcl_ThreadCreateType		unsigned __stdcall
#   define TCL_THREAD_CREATE_RETURN	return 0
#else
#   define Tcl_ThreadCreateType		void
#   define TCL_THREAD_CREATE_RETURN
#endif


/*
 * Definition of values for default stacksize and the possible flags to be
 * given to Tcl_CreateThread.
 */

#define TCL_THREAD_STACK_DEFAULT (0)    /* Use default size for stack */
#define TCL_THREAD_NOFLAGS	 (0000) /* Standard flags, default behaviour */
#define TCL_THREAD_JOINABLE	 (0001) /* Mark the thread as joinable */

/*
 * Flag values passed to Tcl_GetRegExpFromObj.
 */

#define	TCL_REG_BASIC		000000	/* BREs (convenience) */
#define	TCL_REG_EXTENDED	000001	/* EREs */
#define	TCL_REG_ADVF		000002	/* advanced features in EREs */
#define	TCL_REG_ADVANCED	000003	/* AREs (which are also EREs) */
#define	TCL_REG_QUOTE		000004	/* no special characters, none */
#define	TCL_REG_NOCASE		000010	/* ignore case */
#define	TCL_REG_NOSUB		000020	/* don't care about subexpressions */
#define	TCL_REG_EXPANDED	000040	/* expanded format, white space &
					 * comments */
#define	TCL_REG_NLSTOP		000100  /* \n doesn't match . or [^ ] */
#define	TCL_REG_NLANCH		000200  /* ^ matches after \n, $ before */
#define	TCL_REG_NEWLINE		000300  /* newlines are line terminators */
#define	TCL_REG_CANMATCH	001000  /* report details on partial/limited
					 * matches */

/*
 * The following flag is experimental and only intended for use by Expect. It
 * will probably go away in a later release.
 */

#define TCL_REG_BOSONLY		002000	/* prepend \A to pattern so it only
					 * matches at the beginning of the
					 * string. */

/*
 * Flags values passed to Tcl_RegExpExecObj.
 */

#define	TCL_REG_NOTBOL	0001	/* Beginning of string does not match ^.  */
#define	TCL_REG_NOTEOL	0002	/* End of string does not match $. */

/*
 * Structures filled in by Tcl_RegExpInfo. Note that all offset values are
 * relative to the start of the match string, not the beginning of the entire
 * string.
 */

typedef struct Tcl_RegExpIndices {
    long start;			/* Character offset of first character in
				 * match. */
    long end;			/* Character offset of first character after
				 * the match. */
} Tcl_RegExpIndices;

typedef struct Tcl_RegExpInfo {
    int nsubs;			/* Number of subexpressions in the compiled
				 * expression. */
    Tcl_RegExpIndices *matches;	/* Array of nsubs match offset pairs. */

    long extendStart;		/* The offset at which a subsequent match
				 * might begin. */
    long reserved;		/* Reserved for later use. */
} Tcl_RegExpInfo;

/*
 * Picky compilers complain if this typdef doesn't appear before the struct's
 * reference in tclDecls.h.
 */

typedef Tcl_StatBuf *Tcl_Stat_;
typedef struct stat *Tcl_OldStat_;

/*
 * When a TCL command returns, the interpreter contains a result from the
 * command. Programmers are strongly encouraged to use one of the functions
 * Tcl_GetObjResult() or Tcl_GetStringResult() to read the interpreter's
 * result. See the SetResult man page for details. Besides this result, the
 * command function returns an integer code, which is one of the following:

 *
 * TCL_OK		Command completed normally; the interpreter's result
 *			contains the command's result.
 * TCL_ERROR		The command couldn't be completed successfully; the
 *			interpreter's result describes what went wrong.
 * TCL_RETURN		The command requests that the current function return;
 *			the interpreter's result contains the function's
 *			return value.
 * TCL_BREAK		The command requests that the innermost loop be
 *			exited; the interpreter's result is meaningless.
 * TCL_CONTINUE		Go on to the next iteration of the current loop; the
 *			interpreter's result is meaningless.
 */

#define TCL_OK		0
#define TCL_ERROR	1
#define TCL_RETURN	2
#define TCL_BREAK	3
#define TCL_CONTINUE	4

#define TCL_RESULT_SIZE 200

/*
 * Flags to control what substitutions are performed by Tcl_SubstObj():
 */

#define TCL_SUBST_COMMANDS	001
#define TCL_SUBST_VARIABLES	002
#define TCL_SUBST_BACKSLASHES	004
#define TCL_SUBST_ALL		007


/*
 * Argument descriptors for math function callbacks in expressions:
 */

typedef enum {
    TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;

typedef struct Tcl_Value {
    Tcl_ValueType type;		/* Indicates intValue or doubleValue is valid,
				 * or both. */
    long intValue;		/* Integer value. */
    double doubleValue;		/* Double-precision floating value. */
    Tcl_WideInt wideValue;	/* Wide (min. 64-bit) integer value. */
} Tcl_Value;

/*
 * Forward declaration of Tcl_Obj to prevent an error when the forward
 * reference to Tcl_Obj is encountered in the function types declared below.

 */

struct Tcl_Obj;


/*
 * Function types defined by Tcl:
 */

typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int code));
typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int argc, CONST84 char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
	ClientData cmdClientData, int argc, CONST84 char *argv[]));
typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, CONST char *command,
	Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
	struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
	CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
	char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr,
	int *dstCharsPtr));
typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
	int flags));
typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr,
	ClientData clientData));
typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
	int flags));
typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp));
typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
	Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2,
	int flags));
typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
	int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
	Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));


/*
 * The following structure represents a type of object, which is a particular
 * internal representation for an object plus a set of functions that provide
 * standard operations on objects of that type.
 */

typedef struct Tcl_ObjType {
    char *name;			/* Name of the type, e.g. "int". */
    Tcl_FreeInternalRepProc *freeIntRepProc;
				/* Called to free any storage for the type's
				 * internal rep. NULL if the internal rep does
				 * not need freeing. */
    Tcl_DupInternalRepProc *dupIntRepProc;
				/* Called to create a new object as a copy of
				 * an existing object. */
    Tcl_UpdateStringProc *updateStringProc;
				/* Called to update the string rep from the
				 * type's internal representation. */
    Tcl_SetFromAnyProc *setFromAnyProc;
				/* Called to convert the object's internal rep
				 * to this type. Frees the internal rep of the
				 * old type. Returns TCL_ERROR on failure. */

} Tcl_ObjType;


/*
 * One of the following structures exists for each object in the Tcl system.
 * An object stores a value as either a string, some internal representation,
 * or both.
 */

typedef struct Tcl_Obj {
    int refCount;		/* When 0 the object will be freed. */
    char *bytes;		/* This points to the first byte of the
				 * object's string representation. The array
				 * must be followed by a null byte (i.e., at
				 * offset length) but may also contain
				 * embedded null characters. The array's
				 * storage is allocated by ckalloc. NULL means
				 * the string rep is invalid and must be
				 * regenerated from the internal rep.  Clients
				 * should use Tcl_GetStringFromObj or
				 * Tcl_GetString to get a pointer to the byte
				 * array as a readonly value. */
    int length;			/* The number of bytes at *bytes, not
				 * including the terminating null. */
    Tcl_ObjType *typePtr;	/* Denotes the object's type. Always
				 * corresponds to the type of the object's
				 * internal rep. NULL indicates the object has
				 * no internal rep (has no type). */
    union {			/* The internal representation: */
	long longValue;		/*   - an long integer value */
	double doubleValue;	/*   - a double-precision floating value */
	VOID *otherValuePtr;	/*   - another, type-specific value */
	Tcl_WideInt wideValue;	/*   - a long long value */
	struct {		/*   - internal rep as two pointers */
	    VOID *ptr1;
	    VOID *ptr2;
	} twoPtrValue;
	struct {		/*   - internal rep as a wide int, tightly
				 *     packed fields */
	    VOID *ptr;		/* Pointer to digits */
	    unsigned long value;/* Alloc, used, and signum packed into a
				 * single word */
	} ptrAndLongRep;
    } internalRep;
} Tcl_Obj;


/*
 * Macros to increment and decrement a Tcl_Obj's reference count, and to test
 * whether an object is shared (i.e. has reference count > 1). Note: clients
 * should use Tcl_DecrRefCount() when they are finished using an object, and
 * should never call TclFreeObj() directly. TclFreeObj() is only defined and
 * made public in tcl.h to support Tcl_DecrRefCount's macro definition. Note
 * also that Tcl_DecrRefCount() refers to the parameter "obj" twice. This
 * means that you should avoid calling it with an expression that is expensive
 * to compute or has side effects.
 */

void		Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
void		Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
int		Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));

#ifdef TCL_MEM_DEBUG
#   define Tcl_IncrRefCount(objPtr) \
	Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
791
792
793
794
795
796
797
798
799
800
801
802
803


804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829

830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944

945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966

967
968
969
970
971
972
973
974

975
976
977
978
979
980
981
982
983
984
985
986
987

988
989
990
991
992
993
994

995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020

1021
1022
1023
1024
1025
1026
1027

1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047








1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070

1071
1072
1073
1074
1075
1076
1077
1078

1079
1080
1081
1082
1083
1084
1085








1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108

1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167

1168
1169
1170
1171
1172
1173
1174

1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185

1186
1187
1188
1189
1190

1191
1192
1193
1194
1195

1196

1197
1198

1199

1200
1201

1202
1203
1204
1205
1206

1207

1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
#   define Tcl_DecrRefCount(objPtr) \
	if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
#   define Tcl_IsShared(objPtr) \
	((objPtr)->refCount > 1)
#endif

/*
 * Macros and definitions that help to debug the use of Tcl objects.
 * When TCL_MEM_DEBUG is defined, the Tcl_New declarations are 
 * overridden to call debugging versions of the object creation procedures.
 */

#ifdef TCL_MEM_DEBUG


#  define Tcl_NewBooleanObj(val) \
     Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
#  define Tcl_NewByteArrayObj(bytes, len) \
     Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
#  define Tcl_NewDoubleObj(val) \
     Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
#  define Tcl_NewIntObj(val) \
     Tcl_DbNewLongObj(val, __FILE__, __LINE__)
#  define Tcl_NewListObj(objc, objv) \
     Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
#  define Tcl_NewLongObj(val) \
     Tcl_DbNewLongObj(val, __FILE__, __LINE__)
#  define Tcl_NewObj() \
     Tcl_DbNewObj(__FILE__, __LINE__)
#  define Tcl_NewStringObj(bytes, len) \
     Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
#  define Tcl_NewWideIntObj(val) \
     Tcl_DbNewWideIntObj(val, __FILE__, __LINE__)
#endif /* TCL_MEM_DEBUG */


/*
 * The following structure contains the state needed by
 * Tcl_SaveResult.  No-one outside of Tcl should access any of these
 * fields.  This structure is typically allocated on the stack.
 */

typedef struct Tcl_SavedResult {
    char *result;
    Tcl_FreeProc *freeProc;
    Tcl_Obj *objResultPtr;
    char *appendResult;
    int appendAvl;
    int appendUsed;
    char resultSpace[TCL_RESULT_SIZE+1];
} Tcl_SavedResult;


/*
 * The following definitions support Tcl's namespace facility.
 * Note: the first five fields must match exactly the fields in a
 * Namespace structure (see tclInt.h). 
 */

typedef struct Tcl_Namespace {
    char *name;                 /* The namespace's name within its parent
				 * namespace. This contains no ::'s. The
				 * name of the global namespace is ""
				 * although "::" is an synonym. */
    char *fullName;             /* The namespace's fully qualified name.
				 * This starts with ::. */
    ClientData clientData;      /* Arbitrary value associated with this
				 * namespace. */
    Tcl_NamespaceDeleteProc* deleteProc;
                                /* Procedure invoked when deleting the
				 * namespace to, e.g., free clientData. */
    struct Tcl_Namespace* parentPtr;
                                /* Points to the namespace that contains
				 * this one. NULL if this is the global
				 * namespace. */
} Tcl_Namespace;


/*
 * The following structure represents a call frame, or activation record.
 * A call frame defines a naming context for a procedure call: its local
 * scope (for local variables) and its namespace scope (used for non-local
 * variables; often the global :: namespace). A call frame can also define
 * the naming context for a namespace eval or namespace inscope command:
 * the namespace in which the command's code should execute. The
 * Tcl_CallFrame structures exist only while procedures or namespace
 * eval/inscope's are being executed, and provide a Tcl call stack.
 * 
 * A call frame is initialized and pushed using Tcl_PushCallFrame and
 * popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be
 * provided by the Tcl_PushCallFrame caller, and callers typically allocate
 * them on the C call stack for efficiency. For this reason, Tcl_CallFrame
 * is defined as a structure and not as an opaque token. However, most
 * Tcl_CallFrame fields are hidden since applications should not access
 * them directly; others are declared as "dummyX".
 *
 * WARNING!! The structure definition must be kept consistent with the
 * CallFrame structure in tclInt.h. If you change one, change the other.
 */

typedef struct Tcl_CallFrame {
    Tcl_Namespace *nsPtr;
    int dummy1;
    int dummy2;
    char *dummy3;
    char *dummy4;
    char *dummy5;
    int dummy6;
    char *dummy7;
    char *dummy8;
    int dummy9;
    char* dummy10;
} Tcl_CallFrame;


/*
 * Information about commands that is returned by Tcl_GetCommandInfo and
 * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based
 * command procedure while proc is a traditional Tcl argc/argv
 * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand
 * ensure that both objProc and proc are non-NULL and can be called to
 * execute the command. However, it may be faster to call one instead of
 * the other. The member isNativeObjectProc is set to 1 if an
 * object-based procedure was registered by Tcl_CreateObjCommand, and to
 * 0 if a string-based procedure was registered by Tcl_CreateCommand.
 * The other procedure is typically set to a compatibility wrapper that
 * does string-to-object or object-to-string argument conversions then
 * calls the other procedure.
 */

typedef struct Tcl_CmdInfo {
    int isNativeObjectProc;	 /* 1 if objProc was registered by a call to
				  * Tcl_CreateObjCommand; 0 otherwise.
				  * Tcl_SetCmdInfo does not modify this
				  * field. */
    Tcl_ObjCmdProc *objProc;	 /* Command's object-based procedure. */
    ClientData objClientData;	 /* ClientData for object proc. */
    Tcl_CmdProc *proc;		 /* Command's string-based procedure. */
    ClientData clientData;	 /* ClientData for string proc. */
    Tcl_CmdDeleteProc *deleteProc;
                                 /* Procedure to call when command is
                                  * deleted. */
    ClientData deleteData;	 /* Value to pass to deleteProc (usually
				  * the same as clientData). */
    Tcl_Namespace *namespacePtr; /* Points to the namespace that contains
				  * this command. Note that Tcl_SetCmdInfo
				  * will not change a command's namespace;
				  * use TclRenameCommand or Tcl_Eval (of
				  * 'rename') to do that. */

} Tcl_CmdInfo;

/*
 * The structure defined below is used to hold dynamic strings.  The only
 * field that clients should use is the string field, accessible via the
 * macro Tcl_DStringValue.  
 */

#define TCL_DSTRING_STATIC_SIZE 200
typedef struct Tcl_DString {
    char *string;		/* Points to beginning of string:  either
				 * staticSpace below or a malloced array. */
    int length;			/* Number of non-NULL characters in the
				 * string. */
    int spaceAvl;		/* Total number of bytes available for the
				 * string and its terminating NULL char. */
    char staticSpace[TCL_DSTRING_STATIC_SIZE];
				/* Space to use in common case where string
				 * is small. */
} Tcl_DString;

#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
#define Tcl_DStringTrunc Tcl_DStringSetLength

/*
 * Definitions for the maximum number of digits of precision that may
 * be specified in the "tcl_precision" variable, and the number of
 * bytes of buffer space required by Tcl_PrintDouble.
 */

#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)

/*
 * Definition for a number of bytes of buffer space sufficient to hold the
 * string representation of an integer in base 10 (assuming the existence
 * of 64-bit integers).
 */

#define TCL_INTEGER_SPACE	24

/*
 * Flag values passed to Tcl_ConvertElement.
 * TCL_DONT_USE_BRACES forces it not to enclose the element in braces, but
 * 	to use backslash quoting instead.
 * TCL_DONT_QUOTE_HASH disables the default quoting of the '#' character.
 * 	It is safe to leave the hash unquoted when the element is not the
 * 	first element of a list, and this flag can be used by the caller to
 * 	indicated that condition.
 * (careful!  if you change these flag values be sure to change the
 *  definitions at the front of tclUtil.c).
 */

#define TCL_DONT_USE_BRACES	1
#define TCL_DONT_QUOTE_HASH	8

/*
 * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
 * abbreviated strings.
 */

#define TCL_EXACT	1

/*
 * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv.
 * WARNING: these bit choices must not conflict with the bit choices
 * for evalFlag bits in tclInt.h!!
 *
 * Meanings:
 *	TCL_NO_EVAL:		Just record this command
 *	TCL_EVAL_GLOBAL:	Execute script in global namespace
 *	TCL_EVAL_DIRECT:	Do not compile this script
 *	TCL_EVAL_INVOKE:	Magical Tcl_EvalObjv mode for aliases/ensembles
 *				o Run in global namespace
 *				o Cut out of error traces
 *				o Don't reset the flags controlling ensemble
 *				  error message rewriting.
 */
#define TCL_NO_EVAL		0x10000
#define TCL_EVAL_GLOBAL		0x20000
#define TCL_EVAL_DIRECT		0x40000
#define TCL_EVAL_INVOKE		0x80000

/*
 * Special freeProc values that may be passed to Tcl_SetResult (see
 * the man page for details):
 */

#define TCL_VOLATILE	((Tcl_FreeProc *) 1)
#define TCL_STATIC	((Tcl_FreeProc *) 0)
#define TCL_DYNAMIC	((Tcl_FreeProc *) 3)

/*
 * Flag values passed to variable-related procedures.
 */

#define TCL_GLOBAL_ONLY		 1
#define TCL_NAMESPACE_ONLY	 2
#define TCL_APPEND_VALUE	 4
#define TCL_LIST_ELEMENT	 8
#define TCL_TRACE_READS		 0x10
#define TCL_TRACE_WRITES	 0x20
#define TCL_TRACE_UNSETS	 0x40
#define TCL_TRACE_DESTROYED	 0x80
#define TCL_INTERP_DESTROYED	 0x100
#define TCL_LEAVE_ERR_MSG	 0x200
#define TCL_TRACE_ARRAY		 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
/* Required to support old variable/vdelete/vinfo traces */
#define TCL_TRACE_OLD_STYLE	 0x1000
#endif
/* Indicate the semantics of the result of a trace */
#define TCL_TRACE_RESULT_DYNAMIC 0x8000
#define TCL_TRACE_RESULT_OBJECT  0x10000

/*








 * Flag values passed to command-related procedures.
 */

#define TCL_TRACE_RENAME 0x2000
#define TCL_TRACE_DELETE 0x4000

#define TCL_ALLOW_INLINE_COMPILATION 0x20000

/*
 * Flag values passed to Tcl_CreateObjTrace, and used internally
 * by command execution traces.  Slots 4,8,16 and 32 are
 * used internally by execution traces (see tclCmdMZ.c)
 */
#define TCL_TRACE_ENTER_EXEC		1
#define TCL_TRACE_LEAVE_EXEC		2

/*
 * The TCL_PARSE_PART1 flag is deprecated and has no effect. 
 * The part1 is now always parsed whenever the part2 is NULL.
 * (This is to avoid a common error when converting code to
 *  use the new object based APIs and forgetting to give the
 *  flag)
 */

#ifndef TCL_NO_DEPRECATED
#   define TCL_PARSE_PART1      0x400
#endif


/*
 * Types for linked variables:
 */

#define TCL_LINK_INT		1
#define TCL_LINK_DOUBLE		2
#define TCL_LINK_BOOLEAN	3
#define TCL_LINK_STRING		4
#define TCL_LINK_WIDE_INT	5
#define TCL_LINK_READ_ONLY	0x80










/*
 * Forward declarations of Tcl_HashTable and related types.
 */

typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;

typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
	VOID *keyPtr));
typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr,
	Tcl_HashEntry *hPtr));
typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_((
	Tcl_HashTable *tablePtr, VOID *keyPtr));
typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr));

/*
 * This flag controls whether the hash table stores the hash of a key, or
 * recalculates it. There should be no reason for turning this flag off
 * as it is completely binary and source compatible unless you directly
 * access the bucketPtr member of the Tcl_HashTableEntry structure. This
 * member has been removed and the space used to store the hash value.
 */

#ifndef TCL_HASH_KEY_STORE_HASH
#   define TCL_HASH_KEY_STORE_HASH 1
#endif

/*
 * Structure definition for an entry in a hash table.  No-one outside
 * Tcl should access any of these fields directly;  use the macros
 * defined below.
 */

struct Tcl_HashEntry {
    Tcl_HashEntry *nextPtr;		/* Pointer to next entry in this
					 * hash bucket, or NULL for end of
					 * chain. */
    Tcl_HashTable *tablePtr;		/* Pointer to table containing entry. */
#if TCL_HASH_KEY_STORE_HASH
#   if TCL_PRESERVE_BINARY_COMPATABILITY
    VOID *hash;				/* Hash value, stored as pointer to
					 * ensure that the offsets of the
					 * fields in this structure are not
					 * changed. */
#   else
    unsigned int hash;			/* Hash value. */
#   endif
#else
    Tcl_HashEntry **bucketPtr;		/* Pointer to bucket that points to
					 * first entry in this entry's chain:
					 * used for deleting the entry. */
#endif
    ClientData clientData;		/* Application stores something here
					 * with Tcl_SetHashValue. */
    union {				/* Key has one of these forms: */
	char *oneWordValue;		/* One-word value for key. */
        Tcl_Obj *objPtr;		/* Tcl_Obj * key value. */
	int words[1];			/* Multiple integer words for key.
					 * The actual size will be as large
					 * as necessary for this table's
					 * keys. */
	char string[4];			/* String for key.  The actual size
					 * will be as large as needed to hold
					 * the key. */
    } key;				/* MUST BE LAST FIELD IN RECORD!! */
};

/*
 * Flags used in Tcl_HashKeyType.
 *
 * TCL_HASH_KEY_RANDOMIZE_HASH:
 *				There are some things, pointers for example
 *				which don't hash well because they do not use
 *				the lower bits. If this flag is set then the
 *				hash table will attempt to rectify this by
 *				randomising the bits and then using the upper
 *				N bits as the index into the table.
 * TCL_HASH_KEY_SYSTEM_HASH:
 *				If this flag is set then all memory internally
 *                              allocated for the hash table that is not for an
 *                              entry will use the system heap.
 */

#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
#define TCL_HASH_KEY_SYSTEM_HASH    0x2

/*
 * Structure definition for the methods associated with a hash table
 * key type.
 */

#define TCL_HASH_KEY_TYPE_VERSION 1
struct Tcl_HashKeyType {
    int version;		/* Version of the table. If this structure is
				 * extended in future then the version can be
				 * used to distinguish between different
				 * structures. 
				 */

    int flags;			/* Flags, see above for details. */

    /* Calculates a hash value for the key. If this is NULL then the pointer

     * itself is used as a hash value.
     */
    Tcl_HashKeyProc *hashKeyProc;

    /* Compares two keys and returns zero if they do not match, and non-zero

     * if they do. If this is NULL then the pointers are compared.
     */
    Tcl_CompareHashKeysProc *compareKeysProc;

    /* Called to allocate memory for a new entry, i.e. if the key is a

     * string then this could allocate a single block which contains enough

     * space for both the entry and the string. Only the key field of the
     * allocated Tcl_HashEntry structure needs to be filled in. If something

     * else needs to be done to the key, i.e. incrementing a reference count

     * then that should be done by this function. If this is NULL then Tcl_Alloc
     * is used to allocate enough space for a Tcl_HashEntry and the key pointer

     * is assigned to key.oneWordValue.
     */
    Tcl_AllocHashEntryProc *allocEntryProc;

    /* Called to free memory associated with an entry. If something else needs

     * to be done to the key, i.e. decrementing a reference count then that

     * should be done by this function. If this is NULL then Tcl_Free is used
     * to free the Tcl_HashEntry.
     */
    Tcl_FreeHashEntryProc *freeEntryProc;
};

/*
 * Structure definition for a hash table.  Must be in tcl.h so clients
 * can allocate space for these structures, but clients should never
 * access any fields in this structure.
 */

#define TCL_SMALL_HASH_TABLE 4
struct Tcl_HashTable {
    Tcl_HashEntry **buckets;		/* Pointer to bucket array.  Each
					 * element points to first entry in
					 * bucket's hash chain, or NULL. */
    Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
					/* Bucket array used for small tables
					 * (to avoid mallocs and frees). */
    int numBuckets;			/* Total number of buckets allocated
					 * at **bucketPtr. */
    int numEntries;			/* Total number of entries present
					 * in table. */
    int rebuildSize;			/* Enlarge table when numEntries gets
					 * to be this large. */
    int downShift;			/* Shift count used in hashing
					 * function.  Designed to use high-
					 * order bits of randomized keys. */
    int mask;				/* Mask value used in hashing
					 * function. */
    int keyType;			/* Type of keys used in this table. 
					 * It's either TCL_CUSTOM_KEYS,
					 * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
					 * or an integer giving the number of
					 * ints that is the size of the key.
					 */
#if TCL_PRESERVE_BINARY_COMPATABILITY
    Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
	    CONST char *key));
    Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
	    CONST char *key, int *newPtr));
#endif
    Tcl_HashKeyType *typePtr;		/* Type of the keys used in the
					 * Tcl_HashTable. */
};

/*
 * Structure definition for information used to keep track of searches
 * through hash tables:
 */

typedef struct Tcl_HashSearch {
    Tcl_HashTable *tablePtr;		/* Table being searched. */
    int nextIndex;			/* Index of next bucket to be
					 * enumerated after present one. */
    Tcl_HashEntry *nextEntryPtr;	/* Next entry to be enumerated in the
					 * the current bucket. */
} Tcl_HashSearch;

/*
 * Acceptable key types for hash tables:
 *
 * TCL_STRING_KEYS:		The keys are strings, they are copied into
 *				the entry.
 * TCL_ONE_WORD_KEYS:		The keys are pointers, the pointer is stored
 *				in the entry.
 * TCL_CUSTOM_TYPE_KEYS:	The keys are arbitrary types which are copied
 *				into the entry.
 * TCL_CUSTOM_PTR_KEYS:		The keys are pointers to arbitrary types, the
 *				pointer is stored in the entry.
 *
 * While maintaining binary compatability the above have to be distinct
 * values as they are used to differentiate between old versions of the
 * hash table which don't have a typePtr and new ones which do. Once binary
 * compatability is discarded in favour of making more wide spread changes
 * TCL_STRING_KEYS can be the same as TCL_CUSTOM_TYPE_KEYS, and
 * TCL_ONE_WORD_KEYS can be the same as TCL_CUSTOM_PTR_KEYS because they
 * simply determine how the key is accessed from the entry and not the
 * behaviour.
 */

#define TCL_STRING_KEYS		0
#define TCL_ONE_WORD_KEYS	1

#if TCL_PRESERVE_BINARY_COMPATABILITY
#   define TCL_CUSTOM_TYPE_KEYS		-2
#   define TCL_CUSTOM_PTR_KEYS		-1
#else
#   define TCL_CUSTOM_TYPE_KEYS		TCL_STRING_KEYS
#   define TCL_CUSTOM_PTR_KEYS		TCL_ONE_WORD_KEYS
#endif

/*
 * Macros for clients to use to access fields of hash entries:
 */

#define Tcl_GetHashValue(h) ((h)->clientData)







|
|
|



>
>




















<

|
|
|

>










<

|
|
|



|
|
|
|
|
|
|


|


|
|



<

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



















<


|
|
|
|
|
|
|
<
|
|
|



|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
<



|
|
|

>


|






|
|







|
|
|

>





|
|

>




|
|
|
|
|
|
|
|

>







>




|
|

















|
|

>





|

>




















>
>
>
>
>
>
>
>
|








<
<
<
<
<
<
<
<
|
|
<
|
|

>

|

<




>





|
|
>
>
>
>
>
>
>
>




>














|
|
|
|

>





|
|
<



|
|
<
|


|
|
|
<

|


|
|
|

|
|
|
|
|
|
|
<
|
|
|
<
|





|






|
<



>




|
<

>





|
<
<

|
|
>
|
<
<
|
|
>
|
<
|
|
|
>
|
>
|
|
>
|
>
|
|
>
|
<
|
<
|
>
|
>
|
|
<
<



|
|
|




|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|






|
|



|
|



|
|
|
|
|





|
|







|
|
|
|
|
|
|
<






|
|

|
|







805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839

840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855

856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879

880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915

916
917
918
919
920
921
922
923
924

925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948

949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082








1083
1084

1085
1086
1087
1088
1089
1090
1091

1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143

1144
1145
1146
1147
1148

1149
1150
1151
1152
1153
1154

1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169

1170
1171
1172

1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186

1187
1188
1189
1190
1191
1192
1193
1194
1195

1196
1197
1198
1199
1200
1201
1202
1203


1204
1205
1206
1207
1208


1209
1210
1211
1212

1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227

1228

1229
1230
1231
1232
1233
1234


1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260

1261
1262

1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307

1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
#   define Tcl_DecrRefCount(objPtr) \
	if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
#   define Tcl_IsShared(objPtr) \
	((objPtr)->refCount > 1)
#endif

/*
 * Macros and definitions that help to debug the use of Tcl objects. When
 * TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call
 * debugging versions of the object creation functions.
 */

#ifdef TCL_MEM_DEBUG
#  define Tcl_NewBignumObj(val) \
     Tcl_DbNewBignumObj(val, __FILE__, __LINE__)
#  define Tcl_NewBooleanObj(val) \
     Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
#  define Tcl_NewByteArrayObj(bytes, len) \
     Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
#  define Tcl_NewDoubleObj(val) \
     Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
#  define Tcl_NewIntObj(val) \
     Tcl_DbNewLongObj(val, __FILE__, __LINE__)
#  define Tcl_NewListObj(objc, objv) \
     Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
#  define Tcl_NewLongObj(val) \
     Tcl_DbNewLongObj(val, __FILE__, __LINE__)
#  define Tcl_NewObj() \
     Tcl_DbNewObj(__FILE__, __LINE__)
#  define Tcl_NewStringObj(bytes, len) \
     Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
#  define Tcl_NewWideIntObj(val) \
     Tcl_DbNewWideIntObj(val, __FILE__, __LINE__)
#endif /* TCL_MEM_DEBUG */


/*
 * The following structure contains the state needed by Tcl_SaveResult. No-one
 * outside of Tcl should access any of these fields. This structure is
 * typically allocated on the stack.
 */

typedef struct Tcl_SavedResult {
    char *result;
    Tcl_FreeProc *freeProc;
    Tcl_Obj *objResultPtr;
    char *appendResult;
    int appendAvl;
    int appendUsed;
    char resultSpace[TCL_RESULT_SIZE+1];
} Tcl_SavedResult;


/*
 * The following definitions support Tcl's namespace facility. Note: the first
 * five fields must match exactly the fields in a Namespace structure (see
 * tclInt.h).
 */

typedef struct Tcl_Namespace {
    char *name;			/* The namespace's name within its parent
				 * namespace. This contains no ::'s. The name
				 * of the global namespace is "" although "::"
				 * is an synonym. */
    char *fullName;		/* The namespace's fully qualified name. This
				 * starts with ::. */
    ClientData clientData;	/* Arbitrary value associated with this
				 * namespace. */
    Tcl_NamespaceDeleteProc* deleteProc;
				/* Function invoked when deleting the
				 * namespace to, e.g., free clientData. */
    struct Tcl_Namespace* parentPtr;
				/* Points to the namespace that contains this
				 * one. NULL if this is the global
				 * namespace. */
} Tcl_Namespace;


/*
 * The following structure represents a call frame, or activation record. A
 * call frame defines a naming context for a procedure call: its local scope
 * (for local variables) and its namespace scope (used for non-local
 * variables; often the global :: namespace). A call frame can also define the
 * naming context for a namespace eval or namespace inscope command: the
 * namespace in which the command's code should execute. The Tcl_CallFrame
 * structures exist only while procedures or namespace eval/inscope's are
 * being executed, and provide a Tcl call stack.
 *
 * A call frame is initialized and pushed using Tcl_PushCallFrame and popped
 * using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be provided by the
 * Tcl_PushCallFrame caller, and callers typically allocate them on the C call
 * stack for efficiency. For this reason, Tcl_CallFrame is defined as a
 * structure and not as an opaque token. However, most Tcl_CallFrame fields
 * are hidden since applications should not access them directly; others are
 * declared as "dummyX".
 *
 * WARNING!! The structure definition must be kept consistent with the
 * CallFrame structure in tclInt.h. If you change one, change the other.
 */

typedef struct Tcl_CallFrame {
    Tcl_Namespace *nsPtr;
    int dummy1;
    int dummy2;
    char *dummy3;
    char *dummy4;
    char *dummy5;
    int dummy6;
    char *dummy7;
    char *dummy8;
    int dummy9;
    char* dummy10;
} Tcl_CallFrame;


/*
 * Information about commands that is returned by Tcl_GetCommandInfo and
 * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command
 * function while proc is a traditional Tcl argc/argv string-based function.
 * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and
 * proc are non-NULL and can be called to execute the command. However, it may
 * be faster to call one instead of the other. The member isNativeObjectProc
 * is set to 1 if an object-based function was registered by
 * Tcl_CreateObjCommand, and to 0 if a string-based function was registered by

 * Tcl_CreateCommand. The other function is typically set to a compatibility
 * wrapper that does string-to-object or object-to-string argument conversions
 * then calls the other function.
 */

typedef struct Tcl_CmdInfo {
    int isNativeObjectProc;	/* 1 if objProc was registered by a call to
				 * Tcl_CreateObjCommand; 0 otherwise.
				 * Tcl_SetCmdInfo does not modify this
				 * field. */
    Tcl_ObjCmdProc *objProc;	/* Command's object-based function. */
    ClientData objClientData;	/* ClientData for object proc. */
    Tcl_CmdProc *proc;		/* Command's string-based function. */
    ClientData clientData;	/* ClientData for string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* Function to call when command is
				 * deleted. */
    ClientData deleteData;	/* Value to pass to deleteProc (usually the
				 * same as clientData). */
    Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
				 * command. Note that Tcl_SetCmdInfo will not
				 * change a command's namespace; use
				 * TclRenameCommand or Tcl_Eval (of 'rename')
				 * to do that. */

} Tcl_CmdInfo;

/*
 * The structure defined below is used to hold dynamic strings. The only
 * fields that clients should use are string and length, accessible via the
 * macros Tcl_DStringValue and Tcl_DStringLength.
 */

#define TCL_DSTRING_STATIC_SIZE 200
typedef struct Tcl_DString {
    char *string;		/* Points to beginning of string: either
				 * staticSpace below or a malloced array. */
    int length;			/* Number of non-NULL characters in the
				 * string. */
    int spaceAvl;		/* Total number of bytes available for the
				 * string and its terminating NULL char. */
    char staticSpace[TCL_DSTRING_STATIC_SIZE];
				/* Space to use in common case where string is
				 * small. */
} Tcl_DString;

#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
#define Tcl_DStringTrunc Tcl_DStringSetLength

/*
 * Definitions for the maximum number of digits of precision that may be
 * specified in the "tcl_precision" variable, and the number of bytes of
 * buffer space required by Tcl_PrintDouble.
 */

#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)

/*
 * Definition for a number of bytes of buffer space sufficient to hold the
 * string representation of an integer in base 10 (assuming the existence of
 * 64-bit integers).
 */

#define TCL_INTEGER_SPACE	24

/*
 * Flag values passed to Tcl_ConvertElement.
 * TCL_DONT_USE_BRACES forces it not to enclose the element in braces, but to
 *	use backslash quoting instead.
 * TCL_DONT_QUOTE_HASH disables the default quoting of the '#' character. It
 *	is safe to leave the hash unquoted when the element is not the first
 *	element of a list, and this flag can be used by the caller to indicate
 *	that condition.
 * (Careful! If you change these flag values be sure to change the definitions
 * at the front of tclUtil.c).
 */

#define TCL_DONT_USE_BRACES	1
#define TCL_DONT_QUOTE_HASH	8

/*
 * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
 * abbreviated strings.
 */

#define TCL_EXACT	1

/*
 * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv.
 * WARNING: these bit choices must not conflict with the bit choices for
 * evalFlag bits in tclInt.h!
 *
 * Meanings:
 *	TCL_NO_EVAL:		Just record this command
 *	TCL_EVAL_GLOBAL:	Execute script in global namespace
 *	TCL_EVAL_DIRECT:	Do not compile this script
 *	TCL_EVAL_INVOKE:	Magical Tcl_EvalObjv mode for aliases/ensembles
 *				o Run in global namespace
 *				o Cut out of error traces
 *				o Don't reset the flags controlling ensemble
 *				  error message rewriting.
 */
#define TCL_NO_EVAL		0x10000
#define TCL_EVAL_GLOBAL		0x20000
#define TCL_EVAL_DIRECT		0x40000
#define TCL_EVAL_INVOKE		0x80000

/*
 * Special freeProc values that may be passed to Tcl_SetResult (see the man
 * page for details):
 */

#define TCL_VOLATILE	((Tcl_FreeProc *) 1)
#define TCL_STATIC	((Tcl_FreeProc *) 0)
#define TCL_DYNAMIC	((Tcl_FreeProc *) 3)

/*
 * Flag values passed to variable-related functions.
 */

#define TCL_GLOBAL_ONLY		 1
#define TCL_NAMESPACE_ONLY	 2
#define TCL_APPEND_VALUE	 4
#define TCL_LIST_ELEMENT	 8
#define TCL_TRACE_READS		 0x10
#define TCL_TRACE_WRITES	 0x20
#define TCL_TRACE_UNSETS	 0x40
#define TCL_TRACE_DESTROYED	 0x80
#define TCL_INTERP_DESTROYED	 0x100
#define TCL_LEAVE_ERR_MSG	 0x200
#define TCL_TRACE_ARRAY		 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
/* Required to support old variable/vdelete/vinfo traces */
#define TCL_TRACE_OLD_STYLE	 0x1000
#endif
/* Indicate the semantics of the result of a trace */
#define TCL_TRACE_RESULT_DYNAMIC 0x8000
#define TCL_TRACE_RESULT_OBJECT  0x10000

/*
 * Flag values for ensemble commands.
 */

#define TCL_ENSEMBLE_PREFIX 0x02/* Flag value to say whether to allow
				 * unambiguous prefixes of commands or to
				 * require exact matches for command names. */

/*
 * Flag values passed to command-related functions.
 */

#define TCL_TRACE_RENAME 0x2000
#define TCL_TRACE_DELETE 0x4000

#define TCL_ALLOW_INLINE_COMPILATION 0x20000

/*








 * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now
 * always parsed whenever the part2 is NULL. (This is to avoid a common error

 * when converting code to use the new object based APIs and forgetting to
 * give the flag)
 */

#ifndef TCL_NO_DEPRECATED
#   define TCL_PARSE_PART1	0x400
#endif


/*
 * Types for linked variables:
 */

#define TCL_LINK_INT		1
#define TCL_LINK_DOUBLE		2
#define TCL_LINK_BOOLEAN	3
#define TCL_LINK_STRING		4
#define TCL_LINK_WIDE_INT	5
#define TCL_LINK_CHAR		6
#define TCL_LINK_UCHAR		7
#define TCL_LINK_SHORT		8
#define TCL_LINK_USHORT		9
#define TCL_LINK_UINT		10
#define TCL_LINK_LONG		11
#define TCL_LINK_ULONG		12
#define TCL_LINK_FLOAT		13
#define TCL_LINK_WIDE_UINT	14
#define TCL_LINK_READ_ONLY	0x80

/*
 * Forward declarations of Tcl_HashTable and related types.
 */

typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;

typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
	VOID *keyPtr));
typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr,
	Tcl_HashEntry *hPtr));
typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_((
	Tcl_HashTable *tablePtr, VOID *keyPtr));
typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr));

/*
 * This flag controls whether the hash table stores the hash of a key, or
 * recalculates it. There should be no reason for turning this flag off as it
 * is completely binary and source compatible unless you directly access the
 * bucketPtr member of the Tcl_HashTableEntry structure. This member has been
 * removed and the space used to store the hash value.
 */

#ifndef TCL_HASH_KEY_STORE_HASH
#   define TCL_HASH_KEY_STORE_HASH 1
#endif

/*
 * Structure definition for an entry in a hash table. No-one outside Tcl
 * should access any of these fields directly; use the macros defined below.

 */

struct Tcl_HashEntry {
    Tcl_HashEntry *nextPtr;	/* Pointer to next entry in this hash bucket,
				 * or NULL for end of chain. */

    Tcl_HashTable *tablePtr;	/* Pointer to table containing entry. */
#if TCL_HASH_KEY_STORE_HASH
#   if TCL_PRESERVE_BINARY_COMPATABILITY
    VOID *hash;			/* Hash value, stored as pointer to ensure
				 * that the offsets of the fields in this
				 * structure are not changed. */

#   else
    unsigned int hash;		/* Hash value. */
#   endif
#else
    Tcl_HashEntry **bucketPtr;	/* Pointer to bucket that points to first
				 * entry in this entry's chain: used for
				 * deleting the entry. */
#endif
    ClientData clientData;	/* Application stores something here with
				 * Tcl_SetHashValue. */
    union {			/* Key has one of these forms: */
	char *oneWordValue;	/* One-word value for key. */
	Tcl_Obj *objPtr;	/* Tcl_Obj * key value. */
	int words[1];		/* Multiple integer words for key. The actual
				 * size will be as large as necessary for this

				 * table's keys. */
	char string[4];		/* String for key. The actual size will be as
				 * large as needed to hold the key. */

    } key;			/* MUST BE LAST FIELD IN RECORD!! */
};

/*
 * Flags used in Tcl_HashKeyType.
 *
 * TCL_HASH_KEY_RANDOMIZE_HASH -
 *				There are some things, pointers for example
 *				which don't hash well because they do not use
 *				the lower bits. If this flag is set then the
 *				hash table will attempt to rectify this by
 *				randomising the bits and then using the upper
 *				N bits as the index into the table.
 * TCL_HASH_KEY_SYSTEM_HASH -	If this flag is set then all memory internally

 *                              allocated for the hash table that is not for an
 *                              entry will use the system heap.
 */

#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
#define TCL_HASH_KEY_SYSTEM_HASH    0x2

/*
 * Structure definition for the methods associated with a hash table key type.

 */

#define TCL_HASH_KEY_TYPE_VERSION 1
struct Tcl_HashKeyType {
    int version;		/* Version of the table. If this structure is
				 * extended in future then the version can be
				 * used to distinguish between different
				 * structures. */


    int flags;			/* Flags, see above for details. */
    Tcl_HashKeyProc *hashKeyProc;
				/* Calculates a hash value for the key. If
				 * this is NULL then the pointer itself is
				 * used as a hash value. */


    Tcl_CompareHashKeysProc *compareKeysProc;
				/* Compares two keys and returns zero if they
				 * do not match, and non-zero if they do. If
				 * this is NULL then the pointers are

				 * compared. */
    Tcl_AllocHashEntryProc *allocEntryProc;
				/* Called to allocate memory for a new entry,
				 * i.e. if the key is a string then this could
				 * allocate a single block which contains
				 * enough space for both the entry and the
				 * string. Only the key field of the allocated
				 * Tcl_HashEntry structure needs to be filled
				 * in. If something else needs to be done to
				 * the key, i.e. incrementing a reference
				 * count then that should be done by this
				 * function. If this is NULL then Tcl_Alloc is
				 * used to allocate enough space for a
				 * Tcl_HashEntry and the key pointer is
				 * assigned to key.oneWordValue. */

    Tcl_FreeHashEntryProc *freeEntryProc;

				/* Called to free memory associated with an
				 * entry. If something else needs to be done
				 * to the key, i.e. decrementing a reference
				 * count then that should be done by this
				 * function. If this is NULL then Tcl_Free is
				 * used to free the Tcl_HashEntry. */


};

/*
 * Structure definition for a hash table.  Must be in tcl.h so clients can
 * allocate space for these structures, but clients should never access any
 * fields in this structure.
 */

#define TCL_SMALL_HASH_TABLE 4
struct Tcl_HashTable {
    Tcl_HashEntry **buckets;	/* Pointer to bucket array. Each element
				 * points to first entry in bucket's hash
				 * chain, or NULL. */
    Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
				/* Bucket array used for small tables (to
				 * avoid mallocs and frees). */
    int numBuckets;		/* Total number of buckets allocated at
				 * **bucketPtr. */
    int numEntries;		/* Total number of entries present in
				 * table. */
    int rebuildSize;		/* Enlarge table when numEntries gets to be
				 * this large. */
    int downShift;		/* Shift count used in hashing function.
				 * Designed to use high-order bits of
				 * randomized keys. */
    int mask;			/* Mask value used in hashing function. */

    int keyType;		/* Type of keys used in this table. It's
				 * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,

				 * TCL_ONE_WORD_KEYS, or an integer giving the
				 * number of ints that is the size of the
				 * key. */
#if TCL_PRESERVE_BINARY_COMPATABILITY
    Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
	    CONST char *key));
    Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
	    CONST char *key, int *newPtr));
#endif
    Tcl_HashKeyType *typePtr;	/* Type of the keys used in the
				 * Tcl_HashTable. */
};

/*
 * Structure definition for information used to keep track of searches through
 * hash tables:
 */

typedef struct Tcl_HashSearch {
    Tcl_HashTable *tablePtr;	/* Table being searched. */
    int nextIndex;		/* Index of next bucket to be enumerated after
				 * present one. */
    Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current
				 * bucket. */
} Tcl_HashSearch;

/*
 * Acceptable key types for hash tables:
 *
 * TCL_STRING_KEYS:		The keys are strings, they are copied into the
 *				entry.
 * TCL_ONE_WORD_KEYS:		The keys are pointers, the pointer is stored
 *				in the entry.
 * TCL_CUSTOM_TYPE_KEYS:	The keys are arbitrary types which are copied
 *				into the entry.
 * TCL_CUSTOM_PTR_KEYS:		The keys are pointers to arbitrary types, the
 *				pointer is stored in the entry.
 *
 * While maintaining binary compatability the above have to be distinct values
 * as they are used to differentiate between old versions of the hash table
 * which don't have a typePtr and new ones which do. Once binary compatability
 * is discarded in favour of making more wide spread changes TCL_STRING_KEYS
 * can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the
 * same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is
 * accessed from the entry and not the behaviour.

 */

#define TCL_STRING_KEYS		0
#define TCL_ONE_WORD_KEYS	1

#if TCL_PRESERVE_BINARY_COMPATABILITY
#   define TCL_CUSTOM_TYPE_KEYS	-2
#   define TCL_CUSTOM_PTR_KEYS	-1
#else
#   define TCL_CUSTOM_TYPE_KEYS	TCL_STRING_KEYS
#   define TCL_CUSTOM_PTR_KEYS	TCL_ONE_WORD_KEYS
#endif

/*
 * Macros for clients to use to access fields of hash entries:
 */

#define Tcl_GetHashValue(h) ((h)->clientData)
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355

1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371

1372
1373
1374
1375
1376
1377
1378
1379

1380
1381
1382
1383
1384
1385
1386
1387

1388
1389
1390
1391
1392
1393
1394
1395
1396

1397
1398
1399
1400
1401
1402
1403
1404



1405



1406
1407
1408
1409

1410
1411
1412
1413
1414
1415
1416
1417
1418

1419
1420
1421
1422
1423
1424
1425
1426
1427

1428
1429
1430
1431
1432
1433
1434

1435
1436
1437
1438
1439

1440
1441
1442








1443
1444
1445
1446

1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477









1478
1479
1480
1481
1482
1483

1484
1485
1486
1487
1488
1489
1490

1491
1492
1493
1494
1495
1496
1497
1498

1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519

1520
1521
1522
1523
1524

1525
1526
1527
1528
1529
1530
1531
1532
1533

1534
1535
1536
1537
1538
1539

1540
1541
1542
1543
1544

1545
1546
1547
1548
1549
1550
1551
1552
1553
1554

1555
1556

1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567













1568
1569
1570
1571
1572
1573
1574

1575
1576
1577
1578
1579
1580
1581

1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592

1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606

1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624

1625
1626
1627
1628
1629
1630

1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686

1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851





1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
1900
1901
1902
1903
1904

1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920

1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973

1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988

1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023



2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078

2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093

2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108

2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119

2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197

2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213

2214
2215
2216
2217
2218
2219
2220
2221

2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232

2233
2234
2235
2236
2237
2238
2239

2240

2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260








2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
#   define Tcl_GetHashKey(tablePtr, h) \
	((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \
		   ? (h)->key.oneWordValue \
		   : (h)->key.string))
#endif

/*
 * Macros to use for clients to use to invoke find and create procedures
 * for hash tables:
 */

#if TCL_PRESERVE_BINARY_COMPATABILITY
#   define Tcl_FindHashEntry(tablePtr, key) \
	(*((tablePtr)->findProc))(tablePtr, key)
#   define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
	(*((tablePtr)->createProc))(tablePtr, key, newPtr)
#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */
/*
 * Macro to use new extended version of Tcl_InitHashTable.
 */
#   define Tcl_InitHashTable(tablePtr, keyType) \
	Tcl_InitHashTableEx(tablePtr, keyType, NULL)
#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */

/*
 * Structure definition for information used to keep track of searches
 * through dictionaries.  These fields should not be accessed by code
 * outside tclDictObj.c
 */

typedef struct {
    Tcl_HashSearch search;	/* Search struct for underlying hash table. */
    int epoch;			/* Epoch marker for dictionary being searched,
				 * or -1 if search has terminated. */
    Tcl_Dict dictionaryPtr;	/* Reference to dictionary being searched. */
} Tcl_DictSearch;


/*
 * Flag values to pass to Tcl_DoOneEvent to disable searches
 * for some kinds of events:
 */

#define TCL_DONT_WAIT		(1<<1)
#define TCL_WINDOW_EVENTS	(1<<2)
#define TCL_FILE_EVENTS		(1<<3)
#define TCL_TIMER_EVENTS	(1<<4)
#define TCL_IDLE_EVENTS		(1<<5)	/* WAS 0x10 ???? */
#define TCL_ALL_EVENTS		(~TCL_DONT_WAIT)

/*
 * The following structure defines a generic event for the Tcl event
 * system.  These are the things that are queued in calls to Tcl_QueueEvent
 * and serviced later by Tcl_DoOneEvent.  There can be many different
 * kinds of events with different fields, corresponding to window events,
 * timer events, etc.  The structure for a particular event consists of
 * a Tcl_Event header followed by additional information specific to that
 * event.
 */

struct Tcl_Event {
    Tcl_EventProc *proc;	/* Procedure to call to service this event. */
    struct Tcl_Event *nextPtr;	/* Next in list of pending events, or NULL. */
};

/*
 * Positions to pass to Tcl_QueueEvent:
 */

typedef enum {
    TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
} Tcl_QueuePosition;

/*
 * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
 * event routines.
 */

#define TCL_SERVICE_NONE 0
#define TCL_SERVICE_ALL 1


/*
 * The following structure keeps is used to hold a time value, either as
 * an absolute time (the number of seconds from the epoch) or as an
 * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
 */

typedef struct Tcl_Time {
    long sec;			/* Seconds. */
    long usec;			/* Microseconds. */
} Tcl_Time;

typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr));
typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr));








/*
 * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler
 * to indicate what sorts of events are of interest:
 */

#define TCL_READABLE	(1<<1)
#define TCL_WRITABLE	(1<<2)
#define TCL_EXCEPTION	(1<<3)

/*
 * Flag values to pass to Tcl_OpenCommandChannel to indicate the
 * disposition of the stdio handles.  TCL_STDIN, TCL_STDOUT, TCL_STDERR,
 * are also used in Tcl_GetStdChannel.
 */

#define TCL_STDIN		(1<<1)	
#define TCL_STDOUT		(1<<2)
#define TCL_STDERR		(1<<3)
#define TCL_ENFORCE_MODE	(1<<4)

/*
 * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel
 * should be closed.
 */

#define TCL_CLOSE_READ	(1<<1)
#define TCL_CLOSE_WRITE	(1<<2)

/*
 * Value to use as the closeProc for a channel that supports the
 * close2Proc interface.
 */

#define TCL_CLOSE2PROC	((Tcl_DriverCloseProc *)1)

/*
 * Channel version tag.  This was introduced in 8.3.2/8.4.
 */

#define TCL_CHANNEL_VERSION_1	((Tcl_ChannelTypeVersion) 0x1)
#define TCL_CHANNEL_VERSION_2	((Tcl_ChannelTypeVersion) 0x2)
#define TCL_CHANNEL_VERSION_3	((Tcl_ChannelTypeVersion) 0x3)









/*
 * Typedefs for the various operations in a channel type:
 */

typedef int	(Tcl_DriverBlockModeProc) _ANSI_ARGS_((
		    ClientData instanceData, int mode));
typedef int	(Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
		    Tcl_Interp *interp));
typedef int	(Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData,
		    Tcl_Interp *interp, int flags));
typedef int	(Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
		    char *buf, int toRead, int *errorCodePtr));
typedef int	(Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
		    CONST84 char *buf, int toWrite, int *errorCodePtr));
typedef int	(Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
		    long offset, int mode, int *errorCodePtr));
typedef int	(Tcl_DriverSetOptionProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_Interp *interp,
	            CONST char *optionName, CONST char *value));
typedef int	(Tcl_DriverGetOptionProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_Interp *interp,
		    CONST84 char *optionName, Tcl_DString *dsPtr));
typedef void	(Tcl_DriverWatchProc) _ANSI_ARGS_((
		    ClientData instanceData, int mask));
typedef int	(Tcl_DriverGetHandleProc) _ANSI_ARGS_((
		    ClientData instanceData, int direction,
		    ClientData *handlePtr));
typedef int	(Tcl_DriverFlushProc) _ANSI_ARGS_((
		    ClientData instanceData));
typedef int	(Tcl_DriverHandlerProc) _ANSI_ARGS_((
		    ClientData instanceData, int interestMask));
typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_WideInt offset,
		    int mode, int *errorCodePtr));











/*
 * The following declarations either map ckalloc and ckfree to
 * malloc and free, or they map them to procedures with all sorts
 * of debugging hooks defined in tclCkalloc.c.
 */

#ifdef TCL_MEM_DEBUG

#   define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
#   define ckfree(x)  Tcl_DbCkfree(x, __FILE__, __LINE__)
#   define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
#   define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
#   define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)

#else /* !TCL_MEM_DEBUG */

/*
 * If we are not using the debugging allocator, we should call the 
 * Tcl_Alloc, et al. routines in order to guarantee that every module
 * is using the same memory allocator both inside and outside of the
 * Tcl library.
 */

#   define ckalloc(x) Tcl_Alloc(x)
#   define ckfree(x) Tcl_Free(x)
#   define ckrealloc(x,y) Tcl_Realloc(x,y)
#   define attemptckalloc(x) Tcl_AttemptAlloc(x)
#   define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
#   define Tcl_InitMemory(x)
#   define Tcl_DumpActiveMemory(x)
#   define Tcl_ValidateAllMemory(x,y)

#endif /* !TCL_MEM_DEBUG */

/*
 * struct Tcl_ChannelType:
 *
 * One such structure exists for each type (kind) of channel.
 * It collects together in one place all the functions that are
 * part of the specific channel type.
 *
 * It is recommend that the Tcl_Channel* functions are used to access
 * elements of this structure, instead of direct accessing.
 */

typedef struct Tcl_ChannelType {
    char *typeName;			/* The name of the channel type in Tcl
                                         * commands. This storage is owned by
                                         * channel type. */
    Tcl_ChannelTypeVersion version;	/* Version of the channel type. */

    Tcl_DriverCloseProc *closeProc;	/* Procedure to call to close the
					 * channel, or TCL_CLOSE2PROC if the
					 * close2Proc should be used
					 * instead. */
    Tcl_DriverInputProc *inputProc;	/* Procedure to call for input
					 * on channel. */
    Tcl_DriverOutputProc *outputProc;	/* Procedure to call for output
					 * on channel. */
    Tcl_DriverSeekProc *seekProc;	/* Procedure to call to seek

					 * on the channel. May be NULL. */
    Tcl_DriverSetOptionProc *setOptionProc;
					/* Set an option on a channel. */
    Tcl_DriverGetOptionProc *getOptionProc;
					/* Get an option from a channel. */
    Tcl_DriverWatchProc *watchProc;	/* Set up the notifier to watch

					 * for events on this channel. */
    Tcl_DriverGetHandleProc *getHandleProc;
					/* Get an OS handle from the channel
					 * or NULL if not supported. */
    Tcl_DriverClose2Proc *close2Proc;	/* Procedure to call to close the

					 * channel if the device supports
					 * closing the read & write sides
					 * independently. */
    Tcl_DriverBlockModeProc *blockModeProc;
					/* Set blocking mode for the
					 * raw channel. May be NULL. */
    /*
     * Only valid in TCL_CHANNEL_VERSION_2 channels or later
     */
    Tcl_DriverFlushProc *flushProc;	/* Procedure to call to flush a

					 * channel. May be NULL. */
    Tcl_DriverHandlerProc *handlerProc;	/* Procedure to call to handle a

					 * channel event.  This will be passed
					 * up the stacked channel chain. */
    /*
     * Only valid in TCL_CHANNEL_VERSION_3 channels or later
     */
    Tcl_DriverWideSeekProc *wideSeekProc;
					/* Procedure to call to seek
					 * on the channel which can
					 * handle 64-bit offsets. May be
					 * NULL, and must be NULL if
					 * seekProc is NULL. */













} Tcl_ChannelType;

/*
 * The following flags determine whether the blockModeProc above should
 * set the channel into blocking or nonblocking mode. They are passed
 * as arguments to the blockModeProc procedure in the above structure.
 */

#define TCL_MODE_BLOCKING	0	/* Put channel into blocking mode. */
#define TCL_MODE_NONBLOCKING	1	/* Put channel into nonblocking
					 * mode. */

/*
 * Enum for different types of file paths.
 */

typedef enum Tcl_PathType {
    TCL_PATH_ABSOLUTE,
    TCL_PATH_RELATIVE,
    TCL_PATH_VOLUME_RELATIVE
} Tcl_PathType;


/* 
 * The following structure is used to pass glob type data amongst
 * the various glob routines and Tcl_FSMatchInDirectory.
 */

typedef struct Tcl_GlobTypeData {
    /* Corresponds to bcdpfls as in 'find -t' */
    int type;
    /* Corresponds to file permissions */
    int perm;
    /* Acceptable mac type */
    Tcl_Obj* macType;
    /* Acceptable mac creator */
    Tcl_Obj* macCreator;
} Tcl_GlobTypeData;

/*
 * type and permission definitions for glob command
 */

#define TCL_GLOB_TYPE_BLOCK		(1<<0)
#define TCL_GLOB_TYPE_CHAR		(1<<1)
#define TCL_GLOB_TYPE_DIR		(1<<2)
#define TCL_GLOB_TYPE_PIPE		(1<<3)
#define TCL_GLOB_TYPE_FILE		(1<<4)
#define TCL_GLOB_TYPE_LINK		(1<<5)
#define TCL_GLOB_TYPE_SOCK		(1<<6)
#define TCL_GLOB_TYPE_MOUNT		(1<<7)

#define TCL_GLOB_PERM_RONLY		(1<<0)
#define TCL_GLOB_PERM_HIDDEN		(1<<1)
#define TCL_GLOB_PERM_R			(1<<2)
#define TCL_GLOB_PERM_W			(1<<3)
#define TCL_GLOB_PERM_X			(1<<4)

/*
 * Flags for the unload callback procedure
 */

#define TCL_UNLOAD_DETACH_FROM_INTERPRETER   (1<<0)
#define TCL_UNLOAD_DETACH_FROM_PROCESS       (1<<1)

/*
 * Typedefs for the various filesystem operations:
 */

typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) 
	_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, 
	int mode, int permissions));
typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, 
	Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, 
	Tcl_GlobTypeData * types));
typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
					   Tcl_StatBuf *buf));
typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
	   Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
			    Tcl_Obj *destPathPtr));
typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
			    int recursive, Tcl_Obj **errorPtr));
typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
			    Tcl_Obj *destPathPtr));
typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
/* We have to declare the utime structure here. */
struct utimbuf;
typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
					   struct utimbuf *tval));
typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, 
			 Tcl_Obj *pathPtr, int nextCheckpoint));
typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
			    int index, Tcl_Obj *pathPtr,
			    Tcl_Obj **objPtrRef));
typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    Tcl_Obj** objPtrRef));
typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
			    int index, Tcl_Obj *pathPtr,
			    Tcl_Obj *objPtr));
typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
					       Tcl_Obj *toPtr, int linkType));
typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, 
			    Tcl_Obj *pathPtr,
			    Tcl_LoadHandle *handlePtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr));
typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    ClientData *clientDataPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) 
			    _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) 
			    _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
typedef ClientData (Tcl_FSDupInternalRepProc) 
			    _ANSI_ARGS_((ClientData clientData));
typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) 
			    _ANSI_ARGS_((ClientData clientData));
typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));


typedef struct Tcl_FSVersion_ *Tcl_FSVersion;

/*
 *----------------------------------------------------------------
 * Data structures related to hooking into the filesystem
 *----------------------------------------------------------------
 */

/*
 * Filesystem version tag.  This was introduced in 8.4.
 */
#define TCL_FILESYSTEM_VERSION_1	((Tcl_FSVersion) 0x1)

/*
 * struct Tcl_Filesystem:
 *
 * One such structure exists for each type (kind) of filesystem.
 * It collects together in one place all the functions that are
 * part of the specific filesystem.  Tcl always accesses the
 * filesystem through one of these structures.
 * 
 * Not all entries need be non-NULL; any which are NULL are simply
 * ignored.  However, a complete filesystem should provide all of
 * these functions.  The explanations in the structure show
 * the importance of each function.
 */

typedef struct Tcl_Filesystem {
    CONST char *typeName;   /* The name of the filesystem. */
    int structureLength;    /* Length of this structure, so future
			     * binary compatibility can be assured. */
    Tcl_FSVersion version;  
			    /* Version of the filesystem type. */
    Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
			    /* Function to check whether a path is in 
			     * this filesystem.  This is the most
			     * important filesystem procedure. */
    Tcl_FSDupInternalRepProc *dupInternalRepProc;
			    /* Function to duplicate internal fs rep.  May
			     * be NULL (but then fs is less efficient). */ 
    Tcl_FSFreeInternalRepProc *freeInternalRepProc;
			    /* Function to free internal fs rep.  Must
			     * be implemented, if internal representations
			     * need freeing, otherwise it can be NULL. */ 
    Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
			    /* Function to convert internal representation
			     * to a normalized path.  Only required if
			     * the fs creates pure path objects with no
			     * string/path representation. */
    Tcl_FSCreateInternalRepProc *createInternalRepProc;
			    /* Function to create a filesystem-specific
			     * internal representation.  May be NULL
			     * if paths have no internal representation, 
			     * or if the Tcl_FSPathInFilesystemProc
			     * for this filesystem always immediately 
			     * creates an internal representation for 
			     * paths it accepts. */
    Tcl_FSNormalizePathProc *normalizePathProc;       
			    /* Function to normalize a path.  Should
			     * be implemented for all filesystems
			     * which can have multiple string 
			     * representations for the same path 
			     * object. */
    Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
			    /* Function to determine the type of a 
			     * path in this filesystem.  May be NULL. */
    Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
			    /* Function to return the separator 
			     * character(s) for this filesystem.  Must
			     * be implemented. */
    Tcl_FSStatProc *statProc; 
			    /* 
			     * Function to process a 'Tcl_FSStat()'
			     * call.  Must be implemented for any
			     * reasonable filesystem.
			     */
    Tcl_FSAccessProc *accessProc;	    
			    /* 
			     * Function to process a 'Tcl_FSAccess()'
			     * call.  Must be implemented for any
			     * reasonable filesystem.
			     */
    Tcl_FSOpenFileChannelProc *openFileChannelProc; 
			    /* 
			     * Function to process a
			     * 'Tcl_FSOpenFileChannel()' call.  Must be
			     * implemented for any reasonable
			     * filesystem.
			     */
    Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;  
			    /* Function to process a 
			     * 'Tcl_FSMatchInDirectory()'.  If not
			     * implemented, then glob and recursive
			     * copy functionality will be lacking in
			     * the filesystem. */
    Tcl_FSUtimeProc *utimeProc;       
			    /* Function to process a 
			     * 'Tcl_FSUtime()' call.  Required to
			     * allow setting (not reading) of times 
			     * with 'file mtime', 'file atime' and
			     * the open-r/open-w/fcopy implementation
			     * of 'file copy'. */
    Tcl_FSLinkProc *linkProc; 
			    /* Function to process a 
			     * 'Tcl_FSLink()' call.  Should be
			     * implemented only if the filesystem supports
			     * links (reading or creating). */
    Tcl_FSListVolumesProc *listVolumesProc;
			    /* Function to list any filesystem volumes 
			     * added by this filesystem.  Should be
			     * implemented only if the filesystem adds
			     * volumes at the head of the filesystem. */
    Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
			    /* Function to list all attributes strings 
			     * which are valid for this filesystem.  
			     * If not implemented the filesystem will
			     * not support the 'file attributes' command.
			     * This allows arbitrary additional information
			     * to be attached to files in the filesystem. */
    Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
			    /* Function to process a 
			     * 'Tcl_FSFileAttrsGet()' call, used by
			     * 'file attributes'. */
    Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
			    /* Function to process a 
			     * 'Tcl_FSFileAttrsSet()' call, used by
			     * 'file attributes'.  */
    Tcl_FSCreateDirectoryProc *createDirectoryProc;	    
			    /* Function to process a 
			     * 'Tcl_FSCreateDirectory()' call. Should
			     * be implemented unless the FS is
			     * read-only. */
    Tcl_FSRemoveDirectoryProc *removeDirectoryProc;	    
			    /* Function to process a 
			     * 'Tcl_FSRemoveDirectory()' call. Should
			     * be implemented unless the FS is
			     * read-only. */
    Tcl_FSDeleteFileProc *deleteFileProc;	    
			    /* Function to process a 
			     * 'Tcl_FSDeleteFile()' call.  Should
			     * be implemented unless the FS is
			     * read-only. */
    Tcl_FSCopyFileProc *copyFileProc; 
			    /* Function to process a 
			     * 'Tcl_FSCopyFile()' call.  If not
			     * implemented Tcl will fall back
			     * on open-r, open-w and fcopy as
			     * a copying mechanism, for copying
			     * actions initiated in Tcl (not C). */
    Tcl_FSRenameFileProc *renameFileProc;	    
			    /* Function to process a 
			     * 'Tcl_FSRenameFile()' call.  If not
			     * implemented, Tcl will fall back on
			     * a copy and delete mechanism, for 
			     * rename actions initiated in Tcl (not C). */
    Tcl_FSCopyDirectoryProc *copyDirectoryProc;	    
			    /* Function to process a 
			     * 'Tcl_FSCopyDirectory()' call.  If
			     * not implemented, Tcl will fall back
			     * on a recursive create-dir, file copy
			     * mechanism, for copying actions
			     * initiated in Tcl (not C). */
    Tcl_FSLstatProc *lstatProc;	    
			    /* Function to process a 





			     * 'Tcl_FSLstat()' call.  If not implemented,
			     * Tcl will attempt to use the 'statProc'
			     * defined above instead. */
    Tcl_FSLoadFileProc *loadFileProc; 
			    /* Function to process a 
			     * 'Tcl_FSLoadFile()' call.  If not
			     * implemented, Tcl will fall back on
			     * a copy to native-temp followed by a 
			     * Tcl_FSLoadFile on that temporary copy. */
    Tcl_FSGetCwdProc *getCwdProc;     
			    /* 
			     * Function to process a 'Tcl_FSGetCwd()'
			     * call.  Most filesystems need not
			     * implement this.  It will usually only be
			     * called once, if 'getcwd' is called
			     * before 'chdir'.  May be NULL.
			     */
    Tcl_FSChdirProc *chdirProc;	    
			    /* 
			     * Function to process a 'Tcl_FSChdir()'
			     * call.  If filesystems do not implement
			     * this, it will be emulated by a series of
			     * directory access checks.  Otherwise,
			     * virtual filesystems which do implement
			     * it need only respond with a positive
			     * return result if the dirName is a valid
			     * directory in their filesystem.  They
			     * need not remember the result, since that
			     * will be automatically remembered for use
			     * by GetCwd.  Real filesystems should
			     * carry out the correct action (i.e. call
			     * the correct system 'chdir' api).  If not
			     * implemented, then 'cd' and 'pwd' will
			     * fail inside the filesystem.
			     */
} Tcl_Filesystem;

/*
 * The following definitions are used as values for the 'linkAction' flag
 * to Tcl_FSLink, or the linkProc of any filesystem.  Any combination
 * of flags can be given.  For link creation, the linkProc should create
 * a link which matches any of the types given.
 * 
 * TCL_CREATE_SYMBOLIC_LINK:  Create a symbolic or soft link.
 * TCL_CREATE_HARD_LINK:      Create a hard link.
 */

#define TCL_CREATE_SYMBOLIC_LINK   0x01
#define TCL_CREATE_HARD_LINK       0x02

/*
 * The following structure represents the Notifier functions that
 * you can override with the Tcl_SetNotifier call.
 */

typedef struct Tcl_NotifierProcs {
    Tcl_SetTimerProc *setTimerProc;
    Tcl_WaitForEventProc *waitForEventProc;
    Tcl_CreateFileHandlerProc *createFileHandlerProc;
    Tcl_DeleteFileHandlerProc *deleteFileHandlerProc;
    Tcl_InitNotifierProc *initNotifierProc;
    Tcl_FinalizeNotifierProc *finalizeNotifierProc;
    Tcl_AlertNotifierProc *alertNotifierProc;
    Tcl_ServiceModeHookProc *serviceModeHookProc;
} Tcl_NotifierProcs;


/*
 * The following structure represents a user-defined encoding.  It collects
 * together all the functions that are used by the specific encoding.
 */

typedef struct Tcl_EncodingType {
    CONST char *encodingName;	/* The name of the encoding, e.g.  "euc-jp".
				 * This name is the unique key for this
				 * encoding type. */
    Tcl_EncodingConvertProc *toUtfProc;
				/* Procedure to convert from external
				 * encoding into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Procedure to convert from UTF-8 into
				 * external encoding. */
    Tcl_EncodingFreeProc *freeProc;
				/* If non-NULL, procedure to call when this
				 * encoding is deleted. */
    ClientData clientData;	/* Arbitrary value associated with encoding
				 * type.  Passed to conversion procedures. */
    int nullSize;		/* Number of zero bytes that signify
				 * end-of-string in this encoding.  This
				 * number is used to determine the source
				 * string length when the srcLen argument is
				 * negative.  Must be 1 or 2. */
} Tcl_EncodingType;    

/*
 * The following definitions are used as values for the conversion control
 * flags argument when converting text from one character set to another:
 *
 * TCL_ENCODING_START:	     	Signifies that the source buffer is the first
 *				block in a (potentially multi-block) input
 *				stream.  Tells the conversion procedure to
 *				reset to an initial state and perform any
 *				initialization that needs to occur before the
 *				first byte is converted.  If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.
 *
 * TCL_ENCODING_END:		Signifies that the source buffer is the last
 *				block in a (potentially multi-block) input
 *				stream.  Tells the conversion routine to
 *				perform any finalization that needs to occur
 *				after the last byte is converted and then to
 *				reset to an initial state.  If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.
 *				
 * TCL_ENCODING_STOPONERROR:	If set, then the converter will return
 *				immediately upon encountering an invalid
 *				byte sequence or a source character that has
 *				no mapping in the target encoding.  If clear,
 *				then the converter will skip the problem,
 *				substituting one or more "close" characters
 *				in the destination buffer and then continue
 *				to sonvert the source.
 */

#define TCL_ENCODING_START		0x01
#define TCL_ENCODING_END		0x02
#define TCL_ENCODING_STOPONERROR	0x04


/*
 * The following data structures and declarations are for the new Tcl
 * parser.
 */

/*
 * For each word of a command, and for each piece of a word such as a
 * variable reference, one of the following structures is created to
 * describe the token.
 */

typedef struct Tcl_Token {
    int type;			/* Type of token, such as TCL_TOKEN_WORD;
				 * see below for valid types. */
    CONST char *start;		/* First character in token. */
    int size;			/* Number of bytes in token. */
    int numComponents;		/* If this token is composed of other
				 * tokens, this field tells how many of
				 * them there are (including components of
				 * components, etc.).  The component tokens
				 * immediately follow this one. */
} Tcl_Token;

/*
 * Type values defined for Tcl_Token structures.  These values are
 * defined as mask bits so that it's easy to check for collections of
 * types.
 *
 * TCL_TOKEN_WORD -		The token describes one word of a command,
 *				from the first non-blank character of
 *				the word (which may be " or {) up to but
 *				not including the space, semicolon, or
 *				bracket that terminates the word. 
 *				NumComponents counts the total number of
 *				sub-tokens that make up the word.  This
 *				includes, for example, sub-tokens of
 *				TCL_TOKEN_VARIABLE tokens.
 * TCL_TOKEN_SIMPLE_WORD -	This token is just like TCL_TOKEN_WORD
 *				except that the word is guaranteed to
 *				consist of a single TCL_TOKEN_TEXT
 *				sub-token.
 * TCL_TOKEN_TEXT -		The token describes a range of literal
 *				text that is part of a word. 
 *				NumComponents is always 0.
 * TCL_TOKEN_BS -		The token describes a backslash sequence
 *				that must be collapsed.	 NumComponents



 *				is always 0.
 * TCL_TOKEN_COMMAND -		The token describes a command whose result
 *				must be substituted into the word.  The
 *				token includes the enclosing brackets. 
 *				NumComponents is always 0.
 * TCL_TOKEN_VARIABLE -		The token describes a variable
 *				substitution, including the dollar sign,
 *				variable name, and array index (if there
 *				is one) up through the right
 *				parentheses.  NumComponents tells how
 *				many additional tokens follow to
 *				represent the variable name.  The first
 *				token will be a TCL_TOKEN_TEXT token
 *				that describes the variable name.  If
 *				the variable is an array reference then
 *				there will be one or more additional
 *				tokens, of type TCL_TOKEN_TEXT,
 *				TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and
 *				TCL_TOKEN_VARIABLE, that describe the
 *				array index; numComponents counts the
 *				total number of nested tokens that make
 *				up the variable reference, including
 *				sub-tokens of TCL_TOKEN_VARIABLE tokens.
 * TCL_TOKEN_SUB_EXPR -		The token describes one subexpression of a
 *				expression, from the first non-blank
 *				character of the subexpression up to but not
 *				including the space, brace, or bracket
 *				that terminates the subexpression. 
 *				NumComponents counts the total number of
 *				following subtokens that make up the
 *				subexpression; this includes all subtokens
 *				for any nested TCL_TOKEN_SUB_EXPR tokens.
 *				For example, a numeric value used as a
 *				primitive operand is described by a
 *				TCL_TOKEN_SUB_EXPR token followed by a
 *				TCL_TOKEN_TEXT token. A binary subexpression
 *				is described by a TCL_TOKEN_SUB_EXPR token
 *				followed by the	TCL_TOKEN_OPERATOR token
 *				for the operator, then TCL_TOKEN_SUB_EXPR
 *				tokens for the left then the right operands.
 * TCL_TOKEN_OPERATOR -		The token describes one expression operator.
 *				An operator might be the name of a math
 *				function such as "abs". A TCL_TOKEN_OPERATOR
 *				token is always preceeded by one
 *				TCL_TOKEN_SUB_EXPR token for the operator's
 *				subexpression, and is followed by zero or
 *				more TCL_TOKEN_SUB_EXPR tokens for the
 *				operator's operands. NumComponents is
 *				always 0.
 * TCL_TOKEN_EXPAND_WORD -	This token is just like TCL_TOKEN_WORD
 *				except that it marks a word that began with
 *				the literal character prefix "{expand}".  This
 *				word is marked to be expanded - that is, broken
 *				into words after substitution is complete.
 */

#define TCL_TOKEN_WORD		1
#define TCL_TOKEN_SIMPLE_WORD	2
#define TCL_TOKEN_TEXT		4
#define TCL_TOKEN_BS		8
#define TCL_TOKEN_COMMAND	16
#define TCL_TOKEN_VARIABLE	32
#define TCL_TOKEN_SUB_EXPR	64
#define TCL_TOKEN_OPERATOR	128
#define TCL_TOKEN_EXPAND_WORD	256

/*
 * Parsing error types.  On any parsing error, one of these values
 * will be stored in the error field of the Tcl_Parse structure
 * defined below.
 */

#define TCL_PARSE_SUCCESS		0
#define TCL_PARSE_QUOTE_EXTRA		1
#define TCL_PARSE_BRACE_EXTRA		2
#define TCL_PARSE_MISSING_BRACE		3
#define TCL_PARSE_MISSING_BRACKET	4
#define TCL_PARSE_MISSING_PAREN		5
#define TCL_PARSE_MISSING_QUOTE		6
#define TCL_PARSE_MISSING_VAR_BRACE	7
#define TCL_PARSE_SYNTAX		8
#define TCL_PARSE_BAD_NUMBER		9

/*
 * A structure of the following type is filled in by Tcl_ParseCommand.
 * It describes a single command parsed from an input string.
 */

#define NUM_STATIC_TOKENS 20

typedef struct Tcl_Parse {
    CONST char *commentStart;	/* Pointer to # that begins the first of
				 * one or more comments preceding the
				 * command. */
    int commentSize;		/* Number of bytes in comments (up through
				 * newline character that terminates the
				 * last comment).  If there were no
				 * comments, this field is 0. */
    CONST char *commandStart;	/* First character in first word of command. */

    int commandSize;		/* Number of bytes in command, including
				 * first character of first word, up
				 * through the terminating newline,
				 * close bracket, or semicolon. */
    int numWords;		/* Total number of words in command.  May
				 * be 0. */
    Tcl_Token *tokenPtr;	/* Pointer to first token representing
				 * the words of the command.  Initially
				 * points to staticTokens, but may change
				 * to point to malloc-ed space if command
				 * exceeds space in staticTokens. */
    int numTokens;		/* Total number of tokens in command. */
    int tokensAvailable;	/* Total number of tokens available at
				 * *tokenPtr. */
    int errorType;		/* One of the parsing error types defined
				 * above. */

    /*
     * The fields below are intended only for the private use of the
     * parser.	They should not be used by procedures that invoke
     * Tcl_ParseCommand.
     */

    CONST char *string;		/* The original command string passed to
				 * Tcl_ParseCommand. */
    CONST char *end;		/* Points to the character just after the
				 * last one in the command string. */
    Tcl_Interp *interp;		/* Interpreter to use for error reporting,
				 * or NULL. */
    CONST char *term;		/* Points to character in string that
				 * terminated most recent token.  Filled in
				 * by ParseTokens.  If an error occurs,
				 * points to beginning of region where the
				 * error occurred (e.g. the open brace if
				 * the close brace is missing). */
    int incomplete;		/* This field is set to 1 by Tcl_ParseCommand
				 * if the command appears to be incomplete.
				 * This information is used by
				 * Tcl_CommandComplete. */
    Tcl_Token staticTokens[NUM_STATIC_TOKENS];
				/* Initial space for tokens for command.
				 * This space should be large enough to
				 * accommodate most commands; dynamic
				 * space is allocated for very large
				 * commands that don't fit here. */
} Tcl_Parse;

/*
 * The following definitions are the error codes returned by the conversion
 * routines:
 *
 * TCL_OK:			All characters were converted.
 *
 * TCL_CONVERT_NOSPACE:		The output buffer would not have been large
 *				enough for all of the converted data; as many
 *				characters as could fit were converted though.
 *
 * TCL_CONVERT_MULTIBYTE:	The last few bytes in the source string were
 *				the beginning of a multibyte sequence, but
 *				more bytes were needed to complete this
 *				sequence.  A subsequent call to the conversion
 *				routine should pass the beginning of this
 *				unconverted sequence plus additional bytes
 *				from the source stream to properly convert
 *				the formerly split-up multibyte sequence.
 *
 * TCL_CONVERT_SYNTAX:		The source stream contained an invalid
 *				character sequence.  This may occur if the
 *				input stream has been damaged or if the input
 *				encoding method was misidentified.  This error
 *				is reported only if TCL_ENCODING_STOPONERROR
 *				was specified.
 * 
 * TCL_CONVERT_UNKNOWN:		The source string contained a character
 *				that could not be represented in the target
 *				encoding.  This error is reported only if
 *				TCL_ENCODING_STOPONERROR was specified.
 */

#define TCL_CONVERT_MULTIBYTE		-1
#define TCL_CONVERT_SYNTAX		-2
#define TCL_CONVERT_UNKNOWN		-3
#define TCL_CONVERT_NOSPACE		-4


/*
 * The maximum number of bytes that are necessary to represent a single
 * Unicode character in UTF-8.  The valid values should be 3 or 6 (or
 * perhaps 1 if we want to support a non-unicode enabled core).
 * If 3, then Tcl_UniChar must be 2-bytes in size (UCS-2). (default)
 * If 6, then Tcl_UniChar must be 4-bytes in size (UCS-4).
 * At this time UCS-2 mode is the default and recommended mode.
 * UCS-4 is experimental and not recommended.  It works for the core,
 * but most extensions expect UCS-2.
 */

#ifndef TCL_UTF_MAX
#define TCL_UTF_MAX		3
#endif

/*
 * This represents a Unicode character.  Any changes to this should
 * also be reflected in regcustom.h.
 */

#if TCL_UTF_MAX > 3
    /*
     * unsigned int isn't 100% accurate as it should be a strict 4-byte
     * value (perhaps wchar_t).  64-bit systems may have troubles.  The
     * size of this value must be reflected correctly in regcustom.h.
     */
typedef unsigned int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif


/* TIP #59: The following structure is used in calls
 * 'Tcl_RegisterConfig' to provide the system with the embedded
 * configuration data.
 */

typedef struct Tcl_Config {
    CONST char* key;   /* Configuration key to register. ASCII encoded, thus UTF-8 */

    CONST char* value; /* The value associated with the key. System encoding */

} Tcl_Config;


/*
 * Flags for TIP#143 limits, detailing which limits are active in an
 * interpreter.  Used for Tcl_{Add,Remove}LimitHandler type argument.
 */

#define TCL_LIMIT_COMMANDS	0x01
#define TCL_LIMIT_TIME		0x02

/*
 * Structure containing information about a limit handler to be called
 * when a command- or time-limit is exceeded by an interpreter.
 */

typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp));
typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData));










#ifndef TCL_NO_DEPRECATED

    /*
     * Deprecated Tcl procedures:
     */

#   define Tcl_EvalObj(interp,objPtr) \
	Tcl_EvalObjEx((interp),(objPtr),0)
#   define Tcl_GlobalEvalObj(interp,objPtr) \
	Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)

    /*
     * These function have been renamed. The old names are deprecated,
     * but we define these macros for backwards compatibilty.
     */

#   define Tcl_Ckalloc Tcl_Alloc
#   define Tcl_Ckfree Tcl_Free
#   define Tcl_Ckrealloc Tcl_Realloc
#   define Tcl_Return Tcl_SetResult
#   define Tcl_TildeSubst Tcl_TranslateFileName
#   define panic Tcl_Panic
#   define panicVA Tcl_PanicVA
#endif


/*
 * The following constant is used to test for older versions of Tcl
 * in the stubs tables.
 *
 * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
 * value since the stubs tables don't match.
 */

#define TCL_STUB_MAGIC ((int)0xFCA3BACF)

/*
 * The following function is required to be defined in all stubs aware
 * extensions.  The function is actually implemented in the stub
 * library, not the main Tcl library, although there is a trivial
 * implementation in the main library in case an extension is statically
 * linked into an application.
 */

EXTERN CONST char *	Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *version, int exact));

#ifndef USE_TCL_STUBS








|
|
















|
|
|









<

|
|

>








|
|
|
|
|
|
<

>

|






>








>



<

|
|
|

>








>
>
>

>
>
>

|
|

>





|
|
|

>
|








>




|
|

>



|

>



>
>
>
>
>
>
>
>




>














|








|
<





|
>
>
>
>
>
>
>
>
>


|
|
|

>







>



|
|
|
<

>














|
|
|

|
|

>

|
|
|
|
>
|
|
|
|
|
|
|
|
|
>
|

|

|
|
>
|

|
|
|
>
|
<
|

|
|



|
>
|
|
>
|
|




|
<
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|
|

>







>






<
|
|
|

>

|
<
|
<
|
<
|
<



|

>
















|

>
|
|




>


|
|
<
|
|



|
|



|

|

|

|




|
|
|
|

|
<
|
|

|
<
|
|
|
|
<
|
|
|
|
|
|
|

|
|
|
|
|
>

















|
|
|
|
|
|
|
|
<



|
|
|
|
<

|
|
|

|
|

|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
<
|

|
|

|
|
|
|
<
<
|
|
<
|
<
|
|
|
<
|
<
|
|
|
|
<
|
|
|
|
|
|
|
<
<
|
|
|
|
|
<
|
|
|

|
|
|
|

|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
<
|
|
|
|
<
|
|
<
|
|
|
|
<
|
|
|
|
|
|
<
|
|
<
<
<
<
<
<
<
|
|
|
>
>
>
>
>
|
|
|
|
|
<
|
|
|
|
<
|
|
|
|
<
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<



|
|
|
|
|
|
|

>
|
|


|
|

>











<

|


>

|



|
|

|


|


|

|
|
|
|
|





|

|
|

|
|

<
|

|


|


<
|
|
|
|
|
|
|
|

>




<

|
<



|
|
|

>

|
|


|
|
|
|
|



|
|
<


|
|
|
<
|
|
|
|
|
|
|
<
|
|
|
|
|
>
>
>

<
<
<
<
|
|
<
|
|
|
|
|
<
|
|
|

|
|
|
|
|
|
|
|
|
<
|
|
|
|
|




|
|
|





|
|
|
<
|
|
|
|


>











|
|
<

>












|
|

>



|
|
<

|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|







|
|
<




|
|
|
|

|
|
|
|
|





|
|
|
|
|






|
<
|


<
|


|


|
|
<
|
|

|


<
|
|
|


>
|
|
|
|
<



|
|
|
<
|
|
|

>





|
|

>


|
|
|






>
|
|
<



|
>
|
>

<



|






|
|






>
>
>
>
>
>
>
>


<

|








|
|


|
|
|
|
|
|
|


<

|
|









|
|
|
<







1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370

1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389

1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412

1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512

1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548

1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602

1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621

1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659

1660
1661
1662
1663
1664
1665
1666

1667

1668

1669

1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705

1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732

1733
1734
1735
1736

1737
1738
1739
1740

1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779

1780
1781
1782
1783
1784
1785
1786

1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814

1815
1816
1817
1818
1819
1820
1821
1822
1823


1824
1825

1826

1827
1828
1829

1830

1831
1832
1833
1834

1835
1836
1837
1838
1839
1840
1841


1842
1843
1844
1845
1846

1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873

1874
1875
1876
1877

1878
1879

1880
1881
1882
1883

1884
1885
1886
1887
1888
1889

1890
1891







1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904

1905
1906
1907
1908

1909
1910
1911
1912

1913
1914


1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928

1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959

1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998

1999
2000
2001
2002
2003
2004
2005
2006

2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020

2021
2022

2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045

2046
2047
2048
2049
2050

2051
2052
2053
2054
2055
2056
2057

2058
2059
2060
2061
2062
2063
2064
2065
2066




2067
2068

2069
2070
2071
2072
2073

2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086

2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106

2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126

2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149

2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175

2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206

2207
2208
2209

2210
2211
2212
2213
2214
2215
2216
2217

2218
2219
2220
2221
2222
2223

2224
2225
2226
2227
2228
2229
2230
2231
2232
2233

2234
2235
2236
2237
2238
2239

2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267

2268
2269
2270
2271
2272
2273
2274
2275

2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303

2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326

2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341

2342
2343
2344
2345
2346
2347
2348
#   define Tcl_GetHashKey(tablePtr, h) \
	((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \
		   ? (h)->key.oneWordValue \
		   : (h)->key.string))
#endif

/*
 * Macros to use for clients to use to invoke find and create functions for
 * hash tables:
 */

#if TCL_PRESERVE_BINARY_COMPATABILITY
#   define Tcl_FindHashEntry(tablePtr, key) \
	(*((tablePtr)->findProc))(tablePtr, key)
#   define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
	(*((tablePtr)->createProc))(tablePtr, key, newPtr)
#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */
/*
 * Macro to use new extended version of Tcl_InitHashTable.
 */
#   define Tcl_InitHashTable(tablePtr, keyType) \
	Tcl_InitHashTableEx(tablePtr, keyType, NULL)
#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */

/*
 * Structure definition for information used to keep track of searches through
 * dictionaries. These fields should not be accessed by code outside
 * tclDictObj.c
 */

typedef struct {
    Tcl_HashSearch search;	/* Search struct for underlying hash table. */
    int epoch;			/* Epoch marker for dictionary being searched,
				 * or -1 if search has terminated. */
    Tcl_Dict dictionaryPtr;	/* Reference to dictionary being searched. */
} Tcl_DictSearch;


/*
 * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
 * events:
 */

#define TCL_DONT_WAIT		(1<<1)
#define TCL_WINDOW_EVENTS	(1<<2)
#define TCL_FILE_EVENTS		(1<<3)
#define TCL_TIMER_EVENTS	(1<<4)
#define TCL_IDLE_EVENTS		(1<<5)	/* WAS 0x10 ???? */
#define TCL_ALL_EVENTS		(~TCL_DONT_WAIT)

/*
 * The following structure defines a generic event for the Tcl event system.
 * These are the things that are queued in calls to Tcl_QueueEvent and
 * serviced later by Tcl_DoOneEvent. There can be many different kinds of
 * events with different fields, corresponding to window events, timer events,
 * etc. The structure for a particular event consists of a Tcl_Event header
 * followed by additional information specific to that event.

 */

struct Tcl_Event {
    Tcl_EventProc *proc;	/* Function to call to service this event. */
    struct Tcl_Event *nextPtr;	/* Next in list of pending events, or NULL. */
};

/*
 * Positions to pass to Tcl_QueueEvent:
 */

typedef enum {
    TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
} Tcl_QueuePosition;

/*
 * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
 * event routines.
 */

#define TCL_SERVICE_NONE 0
#define TCL_SERVICE_ALL 1


/*
 * The following structure keeps is used to hold a time value, either as an
 * absolute time (the number of seconds from the epoch) or as an elapsed time.
 * On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
 */

typedef struct Tcl_Time {
    long sec;			/* Seconds. */
    long usec;			/* Microseconds. */
} Tcl_Time;

typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr));
typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr));

/*
 * TIP #233 (Virtualized Time)
 */

typedef void (Tcl_GetTimeProc)   _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData));
typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData));

/*
 * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to
 * indicate what sorts of events are of interest:
 */

#define TCL_READABLE	(1<<1)
#define TCL_WRITABLE	(1<<2)
#define TCL_EXCEPTION	(1<<3)

/*
 * Flag values to pass to Tcl_OpenCommandChannel to indicate the disposition
 * of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, are also used in
 * Tcl_GetStdChannel.
 */

#define TCL_STDIN		(1<<1)
#define TCL_STDOUT		(1<<2)
#define TCL_STDERR		(1<<3)
#define TCL_ENFORCE_MODE	(1<<4)

/*
 * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel
 * should be closed.
 */

#define TCL_CLOSE_READ	(1<<1)
#define TCL_CLOSE_WRITE	(1<<2)

/*
 * Value to use as the closeProc for a channel that supports the close2Proc
 * interface.
 */

#define TCL_CLOSE2PROC	((Tcl_DriverCloseProc *)1)

/*
 * Channel version tag. This was introduced in 8.3.2/8.4.
 */

#define TCL_CHANNEL_VERSION_1	((Tcl_ChannelTypeVersion) 0x1)
#define TCL_CHANNEL_VERSION_2	((Tcl_ChannelTypeVersion) 0x2)
#define TCL_CHANNEL_VERSION_3	((Tcl_ChannelTypeVersion) 0x3)
#define TCL_CHANNEL_VERSION_4	((Tcl_ChannelTypeVersion) 0x4)

/*
 * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc
 */

#define TCL_CHANNEL_THREAD_INSERT (0)
#define TCL_CHANNEL_THREAD_REMOVE (1)

/*
 * Typedefs for the various operations in a channel type:
 */

typedef int	(Tcl_DriverBlockModeProc) _ANSI_ARGS_((
		    ClientData instanceData, int mode));
typedef int	(Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
		    Tcl_Interp *interp));
typedef int	(Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData,
		    Tcl_Interp *interp, int flags));
typedef int	(Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
		    char *buf, int toRead, int *errorCodePtr));
typedef int	(Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
		    CONST84 char *buf, int toWrite, int *errorCodePtr));
typedef int	(Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
		    long offset, int mode, int *errorCodePtr));
typedef int	(Tcl_DriverSetOptionProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_Interp *interp,
		    CONST char *optionName, CONST char *value));
typedef int	(Tcl_DriverGetOptionProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_Interp *interp,
		    CONST84 char *optionName, Tcl_DString *dsPtr));
typedef void	(Tcl_DriverWatchProc) _ANSI_ARGS_((
		    ClientData instanceData, int mask));
typedef int	(Tcl_DriverGetHandleProc) _ANSI_ARGS_((
		    ClientData instanceData, int direction,
		    ClientData *handlePtr));
typedef int	(Tcl_DriverFlushProc) _ANSI_ARGS_((ClientData instanceData));

typedef int	(Tcl_DriverHandlerProc) _ANSI_ARGS_((
		    ClientData instanceData, int interestMask));
typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_WideInt offset,
		    int mode, int *errorCodePtr));
/*
 * TIP #218, Channel Thread Actions
 */
typedef void	(Tcl_DriverThreadActionProc) _ANSI_ARGS_ ((
		    ClientData instanceData, int action));
/*
 * TIP #208, File Truncation (etc.)
 */
typedef int	(Tcl_DriverTruncateProc) _ANSI_ARGS_((
		    ClientData instanceData, Tcl_WideInt length));

/*
 * The following declarations either map ckalloc and ckfree to malloc and
 * free, or they map them to functions with all sorts of debugging hooks
 * defined in tclCkalloc.c.
 */

#ifdef TCL_MEM_DEBUG

#   define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
#   define ckfree(x)  Tcl_DbCkfree(x, __FILE__, __LINE__)
#   define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
#   define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
#   define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)

#else /* !TCL_MEM_DEBUG */

/*
 * If we are not using the debugging allocator, we should call the Tcl_Alloc,
 * et al. routines in order to guarantee that every module is using the same
 * memory allocator both inside and outside of the Tcl library.

 */

#   define ckalloc(x) Tcl_Alloc(x)
#   define ckfree(x) Tcl_Free(x)
#   define ckrealloc(x,y) Tcl_Realloc(x,y)
#   define attemptckalloc(x) Tcl_AttemptAlloc(x)
#   define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
#   define Tcl_InitMemory(x)
#   define Tcl_DumpActiveMemory(x)
#   define Tcl_ValidateAllMemory(x,y)

#endif /* !TCL_MEM_DEBUG */

/*
 * struct Tcl_ChannelType:
 *
 * One such structure exists for each type (kind) of channel. It collects
 * together in one place all the functions that are part of the specific
 * channel type.
 *
 * It is recommend that the Tcl_Channel* functions are used to access elements
 * of this structure, instead of direct accessing.
 */

typedef struct Tcl_ChannelType {
    char *typeName;		/* The name of the channel type in Tcl
				 * commands. This storage is owned by channel
				 * type. */
    Tcl_ChannelTypeVersion version;
				/* Version of the channel type. */
    Tcl_DriverCloseProc *closeProc;
				/* Function to call to close the channel, or
				 * TCL_CLOSE2PROC if the close2Proc should be
				 * used instead. */
    Tcl_DriverInputProc *inputProc;
				/* Function to call for input on channel. */
    Tcl_DriverOutputProc *outputProc;
				/* Function to call for output on channel. */
    Tcl_DriverSeekProc *seekProc;
				/* Function to call to seek on the channel.
				 * May be NULL. */
    Tcl_DriverSetOptionProc *setOptionProc;
				/* Set an option on a channel. */
    Tcl_DriverGetOptionProc *getOptionProc;
				/* Get an option from a channel. */
    Tcl_DriverWatchProc *watchProc;
				/* Set up the notifier to watch for events on
				 * this channel. */
    Tcl_DriverGetHandleProc *getHandleProc;
				/* Get an OS handle from the channel or NULL
				 * if not supported. */
    Tcl_DriverClose2Proc *close2Proc;
				/* Function to call to close the channel if
				 * the device supports closing the read &

				 * write sides independently. */
    Tcl_DriverBlockModeProc *blockModeProc;
				/* Set blocking mode for the raw channel. May
				 * be NULL. */
    /*
     * Only valid in TCL_CHANNEL_VERSION_2 channels or later
     */
    Tcl_DriverFlushProc *flushProc;
				/* Function to call to flush a channel. May be
				 * NULL. */
    Tcl_DriverHandlerProc *handlerProc;
				/* Function to call to handle a channel event.
				 * This will be passed up the stacked channel
				 * chain. */
    /*
     * Only valid in TCL_CHANNEL_VERSION_3 channels or later
     */
    Tcl_DriverWideSeekProc *wideSeekProc;
				/* Function to call to seek on the channel

				 * which can handle 64-bit offsets. May be
				 * NULL, and must be NULL if seekProc is
				 * NULL. */
    /*
     * Only valid in TCL_CHANNEL_VERSION_4 channels or later
     * TIP #218, Channel Thread Actions
     * TIP #208 (part relating to truncation)
     */
    Tcl_DriverThreadActionProc *threadActionProc;
				/* Function to call to notify the driver of
				 * thread specific activity for a channel. May
				 * be NULL. */
    Tcl_DriverTruncateProc *truncateProc;
				/* Function to call to truncate the underlying
				 * file to a particular length. May be NULL if
				 * the channel does not support truncation. */
} Tcl_ChannelType;

/*
 * The following flags determine whether the blockModeProc above should set
 * the channel into blocking or nonblocking mode. They are passed as arguments
 * to the blockModeProc function in the above structure.
 */

#define TCL_MODE_BLOCKING	0	/* Put channel into blocking mode. */
#define TCL_MODE_NONBLOCKING	1	/* Put channel into nonblocking
					 * mode. */

/*
 * Enum for different types of file paths.
 */

typedef enum Tcl_PathType {
    TCL_PATH_ABSOLUTE,
    TCL_PATH_RELATIVE,
    TCL_PATH_VOLUME_RELATIVE
} Tcl_PathType;


/*
 * The following structure is used to pass glob type data amongst the various
 * glob routines and Tcl_FSMatchInDirectory.
 */

typedef struct Tcl_GlobTypeData {
    int type;			/* Corresponds to bcdpfls as in 'find -t' */

    int perm;			/* Corresponds to file permissions */

    Tcl_Obj *macType;		/* Acceptable mac type */

    Tcl_Obj *macCreator;	/* Acceptable mac creator */

} Tcl_GlobTypeData;

/*
 * Type and permission definitions for glob command
 */

#define TCL_GLOB_TYPE_BLOCK		(1<<0)
#define TCL_GLOB_TYPE_CHAR		(1<<1)
#define TCL_GLOB_TYPE_DIR		(1<<2)
#define TCL_GLOB_TYPE_PIPE		(1<<3)
#define TCL_GLOB_TYPE_FILE		(1<<4)
#define TCL_GLOB_TYPE_LINK		(1<<5)
#define TCL_GLOB_TYPE_SOCK		(1<<6)
#define TCL_GLOB_TYPE_MOUNT		(1<<7)

#define TCL_GLOB_PERM_RONLY		(1<<0)
#define TCL_GLOB_PERM_HIDDEN		(1<<1)
#define TCL_GLOB_PERM_R			(1<<2)
#define TCL_GLOB_PERM_W			(1<<3)
#define TCL_GLOB_PERM_X			(1<<4)

/*
 * Flags for the unload callback function
 */

#define TCL_UNLOAD_DETACH_FROM_INTERPRETER	(1<<0)
#define TCL_UNLOAD_DETACH_FROM_PROCESS		(1<<1)

/*
 * Typedefs for the various filesystem operations:
 */

typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_((
	Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions));

typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp,
	Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern,
	Tcl_GlobTypeData * types));
typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
	Tcl_StatBuf *buf));
typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
	Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
	Tcl_Obj *destPathPtr));
typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
	int recursive, Tcl_Obj **errorPtr));
typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
	Tcl_Obj *destPathPtr));
typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
/* We have to declare the utime structure here. */
struct utimbuf;
typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
	struct utimbuf *tval));
typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp,
	Tcl_Obj *pathPtr, int nextCheckpoint));
typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef));

typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((
	Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef));
typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr));

typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
	Tcl_Obj *toPtr, int linkType));
typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
	Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr,

	Tcl_FSUnloadFileProc **unloadProcPtr));
typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
	ClientData *clientDataPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) _ANSI_ARGS_((
	Tcl_Obj *pathPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) _ANSI_ARGS_((
	Tcl_Obj *pathPtr));
typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
typedef ClientData (Tcl_FSDupInternalRepProc) _ANSI_ARGS_((
	ClientData clientData));
typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) _ANSI_ARGS_((
	ClientData clientData));
typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((
	Tcl_Obj *pathPtr));

typedef struct Tcl_FSVersion_ *Tcl_FSVersion;

/*
 *----------------------------------------------------------------
 * Data structures related to hooking into the filesystem
 *----------------------------------------------------------------
 */

/*
 * Filesystem version tag.  This was introduced in 8.4.
 */
#define TCL_FILESYSTEM_VERSION_1	((Tcl_FSVersion) 0x1)

/*
 * struct Tcl_Filesystem:
 *
 * One such structure exists for each type (kind) of filesystem. It collects
 * together in one place all the functions that are part of the specific
 * filesystem. Tcl always accesses the filesystem through one of these
 * structures.
 *
 * Not all entries need be non-NULL; any which are NULL are simply ignored.
 * However, a complete filesystem should provide all of these functions. The
 * explanations in the structure show the importance of each function.

 */

typedef struct Tcl_Filesystem {
    CONST char *typeName;	/* The name of the filesystem. */
    int structureLength;	/* Length of this structure, so future binary
				 * compatibility can be assured. */
    Tcl_FSVersion version;	/* Version of the filesystem type. */

    Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
				/* Function to check whether a path is in this
				 * filesystem. This is the most important
				 * filesystem function. */
    Tcl_FSDupInternalRepProc *dupInternalRepProc;
				/* Function to duplicate internal fs rep. May
				 * be NULL (but then fs is less efficient). */
    Tcl_FSFreeInternalRepProc *freeInternalRepProc;
				/* Function to free internal fs rep. Must be
				 * implemented if internal representations
				 * need freeing, otherwise it can be NULL. */
    Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
				/* Function to convert internal representation
				 * to a normalized path. Only required if the
				 * fs creates pure path objects with no
				 * string/path representation. */
    Tcl_FSCreateInternalRepProc *createInternalRepProc;
				/* Function to create a filesystem-specific
				 * internal representation. May be NULL if
				 * paths have no internal representation, or
				 * if the Tcl_FSPathInFilesystemProc for this
				 * filesystem always immediately creates an
				 * internal representation for paths it
				 * accepts. */
    Tcl_FSNormalizePathProc *normalizePathProc;
				/* Function to normalize a path.  Should be
				 * implemented for all filesystems which can
				 * have multiple string representations for

				 * the same path object. */
    Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
				/* Function to determine the type of a path in
				 * this filesystem. May be NULL. */
    Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
				/* Function to return the separator
				 * character(s) for this filesystem. Must be
				 * implemented. */
    Tcl_FSStatProc *statProc;	/* Function to process a 'Tcl_FSStat()' call.


				 * Must be implemented for any reasonable
				 * filesystem. */

    Tcl_FSAccessProc *accessProc;

				/* Function to process a 'Tcl_FSAccess()'
				 * call. Must be implemented for any
				 * reasonable filesystem. */

    Tcl_FSOpenFileChannelProc *openFileChannelProc;

				/* Function to process a
				 * 'Tcl_FSOpenFileChannel()' call. Must be
				 * implemented for any reasonable
				 * filesystem. */

    Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSMatchInDirectory()'.  If not
				 * implemented, then glob and recursive copy
				 * functionality will be lacking in the
				 * filesystem. */
    Tcl_FSUtimeProc *utimeProc;	/* Function to process a 'Tcl_FSUtime()' call.


				 * Required to allow setting (not reading) of
				 * times with 'file mtime', 'file atime' and
				 * the open-r/open-w/fcopy implementation of
				 * 'file copy'. */
    Tcl_FSLinkProc *linkProc;	/* Function to process a 'Tcl_FSLink()' call.

				 * Should be implemented only if the
				 * filesystem supports links (reading or
				 * creating). */
    Tcl_FSListVolumesProc *listVolumesProc;
				/* Function to list any filesystem volumes
				 * added by this filesystem. Should be
				 * implemented only if the filesystem adds
				 * volumes at the head of the filesystem. */
    Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
				/* Function to list all attributes strings
				 * which are valid for this filesystem. If not
				 * implemented the filesystem will not support
				 * the 'file attributes' command. This allows
				 * arbitrary additional information to be
				 * attached to files in the filesystem. */
    Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
				/* Function to process a
				 * 'Tcl_FSFileAttrsGet()' call, used by 'file
				 * attributes'. */
    Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
				/* Function to process a
				 * 'Tcl_FSFileAttrsSet()' call, used by 'file
				 * attributes'.  */
    Tcl_FSCreateDirectoryProc *createDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSCreateDirectory()' call. Should be
				 * implemented unless the FS is read-only. */

    Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSRemoveDirectory()' call. Should be
				 * implemented unless the FS is read-only. */

    Tcl_FSDeleteFileProc *deleteFileProc;
				/* Function to process a 'Tcl_FSDeleteFile()'

				 * call. Should be implemented unless the FS
				 * is read-only. */
    Tcl_FSCopyFileProc *copyFileProc;
				/* Function to process a 'Tcl_FSCopyFile()'

				 * call. If not implemented Tcl will fall back
				 * on open-r, open-w and fcopy as a copying
				 * mechanism, for copying actions initiated in
				 * Tcl (not C). */
    Tcl_FSRenameFileProc *renameFileProc;
				/* Function to process a 'Tcl_FSRenameFile()'

				 * call. If not implemented, Tcl will fall
				 * back on a copy and delete mechanism, for







				 * rename actions initiated in Tcl (not C). */
    Tcl_FSCopyDirectoryProc *copyDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSCopyDirectory()' call. If not
				 * implemented, Tcl will fall back on a
				 * recursive create-dir, file copy mechanism,
				 * for copying actions initiated in Tcl (not
				 * C). */
    Tcl_FSLstatProc *lstatProc;	/* Function to process a 'Tcl_FSLstat()' call.
				 * If not implemented, Tcl will attempt to use
				 * the 'statProc' defined above instead. */
    Tcl_FSLoadFileProc *loadFileProc;
				/* Function to process a 'Tcl_FSLoadFile()'

				 * call. If not implemented, Tcl will fall
				 * back on a copy to native-temp followed by a
				 * Tcl_FSLoadFile on that temporary copy. */
    Tcl_FSGetCwdProc *getCwdProc;

				/* Function to process a 'Tcl_FSGetCwd()'
				 * call. Most filesystems need not implement
				 * this. It will usually only be called once,
				 * if 'getcwd' is called before 'chdir'. May

				 * be NULL. */
    Tcl_FSChdirProc *chdirProc;	/* Function to process a 'Tcl_FSChdir()' call.


				 * If filesystems do not implement this, it
				 * will be emulated by a series of directory
				 * access checks. Otherwise, virtual
				 * filesystems which do implement it need only
				 * respond with a positive return result if
				 * the dirName is a valid directory in their
				 * filesystem. They need not remember the
				 * result, since that will be automatically
				 * remembered for use by GetCwd. Real
				 * filesystems should carry out the correct
				 * action (i.e. call the correct system
				 * 'chdir' api). If not implemented, then 'cd'
				 * and 'pwd' will fail inside the
				 * filesystem. */

} Tcl_Filesystem;

/*
 * The following definitions are used as values for the 'linkAction' flag to
 * Tcl_FSLink, or the linkProc of any filesystem. Any combination of flags can
 * be given. For link creation, the linkProc should create a link which
 * matches any of the types given.
 *
 * TCL_CREATE_SYMBOLIC_LINK -	Create a symbolic or soft link.
 * TCL_CREATE_HARD_LINK -	Create a hard link.
 */

#define TCL_CREATE_SYMBOLIC_LINK	0x01
#define TCL_CREATE_HARD_LINK		0x02

/*
 * The following structure represents the Notifier functions that you can
 * override with the Tcl_SetNotifier call.
 */

typedef struct Tcl_NotifierProcs {
    Tcl_SetTimerProc *setTimerProc;
    Tcl_WaitForEventProc *waitForEventProc;
    Tcl_CreateFileHandlerProc *createFileHandlerProc;
    Tcl_DeleteFileHandlerProc *deleteFileHandlerProc;
    Tcl_InitNotifierProc *initNotifierProc;
    Tcl_FinalizeNotifierProc *finalizeNotifierProc;
    Tcl_AlertNotifierProc *alertNotifierProc;
    Tcl_ServiceModeHookProc *serviceModeHookProc;
} Tcl_NotifierProcs;


/*
 * The following structure represents a user-defined encoding. It collects
 * together all the functions that are used by the specific encoding.
 */

typedef struct Tcl_EncodingType {
    CONST char *encodingName;	/* The name of the encoding, e.g. "euc-jp".
				 * This name is the unique key for this
				 * encoding type. */
    Tcl_EncodingConvertProc *toUtfProc;
				/* Function to convert from external encoding
				 * into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Function to convert from UTF-8 into
				 * external encoding. */
    Tcl_EncodingFreeProc *freeProc;
				/* If non-NULL, function to call when this
				 * encoding is deleted. */
    ClientData clientData;	/* Arbitrary value associated with encoding
				 * type. Passed to conversion functions. */
    int nullSize;		/* Number of zero bytes that signify
				 * end-of-string in this encoding. This number
				 * is used to determine the source string
				 * length when the srcLen argument is
				 * negative. Must be 1 or 2. */
} Tcl_EncodingType;

/*
 * The following definitions are used as values for the conversion control
 * flags argument when converting text from one character set to another:
 *
 * TCL_ENCODING_START -		Signifies that the source buffer is the first
 *				block in a (potentially multi-block) input
 *				stream. Tells the conversion function to reset
 *				to an initial state and perform any
 *				initialization that needs to occur before the
 *				first byte is converted. If the source buffer
 *				contains the entire input stream to be
 *				converted, this flag should be set.

 * TCL_ENCODING_END -		Signifies that the source buffer is the last
 *				block in a (potentially multi-block) input
 *				stream. Tells the conversion routine to
 *				perform any finalization that needs to occur
 *				after the last byte is converted and then to
 *				reset to an initial state. If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.

 * TCL_ENCODING_STOPONERROR -	If set, then the converter will return
 *				immediately upon encountering an invalid byte
 *				sequence or a source character that has no
 *				mapping in the target encoding. If clear, then
 *				the converter will skip the problem,
 *				substituting one or more "close" characters in
 *				the destination buffer and then continue to
 *				convert the source.
 */

#define TCL_ENCODING_START		0x01
#define TCL_ENCODING_END		0x02
#define TCL_ENCODING_STOPONERROR	0x04


/*
 * The following data structures and declarations are for the new Tcl parser.

 */

/*
 * For each word of a command, and for each piece of a word such as a variable
 * reference, one of the following structures is created to describe the
 * token.
 */

typedef struct Tcl_Token {
    int type;			/* Type of token, such as TCL_TOKEN_WORD; see
				 * below for valid types. */
    CONST char *start;		/* First character in token. */
    int size;			/* Number of bytes in token. */
    int numComponents;		/* If this token is composed of other tokens,
				 * this field tells how many of them there are
				 * (including components of components, etc.).
				 * The component tokens immediately follow
				 * this one. */
} Tcl_Token;

/*
 * Type values defined for Tcl_Token structures. These values are defined as
 * mask bits so that it's easy to check for collections of types.

 *
 * TCL_TOKEN_WORD -		The token describes one word of a command,
 *				from the first non-blank character of the word
 *				(which may be " or {) up to but not including
 *				the space, semicolon, or bracket that

 *				terminates the word. NumComponents counts the
 *				total number of sub-tokens that make up the
 *				word. This includes, for example, sub-tokens
 *				of TCL_TOKEN_VARIABLE tokens.
 * TCL_TOKEN_SIMPLE_WORD -	This token is just like TCL_TOKEN_WORD except
 *				that the word is guaranteed to consist of a
 *				single TCL_TOKEN_TEXT sub-token.

 * TCL_TOKEN_TEXT -		The token describes a range of literal text
 *				that is part of a word. NumComponents is
 *				always 0.
 * TCL_TOKEN_BS -		The token describes a backslash sequence that
 *				must be collapsed. NumComponents is always 0.
 * TCL_TOKEN_COMMAND -		The token describes a command whose result
 *				must be substituted into the word. The token
 *				includes the enclosing brackets. NumComponents
 *				is always 0.




 * TCL_TOKEN_VARIABLE -		The token describes a variable substitution,
 *				including the dollar sign, variable name, and

 *				array index (if there is one) up through the
 *				right parentheses. NumComponents tells how
 *				many additional tokens follow to represent the
 *				variable name. The first token will be a
 *				TCL_TOKEN_TEXT token that describes the

 *				variable name. If the variable is an array
 *				reference then there will be one or more
 *				additional tokens, of type TCL_TOKEN_TEXT,
 *				TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and
 *				TCL_TOKEN_VARIABLE, that describe the array
 *				index; numComponents counts the total number
 *				of nested tokens that make up the variable
 *				reference, including sub-tokens of
 *				TCL_TOKEN_VARIABLE tokens.
 * TCL_TOKEN_SUB_EXPR -		The token describes one subexpression of an
 *				expression, from the first non-blank character
 *				of the subexpression up to but not including
 *				the space, brace, or bracket that terminates

 *				the subexpression. NumComponents counts the
 *				total number of following subtokens that make
 *				up the subexpression; this includes all
 *				subtokens for any nested TCL_TOKEN_SUB_EXPR
 *				tokens. For example, a numeric value used as a
 *				primitive operand is described by a
 *				TCL_TOKEN_SUB_EXPR token followed by a
 *				TCL_TOKEN_TEXT token. A binary subexpression
 *				is described by a TCL_TOKEN_SUB_EXPR token
 *				followed by the TCL_TOKEN_OPERATOR token for
 *				the operator, then TCL_TOKEN_SUB_EXPR tokens
 *				for the left then the right operands.
 * TCL_TOKEN_OPERATOR -		The token describes one expression operator.
 *				An operator might be the name of a math
 *				function such as "abs". A TCL_TOKEN_OPERATOR
 *				token is always preceeded by one
 *				TCL_TOKEN_SUB_EXPR token for the operator's
 *				subexpression, and is followed by zero or more
 *				TCL_TOKEN_SUB_EXPR tokens for the operator's
 *				operands. NumComponents is always 0.

 * TCL_TOKEN_EXPAND_WORD -	This token is just like TCL_TOKEN_WORD except
 *				that it marks a word that began with the
 *				literal character prefix "{expand}". This word
 *				is marked to be expanded - that is, broken
 *				into words after substitution is complete.
 */

#define TCL_TOKEN_WORD		1
#define TCL_TOKEN_SIMPLE_WORD	2
#define TCL_TOKEN_TEXT		4
#define TCL_TOKEN_BS		8
#define TCL_TOKEN_COMMAND	16
#define TCL_TOKEN_VARIABLE	32
#define TCL_TOKEN_SUB_EXPR	64
#define TCL_TOKEN_OPERATOR	128
#define TCL_TOKEN_EXPAND_WORD	256

/*
 * Parsing error types. On any parsing error, one of these values will be
 * stored in the error field of the Tcl_Parse structure defined below.

 */

#define TCL_PARSE_SUCCESS		0
#define TCL_PARSE_QUOTE_EXTRA		1
#define TCL_PARSE_BRACE_EXTRA		2
#define TCL_PARSE_MISSING_BRACE		3
#define TCL_PARSE_MISSING_BRACKET	4
#define TCL_PARSE_MISSING_PAREN		5
#define TCL_PARSE_MISSING_QUOTE		6
#define TCL_PARSE_MISSING_VAR_BRACE	7
#define TCL_PARSE_SYNTAX		8
#define TCL_PARSE_BAD_NUMBER		9

/*
 * A structure of the following type is filled in by Tcl_ParseCommand. It
 * describes a single command parsed from an input string.
 */

#define NUM_STATIC_TOKENS 20

typedef struct Tcl_Parse {
    CONST char *commentStart;	/* Pointer to # that begins the first of one
				 * or more comments preceding the command. */

    int commentSize;		/* Number of bytes in comments (up through
				 * newline character that terminates the last
				 * comment). If there were no comments, this
				 * field is 0. */
    CONST char *commandStart;	/* First character in first word of
				 * command. */
    int commandSize;		/* Number of bytes in command, including first
				 * character of first word, up through the
				 * terminating newline, close bracket, or
				 * semicolon. */
    int numWords;		/* Total number of words in command. May be
				 * 0. */
    Tcl_Token *tokenPtr;	/* Pointer to first token representing the
				 * words of the command. Initially points to
				 * staticTokens, but may change to point to
				 * malloc-ed space if command exceeds space in
				 * staticTokens. */
    int numTokens;		/* Total number of tokens in command. */
    int tokensAvailable;	/* Total number of tokens available at
				 * *tokenPtr. */
    int errorType;		/* One of the parsing error types defined
				 * above. */

    /*
     * The fields below are intended only for the private use of the parser.
     * They should not be used by functions that invoke Tcl_ParseCommand.

     */

    CONST char *string;		/* The original command string passed to
				 * Tcl_ParseCommand. */
    CONST char *end;		/* Points to the character just after the last
				 * one in the command string. */
    Tcl_Interp *interp;		/* Interpreter to use for error reporting, or
				 * NULL. */
    CONST char *term;		/* Points to character in string that
				 * terminated most recent token. Filled in by
				 * ParseTokens. If an error occurs, points to
				 * beginning of region where the error
				 * occurred (e.g. the open brace if the close
				 * brace is missing). */
    int incomplete;		/* This field is set to 1 by Tcl_ParseCommand
				 * if the command appears to be incomplete.
				 * This information is used by
				 * Tcl_CommandComplete. */
    Tcl_Token staticTokens[NUM_STATIC_TOKENS];
				/* Initial space for tokens for command. This
				 * space should be large enough to accommodate
				 * most commands; dynamic space is allocated
				 * for very large commands that don't fit
				 * here. */
} Tcl_Parse;

/*
 * The following definitions are the error codes returned by the conversion
 * routines:
 *
 * TCL_OK -			All characters were converted.

 * TCL_CONVERT_NOSPACE -	The output buffer would not have been large
 *				enough for all of the converted data; as many
 *				characters as could fit were converted though.

 * TCL_CONVERT_MULTIBYTE -	The last few bytes in the source string were
 *				the beginning of a multibyte sequence, but
 *				more bytes were needed to complete this
 *				sequence. A subsequent call to the conversion
 *				routine should pass the beginning of this
 *				unconverted sequence plus additional bytes
 *				from the source stream to properly convert the
 *				formerly split-up multibyte sequence.

 * TCL_CONVERT_SYNTAX -		The source stream contained an invalid
 *				character sequence. This may occur if the
 *				input stream has been damaged or if the input
 *				encoding method was misidentified. This error
 *				is reported only if TCL_ENCODING_STOPONERROR
 *				was specified.

 * TCL_CONVERT_UNKNOWN -	The source string contained a character that
 *				could not be represented in the target
 *				encoding. This error is reported only if
 *				TCL_ENCODING_STOPONERROR was specified.
 */

#define TCL_CONVERT_MULTIBYTE	-1
#define TCL_CONVERT_SYNTAX	-2
#define TCL_CONVERT_UNKNOWN	-3
#define TCL_CONVERT_NOSPACE	-4


/*
 * The maximum number of bytes that are necessary to represent a single
 * Unicode character in UTF-8. The valid values should be 3 or 6 (or perhaps 1
 * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar
 * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must

 * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and
 * recommended mode. UCS-4 is experimental and not recommended. It works for
 * the core, but most extensions expect UCS-2.
 */

#ifndef TCL_UTF_MAX
#define TCL_UTF_MAX		3
#endif

/*
 * This represents a Unicode character. Any changes to this should also be
 * reflected in regcustom.h.
 */

#if TCL_UTF_MAX > 3
    /*
     * unsigned int isn't 100% accurate as it should be a strict 4-byte value
     * (perhaps wchar_t). 64-bit systems may have troubles. The size of this
     * value must be reflected correctly in regcustom.h.
     */
typedef unsigned int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif

/*
 * TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
 * provide the system with the embedded configuration data.

 */

typedef struct Tcl_Config {
    CONST char *key;		/* Configuration key to register. ASCII
				 * encoded, thus UTF-8 */
    CONST char *value;		/* The value associated with the key. System
				 * encoding */
} Tcl_Config;


/*
 * Flags for TIP#143 limits, detailing which limits are active in an
 * interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument.
 */

#define TCL_LIMIT_COMMANDS	0x01
#define TCL_LIMIT_TIME		0x02

/*
 * Structure containing information about a limit handler to be called when a
 * command- or time-limit is exceeded by an interpreter.
 */

typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp));
typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData));

#ifndef MP_INT_DECLARED
typedef struct mp_int mp_int;
#define MP_INT_DECLARED
#endif
#ifndef MP_DIGIT_DECLARED
typedef unsigned long mp_digit;
#define MP_DIGIT_DECLARED
#endif

#ifndef TCL_NO_DEPRECATED

    /*
     * Deprecated Tcl functions:
     */

#   define Tcl_EvalObj(interp,objPtr) \
	Tcl_EvalObjEx((interp),(objPtr),0)
#   define Tcl_GlobalEvalObj(interp,objPtr) \
	Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)

    /*
     * These function have been renamed. The old names are deprecated, but we
     * define these macros for backwards compatibilty.
     */

#   define Tcl_Ckalloc		Tcl_Alloc
#   define Tcl_Ckfree		Tcl_Free
#   define Tcl_Ckrealloc	Tcl_Realloc
#   define Tcl_Return		Tcl_SetResult
#   define Tcl_TildeSubst	Tcl_TranslateFileName
#   define panic		Tcl_Panic
#   define panicVA		Tcl_PanicVA
#endif


/*
 * The following constant is used to test for older versions of Tcl in the
 * stubs tables.
 *
 * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
 * value since the stubs tables don't match.
 */

#define TCL_STUB_MAGIC ((int)0xFCA3BACF)

/*
 * The following function is required to be defined in all stubs aware
 * extensions. The function is actually implemented in the stub library, not
 * the main Tcl library, although there is a trivial implementation in the
 * main library in case an extension is statically linked into an application.

 */

EXTERN CONST char *	Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *version, int exact));

#ifndef USE_TCL_STUBS

2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346

2347
2348
2349
2350
2351
2352
2353
2354
2355









2356








/*
 * Public functions that are not accessible via the stubs table.
 */

EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
	Tcl_AppInitProc *appInitProc));


/*
 * Include the public function declarations that are accessible via
 * the stubs table.
 */

#include "tclDecls.h"

/*
 * Include platform specific public function declarations that are
 * accessible via the stubs table.
 */

#include "tclPlatDecls.h"

/*
 * Convenience declaration of Tcl_AppInit for backwards compatibility.
 * This function is not *implemented* by the tcl library, so the storage
 * class is neither DLLEXPORT nor DLLIMPORT
 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS

EXTERN int		Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* RC_INVOKED */









#endif /* _TCL */















<

|
|





|
|





|
|
|

>









>
>
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
2358
2359
2360
2361
2362
2363
2364

2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
/*
 * Public functions that are not accessible via the stubs table.
 */

EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
	Tcl_AppInitProc *appInitProc));


/*
 * Include the public function declarations that are accessible via the stubs
 * table.
 */

#include "tclDecls.h"

/*
 * Include platform specific public function declarations that are accessible
 * via the stubs table.
 */

#include "tclPlatDecls.h"

/*
 * Convenience declaration of Tcl_AppInit for backwards compatibility. This
 * function is not *implemented* by the tcl library, so the storage class is
 * neither DLLEXPORT nor DLLIMPORT.
 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS

EXTERN int		Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* RC_INVOKED */

/*
 * end block for C++
 */

#ifdef __cplusplus
}
#endif

#endif /* _TCL */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclAlloc.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47

48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
/* 
 * tclAlloc.c --
 *
 *	This is a very fast storage allocator.  It allocates blocks of a
 *	small number of different sizes, and keeps free lists of each size.
 *	Blocks that don't exactly fit are passed up to the next larger size.
 *	Blocks over a certain size are directly allocated from the system.
 *
 * Copyright (c) 1983 Regents of the University of California.
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAlloc.c,v 1.21 2004/10/06 12:44:52 dkf Exp $
 */

/*
 * Windows and Unix use an alternative allocator when building with threads
 * that has significantly reduced lock contention.
 */

#include "tclInt.h"
#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)

#if USE_TCLALLOC

#ifdef TCL_DEBUG
#   define DEBUG
/* #define MSTATS */
#   define RCHECK
#endif

/*
 * We should really make use of AC_CHECK_TYPE(caddr_t)
 * here, but it can wait until Tcl uses config.h properly.
 */

#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)
typedef unsigned long caddr_t;
#endif

/*
 * The overhead on a block is at least 8 bytes.  When free, this space
 * contains a pointer to the next free block, and the bottom two bits must * be zero.  When in use, the first byte is set to MAGIC, and the second

 * byte is the size index.  The remaining bytes are for alignment.
 * If range checking is enabled then a second word holds the size of the
 * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC).
 * The order of elements is critical: ov.magic must overlay the low order
 * bits of ov.next, and ov.magic can not be a valid ov.next bit pattern.
 */

union overhead {
    union overhead *next;		/* when free */
    unsigned char padding[8];		/* Ensure the structure is 8-byte
					 * aligned. */
    struct {
	unsigned char magic0;		/* magic number */
	unsigned char index;		/* bucket # */
	unsigned char unused;		/* unused */
	unsigned char magic1;		/* other magic number */
#ifdef RCHECK
	unsigned short rmagic;		/* range magic number */
	unsigned long size;		/* actual block size */
	unsigned short unused2;		/* padding to 8-byte align */
#endif
   } ovu;
#define overMagic0	ovu.magic0
#define overMagic1	ovu.magic1
#define bucketIndex	ovu.index
#define rangeCheckMagic	ovu.rmagic
#define realBlockSize	ovu.size
};


#define MAGIC		0xef		/* magic # on accounting info */
#define RMAGIC		0x5555		/* magic # on range info */

#ifdef RCHECK
#define	RSLOP		sizeof (unsigned short)
#else
#define	RSLOP		0
#endif

#define OVERHEAD (sizeof(union overhead) + RSLOP)

/*
 * Macro to make it easier to refer to the end-of-block guard magic.
 */

#define BLOCK_END(overPtr) \
    (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize))

/*
 * nextf[i] is the pointer to the next free block of size 2^(i+3).  The
 * smallest allocatable block is 8 bytes.  The overhead information
 * precedes the data area returned to the user.
 */

#define NBUCKETS	13
#define MAXMALLOC	(1<<(NBUCKETS+2))
static	union overhead *nextf[NBUCKETS];

/* 
 * The following structure is used to keep track of all system memory 
 * currently owned by Tcl.  When finalizing, all this memory will
 * be returned to the system.
 */

struct block {
    struct block *nextPtr;	/* Linked list. */
    struct block *prevPtr;	/* Linked list for big blocks, ensures 8-byte 
				 * alignment for suballocated blocks. */
};

static struct block *blockList;		/* Tracks the suballocated blocks. */
static struct block bigBlocks = {	/* Big blocks aren't suballocated. */
    &bigBlocks, &bigBlocks
};

/*
 * The allocator is protected by a special mutex that must be
 * explicitly initialized.  Futhermore, because Tcl_Alloc may be
 * used before anything else in Tcl, we make this module self-initializing
 * after all with the allocInit variable.
 */

#ifdef TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
static int allocInit = 0;


#ifdef MSTATS

/*
 * numMallocs[i] is the difference between the number of mallocs and frees
 * for a given block size.
 */

static	unsigned int numMallocs[NBUCKETS+1];
#include <stdio.h>
#endif

#if defined(DEBUG) || defined(RCHECK)
#define	ASSERT(p)   if (!(p)) Tcl_Panic(# p)
#define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p)
#else
#define	ASSERT(p)
#define RANGE_ASSERT(p)
#endif

/*
 * Prototypes for functions used only in this file.
 */

static void 		MoreCore _ANSI_ARGS_((int bucket));


/*
 *-------------------------------------------------------------------------
 *
 * TclInitAlloc --
 *
 *	Initialize the memory system.
|


|
|
|
|







|
|

|



















|
|

>





|
|
>
|
|
|
|
|



|
|
<

|
|
|
|

|
|
|










|
|

















|
|
|




|

|
|
|
|




|



|
|




|
|
|
|







<



|
|







|











<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

160
161
162
163
164
165
166
/*
 * tclAlloc.c --
 *
 *	This is a very fast storage allocator. It allocates blocks of a small
 *	number of different sizes, and keeps free lists of each size. Blocks
 *	that don't exactly fit are passed up to the next larger size. Blocks
 *	over a certain size are directly allocated from the system.
 *
 * Copyright (c) 1983 Regents of the University of California.
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAlloc.c,v 1.21.2.1 2005/08/02 18:15:09 dgp Exp $
 */

/*
 * Windows and Unix use an alternative allocator when building with threads
 * that has significantly reduced lock contention.
 */

#include "tclInt.h"
#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)

#if USE_TCLALLOC

#ifdef TCL_DEBUG
#   define DEBUG
/* #define MSTATS */
#   define RCHECK
#endif

/*
 * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait
 * until Tcl uses config.h properly.
 */

#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)
typedef unsigned long caddr_t;
#endif

/*
 * The overhead on a block is at least 8 bytes. When free, this space contains
 * a pointer to the next free block, and the bottom two bits must be zero.
 * When in use, the first byte is set to MAGIC, and the second byte is the
 * size index. The remaining bytes are for alignment. If range checking is
 * enabled then a second word holds the size of the requested block, less 1,
 * rounded up to a multiple of sizeof(RMAGIC). The order of elements is
 * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic
 * can not be a valid ov.next bit pattern.
 */

union overhead {
    union overhead *next;	/* when free */
    unsigned char padding[8];	/* Ensure the structure is 8-byte aligned. */

    struct {
	unsigned char magic0;	/* magic number */
	unsigned char index;	/* bucket # */
	unsigned char unused;	/* unused */
	unsigned char magic1;	/* other magic number */
#ifdef RCHECK
	unsigned short rmagic;	/* range magic number */
	unsigned long size;	/* actual block size */
	unsigned short unused2;	/* padding to 8-byte align */
#endif
   } ovu;
#define overMagic0	ovu.magic0
#define overMagic1	ovu.magic1
#define bucketIndex	ovu.index
#define rangeCheckMagic	ovu.rmagic
#define realBlockSize	ovu.size
};


#define MAGIC		0xef	/* magic # on accounting info */
#define RMAGIC		0x5555	/* magic # on range info */

#ifdef RCHECK
#define	RSLOP		sizeof (unsigned short)
#else
#define	RSLOP		0
#endif

#define OVERHEAD (sizeof(union overhead) + RSLOP)

/*
 * Macro to make it easier to refer to the end-of-block guard magic.
 */

#define BLOCK_END(overPtr) \
    (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize))

/*
 * nextf[i] is the pointer to the next free block of size 2^(i+3). The
 * smallest allocatable block is 8 bytes. The overhead information precedes
 * the data area returned to the user.
 */

#define NBUCKETS	13
#define MAXMALLOC	(1<<(NBUCKETS+2))
static union overhead *nextf[NBUCKETS];

/*
 * The following structure is used to keep track of all system memory
 * currently owned by Tcl. When finalizing, all this memory will be returned
 * to the system.
 */

struct block {
    struct block *nextPtr;	/* Linked list. */
    struct block *prevPtr;	/* Linked list for big blocks, ensures 8-byte
				 * alignment for suballocated blocks. */
};

static struct block *blockList;	/* Tracks the suballocated blocks. */
static struct block bigBlocks={	/* Big blocks aren't suballocated. */
    &bigBlocks, &bigBlocks
};

/*
 * The allocator is protected by a special mutex that must be explicitly
 * initialized. Futhermore, because Tcl_Alloc may be used before anything else
 * in Tcl, we make this module self-initializing after all with the allocInit
 * variable.
 */

#ifdef TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
static int allocInit = 0;


#ifdef MSTATS

/*
 * numMallocs[i] is the difference between the number of mallocs and frees for
 * a given block size.
 */

static	unsigned int numMallocs[NBUCKETS+1];
#include <stdio.h>
#endif

#if defined(DEBUG) || defined(RCHECK)
#define	ASSERT(p)	if (!(p)) Tcl_Panic(# p)
#define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p)
#else
#define	ASSERT(p)
#define RANGE_ASSERT(p)
#endif

/*
 * Prototypes for functions used only in this file.
 */

static void 		MoreCore _ANSI_ARGS_((int bucket));


/*
 *-------------------------------------------------------------------------
 *
 * TclInitAlloc --
 *
 *	Initialize the memory system.
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
}

/*
 *-------------------------------------------------------------------------
 *
 * TclFinalizeAllocSubsystem --
 *
 *	Release all resources being used by this subsystem, including 
 *	aggressively freeing all memory allocated by TclpAlloc() that 
 *	has not yet been released with TclpFree().
 *	
 *	After this function is called, all memory allocated with 
 *	TclpAlloc() should be considered unusable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This subsystem is self-initializing, since memory can be 
 *	allocated before Tcl is formally initialized.  After this call,
 *	this subsystem has been reset to its initial state and is 
 *	usable again.
 *
 *-------------------------------------------------------------------------
 */

void
TclFinalizeAllocSubsystem()
{







|
|
|
|
|
|





|
|
|
<







186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206

207
208
209
210
211
212
213
}

/*
 *-------------------------------------------------------------------------
 *
 * TclFinalizeAllocSubsystem --
 *
 *	Release all resources being used by this subsystem, including
 *	aggressively freeing all memory allocated by TclpAlloc() that has not
 *	yet been released with TclpFree().
 *
 *	After this function is called, all memory allocated with TclpAlloc()
 *	should be considered unusable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This subsystem is self-initializing, since memory can be allocated
 *	before Tcl is formally initialized. After this call, this subsystem
 *	has been reset to its initial state and is usable again.

 *
 *-------------------------------------------------------------------------
 */

void
TclFinalizeAllocSubsystem()
{
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
	nextPtr = blockPtr->nextPtr;
	TclpSysFree(blockPtr);
	blockPtr = nextPtr;
    }
    bigBlocks.nextPtr = &bigBlocks;
    bigBlocks.prevPtr = &bigBlocks;

    for (i = 0; i < NBUCKETS; i++) {
	nextf[i] = NULL;
#ifdef MSTATS
	numMallocs[i] = 0;
#endif
    }
#ifdef MSTATS
    numMallocs[i] = 0;







|







225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
	nextPtr = blockPtr->nextPtr;
	TclpSysFree(blockPtr);
	blockPtr = nextPtr;
    }
    bigBlocks.nextPtr = &bigBlocks;
    bigBlocks.prevPtr = &bigBlocks;

    for (i=0 ; i<NBUCKETS ; i++) {
	nextf[i] = NULL;
#ifdef MSTATS
	numMallocs[i] = 0;
#endif
    }
#ifdef MSTATS
    numMallocs[i] = 0;
266
267
268
269
270
271
272
273
274
275
276

277
278
279

280
281
282

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

301
302
303
304
305

306
307
308
309

310
311
312

313
314
315
316
317

318
319
320
321
322
323
324

325
326
327
328
329
330
331
332
333
334
335
336
337
338

339
340
341
342
343
344
345

346
347
348

349
350
351

352
353
354

355
356
357
358
359

360
361
362
363

364
365
366
367
368
369
370
    register union overhead *overPtr;
    register long bucket;
    register unsigned amount;
    struct block *bigBlockPtr;

    if (!allocInit) {
	/*
	 * We have to make the "self initializing" because Tcl_Alloc
	 * may be used before any other part of Tcl.  E.g., see
	 * main() for tclsh!
	 */

	TclInitAlloc();
    }
    Tcl_MutexLock(allocMutexPtr);

    /*
     * First the simple case: we simple allocate big blocks directly
     */

    if (numBytes + OVERHEAD >= MAXMALLOC) {
	bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) 
		(sizeof(struct block) + OVERHEAD + numBytes), 0);
	if (bigBlockPtr == NULL) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return NULL;
	}
	bigBlockPtr->nextPtr = bigBlocks.nextPtr;
	bigBlocks.nextPtr = bigBlockPtr;
	bigBlockPtr->prevPtr = &bigBlocks;
	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;

	overPtr = (union overhead *) (bigBlockPtr + 1);
	overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
	overPtr->bucketIndex = 0xff;
#ifdef MSTATS
	numMallocs[NBUCKETS]++;
#endif

#ifdef RCHECK
	/*
	 * Record allocated size of block and
	 * bound space with magic numbers.
	 */

	overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
	overPtr->rangeCheckMagic = RMAGIC;
	BLOCK_END(overPtr) = RMAGIC;
#endif

	Tcl_MutexUnlock(allocMutexPtr);
	return (void *)(overPtr+1);
    }

    /*
     * Convert amount of memory requested into closest block size
     * stored in hash buckets which satisfies request.
     * Account for space used per block for accounting.
     */

#ifndef RCHECK
    amount = 8;		/* size of first bucket */
    bucket = 0;
#else
    amount = 16;	/* size of first bucket */
    bucket = 1;
#endif

    while (numBytes + OVERHEAD > amount) {
	amount <<= 1;
	if (amount == 0) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return (NULL);
	}
	bucket++;
    }
    ASSERT(bucket < NBUCKETS);

    /*
     * If nothing in hash bucket right now,
     * request more memory from the system.
     */

    if ((overPtr = nextf[bucket]) == NULL) {
	MoreCore(bucket);
	if ((overPtr = nextf[bucket]) == NULL) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return (NULL);
	}
    }

    /*
     * Remove from linked list
     */

    nextf[bucket] = overPtr->next;
    overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
    overPtr->bucketIndex = (unsigned char) bucket;

#ifdef MSTATS
    numMallocs[bucket]++;
#endif

#ifdef RCHECK
    /*
     * Record allocated size of block and
     * bound space with magic numbers.
     */

    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
    overPtr->rangeCheckMagic = RMAGIC;
    BLOCK_END(overPtr) = RMAGIC;
#endif

    Tcl_MutexUnlock(allocMutexPtr);
    return ((char *)(overPtr + 1));
}

/*
 *----------------------------------------------------------------------
 *







|
|
<

>



>

|

>

|
















>


|
<

>




>



>

|
|
|

>







>




|






|
|

>




|


>



>



>



>


|
<

>




>







264
265
266
267
268
269
270
271
272

273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367

368
369
370
371
372
373
374
375
376
377
378
379
380
381
    register union overhead *overPtr;
    register long bucket;
    register unsigned amount;
    struct block *bigBlockPtr;

    if (!allocInit) {
	/*
	 * We have to make the "self initializing" because Tcl_Alloc may be
	 * used before any other part of Tcl.  E.g., see main() for tclsh!

	 */

	TclInitAlloc();
    }
    Tcl_MutexLock(allocMutexPtr);

    /*
     * First the simple case: we simple allocate big blocks directly.
     */

    if (numBytes + OVERHEAD >= MAXMALLOC) {
	bigBlockPtr = (struct block *) TclpSysAlloc((unsigned)
		(sizeof(struct block) + OVERHEAD + numBytes), 0);
	if (bigBlockPtr == NULL) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return NULL;
	}
	bigBlockPtr->nextPtr = bigBlocks.nextPtr;
	bigBlocks.nextPtr = bigBlockPtr;
	bigBlockPtr->prevPtr = &bigBlocks;
	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;

	overPtr = (union overhead *) (bigBlockPtr + 1);
	overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
	overPtr->bucketIndex = 0xff;
#ifdef MSTATS
	numMallocs[NBUCKETS]++;
#endif

#ifdef RCHECK
	/*
	 * Record allocated size of block and bound space with magic numbers.

	 */

	overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
	overPtr->rangeCheckMagic = RMAGIC;
	BLOCK_END(overPtr) = RMAGIC;
#endif

	Tcl_MutexUnlock(allocMutexPtr);
	return (void *)(overPtr+1);
    }

    /*
     * Convert amount of memory requested into closest block size stored in
     * hash buckets which satisfies request. Account for space used per block
     * for accounting.
     */

#ifndef RCHECK
    amount = 8;		/* size of first bucket */
    bucket = 0;
#else
    amount = 16;	/* size of first bucket */
    bucket = 1;
#endif

    while (numBytes + OVERHEAD > amount) {
	amount <<= 1;
	if (amount == 0) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return NULL;
	}
	bucket++;
    }
    ASSERT(bucket < NBUCKETS);

    /*
     * If nothing in hash bucket right now, request more memory from the
     * system.
     */

    if ((overPtr = nextf[bucket]) == NULL) {
	MoreCore(bucket);
	if ((overPtr = nextf[bucket]) == NULL) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return NULL;
	}
    }

    /*
     * Remove from linked list
     */

    nextf[bucket] = overPtr->next;
    overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
    overPtr->bucketIndex = (unsigned char) bucket;

#ifdef MSTATS
    numMallocs[bucket]++;
#endif

#ifdef RCHECK
    /*
     * Record allocated size of block and bound space with magic numbers.

     */

    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
    overPtr->rangeCheckMagic = RMAGIC;
    BLOCK_END(overPtr) = RMAGIC;
#endif

    Tcl_MutexUnlock(allocMutexPtr);
    return ((char *)(overPtr + 1));
}

/*
 *----------------------------------------------------------------------
 *
390
391
392
393
394
395
396
397
398
399

400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421

422
423
424
425
426
427
428
    register union overhead *overPtr;
    register long size;		/* size of desired block */
    long amount;		/* amount to allocate */
    int numBlocks;		/* how many blocks we get */
    struct block *blockPtr;

    /*
     * sbrk_size <= 0 only for big, FLUFFY, requests (about
     * 2^30 bytes on a VAX, I think) or for a negative arg.
     */

    size = 1 << (bucket + 3);
    ASSERT(size > 0);

    amount = MAXMALLOC;
    numBlocks = amount / size;
    ASSERT(numBlocks*size == amount);

    blockPtr = (struct block *) TclpSysAlloc((unsigned) 
	    (sizeof(struct block) + amount), 1);
    /* no more room! */
    if (blockPtr == NULL) {
	return;
    }
    blockPtr->nextPtr = blockList;
    blockList = blockPtr;

    overPtr = (union overhead *) (blockPtr + 1);
    
    /*
     * Add new memory allocated to that on
     * free list for this hash bucket.
     */

    nextf[bucket] = overPtr;
    while (--numBlocks > 0) {
	overPtr->next = (union overhead *)((caddr_t)overPtr + size);
	overPtr = (union overhead *)((caddr_t)overPtr + size);
    }
    overPtr->next = (union overhead *)NULL;
}







|
|

>







|









|

|
<

>







401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431

432
433
434
435
436
437
438
439
440
    register union overhead *overPtr;
    register long size;		/* size of desired block */
    long amount;		/* amount to allocate */
    int numBlocks;		/* how many blocks we get */
    struct block *blockPtr;

    /*
     * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a
     * VAX, I think) or for a negative arg.
     */

    size = 1 << (bucket + 3);
    ASSERT(size > 0);

    amount = MAXMALLOC;
    numBlocks = amount / size;
    ASSERT(numBlocks*size == amount);

    blockPtr = (struct block *) TclpSysAlloc((unsigned)
	    (sizeof(struct block) + amount), 1);
    /* no more room! */
    if (blockPtr == NULL) {
	return;
    }
    blockPtr->nextPtr = blockList;
    blockList = blockPtr;

    overPtr = (union overhead *) (blockPtr + 1);

    /*
     * Add new memory allocated to that on free list for this hash bucket.

     */

    nextf[bucket] = overPtr;
    while (--numBlocks > 0) {
	overPtr->next = (union overhead *)((caddr_t)overPtr + size);
	overPtr = (union overhead *)((caddr_t)overPtr + size);
    }
    overPtr->next = (union overhead *)NULL;
}
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
 *
 *----------------------------------------------------------------------
 */

void
TclpFree(oldPtr)
    char *oldPtr;		/* Pointer to memory to free. */
{   
    register long size;
    register union overhead *overPtr;
    struct block *bigBlockPtr;

    if (oldPtr == NULL) {
	return;
    }







|







454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
 *
 *----------------------------------------------------------------------
 */

void
TclpFree(oldPtr)
    char *oldPtr;		/* Pointer to memory to free. */
{
    register long size;
    register union overhead *overPtr;
    struct block *bigBlockPtr;

    if (oldPtr == NULL) {
	return;
    }
468
469
470
471
472
473
474

475
476
477
478

479
480
481
482
483
484

485
486
487

488
489
490
491
492
493
494
    RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
    RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
    size = overPtr->bucketIndex;
    if (size == 0xff) {
#ifdef MSTATS
	numMallocs[NBUCKETS]--;
#endif

	bigBlockPtr = (struct block *) overPtr - 1;
	bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
	TclpSysFree(bigBlockPtr);

	Tcl_MutexUnlock(allocMutexPtr);
	return;
    }
    ASSERT(size < NBUCKETS);
    overPtr->next = nextf[size];	/* also clobbers overMagic */
    nextf[size] = overPtr;

#ifdef MSTATS
    numMallocs[size]--;
#endif

    Tcl_MutexUnlock(allocMutexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpRealloc --







>




>






>



>







480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
    RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
    RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
    size = overPtr->bucketIndex;
    if (size == 0xff) {
#ifdef MSTATS
	numMallocs[NBUCKETS]--;
#endif

	bigBlockPtr = (struct block *) overPtr - 1;
	bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
	TclpSysFree(bigBlockPtr);

	Tcl_MutexUnlock(allocMutexPtr);
	return;
    }
    ASSERT(size < NBUCKETS);
    overPtr->next = nextf[size];	/* also clobbers overMagic */
    nextf[size] = overPtr;

#ifdef MSTATS
    numMallocs[size]--;
#endif

    Tcl_MutexUnlock(allocMutexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpRealloc --
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
 *----------------------------------------------------------------------
 */

char *
TclpRealloc(oldPtr, numBytes)
    char *oldPtr;		/* Pointer to alloced block. */
    unsigned int numBytes;	/* New size of memory. */
{   
    int i;
    union overhead *overPtr;
    struct block *bigBlockPtr;
    int expensive;
    unsigned long maxSize;

    if (oldPtr == NULL) {
	return (TclpAlloc(numBytes));
    }

    Tcl_MutexLock(allocMutexPtr);

    overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead));

    ASSERT(overPtr->overMagic0 == MAGIC);	/* make sure it was in use */







|







|







520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
 *----------------------------------------------------------------------
 */

char *
TclpRealloc(oldPtr, numBytes)
    char *oldPtr;		/* Pointer to alloced block. */
    unsigned int numBytes;	/* New size of memory. */
{
    int i;
    union overhead *overPtr;
    struct block *bigBlockPtr;
    int expensive;
    unsigned long maxSize;

    if (oldPtr == NULL) {
	return TclpAlloc(numBytes);
    }

    Tcl_MutexLock(allocMutexPtr);

    overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead));

    ASSERT(overPtr->overMagic0 == MAGIC);	/* make sure it was in use */
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563

564
565
566

567
568
569
570
571
572
573
574

575
576
577
578
579
580
581
     */

    if (i == 0xff) {
	struct block *prevPtr, *nextPtr;
	bigBlockPtr = (struct block *) overPtr - 1;
	prevPtr = bigBlockPtr->prevPtr;
	nextPtr = bigBlockPtr->nextPtr;
	bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, 
		sizeof(struct block) + OVERHEAD + numBytes);
	if (bigBlockPtr == NULL) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return NULL;
	}

	if (prevPtr->nextPtr != bigBlockPtr) {
	    /*
	     * If the block has moved, splice the new block into the list where
	     * the old block used to be. 
	     */

	    prevPtr->nextPtr = bigBlockPtr;
	    nextPtr->prevPtr = bigBlockPtr;
	}

	overPtr = (union overhead *) (bigBlockPtr + 1);

#ifdef MSTATS
	numMallocs[NBUCKETS]++;
#endif

#ifdef RCHECK
	/*
	 * Record allocated size of block and update magic number bounds.
	 */

	overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
	BLOCK_END(overPtr) = RMAGIC;
#endif

	Tcl_MutexUnlock(allocMutexPtr);
	return (char *)(overPtr+1);
    }
    maxSize = 1 << (i+3);
    expensive = 0;
    if (numBytes+OVERHEAD > maxSize) {
	expensive = 1;







|








|
|







>



>








>







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
     */

    if (i == 0xff) {
	struct block *prevPtr, *nextPtr;
	bigBlockPtr = (struct block *) overPtr - 1;
	prevPtr = bigBlockPtr->prevPtr;
	nextPtr = bigBlockPtr->nextPtr;
	bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
		sizeof(struct block) + OVERHEAD + numBytes);
	if (bigBlockPtr == NULL) {
	    Tcl_MutexUnlock(allocMutexPtr);
	    return NULL;
	}

	if (prevPtr->nextPtr != bigBlockPtr) {
	    /*
	     * If the block has moved, splice the new block into the list
	     * where the old block used to be.
	     */

	    prevPtr->nextPtr = bigBlockPtr;
	    nextPtr->prevPtr = bigBlockPtr;
	}

	overPtr = (union overhead *) (bigBlockPtr + 1);

#ifdef MSTATS
	numMallocs[NBUCKETS]++;
#endif

#ifdef RCHECK
	/*
	 * Record allocated size of block and update magic number bounds.
	 */

	overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
	BLOCK_END(overPtr) = RMAGIC;
#endif

	Tcl_MutexUnlock(allocMutexPtr);
	return (char *)(overPtr+1);
    }
    maxSize = 1 << (i+3);
    expensive = 0;
    if (numBytes+OVERHEAD > maxSize) {
	expensive = 1;
596
597
598
599
600
601
602
603
604
605
606

607
608
609
610

611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642

643
644
645
646
647
648
649

650
651
652
653
654

655
656
657
658

659
660
661
662
663
664
665
	if (maxSize < numBytes) {
	    numBytes = maxSize;
	}
	memcpy((VOID *) newPtr, (VOID *) oldPtr, (size_t) numBytes);
	TclpFree(oldPtr);
	return newPtr;
    }
    
    /*
     * Ok, we don't have to copy, it fits as-is
     */

#ifdef RCHECK
    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
    BLOCK_END(overPtr) = RMAGIC;
#endif

    Tcl_MutexUnlock(allocMutexPtr);
    return(oldPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * mstats --
 *
 *	Prints two lines of numbers, one showing the length of the 
 *	free list for each size category, the second showing the 
 *	number of mallocs - frees for each size category.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef MSTATS
void
mstats(s)
    char *s;	/* Where to write info. */
{
    register int i, j;
    register union overhead *overPtr;
    int totalFree = 0, totalUsed = 0;

    Tcl_MutexLock(allocMutexPtr);

    fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
    for (i = 0; i < NBUCKETS; i++) {
	for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
	    fprintf(stderr, " %d", j);
	}
	totalFree += j * (1 << (i + 3));
    }

    fprintf(stderr, "\nused:\t");
    for (i = 0; i < NBUCKETS; i++) {
	fprintf(stderr, " %d", numMallocs[i]);
	totalUsed += numMallocs[i] * (1 << (i + 3));
    }

    fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
	    totalUsed, totalFree);
    fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", 
	    MAXMALLOC, numMallocs[NBUCKETS]);

    Tcl_MutexUnlock(allocMutexPtr);
}
#endif

#else  /* !USE_TCLALLOC */

/*







|



>




>









|
|
|













|






>







>





>


|

>







615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
	if (maxSize < numBytes) {
	    numBytes = maxSize;
	}
	memcpy((VOID *) newPtr, (VOID *) oldPtr, (size_t) numBytes);
	TclpFree(oldPtr);
	return newPtr;
    }

    /*
     * Ok, we don't have to copy, it fits as-is
     */

#ifdef RCHECK
    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
    BLOCK_END(overPtr) = RMAGIC;
#endif

    Tcl_MutexUnlock(allocMutexPtr);
    return(oldPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * mstats --
 *
 *	Prints two lines of numbers, one showing the length of the free list
 *	for each size category, the second showing the number of mallocs -
 *	frees for each size category.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef MSTATS
void
mstats(s)
    char *s;			/* Where to write info. */
{
    register int i, j;
    register union overhead *overPtr;
    int totalFree = 0, totalUsed = 0;

    Tcl_MutexLock(allocMutexPtr);

    fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
    for (i = 0; i < NBUCKETS; i++) {
	for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
	    fprintf(stderr, " %d", j);
	}
	totalFree += j * (1 << (i + 3));
    }

    fprintf(stderr, "\nused:\t");
    for (i = 0; i < NBUCKETS; i++) {
	fprintf(stderr, " %d", numMallocs[i]);
	totalUsed += numMallocs[i] * (1 << (i + 3));
    }

    fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
	    totalUsed, totalFree);
    fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
	    MAXMALLOC, numMallocs[NBUCKETS]);

    Tcl_MutexUnlock(allocMutexPtr);
}
#endif

#else  /* !USE_TCLALLOC */

/*
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
 *
 *----------------------------------------------------------------------
 */

void
TclpFree(oldPtr)
    char *oldPtr;		/* Pointer to memory to free. */
{   
    free(oldPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *







|







725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
 *
 *----------------------------------------------------------------------
 */

void
TclpFree(oldPtr)
    char *oldPtr;		/* Pointer to memory to free. */
{
    free(oldPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *
725
726
727
728
729
730
731
732
733
734
735
736
737








 *----------------------------------------------------------------------
 */

char *
TclpRealloc(oldPtr, numBytes)
    char *oldPtr;		/* Pointer to alloced block. */
    unsigned int numBytes;	/* New size of memory. */
{   
    return (char*) realloc(oldPtr, numBytes);
}

#endif /* !USE_TCLALLOC */
#endif /* !TCL_THREADS */















|





>
>
>
>
>
>
>
>
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
 *----------------------------------------------------------------------
 */

char *
TclpRealloc(oldPtr, numBytes)
    char *oldPtr;		/* Pointer to alloced block. */
    unsigned int numBytes;	/* New size of memory. */
{
    return (char*) realloc(oldPtr, numBytes);
}

#endif /* !USE_TCLALLOC */
#endif /* !TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclAsync.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
/* 
 * tclAsync.c --
 *
 *	This file provides low-level support needed to invoke signal
 *	handlers in a safe way.  The code here doesn't actually handle
 *	signals, though.  This code is based on proposals made by
 *	Mark Diekhans and Don Libes.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAsync.c,v 1.7 2004/04/06 22:25:48 dgp Exp $
 */

#include "tclInt.h"

/* Forward declaration */
struct ThreadSpecificData;

/*
 * One of the following structures exists for each asynchronous
 * handler:
 */

typedef struct AsyncHandler {
    int ready;				/* Non-zero means this handler should
					 * be invoked in the next call to
					 * Tcl_AsyncInvoke. */
    struct AsyncHandler *nextPtr;	/* Next in list of all handlers for

					 * the process. */
    Tcl_AsyncProc *proc;		/* Procedure to call when handler
					 * is invoked. */
    ClientData clientData;		/* Value to pass to handler when it
					 * is invoked. */
    struct ThreadSpecificData *originTsd;
					/* Used in Tcl_AsyncMark to modify thread-
					 * specific data from outside the thread
					 * it is associated to. */
    Tcl_ThreadId originThrdId;		/* Origin thread where this token was
					 * created and where it will be
					 * yielded. */
} AsyncHandler;


typedef struct ThreadSpecificData {
    /*
     * The variables below maintain a list of all existing handlers
     * specific to the calling thread.
     */
    AsyncHandler *firstHandler;	    /* First handler defined for process,
				     * or NULL if none. */
    AsyncHandler *lastHandler;	    /* Last handler or NULL. */

    /*
     * The variable below is set to 1 whenever a handler becomes ready and
     * it is cleared to zero whenever Tcl_AsyncInvoke is called.  It can be
     * checked elsewhere in the application by calling Tcl_AsyncReady to see

     * if Tcl_AsyncInvoke should be invoked.
     */

    int asyncReady;

    /*
     * The variable below indicates whether Tcl_AsyncInvoke is currently
     * working.  If so then we won't set asyncReady again until
     * Tcl_AsyncInvoke returns.
     */

    int asyncActive;

    Tcl_Mutex asyncMutex;   /* Thread-specific AsyncHandler linked-list lock */

} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;


/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAsync --
 *
 *	Finalizes the mutex in the thread local data structure for the
 *	async subsystem.
 *
 * Results:
 *	None.	
 *
 * Side effects:
 *	Forgets knowledge of the mutex should it have been created.
 *
 *----------------------------------------------------------------------
 */

|


|
|
|
<




|
|

|








|
<



|
|
|
|
>
|
|
|
|
|

|
|
|
|
|
<

<



|
|

|
|
|
|
<
|
|
|
>
|
<
<
<
<
<
|
|
|
<
|
<
<
|
|


<






|
|


|







1
2
3
4
5
6

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

43

44
45
46
47
48
49
50
51
52
53

54
55
56
57
58





59
60
61

62


63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
/*
 * tclAsync.c --
 *
 *	This file provides low-level support needed to invoke signal handlers
 *	in a safe way. The code here doesn't actually handle signals, though.
 *	This code is based on proposals made by Mark Diekhans and Don Libes.

 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAsync.c,v 1.7.2.1 2005/08/02 18:15:10 dgp Exp $
 */

#include "tclInt.h"

/* Forward declaration */
struct ThreadSpecificData;

/*
 * One of the following structures exists for each asynchronous handler:

 */

typedef struct AsyncHandler {
    int ready;			/* Non-zero means this handler should be
				 * invoked in the next call to
				 * Tcl_AsyncInvoke. */
    struct AsyncHandler *nextPtr;
				/* Next in list of all handlers for the
				 * process. */
    Tcl_AsyncProc *proc;	/* Procedure to call when handler is
				 * invoked. */
    ClientData clientData;	/* Value to pass to handler when it is
				 * invoked. */
    struct ThreadSpecificData *originTsd;
				/* Used in Tcl_AsyncMark to modify thread-
				 * specific data from outside the thread it is
				 * associated to. */
    Tcl_ThreadId originThrdId;	/* Origin thread where this token was created
				 * and where it will be yielded. */

} AsyncHandler;


typedef struct ThreadSpecificData {
    /*
     * The variables below maintain a list of all existing handlers specific
     * to the calling thread.
     */
    AsyncHandler *firstHandler;	/* First handler defined for process, or NULL
				 * if none. */
    AsyncHandler *lastHandler;	/* Last handler or NULL. */
    int asyncReady;		/* This is set to 1 whenever a handler becomes

				 * ready and it is cleared to zero whenever
				 * Tcl_AsyncInvoke is called.  It can be
				 * checked elsewhere in the application by
				 * calling Tcl_AsyncReady to see if
				 * Tcl_AsyncInvoke should be invoked. */





    int asyncActive;		/* Indicates whether Tcl_AsyncInvoke is
				 * currently working.  If so then we won't set
				 * asyncReady again until Tcl_AsyncInvoke

				 * returns. */


    Tcl_Mutex asyncMutex;	/* Thread-specific AsyncHandler linked-list
				 * lock */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;


/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAsync --
 *
 *	Finalizes the mutex in the thread local data structure for the async
 *	subsystem.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Forgets knowledge of the mutex should it have been created.
 *
 *----------------------------------------------------------------------
 */

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncCreate --
 *
 *	This procedure creates the data structures for an asynchronous
 *	handler, so that no memory has to be allocated when the handler
 *	is activated.
 *
 * Results:
 *	The return value is a token for the handler, which can be used
 *	to activate it later on.
 *
 * Side effects:
 *	Information about the handler is recorded.
 *
 *----------------------------------------------------------------------
 */

Tcl_AsyncHandler
Tcl_AsyncCreate(proc, clientData)
    Tcl_AsyncProc *proc;		/* Procedure to call when handler
					 * is invoked. */
    ClientData clientData;		/* Argument to pass to handler. */
{
    AsyncHandler *asyncPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
    asyncPtr->ready = 0;
    asyncPtr->nextPtr = NULL;







|
|


|
|









|
|
|







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncCreate --
 *
 *	This procedure creates the data structures for an asynchronous
 *	handler, so that no memory has to be allocated when the handler is
 *	activated.
 *
 * Results:
 *	The return value is a token for the handler, which can be used to
 *	activate it later on.
 *
 * Side effects:
 *	Information about the handler is recorded.
 *
 *----------------------------------------------------------------------
 */

Tcl_AsyncHandler
Tcl_AsyncCreate(proc, clientData)
    Tcl_AsyncProc *proc;	/* Procedure to call when handler is
				 * invoked. */
    ClientData clientData;	/* Argument to pass to handler. */
{
    AsyncHandler *asyncPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
    asyncPtr->ready = 0;
    asyncPtr->nextPtr = NULL;
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncMark --
 *
 *	This procedure is called to request that an asynchronous handler
 *	be invoked as soon as possible.  It's typically called from
 *	an interrupt handler, where it isn't safe to do anything that
 *	depends on or modifies application state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The handler gets marked for invocation later.
 *







|
|
|
|







140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncMark --
 *
 *	This procedure is called to request that an asynchronous handler be
 *	invoked as soon as possible.  It's typically called from an interrupt
 *	handler, where it isn't safe to do anything that depends on or
 *	modifies application state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The handler gets marked for invocation later.
 *
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncInvoke --
 *
 *	This procedure is called at a "safe" time at background level
 *	to invoke any active asynchronous handlers.
 *
 * Results:
 *	The return value is a normal Tcl result, which is intended to
 *	replace the code argument as the current completion code for
 *	interp.
 *
 * Side effects:
 *	Depends on the handlers that are active.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AsyncInvoke(interp, code)
    Tcl_Interp *interp;			/* If invoked from Tcl_Eval just after
					 * completing a command, points to
					 * interpreter.  Otherwise it is
					 * NULL. */
    int code; 				/* If interp is non-NULL, this gives
					 * completion code from command that
					 * just completed. */
{
    AsyncHandler *asyncPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&tsdPtr->asyncMutex);

    if (tsdPtr->asyncReady == 0) {
	Tcl_MutexUnlock(&tsdPtr->asyncMutex);
	return code;
    }
    tsdPtr->asyncReady = 0;
    tsdPtr->asyncActive = 1;
    if (interp == NULL) {
	code = 0;
    }

    /*
     * Make one or more passes over the list of handlers, invoking
     * at most one handler in each pass.  After invoking a handler,
     * go back to the start of the list again so that (a) if a new
     * higher-priority handler gets marked while executing a lower
     * priority handler, we execute the higher-priority handler
     * next, and (b) if a handler gets deleted during the execution
     * of a handler, then the list structure may change so it isn't
     * safe to continue down the list anyway.
     */

    while (1) {
	for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL;
		asyncPtr = asyncPtr->nextPtr) {
	    if (asyncPtr->ready) {







|
|


|
|
<









|
|
|
<
|
|
|

















|
|
|
<
|
|
|







174
175
176
177
178
179
180
181
182
183
184
185
186

187
188
189
190
191
192
193
194
195
196
197
198

199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221

222
223
224
225
226
227
228
229
230
231
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncInvoke --
 *
 *	This procedure is called at a "safe" time at background level to
 *	invoke any active asynchronous handlers.
 *
 * Results:
 *	The return value is a normal Tcl result, which is intended to replace
 *	the code argument as the current completion code for interp.

 *
 * Side effects:
 *	Depends on the handlers that are active.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AsyncInvoke(interp, code)
    Tcl_Interp *interp;		/* If invoked from Tcl_Eval just after
				 * completing a command, points to
				 * interpreter.  Otherwise it is NULL. */

    int code;			/* If interp is non-NULL, this gives
				 * completion code from command that just
				 * completed. */
{
    AsyncHandler *asyncPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&tsdPtr->asyncMutex);

    if (tsdPtr->asyncReady == 0) {
	Tcl_MutexUnlock(&tsdPtr->asyncMutex);
	return code;
    }
    tsdPtr->asyncReady = 0;
    tsdPtr->asyncActive = 1;
    if (interp == NULL) {
	code = 0;
    }

    /*
     * Make one or more passes over the list of handlers, invoking at most one
     * handler in each pass. After invoking a handler, go back to the start of
     * the list again so that (a) if a new higher-priority handler gets marked

     * while executing a lower priority handler, we execute the higher-
     * priority handler next, and (b) if a handler gets deleted during the
     * execution of a handler, then the list structure may change so it isn't
     * safe to continue down the list anyway.
     */

    while (1) {
	for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL;
		asyncPtr = asyncPtr->nextPtr) {
	    if (asyncPtr->ready) {
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncDelete --
 *
 *	Frees up all the state for an asynchronous handler.  The handler
 *	should never be used again.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The state associated with the handler is deleted.
 *







|
|







246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncDelete --
 *
 *	Frees up all the state for an asynchronous handler. The handler should
 *	never be used again.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The state associated with the handler is deleted.
 *
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncReady --
 *
 *	This procedure can be used to tell whether Tcl_AsyncInvoke
 *	needs to be called.  This procedure is the external interface
 *	for checking the thread-specific asyncReady variable.
 *
 * Results:
 * 	The return value is 1 whenever a handler is ready and is 0
 *	when no handlers are ready.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AsyncReady()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    return tsdPtr->asyncReady;
}















|
|
|


|
|













>
>
>
>
>
>
>
>
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AsyncReady --
 *
 *	This procedure can be used to tell whether Tcl_AsyncInvoke needs to be
 *	called.  This procedure is the external interface for checking the
 *	thread-specific asyncReady variable.
 *
 * Results:
 *	The return value is 1 whenever a handler is ready and is 0 when no
 *	handlers are ready.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AsyncReady()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    return tsdPtr->asyncReady;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclBasic.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20



21
22












23
24
25
26
27
28
29
30
31




































32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
/* 
 * tclBasic.c --
 *
 *	Contains the basic facilities for TCL command interpretation,
 *	including interpreter creation and deletion, command creation
 *	and deletion, and command/script execution. 
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136 2004/11/30 19:34:46 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"




/*












 * Static procedures in this file:
 */

static char *		CallCommandTraces _ANSI_ARGS_((Interp *iPtr, 
			    Command *cmdPtr, CONST char *oldName, 
			    CONST char* newName, int flags));
static void		DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void		ProcessUnexpectedResult _ANSI_ARGS_((
			    Tcl_Interp *interp, int returnCode));





































extern TclStubs tclStubs;

/*
 * The following structure defines the commands in the Tcl core.
 */

typedef struct {
    char *name;			/* Name of object-based command. */
    Tcl_ObjCmdProc *objProc;	/* Object-based procedure for command. */
    CompileProc *compileProc;	/* Procedure called to compile command. */
    int isSafe;			/* If non-zero, command will be present
                                 * in safe interpreter. Otherwise it will
                                 * be hidden. */
} CmdInfo;

/*
 * The built-in commands, and the procedures that implement them:
 */

static CmdInfo builtInCmds[] = {
    /*
     * Commands in the generic core. 
     */

    {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	1},
    {"array",		Tcl_ArrayObjCmd,	(CompileProc *) NULL,	1},
    {"binary",		Tcl_BinaryObjCmd,	(CompileProc *) NULL,	1},
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	1},
    {"case",		Tcl_CaseObjCmd,		(CompileProc *) NULL,	1},
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	1},
    {"concat",		Tcl_ConcatObjCmd,	(CompileProc *) NULL,	1},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	1},
    {"dict",		Tcl_DictObjCmd,		(CompileProc *) NULL,	1},
    {"encoding",	Tcl_EncodingObjCmd,	(CompileProc *) NULL,	0},
    {"error",		Tcl_ErrorObjCmd,	(CompileProc *) NULL,	1},
    {"eval",		Tcl_EvalObjCmd,		(CompileProc *) NULL,	1},
    {"exit",		Tcl_ExitObjCmd,		(CompileProc *) NULL,	0},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	1},
    {"fcopy",		Tcl_FcopyObjCmd,	(CompileProc *) NULL,	1},
    {"fileevent",	Tcl_FileEventObjCmd,	(CompileProc *) NULL,	1},




|
|






|
|

|




>
>
>


>
>
>
>
>
>
>
>
>
>
>
>



<
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











|
|
|








|










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
/* 
 * tclBasic.c --
 *
 *	Contains the basic facilities for TCL command interpretation,
 *	including interpreter creation and deletion, command creation and
 *	deletion, and command/script execution.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.39 2005/10/04 13:49:36 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"

/*
 * The following structure defines the client data for a math function
 * registered with Tcl_CreateMathFunc
 */

typedef struct OldMathFuncData {
    Tcl_MathProc* proc;		/* Handler procedure */
    int numArgs;		/* Number of args expected */
    Tcl_ValueType* argTypes;	/* Types of the args */
    ClientData clientData;	/* Client data for the handler function */
} OldMathFuncData;

/*
 * Static procedures in this file:
 */


static char *	CallCommandTraces (Interp *iPtr, Command *cmdPtr,
		    CONST char *oldName, CONST char* newName, int flags);
static int	CheckDoubleResult (Tcl_Interp *interp, double dResult);
static void	DeleteInterpProc (Tcl_Interp *interp);
static void	ProcessUnexpectedResult (Tcl_Interp *interp, int returnCode);

static int	OldMathFuncProc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);

static void	OldMathFuncDeleteProc (ClientData clientData);

static int	ExprAbsFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprBinaryFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprBoolFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprCeilFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprDoubleFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprEntierFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprFloorFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprIntFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprRandFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprRoundFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprSqrtFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprSrandFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprUnaryFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static int	ExprWideFunc (ClientData clientData, Tcl_Interp *interp,
		    int argc, Tcl_Obj *CONST *objv);
static void	MathFuncWrongNumArgs (Tcl_Interp* interp, int expected,
		    int actual, Tcl_Obj *CONST *objv);

extern TclStubs tclStubs;

/*
 * The following structure defines the commands in the Tcl core.
 */

typedef struct {
    char *name;			/* Name of object-based command. */
    Tcl_ObjCmdProc *objProc;	/* Object-based procedure for command. */
    CompileProc *compileProc;	/* Procedure called to compile command. */
    int isSafe;			/* If non-zero, command will be present in
				 * safe interpreter. Otherwise it will be
				 * hidden. */
} CmdInfo;

/*
 * The built-in commands, and the procedures that implement them:
 */

static CmdInfo builtInCmds[] = {
    /*
     * Commands in the generic core.
     */

    {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	1},
    {"array",		Tcl_ArrayObjCmd,	(CompileProc *) NULL,	1},
    {"binary",		Tcl_BinaryObjCmd,	(CompileProc *) NULL,	1},
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	1},
    {"case",		Tcl_CaseObjCmd,		(CompileProc *) NULL,	1},
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	1},
    {"concat",		Tcl_ConcatObjCmd,	(CompileProc *) NULL,	1},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	1},
    {"dict",		Tcl_DictObjCmd,		TclCompileDictCmd,	1},
    {"encoding",	Tcl_EncodingObjCmd,	(CompileProc *) NULL,	0},
    {"error",		Tcl_ErrorObjCmd,	(CompileProc *) NULL,	1},
    {"eval",		Tcl_EvalObjCmd,		(CompileProc *) NULL,	1},
    {"exit",		Tcl_ExitObjCmd,		(CompileProc *) NULL,	0},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	1},
    {"fcopy",		Tcl_FcopyObjCmd,	(CompileProc *) NULL,	1},
    {"fileevent",	Tcl_FileEventObjCmd,	(CompileProc *) NULL,	1},
140
141
142
143
144
145
146









































147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
    {"vwait",		Tcl_VwaitObjCmd,	(CompileProc *) NULL,	1},
    {"exec",		Tcl_ExecObjCmd,		(CompileProc *) NULL,	0},
    {"source",		Tcl_SourceObjCmd,	(CompileProc *) NULL,	0},
#endif /* TCL_GENERIC_ONLY */
    {NULL,	(Tcl_ObjCmdProc *) NULL,	(CompileProc *) NULL,	0}
};











































/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateInterp --
 *
 *	Create a new TCL command interpreter.
 *
 * Results:
 *	The return value is a token for the interpreter, which may be
 *	used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
 *	Tcl_DeleteInterp.
 *
 * Side effects:
 *	The command interpreter is initialized with the built-in commands
 *      and with the variables documented in tclvars(n).
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateInterp()
{
    Interp *iPtr;
    Tcl_Interp *interp;
    Command *cmdPtr;
    BuiltinFunc *builtinFuncPtr;
    MathFunc *mathFuncPtr;
    Tcl_HashEntry *hPtr;
    const CmdInfo *cmdInfoPtr;

    int i;
    union {
	char c[sizeof(short)];
	short s;
    } order;
#ifdef TCL_COMPILE_STATS
    ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */

    TclInitSubsystems();

    /*
     * Panic if someone updated the CallFrame structure without
     * also updating the Tcl_CallFrame structure (or vice versa).
     */  

    if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
	/*NOTREACHED*/
        Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size");
    }

    /*
     * Initialize support for namespaces and create the global namespace
     * (whose name is ""; an alias is "::"). This also initializes the
     * Tcl object type table and other object management code.
     */

    iPtr = (Interp *) ckalloc(sizeof(Interp));
    interp = (Tcl_Interp *) iPtr;

    iPtr->result		= iPtr->resultSpace;
    iPtr->freeProc		= NULL;
    iPtr->errorLine		= 0;
    iPtr->objResultPtr		= Tcl_NewObj();
    Tcl_IncrRefCount(iPtr->objResultPtr);
    iPtr->handle		= TclHandleCreate(iPtr);
    iPtr->globalNsPtr		= NULL;
    iPtr->hiddenCmdTablePtr	= NULL;
    iPtr->interpInfo		= NULL;
    Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);

    iPtr->numLevels = 0;
    iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
    iPtr->framePtr = NULL;
    iPtr->varFramePtr = NULL;
    iPtr->activeVarTracePtr = NULL;

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
    Tcl_IncrRefCount(iPtr->eiVar);
    iPtr->errorCode = NULL;
    iPtr->ecVar = Tcl_NewStringObj("errorCode", -1);
    Tcl_IncrRefCount(iPtr->ecVar);
    iPtr->returnLevel = 0;
    iPtr->returnCode = TCL_OK;

    iPtr->appendResult = NULL;
    iPtr->appendAvl = 0;
    iPtr->appendUsed = 0;

    Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
|
<


|
|










|
<
<

>












|
|
|



|




|
|














<














|







190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263


264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
    {"vwait",		Tcl_VwaitObjCmd,	(CompileProc *) NULL,	1},
    {"exec",		Tcl_ExecObjCmd,		(CompileProc *) NULL,	0},
    {"source",		Tcl_SourceObjCmd,	(CompileProc *) NULL,	0},
#endif /* TCL_GENERIC_ONLY */
    {NULL,	(Tcl_ObjCmdProc *) NULL,	(CompileProc *) NULL,	0}
};

/*
 * Math functions
 */

typedef struct {
    CONST char* name;		/* Name of the function */
    Tcl_ObjCmdProc* objCmdProc;	/* Procedure that evaluates the function */
    ClientData clientData;	/* Client data for the procedure */
} BuiltinFuncDef;
static BuiltinFuncDef BuiltinFuncTable[] = {
    { "::tcl::mathfunc::abs",	ExprAbsFunc,	NULL 			},
    { "::tcl::mathfunc::acos",	ExprUnaryFunc,	(ClientData) acos 	},
    { "::tcl::mathfunc::asin",	ExprUnaryFunc,	(ClientData) asin 	},
    { "::tcl::mathfunc::atan",	ExprUnaryFunc,	(ClientData) atan 	},
    { "::tcl::mathfunc::atan2",	ExprBinaryFunc,	(ClientData) atan2 	},
    { "::tcl::mathfunc::bool",	ExprBoolFunc,	NULL			},
    { "::tcl::mathfunc::ceil",	ExprCeilFunc,	NULL		 	},
    { "::tcl::mathfunc::cos",	ExprUnaryFunc,	(ClientData) cos 	},
    { "::tcl::mathfunc::cosh",	ExprUnaryFunc,	(ClientData) cosh	},
    { "::tcl::mathfunc::double",ExprDoubleFunc,	NULL			},
    { "::tcl::mathfunc::entier",ExprEntierFunc,	NULL			},
    { "::tcl::mathfunc::exp",	ExprUnaryFunc,	(ClientData) exp	},
    { "::tcl::mathfunc::floor",	ExprFloorFunc,	NULL		 	},
    { "::tcl::mathfunc::fmod",	ExprBinaryFunc,	(ClientData) fmod	},
    { "::tcl::mathfunc::hypot",	ExprBinaryFunc,	(ClientData) hypot 	},
    { "::tcl::mathfunc::int",	ExprIntFunc,	NULL			},
    { "::tcl::mathfunc::log",	ExprUnaryFunc,	(ClientData) log 	},
    { "::tcl::mathfunc::log10",	ExprUnaryFunc,  (ClientData) log10 	},
    { "::tcl::mathfunc::pow",	ExprBinaryFunc,	(ClientData) pow 	},
    { "::tcl::mathfunc::rand",	ExprRandFunc,	NULL			},
    { "::tcl::mathfunc::round",	ExprRoundFunc,	NULL			},
    { "::tcl::mathfunc::sin",	ExprUnaryFunc,	(ClientData) sin 	},
    { "::tcl::mathfunc::sinh",	ExprUnaryFunc,	(ClientData) sinh 	},
    { "::tcl::mathfunc::sqrt",	ExprSqrtFunc,	NULL		 	},
    { "::tcl::mathfunc::srand",	ExprSrandFunc,	NULL			},
    { "::tcl::mathfunc::tan",	ExprUnaryFunc,	(ClientData) tan 	},
    { "::tcl::mathfunc::tanh",	ExprUnaryFunc,	(ClientData) tanh 	},
    { "::tcl::mathfunc::wide",	ExprWideFunc,	NULL		 	},
    { NULL, NULL, NULL }
};


/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateInterp --
 *
 *	Create a new TCL command interpreter.
 *
 * Results:
 *	The return value is a token for the interpreter, which may be used in
 *	calls to procedures like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp.

 *
 * Side effects:
 *	The command interpreter is initialized with the built-in commands and
 *	with the variables documented in tclvars(n).
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateInterp()
{
    Interp *iPtr;
    Tcl_Interp *interp;
    Command *cmdPtr;
    BuiltinFuncDef *builtinFuncPtr;


    const CmdInfo *cmdInfoPtr;
    Tcl_Namespace* mathfuncNSPtr;
    int i;
    union {
	char c[sizeof(short)];
	short s;
    } order;
#ifdef TCL_COMPILE_STATS
    ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */

    TclInitSubsystems();

    /*
     * Panic if someone updated the CallFrame structure without also updating
     * the Tcl_CallFrame structure (or vice versa).
     */

    if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
	/*NOTREACHED*/
	Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size");
    }

    /*
     * Initialize support for namespaces and create the global namespace
     * (whose name is ""; an alias is "::"). This also initializes the Tcl
     * object type table and other object management code.
     */

    iPtr = (Interp *) ckalloc(sizeof(Interp));
    interp = (Tcl_Interp *) iPtr;

    iPtr->result		= iPtr->resultSpace;
    iPtr->freeProc		= NULL;
    iPtr->errorLine		= 0;
    iPtr->objResultPtr		= Tcl_NewObj();
    Tcl_IncrRefCount(iPtr->objResultPtr);
    iPtr->handle		= TclHandleCreate(iPtr);
    iPtr->globalNsPtr		= NULL;
    iPtr->hiddenCmdTablePtr	= NULL;
    iPtr->interpInfo		= NULL;


    iPtr->numLevels = 0;
    iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
    iPtr->framePtr = NULL;
    iPtr->varFramePtr = NULL;
    iPtr->activeVarTracePtr = NULL;

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
    Tcl_IncrRefCount(iPtr->eiVar);
    iPtr->errorCode = NULL;
    iPtr->ecVar = Tcl_NewStringObj("errorCode", -1);
    Tcl_IncrRefCount(iPtr->ecVar);
    iPtr->returnLevel = 1;
    iPtr->returnCode = TCL_OK;

    iPtr->appendResult = NULL;
    iPtr->appendAvl = 0;
    iPtr->appendUsed = 0;

    Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273






274
275
276
277
278
279
280
    iPtr->scriptFile = NULL;
    iPtr->flags = 0;
    iPtr->tracePtr = NULL;
    iPtr->tracesForbiddingInline = 0;
    iPtr->activeCmdTracePtr = NULL;
    iPtr->activeInterpTracePtr = NULL;
    iPtr->assocData = (Tcl_HashTable *) NULL;
    iPtr->execEnvPtr = NULL;	      /* set after namespaces initialized */
    iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
    Tcl_IncrRefCount(iPtr->emptyObjPtr);
    iPtr->resultSpace[0] = 0;

    iPtr->globalNsPtr = NULL;	/* force creation of global ns below */
    iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
	    (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
    if (iPtr->globalNsPtr == NULL) {
        Tcl_Panic("Tcl_CreateInterp: can't create global namespace");
    }

    /*
     * Initialize support for code compilation and execution. We call
     * TclCreateExecEnv after initializing namespaces since it tries to
     * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
     * variable).
     */

    iPtr->execEnvPtr = TclCreateExecEnv(interp);







    /*
     * Initialize the compilation and execution statistics kept for this
     * interpreter.
     */

#ifdef TCL_COMPILE_STATS
    statsPtr = &(iPtr->stats);







|
|



|



|











>
>
>
>
>
>







334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
    iPtr->scriptFile = NULL;
    iPtr->flags = 0;
    iPtr->tracePtr = NULL;
    iPtr->tracesForbiddingInline = 0;
    iPtr->activeCmdTracePtr = NULL;
    iPtr->activeInterpTracePtr = NULL;
    iPtr->assocData = (Tcl_HashTable *) NULL;
    iPtr->execEnvPtr = NULL;		/* set after namespaces initialized */
    iPtr->emptyObjPtr = Tcl_NewObj();	/* another empty object */
    Tcl_IncrRefCount(iPtr->emptyObjPtr);
    iPtr->resultSpace[0] = 0;

    iPtr->globalNsPtr = NULL;		/* force creation of global ns below */
    iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
	    (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
    if (iPtr->globalNsPtr == NULL) {
	Tcl_Panic("Tcl_CreateInterp: can't create global namespace");
    }

    /*
     * Initialize support for code compilation and execution. We call
     * TclCreateExecEnv after initializing namespaces since it tries to
     * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
     * variable).
     */

    iPtr->execEnvPtr = TclCreateExecEnv(interp);

    /*
     * TIP #219, Tcl Channel Reflection API support.
     */

    iPtr->chanMsg  = NULL;

    /*
     * Initialize the compilation and execution statistics kept for this
     * interpreter.
     */

#ifdef TCL_COMPILE_STATS
    statsPtr = &(iPtr->stats);
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
    statsPtr->currentSrcBytes = 0.0;
    statsPtr->currentByteCodeBytes = 0.0;
    (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
    (VOID *) memset(statsPtr->byteCodeCount, 0,
	    sizeof(statsPtr->byteCodeCount));
    (VOID *) memset(statsPtr->lifetimeCount, 0,
	    sizeof(statsPtr->lifetimeCount));
    
    statsPtr->currentInstBytes   = 0.0;
    statsPtr->currentLitBytes    = 0.0;
    statsPtr->currentExceptBytes = 0.0;
    statsPtr->currentAuxBytes    = 0.0;
    statsPtr->currentCmdMapBytes = 0.0;
    
    statsPtr->numLiteralsCreated    = 0;
    statsPtr->totalLitStringBytes   = 0.0;
    statsPtr->currentLitStringBytes = 0.0;
    (VOID *) memset(statsPtr->literalCount, 0,
            sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */    

    /*
     * Initialise the stub table pointer.
     */

    iPtr->stubTable = &tclStubs;








|





|



|
<
|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400

401
402
403
404
405
406
407
408
    statsPtr->currentSrcBytes = 0.0;
    statsPtr->currentByteCodeBytes = 0.0;
    (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
    (VOID *) memset(statsPtr->byteCodeCount, 0,
	    sizeof(statsPtr->byteCodeCount));
    (VOID *) memset(statsPtr->lifetimeCount, 0,
	    sizeof(statsPtr->lifetimeCount));

    statsPtr->currentInstBytes   = 0.0;
    statsPtr->currentLitBytes    = 0.0;
    statsPtr->currentExceptBytes = 0.0;
    statsPtr->currentAuxBytes    = 0.0;
    statsPtr->currentCmdMapBytes = 0.0;

    statsPtr->numLiteralsCreated    = 0;
    statsPtr->totalLitStringBytes   = 0.0;
    statsPtr->currentLitStringBytes = 0.0;
    (VOID *) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));

#endif /* TCL_COMPILE_STATS */

    /*
     * Initialise the stub table pointer.
     */

    iPtr->stubTable = &tclStubs;

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
     * TIP#143: Initialise the resource limit support.
     */

    TclInitLimitSupport(interp);

    /*
     * Create the core commands. Do it here, rather than calling
     * Tcl_CreateCommand, because it's faster (there's no need to check for
     * a pre-existing command by the same name). If a command has a
     * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
     * TclInvokeStringCommand. This is an object-based wrapper procedure
     * that extracts strings, calls the string procedure, and creates an
     * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
     * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
     */

    for (cmdInfoPtr = builtInCmds;  cmdInfoPtr->name != NULL; cmdInfoPtr++) {
	int new;
	Tcl_HashEntry *hPtr;

	if ((cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
	        && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
	    Tcl_Panic("Tcl_CreateInterp: builtin command with NULL object command proc and a NULL compile proc\n");
	}
	
	hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
	        cmdInfoPtr->name, &new);
	if (new) {
	    cmdPtr = (Command *) ckalloc(sizeof(Command));
	    cmdPtr->hPtr = hPtr;
	    cmdPtr->nsPtr = iPtr->globalNsPtr;
	    cmdPtr->refCount = 1;
	    cmdPtr->cmdEpoch = 0;
	    cmdPtr->compileProc = cmdInfoPtr->compileProc;







|
|
|
|
|
|
|







|


|

|







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
     * TIP#143: Initialise the resource limit support.
     */

    TclInitLimitSupport(interp);

    /*
     * Create the core commands. Do it here, rather than calling
     * Tcl_CreateCommand, because it's faster (there's no need to check for a
     * pre-existing command by the same name). If a command has a Tcl_CmdProc
     * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
     * TclInvokeStringCommand. This is an object-based wrapper procedure that
     * extracts strings, calls the string procedure, and creates an object for
     * the result. Similarly, if a command has a Tcl_ObjCmdProc but no
     * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
     */

    for (cmdInfoPtr = builtInCmds;  cmdInfoPtr->name != NULL; cmdInfoPtr++) {
	int new;
	Tcl_HashEntry *hPtr;

	if ((cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
		&& (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
	    Tcl_Panic("Tcl_CreateInterp: builtin command with NULL object command proc and a NULL compile proc\n");
	}

	hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
		cmdInfoPtr->name, &new);
	if (new) {
	    cmdPtr = (Command *) ckalloc(sizeof(Command));
	    cmdPtr->hPtr = hPtr;
	    cmdPtr->nsPtr = iPtr->globalNsPtr;
	    cmdPtr->refCount = 1;
	    cmdPtr->cmdEpoch = 0;
	    cmdPtr->compileProc = cmdInfoPtr->compileProc;
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400








401
402


403









404
405
406







407
408
409
410
411





412
413

414
415
416
417
418
419
420
421
422
423
424
425
426



427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
	    cmdPtr->importRefPtr = NULL;
	    cmdPtr->tracePtr = NULL;
	    Tcl_SetHashValue(hPtr, cmdPtr);
	}
    }

    /*
     * Register the clock commands.  These *do* go through 
     * Tcl_CreateObjCommand, since they aren't in the global namespace.
     */

    Tcl_CreateObjCommand( interp,	 "::tcl::clock::clicks",
	    TclClockClicksObjCmd,	 (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	 "::tcl::clock::getenv",
	    TclClockGetenvObjCmd,	 (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	 "::tcl::clock::microseconds",
	    TclClockMicrosecondsObjCmd,	 (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	 "::tcl::clock::milliseconds",
	    TclClockMillisecondsObjCmd,	 (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	 "::tcl::clock::seconds",
	    TclClockSecondsObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	 "::tcl::clock::Localtime",
	    TclClockLocaltimeObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	"::tcl::clock::Mktime",
	    TclClockMktimeObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand( interp,	"::tcl::clock::Oldscan",
	    TclClockOldscanObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );









    /* Register the default [interp bgerror] handler. */












    Tcl_CreateObjCommand( interp,	"::tcl::Bgerror",
	    TclDefaultBgErrorHandlerObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL );








    /*
     * Register the builtin math functions.
     */






    i = 0;
    for (builtinFuncPtr = tclBuiltinFuncTable;  builtinFuncPtr->name != NULL;

	    builtinFuncPtr++) {
	Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
		builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
		(Tcl_MathProc *) NULL, (ClientData) 0);
	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
		builtinFuncPtr->name);
	if (hPtr == NULL) {
	    Tcl_Panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
	    return NULL;
	}
	mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
	mathFuncPtr->builtinFuncIndex = i;
	i++;



    }

    /*
     * Do Multiple/Safe Interps Tcl init stuff
     */

    TclInterpInit(interp);

#ifndef TCL_GENERIC_ONLY
    TclSetupEnv(interp);
#endif

    /*
     * TIP #59: Make embedded configuration information
     * available.
     */

    TclInitEmbeddedConfigurationInformation (interp);

    /*
     * Compute the byte order of this machine.
     */

    order.s = 1;
    Tcl_SetVar2(interp, "tcl_platform", "byteOrder",







|



|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|

|
|

|
>
>
>
>
>
>
>
>

|
>
>

>
>
>
>
>
>
>
>
>
|

|
>
>
>
>
>
>
>





>
>
>
>
>

|
>
|
<
<
<
<
|
<
<
|

|
|
<
>
>
>

















|







459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539




540


541
542
543
544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
	    cmdPtr->importRefPtr = NULL;
	    cmdPtr->tracePtr = NULL;
	    Tcl_SetHashValue(hPtr, cmdPtr);
	}
    }

    /*
     * Register clock and chan subcommands. These *do* go through
     * Tcl_CreateObjCommand, since they aren't in the global namespace.
     */

    Tcl_CreateObjCommand(interp,	"::tcl::clock::clicks",
	    TclClockClicksObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::getenv",
	    TclClockGetenvObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::microseconds",
	    TclClockMicrosecondsObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::milliseconds",
	    TclClockMillisecondsObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::seconds",
	    TclClockSecondsObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::Localtime",
	    TclClockLocaltimeObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::Mktime",
	    TclClockMktimeObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::Oldscan",
	    TclClockOldscanObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    /* TIP #208 */
    Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate",
	    TclChanTruncateObjCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    /* TIP #219 */
    Tcl_CreateObjCommand(interp, "::tcl::chan::rCreate",
	    TclChanCreateObjCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent",
	    TclChanPostEventObjCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);

    /*
     * Register the built-in functions
     */


    /*
     * Register the default [interp bgerror] handler.
     */

    Tcl_CreateObjCommand(interp,	"::tcl::Bgerror",
	    TclDefaultBgErrorHandlerObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);

    /*
     * Register the unsupported encoding search path command.
     */

    Tcl_CreateObjCommand(interp, "::tcl::unsupported::EncodingDirs",
	    TclEncodingDirsObjCmd, NULL, NULL);

    /*
     * Register the builtin math functions.
     */

    mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc",
	    (ClientData) NULL, (Tcl_NamespaceDeleteProc*) NULL);
    if (mathfuncNSPtr == NULL) {
	Tcl_Panic("Can't create math function namespace");
    }
    i = 0;
    for (;;) {
	CONST char* tail;
	builtinFuncPtr = &(BuiltinFuncTable[i++]);




	if (builtinFuncPtr->name == NULL) {


	    break;
	}
	Tcl_CreateObjCommand(interp, builtinFuncPtr->name,
		builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData,

		(Tcl_CmdDeleteProc*) NULL);
	tail = builtinFuncPtr->name + strlen("::tcl::mathfunc::");
	Tcl_Export(interp, mathfuncNSPtr, tail, 0);
    }

    /*
     * Do Multiple/Safe Interps Tcl init stuff
     */

    TclInterpInit(interp);

#ifndef TCL_GENERIC_ONLY
    TclSetupEnv(interp);
#endif

    /*
     * TIP #59: Make embedded configuration information
     * available.
     */

    TclInitEmbeddedConfigurationInformation(interp);

    /*
     * Compute the byte order of this machine.
     */

    order.s = 1;
    Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744

745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
    Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    TclPrecTraceProc, (ClientData) NULL);
    TclpSetVariables(interp);

#ifdef TCL_THREADS
    /*
     * The existence of the "threaded" element of the tcl_platform array indicates
     * that this particular Tcl shell has been compiled with threads turned on.
     * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the 
     * interpreter level of thread safety.
     */


    Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
	    TCL_GLOBAL_ONLY);
#endif

    /*
     * Register Tcl's version number.
     */

    Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
    
#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
#endif
    Tcl_InitStubs(interp, TCL_VERSION, 1);

    return interp;
}

/*
 *----------------------------------------------------------------------
 *
 * TclHideUnsafeCommands --
 *
 *	Hides base commands that are not marked as safe from this
 *	interpreter.
 *
 * Results:
 *	TCL_OK if it succeeds, TCL_ERROR else.
 *
 * Side effects:
 *	Hides functionality in an interpreter.
 *
 *----------------------------------------------------------------------
 */

int
TclHideUnsafeCommands(interp)
    Tcl_Interp *interp;		/* Hide commands in this interpreter. */
{
    register const CmdInfo *cmdInfoPtr;

    if (interp == (Tcl_Interp *) NULL) {
        return TCL_ERROR;
    }
    for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
        if (!cmdInfoPtr->isSafe) {
            Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
        }
    }
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_CallWhenDeleted --
 *
 *	Arrange for a procedure to be called before a given
 *	interpreter is deleted. The procedure is called as soon
 *	as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
 *	called on an interpreter that has already been deleted,
 *	the procedure will be called when the last Tcl_Release is
 *	done on the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When Tcl_DeleteInterp is invoked to delete interp,
 *	proc will be invoked.  See the manual entry for
 *	details.
 *
 *--------------------------------------------------------------
 */

void
Tcl_CallWhenDeleted(interp, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to watch. */
    Tcl_InterpDeleteProc *proc;	/* Procedure to call when interpreter
				 * is about to be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;

    static int assocDataCounter = 0;
#ifdef TCL_THREADS
    static Tcl_Mutex assocMutex;
#endif
    int new;
    char buffer[32 + TCL_INTEGER_SPACE];
    AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    Tcl_HashEntry *hPtr;

    Tcl_MutexLock(&assocMutex);
    sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
    assocDataCounter++;
    Tcl_MutexUnlock(&assocMutex);

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
    dPtr->proc = proc;
    dPtr->clientData = clientData;
    Tcl_SetHashValue(hPtr, dPtr);
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_DontCallWhenDeleted --
 *
 *	Cancel the arrangement for a procedure to be called when
 *	a given interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If proc and clientData were previously registered as a
 *	callback via Tcl_CallWhenDeleted, they are unregistered.
 *	If they weren't previously registered then nothing
 *	happens.
 *
 *--------------------------------------------------------------
 */

void
Tcl_DontCallWhenDeleted(interp, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to watch. */
    Tcl_InterpDeleteProc *proc;	/* Procedure to call when interpreter
				 * is about to be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTablePtr;
    Tcl_HashSearch hSearch;
    Tcl_HashEntry *hPtr;
    AssocData *dPtr;

    hTablePtr = iPtr->assocData;
    if (hTablePtr == (Tcl_HashTable *) NULL) {
        return;
    }
    for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
        dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
        if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
            ckfree((char *) dPtr);
            Tcl_DeleteHashEntry(hPtr);
            return;
        }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetAssocData --
 *
 *	Creates a named association between user-specified data, a delete
 *	function and this interpreter. If the association already exists
 *	the data is overwritten with the new data. The delete function will
 *	be invoked when the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the associated data, creates the association if needed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetAssocData(interp, name, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to associate with. */
    CONST char *name;		/* Name for association. */
    Tcl_InterpDeleteProc *proc;	/* Proc to call when interpreter is
                                 * about to be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;
    int new;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
    if (new == 0) {
        dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    } else {
        dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    }
    dPtr->proc = proc;
    dPtr->clientData = clientData;

    Tcl_SetHashValue(hPtr, dPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteAssocData --
 *
 *	Deletes a named association of user-specified data with
 *	the specified interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the association.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteAssocData(interp, name)
    Tcl_Interp *interp;			/* Interpreter to associate with. */
    CONST char *name;			/* Name of association. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        return;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (dPtr->proc != NULL) {
        (dPtr->proc) (dPtr->clientData, interp);
    }
    ckfree((char *) dPtr);
    Tcl_DeleteHashEntry(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAssocData --
 *
 *	Returns the client data associated with this name in the
 *	specified interpreter.
 *
 * Results:
 *	The client data in the AssocData record denoted by the named
 *	association, or NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_GetAssocData(interp, name, procPtr)
    Tcl_Interp *interp;			/* Interpreter associated with. */
    CONST char *name;			/* Name of association. */
    Tcl_InterpDeleteProc **procPtr;	/* Pointer to place to store address

					 * of current deletion callback. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        return (ClientData) NULL;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return (ClientData) NULL;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
        *procPtr = dPtr->proc;
    }
    return dPtr->clientData;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpDeleted --
 *
 *	Returns nonzero if the interpreter has been deleted with a call
 *	to Tcl_DeleteInterp.
 *
 * Results:
 *	Nonzero if the interpreter is deleted, zero otherwise.
 *
 * Side effects:
 *	None.
 *







|
|
|
|



|
<







|













|
<

















|


|
|
|









|
|
|
<
|
|





|
|
<







|
|



>
|
<
|
<





<
|
|
<


|
|












|
|





|
|
|
<







|
|










|



|
|
|
|
|
|









|
|
|














|
|








|
|



|

|












|
|












|
|






|



|



|










|
|













|
|
|
>
|






|



|



|









|
|







585
586
587
588
589
590
591
592
593
594
595
596
597
598
599

600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621

622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656

657
658
659
660
661
662
663
664
665

666
667
668
669
670
671
672
673
674
675
676
677
678
679

680

681
682
683
684
685

686
687

688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713

714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
    Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    TclPrecTraceProc, (ClientData) NULL);
    TclpSetVariables(interp);

#ifdef TCL_THREADS
    /*
     * The existence of the "threaded" element of the tcl_platform array
     * indicates that this particular Tcl shell has been compiled with threads
     * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
     * introspect on the interpreter level of thread safety.
     */


    Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY);

#endif

    /*
     * Register Tcl's version number.
     */

    Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);

#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
#endif
    Tcl_InitStubs(interp, TCL_VERSION, 1);

    return interp;
}

/*
 *----------------------------------------------------------------------
 *
 * TclHideUnsafeCommands --
 *
 *	Hides base commands that are not marked as safe from this interpreter.

 *
 * Results:
 *	TCL_OK if it succeeds, TCL_ERROR else.
 *
 * Side effects:
 *	Hides functionality in an interpreter.
 *
 *----------------------------------------------------------------------
 */

int
TclHideUnsafeCommands(interp)
    Tcl_Interp *interp;		/* Hide commands in this interpreter. */
{
    register const CmdInfo *cmdInfoPtr;

    if (interp == (Tcl_Interp *) NULL) {
	return TCL_ERROR;
    }
    for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
	if (!cmdInfoPtr->isSafe) {
	    Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
	}
    }
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_CallWhenDeleted --
 *
 *	Arrange for a procedure to be called before a given interpreter is
 *	deleted. The procedure is called as soon as Tcl_DeleteInterp is
 *	called; if Tcl_CallWhenDeleted is called on an interpreter that has

 *	already been deleted, the procedure will be called when the last
 *	Tcl_Release is done on the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When Tcl_DeleteInterp is invoked to delete interp, proc will be
 *	invoked. See the manual entry for details.

 *
 *--------------------------------------------------------------
 */

void
Tcl_CallWhenDeleted(interp, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to watch. */
    Tcl_InterpDeleteProc *proc;	/* Procedure to call when interpreter is about
				 * to be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    static Tcl_ThreadDataKey assocDataCounterKey;
    int *assocDataCounterPtr =

	    Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));

    int new;
    char buffer[32 + TCL_INTEGER_SPACE];
    AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    Tcl_HashEntry *hPtr;


    sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
    (*assocDataCounterPtr)++;


    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
	iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
    dPtr->proc = proc;
    dPtr->clientData = clientData;
    Tcl_SetHashValue(hPtr, dPtr);
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_DontCallWhenDeleted --
 *
 *	Cancel the arrangement for a procedure to be called when a given
 *	interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If proc and clientData were previously registered as a callback via
 *	Tcl_CallWhenDeleted, they are unregistered. If they weren't previously
 *	registered then nothing happens.

 *
 *--------------------------------------------------------------
 */

void
Tcl_DontCallWhenDeleted(interp, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to watch. */
    Tcl_InterpDeleteProc *proc;	/* Procedure to call when interpreter is about
				 * to be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTablePtr;
    Tcl_HashSearch hSearch;
    Tcl_HashEntry *hPtr;
    AssocData *dPtr;

    hTablePtr = iPtr->assocData;
    if (hTablePtr == (Tcl_HashTable *) NULL) {
	return;
    }
    for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
	if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
	    ckfree((char *) dPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    return;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetAssocData --
 *
 *	Creates a named association between user-specified data, a delete
 *	function and this interpreter. If the association already exists the
 *	data is overwritten with the new data. The delete function will be
 *	invoked when the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the associated data, creates the association if needed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetAssocData(interp, name, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to associate with. */
    CONST char *name;		/* Name for association. */
    Tcl_InterpDeleteProc *proc;	/* Proc to call when interpreter is about to
				 * be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;
    int new;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
	iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
    if (new == 0) {
	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    } else {
	dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    }
    dPtr->proc = proc;
    dPtr->clientData = clientData;

    Tcl_SetHashValue(hPtr, dPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteAssocData --
 *
 *	Deletes a named association of user-specified data with the specified
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the association.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteAssocData(interp, name)
    Tcl_Interp *interp;		/* Interpreter to associate with. */
    CONST char *name;		/* Name of association. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
	return;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
	return;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (dPtr->proc != NULL) {
	(dPtr->proc) (dPtr->clientData, interp);
    }
    ckfree((char *) dPtr);
    Tcl_DeleteHashEntry(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAssocData --
 *
 *	Returns the client data associated with this name in the specified
 *	interpreter.
 *
 * Results:
 *	The client data in the AssocData record denoted by the named
 *	association, or NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_GetAssocData(interp, name, procPtr)
    Tcl_Interp *interp;		/* Interpreter associated with. */
    CONST char *name;		/* Name of association. */
    Tcl_InterpDeleteProc **procPtr;
				/* Pointer to place to store address of
				 * current deletion callback. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
	return (ClientData) NULL;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
	return (ClientData) NULL;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
	*procPtr = dPtr->proc;
    }
    return dPtr->clientData;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpDeleted --
 *
 *	Returns nonzero if the interpreter has been deleted with a call to
 *	Tcl_DeleteInterp.
 *
 * Results:
 *	Nonzero if the interpreter is deleted, zero otherwise.
 *
 * Side effects:
 *	None.
 *
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834








835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteInterp --
 *
 *	Ensures that the interpreter will be deleted eventually. If there
 *	are no Tcl_Preserve calls in effect for this interpreter, it is
 *	deleted immediately, otherwise the interpreter is deleted when
 *	the last Tcl_Preserve is matched by a call to Tcl_Release. In either
 *	case, the procedure runs the currently registered deletion callbacks. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter is marked as deleted. The caller may still use it
 *	safely if there are calls to Tcl_Preserve in effect for the
 *	interpreter, but further calls to Tcl_Eval etc in this interpreter
 *	will fail.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteInterp(interp)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by a previous call to Tcl_CreateInterp). */
{
    Interp *iPtr = (Interp *) interp;

    /*
     * If the interpreter has already been marked deleted, just punt.
     */

    if (iPtr->flags & DELETED) {
        return;
    }
    
    /*
     * Mark the interpreter as deleted. No further evals will be allowed.
     * Increase the compileEpoch as a signal to compiled bytecodes.
     */

    iPtr->flags |= DELETED;
    iPtr->compileEpoch++;










    /*
     * Ensure that the interpreter is eventually deleted.
     */

    Tcl_EventuallyFree((ClientData) interp,
            (Tcl_FreeProc *) DeleteInterpProc);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteInterpProc --
 *
 *	Helper procedure to delete an interpreter. This procedure is
 *	called when the last call to Tcl_Preserve on this interpreter
 *	is matched by a call to Tcl_Release. The procedure cleans up
 *	all resources used in the interpreter and calls all currently
 *	registered interpreter deletion callbacks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the interpreter deletion callbacks do. Frees resources
 *	used by the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteInterpProc(interp)
    Tcl_Interp *interp;			/* Interpreter to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *hTablePtr;
    ResolverScheme *resPtr, *nextResPtr;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
     */
    
    if (iPtr->numLevels > 0) {
        Tcl_Panic("DeleteInterpProc called with active evals");
    }

    /*
     * The interpreter should already be marked deleted; otherwise how
     * did we get here?
     */

    if (!(iPtr->flags & DELETED)) {
        Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted");
    }

    /*
     * Shut down all limit handler callback scripts that call back
     * into this interpreter.  Then eliminate all limit handlers for
     * this interpreter.
     */

    TclRemoveScriptLimitCallbacks(interp);
    TclLimitRemoveAllHandlers(interp);

    /*
     * Dismantle the namespace here, before we clear the assocData. If any
     * background errors occur here, they will be deleted below.
     *
     * Dismantle the namespace after freeing the iPtr->handle so that each
     * bytecode releases its literals without caring to update the literal
     * table, as it will be freed later in this function without further use.
     */
    
    TclCleanupLiteralTable(interp, &(iPtr->literalTable));
    TclHandleFree(iPtr->handle);
    TclTeardownNamespace(iPtr->globalNsPtr);

    /*
     * Delete all the hidden commands.
     */
     
    hTablePtr = iPtr->hiddenCmdTablePtr;
    if (hTablePtr != NULL) {
	/*
	 * Non-pernicious deletion.  The deletion callbacks will not be
	 * allowed to create any new hidden or non-hidden commands.
	 * Tcl_DeleteCommandFromToken() will remove the entry from the
	 * hiddenCmdTablePtr.
	 */
	 
	hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Tcl_DeleteCommandFromToken(interp,
		    (Tcl_Command) Tcl_GetHashValue(hPtr));
	}
	Tcl_DeleteHashTable(hTablePtr);
	ckfree((char *) hTablePtr);
    }
    /*
     * Tear down the math function table.
     */

    for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
	     hPtr != NULL;
             hPtr = Tcl_NextHashEntry(&search)) {
	ckfree((char *) Tcl_GetHashValue(hPtr));
    }
    Tcl_DeleteHashTable(&iPtr->mathFuncTable);

    /*
     * Invoke deletion callbacks; note that a callback can create new
     * callbacks, so we iterate.
     */

    while (iPtr->assocData != (Tcl_HashTable *) NULL) {
	AssocData *dPtr;
	
        hTablePtr = iPtr->assocData;
        iPtr->assocData = (Tcl_HashTable *) NULL;
        for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
                 hPtr != NULL;
                 hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
            dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
            Tcl_DeleteHashEntry(hPtr);
            if (dPtr->proc != NULL) {
                (*dPtr->proc)(dPtr->clientData, interp);
            }
            ckfree((char *) dPtr);
        }
        Tcl_DeleteHashTable(hTablePtr);
        ckfree((char *) hTablePtr);
    }

    /*
     * Finish deleting the global namespace.
     */
    
    Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);

    /*
     * Free up the result *after* deleting variables, since variable
     * deletion could have transferred ownership of the result string
     * to Tcl.
     */

    Tcl_FreeResult(interp);
    interp->result = NULL;
    Tcl_DecrRefCount(iPtr->objResultPtr);
    iPtr->objResultPtr = NULL;
    Tcl_DecrRefCount(iPtr->ecVar);







|
|
|
|
|















|
|








|

|








>
>
>
>
>
>
>
>





|
<







|
|
|
|
|





|
|






|










|

|



|
|



|



|
|
<













|







|



|
|



|

|






<
<
<
<
<
<
<
<
<
<








|
|
|
|
|
|
|
|
|
|
|
|
|
|
|





|



|
|
<







901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962

963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054










1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088

1089
1090
1091
1092
1093
1094
1095
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteInterp --
 *
 *	Ensures that the interpreter will be deleted eventually. If there are
 *	no Tcl_Preserve calls in effect for this interpreter, it is deleted
 *	immediately, otherwise the interpreter is deleted when the last
 *	Tcl_Preserve is matched by a call to Tcl_Release. In either case, the
 *	procedure runs the currently registered deletion callbacks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter is marked as deleted. The caller may still use it
 *	safely if there are calls to Tcl_Preserve in effect for the
 *	interpreter, but further calls to Tcl_Eval etc in this interpreter
 *	will fail.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteInterp(interp)
    Tcl_Interp *interp;		/* Token for command interpreter (returned by
				 * a previous call to Tcl_CreateInterp). */
{
    Interp *iPtr = (Interp *) interp;

    /*
     * If the interpreter has already been marked deleted, just punt.
     */

    if (iPtr->flags & DELETED) {
	return;
    }

    /*
     * Mark the interpreter as deleted. No further evals will be allowed.
     * Increase the compileEpoch as a signal to compiled bytecodes.
     */

    iPtr->flags |= DELETED;
    iPtr->compileEpoch++;

    /*
     * TIP #219, Tcl Channel Reflection API. Discard a leftover state.
     */

    if (iPtr->chanMsg != NULL) {
        Tcl_DecrRefCount (iPtr->chanMsg);
	iPtr->chanMsg = NULL;
    }

    /*
     * Ensure that the interpreter is eventually deleted.
     */

    Tcl_EventuallyFree((ClientData) interp, (Tcl_FreeProc *) DeleteInterpProc);

}

/*
 *----------------------------------------------------------------------
 *
 * DeleteInterpProc --
 *
 *	Helper procedure to delete an interpreter. This procedure is called
 *	when the last call to Tcl_Preserve on this interpreter is matched by a
 *	call to Tcl_Release. The procedure cleans up all resources used in the
 *	interpreter and calls all currently registered interpreter deletion
 *	callbacks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the interpreter deletion callbacks do. Frees resources used
 *	by the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteInterpProc(interp)
    Tcl_Interp *interp;		/* Interpreter to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *hTablePtr;
    ResolverScheme *resPtr, *nextResPtr;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
     */

    if (iPtr->numLevels > 0) {
	Tcl_Panic("DeleteInterpProc called with active evals");
    }

    /*
     * The interpreter should already be marked deleted; otherwise how did we
     * get here?
     */

    if (!(iPtr->flags & DELETED)) {
	Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted");
    }

    /*
     * Shut down all limit handler callback scripts that call back into this
     * interpreter. Then eliminate all limit handlers for this interpreter.

     */

    TclRemoveScriptLimitCallbacks(interp);
    TclLimitRemoveAllHandlers(interp);

    /*
     * Dismantle the namespace here, before we clear the assocData. If any
     * background errors occur here, they will be deleted below.
     *
     * Dismantle the namespace after freeing the iPtr->handle so that each
     * bytecode releases its literals without caring to update the literal
     * table, as it will be freed later in this function without further use.
     */

    TclCleanupLiteralTable(interp, &(iPtr->literalTable));
    TclHandleFree(iPtr->handle);
    TclTeardownNamespace(iPtr->globalNsPtr);

    /*
     * Delete all the hidden commands.
     */

    hTablePtr = iPtr->hiddenCmdTablePtr;
    if (hTablePtr != NULL) {
	/*
	 * Non-pernicious deletion. The deletion callbacks will not be allowed
	 * to create any new hidden or non-hidden commands.
	 * Tcl_DeleteCommandFromToken() will remove the entry from the
	 * hiddenCmdTablePtr.
	 */

	hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
	for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Tcl_DeleteCommandFromToken(interp,
		    (Tcl_Command) Tcl_GetHashValue(hPtr));
	}
	Tcl_DeleteHashTable(hTablePtr);
	ckfree((char *) hTablePtr);
    }











    /*
     * Invoke deletion callbacks; note that a callback can create new
     * callbacks, so we iterate.
     */

    while (iPtr->assocData != (Tcl_HashTable *) NULL) {
	AssocData *dPtr;

	hTablePtr = iPtr->assocData;
	iPtr->assocData = (Tcl_HashTable *) NULL;
	for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
		hPtr != NULL;
		hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
	    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    if (dPtr->proc != NULL) {
		(*dPtr->proc)(dPtr->clientData, interp);
	    }
	    ckfree((char *) dPtr);
	}
	Tcl_DeleteHashTable(hTablePtr);
	ckfree((char *) hTablePtr);
    }

    /*
     * Finish deleting the global namespace.
     */

    Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);

    /*
     * Free up the result *after* deleting variables, since variable deletion
     * could have transferred ownership of the result string to Tcl.

     */

    Tcl_FreeResult(interp);
    interp->result = NULL;
    Tcl_DecrRefCount(iPtr->objResultPtr);
    iPtr->objResultPtr = NULL;
    Tcl_DecrRefCount(iPtr->ecVar);
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274

1275
1276
1277
1278
1279

1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455

1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579

1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625

1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
	iPtr->errorInfo = NULL;
    }
    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
    }
    if (iPtr->appendResult != NULL) {
	ckfree(iPtr->appendResult);
        iPtr->appendResult = NULL;
    }
    TclFreePackageInfo(iPtr);
    while (iPtr->tracePtr != NULL) {
	Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr);
    }
    if (iPtr->execEnvPtr != NULL) {
	TclDeleteExecEnv(iPtr->execEnvPtr);
    }
    Tcl_DecrRefCount(iPtr->emptyObjPtr);
    iPtr->emptyObjPtr = NULL;

    resPtr = iPtr->resolverPtr;
    while (resPtr) {
	nextResPtr = resPtr->nextPtr;
	ckfree(resPtr->name);
	ckfree((char *) resPtr);
        resPtr = nextResPtr;
    }
    
    /*
     * Free up literal objects created for scripts compiled by the
     * interpreter.
     */

    TclDeleteLiteralTable(interp, &(iPtr->literalTable));
    ckfree((char *) iPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_HideCommand --
 *
 *	Makes a command hidden so that it cannot be invoked from within
 *	an interpreter, only from within an ancestor.
 *
 * Results:
 *	A standard Tcl result; also leaves a message in the interp's result
 *	if an error occurs.
 *
 * Side effects:
 *	Removes a command from the command table and create an entry
 *      into the hidden command table under the specified token name.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
    Tcl_Interp *interp;		/* Interpreter in which to hide command. */
    CONST char *cmdName;	/* Name of command to hide. */
    CONST char *hiddenCmdToken;	/* Token name of the to-be-hidden command. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_HashTable *hiddenCmdTablePtr;
    Tcl_HashEntry *hPtr;
    int new;

    if (iPtr->flags & DELETED) {

        /*
         * The interpreter is being deleted. Do not create any new
         * structures, because it is not safe to modify the interpreter.
         */
        
        return TCL_ERROR;
    }

    /*
     * Disallow hiding of commands that are currently in a namespace or
     * renaming (as part of hiding) into a namespace.
     *
     * (because the current implementation with a single global table
     *  and the needed uniqueness of names cause problems with namespaces)
     *
     * we don't need to check for "::" in cmdName because the real check is
     * on the nsPtr below.
     *
     * hiddenCmdToken is just a string which is not interpreted in any way.
     * It may contain :: but the string is not interpreted as a namespace
     * qualifier command name. Thus, hiding foo::bar to foo::bar and then
     * trying to expose or invoke ::foo::bar will NOT work; but if the
     * application always uses the same strings it will get consistent
     * behaviour.
     *
     * But as we currently limit ourselves to the global namespace only
     * for the source, in order to avoid potential confusion,
     * lets prevent "::" in the token too.  --dl
     */

    if (strstr(hiddenCmdToken, "::") != NULL) {
        Tcl_AppendResult(interp,
                "cannot use namespace qualifiers in hidden command",
		" token (rename)", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * Find the command to hide. An error is returned if cmdName can't
     * be found. Look up the command only from the global namespace.
     * Full path of the command must be given if using namespaces.
     */

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
	    /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
    if (cmd == (Tcl_Command) NULL) {
	return TCL_ERROR;
    }
    cmdPtr = (Command *) cmd;

    /*
     * Check that the command is really in global namespace
     */

    if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
        Tcl_AppendResult(interp, "can only hide global namespace commands",
		" (use rename then hide)", (char *) NULL);
        return TCL_ERROR;
    }
    
    /*
     * Initialize the hidden command table if necessary.
     */

    hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
    if (hiddenCmdTablePtr == NULL) {
        hiddenCmdTablePtr = (Tcl_HashTable *)
	        ckalloc((unsigned) sizeof(Tcl_HashTable));
        Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
	iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
    }

    /*
     * It is an error to move an exposed command to a hidden command with
     * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
     * exists.
     */
    
    hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
    if (!new) {
        Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken,
		"\" already exists", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * Nb : This code is currently 'like' a rename to a specialy set apart
     * name table. Changes here and in TclRenameCommand must
     * be kept in synch untill the common parts are actually
     * factorized out.
     */

    /*
     * Remove the hash entry for the command from the interpreter command
     * table. This is like deleting the command, so bump its command epoch;
     * this invalidates any cached references that point to the command.
     */

    if (cmdPtr->hPtr != NULL) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
	cmdPtr->cmdEpoch++;
    }

    /*
     * The list of command exported from the namespace might have
     * changed.  However, we do not need to recompute this just yet;
     * next time we need the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * Now link the hash table entry with the command structure.
     * We ensured above that the nsPtr was right.
     */
    
    cmdPtr->hPtr = hPtr;
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);

    /*
     * If the command being hidden has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled with
     * command-specific (i.e., inline) bytecodes for the now-hidden
     * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
     * and code whose compilation epoch doesn't match is recompiled.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExposeCommand --
 *
 *	Makes a previously hidden command callable from inside the
 *	interpreter instead of only by its ancestors.
 *
 * Results:
 *	A standard Tcl result. If an error occurs, a message is left
 *	in the interp's result.
 *
 * Side effects:
 *	Moves commands from one hash table to another.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
    Tcl_Interp *interp;		/* Interpreter in which to make command
                                 * callable. */
    CONST char *hiddenCmdToken;	/* Name of hidden command. */
    CONST char *cmdName;	/* Name of to-be-exposed command. */
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr;
    Namespace *nsPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *hiddenCmdTablePtr;
    int new;

    if (iPtr->flags & DELETED) {
        /*
         * The interpreter is being deleted. Do not create any new
         * structures, because it is not safe to modify the interpreter.
         */
        
        return TCL_ERROR;
    }

    /*
     * Check that we have a regular name for the command
     * (that the user is not trying to do an expose and a rename
     *  (to another namespace) at the same time)
     */

    if (strstr(cmdName, "::") != NULL) {
        Tcl_AppendResult(interp, "can not expose to a namespace ",
		"(use expose to toplevel, then rename)", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * Get the command from the hidden command table:
     */

    hPtr = NULL;
    hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
    if (hiddenCmdTablePtr != NULL) {
	hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
    }
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken,
                "\"", (char *) NULL);
        return TCL_ERROR;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
    

    /*
     * Check that we have a true global namespace
     * command (enforced by Tcl_HideCommand() but let's double
     * check. (If it was not, we would not really know how to
     * handle it).
     */

    if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
	/* 
	 * This case is theoritically impossible,
	 * we might rather Tcl_Panic() than 'nicely' erroring out ?
	 */

        Tcl_AppendResult(interp,
                "trying to expose a non global command name space command",
		(char *) NULL);
        return TCL_ERROR;
    }
    
    /* This is the global table */
    nsPtr = cmdPtr->nsPtr;

    /*
     * It is an error to overwrite an existing exposed command as a result
     * of exposing a previously hidden command.
     */

    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
    if (!new) {
        Tcl_AppendResult(interp, "exposed command \"", cmdName,
                "\" already exists", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * The list of command exported from the namespace might have
     * changed.  However, we do not need to recompute this just yet;
     * next time we need the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(nsPtr);

    /*
     * Remove the hash entry for the command from the interpreter hidden
     * command table.
     */

    if (cmdPtr->hPtr != NULL) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = NULL;
    }

    /*
     * Now link the hash table entry with the command structure.
     * This is like creating a new command, so deal with any shadowing
     * of commands in the global namespace.
     */
    
    cmdPtr->hPtr = hPtr;

    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);

    /*
     * Not needed as we are only in the global namespace
     * (but would be needed again if we supported namespace command hiding)
     *
     * TclResetShadowedCmdRefs(interp, cmdPtr);
     */


    /*
     * If the command being exposed has a compile procedure, increment
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled
     * assuming the command is hidden. This field is checked in Tcl_EvalObj
     * and ObjInterpProc, and code whose compilation epoch doesn't match is
     * recompiled.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCommand --
 *
 *	Define a new command in a command table.
 *
 * Results:
 *	The return value is a token for the command, which can
 *	be used in future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *	If a command named cmdName already exists for interp, it is deleted.
 *	In the future, when cmdName is seen as the name of a command by
 *	Tcl_Eval, proc will be called. To support the bytecode interpreter,
 *	the command is created with a wrapper Tcl_ObjCmdProc
 *	(TclInvokeStringCommand) that eventially calls proc. When the
 *	command is deleted from the table, deleteProc will be called.
 *	See the manual entry for details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;		/* Token for command interpreter returned by
				 * a previous call to Tcl_CreateInterp. */
    CONST char *cmdName;	/* Name of command. If it contains namespace
				 * qualifiers, the new command is put in the
				 * specified namespace; otherwise it is put
				 * in the global namespace. */
    Tcl_CmdProc *proc;		/* Procedure to associate with cmdName. */
    ClientData clientData;	/* Arbitrary value passed to string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* If not NULL, gives a procedure to call
				 * when this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    ImportRef *oldRefPtr = NULL;
    Namespace *nsPtr, *dummy1, *dummy2;
    Command *cmdPtr, *refCmdPtr;
    Tcl_HashEntry *hPtr;
    CONST char *tail;
    int new;
    ImportedCmdData *dataPtr;

    if (iPtr->flags & DELETED) {
	/*
	 * The interpreter is being deleted.  Don't create any new
	 * commands; it's not safe to muck with the interpreter anymore.
	 */

	return (Tcl_Command) NULL;
    }

    /*
     * Determine where the command should reside. If its name contains 
     * namespace qualifiers, we put it in the specified namespace; 
     * otherwise, we always put it in the global namespace.
     */

    if (strstr(cmdName, "::") != NULL) {
       TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
           TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
       if ((nsPtr == NULL) || (tail == NULL)) {
	    return (Tcl_Command) NULL;
	}
    } else {
	nsPtr = iPtr->globalNsPtr;
	tail = cmdName;
    }
    
    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
    if (!new) {
	/*
	 * Command already exists. Delete the old one.
	 * Be careful to preserve any existing import links so we can
	 * restore them down below.  That way, you can redefine a
	 * command and its import status will remain intact.
	 */

	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
	oldRefPtr = cmdPtr->importRefPtr;
	cmdPtr->importRefPtr = NULL;

	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
	if (!new) {
	    /*
	     * If the deletion callback recreated the command, just throw
             * away the new command (if we try to delete it again, we
             * could get stuck in an infinite loop).
	     */

	     ckfree((char*) Tcl_GetHashValue(hPtr));
	}
    } else {
	/*
	 * The list of command exported from the namespace might have
	 * changed.  However, we do not need to recompute this just
	 * yet; next time we need the info will be soon enough.
	 */

	TclInvalidateNsCmdLookup(nsPtr);

    }
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = nsPtr;
    cmdPtr->refCount = 1;
    cmdPtr->cmdEpoch = 0;
    cmdPtr->compileProc = (CompileProc *) NULL;
    cmdPtr->objProc = TclInvokeStringCommand;
    cmdPtr->objClientData = (ClientData) cmdPtr;
    cmdPtr->proc = proc;
    cmdPtr->clientData = clientData;
    cmdPtr->deleteProc = deleteProc;
    cmdPtr->deleteData = clientData;
    cmdPtr->flags = 0;
    cmdPtr->importRefPtr = NULL;
    cmdPtr->tracePtr = NULL;

    /*
     * Plug in any existing import references found above.  Be sure
     * to update all of these references to point to the new command.
     */

    if (oldRefPtr != NULL) {
	cmdPtr->importRefPtr = oldRefPtr;
	while (oldRefPtr != NULL) {
	    refCmdPtr = oldRefPtr->importedCmdPtr;
	    dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
	    dataPtr->realCmdPtr = cmdPtr;
	    oldRefPtr = oldRefPtr->nextPtr;
	}
    }

    /*
     * We just created a command, so in its namespace and all of its parent
     * namespaces, it may shadow global commands with the same name. If any
     * shadowed commands are found, invalidate all cached command references
     * in the affected namespaces.
     */
    
    TclResetShadowedCmdRefs(interp, cmdPtr);
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateObjCommand --
 *
 *	Define a new object-based command in a command table.
 *
 * Results:
 *	The return value is a token for the command, which can
 *	be used in future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *	If no command named "cmdName" already exists for interp, one is
 *	created. Otherwise, if a command does exist, then if the
 *	object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
 *	Tcl_CreateCommand was called previously for the same command and
 *	just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
 *	delete the old command.
 *
 *	In the future, during bytecode evaluation when "cmdName" is seen as
 *	the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
 *	Tcl_ObjCmdProc proc will be called. When the command is deleted from
 *	the table, deleteProc will be called. See the manual entry for
 *	details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by previous call to Tcl_CreateInterp). */
    CONST char *cmdName;	/* Name of command. If it contains namespace
				 * qualifiers, the new command is put in the
				 * specified namespace; otherwise it is put
				 * in the global namespace. */
    Tcl_ObjCmdProc *proc;	/* Object-based procedure to associate with
				 * name. */
    ClientData clientData;	/* Arbitrary value to pass to object
    				 * procedure. */
    Tcl_CmdDeleteProc *deleteProc;
				/* If not NULL, gives a procedure to call
				 * when this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    ImportRef *oldRefPtr = NULL;
    Namespace *nsPtr, *dummy1, *dummy2;
    Command *cmdPtr, *refCmdPtr;
    Tcl_HashEntry *hPtr;
    CONST char *tail;
    int new;
    ImportedCmdData *dataPtr;

    if (iPtr->flags & DELETED) {
	/*
	 * The interpreter is being deleted.  Don't create any new
	 * commands;  it's not safe to muck with the interpreter anymore.
	 */

	return (Tcl_Command) NULL;
    }

    /*
     * Determine where the command should reside. If its name contains 
     * namespace qualifiers, we put it in the specified namespace; 
     * otherwise, we always put it in the global namespace.
     */

    if (strstr(cmdName, "::") != NULL) {
       TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
           TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
       if ((nsPtr == NULL) || (tail == NULL)) {
	    return (Tcl_Command) NULL;
	}
    } else {
	nsPtr = iPtr->globalNsPtr;
	tail = cmdName;
    }

    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);

    if (!new) {
	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

	/*
	 * Command already exists. If its object-based Tcl_ObjCmdProc is
	 * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
	 * argument "proc". Otherwise, we delete the old command. 
	 */

	if (cmdPtr->objProc == TclInvokeStringCommand) {
	    cmdPtr->objProc = proc;
	    cmdPtr->objClientData = clientData;
            cmdPtr->deleteProc = deleteProc;
            cmdPtr->deleteData = clientData;
	    return (Tcl_Command) cmdPtr;
	}

	/*
	 * Otherwise, we delete the old command.  Be careful to preserve
	 * any existing import links so we can restore them down below.
	 * That way, you can redefine a command and its import status
	 * will remain intact.
	 */

	oldRefPtr = cmdPtr->importRefPtr;
	cmdPtr->importRefPtr = NULL;

	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
	if (!new) {
	    /*
	     * If the deletion callback recreated the command, just throw
	     * away the new command (if we try to delete it again, we
	     * could get stuck in an infinite loop).
	     */

	     ckfree((char *) Tcl_GetHashValue(hPtr));
	}
    } else {
	/*
	 * The list of command exported from the namespace might have
	 * changed.  However, we do not need to recompute this just
	 * yet; next time we need the info will be soon enough.
	 */

	TclInvalidateNsCmdLookup(nsPtr);

    }
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = nsPtr;
    cmdPtr->refCount = 1;
    cmdPtr->cmdEpoch = 0;
    cmdPtr->compileProc = (CompileProc *) NULL;
    cmdPtr->objProc = proc;
    cmdPtr->objClientData = clientData;
    cmdPtr->proc = TclInvokeObjectCommand;
    cmdPtr->clientData = (ClientData) cmdPtr;
    cmdPtr->deleteProc = deleteProc;
    cmdPtr->deleteData = clientData;
    cmdPtr->flags = 0;
    cmdPtr->importRefPtr = NULL;
    cmdPtr->tracePtr = NULL;

    /*
     * Plug in any existing import references found above.  Be sure
     * to update all of these references to point to the new command.
     */

    if (oldRefPtr != NULL) {
	cmdPtr->importRefPtr = oldRefPtr;
	while (oldRefPtr != NULL) {
	    refCmdPtr = oldRefPtr->importedCmdPtr;
	    dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
	    dataPtr->realCmdPtr = cmdPtr;
	    oldRefPtr = oldRefPtr->nextPtr;
	}
    }
    
    /*
     * We just created a command, so in its namespace and all of its parent
     * namespaces, it may shadow global commands with the same name. If any
     * shadowed commands are found, invalidate all cached command references
     * in the affected namespaces.
     */
    
    TclResetShadowedCmdRefs(interp, cmdPtr);
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInvokeStringCommand --
 *
 *	"Wrapper" Tcl_ObjCmdProc used to call an existing string-based
 *	Tcl_CmdProc if no object-based procedure exists for a command. A
 *	pointer to this procedure is stored as the Tcl_ObjCmdProc in a
 *	Command structure. It simply turns around and calls the string
 *	Tcl_CmdProc in the Command structure.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Besides those side effects of the called Tcl_CmdProc,
 *	TclInvokeStringCommand allocates and frees storage.







|
















|

|














|
|


|
|


|
|



















|
|
|
|
|
|




|
<
|
|

|
|








|
|
|



|
|

|



|
|
|













|
|

|

|






|
|
|








|


|

|




|
|
<









|
|




|
|
|





|
|

|





|
|
|
|
|













|
|


|
|










|











|
|
|
|
|
|



|
|
|



|

|












|
|
|


|
<

|
|
|
<

>
|
|
|
|

>
|
|

|

|




|
|




|
|
|



|
|
|










|
|



|
|
|

|





|
|




<


|
|
|
|

















|
|






|
|
|






|
|


|
|



|
|












|
|






|
|
|



|
|
|






|



|
|
|
|










|
|
|






|
|
|



>



















|
|


















|












|
|



|
|
|
|
|




|
|






|
|


|
|





|
|












|
|






|
|
|



|
|
|








>






|





|
|




|
|
|
|









|
|
|






|
|
|



>



















|
|











|






|











|
|
|







1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183

1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260

1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374

1375
1376
1377
1378

1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442

1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
	iPtr->errorInfo = NULL;
    }
    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
    }
    if (iPtr->appendResult != NULL) {
	ckfree(iPtr->appendResult);
	iPtr->appendResult = NULL;
    }
    TclFreePackageInfo(iPtr);
    while (iPtr->tracePtr != NULL) {
	Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr);
    }
    if (iPtr->execEnvPtr != NULL) {
	TclDeleteExecEnv(iPtr->execEnvPtr);
    }
    Tcl_DecrRefCount(iPtr->emptyObjPtr);
    iPtr->emptyObjPtr = NULL;

    resPtr = iPtr->resolverPtr;
    while (resPtr) {
	nextResPtr = resPtr->nextPtr;
	ckfree(resPtr->name);
	ckfree((char *) resPtr);
	resPtr = nextResPtr;
    }

    /*
     * Free up literal objects created for scripts compiled by the
     * interpreter.
     */

    TclDeleteLiteralTable(interp, &(iPtr->literalTable));
    ckfree((char *) iPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_HideCommand --
 *
 *	Makes a command hidden so that it cannot be invoked from within an
 *	interpreter, only from within an ancestor.
 *
 * Results:
 *	A standard Tcl result; also leaves a message in the interp's result if
 *	an error occurs.
 *
 * Side effects:
 *	Removes a command from the command table and create an entry into the
 *	hidden command table under the specified token name.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
    Tcl_Interp *interp;		/* Interpreter in which to hide command. */
    CONST char *cmdName;	/* Name of command to hide. */
    CONST char *hiddenCmdToken;	/* Token name of the to-be-hidden command. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_HashTable *hiddenCmdTablePtr;
    Tcl_HashEntry *hPtr;
    int new;

    if (iPtr->flags & DELETED) {

	/*
	 * The interpreter is being deleted. Do not create any new structures,
	 * because it is not safe to modify the interpreter.
	 */

	return TCL_ERROR;
    }

    /*
     * Disallow hiding of commands that are currently in a namespace or
     * renaming (as part of hiding) into a namespace (because the current

     * implementation with a single global table and the needed uniqueness of
     * names cause problems with namespaces).
     *
     * We don't need to check for "::" in cmdName because the real check is on
     * the nsPtr below.
     *
     * hiddenCmdToken is just a string which is not interpreted in any way.
     * It may contain :: but the string is not interpreted as a namespace
     * qualifier command name. Thus, hiding foo::bar to foo::bar and then
     * trying to expose or invoke ::foo::bar will NOT work; but if the
     * application always uses the same strings it will get consistent
     * behaviour.
     *
     * But as we currently limit ourselves to the global namespace only for
     * the source, in order to avoid potential confusion, lets prevent "::" in
     * the token too. - dl
     */

    if (strstr(hiddenCmdToken, "::") != NULL) {
	Tcl_AppendResult(interp,
		"cannot use namespace qualifiers in hidden command",
		" token (rename)", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Find the command to hide. An error is returned if cmdName can't be
     * found. Look up the command only from the global namespace. Full path of
     * the command must be given if using namespaces.
     */

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
	    /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
    if (cmd == (Tcl_Command) NULL) {
	return TCL_ERROR;
    }
    cmdPtr = (Command *) cmd;

    /*
     * Check that the command is really in global namespace
     */

    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
	Tcl_AppendResult(interp, "can only hide global namespace commands",
		" (use rename then hide)", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Initialize the hidden command table if necessary.
     */

    hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
    if (hiddenCmdTablePtr == NULL) {
	hiddenCmdTablePtr = (Tcl_HashTable *)
		ckalloc((unsigned) sizeof(Tcl_HashTable));
	Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
	iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
    }

    /*
     * It is an error to move an exposed command to a hidden command with
     * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
     * exists.
     */

    hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
    if (!new) {
	Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken,
		"\" already exists", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Nb : This code is currently 'like' a rename to a specialy set apart
     * name table. Changes here and in TclRenameCommand must be kept in synch
     * untill the common parts are actually factorized out.

     */

    /*
     * Remove the hash entry for the command from the interpreter command
     * table. This is like deleting the command, so bump its command epoch;
     * this invalidates any cached references that point to the command.
     */

    if (cmdPtr->hPtr != NULL) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
	cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
	cmdPtr->cmdEpoch++;
    }

    /*
     * The list of command exported from the namespace might have changed.
     * However, we do not need to recompute this just yet; next time we need
     * the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * Now link the hash table entry with the command structure. We ensured
     * above that the nsPtr was right.
     */

    cmdPtr->hPtr = hPtr;
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);

    /*
     * If the command being hidden has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This makes
     * sure that we don't later try to execute old code compiled with
     * command-specific (i.e., inline) bytecodes for the now-hidden command.
     * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
     * compilation epoch doesn't match is recompiled.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExposeCommand --
 *
 *	Makes a previously hidden command callable from inside the interpreter
 *	instead of only by its ancestors.
 *
 * Results:
 *	A standard Tcl result. If an error occurs, a message is left in the
 *	interp's result.
 *
 * Side effects:
 *	Moves commands from one hash table to another.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
    Tcl_Interp *interp;		/* Interpreter in which to make command
				 * callable. */
    CONST char *hiddenCmdToken;	/* Name of hidden command. */
    CONST char *cmdName;	/* Name of to-be-exposed command. */
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr;
    Namespace *nsPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *hiddenCmdTablePtr;
    int new;

    if (iPtr->flags & DELETED) {
	/*
	 * The interpreter is being deleted. Do not create any new structures,
	 * because it is not safe to modify the interpreter.
	 */

	return TCL_ERROR;
    }

    /*
     * Check that we have a regular name for the command (that the user is not
     * trying to do an expose and a rename (to another namespace) at the same
     * time).
     */

    if (strstr(cmdName, "::") != NULL) {
	Tcl_AppendResult(interp, "can not expose to a namespace ",
		"(use expose to toplevel, then rename)", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Get the command from the hidden command table:
     */

    hPtr = NULL;
    hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
    if (hiddenCmdTablePtr != NULL) {
	hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
    }
    if (hPtr == (Tcl_HashEntry *) NULL) {
	Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken,
		"\"", (char *) NULL);
	return TCL_ERROR;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);


    /*
     * Check that we have a true global namespace command (enforced by
     * Tcl_HideCommand() but let's double check. (If it was not, we would not
     * really know how to handle it).

     */

    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
	/*
	 * This case is theoritically impossible, we might rather Tcl_Panic()
	 * than 'nicely' erroring out ?
	 */

	Tcl_AppendResult(interp,
		"trying to expose a non global command name space command",
		(char *) NULL);
	return TCL_ERROR;
    }

    /* This is the global table */
    nsPtr = cmdPtr->nsPtr;

    /*
     * It is an error to overwrite an existing exposed command as a result of
     * exposing a previously hidden command.
     */

    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
    if (!new) {
	Tcl_AppendResult(interp, "exposed command \"", cmdName,
		"\" already exists", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * The list of command exported from the namespace might have changed.
     * However, we do not need to recompute this just yet; next time we need
     * the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(nsPtr);

    /*
     * Remove the hash entry for the command from the interpreter hidden
     * command table.
     */

    if (cmdPtr->hPtr != NULL) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
	cmdPtr->hPtr = NULL;
    }

    /*
     * Now link the hash table entry with the command structure. This is like
     * creating a new command, so deal with any shadowing of commands in the
     * global namespace.
     */

    cmdPtr->hPtr = hPtr;

    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);

    /*
     * Not needed as we are only in the global namespace (but would be needed
     * again if we supported namespace command hiding)
     *
     * TclResetShadowedCmdRefs(interp, cmdPtr);
     */


    /*
     * If the command being exposed has a compile procedure, increment
     * interpreter's compileEpoch to invalidate its compiled code. This makes
     * sure that we don't later try to execute old code compiled assuming the
     * command is hidden. This field is checked in Tcl_EvalObj and
     * ObjInterpProc, and code whose compilation epoch doesn't match is
     * recompiled.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCommand --
 *
 *	Define a new command in a command table.
 *
 * Results:
 *	The return value is a token for the command, which can be used in
 *	future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *	If a command named cmdName already exists for interp, it is deleted.
 *	In the future, when cmdName is seen as the name of a command by
 *	Tcl_Eval, proc will be called. To support the bytecode interpreter,
 *	the command is created with a wrapper Tcl_ObjCmdProc
 *	(TclInvokeStringCommand) that eventially calls proc. When the command
 *	is deleted from the table, deleteProc will be called.  See the manual
 *	entry for details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;		/* Token for command interpreter returned by a
				 * previous call to Tcl_CreateInterp. */
    CONST char *cmdName;	/* Name of command. If it contains namespace
				 * qualifiers, the new command is put in the
				 * specified namespace; otherwise it is put in
				 * the global namespace. */
    Tcl_CmdProc *proc;		/* Procedure to associate with cmdName. */
    ClientData clientData;	/* Arbitrary value passed to string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* If not NULL, gives a procedure to call when
				 * this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    ImportRef *oldRefPtr = NULL;
    Namespace *nsPtr, *dummy1, *dummy2;
    Command *cmdPtr, *refCmdPtr;
    Tcl_HashEntry *hPtr;
    CONST char *tail;
    int new;
    ImportedCmdData *dataPtr;

    if (iPtr->flags & DELETED) {
	/*
	 * The interpreter is being deleted. Don't create any new commands;
	 * it's not safe to muck with the interpreter anymore.
	 */

	return (Tcl_Command) NULL;
    }

    /*
     * Determine where the command should reside. If its name contains
     * namespace qualifiers, we put it in the specified namespace; otherwise,
     * we always put it in the global namespace.
     */

    if (strstr(cmdName, "::") != NULL) {
	TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
	if ((nsPtr == NULL) || (tail == NULL)) {
	    return (Tcl_Command) NULL;
	}
    } else {
	nsPtr = iPtr->globalNsPtr;
	tail = cmdName;
    }

    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
    if (!new) {
	/*
	 * Command already exists. Delete the old one. Be careful to preserve
	 * any existing import links so we can restore them down below. That
	 * way, you can redefine a command and its import status will remain
	 * intact.
	 */

	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
	oldRefPtr = cmdPtr->importRefPtr;
	cmdPtr->importRefPtr = NULL;

	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
	if (!new) {
	    /*
	     * If the deletion callback recreated the command, just throw away
	     * the new command (if we try to delete it again, we could get
	     * stuck in an infinite loop).
	     */

	     ckfree((char*) Tcl_GetHashValue(hPtr));
	}
    } else {
	/*
	 * The list of command exported from the namespace might have changed.
	 * However, we do not need to recompute this just yet; next time we
	 * need the info will be soon enough.
	 */

	TclInvalidateNsCmdLookup(nsPtr);
	TclInvalidateNsPath(nsPtr);
    }
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = nsPtr;
    cmdPtr->refCount = 1;
    cmdPtr->cmdEpoch = 0;
    cmdPtr->compileProc = (CompileProc *) NULL;
    cmdPtr->objProc = TclInvokeStringCommand;
    cmdPtr->objClientData = (ClientData) cmdPtr;
    cmdPtr->proc = proc;
    cmdPtr->clientData = clientData;
    cmdPtr->deleteProc = deleteProc;
    cmdPtr->deleteData = clientData;
    cmdPtr->flags = 0;
    cmdPtr->importRefPtr = NULL;
    cmdPtr->tracePtr = NULL;

    /*
     * Plug in any existing import references found above. Be sure to update
     * all of these references to point to the new command.
     */

    if (oldRefPtr != NULL) {
	cmdPtr->importRefPtr = oldRefPtr;
	while (oldRefPtr != NULL) {
	    refCmdPtr = oldRefPtr->importedCmdPtr;
	    dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
	    dataPtr->realCmdPtr = cmdPtr;
	    oldRefPtr = oldRefPtr->nextPtr;
	}
    }

    /*
     * We just created a command, so in its namespace and all of its parent
     * namespaces, it may shadow global commands with the same name. If any
     * shadowed commands are found, invalidate all cached command references
     * in the affected namespaces.
     */

    TclResetShadowedCmdRefs(interp, cmdPtr);
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateObjCommand --
 *
 *	Define a new object-based command in a command table.
 *
 * Results:
 *	The return value is a token for the command, which can be used in
 *	future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *	If no command named "cmdName" already exists for interp, one is
 *	created. Otherwise, if a command does exist, then if the object-based
 *	Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand
 *	was called previously for the same command and just set its
 *	Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old
 *	command.
 *
 *	In the future, during bytecode evaluation when "cmdName" is seen as
 *	the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
 *	Tcl_ObjCmdProc proc will be called. When the command is deleted from
 *	the table, deleteProc will be called. See the manual entry for details
 *	on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;		/* Token for command interpreter (returned by
				 * previous call to Tcl_CreateInterp). */
    CONST char *cmdName;	/* Name of command. If it contains namespace
				 * qualifiers, the new command is put in the
				 * specified namespace; otherwise it is put in
				 * the global namespace. */
    Tcl_ObjCmdProc *proc;	/* Object-based procedure to associate with
				 * name. */
    ClientData clientData;	/* Arbitrary value to pass to object
    				 * procedure. */
    Tcl_CmdDeleteProc *deleteProc;
				/* If not NULL, gives a procedure to call when
				 * this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    ImportRef *oldRefPtr = NULL;
    Namespace *nsPtr, *dummy1, *dummy2;
    Command *cmdPtr, *refCmdPtr;
    Tcl_HashEntry *hPtr;
    CONST char *tail;
    int new;
    ImportedCmdData *dataPtr;

    if (iPtr->flags & DELETED) {
	/*
	 * The interpreter is being deleted. Don't create any new commands;
	 * it's not safe to muck with the interpreter anymore.
	 */

	return (Tcl_Command) NULL;
    }

    /*
     * Determine where the command should reside. If its name contains
     * namespace qualifiers, we put it in the specified namespace; otherwise,
     * we always put it in the global namespace.
     */

    if (strstr(cmdName, "::") != NULL) {
	TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
	if ((nsPtr == NULL) || (tail == NULL)) {
	    return (Tcl_Command) NULL;
	}
    } else {
	nsPtr = iPtr->globalNsPtr;
	tail = cmdName;
    }

    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
    TclInvalidateNsPath(nsPtr);
    if (!new) {
	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

	/*
	 * Command already exists. If its object-based Tcl_ObjCmdProc is
	 * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
	 * argument "proc". Otherwise, we delete the old command.
	 */

	if (cmdPtr->objProc == TclInvokeStringCommand) {
	    cmdPtr->objProc = proc;
	    cmdPtr->objClientData = clientData;
	    cmdPtr->deleteProc = deleteProc;
	    cmdPtr->deleteData = clientData;
	    return (Tcl_Command) cmdPtr;
	}

	/*
	 * Otherwise, we delete the old command. Be careful to preserve any
	 * existing import links so we can restore them down below. That way,
	 * you can redefine a command and its import status will remain
	 * intact.
	 */

	oldRefPtr = cmdPtr->importRefPtr;
	cmdPtr->importRefPtr = NULL;

	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
	if (!new) {
	    /*
	     * If the deletion callback recreated the command, just throw away
	     * the new command (if we try to delete it again, we could get
	     * stuck in an infinite loop).
	     */

	     ckfree((char *) Tcl_GetHashValue(hPtr));
	}
    } else {
	/*
	 * The list of command exported from the namespace might have changed.
	 * However, we do not need to recompute this just yet; next time we
	 * need the info will be soon enough.
	 */

	TclInvalidateNsCmdLookup(nsPtr);
	TclInvalidateNsPath(nsPtr);
    }
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = nsPtr;
    cmdPtr->refCount = 1;
    cmdPtr->cmdEpoch = 0;
    cmdPtr->compileProc = (CompileProc *) NULL;
    cmdPtr->objProc = proc;
    cmdPtr->objClientData = clientData;
    cmdPtr->proc = TclInvokeObjectCommand;
    cmdPtr->clientData = (ClientData) cmdPtr;
    cmdPtr->deleteProc = deleteProc;
    cmdPtr->deleteData = clientData;
    cmdPtr->flags = 0;
    cmdPtr->importRefPtr = NULL;
    cmdPtr->tracePtr = NULL;

    /*
     * Plug in any existing import references found above. Be sure to update
     * all of these references to point to the new command.
     */

    if (oldRefPtr != NULL) {
	cmdPtr->importRefPtr = oldRefPtr;
	while (oldRefPtr != NULL) {
	    refCmdPtr = oldRefPtr->importedCmdPtr;
	    dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
	    dataPtr->realCmdPtr = cmdPtr;
	    oldRefPtr = oldRefPtr->nextPtr;
	}
    }

    /*
     * We just created a command, so in its namespace and all of its parent
     * namespaces, it may shadow global commands with the same name. If any
     * shadowed commands are found, invalidate all cached command references
     * in the affected namespaces.
     */

    TclResetShadowedCmdRefs(interp, cmdPtr);
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInvokeStringCommand --
 *
 *	"Wrapper" Tcl_ObjCmdProc used to call an existing string-based
 *	Tcl_CmdProc if no object-based procedure exists for a command. A
 *	pointer to this procedure is stored as the Tcl_ObjCmdProc in a Command
 *	structure. It simply turns around and calls the string Tcl_CmdProc in
 *	the Command structure.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Besides those side effects of the called Tcl_CmdProc,
 *	TclInvokeStringCommand allocates and frees storage.
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
     */

#define NUM_ARGS 20
    CONST char *(argStorage[NUM_ARGS]);
    CONST char **argv = argStorage;

    /*
     * Create the string argument array "argv". Make sure argv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-argv word.
     */

    if ((objc + 1) > NUM_ARGS) {
	argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
    }

    for (i = 0;  i < objc;  i++) {







|
|
<







1815
1816
1817
1818
1819
1820
1821
1822
1823

1824
1825
1826
1827
1828
1829
1830
     */

#define NUM_ARGS 20
    CONST char *(argStorage[NUM_ARGS]);
    CONST char **argv = argStorage;

    /*
     * Create the string argument array "argv". Make sure argv is large enough
     * to hold the objc arguments plus 1 extra for the zero end-of-argv word.

     */

    if ((objc + 1) > NUM_ARGS) {
	argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
    }

    for (i = 0;  i < objc;  i++) {
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760

/*
 *----------------------------------------------------------------------
 *
 * TclInvokeObjectCommand --
 *
 *	"Wrapper" Tcl_CmdProc used to call an existing object-based
 *	Tcl_ObjCmdProc if no string-based procedure exists for a command.
 *	A pointer to this procedure is stored as the Tcl_CmdProc in a
 *	Command structure. It simply turns around and calls the object
 *	Tcl_ObjCmdProc in the Command structure.
 *
 * Results:
 *	A standard Tcl string result value.
 *
 * Side effects:
 *	Besides those side effects of the called Tcl_CmdProc,
 *	TclInvokeStringCommand allocates and frees storage.







|
|
|
|







1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868

/*
 *----------------------------------------------------------------------
 *
 * TclInvokeObjectCommand --
 *
 *	"Wrapper" Tcl_CmdProc used to call an existing object-based
 *	Tcl_ObjCmdProc if no string-based procedure exists for a command. A
 *	pointer to this procedure is stored as the Tcl_CmdProc in a Command
 *	structure. It simply turns around and calls the object Tcl_ObjCmdProc
 *	in the Command structure.
 *
 * Results:
 *	A standard Tcl string result value.
 *
 * Side effects:
 *	Besides those side effects of the called Tcl_CmdProc,
 *	TclInvokeStringCommand allocates and frees storage.
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931

1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018

2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
     */

#define NUM_ARGS 20
    Tcl_Obj *(argStorage[NUM_ARGS]);
    register Tcl_Obj **objv = argStorage;

    /*
     * Create the object argument array "objv". Make sure objv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-objv word.
     */

    if (argc > NUM_ARGS) {
	objv = (Tcl_Obj **)
	    ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
    }

    for (i = 0;  i < argc;  i++) {
	length = strlen(argv[i]);
	TclNewObj(objPtr);
	TclInitStringRep(objPtr, argv[i], length);
	Tcl_IncrRefCount(objPtr);
	objv[i] = objPtr;
    }

    /*
     * Invoke the command's object-based Tcl_ObjCmdProc.
     */

    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);

    /*
     * Move the interpreter's object result to the string result, 
     * then reset the object result.
     */

    (void) Tcl_GetStringResult(interp);
    
    /*
     * Decrement the ref counts for the argument objects created above,
     * then free the objv array if malloc'ed storage was used.
     */

    for (i = 0;  i < argc;  i++) {
	objPtr = objv[i];
	Tcl_DecrRefCount(objPtr);
    }
    if (objv != argStorage) {
	ckfree((char *) objv);
    }
    return result;
#undef NUM_ARGS
}

/*
 *----------------------------------------------------------------------
 *
 * TclRenameCommand --
 *
 *      Called to give an existing Tcl command a different name. Both the
 *      old command name and the new command name can have "::" namespace
 *      qualifiers. If the new command has a different namespace context,
 *      the command will be moved to that namespace and will execute in
 *	the context of that new namespace.
 *
 *      If the new command name is NULL or the null string, the command is
 *      deleted.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      If anything goes wrong, an error message is returned in the
 *      interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

int
TclRenameCommand(interp, oldName, newName)
    Tcl_Interp *interp;                 /* Current interpreter. */
    char *oldName;                      /* Existing command name. */
    char *newName;                      /* New command name. */
{
    Interp *iPtr = (Interp *) interp;
    CONST char *newTail;
    Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_HashEntry *hPtr, *oldHPtr;
    int new, result;
    Tcl_Obj* oldFullName;
    Tcl_DString newFullName;

    /*
     * Find the existing command. An error is returned if cmdName can't
     * be found.
     */

    cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
	/*flags*/ 0);
    cmdPtr = (Command *) cmd;
    if (cmdPtr == NULL) {
	Tcl_AppendResult(interp, "can't ",
                ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
                " \"", oldName, "\": command doesn't exist", (char *) NULL);
	return TCL_ERROR;
    }
    cmdNsPtr = cmdPtr->nsPtr;
    oldFullName = Tcl_NewObj();
    Tcl_IncrRefCount( oldFullName );
    Tcl_GetCommandFullName( interp, cmd, oldFullName );

    /*
     * If the new command name is NULL or empty, delete the command. Do this
     * with Tcl_DeleteCommandFromToken, since we already have the command.
     */
    
    if ((newName == NULL) || (*newName == '\0')) {
	Tcl_DeleteCommandFromToken(interp, cmd);
	result = TCL_OK;
	goto done;
    }

    /*
     * Make sure that the destination command does not already exist.
     * The rename operation is like creating a command, so we should
     * automatically create the containing namespaces just like
     * Tcl_CreateCommand would.
     */

    TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
       TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);

    if ((newNsPtr == NULL) || (newTail == NULL)) {
	Tcl_AppendResult(interp, "can't rename to \"", newName,
		"\": bad command name", (char *) NULL);
	result = TCL_ERROR;
	goto done;
    }
    if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
	Tcl_AppendResult(interp, "can't rename to \"", newName,
		 "\": command already exists", (char *) NULL);
	result = TCL_ERROR;
	goto done;
    }

    /*
     * Warning: any changes done in the code here are likely
     * to be needed in Tcl_HideCommand() code too.
     * (until the common parts are extracted out)     --dl

     */

    /*
     * Put the command in the new namespace so we can check for an alias
     * loop. Since we are adding a new command to a namespace, we must
     * handle any shadowing of the global commands that this might create.
     */
    
    oldHPtr = cmdPtr->hPtr;
    hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = newNsPtr;
    TclResetShadowedCmdRefs(interp, cmdPtr);

    /*
     * Now check for an alias loop. If we detect one, put everything back
     * the way it was and report the error.
     */

    result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
    if (result != TCL_OK) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = oldHPtr;
        cmdPtr->nsPtr = cmdNsPtr;
	goto done;
    }

    /*
     * The list of command exported from the namespace might have
     * changed.  However, we do not need to recompute this just yet;
     * next time we need the info will be soon enough.  These might
     * refer to the same variable, but that's no big deal.
     */

    TclInvalidateNsCmdLookup(cmdNsPtr);
    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * Script for rename traces can delete the command "oldName".
     * Therefore increment the reference count for cmdPtr so that
     * it's Command structure is freed only towards the end of this
     * function by calling TclCleanupCommand.
     *
     * The trace procedure needs to get a fully qualified name for
     * old and new commands [Tcl bug #651271], or else there's no way
     * for the trace procedure to get the namespace from which the old
     * command is being renamed!
     */

    Tcl_DStringInit( &newFullName );
    Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 );
    if ( newNsPtr != iPtr->globalNsPtr ) {
	Tcl_DStringAppend( &newFullName, "::", 2 );
    }
    Tcl_DStringAppend( &newFullName, newTail, -1 );
    cmdPtr->refCount++;
    CallCommandTraces( iPtr, cmdPtr,
		       Tcl_GetString( oldFullName ),
		       Tcl_DStringValue( &newFullName ),
		       TCL_TRACE_RENAME);
    Tcl_DStringFree( &newFullName );

    /*
     * The new command name is okay, so remove the command from its
     * current namespace. This is like deleting the command, so bump
     * the cmdEpoch to invalidate any cached references to the command.
     */
    
    Tcl_DeleteHashEntry(oldHPtr);
    cmdPtr->cmdEpoch++;

    /*
     * If the command being renamed has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled for
     * the now-renamed command.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }

    /*
     * Now free the Command structure, if the "oldName" command has
     * been deleted by invocation of rename traces.
     */

    TclCleanupCommand(cmdPtr);
    result = TCL_OK;

    done:
    TclDecrRefCount( oldFullName );
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetCommandInfo --
 *
 *	Modifies various information about a Tcl command. Note that
 *	this procedure will not change a command's namespace; use
 *	TclRenameCommand to do that. Also, the isNativeObjectProc
 *	member of *infoPtr is ignored.
 *
 * Results:
 *	If cmdName exists in interp, then the information at *infoPtr
 *	is stored with the command in place of the current information
 *	and 1 is returned. If the command doesn't exist then 0 is
 *	returned. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;			/* Interpreter in which to look
					 * for command. */
    CONST char *cmdName;		/* Name of desired command. */
    CONST Tcl_CmdInfo *infoPtr;		/* Where to find information
					 * to store in the command. */
{
    Tcl_Command cmd;

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ 0);

    return Tcl_SetCommandInfoFromToken( cmd, infoPtr );

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetCommandInfoFromToken --
 *
 *	Modifies various information about a Tcl command. Note that
 *	this procedure will not change a command's namespace; use
 *	TclRenameCommand to do that. Also, the isNativeObjectProc
 *	member of *infoPtr is ignored.
 *
 * Results:
 *	If cmdName exists in interp, then the information at *infoPtr
 *	is stored with the command in place of the current information
 *	and 1 is returned. If the command doesn't exist then 0 is
 *	returned. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetCommandInfoFromToken( cmd, infoPtr )
    Tcl_Command cmd;
    CONST Tcl_CmdInfo* infoPtr;
{
    Command* cmdPtr;		/* Internal representation of the command */

    if (cmd == (Tcl_Command) NULL) {
	return 0;
    }

    /*
     * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
     */
    
    cmdPtr = (Command *) cmd;
    cmdPtr->proc = infoPtr->proc;
    cmdPtr->clientData = infoPtr->clientData;
    if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
	cmdPtr->objProc = TclInvokeStringCommand;
	cmdPtr->objClientData = (ClientData) cmdPtr;
    } else {







|
|
<



<
|




<
|











|
|



|

|
|


















|
|
|
|
|

|
|


|


|
|






|
|
|












|
|



|



|
|




|
|





|







|
|
|
<



|















|
<
|
>



|
|
|

|








|
|




|
|
|




|
|
|
|






|
|
|
|

|
|
|
|


|
|
|
|

|

|
<
|
<
|


|
|
|

|





|
|
|







|
|

>



|
|








|
|
|
|


|
|
|
<









|
|
|
|
|




|

|








|
|
|
|


|
|
|
<








|












|







1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
1900

1901
1902
1903
1904
1905

1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013

2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033

2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093

2094

2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143

2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181

2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
     */

#define NUM_ARGS 20
    Tcl_Obj *(argStorage[NUM_ARGS]);
    register Tcl_Obj **objv = argStorage;

    /*
     * Create the object argument array "objv". Make sure objv is large enough
     * to hold the objc arguments plus 1 extra for the zero end-of-objv word.

     */

    if (argc > NUM_ARGS) {

	objv = (Tcl_Obj **) ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
    }

    for (i = 0;  i < argc;  i++) {
	length = strlen(argv[i]);

	TclNewStringObj(objPtr, argv[i], length);
	Tcl_IncrRefCount(objPtr);
	objv[i] = objPtr;
    }

    /*
     * Invoke the command's object-based Tcl_ObjCmdProc.
     */

    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);

    /*
     * Move the interpreter's object result to the string result, then reset
     * the object result.
     */

    (void) Tcl_GetStringResult(interp);

    /*
     * Decrement the ref counts for the argument objects created above, then
     * free the objv array if malloc'ed storage was used.
     */

    for (i = 0;  i < argc;  i++) {
	objPtr = objv[i];
	Tcl_DecrRefCount(objPtr);
    }
    if (objv != argStorage) {
	ckfree((char *) objv);
    }
    return result;
#undef NUM_ARGS
}

/*
 *----------------------------------------------------------------------
 *
 * TclRenameCommand --
 *
 *	Called to give an existing Tcl command a different name. Both the old
 *	command name and the new command name can have "::" namespace
 *	qualifiers. If the new command has a different namespace context, the
 *	command will be moved to that namespace and will execute in the
 *	context of that new namespace.
 *
 *	If the new command name is NULL or the null string, the command is
 *	deleted.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, an error message is returned in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

int
TclRenameCommand(interp, oldName, newName)
    Tcl_Interp *interp;			/* Current interpreter. */
    char *oldName;			/* Existing command name. */
    char *newName;			/* New command name. */
{
    Interp *iPtr = (Interp *) interp;
    CONST char *newTail;
    Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_HashEntry *hPtr, *oldHPtr;
    int new, result;
    Tcl_Obj* oldFullName;
    Tcl_DString newFullName;

    /*
     * Find the existing command. An error is returned if cmdName can't be
     * found.
     */

    cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
	    /*flags*/ 0);
    cmdPtr = (Command *) cmd;
    if (cmdPtr == NULL) {
	Tcl_AppendResult(interp, "can't ",
		((newName == NULL)||(*newName == '\0'))? "delete":"rename",
		" \"", oldName, "\": command doesn't exist", (char *) NULL);
	return TCL_ERROR;
    }
    cmdNsPtr = cmdPtr->nsPtr;
    oldFullName = Tcl_NewObj();
    Tcl_IncrRefCount(oldFullName);
    Tcl_GetCommandFullName(interp, cmd, oldFullName);

    /*
     * If the new command name is NULL or empty, delete the command. Do this
     * with Tcl_DeleteCommandFromToken, since we already have the command.
     */

    if ((newName == NULL) || (*newName == '\0')) {
	Tcl_DeleteCommandFromToken(interp, cmd);
	result = TCL_OK;
	goto done;
    }

    /*
     * Make sure that the destination command does not already exist. The
     * rename operation is like creating a command, so we should automatically
     * create the containing namespaces just like Tcl_CreateCommand would.

     */

    TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
	    TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);

    if ((newNsPtr == NULL) || (newTail == NULL)) {
	Tcl_AppendResult(interp, "can't rename to \"", newName,
		"\": bad command name", (char *) NULL);
	result = TCL_ERROR;
	goto done;
    }
    if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
	Tcl_AppendResult(interp, "can't rename to \"", newName,
		 "\": command already exists", (char *) NULL);
	result = TCL_ERROR;
	goto done;
    }

    /*
     * Warning: any changes done in the code here are likely to be needed in

     * Tcl_HideCommand() code too (until the common parts are extracted out).
     * - dl
     */

    /*
     * Put the command in the new namespace so we can check for an alias loop.
     * Since we are adding a new command to a namespace, we must handle any
     * shadowing of the global commands that this might create.
     */

    oldHPtr = cmdPtr->hPtr;
    hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = newNsPtr;
    TclResetShadowedCmdRefs(interp, cmdPtr);

    /*
     * Now check for an alias loop. If we detect one, put everything back the
     * way it was and report the error.
     */

    result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
    if (result != TCL_OK) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
	cmdPtr->hPtr = oldHPtr;
	cmdPtr->nsPtr = cmdNsPtr;
	goto done;
    }

    /*
     * The list of command exported from the namespace might have changed.
     * However, we do not need to recompute this just yet; next time we need
     * the info will be soon enough. These might refer to the same variable,
     * but that's no big deal.
     */

    TclInvalidateNsCmdLookup(cmdNsPtr);
    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * Script for rename traces can delete the command "oldName". Therefore
     * increment the reference count for cmdPtr so that it's Command structure
     * is freed only towards the end of this function by calling
     * TclCleanupCommand.
     *
     * The trace procedure needs to get a fully qualified name for old and new
     * commands [Tcl bug #651271], or else there's no way for the trace
     * procedure to get the namespace from which the old command is being
     * renamed!
     */

    Tcl_DStringInit(&newFullName);
    Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
    if (newNsPtr != iPtr->globalNsPtr) {
	Tcl_DStringAppend(&newFullName, "::", 2);
    }
    Tcl_DStringAppend(&newFullName, newTail, -1);
    cmdPtr->refCount++;
    CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),

	    Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);

    Tcl_DStringFree(&newFullName);

    /*
     * The new command name is okay, so remove the command from its current
     * namespace. This is like deleting the command, so bump the cmdEpoch to
     * invalidate any cached references to the command.
     */

    Tcl_DeleteHashEntry(oldHPtr);
    cmdPtr->cmdEpoch++;

    /*
     * If the command being renamed has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This makes
     * sure that we don't later try to execute old code compiled for the
     * now-renamed command.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }

    /*
     * Now free the Command structure, if the "oldName" command has been
     * deleted by invocation of rename traces.
     */

    TclCleanupCommand(cmdPtr);
    result = TCL_OK;

  done:
    TclDecrRefCount(oldFullName);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetCommandInfo --
 *
 *	Modifies various information about a Tcl command. Note that this
 *	procedure will not change a command's namespace; use TclRenameCommand
 *	to do that. Also, the isNativeObjectProc member of *infoPtr is
 *	ignored.
 *
 * Results:
 *	If cmdName exists in interp, then the information at *infoPtr is
 *	stored with the command in place of the current information and 1 is
 *	returned. If the command doesn't exist then 0 is returned.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;		/* Interpreter in which to look for
				 * command. */
    CONST char *cmdName;	/* Name of desired command. */
    CONST Tcl_CmdInfo *infoPtr;	/* Where to find information to store in the
				 * command. */
{
    Tcl_Command cmd;

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
	    /*flags*/ 0);

    return Tcl_SetCommandInfoFromToken(cmd, infoPtr);

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetCommandInfoFromToken --
 *
 *	Modifies various information about a Tcl command. Note that this
 *	procedure will not change a command's namespace; use TclRenameCommand
 *	to do that. Also, the isNativeObjectProc member of *infoPtr is
 *	ignored.
 *
 * Results:
 *	If cmdName exists in interp, then the information at *infoPtr is
 *	stored with the command in place of the current information and 1 is
 *	returned. If the command doesn't exist then 0 is returned.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetCommandInfoFromToken(cmd, infoPtr)
    Tcl_Command cmd;
    CONST Tcl_CmdInfo* infoPtr;
{
    Command* cmdPtr;		/* Internal representation of the command */

    if (cmd == (Tcl_Command) NULL) {
	return 0;
    }

    /*
     * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
     */

    cmdPtr = (Command *) cmd;
    cmdPtr->proc = infoPtr->proc;
    cmdPtr->clientData = infoPtr->clientData;
    if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
	cmdPtr->objProc = TclInvokeStringCommand;
	cmdPtr->objClientData = (ClientData) cmdPtr;
    } else {
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfo --
 *
 *	Returns various information about a Tcl command.
 *
 * Results:
 *	If cmdName exists in interp, then *infoPtr is modified to
 *	hold information about cmdName and 1 is returned.  If the
 *	command doesn't exist then 0 is returned and *infoPtr isn't
 *	modified.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;			/* Interpreter in which to look
					 * for command. */
    CONST char *cmdName;		/* Name of desired command. */
    Tcl_CmdInfo *infoPtr;		/* Where to store information about
					 * command. */
{
    Tcl_Command cmd;

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ 0);

    return Tcl_GetCommandInfoFromToken( cmd, infoPtr );

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfoFromToken --
 *
 *	Returns various information about a Tcl command.
 *
 * Results:
 *	Copies information from the command identified by 'cmd' into
 *	a caller-supplied structure and returns 1.  If the 'cmd' is
 *	NULL, leaves the structure untouched and returns 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCommandInfoFromToken( cmd, infoPtr )
    Tcl_Command cmd;
    Tcl_CmdInfo* infoPtr;
{

    Command* cmdPtr;		/* Internal representation of the command */

    if ( cmd == (Tcl_Command) NULL ) {
	return 0;
    }

    /*
     * Set isNativeObjectProc 1 if objProc was registered by a call to
     * Tcl_CreateObjCommand. Otherwise set it to 0.
     */







|
|
|
<









|
|
|
|
|




|

|











|
|
|








|



<


|







2220
2221
2222
2223
2224
2225
2226
2227
2228
2229

2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276

2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfo --
 *
 *	Returns various information about a Tcl command.
 *
 * Results:
 *	If cmdName exists in interp, then *infoPtr is modified to hold
 *	information about cmdName and 1 is returned. If the command doesn't
 *	exist then 0 is returned and *infoPtr isn't modified.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;		/* Interpreter in which to look for
				 * command. */
    CONST char *cmdName;	/* Name of desired command. */
    Tcl_CmdInfo *infoPtr;	/* Where to store information about
				 * command. */
{
    Tcl_Command cmd;

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
	    /*flags*/ 0);

    return Tcl_GetCommandInfoFromToken(cmd, infoPtr);

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfoFromToken --
 *
 *	Returns various information about a Tcl command.
 *
 * Results:
 *	Copies information from the command identified by 'cmd' into a
 *	caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves
 *	the structure untouched and returns 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCommandInfoFromToken(cmd, infoPtr)
    Tcl_Command cmd;
    Tcl_CmdInfo* infoPtr;
{

    Command* cmdPtr;		/* Internal representation of the command */

    if (cmd == (Tcl_Command) NULL) {
	return 0;
    }

    /*
     * Set isNativeObjectProc 1 if objProc was registered by a call to
     * Tcl_CreateObjCommand. Otherwise set it to 0.
     */
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240

2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandName --
 *
 *	Given a token returned by Tcl_CreateCommand, this procedure
 *	returns the current name of the command (which may have changed
 *	due to renaming).
 *
 * Results:
 *	The return value is the name of the given command.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetCommandName(interp, command)
    Tcl_Interp *interp;		/* Interpreter containing the command. */
    Tcl_Command command;	/* Token for command returned by a previous
				 * call to Tcl_CreateCommand. The command
				 * must not have been deleted. */
{
    Command *cmdPtr = (Command *) command;

    if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {

	/*
	 * This should only happen if command was "created" after the
	 * interpreter began to be deleted, so there isn't really any
	 * command. Just return an empty string.
	 */

	return "";
    }

    return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandFullName --
 *
 *	Given a token returned by, e.g., Tcl_CreateCommand or
 *	Tcl_FindCommand, this procedure appends to an object the command's
 *	full name, qualified by a sequence of parent namespace names. The
 *	command's fully-qualified name may have changed due to renaming.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The command's fully-qualified name is appended to the string
 *	representation of objPtr. 
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetCommandFullName(interp, command, objPtr)
    Tcl_Interp *interp;		/* Interpreter containing the command. */
    Tcl_Command command;	/* Token for command returned by a previous
				 * call to Tcl_CreateCommand. The command
				 * must not have been deleted. */
    Tcl_Obj *objPtr;		/* Points to the object onto which the
				 * command's full name is appended. */

{
    Interp *iPtr = (Interp *) interp;
    register Command *cmdPtr = (Command *) command;
    char *name;







|
|
|














|
|




<


|
|




>








|
|
|
|






|








|
|







2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330

2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandName --
 *
 *	Given a token returned by Tcl_CreateCommand, this procedure returns
 *	the current name of the command (which may have changed due to
 *	renaming).
 *
 * Results:
 *	The return value is the name of the given command.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetCommandName(interp, command)
    Tcl_Interp *interp;		/* Interpreter containing the command. */
    Tcl_Command command;	/* Token for command returned by a previous
				 * call to Tcl_CreateCommand. The command must
				 * not have been deleted. */
{
    Command *cmdPtr = (Command *) command;

    if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {

	/*
	 * This should only happen if command was "created" after the
	 * interpreter began to be deleted, so there isn't really any command.
	 * Just return an empty string.
	 */

	return "";
    }

    return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandFullName --
 *
 *	Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand,
 *	this procedure appends to an object the command's full name, qualified
 *	by a sequence of parent namespace names. The command's fully-qualified
 *	name may have changed due to renaming.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The command's fully-qualified name is appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetCommandFullName(interp, command, objPtr)
    Tcl_Interp *interp;		/* Interpreter containing the command. */
    Tcl_Command command;	/* Token for command returned by a previous
				 * call to Tcl_CreateCommand. The command must
				 * not have been deleted. */
    Tcl_Obj *objPtr;		/* Points to the object onto which the
				 * command's full name is appended. */

{
    Interp *iPtr = (Interp *) interp;
    register Command *cmdPtr = (Command *) command;
    char *name;
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379


2380
2381

2382
2383

2384
2385
2386
2387
2388
2389
2390
2391
2392
2393

2394
2395
2396
2397
2398
2399
2400
2401
2402
2403


2404


2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540

2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552

2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommand --
 *
 *	Remove the given command from the given interpreter.
 *
 * Results:
 *	0 is returned if the command was deleted successfully.
 *	-1 is returned if there didn't exist a command by that name.
 *
 * Side effects:
 *	cmdName will no longer be recognized as a valid command for
 *	interp.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DeleteCommand(interp, cmdName)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by a previous Tcl_CreateInterp call). */
    CONST char *cmdName;	/* Name of command to remove. */
{
    Tcl_Command cmd;

    /*
     *  Find the desired command and delete it.
     */

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {
	return -1;
    }
    return Tcl_DeleteCommandFromToken(interp, cmd);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommandFromToken --
 *
 *	Removes the given command from the given interpreter. This procedure
 *	resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
 *	of a command name for efficiency.
 *
 * Results:
 *	0 is returned if the command was deleted successfully.
 *	-1 is returned if there didn't exist a command by that name.
 *
 * Side effects:
 *	The command specified by "cmd" will no longer be recognized as a
 *	valid command for "interp".
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DeleteCommandFromToken(interp, cmd)
    Tcl_Interp *interp;		/* Token for command interpreter returned by
				 * a previous call to Tcl_CreateInterp. */
    Tcl_Command cmd;            /* Token for command to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = (Command *) cmd;
    ImportRef *refPtr, *nextRefPtr;
    Tcl_Command importCmd;

    /*
     * The code here is tricky.  We can't delete the hash table entry
     * before invoking the deletion callback because there are cases
     * where the deletion callback needs to invoke the command (e.g.
     * object systems such as OTcl). However, this means that the
     * callback could try to delete or rename the command. The deleted
     * flag allows us to detect these cases and skip nested deletes.
     */

    if (cmdPtr->flags & CMD_IS_DELETED) {
	/*
	 * Another deletion is already in progress.  Remove the hash
	 * table entry now, but don't invoke a callback or free the
	 * command structure.


	 */


        Tcl_DeleteHashEntry(cmdPtr->hPtr);
	cmdPtr->hPtr = NULL;

	return 0;
    }

    /* 
     * We must delete this command, even though both traces and
     * delete procs may try to avoid this (renaming the command etc).
     * Also traces and delete procs may try to delete the command
     * themsevles.  This flag declares that a delete is in progress
     * and that recursive deletes should be ignored.
     */

    cmdPtr->flags |= CMD_IS_DELETED;

    /*
     * Call trace procedures for the command being deleted. Then delete
     * its traces. 
     */

    if (cmdPtr->tracePtr != NULL) {
	CommandTrace *tracePtr;
	CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);


	/* Now delete these traces */


	tracePtr = cmdPtr->tracePtr;
	while (tracePtr != NULL) {
	    CommandTrace *nextPtr = tracePtr->nextPtr;
	    if ((--tracePtr->refCount) <= 0) {
		ckfree((char*)tracePtr);
	    }
	    tracePtr = nextPtr;
	}
	cmdPtr->tracePtr = NULL;
    }

    /*
     * The list of command exported from the namespace might have
     * changed.  However, we do not need to recompute this just yet;
     * next time we need the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * If the command being deleted has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled with
     * command-specific (i.e., inline) bytecodes for the now-deleted
     * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
     * code whose compilation epoch doesn't match is recompiled.
     */

    if (cmdPtr->compileProc != NULL) {
        iPtr->compileEpoch++;
    }

    if (cmdPtr->deleteProc != NULL) {
	/*
	 * Delete the command's client data. If this was an imported command
	 * created when a command was imported into a namespace, this client
	 * data will be a pointer to a ImportedCmdData structure describing
	 * the "real" command that this imported command refers to.
	 */
	
	/*
	 * If you are getting a crash during the call to deleteProc and
	 * cmdPtr->deleteProc is a pointer to the function free(), the
	 * most likely cause is that your extension allocated memory
	 * for the clientData argument to Tcl_CreateObjCommand() with
	 * the ckalloc() macro and you are now trying to deallocate
	 * this memory with free() instead of ckfree(). You should
	 * pass a pointer to your own method that calls ckfree().
	 */

	(*cmdPtr->deleteProc)(cmdPtr->deleteData);
    }

    /*
     * Bump the command epoch counter. This will invalidate all cached
     * references that point to this command.
     */
    
    cmdPtr->cmdEpoch++;

    /*
     * If this command was imported into other namespaces, then imported
     * commands were created that refer back to this command. Delete these
     * imported commands now.
     */

    for (refPtr = cmdPtr->importRefPtr;  refPtr != NULL;
            refPtr = nextRefPtr) {
	nextRefPtr = refPtr->nextPtr;
	importCmd = (Tcl_Command) refPtr->importedCmdPtr;
        Tcl_DeleteCommandFromToken(interp, importCmd);
    }

    /*
     * Don't use hPtr to delete the hash entry here, because it's
     * possible that the deletion callback renamed the command.
     * Instead, use cmdPtr->hptr, and make sure that no-one else
     * has already deleted the hash entry.
     */

    if (cmdPtr->hPtr != NULL) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
    }

    /*
     * Mark the Command structure as no longer valid. This allows
     * TclExecuteByteCode to recognize when a Command has logically been
     * deleted and a pointer to this Command structure cached in a CmdName
     * object is invalid. TclExecuteByteCode will look up the command again
     * in the interpreter's command hashtable.
     */

    cmdPtr->objProc = NULL;

    /*
     * Now free the Command structure, unless there is another reference to
     * it from a CmdName Tcl object in some ByteCode code sequence. In that
     * case, delay the cleanup until all references are either discarded
     * (when a ByteCode is freed) or replaced by a new reference (when a
     * cached CmdName Command reference is found to be invalid and
     * TclExecuteByteCode looks up the command in the command hashtable).
     */
    
    TclCleanupCommand(cmdPtr);
    return 0;
}

static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
    Interp *iPtr;		/* Interpreter containing command. */
    Command *cmdPtr;		/* Command whose traces are to be
				 * invoked. */
    CONST char *oldName;        /* Command's old name, or NULL if we
                                 * must get the name from cmdPtr */
    CONST char *newName;        /* Command's new name, or NULL if
                                 * the command is not being renamed */
    int flags;			/* Flags indicating the type of traces
				 * to trigger, either TCL_TRACE_DELETE
				 * or TCL_TRACE_RENAME. */
{
    register CommandTrace *tracePtr;
    ActiveCommandTrace active;
    char *result;
    Tcl_Obj *oldNamePtr = NULL;

    if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
	/* 
	 * While a rename trace is active, we will not process any more
	 * rename traces; while a delete trace is active we will never
	 * reach here -- because Tcl_DeleteCommandFromToken checks for the
	 * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately
	 * when a command deletion is in progress.  For all other traces,
	 * delete traces will not be invoked but a call to TraceCommandProc
	 * will ensure that tracePtr->clientData is freed whenever the
	 * command "oldName" is deleted.
	 */

	if (cmdPtr->flags & TCL_TRACE_RENAME) {
	    flags &= ~TCL_TRACE_RENAME;
	}
	if (flags == 0) {
	    return NULL;
	}
    }
    cmdPtr->flags |= CMD_TRACE_ACTIVE;
    cmdPtr->refCount++;
    
    result = NULL;
    active.nextPtr = iPtr->activeCmdTracePtr;

    iPtr->activeCmdTracePtr = &active;

    if (flags & TCL_TRACE_DELETE) {
	flags |= TCL_TRACE_DESTROYED;
    }
    active.cmdPtr = cmdPtr;
    
    Tcl_Preserve((ClientData) iPtr);
    
    for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
	 tracePtr = active.nextTracePtr) {
	active.nextTracePtr = tracePtr->nextPtr;
	if (!(tracePtr->flags & flags)) {
	    continue;
	}
	cmdPtr->flags |= tracePtr->flags;
	if (oldName == NULL) {
	    TclNewObj(oldNamePtr);
	    Tcl_IncrRefCount(oldNamePtr);
	    Tcl_GetCommandFullName((Tcl_Interp *) iPtr, 
	            (Tcl_Command) cmdPtr, oldNamePtr);
	    oldName = TclGetString(oldNamePtr);
	}
	tracePtr->refCount++;
	(*tracePtr->traceProc)(tracePtr->clientData,
		(Tcl_Interp *) iPtr, oldName, newName, flags);
	cmdPtr->flags &= ~tracePtr->flags;
	if ((--tracePtr->refCount) <= 0) {
	    ckfree((char*)tracePtr);
	}
    }

    /*
     * If a new object was created to hold the full oldName,
     * free it now.
     */

    if (oldNamePtr != NULL) {
	TclDecrRefCount(oldNamePtr);
    }

    /*
     * Restore the variable's flags, remove the record of our active
     * traces, and then return.
     */

    cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
    cmdPtr->refCount--;
    iPtr->activeCmdTracePtr = active.nextPtr;
    Tcl_Release((ClientData) iPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupCommand --
 *
 *	This procedure frees up a Command structure unless it is still
 *	referenced from an interpreter's command hashtable or from a CmdName
 *	Tcl object representing the name of a command in a ByteCode
 *	instruction sequence. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed unless a reference to the Command structure still
 *	exists. In that case the cleanup is delayed until the command is







|
|


|
<






|
|









|












|
|


|
|


|
|






|
|
|







|
|
|
|
|
|




|
|
|
>
>


>
|
|
>



|
|
|
|
|
|

>



|
|





>
>
|
>
>












|
|
|






|
|
|
|
|



|









|


|
|
|
|
|
|









|









|


|



|
|
|
|










|
|





|
|
|
|
|
|

|







|
<
|
|
|
|
|
|
|







|
|
|
|
|
|
|
|
|

>









|


>






|

|

|








|
|












|
<







|
|

















|







2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408

2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622

2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694

2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommand --
 *
 *	Remove the given command from the given interpreter.
 *
 * Results:
 *	0 is returned if the command was deleted successfully. -1 is returned
 *	if there didn't exist a command by that name.
 *
 * Side effects:
 *	cmdName will no longer be recognized as a valid command for interp.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_DeleteCommand(interp, cmdName)
    Tcl_Interp *interp;		/* Token for command interpreter (returned by
				 * a previous Tcl_CreateInterp call). */
    CONST char *cmdName;	/* Name of command to remove. */
{
    Tcl_Command cmd;

    /*
     *  Find the desired command and delete it.
     */

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
	    /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {
	return -1;
    }
    return Tcl_DeleteCommandFromToken(interp, cmd);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommandFromToken --
 *
 *	Removes the given command from the given interpreter. This procedure
 *	resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of
 *	a command name for efficiency.
 *
 * Results:
 *	0 is returned if the command was deleted successfully. -1 is returned
 *	if there didn't exist a command by that name.
 *
 * Side effects:
 *	The command specified by "cmd" will no longer be recognized as a valid
 *	command for "interp".
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DeleteCommandFromToken(interp, cmd)
    Tcl_Interp *interp;		/* Token for command interpreter returned by a
				 * previous call to Tcl_CreateInterp. */
    Tcl_Command cmd;		/* Token for command to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = (Command *) cmd;
    ImportRef *refPtr, *nextRefPtr;
    Tcl_Command importCmd;

    /*
     * The code here is tricky. We can't delete the hash table entry before
     * invoking the deletion callback because there are cases where the
     * deletion callback needs to invoke the command (e.g. object systems such
     * as OTcl). However, this means that the callback could try to delete or
     * rename the command. The deleted flag allows us to detect these cases
     * and skip nested deletes.
     */

    if (cmdPtr->flags & CMD_IS_DELETED) {
	/*
	 * Another deletion is already in progress. Remove the hash table
	 * entry now, but don't invoke a callback or free the command
	 * structure. Take care to only remove the hash entry if it has not
	 * already been removed; otherwise if we manage to hit this function
	 * three times, everything goes up in smoke. [Bug 1220058]
	 */

	if (cmdPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(cmdPtr->hPtr);
	    cmdPtr->hPtr = NULL;
	}
	return 0;
    }

    /*
     * We must delete this command, even though both traces and delete procs
     * may try to avoid this (renaming the command etc). Also traces and
     * delete procs may try to delete the command themsevles. This flag
     * declares that a delete is in progress and that recursive deletes should
     * be ignored.
     */

    cmdPtr->flags |= CMD_IS_DELETED;

    /*
     * Call trace procedures for the command being deleted. Then delete its
     * traces.
     */

    if (cmdPtr->tracePtr != NULL) {
	CommandTrace *tracePtr;
	CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);

	/*
	 * Now delete these traces.
	 */

	tracePtr = cmdPtr->tracePtr;
	while (tracePtr != NULL) {
	    CommandTrace *nextPtr = tracePtr->nextPtr;
	    if ((--tracePtr->refCount) <= 0) {
		ckfree((char*)tracePtr);
	    }
	    tracePtr = nextPtr;
	}
	cmdPtr->tracePtr = NULL;
    }

    /*
     * The list of command exported from the namespace might have changed.
     * However, we do not need to recompute this just yet; next time we need
     * the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * If the command being deleted has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This makes
     * sure that we don't later try to execute old code compiled with
     * command-specific (i.e., inline) bytecodes for the now-deleted command.
     * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
     * compilation epoch doesn't match is recompiled.
     */

    if (cmdPtr->compileProc != NULL) {
	iPtr->compileEpoch++;
    }

    if (cmdPtr->deleteProc != NULL) {
	/*
	 * Delete the command's client data. If this was an imported command
	 * created when a command was imported into a namespace, this client
	 * data will be a pointer to a ImportedCmdData structure describing
	 * the "real" command that this imported command refers to.
	 */

	/*
	 * If you are getting a crash during the call to deleteProc and
	 * cmdPtr->deleteProc is a pointer to the function free(), the most
	 * likely cause is that your extension allocated memory for the
	 * clientData argument to Tcl_CreateObjCommand() with the ckalloc()
	 * macro and you are now trying to deallocate this memory with free()
	 * instead of ckfree(). You should pass a pointer to your own method
	 * that calls ckfree().
	 */

	(*cmdPtr->deleteProc)(cmdPtr->deleteData);
    }

    /*
     * Bump the command epoch counter. This will invalidate all cached
     * references that point to this command.
     */

    cmdPtr->cmdEpoch++;

    /*
     * If this command was imported into other namespaces, then imported
     * commands were created that refer back to this command. Delete these
     * imported commands now.
     */

    for (refPtr = cmdPtr->importRefPtr;  refPtr != NULL;
	    refPtr = nextRefPtr) {
	nextRefPtr = refPtr->nextPtr;
	importCmd = (Tcl_Command) refPtr->importedCmdPtr;
	Tcl_DeleteCommandFromToken(interp, importCmd);
    }

    /*
     * Don't use hPtr to delete the hash entry here, because it's possible
     * that the deletion callback renamed the command. Instead, use
     * cmdPtr->hptr, and make sure that no-one else has already deleted the
     * hash entry.
     */

    if (cmdPtr->hPtr != NULL) {
	Tcl_DeleteHashEntry(cmdPtr->hPtr);
    }

    /*
     * Mark the Command structure as no longer valid. This allows
     * TclExecuteByteCode to recognize when a Command has logically been
     * deleted and a pointer to this Command structure cached in a CmdName
     * object is invalid. TclExecuteByteCode will look up the command again in
     * the interpreter's command hashtable.
     */

    cmdPtr->objProc = NULL;

    /*
     * Now free the Command structure, unless there is another reference to it
     * from a CmdName Tcl object in some ByteCode code sequence. In that case,
     * delay the cleanup until all references are either discarded (when a
     * ByteCode is freed) or replaced by a new reference (when a cached
     * CmdName Command reference is found to be invalid and TclExecuteByteCode
     * looks up the command in the command hashtable).
     */

    TclCleanupCommand(cmdPtr);
    return 0;
}

static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
    Interp *iPtr;		/* Interpreter containing command. */
    Command *cmdPtr;		/* Command whose traces are to be invoked. */

    CONST char *oldName;	/* Command's old name, or NULL if we must get
				 * the name from cmdPtr */
    CONST char *newName;	/* Command's new name, or NULL if the command
				 * is not being renamed */
    int flags;			/* Flags indicating the type of traces to
				 * trigger, either TCL_TRACE_DELETE or
				 * TCL_TRACE_RENAME. */
{
    register CommandTrace *tracePtr;
    ActiveCommandTrace active;
    char *result;
    Tcl_Obj *oldNamePtr = NULL;

    if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
	/*
	 * While a rename trace is active, we will not process any more rename
	 * traces; while a delete trace is active we will never reach here -
	 * because Tcl_DeleteCommandFromToken checks for the condition
	 * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
	 * command deletion is in progress. For all other traces, delete
	 * traces will not be invoked but a call to TraceCommandProc will
	 * ensure that tracePtr->clientData is freed whenever the command
	 * "oldName" is deleted.
	 */

	if (cmdPtr->flags & TCL_TRACE_RENAME) {
	    flags &= ~TCL_TRACE_RENAME;
	}
	if (flags == 0) {
	    return NULL;
	}
    }
    cmdPtr->flags |= CMD_TRACE_ACTIVE;
    cmdPtr->refCount++;

    result = NULL;
    active.nextPtr = iPtr->activeCmdTracePtr;
    active.reverseScan = 0;
    iPtr->activeCmdTracePtr = &active;

    if (flags & TCL_TRACE_DELETE) {
	flags |= TCL_TRACE_DESTROYED;
    }
    active.cmdPtr = cmdPtr;

    Tcl_Preserve((ClientData) iPtr);

    for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
	    tracePtr = active.nextTracePtr) {
	active.nextTracePtr = tracePtr->nextPtr;
	if (!(tracePtr->flags & flags)) {
	    continue;
	}
	cmdPtr->flags |= tracePtr->flags;
	if (oldName == NULL) {
	    TclNewObj(oldNamePtr);
	    Tcl_IncrRefCount(oldNamePtr);
	    Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
		    (Tcl_Command) cmdPtr, oldNamePtr);
	    oldName = TclGetString(oldNamePtr);
	}
	tracePtr->refCount++;
	(*tracePtr->traceProc)(tracePtr->clientData,
		(Tcl_Interp *) iPtr, oldName, newName, flags);
	cmdPtr->flags &= ~tracePtr->flags;
	if ((--tracePtr->refCount) <= 0) {
	    ckfree((char*)tracePtr);
	}
    }

    /*
     * If a new object was created to hold the full oldName, free it now.

     */

    if (oldNamePtr != NULL) {
	TclDecrRefCount(oldNamePtr);
    }

    /*
     * Restore the variable's flags, remove the record of our active traces,
     * and then return.
     */

    cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
    cmdPtr->refCount--;
    iPtr->activeCmdTracePtr = active.nextPtr;
    Tcl_Release((ClientData) iPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupCommand --
 *
 *	This procedure frees up a Command structure unless it is still
 *	referenced from an interpreter's command hashtable or from a CmdName
 *	Tcl object representing the name of a command in a ByteCode
 *	instruction sequence.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed unless a reference to the Command structure still
 *	exists. In that case the cleanup is delayed until the command is
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712













































2713







2714




2715



2716











































2717








2718



















2719


























































































2720




2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760



2761





2762



2763
2764

2765



2766

2767
2768
2769
2770
2771
2772
2773
2774



2775


2776
2777
2778
2779
2780
2781
2782
2783
2784
2785



2786
2787
2788
2789

2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816




2817
2818
2819
2820
2821











2822

2823
2824
2825
2826
2827
2828
2829
2830
2831
2832


2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975



2976
2977

2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000

3001
3002
3003
3004
3005
3006
3007
3008
3009
3010

3011
3012
3013

3014
3015
3016
3017
3018

3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029

3030


3031
3032

3033
3034
3035
3036
3037
3038
3039
3040

3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065

3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateMathFunc --
 *
 *	Creates a new math function for expressions in a given
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The function defined by "name" is created or redefined. If the
 *	function already exists then its definition is replaced; this
 *	includes the builtin functions. Redefining a builtin function forces
 *	all existing code to be invalidated since that code may be compiled
 *	using an instruction specific to the replaced function. In addition,
 *	redefioning a non-builtin function will force existing code to be
 *	invalidated if the number of arguments has changed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
    Tcl_Interp *interp;			/* Interpreter in which function is
					 * to be available. */
    CONST char *name;			/* Name of function (e.g. "sin"). */
    int numArgs;			/* Nnumber of arguments required by
					 * function. */
    Tcl_ValueType *argTypes;		/* Array of types acceptable for
					 * each argument. */
    Tcl_MathProc *proc;			/* Procedure that implements the
					 * math function. */
    ClientData clientData;		/* Additional value to pass to the
					 * function. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    MathFunc *mathFuncPtr;
    int new, i;

    hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
    if (new) {
	Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
    }
    mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);

    if (!new) {	
	if (mathFuncPtr->builtinFuncIndex >= 0) {
	    /*
	     * We are redefining a builtin math function. Invalidate the
             * interpreter's existing code by incrementing its
             * compileEpoch member. This field is checked in Tcl_EvalObj
             * and ObjInterpProc, and code whose compilation epoch doesn't
             * match is recompiled. Newly compiled code will no longer
             * treat the function as builtin.
	     */

	    iPtr->compileEpoch++;
	} else {
	    /*
	     * A non-builtin function is being redefined. We must invalidate
             * existing code if the number of arguments has changed. This
	     * is because existing code was compiled assuming that number.
	     */

	    if (numArgs != mathFuncPtr->numArgs) {
		iPtr->compileEpoch++;
	    }
	}
    }
    
    mathFuncPtr->builtinFuncIndex = -1;	/* can't be a builtin function */
    if (numArgs > MAX_MATH_ARGS) {













































	numArgs = MAX_MATH_ARGS;







    }




    mathFuncPtr->numArgs = numArgs;



    for (i = 0;  i < numArgs;  i++) {











































	mathFuncPtr->argTypes[i] = argTypes[i];








    }



















    mathFuncPtr->proc = proc;


























































































    mathFuncPtr->clientData = clientData;




}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMathFuncInfo --
 *
 *	Discovers how a particular math function was created in a given
 *	interpreter.
 *
 * Results:
 *	TCL_OK if it succeeds, TCL_ERROR else (leaving an error message
 *	in the interpreter result if that happens.)
 *
 * Side effects:
 *	If this function succeeds, the variables pointed to by the
 *	numArgsPtr and argTypePtr arguments will be updated to detail the
 *	arguments allowed by the function.  The variable pointed to by the
 *	procPtr argument will be set to NULL if the function is a builtin
 *	function, and will be set to the address of the C function used to
 *	implement the math function otherwise (in which case the variable
 *	pointed to by the clientDataPtr argument will also be updated.)
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
		    clientDataPtr)
    Tcl_Interp *interp;
    CONST char *name;
    int *numArgsPtr;
    Tcl_ValueType **argTypesPtr;
    Tcl_MathProc **procPtr;
    ClientData *clientDataPtr;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    MathFunc *mathFuncPtr;
    Tcl_ValueType *argTypes;



    int i,numArgs;









    hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name);
    if (hPtr == NULL) {

        Tcl_AppendResult(interp, "math function \"", name,



		"\" not known in this interpreter", (char *) NULL);

	return TCL_ERROR;
    }
    mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);

    *numArgsPtr = numArgs = mathFuncPtr->numArgs;
    if (numArgs == 0) {
	/* Avoid doing zero-sized allocs... */
	numArgs = 1;



    }


    *argTypesPtr = argTypes =
	(Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
    for (i = 0; i < mathFuncPtr->numArgs; i++) {
	argTypes[i] = mathFuncPtr->argTypes[i];
    }

    if (mathFuncPtr->builtinFuncIndex == -1) {
	*procPtr = (Tcl_MathProc *) NULL;
    } else {
	*procPtr = mathFuncPtr->proc;



	*clientDataPtr = mathFuncPtr->clientData;
    }

    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListMathFuncs --
 *
 *	Produces a list of all the math functions defined in a given
 *	interpreter.
 *
 * Results:
 *	A pointer to a Tcl_Obj structure with a reference count of zero,
 *	or NULL in the case of an error (in which case a suitable error
 *	message will be left in the interpreter result.)
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ListMathFuncs(interp, pattern)
    Tcl_Interp *interp;
    CONST char *pattern;
{
    Interp *iPtr = (Interp *) interp;




    Tcl_Obj *resultList = Tcl_NewObj();
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;
    CONST char *name;












    for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch);

	 hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
        name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr);
	if ((pattern == NULL || Tcl_StringMatch(name, pattern)) &&
	    /* I don't expect this to fail, but... */
	    Tcl_ListObjAppendElement(interp, resultList,
				     Tcl_NewStringObj(name,-1)) != TCL_OK) {
	    Tcl_DecrRefCount(resultList);
	    return NULL;
	}
    }


    return resultList;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInterpReady --
 *
 *	Check if an interpreter is ready to eval commands or scripts, 
 *      i.e., if it was not deleted and if the nesting level is not 
 *      too high.
 *
 * Results:
 *	The return value is TCL_OK if it the interpreter is ready, 
 *      TCL_ERROR otherwise.
 *
 * Side effects:
 *	The interpreters object and string results are cleared.
 *
 *----------------------------------------------------------------------
 */

int 
TclInterpReady(interp)
    Tcl_Interp *interp;
{
    register Interp *iPtr = (Interp *) interp;

    /*
     * Reset both the interpreter's string and object results and clear 
     * out any previous error information. 
     */

    Tcl_ResetResult(interp);

    /*
     * If the interpreter has been deleted, return an error.
     */
    
    if (iPtr->flags & DELETED) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp,
	        "attempt to call eval in deleted interpreter", (char *) NULL);
	Tcl_SetErrorCode(interp, "CORE", "IDELETE",
	        "attempt to call eval in deleted interpreter",
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Check depth of nested calls to Tcl_Eval:  if this gets too large,
     * it's probably because of an infinite loop somewhere.
     */

    if (((iPtr->numLevels) > iPtr->maxNestingDepth) 
	    || (TclpCheckStackSpace() == 0)) {
	Tcl_AppendResult(interp,
		"too many nested evaluations (infinite loop?)", (char *) NULL); 
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclEvalObjvInternal --
 *
 *	This procedure evaluates a Tcl command that has already been
 *	parsed into words, with one Tcl_Obj holding each word. The caller
 *      is responsible for managing the iPtr->numLevels.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as
 *	TCL_OK or TCL_ERROR.  A result or error message is left in
 *	interp's result.  If an error occurs, this procedure does
 *	NOT add any information to the errorInfo variable.
 *
 * Side effects:
 *	Depends on the command.
 *
 *----------------------------------------------------------------------
 */

int
TclEvalObjvInternal(interp, objc, objv, command, length, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * command.  Also used for error
				 * reporting. */
    int objc;			/* Number of words in command. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to objects that are
				 * the words that make up the command. */
    CONST char *command;	/* Points to the beginning of the string
				 * representation of the command; this
				 * is used for traces.  If the string
				 * representation of the command is
				 * unknown, an empty string should be
				 * supplied. If it is NULL, no traces will
				 * be called. */
    int length;			/* Number of bytes in command; if -1, all
				 * characters up to the first null byte are
				 * used. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
				 * currently supported. */

{
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **newObjv;
    int i;
    CallFrame *savedVarFramePtr;	/* Saves old copy of iPtr->varFramePtr
					 * in case TCL_EVAL_GLOBAL was set. */
    int code = TCL_OK;
    int traceCode = TCL_OK;
    int checkTraces = 1;

    if (TclInterpReady(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

    if (objc == 0) {
	return TCL_OK;
    }

    /*
     * If any execution traces rename or delete the current command,
     * we may need (at most) two passes here.
     */
    while (1) {
    
        /*
         * Find the procedure to execute this command. If there isn't one,
         * then see if there is a command "unknown".  If so, create a new
         * word array with "unknown" as the first word and the original
         * command words as arguments.  Then call ourselves recursively
         * to execute it.
	 *
	 * If caller requests, or if we're resolving the target end of
	 * an interpeter alias (TCL_EVAL_INVOKE), be sure to do command
	 * name resolution in the global namespace.



         */


	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & (TCL_EVAL_INVOKE | TCL_EVAL_GLOBAL)) {
	    iPtr->varFramePtr = NULL;
	}
        cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
	iPtr->varFramePtr = savedVarFramePtr;

        if (cmdPtr == NULL) {
	    newObjv = (Tcl_Obj **) ckalloc((unsigned)
		((objc + 1) * sizeof (Tcl_Obj *)));
	    for (i = objc-1; i >= 0; i--) {
	        newObjv[i+1] = objv[i];
	    }
	    newObjv[0] = Tcl_NewStringObj("::unknown", -1);
	    Tcl_IncrRefCount(newObjv[0]);
	    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
	    if (cmdPtr == NULL) {
	        Tcl_AppendResult(interp, "invalid command name \"",
			Tcl_GetString(objv[0]), "\"", (char *) NULL);
	        code = TCL_ERROR;
	    } else {
	        iPtr->numLevels++;
	        code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);

	        iPtr->numLevels--;
	    }
	    Tcl_DecrRefCount(newObjv[0]);
	    ckfree((char *) newObjv);
	    goto done;
        }
    
        /*
         * Call trace procedures if needed.
         */

        if ((checkTraces) && (command != NULL)) {
            int cmdEpoch = cmdPtr->cmdEpoch;
            cmdPtr->refCount++;

            /* 
             * If the first set of traces modifies/deletes the command or
             * any existing traces, then the set checkTraces to 0 and
             * go through this while loop one more time.
             */

            if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
                traceCode = TclCheckInterpTraces(interp, command, length,
                               cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
            }
            if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) 
		    && (traceCode == TCL_OK)) {
                traceCode = TclCheckExecutionTraces(interp, command, length,
                               cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
            }
            cmdPtr->refCount--;
            if (cmdEpoch != cmdPtr->cmdEpoch) {

                /* The command has been modified in some way */


                checkTraces = 0;
                continue;

            }
        }
        break;
    }

    /*
     * Finally, invoke the command's Tcl_ObjCmdProc.
     */

    cmdPtr->refCount++;
    iPtr->cmdCount++;
    if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) {
	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_GLOBAL) {
	    iPtr->varFramePtr = NULL;
	}
	if (!(flags & TCL_EVAL_INVOKE) &&
		(iPtr->ensembleRewrite.sourceObjs != NULL) &&
		!TclIsEnsemble(cmdPtr)) {
	    iPtr->ensembleRewrite.sourceObjs = NULL;
	}
	code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
	iPtr->varFramePtr = savedVarFramePtr;
    }
    if (Tcl_AsyncReady()) {
	code = Tcl_AsyncInvoke(interp, code);
    }
    if (code == TCL_OK && Tcl_LimitReady(interp)) {
	code = Tcl_LimitCheck(interp);
    }

    /*
     * Call 'leave' command traces
     */

    if (!(cmdPtr->flags & CMD_IS_DELETED)) {
        if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
            traceCode = TclCheckExecutionTraces(interp, command, length,
                   cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
        }
        if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
            traceCode = TclCheckInterpTraces(interp, command, length,
                   cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
        }
    }
    TclCleanupCommand(cmdPtr);

    /*
     * If one of the trace invocation resulted in error, then 
     * change the result code accordingly. Note, that the
     * interp->result should already be set correctly by the
     * call to TraceExecutionProc.  
     */

    if (traceCode != TCL_OK) {
	code = traceCode;
    }
    
    /*
     * If the interpreter has a non-empty string result, the result
     * object is either empty or stale because some procedure set
     * interp->result directly. If so, move the string result to the
     * result object, then reset the string result.
     */
    
    if (*(iPtr->result) != 0) {
	(void) Tcl_GetObjResult(interp);
    }

    done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObjv --
 *
 *	This procedure evaluates a Tcl command that has already been
 *	parsed into words, with one Tcl_Obj holding each word.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as
 *	TCL_OK or TCL_ERROR.  A result or error message is left in
 *	interp's result.
 *
 * Side effects:
 *	Depends on the command.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalObjv(interp, objc, objv, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * command.  Also used for error
				 * reporting. */
    int objc;			/* Number of words in command. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
				 * are  currently supported. */
{
    Interp *iPtr = (Interp *)interp;
    Trace *tracePtr;
    Tcl_DString cmdBuf;
    char *cmdString = "";	/* A command string is only necessary for
				 * command traces or error logs; it will be
				 * generated to replace this default value if
				 * necessary. */
    int cmdLen = 0;		/* a non-zero value indicates that a command
				 * string was generated. */
    int code = TCL_OK;
    int i;
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);

    for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
	if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
	    /*
	     * The command may be needed for an execution trace.  Generate a
	     * command string.
	     */
	    
	    Tcl_DStringInit(&cmdBuf);
	    for (i = 0; i < objc; i++) {
		Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
	    }
	    cmdString = Tcl_DStringValue(&cmdBuf);
	    cmdLen = Tcl_DStringLength(&cmdBuf);
	    break;
	}
    }

    iPtr->numLevels++;
    code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
    iPtr->numLevels--;

    /*
     * If we are again at the top level, process any unusual 
     * return code returned by the evaluated code. 
     */
	
    if (iPtr->numLevels == 0) {
	if (code == TCL_RETURN) {
	    code = TclUpdateReturnInfo(iPtr);
	}
	if ((code != TCL_OK) && (code != TCL_ERROR) 
	    && !allowExceptions) {
	    ProcessUnexpectedResult(interp, code);
	    code = TCL_ERROR;
	}
    }
	    
    if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {

	/* 
	 * If there was an error, a command string will be needed for the 
	 * error log: generate it now if it was not done previously.
	 */

	if (cmdLen == 0) {
	    Tcl_DStringInit(&cmdBuf);
	    for (i = 0; i < objc; i++) {
		Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));







|
<






|
|
|
|








|
|
|
|
|
|
|
|
|
|
|

<
<
<
<

<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
|
|
<
|
<
<
<
<

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>











|
|


|
|
|
|
|
|
|






|







<
|
|
|
>
>
>
|
>
>
>
>
>

>
>
>
|
|
>
|
>
>
>
|
>


<

<
<
|
<
>
>
>
|
>
>
|
<
|
|
<
|
<
<

|
>
>
>
|

<

>











|
|
|












|
>
>
>
>
|
|
|
|

>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|
<
|
|
<
<
|
|
>
>
|







|
|
<


|
|







|






|
|







|



|

|
<




|
|


|


|











|
|
|


|
|
|
|










|
<




|
<
|
|
|
|



|
|








|
|













<
<
<
<
<
<
|
|
|
|
<
|
|
|
|
>
>
>
|

>
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
>
|
|
|
>
|
|
|
|
|
>
|
|
|
|
|
<
|
|
|
|
|
>
|
>
>
|
<
>
|
<
<





>









|















>

|
|
|
|
|
|
|
|




|
|
<
|





|

|
|
|
|

|




|








|
|


|
|
<










|
<



|
|
|
|

















|


|















|
|

|










|


|
|







2743
2744
2745
2746
2747
2748
2749
2750

2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780




2781





2782










2783







2784
2785

2786




2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054

3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081

3082


3083

3084
3085
3086
3087
3088
3089
3090

3091
3092

3093


3094
3095
3096
3097
3098
3099
3100

3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154

3155
3156


3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170

3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204

3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247

3248
3249
3250
3251
3252

3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284






3285
3286
3287
3288

3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348

3349
3350
3351
3352
3353
3354
3355
3356
3357
3358

3359
3360


3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407

3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440

3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451

3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateMathFunc --
 *
 *	Creates a new math function for expressions in a given interpreter.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The function defined by "name" is created or redefined. If the
 *	function already exists then its definition is replaced; this includes
 *	the builtin functions. Redefining a builtin function forces all
 *	existing code to be invalidated since that code may be compiled using
 *	an instruction specific to the replaced function. In addition,
 *	redefioning a non-builtin function will force existing code to be
 *	invalidated if the number of arguments has changed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which function is to be
				 * available. */
    CONST char *name;		/* Name of function (e.g. "sin"). */
    int numArgs;		/* Nnumber of arguments required by
				 * function. */
    Tcl_ValueType *argTypes;	/* Array of types acceptable for each
				 * argument. */
    Tcl_MathProc *proc;		/* Procedure that implements the math
				 * function. */
    ClientData clientData;	/* Additional value to pass to the
				 * function. */
{










    Tcl_DString bigName;


















    OldMathFuncData *data = (OldMathFuncData *)
	    ckalloc(sizeof(OldMathFuncData));






    if (numArgs > MAX_MATH_ARGS) {
	Tcl_Panic("attempt to create a math function with too many args");
    }

    data->proc = proc;
    data->numArgs = numArgs;
    data->argTypes = (Tcl_ValueType*)
	    Tcl_Alloc(numArgs * sizeof(Tcl_ValueType));
    memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
    data->clientData = clientData;

    Tcl_DStringInit(&bigName);
    Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1);
    Tcl_DStringAppend(&bigName, name, -1);

    Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName),
	    OldMathFuncProc, (ClientData) data, OldMathFuncDeleteProc);
    Tcl_DStringFree(&bigName);
}

/*
 *----------------------------------------------------------------------
 *
 * OldMathFuncProc --
 *
 *	Dispatch to a math function created with Tcl_CreateMathFunc
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Whatever the math function does.
 *
 *----------------------------------------------------------------------
 */

static int
OldMathFuncProc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ponter to OldMathFuncData describing the
				 * function being called */
    Tcl_Interp *interp;		/* Tcl interpreter */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Parameter vector */
{
    Tcl_Obj* valuePtr;
    OldMathFuncData* dataPtr = (OldMathFuncData*) clientData;
    Tcl_Value args[MAX_MATH_ARGS];
    Tcl_Value funcResult;
    int result;
#if 0
    int i;
#endif
    int j, k;
    double d;

    /*
     * Check argument count.
     */

    if (objc != dataPtr->numArgs + 1) {
	MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv);
	return TCL_ERROR;
    }

    /*
     * Convert arguments from Tcl_Obj's to Tcl_Value's.
     */

#if 0
    for (j = 1, k = 0; j < objc; ++j, ++k) {
	valuePtr = objv[j];
	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * Copy the object's numeric value to the argument record, converting
	 * it if necessary.
	 */

	if (valuePtr->typePtr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
	    if (dataPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = i;
	    } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_LongAsWide(i);
	    } else {
		args[k].type = TCL_INT;
		args[k].intValue = i;
	    }
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    Tcl_WideInt w;
	    TclGetWide(w,valuePtr);
	    if (dataPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = Tcl_WideAsDouble(w);
	    } else if (dataPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].intValue = Tcl_WideAsLong(w);
	    } else {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = w;
	    }
	} else {
	    d = valuePtr->internalRep.doubleValue;
	    if (dataPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].intValue = (long) d;
	    } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_DoubleAsWide(d);
	    } else {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = d;
	    }
	}
    }
#else
    for (j = 1, k = 0; j < objc; ++j, ++k) {
	valuePtr = objv[j];
	result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
	if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
	    d = valuePtr->internalRep.doubleValue;
	    result = TCL_OK;
	}
#endif
	if (result != TCL_OK) {
	    /* Non-numeric argument */
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "argument to math function didn't have numeric value", -1));
	    TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
	    return TCL_ERROR;
	}

	/*
	 * Copy the object's numeric value to the argument record,
	 * converting it if necessary. 
	 *
	 * NOTE: no bignum support;  use the new mathfunc interface for that
	 */

	args[k].type = dataPtr->argTypes[k];
	switch (args[k].type) {
	case TCL_EITHER:
	    if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue))
		    == TCL_OK) {
		args[k].type = TCL_INT;
		break;
	    }
	    if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue))
		    == TCL_OK) {
		args[k].type = TCL_WIDE_INT;
		break;
	    }
	    args[k].type = TCL_DOUBLE;
	    /* FALLTHROUGH */

	case TCL_DOUBLE:
	    args[k].doubleValue = d;
	    break;
	case TCL_INT:
	    if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
		return TCL_ERROR;
	    }
	    valuePtr = Tcl_GetObjResult(interp);
	    Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue));
	    Tcl_ResetResult(interp);
	    break;
	case TCL_WIDE_INT:
	    if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
		return TCL_ERROR;
	    }
	    valuePtr = Tcl_GetObjResult(interp);
	    Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue));
	    Tcl_ResetResult(interp);
	    break;
	}
    }
#endif

    /*
     * Call the function.
     */

    errno = 0;
    result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Return the result of the call.
     */

    if (funcResult.type == TCL_INT) {
	TclNewLongObj(valuePtr, funcResult.intValue);
    } else if (funcResult.type == TCL_WIDE_INT) {
	valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
    } else {
	return CheckDoubleResult(interp, funcResult.doubleValue);
    }
    Tcl_SetObjResult(interp, valuePtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * OldMathFuncDeleteProc --
 *
 *	Cleans up after deleting a math function registered with
 *	Tcl_CreateMathFunc
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees allocated memory.
 *
 *----------------------------------------------------------------------
 */

static void
OldMathFuncDeleteProc(clientData)
     ClientData clientData;
{
    OldMathFuncData* dataPtr = (OldMathFuncData*) clientData;
    Tcl_Free((VOID*) dataPtr->argTypes);
    Tcl_Free((VOID*) dataPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMathFuncInfo --
 *
 *	Discovers how a particular math function was created in a given
 *	interpreter.
 *
 * Results:
 *	TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the
 *	interpreter result if that happens.)
 *
 * Side effects:
 *	If this function succeeds, the variables pointed to by the numArgsPtr
 *	and argTypePtr arguments will be updated to detail the arguments
 *	allowed by the function. The variable pointed to by the procPtr
 *	argument will be set to NULL if the function is a builtin function,
 *	and will be set to the address of the C function used to implement the
 *	math function otherwise (in which case the variable pointed to by the
 *	clientDataPtr argument will also be updated.)
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
	clientDataPtr)
    Tcl_Interp *interp;
    CONST char *name;
    int *numArgsPtr;
    Tcl_ValueType **argTypesPtr;
    Tcl_MathProc **procPtr;
    ClientData *clientDataPtr;
{

    Tcl_Obj* cmdNameObj;
    Command* cmdPtr;

    /*
     * Get the command that implements the math function.
     */

    cmdNameObj = Tcl_NewStringObj("tcl::mathfunc::", -1);
    Tcl_AppendToObj(cmdNameObj, name, -1);
    Tcl_IncrRefCount(cmdNameObj);
    cmdPtr = (Command*) Tcl_GetCommandFromObj(interp, cmdNameObj);
    Tcl_DecrRefCount(cmdNameObj);

    /*
     * Report unknown functions.
     */

    if (cmdPtr == NULL) {
	Tcl_Obj* message;
	message = Tcl_NewStringObj("unknown math function \"", -1);
	Tcl_AppendToObj(message, name, -1);
	Tcl_AppendToObj(message, "\"", 1);
	*numArgsPtr = -1; *argTypesPtr = NULL;
	*procPtr = NULL;
	*clientDataPtr = NULL;
	return TCL_ERROR;
    }




    /*

     * Retrieve function info for user defined functions; return dummy
     * information for builtins.
     */

    if (cmdPtr->objProc == &OldMathFuncProc) {
	OldMathFuncData* dataPtr = (OldMathFuncData*) cmdPtr->clientData;
	*procPtr = dataPtr->proc;

	*numArgsPtr = dataPtr->numArgs;
	*argTypesPtr = dataPtr->argTypes;

	*clientDataPtr = dataPtr->clientData;


    } else {
	*procPtr = NULL;
	*numArgsPtr = -1;
	*argTypesPtr = NULL;
	*procPtr = NULL;
	*clientDataPtr = NULL;
    }

    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListMathFuncs --
 *
 *	Produces a list of all the math functions defined in a given
 *	interpreter.
 *
 * Results:
 *	A pointer to a Tcl_Obj structure with a reference count of zero, or
 *	NULL in the case of an error (in which case a suitable error message
 *	will be left in the interpreter result.)
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ListMathFuncs(interp, pattern)
    Tcl_Interp *interp;
    CONST char *pattern;
{
    Namespace* globalNsPtr = (Namespace*) Tcl_GetGlobalNamespace(interp);
    Namespace* nsPtr;
    Namespace* dummy1NsPtr;
    Namespace* dummy2NsPtr;
    CONST char* dummyNamePtr;
    Tcl_Obj* result = Tcl_NewObj();
    Tcl_HashEntry* cmdHashEntry;
    Tcl_HashSearch cmdHashSearch;
    CONST char* cmdNamePtr;

    TclGetNamespaceForQualName(interp, "::tcl::mathfunc",
	    globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY,
	    &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr);

    if (nsPtr != NULL) {
	if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
	    if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) {
		Tcl_ListObjAppendElement(NULL, result,
			Tcl_NewStringObj(pattern, -1));
	    }
	} else {
	    cmdHashEntry = Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch);
	    for (; cmdHashEntry != NULL;
		    cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) {
		cmdNamePtr = Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry);
		if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) {

		    Tcl_ListObjAppendElement(NULL, result,
			    Tcl_NewStringObj(cmdNamePtr, -1));


		}
	    }
	}
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInterpReady --
 *
 *	Check if an interpreter is ready to eval commands or scripts, i.e., if
 *	it was not deleted and if the nesting level is not too high.

 *
 * Results:
 *	The return value is TCL_OK if it the interpreter is ready, TCL_ERROR
 *	otherwise.
 *
 * Side effects:
 *	The interpreters object and string results are cleared.
 *
 *----------------------------------------------------------------------
 */

int
TclInterpReady(interp)
    Tcl_Interp *interp;
{
    register Interp *iPtr = (Interp *) interp;

    /*
     * Reset both the interpreter's string and object results and clear out
     * any previous error information.
     */

    Tcl_ResetResult(interp);

    /*
     * If the interpreter has been deleted, return an error.
     */

    if (iPtr->flags & DELETED) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp,
		"attempt to call eval in deleted interpreter", (char *) NULL);
	Tcl_SetErrorCode(interp, "CORE", "IDELETE",
		"attempt to call eval in deleted interpreter", (char *) NULL);

	return TCL_ERROR;
    }

    /*
     * Check depth of nested calls to Tcl_Eval: if this gets too large, it's
     * probably because of an infinite loop somewhere.
     */

    if (((iPtr->numLevels) > iPtr->maxNestingDepth)
	    || (TclpCheckStackSpace() == 0)) {
	Tcl_AppendResult(interp,
		"too many nested evaluations (infinite loop?)", (char *) NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclEvalObjvInternal --
 *
 *	This procedure evaluates a Tcl command that has already been parsed
 *	into words, with one Tcl_Obj holding each word. The caller is
 *	responsible for managing the iPtr->numLevels.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR. A result or error message is left in interp's result. If an
 *	error occurs, this procedure does NOT add any information to the
 *	errorInfo variable.
 *
 * Side effects:
 *	Depends on the command.
 *
 *----------------------------------------------------------------------
 */

int
TclEvalObjvInternal(interp, objc, objv, command, length, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */

    int objc;			/* Number of words in command. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to objects that are
				 * the words that make up the command. */
    CONST char *command;	/* Points to the beginning of the string
				 * representation of the command; this is used

				 * for traces. If the string representation of
				 * the command is unknown, an empty string
				 * should be supplied. If it is NULL, no
				 * traces will be called. */
    int length;			/* Number of bytes in command; if -1, all
				 * characters up to the first null byte are
				 * used. */
    int flags;			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
				 * currently supported. */

{
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **newObjv;
    int i;
    CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
				 * TCL_EVAL_GLOBAL was set. */
    int code = TCL_OK;
    int traceCode = TCL_OK;
    int checkTraces = 1;

    if (TclInterpReady(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

    if (objc == 0) {
	return TCL_OK;
    }

    /*






     * Find the procedure to execute this command. If there isn't one, then
     * see if there is a command "unknown". If so, create a new word array
     * with "unknown" as the first word and the original command words as
     * arguments. Then call ourselves recursively to execute it.

     *
     * If caller requests, or if we're resolving the target end of an
     * interpeter alias (TCL_EVAL_INVOKE), be sure to do command name
     * resolution in the global namespace.
     *
     * If any execution traces rename or delete the current command, we may
     * need (at most) two passes here.
     */

  reparseBecauseOfTraces:
    savedVarFramePtr = iPtr->varFramePtr;
    if (flags & (TCL_EVAL_INVOKE | TCL_EVAL_GLOBAL)) {
	iPtr->varFramePtr = NULL;
    }
    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
    iPtr->varFramePtr = savedVarFramePtr;

    if (cmdPtr == NULL) {
	newObjv = (Tcl_Obj **)
		ckalloc((unsigned) ((objc + 1) * sizeof(Tcl_Obj *)));
	for (i = objc-1; i >= 0; i--) {
	    newObjv[i+1] = objv[i];
	}
	newObjv[0] = Tcl_NewStringObj("::unknown", -1);
	Tcl_IncrRefCount(newObjv[0]);
	cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
	if (cmdPtr == NULL) {
	    Tcl_AppendResult(interp, "invalid command name \"",
		    TclGetString(objv[0]), "\"", (char *) NULL);
	    code = TCL_ERROR;
	} else {
	    iPtr->numLevels++;
	    code = TclEvalObjvInternal(interp, objc+1, newObjv,
		    command, length, 0);
	    iPtr->numLevels--;
	}
	Tcl_DecrRefCount(newObjv[0]);
	ckfree((char *) newObjv);
	goto done;
    }

    /*
     * Call trace procedures if needed.
     */

    if ((checkTraces) && (command != NULL)) {
	int cmdEpoch = cmdPtr->cmdEpoch;
	cmdPtr->refCount++;

	/*
	 * If the first set of traces modifies/deletes the command or any
	 * existing traces, then the set checkTraces to 0 and go through this
	 * while loop one more time.
	 */

	if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
	    traceCode = TclCheckInterpTraces(interp, command, length,
		    cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
	}
	if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {

	    traceCode = TclCheckExecutionTraces(interp, command, length,
		    cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
	}
	cmdPtr->refCount--;
	if (cmdEpoch != cmdPtr->cmdEpoch) {
	    /*
	     * The command has been modified in some way.
	     */

	    checkTraces = 0;

	    goto reparseBecauseOfTraces;
	}


    }

    /*
     * Finally, invoke the command's Tcl_ObjCmdProc.
     */

    cmdPtr->refCount++;
    iPtr->cmdCount++;
    if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) {
	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_GLOBAL) {
	    iPtr->varFramePtr = NULL;
	}
	if (!(flags & TCL_EVAL_INVOKE) &&
		(iPtr->ensembleRewrite.sourceObjs != NULL) &&
		!Tcl_IsEnsemble((Tcl_Command) cmdPtr)) {
	    iPtr->ensembleRewrite.sourceObjs = NULL;
	}
	code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
	iPtr->varFramePtr = savedVarFramePtr;
    }
    if (Tcl_AsyncReady()) {
	code = Tcl_AsyncInvoke(interp, code);
    }
    if (code == TCL_OK && Tcl_LimitReady(interp)) {
	code = Tcl_LimitCheck(interp);
    }

    /*
     * Call 'leave' command traces
     */

    if (!(cmdPtr->flags & CMD_IS_DELETED)) {
	if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
	    traceCode = TclCheckExecutionTraces(interp, command, length,
		    cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
	}
	if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
	    traceCode = TclCheckInterpTraces(interp, command, length,
		    cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
	}
    }
    TclCleanupCommand(cmdPtr);

    /*
     * If one of the trace invocation resulted in error, then change the
     * result code accordingly. Note, that the interp->result should already

     * be set correctly by the call to TraceExecutionProc.
     */

    if (traceCode != TCL_OK) {
	code = traceCode;
    }

    /*
     * If the interpreter has a non-empty string result, the result object is
     * either empty or stale because some procedure set interp->result
     * directly. If so, move the string result to the result object, then
     * reset the string result.
     */

    if (*(iPtr->result) != 0) {
	(void) Tcl_GetObjResult(interp);
    }

  done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObjv --
 *
 *	This procedure evaluates a Tcl command that has already been parsed
 *	into words, with one Tcl_Obj holding each word.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR. A result or error message is left in interp's result.

 *
 * Side effects:
 *	Depends on the command.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalObjv(interp, objc, objv, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */

    int objc;			/* Number of words in command. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags;			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
				 * currently supported. */
{
    Interp *iPtr = (Interp *)interp;
    Trace *tracePtr;
    Tcl_DString cmdBuf;
    char *cmdString = "";	/* A command string is only necessary for
				 * command traces or error logs; it will be
				 * generated to replace this default value if
				 * necessary. */
    int cmdLen = 0;		/* a non-zero value indicates that a command
				 * string was generated. */
    int code = TCL_OK;
    int i;
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);

    for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
	if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
	    /*
	     * The command may be needed for an execution trace. Generate a
	     * command string.
	     */

	    Tcl_DStringInit(&cmdBuf);
	    for (i = 0; i < objc; i++) {
		Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
	    }
	    cmdString = Tcl_DStringValue(&cmdBuf);
	    cmdLen = Tcl_DStringLength(&cmdBuf);
	    break;
	}
    }

    iPtr->numLevels++;
    code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
    iPtr->numLevels--;

    /*
     * If we are again at the top level, process any unusual return code
     * returned by the evaluated code.
     */

    if (iPtr->numLevels == 0) {
	if (code == TCL_RETURN) {
	    code = TclUpdateReturnInfo(iPtr);
	}
	if ((code != TCL_OK) && (code != TCL_ERROR) 
	    && !allowExceptions) {
	    ProcessUnexpectedResult(interp, code);
	    code = TCL_ERROR;
	}
    }

    if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {

	/*
	 * If there was an error, a command string will be needed for the
	 * error log: generate it now if it was not done previously.
	 */

	if (cmdLen == 0) {
	    Tcl_DStringInit(&cmdBuf);
	    for (i = 0; i < objc; i++) {
		Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262


3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446

3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495

3496


3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511

3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560

3561
3562
3563
3564

3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584

3585




3586





3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602

3603

3604
3605
3606
3607
3608
3609
3610
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LogCommandInfo --
 *
 *	This procedure is invoked after an error occurs in an interpreter.
 *	It adds information to iPtr->errorInfo field to describe the
 *	command that was being executed when the error occurred.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information about the command is added to errorInfo and the
 *	line number stored internally in the interpreter is set.  
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LogCommandInfo(interp, script, command, length)
    Tcl_Interp *interp;		/* Interpreter in which to log information. */
    CONST char *script;		/* First character in script containing
				 * command (must be <= command). */
    CONST char *command;	/* First character in command that
				 * generated the error. */
    int length;			/* Number of bytes in command (-1 means
				 * use all bytes up to first null byte). */
{
    register CONST char *p;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *message;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this
	 * command; we shouldn't add anything more.
	 */

	return;
    }

    /*
     * Compute the line number where the error occurred.
     */

    iPtr->errorLine = 1;
    for (p = script; p != command; p++) {
	if (*p == '\n') {
	    iPtr->errorLine++;
	}
    }



    if (iPtr->errorInfo == NULL) {
	message = Tcl_NewStringObj("\n    while executing\n\"", -1);
    } else {
	message = Tcl_NewStringObj("\n    invoked from within\n\"", -1);
    }
    Tcl_IncrRefCount(message);
    TclAppendLimitedToObj(message, command, length, 153, NULL);
    Tcl_AppendToObj(message, "\"", -1);
    TclAppendObjToErrorInfo(interp, message);
    Tcl_DecrRefCount(message);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokensStandard --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the
 *	tokens that make up a word or the index for an array variable)
 *	this procedure evaluates the tokens and concatenates their
 *	values to form a single result value.
 * 
 * Results:
 *	The return value is a standard Tcl completion code such as
 *	TCL_OK or TCL_ERROR.  A result or error message is left in
 *	interp's result.
 *
 * Side effects:
 *	Depends on the array of tokens being evaled.
  *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalTokensStandard(interp, tokenPtr, count)
    Tcl_Interp *interp;		/* Interpreter in which to lookup
				 * variables, execute nested commands,
				 * and report errors. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens
				 * to evaluate and concatenate. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokens --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the
 *	tokens that make up a word or the index for an array variable)
 *	this procedure evaluates the tokens and concatenates their
 *	values to form a single result value.
 *
 * Results:
 *	The return value is a pointer to a newly allocated Tcl_Obj
 *	containing the value of the array of tokens.  The reference
 *	count of the returned object has been incremented.  If an error
 *	occurs in evaluating the tokens then a NULL value is returned
 *	and an error message is left in interp's result.
 *
 * Side effects:
 *	A new object is allocated to hold the result.
 *
 *----------------------------------------------------------------------
 *
 * This uses a non-standard return convention; its use is now deprecated.
 * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not 
 * used in the core any longer. It is only kept for backward compatibility.
 */

Tcl_Obj *
Tcl_EvalTokens(interp, tokenPtr, count)
    Tcl_Interp *interp;		/* Interpreter in which to lookup
				 * variables, execute nested commands,
				 * and report errors. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens
				 * to evaluate and concatenate. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    int code;
    Tcl_Obj *resPtr;
    
    code = Tcl_EvalTokensStandard(interp, tokenPtr, count);
    if (code == TCL_OK) {
	resPtr = Tcl_GetObjResult(interp);
	Tcl_IncrRefCount(resPtr);
	Tcl_ResetResult(interp);
	return resPtr;
    } else {
	return NULL;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalEx --
 *
 *	This procedure evaluates a Tcl script without using the compiler
 *	or byte-code interpreter.  It just parses the script, creates
 *	values for each word of each command, then calls EvalObjv
 *	to execute each command.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as
 *	TCL_OK or TCL_ERROR.  A result or error message is left in
 *	interp's result.
 *
 * Side effects:
 *	Depends on the script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalEx(interp, script, numBytes, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * script.  Also used for error reporting. */
    CONST char *script;		/* First character of script to evaluate. */
    int numBytes;		/* Number of bytes in script.  If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL is currently
				 * supported. */
{
    Interp *iPtr = (Interp *) interp;
    CONST char *p, *next;
    Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace;
    int expandStatic[NUM_STATIC_OBJS], *expand;
    Tcl_Token *tokenPtr;
    int i, code, commandLength, bytesLeft, expandRequested;
    CallFrame *savedVarFramePtr;   /* Saves old copy of iPtr->varFramePtr
				    * in case TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
    
    /*
     * The variables below keep track of how much state has been
     * allocated while evaluating the script, so that it can be freed
     * properly if an error occurs.
     */

    int gotParse = 0, objectsUsed = 0;

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);

    savedVarFramePtr = iPtr->varFramePtr;
    if (flags & TCL_EVAL_GLOBAL) {
	iPtr->varFramePtr = NULL;
    }

    /*
     * Each iteration through the following loop parses the next
     * command from the script and then executes it.
     */

    objv = objvSpace = staticObjArray;
    expand = expandStatic;
    p = script;
    bytesLeft = numBytes;
    iPtr->evalFlags = 0;
    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse)
	        != TCL_OK) {
	    code = TCL_ERROR;
	    goto error;
	}
	gotParse = 1; 
	if (parse.numWords > 0) {
	    /*
	     * Generate an array of objects for the words of the command.
	     */

	    int objectsNeeded = 0;
    
	    if (parse.numWords > NUM_STATIC_OBJS) {
		expand = (int *) ckalloc((unsigned)
		    (parse.numWords * sizeof (int)));
		objvSpace = (Tcl_Obj **) ckalloc((unsigned)
		    (parse.numWords * sizeof (Tcl_Obj *)));
	    }
	    expandRequested = 0;
	    objv = objvSpace;
	    for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
		    objectsUsed < parse.numWords;
		    objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
		code = TclSubstTokens(interp, tokenPtr+1, 
		            tokenPtr->numComponents, NULL);
		if (code != TCL_OK) {
		    goto error;
		}
		objv[objectsUsed] = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    int numElements;

		    code = Tcl_ListObjLength(interp,
			    objv[objectsUsed], &numElements);
		    if (code == TCL_ERROR) {
			/* Attempt to expand a non-list */
			Tcl_Obj *msg = 
				Tcl_NewStringObj("\n    (expanding word ", -1);
			Tcl_Obj *wordNum = Tcl_NewIntObj(objectsUsed);
			Tcl_IncrRefCount(wordNum);
			Tcl_IncrRefCount(msg);
			Tcl_AppendObjToObj(msg, wordNum);
			Tcl_DecrRefCount(wordNum);
			Tcl_AppendToObj(msg, ")", -1);
			TclAppendObjToErrorInfo(interp, msg);
			Tcl_DecrRefCount(msg);
			Tcl_DecrRefCount(objv[objectsUsed]);
			goto error;
		    }
		    expandRequested = 1;
		    expand[objectsUsed] = 1;
		    objectsNeeded += (numElements ? numElements : 1);
		} else {
		    expand[objectsUsed] = 0;
		    objectsNeeded++;
		}
	    }
	    if (expandRequested) {

		/* Some word expansion was requested.  Check for objv resize */


		Tcl_Obj **copy = objvSpace;
		int wordIdx = parse.numWords;
		int objIdx = objectsNeeded - 1;

		if ((parse.numWords > NUM_STATIC_OBJS)
			|| (objectsNeeded > NUM_STATIC_OBJS)) {
		    objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned)
			    (objectsNeeded * sizeof (Tcl_Obj *)));
		}

		objectsUsed = 0;
		while (wordIdx--) {
		    if (expand[wordIdx]) {
			int numElements;
			Tcl_Obj **elements, *temp = copy[wordIdx];

			Tcl_ListObjGetElements(NULL, temp,
				&numElements, &elements);
			objectsUsed += numElements;
			while (numElements--) {
			    objv[objIdx--] = elements[numElements];
			    Tcl_IncrRefCount(elements[numElements]);
			}
			Tcl_DecrRefCount(temp);
		    } else {
			objv[objIdx--] = copy[wordIdx];
			objectsUsed++;
		    }
		}
		objv += objIdx+1;

		if (copy != staticObjArray) {
		    ckfree((char *) copy);
		}
	    }
    
	    /*
	     * Execute the command and free the objects for its words.
	     */

	    iPtr->numLevels++;    
	    code = TclEvalObjvInternal(interp, objectsUsed, objv, 
	            parse.commandStart, parse.commandSize, 0);
	    iPtr->numLevels--;
	    if (code != TCL_OK) {
		if (iPtr->numLevels == 0) {
		    if (code == TCL_RETURN) {
			code = TclUpdateReturnInfo(iPtr);
		    }
		    if ((code != TCL_OK) && (code != TCL_ERROR) 
			&& !allowExceptions) {
			ProcessUnexpectedResult(interp, code);
			code = TCL_ERROR;
		    }
		}
		goto error;
	    }
	    for (i = 0; i < objectsUsed; i++) {
		Tcl_DecrRefCount(objv[i]);
	    }
	    objectsUsed = 0;
	    if (objvSpace != staticObjArray) {
		ckfree((char *) objvSpace);
		objvSpace = staticObjArray;
	    }

	    /* 
	     * Free expand separately since objvSpace could have been
	     * reallocated above. 
	     */

	    if (expand != expandStatic) {
		ckfree((char *) expand);
		expand = expandStatic;
	    }
	}

	/*
	 * Advance to the next command in the script.
	 */

	next = parse.commandStart + parse.commandSize;
	bytesLeft -= next - p;
	p = next;
	Tcl_FreeParse(&parse);
	gotParse = 0;
    } while (bytesLeft > 0);
    iPtr->varFramePtr = savedVarFramePtr;
    return TCL_OK;

    error:

    /* Generate and log various pieces of error information. */










    if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { 
	commandLength = parse.commandSize;
	if (parse.term == parse.commandStart + commandLength - 1) {
	    /*
	     * The terminator character (such as ; or ]) of the command where
	     * the error occurred is the last character in the parsed command.
	     * Reduce the length by one so that the error message doesn't
	     * include the terminator character.
	     */
	    
	    commandLength -= 1;
	}
	Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
    }
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
    

    /* Then free resources that had been allocated to the command. */


    for (i = 0; i < objectsUsed; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    if (gotParse) {
	Tcl_FreeParse(&parse);
    }







|
|
|





|
|









|
|
|
|



|



|
|
















>
>
|
<
<
|
<
<
|
<
<
<







|
|
|
|
|

|
|
<









|
|
|
|
|












|
|
|
|


|
|
|
|
|






|
|
|




|
|
|
|
|





|

















|
|
|
|


|
|
<










|

|


|
|
|
<









|
|

|

|
|
|















|
|








|
<



|




>

|

|
|
|
|






|
|











|
|
|
<
<
<
<
<
<
<
<












>
|
>
>







|







>



















|




|
|
|


<
<
<
<
<
<
<
<
<
<










>
|

|

>



















|
>
|
>
>
>
>
|
>
>
>
>
>
|








|





|
>
|
>







3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589


3590


3591



3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606

3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692

3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710

3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753

3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791








3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852










3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LogCommandInfo --
 *
 *	This procedure is invoked after an error occurs in an interpreter. It
 *	adds information to iPtr->errorInfo field to describe the command that
 *	was being executed when the error occurred.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information about the command is added to errorInfo and the line
 *	number stored internally in the interpreter is set.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LogCommandInfo(interp, script, command, length)
    Tcl_Interp *interp;		/* Interpreter in which to log information. */
    CONST char *script;		/* First character in script containing
				 * command (must be <= command). */
    CONST char *command;	/* First character in command that generated
				 * the error. */
    int length;			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    register CONST char *p;
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 150;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this command;
	 * we shouldn't add anything more.
	 */

	return;
    }

    /*
     * Compute the line number where the error occurred.
     */

    iPtr->errorLine = 1;
    for (p = script; p != command; p++) {
	if (*p == '\n') {
	    iPtr->errorLine++;
	}
    }

    overflow = (length > limit);
    TclFormatToErrorInfo(interp, "\n    %s\n\"%.*s%s\"",
	    ((iPtr->errorInfo == NULL)


	    ? "while executing" : "invoked from within"),


	    (overflow ? limit : length), command, (overflow ? "..." : ""));



}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokensStandard --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
 *	that make up a word or the index for an array variable) this procedure
 *	evaluates the tokens and concatenates their values to form a single
 *	result value.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR. A result or error message is left in interp's result.

 *
 * Side effects:
 *	Depends on the array of tokens being evaled.
  *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalTokensStandard(interp, tokenPtr, count)
    Tcl_Interp *interp;		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalTokens --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
 *	that make up a word or the index for an array variable) this procedure
 *	evaluates the tokens and concatenates their values to form a single
 *	result value.
 *
 * Results:
 *	The return value is a pointer to a newly allocated Tcl_Obj containing
 *	the value of the array of tokens. The reference count of the returned
 *	object has been incremented. If an error occurs in evaluating the
 *	tokens then a NULL value is returned and an error message is left in
 *	interp's result.
 *
 * Side effects:
 *	A new object is allocated to hold the result.
 *
 *----------------------------------------------------------------------
 *
 * This uses a non-standard return convention; its use is now deprecated. It
 * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used
 * in the core any longer. It is only kept for backward compatibility.
 */

Tcl_Obj *
Tcl_EvalTokens(interp, tokenPtr, count)
    Tcl_Interp *interp;		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    int code;
    Tcl_Obj *resPtr;

    code = Tcl_EvalTokensStandard(interp, tokenPtr, count);
    if (code == TCL_OK) {
	resPtr = Tcl_GetObjResult(interp);
	Tcl_IncrRefCount(resPtr);
	Tcl_ResetResult(interp);
	return resPtr;
    } else {
	return NULL;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalEx --
 *
 *	This procedure evaluates a Tcl script without using the compiler or
 *	byte-code interpreter. It just parses the script, creates values for
 *	each word of each command, then calls EvalObjv to execute each
 *	command.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR. A result or error message is left in interp's result.

 *
 * Side effects:
 *	Depends on the script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalEx(interp, script, numBytes, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * script. Also used for error reporting. */
    CONST char *script;		/* First character of script to evaluate. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int flags;			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */

{
    Interp *iPtr = (Interp *) interp;
    CONST char *p, *next;
    Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace;
    int expandStatic[NUM_STATIC_OBJS], *expand;
    Tcl_Token *tokenPtr;
    int i, code, commandLength, bytesLeft, expandRequested;
    CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
				 * TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);

    /*
     * The variables below keep track of how much state has been allocated
     * while evaluating the script, so that it can be freed properly if an
     * error occurs.
     */

    int gotParse = 0, objectsUsed = 0;

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);

    savedVarFramePtr = iPtr->varFramePtr;
    if (flags & TCL_EVAL_GLOBAL) {
	iPtr->varFramePtr = NULL;
    }

    /*
     * Each iteration through the following loop parses the next command from
     * the script and then executes it.
     */

    objv = objvSpace = staticObjArray;
    expand = expandStatic;
    p = script;
    bytesLeft = numBytes;
    iPtr->evalFlags = 0;
    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) {

	    code = TCL_ERROR;
	    goto error;
	}
	gotParse = 1;
	if (parse.numWords > 0) {
	    /*
	     * Generate an array of objects for the words of the command.
	     */

	    int objectsNeeded = 0;

	    if (parse.numWords > NUM_STATIC_OBJS) {
		expand = (int *)
			ckalloc((unsigned) (parse.numWords * sizeof(int)));
		objvSpace = (Tcl_Obj **)
			ckalloc((unsigned) (parse.numWords*sizeof(Tcl_Obj *)));
	    }
	    expandRequested = 0;
	    objv = objvSpace;
	    for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
		    objectsUsed < parse.numWords;
		    objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
		code = TclSubstTokens(interp, tokenPtr+1,
			tokenPtr->numComponents, NULL);
		if (code != TCL_OK) {
		    goto error;
		}
		objv[objectsUsed] = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    int numElements;

		    code = Tcl_ListObjLength(interp,
			    objv[objectsUsed], &numElements);
		    if (code == TCL_ERROR) {
			/* Attempt to expand a non-list. */
			TclFormatToErrorInfo(interp,
				"\n    (expanding word %d)", objectsUsed);








			Tcl_DecrRefCount(objv[objectsUsed]);
			goto error;
		    }
		    expandRequested = 1;
		    expand[objectsUsed] = 1;
		    objectsNeeded += (numElements ? numElements : 1);
		} else {
		    expand[objectsUsed] = 0;
		    objectsNeeded++;
		}
	    }
	    if (expandRequested) {
		/*
		 * Some word expansion was requested. Check for objv resize.
		 */

		Tcl_Obj **copy = objvSpace;
		int wordIdx = parse.numWords;
		int objIdx = objectsNeeded - 1;

		if ((parse.numWords > NUM_STATIC_OBJS)
			|| (objectsNeeded > NUM_STATIC_OBJS)) {
		    objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned)
			    (objectsNeeded * sizeof(Tcl_Obj *)));
		}

		objectsUsed = 0;
		while (wordIdx--) {
		    if (expand[wordIdx]) {
			int numElements;
			Tcl_Obj **elements, *temp = copy[wordIdx];

			Tcl_ListObjGetElements(NULL, temp,
				&numElements, &elements);
			objectsUsed += numElements;
			while (numElements--) {
			    objv[objIdx--] = elements[numElements];
			    Tcl_IncrRefCount(elements[numElements]);
			}
			Tcl_DecrRefCount(temp);
		    } else {
			objv[objIdx--] = copy[wordIdx];
			objectsUsed++;
		    }
		}
		objv += objIdx+1;

		if (copy != staticObjArray) {
		    ckfree((char *) copy);
		}
	    }

	    /*
	     * Execute the command and free the objects for its words.
	     */

	    iPtr->numLevels++;
	    code = TclEvalObjvInternal(interp, objectsUsed, objv,
		    parse.commandStart, parse.commandSize, 0);
	    iPtr->numLevels--;
	    if (code != TCL_OK) {










		goto error;
	    }
	    for (i = 0; i < objectsUsed; i++) {
		Tcl_DecrRefCount(objv[i]);
	    }
	    objectsUsed = 0;
	    if (objvSpace != staticObjArray) {
		ckfree((char *) objvSpace);
		objvSpace = staticObjArray;
	    }

	    /*
	     * Free expand separately since objvSpace could have been
	     * reallocated above.
	     */

	    if (expand != expandStatic) {
		ckfree((char *) expand);
		expand = expandStatic;
	    }
	}

	/*
	 * Advance to the next command in the script.
	 */

	next = parse.commandStart + parse.commandSize;
	bytesLeft -= next - p;
	p = next;
	Tcl_FreeParse(&parse);
	gotParse = 0;
    } while (bytesLeft > 0);
    iPtr->varFramePtr = savedVarFramePtr;
    return TCL_OK;

  error:
    /*
     * Generate and log various pieces of error information.
     */
    if (iPtr->numLevels == 0) {
	if (code == TCL_RETURN) {
	    code = TclUpdateReturnInfo(iPtr);
	}
	if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) {
	    ProcessUnexpectedResult(interp, code);
	    code = TCL_ERROR;
	}
    }
    if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	commandLength = parse.commandSize;
	if (parse.term == parse.commandStart + commandLength - 1) {
	    /*
	     * The terminator character (such as ; or ]) of the command where
	     * the error occurred is the last character in the parsed command.
	     * Reduce the length by one so that the error message doesn't
	     * include the terminator character.
	     */

	    commandLength -= 1;
	}
	Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
    }
    iPtr->flags &= ~ERR_ALREADY_LOGGED;

    /*
     * Then free resources that had been allocated to the command.
     */

    for (i = 0; i < objectsUsed; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    if (gotParse) {
	Tcl_FreeParse(&parse);
    }
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Eval --
 *
 *	Execute a Tcl command in a string.  This procedure executes the
 *	script directly, rather than compiling it to bytecodes.  Before
 *	the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
 *	the main procedure used for executing Tcl commands, but nowadays
 *	it isn't used much.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h
 *	(such as TCL_OK), and interp's result contains a value
 *	to supplement the return code. The value of the result
 *	will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
 *	you must copy it or lose it!
 *
 * Side effects:
 *	Can be almost arbitrary, depending on the commands in the script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Eval(interp, string)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by previous call to Tcl_CreateInterp). */
    CONST char *string;		/* Pointer to TCL command to execute. */
{
    int code = Tcl_EvalEx(interp, string, -1, 0);

    /*
     * For backwards compatibility with old C code that predates the
     * object system in Tcl 8.0, we have to mirror the object result
     * back into the string result (some callers may expect it there).
     */

    (void) Tcl_GetStringResult(interp);
    return code;
}

/*







|
|
|
|
<


|
|
<
|
|








|
|
|
|

|


|
|
|







3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945

3946
3947
3948
3949

3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Eval --
 *
 *	Execute a Tcl command in a string. This procedure executes the script
 *	directly, rather than compiling it to bytecodes. Before the arrival of
 *	the bytecode compiler in Tcl 8.0 Tcl_Eval was the main procedure used
 *	for executing Tcl commands, but nowadays it isn't used much.

 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h (such as
 *	TCL_OK), and interp's result contains a value to supplement the return

 *	code. The value of the result will persist only until the next call to
 *	Tcl_Eval or Tcl_EvalObj: you must copy it or lose it!
 *
 * Side effects:
 *	Can be almost arbitrary, depending on the commands in the script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Eval(interp, script)
    Tcl_Interp *interp;		/* Token for command interpreter (returned by
				 * previous call to Tcl_CreateInterp). */
    CONST char *script;		/* Pointer to TCL command to execute. */
{
    int code = Tcl_EvalEx(interp, script, -1, 0);

    /*
     * For backwards compatibility with old C code that predates the object
     * system in Tcl 8.0, we have to mirror the object result back into the
     * string result (some callers may expect it there).
     */

    (void) Tcl_GetStringResult(interp);
    return code;
}

/*
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754





3755

3756
3757
3758

3759












3760
3761
3762
















3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798

3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877


3878
3879
3880

3881
3882
3883
3884
3885
3886

3887

3888
3889
3890
3891

3892




3893
3894
3895



3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908

3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009




4010











4011

4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044


4045
4046
4047


4048



4049




4050



4051


4052


4053

4054


4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071

4072
4073





4074
4075
4076
4077
4078
4079

4080




4081

4082

4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149

4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObjEx --
 *
 *	Execute Tcl commands stored in a Tcl object. These commands are
 *	compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
 *	is specified.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h
 *	(such as TCL_OK), and the interpreter's result contains a value
 *	to supplement the return code.
 *
 * Side effects:
 *	The object is converted, if necessary, to a ByteCode object that
 *	holds the bytecode instructions for the commands. Executing the
 *	commands will almost certainly have side effects that depend
 *	on those commands.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalObjEx(interp, objPtr, flags)
    Tcl_Interp *interp;			/* Token for command interpreter
					 * (returned by a previous call to
					 * Tcl_CreateInterp). */
    register Tcl_Obj *objPtr;		/* Pointer to object containing
					 * commands to execute. */
    int flags;				/* Collection of OR-ed bits that
					 * control the evaluation of the
					 * script.  Supported values are
					 * TCL_EVAL_GLOBAL and
					 * TCL_EVAL_DIRECT. */
{
    register Interp *iPtr = (Interp *) interp;
    char *script;
    int numSrcBytes;
    int result;
    CallFrame *savedVarFramePtr;	/* Saves old copy of iPtr->varFramePtr
					 * in case TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);

    Tcl_IncrRefCount(objPtr);

    if (flags & TCL_EVAL_DIRECT) {
	/*
	 * We're not supposed to use the compiler or byte-code interpreter.
	 * Let Tcl_EvalEx evaluate the command directly (and probably
	 * more slowly).
	 *
	 * Pure List Optimization (no string representation).  In this
	 * case, we can safely use Tcl_EvalObjv instead and get an
	 * appreciable improvement in execution speed.  This is because it
	 * allows us to avoid a setFromAny step that would just pack
	 * everything into a string and back out again.





	 */

	if ((objPtr->typePtr == &tclListType) && /* is a list... */
		(objPtr->bytes == NULL) /* ...without a string rep */) {
	    register List *listRepPtr =

		(List *) objPtr->internalRep.twoPtrValue.ptr1;












	    result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
		    listRepPtr->elements, flags);
	} else {
















	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
	    result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
	}
    } else {
	/*
	 * Let the compiler/engine subsystem do the evaluation.
	 */

	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_GLOBAL) {
	    iPtr->varFramePtr = NULL;
	}

	result = TclCompEvalObj(interp, objPtr);

	/*
	 * If we are again at the top level, process any unusual 
	 * return code returned by the evaluated code. 
	 */
	
	if (iPtr->numLevels == 0) {
	    if (result == TCL_RETURN) {
		result = TclUpdateReturnInfo(iPtr);
	    }
	    if ((result != TCL_OK) && (result != TCL_ERROR) 
	        && !allowExceptions) {
		ProcessUnexpectedResult(interp, result);
		result = TCL_ERROR;
		script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
		Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
	    }
	}
	iPtr->evalFlags = 0;
	iPtr->varFramePtr = savedVarFramePtr; 
    }


    TclDecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcessUnexpectedResult --
 *
 *	Procedure called by Tcl_EvalObj to set the interpreter's result
 *	value to an appropriate error message when the code it evaluates
 *	returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
 *	the topmost evaluation level.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter result is set to an error message appropriate to
 *	the result code.
 *
 *----------------------------------------------------------------------
 */

static void
ProcessUnexpectedResult(interp, returnCode)
    Tcl_Interp *interp;		/* The interpreter in which the unexpected
				 * result code was returned. */
    int returnCode;		/* The unexpected result code. */
{
    Tcl_ResetResult(interp);
    if (returnCode == TCL_BREAK) {
	Tcl_AppendResult(interp,
		"invoked \"break\" outside of a loop", (char *) NULL);
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_AppendResult(interp,
		"invoked \"continue\" outside of a loop", (char *) NULL);
    } else {
        char buf[30 + TCL_INTEGER_SPACE];

	sprintf(buf, "command returned bad code: %d", returnCode);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
 *
 *	Procedures to evaluate an expression and return its value in a
 *	particular form.
 *
 * Results:
 *	Each of the procedures below returns a standard Tcl result. If an
 *	error occurs then an error message is left in the interp's result.
 *	Otherwise the value of the expression, in the appropriate form,
 *	is stored at *ptr. If the expression had a result that was
 *	incompatible with the desired form then an error is returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_ExprLong(interp, string, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *string;		/* Expression to evaluate. */
    long *ptr;			/* Where to store result. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    int result = TCL_OK;

    if (length > 0) {


	exprPtr = Tcl_NewStringObj(string, length);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);

	if (result == TCL_OK) {
	    /*
	     * Store an integer based on the expression result.
	     */
	    
	    if (resultPtr->typePtr == &tclIntType) {

		*ptr = resultPtr->internalRep.longValue;

	    } else if (resultPtr->typePtr == &tclDoubleType) {
		*ptr = (long) resultPtr->internalRep.doubleValue;
	    } else {
		Tcl_SetResult(interp,

		        "expression didn't have numeric value", TCL_STATIC);




		result = TCL_ERROR;
	    }
	    Tcl_DecrRefCount(resultPtr);  /* discard the result object */



	} else {
	    /*
	     * Move the interpreter's object result to the string result, 
	     * then reset the object result.
	     */

	    (void) Tcl_GetStringResult(interp);
	}
	Tcl_DecrRefCount(exprPtr);  /* discard the expression object */	
    } else {
	/*
	 * An empty string. Just set the result integer to 0.
	 */

	
	*ptr = 0;
    }
    return result;
}

int
Tcl_ExprDouble(interp, string, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *string;		/* Expression to evaluate. */
    double *ptr;		/* Where to store result. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    int result = TCL_OK;

    if (length > 0) {
	exprPtr = Tcl_NewStringObj(string, length);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
	if (result == TCL_OK) {
	    /*
	     * Store a double  based on the expression result.
	     */
	    
	    if (resultPtr->typePtr == &tclIntType) {
		*ptr = (double) resultPtr->internalRep.longValue;
	    } else if (resultPtr->typePtr == &tclDoubleType) {
		*ptr = resultPtr->internalRep.doubleValue;
	    } else {
		Tcl_SetResult(interp,
		        "expression didn't have numeric value", TCL_STATIC);
		result = TCL_ERROR;
	    }
	    Tcl_DecrRefCount(resultPtr);  /* discard the result object */
	} else {
	    /*
	     * Move the interpreter's object result to the string result, 
	     * then reset the object result.
	     */

	    (void) Tcl_GetStringResult(interp);
	}
	Tcl_DecrRefCount(exprPtr);  /* discard the expression object */
    } else {
	/*
	 * An empty string. Just set the result double to 0.0.
	 */
	
	*ptr = 0.0;
    }
    return result;
}

int
Tcl_ExprBoolean(interp, string, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
			         * expression. */
    CONST char *string;		/* Expression to evaluate. */
    int *ptr;			/* Where to store 0/1 result. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    int result = TCL_OK;

    if (length > 0) {
	exprPtr = Tcl_NewStringObj(string, length);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
	if (result == TCL_OK) {
	    /*
	     * Store a boolean based on the expression result.
	     */
	    
	    if (resultPtr->typePtr == &tclIntType) {
		*ptr = (resultPtr->internalRep.longValue != 0);
	    } else if (resultPtr->typePtr == &tclDoubleType) {
		*ptr = (resultPtr->internalRep.doubleValue != 0.0);
	    } else {
		result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
	    }
	    Tcl_DecrRefCount(resultPtr);  /* discard the result object */
	}
	if (result != TCL_OK) {
	    /*
	     * Move the interpreter's object result to the string result, 
	     * then reset the object result.
	     */

	    (void) Tcl_GetStringResult(interp);
	}
	Tcl_DecrRefCount(exprPtr); /* discard the expression object */
    } else {
	/*
	 * An empty string. Just set the result boolean to 0 (false).
	 */
	
	*ptr = 0;




    }











    return result;

}

/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
 *
 *	Procedures to evaluate an expression in an object and return its
 *	value in a particular form.
 *
 * Results:
 *	Each of the procedures below returns a standard Tcl result
 *	object. If an error occurs then an error message is left in the
 *	interpreter's result. Otherwise the value of the expression, in the
 *	appropriate form, is stored at *ptr. If the expression had a result
 *	that was incompatible with the desired form then an error is
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

int
Tcl_ExprLongObj(interp, objPtr, ptr)
    Tcl_Interp *interp;			/* Context in which to evaluate the
					 * expression. */
    register Tcl_Obj *objPtr;		/* Expression to evaluate. */
    long *ptr;				/* Where to store long result. */
{
    Tcl_Obj *resultPtr;
    int result;



    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {


	if (resultPtr->typePtr == &tclIntType) {



	    *ptr = resultPtr->internalRep.longValue;




	} else if (resultPtr->typePtr == &tclDoubleType) {



	    *ptr = (long) resultPtr->internalRep.doubleValue;


	} else {


	    result = Tcl_GetLongFromObj(interp, resultPtr, ptr);

	    if (result != TCL_OK) {


		return result;
	    }
	}
	Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}

int
Tcl_ExprDoubleObj(interp, objPtr, ptr)
    Tcl_Interp *interp;			/* Context in which to evaluate the
					 * expression. */
    register Tcl_Obj *objPtr;		/* Expression to evaluate. */
    double *ptr;			/* Where to store double result. */
{
    Tcl_Obj *resultPtr;
    int result;


    result = Tcl_ExprObj(interp, objPtr, &resultPtr);





    if (result == TCL_OK) {
	if (resultPtr->typePtr == &tclIntType) {
	    *ptr = (double) resultPtr->internalRep.longValue;
	} else if (resultPtr->typePtr == &tclDoubleType) {
	    *ptr = resultPtr->internalRep.doubleValue;
	} else {

	    result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);




	    if (result != TCL_OK) {

		return result;

	    }
	}
	Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}

int
Tcl_ExprBooleanObj(interp, objPtr, ptr)
    Tcl_Interp *interp;			/* Context in which to evaluate the
					 * expression. */
    register Tcl_Obj *objPtr;		/* Expression to evaluate. */
    int *ptr;				/* Where to store 0/1 result. */
{
    Tcl_Obj *resultPtr;
    int result;

    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {
	if (resultPtr->typePtr == &tclIntType) {
	    *ptr = (resultPtr->internalRep.longValue != 0);
	} else if (resultPtr->typePtr == &tclDoubleType) {
	    *ptr = (resultPtr->internalRep.doubleValue != 0.0);
	} else {
	    result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
	}
	Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInvokeNamespace --
 *
 *	Object version: Invokes a Tcl command, given an objv/objc, from
 *	either the exposed or hidden set of commands in the given
 *	interpreter.
 *	NOTE: The command is invoked in the global stack frame of the
 *	interpreter or namespace, thus it cannot see any current state on
 *	the stack of that interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Whatever the command does.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInvokeNamespace(interp, objc, objv, nsPtr, flags)
    Tcl_Interp *interp;		/* Interpreter in which command is to be
				 * invoked. */
    int objc;			/* Count of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects; objv[0] points to the
				 * name of the command to invoke. */
    Tcl_Namespace *nsPtr;	/* The namespace to use. */
    int flags;			/* Combination of flags controlling the
				 * call: TCL_INVOKE_HIDDEN,
				 * TCL_INVOKE_NO_UNKNOWN, or
				 * TCL_INVOKE_NO_TRACEBACK. */
{
    Tcl_CallFrame frame;
    int result;


    /*
     * Make the specified namespace the current namespace and invoke
     * the command.
     */

    result = Tcl_PushCallFrame(interp, &frame, nsPtr, /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
        return TCL_ERROR;
    }

    result = TclObjInvoke(interp, objc, objv, flags);

    Tcl_PopCallFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInvoke --
 *
 *	Invokes a Tcl command, given an objv/objc, from either the
 *	exposed or the hidden sets of commands in the given interpreter.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	Whatever the command does.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInvoke(interp, objc, objv, flags)
    Tcl_Interp *interp;		/* Interpreter in which command is to be
				 * invoked. */
    int objc;			/* Count of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects; objv[0] points to the
				 * name of the command to invoke. */
    int flags;			/* Combination of flags controlling the
				 * call: TCL_INVOKE_HIDDEN,
				 * TCL_INVOKE_NO_UNKNOWN, or
				 * TCL_INVOKE_NO_TRACEBACK. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTblPtr;	/* Table of hidden commands. */
    char *cmdName;		/* Name of the command from objv[0]. */
    Tcl_HashEntry *hPtr = NULL;
    Command *cmdPtr;
    int result;

    if (interp == (Tcl_Interp *) NULL) {
        return TCL_ERROR;
    }

    if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
        Tcl_AppendResult(interp, "illegal argument vector", (char *) NULL);
        return TCL_ERROR;
    }

    if ((flags & TCL_INVOKE_HIDDEN) == 0) {
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }

    if (TclInterpReady(interp) == TCL_ERROR) {







|
|


|
|
|


|
|
|
<






|
<
|
|
|
|
|
<
|
<





|
|







|
|

|
|
|
|
|
>
>
>
>
>

>
|
<
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<













|
|

|




|
|







|


>









|
|
|
|





|
|


















<
|
|
|














|
|
|








|


|



<
<

|
|
>
>
|

|
>
|
<
|
<
|
<
>
|
>
|
|
<
|
>
|
>
>
>
>
|
|
<
>
>
>
|
<
|
<
<
|
|
<
|
<
<
|
<
>
|
<





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

|
|


<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



|

>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>







|
|


|
|
|
|
|
<









|
|
|
|


|
>
>


|
>
>
|
>
>
>
|
>
>
>
>
|
>
>
>
|
>
>
|
>
>
|
>
|
>
>
|
|
|
|
<





|
|
|
|


|
>


>
>
>
>
>

|
<
<
<
|
>
|
>
>
>
>
|
>
|
>
|
|
|
<





|
|
|
|






<
<
<
<
<
|
<










|
|
<

|
|


















|
|
<
|

<

>


|
|


|

|




|








|
|

















|
|
<
|









|



|
|







4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029

4030
4031
4032
4033
4034
4035
4036

4037
4038
4039
4040
4041

4042

4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072

4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108

4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180

4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215


4216
4217
4218
4219
4220
4221
4222
4223
4224
4225

4226

4227

4228
4229
4230
4231
4232

4233
4234
4235
4236
4237
4238
4239
4240
4241

4242
4243
4244
4245

4246


4247
4248

4249


4250

4251
4252

4253
4254
4255
4256
4257


















































4258
4259
4260
4261
4262
4263




4264




























4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303

4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354

4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376



4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390

4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405





4406

4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418

4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441

4442
4443

4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488

4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObjEx --
 *
 *	Execute Tcl commands stored in a Tcl object. These commands are
 *	compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is
 *	specified.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h (such as
 *	TCL_OK), and the interpreter's result contains a value to supplement
 *	the return code.
 *
 * Side effects:
 *	The object is converted, if necessary, to a ByteCode object that holds
 *	the bytecode instructions for the commands. Executing the commands
 *	will almost certainly have side effects that depend on those commands.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_EvalObjEx(interp, objPtr, flags)
    Tcl_Interp *interp;		/* Token for command interpreter (returned by

				 * a previous call to Tcl_CreateInterp). */
    register Tcl_Obj *objPtr;	/* Pointer to object containing commands to
				 * execute. */
    int flags;			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Supported values

				 * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */

{
    register Interp *iPtr = (Interp *) interp;
    char *script;
    int numSrcBytes;
    int result;
    CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
				 * TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);

    Tcl_IncrRefCount(objPtr);

    if (flags & TCL_EVAL_DIRECT) {
	/*
	 * We're not supposed to use the compiler or byte-code interpreter.
	 * Let Tcl_EvalEx evaluate the command directly (and probably more
	 * slowly).
	 *
	 * Pure List Optimization (no string representation). In this case, we
	 * can safely use Tcl_EvalObjv instead and get an appreciable
	 * improvement in execution speed. This is because it allows us to
	 * avoid a setFromAny step that would just pack everything into a
	 * string and back out again.
	 *
	 * This restriction has been relaxed a bit by storing in lists whether
	 * they are "canonical" or not (a canonical list being one that is
	 * either pure or that has its string rep derived by
	 * UpdateStringOfList from the internal rep).
	 */

	if (objPtr->typePtr == &tclListType) {	/* is a list... */

	    List *listRepPtr;

	    listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1;

	    if (objPtr->bytes == NULL ||	/* ...without a string rep */
		    listRepPtr->canonicalFlag) {/* ...or that is canonical */

		/*
		 * Increase the reference count of the List structure, to
		 * avoid a segfault if objPtr loses its List internal rep [Bug
		 * 1119369]
		 */

		listRepPtr->refCount++;

		result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
			&listRepPtr->elements, flags);

		/*
		 * If we are the last users of listRepPtr, free it.
		 */

		if (--listRepPtr->refCount <= 0) {
		    int i, elemCount = listRepPtr->elemCount;
		    Tcl_Obj **elements = &listRepPtr->elements;

		    for (i=0; i<elemCount; i++) {
			Tcl_DecrRefCount(elements[i]);
		    }
		    ckfree((char *) listRepPtr);
		}
		goto done;
	    }
	}
	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
	result = Tcl_EvalEx(interp, script, numSrcBytes, flags);

    } else {
	/*
	 * Let the compiler/engine subsystem do the evaluation.
	 */

	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_GLOBAL) {
	    iPtr->varFramePtr = NULL;
	}

	result = TclCompEvalObj(interp, objPtr);

	/*
	 * If we are again at the top level, process any unusual return code
	 * returned by the evaluated code.
	 */

	if (iPtr->numLevels == 0) {
	    if (result == TCL_RETURN) {
		result = TclUpdateReturnInfo(iPtr);
	    }
	    if ((result != TCL_OK) && (result != TCL_ERROR)
		    && !allowExceptions) {
		ProcessUnexpectedResult(interp, result);
		result = TCL_ERROR;
		script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
		Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
	    }
	}
	iPtr->evalFlags = 0;
	iPtr->varFramePtr = savedVarFramePtr;
    }

  done:
    TclDecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcessUnexpectedResult --
 *
 *	Procedure called by Tcl_EvalObj to set the interpreter's result value
 *	to an appropriate error message when the code it evaluates returns an
 *	unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost
 *	evaluation level.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter result is set to an error message appropriate to the
 *	result code.
 *
 *----------------------------------------------------------------------
 */

static void
ProcessUnexpectedResult(interp, returnCode)
    Tcl_Interp *interp;		/* The interpreter in which the unexpected
				 * result code was returned. */
    int returnCode;		/* The unexpected result code. */
{
    Tcl_ResetResult(interp);
    if (returnCode == TCL_BREAK) {
	Tcl_AppendResult(interp,
		"invoked \"break\" outside of a loop", (char *) NULL);
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_AppendResult(interp,
		"invoked \"continue\" outside of a loop", (char *) NULL);
    } else {

	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "command returned bad code: %d", returnCode);
	Tcl_SetObjResult(interp, objPtr);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
 *
 *	Procedures to evaluate an expression and return its value in a
 *	particular form.
 *
 * Results:
 *	Each of the procedures below returns a standard Tcl result. If an
 *	error occurs then an error message is left in the interp's result.
 *	Otherwise the value of the expression, in the appropriate form, is
 *	stored at *ptr. If the expression had a result that was incompatible
 *	with the desired form then an error is returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_ExprLong(interp, exprstring, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *exprstring;	/* Expression to evaluate. */
    long *ptr;			/* Where to store result. */
{
    register Tcl_Obj *exprPtr;


    int result = TCL_OK;
    if (*exprstring == '\0') {
	/* Legacy compatibility - return 0 for the zero-length string. */
	*ptr = 0;
    } else {
	exprPtr = Tcl_NewStringObj(exprstring, -1);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprLongObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
	if (result != TCL_OK) {

	    (void) Tcl_GetStringResult(interp);

	}

    }
    return result;
}

int

Tcl_ExprDouble(interp, exprstring, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *exprstring;	/* Expression to evaluate. */
    double *ptr;		/* Where to store result. */
{
    register Tcl_Obj *exprPtr;
    int result = TCL_OK;


    if (*exprstring == '\0') {
	/* Legacy compatibility - return 0 for the zero-length string. */
	*ptr = 0.0;
    } else {

	exprPtr = Tcl_NewStringObj(exprstring, -1);


	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);

	Tcl_DecrRefCount(exprPtr);  /* discard the expression object */


	if (result != TCL_OK) {

	    (void) Tcl_GetStringResult(interp);
	}

    }
    return result;
}

int


















































Tcl_ExprBoolean(interp, exprstring, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *exprstring;	/* Expression to evaluate. */
    int *ptr;			/* Where to store 0/1 result. */
{




    if (*exprstring == '\0') {




























	/*
	 * An empty string. Just set the result boolean to 0 (false).
	 */

	*ptr = 0;
	return TCL_OK;
    } else {
	int result;
	Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1);

	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
	if (result != TCL_OK) {
	    /*
	     * Move the interpreter's object result to the string result, then
	     * reset the object result.
	     */

	    (void) Tcl_GetStringResult(interp);
	}
	return result;
    }
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
 *
 *	Procedures to evaluate an expression in an object and return its value
 *	in a particular form.
 *
 * Results:
 *	Each of the procedures below returns a standard Tcl result object. If
 *	an error occurs then an error message is left in the interpreter's
 *	result. Otherwise the value of the expression, in the appropriate
 *	form, is stored at *ptr. If the expression had a result that was
 *	incompatible with the desired form then an error is returned.

 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

int
Tcl_ExprLongObj(interp, objPtr, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    register Tcl_Obj *objPtr;	/* Expression to evaluate. */
    long *ptr;			/* Where to store long result. */
{
    Tcl_Obj *resultPtr;
    int result, type;
    double d;
    ClientData internalPtr;

    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }

    if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (type) {
    case TCL_NUMBER_DOUBLE: {
	mp_int big;
	d = *((CONST double *)internalPtr);
	Tcl_DecrRefCount(resultPtr);
	if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) {
	    return TCL_ERROR;
	}
	resultPtr = Tcl_NewBignumObj(&big);
	/* FALLTHROUGH */
    }
    case TCL_NUMBER_LONG:
    case TCL_NUMBER_WIDE:
    case TCL_NUMBER_BIG:
	result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
	break;

    case TCL_NUMBER_NAN:
	Tcl_GetDoubleFromObj(interp, resultPtr, &d);
	result = TCL_ERROR;
    }

    Tcl_DecrRefCount(resultPtr);  /* discard the result object */

    return result;
}

int
Tcl_ExprDoubleObj(interp, objPtr, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    register Tcl_Obj *objPtr;	/* Expression to evaluate. */
    double *ptr;		/* Where to store double result. */
{
    Tcl_Obj *resultPtr;
    int result, type;
    ClientData internalPtr;

    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }

    result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type);
    if (result == TCL_OK) {
	switch (type) {



	case TCL_NUMBER_NAN:
#ifndef ACCEPT_NAN
	    result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr );
	    break;
#endif
	case TCL_NUMBER_DOUBLE:
	    *ptr = *((CONST double *)internalPtr);
	    result = TCL_OK;
	    break;
	default:
	    result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr );
	}
    }
    Tcl_DecrRefCount(resultPtr);  /* discard the result object */

    return result;
}

int
Tcl_ExprBooleanObj(interp, objPtr, ptr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    register Tcl_Obj *objPtr;	/* Expression to evaluate. */
    int *ptr;			/* Where to store 0/1 result. */
{
    Tcl_Obj *resultPtr;
    int result;

    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {





	result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);

	Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInvokeNamespace --
 *
 *	Object version: Invokes a Tcl command, given an objv/objc, from either
 *	the exposed or hidden set of commands in the given interpreter.

 *	NOTE: The command is invoked in the global stack frame of the
 *	interpreter or namespace, thus it cannot see any current state on the
 *	stack of that interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Whatever the command does.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInvokeNamespace(interp, objc, objv, nsPtr, flags)
    Tcl_Interp *interp;		/* Interpreter in which command is to be
				 * invoked. */
    int objc;			/* Count of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects; objv[0] points to the
				 * name of the command to invoke. */
    Tcl_Namespace *nsPtr;	/* The namespace to use. */
    int flags;			/* Combination of flags controlling the call:
				 * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,

				 * or TCL_INVOKE_NO_TRACEBACK. */
{

    int result;
    Tcl_CallFrame *framePtr;

    /*
     * Make the specified namespace the current namespace and invoke the
     * command.
     */

    result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }

    result = TclObjInvoke(interp, objc, objv, flags);

    TclPopStackFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInvoke --
 *
 *	Invokes a Tcl command, given an objv/objc, from either the exposed or
 *	the hidden sets of commands in the given interpreter.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	Whatever the command does.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInvoke(interp, objc, objv, flags)
    Tcl_Interp *interp;		/* Interpreter in which command is to be
				 * invoked. */
    int objc;			/* Count of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects; objv[0] points to the
				 * name of the command to invoke. */
    int flags;			/* Combination of flags controlling the call:
				 * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,

				 * or TCL_INVOKE_NO_TRACEBACK. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTblPtr;	/* Table of hidden commands. */
    char *cmdName;		/* Name of the command from objv[0]. */
    Tcl_HashEntry *hPtr = NULL;
    Command *cmdPtr;
    int result;

    if (interp == (Tcl_Interp *) NULL) {
	return TCL_ERROR;
    }

    if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
	Tcl_AppendResult(interp, "illegal argument vector", (char *) NULL);
	return TCL_ERROR;
    }

    if ((flags & TCL_INVOKE_HIDDEN) == 0) {
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }

    if (TclInterpReady(interp) == TCL_ERROR) {
4225
4226
4227
4228
4229
4230
4231

4232

4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248


4249

4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329


4330














4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360

4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438

4439
4440
4441
4442
4443
4444
4445
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "invalid hidden command name \"",
		cmdName, "\"", (char *) NULL);
	return TCL_ERROR;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);


    /* Invoke the command procedure. */


    iPtr->cmdCount++;
    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);

    /*
     * If an error occurred, record information about what was being
     * executed when the error occurred.
     */

    if ((result == TCL_ERROR)
	    && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
	    && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
	int length;
	Tcl_Obj *command = Tcl_NewListObj(objc, objv);
	CONST char* cmdString = Tcl_GetStringFromObj(command, &length);



	Tcl_LogCommandInfo(interp, cmdString, cmdString, length);

	iPtr->flags &= ~ERR_ALREADY_LOGGED;
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprString --
 *
 *	Evaluate an expression in a string and return its value in string
 *	form.
 *
 * Results:
 *	A standard Tcl result. If the result is TCL_OK, then the interp's
 *	result is set to the string value of the expression. If the result
 *	is TCL_ERROR, then the interp's result contains an error message.
 *
 * Side effects:
 *	A Tcl object is allocated to hold a copy of the expression string.
 *	This expression object is passed to Tcl_ExprObj and then
 *	deallocated.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_ExprString(interp, string)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *string;		/* Expression to evaluate. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    char buf[TCL_DOUBLE_SPACE];
    int result = TCL_OK;

    if (length > 0) {
	TclNewObj(exprPtr);
	TclInitStringRep(exprPtr, string, length);
	Tcl_IncrRefCount(exprPtr);

	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
	if (result == TCL_OK) {
	    /*
	     * Set the interpreter's string result from the result object.
	     */
	    
	    if (resultPtr->typePtr == &tclIntType) {
		sprintf(buf, "%ld", resultPtr->internalRep.longValue);
		Tcl_SetResult(interp, buf, TCL_VOLATILE);
	    } else if (resultPtr->typePtr == &tclDoubleType) {
		Tcl_PrintDouble((Tcl_Interp *) NULL,
		        resultPtr->internalRep.doubleValue, buf);
		Tcl_SetResult(interp, buf, TCL_VOLATILE);
	    } else {
		/*
		 * Set interpreter's string result from the result object.
		 */
	    
		Tcl_SetResult(interp, TclGetString(resultPtr),
		        TCL_VOLATILE);
	    }
	    Tcl_DecrRefCount(resultPtr);  /* discard the result object */
	} else {
	    /*
	     * Move the interpreter's object result to the string result, 
	     * then reset the object result.
	     */
	    
	    (void) Tcl_GetStringResult(interp);
	}
	Tcl_DecrRefCount(exprPtr); /* discard the expression object */
    } else {
	/*
	 * An empty string. Just set the interpreter's result to 0.
	 */
	
	Tcl_SetResult(interp, "0", TCL_VOLATILE);


    }














    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclAppendObjToErrorInfo --
 *
 *	Add a Tcl_Obj value to the errorInfo field that describes the
 *	current error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	The value of the Tcl_obj is appended to the errorInfo field.
 *	If we are just starting to log an error, errorInfo is initialized
 *	from the error message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

void
TclAppendObjToErrorInfo(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    Tcl_Obj *objPtr;		/* Message to record. */
{
    int length;
    CONST char *message = Tcl_GetStringFromObj(objPtr, &length);

    Tcl_AddObjErrorInfo(interp, message, length);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddErrorInfo --
 *
 *	Add information to the errorInfo field that describes the
 *	current error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of message are appended to the errorInfo field.
 *	If we are just starting to log an error, errorInfo is initialized
 *	from the error message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AddErrorInfo(interp, message)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    CONST char *message;	/* Message to record. */
{
    Tcl_AddObjErrorInfo(interp, message, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddObjErrorInfo --
 *
 *	Add information to the errorInfo field that describes the
 *	current error. This routine differs from Tcl_AddErrorInfo by
 *	taking a byte pointer and length.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	"length" bytes from "message" are appended to the errorInfo field.
 *	If "length" is negative, use bytes up to the first NULL byte.
 *	If we are just starting to log an error, errorInfo is initialized
 *	from the error message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AddObjErrorInfo(interp, message, length)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    CONST char *message;	/* Points to the first byte of an array of
				 * bytes of the message. */
    int length;			/* The number of bytes in the message.
				 * If < 0, then append all bytes up to a
				 * NULL byte. */
{
    register Interp *iPtr = (Interp *) interp;
    
    /*
     * If we are just starting to log an error, errorInfo is initialized
     * from the error message in the interpreter's result.
     */

    if (iPtr->errorInfo == NULL) { /* just starting to log error */
	if (iPtr->result[0] != 0) {
	    /*
	     * The interp's string result is set, apparently by some
	     * extension making a deprecated direct write to it.
	     * That extension may expect interp->result to continue
	     * to be set, so we'll take special pains to avoid clearing
	     * it, until we drop support for interp->result completely.
	     */

	    iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1);
	} else {
	    iPtr->errorInfo = iPtr->objResultPtr;
	}
	Tcl_IncrRefCount(iPtr->errorInfo);
	if (!iPtr->errorCode) {
	    Tcl_SetErrorCode(interp, "NONE", NULL);







>
|
>





|
|







|

>
>

>















|
|



|
<





|


|

<
<
<
<
|

<
<
<
<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|

>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|







|
|





|
|
|












>








|
|





|
|
|


















|
|
|





|
|
|
|










|
|
<


|

|
|





|
|
|
|
|

>







4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570

4571
4572
4573
4574
4575
4576
4577
4578
4579
4580




4581
4582




4583


4584






























4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696

4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "invalid hidden command name \"",
		cmdName, "\"", (char *) NULL);
	return TCL_ERROR;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

    /*
     * Invoke the command procedure.
     */

    iPtr->cmdCount++;
    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);

    /*
     * If an error occurred, record information about what was being executed
     * when the error occurred.
     */

    if ((result == TCL_ERROR)
	    && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
	    && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
	int length;
	Tcl_Obj *command = Tcl_NewListObj(objc, objv);
	CONST char* cmdString;

	Tcl_IncrRefCount(command);
	cmdString = Tcl_GetStringFromObj(command, &length);
	Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
	Tcl_DecrRefCount(command);
	iPtr->flags &= ~ERR_ALREADY_LOGGED;
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprString --
 *
 *	Evaluate an expression in a string and return its value in string
 *	form.
 *
 * Results:
 *	A standard Tcl result. If the result is TCL_OK, then the interp's
 *	result is set to the string value of the expression. If the result is
 *	TCL_ERROR, then the interp's result contains an error message.
 *
 * Side effects:
 *	A Tcl object is allocated to hold a copy of the expression string.
 *	This expression object is passed to Tcl_ExprObj and then deallocated.

 *
 *---------------------------------------------------------------------------
 */

int
Tcl_ExprString(interp, expr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    CONST char *expr;		/* Expression to evaluate. */
{




    int code = TCL_OK;





    if (expr[0] == '\0') {


	/*






























	 * An empty string. Just set the interpreter's result to 0.
	 */

	Tcl_SetResult(interp, "0", TCL_VOLATILE);
    } else {
	Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);

	Tcl_IncrRefCount(exprObj);
	code = Tcl_ExprObj(interp, exprObj, &resultPtr);
	Tcl_DecrRefCount(exprObj);
	if (code == TCL_OK) {
	    Tcl_SetObjResult(interp, resultPtr);
	    Tcl_DecrRefCount(resultPtr);
	}

	/*
	 * Force the string rep of the interp result.
	 */

	(void) Tcl_GetStringResult(interp);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclAppendObjToErrorInfo --
 *
 *	Add a Tcl_Obj value to the errorInfo field that describes the current
 *	error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The value of the Tcl_obj is appended to the errorInfo field. If we are
 *	just starting to log an error, errorInfo is initialized from the error
 *	message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

void
TclAppendObjToErrorInfo(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    Tcl_Obj *objPtr;		/* Message to record. */
{
    int length;
    CONST char *message = Tcl_GetStringFromObj(objPtr, &length);

    Tcl_AddObjErrorInfo(interp, message, length);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddErrorInfo --
 *
 *	Add information to the errorInfo field that describes the current
 *	error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of message are appended to the errorInfo field. If we are
 *	just starting to log an error, errorInfo is initialized from the error
 *	message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AddErrorInfo(interp, message)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    CONST char *message;	/* Message to record. */
{
    Tcl_AddObjErrorInfo(interp, message, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddObjErrorInfo --
 *
 *	Add information to the errorInfo field that describes the current
 *	error. This routine differs from Tcl_AddErrorInfo by taking a byte
 *	pointer and length.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	"length" bytes from "message" are appended to the errorInfo field. If
 *	"length" is negative, use bytes up to the first NULL byte. If we are
 *	just starting to log an error, errorInfo is initialized from the error
 *	message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AddObjErrorInfo(interp, message, length)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    CONST char *message;	/* Points to the first byte of an array of
				 * bytes of the message. */
    int length;			/* The number of bytes in the message. If < 0,
				 * then append all bytes up to a NULL byte. */

{
    register Interp *iPtr = (Interp *) interp;

    /*
     * If we are just starting to log an error, errorInfo is initialized from
     * the error message in the interpreter's result.
     */

    if (iPtr->errorInfo == NULL) { /* just starting to log error */
	if (iPtr->result[0] != 0) {
	    /*
	     * The interp's string result is set, apparently by some extension
	     * making a deprecated direct write to it. That extension may
	     * expect interp->result to continue to be set, so we'll take
	     * special pains to avoid clearing it, until we drop support for
	     * interp->result completely.
	     */

	    iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1);
	} else {
	    iPtr->errorInfo = iPtr->objResultPtr;
	}
	Tcl_IncrRefCount(iPtr->errorInfo);
	if (!iPtr->errorCode) {
	    Tcl_SetErrorCode(interp, "NONE", NULL);
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_VarEvalVA --
 *
 *	Given a variable number of string arguments, concatenate them
 *	all together and execute the result as a Tcl command.
 *
 * Results:
 *	A standard Tcl return result.  An error message or other result may
 *	be left in the interp's result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_VarEvalVA (interp, argList)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */
    va_list argList;		/* Variable argument list. */
{
    Tcl_DString buf;
    char *string;
    int result;

    /*
     * Copy the strings one after the other into a single larger
     * string.  Use stack-allocated space for small commands, but if
     * the command gets too large than call ckalloc to create the
     * space.
     */

    Tcl_DStringInit(&buf);
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;







|
|


|
|








|








|
|
|
<







4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769

4770
4771
4772
4773
4774
4775
4776
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_VarEvalVA --
 *
 *	Given a variable number of string arguments, concatenate them all
 *	together and execute the result as a Tcl command.
 *
 * Results:
 *	A standard Tcl return result. An error message or other result may be
 *	left in the interp's result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_VarEvalVA(interp, argList)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */
    va_list argList;		/* Variable argument list. */
{
    Tcl_DString buf;
    char *string;
    int result;

    /*
     * Copy the strings one after the other into a single larger string. Use
     * stack-allocated space for small commands, but if the command gets too
     * large than call ckalloc to create the space.

     */

    Tcl_DStringInit(&buf);
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarEval --
 *
 *	Given a variable number of string arguments, concatenate them
 *	all together and execute the result as a Tcl command.
 *
 * Results:
 *	A standard Tcl return result.  An error message or other
 *	result may be left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;
    int result;

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    result = Tcl_VarEvalVA(interp, argList);
    va_end(argList);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_GlobalEval --
 *
 *	Evaluate a command at global level in an interpreter.
 *
 * Results:
 *	A standard Tcl result is returned, and the interp's result is
 *	modified accordingly.
 *
 * Side effects:
 *	The command string is executed in interp, and the execution
 *	is carried out in the variable context of global level (no
 *	procedures active), just as if an "uplevel #0" command were
 *	being executed.
 *
 ---------------------------------------------------------------------------
 */

int
Tcl_GlobalEval(interp, command)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */







|
|


|
|






|

|

<



|














|
|


|
|
|
<







4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806

4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831

4832
4833
4834
4835
4836
4837
4838
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarEval --
 *
 *	Given a variable number of string arguments, concatenate them all
 *	together and execute the result as a Tcl command.
 *
 * Results:
 *	A standard Tcl return result. An error message or other result may be
 *	left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_VarEval(Tcl_Interp *interp, ...)
{

    va_list argList;
    int result;

    va_start(argList, interp);
    result = Tcl_VarEvalVA(interp, argList);
    va_end(argList);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_GlobalEval --
 *
 *	Evaluate a command at global level in an interpreter.
 *
 * Results:
 *	A standard Tcl result is returned, and the interp's result is modified
 *	accordingly.
 *
 * Side effects:
 *	The command string is executed in interp, and the execution is carried
 *	out in the variable context of global level (no procedures active),
 *	just as if an "uplevel #0" command were being executed.

 *
 ---------------------------------------------------------------------------
 */

int
Tcl_GlobalEval(interp, command)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
















































































































































































































































































































































































































































































































































































































































































































































































































































4678




4679
4680







}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetRecursionLimit --
 *
 *	Set the maximum number of recursive calls that may be active
 *	for an interpreter at once.
 *
 * Results:
 *	The return value is the old limit on nesting for interp.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetRecursionLimit(interp, depth)
    Tcl_Interp *interp;			/* Interpreter whose nesting limit
					 * is to be set. */
    int depth;				/* New value for maximimum depth. */
{
    Interp *iPtr = (Interp *) interp;
    int old;

    old = iPtr->maxNestingDepth;
    if (depth > 0) {
	iPtr->maxNestingDepth = depth;
    }
    return old;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AllowExceptions --
 *
 *	Sets a flag in an interpreter so that exceptions can occur
 *	in the next call to Tcl_Eval without them being turned into
 *	errors.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
 *	evalFlags structure.  See the reference documentation for
 *	more details.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AllowExceptions(interp)
    Tcl_Interp *interp;		/* Interpreter in which to set flag. */
{
    Interp *iPtr = (Interp *) interp;

    iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVersion
 *
 *	Get the Tcl major, minor, and patchlevel version numbers and
 *      the release type.  A patch is a release type TCL_FINAL_RELEASE
 *      with a patchLevel > 0.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetVersion(majorV, minorV, patchLevelV, type)
    int *majorV;
    int *minorV;
    int *patchLevelV;
    int *type;
{
    if (majorV != NULL) {
        *majorV = TCL_MAJOR_VERSION;
    }
    if (minorV != NULL) {
        *minorV = TCL_MINOR_VERSION;
    }
    if (patchLevelV != NULL) {
        *patchLevelV = TCL_RELEASE_SERIAL;
    }
    if (type != NULL) {
        *type = TCL_RELEASE_LEVEL;
















































































































































































































































































































































































































































































































































































































































































































































































































































    }




}
 














|
|












|
|
|
















|
|
<





|
|
<












<




|

|
|
|


















|


|


|


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>

|
>
>
>
>
>
>
>
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891

4892
4893
4894
4895
4896
4897
4898

4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910

4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetRecursionLimit --
 *
 *	Set the maximum number of recursive calls that may be active for an
 *	interpreter at once.
 *
 * Results:
 *	The return value is the old limit on nesting for interp.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetRecursionLimit(interp, depth)
    Tcl_Interp *interp;		/* Interpreter whose nesting limit is to be
				 * set. */
    int depth;			/* New value for maximimum depth. */
{
    Interp *iPtr = (Interp *) interp;
    int old;

    old = iPtr->maxNestingDepth;
    if (depth > 0) {
	iPtr->maxNestingDepth = depth;
    }
    return old;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AllowExceptions --
 *
 *	Sets a flag in an interpreter so that exceptions can occur in the next
 *	call to Tcl_Eval without them being turned into errors.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags
 *	structure. See the reference documentation for more details.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_AllowExceptions(interp)
    Tcl_Interp *interp;		/* Interpreter in which to set flag. */
{
    Interp *iPtr = (Interp *) interp;

    iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVersion --
 *
 *	Get the Tcl major, minor, and patchlevel version numbers and the
 *	release type. A patch is a release type TCL_FINAL_RELEASE with a
 *	patchLevel > 0.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetVersion(majorV, minorV, patchLevelV, type)
    int *majorV;
    int *minorV;
    int *patchLevelV;
    int *type;
{
    if (majorV != NULL) {
	*majorV = TCL_MAJOR_VERSION;
    }
    if (minorV != NULL) {
	*minorV = TCL_MINOR_VERSION;
    }
    if (patchLevelV != NULL) {
	*patchLevelV = TCL_RELEASE_SERIAL;
    }
    if (type != NULL) {
	*type = TCL_RELEASE_LEVEL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Math Functions --
 *
 *	This page contains the procedures that implement all of the built-in
 *	math functions for expressions.
 *
 * Results:
 *	Each procedure returns TCL_OK if it succeeds and pushes an Tcl object
 *	holding the result. If it fails it returns TCL_ERROR and leaves an
 *	error message in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ExprCeilFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter list */
{
    int code;
    double d;
    mp_int big;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big)));
	mp_clear(&big);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
    }
    return TCL_OK;
}

static int
ExprFloorFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter list */
{
    int code;
    double d;
    mp_int big;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big)));
	mp_clear(&big);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
    }
    return TCL_OK;
}

static int
ExprSqrtFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter list */
{
    int code;
    double d;
    mp_int big;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    if (d >= 0.0 && TclIsInfinite(d) 
	    && Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
	mp_int root;
	mp_init(&root);
	mp_sqrt(&big, &root);
	mp_clear(&big);
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
	mp_clear(&root);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d)));
    }
    return TCL_OK;
}

static int
ExprUnaryFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes one double argument and returns a
				 * double result. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter list */
{
    int code;
    double d;
    double (*func)(double) = (double (*)(double)) clientData;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	d = objv[1]->internalRep.doubleValue;
	Tcl_ResetResult(interp);
	code = TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    errno = 0;
    return CheckDoubleResult(interp, (*func)(d));
}

static int
CheckDoubleResult(interp, dResult)
    Tcl_Interp *interp;
    double dResult;
{
#ifndef ACCEPT_NAN
    if (TclIsNaN(dResult)) {
	TclExprFloatError(interp, dResult);
	return TCL_ERROR;
    }
#endif
    if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) {
	/* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */
    } else if (errno != 0) {
	/* Report other errno values as errors */
	TclExprFloatError(interp, dResult);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
    return TCL_OK;
}

static int
ExprBinaryFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes two double arguments and returns a
				 * double result. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Parameter vector */
{
    int code;
    double d1, d2;
    double (*func)(double, double) = (double (*)(double, double)) clientData;

    if (objc != 3) {
	MathFuncWrongNumArgs(interp, 3, objc, objv);
	return TCL_ERROR;
    } 
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	d1 = objv[1]->internalRep.doubleValue;
	Tcl_ResetResult(interp);
	code = TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
	d2 = objv[2]->internalRep.doubleValue;
	Tcl_ResetResult(interp);
	code = TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    errno = 0;
    return CheckDoubleResult(interp, (*func)(d1, d2));
}

static int
ExprAbsFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Parameter vector */
{
    ClientData ptr;
    int type;
    mp_int big;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }

    if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
	return TCL_ERROR;
    }

    if (type == TCL_NUMBER_LONG) {
	long l = *((CONST long int *)ptr);
	if (l < (long)0) {
	    if (l == LONG_MIN) {
		TclBNInitBignumFromLong(&big, l);
		goto tooLarge;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
	} else {
	    Tcl_SetObjResult(interp, objv[1]);
	}
	return TCL_OK;
    }

    if (type == TCL_NUMBER_DOUBLE) {
	double d = *((CONST double *)ptr);
	if (d < 0.0) {
	    Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
	} else {
	    Tcl_SetObjResult(interp, objv[1]);
	}
	return TCL_OK;
    }

#ifndef NO_WIDE_TYPE
    if (type == TCL_NUMBER_WIDE) {
	Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr);
	if (w < (Tcl_WideInt)0) {
	    if (w == LLONG_MIN) {
		TclBNInitBignumFromWideInt(&big, w);
		goto tooLarge;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
	} else {
	    Tcl_SetObjResult(interp, objv[1]);
	}
	return TCL_OK;
    }
#endif

    if (type == TCL_NUMBER_BIG) {
	/* TODO: const correctness ? */
	if (mp_cmp_d((mp_int *)ptr, 0) == MP_LT) {
	    Tcl_GetBignumFromObj(NULL, objv[1], &big);
	tooLarge:
	    mp_neg(&big, &big);
	    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
	} else {
	    Tcl_SetObjResult(interp, objv[1]);
	}
	return TCL_OK;
    }

    if (type == TCL_NUMBER_NAN) {
#ifdef ACCEPT_NAN
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
#else
	double d;
	Tcl_GetDoubleFromObj(interp, objv[1], &d);
	return TCL_ERROR;
#endif
    }
}

static int
ExprBoolFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    int value;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
    return TCL_OK;
}

static int
ExprDoubleFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    double dResult;
#if 0
    Tcl_Obj* valuePtr;
    Tcl_Obj* oResult;

    /*
     * Check parameter type
     */

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
    } else {
	valuePtr = objv[1];
	if (VerifyExprObjType(interp, valuePtr) == TCL_OK) {
	    GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
	    TclNewDoubleObj(oResult, dResult);
	    Tcl_SetObjResult(interp, oResult);
	    return TCL_OK;
	}
    }

    return TCL_ERROR;
#else
    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
	if (objv[1]->typePtr == &tclDoubleType) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}
#endif
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
    return TCL_OK;
#endif
}

static int
ExprEntierFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    double d;
    int type;
    ClientData ptr;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
	return TCL_ERROR;
    }
    if (type == TCL_NUMBER_DOUBLE) {
	d = *((CONST double *)ptr);
	if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) {
	    mp_int big;
	    if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) {
		/* Infinity */
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
	    return TCL_OK;
	} else {
	    long result = (long)d;
	    Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
	    return TCL_OK;
	}
    }
    if (type != TCL_NUMBER_NAN) {
	/* All integers are already of integer type */
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
    /* Get the error message for NaN */
    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
}

static int
ExprIntFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    long iResult;
    Tcl_Obj *objPtr;
#if 0
    register Tcl_Obj *valuePtr;
    Tcl_Obj* oResult;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
    } else {
	valuePtr = objv[1];
	if (VerifyExprObjType(interp, valuePtr) == TCL_OK) {
	    if (valuePtr->typePtr == &tclIntType) {
		iResult = valuePtr->internalRep.longValue;
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		TclGetLongFromWide(iResult,valuePtr);
	    } else {
		d = valuePtr->internalRep.doubleValue;
		if (d < 0.0) {
		    if (d < (double) (long) LONG_MIN) {
		    tooLarge:
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"integer value too large to represent", -1));
			Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
				"integer value too large to represent",
				(char *) NULL);
			return TCL_ERROR;
		    }
		} else if (d > (double) LONG_MAX) {
		    goto tooLarge;
		}
		if (IS_NAN(d) || IS_INF(d)) {
		    TclExprFloatError(interp, d);
		    return TCL_ERROR;
		}
		iResult = (long) d;
	    }
	    TclNewIntObj(oResult, iResult);
	    Tcl_SetObjResult(interp, oResult);
	    return TCL_OK;
	}
    }
    return TCL_ERROR;
#else
    if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }
    objPtr = Tcl_GetObjResult(interp);
    if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
	/* truncate the bignum; keep only bits in long range */
	mp_int big;
	Tcl_GetBignumFromObj(NULL, objPtr, &big);
	mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
	objPtr = Tcl_NewBignumObj(&big);
	Tcl_IncrRefCount(objPtr);
	Tcl_GetLongFromObj(NULL, objPtr, &iResult);
	Tcl_DecrRefCount(objPtr);
    }
    Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
    return TCL_OK;
#endif
}

static int
ExprWideFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    Tcl_WideInt wResult;
    Tcl_Obj *objPtr;
#if 0
    register Tcl_Obj *valuePtr;
    Tcl_Obj* oResult;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
    } else {
	valuePtr = objv[1];
	if (VerifyExprObjType(interp, valuePtr) == TCL_OK) {
	    if (valuePtr->typePtr == &tclIntType) {
		wResult = valuePtr->internalRep.longValue;
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		wResult = valuePtr->internalRep.wideValue;
	    } else {
		d = valuePtr->internalRep.doubleValue;
		if (d < 0.0) {
		    if (d < Tcl_WideAsDouble(LLONG_MIN)) {
		    tooLarge:
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"integer value too large to represent", -1));
			Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
				"integer value too large to represent",
				(char *) NULL);
			return TCL_ERROR;
		    }
		} else if (d > Tcl_WideAsDouble(LLONG_MAX)) {
		    goto tooLarge;
		}
		if (IS_NAN(d) || IS_INF(d)) {
		    TclExprFloatError(interp, d);
		    return TCL_ERROR;
		}
		wResult = (Tcl_WideInt) d;
	    }
	    TclNewWideIntObj(oResult, wResult);
	    Tcl_SetObjResult(interp, oResult);
	    return TCL_OK;
	}
    }
    return TCL_ERROR;
#else
    if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }
    objPtr = Tcl_GetObjResult(interp);
    if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
	/* truncate the bignum; keep only bits in wide int range */
	mp_int big;
	Tcl_GetBignumFromObj(NULL, objPtr, &big);
	mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
	objPtr = Tcl_NewBignumObj(&big);
	Tcl_IncrRefCount(objPtr);
	Tcl_GetWideIntFromObj(NULL, objPtr, &wResult);
	Tcl_DecrRefCount(objPtr);
    }
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
    return TCL_OK;
#endif
}

static int
ExprRandFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    Interp *iPtr = (Interp *) interp;
    double dResult;
    long tmp;			/* Algorithm assumes at least 32 bits.
				 * Only long guarantees that.  See below. */
    Tcl_Obj* oResult;

    if (objc != 1) {
	MathFuncWrongNumArgs(interp, 1, objc, objv);
	return TCL_ERROR;
    }

    if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
	iPtr->flags |= RAND_SEED_INITIALIZED;

	/*
	 * Take into consideration the thread this interp is running in order
	 * to insure different seeds in different threads (bug #416643)
	 */

	iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);

	/*
	 * Make sure 1 <= randSeed <= (2^31) - 2. See below.
	 */

	iPtr->randSeed &= (unsigned long) 0x7fffffff;
	if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
	    iPtr->randSeed ^= 123459876;
	}
    }

    /*
     * Generate the random number using the linear congruential generator
     * defined by the following recurrence:
     *		seed = ( IA * seed ) mod IM
     * where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in
     * the range [1, IM - 1] to a new seed in that same range. The recurrence
     * maps IM to 0, and maps 0 back to 0, so those two values must not be
     * allowed as initial values of seed.
     *
     * In order to avoid potential problems with integer overflow, the
     * recurrence is implemented in terms of additional constants IQ and IR
     * such that
     *		IM = IA*IQ + IR
     * None of the operations in the implementation overflows a 32-bit signed
     * integer, and the C type long is guaranteed to be at least 32 bits wide.
     *
     * For more details on how this algorithm works, refer to the following
     * papers:
     *
     *	S.K. Park & K.W. Miller, "Random number generators: good ones are hard
     *	to find," Comm ACM 31(10):1192-1201, Oct 1988
     *
     *	W.H. Press & S.A. Teukolsky, "Portable random number generators,"
     *	Computers in Physics 6(5):522-524, Sep/Oct 1992.
     */

#define RAND_IA		16807
#define RAND_IM		2147483647
#define RAND_IQ		127773
#define RAND_IR		2836
#define RAND_MASK	123459876

    tmp = iPtr->randSeed/RAND_IQ;
    iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
    if (iPtr->randSeed < 0) {
	iPtr->randSeed += RAND_IM;
    }

    /*
     * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
     * dividing by RAND_IM yields a double in the range (0, 1).
     */

    dResult = iPtr->randSeed * (1.0/RAND_IM);

    /*
     * Push a Tcl object with the result.
     */

    TclNewDoubleObj(oResult, dResult);
    Tcl_SetObjResult(interp, oResult);
    return TCL_OK;
}

static int
ExprRoundFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Parameter vector */
{
    double d;
    ClientData ptr;
    int type;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 1, objc, objv);
	return TCL_ERROR;
    }

    if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
	return TCL_ERROR;
    }
    if (type == TCL_NUMBER_DOUBLE) {
	double fractPart, intPart;
	long max = LONG_MAX, min = LONG_MIN;

	fractPart = modf(*((CONST double *)ptr), &intPart);
	if (fractPart <= -0.5) {
	    min++;
	} else if (fractPart >= 0.5) {
	    max--;
	}
	if ((intPart >= (double)max) || (intPart <= (double)min)) {
	    mp_int big;
	    if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
		/* Infinity */
		return TCL_ERROR;
	    }
	    if (fractPart <= -0.5) {
		mp_sub_d(&big, 1, &big);
	    } else if (fractPart >= 0.5) {
		mp_add_d(&big, 1, &big);
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
	    return TCL_OK;
	} else {
	    long result = (long)intPart;
	    if (fractPart <= -0.5) {
		result--;
	    } else if (fractPart >= 0.5) {
		result++;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
	    return TCL_OK;
	}
    }
    if (type != TCL_NUMBER_NAN) {
	/* All integers are already rounded */
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
    /* Get the error message for NaN */
    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
}

static int
ExprSrandFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Parameter vector */
{
    Interp *iPtr = (Interp *) interp;
    long i = 0;			/* Initialized to avoid compiler warning. */

    /*
     * Convert argument and use it to reset the seed.
     */

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }

    if (Tcl_GetLongFromObj(interp, objv[1], &i) != TCL_OK) {
	/* TODO: more ::errorInfo here?  or in caller? */
	return TCL_ERROR;
    }

    /*
     * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
     * ExprRandFunc() for more details.
     */

    iPtr->flags |= RAND_SEED_INITIALIZED;
    iPtr->randSeed = i;
    iPtr->randSeed &= (unsigned long) 0x7fffffff;
    if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
	iPtr->randSeed ^= 123459876;
    }

    /*
     * To avoid duplicating the random number generation code we simply clean
     * up our state and call the real random number function. That function
     * will always succeed.
     */

    return ExprRandFunc(clientData, interp, 1, objv);

}

/*
 *----------------------------------------------------------------------
 *
 * MathFuncWrongNumArgs --
 *
 *	Generate an error message when a math function presents the wrong
 *	number of arguments.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is stored in the interpreter result.
 *
 *----------------------------------------------------------------------
 */

static void
MathFuncWrongNumArgs(interp, expected, found, objv)
     Tcl_Interp* interp;	/* Tcl interpreter */
     int expected;		/* Formal parameter count */
     int found;			/* Actual parameter count */
     Tcl_Obj *CONST *objv;	/* Actual parameter vector */
{
    Tcl_Obj* errorMessage;
    CONST char* name = Tcl_GetString(objv[0]);
    CONST char* tail = name + strlen(name);

    while (tail > name+1) {
	--tail;
	if (*tail == ':' && tail[-1] == ':') {
	    name = tail+1;
	    break;
	}
    }
    errorMessage = Tcl_NewStringObj("too ", -1);
    if (found < expected) {
	Tcl_AppendToObj(errorMessage, "few", -1);
    } else {
	Tcl_AppendToObj(errorMessage, "many", -1);
    }
    Tcl_AppendToObj(errorMessage, " arguments for math function \"", -1);
    Tcl_AppendToObj(errorMessage, name, -1);
    Tcl_AppendToObj(errorMessage, "\"", -1);
    Tcl_SetObjResult(interp, errorMessage);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclBinary.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
/* 
 * tclBinary.c --
 *
 *	This file contains the implementation of the "binary" Tcl built-in
 *	command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.21 2004/10/06 05:52:21 dgp Exp $
 */

#include "tclInt.h"

#ifdef TCL_NO_MATH
#define fabs(x) (x<0 ? -x : x)
#else
#include <math.h>
#endif

/*
 * The following constants are used by GetFormatSpec to indicate various
 * special conditions in the parsing of a format specifier.
 */

#define BINARY_ALL -1		/* Use all elements in the argument. */
#define BINARY_NOCOUNT -2	/* No count was specified in format. */

/*
 * The following defines the maximum number of different (integer)
 * numbers placed in the object cache by 'binary scan' before it bails
 * out and switches back to Plan A (creating a new object for each
 * value.)  Theoretically, it would be possible to keep the cache
 * about for the values that are already in it, but that makes the
 * code slower in practise when overflow happens, and makes little
 * odds the rest of the time (as measured on my machine.)  It is also
 * slower (on the sample I tried at least) to grow the cache to hold
 * all items we might want to put in it; presumably the extra cost of
 * managing the memory for the enlarged table outweighs the benefit
 * from allocating fewer objects.  This is probably because as the
 * number of objects increases, the likelihood of reuse of any
 * particular one drops, and there is very little gain from larger
 * maximum cache sizes (the value below is chosen to allow caching to
 * work in full with conversion of bytes.) - DKF
 */

#define BINARY_SCAN_MAX_CACHE	260

/*
 * Prototypes for local procedures defined in this file:
 */

static void		DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static int		FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
			    Tcl_Obj *src, unsigned char **cursorPtr));
static void		FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		GetFormatSpec _ANSI_ARGS_((char **formatPtr,
			    char *cmdPtr, int *countPtr));
static Tcl_Obj *	ScanNumber _ANSI_ARGS_((unsigned char *buffer,
			    int type, Tcl_HashTable **numberCachePtr));
static int		SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
static void		DeleteScanNumberCache _ANSI_ARGS_((
			    Tcl_HashTable *numberCachePtr));
static int		NeedReversing _ANSI_ARGS_((int format));
static void		CopyNumber _ANSI_ARGS_((CONST void *from, void *to,
			    unsigned int length, int type));

/*
 * The following object type represents an array of bytes.  An array of
 * bytes is not equivalent to an internationalized string.  Conceptually, a
 * string is an array of 16-bit quantities organized as a sequence of properly
 * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
 * Accessor functions are provided to convert a ByteArray to a String or a
 * String to a ByteArray.  Two or more consecutive bytes in an array of bytes
 * may look like a single UTF-8 character if the array is casually treated as
 * a string.  But obtaining the String from a ByteArray is guaranteed to
 * produced properly formed UTF-8 sequences so that there is a one-to-one
 * map between bytes and characters.
 *
 * Converting a ByteArray to a String proceeds by casting each byte in the
 * array to a 16-bit quantity, treating that number as a Unicode character,
 * and storing the UTF-8 version of that Unicode character in the String.
 * For ByteArrays consisting entirely of values 1..127, the corresponding
 * String representation is the same as the ByteArray representation.
 *
 * Converting a String to a ByteArray proceeds by getting the Unicode
 * representation of each character in the String, casting it to a
 * byte by truncating the upper 8 bits, and then storing the byte in the
 * ByteArray.  Converting from ByteArray to String and back to ByteArray
 * is not lossy, but converting an arbitrary String to a ByteArray may be.
 */

Tcl_ObjType tclByteArrayType = {
    "bytearray",
    FreeByteArrayInternalRep,
    DupByteArrayInternalRep,
    UpdateStringOfByteArray,
    SetByteArrayFromAny
};

/*
 * The following structure is the internal rep for a ByteArray object.
 * Keeps track of how much memory has been used and how much has been
 * allocated for the byte array to enable growing and shrinking of the
 * ByteArray object with fewer mallocs.  
 */

typedef struct ByteArray {
    int used;			/* The number of bytes used in the byte
				 * array. */
    int allocated;		/* The amount of space actually allocated
				 * minus 1 byte. */
    unsigned char bytes[4];	/* The array of bytes.  The actual size of
				 * this field depends on the 'allocated' field
				 * above. */
} ByteArray;

#define BYTEARRAY_SIZE(len)	\
		((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
		((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
		(objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)


/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewByteArrayObj --
 *
 *	This procedure is creates a new ByteArray object and initializes
 *	it from the given array of bytes.
 *
 * Results:
 *	The newly create object is returned.  This object will have no
 *	initial string representation.  The returned object has a ref count
 *	of 0.
 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj


Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
    CONST unsigned char *bytes;	/* The array of bytes used to initialize
				 * the new object. */
    int length;			/* Length of the array of bytes, which must
				 * be >= 0. */
{
    return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
    CONST unsigned char *bytes;	/* The array of bytes used to initialize
				 * the new object. */
    int length;			/* Length of the array of bytes, which must
				 * be >= 0. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}
|








|
|

|




<
<
<

<










|
|
|
|
|
|
<
|
|
|
|
|
|
|
|








|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|


|
|
|
|

|

|
|
|



|
|
|


|
|
|
|











|
|
|
|







|
|
















|
|


|
|
<










<

|
|
|
|
|







|
|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17



18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
144
145
146

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
/*
 * tclBinary.c --
 *
 *	This file contains the implementation of the "binary" Tcl built-in
 *	command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.21.2.6 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"




#include <math.h>


/*
 * The following constants are used by GetFormatSpec to indicate various
 * special conditions in the parsing of a format specifier.
 */

#define BINARY_ALL -1		/* Use all elements in the argument. */
#define BINARY_NOCOUNT -2	/* No count was specified in format. */

/*
 * The following defines the maximum number of different (integer) numbers
 * placed in the object cache by 'binary scan' before it bails out and
 * switches back to Plan A (creating a new object for each value.)
 * Theoretically, it would be possible to keep the cache about for the values
 * that are already in it, but that makes the code slower in practise when
 * overflow happens, and makes little odds the rest of the time (as measured

 * on my machine.) It is also slower (on the sample I tried at least) to grow
 * the cache to hold all items we might want to put in it; presumably the
 * extra cost of managing the memory for the enlarged table outweighs the
 * benefit from allocating fewer objects. This is probably because as the
 * number of objects increases, the likelihood of reuse of any particular one
 * drops, and there is very little gain from larger maximum cache sizes (the
 * value below is chosen to allow caching to work in full with conversion of
 * bytes.) - DKF
 */

#define BINARY_SCAN_MAX_CACHE	260

/*
 * Prototypes for local procedures defined in this file:
 */

static void		DupByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    Tcl_Obj *src, unsigned char **cursorPtr);
static void		FreeByteArrayInternalRep(Tcl_Obj *objPtr);
static int		GetFormatSpec(char **formatPtr, char *cmdPtr,
			    int *countPtr);
static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
			    Tcl_HashTable **numberCachePtr);
static int		SetByteArrayFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);

static int		NeedReversing(int format);
static void		CopyNumber(CONST void *from, void *to,
			    unsigned int length, int type);

/*
 * The following object type represents an array of bytes. An array of bytes
 * is not equivalent to an internationalized string. Conceptually, a string is
 * an array of 16-bit quantities organized as a sequence of properly formed
 * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
 * Accessor functions are provided to convert a ByteArray to a String or a
 * String to a ByteArray. Two or more consecutive bytes in an array of bytes
 * may look like a single UTF-8 character if the array is casually treated as
 * a string. But obtaining the String from a ByteArray is guaranteed to
 * produced properly formed UTF-8 sequences so that there is a one-to-one map
 * between bytes and characters.
 *
 * Converting a ByteArray to a String proceeds by casting each byte in the
 * array to a 16-bit quantity, treating that number as a Unicode character,
 * and storing the UTF-8 version of that Unicode character in the String. For
 * ByteArrays consisting entirely of values 1..127, the corresponding String
 * representation is the same as the ByteArray representation.
 *
 * Converting a String to a ByteArray proceeds by getting the Unicode
 * representation of each character in the String, casting it to a byte by
 * truncating the upper 8 bits, and then storing the byte in the ByteArray.
 * Converting from ByteArray to String and back to ByteArray is not lossy, but
 * converting an arbitrary String to a ByteArray may be.
 */

Tcl_ObjType tclByteArrayType = {
    "bytearray",
    FreeByteArrayInternalRep,
    DupByteArrayInternalRep,
    UpdateStringOfByteArray,
    SetByteArrayFromAny
};

/*
 * The following structure is the internal rep for a ByteArray object. Keeps
 * track of how much memory has been used and how much has been allocated for
 * the byte array to enable growing and shrinking of the ByteArray object with
 * fewer mallocs.
 */

typedef struct ByteArray {
    int used;			/* The number of bytes used in the byte
				 * array. */
    int allocated;		/* The amount of space actually allocated
				 * minus 1 byte. */
    unsigned char bytes[4];	/* The array of bytes. The actual size of this
				 * field depends on the 'allocated' field
				 * above. */
} ByteArray;

#define BYTEARRAY_SIZE(len)	\
		((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
		((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
		(objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)


/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewByteArrayObj --
 *
 *	This procedure is creates a new ByteArray object and initializes it
 *	from the given array of bytes.
 *
 * Results:
 *	The newly create object is returned. This object will have no initial
 *	string representation. The returned object has a ref count of 0.

 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj


Tcl_Obj *
Tcl_NewByteArrayObj(
    CONST unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{
    return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewByteArrayObj(
    CONST unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
 *	the [memory active] command will report the correct file name and line
 *	number when reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewByteArrayObj.
 *
 * Results:
 *	The newly create object is returned.  This object will have no
 *	initial string representation.  The returned object has a ref count
 *	of 0.
 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
    CONST unsigned char *bytes;	/* The array of bytes used to initialize
				 * the new object. */
    int length;			/* Length of the array of bytes, which must
				 * be >= 0. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
    CONST unsigned char *bytes;	/* The array of bytes used to initialize
				 * the new object. */
    int length;			/* Length of the array of bytes, which must
				 * be >= 0. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetByteArrayObj --
 *
 *	Modify an object to be a ByteArray object and to have the specified
 *	array of bytes as its value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep and internal rep is freed.
 *	Memory allocated for copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetByteArrayObj(objPtr, bytes, length)
    Tcl_Obj *objPtr;		/* Object to initialize as a ByteArray. */
    CONST unsigned char *bytes;	/* The array of bytes to use as the new
				 * value. */
    int length;			/* Length of the array of bytes, which must
				 * be >= 0. */
{
    ByteArray *byteArrayPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetByteArrayObj called with shared object");
    }
    TclFreeIntRep(objPtr);







|
|
<










|
|
|
|
|
|

|
|











|
|
|
|
|
|

|
|

















|
|





|
|
|

|
|







183
184
185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
 *	the [memory active] command will report the correct file name and line
 *	number when reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewByteArrayObj.
 *
 * Results:
 *	The newly create object is returned. This object will have no initial
 *	string representation. The returned object has a ref count of 0.

 *
 * Side effects:
 *	Memory allocated for new object and copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewByteArrayObj(
    CONST unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length,			/* Length of the array of bytes, which must be
				 * >= 0. */
    CONST char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewByteArrayObj(
    CONST unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    int length,			/* Length of the array of bytes, which must be
				 * >= 0. */
    CONST char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetByteArrayObj --
 *
 *	Modify an object to be a ByteArray object and to have the specified
 *	array of bytes as its value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep and internal rep is freed. Memory
 *	allocated for copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetByteArrayObj(
    Tcl_Obj *objPtr,		/* Object to initialize as a ByteArray. */
    CONST unsigned char *bytes,	/* The array of bytes to use as the new
				 * value. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{
    ByteArray *byteArrayPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetByteArrayObj called with shared object");
    }
    TclFreeIntRep(objPtr);
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetByteArrayFromObj --
 *
 *	Attempt to get the array of bytes from the Tcl object.  If the
 *	object is not already a ByteArray object, an attempt will be
 *	made to convert it to one.
 *
 * Results:
 *	Pointer to array of bytes representing the ByteArray object.
 *
 * Side effects:
 *	Frees old internal rep.  Allocates memory for new internal rep.
 *
 *----------------------------------------------------------------------
 */

unsigned char *
Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
    Tcl_Obj *objPtr;		/* The ByteArray object. */
    int *lengthPtr;		/* If non-NULL, filled with length of the
				 * array of bytes in the ByteArray object. */
{
    ByteArray *baPtr;
    
    SetByteArrayFromAny(NULL, objPtr);
    baPtr = GET_BYTEARRAY(objPtr);

    if (lengthPtr != NULL) {
	*lengthPtr = baPtr->used;
    }
    return (unsigned char *) baPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetByteArrayLength --
 *
 *	This procedure changes the length of the byte array for this
 *	object.  Once the caller has set the length of the array, it
 *	is acceptable to directly modify the bytes in the array up until
 *	Tcl_GetStringFromObj() has been called on this object.
 *
 * Results:
 *	The new byte array of the specified length.
 *
 * Side effects:
 *	Allocates enough memory for an array of bytes of the requested
 *	size.  When growing the array, the old array is copied to the
 *	new array; new bytes are undefined.  When shrinking, the
 *	old array is truncated to the specified length.
 *
 *----------------------------------------------------------------------
 */

unsigned char *
Tcl_SetByteArrayLength(objPtr, length)
    Tcl_Obj *objPtr;		/* The ByteArray object. */
    int length;			/* New length for internal byte array. */
{
    ByteArray *byteArrayPtr, *newByteArrayPtr;
    
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetObjLength called with shared object");
    }
    if (objPtr->typePtr != &tclByteArrayType) {
	SetByteArrayFromAny(NULL, objPtr);
    }








|
|
|





|





|
|
|



|














|
|
|
|





|
|
|
|





|
|
|


|







277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetByteArrayFromObj --
 *
 *	Attempt to get the array of bytes from the Tcl object. If the object
 *	is not already a ByteArray object, an attempt will be made to convert
 *	it to one.
 *
 * Results:
 *	Pointer to array of bytes representing the ByteArray object.
 *
 * Side effects:
 *	Frees old internal rep. Allocates memory for new internal rep.
 *
 *----------------------------------------------------------------------
 */

unsigned char *
Tcl_GetByteArrayFromObj(
    Tcl_Obj *objPtr,		/* The ByteArray object. */
    int *lengthPtr)		/* If non-NULL, filled with length of the
				 * array of bytes in the ByteArray object. */
{
    ByteArray *baPtr;

    SetByteArrayFromAny(NULL, objPtr);
    baPtr = GET_BYTEARRAY(objPtr);

    if (lengthPtr != NULL) {
	*lengthPtr = baPtr->used;
    }
    return (unsigned char *) baPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetByteArrayLength --
 *
 *	This procedure changes the length of the byte array for this object.
 *	Once the caller has set the length of the array, it is acceptable to
 *	directly modify the bytes in the array up until Tcl_GetStringFromObj()
 *	has been called on this object.
 *
 * Results:
 *	The new byte array of the specified length.
 *
 * Side effects:
 *	Allocates enough memory for an array of bytes of the requested size.
 *	When growing the array, the old array is copied to the new array; new
 *	bytes are undefined. When shrinking, the old array is truncated to the
 *	specified length.
 *
 *----------------------------------------------------------------------
 */

unsigned char *
Tcl_SetByteArrayLength(
    Tcl_Obj *objPtr,		/* The ByteArray object. */
    int length)			/* New length for internal byte array. */
{
    ByteArray *byteArrayPtr, *newByteArrayPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetObjLength called with shared object");
    }
    if (objPtr->typePtr != &tclByteArrayType) {
	SetByteArrayFromAny(NULL, objPtr);
    }

385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
 * Side effects:
 *	A ByteArray object is stored as the internal rep of objPtr.
 *
 *----------------------------------------------------------------------
 */

static int
SetByteArrayFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Not used. */
    Tcl_Obj *objPtr;		/* The object to convert to type ByteArray. */
{
    int length;
    char *src, *srcEnd;
    unsigned char *dst;
    ByteArray *byteArrayPtr;
    Tcl_UniChar ch;
    
    if (objPtr->typePtr != &tclByteArrayType) {
	src = Tcl_GetStringFromObj(objPtr, &length);
	srcEnd = src + length;

	byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
	for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
	    src += Tcl_UtfToUniChar(src, &ch);







|
|
|






|







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
 * Side effects:
 *	A ByteArray object is stored as the internal rep of objPtr.
 *
 *----------------------------------------------------------------------
 */

static int
SetByteArrayFromAny(
    Tcl_Interp *interp,		/* Not used. */
    Tcl_Obj *objPtr)		/* The object to convert to type ByteArray. */
{
    int length;
    char *src, *srcEnd;
    unsigned char *dst;
    ByteArray *byteArrayPtr;
    Tcl_UniChar ch;

    if (objPtr->typePtr != &tclByteArrayType) {
	src = Tcl_GetStringFromObj(objPtr, &length);
	srcEnd = src + length;

	byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
	for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
	    src += Tcl_UtfToUniChar(src, &ch);
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
 *	Deallocate the storage associated with a ByteArray data object's
 *	internal representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory. 
 *
 *----------------------------------------------------------------------
 */

static void
FreeByteArrayInternalRep(objPtr)
    Tcl_Obj *objPtr;		/* Object with internal rep to free. */
{
    ckfree((char *) GET_BYTEARRAY(objPtr));
}

/*
 *----------------------------------------------------------------------
 *
 * DupByteArrayInternalRep --
 *
 *	Initialize the internal representation of a ByteArray Tcl_Obj
 *	to a copy of the internal representation of an existing ByteArray
 *	object. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

static void
DupByteArrayInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;		/* Object with internal rep to set. */
{
    int length;
    ByteArray *srcArrayPtr, *copyArrayPtr;    

    srcArrayPtr = GET_BYTEARRAY(srcPtr);
    length = srcArrayPtr->used;

    copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
    copyArrayPtr->used = length;
    copyArrayPtr->allocated = length;
    memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
	    (size_t) length);
    SET_BYTEARRAY(copyPtr, copyArrayPtr);

    copyPtr->typePtr = &tclByteArrayType;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfByteArray --
 *
 *	Update the string representation for a ByteArray data object.
 *	Note: This procedure does not invalidate an existing old string rep
 *	so storage will be lost if this has not already been done. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the ByteArray-to-string conversion.
 *
 *	The object becomes a string object -- the internal rep is
 *	discarded and the typePtr becomes NULL.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfByteArray(objPtr)
    Tcl_Obj *objPtr;		/* ByteArray object whose string rep to
				 * update. */
{
    int i, length, size;
    unsigned char *src;
    char *dst;
    ByteArray *byteArrayPtr;

    byteArrayPtr = GET_BYTEARRAY(objPtr);
    src = byteArrayPtr->bytes;
    length = byteArrayPtr->used;

    /*
     * How much space will string rep need?
     */
     
    size = length;
    for (i = 0; i < length; i++) {
	if ((src[i] == 0) || (src[i] > 127)) {
	    size++;
	}
    }








|





|
|









|
|
<











|
|
|


|



















|
|
|





|
|

|
|





|
|














|







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443

444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
 *	Deallocate the storage associated with a ByteArray data object's
 *	internal representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory.
 *
 *----------------------------------------------------------------------
 */

static void
FreeByteArrayInternalRep(
    Tcl_Obj *objPtr)		/* Object with internal rep to free. */
{
    ckfree((char *) GET_BYTEARRAY(objPtr));
}

/*
 *----------------------------------------------------------------------
 *
 * DupByteArrayInternalRep --
 *
 *	Initialize the internal representation of a ByteArray Tcl_Obj to a
 *	copy of the internal representation of an existing ByteArray object.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

static void
DupByteArrayInternalRep(
    Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr)		/* Object with internal rep to set. */
{
    int length;
    ByteArray *srcArrayPtr, *copyArrayPtr;

    srcArrayPtr = GET_BYTEARRAY(srcPtr);
    length = srcArrayPtr->used;

    copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
    copyArrayPtr->used = length;
    copyArrayPtr->allocated = length;
    memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
	    (size_t) length);
    SET_BYTEARRAY(copyPtr, copyArrayPtr);

    copyPtr->typePtr = &tclByteArrayType;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfByteArray --
 *
 *	Update the string representation for a ByteArray data object. Note:
 *	This procedure does not invalidate an existing old string rep so
 *	storage will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from the
 *	ByteArray-to-string conversion.
 *
 *	The object becomes a string object -- the internal rep is discarded
 *	and the typePtr becomes NULL.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfByteArray(
    Tcl_Obj *objPtr)		/* ByteArray object whose string rep to
				 * update. */
{
    int i, length, size;
    unsigned char *src;
    char *dst;
    ByteArray *byteArrayPtr;

    byteArrayPtr = GET_BYTEARRAY(objPtr);
    src = byteArrayPtr->bytes;
    length = byteArrayPtr->used;

    /*
     * How much space will string rep need?
     */

    size = length;
    for (i = 0; i < length; i++) {
	if ((src[i] == 0) || (src[i] > 127)) {
	    size++;
	}
    }

557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704

705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096











1097


1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_BinaryObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    int count;			/* Count associated with current format
				 * character. */
    char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
    char *errorString, *errorValue, *str;
    int offset, size, length, index;
    static CONST char *options[] = { 
	"format",	"scan",		NULL 
    };
    enum options { 
	BINARY_FORMAT,	BINARY_SCAN
    };

    if (objc < 2) {
    	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
    	return TCL_ERROR;
    }

    switch ((enum options) index) {
	case BINARY_FORMAT: {
	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
		return TCL_ERROR;
	    }

	    /*
	     * To avoid copying the data, we format the string in two passes.
	     * The first pass computes the size of the output buffer.  The
	     * second pass places the formatted data into the buffer.
	     */

	    format = Tcl_GetString(objv[2]);
	    arg = 3;
	    offset = 0;
	    length = 0;
	    while (*format != '\0') {
		str = format;
		if (!GetFormatSpec(&format, &cmd, &count)) {
		    break;
		}
		switch (cmd) {
		    case 'a':
		    case 'A':
		    case 'b':
		    case 'B':
		    case 'h':
		    case 'H': {
			/*
			 * For string-type specifiers, the count corresponds
			 * to the number of bytes in a single argument.
			 */

			if (arg >= objc) {
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    Tcl_GetByteArrayFromObj(objv[arg], &count);
			} else if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			arg++;
			if (cmd == 'a' || cmd == 'A') {
			    offset += count;
			} else if (cmd == 'b' || cmd == 'B') {
			    offset += (count + 7) / 8;
			} else {
			    offset += (count + 1) / 2;
			}
			break;
		    }
		    case 'c': {
			size = 1;
			goto doNumbers;
		    }
		    case 't':
		    case 's':
		    case 'S': {
			size = 2;
			goto doNumbers;
		    }
		    case 'n':
		    case 'i':
		    case 'I': {
			size = 4;
			goto doNumbers;
		    }
		    case 'm':
		    case 'w':
		    case 'W': {
			size = 8;
			goto doNumbers;
		    }
		    case 'r':
		    case 'R':
		    case 'f': {
			size = sizeof(float);
			goto doNumbers;
		    }
		    case 'q':
		    case 'Q':
		    case 'd': {
			size = sizeof(double);
			
			doNumbers:
			if (arg >= objc) {
			    goto badIndex;
			}

			/*
			 * For number-type specifiers, the count corresponds
			 * to the number of elements in the list stored in
			 * a single argument.  If no count is specified, then
			 * the argument is taken as a single non-list value.
			 */

			if (count == BINARY_NOCOUNT) {
			    arg++;
			    count = 1;
			} else {
			    int listc;
			    Tcl_Obj **listv;

			    if (Tcl_ListObjGetElements(interp, objv[arg++],
				    &listc, &listv) != TCL_OK) {
				return TCL_ERROR;
			    }
			    if (count == BINARY_ALL) {
				count = listc;
			    } else if (count > listc) {
				Tcl_AppendResult(interp, 
					"number of elements in list does not match count",
					(char *) NULL);
				return TCL_ERROR;
			    }
			}
			offset += count*size;
			break;
		    }
		    case 'x': {
			if (count == BINARY_ALL) {
			    Tcl_AppendResult(interp, 
				    "cannot use \"*\" in format string with \"x\"",
				    (char *) NULL);
			    return TCL_ERROR;
			} else if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			offset += count;
			break;
		    }
		    case 'X': {
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if ((count > offset) || (count == BINARY_ALL)) {
			    count = offset;
			}
			if (offset > length) {
			    length = offset;
			}
			offset -= count;
			break;
		    }
		    case '@': {
			if (offset > length) {
			    length = offset;
			}
			if (count == BINARY_ALL) {
			    offset = length;
			} else if (count == BINARY_NOCOUNT) {
			    goto badCount;
			} else {
			    offset = count;
			}
			break;
		    }
		    default: {
			errorString = str;
			goto badField;
		    }
		}
	    }
	    if (offset > length) {
		length = offset;
	    }
	    if (length == 0) {
		return TCL_OK;
	    }

	    /*
	     * Prepare the result object by preallocating the caclulated
	     * number of bytes and filling with nulls.
	     */

	    resultPtr = Tcl_NewObj();
	    buffer = Tcl_SetByteArrayLength(resultPtr, length);
	    memset((VOID *) buffer, 0, (size_t) length);

	    /*
	     * Pack the data into the result object.  Note that we can skip
	     * the error checking during this pass, since we have already
	     * parsed the string once.
	     */

	    arg = 3;
	    format = Tcl_GetString(objv[2]);
	    cursor = buffer;
	    maxPos = cursor;
	    while (*format != 0) {
		if (!GetFormatSpec(&format, &cmd, &count)) {
		    break;
		}
		if ((count == 0) && (cmd != '@')) {
		    arg++;
		    continue;
		}
		switch (cmd) {
		    case 'a':
		    case 'A': {
			char pad = (char) (cmd == 'a' ? '\0' : ' ');
			unsigned char *bytes;

			bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);

			if (count == BINARY_ALL) {
			    count = length;
			} else if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if (length >= count) {
			    memcpy((VOID *) cursor, (VOID *) bytes,
				    (size_t) count);
			} else {
			    memcpy((VOID *) cursor, (VOID *) bytes,
				    (size_t) length);
			    memset((VOID *) (cursor + length), pad,
				    (size_t) (count - length));
			}
			cursor += count;
			break;
		    }
		    case 'b':
		    case 'B': {
			unsigned char *last;
			
			str = Tcl_GetStringFromObj(objv[arg++], &length);
			if (count == BINARY_ALL) {
			    count = length;
			} else if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			last = cursor + ((count + 7) / 8);
			if (count > length) {
			    count = length;
			}
			value = 0;
			errorString = "binary";
			if (cmd == 'B') {
			    for (offset = 0; offset < count; offset++) {
				value <<= 1;
				if (str[offset] == '1') {
				    value |= 1;
				} else if (str[offset] != '0') {
				    errorValue = str;
				    goto badValue;
				}
				if (((offset + 1) % 8) == 0) {
				    *cursor++ = (unsigned char) value;
				    value = 0;
				}
			    }
			} else {
			    for (offset = 0; offset < count; offset++) {
				value >>= 1;
				if (str[offset] == '1') {
				    value |= 128;
				} else if (str[offset] != '0') {
				    errorValue = str;
				    goto badValue;
				}
				if (!((offset + 1) % 8)) {
				    *cursor++ = (unsigned char) value;
				    value = 0;
				}
			    }
			}
			if ((offset % 8) != 0) {
			    if (cmd == 'B') {
				value <<= 8 - (offset % 8);
			    } else {
				value >>= 8 - (offset % 8);
			    }
			    *cursor++ = (unsigned char) value;
			}
			while (cursor < last) {
			    *cursor++ = '\0';
			}
			break;
		    }
		    case 'h':
		    case 'H': {
			unsigned char *last;
			int c;
			
			str = Tcl_GetStringFromObj(objv[arg++], &length);
			if (count == BINARY_ALL) {
			    count = length;
			} else if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			last = cursor + ((count + 1) / 2);
			if (count > length) {
			    count = length;
			}
			value = 0;
			errorString = "hexadecimal";
			if (cmd == 'H') {
			    for (offset = 0; offset < count; offset++) {
				value <<= 4;
				if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
				    errorValue = str;
				    goto badValue;
				}
				c = str[offset] - '0';
				if (c > 9) {
				    c += ('0' - 'A') + 10;
				}
				if (c > 16) {
				    c += ('A' - 'a');
				}
				value |= (c & 0xf);
				if (offset % 2) {
				    *cursor++ = (char) value;
				    value = 0;
				}
			    }
			} else {
			    for (offset = 0; offset < count; offset++) {
				value >>= 4;

				if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
				    errorValue = str;
				    goto badValue;
				}
				c = str[offset] - '0';
				if (c > 9) {
				    c += ('0' - 'A') + 10;
				}
				if (c > 16) {
				    c += ('A' - 'a');
				}
				value |= ((c << 4) & 0xf0);
				if (offset % 2) {
				    *cursor++ = (unsigned char)(value & 0xff);
				    value = 0;
				}
			    }
			}
			if (offset % 2) {
			    if (cmd == 'H') {
				value <<= 4;
			    } else {
				value >>= 4;
			    }
			    *cursor++ = (unsigned char) value;
			}

			while (cursor < last) {
			    *cursor++ = '\0';
			}
			break;
		    }
		    case 'c':
		    case 't':
		    case 's':
		    case 'S':
		    case 'n':
		    case 'i':
		    case 'I':
		    case 'm':
		    case 'w':
		    case 'W':
		    case 'r':
		    case 'R':
		    case 'd':
		    case 'q':
		    case 'Q':
		    case 'f': {
			int listc, i;
			Tcl_Obj **listv;

			if (count == BINARY_NOCOUNT) {
			    /*
			     * Note that we are casting away the const-ness of
			     * objv, but this is safe since we aren't going to
			     * modify the array.
			     */

			    listv = (Tcl_Obj**)(objv + arg);
			    listc = 1;
			    count = 1;
			} else {
			    Tcl_ListObjGetElements(interp, objv[arg],
				    &listc, &listv);
			    if (count == BINARY_ALL) {
				count = listc;
			    }
			}
			arg++;
			for (i = 0; i < count; i++) {
			    if (FormatNumber(interp, cmd, listv[i], &cursor)
				    != TCL_OK) {
				return TCL_ERROR;
			    }
			}
			break;
		    }
		    case 'x': {
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			memset(cursor, 0, (size_t) count);
			cursor += count;
			break;
		    }
		    case 'X': {
			if (cursor > maxPos) {
			    maxPos = cursor;
			}
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if ((count == BINARY_ALL)
				|| (count > (cursor - buffer))) {
			    cursor = buffer;
			} else {
			    cursor -= count;
			}
			break;
		    }
		    case '@': {
			if (cursor > maxPos) {
			    maxPos = cursor;
			}
			if (count == BINARY_ALL) {
			    cursor = maxPos;
			} else {
			    cursor = buffer + count;
			}
			break;
		    }
		}
	    }
	    Tcl_SetObjResult(interp, resultPtr);
	    break;
	}
	case BINARY_SCAN: {
	    int i;
	    Tcl_Obj *valuePtr, *elementPtr;
	    Tcl_HashTable numberCacheHash;
	    Tcl_HashTable *numberCachePtr;

	    if (objc < 4) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"value formatString ?varName varName ...?");
		return TCL_ERROR;
	    }
	    numberCachePtr = &numberCacheHash;
	    Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
	    buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
	    format = Tcl_GetString(objv[3]);
	    cursor = buffer;
	    arg = 4;
	    offset = 0;
	    while (*format != '\0') {
		str = format;
		if (!GetFormatSpec(&format, &cmd, &count)) {
		    goto done;
		}
		switch (cmd) {
		    case 'a':
		    case 'A': {
			unsigned char *src;

			if (arg >= objc) {
			    DeleteScanNumberCache(numberCachePtr);
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = length - offset;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;
			    }
			    if (count > (length - offset)) {
				goto done;
			    }
			}

			src = buffer + offset;
			size = count;

			/*
			 * Trim trailing nulls and spaces, if necessary.
			 */

			if (cmd == 'A') {
			    while (size > 0) {
				if (src[size-1] != '\0' && src[size-1] != ' ') {
				    break;
				}
				size--;
			    }
			}











			valuePtr = Tcl_NewByteArrayObj(src, size);


			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    DeleteScanNumberCache(numberCachePtr);
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += count;
			break;
		    }
		    case 'b':
		    case 'B': {
			unsigned char *src;
			char *dest;

			if (arg >= objc) {
			    DeleteScanNumberCache(numberCachePtr);
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = (length - offset) * 8;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;
			    }
			    if (count > (length - offset) * 8) {
				goto done;
			    }
			}
			src = buffer + offset;
			valuePtr = Tcl_NewObj();
			Tcl_SetObjLength(valuePtr, count);
			dest = Tcl_GetString(valuePtr);

			if (cmd == 'b') {
			    for (i = 0; i < count; i++) {
				if (i % 8) {
				    value >>= 1;
				} else {
				    value = *src++;
				}
				*dest++ = (char) ((value & 1) ? '1' : '0');
			    }
			} else {
			    for (i = 0; i < count; i++) {
				if (i % 8) {
				    value <<= 1;
				} else {
				    value = *src++;
				}
				*dest++ = (char) ((value & 0x80) ? '1' : '0');
			    }
			}
			
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    DeleteScanNumberCache(numberCachePtr);
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += (count + 7 ) / 8;
			break;
		    }
		    case 'h':
		    case 'H': {
			char *dest;
			unsigned char *src;
			int i;
			static char hexdigit[] = "0123456789abcdef";

			if (arg >= objc) {
			    DeleteScanNumberCache(numberCachePtr);
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = (length - offset)*2;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;
			    }
			    if (count > (length - offset)*2) {
				goto done;
			    }
			}
			src = buffer + offset;
			valuePtr = Tcl_NewObj();
			Tcl_SetObjLength(valuePtr, count);
			dest = Tcl_GetString(valuePtr);

			if (cmd == 'h') {
			    for (i = 0; i < count; i++) {
				if (i % 2) {
				    value >>= 4;
				} else {
				    value = *src++;
				}
				*dest++ = hexdigit[value & 0xf];
			    }
			} else {
			    for (i = 0; i < count; i++) {
				if (i % 2) {
				    value <<= 4;
				} else {
				    value = *src++;
				}
				*dest++ = hexdigit[(value >> 4) & 0xf];
			    }
			}
			
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    DeleteScanNumberCache(numberCachePtr);
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += (count + 1) / 2;
			break;
		    }
		    case 'c': {
			size = 1;
			goto scanNumber;
		    }
		    case 't':
		    case 's':
		    case 'S': {
			size = 2;
			goto scanNumber;
		    }
		    case 'n':
		    case 'i':
		    case 'I': {
			size = 4;
			goto scanNumber;
		    }
		    case 'm':
		    case 'w':
		    case 'W': {
			size = 8;
			goto scanNumber;
		    }
		    case 'r':
		    case 'R':
		    case 'f': {
			size = sizeof(float);
			goto scanNumber;
		    }
		    case 'q':
		    case 'Q':
		    case 'd': {
			unsigned char *src;

			size = sizeof(double);
			/* fall through */
			
			scanNumber:
			if (arg >= objc) {
			    DeleteScanNumberCache(numberCachePtr);
			    goto badIndex;
			}
			if (count == BINARY_NOCOUNT) {
			    if ((length - offset) < size) {
				goto done;
			    }
			    valuePtr = ScanNumber(buffer+offset, cmd,
				    &numberCachePtr);
			    offset += size;
			} else {
			    if (count == BINARY_ALL) {
				count = (length - offset) / size;
			    }
			    if ((length - offset) < (count * size)) {
				goto done;
			    }
			    valuePtr = Tcl_NewObj();
			    src = buffer+offset;
			    for (i = 0; i < count; i++) {
				elementPtr = ScanNumber(src, cmd,
					&numberCachePtr);
				src += size;
				Tcl_ListObjAppendElement(NULL, valuePtr,
					elementPtr);
			    }
			    offset += count*size;
			}

			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    DeleteScanNumberCache(numberCachePtr);
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			break;
		    }
		    case 'x': {
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if ((count == BINARY_ALL)
				|| (count > (length - offset))) {
			    offset = length;
			} else {
			    offset += count;
			}
			break;
		    }
		    case 'X': {
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if ((count == BINARY_ALL) || (count > offset)) {
			    offset = 0;
			} else {
			    offset -= count;
			}
			break;
		    }
		    case '@': {
			if (count == BINARY_NOCOUNT) {
			    DeleteScanNumberCache(numberCachePtr);
			    goto badCount;
			}
			if ((count == BINARY_ALL) || (count > length)) {
			    offset = length;
			} else {
			    offset = count;
			}
			break;
		    }
		    default: {
			DeleteScanNumberCache(numberCachePtr);
			errorString = str;
			goto badField;
		    }
		}
	    }

	    /*
	     * Set the result to the last position of the cursor.
	     */

	    done:
	    Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4));
	    DeleteScanNumberCache(numberCachePtr);
	    break;
	}
    }
    return TCL_OK;

    badValue:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "expected ", errorString,
	    " string but got \"", errorValue, "\" instead", NULL);
    return TCL_ERROR;

    badCount:
    errorString = "missing count for \"@\" field specifier";
    goto error;

    badIndex:
    errorString = "not enough arguments for all format specifiers";
    goto error;

    badField:
    {
	Tcl_UniChar ch;
	char buf[TCL_UTF_MAX + 1];

	Tcl_UtfToUniChar(errorString, &ch);
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
	return TCL_ERROR;
    }

    error:
    Tcl_AppendResult(interp, errorString, NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetFormatSpec --
 *
 *	This function parses the format strings used in the binary
 *	format and scan commands.
 *
 * Results:
 *	Moves the formatPtr to the start of the next command. Returns
 *	the current command character and count in cmdPtr and countPtr.
 *	The count is set to BINARY_ALL if the count character was '*'
 *	or BINARY_NOCOUNT if no count was specified.  Returns 1 on
 *	success, or 0 if the string did not have a format specifier.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetFormatSpec(formatPtr, cmdPtr, countPtr)
    char **formatPtr;		/* Pointer to format string. */
    char *cmdPtr;		/* Pointer to location of command char. */
    int *countPtr;		/* Pointer to repeat count value. */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;







|
|
|
|
|
















|
|

|














|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
|

|
|
|
|

|
|
|

|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|

|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
<
|
|

|
|
|

|
|
|
|
|



|





|



|



|










|









|
|


|
|
|
|
|








|
|
|
|







547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642

643
644
645

646
647
648
649
650

651
652
653
654
655

656
657
658
659
660

661
662
663
664
665

666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716

717
718
719
720
721
722
723
724
725
726
727
728

729
730
731
732
733
734
735
736
737
738
739
740

741
742
743
744
745

746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794

795
796

797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964

965
966
967
968
969
970
971

972
973
974
975
976
977
978
979
980
981
982
983

984
985
986
987
988
989
990
991

992
993
994
995
996

997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008

1009
1010

1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208

1209
1210
1211
1212
1213

1214
1215
1216
1217
1218

1219
1220
1221
1222
1223

1224
1225
1226
1227
1228

1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246

1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258

1259
1260

1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279

1280
1281
1282
1283
1284

1285
1286
1287
1288
1289
1290
1291
1292
1293
1294

1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305

1306
1307
1308
1309

1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_BinaryObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[])	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    int count;			/* Count associated with current format
				 * character. */
    char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
    char *errorString, *errorValue, *str;
    int offset, size, length, index;
    static CONST char *options[] = {
	"format",	"scan",		NULL
    };
    enum options {
	BINARY_FORMAT,	BINARY_SCAN
    };

    if (objc < 2) {
    	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
    	return TCL_ERROR;
    }

    switch ((enum options) index) {
    case BINARY_FORMAT:
	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
	    return TCL_ERROR;
	}

	/*
	 * To avoid copying the data, we format the string in two passes. The
	 * first pass computes the size of the output buffer. The second pass
	 * places the formatted data into the buffer.
	 */

	format = Tcl_GetString(objv[2]);
	arg = 3;
	offset = 0;
	length = 0;
	while (*format != '\0') {
	    str = format;
	    if (!GetFormatSpec(&format, &cmd, &count)) {
		break;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A':
	    case 'b':
	    case 'B':
	    case 'h':
	    case 'H':
		/*
		 * For string-type specifiers, the count corresponds to the
		 * number of bytes in a single argument.
		 */

		if (arg >= objc) {
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    Tcl_GetByteArrayFromObj(objv[arg], &count);
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		arg++;
		if (cmd == 'a' || cmd == 'A') {
		    offset += count;
		} else if (cmd == 'b' || cmd == 'B') {
		    offset += (count + 7) / 8;
		} else {
		    offset += (count + 1) / 2;
		}
		break;

	    case 'c':
		size = 1;
		goto doNumbers;

	    case 't':
	    case 's':
	    case 'S':
		size = 2;
		goto doNumbers;

	    case 'n':
	    case 'i':
	    case 'I':
		size = 4;
		goto doNumbers;

	    case 'm':
	    case 'w':
	    case 'W':
		size = 8;
		goto doNumbers;

	    case 'r':
	    case 'R':
	    case 'f':
		size = sizeof(float);
		goto doNumbers;

	    case 'q':
	    case 'Q':
	    case 'd':
		size = sizeof(double);

	    doNumbers:
		if (arg >= objc) {
		    goto badIndex;
		}

		/*
		 * For number-type specifiers, the count corresponds to the
		 * number of elements in the list stored in a single argument.
		 * If no count is specified, then the argument is taken as a
		 * single non-list value.
		 */

		if (count == BINARY_NOCOUNT) {
		    arg++;
		    count = 1;
		} else {
		    int listc;
		    Tcl_Obj **listv;

		    if (Tcl_ListObjGetElements(interp, objv[arg++], &listc,
			    &listv) != TCL_OK) {
			return TCL_ERROR;
		    }
		    if (count == BINARY_ALL) {
			count = listc;
		    } else if (count > listc) {
			Tcl_AppendResult(interp,
				"number of elements in list does not match count",
				(char *) NULL);
			return TCL_ERROR;
		    }
		}
		offset += count*size;
		break;

	    case 'x':
		if (count == BINARY_ALL) {
		    Tcl_AppendResult(interp,
			    "cannot use \"*\" in format string with \"x\"",
			    (char *) NULL);
		    return TCL_ERROR;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		offset += count;
		break;

	    case 'X':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count > offset) || (count == BINARY_ALL)) {
		    count = offset;
		}
		if (offset > length) {
		    length = offset;
		}
		offset -= count;
		break;

	    case '@':
		if (offset > length) {
		    length = offset;
		}
		if (count == BINARY_ALL) {
		    offset = length;
		} else if (count == BINARY_NOCOUNT) {
		    goto badCount;
		} else {
		    offset = count;
		}
		break;

	    default:
		errorString = str;
		goto badField;
	    }
	}

	if (offset > length) {
	    length = offset;
	}
	if (length == 0) {
	    return TCL_OK;
	}

	/*
	 * Prepare the result object by preallocating the caclulated number of
	 * bytes and filling with nulls.
	 */

	resultPtr = Tcl_NewObj();
	buffer = Tcl_SetByteArrayLength(resultPtr, length);
	memset((VOID *) buffer, 0, (size_t) length);

	/*
	 * Pack the data into the result object. Note that we can skip the
	 * error checking during this pass, since we have already parsed the
	 * string once.
	 */

	arg = 3;
	format = Tcl_GetString(objv[2]);
	cursor = buffer;
	maxPos = cursor;
	while (*format != 0) {
	    if (!GetFormatSpec(&format, &cmd, &count)) {
		break;
	    }
	    if ((count == 0) && (cmd != '@')) {
		arg++;
		continue;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A': {
		char pad = (char) (cmd == 'a' ? '\0' : ' ');
		unsigned char *bytes;

		bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);

		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (length >= count) {
		    memcpy((VOID *) cursor, (VOID *) bytes, (size_t) count);

		} else {
		    memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length);

		    memset((VOID *) (cursor + length), pad,
			    (size_t) (count - length));
		}
		cursor += count;
		break;
	    }
	    case 'b':
	    case 'B': {
		unsigned char *last;

		str = Tcl_GetStringFromObj(objv[arg++], &length);
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		last = cursor + ((count + 7) / 8);
		if (count > length) {
		    count = length;
		}
		value = 0;
		errorString = "binary";
		if (cmd == 'B') {
		    for (offset = 0; offset < count; offset++) {
			value <<= 1;
			if (str[offset] == '1') {
			    value |= 1;
			} else if (str[offset] != '0') {
			    errorValue = str;
			    goto badValue;
			}
			if (((offset + 1) % 8) == 0) {
			    *cursor++ = (unsigned char) value;
			    value = 0;
			}
		    }
		} else {
		    for (offset = 0; offset < count; offset++) {
			value >>= 1;
			if (str[offset] == '1') {
			    value |= 128;
			} else if (str[offset] != '0') {
			    errorValue = str;
			    goto badValue;
			}
			if (!((offset + 1) % 8)) {
			    *cursor++ = (unsigned char) value;
			    value = 0;
			}
		    }
		}
		if ((offset % 8) != 0) {
		    if (cmd == 'B') {
			value <<= 8 - (offset % 8);
		    } else {
			value >>= 8 - (offset % 8);
		    }
		    *cursor++ = (unsigned char) value;
		}
		while (cursor < last) {
		    *cursor++ = '\0';
		}
		break;
	    }
	    case 'h':
	    case 'H': {
		unsigned char *last;
		int c;

		str = Tcl_GetStringFromObj(objv[arg++], &length);
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		last = cursor + ((count + 1) / 2);
		if (count > length) {
		    count = length;
		}
		value = 0;
		errorString = "hexadecimal";
		if (cmd == 'H') {
		    for (offset = 0; offset < count; offset++) {
			value <<= 4;
			if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
			    errorValue = str;
			    goto badValue;
			}
			c = str[offset] - '0';
			if (c > 9) {
			    c += ('0' - 'A') + 10;
			}
			if (c > 16) {
			    c += ('A' - 'a');
			}
			value |= (c & 0xf);
			if (offset % 2) {
			    *cursor++ = (char) value;
			    value = 0;
			}
		    }
		} else {
		    for (offset = 0; offset < count; offset++) {
			value >>= 4;

			if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
			    errorValue = str;
			    goto badValue;
			}
			c = str[offset] - '0';
			if (c > 9) {
			    c += ('0' - 'A') + 10;
			}
			if (c > 16) {
			    c += ('A' - 'a');
			}
			value |= ((c << 4) & 0xf0);
			if (offset % 2) {
			    *cursor++ = (unsigned char)(value & 0xff);
			    value = 0;
			}
		    }
		}
		if (offset % 2) {
		    if (cmd == 'H') {
			value <<= 4;
		    } else {
			value >>= 4;
		    }
		    *cursor++ = (unsigned char) value;
		}

		while (cursor < last) {
		    *cursor++ = '\0';
		}
		break;
	    }
	    case 'c':
	    case 't':
	    case 's':
	    case 'S':
	    case 'n':
	    case 'i':
	    case 'I':
	    case 'm':
	    case 'w':
	    case 'W':
	    case 'r':
	    case 'R':
	    case 'd':
	    case 'q':
	    case 'Q':
	    case 'f': {
		int listc, i;
		Tcl_Obj **listv;

		if (count == BINARY_NOCOUNT) {
		    /*
		     * Note that we are casting away the const-ness of objv,
		     * but this is safe since we aren't going to modify the
		     * array.
		     */

		    listv = (Tcl_Obj**)(objv + arg);
		    listc = 1;
		    count = 1;
		} else {
		    Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv);

		    if (count == BINARY_ALL) {
			count = listc;
		    }
		}
		arg++;
		for (i = 0; i < count; i++) {
		    if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {

			return TCL_ERROR;
		    }
		}
		break;
	    }
	    case 'x':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		memset(cursor, 0, (size_t) count);
		cursor += count;
		break;

	    case 'X':
		if (cursor > maxPos) {
		    maxPos = cursor;
		}
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count == BINARY_ALL) || (count > (cursor - buffer))) {

		    cursor = buffer;
		} else {
		    cursor -= count;
		}
		break;

	    case '@':
		if (cursor > maxPos) {
		    maxPos = cursor;
		}
		if (count == BINARY_ALL) {
		    cursor = maxPos;
		} else {
		    cursor = buffer + count;
		}
		break;
	    }
	}

	Tcl_SetObjResult(interp, resultPtr);
	break;

    case BINARY_SCAN: {
	int i;
	Tcl_Obj *valuePtr, *elementPtr;
	Tcl_HashTable numberCacheHash;
	Tcl_HashTable *numberCachePtr;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "value formatString ?varName varName ...?");
	    return TCL_ERROR;
	}
	numberCachePtr = &numberCacheHash;
	Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
	buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
	format = Tcl_GetString(objv[3]);
	cursor = buffer;
	arg = 4;
	offset = 0;
	while (*format != '\0') {
	    str = format;
	    if (!GetFormatSpec(&format, &cmd, &count)) {
		goto done;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A': {
		unsigned char *src;

		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = length - offset;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset)) {
			goto done;
		    }
		}

		src = buffer + offset;
		size = count;

		/*
		 * Trim trailing nulls and spaces, if necessary.
		 */

		if (cmd == 'A') {
		    while (size > 0) {
			if (src[size-1] != '\0' && src[size-1] != ' ') {
			    break;
			}
			size--;
		    }
		}

		/*
		 * Have to do this #ifdef-fery because (as part of defining
		 * Tcl_NewByteArrayObj) we removed the #def that hides this
		 * stuff normally. If this code ever gets copied to another
		 * file, it should be changed back to the simpler version.
		 */

#ifdef TCL_MEM_DEBUG
		valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
#else
		valuePtr = Tcl_NewByteArrayObj(src, size);
#endif /* TCL_MEM_DEBUG */

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    Tcl_DecrRefCount(valuePtr);	/* unneeded */
		    return TCL_ERROR;
		}
		offset += count;
		break;
	    }
	    case 'b':
	    case 'B': {
		unsigned char *src;
		char *dest;

		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = (length - offset) * 8;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset) * 8) {
			goto done;
		    }
		}
		src = buffer + offset;
		valuePtr = Tcl_NewObj();
		Tcl_SetObjLength(valuePtr, count);
		dest = Tcl_GetString(valuePtr);

		if (cmd == 'b') {
		    for (i = 0; i < count; i++) {
			if (i % 8) {
			    value >>= 1;
			} else {
			    value = *src++;
			}
			*dest++ = (char) ((value & 1) ? '1' : '0');
		    }
		} else {
		    for (i = 0; i < count; i++) {
			if (i % 8) {
			    value <<= 1;
			} else {
			    value = *src++;
			}
			*dest++ = (char) ((value & 0x80) ? '1' : '0');
		    }
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    Tcl_DecrRefCount(valuePtr);	/* unneeded */
		    return TCL_ERROR;
		}
		offset += (count + 7 ) / 8;
		break;
	    }
	    case 'h':
	    case 'H': {
		char *dest;
		unsigned char *src;
		int i;
		static CONST char hexdigit[] = "0123456789abcdef";

		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = (length - offset)*2;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset)*2) {
			goto done;
		    }
		}
		src = buffer + offset;
		valuePtr = Tcl_NewObj();
		Tcl_SetObjLength(valuePtr, count);
		dest = Tcl_GetString(valuePtr);

		if (cmd == 'h') {
		    for (i = 0; i < count; i++) {
			if (i % 2) {
			    value >>= 4;
			} else {
			    value = *src++;
			}
			*dest++ = hexdigit[value & 0xf];
		    }
		} else {
		    for (i = 0; i < count; i++) {
			if (i % 2) {
			    value <<= 4;
			} else {
			    value = *src++;
			}
			*dest++ = hexdigit[(value >> 4) & 0xf];
		    }
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    Tcl_DecrRefCount(valuePtr);	/* unneeded */
		    return TCL_ERROR;
		}
		offset += (count + 1) / 2;
		break;
	    }
	    case 'c':
		size = 1;
		goto scanNumber;

	    case 't':
	    case 's':
	    case 'S':
		size = 2;
		goto scanNumber;

	    case 'n':
	    case 'i':
	    case 'I':
		size = 4;
		goto scanNumber;

	    case 'm':
	    case 'w':
	    case 'W':
		size = 8;
		goto scanNumber;

	    case 'r':
	    case 'R':
	    case 'f':
		size = sizeof(float);
		goto scanNumber;

	    case 'q':
	    case 'Q':
	    case 'd': {
		unsigned char *src;

		size = sizeof(double);
		/* fall through */

	    scanNumber:
		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_NOCOUNT) {
		    if ((length - offset) < size) {
			goto done;
		    }
		    valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr);

		    offset += size;
		} else {
		    if (count == BINARY_ALL) {
			count = (length - offset) / size;
		    }
		    if ((length - offset) < (count * size)) {
			goto done;
		    }
		    valuePtr = Tcl_NewObj();
		    src = buffer+offset;
		    for (i = 0; i < count; i++) {
			elementPtr = ScanNumber(src, cmd, &numberCachePtr);

			src += size;
			Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);

		    }
		    offset += count*size;
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
			TCL_LEAVE_ERR_MSG);
		arg++;
		if (resultPtr == NULL) {
		    DeleteScanNumberCache(numberCachePtr);
		    Tcl_DecrRefCount(valuePtr);	/* unneeded */
		    return TCL_ERROR;
		}
		break;
	    }
	    case 'x':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count == BINARY_ALL) || (count > (length - offset))) {

		    offset = length;
		} else {
		    offset += count;
		}
		break;

	    case 'X':
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if ((count == BINARY_ALL) || (count > offset)) {
		    offset = 0;
		} else {
		    offset -= count;
		}
		break;

	    case '@':
		if (count == BINARY_NOCOUNT) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badCount;
		}
		if ((count == BINARY_ALL) || (count > length)) {
		    offset = length;
		} else {
		    offset = count;
		}
		break;

	    default:
		DeleteScanNumberCache(numberCachePtr);
		errorString = str;
		goto badField;

	    }
	}

	/*
	 * Set the result to the last position of the cursor.
	 */

    done:
	Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4));
	DeleteScanNumberCache(numberCachePtr);
	break;
    }
    }
    return TCL_OK;

  badValue:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "expected ", errorString,
	    " string but got \"", errorValue, "\" instead", NULL);
    return TCL_ERROR;

  badCount:
    errorString = "missing count for \"@\" field specifier";
    goto error;

  badIndex:
    errorString = "not enough arguments for all format specifiers";
    goto error;

  badField:
    {
	Tcl_UniChar ch;
	char buf[TCL_UTF_MAX + 1];

	Tcl_UtfToUniChar(errorString, &ch);
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
	return TCL_ERROR;
    }

  error:
    Tcl_AppendResult(interp, errorString, NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetFormatSpec --
 *
 *	This function parses the format strings used in the binary format and
 *	scan commands.
 *
 * Results:
 *	Moves the formatPtr to the start of the next command. Returns the
 *	current command character and count in cmdPtr and countPtr. The count
 *	is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT
 *	if no count was specified. Returns 1 on success, or 0 if the string
 *	did not have a format specifier.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetFormatSpec(
    char **formatPtr,		/* Pointer to format string. */
    char *cmdPtr,		/* Pointer to location of command char. */
    int *countPtr)		/* Pointer to repeat count value. */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
}

/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *
 *	This routine determines, if bytes of a number need to be
 *	reversed.  This depends on the endiannes of the machine and
 *	the desired format.  It is in effect a table (whose contents
 *	depend on the endianness of the system) describing whether a
 *	value needs reversing or not.  Anyone porting the code to a
 *	big-endian platform should take care to make sure that they
 *	define WORDS_BIGENDIAN though this is already done by
 *	configure for the Unix build; little-endian platforms
 *	(including Windows) don't need to do anything.
 *
 * Results:
 *	1 if reversion is required, 0 if not.
 *
 * Side effects:
 *	None
 *   
 *----------------------------------------------------------------------
 */

static int 
NeedReversing(format)
    int format;
{
    switch (format) {
	/* native floats and doubles: never reverse */
    case 'd':
    case 'f':
	/* big endian ints: never reverse */
    case 'I':







|
|
|
|
<
|
|
|
|






|



|
|
|







1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423

1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
}

/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *
 *	This routine determines, if bytes of a number need to be reversed.
 *	This depends on the endiannes of the machine and the desired format.
 *	It is in effect a table (whose contents depend on the endianness of
 *	the system) describing whether a value needs reversing or not. Anyone

 *	porting the code to a big-endian platform should take care to make
 *	sure that they define WORDS_BIGENDIAN though this is already done by
 *	configure for the Unix build; little-endian platforms (including
 *	Windows) don't need to do anything.
 *
 * Results:
 *	1 if reversion is required, 0 if not.
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static int
NeedReversing(
    int format)
{
    switch (format) {
	/* native floats and doubles: never reverse */
    case 'd':
    case 'f':
	/* big endian ints: never reverse */
    case 'I':
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
}

/*
 *----------------------------------------------------------------------
 *
 * CopyNumber --
 *
 *	This routine is called by FormatNumber and ScanNumber to copy
 *	a floating-point number.  If required, bytes are reversed
 *	while copying.  The behaviour is only fully defined when used
 *	with IEEE float and double values (guaranteed to be 4 and 8
 *	bytes long, respectively.)
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Copies length bytes
 *
 *----------------------------------------------------------------------
 */

static void 
CopyNumber(from, to, length, type)
    CONST void *from;		/* source */
    void *to;			/* destination */
    unsigned int length;	/* Number of bytes to copy */
    int type;			/* What type of thing are we copying? */
{
    if (NeedReversing(type)) {
	CONST unsigned char *fromPtr = (CONST unsigned char *) from;
	unsigned char *toPtr = (unsigned char *) to;

	switch (length) {
	case 4:







|
|
|
|
<










|
|
|
|
|
|







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497

1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
}

/*
 *----------------------------------------------------------------------
 *
 * CopyNumber --
 *
 *	This routine is called by FormatNumber and ScanNumber to copy a
 *	floating-point number. If required, bytes are reversed while copying.
 *	The behaviour is only fully defined when used with IEEE float and
 *	double values (guaranteed to be 4 and 8 bytes long, respectively.)

 *
 * Results:
 *	None
 *
 * Side effects:
 *	Copies length bytes
 *
 *----------------------------------------------------------------------
 */

static void
CopyNumber(
    CONST void *from,		/* source */
    void *to,			/* destination */
    unsigned int length,	/* Number of bytes to copy */
    int type)			/* What type of thing are we copying? */
{
    if (NeedReversing(type)) {
	CONST unsigned char *fromPtr = (CONST unsigned char *) from;
	unsigned char *toPtr = (unsigned char *) to;

	switch (length) {
	case 4:
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607


1608
1609
1610

1611


1612
1613
1614
1615
1616
1617
1618
1619
1620
1621


1622
1623
1624

1625


1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
	    toPtr[4] = fromPtr[3];
	    toPtr[5] = fromPtr[2];
	    toPtr[6] = fromPtr[1];
	    toPtr[7] = fromPtr[0];
	    break;
	}
    } else {
	memcpy(to, from, length); 
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FormatNumber --
 *
 *	This routine is called by Tcl_BinaryObjCmd to format a number
 *	into a location pointed at by cursor.
 *
 * Results:
 *	 A standard Tcl result.
 *
 * Side effects:
 *	Moves the cursor to the next location to be written into.
 *
 *----------------------------------------------------------------------
 */

static int
FormatNumber(interp, type, src, cursorPtr)
    Tcl_Interp *interp;		/* Current interpreter, used to report
				 * errors. */
    int type;			/* Type of number to format. */
    Tcl_Obj *src;		/* Number to format. */
    unsigned char **cursorPtr;	/* Pointer to index into destination buffer. */
{
    long value;
    double dvalue;
    Tcl_WideInt wvalue;
    float fvalue;

    switch (type) {
    case 'd':
    case 'q':
    case 'Q':
	/*
	 * Double-precision floating point values.


	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {

	    return TCL_ERROR;


	}
	CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
	*cursorPtr += sizeof(double);
	return TCL_OK;

    case 'f':
    case 'r':
    case 'R':
	/*
	 * Single-precision floating point values.


	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {

	    return TCL_ERROR;


	}

	/*
	 * Because some compilers will generate floating point exceptions
	 * on an overflow cast (e.g. Borland), we restrict the values
	 * to the valid range for float.
	 */

	if (fabs(dvalue) > (double)FLT_MAX) {
	    fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
	} else {
	    fvalue = (float) dvalue;
	}







|








|
|


|








|
|

|
|
|











|
>
>



>
|
>
>









|
>
>



>
|
>
>



|
|
|







1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
	    toPtr[4] = fromPtr[3];
	    toPtr[5] = fromPtr[2];
	    toPtr[6] = fromPtr[1];
	    toPtr[7] = fromPtr[0];
	    break;
	}
    } else {
	memcpy(to, from, length);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FormatNumber --
 *
 *	This routine is called by Tcl_BinaryObjCmd to format a number into a
 *	location pointed at by cursor.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Moves the cursor to the next location to be written into.
 *
 *----------------------------------------------------------------------
 */

static int
FormatNumber(
    Tcl_Interp *interp,		/* Current interpreter, used to report
				 * errors. */
    int type,			/* Type of number to format. */
    Tcl_Obj *src,		/* Number to format. */
    unsigned char **cursorPtr)	/* Pointer to index into destination buffer. */
{
    long value;
    double dvalue;
    Tcl_WideInt wvalue;
    float fvalue;

    switch (type) {
    case 'd':
    case 'q':
    case 'Q':
	/*
	 * Double-precision floating point values. Tcl_GetDoubleFromObj
	 * returns TCL_ERROR for NaN, but we can check by comparing the
	 * object's type pointer.
	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
	    if ( src->typePtr != &tclDoubleType ) {
		return TCL_ERROR;
	    }
	    dvalue = src->internalRep.doubleValue;
	}
	CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
	*cursorPtr += sizeof(double);
	return TCL_OK;

    case 'f':
    case 'r':
    case 'R':
	/*
	 * Single-precision floating point values. Tcl_GetDoubleFromObj
	 * returns TCL_ERROR for NaN, but we can check by comparing the
	 * object's type pointer.
	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
	    if ( src->typePtr != &tclDoubleType ) {
		return TCL_ERROR;
	    }
	    dvalue = src->internalRep.doubleValue;
	}

	/*
	 * Because some compilers will generate floating point exceptions on
	 * an overflow cast (e.g. Borland), we restrict the values to the
	 * valid range for float.
	 */

	if (fabs(dvalue) > (double)FLT_MAX) {
	    fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
	} else {
	    fvalue = (float) dvalue;
	}
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
	 */
    case 'c':
	if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	*(*cursorPtr)++ = (unsigned char) value;
	return TCL_OK;
      
    default:
	Tcl_Panic("unexpected fallthrough");
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ScanNumber --
 *
 *	This routine is called by Tcl_BinaryObjCmd to scan a number
 *	out of a buffer.
 *
 * Results:
 *	Returns a newly created object containing the scanned number.
 *	This object has a ref count of zero.
 *
 * Side effects:
 *	Might reuse an object in the number cache, place a new object
 *	in the cache, or delete the cache and set the reference to
 *	it (itself passed in by reference) to NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ScanNumber(buffer, type, numberCachePtrPtr)
    unsigned char *buffer;	/* Buffer to scan number from. */
    int type;			/* Format character from "binary scan" */
    Tcl_HashTable **numberCachePtrPtr;
				/* Place to look for cache of scanned
				 * value objects, or NULL if too many
				 * different numbers have been scanned. */
{
    long value;
    float fvalue;
    double dvalue;
    Tcl_WideUInt uwvalue;

    /*
     * We cannot rely on the compiler to properly sign extend integer values
     * when we cast from smaller values to larger values because we don't know
     * the exact size of the integer types.  So, we have to handle sign
     * extension explicitly by checking the high bit and padding with 1's as
     * needed.
     */

    switch (type) {
    case 'c':
	/*
	 * Characters need special handling.  We want to produce a
	 * signed result, but on some platforms (such as AIX) chars
	 * are unsigned.  To deal with this, check for a value that
	 * should be negative but isn't.
	 */

	value = buffer[0];
	if (value & 0x80) {
	    value |= -0x100;
	}
	goto returnNumericObject;

	/*
	 * 16-bit numeric values.  We need the sign extension trick
	 * (see above) here as well.
	 */

    case 's':
    case 'S':
    case 't':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0] + (buffer[1] << 8));







|











|
|


|
|


|
|
|





|
|
|
|












|







|
|
|
|









|
|







1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
	 */
    case 'c':
	if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	*(*cursorPtr)++ = (unsigned char) value;
	return TCL_OK;

    default:
	Tcl_Panic("unexpected fallthrough");
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ScanNumber --
 *
 *	This routine is called by Tcl_BinaryObjCmd to scan a number out of a
 *	buffer.
 *
 * Results:
 *	Returns a newly created object containing the scanned number. This
 *	object has a ref count of zero.
 *
 * Side effects:
 *	Might reuse an object in the number cache, place a new object in the
 *	cache, or delete the cache and set the reference to it (itself passed
 *	in by reference) to NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ScanNumber(
    unsigned char *buffer,	/* Buffer to scan number from. */
    int type,			/* Format character from "binary scan" */
    Tcl_HashTable **numberCachePtrPtr)
				/* Place to look for cache of scanned
				 * value objects, or NULL if too many
				 * different numbers have been scanned. */
{
    long value;
    float fvalue;
    double dvalue;
    Tcl_WideUInt uwvalue;

    /*
     * We cannot rely on the compiler to properly sign extend integer values
     * when we cast from smaller values to larger values because we don't know
     * the exact size of the integer types. So, we have to handle sign
     * extension explicitly by checking the high bit and padding with 1's as
     * needed.
     */

    switch (type) {
    case 'c':
	/*
	 * Characters need special handling. We want to produce a signed
	 * result, but on some platforms (such as AIX) chars are unsigned. To
	 * deal with this, check for a value that should be negative but
	 * isn't.
	 */

	value = buffer[0];
	if (value & 0x80) {
	    value |= -0x100;
	}
	goto returnNumericObject;

	/*
	 * 16-bit numeric values. We need the sign extension trick (see above)
	 * here as well.
	 */

    case 's':
    case 'S':
    case 't':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0] + (buffer[1] << 8));
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
	 * 32-bit numeric values.
	 */

    case 'i':
    case 'I':
    case 'n':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0] 
		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (buffer[3] << 24));
	} else {
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)
		    + (buffer[1] << 16)
		    + (buffer[0] << 24));
	}

	/*
	 * Check to see if the value was sign extended properly on
	 * systems where an int is more than 32-bits.
	 */

	if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
	    value -= (((unsigned int)1)<<31);
	    value -= (((unsigned int)1)<<31);
	}








|











|
|







1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
	 * 32-bit numeric values.
	 */

    case 'i':
    case 'I':
    case 'n':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0]
		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (buffer[3] << 24));
	} else {
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)
		    + (buffer[1] << 16)
		    + (buffer[0] << 24));
	}

	/*
	 * Check to see if the value was sign extended properly on systems
	 * where an int is more than 32-bits.
	 */

	if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
	    value -= (((unsigned int)1)<<31);
	    value -= (((unsigned int)1)<<31);
	}

1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
	    int isNew;

	    hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
	    if (!isNew) {
		return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
	    }
	    if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {

		/*
		 * We've overflowed the cache!  Someone's parsing a
		 * LOT of varied binary data in a single call!  Bail
		 * out by switching back to the old behaviour for the
		 * rest of the scan.
		 *
		 * Note that anyone just using the 'c' conversion (for
		 * bytes) cannot trigger this.
		 */

		DeleteScanNumberCache(tablePtr);
		*numberCachePtrPtr = NULL;
		return Tcl_NewLongObj(value);
	    } else {
		register Tcl_Obj *objPtr = Tcl_NewLongObj(value);

		Tcl_IncrRefCount(objPtr);
		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
		return objPtr;
	    }
	}

	/*
	 * Do not cache wide (64-bit) values; they are already too
	 * large to use as keys.
	 */

    case 'w':
    case 'W':
    case 'm':
	if (NeedReversing(type)) {
	    uwvalue = ((Tcl_WideUInt) buffer[0])







<

|
|
|
<

|
|















|
|







1820
1821
1822
1823
1824
1825
1826

1827
1828
1829
1830

1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
	    int isNew;

	    hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
	    if (!isNew) {
		return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
	    }
	    if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {

		/*
		 * We've overflowed the cache! Someone's parsing a LOT of
		 * varied binary data in a single call! Bail out by switching
		 * back to the old behaviour for the rest of the scan.

		 *
		 * Note that anyone just using the 'c' conversion (for bytes)
		 * cannot trigger this.
		 */

		DeleteScanNumberCache(tablePtr);
		*numberCachePtrPtr = NULL;
		return Tcl_NewLongObj(value);
	    } else {
		register Tcl_Obj *objPtr = Tcl_NewLongObj(value);

		Tcl_IncrRefCount(objPtr);
		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
		return objPtr;
	    }
	}

	/*
	 * Do not cache wide (64-bit) values; they are already too large to
	 * use as keys.
	 */

    case 'w':
    case 'W':
    case 'm':
	if (NeedReversing(type)) {
	    uwvalue = ((Tcl_WideUInt) buffer[0])
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
		    | (((Tcl_WideUInt) buffer[2]) << 40)
		    | (((Tcl_WideUInt) buffer[1]) << 48)
		    | (((Tcl_WideUInt) buffer[0]) << 56);
	}
	return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);

	/*
	 * Do not cache double values; they are already too large to
	 * use as keys and the values stored are utterly incompatible
	 * with the integer part of the cache.
	 */

	/*
	 * 32-bit IEEE single-precision floating point.
	 */

    case 'f':







|
|
|







1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
		    | (((Tcl_WideUInt) buffer[2]) << 40)
		    | (((Tcl_WideUInt) buffer[1]) << 48)
		    | (((Tcl_WideUInt) buffer[0]) << 56);
	}
	return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);

	/*
	 * Do not cache double values; they are already too large to use as
	 * keys and the values stored are utterly incompatible with the
	 * integer part of the cache.
	 */

	/*
	 * 32-bit IEEE single-precision floating point.
	 */

    case 'f':
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946

1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967








    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteScanNumberCache --
 * 
 *	Deletes the hash table acting as a scan number cache.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Decrements the reference counts of the objects in the cache.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScanNumberCache(numberCachePtr)
    Tcl_HashTable *numberCachePtr;	/* Pointer to the hash table, or

					 * NULL (when the cache has already
					 * been deleted due to overflow.) */
{
    Tcl_HashEntry *hEntry;
    Tcl_HashSearch search;

    if (numberCachePtr == NULL) {
	return;
    }

    hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
    while (hEntry != NULL) {
	register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);

	if (value != NULL) {
	    Tcl_DecrRefCount(value);
	}
	hEntry = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(numberCachePtr);
}















|












|
|
>
|
|



















>
>
>
>
>
>
>
>
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteScanNumberCache --
 *
 *	Deletes the hash table acting as a scan number cache.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Decrements the reference counts of the objects in the cache.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScanNumberCache(
    Tcl_HashTable *numberCachePtr)
				/* Pointer to the hash table, or NULL (when
				 * the cache has already been deleted due to
				 * overflow.) */
{
    Tcl_HashEntry *hEntry;
    Tcl_HashSearch search;

    if (numberCachePtr == NULL) {
	return;
    }

    hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
    while (hEntry != NULL) {
	register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);

	if (value != NULL) {
	    Tcl_DecrRefCount(value);
	}
	hEntry = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(numberCachePtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCkalloc.c.

1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
/* 
 * tclCkalloc.c --
 *
 *    Interface to malloc and free that provides support for debugging problems
 *    involving overwritten, double freeing memory and loss of memory.

 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.22 2004/10/06 13:05:02 dkf Exp $
 */

#include "tclInt.h"

#define FALSE	0
#define TRUE	1

#ifdef TCL_MEM_DEBUG

/*
 * One of the following structures is allocated each time the
 * "memory tag" command is invoked, to hold the current tag.
 */

typedef struct MemTag {
    int refCount;		/* Number of mem_headers referencing
				 * this tag. */
    char string[4];		/* Actual size of string will be as
				 * large as needed for actual tag.  This
				 * must be the last field in the structure. */
} MemTag;

#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)

static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers
				 * (set by "memory tag" command). */

/*
 * One of the following structures is allocated just before each
 * dynamically allocated chunk of memory, both to record information
 * about the chunk and to help detect chunk under-runs.
 */

#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
struct mem_header {
    struct mem_header *flink;
    struct mem_header *blink;
    MemTag *tagPtr;		/* Tag from "memory tag" command;  may be
				 * NULL. */
    CONST char *file;
    long length;
    int line;
    unsigned char low_guard[LOW_GUARD_SIZE];
				/* Aligns body on 8-byte boundary, plus
				 * provides at least 8 additional guard bytes
				 * to detect underruns. */
    char body[1];		/* First byte of client's space.  Actual
				 * size of this field will be larger than
				 * one. */
};

static struct mem_header *allocHead = NULL;  /* List of allocated structures */

#define GUARD_VALUE  0141

/*
 * The following macro determines the amount of guard space *above* each
 * chunk of memory.
 */

#define HIGH_GUARD_SIZE 8

/*
 * The following macro computes the offset of the "body" field within
 * mem_header.  It is used to get back to the header pointer from the
 * body pointer that's used by clients.
 */

#define BODY_OFFSET \
	((unsigned long) (&((struct mem_header *) 0)->body))

static int total_mallocs = 0;
static int total_frees = 0;
|


|
|
>





|
|



|















|
|
|
|
|




|
|


|
|
|






|








|
|
<







|
|






|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
/*
 * tclCkalloc.c --
 *
 *    Interface to malloc and free that provides support for debugging
 *    problems involving overwritten, double freeing memory and loss of
 *    memory.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.2 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

#define FALSE	0
#define TRUE	1

#ifdef TCL_MEM_DEBUG

/*
 * One of the following structures is allocated each time the
 * "memory tag" command is invoked, to hold the current tag.
 */

typedef struct MemTag {
    int refCount;		/* Number of mem_headers referencing this
				 * tag. */
    char string[4];		/* Actual size of string will be as large as
				 * needed for actual tag.  This must be the
				 * last field in the structure. */
} MemTag;

#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)

static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
				 * by "memory tag" command). */

/*
 * One of the following structures is allocated just before each dynamically
 * allocated chunk of memory, both to record information about the chunk and
 * to help detect chunk under-runs.
 */

#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
struct mem_header {
    struct mem_header *flink;
    struct mem_header *blink;
    MemTag *tagPtr;		/* Tag from "memory tag" command; may be
				 * NULL. */
    CONST char *file;
    long length;
    int line;
    unsigned char low_guard[LOW_GUARD_SIZE];
				/* Aligns body on 8-byte boundary, plus
				 * provides at least 8 additional guard bytes
				 * to detect underruns. */
    char body[1];		/* First byte of client's space. Actual size
				 * of this field will be larger than one. */

};

static struct mem_header *allocHead = NULL;  /* List of allocated structures */

#define GUARD_VALUE  0141

/*
 * The following macro determines the amount of guard space *above* each chunk
 * of memory.
 */

#define HIGH_GUARD_SIZE 8

/*
 * The following macro computes the offset of the "body" field within
 * mem_header.  It is used to get back to the header pointer from the body
 * pointer that's used by clients.
 */

#define BODY_OFFSET \
	((unsigned long) (&((struct mem_header *) 0)->body))

static int total_mallocs = 0;
static int total_frees = 0;
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
#ifdef MEM_VALIDATE
    static int  validate_memory = TRUE;
#else
    static int  validate_memory = FALSE;
#endif

/*
 * The following variable indicates to TclFinalizeMemorySubsystem() 
 * that it should dump out the state of memory before exiting.  If the
 * value is non-NULL, it gives the name of the file in which to
 * dump memory usage information.
 */

char *tclMemDumpFileName = NULL;

static char *onExitMemDumpFileName = NULL;
static char dumpFile[100];	/* Records where to dump memory allocation
				 * information. */

/*
 * Mutex to serialize allocations.  This is a low-level mutex that must
 * be explicitly initialized.  This is necessary because the self
 * initializing mutexes use ckalloc...
 */

static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char *argv[]));
static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static void		ValidateMemory _ANSI_ARGS_((
			    struct mem_header *memHeaderP, CONST char *file,
			    int line, int nukeGuards));

/*
 *----------------------------------------------------------------------
 *
 * TclInitDbCkalloc --

 *	Initialize the locks used by the allocator.
 *	This is only appropriate to call in a single threaded environment,
 *	such as during TclInitSubsystems.
 *
 *----------------------------------------------------------------------
 */

void
TclInitDbCkalloc() 
{
    if (!ckallocInit) {
	ckallocInit = 1;
	ckallocMutexPtr = Tcl_GetAllocMutex();
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclDumpMemoryInfo --

 *     Display the global memory management statistics.
 *
 *----------------------------------------------------------------------
 */

void
TclDumpMemoryInfo(outFile) 
    FILE *outFile;
{
    fprintf(outFile,"total mallocs             %10d\n", 
	    total_mallocs);
    fprintf(outFile,"total frees               %10d\n", 
	    total_frees);
    fprintf(outFile,"current packets allocated %10d\n", 
	    current_malloc_packets);
    fprintf(outFile,"current bytes allocated   %10d\n", 
	    current_bytes_malloced);
    fprintf(outFile,"maximum packets allocated %10d\n", 
	    maximum_malloc_packets);
    fprintf(outFile,"maximum bytes allocated   %10d\n", 
	    maximum_bytes_malloced);
}

/*
 *----------------------------------------------------------------------
 *
 * ValidateMemory --







|
|
|
|









|
|
|

>



















>
|
|
|





|











>
|





|


|

|

|

|

|

|







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
#ifdef MEM_VALIDATE
    static int  validate_memory = TRUE;
#else
    static int  validate_memory = FALSE;
#endif

/*
 * The following variable indicates to TclFinalizeMemorySubsystem() that it
 * should dump out the state of memory before exiting.  If the value is
 * non-NULL, it gives the name of the file in which to dump memory usage
 * information.
 */

char *tclMemDumpFileName = NULL;

static char *onExitMemDumpFileName = NULL;
static char dumpFile[100];	/* Records where to dump memory allocation
				 * information. */

/*
 * Mutex to serialize allocations.  This is a low-level mutex that must be
 * explicitly initialized.  This is necessary because the self initializing
 * mutexes use ckalloc...
 */

static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char *argv[]));
static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static void		ValidateMemory _ANSI_ARGS_((
			    struct mem_header *memHeaderP, CONST char *file,
			    int line, int nukeGuards));

/*
 *----------------------------------------------------------------------
 *
 * TclInitDbCkalloc --
 *
 *	Initialize the locks used by the allocator.  This is only appropriate
 *	to call in a single threaded environment, such as during
 *	TclInitSubsystems.
 *
 *----------------------------------------------------------------------
 */

void
TclInitDbCkalloc()
{
    if (!ckallocInit) {
	ckallocInit = 1;
	ckallocMutexPtr = Tcl_GetAllocMutex();
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclDumpMemoryInfo --
 *
 *	Display the global memory management statistics.
 *
 *----------------------------------------------------------------------
 */

void
TclDumpMemoryInfo(outFile)
    FILE *outFile;
{
    fprintf(outFile,"total mallocs             %10d\n",
	    total_mallocs);
    fprintf(outFile,"total frees               %10d\n",
	    total_frees);
    fprintf(outFile,"current packets allocated %10d\n",
	    current_malloc_packets);
    fprintf(outFile,"current bytes allocated   %10d\n",
	    current_bytes_malloced);
    fprintf(outFile,"maximum packets allocated %10d\n",
	    maximum_malloc_packets);
    fprintf(outFile,"maximum bytes allocated   %10d\n",
	    maximum_bytes_malloced);
}

/*
 *----------------------------------------------------------------------
 *
 * ValidateMemory --
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
					 * memory guards are to be reset to 0
					 * after they have been printed */
{
    unsigned char *hiPtr;
    int idx;
    int guard_failed = FALSE;
    int byte;
    
    for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
        byte = *(memHeaderP->low_guard + idx);
        if (byte != GUARD_VALUE) {
            guard_failed = TRUE;
            fflush(stdout);
	    byte &= 0xff;
            fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", idx, byte,
		    (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
        }
    }
    if (guard_failed) {
        TclDumpMemoryInfo (stderr);
        fprintf(stderr, "low guard failed at %lx, %s %d\n",
                 (long unsigned int) memHeaderP->body, file, line);
        fflush(stderr);  /* In case name pointer is bad. */
        fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
		memHeaderP->file, memHeaderP->line);
        Tcl_Panic("Memory validation failure");
    }

    hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
    for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
        byte = *(hiPtr + idx);
        if (byte != GUARD_VALUE) {
            guard_failed = TRUE;
            fflush(stdout);
	    byte &= 0xff;
            fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", idx, byte,
		    (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
        }
    }

    if (guard_failed) {
        TclDumpMemoryInfo(stderr);
        fprintf(stderr, "high guard failed at %lx, %s %d\n",
                 (long unsigned int) memHeaderP->body, file, line);
        fflush(stderr);  /* In case name pointer is bad. */
        fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
		memHeaderP->length, memHeaderP->file,
		memHeaderP->line);
        Tcl_Panic("Memory validation failure");
    }

    if (nukeGuards) {
        memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); 
        memset((char *) hiPtr, 0, HIGH_GUARD_SIZE); 
    }

}

/*
 *----------------------------------------------------------------------
 *







|

|
|
|
|

|

|


|
|
|
|
|

|




|
|
|
|

|

|



|
|
|
|
|


|



|
|







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
					 * memory guards are to be reset to 0
					 * after they have been printed */
{
    unsigned char *hiPtr;
    int idx;
    int guard_failed = FALSE;
    int byte;

    for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
	byte = *(memHeaderP->low_guard + idx);
	if (byte != GUARD_VALUE) {
	    guard_failed = TRUE;
	    fflush(stdout);
	    byte &= 0xff;
	    fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", idx, byte,
		    (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
	}
    }
    if (guard_failed) {
	TclDumpMemoryInfo (stderr);
	fprintf(stderr, "low guard failed at %lx, %s %d\n",
		(long unsigned int) memHeaderP->body, file, line);
	fflush(stderr);  /* In case name pointer is bad. */
	fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
		memHeaderP->file, memHeaderP->line);
	Tcl_Panic("Memory validation failure");
    }

    hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
    for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
	byte = *(hiPtr + idx);
	if (byte != GUARD_VALUE) {
	    guard_failed = TRUE;
	    fflush(stdout);
	    byte &= 0xff;
	    fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", idx, byte,
		    (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
	}
    }

    if (guard_failed) {
	TclDumpMemoryInfo(stderr);
	fprintf(stderr, "high guard failed at %lx, %s %d\n",
		(long unsigned int) memHeaderP->body, file, line);
	fflush(stderr);  /* In case name pointer is bad. */
	fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
		memHeaderP->length, memHeaderP->file,
		memHeaderP->line);
	Tcl_Panic("Memory validation failure");
    }

    if (nukeGuards) {
	memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE);
	memset((char *) hiPtr, 0, HIGH_GUARD_SIZE);
    }

}

/*
 *----------------------------------------------------------------------
 *
278
279
280
281
282
283
284
285


286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392

393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
 *	Displays memory validation information to stderr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ValidateAllMemory(file, line)
    CONST char *file;	/* File from which Tcl_ValidateAllMemory was called */


    int line;		/* Line number of call to Tcl_ValidateAllMemory */
{
    struct mem_header *memScanP;

    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
        ValidateMemory(memScanP, file, line, FALSE);
    }
    Tcl_MutexUnlock(ckallocMutexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DumpActiveMemory --
 *
 *	Displays all allocated memory to a file; if no filename is given,
 *	information will be written to stderr.
 *
 * Results:
 *	Return TCL_ERROR if an error accessing the file occurs, `errno' 
 *	will have the file error number left in it.

 *----------------------------------------------------------------------
 */

int
Tcl_DumpActiveMemory (fileName)
    CONST char *fileName;		/* Name of the file to write info to */
{
    FILE *fileP;
    struct mem_header *memScanP;
    char *address;

    if (fileName == NULL) {
	fileP = stderr;
    } else {
	fileP = fopen(fileName, "w");
	if (fileP == NULL) {
	    return TCL_ERROR;
	}
    }

    Tcl_MutexLock(ckallocMutexPtr);
    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
        address = &memScanP->body [0];
        fprintf(fileP, "%8lx - %8lx  %7ld @ %s %d %s",
		(long unsigned int) address,
		(long unsigned int) address + memScanP->length - 1,
		memScanP->length, memScanP->file, memScanP->line,
		(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
	(void) fputc('\n', fileP);
    }
    Tcl_MutexUnlock(ckallocMutexPtr);

    if (fileP != stderr) {
	fclose(fileP);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkalloc - debugging ckalloc
 *
 *        Allocate the requested amount of space plus some extra for
 *        guard bands at both ends of the request, plus a size, panicing 
 *        if there isn't enough space, then write in the guard bands
 *        and return the address of the space in the middle that the
 *        user asked for.
 *
 *        The second and third arguments are file and line, these contain
 *        the filename and line number corresponding to the caller.
 *        These are sent by the ckalloc macro; it uses the preprocessor
 *        autodefines __FILE__ and __LINE__.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DbCkalloc(size, file, line)
    unsigned int size;
    CONST char *file;
    int line;
{
    struct mem_header *result;

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    result = (struct mem_header *) TclpAlloc((unsigned)size + 
	    sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
        fflush(stdout);
        TclDumpMemoryInfo(stderr);
        Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
    }

    /*
     * Fill in guard zones and size.  Also initialize the contents of
     * the block with bogus bytes to detect uses of initialized data.
     * Link into allocated list.
     */

    if (init_malloced_bodies) {
        memset((VOID *) result, GUARD_VALUE,
		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
	memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
	memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
	curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL) {
        allocHead->blink = result;
    }
    allocHead = result;

    total_mallocs++;
    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
	(void) fflush(stdout);
        fprintf(stderr, "reached malloc trace enable point (%d)\n",
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing) {
        fprintf(stderr,"ckalloc %lx %u %s %d\n",
		(long unsigned int) result->body, size, file, line);
    }

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
	(void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);
        fprintf(stderr, "program will now enter C debugger\n");
	(void) fflush(stderr);
	abort();
    }

    current_malloc_packets++;
    if (current_malloc_packets > maximum_malloc_packets) {
        maximum_malloc_packets = current_malloc_packets;
    }
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced) {
        maximum_bytes_malloced = current_bytes_malloced;
    }

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

char *
Tcl_AttemptDbCkalloc(size, file, line)
    unsigned int size;
    CONST char *file;
    int line;
{
    struct mem_header *result;

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    result = (struct mem_header *) TclpAlloc((unsigned)size + 
	    sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
        fflush(stdout);
        TclDumpMemoryInfo(stderr);
	return NULL;
    }

    /*
     * Fill in guard zones and size.  Also initialize the contents of
     * the block with bogus bytes to detect uses of initialized data.
     * Link into allocated list.
     */
    if (init_malloced_bodies) {
        memset((VOID *) result, GUARD_VALUE,
		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
	memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
	memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
	curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL) {
        allocHead->blink = result;
    }
    allocHead = result;

    total_mallocs++;
    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
	(void) fflush(stdout);
        fprintf(stderr, "reached malloc trace enable point (%d)\n",
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing) {
        fprintf(stderr,"ckalloc %lx %u %s %d\n",
		(long unsigned int) result->body, size, file, line);
    }

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
	(void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);
        fprintf(stderr, "program will now enter C debugger\n");
	(void) fflush(stderr);
	abort();
    }

    current_malloc_packets++;
    if (current_malloc_packets > maximum_malloc_packets) {
        maximum_malloc_packets = current_malloc_packets;
    }
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced) {
        maximum_bytes_malloced = current_bytes_malloced;
    }

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkfree - debugging ckfree
 *
 *        Verify that the low and high guards are intact, and if so
 *        then free the buffer else Tcl_Panic.
 *
 *        The guards are erased after being checked to catch duplicate
 *        frees.
 *
 *        The second and third arguments are file and line, these contain
 *        the filename and line number corresponding to the caller.
 *        These are sent by the ckfree macro; it uses the preprocessor
 *        autodefines __FILE__ and __LINE__.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbCkfree(ptr, file, line)
    char *ptr;
    CONST char *file;
    int line;
{
    struct mem_header *memp;

    if (ptr == NULL) {
	return 0;
    }

    /*
     * The following cast is *very* tricky.  Must convert the pointer
     * to an integer before doing arithmetic on it, because otherwise
     * the arithmetic will be done differently (and incorrectly) on
     * word-addressed machines such as Crays (will subtract only bytes,
     * even though BODY_OFFSET is in words on these machines).
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    if (alloc_tracing) {
        fprintf(stderr, "ckfree %lx %ld %s %d\n",
		(long unsigned int) memp->body, memp->length, file, line);
    }

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    Tcl_MutexLock(ckallocMutexPtr);
    ValidateMemory(memp, file, line, TRUE);
    if (init_malloced_bodies) {
	memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
    }







|
>
>
|








|













|
|
>





|
















|
|



















|
|
|
|
<

|
|
|
|













|


|


|
|
|



|
|
|

>

|




















|






|
|
|
|
|



|




|

|
|
|






|



|
















|


|


|
|




|
|
|


|




















|






|
|
|
|
|



|




|

|
|
|






|



|












|
|

|
<

|
|
|
|

















|
|
|
|
|





|




|







281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562

563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
 *	Displays memory validation information to stderr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ValidateAllMemory(file, line)
    CONST char *file;		/* File from which Tcl_ValidateAllMemory was
				 * called. */
    int line;			/* Line number of call to
				 * Tcl_ValidateAllMemory */
{
    struct mem_header *memScanP;

    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
	ValidateMemory(memScanP, file, line, FALSE);
    }
    Tcl_MutexUnlock(ckallocMutexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DumpActiveMemory --
 *
 *	Displays all allocated memory to a file; if no filename is given,
 *	information will be written to stderr.
 *
 * Results:
 *	Return TCL_ERROR if an error accessing the file occurs, `errno' will
 *	have the file error number left in it.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DumpActiveMemory (fileName)
    CONST char *fileName;	/* Name of the file to write info to */
{
    FILE *fileP;
    struct mem_header *memScanP;
    char *address;

    if (fileName == NULL) {
	fileP = stderr;
    } else {
	fileP = fopen(fileName, "w");
	if (fileP == NULL) {
	    return TCL_ERROR;
	}
    }

    Tcl_MutexLock(ckallocMutexPtr);
    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
	address = &memScanP->body [0];
	fprintf(fileP, "%8lx - %8lx  %7ld @ %s %d %s",
		(long unsigned int) address,
		(long unsigned int) address + memScanP->length - 1,
		memScanP->length, memScanP->file, memScanP->line,
		(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
	(void) fputc('\n', fileP);
    }
    Tcl_MutexUnlock(ckallocMutexPtr);

    if (fileP != stderr) {
	fclose(fileP);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkalloc - debugging ckalloc
 *
 *	Allocate the requested amount of space plus some extra for guard bands
 *	at both ends of the request, plus a size, panicing if there isn't
 *	enough space, then write in the guard bands and return the address of
 *	the space in the middle that the user asked for.

 *
 *	The second and third arguments are file and line, these contain the
 *	filename and line number corresponding to the caller. These are sent
 *	by the ckalloc macro; it uses the preprocessor autodefines __FILE__
 *	and __LINE__.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DbCkalloc(size, file, line)
    unsigned int size;
    CONST char *file;
    int line;
{
    struct mem_header *result;

    if (validate_memory) {
	Tcl_ValidateAllMemory(file, line);
    }

    result = (struct mem_header *) TclpAlloc((unsigned)size +
	    sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
	fflush(stdout);
	TclDumpMemoryInfo(stderr);
	Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
    }

    /*
     * Fill in guard zones and size. Also initialize the contents of the block
     * with bogus bytes to detect uses of initialized data. Link into
     * allocated list.
     */

    if (init_malloced_bodies) {
	memset((VOID *) result, GUARD_VALUE,
		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
	memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
	memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
	curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL) {
	allocHead->blink = result;
    }
    allocHead = result;

    total_mallocs++;
    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
	(void) fflush(stdout);
	fprintf(stderr, "reached malloc trace enable point (%d)\n",
		total_mallocs);
	fflush(stderr);
	alloc_tracing = TRUE;
	trace_on_at_malloc = 0;
    }

    if (alloc_tracing) {
	fprintf(stderr,"ckalloc %lx %u %s %d\n",
		(long unsigned int) result->body, size, file, line);
    }

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
	break_on_malloc = 0;
	(void) fflush(stdout);
	fprintf(stderr,"reached malloc break limit (%d)\n",
		total_mallocs);
	fprintf(stderr, "program will now enter C debugger\n");
	(void) fflush(stderr);
	abort();
    }

    current_malloc_packets++;
    if (current_malloc_packets > maximum_malloc_packets) {
	maximum_malloc_packets = current_malloc_packets;
    }
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced) {
	maximum_bytes_malloced = current_bytes_malloced;
    }

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

char *
Tcl_AttemptDbCkalloc(size, file, line)
    unsigned int size;
    CONST char *file;
    int line;
{
    struct mem_header *result;

    if (validate_memory) {
	Tcl_ValidateAllMemory(file, line);
    }

    result = (struct mem_header *) TclpAlloc((unsigned)size +
	    sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
	fflush(stdout);
	TclDumpMemoryInfo(stderr);
	return NULL;
    }

    /*
     * Fill in guard zones and size. Also initialize the contents of the block
     * with bogus bytes to detect uses of initialized data. Link into
     * allocated list.
     */
    if (init_malloced_bodies) {
	memset((VOID *) result, GUARD_VALUE,
		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
	memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
	memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
	curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL) {
	allocHead->blink = result;
    }
    allocHead = result;

    total_mallocs++;
    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
	(void) fflush(stdout);
	fprintf(stderr, "reached malloc trace enable point (%d)\n",
		total_mallocs);
	fflush(stderr);
	alloc_tracing = TRUE;
	trace_on_at_malloc = 0;
    }

    if (alloc_tracing) {
	fprintf(stderr,"ckalloc %lx %u %s %d\n",
		(long unsigned int) result->body, size, file, line);
    }

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
	break_on_malloc = 0;
	(void) fflush(stdout);
	fprintf(stderr,"reached malloc break limit (%d)\n",
		total_mallocs);
	fprintf(stderr, "program will now enter C debugger\n");
	(void) fflush(stderr);
	abort();
    }

    current_malloc_packets++;
    if (current_malloc_packets > maximum_malloc_packets) {
	maximum_malloc_packets = current_malloc_packets;
    }
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced) {
	maximum_bytes_malloced = current_bytes_malloced;
    }

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkfree - debugging ckfree
 *
 *	Verify that the low and high guards are intact, and if so then free
 *	the buffer else Tcl_Panic.
 *
 *	The guards are erased after being checked to catch duplicate frees.

 *
 *	The second and third arguments are file and line, these contain the
 *	filename and line number corresponding to the caller. These are sent
 *	by the ckfree macro; it uses the preprocessor autodefines __FILE__ and
 *	__LINE__.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbCkfree(ptr, file, line)
    char *ptr;
    CONST char *file;
    int line;
{
    struct mem_header *memp;

    if (ptr == NULL) {
	return 0;
    }

    /*
     * The following cast is *very* tricky. Must convert the pointer to an
     * integer before doing arithmetic on it, because otherwise the arithmetic
     * will be done differently (and incorrectly) on word-addressed machines
     * such as Crays (will subtract only bytes, even though BODY_OFFSET is in
     * words on these machines).
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    if (alloc_tracing) {
	fprintf(stderr, "ckfree %lx %ld %s %d\n",
		(long unsigned int) memp->body, memp->length, file, line);
    }

    if (validate_memory) {
	Tcl_ValidateAllMemory(file, line);
    }

    Tcl_MutexLock(ckallocMutexPtr);
    ValidateMemory(memp, file, line, TRUE);
    if (init_malloced_bodies) {
	memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
    }
611
612
613
614
615
616
617

618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
	    TclpFree((char *) memp->tagPtr);
	}
    }

    /*
     * Delink from allocated list
     */

    if (memp->flink != NULL) {
        memp->flink->blink = memp->blink;
    }
    if (memp->blink != NULL) {
        memp->blink->flink = memp->flink;
    }
    if (allocHead == memp) {
        allocHead = memp->flink;
    }
    TclpFree((char *) memp);
    Tcl_MutexUnlock(ckallocMutexPtr);

    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * Tcl_DbCkrealloc - debugging ckrealloc
 *
 *	Reallocate a chunk of memory by allocating a new one of the
 *	right size, copying the old data to the new location, and then
 *	freeing the old memory space, using all the memory checking
 *	features of this package.
 *
 *--------------------------------------------------------------------
 */

char *
Tcl_DbCkrealloc(ptr, size, file, line)
    char *ptr;
    unsigned int size;
    CONST char *file;
    int line;
{
    char *new;
    unsigned int copySize;
    struct mem_header *memp;

    if (ptr == NULL) {
	return Tcl_DbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following
     * line.
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
	copySize = memp->length;







>

|


|


|












|
|
|
|




















|
<







616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668

669
670
671
672
673
674
675
	    TclpFree((char *) memp->tagPtr);
	}
    }

    /*
     * Delink from allocated list
     */

    if (memp->flink != NULL) {
	memp->flink->blink = memp->blink;
    }
    if (memp->blink != NULL) {
	memp->blink->flink = memp->flink;
    }
    if (allocHead == memp) {
	allocHead = memp->flink;
    }
    TclpFree((char *) memp);
    Tcl_MutexUnlock(ckallocMutexPtr);

    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * Tcl_DbCkrealloc - debugging ckrealloc
 *
 *	Reallocate a chunk of memory by allocating a new one of the right
 *	size, copying the old data to the new location, and then freeing the
 *	old memory space, using all the memory checking features of this
 *	package.
 *
 *--------------------------------------------------------------------
 */

char *
Tcl_DbCkrealloc(ptr, size, file, line)
    char *ptr;
    unsigned int size;
    CONST char *file;
    int line;
{
    char *new;
    unsigned int copySize;
    struct mem_header *memp;

    if (ptr == NULL) {
	return Tcl_DbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following line.

     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
	copySize = memp->length;
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
    struct mem_header *memp;

    if (ptr == NULL) {
	return Tcl_AttemptDbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following
     * line.
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
	copySize = memp->length;







|
<







692
693
694
695
696
697
698
699

700
701
702
703
704
705
706
    struct mem_header *memp;

    if (ptr == NULL) {
	return Tcl_AttemptDbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following line.

     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
	copySize = memp->length;
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc, et al. --
 *
 *	These functions are defined in terms of the debugging versions
 *	when TCL_MEM_DEBUG is set.
 *
 * Results:
 *	Same as the debug versions.
 *
 * Side effects:
 *	Same as the debug versions.
 *







|
|







716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc, et al. --
 *
 *	These functions are defined in terms of the debugging versions when
 *	TCL_MEM_DEBUG is set.
 *
 * Results:
 *	Same as the debug versions.
 *
 * Side effects:
 *	Same as the debug versions.
 *
770
771
772
773
774
775
776

777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
    return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}

/*
 *----------------------------------------------------------------------
 *
 * MemoryCmd --

 *	Implements the Tcl "memory" command, which provides Tcl-level
 *	control of Tcl memory debugging information.
 *		memory active $file
 *		memory break_on_malloc $count
 *		memory info
 *		memory init on|off
 *		memory onexit $file
 *		memory tag $string
 *		memory trace on|off
 *		memory trace_on_at_malloc $count
 *		memory validate on|off
 *
 * Results:
 *     Standard TCL results.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
static int
MemoryCmd(clientData, interp, argc, argv)
    ClientData clientData;







>
|
|











|







774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
    return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}

/*
 *----------------------------------------------------------------------
 *
 * MemoryCmd --
 *
 *	Implements the Tcl "memory" command, which provides Tcl-level control
 *	of Tcl memory debugging information.
 *		memory active $file
 *		memory break_on_malloc $count
 *		memory info
 *		memory init on|off
 *		memory onexit $file
 *		memory tag $string
 *		memory trace on|off
 *		memory trace_on_at_malloc $count
 *		memory validate on|off
 *
 * Results:
 *	Standard TCL results.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
static int
MemoryCmd(clientData, interp, argc, argv)
    ClientData clientData;
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option [args..]\"", (char *) NULL);
	return TCL_ERROR;
    }

    if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
        if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1], " file\"", (char *) NULL);
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	result = Tcl_DumpActiveMemory (fileName);
	Tcl_DStringFree(&buffer);
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "error accessing ", argv[2], 
		    (char *) NULL);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"break_on_malloc") == 0) {
        if (argc != 3) {
            goto argError;
	}
        if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
        return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	char buf[400];
	sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
	    "total mallocs", total_mallocs, "total frees", total_frees,
	    "current packets allocated", current_malloc_packets,
	    "current bytes allocated", current_bytes_malloced,
	    "maximum packets allocated", maximum_malloc_packets,
	    "maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
        return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
        if (argc != 3) {
            goto bad_suboption;
	}
        init_malloced_bodies = (strcmp(argv[2],"on") == 0);
        return TCL_OK;
    }
    if (strcmp(argv[1],"onexit") == 0) {
        if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " onexit file\"", (char *) NULL);
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;







|











|






|
|

|


|


|
|
|
|
|
|
|
|
|


|
|

|
|


|







811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option [args..]\"", (char *) NULL);
	return TCL_ERROR;
    }

    if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1], " file\"", (char *) NULL);
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	result = Tcl_DumpActiveMemory (fileName);
	Tcl_DStringFree(&buffer);
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "error accessing ", argv[2],
		    (char *) NULL);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"break_on_malloc") == 0) {
	if (argc != 3) {
	    goto argError;
	}
	if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
		"total mallocs", total_mallocs, "total frees", total_frees,
		"current packets allocated", current_malloc_packets,
		"current bytes allocated", current_bytes_malloced,
		"maximum packets allocated", maximum_malloc_packets,
		"maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	init_malloced_bodies = (strcmp(argv[2],"on") == 0);
	return TCL_OK;
    }
    if (strcmp(argv[1],"onexit") == 0) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " onexit file\"", (char *) NULL);
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
	}
	curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));
	curTagPtr->refCount = 0;
	strcpy(curTagPtr->string, argv[2]);
	return TCL_OK;
    }
    if (strcmp(argv[1],"trace") == 0) {
        if (argc != 3) {
            goto bad_suboption;
	}
        alloc_tracing = (strcmp(argv[2],"on") == 0);
        return TCL_OK;
    }

    if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
        if (argc != 3) {
            goto argError;
	}
        if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"validate") == 0) {
        if (argc != 3) {
	    goto bad_suboption;
	}
        validate_memory = (strcmp(argv[2],"on") == 0);
        return TCL_OK;
    }

    Tcl_AppendResult(interp, "bad option \"", argv[1],
	    "\": should be active, break_on_malloc, info, init, onexit, ",
	    "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
    return TCL_ERROR;

argError:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
	    " ", argv[1], " count\"", (char *) NULL);
    return TCL_ERROR;

bad_suboption:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
	    " ", argv[1], " on|off\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * CheckmemCmd --
 *
 *	This is the command procedure for the "checkmem" command, which
 *	causes the application to exit after printing information about
 *	memory usage to the file passed to this command as its first
 *	argument.
 *
 * Results:
 *	Returns a standard Tcl completion code.
 *
 * Side effects:
 *	None.
 *







|
|

|
|



|
|

|





|


|
|







|




|










|
|
|
<







886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940

941
942
943
944
945
946
947
	}
	curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));
	curTagPtr->refCount = 0;
	strcpy(curTagPtr->string, argv[2]);
	return TCL_OK;
    }
    if (strcmp(argv[1],"trace") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	alloc_tracing = (strcmp(argv[2],"on") == 0);
	return TCL_OK;
    }

    if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
	if (argc != 3) {
	    goto argError;
	}
	if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"validate") == 0) {
	if (argc != 3) {
	    goto bad_suboption;
	}
	validate_memory = (strcmp(argv[2],"on") == 0);
	return TCL_OK;
    }

    Tcl_AppendResult(interp, "bad option \"", argv[1],
	    "\": should be active, break_on_malloc, info, init, onexit, ",
	    "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
    return TCL_ERROR;

  argError:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
	    " ", argv[1], " count\"", (char *) NULL);
    return TCL_ERROR;

  bad_suboption:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
	    " ", argv[1], " on|off\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * CheckmemCmd --
 *
 *	This is the command procedure for the "checkmem" command, which causes
 *	the application to exit after printing information about memory usage
 *	to the file passed to this command as its first argument.

 *
 * Results:
 *	Returns a standard Tcl completion code.
 *
 * Side effects:
 *	None.
 *
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005

1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018

1019
1020
1021
1022
1023
1024
1025
1026
1027

1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054

1055
1056
1057
1058
1059
1060
1061
1062
1063
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
 *
 *	Create the "memory" and "checkmem" commands in the given
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	New commands are added to the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitMemory(interp)
    Tcl_Interp *interp;	/* Interpreter in which commands should be added */
{
    TclInitDbCkalloc();
    Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, 
	    (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
	    (Tcl_CmdDeleteProc *) NULL);
}


#else	/* TCL_MEM_DEBUG */

/* This is the !TCL_MEM_DEBUG case */

#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc --

 *     Interface to TclpAlloc when TCL_MEM_DEBUG is disabled.  It does check
 *     that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Alloc(size)
    unsigned int size;
{
    char *result;

    result = TclpAlloc(size);

    /*
     * Most systems will not alloc(0), instead bumping it to one so
     * that NULL isn't returned.  Some systems (AIX, Tru64) will alloc(0)
     * by returning NULL, so we have to check that the NULL we get is
     * not in response to alloc(0).
     *
     * The ANSI spec actually says that systems either return NULL *or*
     * a special pointer on failure, but we only check for NULL
     */

    if ((result == NULL) && size) {
	Tcl_Panic("unable to alloc %u bytes", size);
    }
    return result;
}

char *
Tcl_DbCkalloc(size, file, line)
    unsigned int size;
    CONST char *file;
    int line;
{
    char *result;

    result = (char *) TclpAlloc(size);

    if ((result == NULL) && size) {
        fflush(stdout);
        Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptAlloc --

 *     Interface to TclpAlloc when TCL_MEM_DEBUG is disabled.  It does not
 *     check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_AttemptAlloc(size)
    unsigned int size;







|
<















|



















>
|
|











>

|
|
|
|

|
|

>

















|
|








>
|
|







966
967
968
969
970
971
972
973

974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
 *
 *	Create the "memory" and "checkmem" commands in the given interpreter.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	New commands are added to the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitMemory(interp)
    Tcl_Interp *interp;	/* Interpreter in which commands should be added */
{
    TclInitDbCkalloc();
    Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
	    (Tcl_CmdDeleteProc *) NULL);
}


#else	/* TCL_MEM_DEBUG */

/* This is the !TCL_MEM_DEBUG case */

#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc --
 *
 *	Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
 *	that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Alloc(size)
    unsigned int size;
{
    char *result;

    result = TclpAlloc(size);

    /*
     * Most systems will not alloc(0), instead bumping it to one so that NULL
     * isn't returned.  Some systems (AIX, Tru64) will alloc(0) by returning
     * NULL, so we have to check that the NULL we get is not in response to
     * alloc(0).
     *
     * The ANSI spec actually says that systems either return NULL *or* a
     * special pointer on failure, but we only check for NULL
     */

    if ((result == NULL) && size) {
	Tcl_Panic("unable to alloc %u bytes", size);
    }
    return result;
}

char *
Tcl_DbCkalloc(size, file, line)
    unsigned int size;
    CONST char *file;
    int line;
{
    char *result;

    result = (char *) TclpAlloc(size);

    if ((result == NULL) && size) {
	fflush(stdout);
	Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptAlloc --
 *
 *	Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
 *	check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_AttemptAlloc(size)
    unsigned int size;
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087

1088
1089
1090
1091
1092
1093
1094
1095
1096
    int line;
{
    char *result;

    result = (char *) TclpAlloc(size);
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Realloc --

 *     Interface to TclpRealloc when TCL_MEM_DEBUG is disabled.  It does 
 *     check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Realloc(ptr, size)
    char *ptr;







<





>
|
|







1082
1083
1084
1085
1086
1087
1088

1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
    int line;
{
    char *result;

    result = (char *) TclpAlloc(size);
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Realloc --
 *
 *	Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
 *	that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Realloc(ptr, size)
    char *ptr;
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130

1131
1132
1133
1134
1135
1136
1137
1138
1139
    int line;
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
        fflush(stdout);
        Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptRealloc --

 *     Interface to TclpRealloc when TCL_MEM_DEBUG is disabled.  It does 
 *     not check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_AttemptRealloc(ptr, size)
    char *ptr;







|
|








>
|
|







1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
    int line;
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
	fflush(stdout);
	Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptRealloc --
 *
 *	Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not
 *	check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_AttemptRealloc(ptr, size)
    char *ptr;
1158
1159
1160
1161
1162
1163
1164

1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Free --

 *     Interface to TclpFree when TCL_MEM_DEBUG is disabled.  Done here
 *     rather in the macro to keep some modules from being compiled with 
 *     TCL_MEM_DEBUG enabled and some with it disabled.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Free(ptr)
    char *ptr;







>
|
|
|







1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Free --
 *
 *	Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather
 *	in the macro to keep some modules from being compiled with
 *	TCL_MEM_DEBUG enabled and some with it disabled.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Free(ptr)
    char *ptr;
1186
1187
1188
1189
1190
1191
1192

1193
1194
1195
1196
1197
1198
1199
1200
1201
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --

 *     Dummy initialization for memory command, which is only available 
 *     if TCL_MEM_DEBUG is on.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
void
Tcl_InitMemory(interp)
    Tcl_Interp *interp;







>
|
|







1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
 *
 *	Dummy initialization for memory command, which is only available if
 *	TCL_MEM_DEBUG is on.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
void
Tcl_InitMemory(interp)
    Tcl_Interp *interp;
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255

1256

1257
1258
1259
1260
1261

1262
1263
1264
1265
1266
1267
1268








Tcl_ValidateAllMemory(file, line)
    CONST char *file;
    int line;
{
}

void
TclDumpMemoryInfo(outFile) 
    FILE *outFile;
{
}

#endif	/* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * TclFinalizeMemorySubsystem --
 *
 *	This procedure is called to finalize all the structures that 
 *	are used by the memory allocator on a per-process basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This subsystem is self-initializing, since memory can be 
 *	allocated before Tcl is formally initialized.  After this call,
 *	this subsystem has been reset to its initial state and is 
 *	usable again.
 *
 *---------------------------------------------------------------------------
 */

void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
    if (tclMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(tclMemDumpFileName);
    } else if (onExitMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(onExitMemDumpFileName);
    }

    Tcl_MutexLock(ckallocMutexPtr);

    if (curTagPtr != NULL) {
	TclpFree((char *) curTagPtr);
	curTagPtr = NULL;
    }
    allocHead = NULL;

    Tcl_MutexUnlock(ckallocMutexPtr);
#endif

#if USE_TCLALLOC
    TclFinalizeAllocSubsystem(); 
#endif
}















|











|
|





|
|
|
<













>

>





>




|


>
>
>
>
>
>
>
>
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251

1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
Tcl_ValidateAllMemory(file, line)
    CONST char *file;
    int line;
{
}

void
TclDumpMemoryInfo(outFile)
    FILE *outFile;
{
}

#endif	/* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * TclFinalizeMemorySubsystem --
 *
 *	This procedure is called to finalize all the structures that are used
 *	by the memory allocator on a per-process basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This subsystem is self-initializing, since memory can be allocated
 *	before Tcl is formally initialized. After this call, this subsystem
 *	has been reset to its initial state and is usable again.

 *
 *---------------------------------------------------------------------------
 */

void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
    if (tclMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(tclMemDumpFileName);
    } else if (onExitMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(onExitMemDumpFileName);
    }

    Tcl_MutexLock(ckallocMutexPtr);

    if (curTagPtr != NULL) {
	TclpFree((char *) curTagPtr);
	curTagPtr = NULL;
    }
    allocHead = NULL;

    Tcl_MutexUnlock(ckallocMutexPtr);
#endif

#if USE_TCLALLOC
    TclFinalizeAllocSubsystem();
#endif
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclClock.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.37 2004/10/30 18:04:00 kennykb Exp $
 */

#include "tclInt.h"

/*
 * Windows has mktime.  The configurators do not check.
 */







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.37.2.2 2005/08/15 18:13:58 dgp Exp $
 */

#include "tclInt.h"

/*
 * Windows has mktime.  The configurators do not check.
 */
162
163
164
165
166
167
168








169
170
171
172
173
174
175
	      Tcl_NewStringObj("number too large to represent as a Posix time", 
			       -1) );
	Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL );
	return TCL_ERROR;
    }
    TzsetIfNecessary();
    timeVal = ThreadSafeLocalTime( &tock );









    /* Package the results */

    returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 );
    returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1);
    returnVec[2] = Tcl_NewIntObj( timeVal->tm_mday );
    returnVec[3] = Tcl_NewIntObj( timeVal->tm_hour );







>
>
>
>
>
>
>
>







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
	      Tcl_NewStringObj("number too large to represent as a Posix time", 
			       -1) );
	Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL );
	return TCL_ERROR;
    }
    TzsetIfNecessary();
    timeVal = ThreadSafeLocalTime( &tock );
    if ( timeVal == NULL ) {
	Tcl_SetObjResult(interp, 
			 Tcl_NewStringObj("localtime failed (clock "
					  "value may be too large/"
					  "small to represent)", -1));
	Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char*) NULL);
	return TCL_ERROR;
    }

    /* Package the results */

    returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 );
    returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1);
    returnVec[2] = Tcl_NewIntObj( timeVal->tm_mday );
    returnVec[3] = Tcl_NewIntObj( timeVal->tm_hour );
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215


216





217
218

219
220
221
222
223
224
225
226
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeLocalTime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch
				 */

{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm *tmPtr = (struct tm *)
	    Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
    localtime_r(timePtr, tmPtr);
#else


    Tcl_MutexLock(&clockMutex);





    memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm));
    Tcl_MutexUnlock(&clockMutex);

#endif    
    return tmPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclClockMktimeObjCmd --







|
|
<
<










>
>

>
>
>
>
>
|
|
>
|







203
204
205
206
207
208
209
210
211


212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeLocalTime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds since the
				 * local system's epoch */


{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm *tmPtr = (struct tm *)
	    Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
    localtime_r(timePtr, tmPtr);
#else
    struct tm *sysTmPtr;

    Tcl_MutexLock(&clockMutex);
    sysTmPtr = localtime(timePtr);
    if (sysTmPtr == NULL) {
	Tcl_MutexUnlock(&clockMutex);
	return NULL;
    } else {
	memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm));
	Tcl_MutexUnlock(&clockMutex);
    }
#endif
    return tmPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclClockMktimeObjCmd --
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323


324
325
326
327
328
329
330
    }
    toConvert.tm_min = i;
    if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) {
	return TCL_ERROR;
    }
    toConvert.tm_sec = i;
    toConvert.tm_isdst = -1;
    toConvert.tm_wday = 0;
    toConvert.tm_yday = 0;

    /* Convert the time.  It is rumored that mktime is not thread
     * safe on some platforms. */

    TzsetIfNecessary();
    Tcl_MutexLock( &clockMutex );
    errno = 0;
    convertedTime = mktime( &toConvert );
    localErrno = errno;
    Tcl_MutexUnlock( &clockMutex );

    /* Return the converted time, or an error if conversion fails */

    if ( localErrno != 0 ) {


	Tcl_SetObjResult
	    ( interp,
	      Tcl_NewStringObj( "time value too large/small to represent", 
				-1 ) );
	return TCL_ERROR;
    } else {
	Tcl_SetObjResult( interp,







|
|













|
>
>







315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
    }
    toConvert.tm_min = i;
    if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) {
	return TCL_ERROR;
    }
    toConvert.tm_sec = i;
    toConvert.tm_isdst = -1;
    toConvert.tm_wday = -1;
    toConvert.tm_yday = -1;

    /* Convert the time.  It is rumored that mktime is not thread
     * safe on some platforms. */

    TzsetIfNecessary();
    Tcl_MutexLock( &clockMutex );
    errno = 0;
    convertedTime = mktime( &toConvert );
    localErrno = errno;
    Tcl_MutexUnlock( &clockMutex );

    /* Return the converted time, or an error if conversion fails */

    if ( localErrno != 0
	 || ( convertedTime == -1
	      && toConvert.tm_yday == -1 ) ) {
	Tcl_SetObjResult
	    ( interp,
	      Tcl_NewStringObj( "time value too large/small to represent", 
				-1 ) );
	return TCL_ERROR;
    } else {
	Tcl_SetObjResult( interp,

Changes to generic/tclCmdAH.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19


20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
/* 
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.57 2004/11/13 00:19:07 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>



/*
 * Prototypes for local procedures defined in this file:
 */

static int		CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int mode));
static int		GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc,
			    Tcl_StatBuf *statPtr));
static char *		GetTypeFromMode _ANSI_ARGS_((int mode));
static int		StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *varName, Tcl_StatBuf *statPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BreakObjCmd --
 *
 *	This procedure is invoked to process the "break" Tcl command.
 *	See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when
 *	a command name is computed at runtime, and is "break" or the name
 *	to which "break" was renamed: e.g., "set z break; $z"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_BreakObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
    return TCL_BREAK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CaseObjCmd --
 *
 *	This procedure is invoked to process the "case" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
|


|
|
<




|
|

|





>
>




|
|
|
<
|
|
|
|






|
|

|
|
|













|
|
|
|













|
|







1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

#define NEW_FORMAT 1

/*
 * Prototypes for local procedures defined in this file:
 */

static int		CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    int mode);
static int		GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,

			    Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
static char *		GetTypeFromMode(int mode);
static int		StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
			    Tcl_StatBuf *statPtr);

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BreakObjCmd --
 *
 *	This procedure is invoked to process the "break" Tcl command. See the
 *	user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when a
 *	command name is computed at runtime, and is "break" or the name to
 *	which "break" was renamed: e.g., "set z break; $z"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_BreakObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
    return TCL_BREAK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CaseObjCmd --
 *
 *	This procedure is invoked to process the "case" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
    } else {
	i = 2;
    }
    caseObjc = objc - i;
    caseObjv = objv + i;

    /*
     * If all of the pattern/command pairs are lumped into a single
     * argument, split them out again.
     */

    if (caseObjc == 1) {
	Tcl_Obj **newObjv;

	Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
	caseObjv = newObjv;







|
|







112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
    } else {
	i = 2;
    }
    caseObjc = objc - i;
    caseObjv = objv + i;

    /*
     * If all of the pattern/command pairs are lumped into a single argument,
     * split them out again.
     */

    if (caseObjc == 1) {
	Tcl_Obj **newObjv;

	Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
	caseObjv = newObjv;
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
	if (i == (caseObjc - 1)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "extra case pattern with no body", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Check for special case of single pattern (no list) with
	 * no backslash sequences.
	 */

	pat = TclGetString(caseObjv[i]);
	for (p = (unsigned char *) pat; *p != '\0'; p++) {
	    if (isspace(*p) || (*p == '\\')) {	/* INTL: ISO space, UCHAR */
		break;
	    }
	}
	if (*p == '\0') {
	    if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
		body = i + 1;
	    }
	    if (Tcl_StringMatch(stringPtr, pat)) {
		body = i + 1;
		goto match;
	    }
	    continue;
	}

	/*
	 * Break up pattern lists, then check each of the patterns
	 * in the list.
	 */

	result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
	if (result != TCL_OK) {
	    return result;
	}
	for (j = 0; j < patObjc; j++) {
	    if (Tcl_StringMatch(stringPtr, patObjv[j])) {
		body = i + 1;
		break;
	    }
	}
	ckfree((char *) patObjv);
	if (j < patObjc) {
	    break;
	}
    }

    match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {
	    char msg[100 + TCL_INTEGER_SPACE];

	    arg = TclGetString(armPtr);
	    sprintf(msg, "\n    (\"%.50s\" arm line %d)", arg,
		    interp->errorLine);
	    Tcl_AddObjErrorInfo(interp, msg, -1);
	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CatchObjCmd --
 *
 *	This object-based procedure is invoked to process the "catch" Tcl 
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.







|
|




















|
|


















|




<
<
<
|
|
<
















|







136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189



190
191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
	if (i == (caseObjc - 1)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "extra case pattern with no body", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Check for special case of single pattern (no list) with no
	 * backslash sequences.
	 */

	pat = TclGetString(caseObjv[i]);
	for (p = (unsigned char *) pat; *p != '\0'; p++) {
	    if (isspace(*p) || (*p == '\\')) {	/* INTL: ISO space, UCHAR */
		break;
	    }
	}
	if (*p == '\0') {
	    if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
		body = i + 1;
	    }
	    if (Tcl_StringMatch(stringPtr, pat)) {
		body = i + 1;
		goto match;
	    }
	    continue;
	}

	/*
	 * Break up pattern lists, then check each of the patterns in the
	 * list.
	 */

	result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
	if (result != TCL_OK) {
	    return result;
	}
	for (j = 0; j < patObjc; j++) {
	    if (Tcl_StringMatch(stringPtr, patObjv[j])) {
		body = i + 1;
		break;
	    }
	}
	ckfree((char *) patObjv);
	if (j < patObjc) {
	    break;
	}
    }

  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {



	    TclFormatToErrorInfo(interp, "\n    (\"%.50s\" arm line %d)",
		    TclGetString(armPtr), interp->errorLine);

	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CatchObjCmd --
 *
 *	This object-based procedure is invoked to process the "catch" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
247
248
249
250
251
252
253
254
255
256

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
    }

    result = Tcl_EvalObjEx(interp, objv[1], 0);

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */
    if (Tcl_LimitExceeded(interp)) {
	char msg[32 + TCL_INTEGER_SPACE];


	sprintf(msg, "\n    (\"catch\" body line %d)", interp->errorLine);
	Tcl_AddErrorInfo(interp, msg);
	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp,  
	            "couldn't save command result in variable", NULL);
	    return TCL_ERROR;
	}
    }
    if (objc == 4) {
	Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
	if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
		options, 0)) {
	    Tcl_DecrRefCount(options);
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp,
	            "couldn't save return options in variable", NULL);
	    return TCL_ERROR;
	}
    }

    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CdObjCmd --
 *
 *	This procedure is invoked to process the "cd" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







<
<

>
|
|







|
|










|














|
|







243
244
245
246
247
248
249


250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
    }

    result = Tcl_EvalObjEx(interp, objv[1], 0);

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */



    if (Tcl_LimitExceeded(interp)) {
	TclFormatToErrorInfo(interp, "\n    (\"catch\" body line %d)",
		interp->errorLine);
	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp,
		    "couldn't save command result in variable", NULL);
	    return TCL_ERROR;
	}
    }
    if (objc == 4) {
	Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
	if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
		options, 0)) {
	    Tcl_DecrRefCount(options);
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp,
		    "couldn't save return options in variable", NULL);
	    return TCL_ERROR;
	}
    }

    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CdObjCmd --
 *
 *	This procedure is invoked to process the "cd" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ContinueObjCmd -
 *
 *	This procedure is invoked to process the "continue" Tcl command.
 *	See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when
 *	a command name is computed at runtime, and is "continue" or the name
 *	to which "continue" was renamed: e.g., "set z continue; $z"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|

|
|

|
|
|







365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ContinueObjCmd --
 *
 *	This procedure is invoked to process the "continue" Tcl command. See
 *	the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when a
 *	command name is computed at runtime, and is "continue" or the name to
 *	which "continue" was renamed: e.g., "set z continue; $z"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459





460
461
462
463
464


465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528

529






































530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
int
Tcl_EncodingObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int index, length;
    Tcl_Encoding encoding;
    char *stringPtr;
    Tcl_DString ds;

    static CONST char *optionStrings[] = {
	"convertfrom", "convertto", "names", "system",
	NULL
    };
    enum options {
	ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
	case ENC_CONVERTTO:
	case ENC_CONVERTFROM: {
	    char *name;
	    Tcl_Obj *data;





	    if (objc == 3) {
		name = NULL;
		data = objv[2];
	    } else if (objc == 4) {
		name = TclGetString(objv[2]);


		data = objv[3];
	    } else {
		Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
		return TCL_ERROR;
	    }

	    encoding = Tcl_GetEncoding(interp, name);
	    if (!encoding) {
		return TCL_ERROR;
	    }

	    if ((enum options) index == ENC_CONVERTFROM) {
		/*
		 * Treat the string as binary data.
		 */

		stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
		Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds);

		/*
		 * Note that we cannot use Tcl_DStringResult here because
		 * it will truncate the string at the first null byte.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
		Tcl_DStringFree(&ds);
	    } else {
		/*
		 * Store the result as binary data.
		 */

		stringPtr = Tcl_GetStringFromObj(data, &length);
		Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
		Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( 
			(unsigned char *) Tcl_DStringValue(&ds),
			Tcl_DStringLength(&ds)));
		Tcl_DStringFree(&ds);
	    }

	    Tcl_FreeEncoding(encoding);
	    break;
	}
	case ENC_NAMES: {
	    if (objc > 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
	    Tcl_GetEncodingNames(interp);
	    break;
	}
	case ENC_SYSTEM: {
	    if (objc > 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
		return TCL_ERROR;
	    }
	    if (objc == 2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			Tcl_GetEncodingName(NULL), -1));
	    } else {
	        return Tcl_SetSystemEncoding(interp, TclGetString(objv[2]));
	    }
	    break;
	}

    }






































    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrorObjCmd --
 *
 *	This procedure is invoked to process the "error" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
<
<
<











|







|
|
<
|
>
>
>
>
>
|
|
|
|
|
>
>
|
|
|
|
|

<
<
<
<
<
|
|
|
|

|
|

|
|
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|
|







421
422
423
424
425
426
427
428



429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449

450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468





469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507

508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
int
Tcl_EncodingObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int index;




    static CONST char *optionStrings[] = {
	"convertfrom", "convertto", "names", "system",
	NULL
    };
    enum options {
	ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
    case ENC_CONVERTTO:
    case ENC_CONVERTFROM: {

	Tcl_Obj *data;
	Tcl_DString ds;
	Tcl_Encoding encoding;
	int length;
	char *stringPtr;

	if (objc == 3) {
	    encoding = Tcl_GetEncoding(interp, NULL);
	    data = objv[2];
	} else if (objc == 4) {
	    if (TclGetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) {
		return TCL_ERROR;
	    }
	    data = objv[3];
	} else {
	    Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
	    return TCL_ERROR;
	}






	if ((enum options) index == ENC_CONVERTFROM) {
	    /*
	     * Treat the string as binary data.
	     */

	    stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
	    Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds);

	    /*
	     * Note that we cannot use Tcl_DStringResult here because it will
	     * truncate the string at the first null byte.
	     */

	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
	    Tcl_DStringFree(&ds);
	} else {
	    /*
	     * Store the result as binary data.
	     */

	    stringPtr = Tcl_GetStringFromObj(data, &length);
	    Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
	    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
		    (unsigned char *) Tcl_DStringValue(&ds),
		    Tcl_DStringLength(&ds)));
	    Tcl_DStringFree(&ds);
	}

	Tcl_FreeEncoding(encoding);
	break;
    }
    case ENC_NAMES:
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	Tcl_GetEncodingNames(interp);
	break;

    case ENC_SYSTEM:
	if (objc > 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
	    return TCL_ERROR;
	}
	if (objc == 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    Tcl_GetEncodingName(NULL), -1));
	} else {
	    return Tcl_SetSystemEncoding(interp, TclGetString(objv[2]));
	}
	break;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclEncodingDirsObjCmd --
 *
 *	This command manipulates the encoding search path.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Can set the encoding search path.
 *
 *----------------------------------------------------------------------
 */

int
TclEncodingDirsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, TclGetEncodingSearchPath());
	return TCL_OK;
    }
    if (TclSetEncodingSearchPath(objv[1]) == TCL_ERROR) {
	Tcl_AppendResult(interp, "expected directory list but got \"",
		Tcl_GetString(objv[1]), "\"", NULL);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, objv[1]);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrorObjCmd --
 *
 *	This procedure is invoked to process the "error" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObjCmd --
 *
 *	This object-based procedure is invoked to process the "eval" Tcl 
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.







|







612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObjCmd --
 *
 *	This object-based procedure is invoked to process the "eval" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
614
615
616
617
618
619
620
621
622
623

624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
    }

    if (objc == 2) {
	result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result.  Tcl_EvalObjEx will delete
	 * the object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-1, objv+1);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];

	sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitObjCmd --
 *
 *	This procedure is invoked to process the "exit" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|

>




<
|
|
<









|
|







645
646
647
648
649
650
651
652
653
654
655
656
657
658
659

660
661

662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
    }

    if (objc == 2) {
	result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-1, objv+1);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {

	TclFormatToErrorInfo(interp,"\n    (\"eval\" body line %d)",
		interp->errorLine);

    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitObjCmd --
 *
 *	This procedure is invoked to process the "exit" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803

804
805
806


807
808
809
810
811
812
813
814
815
816
817
818

819
820
821
822
823
824

825
826





827
828
829
830
831
832
833

834
835
836
837
838
839

840
841
842
843

844

845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900

901
902
903

904
905
906
907
908
909
910
911
912



913
914
915
916

917



918
919
920
921
922






923



924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948

949


950
951
952
953
954
955
956
957
958

959


960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977


978


979
980
981
982
983
984
985

986
987
988
989
990
991
992
993
994
995
996

997
998
999

1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032


1033


1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048

1049
1050
1051
1052
1053

1054
1055

1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081

1082
1083
1084
1085




1086
1087
1088
1089


1090
1091
1092
1093
1094



1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106

1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238

1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
 *
 * Tcl_ExprObjCmd --
 *
 *	This object-based procedure is invoked to process the "expr" Tcl
 *	command. See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is called in two
 *	circumstances: 1) to execute expr commands that are too complicated
 *	or too unsafe to try compiling directly into an inline sequence of
 *	instructions, and 2) to execute commands where the command name is
 *	computed at runtime and is "expr" or the name to which "expr" was
 *	renamed (e.g., "set z expr; $z 2+3")
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ExprObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{	 
    register Tcl_Obj *objPtr;
    Tcl_Obj *resultPtr;
    int result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
	return TCL_ERROR;
    }

    objPtr = Tcl_ConcatObj(objc-1, objv+1);
    Tcl_IncrRefCount(objPtr);
    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    Tcl_DecrRefCount(objPtr);

    if (result == TCL_OK) {
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_DecrRefCount(resultPtr);  /* done with the result object */
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FileObjCmd --
 *
 *	This procedure is invoked to process the "file" Tcl command.
 *	See the user documentation for details on what it does.
 *	PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
 *	EMBEDDED NULLS.
 *      With the object-based Tcl_FS APIs, the above NOTE may no
 *      longer be true.  In any case this assertion should be tested.
 *      
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int index;

/*
 * This list of constants should match the fileOption string array below.
 */

    static CONST char *fileOptions[] = {
	"atime",	"attributes",	"channels",	"copy",
	"delete",
	"dirname",	"executable",	"exists",	"extension",
	"isdirectory",	"isfile",	"join",		"link",
	"lstat",        "mtime",	"mkdir",	"nativename",	
	"normalize",    "owned",
	"pathtype",	"readable",	"readlink",	"rename",
	"rootname",	"separator",    "size",		"split",	
	"stat",         "system", 
	"tail",		"type",		"volumes",	"writable",
	(char *) NULL
    };
    enum options {
	FCMD_ATIME,	FCMD_ATTRIBUTES, FCMD_CHANNELS,	FCMD_COPY,
	FCMD_DELETE,
	FCMD_DIRNAME,	FCMD_EXECUTABLE, FCMD_EXISTS,	FCMD_EXTENSION,
	FCMD_ISDIRECTORY, FCMD_ISFILE,	FCMD_JOIN,	FCMD_LINK, 
	FCMD_LSTAT,     FCMD_MTIME,	FCMD_MKDIR,	FCMD_NATIVENAME, 
	FCMD_NORMALIZE, FCMD_OWNED,
	FCMD_PATHTYPE,	FCMD_READABLE,	FCMD_READLINK,	FCMD_RENAME,
	FCMD_ROOTNAME,	FCMD_SEPARATOR, FCMD_SIZE,	FCMD_SPLIT,	
	FCMD_STAT,      FCMD_SYSTEM, 
	FCMD_TAIL,	FCMD_TYPE,	FCMD_VOLUMES,	FCMD_WRITABLE
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
	case FCMD_ATIME: {

	    Tcl_StatBuf buf;
	    struct utimbuf tval;



	    if ((objc < 3) || (objc > 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
		return TCL_ERROR;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (objc == 4) {
		/*
		 * Need separate variable for reading longs from an
		 * object on 64-bit platforms. [Bug #698146]
		 */

		long newTime;

		if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
		    return TCL_ERROR;
		}


		tval.actime = newTime;
		tval.modtime = buf.st_mtime;





		if (Tcl_FSUtime(objv[2], &tval) != 0) {
		    Tcl_AppendResult(interp,
			    "could not set access time for file \"",
			    TclGetString(objv[2]), "\": ",
			    Tcl_PosixError(interp), (char *) NULL);
		    return TCL_ERROR;
		}

		/*
		 * Do another stat to ensure that the we return the
		 * new recognized atime - hopefully the same as the
		 * one we sent in.  However, fs's like FAT don't
		 * even know what atime is.
		 */

		if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }

	    Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime));

	    return TCL_OK;
	}
	case FCMD_ATTRIBUTES:
            return TclFileAttrsCmd(interp, objc, objv);
	case FCMD_CHANNELS:
	    if ((objc < 2) || (objc > 3)) {
		Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
		return TCL_ERROR;
	    }
	    return Tcl_GetChannelNamesEx(interp,
		    ((objc == 2) ? NULL : TclGetString(objv[2])));
	case FCMD_COPY:
	    return TclFileCopyCmd(interp, objc, objv);
	case FCMD_DELETE:
	    return TclFileDeleteCmd(interp, objc, objv);
	case FCMD_DIRNAME: {
	    Tcl_Obj *dirPtr;

	    if (objc != 3) {
		goto only3Args;
	    }
	    dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
	    if (dirPtr == NULL) {
	        return TCL_ERROR;
	    } else {
		Tcl_SetObjResult(interp, dirPtr);
		Tcl_DecrRefCount(dirPtr);
		return TCL_OK;
	    }
	}
	case FCMD_EXECUTABLE:
	    if (objc != 3) {
		goto only3Args;
	    }
	    return CheckAccess(interp, objv[2], X_OK);
	case FCMD_EXISTS:
	    if (objc != 3) {
		goto only3Args;
	    }
	    return CheckAccess(interp, objv[2], F_OK);
	case FCMD_EXTENSION: {
	    Tcl_Obj *ext;

	    if (objc != 3) {
		goto only3Args;
	    }
	    ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
	    if (ext != NULL) {
	        Tcl_SetObjResult(interp, ext);
		Tcl_DecrRefCount(ext);
		return TCL_OK;
	    } else {
		return TCL_ERROR;
	    }
	}
	case FCMD_ISDIRECTORY: {

	    int value;
	    Tcl_StatBuf buf;


	    if (objc != 3) {
		goto only3Args;
	    }
	    value = 0;
	    if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
		value = S_ISDIR(buf.st_mode);
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
	    return TCL_OK;



	}
	case FCMD_ISFILE: {
	    int value;
	    Tcl_StatBuf buf;





	    if (objc != 3) {
		goto only3Args;
	    }
	    value = 0;
	    if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {






		value = S_ISREG(buf.st_mode);



	    }
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
	    return TCL_OK;
	}
	case FCMD_JOIN: {
	    Tcl_Obj *resObj;

	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
		return TCL_ERROR;
	    }
	    resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
	    Tcl_SetObjResult(interp, resObj);
	    return TCL_OK;
	}
	case FCMD_LINK: {
	    Tcl_Obj *contents;
	    int index;

	    if (objc < 3 || objc > 5) {
		Tcl_WrongNumArgs(interp, 2, objv, 
				 "?-linktype? linkname ?target?");
		return TCL_ERROR;
	    }


	    /* Index of the 'source' argument */


	    if (objc == 5) {
		index = 3;
	    } else {
		index = 2;
	    }

	    if (objc > 3) {
		int linkAction;
		if (objc == 5) {

		    /* We have a '-linktype' argument */


		    static CONST char *linkTypes[] = {
			"-symbolic", "-hard", NULL
		    };
		    if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, 
				     "switch", 0, &linkAction) != TCL_OK) {
			return TCL_ERROR;
		    }
		    if (linkAction == 0) {
		        linkAction = TCL_CREATE_SYMBOLIC_LINK;
		    } else {
			linkAction = TCL_CREATE_HARD_LINK;
		    }
		} else {
		    linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
		}
		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		    return TCL_ERROR;
		}


		/* Create link from source to target */


		contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
		if (contents == NULL) {
		    /* 
		     * We handle three common error cases specially, and
		     * for all other errors, we use the standard posix
		     * error message.
		     */

		    if (errno == EEXIST) {
			Tcl_AppendResult(interp,
				"could not create new link \"", 
				TclGetString(objv[index]), 
				"\": that path already exists", (char *) NULL);
		    } else if (errno == ENOENT) {
			/*
			 * There are two cases here: either the target
			 * doesn't exist, or the directory of the src
			 * doesn't exist.
			 */

			int access;
			Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], 
						      TCL_PATH_DIRNAME);

			if (dirPtr == NULL) {
			    return TCL_ERROR;
			}
			access = Tcl_FSAccess(dirPtr, F_OK);
			Tcl_DecrRefCount(dirPtr);
			if (access != 0) {
			    Tcl_AppendResult(interp, 
			            "could not create new link \"", 
				    TclGetString(objv[index]), 
				    "\": no such file or directory", 
				    (char *) NULL);
			} else {
			    Tcl_AppendResult(interp, 
			            "could not create new link \"", 
				    TclGetString(objv[index]), 
				    "\": target \"", 
				    TclGetString(objv[index+1]), 
				    "\" doesn't exist", 
				    (char *) NULL);
			}
		    } else {
			Tcl_AppendResult(interp,
				"could not create new link \"",
				TclGetString(objv[index]), "\" pointing to \"",
				TclGetString(objv[index+1]), "\": ", 
				Tcl_PosixError(interp), (char *) NULL);
		    }
		    return TCL_ERROR;
		}
	    } else {
		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		    return TCL_ERROR;
		}


		/* Read link */


		contents = Tcl_FSLink(objv[index], NULL, 0);
		if (contents == NULL) {
		    Tcl_AppendResult(interp, "could not read link \"", 
			    TclGetString(objv[index]), "\": ", 
			    Tcl_PosixError(interp), (char *) NULL);
		    return TCL_ERROR;
		}
	    }
	    Tcl_SetObjResult(interp, contents);
	    if (objc == 3) {
		/* 
		 * If we are reading a link, we need to free this
		 * result refCount.  If we are creating a link, this
		 * will just be objv[index+1], and so we don't own it.
		 */

		Tcl_DecrRefCount(contents);
	    }
	    return TCL_OK;
	}
	case FCMD_LSTAT: {

	    Tcl_StatBuf buf;


	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "name varName");
		return TCL_ERROR;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    return StoreStatData(interp, objv[3], &buf);
	}
	case FCMD_MTIME: {
	    Tcl_StatBuf buf;
	    struct utimbuf tval;

	    if ((objc < 3) || (objc > 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
		return TCL_ERROR;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (objc == 4) {
		/*
		 * Need separate variable for reading longs from an
		 * object on 64-bit platforms. [Bug #698146]
		 */
		long newTime;


		if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
		    return TCL_ERROR;
		}





		tval.actime = buf.st_atime;
		tval.modtime = newTime;
		if (Tcl_FSUtime(objv[2], &tval) != 0) {


		    Tcl_AppendResult(interp,
			    "could not set modification time for file \"",
			    TclGetString(objv[2]), "\": ",
			    Tcl_PosixError(interp), (char *) NULL);
		    return TCL_ERROR;



		}
		/*
		 * Do another stat to ensure that the we return the
		 * new recognized atime - hopefully the same as the
		 * one we sent in.  However, fs's like FAT don't
		 * even know what atime is.
		 */
		if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime));

	    return TCL_OK;
	}
	case FCMD_MKDIR:
	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
		return TCL_ERROR;
	    }
	    return TclFileMakeDirsCmd(interp, objc, objv);
	case FCMD_NATIVENAME: {
	    CONST char *fileName;
	    Tcl_DString ds;

	    if (objc != 3) {
		goto only3Args;
	    }
	    fileName = TclGetString(objv[2]);
	    fileName = Tcl_TranslateFileName(interp, fileName, &ds);
	    if (fileName == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, 
			     Tcl_DStringLength(&ds)));
	    Tcl_DStringFree(&ds);
	    return TCL_OK;
	}
	case FCMD_NORMALIZE: {
	    Tcl_Obj *fileName;

	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "filename");
		return TCL_ERROR;
	    }

	    fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
	    if (fileName == NULL) {
	        return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, fileName);
	    return TCL_OK;
	}
	case FCMD_OWNED: {
	    int value;
	    Tcl_StatBuf buf;

	    if (objc != 3) {
		goto only3Args;
	    }
	    value = 0;
	    if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
		/*
		 * For Windows, there are no user ids 
		 * associated with a file, so we always return 1.
		 */

#if defined(__WIN32__)
		value = 1;
#else
		value = (geteuid() == buf.st_uid);
#endif
	    }	    
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
	    return TCL_OK;
	}
	case FCMD_PATHTYPE:
	    if (objc != 3) {
		goto only3Args;
	    }
	    switch (Tcl_FSGetPathType(objv[2])) {
	    case TCL_PATH_ABSOLUTE:
		Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1));
		break;
	    case TCL_PATH_RELATIVE:
		Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1));
		break;
	    case TCL_PATH_VOLUME_RELATIVE:
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("volumerelative", -1));
		break;
	    }
	    return TCL_OK;
	case FCMD_READABLE:
	    if (objc != 3) {
		goto only3Args;
	    }
	    return CheckAccess(interp, objv[2], R_OK);
	case FCMD_READLINK: {
	    Tcl_Obj *contents;

	    if (objc != 3) {
		goto only3Args;
	    }

	    if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
		return TCL_ERROR;
	    }

	    contents = Tcl_FSLink(objv[2], NULL, 0);

	    if (contents == NULL) {
		Tcl_AppendResult(interp, "could not readlink \"", 
			TclGetString(objv[2]), "\": ", 
			Tcl_PosixError(interp), (char *) NULL);
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, contents);
	    Tcl_DecrRefCount(contents);
	    return TCL_OK;
	}
	case FCMD_RENAME:
	    return TclFileRenameCmd(interp, objc, objv);
	case FCMD_ROOTNAME: {
	    Tcl_Obj *root;

	    if (objc != 3) {
		goto only3Args;
	    }
	    root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
	    if (root != NULL) {
		Tcl_SetObjResult(interp, root);
		Tcl_DecrRefCount(root);
		return TCL_OK;
	    } else {
		return TCL_ERROR;
	    }
	}
	case FCMD_SEPARATOR:
	    if ((objc < 2) || (objc > 3)) {
		Tcl_WrongNumArgs(interp, 2, objv, "?name?");
		return TCL_ERROR;
	    }
	    if (objc == 2) {
	        char *separator = NULL; /* lint */

		switch (tclPlatform) {
		case TCL_PLATFORM_UNIX:
		    separator = "/";
		    break;
		case TCL_PLATFORM_WINDOWS:
		    separator = "\\";
		    break;
		}
		Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
	    } else {
		Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
		if (separatorObj != NULL) {
		    Tcl_SetObjResult(interp, separatorObj);
		} else {
		    Tcl_SetObjResult(interp, 
			    Tcl_NewStringObj("Unrecognised path",-1));
		    return TCL_ERROR;
		}
	    }
	    return TCL_OK;
	case FCMD_SIZE: {
	    Tcl_StatBuf buf;

	    if (objc != 3) {
		goto only3Args;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp,
		    Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
	    return TCL_OK;
	}
	case FCMD_SPLIT: {
	    Tcl_Obj *res;

	    if (objc != 3) {
		goto only3Args;
	    }
	    res = Tcl_FSSplitPath(objv[2], NULL);
	    if (res == NULL) {
		if (interp != NULL) {
		    Tcl_AppendResult(interp, "could not read \"",
			TclGetString(objv[2]),
			"\": no such file or directory", (char *) NULL);
		}
		return TCL_ERROR;
	    } else {
		Tcl_SetObjResult(interp, res);
		return TCL_OK;
	    }
	}
	case FCMD_STAT: {
	    Tcl_StatBuf buf;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
		return TCL_ERROR;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    return StoreStatData(interp, objv[3], &buf);
	}
	case FCMD_SYSTEM: {
	    Tcl_Obj* fsInfo;

	    if (objc != 3) {
		goto only3Args;
	    }
	    fsInfo = Tcl_FSFileSystemInfo(objv[2]);
	    if (fsInfo != NULL) {
		Tcl_SetObjResult(interp, fsInfo);
		return TCL_OK;
	    } else {
		Tcl_SetObjResult(interp, 
				 Tcl_NewStringObj("Unrecognised path",-1));
		return TCL_ERROR;
	    }
	}
	case FCMD_TAIL: {
	    Tcl_Obj *dirPtr;

	    if (objc != 3) {
		goto only3Args;
	    }
	    dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
	    if (dirPtr == NULL) {
		return TCL_ERROR;
	    } else {
		Tcl_SetObjResult(interp, dirPtr);
		Tcl_DecrRefCount(dirPtr);
		return TCL_OK;
	    }
	}
	case FCMD_TYPE: {
	    Tcl_StatBuf buf;

	    if (objc != 3) {
		goto only3Args;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    GetTypeFromMode((unsigned short) buf.st_mode), -1));
	    return TCL_OK;
	}
	case FCMD_VOLUMES:
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_FSListVolumes());
	    return TCL_OK;
	case FCMD_WRITABLE:
	    if (objc != 3) {
		goto only3Args;
	    }
	    return CheckAccess(interp, objv[2], W_OK);
    }

    only3Args:
    Tcl_WrongNumArgs(interp, 2, objv, "name");
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * CheckAccess --
 *
 *	Utility procedure used by Tcl_FileObjCmd() to query file
 *	attributes available through the access() system call.
 *
 * Results:
 *	Always returns TCL_OK.  Sets interp's result to boolean true or
 *	false depending on whether the file has the specified attribute.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
CheckAccess(interp, pathPtr, mode)
    Tcl_Interp *interp;		/* Interp for status return.  Must not be
				 * NULL. */
    Tcl_Obj *pathPtr;		/* Name of file to check. */
    int mode;			/* Attribute to check; passed as argument to
				 * access(). */
{
    int value;








|
|




















|
















|










|
|
|
<
|
|
|



















|
|
|






|


|
|







|
|
|

|
|





|







<
>
|
|

>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|

|
|
|

>


>
>
>
>
>
|
|
|
|
|
|
|
>
|
|
|
<
|
|
>
|
|
|
|
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|

>
|
|
|
|
|
|
|
|
|
>
>
>

<
|
|
>
|
>
>
>
|
|
|
|
|
>
>
>
>
>
>
|
>
>
>
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
<
|
|

>
|
>
>
|
|
|
|
|

|
|
|
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
>
>
|
|
|
|
|
<
|
>
|
|
<
|
|
|
|
|
|
<
|
>
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
<
>
|

>
|
|
|
|
|
|
|
|
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
|
>
|
|
|
|
>
>
>
>
|
<
<
|
>
>
|
<
<
|
|
>
>
>
|
<
<
<
<
<
<
|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|

|
|
|
|
|
|
|


|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
|
|

|
|
|
|
|
|
|
|
|
<
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|


|









|
|


|
|









|







710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769

770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831

832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875

876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940

941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958

959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001

1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049

1050
1051
1052
1053

1054
1055
1056
1057
1058
1059

1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080

1081
1082

1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121

1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133

1134










1135




1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146


1147
1148
1149
1150


1151
1152
1153
1154
1155
1156






1157
1158
1159

1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201























1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214

1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290













1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309












1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321

1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339













1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
 *
 * Tcl_ExprObjCmd --
 *
 *	This object-based procedure is invoked to process the "expr" Tcl
 *	command. See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is called in two
 *	circumstances: 1) to execute expr commands that are too complicated or
 *	too unsafe to try compiling directly into an inline sequence of
 *	instructions, and 2) to execute commands where the command name is
 *	computed at runtime and is "expr" or the name to which "expr" was
 *	renamed (e.g., "set z expr; $z 2+3")
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ExprObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Tcl_Obj *objPtr;
    Tcl_Obj *resultPtr;
    int result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
	return TCL_ERROR;
    }

    objPtr = Tcl_ConcatObj(objc-1, objv+1);
    Tcl_IncrRefCount(objPtr);
    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    Tcl_DecrRefCount(objPtr);

    if (result == TCL_OK) {
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_DecrRefCount(resultPtr);	/* done with the result object */
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FileObjCmd --
 *
 *	This procedure is invoked to process the "file" Tcl command. See the
 *	user documentation for details on what it does. PLEASE NOTE THAT THIS
 *	FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the

 *	object-based Tcl_FS APIs, the above NOTE may no longer be true. In any
 *	case this assertion should be tested.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int index;

    /*
     * This list of constants should match the fileOption string array below.
     */

    static CONST char *fileOptions[] = {
	"atime",	"attributes",	"channels",	"copy",
	"delete",
	"dirname",	"executable",	"exists",	"extension",
	"isdirectory",	"isfile",	"join",		"link",
	"lstat",	"mtime",	"mkdir",	"nativename",
	"normalize",    "owned",
	"pathtype",	"readable",	"readlink",	"rename",
	"rootname",	"separator",    "size",		"split",
	"stat",		"system",
	"tail",		"type",		"volumes",	"writable",
	(char *) NULL
    };
    enum options {
	FCMD_ATIME,	FCMD_ATTRIBUTES, FCMD_CHANNELS,	FCMD_COPY,
	FCMD_DELETE,
	FCMD_DIRNAME,	FCMD_EXECUTABLE, FCMD_EXISTS,	FCMD_EXTENSION,
	FCMD_ISDIRECTORY, FCMD_ISFILE,	FCMD_JOIN,	FCMD_LINK,
	FCMD_LSTAT,	FCMD_MTIME,	FCMD_MKDIR,	FCMD_NATIVENAME,
	FCMD_NORMALIZE,	FCMD_OWNED,
	FCMD_PATHTYPE,	FCMD_READABLE,	FCMD_READLINK,	FCMD_RENAME,
	FCMD_ROOTNAME,	FCMD_SEPARATOR,	FCMD_SIZE,	FCMD_SPLIT,
	FCMD_STAT,	FCMD_SYSTEM,
	FCMD_TAIL,	FCMD_TYPE,	FCMD_VOLUMES,	FCMD_WRITABLE
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {

    {
	Tcl_StatBuf buf;
	struct utimbuf tval;

    case FCMD_ATIME:
    case FCMD_MTIME:
	if ((objc < 3) || (objc > 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
	    return TCL_ERROR;
	}
	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc == 4) {
	    /*
	     * Need separate variable for reading longs from an object on
	     * 64-bit platforms. [Bug #698146]
	     */

	    long newTime;

	    if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
		return TCL_ERROR;
	    }

	    if (index == FCMD_ATIME) {
		tval.actime = newTime;
		tval.modtime = buf.st_mtime;
	    } else {	/* index == FCMD_MTIME */
		tval.actime = buf.st_atime;
		tval.modtime = newTime;
	    }

	    if (Tcl_FSUtime(objv[2], &tval) != 0) {
		Tcl_AppendResult(interp, "could not set ",
			(index == FCMD_ATIME ? "access" : "modification"),
			" time for file \"", TclGetString(objv[2]), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Do another stat to ensure that the we return the new recognized
	     * atime - hopefully the same as the one we sent in. However, fs's

	     * like FAT don't even know what atime is.
	     */

	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	}

	Tcl_SetObjResult(interp, Tcl_NewLongObj((long)
		(index == FCMD_ATIME ? buf.st_atime : buf.st_mtime)));
	return TCL_OK;
    }
    case FCMD_ATTRIBUTES:
	return TclFileAttrsCmd(interp, objc, objv);
    case FCMD_CHANNELS:
	if ((objc < 2) || (objc > 3)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	    return TCL_ERROR;
	}
	return Tcl_GetChannelNamesEx(interp,
		((objc == 2) ? NULL : TclGetString(objv[2])));
    case FCMD_COPY:
	return TclFileCopyCmd(interp, objc, objv);
    case FCMD_DELETE:
	return TclFileDeleteCmd(interp, objc, objv);
    case FCMD_DIRNAME: {
	Tcl_Obj *dirPtr;

	if (objc != 3) {
	    goto only3Args;
	}
	dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
	if (dirPtr == NULL) {
	    return TCL_ERROR;
	} else {
	    Tcl_SetObjResult(interp, dirPtr);
	    Tcl_DecrRefCount(dirPtr);
	    return TCL_OK;
	}
    }
    case FCMD_EXECUTABLE:
	if (objc != 3) {
	    goto only3Args;
	}
	return CheckAccess(interp, objv[2], X_OK);
    case FCMD_EXISTS:
	if (objc != 3) {
	    goto only3Args;
	}
	return CheckAccess(interp, objv[2], F_OK);
    case FCMD_EXTENSION: {
	Tcl_Obj *ext;

	if (objc != 3) {
	    goto only3Args;
	}
	ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
	if (ext != NULL) {
	    Tcl_SetObjResult(interp, ext);
	    Tcl_DecrRefCount(ext);
	    return TCL_OK;
	} else {
	    return TCL_ERROR;
	}
    }

    {
	int value;
	Tcl_StatBuf buf;

    case FCMD_ISDIRECTORY:
	if (objc != 3) {
	    goto only3Args;
	}
	value = 0;
	if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
	    value = S_ISDIR(buf.st_mode);
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
	return TCL_OK;
    case FCMD_ISFILE:
	if (objc != 3) {
	    goto only3Args;
	}

	value = 0;
	if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
	    value = S_ISREG(buf.st_mode);
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
	return TCL_OK;
    case FCMD_OWNED:
	if (objc != 3) {
	    goto only3Args;
	}
	value = 0;
	if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
	    /*
	     * For Windows, there are no user ids associated with a file, so
	     * we always return 1.
	     */

#if defined(__WIN32__)
	    value = 1;
#else
	    value = (geteuid() == buf.st_uid);
#endif
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
	return TCL_OK;
    }
    case FCMD_JOIN: {
	Tcl_Obj *resObj;

	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
	    return TCL_ERROR;
	}
	resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
	Tcl_SetObjResult(interp, resObj);
	return TCL_OK;
    }
    case FCMD_LINK: {
	Tcl_Obj *contents;
	int index;

	if (objc < 3 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?");

	    return TCL_ERROR;
	}

	/*
	 * Index of the 'source' argument.
	 */

	if (objc == 5) {
	    index = 3;
	} else {
	    index = 2;
	}

	if (objc > 3) {
	    int linkAction;
	    if (objc == 5) {
		/*
		 * We have a '-linktype' argument.
		 */

		static CONST char *linkTypes[] = {
		    "-symbolic", "-hard", NULL
		};
		if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch",
			0, &linkAction) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (linkAction == 0) {
		    linkAction = TCL_CREATE_SYMBOLIC_LINK;
		} else {
		    linkAction = TCL_CREATE_HARD_LINK;
		}
	    } else {
		linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
	    }
	    if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		return TCL_ERROR;
	    }

	    /*
	     * Create link from source to target.
	     */

	    contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
	    if (contents == NULL) {
		/*
		 * We handle three common error cases specially, and for all
		 * other errors, we use the standard posix error message.

		 */

		if (errno == EEXIST) {
		    Tcl_AppendResult(interp, "could not create new link \"",

			    TclGetString(objv[index]),
			    "\": that path already exists", (char *) NULL);
		} else if (errno == ENOENT) {
		    /*
		     * There are two cases here: either the target doesn't
		     * exist, or the directory of the src doesn't exist.

		     */

		    int access;
		    Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
			    TCL_PATH_DIRNAME);

		    if (dirPtr == NULL) {
			return TCL_ERROR;
		    }
		    access = Tcl_FSAccess(dirPtr, F_OK);
		    Tcl_DecrRefCount(dirPtr);
		    if (access != 0) {
			Tcl_AppendResult(interp,
				"could not create new link \"",
				TclGetString(objv[index]),
				"\": no such file or directory",
				(char *) NULL);
		    } else {
			Tcl_AppendResult(interp,
				"could not create new link \"",
				TclGetString(objv[index]), "\": target \"",

				TclGetString(objv[index+1]),
				"\" doesn't exist", (char *) NULL);

		    }
		} else {
		    Tcl_AppendResult(interp,
			    "could not create new link \"",
			    TclGetString(objv[index]), "\" pointing to \"",
			    TclGetString(objv[index+1]), "\": ",
			    Tcl_PosixError(interp), (char *) NULL);
		}
		return TCL_ERROR;
	    }
	} else {
	    if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		return TCL_ERROR;
	    }

	    /*
	     * Read link
	     */

	    contents = Tcl_FSLink(objv[index], NULL, 0);
	    if (contents == NULL) {
		Tcl_AppendResult(interp, "could not read link \"",
			TclGetString(objv[index]), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
		return TCL_ERROR;
	    }
	}
	Tcl_SetObjResult(interp, contents);
	if (objc == 3) {
	    /*
	     * If we are reading a link, we need to free this result refCount.
	     * If we are creating a link, this will just be objv[index+1], and
	     * so we don't own it.
	     */

	    Tcl_DecrRefCount(contents);
	}
	return TCL_OK;
    }

    {
	Tcl_StatBuf buf;

    case FCMD_LSTAT:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "name varName");
	    return TCL_ERROR;
	}
	if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
	    return TCL_ERROR;
	}
	return StoreStatData(interp, objv[3], &buf);

    case FCMD_STAT:










	if (objc != 4) {




	    Tcl_WrongNumArgs(interp, 2, objv, "name varName");
	    return TCL_ERROR;
	}
	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
	    return TCL_ERROR;
	}
	return StoreStatData(interp, objv[3], &buf);
    case FCMD_SIZE:
	if (objc != 3) {
	    goto only3Args;
	}


	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp,


		Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
	return TCL_OK;
    case FCMD_TYPE:
	if (objc != 3) {
	    goto only3Args;
	}






	if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
	    return TCL_ERROR;
	}

	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		GetTypeFromMode((unsigned short) buf.st_mode), -1));
	return TCL_OK;
    }
    case FCMD_MKDIR:
	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
	    return TCL_ERROR;
	}
	return TclFileMakeDirsCmd(interp, objc, objv);
    case FCMD_NATIVENAME: {
	CONST char *fileName;
	Tcl_DString ds;

	if (objc != 3) {
	    goto only3Args;
	}
	fileName = TclGetString(objv[2]);
	fileName = Tcl_TranslateFileName(interp, fileName, &ds);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
		Tcl_DStringLength(&ds)));
	Tcl_DStringFree(&ds);
	return TCL_OK;
    }
    case FCMD_NORMALIZE: {
	Tcl_Obj *fileName;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "filename");
	    return TCL_ERROR;
	}

	fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, fileName);
	return TCL_OK;
    }























    case FCMD_PATHTYPE:
	if (objc != 3) {
	    goto only3Args;
	}
	switch (Tcl_FSGetPathType(objv[2])) {
	case TCL_PATH_ABSOLUTE:
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1));
	    break;
	case TCL_PATH_RELATIVE:
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1));
	    break;
	case TCL_PATH_VOLUME_RELATIVE:
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("volumerelative", -1));

	    break;
	}
	return TCL_OK;
    case FCMD_READABLE:
	if (objc != 3) {
	    goto only3Args;
	}
	return CheckAccess(interp, objv[2], R_OK);
    case FCMD_READLINK: {
	Tcl_Obj *contents;

	if (objc != 3) {
	    goto only3Args;
	}

	if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
	    return TCL_ERROR;
	}

	contents = Tcl_FSLink(objv[2], NULL, 0);

	if (contents == NULL) {
	    Tcl_AppendResult(interp, "could not readlink \"",
		    TclGetString(objv[2]), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, contents);
	Tcl_DecrRefCount(contents);
	return TCL_OK;
    }
    case FCMD_RENAME:
	return TclFileRenameCmd(interp, objc, objv);
    case FCMD_ROOTNAME: {
	Tcl_Obj *root;

	if (objc != 3) {
	    goto only3Args;
	}
	root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
	if (root != NULL) {
	    Tcl_SetObjResult(interp, root);
	    Tcl_DecrRefCount(root);
	    return TCL_OK;
	} else {
	    return TCL_ERROR;
	}
    }
    case FCMD_SEPARATOR:
	if ((objc < 2) || (objc > 3)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?name?");
	    return TCL_ERROR;
	}
	if (objc == 2) {
	    char *separator = NULL; /* lint */

	    switch (tclPlatform) {
	    case TCL_PLATFORM_UNIX:
		separator = "/";
		break;
	    case TCL_PLATFORM_WINDOWS:
		separator = "\\";
		break;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
	} else {
	    Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
	    if (separatorObj != NULL) {
		Tcl_SetObjResult(interp, separatorObj);
	    } else {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("Unrecognised path",-1));
		return TCL_ERROR;
	    }
	}
	return TCL_OK;













    case FCMD_SPLIT: {
	Tcl_Obj *res;

	if (objc != 3) {
	    goto only3Args;
	}
	res = Tcl_FSSplitPath(objv[2], NULL);
	if (res == NULL) {
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "could not read \"",
			TclGetString(objv[2]),
			"\": no such file or directory", (char *) NULL);
	    }
	    return TCL_ERROR;
	} else {
	    Tcl_SetObjResult(interp, res);
	    return TCL_OK;
	}
    }












    case FCMD_SYSTEM: {
	Tcl_Obj* fsInfo;

	if (objc != 3) {
	    goto only3Args;
	}
	fsInfo = Tcl_FSFileSystemInfo(objv[2]);
	if (fsInfo != NULL) {
	    Tcl_SetObjResult(interp, fsInfo);
	    return TCL_OK;
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("Unrecognised path",-1));

	    return TCL_ERROR;
	}
    }
    case FCMD_TAIL: {
	Tcl_Obj *dirPtr;

	if (objc != 3) {
	    goto only3Args;
	}
	dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
	if (dirPtr == NULL) {
	    return TCL_ERROR;
	} else {
	    Tcl_SetObjResult(interp, dirPtr);
	    Tcl_DecrRefCount(dirPtr);
	    return TCL_OK;
	}
    }













    case FCMD_VOLUMES:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_FSListVolumes());
	return TCL_OK;
    case FCMD_WRITABLE:
	if (objc != 3) {
	    goto only3Args;
	}
	return CheckAccess(interp, objv[2], W_OK);
    }

  only3Args:
    Tcl_WrongNumArgs(interp, 2, objv, "name");
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * CheckAccess --
 *
 *	Utility procedure used by Tcl_FileObjCmd() to query file attributes
 *	available through the access() system call.
 *
 * Results:
 *	Always returns TCL_OK. Sets interp's result to boolean true or false
 *	depending on whether the file has the specified attribute.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
CheckAccess(interp, pathPtr, mode)
    Tcl_Interp *interp;		/* Interp for status return. Must not be
				 * NULL. */
    Tcl_Obj *pathPtr;		/* Name of file to check. */
    int mode;			/* Attribute to check; passed as argument to
				 * access(). */
{
    int value;

1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
}

/*
 *---------------------------------------------------------------------------
 *
 * GetStatBuf --
 *
 *	Utility procedure used by Tcl_FileObjCmd() to query file
 *	attributes available through the stat() or lstat() system call.
 *
 * Results:
 *	The return value is TCL_OK if the specified file exists and can
 *	be stat'ed, TCL_ERROR otherwise.  If TCL_ERROR is returned, an
 *	error message is left in interp's result.  If TCL_OK is returned,
 *	*statPtr is filled with information about the specified file.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
GetStatBuf(interp, pathPtr, statProc, statPtr)
    Tcl_Interp *interp;		/* Interp for error return.  May be NULL. */
    Tcl_Obj *pathPtr;		/* Path name to examine. */
    Tcl_FSStatProc *statProc;	/* Either stat() or lstat() depending on
				 * desired behavior. */
    Tcl_StatBuf *statPtr;	/* Filled with info about file obtained by
				 * calling (*statProc)(). */
{
    int status;







|
|


|
|
|
|









|







1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
}

/*
 *---------------------------------------------------------------------------
 *
 * GetStatBuf --
 *
 *	Utility procedure used by Tcl_FileObjCmd() to query file attributes
 *	available through the stat() or lstat() system call.
 *
 * Results:
 *	The return value is TCL_OK if the specified file exists and can be
 *	stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error
 *	message is left in interp's result. If TCL_OK is returned, *statPtr is
 *	filled with information about the specified file.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
GetStatBuf(interp, pathPtr, statProc, statPtr)
    Tcl_Interp *interp;		/* Interp for error return. May be NULL. */
    Tcl_Obj *pathPtr;		/* Path name to examine. */
    Tcl_FSStatProc *statProc;	/* Either stat() or lstat() depending on
				 * desired behavior. */
    Tcl_StatBuf *statPtr;	/* Filled with info about file obtained by
				 * calling (*statProc)(). */
{
    int status;
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488

1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504


1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519

1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
}

/*
 *----------------------------------------------------------------------
 *
 * StoreStatData --
 *
 *	This is a utility procedure that breaks out the fields of a
 *	"stat" structure and stores them in textual form into the
 *	elements of an associative array.
 *
 * Results:
 *	Returns a standard Tcl return value.  If an error occurs then
 *	a message is left in interp's result.
 *
 * Side effects:
 *	Elements of the associative array given by "varName" are modified.
 *
 *----------------------------------------------------------------------
 */

static int
StoreStatData(interp, varName, statPtr)
    Tcl_Interp *interp;			/* Interpreter for error reports. */
    Tcl_Obj *varName;			/* Name of associative array variable
					 * in which to store stat results. */
    Tcl_StatBuf *statPtr;		/* Pointer to buffer containing
					 * stat data to store in varName. */
{
    Tcl_Obj *field = Tcl_NewObj();
    Tcl_Obj *value;
    register unsigned short mode;

    /*
     * Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
     *
     * Might be a better idea to call Tcl_SetVar2Ex() instead so we
     * don't have to make assumptions that might go wrong later.
     */

#define STORE_ARY(fieldName, object) \
    Tcl_SetStringObj(field, (fieldName), -1); \
    value = (object); \
    if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
	Tcl_DecrRefCount(field); \
	Tcl_DecrRefCount(value); \
	return TCL_ERROR; \
    }

    Tcl_IncrRefCount(field);
    STORE_ARY("dev",   Tcl_NewLongObj((long)statPtr->st_dev));
    /*
     * Watch out porters; the inode is meant to be an *unsigned* value,
     * so the cast might fail when there isn't a real arithmentic 'long
     * long' type...
     */


    STORE_ARY("ino",   Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
    STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
    STORE_ARY("uid",   Tcl_NewLongObj((long)statPtr->st_uid));
    STORE_ARY("gid",   Tcl_NewLongObj((long)statPtr->st_gid));
    STORE_ARY("size",  Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_ST_BLOCKS
    STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
    STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
    STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
    STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
    mode = (unsigned short) statPtr->st_mode;
    STORE_ARY("mode",  Tcl_NewIntObj(mode));
    STORE_ARY("type",  Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY

    Tcl_DecrRefCount(field);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetTypeFromMode --
 *
 *	Given a mode word, returns a string identifying the type of a
 *	file.
 *
 * Results:
 *	A static text string giving the file type from mode.
 *
 * Side effects:
 *	None.
 *







|
|
|


|
|









|
|
|
|
|








|
|

>



|






|

|
|
<

>
>
|
|
|
|
|

|

|
|
|

|
|

>









|
<







1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496

1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525

1526
1527
1528
1529
1530
1531
1532
}

/*
 *----------------------------------------------------------------------
 *
 * StoreStatData --
 *
 *	This is a utility procedure that breaks out the fields of a "stat"
 *	structure and stores them in textual form into the elements of an
 *	associative array.
 *
 * Results:
 *	Returns a standard Tcl return value. If an error occurs then a message
 *	is left in interp's result.
 *
 * Side effects:
 *	Elements of the associative array given by "varName" are modified.
 *
 *----------------------------------------------------------------------
 */

static int
StoreStatData(interp, varName, statPtr)
    Tcl_Interp *interp;		/* Interpreter for error reports. */
    Tcl_Obj *varName;		/* Name of associative array variable in which
				 * to store stat results. */
    Tcl_StatBuf *statPtr;	/* Pointer to buffer containing stat data to
				 * store in varName. */
{
    Tcl_Obj *field = Tcl_NewObj();
    Tcl_Obj *value;
    register unsigned short mode;

    /*
     * Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
     *
     * Might be a better idea to call Tcl_SetVar2Ex() instead so we don't have
     * to make assumptions that might go wrong later.
     */

#define STORE_ARY(fieldName, object) \
    Tcl_SetStringObj(field, (fieldName), -1); \
    value = (object); \
    if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \
	Tcl_DecrRefCount(field); \
	Tcl_DecrRefCount(value); \
	return TCL_ERROR; \
    }

    Tcl_IncrRefCount(field);

    /*
     * Watch out porters; the inode is meant to be an *unsigned* value, so the
     * cast might fail when there isn't a real arithmentic 'long long' type...

     */

    STORE_ARY("dev",	Tcl_NewLongObj((long)statPtr->st_dev));
    STORE_ARY("ino",	Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
    STORE_ARY("nlink",	Tcl_NewLongObj((long)statPtr->st_nlink));
    STORE_ARY("uid",	Tcl_NewLongObj((long)statPtr->st_uid));
    STORE_ARY("gid",	Tcl_NewLongObj((long)statPtr->st_gid));
    STORE_ARY("size",	Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_ST_BLOCKS
    STORE_ARY("blocks",	Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
    STORE_ARY("atime",	Tcl_NewLongObj((long)statPtr->st_atime));
    STORE_ARY("mtime",	Tcl_NewLongObj((long)statPtr->st_mtime));
    STORE_ARY("ctime",	Tcl_NewLongObj((long)statPtr->st_ctime));
    mode = (unsigned short) statPtr->st_mode;
    STORE_ARY("mode",	Tcl_NewIntObj(mode));
    STORE_ARY("type",	Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY

    Tcl_DecrRefCount(field);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetTypeFromMode --
 *
 *	Given a mode word, returns a string identifying the type of a file.

 *
 * Results:
 *	A static text string giving the file type from mode.
 *
 * Side effects:
 *	None.
 *
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForObjCmd --
 *
 *      This procedure is invoked to process the "for" Tcl command.
 *      See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when
 *	a command name is computed at runtime, and is "for" or the name
 *	to which "for" was renamed: e.g.,
 *	"set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_ForObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result, value;

    if (objc != 5) {
        Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
        return TCL_ERROR;
    }

    result = Tcl_EvalObjEx(interp, objv[1], 0);
    if (result != TCL_OK) {
        if (result == TCL_ERROR) {
            Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
        }
        return result;
    }
    while (1) {
	/*
	 * We need to reset the result before passing it off to
	 * Tcl_ExprBooleanObj.  Otherwise, any error message will be appended
	 * to the result of the last evaluation.
	 */

	Tcl_ResetResult(interp);
        result = Tcl_ExprBooleanObj(interp, objv[2], &value);
        if (result != TCL_OK) {
            return result;
        }
        if (!value) {
            break;
        }
        result = Tcl_EvalObjEx(interp, objv[4], 0);
        if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
            if (result == TCL_ERROR) {
                char msg[32 + TCL_INTEGER_SPACE];

                sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);
                Tcl_AddErrorInfo(interp, msg);
            }
            break;
        }
        result = Tcl_EvalObjEx(interp, objv[3], 0);
	if (result == TCL_BREAK) {
            break;
        } else if (result != TCL_OK) {
            if (result == TCL_ERROR) {
                Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
            }
            return result;
        }
    }
    if (result == TCL_BREAK) {
        result = TCL_OK;
    }
    if (result == TCL_OK) {
        Tcl_ResetResult(interp);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForeachObjCmd --
 *
 *	This object-based procedure is invoked to process the "foreach" Tcl
 *	command.  See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|

|
|
|



|


|




|


|
|
|





|
|




|
|
|
|




|




|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|

|
|
|
|
|
|
|


|


|










|







1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623

1624
1625

1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForObjCmd --
 *
 *	This procedure is invoked to process the "for" Tcl command. See the
 *	user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when a
 *	command name is computed at runtime, and is "for" or the name to which
 *	"for" was renamed: e.g.,
 *	"set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ForObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result, value;

    if (objc != 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
	return TCL_ERROR;
    }

    result = Tcl_EvalObjEx(interp, objv[1], 0);
    if (result != TCL_OK) {
	if (result == TCL_ERROR) {
	    Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
	}
	return result;
    }
    while (1) {
	/*
	 * We need to reset the result before passing it off to
	 * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
	 * to the result of the last evaluation.
	 */

	Tcl_ResetResult(interp);
	result = Tcl_ExprBooleanObj(interp, objv[2], &value);
	if (result != TCL_OK) {
	    return result;
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[4], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {

		TclFormatToErrorInfo(interp, "\n    (\"for\" body line %d)",
			interp->errorLine);

	    }
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[3], 0);
	if (result == TCL_BREAK) {
	    break;
	} else if (result != TCL_OK) {
	    if (result == TCL_ERROR) {
		Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
	    }
	    return result;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForeachObjCmd --
 *
 *	This object-based procedure is invoked to process the "foreach" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
    int i;			/* i selects a value list */
    int j, maxj;		/* Number of loop iterations */
    int v;			/* v selects a loop variable */
    int numLists;		/* Count of value lists */
    Tcl_Obj *bodyPtr;

    /*
     * We copy the argument object pointers into a local array to avoid
     * the problem that "objv" might become invalid. It is a pointer into
     * the evaluation stack and that stack might be grown and reallocated
     * if the loop body requires a large amount of stack space.
     */

#define NUM_ARGS 9
    Tcl_Obj *(argObjStorage[NUM_ARGS]);
    Tcl_Obj **argObjv = argObjStorage;

#define STATIC_LIST_SIZE 4
    int indexArray[STATIC_LIST_SIZE];
    int varcListArray[STATIC_LIST_SIZE];
    Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
    int argcListArray[STATIC_LIST_SIZE];
    Tcl_Obj **argvListArray[STATIC_LIST_SIZE];

    int *index = indexArray;		   /* Array of value list indices */
    int *varcList = varcListArray;	   /* # loop variables per list */
    Tcl_Obj ***varvList = varvListArray;   /* Array of var name lists */
    int *argcList = argcListArray;	   /* Array of value list sizes */
    Tcl_Obj ***argvList = argvListArray;   /* Array of value lists */

    if (objc < 4 || (objc%2 != 0)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"varList list ?varList list ...? command");
	return TCL_ERROR;
    }

    /*
     * Create the object argument array "argObjv". Make sure argObjv is
     * large enough to hold the objc arguments.
     */

    if (objc > NUM_ARGS) {
	argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
    }
    for (i = 0;  i < objc;  i++) {
	argObjv[i] = objv[i];
    }

    /*
     * Manage numList parallel value lists.
     * argvList[i] is a value list counted by argcList[i]
     * varvList[i] is the list of variables associated with the value list
     * varcList[i] is the number of variables associated with the value list
     * index[i] is the current pointer into the value list argvList[i]
     */

    numLists = (objc-2)/2;
    if (numLists > STATIC_LIST_SIZE) {
	index = (int *) ckalloc(numLists * sizeof(int));
	varcList = (int *) ckalloc(numLists * sizeof(int));
	varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
	argcList = (int *) ckalloc(numLists * sizeof(int));
	argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
    }
    for (i = 0;  i < numLists;  i++) {
	index[i] = 0;
	varcList[i] = 0;
	varvList[i] = (Tcl_Obj **) NULL;
	argcList[i] = 0;
	argvList[i] = (Tcl_Obj **) NULL;
    }

    /*
     * Break up the value lists and variable lists into elements
     */

    maxj = 0;
    for (i = 0;  i < numLists;  i++) {
	result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
	        &varcList[i], &varvList[i]);
	if (result != TCL_OK) {
	    goto done;
	}
	if (varcList[i] < 1) {
	    Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
	    result = TCL_ERROR;
	    goto done;
	}

	result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
	        &argcList[i], &argvList[i]);
	if (result != TCL_OK) {
	    goto done;
	}

	j = argcList[i] / varcList[i];
	if ((argcList[i] % varcList[i]) != 0) {
	    j++;
	}
	if (j > maxj) {
	    maxj = j;
	}
    }

    /*
     * Iterate maxj times through the lists in parallel
     * If some value lists run out of values, set loop vars to ""
     */

    bodyPtr = argObjv[objc-1];
    for (j = 0;  j < maxj;  j++) {
	for (i = 0;  i < numLists;  i++) {
	    /*
	     * Refetch the list members; we assume that the sizes are
	     * the same, but the array of elements might be different
	     * if the internal rep of the objects has been lost and
	     * recreated (it is too difficult to accurately tell when
	     * this happens, which can lead to some wierd crashes,
	     * like Bug #494348...)
	     */

	    result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
		    &varcList[i], &varvList[i]);
	    if (result != TCL_OK) {
		Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
	    }
	    result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
		    &argcList[i], &argvList[i]);
	    if (result != TCL_OK) {
		Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
	    }

	    for (v = 0;  v < varcList[i];  v++) {
		int k = index[i]++;
		Tcl_Obj *valuePtr, *varValuePtr;
		int isEmptyObj = 0;

		if (k < argcList[i]) {
		    valuePtr = argvList[i][k];
		} else {







|
|
|
|













|
|
|
|
|








|
|





|





|
|
|
|



















|



|

|










|














|
|



|
|

|
|
|
|
|
<













|







1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791

1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
    int i;			/* i selects a value list */
    int j, maxj;		/* Number of loop iterations */
    int v;			/* v selects a loop variable */
    int numLists;		/* Count of value lists */
    Tcl_Obj *bodyPtr;

    /*
     * We copy the argument object pointers into a local array to avoid the
     * problem that "objv" might become invalid. It is a pointer into the
     * evaluation stack and that stack might be grown and reallocated if the
     * loop body requires a large amount of stack space.
     */

#define NUM_ARGS 9
    Tcl_Obj *(argObjStorage[NUM_ARGS]);
    Tcl_Obj **argObjv = argObjStorage;

#define STATIC_LIST_SIZE 4
    int indexArray[STATIC_LIST_SIZE];
    int varcListArray[STATIC_LIST_SIZE];
    Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
    int argcListArray[STATIC_LIST_SIZE];
    Tcl_Obj **argvListArray[STATIC_LIST_SIZE];

    int *index = indexArray;		/* Array of value list indices */
    int *varcList = varcListArray;	/* # loop variables per list */
    Tcl_Obj ***varvList = varvListArray;/* Array of var name lists */
    int *argcList = argcListArray;	/* Array of value list sizes */
    Tcl_Obj ***argvList = argvListArray;/* Array of value lists */

    if (objc < 4 || (objc%2 != 0)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"varList list ?varList list ...? command");
	return TCL_ERROR;
    }

    /*
     * Create the object argument array "argObjv". Make sure argObjv is large
     * enough to hold the objc arguments.
     */

    if (objc > NUM_ARGS) {
	argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
    }
    for (i=0 ; i<objc ; i++) {
	argObjv[i] = objv[i];
    }

    /*
     * Manage numList parallel value lists.
     * argvList[i] is a value list counted by argcList[i]l;
     * varvList[i] is the list of variables associated with the value list;
     * varcList[i] is the number of variables associated with the value list;
     * index[i] is the current pointer into the value list argvList[i].
     */

    numLists = (objc-2)/2;
    if (numLists > STATIC_LIST_SIZE) {
	index = (int *) ckalloc(numLists * sizeof(int));
	varcList = (int *) ckalloc(numLists * sizeof(int));
	varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
	argcList = (int *) ckalloc(numLists * sizeof(int));
	argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
    }
    for (i = 0;  i < numLists;  i++) {
	index[i] = 0;
	varcList[i] = 0;
	varvList[i] = (Tcl_Obj **) NULL;
	argcList[i] = 0;
	argvList[i] = (Tcl_Obj **) NULL;
    }

    /*
     * Break up the value lists and variable lists into elements.
     */

    maxj = 0;
    for (i=0 ; i<numLists ; i++) {
	result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
		&varcList[i], &varvList[i]);
	if (result != TCL_OK) {
	    goto done;
	}
	if (varcList[i] < 1) {
	    Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
	    result = TCL_ERROR;
	    goto done;
	}

	result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
		&argcList[i], &argvList[i]);
	if (result != TCL_OK) {
	    goto done;
	}

	j = argcList[i] / varcList[i];
	if ((argcList[i] % varcList[i]) != 0) {
	    j++;
	}
	if (j > maxj) {
	    maxj = j;
	}
    }

    /*
     * Iterate maxj times through the lists in parallel. If some value lists
     * run out of values, set loop vars to ""
     */

    bodyPtr = argObjv[objc-1];
    for (j=0 ; j<maxj ; j++) {
	for (i=0 ; i<numLists ; i++) {
	    /*
	     * Refetch the list members; we assume that the sizes are the
	     * same, but the array of elements might be different if the
	     * internal rep of the objects has been lost and recreated (it is
	     * too difficult to accurately tell when this happens, which can
	     * lead to some wierd crashes, like Bug #494348...)

	     */

	    result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
		    &varcList[i], &varvList[i]);
	    if (result != TCL_OK) {
		Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
	    }
	    result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
		    &argcList[i], &argvList[i]);
	    if (result != TCL_OK) {
		Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
	    }

	    for (v=0 ; v<varcList[i] ; v++) {
		int k = index[i]++;
		Tcl_Obj *valuePtr, *varValuePtr;
		int isEmptyObj = 0;

		if (k < argcList[i]) {
		    valuePtr = argvList[i][k];
		} else {
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903

1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935

1936

1937
1938
1939
1940
1941
1942
1943
1944
1945

1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976

1977
1978
1979
1980
1981
1982












1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998

1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021

2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066

2067
2068
2069
2070
2071
2072
2073
		    }
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't set loop variable: \"",
			    TclGetString(varvList[i][v]), "\"", (char *) NULL);
		    result = TCL_ERROR;
		    goto done;
		}

	    }
	}

	result = Tcl_EvalObjEx(interp, bodyPtr, 0);
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {
                char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"foreach\" body line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
		break;
	    } else {
		break;
	    }
	}
    }
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }

    done:
    if (numLists > STATIC_LIST_SIZE) {
	ckfree((char *) index);
	ckfree((char *) varcList);
	ckfree((char *) argcList);
	ckfree((char *) varvList);
	ckfree((char *) argvList);
    }
    if (argObjv != argObjStorage) {
	ckfree((char *) argObjv);
    }
    return result;
#undef STATIC_LIST_SIZE
#undef NUM_ARGS
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FormatObjCmd --
 *
 *	This procedure is invoked to process the "format" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FormatObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{

    char *format;		/* Used to read characters from the format
				 * string. */
    int formatLen;		/* The length of the format string */
    char *endPtr;		/* Points to the last char in format array */
    char newFormat[43];		/* A new format specifier is generated here. */
    int width;			/* Field width from field specifier, or 0 if
				 * no width given. */
    int precision;		/* Field precision from field specifier, or 0
				 * if no precision given. */
    int size;			/* Number of bytes needed for result of
				 * conversion, based on type of conversion
				 * ("e", "s", etc.), width, and precision. */
    long intValue;		/* Used to hold value to pass to sprintf, if
				 * it's a one-word integer or char value */
    char *ptrValue = NULL;	/* Used to hold value to pass to sprintf, if
				 * it's a one-word value. */
    double doubleValue;		/* Used to hold value to pass to sprintf if
				 * it's a double value. */
    Tcl_WideInt wideValue;	/* Used to hold value to pass to sprintf if
				 * it's a 'long long' value. */
    int whichValue;		/* Indicates which of intValue, ptrValue,
				 * or doubleValue has the value to pass to
				 * sprintf, according to the following
				 * definitions: */
#   define INT_VALUE 0
#   define CHAR_VALUE 1
#   define PTR_VALUE 2
#   define DOUBLE_VALUE 3
#   define STRING_VALUE 4
#   define WIDE_VALUE 5
#   define MAX_FLOAT_SIZE 320


    Tcl_Obj *resultPtr;		/* Where result is stored finally. */

    char staticBuf[MAX_FLOAT_SIZE + 1];
				/* A static buffer to copy the format results 
				 * into */
    char *dst = staticBuf;      /* The buffer that sprintf writes into each
				 * time the format processes a specifier */
    int dstSize = MAX_FLOAT_SIZE;
				/* The size of the dst buffer */
    int noPercent;		/* Special case for speed:  indicates there's
				 * no field specifier, just a string to copy.*/

    int objIndex;		/* Index of argument to substitute next. */
    int gotXpg = 0;		/* Non-zero means that an XPG3 %n$-style
				 * specifier has been seen. */
    int gotSequential = 0;	/* Non-zero means that a regular sequential
				 * (non-XPG3) conversion specifier has been
				 * seen. */
    int useShort;		/* Value to be printed is short (half word). */
    char *end;			/* Used to locate end of numerical fields. */
    int stringLen = 0;		/* Length of string in characters rather
				 * than bytes.  Used for %s substitution. */
    int gotMinus;		/* Non-zero indicates that a minus flag has
				 * been seen in the current field. */
    int gotPrecision;		/* Non-zero indicates that a precision has
				 * been set for the current field. */
    int gotZero;		/* Non-zero indicates that a zero flag has
				 * been seen in the current field. */
    int useWide;		/* Value to be printed is Tcl_WideInt. */

    /*
     * This procedure is a bit nasty.  The goal is to use sprintf to
     * do most of the dirty work.  There are several problems:
     * 1. this procedure can't trust its arguments.
     * 2. we must be able to provide a large enough result area to hold
     *    whatever's generated.  This is hard to estimate.
     * 3. there's no way to move the arguments from objv to the call
     *    to sprintf in a reasonable way.  This is particularly nasty
     *    because some of the arguments may be two-word values (doubles
     *    and wide-ints).
     * So, what happens here is to scan the format string one % group
     * at a time, making many individual calls to sprintf.
     */


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
	return TCL_ERROR;
    }













    format = Tcl_GetStringFromObj(objv[1], &formatLen);
    endPtr = format + formatLen;
    resultPtr = Tcl_NewObj();
    objIndex = 2;

    while (format < endPtr) {
	register char *newPtr = newFormat;

	width = precision = noPercent = useShort = 0;
	gotZero = gotMinus = gotPrecision = 0;
	useWide = 0;
	whichValue = PTR_VALUE;

	/*
	 * Get rid of any characters before the next field specifier.
	 */

	if (*format != '%') {
	    ptrValue = format;
	    while ((*format != '%') && (format < endPtr)) {
		format++;
	    }
	    size = format - ptrValue;
	    noPercent = 1;
	    goto doField;
	}

	if (format[1] == '%') {
	    ptrValue = format;
	    size = 1;
	    noPercent = 1;
	    format += 2;
	    goto doField;
	}

	/*
	 * Parse off a field specifier, compute how many characters
	 * will be needed to store the result, and substitute for
	 * "*" size specifiers.
	 */

	*newPtr = '%';
	newPtr++;
	format++;
	if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
	    int tmp;

	    /*
	     * Check for an XPG3-style %n$ specification.  Note: there
	     * must not be a mixture of XPG3 specs and non-XPG3 specs
	     * in the same format string.
	     */

	    tmp = strtoul(format, &end, 10);	/* INTL: "C" locale. */
	    if (*end != '$') {
		goto notXpg;
	    }
	    format = end+1;
	    gotXpg = 1;
	    if (gotSequential) {
		goto mixedXPG;
	    }
	    objIndex = tmp+1;
	    if ((objIndex < 2) || (objIndex >= objc)) {
		goto badIndex;
	    }
	    goto xpgCheckDone;
	}

	notXpg:
	gotSequential = 1;
	if (gotXpg) {
	    goto mixedXPG;
	}

	xpgCheckDone:
	while ((*format == '-') || (*format == '#') || (*format == '0')
		|| (*format == ' ') || (*format == '+')) {
	    if (*format == '-') {
		gotMinus = 1;
	    }
	    if (*format == '0') {
		/*
		 * This will be handled by sprintf for numbers, but we
		 * need to do the char/string ones ourselves
		 */

		gotZero = 1;
	    }
	    *newPtr = *format;
	    newPtr++;
	    format++;
	}
	if (isdigit(UCHAR(*format))) {		/* INTL: Tcl source. */







<











<
|
|
<
<










|




















|
|


















>




















|
|


|
|
|
|
|
|
|

>

>

|

|



|
|
>








|
|









|
|


|
|
|
|
|
|
|

>






>
>
>
>
>
>
>
>
>
>
>
>
















>



















|
|
<

>







|
|
|


















|





|







|
|

>







1821
1822
1823
1824
1825
1826
1827

1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838

1839
1840


1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025

2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
		    }
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't set loop variable: \"",
			    TclGetString(varvList[i][v]), "\"", (char *) NULL);
		    result = TCL_ERROR;
		    goto done;
		}

	    }
	}

	result = Tcl_EvalObjEx(interp, bodyPtr, 0);
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {

		TclFormatToErrorInfo(interp,
			"\n    (\"foreach\" body line %d)", interp->errorLine);


		break;
	    } else {
		break;
	    }
	}
    }
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }

  done:
    if (numLists > STATIC_LIST_SIZE) {
	ckfree((char *) index);
	ckfree((char *) varcList);
	ckfree((char *) argcList);
	ckfree((char *) varvList);
	ckfree((char *) argvList);
    }
    if (argObjv != argObjStorage) {
	ckfree((char *) argObjv);
    }
    return result;
#undef STATIC_LIST_SIZE
#undef NUM_ARGS
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FormatObjCmd --
 *
 *	This procedure is invoked to process the "format" Tcl command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FormatObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
#ifndef NEW_FORMAT
    char *format;		/* Used to read characters from the format
				 * string. */
    int formatLen;		/* The length of the format string */
    char *endPtr;		/* Points to the last char in format array */
    char newFormat[43];		/* A new format specifier is generated here. */
    int width;			/* Field width from field specifier, or 0 if
				 * no width given. */
    int precision;		/* Field precision from field specifier, or 0
				 * if no precision given. */
    int size;			/* Number of bytes needed for result of
				 * conversion, based on type of conversion
				 * ("e", "s", etc.), width, and precision. */
    long intValue;		/* Used to hold value to pass to sprintf, if
				 * it's a one-word integer or char value */
    char *ptrValue = NULL;	/* Used to hold value to pass to sprintf, if
				 * it's a one-word value. */
    double doubleValue;		/* Used to hold value to pass to sprintf if
				 * it's a double value. */
    Tcl_WideInt wideValue;	/* Used to hold value to pass to sprintf if
				 * it's a 'long long' value. */
    int whichValue;		/* Indicates which of intValue, ptrValue, or
				 * doubleValue has the value to pass to
				 * sprintf, according to the following
				 * definitions: */
#define INT_VALUE	0
#define CHAR_VALUE	1
#define PTR_VALUE	2
#define DOUBLE_VALUE	3
#define STRING_VALUE	4
#define WIDE_VALUE	5
#define MAX_FLOAT_SIZE	320

#endif
    Tcl_Obj *resultPtr;		/* Where result is stored finally. */
#ifndef NEW_FORMAT
    char staticBuf[MAX_FLOAT_SIZE + 1];
				/* A static buffer to copy the format results
				 * into */
    char *dst = staticBuf;	/* The buffer that sprintf writes into each
				 * time the format processes a specifier */
    int dstSize = MAX_FLOAT_SIZE;
				/* The size of the dst buffer */
    int noPercent;		/* Special case for speed: indicates there's
				 * no field specifier, just a string to
				 * copy. */
    int objIndex;		/* Index of argument to substitute next. */
    int gotXpg = 0;		/* Non-zero means that an XPG3 %n$-style
				 * specifier has been seen. */
    int gotSequential = 0;	/* Non-zero means that a regular sequential
				 * (non-XPG3) conversion specifier has been
				 * seen. */
    int useShort;		/* Value to be printed is short (half word). */
    char *end;			/* Used to locate end of numerical fields. */
    int stringLen = 0;		/* Length of string in characters rather than
				 * bytes. Used for %s substitution. */
    int gotMinus;		/* Non-zero indicates that a minus flag has
				 * been seen in the current field. */
    int gotPrecision;		/* Non-zero indicates that a precision has
				 * been set for the current field. */
    int gotZero;		/* Non-zero indicates that a zero flag has
				 * been seen in the current field. */
    int useWide;		/* Value to be printed is Tcl_WideInt. */

    /*
     * This procedure is a bit nasty. The goal is to use sprintf to do most of
     * the dirty work. There are several problems:
     * 1. this procedure can't trust its arguments.
     * 2. we must be able to provide a large enough result area to hold
     *	  whatever's generated. This is hard to estimate.
     * 3. there's no way to move the arguments from objv to the call to
     *	  sprintf in a reasonable way. This is particularly nasty because
     *	  some of the arguments may be two-word values (doubles and
     *	  wide-ints).
     * So, what happens here is to scan the format string one % group at a
     * time, making many individual calls to sprintf.
     */
#endif

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
	return TCL_ERROR;
    }

#ifdef NEW_FORMAT
    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);
    if (TclAppendFormattedObjs(interp, resultPtr, Tcl_GetString(objv[1]),
	    objc-2, objv+2) != TCL_OK) {
	Tcl_DecrRefCount(resultPtr);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
#else
    format = Tcl_GetStringFromObj(objv[1], &formatLen);
    endPtr = format + formatLen;
    resultPtr = Tcl_NewObj();
    objIndex = 2;

    while (format < endPtr) {
	register char *newPtr = newFormat;

	width = precision = noPercent = useShort = 0;
	gotZero = gotMinus = gotPrecision = 0;
	useWide = 0;
	whichValue = PTR_VALUE;

	/*
	 * Get rid of any characters before the next field specifier.
	 */

	if (*format != '%') {
	    ptrValue = format;
	    while ((*format != '%') && (format < endPtr)) {
		format++;
	    }
	    size = format - ptrValue;
	    noPercent = 1;
	    goto doField;
	}

	if (format[1] == '%') {
	    ptrValue = format;
	    size = 1;
	    noPercent = 1;
	    format += 2;
	    goto doField;
	}

	/*
	 * Parse off a field specifier, compute how many characters will be
	 * needed to store the result, and substitute for "*" size specifiers.

	 */

	*newPtr = '%';
	newPtr++;
	format++;
	if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
	    int tmp;

	    /*
	     * Check for an XPG3-style %n$ specification. Note: there must not
	     * be a mixture of XPG3 specs and non-XPG3 specs in the same
	     * format string.
	     */

	    tmp = strtoul(format, &end, 10);	/* INTL: "C" locale. */
	    if (*end != '$') {
		goto notXpg;
	    }
	    format = end+1;
	    gotXpg = 1;
	    if (gotSequential) {
		goto mixedXPG;
	    }
	    objIndex = tmp+1;
	    if ((objIndex < 2) || (objIndex >= objc)) {
		goto badIndex;
	    }
	    goto xpgCheckDone;
	}

    notXpg:
	gotSequential = 1;
	if (gotXpg) {
	    goto mixedXPG;
	}

    xpgCheckDone:
	while ((*format == '-') || (*format == '#') || (*format == '0')
		|| (*format == ' ') || (*format == '+')) {
	    if (*format == '-') {
		gotMinus = 1;
	    }
	    if (*format == '0') {
		/*
		 * This will be handled by sprintf for numbers, but we need to
		 * do the char/string ones ourselves.
		 */

		gotZero = 1;
	    }
	    *newPtr = *format;
	    newPtr++;
	    format++;
	}
	if (isdigit(UCHAR(*format))) {		/* INTL: Tcl source. */
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137

2138
2139
2140
2141

2142
2143
2144
2145
2146
2147
2148
		newPtr++;
	    }
	    objIndex++;
	    format++;
	}
	if (width > 100000) {
	    /*
	     * Don't allow arbitrarily large widths:  could cause core
	     * dump when we try to allocate a zillion bytes of memory
	     * below.
	     */

	    width = 100000;
	} else if (width < 0) {
	    width = 0;
	}
	if (width != 0) {
	    TclFormatInt(newPtr, width);	/* INTL: printf format. */
	    while (*newPtr != 0) {
		newPtr++;
	    }
	}
	if (*format == '.') {
	    *newPtr = '.';
	    newPtr++;
	    format++;
	    gotPrecision = 1;
	}
	if (isdigit(UCHAR(*format))) {		/* INTL: Tcl source. */
	    precision = strtoul(format, &end, 10);  /* INTL: "C" locale. */
	    format = end;
	} else if (*format == '*') {
	    if (objIndex >= objc) {
		goto badIndex;
	    }
	    if (Tcl_GetIntFromObj(interp,	/* INTL: Tcl source. */
		    objv[objIndex], &precision) != TCL_OK) {
		goto fmtError;
	    }
	    objIndex++;
	    format++;
	}
	if (gotPrecision) {
	    TclFormatInt(newPtr, precision);	/* INTL: printf format. */
	    while (*newPtr != 0) {
		newPtr++;
	    }
	}
	if (*format == 'l') {
	    useWide = 1;

	    /*
	     * Only add a 'll' modifier for integer values as it makes
	     * some libc's go into spasm otherwise.  [Bug #702622]
	     */

	    switch (format[1]) {
	    case 'i':
	    case 'd':
	    case 'o':
	    case 'u':
	    case 'x':
	    case 'X':







|
|
<



















|




















>

|
|

>







2095
2096
2097
2098
2099
2100
2101
2102
2103

2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
		newPtr++;
	    }
	    objIndex++;
	    format++;
	}
	if (width > 100000) {
	    /*
	     * Don't allow arbitrarily large widths: could cause core dump
	     * when we try to allocate a zillion bytes of memory below.

	     */

	    width = 100000;
	} else if (width < 0) {
	    width = 0;
	}
	if (width != 0) {
	    TclFormatInt(newPtr, width);	/* INTL: printf format. */
	    while (*newPtr != 0) {
		newPtr++;
	    }
	}
	if (*format == '.') {
	    *newPtr = '.';
	    newPtr++;
	    format++;
	    gotPrecision = 1;
	}
	if (isdigit(UCHAR(*format))) {		/* INTL: Tcl source. */
	    precision = strtoul(format, &end, 10);	/* INTL: "C" locale. */
	    format = end;
	} else if (*format == '*') {
	    if (objIndex >= objc) {
		goto badIndex;
	    }
	    if (Tcl_GetIntFromObj(interp,	/* INTL: Tcl source. */
		    objv[objIndex], &precision) != TCL_OK) {
		goto fmtError;
	    }
	    objIndex++;
	    format++;
	}
	if (gotPrecision) {
	    TclFormatInt(newPtr, precision);	/* INTL: printf format. */
	    while (*newPtr != 0) {
		newPtr++;
	    }
	}
	if (*format == 'l') {
	    useWide = 1;

	    /*
	     * Only add a 'll' modifier for integer values as it makes some
	     * libc's go into spasm otherwise. [Bug #702622]
	     */

	    switch (format[1]) {
	    case 'i':
	    case 'd':
	    case 'o':
	    case 'u':
	    case 'x':
	    case 'X':
2180
2181
2182
2183
2184
2185
2186

2187
2188
2189
2190





2191

2192
2193
2194
2195

2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
		break;
	    }
	    if (Tcl_GetLongFromObj(interp,	/* INTL: Tcl source. */
		    objv[objIndex], &intValue) != TCL_OK) {
		goto fmtError;
	    }
#if (LONG_MAX > INT_MAX)

	    /*
	     * Add the 'l' for long format type because we are on an
	     * LP64 archtecture and we are really going to pass a long
	     * argument to sprintf.





	     */

	    newPtr++;
	    *newPtr = 0;
	    newPtr[-1] = newPtr[-2];
	    newPtr[-2] = 'l';

#endif /* LONG_MAX > INT_MAX */
	    whichValue = INT_VALUE;
	    size = 40 + precision;
	    break;
	case 's':
	    /*
	     * Compute the length of the string in characters and add
	     * any additional space required by the field width.  All
	     * of the extra characters will be spaces, so one byte per
	     * character is adequate.
	     */

	    whichValue = STRING_VALUE;
	    ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
	    stringLen = Tcl_NumUtfChars(ptrValue, size);
	    if (gotPrecision && (precision < stringLen)) {
		stringLen = precision;







>
|
|
|
|
>
>
>
>
>
|
>
|
|
|
|
>






|
|
|
|







2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
		break;
	    }
	    if (Tcl_GetLongFromObj(interp,	/* INTL: Tcl source. */
		    objv[objIndex], &intValue) != TCL_OK) {
		goto fmtError;
	    }
#if (LONG_MAX > INT_MAX)
	    if (!useShort) {
		/*
		 * Add the 'l' for long format type because we are on an LP64
		 * archtecture and we are really going to pass a long argument
		 * to sprintf.
		 *
		 * Do not add this if we're going to pass in a short (i.e. if
		 * we've got an 'h' modifier already in the string); some libc
		 * implementations of sprintf() do not like it at all. [Bug
		 * 1154163]
		 */

		newPtr++;
		*newPtr = 0;
		newPtr[-1] = newPtr[-2];
		newPtr[-2] = 'l';
	    }
#endif /* LONG_MAX > INT_MAX */
	    whichValue = INT_VALUE;
	    size = 40 + precision;
	    break;
	case 's':
	    /*
	     * Compute the length of the string in characters and add any
	     * additional space required by the field width. All of the extra
	     * characters will be spaces, so one byte per character is
	     * adequate.
	     */

	    whichValue = STRING_VALUE;
	    ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
	    stringLen = Tcl_NumUtfChars(ptrValue, size);
	    if (gotPrecision && (precision < stringLen)) {
		stringLen = precision;
2225
2226
2227
2228
2229
2230
2231
2232
2233

2234
2235
2236
2237
2238
2239
2240
	    size = width + TCL_UTF_MAX;
	    break;
	case 'e':
	case 'E':
	case 'f':
	case 'g':
	case 'G':
	    if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
		    objv[objIndex], &doubleValue) != TCL_OK) {

		goto fmtError;
	    }
	    whichValue = DOUBLE_VALUE;
	    size = MAX_FLOAT_SIZE;
	    if (precision > 10) {
		size += precision;
	    }







|

>







2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
	    size = width + TCL_UTF_MAX;
	    break;
	case 'e':
	case 'E':
	case 'f':
	case 'g':
	case 'G':
	    if (Tcl_GetDoubleFromObj(interp,	/* INTL: Tcl source. */
		    objv[objIndex], &doubleValue) != TCL_OK) {
		/*TODO: figure out ACCEPT_NAN */
		goto fmtError;
	    }
	    whichValue = DOUBLE_VALUE;
	    size = MAX_FLOAT_SIZE;
	    if (precision > 10) {
		size += precision;
	    }
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
	    goto fmtError;
	}
	}
	objIndex++;
	format++;

	/*
	 * Make sure that there's enough space to hold the formatted
	 * result, then format it.
	 */

	doField:
	if (width > size) {
	    size = width;
	}
	if (noPercent) {
	    Tcl_AppendToObj(resultPtr, ptrValue, size);
	} else {
	    if (size > dstSize) {
	        if (dst != staticBuf) {
		    ckfree(dst);
		}
		dst = (char *) ckalloc((unsigned) (size + 1));
		dstSize = size;
	    }
	    switch (whichValue) {
	    case DOUBLE_VALUE:







|
|


|







|







2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
	    goto fmtError;
	}
	}
	objIndex++;
	format++;

	/*
	 * Make sure that there's enough space to hold the formatted result,
	 * then format it.
	 */

    doField:
	if (width > size) {
	    size = width;
	}
	if (noPercent) {
	    Tcl_AppendToObj(resultPtr, ptrValue, size);
	} else {
	    if (size > dstSize) {
		if (dst != staticBuf) {
		    ckfree(dst);
		}
		dst = (char *) ckalloc((unsigned) (size + 1));
		dstSize = size;
	    }
	    switch (whichValue) {
	    case DOUBLE_VALUE:
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
		if (!gotMinus) {
		    while (pad > 0) {
			*ptr++ = padChar;
			pad--;
		    }
		}

		size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; 
		if (size) {
		    memcpy(ptr, ptrValue, (size_t) size);
		    ptr += size;
		}
		while (pad > 0) {
		    *ptr++ = padChar;
		    pad--;







|







2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
		if (!gotMinus) {
		    while (pad > 0) {
			*ptr++ = padChar;
			pad--;
		    }
		}

		size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
		if (size) {
		    memcpy(ptr, ptrValue, (size_t) size);
		    ptr += size;
		}
		while (pad > 0) {
		    *ptr++ = padChar;
		    pad--;
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372

2373









    Tcl_SetObjResult(interp, resultPtr);
    if (dst != staticBuf) {
	ckfree(dst);
    }
    return TCL_OK;

    mixedXPG:
    Tcl_SetResult(interp, 
	    "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
    goto fmtError;

    badIndex:
    if (gotXpg) {
	Tcl_SetResult(interp, 
		"\"%n$\" argument index out of range", TCL_STATIC);
    } else {
	Tcl_SetResult(interp, 
		"not enough arguments for all format specifiers", TCL_STATIC);
    }

    fmtError:
    if (dst != staticBuf) {
	ckfree(dst);
    }
    Tcl_DecrRefCount(resultPtr);
    return TCL_ERROR;

}















|
|



|

|


|



|





>

>
>
>
>
>
>
>
>
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399

    Tcl_SetObjResult(interp, resultPtr);
    if (dst != staticBuf) {
	ckfree(dst);
    }
    return TCL_OK;

  mixedXPG:
    Tcl_SetResult(interp,
	    "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
    goto fmtError;

  badIndex:
    if (gotXpg) {
	Tcl_SetResult(interp,
		"\"%n$\" argument index out of range", TCL_STATIC);
    } else {
	Tcl_SetResult(interp,
		"not enough arguments for all format specifiers", TCL_STATIC);
    }

  fmtError:
    if (dst != staticBuf) {
	ckfree(dst);
    }
    Tcl_DecrRefCount(resultPtr);
    return TCL_ERROR;
#endif
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCmdIL.c.

1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37








38
39
40
41
42
43
44
45
46
47
48


49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
/* 
 * tclCmdIL.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	I through L.  It contains only commands in the generic core
 *	(i.e. those that don't depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.70 2004/12/01 23:18:49 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 * During execution of the "lsort" command, structures of the following
 * type are used to arrange the objects being sorted into a collection
 * of linked lists.
 */

typedef struct SortElement {
    Tcl_Obj *objPtr;			/* Object being sorted. */
    int count;				/* number of same elements in list */
    struct SortElement *nextPtr;	/* Next element in the list, or
					 * NULL for end of list. */
} SortElement;

/*








 * The "lsort" command needs to pass certain information down to the
 * function that compares two list elements, and the comparison function
 * needs to pass success or failure information back up to the top-level
 * "lsort" command.  The following structure is used to pass this
 * information.
 */

typedef struct SortInfo {
    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode.  One of SORTMODE_*
				 * values defined below */


    Tcl_Obj *compareCmdPtr;     /* The Tcl comparison command when sortMode
				 * is SORTMODE_COMMAND.  Pre-initialized to
				 * hold base of command.*/
    int *indexv;		/* If the -index option was specified, this
				 * holds the indexes contained in the list
				 * supplied as an argument to that option.
				 * NULL if no indexes supplied, and points
				 * to singleIndex field when only one
				 * supplied. */
    int indexc;			/* Number of indexes in indexv array. */
    int singleIndex;		/* Static space for common index case. */
    Tcl_Interp *interp;		/* The interpreter in which the sortis
				 * being done. */
    int resultCode;		/* Completion code for the lsort command.
				 * If an error occurs during the sort this
				 * is changed from TCL_OK to TCL_ERROR. */
} SortInfo;

/*
 * The "sortMode" field of the SortInfo structure can take on any of the
 * following values.
 */

#define SORTMODE_ASCII      0
#define SORTMODE_INTEGER    1
#define SORTMODE_REAL       2
#define SORTMODE_COMMAND    3
#define SORTMODE_DICTIONARY 4

/*
 * Magic values for the index field of the SortInfo structure.
 * Note that the index "end-1" will be translated to SORTIDX_END-1, etc.
 */

#define SORTIDX_NONE	-1		/* Not indexed; use whole value. */
#define SORTIDX_END	-2		/* Indexed from end. */

/*
 * Forward declarations for procedures defined in this file:
 */

static void		AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *listPtr, CONST char *pattern,
			    int includeLinks));
static int		DictionaryCompare _ANSI_ARGS_((char *left,
			    char *right));
static int		InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoNameOfExecutableCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static SortElement *    MergeSort _ANSI_ARGS_((SortElement *headPt,
			    SortInfo *infoPtr));
static SortElement *    MergeLists _ANSI_ARGS_((SortElement *leftPtr,
			    SortElement *rightPtr, SortInfo *infoPtr));
static int		SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
			    Tcl_Obj *second, SortInfo *infoPtr));
static Tcl_Obj *	SelectObjFromSublist _ANSI_ARGS_((Tcl_Obj *firstPtr,
			    SortInfo *infoPtr));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_IfObjCmd --
 *
 *	This procedure is invoked to process the "if" Tcl command.
 *	See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when
 *	a command name is computed at runtime, and is "if" or the name
 *	to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_IfObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int thenScriptIndex = 0;	/* then script to be evaled after syntax check */

    int i, result, value;
    char *clause;
    i = 1;
    while (1) {
	/*
	 * At this point in the loop, objv and objc refer to an expression
	 * to test, either for the main expression or an expression
	 * following an "elseif".  The arguments after the expression must
	 * be "then" (optional) and a script to execute if the expression is
	 * true.
	 */

	if (i >= objc) {
	    clause = TclGetString(objv[i-1]);
	    Tcl_AppendResult(interp, "wrong # args: no expression after \"",
		    clause, "\" argument", (char *) NULL);
	    return TCL_ERROR;
|


|
|
|
|






>

|
|

|






|
|
|



|
|
|
|



>
>
>
>
>
>
>
>
|
|
|
|
<




|
|
>
>
|
|
|



|
|



|
|
|
|
|







|
|
|
|
|


|
|

>
|
|





|
<
|
|
<
<
|
|
<
|
|
|
<
|
|
<
|
|
<
|
|
<
|
|
<
|
|
<
|
|
<
|
|
<
|
<
|
|
|
<
|
|
<
|
|
<
|
|
|
|
|
<
|
<
|
|
|
<
|
|
<
|
|
<
|
<
|
|
|
<
|
|
|
|
|
|
<






|
|

|
|
|


















|
>





|
|
|
|
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

101
102


103
104

105
106
107

108
109

110
111

112
113

114
115

116
117

118
119

120
121

122

123
124
125

126
127

128
129

130
131
132
133
134

135

136
137
138

139
140

141
142

143

144
145
146

147
148
149
150
151
152

153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

194
195
196
197
198
199
200
/*
 * tclCmdIL.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters I through L. It
 *	contains only commands in the generic core (i.e. those that don't
 *	depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2005 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.9 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 * During execution of the "lsort" command, structures of the following type
 * are used to arrange the objects being sorted into a collection of linked
 * lists.
 */

typedef struct SortElement {
    Tcl_Obj *objPtr;		/* Object being sorted. */
    int count;			/* number of same elements in list */
    struct SortElement *nextPtr;/* Next element in the list, or NULL for end
				 * of list. */
} SortElement;

/*
 * These function pointer types are used with the "lsearch" and "lsort"
 * commands to facilitate the "-nocase" option.
 */

typedef int (*SortStrCmpFn_t) (const char *, const char *);
typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);

/*
 * The "lsort" command needs to pass certain information down to the function
 * that compares two list elements, and the comparison function needs to pass
 * success or failure information back up to the top-level "lsort" command.
 * The following structure is used to pass this information.

 */

typedef struct SortInfo {
    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode. One of SORTMODE_* values
				 * defined below */
    SortStrCmpFn_t strCmpFn;	/* Basic string compare command (used with
				 * ASCII mode). */
    Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
				 * SORTMODE_COMMAND. Pre-initialized to hold
				 * base of command.*/
    int *indexv;		/* If the -index option was specified, this
				 * holds the indexes contained in the list
				 * supplied as an argument to that option.
				 * NULL if no indexes supplied, and points to
				 * singleIndex field when only one
				 * supplied. */
    int indexc;			/* Number of indexes in indexv array. */
    int singleIndex;		/* Static space for common index case. */
    Tcl_Interp *interp;		/* The interpreter in which the sort is being
				 * done. */
    int resultCode;		/* Completion code for the lsort command. If
				 * an error occurs during the sort this is
				 * changed from TCL_OK to TCL_ERROR. */
} SortInfo;

/*
 * The "sortMode" field of the SortInfo structure can take on any of the
 * following values.
 */

#define SORTMODE_ASCII		0
#define SORTMODE_INTEGER	1
#define SORTMODE_REAL		2
#define SORTMODE_COMMAND	3
#define SORTMODE_DICTIONARY	4

/*
 * Magic values for the index field of the SortInfo structure. Note that the
 * index "end-1" will be translated to SORTIDX_END-1, etc.
 */

#define SORTIDX_NONE	-1	/* Not indexed; use whole value. */
#define SORTIDX_END	-2	/* Indexed from end. */

/*
 * Forward declarations for procedures defined in this file:
 */

static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,

			    CONST char *pattern, int includeLinks);
static int		DictionaryCompare(char *left, char *right);


static int		InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);

static int		InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoExistsCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);

static int		InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoNameOfExecutableCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
static int		InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);

static int		InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);

static int		InfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static SortElement *    MergeSort(SortElement *headPt, SortInfo *infoPtr);

static SortElement *    MergeLists(SortElement *leftPtr, SortElement *rightPtr,
			    SortInfo *infoPtr);
static int		SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second,
			    SortInfo *infoPtr);
static Tcl_Obj *	SelectObjFromSublist(Tcl_Obj *firstPtr,
			    SortInfo *infoPtr);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_IfObjCmd --
 *
 *	This procedure is invoked to process the "if" Tcl command. See the
 *	user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when a
 *	command name is computed at runtime, and is "if" or the name to which
 *	"if" was renamed: e.g., "set z if; $z 1 {puts foo}"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_IfObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int thenScriptIndex = 0;		/* "then" script to be evaled after
					 * syntax check */
    int i, result, value;
    char *clause;
    i = 1;
    while (1) {
	/*
	 * At this point in the loop, objv and objc refer to an expression to
	 * test, either for the main expression or an expression following an
	 * "elseif". The arguments after the expression must be "then"
	 * (optional) and a script to execute if the expression is true.

	 */

	if (i >= objc) {
	    clause = TclGetString(objv[i-1]);
	    Tcl_AppendResult(interp, "wrong # args: no expression after \"",
		    clause, "\" argument", (char *) NULL);
	    return TCL_ERROR;
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
	}
	if (value) {
	    thenScriptIndex = i;
	    value = 0;
	}

	/*
	 * The expression evaluated to false.  Skip the command, then
	 * see if there is an "else" or "elseif" clause.
	 */

	i++;
	if (i >= objc) {
	    if (thenScriptIndex) {
		return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
	    }
	    return TCL_OK;
	}
	clause = TclGetString(objv[i]);
	if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
	    i++;
	    continue;
	}
	break;
    }

    /*
     * Couldn't find a "then" or "elseif" clause to execute.  Check now
     * for an "else" clause.  We know that there's at least one more
     * argument when we get here.
     */

    if (strcmp(clause, "else") == 0) {
	i++;
	if (i >= objc) {
	    Tcl_AppendResult(interp,
		    "wrong # args: no script following \"else\" argument",







|
|


















|
|
|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
	}
	if (value) {
	    thenScriptIndex = i;
	    value = 0;
	}

	/*
	 * The expression evaluated to false. Skip the command, then see if
	 * there is an "else" or "elseif" clause.
	 */

	i++;
	if (i >= objc) {
	    if (thenScriptIndex) {
		return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
	    }
	    return TCL_OK;
	}
	clause = TclGetString(objv[i]);
	if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
	    i++;
	    continue;
	}
	break;
    }

    /*
     * Couldn't find a "then" or "elseif" clause to execute. Check now for an
     * "else" clause. We know that there's at least one more argument when we
     * get here.
     */

    if (strcmp(clause, "else") == 0) {
	i++;
	if (i >= objc) {
	    Tcl_AppendResult(interp,
		    "wrong # args: no script following \"else\" argument",
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

317
318
319
320


321
322
323
324
325
326

327
328
329
330
331
332
333
334
335
336

337
338
339
340
341
342
343
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IncrObjCmd --
 *
 *	This procedure is invoked to process the "incr" Tcl command.
 *	See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when
 *	a command name is computed at runtime, and is "incr" or the name
 *	to which "incr" was renamed: e.g., "set z incr; $z i -1"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
int
Tcl_IncrObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{

    long incrAmount = 1;
    Tcl_WideInt wideIncrAmount;
    Tcl_Obj *newValuePtr;
    int isWide = 0;



    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
	return TCL_ERROR;
    }


    /*
     * Calculate the amount to increment by.
     */

    if (objc == 3) {
	/*
	 * Need to be a bit cautious to ensure that [expr]-like rules
	 * are enforced for interpretation of wide integers, despite
	 * the fact that the underlying API itself is a 'long' only one.
	 */

	if (objv[2]->typePtr == &tclIntType) {
	    incrAmount = objv[2]->internalRep.longValue;
	    isWide = 0;
	} else if (objv[2]->typePtr == &tclWideIntType) {
	    wideIncrAmount = objv[2]->internalRep.wideValue;
	    isWide = 1;
	} else {







|
|

|
|
|


















>


<

>
>






>






|
|
|

>







273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306

307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IncrObjCmd --
 *
 *	This procedure is invoked to process the "incr" Tcl command. See the
 *	user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when a
 *	command name is computed at runtime, and is "incr" or the name to
 *	which "incr" was renamed: e.g., "set z incr; $z i -1"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
int
Tcl_IncrObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
#if 0
    long incrAmount = 1;
    Tcl_WideInt wideIncrAmount;

    int isWide = 0;
#endif
    Tcl_Obj *newValuePtr, *incrPtr;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
	return TCL_ERROR;
    }

#if 0
    /*
     * Calculate the amount to increment by.
     */

    if (objc == 3) {
	/*
	 * Need to be a bit cautious to ensure that [expr]-like rules are
	 * enforced for interpretation of wide integers, despite the fact that
	 * the underlying API itself is a 'long' only one.
	 */

	if (objv[2]->typePtr == &tclIntType) {
	    incrAmount = objv[2]->internalRep.longValue;
	    isWide = 0;
	} else if (objv[2]->typePtr == &tclWideIntType) {
	    wideIncrAmount = objv[2]->internalRep.wideValue;
	    isWide = 1;
	} else {
365
366
367
368
369
370
371












372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    if (isWide) {
	newValuePtr = TclIncrWideVar2(interp, objv[1], (Tcl_Obj *) NULL,
		wideIncrAmount, TCL_LEAVE_ERR_MSG);
    } else {
	newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL,
		incrAmount, TCL_LEAVE_ERR_MSG);
    }












    if (newValuePtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Set the interpreter's object result to refer to the variable's new
     * value object.
     */

    Tcl_SetObjResult(interp, newValuePtr);
    return TCL_OK; 
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InfoObjCmd --
 *
 *	This procedure is invoked to process the "info" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







>
>
>
>
>
>
>
>
>
>
>
>










|







|
|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
    if (isWide) {
	newValuePtr = TclIncrWideVar2(interp, objv[1], (Tcl_Obj *) NULL,
		wideIncrAmount, TCL_LEAVE_ERR_MSG);
    } else {
	newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL,
		incrAmount, TCL_LEAVE_ERR_MSG);
    }
#else
    if (objc == 3) {
	incrPtr = objv[2];
    } else {
	incrPtr = Tcl_NewIntObj(1);
    }
    Tcl_IncrRefCount(incrPtr);
    newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
	    incrPtr, TCL_LEAVE_ERR_MSG);
    Tcl_DecrRefCount(incrPtr);

#endif
    if (newValuePtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Set the interpreter's object result to refer to the variable's new
     * value object.
     */

    Tcl_SetObjResult(interp, newValuePtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InfoObjCmd --
 *
 *	This procedure is invoked to process the "info" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
}

/*
 *----------------------------------------------------------------------
 *
 * InfoArgsCmd --
 *
 *      Called to implement the "info args" command that returns the
 *      argument list for a procedure. Handles the following syntax:
 *
 *	    info args procName
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoArgsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|




|


|
|







506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
}

/*
 *----------------------------------------------------------------------
 *
 * InfoArgsCmd --
 *
 *	Called to implement the "info args" command that returns the argument
 *	list for a procedure. Handles the following syntax:
 *
 *	    info args procName
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoArgsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
}

/*
 *----------------------------------------------------------------------
 *
 * InfoBodyCmd --
 *
 *      Called to implement the "info body" command that returns the body
 *      for a procedure. Handles the following syntax:
 *
 *	    info body procName
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoBodyCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|




|


|
|







568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
}

/*
 *----------------------------------------------------------------------
 *
 * InfoBodyCmd --
 *
 *	Called to implement the "info body" command that returns the body for
 *	a procedure. Handles the following syntax:
 *
 *	    info body procName
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoBodyCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626

627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
    procPtr = TclFindProc(iPtr, name);
    if (procPtr == NULL) {
	Tcl_AppendResult(interp, "\"", name,
		"\" isn't a procedure", (char *) NULL);
	return TCL_ERROR;
    }

    /* 
     * Here we used to return procPtr->bodyPtr, except when the body was
     * bytecompiled - in that case, the return was a copy of the body's
     * string rep. In order to better isolate the implementation details
     * of the compiler/engine subsystem, we now always return a copy of 
     * the string rep. It is important to return a copy so that later 
     * manipulations of the object do not invalidate the internal rep.
     */

    bodyPtr = procPtr->bodyPtr;
    if (bodyPtr->bytes == NULL) {
	/*
	 * The string rep might not be valid if the procedure has
	 * never been run before.  [Bug #545644]
	 */

	(void) Tcl_GetString(bodyPtr);
    }
    resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);

    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoCmdCountCmd --
 *
 *      Called to implement the "info cmdcount" command that returns the
 *      number of commands that have been executed. Handles the following
 *      syntax:
 *
 *	    info cmdcount
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoCmdCountCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|

|
|
|
|
|





|
|

>













|
|
|




|


|
|







608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
    procPtr = TclFindProc(iPtr, name);
    if (procPtr == NULL) {
	Tcl_AppendResult(interp, "\"", name,
		"\" isn't a procedure", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Here we used to return procPtr->bodyPtr, except when the body was
     * bytecompiled - in that case, the return was a copy of the body's string
     * rep. In order to better isolate the implementation details of the
     * compiler/engine subsystem, we now always return a copy of the string
     * rep. It is important to return a copy so that later manipulations of
     * the object do not invalidate the internal rep.
     */

    bodyPtr = procPtr->bodyPtr;
    if (bodyPtr->bytes == NULL) {
	/*
	 * The string rep might not be valid if the procedure has never been
	 * run before. [Bug #545644]
	 */

	(void) Tcl_GetString(bodyPtr);
    }
    resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);

    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoCmdCountCmd --
 *
 *	Called to implement the "info cmdcount" command that returns the
 *	number of commands that have been executed. Handles the following
 *	syntax:
 *
 *	    info cmdcount
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoCmdCountCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714

715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
}

/*
 *----------------------------------------------------------------------
 *
 * InfoCommandsCmd --
 *
 *	Called to implement the "info commands" command that returns the
 *	list of commands in the interpreter that match an optional pattern.
 *	The pattern, if any, consists of an optional sequence of namespace
 *	names separated by "::" qualifiers, which is followed by a
 *	glob-style pattern that restricts which commands are returned.
 *	Handles the following syntax:
 *
 *	    info commands ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoCommandsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *cmdName, *pattern;
    CONST char *simplePattern;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
    Tcl_Command cmd;


    /*
     * Get the pattern and find the "effective namespace" in which to
     * list commands.
     */

    if (objc == 2) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an
	 * error was found while parsing the pattern, return it. Otherwise,
	 * if the namespace wasn't found, just leave nsPtr NULL: we will
	 * return an empty list since no commands there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

	pattern = TclGetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0,
		&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);







|
|
|
|
|
|




|


|
|

















|

|

>


|
|









|
|
|
|







676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
}

/*
 *----------------------------------------------------------------------
 *
 * InfoCommandsCmd --
 *
 *	Called to implement the "info commands" command that returns the list
 *	of commands in the interpreter that match an optional pattern. The
 *	pattern, if any, consists of an optional sequence of namespace names
 *	separated by "::" qualifiers, which is followed by a glob-style
 *	pattern that restricts which commands are returned. Handles the
 *	following syntax:
 *
 *	    info commands ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoCommandsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *cmdName, *pattern;
    CONST char *simplePattern;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
    Tcl_Command cmd;
    int i;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * commands.
     */

    if (objc == 2) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no commands there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

	pattern = TclGetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0,
		&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770

771
772
773
774
775
776
777
778
779
780
781



782









783






784

785
786
787
788


789
790






791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830

























































































831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
     */

    if (nsPtr == NULL) {
	return TCL_OK;
    }

    /*
     * Scan through the effective namespace's command table and create a
     * list with all commands that match the pattern. If a specific
     * namespace was requested in the pattern, qualify the command names
     * with the namespace name.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

    if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
	/*
	 * Special case for when the pattern doesn't include any of
	 * glob's special characters. This lets us avoid scans of any
	 * hash tables.
	 */

	entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
	if (entryPtr != NULL) {
	    if (specificNsInPattern) {
		cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
		elemObjPtr = Tcl_NewObj();
		Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
	    } else {
		cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
		elemObjPtr = Tcl_NewStringObj(cmdName, -1);
	    }
	    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);



	} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {









	    entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,






		    simplePattern);

	    if (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(cmdName, -1));


	    }
	}






    } else {
	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	while (entryPtr != NULL) {
	    cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		if (specificNsInPattern) {
		    cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		}
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
	 * If the effective namespace isn't the global :: namespace, and a
	 * specific namespace wasn't requested in the pattern, then add in
	 * all global :: commands that match the simple pattern. Of course,
	 * we add in only those commands that aren't hidden by a command in
	 * the effective namespace.
	 */

	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr,
				Tcl_NewStringObj(cmdName, -1));
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}

























































































    }

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoCompleteCmd --
 *
 *      Called to implement the "info complete" command that determines
 *      whether a string is a complete Tcl command. Handles the following
 *      syntax:
 *
 *	    info complete command
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoCompleteCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|
|






|
|
<

>











>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
>

|


>
>


>
>
>
>
>
>
|



















|
|
|
|
















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











|
|
|




|


|
|







755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773

774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
     */

    if (nsPtr == NULL) {
	return TCL_OK;
    }

    /*
     * Scan through the effective namespace's command table and create a list
     * with all commands that match the pattern. If a specific namespace was
     * requested in the pattern, qualify the command names with the namespace
     * name.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

    if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
	/*
	 * Special case for when the pattern doesn't include any of glob's
	 * special characters. This lets us avoid scans of any hash tables.

	 */

	entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
	if (entryPtr != NULL) {
	    if (specificNsInPattern) {
		cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
		elemObjPtr = Tcl_NewObj();
		Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
	    } else {
		cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
		elemObjPtr = Tcl_NewStringObj(cmdName, -1);
	    }
	    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    Tcl_SetObjResult(interp, listPtr);
	    return TCL_OK;
	}
	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    Tcl_HashTable *tablePtr = NULL;	/* Quell warning */

	    for (i=0 ; i<nsPtr->commandPathLength ; i++) {
		Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr;

		if (pathNsPtr == NULL) {
		    continue;
		}
		tablePtr = &pathNsPtr->cmdTable;
		entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
		if (entryPtr != NULL) {
		    break;
		}
	    }
	    if (entryPtr == NULL) {
		tablePtr = &globalNsPtr->cmdTable;
		entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
	    }
	    if (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(tablePtr, entryPtr);
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(cmdName, -1));
		Tcl_SetObjResult(interp, listPtr);
		return TCL_OK;
	    }
	}
    } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
	/*
	 * The pattern is non-trivial, but either there is no explicit path or
	 * there is an explicit namespace in the pattern. In both cases, the
	 * old matching scheme is perfect.
	 */

	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	while (entryPtr != NULL) {
	    cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		if (specificNsInPattern) {
		    cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		}
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
	 * If the effective namespace isn't the global :: namespace, and a
	 * specific namespace wasn't requested in the pattern, then add in all
	 * global :: commands that match the simple pattern. Of course, we add
	 * in only those commands that aren't hidden by a command in the
	 * effective namespace.
	 */

	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr,
				Tcl_NewStringObj(cmdName, -1));
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}
    } else {
	/*
	 * The pattern is non-trivial (can match more than one command name),
	 * there is an explicit path, and there is no explicit namespace in
	 * the pattern. This means that we have to traverse the path to
	 * discover all the commands defined.
	 */

	Tcl_HashTable addedCommandsTable;
	int isNew;
	int foundGlobal = (nsPtr == globalNsPtr);

	/*
	 * We keep a hash of the objects already added to the result list.
	 */

	Tcl_InitObjHashTable(&addedCommandsTable);

	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	while (entryPtr != NULL) {
	    cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		(void) Tcl_CreateHashEntry(&addedCommandsTable,
			(char *)elemObjPtr, &isNew);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
	 * Search the path next.
	 */

	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	    Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr;

	    if (pathNsPtr == NULL) {
		continue;
	    }
	    if (pathNsPtr == globalNsPtr) {
		foundGlobal = 1;
	    }
	    entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    (void) Tcl_CreateHashEntry(&addedCommandsTable,
			    (char *) elemObjPtr, &isNew);
		    if (isNew) {
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    } else {
			TclDecrRefCount(elemObjPtr);
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}

	/*
	 * If the effective namespace isn't the global :: namespace, and a
	 * specific namespace wasn't requested in the pattern, then add in all
	 * global :: commands that match the simple pattern. Of course, we add
	 * in only those commands that aren't hidden by a command in the
	 * effective namespace.
	 */

	if (!foundGlobal) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    if (Tcl_FindHashEntry(&addedCommandsTable,
			    (char *) elemObjPtr) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    } else {
			TclDecrRefCount(elemObjPtr);
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}

	Tcl_DeleteHashTable(&addedCommandsTable);
    }

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoCompleteCmd --
 *
 *	Called to implement the "info complete" command that determines
 *	whether a string is a complete Tcl command. Handles the following
 *	syntax:
 *
 *	    info complete command
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoCompleteCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
}

/*
 *----------------------------------------------------------------------
 *
 * InfoDefaultCmd --
 *
 *      Called to implement the "info default" command that returns the
 *      default value for a procedure argument. Handles the following
 *      syntax:
 *
 *	    info default procName arg varName
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoDefaultCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
<




|


|
|







998
999
1000
1001
1002
1003
1004
1005
1006

1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
}

/*
 *----------------------------------------------------------------------
 *
 * InfoDefaultCmd --
 *
 *	Called to implement the "info default" command that returns the
 *	default value for a procedure argument. Handles the following syntax:

 *
 *	    info default procName arg varName
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoDefaultCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
}

/*
 *----------------------------------------------------------------------
 *
 * InfoExistsCmd --
 *
 *      Called to implement the "info exists" command that determines
 *      whether a variable exists. Handles the following syntax:
 *
 *	    info exists varName
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoExistsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|




|


|
|







1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
}

/*
 *----------------------------------------------------------------------
 *
 * InfoExistsCmd --
 *
 *	Called to implement the "info exists" command that determines whether
 *	a variable exists. Handles the following syntax:
 *
 *	    info exists varName
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoExistsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
}

/*
 *----------------------------------------------------------------------
 *
 * InfoFunctionsCmd --
 *
 *      Called to implement the "info functions" command that returns the
 *      list of math functions matching an optional pattern. Handles the
 *      following syntax:
 *
 *	    info functions ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoFunctionsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
}

/*
 *----------------------------------------------------------------------
 *
 * InfoFunctionsCmd --
 *
 *	Called to implement the "info functions" command that returns the list
 *	of math functions matching an optional pattern. Handles the following
 *	syntax:
 *
 *	    info functions ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoFunctionsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
}

/*
 *----------------------------------------------------------------------
 *
 * InfoGlobalsCmd --
 *
 *      Called to implement the "info globals" command that returns the list
 *      of global variables matching an optional pattern. Handles the
 *      following syntax:
 *
 *	    info globals ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoGlobalsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
}

/*
 *----------------------------------------------------------------------
 *
 * InfoGlobalsCmd --
 *
 *	Called to implement the "info globals" command that returns the list
 *	of global variables matching an optional pattern. Handles the
 *	following syntax:
 *
 *	    info globals ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoGlobalsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1091
1092
1093
1094
1095
1096
1097

1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116


1117
1118

1119
1120
1121
1122
1123
1124
1125
    if (objc == 2) {
	pattern = NULL;
    } else if (objc == 3) {
	pattern = TclGetString(objv[2]);
	/*
	 * Strip leading global-namespace qualifiers. [Bug 1057461]
	 */

	if (pattern[0] == ':' && pattern[1] == ':') {
	    while (*pattern == ':') {
		pattern++;
	    }
	}
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	return TCL_ERROR;
    }

    /*
     * Scan through the global :: namespace's variable table and create a
     * list of all global variables that match the pattern.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    if (pattern != NULL && TclMatchIsTrivial(pattern)) {
	entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
	if (entryPtr != NULL) {


	    Tcl_ListObjAppendElement(interp, listPtr,
		    Tcl_NewStringObj(pattern, -1));

	}
    } else {
	for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {
	    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    if (TclIsVarUndefined(varPtr)) {







>











|
|






>
>
|
|
>







1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
    if (objc == 2) {
	pattern = NULL;
    } else if (objc == 3) {
	pattern = TclGetString(objv[2]);
	/*
	 * Strip leading global-namespace qualifiers. [Bug 1057461]
	 */

	if (pattern[0] == ':' && pattern[1] == ':') {
	    while (*pattern == ':') {
		pattern++;
	    }
	}
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	return TCL_ERROR;
    }

    /*
     * Scan through the global :: namespace's variable table and create a list
     * of all global variables that match the pattern.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    if (pattern != NULL && TclMatchIsTrivial(pattern)) {
	entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
	if (entryPtr != NULL) {
	    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    if (!TclIsVarUndefined(varPtr)) {
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(pattern, -1));
	    }
	}
    } else {
	for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {
	    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    if (TclIsVarUndefined(varPtr)) {
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
}

/*
 *----------------------------------------------------------------------
 *
 * InfoHostnameCmd --
 *
 *      Called to implement the "info hostname" command that returns the
 *      host name. Handles the following syntax:
 *
 *	    info hostname
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoHostnameCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|




|


|
|







1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
}

/*
 *----------------------------------------------------------------------
 *
 * InfoHostnameCmd --
 *
 *	Called to implement the "info hostname" command that returns the host
 *	name. Handles the following syntax:
 *
 *	    info hostname
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoHostnameCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLevelCmd --
 *
 *      Called to implement the "info level" command that returns
 *      information about the call stack. Handles the following syntax:
 *
 *	    info level ?number?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLevelCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|




|


|
|







1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLevelCmd --
 *
 *	Called to implement the "info level" command that returns information
 *	about the call stack. Handles the following syntax:
 *
 *	    info level ?number?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLevelCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLibraryCmd --
 *
 *      Called to implement the "info library" command that returns the
 *      library directory for the Tcl installation. Handles the following
 *      syntax:
 *
 *	    info library
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLibraryCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLibraryCmd --
 *
 *	Called to implement the "info library" command that returns the
 *	library directory for the Tcl installation. Handles the following
 *	syntax:
 *
 *	    info library
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLibraryCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLoadedCmd --
 *
 *      Called to implement the "info loaded" command that returns the
 *      packages that have been loaded into an interpreter. Handles the
 *      following syntax:
 *
 *	    info loaded ?interp?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLoadedCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLoadedCmd --
 *
 *	Called to implement the "info loaded" command that returns the
 *	packages that have been loaded into an interpreter. Handles the
 *	following syntax:
 *
 *	    info loaded ?interp?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLoadedCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLocalsCmd --
 *
 *      Called to implement the "info locals" command to return a list of
 *      local variables that match an optional pattern. Handles the
 *      following syntax:
 *
 *	    info locals ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLocalsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLocalsCmd --
 *
 *	Called to implement the "info locals" command to return a list of
 *	local variables that match an optional pattern. Handles the following
 *	syntax:
 *
 *	    info locals ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLocalsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1378
1379
1380
1381
1382
1383
1384
1385

1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
    } else if (objc == 3) {
	pattern = TclGetString(objv[2]);
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	return TCL_ERROR;
    }

    if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {

	return TCL_OK;
    }

    /*
     * Return a list containing names of first the compiled locals (i.e. the
     * ones stored in the call frame), then the variables in the local hash
     * table (if one exists).
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    AppendLocals(interp, listPtr, pattern, 0);
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppendLocals --
 *
 *	Append the local variables for the current frame to the
 *	specified list object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|
>




















|
|







1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
    } else if (objc == 3) {
	pattern = TclGetString(objv[2]);
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	return TCL_ERROR;
    }

    if (iPtr->varFramePtr == NULL ||
	    !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) {
	return TCL_OK;
    }

    /*
     * Return a list containing names of first the compiled locals (i.e. the
     * ones stored in the call frame), then the variables in the local hash
     * table (if one exists).
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    AppendLocals(interp, listPtr, pattern, 0);
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppendLocals --
 *
 *	Append the local variables for the current frame to the specified list
 *	object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
1449
1450
1451
1452
1453
1454
1455




1456
























1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
			Tcl_NewStringObj(varName, -1));
	    }
	}
	varPtr++;
	localPtr = localPtr->nextPtr;
    }





    if (localVarTablePtr != NULL) {
























	for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {
	    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    if (!TclIsVarUndefined(varPtr)
		    && (includeLinks || !TclIsVarLink(varPtr))) {
		varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
		if ((pattern == NULL)
			|| Tcl_StringMatch(varName, pattern)) {
		    Tcl_ListObjAppendElement(interp, listPtr,
			    Tcl_NewStringObj(varName, -1));
		}
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * InfoNameOfExecutableCmd --
 *
 *      Called to implement the "info nameofexecutable" command that returns
 *      the name of the binary file running this application. Handles the
 *      following syntax:
 *
 *	    info nameofexecutable
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoNameOfExecutableCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
<
|
|
|
<










|
|
|




|


|
|







1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616

1617
1618
1619

1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
			Tcl_NewStringObj(varName, -1));
	    }
	}
	varPtr++;
	localPtr = localPtr->nextPtr;
    }

    /*
     * Do nothing if no local variables.
     */

    if (localVarTablePtr == NULL) {
	return;
    }

    /*
     * Check for the simple and fast case.
     */

    if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
	entryPtr = Tcl_FindHashEntry(localVarTablePtr, pattern);
	if (entryPtr != NULL) {
	    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    if (!TclIsVarUndefined(varPtr)
		    && (includeLinks || !TclIsVarLink(varPtr))) {
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(pattern,-1));
	    }
	}
	return;
    }

    /*
     * Scan over and process all local variables.
     */

    for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_NextHashEntry(&search)) {
	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	if (!TclIsVarUndefined(varPtr)
		&& (includeLinks || !TclIsVarLink(varPtr))) {
	    varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);

	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(varName, -1));

	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * InfoNameOfExecutableCmd --
 *
 *	Called to implement the "info nameofexecutable" command that returns
 *	the name of the binary file running this application. Handles the
 *	following syntax:
 *
 *	    info nameofexecutable
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoNameOfExecutableCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
}

/*
 *----------------------------------------------------------------------
 *
 * InfoPatchLevelCmd --
 *
 *      Called to implement the "info patchlevel" command that returns the
 *      default value for an argument to a procedure. Handles the following
 *      syntax:
 *
 *	    info patchlevel
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoPatchLevelCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
}

/*
 *----------------------------------------------------------------------
 *
 * InfoPatchLevelCmd --
 *
 *	Called to implement the "info patchlevel" command that returns the
 *	default value for an argument to a procedure. Handles the following
 *	syntax:
 *
 *	    info patchlevel
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoPatchLevelCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
}

/*
 *----------------------------------------------------------------------
 *
 * InfoProcsCmd --
 *
 *	Called to implement the "info procs" command that returns the
 *	list of procedures in the interpreter that match an optional pattern.
 *	The pattern, if any, consists of an optional sequence of namespace
 *	names separated by "::" qualifiers, which is followed by a
 *	glob-style pattern that restricts which commands are returned.
 *	Handles the following syntax:
 *
 *	    info procs ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoProcsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *cmdName, *pattern;
    CONST char *simplePattern;
    Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
#endif
    Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Command *cmdPtr, *realCmdPtr;

    /*
     * Get the pattern and find the "effective namespace" in which to
     * list procs.
     */

    if (objc == 2) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an
	 * error was found while parsing the pattern, return it. Otherwise,
	 * if the namespace wasn't found, just leave nsPtr NULL: we will
	 * return an empty list since no commands there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

	pattern = TclGetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
		/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,







|
|
|
|
|
|




|


|
|

















|

|





|
|









|
|
|
|







1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
}

/*
 *----------------------------------------------------------------------
 *
 * InfoProcsCmd --
 *
 *	Called to implement the "info procs" command that returns the list of
 *	procedures in the interpreter that match an optional pattern. The
 *	pattern, if any, consists of an optional sequence of namespace names
 *	separated by "::" qualifiers, which is followed by a glob-style
 *	pattern that restricts which commands are returned. Handles the
 *	following syntax:
 *
 *	    info procs ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoProcsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *cmdName, *pattern;
    CONST char *simplePattern;
    Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
#endif
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Command *cmdPtr, *realCmdPtr;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * procs.
     */

    if (objc == 2) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no commands there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

	pattern = TclGetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
		/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
    }

    if (nsPtr == NULL) {
	return TCL_OK;
    }

    /*
     * Scan through the effective namespace's command table and create a
     * list with all procs that match the pattern. If a specific
     * namespace was requested in the pattern, qualify the command names
     * with the namespace name.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
    if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
	entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
	if (entryPtr != NULL) {
	    cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);

	    if (!TclIsProc(cmdPtr)) {
		realCmdPtr = (Command *)
			TclGetOriginalCommand((Tcl_Command) cmdPtr);
		if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
		    goto simpleProcOK;
		}
	    } else {
	      simpleProcOK:
		if (specificNsInPattern) {
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
			    elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
		}







|
|
|
|
















|







1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
    }

    if (nsPtr == NULL) {
	return TCL_OK;
    }

    /*
     * Scan through the effective namespace's command table and create a list
     * with all procs that match the pattern. If a specific namespace was
     * requested in the pattern, qualify the command names with the namespace
     * name.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
    if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
	entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
	if (entryPtr != NULL) {
	    cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);

	    if (!TclIsProc(cmdPtr)) {
		realCmdPtr = (Command *)
			TclGetOriginalCommand((Tcl_Command) cmdPtr);
		if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
		    goto simpleProcOK;
		}
	    } else {
	    simpleProcOK:
		if (specificNsInPattern) {
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
			    elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
		}
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713

1714
1715
1716
1717
1718
1719
1720
		if (!TclIsProc(cmdPtr)) {
		    realCmdPtr = (Command *)
			    TclGetOriginalCommand((Tcl_Command) cmdPtr);
		    if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
			goto procOK;
		    }
		} else {
		  procOK:
		    if (specificNsInPattern) {
			elemObjPtr = Tcl_NewObj();
			Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
				elemObjPtr);
		    } else {
			elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    }
		    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		}
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
	 * If the effective namespace isn't the global :: namespace, and a
	 * specific namespace wasn't requested in the pattern, then add in
	 * all global :: procs that match the simple pattern. Of course,
	 * we add in only those procs that aren't hidden by a proc in
	 * the effective namespace.
	 */

#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
	/*
	 * If "info procs" worked like "info commands", returning the
	 * commands also seen in the global namespace, then you would
	 * include this code.  As this could break backwards compatibilty
	 * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
	 * behavior slightly different.
	 */

	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {







|















|
|
|
|




|
|
|
|
|

>







1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
		if (!TclIsProc(cmdPtr)) {
		    realCmdPtr = (Command *)
			    TclGetOriginalCommand((Tcl_Command) cmdPtr);
		    if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
			goto procOK;
		    }
		} else {
		procOK:
		    if (specificNsInPattern) {
			elemObjPtr = Tcl_NewObj();
			Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
				elemObjPtr);
		    } else {
			elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    }
		    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		}
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
	 * If the effective namespace isn't the global :: namespace, and a
	 * specific namespace wasn't requested in the pattern, then add in all
	 * global :: procs that match the simple pattern. Of course, we add in
	 * only those procs that aren't hidden by a proc in the effective
	 * namespace.
	 */

#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
	/*
	 * If "info procs" worked like "info commands", returning the commands
	 * also seen in the global namespace, then you would include this
	 * code. As this could break backwards compatibilty with 8.0-8.2, we
	 * decided not to "fix" it in 8.3, leaving the behavior slightly
	 * different.
	 */

	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
}

/*
 *----------------------------------------------------------------------
 *
 * InfoScriptCmd --
 *
 *      Called to implement the "info script" command that returns the
 *      script file that is currently being evaluated. Handles the
 *      following syntax:
 *
 *	    info script ?newName?
 *
 *	If newName is specified, it will set that as the internal name.
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.  It may change the
 *	internal script filename.
 *
 *----------------------------------------------------------------------
 */

static int
InfoScriptCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
<






|


|
|
|







1892
1893
1894
1895
1896
1897
1898
1899
1900

1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
}

/*
 *----------------------------------------------------------------------
 *
 * InfoScriptCmd --
 *
 *	Called to implement the "info script" command that returns the script
 *	file that is currently being evaluated. Handles the following syntax:

 *
 *	    info script ?newName?
 *
 *	If newName is specified, it will set that as the internal name.
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message. It may change the internal
 *	script filename.
 *
 *----------------------------------------------------------------------
 */

static int
InfoScriptCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
}

/*
 *----------------------------------------------------------------------
 *
 * InfoSharedlibCmd --
 *
 *      Called to implement the "info sharedlibextension" command that
 *      returns the file extension used for shared libraries. Handles the
 *      following syntax:
 *
 *	    info sharedlibextension
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoSharedlibCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|


|
|







1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
}

/*
 *----------------------------------------------------------------------
 *
 * InfoSharedlibCmd --
 *
 *	Called to implement the "info sharedlibextension" command that returns
 *	the file extension used for shared libraries. Handles the following
 *	syntax:
 *
 *	    info sharedlibextension
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoSharedlibCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
}

/*
 *----------------------------------------------------------------------
 *
 * InfoTclVersionCmd --
 *
 *      Called to implement the "info tclversion" command that returns the
 *      version number for this Tcl library. Handles the following syntax:
 *
 *	    info tclversion
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoTclVersionCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *version;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 2, objv, NULL);
	return TCL_ERROR;
    }

    version = Tcl_GetVar2Ex(interp, "tcl_version", NULL,
	(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
    if (version != NULL) {
	Tcl_SetObjResult(interp, version);
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoVarsCmd --
 *
 *	Called to implement the "info vars" command that returns the
 *	list of variables in the interpreter that match an optional pattern.
 *	The pattern, if any, consists of an optional sequence of namespace
 *	names separated by "::" qualifiers, which is followed by a
 *	glob-style pattern that restricts which variables are returned.
 *	Handles the following syntax:
 *
 *	    info vars ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoVarsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    char *varName, *pattern;
    CONST char *simplePattern;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Var *varPtr;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */

    /*
     * Get the pattern and find the "effective namespace" in which to
     * list variables. We only use this effective namespace if there's
     * no active Tcl procedure frame.
     */

    if (objc == 2) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an
	 * error was found while parsing the pattern, return it. Otherwise,
	 * if the namespace wasn't found, just leave nsPtr NULL: we will
	 * return an empty list since no variables there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

	pattern = TclGetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
		/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
		&simplePattern);

	if (nsPtr != NULL) {	/* we successfully found the pattern's ns */
	    specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
	}
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	return TCL_ERROR;
    }

    /*
     * If the namespace specified in the pattern wasn't found, just return.
     */

    if (nsPtr == NULL) {
	return TCL_OK;
    }

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

    if ((iPtr->varFramePtr == NULL)
	    || !iPtr->varFramePtr->isProcCallFrame
	    || specificNsInPattern) {
	/*
	 * There is no frame pointer, the frame pointer was pushed only
	 * to activate a namespace, or we are in a procedure call frame
	 * but a specific namespace was specified. Create a list containing
	 * only the variables in the effective namespace's variable table.
	 */

	if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
	    /*
	     * If we can just do hash lookups, that simplifies things
	     * a lot.
	     */

	    entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
	    if (entryPtr != NULL) {
		varPtr = (Var *) Tcl_GetHashValue(entryPtr);
		if (!TclIsVarUndefined(varPtr)
			|| TclIsVarNamespaceVar(varPtr)) {







|
|




|


|
|



















|












|
|
|
|
|
|




|


|
|



















|

|


|
|
|









|
|
|
|









|


















|


|
|
|
|




|
<







1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124

2125
2126
2127
2128
2129
2130
2131
}

/*
 *----------------------------------------------------------------------
 *
 * InfoTclVersionCmd --
 *
 *	Called to implement the "info tclversion" command that returns the
 *	version number for this Tcl library. Handles the following syntax:
 *
 *	    info tclversion
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoTclVersionCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *version;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 2, objv, NULL);
	return TCL_ERROR;
    }

    version = Tcl_GetVar2Ex(interp, "tcl_version", NULL,
	    (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
    if (version != NULL) {
	Tcl_SetObjResult(interp, version);
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoVarsCmd --
 *
 *	Called to implement the "info vars" command that returns the list of
 *	variables in the interpreter that match an optional pattern. The
 *	pattern, if any, consists of an optional sequence of namespace names
 *	separated by "::" qualifiers, which is followed by a glob-style
 *	pattern that restricts which variables are returned. Handles the
 *	following syntax:
 *
 *	    info vars ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If there is an
 *	error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoVarsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    char *varName, *pattern;
    CONST char *simplePattern;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Var *varPtr;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * variables. We only use this effective namespace if there's no active
     * Tcl procedure frame.
     */

    if (objc == 2) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no variables there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

	pattern = TclGetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
		/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
		&simplePattern);

	if (nsPtr != NULL) {	/* We successfully found the pattern's ns */
	    specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
	}
    } else {
	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
	return TCL_ERROR;
    }

    /*
     * If the namespace specified in the pattern wasn't found, just return.
     */

    if (nsPtr == NULL) {
	return TCL_OK;
    }

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

    if ((iPtr->varFramePtr == NULL)
	    || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)
	    || specificNsInPattern) {
	/*
	 * There is no frame pointer, the frame pointer was pushed only to
	 * activate a namespace, or we are in a procedure call frame but a
	 * specific namespace was specified. Create a list containing only the
	 * variables in the effective namespace's variable table.
	 */

	if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
	    /*
	     * If we can just do hash lookups, that simplifies things a lot.

	     */

	    entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
	    if (entryPtr != NULL) {
		varPtr = (Var *) Tcl_GetHashValue(entryPtr);
		if (!TclIsVarUndefined(varPtr)
			|| TclIsVarNamespaceVar(varPtr)) {
2011
2012
2013
2014
2015
2016
2017
2018

2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
		if (!TclIsVarUndefined(varPtr)
			|| TclIsVarNamespaceVar(varPtr)) {
		    varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
		    if ((simplePattern == NULL)
			    || Tcl_StringMatch(varName, simplePattern)) {
			if (specificNsInPattern) {
			    elemObjPtr = Tcl_NewObj();
			    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,				    elemObjPtr);

			} else {
			    elemObjPtr = Tcl_NewStringObj(varName, -1);
			}
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }

	    /*
	     * If the effective namespace isn't the global ::
	     * namespace, and a specific namespace wasn't requested in
	     * the pattern (i.e., the pattern only specifies variable
	     * names), then add in all global :: variables that match
	     * the simple pattern. Of course, add in only those
	     * variables that aren't hidden by a variable in the
	     * effective namespace.
	     */

	    if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
		entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
		while (entryPtr != NULL) {
		    varPtr = (Var *) Tcl_GetHashValue(entryPtr);







|
>










|
|
|
<
|
|







2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182

2183
2184
2185
2186
2187
2188
2189
2190
2191
		if (!TclIsVarUndefined(varPtr)
			|| TclIsVarNamespaceVar(varPtr)) {
		    varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
		    if ((simplePattern == NULL)
			    || Tcl_StringMatch(varName, simplePattern)) {
			if (specificNsInPattern) {
			    elemObjPtr = Tcl_NewObj();
			    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
				    elemObjPtr);
			} else {
			    elemObjPtr = Tcl_NewStringObj(varName, -1);
			}
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }

	    /*
	     * If the effective namespace isn't the global :: namespace, and a
	     * specific namespace wasn't requested in the pattern (i.e., the
	     * pattern only specifies variable names), then add in all global

	     * :: variables that match the simple pattern. Of course, add in
	     * only those variables that aren't hidden by a variable in the
	     * effective namespace.
	     */

	    if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
		entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
		while (entryPtr != NULL) {
		    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinObjCmd --
 *
 *	This procedure is invoked to process the "join" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinObjCmd --
 *
 *	This procedure is invoked to process the "join" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
	joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
	return TCL_ERROR;
    }

    /*
     * Make sure the list argument is a list object and get its length and
     * a pointer to its array of element pointers.
     */

    result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
    if (result != TCL_OK) {
	return result;
    }








|
|







2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
	joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
	return TCL_ERROR;
    }

    /*
     * Make sure the list argument is a list object and get its length and a
     * pointer to its array of element pointers.
     */

    result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
    if (result != TCL_OK) {
	return result;
    }

2172
2173
2174
2175
2176
2177
2178
2179
2180
2181

2182
2183
2184
2185
2186
2187
2188
2189
2190
2191

2192
2193
2194
2195
2196

2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230

2231
2232
2233
2234
2235
2236
2237

    /*
     * First assign values out of the list to variables.
     */

    for (i=0 ; i+2<objc ; i++) {
	/*
	 * We do this each time round the loop because that is robust
	 * against shimmering nasties.
	 */

	if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (valueObj == NULL) {
	    if (emptyObj == NULL) {
		TclNewObj(emptyObj);
		Tcl_IncrRefCount(emptyObj);
	    }
	    valueObj = emptyObj;
	}

	/*
	 * Make sure the reference count for the value being assigned
	 * is greater than one (other reference minimally in the list)
	 * so we can't get hammered by shimmering.
	 */

	Tcl_IncrRefCount(valueObj);
	if (Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_DecrRefCount(valueObj);
	    if (emptyObj != NULL) {
		Tcl_DecrRefCount(emptyObj);
	    }
	    return TCL_ERROR;
	}
	Tcl_DecrRefCount(valueObj);
    }
    if (emptyObj != NULL) {
	Tcl_DecrRefCount(emptyObj);
    }

    /*
     * Now place a list of any values left over into the interpreter
     * result.
     *
     * First, figure out how many values were not assigned by getting
     * the length of the list.  Note that I do not expect this
     * operation to fail.
     */

    if (Tcl_ListObjGetElements(interp, objv[1],
	    &listObjc, &listObjv) != TCL_OK) {
	return TCL_ERROR;
    }

    if (listObjc > objc-2) {
	/*
	 * OK, there were left-overs.  Make a list of them and slap
	 * that back in the interpreter result.
	 */

	Tcl_SetObjResult(interp,
		Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2));
    }

    return TCL_OK;
}








|
|

>










>

|
|
|

>
















|
<

|
|
<









|
|

>







2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366

2367
2368
2369

2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389

    /*
     * First assign values out of the list to variables.
     */

    for (i=0 ; i+2<objc ; i++) {
	/*
	 * We do this each time round the loop because that is robust against
	 * shimmering nasties.
	 */

	if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (valueObj == NULL) {
	    if (emptyObj == NULL) {
		TclNewObj(emptyObj);
		Tcl_IncrRefCount(emptyObj);
	    }
	    valueObj = emptyObj;
	}

	/*
	 * Make sure the reference count for the value being assigned is
	 * greater than one (other reference minimally in the list) so we
	 * can't get hammered by shimmering.
	 */

	Tcl_IncrRefCount(valueObj);
	if (Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_DecrRefCount(valueObj);
	    if (emptyObj != NULL) {
		Tcl_DecrRefCount(emptyObj);
	    }
	    return TCL_ERROR;
	}
	Tcl_DecrRefCount(valueObj);
    }
    if (emptyObj != NULL) {
	Tcl_DecrRefCount(emptyObj);
    }

    /*
     * Now place a list of any values left over into the interpreter result.

     *
     * First, figure out how many values were not assigned by getting the
     * length of the list. Note that I do not expect this operation to fail.

     */

    if (Tcl_ListObjGetElements(interp, objv[1],
	    &listObjc, &listObjv) != TCL_OK) {
	return TCL_ERROR;
    }

    if (listObjc > objc-2) {
	/*
	 * OK, there were left-overs. Make a list of them and slap that back
	 * in the interpreter result.
	 */

	Tcl_SetObjResult(interp,
		Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2));
    }

    return TCL_OK;
}

2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
	return TCL_ERROR;
    }

    /*
     * If objc==3, then objv[2] may be either a single index or a list
     * of indices: go to TclLindexList to determine which.
     * If objc>=4, or objc==2, then objv[2 .. objc-2] are all single
     * indices and processed as such in TclLindexFlat.
     */

    if (objc == 3) {
	elemPtr = TclLindexList(interp, objv[1], objv[2]);
    } else {
	elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2);
    }

    /*
     * Set the interpreter's object result to the last element extracted
     */

    if (elemPtr == NULL) {
	return TCL_ERROR;
    } else {
	Tcl_SetObjResult(interp, elemPtr);
	Tcl_DecrRefCount(elemPtr);
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclLindexList --
 *
 *	This procedure handles the 'lindex' command when objc==3.
 *
 * Results:
 *	Returns a pointer to the object extracted, or NULL if an
 *	error occurred.
 *
 * Side effects:
 *	None.
 *
 * Notes:
 *	If objv[1] can be parsed as a list, TclLindexList handles
 *	extraction of the desired element locally.  Otherwise, it
 *	invokes TclLindexFlat to treat objv[1] as a scalar.
 *
 *	The reference count of the returned object includes one
 *	reference corresponding to the pointer returned.  Thus, the
 *	calling code will usually do something like:
 *		Tcl_SetObjResult(interp, result);
 *		Tcl_DecrRefCount(result);
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclLindexList(interp, listPtr, argPtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* List being unpacked */
    Tcl_Obj* argPtr;		/* Index or index list */
{

    Tcl_Obj **elemPtrs;		/* Elements of the list being manipulated. */
    int listLen;		/* Length of the list being manipulated. */
    int index;			/* Index into the list */
    int result;			/* Result returned from a Tcl library call */
    int i;			/* Current index number */
    Tcl_Obj **indices;		/* Array of list indices */
    int indexCount;		/* Size of the array of list indices */
    Tcl_Obj *oldListPtr;	/* Temp location to preserve the list
				 * pointer when replacing it with a sublist */

    /*
     * Determine whether argPtr designates a list or a single index.
     * We have to be careful about the order of the checks to avoid
     * repeated shimmering; see TIP#22 and TIP#33 for the details.
     */

    if (argPtr->typePtr != &tclListType 
	    && TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) {
	/*
	 * argPtr designates a single index.
	 */

	return TclLindexFlat(interp, listPtr, 1, &argPtr);

    }
    if (Tcl_ListObjGetElements(NULL, argPtr, &indexCount, &indices) != TCL_OK){
	/*
	 * argPtr designates something that is neither an index nor a
	 * well-formed list.  Report the error via TclLindexFlat.
	 */

	return TclLindexFlat( interp, listPtr, 1, &argPtr );
    }

    /*
     * Record the reference to the list that we are maintaining in
     * the activation record.
     */

    Tcl_IncrRefCount(listPtr);

    /*
     * argPtr designates a list, and the 'else if' above has parsed it
     * into indexCount and indices.
     */

    for (i=0 ; i<indexCount ; i++) {
	/*
	 * Convert the current listPtr to a list if necessary.
	 */








|
|
|
|









|



















|
|





|
|
|

|
|
|















|
|
|
|
|
|
|


|
|
|


|






|
|



|


|



|
|





|
|







2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
	return TCL_ERROR;
    }

    /*
     * If objc==3, then objv[2] may be either a single index or a list of
     * indices: go to TclLindexList to determine which. If objc>=4, or
     * objc==2, then objv[2 .. objc-2] are all single indices and processed as
     * such in TclLindexFlat.
     */

    if (objc == 3) {
	elemPtr = TclLindexList(interp, objv[1], objv[2]);
    } else {
	elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2);
    }

    /*
     * Set the interpreter's object result to the last element extracted.
     */

    if (elemPtr == NULL) {
	return TCL_ERROR;
    } else {
	Tcl_SetObjResult(interp, elemPtr);
	Tcl_DecrRefCount(elemPtr);
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclLindexList --
 *
 *	This procedure handles the 'lindex' command when objc==3.
 *
 * Results:
 *	Returns a pointer to the object extracted, or NULL if an error
 *	occurred.
 *
 * Side effects:
 *	None.
 *
 * Notes:
 *	If objv[1] can be parsed as a list, TclLindexList handles extraction
 *	of the desired element locally. Otherwise, it invokes TclLindexFlat to
 *	treat objv[1] as a scalar.
 *
 *	The reference count of the returned object includes one reference
 *	corresponding to the pointer returned. Thus, the calling code will
 *	usually do something like:
 *		Tcl_SetObjResult(interp, result);
 *		Tcl_DecrRefCount(result);
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclLindexList(interp, listPtr, argPtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* List being unpacked */
    Tcl_Obj* argPtr;		/* Index or index list */
{

    Tcl_Obj **elemPtrs;		/* Elements of the list being manipulated. */
    int listLen;		/* Length of the list being manipulated. */
    int index;			/* Index into the list. */
    int result;			/* Result returned from a Tcl library call. */
    int i;			/* Current index number. */
    Tcl_Obj **indices;		/* Array of list indices. */
    int indexCount;		/* Size of the array of list indices. */
    Tcl_Obj *oldListPtr;	/* Temp location to preserve the list pointer
				 * when replacing it with a sublist. */

    /*
     * Determine whether argPtr designates a list or a single index. We have
     * to be careful about the order of the checks to avoid repeated
     * shimmering; see TIP#22 and TIP#33 for the details.
     */

    if (argPtr->typePtr != &tclListType
	    && TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) {
	/*
	 * argPtr designates a single index.
	 */

	return TclLindexFlat(interp, listPtr, 1, &argPtr);
    }

    if (Tcl_ListObjGetElements(NULL, argPtr, &indexCount, &indices) != TCL_OK){
	/*
	 * argPtr designates something that is neither an index nor a
	 * well-formed list. Report the error via TclLindexFlat.
	 */

	return TclLindexFlat(interp, listPtr, 1, &argPtr);
    }

    /*
     * Record the reference to the list that we are maintaining in the
     * activation record.
     */

    Tcl_IncrRefCount(listPtr);

    /*
     * argPtr designates a list, and the 'else if' above has parsed it into
     * indexCount and indices.
     */

    for (i=0 ; i<indexCount ; i++) {
	/*
	 * Convert the current listPtr to a list if necessary.
	 */

2400
2401
2402
2403
2404
2405
2406

2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446

2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
	    Tcl_DecrRefCount(listPtr);
	    return NULL;

	} else if (index<0 || index>=listLen) {
	    /*
	     * Index is out of range
	     */

	    Tcl_DecrRefCount(listPtr);
	    listPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(listPtr);
	    return listPtr;
	}

	/*
	 * Make sure listPtr still refers to a list object.
	 * If it shared a Tcl_Obj structure with the arguments, then
	 * it might have just been converted to something else.
	 */

	if (listPtr->typePtr != &tclListType) {
	    result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
					    &elemPtrs);
	    if (result != TCL_OK) {
		Tcl_DecrRefCount(listPtr);
		return NULL;
	    }
	}

	/*
	 * Extract the pointer to the appropriate element
	 */

	oldListPtr = listPtr;
	listPtr = elemPtrs[index];
	Tcl_IncrRefCount(listPtr);
	Tcl_DecrRefCount(oldListPtr);

	/*
	 * The work we did above may have caused the internal rep
	 * of *argPtr to change to something else.  Get it back.
	 */

	result = Tcl_ListObjGetElements(interp, argPtr, &indexCount, &indices);
	if (result != TCL_OK) {
	    /* 
	     * This can't happen unless some extension corrupted a Tcl_Obj.
	     */

	    Tcl_DecrRefCount(listPtr);
	    return NULL;
	}
    }

    /*
     * Return the last object extracted.  Its reference count will include
     * the reference being returned.
     */

    return listPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLindexFlat --
 *
 *	This procedure handles the 'lindex' command, given that the
 *	arguments to the command are known to be a flat list.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 * Notes:
 *	This procedure is called from either tclExecute.c or
 *	Tcl_LindexObjCmd whenever either is presented with objc==2 or
 *	objc>=4.  It is also called from TclLindexList for the objc==3
 *	case once it is determined that objv[2] cannot be parsed as a
 *	list.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclLindexFlat(interp, listPtr, indexCount, indexArray)
    Tcl_Interp *interp;		/* Tcl interpreter */
    Tcl_Obj *listPtr;		/* Tcl object representing the list */
    int indexCount;		/* Count of indices */
    Tcl_Obj *CONST indexArray[];
				/* Array of pointers to Tcl objects
				 * representing the indices in the
				 * list */
{
    int i;			/* Current list index */
    int result;			/* Result of Tcl library calls */
    int listLen;		/* Length of the current list being 
				 * processed */
    Tcl_Obj** elemPtrs;		/* Array of pointers to the elements
				 * of the current list */
    int index;			/* Parsed version of the current element
				 * of indexArray  */
    Tcl_Obj* oldListPtr;	/* Temporary to hold listPtr so that
				 * its ref count can be decremented. */

    /*
     * Record the reference to the 'listPtr' object that we are
     * maintaining in the C activation record.
     */

    Tcl_IncrRefCount(listPtr);

    for (i=0 ; i<indexCount ; i++) {
	/*
	 * Convert the current listPtr to a list if necessary.
	 */

	result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
	if (result != TCL_OK) {
	    Tcl_DecrRefCount(listPtr);
	    return NULL;
	}

	/*
	 * Get the index from objv[i]
	 */

	result = TclGetIntForIndex(interp, indexArray[i],
		/*endValue*/ listLen-1, &index);
	if (result != TCL_OK) {
	    /*
	     * Index could not be parsed
	     */

	    Tcl_DecrRefCount(listPtr);
	    return NULL;

	} else if (index<0 || index>=listLen) {
	    /*
	     * Index is out of range
	     */

	    Tcl_DecrRefCount(listPtr);
	    listPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(listPtr);
	    return listPtr;
	}

	/*
	 * Make sure listPtr still refers to a list object.
	 * It might have been converted to something else above
	 * if objv[1] overlaps with one of the other parameters.
	 */

	if (listPtr->typePtr != &tclListType) {
	    result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
					    &elemPtrs);
	    if (result != TCL_OK) {
		Tcl_DecrRefCount(listPtr);
		return NULL;
	    }
	}

	/*
	 * Extract the pointer to the appropriate element
	 */

	oldListPtr = listPtr;
	listPtr = elemPtrs[index];
	Tcl_IncrRefCount(listPtr);
	Tcl_DecrRefCount(oldListPtr);
    }

    return listPtr;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinsertObjCmd --
 *
 *	This object-based procedure is invoked to process the "linsert" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A new Tcl list object formed by inserting zero or more elements 
 *	into a list.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */








>







|
|
|




|
















|
|




|


>






|
|










|
|








|
|
|
|
<











|
<

|
|
|
|
|
|
|
|
|
|


|
|
















|






|







|









|
|
|




|







|









<











|
|







2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632

2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644

2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725

2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
	    Tcl_DecrRefCount(listPtr);
	    return NULL;

	} else if (index<0 || index>=listLen) {
	    /*
	     * Index is out of range
	     */

	    Tcl_DecrRefCount(listPtr);
	    listPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(listPtr);
	    return listPtr;
	}

	/*
	 * Make sure listPtr still refers to a list object. If it shared a
	 * Tcl_Obj structure with the arguments, then it might have just been
	 * converted to something else.
	 */

	if (listPtr->typePtr != &tclListType) {
	    result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
		    &elemPtrs);
	    if (result != TCL_OK) {
		Tcl_DecrRefCount(listPtr);
		return NULL;
	    }
	}

	/*
	 * Extract the pointer to the appropriate element
	 */

	oldListPtr = listPtr;
	listPtr = elemPtrs[index];
	Tcl_IncrRefCount(listPtr);
	Tcl_DecrRefCount(oldListPtr);

	/*
	 * The work we did above may have caused the internal rep of *argPtr
	 * to change to something else. Get it back.
	 */

	result = Tcl_ListObjGetElements(interp, argPtr, &indexCount, &indices);
	if (result != TCL_OK) {
	    /*
	     * This can't happen unless some extension corrupted a Tcl_Obj.
	     */

	    Tcl_DecrRefCount(listPtr);
	    return NULL;
	}
    }

    /*
     * Return the last object extracted. Its reference count will include the
     * reference being returned.
     */

    return listPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLindexFlat --
 *
 *	This procedure handles the 'lindex' command, given that the arguments
 *	to the command are known to be a flat list.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 * Notes:
 *	This procedure is called from either tclExecute.c or Tcl_LindexObjCmd
 *	whenever either is presented with objc==2 or objc>=4. It is also
 *	called from TclLindexList for the objc==3 case once it is determined
 *	that objv[2] cannot be parsed as a list.

 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclLindexFlat(interp, listPtr, indexCount, indexArray)
    Tcl_Interp *interp;		/* Tcl interpreter */
    Tcl_Obj *listPtr;		/* Tcl object representing the list */
    int indexCount;		/* Count of indices */
    Tcl_Obj *CONST indexArray[];
				/* Array of pointers to Tcl objects
				 * representing the indices in the list. */

{
    int i;			/* Current list index. */
    int result;			/* Result of Tcl library calls. */
    int listLen;		/* Length of the current list being
				 * processed. */
    Tcl_Obj** elemPtrs;		/* Array of pointers to the elements of the
				 * current list. */
    int index;			/* Parsed version of the current element of
				 * indexArray. */
    Tcl_Obj* oldListPtr;	/* Temporary to hold listPtr so that its ref
				 * count can be decremented. */

    /*
     * Record the reference to the 'listPtr' object that we are maintaining in
     * the C activation record.
     */

    Tcl_IncrRefCount(listPtr);

    for (i=0 ; i<indexCount ; i++) {
	/*
	 * Convert the current listPtr to a list if necessary.
	 */

	result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
	if (result != TCL_OK) {
	    Tcl_DecrRefCount(listPtr);
	    return NULL;
	}

	/*
	 * Get the index from objv[i].
	 */

	result = TclGetIntForIndex(interp, indexArray[i],
		/*endValue*/ listLen-1, &index);
	if (result != TCL_OK) {
	    /*
	     * Index could not be parsed.
	     */

	    Tcl_DecrRefCount(listPtr);
	    return NULL;

	} else if (index<0 || index>=listLen) {
	    /*
	     * Index is out of range.
	     */

	    Tcl_DecrRefCount(listPtr);
	    listPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(listPtr);
	    return listPtr;
	}

	/*
	 * Make sure listPtr still refers to a list object. It might have been
	 * converted to something else above if objv[1] overlaps with one of
	 * the other parameters.
	 */

	if (listPtr->typePtr != &tclListType) {
	    result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
		    &elemPtrs);
	    if (result != TCL_OK) {
		Tcl_DecrRefCount(listPtr);
		return NULL;
	    }
	}

	/*
	 * Extract the pointer to the appropriate element.
	 */

	oldListPtr = listPtr;
	listPtr = elemPtrs[index];
	Tcl_IncrRefCount(listPtr);
	Tcl_DecrRefCount(oldListPtr);
    }

    return listPtr;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinsertObjCmd --
 *
 *	This object-based procedure is invoked to process the "linsert" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A new Tcl list object formed by inserting zero or more elements into a
 *	list.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645

2646
2647
2648
2649
2650
2651
2652

    result = Tcl_ListObjLength(interp, objv[1], &len);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Get the index.  "end" is interpreted to be the index after the last
     * element, such that using it will cause any inserted elements to be
     * appended to the list.
     */

    result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
    if (result != TCL_OK) {
	return result;
    }
    if (index > len) {
	index = len;
    }

    /*
     * If the list object is unshared we can modify it directly. Otherwise
     * we create a copy to modify: this is "copy on write".
     */

    listPtr = objv[1];
    isDuplicate = 0;
    if (Tcl_IsShared(listPtr)) {
	listPtr = Tcl_DuplicateObj(listPtr);
	isDuplicate = 1;
    }

    if ((objc == 4) && (index == len)) {
	/*
	 * Special case: insert one element at the end of the list.
	 */

	result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
    } else if (objc > 3) {
	result = Tcl_ListObjReplace(interp, listPtr, index, 0,
				    (objc-3), &(objv[3]));
    }
    if (result != TCL_OK) {
	if (isDuplicate) {







|













|
|













>







2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804

    result = Tcl_ListObjLength(interp, objv[1], &len);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Get the index. "end" is interpreted to be the index after the last
     * element, such that using it will cause any inserted elements to be
     * appended to the list.
     */

    result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
    if (result != TCL_OK) {
	return result;
    }
    if (index > len) {
	index = len;
    }

    /*
     * If the list object is unshared we can modify it directly. Otherwise we
     * create a copy to modify: this is "copy on write".
     */

    listPtr = objv[1];
    isDuplicate = 0;
    if (Tcl_IsShared(listPtr)) {
	listPtr = Tcl_DuplicateObj(listPtr);
	isDuplicate = 1;
    }

    if ((objc == 4) && (index == len)) {
	/*
	 * Special case: insert one element at the end of the list.
	 */

	result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
    } else if (objc > 3) {
	result = Tcl_ListObjReplace(interp, listPtr, index, 0,
				    (objc-3), &(objv[3]));
    }
    if (result != TCL_OK) {
	if (isDuplicate) {
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjCmd --
 *
 *	This procedure is invoked to process the "list" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjCmd --
 *
 *	This procedure is invoked to process the "list" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LlengthObjCmd --
 *
 *	This object-based procedure is invoked to process the "llength" Tcl
 *	command.  See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|







2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LlengthObjCmd --
 *
 *	This object-based procedure is invoked to process the "llength" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
    result = Tcl_ListObjLength(interp, objv[1], &listLen);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Set the interpreter's object result to an integer object holding the
     * length. 
     */

    Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrangeObjCmd --
 *
 *	This procedure is invoked to process the "lrange" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







|











|
|







2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
    result = Tcl_ListObjLength(interp, objv[1], &listLen);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Set the interpreter's object result to an integer object holding the
     * length.
     */

    Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrangeObjCmd --
 *
 *	This procedure is invoked to process the "lrange" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

    /*
     * Make sure the list argument is a list object and get its length and
     * a pointer to its array of element pointers.
     */

    listPtr = objv[1];
    result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
    if (result != TCL_OK) {
	return result;
    }







|
|







2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

    /*
     * Make sure the list argument is a list object and get its length and a
     * pointer to its array of element pointers.
     */

    listPtr = objv[1];
    result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
    if (result != TCL_OK) {
	return result;
    }
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865

2866
2867
2868

2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935

2936
2937
2938
2939
2940
2941
2942
2943

2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
    if (first > last) {
	return TCL_OK;		/* the result is an empty object */
    }

    /*
     * Make sure listPtr still refers to a list object. It might have been
     * converted to an int above if the argument objects were shared.
     */  

    if (listPtr->typePtr != &tclListType) {
	result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
		&elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
    }

    /*
     * Extract a range of fields. We modify the interpreter's result object
     * to be a list object containing the specified elements.
     */

    numElems = (last - first + 1);
    Tcl_SetObjResult(interp, Tcl_NewListObj(numElems, &(elemPtrs[first])));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrepeatObjCmd --
 *
 *	This procedure is invoked to process the "lrepeat" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LrepeatObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    register int objc;			/* Number of arguments. */
    register Tcl_Obj *CONST objv[];	/* The argument objects. */

{
    int elementCount, i, result;
    Tcl_Obj **dataArray;


    /* 
     * Check arguments for legality:
     *		lrepeat posInt value ?value ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?");
	return TCL_ERROR;
    }
    elementCount = 0;
    result = Tcl_GetIntFromObj(interp, objv[1], &elementCount);
    if (result == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (elementCount < 1) {
	Tcl_AppendResult(interp, "must have a count of at least 1", NULL);
	return TCL_ERROR;
    }

    /*
     * Skip forward to the interesting arguments now we've finished
     * parsing.
     */

    objc -= 2;
    objv += 2;

    /*
     * Create workspace array large enough to hold each init value
     * elementCount times.  Note that we don't bother with stack
     * allocation for this, as we expect this function to be used
     * mainly when stack allocation would be inappropriate anyway.
     * First check to see if we'd overflow and try to allocate an
     * object larger than our memory allocator allows.  Note that this
     * is actually a fairly small value when you're on a serious
     * 64-bit machine, but that requires API changes to fix.
     *
     * We allocate using attemptckalloc() because if we ask for
     * something big but can't get it, we've still got a high chance
     * of having a proper failover strategy.  If *that* fails to get
     * memory, Tcl_Panic() will happen just a few lines lower...
     */

    if ((unsigned)elementCount > INT_MAX/sizeof(Tcl_Obj *)/objc) {
	Tcl_AppendResult(interp, "overflow of maximum list length", NULL);
	return TCL_ERROR;
    }

    dataArray = (Tcl_Obj **)
	    attemptckalloc(elementCount * objc * sizeof(Tcl_Obj *));

    if (dataArray == NULL) {
	Tcl_AppendResult(interp, "insufficient memory to create list", NULL);
	return TCL_ERROR;
    }

    /*
     * Set the elements.  Note that we handle the common degenerate
     * case of a single value being repeated separately to permit the
     * compiler as much room as possible to optimize a loop that might
     * be run a very large number of times.
     */

    if (objc == 1) {
	register Tcl_Obj *tmpPtr = objv[0];


	for (i=0 ; i<elementCount ; i++) {
	    dataArray[i] = tmpPtr;
	}
    } else {
	int j, k = 0;

	for (i=0 ; i<elementCount ; i++) {
	    for (j=0 ; j<objc ; j++) {

		dataArray[k++] = objv[j];
	    }
	}
    }

    /*
     * Build the result list, clean up and return.
     */

    Tcl_SetObjResult(interp, TclNewListObjDirect(elementCount*objc,dataArray));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LreplaceObjCmd --
 *
 *	This object-based procedure is invoked to process the "lreplace" 
 *	Tcl command. See the user documentation for details on what it does.
 *
 * Results:
 *	A new Tcl list object formed by replacing zero or more elements of
 *	a list.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */








|










|
|












|
|













|
|
|
|
>


|
>

|



















|
<






|
|
<
<
<
<
<
<
<
<
<
<
<


|
<
<
<
|
<
<
|
|
<
<
|
<

|
|
|
|





>








>





<
<
<
<
|








|
|


|
|







2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044

3045
3046
3047
3048
3049
3050
3051
3052











3053
3054
3055



3056


3057
3058


3059

3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084




3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
    if (first > last) {
	return TCL_OK;		/* the result is an empty object */
    }

    /*
     * Make sure listPtr still refers to a list object. It might have been
     * converted to an int above if the argument objects were shared.
     */

    if (listPtr->typePtr != &tclListType) {
	result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
		&elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
    }

    /*
     * Extract a range of fields. We modify the interpreter's result object to
     * be a list object containing the specified elements.
     */

    numElems = (last - first + 1);
    Tcl_SetObjResult(interp, Tcl_NewListObj(numElems, &(elemPtrs[first])));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrepeatObjCmd --
 *
 *	This procedure is invoked to process the "lrepeat" Tcl command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LrepeatObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    register int objc;		/* Number of arguments. */
    register Tcl_Obj *CONST objv[];
				/* The argument objects. */
{
    int elementCount, i, result;
    Tcl_Obj *listPtr, **dataArray;
    List *listRepPtr;

    /*
     * Check arguments for legality:
     *		lrepeat posInt value ?value ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?");
	return TCL_ERROR;
    }
    elementCount = 0;
    result = Tcl_GetIntFromObj(interp, objv[1], &elementCount);
    if (result == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (elementCount < 1) {
	Tcl_AppendResult(interp, "must have a count of at least 1", NULL);
	return TCL_ERROR;
    }

    /*
     * Skip forward to the interesting arguments now we've finished parsing.

     */

    objc -= 2;
    objv += 2;

    /*
     * Get an empty list object that is allocated large enough to hold each
     * init value elementCount times.











     */

    listPtr = Tcl_NewListObj(elementCount*objc, NULL);



    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;


    listRepPtr->elemCount = elementCount*objc;
    dataArray = &listRepPtr->elements;




    /*
     * Set the elements. Note that we handle the common degenerate case of a
     * single value being repeated separately to permit the compiler as much
     * room as possible to optimize a loop that might be run a very large
     * number of times.
     */

    if (objc == 1) {
	register Tcl_Obj *tmpPtr = objv[0];

	tmpPtr->refCount += elementCount;
	for (i=0 ; i<elementCount ; i++) {
	    dataArray[i] = tmpPtr;
	}
    } else {
	int j, k = 0;

	for (i=0 ; i<elementCount ; i++) {
	    for (j=0 ; j<objc ; j++) {
		Tcl_IncrRefCount(objv[j]);
		dataArray[k++] = objv[j];
	    }
	}
    }





    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LreplaceObjCmd --
 *
 *	This object-based procedure is invoked to process the "lreplace" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A new Tcl list object formed by replacing zero or more elements of a
 *	list.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106

3107
3108
3109
3110
3111
3112
3113
3114

3115
3116
3117
3118
3119
3120
3121

3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132

3133
3134
3135
3136
3137
3138
3139

    result = Tcl_ListObjLength(interp, objv[1], &listLen);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Get the first and last indexes.  "end" is interpreted to be the index
     * for the last element, such that using it will cause that element to
     * be included for deletion.
     */

    result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
    if (result != TCL_OK) {
	return result;
    }

    result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0)  {
    	first = 0;
    }

    /*
     * Complain if the user asked for a start element that is greater than the
     * list length.  This won't ever trigger for the "end*" case as that will
     * be properly constrained by TclGetIntForIndex because we use listLen-1
     * (to allow for replacing the last elem).
     */

    if ((first >= listLen) && (listLen > 0)) {
	Tcl_AppendResult(interp, "list doesn't contain element ",
		TclGetString(objv[2]), (int *) NULL);
	return TCL_ERROR;
    }
    if (last >= listLen) {
    	last = (listLen - 1);
    }
    if (first <= last) {
	numToDelete = (last - first + 1);
    } else {
	numToDelete = 0;
    }

    /*
     * If the list object is unshared we can modify it directly, otherwise
     * we create a copy to modify: this is "copy on write".
     */

    listPtr = objv[1];
    isDuplicate = 0;
    if (Tcl_IsShared(listPtr)) {
	listPtr = Tcl_DuplicateObj(listPtr);
	isDuplicate = 1;
    }
    if (objc > 4) {
	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
	        (objc-4), &(objv[4]));
    } else {
	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
		0, NULL);
    }
    if (result != TCL_OK) {
	if (isDuplicate) {
	    Tcl_DecrRefCount(listPtr); /* free unneeded obj */
	}
	return result;
    }

    /*
     * Set the interpreter's object result. 
     */

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsearchObjCmd --
 *
 *	This procedure is invoked to process the "lsearch" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LsearchObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument values. */
{
    char *bytes, *patternBytes;
    int i, match, mode, index, result, listc, length, elemLen;
    int dataType, isIncreasing, lower, upper, patInt, objInt;
    int offset, allMatches, inlineReturn, negatedMatch, returnSubindices;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
    Tcl_RegExp regexp = NULL;
    static CONST char *options[] = {
	"-all",	    "-ascii",   "-decreasing", "-dictionary",
	"-exact",   "-glob",    "-increasing", "-index",
	"-inline",  "-integer", "-not",        "-real",

	"-regexp",  "-sorted",  "-start",      "-subindices",
	NULL
    };
    enum options {
	LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
	LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX,
	LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL,
	LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, LSEARCH_SUBINDICES

    };
    enum datatypes {
	ASCII, DICTIONARY, INTEGER, REAL
    };
    enum modes {
	EXACT, GLOB, REGEXP, SORTED
    };


    mode = GLOB;
    dataType = ASCII;
    isIncreasing = 1;
    allMatches = 0;
    inlineReturn = 0;
    returnSubindices = 0;
    negatedMatch = 0;
    listPtr = NULL;
    startPtr = NULL;
    offset = 0;

    sortInfo.compareCmdPtr = NULL;
    sortInfo.isIncreasing = 0;
    sortInfo.sortMode = 0;
    sortInfo.interp = interp;
    sortInfo.resultCode = TCL_OK;
    sortInfo.indexv = NULL;
    sortInfo.indexc = 0;







|
|
|












|





|



















|
|










|












|











|
|



















|
|







|
>
|





|
|
>







>











>







3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275

    result = Tcl_ListObjLength(interp, objv[1], &listLen);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Get the first and last indexes. "end" is interpreted to be the index
     * for the last element, such that using it will cause that element to be
     * included for deletion.
     */

    result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
    if (result != TCL_OK) {
	return result;
    }

    result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0) {
    	first = 0;
    }

    /*
     * Complain if the user asked for a start element that is greater than the
     * list length. This won't ever trigger for the "end*" case as that will
     * be properly constrained by TclGetIntForIndex because we use listLen-1
     * (to allow for replacing the last elem).
     */

    if ((first >= listLen) && (listLen > 0)) {
	Tcl_AppendResult(interp, "list doesn't contain element ",
		TclGetString(objv[2]), (int *) NULL);
	return TCL_ERROR;
    }
    if (last >= listLen) {
    	last = (listLen - 1);
    }
    if (first <= last) {
	numToDelete = (last - first + 1);
    } else {
	numToDelete = 0;
    }

    /*
     * If the list object is unshared we can modify it directly, otherwise we
     * create a copy to modify: this is "copy on write".
     */

    listPtr = objv[1];
    isDuplicate = 0;
    if (Tcl_IsShared(listPtr)) {
	listPtr = Tcl_DuplicateObj(listPtr);
	isDuplicate = 1;
    }
    if (objc > 4) {
	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
		(objc-4), &(objv[4]));
    } else {
	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
		0, NULL);
    }
    if (result != TCL_OK) {
	if (isDuplicate) {
	    Tcl_DecrRefCount(listPtr); /* free unneeded obj */
	}
	return result;
    }

    /*
     * Set the interpreter's object result.
     */

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsearchObjCmd --
 *
 *	This procedure is invoked to process the "lsearch" Tcl command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LsearchObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument values. */
{
    char *bytes, *patternBytes;
    int i, match, mode, index, result, listc, length, elemLen;
    int dataType, isIncreasing, lower, upper, patInt, objInt, offset;
    int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
    Tcl_RegExp regexp = NULL;
    static CONST char *options[] = {
	"-all",	    "-ascii",   "-decreasing", "-dictionary",
	"-exact",   "-glob",    "-increasing", "-index",
	"-inline",  "-integer", "-nocase",     "-not",
	"-real",    "-regexp",  "-sorted",     "-start",
	"-subindices",
	NULL
    };
    enum options {
	LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
	LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX,
	LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT,
	LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START,
	LSEARCH_SUBINDICES
    };
    enum datatypes {
	ASCII, DICTIONARY, INTEGER, REAL
    };
    enum modes {
	EXACT, GLOB, REGEXP, SORTED
    };
    SortStrCmpFn_t strCmpFn = strcmp;

    mode = GLOB;
    dataType = ASCII;
    isIncreasing = 1;
    allMatches = 0;
    inlineReturn = 0;
    returnSubindices = 0;
    negatedMatch = 0;
    listPtr = NULL;
    startPtr = NULL;
    offset = 0;
    noCase = 0;
    sortInfo.compareCmdPtr = NULL;
    sortInfo.isIncreasing = 0;
    sortInfo.sortMode = 0;
    sortInfo.interp = interp;
    sortInfo.resultCode = TCL_OK;
    sortInfo.indexv = NULL;
    sortInfo.indexc = 0;
3177
3178
3179
3180
3181
3182
3183




3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205

3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224

3225
3226
3227
3228
3229
3230
3231
	    isIncreasing = 1;
	    break;
	case LSEARCH_INLINE:		/* -inline */
	    inlineReturn = 1;
	    break;
	case LSEARCH_INTEGER:		/* -integer */
	    dataType = INTEGER;




	    break;
	case LSEARCH_NOT:		/* -not */
	    negatedMatch = 1;
	    break;
	case LSEARCH_REAL:		/* -real */
	    dataType = REAL;
	    break;
	case LSEARCH_REGEXP:		/* -regexp */
	    mode = REGEXP;
	    break;
	case LSEARCH_SORTED:		/* -sorted */
	    mode = SORTED;
	    break;
	case LSEARCH_SUBINDICES:	/* -subindices */
	    returnSubindices = 1;
	    break;
	case LSEARCH_START:		/* -start */
	    /*
	     * If there was a previous -start option, release its saved
	     * index because it will either be replaced or there will be
	     * an error.
	     */

	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
	    }
	    if (i > objc-4) {
		if (sortInfo.indexc > 1) {
		    ckfree((char *) sortInfo.indexv);
		}
		Tcl_AppendResult(interp, "missing starting index", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    if (objv[i] == objv[objc - 2]) {
		/*
		 * Take copy to prevent shimmering problems.  Note
		 * that it does not matter if the index obj is also a
		 * component of the list being searched.  We only need
		 * to copy where the list and the index are
		 * one-and-the-same.
		 */

		startPtr = Tcl_DuplicateObj(objv[i]);
	    } else {
		startPtr = objv[i];
		Tcl_IncrRefCount(startPtr);
	    }
	    break;
	case LSEARCH_INDEX: {		/* -index */







>
>
>
>


















|
|
<

>













|
|
|
<
|

>







3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343

3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361

3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
	    isIncreasing = 1;
	    break;
	case LSEARCH_INLINE:		/* -inline */
	    inlineReturn = 1;
	    break;
	case LSEARCH_INTEGER:		/* -integer */
	    dataType = INTEGER;
	    break;
	case LSEARCH_NOCASE:		/* -nocase */
	    strCmpFn = strcasecmp;
	    noCase = 1;
	    break;
	case LSEARCH_NOT:		/* -not */
	    negatedMatch = 1;
	    break;
	case LSEARCH_REAL:		/* -real */
	    dataType = REAL;
	    break;
	case LSEARCH_REGEXP:		/* -regexp */
	    mode = REGEXP;
	    break;
	case LSEARCH_SORTED:		/* -sorted */
	    mode = SORTED;
	    break;
	case LSEARCH_SUBINDICES:	/* -subindices */
	    returnSubindices = 1;
	    break;
	case LSEARCH_START:		/* -start */
	    /*
	     * If there was a previous -start option, release its saved index
	     * because it will either be replaced or there will be an error.

	     */

	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
	    }
	    if (i > objc-4) {
		if (sortInfo.indexc > 1) {
		    ckfree((char *) sortInfo.indexv);
		}
		Tcl_AppendResult(interp, "missing starting index", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    if (objv[i] == objv[objc - 2]) {
		/*
		 * Take copy to prevent shimmering problems. Note that it
		 * does not matter if the index obj is also a component of the
		 * list being searched. We only need to copy where the list

		 * and the index are one-and-the-same.
		 */

		startPtr = Tcl_DuplicateObj(objv[i]);
	    } else {
		startPtr = objv[i];
		Tcl_IncrRefCount(startPtr);
	    }
	    break;
	case LSEARCH_INDEX: {		/* -index */
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
			"\"-index\" option must be followed by list index",
			NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Store the extracted indices for processing by sublist
	     * extraction.  Note that we don't do this using objects
	     * because that has shimmering problems.
	     */

	    i++;
	    if (Tcl_ListObjGetElements(interp, objv[i],
		    &sortInfo.indexc, &indices) != TCL_OK) {
		if (startPtr != NULL) {
		    Tcl_DecrRefCount(startPtr);







|
|







3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
			"\"-index\" option must be followed by list index",
			NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Store the extracted indices for processing by sublist
	     * extraction. Note that we don't do this using objects because
	     * that has shimmering problems.
	     */

	    i++;
	    if (Tcl_ListObjGetElements(interp, objv[i],
		    &sortInfo.indexc, &indices) != TCL_OK) {
		if (startPtr != NULL) {
		    Tcl_DecrRefCount(startPtr);
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
		break;
	    default:
		sortInfo.indexv = (int *)
			ckalloc(sizeof(int) * sortInfo.indexc);
	    }

	    /*
	     * Fill the array by parsing each index.  We don't know
	     * whether their scale is sensible yet, but we at least
	     * perform the syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    char buffer[TCL_INTEGER_SPACE];
		    
		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    sprintf(buffer, "%d", j);
		    Tcl_AddErrorInfo(interp,
			    "\n    (-index option item number ");
		    Tcl_AddErrorInfo(interp, buffer);
		    Tcl_AddErrorInfo(interp, ")");
		    return TCL_ERROR;
		}
	    }
	    break;
	}
	}
    }







|
|
|





<
<



<
|
|
<
<







3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421


3422
3423
3424

3425
3426


3427
3428
3429
3430
3431
3432
3433
		break;
	    default:
		sortInfo.indexv = (int *)
			ckalloc(sizeof(int) * sortInfo.indexc);
	    }

	    /*
	     * Fill the array by parsing each index. We don't know whether
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {


		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }

		    TclFormatToErrorInfo(interp,
			    "\n    (-index option item number %d)", j);


		    return TCL_ERROR;
		}
	    }
	    break;
	}
	}
    }
3311
3312
3313
3314
3315
3316
3317

3318
3319

3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349

3350
3351
3352
3353
3354
3355
3356
    }

    if ((enum modes) mode == REGEXP) {
	/*
	 * We can shimmer regexp/list if listv[i] == pattern, so get the
	 * regexp rep before the list rep.
	 */

	regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
		TCL_REG_ADVANCED | TCL_REG_NOSUB);

	if (regexp == NULL) {
	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
	    }
	    if (sortInfo.indexc > 1) {
		ckfree((char *) sortInfo.indexv);
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * Make sure the list argument is a list object and get its length and
     * a pointer to its array of element pointers.
     */

    result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
    if (result != TCL_OK) {
	if (startPtr != NULL) {
	    Tcl_DecrRefCount(startPtr);
	}
	if (sortInfo.indexc > 1) {
	    ckfree((char *) sortInfo.indexv);
	}
	return result;
    }

    /*
     * Get the user-specified start offset.
     */

    if (startPtr) {
	result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
	Tcl_DecrRefCount(startPtr);
	if (result != TCL_OK) {
	    if (sortInfo.indexc > 1) {
		ckfree((char *) sortInfo.indexv);
	    }







>

|
>












|
|
















>







3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
    }

    if ((enum modes) mode == REGEXP) {
	/*
	 * We can shimmer regexp/list if listv[i] == pattern, so get the
	 * regexp rep before the list rep.
	 */

	regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
		TCL_REG_ADVANCED | TCL_REG_NOSUB |
		(noCase ? TCL_REG_NOCASE : 0));
	if (regexp == NULL) {
	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
	    }
	    if (sortInfo.indexc > 1) {
		ckfree((char *) sortInfo.indexv);
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * Make sure the list argument is a list object and get its length and a
     * pointer to its array of element pointers.
     */

    result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
    if (result != TCL_OK) {
	if (startPtr != NULL) {
	    Tcl_DecrRefCount(startPtr);
	}
	if (sortInfo.indexc > 1) {
	    ckfree((char *) sortInfo.indexv);
	}
	return result;
    }

    /*
     * Get the user-specified start offset.
     */

    if (startPtr) {
	result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
	Tcl_DecrRefCount(startPtr);
	if (result != TCL_OK) {
	    if (sortInfo.indexc > 1) {
		ckfree((char *) sortInfo.indexv);
	    }
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402

3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413

3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
	    break;
	}
    } else {
	patternBytes = Tcl_GetStringFromObj(patObj, &length);
    }

    /*
     * Set default index value to -1, indicating failure; if we find the
     * item in the course of our search, index will be set to the correct
     * value.
     */

    index = -1;
    match = 0;

    if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
	/*
	 * If the data is sorted, we can do a more intelligent search.
	 * Note that there is no point in being smart when -all was
	 * specified; in that case, we have to look at all items anyway,
	 * and there is no sense in doing this when the match sense is
	 * inverted.
	 */

	lower = offset - 1;
	upper = listc;
	while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
	    i = (lower + upper)/2;
	    itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
	    if (sortInfo.resultCode != TCL_OK) {
		if (sortInfo.indexc > 1) {
		    ckfree((char *) sortInfo.indexv);
		}
		return sortInfo.resultCode;
	    }
	    switch ((enum datatypes) dataType) {
	    case ASCII:
		bytes = TclGetString(itemPtr);
		match = strcmp(patternBytes, bytes);
		break;
	    case DICTIONARY:
		bytes = TclGetString(itemPtr);
		match = DictionaryCompare(patternBytes, bytes);
		break;
	    case INTEGER:
		result = Tcl_GetIntFromObj(interp, itemPtr, &objInt);







|
|
<

>





|
|
|
|
<

>














|







3530
3531
3532
3533
3534
3535
3536
3537
3538

3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549

3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
	    break;
	}
    } else {
	patternBytes = Tcl_GetStringFromObj(patObj, &length);
    }

    /*
     * Set default index value to -1, indicating failure; if we find the item
     * in the course of our search, index will be set to the correct value.

     */

    index = -1;
    match = 0;

    if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
	/*
	 * If the data is sorted, we can do a more intelligent search. Note
	 * that there is no point in being smart when -all was specified; in
	 * that case, we have to look at all items anyway, and there is no
	 * sense in doing this when the match sense is inverted.

	 */

	lower = offset - 1;
	upper = listc;
	while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
	    i = (lower + upper)/2;
	    itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
	    if (sortInfo.resultCode != TCL_OK) {
		if (sortInfo.indexc > 1) {
		    ckfree((char *) sortInfo.indexv);
		}
		return sortInfo.resultCode;
	    }
	    switch ((enum datatypes) dataType) {
	    case ASCII:
		bytes = TclGetString(itemPtr);
		match = strCmpFn(patternBytes, bytes);
		break;
	    case DICTIONARY:
		bytes = TclGetString(itemPtr);
		match = DictionaryCompare(patternBytes, bytes);
		break;
	    case INTEGER:
		result = Tcl_GetIntFromObj(interp, itemPtr, &objInt);
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472

3473
3474
3475
3476
3477
3478
3479

3480
3481
3482
3483
3484
3485
3486
		} else {
		    match = 1;
		}
		break;
	    }
	    if (match == 0) {
		/*
		 * Normally, binary search is written to stop when it
		 * finds a match.  If there are duplicates of an element in
		 * the list, our first match might not be the first occurance.
		 * Consider:  0 0 0 1 1 1 2 2 2

		 * To maintain consistancy with standard lsearch semantics,
		 * we must find the leftmost occurance of the pattern in the
		 * list.  Thus we don't just stop searching here.  This
		 * variation means that a search always makes log n
		 * comparisons (normal binary search might "get lucky" with
		 * an early comparison).
		 */

		index = i;
		upper = i;
	    } else if (match > 0) {
		if (isIncreasing) {
		    lower = i;
		} else {
		    upper = i;







|
|
|
|
>
|
|
|

|
|

>







3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
		} else {
		    match = 1;
		}
		break;
	    }
	    if (match == 0) {
		/*
		 * Normally, binary search is written to stop when it finds a
		 * match. If there are duplicates of an element in the list,
		 * our first match might not be the first occurance.
		 * Consider: 0 0 0 1 1 1 2 2 2
		 *
		 * To maintain consistancy with standard lsearch semantics, we
		 * must find the leftmost occurance of the pattern in the
		 * list. Thus we don't just stop searching here. This
		 * variation means that a search always makes log n
		 * comparisons (normal binary search might "get lucky" with an
		 * early comparison).
		 */

		index = i;
		upper = i;
	    } else if (match > 0) {
		if (isIncreasing) {
		    lower = i;
		} else {
		    upper = i;
3497
3498
3499
3500
3501
3502
3503

3504
3505
3506
3507
3508
3509
3510
    } else {
	/*
	 * We need to do a linear search, because (at least one) of:
	 *   - our matcher can only tell equal vs. not equal
	 *   - our matching sense is negated
	 *   - we're building a list of all matched items
	 */

	if (allMatches) {
	    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	}
	for (i = offset; i < listc; i++) {
	    match = 0;
	    itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
	    if (sortInfo.resultCode != TCL_OK) {







>







3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
    } else {
	/*
	 * We need to do a linear search, because (at least one) of:
	 *   - our matcher can only tell equal vs. not equal
	 *   - our matching sense is negated
	 *   - we're building a list of all matched items
	 */

	if (allMatches) {
	    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	}
	for (i = offset; i < listc; i++) {
	    match = 0;
	    itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
	    if (sortInfo.resultCode != TCL_OK) {
3519
3520
3521
3522
3523
3524
3525








3526
3527

3528
3529
3530
3531
3532
3533
3534
	    switch ((enum modes) mode) {
	    case SORTED:
	    case EXACT:
		switch ((enum datatypes) dataType) {
		case ASCII:
		    bytes = Tcl_GetStringFromObj(itemPtr, &elemLen);
		    if (length == elemLen) {








			match = (memcmp(bytes, patternBytes,
				(size_t) length) == 0);

		    }
		    break;
		case DICTIONARY:
		    bytes = TclGetString(itemPtr);
		    match = (DictionaryCompare(bytes, patternBytes) == 0);
		    break;








>
>
>
>
>
>
>
>
|
|
>







3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
	    switch ((enum modes) mode) {
	    case SORTED:
	    case EXACT:
		switch ((enum datatypes) dataType) {
		case ASCII:
		    bytes = Tcl_GetStringFromObj(itemPtr, &elemLen);
		    if (length == elemLen) {
			/*
			 * This split allows for more optimal compilation of
			 * memcmp/
			 */

			if (noCase) {
			    match = (strcasecmp(bytes, patternBytes) == 0);
			} else {
			    match = (memcmp(bytes, patternBytes,
				    (size_t) length) == 0);
			}
		    }
		    break;
		case DICTIONARY:
		    bytes = TclGetString(itemPtr);
		    match = (DictionaryCompare(bytes, patternBytes) == 0);
		    break;

3559
3560
3561
3562
3563
3564
3565
3566

3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581

3582
3583
3584

3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597

3598
3599
3600
3601
3602
3603
3604
		    }
		    match = (objDouble == patDouble);
		    break;
		}
		break;

	    case GLOB:
		match = Tcl_StringMatch(TclGetString(itemPtr), patternBytes);

		break;
	    case REGEXP:
		match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0);
		if (match < 0) {
		    Tcl_DecrRefCount(patObj);
		    if (listPtr != NULL) {
			Tcl_DecrRefCount(listPtr);
		    }
		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    return TCL_ERROR;
		}
		break;
	    }

	    /*
	     * Invert match condition for -not
	     */

	    if (negatedMatch) {
		match = !match;
	    }
	    if (!match) {
		continue;
	    }
	    if (!allMatches) {
		index = i;
		break;
	    } else if (inlineReturn) {
		/*
		 * Note that these appends are not expected to fail.
		 */

		if (returnSubindices) {
		    itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
		} else {
		    itemPtr = listv[i];
		}
		Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
	    } else if (returnSubindices) {







|
>















>



>













>







3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
		    }
		    match = (objDouble == patDouble);
		    break;
		}
		break;

	    case GLOB:
		match = Tcl_StringCaseMatch(TclGetString(itemPtr),
			patternBytes, noCase);
		break;
	    case REGEXP:
		match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0);
		if (match < 0) {
		    Tcl_DecrRefCount(patObj);
		    if (listPtr != NULL) {
			Tcl_DecrRefCount(listPtr);
		    }
		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    return TCL_ERROR;
		}
		break;
	    }

	    /*
	     * Invert match condition for -not
	     */

	    if (negatedMatch) {
		match = !match;
	    }
	    if (!match) {
		continue;
	    }
	    if (!allMatches) {
		index = i;
		break;
	    } else if (inlineReturn) {
		/*
		 * Note that these appends are not expected to fail.
		 */

		if (returnSubindices) {
		    itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
		} else {
		    itemPtr = listv[i];
		}
		Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
	    } else if (returnSubindices) {
3614
3615
3616
3617
3618
3619
3620

3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639

3640
3641
3642
3643

3644
3645
3646

3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680

3681

3682
3683
3684
3685
3686
3687

3688

3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716

3717

3718
3719
3720
3721
3722
3723
3724
3725

3726

3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
	    }
	}
    }

    /*
     * Return everything or a single value.
     */

    if (allMatches) {
	Tcl_SetObjResult(interp, listPtr);
    } else if (!inlineReturn) {
	if (returnSubindices) {
	    int j;
	    itemPtr = Tcl_NewIntObj(index);
	    for (j=0 ; j<sortInfo.indexc ; j++) {
		Tcl_ListObjAppendElement(interp, itemPtr,
			Tcl_NewIntObj(sortInfo.indexv[j]));
	    }
	    Tcl_SetObjResult(interp, itemPtr);
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
	}
    } else if (index < 0) {
	/*
	 * Is this superfluous?  The result should be a blank object
	 * by default...
	 */

	Tcl_SetObjResult(interp, Tcl_NewObj());
    } else {
	Tcl_SetObjResult(interp, listv[index]);
    }

    /*
     * Cleanup the index list array.
     */

    if (sortInfo.indexc > 1) {
	ckfree((char *) sortInfo.indexv);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsetObjCmd --
 *
 *	This procedure is invoked to process the "lset" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LsetObjCmd( clientData, interp, objc, objv )
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument values. */
{

    Tcl_Obj* listPtr;		/* Pointer to the list being altered. */
    Tcl_Obj* finalValuePtr;	/* Value finally assigned to the variable */


    /* Check parameter count */


    if ( objc < 3 ) {
	Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
	return TCL_ERROR;
    }


    /* Look up the list variable's value */


    listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
			      TCL_LEAVE_ERR_MSG );
    if ( listPtr == NULL ) {
	return TCL_ERROR;
    }

    /* 
     * Substitute the value in the value.  Return either the value or
     * else an unshared copy of it.
     */

    if ( objc == 4 ) {
	finalValuePtr = TclLsetList( interp, listPtr,
				     objv[ 2 ], objv[ 3 ] );
    } else {
	finalValuePtr = TclLsetFlat( interp, listPtr,
				     objc-3, objv+2, objv[ objc-1 ] );
    }

    /*
     * If substitution has failed, bail out.
     */

    if ( finalValuePtr == NULL ) {
	return TCL_ERROR;
    }


    /* Finally, update the variable so that traces fire. */


    listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
			      TCL_LEAVE_ERR_MSG );
    Tcl_DecrRefCount( finalValuePtr );
    if ( listPtr == NULL ) {
	return TCL_ERROR;
    }


    /* Return the new value of the variable as the interpreter result. */


    Tcl_SetObjResult( interp, listPtr );
    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsortObjCmd --
 *
 *	This procedure is invoked to process the "lsort" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







>
















|
|

>




>



>











|
|











|





<

|

>
|
>

|
|



>
|
>

|
|
|



|
|
|


|
|
<

|
|






|



>
|
>

|
|
|
|



>
|
>

|

<







|
|







3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834

3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863

3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893

3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
	    }
	}
    }

    /*
     * Return everything or a single value.
     */

    if (allMatches) {
	Tcl_SetObjResult(interp, listPtr);
    } else if (!inlineReturn) {
	if (returnSubindices) {
	    int j;
	    itemPtr = Tcl_NewIntObj(index);
	    for (j=0 ; j<sortInfo.indexc ; j++) {
		Tcl_ListObjAppendElement(interp, itemPtr,
			Tcl_NewIntObj(sortInfo.indexv[j]));
	    }
	    Tcl_SetObjResult(interp, itemPtr);
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
	}
    } else if (index < 0) {
	/*
	 * Is this superfluous? The result should be a blank object by
	 * default...
	 */

	Tcl_SetObjResult(interp, Tcl_NewObj());
    } else {
	Tcl_SetObjResult(interp, listv[index]);
    }

    /*
     * Cleanup the index list array.
     */

    if (sortInfo.indexc > 1) {
	ckfree((char *) sortInfo.indexv);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsetObjCmd --
 *
 *	This procedure is invoked to process the "lset" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LsetObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument values. */
{

    Tcl_Obj* listPtr;		/* Pointer to the list being altered. */
    Tcl_Obj* finalValuePtr;	/* Value finally assigned to the variable. */

    /*
     * Check parameter count.
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "listVar index ?index...? value");
	return TCL_ERROR;
    }

    /*
     * Look up the list variable's value.
     */

    listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
	    TCL_LEAVE_ERR_MSG);
    if (listPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Substitute the value in the value. Return either the value or else an
     * unshared copy of it.
     */

    if (objc == 4) {
	finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);

    } else {
	finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2,
		objv[objc-1]);
    }

    /*
     * If substitution has failed, bail out.
     */

    if (finalValuePtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Finally, update the variable so that traces fire.
     */

    listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr,
	    TCL_LEAVE_ERR_MSG);
    Tcl_DecrRefCount(finalValuePtr);
    if (listPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Return the new value of the variable as the interpreter result.
     */

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsortObjCmd --
 *
 *	This procedure is invoked to process the "lsort" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768

3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786

3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
    Tcl_Obj *CONST objv[];	/* Argument values. */
{
    int i, index, unique, indices;
    Tcl_Obj *resultPtr;
    int length;
    Tcl_Obj *cmdPtr, **listObjPtrs;
    SortElement *elementArray;
    SortElement *elementPtr;        
    SortInfo sortInfo;                  /* Information about this sort that
					 * needs to be passed to the 
					 * comparison function */
    static CONST char *switches[] = {
	"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
	"-index", "-indices", "-integer", "-real", "-unique", (char *) NULL

    };
    enum Lsort_Switches {
	LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY,
	LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER,
	LSORT_REAL, LSORT_UNIQUE
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
	return TCL_ERROR;
    }

    /*
     * Parse arguments to set up the mode for the sort.
     */

    sortInfo.isIncreasing = 1;
    sortInfo.sortMode = SORTMODE_ASCII;

    sortInfo.indexv = NULL;
    sortInfo.indexc = 0;
    sortInfo.interp = interp;
    sortInfo.resultCode = TCL_OK;
    cmdPtr = NULL;
    unique = 0;
    indices = 0;
    for (i = 1; i < objc-1; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum Lsort_Switches) index) {
	case LSORT_ASCII:
	    sortInfo.sortMode = SORTMODE_ASCII;
	    break;
	case LSORT_COMMAND:







|
|
<
|


|
>




|













>








|
|







3918
3919
3920
3921
3922
3923
3924
3925
3926

3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
    Tcl_Obj *CONST objv[];	/* Argument values. */
{
    int i, index, unique, indices;
    Tcl_Obj *resultPtr;
    int length;
    Tcl_Obj *cmdPtr, **listObjPtrs;
    SortElement *elementArray;
    SortElement *elementPtr;
    SortInfo sortInfo;		/* Information about this sort that needs to

				 * be passed to the comparison function. */
    static CONST char *switches[] = {
	"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
	"-index", "-indices", "-integer", "-nocase", "-real", "-unique",
	(char *) NULL
    };
    enum Lsort_Switches {
	LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY,
	LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER,
	LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
	return TCL_ERROR;
    }

    /*
     * Parse arguments to set up the mode for the sort.
     */

    sortInfo.isIncreasing = 1;
    sortInfo.sortMode = SORTMODE_ASCII;
    sortInfo.strCmpFn = strcmp;
    sortInfo.indexv = NULL;
    sortInfo.indexc = 0;
    sortInfo.interp = interp;
    sortInfo.resultCode = TCL_OK;
    cmdPtr = NULL;
    unique = 0;
    indices = 0;
    for (i = 1; i < objc-1; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum Lsort_Switches) index) {
	case LSORT_ASCII:
	    sortInfo.sortMode = SORTMODE_ASCII;
	    break;
	case LSORT_COMMAND:
3831
3832
3833
3834
3835
3836
3837

3838
3839
3840

3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884



3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
		ckfree((char *) sortInfo.indexv);
	    }
	    if (i == (objc-2)) {
		Tcl_AppendResult(interp, "\"-index\" option must be ",
			"followed by list index", NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Take copy to prevent shimmering problems.
	     */

	    if (Tcl_ListObjGetElements(interp, objv[i+1],
		    &sortInfo.indexc, &indices) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (sortInfo.indexc) {
	    case 0:
		sortInfo.indexv = NULL;
		break;
	    case 1:
		sortInfo.indexv = &sortInfo.singleIndex;
		break;
	    default:
		sortInfo.indexv = (int *)
			ckalloc(sizeof(int) * sortInfo.indexc);
	    }

	    /*
	     * Fill the array by parsing each index.  We don't know
	     * whether their scale is sensible yet, but we at least
	     * perform the syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {
		    char buffer[TCL_INTEGER_SPACE];
		    
		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }
		    sprintf(buffer, "%d", j);
		    Tcl_AddErrorInfo(interp,
			    "\n    (-index option item number ");
		    Tcl_AddErrorInfo(interp, buffer);
		    Tcl_AddErrorInfo(interp, ")");
		    return TCL_ERROR;
		}
	    }
	    i++;
	    break;
	}
	case LSORT_INTEGER:
	    sortInfo.sortMode = SORTMODE_INTEGER;
	    break;



	case LSORT_REAL:
	    sortInfo.sortMode = SORTMODE_REAL;
	    break;
	case LSORT_UNIQUE:
	    unique = 1;
	    break;
	case LSORT_INDICES:
	    indices = 1;
	    break;
	}
    }

    if (sortInfo.sortMode == SORTMODE_COMMAND) {
	/*
	 * The existing command is a list. We want to flatten it, append
	 * two dummy arguments on the end, and replace these arguments
	 * later.
	 */

	Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
	Tcl_Obj *newObjPtr = Tcl_NewObj();

	Tcl_IncrRefCount(newCommandPtr);
	if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)







>



>
|
|















|
|
|





<
<



<
|
|
<
<









>
>
>














|
|
<







3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031


4032
4033
4034

4035
4036


4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064

4065
4066
4067
4068
4069
4070
4071
		ckfree((char *) sortInfo.indexv);
	    }
	    if (i == (objc-2)) {
		Tcl_AppendResult(interp, "\"-index\" option must be ",
			"followed by list index", NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Take copy to prevent shimmering problems.
	     */

	    if (Tcl_ListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
		    &indices) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (sortInfo.indexc) {
	    case 0:
		sortInfo.indexv = NULL;
		break;
	    case 1:
		sortInfo.indexv = &sortInfo.singleIndex;
		break;
	    default:
		sortInfo.indexv = (int *)
			ckalloc(sizeof(int) * sortInfo.indexc);
	    }

	    /*
	     * Fill the array by parsing each index. We don't know whether
	     * their scale is sensible yet, but we at least perform the
	     * syntactic check here.
	     */

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
			&sortInfo.indexv[j]) != TCL_OK) {


		    if (sortInfo.indexc > 1) {
			ckfree((char *) sortInfo.indexv);
		    }

		    TclFormatToErrorInfo(interp,
			    "\n    (-index option item number %d)", j);


		    return TCL_ERROR;
		}
	    }
	    i++;
	    break;
	}
	case LSORT_INTEGER:
	    sortInfo.sortMode = SORTMODE_INTEGER;
	    break;
	case LSORT_NOCASE:
	    sortInfo.strCmpFn = strcasecmp;
	    break;
	case LSORT_REAL:
	    sortInfo.sortMode = SORTMODE_REAL;
	    break;
	case LSORT_UNIQUE:
	    unique = 1;
	    break;
	case LSORT_INDICES:
	    indices = 1;
	    break;
	}
    }

    if (sortInfo.sortMode == SORTMODE_COMMAND) {
	/*
	 * The existing command is a list. We want to flatten it, append two
	 * dummy arguments on the end, and replace these arguments later.

	 */

	Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
	Tcl_Obj *newObjPtr = Tcl_NewObj();

	Tcl_IncrRefCount(newCommandPtr);
	if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071

    done:
    if (sortInfo.sortMode == SORTMODE_COMMAND) {
	Tcl_DecrRefCount(sortInfo.compareCmdPtr);
	sortInfo.compareCmdPtr = NULL;
    }
    if (sortInfo.indexc > 1) {
        ckfree((char *) sortInfo.indexv);
    }
    return sortInfo.resultCode;
}

/*
 *----------------------------------------------------------------------
 *
 * MergeSort -
 *
 *	This procedure sorts a linked list of SortElement structures
 *	use the merge-sort algorithm.
 *
 * Results:
 *      A pointer to the head of the list after sorting is returned.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something
 *	weird.
 *
 *----------------------------------------------------------------------
 */

static SortElement *
MergeSort(headPtr, infoPtr)
    SortElement *headPtr;               /* First element on the list */
    SortInfo *infoPtr;                  /* Information needed by the
					 * comparison operator */
{
    /*
     * The subList array below holds pointers to temporary lists built
     * during the merge sort.  Element i of the array holds a list of
     * length 2**i.
     */

#   define NUM_LISTS 30
    SortElement *subList[NUM_LISTS];
    SortElement *elementPtr;
    int i;

    for(i = 0; i < NUM_LISTS; i++){
	subList[i] = NULL;
    }
    while (headPtr != NULL) {
	elementPtr = headPtr;
	headPtr = headPtr->nextPtr;
	elementPtr->nextPtr = 0;
	for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
	    elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
	    subList[i] = NULL;
	}
	if (i >= NUM_LISTS) {
	    i = NUM_LISTS-1;
	}
	subList[i] = elementPtr;
    }
    elementPtr = NULL;
    for (i = 0; i < NUM_LISTS; i++){
	elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
    }
    return elementPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * MergeLists -
 *
 *	This procedure combines two sorted lists of SortElement structures
 *	into a single sorted list.
 *
 * Results:
 *      The unified list of SortElement structures.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something
 *	weird.
 *
 *----------------------------------------------------------------------
 */

static SortElement *
MergeLists(leftPtr, rightPtr, infoPtr)
    SortElement *leftPtr;               /* First list to be merged; may be
					 * NULL. */
    SortElement *rightPtr;              /* Second list to be merged; may be
					 * NULL. */
    SortInfo *infoPtr;                  /* Information needed by the
					 * comparison operator. */
{
    SortElement *headPtr;
    SortElement *tailPtr;
    int cmp;

    if (leftPtr == NULL) {
	return rightPtr;







|









|
|


|


|
<






|
|
|


|
|
<







|






|









|














|


|
<






|
<
|
<
|
|







4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156

4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169

4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212

4213
4214
4215
4216
4217
4218
4219

4220

4221
4222
4223
4224
4225
4226
4227
4228
4229

    done:
    if (sortInfo.sortMode == SORTMODE_COMMAND) {
	Tcl_DecrRefCount(sortInfo.compareCmdPtr);
	sortInfo.compareCmdPtr = NULL;
    }
    if (sortInfo.indexc > 1) {
	ckfree((char *) sortInfo.indexv);
    }
    return sortInfo.resultCode;
}

/*
 *----------------------------------------------------------------------
 *
 * MergeSort -
 *
 *	This procedure sorts a linked list of SortElement structures use the
 *	merge-sort algorithm.
 *
 * Results:
 *	A pointer to the head of the list after sorting is returned.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something weird.

 *
 *----------------------------------------------------------------------
 */

static SortElement *
MergeSort(headPtr, infoPtr)
    SortElement *headPtr;	/* First element on the list. */
    SortInfo *infoPtr;		/* Information needed by the comparison
				 * operator. */
{
    /*
     * The subList array below holds pointers to temporary lists built during
     * the merge sort. Element i of the array holds a list of length 2**i.

     */

#   define NUM_LISTS 30
    SortElement *subList[NUM_LISTS];
    SortElement *elementPtr;
    int i;

    for (i=0 ; i<NUM_LISTS ; i++) {
	subList[i] = NULL;
    }
    while (headPtr != NULL) {
	elementPtr = headPtr;
	headPtr = headPtr->nextPtr;
	elementPtr->nextPtr = 0;
	for (i=0 ; i<NUM_LISTS && subList[i]!=NULL ; i++) {
	    elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
	    subList[i] = NULL;
	}
	if (i >= NUM_LISTS) {
	    i = NUM_LISTS-1;
	}
	subList[i] = elementPtr;
    }
    elementPtr = NULL;
    for (i=0 ; i<NUM_LISTS ; i++) {
	elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
    }
    return elementPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * MergeLists -
 *
 *	This procedure combines two sorted lists of SortElement structures
 *	into a single sorted list.
 *
 * Results:
 *	The unified list of SortElement structures.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something weird.

 *
 *----------------------------------------------------------------------
 */

static SortElement *
MergeLists(leftPtr, rightPtr, infoPtr)
    SortElement *leftPtr;	/* First list to be merged; may be NULL. */

    SortElement *rightPtr;	/* Second list to be merged; may be NULL. */

    SortInfo *infoPtr;		/* Information needed by the comparison
				 * operator. */
{
    SortElement *headPtr;
    SortElement *tailPtr;
    int cmp;

    if (leftPtr == NULL) {
	return rightPtr;
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145

4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
 *
 * SortCompare --
 *
 *	This procedure is invoked by MergeLists to determine the proper
 *	ordering between two elements.
 *
 * Results:
 *      A negative results means the the first element comes before the
 *      second, and a positive results means that the second element
 *      should come first.  A result of zero means the two elements
 *      are equal and it doesn't matter which comes first.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something
 *	weird.
 *
 *----------------------------------------------------------------------
 */

static int
SortCompare(objPtr1, objPtr2, infoPtr)
    Tcl_Obj *objPtr1, *objPtr2;		/* Values to be compared. */
    SortInfo *infoPtr;                  /* Information passed from the
					 * top-level "lsort" command */
{
    int order;

    order = 0;
    if (infoPtr->resultCode != TCL_OK) {
	/*
	 * Once an error has occurred, skip any future comparisons so
	 * as to preserve the error message in sortInterp->result.
	 */

	return order;
    }

    objPtr1 = SelectObjFromSublist(objPtr1, infoPtr);
    if (infoPtr->resultCode != TCL_OK) {
	return order;
    }
    objPtr2 = SelectObjFromSublist(objPtr2, infoPtr);
    if (infoPtr->resultCode != TCL_OK) {
	return order;
    }

    if (infoPtr->sortMode == SORTMODE_ASCII) {
	order = strcmp(TclGetString(objPtr1), TclGetString(objPtr2));
    } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
	order = DictionaryCompare(
		TclGetString(objPtr1), TclGetString(objPtr2));
    } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
	long a, b;

	if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
		|| (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
		!= TCL_OK)) {
	    infoPtr->resultCode = TCL_ERROR;
	    return order;
	}
	if (a > b) {
	    order = 1;
	} else if (b > a) {
	    order = -1;
	}
    } else if (infoPtr->sortMode == SORTMODE_REAL) {
	double a, b;

	if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
	      || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
		      != TCL_OK)) {
	    infoPtr->resultCode = TCL_ERROR;
	    return order;
	}
	if (a > b) {
	    order = 1;
	} else if (b > a) {
	    order = -1;
	}
    } else {
	Tcl_Obj **objv, *paramObjv[2];
	int objc;

	paramObjv[0] = objPtr1;
	paramObjv[1] = objPtr2;

  	/*
 	 * We made space in the command list for the two things to
	 * compare. Replace them and evaluate the result.
	 */

	Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
	Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
		2, 2, paramObjv);
   	Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
		&objc, &objv);

	infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);

  	if (infoPtr->resultCode != TCL_OK) {
	    Tcl_AddErrorInfo(infoPtr->interp,
		    "\n    (-compare command)");
	    return order;
	}

	/*
	 * Parse the result of the command.







|
|
|
|


|
<






|
|
|






|
|

>













|




















|
|
<















|
|
|





|




|







4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284

4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339

4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
 *
 * SortCompare --
 *
 *	This procedure is invoked by MergeLists to determine the proper
 *	ordering between two elements.
 *
 * Results:
 *	A negative results means the the first element comes before the
 *	second, and a positive results means that the second element should
 *	come first. A result of zero means the two elements are equal and it
 *	doesn't matter which comes first.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something weird.

 *
 *----------------------------------------------------------------------
 */

static int
SortCompare(objPtr1, objPtr2, infoPtr)
    Tcl_Obj *objPtr1, *objPtr2;	/* Values to be compared. */
    SortInfo *infoPtr;		/* Information passed from the top-level
				 * "lsort" command. */
{
    int order;

    order = 0;
    if (infoPtr->resultCode != TCL_OK) {
	/*
	 * Once an error has occurred, skip any future comparisons so as to
	 * preserve the error message in sortInterp->result.
	 */

	return order;
    }

    objPtr1 = SelectObjFromSublist(objPtr1, infoPtr);
    if (infoPtr->resultCode != TCL_OK) {
	return order;
    }
    objPtr2 = SelectObjFromSublist(objPtr2, infoPtr);
    if (infoPtr->resultCode != TCL_OK) {
	return order;
    }

    if (infoPtr->sortMode == SORTMODE_ASCII) {
	order = infoPtr->strCmpFn(TclGetString(objPtr1), TclGetString(objPtr2));
    } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
	order = DictionaryCompare(
		TclGetString(objPtr1), TclGetString(objPtr2));
    } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
	long a, b;

	if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
		|| (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
		!= TCL_OK)) {
	    infoPtr->resultCode = TCL_ERROR;
	    return order;
	}
	if (a > b) {
	    order = 1;
	} else if (b > a) {
	    order = -1;
	}
    } else if (infoPtr->sortMode == SORTMODE_REAL) {
	double a, b;

	if (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK
		|| Tcl_GetDoubleFromObj(infoPtr->interp,objPtr2,&b) != TCL_OK){

	    infoPtr->resultCode = TCL_ERROR;
	    return order;
	}
	if (a > b) {
	    order = 1;
	} else if (b > a) {
	    order = -1;
	}
    } else {
	Tcl_Obj **objv, *paramObjv[2];
	int objc;

	paramObjv[0] = objPtr1;
	paramObjv[1] = objPtr2;

	/*
	 * We made space in the command list for the two things to compare.
	 * Replace them and evaluate the result.
	 */

	Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
	Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
		2, 2, paramObjv);
	Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
		&objc, &objv);

	infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);

	if (infoPtr->resultCode != TCL_OK) {
	    Tcl_AddErrorInfo(infoPtr->interp,
		    "\n    (-compare command)");
	    return order;
	}

	/*
	 * Parse the result of the command.
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335

4336
4337
4338
4339
4340
4341

4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422

4423
4424
4425

4426
4427
4428

4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446








}

/*
 *----------------------------------------------------------------------
 *
 * DictionaryCompare
 *
 *	This function compares two strings as if they were being used in
 *	an index or card catalog.  The case of alphabetic characters is
 *	ignored, except to break ties.  Thus "B" comes before "b" but
 *	after "a".  Also, integers embedded in the strings compare in
 *	numerical order.  In other words, "x10y" comes after "x9y", not
 *      before it as it would when using strcmp().
 *
 * Results:
 *      A negative result means that the first element comes before the
 *      second, and a positive result means that the second element
 *      should come first.  A result of zero means the two elements
 *      are equal and it doesn't matter which comes first.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
DictionaryCompare(left, right)
    char *left, *right;          /* The strings to compare */
{
    Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
    int diff, zeros;
    int secondaryDiff = 0;

    while (1) {
	if (isdigit(UCHAR(*right)) /* INTL: digit */
		&& isdigit(UCHAR(*left))) { /* INTL: digit */
	    /*
	     * There are decimal numbers embedded in the two
	     * strings.  Compare them as numbers, rather than
	     * strings.  If one number has more leading zeros than
	     * the other, the number with more leading zeros sorts
	     * later, but only as a secondary choice.
	     */

	    zeros = 0;
	    while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
		right++;
		zeros--;
	    }
	    while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
		left++;
		zeros++;
	    }
	    if (secondaryDiff == 0) {
		secondaryDiff = zeros;
	    }

	    /*
	     * The code below compares the numbers in the two
	     * strings without ever converting them to integers.  It
	     * does this by first comparing the lengths of the
	     * numbers and then comparing the digit values.
	     */

	    diff = 0;
	    while (1) {
		if (diff == 0) {
		    diff = UCHAR(*left) - UCHAR(*right);
		}
		right++;
		left++;
		if (!isdigit(UCHAR(*right))) { /* INTL: digit */
		    if (isdigit(UCHAR(*left))) { /* INTL: digit */
			return 1;
		    } else {
			/*
			 * The two numbers have the same length. See
			 * if their values are different.
			 */

			if (diff != 0) {
			    return diff;
			}
			break;
		    }
		} else if (!isdigit(UCHAR(*left))) { /* INTL: digit */
		    return -1;
		}
	    }
	    continue;
	}

	/*
	 * Convert character to Unicode for comparison purposes.  If either
	 * string is at the terminating null, do a byte-wise comparison and
	 * bail out immediately.
	 */

	if ((*left != '\0') && (*right != '\0')) {
	    left += Tcl_UtfToUniChar(left, &uniLeft);
	    right += Tcl_UtfToUniChar(right, &uniRight);

	    /*
	     * Convert both chars to lower for the comparison, because
	     * dictionary sorts are case insensitve.  Covert to lower, not
	     * upper, so chars between Z and a will sort before A (where most
	     * other interesting punctuations occur)
	     */

	    uniLeftLower = Tcl_UniCharToLower(uniLeft);
	    uniRightLower = Tcl_UniCharToLower(uniRight);
	} else {
	    diff = UCHAR(*left) - UCHAR(*right);
	    break;
	}

	diff = uniLeftLower - uniRightLower;
	if (diff) {
	    return diff;
	} else if (secondaryDiff == 0) {
	    if (Tcl_UniCharIsUpper(uniLeft) &&
		    Tcl_UniCharIsLower(uniRight)) {
		secondaryDiff = -1;
	    } else if (Tcl_UniCharIsUpper(uniRight)
		    && Tcl_UniCharIsLower(uniLeft)) {
		secondaryDiff = 1;
	    }
	}
    }
    if (diff == 0) {
	diff = secondaryDiff;
    }
    return diff;
}

/*
 *----------------------------------------------------------------------
 *
 * SelectObjFromSublist --
 *
 *	This procedure is invoked from lsearch and SortCompare.  It is
 *	used for implementing the -index option, for the lsort and
 *	lsearch commands.
 *
 * Results:
 *      Returns NULL if a failure occurs, and sets the result in the
 *      infoPtr.  Otherwise returns the Tcl_Obj* to the item.
 *
 * Side effects:
 *      None.
 *
 * Note:
 *      No reference counting is done, as the result is only used
 *      internally and never passed directly to user code.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SelectObjFromSublist(objPtr, infoPtr)
    Tcl_Obj *objPtr;			/* Obj to select sublist from. */
    SortInfo *infoPtr;			/* Information passed from the
					 * top-level "lsearch" or "lsort"
					 * command. */
{
    int i;

    /*
     * Quick check for case when no "-index" option is there.
     */

    if (infoPtr->indexc == 0) {
	return objPtr;
    }

    /*
     * Iterate over the indices, traversing through the nested
     * sublists as we go.
     */

    for (i=0 ; i<infoPtr->indexc ; i++) {
	int listLen, index;
	Tcl_Obj *currentObj;

	if (Tcl_ListObjLength(infoPtr->interp, objPtr,
		&listLen) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	index = infoPtr->indexv[i];

	/*
	 * Adjust for end-based indexing.
	 */

	if (index < SORTIDX_NONE) {
	    index += listLen + 1;
	}

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {
	    char buffer[TCL_INTEGER_SPACE];
	    TclFormatInt(buffer, index);
	    Tcl_AppendResult(infoPtr->interp,
		    "element ", buffer, " missing from sublist \"",
		    TclGetString(objPtr), "\"", (char *) NULL);
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	objPtr = currentObj;
    }
    return objPtr;
}















|
|
|
|
|
|


|
|
|
|









|






|
|

|
|
<
|
|
















|
|
|
|









|
|



|
|







|







|







>


|



>











|
<


















|
|
|


|
|


|


|
|






|
|
|
<












|
|












>



>



>


















>
>
>
>
>
>
>
>
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430

4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511

4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552

4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
}

/*
 *----------------------------------------------------------------------
 *
 * DictionaryCompare
 *
 *	This function compares two strings as if they were being used in an
 *	index or card catalog. The case of alphabetic characters is ignored,
 *	except to break ties. Thus "B" comes before "b" but after "a". Also,
 *	integers embedded in the strings compare in numerical order. In other
 *	words, "x10y" comes after "x9y", not * before it as it would when
 *	using strcmp().
 *
 * Results:
 *	A negative result means that the first element comes before the
 *	second, and a positive result means that the second element should
 *	come first. A result of zero means the two elements are equal and it
 *	doesn't matter which comes first.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
DictionaryCompare(left, right)
    char *left, *right;		/* The strings to compare. */
{
    Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
    int diff, zeros;
    int secondaryDiff = 0;

    while (1) {
	if (isdigit(UCHAR(*right))		/* INTL: digit */
		&& isdigit(UCHAR(*left))) {	/* INTL: digit */
	    /*
	     * There are decimal numbers embedded in the two strings. Compare
	     * them as numbers, rather than strings. If one number has more

	     * leading zeros than the other, the number with more leading
	     * zeros sorts later, but only as a secondary choice.
	     */

	    zeros = 0;
	    while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
		right++;
		zeros--;
	    }
	    while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
		left++;
		zeros++;
	    }
	    if (secondaryDiff == 0) {
		secondaryDiff = zeros;
	    }

	    /*
	     * The code below compares the numbers in the two strings without
	     * ever converting them to integers. It does this by first
	     * comparing the lengths of the numbers and then comparing the
	     * digit values.
	     */

	    diff = 0;
	    while (1) {
		if (diff == 0) {
		    diff = UCHAR(*left) - UCHAR(*right);
		}
		right++;
		left++;
		if (!isdigit(UCHAR(*right))) {		/* INTL: digit */
		    if (isdigit(UCHAR(*left))) {	/* INTL: digit */
			return 1;
		    } else {
			/*
			 * The two numbers have the same length. See if their
			 * values are different.
			 */

			if (diff != 0) {
			    return diff;
			}
			break;
		    }
		} else if (!isdigit(UCHAR(*left))) {	/* INTL: digit */
		    return -1;
		}
	    }
	    continue;
	}

	/*
	 * Convert character to Unicode for comparison purposes. If either
	 * string is at the terminating null, do a byte-wise comparison and
	 * bail out immediately.
	 */

	if ((*left != '\0') && (*right != '\0')) {
	    left += Tcl_UtfToUniChar(left, &uniLeft);
	    right += Tcl_UtfToUniChar(right, &uniRight);

	    /*
	     * Convert both chars to lower for the comparison, because
	     * dictionary sorts are case insensitve. Covert to lower, not
	     * upper, so chars between Z and a will sort before A (where most
	     * other interesting punctuations occur)
	     */

	    uniLeftLower = Tcl_UniCharToLower(uniLeft);
	    uniRightLower = Tcl_UniCharToLower(uniRight);
	} else {
	    diff = UCHAR(*left) - UCHAR(*right);
	    break;
	}

	diff = uniLeftLower - uniRightLower;
	if (diff) {
	    return diff;
	} else if (secondaryDiff == 0) {
	    if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) {

		secondaryDiff = -1;
	    } else if (Tcl_UniCharIsUpper(uniRight)
		    && Tcl_UniCharIsLower(uniLeft)) {
		secondaryDiff = 1;
	    }
	}
    }
    if (diff == 0) {
	diff = secondaryDiff;
    }
    return diff;
}

/*
 *----------------------------------------------------------------------
 *
 * SelectObjFromSublist --
 *
 *	This procedure is invoked from lsearch and SortCompare. It is used
 *	for implementing the -index option, for the lsort and lsearch
 *	commands.
 *
 * Results:
 *	Returns NULL if a failure occurs, and sets the result in the infoPtr.
 *	Otherwise returns the Tcl_Obj* to the item.
 *
 * Side effects:
 *	None.
 *
 * Note:
 *	No reference counting is done, as the result is only used internally
 *	and never passed directly to user code.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SelectObjFromSublist(objPtr, infoPtr)
    Tcl_Obj *objPtr;		/* Obj to select sublist from. */
    SortInfo *infoPtr;		/* Information passed from the top-level
				 * "lsearch" or "lsort" command. */

{
    int i;

    /*
     * Quick check for case when no "-index" option is there.
     */

    if (infoPtr->indexc == 0) {
	return objPtr;
    }

    /*
     * Iterate over the indices, traversing through the nested sublists as we
     * go.
     */

    for (i=0 ; i<infoPtr->indexc ; i++) {
	int listLen, index;
	Tcl_Obj *currentObj;

	if (Tcl_ListObjLength(infoPtr->interp, objPtr,
		&listLen) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	index = infoPtr->indexv[i];

	/*
	 * Adjust for end-based indexing.
	 */

	if (index < SORTIDX_NONE) {
	    index += listLen + 1;
	}

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {
	    char buffer[TCL_INTEGER_SPACE];
	    TclFormatInt(buffer, index);
	    Tcl_AppendResult(infoPtr->interp,
		    "element ", buffer, " missing from sublist \"",
		    TclGetString(objPtr), "\"", (char *) NULL);
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	objPtr = currentObj;
    }
    return objPtr;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCmdMZ.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
/* 
 * tclCmdMZ.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	M to Z.  It contains only commands in the generic core (i.e.
 *	those that don't depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.115 2004/10/21 15:19:46 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *	This procedure is invoked to process the "pwd" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Obj *retVal;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
|


|
|
|
|







|
|

|




|





|
|













|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
/*
 * tclCmdMZ.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters M to Z. It
 *	contains only commands in the generic core (i.e. those that don't
 *	depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2003 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.13 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *	This procedure is invoked to process the "pwd" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *retVal;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152



153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168

169
170
171

172


173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

194


195
196
197

198
199
200
201
202

203
204
205




206
207
208
209
210
211
212
213
214
215

216
217








218
219
220
221
222
223
224
225
226
227
228

229
230
231
232
233
234
235
236
237
238

239
240
241
242
243
244
245

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272

273
274
275
276
277
278

279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297

298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313

314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpObjCmd --
 *
 *	This procedure is invoked to process the "regexp" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int i, indices, match, about, offset, all, doinline, numMatchesSaved;
    int cflags, eflags, stringLength;
    Tcl_RegExp regExpr;
    Tcl_Obj *objPtr, *resultPtr = NULL;
    Tcl_RegExpInfo info;
    static CONST char *options[] = {
	"-all",		"-about",	"-indices",	"-inline",
	"-expanded",	"-line",	"-linestop",	"-lineanchor",
	"-nocase",	"-start",	"--",		(char *) NULL
    };
    enum options {
	REGEXP_ALL,	REGEXP_ABOUT,	REGEXP_INDICES,	REGEXP_INLINE,
	REGEXP_EXPANDED,REGEXP_LINE,	REGEXP_LINESTOP,REGEXP_LINEANCHOR,
	REGEXP_NOCASE,	REGEXP_START,	REGEXP_LAST
    };

    indices	= 0;
    about	= 0;
    cflags	= TCL_REG_ADVANCED;
    eflags	= 0;
    offset	= 0;
    all		= 0;
    doinline	= 0;
    
    for (i = 1; i < objc; i++) {
	char *name;
	int index;

	name = TclGetString(objv[i]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum options) index) {
	    case REGEXP_ALL: {
		all = 1;
		break;
	    }
	    case REGEXP_INDICES: {
		indices = 1;
		break;
	    }
	    case REGEXP_INLINE: {
		doinline = 1;
		break;
	    }
	    case REGEXP_NOCASE: {
		cflags |= TCL_REG_NOCASE;
		break;
	    }
	    case REGEXP_ABOUT: {
		about = 1;
		break;
	    }
	    case REGEXP_EXPANDED: {
		cflags |= TCL_REG_EXPANDED;
		break;
	    }
	    case REGEXP_LINE: {
		cflags |= TCL_REG_NEWLINE;



		break;
	    }
	    case REGEXP_LINESTOP: {
		cflags |= TCL_REG_NLSTOP;
		break;
	    }
	    case REGEXP_LINEANCHOR: {
		cflags |= TCL_REG_NLANCH;
		break;
	    }
	    case REGEXP_START: {

		if (++i >= objc) {
		    goto endOfForLoop;
		}
		if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
		    return TCL_ERROR;

		}
		if (offset < 0) {
		    offset = 0;

		}


		break;
	    }
	    case REGEXP_LAST: {
		i++;
		goto endOfForLoop;
	    }
	}
    }

    endOfForLoop:
    if ((objc - i) < (2 - about)) {
	Tcl_WrongNumArgs(interp, 1, objv, 
	  "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
	return TCL_ERROR;
    }
    objc -= i;
    objv += i;

    if (doinline && ((objc - 2) != 0)) {
	/*
	 * User requested -inline, but specified match variables - a no-no.

	 */


	Tcl_AppendResult(interp, "regexp match variables not allowed",
		" when using -inline", (char *) NULL);
	return TCL_ERROR;

    }

    /*
     * Handle the odd about case separately.
     */

    if (about) {
	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
	if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {




	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Get the length of the string that we are matching against so
     * we can do the termination test for -all matches.  Do this before
     * getting the regexp to avoid shimmering problems.
     */

    objPtr = objv[1];
    stringLength = Tcl_GetCharLength(objPtr);









    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;
    }

    if (offset > 0) {
	/*
	 * Add flag if using offset (string is part of a larger string),
	 * so that "^" won't match.
	 */

	eflags |= TCL_REG_NOTBOL;
    }

    objc -= 2;
    objv += 2;

    if (doinline) {
	/*
	 * Save all the subexpressions, as we will return them as a list
	 */

	numMatchesSaved = -1;
    } else {
	/*
	 * Save only enough subexpressions for matches we want to keep,
	 * expect in the case of -all, where we need to keep at least
	 * one to know where to move the offset.
	 */

	numMatchesSaved = (objc == 0) ? all : objc;
    }

    /*
     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match.  If "-all"
     * hasn't been specified then the loop body only gets executed once.
     * We terminate the loop when the starting offset is past the end of the
     * string.
     */

    while (1) {
	match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
		offset /* offset */, numMatchesSaved, eflags 
		| ((offset > 0 &&
		   (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
		   ? TCL_REG_NOTBOL : 0));

	if (match < 0) {
	    return TCL_ERROR;
	}

	if (match == 0) {
	    /*
	     * We want to set the value of the intepreter result only when
	     * this is the first time through the loop.
	     */

	    if (all <= 1) {
		/*
		 * If inlining, the interpreter's object result remains
		 * an empty list, otherwise set it to an integer object w/
		 * value 0.
		 */

		if (!doinline) {
		    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
		}
		return TCL_OK;
	    }
	    break;
	}

	/*
	 * If additional variable names have been specified, return
	 * index information in those variables.
	 */

	Tcl_RegExpGetInfo(regExpr, &info);
	if (doinline) {
	    /*
	     * It's the number of substitutions, plus one for the matchVar
	     * at index 0
	     */

	    objc = info.nsubs + 1;
	    if (all <= 1) {
		resultPtr = Tcl_NewObj();
	    }
	}
	for (i = 0; i < objc; i++) {
	    Tcl_Obj *newPtr;

	    if (indices) {
		int start, end;
		Tcl_Obj *objs[2];

		/*
		 * Only adjust the match area if there was a match for
		 * that area.  (Scriptics Bug 4391/SF Bug #219232)
		 */

		if (i <= info.nsubs && info.matches[i].start >= 0) {
		    start = offset + info.matches[i].start;
		    end   = offset + info.matches[i].end;

		    /*
		     * Adjust index so it refers to the last character in the
		     * match instead of the first character after the match.
		     */

		    if (end >= offset) {
			end--;
		    }
		} else {
		    start = -1;
		    end   = -1;
		}

		objs[0] = Tcl_NewLongObj(start);
		objs[1] = Tcl_NewLongObj(end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {







|
|













|
|
|
|




|












|
|
|
|
|
|
|
|










|


|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
|
>
>
>
|
<
<
<
<
<
|
|
|
<
|
>
|
|
|
|
<
>
|
|
<
>
|
>
>
|
|
|
|
|
<



|

|
|
|




<
|
|
>
|
>
>


<
>





>



>
>
>
>






|
|
|

>


>
>
>
>
>
>
>
>








|
|

>










>



|
|
|

>




|
|
|
|
<




|

|
|










>


|
|
|

>









|
|





|
|

>













|
|

>


|











|







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132

133
134
135

136
137
138

139
140
141

142
143
144

145
146
147
148
149
150





151
152
153

154
155
156
157
158
159

160
161
162

163
164
165
166
167
168
169
170
171

172
173
174
175
176
177
178
179
180
181
182
183

184
185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpObjCmd --
 *
 *	This procedure is invoked to process the "regexp" Tcl command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i, indices, match, about, offset, all, doinline, numMatchesSaved;
    int cflags, eflags, stringLength;
    Tcl_RegExp regExpr;
    Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
    Tcl_RegExpInfo info;
    static CONST char *options[] = {
	"-all",		"-about",	"-indices",	"-inline",
	"-expanded",	"-line",	"-linestop",	"-lineanchor",
	"-nocase",	"-start",	"--",		(char *) NULL
    };
    enum options {
	REGEXP_ALL,	REGEXP_ABOUT,	REGEXP_INDICES,	REGEXP_INLINE,
	REGEXP_EXPANDED,REGEXP_LINE,	REGEXP_LINESTOP,REGEXP_LINEANCHOR,
	REGEXP_NOCASE,	REGEXP_START,	REGEXP_LAST
    };

    indices = 0;
    about = 0;
    cflags = TCL_REG_ADVANCED;
    eflags = 0;
    offset = 0;
    all = 0;
    doinline = 0;

    for (i = 1; i < objc; i++) {
	char *name;
	int index;

	name = TclGetString(objv[i]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
		&index) != TCL_OK) {
	    goto optionError;
	}
	switch ((enum options) index) {
	case REGEXP_ALL:
	    all = 1;
	    break;

	case REGEXP_INDICES:
	    indices = 1;
	    break;

	case REGEXP_INLINE:
	    doinline = 1;
	    break;

	case REGEXP_NOCASE:
	    cflags |= TCL_REG_NOCASE;
	    break;

	case REGEXP_ABOUT:
	    about = 1;
	    break;

	case REGEXP_EXPANDED:
	    cflags |= TCL_REG_EXPANDED;
	    break;

	case REGEXP_LINE:
	    cflags |= TCL_REG_NEWLINE;
	    break;
	case REGEXP_LINESTOP:
	    cflags |= TCL_REG_NLSTOP;
	    break;





	case REGEXP_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;

	case REGEXP_START: {
	    int temp;
	    if (++i >= objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) {

		goto optionError;
	    }
	    if (startIndex) {

		Tcl_DecrRefCount(startIndex);
	    }
	    startIndex = objv[i];
	    Tcl_IncrRefCount(startIndex);
	    break;
	}
	case REGEXP_LAST:
	    i++;
	    goto endOfForLoop;

	}
    }

  endOfForLoop:
    if ((objc - i) < (2 - about)) {
	Tcl_WrongNumArgs(interp, 1, objv,
	    "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
	goto optionError;
    }
    objc -= i;
    objv += i;


    /*
     * Check if the user requested -inline, but specified match variables; a
     * no-no.
     */

    if (doinline && ((objc - 2) != 0)) {
	Tcl_AppendResult(interp, "regexp match variables not allowed",
		" when using -inline", (char *) NULL);

	goto optionError;
    }

    /*
     * Handle the odd about case separately.
     */

    if (about) {
	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
	if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
	optionError:
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Get the length of the string that we are matching against so we can do
     * the termination test for -all matches. Do this before getting the
     * regexp to avoid shimmering problems.
     */

    objPtr = objv[1];
    stringLength = Tcl_GetCharLength(objPtr);

    if (startIndex) {
	TclGetIntForIndex(NULL, startIndex, stringLength, &offset);
	Tcl_DecrRefCount(startIndex);
	if (offset < 0) {
	    offset = 0;
	}
    }

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;
    }

    if (offset > 0) {
	/*
	 * Add flag if using offset (string is part of a larger string), so
	 * that "^" won't match.
	 */

	eflags |= TCL_REG_NOTBOL;
    }

    objc -= 2;
    objv += 2;

    if (doinline) {
	/*
	 * Save all the subexpressions, as we will return them as a list
	 */

	numMatchesSaved = -1;
    } else {
	/*
	 * Save only enough subexpressions for matches we want to keep, expect
	 * in the case of -all, where we need to keep at least one to know
	 * where to move the offset.
	 */

	numMatchesSaved = (objc == 0) ? all : objc;
    }

    /*
     * The following loop is to handle multiple matches within the same source
     * string; each iteration handles one match. If "-all" hasn't been
     * specified then the loop body only gets executed once. We terminate the
     * loop when the starting offset is past the end of the string.

     */

    while (1) {
	match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
		offset /* offset */, numMatchesSaved, eflags
		| ((offset > 0 &&
		(Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
		? TCL_REG_NOTBOL : 0));

	if (match < 0) {
	    return TCL_ERROR;
	}

	if (match == 0) {
	    /*
	     * We want to set the value of the intepreter result only when
	     * this is the first time through the loop.
	     */

	    if (all <= 1) {
		/*
		 * If inlining, the interpreter's object result remains an
		 * empty list, otherwise set it to an integer object w/ value
		 * 0.
		 */

		if (!doinline) {
		    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
		}
		return TCL_OK;
	    }
	    break;
	}

	/*
	 * If additional variable names have been specified, return index
	 * information in those variables.
	 */

	Tcl_RegExpGetInfo(regExpr, &info);
	if (doinline) {
	    /*
	     * It's the number of substitutions, plus one for the matchVar at
	     * index 0
	     */

	    objc = info.nsubs + 1;
	    if (all <= 1) {
		resultPtr = Tcl_NewObj();
	    }
	}
	for (i = 0; i < objc; i++) {
	    Tcl_Obj *newPtr;

	    if (indices) {
		int start, end;
		Tcl_Obj *objs[2];

		/*
		 * Only adjust the match area if there was a match for that
		 * area. (Scriptics Bug 4391/SF Bug #219232)
		 */

		if (i <= info.nsubs && info.matches[i].start >= 0) {
		    start = offset + info.matches[i].start;
		    end = offset + info.matches[i].end;

		    /*
		     * Adjust index so it refers to the last character in the
		     * match instead of the first character after the match.
		     */

		    if (end >= offset) {
			end--;
		    }
		} else {
		    start = -1;
		    end = -1;
		}

		objs[0] = Tcl_NewLongObj(start);
		objs[1] = Tcl_NewLongObj(end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {
359
360
361
362
363
364
365

366
367
368
369
370
371
372
373
374

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
		}
	    }
	}

	if (all == 0) {
	    break;
	}

	/*
	 * Adjust the offset to the character just after the last one
	 * in the matchVar and increment all to count how many times
	 * we are making a match.  We always increment the offset by at least
	 * one to prevent endless looping (as in the case:
	 * regexp -all {a*} a).  Otherwise, when we match the NULL string at
	 * the end of the input string, we will loop indefinately (because the
	 * length of the match is 0, so offset never changes).
	 */

	if (info.matches[0].end == 0) {
	    offset++;
	}
	offset += info.matches[0].end;
	all++;
	eflags |= TCL_REG_NOTBOL;
	if (offset >= stringLength) {
	    break;
	}
    }

    /*
     * Set the interpreter's object result to an integer object
     * with value 1 if -all wasn't specified, otherwise it's all-1
     * (the number of times through the while - 1).
     */

    if (doinline) {
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegsubObjCmd --
 *
 *	This procedure is invoked to process the "regsub" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
    int start, end, subStart, subEnd, match;
    Tcl_RegExp regExpr;
    Tcl_RegExpInfo info;
    Tcl_Obj *resultPtr, *subPtr, *objPtr;
    Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;

    static CONST char *options[] = {
	"-all",		"-nocase",	"-expanded",
	"-line",	"-linestop",	"-lineanchor",	"-start",
	"--",		NULL
    };







>

|
|
|
|
|
|
|

>












|
|
|















|
|













|
|
|
|





|







374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
		}
	    }
	}

	if (all == 0) {
	    break;
	}

	/*
	 * Adjust the offset to the character just after the last one in the
	 * matchVar and increment all to count how many times we are making a
	 * match. We always increment the offset by at least one to prevent
	 * endless looping (as in the case: regexp -all {a*} a). Otherwise,
	 * when we match the NULL string at the end of the input string, we
	 * will loop indefinately (because the length of the match is 0, so
	 * offset never changes).
	 */

	if (info.matches[0].end == 0) {
	    offset++;
	}
	offset += info.matches[0].end;
	all++;
	eflags |= TCL_REG_NOTBOL;
	if (offset >= stringLength) {
	    break;
	}
    }

    /*
     * Set the interpreter's object result to an integer object with value 1
     * if -all wasn't specified, otherwise it's all-1 (the number of times
     * through the while - 1).
     */

    if (doinline) {
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegsubObjCmd --
 *
 *	This procedure is invoked to process the "regsub" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
    int start, end, subStart, subEnd, match;
    Tcl_RegExp regExpr;
    Tcl_RegExpInfo info;
    Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
    Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;

    static CONST char *options[] = {
	"-all",		"-nocase",	"-expanded",
	"-line",	"-linestop",	"-lineanchor",	"-start",
	"--",		NULL
    };
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493
494


495
496
497
498
499
500
501
502
503
504
505
506




507
508
509
510
511










512
513
514
515
516
517
518
519

520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539

540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
    all = 0;
    offset = 0;
    resultPtr = NULL;

    for (idx = 1; idx < objc; idx++) {
	char *name;
	int index;
	
	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum options) index) {
	    case REGSUB_ALL: {
		all = 1;
		break;
	    }
	    case REGSUB_NOCASE: {
		cflags |= TCL_REG_NOCASE;
		break;
	    }
	    case REGSUB_EXPANDED: {
		cflags |= TCL_REG_EXPANDED;
		break;
	    }
	    case REGSUB_LINE: {
		cflags |= TCL_REG_NEWLINE;
		break;
	    }
	    case REGSUB_LINESTOP: {
		cflags |= TCL_REG_NLSTOP;
		break;
	    }
	    case REGSUB_LINEANCHOR: {
		cflags |= TCL_REG_NLANCH;
		break;
	    }
	    case REGSUB_START: {

		if (++idx >= objc) {
		    goto endOfForLoop;
		}
		if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (offset < 0) {
		    offset = 0;
		}


		break;
	    }
	    case REGSUB_LAST: {
		idx++;
		goto endOfForLoop;
	    }
	}
    }
    endOfForLoop:
    if (objc-idx < 3 || objc-idx > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?switches? exp string subSpec ?varName?");




	return TCL_ERROR;
    }

    objc -= idx;
    objv += idx;











    if (all && (offset == 0)
	    && (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
	    && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
	/*
	 * This is a simple one pair string map situation.  We make use of
	 * a slightly modified version of the one pair STR_MAP code.
	 */

	int slen, nocase;
	int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *,
		unsigned long));
	Tcl_UniChar *p, wsrclc;

	numMatches = 0;
	nocase     = (cflags & TCL_REG_NOCASE);
	strCmpFn   = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;

	wsrc     = Tcl_GetUnicodeFromObj(objv[0], &slen);
	wstring  = Tcl_GetUnicodeFromObj(objv[1], &wlen);
	wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
	wend     = wstring + wlen - (slen ? slen - 1 : 0);
	result   = TCL_OK;

	if (slen == 0) {
	    /*
	     * regsub behavior for "" matches between each character.
	     * 'string map' skips the "" case.
	     */

	    if (wstring < wend) {
		resultPtr = Tcl_NewUnicodeObj(wstring, 0);
		Tcl_IncrRefCount(resultPtr);
		for (; wstring < wend; wstring++) {
		    Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
		    Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
		    numMatches++;
		}
		wlen = 0;
	    }
	} else {
	    wsrclc = Tcl_UniCharToLower(*wsrc);
	    for (p = wfirstChar = wstring; wstring < wend; wstring++) {
		if (((*wstring == *wsrc) ||
			(nocase && (Tcl_UniCharToLower(*wstring) ==
				wsrclc))) &&
			((slen == 1) || (strCmpFn(wstring, wsrc,
				(unsigned long) slen) == 0))) {
		    if (numMatches == 0) {
			resultPtr = Tcl_NewUnicodeObj(wstring, 0);
			Tcl_IncrRefCount(resultPtr);
		    }
		    if (p != wstring) {
			Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);







|






|


|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|



>
>
>
>





>
>
>
>
>
>
>
>
>
>





|
|

>

<
|



|
|

|
|

|
|



|
|

>













|
|
<
|







461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

481
482
483

484
485
486

487
488
489

490
491
492

493
494
495

496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583

584
585
586
587
588
589
590
591
    all = 0;
    offset = 0;
    resultPtr = NULL;

    for (idx = 1; idx < objc; idx++) {
	char *name;
	int index;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
		TCL_EXACT, &index) != TCL_OK) {
	    goto optionError;
	}
	switch ((enum options) index) {
	case REGSUB_ALL:
	    all = 1;
	    break;

	case REGSUB_NOCASE:
	    cflags |= TCL_REG_NOCASE;
	    break;

	case REGSUB_EXPANDED:
	    cflags |= TCL_REG_EXPANDED;
	    break;

	case REGSUB_LINE:
	    cflags |= TCL_REG_NEWLINE;
	    break;

	case REGSUB_LINESTOP:
	    cflags |= TCL_REG_NLSTOP;
	    break;

	case REGSUB_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;

	case REGSUB_START: {
	    int temp;
	    if (++idx >= objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
	    }
	    startIndex = objv[idx];
	    Tcl_IncrRefCount(startIndex);
	    break;
	}
	case REGSUB_LAST:
	    idx++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if (objc-idx < 3 || objc-idx > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?switches? exp string subSpec ?varName?");
    optionError:
	if (startIndex) {
	    Tcl_DecrRefCount(startIndex);
	}
	return TCL_ERROR;
    }

    objc -= idx;
    objv += idx;

    if (startIndex) {
	int stringLength = Tcl_GetCharLength(objv[1]);

	TclGetIntForIndex(NULL, startIndex, stringLength, &offset);
	Tcl_DecrRefCount(startIndex);
	if (offset < 0) {
	    offset = 0;
	}
    }

    if (all && (offset == 0)
	    && (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
	    && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
	/*
	 * This is a simple one pair string map situation. We make use of a
	 * slightly modified version of the one pair STR_MAP code.
	 */

	int slen, nocase;

	int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long);
	Tcl_UniChar *p, wsrclc;

	numMatches = 0;
	nocase = (cflags & TCL_REG_NOCASE);
	strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;

	wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
	wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
	wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
	wend = wstring + wlen - (slen ? slen - 1 : 0);
	result = TCL_OK;

	if (slen == 0) {
	    /*
	     * regsub behavior for "" matches between each character. 'string
	     * map' skips the "" case.
	     */

	    if (wstring < wend) {
		resultPtr = Tcl_NewUnicodeObj(wstring, 0);
		Tcl_IncrRefCount(resultPtr);
		for (; wstring < wend; wstring++) {
		    Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
		    Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
		    numMatches++;
		}
		wlen = 0;
	    }
	} else {
	    wsrclc = Tcl_UniCharToLower(*wsrc);
	    for (p = wfirstChar = wstring; wstring < wend; wstring++) {
		if ((*wstring == *wsrc ||
			(nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) &&

			(slen==1 || (strCmpFn(wstring, wsrc,
				(unsigned long) slen) == 0))) {
		    if (numMatches == 0) {
			resultPtr = Tcl_NewUnicodeObj(wstring, 0);
			Tcl_IncrRefCount(resultPtr);
		    }
		    if (p != wstring) {
			Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617

618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647

648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Make sure to avoid problems where the objects are shared.  This
     * can cause RegExpObj <> UnicodeObj shimmering that causes data
     * corruption.  [Bug #461322]
     */

    if (objv[1] == objv[0]) {
	objPtr = Tcl_DuplicateObj(objv[1]);
    } else {
	objPtr = objv[1];
    }
    wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
    if (objv[2] == objv[0]) {
	subPtr = Tcl_DuplicateObj(objv[2]);
    } else {
	subPtr = objv[2];
    }
    wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);

    result = TCL_OK;

    /*
     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match and its
     * corresponding substitution.  If "-all" hasn't been specified
     * then the loop body only gets executed once.  We must use
     * 'offset <= wlen' in particular for the case where the regexp
     * pattern can match the empty string - this is useful when
     * doing, say, 'regsub -- ^ $str ...' when $str might be empty.

     */

    numMatches = 0;
    for ( ; offset <= wlen; ) {

	/*
	 * The flags argument is set if string is part of a larger string,
	 * so that "^" won't match.
	 */

	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
		10 /* matches */, ((offset > 0 &&
		   (wstring[offset-1] != (Tcl_UniChar)'\n'))
		   ? TCL_REG_NOTBOL : 0));

	if (match < 0) {
	    result = TCL_ERROR;
	    goto done;
	}
	if (match == 0) {
	    break;
	}
	if (numMatches == 0) {
	    resultPtr = Tcl_NewUnicodeObj(wstring, 0);
	    Tcl_IncrRefCount(resultPtr);
	    if (offset > 0) {
		/*
		 * Copy the initial portion of the string in if an offset
		 * was specified.
		 */

		Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
	    }
	}
	numMatches++;

	/*
	 * Copy the portion of the source string before the match to the
	 * result variable.
	 */

	Tcl_RegExpGetInfo(regExpr, &info);
	start = info.matches[0].start;
	end = info.matches[0].end;
	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);

	/*
	 * Append the subSpec argument to the variable, making appropriate
	 * substitutions.  This code is a bit hairy because of the backslash
	 * conventions and because the code saves up ranges of characters in
	 * subSpec to reduce the number of calls to Tcl_SetVar.
	 */

	wsrc = wfirstChar = wsubspec;
	wend = wsubspec + wsublen;
	for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) {







|
|
|


















|
|
|
<
|
|
|
>






|
|




|
|













|
|

>

















|







611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641

642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Make sure to avoid problems where the objects are shared. This can
     * cause RegExpObj <> UnicodeObj shimmering that causes data corruption.
     * [Bug #461322]
     */

    if (objv[1] == objv[0]) {
	objPtr = Tcl_DuplicateObj(objv[1]);
    } else {
	objPtr = objv[1];
    }
    wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
    if (objv[2] == objv[0]) {
	subPtr = Tcl_DuplicateObj(objv[2]);
    } else {
	subPtr = objv[2];
    }
    wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);

    result = TCL_OK;

    /*
     * The following loop is to handle multiple matches within the same source
     * string; each iteration handles one match and its corresponding
     * substitution. If "-all" hasn't been specified then the loop body only

     * gets executed once. We must use 'offset <= wlen' in particular for the
     * case where the regexp pattern can match the empty string - this is
     * useful when doing, say, 'regsub -- ^ $str ...' when $str might be
     * empty.
     */

    numMatches = 0;
    for ( ; offset <= wlen; ) {

	/*
	 * The flags argument is set if string is part of a larger string, so
	 * that "^" won't match.
	 */

	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
		10 /* matches */, ((offset > 0 &&
		(wstring[offset-1] != (Tcl_UniChar)'\n'))
		? TCL_REG_NOTBOL : 0));

	if (match < 0) {
	    result = TCL_ERROR;
	    goto done;
	}
	if (match == 0) {
	    break;
	}
	if (numMatches == 0) {
	    resultPtr = Tcl_NewUnicodeObj(wstring, 0);
	    Tcl_IncrRefCount(resultPtr);
	    if (offset > 0) {
		/*
		 * Copy the initial portion of the string in if an offset was
		 * specified.
		 */

		Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
	    }
	}
	numMatches++;

	/*
	 * Copy the portion of the source string before the match to the
	 * result variable.
	 */

	Tcl_RegExpGetInfo(regExpr, &info);
	start = info.matches[0].start;
	end = info.matches[0].end;
	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);

	/*
	 * Append the subSpec argument to the variable, making appropriate
	 * substitutions. This code is a bit hairy because of the backslash
	 * conventions and because the code saves up ranges of characters in
	 * subSpec to reduce the number of calls to Tcl_SetVar.
	 */

	wsrc = wfirstChar = wsubspec;
	wend = wsubspec + wsublen;
	for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) {
686
687
688
689
690
691
692

693
694
695
696

697
698
699
700
701
702
703
704

705
706
707
708
709

710
711
712

713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730

731
732
733
734
735
736
737
738
739
740
741
742
743
744
745

746
747
748
749
750
751

752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773

774
775
776
777
778


779


780


781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
		    continue;
		} else {
		    continue;
		}
	    } else {
		continue;
	    }

	    if (wfirstChar != wsrc) {
		Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
			wsrc - wfirstChar);
	    }

	    if (idx <= info.nsubs) {
		subStart = info.matches[idx].start;
		subEnd = info.matches[idx].end;
		if ((subStart >= 0) && (subEnd >= 0)) {
		    Tcl_AppendUnicodeToObj(resultPtr,
			    wstring + offset + subStart, subEnd - subStart);
		}
	    }

	    if (*wsrc == '\\') {
		wsrc++;
	    }
	    wfirstChar = wsrc + 1;
	}

	if (wfirstChar != wsrc) {
	    Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
	}

	if (end == 0) {
	    /*
	     * Always consume at least one character of the input string
	     * in order to prevent infinite loops.
	     */

	    if (offset < wlen) {
		Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
	    }
	    offset++;
	} else {
	    offset += end;
	    if (start == end) {
		/*
		 * We matched an empty string, which means we must go 
		 * forward one more step so we don't match again at the
		 * same spot.
		 */

		if (offset < wlen) {
		    Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
		}
		offset++;
	    }
	}
	if (!all) {
	    break;
	}
    }

    /*
     * Copy the portion of the source string after the last match to the
     * result variable.
     */

    regsubDone:
    if (numMatches == 0) {
	/*
	 * On zero matches, just ignore the offset, since it shouldn't
	 * matter to us in this case, and the user may have skewed it.
	 */

	resultPtr = objv[1];
	Tcl_IncrRefCount(resultPtr);
    } else if (offset < wlen) {
	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
    }
    if (objc == 4) {
	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
	    Tcl_AppendResult(interp, "couldn't set variable \"",
		    TclGetString(objv[3]), "\"", (char *) NULL);
	    result = TCL_ERROR;
	} else {
	    /*
	     * Set the interpreter's object result to an integer object
	     * holding the number of matches. 
	     */

	    Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches));
	}
    } else {
	/*
	 * No varname supplied, so just return the modified string.
	 */

	Tcl_SetObjResult(interp, resultPtr);
    }

    done:
    if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); }


    if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); }


    if (resultPtr) { Tcl_DecrRefCount(resultPtr); }


    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RenameObjCmd --
 *
 *	This procedure is invoked to process the "rename" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Arbitrary value passed to the command. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *oldName, *newName;
    
    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
	return TCL_ERROR;
    }

    oldName = TclGetString(objv[1]);
    newName = TclGetString(objv[2]);







>




>








>





>



>


|
|










|
|
<

>















>
|


|
|

>













|








>



|
|
>
>
|
>
>
|
>
>








|
|



















|







715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762

763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
		    continue;
		} else {
		    continue;
		}
	    } else {
		continue;
	    }

	    if (wfirstChar != wsrc) {
		Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
			wsrc - wfirstChar);
	    }

	    if (idx <= info.nsubs) {
		subStart = info.matches[idx].start;
		subEnd = info.matches[idx].end;
		if ((subStart >= 0) && (subEnd >= 0)) {
		    Tcl_AppendUnicodeToObj(resultPtr,
			    wstring + offset + subStart, subEnd - subStart);
		}
	    }

	    if (*wsrc == '\\') {
		wsrc++;
	    }
	    wfirstChar = wsrc + 1;
	}

	if (wfirstChar != wsrc) {
	    Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
	}

	if (end == 0) {
	    /*
	     * Always consume at least one character of the input string in
	     * order to prevent infinite loops.
	     */

	    if (offset < wlen) {
		Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
	    }
	    offset++;
	} else {
	    offset += end;
	    if (start == end) {
		/*
		 * We matched an empty string, which means we must go forward
		 * one more step so we don't match again at the same spot.

		 */

		if (offset < wlen) {
		    Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
		}
		offset++;
	    }
	}
	if (!all) {
	    break;
	}
    }

    /*
     * Copy the portion of the source string after the last match to the
     * result variable.
     */

  regsubDone:
    if (numMatches == 0) {
	/*
	 * On zero matches, just ignore the offset, since it shouldn't matter
	 * to us in this case, and the user may have skewed it.
	 */

	resultPtr = objv[1];
	Tcl_IncrRefCount(resultPtr);
    } else if (offset < wlen) {
	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
    }
    if (objc == 4) {
	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
	    Tcl_AppendResult(interp, "couldn't set variable \"",
		    TclGetString(objv[3]), "\"", (char *) NULL);
	    result = TCL_ERROR;
	} else {
	    /*
	     * Set the interpreter's object result to an integer object
	     * holding the number of matches.
	     */

	    Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches));
	}
    } else {
	/*
	 * No varname supplied, so just return the modified string.
	 */

	Tcl_SetObjResult(interp, resultPtr);
    }

  done:
    if (objPtr && (objv[1] == objv[0])) {
	Tcl_DecrRefCount(objPtr);
    }
    if (subPtr && (objv[2] == objv[0])) {
	Tcl_DecrRefCount(subPtr);
    }
    if (resultPtr) {
	Tcl_DecrRefCount(resultPtr);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RenameObjCmd --
 *
 *	This procedure is invoked to process the "rename" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Arbitrary value passed to the command. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *oldName, *newName;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
	return TCL_ERROR;
    }

    oldName = TclGetString(objv[1]);
    newName = TclGetString(objv[2]);
846
847
848
849
850
851
852

853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
    int code, level;
    Tcl_Obj *returnOpts;

    /*
     * General syntax: [return ?-option value ...? ?result?]
     * An even number of words means an explicit result argument is present.
     */

    int explicitResult = (0 == (objc % 2));
    int numOptionWords = objc - 1 - explicitResult;

    if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1,
	    &returnOpts, &code, &level)) {
	return TCL_ERROR;
    }

    code = TclProcessReturn(interp, code, level, returnOpts);
    if (explicitResult) {
	Tcl_SetObjResult(interp, objv[objc-1]);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SourceObjCmd --
 *
 *	This procedure is invoked to process the "source" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *







>




















|
|







889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
    int code, level;
    Tcl_Obj *returnOpts;

    /*
     * General syntax: [return ?-option value ...? ?result?]
     * An even number of words means an explicit result argument is present.
     */

    int explicitResult = (0 == (objc % 2));
    int numOptionWords = objc - 1 - explicitResult;

    if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1,
	    &returnOpts, &code, &level)) {
	return TCL_ERROR;
    }

    code = TclProcessReturn(interp, code, level, returnOpts);
    if (explicitResult) {
	Tcl_SetObjResult(interp, objv[objc-1]);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SourceObjCmd --
 *
 *	This procedure is invoked to process the "source" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
893
894
895
896
897
898
899

900

901
902
903
904
905

906
907
908
909
910
911

912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
    CONST char *encodingName = NULL;
    Tcl_Obj *fileName;

    if (objc != 2 && objc !=4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
	return TCL_ERROR;
    }

    fileName = objv[objc-1];

    if (objc == 4) {
	static CONST char *options[] = {
	    "-encoding", (char *) NULL
	};
	int index;

	if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1],
		options, "option", TCL_EXACT, &index)) {
	    return TCL_ERROR;
	}
	encodingName = TclGetString(objv[2]);
    }

    return Tcl_FSEvalFileEx(interp, fileName, encodingName);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitObjCmd --
 *
 *	This procedure is invoked to process the "split" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







>

>





>






>








|
|







937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
    CONST char *encodingName = NULL;
    Tcl_Obj *fileName;

    if (objc != 2 && objc !=4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
	return TCL_ERROR;
    }

    fileName = objv[objc-1];

    if (objc == 4) {
	static CONST char *options[] = {
	    "-encoding", (char *) NULL
	};
	int index;

	if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1],
		options, "option", TCL_EXACT, &index)) {
	    return TCL_ERROR;
	}
	encodingName = TclGetString(objv[2]);
    }

    return Tcl_FSEvalFileEx(interp, fileName, encodingName);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitObjCmd --
 *
 *	This procedure is invoked to process the "split" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978

979
980


981


982
983
984


985


986
987
988
989
990
991
992

993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032

1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
	Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
	return TCL_ERROR;
    }

    stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen);
    end = stringPtr + stringLen;
    listPtr = Tcl_NewObj();
    
    if (stringLen == 0) {
	/*
	 * Do nothing.
	 */
    } else if (splitCharLen == 0) {
	Tcl_HashTable charReuseTable;
	Tcl_HashEntry *hPtr;
	int isNew;

	/*
	 * Handle the special case of splitting on every character.
	 *
	 * Uses a hash table to ensure that each kind of character has
	 * only one Tcl_Obj instance (multiply-referenced) in the
	 * final list.  This is a *major* win when splitting on a long
	 * string (especially in the megabyte range!) - DKF
	 */

	Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);

	for ( ; stringPtr < end; stringPtr += len) {
	    len = TclUtfToUniChar(stringPtr, &ch);


	    /* Assume Tcl_UniChar is an integral type... */


	    hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
	    if (isNew) {
		objPtr = Tcl_NewStringObj(stringPtr, len);


		/* Don't need to fiddle with refcount... */


		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
	    } else {
		objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
	    }
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	}
	Tcl_DeleteHashTable(&charReuseTable);

    } else if (splitCharLen == 1) {
	char *p;

	/*
	 * Handle the special case of splitting on a single character.
	 * This is only true for the one-char ASCII case, as one unicode
	 * char is > 1 byte in length.
	 */

	while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
	    objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;
	}
	objPtr = Tcl_NewStringObj(stringPtr, end - stringPtr);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    } else {
	char *element, *p, *splitEnd;
	int splitLen;
	Tcl_UniChar splitChar;
	
	/*
	 * Normal case: split on any of a given set of characters.
	 * Discard instances of the split characters.
	 */

	splitEnd = splitChars + splitCharLen;

	for (element = stringPtr; stringPtr < end; stringPtr += len) {
	    len = TclUtfToUniChar(stringPtr, &ch);
	    for (p = splitChars; p < splitEnd; p += splitLen) {
		splitLen = TclUtfToUniChar(p, &splitChar);
		if (ch == splitChar) {
		    objPtr = Tcl_NewStringObj(element, stringPtr - element);
		    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
		    element = stringPtr + len;
		    break;
		}
	    }
	}

	objPtr = Tcl_NewStringObj(element, stringPtr - element);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    }
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringObjCmd --
 *
 *	This procedure is invoked to process the "string" Tcl command.
 *	See the user documentation for details on what it does.  Note
 *	that this command only functions correctly on properly formed
 *	Tcl UTF strings.
 *
 *	Note that the primary methods here (equal, compare, match, ...)
 *	have bytecode equivalents.  You will find the code for those in
 *	tclExecute.c.  The code here will only be used in the non-bc
 *	case (like in an 'eval').
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|












|
|
|
|



>


>
>
|
>
>



>
>
|
>
>







>




|
|
|













|

|
|
















>












|
|
|
<

|
|
|
|







1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106

1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
	Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
	return TCL_ERROR;
    }

    stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen);
    end = stringPtr + stringLen;
    listPtr = Tcl_NewObj();

    if (stringLen == 0) {
	/*
	 * Do nothing.
	 */
    } else if (splitCharLen == 0) {
	Tcl_HashTable charReuseTable;
	Tcl_HashEntry *hPtr;
	int isNew;

	/*
	 * Handle the special case of splitting on every character.
	 *
	 * Uses a hash table to ensure that each kind of character has only
	 * one Tcl_Obj instance (multiply-referenced) in the final list. This
	 * is a *major* win when splitting on a long string (especially in the
	 * megabyte range!) - DKF
	 */

	Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);

	for ( ; stringPtr < end; stringPtr += len) {
	    len = TclUtfToUniChar(stringPtr, &ch);

	    /*
	     * Assume Tcl_UniChar is an integral type...
	     */

	    hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
	    if (isNew) {
		objPtr = Tcl_NewStringObj(stringPtr, len);

		/*
		 * Don't need to fiddle with refcount...
		 */

		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
	    } else {
		objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
	    }
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	}
	Tcl_DeleteHashTable(&charReuseTable);

    } else if (splitCharLen == 1) {
	char *p;

	/*
	 * Handle the special case of splitting on a single character. This is
	 * only true for the one-char ASCII case, as one unicode char is > 1
	 * byte in length.
	 */

	while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
	    objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;
	}
	objPtr = Tcl_NewStringObj(stringPtr, end - stringPtr);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    } else {
	char *element, *p, *splitEnd;
	int splitLen;
	Tcl_UniChar splitChar;

	/*
	 * Normal case: split on any of a given set of characters. Discard
	 * instances of the split characters.
	 */

	splitEnd = splitChars + splitCharLen;

	for (element = stringPtr; stringPtr < end; stringPtr += len) {
	    len = TclUtfToUniChar(stringPtr, &ch);
	    for (p = splitChars; p < splitEnd; p += splitLen) {
		splitLen = TclUtfToUniChar(p, &splitChar);
		if (ch == splitChar) {
		    objPtr = Tcl_NewStringObj(element, stringPtr - element);
		    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
		    element = stringPtr + len;
		    break;
		}
	    }
	}

	objPtr = Tcl_NewStringObj(element, stringPtr - element);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    }
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringObjCmd --
 *
 *	This procedure is invoked to process the "string" Tcl command. See the
 *	user documentation for details on what it does. Note that this command
 *	only functions correctly on properly formed Tcl UTF strings.

 *
 *	Note that the primary methods here (equal, compare, match, ...) have
 *	bytecode equivalents. You will find the code for those in
 *	tclExecute.c. The code here will only be used in the non-bc case (like
 *	in an 'eval').
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110

1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148

1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167

1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178

1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190

1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214

1215
1216

1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257

1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271

1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291

1292
1293
1294
1295

1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331

1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415

1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428

1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442

1443
1444
1445
1446
1447
1448
1449
1450
1451
1452

1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476

1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497

1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564

1565
1566
1567
1568
1569

1570
1571
1572
1573
1574
1575
1576

1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621

1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633

1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668


1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702

1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722

1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791

1792
1793
1794
1795
1796
1797
1798
1799
1800
1801

1802
1803
1804
1805
1806

1807
1808
1809

1810
1811

1812
1813
1814
1815

1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830

1831
1832
1833
1834
1835
1836

1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847

1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989








































































































































1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040

2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091

2092

2093
2094
2095

2096
2097
2098
2099


2100
2101

2102
2103
2104

2105
2106
2107
2108
2109
2110

2111
2112
2113
2114
2115

2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197

2198
2199
2200
2201

2202
2203
2204
2205
2206
2207
2208

2209
2210
2211
2212
2213
2214

2215
2216
2217
2218
2219
2220
2221

2222
2223
2224
2225
2226
2227
2228
2229








2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469

2470
2471
2472
2473
2474
2475
2476
    enum options {
	STR_BYTELENGTH,	STR_COMPARE,	STR_EQUAL,	STR_FIRST,
	STR_INDEX,	STR_IS,		STR_LAST,	STR_LENGTH,
	STR_MAP,	STR_MATCH,	STR_RANGE,	STR_REPEAT,
	STR_REPLACE,	STR_TOLOWER,	STR_TOUPPER,	STR_TOTITLE,
	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
	STR_WORDEND,	STR_WORDSTART
    };	  

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
	return TCL_ERROR;
    }
    
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
	case STR_EQUAL:
	case STR_COMPARE: {
	    /*
	     * Remember to keep code here in some sync with the
	     * byte-compiled versions in tclExecute.c (INST_STR_EQ,
	     * INST_STR_NEQ and INST_STR_CMP as well as the expr string
	     * comparison in INST_EQ/INST_NEQ/INST_LT/...).
	     */

	    int i, match, length, nocase = 0, reqlength = -1;
	    typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *,
		    unsigned int));
	    strCmpFn_t strCmpFn;

	    if (objc < 4 || objc > 7) {
	    str_cmp_args:
	        Tcl_WrongNumArgs(interp, 2, objv,
			"?-nocase? ?-length int? string1 string2");
		return TCL_ERROR;
	    }

	    for (i = 2; i < objc-2; i++) {
		string2 = Tcl_GetStringFromObj(objv[i], &length2);
		if ((length2 > 1)
			&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
		    nocase = 1;
		} else if ((length2 > 1)
			&& strncmp(string2, "-length", (size_t)length2) == 0) {
		    if (i+1 >= objc-2) {
			goto str_cmp_args;
		    }
		    if (Tcl_GetIntFromObj(interp, objv[++i],
			    &reqlength) != TCL_OK) {
			return TCL_ERROR;
		    }
		} else {
		    Tcl_AppendResult(interp, "bad option \"",
			    string2, "\": must be -nocase or -length",
			    (char *) NULL);
		    return TCL_ERROR;
		}
	    }

	    /*
	     * From now on, we only access the two objects at the end
	     * of the argument array.
	     */

	    objv += objc-2;

	    if ((reqlength == 0) || (objv[0] == objv[1])) {
		/*
		 * Alway match at 0 chars of if it is the same obj.
		 */

		Tcl_SetObjResult(interp,
			Tcl_NewBooleanObj((enum options) index == STR_EQUAL));
		break;
	    } else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
		    objv[1]->typePtr == &tclByteArrayType) {
		/*
		 * Use binary versions of comparisons since that won't
		 * cause undue type conversions and it is much faster.
		 * Only do this if we're case-sensitive (which is all
		 * that really makes sense with byte arrays anyway, and
		 * we have no memcasecmp() for some reason... :^)
		 */

		string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
		string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
		strCmpFn = (strCmpFn_t) memcmp;
	    } else if ((objv[0]->typePtr == &tclStringType)
		    && (objv[1]->typePtr == &tclStringType)) {
		/*
		 * Do a unicode-specific comparison if both of the args
		 * are of String type.  In benchmark testing this proved
		 * the most efficient check between the unicode and
		 * string comparison operations.
		 */

		string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
		string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
		strCmpFn = (strCmpFn_t)
			(nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
	    } else {
		/*
		 * As a catch-all we will work with UTF-8.  We cannot use
		 * memcmp() as that is unsafe with any string containing
		 * NULL (\xC0\x80 in Tcl's utf rep).  We can use the more
		 * efficient TclpUtfNcmp2 if we are case-sensitive and no
		 * specific length was requested.
		 */

		string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
		string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
		if ((reqlength < 0) && !nocase) {
		    strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
		} else {
		    length1 = Tcl_NumUtfChars(string1, length1);
		    length2 = Tcl_NumUtfChars(string2, length2);
		    strCmpFn = (strCmpFn_t)
			    (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
		}
	    }

	    if (((enum options) index == STR_EQUAL)
		    && (reqlength < 0) && (length1 != length2)) {
		match = 1; /* this will be reversed below */
	    } else {
		length = (length1 < length2) ? length1 : length2;
		if (reqlength > 0 && reqlength < length) {
		    length = reqlength;
		} else if (reqlength < 0) {
		    /*
		     * The requested length is negative, so we ignore it by
		     * setting it to length + 1 so we correct the match var.
		     */

		    reqlength = length + 1;
		}

		match = strCmpFn(string1, string2, (unsigned) length);
		if ((match == 0) && (reqlength > length)) {
		    match = length1 - length2;
		}
	    }

	    if ((enum options) index == STR_EQUAL) {
		Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
	    } else {
		Tcl_SetObjResult(interp, Tcl_NewIntObj(
			(match > 0) ? 1 : (match < 0) ? -1 : 0));
	    }
	    break;
	}
	case STR_FIRST: {
	    Tcl_UniChar *ustring1, *ustring2;
	    int match, start;

	    if (objc < 4 || objc > 5) {
	        Tcl_WrongNumArgs(interp, 2, objv,
				 "subString string ?startIndex?");
		return TCL_ERROR;
	    }

	    /*
	     * We are searching string2 for the sequence string1.
	     */

	    match = -1;
	    start = 0;
	    length2 = -1;

	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
	    ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);

	    if (objc == 5) {
		/*
		 * If a startIndex is specified, we will need to fast
		 * forward to that point in the string before we think
		 * about a match
		 */

		if (TclGetIntForIndex(interp, objv[4], length2 - 1,
			&start) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (start >= length2) {
		    goto str_first_done;
		} else if (start > 0) {
		    ustring2 += start;
		    length2  -= start;
		} else if (start < 0) {
		    /*
		     * Invalid start index mapped to string start;
		     * Bug #423581
		     */

		    start = 0;
		}
	    }

	    if (length1 > 0) {
		register Tcl_UniChar *p, *end;

		end = ustring2 + length2 - length1 + 1;
		for (p = ustring2;  p < end;  p++) {
		    /*
		     * Scan forward to find the first character.
		     */
		    if ((*p == *ustring1) &&
			    (TclUniCharNcmp(ustring1, p,
				    (unsigned long) length1) == 0)) {
			match = p - ustring2;
			break;
		    }
		}
	    }

	    /*
	     * Compute the character index of the matching string by
	     * counting the number of characters before the match.
	     */

	    if ((match != -1) && (objc == 5)) {
		match += start;
	    }

	    str_first_done:
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
	    break;
	}
	case STR_INDEX: {
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
		return TCL_ERROR;
	    }

	    /*
	     * If we have a ByteArray object, avoid indexing in the
	     * Utf string since the byte array contains one byte per
	     * character.  Otherwise, use the Unicode string rep to
	     * get the index'th char.
	     */

	    if (objv[2]->typePtr == &tclByteArrayType) {
		string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);

		if (TclGetIntForIndex(interp, objv[3], length1 - 1,
			&index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if ((index >= 0) && (index < length1)) {
		    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
			    (unsigned char *)(&string1[index]), 1));
		}
	    } else {
		/*
		 * Get Unicode char length to calulate what 'end' means.
		 */

		length1 = Tcl_GetCharLength(objv[2]);

		if (TclGetIntForIndex(interp, objv[3], length1 - 1,
			&index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if ((index >= 0) && (index < length1)) {
		    char buf[TCL_UTF_MAX];
		    Tcl_UniChar ch;

		    ch      = Tcl_GetUniChar(objv[2], index);
		    length1 = Tcl_UniCharToUtf(ch, buf);
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1));
		}
	    }
	    break;
	}
	case STR_IS: {
	    char *end;
	    Tcl_UniChar ch;

            /*
	     * The UniChar comparison function
	     */

	    int (*chcomp)_ANSI_ARGS_((int)) = NULL; 
	    int i, failat = 0, result = 1, strict = 0;
	    Tcl_Obj *objPtr, *failVarObj = NULL;
	    Tcl_WideInt w;

	    static CONST char *isOptions[] = {
		"alnum",	"alpha",	"ascii",	"control",
		"boolean",	"digit",	"double",	"false",
		"graph",	"integer",	"lower",	"print",
		"punct",	"space",	"true",		"upper",
		"wideinteger",  "wordchar",	"xdigit",	(char *) NULL
	    };
	    enum isOptions {
		STR_IS_ALNUM,	STR_IS_ALPHA,	STR_IS_ASCII,	STR_IS_CONTROL,
		STR_IS_BOOL,	STR_IS_DIGIT,	STR_IS_DOUBLE,	STR_IS_FALSE,
		STR_IS_GRAPH,	STR_IS_INT,	STR_IS_LOWER,	STR_IS_PRINT,
		STR_IS_PUNCT,	STR_IS_SPACE,	STR_IS_TRUE,	STR_IS_UPPER,
		STR_IS_WIDE,    STR_IS_WORD,	STR_IS_XDIGIT
	    };

	    if (objc < 4 || objc > 7) {
		Tcl_WrongNumArgs(interp, 2, objv,
				 "class ?-strict? ?-failindex var? str");
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
				    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (objc != 4) {
		for (i = 3; i < objc-1; i++) {
		    string2 = Tcl_GetStringFromObj(objv[i], &length2);
		    if ((length2 > 1) &&
			strncmp(string2, "-strict", (size_t) length2) == 0) {
			strict = 1;
		    } else if ((length2 > 1) &&
			    strncmp(string2, "-failindex",
				    (size_t) length2) == 0) {
			if (i+1 >= objc-1) {
			    Tcl_WrongNumArgs(interp, 3, objv,
					     "?-strict? ?-failindex var? str");
			    return TCL_ERROR;
			}
			failVarObj = objv[++i];
		    } else {
			Tcl_AppendResult(interp, "bad option \"",
				string2, "\": must be -strict or -failindex",
				(char *) NULL);
			return TCL_ERROR;
		    }
		}
	    }

	    /*
	     * We get the objPtr so that we can short-cut for some classes
	     * by checking the object type (int and double), but we need
	     * the string otherwise, because we don't want any conversion
	     * of type occuring (as, for example, Tcl_Get*FromObj would do
	     */

	    objPtr = objv[objc-1];
	    string1 = Tcl_GetStringFromObj(objPtr, &length1);
	    if (length1 == 0) {
		if (strict) {
		    result = 0;
		}
		goto str_is_done;
	    }
	    end = string1 + length1;

	    /*
	     * When entering here, result == 1 and failat == 0
	     */

	    switch ((enum isOptions) index) {
		case STR_IS_ALNUM:
		    chcomp = Tcl_UniCharIsAlnum;
		    break;
		case STR_IS_ALPHA:
		    chcomp = Tcl_UniCharIsAlpha;
		    break;
		case STR_IS_ASCII:
		    for (; string1 < end; string1++, failat++) {
			/*
			 * This is a valid check in unicode, because all
			 * bytes < 0xC0 are single byte chars (but isascii
			 * limits that def'n to 0x80).
			 */

			if (*((unsigned char *)string1) >= 0x80) {
			    result = 0;
			    break;
			}
		    }
		    break;
		case STR_IS_BOOL:
		case STR_IS_TRUE:
		case STR_IS_FALSE:
		    if (objPtr->typePtr == &tclBooleanType) {

			if ((((enum isOptions) index == STR_IS_TRUE) &&
			     objPtr->internalRep.longValue == 0) ||
			    (((enum isOptions) index == STR_IS_FALSE) &&
			     objPtr->internalRep.longValue != 0)) {
			    result = 0;
			}
		    } else if ((Tcl_GetBoolean(NULL, string1, &i)
				== TCL_ERROR) ||
			       (((enum isOptions) index == STR_IS_TRUE) &&
				i == 0) ||
			       (((enum isOptions) index == STR_IS_FALSE) &&
				i != 0)) {
			result = 0;
		    }
		    break;
		case STR_IS_CONTROL:
		    chcomp = Tcl_UniCharIsControl;
		    break;
		case STR_IS_DIGIT:
		    chcomp = Tcl_UniCharIsDigit;
		    break;
		case STR_IS_DOUBLE: {
		    char *stop;


		    if ((objPtr->typePtr == &tclDoubleType) ||
			(objPtr->typePtr == &tclIntType)) {
			break;
		    }
		    /*
		     * This is adapted from Tcl_GetDouble
		     *
		     * The danger in this function is that
		     * "12345678901234567890" is an acceptable 'double',
		     * but will later be interp'd as an int by something
		     * like [expr].  Therefore, we check to see if it looks
		     * like an int, and if so we do a range check on it.
		     * If strtoul gets to the end, we know we either
		     * received an acceptable int, or over/underflow
		     */
		    if (TclLooksLikeInt(string1, length1)) {
			errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
			strtoul(string1, &stop, 0); /* INTL: Tcl source. */
#else
			strtoull(string1, &stop, 0); /* INTL: Tcl source. */

#endif
			if (stop == end) {
			    if (errno == ERANGE) {
				result = 0;
				failat = -1;
			    }
			    break;
			}
		    }
		    errno = 0;
		    strtod(string1, &stop); /* INTL: Tcl source. */
		    if (errno == ERANGE) {
			/*
			 * if (errno == ERANGE), then it was an over/underflow
			 * problem, but in this method, we only want to know
			 * yes or no, so bad flow returns 0 (false) and sets
			 * the failVarObj to the string length.
			 */
			result = 0;
			failat = -1;
		    } else if (stop == string1) {
			/*
			 * In this case, nothing like a number was found
			 */
			result = 0;
			failat = 0;
		    } else {
			/*
			 * Assume we sucked up one char per byte
			 * and then we go onto SPACE, since we are
			 * allowed trailing whitespace
			 */
			failat = stop - string1;
			string1 = stop;
			chcomp = Tcl_UniCharIsSpace;
		    }
		    break;
		}
		case STR_IS_GRAPH:
		    chcomp = Tcl_UniCharIsGraph;
		    break;
		case STR_IS_INT: {
		    char *stop;
		    long int l = 0;

		    if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
			break;
		    }

		    /*
		     * Like STR_IS_DOUBLE, but we use strtoul.
		     * Since Tcl_GetIntFromObj already failed,
		     * we set result to 0.
		     */

		    result = 0;
		    errno = 0;
		    l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
		    if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
			/*
			 * if (errno == ERANGE) or the long value
			 * won't fit in an int, then it was an
			 * over/underflow problem, but in this method,
			 * we only want to know yes or no, so bad flow
			 * returns 0 (false) and sets the failVarObj
			 * to the string length.
			 */

			failat = -1;
		    } else if (stop == string1) {
			/*
			 * In this case, nothing like a number was found
			 */

			failat = 0;
		    } else {
			/*
			 * Assume we sucked up one char per byte
			 * and then we go onto SPACE, since we are
			 * allowed trailing whitespace
			 */

			failat = stop - string1;
			string1 = stop;
			chcomp = Tcl_UniCharIsSpace;
		    }
		    break;
		}
		case STR_IS_LOWER:
		    chcomp = Tcl_UniCharIsLower;
		    break;
		case STR_IS_PRINT:
		    chcomp = Tcl_UniCharIsPrint;
		    break;
		case STR_IS_PUNCT:
		    chcomp = Tcl_UniCharIsPunct;
		    break;
		case STR_IS_SPACE:
		    chcomp = Tcl_UniCharIsSpace;
		    break;
		case STR_IS_UPPER:
		    chcomp = Tcl_UniCharIsUpper;
		    break;
		case STR_IS_WIDE: {
		    char *stop;

		    if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
			break;
		    }

		    /*
		     * Like STR_IS_DOUBLE, but we use strtoll.  Since
		     * Tcl_GetWideIntFromObj already failed, we set
		     * result to 0.
		     */

		    result = 0;
		    errno = 0;
		    w = strtoll(string1, &stop, 0);	/* INTL: Tcl source. */
		    if (errno == ERANGE) {
			/*
			 * if (errno == ERANGE), then it was an
			 * over/underflow problem, but in this method,
			 * we only want to know yes or no, so bad flow
			 * returns 0 (false) and sets the failVarObj
			 * to the string length.
			 */

			failat = -1;
		    } else if (stop == string1) {
			/*
			 * In this case, nothing like a number was found
			 */
			failat = 0;
		    } else {
			/*
			 * Assume we sucked up one char per byte and
			 * then we go onto SPACE, since we are allowed
			 * trailing whitespace
			 */

			failat = stop - string1;
			string1 = stop;
			chcomp = Tcl_UniCharIsSpace;
		    }
		    break;
		}
		case STR_IS_WORD:
		    chcomp = Tcl_UniCharIsWordChar;
		    break;
		case STR_IS_XDIGIT: {
		    for (; string1 < end; string1++, failat++) {
			/* INTL: We assume unicode is bad for this class */
			if ((*((unsigned char *)string1) >= 0xC0) ||
			    !isxdigit(*(unsigned char *)string1)) {
			    result = 0;
			    break;
			}
		    }
		    break;
		}
	    }
	    if (chcomp != NULL) {
		for (; string1 < end; string1 += length2, failat++) {
		    length2 = TclUtfToUniChar(string1, &ch);
		    if (!chcomp(ch)) {
			result = 0;
			break;
		    }
		}
	    }
	str_is_done:
	    /*
	     * Only set the failVarObj when we will return 0
	     * and we have indicated a valid fail index (>= 0)
	     */


	    if ((result == 0) && (failVarObj != NULL) &&
		Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
			       TCL_LEAVE_ERR_MSG) == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
	    break;
	}
	case STR_LAST: {
	    Tcl_UniChar *ustring1, *ustring2, *p;
	    int match, start;

	    if (objc < 4 || objc > 5) {
	        Tcl_WrongNumArgs(interp, 2, objv,
				 "subString string ?startIndex?");
		return TCL_ERROR;
	    }

	    /*
	     * We are searching string2 for the sequence string1.
	     */

	    match = -1;
	    start = 0;
	    length2 = -1;

	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
	    ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);

	    if (objc == 5) {
		/*
		 * If a startIndex is specified, we will need to restrict
		 * the string range to that char index in the string
		 */

		if (TclGetIntForIndex(interp, objv[4], length2 - 1,
			&start) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (start < 0) {
		    goto str_last_done;
		} else if (start < length2) {
		    p = ustring2 + start + 1 - length1;
		} else {
		    p = ustring2 + length2 - length1;
		}
	    } else {
		p = ustring2 + length2 - length1;
	    }

	    if (length1 > 0) {
		for (; p >= ustring2;  p--) {
		    /*
		     * Scan backwards to find the first character.
		     */

		    if ((*p == *ustring1) &&
			    (memcmp((char *) ustring1, (char *) p, (size_t)
				    (length1 * sizeof(Tcl_UniChar))) == 0)) {
			match = p - ustring2;
			break;
		    }
		}
	    }

	    str_last_done:
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
	    break;
	}
	case STR_BYTELENGTH:
	case STR_LENGTH: {
	    if (objc != 3) {
	        Tcl_WrongNumArgs(interp, 2, objv, "string");
		return TCL_ERROR;
	    }

	    if ((enum options) index == STR_BYTELENGTH) {
		(void) Tcl_GetStringFromObj(objv[2], &length1);
	    } else {
		/*
		 * If we have a ByteArray object, avoid recomputing the
		 * string since the byte array contains one byte per
		 * character.  Otherwise, use the Unicode string rep to
		 * calculate the length.
		 */

		if (objv[2]->typePtr == &tclByteArrayType) {
		    (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
		} else {
		    length1 = Tcl_GetCharLength(objv[2]);
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(length1));
	    break;
	}
	case STR_MAP: {
	    int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0;
	    Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
	    Tcl_UniChar *ustring1, *ustring2, *p, *end;
	    int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
		    CONST Tcl_UniChar*, unsigned long));

	    if (objc < 4 || objc > 5) {
	        Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
		return TCL_ERROR;
	    }

	    if (objc == 5) {
		string2 = Tcl_GetStringFromObj(objv[2], &length2);
		if ((length2 > 1) &&
		    strncmp(string2, "-nocase", (size_t) length2) == 0) {
		    nocase = 1;
		} else {
		    Tcl_AppendResult(interp, "bad option \"",
			    string2, "\": must be -nocase", (char *) NULL);
		    return TCL_ERROR;
		}
	    }


	    /*
	     * This test is tricky, but has to be that way or you get
	     * other strange inconsistencies (see test string-10.20
	     * for illustration why!)
	     */

	    if (objv[objc-2]->typePtr == &tclDictType &&
		    objv[objc-2]->bytes == NULL) {
		int i, done;
		Tcl_DictSearch search;

		/*
		 * We know the type exactly, so all dict operations
		 * will succeed for sure.  This shortens this code
		 * quite a bit.
		 */

		Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
		if (mapElemc == 0) {
		    /*
		     * empty charMap, just return whatever string was given
		     */

		    Tcl_SetObjResult(interp, objv[objc-1]);
		    return TCL_OK;
		}

		mapElemc *= 2;
		mapWithDict = 1;

		/*
		 * Copy the dictionary out into an array; that's the
		 * easiest way to adapt this code...
		 */

		mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc);
		Tcl_DictObjFirst(interp, objv[objc-2], &search,
			mapElemv+0, mapElemv+1, &done);
		for (i=2 ; i<mapElemc ; i+=2) {
		    Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
		}
	    } else {
		if (Tcl_ListObjGetElements(interp, objv[objc-2],
			&mapElemc, &mapElemv) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (mapElemc == 0) {
		    /*
		     * empty charMap, just return whatever string was given
		     */

		    Tcl_SetObjResult(interp, objv[objc-1]);
		    return TCL_OK;
		} else if (mapElemc & 1) {
		    /*
		     * The charMap must be an even number of key/value items
		     */

		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "char map list unbalanced", -1));
		    return TCL_ERROR;
		}
	    }

	    /*
	     * Take a copy of the source string object if it is the
	     * same as the map string to cut out nasty sharing
	     * crashes. [Bug 1018562]
	     */

	    if (objv[objc-2] == objv[objc-1]) {
		sourceObj = Tcl_DuplicateObj(objv[objc-1]);
		copySource = 1;
	    } else {
		sourceObj = objv[objc-1];
	    }
	    ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
	    if (length1 == 0) {
		/*
		 * Empty input string, just stop now
		 */
		if (mapWithDict) {
		    ckfree((char *) mapElemv);
		}
		if (copySource) {
		    Tcl_DecrRefCount(sourceObj);
		}
		break;
	    }
	    end = ustring1 + length1;

	    strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;

	    /*
	     * Force result to be Unicode
	     */
	    resultPtr = Tcl_NewUnicodeObj(ustring1, 0);

	    if (mapElemc == 2) {
		/*
		 * Special case for one map pair which avoids the extra
		 * for loop and extra calls to get Unicode data.  The
		 * algorithm is otherwise identical to the multi-pair case.
		 * This will be >30% faster on larger strings.
		 */
		int mapLen;
		Tcl_UniChar *mapString, u2lc;

		ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
		p = ustring1;
		if (length2 == 0) {
		    ustring1 = end;
		} else {
		    mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
		    u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
		    for (; ustring1 < end; ustring1++) {
			if (((*ustring1 == *ustring2) ||
				(nocase && (Tcl_UniCharToLower(*ustring1) ==
					u2lc))) &&
				((length2 == 1) || strCmpFn(ustring1, ustring2,
					(unsigned long) length2) == 0)) {
			    if (p != ustring1) {
				Tcl_AppendUnicodeToObj(resultPtr, p,
					ustring1 - p);
				p = ustring1 + length2;
			    } else {
				p += length2;
			    }
			    ustring1 = p - 1;

			    Tcl_AppendUnicodeToObj(resultPtr, mapString,
				    mapLen);
			}
		    }
		}
	    } else {
		Tcl_UniChar **mapStrings, *u2lc = NULL;
		int *mapLens;
		/*
		 * Precompute pointers to the unicode string and length.
		 * This saves us repeated function calls later,
		 * significantly speeding up the algorithm.  We only need
		 * the lowercase first char in the nocase case.
		 */
		mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
			* sizeof(Tcl_UniChar *));
		mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
		if (nocase) {
		    u2lc = (Tcl_UniChar *)
			    ckalloc((mapElemc) * sizeof(Tcl_UniChar));
		}
		for (index = 0; index < mapElemc; index++) {
		    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
			    &(mapLens[index]));
		    if (nocase && ((index % 2) == 0)) {
			u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
		    }
		}
		for (p = ustring1; ustring1 < end; ustring1++) {
		    for (index = 0; index < mapElemc; index += 2) {
			/*
			 * Get the key string to match on.
			 */
			ustring2 = mapStrings[index];
			length2  = mapLens[index];
			if ((length2 > 0) && ((*ustring1 == *ustring2) ||
				(nocase && (Tcl_UniCharToLower(*ustring1) ==
					u2lc[index/2]))) &&
				((length2 == 1) || strCmpFn(ustring2, ustring1,
					(unsigned long) length2) == 0)) {
			    if (p != ustring1) {
				/*
				 * Put the skipped chars onto the result first
				 */
				Tcl_AppendUnicodeToObj(resultPtr, p,
					ustring1 - p);
				p = ustring1 + length2;
			    } else {
				p += length2;
			    }
			    /*
			     * Adjust len to be full length of matched string
			     */
			    ustring1 = p - 1;

			    /*
			     * Append the map value to the unicode string
			     */
			    Tcl_AppendUnicodeToObj(resultPtr,
				    mapStrings[index+1], mapLens[index+1]);
			    break;
			}
		    }
		}
		ckfree((char *) mapStrings);
		ckfree((char *) mapLens);
		if (nocase) {
		    ckfree((char *) u2lc);
		}
	    }
	    if (p != ustring1) {
		/*
		 * Put the rest of the unmapped chars onto result
		 */
		Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
	    }
	    if (mapWithDict) {
		ckfree((char *) mapElemv);
	    }
	    if (copySource) {
		Tcl_DecrRefCount(sourceObj);
	    }








































































































































	    Tcl_SetObjResult(interp, resultPtr);
	    break;
	}
	case STR_MATCH: {
	    Tcl_UniChar *ustring1, *ustring2;
	    int nocase = 0;

	    if (objc < 4 || objc > 5) {
	        Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
		return TCL_ERROR;
	    }

	    if (objc == 5) {
		string2 = Tcl_GetStringFromObj(objv[2], &length2);
		if ((length2 > 1) &&
		    strncmp(string2, "-nocase", (size_t) length2) == 0) {
		    nocase = 1;
		} else {
		    Tcl_AppendResult(interp, "bad option \"",
			    string2, "\": must be -nocase", (char *) NULL);
		    return TCL_ERROR;
		}
	    }
	    ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
	    ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch(
		    ustring1, length1, ustring2, length2, nocase)));
	    break;
	}
	case STR_RANGE: {
	    int first, last;

	    if (objc != 5) {
	        Tcl_WrongNumArgs(interp, 2, objv, "string first last");
		return TCL_ERROR;
	    }

	    /*
	     * If we have a ByteArray object, avoid indexing in the
	     * Utf string since the byte array contains one byte per
	     * character.  Otherwise, use the Unicode string rep to
	     * get the range.
	     */

	    if (objv[2]->typePtr == &tclByteArrayType) {
		string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
		length1--;
	    } else {
		/*
		 * Get the length in actual characters.
		 */

		string1 = NULL;
		length1 = Tcl_GetCharLength(objv[2]) - 1;
	    }

	    if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
		    || (TclGetIntForIndex(interp, objv[4], length1,
			    &last) != TCL_OK)) {
		return TCL_ERROR;
	    }

	    if (first < 0) {
		first = 0;
	    }
	    if (last >= length1) {
		last = length1;
	    }
	    if (last >= first) {
		if (string1 != NULL) {
		    int numBytes = last - first + 1;
		    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
			(unsigned char *) &string1[first], numBytes));
		} else {
		    Tcl_SetObjResult(interp,
			    Tcl_GetRange(objv[2], first, last));
		}
	    }
	    break;
	}
	case STR_REPEAT: {
	    int count;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "string count");
		return TCL_ERROR;
	    }

	    if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
		return TCL_ERROR;
	    }

	    if (count == 1) {
		Tcl_SetObjResult(interp, objv[2]);
	    } else if (count > 1) {
		string1 = Tcl_GetStringFromObj(objv[2], &length1);
		if (length1 > 0) {
		    /*
		     * Only build up a string that has data.  Instead of
		     * building it up with repeated appends, we just allocate
		     * the necessary space once and copy the string value in.
		     * Check for overflow with back-division. [Bug #714106]
		     */

		    Tcl_Obj *resultPtr;

		    length2		= length1 * count;
		    if ((length2 / count) != length1) {
			char buf[TCL_INTEGER_SPACE+1];

			sprintf(buf, "%d", INT_MAX);
			Tcl_AppendResult(interp,
				"string size overflow, must be less than ",
				buf, (char *) NULL);


			return TCL_ERROR;
		    }

		    /*
		     * Include space for the NULL
		     */

		    string2		= (char *) ckalloc((size_t) length2+1);
		    for (index = 0; index < count; index++) {
			memcpy(string2 + (length1 * index), string1,
				(size_t) length1);
		    }
		    string2[length2]	= '\0';

		    /*
		     * We have to directly assign this instead of using
		     * Tcl_SetStringObj (and indirectly TclInitStringRep)
		     * because that makes another copy of the data.
		     */

		    resultPtr		= Tcl_NewObj();
		    resultPtr->bytes	= string2;
		    resultPtr->length	= length2;
		    Tcl_SetObjResult(interp, resultPtr);
		}
	    }
	    break;
	}
	case STR_REPLACE: {
	    Tcl_UniChar *ustring1;
	    int first, last;

	    if (objc < 5 || objc > 6) {
	        Tcl_WrongNumArgs(interp, 2, objv,
				 "string first last ?string?");
		return TCL_ERROR;
	    }

	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
	    length1--;

	    if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
		    || (TclGetIntForIndex(interp, objv[4], length1,
			    &last) != TCL_OK)) {
		return TCL_ERROR;
	    }

	    if ((last < first) || (last < 0) || (first > length1)) {
		Tcl_SetObjResult(interp, objv[2]);
	    } else {
		Tcl_Obj *resultPtr;
		if (first < 0) {
		    first = 0;
		}

		resultPtr = Tcl_NewUnicodeObj(ustring1, first);
		if (objc == 6) {
		    Tcl_AppendObjToObj(resultPtr, objv[5]);
		}
		if (last < length1) {
		    Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
			    length1 - last);
		}
		Tcl_SetObjResult(interp, resultPtr);
	    }
	    break;
	}
	case STR_TOLOWER:
	case STR_TOUPPER:
	case STR_TOTITLE:
	    if (objc < 3 || objc > 5) {
	        Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
		return TCL_ERROR;
	    }

	    string1 = Tcl_GetStringFromObj(objv[2], &length1);

	    if (objc == 3) {
		Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
		if ((enum options) index == STR_TOLOWER) {
		    length1 = Tcl_UtfToLower(TclGetString(resultPtr));
		} else if ((enum options) index == STR_TOUPPER) {
		    length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
		} else {
		    length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
		}
		Tcl_SetObjLength(resultPtr, length1);
		Tcl_SetObjResult(interp, resultPtr);
	    } else {
		int first, last;
		CONST char *start, *end;
		Tcl_Obj *resultPtr;

		length1 = Tcl_NumUtfChars(string1, length1) - 1;
		if (TclGetIntForIndex(interp, objv[3], length1,
				      &first) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (first < 0) {
		    first = 0;
		}
		last = first;

		if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
						      &last) != TCL_OK)) {
		    return TCL_ERROR;
		}

		if (last >= length1) {
		    last = length1;
		}
		if (last < first) {
		    Tcl_SetObjResult(interp, objv[2]);
		    break;
		}

		start = Tcl_UtfAtIndex(string1, first);
		end = Tcl_UtfAtIndex(start, last - first + 1);
		length2 = end-start;
		string2 = ckalloc((size_t) length2+1);
		memcpy(string2, start, (size_t) length2);
		string2[length2] = '\0';

		if ((enum options) index == STR_TOLOWER) {
		    length2 = Tcl_UtfToLower(string2);
		} else if ((enum options) index == STR_TOUPPER) {
		    length2 = Tcl_UtfToUpper(string2);
		} else {
		    length2 = Tcl_UtfToTitle(string2);
		}

		resultPtr = Tcl_NewStringObj(string1, start - string1);
		Tcl_AppendToObj(resultPtr, string2, length2);
		Tcl_AppendToObj(resultPtr, end, -1);
		Tcl_SetObjResult(interp, resultPtr);
		ckfree(string2);
	    }
	    break;









	case STR_TRIM: {
	    Tcl_UniChar ch, trim;
	    register CONST char *p, *end;
	    char *check, *checkEnd;
	    int offset;

	    left = 1;
	    right = 1;

	    dotrim:
	    if (objc == 4) {
		string2 = Tcl_GetStringFromObj(objv[3], &length2);
	    } else if (objc == 3) {
		string2 = " \t\n\r";
		length2 = strlen(string2);
	    } else {
	        Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
		return TCL_ERROR;
	    }
	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
	    checkEnd = string2 + length2;

	    if (left) {
		end = string1 + length1;
		/*
		 * The outer loop iterates over the string.  The inner
		 * loop iterates over the trim characters.  The loops
		 * terminate as soon as a non-trim character is discovered
		 * and string1 is left pointing at the first non-trim
		 * character.
		 */

		for (p = string1; p < end; p += offset) {
		    offset = TclUtfToUniChar(p, &ch);
		    
		    for (check = string2; ; ) {
			if (check >= checkEnd) {
			    p = end;
			    break;
			}
			check += TclUtfToUniChar(check, &trim);
			if (ch == trim) {
			    length1 -= offset;
			    string1 += offset;
			    break;
			}
		    }
		}
	    }
	    if (right) {
	        end = string1;

		/*
		 * The outer loop iterates over the string.  The inner
		 * loop iterates over the trim characters.  The loops
		 * terminate as soon as a non-trim character is discovered
		 * and length1 marks the last non-trim character.
		 */

		for (p = string1 + length1; p > end; ) {
		    p = Tcl_UtfPrev(p, string1);
		    offset = TclUtfToUniChar(p, &ch);
		    for (check = string2; ; ) {
		        if (check >= checkEnd) {
			    p = end;
			    break;
			}
			check += TclUtfToUniChar(check, &trim);
			if (ch == trim) {
			    length1 -= offset;
			    break;
			}
		    }
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1));
	    break;
	}
	case STR_TRIMLEFT: {
	    left = 1;
	    right = 0;
	    goto dotrim;
	}
	case STR_TRIMRIGHT: {
	    left = 0;
	    right = 1;
	    goto dotrim;
	}
	case STR_WORDEND: {
	    int cur;
	    Tcl_UniChar ch;
	    CONST char *p, *end;
	    int numChars;
	    
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "string index");
		return TCL_ERROR;
	    }

	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
	    numChars = Tcl_NumUtfChars(string1, length1);
	    if (TclGetIntForIndex(interp, objv[3], numChars-1,
				  &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (index < 0) {
		index = 0;
	    }
	    if (index < numChars) {
		p = Tcl_UtfAtIndex(string1, index);
		end = string1+length1;
		for (cur = index; p < end; cur++) {
		    p += TclUtfToUniChar(p, &ch);
		    if (!Tcl_UniCharIsWordChar(ch)) {
			break;
		    }
		}
		if (cur == index) {
		    cur++;
		}
	    } else {
		cur = numChars;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
	    break;
	}
	case STR_WORDSTART: {
	    int cur;
	    Tcl_UniChar ch;
	    CONST char *p;
	    int numChars;
	    
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "string index");
		return TCL_ERROR;
	    }

	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
	    numChars = Tcl_NumUtfChars(string1, length1);
	    if (TclGetIntForIndex(interp, objv[3], numChars-1,
				  &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (index >= numChars) {
		index = numChars - 1;
	    }
	    cur = 0;
	    if (index > 0) {
		p = Tcl_UtfAtIndex(string1, index);
	        for (cur = index; cur >= 0; cur--) {
		    TclUtfToUniChar(p, &ch);
		    if (!Tcl_UniCharIsWordChar(ch)) {
			break;
		    }
		    p = Tcl_UtfPrev(p, string1);
		}
		if (cur != index) {
		    cur += 1;
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
	    break;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SubstObjCmd --
 *
 *	This procedure is invoked to process the "subst" Tcl command.
 *	See the user documentation for details on what it does.  This
 *	command relies on Tcl_SubstObj() for its implementation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];       	/* Argument objects. */
{
    static CONST char *substOptions[] = {
	"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
    };
    enum substOptions {
	SUBST_NOBACKSLASHES,      SUBST_NOCOMMANDS,       SUBST_NOVARS
    };
    Tcl_Obj *resultPtr;
    int optionIndex, flags, i;

    /*
     * Parse command-line options.
     */

    flags = TCL_SUBST_ALL;
    for (i = 1; i < (objc-1); i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
		"switch", 0, &optionIndex) != TCL_OK) {

	    return TCL_ERROR;
	}
	switch (optionIndex) {
	    case SUBST_NOBACKSLASHES: {
		flags &= ~TCL_SUBST_BACKSLASHES;
		break;
	    }
	    case SUBST_NOCOMMANDS: {
		flags &= ~TCL_SUBST_COMMANDS;
		break;
	    }
	    case SUBST_NOVARS: {
		flags &= ~TCL_SUBST_VARIABLES;
		break;
	    }
	    default: {
		Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
	    }
	}
    }
    if (i != (objc-1)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nobackslashes? ?-nocommands? ?-novariables? string");
	return TCL_ERROR;
    }

    /*
     * Perform the substitution.
     */

    resultPtr = Tcl_SubstObj(interp, objv[i], flags);

    if (resultPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;







|


|


|






|
|
|
|
|
|
|
|
>
|
|
<
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|

|
|
|
|
>
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
<
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
>
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
<
|
|

|
|
|

|
|
|

|
|

|
|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|

|
|

|
|
|
|
|
|
<
|
|
|
|
|
|
>
|
|
|
|
>
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
<
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
>
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
<
|
|
|
|
|
|
|
|
|
<
|
|
|
|

|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|

|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|

>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
>

|
<
<
<
<
|
|
<
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
|
|
|
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
<
|
|

|
|
|
|
|
|
<
|
|
|
<
|
>
|
|
|
|
|
>
|
|
|
|
<
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
<
|

|
|
|
|
|
|
|
<
|
|
|
>
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|

|
|
|

|
|
|

|
|

|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
>
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
<
|

|
|
|
|
|
|
|
|
<
|
|
|
|
<
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

<
|
|
|
|
|
>
|
|
|
|

|
|
|
<
|
>
|
|
|
|
|
>
|
|
|
>
|
|
>
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|

|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
<
|

|
|
|
|
|
|
|
>
|
|
|

|
|
<
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
>
|
>
|
|
<
>
|
<
|
<
>
>
|
|
>
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|

|
|
<
|
|

|
|

|
|
<
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
<
|
|
|
|
|
|
>
|
|
|
|
>
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|

>
>
>
>
>
>
>
>
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
<
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|

|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|









|
|
|













|
|
|
|





|










|
|
<



|
|
|
<
|
|
|
<
|
|
|
<
|
|
<











>







1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171

1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197

1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246

1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298

1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316

1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330

1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345

1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375

1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455

1456
1457
1458
1459
1460
1461
1462
1463
1464

1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520








1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535















1536



1537
1538
1539




1540
1541



1542








1543



1544
1545
1546





1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565

1566
1567
1568
1569
1570
1571
1572
1573
1574

1575
1576
1577

1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589

1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623

1624
1625
1626
1627
1628
1629
1630
1631
1632

1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646

1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668

1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767

1768
1769
1770
1771
1772
1773
1774
1775
1776
1777

1778
1779
1780
1781

1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800

1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814

1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866

1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879


1880


























































































































1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063

2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079

2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128

2129
2130

2131

2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167

2168
2169
2170
2171
2172
2173
2174
2175

2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226

2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306

2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354










2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368

2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405

2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474

2475
2476
2477
2478
2479
2480

2481
2482
2483

2484
2485
2486

2487
2488

2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
    enum options {
	STR_BYTELENGTH,	STR_COMPARE,	STR_EQUAL,	STR_FIRST,
	STR_INDEX,	STR_IS,		STR_LAST,	STR_LENGTH,
	STR_MAP,	STR_MATCH,	STR_RANGE,	STR_REPEAT,
	STR_REPLACE,	STR_TOLOWER,	STR_TOUPPER,	STR_TOTITLE,
	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
	STR_WORDEND,	STR_WORDSTART
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
    case STR_EQUAL:
    case STR_COMPARE: {
	/*
	 * Remember to keep code here in some sync with the byte-compiled
	 * versions in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and
	 * INST_STR_CMP as well as the expr string comparison in
	 * INST_EQ/INST_NEQ/INST_LT/...).
	 */

	int i, match, length, nocase = 0, reqlength = -1;
	typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);

	strCmpFn_t strCmpFn;

	if (objc < 4 || objc > 7) {
	str_cmp_args:
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "?-nocase? ?-length int? string1 string2");
	    return TCL_ERROR;
	}

	for (i = 2; i < objc-2; i++) {
	    string2 = Tcl_GetStringFromObj(objv[i], &length2);
	    if ((length2 > 1)
		    && strncmp(string2, "-nocase", (size_t)length2) == 0) {
		nocase = 1;
	    } else if ((length2 > 1)
		    && strncmp(string2, "-length", (size_t)length2) == 0) {
		if (i+1 >= objc-2) {
		    goto str_cmp_args;
		}
		if (Tcl_GetIntFromObj(interp, objv[++i],
			&reqlength) != TCL_OK) {
		    return TCL_ERROR;
		}
	    } else {
		Tcl_AppendResult(interp, "bad option \"", string2,
			"\": must be -nocase or -length", (char *) NULL);

		return TCL_ERROR;
	    }
	}

	/*
	 * From now on, we only access the two objects at the end of the
	 * argument array.
	 */

	objv += objc-2;

	if ((reqlength == 0) || (objv[0] == objv[1])) {
	    /*
	     * Always match at 0 chars of if it is the same obj.
	     */

	    Tcl_SetObjResult(interp,
		    Tcl_NewBooleanObj((enum options) index == STR_EQUAL));
	    break;
	} else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
		objv[1]->typePtr == &tclByteArrayType) {
	    /*
	     * Use binary versions of comparisons since that won't cause undue
	     * type conversions and it is much faster. Only do this if we're
	     * case-sensitive (which is all that really makes sense with byte
	     * arrays anyway, and we have no memcasecmp() for some
	     * reason... :^)
	     */

	    string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
	    string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
	    strCmpFn = (strCmpFn_t) memcmp;
	} else if ((objv[0]->typePtr == &tclStringType)
		&& (objv[1]->typePtr == &tclStringType)) {
	    /*
	     * Do a unicode-specific comparison if both of the args are of
	     * String type. In benchmark testing this proved the most
	     * efficient check between the unicode and string comparison
	     * operations.
	     */

	    string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
	    string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
	    strCmpFn = (strCmpFn_t)
		    (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
	} else {
	    /*
	     * As a catch-all we will work with UTF-8. We cannot use memcmp()
	     * as that is unsafe with any string containing NULL (\xC0\x80 in

	     * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if
	     * we are case-sensitive and no specific length was requested.
	     */

	    string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
	    string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
	    if ((reqlength < 0) && !nocase) {
		strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
	    } else {
		length1 = Tcl_NumUtfChars(string1, length1);
		length2 = Tcl_NumUtfChars(string2, length2);
		strCmpFn = (strCmpFn_t)
			(nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
	    }
	}

	if (((enum options) index == STR_EQUAL)
		&& (reqlength < 0) && (length1 != length2)) {
	    match = 1; /* this will be reversed below */
	} else {
	    length = (length1 < length2) ? length1 : length2;
	    if (reqlength > 0 && reqlength < length) {
		length = reqlength;
	    } else if (reqlength < 0) {
		/*
		 * The requested length is negative, so we ignore it by
		 * setting it to length + 1 so we correct the match var.
		 */

		reqlength = length + 1;
	    }

	    match = strCmpFn(string1, string2, (unsigned) length);
	    if ((match == 0) && (reqlength > length)) {
		match = length1 - length2;
	    }
	}

	if ((enum options) index == STR_EQUAL) {
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(
		    (match > 0) ? 1 : (match < 0) ? -1 : 0));
	}
	break;
    }
    case STR_FIRST: {
	Tcl_UniChar *ustring1, *ustring2;
	int match, start;

	if (objc < 4 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?");

	    return TCL_ERROR;
	}

	/*
	 * We are searching string2 for the sequence string1.
	 */

	match = -1;
	start = 0;
	length2 = -1;

	ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
	ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);

	if (objc == 5) {
	    /*
	     * If a startIndex is specified, we will need to fast forward to
	     * that point in the string before we think about a match.

	     */

	    if (TclGetIntForIndex(interp, objv[4], length2 - 1,
		    &start) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (start >= length2) {
		goto str_first_done;
	    } else if (start > 0) {
		ustring2 += start;
		length2 -= start;
	    } else if (start < 0) {
		/*
		 * Invalid start index mapped to string start; Bug #423581

		 */

		start = 0;
	    }
	}

	if (length1 > 0) {
	    register Tcl_UniChar *p, *end;

	    end = ustring2 + length2 - length1 + 1;
	    for (p = ustring2;  p < end;  p++) {
		/*
		 * Scan forward to find the first character.
		 */
		if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p,

			(unsigned long) length1) == 0)) {
		    match = p - ustring2;
		    break;
		}
	    }
	}

	/*
	 * Compute the character index of the matching string by counting the
	 * number of characters before the match.
	 */

	if ((match != -1) && (objc == 5)) {
	    match += start;
	}

    str_first_done:
	Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
	break;
    }
    case STR_INDEX: {
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
	    return TCL_ERROR;
	}

	/*
	 * If we have a ByteArray object, avoid indexing in the Utf string
	 * since the byte array contains one byte per character. Otherwise,
	 * use the Unicode string rep to get the index'th char.

	 */

	if (objv[2]->typePtr == &tclByteArrayType) {
	    string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);

	    if (TclGetIntForIndex(interp, objv[3], length1 - 1,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if ((index >= 0) && (index < length1)) {
		Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
			(unsigned char *)(&string1[index]), 1));
	    }
	} else {
	    /*
	     * Get Unicode char length to calulate what 'end' means.
	     */

	    length1 = Tcl_GetCharLength(objv[2]);

	    if (TclGetIntForIndex(interp, objv[3], length1 - 1,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if ((index >= 0) && (index < length1)) {
		char buf[TCL_UTF_MAX];
		Tcl_UniChar ch;

		ch = Tcl_GetUniChar(objv[2], index);
		length1 = Tcl_UniCharToUtf(ch, buf);
		Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1));
	    }
	}
	break;
    }
    case STR_IS: {
	char *end;
	Tcl_UniChar ch;

	/*
	 * The UniChar comparison function
	 */

	int (*chcomp)(int) = NULL;
	int i, failat = 0, result = 1, strict = 0;
	Tcl_Obj *objPtr, *failVarObj = NULL;
	Tcl_WideInt w;

	static CONST char *isOptions[] = {
	    "alnum",	   "alpha",	"ascii",	"control",
	    "boolean",	   "digit",	"double",	"false",
	    "graph",	   "integer",	"lower",	"print",
	    "punct",	   "space",	"true",		"upper",
	    "wideinteger", "wordchar",	"xdigit",	(char *) NULL
	};
	enum isOptions {
	    STR_IS_ALNUM, STR_IS_ALPHA,	STR_IS_ASCII,  STR_IS_CONTROL,
	    STR_IS_BOOL,  STR_IS_DIGIT,	STR_IS_DOUBLE, STR_IS_FALSE,
	    STR_IS_GRAPH, STR_IS_INT,	STR_IS_LOWER,  STR_IS_PRINT,
	    STR_IS_PUNCT, STR_IS_SPACE,	STR_IS_TRUE,   STR_IS_UPPER,
	    STR_IS_WIDE,  STR_IS_WORD,	STR_IS_XDIGIT
	};

	if (objc < 4 || objc > 7) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "class ?-strict? ?-failindex var? str");
	    return TCL_ERROR;
	}
	if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc != 4) {
	    for (i = 3; i < objc-1; i++) {
		string2 = Tcl_GetStringFromObj(objv[i], &length2);
		if ((length2 > 1) &&
			strncmp(string2, "-strict", (size_t) length2) == 0) {
		    strict = 1;
		} else if ((length2 > 1) &&
			strncmp(string2, "-failindex", (size_t) length2) == 0){

		    if (i+1 >= objc-1) {
			Tcl_WrongNumArgs(interp, 3, objv,
				"?-strict? ?-failindex var? str");
			return TCL_ERROR;
		    }
		    failVarObj = objv[++i];
		} else {
		    Tcl_AppendResult(interp, "bad option \"", string2,
			    "\": must be -strict or -failindex", (char *)NULL);

		    return TCL_ERROR;
		}
	    }
	}

	/*
	 * We get the objPtr so that we can short-cut for some classes by
	 * checking the object type (int and double), but we need the string
	 * otherwise, because we don't want any conversion of type occuring
	 * (as, for example, Tcl_Get*FromObj would do
	 */

	objPtr = objv[objc-1];
	string1 = Tcl_GetStringFromObj(objPtr, &length1);
	if (length1 == 0) {
	    if (strict) {
		result = 0;
	    }
	    goto str_is_done;
	}
	end = string1 + length1;

	/*
	 * When entering here, result == 1 and failat == 0
	 */

	switch ((enum isOptions) index) {
	case STR_IS_ALNUM:
	    chcomp = Tcl_UniCharIsAlnum;
	    break;
	case STR_IS_ALPHA:
	    chcomp = Tcl_UniCharIsAlpha;
	    break;
	case STR_IS_ASCII:
	    for (; string1 < end; string1++, failat++) {
		/*
		 * This is a valid check in unicode, because all bytes less
		 * than 0xC0 are single byte chars (but isascii limits that
		 * def'n to 0x80).
		 */

		if (*((unsigned char *)string1) >= 0x80) {
		    result = 0;
		    break;
		}
	    }
	    break;
	case STR_IS_BOOL:
	case STR_IS_TRUE:
	case STR_IS_FALSE:
	    if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) {
		result = 0;
	    } else if ((((enum isOptions) index == STR_IS_TRUE) &&
		    objPtr->internalRep.longValue == 0) ||
		    (((enum isOptions) index == STR_IS_FALSE) &&
		    objPtr->internalRep.longValue != 0)) {








		result = 0;
	    }
	    break;
	case STR_IS_CONTROL:
	    chcomp = Tcl_UniCharIsControl;
	    break;
	case STR_IS_DIGIT:
	    chcomp = Tcl_UniCharIsDigit;
	    break;
	case STR_IS_DOUBLE: {
	    char *stop;

	    /* TODO */
	    if ((objPtr->typePtr == &tclDoubleType) ||
		(objPtr->typePtr == &tclIntType) ||















#ifndef NO_WIDE_TYPE



		(objPtr->typePtr == &tclWideIntType) ||
#endif
		(objPtr->typePtr == &tclBignumType)) {




		break;
	    }



	    if (TclParseNumber( NULL, objPtr, NULL, NULL, -1, 








				(CONST char**) &stop, 0 ) != TCL_OK) {



		result = 0;
		failat = 0;
	    } else {





		failat = stop - string1;
		string1 = stop;
		chcomp = Tcl_UniCharIsSpace;
	    }
	    break;
	}
	case STR_IS_GRAPH:
	    chcomp = Tcl_UniCharIsGraph;
	    break;
	case STR_IS_INT: {
	    char *stop;
	    long int l = 0;

	    if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
		break;
	    }

	    /*
	     * Like STR_IS_DOUBLE, but we use strtoul. Since Tcl_GetIntFromObj

	     * already failed, we set result to 0.
	     */

	    result = 0;
	    errno = 0;
	    l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
	    if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
		/*
		 * if (errno == ERANGE) or the long value won't fit in an int,

		 * then it was an over/underflow problem, but in this method,
		 * we only want to know yes or no, so bad flow returns 0
		 * (false) and sets the failVarObj to the string length.

		 */

		failat = -1;
	    } else if (stop == string1) {
		/*
		 * In this case, nothing like a number was found
		 */

		failat = 0;
	    } else {
		/*
		 * Assume we sucked up one char per byte and then we go onto

		 * SPACE, since we are allowed trailing whitespace.
		 */

		failat = stop - string1;
		string1 = stop;
		chcomp = Tcl_UniCharIsSpace;
	    }
	    break;
	}
	case STR_IS_LOWER:
	    chcomp = Tcl_UniCharIsLower;
	    break;
	case STR_IS_PRINT:
	    chcomp = Tcl_UniCharIsPrint;
	    break;
	case STR_IS_PUNCT:
	    chcomp = Tcl_UniCharIsPunct;
	    break;
	case STR_IS_SPACE:
	    chcomp = Tcl_UniCharIsSpace;
	    break;
	case STR_IS_UPPER:
	    chcomp = Tcl_UniCharIsUpper;
	    break;
	case STR_IS_WIDE: {
	    char *stop;

	    if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
		break;
	    }

	    /*
	     * Like STR_IS_DOUBLE, but we use strtoll. Since
	     * Tcl_GetWideIntFromObj already failed, we set result to 0.

	     */

	    result = 0;
	    errno = 0;
	    w = strtoll(string1, &stop, 0);	/* INTL: Tcl source. */
	    if (errno == ERANGE) {
		/*
		 * if (errno == ERANGE), then it was an over/underflow
		 * problem, but in this method, we only want to know yes or

		 * no, so bad flow returns 0 (false) and sets the failVarObj
		 * to the string length.
		 */

		failat = -1;
	    } else if (stop == string1) {
		/*
		 * In this case, nothing like a number was found
		 */
		failat = 0;
	    } else {
		/*
		 * Assume we sucked up one char per byte and then we go onto
		 * SPACE, since we are allowed trailing whitespace.

		 */

		failat = stop - string1;
		string1 = stop;
		chcomp = Tcl_UniCharIsSpace;
	    }
	    break;
	}
	case STR_IS_WORD:
	    chcomp = Tcl_UniCharIsWordChar;
	    break;
	case STR_IS_XDIGIT:
	    for (; string1 < end; string1++, failat++) {
		/* INTL: We assume unicode is bad for this class */
		if ((*((unsigned char *)string1) >= 0xC0) ||
			!isxdigit(*(unsigned char *)string1)) {
		    result = 0;
		    break;
		}
	    }
	    break;
	}

	if (chcomp != NULL) {
	    for (; string1 < end; string1 += length2, failat++) {
		length2 = TclUtfToUniChar(string1, &ch);
		if (!chcomp(ch)) {
		    result = 0;
		    break;
		}
	    }
	}

	/*
	 * Only set the failVarObj when we will return 0 and we have indicated
	 * a valid fail index (>= 0).
	 */

    str_is_done:
	if ((result == 0) && (failVarObj != NULL) &&
	    Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
		    TCL_LEAVE_ERR_MSG) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
	break;
    }
    case STR_LAST: {
	Tcl_UniChar *ustring1, *ustring2, *p;
	int match, start;

	if (objc < 4 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "subString string ?startIndex?");
	    return TCL_ERROR;
	}

	/*
	 * We are searching string2 for the sequence string1.
	 */

	match = -1;
	start = 0;
	length2 = -1;

	ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
	ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);

	if (objc == 5) {
	    /*
	     * If a startIndex is specified, we will need to restrict the
	     * string range to that char index in the string
	     */

	    if (TclGetIntForIndex(interp, objv[4], length2 - 1,
		    &start) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (start < 0) {
		goto str_last_done;
	    } else if (start < length2) {
		p = ustring2 + start + 1 - length1;
	    } else {
		p = ustring2 + length2 - length1;
	    }
	} else {
	    p = ustring2 + length2 - length1;
	}

	if (length1 > 0) {
	    for (; p >= ustring2; p--) {
		/*
		 * Scan backwards to find the first character.
		 */

		if ((*p == *ustring1) &&
			(memcmp((char *) ustring1, (char *) p, (size_t)
			    (length1 * sizeof(Tcl_UniChar))) == 0)) {
		    match = p - ustring2;
		    break;
		}
	    }
	}

    str_last_done:
	Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
	break;
    }
    case STR_BYTELENGTH:
    case STR_LENGTH:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string");
	    return TCL_ERROR;
	}

	if ((enum options) index == STR_BYTELENGTH) {
	    (void) Tcl_GetStringFromObj(objv[2], &length1);
	} else {
	    /*
	     * If we have a ByteArray object, avoid recomputing the string
	     * since the byte array contains one byte per character.
	     * Otherwise, use the Unicode string rep to calculate the length.

	     */

	    if (objv[2]->typePtr == &tclByteArrayType) {
		(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
	    } else {
		length1 = Tcl_GetCharLength(objv[2]);
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(length1));
	break;

    case STR_MAP: {
	int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0;
	Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
	Tcl_UniChar *ustring1, *ustring2, *p, *end;

	int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long);

	if (objc < 4 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
	    return TCL_ERROR;
	}

	if (objc == 5) {
	    string2 = Tcl_GetStringFromObj(objv[2], &length2);
	    if ((length2 > 1) &&
		strncmp(string2, "-nocase", (size_t) length2) == 0) {
		nocase = 1;
	    } else {
		Tcl_AppendResult(interp, "bad option \"", string2,
			"\": must be -nocase", (char *) NULL);
		return TCL_ERROR;
	    }
	}


	/*
	 * This test is tricky, but has to be that way or you get other
	 * strange inconsistencies (see test string-10.20 for illustration
	 * why!)
	 */

	if (objv[objc-2]->typePtr == &tclDictType &&
		objv[objc-2]->bytes == NULL) {
	    int i, done;
	    Tcl_DictSearch search;

	    /*
	     * We know the type exactly, so all dict operations will succeed
	     * for sure. This shortens this code quite a bit.

	     */

	    Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
	    if (mapElemc == 0) {
		/*
		 * empty charMap, just return whatever string was given
		 */

		Tcl_SetObjResult(interp, objv[objc-1]);
		return TCL_OK;
	    }

	    mapElemc *= 2;
	    mapWithDict = 1;

	    /*
	     * Copy the dictionary out into an array; that's the easiest way
	     * to adapt this code...
	     */

	    mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc);
	    Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
		    mapElemv+1, &done);
	    for (i=2 ; i<mapElemc ; i+=2) {
		Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
	    }
	} else {
	    if (Tcl_ListObjGetElements(interp, objv[objc-2],
		    &mapElemc, &mapElemv) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (mapElemc == 0) {
		/*
		 * empty charMap, just return whatever string was given.
		 */

		Tcl_SetObjResult(interp, objv[objc-1]);
		return TCL_OK;
	    } else if (mapElemc & 1) {
		/*
		 * The charMap must be an even number of key/value items.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"char map list unbalanced", -1));
		return TCL_ERROR;
	    }
	}

	/*
	 * Take a copy of the source string object if it is the same as the
	 * map string to cut out nasty sharing crashes. [Bug 1018562]

	 */

	if (objv[objc-2] == objv[objc-1]) {
	    sourceObj = Tcl_DuplicateObj(objv[objc-1]);
	    copySource = 1;
	} else {
	    sourceObj = objv[objc-1];
	}
	ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
	if (length1 == 0) {
	    /*
	     * Empty input string, just stop now.
	     */





























































































































	    if (mapWithDict) {
		ckfree((char *) mapElemv);
	    }
	    if (copySource) {
		Tcl_DecrRefCount(sourceObj);
	    }
	    break;
	}
	end = ustring1 + length1;

	strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);

	/*
	 * Force result to be Unicode
	 */
	resultPtr = Tcl_NewUnicodeObj(ustring1, 0);

	if (mapElemc == 2) {
	    /*
	     * Special case for one map pair which avoids the extra for loop
	     * and extra calls to get Unicode data. The algorithm is otherwise
	     * identical to the multi-pair case. This will be >30% faster on
	     * larger strings.
	     */

	    int mapLen;
	    Tcl_UniChar *mapString, u2lc;

	    ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
	    p = ustring1;
	    if ((length2 > length1) || (length2 == 0)) {
		/*
		 * Match string is either longer than input or empty.
		 */

		ustring1 = end;
	    } else {
		mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
		u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
		for (; ustring1 < end; ustring1++) {
		    if (((*ustring1 == *ustring2) ||
			    (nocase && Tcl_UniCharToLower(*ustring1)==u2lc)) &&
			    (length2==1 || strCmpFn(ustring1, ustring2,
				    (unsigned long) length2) == 0)) {
			if (p != ustring1) {
			    Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
			    p = ustring1 + length2;
			} else {
			    p += length2;
			}
			ustring1 = p - 1;

			Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
		    }
		}
	    }
	} else {
	    Tcl_UniChar **mapStrings, *u2lc = NULL;
	    int *mapLens;

	    /*
	     * Precompute pointers to the unicode string and length. This
	     * saves us repeated function calls later, significantly speeding
	     * up the algorithm. We only need the lowercase first char in the
	     * nocase case.
	     */

	    mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
		    * sizeof(Tcl_UniChar *));
	    mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
	    if (nocase) {
		u2lc = (Tcl_UniChar *)
			ckalloc((mapElemc) * sizeof(Tcl_UniChar));
	    }
	    for (index = 0; index < mapElemc; index++) {
		mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
			&(mapLens[index]));
		if (nocase && ((index % 2) == 0)) {
		    u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
		}
	    }
	    for (p = ustring1; ustring1 < end; ustring1++) {
		for (index = 0; index < mapElemc; index += 2) {
		    /*
		     * Get the key string to match on.
		     */

		    ustring2 = mapStrings[index];
		    length2 = mapLens[index];
		    if ((length2 > 0) && ((*ustring1 == *ustring2) ||
			    (nocase && (Tcl_UniCharToLower(*ustring1) ==
				    u2lc[index/2]))) &&
			    /* restrict max compare length */
			    ((end - ustring1) >= length2) &&
			    ((length2 == 1) || strCmpFn(ustring2, ustring1,
				    (unsigned long) length2) == 0)) {
			if (p != ustring1) {
			    /*
			     * Put the skipped chars onto the result first.
			     */

			    Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
			    p = ustring1 + length2;
			} else {
			    p += length2;
			}

			/*
			 * Adjust len to be full length of matched string.
			 */

			ustring1 = p - 1;

			/*
			 * Append the map value to the unicode string.
			 */

			Tcl_AppendUnicodeToObj(resultPtr,
				mapStrings[index+1], mapLens[index+1]);
			break;
		    }
		}
	    }
	    ckfree((char *) mapStrings);
	    ckfree((char *) mapLens);
	    if (nocase) {
		ckfree((char *) u2lc);
	    }
	}
	if (p != ustring1) {
	    /*
	     * Put the rest of the unmapped chars onto result.
	     */

	    Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
	}
	if (mapWithDict) {
	    ckfree((char *) mapElemv);
	}
	if (copySource) {
	    Tcl_DecrRefCount(sourceObj);
	}
	Tcl_SetObjResult(interp, resultPtr);
	break;
    }
    case STR_MATCH: {
	Tcl_UniChar *ustring1, *ustring2;
	int nocase = 0;

	if (objc < 4 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
	    return TCL_ERROR;
	}

	if (objc == 5) {
	    string2 = Tcl_GetStringFromObj(objv[2], &length2);
	    if ((length2 > 1) &&
		strncmp(string2, "-nocase", (size_t) length2) == 0) {
		nocase = 1;
	    } else {
		Tcl_AppendResult(interp, "bad option \"",
			string2, "\": must be -nocase", (char *) NULL);
		return TCL_ERROR;
	    }
	}
	ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
	ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch(
		ustring1, length1, ustring2, length2, nocase)));
	break;
    }
    case STR_RANGE: {
	int first, last;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string first last");
	    return TCL_ERROR;
	}

	/*
	 * If we have a ByteArray object, avoid indexing in the Utf string
	 * since the byte array contains one byte per character. Otherwise,
	 * use the Unicode string rep to get the range.

	 */

	if (objv[2]->typePtr == &tclByteArrayType) {
	    string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
	    length1--;
	} else {
	    /*
	     * Get the length in actual characters.
	     */

	    string1 = NULL;
	    length1 = Tcl_GetCharLength(objv[2]) - 1;
	}

	if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK ||
		TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) {

	    return TCL_ERROR;
	}

	if (first < 0) {
	    first = 0;
	}
	if (last >= length1) {
	    last = length1;
	}
	if (last >= first) {
	    if (string1 != NULL) {
		int numBytes = last - first + 1;
		Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
			(unsigned char *) &string1[first], numBytes));
	    } else {
		Tcl_SetObjResult(interp,
			Tcl_GetRange(objv[2], first, last));
	    }
	}
	break;
    }
    case STR_REPEAT: {
	int count;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string count");
	    return TCL_ERROR;
	}

	if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
	    return TCL_ERROR;
	}

	if (count == 1) {
	    Tcl_SetObjResult(interp, objv[2]);
	} else if (count > 1) {
	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
	    if (length1 > 0) {
		/*
		 * Only build up a string that has data. Instead of building
		 * it up with repeated appends, we just allocate the necessary
		 * space once and copy the string value in. Check for overflow
		 * with back-division. [Bug #714106]
		 */

		Tcl_Obj *resultPtr;

		length2 = length1 * count;
		if ((length2 / count) != length1) {

		    resultPtr = Tcl_NewObj();
		    TclObjPrintf(NULL, resultPtr,

			    "string size overflow, must be less than %d",

			    INT_MAX);
		    Tcl_SetObjResult(interp, resultPtr);
		    return TCL_ERROR;
		}

		/*
		 * Include space for the NULL.
		 */

		string2 = (char *) ckalloc((size_t) length2+1);
		for (index = 0; index < count; index++) {
		    memcpy(string2 + (length1 * index), string1,
			    (size_t) length1);
		}
		string2[length2] = '\0';

		/*
		 * We have to directly assign this instead of using
		 * Tcl_SetStringObj (and indirectly TclInitStringRep) because
		 * that makes another copy of the data.
		 */

		TclNewObj(resultPtr);
		resultPtr->bytes = string2;
		resultPtr->length = length2;
		Tcl_SetObjResult(interp, resultPtr);
	    }
	}
	break;
    }
    case STR_REPLACE: {
	Tcl_UniChar *ustring1;
	int first, last;

	if (objc < 5 || objc > 6) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?");

	    return TCL_ERROR;
	}

	ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
	length1--;

	if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK ||
		TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) {

	    return TCL_ERROR;
	}

	if ((last < first) || (last < 0) || (first > length1)) {
	    Tcl_SetObjResult(interp, objv[2]);
	} else {
	    Tcl_Obj *resultPtr;
	    if (first < 0) {
		first = 0;
	    }

	    resultPtr = Tcl_NewUnicodeObj(ustring1, first);
	    if (objc == 6) {
		Tcl_AppendObjToObj(resultPtr, objv[5]);
	    }
	    if (last < length1) {
		Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
			length1 - last);
	    }
	    Tcl_SetObjResult(interp, resultPtr);
	}
	break;
    }
    case STR_TOLOWER:
    case STR_TOUPPER:
    case STR_TOTITLE:
	if (objc < 3 || objc > 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
	    return TCL_ERROR;
	}

	string1 = Tcl_GetStringFromObj(objv[2], &length1);

	if (objc == 3) {
	    Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
	    if ((enum options) index == STR_TOLOWER) {
		length1 = Tcl_UtfToLower(TclGetString(resultPtr));
	    } else if ((enum options) index == STR_TOUPPER) {
		length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
	    } else {
		length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
	    }
	    Tcl_SetObjLength(resultPtr, length1);
	    Tcl_SetObjResult(interp, resultPtr);
	} else {
	    int first, last;
	    CONST char *start, *end;
	    Tcl_Obj *resultPtr;

	    length1 = Tcl_NumUtfChars(string1, length1) - 1;
	    if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK){

		return TCL_ERROR;
	    }
	    if (first < 0) {
		first = 0;
	    }
	    last = first;

	    if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
		    &last) != TCL_OK)) {
		return TCL_ERROR;
	    }

	    if (last >= length1) {
		last = length1;
	    }
	    if (last < first) {
		Tcl_SetObjResult(interp, objv[2]);
		break;
	    }

	    start = Tcl_UtfAtIndex(string1, first);
	    end = Tcl_UtfAtIndex(start, last - first + 1);
	    length2 = end-start;
	    string2 = ckalloc((size_t) length2+1);
	    memcpy(string2, start, (size_t) length2);
	    string2[length2] = '\0';

	    if ((enum options) index == STR_TOLOWER) {
		length2 = Tcl_UtfToLower(string2);
	    } else if ((enum options) index == STR_TOUPPER) {
		length2 = Tcl_UtfToUpper(string2);
	    } else {
		length2 = Tcl_UtfToTitle(string2);
	    }

	    resultPtr = Tcl_NewStringObj(string1, start - string1);
	    Tcl_AppendToObj(resultPtr, string2, length2);
	    Tcl_AppendToObj(resultPtr, end, -1);
	    Tcl_SetObjResult(interp, resultPtr);
	    ckfree(string2);
	}
	break;

    case STR_TRIMLEFT:
	left = 1;
	right = 0;
	goto dotrim;
    case STR_TRIMRIGHT:
	left = 0;
	right = 1;
	goto dotrim;
    case STR_TRIM: {
	Tcl_UniChar ch, trim;
	register CONST char *p, *end;
	char *check, *checkEnd;
	int offset;

	left = 1;
	right = 1;

    dotrim:
	if (objc == 4) {
	    string2 = Tcl_GetStringFromObj(objv[3], &length2);
	} else if (objc == 3) {
	    string2 = " \t\n\r";
	    length2 = strlen(string2);
	} else {
	    Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
	    return TCL_ERROR;
	}
	string1 = Tcl_GetStringFromObj(objv[2], &length1);
	checkEnd = string2 + length2;

	if (left) {
	    end = string1 + length1;
	    /*
	     * The outer loop iterates over the string. The inner loop
	     * iterates over the trim characters. The loops terminate as soon
	     * as a non-trim character is discovered and string1 is left
	     * pointing at the first non-trim character.

	     */

	    for (p = string1; p < end; p += offset) {
		offset = TclUtfToUniChar(p, &ch);

		for (check = string2; ; ) {
		    if (check >= checkEnd) {
			p = end;
			break;
		    }
		    check += TclUtfToUniChar(check, &trim);
		    if (ch == trim) {
			length1 -= offset;
			string1 += offset;
			break;
		    }
		}
	    }
	}
	if (right) {
	    end = string1;

	    /*
	     * The outer loop iterates over the string. The inner loop
	     * iterates over the trim characters. The loops terminate as soon
	     * as a non-trim character is discovered and length1 marks the
	     * last non-trim character.
	     */

	    for (p = string1 + length1; p > end; ) {
		p = Tcl_UtfPrev(p, string1);
		offset = TclUtfToUniChar(p, &ch);
		for (check = string2; ; ) {
		    if (check >= checkEnd) {
			p = end;
			break;
		    }
		    check += TclUtfToUniChar(check, &trim);
		    if (ch == trim) {
			length1 -= offset;
			break;
		    }
		}
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1));
	break;
    }










    case STR_WORDEND: {
	int cur;
	Tcl_UniChar ch;
	CONST char *p, *end;
	int numChars;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string index");
	    return TCL_ERROR;
	}

	string1 = Tcl_GetStringFromObj(objv[2], &length1);
	numChars = Tcl_NumUtfChars(string1, length1);
	if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) {

	    return TCL_ERROR;
	}
	if (index < 0) {
	    index = 0;
	}
	if (index < numChars) {
	    p = Tcl_UtfAtIndex(string1, index);
	    end = string1+length1;
	    for (cur = index; p < end; cur++) {
		p += TclUtfToUniChar(p, &ch);
		if (!Tcl_UniCharIsWordChar(ch)) {
		    break;
		}
	    }
	    if (cur == index) {
		cur++;
	    }
	} else {
	    cur = numChars;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
	break;
    }
    case STR_WORDSTART: {
	int cur;
	Tcl_UniChar ch;
	CONST char *p;
	int numChars;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "string index");
	    return TCL_ERROR;
	}

	string1 = Tcl_GetStringFromObj(objv[2], &length1);
	numChars = Tcl_NumUtfChars(string1, length1);
	if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) {

	    return TCL_ERROR;
	}
	if (index >= numChars) {
	    index = numChars - 1;
	}
	cur = 0;
	if (index > 0) {
	    p = Tcl_UtfAtIndex(string1, index);
	    for (cur = index; cur >= 0; cur--) {
		TclUtfToUniChar(p, &ch);
		if (!Tcl_UniCharIsWordChar(ch)) {
		    break;
		}
		p = Tcl_UtfPrev(p, string1);
	    }
	    if (cur != index) {
		cur += 1;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
	break;
    }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SubstObjCmd --
 *
 *	This procedure is invoked to process the "subst" Tcl command. See the
 *	user documentation for details on what it does. This command relies on
 *	Tcl_SubstObj() for its implementation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    static CONST char *substOptions[] = {
	"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
    };
    enum substOptions {
	SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
    };
    Tcl_Obj *resultPtr;
    int optionIndex, flags, i;

    /*
     * Parse command-line options.
     */

    flags = TCL_SUBST_ALL;
    for (i = 1; i < (objc-1); i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0,
		&optionIndex) != TCL_OK) {

	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case SUBST_NOBACKSLASHES:
	    flags &= ~TCL_SUBST_BACKSLASHES;
	    break;

	case SUBST_NOCOMMANDS:
	    flags &= ~TCL_SUBST_COMMANDS;
	    break;

	case SUBST_NOVARS:
	    flags &= ~TCL_SUBST_VARIABLES;
	    break;

	default:
	    Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions");

	}
    }
    if (i != (objc-1)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nobackslashes? ?-nocommands? ?-novariables? string");
	return TCL_ERROR;
    }

    /*
     * Perform the substitution.
     */

    resultPtr = Tcl_SubstObj(interp, objv[i], flags);

    if (resultPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
2497
2498
2499
2500
2501
2502
2503
2504

2505
2506
2507
2508






2509
2510
2511
2512
2513
2514

2515


2516
2517

2518
2519
2520

2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i, j, index, mode, result, splitObjs, numMatchesSaved;

    char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *CONST *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;






    static CONST char *options[] = {
	"-exact", "-glob", "-indexvar", "-matchvar", "-regexp", "--", 
	NULL
    };
    enum options {
	OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_REGEXP, OPT_LAST

    };



    mode = OPT_EXACT;

    indexVarObj = NULL;
    matchVarObj = NULL;
    numMatchesSaved = 0;

    for (i = 1; i < objc; i++) {
	if (TclGetString(objv[i])[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == OPT_LAST) {
	    i++;
	    break;
	}

	/*
	 * Check for TIP#75 options specifying the variables to write
	 * regexp information into.
	 */

	if (index == OPT_INDEXV) {
	    i++;
	    if (i == objc) {
		Tcl_AppendResult(interp,
			"missing variable name argument to -indexvar option",







|
>




>
>
>
>
>
>

|
|


|
>

>
>


>



>




|









|
|







2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase;
    int patternLength;
    char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *CONST *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;

    /*
     * If you add options that make -e and -g not unique prefixes of -exact or
     * -glob, you *must* fix TclCompileSwitchCmd's option parser as well.
     */

    static CONST char *options[] = {
	"-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp",
	"--", NULL
    };
    enum options {
	OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP,
	OPT_LAST
    };
    typedef int (*strCmpFn_t)(const char *, const char *);
    strCmpFn_t strCmpFn = strcmp;

    mode = OPT_EXACT;
    foundmode = 0;
    indexVarObj = NULL;
    matchVarObj = NULL;
    numMatchesSaved = 0;
    noCase = 0;
    for (i = 1; i < objc; i++) {
	if (TclGetString(objv[i])[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == OPT_LAST) {
	    i++;
	    break;
	}

	/*
	 * Check for TIP#75 options specifying the variables to write regexp
	 * information into.
	 */

	if (index == OPT_INDEXV) {
	    i++;
	    if (i == objc) {
		Tcl_AppendResult(interp,
			"missing variable name argument to -indexvar option",
2552
2553
2554
2555
2556
2557
2558



2559











2560
2561
2562
2563
2564
2565
2566
		Tcl_AppendResult(interp,
			"missing variable name argument to -matchvar option",
			(char *) NULL);
		return TCL_ERROR;
	    }
	    matchVarObj = objv[i];
	    numMatchesSaved = -1;



	} else {











	    mode = index;
	}
    }

    if (objc - i < 2) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?switches? string pattern body ... ?default body?");







>
>
>

>
>
>
>
>
>
>
>
>
>
>







2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
		Tcl_AppendResult(interp,
			"missing variable name argument to -matchvar option",
			(char *) NULL);
		return TCL_ERROR;
	    }
	    matchVarObj = objv[i];
	    numMatchesSaved = -1;
	} else if (index == OPT_NOCASE) {
	    strCmpFn = strcasecmp;
	    noCase = 1;
	} else {
	    if (foundmode) {
		/*
		 * Mode already set via -exact, -glob, or -regexp.
		 */

		Tcl_AppendResult(interp, "bad option \"",
			TclGetString(objv[i]), "\": ", options[mode],
			" option already found", (char *) NULL);
		return TCL_ERROR;
	    }
	    foundmode = 1;
	    mode = index;
	}
    }

    if (objc - i < 2) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?switches? string pattern body ... ?default body?");
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
    }

    stringObj = objv[i];
    objc -= i + 1;
    objv += i + 1;

    /*
     * If all of the pattern/command pairs are lumped into a single
     * argument, split them out again.
     */

    splitObjs = 0;
    if (objc == 1) {
	Tcl_Obj **listv;

	if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {







|
|







2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
    }

    stringObj = objv[i];
    objc -= i + 1;
    objv += i + 1;

    /*
     * If all of the pattern/command pairs are lumped into a single argument,
     * split them out again.
     */

    splitObjs = 0;
    if (objc == 1) {
	Tcl_Obj **listv;

	if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672

2673
2674
2675
2676
2677
2678
2679
	    return TCL_ERROR;
	}
	objv = listv;
	splitObjs = 1;
    }

    /*
     * Complain if there is an odd number of words in the list of
     * patterns and bodies.
     */

    if (objc % 2) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);

	/*
	 * Check if this can be due to a badly placed comment
	 * in the switch block.
	 *
	 * The following is an heuristic to detect the infamous
	 * "comment in switch" error: just check if a pattern
	 * begins with '#'.
	 */

	if (splitObjs) {
	    for (i=0 ; i<objc ; i+=2) {
		if (TclGetString(objv[i])[0] == '#') {
		    Tcl_AppendResult(interp, ", this may be due to a ",
			    "comment incorrectly placed outside of a ",
			    "switch body - see the \"switch\" ",
			    "documentation", NULL);
		    break;
		}
	    }
	}

	return TCL_ERROR;
    }

    /*
     * Complain if the last body is a continuation.  Note that this
     * check assumes that the list is non-empty!
     */

    if (strcmp(TclGetString(objv[objc-1]), "-") == 0) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "no body specified for pattern \"",
		TclGetString(objv[objc-2]), "\"", NULL);
	return TCL_ERROR;
    }

    for (i = 0; i < objc; i += 2) {
	/*
	 * See if the pattern matches the string.
	 */

	pattern = TclGetString(objv[i]);

	if ((i == objc - 2) && (*pattern == 'd') 
		&& (strcmp(pattern, "default") == 0)) {
	    Tcl_Obj *emptyObj = NULL;

	    /*
	     * If either indexVarObj or matchVarObj are non-NULL,
	     * we're in REGEXP mode but have reached the default
	     * clause anyway.  TIP#75 specifies that we set the
	     * variables to empty lists (== empty objects) in that
	     * case.
	     */

	    if (indexVarObj != NULL) {
		TclNewObj(emptyObj);
		if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj,
			TCL_LEAVE_ERR_MSG) == NULL) {
		    Tcl_DecrRefCount(emptyObj);
		    return TCL_ERROR;
		}







|
|







|
|

|
|
<


















|
|














|

|




|
|
|
|
<

>







2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681

2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726

2727
2728
2729
2730
2731
2732
2733
2734
2735
	    return TCL_ERROR;
	}
	objv = listv;
	splitObjs = 1;
    }

    /*
     * Complain if there is an odd number of words in the list of patterns and
     * bodies.
     */

    if (objc % 2) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);

	/*
	 * Check if this can be due to a badly placed comment in the switch
	 * block.
	 *
	 * The following is an heuristic to detect the infamous "comment in
	 * switch" error: just check if a pattern begins with '#'.

	 */

	if (splitObjs) {
	    for (i=0 ; i<objc ; i+=2) {
		if (TclGetString(objv[i])[0] == '#') {
		    Tcl_AppendResult(interp, ", this may be due to a ",
			    "comment incorrectly placed outside of a ",
			    "switch body - see the \"switch\" ",
			    "documentation", NULL);
		    break;
		}
	    }
	}

	return TCL_ERROR;
    }

    /*
     * Complain if the last body is a continuation. Note that this check
     * assumes that the list is non-empty!
     */

    if (strcmp(TclGetString(objv[objc-1]), "-") == 0) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "no body specified for pattern \"",
		TclGetString(objv[objc-2]), "\"", NULL);
	return TCL_ERROR;
    }

    for (i = 0; i < objc; i += 2) {
	/*
	 * See if the pattern matches the string.
	 */

	pattern = Tcl_GetStringFromObj(objv[i], &patternLength);

	if ((i == objc - 2) && (*pattern == 'd')
		&& (strcmp(pattern, "default") == 0)) {
	    Tcl_Obj *emptyObj = NULL;

	    /*
	     * If either indexVarObj or matchVarObj are non-NULL, we're in
	     * REGEXP mode but have reached the default clause anyway. TIP#75
	     * specifies that we set the variables to empty lists (== empty
	     * objects) in that case.

	     */

	    if (indexVarObj != NULL) {
		TclNewObj(emptyObj);
		if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj,
			TCL_LEAVE_ERR_MSG) == NULL) {
		    Tcl_DecrRefCount(emptyObj);
		    return TCL_ERROR;
		}
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702

2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746

2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758

2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769

2770
2771
2772
2773

2774
2775
2776
2777
2778
2779
2780
2781

2782
2783
2784
2785
2786
2787
2788
2789
2790
2791

2792
2793
2794
2795
2796

2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807

2808
2809
2810
2811
2812
2813

2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825

2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867

2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899







2900










2901

2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968








		    return TCL_ERROR;
		}
	    }
	    goto matchFound;
	} else {
	    switch (mode) {
	    case OPT_EXACT:
		if (strcmp(TclGetString(stringObj), pattern) == 0) {
		    goto matchFound;
		}
		break;
	    case OPT_GLOB:
		if (Tcl_StringMatch(TclGetString(stringObj), pattern)) {

		    goto matchFound;
		}
		break;
	    case OPT_REGEXP:
		regExpr = Tcl_GetRegExpFromObj(interp, objv[i],
			TCL_REG_ADVANCED);
		if (regExpr == NULL) {
		    return TCL_ERROR;
		} else {
		    int matched = Tcl_RegExpExecObj(interp, regExpr,
			    stringObj, 0, numMatchesSaved, 0);
		    if (matched < 0) {
			return TCL_ERROR;
		    } else if (matched) {
			goto matchFoundRegexp;
		    }
		}
		break;
	    }
	}
    }
    return TCL_OK;

  matchFoundRegexp:
    /*
     * We are operating in REGEXP mode and we need to store
     * information about what we matched in some user-nominated
     * arrays.  So build the lists of values and indices to write
     * here.  [TIP#75]
     */

    if (numMatchesSaved) {
	Tcl_RegExpInfo info;
	Tcl_Obj *matchesObj, *indicesObj = NULL;

	Tcl_RegExpGetInfo(regExpr, &info);
	if (matchVarObj != NULL) {
	    TclNewObj(matchesObj);
	} else {
	    matchesObj = NULL;
	}
	if (indexVarObj != NULL) {
	    TclNewObj(indicesObj);
	}

	for (j=0 ; j<=info.nsubs ; j++) {
	    if (indexVarObj != NULL) {
		Tcl_Obj *rangeObjAry[2];

		rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
		rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end);
		/*
		 * Never fails; the object is always clean at this point.
		 */
		Tcl_ListObjAppendElement(NULL, indicesObj,
			Tcl_NewListObj(2, rangeObjAry));
	    }

	    if (matchVarObj != NULL) {
		Tcl_Obj *substringObj;

		substringObj = Tcl_GetRange(stringObj,
			info.matches[j].start, info.matches[j].end-1);
		/*
		 * Never fails; the object is always clean at this point.
		 */
		Tcl_ListObjAppendElement(NULL, matchesObj, substringObj);
	    }
	}

	if (indexVarObj != NULL) {
	    if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_DecrRefCount(indicesObj);

		/*
		 * Careful!  Check to see if we have allocated the
		 * list of matched strings; if so (but there was an
		 * error assigning the indices list) we have a
		 * potential memory leak because the match list has
		 * not been written to a variable.  Except that we'll
		 * clean that up right now.
		 */

		if (matchesObj != NULL) {
		    Tcl_DecrRefCount(matchesObj);
		}
		return TCL_ERROR;
	    }
	}
	if (matchVarObj != NULL) {
	    if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_DecrRefCount(matchesObj);

		/*
		 * Unlike above, if indicesObj is non-NULL at this
		 * point, it will have been written to a variable
		 * already and will hence not be leaked.
		 */

		return TCL_ERROR;
	    }
	}
    }

  matchFound:
    /*
     * We've got a match. Find a body to execute, skipping bodies that
     * are "-".
     */


    for (j = i + 1; ; j += 2) {
	if (j >= objc) {
	    /*
	     * This shouldn't happen since we've checked that the
	     * last body is not a continuation...
	     */

	    Tcl_Panic("fall-out when searching for body to match pattern");
	}
	if (strcmp(TclGetString(objv[j]), "-") != 0) {
	    break;
	}
    }

    result = Tcl_EvalObjEx(interp, objv[j], 0);

    /*
     * Generate an error message if necessary.
     */

    if (result == TCL_ERROR) {
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (\"", -1);
	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_IncrRefCount(msg);
	Tcl_IncrRefCount(errorLine);
	TclAppendLimitedToObj(msg, pattern, -1, 50, "");
	Tcl_AppendToObj(msg,"\" arm line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg,")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TimeObjCmd --
 *
 *	This object-based procedure is invoked to process the "time" Tcl
 *	command.  See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Tcl_Obj *objPtr;

    register int i, result;
    int count;
    double totalMicroSec;
    Tcl_Time start, stop;
    char buf[100];

    if (objc == 2) {
	count = 1;
    } else if (objc == 3) {
	result = Tcl_GetIntFromObj(interp, objv[2], &count);
	if (result != TCL_OK) {
	    return result;
	}
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
	return TCL_ERROR;
    }
    
    objPtr = objv[1];
    i = count;
    Tcl_GetTime(&start);
    while (i-- > 0) {
	result = Tcl_EvalObjEx(interp, objPtr, 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
    Tcl_GetTime(&stop);
    
    totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
		      + ( stop.usec - start.usec ) );
    sprintf(buf, "%.0f microseconds per iteration",







	((count <= 0) ? 0 : totalMicroSec/count));










    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileObjCmd --
 *
 *      This procedure is invoked to process the "while" Tcl command.
 *      See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when
 *	a command name is computed at runtime, and is "while" or the name
 *	to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];       	/* Argument objects. */
{
    int result, value;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "test command");
        return TCL_ERROR;
    }

    while (1) {
        result = Tcl_ExprBooleanObj(interp, objv[1], &value);
        if (result != TCL_OK) {
            return result;
        }
        if (!value) {
            break;
        }
        result = Tcl_EvalObjEx(interp, objv[2], 0);
        if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
            if (result == TCL_ERROR) {
                char msg[32 + TCL_INTEGER_SPACE];

                sprintf(msg, "\n    (\"while\" body line %d)",
                        interp->errorLine);
                Tcl_AddErrorInfo(interp, msg);
            }
            break;
        }
    }
    if (result == TCL_BREAK) {
        result = TCL_OK;
    }
    if (result == TCL_OK) {
        Tcl_ResetResult(interp);
    }
    return result;
}















|




|
>





|



















|
|
|
<















>












>











>




>

|
|
|
<
|
|

>










>

|
|
|

>





<

|
|


>



|
|

>












>

<
|
|
|
|
<
<
|
<
<
<










|



















>




<












|










|
|
|
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>








|
|

|
|
|


|


|




|


|
|
|
|





|



|
|
|
|
|
|
|
|
|
|
<
<
|
|
<
|
|
|


|


|



>
>
>
>
>
>
>
>
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787

2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837

2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863

2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890

2891
2892
2893
2894


2895



2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930

2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027


3028
3029

3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
		    return TCL_ERROR;
		}
	    }
	    goto matchFound;
	} else {
	    switch (mode) {
	    case OPT_EXACT:
		if (strCmpFn(TclGetString(stringObj), pattern) == 0) {
		    goto matchFound;
		}
		break;
	    case OPT_GLOB:
		if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern,
			noCase)) {
		    goto matchFound;
		}
		break;
	    case OPT_REGEXP:
		regExpr = Tcl_GetRegExpFromObj(interp, objv[i],
			TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0));
		if (regExpr == NULL) {
		    return TCL_ERROR;
		} else {
		    int matched = Tcl_RegExpExecObj(interp, regExpr,
			    stringObj, 0, numMatchesSaved, 0);
		    if (matched < 0) {
			return TCL_ERROR;
		    } else if (matched) {
			goto matchFoundRegexp;
		    }
		}
		break;
	    }
	}
    }
    return TCL_OK;

  matchFoundRegexp:
    /*
     * We are operating in REGEXP mode and we need to store information about
     * what we matched in some user-nominated arrays. So build the lists of
     * values and indices to write here. [TIP#75]

     */

    if (numMatchesSaved) {
	Tcl_RegExpInfo info;
	Tcl_Obj *matchesObj, *indicesObj = NULL;

	Tcl_RegExpGetInfo(regExpr, &info);
	if (matchVarObj != NULL) {
	    TclNewObj(matchesObj);
	} else {
	    matchesObj = NULL;
	}
	if (indexVarObj != NULL) {
	    TclNewObj(indicesObj);
	}

	for (j=0 ; j<=info.nsubs ; j++) {
	    if (indexVarObj != NULL) {
		Tcl_Obj *rangeObjAry[2];

		rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
		rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end);
		/*
		 * Never fails; the object is always clean at this point.
		 */
		Tcl_ListObjAppendElement(NULL, indicesObj,
			Tcl_NewListObj(2, rangeObjAry));
	    }

	    if (matchVarObj != NULL) {
		Tcl_Obj *substringObj;

		substringObj = Tcl_GetRange(stringObj,
			info.matches[j].start, info.matches[j].end-1);
		/*
		 * Never fails; the object is always clean at this point.
		 */
		Tcl_ListObjAppendElement(NULL, matchesObj, substringObj);
	    }
	}

	if (indexVarObj != NULL) {
	    if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_DecrRefCount(indicesObj);

		/*
		 * Careful! Check to see if we have allocated the list of
		 * matched strings; if so (but there was an error assigning
		 * the indices list) we have a potential memory leak because

		 * the match list has not been written to a variable. Except
		 * that we'll clean that up right now.
		 */

		if (matchesObj != NULL) {
		    Tcl_DecrRefCount(matchesObj);
		}
		return TCL_ERROR;
	    }
	}
	if (matchVarObj != NULL) {
	    if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		Tcl_DecrRefCount(matchesObj);

		/*
		 * Unlike above, if indicesObj is non-NULL at this point, it
		 * will have been written to a variable already and will hence
		 * not be leaked.
		 */

		return TCL_ERROR;
	    }
	}
    }


    /*
     * We've got a match. Find a body to execute, skipping bodies that are
     * "-".
     */

  matchFound:
    for (j = i + 1; ; j += 2) {
	if (j >= objc) {
	    /*
	     * This shouldn't happen since we've checked that the last body is
	     * not a continuation...
	     */

	    Tcl_Panic("fall-out when searching for body to match pattern");
	}
	if (strcmp(TclGetString(objv[j]), "-") != 0) {
	    break;
	}
    }

    result = Tcl_EvalObjEx(interp, objv[j], 0);

    /*
     * Generate an error message if necessary.
     */

    if (result == TCL_ERROR) {

	int limit = 50;
	int overflow = (patternLength > limit);
	TclFormatToErrorInfo(interp, "\n    (\"%.*s%s\" arm line %d)",
		(overflow ? limit : patternLength), pattern,


		(overflow ? "..." : ""), interp->errorLine);



    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TimeObjCmd --
 *
 *	This object-based procedure is invoked to process the "time" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Tcl_Obj *objPtr;
    Tcl_Obj *objs[4];
    register int i, result;
    int count;
    double totalMicroSec;
    Tcl_Time start, stop;


    if (objc == 2) {
	count = 1;
    } else if (objc == 3) {
	result = Tcl_GetIntFromObj(interp, objv[2], &count);
	if (result != TCL_OK) {
	    return result;
	}
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
	return TCL_ERROR;
    }

    objPtr = objv[1];
    i = count;
    Tcl_GetTime(&start);
    while (i-- > 0) {
	result = Tcl_EvalObjEx(interp, objPtr, 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
    Tcl_GetTime(&stop);

    totalMicroSec = (((double) (stop.sec - start.sec))*1.0e6
	    + (stop.usec - start.usec));

    if (count <= 1) {
	/*
	 * Use int obj since we know time is not fractional. [Bug 1202178]
	 */

	objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec);
    } else {
	objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
    }

    /*
     * Construct the result as a list because many programs have always parsed
     * at such (extracting the first element, typically).
     */

    objs[1] = Tcl_NewStringObj("microseconds", -1);
    objs[2] = Tcl_NewStringObj("per", -1);
    objs[3] = Tcl_NewStringObj("iteration", -1);
    Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileObjCmd --
 *
 *	This procedure is invoked to process the "while" Tcl command. See the
 *	user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is only called when a
 *	command name is computed at runtime, and is "while" or the name to
 *	which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result, value;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "test command");
	return TCL_ERROR;
    }

    while (1) {
	result = Tcl_ExprBooleanObj(interp, objv[1], &value);
	if (result != TCL_OK) {
	    return result;
	}
	if (!value) {
	    break;
	}
	result = Tcl_EvalObjEx(interp, objv[2], 0);
	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
	    if (result == TCL_ERROR) {


		TclFormatToErrorInfo(interp, "\n    (\"while\" body line %d)",
			interp->errorLine);

	    }
	    break;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCompCmds.c.

1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16
17
18
19
















































































20
21
22
23
24
25
26
/* 
 * tclCompCmds.c --
 *
 *	This file contains compilation procedures that compile various
 *	Tcl commands into a sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompCmds.c,v 1.59 2004/10/18 21:15:37 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

















































































/*
 * Prototypes for procedures defined later in this file:
 */

static ClientData	DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static void		FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
static int		PushVarName _ANSI_ARGS_((Tcl_Interp *interp,
|



|




>




|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
/*
 * tclCompCmds.c --
 *
 *	This file contains compilation procedures that compile various
 *	Tcl commands into a sequence of instructions ("bytecodes").
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2004-2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompCmds.c,v 1.59.2.7 2005/08/15 20:46:02 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Macro that encapsulates an efficiency trick that avoids a function call for
 * the simplest of compiles.  The ANSI C "prototype" for this macro is:
 *
 * static void		CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
 *			    Tcl_Interp *interp);
 */

#define CompileWord(envPtr, tokenPtr, interp) \
    if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
	TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
		(tokenPtr)[1].size), (envPtr)); \
    } else { \
	TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
		(envPtr)); \
    }

/*
 * Convenience macro for use when compiling bodies of commands. The ANSI C
 * "prototype" for this macro is:
 *
 * static void		CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
 *			    Tcl_Interp *interp);
 */

#define CompileBody(envPtr, tokenPtr, interp) \
    TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
	    (envPtr))

/*
 * Convenience macro for use when pushing literals. The ANSI C "prototype" for
 * this macro is:
 *
 * static void		PushLiteral(CompileEnv *envPtr,
 *			    const char *string, int length);
 */

#define PushLiteral(envPtr, string, length) \
    TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))

/*
 * Macro to advance to the next token; it is more mnemonic than the address
 * arithmetic that it replaces. The ANSI C "prototype" for this macro is:
 *
 * static Tcl_Token *	TokenAfter(Tcl_Token *tokenPtr);
 */

#define TokenAfter(tokenPtr) \
    ((tokenPtr) + ((tokenPtr)->numComponents + 1))

/*
 * Macro to get the offset to the next instruction to be issued. The ANSI C
 * "prototype" for this macro is:
 *
 * static int	CurrentOffset(CompileEnv *envPtr);
 */

#define CurrentOffset(envPtr) \
    ((envPtr)->codeNext - (envPtr)->codeStart)

/*
 * static int	DeclareExceptionRange(CompileEnv *envPtr, int type);
 * static int	ExceptionRangeStarts(CompileEnv *envPtr, int index);
 * static void	ExceptionRangeEnds(CompileEnv *envPtr, int index);
 * static void	ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
 */

#define DeclareExceptionRange(envPtr, type) \
    (((envPtr)->exceptDepth++), \
    ((envPtr)->maxExceptDepth = \
	    TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
    (TclCreateExceptRange((type), (envPtr))))
#define ExceptionRangeStarts(envPtr, index) \
    ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))
#define ExceptionRangeEnds(envPtr, index) \
    ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
	CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)
#define ExceptionRangeTarget(envPtr, index, targetType) \
    ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))

/*
 * Prototypes for procedures defined later in this file:
 */

static ClientData	DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static void		FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
static int		PushVarName _ANSI_ARGS_((Tcl_Interp *interp,
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127

128
129
130
131
132
133

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249

250

















251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287

288
289
290
291
292

293
294
295
296
297
298
299
300
301




302
303

304










305
306
307
308


309
310
311
312
313
314
315
316
317
318


319
320
321
322
323
324


325







326
327
328
329
330
331

332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395































































































































































































































































































































































































































































































































396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543

544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579

580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */

/*
 * The structures below define the AuxData types defined in this file.
 */

AuxDataType tclForeachInfoType = {
    "ForeachInfo",				/* name */
    DupForeachInfo,				/* dupProc */
    FreeForeachInfo				/* freeProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclCompileAppendCmd --
 *
 *	Procedure called to compile the "append" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "append" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileAppendCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int simpleVarName, isScalar, localIndex, numWords;

    numWords = parsePtr->numWords;
    if (numWords == 1) {
        return TCL_OUT_LINE_COMPILE;
    } else if (numWords == 2) {
	/*
	 * append varName == set varName
	 */
        return TclCompileSetCmd(interp, parsePtr, envPtr);
    } else if (numWords > 3) {
	/*
	 * APPEND instructions currently only handle one value
	 */
        return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * We are doing an assignment, otherwise TclCompileSetCmd was called,
     * so push the new value.  This will need to be extended to push a
     * value for each argument.
     */

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, 
		    valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	} else {
	    TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	}
    }

    /*
     * Emit instructions to set/get the variable.
     */

    if (simpleVarName) {
	if (isScalar) {
	    if (localIndex >= 0) {

		if (localIndex <= 255) {
		    TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
		} else {
		    TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
		}
	    } else {

		TclEmitOpcode(INST_APPEND_STK, envPtr);
	    }
	} else {
	    if (localIndex >= 0) {
		if (localIndex <= 255) {
		    TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
		} else {
		    TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
		}
	    } else {
		TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
	    }
	}
    } else {
	TclEmitOpcode(INST_APPEND_STK, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileBreakCmd --
 *
 *	Procedure called to compile the "break" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "break" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileBreakCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    if (parsePtr->numWords != 1) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Emit a break instruction.
     */

    TclEmitOpcode(INST_BREAK, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCatchCmd --
 *
 *	Procedure called to compile the "catch" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "catch" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileCatchCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    JumpFixup jumpFixup;
    Tcl_Token *cmdTokenPtr, *nameTokenPtr;
    CONST char *name;
    int localIndex, nameChars, range, startOffset;
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * If syntax does not match what we expect for [catch], do not
     * compile.  Let runtime checks determine if syntax has changed.
     */
    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * If a variable was specified and the catch command is at global level
     * (not in a procedure), don't compile it inline: the payoff is
     * too small.
     */

    if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Make sure the variable name, if any, has no substitutions and just
     * refers to a local scaler.
     */

    localIndex = -1;
    cmdTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    if (parsePtr->numWords == 3) {
	nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);

	if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {

















	    name = nameTokenPtr[1].start;
	    nameChars = nameTokenPtr[1].size;
	    if (!TclIsLocalScalar(name, nameChars)) {
		return TCL_OUT_LINE_COMPILE;
	    }
	    localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
		    nameTokenPtr[1].size, /*create*/ 1, 
		    /*flags*/ VAR_SCALAR, envPtr->procPtr);
	} else {
	   return TCL_OUT_LINE_COMPILE;
	}
    }

    /*
     * We will compile the catch command. Emit a beginCatch instruction at
     * the start of the catch body: the subcommand it controls.
     */

    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =
	TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
    TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);

    /*
     * If the body is a simple word, compile the instructions to
     * eval it. Otherwise, compile instructions to substitute its
     * text without catching, a catch instruction that resets the 
     * stack to what it was before substituting the body, and then 
     * an instruction to eval the body. Care has to be taken to 
     * register the correct startOffset for the catch range so that
     * errors in the substitution are not catched [Bug 219184]
     */

    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	startOffset = (envPtr->codeNext - envPtr->codeStart);
	TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);

    } else {
	TclCompileTokens(interp, cmdTokenPtr+1,
	        cmdTokenPtr->numComponents, envPtr);
	startOffset = (envPtr->codeNext - envPtr->codeStart);
	TclEmitOpcode(INST_EVAL_STK, envPtr);

    }
    envPtr->exceptArrayPtr[range].codeOffset = startOffset;
    envPtr->exceptArrayPtr[range].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart) - startOffset;

    /*
     * The "no errors" epilogue code: store the body's result into the
     * variable (if any), push "0" (TCL_OK) as the catch's "no error"
     * result, and jump around the "error case" code.




     */


    if (localIndex != -1) {










	if (localIndex <= 255) {
	    TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
	} else {
	    TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);


	}
    }
    TclEmitOpcode(INST_POP, envPtr);
    TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * The "error case" code: store the body's result into the variable (if
     * any), then push the error result code. The initial PC offset here is
     * the catch's error target.


     */

    envPtr->currStackDepth = savedStackDepth;
    envPtr->exceptArrayPtr[range].catchOffset =
	    (envPtr->codeNext - envPtr->codeStart);
    if (localIndex != -1) {


	TclEmitOpcode(INST_PUSH_RESULT, envPtr);







	if (localIndex <= 255) {
	    TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
	} else {
	    TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
	}
	TclEmitOpcode(INST_POP, envPtr);

    }
    TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);


    /*
     * Update the target of the jump after the "no errors" code, then emit
     * an endCatch instruction at the end of the catch command.
     */

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileCatchCmd: bad jump distance %d\n",
		(envPtr->codeNext - envPtr->codeStart) - jumpFixup.codeOffset);
    }
    TclEmitOpcode(INST_END_CATCH, envPtr);

    envPtr->currStackDepth = savedStackDepth + 1;
    envPtr->exceptDepth--;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileContinueCmd --
 *
 *	Procedure called to compile the "continue" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "continue" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileContinueCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * There should be no argument after the "continue".
     */

    if (parsePtr->numWords != 1) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Emit a continue instruction.
     */

    TclEmitOpcode(INST_CONTINUE, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *































































































































































































































































































































































































































































































































 * TclCompileExprCmd --
 *
 *	Procedure called to compile the "expr" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "expr" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileExprCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *firstWordPtr;

    if (parsePtr->numWords == 1) {
	return TCL_OUT_LINE_COMPILE;
    }

    firstWordPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileForCmd --
 *
 *	Procedure called to compile the "for" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "for" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */
int
TclCompileForCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
    int bodyRange, nextRange;
    int savedStackDepth = envPtr->currStackDepth;

    if (parsePtr->numWords != 5) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * If the test expression requires substitutions, don't compile the for
     * command inline. E.g., the expression might cause the loop to never
     * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
     */

    startTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
    if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Bail out also if the body or the next expression require substitutions
     * in order to insure correct behaviour [Bug 219166]
     */

    nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
    bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
    if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) 
	    || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Create ExceptionRange records for the body and the "next" command.
     * The "next" command's ExceptionRange supports break but not continue
     * (and has a -1 continueOffset).
     */

    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =
	    TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
    bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
    nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);

    /*
     * Inline compile the initial command.
     */

    TclCompileCmdWord(interp, startTokenPtr+1,
	    startTokenPtr->numComponents, envPtr);
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "for start cond next body" produces then:
     *       start
     *       goto A
     *    B: body                : bodyCodeOffset
     *       next                : nextCodeOffset, continueOffset
     *    A: cond -> result      : testCodeOffset
     *       if (result) goto B
     */

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    TclCompileCmdWord(interp, bodyTokenPtr+1,
	    bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
    TclEmitOpcode(INST_POP, envPtr);


    /*
     * Compile the "next" subcommand.
     */

    nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    envPtr->currStackDepth = savedStackDepth;

    TclCompileCmdWord(interp, nextTokenPtr+1,
	    nextTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    envPtr->exceptArrayPtr[nextRange].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart)
	    - nextCodeOffset;
    TclEmitOpcode(INST_POP, envPtr);
    envPtr->currStackDepth = savedStackDepth;

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the for.
     */

    testCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	bodyCodeOffset += 3;
	nextCodeOffset += 3;
	testCodeOffset += 3;
    }

    envPtr->currStackDepth = savedStackDepth;
    TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
    if (jumpDist > 127) {
	TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
    } else {
	TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
    }

    /*
     * Set the loop's offsets and break target.

     */

    envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
    envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;

    envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;

    envPtr->exceptArrayPtr[bodyRange].breakOffset =
            envPtr->exceptArrayPtr[nextRange].breakOffset =
	    (envPtr->codeNext - envPtr->codeStart);

    /*
     * The for command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);

    envPtr->exceptDepth--;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileForeachCmd --
 *
 *	Procedure called to compile the "foreach" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "foreach" command
 *	at runtime.
 *
n*----------------------------------------------------------------------
 */

int
TclCompileForeachCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */







|
|
|










|
|


|
|







|
|







|




|




|



|
|
|
|
|


|
<





|
|
|



|
<
<
<
<
|
<
<








|
>
|
|
|
|
|
|
>
|
<
<
<
|
|
|
|
<
<
<

















|
|


|
|







|
|



|


















|
|


|
|












|

|



|
|

|
|



|
|
<


|
|



|
|


|
|
<
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|

|

|
|
|
<
<




|
|


<
<
<
|



|
|
|
|
<
|
|



|
|
>


|
|

>

<
<
<



|
|
>
>
>
>


>
|
>
>
>
>
>
>
>
>
>
>
|
|
|
|
>
>



|





|
>
>



|
|
|
>
>

>
>
>
>
>
>
>
|
|
|
|
|
|
>



<

|
|




|
















|
|


|
|
















|













>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|


|
|














|


|
<
|











|
|


|
|

















|








|
<
|

|







|
|
|

|



|
|
|


<
<
<
|






|
<




















|
|
|
<

<
<







<
<

>
|
|

<
<
<








|












|







|
>







|
|
<






|













|
|


|
|







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

180
181
182
183
184
185
186
187
188
189
190
191




192


193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210



211
212
213
214



215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302

303
304
305
306
307
308
309
310
311
312
313
314
315

316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344


345
346
347
348
349
350
351
352



353
354
355
356
357
358
359
360

361
362
363
364
365
366
367
368
369
370
371
372
373
374
375



376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442

443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087

1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110



1111
1112
1113
1114
1115
1116
1117
1118

1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141

1142


1143
1144
1145
1146
1147
1148
1149


1150
1151
1152
1153
1154



1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194

1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */

/*
 * The structures below define the AuxData types defined in this file.
 */

AuxDataType tclForeachInfoType = {
    "ForeachInfo",		/* name */
    DupForeachInfo,		/* dupProc */
    FreeForeachInfo		/* freeProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclCompileAppendCmd --
 *
 *	Procedure called to compile the "append" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "append" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileAppendCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int simpleVarName, isScalar, localIndex, numWords;

    numWords = parsePtr->numWords;
    if (numWords == 1) {
	return TCL_ERROR;
    } else if (numWords == 2) {
	/*
	 * append varName == set varName
	 */
	return TclCompileSetCmd(interp, parsePtr, envPtr);
    } else if (numWords > 3) {
	/*
	 * APPEND instructions currently only handle one value
	 */
	return TCL_ERROR;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we need
     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);


    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * We are doing an assignment, otherwise TclCompileSetCmd was called, so
     * push the new value.  This will need to be extended to push a value for
     * each argument.
     */

    if (numWords > 2) {
	valueTokenPtr = TokenAfter(varTokenPtr);




	CompileWord(envPtr, valueTokenPtr, interp);


    }

    /*
     * Emit instructions to set/get the variable.
     */

    if (simpleVarName) {
	if (isScalar) {
	    if (localIndex < 0) {
		TclEmitOpcode(INST_APPEND_STK, envPtr);
	    } else if (localIndex <= 255) {
		TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
	    } else {
		TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
	    }
	} else {
	    if (localIndex < 0) {
		TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);



	    } else if (localIndex <= 255) {
		TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
	    } else {
		TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);



	    }
	}
    } else {
	TclEmitOpcode(INST_APPEND_STK, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileBreakCmd --
 *
 *	Procedure called to compile the "break" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "break" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileBreakCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    if (parsePtr->numWords != 1) {
	return TCL_ERROR;
    }

    /*
     * Emit a break instruction.
     */

    TclEmitOpcode(INST_BREAK, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCatchCmd --
 *
 *	Procedure called to compile the "catch" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "catch" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileCatchCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    JumpFixup jumpFixup;
    Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
    CONST char *name;
    int resultIndex, optsIndex, nameChars, range;
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * If syntax does not match what we expect for [catch], do not compile.
     * Let runtime checks determine if syntax has changed.
     */
    if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) {
	return TCL_ERROR;
    }

    /*
     * If variables were specified and the catch command is at global level
     * (not in a procedure), don't compile it inline: the payoff is too small.

     */

    if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) {
	return TCL_ERROR;
    }

    /*
     * Make sure the variable names, if any, have no substitutions and just
     * refer to local scalars.
     */

    resultIndex = optsIndex = -1;
    cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);

    if (parsePtr->numWords >= 3) {
	resultNameTokenPtr = TokenAfter(cmdTokenPtr);
	/* DGP */
	if (resultNameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    name = resultNameTokenPtr[1].start;
	    nameChars = resultNameTokenPtr[1].size;
	    if (!TclIsLocalScalar(name, nameChars)) {
		return TCL_ERROR;
	    }
	    resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
		    resultNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR,
		    envPtr->procPtr);
	} else {
	   return TCL_ERROR;
	}
	/* DKF */
	if (parsePtr->numWords == 4) {
	    optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
	    if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		return TCL_ERROR;
	    }
	    name = optsNameTokenPtr[1].start;
	    nameChars = optsNameTokenPtr[1].size;
	    if (!TclIsLocalScalar(name, nameChars)) {
		return TCL_ERROR;
	    }
	    optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
		    optsNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR,
		    envPtr->procPtr);


	}
    }

    /*
     * We will compile the catch command. Emit a beginCatch instruction at the
     * start of the catch body: the subcommand it controls.
     */




    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
    TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);

    /*
     * If the body is a simple word, compile the instructions to eval it.
     * Otherwise, compile instructions to substitute its text without
     * catching, a catch instruction that resets the stack to what it was
     * before substituting the body, and then an instruction to eval the body.

     * Care has to be taken to register the correct startOffset for the catch
     * range so that errors in the substitution are not catched [Bug 219184]
     */

    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	ExceptionRangeStarts(envPtr, range);
	CompileBody(envPtr, cmdTokenPtr, interp);
	ExceptionRangeEnds(envPtr, range);
    } else {
	TclCompileTokens(interp, cmdTokenPtr+1,
		cmdTokenPtr->numComponents, envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(INST_EVAL_STK, envPtr);
	ExceptionRangeEnds(envPtr, range);
    }




    /*
     * The "no errors" epilogue code: store the body's result into the
     * variable (if any), push "0" (TCL_OK) as the catch's "no error" result,
     * and jump around the "error case" code. Note that we issue the push of
     * the return options first so that if alterations happen to the current
     * interpreter state during the writing of the variable, we won't see
     * them; this results in a slightly complex instruction issuing flow
     * (can't exchange, only duplicate and pop).
     */

    if (resultIndex != -1) {
	if (optsIndex != -1) {
	    TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
	    TclEmitInstInt4(INST_OVER, 1, envPtr);
	}
	if (resultIndex <= 255) {
	    TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
	} else {
	    TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
	}
	if (optsIndex != -1) {
	    TclEmitOpcode(INST_POP, envPtr);
	    if (optsIndex <= 255) {
		TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
	    } else {
		TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
	    }
	    TclEmitOpcode(INST_POP, envPtr);
	}
    }
    TclEmitOpcode(INST_POP, envPtr);
    PushLiteral(envPtr, "0", 1);
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * The "error case" code: store the body's result into the variable (if
     * any), then push the error result code. The initial PC offset here is
     * the catch's error target. Note that if we are saving the return
     * options, we do that first so the preservation cannot get affected by
     * any intermediate result handling.
     */

    envPtr->currStackDepth = savedStackDepth;
    ExceptionRangeTarget(envPtr, range, catchOffset);
    if (resultIndex != -1) {
	if (optsIndex != -1) {
	    TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
	}
	TclEmitOpcode(INST_PUSH_RESULT, envPtr);
	if (resultIndex <= 255) {
	    TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
	} else {
	    TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
	}
	TclEmitOpcode(INST_POP, envPtr);
	if (optsIndex != -1) {
	    if (optsIndex <= 255) {
		TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
	    } else {
		TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
	    }
	    TclEmitOpcode(INST_POP, envPtr);
	}
    }
    TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);


    /*
     * Update the target of the jump after the "no errors" code, then emit an
     * endCatch instruction at the end of the catch command.
     */

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileCatchCmd: bad jump distance %d\n",
		CurrentOffset(envPtr) - jumpFixup.codeOffset);
    }
    TclEmitOpcode(INST_END_CATCH, envPtr);

    envPtr->currStackDepth = savedStackDepth + 1;
    envPtr->exceptDepth--;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileContinueCmd --
 *
 *	Procedure called to compile the "continue" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "continue" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileContinueCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * There should be no argument after the "continue".
     */

    if (parsePtr->numWords != 1) {
	return TCL_ERROR;
    }

    /*
     * Emit a continue instruction.
     */

    TclEmitOpcode(INST_CONTINUE, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileDictCmd --
 *
 *	Procedure called to compile the "dict" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "dict" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileDictCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int numWords, size, i;
    const char *cmd;
    Proc *procPtr = envPtr->procPtr;

    /*
     * There must be at least one argument after the command.
     */

    if (parsePtr->numWords < 2) {
	return TCL_ERROR;
    }

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    numWords = parsePtr->numWords-2;
    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_ERROR;
    }

    /*
     * The following commands are in fairly common use and are possibly worth
     * bytecoding:
     *     dict append
     *     dict create	[*]
     *     dict exists	[*]
     *     dict for
     *     dict get	[*]
     *     dict incr
     *     dict keys	[*]
     *     dict lappend
     *     dict set
     *     dict unset
     * In practice, those that are pure-value operators (marked with [*]) can
     * probably be left alone (except perhaps [dict get] which is very very
     * common) and [dict update] should be considered instead (really big
     * win!)
     */

    size = tokenPtr[1].size;
    cmd = tokenPtr[1].start;
    if (size==3 && strncmp(cmd, "set", 3)==0) {
	Tcl_Token *varTokenPtr;
	int dictVarIndex, nameChars;
	const char *name;

	if (numWords < 3 || procPtr == NULL) {
	    return TCL_ERROR;
	}
	varTokenPtr = TokenAfter(tokenPtr);
	tokenPtr = TokenAfter(varTokenPtr);
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
	name = varTokenPtr[1].start;
	nameChars = varTokenPtr[1].size;
	if (!TclIsLocalScalar(name, nameChars)) {
	    return TCL_ERROR;
	}
	dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
		procPtr);
	for (i=1 ; i<numWords ; i++) {
	    CompileWord(envPtr, tokenPtr, interp);
	    tokenPtr = TokenAfter(tokenPtr);
	}
	TclEmitInstInt4( INST_DICT_SET, numWords-2,		envPtr);
	TclEmitInt4(	 dictVarIndex,				envPtr);
	return TCL_OK;
    } else if (size==4 && strncmp(cmd, "incr", 4)==0) {
	Tcl_Token *varTokenPtr, *keyTokenPtr, *incrTokenPtr = NULL;
	int dictVarIndex, nameChars, incrAmount = 1;
	const char *name;

	if (numWords < 2 || numWords > 3 || procPtr == NULL) {
	    return TCL_ERROR;
	}
	varTokenPtr = TokenAfter(tokenPtr);
	keyTokenPtr = TokenAfter(varTokenPtr);
	if (numWords == 3) {
	    const char *word;
	    int numBytes, code;
	    Tcl_Obj *intObj;

	    incrTokenPtr = TokenAfter(keyTokenPtr);
	    if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		return TCL_ERROR;
	    }
	    word = incrTokenPtr[1].start;
	    numBytes = incrTokenPtr[1].size;

#if 0
	    /*
	     * Note there is a danger that modifying the string could have
	     * undesirable side effects.  In this case, TclLooksLikeInt has no
	     * dependencies on shared strings so we should be safe.
	     */

	    if (!TclLooksLikeInt(word, numBytes)) {
		return TCL_ERROR;
	    }
#endif

	    /*
	     * Now try to really parse the number.
	     */

	    intObj = Tcl_NewStringObj(word, numBytes);
	    Tcl_IncrRefCount(intObj);
	    code = Tcl_GetIntFromObj(NULL, intObj, &incrAmount);
	    Tcl_DecrRefCount(intObj);
	    if (code != TCL_OK) {
		return TCL_ERROR;
	    }
	}
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
	name = varTokenPtr[1].start;
	nameChars = varTokenPtr[1].size;
	if (!TclIsLocalScalar(name, nameChars)) {
	    return TCL_ERROR;
	}
	dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
		procPtr);
	CompileWord(envPtr, keyTokenPtr, interp);
	TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount,	envPtr);
	TclEmitInt4(	 dictVarIndex,				envPtr);
	return TCL_OK;
    } else if (size==3 && strncmp(cmd, "get", 3)==0) {
	/*
	 * Only compile this because we need INST_DICT_GET anyway.
	 */
	if (numWords < 2) {
	    return TCL_ERROR;
	}
	for (i=0 ; i<numWords ; i++) {
	    tokenPtr = TokenAfter(tokenPtr);
	    CompileWord(envPtr, tokenPtr, interp);
	}
	TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
	return TCL_OK;
    } else if (size==3 && strncmp(cmd, "for", 3)==0) {
	Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
	int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
	int infoIndex, jumpDisplacement, bodyTargetOffset, doneTargetOffset;
	int endTargetOffset;
	const char **argv;
	Tcl_DString buffer;
	int savedStackDepth = envPtr->currStackDepth;

	if (numWords != 3 || procPtr == NULL) {
	    return TCL_ERROR;
	}

	varsTokenPtr = TokenAfter(tokenPtr);
	dictTokenPtr = TokenAfter(varsTokenPtr);
	bodyTokenPtr = TokenAfter(dictTokenPtr);
	if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
		bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}

	/*
	 * Check we've got a pair of variables and that they are local
	 * variables. Then extract their indices in the LVT.
	 */

	Tcl_DStringInit(&buffer);
	Tcl_DStringAppend(&buffer, varsTokenPtr[1].start,
		varsTokenPtr[1].size);
	if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numWords,
		&argv) != TCL_OK) {
	    Tcl_DStringFree(&buffer);
	    return TCL_ERROR;
	}
	Tcl_DStringFree(&buffer);
	if (numWords != 2) {
	    ckfree((char *) argv);
	    return TCL_ERROR;
	}
	nameChars = strlen(argv[0]);
	if (!TclIsLocalScalar(argv[0], nameChars)) {
	    ckfree((char *) argv);
	    return TCL_ERROR;
	}
	keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, VAR_SCALAR,
		procPtr);
	nameChars = strlen(argv[1]);
	if (!TclIsLocalScalar(argv[1], nameChars)) {
	    ckfree((char *) argv);
	    return TCL_ERROR;
	}
	valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, VAR_SCALAR,
		procPtr);
	ckfree((char *) argv);

	/*
	 * Allocate a temporary variable to store the iterator reference. The
	 * variable will contain a Tcl_DictSearch reference which will be
	 * allocated by INST_DICT_FIRST and disposed when the variable is
	 * unset (at which point it should also have been finished with).
	 */

	infoIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);

	/*
	 * Preparation complete; issue instructions. Note that this code
	 * issues fixed-sized jumps. That simplifies things a lot!
	 *
	 * First up, get the dictionary and start the iteration. No catching
	 * of errors at this point.
	 */

	CompileWord(envPtr, dictTokenPtr, interp);
	TclEmitInstInt4( INST_DICT_FIRST, infoIndex,		envPtr);
	doneTargetOffset = CurrentOffset(envPtr);
	TclEmitInstInt4( INST_JUMP_TRUE4, 0,			envPtr);

	/*
	 * Now we catch errors from here on so that we can finalize the search
	 * started by Tcl_DictObjFirst above.
	 */

	catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
	TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange,		envPtr);
	ExceptionRangeStarts(envPtr, catchRange);

	/*
	 * Inside the iteration, write the loop variables.
	 */

	bodyTargetOffset = CurrentOffset(envPtr);
	TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex,	envPtr);
	TclEmitOpcode(   INST_POP,				envPtr);
	TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex,	envPtr);
	TclEmitOpcode(   INST_POP,				envPtr);

	/*
	 * Set up the loop exception targets.
	 */

	loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
	ExceptionRangeStarts(envPtr, loopRange);

	/*
	 * Compile the loop body itself. It should be stack-neutral.
	 */

	CompileBody(envPtr, bodyTokenPtr, interp);
	envPtr->currStackDepth = savedStackDepth + 1;
	TclEmitOpcode(   INST_POP,				envPtr);
	envPtr->currStackDepth = savedStackDepth;

	/*
	 * Both exception target ranges (error and loop) end here.
	 */

	ExceptionRangeEnds(envPtr, loopRange);
	ExceptionRangeEnds(envPtr, catchRange);

	/*
	 * Continue (or just normally process) by getting the next pair of
	 * items from the dictionary and jumping back to the code to write
	 * them into variables if there is another pair.
	 */

	ExceptionRangeTarget(envPtr, loopRange, continueOffset);
	TclEmitInstInt4( INST_DICT_NEXT, infoIndex,		envPtr);
	jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
	TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement,	envPtr);

	/*
	 * Otherwise we're done (the jump after the DICT_FIRST points here)
	 * and we need to pop the bogus key/value pair (pushed to keep stack
	 * calculations easy!)
	 */

	jumpDisplacement = CurrentOffset(envPtr) - doneTargetOffset;
	TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
		envPtr->codeStart + doneTargetOffset);
	TclEmitOpcode(   INST_POP,				envPtr);
	TclEmitOpcode(   INST_POP,				envPtr);

	/*
	 * Now do the final cleanup for the no-error case (this is where we
	 * break out of the loop to) by force-terminating the iteration (if
	 * not already terminated), ditching the exception info and jumping to
	 * the last instruction for this command. In theory, this could be
	 * done using the "finally" clause (next generated) but this is
	 * faster.
	 */

	ExceptionRangeTarget(envPtr, loopRange, breakOffset);
	TclEmitInstInt4( INST_DICT_DONE, infoIndex,		envPtr);
	TclEmitOpcode(	 INST_END_CATCH,			envPtr);
	endTargetOffset = CurrentOffset(envPtr);
	TclEmitInstInt4( INST_JUMP4, 0,				envPtr);

	/*
	 * Error handler "finally" clause, which force-terminates the
	 * iteration and rethrows the error.
	 */

	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
	TclEmitOpcode(   INST_PUSH_RETURN_OPTIONS,		envPtr);
	TclEmitOpcode(   INST_PUSH_RESULT,			envPtr);
	TclEmitInstInt4( INST_DICT_DONE, infoIndex,		envPtr);
	TclEmitOpcode(   INST_END_CATCH,			envPtr);
	TclEmitOpcode(   INST_RETURN_STK,			envPtr);

	/*
	 * Final stage of the command (normal case) is that we push an empty
	 * object. This is done last to promote peephole optimization when
	 * it's dropped immediately.
	 */

	jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
	TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
		envPtr->codeStart + endTargetOffset);
	PushLiteral(envPtr, "", 0);
	envPtr->exceptDepth -= 2;
	return TCL_OK;
    } else if (size==6 && strncmp(cmd, "update", 6)==0) {
	const char *name;
	int nameChars, dictIndex, keyTmpIndex, numVars, range;
	Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr;
	Tcl_DString localVarsLiteral;

	/*
	 * Parse the command. Expect the following:
	 *   dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit>
	 */

	if (numWords < 4 || numWords & 1 || procPtr == NULL) {
	    return TCL_ERROR;
	}
	numVars = numWords/2 - 1;
	dictVarTokenPtr = TokenAfter(tokenPtr);
	if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
	name = dictVarTokenPtr[1].start;
	nameChars = dictVarTokenPtr[1].size;
	if (!TclIsLocalScalar(name, nameChars)) {
	    return TCL_ERROR;
	}
	dictIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
		procPtr);

	Tcl_DStringInit(&localVarsLiteral);
	keyTokenPtrs = (Tcl_Token **) ckalloc(sizeof(Tcl_Token*) * numVars);
	tokenPtr = TokenAfter(dictVarTokenPtr);
	for (i=0 ; i<numVars ; i++) {
	    keyTokenPtrs[i] = tokenPtr;
	    tokenPtr = TokenAfter(tokenPtr);
	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		Tcl_DStringFree(&localVarsLiteral);
		ckfree((char *) keyTokenPtrs);
		return TCL_ERROR;
	    }
	    name = tokenPtr[1].start;
	    nameChars = tokenPtr[1].size;
	    if (!TclIsLocalScalar(name, nameChars)) {
		Tcl_DStringFree(&localVarsLiteral);
		ckfree((char *) keyTokenPtrs);
		return TCL_ERROR;
	    } else {
		int localVar = TclFindCompiledLocal(name, nameChars, 1,
			VAR_SCALAR, procPtr);
		char buf[12];

		sprintf(buf, "%d", localVar);
		Tcl_DStringAppendElement(&localVarsLiteral, buf);
	    }
	    tokenPtr = TokenAfter(tokenPtr);
	}
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    Tcl_DStringFree(&localVarsLiteral);
	    ckfree((char *) keyTokenPtrs);
	    return TCL_ERROR;
	}
	bodyTokenPtr = tokenPtr;

	keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);

	for (i=0 ; i<numVars ; i++) {
	    CompileWord(envPtr, keyTokenPtrs[i], interp);
	}
	TclEmitInstInt4( INST_LIST, numVars,			envPtr);
	TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex,	envPtr);
	PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral),
		Tcl_DStringLength(&localVarsLiteral));
	TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex,	envPtr);

	range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
	TclEmitInstInt4( INST_BEGIN_CATCH4, range,		envPtr);

	ExceptionRangeStarts(envPtr, range);
	CompileBody(envPtr, bodyTokenPtr, interp);
	ExceptionRangeEnds(envPtr, range);

	ExceptionRangeTarget(envPtr, range, catchOffset);
	TclEmitOpcode(   INST_PUSH_RETURN_OPTIONS,		envPtr);
	TclEmitOpcode(   INST_PUSH_RESULT,			envPtr);
	TclEmitOpcode(   INST_END_CATCH,			envPtr);
	envPtr->exceptDepth--;

	TclEmitInstInt4( INST_LOAD_SCALAR4, keyTmpIndex,	envPtr);
	PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral),
		Tcl_DStringLength(&localVarsLiteral));
	/*
	 * Any literal would do, but this one is handy...
	 */
	TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex,	envPtr);
	TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex,	envPtr);

	TclEmitOpcode(   INST_RETURN_STK,			envPtr);

	Tcl_DStringFree(&localVarsLiteral);
	ckfree((char *) keyTokenPtrs);
	return TCL_OK;
    } else if (size==6 && strncmp(cmd, "append", 6) == 0) {
	Tcl_Token *varTokenPtr;
	int dictVarIndex, nameChars;
	const char *name;

	/*
	 * Arbirary safe limit; anyone exceeding it should stop worrying about
	 * speed quite so much. ;-)
	 */
	if (numWords < 3 || numWords > 100 || procPtr == NULL) {
	    return TCL_ERROR;
	}
	varTokenPtr = TokenAfter(tokenPtr);
	tokenPtr = TokenAfter(varTokenPtr);
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
	name = varTokenPtr[1].start;
	nameChars = varTokenPtr[1].size;
	if (!TclIsLocalScalar(name, nameChars)) {
	    return TCL_ERROR;
	}
	dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
		procPtr);
	for (i=1 ; i<numWords ; i++) {
	    CompileWord(envPtr, tokenPtr, interp);
	    tokenPtr = TokenAfter(tokenPtr);
	}
	if (numWords > 3) {
	    TclEmitInstInt1( INST_CONCAT1, numWords-2,		envPtr);
	}
	TclEmitInstInt4( INST_DICT_APPEND, dictVarIndex,	envPtr);
	return TCL_OK;
    } else if (size==7 && strncmp(cmd, "lappend", 7) == 0) {
	Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
	int dictVarIndex, nameChars;
	const char *name;

	if (numWords != 3 || procPtr == NULL) {
	    return TCL_ERROR;
	}
	varTokenPtr = TokenAfter(tokenPtr);
	keyTokenPtr = TokenAfter(varTokenPtr);
	valueTokenPtr = TokenAfter(keyTokenPtr);
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
	name = varTokenPtr[1].start;
	nameChars = varTokenPtr[1].size;
	if (!TclIsLocalScalar(name, nameChars)) {
	    return TCL_ERROR;
	}
	dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
		procPtr);
	CompileWord(envPtr, keyTokenPtr, interp);
	CompileWord(envPtr, valueTokenPtr, interp);
	TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex,	envPtr);
	return TCL_OK;
    }

    /*
     * Something we do not know how to compile.
     */
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileExprCmd --
 *
 *	Procedure called to compile the "expr" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "expr" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileExprCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *firstWordPtr;

    if (parsePtr->numWords == 1) {
	return TCL_ERROR;
    }

    firstWordPtr = TokenAfter(parsePtr->tokenPtr);

    TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileForCmd --
 *
 *	Procedure called to compile the "for" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "for" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */
int
TclCompileForCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
    int bodyRange, nextRange;
    int savedStackDepth = envPtr->currStackDepth;

    if (parsePtr->numWords != 5) {
	return TCL_ERROR;
    }

    /*
     * If the test expression requires substitutions, don't compile the for
     * command inline. E.g., the expression might cause the loop to never
     * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
     */

    startTokenPtr = TokenAfter(parsePtr->tokenPtr);

    testTokenPtr = TokenAfter(startTokenPtr);
    if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_ERROR;
    }

    /*
     * Bail out also if the body or the next expression require substitutions
     * in order to insure correct behaviour [Bug 219166]
     */

    nextTokenPtr = TokenAfter(testTokenPtr);
    bodyTokenPtr = TokenAfter(nextTokenPtr);
    if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
	    || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
	return TCL_ERROR;
    }

    /*
     * Create ExceptionRange records for the body and the "next" command. The
     * "next" command's ExceptionRange supports break but not continue (and
     * has a -1 continueOffset).
     */




    bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
    nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);

    /*
     * Inline compile the initial command.
     */

    CompileBody(envPtr, startTokenPtr, interp);

    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "for start cond next body" produces then:
     *       start
     *       goto A
     *    B: body                : bodyCodeOffset
     *       next                : nextCodeOffset, continueOffset
     *    A: cond -> result      : testCodeOffset
     *       if (result) goto B
     */

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
    CompileBody(envPtr, bodyTokenPtr, interp);
    ExceptionRangeEnds(envPtr, bodyRange);

    envPtr->currStackDepth = savedStackDepth + 1;


    TclEmitOpcode(INST_POP, envPtr);


    /*
     * Compile the "next" subcommand.
     */



    envPtr->currStackDepth = savedStackDepth;
    nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
    CompileBody(envPtr, nextTokenPtr, interp);
    ExceptionRangeEnds(envPtr, nextRange);
    envPtr->currStackDepth = savedStackDepth + 1;



    TclEmitOpcode(INST_POP, envPtr);
    envPtr->currStackDepth = savedStackDepth;

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the for.
     */

    testCodeOffset = CurrentOffset(envPtr);

    jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	bodyCodeOffset += 3;
	nextCodeOffset += 3;
	testCodeOffset += 3;
    }

    envPtr->currStackDepth = savedStackDepth;
    TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
    if (jumpDist > 127) {
	TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
    } else {
	TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
    }

    /*
     * Fix the starting points of the exception ranges (may have moved due to
     * jump type modification) and set where the exceptions target.
     */

    envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
    envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;

    envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;

    ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
    ExceptionRangeTarget(envPtr, nextRange, breakOffset);


    /*
     * The for command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    PushLiteral(envPtr, "", 0);

    envPtr->exceptDepth--;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileForeachCmd --
 *
 *	Procedure called to compile the "foreach" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "foreach" command at
 *	runtime.
 *
n*----------------------------------------------------------------------
 */

int
TclCompileForeachCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711


712
713


714
715
716

717

718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793






794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810

    /*
     * If the foreach command isn't in a procedure, don't compile it inline:
     * the payoff is too small.
     */

    if (procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

    numWords = parsePtr->numWords;
    if ((numWords < 4) || (numWords%2 != 0)) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Bail out if the body requires substitutions
     * in order to insure correct behaviour [Bug 219166]
     */
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr += (tokenPtr->numComponents + 1)) {
    }
    bodyTokenPtr = tokenPtr;
    if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Allocate storage for the varcList and varvList arrays if necessary.
     */

    numLists = (numWords - 2)/2;
    if (numLists > STATIC_VAR_LIST_SIZE) {
        varcList = (int *) ckalloc(numLists * sizeof(int));
        varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
    }
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
        varcList[loopIndex] = 0;
        varvList[loopIndex] = NULL;
    }

    /*
     * Set the exception stack depth.
     */ 

    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =
	    TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);

    /*
     * Break up each var list and set the varcList and varvList arrays.
     * Don't compile the foreach inline if any var name needs substitutions
     * or isn't a scalar, or if any var list needs substitutions.
     */

    loopIndex = 0;
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;


	    i++, tokenPtr += (tokenPtr->numComponents + 1)) {
	if (i%2 == 1) {


	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		code = TCL_OUT_LINE_COMPILE;
		goto done;

	    } else {

		/* Lots of copying going on here.  Need a ListObj wizard
		 * to show a better way. */

		Tcl_DString varList;

		Tcl_DStringInit(&varList);
		Tcl_DStringAppend(&varList, tokenPtr[1].start,
			tokenPtr[1].size);
		code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
			&varcList[loopIndex], &varvList[loopIndex]);
		Tcl_DStringFree(&varList);
		if (code != TCL_OK) {
		    code = TCL_OUT_LINE_COMPILE;
		    goto done;
		}
		numVars = varcList[loopIndex];
		for (j = 0;  j < numVars;  j++) {
		    CONST char *varName = varvList[loopIndex][j];
		    if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
			code = TCL_OUT_LINE_COMPILE;
			goto done;
		    }
		}
	    }
	    loopIndex++;
	}
    }

    /*
     * We will compile the foreach command.
     * Reserve (numLists + 1) temporary variables:
     *    - numLists temps to hold each value list
     *    - 1 temp for the loop counter (index of next element in each list)

     * At this time we don't try to reuse temporaries; if there are two
     * nonoverlapping foreach loops, they don't share any temps.
     */

    code = TCL_OK;
    firstValueTemp = -1;
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
		/*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
	if (loopIndex == 0) {
	    firstValueTemp = tempVar;
	}
    }
    loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
	    /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);

    /*
     * Create and initialize the ForeachInfo and ForeachVarList data
     * structures describing this command. Then create a AuxData record
     * pointing to the ForeachInfo structure.
     */

    infoPtr = (ForeachInfo *) ckalloc((unsigned)
	    (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
    infoPtr->numLists = numLists;
    infoPtr->firstValueTemp = firstValueTemp;
    infoPtr->loopCtTemp = loopCtTemp;
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	ForeachVarList *varListPtr;
	numVars = varcList[loopIndex];
	varListPtr = (ForeachVarList *) ckalloc((unsigned)
	        sizeof(ForeachVarList) + (numVars * sizeof(int)));
	varListPtr->numVars = numVars;
	for (j = 0;  j < numVars;  j++) {
	    CONST char *varName = varvList[loopIndex][j];
	    int nameChars = strlen(varName);
	    varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
		    nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
	}
	infoPtr->varLists[loopIndex] = varListPtr;
    }
    infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);







    /*
     * Evaluate then store each value list in the associated temporary.
     */

    range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);

    loopIndex = 0;
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr += (tokenPtr->numComponents + 1)) {
	if ((i%2 == 0) && (i > 0)) {
	    TclCompileTokens(interp, tokenPtr+1,
		    tokenPtr->numComponents, envPtr);

	    tempVar = (firstValueTemp + loopIndex);
	    if (tempVar <= 255) {
		TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);







|




|



|
|

|
<
|



|








|
|


|
|



<
<
<
<
<
<
<
<
|
|
|





>
>
|
|
>
>
|
|
|
>
|
>
|
|
|
<

|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
<

|
|


>








|





|








|







|





|





>
>
>
>
>
>




<
<



|







1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277

1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299








1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322

1323
1324
1325

1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340

1341
1342
1343

1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402


1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413

    /*
     * If the foreach command isn't in a procedure, don't compile it inline:
     * the payoff is too small.
     */

    if (procPtr == NULL) {
	return TCL_ERROR;
    }

    numWords = parsePtr->numWords;
    if ((numWords < 4) || (numWords%2 != 0)) {
	return TCL_ERROR;
    }

    /*
     * Bail out if the body requires substitutions in order to insure correct
     * behaviour [Bug 219166]
     */
    for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) {

	tokenPtr = TokenAfter(tokenPtr);
    }
    bodyTokenPtr = tokenPtr;
    if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_ERROR;
    }

    /*
     * Allocate storage for the varcList and varvList arrays if necessary.
     */

    numLists = (numWords - 2)/2;
    if (numLists > STATIC_VAR_LIST_SIZE) {
	varcList = (int *) ckalloc(numLists * sizeof(int));
	varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
    }
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	varcList[loopIndex] = 0;
	varvList[loopIndex] = NULL;
    }

    /*








     * Break up each var list and set the varcList and varvList arrays. Don't
     * compile the foreach inline if any var name needs substitutions or isn't
     * a scalar, or if any var list needs substitutions.
     */

    loopIndex = 0;
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr = TokenAfter(tokenPtr)) {
	Tcl_DString varList;

	if (i%2 != 1) {
	    continue;
	}
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    code = TCL_ERROR;
	    goto done;
	}

	/*
	 * Lots of copying going on here.  Need a ListObj wizard to show a
	 * better way.
	 */


	Tcl_DStringInit(&varList);
	Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size);

	code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
		&varcList[loopIndex], &varvList[loopIndex]);
	Tcl_DStringFree(&varList);
	if (code != TCL_OK) {
	    code = TCL_ERROR;
	    goto done;
	}
	numVars = varcList[loopIndex];
	for (j = 0;  j < numVars;  j++) {
	    CONST char *varName = varvList[loopIndex][j];
	    if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
		code = TCL_ERROR;
		goto done;
	    }
	}

	loopIndex++;
    }


    /*
     * We will compile the foreach command.  Reserve (numLists + 1) temporary
     * variables:
     *    - numLists temps to hold each value list
     *    - 1 temp for the loop counter (index of next element in each list)
     *
     * At this time we don't try to reuse temporaries; if there are two
     * nonoverlapping foreach loops, they don't share any temps.
     */

    code = TCL_OK;
    firstValueTemp = -1;
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
		/*create*/ 1, VAR_SCALAR, procPtr);
	if (loopIndex == 0) {
	    firstValueTemp = tempVar;
	}
    }
    loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
	    /*create*/ 1, VAR_SCALAR, procPtr);

    /*
     * Create and initialize the ForeachInfo and ForeachVarList data
     * structures describing this command. Then create a AuxData record
     * pointing to the ForeachInfo structure.
     */

    infoPtr = (ForeachInfo *) ckalloc((unsigned)
	    sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
    infoPtr->numLists = numLists;
    infoPtr->firstValueTemp = firstValueTemp;
    infoPtr->loopCtTemp = loopCtTemp;
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	ForeachVarList *varListPtr;
	numVars = varcList[loopIndex];
	varListPtr = (ForeachVarList *) ckalloc((unsigned)
		sizeof(ForeachVarList) + numVars*sizeof(int));
	varListPtr->numVars = numVars;
	for (j = 0;  j < numVars;  j++) {
	    CONST char *varName = varvList[loopIndex][j];
	    int nameChars = strlen(varName);
	    varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
		    nameChars, /*create*/ 1, VAR_SCALAR, procPtr);
	}
	infoPtr->varLists[loopIndex] = varListPtr;
    }
    infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);

    /*
     * Create an exception record to handle [break] and [continue].
     */

    range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);

    /*
     * Evaluate then store each value list in the associated temporary.
     */



    loopIndex = 0;
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr = TokenAfter(tokenPtr)) {
	if ((i%2 == 0) && (i > 0)) {
	    TclCompileTokens(interp, tokenPtr+1,
		    tokenPtr->numComponents, envPtr);

	    tempVar = (firstValueTemp + loopIndex);
	    if (tempVar <= 255) {
		TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
    TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);

    /*
     * Top of loop code: assign each loop variable and check whether
     * to terminate the loop.
     */

    envPtr->exceptArrayPtr[range].continueOffset =
	    (envPtr->codeNext - envPtr->codeStart);
    TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);

    /*
     * Inline compile the loop body.
     */

    envPtr->exceptArrayPtr[range].codeOffset =
	    (envPtr->codeNext - envPtr->codeStart);
    TclCompileCmdWord(interp, bodyTokenPtr+1,
	    bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    envPtr->exceptArrayPtr[range].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart)
	    - envPtr->exceptArrayPtr[range].codeOffset;
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Jump back to the test at the top of the loop. Generate a 4 byte jump
     * if the distance to the test is > 120 bytes. This is conservative and
     * ensures that we won't have to replace this jump if we later need to
     * replace the ifFalse jump with a 4 byte jump.
     */

    jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
    jumpBackDist =
	(jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
    if (jumpBackDist > 120) {
	TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
    } else {
	TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
    }

    /*







|
<







<
|
|
|

<
<
<



|
|




<
|
|







1426
1427
1428
1429
1430
1431
1432
1433

1434
1435
1436
1437
1438
1439
1440

1441
1442
1443
1444



1445
1446
1447
1448
1449
1450
1451
1452
1453

1454
1455
1456
1457
1458
1459
1460
1461
1462
    TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);

    /*
     * Top of loop code: assign each loop variable and check whether
     * to terminate the loop.
     */

    ExceptionRangeTarget(envPtr, range, continueOffset);

    TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);

    /*
     * Inline compile the loop body.
     */


    ExceptionRangeStarts(envPtr, range);
    CompileBody(envPtr, bodyTokenPtr, interp);
    ExceptionRangeEnds(envPtr, range);
    envPtr->currStackDepth = savedStackDepth + 1;



    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Jump back to the test at the top of the loop. Generate a 4 byte jump if
     * the distance to the test is > 120 bytes. This is conservative and
     * ensures that we won't have to replace this jump if we later need to
     * replace the ifFalse jump with a 4 byte jump.
     */


    jumpBackOffset = CurrentOffset(envPtr);
    jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset;
    if (jumpBackDist > 120) {
	TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
    } else {
	TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
    }

    /*
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
	}
    }

    /*
     * Set the loop's break target.
     */

    envPtr->exceptArrayPtr[range].breakOffset =
	    (envPtr->codeNext - envPtr->codeStart);

    /*
     * The foreach command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    done:
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	if (varvList[loopIndex] != (CONST char **) NULL) {
	    ckfree((char *) varvList[loopIndex]);
	}
    }
    if (varcList != varcListStaticSpace) {
	ckfree((char *) varcList);
        ckfree((char *) varvList);
    }
    envPtr->exceptDepth--;
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * DupForeachInfo --
 *
 *	This procedure duplicates a ForeachInfo structure created as
 *	auxiliary data during the compilation of a foreach command.
 *
 * Results:
 *	A pointer to a newly allocated copy of the existing ForeachInfo
 *	structure is returned.
 *
 * Side effects:
 *	Storage for the copied ForeachInfo record is allocated. If the
 *	original ForeachInfo structure pointed to any ForeachVarList
 *	records, these structures are also copied and pointers to them
 *	are stored in the new ForeachInfo record.
 *
 *----------------------------------------------------------------------
 */

static ClientData
DupForeachInfo(clientData)
    ClientData clientData;	/* The foreach command's compilation
				 * auxiliary data to duplicate. */
{
    register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
    ForeachInfo *dupPtr;
    register ForeachVarList *srcListPtr, *dupListPtr;
    int numLists = srcPtr->numLists;
    int numVars, i, j;

    dupPtr = (ForeachInfo *) ckalloc((unsigned)
	    (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
    dupPtr->numLists = numLists;
    dupPtr->firstValueTemp = srcPtr->firstValueTemp;
    dupPtr->loopCtTemp = srcPtr->loopCtTemp;

    for (i = 0;  i < numLists;  i++) {
	srcListPtr = srcPtr->varLists[i];
	numVars = srcListPtr->numVars;
	dupListPtr = (ForeachVarList *) ckalloc((unsigned)
	        sizeof(ForeachVarList) + numVars*sizeof(int));
	dupListPtr->numVars = numVars;
	for (j = 0;  j < numVars;  j++) {
	    dupListPtr->varIndexes[j] =	srcListPtr->varIndexes[j];
	}
	dupPtr->varLists[i] = dupListPtr;
    }
    return (ClientData) dupPtr;







|
<






|


|







|










|
|







|
|
|
















|








|







1485
1486
1487
1488
1489
1490
1491
1492

1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
	}
    }

    /*
     * Set the loop's break target.
     */

    ExceptionRangeTarget(envPtr, range, breakOffset);


    /*
     * The foreach command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    PushLiteral(envPtr, "", 0);
    envPtr->currStackDepth = savedStackDepth + 1;

  done:
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	if (varvList[loopIndex] != (CONST char **) NULL) {
	    ckfree((char *) varvList[loopIndex]);
	}
    }
    if (varcList != varcListStaticSpace) {
	ckfree((char *) varcList);
	ckfree((char *) varvList);
    }
    envPtr->exceptDepth--;
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * DupForeachInfo --
 *
 *	This procedure duplicates a ForeachInfo structure created as auxiliary
 *	data during the compilation of a foreach command.
 *
 * Results:
 *	A pointer to a newly allocated copy of the existing ForeachInfo
 *	structure is returned.
 *
 * Side effects:
 *	Storage for the copied ForeachInfo record is allocated. If the
 *	original ForeachInfo structure pointed to any ForeachVarList records,
 *	these structures are also copied and pointers to them are stored in
 *	the new ForeachInfo record.
 *
 *----------------------------------------------------------------------
 */

static ClientData
DupForeachInfo(clientData)
    ClientData clientData;	/* The foreach command's compilation
				 * auxiliary data to duplicate. */
{
    register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
    ForeachInfo *dupPtr;
    register ForeachVarList *srcListPtr, *dupListPtr;
    int numLists = srcPtr->numLists;
    int numVars, i, j;

    dupPtr = (ForeachInfo *) ckalloc((unsigned)
	    sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
    dupPtr->numLists = numLists;
    dupPtr->firstValueTemp = srcPtr->firstValueTemp;
    dupPtr->loopCtTemp = srcPtr->loopCtTemp;

    for (i = 0;  i < numLists;  i++) {
	srcListPtr = srcPtr->varLists[i];
	numVars = srcListPtr->numVars;
	dupListPtr = (ForeachVarList *) ckalloc((unsigned)
		sizeof(ForeachVarList) + numVars*sizeof(int));
	dupListPtr->numVars = numVars;
	for (j = 0;  j < numVars;  j++) {
	    dupListPtr->varIndexes[j] =	srcListPtr->varIndexes[j];
	}
	dupPtr->varLists[i] = dupListPtr;
    }
    return (ClientData) dupPtr;
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
 *----------------------------------------------------------------------
 *
 * TclCompileIfCmd --
 *
 *	Procedure called to compile the "if" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "if" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */
int
TclCompileIfCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    JumpFixupArray jumpFalseFixupArray;
    				/* Used to fix the ifFalse jump after each
				 * test when its target PC is determined. */
    JumpFixupArray jumpEndFixupArray;
				/* Used to fix the jump after each "then"
				 * body to the end of the "if" when that PC
				 * is determined. */
    Tcl_Token *tokenPtr, *testTokenPtr;
    int jumpFalseDist;
    int jumpIndex = 0;          /* avoid compiler warning. */
    int numWords, wordIdx, numBytes, j, code;
    CONST char *word;
    int savedStackDepth = envPtr->currStackDepth;
                                /* Saved stack depth at the start of the first
				 * test; the envPtr current depth is restored
				 * to this value at the start of each test. */
    int realCond = 1;           /* set to 0 for static conditions: "if 0 {..}" */
    int boolVal;                /* value of static condition */
    int compileScripts = 1;            

    /*
     * Only compile the "if" command if all arguments are simple
     * words, in order to insure correct substitution [Bug 219166]
     */

    tokenPtr = parsePtr->tokenPtr;
    wordIdx = 0;
    numWords = parsePtr->numWords;

    for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_OUT_LINE_COMPILE;
	}
	tokenPtr += 2;
    }


    TclInitJumpFixupArray(&jumpFalseFixupArray);
    TclInitJumpFixupArray(&jumpEndFixupArray);
    code = TCL_OK;

    /*
     * Each iteration of this loop compiles one "if expr ?then? body"
     * or "elseif expr ?then? body" clause. 
     */

    tokenPtr = parsePtr->tokenPtr;
    wordIdx = 0;
    while (wordIdx < numWords) {
	/*
	 * Stop looping if the token isn't "if" or "elseif".
	 */

	word = tokenPtr[1].start;
	numBytes = tokenPtr[1].size;
	if ((tokenPtr == parsePtr->tokenPtr)
	        || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
	    tokenPtr += (tokenPtr->numComponents + 1);
	    wordIdx++;
	} else {
	    break;
	}
	if (wordIdx >= numWords) {
	    code = TCL_OUT_LINE_COMPILE;
	    goto done;
	}

	/*
	 * Compile the test expression then emit the conditional jump
	 * around the "then" part. 
	 */

	envPtr->currStackDepth = savedStackDepth;
	testTokenPtr = tokenPtr;


	if (realCond) {
	    /*
	     * Find out if the condition is a constant. 
	     */

	    Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
		    testTokenPtr[1].size);
	    Tcl_IncrRefCount(boolObj);
	    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
	    Tcl_DecrRefCount(boolObj);







|
|


|
|






|
|






|
|
|


|



|


|
|
|


|
|








|

|








|
|












|
|





|




|
|








|







1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
 *----------------------------------------------------------------------
 *
 * TclCompileIfCmd --
 *
 *	Procedure called to compile the "if" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "if" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */
int
TclCompileIfCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    JumpFixupArray jumpFalseFixupArray;
    				/* Used to fix the ifFalse jump after each
				 * test when its target PC is determined. */
    JumpFixupArray jumpEndFixupArray;
				/* Used to fix the jump after each "then" body
				 * to the end of the "if" when that PC is
				 * determined. */
    Tcl_Token *tokenPtr, *testTokenPtr;
    int jumpFalseDist;
    int jumpIndex = 0;		/* avoid compiler warning. */
    int numWords, wordIdx, numBytes, j, code;
    CONST char *word;
    int savedStackDepth = envPtr->currStackDepth;
				/* Saved stack depth at the start of the first
				 * test; the envPtr current depth is restored
				 * to this value at the start of each test. */
    int realCond = 1;		/* set to 0 for static conditions: "if 0 {..}" */
    int boolVal;		/* value of static condition */
    int compileScripts = 1;

    /*
     * Only compile the "if" command if all arguments are simple words, in
     * order to insure correct substitution [Bug 219166]
     */

    tokenPtr = parsePtr->tokenPtr;
    wordIdx = 0;
    numWords = parsePtr->numWords;

    for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
	tokenPtr = TokenAfter(tokenPtr);
    }


    TclInitJumpFixupArray(&jumpFalseFixupArray);
    TclInitJumpFixupArray(&jumpEndFixupArray);
    code = TCL_OK;

    /*
     * Each iteration of this loop compiles one "if expr ?then? body" or
     * "elseif expr ?then? body" clause.
     */

    tokenPtr = parsePtr->tokenPtr;
    wordIdx = 0;
    while (wordIdx < numWords) {
	/*
	 * Stop looping if the token isn't "if" or "elseif".
	 */

	word = tokenPtr[1].start;
	numBytes = tokenPtr[1].size;
	if ((tokenPtr == parsePtr->tokenPtr)
		|| ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
	    tokenPtr = TokenAfter(tokenPtr);
	    wordIdx++;
	} else {
	    break;
	}
	if (wordIdx >= numWords) {
	    code = TCL_ERROR;
	    goto done;
	}

	/*
	 * Compile the test expression then emit the conditional jump around
	 * the "then" part.
	 */

	envPtr->currStackDepth = savedStackDepth;
	testTokenPtr = tokenPtr;


	if (realCond) {
	    /*
	     * Find out if the condition is a constant.
	     */

	    Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
		    testTokenPtr[1].size);
	    Tcl_IncrRefCount(boolObj);
	    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
	    Tcl_DecrRefCount(boolObj);
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384

1385
1386
1387
1388
1389
1390

1391
1392
1393

1394

1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
		TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
		if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
		    TclExpandJumpFixupArray(&jumpFalseFixupArray);
		}
		jumpIndex = jumpFalseFixupArray.next;
		jumpFalseFixupArray.next++;
		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
			       &(jumpFalseFixupArray.fixup[jumpIndex]));	    
	    }
	    code = TCL_OK;
	}


	/*
	 * Skip over the optional "then" before the then clause.
	 */

	tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
	wordIdx++;
	if (wordIdx >= numWords) {
	    code = TCL_OUT_LINE_COMPILE;
	    goto done;
	}
	if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    word = tokenPtr[1].start;
	    numBytes = tokenPtr[1].size;
	    if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
		tokenPtr += (tokenPtr->numComponents + 1);
		wordIdx++;
		if (wordIdx >= numWords) {
		    code = TCL_OUT_LINE_COMPILE;
		    goto done;
		}
	    }
	}

	/*
	 * Compile the "then" command body.
	 */

	if (compileScripts) {
	    envPtr->currStackDepth = savedStackDepth;
	    TclCompileCmdWord(interp, tokenPtr+1,
	            tokenPtr->numComponents, envPtr);
	}

	if (realCond) {
	    /*
	     * Jump to the end of the "if" command. Both jumpFalseFixupArray and
	     * jumpEndFixupArray are indexed by "jumpIndex".
	     */

	    if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
		TclExpandJumpFixupArray(&jumpEndFixupArray);
	    }
	    jumpEndFixupArray.next++;
	    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
	            &(jumpEndFixupArray.fixup[jumpIndex]));

	    /*
	     * Fix the target of the jumpFalse after the test. Generate a 4 byte
	     * jump if the distance is > 120 bytes. This is conservative, and
	     * ensures that we won't have to replace this jump if we later also
	     * need to replace the proceeding jump to the end of the "if" with a
	     * 4 byte jump.
	     */

	    if (TclFixupForwardJumpToHere(envPtr,
	            &(jumpFalseFixupArray.fixup[jumpIndex]), 120)) {
		/*
		 * Adjust the code offset for the proceeding jump to the end
		 * of the "if" command.
		 */

		jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
	    }
	} else if (boolVal) {
	    /* 
	     *We were processing an "if 1 {...}"; stop compiling
	     * scripts
	     */

	    compileScripts = 0;
	} else {
	    /* 
	     *We were processing an "if 0 {...}"; reset so that
	     * the rest (elseif, else) is compiled correctly
	     */

	    realCond = 1;
	    compileScripts = 1;
	} 

	tokenPtr += (tokenPtr->numComponents + 1);
	wordIdx++;
    }

    /*
     * Restore the current stack depth in the environment; the 
     * "else" clause (or its default) will add 1 to this.
     */

    envPtr->currStackDepth = savedStackDepth;

    /*
     * Check for the optional else clause. Do not compile
     * anything if this was an "if 1 {...}" case.
     */

    if ((wordIdx < numWords)
	    && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
	/*
	 * There is an else clause. Skip over the optional "else" word.
	 */

	word = tokenPtr[1].start;
	numBytes = tokenPtr[1].size;
	if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
	    tokenPtr += (tokenPtr->numComponents + 1);
	    wordIdx++;
	    if (wordIdx >= numWords) {
		code = TCL_OUT_LINE_COMPILE;
		goto done;
	    }
	}

	if (compileScripts) {
	    /*
	     * Compile the else command body.
	     */

	    TclCompileCmdWord(interp, tokenPtr+1,
		    tokenPtr->numComponents, envPtr);
	}

	/*
	 * Make sure there are no words after the else clause.
	 */

	wordIdx++;
	if (wordIdx < numWords) {
	    code = TCL_OUT_LINE_COMPILE;
	    goto done;
	}
    } else {
	/*
	 * No else clause: the "if" command's result is an empty string.
	 */

	if (compileScripts) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
	}
    }

    /*
     * Fix the unconditional jumps to the end of the "if" command.
     */

    for (j = jumpEndFixupArray.next;  j > 0;  j--) {
	jumpIndex = (j - 1);	/* i.e. process the closest jump first */
	if (TclFixupForwardJumpToHere(envPtr,
	        &(jumpEndFixupArray.fixup[jumpIndex]), 127)) {
	    /*
	     * Adjust the immediately preceeding "ifFalse" jump. We moved
	     * it's target (just after this jump) down three bytes.
	     */

	    unsigned char *ifFalsePc = envPtr->codeStart
	            + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
	    unsigned char opCode = *ifFalsePc;
	    if (opCode == INST_JUMP_FALSE1) {
		jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
		jumpFalseDist += 3;
		TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else if (opCode == INST_JUMP_FALSE4) {
		jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
		jumpFalseDist += 3;
		TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else {
		Tcl_Panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
	    }
	}
    }

    /*
     * Free the jumpFixupArray array if malloc'ed storage was used.
     */

    done:
    envPtr->currStackDepth = savedStackDepth + 1;
    TclFreeJumpFixupArray(&jumpFalseFixupArray);
    TclFreeJumpFixupArray(&jumpEndFixupArray);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileIncrCmd --
 *
 *	Procedure called to compile the "incr" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "incr" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileIncrCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *incrTokenPtr;
    int simpleVarName, isScalar, localIndex, haveImmValue, immValue;

    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	return TCL_OUT_LINE_COMPILE;
    }

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    PushVarName(interp, varTokenPtr, envPtr, 
	    (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * If an increment is given, push it, but see first if it's a small
     * integer.
     */

    haveImmValue = 0;
    immValue = 0;
    if (parsePtr->numWords == 3) {
	incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    CONST char *word = incrTokenPtr[1].start;
	    int numBytes = incrTokenPtr[1].size;
	    int validLength = TclParseInteger(word, numBytes);
	    long n;

	    /*
	     * Note there is a danger that modifying the string could have
	     * undesirable side effects.  In this case, TclLooksLikeInt and
	     * TclGetLong do not have any dependencies on shared strings so we
	     * should be safe.
	     */

	    if (validLength == numBytes) {

		int code;
		Tcl_Obj *longObj = Tcl_NewStringObj(word, numBytes);
		Tcl_IncrRefCount(longObj);
		code = Tcl_GetLongFromObj(NULL, longObj, &n);
		Tcl_DecrRefCount(longObj);
		if ((code == TCL_OK) && (-127 <= n) && (n <= 127)) {

		    haveImmValue = 1;
		    immValue = n;
		}

	    }

	    if (!haveImmValue) {
		TclEmitPush(
			TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
	    }
	} else {
	    TclCompileTokens(interp, incrTokenPtr+1, 
	            incrTokenPtr->numComponents, envPtr);
	}
    } else {			/* no incr amount given so use 1 */
	haveImmValue = 1;
	immValue = 1;
    }

    /*
     * Emit the instruction to increment the variable.
     */

    if (simpleVarName) {







|









|


|






|


|











|
<




|
|







|


|
|
|
|
|



|








|
|
<




|
|
|




|

|




|
|





|
|


<
|







|


|









|
<








|








|










|

|
|



|










|








|














|
|


|
|















|


|
<

|
<








|

|



<
<
|


|
|
<


|
>

|
|
|
|
|
>

<

>

>

<
|


|
|



<







1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766

1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801

1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830

1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852

1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947

1948
1949

1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963


1964
1965
1966
1967
1968

1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980

1981
1982
1983
1984
1985

1986
1987
1988
1989
1990
1991
1992
1993

1994
1995
1996
1997
1998
1999
2000
		TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
		if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
		    TclExpandJumpFixupArray(&jumpFalseFixupArray);
		}
		jumpIndex = jumpFalseFixupArray.next;
		jumpFalseFixupArray.next++;
		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
			jumpFalseFixupArray.fixup+jumpIndex);
	    }
	    code = TCL_OK;
	}


	/*
	 * Skip over the optional "then" before the then clause.
	 */

	tokenPtr = TokenAfter(testTokenPtr);
	wordIdx++;
	if (wordIdx >= numWords) {
	    code = TCL_ERROR;
	    goto done;
	}
	if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    word = tokenPtr[1].start;
	    numBytes = tokenPtr[1].size;
	    if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
		tokenPtr = TokenAfter(tokenPtr);
		wordIdx++;
		if (wordIdx >= numWords) {
		    code = TCL_ERROR;
		    goto done;
		}
	    }
	}

	/*
	 * Compile the "then" command body.
	 */

	if (compileScripts) {
	    envPtr->currStackDepth = savedStackDepth;
	    CompileBody(envPtr, tokenPtr, interp);

	}

	if (realCond) {
	    /*
	     * Jump to the end of the "if" command. Both jumpFalseFixupArray
	     * and jumpEndFixupArray are indexed by "jumpIndex".
	     */

	    if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
		TclExpandJumpFixupArray(&jumpEndFixupArray);
	    }
	    jumpEndFixupArray.next++;
	    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
		    jumpEndFixupArray.fixup+jumpIndex);

	    /*
	     * Fix the target of the jumpFalse after the test. Generate a 4
	     * byte jump if the distance is > 120 bytes. This is conservative,
	     * and ensures that we won't have to replace this jump if we later
	     * also need to replace the proceeding jump to the end of the "if"
	     * with a 4 byte jump.
	     */

	    if (TclFixupForwardJumpToHere(envPtr,
		    jumpFalseFixupArray.fixup+jumpIndex, 120)) {
		/*
		 * Adjust the code offset for the proceeding jump to the end
		 * of the "if" command.
		 */

		jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
	    }
	} else if (boolVal) {
	    /*
	     * We were processing an "if 1 {...}"; stop compiling scripts.

	     */

	    compileScripts = 0;
	} else {
	    /*
	     * We were processing an "if 0 {...}"; reset so that the rest
	     * (elseif, else) is compiled correctly.
	     */

	    realCond = 1;
	    compileScripts = 1;
	}

	tokenPtr = TokenAfter(tokenPtr);
	wordIdx++;
    }

    /*
     * Restore the current stack depth in the environment; the "else" clause
     * (or its default) will add 1 to this.
     */

    envPtr->currStackDepth = savedStackDepth;

    /*
     * Check for the optional else clause. Do not compile anything if this was
     * an "if 1 {...}" case.
     */


    if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
	/*
	 * There is an else clause. Skip over the optional "else" word.
	 */

	word = tokenPtr[1].start;
	numBytes = tokenPtr[1].size;
	if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
	    tokenPtr = TokenAfter(tokenPtr);
	    wordIdx++;
	    if (wordIdx >= numWords) {
		code = TCL_ERROR;
		goto done;
	    }
	}

	if (compileScripts) {
	    /*
	     * Compile the else command body.
	     */

	    CompileBody(envPtr, tokenPtr, interp);

	}

	/*
	 * Make sure there are no words after the else clause.
	 */

	wordIdx++;
	if (wordIdx < numWords) {
	    code = TCL_ERROR;
	    goto done;
	}
    } else {
	/*
	 * No else clause: the "if" command's result is an empty string.
	 */

	if (compileScripts) {
	    PushLiteral(envPtr, "", 0);
	}
    }

    /*
     * Fix the unconditional jumps to the end of the "if" command.
     */

    for (j = jumpEndFixupArray.next;  j > 0;  j--) {
	jumpIndex = (j - 1);	/* i.e. process the closest jump first */
	if (TclFixupForwardJumpToHere(envPtr,
		jumpEndFixupArray.fixup+jumpIndex, 127)) {
	    /*
	     * Adjust the immediately preceeding "ifFalse" jump. We moved it's
	     * target (just after this jump) down three bytes.
	     */

	    unsigned char *ifFalsePc = envPtr->codeStart
		    + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
	    unsigned char opCode = *ifFalsePc;
	    if (opCode == INST_JUMP_FALSE1) {
		jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
		jumpFalseDist += 3;
		TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else if (opCode == INST_JUMP_FALSE4) {
		jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
		jumpFalseDist += 3;
		TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else {
		Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
	    }
	}
    }

    /*
     * Free the jumpFixupArray array if malloc'ed storage was used.
     */

  done:
    envPtr->currStackDepth = savedStackDepth + 1;
    TclFreeJumpFixupArray(&jumpFalseFixupArray);
    TclFreeJumpFixupArray(&jumpEndFixupArray);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileIncrCmd --
 *
 *	Procedure called to compile the "incr" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "incr" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileIncrCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *incrTokenPtr;
    int simpleVarName, isScalar, localIndex, haveImmValue, immValue;

    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	return TCL_ERROR;
    }

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);


    PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,

	    &localIndex, &simpleVarName, &isScalar);

    /*
     * If an increment is given, push it, but see first if it's a small
     * integer.
     */

    haveImmValue = 0;
    immValue = 1;
    if (parsePtr->numWords == 3) {
	incrTokenPtr = TokenAfter(varTokenPtr);
	if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    CONST char *word = incrTokenPtr[1].start;
	    int numBytes = incrTokenPtr[1].size;


#if 0
	    /*
	     * Note there is a danger that modifying the string could have
	     * undesirable side effects.  In this case, TclLooksLikeInt has
	     * no dependencies on shared strings so we should be safe.

	     */

	    if (TclLooksLikeInt(word, numBytes)) {
#endif
		int code;
		Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
		Tcl_IncrRefCount(intObj);
		code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
		Tcl_DecrRefCount(intObj);
		if ((code == TCL_OK)
			&& (-127 <= immValue) && (immValue <= 127)) {
		    haveImmValue = 1;

		}
#if 0
	    }
#endif
	    if (!haveImmValue) {

		PushLiteral(envPtr, word, numBytes);
	    }
	} else {
	    TclCompileTokens(interp, incrTokenPtr+1,
		    incrTokenPtr->numComponents, envPtr);
	}
    } else {			/* no incr amount given so use 1 */
	haveImmValue = 1;

    }

    /*
     * Emit the instruction to increment the variable.
     */

    if (simpleVarName) {
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541

1542
1543
1544
1545
1546
1547

1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
 *----------------------------------------------------------------------
 *
 * TclCompileLappendCmd --
 *
 *	Procedure called to compile the "lappend" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lappend" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLappendCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int simpleVarName, isScalar, localIndex, numWords;

    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

    numWords = parsePtr->numWords;
    if (numWords == 1) {
	return TCL_OUT_LINE_COMPILE;
    }
    if (numWords != 3) {
	/*
	 * LAPPEND instructions currently only handle one value appends
	 */
        return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * If we are doing an assignment, push the new value.
     * In the no values case, create an empty object.
     */

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, 
		    valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	} else {
	    TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	}
    }

    /*
     * Emit instructions to set/get the variable.
     */

    /*
     * The *_STK opcodes should be refactored to make better use of existing
     * LOAD/STORE instructions.
     */
    if (simpleVarName) {
	if (isScalar) {
	    if (localIndex >= 0) {

		if (localIndex <= 255) {
		    TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
		} else {
		    TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
		}
	    } else {

		TclEmitOpcode(INST_LAPPEND_STK, envPtr);
	    }
	} else {
	    if (localIndex >= 0) {
		if (localIndex <= 255) {
		    TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
		} else {
		    TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
		}
	    } else {
		TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
	    }
	}
    } else {
	TclEmitOpcode(INST_LAPPEND_STK, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLassignCmd --
 *
 *	Procedure called to compile the "lassign" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lassign" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLassignCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int simpleVarName, isScalar, localIndex, numWords, idx;

    numWords = parsePtr->numWords;
    /*
     * Check for command syntax error, but we'll punt that to runtime
     */
    if (numWords < 3) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Generate code to push list being taken apart by [lassign].
     */
    tokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1);
    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, 
		tokenPtr[1].start, tokenPtr[1].size), envPtr);
    } else {
	TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr);
    }

    /*
     * Generate code to assign values from the list to variables
     */
    for (idx=0 ; idx<numWords-2 ; idx++) {
	tokenPtr += tokenPtr->numComponents + 1;

	/*
	 * Generate the next variable name
	 */
	PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR,
		&localIndex, &simpleVarName, &isScalar);

	/*
	 * Emit instructions to get the idx'th item out of the list
	 * value on the stack and assign it to the variable.
	 */
	if (simpleVarName) {
	    if (isScalar) {
		if (localIndex >= 0) {
		    TclEmitOpcode(INST_DUP, envPtr);
		    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
		    if (localIndex <= 255) {







|
|


|
|











|






|




|





|







|


|
<





|
|



|
<
<
<
<
|
<
<












|
>
|
|
|
|
|
|
>
|
<
<
<
|
|
|
|
<
<
<

















|
|


|
|



















|





|
<
<
|
<
<
<





|








|
|







2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097

2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108




2109


2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131



2132
2133
2134
2135



2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184


2185



2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
 *----------------------------------------------------------------------
 *
 * TclCompileLappendCmd --
 *
 *	Procedure called to compile the "lappend" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lappend" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLappendCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int simpleVarName, isScalar, localIndex, numWords;

    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_ERROR;
    }

    numWords = parsePtr->numWords;
    if (numWords == 1) {
	return TCL_ERROR;
    }
    if (numWords != 3) {
	/*
	 * LAPPEND instructions currently only handle one value appends
	 */
	return TCL_ERROR;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);


    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * If we are doing an assignment, push the new value.  In the no values
     * case, create an empty object.
     */

    if (numWords > 2) {
	Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);




	CompileWord(envPtr, valueTokenPtr, interp);


    }

    /*
     * Emit instructions to set/get the variable.
     */

    /*
     * The *_STK opcodes should be refactored to make better use of existing
     * LOAD/STORE instructions.
     */
    if (simpleVarName) {
	if (isScalar) {
	    if (localIndex < 0) {
		TclEmitOpcode(INST_LAPPEND_STK, envPtr);
	    } else if (localIndex <= 255) {
		TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
	    } else {
		TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
	    }
	} else {
	    if (localIndex < 0) {
		TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);



	    } else if (localIndex <= 255) {
		TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
	    } else {
		TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);



	    }
	}
    } else {
	TclEmitOpcode(INST_LAPPEND_STK, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLassignCmd --
 *
 *	Procedure called to compile the "lassign" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lassign" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLassignCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int simpleVarName, isScalar, localIndex, numWords, idx;

    numWords = parsePtr->numWords;
    /*
     * Check for command syntax error, but we'll punt that to runtime
     */
    if (numWords < 3) {
	return TCL_ERROR;
    }

    /*
     * Generate code to push list being taken apart by [lassign].
     */
    tokenPtr = TokenAfter(parsePtr->tokenPtr);


    CompileWord(envPtr, tokenPtr, interp);




    /*
     * Generate code to assign values from the list to variables
     */
    for (idx=0 ; idx<numWords-2 ; idx++) {
	tokenPtr = TokenAfter(tokenPtr);

	/*
	 * Generate the next variable name
	 */
	PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR,
		&localIndex, &simpleVarName, &isScalar);

	/*
	 * Emit instructions to get the idx'th item out of the list value on
	 * the stack and assign it to the variable.
	 */
	if (simpleVarName) {
	    if (isScalar) {
		if (localIndex >= 0) {
		    TclEmitOpcode(INST_DUP, envPtr);
		    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
		    if (localIndex <= 255) {
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
































1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936

1937

1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
 *----------------------------------------------------------------------
 *
 * TclCompileLindexCmd --
 *
 *	Procedure called to compile the "lindex" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lindex" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLindexCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int i, numWords;
    numWords = parsePtr->numWords;

    /*
     * Quit if too few args
     */

    if (numWords <= 1) {
	return TCL_OUT_LINE_COMPILE;
    }

    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);

































    /*
     * Push the operands onto the stack.
     */

    for (i=1 ; i<numWords ; i++) {
	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(
		    TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);
	} else {
	    TclCompileTokens(interp, varTokenPtr+1,
		    varTokenPtr->numComponents, envPtr);
	}
	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    }

    /*
     * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
     * if there are multiple index args.
     */

    if (numWords == 3) {
	TclEmitOpcode(INST_LIST_INDEX, envPtr);
    } else {
 	TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileListCmd --
 *
 *	Procedure called to compile the "list" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "list" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileListCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

    if (parsePtr->numWords == 1) {
	/*
	 * Empty args case
	 */

	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    } else {
	/*
	 * Push the all values onto the stack.
	 */
	Tcl_Token *valueTokenPtr;
	int i, numWords;

	numWords = parsePtr->numWords;

	valueTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
	for (i = 1; i < numWords; i++) {
	    if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		TclEmitPush(TclRegisterNewLiteral(envPtr,
			valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	    } else {
		TclCompileTokens(interp, valueTokenPtr+1,
			valueTokenPtr->numComponents, envPtr);
	    }
	    valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
	}
	TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLlengthCmd --
 *
 *	Procedure called to compile the "llength" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "llength" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLlengthCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;

    if (parsePtr->numWords != 2) {
	return TCL_OUT_LINE_COMPILE;
    }
    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);

    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * We could simply count the number of elements here and push
	 * that value, but that is too rare a case to waste the code space.
	 */
	TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
		varTokenPtr[1].size), envPtr);
    } else {
	TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
    }
    TclEmitOpcode(INST_LIST_LENGTH, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLsetCmd --
 *
 *	Procedure called to compile the "lset" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lset" command
 *	at runtime.
 *
 * The general template for execution of the "lset" command is:
 *	(1) Instructions to push the variable name, unless the
 *	    variable is local to the stack frame.
 *	(2) If the variable is an array element, instructions
 *	    to push the array element name.
 *	(3) Instructions to push each of zero or more "index" arguments
 *	    to the stack, followed with the "newValue" element.
 *	(4) Instructions to duplicate the variable name and/or array
 *	    element name onto the top of the stack, if either was
 *	    pushed at steps (1) and (2).
 *	(5) The appropriate INST_LOAD_* instruction to place the
 *	    original value of the list variable at top of stack.
 *	(6) At this point, the stack contains:
 *	     varName? arrayElementName? index1 index2 ... newValue oldList
 *	    The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
 *	    according as whether there is exactly one index element (LIST)
 *	    or either zero or else two or more (FLAT).  This instruction
 *	    removes everything from the stack except for the two names
 *	    and pushes the new value of the variable.
 *	(7) Finally, INST_STORE_* stores the new value in the variable
 *	    and cleans up the stack.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLsetCmd(interp, parsePtr, envPtr)
    Tcl_Interp* interp;		/* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;	/* Points to a parse structure for
				 * the command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    int tempDepth;		/* Depth used for emitting one part
				 * of the code burst. */
    Tcl_Token* varTokenPtr;	/* Pointer to the Tcl_Token representing
				 * the parse of the variable name */
    int localIndex;		/* Index of var in local var table */
    int simpleVarName;		/* Flag == 1 if var name is simple */
    int isScalar;		/* Flag == 1 if scalar, 0 if array */
    int i;

    /* Check argument count */

    if (parsePtr->numWords < 3) {
	/* Fail at run time, not in compilation */
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);


    /* Push the "index" args and the new element value. */


    for (i=2 ; i<parsePtr->numWords ; ++i) {
	/* Advance to next arg */

	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

	/* Push an arg */

	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);
	} else {
	    TclCompileTokens(interp, varTokenPtr+1,
		    varTokenPtr->numComponents, envPtr);
	}
    }

    /*
     * Duplicate the variable name if it's been pushed.  
     */

    if (!simpleVarName || localIndex < 0) {
	if (!simpleVarName || isScalar) {
	    tempDepth = parsePtr->numWords - 2;
	} else {
	    tempDepth = parsePtr->numWords - 1;







|
|


|
|







|
|



<
|






|


|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






<
<
|
|
<
<
<
<
<



|
|



















|
|


|
|







|
|






|




|


|









|
<

<
<
<
<
|
|
<
<















|
|


|
|







|
|





|

|
<

<
<
<
<
<
|
<
<
<
<
<












|
|


|
|


|
|
|
|
|
|
|
|
|
|
|

|

|
|
|
|
|
|







|
|


|
|
|
|









|



|
|
|
|
|


|
<



>
|
>


<
|
<
<
<
<
<
|
<
<
<
<
<



|







2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275

2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325


2326
2327





2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391

2392




2393
2394


2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432

2433





2434





2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510

2511
2512
2513
2514
2515
2516
2517
2518

2519





2520





2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
 *----------------------------------------------------------------------
 *
 * TclCompileLindexCmd --
 *
 *	Procedure called to compile the "lindex" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lindex" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLindexCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;

    int i, numWords = parsePtr->numWords;

    /*
     * Quit if too few args
     */

    if (numWords <= 1) {
	return TCL_ERROR;
    }

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);

    if ((numWords == 3) && (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
#if 0
	    && TclLooksLikeInt(varTokenPtr[1].start, varTokenPtr[1].size)
#endif
	    ) {
	Tcl_Obj *tmpObj;
	int idx, result;

	tmpObj = Tcl_NewStringObj(varTokenPtr[1].start, varTokenPtr[1].size);
	result = Tcl_GetIntFromObj(NULL, tmpObj, &idx);
	TclDecrRefCount(tmpObj);

	if (result == TCL_OK && idx >= 0) {
	    /*
	     * All checks have been completed, and we have exactly this
	     * construct:
	     *	 lindex <posInt> <arbitraryValue>
	     * This is best compiled as a push of the arbitrary value followed
	     * by an "immediate lindex" which is the most efficient variety.
	     */

	    varTokenPtr = TokenAfter(varTokenPtr);
	    CompileWord(envPtr, varTokenPtr, interp);
	    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
	    return TCL_OK;
	}

	/*
	 * If the conversion failed or the value was negative, we just keep on
	 * going with the more complex compilation.
	 */
    }

    /*
     * Push the operands onto the stack.
     */

    for (i=1 ; i<numWords ; i++) {


	CompileWord(envPtr, varTokenPtr, interp);
	varTokenPtr = TokenAfter(varTokenPtr);





    }

    /*
     * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
     * multiple index args.
     */

    if (numWords == 3) {
	TclEmitOpcode(INST_LIST_INDEX, envPtr);
    } else {
 	TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileListCmd --
 *
 *	Procedure called to compile the "list" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "list" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileListCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_ERROR;
    }

    if (parsePtr->numWords == 1) {
	/*
	 * [list] without arguments just pushes an empty object.
	 */

	PushLiteral(envPtr, "", 0);
    } else {
	/*
	 * Push the all values onto the stack.
	 */
	Tcl_Token *valueTokenPtr;
	int i, numWords;

	numWords = parsePtr->numWords;

	valueTokenPtr = TokenAfter(parsePtr->tokenPtr);

	for (i = 1; i < numWords; i++) {




	    CompileWord(envPtr, valueTokenPtr, interp);
	    valueTokenPtr = TokenAfter(valueTokenPtr);


	}
	TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLlengthCmd --
 *
 *	Procedure called to compile the "llength" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "llength" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLlengthCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;

    if (parsePtr->numWords != 2) {
	return TCL_ERROR;
    }
    varTokenPtr = TokenAfter(parsePtr->tokenPtr);







    CompileWord(envPtr, varTokenPtr, interp);





    TclEmitOpcode(INST_LIST_LENGTH, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLsetCmd --
 *
 *	Procedure called to compile the "lset" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lset" command at
 *	runtime.
 *
 * The general template for execution of the "lset" command is:
 *	(1) Instructions to push the variable name, unless the variable is
 *	    local to the stack frame.
 *	(2) If the variable is an array element, instructions to push the
 *	    array element name.
 *	(3) Instructions to push each of zero or more "index" arguments to the
 *	    stack, followed with the "newValue" element.
 *	(4) Instructions to duplicate the variable name and/or array element
 *	    name onto the top of the stack, if either was pushed at steps (1)
 *	    and (2).
 *	(5) The appropriate INST_LOAD_* instruction to place the original
 *	    value of the list variable at top of stack.
 *	(6) At this point, the stack contains:
 *		varName? arrayElementName? index1 index2 ... newValue oldList
 *	    The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
 *	    according as whether there is exactly one index element (LIST) or
 *	    either zero or else two or more (FLAT).  This instruction removes
 *	    everything from the stack except for the two names and pushes the
 *	    new value of the variable.
 *	(7) Finally, INST_STORE_* stores the new value in the variable and
 *	    cleans up the stack.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLsetCmd(interp, parsePtr, envPtr)
    Tcl_Interp* interp;		/* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;	/* Points to a parse structure for the
				 * command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    int tempDepth;		/* Depth used for emitting one part of the
				 * code burst. */
    Tcl_Token* varTokenPtr;	/* Pointer to the Tcl_Token representing the
				 * parse of the variable name */
    int localIndex;		/* Index of var in local var table */
    int simpleVarName;		/* Flag == 1 if var name is simple */
    int isScalar;		/* Flag == 1 if scalar, 0 if array */
    int i;

    /* Check argument count */

    if (parsePtr->numWords < 3) {
	/* Fail at run time, not in compilation */
	return TCL_ERROR;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we need
     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);

    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * Push the "index" args and the new element value.
     */

    for (i=2 ; i<parsePtr->numWords ; ++i) {

	varTokenPtr = TokenAfter(varTokenPtr);





	CompileWord(envPtr, varTokenPtr, interp);





    }

    /*
     * Duplicate the variable name if it's been pushed.
     */

    if (!simpleVarName || localIndex < 0) {
	if (!simpleVarName || isScalar) {
	    tempDepth = parsePtr->numWords - 2;
	} else {
	    tempDepth = parsePtr->numWords - 1;
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
    /*
     * Emit the correct variety of 'lset' instruction
     */

    if (parsePtr->numWords == 4) {
	TclEmitOpcode(INST_LSET_LIST, envPtr);
    } else {
	TclEmitInstInt4(INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr);
    }

    /*
     * Emit code to put the value back in the variable
     */

    if (!simpleVarName) {







|







2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
    /*
     * Emit the correct variety of 'lset' instruction
     */

    if (parsePtr->numWords == 4) {
	TclEmitOpcode(INST_LSET_LIST, envPtr);
    } else {
	TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
    }

    /*
     * Emit code to put the value back in the variable
     */

    if (!simpleVarName) {
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
 *----------------------------------------------------------------------
 *
 * TclCompileRegexpCmd --
 *
 *	Procedure called to compile the "regexp" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "regexp" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileRegexpCmd(interp, parsePtr, envPtr)
    Tcl_Interp* interp;		/* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;	/* Points to a parse structure for
				 * the command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    Tcl_Token *varTokenPtr;	/* Pointer to the Tcl_Token representing
				 * the parse of the RE or string */
    int i, len, nocase, anchorLeft, anchorRight, start;
    char *str;

    /*
     * We are only interested in compiling simple regexp cases.
     * Currently supported compile cases are:
     *   regexp ?-nocase? ?--? staticString $var
     *   regexp ?-nocase? ?--? {^staticString$} $var
     */
    if (parsePtr->numWords < 3) {
	return TCL_OUT_LINE_COMPILE;
    }

    nocase = 0;
    varTokenPtr = parsePtr->tokenPtr;

    /*
     * We only look for -nocase and -- as options.  Everything else
     * gets pushed to runtime execution.  This is different than regexp's
     * runtime option handling, but satisfies our stricter needs.
     */
    for (i = 1; i < parsePtr->numWords - 2; i++) {
	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    /* Not a simple string - punt to runtime. */
	    return TCL_OUT_LINE_COMPILE;
	}
	str = (char *) varTokenPtr[1].start;
	len = varTokenPtr[1].size;
	if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
	    i++;
	    break;
	} else if ((len > 1)
		&& (strncmp(str, "-nocase", (unsigned) len) == 0)) {
	    nocase = 1;
	} else {
	    /* Not an option we recognize. */
	    return TCL_OUT_LINE_COMPILE;
	}
    }

    if ((parsePtr->numWords - i) != 2) {
	/* We don't support capturing to variables */
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Get the regexp string.  If it is not a simple string, punt to runtime.
     * If it has a '-', it could be an incorrectly formed regexp command.
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    str = (char *) varTokenPtr[1].start;
    len = varTokenPtr[1].size;
    if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
	return TCL_OUT_LINE_COMPILE;
    }

    if (len == 0) {
	/*
	 * The semantics of regexp are always match on re == "".
	 */
	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
	return TCL_OK;
    }

    /*
     * Make a copy of the string that is null-terminated for checks which
     * require such.
     */







|
|


|
|







|
|


|
|




|
|




|






|
|
|


|


|






|
<



|





|






|



|






|







2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669

2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
 *----------------------------------------------------------------------
 *
 * TclCompileRegexpCmd --
 *
 *	Procedure called to compile the "regexp" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "regexp" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileRegexpCmd(interp, parsePtr, envPtr)
    Tcl_Interp* interp;		/* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;	/* Points to a parse structure for the
				 * command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    Tcl_Token *varTokenPtr;	/* Pointer to the Tcl_Token representing the
				 * parse of the RE or string */
    int i, len, nocase, anchorLeft, anchorRight, start;
    char *str;

    /*
     * We are only interested in compiling simple regexp cases.  Currently
     * supported compile cases are:
     *   regexp ?-nocase? ?--? staticString $var
     *   regexp ?-nocase? ?--? {^staticString$} $var
     */
    if (parsePtr->numWords < 3) {
	return TCL_ERROR;
    }

    nocase = 0;
    varTokenPtr = parsePtr->tokenPtr;

    /*
     * We only look for -nocase and -- as options.  Everything else gets
     * pushed to runtime execution.  This is different than regexp's runtime
     * option handling, but satisfies our stricter needs.
     */
    for (i = 1; i < parsePtr->numWords - 2; i++) {
	varTokenPtr = TokenAfter(varTokenPtr);
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    /* Not a simple string - punt to runtime. */
	    return TCL_ERROR;
	}
	str = (char *) varTokenPtr[1].start;
	len = varTokenPtr[1].size;
	if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
	    i++;
	    break;
	} else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {

	    nocase = 1;
	} else {
	    /* Not an option we recognize. */
	    return TCL_ERROR;
	}
    }

    if ((parsePtr->numWords - i) != 2) {
	/* We don't support capturing to variables */
	return TCL_ERROR;
    }

    /*
     * Get the regexp string.  If it is not a simple string, punt to runtime.
     * If it has a '-', it could be an incorrectly formed regexp command.
     */
    varTokenPtr = TokenAfter(varTokenPtr);
    str = (char *) varTokenPtr[1].start;
    len = varTokenPtr[1].size;
    if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
	return TCL_ERROR;
    }

    if (len == 0) {
	/*
	 * The semantics of regexp are always match on re == "".
	 */
	PushLiteral(envPtr, "1", 1);
	return TCL_OK;
    }

    /*
     * Make a copy of the string that is null-terminated for checks which
     * require such.
     */
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194

2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221


2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271

























2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329

2330
2331
2332
2333
2334
2335
2336
2337

2338

2339
2340
2341

2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353

2354


2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443


2444
2445
2446
2447
2448
2449
2450
2451
2452
2453

2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485



2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574














2575





2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707





























2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722


2723
2724
2725
2726



2727
2728
2729

2730
2731
2732
2733
2734
2735
2736
2737


2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749


2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763

2764
2765
2766
2767
2768
2769







2770
2771
2772
2773
2774
2775
2776
2777




2778
2779
2780
2781
2782
2783
2784
2785


2786
2787
2788






2789
2790
2791
2792
2793



2794
2795

2796
2797



2798
2799

2800


2801
2802
2803
2804
2805
2806
2807


2808







2809
2810


2811
2812
2813





2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825

2826
2827
2828


2829

2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854

2855



2856
2857

2858
2859
2860
2861

2862
2863



2864
2865
2866


2867
2868
2869
2870
2871

2872
2873
2874
2875
2876
2877
2878
2879

2880



2881

2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893







2894








2895

2896
2897
2898

2899
2900




2901










2902
2903


2904
2905





2906
2907























2908














2909



2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932

2933
2934
2935
2936
2937
2938
2939
2940


2941
2942

2943
2944

2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962

2963
2964


2965
2966

2967
2968
2969
2970
2971
2972
2973
2974
2975
2976

2977
2978
2979
2980
2981
2982
2983
2984
2985
2986

2987
2988
2989

2990
2991

2992

2993
2994
2995
2996
2997
2998
2999
3000

3001
3002
3003
3004
3005
3006
3007
3008


3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023

3024
3025

3026
3027
3028

3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054

3055
3056
3057

3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087

3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107



3108



3109
3110




3111



3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193

3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536








	anchorRight = 0;
    }

    /*
     * On the first (pattern) arg, check to see if any RE special characters
     * are in the word.  If not, this is the same as 'string equal'.
     */
    if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
	start += 2;
	anchorLeft = 0;
    }
    if ((len > (2+start)) && (str[len-3] != '\\')
	    && (str[len-2] == '.') && (str[len-1] == '*')) {
	len -= 2;
	str[len] = '\0';
	anchorRight = 0;
    }

    /*
     * Don't do anything with REs with other special chars.  Also check if
     * this is a bad RE (do this at the end because it can be expensive).
     * If so, let it complain at runtime.
     */
    if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
	    || (Tcl_RegExpCompile(NULL, str) == NULL)) {
	ckfree((char *) str);
	return TCL_OUT_LINE_COMPILE;
    }

    if (anchorLeft && anchorRight) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
		envPtr);
    } else {
	/*
	 * This needs to find the substring anywhere in the string, so
	 * use string match and *foo*, with appropriate anchoring.
	 */
	char *newStr  = ckalloc((unsigned) len + 3);

	len -= start;
	if (anchorLeft) {
	    strncpy(newStr, str + start, (size_t) len);
	} else {
	    newStr[0] = '*';
	    strncpy(newStr + 1, str + start, (size_t) len++);
	}
	if (!anchorRight) {
	    newStr[len++] = '*';
	}
	newStr[len] = '\0';
	TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
	ckfree((char *) newStr);
    }
    ckfree((char *) str);

    /*
     * Push the string arg
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitPush(TclRegisterNewLiteral(envPtr,
		varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
    } else {
	TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
    }



    if (anchorLeft && anchorRight && !nocase) {
	TclEmitOpcode(INST_STR_EQ, envPtr);
    } else {
	TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileReturnCmd --
 *
 *	Procedure called to compile the "return" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "return" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileReturnCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * General syntax: [return ?-option value ...? ?result?]
     * An even number of words means an explicit result argument is present.
     */
    int level, code, status = TCL_OK;
    int numWords = parsePtr->numWords;
    int explicitResult = (0 == (numWords % 2));
    int numOptionWords = numWords - 1 - explicitResult;
    Tcl_Obj *returnOpts;
    Tcl_Token *wordTokenPtr = parsePtr->tokenPtr
		+ (parsePtr->tokenPtr->numComponents + 1);
#define NUM_STATIC_OBJS 20
    int objc;
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;


























    if (numOptionWords > NUM_STATIC_OBJS) {
	objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *));
    } else {
	objv = staticObjArray;
    }

    /* 
     * Scan through the return options.  If any are unknown at compile
     * time, there is no value in bytecompiling.  Save the option values
     * known in an objv array for merging into a return options dictionary.
     */

    for (objc = 0; objc < numOptionWords; objc++) {
	objv[objc] = Tcl_NewObj();
	Tcl_IncrRefCount(objv[objc]);
	if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
	    objc++;
	    status = TCL_ERROR;
	    goto cleanup;
	}
	wordTokenPtr += wordTokenPtr->numComponents + 1;
    }
    status = TclMergeReturnOptions(interp, objc, objv,
	    &returnOpts, &code, &level);
cleanup:
    while (--objc >= 0) {
	Tcl_DecrRefCount(objv[objc]);
    }
    if (numOptionWords > NUM_STATIC_OBJS) {
	ckfree((char *)objv);
    }
    if (TCL_ERROR == status) {
	/*
	 * Something was bogus in the return options.  Clear the
	 * error message, and report back to the compiler that this
	 * must be interpreted at runtime.
	 */
	Tcl_ResetResult(interp);
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * All options are known at compile time, so we're going to bytecompile.
     * Emit instructions to push the result on the stack
     */

    if (explicitResult) {
	if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    /* Simple word: compile quickly to a simple push */
	    TclEmitPush(TclRegisterNewLiteral(envPtr, wordTokenPtr[1].start,
			wordTokenPtr[1].size), envPtr);
	} else {
	    /* More complex tokens get compiled */
	    TclCompileTokens(interp, wordTokenPtr+1,
		    wordTokenPtr->numComponents, envPtr);
	}
    } else {
	/* No explict result argument, so default result is empty string */

	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    }

   /* 
    * Check for optimization:  When [return] is in a proc, and there's
    * no enclosing [catch], and there are no return options, then the
    * INST_DONE instruction is equivalent, and may be more efficient.
    */

    if (numOptionWords == 0) {

	/* We have default return options... */
	if (envPtr->procPtr != NULL) {
	    /* ... and we're in a proc ... */

	    int index = envPtr->exceptArrayNext - 1;
	    int enclosingCatch = 0;
	    while (index >= 0) {
		ExceptionRange range = envPtr->exceptArrayPtr[index];
		if ((range.type == CATCH_EXCEPTION_RANGE)
			&& (range.catchOffset == -1)) {
		    enclosingCatch = 1;
		    break;
		}
		index--;
	    }
	    if (!enclosingCatch) {

		/* ... and there is no enclosing catch. */


		Tcl_DecrRefCount(returnOpts);
		TclEmitOpcode(INST_DONE, envPtr);
		return TCL_OK;
	    }
	}
    }

    /*
     * Could not use the optimization, so we push the return options
     * dictionary, and emit the INST_RETURN instruction with code
     * and level as operands.
     */

    TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
    TclEmitInstInt4(INST_RETURN, code, envPtr);
    TclEmitInt4(level, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "set" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileSetCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int isAssignment, isScalar, simpleVarName, localIndex, numWords;

    numWords = parsePtr->numWords;
    if ((numWords != 2) && (numWords != 3)) {
	return TCL_OUT_LINE_COMPILE;
    }
    isAssignment = (numWords == 3);

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * If we are doing an assignment, push the new value.
     */

    if (isAssignment) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
		    valueTokenPtr[1].size), envPtr);
	} else {
	    TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	}
    }

    /*
     * Emit instructions to set/get the variable.
     */

    if (simpleVarName) {
	if (isScalar) {
	    if (localIndex >= 0) {


		if (localIndex <= 255) {
		    TclEmitInstInt1((isAssignment?
		            INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
			    localIndex, envPtr);
		} else {
		    TclEmitInstInt4((isAssignment?
			    INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
			    localIndex, envPtr);
		}
	    } else {

		TclEmitOpcode((isAssignment?
		        INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
	    }
	} else {
	    if (localIndex >= 0) {
		if (localIndex <= 255) {
		    TclEmitInstInt1((isAssignment?
		            INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
			    localIndex, envPtr);
		} else {
		    TclEmitInstInt4((isAssignment?
			    INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
			    localIndex, envPtr);
		}
	    } else {
		TclEmitOpcode((isAssignment?
		        INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
	    }
	}
    } else {
	TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileStringCmd --
 *
 *	Procedure called to compile the "string" command.



 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "string" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileStringCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *opTokenPtr, *varTokenPtr;
    Tcl_Obj *opObj;
    int index;

    static CONST char *options[] = {
	"bytelength",	"compare",	"equal",	"first",
	"index",	"is",		"last",		"length",
	"map",		"match",	"range",	"repeat",
	"replace",	"tolower",	"toupper",	"totitle",
	"trim",		"trimleft",	"trimright",
	"wordend",	"wordstart",	(char *) NULL
    };
    enum options {
	STR_BYTELENGTH,	STR_COMPARE,	STR_EQUAL,	STR_FIRST,
	STR_INDEX,	STR_IS,		STR_LAST,	STR_LENGTH,
	STR_MAP,	STR_MATCH,	STR_RANGE,	STR_REPEAT,
	STR_REPLACE,	STR_TOLOWER,	STR_TOUPPER,	STR_TOTITLE,
	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
	STR_WORDEND,	STR_WORDSTART
    };	  

    if (parsePtr->numWords < 2) {
	/* Fail at run time, not in compilation */
	return TCL_OUT_LINE_COMPILE;
    }
    opTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);

    opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
    if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
	    &index) != TCL_OK) {
	Tcl_DecrRefCount(opObj);
	Tcl_ResetResult(interp);
	return TCL_OUT_LINE_COMPILE;
    }
    Tcl_DecrRefCount(opObj);

    varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);

    switch ((enum options) index) {
	case STR_BYTELENGTH:
	case STR_FIRST:
	case STR_IS:
	case STR_LAST:
	case STR_MAP:
	case STR_RANGE:
	case STR_REPEAT:
	case STR_REPLACE:
	case STR_TOLOWER:
	case STR_TOUPPER:
	case STR_TOTITLE:
	case STR_TRIM:
	case STR_TRIMLEFT:
	case STR_TRIMRIGHT:
	case STR_WORDEND:
	case STR_WORDSTART:
	    /*
	     * All other cases: compile out of line.
	     */
	    return TCL_OUT_LINE_COMPILE;

	case STR_COMPARE: 
	case STR_EQUAL: {
	    int i;
	    /*
	     * If there are any flags to the command, we can't byte compile it
	     * because the INST_STR_EQ bytecode doesn't support flags.
	     */

	    if (parsePtr->numWords != 4) {














		return TCL_OUT_LINE_COMPILE;





	    }

	    /*
	     * Push the two operands onto the stack.
	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
		} else {
		    TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	    }

	    TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
		    INST_STR_CMP : INST_STR_EQ), envPtr);
	    return TCL_OK;
	}
	case STR_INDEX: {
	    int i;

	    if (parsePtr->numWords != 4) {
		/* Fail at run time, not in compilation */
		return TCL_OUT_LINE_COMPILE;
	    }

	    /*
	     * Push the two operands onto the stack.
	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
		} else {
		    TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	    }

	    TclEmitOpcode(INST_STR_INDEX, envPtr);
	    return TCL_OK;
	}
	case STR_LENGTH: {
	    if (parsePtr->numWords != 3) {
		/* Fail at run time, not in compilation */
		return TCL_OUT_LINE_COMPILE;
	    }

	    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		/*
		 * Here someone is asking for the length of a static string.
		 * Just push the actual character (not byte) length.
		 */
		char buf[TCL_INTEGER_SPACE];
		int len = Tcl_NumUtfChars(varTokenPtr[1].start,
			varTokenPtr[1].size);
		len = sprintf(buf, "%d", len);
		TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
		return TCL_OK;
	    } else {
		TclCompileTokens(interp, varTokenPtr+1,
			varTokenPtr->numComponents, envPtr);
	    }
	    TclEmitOpcode(INST_STR_LEN, envPtr);
	    return TCL_OK;
	}
	case STR_MATCH: {
	    int i, length, exactMatch = 0, nocase = 0;
	    CONST char *str;

	    if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
		/* Fail at run time, not in compilation */
		return TCL_OUT_LINE_COMPILE;
	    }

	    if (parsePtr->numWords == 5) {
		if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		    return TCL_OUT_LINE_COMPILE;
		}
		str    = varTokenPtr[1].start;
		length = varTokenPtr[1].size;
		if ((length > 1) &&
			strncmp(str, "-nocase", (size_t) length) == 0) {
		    nocase = 1;
		} else {
		    /* Fail at run time, not in compilation */
		    return TCL_OUT_LINE_COMPILE;
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	    }

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    str = varTokenPtr[1].start;
		    length = varTokenPtr[1].size;
		    if (!nocase && (i == 0)) {
			/*
			 * On the first (pattern) arg, check to see if any
			 * glob special characters are in the word '*[]?\\'.
			 * If not, this is the same as 'string equal'.  We
			 * can use strpbrk here because the glob chars are all
			 * in the ascii-7 range.  If -nocase was specified,
			 * we can't do this because INST_STR_EQ has no support
			 * for nocase.
			 */
			Tcl_Obj *copy = Tcl_NewStringObj(str, length);
			Tcl_IncrRefCount(copy);
			exactMatch = (strpbrk(Tcl_GetString(copy),
				"*[]?\\") == NULL);
			Tcl_DecrRefCount(copy);
		    }
		    TclEmitPush(
			    TclRegisterNewLiteral(envPtr, str, length), envPtr);
		} else {
		    TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		}
		varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	    }

	    if (exactMatch) {
		TclEmitOpcode(INST_STR_EQ, envPtr);
	    } else {
		TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
	    }
	    return TCL_OK;
	}





























    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileSwitchCmd --
 *
 *	Procedure called to compile the "switch" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.


 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "switch" command
 *	at runtime.



 *
 *----------------------------------------------------------------------
 */

int
TclCompileSwitchCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;	/* Pointer to tokens in command */


    Tcl_Token *valueTokenPtr;	/* Token for the value to switch on. */
    int foundDefault;		/* Flag to indicate whether a "default"
				 * clause is present. */
    enum {Switch_Exact, Switch_Glob} mode;
				/* What kind of switch are we doing? */
    int i, j;			/* Loop counter variables. */

    Tcl_DString bodyList;	/* Used for splitting the pattern list. */
    int argc;			/* Number of items in pattern list. */
    CONST char **argv;		/* Array of copies of items in pattern list. */
    Tcl_Token *bodyTokenArray;	/* Array of real pattern list items. */
    CONST char *tokenStartPtr;	/* Used as part of synthesizing tokens. */


    int isTokenBraced;

    JumpFixup *fixupArray;	/* Array of forward-jump fixup records. */
    int *fixupTargetArray;	/* Array of places for fixups to point at. */
    int fixupCount;		/* Number of places to fix up. */
    int contFixIndex;		/* Where the first of the jumps due to a
				 * group of continuation bodies starts,
				 * or -1 if there aren't any. */
    int contFixCount = 0;	/* Number of continuation bodies pointing
				 * to the current (or next) real body. */
    int codeOffset;		/* Cache of current bytecode offset. */
    int savedStackDepth = envPtr->currStackDepth;

    tokenPtr = parsePtr->tokenPtr;


    /*
     * Only handle the following versions:
     *   switch        -- word {pattern body ...}
     *   switch -exact -- word {pattern body ...} 
     *   switch -glob  -- word {pattern body ...}







     */

    if (parsePtr->numWords != 5 &&
	parsePtr->numWords != 4) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*




     * We don't care how the command's word was generated; we're
     * compiling it anyway!
     */
    tokenPtr += tokenPtr->numComponents + 1;

    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_OUT_LINE_COMPILE;
    } else {


	register int size = tokenPtr[1].size;
	register CONST char *chrs = tokenPtr[1].start;







	if (size < 2) {
	    return TCL_OUT_LINE_COMPILE;
	}
	if ((size <= 6) && (parsePtr->numWords == 5)
		&& !strncmp(chrs, "-exact", (unsigned) TclMin(size, 6))) {



	    mode = Switch_Exact;
	    tokenPtr += 2;

	} else if ((size <= 5) && (parsePtr->numWords == 5)
		&& !strncmp(chrs, "-glob", (unsigned) TclMin(size, 5))) {



	    mode = Switch_Glob;
	    tokenPtr += 2;

	} else if ((size == 2) && (parsePtr->numWords == 4)


		&& !strncmp(chrs, "--", 2)) {
	    /*
	     * If no control flag present, use exact matching (the default).
	     *
	     * We end up re-checking this word, but that's the way things are...
	     */
	    mode = Switch_Exact;


	} else {







	    return TCL_OUT_LINE_COMPILE;
	}


    }
    if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
	|| (tokenPtr[1].size != 2) || strncmp(tokenPtr[1].start, "--", 2)) {





	return TCL_OUT_LINE_COMPILE;
    }
    tokenPtr += 2;

    /*
     * The value to test against is going to always get pushed on the
     * stack.  But not yet; we need to verify that the rest of the
     * command is compilable too.
     */

    valueTokenPtr = tokenPtr;
    tokenPtr += tokenPtr->numComponents + 1;


    /*
     * Test that we've got a suitable body list as a simple (i.e.


     * braced) word, and that the elements of the body are simple

     * words too.  This is really rather nasty indeed.
     */

    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	return TCL_OUT_LINE_COMPILE;
    }
    Tcl_DStringInit(&bodyList);
    Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size);
    if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &argc,
	    &argv) != TCL_OK) {
	Tcl_DStringFree(&bodyList);
	return TCL_OUT_LINE_COMPILE;
    }
    Tcl_DStringFree(&bodyList);
    if (argc == 0 || argc % 2) {
	ckfree((char *)argv);
	return TCL_OUT_LINE_COMPILE;
    }
    bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * argc);
    tokenStartPtr = tokenPtr[1].start;
    while (isspace(UCHAR(*tokenStartPtr))) {
	tokenStartPtr++;
    }
    if (*tokenStartPtr == '{') {
	tokenStartPtr++;

	isTokenBraced = 1;



    } else {
	isTokenBraced = 0;

    }
    for (i=0 ; i<argc ; i++) {
	bodyTokenArray[i].type = TCL_TOKEN_TEXT;
	bodyTokenArray[i].start = tokenStartPtr;

	bodyTokenArray[i].size = strlen(argv[i]);
	bodyTokenArray[i].numComponents = 0;



	tokenStartPtr += bodyTokenArray[i].size;
	/*
	 * Test to see if we have guessed the end of the word


	 * correctly; if not, we can't feed the real string to the
	 * sub-compilation engine, and we're then stuck and so have to
	 * punt out to doing everything at runtime.
	 */
	if (isTokenBraced && *(tokenStartPtr++) != '}') {

	    ckfree((char *)argv);
	    ckfree((char *)bodyTokenArray);
	    return TCL_OUT_LINE_COMPILE;
	}
	if ((tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size)
		&& !isspace(UCHAR(*tokenStartPtr))) {
	    ckfree((char *)argv);
	    ckfree((char *)bodyTokenArray);

	    return TCL_OUT_LINE_COMPILE;



	}

	while (isspace(UCHAR(*tokenStartPtr))) {
	    tokenStartPtr++;
	    if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
		break;
	    }
	}
	if (*tokenStartPtr == '{') {
	    tokenStartPtr++;
	    isTokenBraced = 1;
	} else {
	    isTokenBraced = 0;
	}







    }








    if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {

	ckfree((char *)argv);
	ckfree((char *)bodyTokenArray);
	fprintf(stderr, "BAD ASSUMPTION\n");

	return TCL_OUT_LINE_COMPILE;
    }















    /*
     * Complain if the last body is a continuation.  Note that this


     * check assumes that the list is non-empty!
     */






    if (argc>0 && argv[argc-1][0]=='-' && argv[argc-1]=='\0') {























	ckfree((char *)argv);














	ckfree((char *)bodyTokenArray);



	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Now we commit to generating code; the parsing stage per se is
     * done.
     *
     * First, we push the value we're matching against on the stack.
     */

    if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
		valueTokenPtr[1].size), envPtr);
    } else {
	TclCompileTokens(interp, valueTokenPtr+1,
		valueTokenPtr->numComponents, envPtr);
    }

    /*
     * Generate a test for each arm.
     */

    contFixIndex = -1;

    fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * argc);
    fixupTargetArray = (int *) ckalloc(sizeof(int) * argc);
    (VOID *) memset(fixupTargetArray, 0, argc * sizeof(int));
    fixupCount = 0;
    foundDefault = 0;
    for (i=0 ; i<argc ; i+=2) {
	int nextArmFixupIndex = -1;



	/*
	 * Generate the test for the arm.

	 */


	envPtr->currStackDepth = savedStackDepth + 1;
	if (argv[i][0]!='d' || strcmp(argv[i], "default") || i!=argc-2) {
	    switch (mode) {
	    case Switch_Exact:
		TclEmitOpcode(INST_DUP, envPtr);
		TclEmitPush(TclRegisterNewLiteral(envPtr, argv[i],
			(int) strlen(argv[i])), envPtr);
		TclEmitOpcode(INST_STR_EQ, envPtr);
		break;
	    case Switch_Glob:
		TclEmitPush(TclRegisterNewLiteral(envPtr, argv[i],
			(int) strlen(argv[i])), envPtr);
		TclEmitInstInt4(INST_OVER, 1, envPtr);
		TclEmitInstInt1(INST_STR_MATCH, /*nocase*/0, envPtr);
		break;
	    default:
		Tcl_Panic("unknown switch mode: %d",mode);
	    }

	    /*
	     * Process fall-through clauses here...


	     */
	    if (argv[i+1][0]=='-' && argv[i+1][1]=='\0') {

		if (contFixIndex == -1) {
		    contFixIndex = fixupCount;
		    contFixCount = 0;
		}
		TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
			&fixupArray[contFixIndex+contFixCount]);
		fixupCount++;
		contFixCount++;
		continue;
	    }

	    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
		    &fixupArray[fixupCount]);
	    nextArmFixupIndex = fixupCount;
	    fixupCount++;
	} else {
	    /*
	     * Got a default clause; set a flag.
	     */
	    foundDefault = 1;
	    /*

	     * Note that default clauses (which are always last
	     * clauses) cannot be fall-through clauses as well,
	     * because the last clause is never a fall-through clause.

	     */
	}



	/*
	 * Generate the body for the arm.  This is guaranteed not to
	 * be a fall-through case, but it might have preceding
	 * fall-through cases, so we must process those first.
	 */

	if (contFixIndex != -1) {
	    codeOffset = envPtr->codeNext-envPtr->codeStart;

	    for (j=0 ; j<contFixCount ; j++) {
		fixupTargetArray[contFixIndex+j] = codeOffset;
	    }
	    contFixIndex = -1;
	}

	/*
	 * Now do the actual compilation.


	 */

	TclEmitOpcode(INST_POP, envPtr);
	envPtr->currStackDepth = savedStackDepth + 1;
	TclCompileCmdWord(interp, bodyTokenArray+i+1, 1, envPtr);

	if (!foundDefault) {
	    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
		    &fixupArray[fixupCount]);
	    fixupCount++;
	    fixupTargetArray[nextArmFixupIndex] =
		    envPtr->codeNext-envPtr->codeStart;
	}
    }
    ckfree((char *)argv);

    ckfree((char *)bodyTokenArray);


    /*
     * Discard the value we are matching against unless we've had a
     * default clause (in which case it will already be gone) and make

     * the result of the command an empty string.
     */

    if (!foundDefault) {
	TclEmitOpcode(INST_POP, envPtr);
	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    }

    /*
     * Do jump fixups for arms that were executed.  First, fill in the
     * jumps of all jumps that don't point elsewhere to point to here.
     */
    codeOffset = envPtr->codeNext-envPtr->codeStart;
    for (i=0 ; i<fixupCount ; i++) {
	if (fixupTargetArray[i] == 0) {
	    fixupTargetArray[i] = codeOffset;
	}
    }

    /*
     * Now scan backwards over all the jumps (all of which are forward
     * jumps) doing each one.  When we do one and there is a size
     * changes, we must scan back over all the previous ones and see
     * if they need adjusting before proceeding with further jump
     * fixups.
     */

    for (i=fixupCount-1 ; i>=0 ; i--) {
	if (TclFixupForwardJump(envPtr, &fixupArray[i],
		fixupTargetArray[i]-fixupArray[i].codeOffset, 127)) {

	    for (j=i-1 ; j>=0 ; j--) {
		if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
		    fixupTargetArray[j] += 3;
		}
	    }
	}
    }
    ckfree((char *)fixupArray);
    ckfree((char *)fixupTargetArray);

    envPtr->currStackDepth = savedStackDepth + 1;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileVariableCmd --
 *
 *	Procedure called to reserve the local variables for the 
 *      "variable" command. The command itself is *not* compiled.
 *
 * Results:
 *      Always returns TCL_OUT_LINE_COMPILE.
 *
 * Side effects:
 *      Indexed local variables are added to the environment.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileVariableCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int i, numWords;
    CONST char *varName, *tail;

    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

    numWords = parsePtr->numWords;

    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);
    for (i = 1; i < numWords; i += 2) {



	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {



	    varName = varTokenPtr[1].start;
	    tail = varName + varTokenPtr[1].size - 1;




	    if ((*tail == ')') || (tail < varName)) continue;



	    while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
		tail--;
	    }
	    if ((*tail == ':') && (tail > varName)) {
		tail++;
	    }
	    (void) TclFindCompiledLocal(tail, (tail-varName+1),
		    /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
	    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	}
    }
    return TCL_OUT_LINE_COMPILE;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileWhileCmd --
 *
 *	Procedure called to compile the "while" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "while" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileWhileCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *testTokenPtr, *bodyTokenPtr;
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, jumpDist;
    int range, code;
    int savedStackDepth = envPtr->currStackDepth;
    int loopMayEnd = 1;         /* This is set to 0 if it is recognized as
				 * an infinite loop. */
    Tcl_Obj *boolObj;
    int boolVal;

    if (parsePtr->numWords != 3) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * If the test expression requires substitutions, don't compile the
     * while command inline. E.g., the expression might cause the loop to
     * never execute or execute forever, as in "while "$x < 5" {}".
     *
     * Bail out also if the body expression requires substitutions
     * in order to insure correct behaviour [Bug 219166]
     */

    testTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
    if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
	    || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Find out if the condition is a constant. 
     */

    boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
    Tcl_IncrRefCount(boolObj);
    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
    Tcl_DecrRefCount(boolObj);
    if (code == TCL_OK) {
	if (boolVal) {
	    /*
	     * it is an infinite loop 

	     */

	    loopMayEnd = 0;  
	} else {
	    /*
	     * This is an empty loop: "while 0 {...}" or such.
	     * Compile no bytecodes.
	     */

	    goto pushResult;
	}
    }

    /* 
     * Create a ExceptionRange record for the loop body. This is used to
     * implement break and continue.
     */

    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =
	TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
    range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);

    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "while cond body" produces then:
     *       goto A
     *    B: body                : bodyCodeOffset
     *    A: cond -> result      : testCodeOffset, continueOffset
     *       if (result) goto B
     *
     * The infinite loop "while 1 body" produces:
     *    B: body                : all three offsets here
     *       goto B
     */

    if (loopMayEnd) {
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
	testCodeOffset = 0; /* avoid compiler warning */
    } else {
	testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
    }

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
    TclCompileCmdWord(interp, bodyTokenPtr+1,
	    bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    envPtr->exceptArrayPtr[range].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the while. We already know it's a simple word.
     */

    if (loopMayEnd) {
	testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
	jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
	if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	    bodyCodeOffset += 3;
	    testCodeOffset += 3;
	}
	envPtr->currStackDepth = savedStackDepth;
	TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
	envPtr->currStackDepth = savedStackDepth + 1;

	jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
	if (jumpDist > 127) {
	    TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
	} else {
	    TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
	}
    } else {
	jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
	if (jumpDist > 127) {
	    TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
	} else {
	    TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
	}	
    }


    /*
     * Set the loop's body, continue and break offsets.
     */

    envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
    envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
    envPtr->exceptArrayPtr[range].breakOffset =
	    (envPtr->codeNext - envPtr->codeStart);

    /*
     * The while command's result is an empty string.
     */

    pushResult:
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    envPtr->exceptDepth--;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * PushVarName --
 *
 *	Procedure used in the compiling where pushing a variable name
 *	is necessary (append, lappend, set).
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.
 * 	Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "set" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
PushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
	simpleVarNamePtr, isScalarPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Token *varTokenPtr;	/* Points to a variable token. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    int flags;			/* takes TCL_CREATE_VAR or
				 * TCL_NO_LARGE_INDEX */
    int *localIndexPtr;		/* must not be NULL */
    int *simpleVarNamePtr;	/* must not be NULL */
    int *isScalarPtr;		/* must not be NULL */
{
    register CONST char *p;
    CONST char *name, *elName;
    register int i, n;
    int nameChars, elNameChars, simpleVarName, localIndex;

    Tcl_Token *elemTokenPtr = NULL;
    int elemTokenCount = 0;
    int allocedTokens = 0;
    int removedParen = 0;

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    simpleVarName = 0;
    name = elName = NULL;
    nameChars = elNameChars = 0;
    localIndex = -1;

    /*
     * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
     * curly braces surround the variable name.
     * This really matters for array elements to handle things like
     *    set {x($foo)} 5
     * which raises an undefined var error if we are not careful here.
     */

    if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
	    (varTokenPtr->start[0] != '{')) {
	/*
	 * A simple variable name. Divide it up into "name" and "elName"
	 * strings. If it is not a local variable, look it up at runtime.
	 */
	simpleVarName = 1;

	name = varTokenPtr[1].start;
	nameChars = varTokenPtr[1].size;
	if (name[nameChars-1] == ')') {
	    /* 
	     * last char is ')' => potential array reference.
	     */

	    for (i=0,p=name ; i<nameChars ; i++,p++) {
		if (*p == '(') {
		    elName = p + 1;
		    elNameChars = nameChars - i - 2;
		    nameChars = i;
		    break;
		}
	    }

	    if ((elName != NULL) && elNameChars) {
		/*
		 * An array element, the element name is a simple
		 * string: assemble the corresponding token.
		 */

		elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
		allocedTokens = 1;
		elemTokenPtr->type = TCL_TOKEN_TEXT;
		elemTokenPtr->start = elName;
		elemTokenPtr->size = elNameChars;
		elemTokenPtr->numComponents = 0;
		elemTokenCount = 1;
	    }
	}
    } else if (((n = varTokenPtr->numComponents) > 1)
	    && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
            && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
            && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {

        /*
	 * Check for parentheses inside first token
	 */

        simpleVarName = 0;
        for (i = 0, p = varTokenPtr[1].start; 
	     i < varTokenPtr[1].size; i++, p++) {
            if (*p == '(') {
                simpleVarName = 1;
                break;
            }
        }
        if (simpleVarName) {
	    int remainingChars;

	    /*
	     * Check the last token: if it is just ')', do not count
	     * it. Otherwise, remove the ')' and flag so that it is
	     * restored at the end.
	     */

	    if (varTokenPtr[n].size == 1) {
		--n;
	    } else {
		--varTokenPtr[n].size;
		removedParen = n;
	    }

            name = varTokenPtr[1].start;
            nameChars = p - varTokenPtr[1].start;
            elName = p + 1;
            remainingChars = (varTokenPtr[2].start - p) - 1;
            elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;

	    if (remainingChars) {
		/*
		 * Make a first token with the extra characters in the first 
		 * token.
		 */

		elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
		allocedTokens = 1;
		elemTokenPtr->type = TCL_TOKEN_TEXT;
		elemTokenPtr->start = elName;
		elemTokenPtr->size = remainingChars;
		elemTokenPtr->numComponents = 0;
		elemTokenCount = n;

		/*
		 * Copy the remaining tokens.
		 */

		memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
			((n-1) * sizeof(Tcl_Token)));
	    } else {
		/*
		 * Use the already available tokens.
		 */

		elemTokenPtr = &varTokenPtr[2];
		elemTokenCount = n - 1;	    
	    }
	}
    }

    if (simpleVarName) {
	/*
	 * See whether name has any namespace separators (::'s).
	 */

	int hasNsQualifiers = 0;
	for (i = 0, p = name;  i < nameChars;  i++, p++) {
	    if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
		hasNsQualifiers = 1;
		break;
	    }
	}

	/*
	 * Look up the var name's index in the array of local vars in the
	 * proc frame. If retrieving the var's value and it doesn't already
	 * exist, push its name and look it up at runtime.
	 */

	if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
	    localIndex = TclFindCompiledLocal(name, nameChars,
		    /*create*/ (flags & TCL_CREATE_VAR),
                    /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
		    envPtr->procPtr);
	    if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
		/* we'll push the name */
		localIndex = -1;
	    }
	}
	if (localIndex < 0) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
	}

	/*
	 * Compile the element script, if any.
	 */

	if (elName != NULL) {
	    if (elNameChars) {
		TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
	    } else {
		TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
	    }
	}
    } else {
	/*
	 * The var name isn't simple: compile and push it.
	 */

	TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
    }

    if (removedParen) {
	++varTokenPtr[removedParen].size;
    }
    if (allocedTokens) {
        ckfree((char *) elemTokenPtr);
    }
    *localIndexPtr	= localIndex;
    *simpleVarNamePtr	= simpleVarName;
    *isScalarPtr	= (elName == NULL);
    return TCL_OK;
}















|



|







|
|
|




|



|
<


|
|

|
>











|







<
<
<
<
<
<
<
|
>
>


















|
|


|
|




















|
<




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|
|
|










|



|








|
|
|


|








<
<
|
<
|
|
<
<
<
<
|
>
|


|
|
|
|
|
>
|
>
|
<
<
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
|
|
|
|
|
|
<

|
<
|



|












|
|


|
|







|
|







|




|
|
|
|
|


|
<
<








|
<
|
<
<
<
<
<








|
>
>
|
|
|
|
|
|
|
|
|
|
>

|
<
<
<
|
|
|
|
|
|
|
|
<
<
<
<














|
>
>
>


|
|


|
|







|
|




|
















|



|

|
<






|



|


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
|
|
|
|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|

|
|
|

|
<
<
<
<
|
|
|
<
|
|
<
<
|
<
|
<
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
<
<
|
<
|
|
<
|
|
|
|
<
|
|
<
|
|
|
|
|
|
|

|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|
|
>
>


|
|
>
>
>



>



|
|



>
>

<
<


<

<
<
<

<
>
>
|




|
|
|
|
|
|

|
|
>




|

>
>
>
>
>
>
>


|
|
<
|
<

>
>
>
>
|
<

<

<
<
|
>
>
|


>
>
>
>
>
>
|
|

|
|
>
>
>

|
>
|
<
>
>
>

|
>
|
>
>
|
<
<
<
<
<
<
>
>
|
>
>
>
>
>
>
>
|
|
>
>

|
<
>
>
>
>
>
|

<


|
|
|



|
>


<
>
>
|
>
|


|
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
|
<
|
|
<
<
>
|
>
>
>
|
|
>
|
<
|
|
>
|
|
>
>
>
|

<
>
>
|
<
<

|
>
|
<
|

|
<
<
|
>
|
>
>
>
|
>


<
<
<







>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
>
|
|
<
>
|
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
<
>
>
|
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|



|
<
<



<
<
<
<
|
|
<






>
|
|
|


|

|
>
>
|
|
>
|

>
|
<


<
<
<



<
<
<
|


|

>

|
>
>

|
>





|




>
|
<




|
|
|
<
>
|
|
|
>

|
>
|
>

|
|
|



<
>

|





|
>
>




|



|

|
<


|
>
|
|
>

|
|
>
|




|



|
|

|


|




|
|
|
|
|

>


|
>







|
|










|
|


|






>



|
|







|




|
<

>
>
>
|
>
>
>
|
|
>
>
>
>
|
>
>
>
|
|
|
|
|
|
|
|
|
|
<
|










|
|


|
|







|
|







|
|




|



|
|
|

|
|


|
|
|


|



|









|
>


|


|
|






|




<
<
<
|



















|






|
|
|

<
<








|









|






|




|









|
<





|

|









|
|


|
|


|
|










<
|















|
|
|
|
|









|
|















|














|
|













|
|

|



|
|
|
|
|
|
|
|
|



|
|
|









|
|
|
|
|



|
















|






|


















|
|
|




|
|







|










|







|
|








|
|
|


>
>
>
>
>
>
>
>
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754

2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780







2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828

2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904


2905

2906
2907




2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921


2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944

2945
2946

2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998


2999
3000
3001
3002
3003
3004
3005
3006
3007

3008





3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032



3033
3034
3035
3036
3037
3038
3039
3040




3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103

3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116





















3117
3118

3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151




3152
3153
3154

3155
3156


3157

3158

3159




3160

















3161




























3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188


3189

3190
3191

3192
3193
3194
3195

3196
3197

3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280


3281
3282

3283



3284

3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318

3319

3320
3321
3322
3323
3324
3325

3326

3327


3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351

3352
3353
3354
3355
3356
3357
3358
3359
3360
3361






3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377

3378
3379
3380
3381
3382
3383
3384

3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396

3397
3398
3399
3400
3401
3402
3403
3404


3405








3406



3407

3408
3409


3410
3411
3412
3413
3414
3415
3416
3417
3418

3419
3420
3421
3422
3423
3424
3425
3426
3427
3428

3429
3430
3431


3432
3433
3434
3435

3436
3437
3438


3439
3440
3441
3442
3443
3444
3445
3446
3447
3448



3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475

3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494

3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552


3553
3554
3555




3556
3557

3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581

3582
3583



3584
3585
3586



3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611

3612
3613
3614
3615
3616
3617
3618

3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635

3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657

3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748

3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776

3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866



3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897


3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938

3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975

3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
	anchorRight = 0;
    }

    /*
     * On the first (pattern) arg, check to see if any RE special characters
     * are in the word.  If not, this is the same as 'string equal'.
     */
    if ((len > 1+start) && (str[start] == '.') && (str[start+1] == '*')) {
	start += 2;
	anchorLeft = 0;
    }
    if ((len > 2+start) && (str[len-3] != '\\')
	    && (str[len-2] == '.') && (str[len-1] == '*')) {
	len -= 2;
	str[len] = '\0';
	anchorRight = 0;
    }

    /*
     * Don't do anything with REs with other special chars. Also check if this
     * is a bad RE (do this at the end because it can be expensive). If so,
     * let it complain at runtime.
     */
    if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
	    || (Tcl_RegExpCompile(NULL, str) == NULL)) {
	ckfree((char *) str);
	return TCL_ERROR;
    }

    if (anchorLeft && anchorRight) {
	PushLiteral(envPtr, str+start, len-start);

    } else {
	/*
	 * This needs to find the substring anywhere in the string, so use
	 * [string match] and *foo*, with appropriate anchoring.
	 */
	char *newStr = ckalloc((unsigned) len + 3);

	len -= start;
	if (anchorLeft) {
	    strncpy(newStr, str + start, (size_t) len);
	} else {
	    newStr[0] = '*';
	    strncpy(newStr + 1, str + start, (size_t) len++);
	}
	if (!anchorRight) {
	    newStr[len++] = '*';
	}
	newStr[len] = '\0';
	PushLiteral(envPtr, newStr, len);
	ckfree((char *) newStr);
    }
    ckfree((char *) str);

    /*
     * Push the string arg
     */








    varTokenPtr = TokenAfter(varTokenPtr);
    CompileWord(envPtr, varTokenPtr, interp);

    if (anchorLeft && anchorRight && !nocase) {
	TclEmitOpcode(INST_STR_EQ, envPtr);
    } else {
	TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileReturnCmd --
 *
 *	Procedure called to compile the "return" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "return" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileReturnCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * General syntax: [return ?-option value ...? ?result?]
     * An even number of words means an explicit result argument is present.
     */
    int level, code, status = TCL_OK;
    int numWords = parsePtr->numWords;
    int explicitResult = (0 == (numWords % 2));
    int numOptionWords = numWords - 1 - explicitResult;
    Tcl_Obj *returnOpts;
    Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);

#define NUM_STATIC_OBJS 20
    int objc;
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;

    /*
     * Check for special case which can always be compiled:
     *	    return -options <opts> <msg>
     * Unlike the normal [return] compilation, this version does everything at
     * runtime so it can handle arbitrary words and not just literals. Note
     * that if INST_RETURN_STK wasn't already needed for something else
     * ('finally' clause processing) this piece of code would not be present.
     */

    if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
	    && (wordTokenPtr[1].size == 8)
	    && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
	Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
	Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);

	CompileWord(envPtr, optsTokenPtr, interp);
	CompileWord(envPtr, msgTokenPtr, interp);
	TclEmitOpcode(INST_RETURN_STK, envPtr);
	return TCL_OK;
    }

    /*
     * Allocate some working space if needed
     */

    if (numOptionWords > NUM_STATIC_OBJS) {
	objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *));
    } else {
	objv = staticObjArray;
    }

    /*
     * Scan through the return options.  If any are unknown at compile time,
     * there is no value in bytecompiling.  Save the option values known in an
     * objv array for merging into a return options dictionary.
     */

    for (objc = 0; objc < numOptionWords; objc++) {
	objv[objc] = Tcl_NewObj();
	Tcl_IncrRefCount(objv[objc]);
	if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
	    objc++;
	    status = TCL_ERROR;
	    goto cleanup;
	}
	wordTokenPtr = TokenAfter(wordTokenPtr);
    }
    status = TclMergeReturnOptions(interp, objc, objv,
	    &returnOpts, &code, &level);
  cleanup:
    while (--objc >= 0) {
	Tcl_DecrRefCount(objv[objc]);
    }
    if (numOptionWords > NUM_STATIC_OBJS) {
	ckfree((char *)objv);
    }
    if (TCL_ERROR == status) {
	/*
	 * Something was bogus in the return options. Clear the error message,
	 * and report back to the compiler that this must be interpreted at
	 * runtime.
	 */
	Tcl_ResetResult(interp);
	return TCL_ERROR;
    }

    /*
     * All options are known at compile time, so we're going to bytecompile.
     * Emit instructions to push the result on the stack
     */

    if (explicitResult) {


	CompileWord(envPtr, wordTokenPtr, interp);

    } else {
	/*




	 * No explict result argument, so default result is empty string.
	 */
	PushLiteral(envPtr, "", 0);
    }

    /*
     * Check for optimization: When [return] is in a proc, and there's no
     * enclosing [catch], and there are no return options, then the INST_DONE
     * instruction is equivalent, and may be more efficient.
     */

    if (numOptionWords == 0 && envPtr->procPtr != NULL) {
	/*
	 * We have default return options and we're in a proc ...


	 */
	int index = envPtr->exceptArrayNext - 1;
	int enclosingCatch = 0;
	while (index >= 0) {
	    ExceptionRange range = envPtr->exceptArrayPtr[index];
	    if ((range.type == CATCH_EXCEPTION_RANGE)
		    && (range.catchOffset == -1)) {
		enclosingCatch = 1;
		break;
	    }
	    index--;
	}
	if (!enclosingCatch) {
	    /*
	     * ... and there is no enclosing catch. Issue the maximally
	     * efficient exit instruction.
	     */
	    Tcl_DecrRefCount(returnOpts);
	    TclEmitOpcode(INST_DONE, envPtr);
	    return TCL_OK;
	}
    }


    /*
     * Could not use the optimization, so we push the return options dict, and

     * emit the INST_RETURN_IMM instruction with code and level as operands.
     */

    TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
    TclEmitInstInt4(INST_RETURN_IMM, code, envPtr);
    TclEmitInt4(level, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "set" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileSetCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr, *valueTokenPtr;
    int isAssignment, isScalar, simpleVarName, localIndex, numWords;

    numWords = parsePtr->numWords;
    if ((numWords != 2) && (numWords != 3)) {
	return TCL_ERROR;
    }
    isAssignment = (numWords == 3);

    /*
     * Decide if we can use a frame slot for the var/array name or if we need
     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);


    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
	    &localIndex, &simpleVarName, &isScalar);

    /*
     * If we are doing an assignment, push the new value.
     */

    if (isAssignment) {
	valueTokenPtr = TokenAfter(varTokenPtr);

	CompileWord(envPtr, valueTokenPtr, interp);





    }

    /*
     * Emit instructions to set/get the variable.
     */

    if (simpleVarName) {
	if (isScalar) {
	    if (localIndex < 0) {
		TclEmitOpcode((isAssignment?
		        INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
	    } else if (localIndex <= 255) {
		TclEmitInstInt1((isAssignment?
			INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
			localIndex, envPtr);
	    } else {
		TclEmitInstInt4((isAssignment?
			INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
			localIndex, envPtr);
	    }
	} else {
	    if (localIndex < 0) {
		TclEmitOpcode((isAssignment?
			INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);



	    } else if (localIndex <= 255) {
		TclEmitInstInt1((isAssignment?
			INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
			localIndex, envPtr);
	    } else {
		TclEmitInstInt4((isAssignment?
			INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
			localIndex, envPtr);




	    }
	}
    } else {
	TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileStringCmd --
 *
 *	Procedure called to compile the "string" command. Generally speaking,
 *	these are mostly various kinds of peephole optimizations; most string
 *	operations are handled by executing the interpreted version of the
 *	command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "string" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileStringCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *opTokenPtr, *varTokenPtr;
    Tcl_Obj *opObj;
    int i, index;

    static CONST char *options[] = {
	"bytelength",	"compare",	"equal",	"first",
	"index",	"is",		"last",		"length",
	"map",		"match",	"range",	"repeat",
	"replace",	"tolower",	"toupper",	"totitle",
	"trim",		"trimleft",	"trimright",
	"wordend",	"wordstart",	(char *) NULL
    };
    enum options {
	STR_BYTELENGTH,	STR_COMPARE,	STR_EQUAL,	STR_FIRST,
	STR_INDEX,	STR_IS,		STR_LAST,	STR_LENGTH,
	STR_MAP,	STR_MATCH,	STR_RANGE,	STR_REPEAT,
	STR_REPLACE,	STR_TOLOWER,	STR_TOUPPER,	STR_TOTITLE,
	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
	STR_WORDEND,	STR_WORDSTART
    };

    if (parsePtr->numWords < 2) {
	/* Fail at run time, not in compilation */
	return TCL_ERROR;
    }
    opTokenPtr = TokenAfter(parsePtr->tokenPtr);


    opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
    if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
	    &index) != TCL_OK) {
	Tcl_DecrRefCount(opObj);
	Tcl_ResetResult(interp);
	return TCL_ERROR;
    }
    Tcl_DecrRefCount(opObj);

    varTokenPtr = TokenAfter(opTokenPtr);

    switch ((enum options) index) {





















    case STR_COMPARE:
    case STR_EQUAL:

	/*
	 * If there are any flags to the command, we can't byte compile it
	 * because the INST_STR_EQ bytecode doesn't support flags.
	 */

	if (parsePtr->numWords != 4) {
	    return TCL_ERROR;
	}

	/*
	 * Push the two operands onto the stack.
	 */

	for (i = 0; i < 2; i++) {
	    CompileWord(envPtr, varTokenPtr, interp);
	    varTokenPtr = TokenAfter(varTokenPtr);
	}

	TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
		INST_STR_CMP : INST_STR_EQ), envPtr);
	return TCL_OK;

    case STR_INDEX:
	if (parsePtr->numWords != 4) {
	    /* Fail at run time, not in compilation */
	    return TCL_ERROR;
	}

	/*
	 * Push the two operands onto the stack.
	 */

	for (i = 0; i < 2; i++) {




	    CompileWord(envPtr, varTokenPtr, interp);
	    varTokenPtr = TokenAfter(varTokenPtr);
	}


	TclEmitOpcode(INST_STR_INDEX, envPtr);


	return TCL_OK;

    case STR_MATCH: {

	int length, exactMatch = 0, nocase = 0;




	CONST char *str;














































	if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
	    /* Fail at run time, not in compilation */
	    return TCL_ERROR;
	}

	if (parsePtr->numWords == 5) {
	    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		return TCL_ERROR;
	    }
	    str = varTokenPtr[1].start;
	    length = varTokenPtr[1].size;
	    if ((length > 1) &&
		    strncmp(str, "-nocase", (size_t) length) == 0) {
		nocase = 1;
	    } else {
		/* Fail at run time, not in compilation */
		return TCL_ERROR;
	    }
	    varTokenPtr = TokenAfter(varTokenPtr);
	}

	for (i = 0; i < 2; i++) {
	    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		str = varTokenPtr[1].start;
		length = varTokenPtr[1].size;
		if (!nocase && (i == 0)) {
		    /*


		     * Trivial matches can be done by 'string equal'. If

		     * -nocase was specified, we can't do this because
		     * INST_STR_EQ has no support for nocase.

		     */
		    Tcl_Obj *copy = Tcl_NewStringObj(str, length);
		    Tcl_IncrRefCount(copy);
		    exactMatch = TclMatchIsTrivial(Tcl_GetString(copy));

		    Tcl_DecrRefCount(copy);
		}

		PushLiteral(envPtr, str, length);
	    } else {
		TclCompileTokens(interp, varTokenPtr+1,
			varTokenPtr->numComponents, envPtr);
	    }
	    varTokenPtr = TokenAfter(varTokenPtr);
	}

	if (exactMatch) {
	    TclEmitOpcode(INST_STR_EQ, envPtr);
	} else {
	    TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
	}
	return TCL_OK;
    }
    case STR_LENGTH:
	if (parsePtr->numWords != 3) {
	    /* Fail at run time, not in compilation */
	    return TCL_ERROR;
	}

	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    /*
	     * Here someone is asking for the length of a static string. Just
	     * push the actual character (not byte) length.
	     */
	    char buf[TCL_INTEGER_SPACE];
	    int len = Tcl_NumUtfChars(varTokenPtr[1].start,
		    varTokenPtr[1].size);
	    len = sprintf(buf, "%d", len);
	    PushLiteral(envPtr, buf, len);
	    return TCL_OK;
	} else {
	    TclCompileTokens(interp, varTokenPtr+1,
		    varTokenPtr->numComponents, envPtr);
	}
	TclEmitOpcode(INST_STR_LEN, envPtr);
	return TCL_OK;

    default:
	/*
	 * All other cases: compile out of line.
	 */
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileSwitchCmd --
 *
 *	Procedure called to compile the "switch" command.
 *
 * Results:
 * 	Returns TCL_OK for successful compile, or TCL_ERROR to defer
 * 	evaluation to runtime (either when it is too complex to get the
 * 	semantics right, or when we know for sure that it is an error but need
 * 	the error to happen at the right time).
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "switch" command at
 *	runtime.
 *
 * FIXME:
 *	Stack depths are probably not calculated correctly.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileSwitchCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;	/* Pointer to tokens in command */
    int numWords;		/* Number of words in command */

    Tcl_Token *valueTokenPtr;	/* Token for the value to switch on. */


    enum {Switch_Exact, Switch_Glob} mode;
				/* What kind of switch are we doing? */





    Tcl_Token *bodyTokenArray;	/* Array of real pattern list items. */

    Tcl_Token **bodyToken;	/* Array of pointers to pattern list items. */
    int foundDefault;		/* Flag to indicate whether a "default" clause
				 * is present. */

    JumpFixup *fixupArray;	/* Array of forward-jump fixup records. */
    int *fixupTargetArray;	/* Array of places for fixups to point at. */
    int fixupCount;		/* Number of places to fix up. */
    int contFixIndex;		/* Where the first of the jumps due to a group
				 * of continuation bodies starts, or -1 if
				 * there aren't any. */
    int contFixCount;		/* Number of continuation bodies pointing to
				 * the current (or next) real body. */

    int savedStackDepth = envPtr->currStackDepth;
    int noCase;			/* Has the -nocase flag been given? */
    int foundMode = 0;		/* Have we seen a mode flag yet? */
    int i;

    /*
     * Only handle the following versions:
     *   switch        -- word {pattern body ...}
     *   switch -exact -- word {pattern body ...}
     *   switch -glob  -- word {pattern body ...}
     *   switch        -- word simpleWordPattern simpleWordBody ...
     *   switch -exact -- word simpleWordPattern simpleWordBody ...
     *   switch -glob  -- word simpleWordPattern simpleWordBody ...
     * When the mode is -glob, can also handle a -nocase flag.
     *
     * First off, we don't care how the command's word was generated; we're
     * compiling it anyway! So skip it...
     */

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    numWords = parsePtr->numWords-1;



    /*
     * Check for options. There must be at least one, --, because without that
     * there is no way to statically avoid the problems you get from strings-
     * -to-be-matched that start with a - (the interpreted code falls apart if
     * it encounters them, so we punt if we *might* encounter them as that is
     * the easiest way of emulating the behaviour).

     */




    noCase = 0;
    mode = Switch_Exact;
    for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
	register unsigned size = tokenPtr[1].size;
	register CONST char *chrs = tokenPtr[1].start;

	/*
	 * We only process literal options, and we assume that -e, -g and -n
	 * are unique prefixes of -exact, -glob and -nocase respectively (true
	 * at time of writing). Note that -exact and -glob may only be given
	 * at most once or we bail out (error case).
	 */
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
	    return TCL_ERROR;
	}

	if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
	    if (foundMode) {
		return TCL_ERROR;
	    }
	    mode = Switch_Exact;
	    foundMode = 1;
	    continue;
	} else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {

	    if (foundMode) {
		return TCL_ERROR;
	    }
	    mode = Switch_Glob;
	    foundMode = 1;
	    continue;
	} else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
	    noCase = 1;
	    continue;
	} else if ((size == 2) && !memcmp(chrs, "--", 2)) {






	    break;
	}

	/*
	 * The switch command has many flags we cannot compile at all (e.g.
	 * all the RE-related ones) which we must have encountered.  Either
	 * that or we have run off the end. The action here is the same: punt
	 * to interpreted version.
	 */

	return TCL_ERROR;
    }
    if (numWords < 3) {
	return TCL_ERROR;
    }
    tokenPtr = TokenAfter(tokenPtr);

    numWords--;
    if (noCase && (mode == Switch_Exact)) {
	/*
	 * Can't compile this case; no opcode for case-insensitive equality!
	 */
	return TCL_ERROR;
    }


    /*
     * The value to test against is going to always get pushed on the stack.
     * But not yet; we need to verify that the rest of the command is
     * compilable too.
     */

    valueTokenPtr = tokenPtr;
    tokenPtr = TokenAfter(tokenPtr);
    numWords--;

    /*

     * Build an array of tokens for the matcher terms and script bodies. Note
     * that in the case of the quoted bodies, this is tricky as we cannot use
     * copies of the string from the input token for the generated tokens (it
     * causes a crash during exception handling). When multiple tokens are
     * available at this point, this is pretty easy.
     */

    if (numWords == 1) {


	Tcl_DString bodyList;








	CONST char **argv = NULL;



	int isTokenBraced;

	CONST char *tokenStartPtr;



	/*
	 * Test that we've got a suitable body list as a simple (i.e. braced)
	 * word, and that the elements of the body are simple words too. This
	 * is really rather nasty indeed.
	 */

	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}

	Tcl_DStringInit(&bodyList);
	Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size);
	if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords,
		&argv) != TCL_OK) {
	    Tcl_DStringFree(&bodyList);
	    return TCL_ERROR;
	}
	Tcl_DStringFree(&bodyList);

	/*

	 * Now we know what the switch arms are, we've got to see whether we
	 * can synthesize tokens for the arms. First check whether we've got a
	 * valid number of arms since we can do that now.


	 */

	if (numWords == 0 || numWords % 2) {
	    ckfree((char *) argv);

	    return TCL_ERROR;
	}



	bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords);
	bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);

	/*
	 * Locate the start of the arms within the overall word.
	 */

	tokenStartPtr = tokenPtr[1].start;
	while (isspace(UCHAR(*tokenStartPtr))) {
	    tokenStartPtr++;



	}
	if (*tokenStartPtr == '{') {
	    tokenStartPtr++;
	    isTokenBraced = 1;
	} else {
	    isTokenBraced = 0;
	}
	for (i=0 ; i<numWords ; i++) {
	    bodyTokenArray[i].type = TCL_TOKEN_TEXT;
	    bodyTokenArray[i].start = tokenStartPtr;
	    bodyTokenArray[i].size = strlen(argv[i]);
	    bodyTokenArray[i].numComponents = 0;
	    bodyToken[i] = bodyTokenArray+i;
	    tokenStartPtr += bodyTokenArray[i].size;

	    /*
	     * Test to see if we have guessed the end of the word correctly;
	     * if not, we can't feed the real string to the sub-compilation
	     * engine, and we're then stuck and so have to punt out to doing
	     * everything at runtime.
	     */

	    if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
		    (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
		    && !isspace(UCHAR(*tokenStartPtr)))) {
		ckfree((char *) argv);
		ckfree((char *) bodyToken);

		ckfree((char *) bodyTokenArray);
		return TCL_ERROR;
	    }
	    while (isspace(UCHAR(*tokenStartPtr))) {
		tokenStartPtr++;
		if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
		    break;
		}
	    }
	    if (*tokenStartPtr == '{') {
		tokenStartPtr++;
		isTokenBraced = 1;
	    } else {
		isTokenBraced = 0;
	    }
	}
	ckfree((char *)argv);

	/*

	 * Check that we've parsed everything we thought we were going to
	 * parse. If not, something odd is going on (I believe it is possible
	 * to defeat the code above) and we should bail out.
	 */

	if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {
	    ckfree((char *) bodyToken);
	    ckfree((char *) bodyTokenArray);
	    return TCL_ERROR;
	}

    } else if (numWords % 2 || numWords == 0) {
	/*
	 * Odd number of words (>1) available, or no words at all available.
	 * Both are error cases, so punt and let the interpreted-version
	 * generate the error message. Note that the second case probably
	 * should get caught earlier, but it's easy to check here again anyway
	 * because it'd cause a nasty crash otherwise.
	 */

	return TCL_ERROR;

    } else {
	bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
	bodyTokenArray = NULL;
	for (i=0 ; i<numWords ; i++) {
	    /*
	     * We only handle the very simplest case. Anything more complex is
	     * a good reason to go to the interpreted case anyway due to
	     * traces, etc.
	     */

	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
		    tokenPtr->numComponents != 1) {
		ckfree((char *) bodyToken);
		return TCL_ERROR;
	    }
	    bodyToken[i] = tokenPtr+1;
	    tokenPtr = TokenAfter(tokenPtr);
	}
    }

    /*
     * Fall back to interpreted if the last body is a continuation (it's
     * illegal, but this makes the error happen at the right time).
     */

    if (bodyToken[numWords-1]->size == 1 &&
	    bodyToken[numWords-1]->start[0] == '-') {
	ckfree((char *) bodyToken);
	if (bodyTokenArray != NULL) {
	    ckfree((char *) bodyTokenArray);
	}
	return TCL_ERROR;
    }

    /*
     * Now we commit to generating code; the parsing stage per se is done.


     * First, we push the value we're matching against on the stack.
     */





    TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents,
	    envPtr);


    /*
     * Generate a test for each arm.
     */

    contFixIndex = -1;
    contFixCount = 0;
    fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords);
    fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords);
    memset(fixupTargetArray, 0, numWords * sizeof(int));
    fixupCount = 0;
    foundDefault = 0;
    for (i=0 ; i<numWords ; i+=2) {
	int nextArmFixupIndex = -1;
	envPtr->currStackDepth = savedStackDepth + 1;
	if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
		memcmp(bodyToken[numWords-2]->start, "default", 7)) {
	    /*
	     * Generate the test for the arm. This code is slightly
	     * inefficient, but much simpler than the first version.
	     */

	    TclCompileTokens(interp, bodyToken[i], 1, envPtr);
	    TclEmitInstInt4(INST_OVER, 1, envPtr);

	    switch (mode) {
	    case Switch_Exact:



		TclEmitOpcode(INST_STR_EQ, envPtr);
		break;
	    case Switch_Glob:



		TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
		break;
	    default:
		Tcl_Panic("unknown switch mode: %d", mode);
	    }

	    /*
	     * In a fall-through case, we will jump on _true_ to the place
	     * where the body starts (generated later, with guarantee of this
	     * ensured earlier; the final body is never a fall-through).
	     */

	    if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') {
		if (contFixIndex == -1) {
		    contFixIndex = fixupCount;
		    contFixCount = 0;
		}
		TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
			fixupArray+contFixIndex+contFixCount);
		fixupCount++;
		contFixCount++;
		continue;
	    }

	    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount);

	    nextArmFixupIndex = fixupCount;
	    fixupCount++;
	} else {
	    /*
	     * Got a default clause; set a flag to inhibit the generation of
	     * the jump after the body and the cleanup of the intermediate
	     * value that we are switching against.

	     *
	     * Note that default clauses (which are always terminal clauses)
	     * cannot be fall-through clauses as well, since the last clause
	     * is never a fall-through clause (which we have already
	     * verified).
	     */

	    foundDefault = 1;
	}

	/*
	 * Generate the body for the arm.  This is guaranteed not to be a
	 * fall-through case, but it might have preceding fall-through cases,
	 * so we must process those first.
	 */

	if (contFixIndex != -1) {

	    int j;
	    for (j=0 ; j<contFixCount ; j++) {
		fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr);
	    }
	    contFixIndex = -1;
	}

	/*
	 * Now do the actual compilation. Note that we do not use CompileBody
	 * because we may have synthesized the tokens in a non-standard
	 * pattern.
	 */

	TclEmitOpcode(INST_POP, envPtr);
	envPtr->currStackDepth = savedStackDepth + 1;
	TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);

	if (!foundDefault) {
	    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
		    fixupArray+fixupCount);
	    fixupCount++;
	    fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);

	}
    }
    ckfree((char *) bodyToken);
    if (bodyTokenArray != NULL) {
	ckfree((char *) bodyTokenArray);
    }

    /*
     * Discard the value we are matching against unless we've had a default
     * clause (in which case it will already be gone due to the code at the
     * start of processing an arm, guaranteed) and make the result of the
     * command an empty string.
     */

    if (!foundDefault) {
	TclEmitOpcode(INST_POP, envPtr);
	PushLiteral(envPtr, "", 0);
    }

    /*
     * Do jump fixups for arms that were executed.  First, fill in the jumps
     * of all jumps that don't point elsewhere to point to here.
     */

    for (i=0 ; i<fixupCount ; i++) {
	if (fixupTargetArray[i] == 0) {
	    fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
	}
    }

    /*
     * Now scan backwards over all the jumps (all of which are forward jumps)
     * doing each one.  When we do one and there is a size changes, we must
     * scan back over all the previous ones and see if they need adjusting
     * before proceeding with further jump fixups (the interleaved nature of
     * all the jumps makes this impossible to do without nested loops).
     */

    for (i=fixupCount-1 ; i>=0 ; i--) {
	if (TclFixupForwardJump(envPtr, &fixupArray[i],
		fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
	    int j;
	    for (j=i-1 ; j>=0 ; j--) {
		if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
		    fixupTargetArray[j] += 3;
		}
	    }
	}
    }
    ckfree((char *) fixupArray);
    ckfree((char *) fixupTargetArray);

    envPtr->currStackDepth = savedStackDepth + 1;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileVariableCmd --
 *
 *	Procedure called to reserve the local variables for the "variable"
 *	command. The command itself is *not* compiled.
 *
 * Results:
 *      Always returns TCL_ERROR.
 *
 * Side effects:
 *      Indexed local variables are added to the environment.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileVariableCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int i, numWords;
    CONST char *varName, *tail;

    if (envPtr->procPtr == NULL) {
	return TCL_ERROR;
    }

    numWords = parsePtr->numWords;

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);

    for (i = 1; i < numWords; i += 2) {
	/*
	 * Skip non-literals.
	 */
	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    continue;
	}

	varName = varTokenPtr[1].start;
	tail = varName + varTokenPtr[1].size - 1;

	/*
	 * Skip if it looks like it might be an array or an empty string.
	 */
	if ((*tail == ')') || (tail < varName)) {
	    continue;
	}

	while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
	    tail--;
	}
	if ((*tail == ':') && (tail > varName)) {
	    tail++;
	}
	(void) TclFindCompiledLocal(tail, tail-varName+1,
		/*create*/ 1, /*flags*/ 0, envPtr->procPtr);
	varTokenPtr = TokenAfter(varTokenPtr);
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileWhileCmd --
 *
 *	Procedure called to compile the "while" command.
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "while" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileWhileCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *testTokenPtr, *bodyTokenPtr;
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, jumpDist;
    int range, code;
    int savedStackDepth = envPtr->currStackDepth;
    int loopMayEnd = 1;		/* This is set to 0 if it is recognized as an
				 * infinite loop. */
    Tcl_Obj *boolObj;
    int boolVal;

    if (parsePtr->numWords != 3) {
	return TCL_ERROR;
    }

    /*
     * If the test expression requires substitutions, don't compile the while
     * command inline. E.g., the expression might cause the loop to never
     * execute or execute forever, as in "while "$x < 5" {}".
     *
     * Bail out also if the body expression requires substitutions in order to
     * insure correct behaviour [Bug 219166]
     */

    testTokenPtr = TokenAfter(parsePtr->tokenPtr);
    bodyTokenPtr = TokenAfter(testTokenPtr);

    if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
	    || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
	return TCL_ERROR;
    }

    /*
     * Find out if the condition is a constant.
     */

    boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
    Tcl_IncrRefCount(boolObj);
    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
    Tcl_DecrRefCount(boolObj);
    if (code == TCL_OK) {
	if (boolVal) {
	    /*
	     * It is an infinite loop; flag it so that we generate a more
	     * efficient body.
	     */

	    loopMayEnd = 0;
	} else {
	    /*
	     * This is an empty loop: "while 0 {...}" or such.  Compile no
	     * bytecodes.
	     */

	    goto pushResult;
	}
    }

    /*
     * Create a ExceptionRange record for the loop body. This is used to
     * implement break and continue.
     */




    range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);

    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "while cond body" produces then:
     *       goto A
     *    B: body                : bodyCodeOffset
     *    A: cond -> result      : testCodeOffset, continueOffset
     *       if (result) goto B
     *
     * The infinite loop "while 1 body" produces:
     *    B: body                : all three offsets here
     *       goto B
     */

    if (loopMayEnd) {
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
	testCodeOffset = 0; /* avoid compiler warning */
    } else {
	testCodeOffset = CurrentOffset(envPtr);
    }

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
    CompileBody(envPtr, bodyTokenPtr, interp);
    ExceptionRangeEnds(envPtr, range);
    envPtr->currStackDepth = savedStackDepth + 1;


    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the while. We already know it's a simple word.
     */

    if (loopMayEnd) {
	testCodeOffset = CurrentOffset(envPtr);
	jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
	if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
	    bodyCodeOffset += 3;
	    testCodeOffset += 3;
	}
	envPtr->currStackDepth = savedStackDepth;
	TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
	envPtr->currStackDepth = savedStackDepth + 1;

	jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
	if (jumpDist > 127) {
	    TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
	} else {
	    TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
	}
    } else {
	jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
	if (jumpDist > 127) {
	    TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
	} else {
	    TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
	}
    }


    /*
     * Set the loop's body, continue and break offsets.
     */

    envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
    envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
    ExceptionRangeTarget(envPtr, range, breakOffset);


    /*
     * The while command's result is an empty string.
     */

  pushResult:
    envPtr->currStackDepth = savedStackDepth;
    PushLiteral(envPtr, "", 0);
    envPtr->exceptDepth--;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * PushVarName --
 *
 *	Procedure used in the compiling where pushing a variable name is
 *	necessary (append, lappend, set).
 *
 * Results:
 * 	Returns TCL_OK for a successful compile.  Returns TCL_ERROR to defer
 * 	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "set" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

static int
PushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
	simpleVarNamePtr, isScalarPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Token *varTokenPtr;	/* Points to a variable token. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */

    int flags;			/* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX */
    int *localIndexPtr;		/* must not be NULL */
    int *simpleVarNamePtr;	/* must not be NULL */
    int *isScalarPtr;		/* must not be NULL */
{
    register CONST char *p;
    CONST char *name, *elName;
    register int i, n;
    int nameChars, elNameChars, simpleVarName, localIndex;

    Tcl_Token *elemTokenPtr = NULL;
    int elemTokenCount = 0;
    int allocedTokens = 0;
    int removedParen = 0;

    /*
     * Decide if we can use a frame slot for the var/array name or if we need
     * to emit code to compute and push the name at runtime. We use a frame
     * slot (entry in the array of local vars) if we are compiling a procedure
     * body and if the name is simple text that does not include namespace
     * qualifiers.
     */

    simpleVarName = 0;
    name = elName = NULL;
    nameChars = elNameChars = 0;
    localIndex = -1;

    /*
     * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
     * curly braces surround the variable name. This really matters for array
     * elements to handle things like
     *    set {x($foo)} 5
     * which raises an undefined var error if we are not careful here.
     */

    if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
	    (varTokenPtr->start[0] != '{')) {
	/*
	 * A simple variable name. Divide it up into "name" and "elName"
	 * strings. If it is not a local variable, look it up at runtime.
	 */
	simpleVarName = 1;

	name = varTokenPtr[1].start;
	nameChars = varTokenPtr[1].size;
	if (name[nameChars-1] == ')') {
	    /*
	     * last char is ')' => potential array reference.
	     */

	    for (i=0,p=name ; i<nameChars ; i++,p++) {
		if (*p == '(') {
		    elName = p + 1;
		    elNameChars = nameChars - i - 2;
		    nameChars = i;
		    break;
		}
	    }

	    if ((elName != NULL) && elNameChars) {
		/*
		 * An array element, the element name is a simple string:
		 * assemble the corresponding token.
		 */

		elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
		allocedTokens = 1;
		elemTokenPtr->type = TCL_TOKEN_TEXT;
		elemTokenPtr->start = elName;
		elemTokenPtr->size = elNameChars;
		elemTokenPtr->numComponents = 0;
		elemTokenCount = 1;
	    }
	}
    } else if (((n = varTokenPtr->numComponents) > 1)
	    && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
	    && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
	    && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {

	/*
	 * Check for parentheses inside first token
	 */

	simpleVarName = 0;
	for (i = 0, p = varTokenPtr[1].start;
		i < varTokenPtr[1].size; i++, p++) {
	    if (*p == '(') {
		simpleVarName = 1;
		break;
	    }
	}
	if (simpleVarName) {
	    int remainingChars;

	    /*
	     * Check the last token: if it is just ')', do not count it.
	     * Otherwise, remove the ')' and flag so that it is restored at
	     * the end.
	     */

	    if (varTokenPtr[n].size == 1) {
		--n;
	    } else {
		--varTokenPtr[n].size;
		removedParen = n;
	    }

	    name = varTokenPtr[1].start;
	    nameChars = p - varTokenPtr[1].start;
	    elName = p + 1;
	    remainingChars = (varTokenPtr[2].start - p) - 1;
	    elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;

	    if (remainingChars) {
		/*
		 * Make a first token with the extra characters in the first
		 * token.
		 */

		elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
		allocedTokens = 1;
		elemTokenPtr->type = TCL_TOKEN_TEXT;
		elemTokenPtr->start = elName;
		elemTokenPtr->size = remainingChars;
		elemTokenPtr->numComponents = 0;
		elemTokenCount = n;

		/*
		 * Copy the remaining tokens.
		 */

		memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
			(n-1) * sizeof(Tcl_Token));
	    } else {
		/*
		 * Use the already available tokens.
		 */

		elemTokenPtr = &varTokenPtr[2];
		elemTokenCount = n - 1;
	    }
	}
    }

    if (simpleVarName) {
	/*
	 * See whether name has any namespace separators (::'s).
	 */

	int hasNsQualifiers = 0;
	for (i = 0, p = name;  i < nameChars;  i++, p++) {
	    if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
		hasNsQualifiers = 1;
		break;
	    }
	}

	/*
	 * Look up the var name's index in the array of local vars in the proc
	 * frame. If retrieving the var's value and it doesn't already exist,
	 * push its name and look it up at runtime.
	 */

	if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
	    localIndex = TclFindCompiledLocal(name, nameChars,
		    /*create*/ flags & TCL_CREATE_VAR,
		    /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
		    envPtr->procPtr);
	    if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
		/* we'll push the name */
		localIndex = -1;
	    }
	}
	if (localIndex < 0) {
	    PushLiteral(envPtr, name, nameChars);
	}

	/*
	 * Compile the element script, if any.
	 */

	if (elName != NULL) {
	    if (elNameChars) {
		TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
	    } else {
		PushLiteral(envPtr, "", 0);
	    }
	}
    } else {
	/*
	 * The var name isn't simple: compile and push it.
	 */

	TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents,
		envPtr);
    }

    if (removedParen) {
	++varTokenPtr[removedParen].size;
    }
    if (allocedTokens) {
        ckfree((char *) elemTokenPtr);
    }
    *localIndexPtr = localIndex;
    *simpleVarNamePtr = simpleVarName;
    *isScalarPtr = (elName == NULL);
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCompExpr.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
/* 
 * tclCompExpr.c --
 *
 *	This file contains the code to compile Tcl expressions.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompExpr.c,v 1.25 2004/10/08 15:39:52 dkf Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * The stuff below is a bit of a hack so that this file can be used in
 * environments that include no UNIX, i.e. no errno: just arrange to use
 * the errno from tclExecute.c here.
 */

#ifdef TCL_GENERIC_ONLY
#define NO_ERRNO_H
#endif

#ifdef NO_ERRNO_H
extern int errno;			/* Use errno from tclExecute.c. */
#define ERANGE 34
#endif

/*
 * Boolean variable that controls whether expression compilation tracing
 * is enabled.
 */

#ifdef TCL_COMPILE_DEBUG
static int traceExprComp = 0;
#endif /* TCL_COMPILE_DEBUG */

/*
 * The ExprInfo structure describes the state of compiling an expression.
 * A pointer to an ExprInfo record is passed among the routines in
 * this module.
 */

typedef struct ExprInfo {
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Structure filled with information about
				 * the parsed expression. */
    CONST char *expr;		/* The expression that was originally passed
				 * to TclCompileExpr. */
    CONST char *lastChar;	/* Points just after last byte of expr. */
    int hasOperators;		/* Set 1 if the expr has operators; 0 if
				 * expr is only a primary. If 1 after
				 * compiling an expr, a tryCvtToNumeric
				 * instruction is emitted to convert the
				 * primary to a number if possible. */
} ExprInfo;

/*
 * Definitions of numeric codes representing each expression operator.
 * The order of these must match the entries in the operatorTable below.
 * Also the codes for the relational operators (OP_LESS, OP_GREATER, 
 * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order.
 * Note that OP_PLUS and OP_MINUS represent both unary and binary operators.
 */

#define OP_MULT		0
#define OP_DIVIDE	1
#define OP_MOD		2
#define OP_PLUS		3
#define OP_MINUS	4
|







|
|

|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|







|
|
<




|
|



|
|
|
|
|



|
|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18















19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
/*
 * tclCompExpr.c --
 *
 *	This file contains the code to compile Tcl expressions.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompExpr.c,v 1.25.2.4 2005/08/22 03:49:39 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*















 * Boolean variable that controls whether expression compilation tracing is
 * enabled.
 */

#ifdef TCL_COMPILE_DEBUG
static int traceExprComp = 0;
#endif /* TCL_COMPILE_DEBUG */

/*
 * The ExprInfo structure describes the state of compiling an expression.  A
 * pointer to an ExprInfo record is passed among the routines in this module.

 */

typedef struct ExprInfo {
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Structure filled with information about the
				 * parsed expression. */
    CONST char *expr;		/* The expression that was originally passed
				 * to TclCompileExpr. */
    CONST char *lastChar;	/* Points just after last byte of expr. */
    int hasOperators;		/* Set 1 if the expr has operators; 0 if expr
				 * is only a primary. If 1 after compiling an
				 * expr, a tryCvtToNumeric instruction is
				 * emitted to convert the primary to a number
				 * if possible. */
} ExprInfo;

/*
 * Definitions of numeric codes representing each expression operator.  The
 * order of these must match the entries in the operatorTable below.  Also the
 * codes for the relational operators (OP_LESS, OP_GREATER, OP_LE, OP_GE,
 * OP_EQ, and OP_NE) must be consecutive and in that order.  Note that OP_PLUS
 * and OP_MINUS represent both unary and binary operators.
 */

#define OP_MULT		0
#define OP_DIVIDE	1
#define OP_MOD		2
#define OP_PLUS		3
#define OP_MINUS	4
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
				 * Ignored if numOperands is 0. */
} OperatorDesc;

static OperatorDesc operatorTable[] = {
    {"*",   2,  INST_MULT},
    {"/",   2,  INST_DIV},
    {"%",   2,  INST_MOD},
    {"+",   0}, 
    {"-",   0},
    {"<<",  2,  INST_LSHIFT},
    {">>",  2,  INST_RSHIFT},
    {"<",   2,  INST_LT},
    {">",   2,  INST_GT},
    {"<=",  2,  INST_LE},
    {">=",  2,  INST_GE},







|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
				 * Ignored if numOperands is 0. */
} OperatorDesc;

static OperatorDesc operatorTable[] = {
    {"*",   2,  INST_MULT},
    {"/",   2,  INST_DIV},
    {"%",   2,  INST_MOD},
    {"+",   0},
    {"-",   0},
    {"<<",  2,  INST_LSHIFT},
    {">>",  2,  INST_RSHIFT},
    {"<",   2,  INST_LT},
    {">",   2,  INST_GT},
    {"<=",  2,  INST_LE},
    {">=",  2,  INST_GE},
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
    {"**",  2,	INST_EXPON},
    {"in",  2,	INST_LIST_IN},
    {"ni",  2,	INST_LIST_NOT_IN},
    {NULL}
};

/*
 * Hashtable used to map the names of expression operators to the index
 * of their OperatorDesc description.
 */

static Tcl_HashTable opHashTable;

/*
 * Declarations for local procedures to this file:
 */







|
|







122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
    {"**",  2,	INST_EXPON},
    {"in",  2,	INST_LIST_IN},
    {"ni",  2,	INST_LIST_NOT_IN},
    {NULL}
};

/*
 * Hashtable used to map the names of expression operators to the index of
 * their OperatorDesc description.
 */

static Tcl_HashTable opHashTable;

/*
 * Declarations for local procedures to this file:
 */
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
 * Macro used to debug the execution of the expression compiler.
 */

#ifdef TCL_COMPILE_DEBUG
#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \
    if (traceExprComp) { \
	fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \
	        (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \
    }
#else
#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength)
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclCompileExpr --
 *
 *	This procedure compiles a string containing a Tcl expression into
 *	Tcl bytecodes. This procedure is the top-level interface to the
 *	the expression compilation module, and is used by such public
 *	procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong,
 *	Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
 *
 * Results:
 *	The return value is TCL_OK on a successful compilation and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:







|










|
|
|
|
|







156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
 * Macro used to debug the execution of the expression compiler.
 */

#ifdef TCL_COMPILE_DEBUG
#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \
    if (traceExprComp) { \
	fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \
		(exprLength), (exprBytes), (tokenLength), (tokenBytes)); \
    }
#else
#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength)
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclCompileExpr --
 *
 *	This procedure compiles a string containing a Tcl expression into Tcl
 *	bytecodes. This procedure is the top-level interface to the the
 *	expression compilation module, and is used by such public procedures
 *	as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, Tcl_ExprDouble,
 *	Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
 *
 * Results:
 *	The return value is TCL_OK on a successful compilation and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
{
    ExprInfo info;
    Tcl_Parse parse;
    Tcl_HashEntry *hPtr;
    int new, i, code;

    /*
     * If this is the first time we've been called, initialize the table
     * of expression operators.
     */

    if (numBytes < 0) {
	numBytes = (script? strlen(script) : 0);
    }
    if (!opTableInitialized) {
	Tcl_MutexLock(&opMutex);







|
|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
{
    ExprInfo info;
    Tcl_Parse parse;
    Tcl_HashEntry *hPtr;
    int new, i, code;

    /*
     * If this is the first time we've been called, initialize the table of
     * expression operators.
     */

    if (numBytes < 0) {
	numBytes = (script? strlen(script) : 0);
    }
    if (!opTableInitialized) {
	Tcl_MutexLock(&opMutex);
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
	    }
	    opTableInitialized = 1;
	}
	Tcl_MutexUnlock(&opMutex);
    }

    /*
     * Initialize the structure containing information abvout this
     * expression compilation.
     */

    info.interp = interp;
    info.parsePtr = &parse;
    info.expr = script;
    info.lastChar = (script + numBytes); 
    info.hasOperators = 0;

    /*
     * Parse the expression then compile it.
     */

    code = Tcl_ParseExpr(interp, script, numBytes, &parse);
    if (code != TCL_OK) {
	goto done;
    }

    code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
    if (code != TCL_OK) {
	Tcl_FreeParse(&parse);
	goto done;
    }
    
    if (!info.hasOperators) {
	/*
	 * Attempt to convert the primary's object to an int or double.
	 * This is done in order to support Tcl's policy of interpreting
	 * operands if at all possible as first integers, else
	 * floating-point numbers.
	 */
	
	TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
    }
    Tcl_FreeParse(&parse);

    done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeCompilation --
 *
 *	Clean up the compilation environment so it can later be
 *	properly reinitialized. This procedure is called by
 *	TclFinalizeCompExecEnv() in tclObj.c, which in turn is called
 *	by Tcl_Finalize().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up the compilation environment. At the moment, just the
 *	table of expression operators is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeCompilation()
{
    Tcl_MutexLock(&opMutex);
    if (opTableInitialized) {
        Tcl_DeleteHashTable(&opHashTable);
        opTableInitialized = 0;
    }
    Tcl_MutexUnlock(&opMutex);
}

/*
 *----------------------------------------------------------------------
 *







|
|





|
















|


|
|
|
<

|




|








|
|
<
<





|
|









|
|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259

260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276


277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	    }
	    opTableInitialized = 1;
	}
	Tcl_MutexUnlock(&opMutex);
    }

    /*
     * Initialize the structure containing information abvout this expression
     * compilation.
     */

    info.interp = interp;
    info.parsePtr = &parse;
    info.expr = script;
    info.lastChar = (script + numBytes);
    info.hasOperators = 0;

    /*
     * Parse the expression then compile it.
     */

    code = Tcl_ParseExpr(interp, script, numBytes, &parse);
    if (code != TCL_OK) {
	goto done;
    }

    code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
    if (code != TCL_OK) {
	Tcl_FreeParse(&parse);
	goto done;
    }

    if (!info.hasOperators) {
	/*
	 * Attempt to convert the primary's object to an int or double.  This
	 * is done in order to support Tcl's policy of interpreting operands
	 * if at all possible as first integers, else floating-point numbers.

	 */

	TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
    }
    Tcl_FreeParse(&parse);

  done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeCompilation --
 *
 *	Clean up the compilation environment so it can later be properly
 *	reinitialized. This procedure is called by Tcl_Finalize().


 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up the compilation environment. At the moment, just the table
 *	of expression operators is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeCompilation()
{
    Tcl_MutexLock(&opMutex);
    if (opTableInitialized) {
	Tcl_DeleteHashTable(&opHashTable);
	opTableInitialized = 0;
    }
    Tcl_MutexUnlock(&opMutex);
}

/*
 *----------------------------------------------------------------------
 *
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591

592
593
594
595
596
597
598
599
600
 *	Adds instructions to envPtr to evaluate the subexpression.
 *
 *----------------------------------------------------------------------
 */

static int
CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * to compile. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Interp *interp = infoPtr->interp;
    Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
    OperatorDesc *opDescPtr;
    Tcl_HashEntry *hPtr;
    CONST char *operator;
    Tcl_DString opBuf;
    int objIndex, opIndex, length, code;
    char buffer[TCL_UTF_MAX];

    if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
	Tcl_Panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
	        exprTokenPtr->type);
    }
    code = TCL_OK;

    /*
     * Switch on the type of the first token after the subexpression token.
     * After processing it, advance tokenPtr to point just after the
     * subexpression's last token.
     */
    
    tokenPtr = exprTokenPtr+1;
    TRACE(exprTokenPtr->start, exprTokenPtr->size,
	    tokenPtr->start, tokenPtr->size);
    switch (tokenPtr->type) {
        case TCL_TOKEN_WORD:
	    TclCompileTokens(interp, tokenPtr+1,
	            tokenPtr->numComponents, envPtr);
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_TEXT:
	    if (tokenPtr->size > 0) {
		objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
	                tokenPtr->size);
	    } else {
		objIndex = TclRegisterNewLiteral(envPtr, "", 0);
	    }
	    TclEmitPush(objIndex, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_BS:
	    length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
		    buffer);
	    if (length > 0) {
		objIndex = TclRegisterNewLiteral(envPtr, buffer, length);
	    } else {
		objIndex = TclRegisterNewLiteral(envPtr, "", 0);
	    }
	    TclEmitPush(objIndex, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_COMMAND:
	    TclCompileScript(interp, tokenPtr->start+1,
		    tokenPtr->size-2, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_VARIABLE:
	    TclCompileTokens(interp, tokenPtr, 1, envPtr);
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_SUB_EXPR:
	    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_OPERATOR:
	    /*
	     * Look up the operator.  If the operator isn't found, treat it
	     * as a math function.
	     */
	    Tcl_DStringInit(&opBuf);
	    operator = Tcl_DStringAppend(&opBuf, 
		    tokenPtr->start, tokenPtr->size);
	    hPtr = Tcl_FindHashEntry(&opHashTable, operator);
	    if (hPtr == NULL) {
		code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
			envPtr, &endPtr);
		Tcl_DStringFree(&opBuf);
		if (code != TCL_OK) {
		    goto done;
		}
		tokenPtr = endPtr;
		break;
	    }
	    Tcl_DStringFree(&opBuf);
	    opIndex = (int) Tcl_GetHashValue(hPtr);
	    opDescPtr = &(operatorTable[opIndex]);

	    /*
	     * If the operator is "normal", compile it using information
	     * from the operator table.
	     */

	    if (opDescPtr->numOperands > 0) {
		tokenPtr++;
		code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
		if (code != TCL_OK) {
		    goto done;
		}
		tokenPtr += (tokenPtr->numComponents + 1);

		if (opDescPtr->numOperands == 2) {
		    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
		    if (code != TCL_OK) {
			goto done;
		    }
		    tokenPtr += (tokenPtr->numComponents + 1);
		}
		TclEmitOpcode(opDescPtr->instruction, envPtr);
		infoPtr->hasOperators = 1;
		break;
	    }
	    
	    /*
	     * The operator requires special treatment, and is either
	     * "+" or "-", or one of "&&", "||" or "?".
	     */
	    
	    switch (opIndex) {
	        case OP_PLUS:
	        case OP_MINUS:
		    tokenPtr++;
		    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
		    if (code != TCL_OK) {
			goto done;
		    }
		    tokenPtr += (tokenPtr->numComponents + 1);
		    
		    /*
		     * Check whether the "+" or "-" is unary.
		     */
		    
		    afterSubexprPtr = exprTokenPtr
			    + exprTokenPtr->numComponents+1;
		    if (tokenPtr == afterSubexprPtr) {
			TclEmitOpcode(((opIndex==OP_PLUS)?
			        INST_UPLUS : INST_UMINUS),
			        envPtr);
			break;
		    }
		    
		    /*
		     * The "+" or "-" is binary.
		     */
		    
		    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
		    if (code != TCL_OK) {
			goto done;
		    }
		    tokenPtr += (tokenPtr->numComponents + 1);
		    TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB),
			    envPtr);
		    break;

	        case OP_LAND:
	        case OP_LOR:
		    code = CompileLandOrLorExpr(exprTokenPtr, opIndex,
			    infoPtr, envPtr, &endPtr);
		    if (code != TCL_OK) {
			goto done;
		    }
		    tokenPtr = endPtr;
		    break;
			
	        case OP_QUESTY:
		    code = CompileCondExpr(exprTokenPtr, infoPtr,
			    envPtr, &endPtr);
		    if (code != TCL_OK) {
			goto done;
		    }
		    tokenPtr = endPtr;
		    break;
		    
		default:
		    Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n",
		        opIndex);
	    } /* end switch on operator requiring special treatment */
	    infoPtr->hasOperators = 1;
	    break;

        default:
	    Tcl_Panic("CompileSubExpr: unexpected token type %d\n",
	            tokenPtr->type);
    }

    /*
     * Verify that the subexpression token had the required number of
     * subtokens: that we've advanced tokenPtr just beyond the
     * subexpression's last token. For example, a "*" subexpression must
     * contain the tokens for exactly two operands.
     */
    
    if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) {
	LogSyntaxError(infoPtr);
	code = TCL_ERROR;
    }
    
    done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * CompileLandOrLorExpr --
 *
 *	This procedure compiles a Tcl logical and ("&&") or logical or
 *	("||") subexpression.
 *
 * Results:
 *	The return value is TCL_OK on a successful compilation and TCL_ERROR
 *	on failure. If TCL_OK is returned, a pointer to the token just after
 *	the last one in the subexpression is stored at the address in
 *	endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	Adds instructions to envPtr to evaluate the expression at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	 /* Points to TCL_TOKEN_SUB_EXPR token
				  * containing the "&&" or "||" operator. */
    int opIndex;		 /* A code describing the expression
				  * operator: either OP_LAND or OP_LOR. */
    ExprInfo *infoPtr;		 /* Describes the compilation state for the
				  * expression being compiled. */
    CompileEnv *envPtr;		 /* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	 /* If successful, a pointer to the token
				  * just after the last token in the
				  * subexpression is stored here. */
{
    JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump
				  * after the first subexpression. */
    JumpFixup shortCircuitFixup2;/* Used to fix up the second jump to the

				  * short-circuit target. */
    JumpFixup endFixup;          /* Used to fix up jump to the end. */
    Tcl_Token *tokenPtr;
    int code;
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * Emit code for the first operand.
     */







|
|















|








|




|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|

|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|




|
|
|

|




|
|








|
|
















|
|
|
|
|
|
|
|
|
|

|
|
|
>
|
|







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353

354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369

370
371
372
373
374
375
376
377
378
379
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403

404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463

464
465

466
467
468
469
470
471
472
473
474
475
476
477
478
479

480
481
482
483
484
485
486
487
488
489
490
491
492
493

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
 *	Adds instructions to envPtr to evaluate the subexpression.
 *
 *----------------------------------------------------------------------
 */

static int
CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token to
				 * compile. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Interp *interp = infoPtr->interp;
    Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
    OperatorDesc *opDescPtr;
    Tcl_HashEntry *hPtr;
    CONST char *operator;
    Tcl_DString opBuf;
    int objIndex, opIndex, length, code;
    char buffer[TCL_UTF_MAX];

    if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
	Tcl_Panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
		exprTokenPtr->type);
    }
    code = TCL_OK;

    /*
     * Switch on the type of the first token after the subexpression token.
     * After processing it, advance tokenPtr to point just after the
     * subexpression's last token.
     */

    tokenPtr = exprTokenPtr+1;
    TRACE(exprTokenPtr->start, exprTokenPtr->size,
	    tokenPtr->start, tokenPtr->size);
    switch (tokenPtr->type) {
    case TCL_TOKEN_WORD:
	TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr);

	tokenPtr += (tokenPtr->numComponents + 1);
	break;

    case TCL_TOKEN_TEXT:
	if (tokenPtr->size > 0) {
	    objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
		    tokenPtr->size);
	} else {
	    objIndex = TclRegisterNewLiteral(envPtr, "", 0);
	}
	TclEmitPush(objIndex, envPtr);
	tokenPtr += 1;
	break;

    case TCL_TOKEN_BS:
	length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer);

	if (length > 0) {
	    objIndex = TclRegisterNewLiteral(envPtr, buffer, length);
	} else {
	    objIndex = TclRegisterNewLiteral(envPtr, "", 0);
	}
	TclEmitPush(objIndex, envPtr);
	tokenPtr += 1;
	break;

    case TCL_TOKEN_COMMAND:
	TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr);

	tokenPtr += 1;
	break;

    case TCL_TOKEN_VARIABLE:
	TclCompileTokens(interp, tokenPtr, 1, envPtr);
	tokenPtr += (tokenPtr->numComponents + 1);
	break;

    case TCL_TOKEN_SUB_EXPR:
	code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	if (code != TCL_OK) {
	    goto done;
	}
	tokenPtr += (tokenPtr->numComponents + 1);
	break;

    case TCL_TOKEN_OPERATOR:
	/*
	 * Look up the operator.  If the operator isn't found, treat it as a
	 * math function.
	 */
	Tcl_DStringInit(&opBuf);
	operator = Tcl_DStringAppend(&opBuf, tokenPtr->start, tokenPtr->size);

	hPtr = Tcl_FindHashEntry(&opHashTable, operator);
	if (hPtr == NULL) {
	    code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, envPtr,
		    &endPtr);
	    Tcl_DStringFree(&opBuf);
	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr = endPtr;
	    break;
	}
	Tcl_DStringFree(&opBuf);
	opIndex = (int) Tcl_GetHashValue(hPtr);
	opDescPtr = &(operatorTable[opIndex]);

	/*
	 * If the operator is "normal", compile it using information from the
	 * operator table.
	 */

	if (opDescPtr->numOperands > 0) {
	    tokenPtr++;
	    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);

	    if (opDescPtr->numOperands == 2) {
		code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
		if (code != TCL_OK) {
		    goto done;
		}
		tokenPtr += (tokenPtr->numComponents + 1);
	    }
	    TclEmitOpcode(opDescPtr->instruction, envPtr);
	    infoPtr->hasOperators = 1;
	    break;
	}

	/*
	 * The operator requires special treatment, and is either "+" or "-",
	 * or one of "&&", "||" or "?".
	 */

	switch (opIndex) {
	case OP_PLUS:
	case OP_MINUS:
	    tokenPtr++;
	    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);

	    /*
	     * Check whether the "+" or "-" is unary.
	     */

	    afterSubexprPtr = exprTokenPtr + exprTokenPtr->numComponents+1;

	    if (tokenPtr == afterSubexprPtr) {
		TclEmitOpcode(((opIndex==OP_PLUS)? INST_UPLUS : INST_UMINUS),

			envPtr);
		break;
	    }

	    /*
	     * The "+" or "-" is binary.
	     */

	    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	    TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), envPtr);

	    break;

	case OP_LAND:
	case OP_LOR:
	    code = CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr,
		    &endPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr = endPtr;
	    break;

	case OP_QUESTY:
	    code = CompileCondExpr(exprTokenPtr, infoPtr, envPtr, &endPtr);

	    if (code != TCL_OK) {
		goto done;
	    }
	    tokenPtr = endPtr;
	    break;

	default:
	    Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n",
		    opIndex);
	} /* end switch on operator requiring special treatment */
	infoPtr->hasOperators = 1;
	break;

    default:
	Tcl_Panic("CompileSubExpr: unexpected token type %d\n",
		tokenPtr->type);
    }

    /*
     * Verify that the subexpression token had the required number of
     * subtokens: that we've advanced tokenPtr just beyond the subexpression's
     * last token. For example, a "*" subexpression must contain the tokens
     * for exactly two operands.
     */

    if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) {
	LogSyntaxError(infoPtr);
	code = TCL_ERROR;
    }

  done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * CompileLandOrLorExpr --
 *
 *	This procedure compiles a Tcl logical and ("&&") or logical or ("||")
 *	subexpression.
 *
 * Results:
 *	The return value is TCL_OK on a successful compilation and TCL_ERROR
 *	on failure. If TCL_OK is returned, a pointer to the token just after
 *	the last one in the subexpression is stored at the address in
 *	endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	Adds instructions to envPtr to evaluate the expression at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the "&&" or "||" operator. */
    int opIndex;		/* A code describing the expression operator:
				 * either OP_LAND or OP_LOR. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	/* If successful, a pointer to the token just
				 * after the last token in the subexpression
				 * is stored here. */
{
    JumpFixup shortCircuitFixup;/* Used to fix up the short circuit jump after
				 * the first subexpression. */
    JumpFixup shortCircuitFixup2;
				/* Used to fix up the second jump to the
				 * short-circuit target. */
    JumpFixup endFixup;		/* Used to fix up jump to the end. */
    Tcl_Token *tokenPtr;
    int code;
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * Emit code for the first operand.
     */
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
     */

    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
    if (code != TCL_OK) {
	goto done;
    }
    tokenPtr += (tokenPtr->numComponents + 1);
	    
    /*
     * The result is the boolean value of the second operand. We 
     * code this in a somewhat contorted manner to be able to reuse
     * the shortCircuit value and save one INST_JUMP.
     */

    TclEmitForwardJump(envPtr,
	    ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP),
	    &shortCircuitFixup2);

    if (opIndex == OP_LAND) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
    } else {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    }
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);

    /*
     * Fixup the short-circuit jumps and push the shortCircuit value.
     * Note that shortCircuitFixup2 is always a short jump.
     */

    TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup2, 127);
    if (TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup, 127)) {
	/*
	 * shortCircuit jump grown by 3 bytes: update endFixup.
	 */
	    
	 endFixup.codeOffset += 3;
    }

    if (opIndex == OP_LAND) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    } else {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
    }

    TclFixupForwardJumpToHere(envPtr, &endFixup, 127);
    *endPtrPtr = tokenPtr;

    done:
    envPtr->currStackDepth = savedStackDepth + 1;
    return code;
}

/*
 *----------------------------------------------------------------------
 *







|

|
|
|














|
|







|












|







593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
     */

    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
    if (code != TCL_OK) {
	goto done;
    }
    tokenPtr += (tokenPtr->numComponents + 1);

    /*
     * The result is the boolean value of the second operand. We code this in
     * a somewhat contorted manner to be able to reuse the shortCircuit value
     * and save one INST_JUMP.
     */

    TclEmitForwardJump(envPtr,
	    ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP),
	    &shortCircuitFixup2);

    if (opIndex == OP_LAND) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
    } else {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    }
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);

    /*
     * Fixup the short-circuit jumps and push the shortCircuit value.  Note
     * that shortCircuitFixup2 is always a short jump.
     */

    TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup2, 127);
    if (TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup, 127)) {
	/*
	 * shortCircuit jump grown by 3 bytes: update endFixup.
	 */

	 endFixup.codeOffset += 3;
    }

    if (opIndex == OP_LAND) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    } else {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
    }

    TclFixupForwardJumpToHere(envPtr, &endFixup, 127);
    *endPtrPtr = tokenPtr;

  done:
    envPtr->currStackDepth = savedStackDepth + 1;
    return code;
}

/*
 *----------------------------------------------------------------------
 *
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
static int
CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the "?" operator. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	/* If successful, a pointer to the token
				 * just after the last token in the
				 * subexpression is stored here. */
{
    JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
				/* Used to update or replace one-byte jumps
				 * around the then and else expressions when
				 * their target PCs are determined. */
    Tcl_Token *tokenPtr;
    int elseCodeOffset, dist, code;
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * Emit code for the test.
     */

    tokenPtr = exprTokenPtr+2;
    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
    if (code != TCL_OK) {
	goto done;
    }
    tokenPtr += (tokenPtr->numComponents + 1);
    
    /*
     * Emit the jump to the "else" expression if the test was false.
     */
    
    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);

    /*
     * Compile the "then" expression. Note that if a subexpression is only
     * a primary, we need to try to convert it to numeric. We do this to
     * support Tcl's policy of interpreting operands if at all possible as
     * first integers, else floating-point numbers.
     */

    infoPtr->hasOperators = 0;
    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
    if (code != TCL_OK) {
	goto done;
    }
    tokenPtr += (tokenPtr->numComponents + 1);
    if (!infoPtr->hasOperators) {
	TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
    }

    /*
     * Emit an unconditional jump around the "else" condExpr.
     */
    
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
	    &jumpAroundElseFixup);

    /*
     * Compile the "else" expression.
     */

    envPtr->currStackDepth = savedStackDepth;
    elseCodeOffset = (envPtr->codeNext - envPtr->codeStart);







|
|
|



















|



|



|
|
|
|















|
|
<







667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724

725
726
727
728
729
730
731
static int
CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the "?" operator. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	/* If successful, a pointer to the token just
				 * after the last token in the subexpression
				 * is stored here. */
{
    JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
				/* Used to update or replace one-byte jumps
				 * around the then and else expressions when
				 * their target PCs are determined. */
    Tcl_Token *tokenPtr;
    int elseCodeOffset, dist, code;
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * Emit code for the test.
     */

    tokenPtr = exprTokenPtr+2;
    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
    if (code != TCL_OK) {
	goto done;
    }
    tokenPtr += (tokenPtr->numComponents + 1);

    /*
     * Emit the jump to the "else" expression if the test was false.
     */

    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);

    /*
     * Compile the "then" expression. Note that if a subexpression is only a
     * primary, we need to try to convert it to numeric. We do this to support
     * Tcl's policy of interpreting operands if at all possible as first
     * integers, else floating-point numbers.
     */

    infoPtr->hasOperators = 0;
    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
    if (code != TCL_OK) {
	goto done;
    }
    tokenPtr += (tokenPtr->numComponents + 1);
    if (!infoPtr->hasOperators) {
	TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
    }

    /*
     * Emit an unconditional jump around the "else" condExpr.
     */

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpAroundElseFixup);


    /*
     * Compile the "else" expression.
     */

    envPtr->currStackDepth = savedStackDepth;
    elseCodeOffset = (envPtr->codeNext - envPtr->codeStart);
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
     * Fix up the second jump around the "else" expression.
     */

    dist = (envPtr->codeNext - envPtr->codeStart)
	    - jumpAroundElseFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) {
	/*
	 * Update the else expression's starting code offset since it
	 * moved down 3 bytes too.
	 */
	
	elseCodeOffset += 3;
    }
	
    /*
     * Fix up the first jump to the "else" expression if the test was false.
     */
    
    dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
    TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127);
    *endPtrPtr = tokenPtr;

    done:
    envPtr->currStackDepth = savedStackDepth + 1;
    return code;
}

/*
 *----------------------------------------------------------------------
 *







|
|

|


|



|




|







743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
     * Fix up the second jump around the "else" expression.
     */

    dist = (envPtr->codeNext - envPtr->codeStart)
	    - jumpAroundElseFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) {
	/*
	 * Update the else expression's starting code offset since it moved
	 * down 3 bytes too.
	 */

	elseCodeOffset += 3;
    }

    /*
     * Fix up the first jump to the "else" expression if the test was false.
     */

    dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
    TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127);
    *endPtrPtr = tokenPtr;

  done:
    envPtr->currStackDepth = savedStackDepth + 1;
    return code;
}

/*
 *----------------------------------------------------------------------
 *
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

836
837
838

839


840
841
842
843
844

845
846
847
848
849
850
851
852
853
854
855
856
857

858
859
860
861
862
863

864
865
866
867
868
869
870
871
872
873
874
875
876

877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918

919
920
921
922
923
924
925
926
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the math function call. */
    CONST char *funcName;	/* Name of the math function. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	/* If successful, a pointer to the token
				 * just after the last token in the
				 * subexpression is stored here. */
{
    Tcl_Interp *interp = infoPtr->interp;
    Interp *iPtr = (Interp *) interp;
    MathFunc *mathFuncPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Token *tokenPtr, *afterSubexprPtr;

    int code, i;

    /*

     * Look up the MathFunc record for the function.


     */

    code = TCL_OK;
    hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
    if (hPtr == NULL) {

	Tcl_AppendResult(interp, "unknown math function \"", funcName,
		"\"", (char *) NULL);
	code = TCL_ERROR;
	goto done;
    }
    mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);

    /*
     * If not a builtin function, push an object with the function's name.
     */

    if (mathFuncPtr->builtinFuncIndex < 0) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);

    }

    /*
     * Compile any arguments for the function.
     */


    tokenPtr = exprTokenPtr+2;
    afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);
    if (mathFuncPtr->numArgs > 0) {
	for (i = 0;  i < mathFuncPtr->numArgs;  i++) {
	    if (tokenPtr == afterSubexprPtr) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
		        "too few arguments for math function", -1));
		code = TCL_ERROR;
		goto done;
	    }
	    code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	    if (code != TCL_OK) {
		goto done;

	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	}
	if (tokenPtr != afterSubexprPtr) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "too many arguments for math function", -1));
	    code = TCL_ERROR;
	    goto done;
	} 
    } else if (tokenPtr != afterSubexprPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"too many arguments for math function", -1));
	code = TCL_ERROR;
	goto done;
    }
    
    /*
     * Compile the call on the math function. Note that the "objc" argument
     * count for non-builtin functions is incremented by 1 to include the
     * function name itself.
     */

    if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
	/*
	 * Adjust the current stack depth by the number of arguments
	 * of the builtin function. This cannot be handled by the 
	 * TclEmitInstInt1 macro as the number of arguments is not
	 * passed as an operand.
	 */

	if (envPtr->maxStackDepth < envPtr->currStackDepth) {
	    envPtr->maxStackDepth = envPtr->currStackDepth;
	}
	TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
	        mathFuncPtr->builtinFuncIndex, envPtr);
	envPtr->currStackDepth -= mathFuncPtr->numArgs;
    } else {
	TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
    }
    *endPtrPtr = afterSubexprPtr;

    done:

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * LogSyntaxError --
 *







|
|
|

|
|
<
<

>
|


>
|
>
>


<
|
<
>
|
<
<
<
<
<
|
<
<
<
|
<
|
>
|
<




>


<
<
|
<
|
<
<
<
|
|
<
>
|
|
|
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<

<
<
<
<
<
<
<
|
<
<
<
|
<
<

|

<

<
>
|







793
794
795
796
797
798
799
800
801
802
803
804
805


806
807
808
809
810
811
812
813
814
815
816

817

818
819





820



821

822
823
824

825
826
827
828
829
830
831


832

833



834
835

836
837
838
839





840










841

842







843



844


845
846
847

848

849
850
851
852
853
854
855
856
857
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the math function call. */
    CONST char *funcName;	/* Name of the math function. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	/* If successful, a pointer to the token just
				 * after the last token in the subexpression
				 * is stored here. */
{
    Tcl_DString cmdName;
    int objIndex;


    Tcl_Token *tokenPtr, *afterSubexprPtr;
    int argCount;
    int code = TCL_OK;

    /*
     * Prepend "tcl::mathfunc::" to the function name, to produce the name of
     * a command that evaluates the function.  Push that command name on the
     * stack, in a literal registered to the namespace so that resolution can
     * be cached.
     */


    Tcl_DStringInit(&cmdName);

    Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1);
    Tcl_DStringAppend(&cmdName, funcName, -1);





    objIndex = TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName),



	    Tcl_DStringLength(&cmdName));

    TclEmitPush(objIndex, envPtr);
    Tcl_DStringFree(&cmdName);


    /*
     * Compile any arguments for the function.
     */

    argCount = 1;
    tokenPtr = exprTokenPtr+2;
    afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);


    while (tokenPtr != afterSubexprPtr) {

	++argCount;



	code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
	if (code != TCL_OK) {

	    return code;
	}
	tokenPtr += (tokenPtr->numComponents + 1);
    }
















    /* Invoke the function */









    if (argCount < 255) {



	TclEmitInstInt1(INST_INVOKE_STK1, argCount, envPtr);


    } else {
	TclEmitInstInt4(INST_INVOKE_STK4, argCount, envPtr);
    }



    *endPtrPtr = afterSubexprPtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * LogSyntaxError --
 *
940
941
942
943
944
945
946
947
948
949
950
951
952









static void
LogSyntaxError(infoPtr)
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
{
    Tcl_Obj *result =
            Tcl_NewStringObj("syntax error in expression \"", -1);
    TclAppendLimitedToObj(result, infoPtr->expr,
            (int)(infoPtr->lastChar - infoPtr->expr), 60, "");
    Tcl_AppendToObj(result, "\"", -1);
    Tcl_SetObjResult(infoPtr->interp, result);
}















|

|



>
>
>
>
>
>
>
>
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891

static void
LogSyntaxError(infoPtr)
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
{
    Tcl_Obj *result =
	    Tcl_NewStringObj("syntax error in expression \"", -1);
    TclAppendLimitedToObj(result, infoPtr->expr,
	    (int)(infoPtr->lastChar - infoPtr->expr), 60, "");
    Tcl_AppendToObj(result, "\"", -1);
    Tcl_SetObjResult(infoPtr->interp, result);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCompile.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
/* 
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts
 *	of commands (like quoted strings or nested sub-commands) into a
 *	sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.78 2004/10/08 15:39:52 dkf Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
 */
 
static Tcl_HashTable auxDataTypeTable;
static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */

TCL_DECLARE_MUTEX(tableMutex)

/*
 * Variable that controls whether compilation tracing is enabled and, if so,
|


|
|
|




|
|

|








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
/*
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts of
 *	commands (like quoted strings or nested sub-commands) into a sequence
 *	of instructions ("bytecodes").
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.78.2.7 2005/08/02 18:15:19 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
 */

static Tcl_HashTable auxDataTypeTable;
static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */

TCL_DECLARE_MUTEX(tableMutex)

/*
 * Variable that controls whether compilation tracing is enabled and, if so,
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
224
225
226
227

228
229
230
231
232
233

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

258
259
260
261
262
263
264
265
266
267
268
269
270
271

272
273
274
275
276

277
278
279
280
281
282
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297
298
299
300
301
302
























































303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
#ifdef TCL_COMPILE_DEBUG
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif

/*
 * A table describing the Tcl bytecode instructions. Entries in this table
 * must correspond to the instruction opcode definitions in tclCompile.h.
 * The names "op1" and "op4" refer to an instruction's one or four byte
 * first operand. Similarly, "stktop" and "stknext" refer to the topmost
 * and next to topmost stack elements.
 *
 * Note that the load, store, and incr instructions do not distinguish local
 * from global variables; the bytecode interpreter at runtime uses the
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc tclInstructionTable[] = {
   /* Name	      Bytes stackEffect #Opnds Operand types	Stack top, next	  */
    {"done",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,   {OPERAND_UINT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,   {OPERAND_UINT4}},
	/* Push object at ByteCode objArray[op4] */
    {"pop",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Pop the topmost stack object */
    {"dup",		  1,   +1,         0,   {OPERAND_NONE}},
	/* Duplicate the topmost stack object and push the result */
    {"concat1",		  2,   INT_MIN,    1,   {OPERAND_UINT1}},
	/* Concatenate the top op1 items and push result */
    {"invokeStk1",	  2,   INT_MIN,    1,   {OPERAND_UINT1}},
	/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
    {"invokeStk4",	  5,   INT_MIN,    1,   {OPERAND_UINT4}},
	/* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
    {"evalStk",		  1,   0,          0,   {OPERAND_NONE}},
	/* Evaluate command in stktop using Tcl_EvalObj. */
    {"exprStk",		  1,   0,          0,   {OPERAND_NONE}},
	/* Execute expression in stktop using Tcl_ExprStringObj. */
    
    {"loadScalar1",	  2,   1,          1,   {OPERAND_UINT1}},
	/* Load scalar variable at index op1 <= 255 in call frame */
    {"loadScalar4",	  5,   1,          1,   {OPERAND_UINT4}},
	/* Load scalar variable at index op1 >= 256 in call frame */
    {"loadScalarStk",	  1,   0,          0,   {OPERAND_NONE}},
	/* Load scalar variable; scalar's name is stktop */
    {"loadArray1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Load array element; array at slot op1<=255, element is stktop */
    {"loadArray4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Load array element; array at slot op1 > 255, element is stktop */
    {"loadArrayStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Load array element; element is stktop, array name is stknext */
    {"loadStk",		  1,   0,          0,   {OPERAND_NONE}},
	/* Load general variable; unparsed variable name is stktop */
    {"storeScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Store scalar variable at op1<=255 in frame; value is stktop */
    {"storeScalar4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Store scalar variable at op1 > 255 in frame; value is stktop */
    {"storeScalarStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Store scalar; value is stktop, scalar name is stknext */
    {"storeArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Store array element; array at op1<=255, value is top then elem */
    {"storeArray4",	  5,   -1,         1,   {OPERAND_UINT4}},
	/* Store array element; array at op1>=256, value is top then elem */
    {"storeArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Store array element; value is stktop, then elem, array names */
    {"storeStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Store general variable; value is stktop, then unparsed name */
    
    {"incrScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
    {"incrScalarStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Incr scalar; incr amount is stktop, scalar's name is stknext */
    {"incrArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Incr array elem; arr at slot op1<=255, amount is top then elem */
    {"incrArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Incr array element; amount is top then elem then array names */
    {"incrStk",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Incr general variable; amount is stktop then unparsed var name */
    {"incrScalar1Imm",	  3,   +1,         2,   {OPERAND_UINT1, OPERAND_INT1}},
	/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
    {"incrScalarStkImm",  2,   0,          1,   {OPERAND_INT1}},
	/* Incr scalar; scalar name is stktop; incr amount is op1 */
    {"incrArray1Imm",	  3,   0,          2,   {OPERAND_UINT1, OPERAND_INT1}},
	/* Incr array elem; array at slot op1 <= 255, elem is stktop,
	 * amount is 2nd operand byte */
    {"incrArrayStkImm",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Incr array element; elem is top then array name, amount is op1 */
    {"incrStkImm",	  2,   0,	   1,   {OPERAND_INT1}},
	/* Incr general variable; unparsed name is top, amount is op1 */
    
    {"jump1",		  2,   0,          1,   {OPERAND_INT1}},
	/* Jump relative to (pc + op1) */
    {"jump4",		  5,   0,          1,   {OPERAND_INT4}},
	/* Jump relative to (pc + op4) */
    {"jumpTrue1",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is true */
    {"jumpTrue4",	  5,   -1,         1,   {OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",	  5,   -1,         1,   {OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is false */

    {"lor",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"land",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical and:	push (stknext && stktop) */
    {"bitor",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Bitwise or:	push (stknext | stktop) */
    {"bitxor",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Bitwise xor	push (stknext ^ stktop) */
    {"bitand",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Bitwise and:	push (stknext & stktop) */
    {"eq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Equal:	push (stknext == stktop) */
    {"neq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Not equal:	push (stknext != stktop) */
    {"lt",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Less:	push (stknext < stktop) */
    {"gt",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Greater:	push (stknext || stktop) */
    {"le",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"ge",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"lshift",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Left shift:	push (stknext << stktop) */
    {"rshift",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Right shift:	push (stknext >> stktop) */
    {"add",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Add:		push (stknext + stktop) */
    {"sub",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Sub:		push (stkext - stktop) */
    {"mult",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Multiply:	push (stknext * stktop) */
    {"div",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Divide:	push (stknext / stktop) */
    {"mod",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Mod:		push (stknext % stktop) */
    {"uplus",		  1,   0,          0,   {OPERAND_NONE}},
	/* Unary plus:	push +stktop */
    {"uminus",		  1,   0,          0,   {OPERAND_NONE}},
	/* Unary minus:	push -stktop */
    {"bitnot",		  1,   0,          0,   {OPERAND_NONE}},
	/* Bitwise not:	push ~stktop */
    {"not",		  1,   0,          0,   {OPERAND_NONE}},
	/* Logical not:	push !stktop */
    {"callBuiltinFunc1",  2,   1,          1,   {OPERAND_UINT1}},
	/* Call builtin math function with index op1; any args are on stk */
    {"callFunc1",	  2,   INT_MIN,    1,   {OPERAND_UINT1}},
	/* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1>  */
    {"tryCvtToNumeric",	  1,   0,          0,   {OPERAND_NONE}},
	/* Try converting stktop to first int then double if possible. */

    {"break",		  1,   0,          0,   {OPERAND_NONE}},
	/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
    {"continue",	  1,   0,          0,   {OPERAND_NONE}},
	/* Skip to next iteration of closest enclosing loop; if none,
	 * return TCL_CONTINUE code. */

    {"foreach_start4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Initialize execution of a foreach loop. Operand is aux data index
	 * of the ForeachInfo structure for the foreach command. */
    {"foreach_step4",	  5,   +1,         1,   {OPERAND_UINT4}},
	/* "Step" or begin next iteration of foreach loop. Push 0 if to
	 *  terminate loop, else push 1. */

    {"beginCatch4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Record start of catch with the operand's exception index.
	 * Push the current stack depth onto a special catch stack. */
    {"endCatch",	  1,   0,          0,   {OPERAND_NONE}},
	/* End of last catch. Pop the bytecode interpreter's catch stack. */
    {"pushResult",	  1,   +1,         0,   {OPERAND_NONE}},
	/* Push the interpreter's object result onto the stack. */
    {"pushReturnCode",	  1,   +1,         0,   {OPERAND_NONE}},
	/* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
	 * a new object onto the stack. */

    {"streq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Str Equal:	push (stknext eq stktop) */
    {"strneq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Str !Equal:	push (stknext neq stktop) */
    {"strcmp",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Str Compare:	push (stknext cmp stktop) */
    {"strlen",		  1,   0,          0,   {OPERAND_NONE}},
	/* Str Length:	push (strlen stktop) */
    {"strindex",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Str Index:	push (strindex stknext stktop) */
    {"strmatch",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Str Match:	push (strmatch stknext stktop) opnd == nocase */

    {"list",		  5,   INT_MIN,    1,   {OPERAND_UINT4}},
	/* List:	push (stk1 stk2 ... stktop) */
    {"listIndex",	  1,   -1,         0,   {OPERAND_NONE}},
	/* List Index:	push (listindex stknext stktop) */
    {"listLength",	  1,   0,          0,   {OPERAND_NONE}},
	/* List Len:	push (listlength stktop) */

    {"appendScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Append scalar variable at op1<=255 in frame; value is stktop */
    {"appendScalar4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Append scalar variable at op1 > 255 in frame; value is stktop */
    {"appendArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Append array element; array at op1<=255, value is top then elem */
    {"appendArray4",	  5,   -1,         1,   {OPERAND_UINT4}},
	/* Append array element; array at op1>=256, value is top then elem */
    {"appendArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Append array element; value is stktop, then elem, array names */
    {"appendStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Append general variable; value is stktop, then unparsed name */
    {"lappendScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Lappend scalar variable at op1<=255 in frame; value is stktop */
    {"lappendScalar4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
    {"lappendArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Lappend array element; array at op1<=255, value is top then elem */
    {"lappendArray4",	  5,   -1,         1,   {OPERAND_UINT4}},
	/* Lappend array element; array at op1>=256, value is top then elem */
    {"lappendArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Lappend array element; value is stktop, then elem, array names */
    {"lappendStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Lappend general variable; value is stktop, then unparsed name */

    {"lindexMulti",	  5,   INT_MIN,    1,   {OPERAND_UINT4}},
        /* Lindex with generalized args, operand is number of stacked objs 
	 * used: (operand-1) entries from stktop are the indices; then list 
	 * to process. */
    {"over",		  5,   +1,         1,   {OPERAND_UINT4}},
        /* Duplicate the arg-th element from top of stack (TOS=0) */
    {"lsetList",          1,   -2,         0,   {OPERAND_NONE}},
        /* Four-arg version of 'lset'. stktop is old value; next is
         * new element value, next is the index list; pushes new value */
    {"lsetFlat",          5,   INT_MIN,    1,   {OPERAND_UINT4}},
        /* Three- or >=5-arg version of 'lset', operand is number of 
	 * stacked objs: stktop is old value, next is new element value, next 
	 * come (operand-2) indices; pushes the new value.
	 */

    {"return",		  9,   -2,         2,   {OPERAND_INT4, OPERAND_UINT4}},
	/* Compiled [return], code, level are operands; options and result
	 * are on the stack. */
    {"expon",		  1,   -1,	   0,	{OPERAND_NONE}},
	/* Binary exponentiation operator: push (stknext ** stktop) */

     /* 
      * NOTE: the stack effects of expandStkTop and invokeExpanded
      * are wrong - but it cannot be done right at compile time, the stack
      * effect is only known at run time. The value for invokeExpanded
      * is estimated better at compile time.
      * See the comments further down in this file, where INST_INVOKE_EXPANDED 
      * is emitted.
      */
     {"expandStart",       1,    0,          0,   {OPERAND_NONE}},
         /* Start of command with {expand}ed arguments */
     {"expandStkTop",      5,    0,          1,   {OPERAND_INT4}},
         /* Expand the list at stacktop: push its elements on the stack */
     {"invokeExpanded",    1,    0,          0,   {OPERAND_NONE}},
         /* Invoke the command marked by the last 'expandStart' */

    {"listIndexImm",	  5,	0,	   1,	{OPERAND_IDX4}},
	/* List Index:	push (lindex stktop op4) */
    {"listRangeImm",	  9,	0,	   2,	{OPERAND_IDX4, OPERAND_IDX4}},
	/* List Range:	push (lrange stktop op4 op4) */

    {"startCommand",      5,    0,         1,   {OPERAND_UINT4}},
        /* Start of bytecoded command: op is the length of the cmd's code */ 

    {"listIn",		  1,	-1,	   0,	{OPERAND_NONE}},
	/* List containment: push [lsearch stktop stknext]>=0) */
    {"listNotIn",	  1,	-1,	   0,	{OPERAND_NONE}},
	/* List negated containment: push [lsearch stktop stknext]<0) */
























































    {0}
};

/*
 * Prototypes for procedures defined later in this file:
 */

static void		DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static unsigned char *	EncodeCmdLocMap _ANSI_ARGS_((
			    CompileEnv *envPtr, ByteCode *codePtr,
			    unsigned char *startPtr));
static void		EnterCmdExtentData _ANSI_ARGS_((
    			    CompileEnv *envPtr, int cmdNumber,
			    int numSrcBytes, int numCodeBytes));
static void		EnterCmdStartData _ANSI_ARGS_((
    			    CompileEnv *envPtr, int cmdNumber,
			    int srcOffset, int codeOffset));
static void		FreeByteCodeInternalRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr));
static int		GetCmdLocEncodingSize _ANSI_ARGS_((
			    CompileEnv *envPtr));
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats _ANSI_ARGS_((
			    ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * The structure below defines the bytecode Tcl object type by
 * means of procedures that can be invoked by generic object code.
 */

Tcl_ObjType tclByteCodeType = {
    "bytecode",				/* name */
    FreeByteCodeInternalRep,		/* freeIntRepProc */
    DupByteCodeInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetByteCodeFromAny			/* setFromAnyProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclSetByteCodeFromAny --
 *
 *	Part of the bytecode Tcl object type implementation. Attempts to
 *	generate an byte code internal form for the Tcl object "objPtr" by
 *	compiling its string representation.  This function also takes
 *	a hook procedure that will be invoked to perform any needed post
 *	processing on the compilation results before generating byte
 *	codes.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during compilation, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	Frees the old internal representation. If no error occurs, then the
 *	compiled code is stored as "objPtr"s bytecode representation.
 *	Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
 *	used to trace compilations.
 *
 *----------------------------------------------------------------------
 */

int
TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
    Tcl_Interp *interp;		/* The interpreter for which the code is
				 * being compiled.  Must not be NULL. */
    Tcl_Obj *objPtr;		/* The object to make a ByteCode object. */
    CompileHookProc *hookProc;	/* Procedure to invoke after compilation. */
    ClientData clientData;	/* Hook procedure private data. */
{
#ifdef TCL_COMPILE_DEBUG
    Interp *iPtr = (Interp *) interp;
#endif /*TCL_COMPILE_DEBUG*/
    CompileEnv compEnv;		/* Compilation environment structure
				 * allocated in frame. */
    LiteralTable *localTablePtr = &(compEnv.localLitTable);
    register AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    register int i;
    int length, result = TCL_OK;
    char *stringPtr;

#ifdef TCL_COMPILE_DEBUG
    if (!traceInitialized) {
        if (Tcl_LinkVar(interp, "tcl_traceCompile",
	            (char *) &tclTraceCompile,  TCL_LINK_INT) != TCL_OK) {
            Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
        }
        traceInitialized = 1;
    }
#endif

    stringPtr = Tcl_GetStringFromObj(objPtr, &length);
    TclInitCompileEnv(interp, &compEnv, stringPtr, length);
    TclCompileScript(interp, stringPtr, length, &compEnv);

    /*
     * Successful compilation. Add a "done" instruction at the end.
     */

    TclEmitOpcode(INST_DONE, &compEnv);

    /*
     * Invoke the compilation hook procedure if one exists.
     */

    if (hookProc) {
        result = (*hookProc)(interp, &compEnv, clientData);
    }

    /*
     * Change the object into a ByteCode object. Ownership of the literal
     * objects and aux data items is given to the ByteCode object.
     */
    
#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/

    TclInitByteCodeObj(objPtr, &compEnv);
#ifdef TCL_COMPILE_DEBUG
    if (tclTraceCompile >= 2) {
        TclPrintByteCodeObj(interp, objPtr);
    }
#endif /* TCL_COMPILE_DEBUG */
	
    if (result != TCL_OK) {
	/*
	 * Handle any error from the hookProc
	 */

	entryPtr = compEnv.literalArrayPtr;
	for (i = 0;  i < compEnv.literalArrayNext;  i++) {







|
|
|
|







|
|

|

|

|

|

|

|

|

|

|

|
|

|

|

|

|

|

|

|

|

|

|

|

|

|

|
|

|

|

|

|

|

|

|


|

|

|
|

|

|

|

|

|


|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|

|


|

|
|
|

|


|



|
|
|
|

|

|
|
|
>
|

|

|

|

|

|

>
|

|

|

>
|

|

|

|

|

|

|

|

|

|

|

|

>
|
|
|
|
|
|
|
|
|
|
|
|
|

>
|




>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>




|
<
|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
<
|
|
<
|
|
<
|
|
<



|
<





|
|

















|
|
|
<








|
|
|






|
|







|
|









|
|
|
|
|


















|






|







|


|







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302

303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374

375
376

377
378

379
380

381
382
383
384

385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411

412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
#ifdef TCL_COMPILE_DEBUG
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif

/*
 * A table describing the Tcl bytecode instructions. Entries in this table
 * must correspond to the instruction opcode definitions in tclCompile.h.  The
 * names "op1" and "op4" refer to an instruction's one or four byte first
 * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to
 * topmost stack elements.
 *
 * Note that the load, store, and incr instructions do not distinguish local
 * from global variables; the bytecode interpreter at runtime uses the
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc tclInstructionTable[] = {
    /* Name	      Bytes stackEffect #Opnds  Operand types */
    {"done",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,	{OPERAND_UINT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,	{OPERAND_UINT4}},
	/* Push object at ByteCode objArray[op4] */
    {"pop",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Pop the topmost stack object */
    {"dup",		  1,   +1,         0,	{OPERAND_NONE}},
	/* Duplicate the topmost stack object and push the result */
    {"concat1",		  2,   INT_MIN,    1,	{OPERAND_UINT1}},
	/* Concatenate the top op1 items and push result */
    {"invokeStk1",	  2,   INT_MIN,    1,	{OPERAND_UINT1}},
	/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
    {"invokeStk4",	  5,   INT_MIN,    1,	{OPERAND_UINT4}},
	/* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
    {"evalStk",		  1,   0,          0,	{OPERAND_NONE}},
	/* Evaluate command in stktop using Tcl_EvalObj. */
    {"exprStk",		  1,   0,          0,	{OPERAND_NONE}},
	/* Execute expression in stktop using Tcl_ExprStringObj. */

    {"loadScalar1",	  2,   1,          1,	{OPERAND_LVT1}},
	/* Load scalar variable at index op1 <= 255 in call frame */
    {"loadScalar4",	  5,   1,          1,	{OPERAND_LVT4}},
	/* Load scalar variable at index op1 >= 256 in call frame */
    {"loadScalarStk",	  1,   0,          0,	{OPERAND_NONE}},
	/* Load scalar variable; scalar's name is stktop */
    {"loadArray1",	  2,   0,          1,	{OPERAND_LVT1}},
	/* Load array element; array at slot op1<=255, element is stktop */
    {"loadArray4",	  5,   0,          1,	{OPERAND_LVT4}},
	/* Load array element; array at slot op1 > 255, element is stktop */
    {"loadArrayStk",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Load array element; element is stktop, array name is stknext */
    {"loadStk",		  1,   0,          0,	{OPERAND_NONE}},
	/* Load general variable; unparsed variable name is stktop */
    {"storeScalar1",	  2,   0,          1,	{OPERAND_LVT1}},
	/* Store scalar variable at op1<=255 in frame; value is stktop */
    {"storeScalar4",	  5,   0,          1,	{OPERAND_LVT4}},
	/* Store scalar variable at op1 > 255 in frame; value is stktop */
    {"storeScalarStk",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Store scalar; value is stktop, scalar name is stknext */
    {"storeArray1",	  2,   -1,         1,	{OPERAND_LVT1}},
	/* Store array element; array at op1<=255, value is top then elem */
    {"storeArray4",	  5,   -1,         1,	{OPERAND_LVT4}},
	/* Store array element; array at op1>=256, value is top then elem */
    {"storeArrayStk",	  1,   -2,         0,	{OPERAND_NONE}},
	/* Store array element; value is stktop, then elem, array names */
    {"storeStk",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Store general variable; value is stktop, then unparsed name */

    {"incrScalar1",	  2,   0,          1,	{OPERAND_LVT1}},
	/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
    {"incrScalarStk",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Incr scalar; incr amount is stktop, scalar's name is stknext */
    {"incrArray1",	  2,   -1,         1,	{OPERAND_LVT1}},
	/* Incr array elem; arr at slot op1<=255, amount is top then elem */
    {"incrArrayStk",	  1,   -2,         0,	{OPERAND_NONE}},
	/* Incr array element; amount is top then elem then array names */
    {"incrStk",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Incr general variable; amount is stktop then unparsed var name */
    {"incrScalar1Imm",	  3,   +1,         2,	{OPERAND_LVT1, OPERAND_INT1}},
	/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
    {"incrScalarStkImm",  2,   0,          1,	{OPERAND_INT1}},
	/* Incr scalar; scalar name is stktop; incr amount is op1 */
    {"incrArray1Imm",	  3,   0,          2,	{OPERAND_LVT1, OPERAND_INT1}},
	/* Incr array elem; array at slot op1 <= 255, elem is stktop,
	 * amount is 2nd operand byte */
    {"incrArrayStkImm",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Incr array element; elem is top then array name, amount is op1 */
    {"incrStkImm",	  2,   0,	   1,	{OPERAND_INT1}},
	/* Incr general variable; unparsed name is top, amount is op1 */

    {"jump1",		  2,   0,          1,	{OPERAND_INT1}},
	/* Jump relative to (pc + op1) */
    {"jump4",		  5,   0,          1,	{OPERAND_INT4}},
	/* Jump relative to (pc + op4) */
    {"jumpTrue1",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is true */
    {"jumpTrue4",	  5,   -1,         1,	{OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",	  5,   -1,         1,	{OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is false */

    {"lor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"land",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical and:	push (stknext && stktop) */
    {"bitor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Bitwise or:	push (stknext | stktop) */
    {"bitxor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Bitwise xor	push (stknext ^ stktop) */
    {"bitand",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Bitwise and:	push (stknext & stktop) */
    {"eq",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Equal:	push (stknext == stktop) */
    {"neq",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Not equal:	push (stknext != stktop) */
    {"lt",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Less:	push (stknext < stktop) */
    {"gt",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Greater:	push (stknext || stktop) */
    {"le",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"ge",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"lshift",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Left shift:	push (stknext << stktop) */
    {"rshift",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Right shift:	push (stknext >> stktop) */
    {"add",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Add:		push (stknext + stktop) */
    {"sub",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Sub:		push (stkext - stktop) */
    {"mult",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Multiply:	push (stknext * stktop) */
    {"div",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Divide:	push (stknext / stktop) */
    {"mod",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Mod:		push (stknext % stktop) */
    {"uplus",		  1,   0,          0,	{OPERAND_NONE}},
	/* Unary plus:	push +stktop */
    {"uminus",		  1,   0,          0,	{OPERAND_NONE}},
	/* Unary minus:	push -stktop */
    {"bitnot",		  1,   0,          0,	{OPERAND_NONE}},
	/* Bitwise not:	push ~stktop */
    {"not",		  1,   0,          0,	{OPERAND_NONE}},
	/* Logical not:	push !stktop */
    {"callBuiltinFunc1",  2,   1,          1,	{OPERAND_UINT1}},
	/* Call builtin math function with index op1; any args are on stk */
    {"callFunc1",	  2,   INT_MIN,    1,	{OPERAND_UINT1}},
	/* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1>  */
    {"tryCvtToNumeric",	  1,   0,          0,	{OPERAND_NONE}},
	/* Try converting stktop to first int then double if possible. */

    {"break",		  1,   0,          0,	{OPERAND_NONE}},
	/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
    {"continue",	  1,   0,          0,	{OPERAND_NONE}},
	/* Skip to next iteration of closest enclosing loop; if none, return
	 * TCL_CONTINUE code. */

    {"foreach_start4",	  5,   0,          1,	{OPERAND_UINT4}},
	/* Initialize execution of a foreach loop. Operand is aux data index
	 * of the ForeachInfo structure for the foreach command. */
    {"foreach_step4",	  5,   +1,         1,	{OPERAND_UINT4}},
	/* "Step" or begin next iteration of foreach loop. Push 0 if to
	 *  terminate loop, else push 1. */

    {"beginCatch4",	  5,   0,          1,	{OPERAND_UINT4}},
	/* Record start of catch with the operand's exception index.  Push the
	 * current stack depth onto a special catch stack. */
    {"endCatch",	  1,   0,          0,	{OPERAND_NONE}},
	/* End of last catch. Pop the bytecode interpreter's catch stack. */
    {"pushResult",	  1,   +1,         0,	{OPERAND_NONE}},
	/* Push the interpreter's object result onto the stack. */
    {"pushReturnCode",	  1,   +1,         0,	{OPERAND_NONE}},
	/* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new
	 * object onto the stack. */

    {"streq",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Str Equal:	push (stknext eq stktop) */
    {"strneq",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Str !Equal:	push (stknext neq stktop) */
    {"strcmp",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Str Compare:	push (stknext cmp stktop) */
    {"strlen",		  1,   0,          0,	{OPERAND_NONE}},
	/* Str Length:	push (strlen stktop) */
    {"strindex",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Str Index:	push (strindex stknext stktop) */
    {"strmatch",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Str Match:	push (strmatch stknext stktop) opnd == nocase */

    {"list",		  5,   INT_MIN,    1,	{OPERAND_UINT4}},
	/* List:	push (stk1 stk2 ... stktop) */
    {"listIndex",	  1,   -1,         0,	{OPERAND_NONE}},
	/* List Index:	push (listindex stknext stktop) */
    {"listLength",	  1,   0,          0,	{OPERAND_NONE}},
	/* List Len:	push (listlength stktop) */

    {"appendScalar1",	  2,   0,          1,	{OPERAND_LVT1}},
	/* Append scalar variable at op1<=255 in frame; value is stktop */
    {"appendScalar4",	  5,   0,          1,	{OPERAND_LVT4}},
	/* Append scalar variable at op1 > 255 in frame; value is stktop */
    {"appendArray1",	  2,   -1,         1,	{OPERAND_LVT1}},
	/* Append array element; array at op1<=255, value is top then elem */
    {"appendArray4",	  5,   -1,         1,	{OPERAND_LVT4}},
	/* Append array element; array at op1>=256, value is top then elem */
    {"appendArrayStk",	  1,   -2,         0,	{OPERAND_NONE}},
	/* Append array element; value is stktop, then elem, array names */
    {"appendStk",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Append general variable; value is stktop, then unparsed name */
    {"lappendScalar1",	  2,   0,          1,	{OPERAND_LVT1}},
	/* Lappend scalar variable at op1<=255 in frame; value is stktop */
    {"lappendScalar4",	  5,   0,          1,	{OPERAND_LVT4}},
	/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
    {"lappendArray1",	  2,   -1,         1,	{OPERAND_LVT1}},
	/* Lappend array element; array at op1<=255, value is top then elem */
    {"lappendArray4",	  5,   -1,         1,	{OPERAND_LVT4}},
	/* Lappend array element; array at op1>=256, value is top then elem */
    {"lappendArrayStk",	  1,   -2,         0,	{OPERAND_NONE}},
	/* Lappend array element; value is stktop, then elem, array names */
    {"lappendStk",	  1,   -1,         0,	{OPERAND_NONE}},
	/* Lappend general variable; value is stktop, then unparsed name */

    {"lindexMulti",	  5,   INT_MIN,    1,	{OPERAND_UINT4}},
	/* Lindex with generalized args, operand is number of stacked objs
	 * used: (operand-1) entries from stktop are the indices; then list to
	 * process. */
    {"over",		  5,   +1,         1,	{OPERAND_UINT4}},
	/* Duplicate the arg-th element from top of stack (TOS=0) */
    {"lsetList",          1,   -2,         0,	{OPERAND_NONE}},
	/* Four-arg version of 'lset'. stktop is old value; next is new
	 * element value, next is the index list; pushes new value */
    {"lsetFlat",          5,   INT_MIN,    1,	{OPERAND_UINT4}},
	/* Three- or >=5-arg version of 'lset', operand is number of stacked
	 * objs: stktop is old value, next is new element value, next come
	 * (operand-2) indices; pushes the new value.
	 */

    {"returnImm",	  9,   -1,         2,	{OPERAND_INT4, OPERAND_UINT4}},
	/* Compiled [return], code, level are operands; options and result
	 * are on the stack. */
    {"expon",		  1,   -1,	   0,	{OPERAND_NONE}},
	/* Binary exponentiation operator: push (stknext ** stktop) */

    /*
     * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong -
     * but it cannot be done right at compile time, the stack effect is only
     * known at run time. The value for invokeExpanded is estimated better at
     * compile time.
     * See the comments further down in this file, where INST_INVOKE_EXPANDED
     * is emitted.
     */
    {"expandStart",       1,    0,          0,	{OPERAND_NONE}},
	/* Start of command with {expand}ed arguments */
    {"expandStkTop",      5,    0,          1,	{OPERAND_INT4}},
	/* Expand the list at stacktop: push its elements on the stack */
    {"invokeExpanded",    1,    0,          0,	{OPERAND_NONE}},
	/* Invoke the command marked by the last 'expandStart' */

    {"listIndexImm",	  5,	0,	   1,	{OPERAND_IDX4}},
	/* List Index:	push (lindex stktop op4) */
    {"listRangeImm",	  9,	0,	   2,	{OPERAND_IDX4, OPERAND_IDX4}},
	/* List Range:	push (lrange stktop op4 op4) */
    {"startCommand",	  5,	0,	   1,	{OPERAND_UINT4}},

	/* Start of bytecoded command: op is the length of the cmd's code */

    {"listIn",		  1,	-1,	   0,	{OPERAND_NONE}},
	/* List containment: push [lsearch stktop stknext]>=0) */
    {"listNotIn",	  1,	-1,	   0,	{OPERAND_NONE}},
	/* List negated containment: push [lsearch stktop stknext]<0) */

    {"pushReturnOpts",	  1,	+1,	   0,	{OPERAND_NONE}},
	/* Push the interpreter's return option dictionary as an object on the
	 * stack. */
    {"returnStk",	  1,	-2,	   0,	{OPERAND_NONE}},
	/* Compiled [return]; options and result are on the stack, code and
	 * level are in the options. */

    {"dictGet",		  5,	INT_MIN,   1,	{OPERAND_UINT4}},
	/* The top op4 words (min 1) are a key path into the dictionary just
	 * below the keys on the stack, and all those values are replaced by
	 * the value read out of that key-path (like [dict get]).
	 * Stack:  ... dict key1 ... keyN => ... value */
    {"dictSet",		  5,	INT_MIN,   2,	{OPERAND_UINT4, OPERAND_LVT4}},
	/* Update a dictionary value such that the keys are a path pointing to
	 * the value. op4#1 = numKeys, op4#2 = LVTindex
	 * Stack:  ... key1 ... keyN value => ... newDict */
    {"dictUnset",	  5,	INT_MIN,   2,	{OPERAND_UINT4, OPERAND_LVT4}},
	/* Update a dictionary value such that the keys are not a path pointing
	 * to any value. op4#1 = numKeys, op4#2 = LVTindex
	 * Stack:  ... key1 ... keyN => ... newDict */
    {"dictIncrImm",	  5,	0,	   2,	{OPERAND_INT4, OPERAND_LVT4}},
	/* Update a dictionary value such that the value pointed to by key is
	 * incremented by some value (or set to it if the key isn't in the
	 * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex
	 * Stack:  ... key => ... newDict */
    {"dictAppend",	  5,	-1,	   1,	{OPERAND_LVT4}},
	/* Update a dictionary value such that the value pointed to by key has
	 * some value string-concatenated onto it. op4 = LVTindex
	 * Stack:  ... key valueToAppend => ... newDict */
    {"dictLappend",	  5,	-1,	   1,	{OPERAND_LVT4}},
	/* Update a dictionary value such that the value pointed to by key has
	 * some value list-appended onto it. op4 = LVTindex
	 * Stack:  ... key valueToAppend => ... newDict */
    {"dictFirst",	  5,	+2,	   1,	{OPERAND_LVT4}},
	/* Begin iterating over the dictionary, using the local scalar
	 * indicated by op4 to hold the iterator state. If doneBool is true,
	 * dictDone *must* be called later on.
	 * Stack:  ... dict => ... value key doneBool */
    {"dictNext",	  5,	+3,	   1,	{OPERAND_LVT4}},
	/* Get the next iteration from the iterator in op4's local scalar.
	 * Stack:  ... => ... value key doneBool */
    {"dictDone",	  5,	0,	   1,	{OPERAND_LVT4}},
	/* Terminate the iterator in op4's local scalar. */
    {"dictUpdateStart",   5,    -2,	   1,	{OPERAND_LVT4}},
	/* Create the variables to mirror the state of the dictionary in the
	 * variable referred to by the immediate argument.
	 * Stack:  ... keyList LVTindexList => ...
	 * Note that the list of LVT indices is assumed to be the same length
	 * as the keyList, and the indices should be only ever generated by the
	 * compiler. */
    {"dictUpdateEnd",	  5,    -2,	   1,	{OPERAND_LVT4}},
	/* Reflect the state of local variables back to the state of the
	 * dictionary in the variable referred to by the immediate argument.
	 * Stack:  ... keyList LVTindexList => ...
	 * Same notes as in "dictUpdateStart" apply here. */
    {0}
};

/*
 * Prototypes for procedures defined later in this file:
 */

static void		DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static unsigned char *	EncodeCmdLocMap _ANSI_ARGS_((CompileEnv *envPtr,

			    ByteCode *codePtr, unsigned char *startPtr));
static void		EnterCmdExtentData _ANSI_ARGS_((CompileEnv *envPtr,

			    int cmdNumber, int numSrcBytes, int numCodeBytes));
static void		EnterCmdStartData _ANSI_ARGS_((CompileEnv *envPtr,

			    int cmdNumber, int srcOffset, int codeOffset));
static void		FreeByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));

static int		GetCmdLocEncodingSize _ANSI_ARGS_((
			    CompileEnv *envPtr));
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats _ANSI_ARGS_((ByteCode *codePtr));

#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * The structure below defines the bytecode Tcl object type by means of
 * procedures that can be invoked by generic object code.
 */

Tcl_ObjType tclByteCodeType = {
    "bytecode",				/* name */
    FreeByteCodeInternalRep,		/* freeIntRepProc */
    DupByteCodeInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetByteCodeFromAny			/* setFromAnyProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclSetByteCodeFromAny --
 *
 *	Part of the bytecode Tcl object type implementation. Attempts to
 *	generate an byte code internal form for the Tcl object "objPtr" by
 *	compiling its string representation.  This function also takes a hook
 *	procedure that will be invoked to perform any needed post processing
 *	on the compilation results before generating byte codes.

 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during compilation, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	Frees the old internal representation. If no error occurs, then the
 *	compiled code is stored as "objPtr"s bytecode representation. Also, if
 *	debugging, initializes the "tcl_traceCompile" Tcl variable used to
 *	trace compilations.
 *
 *----------------------------------------------------------------------
 */

int
TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
    Tcl_Interp *interp;		/* The interpreter for which the code is being
				 * compiled.  Must not be NULL. */
    Tcl_Obj *objPtr;		/* The object to make a ByteCode object. */
    CompileHookProc *hookProc;	/* Procedure to invoke after compilation. */
    ClientData clientData;	/* Hook procedure private data. */
{
#ifdef TCL_COMPILE_DEBUG
    Interp *iPtr = (Interp *) interp;
#endif /*TCL_COMPILE_DEBUG*/
    CompileEnv compEnv;		/* Compilation environment structure allocated
				 * in frame. */
    LiteralTable *localTablePtr = &(compEnv.localLitTable);
    register AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    register int i;
    int length, result = TCL_OK;
    char *stringPtr;

#ifdef TCL_COMPILE_DEBUG
    if (!traceInitialized) {
	if (Tcl_LinkVar(interp, "tcl_traceCompile",
		(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
	    Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
	}
	traceInitialized = 1;
    }
#endif

    stringPtr = Tcl_GetStringFromObj(objPtr, &length);
    TclInitCompileEnv(interp, &compEnv, stringPtr, length);
    TclCompileScript(interp, stringPtr, length, &compEnv);

    /*
     * Successful compilation. Add a "done" instruction at the end.
     */

    TclEmitOpcode(INST_DONE, &compEnv);

    /*
     * Invoke the compilation hook procedure if one exists.
     */

    if (hookProc) {
	result = (*hookProc)(interp, &compEnv, clientData);
    }

    /*
     * Change the object into a ByteCode object. Ownership of the literal
     * objects and aux data items is given to the ByteCode object.
     */

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/

    TclInitByteCodeObj(objPtr, &compEnv);
#ifdef TCL_COMPILE_DEBUG
    if (tclTraceCompile >= 2) {
	TclPrintByteCodeObj(interp, objPtr);
    }
#endif /* TCL_COMPILE_DEBUG */

    if (result != TCL_OK) {
	/*
	 * Handle any error from the hookProc
	 */

	entryPtr = compEnv.literalArrayPtr;
	for (i = 0;  i < compEnv.literalArrayNext;  i++) {
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
	    if (auxDataPtr->type->freeProc != NULL) {
		auxDataPtr->type->freeProc(auxDataPtr->clientData);
	    }
	    auxDataPtr++;
	}
    }


    /*
     * Free storage allocated during compilation.
     */
    
    if (localTablePtr->buckets != localTablePtr->staticBuckets) {
	ckfree((char *) localTablePtr->buckets);
    }
    TclFreeCompileEnv(&compEnv);
    return result;
}








<



|







507
508
509
510
511
512
513

514
515
516
517
518
519
520
521
522
523
524
	    if (auxDataPtr->type->freeProc != NULL) {
		auxDataPtr->type->freeProc(auxDataPtr->clientData);
	    }
	    auxDataPtr++;
	}
    }


    /*
     * Free storage allocated during compilation.
     */

    if (localTablePtr->buckets != localTablePtr->staticBuckets) {
	ckfree((char *) localTablePtr->buckets);
    }
    TclFreeCompileEnv(&compEnv);
    return result;
}

479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during compilation, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	Frees the old internal representation. If no error occurs, then the
 *	compiled code is stored as "objPtr"s bytecode representation.
 *	Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
 *	used to trace compilations.
 *
 *----------------------------------------------------------------------
 */

static int
SetByteCodeFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* The interpreter for which the code is
				 * being compiled.  Must not be NULL. */
    Tcl_Obj *objPtr;		/* The object to make a ByteCode object. */
{
    return TclSetByteCodeFromAny(interp, objPtr,
	    (CompileHookProc *) NULL, (ClientData) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * DupByteCodeInternalRep --
 *
 *	Part of the bytecode Tcl object type implementation. However, it
 *	does not copy the internal representation of a bytecode Tcl_Obj, but
 *	instead leaves the new object untyped (with a NULL type pointer).
 *	Code will be compiled for the new object only if necessary.
 *
 * Results:
 *	None.
 *
 * Side effects:







|
|
|






|
|











|
|







534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during compilation, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	Frees the old internal representation. If no error occurs, then the
 *	compiled code is stored as "objPtr"s bytecode representation.  Also,
 *	if debugging, initializes the "tcl_traceCompile" Tcl variable used to
 *	trace compilations.
 *
 *----------------------------------------------------------------------
 */

static int
SetByteCodeFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* The interpreter for which the code is being
				 * compiled.  Must not be NULL. */
    Tcl_Obj *objPtr;		/* The object to make a ByteCode object. */
{
    return TclSetByteCodeFromAny(interp, objPtr,
	    (CompileHookProc *) NULL, (ClientData) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * DupByteCodeInternalRep --
 *
 *	Part of the bytecode Tcl object type implementation. However, it does
 *	not copy the internal representation of a bytecode Tcl_Obj, but
 *	instead leaves the new object untyped (with a NULL type pointer).
 *	Code will be compiled for the new object only if necessary.
 *
 * Results:
 *	None.
 *
 * Side effects:
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
}

/*
 *----------------------------------------------------------------------
 *
 * FreeByteCodeInternalRep --
 *
 *	Part of the bytecode Tcl object type implementation. Frees the
 *	storage associated with a bytecode object's internal representation
 *	unless its code is actively being executed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The bytecode object's internal rep is marked invalid and its
 *	code gets freed unless the code is actively being executed.
 *	In that case the cleanup is delayed until the last execution
 *	of the code completes.
 *
 *----------------------------------------------------------------------
 */

static void
FreeByteCodeInternalRep(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to free. */
{
    register ByteCode *codePtr =
	    (ByteCode *) objPtr->internalRep.otherValuePtr;

    codePtr->refCount--;
    if (codePtr->refCount <= 0) {
	TclCleanupByteCode(codePtr);
    }
    objPtr->typePtr = NULL;
    objPtr->internalRep.otherValuePtr = NULL;







|
|
|





|
|
|
<








|
|







583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600

601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
}

/*
 *----------------------------------------------------------------------
 *
 * FreeByteCodeInternalRep --
 *
 *	Part of the bytecode Tcl object type implementation. Frees the storage
 *	associated with a bytecode object's internal representation unless its
 *	code is actively being executed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The bytecode object's internal rep is marked invalid and its code gets
 *	freed unless the code is actively being executed.  In that case the
 *	cleanup is delayed until the last execution of the code completes.

 *
 *----------------------------------------------------------------------
 */

static void
FreeByteCodeInternalRep(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to free. */
{
    register ByteCode *codePtr = (ByteCode *)
	    objPtr->internalRep.otherValuePtr;

    codePtr->refCount--;
    if (codePtr->refCount <= 0) {
	TclCleanupByteCode(codePtr);
    }
    objPtr->typePtr = NULL;
    objPtr->internalRep.otherValuePtr = NULL;
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
 *	object's ByteCode structure. It's called only when the structure's
 *	reference count becomes zero.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees objPtr's bytecode internal representation and sets its type
 *	and objPtr->internalRep.otherValuePtr NULL. Also releases its
 *	literals and frees its auxiliary data items.
 *
 *----------------------------------------------------------------------
 */

void
TclCleanupByteCode(codePtr)
    register ByteCode *codePtr;	/* Points to the ByteCode to free. */







|
|
|







626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
 *	object's ByteCode structure. It's called only when the structure's
 *	reference count becomes zero.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees objPtr's bytecode internal representation and sets its type and
 *	objPtr->internalRep.otherValuePtr NULL. Also releases its literals and
 *	frees its auxiliary data items.
 *
 *----------------------------------------------------------------------
 */

void
TclCleanupByteCode(codePtr)
    register ByteCode *codePtr;	/* Points to the ByteCode to free. */
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692

	statsPtr = &((Interp *) interp)->stats;

	statsPtr->numByteCodesFreed++;
	statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
	statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;

	statsPtr->currentInstBytes   -= (double) codePtr->numCodeBytes;
	statsPtr->currentLitBytes    -=
		(double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); 
	statsPtr->currentExceptBytes -=
		(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
	statsPtr->currentAuxBytes    -=
		(double) (codePtr->numAuxDataItems * sizeof(AuxData));
	statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;

	Tcl_GetTime(&destroyTime);
	lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
	if (lifetimeSec > 2000) {	/* avoid overflow */
	    lifetimeSec = 2000;
	}
	lifetimeMicroSec =
	    1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
	
	log2 = TclLog2(lifetimeMicroSec);
	if (log2 > 31) {
	    log2 = 31;
	}
	statsPtr->lifetimeCount[log2]++;
    }
#endif /* TCL_COMPILE_STATS */

    /*
     * A single heap object holds the ByteCode structure and its code,
     * object, command location, and auxiliary data arrays. This means we
     * only need to 1) decrement the ref counts of the LiteralEntry's in
     * its literal array, 2) call the free procs for the auxiliary data
     * items, and 3) free the ByteCode structure's heap object.
     *
     * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
     * like those generated from tbcload) is special, as they doesn't
     * make use of the global literal table.  They instead maintain
     * private references to their literals which must be decremented.
     *
     * In order to insure a proper and efficient cleanup of the literal
     * array when it contains non-shared literals [Bug 983660], we also
     * distinguish the case of an interpreter being deleted (signaled by
     * interp == NULL). Also, as the interp deletion will remove the global
     * literal table anyway, we avoid the extra cost of updating it for each
     * literal being released.
     */

    if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
	    || (interp == NULL)) {
 
	objArrayPtr = codePtr->objArrayPtr;
	for (i = 0;  i < numLitObjects;  i++) {
	    objPtr = *objArrayPtr;
	    if (objPtr) {
		Tcl_DecrRefCount(objPtr);
	    }
	    objArrayPtr++;
	}
	codePtr->numLitObjects = 0;
    } else {
	objArrayPtr = codePtr->objArrayPtr;
	for (i = 0;  i < numLitObjects;  i++) {
	    /*
	     * TclReleaseLiteral sets a ByteCode's object array entry NULL to
	     * indicate that it has already freed the literal.
	     */
	    
	    objPtr = *objArrayPtr;
	    if (objPtr != NULL) {
		TclReleaseLiteral(interp, objPtr);
	    }
	    objArrayPtr++;
	}
    }
    
    auxDataPtr = codePtr->auxDataArrayPtr;
    for (i = 0;  i < numAuxDataItems;  i++) {
	if (auxDataPtr->type->freeProc != NULL) {
	    (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
	}
	auxDataPtr++;
    }

    TclHandleRelease(codePtr->interpHandle);
    ckfree((char *) codePtr);
}







|
|
|
|
|
|
|







|
|
|









|
|
|
|
|

|
|
|
|

|
|
|
|
|
|


|
<
|
















|







|



|







656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708

709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745

	statsPtr = &((Interp *) interp)->stats;

	statsPtr->numByteCodesFreed++;
	statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
	statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;

	statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
	statsPtr->currentLitBytes -= (double)
		codePtr->numLitObjects * sizeof(Tcl_Obj *);
	statsPtr->currentExceptBytes -= (double)
		codePtr->numExceptRanges * sizeof(ExceptionRange);
	statsPtr->currentAuxBytes -= (double)
		codePtr->numAuxDataItems * sizeof(AuxData);
	statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;

	Tcl_GetTime(&destroyTime);
	lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
	if (lifetimeSec > 2000) {	/* avoid overflow */
	    lifetimeSec = 2000;
	}
	lifetimeMicroSec = 1000000 * lifetimeSec +
		(destroyTime.usec - codePtr->createTime.usec);

	log2 = TclLog2(lifetimeMicroSec);
	if (log2 > 31) {
	    log2 = 31;
	}
	statsPtr->lifetimeCount[log2]++;
    }
#endif /* TCL_COMPILE_STATS */

    /*
     * A single heap object holds the ByteCode structure and its code, object,
     * command location, and auxiliary data arrays. This means we only need to
     * 1) decrement the ref counts of the LiteralEntry's in its literal array,
     * 2) call the free procs for the auxiliary data items, and 3) free the
     * ByteCode structure's heap object.
     *
     * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
     * those generated from tbcload) is special, as they doesn't make use of
     * the global literal table.  They instead maintain private references to
     * their literals which must be decremented.
     *
     * In order to insure a proper and efficient cleanup of the literal array
     * when it contains non-shared literals [Bug 983660], we also distinguish
     * the case of an interpreter being deleted (signaled by interp == NULL).
     * Also, as the interp deletion will remove the global literal table
     * anyway, we avoid the extra cost of updating it for each literal being
     * released.
     */

    if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) {


	objArrayPtr = codePtr->objArrayPtr;
	for (i = 0;  i < numLitObjects;  i++) {
	    objPtr = *objArrayPtr;
	    if (objPtr) {
		Tcl_DecrRefCount(objPtr);
	    }
	    objArrayPtr++;
	}
	codePtr->numLitObjects = 0;
    } else {
	objArrayPtr = codePtr->objArrayPtr;
	for (i = 0;  i < numLitObjects;  i++) {
	    /*
	     * TclReleaseLiteral sets a ByteCode's object array entry NULL to
	     * indicate that it has already freed the literal.
	     */

	    objPtr = *objArrayPtr;
	    if (objPtr != NULL) {
		TclReleaseLiteral(interp, objPtr);
	    }
	    objArrayPtr++;
	}
    }

    auxDataPtr = codePtr->auxDataArrayPtr;
    for (i = 0;  i < numAuxDataItems;  i++) {
	if (auxDataPtr->type->freeProc != NULL) {
	    (auxDataPtr->type->freeProc)(auxDataPtr->clientData);
	}
	auxDataPtr++;
    }

    TclHandleRelease(codePtr->interpHandle);
    ckfree((char *) codePtr);
}
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
				  * structure is initialized. */
    register CompileEnv *envPtr; /* Points to the CompileEnv structure to
				  * initialize. */
    char *stringPtr;		 /* The source string to be compiled. */
    int numBytes;		 /* Number of bytes in source string. */
{
    Interp *iPtr = (Interp *) interp;
    
    envPtr->iPtr = iPtr;
    envPtr->source = stringPtr;
    envPtr->numSrcBytes = numBytes;
    envPtr->procPtr = iPtr->compiledProcPtr;
    envPtr->numCommands = 0;
    envPtr->exceptDepth = 0;
    envPtr->maxExceptDepth = 0;
    envPtr->maxStackDepth = 0;
    envPtr->currStackDepth = 0;
    TclInitLiteralTable(&(envPtr->localLitTable));

    envPtr->codeStart = envPtr->staticCodeSpace;
    envPtr->codeNext = envPtr->codeStart;
    envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
    envPtr->mallocedCodeArray = 0;

    envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
    envPtr->literalArrayNext = 0;
    envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
    envPtr->mallocedLiteralArray = 0;
    
    envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
    envPtr->exceptArrayNext = 0;
    envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
    envPtr->mallocedExceptArray = 0;
    
    envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
    envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
    envPtr->mallocedCmdMap = 0;
    
    envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
    envPtr->auxDataArrayNext = 0;
    envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
    envPtr->mallocedAuxDataArray = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreeCompileEnv --
 *
 *	Free the storage allocated in a CompileEnv compilation environment
 *	structure.
 *
 * Results:
 *	None.
 * 
 * Side effects:
 *	Allocated storage in the CompileEnv structure is freed. Note that
 *	its local literal table is not deleted and its literal objects are
 *	not released. In addition, storage referenced by its auxiliary data
 *	items is not freed. This is done so that, when compilation is
 *	successful, "ownership" of these objects and aux data items is
 *	handed over to the corresponding ByteCode structure.
 *
 *----------------------------------------------------------------------
 */

void
TclFreeCompileEnv(envPtr)
    register CompileEnv *envPtr; /* Points to the CompileEnv structure. */







|




















|




|



|
















|

|
|
|
|
|
|







767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
				  * structure is initialized. */
    register CompileEnv *envPtr; /* Points to the CompileEnv structure to
				  * initialize. */
    char *stringPtr;		 /* The source string to be compiled. */
    int numBytes;		 /* Number of bytes in source string. */
{
    Interp *iPtr = (Interp *) interp;

    envPtr->iPtr = iPtr;
    envPtr->source = stringPtr;
    envPtr->numSrcBytes = numBytes;
    envPtr->procPtr = iPtr->compiledProcPtr;
    envPtr->numCommands = 0;
    envPtr->exceptDepth = 0;
    envPtr->maxExceptDepth = 0;
    envPtr->maxStackDepth = 0;
    envPtr->currStackDepth = 0;
    TclInitLiteralTable(&(envPtr->localLitTable));

    envPtr->codeStart = envPtr->staticCodeSpace;
    envPtr->codeNext = envPtr->codeStart;
    envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
    envPtr->mallocedCodeArray = 0;

    envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
    envPtr->literalArrayNext = 0;
    envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
    envPtr->mallocedLiteralArray = 0;

    envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
    envPtr->exceptArrayNext = 0;
    envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
    envPtr->mallocedExceptArray = 0;

    envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
    envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
    envPtr->mallocedCmdMap = 0;

    envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
    envPtr->auxDataArrayNext = 0;
    envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
    envPtr->mallocedAuxDataArray = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreeCompileEnv --
 *
 *	Free the storage allocated in a CompileEnv compilation environment
 *	structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocated storage in the CompileEnv structure is freed. Note that its
 *	local literal table is not deleted and its literal objects are not
 *	released. In addition, storage referenced by its auxiliary data items
 *	is not freed. This is done so that, when compilation is successful,
 *	"ownership" of these objects and aux data items is handed over to the
 *	corresponding ByteCode structure.
 *
 *----------------------------------------------------------------------
 */

void
TclFreeCompileEnv(envPtr)
    register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
}

/*
 *----------------------------------------------------------------------
 *
 * TclWordKnownAtCompileTime --
 *
 *	Test whether the value of a token is completely known at compile
 *	time.
 *
 * Results:
 *	Returns true if the tokenPtr argument points to a word value that
 *	is completely known at compile time.  Generally, values that are
 *	known at compile time can be compiled to their values, while values
 *	that cannot be	known until substitution at runtime must be compiled
 *	to bytecode instructions that perform that substitution.  For several
 *	commands, whether or not arguments are known at compile time determine
 *	whether it is worthwhile to compile at all.
 *
 * Side effects:
 *	When returning true, appends the known value of the word to
 *	the unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
 *
 *----------------------------------------------------------------------
 */

int
TclWordKnownAtCompileTime(tokenPtr, valuePtr)
    Tcl_Token *tokenPtr;	/* Points to Tcl_Token we should check */







|
<


|
|
|
|
|
|
|


|
|







852
853
854
855
856
857
858
859

860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
}

/*
 *----------------------------------------------------------------------
 *
 * TclWordKnownAtCompileTime --
 *
 *	Test whether the value of a token is completely known at compile time.

 *
 * Results:
 *	Returns true if the tokenPtr argument points to a word value that is
 *	completely known at compile time.  Generally, values that are known at
 *	compile time can be compiled to their values, while values that cannot
 *	be known until substitution at runtime must be compiled to bytecode
 *	instructions that perform that substitution.  For several commands,
 *	whether or not arguments are known at compile time determine whether
 *	it is worthwhile to compile at all.
 *
 * Side effects:
 *	When returning true, appends the known value of the word to the
 *	unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
 *
 *----------------------------------------------------------------------
 */

int
TclWordKnownAtCompileTime(tokenPtr, valuePtr)
    Tcl_Token *tokenPtr;	/* Points to Tcl_Token we should check */
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
    tokenPtr++;
    if (valuePtr != NULL) {
	tempPtr = Tcl_NewObj();
	Tcl_IncrRefCount(tempPtr);
    }
    while (numComponents--) {
	switch (tokenPtr->type) {
	    case TCL_TOKEN_TEXT:
		if (tempPtr != NULL) {
		    Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
		}
		break;

	    case TCL_TOKEN_BS:
		if (tempPtr != NULL) {
		    char utfBuf[TCL_UTF_MAX];
		    int length = 
			    Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf);
		    Tcl_AppendToObj(tempPtr, utfBuf, length);
		}
		break;
	    
	    default:
		if (tempPtr != NULL) {
		    Tcl_DecrRefCount(tempPtr);
		}
		return 0;
	}
	tokenPtr++;
    }
    if (valuePtr != NULL) {
	Tcl_AppendObjToObj(valuePtr, tempPtr);
	Tcl_DecrRefCount(tempPtr);
    }







|
|
|
|
|

|
|
|
<
|
|
|
|
|
|
|
|
|
|







896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911

912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
    tokenPtr++;
    if (valuePtr != NULL) {
	tempPtr = Tcl_NewObj();
	Tcl_IncrRefCount(tempPtr);
    }
    while (numComponents--) {
	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
	    if (tempPtr != NULL) {
		Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
	    }
	    break;

	case TCL_TOKEN_BS:
	    if (tempPtr != NULL) {
		char utfBuf[TCL_UTF_MAX];

		int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf);
		Tcl_AppendToObj(tempPtr, utfBuf, length);
	    }
	    break;

	default:
	    if (tempPtr != NULL) {
		Tcl_DecrRefCount(tempPtr);
	    }
	    return 0;
	}
	tokenPtr++;
    }
    if (valuePtr != NULL) {
	Tcl_AppendObjToObj(valuePtr, tempPtr);
	Tcl_DecrRefCount(tempPtr);
    }
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
 *	Adds instructions to envPtr to evaluate the script at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileScript(interp, script, numBytes, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting.
				 * Also serves as context for finding and
				 * compiling commands.  May not be NULL. */
    CONST char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Parse parse;
    int lastTopLevelCmdIndex = -1;
    				/* Index of most recent toplevel command in
 				 * the command location table. Initialized
				 * to avoid compiler warning. */
    int startCodeOffset = -1;	/* Offset of first byte of current command's
                                 * code. Init. to avoid compiler warning. */
    unsigned char *entryCodeNext = envPtr->codeNext;
    CONST char *p, *next;
    Namespace *cmdNsPtr;
    Command *cmdPtr;
    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
    int commandLength, objIndex, code;
    Tcl_DString ds;

    Tcl_DStringInit(&ds);

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);
    isFirstCmd = 1;

    if (envPtr->procPtr != NULL) {
	cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
    } else {
	cmdNsPtr = NULL; /* use current NS */
    }

    /*
     * Each iteration through the following loop compiles the next
     * command from the script.
     */

    p = script;
    bytesLeft = numBytes;
    gotParse = 0;
    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) {







|
|
|










|
|

|




















|



|
|







945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
 *	Adds instructions to envPtr to evaluate the script at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileScript(interp, script, numBytes, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting.  Also
				 * serves as context for finding and compiling
				 * commands.  May not be NULL. */
    CONST char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Parse parse;
    int lastTopLevelCmdIndex = -1;
    				/* Index of most recent toplevel command in
 				 * the command location table. Initialized *
 				 * to avoid compiler warning. */
    int startCodeOffset = -1;	/* Offset of first byte of current command's
				 * code. Init. to avoid compiler warning. */
    unsigned char *entryCodeNext = envPtr->codeNext;
    CONST char *p, *next;
    Namespace *cmdNsPtr;
    Command *cmdPtr;
    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
    int commandLength, objIndex, code;
    Tcl_DString ds;

    Tcl_DStringInit(&ds);

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);
    isFirstCmd = 1;

    if (envPtr->procPtr != NULL) {
	cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
    } else {
	cmdNsPtr = NULL;	/* use current NS */
    }

    /*
     * Each iteration through the following loop compiles the next command
     * from the script.
     */

    p = script;
    bytesLeft = numBytes;
    gotParse = 0;
    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) {
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
	    Tcl_Parse subParse;
	    int errorLine = 1;

	    Tcl_IncrRefCount(returnCmd);
	    Tcl_IncrRefCount(errInfo);
	    Tcl_AppendToObj(errInfo, "\n    while executing\n\"", -1);
	    TclAppendLimitedToObj(errInfo, parse.commandStart,
		/* Drop the command terminator (";" or "]") if appropriate */
		(parse.term == parse.commandStart + parse.commandSize - 1) ?
			parse.commandSize - 1 : parse.commandSize, 153, NULL);
	    Tcl_AppendToObj(errInfo, "\"", -1);

	    Tcl_ListObjAppendElement(NULL, returnCmd, errInfo);

	    for (p = envPtr->source; p != parse.commandStart; p++) {
		if (*p == '\n') {
		    errorLine++;







|
|
|







1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
	    Tcl_Parse subParse;
	    int errorLine = 1;

	    Tcl_IncrRefCount(returnCmd);
	    Tcl_IncrRefCount(errInfo);
	    Tcl_AppendToObj(errInfo, "\n    while executing\n\"", -1);
	    TclAppendLimitedToObj(errInfo, parse.commandStart,
		    /* Drop the command terminator (";","]") if appropriate */
		    (parse.term == parse.commandStart + parse.commandSize - 1)?
		    parse.commandSize - 1 : parse.commandSize, 153, NULL);
	    Tcl_AppendToObj(errInfo, "\"", -1);

	    Tcl_ListObjAppendElement(NULL, returnCmd, errInfo);

	    for (p = envPtr->source; p != parse.commandStart; p++) {
		if (*p == '\n') {
		    errorLine++;
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184





































































































1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199

1200
1201
1202
1203

1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353

1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
	    /*
	     * Determine the actual length of the command.
	     */

	    commandLength = parse.commandSize;
	    if (parse.term == parse.commandStart + commandLength - 1) {
		/*
		 * The command terminator character (such as ; or ]) is
		 * the last character in the parsed command.  Reduce the
		 * length by one so that the trace message doesn't include
		 * the terminator character.
		 */
		
		commandLength -= 1;
	    }

#ifdef TCL_COMPILE_DEBUG
	    /*
             * If tracing, print a line for each top level command compiled.
             */

	    if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
		fprintf(stdout, "  Compiling: ");
		TclPrintSource(stdout, parse.commandStart,
			TclMin(commandLength, 55));
		fprintf(stdout, "\n");
	    }
#endif

	    /*
	     * Check whether expansion has been requested for any of
	     * the words
	     */

	    for (wordIdx = 0, tokenPtr = parse.tokenPtr;
		    wordIdx < parse.numWords;
		    wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    expand = 1;
		    TclEmitOpcode(INST_EXPAND_START, envPtr);		    
		    break;
		}
	    }

	    envPtr->numCommands++;
	    currCmdIndex = (envPtr->numCommands - 1);
	    lastTopLevelCmdIndex = currCmdIndex;
	    startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
	    EnterCmdStartData(envPtr, currCmdIndex,
	            (parse.commandStart - envPtr->source), startCodeOffset);

	    /*
	     * Each iteration of the following loop compiles one word
	     * from the command.
	     */
	    
	    for (wordIdx = 0, tokenPtr = parse.tokenPtr;
		    wordIdx < parse.numWords; wordIdx++,
		    tokenPtr += (tokenPtr->numComponents + 1)) {

		if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    /*
		     * If this is the first word and the command has a
		     * compile procedure, let it compile the command.
		     */

		    if ((wordIdx == 0) && !expand) {
			/*
			 * We copy the string before trying to find the command
			 * by name.  We used to modify the string in place, but
			 * this is not safe because the name resolution
			 * handlers could have side effects that rely on the
			 * unmodified string.
			 */

			Tcl_DStringSetLength(&ds, 0);
			Tcl_DStringAppend(&ds, tokenPtr[1].start,
				tokenPtr[1].size);

			cmdPtr = (Command *) Tcl_FindCommand(interp,
				Tcl_DStringValue(&ds),
			        (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);

			if ((cmdPtr != NULL)
			        && (cmdPtr->compileProc != NULL)
			        && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
			        && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
			    int savedNumCmds = envPtr->numCommands;
			    unsigned int savedCodeNext =
				    envPtr->codeNext - envPtr->codeStart;			    

			    /*
			     * Mark the start of the command; the proper
			     * bytecode length will be updated later. There
			     * is no need to do this for the first command
			     * in the compile env, as the check is done before
			     * calling TclExecuteByteCode(). Remark that we
			     * are compiling the first cmd in the environment
			     * exactly when (savedCodeNext == 0)
			     */

			    if (savedCodeNext != 0) {
				TclEmitInstInt4(INST_START_CMD, 0, envPtr);				
			    }
			    
			    code = (*(cmdPtr->compileProc))(interp, &parse,
			            envPtr);
			    
			    if (code == TCL_OK) {
				if (savedCodeNext != 0) {
				    /*
				     * Fix the bytecode length.
				     */
				    unsigned char *fixPtr = envPtr->codeStart
					    + savedCodeNext + 1;
				    unsigned int fixLen = envPtr->codeNext
					    - envPtr->codeStart
					    - savedCodeNext;
				
				    TclStoreInt4AtPtr(fixLen, fixPtr);
				}				
				goto finishCommand;
			    } else if (code == TCL_OUT_LINE_COMPILE) {
				/*
				 * Restore numCommands and codeNext to their
				 * correct values, removing any commands
				 * compiled before TCL_OUT_LINE_COMPILE
				 * [Bugs 705406 and 735055]
				 */
				envPtr->numCommands = savedNumCmds;
				envPtr->codeNext = envPtr->codeStart
					+ savedCodeNext;
			    } else { /* an error */
				Tcl_Panic("TclCompileScript: compileProc returned TCL_ERROR\n");
			    }
			}

			/*
			 * No compile procedure so push the word. If the
			 * command was found, push a CmdName object to
			 * reduce runtime lookups.
			 */

			objIndex = TclRegisterNewLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size);
			if (cmdPtr != NULL) {
			    TclSetCmdNameObj(interp,
			           envPtr->literalArrayPtr[objIndex].objPtr,
				   cmdPtr);
			}
			if ((wordIdx == 0) && (parse.numWords == 1)) {
			    /*
			     * Single word script: unshare the command name to
			     * avoid shimmering between bytecode and cmdName
			     * representations [Bug 458361]
			     */

			    TclHideLiteral(interp, envPtr, objIndex);
			}
		    } else {
			objIndex = TclRegisterNewLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size);
		    }
		    TclEmitPush(objIndex, envPtr);
		} else {
		    /*
		     * The word is not a simple string of characters.
		     */
		    
		    TclCompileTokens(interp, tokenPtr+1,
			    tokenPtr->numComponents, envPtr);
		}
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    TclEmitInstInt4(INST_EXPAND_STKTOP, 
		            envPtr->currStackDepth, envPtr);
		}





































































































	    }

	    /*
	     * Emit an invoke instruction for the command. We skip this
	     * if a compile procedure was found for the command.
	     */

	    if (expand) {
		/*
		 * The stack depth during argument expansion can only be
		 * managed at runtime, as the number of elements in the
		 * expanded lists is not known at compile time.
		 * We adjust here the stack depth estimate so that it is
		 * correct after the command with expanded arguments
		 * returns.

		 * The end effect of this command's invocation is that 
		 * all the words of the command are popped from the stack, 
		 * and the result is pushed: the stack top changes by
		 * (1-wordIdx).

		 * Note that the estimates are not correct while the 
		 * command is being prepared and run, INST_EXPAND_STKTOP 
		 * is not stack-neutral in general. 
		 */

		TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
		TclAdjustStackDepth((1-wordIdx), envPtr);
	    } else if (wordIdx > 0) {
		if (wordIdx <= 255) {
		    TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
		} else {
		    TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
		}
	    } 

	    /*
	     * Update the compilation environment structure and record the
	     * offsets of the source and code for the command.
	     */

	    finishCommand:
	    EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
		    (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
	    isFirstCmd = 0;
	} /* end if parse.numWords > 0 */

	/*
	 * Advance to the next command in the script.
	 */
	
	next = parse.commandStart + parse.commandSize;
	bytesLeft -= (next - p);
	p = next;
	Tcl_FreeParse(&parse);
	gotParse = 0;
    } while (bytesLeft > 0);

    /*
     * If the source script yielded no instructions (e.g., if it was empty),
     * push an empty string as the command's result.
     *
     * WARNING: push an unshared object! If the script being compiled is a
     * shared empty string, it will otherwise be self-referential and cause
     * difficulties with literal management [Bugs 467523, 983660]. We used to
     * have special code in TclReleaseLiteral to handle this particular
     * self-reference, but now opt for avoiding its creation altogether.
     */
    
    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr);
    }
    
    envPtr->numSrcBytes = (p - script);
    Tcl_DStringFree(&ds);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileTokens --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
 *	that make up a word) this procedure emits instructions to evaluate
 *	the tokens and concatenate their values to form a single result
 *	value on the interpreter's runtime evaluation stack.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *	
 * Side effects:
 *	Instructions are added to envPtr to push and evaluate the tokens
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileTokens(interp, tokenPtr, count, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens
				 * to compile. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    CONST char *name, *p;
    int numObjsToConcat, nameBytes, localVarName, localVar;
    int length, i;
    unsigned char *entryCodeNext = envPtr->codeNext;

    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;
    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {
	    case TCL_TOKEN_TEXT:
		Tcl_DStringAppend(&textBuffer, tokenPtr->start,
			tokenPtr->size);
		break;

	    case TCL_TOKEN_BS:
		length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
			buffer);
		Tcl_DStringAppend(&textBuffer, buffer, length);
		break;

	    case TCL_TOKEN_COMMAND:
		/*
		 * Push any accumulated chars appearing before the command.
		 */
		
		if (Tcl_DStringLength(&textBuffer) > 0) {
		    int literal;
		    
		    literal = TclRegisterLiteral(envPtr,
			    Tcl_DStringValue(&textBuffer),
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
		}
		
		TclCompileScript(interp, tokenPtr->start+1,
			tokenPtr->size-2, envPtr);
		numObjsToConcat++;
		break;

	    case TCL_TOKEN_VARIABLE:
		/*
		 * Push any accumulated chars appearing before the $<var>.
		 */
		
		if (Tcl_DStringLength(&textBuffer) > 0) {
		    int literal;
		    
		    literal = TclRegisterLiteral(envPtr,
			    Tcl_DStringValue(&textBuffer),
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
		}
		
		/*
		 * Determine how the variable name should be handled: if it contains 
		 * any namespace qualifiers it is not a local variable (localVarName=-1);
		 * if it looks like an array element and the token has a single component, 

		 * it should not be created here [Bug 569438] (localVarName=0); otherwise, 
		 * the local variable can safely be created (localVarName=1).
		 */
		
		name = tokenPtr[1].start;
		nameBytes = tokenPtr[1].size;
		localVarName = -1;
		if (envPtr->procPtr != NULL) {
		    localVarName = 1;
		    for (i = 0, p = name;  i < nameBytes;  i++, p++) {
			if ((*p == ':') && (i < (nameBytes-1))
			        && (*(p+1) == ':')) {
			    localVarName = -1;
			    break;
			} else if ((*p == '(')
			        && (tokenPtr->numComponents == 1) 
				&& (*(name + nameBytes - 1) == ')')) {
			    localVarName = 0;
			    break;
			}
		    }
		}

		/*
		 * Either push the variable's name, or find its index in
		 * the array of local variables in a procedure frame. 
		 */

		localVar = -1;
		if (localVarName != -1) {
		    localVar = TclFindCompiledLocal(name, nameBytes, 
			        localVarName, /*flags*/ 0, envPtr->procPtr);
		}
		if (localVar < 0) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
			    envPtr); 
		}

		/*
		 * Emit instructions to load the variable.
		 */
		
		if (tokenPtr->numComponents == 1) {
		    if (localVar < 0) {
			TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
		    } else if (localVar <= 255) {
			TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
			        envPtr);
		    } else {
			TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
				envPtr);
		    }
		} else {
		    TclCompileTokens(interp, tokenPtr+2,
			    tokenPtr->numComponents-1, envPtr);
		    if (localVar < 0) {
			TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
		    } else if (localVar <= 255) {
			TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
			        envPtr);
		    } else {
			TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
			        envPtr);
		    }
		}
		numObjsToConcat++;
		count -= tokenPtr->numComponents;
		tokenPtr += tokenPtr->numComponents;
		break;

	    default:
		Tcl_Panic("Unexpected token type in TclCompileTokens");
	}
    }

    /*
     * Push any accumulated characters appearing at the end.
     */

    if (Tcl_DStringLength(&textBuffer) > 0) {
	int literal;

	literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
	        Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
	TclEmitPush(literal, envPtr);
	numObjsToConcat++;
    }

    /*
     * If necessary, concatenate the parts of the word.
     */

    while (numObjsToConcat > 255) {
	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
	numObjsToConcat -= 254;	/* concat pushes 1 obj, the result */
    }
    if (numObjsToConcat > 1) {
	TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
    }

    /*
     * If the tokens yielded no instructions, push an empty string.
     */
    
    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
	        envPtr);
    }
    Tcl_DStringFree(&textBuffer);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCmdWord --
 *
 *	Given an array of parse tokens for a word containing one or more Tcl
 *	commands, emit inline instructions to execute them. This procedure
 *	differs from TclCompileTokens in that a simple word such as a loop
 *	body enclosed in braces is not just pushed as a string, but is
 *	itself parsed into tokens and compiled.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *	
 * Side effects:
 *	Instructions are added to envPtr to execute the tokens at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileCmdWord(interp, tokenPtr, count, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens
				 * for a command word to compile inline. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
	/*
	 * Handle the common case: if there is a single text token,
	 * compile it into an inline sequence of instructions.
	 */
    
	TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
    } else {
	/*
	 * Multiple tokens or the single token involves substitutions.
	 * Emit instructions to invoke the eval command procedure at
	 * runtime on the result of evaluating the tokens.
	 */

	TclCompileTokens(interp, tokenPtr, count, envPtr);
	TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
}








|
|
|
|

|





|
|










|
<







|









|


|
|

|




|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|


<
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|






|
|
|
<
>
|
|
|
<
>
|
|
|










|






|








|

















|



|










|
|
|




|

|
|







|
|
















|
|
<
|

|
|
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
|
|

|
|










|
|



















|

|
<












|
|




|









|
|






|
|

|



|
|
|







1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090

1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120








































































































1121
1122
1123
1124
1125

1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244

1245
1246
1247
1248

1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349

1350
1351
1352
1353

1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409

1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444

1445
1446

1447
1448
1449
1450
1451
1452
1453
1454

1455
1456

1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499

1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
	    /*
	     * Determine the actual length of the command.
	     */

	    commandLength = parse.commandSize;
	    if (parse.term == parse.commandStart + commandLength - 1) {
		/*
		 * The command terminator character (such as ; or ]) is the
		 * last character in the parsed command.  Reduce the length by
		 * one so that the trace message doesn't include the
		 * terminator character.
		 */

		commandLength -= 1;
	    }

#ifdef TCL_COMPILE_DEBUG
	    /*
	     * If tracing, print a line for each top level command compiled.
	     */

	    if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
		fprintf(stdout, "  Compiling: ");
		TclPrintSource(stdout, parse.commandStart,
			TclMin(commandLength, 55));
		fprintf(stdout, "\n");
	    }
#endif

	    /*
	     * Check whether expansion has been requested for any of the words

	     */

	    for (wordIdx = 0, tokenPtr = parse.tokenPtr;
		    wordIdx < parse.numWords;
		    wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    expand = 1;
		    TclEmitOpcode(INST_EXPAND_START, envPtr);
		    break;
		}
	    }

	    envPtr->numCommands++;
	    currCmdIndex = (envPtr->numCommands - 1);
	    lastTopLevelCmdIndex = currCmdIndex;
	    startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
	    EnterCmdStartData(envPtr, currCmdIndex,
		    (parse.commandStart - envPtr->source), startCodeOffset);

	    /*
	     * Each iteration of the following loop compiles one word from the
	     * command.
	     */

	    for (wordIdx = 0, tokenPtr = parse.tokenPtr;
		    wordIdx < parse.numWords; wordIdx++,
		    tokenPtr += (tokenPtr->numComponents + 1)) {

		if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		    /*








































































































		     * The word is not a simple string of characters.
		     */

		    TclCompileTokens(interp, tokenPtr+1,
			    tokenPtr->numComponents, envPtr);

		    if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
			TclEmitInstInt4(INST_EXPAND_STKTOP,
				envPtr->currStackDepth, envPtr);
		    }
		    continue;
		}

		/*
		 * This is a simple string of literal characters (i.e. we know
		 * it absolutely and can use it directly).  If this is the
		 * first word and the command has a compile procedure, let it
		 * compile the command.
		 */

		if ((wordIdx == 0) && !expand) {
		    /*
		     * We copy the string before trying to find the command by
		     * name.  We used to modify the string in place, but this
		     * is not safe because the name resolution handlers could
		     * have side effects that rely on the unmodified string.
		     */

		    Tcl_DStringSetLength(&ds, 0);
		    Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size);

		    cmdPtr = (Command *) Tcl_FindCommand(interp,
			    Tcl_DStringValue(&ds),
			    (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);

		    if ((cmdPtr != NULL)
			    && (cmdPtr->compileProc != NULL)
			    && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
			    && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
			int savedNumCmds = envPtr->numCommands;
			unsigned int savedCodeNext =
				envPtr->codeNext - envPtr->codeStart;

			/*
			 * Mark the start of the command; the proper bytecode
			 * length will be updated later. There is no need to
			 * do this for the first command in the compile env,
			 * as the check is done before calling
			 * TclExecuteByteCode(). Remark that we are compiling
			 * the first cmd in the environment exactly when
			 * (savedCodeNext == 0)
			 */

			if (savedCodeNext != 0) {
			    TclEmitInstInt4(INST_START_CMD, 0, envPtr);
			}

			code = (cmdPtr->compileProc)(interp, &parse, envPtr);

			if (code == TCL_OK) {
			    if (savedCodeNext != 0) {
				/*
				 * Fix the bytecode length.
				 */
				unsigned char *fixPtr = envPtr->codeStart
					+ savedCodeNext + 1;
				unsigned int fixLen = envPtr->codeNext
					- envPtr->codeStart - savedCodeNext;

				TclStoreInt4AtPtr(fixLen, fixPtr);
			    }
			    goto finishCommand;
			} else {
			    /*
			     * Restore numCommands and codeNext to their
			     * correct values, removing any commands compiled
			     * before the failure to produce bytecode got
			     * reported.  [Bugs 705406 and 735055]
			     */
			    envPtr->numCommands = savedNumCmds;
			    envPtr->codeNext = envPtr->codeStart+savedCodeNext;
			}
		    }

		    /*
		     * No compile procedure so push the word. If the command
		     * was found, push a CmdName object to reduce runtime
		     * lookups. Avoid sharing this literal among different
		     * namespaces to reduce shimmering.
		     */

		    objIndex = TclRegisterNewNSLiteral(envPtr,
			    tokenPtr[1].start, tokenPtr[1].size);
		    if (cmdPtr != NULL) {
			TclSetCmdNameObj(interp,
			      envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr);
		    }
		    if ((wordIdx == 0) && (parse.numWords == 1)) {
			/*
			 * Single word script: unshare the command name to
			 * avoid shimmering between bytecode and cmdName
			 * representations [Bug 458361]
			 */

			TclHideLiteral(interp, envPtr, objIndex);
		    }
		} else {
		    objIndex = TclRegisterNewLiteral(envPtr,
			    tokenPtr[1].start, tokenPtr[1].size);
		}
		TclEmitPush(objIndex, envPtr);
	    }

	    /*
	     * Emit an invoke instruction for the command. We skip this if a
	     * compile procedure was found for the command.
	     */

	    if (expand) {
		/*
		 * The stack depth during argument expansion can only be
		 * managed at runtime, as the number of elements in the
		 * expanded lists is not known at compile time.  We adjust
		 * here the stack depth estimate so that it is correct after
		 * the command with expanded arguments returns.

		 *
		 * The end effect of this command's invocation is that all the
		 * words of the command are popped from the stack, and the
		 * result is pushed: the stack top changes by (1-wordIdx).

		 *
		 * Note that the estimates are not correct while the command
		 * is being prepared and run, INST_EXPAND_STKTOP is not
		 * stack-neutral in general.
		 */

		TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
		TclAdjustStackDepth((1-wordIdx), envPtr);
	    } else if (wordIdx > 0) {
		if (wordIdx <= 255) {
		    TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
		} else {
		    TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
		}
	    }

	    /*
	     * Update the compilation environment structure and record the
	     * offsets of the source and code for the command.
	     */

	finishCommand:
	    EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
		    (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
	    isFirstCmd = 0;
	} /* end if parse.numWords > 0 */

	/*
	 * Advance to the next command in the script.
	 */

	next = parse.commandStart + parse.commandSize;
	bytesLeft -= (next - p);
	p = next;
	Tcl_FreeParse(&parse);
	gotParse = 0;
    } while (bytesLeft > 0);

    /*
     * If the source script yielded no instructions (e.g., if it was empty),
     * push an empty string as the command's result.
     *
     * WARNING: push an unshared object! If the script being compiled is a
     * shared empty string, it will otherwise be self-referential and cause
     * difficulties with literal management [Bugs 467523, 983660]. We used to
     * have special code in TclReleaseLiteral to handle this particular
     * self-reference, but now opt for avoiding its creation altogether.
     */

    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr);
    }

    envPtr->numSrcBytes = (p - script);
    Tcl_DStringFree(&ds);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileTokens --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
 *	that make up a word) this procedure emits instructions to evaluate the
 *	tokens and concatenate their values to form a single result value on
 *	the interpreter's runtime evaluation stack.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *
 * Side effects:
 *	Instructions are added to envPtr to push and evaluate the tokens at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileTokens(interp, tokenPtr, count, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens to
				 * compile. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    CONST char *name, *p;
    int numObjsToConcat, nameBytes, localVarName, localVar;
    int length, i;
    unsigned char *entryCodeNext = envPtr->codeNext;

    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;
    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
	    Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size);

	    break;

	case TCL_TOKEN_BS:
	    length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer);

	    Tcl_DStringAppend(&textBuffer, buffer, length);
	    break;

	case TCL_TOKEN_COMMAND:
	    /*
	     * Push any accumulated chars appearing before the command.
	     */

	    if (Tcl_DStringLength(&textBuffer) > 0) {
		int literal;

		literal = TclRegisterNewLiteral(envPtr,
			Tcl_DStringValue(&textBuffer),
			Tcl_DStringLength(&textBuffer));
		TclEmitPush(literal, envPtr);
		numObjsToConcat++;
		Tcl_DStringFree(&textBuffer);
	    }

	    TclCompileScript(interp, tokenPtr->start+1,
		    tokenPtr->size-2, envPtr);
	    numObjsToConcat++;
	    break;

	case TCL_TOKEN_VARIABLE:
	    /*
	     * Push any accumulated chars appearing before the $<var>.
	     */

	    if (Tcl_DStringLength(&textBuffer) > 0) {
		int literal;

		literal = TclRegisterNewLiteral(envPtr,
			Tcl_DStringValue(&textBuffer),
			Tcl_DStringLength(&textBuffer));
		TclEmitPush(literal, envPtr);
		numObjsToConcat++;
		Tcl_DStringFree(&textBuffer);
	    }

	    /*
	     * Determine how the variable name should be handled: if it
	     * contains any namespace qualifiers it is not a local variable
	     * (localVarName=-1); if it looks like an array element and the
	     * token has a single component, it should not be created here
	     * [Bug 569438] (localVarName=0); otherwise, the local variable
	     * can safely be created (localVarName=1).
	     */

	    name = tokenPtr[1].start;
	    nameBytes = tokenPtr[1].size;
	    localVarName = -1;
	    if (envPtr->procPtr != NULL) {
		localVarName = 1;
		for (i = 0, p = name;  i < nameBytes;  i++, p++) {
		    if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) {

			localVarName = -1;
			break;
		    } else if ((*p == '(')
			    && (tokenPtr->numComponents == 1)
			    && (*(name + nameBytes - 1) == ')')) {
			localVarName = 0;
			break;
		    }
		}
	    }

	    /*
	     * Either push the variable's name, or find its index in the array
	     * of local variables in a procedure frame.
	     */

	    localVar = -1;
	    if (localVarName != -1) {
		localVar = TclFindCompiledLocal(name, nameBytes, localVarName,
			/*flags*/ 0, envPtr->procPtr);
	    }
	    if (localVar < 0) {
		TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
			envPtr);
	    }

	    /*
	     * Emit instructions to load the variable.
	     */

	    if (tokenPtr->numComponents == 1) {
		if (localVar < 0) {
		    TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
		} else if (localVar <= 255) {
		    TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);

		} else {
		    TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);

		}
	    } else {
		TclCompileTokens(interp, tokenPtr+2,
			tokenPtr->numComponents-1, envPtr);
		if (localVar < 0) {
		    TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
		} else if (localVar <= 255) {
		    TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);

		} else {
		    TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);

		}
	    }
	    numObjsToConcat++;
	    count -= tokenPtr->numComponents;
	    tokenPtr += tokenPtr->numComponents;
	    break;

	default:
	    Tcl_Panic("Unexpected token type in TclCompileTokens");
	}
    }

    /*
     * Push any accumulated characters appearing at the end.
     */

    if (Tcl_DStringLength(&textBuffer) > 0) {
	int literal;

	literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer),
		Tcl_DStringLength(&textBuffer));
	TclEmitPush(literal, envPtr);
	numObjsToConcat++;
    }

    /*
     * If necessary, concatenate the parts of the word.
     */

    while (numObjsToConcat > 255) {
	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
	numObjsToConcat -= 254;	/* concat pushes 1 obj, the result */
    }
    if (numObjsToConcat > 1) {
	TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
    }

    /*
     * If the tokens yielded no instructions, push an empty string.
     */

    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);

    }
    Tcl_DStringFree(&textBuffer);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCmdWord --
 *
 *	Given an array of parse tokens for a word containing one or more Tcl
 *	commands, emit inline instructions to execute them. This procedure
 *	differs from TclCompileTokens in that a simple word such as a loop
 *	body enclosed in braces is not just pushed as a string, but is itself
 *	parsed into tokens and compiled.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the tokens at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileCmdWord(interp, tokenPtr, count, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens for
				 * a command word to compile inline. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
	/*
	 * Handle the common case: if there is a single text token, compile it
	 * into an inline sequence of instructions.
	 */

	TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
    } else {
	/*
	 * Multiple tokens or the single token involves substitutions.  Emit
	 * instructions to invoke the eval command procedure at runtime on the
	 * result of evaluating the tokens.
	 */

	TclCompileTokens(interp, tokenPtr, count, envPtr);
	TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
}

1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
 *	expression. This procedure differs from TclCompileExpr in that it
 *	supports Tcl's two-level substitution semantics for expressions that
 *	appear as command words.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *	
 * Side effects:
 *	Instructions are added to envPtr to execute the expression.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Points to first in an array of word
				 * tokens tokens for the expression to
				 * compile inline. */
    int numWords;		/* Number of word tokens starting at
				 * tokenPtr. Must be at least 1. Each word
				 * token contains one or more subtokens. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_Token *wordPtr;
    int i, concatItems;

    /*
     * If the expression is a single word that doesn't require
     * substitutions, just compile its string into inline instructions.
     */

    if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
	CONST char *script = tokenPtr[1].start;
	int numBytes = tokenPtr[1].size;
	int savedNumCmds = envPtr->numCommands;
	unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart;

	if (TclCompileExpr(interp, script, numBytes, envPtr) == TCL_OK) {
	    return;
	}
	envPtr->numCommands = savedNumCmds;
	envPtr->codeNext = envPtr->codeStart + savedCodeNext;
    }
   
    /*
     * Emit code to call the expr command proc at runtime. Concatenate the
     * (already substituted once) expr tokens with a space between each.
     */

    wordPtr = tokenPtr;
    for (i = 0;  i < numWords;  i++) {
	TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr);
	if (i < (numWords - 1)) {
	    TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
	            envPtr);
	}
	wordPtr += (wordPtr->numComponents + 1);
    }
    concatItems = 2*numWords - 1;
    while (concatItems > 255) {
	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
	concatItems -= 254;
    }
    if (concatItems > 1) {
	TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
    }
    TclEmitOpcode(INST_EXPR_STK, envPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitByteCodeObj --
 *
 *	Create a ByteCode structure and initialize it from a CompileEnv
 *	compilation environment structure. The ByteCode structure is
 *	smaller and contains just that information needed to execute
 *	the bytecode instructions resulting from compiling a Tcl script.
 *	The resulting structure is placed in the specified object.
 *
 * Results:
 *	A newly constructed ByteCode object is stored in the internal
 *	representation of the objPtr.
 *
 * Side effects:
 *	A single heap object is allocated to hold the new ByteCode structure
 *	and its code, object, command location, and aux data arrays. Note
 *	that "ownership" (i.e., the pointers to) the Tcl objects and aux
 *	data items will be handed over to the new ByteCode structure from
 *	the CompileEnv structure.
 *
 *----------------------------------------------------------------------
 */

void
TclInitByteCodeObj(objPtr, envPtr)
    Tcl_Obj *objPtr;		 /* Points object that should be
				  * initialized, and whose string rep
				  * contains the source code. */
    register CompileEnv *envPtr; /* Points to the CompileEnv structure from
				  * which to create a ByteCode structure. */
{
    register ByteCode *codePtr;
    size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
    size_t auxDataArrayBytes, structureSize;
    register unsigned char *p;







|









|
|
|
|
|
|






|
|














|









|
<




















|
|
|
|







|
|
|
|






|
|
|







1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615

1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
 *	expression. This procedure differs from TclCompileExpr in that it
 *	supports Tcl's two-level substitution semantics for expressions that
 *	appear as command words.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the expression.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Points to first in an array of word tokens
				 * tokens for the expression to compile
				 * inline. */
    int numWords;		/* Number of word tokens starting at tokenPtr.
				 * Must be at least 1. Each word token
				 * contains one or more subtokens. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_Token *wordPtr;
    int i, concatItems;

    /*
     * If the expression is a single word that doesn't require substitutions,
     * just compile its string into inline instructions.
     */

    if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
	CONST char *script = tokenPtr[1].start;
	int numBytes = tokenPtr[1].size;
	int savedNumCmds = envPtr->numCommands;
	unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart;

	if (TclCompileExpr(interp, script, numBytes, envPtr) == TCL_OK) {
	    return;
	}
	envPtr->numCommands = savedNumCmds;
	envPtr->codeNext = envPtr->codeStart + savedCodeNext;
    }

    /*
     * Emit code to call the expr command proc at runtime. Concatenate the
     * (already substituted once) expr tokens with a space between each.
     */

    wordPtr = tokenPtr;
    for (i = 0;  i < numWords;  i++) {
	TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr);
	if (i < (numWords - 1)) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr);

	}
	wordPtr += (wordPtr->numComponents + 1);
    }
    concatItems = 2*numWords - 1;
    while (concatItems > 255) {
	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
	concatItems -= 254;
    }
    if (concatItems > 1) {
	TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
    }
    TclEmitOpcode(INST_EXPR_STK, envPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitByteCodeObj --
 *
 *	Create a ByteCode structure and initialize it from a CompileEnv
 *	compilation environment structure. The ByteCode structure is smaller
 *	and contains just that information needed to execute the bytecode
 *	instructions resulting from compiling a Tcl script.  The resulting
 *	structure is placed in the specified object.
 *
 * Results:
 *	A newly constructed ByteCode object is stored in the internal
 *	representation of the objPtr.
 *
 * Side effects:
 *	A single heap object is allocated to hold the new ByteCode structure
 *	and its code, object, command location, and aux data arrays. Note that
 *	"ownership" (i.e., the pointers to) the Tcl objects and aux data items
 *	will be handed over to the new ByteCode structure from the CompileEnv
 *	structure.
 *
 *----------------------------------------------------------------------
 */

void
TclInitByteCodeObj(objPtr, envPtr)
    Tcl_Obj *objPtr;		 /* Points object that should be initialized,
				  * and whose string rep contains the source
				  * code. */
    register CompileEnv *envPtr; /* Points to the CompileEnv structure from
				  * which to create a ByteCode structure. */
{
    register ByteCode *codePtr;
    size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
    size_t auxDataArrayBytes, structureSize;
    register unsigned char *p;
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668



1669

1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982

1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
    iPtr = envPtr->iPtr;

    codeBytes = (envPtr->codeNext - envPtr->codeStart);
    objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
    exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
    auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
    cmdLocBytes = GetCmdLocEncodingSize(envPtr);
    
    /*
     * Compute the total number of bytes needed for this bytecode.
     */

    structureSize = sizeof(ByteCode);
    structureSize += TCL_ALIGN(codeBytes);        /* align object array */
    structureSize += TCL_ALIGN(objArrayBytes);    /* align exc range arr */
    structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
    structureSize += auxDataArrayBytes;
    structureSize += cmdLocBytes;

    if (envPtr->iPtr->varFramePtr != NULL) {
        namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
    } else {
        namespacePtr = envPtr->iPtr->globalNsPtr;
    }
    
    p = (unsigned char *) ckalloc((size_t) structureSize);
    codePtr = (ByteCode *) p;
    codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
    codePtr->compileEpoch = iPtr->compileEpoch;
    codePtr->nsPtr = namespacePtr;
    codePtr->nsEpoch = namespacePtr->resolverEpoch;
    codePtr->refCount = 1;



    codePtr->flags = 0;

    codePtr->source = envPtr->source;
    codePtr->procPtr = envPtr->procPtr;

    codePtr->numCommands = envPtr->numCommands;
    codePtr->numSrcBytes = envPtr->numSrcBytes;
    codePtr->numCodeBytes = codeBytes;
    codePtr->numLitObjects = numLitObjects;
    codePtr->numExceptRanges = envPtr->exceptArrayNext;
    codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
    codePtr->numCmdLocBytes = cmdLocBytes;
    codePtr->maxExceptDepth = envPtr->maxExceptDepth;
    codePtr->maxStackDepth = envPtr->maxStackDepth;

    p += sizeof(ByteCode);
    codePtr->codeStart = p;
    memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
    
    p += TCL_ALIGN(codeBytes);	      /* align object array */
    codePtr->objArrayPtr = (Tcl_Obj **) p;
    for (i = 0;  i < numLitObjects;  i++) {
	codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
    }

    p += TCL_ALIGN(objArrayBytes);    /* align exception range array */
    if (exceptArrayBytes > 0) {
	codePtr->exceptArrayPtr = (ExceptionRange *) p;
	memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
	        (size_t) exceptArrayBytes);
    } else {
	codePtr->exceptArrayPtr = NULL;
    }
    
    p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
    if (auxDataArrayBytes > 0) {
	codePtr->auxDataArrayPtr = (AuxData *) p;
	memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
	        (size_t) auxDataArrayBytes);
    } else {
	codePtr->auxDataArrayPtr = NULL;
    }

    p += auxDataArrayBytes;
#ifndef TCL_COMPILE_DEBUG
    EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
#else
    nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
    if (((size_t)(nextPtr - p)) != cmdLocBytes) {	
	Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
    }
#endif
    
    /*
     * Record various compilation-related statistics about the new ByteCode
     * structure. Don't include overhead for statistics-related fields.
     */

#ifdef TCL_COMPILE_STATS
    codePtr->structureSize = structureSize
	    - (sizeof(size_t) + sizeof(Tcl_Time));
    Tcl_GetTime(&(codePtr->createTime));
    
    RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */
    
    /*
     * Free the old internal rep then convert the object to a
     * bytecode object by making its internal rep point to the just
     * compiled ByteCode.
     */
	    
    TclFreeIntRep(objPtr);
    objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
    objPtr->typePtr = &tclByteCodeType;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindCompiledLocal --
 *
 *	This procedure is called at compile time to look up and optionally
 *	allocate an entry ("slot") for a variable in a procedure's array of
 *	local variables. If the variable's name is NULL, a new temporary
 *	variable is always created. (Such temporary variables can only be
 *	referenced using their slot index.)
 *
 * Results:
 *	If create is 0 and the name is non-NULL, then if the variable is
 *	found, the index of its entry in the procedure's array of local
 *	variables is returned; otherwise -1 is returned. If name is NULL,
 *	the index of a new temporary variable is returned. Finally, if
 *	create is 1 and name is non-NULL, the index of a new entry is
 *	returned.
 *
 * Side effects:
 *	Creates and registers a new local variable if create is 1 and
 *	the variable is unknown, or if the name is NULL.
 *
 *----------------------------------------------------------------------
 */

int
TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
    register CONST char *name;	/* Points to first character of the name of
				 * a scalar or array variable. If NULL, a
				 * temporary var should be created. */
    int nameBytes;		/* Number of bytes in the name. */
    int create;			/* If 1, allocate a local frame entry for
				 * the variable if it is new. */
    int flags;			/* Flag bits for the compiled local if
				 * created. Only VAR_SCALAR, VAR_ARRAY, and
				 * VAR_LINK make sense. */
    register Proc *procPtr;	/* Points to structure describing procedure
				 * containing the variable reference. */
{
    register CompiledLocal *localPtr;
    int localVar = -1;
    register int i;

    /*
     * If not creating a temporary, does a local variable of the specified
     * name already exist?
     */

    if (name != NULL) {	
	int localCt = procPtr->numCompiledLocals;
	localPtr = procPtr->firstLocalPtr;
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		char *localName = localPtr->name;
		if ((nameBytes == localPtr->nameLength)
	                && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
		    return i;
		}
	    }
	    localPtr = localPtr->nextPtr;
	}
    }

    /*
     * Create a new variable if appropriate.
     */
    
    if (create || (name == NULL)) {
	localVar = procPtr->numCompiledLocals;
	localPtr = (CompiledLocal *) ckalloc((unsigned) 
	        (sizeof(CompiledLocal) - sizeof(localPtr->name)
		+ nameBytes+1));
	if (procPtr->firstLocalPtr == NULL) {
	    procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	} else {
	    procPtr->lastLocalPtr->nextPtr = localPtr;
	    procPtr->lastLocalPtr = localPtr;
	}
	localPtr->nextPtr = NULL;
	localPtr->nameLength = nameBytes;
	localPtr->frameIndex = localVar;
	localPtr->flags = flags | VAR_UNDEFINED;
	if (name == NULL) {
	    localPtr->flags |= VAR_TEMPORARY;
	}
	localPtr->defValuePtr = NULL;
	localPtr->resolveInfo = NULL;

	if (name != NULL) {
	    memcpy((VOID *) localPtr->name, (VOID *) name,
	            (size_t) nameBytes);
	}
	localPtr->name[nameBytes] = '\0';
	procPtr->numCompiledLocals++;
    }
    return localVar;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitCompiledLocals --
 *
 *	This routine is invoked in order to initialize the compiled
 *	locals table for a new call frame.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May invoke various name resolvers in order to determine which
 *	variables are being referenced at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclInitCompiledLocals(interp, framePtr, nsPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
    CallFrame *framePtr;	/* Call frame to initialize. */
    Namespace *nsPtr;		/* Pointer to current namespace. */
{
    register CompiledLocal *localPtr;
    Interp *iPtr = (Interp*) interp;
    Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
    Var *varPtr = framePtr->compiledLocals;
    Var *resolvedVarPtr;
    ResolverScheme *resPtr;
    int result;

    /*
     * Initialize the array of local variables stored in the call frame.
     * Some variables may have special resolution rules.  In that case,
     * we call their "resolver" procs to get our hands on the variable,
     * and we make the compiled local a link to the real variable.
     */

    for (localPtr = framePtr->procPtr->firstLocalPtr;
	 localPtr != NULL;
	 localPtr = localPtr->nextPtr) {

	/*
	 * Check to see if this local is affected by namespace or
	 * interp resolvers.  The resolver to use is cached for the
	 * next invocation of the procedure.
	 */

	if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
		&& (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
	    resPtr = iPtr->resolverPtr;

	    if (nsPtr->compiledVarResProc) {
		result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
			localPtr->name, localPtr->nameLength,
			(Tcl_Namespace *) nsPtr, &vinfo);
	    } else {
		result = TCL_CONTINUE;
	    }

	    while ((result == TCL_CONTINUE) && resPtr) {
		if (resPtr->compiledVarResProc) {
		    result = (*resPtr->compiledVarResProc)(nsPtr->interp,
			    localPtr->name, localPtr->nameLength,
			    (Tcl_Namespace *) nsPtr, &vinfo);
		}
		resPtr = resPtr->nextPtr;
	    }
	    if (result == TCL_OK) {
		localPtr->resolveInfo = vinfo;
		localPtr->flags |= VAR_RESOLVED;
	    }
	}

	/*
	 * Now invoke the resolvers to determine the exact variables that
	 * should be used.
	 */

        resVarInfo = localPtr->resolveInfo;
        resolvedVarPtr = NULL;

        if (resVarInfo && resVarInfo->fetchProc) {
            resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
		    resVarInfo);
        }

        if (resolvedVarPtr) {
	    varPtr->name = localPtr->name; /* will be just '\0' if temp var */
	    varPtr->nsPtr = NULL;
	    varPtr->hPtr = NULL;
	    varPtr->refCount = 0;
	    varPtr->tracePtr = NULL;
	    varPtr->searchPtr = NULL;
	    varPtr->flags = 0;
            TclSetVarLink(varPtr);
            varPtr->value.linkPtr = resolvedVarPtr;
            resolvedVarPtr->refCount++;
        } else {
	    varPtr->value.objPtr = NULL;
	    varPtr->name = localPtr->name; /* will be just '\0' if temp var */
	    varPtr->nsPtr = NULL;
	    varPtr->hPtr = NULL;
	    varPtr->refCount = 0;
	    varPtr->tracePtr = NULL;
	    varPtr->searchPtr = NULL;
	    varPtr->flags = localPtr->flags;
        }
	varPtr++;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandCodeArray --
 *
 *	Procedure that uses malloc to allocate more storage for a
 *	CompileEnv's code array.
 *
 * Results:
 *	None. 
 *
 * Side effects:
 *	The byte code array in *envPtr is reallocated to a new array of
 *	double the size, and if envPtr->mallocedCodeArray is non-zero the
 *	old array is freed. Byte codes are copied from the old array to the
 *	new one.
 *
 *----------------------------------------------------------------------
 */

void
TclExpandCodeArray(envArgPtr)
    void *envArgPtr;		/* Points to the CompileEnv whose code array
				 * must be enlarged. */
{
    CompileEnv *envPtr = (CompileEnv*) envArgPtr;	/* Points to the CompileEnv whose code array

							 * must be enlarged. */

    /*
     * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
     * code bytes are stored between envPtr->codeStart and
     * (envPtr->codeNext - 1) [inclusive].
     */
    
    size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
    size_t newBytes  = 2*(envPtr->codeEnd  - envPtr->codeStart);
    unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);

    /*
     * Copy from old code array to new, free old code array if needed, and
     * mark new code array as malloced.
     */
 
    memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
    if (envPtr->mallocedCodeArray) {
        ckfree((char *) envPtr->codeStart);
    }
    envPtr->codeStart = newPtr;
    envPtr->codeNext = (newPtr + currBytes);
    envPtr->codeEnd  = (newPtr + newBytes);
    envPtr->mallocedCodeArray = 1;
}

/*
 *----------------------------------------------------------------------
 *
 * EnterCmdStartData --
 *
 *	Registers the starting source and bytecode location of a
 *	command. This information is used at runtime to map between
 *	instruction pc and source locations.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Inserts source and code location information into the compilation
 *	environment envPtr for the command at index cmdIndex. The
 *	compilation environment's CmdLocation array is grown if necessary.
 *
 *----------------------------------------------------------------------
 */

static void
EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
    CompileEnv *envPtr;		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    int cmdIndex;		/* Index of the command whose start data
				 * is being set. */
    int srcOffset;		/* Offset of first char of the command. */
    int codeOffset;		/* Offset of first byte of command code. */
{
    CmdLocation *cmdLocPtr;
    
    if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
	Tcl_Panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
    }
    
    if (cmdIndex >= envPtr->cmdMapEnd) {
	/*
	 * Expand the command location array by allocating more storage from
	 * the heap. The currently allocated CmdLocation entries are stored
	 * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
	 */

	size_t currElems = envPtr->cmdMapEnd;
	size_t newElems  = 2*currElems;
	size_t currBytes = currElems * sizeof(CmdLocation);
	size_t newBytes  = newElems  * sizeof(CmdLocation);
	CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
	
	/*
	 * Copy from old command location array to new, free old command
	 * location array if needed, and mark new array as malloced.
	 */
	
	memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
	if (envPtr->mallocedCmdMap) {
	    ckfree((char *) envPtr->cmdMapPtr);
	}
	envPtr->cmdMapPtr = (CmdLocation *) newPtr;
	envPtr->cmdMapEnd = newElems;
	envPtr->mallocedCmdMap = 1;







|





|
|





|

|

|







>
>
>
|
>
















|
|





|



|



|
|



|









|



|









|


|

|
|
<

|



















|
|
|
<


|
|






|
|


|
|















|





|
|










|


|
|
|

















|
<





|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|
|


|


|
|
|
<









|
>
|



|
|

|

|






|


|



|








|
|
|






|
|









|
|




|



|








|

|

|




|







1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778

1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802

1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875

1876
1877
1878
1879
1880
1881
1882

















































































































1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
    iPtr = envPtr->iPtr;

    codeBytes = (envPtr->codeNext - envPtr->codeStart);
    objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
    exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
    auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
    cmdLocBytes = GetCmdLocEncodingSize(envPtr);

    /*
     * Compute the total number of bytes needed for this bytecode.
     */

    structureSize = sizeof(ByteCode);
    structureSize += TCL_ALIGN(codeBytes);	  /* align object array */
    structureSize += TCL_ALIGN(objArrayBytes);	  /* align exc range arr */
    structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
    structureSize += auxDataArrayBytes;
    structureSize += cmdLocBytes;

    if (envPtr->iPtr->varFramePtr != NULL) {
	namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
    } else {
	namespacePtr = envPtr->iPtr->globalNsPtr;
    }

    p = (unsigned char *) ckalloc((size_t) structureSize);
    codePtr = (ByteCode *) p;
    codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
    codePtr->compileEpoch = iPtr->compileEpoch;
    codePtr->nsPtr = namespacePtr;
    codePtr->nsEpoch = namespacePtr->resolverEpoch;
    codePtr->refCount = 1;
    if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
	codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
    } else {
	codePtr->flags = 0;
    }
    codePtr->source = envPtr->source;
    codePtr->procPtr = envPtr->procPtr;

    codePtr->numCommands = envPtr->numCommands;
    codePtr->numSrcBytes = envPtr->numSrcBytes;
    codePtr->numCodeBytes = codeBytes;
    codePtr->numLitObjects = numLitObjects;
    codePtr->numExceptRanges = envPtr->exceptArrayNext;
    codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
    codePtr->numCmdLocBytes = cmdLocBytes;
    codePtr->maxExceptDepth = envPtr->maxExceptDepth;
    codePtr->maxStackDepth = envPtr->maxStackDepth;

    p += sizeof(ByteCode);
    codePtr->codeStart = p;
    memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);

    p += TCL_ALIGN(codeBytes);		/* align object array */
    codePtr->objArrayPtr = (Tcl_Obj **) p;
    for (i = 0;  i < numLitObjects;  i++) {
	codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
    }

    p += TCL_ALIGN(objArrayBytes);	/* align exception range array */
    if (exceptArrayBytes > 0) {
	codePtr->exceptArrayPtr = (ExceptionRange *) p;
	memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
		(size_t) exceptArrayBytes);
    } else {
	codePtr->exceptArrayPtr = NULL;
    }

    p += TCL_ALIGN(exceptArrayBytes);	/* align AuxData array */
    if (auxDataArrayBytes > 0) {
	codePtr->auxDataArrayPtr = (AuxData *) p;
	memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
		(size_t) auxDataArrayBytes);
    } else {
	codePtr->auxDataArrayPtr = NULL;
    }

    p += auxDataArrayBytes;
#ifndef TCL_COMPILE_DEBUG
    EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
#else
    nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
    if (((size_t)(nextPtr - p)) != cmdLocBytes) {
	Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
    }
#endif

    /*
     * Record various compilation-related statistics about the new ByteCode
     * structure. Don't include overhead for statistics-related fields.
     */

#ifdef TCL_COMPILE_STATS
    codePtr->structureSize = structureSize
	    - (sizeof(size_t) + sizeof(Tcl_Time));
    Tcl_GetTime(&(codePtr->createTime));

    RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */

    /*
     * Free the old internal rep then convert the object to a bytecode object
     * by making its internal rep point to the just compiled ByteCode.

     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
    objPtr->typePtr = &tclByteCodeType;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindCompiledLocal --
 *
 *	This procedure is called at compile time to look up and optionally
 *	allocate an entry ("slot") for a variable in a procedure's array of
 *	local variables. If the variable's name is NULL, a new temporary
 *	variable is always created. (Such temporary variables can only be
 *	referenced using their slot index.)
 *
 * Results:
 *	If create is 0 and the name is non-NULL, then if the variable is
 *	found, the index of its entry in the procedure's array of local
 *	variables is returned; otherwise -1 is returned. If name is NULL, the
 *	index of a new temporary variable is returned. Finally, if create is 1
 *	and name is non-NULL, the index of a new entry is returned.

 *
 * Side effects:
 *	Creates and registers a new local variable if create is 1 and the
 *	variable is unknown, or if the name is NULL.
 *
 *----------------------------------------------------------------------
 */

int
TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
    register CONST char *name;	/* Points to first character of the name of a
				 * scalar or array variable. If NULL, a
				 * temporary var should be created. */
    int nameBytes;		/* Number of bytes in the name. */
    int create;			/* If 1, allocate a local frame entry for the
				 * variable if it is new. */
    int flags;			/* Flag bits for the compiled local if
				 * created. Only VAR_SCALAR, VAR_ARRAY, and
				 * VAR_LINK make sense. */
    register Proc *procPtr;	/* Points to structure describing procedure
				 * containing the variable reference. */
{
    register CompiledLocal *localPtr;
    int localVar = -1;
    register int i;

    /*
     * If not creating a temporary, does a local variable of the specified
     * name already exist?
     */

    if (name != NULL) {
	int localCt = procPtr->numCompiledLocals;
	localPtr = procPtr->firstLocalPtr;
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		char *localName = localPtr->name;
		if ((nameBytes == localPtr->nameLength) &&
			(strncmp(name,localName,(unsigned)nameBytes) == 0)) {
		    return i;
		}
	    }
	    localPtr = localPtr->nextPtr;
	}
    }

    /*
     * Create a new variable if appropriate.
     */

    if (create || (name == NULL)) {
	localVar = procPtr->numCompiledLocals;
	localPtr = (CompiledLocal *) ckalloc((unsigned)
		(sizeof(CompiledLocal) - sizeof(localPtr->name)
		+ nameBytes + 1));
	if (procPtr->firstLocalPtr == NULL) {
	    procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	} else {
	    procPtr->lastLocalPtr->nextPtr = localPtr;
	    procPtr->lastLocalPtr = localPtr;
	}
	localPtr->nextPtr = NULL;
	localPtr->nameLength = nameBytes;
	localPtr->frameIndex = localVar;
	localPtr->flags = flags | VAR_UNDEFINED;
	if (name == NULL) {
	    localPtr->flags |= VAR_TEMPORARY;
	}
	localPtr->defValuePtr = NULL;
	localPtr->resolveInfo = NULL;

	if (name != NULL) {
	    memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameBytes);

	}
	localPtr->name[nameBytes] = '\0';
	procPtr->numCompiledLocals++;
    }
    return localVar;

}

















































































































/*
 *----------------------------------------------------------------------
 *
 * TclExpandCodeArray --
 *
 *	Procedure that uses malloc to allocate more storage for a CompileEnv's
 *	code array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The byte code array in *envPtr is reallocated to a new array of double
 *	the size, and if envPtr->mallocedCodeArray is non-zero the old array
 *	is freed. Byte codes are copied from the old array to the new one.

 *
 *----------------------------------------------------------------------
 */

void
TclExpandCodeArray(envArgPtr)
    void *envArgPtr;		/* Points to the CompileEnv whose code array
				 * must be enlarged. */
{
    CompileEnv *envPtr = (CompileEnv*) envArgPtr;
				/* The CompileEnv containing the code array to
				 * be doubled in size. */

    /*
     * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
     * code bytes are stored between envPtr->codeStart and envPtr->codeNext-1
     * [inclusive].
     */

    size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
    size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
    unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);

    /*
     * Copy from old code array to new, free old code array if needed, and
     * mark new code array as malloced.
     */

    memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
    if (envPtr->mallocedCodeArray) {
	ckfree((char *) envPtr->codeStart);
    }
    envPtr->codeStart = newPtr;
    envPtr->codeNext = (newPtr + currBytes);
    envPtr->codeEnd = (newPtr + newBytes);
    envPtr->mallocedCodeArray = 1;
}

/*
 *----------------------------------------------------------------------
 *
 * EnterCmdStartData --
 *
 *	Registers the starting source and bytecode location of a command. This
 *	information is used at runtime to map between instruction pc and
 *	source locations.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Inserts source and code location information into the compilation
 *	environment envPtr for the command at index cmdIndex. The compilation
 *	environment's CmdLocation array is grown if necessary.
 *
 *----------------------------------------------------------------------
 */

static void
EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
    CompileEnv *envPtr;		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    int cmdIndex;		/* Index of the command whose start data is
				 * being set. */
    int srcOffset;		/* Offset of first char of the command. */
    int codeOffset;		/* Offset of first byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
	Tcl_Panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
    }

    if (cmdIndex >= envPtr->cmdMapEnd) {
	/*
	 * Expand the command location array by allocating more storage from
	 * the heap. The currently allocated CmdLocation entries are stored
	 * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
	 */

	size_t currElems = envPtr->cmdMapEnd;
	size_t newElems = 2*currElems;
	size_t currBytes = currElems * sizeof(CmdLocation);
	size_t newBytes = newElems * sizeof(CmdLocation);
	CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);

	/*
	 * Copy from old command location array to new, free old command
	 * location array if needed, and mark new array as malloced.
	 */

	memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
	if (envPtr->mallocedCmdMap) {
	    ckfree((char *) envPtr->cmdMapPtr);
	}
	envPtr->cmdMapPtr = (CmdLocation *) newPtr;
	envPtr->cmdMapEnd = newElems;
	envPtr->mallocedCmdMap = 1;
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232

2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
 *	source locations.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Inserts source and code length information into the compilation
 *	environment envPtr for the command at index cmdIndex. Starting
 *	source and bytecode information for the command must already
 *	have been registered.
 *
 *----------------------------------------------------------------------
 */

static void
EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
    CompileEnv *envPtr;		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    int cmdIndex;		/* Index of the command whose source and
				 * code length data is being set. */
    int numSrcBytes;		/* Number of command source chars. */
    int numCodeBytes;		/* Offset of last byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
	Tcl_Panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
    }
    
    if (cmdIndex > envPtr->cmdMapEnd) {
	Tcl_Panic("EnterCmdExtentData: missing start data for command %d\n",
	        cmdIndex);
    }

    cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
    cmdLocPtr->numSrcBytes = numSrcBytes;
    cmdLocPtr->numCodeBytes = numCodeBytes;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateExceptRange --
 *
 *	Procedure that allocates and initializes a new ExceptionRange
 *	structure of the specified kind in a CompileEnv.
 *
 * Results:
 *	Returns the index for the newly created ExceptionRange.
 *
 * Side effects:
 *	If there is not enough room in the CompileEnv's ExceptionRange
 *	array, the array in expanded: a new array of double the size is
 *	allocated, if envPtr->mallocedExceptArray is non-zero the old
 *	array is freed, and ExceptionRange entries are copied from the old
 *	array to the new one.
 *
 *----------------------------------------------------------------------
 */

int
TclCreateExceptRange(type, envPtr)
    ExceptionRangeType type;	/* The kind of ExceptionRange desired. */
    register CompileEnv *envPtr;/* Points to CompileEnv for which to
				 * create a new ExceptionRange structure. */
{
    register ExceptionRange *rangePtr;
    int index = envPtr->exceptArrayNext;
    
    if (index >= envPtr->exceptArrayEnd) {
        /*
	 * Expand the ExceptionRange array. The currently allocated entries
	 * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
	 * [inclusive].
	 */
	
	size_t currBytes =
	        envPtr->exceptArrayNext * sizeof(ExceptionRange);
	int newElems = 2*envPtr->exceptArrayEnd;
	size_t newBytes = newElems * sizeof(ExceptionRange);
	ExceptionRange *newPtr = (ExceptionRange *)
	        ckalloc((unsigned) newBytes);
	
	/*
	 * Copy from old ExceptionRange array to new, free old
	 * ExceptionRange array if needed, and mark the new ExceptionRange
	 * array as malloced.
	 */
	
	memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
	        currBytes);
	if (envPtr->mallocedExceptArray) {
	    ckfree((char *) envPtr->exceptArrayPtr);
	}
	envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
	envPtr->exceptArrayEnd = newElems;
	envPtr->mallocedExceptArray = 1;
    }
    envPtr->exceptArrayNext++;
    
    rangePtr = &(envPtr->exceptArrayPtr[index]);
    rangePtr->type = type;
    rangePtr->nestingLevel = envPtr->exceptDepth;
    rangePtr->codeOffset = -1;
    rangePtr->numCodeBytes = -1;
    rangePtr->breakOffset = -1;
    rangePtr->continueOffset = -1;
    rangePtr->catchOffset = -1;
    return index;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateAuxData --
 *
 *	Procedure that allocates and initializes a new AuxData structure in
 *	a CompileEnv's array of compilation auxiliary data records. These
 *	AuxData records hold information created during compilation by
 *	CompileProcs and used by instructions during execution.
 *
 * Results:
 *	Returns the index for the newly created AuxData structure.
 *
 * Side effects:
 *	If there is not enough room in the CompileEnv's AuxData array,
 *	the AuxData array in expanded: a new array of double the size
 *	is allocated, if envPtr->mallocedAuxDataArray is non-zero
 *	the old array is freed, and AuxData entries are copied from
 *	the old array to the new one.
 *
 *----------------------------------------------------------------------
 */

int
TclCreateAuxData(clientData, typePtr, envPtr)
    ClientData clientData;	/* The compilation auxiliary data to store
				 * in the new aux data record. */
    AuxDataType *typePtr;	/* Pointer to the type to attach to this AuxData */

    register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
				 * aux data structure is to be allocated. */
{
    int index;			/* Index for the new AuxData structure. */
    register AuxData *auxDataPtr;
    				/* Points to the new AuxData structure */
    
    index = envPtr->auxDataArrayNext;
    if (index >= envPtr->auxDataArrayEnd) {
        /*
	 * Expand the AuxData array. The currently allocated entries are
	 * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
	 * [inclusive].
	 */
	
	size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
	int newElems = 2*envPtr->auxDataArrayEnd;
	size_t newBytes = newElems * sizeof(AuxData);
	AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
	
	/*
	 * Copy from old AuxData array to new, free old AuxData array if
	 * needed, and mark the new AuxData array as malloced.
	 */
	
	memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
	        currBytes);
	if (envPtr->mallocedAuxDataArray) {
	    ckfree((char *) envPtr->auxDataArrayPtr);
	}
	envPtr->auxDataArrayPtr = newPtr;
	envPtr->auxDataArrayEnd = newElems;
	envPtr->mallocedAuxDataArray = 1;
    }
    envPtr->auxDataArrayNext++;
    
    auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
    auxDataPtr->clientData = clientData;
    auxDataPtr->type = typePtr;
    return index;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitJumpFixupArray --
 *
 *	Initializes a JumpFixupArray structure to hold some number of
 *	jump fixup entries.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The JumpFixupArray structure is initialized.
 *
 *----------------------------------------------------------------------
 */

void
TclInitJumpFixupArray(fixupArrayPtr)
    register JumpFixupArray *fixupArrayPtr;
				 /* Points to the JumpFixupArray structure
				  * to initialize. */
{
    fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
    fixupArrayPtr->next = 0;
    fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
    fixupArrayPtr->mallocedArray = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandJumpFixupArray --
 *
 *	Procedure that uses malloc to allocate more storage for a
 *      jump fixup array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The jump fixup array in *fixupArrayPtr is reallocated to a new array
 *	of double the size, and if fixupArrayPtr->mallocedArray is non-zero
 *	the old array is freed. Jump fixup structures are copied from the
 *	old array to the new one.
 *
 *----------------------------------------------------------------------
 */

void
TclExpandJumpFixupArray(fixupArrayPtr)
    register JumpFixupArray *fixupArrayPtr;
				 /* Points to the JumpFixupArray structure
				  * to enlarge. */
{
    /*
     * The currently allocated jump fixup entries are stored from fixup[0]
     * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
     * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
     */

    size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
    int newElems = 2*(fixupArrayPtr->end + 1);
    size_t newBytes = newElems * sizeof(JumpFixup);
    JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);

    /*
     * Copy from the old array to new, free the old array if needed,
     * and mark the new array as malloced.
     */
 
    memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
    if (fixupArrayPtr->mallocedArray) {
	ckfree((char *) fixupArrayPtr->fixup);
    }
    fixupArrayPtr->fixup = (JumpFixup *) newPtr;
    fixupArrayPtr->end = newElems;
    fixupArrayPtr->mallocedArray = 1;







|
|
|









|
|








|


|



















|
|
|
|
<







|
|



|

|




|

|



|
|

|
|
<

|
|
<








|
















|
|







|
|
|
|
|






|
|
|
>






|


|




|




|




|
|
<








|











|
|













|
|












|
|







|
|







|
|


|
|









|
|

|







2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074

2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104

2105
2106
2107

2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182

2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
 *	source locations.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Inserts source and code length information into the compilation
 *	environment envPtr for the command at index cmdIndex. Starting source
 *	and bytecode information for the command must already have been
 *	registered.
 *
 *----------------------------------------------------------------------
 */

static void
EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
    CompileEnv *envPtr;		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    int cmdIndex;		/* Index of the command whose source and code
				 * length data is being set. */
    int numSrcBytes;		/* Number of command source chars. */
    int numCodeBytes;		/* Offset of last byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
	Tcl_Panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
    }

    if (cmdIndex > envPtr->cmdMapEnd) {
	Tcl_Panic("EnterCmdExtentData: missing start data for command %d\n",
		cmdIndex);
    }

    cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
    cmdLocPtr->numSrcBytes = numSrcBytes;
    cmdLocPtr->numCodeBytes = numCodeBytes;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateExceptRange --
 *
 *	Procedure that allocates and initializes a new ExceptionRange
 *	structure of the specified kind in a CompileEnv.
 *
 * Results:
 *	Returns the index for the newly created ExceptionRange.
 *
 * Side effects:
 *	If there is not enough room in the CompileEnv's ExceptionRange array,
 *	the array in expanded: a new array of double the size is allocated, if
 *	envPtr->mallocedExceptArray is non-zero the old array is freed, and
 *	ExceptionRange entries are copied from the old array to the new one.

 *
 *----------------------------------------------------------------------
 */

int
TclCreateExceptRange(type, envPtr)
    ExceptionRangeType type;	/* The kind of ExceptionRange desired. */
    register CompileEnv *envPtr;/* Points to CompileEnv for which to create a
				 * new ExceptionRange structure. */
{
    register ExceptionRange *rangePtr;
    int index = envPtr->exceptArrayNext;

    if (index >= envPtr->exceptArrayEnd) {
	/*
	 * Expand the ExceptionRange array. The currently allocated entries
	 * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
	 * [inclusive].
	 */

	size_t currBytes =
		envPtr->exceptArrayNext * sizeof(ExceptionRange);
	int newElems = 2*envPtr->exceptArrayEnd;
	size_t newBytes = newElems * sizeof(ExceptionRange);
	ExceptionRange *newPtr = (ExceptionRange *)
		ckalloc((unsigned) newBytes);

	/*
	 * Copy from old ExceptionRange array to new, free old ExceptionRange
	 * array if needed, and mark the new ExceptionRange array as malloced.

	 */

	memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, currBytes);

	if (envPtr->mallocedExceptArray) {
	    ckfree((char *) envPtr->exceptArrayPtr);
	}
	envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
	envPtr->exceptArrayEnd = newElems;
	envPtr->mallocedExceptArray = 1;
    }
    envPtr->exceptArrayNext++;

    rangePtr = &(envPtr->exceptArrayPtr[index]);
    rangePtr->type = type;
    rangePtr->nestingLevel = envPtr->exceptDepth;
    rangePtr->codeOffset = -1;
    rangePtr->numCodeBytes = -1;
    rangePtr->breakOffset = -1;
    rangePtr->continueOffset = -1;
    rangePtr->catchOffset = -1;
    return index;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateAuxData --
 *
 *	Procedure that allocates and initializes a new AuxData structure in a
 *	CompileEnv's array of compilation auxiliary data records. These
 *	AuxData records hold information created during compilation by
 *	CompileProcs and used by instructions during execution.
 *
 * Results:
 *	Returns the index for the newly created AuxData structure.
 *
 * Side effects:
 *	If there is not enough room in the CompileEnv's AuxData array, the
 *	AuxData array in expanded: a new array of double the size is
 *	allocated, if envPtr->mallocedAuxDataArray is non-zero the old array
 *	is freed, and AuxData entries are copied from the old array to the new
 *	one.
 *
 *----------------------------------------------------------------------
 */

int
TclCreateAuxData(clientData, typePtr, envPtr)
    ClientData clientData;	/* The compilation auxiliary data to store in
				 * the new aux data record. */
    AuxDataType *typePtr;	/* Pointer to the type to attach to this
				 * AuxData */
    register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
				 * aux data structure is to be allocated. */
{
    int index;			/* Index for the new AuxData structure. */
    register AuxData *auxDataPtr;
    				/* Points to the new AuxData structure */

    index = envPtr->auxDataArrayNext;
    if (index >= envPtr->auxDataArrayEnd) {
	/*
	 * Expand the AuxData array. The currently allocated entries are
	 * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
	 * [inclusive].
	 */

	size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
	int newElems = 2*envPtr->auxDataArrayEnd;
	size_t newBytes = newElems * sizeof(AuxData);
	AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);

	/*
	 * Copy from old AuxData array to new, free old AuxData array if
	 * needed, and mark the new AuxData array as malloced.
	 */

	memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, currBytes);

	if (envPtr->mallocedAuxDataArray) {
	    ckfree((char *) envPtr->auxDataArrayPtr);
	}
	envPtr->auxDataArrayPtr = newPtr;
	envPtr->auxDataArrayEnd = newElems;
	envPtr->mallocedAuxDataArray = 1;
    }
    envPtr->auxDataArrayNext++;

    auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
    auxDataPtr->clientData = clientData;
    auxDataPtr->type = typePtr;
    return index;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitJumpFixupArray --
 *
 *	Initializes a JumpFixupArray structure to hold some number of jump
 *	fixup entries.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The JumpFixupArray structure is initialized.
 *
 *----------------------------------------------------------------------
 */

void
TclInitJumpFixupArray(fixupArrayPtr)
    register JumpFixupArray *fixupArrayPtr;
				/* Points to the JumpFixupArray structure to
				 * initialize. */
{
    fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
    fixupArrayPtr->next = 0;
    fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
    fixupArrayPtr->mallocedArray = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandJumpFixupArray --
 *
 *	Procedure that uses malloc to allocate more storage for a jump fixup
 *	array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The jump fixup array in *fixupArrayPtr is reallocated to a new array
 *	of double the size, and if fixupArrayPtr->mallocedArray is non-zero
 *	the old array is freed. Jump fixup structures are copied from the old
 *	array to the new one.
 *
 *----------------------------------------------------------------------
 */

void
TclExpandJumpFixupArray(fixupArrayPtr)
    register JumpFixupArray *fixupArrayPtr;
				/* Points to the JumpFixupArray structure
				 * to enlarge. */
{
    /*
     * The currently allocated jump fixup entries are stored from fixup[0] up
     * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
     * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
     */

    size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
    int newElems = 2*(fixupArrayPtr->end + 1);
    size_t newBytes = newElems * sizeof(JumpFixup);
    JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);

    /*
     * Copy from the old array to new, free the old array if needed, and mark
     * the new array as malloced.
     */

    memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
    if (fixupArrayPtr->mallocedArray) {
	ckfree((char *) fixupArrayPtr->fixup);
    }
    fixupArrayPtr->fixup = (JumpFixup *) newPtr;
    fixupArrayPtr->end = newElems;
    fixupArrayPtr->mallocedArray = 1;
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
 *
 *----------------------------------------------------------------------
 */

void
TclFreeJumpFixupArray(fixupArrayPtr)
    register JumpFixupArray *fixupArrayPtr;
				 /* Points to the JumpFixupArray structure
				  * to free. */
{
    if (fixupArrayPtr->mallocedArray) {
	ckfree((char *) fixupArrayPtr->fixup);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclEmitForwardJump --
 *
 *	Procedure to emit a two-byte forward jump of kind "jumpType". Since
 *	the jump may later have to be grown to five bytes if the jump target
 *	is more than, say, 127 bytes away, this procedure also initializes a
 *	JumpFixup record with information about the jump. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The JumpFixup record pointed to by "jumpFixupPtr" is initialized
 *	with information needed later if the jump is to be grown. Also,
 *	a two byte jump of the designated type is emitted at the current
 *	point in the bytecode stream.
 *
 *----------------------------------------------------------------------
 */

void
TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
    CompileEnv *envPtr;		/* Points to the CompileEnv structure that
				 * holds the resulting instruction. */
    TclJumpType jumpType;	/* Indicates the kind of jump: if true or
				 * false or unconditional. */
    JumpFixup *jumpFixupPtr;	/* Points to the JumpFixup structure to
				 * initialize with information about this
				 * forward jump. */
{
    /*
     * Initialize the JumpFixup structure:
     *    - codeOffset is offset of first byte of jump below
     *    - cmdIndex is index of the command after the current one
     *    - exceptIndex is the index of the first ExceptionRange after
     *      the current one.
     */
    
    jumpFixupPtr->jumpType = jumpType;
    jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
    jumpFixupPtr->cmdIndex = envPtr->numCommands;
    jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
    
    switch (jumpType) {
    case TCL_UNCONDITIONAL_JUMP:
	TclEmitInstInt1(INST_JUMP1, 0, envPtr);
	break;
    case TCL_TRUE_JUMP:
	TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
	break;
    default:
	TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
	break;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFixupForwardJump --
 *
 *	Procedure that updates a previously-emitted forward jump to jump
 *	a specified number of bytes, "jumpDist". If necessary, the jump is
 *      grown from two to five bytes; this is done if the jump distance is
 *	greater than "distThreshold" (normally 127 bytes). The jump is
 *	described by a JumpFixup record previously initialized by
 *	TclEmitForwardJump.
 *
 * Results:
 *	1 if the jump was grown and subsequent instructions had to be moved;
 *	otherwise 0. This result is returned to allow callers to update
 *	any additional code offsets they may hold.
 *
 * Side effects:
 *	The jump may be grown and subsequent instructions moved. If this
 *	happens, the code offsets for any commands and any ExceptionRange
 *	records	between the jump and the current code address will be
 *	updated to reflect the moved code. Also, the bytecode instruction
 *	array in the CompileEnv structure may be grown and reallocated.
 *
 *----------------------------------------------------------------------
 */

int
TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
    CompileEnv *envPtr;		/* Points to the CompileEnv structure that
				 * holds the resulting instruction. */
    JumpFixup *jumpFixupPtr;    /* Points to the JumpFixup structure that
				 * describes the forward jump. */
    int jumpDist;		/* Jump distance to set in jump
				 * instruction. */
    int distThreshold;		/* Maximum distance before the two byte
				 * jump is grown to five bytes. */
{
    unsigned char *jumpPc, *p;
    int firstCmd, lastCmd, firstRange, lastRange, k;
    unsigned int numBytes;
    
    if (jumpDist <= distThreshold) {
	jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
	switch (jumpFixupPtr->jumpType) {
	case TCL_UNCONDITIONAL_JUMP:
	    TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
	    break;
	case TCL_TRUE_JUMP:
	    TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
	    break;
	default:
	    TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
	    break;
	}
	return 0;
    }

    /*
     * We must grow the jump then move subsequent instructions down.
     * Note that if we expand the space for generated instructions,
     * code addresses might change; be careful about updating any of
     * these addresses held in variables.
     */
    
    if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
        TclExpandCodeArray(envPtr);
    }
    jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
    for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
	    numBytes > 0;  numBytes--, p--) {
	p[3] = p[0];
    }
    envPtr->codeNext += 3;
    jumpDist += 3;
    switch (jumpFixupPtr->jumpType) {
    case TCL_UNCONDITIONAL_JUMP:
	TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
	break;
    case TCL_TRUE_JUMP:
	TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
	break;
    default:
	TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
	break;
    }
    
    /*
     * Adjust the code offsets for any commands and any ExceptionRange
     * records between the jump and the current code address.
     */
    
    firstCmd = jumpFixupPtr->cmdIndex;
    lastCmd  = (envPtr->numCommands - 1);
    if (firstCmd < lastCmd) {
	for (k = firstCmd;  k <= lastCmd;  k++) {
	    (envPtr->cmdMapPtr[k]).codeOffset += 3;
	}
    }
    
    firstRange = jumpFixupPtr->exceptIndex;
    lastRange  = (envPtr->exceptArrayNext - 1);
    for (k = firstRange;  k <= lastRange;  k++) {
	ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
	rangePtr->codeOffset += 3;
	
	switch (rangePtr->type) {
	case LOOP_EXCEPTION_RANGE:
	    rangePtr->breakOffset += 3;
	    if (rangePtr->continueOffset != -1) {
		rangePtr->continueOffset += 3;
	    }
	    break;
	case CATCH_EXCEPTION_RANGE:
	    rangePtr->catchOffset += 3;
	    break;
	default:
	    Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
	            rangePtr->type);
	}
    }
    return 1;			/* the jump was grown */
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetInstructionTable --
 *
 *  Returns a pointer to the table describing Tcl bytecode instructions.
 *  This procedure is defined so that clients can access the pointer from
 *  outside the TCL DLLs.
 *
 * Results:
 *	Returns a pointer to the global instruction table, same as the
 *	expression (&tclInstructionTable[0]).
 *
 * Side effects:
 *	None.







|
|














|





|
|
|
|


















|
|

|




|


















|
|
|
|
|
<



|
|




|
|
|










|
<
|
|




|

















|
|
|
|

|

|



















|

|
|

|

|





|

|



|












|










|
|
|







2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372

2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395

2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
 *
 *----------------------------------------------------------------------
 */

void
TclFreeJumpFixupArray(fixupArrayPtr)
    register JumpFixupArray *fixupArrayPtr;
				/* Points to the JumpFixupArray structure to
				 * free. */
{
    if (fixupArrayPtr->mallocedArray) {
	ckfree((char *) fixupArrayPtr->fixup);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclEmitForwardJump --
 *
 *	Procedure to emit a two-byte forward jump of kind "jumpType". Since
 *	the jump may later have to be grown to five bytes if the jump target
 *	is more than, say, 127 bytes away, this procedure also initializes a
 *	JumpFixup record with information about the jump.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The JumpFixup record pointed to by "jumpFixupPtr" is initialized with
 *	information needed later if the jump is to be grown. Also, a two byte
 *	jump of the designated type is emitted at the current point in the
 *	bytecode stream.
 *
 *----------------------------------------------------------------------
 */

void
TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
    CompileEnv *envPtr;		/* Points to the CompileEnv structure that
				 * holds the resulting instruction. */
    TclJumpType jumpType;	/* Indicates the kind of jump: if true or
				 * false or unconditional. */
    JumpFixup *jumpFixupPtr;	/* Points to the JumpFixup structure to
				 * initialize with information about this
				 * forward jump. */
{
    /*
     * Initialize the JumpFixup structure:
     *    - codeOffset is offset of first byte of jump below
     *    - cmdIndex is index of the command after the current one
     *    - exceptIndex is the index of the first ExceptionRange after the
     *	    current one.
     */

    jumpFixupPtr->jumpType = jumpType;
    jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
    jumpFixupPtr->cmdIndex = envPtr->numCommands;
    jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;

    switch (jumpType) {
    case TCL_UNCONDITIONAL_JUMP:
	TclEmitInstInt1(INST_JUMP1, 0, envPtr);
	break;
    case TCL_TRUE_JUMP:
	TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
	break;
    default:
	TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
	break;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFixupForwardJump --
 *
 *	Procedure that updates a previously-emitted forward jump to jump a
 *	specified number of bytes, "jumpDist". If necessary, the jump is grown
 *	from two to five bytes; this is done if the jump distance is greater
 *	than "distThreshold" (normally 127 bytes). The jump is described by a
 *	JumpFixup record previously initialized by TclEmitForwardJump.

 *
 * Results:
 *	1 if the jump was grown and subsequent instructions had to be moved;
 *	otherwise 0. This result is returned to allow callers to update any
 *	additional code offsets they may hold.
 *
 * Side effects:
 *	The jump may be grown and subsequent instructions moved. If this
 *	happens, the code offsets for any commands and any ExceptionRange
 *	records between the jump and the current code address will be updated
 *	to reflect the moved code. Also, the bytecode instruction array in the
 *	CompileEnv structure may be grown and reallocated.
 *
 *----------------------------------------------------------------------
 */

int
TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
    CompileEnv *envPtr;		/* Points to the CompileEnv structure that
				 * holds the resulting instruction. */
    JumpFixup *jumpFixupPtr;    /* Points to the JumpFixup structure that
				 * describes the forward jump. */
    int jumpDist;		/* Jump distance to set in jump instr. */

    int distThreshold;		/* Maximum distance before the two byte jump
				 * is grown to five bytes. */
{
    unsigned char *jumpPc, *p;
    int firstCmd, lastCmd, firstRange, lastRange, k;
    unsigned int numBytes;

    if (jumpDist <= distThreshold) {
	jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
	switch (jumpFixupPtr->jumpType) {
	case TCL_UNCONDITIONAL_JUMP:
	    TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
	    break;
	case TCL_TRUE_JUMP:
	    TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
	    break;
	default:
	    TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
	    break;
	}
	return 0;
    }

    /*
     * We must grow the jump then move subsequent instructions down.  Note
     * that if we expand the space for generated instructions, code addresses
     * might change; be careful about updating any of these addresses held in
     * variables.
     */

    if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
	TclExpandCodeArray(envPtr);
    }
    jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
    for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
	    numBytes > 0;  numBytes--, p--) {
	p[3] = p[0];
    }
    envPtr->codeNext += 3;
    jumpDist += 3;
    switch (jumpFixupPtr->jumpType) {
    case TCL_UNCONDITIONAL_JUMP:
	TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
	break;
    case TCL_TRUE_JUMP:
	TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
	break;
    default:
	TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
	break;
    }

    /*
     * Adjust the code offsets for any commands and any ExceptionRange records
     * between the jump and the current code address.
     */

    firstCmd = jumpFixupPtr->cmdIndex;
    lastCmd = (envPtr->numCommands - 1);
    if (firstCmd < lastCmd) {
	for (k = firstCmd;  k <= lastCmd;  k++) {
	    (envPtr->cmdMapPtr[k]).codeOffset += 3;
	}
    }

    firstRange = jumpFixupPtr->exceptIndex;
    lastRange = (envPtr->exceptArrayNext - 1);
    for (k = firstRange;  k <= lastRange;  k++) {
	ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
	rangePtr->codeOffset += 3;

	switch (rangePtr->type) {
	case LOOP_EXCEPTION_RANGE:
	    rangePtr->breakOffset += 3;
	    if (rangePtr->continueOffset != -1) {
		rangePtr->continueOffset += 3;
	    }
	    break;
	case CATCH_EXCEPTION_RANGE:
	    rangePtr->catchOffset += 3;
	    break;
	default:
	    Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
		    rangePtr->type);
	}
    }
    return 1;			/* the jump was grown */
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetInstructionTable --
 *
 *	Returns a pointer to the table describing Tcl bytecode instructions.
 *	This procedure is defined so that clients can access the pointer from
 *	outside the TCL DLLs.
 *
 * Results:
 *	Returns a pointer to the global instruction table, same as the
 *	expression (&tclInstructionTable[0]).
 *
 * Side effects:
 *	None.
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
}

/*
 *--------------------------------------------------------------
 *
 * TclRegisterAuxDataType --
 *
 *	This procedure is called to register a new AuxData type
 *	in the table of all AuxData types supported by Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The type is registered in the AuxData type table. If there was already
 *	a type with the same name as in typePtr, it is replaced with the
 *	new type.
 *
 *--------------------------------------------------------------
 */

void
TclRegisterAuxDataType(typePtr)
    AuxDataType *typePtr;	/* Information about object type;
                             * storage must be statically
                             * allocated (must live forever). */
{
    register Tcl_HashEntry *hPtr;
    int new;

    Tcl_MutexLock(&tableMutex);
    if (!auxDataTypeTableInitialized) {
        TclInitAuxDataTypeTable();
    }

    /*
     * If there's already a type with the given name, remove it.
     */

    hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
    if (hPtr != (Tcl_HashEntry *) NULL) {
        Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Now insert the new object type.
     */

    hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
    if (new) {
        Tcl_SetHashValue(hPtr, typePtr);
    }
    Tcl_MutexUnlock(&tableMutex);
}

/*
 *----------------------------------------------------------------------
 *







|
|






|
|






|
|
|






|








|








|







2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
}

/*
 *--------------------------------------------------------------
 *
 * TclRegisterAuxDataType --
 *
 *	This procedure is called to register a new AuxData type in the table
 *	of all AuxData types supported by Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The type is registered in the AuxData type table. If there was already
 *	a type with the same name as in typePtr, it is replaced with the new
 *	type.
 *
 *--------------------------------------------------------------
 */

void
TclRegisterAuxDataType(typePtr)
    AuxDataType *typePtr;	/* Information about object type; storage must
				 * be statically allocated (must live
				 * forever; will not be deallocated). */
{
    register Tcl_HashEntry *hPtr;
    int new;

    Tcl_MutexLock(&tableMutex);
    if (!auxDataTypeTableInitialized) {
	TclInitAuxDataTypeTable();
    }

    /*
     * If there's already a type with the given name, remove it.
     */

    hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
    if (hPtr != (Tcl_HashEntry *) NULL) {
	Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Now insert the new object type.
     */

    hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
    if (new) {
	Tcl_SetHashValue(hPtr, typePtr);
    }
    Tcl_MutexUnlock(&tableMutex);
}

/*
 *----------------------------------------------------------------------
 *
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
    char *typeName;		/* Name of AuxData type to look up. */
{
    register Tcl_HashEntry *hPtr;
    AuxDataType *typePtr = NULL;

    Tcl_MutexLock(&tableMutex);
    if (!auxDataTypeTableInitialized) {
        TclInitAuxDataTypeTable();
    }

    hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
    if (hPtr != (Tcl_HashEntry *) NULL) {
        typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
    }
    Tcl_MutexUnlock(&tableMutex);

    return typePtr;
}

/*
 *--------------------------------------------------------------
 *
 * TclInitAuxDataTypeTable --
 *
 *	This procedure is invoked to perform once-only initialization of
 *	the AuxData type table. It also registers the AuxData types defined in 
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes the table of defined AuxData types "auxDataTypeTable" with







|




|











|
|







2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
    char *typeName;		/* Name of AuxData type to look up. */
{
    register Tcl_HashEntry *hPtr;
    AuxDataType *typePtr = NULL;

    Tcl_MutexLock(&tableMutex);
    if (!auxDataTypeTableInitialized) {
	TclInitAuxDataTypeTable();
    }

    hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
    if (hPtr != (Tcl_HashEntry *) NULL) {
	typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
    }
    Tcl_MutexUnlock(&tableMutex);

    return typePtr;
}

/*
 *--------------------------------------------------------------
 *
 * TclInitAuxDataTypeTable --
 *
 *	This procedure is invoked to perform once-only initialization of the
 *	AuxData type table. It also registers the AuxData types defined in
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes the table of defined AuxData types "auxDataTypeTable" with
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAuxDataTypeTable --
 *
 *	This procedure is called by Tcl_Finalize after all exit handlers
 *	have been run to free up storage associated with the table of AuxData
 *	types.  This procedure is called by TclFinalizeExecution() which
 *	is called by Tcl_Finalize().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes all entries in the hash table of AuxData types.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeAuxDataTypeTable()
{
    Tcl_MutexLock(&tableMutex);
    if (auxDataTypeTableInitialized) {
        Tcl_DeleteHashTable(&auxDataTypeTable);
        auxDataTypeTableInitialized = 0;
    }
    Tcl_MutexUnlock(&tableMutex);
}

/*
 *----------------------------------------------------------------------
 *







|
|
|
|















|
|







2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAuxDataTypeTable --
 *
 *	This procedure is called by Tcl_Finalize after all exit handlers have
 *	been run to free up storage associated with the table of AuxData
 *	types.  This procedure is called by TclFinalizeExecution() which is
 *	called by Tcl_Finalize().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes all entries in the hash table of AuxData types.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeAuxDataTypeTable()
{
    Tcl_MutexLock(&tableMutex);
    if (auxDataTypeTableInitialized) {
	Tcl_DeleteHashTable(&auxDataTypeTable);
	auxDataTypeTableInitialized = 0;
    }
    Tcl_MutexUnlock(&tableMutex);
}

/*
 *----------------------------------------------------------------------
 *
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetCmdLocEncodingSize(envPtr)
     CompileEnv *envPtr;	/* Points to compilation environment
				 * structure containing the CmdLocation
				 * structure to encode. */
{
    register CmdLocation *mapPtr = envPtr->cmdMapPtr;
    int numCmds = envPtr->numCommands;
    int codeDelta, codeLen, srcDelta, srcLen;
    int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
				/* The offsets in their respective byte
				 * sequences where the next encoded offset
				 * or length should go. */
    int prevCodeOffset, prevSrcOffset, i;

    codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
    prevCodeOffset = prevSrcOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
	if (codeDelta < 0) {







|
|
|






|
|







2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetCmdLocEncodingSize(envPtr)
    CompileEnv *envPtr;		/* Points to compilation environment structure
				 * containing the CmdLocation structure to
				 * encode. */
{
    register CmdLocation *mapPtr = envPtr->cmdMapPtr;
    int numCmds = envPtr->numCommands;
    int codeDelta, codeLen, srcDelta, srcLen;
    int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
				/* The offsets in their respective byte
				 * sequences where the next encoded offset or
				 * length should go. */
    int prevCodeOffset, prevSrcOffset, i;

    codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
    prevCodeOffset = prevSrcOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
	if (codeDelta < 0) {
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
}

/*
 *----------------------------------------------------------------------
 *
 * EncodeCmdLocMap --
 *
 *	Encode the command location information for some compiled code into
 *	a ByteCode structure. The encoded command location map is stored as
 *	three adjacent byte sequences.
 *
 * Results:
 *	Pointer to the first byte after the encoded command location
 *	information.
 *
 * Side effects:
 *	The encoded information is stored into the block of memory headed
 *	by codePtr. Also records pointers to the start of the four byte
 *	sequences in fields in codePtr's ByteCode header structure.
 *
 *----------------------------------------------------------------------
 */

static unsigned char *
EncodeCmdLocMap(envPtr, codePtr, startPtr)
     CompileEnv *envPtr;	/* Points to compilation environment
				 * structure containing the CmdLocation
				 * structure to encode. */
     ByteCode *codePtr;		/* ByteCode in which to encode envPtr's
				 * command location information. */
     unsigned char *startPtr;	/* Points to the first byte in codePtr's
				 * memory block where the location
				 * information is to be stored. */
{
    register CmdLocation *mapPtr = envPtr->cmdMapPtr;
    int numCmds = envPtr->numCommands;
    register unsigned char *p = startPtr;
    int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
    register int i;
    
    /*
     * Encode the code offset for each command as a sequence of deltas.
     */

    codePtr->codeDeltaStart = p;
    prevOffset = 0;
    for (i = 0;  i < numCmds;  i++) {







|
|







|
|
|






|
|
|
|

|
|
|






|







2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
}

/*
 *----------------------------------------------------------------------
 *
 * EncodeCmdLocMap --
 *
 *	Encode the command location information for some compiled code into a
 *	ByteCode structure. The encoded command location map is stored as
 *	three adjacent byte sequences.
 *
 * Results:
 *	Pointer to the first byte after the encoded command location
 *	information.
 *
 * Side effects:
 *	The encoded information is stored into the block of memory headed by
 *	codePtr. Also records pointers to the start of the four byte sequences
 *	in fields in codePtr's ByteCode header structure.
 *
 *----------------------------------------------------------------------
 */

static unsigned char *
EncodeCmdLocMap(envPtr, codePtr, startPtr)
    CompileEnv *envPtr;		/* Points to compilation environment structure
				 * containing the CmdLocation structure to
				 * encode. */
    ByteCode *codePtr;		/* ByteCode in which to encode envPtr's
				 * command location information. */
    unsigned char *startPtr;	/* Points to the first byte in codePtr's
				 * memory block where the location information
				 * is to be stored. */
{
    register CmdLocation *mapPtr = envPtr->cmdMapPtr;
    int numCmds = envPtr->numCommands;
    register unsigned char *p = startPtr;
    int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
    register int i;

    /*
     * Encode the code offset for each command as a sequence of deltas.
     */

    codePtr->codeDeltaStart = p;
    prevOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;
	    TclStoreInt4AtPtr(srcLen, p);
	    p += 4;
	}
    }
    
    return p;
}

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclPrintByteCodeObj --
 *
 *	This procedure prints ("disassembles") the instructions of a
 *	bytecode object to stdout.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|









|
|







2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;
	    TclStoreInt4AtPtr(srcLen, p);
	    p += 4;
	}
    }

    return p;
}

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclPrintByteCodeObj --
 *
 *	This procedure prints ("disassembles") the instructions of a bytecode
 *	object to stdout.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
    TclPrintSource(stdout, codePtr->source,
	    TclMin(codePtr->numSrcBytes, 55));
    fprintf(stdout, "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
	    numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
	    codePtr->numLitObjects, codePtr->numAuxDataItems,
	    codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
	    (codePtr->numSrcBytes?
	            ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
#else
	    0.0);
#endif
#ifdef TCL_COMPILE_STATS
    fprintf(stdout,
	    "  Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
	    codePtr->structureSize,
	    (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
	    codePtr->numCodeBytes,
	    (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (codePtr->numExceptRanges * sizeof(ExceptionRange)),
	    (codePtr->numAuxDataItems * sizeof(AuxData)),
	    codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
    
    /*
     * If the ByteCode is the compiled body of a Tcl procedure, print
     * information about that procedure. Note that we don't know the
     * procedure's name since ByteCode's can be shared among procedures.
     */
    
    if (codePtr->procPtr != NULL) {
	Proc *procPtr = codePtr->procPtr;
	int numCompiledLocals = procPtr->numCompiledLocals;
	fprintf(stdout,
	        "  Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
		(unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
		numCompiledLocals);
	if (numCompiledLocals > 0) {
	    CompiledLocal *localPtr = procPtr->firstLocalPtr;
	    for (i = 0;  i < numCompiledLocals;  i++) {
		fprintf(stdout, "      slot %d%s%s%s%s%s%s", i, 
			((localPtr->flags & VAR_SCALAR)?  ", scalar"  : ""),
			((localPtr->flags & VAR_ARRAY)?  ", array"  : ""),
			((localPtr->flags & VAR_LINK)?  ", link"  : ""),
			((localPtr->flags & VAR_ARGUMENT)?  ", arg"  : ""),
			((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
			((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
		if (TclIsVarTemporary(localPtr)) {
		    fprintf(stdout,	"\n");
		} else {
		    fprintf(stdout,	", \"%s\"\n", localPtr->name);
		}
		localPtr = localPtr->nextPtr;
	    }
	}
    }

    /*
     * Print the ExceptionRange array.
     */

    if (codePtr->numExceptRanges > 0) {
	fprintf(stdout, "  Exception ranges %d, depth %d:\n",
	        codePtr->numExceptRanges, codePtr->maxExceptDepth);
	for (i = 0;  i < codePtr->numExceptRanges;  i++) {
	    ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
	    fprintf(stdout, "      %d: level %d, %s, pc %d-%d, ",
		    i, rangePtr->nestingLevel,
		    ((rangePtr->type == LOOP_EXCEPTION_RANGE)
			    ? "loop" : "catch"),
		    rangePtr->codeOffset,
		    (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
	    switch (rangePtr->type) {
	    case LOOP_EXCEPTION_RANGE:
		fprintf(stdout,	"continue %d, break %d\n",
		        rangePtr->continueOffset, rangePtr->breakOffset);
		break;
	    case CATCH_EXCEPTION_RANGE:
		fprintf(stdout,	"catch %d\n", rangePtr->catchOffset);
		break;
	    default:
		Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
		        rangePtr->type);
	    }
	}
    }
    
    /*
     * If there were no commands (e.g., an expression or an empty string
     * was compiled), just print all instructions and return.
     */

    if (numCmds == 0) {
	pc = codeStart;
	while (pc < codeLimit) {
	    fprintf(stdout, "    ");
	    pc += TclPrintInstruction(codePtr, pc);
	}
	return;
    }
    
    /*
     * Print table showing the code offset, source offset, and source
     * length for each command. These are encoded as a sequence of bytes.
     */

    fprintf(stdout, "  Commands %d:", numCmds);
    codeDeltaNext = codePtr->codeDeltaStart;
    codeLengthNext = codePtr->codeLengthStart;
    srcDeltaNext  = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
	    codeDeltaNext += 4;







|
|
|

|











|





|




|





|
|
|
|
|
|
|

|

|












|




<
|





|






|



|

|
|










|

|
|





|







2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979

2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
    TclPrintSource(stdout, codePtr->source,
	    TclMin(codePtr->numSrcBytes, 55));
    fprintf(stdout, "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
	    numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
	    codePtr->numLitObjects, codePtr->numAuxDataItems,
	    codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
	    codePtr->numSrcBytes?
		    codePtr->structureSize/(float)codePtr->numSrcBytes :
#endif
	    0.0);

#ifdef TCL_COMPILE_STATS
    fprintf(stdout,
	    "  Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
	    codePtr->structureSize,
	    (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
	    codePtr->numCodeBytes,
	    (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (codePtr->numExceptRanges * sizeof(ExceptionRange)),
	    (codePtr->numAuxDataItems * sizeof(AuxData)),
	    codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */

    /*
     * If the ByteCode is the compiled body of a Tcl procedure, print
     * information about that procedure. Note that we don't know the
     * procedure's name since ByteCode's can be shared among procedures.
     */

    if (codePtr->procPtr != NULL) {
	Proc *procPtr = codePtr->procPtr;
	int numCompiledLocals = procPtr->numCompiledLocals;
	fprintf(stdout,
		"  Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
		(unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
		numCompiledLocals);
	if (numCompiledLocals > 0) {
	    CompiledLocal *localPtr = procPtr->firstLocalPtr;
	    for (i = 0;  i < numCompiledLocals;  i++) {
		fprintf(stdout, "      slot %d%s%s%s%s%s%s", i,
			(localPtr->flags & VAR_SCALAR) ? ", scalar" : "",
			(localPtr->flags & VAR_ARRAY) ? ", array" : "",
			(localPtr->flags & VAR_LINK) ? ", link" : "",
			(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
		if (TclIsVarTemporary(localPtr)) {
		    fprintf(stdout, "\n");
		} else {
		    fprintf(stdout, ", \"%s\"\n", localPtr->name);
		}
		localPtr = localPtr->nextPtr;
	    }
	}
    }

    /*
     * Print the ExceptionRange array.
     */

    if (codePtr->numExceptRanges > 0) {
	fprintf(stdout, "  Exception ranges %d, depth %d:\n",
		codePtr->numExceptRanges, codePtr->maxExceptDepth);
	for (i = 0;  i < codePtr->numExceptRanges;  i++) {
	    ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
	    fprintf(stdout, "      %d: level %d, %s, pc %d-%d, ",
		    i, rangePtr->nestingLevel,

		    (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"),
		    rangePtr->codeOffset,
		    (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
	    switch (rangePtr->type) {
	    case LOOP_EXCEPTION_RANGE:
		fprintf(stdout,	"continue %d, break %d\n",
			rangePtr->continueOffset, rangePtr->breakOffset);
		break;
	    case CATCH_EXCEPTION_RANGE:
		fprintf(stdout,	"catch %d\n", rangePtr->catchOffset);
		break;
	    default:
		Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
			rangePtr->type);
	    }
	}
    }

    /*
     * If there were no commands (e.g., an expression or an empty string was
     * compiled), just print all instructions and return.
     */

    if (numCmds == 0) {
	pc = codeStart;
	while (pc < codeLimit) {
	    fprintf(stdout, "    ");
	    pc += TclPrintInstruction(codePtr, pc);
	}
	return;
    }

    /*
     * Print table showing the code offset, source offset, and source length
     * for each command. These are encoded as a sequence of bytes.
     */

    fprintf(stdout, "  Commands %d:", numCmds);
    codeDeltaNext = codePtr->codeDeltaStart;
    codeLengthNext = codePtr->codeLengthStart;
    srcDeltaNext = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
	    codeDeltaNext += 4;
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
	    codeLengthNext++;
	    codeLen = TclGetInt4AtPtr(codeLengthNext);
	    codeLengthNext += 4;
	} else {
	    codeLen = TclGetInt1AtPtr(codeLengthNext);
	    codeLengthNext++;
	}
	
	if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
	    srcDeltaNext++;
	    delta = TclGetInt4AtPtr(srcDeltaNext);
	    srcDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(srcDeltaNext);
	    srcDeltaNext++;
	}
	srcOffset += delta;

	if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}
	
	fprintf(stdout,	"%s%4d: pc %d-%d, src %d-%d",
		((i % 2)? "   	" : "\n   "),
		(i+1), codeOffset, (codeOffset + codeLen - 1),
		srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
	fprintf(stdout,	"\n");
    }
    
    /*
     * Print each instruction. If the instruction corresponds to the start
     * of a command, print the command's source. Note that we don't need
     * the code length here.
     */

    codeDeltaNext = codePtr->codeDeltaStart;
    srcDeltaNext  = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    pc = codeStart;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);







|


















|








|

|
|
|



|







3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
	    codeLengthNext++;
	    codeLen = TclGetInt4AtPtr(codeLengthNext);
	    codeLengthNext += 4;
	} else {
	    codeLen = TclGetInt1AtPtr(codeLengthNext);
	    codeLengthNext++;
	}

	if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
	    srcDeltaNext++;
	    delta = TclGetInt4AtPtr(srcDeltaNext);
	    srcDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(srcDeltaNext);
	    srcDeltaNext++;
	}
	srcOffset += delta;

	if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	fprintf(stdout,	"%s%4d: pc %d-%d, src %d-%d",
		((i % 2)? "   	" : "\n   "),
		(i+1), codeOffset, (codeOffset + codeLen - 1),
		srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
	fprintf(stdout,	"\n");
    }

    /*
     * Print each instruction. If the instruction corresponds to the start of
     * a command, print the command's source. Note that we don't need the code
     * length here.
     */

    codeDeltaNext = codePtr->codeDeltaStart;
    srcDeltaNext = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    pc = codeStart;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	/*
	 * Print instructions before command i.
	 */
	
	while ((pc-codeStart) < codeOffset) {
	    fprintf(stdout, "    ");
	    pc += TclPrintInstruction(codePtr, pc);
	}

	fprintf(stdout, "  Command %d: ", (i+1));
	TclPrintSource(stdout, (codePtr->source + srcOffset),
	        TclMin(srcLen, 55));
	fprintf(stdout, "\n");
    }
    if (pc < codeLimit) {
	/*
	 * Print instructions after the last command.
	 */

	while (pc < codeLimit) {
	    fprintf(stdout, "    ");
	    pc += TclPrintInstruction(codePtr, pc);
	}
    }
}
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclPrintInstruction --
 *
 *	This procedure prints ("disassembles") one instruction from a
 *	bytecode object to stdout.
 *
 * Results:
 *	Returns the length in bytes of the current instruiction.
 *
 * Side effects:
 *	None.
 *







|







|













<






|
|







3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136

3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	/*
	 * Print instructions before command i.
	 */

	while ((pc-codeStart) < codeOffset) {
	    fprintf(stdout, "    ");
	    pc += TclPrintInstruction(codePtr, pc);
	}

	fprintf(stdout, "  Command %d: ", (i+1));
	TclPrintSource(stdout, (codePtr->source + srcOffset),
		TclMin(srcLen, 55));
	fprintf(stdout, "\n");
    }
    if (pc < codeLimit) {
	/*
	 * Print instructions after the last command.
	 */

	while (pc < codeLimit) {
	    fprintf(stdout, "    ");
	    pc += TclPrintInstruction(codePtr, pc);
	}
    }
}


/*
 *----------------------------------------------------------------------
 *
 * TclPrintInstruction --
 *
 *	This procedure prints ("disassembles") one instruction from a bytecode
 *	object to stdout.
 *
 * Results:
 *	Returns the length in bytes of the current instruiction.
 *
 * Side effects:
 *	None.
 *
3240
3241
3242
3243
3244
3245
3246


3247






3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259

3260
3261
3262
3263
3264
3265
3266
3267
3268
3269

3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339












3340












3341
3342
3343
3344









3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register InstructionDesc *instDesc = &tclInstructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned int pcOffset = (pc - codeStart);
    int opnd, i, j, numBytes = 1;


    






    fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
	switch (instDesc->opTypes[i]) {
	case OPERAND_INT1:
	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
	    if ((i == 0) && ((opCode == INST_JUMP1)
			     || (opCode == INST_JUMP_TRUE1)
		             || (opCode == INST_JUMP_FALSE1))) {
		fprintf(stdout, "%d  	# pc %u", opnd, (pcOffset + opnd));
	    } else {
		fprintf(stdout, "%d ", opnd);
	    }

	    break;
	case OPERAND_INT4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if ((i == 0) && ((opCode == INST_JUMP4)
			     || (opCode == INST_JUMP_TRUE4)
		             || (opCode == INST_JUMP_FALSE4))) {
		fprintf(stdout, "%d  	# pc %u", opnd, (pcOffset + opnd));
	    } else {
		fprintf(stdout, "%d ", opnd);
	    }

	    break;
	case OPERAND_UINT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    if ((i == 0) && (opCode == INST_PUSH1)) {
		fprintf(stdout, "%u  	# ", (unsigned int) opnd);
		TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
	    } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
				    || (opCode == INST_LOAD_ARRAY1)
				    || (opCode == INST_STORE_SCALAR1)
				    || (opCode == INST_STORE_ARRAY1))) {
		int localCt = procPtr->numCompiledLocals;
		CompiledLocal *localPtr = procPtr->firstLocalPtr;
		if (opnd >= localCt) {
		    Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
			     (unsigned int) opnd, localCt);
		}
		for (j = 0;  j < opnd;  j++) {
		    localPtr = localPtr->nextPtr;
		}
		if (TclIsVarTemporary(localPtr)) {
		    fprintf(stdout, "%u	# temp var %u",
			    (unsigned int) opnd, (unsigned int) opnd);
		} else {
		    fprintf(stdout, "%u	# var ", (unsigned int) opnd);
		    TclPrintSource(stdout, localPtr->name, 40);
		}
	    } else {
		fprintf(stdout, "%u ", (unsigned int) opnd);
	    }
	    break;
	case OPERAND_UINT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opCode == INST_PUSH4) {
		fprintf(stdout, "%u  	# ", opnd);
		TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
	    } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
				    || (opCode == INST_LOAD_ARRAY4)
				    || (opCode == INST_STORE_SCALAR4)
				    || (opCode == INST_STORE_ARRAY4))) {
		int localCt = procPtr->numCompiledLocals;
		CompiledLocal *localPtr = procPtr->firstLocalPtr;
		if (opnd >= localCt) {
		    Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
			     (unsigned int) opnd, localCt);
		}
		for (j = 0;  j < opnd;  j++) {
		    localPtr = localPtr->nextPtr;
		}
		if (TclIsVarTemporary(localPtr)) {
		    fprintf(stdout, "%u	# temp var %u",
			    (unsigned int) opnd, (unsigned int) opnd);
		} else {
		    fprintf(stdout, "%u	# var ", (unsigned int) opnd);
		    TclPrintSource(stdout, localPtr->name, 40);
		}
	    } else {
		fprintf(stdout, "%u ", (unsigned int) opnd);
	    }
	    break;

	case OPERAND_IDX4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opnd >= -1) {
		fprintf(stdout, "%d ", opnd);
	    } else if (opnd == -2) {
		fprintf(stdout, "end ");
	    } else {
		fprintf(stdout, "end-%d ", -2-opnd);
            }
	    break;

























	case OPERAND_NONE:
	default:
	    break;
	}









    }
    fprintf(stdout, "\n");
    return numBytes;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPrintObject --
 *
 *	This procedure prints up to a specified number of characters from
 *	the argument Tcl object's string representation to a specified file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintObject(outFile, objPtr, maxChars)
    FILE *outFile;		/* The file to print the source to. */
    Tcl_Obj *objPtr;		/* Points to the Tcl object whose string
				 * representation should be printed. */
    int maxChars;		/* Maximum number of chars to print. */
{
    char *bytes;
    int length;
    
    bytes = Tcl_GetStringFromObj(objPtr, &length);
    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}

/*
 *----------------------------------------------------------------------
 *
 * TclPrintSource --
 *
 *	This procedure prints up to a specified number of characters from
 *	the argument string to a specified file. It tries to produce legible
 *	output by adding backslashes as necessary.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.







>
>
|
>
>
>
>
>
>





<
|
|
<
<
|

>



<
|
|
<
<
|

>



|
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<




<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
|
<
|
<

<








|

>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
>
>










|
|



















|









|
|







3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179

3180
3181


3182
3183
3184
3185
3186
3187

3188
3189


3190
3191
3192
3193
3194
3195
3196

3197









3198











3199

3200
3201
3202
3203

3204


3205











3206




3207

3208

3209

3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register InstructionDesc *instDesc = &tclInstructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned int pcOffset = (pc - codeStart);
    int opnd, i, j, numBytes = 1;
    int localCt = procPtr ? procPtr->numCompiledLocals : 0;
    CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;

    char suffixBuffer[64];	/* Additional info to print after main opcode
				 * and immediates. */
    char *suffixSrc = NULL;
    Tcl_Obj *suffixObj = NULL;

    suffixBuffer[0] = '\0';
    fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
	switch (instDesc->opTypes[i]) {
	case OPERAND_INT1:
	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;

	    if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1
		    || opCode == INST_JUMP_FALSE1) {


		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
	    }
	    fprintf(stdout, "%+d ", opnd);
	    break;
	case OPERAND_INT4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;

	    if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4
		    || opCode == INST_JUMP_FALSE4) {


		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
	    }
	    fprintf(stdout, "%+d ", opnd);
	    break;
	case OPERAND_UINT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    if (opCode == INST_PUSH1) {

		suffixObj = codePtr->objArrayPtr[opnd];









	    }











	    fprintf(stdout, "%u ", (unsigned int) opnd);

	    break;
	case OPERAND_UINT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opCode == INST_PUSH4) {

		suffixObj = codePtr->objArrayPtr[opnd];


	    } else if (opCode == INST_START_CMD) {











		sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);




	    }

	    fprintf(stdout, "%u ", (unsigned int) opnd);

	    break;

	case OPERAND_IDX4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opnd >= -1) {
		fprintf(stdout, "%d ", opnd);
	    } else if (opnd == -2) {
		fprintf(stdout, "end ");
	    } else {
		fprintf(stdout, "end-%d ", -2-opnd);
	    }
	    break;
	case OPERAND_LVT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes);
	    numBytes++;
	    goto printLVTindex;
	case OPERAND_LVT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes);
	    numBytes += 4;
	printLVTindex:
	    if (localPtr != NULL) {
		if (opnd >= localCt) {
		    Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
			    (unsigned int) opnd, localCt);
		}
		for (j = 0;  j < opnd;  j++) {
		    localPtr = localPtr->nextPtr;
		}
		if (TclIsVarTemporary(localPtr)) {
		    sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
		} else {
		    sprintf(suffixBuffer, "var ");
		    suffixSrc = localPtr->name;
		}
	    }
	    fprintf(stdout, "%%v%u ", (unsigned) opnd);
	    break;
	case OPERAND_NONE:
	default:
	    break;
	}
    }
    if (suffixObj) {
	fprintf(stdout, "\t# ");
	TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
    } else if (suffixBuffer[0]) {
	fprintf(stdout, "\t# %s", suffixBuffer);
	if (suffixSrc) {
	    TclPrintSource(stdout, suffixSrc, 40);
	}
    }
    fprintf(stdout, "\n");
    return numBytes;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPrintObject --
 *
 *	This procedure prints up to a specified number of characters from the
 *	argument Tcl object's string representation to a specified file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintObject(outFile, objPtr, maxChars)
    FILE *outFile;		/* The file to print the source to. */
    Tcl_Obj *objPtr;		/* Points to the Tcl object whose string
				 * representation should be printed. */
    int maxChars;		/* Maximum number of chars to print. */
{
    char *bytes;
    int length;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}

/*
 *----------------------------------------------------------------------
 *
 * TclPrintSource --
 *
 *	This procedure prints up to a specified number of characters from the
 *	argument string to a specified file. It tries to produce legible
 *	output by adding backslashes as necessary.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441

3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490








	return;
    }

    fprintf(outFile, "\"");
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p++, i++) {
	switch (*p) {
	    case '"':
		fprintf(outFile, "\\\"");
		continue;
	    case '\f':
		fprintf(outFile, "\\f");
		continue;
	    case '\n':
		fprintf(outFile, "\\n");
		continue;
            case '\r':
		fprintf(outFile, "\\r");
		continue;
	    case '\t':
		fprintf(outFile, "\\t");
		continue;
            case '\v':
		fprintf(outFile, "\\v");
		continue;
	    default:
		fprintf(outFile, "%c", *p);
		continue;
	}
    }
    fprintf(outFile, "\"");
}


#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * RecordByteCodeStats --
 *
 *	Accumulates various compilation-related statistics for each newly
 *	compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
 *	compiled with the -DTCL_COMPILE_STATS flag
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Accumulates aggregate code-related statistics in the interpreter's
 *	ByteCodeStats structure. Records statistics specific to a ByteCode
 *	in its ByteCode structure.
 *
 *----------------------------------------------------------------------
 */

void
RecordByteCodeStats(codePtr)
    ByteCode *codePtr;		/* Points to ByteCode structure with info
				 * to add to accumulated statistics. */
{
    Interp *iPtr = (Interp *) *codePtr->interpHandle;
    register ByteCodeStats *statsPtr = &(iPtr->stats);

    statsPtr->numCompilations++;
    statsPtr->totalSrcBytes        += (double) codePtr->numSrcBytes;
    statsPtr->totalByteCodeBytes   += (double) codePtr->structureSize;
    statsPtr->currentSrcBytes      += (double) codePtr->numSrcBytes;
    statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
    
    statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
    statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;

    statsPtr->currentInstBytes   += (double) codePtr->numCodeBytes;
    statsPtr->currentLitBytes    +=
	    (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); 
    statsPtr->currentExceptBytes +=
	    (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
    statsPtr->currentAuxBytes    +=
            (double) (codePtr->numAuxDataItems * sizeof(AuxData));
    statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
}
#endif /* TCL_COMPILE_STATS */















|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|




>
















|
|













|
|
|

|



|
|
|
|
|
|
|



>
>
>
>
>
>
>
>
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
	return;
    }

    fprintf(outFile, "\"");
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p++, i++) {
	switch (*p) {
	case '"':
	    fprintf(outFile, "\\\"");
	    continue;
	case '\f':
	    fprintf(outFile, "\\f");
	    continue;
	case '\n':
	    fprintf(outFile, "\\n");
	    continue;
	case '\r':
	    fprintf(outFile, "\\r");
	    continue;
	case '\t':
	    fprintf(outFile, "\\t");
	    continue;
	case '\v':
	    fprintf(outFile, "\\v");
	    continue;
	default:
	    fprintf(outFile, "%c", *p);
	    continue;
	}
    }
    fprintf(outFile, "\"");
}
#endif /* TCL_COMPILE_DEBUG */

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * RecordByteCodeStats --
 *
 *	Accumulates various compilation-related statistics for each newly
 *	compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
 *	compiled with the -DTCL_COMPILE_STATS flag
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Accumulates aggregate code-related statistics in the interpreter's
 *	ByteCodeStats structure. Records statistics specific to a ByteCode in
 *	its ByteCode structure.
 *
 *----------------------------------------------------------------------
 */

void
RecordByteCodeStats(codePtr)
    ByteCode *codePtr;		/* Points to ByteCode structure with info
				 * to add to accumulated statistics. */
{
    Interp *iPtr = (Interp *) *codePtr->interpHandle;
    register ByteCodeStats *statsPtr = &(iPtr->stats);

    statsPtr->numCompilations++;
    statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
    statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
    statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
    statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;

    statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
    statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;

    statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
    statsPtr->currentLitBytes += (double)
	    codePtr->numLitObjects * sizeof(Tcl_Obj *);
    statsPtr->currentExceptBytes += (double)
	    codePtr->numExceptRanges * sizeof(ExceptionRange);
    statsPtr->currentAuxBytes += (double)
	    codePtr->numAuxDataItems * sizeof(AuxData);
    statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
}
#endif /* TCL_COMPILE_STATS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCompile.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclCompile.h --
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.h,v 1.51 2004/11/03 21:20:30 davygrvy Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclCompile.h --
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.h,v 1.51.2.6 2005/08/02 18:15:21 dgp Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled
 * This variable is linked to the Tcl variable "tcl_traceCompile".
 */

MODULE_SCOPE int 	tclTraceCompile;
#endif

#ifdef TCL_COMPILE_DEBUG
/*
 * Variable that controls whether execution tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no execution tracing
 *    1: trace invocations of Tcl procs only
 *    2: trace invocations of all (not compiled away) commands
 *    3: display each instruction executed
 * This variable is linked to the Tcl variable "tcl_traceExec".
 */

MODULE_SCOPE int 	tclTraceExec;
#endif

/*
 *------------------------------------------------------------------------
 * Data structures related to compilation.
 *------------------------------------------------------------------------
 */

/*
 * The structure used to implement Tcl "exceptions" (exceptional returns):
 * for example, those generated in loops by the break and continue commands,
 * and those generated by scripts and caught by the catch command. This
 * ExceptionRange structure describes a range of code (e.g., a loop body),
 * the kind of exceptions (e.g., a break or continue) that might occur, and
 * the PC offsets to jump to if a matching exception does occur. Exception
 * ranges can nest so this structure includes a nesting level that is used
 * at runtime to find the closest exception range surrounding a PC. For
 * example, when a break command is executed, the ExceptionRange structure
 * for the most deeply nested loop, if any, is found and used. These
 * structures are also generated for the "next" subcommands of for loops
 * since a break there terminates the for command. This means a for command
 * actually generates two LoopInfo structures.
 */

typedef enum {
    LOOP_EXCEPTION_RANGE,	/* Exception's range is part of a loop.
				 * Break and continue "exceptions" cause
				 * jumps to appropriate PC offsets. */
    CATCH_EXCEPTION_RANGE	/* Exception's range is controlled by a
				 * catch command. Errors in the range cause
				 * a jump to a catch PC offset. */
} ExceptionRangeType;

typedef struct ExceptionRange {
    ExceptionRangeType type;	/* The kind of ExceptionRange. */
    int nestingLevel;		/* Static depth of the exception range.
				 * Used to find the most deeply-nested
				 * range surrounding a PC at runtime. */
    int codeOffset;		/* Offset of the first instruction byte of
				 * the code range. */
    int numCodeBytes;		/* Number of bytes in the code range. */
    int breakOffset;		/* If LOOP_EXCEPTION_RANGE, the target PC
				 * offset for a break command in the range. */
    int continueOffset;		/* If LOOP_EXCEPTION_RANGE and not -1, the
				 * target PC offset for a continue command in
				 * the code range. Otherwise, ignore this range
				 * when processing a continue command. */

    int catchOffset;		/* If a CATCH_EXCEPTION_RANGE, the target PC
				 * offset for any "exception" in range. */
} ExceptionRange;

/*
 * Structure used to map between instruction pc and source locations. It
 * defines for each compiled Tcl command its code's starting offset and 
 * its source's starting offset and length. Note that the code offset
 * increases monotonically: that is, the table is sorted in code offset
 * order. The source offset is not monotonic.
 */

typedef struct CmdLocation {
    int codeOffset;		/* Offset of first byte of command code. */
    int numCodeBytes;		/* Number of bytes for command's code. */
    int srcOffset;		/* Offset of first char of the command. */
    int numSrcBytes;		/* Number of command source chars. */
} CmdLocation;

/*
 * CompileProcs need the ability to record information during compilation
 * that can be used by bytecode instructions during execution. The AuxData
 * structure provides this "auxiliary data" mechanism. An arbitrary number
 * of these structures can be stored in the ByteCode record (during
 * compilation they are stored in a CompileEnv structure). Each AuxData
 * record holds one word of client-specified data (often a pointer) and is
 * given an index that instructions can later use to look up the structure
 * and its data.
 *
 * The following definitions declare the types of procedures that are called
 * to duplicate or free this auxiliary data when the containing ByteCode
 * objects are duplicated and freed. Pointers to these procedures are kept
 * in the AuxData structure.
 */

typedef ClientData (AuxDataDupProc)  _ANSI_ARGS_((ClientData clientData));
typedef void       (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData));

/*
 * We define a separate AuxDataType struct to hold type-related information
 * for the AuxData structure. This separation makes it possible for clients
 * outside of the TCL core to manipulate (in a limited fashion!) AuxData;
 * for example, it makes it possible to pickle and unpickle AuxData structs.
 */

typedef struct AuxDataType {
    char *name;			/* the name of the type. Types can be
				 * registered and found by name */
    AuxDataDupProc *dupProc;	/* Callback procedure to invoke when the
				 * aux data is duplicated (e.g., when the
				 * ByteCode structure containing the aux
				 * data is duplicated). NULL means just
				 * copy the source clientData bits; no
				 * proc need be called. */
    AuxDataFreeProc *freeProc;	/* Callback procedure to invoke when the
				 * aux data is freed. NULL means no
				 * proc need be called. */
} AuxDataType;

/*
 * The definition of the AuxData structure that holds information created
 * during compilation by CompileProcs and used by instructions during
 * execution.
 */







<

<












|







|
|
|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|




|
|
|
|
|





|
|
>






|
|
|
|










|
|
|
|
|
|
|
<



|
|








|
|





|
|
|
|
|
|
|
|
|







30
31
32
33
34
35
36

37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled
 * This variable is linked to the Tcl variable "tcl_traceCompile".
 */

MODULE_SCOPE int 	tclTraceCompile;



/*
 * Variable that controls whether execution tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no execution tracing
 *    1: trace invocations of Tcl procs only
 *    2: trace invocations of all (not compiled away) commands
 *    3: display each instruction executed
 * This variable is linked to the Tcl variable "tcl_traceExec".
 */

MODULE_SCOPE int 	tclTraceExec;
#endif

/*
 *------------------------------------------------------------------------
 * Data structures related to compilation.
 *------------------------------------------------------------------------
 */

/*
 * The structure used to implement Tcl "exceptions" (exceptional returns): for
 * example, those generated in loops by the break and continue commands, and
 * those generated by scripts and caught by the catch command. This
 * ExceptionRange structure describes a range of code (e.g., a loop body), the
 * kind of exceptions (e.g., a break or continue) that might occur, and the PC
 * offsets to jump to if a matching exception does occur. Exception ranges can
 * nest so this structure includes a nesting level that is used at runtime to
 * find the closest exception range surrounding a PC. For example, when a
 * break command is executed, the ExceptionRange structure for the most deeply
 * nested loop, if any, is found and used. These structures are also generated
 * for the "next" subcommands of for loops since a break there terminates the
 * for command. This means a for command actually generates two LoopInfo
 * structures.
 */

typedef enum {
    LOOP_EXCEPTION_RANGE,	/* Exception's range is part of a loop.  Break
				 * and continue "exceptions" cause jumps to
				 * appropriate PC offsets. */
    CATCH_EXCEPTION_RANGE	/* Exception's range is controlled by a catch
				 * command. Errors in the range cause a jump
				 * to a catch PC offset. */
} ExceptionRangeType;

typedef struct ExceptionRange {
    ExceptionRangeType type;	/* The kind of ExceptionRange. */
    int nestingLevel;		/* Static depth of the exception range. Used
				 * to find the most deeply-nested range
				 * surrounding a PC at runtime. */
    int codeOffset;		/* Offset of the first instruction byte of the
				 * code range. */
    int numCodeBytes;		/* Number of bytes in the code range. */
    int breakOffset;		/* If LOOP_EXCEPTION_RANGE, the target PC
				 * offset for a break command in the range. */
    int continueOffset;		/* If LOOP_EXCEPTION_RANGE and not -1, the
				 * target PC offset for a continue command in
				 * the code range. Otherwise, ignore this
				 * range when processing a continue
				 * command. */
    int catchOffset;		/* If a CATCH_EXCEPTION_RANGE, the target PC
				 * offset for any "exception" in range. */
} ExceptionRange;

/*
 * Structure used to map between instruction pc and source locations. It
 * defines for each compiled Tcl command its code's starting offset and its
 * source's starting offset and length. Note that the code offset increases
 * monotonically: that is, the table is sorted in code offset order. The
 * source offset is not monotonic.
 */

typedef struct CmdLocation {
    int codeOffset;		/* Offset of first byte of command code. */
    int numCodeBytes;		/* Number of bytes for command's code. */
    int srcOffset;		/* Offset of first char of the command. */
    int numSrcBytes;		/* Number of command source chars. */
} CmdLocation;

/*
 * CompileProcs need the ability to record information during compilation that
 * can be used by bytecode instructions during execution. The AuxData
 * structure provides this "auxiliary data" mechanism. An arbitrary number of
 * these structures can be stored in the ByteCode record (during compilation
 * they are stored in a CompileEnv structure). Each AuxData record holds one
 * word of client-specified data (often a pointer) and is given an index that
 * instructions can later use to look up the structure and its data.

 *
 * The following definitions declare the types of procedures that are called
 * to duplicate or free this auxiliary data when the containing ByteCode
 * objects are duplicated and freed. Pointers to these procedures are kept in
 * the AuxData structure.
 */

typedef ClientData (AuxDataDupProc)  _ANSI_ARGS_((ClientData clientData));
typedef void       (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData));

/*
 * We define a separate AuxDataType struct to hold type-related information
 * for the AuxData structure. This separation makes it possible for clients
 * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for
 * example, it makes it possible to pickle and unpickle AuxData structs.
 */

typedef struct AuxDataType {
    char *name;			/* the name of the type. Types can be
				 * registered and found by name */
    AuxDataDupProc *dupProc;	/* Callback procedure to invoke when the aux
				 * data is duplicated (e.g., when the ByteCode
				 * structure containing the aux data is
				 * duplicated). NULL means just copy the
				 * source clientData bits; no proc need be
				 * called. */
    AuxDataFreeProc *freeProc;	/* Callback procedure to invoke when the aux
				 * data is freed. NULL means no proc need be
				 * called. */
} AuxDataType;

/*
 * The definition of the AuxData structure that holds information created
 * during compilation by CompileProcs and used by instructions during
 * execution.
 */
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
#define COMPILEENV_INIT_NUM_OBJECTS    60
#define COMPILEENV_INIT_EXCEPT_RANGES   5
#define COMPILEENV_INIT_CMD_MAP_SIZE   40
#define COMPILEENV_INIT_AUX_DATA_SIZE   5

typedef struct CompileEnv {
    Interp *iPtr;		/* Interpreter containing the code being
				 * compiled. Commands and their compile
				 * procs are specific to an interpreter so
				 * the code emitted will depend on the
				 * interpreter. */
    char *source;		/* The source string being compiled by
				 * SetByteCodeFromAny. This pointer is not
				 * owned by the CompileEnv and must not be
				 * freed or changed by it. */
    int numSrcBytes;		/* Number of bytes in source. */
    Proc *procPtr;		/* If a procedure is being compiled, a
				 * pointer to its Proc structure; otherwise
				 * NULL. Used to compile local variables.
				 * Set from information provided by
				 * ObjInterpProc in tclProc.c. */
    int numCommands;		/* Number of commands compiled. */
    int exceptDepth;		/* Current exception range nesting level;
				 * -1 if not in any range currently. */
    int maxExceptDepth;		/* Max nesting level of exception ranges;
				 * -1 if no ranges have been compiled. */
    int maxStackDepth;		/* Maximum number of stack elements needed
				 * to execute the code. Set by compilation
				 * procedures before returning. */
    int currStackDepth;		/* Current stack depth. */
    LiteralTable localLitTable;	/* Contains LiteralEntry's describing
				 * all Tcl objects referenced by this
				 * compiled code. Indexed by the string
				 * representations of the literals. Used to
				 * avoid creating duplicate objects. */
    unsigned char *codeStart;	/* Points to the first byte of the code. */
    unsigned char *codeNext;	/* Points to next code array byte to use. */
    unsigned char *codeEnd;	/* Points just after the last allocated
				 * code array byte. */
    int mallocedCodeArray;	/* Set 1 if code array was expanded 
				 * and codeStart points into the heap.*/
    LiteralEntry *literalArrayPtr;
    				/* Points to start of LiteralEntry array. */
    int literalArrayNext;	/* Index of next free object array entry. */
    int literalArrayEnd;	/* Index just after last obj array entry. */
    int mallocedLiteralArray;	/* 1 if object array was expanded and
				 * objArray points into the heap, else 0. */
    ExceptionRange *exceptArrayPtr;
    				/* Points to start of the ExceptionRange
				 * array. */
    int exceptArrayNext;	/* Next free ExceptionRange array index.
				 * exceptArrayNext is the number of ranges
				 * and (exceptArrayNext-1) is the index of
				 * the current range's array entry. */
    int exceptArrayEnd;		/* Index after the last ExceptionRange
				 * array entry. */
    int mallocedExceptArray;	/* 1 if ExceptionRange array was expanded
				 * and exceptArrayPtr points in heap,
				 * else 0. */
    CmdLocation *cmdMapPtr;	/* Points to start of CmdLocation array.
				 * numCommands is the index of the next
				 * entry to use; (numCommands-1) is the
				 * entry index for the last command. */
    int cmdMapEnd;		/* Index after last CmdLocation entry. */
    int mallocedCmdMap;		/* 1 if command map array was expanded and
				 * cmdMapPtr points in the heap, else 0. */
    AuxData *auxDataArrayPtr;	/* Points to auxiliary data array start. */
    int auxDataArrayNext;	/* Next free compile aux data array index.
				 * auxDataArrayNext is the number of aux
				 * data items and (auxDataArrayNext-1) is
				 * index of current aux data array entry. */
    int auxDataArrayEnd;	/* Index after last aux data array entry. */
    int mallocedAuxDataArray;	/* 1 if aux data array was expanded and
				 * auxDataArrayPtr points in heap else 0. */
    unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
				/* Initial storage for code. */
    LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
				/* Initial storage of LiteralEntry array. */
    ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
				/* Initial ExceptionRange array storage. */
    CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
				/* Initial storage for cmd location map. */
    AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
				/* Initial storage for aux data array. */
} CompileEnv;

/*
 * The structure defining the bytecode instructions resulting from compiling
 * a Tcl script. Note that this structure is variable length: a single heap
 * object is allocated to hold the ByteCode structure immediately followed
 * by the code bytes, the literal object array, the ExceptionRange array,
 * the CmdLocation map, and the compilation AuxData array.
 */

/*
 * A PRECOMPILED bytecode struct is one that was generated from a compiled
 * image rather than implicitly compiled from source
 */
#define TCL_BYTECODE_PRECOMPILED		0x0001








typedef struct ByteCode {
    TclHandle interpHandle;	/* Handle for interpreter containing the
				 * compiled code.  Commands and their compile
				 * procs are specific to an interpreter so the
				 * code emitted will depend on the
				 * interpreter. */
    int compileEpoch;		/* Value of iPtr->compileEpoch when this
				 * ByteCode was compiled. Used to invalidate
				 * code when, e.g., commands with compile
				 * procs are redefined. */
    Namespace *nsPtr;		/* Namespace context in which this code
				 * was compiled. If the code is executed
				 * if a different namespace, it must be
				 * recompiled. */
    int nsEpoch;		/* Value of nsPtr->resolverEpoch when this
				 * ByteCode was compiled. Used to invalidate
				 * code when new namespace resolution rules
				 * are put into effect. */
    int refCount;		/* Reference count: set 1 when created
				 * plus 1 for each execution of the code
				 * currently active. This structure can be
				 * freed when refCount becomes zero. */
    unsigned int flags;		/* flags describing state for the codebyte.
				 * this variable holds ORed values from the
				 * TCL_BYTECODE_ masks defined above */
    char *source;		/* The source string from which this
				 * ByteCode was compiled. Note that this
				 * pointer is not owned by the ByteCode and
				 * must not be freed or modified by it. */
    Proc *procPtr;		/* If the ByteCode was compiled from a
				 * procedure body, this is a pointer to its
				 * Proc structure; otherwise NULL. This
				 * pointer is also not owned by the ByteCode
				 * and must not be freed by it. */
    size_t structureSize;	/* Number of bytes in the ByteCode structure
				 * itself. Does not include heap space for
				 * literal Tcl objects or storage referenced
				 * by AuxData entries. */
    int numCommands;		/* Number of commands compiled. */
    int numSrcBytes;		/* Number of source bytes compiled. */
    int numCodeBytes;		/* Number of code bytes. */
    int numLitObjects;		/* Number of objects in literal array. */
    int numExceptRanges;	/* Number of ExceptionRange array elems. */
    int numAuxDataItems;	/* Number of AuxData items. */
    int numCmdLocBytes;		/* Number of bytes needed for encoded
				 * command location information. */
    int maxExceptDepth;		/* Maximum nesting level of ExceptionRanges;
				 * -1 if no ranges were compiled. */
    int maxStackDepth;		/* Maximum number of stack elements needed
				 * to execute the code. */
    unsigned char *codeStart;	/* Points to the first byte of the code.
				 * This is just after the final ByteCode
				 * member cmdMapPtr. */
    Tcl_Obj **objArrayPtr;	/* Points to the start of the literal
				 * object array. This is just after the
				 * last code byte. */
    ExceptionRange *exceptArrayPtr;
    				/* Points to the start of the ExceptionRange
				 * array. This is just after the last
				 * object in the object array. */
    AuxData *auxDataArrayPtr;	/* Points to the start of the auxiliary data
				 * array. This is just after the last entry
				 * in the ExceptionRange array. */
    unsigned char *codeDeltaStart;
				/* Points to the first of a sequence of
				 * bytes that encode the change in the
				 * starting offset of each command's code.
				 * If -127<=delta<=127, it is encoded as 1
				 * byte, otherwise 0xFF (128) appears and
				 * the delta is encoded by the next 4 bytes.
				 * Code deltas are always positive. This
				 * sequence is just after the last entry in
				 * the AuxData array. */
    unsigned char *codeLengthStart;
				/* Points to the first of a sequence of
				 * bytes that encode the length of each
				 * command's code. The encoding is the same
				 * as for code deltas. Code lengths are
				 * always positive. This sequence is just
				 * after the last entry in the code delta
				 * sequence. */
    unsigned char *srcDeltaStart;
				/* Points to the first of a sequence of
				 * bytes that encode the change in the
				 * starting offset of each command's source.
				 * The encoding is the same as for code
				 * deltas. Source deltas can be negative.
				 * This sequence is just after the last byte
				 * in the code length sequence. */
    unsigned char *srcLengthStart;
				/* Points to the first of a sequence of
				 * bytes that encode the length of each
				 * command's source. The encoding is the
				 * same as for code deltas. Source lengths
				 * are always positive. This sequence is
				 * just after the last byte in the source
				 * delta sequence. */
#ifdef TCL_COMPILE_STATS
    Tcl_Time createTime;	/* Absolute time when the ByteCode was
				 * created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;

/*
 * Opcodes for the Tcl bytecode instructions. These must correspond to
 * the entries in the table of instruction descriptions,
 * tclInstructionTable, in tclCompile.c. Also, the order and number of
 * the expression opcodes (e.g., INST_LOR) must match the entries in
 * the array operatorStrings in tclExecute.c.
 */

/* Opcodes 0 to 9 */
#define INST_DONE			0
#define INST_PUSH1			1
#define INST_PUSH4			2
#define INST_POP			3







|
|
|
<





|
|
|
|
|

|
|
|
|
|
|


|
|
|
|
|


|
|
|
|




|
|




|
|
|
|
|
|
|
<

|
|
|





|
|
|
















|
|
|
|
|








>
>
>
>
>
>
>










|
|
|





|
|
|
|



|
|
|
|















|
|


|
|
|
|
|
|
|
|


|
|

|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
<
|

|
|
|
|
|
|
|

|
|
|
|
|
|
<





|

|
|
|
|
|







174
175
176
177
178
179
180
181
182
183

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230

231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373

374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
#define COMPILEENV_INIT_NUM_OBJECTS    60
#define COMPILEENV_INIT_EXCEPT_RANGES   5
#define COMPILEENV_INIT_CMD_MAP_SIZE   40
#define COMPILEENV_INIT_AUX_DATA_SIZE   5

typedef struct CompileEnv {
    Interp *iPtr;		/* Interpreter containing the code being
				 * compiled. Commands and their compile procs
				 * are specific to an interpreter so the code
				 * emitted will depend on the interpreter. */

    char *source;		/* The source string being compiled by
				 * SetByteCodeFromAny. This pointer is not
				 * owned by the CompileEnv and must not be
				 * freed or changed by it. */
    int numSrcBytes;		/* Number of bytes in source. */
    Proc *procPtr;		/* If a procedure is being compiled, a pointer
				 * to its Proc structure; otherwise NULL. Used
				 * to compile local variables.  Set from
				 * information provided by ObjInterpProc in
				 * tclProc.c. */
    int numCommands;		/* Number of commands compiled. */
    int exceptDepth;		/* Current exception range nesting level; -1
				 * if not in any range currently. */
    int maxExceptDepth;		/* Max nesting level of exception ranges; -1
				 * if no ranges have been compiled. */
    int maxStackDepth;		/* Maximum number of stack elements needed to
				 * execute the code. Set by compilation
				 * procedures before returning. */
    int currStackDepth;		/* Current stack depth. */
    LiteralTable localLitTable;	/* Contains LiteralEntry's describing all Tcl
				 * objects referenced by this compiled code.
				 * Indexed by the string representations of
				 * the literals. Used to avoid creating
				 * duplicate objects. */
    unsigned char *codeStart;	/* Points to the first byte of the code. */
    unsigned char *codeNext;	/* Points to next code array byte to use. */
    unsigned char *codeEnd;	/* Points just after the last allocated code
				 * array byte. */
    int mallocedCodeArray;	/* Set 1 if code array was expanded and
				 * codeStart points into the heap.*/
    LiteralEntry *literalArrayPtr;
    				/* Points to start of LiteralEntry array. */
    int literalArrayNext;	/* Index of next free object array entry. */
    int literalArrayEnd;	/* Index just after last obj array entry. */
    int mallocedLiteralArray;	/* 1 if object array was expanded and objArray
				 * points into the heap, else 0. */
    ExceptionRange *exceptArrayPtr;
    				/* Points to start of the ExceptionRange
				 * array. */
    int exceptArrayNext;	/* Next free ExceptionRange array index.
				 * exceptArrayNext is the number of ranges and
				 * (exceptArrayNext-1) is the index of the
				 * current range's array entry. */
    int exceptArrayEnd;		/* Index after the last ExceptionRange array
				 * entry. */
    int mallocedExceptArray;	/* 1 if ExceptionRange array was expanded and
				 * exceptArrayPtr points in heap, else 0. */

    CmdLocation *cmdMapPtr;	/* Points to start of CmdLocation array.
				 * numCommands is the index of the next entry
				 * to use; (numCommands-1) is the entry index
				 * for the last command. */
    int cmdMapEnd;		/* Index after last CmdLocation entry. */
    int mallocedCmdMap;		/* 1 if command map array was expanded and
				 * cmdMapPtr points in the heap, else 0. */
    AuxData *auxDataArrayPtr;	/* Points to auxiliary data array start. */
    int auxDataArrayNext;	/* Next free compile aux data array index.
				 * auxDataArrayNext is the number of aux data
				 * items and (auxDataArrayNext-1) is index of
				 * current aux data array entry. */
    int auxDataArrayEnd;	/* Index after last aux data array entry. */
    int mallocedAuxDataArray;	/* 1 if aux data array was expanded and
				 * auxDataArrayPtr points in heap else 0. */
    unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
				/* Initial storage for code. */
    LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
				/* Initial storage of LiteralEntry array. */
    ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
				/* Initial ExceptionRange array storage. */
    CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
				/* Initial storage for cmd location map. */
    AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
				/* Initial storage for aux data array. */
} CompileEnv;

/*
 * The structure defining the bytecode instructions resulting from compiling a
 * Tcl script. Note that this structure is variable length: a single heap
 * object is allocated to hold the ByteCode structure immediately followed by
 * the code bytes, the literal object array, the ExceptionRange array, the
 * CmdLocation map, and the compilation AuxData array.
 */

/*
 * A PRECOMPILED bytecode struct is one that was generated from a compiled
 * image rather than implicitly compiled from source
 */
#define TCL_BYTECODE_PRECOMPILED		0x0001

/*
 * When a bytecode is compiled, interp or namespace resolvers have not been
 * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag.
 */

#define TCL_BYTECODE_RESOLVE_VARS		0x0002

typedef struct ByteCode {
    TclHandle interpHandle;	/* Handle for interpreter containing the
				 * compiled code.  Commands and their compile
				 * procs are specific to an interpreter so the
				 * code emitted will depend on the
				 * interpreter. */
    int compileEpoch;		/* Value of iPtr->compileEpoch when this
				 * ByteCode was compiled. Used to invalidate
				 * code when, e.g., commands with compile
				 * procs are redefined. */
    Namespace *nsPtr;		/* Namespace context in which this code was
				 * compiled. If the code is executed if a
				 * different namespace, it must be
				 * recompiled. */
    int nsEpoch;		/* Value of nsPtr->resolverEpoch when this
				 * ByteCode was compiled. Used to invalidate
				 * code when new namespace resolution rules
				 * are put into effect. */
    int refCount;		/* Reference count: set 1 when created plus 1
				 * for each execution of the code currently
				 * active. This structure can be freed when
				 * refCount becomes zero. */
    unsigned int flags;		/* flags describing state for the codebyte.
				 * this variable holds ORed values from the
				 * TCL_BYTECODE_ masks defined above */
    char *source;		/* The source string from which this ByteCode
				 * was compiled. Note that this pointer is not
				 * owned by the ByteCode and must not be freed
				 * or modified by it. */
    Proc *procPtr;		/* If the ByteCode was compiled from a
				 * procedure body, this is a pointer to its
				 * Proc structure; otherwise NULL. This
				 * pointer is also not owned by the ByteCode
				 * and must not be freed by it. */
    size_t structureSize;	/* Number of bytes in the ByteCode structure
				 * itself. Does not include heap space for
				 * literal Tcl objects or storage referenced
				 * by AuxData entries. */
    int numCommands;		/* Number of commands compiled. */
    int numSrcBytes;		/* Number of source bytes compiled. */
    int numCodeBytes;		/* Number of code bytes. */
    int numLitObjects;		/* Number of objects in literal array. */
    int numExceptRanges;	/* Number of ExceptionRange array elems. */
    int numAuxDataItems;	/* Number of AuxData items. */
    int numCmdLocBytes;		/* Number of bytes needed for encoded command
				 * location information. */
    int maxExceptDepth;		/* Maximum nesting level of ExceptionRanges;
				 * -1 if no ranges were compiled. */
    int maxStackDepth;		/* Maximum number of stack elements needed to
				 * execute the code. */
    unsigned char *codeStart;	/* Points to the first byte of the code. This
				 * is just after the final ByteCode member
				 * cmdMapPtr. */
    Tcl_Obj **objArrayPtr;	/* Points to the start of the literal object
				 * array. This is just after the last code
				 * byte. */
    ExceptionRange *exceptArrayPtr;
    				/* Points to the start of the ExceptionRange
				 * array. This is just after the last object
				 * in the object array. */
    AuxData *auxDataArrayPtr;	/* Points to the start of the auxiliary data
				 * array. This is just after the last entry in
				 * the ExceptionRange array. */
    unsigned char *codeDeltaStart;
				/* Points to the first of a sequence of bytes
				 * that encode the change in the starting
				 * offset of each command's code. If -127 <=
				 * delta <= 127, it is encoded as 1 byte,
				 * otherwise 0xFF (128) appears and the delta
				 * is encoded by the next 4 bytes. Code deltas
				 * are always positive. This sequence is just
				 * after the last entry in the AuxData
				 * array. */
    unsigned char *codeLengthStart;
				/* Points to the first of a sequence of bytes
				 * that encode the length of each command's
				 * code. The encoding is the same as for code
				 * deltas. Code lengths are always positive.
				 * This sequence is just after the last entry

				 * in the code delta sequence. */
    unsigned char *srcDeltaStart;
				/* Points to the first of a sequence of bytes
				 * that encode the change in the starting
				 * offset of each command's source. The
				 * encoding is the same as for code deltas.
				 * Source deltas can be negative. This
				 * sequence is just after the last byte in the
				 * code length sequence. */
    unsigned char *srcLengthStart;
				/* Points to the first of a sequence of bytes
				 * that encode the length of each command's
				 * source. The encoding is the same as for
				 * code deltas. Source lengths are always
				 * positive. This sequence is just after the
				 * last byte in the source delta sequence. */

#ifdef TCL_COMPILE_STATS
    Tcl_Time createTime;	/* Absolute time when the ByteCode was
				 * created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;

/*
 * Opcodes for the Tcl bytecode instructions. These must correspond to the
 * entries in the table of instruction descriptions, tclInstructionTable, in
 * tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
 * INST_LOR) must match the entries in the array operatorStrings in
 * tclExecute.c.
 */

/* Opcodes 0 to 9 */
#define INST_DONE			0
#define INST_PUSH1			1
#define INST_PUSH4			2
#define INST_POP			3
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544



















545
546
547
548
549
550
551
552
553
554

555
556
557
558
559
560
561
562
563
564
565
566




567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764

#define INST_OVER			95
#define INST_LSET_LIST			96
#define INST_LSET_FLAT			97

/* TIP#90 - 'return' command. */

#define INST_RETURN			98

/* TIP#123 - exponentiation operator. */

#define INST_EXPON			99

/* TIP #157 - {expand}... language syntax support. */

#define INST_EXPAND_START             100
#define INST_EXPAND_STKTOP            101
#define INST_INVOKE_EXPANDED          102

/*
 * TIP #57 - 'lassign' command.  Code generation requires immediate
 *	     LINDEX and LRANGE operators.
 */

#define INST_LIST_INDEX_IMM		103
#define INST_LIST_RANGE_IMM		104

#define INST_START_CMD                  105

#define INST_LIST_IN			106
#define INST_LIST_NOT_IN		107




















/* The last opcode */
#define LAST_INST_OPCODE		107

/*
 * Table describing the Tcl bytecode instructions: their name (for
 * displaying code), total number of code bytes required (including
 * operand bytes), and a description of the type of each operand.
 * These operand types include signed and unsigned integers of length
 * one and four bytes. The unsigned integers are used for indexes or
 * for, e.g., the count of objects to push in a "push" instruction.

 */

#define MAX_INSTRUCTION_OPERANDS 2

typedef enum InstOperandType {
    OPERAND_NONE,
    OPERAND_INT1,		/* One byte signed integer. */
    OPERAND_INT4,		/* Four byte signed integer. */
    OPERAND_UINT1,		/* One byte unsigned integer. */
    OPERAND_UINT4,		/* Four byte unsigned integer. */
    OPERAND_IDX4		/* Four byte signed index (actually an
				 * integer, but displayed differently.) */




} InstOperandType;

typedef struct InstructionDesc {
    char *name;			/* Name of instruction. */
    int numBytes;		/* Total number of bytes for instruction. */
    int stackEffect;		/* The worst-case balance stack effect of the 
				 * instruction, used for stack requirements 
				 * computations. The value INT_MIN signals
				 * that the instruction's worst case effect
				 * is (1-opnd1).
				 */
    int numOperands;		/* Number of operands. */
    InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
				/* The type of each operand. */
} InstructionDesc;

MODULE_SCOPE InstructionDesc tclInstructionTable[];

/*
 * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte. Each value denotes a builtin Tcl math function. These
 * values must correspond to the entries in the tclBuiltinFuncTable array
 * below and to the values stored in the tclInt.h MathFunc structure's
 * builtinFuncIndex field.
 */

#define BUILTIN_FUNC_ACOS		0
#define BUILTIN_FUNC_ASIN		1
#define BUILTIN_FUNC_ATAN		2
#define BUILTIN_FUNC_ATAN2		3
#define BUILTIN_FUNC_CEIL		4
#define BUILTIN_FUNC_COS		5
#define BUILTIN_FUNC_COSH		6
#define BUILTIN_FUNC_EXP		7
#define BUILTIN_FUNC_FLOOR		8
#define BUILTIN_FUNC_FMOD		9
#define BUILTIN_FUNC_HYPOT		10
#define BUILTIN_FUNC_LOG		11
#define BUILTIN_FUNC_LOG10		12
#define BUILTIN_FUNC_POW		13
#define BUILTIN_FUNC_SIN		14
#define BUILTIN_FUNC_SINH		15
#define BUILTIN_FUNC_SQRT		16
#define BUILTIN_FUNC_TAN		17
#define BUILTIN_FUNC_TANH		18
#define BUILTIN_FUNC_ABS		19
#define BUILTIN_FUNC_DOUBLE		20
#define BUILTIN_FUNC_INT		21
#define BUILTIN_FUNC_RAND		22
#define BUILTIN_FUNC_ROUND		23
#define BUILTIN_FUNC_SRAND		24
#define BUILTIN_FUNC_WIDE		25

#define LAST_BUILTIN_FUNC		25

/*
 * Table describing the built-in math functions. Entries in this table are
 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte.
 */

typedef int (CallBuiltinFuncProc) _ANSI_ARGS_((Tcl_Interp *interp,
	Tcl_Obj **tosPtr, ClientData clientData));

typedef struct {
    char *name;			/* Name of function. */
    int numArgs;		/* Number of arguments for function. */
    Tcl_ValueType argTypes[MAX_MATH_ARGS];
				/* Acceptable types for each argument. */
    CallBuiltinFuncProc *proc;	/* Procedure implementing this function. */
    ClientData clientData;	/* Additional argument to pass to the
				 * function when invoking it. */
} BuiltinFunc;

MODULE_SCOPE BuiltinFunc tclBuiltinFuncTable[];

/*
 * Compilation of some Tcl constructs such as if commands and the logical or
 * (||) and logical and (&&) operators in expressions requires the
 * generation of forward jumps. Since the PC target of these jumps isn't
 * known when the jumps are emitted, we record the offset of each jump in an
 * array of JumpFixup structures. There is one array for each sequence of
 * jumps to one target PC. When we learn the target PC, we update the jumps
 * with the correct distance. Also, if the distance is too great (> 127
 * bytes), we replace the single-byte jump with a four byte jump
 * instruction, move the instructions after the jump down, and update the
 * code offsets for any commands between the jump and the target.
 */

typedef enum {
    TCL_UNCONDITIONAL_JUMP,
    TCL_TRUE_JUMP,
    TCL_FALSE_JUMP
} TclJumpType;

typedef struct JumpFixup {
    TclJumpType jumpType;	/* Indicates the kind of jump. */
    int codeOffset;		/* Offset of the first byte of the one-byte
				 * forward jump's code. */
    int cmdIndex;		/* Index of the first command after the one
				 * for which the jump was emitted. Used to
				 * update the code offsets for subsequent
				 * commands if the two-byte jump at jumpPc
				 * must be replaced with a five-byte one. */
    int exceptIndex;		/* Index of the first range entry in the
				 * ExceptionRange array after the current
				 * one. This field is used to adjust the
				 * code offsets in subsequent ExceptionRange
				 * records when a jump is grown from 2 bytes
				 * to 5 bytes. */
} JumpFixup;

#define JUMPFIXUP_INIT_ENTRIES	10

typedef struct JumpFixupArray {
    JumpFixup *fixup;		/* Points to start of jump fixup array. */
    int next;			/* Index of next free array entry. */
    int end;			/* Index of last usable entry in array. */
    int mallocedArray;		/* 1 if array was expanded and fixups points
				 * into the heap, else 0. */
    JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES];
				/* Initial storage for jump fixup array. */
} JumpFixupArray;

/*
 * The structure describing one variable list of a foreach command. Note
 * that only foreach commands inside procedure bodies are compiled inline so
 * a ForeachVarList structure always describes local variables. Furthermore,
 * only scalar variables are supported for inline-compiled foreach loops.
 */

typedef struct ForeachVarList {
    int numVars;		/* The number of variables in the list. */
    int varIndexes[1];		/* An array of the indexes ("slot numbers")
				 * for each variable in the procedure's
				 * array of local variables. Only scalar
				 * variables are supported. The actual
				 * size of this field will be large enough
				 * to numVars indexes. THIS MUST BE THE
				 * LAST FIELD IN THE STRUCTURE! */
} ForeachVarList;

/*
 * Structure used to hold information about a foreach command that is needed
 * during program execution. These structures are stored in CompileEnv and
 * ByteCode structures as auxiliary data.
 */

typedef struct ForeachInfo {
    int numLists;		/* The number of both the variable and value
				 * lists of the foreach command. */
    int firstValueTemp;		/* Index of the first temp var in a proc
				 * frame used to point to a value list. */
    int loopCtTemp;		/* Index of temp var in a proc frame
				 * holding the loop's iteration count. Used
				 * to determine next value list element to
				 * assign each loop var. */
    ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList
				 * structures describing each var list. The
				 * actual size of this field will be large
				 * enough to numVars indexes. THIS MUST BE
				 * THE LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;

MODULE_SCOPE AuxDataType		tclForeachInfoType;


/*
 *----------------------------------------------------------------
 * Procedures exported by tclBasic.c to be used within the engine.
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    CONST char *command, int length, int flags));
MODULE_SCOPE int	TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));


/*
 *----------------------------------------------------------------
 * Procedures exported by the engine to be used by tclBasic.c
 *----------------------------------------------------------------
 */

/*
 * Declaration moved to the internal stubs table
 *
MODULE_SCOPE int	TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
*/

/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl bytecode compilation and execution
 * modules but not used outside:
 *----------------------------------------------------------------
 */







|







|
|
|









|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|

|
|
|
|
<
|
>










|

>
>
>
>





|
|

|
|









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|
|
|
|
|
|
|
|
|


















|
|
|

















|
|
|






|
|
|
|
|
|











|
|
|
|
|
|



|
|



|
<









<
<












|







514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609


























































610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698

699
700
701
702
703
704
705
706
707


708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727

#define INST_OVER			95
#define INST_LSET_LIST			96
#define INST_LSET_FLAT			97

/* TIP#90 - 'return' command. */

#define INST_RETURN_IMM			98

/* TIP#123 - exponentiation operator. */

#define INST_EXPON			99

/* TIP #157 - {expand}... language syntax support. */

#define INST_EXPAND_START		100
#define INST_EXPAND_STKTOP		101
#define INST_INVOKE_EXPANDED		102

/*
 * TIP #57 - 'lassign' command.  Code generation requires immediate
 *	     LINDEX and LRANGE operators.
 */

#define INST_LIST_INDEX_IMM		103
#define INST_LIST_RANGE_IMM		104

#define INST_START_CMD			105

#define INST_LIST_IN			106
#define INST_LIST_NOT_IN		107

#define INST_PUSH_RETURN_OPTIONS	108
#define INST_RETURN_STK			109

/*
 * Dictionary (TIP#111) related commands.
 */

#define INST_DICT_GET			110
#define INST_DICT_SET			111
#define INST_DICT_UNSET			112
#define INST_DICT_INCR_IMM		113
#define INST_DICT_APPEND		114
#define INST_DICT_LAPPEND		115
#define INST_DICT_FIRST			116
#define INST_DICT_NEXT			117
#define INST_DICT_DONE			118
#define INST_DICT_UPDATE_START		119
#define INST_DICT_UPDATE_END		120

/* The last opcode */
#define LAST_INST_OPCODE		120

/*
 * Table describing the Tcl bytecode instructions: their name (for displaying
 * code), total number of code bytes required (including operand bytes), and a
 * description of the type of each operand. These operand types include signed
 * and unsigned integers of length one and four bytes. The unsigned integers

 * are used for indexes or for, e.g., the count of objects to push in a "push"
 * instruction.
 */

#define MAX_INSTRUCTION_OPERANDS 2

typedef enum InstOperandType {
    OPERAND_NONE,
    OPERAND_INT1,		/* One byte signed integer. */
    OPERAND_INT4,		/* Four byte signed integer. */
    OPERAND_UINT1,		/* One byte unsigned integer. */
    OPERAND_UINT4,		/* Four byte unsigned integer. */
    OPERAND_IDX4,		/* Four byte signed index (actually an
				 * integer, but displayed differently.) */
    OPERAND_LVT1,		/* One byte unsigned index into the local
				 * variable table. */
    OPERAND_LVT4		/* Four byte unsigned index into the local
				 * variable table. */
} InstOperandType;

typedef struct InstructionDesc {
    char *name;			/* Name of instruction. */
    int numBytes;		/* Total number of bytes for instruction. */
    int stackEffect;		/* The worst-case balance stack effect of the
				 * instruction, used for stack requirements
				 * computations. The value INT_MIN signals
				 * that the instruction's worst case effect is
				 * (1-opnd1).
				 */
    int numOperands;		/* Number of operands. */
    InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
				/* The type of each operand. */
} InstructionDesc;

MODULE_SCOPE InstructionDesc tclInstructionTable[];

/*


























































 * Compilation of some Tcl constructs such as if commands and the logical or
 * (||) and logical and (&&) operators in expressions requires the generation
 * of forward jumps. Since the PC target of these jumps isn't known when the
 * jumps are emitted, we record the offset of each jump in an array of
 * JumpFixup structures. There is one array for each sequence of jumps to one
 * target PC. When we learn the target PC, we update the jumps with the
 * correct distance. Also, if the distance is too great (> 127 bytes), we
 * replace the single-byte jump with a four byte jump instruction, move the
 * instructions after the jump down, and update the code offsets for any
 * commands between the jump and the target.
 */

typedef enum {
    TCL_UNCONDITIONAL_JUMP,
    TCL_TRUE_JUMP,
    TCL_FALSE_JUMP
} TclJumpType;

typedef struct JumpFixup {
    TclJumpType jumpType;	/* Indicates the kind of jump. */
    int codeOffset;		/* Offset of the first byte of the one-byte
				 * forward jump's code. */
    int cmdIndex;		/* Index of the first command after the one
				 * for which the jump was emitted. Used to
				 * update the code offsets for subsequent
				 * commands if the two-byte jump at jumpPc
				 * must be replaced with a five-byte one. */
    int exceptIndex;		/* Index of the first range entry in the
				 * ExceptionRange array after the current one.
				 * This field is used to adjust the code
				 * offsets in subsequent ExceptionRange
				 * records when a jump is grown from 2 bytes
				 * to 5 bytes. */
} JumpFixup;

#define JUMPFIXUP_INIT_ENTRIES	10

typedef struct JumpFixupArray {
    JumpFixup *fixup;		/* Points to start of jump fixup array. */
    int next;			/* Index of next free array entry. */
    int end;			/* Index of last usable entry in array. */
    int mallocedArray;		/* 1 if array was expanded and fixups points
				 * into the heap, else 0. */
    JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES];
				/* Initial storage for jump fixup array. */
} JumpFixupArray;

/*
 * The structure describing one variable list of a foreach command. Note that
 * only foreach commands inside procedure bodies are compiled inline so a
 * ForeachVarList structure always describes local variables. Furthermore,
 * only scalar variables are supported for inline-compiled foreach loops.
 */

typedef struct ForeachVarList {
    int numVars;		/* The number of variables in the list. */
    int varIndexes[1];		/* An array of the indexes ("slot numbers")
				 * for each variable in the procedure's array
				 * of local variables. Only scalar variables
				 * are supported. The actual size of this
				 * field will be large enough to numVars
				 * indexes. THIS MUST BE THE LAST FIELD IN THE
				 * STRUCTURE! */
} ForeachVarList;

/*
 * Structure used to hold information about a foreach command that is needed
 * during program execution. These structures are stored in CompileEnv and
 * ByteCode structures as auxiliary data.
 */

typedef struct ForeachInfo {
    int numLists;		/* The number of both the variable and value
				 * lists of the foreach command. */
    int firstValueTemp;		/* Index of the first temp var in a proc frame
				 * used to point to a value list. */
    int loopCtTemp;		/* Index of temp var in a proc frame holding
				 * the loop's iteration count. Used to
				 * determine next value list element to assign
				 * each loop var. */
    ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList
				 * structures describing each var list. The
				 * actual size of this field will be large
				 * enough to numVars indexes. THIS MUST BE THE
				 * LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;

MODULE_SCOPE AuxDataType		tclForeachInfoType;


/*
 *----------------------------------------------------------------
 * Procedures exported by tclBasic.c to be used within the engine.
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    CONST char *command, int length, int flags));



/*
 *----------------------------------------------------------------
 * Procedures exported by the engine to be used by tclBasic.c
 *----------------------------------------------------------------
 */

/*
 * Declaration moved to the internal stubs table
 *
MODULE_SCOPE int	TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
 */

/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl bytecode compilation and execution
 * modules but not used outside:
 *----------------------------------------------------------------
 */
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859



860
861
862
863



864
865
866
867
868
869












870
871
872

873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890


891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
MODULE_SCOPE void	TclFreeJumpFixupArray _ANSI_ARGS_((
  			    JumpFixupArray *fixupArrayPtr));
MODULE_SCOPE void	TclInitAuxDataTypeTable _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CompileEnv *envPtr));
MODULE_SCOPE void	TclInitCompilation _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
			    CompileEnv *envPtr, char *string,
			    int numBytes));
MODULE_SCOPE void	TclInitJumpFixupArray _ANSI_ARGS_((
			    JumpFixupArray *fixupArrayPtr));
MODULE_SCOPE void	TclInitLiteralTable _ANSI_ARGS_((
			    LiteralTable *tablePtr));
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char *	TclLiteralStats _ANSI_ARGS_((
			    LiteralTable *tablePtr));
MODULE_SCOPE int	TclLog2 _ANSI_ARGS_((int value));
#endif
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
#endif
MODULE_SCOPE int	TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr,
			    unsigned char *pc));
MODULE_SCOPE void	TclPrintObject _ANSI_ARGS_((FILE *outFile,
			    Tcl_Obj *objPtr, int maxChars));
MODULE_SCOPE void	TclPrintSource _ANSI_ARGS_((FILE *outFile,
			    CONST char *string, int maxChars));
MODULE_SCOPE void	TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));

MODULE_SCOPE int	TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr,
			    char *bytes, int length, int onHeap));
MODULE_SCOPE void	TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
MODULE_SCOPE void	TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Command *cmdPtr));
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclVerifyGlobalLiteralTable _ANSI_ARGS_((
			    Interp *iPtr));
MODULE_SCOPE void	TclVerifyLocalLiteralTable _ANSI_ARGS_((
			    CompileEnv *envPtr));
#endif
MODULE_SCOPE int	TclCompileVariableCmd _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr));
MODULE_SCOPE int	TclWordKnownAtCompileTime _ANSI_ARGS_((
			    Tcl_Token *tokenPtr, Tcl_Obj *valuePtr));

/*
 *----------------------------------------------------------------
 * Macros used by Tcl bytecode compilation and execution modules
 * inside the Tcl core but not used outside.
 *----------------------------------------------------------------
 */




/*
 * Form of TclRegisterLiteral with onHeap == 0.
 * In that case, it is safe to cast away CONSTness, and it
 * is cleanest to do that here, all in one place.



 */

#define TclRegisterNewLiteral(envPtr, bytes, length) \
	TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0)

/*












 * Macro used to manually adjust the stack requirements; used
 * in cases where the stack effect cannot be computed from
 * the opcode and its operands, but is still known at

 * compile time.
 */

#define TclAdjustStackDepth(delta, envPtr) \
    if ((delta) < 0) {\
	if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
	    (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
	}\
    }\
    (envPtr)->currStackDepth += (delta)

/*
 * Macro used to update the stack requirements.
 * It is called by the macros TclEmitOpCode, TclEmitInst1 and
 * TclEmitInst4.
 * Remark that the very last instruction of a bytecode always
 * reduces the stack level: INST_DONE or INST_POP, so that the 
 * maxStackdepth is always updated.


 */

#define TclUpdateStackReqs(op, i, envPtr) \
    {\
	int delta = tclInstructionTable[(op)].stackEffect;\
	if (delta) {\
	    if (delta == INT_MIN) {\
		delta = 1 - (i);\
	    }\
            TclAdjustStackDepth(delta, envPtr);\
        }\
    }

/*
 * Macro to emit an opcode byte into a CompileEnv's code array.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclEmitOpcode _ANSI_ARGS_((unsigned char op,
 *		    CompileEnv *envPtr));
 */

#define TclEmitOpcode(op, envPtr) \
    if ((envPtr)->codeNext == (envPtr)->codeEnd) \
	TclExpandCodeArray(envPtr); \
    *(envPtr)->codeNext++ = (unsigned char) (op);\
    TclUpdateStackReqs(op, 0, envPtr)

/*
 * Macros to emit an integer operand.
 * The ANSI C "prototype" for these macros are:
 *
 * MODULE_SCOPE void	TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr));
 * MODULE_SCOPE void	TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr));
 */

#define TclEmitInt1(i, envPtr) \
    if ((envPtr)->codeNext == (envPtr)->codeEnd) \
	TclExpandCodeArray(envPtr); \
    *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))








|
<



















|
>

|










|
|


|


|
|



>
>
>

|
<
|
>
>
>



|


>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
>
|











|
|
<
|
|
|
>
>









|
|



|
|

<
|









|
|

|
|







770
771
772
773
774
775
776
777

778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827

828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867

868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889

890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
MODULE_SCOPE void	TclFreeJumpFixupArray _ANSI_ARGS_((
  			    JumpFixupArray *fixupArrayPtr));
MODULE_SCOPE void	TclInitAuxDataTypeTable _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CompileEnv *envPtr));
MODULE_SCOPE void	TclInitCompilation _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
			    CompileEnv *envPtr, char *string, int numBytes));

MODULE_SCOPE void	TclInitJumpFixupArray _ANSI_ARGS_((
			    JumpFixupArray *fixupArrayPtr));
MODULE_SCOPE void	TclInitLiteralTable _ANSI_ARGS_((
			    LiteralTable *tablePtr));
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char *	TclLiteralStats _ANSI_ARGS_((
			    LiteralTable *tablePtr));
MODULE_SCOPE int	TclLog2 _ANSI_ARGS_((int value));
#endif
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
#endif
MODULE_SCOPE int	TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr,
			    unsigned char *pc));
MODULE_SCOPE void	TclPrintObject _ANSI_ARGS_((FILE *outFile,
			    Tcl_Obj *objPtr, int maxChars));
MODULE_SCOPE void	TclPrintSource _ANSI_ARGS_((FILE *outFile,
			    CONST char *string, int maxChars));
MODULE_SCOPE void	TclRegisterAuxDataType _ANSI_ARGS_((
			    AuxDataType *typePtr));
MODULE_SCOPE int	TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr,
			    char *bytes, int length, int flags));
MODULE_SCOPE void	TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
MODULE_SCOPE void	TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Command *cmdPtr));
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclVerifyGlobalLiteralTable _ANSI_ARGS_((
			    Interp *iPtr));
MODULE_SCOPE void	TclVerifyLocalLiteralTable _ANSI_ARGS_((
			    CompileEnv *envPtr));
#endif
MODULE_SCOPE int	TclCompileVariableCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, CompileEnv *envPtr));
MODULE_SCOPE int	TclWordKnownAtCompileTime _ANSI_ARGS_((
			    Tcl_Token *tokenPtr, Tcl_Obj *valuePtr));

/*
 *----------------------------------------------------------------
 * Macros and flag values used by Tcl bytecode compilation and execution
 * modules inside the Tcl core but not used outside.
 *----------------------------------------------------------------
 */

#define LITERAL_ON_HEAP    0x01
#define LITERAL_NS_SCOPE   0x02

/*
 * Form of TclRegisterLiteral with onHeap == 0. In that case, it is safe to

 * cast away CONSTness, and it is cleanest to do that here, all in one place.
 *
 * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes,
 *			     int length);
 */

#define TclRegisterNewLiteral(envPtr, bytes, length) \
	TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0)

/*
 * Form of TclRegisterNSLiteral with onHeap == 0.  In that case, it is safe to
 * cast away CONSTness, and it is cleanest to do that here, all in one place.
 *
 * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes,
 *			       int length);
 */

#define TclRegisterNewNSLiteral(envPtr, bytes, length) \
	TclRegisterLiteral(envPtr, (char *)(bytes), length, \
		/*flags*/ LITERAL_NS_SCOPE)

/*
 * Macro used to manually adjust the stack requirements; used in cases where
 * the stack effect cannot be computed from the opcode and its operands, but
 * is still known at compile time.
 *
 * void TclAdjustStackDepth(int delta, CompileEnv *envPtr);
 */

#define TclAdjustStackDepth(delta, envPtr) \
    if ((delta) < 0) {\
	if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
	    (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
	}\
    }\
    (envPtr)->currStackDepth += (delta)

/*
 * Macro used to update the stack requirements.  It is called by the macros
 * TclEmitOpCode, TclEmitInst1 and TclEmitInst4.

 * Remark that the very last instruction of a bytecode always reduces the
 * stack level: INST_DONE or INST_POP, so that the maxStackdepth is always
 * updated.
 *
 * void TclUpdateStackReqs(unsigned char op, int i, CompileEnv *envPtr);
 */

#define TclUpdateStackReqs(op, i, envPtr) \
    {\
	int delta = tclInstructionTable[(op)].stackEffect;\
	if (delta) {\
	    if (delta == INT_MIN) {\
		delta = 1 - (i);\
	    }\
	    TclAdjustStackDepth(delta, envPtr);\
	}\
    }

/*
 * Macro to emit an opcode byte into a CompileEnv's code array.  The ANSI C
 * "prototype" for this macro is:
 *

 * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr);
 */

#define TclEmitOpcode(op, envPtr) \
    if ((envPtr)->codeNext == (envPtr)->codeEnd) \
	TclExpandCodeArray(envPtr); \
    *(envPtr)->codeNext++ = (unsigned char) (op);\
    TclUpdateStackReqs(op, 0, envPtr)

/*
 * Macros to emit an integer operand.  The ANSI C "prototype" for these macros
 * are:
 *
 * void TclEmitInt1(int i, CompileEnv *envPtr);
 * void TclEmitInt4(int i, CompileEnv *envPtr);
 */

#define TclEmitInt1(i, envPtr) \
    if ((envPtr)->codeNext == (envPtr)->codeEnd) \
	TclExpandCodeArray(envPtr); \
    *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))

940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
	(unsigned char) ((unsigned int) (i) >>  8); \
    *(envPtr)->codeNext++ = \
	(unsigned char) ((unsigned int) (i)      )

/*
 * Macros to emit an instruction with signed or unsigned integer operands.
 * Four byte integers are stored in "big-endian" order with the high order
 * byte stored at the lowest address.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i, 
 *		    CompileEnv *envPtr));
 * MODULE_SCOPE void	TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i, 
 *		    CompileEnv *envPtr));
 */


#define TclEmitInstInt1(op, i, envPtr) \
    if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
	TclExpandCodeArray(envPtr); \
    } \
    *(envPtr)->codeNext++ = (unsigned char) (op); \
    *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\







|
|

<
|
<
|

<







921
922
923
924
925
926
927
928
929
930

931

932
933

934
935
936
937
938
939
940
	(unsigned char) ((unsigned int) (i) >>  8); \
    *(envPtr)->codeNext++ = \
	(unsigned char) ((unsigned int) (i)      )

/*
 * Macros to emit an instruction with signed or unsigned integer operands.
 * Four byte integers are stored in "big-endian" order with the high order
 * byte stored at the lowest address.  The ANSI C "prototypes" for these
 * macros are:
 *

 * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr);

 * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr);
 */


#define TclEmitInstInt1(op, i, envPtr) \
    if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
	TclExpandCodeArray(envPtr); \
    } \
    *(envPtr)->codeNext++ = (unsigned char) (op); \
    *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
	(unsigned char) ((unsigned int) (i) >>  8); \
    *(envPtr)->codeNext++ = \
	(unsigned char) ((unsigned int) (i)      );\
    TclUpdateStackReqs(op, i, envPtr)

/*
 * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
 * object's one or four byte array index into the CompileEnv's code
 * array. These support, respectively, a maximum of 256 (2**8) and 2**32
 * objects in a CompileEnv. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
 */

#define TclEmitPush(objIndex, envPtr) \
    {\
	register int objIndexCopy = (objIndex);\
	if (objIndexCopy <= 255) { \
	    TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
	} else { \
	    TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
	}\
    }

/*
 * Macros to update a (signed or unsigned) integer starting at a pointer.
 * The two variants depend on the number of bytes. The ANSI C "prototypes"
 * for these macros are:
 *
 * MODULE_SCOPE void	TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p));
 * MODULE_SCOPE void	TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p));
 */

#define TclStoreInt1AtPtr(i, p) \
    *(p)   = (unsigned char) ((unsigned int) (i))

#define TclStoreInt4AtPtr(i, p) \
    *(p)   = (unsigned char) ((unsigned int) (i) >> 24); \
    *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
    *(p+2) = (unsigned char) ((unsigned int) (i) >>  8); \
    *(p+3) = (unsigned char) ((unsigned int) (i)      )

/*
 * Macros to update instructions at a particular pc with a new op code
 * and a (signed or unsigned) int operand. The ANSI C "prototypes" for
 * these macros are:
 *
 * MODULE_SCOPE void	TclUpdateInstInt1AtPc _ANSI_ARGS_((unsigned char op, int i,
 *		    unsigned char *pc));
 * MODULE_SCOPE void	TclUpdateInstInt4AtPc _ANSI_ARGS_((unsigned char op, int i,
 *		    unsigned char *pc));
 */

#define TclUpdateInstInt1AtPc(op, i, pc) \
    *(pc) = (unsigned char) (op); \
    TclStoreInt1AtPtr((i), ((pc)+1))

#define TclUpdateInstInt4AtPc(op, i, pc) \
    *(pc) = (unsigned char) (op); \
    TclStoreInt4AtPtr((i), ((pc)+1))

/*
 * Macro to fix up a forward jump to point to the current
 * code-generation position in the bytecode being created (the most
 * common case). The ANSI C "prototypes" for this macro is:
 *
 * MODULE_SCOPE int	TclFixupForwardJumpToHere _ANSI_ARGS_((CompileEnv *envPtr,
 *		    JumpFixup *fixupPtr, int threshold));
 */

#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \
    TclFixupForwardJump((envPtr), (fixupPtr), \
	    (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \
	    (threshold))

/*
 * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int
 * (GET_UINT{1,2}) from a pointer. There are two variants for each
 * return type that depend on the number of bytes fetched.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE int		TclGetInt1AtPtr  _ANSI_ARGS_((unsigned char *p));
 * MODULE_SCOPE int		TclGetInt4AtPtr  _ANSI_ARGS_((unsigned char *p));
 * MODULE_SCOPE unsigned int	TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p));
 * MODULE_SCOPE unsigned int	TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p));
 */

/*
 * The TclGetInt1AtPtr macro is tricky because we want to do sign
 * extension on the 1-byte value. Unfortunately the "char" type isn't
 * signed on all platforms so sign-extension doesn't always happen
 * automatically. Sometimes we can explicitly declare the pointer to be
 * signed, but other times we have to explicitly sign-extend the value
 * in software.
 */

#ifndef __CHAR_UNSIGNED__
#   define TclGetInt1AtPtr(p) ((int) *((char *) p))
#else
#   ifdef HAVE_SIGNED_CHAR
#	define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#    else
#	define TclGetInt1AtPtr(p) (((int) *((char *) p)) \
		| ((*(p) & 0200) ? (-256) : 0))
#    endif
#endif

#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \
					    (*((p)+1) << 16) | \
				  	    (*((p)+2) <<  8) | \
				  	    (*((p)+3)))

#define TclGetUInt1AtPtr(p) ((unsigned int) *(p))
#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p)     << 24) | \
					    (*((p)+1) << 16) | \
					    (*((p)+2) <<  8) | \
					    (*((p)+3)))

/*
 * Macros used to compute the minimum and maximum of two integers.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE int  TclMin _ANSI_ARGS_((int i, int j));
 * MODULE_SCOPE int  TclMax _ANSI_ARGS_((int i, int j));
 */

#define TclMin(i, j)   ((((int) i) < ((int) j))? (i) : (j))
#define TclMax(i, j)   ((((int) i) > ((int) j))? (i) : (j))

#endif /* _TCLCOMPILATION */







|
|
|

|













|
|
|

|
|












|
|
|

<
|
<
|











|
|
|

|
|









|
|
|

|
|
|
|



|
|
|
|
|
<







|


|














|
|

|
|






953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999

1000

1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043

1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
	(unsigned char) ((unsigned int) (i) >>  8); \
    *(envPtr)->codeNext++ = \
	(unsigned char) ((unsigned int) (i)      );\
    TclUpdateStackReqs(op, i, envPtr)

/*
 * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
 * object's one or four byte array index into the CompileEnv's code array.
 * These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a
 * CompileEnv. The ANSI C "prototype" for this macro is:
 *
 * void	TclEmitPush(int objIndex, CompileEnv *envPtr);
 */

#define TclEmitPush(objIndex, envPtr) \
    {\
	register int objIndexCopy = (objIndex);\
	if (objIndexCopy <= 255) { \
	    TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
	} else { \
	    TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
	}\
    }

/*
 * Macros to update a (signed or unsigned) integer starting at a pointer.  The
 * two variants depend on the number of bytes. The ANSI C "prototypes" for
 * these macros are:
 *
 * void TclStoreInt1AtPtr(int i, unsigned char *p);
 * void TclStoreInt4AtPtr(int i, unsigned char *p);
 */

#define TclStoreInt1AtPtr(i, p) \
    *(p)   = (unsigned char) ((unsigned int) (i))

#define TclStoreInt4AtPtr(i, p) \
    *(p)   = (unsigned char) ((unsigned int) (i) >> 24); \
    *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
    *(p+2) = (unsigned char) ((unsigned int) (i) >>  8); \
    *(p+3) = (unsigned char) ((unsigned int) (i)      )

/*
 * Macros to update instructions at a particular pc with a new op code and a
 * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros
 * are:
 *

 * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc);

 * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc);
 */

#define TclUpdateInstInt1AtPc(op, i, pc) \
    *(pc) = (unsigned char) (op); \
    TclStoreInt1AtPtr((i), ((pc)+1))

#define TclUpdateInstInt4AtPc(op, i, pc) \
    *(pc) = (unsigned char) (op); \
    TclStoreInt4AtPtr((i), ((pc)+1))

/*
 * Macro to fix up a forward jump to point to the current code-generation
 * position in the bytecode being created (the most common case). The ANSI C
 * "prototypes" for this macro is:
 *
 * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr,
 *				 int threshold);
 */

#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \
    TclFixupForwardJump((envPtr), (fixupPtr), \
	    (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \
	    (threshold))

/*
 * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int
 * (GET_UINT{1,2}) from a pointer. There are two variants for each return type
 * that depend on the number of bytes fetched.  The ANSI C "prototypes" for
 * these macros are:
 *
 * int TclGetInt1AtPtr(unsigned char *p);
 * int TclGetInt4AtPtr(unsigned char *p);
 * unsigned int TclGetUInt1AtPtr(unsigned char *p);
 * unsigned int TclGetUInt4AtPtr(unsigned char *p);
 */

/*
 * The TclGetInt1AtPtr macro is tricky because we want to do sign extension on
 * the 1-byte value. Unfortunately the "char" type isn't signed on all
 * platforms so sign-extension doesn't always happen automatically. Sometimes
 * we can explicitly declare the pointer to be signed, but other times we have
 * to explicitly sign-extend the value in software.

 */

#ifndef __CHAR_UNSIGNED__
#   define TclGetInt1AtPtr(p) ((int) *((char *) p))
#else
#   ifdef HAVE_SIGNED_CHAR
#	define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
#   else
#	define TclGetInt1AtPtr(p) (((int) *((char *) p)) \
		| ((*(p) & 0200) ? (-256) : 0))
#   endif
#endif

#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \
					    (*((p)+1) << 16) | \
				  	    (*((p)+2) <<  8) | \
				  	    (*((p)+3)))

#define TclGetUInt1AtPtr(p) ((unsigned int) *(p))
#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p)     << 24) | \
					    (*((p)+1) << 16) | \
					    (*((p)+2) <<  8) | \
					    (*((p)+3)))

/*
 * Macros used to compute the minimum and maximum of two integers.  The ANSI C
 * "prototypes" for these macros are:
 *
 * int TclMin(int i, int j);
 * int TclMax(int i, int j);
 */

#define TclMin(i, j)   ((((int) i) < ((int) j))? (i) : (j))
#define TclMax(i, j)   ((((int) i) > ((int) j))? (i) : (j))

#endif /* _TCLCOMPILATION */

Changes to generic/tclConfig.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85


























86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124
125
126
127
128
129
130

131

132
133
134
135
136
137
138
139
140
141
142
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
/* 
 * tclConfig.c --
 *
 *	This file provides the facilities which allow Tcl and other packages
 *	to embed configuration information into their binary libraries.
 *
 * Copyright (c) 2002 Andreas Kupries <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclConfig.c,v 1.6 2004/10/29 15:39:05 dkf Exp $
 */

#include "tclInt.h"



/*
 * Internal structure to hold embedded configuration information.
 *
 * Our structure is a two-level dictionary associated with the
 * 'interp'. The first level is keyed with the package name and maps
 * to the dictionary for that package. The package dictionary is keyed
 * with metadata keys and maps to the metadata value for that
 * key. This is package specific. The metadata values are in UTF8,
 * converted from the external representation given to us by the
 * caller.
 */

#define ASSOC_KEY "tclPackageAboutDict"

/*
 * Static functions in this file:
 */

static int
QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));

static void
QueryConfigDelete _ANSI_ARGS_((ClientData clientData));

static Tcl_Obj*
GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp));

static void
ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegisterConfig --
 *
 *	See TIP#59 for details on what this procedure does.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates namespace and cfg query command in it as per TIP #59.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding)
     Tcl_Interp* interp;            /* Interpreter the configuration
				     * command is registered in. */
     CONST char* pkgName;           /* Name of the package registering
				     * the embedded configuration. ASCII,
				     * thus in UTF-8 too. */
     Tcl_Config* configuration;     /* Embedded configuration */
     CONST char* valEncoding;       /* Name of the encoding used to
				     * store the configuration values,
				     * ASCII, thus UTF-8 */
{
    Tcl_Encoding venc = Tcl_GetEncoding (NULL, valEncoding);
    Tcl_Obj*     pDB  = GetConfigDict (interp);
    Tcl_Obj*     pkg  = Tcl_NewStringObj (pkgName, -1);
    Tcl_Obj*     pkgDict;
    Tcl_DString  cmdName;
    Tcl_Config*  cfg;
    int          res;



























    /*
     * Phase I: Adding the provided information to the internal
     * database of package meta data.
     *
     * Phase II: Create a command for querying this database, specific
     * to the package registerting its configuration. This is the
     * approved interface in TIP 59. In the future a more general
     * interface should be done, as followup to TIP 59. Simply because
     * our database is now general across packages, and not a
     * structure tied to one package.
     */

    /* Note, the created command will have a reference through its clientdata */
    Tcl_IncrRefCount (pkg);

    /* Retrieve package specific configuration ... */

    res = Tcl_DictObjGet (interp, pDB, pkg, &pkgDict);
    if ((TCL_OK != res) || (pkgDict == NULL)) {
        pkgDict = Tcl_NewDictObj ();
    } else if (Tcl_IsShared (pkgDict)) {
        pkgDict = Tcl_DuplicateObj (pkgDict);
    }

    /* Extend the package configuration ... */

    for (cfg = configuration;
	 (cfg->key != (CONST char*) NULL) && (cfg->key [0] != '\0') ;
	 cfg++) {

        Tcl_DString conv;

	CONST char* convValue = Tcl_ExternalToUtfDString (venc, cfg->value, -1, &conv);

	/*
	 * We know that the keys are in ASCII/UTF-8, so for them is no
	 * conversion required.
	 */

	Tcl_DictObjPut (interp, pkgDict,
			Tcl_NewStringObj (cfg->key, -1),
			Tcl_NewStringObj (convValue, -1));
	Tcl_DStringFree (&conv);
    }


    /* Write the changes back into the overall database */


    Tcl_DictObjPut (interp, pDB, pkg, pkgDict);

    /*
     * Now create the interface command for retrieval of the package
     * information.
     */

    Tcl_DStringInit   (&cmdName);
    Tcl_DStringAppend (&cmdName, "::",          -1);   
    Tcl_DStringAppend (&cmdName, pkgName,       -1);   


    /* The incomplete command name is the name of the namespace to
     * place it in.
     */

    if ((Tcl_Namespace*) NULL == Tcl_FindNamespace(interp,
		Tcl_DStringValue (&cmdName), NULL, TCL_GLOBAL_ONLY)) {

	if ((Tcl_Namespace*) NULL == Tcl_CreateNamespace (interp,
			  Tcl_DStringValue (&cmdName), (ClientData) NULL,
			  (Tcl_NamespaceDeleteProc *) NULL)) {

	    Tcl_Panic ("%s.\n%s %s", Tcl_GetStringResult(interp),
		    "Tcl_RegisterConfig: Unable to create namespace for",
		    "package configuration.");
	}
    }

    Tcl_DStringAppend (&cmdName, "::pkgconfig", -1);   

    if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp,
		    Tcl_DStringValue (&cmdName), QueryConfigObjCmd,
		    (ClientData) pkg, QueryConfigDelete)) {

        Tcl_Panic ("%s %s", "Tcl_RegisterConfig: Unable to create query",
		"command for package configuration");
    }

    Tcl_DStringFree (&cmdName);
}

/*
 *----------------------------------------------------------------------
 *
 * QueryConfigObjCmd --
 *
|







|
|

|









|
|
|
<
|
|
|








<
|
|
|
<
|
<
<
|
<
<
|
|






|











|
|
|
|
|
|
|
|
|
<

|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


<
<
<
<
|
<
<
<
<


<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

>
|






|
|
<
|


>
|
>

|






|
|
|

>
|
|


|
|
|
<
<
|
<
|





|

|
<
|
<
|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
35

36
37
38

39


40


41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105




106




107
108


109















110
111
112
113
114
115
116
117
118
119
120

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146


147

148
149
150
151
152
153
154
155
156

157

158
159
160
161
162
163
164
165
166
167
168
169
/*
 * tclConfig.c --
 *
 *	This file provides the facilities which allow Tcl and other packages
 *	to embed configuration information into their binary libraries.
 *
 * Copyright (c) 2002 Andreas Kupries <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclConfig.c,v 1.6.2.2 2005/08/02 18:15:22 dgp Exp $
 */

#include "tclInt.h"



/*
 * Internal structure to hold embedded configuration information.
 *
 * Our structure is a two-level dictionary associated with the 'interp'. The
 * first level is keyed with the package name and maps to the dictionary for
 * that package. The package dictionary is keyed with metadata keys and maps

 * to the metadata value for that key. This is package specific. The metadata
 * values are in UTF-8, converted from the external representation given to us
 * by the caller.
 */

#define ASSOC_KEY "tclPackageAboutDict"

/*
 * Static functions in this file:
 */


static int		QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    struct Tcl_Obj * CONST * objv));

static void		QueryConfigDelete _ANSI_ARGS_((ClientData clientData));


static Tcl_Obj *	GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp));


static void		ConfigDictDeleteProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegisterConfig --
 *
 *	See TIP#59 for details on what this function does.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates namespace and cfg query command in it as per TIP #59.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding)
    Tcl_Interp *interp;		/* Interpreter the configuration command is
				 * registered in. */
    CONST char *pkgName;	/* Name of the package registering the
				 * embedded configuration. ASCII, thus in
				 * UTF-8 too. */
    Tcl_Config *configuration;	/* Embedded configuration. */
    CONST char *valEncoding;	/* Name of the encoding used to store the
				 * configuration values, ASCII, thus UTF-8. */

{
    Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
    Tcl_Obj *pDB  = GetConfigDict(interp);
    Tcl_Obj *pkg  = Tcl_NewStringObj(pkgName, -1);
    Tcl_Obj *pkgDict;
    Tcl_DString cmdName;
    Tcl_Config *cfg;
    int res;

    /*
     * Phase I: Adding the provided information to the internal database of
     * package meta data.
     *
     * Phase II: Create a command for querying this database, specific to the
     * package registerting its configuration. This is the approved interface
     * in TIP 59. In the future a more general interface should be done, as
     * followup to TIP 59. Simply because our database is now general across
     * packages, and not a structure tied to one package.
     *
     * Note, the created command will have a reference through its clientdata.
     */

    Tcl_IncrRefCount(pkg);

    /*
     * Retrieve package specific configuration...
     */

    res = Tcl_DictObjGet(interp, pDB, pkg, &pkgDict);
    if ((TCL_OK != res) || (pkgDict == NULL)) {
        pkgDict = Tcl_NewDictObj();
    } else if (Tcl_IsShared(pkgDict)) {
        pkgDict = Tcl_DuplicateObj(pkgDict);
    }

    /*




     * Extend the package configuration...




     */



    for (cfg=configuration ; (cfg->key!=NULL) && (cfg->key[0]!='\0') ; cfg++) {















        Tcl_DString conv;
	CONST char *convValue =
		Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);

	/*
	 * We know that the keys are in ASCII/UTF-8, so for them is no
	 * conversion required.
	 */

	Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
		Tcl_NewStringObj(convValue, -1));

	Tcl_DStringFree(&conv);
    }

    /*
     * Write the changes back into the overall database.
     */

    Tcl_DictObjPut(interp, pDB, pkg, pkgDict);

    /*
     * Now create the interface command for retrieval of the package
     * information.
     */

    Tcl_DStringInit(&cmdName);
    Tcl_DStringAppend(&cmdName, "::", -1);
    Tcl_DStringAppend(&cmdName, pkgName, -1);

    /*
     * The incomplete command name is the name of the namespace to place it
     * in.
     */

    if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
	    TCL_GLOBAL_ONLY) == NULL) {
	if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),


		(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL) == NULL) {

	    Tcl_Panic("%s.\n%s %s", Tcl_GetStringResult(interp),
		    "Tcl_RegisterConfig: Unable to create namespace for",
		    "package configuration.");
	}
    }

    Tcl_DStringAppend(&cmdName, "::pkgconfig", -1);

    if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),

	    QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) {

        Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query",
		"command for package configuration");
    }

    Tcl_DStringFree(&cmdName);
}

/*
 *----------------------------------------------------------------------
 *
 * QueryConfigObjCmd --
 *
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222

223



224
225
226
227
228
229
230
 *	See the manual for what this command does.
 *
 *----------------------------------------------------------------------
 */

static int
QueryConfigObjCmd(clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     struct Tcl_Obj * CONST *objv;
{
    Tcl_Obj *pkgName = (Tcl_Obj*) clientData;
    Tcl_Obj *pDB, *pkgDict, *val;
    Tcl_DictSearch s;
    int n, i, res, done, index;
    Tcl_Obj *key, **vals;

    static CONST char *subcmdStrings[] = {
	"get", "list", NULL
    };
    enum subcmds {
	CFG_GET, CFG_LIST
    };

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings,
	   "subcommand", 0, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    pDB = GetConfigDict(interp);
    res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict);
    if (res!=TCL_OK || pkgDict==NULL) {

        /* Maybe a Tcl_Panic is better, because the package data has to be present */



        Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
	return TCL_ERROR;
    }

    switch ((enum subcmds) index) {
    case CFG_GET:
	if (objc != 3) {







|
|
|
|

|
|
<
|
<












|
|






>
|
>
>
>







177
178
179
180
181
182
183
184
185
186
187
188
189
190

191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
 *	See the manual for what this command does.
 *
 *----------------------------------------------------------------------
 */

static int
QueryConfigObjCmd(clientData, interp, objc, objv)
    ClientData clientData;
    Tcl_Interp *interp;
    int objc;
    struct Tcl_Obj * CONST *objv;
{
    Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
    Tcl_Obj *pDB, *pkgDict, *val, *listPtr;

    int n, i, res, index;


    static CONST char *subcmdStrings[] = {
	"get", "list", NULL
    };
    enum subcmds {
	CFG_GET, CFG_LIST
    };

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    pDB = GetConfigDict(interp);
    res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict);
    if (res!=TCL_OK || pkgDict==NULL) {
        /*
	 * Maybe a Tcl_Panic is better, because the package data has to be
	 * present.
	 */

        Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
	return TCL_ERROR;
    }

    switch ((enum subcmds) index) {
    case CFG_GET:
	if (objc != 3) {
244
245
246
247
248
249
250

251

252

253
254
255






256


257
258
259
260

261
262

263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356








    case CFG_LIST:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 1, objv, "list");
	    return TCL_ERROR;
	}

	Tcl_DictObjSize(interp, pkgDict, &n);

	if (n == 0) {

	    Tcl_SetObjResult(interp, Tcl_NewListObj(0, NULL));

	    return TCL_OK;
	}







	vals = (Tcl_Obj**) ckalloc(n * sizeof(Tcl_Obj*));



	for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
		!done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) {
	    vals[i] = key;

	}


	Tcl_SetObjResult(interp, TclNewListObjDirect(n, vals));
	return TCL_OK;

    default:
	Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
	break;
    }
    return TCL_ERROR;
}

/*
 *-------------------------------------------------------------------------
 *
 * QueryConfigDelete --
 *
 *	Command delete procedure. Cleans up after the configuration query
 *	command when it is deleted by the user or during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates all non-transient memory allocated by Tcl_RegisterConfig.
 *
 *-------------------------------------------------------------------------
 */

static void
QueryConfigDelete (clientData)
     ClientData clientData;
{
    Tcl_Obj*          pkgName = (Tcl_Obj*) clientData;
    Tcl_DecrRefCount (pkgName);
}

/*
 *-------------------------------------------------------------------------
 *
 * GetConfigDict --
 *
 *	Retrieve the package metadata database from the interpreter.
 *	Initializes it, if not present yet.
 *
 * Results:
 *	A Tcl_Obj reference
 *
 * Side effects:
 *	May allocate a Tcl_Obj.
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Obj*
GetConfigDict (interp)
     Tcl_Interp* interp;
{
  Tcl_Obj* pDB = Tcl_GetAssocData (interp, ASSOC_KEY, NULL);

  if (pDB == (Tcl_Obj*) NULL) {
      pDB = Tcl_NewDictObj ();
      Tcl_IncrRefCount (pDB);
      Tcl_SetAssocData (interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
  }

  return pDB;
}

/*
 *----------------------------------------------------------------------
 *
 * ConfigDictDeleteProc --
 *
 *	This procedure is associated with the "Package About dict" assoc data
 *	for an interpreter;  it is invoked when the interpreter is
 *	deleted in order to free the information assoicated with any
 *	pending error reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The package metadata database is freed.
 *
 *----------------------------------------------------------------------
 */

static void
ConfigDictDeleteProc(clientData, interp)
    ClientData clientData;	/* Pointer to Tcl_Obj. */
    Tcl_Interp *interp;		/* Interpreter being deleted. */
{
    Tcl_Obj* pDB = (Tcl_Obj*) clientData;
    Tcl_DecrRefCount (pDB);
}















>
|
>
|
>
|


>
>
>
>
>
>
|
>
>

|
|
|
>
|
|
>
|














|












|
|

|
|



















|
|
|

|

|
|
|
|
|

|







|
|
|
|















|
|

>
>
>
>
>
>
>
>
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
    case CFG_LIST:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 1, objv, "list");
	    return TCL_ERROR;
	}

	Tcl_DictObjSize(interp, pkgDict, &n);
	listPtr = Tcl_NewListObj(n, NULL);

	if (!listPtr) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("insufficient memory to create list",-1));
	    return TCL_ERROR;
	}

	if (n) {
	    List *listRepPtr = (List *)
		    listPtr->internalRep.twoPtrValue.ptr1;
	    Tcl_DictSearch s;
	    Tcl_Obj *key, **vals;
	    int done;

	    listRepPtr->elemCount = n;
	    vals = &listRepPtr->elements;

	    for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
		    !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) {
		vals[i] = key;
		Tcl_IncrRefCount(key);
	    }
	}

	Tcl_SetObjResult(interp, listPtr);
	return TCL_OK;

    default:
	Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
	break;
    }
    return TCL_ERROR;
}

/*
 *-------------------------------------------------------------------------
 *
 * QueryConfigDelete --
 *
 *	Command delete function. Cleans up after the configuration query
 *	command when it is deleted by the user or during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates all non-transient memory allocated by Tcl_RegisterConfig.
 *
 *-------------------------------------------------------------------------
 */

static void
QueryConfigDelete(clientData)
    ClientData clientData;
{
    Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
    Tcl_DecrRefCount(pkgName);
}

/*
 *-------------------------------------------------------------------------
 *
 * GetConfigDict --
 *
 *	Retrieve the package metadata database from the interpreter.
 *	Initializes it, if not present yet.
 *
 * Results:
 *	A Tcl_Obj reference
 *
 * Side effects:
 *	May allocate a Tcl_Obj.
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
GetConfigDict(interp)
    Tcl_Interp *interp;
{
    Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);

    if (pDB == (Tcl_Obj *) NULL) {
	pDB = Tcl_NewDictObj();
	Tcl_IncrRefCount(pDB);
	Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
    }

    return pDB;
}

/*
 *----------------------------------------------------------------------
 *
 * ConfigDictDeleteProc --
 *
 *	This function is associated with the "Package About dict" assoc data
 *	for an interpreter; it is invoked when the interpreter is deleted in
 *	order to free the information assoicated with any pending error
 *	reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The package metadata database is freed.
 *
 *----------------------------------------------------------------------
 */

static void
ConfigDictDeleteProc(clientData, interp)
    ClientData clientData;	/* Pointer to Tcl_Obj. */
    Tcl_Interp *interp;		/* Interpreter being deleted. */
{
    Tcl_Obj *pDB = (Tcl_Obj *) clientData;
    Tcl_DecrRefCount(pDB);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclDate.c.

1
2
3
4
5
6
7
8
9
10
11
/* A Bison parser, made by GNU Bison 1.875.  */

/* Skeleton parser for Yacc-like parsing with Bison,
   Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002 Free Software Foundation, Inc.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   This program is distributed in the hope that it will be useful,
|


|







1
2
3
4
5
6
7
8
9
10
11
/* A Bison parser, made by GNU Bison 1.875b.  */

/* Skeleton parser for Yacc-like parsing with Bison,
   Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   This program is distributed in the hope that it will be useful,
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
#define tDAY_UNIT 274
#define tNEXT 275




/* Copy the first part of user declarations.  */
#line 17 "../unix/../generic/tclGetDate.y"

/* 
 * tclDate.c --
 *
 *	This file is generated from a yacc grammar defined in
 *	the file tclGetDate.y.  It should not be edited directly.
 *







|







101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
#define tDAY_UNIT 274
#define tNEXT 275




/* Copy the first part of user declarations.  */


/* 
 * tclDate.c --
 *
 *	This file is generated from a yacc grammar defined in
 *	the file tclGetDate.y.  It should not be edited directly.
 *
165
166
167
168
169
170
171


172
173
174
175
176
177
178
    time_t   dateDayOrdinal;
    time_t   dateDayNumber;
    int      dateHaveDay;

    char     *dateInput;
    time_t   *dateRelPointer;



} DateInfo;

#define YYPARSE_PARAM info
#define YYLEX_PARAM info

#define yyDSTmode (((DateInfo*)info)->dateDSTmode)
#define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal)







>
>







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
    time_t   dateDayOrdinal;
    time_t   dateDayNumber;
    int      dateHaveDay;

    char     *dateInput;
    time_t   *dateRelPointer;

    int	     dateDigitCount;

} DateInfo;

#define YYPARSE_PARAM info
#define YYLEX_PARAM info

#define yyDSTmode (((DateInfo*)info)->dateDSTmode)
#define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal)
193
194
195
196
197
198
199

200
201
202
203
204
205
206
#define yySeconds (((DateInfo*)info)->dateSeconds)
#define yyMeridian (((DateInfo*)info)->dateMeridian)
#define yyRelMonth (((DateInfo*)info)->dateRelMonth)
#define yyRelDay (((DateInfo*)info)->dateRelDay)
#define yyRelSeconds (((DateInfo*)info)->dateRelSeconds)
#define yyRelPointer (((DateInfo*)info)->dateRelPointer)
#define yyInput (((DateInfo*)info)->dateInput)


#define EPOCH           1970
#define START_OF_TIME   1902
#define END_OF_TIME     2037

/*
 * The offset of tm_year of struct tm returned by localtime, gmtime, etc.







>







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
#define yySeconds (((DateInfo*)info)->dateSeconds)
#define yyMeridian (((DateInfo*)info)->dateMeridian)
#define yyRelMonth (((DateInfo*)info)->dateRelMonth)
#define yyRelDay (((DateInfo*)info)->dateRelDay)
#define yyRelSeconds (((DateInfo*)info)->dateRelSeconds)
#define yyRelPointer (((DateInfo*)info)->dateRelPointer)
#define yyInput (((DateInfo*)info)->dateInput)
#define yyDigitCount (((DateInfo*)info)->dateDigitCount)

#define EPOCH           1970
#define START_OF_TIME   1902
#define END_OF_TIME     2037

/*
 * The offset of tm_year of struct tm returned by localtime, gmtime, etc.
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
# undef YYERROR_VERBOSE
# define YYERROR_VERBOSE 1
#else
# define YYERROR_VERBOSE 0
#endif

#if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED)
#line 160 "../unix/../generic/tclGetDate.y"
typedef union YYSTYPE {
    time_t              Number;
    enum _MERIDIAN      Meridian;
} YYSTYPE;
/* Line 191 of yacc.c.  */
#line 272 "../unix/../generic/tclDate.c"
# define yystype YYSTYPE /* obsolescent; will be withdrawn */
# define YYSTYPE_IS_DECLARED 1
# define YYSTYPE_IS_TRIVIAL 1
#endif



/* Copy the second part of user declarations.  */


/* Line 214 of yacc.c.  */
#line 284 "../unix/../generic/tclDate.c"

#if ! defined (yyoverflow) || YYERROR_VERBOSE

/* The parser invokes alloca or malloc; define the necessary symbols.  */

# if YYSTACK_USE_ALLOCA
#  define YYSTACK_ALLOC alloca







|





|











|







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
# undef YYERROR_VERBOSE
# define YYERROR_VERBOSE 1
#else
# define YYERROR_VERBOSE 0
#endif

#if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED)

typedef union YYSTYPE {
    time_t              Number;
    enum _MERIDIAN      Meridian;
} YYSTYPE;
/* Line 191 of yacc.c.  */

# define yystype YYSTYPE /* obsolescent; will be withdrawn */
# define YYSTYPE_IS_DECLARED 1
# define YYSTYPE_IS_TRIVIAL 1
#endif



/* Copy the second part of user declarations.  */


/* Line 214 of yacc.c.  */


#if ! defined (yyoverflow) || YYERROR_VERBOSE

/* The parser invokes alloca or malloc; define the necessary symbols.  */

# if YYSTACK_USE_ALLOCA
#  define YYSTACK_ALLOC alloca
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
      14,    40,    -1,    40,    -1,    22,    -1,    26,    -1,    12,
      -1,    19,    -1,    10,    -1,    14,    -1,    -1,     7,    -1
};

/* YYRLINE[YYN] -- source line where rule number YYN was defined.  */
static const unsigned short yyrline[] =
{
       0,   176,   176,   177,   180,   183,   186,   189,   192,   195,
     198,   202,   207,   210,   216,   222,   230,   236,   247,   251,
     255,   261,   265,   269,   273,   277,   283,   287,   292,   297,
     302,   307,   311,   316,   320,   325,   332,   336,   342,   351,
     360,   370,   383,   388,   390,   391,   392,   393,   394,   396,
     397,   399,   400,   401,   404,   423,   426
};
#endif

#if YYDEBUG || YYERROR_VERBOSE
/* YYTNME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
   First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =







|
|
|
|
|
|







469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
      14,    40,    -1,    40,    -1,    22,    -1,    26,    -1,    12,
      -1,    19,    -1,    10,    -1,    14,    -1,    -1,     7,    -1
};

/* YYRLINE[YYN] -- source line where rule number YYN was defined.  */
static const unsigned short yyrline[] =
{
       0,   179,   179,   180,   183,   186,   189,   192,   195,   198,
     201,   205,   210,   213,   219,   225,   233,   239,   250,   254,
     258,   264,   268,   272,   276,   280,   286,   290,   295,   300,
     305,   310,   314,   319,   323,   328,   335,   339,   345,   354,
     363,   373,   386,   391,   393,   394,   395,   396,   397,   399,
     400,   402,   403,   404,   407,   426,   429
};
#endif

#if YYDEBUG || YYERROR_VERBOSE
/* YYTNME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
   First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
637
638
639
640
641
642
643

644
645
646
647
648
649
650
#define yyclearin	(yychar = YYEMPTY)
#define YYEMPTY		(-2)
#define YYEOF		0

#define YYACCEPT	goto yyacceptlab
#define YYABORT		goto yyabortlab
#define YYERROR		goto yyerrlab1


/* Like YYERROR except do call yyerror.  This remains here temporarily
   to ease the transition to the new meaning of YYERROR, for GCC.
   Once GCC version 2 has supplanted version 1, this can go.  */

#define YYFAIL		goto yyerrlab








>







640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
#define yyclearin	(yychar = YYEMPTY)
#define YYEMPTY		(-2)
#define YYEOF		0

#define YYACCEPT	goto yyacceptlab
#define YYABORT		goto yyabortlab
#define YYERROR		goto yyerrlab1


/* Like YYERROR except do call yyerror.  This remains here temporarily
   to ease the transition to the new meaning of YYERROR, for GCC.
   Once GCC version 2 has supplanted version 1, this can go.  */

#define YYFAIL		goto yyerrlab

758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
#else
static void
yy_reduce_print (yyrule)
    int yyrule;
#endif
{
  int yyi;
  unsigned int yylineno = yyrline[yyrule];
  YYFPRINTF (stderr, "Reducing stack by rule %d (line %u), ",
             yyrule - 1, yylineno);
  /* Print the symbols being reduced, and their result.  */
  for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
    YYFPRINTF (stderr, "%s ", yytname [yyrhs[yyi]]);
  YYFPRINTF (stderr, "-> %s\n", yytname [yyr1[yyrule]]);
}

# define YY_REDUCE_PRINT(Rule)		\







|

|







762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
#else
static void
yy_reduce_print (yyrule)
    int yyrule;
#endif
{
  int yyi;
  unsigned int yylno = yyrline[yyrule];
  YYFPRINTF (stderr, "Reducing stack by rule %d (line %u), ",
             yyrule - 1, yylno);
  /* Print the symbols being reduced, and their result.  */
  for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
    YYFPRINTF (stderr, "%s ", yytname [yyrhs[yyi]]);
  YYFPRINTF (stderr, "-> %s\n", yytname [yyr1[yyrule]]);
}

# define YY_REDUCE_PRINT(Rule)		\
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
  yyval = yyvsp[1-yylen];


  YY_REDUCE_PRINT (yyn);
  switch (yyn)
    {
        case 4:
#line 180 "../unix/../generic/tclGetDate.y"
    {
            yyHaveTime++;
        ;}
    break;

  case 5:
#line 183 "../unix/../generic/tclGetDate.y"
    {
            yyHaveZone++;
        ;}
    break;

  case 6:
#line 186 "../unix/../generic/tclGetDate.y"
    {
            yyHaveDate++;
        ;}
    break;

  case 7:
#line 189 "../unix/../generic/tclGetDate.y"
    {
            yyHaveOrdinalMonth++;
        ;}
    break;

  case 8:
#line 192 "../unix/../generic/tclGetDate.y"
    {
            yyHaveDay++;
        ;}
    break;

  case 9:
#line 195 "../unix/../generic/tclGetDate.y"
    {
            yyHaveRel++;
        ;}
    break;

  case 10:
#line 198 "../unix/../generic/tclGetDate.y"
    {
	    yyHaveTime++;
	    yyHaveDate++;
	;}
    break;

  case 11:
#line 202 "../unix/../generic/tclGetDate.y"
    {
	    yyHaveTime++;
	    yyHaveDate++;
	    yyHaveRel++;
        ;}
    break;

  case 13:
#line 210 "../unix/../generic/tclGetDate.y"
    {
            yyHour = yyvsp[-1].Number;
            yyMinutes = 0;
            yySeconds = 0;
            yyMeridian = yyvsp[0].Meridian;
        ;}
    break;

  case 14:
#line 216 "../unix/../generic/tclGetDate.y"
    {
            yyHour = yyvsp[-3].Number;
            yyMinutes = yyvsp[-1].Number;
            yySeconds = 0;
            yyMeridian = yyvsp[0].Meridian;
        ;}
    break;

  case 15:
#line 222 "../unix/../generic/tclGetDate.y"
    {
            yyHour = yyvsp[-4].Number;
            yyMinutes = yyvsp[-2].Number;
            yyMeridian = MER24;
            yyDSTmode = DSToff;
            yyTimezone = (yyvsp[0].Number % 100 + (yyvsp[0].Number / 100) * 60);
	    ++yyHaveZone;
        ;}
    break;

  case 16:
#line 230 "../unix/../generic/tclGetDate.y"
    {
            yyHour = yyvsp[-5].Number;
            yyMinutes = yyvsp[-3].Number;
            yySeconds = yyvsp[-1].Number;
            yyMeridian = yyvsp[0].Meridian;
        ;}
    break;

  case 17:
#line 236 "../unix/../generic/tclGetDate.y"
    {
            yyHour = yyvsp[-6].Number;
            yyMinutes = yyvsp[-4].Number;
            yySeconds = yyvsp[-2].Number;
            yyMeridian = MER24;
            yyDSTmode = DSToff;
            yyTimezone = (yyvsp[0].Number % 100 + (yyvsp[0].Number / 100) * 60);
	    ++yyHaveZone;
        ;}
    break;

  case 18:
#line 247 "../unix/../generic/tclGetDate.y"
    {
            yyTimezone = yyvsp[-1].Number;
            yyDSTmode = DSTon;
        ;}
    break;

  case 19:
#line 251 "../unix/../generic/tclGetDate.y"
    {
            yyTimezone = yyvsp[0].Number;
            yyDSTmode = DSToff;
        ;}
    break;

  case 20:
#line 255 "../unix/../generic/tclGetDate.y"
    {
            yyTimezone = yyvsp[0].Number;
            yyDSTmode = DSTon;
        ;}
    break;

  case 21:
#line 261 "../unix/../generic/tclGetDate.y"
    {
            yyDayOrdinal = 1;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 22:
#line 265 "../unix/../generic/tclGetDate.y"
    {
            yyDayOrdinal = 1;
            yyDayNumber = yyvsp[-1].Number;
        ;}
    break;

  case 23:
#line 269 "../unix/../generic/tclGetDate.y"
    {
            yyDayOrdinal = yyvsp[-1].Number;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 24:
#line 273 "../unix/../generic/tclGetDate.y"
    {
            yyDayOrdinal = yyvsp[-2].Number * yyvsp[-1].Number;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 25:
#line 277 "../unix/../generic/tclGetDate.y"
    {
            yyDayOrdinal = 2;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 26:
#line 283 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[-2].Number;
            yyDay = yyvsp[0].Number;
        ;}
    break;

  case 27:
#line 287 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[-4].Number;
            yyDay = yyvsp[-2].Number;
            yyYear = yyvsp[0].Number;
        ;}
    break;

  case 28:
#line 292 "../unix/../generic/tclGetDate.y"
    {
	    yyYear = yyvsp[0].Number / 10000;
	    yyMonth = (yyvsp[0].Number % 10000)/100;
	    yyDay = yyvsp[0].Number % 100;
	;}
    break;

  case 29:
#line 297 "../unix/../generic/tclGetDate.y"
    {
	    yyDay = yyvsp[-4].Number;
	    yyMonth = yyvsp[-2].Number;
	    yyYear = yyvsp[0].Number;
	;}
    break;

  case 30:
#line 302 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[-2].Number;
            yyDay = yyvsp[0].Number;
            yyYear = yyvsp[-4].Number;
        ;}
    break;

  case 31:
#line 307 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[-1].Number;
            yyDay = yyvsp[0].Number;
        ;}
    break;

  case 32:
#line 311 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[-3].Number;
            yyDay = yyvsp[-2].Number;
            yyYear = yyvsp[0].Number;
        ;}
    break;

  case 33:
#line 316 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[0].Number;
            yyDay = yyvsp[-1].Number;
        ;}
    break;

  case 34:
#line 320 "../unix/../generic/tclGetDate.y"
    {
	    yyMonth = 1;
	    yyDay = 1;
	    yyYear = EPOCH;
	;}
    break;

  case 35:
#line 325 "../unix/../generic/tclGetDate.y"
    {
            yyMonth = yyvsp[-1].Number;
            yyDay = yyvsp[-2].Number;
            yyYear = yyvsp[0].Number;
        ;}
    break;

  case 36:
#line 332 "../unix/../generic/tclGetDate.y"
    {
	    yyMonthOrdinal = 1;
	    yyMonth = yyvsp[0].Number;
	;}
    break;

  case 37:
#line 336 "../unix/../generic/tclGetDate.y"
    {
	    yyMonthOrdinal = yyvsp[-1].Number;
	    yyMonth = yyvsp[0].Number;
	;}
    break;

  case 38:
#line 342 "../unix/../generic/tclGetDate.y"
    {
            if (yyvsp[-1].Number != HOUR(- 7)) YYABORT;
	    yyYear = yyvsp[-2].Number / 10000;
	    yyMonth = (yyvsp[-2].Number % 10000)/100;
	    yyDay = yyvsp[-2].Number % 100;
	    yyHour = yyvsp[0].Number / 10000;
	    yyMinutes = (yyvsp[0].Number % 10000)/100;
	    yySeconds = yyvsp[0].Number % 100;
        ;}
    break;

  case 39:
#line 351 "../unix/../generic/tclGetDate.y"
    {
            if (yyvsp[-5].Number != HOUR(- 7)) YYABORT;
	    yyYear = yyvsp[-6].Number / 10000;
	    yyMonth = (yyvsp[-6].Number % 10000)/100;
	    yyDay = yyvsp[-6].Number % 100;
	    yyHour = yyvsp[-4].Number;
	    yyMinutes = yyvsp[-2].Number;
	    yySeconds = yyvsp[0].Number;
        ;}
    break;

  case 40:
#line 360 "../unix/../generic/tclGetDate.y"
    {
	    yyYear = yyvsp[-1].Number / 10000;
	    yyMonth = (yyvsp[-1].Number % 10000)/100;
	    yyDay = yyvsp[-1].Number % 100;
	    yyHour = yyvsp[0].Number / 10000;
	    yyMinutes = (yyvsp[0].Number % 10000)/100;
	    yySeconds = yyvsp[0].Number % 100;
        ;}
    break;

  case 41:
#line 370 "../unix/../generic/tclGetDate.y"
    {
            /*
	     * Offset computed year by -377 so that the returned years will
	     * be in a range accessible with a 32 bit clock seconds value
	     */
            yyYear = yyvsp[-2].Number/1000 + 2323 - 377;
            yyDay  = 1;
	    yyMonth = 1;
	    yyRelDay += ((yyvsp[-2].Number%1000)*(365 + IsLeapYear(yyYear)))/1000;
	    yyRelSeconds += yyvsp[0].Number * 144 * 60;
        ;}
    break;

  case 42:
#line 383 "../unix/../generic/tclGetDate.y"
    {
	    yyRelSeconds *= -1;
	    yyRelMonth *= -1;
	    yyRelDay *= -1;
	;}
    break;

  case 44:
#line 390 "../unix/../generic/tclGetDate.y"
    { *yyRelPointer += yyvsp[-2].Number * yyvsp[-1].Number * yyvsp[0].Number; ;}
    break;

  case 45:
#line 391 "../unix/../generic/tclGetDate.y"
    { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;}
    break;

  case 46:
#line 392 "../unix/../generic/tclGetDate.y"
    { *yyRelPointer += yyvsp[0].Number; ;}
    break;

  case 47:
#line 393 "../unix/../generic/tclGetDate.y"
    { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;}
    break;

  case 48:
#line 394 "../unix/../generic/tclGetDate.y"
    { *yyRelPointer += yyvsp[0].Number; ;}
    break;

  case 49:
#line 396 "../unix/../generic/tclGetDate.y"
    { yyval.Number = -1; ;}
    break;

  case 50:
#line 397 "../unix/../generic/tclGetDate.y"
    { yyval.Number =  1; ;}
    break;

  case 51:
#line 399 "../unix/../generic/tclGetDate.y"
    { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelSeconds; ;}
    break;

  case 52:
#line 400 "../unix/../generic/tclGetDate.y"
    { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelDay; ;}
    break;

  case 53:
#line 401 "../unix/../generic/tclGetDate.y"
    { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelMonth; ;}
    break;

  case 54:
#line 405 "../unix/../generic/tclGetDate.y"
    {
	if (yyHaveTime && yyHaveDate && !yyHaveRel) {
	    yyYear = yyvsp[0].Number;
	} else {
	    yyHaveTime++;
	    if (yyvsp[0].Number < 100) {
		yyHour = yyvsp[0].Number;
		yyMinutes = 0;
	    } else {
		yyHour = yyvsp[0].Number / 100;
		yyMinutes = yyvsp[0].Number % 100;
	    }
	    yySeconds = 0;
	    yyMeridian = MER24;
	}
    ;}
    break;

  case 55:
#line 423 "../unix/../generic/tclGetDate.y"
    {
            yyval.Meridian = MER24;
        ;}
    break;

  case 56:
#line 426 "../unix/../generic/tclGetDate.y"
    {
            yyval.Meridian = yyvsp[0].Meridian;
        ;}
    break;


    }

/* Line 991 of yacc.c.  */
#line 1657 "../unix/../generic/tclDate.c"

  yyvsp -= yylen;
  yyssp -= yylen;


  YY_STACK_PRINT (yyss, yyssp);








|






|






|






|






|






|






|







|








|









|









|











|









|












|







|







|







|







|







|







|







|







|







|








|








|








|








|







|








|







|








|








|







|







|












|












|











|














|








|




|




|




|




|




|




|




|




|




|




|





|













|






|








|
|







1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
  yyval = yyvsp[1-yylen];


  YY_REDUCE_PRINT (yyn);
  switch (yyn)
    {
        case 4:

    {
            yyHaveTime++;
        ;}
    break;

  case 5:

    {
            yyHaveZone++;
        ;}
    break;

  case 6:

    {
            yyHaveDate++;
        ;}
    break;

  case 7:

    {
            yyHaveOrdinalMonth++;
        ;}
    break;

  case 8:

    {
            yyHaveDay++;
        ;}
    break;

  case 9:

    {
            yyHaveRel++;
        ;}
    break;

  case 10:

    {
	    yyHaveTime++;
	    yyHaveDate++;
	;}
    break;

  case 11:

    {
	    yyHaveTime++;
	    yyHaveDate++;
	    yyHaveRel++;
        ;}
    break;

  case 13:

    {
            yyHour = yyvsp[-1].Number;
            yyMinutes = 0;
            yySeconds = 0;
            yyMeridian = yyvsp[0].Meridian;
        ;}
    break;

  case 14:

    {
            yyHour = yyvsp[-3].Number;
            yyMinutes = yyvsp[-1].Number;
            yySeconds = 0;
            yyMeridian = yyvsp[0].Meridian;
        ;}
    break;

  case 15:

    {
            yyHour = yyvsp[-4].Number;
            yyMinutes = yyvsp[-2].Number;
            yyMeridian = MER24;
            yyDSTmode = DSToff;
            yyTimezone = (yyvsp[0].Number % 100 + (yyvsp[0].Number / 100) * 60);
	    ++yyHaveZone;
        ;}
    break;

  case 16:

    {
            yyHour = yyvsp[-5].Number;
            yyMinutes = yyvsp[-3].Number;
            yySeconds = yyvsp[-1].Number;
            yyMeridian = yyvsp[0].Meridian;
        ;}
    break;

  case 17:

    {
            yyHour = yyvsp[-6].Number;
            yyMinutes = yyvsp[-4].Number;
            yySeconds = yyvsp[-2].Number;
            yyMeridian = MER24;
            yyDSTmode = DSToff;
            yyTimezone = (yyvsp[0].Number % 100 + (yyvsp[0].Number / 100) * 60);
	    ++yyHaveZone;
        ;}
    break;

  case 18:

    {
            yyTimezone = yyvsp[-1].Number;
            yyDSTmode = DSTon;
        ;}
    break;

  case 19:

    {
            yyTimezone = yyvsp[0].Number;
            yyDSTmode = DSToff;
        ;}
    break;

  case 20:

    {
            yyTimezone = yyvsp[0].Number;
            yyDSTmode = DSTon;
        ;}
    break;

  case 21:

    {
            yyDayOrdinal = 1;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 22:

    {
            yyDayOrdinal = 1;
            yyDayNumber = yyvsp[-1].Number;
        ;}
    break;

  case 23:

    {
            yyDayOrdinal = yyvsp[-1].Number;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 24:

    {
            yyDayOrdinal = yyvsp[-2].Number * yyvsp[-1].Number;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 25:

    {
            yyDayOrdinal = 2;
            yyDayNumber = yyvsp[0].Number;
        ;}
    break;

  case 26:

    {
            yyMonth = yyvsp[-2].Number;
            yyDay = yyvsp[0].Number;
        ;}
    break;

  case 27:

    {
            yyMonth = yyvsp[-4].Number;
            yyDay = yyvsp[-2].Number;
            yyYear = yyvsp[0].Number;
        ;}
    break;

  case 28:

    {
	    yyYear = yyvsp[0].Number / 10000;
	    yyMonth = (yyvsp[0].Number % 10000)/100;
	    yyDay = yyvsp[0].Number % 100;
	;}
    break;

  case 29:

    {
	    yyDay = yyvsp[-4].Number;
	    yyMonth = yyvsp[-2].Number;
	    yyYear = yyvsp[0].Number;
	;}
    break;

  case 30:

    {
            yyMonth = yyvsp[-2].Number;
            yyDay = yyvsp[0].Number;
            yyYear = yyvsp[-4].Number;
        ;}
    break;

  case 31:

    {
            yyMonth = yyvsp[-1].Number;
            yyDay = yyvsp[0].Number;
        ;}
    break;

  case 32:

    {
            yyMonth = yyvsp[-3].Number;
            yyDay = yyvsp[-2].Number;
            yyYear = yyvsp[0].Number;
        ;}
    break;

  case 33:

    {
            yyMonth = yyvsp[0].Number;
            yyDay = yyvsp[-1].Number;
        ;}
    break;

  case 34:

    {
	    yyMonth = 1;
	    yyDay = 1;
	    yyYear = EPOCH;
	;}
    break;

  case 35:

    {
            yyMonth = yyvsp[-1].Number;
            yyDay = yyvsp[-2].Number;
            yyYear = yyvsp[0].Number;
        ;}
    break;

  case 36:

    {
	    yyMonthOrdinal = 1;
	    yyMonth = yyvsp[0].Number;
	;}
    break;

  case 37:

    {
	    yyMonthOrdinal = yyvsp[-1].Number;
	    yyMonth = yyvsp[0].Number;
	;}
    break;

  case 38:

    {
            if (yyvsp[-1].Number != HOUR(- 7)) YYABORT;
	    yyYear = yyvsp[-2].Number / 10000;
	    yyMonth = (yyvsp[-2].Number % 10000)/100;
	    yyDay = yyvsp[-2].Number % 100;
	    yyHour = yyvsp[0].Number / 10000;
	    yyMinutes = (yyvsp[0].Number % 10000)/100;
	    yySeconds = yyvsp[0].Number % 100;
        ;}
    break;

  case 39:

    {
            if (yyvsp[-5].Number != HOUR(- 7)) YYABORT;
	    yyYear = yyvsp[-6].Number / 10000;
	    yyMonth = (yyvsp[-6].Number % 10000)/100;
	    yyDay = yyvsp[-6].Number % 100;
	    yyHour = yyvsp[-4].Number;
	    yyMinutes = yyvsp[-2].Number;
	    yySeconds = yyvsp[0].Number;
        ;}
    break;

  case 40:

    {
	    yyYear = yyvsp[-1].Number / 10000;
	    yyMonth = (yyvsp[-1].Number % 10000)/100;
	    yyDay = yyvsp[-1].Number % 100;
	    yyHour = yyvsp[0].Number / 10000;
	    yyMinutes = (yyvsp[0].Number % 10000)/100;
	    yySeconds = yyvsp[0].Number % 100;
        ;}
    break;

  case 41:

    {
            /*
	     * Offset computed year by -377 so that the returned years will
	     * be in a range accessible with a 32 bit clock seconds value
	     */
            yyYear = yyvsp[-2].Number/1000 + 2323 - 377;
            yyDay  = 1;
	    yyMonth = 1;
	    yyRelDay += ((yyvsp[-2].Number%1000)*(365 + IsLeapYear(yyYear)))/1000;
	    yyRelSeconds += yyvsp[0].Number * 144 * 60;
        ;}
    break;

  case 42:

    {
	    yyRelSeconds *= -1;
	    yyRelMonth *= -1;
	    yyRelDay *= -1;
	;}
    break;

  case 44:

    { *yyRelPointer += yyvsp[-2].Number * yyvsp[-1].Number * yyvsp[0].Number; ;}
    break;

  case 45:

    { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;}
    break;

  case 46:

    { *yyRelPointer += yyvsp[0].Number; ;}
    break;

  case 47:

    { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;}
    break;

  case 48:

    { *yyRelPointer += yyvsp[0].Number; ;}
    break;

  case 49:

    { yyval.Number = -1; ;}
    break;

  case 50:

    { yyval.Number =  1; ;}
    break;

  case 51:

    { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelSeconds; ;}
    break;

  case 52:

    { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelDay; ;}
    break;

  case 53:

    { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelMonth; ;}
    break;

  case 54:

    {
	if (yyHaveTime && yyHaveDate && !yyHaveRel) {
	    yyYear = yyvsp[0].Number;
	} else {
	    yyHaveTime++;
	    if (yyDigitCount <= 2) {
		yyHour = yyvsp[0].Number;
		yyMinutes = 0;
	    } else {
		yyHour = yyvsp[0].Number / 100;
		yyMinutes = yyvsp[0].Number % 100;
	    }
	    yySeconds = 0;
	    yyMeridian = MER24;
	}
    ;}
    break;

  case 55:

    {
            yyval.Meridian = MER24;
        ;}
    break;

  case 56:

    {
            yyval.Meridian = yyvsp[0].Meridian;
        ;}
    break;


    }

/* Line 999 of yacc.c.  */


  yyvsp -= yylen;
  yyssp -= yylen;


  YY_STACK_PRINT (yyss, yyssp);

1691
1692
1693
1694
1695
1696
1697

1698
1699
1700
1701
1702
1703
1704
1705







1706

1707







1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
#if YYERROR_VERBOSE
      yyn = yypact[yystate];

      if (YYPACT_NINF < yyn && yyn < YYLAST)
	{
	  YYSIZE_T yysize = 0;
	  int yytype = YYTRANSLATE (yychar);

	  char *yymsg;
	  int yyx, yycount;

	  yycount = 0;
	  /* Start YYX at -YYN if negative to avoid negative indexes in
	     YYCHECK.  */
	  for (yyx = yyn < 0 ? -yyn : 0;
	       yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++)







	    if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)

	      yysize += yystrlen (yytname[yyx]) + 15, yycount++;







	  yysize += yystrlen ("syntax error, unexpected ") + 1;
	  yysize += yystrlen (yytname[yytype]);
	  yymsg = (char *) YYSTACK_ALLOC (yysize);
	  if (yymsg != 0)
	    {
	      char *yyp = yystpcpy (yymsg, "syntax error, unexpected ");
	      yyp = yystpcpy (yyp, yytname[yytype]);

	      if (yycount < 5)
		{
		  yycount = 0;
		  for (yyx = yyn < 0 ? -yyn : 0;
		       yyx < (int) (sizeof (yytname) / sizeof (char *));
		       yyx++)
		    if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
		      {
			const char *yyq = ! yycount ? ", expecting " : " or ";
			yyp = yystpcpy (yyp, yyq);
			yyp = yystpcpy (yyp, yytname[yyx]);
			yycount++;
		      }
		}
	      yyerror (yymsg);
	      YYSTACK_FREE (yymsg);
	    }
	  else
	    yyerror ("syntax error; also virtual memory exhausted");







>

|

<


|
|
>
>
>
>
>
>
>

>
|
>
>
>
>
>
>
>
|
|








|
|
<
<


<
|

|







1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705

1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738


1739
1740

1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
#if YYERROR_VERBOSE
      yyn = yypact[yystate];

      if (YYPACT_NINF < yyn && yyn < YYLAST)
	{
	  YYSIZE_T yysize = 0;
	  int yytype = YYTRANSLATE (yychar);
	  const char* yyprefix;
	  char *yymsg;
	  int yyx;


	  /* Start YYX at -YYN if negative to avoid negative indexes in
	     YYCHECK.  */
	  int yyxbegin = yyn < 0 ? -yyn : 0;

	  /* Stay within bounds of both yycheck and yytname.  */
	  int yychecklim = YYLAST - yyn;
	  int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS;
	  int yycount = 0;

	  yyprefix = ", expecting ";
	  for (yyx = yyxbegin; yyx < yyxend; ++yyx)
	    if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
	      {
		yysize += yystrlen (yyprefix) + yystrlen (yytname [yyx]);
		yycount += 1;
		if (yycount == 5)
		  {
		    yysize = 0;
		    break;
		  }
	      }
	  yysize += (sizeof ("syntax error, unexpected ")
		     + yystrlen (yytname[yytype]));
	  yymsg = (char *) YYSTACK_ALLOC (yysize);
	  if (yymsg != 0)
	    {
	      char *yyp = yystpcpy (yymsg, "syntax error, unexpected ");
	      yyp = yystpcpy (yyp, yytname[yytype]);

	      if (yycount < 5)
		{
		  yyprefix = ", expecting ";
		  for (yyx = yyxbegin; yyx < yyxend; ++yyx)


		    if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
		      {

			yyp = yystpcpy (yyp, yyprefix);
			yyp = yystpcpy (yyp, yytname[yyx]);
			yyprefix = " or ";
		      }
		}
	      yyerror (yymsg);
	      YYSTACK_FREE (yymsg);
	    }
	  else
	    yyerror ("syntax error; also virtual memory exhausted");
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
      yydestruct (yytoken, &yylval);
      yychar = YYEMPTY;

    }

  /* Else will try to reuse lookahead token after shifting the error
     token.  */
  goto yyerrlab2;


/*----------------------------------------------------.
| yyerrlab1 -- error raised explicitly by an action.  |
`----------------------------------------------------*/
yyerrlab1:

  /* Suppress GCC warning that yyerrlab1 is unused when no action
     invokes YYERROR.  Doesn't work in C++ */
#ifndef __cplusplus
#if defined (__GNUC_MINOR__) && 2093 <= (__GNUC__ * 1000 + __GNUC_MINOR__)
  __attribute__ ((__unused__))
#endif
#endif


  goto yyerrlab2;


/*---------------------------------------------------------------.
| yyerrlab2 -- pop states until the error token can be shifted.  |
`---------------------------------------------------------------*/
yyerrlab2:
  yyerrstatus = 3;	/* Each real token shifted decrements this.  */

  for (;;)
    {
      yyn = yypact[yystate];
      if (yyn != YYPACT_NINF)
	{







|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793

















1794
1795
1796
1797
1798
1799
1800
      yydestruct (yytoken, &yylval);
      yychar = YYEMPTY;

    }

  /* Else will try to reuse lookahead token after shifting the error
     token.  */
  goto yyerrlab1;


/*----------------------------------------------------.
| yyerrlab1 -- error raised explicitly by an action.  |
`----------------------------------------------------*/
yyerrlab1:

















  yyerrstatus = 3;	/* Each real token shifted decrements this.  */

  for (;;)
    {
      yyn = yypact[yystate];
      if (yyn != YYPACT_NINF)
	{
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
  if (yyss != yyssa)
    YYSTACK_FREE (yyss);
#endif
  return yyresult;
}


#line 431 "../unix/../generic/tclGetDate.y"


/*
 * Month and day table.
 */
static TABLE    MonthDayTable[] = {
    { "january",        tMONTH,  1 },







|







1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
  if (yyss != yyssa)
    YYSTACK_FREE (yyss);
#endif
  return yyresult;
}





/*
 * Month and day table.
 */
static TABLE    MonthDayTable[] = {
    { "january",        tMONTH,  1 },
2235
2236
2237
2238
2239
2240
2241

2242
2243
2244
2245
2246
2247
2248
	    Count = 0;
            for (yylval.Number = 0;
		    isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
                yylval.Number = 10 * yylval.Number + c - '0';
		Count++;
	    }
            yyInput--;

	    /* A number with 6 or more digits is considered an ISO 8601 base */
	    if (Count >= 6) {
		return tISOBASE;
	    } else {
		return tUNUMBER;
	    }
        }







>







2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
	    Count = 0;
            for (yylval.Number = 0;
		    isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
                yylval.Number = 10 * yylval.Number + c - '0';
		Count++;
	    }
            yyInput--;
	    yyDigitCount = Count;
	    /* A number with 6 or more digits is considered an ISO 8601 base */
	    if (Count >= 6) {
		return tISOBASE;
	    } else {
		return tUNUMBER;
	    }
        }

Changes to generic/tclDecls.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.107 2004/11/13 00:19:07 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.107.2.9 2005/09/20 14:11:51 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
#endif
#ifndef Tcl_Panic_TCL_DECLARED
#define Tcl_Panic_TCL_DECLARED
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
#endif
#ifndef Tcl_Alloc_TCL_DECLARED
#define Tcl_Alloc_TCL_DECLARED
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
#endif
#ifndef Tcl_Free_TCL_DECLARED







|







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
#endif
#ifndef Tcl_Panic_TCL_DECLARED
#define Tcl_Panic_TCL_DECLARED
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_((CONST char *format, ...));
#endif
#ifndef Tcl_Alloc_TCL_DECLARED
#define Tcl_Alloc_TCL_DECLARED
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
#endif
#ifndef Tcl_Free_TCL_DECLARED
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
/* 14 */
EXTERN int		Tcl_AppendAllObjTypes _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
#endif
#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void		Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr));
#endif
#ifndef Tcl_AppendToObj_TCL_DECLARED
#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
EXTERN void		Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 
				CONST char* bytes, int length));
#endif







|







127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
/* 14 */
EXTERN int		Tcl_AppendAllObjTypes _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
#endif
#ifndef Tcl_AppendStringsToObj_TCL_DECLARED
#define Tcl_AppendStringsToObj_TCL_DECLARED
/* 15 */
EXTERN void		Tcl_AppendStringsToObj _ANSI_ARGS_((Tcl_Obj *objPtr, ...));
#endif
#ifndef Tcl_AppendToObj_TCL_DECLARED
#define Tcl_AppendToObj_TCL_DECLARED
/* 16 */
EXTERN void		Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, 
				CONST char* bytes, int length));
#endif
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
/* 30 */
EXTERN void		TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr));
#endif
#ifndef Tcl_GetBoolean_TCL_DECLARED
#define Tcl_GetBoolean_TCL_DECLARED
/* 31 */
EXTERN int		Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, int * boolPtr));
#endif
#ifndef Tcl_GetBooleanFromObj_TCL_DECLARED
#define Tcl_GetBooleanFromObj_TCL_DECLARED
/* 32 */
EXTERN int		Tcl_GetBooleanFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				int * boolPtr));
#endif
#ifndef Tcl_GetByteArrayFromObj_TCL_DECLARED
#define Tcl_GetByteArrayFromObj_TCL_DECLARED
/* 33 */
EXTERN unsigned char *	Tcl_GetByteArrayFromObj _ANSI_ARGS_((
				Tcl_Obj * objPtr, int * lengthPtr));
#endif
#ifndef Tcl_GetDouble_TCL_DECLARED
#define Tcl_GetDouble_TCL_DECLARED
/* 34 */
EXTERN int		Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, double * doublePtr));
#endif
#ifndef Tcl_GetDoubleFromObj_TCL_DECLARED
#define Tcl_GetDoubleFromObj_TCL_DECLARED
/* 35 */
EXTERN int		Tcl_GetDoubleFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				double * doublePtr));
#endif
#ifndef Tcl_GetIndexFromObj_TCL_DECLARED
#define Tcl_GetIndexFromObj_TCL_DECLARED
/* 36 */
EXTERN int		Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, CONST84 char ** tablePtr, 
				CONST char * msg, int flags, int * indexPtr));
#endif
#ifndef Tcl_GetInt_TCL_DECLARED
#define Tcl_GetInt_TCL_DECLARED
/* 37 */
EXTERN int		Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, int * intPtr));
#endif
#ifndef Tcl_GetIntFromObj_TCL_DECLARED
#define Tcl_GetIntFromObj_TCL_DECLARED
/* 38 */
EXTERN int		Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int * intPtr));
#endif







|


















|



















|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
/* 30 */
EXTERN void		TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr));
#endif
#ifndef Tcl_GetBoolean_TCL_DECLARED
#define Tcl_GetBoolean_TCL_DECLARED
/* 31 */
EXTERN int		Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * src, int * boolPtr));
#endif
#ifndef Tcl_GetBooleanFromObj_TCL_DECLARED
#define Tcl_GetBooleanFromObj_TCL_DECLARED
/* 32 */
EXTERN int		Tcl_GetBooleanFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				int * boolPtr));
#endif
#ifndef Tcl_GetByteArrayFromObj_TCL_DECLARED
#define Tcl_GetByteArrayFromObj_TCL_DECLARED
/* 33 */
EXTERN unsigned char *	Tcl_GetByteArrayFromObj _ANSI_ARGS_((
				Tcl_Obj * objPtr, int * lengthPtr));
#endif
#ifndef Tcl_GetDouble_TCL_DECLARED
#define Tcl_GetDouble_TCL_DECLARED
/* 34 */
EXTERN int		Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * src, double * doublePtr));
#endif
#ifndef Tcl_GetDoubleFromObj_TCL_DECLARED
#define Tcl_GetDoubleFromObj_TCL_DECLARED
/* 35 */
EXTERN int		Tcl_GetDoubleFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				double * doublePtr));
#endif
#ifndef Tcl_GetIndexFromObj_TCL_DECLARED
#define Tcl_GetIndexFromObj_TCL_DECLARED
/* 36 */
EXTERN int		Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, CONST84 char ** tablePtr, 
				CONST char * msg, int flags, int * indexPtr));
#endif
#ifndef Tcl_GetInt_TCL_DECLARED
#define Tcl_GetInt_TCL_DECLARED
/* 37 */
EXTERN int		Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * src, int * intPtr));
#endif
#ifndef Tcl_GetIntFromObj_TCL_DECLARED
#define Tcl_GetIntFromObj_TCL_DECLARED
/* 38 */
EXTERN int		Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int * intPtr));
#endif
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
/* 68 */
EXTERN void		Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef Tcl_AppendElement_TCL_DECLARED
#define Tcl_AppendElement_TCL_DECLARED
/* 69 */
EXTERN void		Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string));
#endif
#ifndef Tcl_AppendResult_TCL_DECLARED
#define Tcl_AppendResult_TCL_DECLARED
/* 70 */
EXTERN void		Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_AsyncCreate_TCL_DECLARED
#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler	 Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 
				ClientData clientData));
#endif







|




|







452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
/* 68 */
EXTERN void		Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef Tcl_AppendElement_TCL_DECLARED
#define Tcl_AppendElement_TCL_DECLARED
/* 69 */
EXTERN void		Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * element));
#endif
#ifndef Tcl_AppendResult_TCL_DECLARED
#define Tcl_AppendResult_TCL_DECLARED
/* 70 */
EXTERN void		Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_AsyncCreate_TCL_DECLARED
#define Tcl_AsyncCreate_TCL_DECLARED
/* 71 */
EXTERN Tcl_AsyncHandler	 Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, 
				ClientData clientData));
#endif
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
EXTERN void		Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc, 
				ClientData clientData));
#endif
#ifndef Tcl_DStringAppend_TCL_DECLARED
#define Tcl_DStringAppend_TCL_DECLARED
/* 117 */
EXTERN char *		Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, 
				CONST char * str, int length));
#endif
#ifndef Tcl_DStringAppendElement_TCL_DECLARED
#define Tcl_DStringAppendElement_TCL_DECLARED
/* 118 */
EXTERN char *		Tcl_DStringAppendElement _ANSI_ARGS_((
				Tcl_DString * dsPtr, CONST char * string));
#endif
#ifndef Tcl_DStringEndSublist_TCL_DECLARED
#define Tcl_DStringEndSublist_TCL_DECLARED
/* 119 */
EXTERN void		Tcl_DStringEndSublist _ANSI_ARGS_((
				Tcl_DString * dsPtr));
#endif







|





|







768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
EXTERN void		Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc, 
				ClientData clientData));
#endif
#ifndef Tcl_DStringAppend_TCL_DECLARED
#define Tcl_DStringAppend_TCL_DECLARED
/* 117 */
EXTERN char *		Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, 
				CONST char * bytes, int length));
#endif
#ifndef Tcl_DStringAppendElement_TCL_DECLARED
#define Tcl_DStringAppendElement_TCL_DECLARED
/* 118 */
EXTERN char *		Tcl_DStringAppendElement _ANSI_ARGS_((
				Tcl_DString * dsPtr, CONST char * element));
#endif
#ifndef Tcl_DStringEndSublist_TCL_DECLARED
#define Tcl_DStringEndSublist_TCL_DECLARED
/* 119 */
EXTERN void		Tcl_DStringEndSublist _ANSI_ARGS_((
				Tcl_DString * dsPtr));
#endif
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
/* 128 */
EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_Eval_TCL_DECLARED
#define Tcl_Eval_TCL_DECLARED
/* 129 */
EXTERN int		Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string));
#endif
#ifndef Tcl_EvalFile_TCL_DECLARED
#define Tcl_EvalFile_TCL_DECLARED
/* 130 */
EXTERN int		Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * fileName));
#endif







|







835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
/* 128 */
EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_Eval_TCL_DECLARED
#define Tcl_Eval_TCL_DECLARED
/* 129 */
EXTERN int		Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * script));
#endif
#ifndef Tcl_EvalFile_TCL_DECLARED
#define Tcl_EvalFile_TCL_DECLARED
/* 130 */
EXTERN int		Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * fileName));
#endif
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
				CONST char * hiddenCmdToken, 
				CONST char * cmdName));
#endif
#ifndef Tcl_ExprBoolean_TCL_DECLARED
#define Tcl_ExprBoolean_TCL_DECLARED
/* 135 */
EXTERN int		Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, int * ptr));
#endif
#ifndef Tcl_ExprBooleanObj_TCL_DECLARED
#define Tcl_ExprBooleanObj_TCL_DECLARED
/* 136 */
EXTERN int		Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int * ptr));
#endif
#ifndef Tcl_ExprDouble_TCL_DECLARED
#define Tcl_ExprDouble_TCL_DECLARED
/* 137 */
EXTERN int		Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, double * ptr));
#endif
#ifndef Tcl_ExprDoubleObj_TCL_DECLARED
#define Tcl_ExprDoubleObj_TCL_DECLARED
/* 138 */
EXTERN int		Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, double * ptr));
#endif
#ifndef Tcl_ExprLong_TCL_DECLARED
#define Tcl_ExprLong_TCL_DECLARED
/* 139 */
EXTERN int		Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, long * ptr));
#endif
#ifndef Tcl_ExprLongObj_TCL_DECLARED
#define Tcl_ExprLongObj_TCL_DECLARED
/* 140 */
EXTERN int		Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, long * ptr));
#endif
#ifndef Tcl_ExprObj_TCL_DECLARED
#define Tcl_ExprObj_TCL_DECLARED
/* 141 */
EXTERN int		Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr));
#endif
#ifndef Tcl_ExprString_TCL_DECLARED
#define Tcl_ExprString_TCL_DECLARED
/* 142 */
EXTERN int		Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string));
#endif
#ifndef Tcl_Finalize_TCL_DECLARED
#define Tcl_Finalize_TCL_DECLARED
/* 143 */
EXTERN void		Tcl_Finalize _ANSI_ARGS_((void));
#endif
#ifndef Tcl_FindExecutable_TCL_DECLARED







|











|











|

















|







872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
				CONST char * hiddenCmdToken, 
				CONST char * cmdName));
#endif
#ifndef Tcl_ExprBoolean_TCL_DECLARED
#define Tcl_ExprBoolean_TCL_DECLARED
/* 135 */
EXTERN int		Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * expr, int * ptr));
#endif
#ifndef Tcl_ExprBooleanObj_TCL_DECLARED
#define Tcl_ExprBooleanObj_TCL_DECLARED
/* 136 */
EXTERN int		Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int * ptr));
#endif
#ifndef Tcl_ExprDouble_TCL_DECLARED
#define Tcl_ExprDouble_TCL_DECLARED
/* 137 */
EXTERN int		Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * expr, double * ptr));
#endif
#ifndef Tcl_ExprDoubleObj_TCL_DECLARED
#define Tcl_ExprDoubleObj_TCL_DECLARED
/* 138 */
EXTERN int		Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, double * ptr));
#endif
#ifndef Tcl_ExprLong_TCL_DECLARED
#define Tcl_ExprLong_TCL_DECLARED
/* 139 */
EXTERN int		Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * expr, long * ptr));
#endif
#ifndef Tcl_ExprLongObj_TCL_DECLARED
#define Tcl_ExprLongObj_TCL_DECLARED
/* 140 */
EXTERN int		Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, long * ptr));
#endif
#ifndef Tcl_ExprObj_TCL_DECLARED
#define Tcl_ExprObj_TCL_DECLARED
/* 141 */
EXTERN int		Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr));
#endif
#ifndef Tcl_ExprString_TCL_DECLARED
#define Tcl_ExprString_TCL_DECLARED
/* 142 */
EXTERN int		Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * expr));
#endif
#ifndef Tcl_Finalize_TCL_DECLARED
#define Tcl_Finalize_TCL_DECLARED
/* 143 */
EXTERN void		Tcl_Finalize _ANSI_ARGS_((void));
#endif
#ifndef Tcl_FindExecutable_TCL_DECLARED
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
EXTERN Tcl_Obj *	Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#if !defined(__WIN32__) /* UNIX */
#ifndef Tcl_GetOpenFile_TCL_DECLARED
#define Tcl_GetOpenFile_TCL_DECLARED
/* 167 */
EXTERN int		Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, int forWriting, 
				int checkUsage, ClientData * filePtr));
#endif
#endif /* UNIX */
#ifndef Tcl_GetPathType_TCL_DECLARED
#define Tcl_GetPathType_TCL_DECLARED
/* 168 */
EXTERN Tcl_PathType	Tcl_GetPathType _ANSI_ARGS_((CONST char * path));







|







1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
EXTERN Tcl_Obj *	Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#if !defined(__WIN32__) /* UNIX */
#ifndef Tcl_GetOpenFile_TCL_DECLARED
#define Tcl_GetOpenFile_TCL_DECLARED
/* 167 */
EXTERN int		Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * chanID, int forWriting, 
				int checkUsage, ClientData * filePtr));
#endif
#endif /* UNIX */
#ifndef Tcl_GetPathType_TCL_DECLARED
#define Tcl_GetPathType_TCL_DECLARED
/* 168 */
EXTERN Tcl_PathType	Tcl_GetPathType _ANSI_ARGS_((CONST char * path));
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
/* 202 */
EXTERN void		Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				double value, char * dst));
#endif
#ifndef Tcl_PutEnv_TCL_DECLARED
#define Tcl_PutEnv_TCL_DECLARED
/* 203 */
EXTERN int		Tcl_PutEnv _ANSI_ARGS_((CONST char * string));
#endif
#ifndef Tcl_PosixError_TCL_DECLARED
#define Tcl_PosixError_TCL_DECLARED
/* 204 */
EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef Tcl_QueueEvent_TCL_DECLARED







|







1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
/* 202 */
EXTERN void		Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				double value, char * dst));
#endif
#ifndef Tcl_PutEnv_TCL_DECLARED
#define Tcl_PutEnv_TCL_DECLARED
/* 203 */
EXTERN int		Tcl_PutEnv _ANSI_ARGS_((CONST char * assignment));
#endif
#ifndef Tcl_PosixError_TCL_DECLARED
#define Tcl_PosixError_TCL_DECLARED
/* 204 */
EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef Tcl_QueueEvent_TCL_DECLARED
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
EXTERN void		Tcl_RegisterObjType _ANSI_ARGS_((
				Tcl_ObjType * typePtr));
#endif
#ifndef Tcl_RegExpCompile_TCL_DECLARED
#define Tcl_RegExpCompile_TCL_DECLARED
/* 212 */
EXTERN Tcl_RegExp	Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string));
#endif
#ifndef Tcl_RegExpExec_TCL_DECLARED
#define Tcl_RegExpExec_TCL_DECLARED
/* 213 */
EXTERN int		Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_RegExp regexp, CONST char * str, 
				CONST char * start));
#endif
#ifndef Tcl_RegExpMatch_TCL_DECLARED
#define Tcl_RegExpMatch_TCL_DECLARED
/* 214 */
EXTERN int		Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, CONST char * pattern));
#endif
#ifndef Tcl_RegExpRange_TCL_DECLARED
#define Tcl_RegExpRange_TCL_DECLARED
/* 215 */
EXTERN void		Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, 
				int index, CONST84 char ** startPtr, 
				CONST84 char ** endPtr));







|





|






|







1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
EXTERN void		Tcl_RegisterObjType _ANSI_ARGS_((
				Tcl_ObjType * typePtr));
#endif
#ifndef Tcl_RegExpCompile_TCL_DECLARED
#define Tcl_RegExpCompile_TCL_DECLARED
/* 212 */
EXTERN Tcl_RegExp	Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * pattern));
#endif
#ifndef Tcl_RegExpExec_TCL_DECLARED
#define Tcl_RegExpExec_TCL_DECLARED
/* 213 */
EXTERN int		Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_RegExp regexp, CONST char * text, 
				CONST char * start));
#endif
#ifndef Tcl_RegExpMatch_TCL_DECLARED
#define Tcl_RegExpMatch_TCL_DECLARED
/* 214 */
EXTERN int		Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * text, CONST char * pattern));
#endif
#ifndef Tcl_RegExpRange_TCL_DECLARED
#define Tcl_RegExpRange_TCL_DECLARED
/* 215 */
EXTERN void		Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, 
				int index, CONST84 char ** startPtr, 
				CONST84 char ** endPtr));
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
#define Tcl_SetErrno_TCL_DECLARED
/* 227 */
EXTERN void		Tcl_SetErrno _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_SetErrorCode_TCL_DECLARED
#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void		Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
#endif
#ifndef Tcl_SetPanicProc_TCL_DECLARED







|







1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
#define Tcl_SetErrno_TCL_DECLARED
/* 227 */
EXTERN void		Tcl_SetErrno _ANSI_ARGS_((int err));
#endif
#ifndef Tcl_SetErrorCode_TCL_DECLARED
#define Tcl_SetErrorCode_TCL_DECLARED
/* 228 */
EXTERN void		Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED
#define Tcl_SetMaxBlockTime_TCL_DECLARED
/* 229 */
EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr));
#endif
#ifndef Tcl_SetPanicProc_TCL_DECLARED
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
EXTERN int		Tcl_SetRecursionLimit _ANSI_ARGS_((
				Tcl_Interp * interp, int depth));
#endif
#ifndef Tcl_SetResult_TCL_DECLARED
#define Tcl_SetResult_TCL_DECLARED
/* 232 */
EXTERN void		Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, 
				char * str, Tcl_FreeProc * freeProc));
#endif
#ifndef Tcl_SetServiceMode_TCL_DECLARED
#define Tcl_SetServiceMode_TCL_DECLARED
/* 233 */
EXTERN int		Tcl_SetServiceMode _ANSI_ARGS_((int mode));
#endif
#ifndef Tcl_SetObjErrorCode_TCL_DECLARED







|







1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
EXTERN int		Tcl_SetRecursionLimit _ANSI_ARGS_((
				Tcl_Interp * interp, int depth));
#endif
#ifndef Tcl_SetResult_TCL_DECLARED
#define Tcl_SetResult_TCL_DECLARED
/* 232 */
EXTERN void		Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, 
				char * result, Tcl_FreeProc * freeProc));
#endif
#ifndef Tcl_SetServiceMode_TCL_DECLARED
#define Tcl_SetServiceMode_TCL_DECLARED
/* 233 */
EXTERN int		Tcl_SetServiceMode _ANSI_ARGS_((int mode));
#endif
#ifndef Tcl_SetObjErrorCode_TCL_DECLARED
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
#endif
#ifndef Tcl_VarEval_TCL_DECLARED
#define Tcl_VarEval_TCL_DECLARED
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
#endif
#ifndef Tcl_VarTraceInfo_TCL_DECLARED
#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 







|







1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
#endif
#ifndef Tcl_VarEval_TCL_DECLARED
#define Tcl_VarEval_TCL_DECLARED
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *interp, ...));
#endif
#ifndef Tcl_VarTraceInfo_TCL_DECLARED
#define Tcl_VarTraceInfo_TCL_DECLARED
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_((
				Tcl_HashTable * tablePtr));
#endif
#ifndef Tcl_ParseVar_TCL_DECLARED
#define Tcl_ParseVar_TCL_DECLARED
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, CONST84 char ** termPtr));
#endif
#ifndef Tcl_PkgPresent_TCL_DECLARED
#define Tcl_PkgPresent_TCL_DECLARED
/* 271 */
EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version, 
				int exact));







|







1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_((
				Tcl_HashTable * tablePtr));
#endif
#ifndef Tcl_ParseVar_TCL_DECLARED
#define Tcl_ParseVar_TCL_DECLARED
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * start, CONST84 char ** termPtr));
#endif
#ifndef Tcl_PkgPresent_TCL_DECLARED
#define Tcl_PkgPresent_TCL_DECLARED
/* 271 */
EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version, 
				int exact));
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
				Tcl_Condition * condPtr, 
				Tcl_Mutex * mutexPtr, Tcl_Time * timePtr));
#endif
#ifndef Tcl_NumUtfChars_TCL_DECLARED
#define Tcl_NumUtfChars_TCL_DECLARED
/* 312 */
EXTERN int		Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, 
				int len));
#endif
#ifndef Tcl_ReadChars_TCL_DECLARED
#define Tcl_ReadChars_TCL_DECLARED
/* 313 */
EXTERN int		Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, 
				Tcl_Obj * objPtr, int charsToRead, 
				int appendFlag));







|







1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
				Tcl_Condition * condPtr, 
				Tcl_Mutex * mutexPtr, Tcl_Time * timePtr));
#endif
#ifndef Tcl_NumUtfChars_TCL_DECLARED
#define Tcl_NumUtfChars_TCL_DECLARED
/* 312 */
EXTERN int		Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, 
				int length));
#endif
#ifndef Tcl_ReadChars_TCL_DECLARED
#define Tcl_ReadChars_TCL_DECLARED
/* 313 */
EXTERN int		Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, 
				Tcl_Obj * objPtr, int charsToRead, 
				int appendFlag));
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, 
				int index));
#endif
#ifndef Tcl_UtfCharComplete_TCL_DECLARED
#define Tcl_UtfCharComplete_TCL_DECLARED
/* 326 */
EXTERN int		Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, 
				int len));
#endif
#ifndef Tcl_UtfBackslash_TCL_DECLARED
#define Tcl_UtfBackslash_TCL_DECLARED
/* 327 */
EXTERN int		Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, 
				int * readPtr, char * dst));
#endif







|







2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, 
				int index));
#endif
#ifndef Tcl_UtfCharComplete_TCL_DECLARED
#define Tcl_UtfCharComplete_TCL_DECLARED
/* 326 */
EXTERN int		Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, 
				int length));
#endif
#ifndef Tcl_UtfBackslash_TCL_DECLARED
#define Tcl_UtfBackslash_TCL_DECLARED
/* 327 */
EXTERN int		Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, 
				int * readPtr, char * dst));
#endif
2193
2194
2195
2196
2197
2198
2199
2200

2201
2202
2203
2204
2205
2206

2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
#define Tcl_UniCharIsWordChar_TCL_DECLARED
/* 351 */
EXTERN int		Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
#endif
#ifndef Tcl_UniCharLen_TCL_DECLARED
#define Tcl_UniCharLen_TCL_DECLARED
/* 352 */
EXTERN int		Tcl_UniCharLen _ANSI_ARGS_((CONST Tcl_UniChar * str));

#endif
#ifndef Tcl_UniCharNcmp_TCL_DECLARED
#define Tcl_UniCharNcmp_TCL_DECLARED
/* 353 */
EXTERN int		Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * cs, 
				CONST Tcl_UniChar * ct, unsigned long n));

#endif
#ifndef Tcl_UniCharToUtfDString_TCL_DECLARED
#define Tcl_UniCharToUtfDString_TCL_DECLARED
/* 354 */
EXTERN char *		Tcl_UniCharToUtfDString _ANSI_ARGS_((
				CONST Tcl_UniChar * string, int numChars, 
				Tcl_DString * dsPtr));
#endif
#ifndef Tcl_UtfToUniCharDString_TCL_DECLARED
#define Tcl_UtfToUniCharDString_TCL_DECLARED
/* 355 */
EXTERN Tcl_UniChar *	Tcl_UtfToUniCharDString _ANSI_ARGS_((
				CONST char * string, int length, 
				Tcl_DString * dsPtr));
#endif
#ifndef Tcl_GetRegExpFromObj_TCL_DECLARED
#define Tcl_GetRegExpFromObj_TCL_DECLARED
/* 356 */
EXTERN Tcl_RegExp	Tcl_GetRegExpFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * patObj, 







|
>




|
|
>





|






|







2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
#define Tcl_UniCharIsWordChar_TCL_DECLARED
/* 351 */
EXTERN int		Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
#endif
#ifndef Tcl_UniCharLen_TCL_DECLARED
#define Tcl_UniCharLen_TCL_DECLARED
/* 352 */
EXTERN int		Tcl_UniCharLen _ANSI_ARGS_((
				CONST Tcl_UniChar * uniStr));
#endif
#ifndef Tcl_UniCharNcmp_TCL_DECLARED
#define Tcl_UniCharNcmp_TCL_DECLARED
/* 353 */
EXTERN int		Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * ucs, 
				CONST Tcl_UniChar * uct, 
				unsigned long numChars));
#endif
#ifndef Tcl_UniCharToUtfDString_TCL_DECLARED
#define Tcl_UniCharToUtfDString_TCL_DECLARED
/* 354 */
EXTERN char *		Tcl_UniCharToUtfDString _ANSI_ARGS_((
				CONST Tcl_UniChar * uniStr, int uniLength, 
				Tcl_DString * dsPtr));
#endif
#ifndef Tcl_UtfToUniCharDString_TCL_DECLARED
#define Tcl_UtfToUniCharDString_TCL_DECLARED
/* 355 */
EXTERN Tcl_UniChar *	Tcl_UtfToUniCharDString _ANSI_ARGS_((
				CONST char * src, int length, 
				Tcl_DString * dsPtr));
#endif
#ifndef Tcl_GetRegExpFromObj_TCL_DECLARED
#define Tcl_GetRegExpFromObj_TCL_DECLARED
/* 356 */
EXTERN Tcl_RegExp	Tcl_GetRegExpFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * patObj, 
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
				CONST char * script, CONST char * command, 
				int length));
#endif
#ifndef Tcl_ParseBraces_TCL_DECLARED
#define Tcl_ParseBraces_TCL_DECLARED
/* 360 */
EXTERN int		Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				Tcl_Parse * parsePtr, int append, 
				CONST84 char ** termPtr));
#endif
#ifndef Tcl_ParseCommand_TCL_DECLARED
#define Tcl_ParseCommand_TCL_DECLARED
/* 361 */
EXTERN int		Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				int nested, Tcl_Parse * parsePtr));
#endif
#ifndef Tcl_ParseExpr_TCL_DECLARED
#define Tcl_ParseExpr_TCL_DECLARED
/* 362 */
EXTERN int		Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				Tcl_Parse * parsePtr));
#endif
#ifndef Tcl_ParseQuotedString_TCL_DECLARED
#define Tcl_ParseQuotedString_TCL_DECLARED
/* 363 */
EXTERN int		Tcl_ParseQuotedString _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * string, 
				int numBytes, Tcl_Parse * parsePtr, 
				int append, CONST84 char ** termPtr));
#endif
#ifndef Tcl_ParseVarName_TCL_DECLARED
#define Tcl_ParseVarName_TCL_DECLARED
/* 364 */
EXTERN int		Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				Tcl_Parse * parsePtr, int append));
#endif
#ifndef Tcl_GetCwd_TCL_DECLARED
#define Tcl_GetCwd_TCL_DECLARED
/* 365 */
EXTERN char *		Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));







|







|
|





|






|







|







2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
				CONST char * script, CONST char * command, 
				int length));
#endif
#ifndef Tcl_ParseBraces_TCL_DECLARED
#define Tcl_ParseBraces_TCL_DECLARED
/* 360 */
EXTERN int		Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * start, int numBytes, 
				Tcl_Parse * parsePtr, int append, 
				CONST84 char ** termPtr));
#endif
#ifndef Tcl_ParseCommand_TCL_DECLARED
#define Tcl_ParseCommand_TCL_DECLARED
/* 361 */
EXTERN int		Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * start, int numBytes, int nested, 
				Tcl_Parse * parsePtr));
#endif
#ifndef Tcl_ParseExpr_TCL_DECLARED
#define Tcl_ParseExpr_TCL_DECLARED
/* 362 */
EXTERN int		Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * start, int numBytes, 
				Tcl_Parse * parsePtr));
#endif
#ifndef Tcl_ParseQuotedString_TCL_DECLARED
#define Tcl_ParseQuotedString_TCL_DECLARED
/* 363 */
EXTERN int		Tcl_ParseQuotedString _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * start, 
				int numBytes, Tcl_Parse * parsePtr, 
				int append, CONST84 char ** termPtr));
#endif
#ifndef Tcl_ParseVarName_TCL_DECLARED
#define Tcl_ParseVarName_TCL_DECLARED
/* 364 */
EXTERN int		Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * start, int numBytes, 
				Tcl_Parse * parsePtr, int append));
#endif
#ifndef Tcl_GetCwd_TCL_DECLARED
#define Tcl_GetCwd_TCL_DECLARED
/* 365 */
EXTERN char *		Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
/* 375 */
EXTERN int		Tcl_UniCharIsPunct _ANSI_ARGS_((int ch));
#endif
#ifndef Tcl_RegExpExecObj_TCL_DECLARED
#define Tcl_RegExpExecObj_TCL_DECLARED
/* 376 */
EXTERN int		Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_RegExp regexp, Tcl_Obj * objPtr, 
				int offset, int nmatches, int flags));
#endif
#ifndef Tcl_RegExpGetInfo_TCL_DECLARED
#define Tcl_RegExpGetInfo_TCL_DECLARED
/* 377 */
EXTERN void		Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp, 
				Tcl_RegExpInfo * infoPtr));







|







2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
/* 375 */
EXTERN int		Tcl_UniCharIsPunct _ANSI_ARGS_((int ch));
#endif
#ifndef Tcl_RegExpExecObj_TCL_DECLARED
#define Tcl_RegExpExecObj_TCL_DECLARED
/* 376 */
EXTERN int		Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_RegExp regexp, Tcl_Obj * textObj, 
				int offset, int nmatches, int flags));
#endif
#ifndef Tcl_RegExpGetInfo_TCL_DECLARED
#define Tcl_RegExpGetInfo_TCL_DECLARED
/* 377 */
EXTERN void		Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp, 
				Tcl_RegExpInfo * infoPtr));
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
EXTERN void		Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr, 
				CONST Tcl_UniChar * unicode, int length));
#endif
#ifndef Tcl_RegExpMatchObj_TCL_DECLARED
#define Tcl_RegExpMatchObj_TCL_DECLARED
/* 385 */
EXTERN int		Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * stringObj, Tcl_Obj * patternObj));
#endif
#ifndef Tcl_SetNotifier_TCL_DECLARED
#define Tcl_SetNotifier_TCL_DECLARED
/* 386 */
EXTERN void		Tcl_SetNotifier _ANSI_ARGS_((
				Tcl_NotifierProcs * notifierProcPtr));
#endif







|







2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
EXTERN void		Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr, 
				CONST Tcl_UniChar * unicode, int length));
#endif
#ifndef Tcl_RegExpMatchObj_TCL_DECLARED
#define Tcl_RegExpMatchObj_TCL_DECLARED
/* 385 */
EXTERN int		Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * textObj, Tcl_Obj * patternObj));
#endif
#ifndef Tcl_SetNotifier_TCL_DECLARED
#define Tcl_SetNotifier_TCL_DECLARED
/* 386 */
EXTERN void		Tcl_SetNotifier _ANSI_ARGS_((
				Tcl_NotifierProcs * notifierProcPtr));
#endif
2593
2594
2595
2596
2597
2598
2599
2600
2601

2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
EXTERN int		Tcl_IsChannelExisting _ANSI_ARGS_((
				CONST char* channelName));
#endif
#ifndef Tcl_UniCharNcasecmp_TCL_DECLARED
#define Tcl_UniCharNcasecmp_TCL_DECLARED
/* 419 */
EXTERN int		Tcl_UniCharNcasecmp _ANSI_ARGS_((
				CONST Tcl_UniChar * cs, 
				CONST Tcl_UniChar * ct, unsigned long n));

#endif
#ifndef Tcl_UniCharCaseMatch_TCL_DECLARED
#define Tcl_UniCharCaseMatch_TCL_DECLARED
/* 420 */
EXTERN int		Tcl_UniCharCaseMatch _ANSI_ARGS_((
				CONST Tcl_UniChar * ustr, 
				CONST Tcl_UniChar * pattern, int nocase));
#endif
#ifndef Tcl_FindHashEntry_TCL_DECLARED
#define Tcl_FindHashEntry_TCL_DECLARED
/* 421 */
EXTERN Tcl_HashEntry *	Tcl_FindHashEntry _ANSI_ARGS_((
				Tcl_HashTable * tablePtr, CONST char * key));
#endif







|
|
>





|
|







2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
EXTERN int		Tcl_IsChannelExisting _ANSI_ARGS_((
				CONST char* channelName));
#endif
#ifndef Tcl_UniCharNcasecmp_TCL_DECLARED
#define Tcl_UniCharNcasecmp_TCL_DECLARED
/* 419 */
EXTERN int		Tcl_UniCharNcasecmp _ANSI_ARGS_((
				CONST Tcl_UniChar * ucs, 
				CONST Tcl_UniChar * uct, 
				unsigned long numChars));
#endif
#ifndef Tcl_UniCharCaseMatch_TCL_DECLARED
#define Tcl_UniCharCaseMatch_TCL_DECLARED
/* 420 */
EXTERN int		Tcl_UniCharCaseMatch _ANSI_ARGS_((
				CONST Tcl_UniChar * uniStr, 
				CONST Tcl_UniChar * uniPattern, int nocase));
#endif
#ifndef Tcl_FindHashEntry_TCL_DECLARED
#define Tcl_FindHashEntry_TCL_DECLARED
/* 421 */
EXTERN Tcl_HashEntry *	Tcl_FindHashEntry _ANSI_ARGS_((
				Tcl_HashTable * tablePtr, CONST char * key));
#endif
3351
3352
3353
3354
3355
3356
3357









































































































































































3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
#endif
#ifndef Tcl_GetReturnOptions_TCL_DECLARED
#define Tcl_GetReturnOptions_TCL_DECLARED
/* 539 */
EXTERN Tcl_Obj *	Tcl_GetReturnOptions _ANSI_ARGS_((
				Tcl_Interp * interp, int result));
#endif










































































































































































typedef struct TclStubHooks {
    struct TclPlatStubs *tclPlatStubs;
    struct TclIntStubs *tclIntStubs;
    struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) /* UNIX */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|







3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
#endif
#ifndef Tcl_GetReturnOptions_TCL_DECLARED
#define Tcl_GetReturnOptions_TCL_DECLARED
/* 539 */
EXTERN Tcl_Obj *	Tcl_GetReturnOptions _ANSI_ARGS_((
				Tcl_Interp * interp, int result));
#endif
#ifndef Tcl_IsEnsemble_TCL_DECLARED
#define Tcl_IsEnsemble_TCL_DECLARED
/* 540 */
EXTERN int		Tcl_IsEnsemble _ANSI_ARGS_((Tcl_Command token));
#endif
#ifndef Tcl_CreateEnsemble_TCL_DECLARED
#define Tcl_CreateEnsemble_TCL_DECLARED
/* 541 */
EXTERN Tcl_Command	Tcl_CreateEnsemble _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, 
				Tcl_Namespace * namespacePtr, int flags));
#endif
#ifndef Tcl_FindEnsemble_TCL_DECLARED
#define Tcl_FindEnsemble_TCL_DECLARED
/* 542 */
EXTERN Tcl_Command	Tcl_FindEnsemble _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * cmdNameObj, int flags));
#endif
#ifndef Tcl_SetEnsembleSubcommandList_TCL_DECLARED
#define Tcl_SetEnsembleSubcommandList_TCL_DECLARED
/* 543 */
EXTERN int		Tcl_SetEnsembleSubcommandList _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Obj * subcmdList));
#endif
#ifndef Tcl_SetEnsembleMappingDict_TCL_DECLARED
#define Tcl_SetEnsembleMappingDict_TCL_DECLARED
/* 544 */
EXTERN int		Tcl_SetEnsembleMappingDict _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Obj * mapDict));
#endif
#ifndef Tcl_SetEnsembleUnknownHandler_TCL_DECLARED
#define Tcl_SetEnsembleUnknownHandler_TCL_DECLARED
/* 545 */
EXTERN int		Tcl_SetEnsembleUnknownHandler _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Obj * unknownList));
#endif
#ifndef Tcl_SetEnsembleFlags_TCL_DECLARED
#define Tcl_SetEnsembleFlags_TCL_DECLARED
/* 546 */
EXTERN int		Tcl_SetEnsembleFlags _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				int flags));
#endif
#ifndef Tcl_GetEnsembleSubcommandList_TCL_DECLARED
#define Tcl_GetEnsembleSubcommandList_TCL_DECLARED
/* 547 */
EXTERN int		Tcl_GetEnsembleSubcommandList _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Obj ** subcmdListPtr));
#endif
#ifndef Tcl_GetEnsembleMappingDict_TCL_DECLARED
#define Tcl_GetEnsembleMappingDict_TCL_DECLARED
/* 548 */
EXTERN int		Tcl_GetEnsembleMappingDict _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Obj ** mapDictPtr));
#endif
#ifndef Tcl_GetEnsembleUnknownHandler_TCL_DECLARED
#define Tcl_GetEnsembleUnknownHandler_TCL_DECLARED
/* 549 */
EXTERN int		Tcl_GetEnsembleUnknownHandler _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Obj ** unknownListPtr));
#endif
#ifndef Tcl_GetEnsembleFlags_TCL_DECLARED
#define Tcl_GetEnsembleFlags_TCL_DECLARED
/* 550 */
EXTERN int		Tcl_GetEnsembleFlags _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				int * flagsPtr));
#endif
#ifndef Tcl_GetEnsembleNamespace_TCL_DECLARED
#define Tcl_GetEnsembleNamespace_TCL_DECLARED
/* 551 */
EXTERN int		Tcl_GetEnsembleNamespace _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command token, 
				Tcl_Namespace ** namespacePtrPtr));
#endif
#ifndef Tcl_SetTimeProc_TCL_DECLARED
#define Tcl_SetTimeProc_TCL_DECLARED
/* 552 */
EXTERN void		Tcl_SetTimeProc _ANSI_ARGS_((
				Tcl_GetTimeProc* getProc, 
				Tcl_ScaleTimeProc* scaleProc, 
				ClientData clientData));
#endif
#ifndef Tcl_QueryTimeProc_TCL_DECLARED
#define Tcl_QueryTimeProc_TCL_DECLARED
/* 553 */
EXTERN void		Tcl_QueryTimeProc _ANSI_ARGS_((
				Tcl_GetTimeProc** getProc, 
				Tcl_ScaleTimeProc** scaleProc, 
				ClientData* clientData));
#endif
#ifndef Tcl_ChannelThreadActionProc_TCL_DECLARED
#define Tcl_ChannelThreadActionProc_TCL_DECLARED
/* 554 */
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
#endif
#ifndef Tcl_NewBignumObj_TCL_DECLARED
#define Tcl_NewBignumObj_TCL_DECLARED
/* 555 */
EXTERN Tcl_Obj*		Tcl_NewBignumObj _ANSI_ARGS_((mp_int* value));
#endif
#ifndef Tcl_DbNewBignumObj_TCL_DECLARED
#define Tcl_DbNewBignumObj_TCL_DECLARED
/* 556 */
EXTERN Tcl_Obj*		Tcl_DbNewBignumObj _ANSI_ARGS_((mp_int* value, 
				CONST char* file, int line));
#endif
#ifndef Tcl_SetBignumObj_TCL_DECLARED
#define Tcl_SetBignumObj_TCL_DECLARED
/* 557 */
EXTERN void		Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj, 
				mp_int* value));
#endif
#ifndef Tcl_GetBignumFromObj_TCL_DECLARED
#define Tcl_GetBignumFromObj_TCL_DECLARED
/* 558 */
EXTERN int		Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp, 
				Tcl_Obj* obj, mp_int* value));
#endif
#ifndef Tcl_GetBignumAndClearObj_TCL_DECLARED
#define Tcl_GetBignumAndClearObj_TCL_DECLARED
/* 559 */
EXTERN int		Tcl_GetBignumAndClearObj _ANSI_ARGS_((
				Tcl_Interp* interp, Tcl_Obj* obj, 
				mp_int* value));
#endif
#ifndef Tcl_TruncateChannel_TCL_DECLARED
#define Tcl_TruncateChannel_TCL_DECLARED
/* 560 */
EXTERN int		Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_WideInt length));
#endif
#ifndef Tcl_ChannelTruncateProc_TCL_DECLARED
#define Tcl_ChannelTruncateProc_TCL_DECLARED
/* 561 */
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
#endif
#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED
#define Tcl_SetChannelErrorInterp_TCL_DECLARED
/* 562 */
EXTERN void		Tcl_SetChannelErrorInterp _ANSI_ARGS_((
				Tcl_Interp* interp, Tcl_Obj* msg));
#endif
#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED
#define Tcl_GetChannelErrorInterp_TCL_DECLARED
/* 563 */
EXTERN void		Tcl_GetChannelErrorInterp _ANSI_ARGS_((
				Tcl_Interp* interp, Tcl_Obj** msg));
#endif
#ifndef Tcl_SetChannelError_TCL_DECLARED
#define Tcl_SetChannelError_TCL_DECLARED
/* 564 */
EXTERN void		Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_Obj* msg));
#endif
#ifndef Tcl_GetChannelError_TCL_DECLARED
#define Tcl_GetChannelError_TCL_DECLARED
/* 565 */
EXTERN void		Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_Obj** msg));
#endif

typedef struct TclStubHooks {
    struct TclPlatStubs *tclPlatStubs;
    struct TclIntStubs *tclIntStubs;
    struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_((CONST char *format, ...)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) /* UNIX */
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
    void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
    void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
    int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
    int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
    void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */
    void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
    int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
    void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
    void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
    int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
    Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char * bytes, int length, CONST char * file, int line)); /* 23 */
    Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char * file, int line)); /* 24 */
    Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST * objv, CONST char * file, int line)); /* 25 */
    Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */
    Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */
    Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */
    Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */
    void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */
    int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * boolPtr)); /* 31 */
    int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */
    unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */
    int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * doublePtr)); /* 34 */
    int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */
    int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */
    int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * intPtr)); /* 37 */
    int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */
    int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */
    Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */
    char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */
    void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */
    int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr)); /* 43 */
    int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */







|















|


|


|







3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
    void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */
    void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
    int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
    int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
    void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */
    void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
    int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
    void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
    void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
    int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
    Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char * bytes, int length, CONST char * file, int line)); /* 23 */
    Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char * file, int line)); /* 24 */
    Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST * objv, CONST char * file, int line)); /* 25 */
    Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */
    Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */
    Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */
    Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */
    void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */
    int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * boolPtr)); /* 31 */
    int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */
    unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */
    int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, double * doublePtr)); /* 34 */
    int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */
    int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */
    int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * intPtr)); /* 37 */
    int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */
    int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */
    Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */
    char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */
    void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */
    int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr)); /* 43 */
    int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
    void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */
    void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
    void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
    void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
    void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
    void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
    void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
    void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 69 */
    void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */
    Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
    void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
    int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
    void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */







|
|







3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
    void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */
    void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
    void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
    void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
    void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
    void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
    void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
    void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */
    void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */
    Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
    void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
    int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */
    void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
    void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* __WIN32__ */
    void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */
    void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Trace trace)); /* 113 */
    void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */
    int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */
    void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */
    char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * str, int length)); /* 117 */
    char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string)); /* 118 */
    void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */
    void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
    void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */
    void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */
    void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */
    void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
    void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
    int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
    CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
    CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
    int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */
    int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
    int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
    void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
    void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
    int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
    int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
    int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
    int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
    int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
    int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
    int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
    int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
    int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
    void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
    void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
    Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
    int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
    void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
    int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */
    int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */







|
|










|





|

|

|


|







3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
    void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* __WIN32__ */
    void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */
    void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Trace trace)); /* 113 */
    void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */
    int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */
    void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */
    char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * bytes, int length)); /* 117 */
    char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * element)); /* 118 */
    void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */
    void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
    void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */
    void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */
    void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */
    void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
    void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
    int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
    CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
    CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
    int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script)); /* 129 */
    int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
    int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
    void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
    void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
    int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
    int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, int * ptr)); /* 135 */
    int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
    int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, double * ptr)); /* 137 */
    int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
    int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, long * ptr)); /* 139 */
    int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
    int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
    int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr)); /* 142 */
    void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
    void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
    Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
    int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
    void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
    int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */
    int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
    int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
    CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
    int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
    Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
    CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
    Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !defined(__WIN32__) /* UNIX */
    int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved167;
#endif /* __WIN32__ */
    Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
    int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
    int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */







|







3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
    int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
    CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
    int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
    Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
    CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
    Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !defined(__WIN32__) /* UNIX */
    int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanID, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved167;
#endif /* __WIN32__ */
    Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
    int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
    int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
    Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* __WIN32__ */
    Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
    Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
    Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
    void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
    void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
    int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */
    CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
    void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
    int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
#if !defined(__WIN32__) /* UNIX */
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* __WIN32__ */
    int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */
    int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */
    void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */
    void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */
    Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 212 */
    int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */
    int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST char * pattern)); /* 214 */
    void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */
    void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */
    void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */
    int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */
    int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */
    int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
    int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
    int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
    void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
    void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
    int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
    int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
    void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
    void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
    void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
    void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
    CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */
    CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
    CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */







|













|
|
|













|



|







3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
    Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* __WIN32__ */
    Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
    Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
    Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
    void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
    void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
    int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * assignment)); /* 203 */
    CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
    void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
    int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
#if !defined(__WIN32__) /* UNIX */
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* __WIN32__ */
    int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */
    int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */
    void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */
    void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */
    Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 212 */
    int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * text, CONST char * start)); /* 213 */
    int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * text, CONST char * pattern)); /* 214 */
    void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */
    void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */
    void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */
    int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */
    int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */
    int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
    int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
    int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
    void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
    void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
    int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
    int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
    void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
    void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */
    void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
    void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
    CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */
    CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
    CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
    void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
    CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
    CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */
    CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
    CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */
    int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */
    CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
    void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
    int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
    Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */







|









|







3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
    void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
    CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
    CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, CONST84 char ** termPtr)); /* 270 */
    CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
    CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */
    int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */
    CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
    void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
    int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
    Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
    VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
    Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */
    ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
    void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
    void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
    void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
    void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
    int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */
    int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
    void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
    void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
    int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
    Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
    void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
    void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
    Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
    Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
    Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
    Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
    int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
    CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
    int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
    int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
    CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
    CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
    CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
    CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
    int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
    char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */







|













|







3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
    VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
    Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */
    ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
    void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
    void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
    void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
    void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
    int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int length)); /* 312 */
    int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
    void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
    void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
    int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
    Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
    void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
    void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
    Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
    Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
    Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
    Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
    int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
    CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
    int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int length)); /* 326 */
    int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
    CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
    CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
    CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
    CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
    int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
    char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
    int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
    int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
    int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
    int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
    int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
    int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
    int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
    int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */
    int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */
    char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
    Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
    Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
    Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
    void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
    void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
    int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */
    int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
    int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
    int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */
    int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
    char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
    int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
    int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
    int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */
    int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */
    int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 370 */
    int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */
    int (*tcl_UniCharIsControl) _ANSI_ARGS_((int ch)); /* 372 */
    int (*tcl_UniCharIsGraph) _ANSI_ARGS_((int ch)); /* 373 */
    int (*tcl_UniCharIsPrint) _ANSI_ARGS_((int ch)); /* 374 */
    int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */
    int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * objPtr, int offset, int nmatches, int flags)); /* 376 */
    void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */
    Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */
    void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */
    int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */
    Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */
    Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */
    Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */
    void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */
    int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); /* 385 */
    void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */
    Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */
    int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */
    int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */
    int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */
    void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
    void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */







|
|
|
|




|
|
|
|
|











|








|







3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
    int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
    int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
    int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
    int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
    int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
    int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
    int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
    int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr)); /* 352 */
    int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); /* 353 */
    char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr, int uniLength, Tcl_DString * dsPtr)); /* 354 */
    Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * src, int length, Tcl_DString * dsPtr)); /* 355 */
    Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
    Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
    void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
    void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
    int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */
    int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
    int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
    int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */
    int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
    char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
    int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
    int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
    int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */
    int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */
    int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 370 */
    int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */
    int (*tcl_UniCharIsControl) _ANSI_ARGS_((int ch)); /* 372 */
    int (*tcl_UniCharIsGraph) _ANSI_ARGS_((int ch)); /* 373 */
    int (*tcl_UniCharIsPrint) _ANSI_ARGS_((int ch)); /* 374 */
    int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */
    int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * textObj, int offset, int nmatches, int flags)); /* 376 */
    void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */
    Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */
    void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */
    int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */
    Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */
    Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */
    Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */
    void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */
    int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * textObj, Tcl_Obj * patternObj)); /* 385 */
    void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */
    Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */
    int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */
    int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */
    int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */
    void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
    void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
    int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 412 */
    int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */
    int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */
    void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */
    void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */
    void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */
    int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */
    int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 419 */
    int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); /* 420 */
    Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */
    Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */
    void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */
    void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */
    ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */
    int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 426 */
    void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 427 */







|
|







3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
    int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 412 */
    int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */
    int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */
    void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */
    void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */
    void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */
    int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */
    int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); /* 419 */
    int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr, CONST Tcl_UniChar * uniPattern, int nocase)); /* 420 */
    Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */
    Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */
    void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */
    void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */
    ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */
    int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 426 */
    void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 427 */
3932
3933
3934
3935
3936
3937
3938


























3939
3940
3941
3942
3943
3944
3945
    void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */
    int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */
    Tcl_InterpState (*tcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp * interp, int status)); /* 535 */
    int (*tcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpState state)); /* 536 */
    void (*tcl_DiscardInterpState) _ANSI_ARGS_((Tcl_InterpState state)); /* 537 */
    int (*tcl_SetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * options)); /* 538 */
    Tcl_Obj * (*tcl_GetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, int result)); /* 539 */


























} TclStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclStubs *tclStubsPtr;
#ifdef __cplusplus







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
    void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */
    int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */
    Tcl_InterpState (*tcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp * interp, int status)); /* 535 */
    int (*tcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpState state)); /* 536 */
    void (*tcl_DiscardInterpState) _ANSI_ARGS_((Tcl_InterpState state)); /* 537 */
    int (*tcl_SetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * options)); /* 538 */
    Tcl_Obj * (*tcl_GetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, int result)); /* 539 */
    int (*tcl_IsEnsemble) _ANSI_ARGS_((Tcl_Command token)); /* 540 */
    Tcl_Command (*tcl_CreateEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * namespacePtr, int flags)); /* 541 */
    Tcl_Command (*tcl_FindEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdNameObj, int flags)); /* 542 */
    int (*tcl_SetEnsembleSubcommandList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * subcmdList)); /* 543 */
    int (*tcl_SetEnsembleMappingDict) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * mapDict)); /* 544 */
    int (*tcl_SetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * unknownList)); /* 545 */
    int (*tcl_SetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int flags)); /* 546 */
    int (*tcl_GetEnsembleSubcommandList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** subcmdListPtr)); /* 547 */
    int (*tcl_GetEnsembleMappingDict) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** mapDictPtr)); /* 548 */
    int (*tcl_GetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** unknownListPtr)); /* 549 */
    int (*tcl_GetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int * flagsPtr)); /* 550 */
    int (*tcl_GetEnsembleNamespace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Namespace ** namespacePtrPtr)); /* 551 */
    void (*tcl_SetTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); /* 552 */
    void (*tcl_QueryTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); /* 553 */
    Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */
    Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 555 */
    Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */
    void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */
    int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */
    int (*tcl_GetBignumAndClearObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 559 */
    int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 560 */
    Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 561 */
    void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 562 */
    void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 563 */
    void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 564 */
    void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 565 */
} TclStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclStubs *tclStubsPtr;
#ifdef __cplusplus
6132
6133
6134
6135
6136
6137
6138








































































































6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
#define Tcl_SetReturnOptions \
	(tclStubsPtr->tcl_SetReturnOptions) /* 538 */
#endif
#ifndef Tcl_GetReturnOptions
#define Tcl_GetReturnOptions \
	(tclStubsPtr->tcl_GetReturnOptions) /* 539 */
#endif









































































































#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLDECLS */








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
#define Tcl_SetReturnOptions \
	(tclStubsPtr->tcl_SetReturnOptions) /* 538 */
#endif
#ifndef Tcl_GetReturnOptions
#define Tcl_GetReturnOptions \
	(tclStubsPtr->tcl_GetReturnOptions) /* 539 */
#endif
#ifndef Tcl_IsEnsemble
#define Tcl_IsEnsemble \
	(tclStubsPtr->tcl_IsEnsemble) /* 540 */
#endif
#ifndef Tcl_CreateEnsemble
#define Tcl_CreateEnsemble \
	(tclStubsPtr->tcl_CreateEnsemble) /* 541 */
#endif
#ifndef Tcl_FindEnsemble
#define Tcl_FindEnsemble \
	(tclStubsPtr->tcl_FindEnsemble) /* 542 */
#endif
#ifndef Tcl_SetEnsembleSubcommandList
#define Tcl_SetEnsembleSubcommandList \
	(tclStubsPtr->tcl_SetEnsembleSubcommandList) /* 543 */
#endif
#ifndef Tcl_SetEnsembleMappingDict
#define Tcl_SetEnsembleMappingDict \
	(tclStubsPtr->tcl_SetEnsembleMappingDict) /* 544 */
#endif
#ifndef Tcl_SetEnsembleUnknownHandler
#define Tcl_SetEnsembleUnknownHandler \
	(tclStubsPtr->tcl_SetEnsembleUnknownHandler) /* 545 */
#endif
#ifndef Tcl_SetEnsembleFlags
#define Tcl_SetEnsembleFlags \
	(tclStubsPtr->tcl_SetEnsembleFlags) /* 546 */
#endif
#ifndef Tcl_GetEnsembleSubcommandList
#define Tcl_GetEnsembleSubcommandList \
	(tclStubsPtr->tcl_GetEnsembleSubcommandList) /* 547 */
#endif
#ifndef Tcl_GetEnsembleMappingDict
#define Tcl_GetEnsembleMappingDict \
	(tclStubsPtr->tcl_GetEnsembleMappingDict) /* 548 */
#endif
#ifndef Tcl_GetEnsembleUnknownHandler
#define Tcl_GetEnsembleUnknownHandler \
	(tclStubsPtr->tcl_GetEnsembleUnknownHandler) /* 549 */
#endif
#ifndef Tcl_GetEnsembleFlags
#define Tcl_GetEnsembleFlags \
	(tclStubsPtr->tcl_GetEnsembleFlags) /* 550 */
#endif
#ifndef Tcl_GetEnsembleNamespace
#define Tcl_GetEnsembleNamespace \
	(tclStubsPtr->tcl_GetEnsembleNamespace) /* 551 */
#endif
#ifndef Tcl_SetTimeProc
#define Tcl_SetTimeProc \
	(tclStubsPtr->tcl_SetTimeProc) /* 552 */
#endif
#ifndef Tcl_QueryTimeProc
#define Tcl_QueryTimeProc \
	(tclStubsPtr->tcl_QueryTimeProc) /* 553 */
#endif
#ifndef Tcl_ChannelThreadActionProc
#define Tcl_ChannelThreadActionProc \
	(tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */
#endif
#ifndef Tcl_NewBignumObj
#define Tcl_NewBignumObj \
	(tclStubsPtr->tcl_NewBignumObj) /* 555 */
#endif
#ifndef Tcl_DbNewBignumObj
#define Tcl_DbNewBignumObj \
	(tclStubsPtr->tcl_DbNewBignumObj) /* 556 */
#endif
#ifndef Tcl_SetBignumObj
#define Tcl_SetBignumObj \
	(tclStubsPtr->tcl_SetBignumObj) /* 557 */
#endif
#ifndef Tcl_GetBignumFromObj
#define Tcl_GetBignumFromObj \
	(tclStubsPtr->tcl_GetBignumFromObj) /* 558 */
#endif
#ifndef Tcl_GetBignumAndClearObj
#define Tcl_GetBignumAndClearObj \
	(tclStubsPtr->tcl_GetBignumAndClearObj) /* 559 */
#endif
#ifndef Tcl_TruncateChannel
#define Tcl_TruncateChannel \
	(tclStubsPtr->tcl_TruncateChannel) /* 560 */
#endif
#ifndef Tcl_ChannelTruncateProc
#define Tcl_ChannelTruncateProc \
	(tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */
#endif
#ifndef Tcl_SetChannelErrorInterp
#define Tcl_SetChannelErrorInterp \
	(tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */
#endif
#ifndef Tcl_GetChannelErrorInterp
#define Tcl_GetChannelErrorInterp \
	(tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */
#endif
#ifndef Tcl_SetChannelError
#define Tcl_SetChannelError \
	(tclStubsPtr->tcl_SetChannelError) /* 564 */
#endif
#ifndef Tcl_GetChannelError
#define Tcl_GetChannelError \
	(tclStubsPtr->tcl_GetChannelError) /* 565 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLDECLS */

Changes to generic/tclDictObj.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
/* 
 * tclDictObj.c --
 *
 *	This file contains procedures that implement the Tcl dict object
 *	type and its accessor command.
 *
 * Copyright (c) 2002 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDictObj.c,v 1.27 2004/11/13 00:19:09 dgp Exp $
 */

#include "tclInt.h"


/*
 * Forward declaration.
 */
struct Dict;

/*
 * Flag values for TraceDictPath().
 *
 * DICT_PATH_READ indicates that all entries on the path must exist
 * but no updates will be needed.
 *
 * DICT_PATH_UPDATE indicates that we are going to be doing an update
 * at the tip of the path, so duplication of shared objects should be
 * done along the way.
 *
 * DICT_PATH_EXISTS indicates that we are performing an existance test
 * and a lookup failure should therefore not be an error.  If (and
 * only if) this flag is set, TraceDictPath() will return the special
 * value DICT_PATH_NON_EXISTENT if the path is not traceable.
 *
 * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to
 * be set) indicates that we are to create non-existant dictionaries
 * on the path.
 */

#define DICT_PATH_READ   0
#define DICT_PATH_UPDATE 1
#define DICT_PATH_EXISTS 2
#define DICT_PATH_CREATE 5

#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1)

/*
 * Prototypes for procedures defined later in this file:
 */

static void		DeleteDict _ANSI_ARGS_((struct Dict *dict));
static int		DictAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST *objv));











|



>






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22



























23
24
25
26
27
28
29
/* 
 * tclDictObj.c --
 *
 *	This file contains procedures that implement the Tcl dict object
 *	type and its accessor command.
 *
 * Copyright (c) 2002 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.5 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
 */
struct Dict;




























/*
 * Prototypes for procedures defined later in this file:
 */

static void		DeleteDict _ANSI_ARGS_((struct Dict *dict));
static int		DictAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST *objv));
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
			    int objc, Tcl_Obj *CONST *objv));
static void		DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static void		FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr));
static void		InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj));
static int		SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static Tcl_Obj *	TraceDictPath _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[],
			    int flags));
static void		UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr));

/*
 * Internal representation of a dictionary.
 *
 * The internal representation of a dictionary object is a hash table
 * (with Tcl_Objs for both keys and values), a reference count and







<
<
<







65
66
67
68
69
70
71



72
73
74
75
76
77
78
			    int objc, Tcl_Obj *CONST *objv));
static void		DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static void		FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr));
static void		InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj));
static int		SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));



static void		UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr));

/*
 * Internal representation of a dictionary.
 *
 * The internal representation of a dictionary object is a hash table
 * (with Tcl_Objs for both keys and values), a reference count and
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
    ckfree((char *) dict);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceDictPath --
 *
 *	Trace through a tree of dictionaries using the array of keys
 *	given. If the flags argument has the DICT_PATH_UPDATE flag is
 *	set, a backward-pointing chain of dictionaries is also built
 *	(in the Dict's chain field) and the chained dictionaries are
 *	made into unshared dictionaries (if they aren't already.)
 *







|







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
    ckfree((char *) dict);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceDictPath --
 *
 *	Trace through a tree of dictionaries using the array of keys
 *	given. If the flags argument has the DICT_PATH_UPDATE flag is
 *	set, a backward-pointing chain of dictionaries is also built
 *	(in the Dict's chain field) and the chained dictionaries are
 *	made into unshared dictionaries (if they aren't already.)
 *
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
 *	DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit),
 *	non-existant keys will be inserted with a value of an empty
 *	dictionary, resulting in the path being built.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
TraceDictPath(interp, dictPtr, keyc, keyv, flags)
    Tcl_Interp *interp;
    Tcl_Obj *dictPtr, *CONST keyv[];
    int keyc, flags;
{
    Dict *dict, *newDict;
    int i;








|
|







586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
 *	DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit),
 *	non-existant keys will be inserted with a value of an empty
 *	dictionary, resulting in the path being built.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclTraceDictPath(interp, dictPtr, keyc, keyv, flags)
    Tcl_Interp *interp;
    Tcl_Obj *dictPtr, *CONST keyv[];
    int keyc, flags;
{
    Dict *dict, *newDict;
    int i;

693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708

/*
 *----------------------------------------------------------------------
 *
 * InvalidateDictChain --
 *
 *	Go through a dictionary chain (built by an updating invokation
 *	of TraceDictPath) and invalidate the string representations of
 *	all the dictionaries on the chain.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	String reps are invalidated and epoch counters (for detecting
 *	illegal concurrent modifications) are updated through the







|
|







664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679

/*
 *----------------------------------------------------------------------
 *
 * InvalidateDictChain --
 *
 *	Go through a dictionary chain (built by an updating invokation
 *	of TclTraceDictPath) and invalidate the string representations
 *	of all the dictionaries on the chain.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	String reps are invalidated and epoch counters (for detecting
 *	illegal concurrent modifications) are updated through the
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("Tcl_DictObjPutKeyList called with shared object");
    }
    if (keyc < 1) {
	Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list");
    }

    dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_CREATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = (Dict *) dictPtr->internalRep.otherValuePtr;
    hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[keyc-1], &isNew);
    Tcl_IncrRefCount(valuePtr);







|







1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("Tcl_DictObjPutKeyList called with shared object");
    }
    if (keyc < 1) {
	Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list");
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = (Dict *) dictPtr->internalRep.otherValuePtr;
    hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[keyc-1], &isNew);
    Tcl_IncrRefCount(valuePtr);
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("Tcl_DictObjRemoveKeyList called with shared object");
    }
    if (keyc < 1) {
	Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list");
    }

    dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_UPDATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = (Dict *) dictPtr->internalRep.otherValuePtr;
    hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[keyc-1]);
    if (hPtr != NULL) {







|







1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("Tcl_DictObjRemoveKeyList called with shared object");
    }
    if (keyc < 1) {
	Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list");
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }

    dict = (Dict *) dictPtr->internalRep.otherValuePtr;
    hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[keyc-1]);
    if (hPtr != NULL) {
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
     * current index in the current dictionary each time.  Once we've
     * done the lookup, we set the current dictionary to be the value
     * we looked up (in case the value was not the last one and we are
     * going through a chain of searches.)  Note that this loop always
     * executes at least once.
     */

    dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_READ);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
    result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
    if (result != TCL_OK) {
	return result;
    }







|







1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
     * current index in the current dictionary each time.  Once we've
     * done the lookup, we set the current dictionary to be the value
     * we looked up (in case the value was not the last one and we are
     * going through a chain of searches.)  Note that this loop always
     * executes at least once.
     */

    dictPtr = TclTraceDictPath(interp, objv[2], objc-4,objv+3, DICT_PATH_READ);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
    result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
    if (result != TCL_OK) {
	return result;
    }
1667
1668
1669
1670
1671
1672
1673








1674
1675
1676
1677
1678
1679
1680
1681

1682
1683
1684
1685
1686
1687
1688
    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc == 4) {
	pattern = TclGetString(objv[3]);
    }
    listPtr = Tcl_NewListObj(0, NULL);








    for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) {
	if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) {
	    /*
	     * Assume this operation always succeeds.
	     */
	    Tcl_ListObjAppendElement(interp, listPtr, keyPtr);
	}
    }

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







>
>
>
>
>
>
>
>








>







1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc == 4) {
	pattern = TclGetString(objv[3]);
    }
    listPtr = Tcl_NewListObj(0, NULL);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
	Tcl_Obj *valuePtr = NULL;
	Tcl_DictObjGet(interp, objv[2], objv[3], &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
	}
	goto searchDone;
    }
    for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) {
	if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) {
	    /*
	     * Assume this operation always succeeds.
	     */
	    Tcl_ListObjAppendElement(interp, listPtr, keyPtr);
	}
    }
searchDone:
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
1802
1803
1804
1805
1806
1807
1808
1809

1810
1811
1812
1813
1814
1815
1816
    int result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary key ?key ...?");
	return TCL_ERROR;
    }

    dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_EXISTS);

    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
    if (dictPtr == DICT_PATH_NON_EXISTENT) {
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
	return TCL_OK;
    }







|
>







1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
    int result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary key ?key ...?");
	return TCL_ERROR;
    }

    dictPtr = TclTraceDictPath(interp, objv[2], objc-4, objv+3,
	    DICT_PATH_EXISTS);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
    if (dictPtr == DICT_PATH_NON_EXISTENT) {
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
	return TCL_OK;
    }
1889
1890
1891
1892
1893
1894
1895

1896
1897
1898
1899
1900




1901
1902
1903
1904
1905
1906

1907
1908
1909
1910
1911
1912
1913

static int
DictIncrCmd(interp, objc, objv)
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST *objv;
{

    Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
    int result, isWide = 0;
    long incrValue = 1;
    Tcl_WideInt wideIncrValue = 0;
    int allocatedDict = 0;





    if (objc < 4 || objc > 5) {
	Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?");
	return TCL_ERROR;
    }


    if (objc == 5) {
	if (objv[4]->typePtr == &tclIntType) {
	    incrValue = objv[4]->internalRep.longValue;
	} else if (objv[4]->typePtr == &tclWideIntType) {
	    wideIncrValue = objv[4]->internalRep.wideValue;
	    isWide = 1;
	} else {







>
|




>
>
>
>






>







1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900

static int
DictIncrCmd(interp, objc, objv)
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST *objv;
{
#if 0
    Tcl_Obj *dictPtr, *resultPtr;
    int result, isWide = 0;
    long incrValue = 1;
    Tcl_WideInt wideIncrValue = 0;
    int allocatedDict = 0;
#else
    int code = TCL_OK;
    Tcl_Obj *dictPtr, *valuePtr = NULL;
#endif

    if (objc < 4 || objc > 5) {
	Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?");
	return TCL_ERROR;
    }

#if 0
    if (objc == 5) {
	if (objv[4]->typePtr == &tclIntType) {
	    incrValue = objv[4]->internalRep.longValue;
	} else if (objv[4]->typePtr == &tclWideIntType) {
	    wideIncrValue = objv[4]->internalRep.wideValue;
	    isWide = 1;
	} else {
2056
2057
2058
2059
2060
2061
2062





























































2063
2064
2065
2066
2067
2068
2069
	    TCL_LEAVE_ERR_MSG);
    TclDecrRefCount(dictPtr);
    if (resultPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;





























































}

/*
 *----------------------------------------------------------------------
 *
 * DictLappendCmd --
 *







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
	    TCL_LEAVE_ERR_MSG);
    TclDecrRefCount(dictPtr);
    if (resultPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
#else
    dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
    if (dictPtr == NULL) {
	/* Variable didn't yet exist.  Create new dictionary value */
	dictPtr = Tcl_NewDictObj();
    } else if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) {
	/* Variable contents are not a dict, report error */
	return TCL_ERROR;
    }
    if (Tcl_IsShared(dictPtr)) {
	/* A little internals surgery to avoid copying a string rep
	 * that will soon be no good */
	char *saved = dictPtr->bytes;
	dictPtr->bytes = NULL;
	dictPtr = Tcl_DuplicateObj(dictPtr);
	dictPtr->bytes = saved;
    }
    if (valuePtr == NULL) {
	/* Key not in dictionary.  Create new key with increment as value */
	if (objc == 5) {
	    /* Verify increment is an integer */
	    mp_int increment;
	    code = Tcl_GetBignumFromObj(interp, objv[4], &increment);
	    if (code != TCL_OK) {
		Tcl_AddErrorInfo(interp, "\n    (reading increment)");
	    } else {
		Tcl_DictObjPut(interp, dictPtr, objv[3], objv[4]);
	    }
	} else {
	    Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(1));
	}
    } else {
	/* Key in dictionary.  Increment its value with minimum dup. */
	if (Tcl_IsShared(valuePtr)) {
	    valuePtr = Tcl_DuplicateObj(valuePtr);
	    Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr);
	}
	if (objc == 5) {
	    code = TclIncrObj(interp, valuePtr, objv[4]);
	} else {
	    Tcl_Obj *incrPtr = Tcl_NewIntObj(1);
	    Tcl_IncrRefCount(incrPtr);
	    code = TclIncrObj(interp, valuePtr, incrPtr);
	    Tcl_DecrRefCount(incrPtr);
	}
    }
    Tcl_IncrRefCount(dictPtr);
    if (code == TCL_OK) {
	Tcl_InvalidateStringRep(dictPtr);
	valuePtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
		dictPtr, TCL_LEAVE_ERR_MSG);
	if (valuePtr == NULL) {
	    code = TCL_ERROR;
	}
    }
    Tcl_DecrRefCount(dictPtr);
    if (code == TCL_OK) {
	Tcl_SetObjResult(interp, valuePtr);
    }
    return code;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * DictLappendCmd --
 *
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280

2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294

static int
DictForCmd(interp, objc, objv)
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST *objv;
{
    Tcl_Obj *dictObj, *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj;
    Tcl_DictSearch search;
    int varc, done, result;

    if (objc != 5) {
	Tcl_WrongNumArgs(interp, 2, objv,
		"{keyVar valueVar} dictionary script");
	return TCL_ERROR;
    }

    if (Tcl_ListObjGetElements(interp, objv[2], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));
	return TCL_ERROR;
    }
    keyVarObj = varv[0];
    valueVarObj = varv[1];
    dictObj = objv[3];
    scriptObj = objv[4];
    /*
     * Make sure that these objects (which we need throughout the body
     * of the loop) don't vanish.  Note that we also care that the
     * dictObj remains a dictionary, which requires slightly more
     * elaborate precautions.  That we achieve by making sure that the
     * type is static throughout and that the hash is the same hash
     * throughout; taking a copy of the whole thing would be easier,
     * but much less efficient.

     */
    Tcl_IncrRefCount(keyVarObj);
    Tcl_IncrRefCount(valueVarObj);
    Tcl_IncrRefCount(dictObj);
    Tcl_IncrRefCount(scriptObj);

    result = Tcl_DictObjFirst(interp, dictObj,
	    &search, &keyObj, &valueObj, &done);
    if (result != TCL_OK) {
	goto doneFor;
    }

    while (!done) {
	/*







|




















<


|
|
<
<
<
<
<
>



<


|







2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318

2319
2320
2321
2322





2323
2324
2325
2326

2327
2328
2329
2330
2331
2332
2333
2334
2335
2336

static int
DictForCmd(interp, objc, objv)
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST *objv;
{
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj;
    Tcl_DictSearch search;
    int varc, done, result;

    if (objc != 5) {
	Tcl_WrongNumArgs(interp, 2, objv,
		"{keyVar valueVar} dictionary script");
	return TCL_ERROR;
    }

    if (Tcl_ListObjGetElements(interp, objv[2], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));
	return TCL_ERROR;
    }
    keyVarObj = varv[0];
    valueVarObj = varv[1];

    scriptObj = objv[4];
    /*
     * Make sure that these objects (which we need throughout the body of the
     * loop) don't vanish.  Note that the dictionary internal rep is locked





     * internally so that updates, shimmering, etc are not a problem.
     */
    Tcl_IncrRefCount(keyVarObj);
    Tcl_IncrRefCount(valueVarObj);

    Tcl_IncrRefCount(scriptObj);

    result = Tcl_DictObjFirst(interp, objv[3],
	    &search, &keyObj, &valueObj, &done);
    if (result != TCL_OK) {
	goto doneFor;
    }

    while (!done) {
	/*
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
	result = Tcl_EvalObjEx(interp, scriptObj, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_BREAK) {
		result = TCL_OK;
	    } else if (result == TCL_ERROR) {
		char msg[32 + TCL_INTEGER_SPACE];

		sprintf(msg, "\n    (\"dict for\" body line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
	    }
	    break;
	}

	Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
    }

 doneFor:
    /*
     * Stop holding a reference to these objects.
     */
    TclDecrRefCount(keyVarObj);
    TclDecrRefCount(valueVarObj);
    TclDecrRefCount(dictObj);
    TclDecrRefCount(scriptObj);

    Tcl_DictObjDone(&search);
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;







<
|
|
<
<













<







2358
2359
2360
2361
2362
2363
2364

2365
2366


2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379

2380
2381
2382
2383
2384
2385
2386
	result = Tcl_EvalObjEx(interp, scriptObj, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_BREAK) {
		result = TCL_OK;
	    } else if (result == TCL_ERROR) {

		TclFormatToErrorInfo(interp,
			"\n    (\"dict for\" body line %d)", interp->errorLine);


	    }
	    break;
	}

	Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
    }

 doneFor:
    /*
     * Stop holding a reference to these objects.
     */
    TclDecrRefCount(keyVarObj);
    TclDecrRefCount(valueVarObj);

    TclDecrRefCount(scriptObj);

    Tcl_DictObjDone(&search);
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
{
    static CONST char *filters[] = {
	"key", "script", "value", NULL
    };
    enum FilterTypes {
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    };
    Tcl_Obj *dictObj, *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int index, varc, done, result, satisfied;
    char *pattern;
    char msg[32 + TCL_INTEGER_SPACE];

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType",
	     0, &index) != TCL_OK) {







|




<







2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544

2545
2546
2547
2548
2549
2550
2551
{
    static CONST char *filters[] = {
	"key", "script", "value", NULL
    };
    enum FilterTypes {
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    };
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int index, varc, done, result, satisfied;
    char *pattern;


    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType",
	     0, &index) != TCL_OK) {
2527
2528
2529
2530
2531
2532
2533






2534
2535
2536
2537
2538

2539
2540
2541
2542
2543
2544
2545
	 */
	if (Tcl_DictObjFirst(interp, objv[2], &search,
		&keyObj, &valueObj, &done) != TCL_OK) {
	    return TCL_ERROR;
	}
	pattern = TclGetString(objv[4]);
	resultObj = Tcl_NewDictObj();






	while (!done) {
	    if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
		Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
	    }
	    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);

	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;

    case FILTER_VALUES:
	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "dictionary value globPattern");







>
>
>
>
>
>
|
|
|
|
|
>







2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
	 */
	if (Tcl_DictObjFirst(interp, objv[2], &search,
		&keyObj, &valueObj, &done) != TCL_OK) {
	    return TCL_ERROR;
	}
	pattern = TclGetString(objv[4]);
	resultObj = Tcl_NewDictObj();
	if (TclMatchIsTrivial(pattern)) {
	    Tcl_DictObjGet(interp, objv[2], objv[4], &valueObj);
	    if (valueObj != NULL) {
		Tcl_DictObjPut(interp, resultObj, objv[4], valueObj);
	    }
	} else {
	    while (!done) {
		if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
		    Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
		}
		Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	    }
	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;

    case FILTER_VALUES:
	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "dictionary value globPattern");
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595

2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
	if (varc != 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "must have exactly two variable names", -1));
	    return TCL_ERROR;
	}
	keyVarObj = varv[0];
	valueVarObj = varv[1];
	dictObj = objv[2];
	scriptObj = objv[5];
	/*
	 * Make sure that these objects (which we need throughout the
	 * body of the loop) don't vanish.  Note that we also care

	 * that the dictObj remains a dictionary, which requires
	 * slightly more elaborate precautions.  That we achieve by
	 * making sure that the type is static throughout and that the
	 * hash is the same hash throughout; taking a copy of the
	 * whole thing would be easier, but much less efficient.
	 */
	Tcl_IncrRefCount(keyVarObj);
	Tcl_IncrRefCount(valueVarObj);
	Tcl_IncrRefCount(dictObj);
	Tcl_IncrRefCount(scriptObj);

	result = Tcl_DictObjFirst(interp, dictObj,
		&search, &keyObj, &valueObj, &done);
	if (result != TCL_OK) {
	    TclDecrRefCount(keyVarObj);
	    TclDecrRefCount(valueVarObj);
	    TclDecrRefCount(dictObj);
	    TclDecrRefCount(scriptObj);
	    return TCL_ERROR;
	}

	resultObj = Tcl_NewDictObj();

	while (!done) {







<


|
|
>
|
<
<
<
<



<


|




<







2628
2629
2630
2631
2632
2633
2634

2635
2636
2637
2638
2639
2640




2641
2642
2643

2644
2645
2646
2647
2648
2649
2650

2651
2652
2653
2654
2655
2656
2657
	if (varc != 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "must have exactly two variable names", -1));
	    return TCL_ERROR;
	}
	keyVarObj = varv[0];
	valueVarObj = varv[1];

	scriptObj = objv[5];
	/*
	 * Make sure that these objects (which we need throughout the body of
	 * the loop) don't vanish.  Note that the dictionary internal rep is
	 * locked internally so that updates, shimmering, etc are not a
	 * problem.




	 */
	Tcl_IncrRefCount(keyVarObj);
	Tcl_IncrRefCount(valueVarObj);

	Tcl_IncrRefCount(scriptObj);

	result = Tcl_DictObjFirst(interp, objv[2],
		&search, &keyObj, &valueObj, &done);
	if (result != TCL_OK) {
	    TclDecrRefCount(keyVarObj);
	    TclDecrRefCount(valueVarObj);

	    TclDecrRefCount(scriptObj);
	    return TCL_ERROR;
	}

	resultObj = Tcl_NewDictObj();

	while (!done) {
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664

2665
2666
2667

2668
2669
2670

2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698









2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
		    result = TCL_ERROR;
		    goto abnormalResult;
		}
		TclDecrRefCount(boolObj);
		if (satisfied) {
		    Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
		}
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_BREAK:
		/*
		 * Force loop termination.  Has to be done with a jump
		 * so we remove references to the dictionary correctly.

		 */
		Tcl_ResetResult(interp);
		Tcl_DictObjDone(&search);

		result = TCL_OK;
		break;
	    case TCL_ERROR:

		sprintf(msg, "\n    (\"dict filter\" script line %d)",
			interp->errorLine);
		Tcl_AddObjErrorInfo(interp, msg, -1);
	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);

	    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	}

	/*
	 * Stop holding a reference to these objects.
	 */
	TclDecrRefCount(keyVarObj);
	TclDecrRefCount(valueVarObj);
	TclDecrRefCount(dictObj);
	TclDecrRefCount(scriptObj);
	Tcl_DictObjDone(&search);

	if (result == TCL_OK) {
	    Tcl_SetObjResult(interp, resultObj);
	} else {
	    TclDecrRefCount(resultObj);
	}
	return result;









    }
    Tcl_Panic("unexpected fallthrough");
    /* Control never reaches this point. */
    return TCL_ERROR;

  abnormalResult:
    Tcl_DictObjDone(&search);
    TclDecrRefCount(keyObj);
    TclDecrRefCount(valueObj);
    TclDecrRefCount(keyVarObj);
    TclDecrRefCount(valueVarObj);
    TclDecrRefCount(dictObj);
    TclDecrRefCount(scriptObj);
    TclDecrRefCount(resultObj);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * DictUpdateCmd --
 *







<
<



|
|
>



>



>
|

<















<









>
>
>
>
>
>
>
>
>




<
<
<
<
<
<
<
<
<
<
<







2689
2690
2691
2692
2693
2694
2695


2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711

2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726

2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748











2749
2750
2751
2752
2753
2754
2755
		    result = TCL_ERROR;
		    goto abnormalResult;
		}
		TclDecrRefCount(boolObj);
		if (satisfied) {
		    Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
		}


		break;
	    case TCL_BREAK:
		/*
		 * Force loop termination by calling Tcl_DictObjDone; this
		 * makes the next Tcl_DictObjNext say there is nothing more to
		 * do.
		 */
		Tcl_ResetResult(interp);
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:
		TclFormatToErrorInfo(interp,
			"\n    (\"dict filter\" script line %d)",
			interp->errorLine);

	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);

	    Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
	}

	/*
	 * Stop holding a reference to these objects.
	 */
	TclDecrRefCount(keyVarObj);
	TclDecrRefCount(valueVarObj);

	TclDecrRefCount(scriptObj);
	Tcl_DictObjDone(&search);

	if (result == TCL_OK) {
	    Tcl_SetObjResult(interp, resultObj);
	} else {
	    TclDecrRefCount(resultObj);
	}
	return result;
    abnormalResult:
	Tcl_DictObjDone(&search);
	TclDecrRefCount(keyObj);
	TclDecrRefCount(valueObj);
	TclDecrRefCount(keyVarObj);
	TclDecrRefCount(valueVarObj);
	TclDecrRefCount(scriptObj);
	TclDecrRefCount(resultObj);
	return result;
    }
    Tcl_Panic("unexpected fallthrough");
    /* Control never reaches this point. */
    return TCL_ERROR;











}

/*
 *----------------------------------------------------------------------
 *
 * DictUpdateCmd --
 *
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
     */

    dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
    if (objc > 4) {
	dictPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3,
		DICT_PATH_READ);
	if (dictPtr == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Go over the list of keys and write each corresponding value to
     * a variable in the current context with the same name.  Also
     * keep a copy of the keys so we can write back properly later on
     * even if the dictionary has been structurally modified.
     */

    if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
	    &done) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_IncrRefCount(dictPtr);
    TclNewObj(keysPtr);
    Tcl_IncrRefCount(keysPtr);

    for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
	Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
	if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    TclDecrRefCount(dictPtr);
	    TclDecrRefCount(keysPtr);
	    Tcl_DictObjDone(&s);
	    return TCL_ERROR;
	}
    }
    TclDecrRefCount(dictPtr);

    /*
     * Execute the body.
     */

    result = Tcl_EvalObjEx(interp, objv[objc-1], 0);
    if (result == TCL_ERROR) {







|


















<







<





<







2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935

2936
2937
2938
2939
2940
2941
2942

2943
2944
2945
2946
2947

2948
2949
2950
2951
2952
2953
2954
     */

    dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
    if (objc > 4) {
	dictPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3,
		DICT_PATH_READ);
	if (dictPtr == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Go over the list of keys and write each corresponding value to
     * a variable in the current context with the same name.  Also
     * keep a copy of the keys so we can write back properly later on
     * even if the dictionary has been structurally modified.
     */

    if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
	    &done) != TCL_OK) {
	return TCL_ERROR;
    }


    TclNewObj(keysPtr);
    Tcl_IncrRefCount(keysPtr);

    for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
	Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
	if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
		TCL_LEAVE_ERR_MSG) == NULL) {

	    TclDecrRefCount(keysPtr);
	    Tcl_DictObjDone(&s);
	    return TCL_ERROR;
	}
    }


    /*
     * Execute the body.
     */

    result = Tcl_EvalObjEx(interp, objv[objc-1], 0);
    if (result == TCL_ERROR) {
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
	 * do prepare-for-update de-sharing along the path *but* avoid
	 * generating an error on a non-existant path (we'll treat
	 * that the same as a non-existant variable.  Luckily, the
	 * de-sharing operation isn't deeply damaging if we don't go
	 * on to update; it's just less than perfectly efficient (but
	 * no memory should be leaked).
	 */
	leafPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3,
		DICT_PATH_EXISTS | DICT_PATH_UPDATE);
	if (leafPtr == NULL) {
	    TclDecrRefCount(keysPtr);
	    if (allocdict) {
		TclDecrRefCount(dictPtr);
	    }
	    Tcl_DiscardInterpState(state);







|







2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
	 * do prepare-for-update de-sharing along the path *but* avoid
	 * generating an error on a non-existant path (we'll treat
	 * that the same as a non-existant variable.  Luckily, the
	 * de-sharing operation isn't deeply damaging if we don't go
	 * on to update; it's just less than perfectly efficient (but
	 * no memory should be leaked).
	 */
	leafPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3,
		DICT_PATH_EXISTS | DICT_PATH_UPDATE);
	if (leafPtr == NULL) {
	    TclDecrRefCount(keysPtr);
	    if (allocdict) {
		TclDecrRefCount(dictPtr);
	    }
	    Tcl_DiscardInterpState(state);

Changes to generic/tclEncoding.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
/*
 * tclEncoding.c --
 *
 *	Contains the implementation of the encoding conversion package.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEncoding.c,v 1.29 2004/12/01 23:18:50 dgp Exp $
 */

#include "tclInt.h"

typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src));

/*
 * The following data structure represents an encoding, which describes how
 * to convert between various character sets and UTF-8.
 */

typedef struct Encoding {
    char *name;			/* Name of encoding.  Malloced because (1)
				 * hash table entry that owns this encoding
				 * may be freed prior to this encoding being
				 * freed, (2) string passed in the
				 * Tcl_EncodingType structure may not be
				 * persistent. */
    Tcl_EncodingConvertProc *toUtfProc;
				/* Procedure to convert from external
				 * encoding into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Procedure to convert from UTF-8 into
				 * external encoding. */
    Tcl_EncodingFreeProc *freeProc;
				/* If non-NULL, procedure to call when this
				 * encoding is deleted. */
    int nullSize;		/* Number of 0x00 bytes that signify










|







|
|










|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
/*
 * tclEncoding.c --
 *
 *	Contains the implementation of the encoding conversion package.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEncoding.c,v 1.29.2.6 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src));

/*
 * The following data structure represents an encoding, which describes how to
 * convert between various character sets and UTF-8.
 */

typedef struct Encoding {
    char *name;			/* Name of encoding.  Malloced because (1)
				 * hash table entry that owns this encoding
				 * may be freed prior to this encoding being
				 * freed, (2) string passed in the
				 * Tcl_EncodingType structure may not be
				 * persistent. */
    Tcl_EncodingConvertProc *toUtfProc;
				/* Procedure to convert from external encoding
				 * into UTF-8. */
    Tcl_EncodingConvertProc *fromUtfProc;
				/* Procedure to convert from UTF-8 into
				 * external encoding. */
    Tcl_EncodingFreeProc *freeProc;
				/* If non-NULL, procedure to call when this
				 * encoding is deleted. */
    int nullSize;		/* Number of 0x00 bytes that signify
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145

146
147
148
149
150
151
152
153
154
155

156
157
158
159
160
161
162
163
164

165
166

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
 * The following structure is the clientData for a dynamically-loaded,
 * table-driven encoding created by LoadTableEncoding().  It maps between
 * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only)
 * encoding.
 */

typedef struct TableEncodingData {
    int fallback;		/* Character (in this encoding) to
				 * substitute when this encoding cannot
				 * represent a UTF-8 character. */
    char prefixBytes[256];	/* If a byte in the input stream is a lead
				 * byte for a 2-byte sequence, the
				 * corresponding entry in this array is 1,
				 * otherwise it is 0. */
    unsigned short **toUnicode;	/* Two dimensional sparse matrix to map
				 * characters from the encoding to Unicode.
				 * Each element of the toUnicode array points
				 * to an array of 256 shorts.  If there is no
				 * corresponding character in Unicode, the
				 * value in the matrix is 0x0000.  malloc'd. */

    unsigned short **fromUnicode;
				/* Two dimensional sparse matrix to map
				 * characters from Unicode to the encoding.
				 * Each element of the fromUnicode array
				 * points to an array of 256 shorts.  If there
				 * is no corresponding character the encoding,
				 * the value in the matrix is 0x0000.
				 * malloc'd. */
} TableEncodingData;

/*
 * The following structures is the clientData for a dynamically-loaded,
 * escape-driven encoding that is itself comprised of other simpler
 * encodings.  An example is "iso-2022-jp", which uses escape sequences to
 * switch between ascii, jis0208, jis0212, gb2312, and ksc5601.  Note that
 * "escape-driven" does not necessarily mean that the ESCAPE character is
 * the character used for switching character sets.
 */

typedef struct EscapeSubTable {
    unsigned int sequenceLen;	/* Length of following string. */
    char sequence[16];		/* Escape code that marks this encoding. */
    char name[32];		/* Name for encoding. */
    Encoding *encodingPtr;	/* Encoding loaded using above name, or NULL
				 * if this sub-encoding has not been needed
				 * yet. */
} EscapeSubTable;

typedef struct EscapeEncodingData {
    int fallback;		/* Character (in this encoding) to
				 * substitute when this encoding cannot
				 * represent a UTF-8 character. */
    unsigned int initLen;	/* Length of following string. */
    char init[16];		/* String to emit or expect before first char
				 * in conversion. */
    unsigned int finalLen;	/* Length of following string. */
    char final[16];		/* String to emit or expect after last char
				 * in conversion. */
    char prefixBytes[256];	/* If a byte in the input stream is the 
				 * first character of one of the escape 
				 * sequences in the following array, the 
				 * corresponding entry in this array is 1,
				 * otherwise it is 0. */
    int numSubTables;		/* Length of following array. */
    EscapeSubTable subTables[1];/* Information about each EscapeSubTable
				 * used by this encoding type.  The actual 
				 * size will be as large as necessary to 
				 * hold all EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the
 * file.
 */

#define ENCODING_SINGLEBYTE	0
#define ENCODING_DOUBLEBYTE	1
#define ENCODING_MULTIBYTE	2
#define ENCODING_ESCAPE		3

/*
 * A list of directories in which Tcl should look for *.enc files.
 * This list is shared by all threads.  Access is governed by a
 * mutex lock.
 */

static TclInitProcessGlobalValueProc	InitializeEncodingSearchPath;
static ProcessGlobalValue encodingSearchPath =
	{0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL};


/*
 * A map from encoding names to the directories in which their data
 * files have been seen.  The string value of the map is shared by all
 * threads.  Access to the shared string is governed by a mutex lock.
 */

static TclInitProcessGlobalValueProc	InitializeEncodingFileMap;
static ProcessGlobalValue encodingFileMap = 
	{0, 0, NULL, NULL, InitializeEncodingFileMap, NULL, NULL};


/*
 * A list of directories making up the "library path".  Historically
 * this search path has served many uses, but the only one remaining
 * is a base for the encodingSearchPath above.  If the application
 * does not explicitly set the encodingSearchPath, then it will be
 * initialized by appending /encoding to each directory in this
 * "libraryPath".
 */

static ProcessGlobalValue libraryPath =
	{0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL};


static int encodingsInitialized  = 0;

/*
 * Hash table that keeps track of all loaded Encodings.  Keys are
 * the string names that represent the encoding, values are (Encoding *).
 */
 
static Tcl_HashTable encodingTable;
TCL_DECLARE_MUTEX(encodingMutex)

/*
 * The following are used to hold the default and current system encodings.  
 * If NULL is passed to one of the conversion routines, the current setting 
 * of the system encoding will be used to perform the conversion.
 */

static Tcl_Encoding defaultEncoding;
static Tcl_Encoding systemEncoding;

/*
 * The following variable is used in the sparse matrix code for a







|
|
|









|
>












|
|
|
|
|












|
|
|




|
|
|
|
|
|
|

|
|
|
|













|
|
<


|
|
|
>


|
|
|


<
|
|
>


|
|
|
|
|
<

>
|
|
>




|
|

|




|
|
|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

141
142
143
144
145
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
 * The following structure is the clientData for a dynamically-loaded,
 * table-driven encoding created by LoadTableEncoding().  It maps between
 * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only)
 * encoding.
 */

typedef struct TableEncodingData {
    int fallback;		/* Character (in this encoding) to substitute
				 * when this encoding cannot represent a UTF-8
				 * character. */
    char prefixBytes[256];	/* If a byte in the input stream is a lead
				 * byte for a 2-byte sequence, the
				 * corresponding entry in this array is 1,
				 * otherwise it is 0. */
    unsigned short **toUnicode;	/* Two dimensional sparse matrix to map
				 * characters from the encoding to Unicode.
				 * Each element of the toUnicode array points
				 * to an array of 256 shorts.  If there is no
				 * corresponding character in Unicode, the
				 * value in the matrix is 0x0000.
				 * malloc'd. */
    unsigned short **fromUnicode;
				/* Two dimensional sparse matrix to map
				 * characters from Unicode to the encoding.
				 * Each element of the fromUnicode array
				 * points to an array of 256 shorts.  If there
				 * is no corresponding character the encoding,
				 * the value in the matrix is 0x0000.
				 * malloc'd. */
} TableEncodingData;

/*
 * The following structures is the clientData for a dynamically-loaded,
 * escape-driven encoding that is itself comprised of other simpler encodings.
 * An example is "iso-2022-jp", which uses escape sequences to switch between
 * ascii, jis0208, jis0212, gb2312, and ksc5601.  Note that "escape-driven"
 * does not necessarily mean that the ESCAPE character is the character used
 * for switching character sets.
 */

typedef struct EscapeSubTable {
    unsigned int sequenceLen;	/* Length of following string. */
    char sequence[16];		/* Escape code that marks this encoding. */
    char name[32];		/* Name for encoding. */
    Encoding *encodingPtr;	/* Encoding loaded using above name, or NULL
				 * if this sub-encoding has not been needed
				 * yet. */
} EscapeSubTable;

typedef struct EscapeEncodingData {
    int fallback;		/* Character (in this encoding) to substitute
				 * when this encoding cannot represent a UTF-8
				 * character. */
    unsigned int initLen;	/* Length of following string. */
    char init[16];		/* String to emit or expect before first char
				 * in conversion. */
    unsigned int finalLen;	/* Length of following string. */
    char final[16];		/* String to emit or expect after last char in
				 * conversion. */
    char prefixBytes[256];	/* If a byte in the input stream is the first
				 * character of one of the escape sequences in
				 * the following array, the corresponding
				 * entry in this array is 1, otherwise it is
				 * 0. */
    int numSubTables;		/* Length of following array. */
    EscapeSubTable subTables[1];/* Information about each EscapeSubTable used
				 * by this encoding type.  The actual size
				 * will be as large as necessary to hold all
				 * EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the
 * file.
 */

#define ENCODING_SINGLEBYTE	0
#define ENCODING_DOUBLEBYTE	1
#define ENCODING_MULTIBYTE	2
#define ENCODING_ESCAPE		3

/*
 * A list of directories in which Tcl should look for *.enc files.  This list
 * is shared by all threads.  Access is governed by a mutex lock.

 */

static TclInitProcessGlobalValueProc InitializeEncodingSearchPath;
static ProcessGlobalValue encodingSearchPath = {
    0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL
};

/*
 * A map from encoding names to the directories in which their data files have
 * been seen.  The string value of the map is shared by all threads.  Access
 * to the shared string is governed by a mutex lock.
 */


static ProcessGlobalValue encodingFileMap = {
    0, 0, NULL, NULL, NULL, NULL, NULL
};

/*
 * A list of directories making up the "library path".  Historically this
 * search path has served many uses, but the only one remaining is a base for
 * the encodingSearchPath above.  If the application does not explicitly set
 * the encodingSearchPath, then it will be initialized by appending /encoding
 * to each directory in this "libraryPath".

 */

static ProcessGlobalValue libraryPath = {
    0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL
};

static int encodingsInitialized  = 0;

/*
 * Hash table that keeps track of all loaded Encodings.  Keys are the string
 * names that represent the encoding, values are (Encoding *).
 */

static Tcl_HashTable encodingTable;
TCL_DECLARE_MUTEX(encodingMutex)

/*
 * The following are used to hold the default and current system encodings.
 * If NULL is passed to one of the conversion routines, the current setting of
 * the system encoding will be used to perform the conversion.
 */

static Tcl_Encoding defaultEncoding;
static Tcl_Encoding systemEncoding;

/*
 * The following variable is used in the sparse matrix code for a
196
197
198
199
200
201
202


203
204
205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
224

225
226
227
228
229
230
231
 */

static int		BinaryProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));


static void		EscapeFreeProc _ANSI_ARGS_((ClientData clientData));
static int		EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static int		EscapeToUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static void		FillEncodingFileMap ();
static void		FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));

static Encoding *	GetTableEncoding _ANSI_ARGS_((
			    EscapeEncodingData *dataPtr, int state));
static Tcl_Encoding	LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *name));
static Tcl_Encoding	LoadTableEncoding _ANSI_ARGS_((CONST char *name,
			    int type, Tcl_Channel chan));
static Tcl_Encoding	LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, 
			    Tcl_Channel chan));
static Tcl_Obj *	MakeFileMap ();

static void		TableFreeProc _ANSI_ARGS_((ClientData clientData));
static int		TableFromUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static int		TableToUtfProc _ANSI_ARGS_((ClientData clientData,







>
>













>






|

|
>







198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
 */

static int		BinaryProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static void		DupEncodingIntRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *dupPtr));
static void		EscapeFreeProc _ANSI_ARGS_((ClientData clientData));
static int		EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static int		EscapeToUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static void		FillEncodingFileMap ();
static void		FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
static void		FreeEncodingIntRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static Encoding *	GetTableEncoding _ANSI_ARGS_((
			    EscapeEncodingData *dataPtr, int state));
static Tcl_Encoding	LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *name));
static Tcl_Encoding	LoadTableEncoding _ANSI_ARGS_((CONST char *name,
			    int type, Tcl_Channel chan));
static Tcl_Encoding	LoadEscapeEncoding _ANSI_ARGS_((CONST char *name,
			    Tcl_Channel chan));
static Tcl_Channel	OpenEncodingFileChannel _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *name));
static void		TableFreeProc _ANSI_ARGS_((ClientData clientData));
static int		TableFromUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static int		TableToUtfProc _ANSI_ARGS_((ClientData clientData,
256
257
258
259
260
261
262





263




264
265
266












































































267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359



360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389

390
391
392
393
394
395

396
397
398
399
400

401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416


417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
			    int *dstCharsPtr));
static int		UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));











/*
 *----------------------------------------------------------------------
 *












































































 * TclGetEncodingSearchPath --
 *
 *      Keeps the per-thread copy of the encoding search path current
 *      with changes to the global copy.  
 *
 * Results:
 *      Returns a "list" (Tcl_Obj *) that contains the encoding
 *      search path.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetEncodingSearchPath() {
    return TclGetProcessGlobalValue(&encodingSearchPath);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetEncodingSearchPath --
 *
 *      Keeps the per-thread copy of the encoding search path current
 *      with changes to the global copy.  
 *
 *----------------------------------------------------------------------
 */

int 
TclSetEncodingSearchPath(searchPath)
    Tcl_Obj *searchPath; 
{
    int dummy;

    if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) {
	return TCL_ERROR;
    }
    TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL);
    FillEncodingFileMap();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetLibraryPath --
 *
 *      Keeps the per-thread copy of the library path current
 *      with changes to the global copy.  
 *
 * Results:
 *      Returns a "list" (Tcl_Obj *) that contains the library path.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetLibraryPath() {
    return TclGetProcessGlobalValue(&libraryPath);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetLibraryPath --
 *
 *      Keeps the per-thread copy of the library path current
 *      with changes to the global copy.  
 *
 *      NOTE: this routine returns void, so there's no way to
 *      report the error that searchPath is not a valid list.
 *      In that case, this routine will silently do nothing.
 *
 *----------------------------------------------------------------------
 */

void
TclSetLibraryPath(path)
    Tcl_Obj *path; 
{
    int dummy;

    if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) {
	return;
    }
    TclSetProcessGlobalValue(&libraryPath, path, NULL);
}

/*
 *---------------------------------------------------------------------------
 *
 * MakeFileMap --
 *



 *	Scan the directories on the encoding search path, find the
 *	*.enc files, and store the found pathnames in a map associated
 *	with the encoding name.
 *
 *	In particular, if $dir is on the encoding search path, and the
 *	file $dir/foo.enc is found, then store a "foo" -> $dir entry
 *	in the map.  Later, any need for the "foo" encoding will quickly
 * 	be able to construct the $dir/foo.enc pathname for reading the
 *	encoding data.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Entries are added to the encoding file map.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
MakeFileMap()
{
    int i, numDirs = 0;
    Tcl_Obj *map, *searchPath;

    searchPath = TclGetEncodingSearchPath();
    Tcl_IncrRefCount(searchPath);
    Tcl_ListObjLength(NULL, searchPath, &numDirs);
    map = Tcl_NewDictObj();
    Tcl_IncrRefCount(map);

    for (i = numDirs-1; i >= 0; i--) {
	/* 
	 * Iterate backwards through the search path so as we
	 * overwrite entries found, we favor files earlier on
	 * the search path.
	 */

	int j, numFiles;
	Tcl_Obj *directory, *matchFileList = Tcl_NewObj();
	Tcl_Obj **filev;
	Tcl_GlobTypeData readableFiles =
		{TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL};


	Tcl_ListObjIndex(NULL, searchPath, i, &directory);
	Tcl_IncrRefCount(directory);
	Tcl_IncrRefCount(matchFileList);
	Tcl_FSMatchInDirectory(NULL, matchFileList,
		directory, "*.enc", &readableFiles);

	Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev);
	for (j=0; j<numFiles; j++) {
	    Tcl_Obj *encodingName, *file;

	    file = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);
	    Tcl_IncrRefCount(file);
	    encodingName = TclPathPart(NULL, file, TCL_PATH_ROOT);
	    Tcl_IncrRefCount(encodingName);
	    Tcl_DictObjPut(NULL, map, encodingName, directory);


	}
	Tcl_DecrRefCount(matchFileList);
	Tcl_DecrRefCount(directory);
    }
    Tcl_DecrRefCount(searchPath);
    return map;
}

/*
 *---------------------------------------------------------------------------
 *
 * FillEncodingFileMap --
 *
 * 	Called to bring the encoding file map in sync with the current
 * 	value of the encoding search path.
 *
 * 	TODO: Check the callers of this routine to see if it's called
 * 	too frequently.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Entries are added to the encoding file map.
 *
 *---------------------------------------------------------------------------
 */

void
FillEncodingFileMap()
{
    Tcl_Obj *map = MakeFileMap();
    TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
    Tcl_DecrRefCount(map);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclInitEncodingSubsystem --
 *
 *	Initialize all resources used by this subsystem on a per-process
 *	basis.  
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the memory, object, and IO subsystems.
 *







>
>
>
>
>
|
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|


|
<














|
|




|

|







<








|
|


|














|
|

|
|
|






|












|

>
>
>
|
|
|

|
|
|
|
<










|
|









>

|
|
|
<

>



|
|
>




|
|






<

<

>
>





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










|







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394

395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459

460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505

506

507
508
509
510
511
512
513
514



























515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
			    int *dstCharsPtr));
static int		UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));

/*
 * A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep.  This should
 * help the lifetime of encodings be more useful.  See concerns raised in [Bug
 * 1077262].
 */

static Tcl_ObjType EncodingType = {
    "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};

/*
 *----------------------------------------------------------------------
 *
 * TclGetEncodingFromObj --
 *
 *	Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if
 *	possible, and returns TCL_OK.  If no such encoding exists, TCL_ERROR
 *	is returned, and if interp is non-NULL, an error message is written
 *	there.
 *
 * Results:
 *	Standard Tcl return code.
 *
 * Side effects:
 * 	Caches the Tcl_Encoding value as the internal rep of (*objPtr).
 *
 *----------------------------------------------------------------------
 */

int
TclGetEncodingFromObj(interp, objPtr, encodingPtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
    Tcl_Encoding *encodingPtr;
{
    CONST char *name = Tcl_GetString(objPtr);
    if (objPtr->typePtr != &EncodingType) {
	Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);

	if (encoding == NULL) {
	    return TCL_ERROR;
	}
	TclFreeIntRep(objPtr);
	objPtr->internalRep.otherValuePtr = (VOID *) encoding;
	objPtr->typePtr = &EncodingType;
    }
    *encodingPtr = Tcl_GetEncoding(NULL, name);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeEncodingIntRep --
 *
 *	The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType.
 *
 *----------------------------------------------------------------------
 */

static void
FreeEncodingIntRep(objPtr)
    Tcl_Obj *objPtr;
{
    Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * DupEncodingIntRep --
 *
 *	The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType.
 *
 *----------------------------------------------------------------------
 */

static void
DupEncodingIntRep(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    dupPtr->internalRep.otherValuePtr = (VOID *)
	    Tcl_GetEncoding(NULL, srcPtr->bytes);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetEncodingSearchPath --
 *
 *	Keeps the per-thread copy of the encoding search path current with
 *	changes to the global copy.
 *
 * Results:
 *	Returns a "list" (Tcl_Obj *) that contains the encoding search path.

 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetEncodingSearchPath() {
    return TclGetProcessGlobalValue(&encodingSearchPath);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetEncodingSearchPath --
 *
 *	Keeps the per-thread copy of the encoding search path current with
 *	changes to the global copy.
 *
 *----------------------------------------------------------------------
 */

int
TclSetEncodingSearchPath(searchPath)
    Tcl_Obj *searchPath;
{
    int dummy;

    if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) {
	return TCL_ERROR;
    }
    TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetLibraryPath --
 *
 *	Keeps the per-thread copy of the library path current with changes to
 *	the global copy.
 *
 * Results:
 *	Returns a "list" (Tcl_Obj *) that contains the library path.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetLibraryPath() {
    return TclGetProcessGlobalValue(&libraryPath);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetLibraryPath --
 *
 *	Keeps the per-thread copy of the library path current with changes to
 *	the global copy.
 *
 *	NOTE: this routine returns void, so there's no way to report the error
 *	that searchPath is not a valid list.  In that case, this routine will
 *	silently do nothing.
 *
 *----------------------------------------------------------------------
 */

void
TclSetLibraryPath(path)
    Tcl_Obj *path;
{
    int dummy;

    if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) {
	return;
    }
    TclSetProcessGlobalValue(&libraryPath, path, NULL);
}

/*
 *---------------------------------------------------------------------------
 *
 * FillEncodingFileMap --
 *
 * 	Called to bring the encoding file map in sync with the current value
 * 	of the encoding search path.
 *
 *	Scan the directories on the encoding search path, find the *.enc
 *	files, and store the found pathnames in a map associated with the
 *	encoding name.
 *
 *	In particular, if $dir is on the encoding search path, and the file
 *	$dir/foo.enc is found, then store a "foo" -> $dir entry in the map.
 *	Later, any need for the "foo" encoding will quickly * be able to
 *	construct the $dir/foo.enc pathname for reading the encoding data.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Entries are added to the encoding file map.
 *
 *---------------------------------------------------------------------------
 */

static void
FillEncodingFileMap()
{
    int i, numDirs = 0;
    Tcl_Obj *map, *searchPath;

    searchPath = TclGetEncodingSearchPath();
    Tcl_IncrRefCount(searchPath);
    Tcl_ListObjLength(NULL, searchPath, &numDirs);
    map = Tcl_NewDictObj();
    Tcl_IncrRefCount(map);

    for (i = numDirs-1; i >= 0; i--) {
	/*
	 * Iterate backwards through the search path so as we overwrite
	 * entries found, we favor files earlier on the search path.

	 */

	int j, numFiles;
	Tcl_Obj *directory, *matchFileList = Tcl_NewObj();
	Tcl_Obj **filev;
	Tcl_GlobTypeData readableFiles = {
	    TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL
	};

	Tcl_ListObjIndex(NULL, searchPath, i, &directory);
	Tcl_IncrRefCount(directory);
	Tcl_IncrRefCount(matchFileList);
	Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc",
		&readableFiles);

	Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev);
	for (j=0; j<numFiles; j++) {
	    Tcl_Obj *encodingName, *file;

	    file = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);

	    encodingName = TclPathPart(NULL, file, TCL_PATH_ROOT);

	    Tcl_DictObjPut(NULL, map, encodingName, directory);
	    Tcl_DecrRefCount(file);
	    Tcl_DecrRefCount(encodingName);
	}
	Tcl_DecrRefCount(matchFileList);
	Tcl_DecrRefCount(directory);
    }
    Tcl_DecrRefCount(searchPath);



























    TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
    Tcl_DecrRefCount(map);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclInitEncodingSubsystem --
 *
 *	Initialize all resources used by this subsystem on a per-process
 *	basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the memory, object, and IO subsystems.
 *
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
    if (encodingsInitialized) {
	return;
    }

    Tcl_MutexLock(&encodingMutex);
    Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&encodingMutex);
    
    /*
     * Create a few initial encodings.  Note that the UTF-8 to UTF-8 
     * translation is not a no-op, because it will turn a stream of
     * improperly formed UTF-8 into a properly formed stream.
     */

    type.encodingName	= "identity";
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;







|

|
|
|







541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
    if (encodingsInitialized) {
	return;
    }

    Tcl_MutexLock(&encodingMutex);
    Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&encodingMutex);

    /*
     * Create a few initial encodings.  Note that the UTF-8 to UTF-8
     * translation is not a no-op, because it will turn a stream of improperly
     * formed UTF-8 into a properly formed stream.
     */

    type.encodingName	= "identity";
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
    type.fromUtfProc    = UtfToUnicodeProc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);

    encodingsInitialized = 1;
    TclpSetInitialEncodings();
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEncodingSubsystem --
 *







<







575
576
577
578
579
580
581

582
583
584
585
586
587
588
    type.fromUtfProc    = UtfToUnicodeProc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);

    encodingsInitialized = 1;

}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEncodingSubsystem --
 *
535
536
537
538
539
540
541
542
543

544
545
546
547
548
549
550
551

552
553
554

555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
void
TclFinalizeEncodingSubsystem()
{
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;

    Tcl_MutexLock(&encodingMutex);
    encodingsInitialized  = 0;
    FreeEncoding(systemEncoding);

    hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
    while (hPtr != NULL) {
	/*
	 * Call FreeEncoding instead of doing it directly to handle refcounts
	 * like escape encodings use.  [Bug #524674]
	 * Make sure to call Tcl_FirstHashEntry repeatedly so that all
	 * encodings are eventually cleaned up.
	 */

	FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr));
	hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
    }

    Tcl_DeleteHashTable(&encodingTable);
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetDefaultEncodingDir --
 *
 * 	Legacy public interface to retrieve first directory in the
 * 	encoding searchPath.
 *
 * Results:
 *	The directory pathname, as a string, or NULL for an empty
 *	encoding search path.
 *
 * Side effects:
 * 	None.
 *
 *-------------------------------------------------------------------------
 */








|

>




|
|
|

>



>









|
|


|
|







600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
void
TclFinalizeEncodingSubsystem()
{
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;

    Tcl_MutexLock(&encodingMutex);
    encodingsInitialized = 0;
    FreeEncoding(systemEncoding);

    hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
    while (hPtr != NULL) {
	/*
	 * Call FreeEncoding instead of doing it directly to handle refcounts
	 * like escape encodings use.  [Bug #524674] Make sure to call
	 * Tcl_FirstHashEntry repeatedly so that all encodings are eventually
	 * cleaned up.
	 */

	FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr));
	hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
    }

    Tcl_DeleteHashTable(&encodingTable);
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetDefaultEncodingDir --
 *
 * 	Legacy public interface to retrieve first directory in the encoding
 * 	searchPath.
 *
 * Results:
 *	The directory pathname, as a string, or NULL for an empty encoding
 *	search path.
 *
 * Side effects:
 * 	None.
 *
 *-------------------------------------------------------------------------
 */

590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_SetDefaultEncodingDir --
 *
 * 	Legacy public interface to set the first directory in the
 * 	encoding search path.
 *
 * Results:
 * 	None.
 *
 * Side effects:
 * 	Modifies the encoding search path.
 *







|
|







658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_SetDefaultEncodingDir --
 *
 * 	Legacy public interface to set the first directory in the encoding
 * 	search path.
 *
 * Results:
 * 	None.
 *
 * Side effects:
 * 	Modifies the encoding search path.
 *
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
 *
 *	Given the name of a encoding, find the corresponding Tcl_Encoding
 *	token.  If the encoding did not already exist, Tcl attempts to
 *	dynamically load an encoding by that name.
 *
 * Results:
 *	Returns a token that represents the encoding.  If the name didn't
 *	refer to any known or loadable encoding, NULL is returned.  If
 *	NULL was returned, an error message is left in interp's result
 *	object, unless interp was NULL.
 *
 * Side effects:
 *	The new encoding type is entered into a table visible to all
 *	interpreters, keyed off the encoding's name.  For each call to
 *	this procedure, there should eventually be a call to
 *	Tcl_FreeEncoding, so that the database can be cleaned up when
 *	encodings aren't needed anymore.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_GetEncoding(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */







|
|
|



|
|
|
|







693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
 *
 *	Given the name of a encoding, find the corresponding Tcl_Encoding
 *	token.  If the encoding did not already exist, Tcl attempts to
 *	dynamically load an encoding by that name.
 *
 * Results:
 *	Returns a token that represents the encoding.  If the name didn't
 *	refer to any known or loadable encoding, NULL is returned.  If NULL
 *	was returned, an error message is left in interp's result object,
 *	unless interp was NULL.
 *
 * Side effects:
 *	The new encoding type is entered into a table visible to all
 *	interpreters, keyed off the encoding's name.  For each call to this
 *	procedure, there should eventually be a call to Tcl_FreeEncoding, so
 *	that the database can be cleaned up when encodings aren't needed
 *	anymore.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_GetEncoding(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */
663
664
665
666
667
668
669

670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
    if (hPtr != NULL) {
	encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
	encodingPtr->refCount++;
	Tcl_MutexUnlock(&encodingMutex);
	return (Tcl_Encoding) encodingPtr;
    }
    Tcl_MutexUnlock(&encodingMutex);

    return LoadEncodingFile(interp, name);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FreeEncoding --
 *
 *	This procedure is called to release an encoding allocated by
 *	Tcl_CreateEncoding() or Tcl_GetEncoding().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count associated with the encoding is decremented
 *	and the encoding may be deleted if nothing is using it anymore.
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_FreeEncoding(encoding)
    Tcl_Encoding encoding;
{
    Tcl_MutexLock(&encodingMutex);
    FreeEncoding(encoding);
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeEncoding --
 *
 *	This procedure is called to release an encoding by procedures
 *	that already have the encodingMutex.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count associated with the encoding is decremented
 *	and the encoding may be deleted if nothing is using it anymore.
 *
 *----------------------------------------------------------------------
 */

static void
FreeEncoding(encoding)
    Tcl_Encoding encoding;
{
    Encoding *encodingPtr;
    
    encodingPtr = (Encoding *) encoding;
    if (encodingPtr == NULL) {
	return;
    }
    encodingPtr->refCount--;
    if (encodingPtr->refCount == 0) {
	if (encodingPtr->freeProc != NULL) {







>















|
|


















|
|





|
|









|







731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
    if (hPtr != NULL) {
	encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
	encodingPtr->refCount++;
	Tcl_MutexUnlock(&encodingMutex);
	return (Tcl_Encoding) encodingPtr;
    }
    Tcl_MutexUnlock(&encodingMutex);

    return LoadEncodingFile(interp, name);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FreeEncoding --
 *
 *	This procedure is called to release an encoding allocated by
 *	Tcl_CreateEncoding() or Tcl_GetEncoding().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count associated with the encoding is decremented and
 *	the encoding may be deleted if nothing is using it anymore.
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_FreeEncoding(encoding)
    Tcl_Encoding encoding;
{
    Tcl_MutexLock(&encodingMutex);
    FreeEncoding(encoding);
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeEncoding --
 *
 *	This procedure is called to release an encoding by procedures that
 *	already have the encodingMutex.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count associated with the encoding is decremented and
 *	the encoding may be deleted if nothing is using it anymore.
 *
 *----------------------------------------------------------------------
 */

static void
FreeEncoding(encoding)
    Tcl_Encoding encoding;
{
    Encoding *encodingPtr;

    encodingPtr = (Encoding *) encoding;
    if (encodingPtr == NULL) {
	return;
    }
    encodingPtr->refCount--;
    if (encodingPtr->refCount == 0) {
	if (encodingPtr->freeProc != NULL) {
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingName --
 *
 *	Given an encoding, return the name that was used to constuct
 *	the encoding.
 *
 * Results:
 *	The name of the encoding.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_GetEncodingName(encoding)
    Tcl_Encoding encoding;	/* The encoding whose name to fetch. */
{
    Encoding *encodingPtr;

    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;
    return encodingPtr->name;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingNames --
 *
 *	Get the list of all known encodings, including the ones stored
 *	as files on disk in the encoding path.
 *
 * Results:
 *	Modifies interp's result object to hold a list of all the available
 *	encodings.
 *
 * Side effects:
 *	None.







|
|














<
<



|
|







|
|







808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830


831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingName --
 *
 *	Given an encoding, return the name that was used to constuct the
 *	encoding.
 *
 * Results:
 *	The name of the encoding.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_GetEncodingName(encoding)
    Tcl_Encoding encoding;	/* The encoding whose name to fetch. */
{


    if (encoding == NULL) {
	encoding = systemEncoding;
    }

    return ((Encoding *) encoding)->name;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetEncodingNames --
 *
 *	Get the list of all known encodings, including the ones stored as
 *	files on disk in the encoding path.
 *
 * Results:
 *	Modifies interp's result object to hold a list of all the available
 *	encodings.
 *
 * Side effects:
 *	None.
795
796
797
798
799
800
801

802


803
804
805
806
807
808
809
810
811
812
813
814

815


816
817
818
819
820

821


822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
    Tcl_HashEntry *hPtr;
    Tcl_Obj *map, *name, *result = Tcl_NewObj();
    Tcl_DictSearch mapSearch;
    int dummy, done = 0;

    Tcl_InitObjHashTable(&table);


    /* Copy encoding names from loaded encoding table to table */


    Tcl_MutexLock(&encodingMutex);
    for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
	Tcl_CreateHashEntry(&table,
		(char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
    }
    Tcl_MutexUnlock(&encodingMutex);

    FillEncodingFileMap();
    map = TclGetProcessGlobalValue(&encodingFileMap);


    /* Copy encoding names from encoding file map to table */


    Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done);
    for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) {
	Tcl_CreateHashEntry(&table, (char *) name, &dummy);
    }


    /* Pull all encoding names from table into the result list */


    for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_ListObjAppendElement(NULL, result, 
		(Tcl_Obj *) Tcl_GetHashKey(&table, hPtr));
    }
    Tcl_SetObjResult(interp, result);
    Tcl_DeleteHashTable(&table);
}

/*
 *------------------------------------------------------------------------
 *
 * Tcl_SetSystemEncoding --
 *
 *	Sets the default encoding that should be used whenever the user
 *	passes a NULL value in to one of the conversion routines.
 *	If the supplied name is NULL, the system encoding is reset to the
 *	default system encoding.
 *
 * Results:
 *	The return value is TCL_OK if the system encoding was successfully
 *	set to the encoding specified by name, TCL_ERROR otherwise.  If
 *	TCL_ERROR is returned, an error message is left in interp's result
 *	object, unless interp was NULL.
 *
 * Side effects:
 *	The reference count of the new system encoding is incremented.
 *	The reference count of the old system encoding is decremented and 
 *	it may be freed.  
 *
 *------------------------------------------------------------------------
 */

int
Tcl_SetSystemEncoding(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */







>
|
>
>












>
|
>
>





>
|
>
>


|











|
|
|
|


|
|
|
|


|
|
|







862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
    Tcl_HashEntry *hPtr;
    Tcl_Obj *map, *name, *result = Tcl_NewObj();
    Tcl_DictSearch mapSearch;
    int dummy, done = 0;

    Tcl_InitObjHashTable(&table);

    /*
     * Copy encoding names from loaded encoding table to table.
     */

    Tcl_MutexLock(&encodingMutex);
    for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
	Tcl_CreateHashEntry(&table,
		(char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
    }
    Tcl_MutexUnlock(&encodingMutex);

    FillEncodingFileMap();
    map = TclGetProcessGlobalValue(&encodingFileMap);

    /*
     * Copy encoding names from encoding file map to table.
     */

    Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done);
    for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) {
	Tcl_CreateHashEntry(&table, (char *) name, &dummy);
    }

    /*
     * Pull all encoding names from table into the result list.
     */

    for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_ListObjAppendElement(NULL, result,
		(Tcl_Obj *) Tcl_GetHashKey(&table, hPtr));
    }
    Tcl_SetObjResult(interp, result);
    Tcl_DeleteHashTable(&table);
}

/*
 *------------------------------------------------------------------------
 *
 * Tcl_SetSystemEncoding --
 *
 *	Sets the default encoding that should be used whenever the user passes
 *	a NULL value in to one of the conversion routines.  If the supplied
 *	name is NULL, the system encoding is reset to the default system
 *	encoding.
 *
 * Results:
 *	The return value is TCL_OK if the system encoding was successfully set
 *	to the encoding specified by name, TCL_ERROR otherwise.  If TCL_ERROR
 *	is returned, an error message is left in interp's result object,
 *	unless interp was NULL.
 *
 * Side effects:
 *	The reference count of the new system encoding is incremented.  The
 *	reference count of the old system encoding is decremented and it may
 *	be freed.
 *
 *------------------------------------------------------------------------
 */

int
Tcl_SetSystemEncoding(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_CreateEncoding --
 *
 *	This procedure is called to define a new encoding and the procedures
 *	that are used to convert between the specified encoding and Unicode.  
 *
 * Results:
 *	Returns a token that represents the encoding.  If an encoding with
 *	the same name already existed, the old encoding token remains
 *	valid and continues to behave as it used to, and will eventually
 *	be garbage collected when the last reference to it goes away.  Any
 *	subsequent calls to Tcl_GetEncoding with the specified name will
 *	retrieve the most recent encoding token.
 *
 * Side effects:
 *	The new encoding type is entered into a table visible to all
 *	interpreters, keyed off the encoding's name.  For each call to
 *	this procedure, there should eventually be a call to
 *	Tcl_FreeEncoding, so that the database can be cleaned up when
 *	encodings aren't needed anymore.
 *
 *---------------------------------------------------------------------------
 */ 

Tcl_Encoding
Tcl_CreateEncoding(typePtr)
    Tcl_EncodingType *typePtr;	/* The encoding type. */
{
    Tcl_HashEntry *hPtr;
    int new;
    Encoding *encodingPtr;
    char *name;

    Tcl_MutexLock(&encodingMutex);
    hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new);
    if (new == 0) {
	/*
	 * Remove old encoding from hash table, but don't delete it until
	 * last reference goes away.
	 */
	 
	encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
	encodingPtr->hPtr = NULL;
    }

    name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1);
    
    encodingPtr = (Encoding *) ckalloc(sizeof(Encoding));
    encodingPtr->name		= strcpy(name, typePtr->encodingName);
    encodingPtr->toUtfProc	= typePtr->toUtfProc;
    encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
    encodingPtr->freeProc	= typePtr->freeProc;
    encodingPtr->nullSize	= typePtr->nullSize;
    encodingPtr->clientData	= typePtr->clientData;







|


|
|
|
|
|
|



|
|
|
|


|














|
|

|





|







960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_CreateEncoding --
 *
 *	This procedure is called to define a new encoding and the procedures
 *	that are used to convert between the specified encoding and Unicode.
 *
 * Results:
 *	Returns a token that represents the encoding.  If an encoding with the
 *	same name already existed, the old encoding token remains valid and
 *	continues to behave as it used to, and will eventually be garbage
 *	collected when the last reference to it goes away.  Any subsequent
 *	calls to Tcl_GetEncoding with the specified name will retrieve the
 *	most recent encoding token.
 *
 * Side effects:
 *	The new encoding type is entered into a table visible to all
 *	interpreters, keyed off the encoding's name.  For each call to this
 *	procedure, there should eventually be a call to Tcl_FreeEncoding, so
 *	that the database can be cleaned up when encodings aren't needed
 *	anymore.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_CreateEncoding(typePtr)
    Tcl_EncodingType *typePtr;	/* The encoding type. */
{
    Tcl_HashEntry *hPtr;
    int new;
    Encoding *encodingPtr;
    char *name;

    Tcl_MutexLock(&encodingMutex);
    hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new);
    if (new == 0) {
	/*
	 * Remove old encoding from hash table, but don't delete it until last
	 * reference goes away.
	 */

	encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
	encodingPtr->hPtr = NULL;
    }

    name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1);

    encodingPtr = (Encoding *) ckalloc(sizeof(Encoding));
    encodingPtr->name		= strcpy(name, typePtr->encodingName);
    encodingPtr->toUtfProc	= typePtr->toUtfProc;
    encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
    encodingPtr->freeProc	= typePtr->freeProc;
    encodingPtr->nullSize	= typePtr->nullSize;
    encodingPtr->clientData	= typePtr->clientData;
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004

1005

1006
1007
1008
1009
1010

1011
1012
1013
1014

1015
1016
1017
1018
1019
1020
1021
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_ExternalToUtfDString --
 *
 *	Convert a source buffer from the specified encoding into UTF-8.
 *	If any of the bytes in the source buffer are invalid or cannot
 *	be represented in the target encoding, a default fallback
 *	character will be substituted.
 *
 * Results:
 *	The converted bytes are stored in the DString, which is then NULL
 *	terminated.  The return value is a pointer to the value stored 
 *	in the DString.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

char * 
Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr)
    Tcl_Encoding encoding;	/* The encoding for the source string, or
				 * NULL for the default system encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * encoding-specific string length. */
    Tcl_DString *dstPtr;	/* Uninitialized or free DString in which 
				 * the converted string is stored. */
{
    char *dst;
    Tcl_EncodingState state;
    Encoding *encodingPtr;
    int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;

    Tcl_DStringInit(dstPtr);
    dst = Tcl_DStringValue(dstPtr);
    dstLen = dstPtr->spaceAvl - 1;
    
    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = (*encodingPtr->lengthProc)(src);
    }

    flags = TCL_ENCODING_START | TCL_ENCODING_END;

    while (1) {
	result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src,
		srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
		&dstChars);
	soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);

	if (result != TCL_CONVERT_NOSPACE) {
	    Tcl_DStringSetLength(dstPtr, soFar);
	    return Tcl_DStringValue(dstPtr);
	}

	flags &= ~TCL_ENCODING_START;
	src += srcRead;
	srcLen -= srcRead;
	if (Tcl_DStringLength(dstPtr) == 0) {
	    Tcl_DStringSetLength(dstPtr, dstLen);
	}
	Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);







|
|
|
|



|
|







|

|
|



|
|









|










>

>





>




>







1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_ExternalToUtfDString --
 *
 *	Convert a source buffer from the specified encoding into UTF-8. If any
 *	of the bytes in the source buffer are invalid or cannot be represented
 *	in the target encoding, a default fallback character will be
 *	substituted.
 *
 * Results:
 *	The converted bytes are stored in the DString, which is then NULL
 *	terminated. The return value is a pointer to the value stored in the
 *	DString.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

char *
Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr)
    Tcl_Encoding encoding;	/* The encoding for the source string, or NULL
				 * for the default system encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * encoding-specific string length. */
    Tcl_DString *dstPtr;	/* Uninitialized or free DString in which the
				 * converted string is stored. */
{
    char *dst;
    Tcl_EncodingState state;
    Encoding *encodingPtr;
    int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;

    Tcl_DStringInit(dstPtr);
    dst = Tcl_DStringValue(dstPtr);
    dstLen = dstPtr->spaceAvl - 1;

    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = (*encodingPtr->lengthProc)(src);
    }

    flags = TCL_ENCODING_START | TCL_ENCODING_END;

    while (1) {
	result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src,
		srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
		&dstChars);
	soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);

	if (result != TCL_CONVERT_NOSPACE) {
	    Tcl_DStringSetLength(dstPtr, soFar);
	    return Tcl_DStringValue(dstPtr);
	}

	flags &= ~TCL_ENCODING_START;
	src += srcRead;
	srcLen -= srcRead;
	if (Tcl_DStringLength(dstPtr) == 0) {
	    Tcl_DStringSetLength(dstPtr, dstLen);
	}
	Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
 *
 * Tcl_ExternalToUtf --
 *
 *	Convert a source buffer from the specified encoding into UTF-8.
 *
 * Results:
 *	The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
 *	TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE,
 *	as documented in tcl.h.
 *
 * Side effects:
 *	The converted bytes are stored in the output buffer.  
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst,
	dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
    Tcl_Interp *interp;		/* Interp for error return, if not NULL. */
    Tcl_Encoding encoding;	/* The encoding for the source string, or
				 * NULL for the default system encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * encoding-specific string length. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    Encoding *encodingPtr;
    int result, srcRead, dstWrote, dstChars;
    Tcl_EncodingState state;
    
    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;







|
|


|








|
|




|
|



|
|

















|







1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
 *
 * Tcl_ExternalToUtf --
 *
 *	Convert a source buffer from the specified encoding into UTF-8.
 *
 * Results:
 *	The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
 *	TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as
 *	documented in tcl.h.
 *
 * Side effects:
 *	The converted bytes are stored in the output buffer.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst,
	dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
    Tcl_Interp *interp;		/* Interp for error return, if not NULL. */
    Tcl_Encoding encoding;	/* The encoding for the source string, or NULL
				 * for the default system encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * encoding-specific string length. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    Encoding *encodingPtr;
    int result, srcRead, dstWrote, dstChars;
    Tcl_EncodingState state;

    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114

1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173

1174
1175
1176
1177
1178
1179
1180

1181
1182
1183
1184
1185
1186
1187
    }
    if (dstCharsPtr == NULL) {
	dstCharsPtr = &dstChars;
    }

    /*
     * If there are any null characters in the middle of the buffer, they will
     * converted to the UTF-8 null character (\xC080).  To get the actual 
     * \0 at the end of the destination buffer, we need to append it manually.
     */

    dstLen--;
    result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen,
	    flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
	    dstCharsPtr);
    dst[*dstWrotePtr] = '\0';

    return result;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_UtfToExternalDString --
 *
 *	Convert a source buffer from UTF-8 into the specified encoding.
 *	If any of the bytes in the source buffer are invalid or cannot
 *	be represented in the target encoding, a default fallback
 *	character will be substituted.
 *
 * Results:
 *	The converted bytes are stored in the DString, which is then
 *	NULL terminated in an encoding-specific manner.  The return value 
 *	is a pointer to the value stored in the DString.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

char *
Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr)
    Tcl_Encoding encoding;	/* The encoding for the converted string,
				 * or NULL for the default system encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * strlen(). */
    Tcl_DString *dstPtr;	/* Uninitialized or free DString in which 
				 * the converted string is stored. */
{
    char *dst;
    Tcl_EncodingState state;
    Encoding *encodingPtr;
    int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
    
    Tcl_DStringInit(dstPtr);
    dst = Tcl_DStringValue(dstPtr);
    dstLen = dstPtr->spaceAvl - 1;

    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = strlen(src);
    }
    flags = TCL_ENCODING_START | TCL_ENCODING_END;
    while (1) {
	result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src,
		srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
		&dstChars);
	soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);

	if (result != TCL_CONVERT_NOSPACE) {
	    if (encodingPtr->nullSize == 2) {
	        Tcl_DStringSetLength(dstPtr, soFar + 1);
	    }
	    Tcl_DStringSetLength(dstPtr, soFar);
	    return Tcl_DStringValue(dstPtr);
	}

	flags &= ~TCL_ENCODING_START;
	src += srcRead;
	srcLen -= srcRead;
	if (Tcl_DStringLength(dstPtr) == 0) {
	    Tcl_DStringSetLength(dstPtr, dstLen);
	}
	Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);







|
|







>








|
|
|
|


|
|
|









|
|



|
|





|




















>


|




>







1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
    }
    if (dstCharsPtr == NULL) {
	dstCharsPtr = &dstChars;
    }

    /*
     * If there are any null characters in the middle of the buffer, they will
     * converted to the UTF-8 null character (\xC080). To get the actual \0 at
     * the end of the destination buffer, we need to append it manually.
     */

    dstLen--;
    result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen,
	    flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
	    dstCharsPtr);
    dst[*dstWrotePtr] = '\0';

    return result;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_UtfToExternalDString --
 *
 *	Convert a source buffer from UTF-8 into the specified encoding.  If
 *	any of the bytes in the source buffer are invalid or cannot be
 *	represented in the target encoding, a default fallback character will
 *	be substituted.
 *
 * Results:
 *	The converted bytes are stored in the DString, which is then NULL
 *	terminated in an encoding-specific manner.  The return value is a
 *	pointer to the value stored in the DString.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

char *
Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr)
    Tcl_Encoding encoding;	/* The encoding for the converted string, or
				 * NULL for the default system encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * strlen(). */
    Tcl_DString *dstPtr;	/* Uninitialized or free DString in which the
				 * converted string is stored. */
{
    char *dst;
    Tcl_EncodingState state;
    Encoding *encodingPtr;
    int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;

    Tcl_DStringInit(dstPtr);
    dst = Tcl_DStringValue(dstPtr);
    dstLen = dstPtr->spaceAvl - 1;

    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = strlen(src);
    }
    flags = TCL_ENCODING_START | TCL_ENCODING_END;
    while (1) {
	result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src,
		srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
		&dstChars);
	soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);

	if (result != TCL_CONVERT_NOSPACE) {
	    if (encodingPtr->nullSize == 2) {
		Tcl_DStringSetLength(dstPtr, soFar + 1);
	    }
	    Tcl_DStringSetLength(dstPtr, soFar);
	    return Tcl_DStringValue(dstPtr);
	}

	flags &= ~TCL_ENCODING_START;
	src += srcRead;
	srcLen -= srcRead;
	if (Tcl_DStringLength(dstPtr) == 0) {
	    Tcl_DStringSetLength(dstPtr, dstLen);
	}
	Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
 *
 * Tcl_UtfToExternal --
 *
 *	Convert a buffer from UTF-8 into the specified encoding.
 *
 * Results:
 *	The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
 *	TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE,
 *	as documented in tcl.h.
 *
 * Side effects:
 *	The converted bytes are stored in the output buffer.  
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst,
	dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
    Tcl_Interp *interp;		/* Interp for error return, if not NULL. */
    Tcl_Encoding encoding;	/* The encoding for the converted string,
				 * or NULL for the default system encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * strlen(). */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */







|
|


|








|
|




|
|







1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
 *
 * Tcl_UtfToExternal --
 *
 *	Convert a buffer from UTF-8 into the specified encoding.
 *
 * Results:
 *	The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
 *	TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as
 *	documented in tcl.h.
 *
 * Side effects:
 *	The converted bytes are stored in the output buffer.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst,
	dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
    Tcl_Interp *interp;		/* Interp for error return, if not NULL. */
    Tcl_Encoding encoding;	/* The encoding for the converted string, or
				 * NULL for the default system encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes, or < 0 for
				 * strlen(). */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    Encoding *encodingPtr;
    int result, srcRead, dstWrote, dstChars;
    Tcl_EncodingState state;
    
    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;







|







1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    Encoding *encodingPtr;
    int result, srcRead, dstWrote, dstChars;
    Tcl_EncodingState state;

    if (encoding == NULL) {
	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305

1306
1307



















































































































1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
    result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen,
	    flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
	    dstCharsPtr);
    if (encodingPtr->nullSize == 2) {
	dst[*dstWrotePtr + 1] = '\0';
    }
    dst[*dstWrotePtr] = '\0';
    
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FindExecutable --
 *
 *	This procedure computes the absolute path name of the current
 *	application, given its argv[0] value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The absolute pathname for the application is computed and stored
 *	to be returned later be [info nameofexecutable].
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_FindExecutable(argv0)
    CONST char *argv0;		/* The value of the application's argv[0]
				 * (native). */
{
    TclInitSubsystems();

    TclpFindExecutable(argv0);
}




















































































































/*
 *---------------------------------------------------------------------------
 *
 * LoadEncodingFile --
 *
 *	Read a file that describes an encoding and create a new Encoding
 *	from the data.  
 *
 * Results:
 *	The return value is the newly loaded Encoding, or NULL if
 *	the file didn't exist of was in the incorrect format.  If NULL was
 *	returned, an error message is left in interp's result object,
 *	unless interp was NULL.
 *
 * Side effects:
 *	File read from disk.  
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadEncodingFile(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */
    CONST char *name;		/* The name of the encoding file on disk
				 * and also the name for new encoding. */
{
    Tcl_Channel chan;
    Tcl_Encoding encoding;
    Tcl_Obj *map, *path, *directory = NULL;
    Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
    int ch, scanned = 0;


    Tcl_IncrRefCount(nameObj);
    while (1) {
	map = TclGetProcessGlobalValue(&encodingFileMap);
	Tcl_DictObjGet(NULL, map, nameObj, &directory);
	if (scanned || (NULL != directory)) {
	    break;
	}
scan:
	FillEncodingFileMap();
	scanned = 1;
    }
    if (NULL == directory) {
	Tcl_DecrRefCount(nameObj);
	goto unknown;
    }

    /* Construct $directory/$encoding.enc path name */
    Tcl_IncrRefCount(directory);
    Tcl_AppendToObj(nameObj, ".enc", -1);
    path = Tcl_FSJoinToPath(directory, 1, &nameObj);
    Tcl_DecrRefCount(directory);
    Tcl_IncrRefCount(path);
    chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
    Tcl_DecrRefCount(path);

    if (NULL == chan) {
	if (!scanned) {
	    goto scan;
	}
	goto unknown;
    }

    Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");

    while (1) {
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_Gets(chan, &ds);
	ch = Tcl_DStringValue(&ds)[0];
	Tcl_DStringFree(&ds);
	if (ch != '#') {
	    break;
	}
    }

    encoding = NULL;
    switch (ch) {
	case 'S': {
	    encoding = LoadTableEncoding(name, ENCODING_SINGLEBYTE, chan);
	    break;
	}
	case 'D': {
	    encoding = LoadTableEncoding(name, ENCODING_DOUBLEBYTE, chan);
	    break;
	}
	case 'M': {
	    encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan);
	    break;
	}
	case 'E': {
	    encoding = LoadEscapeEncoding(name, chan);
	    break;
	}
    }
    if ((encoding == NULL) && (interp != NULL)) {
	Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
    }
    Tcl_Close(NULL, chan);
    return encoding;

    unknown:
    if (interp != NULL) {
	Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
    }
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *
 * LoadTableEncoding --
 *
 *	Helper function for LoadEncodingTable().  Loads a table to that 
 *	converts between Unicode and some other encoding and creates an 
 *	encoding (using a TableEncoding structure) from that information.
 *
 *	File contains binary data, but begins with a marker to indicate 
 *	byte-ordering, so that same binary file can be read on either
 *	endian platforms.
 *
 * Results:
 *	The return value is the new encoding, or NULL if the encoding 
 *	could not be created (because the file contained invalid data).
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */








|















|
|










>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|


|
|
|
|


|







|
|

|
|
<
<
|

<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
<
<
















<

|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<





<

<
<
<
<
|







|
|


|
|
|


|
|







1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535


1536
1537









1538






1539








1540





1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556

1557
1558
1559
1560

1561
1562
1563

1564
1565
1566

1567
1568
1569

1570
1571
1572
1573
1574

1575




1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
    result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen,
	    flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
	    dstCharsPtr);
    if (encodingPtr->nullSize == 2) {
	dst[*dstWrotePtr + 1] = '\0';
    }
    dst[*dstWrotePtr] = '\0';

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FindExecutable --
 *
 *	This procedure computes the absolute path name of the current
 *	application, given its argv[0] value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The absolute pathname for the application is computed and stored to be
 *	returned later be [info nameofexecutable].
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_FindExecutable(argv0)
    CONST char *argv0;		/* The value of the application's argv[0]
				 * (native). */
{
    TclInitSubsystems();
    TclpSetInitialEncodings();
    TclpFindExecutable(argv0);
}

/*
 *---------------------------------------------------------------------------
 *
 * OpenEncodingFileChannel --
 *
 *	Open the file believed to hold data for the encoding, "name".
 *
 * Results:
 * 	Returns the readable Tcl_Channel from opening the file, or NULL if the
 * 	file could not be successfully opened.  If NULL was * returned, an
 * 	error message is left in interp's result object, * unless interp was
 * 	NULL.
 *
 * Side effects:
 *	Channel may be opened.  Information about the filesystem may be cached
 *	to speed later calls.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Channel
OpenEncodingFileChannel(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */
    CONST char *name;		/* The name of the encoding file on disk and
				 * also the name for new encoding. */
{
    Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
    Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj);
    Tcl_Obj *searchPath = Tcl_DuplicateObj(TclGetEncodingSearchPath());
    Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap);
    Tcl_Obj **dir, *path, *directory = NULL;
    Tcl_Channel chan = NULL;
    int i, numDirs;

    Tcl_ListObjGetElements(NULL, searchPath, &numDirs, &dir);
    Tcl_IncrRefCount(nameObj);
    Tcl_AppendToObj(fileNameObj, ".enc", -1);
    Tcl_IncrRefCount(fileNameObj);
    Tcl_DictObjGet(NULL, map, nameObj, &directory);

    /*
     * Check that any cached directory is still on the encoding search path.
     */

    if (NULL != directory) {
	int verified = 0;

	for (i=0; i<numDirs && !verified; i++) {
	    if (dir[i] == directory) {
		verified = 1;
	    }
	}
	if (!verified) {
	    CONST char *dirString = Tcl_GetString(directory);
	    for (i=0; i<numDirs && !verified; i++) {
		if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) {
		    verified = 1;
		}
	    }
	}
	if (!verified) {
	    /*
	     * Directory no longer on the search path.  Remove from cache.
	     */

	    map = Tcl_DuplicateObj(map);
	    Tcl_DictObjRemove(NULL, map, nameObj);
	    TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
	    directory = NULL;
	}
    }

    if (NULL != directory) {
	/*
	 * Got a directory from the cache.  Try to use it first.
	 */

	Tcl_IncrRefCount(directory);
	path = Tcl_FSJoinToPath(directory, 1, &fileNameObj);
	Tcl_IncrRefCount(path);
	Tcl_DecrRefCount(directory);
	chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
	Tcl_DecrRefCount(path);
    }

    /*
     * Scan the search path until we find it.
     */

    for (i=0; i<numDirs && (chan == NULL); i++) {
	path = Tcl_FSJoinToPath(dir[i], 1, &fileNameObj);
	Tcl_IncrRefCount(path);
	chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
	Tcl_DecrRefCount(path);
	if (chan != NULL) {
	    /*
	     * Save directory in the cache.
	     */

	    map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
	    Tcl_DictObjPut(NULL, map, nameObj, dir[i]);
	    TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
	}
    }

    if ((NULL == chan) && (interp != NULL)) {
	Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
    }
    Tcl_DecrRefCount(fileNameObj);
    Tcl_DecrRefCount(nameObj);
    Tcl_DecrRefCount(searchPath);

    return chan;
}

/*
 *---------------------------------------------------------------------------
 *
 * LoadEncodingFile --
 *
 *	Read a file that describes an encoding and create a new Encoding from
 *	the data.
 *
 * Results:
 *	The return value is the newly loaded Encoding, or NULL if the file
 *	didn't exist of was in the incorrect format.  If NULL was returned, an
 *	error message is left in interp's result object, unless interp was
 *	NULL.
 *
 * Side effects:
 *	File read from disk.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadEncodingFile(interp, name)
    Tcl_Interp *interp;		/* Interp for error reporting, if not NULL. */
    CONST char *name;		/* The name of the encoding file on disk and
				 * also the name for new encoding. */
{
    Tcl_Channel chan = NULL;
    Tcl_Encoding encoding = NULL;


    int ch;










    chan = OpenEncodingFileChannel(interp, name);






    if (chan == NULL) {








	return NULL;





    }

    Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");

    while (1) {
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_Gets(chan, &ds);
	ch = Tcl_DStringValue(&ds)[0];
	Tcl_DStringFree(&ds);
	if (ch != '#') {
	    break;
	}
    }


    switch (ch) {
    case 'S':
	encoding = LoadTableEncoding(name, ENCODING_SINGLEBYTE, chan);
	break;

    case 'D':
	encoding = LoadTableEncoding(name, ENCODING_DOUBLEBYTE, chan);
	break;

    case 'M':
	encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan);
	break;

    case 'E':
	encoding = LoadEscapeEncoding(name, chan);
	break;

    }
    if ((encoding == NULL) && (interp != NULL)) {
	Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
    }
    Tcl_Close(NULL, chan);






    return encoding;
}

/*
 *-------------------------------------------------------------------------
 *
 * LoadTableEncoding --
 *
 *	Helper function for LoadEncodingTable().  Loads a table to that
 *	converts between Unicode and some other encoding and creates an
 *	encoding (using a TableEncoding structure) from that information.
 *
 *	File contains binary data, but begins with a marker to indicate
 *	byte-ordering, so that same binary file can be read on either endian
 *	platforms.
 *
 * Results:
 *	The return value is the new encoding, or NULL if the encoding could
 *	not be created (because the file contained invalid data).
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
    dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
    memset(dataPtr, 0, sizeof(TableEncodingData));

    dataPtr->fallback = fallback;

    /*
     * Read the table that maps characters to Unicode.  Performs a single
     * malloc to get the memory for the array and all the pages needed by
     * the array.
     */

    size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
    dataPtr->toUnicode = (unsigned short **) ckalloc(size);
    memset(dataPtr->toUnicode, 0, size);
    pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);

    TclNewObj(objPtr);
    Tcl_IncrRefCount(objPtr);
    for (i = 0; i < numPages; i++) {
	int ch;
	char *p;

	Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
	p = Tcl_GetString(objPtr);
	hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]];
	dataPtr->toUnicode[hi] = pageMemPtr;
	p += 2;
	for (lo = 0; lo < 256; lo++) {
	    if ((lo & 0x0f) == 0) {
		p++;
	    }
	    ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8)
		+ (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]];
	    if (ch != 0) {
		used[ch >> 8] = 1;
	    }
	    *pageMemPtr = (unsigned short) ch;
	    pageMemPtr++;
	    p += 4;
	}
    }
    TclDecrRefCount(objPtr);
	
    if (type == ENCODING_DOUBLEBYTE) {
	memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes));
    } else {
	for (hi = 1; hi < 256; hi++) {
	    if (dataPtr->toUnicode[hi] != NULL) {
		dataPtr->prefixBytes[hi] = 1;
	    }
	}
    }

    /*
     * Invert toUnicode array to produce the fromUnicode array.  Performs a
     * single malloc to get the memory for the array and all the pages
     * needed by the array.  While reading in the toUnicode array, we
     * remembered what pages that would be needed for the fromUnicode array.
     */

    if (symbol) {
	used[0] = 1;
    }
    numPages = 0;
    for (hi = 0; hi < 256; hi++) {







|
|















|






|
|









|












|
|
|







1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
    dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
    memset(dataPtr, 0, sizeof(TableEncodingData));

    dataPtr->fallback = fallback;

    /*
     * Read the table that maps characters to Unicode.  Performs a single
     * malloc to get the memory for the array and all the pages needed by the
     * array.
     */

    size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
    dataPtr->toUnicode = (unsigned short **) ckalloc(size);
    memset(dataPtr->toUnicode, 0, size);
    pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);

    TclNewObj(objPtr);
    Tcl_IncrRefCount(objPtr);
    for (i = 0; i < numPages; i++) {
	int ch;
	char *p;

	Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
	p = Tcl_GetString(objPtr);
	hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
	dataPtr->toUnicode[hi] = pageMemPtr;
	p += 2;
	for (lo = 0; lo < 256; lo++) {
	    if ((lo & 0x0f) == 0) {
		p++;
	    }
	    ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8)
		    + (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])];
	    if (ch != 0) {
		used[ch >> 8] = 1;
	    }
	    *pageMemPtr = (unsigned short) ch;
	    pageMemPtr++;
	    p += 4;
	}
    }
    TclDecrRefCount(objPtr);

    if (type == ENCODING_DOUBLEBYTE) {
	memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes));
    } else {
	for (hi = 1; hi < 256; hi++) {
	    if (dataPtr->toUnicode[hi] != NULL) {
		dataPtr->prefixBytes[hi] = 1;
	    }
	}
    }

    /*
     * Invert toUnicode array to produce the fromUnicode array.  Performs a
     * single malloc to get the memory for the array and all the pages needed
     * by the array.  While reading in the toUnicode array, we remembered what
     * pages that would be needed for the fromUnicode array.
     */

    if (symbol) {
	used[0] = 1;
    }
    numPages = 0;
    for (hi = 0; hi < 256; hi++) {
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
	} else {
	    for (lo = 0; lo < 256; lo++) {
		int ch;

		ch = dataPtr->toUnicode[hi][lo];
		if (ch != 0) {
		    unsigned short *page;
		    
		    page = dataPtr->fromUnicode[ch >> 8];
		    if (page == NULL) {
			page = pageMemPtr;
			pageMemPtr += 256;
			dataPtr->fromUnicode[ch >> 8] = page;
		    }
		    page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);







|







1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
	} else {
	    for (lo = 0; lo < 256; lo++) {
		int ch;

		ch = dataPtr->toUnicode[hi][lo];
		if (ch != 0) {
		    unsigned short *page;

		    page = dataPtr->fromUnicode[ch >> 8];
		    if (page == NULL) {
			page = pageMemPtr;
			pageMemPtr += 256;
			dataPtr->fromUnicode[ch >> 8] = page;
		    }
		    page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642

1643
1644
1645

1646
1647
1648


1649


1650
1651

1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663

1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
	    if (dataPtr->fromUnicode[0]['\\'] == '\0') {
		dataPtr->fromUnicode[0]['\\'] = '\\';
	    }
	}
    }
    if (symbol) {
	unsigned short *page;
	
	/*
	 * Make a special symbol encoding that not only maps the symbol
	 * characters from their Unicode code points down into page 0, but
	 * also ensure that the characters on page 0 map to themselves.
	 * This is so that a symbol font can be used to display a simple
	 * string like "abcd" and have alpha, beta, chi, delta show up,
	 * rather than have "unknown" chars show up because strictly
	 * speaking the symbol font doesn't have glyphs for those low ascii
	 * chars.
	 */

	page = dataPtr->fromUnicode[0];
	if (page == NULL) {
	    page = pageMemPtr;
	    dataPtr->fromUnicode[0] = page;
	}
	for (lo = 0; lo < 256; lo++) {
	    if (dataPtr->toUnicode[0][lo] != 0) {
		page[lo] = (unsigned short) lo;
	    }
	}
    }
    for (hi = 0; hi < 256; hi++) {
	if (dataPtr->fromUnicode[hi] == NULL) {
	    dataPtr->fromUnicode[hi] = emptyPage;
	}
    }

    /*
     * For trailing 'R'everse encoding, see [Patch #689341]
     */

    Tcl_DStringInit(&lineString);
    do {
	int len;


	/* skip leading empty lines */


	while ((len = Tcl_Gets(chan, &lineString)) == 0)
	    ;

	if (len < 0) {
	    break;
	}
	line = Tcl_DStringValue(&lineString);
	if (line[0] != 'R') {
	    break;
	}
	for (Tcl_DStringSetLength(&lineString, 0);
	     (len = Tcl_Gets(chan, &lineString)) >= 0;
	     Tcl_DStringSetLength(&lineString, 0)) {
	    unsigned char* p;
	    int to, from;

	    if (len < 5) {
		continue;
	    }
	    p = (unsigned char*) Tcl_DStringValue(&lineString);
	    to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
		+ (staticHex[p[2]] << 4) + staticHex[p[3]];
	    if (to == 0) {
	    	continue;
	    }
	    for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
		from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
			+ (staticHex[p[2]] << 4) + staticHex[p[3]];
	    	if (from == 0) {







|



|
|
|
|
|
<


















>



>



>
>
|
>
>


>








|
|


>





|







1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782

1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
	    if (dataPtr->fromUnicode[0]['\\'] == '\0') {
		dataPtr->fromUnicode[0]['\\'] = '\\';
	    }
	}
    }
    if (symbol) {
	unsigned short *page;

	/*
	 * Make a special symbol encoding that not only maps the symbol
	 * characters from their Unicode code points down into page 0, but
	 * also ensure that the characters on page 0 map to themselves. This
	 * is so that a symbol font can be used to display a simple string
	 * like "abcd" and have alpha, beta, chi, delta show up, rather than
	 * have "unknown" chars show up because strictly speaking the symbol
	 * font doesn't have glyphs for those low ascii chars.

	 */

	page = dataPtr->fromUnicode[0];
	if (page == NULL) {
	    page = pageMemPtr;
	    dataPtr->fromUnicode[0] = page;
	}
	for (lo = 0; lo < 256; lo++) {
	    if (dataPtr->toUnicode[0][lo] != 0) {
		page[lo] = (unsigned short) lo;
	    }
	}
    }
    for (hi = 0; hi < 256; hi++) {
	if (dataPtr->fromUnicode[hi] == NULL) {
	    dataPtr->fromUnicode[hi] = emptyPage;
	}
    }

    /*
     * For trailing 'R'everse encoding, see [Patch #689341]
     */

    Tcl_DStringInit(&lineString);
    do {
	int len;

	/*
	 * Skip leading empty lines.
	 */

	while ((len = Tcl_Gets(chan, &lineString)) == 0)
	    ;

	if (len < 0) {
	    break;
	}
	line = Tcl_DStringValue(&lineString);
	if (line[0] != 'R') {
	    break;
	}
	for (Tcl_DStringSetLength(&lineString, 0);
		(len = Tcl_Gets(chan, &lineString)) >= 0;
		Tcl_DStringSetLength(&lineString, 0)) {
	    unsigned char* p;
	    int to, from;

	    if (len < 5) {
		continue;
	    }
	    p = (unsigned char*) Tcl_DStringValue(&lineString);
	    to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
		    + (staticHex[p[2]] << 4) + staticHex[p[3]];
	    if (to == 0) {
	    	continue;
	    }
	    for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
		from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
			+ (staticHex[p[2]] << 4) + staticHex[p[3]];
	    	if (from == 0) {
1684
1685
1686
1687
1688
1689
1690

1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715

    encType.encodingName    = name;
    encType.toUtfProc	    = TableToUtfProc;
    encType.fromUtfProc	    = TableFromUtfProc;
    encType.freeProc	    = TableFreeProc;
    encType.nullSize	    = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
    encType.clientData	    = (ClientData) dataPtr;

    return Tcl_CreateEncoding(&encType);
}

/*
 *-------------------------------------------------------------------------
 *
 * LoadEscapeEncoding --
 *
 *	Helper function for LoadEncodingTable().  Loads a state machine
 *	that converts between Unicode and some other encoding.  
 *
 *	File contains text data that describes the escape sequences that
 *	are used to choose an encoding and the associated names for the 
 *	sub-encodings.
 *
 * Results:
 *	The return value is the new encoding, or NULL if the encoding 
 *	could not be created (because the file contained invalid data).
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */








>








|
|

|
|



|
|







1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882

    encType.encodingName    = name;
    encType.toUtfProc	    = TableToUtfProc;
    encType.fromUtfProc	    = TableFromUtfProc;
    encType.freeProc	    = TableFreeProc;
    encType.nullSize	    = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
    encType.clientData	    = (ClientData) dataPtr;

    return Tcl_CreateEncoding(&encType);
}

/*
 *-------------------------------------------------------------------------
 *
 * LoadEscapeEncoding --
 *
 *	Helper function for LoadEncodingTable().  Loads a state machine that
 *	converts between Unicode and some other encoding.
 *
 *	File contains text data that describes the escape sequences that are
 *	used to choose an encoding and the associated names for the
 *	sub-encodings.
 *
 * Results:
 *	The return value is the new encoding, or NULL if the encoding could
 *	not be created (because the file contained invalid data).
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
    Tcl_DStringInit(&escapeData);

    while (1) {
	int argc;
	CONST char **argv;
	char *line;
	Tcl_DString lineString;
	
	Tcl_DStringInit(&lineString);
	if (Tcl_Gets(chan, &lineString) < 0) {
	    break;
	}
	line = Tcl_DStringValue(&lineString);
        if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
	    continue;
	}
	if (argc >= 2) {
	    if (strcmp(argv[0], "name") == 0) {
		;
	    } else if (strcmp(argv[0], "init") == 0) {
		strncpy(init, argv[1], sizeof(init));







|





|







1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
    Tcl_DStringInit(&escapeData);

    while (1) {
	int argc;
	CONST char **argv;
	char *line;
	Tcl_DString lineString;

	Tcl_DStringInit(&lineString);
	if (Tcl_Gets(chan, &lineString) < 0) {
	    break;
	}
	line = Tcl_DStringValue(&lineString);
	if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
	    continue;
	}
	if (argc >= 2) {
	    if (strcmp(argv[0], "name") == 0) {
		;
	    } else if (strcmp(argv[0], "init") == 0) {
		strncpy(init, argv[1], sizeof(init));
1758
1759
1760
1761
1762
1763
1764

1765


1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782

1783
1784
1785
1786
1787
1788
1789
1790
		strncpy(est.sequence, argv[1], sizeof(est.sequence));
		est.sequence[sizeof(est.sequence) - 1] = '\0';
		est.sequenceLen = strlen(est.sequence);

		strncpy(est.name, argv[0], sizeof(est.name));
		est.name[sizeof(est.name) - 1] = '\0';


		/* To avoid infinite recursion in [encoding system iso2022-*]*/


		Tcl_GetEncoding(NULL, est.name);

		est.encodingPtr = NULL;
		Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
	    }
	}
	ckfree((char *) argv);
	Tcl_DStringFree(&lineString);
    }

    size = sizeof(EscapeEncodingData)
	    - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData);
    dataPtr = (EscapeEncodingData *) ckalloc(size);
    dataPtr->initLen = strlen(init);
    strcpy(dataPtr->init, init);
    dataPtr->finalLen = strlen(final);
    strcpy(dataPtr->final, final);

    dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
    memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData),
	    (size_t) Tcl_DStringLength(&escapeData));
    Tcl_DStringFree(&escapeData);

    memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes));
    for (i = 0; i < dataPtr->numSubTables; i++) {
	dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1;







>
|
>
>










|
|





>
|







1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
		strncpy(est.sequence, argv[1], sizeof(est.sequence));
		est.sequence[sizeof(est.sequence) - 1] = '\0';
		est.sequenceLen = strlen(est.sequence);

		strncpy(est.name, argv[0], sizeof(est.name));
		est.name[sizeof(est.name) - 1] = '\0';

		/*
		 * To avoid infinite recursion in [encoding system iso2022-*]
		 */

		Tcl_GetEncoding(NULL, est.name);

		est.encodingPtr = NULL;
		Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
	    }
	}
	ckfree((char *) argv);
	Tcl_DStringFree(&lineString);
    }

    size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable)
	    + Tcl_DStringLength(&escapeData);
    dataPtr = (EscapeEncodingData *) ckalloc(size);
    dataPtr->initLen = strlen(init);
    strcpy(dataPtr->init, init);
    dataPtr->finalLen = strlen(final);
    strcpy(dataPtr->final, final);
    dataPtr->numSubTables =
	    Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
    memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData),
	    (size_t) Tcl_DStringLength(&escapeData));
    Tcl_DStringFree(&escapeData);

    memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes));
    for (i = 0; i < dataPtr->numSubTables; i++) {
	dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1;
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
}

/*
 *-------------------------------------------------------------------------
 *
 * BinaryProc --
 *
 *	The default conversion when no other conversion is specified.
 *	No translation is done; source bytes are copied directly to 
 *	destination bytes.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string (unknown encoding). */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */







|
|
|

















|
|



|
|







1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
}

/*
 *-------------------------------------------------------------------------
 *
 * BinaryProc --
 *
 *	The default conversion when no other conversion is specified.  No
 *	translation is done; source bytes are copied directly to destination
 *	bytes.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string (unknown encoding). */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890

1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
    *dstCharsPtr = srcLen;
    for ( ; --srcLen >= 0; ) {
	*dst++ = *src++;
    }
    return result;
}


/*
 *-------------------------------------------------------------------------
 *
 * UtfExtToUtfIntProc --
 *
 *	Convert from UTF-8 to UTF-8. While converting null-bytes from
 *	the Tcl's internal representation (0xc0, 0x80) to the official
 *	representation (0x00). See UtfToUtfProc for details.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	     srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
			srcReadPtr, dstWrotePtr, dstCharsPtr, 1);
}

/*
 *-------------------------------------------------------------------------
 *
 * UtfExtToUtfIntProc --
 *
 *	Convert from UTF-8 to UTF-8 while converting null-bytes from
 *	the official representation (0x00) to Tcl's internal
 *	representation (0xc0, 0x80). See UtfToUtfProc for details.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */
static int 
UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	     srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
			srcReadPtr, dstWrotePtr, dstCharsPtr, 0);
}

/*
 *-------------------------------------------------------------------------
 *
 * UtfToUtfProc --
 *
 *	Convert from UTF-8 to UTF-8.  Note that the UTF-8 to UTF-8 
 *	translation is not a no-op, because it will turn a stream of
 *	improperly formed UTF-8 into a properly formed stream.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	     srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
    int pureNullMode;		/* Convert embedded nulls from
				 * internal representation to real
				 * null-bytes or vice versa */

{
    CONST char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd;
    int result, numChars;
    Tcl_UniChar ch;

    result = TCL_OK;
    
    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }








<





|
|










>
|

|




|
|




















|



















|

|




|
|



|
|















|







|
|
|










|

|




|
|



|
|



|
|
|
|






|
|
<
|







|







2037
2038
2039
2040
2041
2042
2043

2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189

2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
    *dstCharsPtr = srcLen;
    for ( ; --srcLen >= 0; ) {
	*dst++ = *src++;
    }
    return result;
}


/*
 *-------------------------------------------------------------------------
 *
 * UtfExtToUtfIntProc --
 *
 *	Convert from UTF-8 to UTF-8. While converting null-bytes from the
 *	Tcl's internal representation (0xc0, 0x80) to the official
 *	representation (0x00). See UtfToUtfProc for details.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	    srcReadPtr, dstWrotePtr, dstCharsPtr, 1);
}

/*
 *-------------------------------------------------------------------------
 *
 * UtfExtToUtfIntProc --
 *
 *	Convert from UTF-8 to UTF-8 while converting null-bytes from
 *	the official representation (0x00) to Tcl's internal
 *	representation (0xc0, 0x80). See UtfToUtfProc for details.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */
static int
UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	    srcReadPtr, dstWrotePtr, dstCharsPtr, 0);
}

/*
 *-------------------------------------------------------------------------
 *
 * UtfToUtfProc --
 *
 *	Convert from UTF-8 to UTF-8.  Note that the UTF-8 to UTF-8 translation
 *	is not a no-op, because it will turn a stream of improperly formed
 *	UTF-8 into a properly formed stream.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted. This may
				 * be less than the original source length if
				 * there was a problem converting some source
				 * characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
    int pureNullMode;		/* Convert embedded nulls from internal
				 * representation to real null-bytes or vice

				 * versa. */
{
    CONST char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd;
    int result, numChars;
    Tcl_UniChar ch;

    result = TCL_OK;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }

2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058

2059
2060
2061
2062
2063
2064
2065

2066
2067
2068
2069
2070
2071
2072
	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	if (UCHAR(*src) < 0x80 &&
	    !(UCHAR(*src) == 0 && pureNullMode == 0)) {
	    /*
	     * Copy 7bit chatacters, but skip null-bytes when we are
	     * in input mode, so that they get converted to 0xc080.
	     */

	    *dst++ = *src++;
	} else if (pureNullMode == 1 &&
		   UCHAR(*src) == 0xc0 &&
		   UCHAR(*(src+1)) == 0x80) {
	    /* 
	     * Convert 0xc080 to real nulls when we are in output mode.
	     */

	    *dst++ = 0;
	    src += 2;
	} else {
	    src += Tcl_UtfToUniChar(src, &ch);
	    dst += Tcl_UniCharToUtf(ch, dst);
	}
    }







|
<

|
|

>

|
<
|
|


>







2216
2217
2218
2219
2220
2221
2222
2223

2224
2225
2226
2227
2228
2229
2230

2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) {

	    /*
	     * Copy 7bit chatacters, but skip null-bytes when we are in input
	     * mode, so that they get converted to 0xc080.
	     */

	    *dst++ = *src++;
	} else if (pureNullMode == 1 && UCHAR(*src) == 0xc0 &&

		UCHAR(*(src+1)) == 0x80) {
	    /*
	     * Convert 0xc080 to real nulls when we are in output mode.
	     */

	    *dst++ = 0;
	    src += 2;
	} else {
	    src += Tcl_UtfToUniChar(src, &ch);
	    dst += Tcl_UniCharToUtf(ch, dst);
	}
    }
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147

2148
2149
2150

2151
2152
2153
2154
2155
2156
2157
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in Unicode. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd;
    char *dstEnd, *dstStart;
    int result, numChars;
    
    result = TCL_OK;
    if ((srcLen % sizeof(Tcl_UniChar)) != 0) {
	result = TCL_CONVERT_MULTIBYTE;
	srcLen /= sizeof(Tcl_UniChar);
	srcLen *= sizeof(Tcl_UniChar);
    }

    wSrc = (Tcl_UniChar *) src;

    wSrcStart = (Tcl_UniChar *) src;
    wSrcEnd = (Tcl_UniChar *) (src + srcLen);

    dstStart = dst;
    dstEnd = dst + dstLen - TCL_UTF_MAX;

    for (numChars = 0; wSrc < wSrcEnd; numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	/*
	 * Special case for 1-byte utf chars for speed.
	 */

	if (*wSrc && *wSrc < 0x80) {
	    *dst++ = (char) *wSrc;
	} else {
	    dst += Tcl_UniCharToUtf(*wSrc, dst);
	}
	wSrc++;
    }







|






|
|



|
|

















|




















>



>







2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* Not used. */
    CONST char *src;		/* Source string in Unicode. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd;
    char *dstEnd, *dstStart;
    int result, numChars;

    result = TCL_OK;
    if ((srcLen % sizeof(Tcl_UniChar)) != 0) {
	result = TCL_CONVERT_MULTIBYTE;
	srcLen /= sizeof(Tcl_UniChar);
	srcLen *= sizeof(Tcl_UniChar);
    }

    wSrc = (Tcl_UniChar *) src;

    wSrcStart = (Tcl_UniChar *) src;
    wSrcEnd = (Tcl_UniChar *) (src + srcLen);

    dstStart = dst;
    dstEnd = dst + dstLen - TCL_UTF_MAX;

    for (numChars = 0; wSrc < wSrcEnd; numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}

	/*
	 * Special case for 1-byte utf chars for speed.
	 */

	if (*wSrc && *wSrc < 0x80) {
	    *dst++ = (char) *wSrc;
	} else {
	    dst += Tcl_UniCharToUtf(*wSrc, dst);
	}
	wSrc++;
    }
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184

2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TableEncodingData that specifies encoding. */

    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    CONST char *srcStart, *srcEnd, *srcClose;
    Tcl_UniChar *wDst, *wDstStart, *wDstEnd;
    int result, numChars;
    
    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }








|


|
>



|
|



|
|

















|







2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TableEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    CONST char *srcStart, *srcEnd, *srcClose;
    Tcl_UniChar *wDst, *wDstStart, *wDstEnd;
    int result, numChars;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }

2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241

2242
2243
2244
2245
2246
2247
2248

	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (wDst > wDstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
        }
	src += TclUtfToUniChar(src, wDst);
	wDst++;
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = (char *) wDst - (char *) wDstStart;
    *dstCharsPtr = numChars;
    return result;
}

/*







|



>







2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422

	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (wDst > wDstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	src += TclUtfToUniChar(src, wDst);
	wDst++;
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = (char *) wDst - (char *) wDstStart;
    *dstCharsPtr = numChars;
    return result;
}

/*
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TableEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */







|







|
|



|
|







2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TableEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
    CONST char *srcStart, *srcEnd;
    char *dstEnd, *dstStart, *prefixBytes;
    int result, byte, numChars;
    Tcl_UniChar ch;
    unsigned short **toUnicode;
    unsigned short *pageZero;
    TableEncodingData *dataPtr;
    
    srcStart = src;
    srcEnd = src + srcLen;

    dstStart = dst;
    dstEnd = dst + dstLen - TCL_UTF_MAX;

    dataPtr = (TableEncodingData *) clientData;
    toUnicode = dataPtr->toUnicode;
    prefixBytes = dataPtr->prefixBytes;
    pageZero = toUnicode[0];

    result = TCL_OK;
    for (numChars = 0; src < srcEnd; numChars++) {
        if (dst > dstEnd) {
            result = TCL_CONVERT_NOSPACE;
            break;
        }
	byte = *((unsigned char *) src);
	if (prefixBytes[byte]) {
	    src++;
	    if (src >= srcEnd) {
		src--;
		result = TCL_CONVERT_MULTIBYTE;
		break;







|













|
|
|
|







2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
    CONST char *srcStart, *srcEnd;
    char *dstEnd, *dstStart, *prefixBytes;
    int result, byte, numChars;
    Tcl_UniChar ch;
    unsigned short **toUnicode;
    unsigned short *pageZero;
    TableEncodingData *dataPtr;

    srcStart = src;
    srcEnd = src + srcLen;

    dstStart = dst;
    dstEnd = dst + dstLen - TCL_UTF_MAX;

    dataPtr = (TableEncodingData *) clientData;
    toUnicode = dataPtr->toUnicode;
    prefixBytes = dataPtr->prefixBytes;
    pageZero = toUnicode[0];

    result = TCL_OK;
    for (numChars = 0; src < srcEnd; numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	byte = *((unsigned char *) src);
	if (prefixBytes[byte]) {
	    src++;
	    if (src >= srcEnd) {
		src--;
		result = TCL_CONVERT_MULTIBYTE;
		break;
2342
2343
2344
2345
2346
2347
2348
2349
2350

2351
2352
2353
2354
2355
2356
2357
	 * Special case for 1-byte utf chars for speed.
	 */
	if (ch && ch < 0x80) {
	    *dst++ = (char) ch;
	} else {
	    dst += Tcl_UniCharToUtf(ch, dst);
	}
        src++;
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}

/*







|

>







2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
	 * Special case for 1-byte utf chars for speed.
	 */
	if (ch && ch < 0x80) {
	    *dst++ = (char) ch;
	} else {
	    dst += Tcl_UniCharToUtf(ch, dst);
	}
	src++;
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}

/*
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TableEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    CONST char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd, *prefixBytes;
    Tcl_UniChar ch;
    int result, len, word, numChars;
    TableEncodingData *dataPtr;
    unsigned short **fromUnicode;
    
    result = TCL_OK;    

    dataPtr = (TableEncodingData *) clientData;
    prefixBytes = dataPtr->prefixBytes;
    fromUnicode = dataPtr->fromUnicode;
    
    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }








|







|
|



|
|




















|
|




|







2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TableEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    CONST char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd, *prefixBytes;
    Tcl_UniChar ch;
    int result, len, word, numChars;
    TableEncodingData *dataPtr;
    unsigned short **fromUnicode;

    result = TCL_OK;

    dataPtr = (TableEncodingData *) clientData;
    prefixBytes = dataPtr->prefixBytes;
    fromUnicode = dataPtr->fromUnicode;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }

2433
2434
2435
2436
2437
2438
2439
2440
2441
2442

2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473

2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	len = TclUtfToUniChar(src, &ch);

#if TCL_UTF_MAX > 3
	/*
	 * This prevents a crash condition.  More evaluation is required
	 * for full support of int Tcl_UniChar. [Bug 1004065]
	 */

	if (ch & 0xffff0000) {
	    word = 0;
	} else
#endif
	    word = fromUnicode[(ch >> 8)][ch & 0xff];

	if ((word == 0) && (ch != 0)) {
	    if (flags & TCL_ENCODING_STOPONERROR) {
		result = TCL_CONVERT_UNKNOWN;
		break;
	    }
	    word = dataPtr->fallback; 
	}
	if (prefixBytes[(word >> 8)] != 0) {
	    if (dst + 1 > dstEnd) {
		result = TCL_CONVERT_NOSPACE;
		break;
	    }
	    dst[0] = (char) (word >> 8);
	    dst[1] = (char) word;
	    dst += 2;
	} else {
	    if (dst > dstEnd) {
		result = TCL_CONVERT_NOSPACE;
		break;
	    }
	    dst[0] = (char) word;
	    dst++;
	} 
	src += len;
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TableFreeProc --
 *
 *	This procedure is invoked when an encoding is deleted.  It deletes
 *	the memory used by the TableEncodingData.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory freed.
 *







|
|

>











|
















|


>











|
|







2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	len = TclUtfToUniChar(src, &ch);

#if TCL_UTF_MAX > 3
	/*
	 * This prevents a crash condition.  More evaluation is required for
	 * full support of int Tcl_UniChar. [Bug 1004065]
	 */

	if (ch & 0xffff0000) {
	    word = 0;
	} else
#endif
	    word = fromUnicode[(ch >> 8)][ch & 0xff];

	if ((word == 0) && (ch != 0)) {
	    if (flags & TCL_ENCODING_STOPONERROR) {
		result = TCL_CONVERT_UNKNOWN;
		break;
	    }
	    word = dataPtr->fallback;
	}
	if (prefixBytes[(word >> 8)] != 0) {
	    if (dst + 1 > dstEnd) {
		result = TCL_CONVERT_NOSPACE;
		break;
	    }
	    dst[0] = (char) (word >> 8);
	    dst[1] = (char) word;
	    dst += 2;
	} else {
	    if (dst > dstEnd) {
		result = TCL_CONVERT_NOSPACE;
		break;
	    }
	    dst[0] = (char) word;
	    dst++;
	}
	src += len;
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TableFreeProc --
 *
 *	This procedure is invoked when an encoding is deleted.  It deletes the
 *	memory used by the TableEncodingData.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory freed.
 *
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* EscapeEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */







|







|
|



|
|







2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* EscapeEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608

2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621

2622
2623
2624
2625

2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638

2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657

2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
    if (flags & TCL_ENCODING_START) {
	state = 0;
    }

    for (numChars = 0; src < srcEnd; ) {
	int byte, hi, lo, ch;

        if (dst > dstEnd) {
            result = TCL_CONVERT_NOSPACE;
            break;
        }
	byte = *((unsigned char *) src);
	if (prefixBytes[byte]) {
	    unsigned int left, len, longest;
	    int checked, i;
	    EscapeSubTable *subTablePtr;
	    
	    /*
	     * Saw the beginning of an escape sequence. 
	     */
	     
	    left = srcEnd - src;
	    len = dataPtr->initLen;
	    longest = len;
	    checked = 0;

	    if (len <= left) {
		checked++;
		if ((len > 0) && 
			(memcmp(src, dataPtr->init, len) == 0)) {
		    /*
		     * If we see initialization string, skip it, even if we're
		     * not at the beginning of the buffer. 
		     */
		     
		    src += len;
		    continue;
		}
	    }

	    len = dataPtr->finalLen;
	    if (len > longest) {
		longest = len;
	    }

	    if (len <= left) {
		checked++;
		if ((len > 0) && 
			(memcmp(src, dataPtr->final, len) == 0)) {
		    /*
		     * If we see finalization string, skip it, even if we're
		     * not at the end of the buffer. 
		     */
		     
		    src += len;
		    continue;
		}
	    }

	    subTablePtr = dataPtr->subTables;
	    for (i = 0; i < dataPtr->numSubTables; i++) {
		len = subTablePtr->sequenceLen;
		if (len > longest) {
		    longest = len;
		}
		if (len <= left) {
		    checked++;
		    if ((len > 0) && 
			    (memcmp(src, subTablePtr->sequence, len) == 0)) {
			state = i;
			encodingPtr = NULL;
			subTablePtr = NULL;
			src += len;
			break;
		    }
		}
		subTablePtr++;
	    }

	    if (subTablePtr == NULL) {
		/*
		 * A match was found, the escape sequence was consumed, and
		 * the state was updated.
		 */

		continue;
	    }

	    /*
	     * We have a split-up or unrecognized escape sequence.  If we
	     * checked all the sequences, then it's a syntax error,
	     * otherwise we need more bytes to determine a match.
	     */

	    if ((checked == dataPtr->numSubTables + 2)
		    || (flags & TCL_ENCODING_END)) {
		if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
		    /*
		     * Skip the unknown escape sequence.







|
|
|
|





|

|

|




>


<
|


|

|




>




>


<
|


|

|




>








|










>











|
|







2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788

2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806

2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
    if (flags & TCL_ENCODING_START) {
	state = 0;
    }

    for (numChars = 0; src < srcEnd; ) {
	int byte, hi, lo, ch;

	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	byte = *((unsigned char *) src);
	if (prefixBytes[byte]) {
	    unsigned int left, len, longest;
	    int checked, i;
	    EscapeSubTable *subTablePtr;

	    /*
	     * Saw the beginning of an escape sequence.
	     */

	    left = srcEnd - src;
	    len = dataPtr->initLen;
	    longest = len;
	    checked = 0;

	    if (len <= left) {
		checked++;

		if ((len > 0) && (memcmp(src, dataPtr->init, len) == 0)) {
		    /*
		     * If we see initialization string, skip it, even if we're
		     * not at the beginning of the buffer.
		     */

		    src += len;
		    continue;
		}
	    }

	    len = dataPtr->finalLen;
	    if (len > longest) {
		longest = len;
	    }

	    if (len <= left) {
		checked++;

		if ((len > 0) && (memcmp(src, dataPtr->final, len) == 0)) {
		    /*
		     * If we see finalization string, skip it, even if we're
		     * not at the end of the buffer.
		     */

		    src += len;
		    continue;
		}
	    }

	    subTablePtr = dataPtr->subTables;
	    for (i = 0; i < dataPtr->numSubTables; i++) {
		len = subTablePtr->sequenceLen;
		if (len > longest) {
		    longest = len;
		}
		if (len <= left) {
		    checked++;
		    if ((len > 0) &&
			    (memcmp(src, subTablePtr->sequence, len) == 0)) {
			state = i;
			encodingPtr = NULL;
			subTablePtr = NULL;
			src += len;
			break;
		    }
		}
		subTablePtr++;
	    }

	    if (subTablePtr == NULL) {
		/*
		 * A match was found, the escape sequence was consumed, and
		 * the state was updated.
		 */

		continue;
	    }

	    /*
	     * We have a split-up or unrecognized escape sequence.  If we
	     * checked all the sequences, then it's a syntax error, otherwise
	     * we need more bytes to determine a match.
	     */

	    if ((checked == dataPtr->numSubTables + 2)
		    || (flags & TCL_ENCODING_END)) {
		if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
		    /*
		     * Skip the unknown escape sequence.
2691
2692
2693
2694
2695
2696
2697

2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710

2711
2712
2713
2714
2715
2716
2717
	    TableEncodingData *tableDataPtr;

	    encodingPtr = GetTableEncoding(dataPtr, state);
	    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
	    tablePrefixBytes = tableDataPtr->prefixBytes;
	    tableToUnicode = tableDataPtr->toUnicode;
	}

	if (tablePrefixBytes[byte]) {
	    src++;
	    if (src >= srcEnd) {
		src--;
		result = TCL_CONVERT_MULTIBYTE;
		break;
	    }
	    hi = byte;
	    lo = *((unsigned char *) src);
	} else {
	    hi = 0;
	    lo = byte;
	}

	ch = tableToUnicode[hi][lo];
	dst += Tcl_UniCharToUtf(ch, dst);
	src++;
	numChars++;
    }

    *statePtr = (Tcl_EncodingState) state;







>













>







2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
	    TableEncodingData *tableDataPtr;

	    encodingPtr = GetTableEncoding(dataPtr, state);
	    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
	    tablePrefixBytes = tableDataPtr->prefixBytes;
	    tableToUnicode = tableDataPtr->toUnicode;
	}

	if (tablePrefixBytes[byte]) {
	    src++;
	    if (src >= srcEnd) {
		src--;
		result = TCL_CONVERT_MULTIBYTE;
		break;
	    }
	    hi = byte;
	    lo = *((unsigned char *) src);
	} else {
	    hi = 0;
	    lo = byte;
	}

	ch = tableToUnicode[hi][lo];
	dst += Tcl_UniCharToUtf(ch, dst);
	src++;
	numChars++;
    }

    *statePtr = (Tcl_EncodingState) state;
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int 
EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* EscapeEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store
				 * state information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string
				 * is stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted.  This
				 * may be less than the original source length
				 * if there was a problem converting some
				 * source characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    EscapeEncodingData *dataPtr;
    Encoding *encodingPtr;
    CONST char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd;
    int state, result, numChars;
    TableEncodingData *tableDataPtr;
    char *tablePrefixBytes;
    unsigned short **tableFromUnicode;
    
    result = TCL_OK;    

    dataPtr = (EscapeEncodingData *) clientData;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {







|







|
|



|
|



|
|
|
|















|
|







2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* EscapeEncodingData that specifies
				 * encoding. */
    CONST char *src;		/* Source string in UTF-8. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion.  Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst;			/* Output buffer in which converted string is
				 * stored. */
    int dstLen;			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr;		/* Filled with the number of bytes from the
				 * source string that were converted. This may
				 * be less than the original source length if
				 * there was a problem converting some source
				 * characters. */
    int *dstWrotePtr;		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr;		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    EscapeEncodingData *dataPtr;
    Encoding *encodingPtr;
    CONST char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd;
    int state, result, numChars;
    TableEncodingData *tableDataPtr;
    char *tablePrefixBytes;
    unsigned short **tableFromUnicode;

    result = TCL_OK;

    dataPtr = (EscapeEncodingData *) clientData;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866

2867
2868
2869
2870
2871
2872
2873
2874
2875

2876
2877
2878
2879
2880
2881
2882
    if (flags & TCL_ENCODING_START) {
	state = 0;
	if (dst + dataPtr->initLen > dstEnd) {
	    *srcReadPtr = 0;
	    *dstWrotePtr = 0;
	    return TCL_CONVERT_NOSPACE;
	}
	memcpy((VOID *) dst, (VOID *) dataPtr->init,
		(size_t) dataPtr->initLen);
	dst += dataPtr->initLen;
    } else {
        state = (int) *statePtr;
    }

    encodingPtr = GetTableEncoding(dataPtr, state);
    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
    tablePrefixBytes = tableDataPtr->prefixBytes;
    tableFromUnicode = tableDataPtr->fromUnicode;

    for (numChars = 0; src < srcEnd; numChars++) {
	unsigned int len;
	int word;
	Tcl_UniChar ch;
	
	if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
	    /*
	     * If there is more string to follow, this will ensure that the
	     * last UTF-8 character in the source buffer hasn't been cut off.
	     */

	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	len = TclUtfToUniChar(src, &ch);
	word = tableFromUnicode[(ch >> 8)][ch & 0xff];

	if ((word == 0) && (ch != 0)) {
	    int oldState;
	    EscapeSubTable *subTablePtr;
	    
	    oldState = state;
	    for (state = 0; state < dataPtr->numSubTables; state++) {
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
	    	word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
		if (word != 0) {
		    break;
		}
	    }

	    if (word == 0) {
		state = oldState;
		if (flags & TCL_ENCODING_STOPONERROR) {
		    result = TCL_CONVERT_UNKNOWN;
		    break;
		}
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
		word = tableDataPtr->fallback;
	    } 
	    
	    tablePrefixBytes = tableDataPtr->prefixBytes;
	    tableFromUnicode = tableDataPtr->fromUnicode;

	    /*
	     * The state variable has the value of oldState when word is 0.
	     * In this case, the escape sequense should not be copied to dst 
	     * because the current character set is not changed.
	     */

	    if (state != oldState) {
		subTablePtr = &dataPtr->subTables[state];
		if ((dst + subTablePtr->sequenceLen) > dstEnd) {
		    /*
		     * If there is no space to write the escape sequence, the
		     * state variable must be changed to the value of oldState
		     * variable because this escape sequence must be written
		     * in the next conversion.
		     */

		    state = oldState;
		    result = TCL_CONVERT_NOSPACE;
		    break;
		}
		memcpy((VOID *) dst, (VOID *) subTablePtr->sequence,
			(size_t) subTablePtr->sequenceLen);
		dst += subTablePtr->sequenceLen;







|
<


|











|















|



















|
|





|


>









>







2980
2981
2982
2983
2984
2985
2986
2987

2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
    if (flags & TCL_ENCODING_START) {
	state = 0;
	if (dst + dataPtr->initLen > dstEnd) {
	    *srcReadPtr = 0;
	    *dstWrotePtr = 0;
	    return TCL_CONVERT_NOSPACE;
	}
	memcpy((VOID *)dst, (VOID *)dataPtr->init, (size_t)dataPtr->initLen);

	dst += dataPtr->initLen;
    } else {
	state = (int) *statePtr;
    }

    encodingPtr = GetTableEncoding(dataPtr, state);
    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
    tablePrefixBytes = tableDataPtr->prefixBytes;
    tableFromUnicode = tableDataPtr->fromUnicode;

    for (numChars = 0; src < srcEnd; numChars++) {
	unsigned int len;
	int word;
	Tcl_UniChar ch;

	if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
	    /*
	     * If there is more string to follow, this will ensure that the
	     * last UTF-8 character in the source buffer hasn't been cut off.
	     */

	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	len = TclUtfToUniChar(src, &ch);
	word = tableFromUnicode[(ch >> 8)][ch & 0xff];

	if ((word == 0) && (ch != 0)) {
	    int oldState;
	    EscapeSubTable *subTablePtr;

	    oldState = state;
	    for (state = 0; state < dataPtr->numSubTables; state++) {
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
	    	word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
		if (word != 0) {
		    break;
		}
	    }

	    if (word == 0) {
		state = oldState;
		if (flags & TCL_ENCODING_STOPONERROR) {
		    result = TCL_CONVERT_UNKNOWN;
		    break;
		}
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
		word = tableDataPtr->fallback;
	    }

	    tablePrefixBytes = tableDataPtr->prefixBytes;
	    tableFromUnicode = tableDataPtr->fromUnicode;

	    /*
	     * The state variable has the value of oldState when word is 0.
	     * In this case, the escape sequense should not be copied to dst
	     * because the current character set is not changed.
	     */

	    if (state != oldState) {
		subTablePtr = &dataPtr->subTables[state];
		if ((dst + subTablePtr->sequenceLen) > dstEnd) {
		    /*
		     * If there is no space to write the escape sequence, the
		     * state variable must be changed to the value of oldState
		     * variable because this escape sequence must be written
		     * in the next conversion.
		     */

		    state = oldState;
		    result = TCL_CONVERT_NOSPACE;
		    break;
		}
		memcpy((VOID *) dst, (VOID *) subTablePtr->sequence,
			(size_t) subTablePtr->sequenceLen);
		dst += subTablePtr->sequenceLen;
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
	} else {
	    if (dst > dstEnd) {
		result = TCL_CONVERT_NOSPACE;
		break;
	    }
	    dst[0] = (char) word;
	    dst++;
	} 
	src += len;
    }

    if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
	unsigned int len = dataPtr->subTables[0].sequenceLen;
	if (dst + dataPtr->finalLen + (state?len:0) > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;







|







3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
	} else {
	    if (dst > dstEnd) {
		result = TCL_CONVERT_NOSPACE;
		break;
	    }
	    dst[0] = (char) word;
	    dst++;
	}
	src += len;
    }

    if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
	unsigned int len = dataPtr->subTables[0].sequenceLen;
	if (dst + dataPtr->finalLen + (state?len:0) > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
}

/*
 *---------------------------------------------------------------------------
 *
 * EscapeFreeProc --
 *
 *	This procedure is invoked when an EscapeEncodingData encoding is 
 *	deleted.  It deletes the memory used by the encoding.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory freed.







|







3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
}

/*
 *---------------------------------------------------------------------------
 *
 * EscapeFreeProc --
 *
 *	This procedure is invoked when an EscapeEncodingData encoding is
 *	deleted.  It deletes the memory used by the encoding.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory freed.
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994

2995
2996
2997
2998
2999
3000
3001
3002

3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
 *	encoding (of type TextEncodingData) that represents the specified
 *	state.
 *
 * Results:
 *	The return value is the encoding.
 *
 * Side effects:
 *	If the encoding that represents the specified state has not
 *	already been used by this EscapeEncoding, it will be loaded
 *	and cached in the dataPtr.
 *
 *---------------------------------------------------------------------------
 */

static Encoding *
GetTableEncoding(dataPtr, state)
    EscapeEncodingData *dataPtr;/* Contains names of encodings. */
    int state;			/* Index in dataPtr of desired Encoding. */
{
    EscapeSubTable *subTablePtr;
    Encoding *encodingPtr;
    
    subTablePtr = &dataPtr->subTables[state];
    encodingPtr = subTablePtr->encodingPtr;

    if (encodingPtr == NULL) {
	encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
	if ((encodingPtr == NULL) 
		|| (encodingPtr->toUtfProc != TableToUtfProc)) {
	    Tcl_Panic("EscapeToUtfProc: invalid sub table");
	}
	subTablePtr->encodingPtr = encodingPtr;
    }

    return encodingPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * unilen --
 *
 *	A helper function for the Tcl_ExternalToUtf functions.  This
 *	function is similar to strlen for double-byte characters: it
 *	returns the number of bytes in a 0x0000 terminated string.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *







|
|
|











|


>


|





>








|
|
|







3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
 *	encoding (of type TextEncodingData) that represents the specified
 *	state.
 *
 * Results:
 *	The return value is the encoding.
 *
 * Side effects:
 *	If the encoding that represents the specified state has not already
 *	been used by this EscapeEncoding, it will be loaded and cached in the
 *	dataPtr.
 *
 *---------------------------------------------------------------------------
 */

static Encoding *
GetTableEncoding(dataPtr, state)
    EscapeEncodingData *dataPtr;/* Contains names of encodings. */
    int state;			/* Index in dataPtr of desired Encoding. */
{
    EscapeSubTable *subTablePtr;
    Encoding *encodingPtr;

    subTablePtr = &dataPtr->subTables[state];
    encodingPtr = subTablePtr->encodingPtr;

    if (encodingPtr == NULL) {
	encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
	if ((encodingPtr == NULL)
		|| (encodingPtr->toUtfProc != TableToUtfProc)) {
	    Tcl_Panic("EscapeToUtfProc: invalid sub table");
	}
	subTablePtr->encodingPtr = encodingPtr;
    }

    return encodingPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * unilen --
 *
 *	A helper function for the Tcl_ExternalToUtf functions.  This function
 *	is similar to strlen for double-byte characters: it returns the number
 *	of bytes in a 0x0000 terminated string.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076

3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088

3089
3090
3091
3092
3093
3094
3095

3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
}

/*
 *-------------------------------------------------------------------------
 *
 * InitializeEncodingSearchPath	--
 *
 *	This is the fallback routine that sets the default value
 *	of the encoding search path if the application has not set
 *	one via a call to TclSetEncodingSearchPath() by the first
 *	time the search path is needed to load encoding data.
 *
 *	The default encoding search path is produced by taking each
 *	directory in the library path, appending a subdirectory
 *	named "encoding", and if the resulting directory exists,
 *	adding it to the encoding search path.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the encoding search path to an initial value.  
 *
 *-------------------------------------------------------------------------
 */

void
InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr; 
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
    char *bytes;
    int i, numDirs, numBytes;
    Tcl_Obj *libPath, *encodingObj = Tcl_NewStringObj("encoding", -1);
    Tcl_Obj *searchPath = Tcl_NewObj();

    Tcl_IncrRefCount(encodingObj);
    Tcl_IncrRefCount(searchPath);
    libPath = TclGetLibraryPath();
    Tcl_IncrRefCount(libPath);
    Tcl_ListObjLength(NULL, libPath, &numDirs);

    for (i = 0; i < numDirs; i++) {
	Tcl_Obj *directory, *path;
	Tcl_StatBuf stat;

	Tcl_ListObjIndex(NULL, libPath, i, &directory);
       	path = Tcl_FSJoinToPath(directory, 1, &encodingObj);
	Tcl_IncrRefCount(path);
	if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) {
	    Tcl_ListObjAppendElement(NULL, searchPath, path);
	}
	Tcl_IncrRefCount(path);
    }

    Tcl_DecrRefCount(libPath);
    Tcl_DecrRefCount(encodingObj);
    *encodingPtr = libraryPath.encoding;
    if (*encodingPtr) {
	((Encoding *)(*encodingPtr))->refCount++;
    }
    bytes = Tcl_GetStringFromObj(searchPath, &numBytes);

    *lengthPtr = numBytes;
    *valuePtr = ckalloc((unsigned int) numBytes + 1);
    memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
    Tcl_DecrRefCount(searchPath);
}

/*
 *-------------------------------------------------------------------------
 *
 * InitializeEncodingFileMap --
 *
 *	This is the fallback routine that fills the encoding data
 *	file map if the application has not set up an encoding
 *	search path by the first time the file map is needed to
 *	load encoding data.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Fills the encoding data file map.
 *
 *-------------------------------------------------------------------------
 */
	     
void
InitializeEncodingFileMap(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr; 
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
    char *bytes;
    int numBytes;
    Tcl_Obj *map = MakeFileMap();

    *encodingPtr = encodingSearchPath.encoding;
    if (*encodingPtr) {
	((Encoding *)(*encodingPtr))->refCount++;
    }
    bytes = Tcl_GetStringFromObj(map, &numBytes);
    *lengthPtr = numBytes;
    *valuePtr = ckalloc((unsigned int) numBytes + 1);
    memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
    Tcl_DecrRefCount(map);
}







|
|
|
|

|
|
<
|





|




|

|













>





|




|

>







>







<
|
<
<
<
<
<
<
<
|
<
<
|
|
|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233

3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289

3290







3291


3292
3293
3294

3295





















}

/*
 *-------------------------------------------------------------------------
 *
 * InitializeEncodingSearchPath	--
 *
 *	This is the fallback routine that sets the default value of the
 *	encoding search path if the application has not set one via a call to
 *	TclSetEncodingSearchPath() by the first time the search path is needed
 *	to load encoding data.
 *
 *	The default encoding search path is produced by taking each directory
 *	in the library path, appending a subdirectory named "encoding", and if

 *	the resulting directory exists, adding it to the encoding search path.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the encoding search path to an initial value.
 *
 *-------------------------------------------------------------------------
 */

static void
InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
    char *bytes;
    int i, numDirs, numBytes;
    Tcl_Obj *libPath, *encodingObj = Tcl_NewStringObj("encoding", -1);
    Tcl_Obj *searchPath = Tcl_NewObj();

    Tcl_IncrRefCount(encodingObj);
    Tcl_IncrRefCount(searchPath);
    libPath = TclGetLibraryPath();
    Tcl_IncrRefCount(libPath);
    Tcl_ListObjLength(NULL, libPath, &numDirs);

    for (i = 0; i < numDirs; i++) {
	Tcl_Obj *directory, *path;
	Tcl_StatBuf stat;

	Tcl_ListObjIndex(NULL, libPath, i, &directory);
	path = Tcl_FSJoinToPath(directory, 1, &encodingObj);
	Tcl_IncrRefCount(path);
	if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) {
	    Tcl_ListObjAppendElement(NULL, searchPath, path);
	}
	Tcl_DecrRefCount(path);
    }

    Tcl_DecrRefCount(libPath);
    Tcl_DecrRefCount(encodingObj);
    *encodingPtr = libraryPath.encoding;
    if (*encodingPtr) {
	((Encoding *)(*encodingPtr))->refCount++;
    }
    bytes = Tcl_GetStringFromObj(searchPath, &numBytes);

    *lengthPtr = numBytes;
    *valuePtr = ckalloc((unsigned int) numBytes + 1);
    memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
    Tcl_DecrRefCount(searchPath);
}

/*

 * Local Variables:







 * mode: c


 * c-basic-offset: 4
 * fill-column: 78
 * End:

 */





















Changes to generic/tclEnv.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27





28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
/* 
 * tclEnv.c --
 *
 *	Tcl support for environment variables, including a setenv
 *	procedure.  This file contains the generic portion of the
 *	environment module.  It is primarily responsible for keeping
 *	the "env" arrays in sync with the system environment variables.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.22 2004/04/06 22:25:50 dgp Exp $
 */

#include "tclInt.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */

static int cacheSize = 0;	/* Number of env strings in environCache. */
static char **environCache = NULL;
				/* Array containing all of the environment
				 * strings that Tcl has allocated. */

#ifndef USE_PUTENV





static int environSize = 0;	/* Non-zero means that the environ array was
				 * malloced and has this many total entries
				 * allocated to it (not all may be in use at
				 * once).  Zero means that the environment
				 * array is in its original static state. */
#endif

/*
 * For MacOS X
 */
#if defined(__APPLE__) && defined(__DYNAMIC__)
#include <crt_externs.h>
char **environ = NULL;
#endif

/*
 * Declarations for local procedures defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
			    CONST char *name2, int flags));
static void		ReplaceString _ANSI_ARGS_((CONST char *oldStr,
			    char *newStr));
void			TclSetEnv _ANSI_ARGS_((CONST char *name,
			    CONST char *value));
void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));

#if defined (__CYGWIN__) && defined(__WIN32__)
static void		TclCygwinPutenv _ANSI_ARGS_((CONST char *string));
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclSetupEnv --
 *
 *	This procedure is invoked for an interpreter to make environment
 *	variables accessible from that interpreter via the "env"
 *	associative array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter is added to a list of interpreters managed
 *	by us, so that its view of envariables can be kept consistent
 *	with the view in other interpreters.  If this is the first
 *	call to TclSetupEnv, then additional initialization happens,
 *	such as copying the environment to dynamically-allocated space
 *	for ease of management.
 *
 *----------------------------------------------------------------------
 */

void
TclSetupEnv(interp)
    Tcl_Interp *interp;		/* Interpreter whose "env" array is to be
|


|
|
|
|




|
|

|












>
>
>
>
>
















|



|
















|
|
|





|
|
|
|
<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
/*
 * tclEnv.c --
 *
 *	Tcl support for environment variables, including a setenv function.
 *	This file contains the generic portion of the environment module. It
 *	is primarily responsible for keeping the "env" arrays in sync with the
 *	system environment variables.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.22.2.3 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */

static int cacheSize = 0;	/* Number of env strings in environCache. */
static char **environCache = NULL;
				/* Array containing all of the environment
				 * strings that Tcl has allocated. */

#ifndef USE_PUTENV
static char **ourEnviron = NULL;/* Cache of the array that we allocate.
				 * We need to track this in case another
				 * subsystem swaps around the environ array
				 * like we do.
				 */
static int environSize = 0;	/* Non-zero means that the environ array was
				 * malloced and has this many total entries
				 * allocated to it (not all may be in use at
				 * once).  Zero means that the environment
				 * array is in its original static state. */
#endif

/*
 * For MacOS X
 */
#if defined(__APPLE__) && defined(__DYNAMIC__)
#include <crt_externs.h>
char **environ = NULL;
#endif

/*
 * Declarations for local functions defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1,
			    CONST char *name2, int flags));
static void		ReplaceString _ANSI_ARGS_((CONST char *oldStr,
			    char *newStr));
void			TclSetEnv _ANSI_ARGS_((CONST char *name,
			    CONST char *value));
void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));

#if defined (__CYGWIN__) && defined(__WIN32__)
static void		TclCygwinPutenv _ANSI_ARGS_((CONST char *string));
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclSetupEnv --
 *
 *	This function is invoked for an interpreter to make environment
 *	variables accessible from that interpreter via the "env" associative
 *	array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter is added to a list of interpreters managed by us, so
 *	that its view of envariables can be kept consistent with the view in
 *	other interpreters.  If this is the first call to TclSetupEnv, then
 *	additional initialization happens, such as copying the environment to

 *	dynamically-allocated space for ease of management.
 *
 *----------------------------------------------------------------------
 */

void
TclSetupEnv(interp)
    Tcl_Interp *interp;		/* Interpreter whose "env" array is to be
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192





193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281

282


283
284
285
286
287
288
289
290
291
292
293
294

295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410





411
412
413
414





415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432

433


434
435
436
437
438
439
440
     * For MacOS X
     */
#if defined(__APPLE__) && defined(__DYNAMIC__)
    environ = *_NSGetEnviron();
#endif

    /*
     * Synchronize the values in the environ array with the contents
     * of the Tcl "env" variable.  To do this:
     *    1) Remove the trace that fires when the "env" var is unset.
     *    2) Unset the "env" variable.
     *    3) If there are no environ variables, create an empty "env"
     *       array.  Otherwise populate the array with current values.
     *    4) Add a trace that synchronizes the "env" array.
     */
    
    Tcl_UntraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
    
    Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); 
    
    if (environ[0] == NULL) {
	Tcl_Obj *varNamePtr;
	
	varNamePtr = Tcl_NewStringObj("env", -1);
	Tcl_IncrRefCount(varNamePtr);
	TclArraySet(interp, varNamePtr, NULL);	
	Tcl_DecrRefCount(varNamePtr);
    } else {
	Tcl_MutexLock(&envMutex);
	for (i = 0; environ[i] != NULL; i++) {
	    p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
	    p2 = strchr(p1, '=');
	    if (p2 == NULL) {
		/*
		 * This condition seem to happen occasionally under some
		 * versions of Solaris; ignore the entry.
		 */
		
		continue;
	    }
	    p2++;
	    p2[-1] = '\0';
	    Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);	
	    Tcl_DStringFree(&envString);
	}
	Tcl_MutexUnlock(&envMutex);
    }

    Tcl_TraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetEnv --
 *
 *	Set an environment variable, replacing an existing value
 *	or creating a new variable if there doesn't exist a variable
 *	by the given name.  This procedure is intended to be a
 *	stand-in for the  UNIX "setenv" procedure so that applications
 *	using that procedure will interface properly to Tcl.  To make
 *	it a stand-in, the Makefile must define "TclSetEnv" to "setenv".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The environ array gets updated.
 *
 *----------------------------------------------------------------------
 */

void
TclSetEnv(name, value)
    CONST char *name;		/* Name of variable whose value is to be
				 * set (UTF-8). */
    CONST char *value;		/* New value for variable (UTF-8). */
{
    Tcl_DString envString;
    int index, length, nameLength;
    char *p, *oldValue;
    CONST char *p2;

    /*
     * Figure out where the entry is going to go.  If the name doesn't
     * already exist, enlarge the array if necessary to make room.  If the
     * name exists, free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    if (index == -1) {
#ifndef USE_PUTENV





	if ((length + 2) > environSize) {
	    char **newEnviron;

	    newEnviron = (char **) ckalloc((unsigned)
		    ((length + 5) * sizeof(char *)));
	    memcpy((VOID *) newEnviron, (VOID *) environ,
		    length*sizeof(char *));
	    if (environSize != 0) {
		ckfree((char *) environ);
	    }
	    environ = newEnviron;
	    environSize = length + 5;
#if defined(__APPLE__) && defined(__DYNAMIC__)
	    {
	    char ***e = _NSGetEnviron();
	    *e = environ;
	    }
#endif
	}
	index = length;
	environ[index + 1] = NULL;
#endif
	oldValue = NULL;
	nameLength = strlen(name);
    } else {
	CONST char *env;

	/*
	 * Compare the new value to the existing value.  If they're
	 * the same then quit immediately (e.g. don't rewrite the
	 * value or propagate it to other interpreters).  Otherwise,
	 * when there are N interpreters there will be N! propagations
	 * of the same value among the interpreters.
	 */

	env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
	if (strcmp(value, (env + length + 1)) == 0) {
	    Tcl_DStringFree(&envString);
	    Tcl_MutexUnlock(&envMutex);
	    return;
	}
	Tcl_DStringFree(&envString);

	oldValue = environ[index];
	nameLength = length;
    }
	

    /*
     * Create a new entry.  Build a complete UTF string that contains
     * a "name=value" pattern.  Then convert the string to the native
     * encoding, and set the environ array value.
     */

    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
    strcpy(p, name);
    p[nameLength] = '=';
    strcpy(p+nameLength+1, value);
    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);

    /*
     * Copy the native string to heap memory.
     */
    
    p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1));
    strcpy(p, p2);
    Tcl_DStringFree(&envString);

#ifdef USE_PUTENV
    /*
     * Update the system environment.
     */

    putenv(p);
    index = TclpFindVariable(name, &length);
#else
    environ[index] = p;
#endif

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if ((index != -1) && (environ[index] == p)) {
	ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
    } else {

	/* This putenv() copies instead of taking ownership */


	ckfree(p);
#endif
    }

    Tcl_MutexUnlock(&envMutex);
    
    if (!strcmp(name, "HOME")) {
	/* 
	 * If the user's home directory has changed, we must invalidate
	 * the filesystem cache, because '~' expansions will now be
	 * incorrect.
	 */

        Tcl_FSMountsChanged(NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutEnv --
 *
 *	Set an environment variable.  Similar to setenv except that
 *	the information is passed in a single string of the form
 *	NAME=value, rather than as separate name strings.  This procedure
 *	is intended to be a stand-in for the  UNIX "putenv" procedure
 *	so that applications using that procedure will interface
 *	properly to Tcl.  To make it a stand-in, the Makefile will
 *	define "Tcl_PutEnv" to "putenv".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The environ array gets updated, as do all of the interpreters
 *	that we manage.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PutEnv(string)
    CONST char *string;		/* Info about environment variable in the
				 * form NAME=value. (native) */
{
    Tcl_DString nameString;   
    CONST char *name;
    char *value;

    if (string == NULL) {
	return 0;
    }

    /*
     * First convert the native string to UTF.  Then separate the
     * string into name and value parts, and call TclSetEnv to do
     * all of the real work.
     */

    name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
    value = strchr(name, '=');

    if ((value != NULL) && (value != name)) {
	value[0] = '\0';
	TclSetEnv(name, value+1);
    }

    Tcl_DStringFree(&nameString);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnsetEnv --
 *
 *	Remove an environment variable, updating the "env" arrays
 *	in all interpreters managed by us.  This function is intended
 *	to replace the UNIX "unsetenv" function (but to do this the
 *	Makefile must be modified to redefine "TclUnsetEnv" to
 *	"unsetenv".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Interpreters are updated, as is environ.
 *
 *----------------------------------------------------------------------
 */

void
TclUnsetEnv(name)
    CONST char *name;		/* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    int length;
    int index;
#ifdef USE_PUTENV
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid
     * doing needless work and to avoid recursion on the unset.
     */
    
    if (index == -1) {
	Tcl_MutexUnlock(&envMutex);
	return;
    }
    /*
     * Remember the old value so we can free it if Tcl created the string.
     */

    oldValue = environ[index];

    /*
     * Update the system environment.  This must be done before we 
     * update the interpreters or we will recurse.
     */

#ifdef USE_PUTENV





    string = ckalloc((unsigned int) length+2);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';





    
    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
    strcpy(string, Tcl_DStringValue(&envString));
    Tcl_DStringFree(&envString);

    putenv(string);

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if (environ[index] == string) {
	ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
    } else {

	/* This putenv() copies instead of taking ownership */


	ckfree(string);
#endif
    }
#else
    for (envPtr = environ+index+1; ; envPtr++) {
	envPtr[-1] = *envPtr;
	if (*envPtr == NULL) {







|
|


|
|


|




|
|
|


|


|











|




|
















|
|
|
|
|
|












|
|








|
|
|







>
>
>
>
>
|






|
|

|



|
|

|



|






|
|
|
|
|













|
<

|
|
|











|
















|
|
|






>
|
>
>





|

|
|
|
<

>
|








|
|
|
|
<
|
|





|
|





|
|
|

|



|




|
|
<


|
















|
|
|
|
<

















|










|
|

|











|
|


|
>
>
>
>
>




>
>
>
>
>
|








|
|
|






>
|
>
>







97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

304
305
306
307
308
309
310
311
312
313
314
315
316
317
318

319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347

348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370

371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
     * For MacOS X
     */
#if defined(__APPLE__) && defined(__DYNAMIC__)
    environ = *_NSGetEnviron();
#endif

    /*
     * Synchronize the values in the environ array with the contents of the
     * Tcl "env" variable.  To do this:
     *    1) Remove the trace that fires when the "env" var is unset.
     *    2) Unset the "env" variable.
     *    3) If there are no environ variables, create an empty "env" array.
     *	     Otherwise populate the array with current values.
     *    4) Add a trace that synchronizes the "env" array.
     */

    Tcl_UntraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);

    Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);

    if (environ[0] == NULL) {
	Tcl_Obj *varNamePtr;

	varNamePtr = Tcl_NewStringObj("env", -1);
	Tcl_IncrRefCount(varNamePtr);
	TclArraySet(interp, varNamePtr, NULL);
	Tcl_DecrRefCount(varNamePtr);
    } else {
	Tcl_MutexLock(&envMutex);
	for (i = 0; environ[i] != NULL; i++) {
	    p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
	    p2 = strchr(p1, '=');
	    if (p2 == NULL) {
		/*
		 * This condition seem to happen occasionally under some
		 * versions of Solaris; ignore the entry.
		 */

		continue;
	    }
	    p2++;
	    p2[-1] = '\0';
	    Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
	    Tcl_DStringFree(&envString);
	}
	Tcl_MutexUnlock(&envMutex);
    }

    Tcl_TraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetEnv --
 *
 *	Set an environment variable, replacing an existing value or creating a
 *	new variable if there doesn't exist a variable by the given name.
 *	This function is intended to be a stand-in for the UNIX "setenv"
 *	function so that applications using that function will interface
 *	properly to Tcl. To make it a stand-in, the Makefile must define
 *	"TclSetEnv" to "setenv".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The environ array gets updated.
 *
 *----------------------------------------------------------------------
 */

void
TclSetEnv(name, value)
    CONST char *name;		/* Name of variable whose value is to be set
				 * (UTF-8). */
    CONST char *value;		/* New value for variable (UTF-8). */
{
    Tcl_DString envString;
    int index, length, nameLength;
    char *p, *oldValue;
    CONST char *p2;

    /*
     * Figure out where the entry is going to go. If the name doesn't already
     * exist, enlarge the array if necessary to make room. If the name exists,
     * free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    if (index == -1) {
#ifndef USE_PUTENV
	/*
	 * We need to handle the case where the environment may be changed
	 * outside our control.  environSize is only valid if the current
	 * environment is the one we allocated. [Bug 979640]
	 */
	if ((ourEnviron != environ) || ((length + 2) > environSize)) {
	    char **newEnviron;

	    newEnviron = (char **) ckalloc((unsigned)
		    ((length + 5) * sizeof(char *)));
	    memcpy((VOID *) newEnviron, (VOID *) environ,
		    length*sizeof(char *));
	    if ((environSize != 0) && (ourEnviron != NULL)) {
		ckfree((char *) ourEnviron);
	    }
	    environ = ourEnviron = newEnviron;
	    environSize = length + 5;
#if defined(__APPLE__) && defined(__DYNAMIC__)
	    {
		char ***e = _NSGetEnviron();
		*e = environ;
	    }
#endif /* __APPLE__ && __DYNAMIC__ */
	}
	index = length;
	environ[index + 1] = NULL;
#endif /* USE_PUTENV */
	oldValue = NULL;
	nameLength = strlen(name);
    } else {
	CONST char *env;

	/*
	 * Compare the new value to the existing value. If they're the same
	 * then quit immediately (e.g. don't rewrite the value or propagate it
	 * to other interpreters). Otherwise, when there are N interpreters
	 * there will be N! propagations of the same value among the
	 * interpreters.
	 */

	env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
	if (strcmp(value, (env + length + 1)) == 0) {
	    Tcl_DStringFree(&envString);
	    Tcl_MutexUnlock(&envMutex);
	    return;
	}
	Tcl_DStringFree(&envString);

	oldValue = environ[index];
	nameLength = length;
    }


    /*
     * Create a new entry. Build a complete UTF string that contains a
     * "name=value" pattern. Then convert the string to the native encoding,
     * and set the environ array value.
     */

    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
    strcpy(p, name);
    p[nameLength] = '=';
    strcpy(p+nameLength+1, value);
    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);

    /*
     * Copy the native string to heap memory.
     */

    p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1));
    strcpy(p, p2);
    Tcl_DStringFree(&envString);

#ifdef USE_PUTENV
    /*
     * Update the system environment.
     */

    putenv(p);
    index = TclpFindVariable(name, &length);
#else
    environ[index] = p;
#endif

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++). In
     * this case we need to free the string immediately. Otherwise update the
     * string in the cache.
     */

    if ((index != -1) && (environ[index] == p)) {
	ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
    } else {
	/*
	 * This putenv() copies instead of taking ownership.
	 */

	ckfree(p);
#endif
    }

    Tcl_MutexUnlock(&envMutex);

    if (!strcmp(name, "HOME")) {
	/*
	 * If the user's home directory has changed, we must invalidate the
	 * filesystem cache, because '~' expansions will now be incorrect.

	 */

	Tcl_FSMountsChanged(NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutEnv --
 *
 *	Set an environment variable. Similar to setenv except that the
 *	information is passed in a single string of the form NAME=value,
 *	rather than as separate name strings. This function is intended to be
 *	a stand-in for the UNIX "putenv" function so that applications using

 *	that function will interface properly to Tcl. To make it a stand-in,
 *	the Makefile will define "Tcl_PutEnv" to "putenv".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The environ array gets updated, as do all of the interpreters that we
 *	manage.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PutEnv(assignment)
    CONST char *assignment;	/* Info about environment variable in the form
				 * NAME=value. (native) */
{
    Tcl_DString nameString;
    CONST char *name;
    char *value;

    if (assignment == NULL) {
	return 0;
    }

    /*
     * First convert the native string to UTF. Then separate the string into
     * name and value parts, and call TclSetEnv to do all of the real work.

     */

    name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
    value = strchr(name, '=');

    if ((value != NULL) && (value != name)) {
	value[0] = '\0';
	TclSetEnv(name, value+1);
    }

    Tcl_DStringFree(&nameString);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnsetEnv --
 *
 *	Remove an environment variable, updating the "env" arrays in all
 *	interpreters managed by us. This function is intended to replace the
 *	UNIX "unsetenv" function (but to do this the Makefile must be modified
 *	to redefine "TclUnsetEnv" to "unsetenv".

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Interpreters are updated, as is environ.
 *
 *----------------------------------------------------------------------
 */

void
TclUnsetEnv(name)
    CONST char *name;		/* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    int length;
    int index;
#ifdef USE_PUTENV_FOR_UNSET
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid doing
     * needless work and to avoid recursion on the unset.
     */

    if (index == -1) {
	Tcl_MutexUnlock(&envMutex);
	return;
    }
    /*
     * Remember the old value so we can free it if Tcl created the string.
     */

    oldValue = environ[index];

    /*
     * Update the system environment.  This must be done before we update the
     * interpreters or we will recurse.
     */

#ifdef USE_PUTENV_FOR_UNSET
    /*
     * For those platforms that support putenv to unset, Linux indicates
     * that no = should be included, and Windows requires it.
     */
#ifdef WIN32
    string = ckalloc((unsigned int) length+2);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';
#else
    string = ckalloc((unsigned int) length+1);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '\0';
#endif

    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
    strcpy(string, Tcl_DStringValue(&envString));
    Tcl_DStringFree(&envString);

    putenv(string);

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++). In
     * this case we need to free the string immediately. Otherwise update the
     * string in the cache.
     */

    if (environ[index] == string) {
	ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
    } else {
	/*
	 * This putenv() copies instead of taking ownership.
	 */

	ckfree(string);
#endif
    }
#else
    for (envPtr = environ+index+1; ; envPtr++) {
	envPtr[-1] = *envPtr;
	if (*envPtr == NULL) {
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
 *
 * TclGetEnv --
 *
 *	Retrieve the value of an environment variable.
 *
 * Results:
 *	The result is a pointer to a string specifying the value of the
 *	environment variable, or NULL if that environment variable does
 *	not exist.  Storage for the result string is allocated in valuePtr;
 *	the caller must call Tcl_DStringFree() when the result is no
 *	longer needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclGetEnv(name, valuePtr)
    CONST char *name;		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr;	/* Uninitialized or free DString in which
				 * the value of the environment variable is
				 * stored. */
{
    int length, index;
    CONST char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);
    result = NULL;
    if (index != -1) {
	Tcl_DString envStr;
	
	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, -1);
	    result = Tcl_DStringValue(valuePtr);







|
|
|
|











|
|










|







473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
 *
 * TclGetEnv --
 *
 *	Retrieve the value of an environment variable.
 *
 * Results:
 *	The result is a pointer to a string specifying the value of the
 *	environment variable, or NULL if that environment variable does not
 *	exist. Storage for the result string is allocated in valuePtr; the
 *	caller must call Tcl_DStringFree() when the result is no longer
 *	needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclGetEnv(name, valuePtr)
    CONST char *name;		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr;	/* Uninitialized or free DString in which the
				 * value of the environment variable is
				 * stored. */
{
    int length, index;
    CONST char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);
    result = NULL;
    if (index != -1) {
	Tcl_DString envStr;

	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, -1);
	    result = Tcl_DStringValue(valuePtr);
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
}

/*
 *----------------------------------------------------------------------
 *
 * EnvTraceProc --
 *
 *	This procedure is invoked whenever an environment variable
 *	is read, modified or deleted.  It propagates the change to the global
 *	"environ" array.
 *
 * Results:
 *	Always returns NULL to indicate success.
 *
 * Side effects:
 *	Environment variable changes get propagated.  If the whole
 *	"env" array is deleted, then we stop managing things for
 *	this interpreter (usually this happens because the whole
 *	interpreter is being deleted).
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
				 * being modified. */
    CONST char *name1;		/* Better be "env". */
    CONST char *name2;		/* Name of variable being modified, or NULL
				 * if whole array is being deleted (UTF-8). */
    int flags;			/* Indicates what's happening. */
{
    /*
     * For array traces, let TclSetupEnv do all the work.
     */

    if (flags & TCL_TRACE_ARRAY) {
	TclSetupEnv(interp);
	return NULL;
    }

    /*
     * If name2 is NULL, then return and do nothing.
     */
     
    if (name2 == NULL) {
	return NULL;
    }

    /*
     * If a value is being set, call TclSetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_WRITES) {
	CONST char *value;
	
	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
	TclSetEnv(name2, value);
    }

    /*
     * If a value is being read, call TclGetEnv to do all of the work.
     */







|
|
|





|
|
<
|








|
|

|
|














|










|







522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538

539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
}

/*
 *----------------------------------------------------------------------
 *
 * EnvTraceProc --
 *
 *	This function is invoked whenever an environment variable is read,
 *	modified or deleted. It propagates the change to the global "environ"
 *	array.
 *
 * Results:
 *	Always returns NULL to indicate success.
 *
 * Side effects:
 *	Environment variable changes get propagated. If the whole "env" array
 *	is deleted, then we stop managing things for this interpreter (usually

 *	this happens because the whole interpreter is being deleted).
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter whose "env" variable is being
				 * modified. */
    CONST char *name1;		/* Better be "env". */
    CONST char *name2;		/* Name of variable being modified, or NULL if
				 * whole array is being deleted (UTF-8). */
    int flags;			/* Indicates what's happening. */
{
    /*
     * For array traces, let TclSetupEnv do all the work.
     */

    if (flags & TCL_TRACE_ARRAY) {
	TclSetupEnv(interp);
	return NULL;
    }

    /*
     * If name2 is NULL, then return and do nothing.
     */

    if (name2 == NULL) {
	return NULL;
    }

    /*
     * If a value is being set, call TclSetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_WRITES) {
	CONST char *value;

	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
	TclSetEnv(name2, value);
    }

    /*
     * If a value is being read, call TclGetEnv to do all of the work.
     */
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
}

/*
 *----------------------------------------------------------------------
 *
 * ReplaceString --
 *
 *	Replace one string with another in the environment variable
 *	cache.  The cache keeps track of all of the environment
 *	variables that Tcl has modified so they can be freed later.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May free the old string.
 *
 *----------------------------------------------------------------------
 */

static void
ReplaceString(oldStr, newStr)
    CONST char *oldStr;		/* Old environment string. */
    char *newStr;		/* New environment string. */
{
    int i;
    char **newCache;

    /*
     * Check to see if the old value was allocated by Tcl.  If so,
     * it needs to be deallocated to avoid memory leaks.  Note that this
     * algorithm is O(n), not O(1).  This will result in n-squared behavior
     * if lots of environment changes are being made.
     */

    for (i = 0; i < cacheSize; i++) {
	if ((environCache[i] == oldStr) || (environCache[i] == NULL)) {
	    break;
	}
    }
    if (i < cacheSize) {
	/*
	 * Replace or delete the old value.
	 */

	if (environCache[i]) {
	    ckfree(environCache[i]);
	}
	    
	if (newStr) {
	    environCache[i] = newStr;
	} else {
	    for (; i < cacheSize-1; i++) {
		environCache[i] = environCache[i+1];
	    }
	    environCache[cacheSize-1] = NULL;
	}
    } else {	
        int allocatedSize = (cacheSize + 5) * sizeof(char *);

	/*
	 * We need to grow the cache in order to hold the new string.
	 */

	newCache = (char **) ckalloc((unsigned) allocatedSize);
        (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
        
	if (environCache) {
	    memcpy((VOID *) newCache, (VOID *) environCache,
		    (size_t) (cacheSize * sizeof(char*)));
	    ckfree((char *) environCache);
	}
	environCache = newCache;
	environCache[cacheSize] = newStr;
	environCache[cacheSize+1] = NULL;
	cacheSize += 5;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEnvironment --
 *
 *	This function releases any storage allocated by this module
 *	that isn't still in use by the global environment.  Any
 *	strings that are still in the environment will be leaked.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May deallocate storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeEnvironment()
{
    /*
     * For now we just deallocate the cache array and none of the environment
     * strings.  This may leak more memory that strictly necessary, since some
     * of the strings may no longer be in the environment.  However,
     * determining which ones are ok to delete is n-squared, and is pretty
     * unlikely, so we don't bother.
     */

    if (environCache) {
	ckfree((char *) environCache);
	environCache = NULL;
	cacheSize    = 0;
#ifndef USE_PUTENV
	environSize  = 0;
#endif
    }
}

#if defined(__CYGWIN__) && defined(__WIN32__)

#include <windows.h>







|
|
|



















|
|
|
|















|








|
|






|
|

















|
|
|















|
|







|

|







607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
}

/*
 *----------------------------------------------------------------------
 *
 * ReplaceString --
 *
 *	Replace one string with another in the environment variable cache.
 *	The cache keeps track of all of the environment variables that Tcl has
 *	modified so they can be freed later.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May free the old string.
 *
 *----------------------------------------------------------------------
 */

static void
ReplaceString(oldStr, newStr)
    CONST char *oldStr;		/* Old environment string. */
    char *newStr;		/* New environment string. */
{
    int i;
    char **newCache;

    /*
     * Check to see if the old value was allocated by Tcl. If so, it needs to
     * be deallocated to avoid memory leaks. Note that this algorithm is O(n),
     * not O(1). This will result in n-squared behavior if lots of environment
     * changes are being made.
     */

    for (i = 0; i < cacheSize; i++) {
	if ((environCache[i] == oldStr) || (environCache[i] == NULL)) {
	    break;
	}
    }
    if (i < cacheSize) {
	/*
	 * Replace or delete the old value.
	 */

	if (environCache[i]) {
	    ckfree(environCache[i]);
	}

	if (newStr) {
	    environCache[i] = newStr;
	} else {
	    for (; i < cacheSize-1; i++) {
		environCache[i] = environCache[i+1];
	    }
	    environCache[cacheSize-1] = NULL;
	}
    } else {
	int allocatedSize = (cacheSize + 5) * sizeof(char *);

	/*
	 * We need to grow the cache in order to hold the new string.
	 */

	newCache = (char **) ckalloc((unsigned) allocatedSize);
	(VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);

	if (environCache) {
	    memcpy((VOID *) newCache, (VOID *) environCache,
		    (size_t) (cacheSize * sizeof(char*)));
	    ckfree((char *) environCache);
	}
	environCache = newCache;
	environCache[cacheSize] = newStr;
	environCache[cacheSize+1] = NULL;
	cacheSize += 5;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEnvironment --
 *
 *	This function releases any storage allocated by this module that isn't
 *	still in use by the global environment. Any strings that are still in
 *	the environment will be leaked.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May deallocate storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeEnvironment()
{
    /*
     * For now we just deallocate the cache array and none of the environment
     * strings. This may leak more memory that strictly necessary, since some
     * of the strings may no longer be in the environment. However,
     * determining which ones are ok to delete is n-squared, and is pretty
     * unlikely, so we don't bother.
     */

    if (environCache) {
	ckfree((char *) environCache);
	environCache = NULL;
	cacheSize = 0;
#ifndef USE_PUTENV
	environSize = 0;
#endif
    }
}

#if defined(__CYGWIN__) && defined(__WIN32__)

#include <windows.h>
715
716
717
718
719
720
721

722
723


724
725
726
727


728
729
730
731
732
733
734
735
736
737

738


739
740
741
742
743
744
745
746
747
748
749
750
751
752
753

754

755
756


757
758
759
760
761
762
763
764
765

766


767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784









static void
TclCygwinPutenv(str)
    const char *str;
{
    char *name, *value;


    /* Get the name and value, so that we can change the environment
       variable for Windows.  */


    name = (char *) alloca (strlen (str) + 1);
    strcpy (name, str);
    for (value = name; *value != '=' && *value != '\0'; ++value)
	;


    if (*value == '\0') {
	    /* Can't happen.  */
	    return;
	}
    *value = '\0';
    ++value;
    if (*value == '\0') {
	value = NULL;
    }


    /* Set the cygwin environment variable.  */


#undef putenv
    if (value == NULL) {
	unsetenv (name);
    } else {
	putenv(str);
    }

    /*
     * Before changing the environment variable in Windows, if this is PATH,
     * we need to convert the value back to a Windows style path.
     *
     * FIXME: The calling program may know it is running under windows, and
     * may have set the path to a Windows path, or, worse, appended or
     * prepended a Windows path to PATH.
     */

    if (strcmp (name, "PATH") != 0) {

	/* If this is Path, eliminate any PATH variable, to prevent any
	   confusion.  */


	if (strcmp (name, "Path") == 0) {
	    SetEnvironmentVariable ("PATH", (char *) NULL);
	    unsetenv ("PATH");
	}

	SetEnvironmentVariable (name, value);
    } else {
	char *buf;


	    /* Eliminate any Path variable, to prevent any confusion.  */


	SetEnvironmentVariable ("Path", (char *) NULL);
	unsetenv ("Path");

	if (value == NULL) {
	    buf = NULL;
	} else {
	    int size;

	    size = cygwin_posix_to_win32_path_list_buf_size (value);
	    buf = (char *) alloca (size + 1);
	    cygwin_posix_to_win32_path_list (value, buf);
	}

	SetEnvironmentVariable (name, buf);
    }
}

#endif /* __CYGWIN__ && __WIN32__ */















>
|
|
>
>
|
|
|
<
>
>

|
|
|






>
|
>
>


|












>
|
>
|
|
>
>
|
|
|


|



>
|
>
>
|
|






|
|
|


|




>
>
>
>
>
>
>
>
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749

750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826

static void
TclCygwinPutenv(str)
    const char *str;
{
    char *name, *value;

    /*
     * Get the name and value, so that we can change the environment variable
     * for Windows.
     */

    name = (char *) alloca(strlen(str) + 1);
    strcpy(name, str);
    for (value=name ; *value!='=' && *value!='\0' ; ++value) {

	/* Empty body */
    }
    if (*value == '\0') {
	/* Can't happen. */
	return;
    }
    *value = '\0';
    ++value;
    if (*value == '\0') {
	value = NULL;
    }

    /*
     * Set the cygwin environment variable.
     */

#undef putenv
    if (value == NULL) {
	unsetenv(name);
    } else {
	putenv(str);
    }

    /*
     * Before changing the environment variable in Windows, if this is PATH,
     * we need to convert the value back to a Windows style path.
     *
     * FIXME: The calling program may know it is running under windows, and
     * may have set the path to a Windows path, or, worse, appended or
     * prepended a Windows path to PATH.
     */

    if (strcmp(name, "PATH") != 0) {
	/*
	 * If this is Path, eliminate any PATH variable, to prevent any
	 * confusion.
	 */

	if (strcmp(name, "Path") == 0) {
	    SetEnvironmentVariable("PATH", (char *) NULL);
	    unsetenv("PATH");
	}

	SetEnvironmentVariable(name, value);
    } else {
	char *buf;

	/*
	 * Eliminate any Path variable, to prevent any confusion.
	 */

	SetEnvironmentVariable("Path", (char *) NULL);
	unsetenv("Path");

	if (value == NULL) {
	    buf = NULL;
	} else {
	    int size;

	    size = cygwin_posix_to_win32_path_list_buf_size(value);
	    buf = (char *) alloca(size + 1);
	    cygwin_posix_to_win32_path_list(value, buf);
	}

	SetEnvironmentVariable(name, buf);
    }
}

#endif /* __CYGWIN__ && __WIN32__ */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclEvent.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
/* 
 * tclEvent.c --
 *
 *	This file implements some general event related interfaces including
 *	background errors, exit handlers, and the "vwait" and "update"
 *	command procedures. 
 *
 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEvent.c,v 1.54 2004/12/01 23:18:50 dgp Exp $
 */

#include "tclInt.h"

/*
 * The data structure below is used to report background errors.  One
 * such structure is allocated for each error;  it holds information
 * about the interpreter and the error until an idle handler command
 * can be invoked.
 */

typedef struct BgError {
    Tcl_Obj *errorMsg;		/* Copy of the error message (the interp's
				 * result when the error occurred). */
    Tcl_Obj *returnOpts;	/* Active return options when the
				 * error occurred */
    struct BgError *nextPtr;	/* Next in list of all pending error
				 * reports for this interpreter, or NULL
				 * for end of list. */
} BgError;

/*
 * One of the structures below is associated with the "tclBgError"
 * assoc data for each interpreter.  It keeps track of the head and
 * tail of the list of pending background errors for the interpreter.
 */

typedef struct ErrAssocData {
    Tcl_Interp *interp;		/* Interpreter in which error occurred. */
    Tcl_Obj *cmdPrefix;		/* First word(s) of the handler command */
    BgError *firstBgPtr;	/* First in list of all background errors
				 * waiting to be processed for this




|
|





|
|

|





|
|
|
<





|
|
|
|
|



|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
/* 
 * tclEvent.c --
 *
 *	This file implements some general event related interfaces including
 *	background errors, exit handlers, and the "vwait" and "update" command
 *	procedures.
 *
 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEvent.c,v 1.54.2.8 2005/08/25 15:46:30 dgp Exp $
 */

#include "tclInt.h"

/*
 * The data structure below is used to report background errors.  One such
 * structure is allocated for each error; it holds information about the
 * interpreter and the error until an idle handler command can be invoked.

 */

typedef struct BgError {
    Tcl_Obj *errorMsg;		/* Copy of the error message (the interp's
				 * result when the error occurred). */
    Tcl_Obj *returnOpts;	/* Active return options when the error
				 * occurred */
    struct BgError *nextPtr;	/* Next in list of all pending error reports
				 * for this interpreter, or NULL for end of
				 * list. */
} BgError;

/*
 * One of the structures below is associated with the "tclBgError" assoc data
 * for each interpreter.  It keeps track of the head and tail of the list of
 * pending background errors for the interpreter.
 */

typedef struct ErrAssocData {
    Tcl_Interp *interp;		/* Interpreter in which error occurred. */
    Tcl_Obj *cmdPrefix;		/* First word(s) of the handler command */
    BgError *firstBgPtr;	/* First in list of all background errors
				 * waiting to be processed for this
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
 * For each exit handler created with a call to Tcl_CreateExitHandler
 * there is a structure of the following type:
 */

typedef struct ExitHandler {
    Tcl_ExitProc *proc;		/* Procedure to call when process exits. */
    ClientData clientData;	/* One word of information to pass to proc. */
    struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
				 * this application, or NULL for end of list. */
} ExitHandler;

/*
 * There is both per-process and per-thread exit handlers.
 * The first list is controlled by a mutex.  The other is in
 * thread local storage.
 */

static ExitHandler *firstExitPtr = NULL;
				/* First in list of all exit handlers for
				 * application. */
TCL_DECLARE_MUTEX(exitMutex)

/*
 * This variable is set to 1 when Tcl_Finalize is called, and at the end of
 * its work, it is reset to 0. The variable is checked by TclInExit() to
 * allow different behavior for exit-time processing, e.g. in closing of
 * files and pipes.
 */

static int inFinalize = 0;
static int subsystemsInitialized = 0;

/*
 * This variable contains the application wide exit handler.  It will be
 * called by Tcl_Exit instead of the C-runtime exit if this variable is set
 * to a non-NULL value.
 */

static Tcl_ExitProc *appExitPtr = NULL;

typedef struct ThreadSpecificData {
    ExitHandler *firstExitPtr;  /* First in list of all exit handlers for
				 * this thread. */
    int inExit;			/* True when this thread is exiting. This
				 * is used as a hack to decide to close
				 * the standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#ifdef TCL_THREADS

typedef struct {
    Tcl_ThreadCreateProc *proc;	/* Main() function of the thread */
    ClientData clientData;	/* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_((
           ClientData clientData));
#endif

/*
 * Prototypes for procedures referenced only in this file:
 */

static void		BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static void		HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char *		VwaitVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
			    CONST char *name2, int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BackgroundError --
 *
 *	This procedure is invoked to handle errors that occur in Tcl
 *	commands that are invoked in "background" (e.g. from event or
 *	timer bindings).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A handler command is invoked later as an idle handler to
 *	process the error, passing it the interp result and return
 *	options.  
 *
 *----------------------------------------------------------------------
 */

void
Tcl_BackgroundError(interp)
    Tcl_Interp *interp;		/* Interpreter in which an error has







|
|



|
|
<









|
|
|














|
|
|
|
|










|


















|
|
<





|
|
<







54
55
56
57
58
59
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136

137
138
139
140
141
142
143
 * For each exit handler created with a call to Tcl_CreateExitHandler
 * there is a structure of the following type:
 */

typedef struct ExitHandler {
    Tcl_ExitProc *proc;		/* Procedure to call when process exits. */
    ClientData clientData;	/* One word of information to pass to proc. */
    struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
				 * application, or NULL for end of list. */
} ExitHandler;

/*
 * There is both per-process and per-thread exit handlers.  The first list is
 * controlled by a mutex.  The other is in thread local storage.

 */

static ExitHandler *firstExitPtr = NULL;
				/* First in list of all exit handlers for
				 * application. */
TCL_DECLARE_MUTEX(exitMutex)

/*
 * This variable is set to 1 when Tcl_Finalize is called, and at the end of
 * its work, it is reset to 0. The variable is checked by TclInExit() to allow
 * different behavior for exit-time processing, e.g. in closing of files and
 * pipes.
 */

static int inFinalize = 0;
static int subsystemsInitialized = 0;

/*
 * This variable contains the application wide exit handler.  It will be
 * called by Tcl_Exit instead of the C-runtime exit if this variable is set
 * to a non-NULL value.
 */

static Tcl_ExitProc *appExitPtr = NULL;

typedef struct ThreadSpecificData {
    ExitHandler *firstExitPtr;  /* First in list of all exit handlers for this
				 * thread. */
    int inExit;			/* True when this thread is exiting. This is
				 * used as a hack to decide to close the
				 * standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#ifdef TCL_THREADS

typedef struct {
    Tcl_ThreadCreateProc *proc;	/* Main() function of the thread */
    ClientData clientData;	/* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_((
	ClientData clientData));
#endif

/*
 * Prototypes for procedures referenced only in this file:
 */

static void		BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static void		HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char *		VwaitVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
			    CONST char *name2, int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BackgroundError --
 *
 *	This procedure is invoked to handle errors that occur in Tcl commands
 *	that are invoked in "background" (e.g. from event or timer bindings).

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A handler command is invoked later as an idle handler to process the
 *	error, passing it the interp result and return options.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_BackgroundError(interp)
    Tcl_Interp *interp;		/* Interpreter in which an error has
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
}

/*
 *----------------------------------------------------------------------
 *
 * HandleBgErrors --
 *
 *	This procedure is invoked as an idle handler to process all of
 *	the accumulated background errors.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on what actions the handler command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

static void
HandleBgErrors(clientData)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
{
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    Tcl_Interp *interp = assocPtr->interp;
    BgError *errPtr;

    /*
     * Not bothering to save/restore the interp state.  Assume that
     * any code that has interp state it needs to keep will make
     * its own Tcl_SaveInterpState call before calling something like
     * Tcl_DoOneEvent() that could lead us here.
     */

    Tcl_Preserve((ClientData) assocPtr);
    Tcl_Preserve((ClientData) interp);
    while (assocPtr->firstBgPtr != NULL) {
	int code, prefixObjc;
	Tcl_Obj **prefixObjv, **tempObjv;

	errPtr = assocPtr->firstBgPtr;

	Tcl_IncrRefCount(assocPtr->cmdPrefix);
	Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix,
		&prefixObjc, &prefixObjv);
	tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
	memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
	tempObjv[prefixObjc] = errPtr->errorMsg;
	tempObjv[prefixObjc+1] = errPtr->returnOpts;
	Tcl_AllowExceptions(interp);
	code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);








|
|



















|
|
|
|











|
|







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
}

/*
 *----------------------------------------------------------------------
 *
 * HandleBgErrors --
 *
 *	This procedure is invoked as an idle handler to process all of the
 *	accumulated background errors.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on what actions the handler command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

static void
HandleBgErrors(clientData)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
{
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    Tcl_Interp *interp = assocPtr->interp;
    BgError *errPtr;

    /*
     * Not bothering to save/restore the interp state.  Assume that any code
     * that has interp state it needs to keep will make its own
     * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
     * that could lead us here.
     */

    Tcl_Preserve((ClientData) assocPtr);
    Tcl_Preserve((ClientData) interp);
    while (assocPtr->firstBgPtr != NULL) {
	int code, prefixObjc;
	Tcl_Obj **prefixObjv, **tempObjv;

	errPtr = assocPtr->firstBgPtr;

	Tcl_IncrRefCount(assocPtr->cmdPrefix);
	Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, &prefixObjc,
		&prefixObjv);
	tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
	memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
	tempObjv[prefixObjc] = errPtr->errorMsg;
	tempObjv[prefixObjc+1] = errPtr->returnOpts;
	Tcl_AllowExceptions(interp);
	code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

333

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
			"error in background error handler:\n", -1);
		if (valuePtr) {
		    Tcl_WriteObj(errChannel, valuePtr);
		} else {
		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		}
		Tcl_WriteChars(errChannel, "\n", 1);
                Tcl_Flush(errChannel);
	    }
	}
    }
    assocPtr->lastBgPtr = NULL;
    Tcl_Release((ClientData) interp);
    Tcl_Release((ClientData) assocPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclDefaultBgErrorHandlerObjCmd --
 *
 *	This procedure is invoked to process the "::tcl::Bgerror" Tcl
 *	command.  It is the default handler command registered with
 *	[interp bgerror] for the sake of compatibility with older Tcl
 *	releases.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	Depends on what actions the "bgerror" command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

int
TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Obj *keyPtr, *valuePtr;
    Tcl_Obj *tempObjv[2];
    int code;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "msg options");
	return TCL_ERROR;
    }

    /*
     * Restore important state variables to what they were at
     * the time the error occurred.
     *
     * Need to set the variables, not the interp fields, because
     * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy
     * anything we write to the interp fields.
     */

    keyPtr = Tcl_NewStringObj("-errorcode", -1);
    Tcl_IncrRefCount(keyPtr);
    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (valuePtr) {
	Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
    }

    keyPtr = Tcl_NewStringObj("-errorinfo", -1);
    Tcl_IncrRefCount(keyPtr);
    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (valuePtr) {
	Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
    }


    /* Create and invoke the bgerror command. */


    tempObjv[0] = Tcl_NewStringObj("bgerror", -1);
    Tcl_IncrRefCount(tempObjv[0]);
    tempObjv[1] = objv[1];
    Tcl_AllowExceptions(interp);
    code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
    if (code == TCL_ERROR) {
        /*
         * If the interpreter is safe, we look for a hidden command
         * named "bgerror" and call that with the error information.
         * Otherwise, simply ignore the error. The rationale is that
         * this could be an error caused by a malicious applet trying
         * to cause an infinite barrage of error messages. The hidden
         * "bgerror" command can be used by a security policy to
         * interpose on such attacks and e.g. kill the applet after a
         * few attempts.
         */

	if (Tcl_IsSafe(interp)) {
	    Tcl_ResetResult(interp);
	    TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
	} else {
	    Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

		Tcl_IncrRefCount(resultPtr);
		if (Tcl_FindCommand(interp, "bgerror",
			    NULL, TCL_GLOBAL_ONLY) == NULL) {
		    if (valuePtr) {
			Tcl_WriteObj(errChannel, valuePtr);
			Tcl_WriteChars(errChannel, "\n", -1);
		    }
                } else {
		    Tcl_WriteChars(errChannel,
			    "bgerror failed to handle background error.\n", -1);
		    Tcl_WriteChars(errChannel, "    Original error: ", -1);
		    Tcl_WriteObj(errChannel, objv[1]);
		    Tcl_WriteChars(errChannel, "\n", -1);
		    Tcl_WriteChars(errChannel,
				"    Error in bgerror: ", -1);
		    Tcl_WriteObj(errChannel, resultPtr);
		    Tcl_WriteChars(errChannel, "\n", -1);
                }
		Tcl_DecrRefCount(resultPtr);
                Tcl_Flush(errChannel);
	    }
	}
	code = TCL_OK;
    }
    Tcl_DecrRefCount(tempObjv[0]);
    Tcl_ResetResult(interp);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetBgErrorHandler --
 *
 *	This procedure sets the command prefix to be used to handle
 *	background errors in interp.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Error handler is registered.
 *







|













|
|
|
<












|
|
|
|











|
|

|
|
|


















>
|
>







|
|
|
|
|
|
<
|
|
|
>









|
|




|





|
<


|

|














|
|







253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276

277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369

370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
			"error in background error handler:\n", -1);
		if (valuePtr) {
		    Tcl_WriteObj(errChannel, valuePtr);
		} else {
		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		}
		Tcl_WriteChars(errChannel, "\n", 1);
		Tcl_Flush(errChannel);
	    }
	}
    }
    assocPtr->lastBgPtr = NULL;
    Tcl_Release((ClientData) interp);
    Tcl_Release((ClientData) assocPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclDefaultBgErrorHandlerObjCmd --
 *
 *	This procedure is invoked to process the "::tcl::Bgerror" Tcl command.
 *	It is the default handler command registered with [interp bgerror] for
 *	the sake of compatibility with older Tcl releases.

 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	Depends on what actions the "bgerror" command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

int
TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *keyPtr, *valuePtr;
    Tcl_Obj *tempObjv[2];
    int code;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "msg options");
	return TCL_ERROR;
    }

    /*
     * Restore important state variables to what they were at the time the
     * error occurred.
     *
     * Need to set the variables, not the interp fields, because Tcl_EvalObjv
     * calls Tcl_ResetResult which would destroy anything we write to the
     * interp fields.
     */

    keyPtr = Tcl_NewStringObj("-errorcode", -1);
    Tcl_IncrRefCount(keyPtr);
    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (valuePtr) {
	Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
    }

    keyPtr = Tcl_NewStringObj("-errorinfo", -1);
    Tcl_IncrRefCount(keyPtr);
    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (valuePtr) {
	Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
    }

    /*
     * Create and invoke the bgerror command.
     */

    tempObjv[0] = Tcl_NewStringObj("bgerror", -1);
    Tcl_IncrRefCount(tempObjv[0]);
    tempObjv[1] = objv[1];
    Tcl_AllowExceptions(interp);
    code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
    if (code == TCL_ERROR) {
	/*
	 * If the interpreter is safe, we look for a hidden command named
	 * "bgerror" and call that with the error information. Otherwise,
	 * simply ignore the error. The rationale is that this could be an
	 * error caused by a malicious applet trying to cause an infinite
	 * barrage of error messages. The hidden "bgerror" command can be used

	 * by a security policy to interpose on such attacks and e.g. kill the
	 * applet after a few attempts.
	 */

	if (Tcl_IsSafe(interp)) {
	    Tcl_ResetResult(interp);
	    TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
	} else {
	    Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

		Tcl_IncrRefCount(resultPtr);
		if (Tcl_FindCommand(interp, "bgerror", NULL,
			TCL_GLOBAL_ONLY) == NULL) {
		    if (valuePtr) {
			Tcl_WriteObj(errChannel, valuePtr);
			Tcl_WriteChars(errChannel, "\n", -1);
		    }
		} else {
		    Tcl_WriteChars(errChannel,
			    "bgerror failed to handle background error.\n", -1);
		    Tcl_WriteChars(errChannel, "    Original error: ", -1);
		    Tcl_WriteObj(errChannel, objv[1]);
		    Tcl_WriteChars(errChannel, "\n", -1);
		    Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);

		    Tcl_WriteObj(errChannel, resultPtr);
		    Tcl_WriteChars(errChannel, "\n", -1);
		}
		Tcl_DecrRefCount(resultPtr);
		Tcl_Flush(errChannel);
	    }
	}
	code = TCL_OK;
    }
    Tcl_DecrRefCount(tempObjv[0]);
    Tcl_ResetResult(interp);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetBgErrorHandler --
 *
 *	This procedure sets the command prefix to be used to handle background
 *	errors in interp.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Error handler is registered.
 *
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetBgErrorHandler --
 *
 *	This procedure retrieves the command prefix currently used
 *	to handle background errors in interp.
 *
 * Results:
 *	A (Tcl_Obj *) to a list of words (command prefix).
 *
 * Side effects:
 *	None.
 *







|
|







427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetBgErrorHandler --
 *
 *	This procedure retrieves the command prefix currently used to handle
 *	background errors in interp.
 *
 * Results:
 *	A (Tcl_Obj *) to a list of words (command prefix).
 *
 * Side effects:
 *	None.
 *
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
}

/*
 *----------------------------------------------------------------------
 *
 * BgErrorDeleteProc --
 *
 *	This procedure is associated with the "tclBgError" assoc data
 *	for an interpreter;  it is invoked when the interpreter is
 *	deleted in order to free the information assoicated with any
 *	pending error reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Background error information is freed: if there were any
 *	pending error reports, they are cancelled.
 *
 *----------------------------------------------------------------------
 */

static void
BgErrorDeleteProc(clientData, interp)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */







|
|
|
<





|
|







459
460
461
462
463
464
465
466
467
468

469
470
471
472
473
474
475
476
477
478
479
480
481
482
}

/*
 *----------------------------------------------------------------------
 *
 * BgErrorDeleteProc --
 *
 *	This procedure is associated with the "tclBgError" assoc data for an
 *	interpreter; it is invoked when the interpreter is deleted in order to
 *	free the information assoicated with any pending error reports.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Background error information is freed: if there were any pending error
 *	reports, they are cancelled.
 *
 *----------------------------------------------------------------------
 */

static void
BgErrorDeleteProc(clientData, interp)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
 *	Arrange for a given procedure to be invoked just before the
 *	application exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Proc will be invoked with clientData as argument when the
 *	application exits.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure to invoke. */







|
|







505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
 *	Arrange for a given procedure to be invoked just before the
 *	application exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Proc will be invoked with clientData as argument when the application
 *	exits.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure to invoke. */
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteExitHandler --
 *
 *	This procedure cancels an existing exit handler matching proc
 *	and clientData, if such a handler exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is an exit handler corresponding to proc and clientData
 *	then it is cancelled;  if no such handler exists then nothing
 *	happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure that was previously registered. */







|
|





|
|
<







532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547

548
549
550
551
552
553
554
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteExitHandler --
 *
 *	This procedure cancels an existing exit handler matching proc and
 *	clientData, if such a handler exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is an exit handler corresponding to proc and clientData then
 *	it is cancelled; if no such handler exists then nothing happens.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure that was previously registered. */
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateThreadExitHandler --
 *
 *	Arrange for a given procedure to be invoked just before the
 *	current thread exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Proc will be invoked with clientData as argument when the
 *	application exits.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateThreadExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure to invoke. */







|
|





|
|







575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateThreadExitHandler --
 *
 *	Arrange for a given procedure to be invoked just before the current
 *	thread exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Proc will be invoked with clientData as argument when the application
 *	exits.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateThreadExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure to invoke. */
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteThreadExitHandler --
 *
 *	This procedure cancels an existing exit handler matching proc
 *	and clientData, if such a handler exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is an exit handler corresponding to proc and clientData
 *	then it is cancelled;  if no such handler exists then nothing
 *	happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteThreadExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure that was previously registered. */







|
|





|
|
<







608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623

624
625
626
627
628
629
630
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteThreadExitHandler --
 *
 *	This procedure cancels an existing exit handler matching proc and
 *	clientData, if such a handler exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is an exit handler corresponding to proc and clientData then
 *	it is cancelled; if no such handler exists then nothing happens.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteThreadExitHandler(proc, clientData)
    Tcl_ExitProc *proc;		/* Procedure that was previously registered. */
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetExitProc --
 *
 *	This procedure sets the application wide exit handler that
 *	will be called by Tcl_Exit in place of the C-runtime exit.  If
 *	the application wide exit handler is NULL, the C-runtime exit
 *	will be used instead.
 *
 * Results:
 *	The previously set application wide exit handler.
 *
 * Side effects:
 *	Sets the application wide exit handler to the specified value.
 *
 *----------------------------------------------------------------------
 */

Tcl_ExitProc *
Tcl_SetExitProc(proc)
    Tcl_ExitProc *proc; /* new exit handler for app or NULL */
{
    Tcl_ExitProc *prevExitProc;

    /*
     * Swap the old exit proc for the new one, saving the old one for
     * our return value.
     */

    Tcl_MutexLock(&exitMutex);
    prevExitProc = appExitPtr;
    appExitPtr = proc;
    Tcl_MutexUnlock(&exitMutex);








|
|
|
<

















|
|







649
650
651
652
653
654
655
656
657
658

659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetExitProc --
 *
 *	This procedure sets the application wide exit handler that will be
 *	called by Tcl_Exit in place of the C-runtime exit.  If the application
 *	wide exit handler is NULL, the C-runtime exit will be used instead.

 *
 * Results:
 *	The previously set application wide exit handler.
 *
 * Side effects:
 *	Sets the application wide exit handler to the specified value.
 *
 *----------------------------------------------------------------------
 */

Tcl_ExitProc *
Tcl_SetExitProc(proc)
    Tcl_ExitProc *proc; /* new exit handler for app or NULL */
{
    Tcl_ExitProc *prevExitProc;

    /*
     * Swap the old exit proc for the new one, saving the old one for our
     * return value.
     */

    Tcl_MutexLock(&exitMutex);
    prevExitProc = appExitPtr;
    appExitPtr = proc;
    Tcl_MutexUnlock(&exitMutex);

700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729

730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792



793
794
795
796
797
798
799
800


801

802
803

804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
 *
 *	This procedure is called to terminate the application.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	All existing exit handlers are invoked, then the application
 *	ends.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Exit(status)
    int status;			/* Exit status for application;  typically
				 * 0 for normal return, 1 for error return. */
{
    Tcl_ExitProc *currentAppExitPtr;

    Tcl_MutexLock(&exitMutex);
    currentAppExitPtr = appExitPtr;
    Tcl_MutexUnlock(&exitMutex);

    if (currentAppExitPtr) {
	/*
	 * Warning: this code SHOULD NOT return, as there is code that
	 * depends on Tcl_Exit never returning.  In fact, we will
	 * Tcl_Panic if anyone returns, so critical is this dependcy.
	 */

	currentAppExitPtr((ClientData) status);
	Tcl_Panic("AppExitProc returned unexpectedly");
    } else {
	/* use default handling */
	Tcl_Finalize();
	TclpExit(status);
	Tcl_Panic("OS exit failed!");
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * TclInitSubsystems --
 *
 *	Initialize various subsytems in Tcl.  This should be called the
 *	first time an interp is created, or before any of the subsystems
 *	are used.  This function ensures an order for the initialization 
 *	of subsystems:
 *
 *	1. that cannot be initialized in lazy order because they are 
 *	mutually dependent.
 *
 *	2. so that they can be finalized in a known order w/o causing
 *	the subsequent re-initialization of a subsystem in the act of
 *	shutting down another.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Varied, see the respective initialization routines.
 *
 *-------------------------------------------------------------------------
 */

void
TclInitSubsystems()
{
    if (inFinalize != 0) {
	Tcl_Panic("TclInitSubsystems called while finalizing");
    }

    if (subsystemsInitialized == 0) {
	/* 
	 * Double check inside the mutex.  There are definitly calls
	 * back into this routine from some of the procedures below.
	 */

	TclpInitLock();
	if (subsystemsInitialized == 0) {
	    /*
	     * Have to set this bit here to avoid deadlock with the
	     * routines below us that call into TclInitSubsystems.
	     */

	    subsystemsInitialized = 1;

	    /*
	     * Initialize locks used by the memory allocators before anything
	     * interesting happens so we can use the allocators in the
	     * implementation of self-initializing locks.
	     */



#if USE_TCLALLOC
	    TclInitAlloc(); /* process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
	    TclInitDbCkalloc(); /* process wide mutex init */
#endif

	    TclpInitPlatform(); /* creates signal handler(s) */


    	    TclInitObjSubsystem(); /* register obj types, create mutexes */

	    TclInitIOSubsystem(); /* inits a tsd key (noop) */
	    TclInitEncodingSubsystem(); /* process wide encoding init */

    	    TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
	}
	TclpInitUnlock();
    }
    TclInitNotifier();
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Finalize --
 *
 *	Shut down Tcl.  First calls registered exit handlers, then
 *	carefully shuts down various subsystems.
 *	Called by Tcl_Exit or when the Tcl shared library is being 
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Varied, see the respective finalization routines.
 *







|
<

















|
|
|

>















|
|
|
<

|
|

|
|
|



















|
|





|
|









>
>
>

|


|


|
>
>
|
>
|
|
>
|











|
|
|
<







692
693
694
695
696
697
698
699

700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739

740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816

817
818
819
820
821
822
823
 *
 *	This procedure is called to terminate the application.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	All existing exit handlers are invoked, then the application ends.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_Exit(status)
    int status;			/* Exit status for application;  typically
				 * 0 for normal return, 1 for error return. */
{
    Tcl_ExitProc *currentAppExitPtr;

    Tcl_MutexLock(&exitMutex);
    currentAppExitPtr = appExitPtr;
    Tcl_MutexUnlock(&exitMutex);

    if (currentAppExitPtr) {
	/*
	 * Warning: this code SHOULD NOT return, as there is code that depends
	 * on Tcl_Exit never returning.  In fact, we will Tcl_Panic if anyone
	 * returns, so critical is this dependcy.
	 */

	currentAppExitPtr((ClientData) status);
	Tcl_Panic("AppExitProc returned unexpectedly");
    } else {
	/* use default handling */
	Tcl_Finalize();
	TclpExit(status);
	Tcl_Panic("OS exit failed!");
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * TclInitSubsystems --
 *
 *	Initialize various subsytems in Tcl.  This should be called the first
 *	time an interp is created, or before any of the subsystems are used.
 *	This function ensures an order for the initialization of subsystems:

 *
 *	1. that cannot be initialized in lazy order because they are mutually
 *	dependent.
 *
 *	2. so that they can be finalized in a known order w/o causing the
 *	subsequent re-initialization of a subsystem in the act of shutting
 *	down another.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Varied, see the respective initialization routines.
 *
 *-------------------------------------------------------------------------
 */

void
TclInitSubsystems()
{
    if (inFinalize != 0) {
	Tcl_Panic("TclInitSubsystems called while finalizing");
    }

    if (subsystemsInitialized == 0) {
	/* 
	 * Double check inside the mutex.  There are definitly calls back into
	 * this routine from some of the procedures below.
	 */

	TclpInitLock();
	if (subsystemsInitialized == 0) {
	    /*
	     * Have to set this bit here to avoid deadlock with the routines
	     * below us that call into TclInitSubsystems.
	     */

	    subsystemsInitialized = 1;

	    /*
	     * Initialize locks used by the memory allocators before anything
	     * interesting happens so we can use the allocators in the
	     * implementation of self-initializing locks.
	     */

	    TclInitThreadStorage();     /* Creates master hash table for
					 * thread local storage */
#if USE_TCLALLOC
	    TclInitAlloc();		/* Process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
	    TclInitDbCkalloc();		/* Process wide mutex init */
#endif

	    TclpInitPlatform();		/* Creates signal handler(s) */
	    TclInitDoubleConversion();	/* Initializes constants for
					 * converting to/from double. */
    	    TclInitObjSubsystem();	/* Register obj types, create
					 * mutexes. */
	    TclInitIOSubsystem();	/* Inits a tsd key (noop). */
	    TclInitEncodingSubsystem();	/* Process wide encoding init. */
	    TclpSetInterfaces();
    	    TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
	}
	TclpInitUnlock();
    }
    TclInitNotifier();
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Finalize --
 *
 *	Shut down Tcl.  First calls registered exit handlers, then carefully
 *	shuts down various subsystems.  Called by Tcl_Exit or when the Tcl
 *	shared library is being unloaded.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Varied, see the respective finalization routines.
 *
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884

885
886
887
888
889
890

891
892
893












894
895
896
897
898

899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914

915
916





















917
918
919
920

921
922



923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973







974
975
976
977
978
979
980
     * Invoke exit handlers first.
     */

    Tcl_MutexLock(&exitMutex);
    inFinalize = 1;
    for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
	/*
	 * Be careful to remove the handler from the list before
	 * invoking its callback.  This protects us against
	 * double-freeing if the callback should call
	 * Tcl_DeleteExitHandler on itself.
	 */

	firstExitPtr = exitPtr->nextPtr;
	Tcl_MutexUnlock(&exitMutex);
	(*exitPtr->proc)(exitPtr->clientData);
	ckfree((char *) exitPtr);
	Tcl_MutexLock(&exitMutex);
    }    
    firstExitPtr = NULL;
    Tcl_MutexUnlock(&exitMutex);

    TclpInitLock();
    if (subsystemsInitialized != 0) {
	subsystemsInitialized = 0;

	/*
	 * Ensure the thread-specific data is initialised as it is
	 * used in Tcl_FinalizeThread()
	 */

	(void) TCL_TSD_INIT(&dataKey);

	/*
	 * Clean up after the current thread now, after exit handlers.
	 * In particular, the testexithandler command sets up something
	 * that writes to standard output, which gets closed.
	 * Note that there is no thread-local storage after this call.
	 */

	Tcl_FinalizeThread();

	/*
	 * Now finalize the Tcl execution environment.  Note that this
	 * must be done after the exit handlers, because there are
	 * order dependencies.
	 */

	TclFinalizeCompExecEnv();

	TclFinalizeEnvironment();

	/* 
	 * Finalizing the filesystem must come after anything which
	 * might conceivably interact with the 'Tcl_FS' API. 
	 */

	TclFinalizeFilesystem();

	/* 












	 * We must be sure the encoding finalization doesn't need
	 * to examine the filesystem in any way.  Since it only
	 * needs to clean up internal data structures, this is
	 * fine.
	 */

	TclFinalizeEncodingSubsystem();

	Tcl_SetPanicProc(NULL);

	/*
	 * Repeat finalization of the thread local storage once more.
	 * Although this step is already done by the Tcl_FinalizeThread
	 * call above, series of events happening afterwards may
	 * re-initialize TSD slots.  Those need to be finalized again,
	 * otherwise we're leaking memory chunks.
	 * Very important to note is that things happening afterwards
	 * should not reference anything which may re-initialize TSD's.
	 * This includes freeing Tcl_Objs's, among other things.
	 *
	 * This fixes the Tcl Bug #990552.
	 */

	TclFinalizeThreadData();






















	/*
	 * Free synchronization objects.  There really should only be one
	 * thread alive at this moment.
	 */

	TclFinalizeSynchronization();




	/*
	 * We defer unloading of packages until very late 
	 * to avoid memory access issues.  Both exit callbacks and
	 * synchronization variables may be stored in packages.
	 * 
	 * Note that TclFinalizeLoad unloads packages in the reverse
	 * of the order they were loaded in (i.e. last to be loaded
	 * is the first to be unloaded).  This can be important for
	 * correct unloading when dependencies exist.
	 * 
	 * Once load has been finalized, we will have deleted any
	 * temporary copies of shared libraries and can therefore
	 * reset the filesystem to its original state.
	 */

	TclFinalizeLoad();
	TclResetFilesystem();
	
	/*
	 * There shouldn't be any malloc'ed memory after this.
	 */
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
  TclFinalizeThreadAlloc();
#endif
	TclFinalizeMemorySubsystem();
	inFinalize = 0;
    }
    TclFinalizeLock();
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeThread --
 *
 *	Runs the exit handlers to allow Tcl to clean up its state
 *	about a particular thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Varied, see the respective finalization routines.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeThread()
{
    ExitHandler *exitPtr;







    ThreadSpecificData *tsdPtr =
	    (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (tsdPtr != NULL) {
	tsdPtr->inExit = 1;

	for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;







|
|
<
|
















|
|





|
|
|
|





|
|
<


|
>



|
|

>


|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
<

>





|
|
|
|
<
|
|
|



>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




>


>
>
>

|
|
|

|
|
|
|

|
|
|




|

|

|
<
<











|
|














>
>
>
>
>
>
>







833
834
835
836
837
838
839
840
841

842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876

877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905

906
907
908
909
910
911
912
913
914
915
916

917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978


979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
     * Invoke exit handlers first.
     */

    Tcl_MutexLock(&exitMutex);
    inFinalize = 1;
    for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
	/*
	 * Be careful to remove the handler from the list before invoking its
	 * callback.  This protects us against double-freeing if the callback

	 * should call Tcl_DeleteExitHandler on itself.
	 */

	firstExitPtr = exitPtr->nextPtr;
	Tcl_MutexUnlock(&exitMutex);
	(*exitPtr->proc)(exitPtr->clientData);
	ckfree((char *) exitPtr);
	Tcl_MutexLock(&exitMutex);
    }    
    firstExitPtr = NULL;
    Tcl_MutexUnlock(&exitMutex);

    TclpInitLock();
    if (subsystemsInitialized != 0) {
	subsystemsInitialized = 0;

	/*
	 * Ensure the thread-specific data is initialised as it is used in
	 * Tcl_FinalizeThread()
	 */

	(void) TCL_TSD_INIT(&dataKey);

	/*
	 * Clean up after the current thread now, after exit handlers.  In
	 * particular, the testexithandler command sets up something that
	 * writes to standard output, which gets closed.  Note that there is
	 * no thread-local storage after this call.
	 */

	Tcl_FinalizeThread();

	/*
	 * Now finalize the Tcl execution environment.  Note that this must be
	 * done after the exit handlers, because there are order dependencies.

	 */

	TclFinalizeCompilation();
	TclFinalizeExecution();
	TclFinalizeEnvironment();

	/* 
	 * Finalizing the filesystem must come after anything which might
	 * conceivably interact with the 'Tcl_FS' API.
	 */

	TclFinalizeFilesystem();

	/*
	 * Undo all Tcl_ObjType registrations, and reset the master list
	 * of free Tcl_Obj's.  After this returns, no more Tcl_Obj's should
	 * be allocated or freed.  
	 *
	 * Note in particular that TclFinalizeObjects() must follow
	 * TclFinalizeFilesystem() because TclFinalizeFilesystem free's
	 * the Tcl_Obj that holds the path of the current working directory.
	 */

	TclFinalizeObjects();

	/* 
	 * We must be sure the encoding finalization doesn't need to examine
	 * the filesystem in any way.  Since it only needs to clean up
	 * internal data structures, this is fine.

	 */

	TclFinalizeEncodingSubsystem();

	Tcl_SetPanicProc(NULL);

	/*
	 * Repeat finalization of the thread local storage once more. Although
	 * this step is already done by the Tcl_FinalizeThread call above,
	 * series of events happening afterwards may re-initialize TSD slots.
	 * Those need to be finalized again, otherwise we're leaking memory

	 * chunks. Very important to note is that things happening afterwards
	 * should not reference anything which may re-initialize TSD's. This
	 * includes freeing Tcl_Objs's, among other things.
	 *
	 * This fixes the Tcl Bug #990552.
	 */

	TclFinalizeThreadData();

	/*
	 * Now we can free constants for conversions to/from double.
	 */

	TclFinalizeDoubleConversion();
	
	/*
	 * There have been several bugs in the past that cause exit handlers
	 * to be established during Tcl_Finalize processing. Such exit
	 * handlers leave malloc'ed memory, and Tcl_FinalizeThreadAlloc or
	 * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The
	 * result can be a mysterious crash on process exit. Check here that
	 * nobody's done this.
	 */

	if (firstExitPtr != NULL) {
	    Tcl_Panic("exit handlers were created during Tcl_Finalize");
	}

	TclFinalizePreserve();

	/*
	 * Free synchronization objects.  There really should only be one
	 * thread alive at this moment.
	 */

	TclFinalizeSynchronization();

#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
	TclFinalizeThreadAlloc();
#endif
	/*
	 * We defer unloading of packages until very late to avoid memory
	 * access issues.  Both exit callbacks and synchronization variables
	 * may be stored in packages.
	 * 
	 * Note that TclFinalizeLoad unloads packages in the reverse of the
	 * order they were loaded in (i.e. last to be loaded is the first to
	 * be unloaded).  This can be important for correct unloading when
	 * dependencies exist.
	 * 
	 * Once load has been finalized, we will have deleted any temporary
	 * copies of shared libraries and can therefore reset the filesystem
	 * to its original state.
	 */

	TclFinalizeLoad();
	TclResetFilesystem();

	/*
	 * At this point, there should no longer be any ckalloc'ed memory.
	 */



	TclFinalizeMemorySubsystem();
	inFinalize = 0;
    }
    TclFinalizeLock();
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeThread --
 *
 *	Runs the exit handlers to allow Tcl to clean up its state about a
 *	particular thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Varied, see the respective finalization routines.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeThread()
{
    ExitHandler *exitPtr;

    /* 
     * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData,
     * because we don't want to initialize the data block if it hasn't
     * been initialized already.
     */

    ThreadSpecificData *tsdPtr =
	    (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (tsdPtr != NULL) {
	tsdPtr->inExit = 1;

	for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
	TclFinalizeNotifier();
	TclFinalizeAsync();
    }

    /*
     * Blow away all thread local storage blocks.
     *
     * Note that Tcl API allows creation of threads which do not use any
     * Tcl interp or other Tcl subsytems. Those threads might, however,
     * use thread local storage, so we must unconditionally finalize it.
     *
     * Fix [Bug #571002]
     */

     TclFinalizeThreadData();
}

/*
 *----------------------------------------------------------------------
 *
 * TclInExit --
 *







|
|
|




|







1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
	TclFinalizeNotifier();
	TclFinalizeAsync();
    }

    /*
     * Blow away all thread local storage blocks.
     *
     * Note that Tcl API allows creation of threads which do not use any Tcl
     * interp or other Tcl subsytems. Those threads might, however, use thread
     * local storage, so we must unconditionally finalize it.
     *
     * Fix [Bug #571002]
     */

    TclFinalizeThreadData();
}

/*
 *----------------------------------------------------------------------
 *
 * TclInExit --
 *
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VwaitObjCmd --
 *
 *	This procedure is invoked to process the "vwait" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VwaitObjCmd --
 *
 *	This procedure is invoked to process the "vwait" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102


1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int done, foundEvent;
    char *nameString;

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }
    nameString = Tcl_GetString(objv[1]);
    if (Tcl_TraceVar(interp, nameString,
	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    VwaitVarProc, (ClientData) &done) != TCL_OK) {
	return TCL_ERROR;
    };
    done = 0;
    foundEvent = 1;
    while (!done && foundEvent) {
	foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
	if (Tcl_LimitExceeded(interp)) {


	    return TCL_ERROR;
	}
    }
    Tcl_UntraceVar(interp, nameString,
	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    VwaitVarProc, (ClientData) &done);

    /*
     * Clear out the interpreter's result, since it may have been set
     * by event handlers.
     */

    Tcl_ResetResult(interp);
    if (!foundEvent) {
	Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
		"\":  would wait forever", (char *) NULL);
	return TCL_ERROR;







|













>
>








|
|







1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int done, foundEvent;
    char *nameString;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }
    nameString = Tcl_GetString(objv[1]);
    if (Tcl_TraceVar(interp, nameString,
	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    VwaitVarProc, (ClientData) &done) != TCL_OK) {
	return TCL_ERROR;
    };
    done = 0;
    foundEvent = 1;
    while (!done && foundEvent) {
	foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "limit exceeded", NULL);
	    return TCL_ERROR;
	}
    }
    Tcl_UntraceVar(interp, nameString,
	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    VwaitVarProc, (ClientData) &done);

    /*
     * Clear out the interpreter's result, since it may have been set by event
     * handlers.
     */

    Tcl_ResetResult(interp);
    if (!foundEvent) {
	Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
		"\":  would wait forever", (char *) NULL);
	return TCL_ERROR;
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateObjCmd --
 *
 *	This procedure is invoked to process the "update" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateObjCmd --
 *
 *	This procedure is invoked to process the "update" Tcl command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191


1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
	flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
    } else if (objc == 2) {
	if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
		"option", 0, &optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum updateOptions) optionIndex) {
	    case REGEXP_IDLETASKS: {
		flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
		break;
	    }
	    default: {
		Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
	    }
	}
    } else {
        Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
	return TCL_ERROR;
    }
    
    while (Tcl_DoOneEvent(flags) != 0) {
	if (Tcl_LimitExceeded(interp)) {


	    return TCL_ERROR;
	}
    }

    /*
     * Must clear the interpreter's result because event handlers could
     * have executed commands.
     */

    Tcl_ResetResult(interp);
    return TCL_OK;
}

#ifdef TCL_THREADS
/*
 *-----------------------------------------------------------------------------
 *
 *  NewThreadProc --
 *
 * 	Bootstrap function of a new Tcl thread.







|
|
|
<
|
|
|
<

|





>
>





|
|





|







1211
1212
1213
1214
1215
1216
1217
1218
1219
1220

1221
1222
1223

1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
	flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
    } else if (objc == 2) {
	if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
		"option", 0, &optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum updateOptions) optionIndex) {
	case REGEXP_IDLETASKS:
	    flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
	    break;

	default:
	    Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
	}

    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
	return TCL_ERROR;
    }
    
    while (Tcl_DoOneEvent(flags) != 0) {
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "limit exceeded", NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * Must clear the interpreter's result because event handlers could have
     * executed commands.
     */

    Tcl_ResetResult(interp);
    return TCL_OK;
}

#ifdef TCL_THREADS
/*
 *-----------------------------------------------------------------------------
 *
 *  NewThreadProc --
 *
 * 	Bootstrap function of a new Tcl thread.
1232
1233
1234
1235
1236
1237
1238

1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279








    Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */

    (*threadProc)(threadClientData);

    TCL_THREAD_CREATE_RETURN;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateThread --
 *
 *	This procedure creates a new thread. This actually belongs
 *	to the tclThread.c file but since we use some private 
 *	data structures local to this file, it is placed here.
 *
 * Results:
 *	TCL_OK if the thread could be created.  The thread ID is
 *	returned in a parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread */
    ClientData clientData;		/* The one argument to Main() */
    int stackSize;			/* Size of stack for the new thread */
    int flags;				/* Flags controlling behaviour of
					 * the new thread */
{
#ifdef TCL_THREADS
    ThreadClientData *cdPtr;

    cdPtr = (ThreadClientData*)Tcl_Alloc(sizeof(ThreadClientData));
    cdPtr->proc = proc;
    cdPtr->clientData = clientData;

    return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
                           stackSize, flags);
#else
    return TCL_ERROR;
#endif /* TCL_THREADS */
}















>





|
|
|


|
|













|
|




|




|




>
>
>
>
>
>
>
>
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
    Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */

    (*threadProc)(threadClientData);

    TCL_THREAD_CREATE_RETURN;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateThread --
 *
 *	This procedure creates a new thread. This actually belongs to the
 *	tclThread.c file but since we use some private data structures local
 *	to this file, it is placed here.
 *
 * Results:
 *	TCL_OK if the thread could be created.  The thread ID is returned in a
 *	parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread */
    ClientData clientData;		/* The one argument to Main() */
    int stackSize;			/* Size of stack for the new thread */
    int flags;				/* Flags controlling behaviour of the
					 * new thread. */
{
#ifdef TCL_THREADS
    ThreadClientData *cdPtr;

    cdPtr = (ThreadClientData *) Tcl_Alloc(sizeof(ThreadClientData));
    cdPtr->proc = proc;
    cdPtr->clientData = clientData;

    return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
	    stackSize, flags);
#else
    return TCL_ERROR;
#endif /* TCL_THREADS */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclExecute.c.

1
2
3
4
5
6
7
8
9


10
11
12
13
14
15
16
17
18

19
20
21











22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
/* 
 * tclExecute.c --
 *
 *	This file contains procedures that execute byte-compiled Tcl
 *	commands.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.


 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167 2004/11/12 19:16:50 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"


#ifndef TCL_NO_MATH
#   include <math.h>











#endif

/*
 * The stuff below is a bit of a hack so that this file can be used
 * in environments that include no UNIX, i.e. no errno.  Just define
 * errno here.
 */

#ifdef TCL_GENERIC_ONLY
#   ifndef NO_FLOAT_H
#	include <float.h>
#   else /* NO_FLOAT_H */
#	ifndef NO_VALUES_H
#	    include <values.h>
#	endif /* !NO_VALUES_H */
#   endif /* !NO_FLOAT_H */
#   define NO_ERRNO_H
#endif /* !TCL_GENERIC_ONLY */


#ifdef NO_ERRNO_H
int errno;
#   define EDOM   33
#   define ERANGE 34
#endif

/*
 * Need DBL_MAX for IS_INF() macro...
 */
#ifndef DBL_MAX
#   ifdef MAXDOUBLE
#	define DBL_MAX MAXDOUBLE
#   else /* !MAXDOUBLE */
/*
 * This value is from the Solaris headers, but doubles seem to be the
 * same size everywhere.  Long doubles aren't, but we don't use those.
 */
#	define DBL_MAX 1.79769313486231570e+308
#   endif /* MAXDOUBLE */
#endif /* !DBL_MAX */

/*
 * A mask (should be 2**n-1) that is used to work out when the
 * bytecode engine should call Tcl_AsyncReady() to see whether there
 * is a signal that needs handling.
 */

#ifndef ASYNC_CHECK_COUNT_MASK
#   define ASYNC_CHECK_COUNT_MASK	63
#endif /* !ASYNC_CHECK_COUNT_MASK */


|


|
<




>
>

|
|

|




>

<
|
>
>
>
>
>
>
>
>
>
>
>



|
|
<













>





<
<
<
<
<
<
<
<
<
<
<
<
<
<
|


|
|
|







1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57














58
59
60
61
62
63
64
65
66
67
68
69
70
/*
 * tclExecute.c --
 *
 *	This file contains procedures that execute byte-compiled Tcl commands.

 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.57 2005/10/08 06:43:18 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"


#include <math.h>
#include <float.h>

/*
 * Hack to determine whether we may expect IEEE floating point.  The hack is
 * formally incorrect in that non-IEEE platforms might have the same precision
 * and range, but VAX, IBM, and Cray do not; are there any other floating
 * point units that we might care about?
 */

#if ( FLT_RADIX == 2 ) && ( DBL_MANT_DIG == 53 ) && ( DBL_MAX_EXP == 1024 )
#define IEEE_FLOATING_POINT
#endif

/*
 * The stuff below is a bit of a hack so that this file can be used in
 * environments that include no UNIX, i.e. no errno.  Just define errno here.

 */

#ifdef TCL_GENERIC_ONLY
#   ifndef NO_FLOAT_H
#	include <float.h>
#   else /* NO_FLOAT_H */
#	ifndef NO_VALUES_H
#	    include <values.h>
#	endif /* !NO_VALUES_H */
#   endif /* !NO_FLOAT_H */
#   define NO_ERRNO_H
#endif /* !TCL_GENERIC_ONLY */

#if 0
#ifdef NO_ERRNO_H
int errno;
#   define EDOM   33
#   define ERANGE 34
#endif














#endif

/*
 * A mask (should be 2**n-1) that is used to work out when the bytecode engine
 * should call Tcl_AsyncReady() to see whether there is a signal that needs
 * handling.
 */

#ifndef ASYNC_CHECK_COUNT_MASK
#   define ASYNC_CHECK_COUNT_MASK	63
#endif /* !ASYNC_CHECK_COUNT_MASK */


106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
    "+", "-", "*", "/", "%", "+", "-", "~", "!",
    "BUILTIN FUNCTION", "FUNCTION",
    "", "", "", "", "", "", "", "", "eq", "ne"
};

/*
 * Mapping from Tcl result codes to strings; used for error and debugging
 * messages. 
 */

#ifdef TCL_COMPILE_DEBUG
static char *resultStrings[] = {
    "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif

/*
 * These are used by evalstats to monitor object usage in Tcl.
 */

#ifdef TCL_COMPILE_STATS
long		tclObjsAlloced = 0;
long		tclObjsFreed   = 0;
#define TCL_MAX_SHARED_OBJ_STATS 5
long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */

/*
 * Macros for testing floating-point values for certain special cases. Test
 * for not-a-number by comparing a value against itself; test for infinity
 * by comparing against the largest floating-point value.
 */

#define IS_NAN(v) ((v) != (v))
#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))

/*
 * The new macro for ending an instruction; note that a
 * reasonable C-optimiser will resolve all branches
 * at compile time. (result) is always a constant; the macro 
 * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
 * resolved at runtime for variable (nCleanup).
 *
 * ARGUMENTS:
 *    pcAdjustment: how much to increment pc
 *    nCleanup: how many objects to remove from the stack
 *    resultHandling: 0 indicates no object should be pushed on the
 *       stack; otherwise, push objResultPtr. If (result < 0),
 *       objResultPtr already has the correct reference count.
 */

#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
     if (nCleanup == 0) {\
	 if (resultHandling != 0) {\
	     if ((resultHandling) > 0) {\
		 PUSH_OBJECT(objResultPtr);\
	     } else {\
		 *(++tosPtr) = objResultPtr;\
	     }\
	 } \
	 pc += (pcAdjustment);\
	 goto cleanup0;\
     } else if (resultHandling != 0) {\
	 if ((resultHandling) > 0) {\
	     Tcl_IncrRefCount(objResultPtr);\
	 }\
	 pc += (pcAdjustment);\
	 switch (nCleanup) {\
	     case 1: goto cleanup1_pushObjResultPtr;\
	     case 2: goto cleanup2_pushObjResultPtr;\
	     default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\
	 }\
     } else {\
	 pc += (pcAdjustment);\
	 switch (nCleanup) {\
	     case 1: goto cleanup1;\
	     case 2: goto cleanup2;\
	     default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\
	 }\
     }

#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
    pc += (pcAdjustment);\
    cleanup = (nCleanup);\
    if (resultHandling) {\
	if ((resultHandling) > 0) {\
	    Tcl_IncrRefCount(objResultPtr);\







|




















<
<
<
<
<
<
<
<
<
|
<
|
|
|




|
|
|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131









132

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
    "+", "-", "*", "/", "%", "+", "-", "~", "!",
    "BUILTIN FUNCTION", "FUNCTION",
    "", "", "", "", "", "", "", "", "eq", "ne"
};

/*
 * Mapping from Tcl result codes to strings; used for error and debugging
 * messages.
 */

#ifdef TCL_COMPILE_DEBUG
static char *resultStrings[] = {
    "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif

/*
 * These are used by evalstats to monitor object usage in Tcl.
 */

#ifdef TCL_COMPILE_STATS
long		tclObjsAlloced = 0;
long		tclObjsFreed   = 0;
#define TCL_MAX_SHARED_OBJ_STATS 5
long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */

/*









 * The new macro for ending an instruction; note that a reasonable C-optimiser

 * will resolve all branches at compile time. (result) is always a constant;
 * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved
 * at runtime for variable (nCleanup).
 *
 * ARGUMENTS:
 *    pcAdjustment: how much to increment pc
 *    nCleanup: how many objects to remove from the stack
 *    resultHandling: 0 indicates no object should be pushed on the stack;
 *	otherwise, push objResultPtr. If (result < 0), objResultPtr already
 *	has the correct reference count.
 */

#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
    if (nCleanup == 0) {\
	if (resultHandling != 0) {\
	    if ((resultHandling) > 0) {\
		PUSH_OBJECT(objResultPtr);\
	    } else {\
		*(++tosPtr) = objResultPtr;\
	    }\
	} \
	pc += (pcAdjustment);\
	goto cleanup0;\
    } else if (resultHandling != 0) {\
	if ((resultHandling) > 0) {\
	    Tcl_IncrRefCount(objResultPtr);\
	}\
	pc += (pcAdjustment);\
	switch (nCleanup) {\
	    case 1: goto cleanup1_pushObjResultPtr;\
	    case 2: goto cleanup2_pushObjResultPtr;\
	    default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\
	}\
    } else {\
	pc += (pcAdjustment);\
	switch (nCleanup) {\
	    case 1: goto cleanup1;\
	    case 2: goto cleanup2;\
	    default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\
	}\
    }

#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
    pc += (pcAdjustment);\
    cleanup = (nCleanup);\
    if (resultHandling) {\
	if ((resultHandling) > 0) {\
	    Tcl_IncrRefCount(objResultPtr);\
205
206
207
208
209
210
211
212

213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273

274
275
276
277
278
279
280
281
282

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

301
302
303
304

305
306
307
308
309
310
311
312
313
314
315
316
317
 * to TclExecuteByteCode.
 */

#define CACHE_STACK_INFO() \
    tosPtr = eePtr->tosPtr

#define DECACHE_STACK_INFO() \
    eePtr->tosPtr = tosPtr



/*
 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 * increments the object's ref count since it makes the stack have another
 * reference pointing to the object. However, POP_OBJECT does not decrement
 * the ref count. This is because the stack may hold the only reference to
 * the object, so the object would be destroyed if its ref count were
 * decremented before the caller had a chance to, e.g., store it in a
 * variable. It is the caller's responsibility to decrement the ref count
 * when it is finished with an object.
 *
 * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
 * macro. The actual parameter might be an expression with side effects,
 * and this ensures that it will be executed only once. 
 */
    
#define PUSH_OBJECT(objPtr) \
    Tcl_IncrRefCount(*(++tosPtr) = (objPtr))
    
#define POP_OBJECT() \
    *(tosPtr--)

/*
 * Macros used to trace instruction execution. The macros TRACE,
 * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
 * O2S is only used in TRACE* calls to get a string from an object.
 */

#ifdef TCL_COMPILE_DEBUG
#   define TRACE(a) \
    if (traceInstructions) { \
        fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
               (tosPtr - eePtr->stackPtr), \
	       (unsigned int)(pc - codePtr->codeStart), \
	       GetOpcodeName(pc)); \
	printf a; \
    }
#   define TRACE_APPEND(a) \
    if (traceInstructions) { \
	printf a; \
    }
#   define TRACE_WITH_OBJ(a, objPtr) \
    if (traceInstructions) { \
        fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
               (tosPtr - eePtr->stackPtr), \
	       (unsigned int)(pc - codePtr->codeStart), \
	       GetOpcodeName(pc)); \
	printf a; \
        TclPrintObject(stdout, objPtr, 30); \
        fprintf(stdout, "\n"); \
    }
#   define O2S(objPtr) \
    (objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
#   define TRACE(a)
#   define TRACE_APPEND(a) 
#   define TRACE_WITH_OBJ(a, objPtr)
#   define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */


/*
 * Macro to read a string containing either a wide or an int and
 * decide which it is while decoding it at the same time.  This
 * enforces the policy that integer constants between LONG_MIN and
 * LONG_MAX (inclusive) are represented by normal longs, and integer
 * constants outside that range are represented by wide ints.
 *
 * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
 * generates an error message.

 */
#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar)	\
    (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar));	\
    if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN)	\
	    && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) {			\
	(objPtr)->typePtr = &tclIntType;				\
	(objPtr)->internalRep.longValue = (longVar)			\
		= Tcl_WideAsLong(wideVar);				\
    }
#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar)		\
    (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr),	\
	    &(wideVar));						\
    if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN)	\
	    && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) {			\
	(objPtr)->typePtr = &tclIntType;				\
	(objPtr)->internalRep.longValue = (longVar)			\
		= Tcl_WideAsLong(wideVar);				\
    }

/*
 * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
 * an obj.
 */

#define FORCE_LONG(objPtr, longVar, wideVar)				\
    if ((objPtr)->typePtr == &tclWideIntType) {				\
	(longVar) = Tcl_WideAsLong(wideVar);				\
    }
#define IS_INTEGER_TYPE(typePtr)					\
	((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
#define IS_NUMERIC_TYPE(typePtr)					\
	(IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)

#define W0	Tcl_LongAsWide(0)
/*
 * For tracing that uses wide values.
 */







|
>






|
|
|
|
|


|
|

|


|





|
|





|
|
|
|








|
|
|
|

|
|





|




>

|
|
|
|
|



>


















>

|
<

>





|







193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294

295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
 * to TclExecuteByteCode.
 */

#define CACHE_STACK_INFO() \
    tosPtr = eePtr->tosPtr

#define DECACHE_STACK_INFO() \
    eePtr->tosPtr = tosPtr;\
    checkInterp = 1


/*
 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 * increments the object's ref count since it makes the stack have another
 * reference pointing to the object. However, POP_OBJECT does not decrement
 * the ref count. This is because the stack may hold the only reference to the
 * object, so the object would be destroyed if its ref count were decremented
 * before the caller had a chance to, e.g., store it in a variable. It is the
 * caller's responsibility to decrement the ref count when it is finished with
 * an object.
 *
 * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
 * macro. The actual parameter might be an expression with side effects, and
 * this ensures that it will be executed only once.
 */

#define PUSH_OBJECT(objPtr) \
    Tcl_IncrRefCount(*(++tosPtr) = (objPtr))

#define POP_OBJECT() \
    *(tosPtr--)

/*
 * Macros used to trace instruction execution. The macros TRACE,
 * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.  O2S is
 * only used in TRACE* calls to get a string from an object.
 */

#ifdef TCL_COMPILE_DEBUG
#   define TRACE(a) \
    if (traceInstructions) { \
	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
		(tosPtr - eePtr->stackPtr), \
		(unsigned int)(pc - codePtr->codeStart), \
		GetOpcodeName(pc)); \
	printf a; \
    }
#   define TRACE_APPEND(a) \
    if (traceInstructions) { \
	printf a; \
    }
#   define TRACE_WITH_OBJ(a, objPtr) \
    if (traceInstructions) { \
	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
		(tosPtr - eePtr->stackPtr), \
		(unsigned int)(pc - codePtr->codeStart), \
		GetOpcodeName(pc)); \
	printf a; \
	TclPrintObject(stdout, objPtr, 30); \
	fprintf(stdout, "\n"); \
    }
#   define O2S(objPtr) \
    (objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
#   define TRACE(a)
#   define TRACE_APPEND(a)
#   define TRACE_WITH_OBJ(a, objPtr)
#   define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */

#if 0
/*
 * Macro to read a string containing either a wide or an int and decide which
 * it is while decoding it at the same time.  This enforces the policy that
 * integer constants between LONG_MIN and LONG_MAX (inclusive) are represented
 * by normal longs, and integer constants outside that range are represented
 * by wide ints.
 *
 * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
 * generates an error message.
 * 
 */
#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar)	\
    (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar));	\
    if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN)	\
	    && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) {			\
	(objPtr)->typePtr = &tclIntType;				\
	(objPtr)->internalRep.longValue = (longVar)			\
		= Tcl_WideAsLong(wideVar);				\
    }
#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar)		\
    (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr),	\
	    &(wideVar));						\
    if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN)	\
	    && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) {			\
	(objPtr)->typePtr = &tclIntType;				\
	(objPtr)->internalRep.longValue = (longVar)			\
		= Tcl_WideAsLong(wideVar);				\
    }
#endif
/*
 * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from an obj.

 */
#if 0
#define FORCE_LONG(objPtr, longVar, wideVar)				\
    if ((objPtr)->typePtr == &tclWideIntType) {				\
	(longVar) = Tcl_WideAsLong(wideVar);				\
    }
#define IS_INTEGER_TYPE(typePtr)					\
	((typePtr) == &tclIntType || (typePtr) == &tclWideIntType || (typePtr) == &tclBignumType)
#define IS_NUMERIC_TYPE(typePtr)					\
	(IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)

#define W0	Tcl_LongAsWide(0)
/*
 * For tracing that uses wide values.
 */
333
334
335
336
337
338
339
























































































340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522





523
524
525
526
527
528
529
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr)			\
    if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
	(doubleVar) = (double) (objPtr)->internalRep.longValue;		\
    } else {								\
	(doubleVar) = (objPtr)->internalRep.doubleValue;		\
    }
#endif /* TCL_WIDE_INT_IS_LONG */

























































































/*
 * Declarations for local procedures to this file:
 */

static int		TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
			    ByteCode *codePtr));
static int		ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj **objv));
static int		ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
static int		ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj **tosPtr, ClientData clientData));
#ifdef TCL_COMPILE_STATS
static int              EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
static char *		GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
#endif /* TCL_COMPILE_DEBUG */
static ExceptionRange *	GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
			    int catchOnly, ByteCode* codePtr));
static char *		GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
        		    ByteCode* codePtr, int *lengthPtr));
static void		GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void		IllegalExprOperandType _ANSI_ARGS_((
			    Tcl_Interp *interp, unsigned char *pc,
			    Tcl_Obj *opndPtr));
static void		InitByteCodeExecution _ANSI_ARGS_((
			    Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void		PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static char *		StringForResultCode _ANSI_ARGS_((int result));
static void		ValidatePcAndStackTop _ANSI_ARGS_((
			    ByteCode *codePtr, unsigned char *pc,
			    int stackTop, int stackLowerBound, 
			    int checkStack));
#endif /* TCL_COMPILE_DEBUG */
static int		VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static Tcl_WideInt	ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2,
			    int *errExpon));
static long		ExponLong _ANSI_ARGS_((long i, long i2,
			    int *errExpon));

/*
 * Table describing the built-in math functions. Entries in this table are
 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte.
 */

BuiltinFunc tclBuiltinFuncTable[] = {
#ifndef TCL_NO_MATH
    {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
    {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
    {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
    {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
    {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
    {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
    {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
    {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
    {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
    {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
    {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
    {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
    {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
    {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
    {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
    {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
    {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
    {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
    {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
#endif
    {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
    {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
    {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
    {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0},	/* NOTE: rand takes no args. */
    {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
    {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
    {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
    {0},
};

/*
 *----------------------------------------------------------------------
 *
 * InitByteCodeExecution --
 *
 *	This procedure is called once to initialize the Tcl bytecode
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This procedure initializes the array of instruction names. If
 *	compiling with the TCL_COMPILE_STATS flag, it initializes the
 *	array that counts the executions of each instruction and it
 *	creates the "evalstats" command. It also establishes the link 
 *      between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
 *
 *----------------------------------------------------------------------
 */

static void
InitByteCodeExecution(interp)
    Tcl_Interp *interp;		/* Interpreter for which the Tcl variable
				 * "tcl_traceExec" is linked to control
				 * instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
    if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
		    TCL_LINK_INT) != TCL_OK) {
	Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
    }
#endif
#ifdef TCL_COMPILE_STATS    
    Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
	    (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateExecEnv --
 *
 *	This procedure creates a new execution environment for Tcl bytecode
 *	execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
 *	is typically created once for each Tcl interpreter (Interp
 *	structure) and recursively passed to TclExecuteByteCode to execute
 *	ByteCode sequences for nested commands.
 *
 * Results:
 *	A newly allocated ExecEnv is returned. This points to an empty
 *	evaluation stack of the standard initial size.
 *
 * Side effects:
 *	The bytecode interpreter is also initialized here, as this
 *	procedure will be called before any call to TclExecuteByteCode.
 *
 *----------------------------------------------------------------------
 */

#define TCL_STACK_INITIAL_SIZE 2000

ExecEnv *
TclCreateExecEnv(interp)
    Tcl_Interp *interp;		/* Interpreter for which the execution
				 * environment is being created. */
{
    ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
    Tcl_Obj **stackPtr;

    stackPtr = (Tcl_Obj **)
	ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));

    /*
     * Use the bottom pointer to keep a reference count; the 
     * execution environment holds a reference.
     */

    stackPtr++;
    eePtr->stackPtr = stackPtr;
    stackPtr[-1] = (Tcl_Obj *) ((char *) 1);

    eePtr->tosPtr = stackPtr - 1;
    eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2);






    Tcl_MutexLock(&execMutex);
    if (!execInitialized) {
	TclInitAuxDataTypeTable();
	InitByteCodeExecution(interp);
	execInitialized = 1;
    }







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|
|








|











|


|
<




|
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














|
|
|
|












|



|











|
|
|
|






|
|















|


|
|








>
>
>
>
>







325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426




















427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

454
455
456
457
458





459































460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr)			\
    if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
	(doubleVar) = (double) (objPtr)->internalRep.longValue;		\
    } else {								\
	(doubleVar) = (objPtr)->internalRep.doubleValue;		\
    }
#endif /* TCL_WIDE_INT_IS_LONG */
#endif

/*
 * Macro used in this file to save a function call for common uses of
 * TclGetNumberFromObj().  The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			ClientData *ptrPtr, int *tPtr);
 */

#ifdef TCL_WIDE_INT_IS_LONG

#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr)			\
    (((objPtr)->typePtr == &tclIntType)					\
	?	(*(tPtr) = TCL_NUMBER_LONG,				\
		*(ptrPtr) = (ClientData)				\
		    (&((objPtr)->internalRep.longValue)), TCL_OK) :	\
    ((objPtr)->typePtr == &tclDoubleType)				\
	?	(((TclIsNaN((objPtr)->internalRep.doubleValue))		\
		    ?	(*(tPtr) = TCL_NUMBER_NAN)			\
		    :	(*(tPtr) = TCL_NUMBER_DOUBLE)),			\
		*(ptrPtr) = (ClientData)				\
		    (&((objPtr)->internalRep.doubleValue)), TCL_OK) :	\
    TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))

#else

#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr)			\
    (((objPtr)->typePtr == &tclIntType)					\
	?	(*(tPtr) = TCL_NUMBER_LONG,				\
		*(ptrPtr) = (ClientData)				\
		    (&((objPtr)->internalRep.longValue)), TCL_OK) :	\
    ((objPtr)->typePtr == &tclWideIntType)				\
	?	(*(tPtr) = TCL_NUMBER_WIDE,				\
		*(ptrPtr) = (ClientData)				\
		    (&((objPtr)->internalRep.wideValue)), TCL_OK) :	\
    ((objPtr)->typePtr == &tclDoubleType)				\
	?	(((TclIsNaN((objPtr)->internalRep.doubleValue))		\
		    ?	(*(tPtr) = TCL_NUMBER_NAN)			\
		    :	(*(tPtr) = TCL_NUMBER_DOUBLE)),			\
		*(ptrPtr) = (ClientData)				\
		    (&((objPtr)->internalRep.doubleValue)), TCL_OK) :	\
    TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))

#endif

/*
 * Macro used in this file to save a function call for common uses of
 * Tcl_GetBooleanFromObj().  The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			int *boolPtr);
 */

#define TclGetBooleanFromObj(interp, objPtr, boolPtr)			\
    ((((objPtr)->typePtr == &tclIntType)				\
	|| ((objPtr)->typePtr == &tclIntType))				\
	? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK)	\
	: Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))

/*
 * Macro used in this file to save a function call for common uses of
 * Tcl_GetWideIntFromObj().  The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			Tcl_WideInt *wideIntPtr);
 */

#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr)		\
    (((objPtr)->typePtr == &tclIntType)					\
	? (*(wideIntPtr) = (Tcl_WideInt)				\
		((objPtr)->internalRep.longValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#else
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr)		\
    (((objPtr)->typePtr == &tclWideIntType)				\
	? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) :	\
    ((objPtr)->typePtr == &tclIntType)					\
	? (*(wideIntPtr) = (Tcl_WideInt)				\
		((objPtr)->internalRep.longValue), TCL_OK) :		\
	Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#endif

static Tcl_ObjType dictIteratorType = {
    "dictIterator",
    NULL, NULL, NULL, NULL
};

/*
 * Declarations for local procedures to this file:
 */

static int		TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
			    ByteCode *codePtr));




















#ifdef TCL_COMPILE_STATS
static int		EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
static char *		GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
#endif /* TCL_COMPILE_DEBUG */
static ExceptionRange *	GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
			    int catchOnly, ByteCode* codePtr));
static char *		GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
			    ByteCode* codePtr, int *lengthPtr));
static void		GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void		IllegalExprOperandType _ANSI_ARGS_((
			    Tcl_Interp *interp, unsigned char *pc,
			    Tcl_Obj *opndPtr));
static void		InitByteCodeExecution _ANSI_ARGS_((
			    Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void		PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static char *		StringForResultCode _ANSI_ARGS_((int result));
static void		ValidatePcAndStackTop _ANSI_ARGS_((
			    ByteCode *codePtr, unsigned char *pc,
			    int stackTop, int stackLowerBound,
			    int checkStack));
#endif /* TCL_COMPILE_DEBUG */
#if 0

static Tcl_WideInt	ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2,
			    int *errExpon));
static long		ExponLong _ANSI_ARGS_((long i, long i2,
			    int *errExpon));
#endif






































/*
 *----------------------------------------------------------------------
 *
 * InitByteCodeExecution --
 *
 *	This procedure is called once to initialize the Tcl bytecode
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This procedure initializes the array of instruction names. If
 *	compiling with the TCL_COMPILE_STATS flag, it initializes the array
 *	that counts the executions of each instruction and it creates the
 *	"evalstats" command. It also establishes the link between the Tcl
 *	"tcl_traceExec" and C "tclTraceExec" variables.
 *
 *----------------------------------------------------------------------
 */

static void
InitByteCodeExecution(interp)
    Tcl_Interp *interp;		/* Interpreter for which the Tcl variable
				 * "tcl_traceExec" is linked to control
				 * instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
    if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
	    TCL_LINK_INT) != TCL_OK) {
	Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
    }
#endif
#ifdef TCL_COMPILE_STATS
    Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
	    (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateExecEnv --
 *
 *	This procedure creates a new execution environment for Tcl bytecode
 *	execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is
 *	typically created once for each Tcl interpreter (Interp structure) and
 *	recursively passed to TclExecuteByteCode to execute ByteCode sequences
 *	for nested commands.
 *
 * Results:
 *	A newly allocated ExecEnv is returned. This points to an empty
 *	evaluation stack of the standard initial size.
 *
 * Side effects:
 *	The bytecode interpreter is also initialized here, as this procedure
 *	will be called before any call to TclExecuteByteCode.
 *
 *----------------------------------------------------------------------
 */

#define TCL_STACK_INITIAL_SIZE 2000

ExecEnv *
TclCreateExecEnv(interp)
    Tcl_Interp *interp;		/* Interpreter for which the execution
				 * environment is being created. */
{
    ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
    Tcl_Obj **stackPtr;

    stackPtr = (Tcl_Obj **)
	    ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));

    /*
     * Use the bottom pointer to keep a reference count; the execution
     * environment holds a reference.
     */

    stackPtr++;
    eePtr->stackPtr = stackPtr;
    stackPtr[-1] = (Tcl_Obj *) ((char *) 1);

    eePtr->tosPtr = stackPtr - 1;
    eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2);

    TclNewBooleanObj(eePtr->constants[0], 0);
    Tcl_IncrRefCount(eePtr->constants[0]);
    TclNewBooleanObj(eePtr->constants[1], 1);
    Tcl_IncrRefCount(eePtr->constants[1]);

    Tcl_MutexLock(&execMutex);
    if (!execInitialized) {
	TclInitAuxDataTypeTable();
	InitByteCodeExecution(interp);
	execInitialized = 1;
    }
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561


562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
 *
 *	Frees the storage for an ExecEnv.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Storage for an ExecEnv and its contained storage (e.g. the
 *	evaluation stack) is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteExecEnv(eePtr)
    ExecEnv *eePtr;		/* Execution environment to free. */
{
    if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
	ckfree((char *) (eePtr->stackPtr-1));
    } else {
	Tcl_Panic("ERROR: freeing an execEnv whose stack is still in use.\n");
    }


    ckfree((char *) eePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeExecution --
 *
 *	Finalizes the execution environment setup so that it can be
 *	later reinitialized.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	After this call, the next time TclCreateExecEnv will be called
 *	it will call InitByteCodeExecution.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeExecution()
{







|
|













>
>








|
|





|
|







568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
 *
 *	Frees the storage for an ExecEnv.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Storage for an ExecEnv and its contained storage (e.g. the evaluation
 *	stack) is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteExecEnv(eePtr)
    ExecEnv *eePtr;		/* Execution environment to free. */
{
    if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
	ckfree((char *) (eePtr->stackPtr-1));
    } else {
	Tcl_Panic("ERROR: freeing an execEnv whose stack is still in use.\n");
    }
    TclDecrRefCount(eePtr->constants[0]);
    TclDecrRefCount(eePtr->constants[1]);
    ckfree((char *) eePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeExecution --
 *
 *	Finalizes the execution environment setup so that it can be later
 *	reinitialized.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	After this call, the next time TclCreateExecEnv will be called it will
 *	call InitByteCodeExecution.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeExecution()
{
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656















































































657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713

714
715
716
717

718
719
720
721
722
723

724
725
726
727

728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
 *	The size of the evaluation stack is doubled.
 *
 *----------------------------------------------------------------------
 */

static void
GrowEvaluationStack(eePtr)
    register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
			      * stack to enlarge. */
{
    /*
     * The current Tcl stack elements are stored from *(eePtr->stackPtr)
     * to *(eePtr->endPtr) (inclusive).
     */

    int currElems = (eePtr->endPtr - eePtr->stackPtr + 1);
    int newElems  = 2*currElems;
    int currBytes = currElems * sizeof(Tcl_Obj *);
    int newBytes  = 2*currBytes;
    Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
    Tcl_Obj **oldStackPtr = eePtr->stackPtr;

    /*
     * We keep the stack reference count as a (char *), as that
     * works nicely as a portable pointer-sized counter.
     */

    char *refCount = (char *) oldStackPtr[-1];

    /*
     * Copy the existing stack items to the new stack space, free the old
     * storage if appropriate, and record the refCount of the new stack
     * held by the environment.
     */
 
    newStackPtr++;
    memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
	   (size_t) currBytes);

    if (refCount == (char *) 1) {
	ckfree((VOID *) (oldStackPtr-1));
    } else {
	/*
	 * Remove the reference corresponding to the
	 * environment pointer.
	 */
	
	oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
    }

    eePtr->stackPtr = newStackPtr;
    eePtr->endPtr = newStackPtr + (newElems - 2); /* index of last usable item */
    eePtr->tosPtr += (newStackPtr - oldStackPtr);
    newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);	















































































}

/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprObj --
 *
 *	Evaluate an expression in a Tcl_Obj.
 *
 * Results:
 *	A standard Tcl object result. If the result is other than TCL_OK,
 *	then the interpreter's result contains an error message. If the
 *	result is TCL_OK, then a pointer to the expression's result value
 *	object is stored in resultPtrPtr. In that case, the object's ref
 *	count is incremented to reflect the reference returned to the
 *	caller; the caller is then responsible for the resulting object
 *	and must, for example, decrement the ref count when it is finished
 *	with the object.
 *
 * Side effects:
 *	Any side effects caused by subcommands in the expression, if any.
 *	The interpreter result is not modified unless there is an error.
 *
 *--------------------------------------------------------------
 */

int
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    register Tcl_Obj *objPtr;	/* Points to Tcl object containing
				 * expression to evaluate. */
    Tcl_Obj **resultPtrPtr;	/* Where the Tcl_Obj* that is the expression
				 * result is stored if no errors occur. */
{
    Interp *iPtr = (Interp *) interp;
    CompileEnv compEnv;		/* Compilation environment structure
				 * allocated in frame. */
    LiteralTable *localTablePtr = &(compEnv.localLitTable);
    register ByteCode *codePtr = NULL;
    				/* Tcl Internal type of bytecode.
				 * Initialized to avoid compiler warning. */
    AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    Tcl_Obj *saveObjPtr;
    char *string;
    int length, i, result;

    /*
     * First handle some common expressions specially.
     */

    string = Tcl_GetStringFromObj(objPtr, &length);
    if (length == 1) {
	if (*string == '0') {
	    *resultPtrPtr = Tcl_NewLongObj(0);
	    Tcl_IncrRefCount(*resultPtrPtr);

	    return TCL_OK;
	} else if (*string == '1') {
	    *resultPtrPtr = Tcl_NewLongObj(1);
	    Tcl_IncrRefCount(*resultPtrPtr);

	    return TCL_OK;
	}
    } else if ((length == 2) && (*string == '!')) {
	if (*(string+1) == '0') {
	    *resultPtrPtr = Tcl_NewLongObj(1);
	    Tcl_IncrRefCount(*resultPtrPtr);

	    return TCL_OK;
	} else if (*(string+1) == '1') {
	    *resultPtrPtr = Tcl_NewLongObj(0);
	    Tcl_IncrRefCount(*resultPtrPtr);

	    return TCL_OK;
	}
    }

    /*
     * Get the ByteCode from the object. If it exists, make sure it hasn't
     * been invalidated by, e.g., someone redefining a command with a
     * compile procedure (this might make the compiled code wrong). If
     * necessary, convert the object to be a ByteCode object and compile it.
     * Also, if the code was compiled in/for a different interpreter, we
     * recompile it.
     *
     * Precompiled expressions, however, are immutable and therefore
     * they are not recompiled, even if the epoch has changed.
     *
     */

    if (objPtr->typePtr == &tclByteCodeType) {
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
	    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {







|
|


|
|










|
|






|
|

|








|
<

|






|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










|
|
|
|
|
|
|
<


|
|








|
|




|
|


|
|


|










|
|
>


|
|
>




|
|
>


|
|
>






|
|
|
|
<

|
|
<







633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676

677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781

782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848

849
850
851

852
853
854
855
856
857
858
 *	The size of the evaluation stack is doubled.
 *
 *----------------------------------------------------------------------
 */

static void
GrowEvaluationStack(eePtr)
    register ExecEnv *eePtr;	/* Points to the ExecEnv with an evaluation
				 * stack to enlarge. */
{
    /*
     * The current Tcl stack elements are stored from *(eePtr->stackPtr) to
     * *(eePtr->endPtr) (inclusive).
     */

    int currElems = (eePtr->endPtr - eePtr->stackPtr + 1);
    int newElems  = 2*currElems;
    int currBytes = currElems * sizeof(Tcl_Obj *);
    int newBytes  = 2*currBytes;
    Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
    Tcl_Obj **oldStackPtr = eePtr->stackPtr;

    /*
     * We keep the stack reference count as a (char *), as that works nicely
     * as a portable pointer-sized counter.
     */

    char *refCount = (char *) oldStackPtr[-1];

    /*
     * Copy the existing stack items to the new stack space, free the old
     * storage if appropriate, and record the refCount of the new stack held
     * by the environment.
     */

    newStackPtr++;
    memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
	   (size_t) currBytes);

    if (refCount == (char *) 1) {
	ckfree((VOID *) (oldStackPtr-1));
    } else {
	/*
	 * Remove the reference corresponding to the environment pointer.

	 */

	oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
    }

    eePtr->stackPtr = newStackPtr;
    eePtr->endPtr = newStackPtr + (newElems - 2); /* index of last usable item */
    eePtr->tosPtr += (newStackPtr - oldStackPtr);
    newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
}

/*
 *--------------------------------------------------------------
 *
 * TclStackAlloc --
 *
 *	Allocate memory from the execution stack; it has to be returned later
 *	with a call to TclStackFree
 *
 * Results:
 *	A pointer to the first byte allocated, or panics if the allocation did
 *	not succeed.
 *
 * Side effects:
 *	The execution stack may be grown.
 *
 *--------------------------------------------------------------
 */

char *
TclStackAlloc(interp, numBytes)
    Tcl_Interp *interp;
    int numBytes;
{
    Interp *iPtr = (Interp *) interp;
    ExecEnv *eePtr = iPtr->execEnvPtr;
    int numWords;
    Tcl_Obj **tosPtr = eePtr->tosPtr;
    char **stackRefCountPtr;

    /*
     * Add two words to store
     *   - a pointer to the used execution stack
     *   - the number of words reserved
     * These will be used later by TclStackFree.
     */

    numWords = (numBytes + 3*sizeof(void *) - 1)/sizeof(void *);

    while ((tosPtr + numWords) > eePtr->endPtr) {
	GrowEvaluationStack(eePtr);
	tosPtr = eePtr->tosPtr;
    }

    /*
     * Increase the stack's reference count, to make sure it is not freed
     * prematurely.
     */

    stackRefCountPtr = (char **) (eePtr->stackPtr-1);
    ++*stackRefCountPtr;

    /*
     * Reserve the space in the exec stack, and store the data for freeing.
     */

    eePtr->tosPtr += numWords;
    *(eePtr->tosPtr-1) = (Tcl_Obj *) stackRefCountPtr;
    *(eePtr->tosPtr)   = (Tcl_Obj *) numWords;

    return (char *) (tosPtr+1);
}

void
TclStackFree(interp)
    Tcl_Interp *interp;
{
    Interp *iPtr = (Interp *) interp;
    ExecEnv *eePtr = iPtr->execEnvPtr;
    char **stackRefCountPtr;

    stackRefCountPtr = (char **) *(eePtr->tosPtr-1);
    eePtr->tosPtr -= (int) *(eePtr->tosPtr);

    --*stackRefCountPtr;
    if (*stackRefCountPtr == (char *) 0) {
	ckfree((VOID *) stackRefCountPtr);
    }
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprObj --
 *
 *	Evaluate an expression in a Tcl_Obj.
 *
 * Results:
 *	A standard Tcl object result. If the result is other than TCL_OK, then
 *	the interpreter's result contains an error message. If the result is
 *	TCL_OK, then a pointer to the expression's result value object is
 *	stored in resultPtrPtr. In that case, the object's ref count is
 *	incremented to reflect the reference returned to the caller; the
 *	caller is then responsible for the resulting object and must, for
 *	example, decrement the ref count when it is finished with the object.

 *
 * Side effects:
 *	Any side effects caused by subcommands in the expression, if any. The
 *	interpreter result is not modified unless there is an error.
 *
 *--------------------------------------------------------------
 */

int
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
    Tcl_Interp *interp;		/* Context in which to evaluate the
				 * expression. */
    register Tcl_Obj *objPtr;	/* Points to Tcl object containing expression
				 * to evaluate. */
    Tcl_Obj **resultPtrPtr;	/* Where the Tcl_Obj* that is the expression
				 * result is stored if no errors occur. */
{
    Interp *iPtr = (Interp *) interp;
    CompileEnv compEnv;		/* Compilation environment structure allocated
				 * in frame. */
    LiteralTable *localTablePtr = &(compEnv.localLitTable);
    register ByteCode *codePtr = NULL;
    				/* Tcl Internal type of bytecode.  Initialized
				 * to avoid compiler warning. */
    AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    Tcl_Obj *saveObjPtr, *resultPtr;
    char *string;
    int length, i, result;

    /*
     * First handle some common expressions specially.
     */

    string = Tcl_GetStringFromObj(objPtr, &length);
    if (length == 1) {
	if (*string == '0') {
	    TclNewBooleanObj(resultPtr, 0);
	    Tcl_IncrRefCount(resultPtr);
	    *resultPtrPtr = resultPtr;
	    return TCL_OK;
	} else if (*string == '1') {
	    TclNewBooleanObj(resultPtr, 1);
	    Tcl_IncrRefCount(resultPtr);
	    *resultPtrPtr = resultPtr;
	    return TCL_OK;
	}
    } else if ((length == 2) && (*string == '!')) {
	if (*(string+1) == '0') {
	    TclNewBooleanObj(resultPtr, 1);
	    Tcl_IncrRefCount(resultPtr);
	    *resultPtrPtr = resultPtr;
	    return TCL_OK;
	} else if (*(string+1) == '1') {
	    TclNewBooleanObj(resultPtr, 0);
	    Tcl_IncrRefCount(resultPtr);
	    *resultPtrPtr = resultPtr;
	    return TCL_OK;
	}
    }

    /*
     * Get the ByteCode from the object. If it exists, make sure it hasn't
     * been invalidated by, e.g., someone redefining a command with a compile
     * procedure (this might make the compiled code wrong). If necessary,
     * convert the object to be a ByteCode object and compile it.  Also, if
     * the code was compiled in/for a different interpreter, we recompile it.

     *
     * Precompiled expressions, however, are immutable and therefore they are
     * not recompiled, even if the epoch has changed.

     */

    if (objPtr->typePtr == &tclByteCodeType) {
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
	    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
	}
    }
    if (objPtr->typePtr != &tclByteCodeType) {
	TclInitCompileEnv(interp, &compEnv, string, length);
	result = TclCompileExpr(interp, string, length, &compEnv);

	/*
	 * Free the compilation environment's literal table bucket array if
	 * it was dynamically allocated. 
	 */

	if (localTablePtr->buckets != localTablePtr->staticBuckets) {
	    ckfree((char *) localTablePtr->buckets);
	}
    
	if (result != TCL_OK) {
	    /*
	     * Compilation errors. Free storage allocated for compilation.
	     */

#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(&compEnv);







|
|





|







867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
	}
    }
    if (objPtr->typePtr != &tclByteCodeType) {
	TclInitCompileEnv(interp, &compEnv, string, length);
	result = TclCompileExpr(interp, string, length, &compEnv);

	/*
	 * Free the compilation environment's literal table bucket array if it
	 * was dynamically allocated.
	 */

	if (localTablePtr->buckets != localTablePtr->staticBuckets) {
	    ckfree((char *) localTablePtr->buckets);
	}

	if (result != TCL_OK) {
	    /*
	     * Compilation errors. Free storage allocated for compilation.
	     */

#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(&compEnv);
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
		auxDataPtr++;
	    }
	    TclFreeCompileEnv(&compEnv);
	    return result;
	}

	/*
	 * Successful compilation. If the expression yielded no
	 * instructions, push an zero object as the expression's result.
	 */
	    
	if (compEnv.codeNext == compEnv.codeStart) {
	    TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
		    &compEnv);
	}

	/*
	 * Add a "done" instruction as the last instruction and change the
	 * object into a ByteCode object. Ownership of the literal objects
	 * and aux data items is given to the ByteCode object.
	 */

	TclEmitOpcode(INST_DONE, &compEnv);
	TclInitByteCodeObj(objPtr, &compEnv);
	TclFreeCompileEnv(&compEnv);
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceCompile == 2) {
	    TclPrintByteCodeObj(interp, objPtr);
	}
#endif /* TCL_COMPILE_DEBUG */
    }

    /*
     * Execute the expression after first saving the interpreter's result.
     */
    
    saveObjPtr = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(saveObjPtr);
    Tcl_ResetResult(interp);

    /*
     * Increment the code's ref count while it is being executed. If
     * afterwards no references to it remain, free the code.
     */
    
    codePtr->refCount++;
    result = TclExecuteByteCode(interp, codePtr);
    codePtr->refCount--;
    if (codePtr->refCount <= 0) {
	TclCleanupByteCode(codePtr);
	objPtr->typePtr = NULL;
	objPtr->internalRep.otherValuePtr = NULL;
    }
    
    /*
     * If the expression evaluated successfully, store a pointer to its
     * value object in resultPtrPtr then restore the old interpreter result.
     * We increment the object's ref count to reflect the reference that we
     * are returning to the caller. We also decrement the ref count of the
     * interpreter's result object after calling Tcl_SetResult since we
     * next store into that field directly.
     */
    
    if (result == TCL_OK) {
	*resultPtrPtr = iPtr->objResultPtr;
	Tcl_IncrRefCount(iPtr->objResultPtr);
	
	Tcl_SetObjResult(interp, saveObjPtr);
    }
    TclDecrRefCount(saveObjPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompEvalObj --
 *
 *	This procedure evaluates the script contained in a Tcl_Obj by 
 *      first compiling it and then passing it to TclExecuteByteCode.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h
 *	(such as TCL_OK), and interp->objResultPtr refers to a Tcl object
 *	that either contains the result of executing the code or an
 *	error message.
 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */








|
|

|

|





|
|
















|








|








|

|
|
|
|
|
|

|



|











|
|


|
|
|
<







904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989

990
991
992
993
994
995
996
		auxDataPtr++;
	    }
	    TclFreeCompileEnv(&compEnv);
	    return result;
	}

	/*
	 * Successful compilation. If the expression yielded no instructions,
	 * push an zero object as the expression's result.
	 */

	if (compEnv.codeNext == compEnv.codeStart) {
	    TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
		    &compEnv);
	}

	/*
	 * Add a "done" instruction as the last instruction and change the
	 * object into a ByteCode object. Ownership of the literal objects and
	 * aux data items is given to the ByteCode object.
	 */

	TclEmitOpcode(INST_DONE, &compEnv);
	TclInitByteCodeObj(objPtr, &compEnv);
	TclFreeCompileEnv(&compEnv);
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceCompile == 2) {
	    TclPrintByteCodeObj(interp, objPtr);
	}
#endif /* TCL_COMPILE_DEBUG */
    }

    /*
     * Execute the expression after first saving the interpreter's result.
     */

    saveObjPtr = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(saveObjPtr);
    Tcl_ResetResult(interp);

    /*
     * Increment the code's ref count while it is being executed. If
     * afterwards no references to it remain, free the code.
     */

    codePtr->refCount++;
    result = TclExecuteByteCode(interp, codePtr);
    codePtr->refCount--;
    if (codePtr->refCount <= 0) {
	TclCleanupByteCode(codePtr);
	objPtr->typePtr = NULL;
	objPtr->internalRep.otherValuePtr = NULL;
    }

    /*
     * If the expression evaluated successfully, store a pointer to its value
     * object in resultPtrPtr then restore the old interpreter result.  We
     * increment the object's ref count to reflect the reference that we are
     * returning to the caller. We also decrement the ref count of the
     * interpreter's result object after calling Tcl_SetResult since we next
     * store into that field directly.
     */

    if (result == TCL_OK) {
	*resultPtrPtr = iPtr->objResultPtr;
	Tcl_IncrRefCount(iPtr->objResultPtr);

	Tcl_SetObjResult(interp, saveObjPtr);
    }
    TclDecrRefCount(saveObjPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompEvalObj --
 *
 *	This procedure evaluates the script contained in a Tcl_Obj by first
 *	compiling it and then passing it to TclExecuteByteCode.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h (such as
 *	TCL_OK), and interp->objResultPtr refers to a Tcl object that either
 *	contains the result of executing the code or an error message.

 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */

908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955

    if (iPtr->varFramePtr != NULL) {
	namespacePtr = iPtr->varFramePtr->nsPtr;
    } else {
	namespacePtr = iPtr->globalNsPtr;
    }

    /* 
     * If the object is not already of tclByteCodeType, compile it (and
     * reset the compilation flags in the interpreter; this should be 
     * done after any compilation).
     * Otherwise, check that it is "fresh" enough.
     */

    if (objPtr->typePtr != &tclByteCodeType) {
      recompileObj:
	iPtr->errorLine = 1; 
	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    iPtr->numLevels--;
	    return result;
	}
	iPtr->evalFlags = 0;
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
    } else {
	/*
	 * Make sure the Bytecode hasn't been invalidated by, e.g., someone 
	 * redefining a command with a compile procedure (this might make the 
	 * compiled code wrong). 
	 * The object needs to be recompiled if it was compiled in/for a 
	 * different interpreter, or for a different namespace, or for the 
	 * same namespace but with different name resolution rules. 
	 * Precompiled objects, however, are immutable and therefore
	 * they are not recompiled, even if the epoch has changed.
	 *
	 * To be pedantically correct, we should also check that the
	 * originating procPtr is the same as the current context procPtr
	 * (assuming one exists at all - none for global level).  This
	 * code is #def'ed out because [info body] was changed to never
	 * return a bytecode type object, which should obviate us from
	 * the extra checks here.
	 */
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION	/* [Bug: 3412 Pedantic] */
		|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
			iPtr->varFramePtr->procPtr == codePtr->procPtr))







|
|
|
<
|



|
|





<



|
|
|
<
|
|
|
|



|
|
|
|







1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036

1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060

    if (iPtr->varFramePtr != NULL) {
	namespacePtr = iPtr->varFramePtr->nsPtr;
    } else {
	namespacePtr = iPtr->globalNsPtr;
    }

    /*
     * If the object is not already of tclByteCodeType, compile it (and reset
     * the compilation flags in the interpreter; this should be done after any

     * compilation).  Otherwise, check that it is "fresh" enough.
     */

    if (objPtr->typePtr != &tclByteCodeType) {
    recompileObj:
	iPtr->errorLine = 1;
	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    iPtr->numLevels--;
	    return result;
	}

	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
    } else {
	/*
	 * Make sure the Bytecode hasn't been invalidated by, e.g., someone
	 * redefining a command with a compile procedure (this might make the
	 * compiled code wrong).  The object needs to be recompiled if it was

	 * compiled in/for a different interpreter, or for a different
	 * namespace, or for the same namespace but with different name
	 * resolution rules.  Precompiled objects, however, are immutable and
	 * therefore they are not recompiled, even if the epoch has changed.
	 *
	 * To be pedantically correct, we should also check that the
	 * originating procPtr is the same as the current context procPtr
	 * (assuming one exists at all - none for global level).  This code is
	 * #def'ed out because [info body] was changed to never return a
	 * bytecode type object, which should obviate us from the extra checks
	 * here.
	 */
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION	/* [Bug: 3412 Pedantic] */
		|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
			iPtr->varFramePtr->procPtr == codePtr->procPtr))
985
986
987
988
989
990
991









































































992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042


1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206

1207
1208
1209
1210

1211
1212
1213
1214

1215
1216
1217
1218

1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230


1231
1232
1233
1234
1235
1236
1237


1238
1239














1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264



1265
1266










1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287

1288

1289



1290
1291
1292
1293



1294
1295
1296
1297

1298
1299
1300

1301
1302
1303















1304

1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442

1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596

1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643

1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663

1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883























































































































1884













































































































1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150

2151

2152
2153

2154
2155


2156
2157
2158
2159
2160
2161
2162
2163
2164

2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185




2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201

2202




2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225

2226
2227
2228
2229
2230
2231
2232
2233

2234




2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250

2251
2252
2253
2254
2255
2256
2257
2258

2259




2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274

2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286

2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303

2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323








2324
2325
2326
2327
2328

2329

2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364

2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386



2387
2388
2389

2390


2391

2392

2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420

2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449

2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568

2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603

2604
2605
2606
2607
2608
2609

2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620

2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636

2637
2638
2639
2640
2641
2642
2643

2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654

2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685

2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
    iPtr->numLevels--;
    return result;
}

/*
 *----------------------------------------------------------------------
 *









































































 * TclExecuteByteCode --
 *
 *	This procedure executes the instructions of a ByteCode structure.
 *	It returns when a "done" instruction is executed or an error occurs.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h
 *	(such as TCL_OK), and interp->objResultPtr refers to a Tcl object
 *	that either contains the result of executing the code or an
 *	error message.
 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */
 
static int
TclExecuteByteCode(interp, codePtr)
    Tcl_Interp *interp;		/* Token for command interpreter. */
    ByteCode *codePtr;		/* The bytecode sequence to interpret. */
{
    /*
     * Compiler cast directive - not a real variable.
     *     Interp *iPtr = (Interp *) interp;
     */
#define iPtr ((Interp *) interp)

    /*
     * Constants: variables that do not change during the execution,
     * used sporadically.
     */

    ExecEnv *eePtr;             /* Points to the execution environment. */
    int initStackTop;           /* Stack top at start of execution. */
    int initCatchTop;           /* Catch stack top at start of execution. */
    Var *compiledLocals;
    Namespace *namespacePtr;

    /*
     * Globals: variables that store state, must remain valid at
     * all times.
     */
    
    int catchTop;
    register Tcl_Obj **tosPtr;  /* Cached pointer to top of evaluation stack. */
    register unsigned char *pc = codePtr->codeStart;
				/* The current program counter. */
    int instructionCount = 0;	/* Counter that is used to work out
				 * when to call Tcl_AsyncReady() */
    Tcl_Obj *expandNestList = NULL;



    /*
     * Transfer variables - needed only between opcodes, but not
     * while executing an instruction.
     */

    register int cleanup;
    Tcl_Obj *objResultPtr;

    
    /*
     * Result variable - needed only when going to checkForcatch or
     * other error handlers; also used as local in some opcodes.
     */

    int result = TCL_OK;	/* Return code returned after execution. */

    /*
     * Locals - variables that are used within opcodes or bounded sections
     * of the file (jumps between opcodes within a family).
     * NOTE: These are now defined locally where needed.
     */

#ifdef TCL_COMPILE_DEBUG
    int traceInstructions = (tclTraceExec == 3);
    char cmdNameBuf[21];
#endif

    /*
     * The execution uses a unified stack: first the catch stack, immediately
     * above it the execution stack.
     *
     * Make sure the catch stack is large enough to hold the maximum number
     * of catch commands that could ever be executing at the same time (this
     * will be no more than the exception range array's depth).
     * Make sure the execution stack is large enough to execute this ByteCode.
     */

    eePtr = iPtr->execEnvPtr;
    initCatchTop = eePtr->tosPtr - eePtr->stackPtr;
    catchTop = initCatchTop;
    tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth;

    while ((tosPtr + codePtr->maxStackDepth) > eePtr->endPtr) {
        GrowEvaluationStack(eePtr); 
	tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth;
    }
    initStackTop = tosPtr - eePtr->stackPtr;

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 2) {
	PrintByteCodeInfo(codePtr);
	fprintf(stdout, "  Starting stack top=%d\n", initStackTop);
	fflush(stdout);
    }
#endif
    
#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    if (iPtr->varFramePtr != NULL) {
        namespacePtr = iPtr->varFramePtr->nsPtr;
	compiledLocals = iPtr->varFramePtr->compiledLocals;
    } else {
        namespacePtr = iPtr->globalNsPtr;
	compiledLocals = NULL;
    }

    /*
     * Loop executing instructions until a "done" instruction, a 
     * TCL_RETURN, or some error.
     */

    goto cleanup0;

    
    /*
     * Targets for standard instruction endings; unrolled
     * for speed in the most frequent cases (instructions that 
     * consume up to two stack elements).
     *
     * This used to be a "for(;;)" loop, with each instruction doing
     * its own cleanup.
     */
    
    {
	Tcl_Obj *valuePtr;
	
	cleanupV_pushObjResultPtr:
	switch (cleanup) {
	    case 0:
		*(++tosPtr) = (objResultPtr);
		goto cleanup0;
	    default:
		cleanup -= 2;
		while (cleanup--) {
		    valuePtr = POP_OBJECT();
		    TclDecrRefCount(valuePtr);
		}
	    case 2: 
	    cleanup2_pushObjResultPtr:
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    case 1: 
	    cleanup1_pushObjResultPtr:
		valuePtr = *tosPtr;
		TclDecrRefCount(valuePtr);
	}
	*tosPtr = objResultPtr;
	goto cleanup0;
	
	cleanupV:
	switch (cleanup) {
	    default:
		cleanup -= 2;
		while (cleanup--) {
		    valuePtr = POP_OBJECT();
		    TclDecrRefCount(valuePtr);
		}
	    case 2: 
	    cleanup2:
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    case 1: 
	    cleanup1:
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    case 0:
		/*
		 * We really want to do nothing now, but this is needed
		 * for some compilers (SunPro CC)
		 */
		break;
	}
    }
    cleanup0:
    
#ifdef TCL_COMPILE_DEBUG
    /*
     * Skip the stack depth check if an expansion is in progress
     */

    ValidatePcAndStackTop(codePtr, pc, (tosPtr - eePtr->stackPtr),
            initStackTop, /*checkStack*/ (expandNestList == NULL));
    if (traceInstructions) {
	fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (tosPtr - eePtr->stackPtr));
	TclPrintInstruction(codePtr, pc);
	fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */
    
#ifdef TCL_COMPILE_STATS    
    iPtr->stats.instructionCount[*pc]++;
#endif

    /*
     * Check for asynchronous handlers [Bug 746722]; we
     * do the check every ASYNC_CHECK_COUNT_MASK instruction,
     * of the form (2**n-1).
     */

    if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
	if (Tcl_AsyncReady()) {

	    DECACHE_STACK_INFO();
	    result = Tcl_AsyncInvoke(interp, result);
	    CACHE_STACK_INFO();
	    if (result == TCL_ERROR) {

		goto checkForCatch;
	    }
	}
	if (Tcl_LimitReady(interp)) {

	    DECACHE_STACK_INFO();
	    result = Tcl_LimitCheck(interp);
	    CACHE_STACK_INFO();
	    if (result == TCL_ERROR) {

		goto checkForCatch;
	    }
	}
    }

    switch (*pc) {
    case INST_RETURN:
	{
	    int code = TclGetInt4AtPtr(pc+1);
	    int level = TclGetUInt4AtPtr(pc+5);
	    Tcl_Obj *returnOpts = POP_OBJECT();



	    result = TclProcessReturn(interp, code, level, returnOpts);
	    Tcl_DecrRefCount(returnOpts);
	    if (result != TCL_OK) {
		Tcl_SetObjResult(interp, *tosPtr);
		cleanup = 1;
		goto processExceptionReturn;
	    }


	    NEXT_INST_F(9, 0, 0);
	}















    case INST_DONE:
	if (tosPtr <= eePtr->stackPtr + initStackTop) {
	    tosPtr--;
	    goto abnormalReturn;
	}
	
	/*
	 * Set the interpreter's object result to point to the 
	 * topmost object from the stack, and check for a possible
	 * [catch]. The stackTop's level and refCount will be handled 
	 * by "processCatch" or "abnormalReturn".
	 */

	Tcl_SetObjResult(interp, *tosPtr);
#ifdef TCL_COMPILE_DEBUG	    
	TRACE_WITH_OBJ(("=> return code=%d, result=", result),
	        iPtr->objResultPtr);
	if (traceInstructions) {
	    fprintf(stdout, "\n");
	}
#endif
	goto checkForCatch;
	
    case INST_PUSH1:



	objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
	TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);










	NEXT_INST_F(2, 0, 1);

    case INST_PUSH4:
	objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
	TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
	NEXT_INST_F(5, 0, 1);

    case INST_POP:
        {
	    Tcl_Obj *valuePtr;
	    
	    TRACE_WITH_OBJ(("=> discarding "), *tosPtr);
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	}

	/*
	 * Runtime peephole optimisation: an INST_POP is scheduled
	 * at the end of most commands. If the next instruction is an
	 * INST_START_CMD, fall through to it.
	 */

	pc++;

	if (*pc != INST_START_CMD) {	



	    NEXT_INST_F(0, 0, 0);
	}
	
    case INST_START_CMD:



	/*
	 * Remark that if the interpreter is marked for deletion
	 * its compileEpoch is modified, so that the epoch
	 * check also verifies that the interp is not deleted.

	 */

	iPtr->cmdCount++;

	if (((codePtr->compileEpoch == iPtr->compileEpoch)
		    && (codePtr->nsEpoch == namespacePtr->resolverEpoch))
		|| (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {















	    NEXT_INST_F(5, 0, 0);

	} else {
	    char *bytes;
	    int length, opnd;
	    Tcl_Obj *newObjResultPtr;
	    
	    bytes = GetSrcInfoForPc(pc, codePtr, &length);
	    DECACHE_STACK_INFO();	    
	    result = Tcl_EvalEx(interp, bytes, length, 0);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		cleanup = 0;
		goto processExceptionReturn;
	    }
	    opnd = TclGetUInt4AtPtr(pc+1);
	    objResultPtr = Tcl_GetObjResult(interp);
	    {
		TclNewObj(newObjResultPtr);
		Tcl_IncrRefCount(newObjResultPtr);
		iPtr->objResultPtr = newObjResultPtr;
	    }
	    NEXT_INST_V(opnd, 0, -1);
	}
	
    case INST_DUP:
	objResultPtr = *tosPtr;
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(1, 0, 1);

    case INST_OVER:
        {
	    int opnd;
	    
	    opnd = TclGetUInt4AtPtr(pc+1);
	    objResultPtr = *(tosPtr - opnd);
	    TRACE_WITH_OBJ(("=> "), objResultPtr);
	    NEXT_INST_F(5, 0, 1);
	}

    case INST_CONCAT1:
	{
	    int opnd, length, appendLen = 0;
	    char *bytes, *p;		
	    Tcl_Obj **currPtr;
	    
	    opnd = TclGetUInt1AtPtr(pc+1);

	    /*
	     * Compute the length to be appended.
	     */
	    
	    for (currPtr = tosPtr - (opnd-2); currPtr <= tosPtr; 
		     currPtr++) {
		bytes = Tcl_GetStringFromObj(*currPtr, &length);
		if (bytes != NULL) {
		    appendLen += length;
		}
	    }

	    /*
	     * If nothing is to be appended, just return the first
	     * object by dropping all the others from the stack; this
	     * saves both the computation and copy of the string rep
	     * of the first object, enabling the fast '$x[set x {}]'
	     * idiom for 'K $x [set x{}]'.
	     */

	    if (appendLen == 0) {
		TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
		NEXT_INST_V(2, (opnd-1), 0);
	    }

	    /*
	     * If the first object is shared, we need a new obj for
	     * the result; otherwise, we can reuse the first object.
	     * In any case, make sure it has enough room to accomodate
	     * all the concatenated bytes. Note that if it is unshared
	     * its bytes are already copied by Tcl_SetObjectLength, so
	     * that we set the loop parameters to avoid copying them
	     * again: p points to the end of the already copied bytes,
	     * currPtr to the second object.
	     */
	    
	    objResultPtr = *(tosPtr-(opnd-1));
	    bytes = Tcl_GetStringFromObj(objResultPtr, &length);
#if !TCL_COMPILE_DEBUG
	    if (!Tcl_IsShared(objResultPtr)) {
		Tcl_SetObjLength(objResultPtr, (length + appendLen));
		p = TclGetString(objResultPtr) + length;
		currPtr = tosPtr - (opnd - 2);
	    } else {
#endif
		p = (char *) ckalloc((unsigned) (length + appendLen + 1));
		TclNewObj(objResultPtr);
		objResultPtr->bytes = p;
		objResultPtr->length = length + appendLen;
		currPtr = tosPtr - (opnd - 1);
#if !TCL_COMPILE_DEBUG
	    } 
#endif

	    /*
	     * Append the remaining characters.
	     */

	    for (; currPtr <= tosPtr; currPtr++) {
		bytes = Tcl_GetStringFromObj(*currPtr, &length);
		if (bytes != NULL) {
		    memcpy((VOID *) p, (VOID *) bytes,
			    (size_t) length);
		    p += length;
		}
	    }
	    *p = '\0';
		
	    TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	    NEXT_INST_V(2, opnd, 1);
	}

    case INST_EXPAND_START:
	/*
	 * Push an element to the expandNestList. This records
	 * the current tosPtr - i.e., the point in the stack
	 * where the expanded command starts.
	 *
	 * Use a Tcl_Obj as linked list element; slight mem waste,
	 * but faster allocation than ckalloc. This also abuses
	 * the Tcl_Obj structure, as we do not define a special
	 * tclObjType for it. It is not dangerous as the obj is
	 * never passed anywhere, so that all manipulations are
	 * performed here and in INST_INVOKE_EXPANDED (in case of
	 * an expansion error, also in INST_EXPAND_STKTOP).
	 */

        {
	    Tcl_Obj *objPtr;

	    TclNewObj(objPtr);
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) (tosPtr - eePtr->stackPtr);

	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList;
	    expandNestList = objPtr;
	    NEXT_INST_F(1, 0, 0);
	}

    case INST_EXPAND_STKTOP:
	{  
	    int objc, length, i;
	    Tcl_Obj **objv, *valuePtr, *objPtr;

	    /*
	     * Make sure that the element at stackTop is a list; if not,
	     * remove the element from the expand link list and leave.
	     */
	    

	    valuePtr = *tosPtr;
	    result = Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv);
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
	        	Tcl_GetObjResult(interp));
		objPtr = expandNestList;
		expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
		TclDecrRefCount(objPtr);
		goto checkForCatch;
	    }
	    tosPtr--;

	    /*
	     * Make sure there is enough room in the stack to expand
	     * this list *and* process the rest of the command (at least
	     * up to the next argument expansion or command end).
	     * The operand is the current stack depth, as seen by the 
	     * compiler.
	     */ 

	    length = objc + codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1);
	    while ((tosPtr + length) > eePtr->endPtr) {
		DECACHE_STACK_INFO();
		GrowEvaluationStack(eePtr); 
		CACHE_STACK_INFO();
	    }
	    
	    /*
	     * Expand the list at stacktop onto the stack; free the list.
	     */

	    for (i = 0; i < objc; i++) {
		PUSH_OBJECT(objv[i]);
	    }
	    TclDecrRefCount(valuePtr);
	    NEXT_INST_F(5, 0, 0);
	}

    {
	/*
	 * INVOCATION BLOCK
	 */
	
	int objc, pcAdjustment;
	
	case INST_INVOKE_EXPANDED:
            {
		Tcl_Obj *objPtr;
		
		objPtr = expandNestList;
		expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
		objc = tosPtr - eePtr->stackPtr 
		        - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;
		TclDecrRefCount(objPtr);
	    }
		
	    if (objc == 0) {
		/* 
		 * Nothing was expanded, return {}.
		 */
		
		TclNewObj(objResultPtr);
		NEXT_INST_F(1, 0, 1);
	    }
	    
	    pcAdjustment = 1;
	    goto doInvocation;
	    
	case INST_INVOKE_STK4:
	    objc = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doInvocation;
	    
	case INST_INVOKE_STK1:
	    objc = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    
	doInvocation:
	    {
		Tcl_Obj **objv = (tosPtr - (objc-1));
		int length;
		char *bytes;
		
		/*
		 * We keep the stack reference count as a (char *), as that
		 * works nicely as a portable pointer-sized counter.
		 */
		
		char **preservedStackRefCountPtr;
		
#ifdef TCL_COMPILE_DEBUG
		if (tclTraceExec >= 2) {
		    int i;

		    if (traceInstructions) {
			strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
			TRACE(("%u => call ", objc));
		    } else {
			fprintf(stdout, "%d: (%u) invoking ",
				iPtr->numLevels,
				(unsigned int)(pc - codePtr->codeStart));
		    }
		    for (i = 0;  i < objc;  i++) {
			TclPrintObject(stdout, objv[i], 15);
			fprintf(stdout, " ");
		    }
		    fprintf(stdout, "\n");
		    fflush(stdout);
		}
#endif /*TCL_COMPILE_DEBUG*/
		
		/* 
		 * If trace procedures will be called, we need a
		 * command string to pass to TclEvalObjvInternal; note 
		 * that a copy of the string will be made there to 
		 * include the ending \0.
		 */
		
		bytes = NULL;
		length = 0;
		if (iPtr->tracePtr != NULL) {
		    Trace *tracePtr, *nextTracePtr;
		    
		    for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
			    tracePtr = nextTracePtr) {
			nextTracePtr = tracePtr->nextPtr;
			if (tracePtr->level == 0 ||
				iPtr->numLevels <= tracePtr->level) {
			    /*
			     * Traces will be called: get command string
			     */
			    
			    bytes = GetSrcInfoForPc(pc, codePtr, &length);
			    break;
			}
		    }
		} else {		
		    Command *cmdPtr;

		    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
		    if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
			bytes = GetSrcInfoForPc(pc, codePtr, &length);
		    }
		}		
		
		/*
		 * A reference to part of the stack vector itself
		 * escapes our control: increase its refCount
		 * to stop it from being deallocated by a recursive
		 * call to ourselves.  The extra variable is needed
		 * because all others are liable to change due to the
		 * trace procedures.
		 */
		
		preservedStackRefCountPtr = (char **) (eePtr->stackPtr-1);
		++*preservedStackRefCountPtr;
		
		/*
		 * Reset the instructionCount variable, since we're about
		 * to check for async stuff anyway while processing
		 * TclEvalObjvInternal.
		 */
		
		instructionCount = 1;
		
		/*
		 * Finally, let TclEvalObjvInternal handle the command. 
		 */
		
		DECACHE_STACK_INFO();
		Tcl_ResetResult(interp);
		result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
		CACHE_STACK_INFO();
		
		/*
		 * If the old stack is going to be released, it is
		 * safe to do so now, since no references to objv are
		 * going to be used from now on.
		 */
		
		--*preservedStackRefCountPtr;
		if (*preservedStackRefCountPtr == (char *) 0) {
		    ckfree((VOID *) preservedStackRefCountPtr);
		}	    
		
		if (result == TCL_OK) {

		    /*
		     * Push the call's object result and continue execution
		     * with the next instruction.
		     */
		    
		    TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
			    objc, cmdNameBuf), Tcl_GetObjResult(interp));
		    
		    objResultPtr = Tcl_GetObjResult(interp);
		    
		    /*
		     * Reset the interp's result to avoid possible duplications
		     * of large objects [Bug 781585]. We do not call
		     * Tcl_ResetResult() to avoid any side effects caused by
		     * the resetting of errorInfo and errorCode [Bug 804681], 
		     * which are not needed here. We chose instead to manipulate
		     * the interp's object result directly.
		     *
		     * Note that the result object is now in objResultPtr, it
		     * keeps the refCount it had in its role of iPtr->objResultPtr.

		     */
		    {
			Tcl_Obj *objPtr;
			
			TclNewObj(objPtr);
			Tcl_IncrRefCount(objPtr);
			iPtr->objResultPtr = objPtr;
		    }
		    
		    NEXT_INST_V(pcAdjustment, objc, -1);
		} else {
		    cleanup = objc;
		    goto processExceptionReturn;
		}
	    }
    }
	

    case INST_EVAL_STK:
	/*
	 * Note to maintainers: it is important that INST_EVAL_STK
	 * pop its argument from the stack before jumping to
	 * checkForCatch! DO NOT OPTIMISE!
	 */

        {
	    Tcl_Obj *objPtr;
	    
	    objPtr = *tosPtr;
	    DECACHE_STACK_INFO();
	    result = TclCompEvalObj(interp, objPtr);
	    CACHE_STACK_INFO();
	    if (result == TCL_OK) {
		/*
		 * Normal return; push the eval's object result.
		 */
		
		objResultPtr = Tcl_GetObjResult(interp);
		TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
			Tcl_GetObjResult(interp));
		
		/*
		 * Reset the interp's result to avoid possible duplications
		 * of large objects [Bug 781585]. We do not call
		 * Tcl_ResetResult() to avoid any side effects caused by
		 * the resetting of errorInfo and errorCode [Bug 804681], 
		 * which are not needed here. We chose instead to manipulate
		 * the interp's object result directly.
		 *
		 * Note that the result object is now in objResultPtr, it
		 * keeps the refCount it had in its role of iPtr->objResultPtr.
		 */

		TclNewObj(objPtr);
		Tcl_IncrRefCount(objPtr);
		iPtr->objResultPtr = objPtr;
		NEXT_INST_F(1, 1, -1);
	    } else {
		cleanup = 1;
		goto processExceptionReturn;
	    }
	}

    case INST_EXPR_STK:
        {
	    Tcl_Obj *objPtr, *valuePtr;
	    
	    objPtr = *tosPtr;
	    DECACHE_STACK_INFO();
	    Tcl_ResetResult(interp);
	    result = Tcl_ExprObj(interp, objPtr, &valuePtr);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
			Tcl_GetObjResult(interp));
		goto checkForCatch;
	    }
	    objResultPtr = valuePtr;
	    TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
	    NEXT_INST_F(1, 1, -1); /* already has right refct */
	}

    /*
     * ---------------------------------------------------------
     *     Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!
     * The different instructions set the value of some variables
     * and then jump to somme common execution code.
     */
    {
	int opnd, pcAdjustment; 
	char *part1, *part2;
	Var *varPtr, *arrayPtr;
	Tcl_Obj *objPtr;

	case INST_LOAD_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    varPtr = &(compiledLocals[opnd]);
	    part1 = varPtr->name;
	    while (TclIsVarLink(varPtr)) {
		varPtr = varPtr->value.linkPtr;
	    }
	    TRACE(("%u => ", opnd));
	    if (TclIsVarDirectReadable(varPtr)) {
		/*
		 * No errors, no traces: just get the value.
		 */
		objResultPtr = varPtr->value.objPtr;
		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
		NEXT_INST_F(2, 0, 1);
	    }
	    pcAdjustment = 2;
	    cleanup = 0;
	    arrayPtr = NULL;
	    part2 = NULL;
	    goto doCallPtrGetVar;

	case INST_LOAD_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    varPtr = &(compiledLocals[opnd]);
	    part1 = varPtr->name;
	    while (TclIsVarLink(varPtr)) {
		varPtr = varPtr->value.linkPtr;
	    }
	    TRACE(("%u => ", opnd));
	    if (TclIsVarDirectReadable(varPtr)) {
		/*
		 * No errors, no traces: just get the value.
		 */
		objResultPtr = varPtr->value.objPtr;
		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
		NEXT_INST_F(5, 0, 1);
	    }
	    pcAdjustment = 5;
	    cleanup = 0;
	    arrayPtr = NULL;
	    part2 = NULL;
	    goto doCallPtrGetVar;

	case INST_LOAD_ARRAY_STK:
	    cleanup = 2;
	    part2 = Tcl_GetString(*tosPtr);  /* element name */
	    objPtr = *(tosPtr - 1); /* array name */
	    TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
	    goto doLoadStk;
	    
	case INST_LOAD_STK:
	case INST_LOAD_SCALAR_STK:
	    cleanup = 1;
	    part2 = NULL;
	    objPtr = *tosPtr; /* variable name */
	    TRACE(("\"%.30s\" => ", O2S(objPtr)));

	doLoadStk:
	    part1 = TclGetString(objPtr);
	    varPtr = TclObjLookupVar(interp, objPtr, part2, 
		    TCL_LEAVE_ERR_MSG, "read",
		    /*createPart1*/ 0,
		    /*createPart2*/ 1, &arrayPtr);
	    if (varPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    if (TclIsVarDirectReadable(varPtr)
		    && ((arrayPtr == NULL) 
			    || TclIsVarUntraced(arrayPtr))) {
		/*
		 * No errors, no traces: just get the value.
		 */
		objResultPtr = varPtr->value.objPtr;
		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
		NEXT_INST_V(1, cleanup, 1);
	    }
	    pcAdjustment = 1;
	    goto doCallPtrGetVar;
	    
	case INST_LOAD_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doLoadArray;
	    
	case INST_LOAD_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    
	doLoadArray:
	    part2 = TclGetString(*tosPtr);
	    arrayPtr = &(compiledLocals[opnd]);
	    part1 = arrayPtr->name;
	    while (TclIsVarLink(arrayPtr)) {
		arrayPtr = arrayPtr->value.linkPtr;
	    }
	    TRACE(("%u \"%.30s\" => ", opnd, part2));
	    varPtr = TclLookupArrayElement(interp, part1, part2, 
		    TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
	    if (varPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    if (TclIsVarDirectReadable(varPtr)
		    && ((arrayPtr == NULL) 
			    || TclIsVarUntraced(arrayPtr))) {
		/*
		 * No errors, no traces: just get the value.
		 */
		objResultPtr = varPtr->value.objPtr;
		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
		NEXT_INST_F(pcAdjustment, 1, 1);
	    }
	    cleanup = 1;
	    goto doCallPtrGetVar;
	    
	doCallPtrGetVar:
	    /*
	     * There are either errors or the variable is traced:
	     * call TclPtrGetVar to process fully.
	     */























































































































	    













































































































	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, 
		    part2, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_V(pcAdjustment, cleanup, 1);
    }
	
    /*
     *     End of INST_LOAD instructions.
     * ---------------------------------------------------------
     */

    /*
     * ---------------------------------------------------------
     *     Start of INST_STORE and related instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!
     * The different instructions set the value of some variables
     * and then jump to somme common execution code.
     */

    {
	int opnd, pcAdjustment, storeFlags; 
	char *part1, *part2;
	Var *varPtr, *arrayPtr;
	Tcl_Obj *objPtr, *valuePtr;

	case INST_LAPPEND_STK:
	    valuePtr = *tosPtr; /* value to append */
	    part2 = NULL;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		    | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	    goto doStoreStk;

	case INST_LAPPEND_ARRAY_STK:
	    valuePtr = *tosPtr; /* value to append */
	    part2 = TclGetString(*(tosPtr - 1));
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		    | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	    goto doStoreStk;
	    
	case INST_APPEND_STK:
	    valuePtr = *tosPtr; /* value to append */
	    part2 = NULL;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    goto doStoreStk;
	    
	case INST_APPEND_ARRAY_STK:
	    valuePtr = *tosPtr; /* value to append */
	    part2 = TclGetString(*(tosPtr - 1));
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    goto doStoreStk;
	    
	case INST_STORE_ARRAY_STK:
	    valuePtr = *tosPtr;
	    part2 = TclGetString(*(tosPtr - 1));
	    storeFlags = TCL_LEAVE_ERR_MSG;
	    goto doStoreStk;

	case INST_STORE_STK:
	case INST_STORE_SCALAR_STK:
	    valuePtr = *tosPtr;
	    part2 = NULL;
	    storeFlags = TCL_LEAVE_ERR_MSG;
	    
	doStoreStk:
	    objPtr = *(tosPtr - 1 - (part2 != NULL)); /* variable name */
	    part1 = TclGetString(objPtr);
#ifdef TCL_COMPILE_DEBUG
	    if (part2 == NULL) {
		TRACE(("\"%.30s\" <- \"%.30s\" =>", 
			      part1, O2S(valuePtr)));
	    } else {
		TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
			      part1, part2, O2S(valuePtr)));
	    }
#endif
	    varPtr = TclObjLookupVar(interp, objPtr, part2, 
		    TCL_LEAVE_ERR_MSG, "set",
		    /*createPart1*/ 1,
		    /*createPart2*/ 1, &arrayPtr);
	    if (varPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    cleanup = ((part2 == NULL)? 2 : 3);
	    pcAdjustment = 1;
	    goto doCallPtrSetVar;
	    
	case INST_LAPPEND_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		    | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	    goto doStoreArray;
	    
	case INST_LAPPEND_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		    | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	    goto doStoreArray;
	    
	case INST_APPEND_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    goto doStoreArray;
	    
	case INST_APPEND_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    goto doStoreArray;
	    
	case INST_STORE_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    storeFlags = TCL_LEAVE_ERR_MSG;
	    goto doStoreArray;
	    
	case INST_STORE_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    storeFlags = TCL_LEAVE_ERR_MSG;
	    
	doStoreArray:
	    valuePtr = *tosPtr;
	    part2 = TclGetString(*(tosPtr - 1));
	    arrayPtr = &(compiledLocals[opnd]);
	    part1 = arrayPtr->name;
	    TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
			  opnd, part2, O2S(valuePtr)));
	    while (TclIsVarLink(arrayPtr)) {
		arrayPtr = arrayPtr->value.linkPtr;
	    }
	    varPtr = TclLookupArrayElement(interp, part1, part2, 
		    TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
	    if (varPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    cleanup = 2;
	    goto doCallPtrSetVar;
	    
	case INST_LAPPEND_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		    | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	    goto doStoreScalar;
	    
	case INST_LAPPEND_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;	    
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		    | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	    goto doStoreScalar;
	    
	case INST_APPEND_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    goto doStoreScalar;
	    
	case INST_APPEND_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;	    
	    storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    goto doStoreScalar;
	    
	case INST_STORE_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    storeFlags = TCL_LEAVE_ERR_MSG;
	    goto doStoreScalar;
	    
	case INST_STORE_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    storeFlags = TCL_LEAVE_ERR_MSG;
	    
	doStoreScalar:
	    valuePtr = *tosPtr;
	    varPtr = &(compiledLocals[opnd]);
	    part1 = varPtr->name;
	    TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
	    while (TclIsVarLink(varPtr)) {
		varPtr = varPtr->value.linkPtr;
	    }
	    cleanup = 1;
	    arrayPtr = NULL;
	    part2 = NULL;
	    
	doCallPtrSetVar:
	    if ((storeFlags == TCL_LEAVE_ERR_MSG)
		    && TclIsVarDirectWritable(varPtr)
		    && ((arrayPtr == NULL) 
			    || TclIsVarUntraced(arrayPtr))) {
		/*
		 * No traces, no errors, plain 'set': we can safely inline.
		 * The value *will* be set to what's requested, so that 
		 * the stack top remains pointing to the same Tcl_Obj.
		 */
		valuePtr = varPtr->value.objPtr;
		objResultPtr = *tosPtr;
		if (valuePtr != objResultPtr) {
		    if (valuePtr != NULL) {
			TclDecrRefCount(valuePtr);
		    } else {
			TclSetVarScalar(varPtr);
			TclClearVarUndefined(varPtr);
		    }
		    varPtr->value.objPtr = objResultPtr;
		    Tcl_IncrRefCount(objResultPtr);
		}
#ifndef TCL_COMPILE_DEBUG
		if (*(pc+pcAdjustment) == INST_POP) {
		    NEXT_INST_V((pcAdjustment+1), cleanup, 0);
		}
#else
		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
		NEXT_INST_V(pcAdjustment, cleanup, 1);
	    } else {
		DECACHE_STACK_INFO();
		objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, 
			part1, part2, valuePtr, storeFlags);
		CACHE_STACK_INFO();
		if (objResultPtr == NULL) {
		    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		    result = TCL_ERROR;
		    goto checkForCatch;
		}
	    }
#ifndef TCL_COMPILE_DEBUG
	    if (*(pc+pcAdjustment) == INST_POP) {
		NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	    }
#endif
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_V(pcAdjustment, cleanup, 1);
    }

    /*
     *     End of INST_STORE and related instructions.
     * ---------------------------------------------------------
     */

    /*
     * ---------------------------------------------------------
     *     Start of INST_INCR instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!
     * The different instructions set the value of some variables
     * and then jump to somme common execution code.
     */


     {

	 Tcl_Obj *objPtr;
	 int opnd, pcAdjustment, isWide;

	 long i;
	 Tcl_WideInt w;


	 char *part1, *part2;
	 Var *varPtr, *arrayPtr;
	 
	 case INST_INCR_SCALAR1:
	 case INST_INCR_ARRAY1:
	 case INST_INCR_ARRAY_STK:
	 case INST_INCR_SCALAR_STK:
	 case INST_INCR_STK:
	     opnd = TclGetUInt1AtPtr(pc+1);

	     objPtr = *tosPtr;
	     if (objPtr->typePtr == &tclIntType) {
		 i = objPtr->internalRep.longValue;
		 isWide = 0;
	     } else if (objPtr->typePtr == &tclWideIntType) {
		 i = 0; /* lint */
		 w = objPtr->internalRep.wideValue;
		 isWide = 1;
	     } else {
		 i = 0; /* lint */
		 REQUIRE_WIDE_OR_INT(result, objPtr, i, w);
		 if (result != TCL_OK) {
		     TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
			     opnd, O2S(objPtr)), Tcl_GetObjResult(interp));
		     Tcl_AddErrorInfo(interp, "\n    (reading increment)");
		     goto checkForCatch;
		 }
		 isWide = (objPtr->typePtr == &tclWideIntType);
	     }
	     tosPtr--;
	     TclDecrRefCount(objPtr);




	     switch (*pc) {
		 case INST_INCR_SCALAR1:
		     pcAdjustment = 2;
		     goto doIncrScalar;
		 case INST_INCR_ARRAY1:
		     pcAdjustment = 2;
		     goto doIncrArray;
		 default:
		     pcAdjustment = 1;
		     goto doIncrStk;
	     }
	     
	 case INST_INCR_ARRAY_STK_IMM:
	 case INST_INCR_SCALAR_STK_IMM:
	 case INST_INCR_STK_IMM:
	     i = TclGetInt1AtPtr(pc+1);

	     isWide = 0;




	     pcAdjustment = 2;
	     
	 doIncrStk:
	     if ((*pc == INST_INCR_ARRAY_STK_IMM) 
		     || (*pc == INST_INCR_ARRAY_STK)) {
		 part2 = TclGetString(*tosPtr);
		 objPtr = *(tosPtr - 1);
		 TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
			       O2S(objPtr), part2, i));
	     } else {
		 part2 = NULL;
		 objPtr = *tosPtr;
		 TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
	     }
	     part1 = TclGetString(objPtr);
	     
	     varPtr = TclObjLookupVar(interp, objPtr, part2, 
		     TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
	     if (varPtr == NULL) {
		 Tcl_AddObjErrorInfo(interp,
			 "\n    (reading value of variable to increment)", -1);
		 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		 result = TCL_ERROR;

		 goto checkForCatch;
	     }
	     cleanup = ((part2 == NULL)? 1 : 2);
	     goto doIncrVar;
	     
	 case INST_INCR_ARRAY1_IMM:
	     opnd = TclGetUInt1AtPtr(pc+1);
	     i = TclGetInt1AtPtr(pc+2);

	     isWide = 0;




	     pcAdjustment = 3;
	     
	 doIncrArray:
	     part2 = TclGetString(*tosPtr);
	     arrayPtr = &(compiledLocals[opnd]);
	     part1 = arrayPtr->name;
	     while (TclIsVarLink(arrayPtr)) {
		 arrayPtr = arrayPtr->value.linkPtr;
	     }
	     TRACE(("%u \"%.30s\" (by %ld) => ",
			   opnd, part2, i));
	     varPtr = TclLookupArrayElement(interp, part1, part2, 
		     TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
	     if (varPtr == NULL) {
		 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		 result = TCL_ERROR;

		 goto checkForCatch;
	     }
	     cleanup = 1;
	     goto doIncrVar;
	     
	 case INST_INCR_SCALAR1_IMM:
	     opnd = TclGetUInt1AtPtr(pc+1);
	     i = TclGetInt1AtPtr(pc+2);

	     isWide = 0;




	     pcAdjustment = 3;
	     
	 doIncrScalar:
	     varPtr = &(compiledLocals[opnd]);
	     part1 = varPtr->name;
	     while (TclIsVarLink(varPtr)) {
		 varPtr = varPtr->value.linkPtr;
	     }
	     arrayPtr = NULL;
	     part2 = NULL;
	     cleanup = 0;
	     TRACE(("%u %ld => ", opnd, i));
	     
		
	 doIncrVar:

	     objPtr = varPtr->value.objPtr;
	     if (TclIsVarDirectReadable(varPtr)
		     && ((arrayPtr == NULL) 
			     || TclIsVarUntraced(arrayPtr))) {
		 if (objPtr->typePtr == &tclIntType && !isWide) {
		     /*
		      * No errors, no traces, the variable already has an
		      * integer value: inline processing.
		      */
		     
		     i += objPtr->internalRep.longValue;
		     if (Tcl_IsShared(objPtr)) {

			 objResultPtr = Tcl_NewLongObj(i);
			 TclDecrRefCount(objPtr);
			 Tcl_IncrRefCount(objResultPtr);
			 varPtr->value.objPtr = objResultPtr;
		     } else {
			 Tcl_SetLongObj(objPtr, i);
			 objResultPtr = objPtr;
		     }
		     goto doneIncr;
		 } else if (objPtr->typePtr == &tclWideIntType && isWide) {
		     /*
		      * No errors, no traces, the variable already has a
		      * wide integer value: inline processing.
		      */
			
		     w += objPtr->internalRep.wideValue;
		     if (Tcl_IsShared(objPtr)) {

			 objResultPtr = Tcl_NewWideIntObj(w);
			 TclDecrRefCount(objPtr);
			 Tcl_IncrRefCount(objResultPtr);
			 varPtr->value.objPtr = objResultPtr;
		     } else {
			 Tcl_SetWideIntObj(objPtr, w);
			 objResultPtr = objPtr;
		     }
		     goto doneIncr;
		 }
	     }
	     DECACHE_STACK_INFO();
	     if (isWide) {
		 objResultPtr = TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, 
			 part2, w, TCL_LEAVE_ERR_MSG);
	     } else {
		 objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, 
			 part2, i, TCL_LEAVE_ERR_MSG);
	     }
	     CACHE_STACK_INFO();








	     if (objResultPtr == NULL) {
		 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		 result = TCL_ERROR;
		 goto checkForCatch;
	     }

	 doneIncr:

	     TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
	     if (*(pc+pcAdjustment) == INST_POP) {
		 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	     }
#endif
	     NEXT_INST_V(pcAdjustment, cleanup, 1);
     }	    	    

    /*
     *     End of INST_INCR instructions.
     * ---------------------------------------------------------
     */

    case INST_JUMP1:
        {
	    int opnd;
	    
	    opnd = TclGetInt1AtPtr(pc+1);
	    TRACE(("%d => new pc %u\n", opnd,
			  (unsigned int)(pc + opnd - codePtr->codeStart)));
	    NEXT_INST_F(opnd, 0, 0);
	}

    case INST_JUMP4:
       {
	   int opnd;
	   
	   opnd = TclGetInt4AtPtr(pc+1);
	   TRACE(("%d => new pc %u\n", opnd,
			 (unsigned int)(pc + opnd - codePtr->codeStart)));
	   NEXT_INST_F(opnd, 0, 0);
       }

    {

	int trueJmp, falseJmp;
	
	
	case INST_JUMP_FALSE4:
	    trueJmp = 5;              
	    falseJmp = TclGetInt4AtPtr(pc+1);
	    goto doJumpTrue;
	    
	case INST_JUMP_TRUE4:
	    trueJmp = TclGetInt4AtPtr(pc+1);
	    falseJmp = 5;
	    goto doJumpTrue;
	    
	case INST_JUMP_FALSE1:
	    trueJmp = 2;
	    falseJmp = TclGetInt1AtPtr(pc+1);
	    goto doJumpTrue;

	case INST_JUMP_TRUE1:
	    trueJmp = TclGetInt1AtPtr(pc+1);
	    falseJmp = 2;
	    



	doJumpTrue:
	    {
		int b;

		Tcl_Obj *valuePtr;


		

		valuePtr = *tosPtr;


		/*
		 * The following will be partially resolved at compile 
		 * time and optimised away.
		 */
		if (((sizeof(long) == sizeof(int)) &&
			    (valuePtr->typePtr == &tclIntType))
			|| (valuePtr->typePtr == &tclBooleanType)) {
		    b = (int) valuePtr->internalRep.longValue;
		} else if ((sizeof(long) != sizeof(int)) &&
		        (valuePtr->typePtr == &tclIntType)) {
		    b = (valuePtr->internalRep.longValue != 0);
		} else if (valuePtr->typePtr == &tclDoubleType) {
		    b = (valuePtr->internalRep.doubleValue != 0.0);
		} else if (valuePtr->typePtr == &tclWideIntType) {
		    Tcl_WideInt w;

		    TclGetWide(w,valuePtr);
		    b = (w != W0);
		} else {
		     /*
		      * Taking b's address impedes it being a register
		      * variable (in gcc at least), so we avoid doing it.
		    
		      */
		    int b1;
		    result = Tcl_GetBooleanFromObj(interp, valuePtr, &b1);
		    if (result != TCL_OK) {

			if ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) {
			    trueJmp = falseJmp;
			}
			TRACE_WITH_OBJ(("%d => ERROR: ", trueJmp), Tcl_GetObjResult(interp));
			goto checkForCatch;
		    }
		    b = b1;
		}
#ifndef TCL_COMPILE_DEBUG
		NEXT_INST_F((b? trueJmp : falseJmp), 1, 0);
#else
		if (b) {
		    if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
			TRACE(("%d => %.20s true, new pc %u\n", trueJmp, O2S(valuePtr),
				      (unsigned int)(pc+trueJmp - codePtr->codeStart)));
		    } else {
			TRACE(("%d => %.20s true\n", falseJmp, O2S(valuePtr)));
		    }
		    NEXT_INST_F(trueJmp, 1, 0);
		} else {
		    if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
			TRACE(("%d => %.20s false\n", falseJmp, O2S(valuePtr)));
		    } else {
			TRACE(("%d => %.20s false, new pc %u\n", falseJmp, O2S(valuePtr),
				      (unsigned int)(pc + falseJmp - codePtr->codeStart)));
		    }
		    NEXT_INST_F(falseJmp, 1, 0);
		}
#endif

	    }
    }
	    	    
    /*
     * These two instructions are now redundant: the complete logic of the
     * LOR and LAND is now handled by the expression compiler.
     */

    case INST_LOR:
    case INST_LAND:
    {
	/*
	 * Operands must be boolean or numeric. No int->double
	 * conversions are performed.
	 */
		
	int i1, i2, length;
	int iResult;
	char *s;
	Tcl_ObjType *t1Ptr, *t2Ptr;
	Tcl_Obj *valuePtr, *value2Ptr;
	Tcl_WideInt w;
	
	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1);
	t1Ptr = valuePtr->typePtr;
	t2Ptr = value2Ptr->typePtr;

	if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
	    i1 = (valuePtr->internalRep.longValue != 0);
	} else if (t1Ptr == &tclWideIntType) {
	    TclGetWide(w,valuePtr);
	    i1 = (w != W0);
	} else if (t1Ptr == &tclDoubleType) {
	    i1 = (valuePtr->internalRep.doubleValue != 0.0);
	} else {
	    s = Tcl_GetStringFromObj(valuePtr, &length);
	    if (TclLooksLikeInt(s, length)) {
		long i = 0;
		
		GET_WIDE_OR_INT(result, valuePtr, i, w);
		if (valuePtr->typePtr == &tclIntType) {
		    i1 = (i != 0);
		} else {
		    i1 = (w != W0);
		}
	    } else {
		result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
					       valuePtr, &i1);
		i1 = (i1 != 0);
	    }
	    if (result != TCL_OK) {
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		        (t1Ptr? t1Ptr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	}
		
	if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
	    i2 = (value2Ptr->internalRep.longValue != 0);
	} else if (t2Ptr == &tclWideIntType) {
	    TclGetWide(w,value2Ptr);
	    i2 = (w != W0);
	} else if (t2Ptr == &tclDoubleType) {
	    i2 = (value2Ptr->internalRep.doubleValue != 0.0);
	} else {
	    s = Tcl_GetStringFromObj(value2Ptr, &length);
	    if (TclLooksLikeInt(s, length)) {
		long i = 0;
		
		GET_WIDE_OR_INT(result, value2Ptr, i, w);
		if (value2Ptr->typePtr == &tclIntType) {
		    i2 = (i != 0);
		} else {
		    i2 = (w != W0);
		}
	    } else {
		result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
	    }
	    if (result != TCL_OK) {
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
		        (t2Ptr? t2Ptr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);
		goto checkForCatch;
	    }
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */
	
	if (*pc == INST_LOR) {
	    iResult = (i1 || i2);
	} else {
	    iResult = (i1 && i2);
	}
	if (Tcl_IsShared(valuePtr)) {
	    objResultPtr = Tcl_NewLongObj(iResult);
	    TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
	    NEXT_INST_F(1, 2, 1);
	} else {	/* reuse the valuePtr object */
	    TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
	    Tcl_SetLongObj(valuePtr, iResult);
	    NEXT_INST_F(1, 1, 0);
	}
    }

    /*
     * ---------------------------------------------------------
     *     Start of INST_LIST and related instructions.
     */

    case INST_LIST:
        {
	    /*
	     * Pop the opnd (objc) top stack elements into a new list obj
	     * and then decrement their ref counts. 
	     */

	    int opnd;
	    
	    opnd = TclGetUInt4AtPtr(pc+1);
	    objResultPtr = Tcl_NewListObj(opnd, (tosPtr - (opnd-1)));
	    TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	    NEXT_INST_V(5, opnd, 1);
	}

    case INST_LIST_LENGTH:
        {
	    Tcl_Obj *valuePtr;
	    int length;
	    
	    valuePtr = *tosPtr;

	    result = Tcl_ListObjLength(interp, valuePtr, &length);
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		goto checkForCatch;
	    }
	    objResultPtr = Tcl_NewIntObj(length);
	    TRACE(("%.20s => %d\n", O2S(valuePtr), length));
	    NEXT_INST_F(1, 1, 1);
	}
	    
    case INST_LIST_INDEX:
        {
	    /*** lindex with objc == 3 ***/

	    Tcl_Obj *valuePtr, *value2Ptr;
	    
	    /*
	     * Pop the two operands
	     */

	    value2Ptr = *tosPtr;
	    valuePtr  = *(tosPtr - 1);
	    
	    /*
	     * Extract the desired list element
	     */

	    objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
	    if (objResultPtr == NULL) {
		TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
			Tcl_GetObjResult(interp));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    
	    /*
	     * Stash the list element on the stack
	     */

	    TRACE(("%.20s %.20s => %s\n",
			  O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
	    NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
	}

    case INST_LIST_INDEX_IMM:
    {
	/*** lindex with objc==3 and index in bytecode stream ***/

	int listc, idx, opnd;
	Tcl_Obj **listv;
	Tcl_Obj *valuePtr;
	
	/*
	 * Pop the list and get the index
	 */

	valuePtr = *tosPtr;
	opnd = TclGetInt4AtPtr(pc+1);

	/*
	 * Get the contents of the list, making sure that it
	 * really is a list in the process.
	 */

	result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
		    Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}

	/*
	 * Select the list item based on the index.  Negative
	 * operand == end-based indexing.
	 */

	if (opnd < -1) {
	    idx = opnd+1 + listc;
	} else {
	    idx = opnd;
	}
	if (idx >= 0 && idx < listc) {
	    objResultPtr = listv[idx];
	} else {
	    TclNewObj(objResultPtr);
	}

	TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr);
	NEXT_INST_F(5, 1, 1);
    }

    case INST_LIST_INDEX_MULTI:
    {
	/*
	 * 'lindex' with multiple index args:
	 *
	 * Determine the count of index args.
	 */

	int numIdx, opnd;

	opnd = TclGetUInt4AtPtr(pc+1);
	numIdx = opnd-1;

	/*
	 * Do the 'lindex' operation.
	 */

	objResultPtr = TclLindexFlat(interp, *(tosPtr - numIdx),
	        numIdx, tosPtr - numIdx + 1);

	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */
	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
	NEXT_INST_V(5, opnd, -1);
    }

    case INST_LSET_FLAT:
    {
	/*
	 * Lset with 3, 5, or more args.  Get the number
	 * of index args.
	 */
	int numIdx,opnd;
	Tcl_Obj *valuePtr, *value2Ptr;

	opnd = TclGetUInt4AtPtr(pc + 1);
	numIdx = opnd - 2;

	/*
	 * Get the old value of variable, and remove the stack ref.
	 * This is safe because the variable still references the
	 * object; the ref count will never go zero here.
	 */
	value2Ptr = POP_OBJECT();
	TclDecrRefCount(value2Ptr); /* This one should be done here */

	/*
	 * Get the new element value.
	 */
	valuePtr = *tosPtr;

	/*
	 * Compute the new variable value
	 */
	objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
	        tosPtr - numIdx, valuePtr);

	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */
	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
	NEXT_INST_V(5, (numIdx+1), -1);
    }

    case INST_LSET_LIST:
    {
	/*
	 * 'lset' with 4 args.
	 */

	Tcl_Obj *objPtr, *valuePtr, *value2Ptr;
	
	/*
	 * Get the old value of variable, and remove the stack ref.
	 * This is safe because the variable still references the
	 * object; the ref count will never go zero here.
	 */
	objPtr = POP_OBJECT(); 
	TclDecrRefCount(objPtr); /* This one should be done here */
	
	/*
	 * Get the new element value, and the index list
	 */
	valuePtr = *tosPtr;
	value2Ptr = *(tosPtr - 1);
	
	/*
	 * Compute the new variable value
	 */
	objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);

	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
	            Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */
	TRACE(("=> %s\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 2, -1);
    }
    
    case INST_LIST_RANGE_IMM:
    {
	/*** lrange with objc==4 and both indices in bytecode stream ***/

	int listc, fromIdx, toIdx;
	Tcl_Obj **listv;
	Tcl_Obj *valuePtr;
	
	/*
	 * Pop the list and get the indices
	 */
	valuePtr = *tosPtr;
	fromIdx = TclGetInt4AtPtr(pc+1);
	toIdx = TclGetInt4AtPtr(pc+5);

	/*
	 * Get the contents of the list, making sure that it
	 * really is a list in the process.
	 */
	result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
		    fromIdx, toIdx), Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}

	/*
	 * Skip a lot of work if we're about to throw the result away
	 * (common with uses of [lassign].)
	 */
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+9) == INST_POP) {
	    NEXT_INST_F(10, 1, 0);
	}
#endif








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|


|
|
|
<






|







|




|
|


|
|
|




|
<

|




|
|

>
>


|
|





<

|
|





|
|












|
|
|
|








|











|





|


|




|
|




<

|
|
|

|
|

|


|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|






|






|
|




|
|
<




>

|

|
>




>

|

|
>






|
<
|
|
|

>
>
|
|
|
|
|
|
|
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|

|
|
|
|



|

|





|

>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
|






|
<
|
|
|
|
|
|
<

|
|
|

>

>
|
>
>
>
|
|
|

>
>
>

|
|
|
>



>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>




|

|








<
|
|
|
<


|





|
<
|
|
|
|
|
|
|

|
<
|
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|

|
|
|
|
|
<
|

|
|
|
|

|
|
|
|
<
|
|
|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|

|


|
|
|

|
|
|
|
<
|
|
|
|
|
|
|
|

|

|
|
|

|
|
<
|
|
|
|


<
|

|
|
>
|
|
|
|

|
<
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
<
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|





|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|

|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
<
<
|
|
|
<
<
|
|
|
|
|
|

|
<
|

|
|
|


<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|

|
|
|


|




|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
<
|
<
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

|
|
|

|
|



|





|

|
|
|


>
|
>
|
|
>
|
|
>
>
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
>
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
>
|
|
|
|
|
|
|
|
>
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|
<
|
|
|
|
|
|
|
|
>
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
|
|
|
|
|
>
|
>
|

|
|
|

|
|


|




|

|







|

|




|


>
|
|
|
<
|
<
<
|
|
|
<
<
|
<
<
<
|
<
<
<
<
|
>
>
>
|
|
<
>
|
>
>
|
>
|
>

<
<
|
<
<
|
<
<
<
<
<
<
<
<
<

<
<
<
<
|
<
|
<
<
|
|
>
|
<
<
|
|
|
<
|
|
<
<
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
<
|

>
|
|
<

|
|






|
|

|
|
<
<
<
<
<
<
|
|
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
|
|
|
|
|
|
<
<
<
<
<





<
|
|
|
<
<
<
<
<




|


|
<
|
|
|
|
>
|
|
|
|
|
|
|

|
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
<
|

|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|

|
<





|



>




|
|

>








|
|

>















|
<














>

|

















|
<

|
<








|
|
|













|

















|
<





|

|
|
|

|

|





|










|










|
|
<





|








|
|









|
|







1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178

1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209

1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229

1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295

1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377

1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404

1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483

1484
1485
1486
1487
1488
1489

1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552

1553
1554
1555

1556
1557
1558
1559
1560
1561
1562
1563
1564

1565
1566
1567
1568
1569
1570
1571
1572
1573

1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584

1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595

1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606

1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638

1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655

1656
1657
1658
1659
1660
1661

1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672

1673
1674
1675
1676
1677
1678
1679
1680

1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697

1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778

1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792

1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826

1827
1828
1829
1830
1831
1832
1833
1834
1835
1836

1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885


1886
1887
1888


1889
1890
1891
1892
1893
1894
1895
1896

1897
1898
1899
1900
1901
1902
1903

1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922

1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940

1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032

2033

2034
2035
2036
2037
2038
2039
2040

2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076

2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329









































































































































































































































2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468

2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501

2502
2503
2504
2505
2506

2507
2508
2509
2510
2511
2512
2513
2514
2515
2516

2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533

2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606

2607


2608
2609
2610


2611



2612




2613
2614
2615
2616
2617
2618

2619
2620
2621
2622
2623
2624
2625
2626
2627


2628


2629









2630




2631

2632


2633
2634
2635
2636


2637
2638
2639

2640
2641


2642
2643
2644
2645
2646
2647
2648

2649
2650
2651
2652
2653
2654
2655

2656
2657
2658
2659
2660

2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674






2675
2676


2677




















2678


2679
2680
2681
2682
2683
2684
2685




















2686

2687
2688
2689
2690
2691
2692
2693





2694
2695
2696
2697
2698

2699
2700
2701





2702
2703
2704
2705
2706
2707
2708
2709

2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723

2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740

2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773

2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819

2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854

2855
2856

2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899

2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942

2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
    iPtr->numLevels--;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrObj --
 *
 *	Increment an integeral value in a Tcl_Obj by an integeral value
 *	held in another Tcl_Obj.  Caller is responsible for making sure
 *	we can update the first object.
 *
 * Results:
 *	TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On
 *	error, an error message is left in the interpreter (if it is not NULL,
 *	of course).
 *
 * Side effects:
 *	valuePtr gets the new incrmented value.
 *
 *----------------------------------------------------------------------
 */

int
TclIncrObj(interp, valuePtr, incrPtr)
    Tcl_Interp *interp;
    Tcl_Obj *valuePtr;
    Tcl_Obj *incrPtr;
{
    ClientData ptr1, ptr2;
    int type1, type2;
    mp_int value, incr;

    if (Tcl_IsShared(valuePtr)) {
	Tcl_Panic("shared object passed to TclIncrObj");
    }

    if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
	    || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
	/* Produce error message (reparse?!) */
	return Tcl_GetIntFromObj(interp, valuePtr, &type1);
    }
    if ((GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK)
	    || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
	/* Produce error message (reparse?!) */
	Tcl_GetIntFromObj(interp, incrPtr, &type1);
	Tcl_AddErrorInfo(interp, "\n    (reading increment)");
	return TCL_ERROR;
    }
    do {if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
	Tcl_WideInt w1, w2, sum;
	TclGetWideIntFromObj(NULL, valuePtr, &w1);
	TclGetWideIntFromObj(NULL, incrPtr, &w2);
	sum = w1 + w2;
#ifndef NO_WIDE_TYPE
	if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
	{
	    /* Check for overflow */
	    if (((w1 < 0) && (w2 < 0) && (sum > 0))
		    || ((w1 > 0) && (w2 > 0) && (sum < 0))) {
		break;
	    }
	}
	Tcl_SetWideIntObj(valuePtr, sum);
	return TCL_OK;
    }} while (0);
    
    Tcl_GetBignumAndClearObj(interp, valuePtr, &value);
    Tcl_GetBignumFromObj(interp, incrPtr, &incr);
    mp_add(&value, &incr, &value);
    mp_clear(&incr);
    Tcl_SetBignumObj(valuePtr, &value);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExecuteByteCode --
 *
 *	This procedure executes the instructions of a ByteCode structure. It
 *	returns when a "done" instruction is executed or an error occurs.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h (such as
 *	TCL_OK), and interp->objResultPtr refers to a Tcl object that either
 *	contains the result of executing the code or an error message.

 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */

static int
TclExecuteByteCode(interp, codePtr)
    Tcl_Interp *interp;		/* Token for command interpreter. */
    ByteCode *codePtr;		/* The bytecode sequence to interpret. */
{
    /*
     * Compiler cast directive - not a real variable.
     *	   Interp *iPtr = (Interp *) interp;
     */
#define iPtr ((Interp *) interp)

    /*
     * Constants: variables that do not change during the execution, used
     * sporadically.
     */

    ExecEnv *eePtr;		/* Points to the execution environment. */
    int initStackTop;		/* Stack top at start of execution. */
    int initCatchTop;		/* Catch stack top at start of execution. */
    Var *compiledLocals;
    Namespace *namespacePtr;

    /*
     * Globals: variables that store state, must remain valid at all times.

     */

    int catchTop;
    register Tcl_Obj **tosPtr;  /* Cached pointer to top of evaluation stack. */
    register unsigned char *pc = codePtr->codeStart;
				/* The current program counter. */
    int instructionCount = 0;	/* Counter that is used to work out when to
				 * call Tcl_AsyncReady() */
    Tcl_Obj *expandNestList = NULL;
    int checkInterp = 0;	/* Indicates when a check of interp readyness
				 * is necessary. Set by DECACHE_STACK_INFO() */

    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    register int cleanup;
    Tcl_Obj *objResultPtr;


    /*
     * Result variable - needed only when going to checkForcatch or other
     * error handlers; also used as local in some opcodes.
     */

    int result = TCL_OK;	/* Return code returned after execution. */

    /*
     * Locals - variables that are used within opcodes or bounded sections of
     * the file (jumps between opcodes within a family).
     * NOTE: These are now defined locally where needed.
     */

#ifdef TCL_COMPILE_DEBUG
    int traceInstructions = (tclTraceExec == 3);
    char cmdNameBuf[21];
#endif

    /*
     * The execution uses a unified stack: first the catch stack, immediately
     * above it the execution stack.
     *
     * Make sure the catch stack is large enough to hold the maximum number of
     * catch commands that could ever be executing at the same time (this will
     * be no more than the exception range array's depth).  Make sure the
     * execution stack is large enough to execute this ByteCode.
     */

    eePtr = iPtr->execEnvPtr;
    initCatchTop = eePtr->tosPtr - eePtr->stackPtr;
    catchTop = initCatchTop;
    tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth;

    while ((tosPtr + codePtr->maxStackDepth) > eePtr->endPtr) {
	GrowEvaluationStack(eePtr);
	tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth;
    }
    initStackTop = tosPtr - eePtr->stackPtr;

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 2) {
	PrintByteCodeInfo(codePtr);
	fprintf(stdout, "  Starting stack top=%d\n", initStackTop);
	fflush(stdout);
    }
#endif

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    if (iPtr->varFramePtr != NULL) {
	namespacePtr = iPtr->varFramePtr->nsPtr;
	compiledLocals = iPtr->varFramePtr->compiledLocals;
    } else {
	namespacePtr = iPtr->globalNsPtr;
	compiledLocals = NULL;
    }

    /*
     * Loop executing instructions until a "done" instruction, a TCL_RETURN,
     * or some error.
     */

    goto cleanup0;


    /*
     * Targets for standard instruction endings; unrolled for speed in the
     * most frequent cases (instructions that consume up to two stack
     * elements).
     *
     * This used to be a "for(;;)" loop, with each instruction doing its own
     * cleanup.
     */

    {
	Tcl_Obj *valuePtr;

    cleanupV_pushObjResultPtr:
	switch (cleanup) {
	case 0:
	    *(++tosPtr) = (objResultPtr);
	    goto cleanup0;
	default:
	    cleanup -= 2;
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
	case 2:
	cleanup2_pushObjResultPtr:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	case 1:
	cleanup1_pushObjResultPtr:
	    valuePtr = *tosPtr;
	    TclDecrRefCount(valuePtr);
	}
	*tosPtr = objResultPtr;
	goto cleanup0;

    cleanupV:
	switch (cleanup) {
	default:
	    cleanup -= 2;
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
	case 2:
	cleanup2:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	case 1:
	cleanup1:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	case 0:
	    /*
	     * We really want to do nothing now, but this is needed for some
	     * compilers (SunPro CC)
	     */
	    break;
	}
    }
 cleanup0:

#ifdef TCL_COMPILE_DEBUG
    /*
     * Skip the stack depth check if an expansion is in progress
     */

    ValidatePcAndStackTop(codePtr, pc, (tosPtr - eePtr->stackPtr),
	    initStackTop, /*checkStack*/ (expandNestList == NULL));
    if (traceInstructions) {
	fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (tosPtr - eePtr->stackPtr));
	TclPrintInstruction(codePtr, pc);
	fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */

#ifdef TCL_COMPILE_STATS
    iPtr->stats.instructionCount[*pc]++;
#endif

    /*
     * Check for asynchronous handlers [Bug 746722]; we do the check every
     * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).

     */

    if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
	if (Tcl_AsyncReady()) {
	    int localResult;
	    DECACHE_STACK_INFO();
	    localResult = Tcl_AsyncInvoke(interp, result);
	    CACHE_STACK_INFO();
	    if (localResult == TCL_ERROR) {
		result = localResult;
		goto checkForCatch;
	    }
	}
	if (Tcl_LimitReady(interp)) {
	    int localResult;
	    DECACHE_STACK_INFO();
	    localResult = Tcl_LimitCheck(interp);
	    CACHE_STACK_INFO();
	    if (localResult == TCL_ERROR) {
		result = localResult;
		goto checkForCatch;
	    }
	}
    }

    switch (*pc) {
    case INST_RETURN_IMM: {

	int code = TclGetInt4AtPtr(pc+1);
	int level = TclGetUInt4AtPtr(pc+5);
	Tcl_Obj *returnOpts;

	TRACE(("%u %u => ", code, level));
	returnOpts = POP_OBJECT();
	result = TclProcessReturn(interp, code, level, returnOpts);
	Tcl_DecrRefCount(returnOpts);
	if (result != TCL_OK) {
	    Tcl_SetObjResult(interp, *tosPtr);
	    cleanup = 1;
	    goto processExceptionReturn;
	}
	TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
		O2S(objResultPtr)));
	NEXT_INST_F(9, 0, 0);
    }

    case INST_RETURN_STK:
	TRACE(("=> "));
	objResultPtr = POP_OBJECT();
	result = Tcl_SetReturnOptions(interp, POP_OBJECT());
	if (result != TCL_OK) {
	    Tcl_SetObjResult(interp, objResultPtr);
	    Tcl_DecrRefCount(objResultPtr);
	    cleanup = 0;
	    goto processExceptionReturn;
	}
	TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
		O2S(objResultPtr)));
	NEXT_INST_F(1, 0, -1);

    case INST_DONE:
	if (tosPtr <= eePtr->stackPtr + initStackTop) {
	    tosPtr--;
	    goto abnormalReturn;
	}

	/*
	 * Set the interpreter's object result to point to the topmost object
	 * from the stack, and check for a possible [catch]. The stackTop's
	 * level and refCount will be handled by "processCatch" or
	 * "abnormalReturn".
	 */

	Tcl_SetObjResult(interp, *tosPtr);
#ifdef TCL_COMPILE_DEBUG
	TRACE_WITH_OBJ(("=> return code=%d, result=", result),
		iPtr->objResultPtr);
	if (traceInstructions) {
	    fprintf(stdout, "\n");
	}
#endif
	goto checkForCatch;

    case INST_PUSH1:
#if !TCL_COMPILE_DEBUG
	instPush1Peephole:
#endif
	PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
	TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), *tosPtr);
	pc += 2;
#if !TCL_COMPILE_DEBUG
	/*
	 * Runtime peephole optimisation: check if we are pushing again.
	 */

	if (*pc == INST_PUSH1) {
	    goto instPush1Peephole;
	}
#endif
	NEXT_INST_F(0, 0, 0);

    case INST_PUSH4:
	objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
	TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
	NEXT_INST_F(5, 0, 1);

    case INST_POP: {

	Tcl_Obj *valuePtr;

	TRACE_WITH_OBJ(("=> discarding "), *tosPtr);
	valuePtr = POP_OBJECT();
	TclDecrRefCount(valuePtr);


	/*
	 * Runtime peephole optimisation: an INST_POP is scheduled at the end
	 * of most commands. If the next instruction is an INST_START_CMD,
	 * fall through to it.
	 */

	pc++;
#if !TCL_COMPILE_DEBUG
	if (*pc == INST_START_CMD) {
	    goto instStartCmdPeephole;
	}
#endif
	NEXT_INST_F(0, 0, 0);
    }

    case INST_START_CMD:
#if !TCL_COMPILE_DEBUG
    instStartCmdPeephole:
#endif
	/*
	 * Remark that if the interpreter is marked for deletion its
	 * compileEpoch is modified, so that the epoch check also verifies
	 * that the interp is not deleted.  If no outside call has been made
	 * since the last check, it is safe to omit the check.
	 */

	iPtr->cmdCount++;
	if (!checkInterp ||
		(((codePtr->compileEpoch == iPtr->compileEpoch)
			&& (codePtr->nsEpoch == namespacePtr->resolverEpoch))
			|| (codePtr->flags & TCL_BYTECODE_PRECOMPILED))) {
#if !TCL_COMPILE_DEBUG
	    /*
	     * Peephole optimisations: check if there are several
	     * INST_START_CMD in a row. Many commands start by pushing a
	     * literal argument or command name; optimise that case too.
	     */

	    while (*(pc += 5) == INST_START_CMD) {
		iPtr->cmdCount++;
	    }
	    if (*pc == INST_PUSH1) {
		goto instPush1Peephole;
	    }
	    NEXT_INST_F(0, 0, 0);
#else
	    NEXT_INST_F(5, 0, 0);
#endif
	} else {
	    char *bytes;
	    int length, opnd;
	    Tcl_Obj *newObjResultPtr;

	    bytes = GetSrcInfoForPc(pc, codePtr, &length);
	    DECACHE_STACK_INFO();
	    result = Tcl_EvalEx(interp, bytes, length, 0);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		cleanup = 0;
		goto processExceptionReturn;
	    }
	    opnd = TclGetUInt4AtPtr(pc+1);
	    objResultPtr = Tcl_GetObjResult(interp);

	    TclNewObj(newObjResultPtr);
	    Tcl_IncrRefCount(newObjResultPtr);
	    iPtr->objResultPtr = newObjResultPtr;

	    NEXT_INST_V(opnd, 0, -1);
	}

    case INST_DUP:
	objResultPtr = *tosPtr;
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(1, 0, 1);

    case INST_OVER: {

	int opnd;

	opnd = TclGetUInt4AtPtr(pc+1);
	objResultPtr = *(tosPtr - opnd);
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(5, 0, 1);
    }

    case INST_CONCAT1: {

	int opnd, length, appendLen = 0;
	char *bytes, *p;
	Tcl_Obj **currPtr;

	opnd = TclGetUInt1AtPtr(pc+1);

	/*
	 * Compute the length to be appended.
	 */

	for (currPtr = tosPtr - (opnd-2); currPtr <= tosPtr; currPtr++) {

	    bytes = Tcl_GetStringFromObj(*currPtr, &length);
	    if (bytes != NULL) {
		appendLen += length;
	    }
	}

	/*
	 * If nothing is to be appended, just return the first object by
	 * dropping all the others from the stack; this saves both the
	 * computation and copy of the string rep of the first object,
	 * enabling the fast '$x[set x {}]' idiom for 'K $x [set x{}]'.

	 */

	if (appendLen == 0) {
	    TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	    NEXT_INST_V(2, (opnd-1), 0);
	}

	/*
	 * If the first object is shared, we need a new obj for the result;
	 * otherwise, we can reuse the first object.  In any case, make sure
	 * it has enough room to accomodate all the concatenated bytes. Note

	 * that if it is unshared its bytes are already copied by
	 * Tcl_SetObjectLength, so that we set the loop parameters to avoid
	 * copying them again: p points to the end of the already copied
	 * bytes, currPtr to the second object.
	 */

	objResultPtr = *(tosPtr-(opnd-1));
	bytes = Tcl_GetStringFromObj(objResultPtr, &length);
#if !TCL_COMPILE_DEBUG
	if (!Tcl_IsShared(objResultPtr)) {
	    Tcl_SetObjLength(objResultPtr, (length + appendLen));
	    p = TclGetString(objResultPtr) + length;
	    currPtr = tosPtr - (opnd - 2);
	} else {
#endif
	    p = (char *) ckalloc((unsigned) (length + appendLen + 1));
	    TclNewObj(objResultPtr);
	    objResultPtr->bytes = p;
	    objResultPtr->length = length + appendLen;
	    currPtr = tosPtr - (opnd - 1);
#if !TCL_COMPILE_DEBUG
	}
#endif

	/*
	 * Append the remaining characters.
	 */

	for (; currPtr <= tosPtr; currPtr++) {
	    bytes = Tcl_GetStringFromObj(*currPtr, &length);
	    if (bytes != NULL) {
		memcpy((VOID *) p, (VOID *) bytes, (size_t) length);

		p += length;
	    }
	}
	*p = '\0';

	TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	NEXT_INST_V(2, opnd, 1);
    }

    case INST_EXPAND_START: {
	/*
	 * Push an element to the expandNestList. This records the current
	 * tosPtr - i.e., the point in the stack where the expanded command
	 * starts.
	 *
	 * Use a Tcl_Obj as linked list element; slight mem waste, but faster
	 * allocation than ckalloc. This also abuses the Tcl_Obj structure, as

	 * we do not define a special tclObjType for it. It is not dangerous
	 * as the obj is never passed anywhere, so that all manipulations are
	 * performed here and in INST_INVOKE_EXPANDED (in case of an expansion
	 * error, also in INST_EXPAND_STKTOP).
	 */


	Tcl_Obj *objPtr;

	TclNewObj(objPtr);
	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)
		(tosPtr - eePtr->stackPtr);
	objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList;
	expandNestList = objPtr;
	NEXT_INST_F(1, 0, 0);
    }

    case INST_EXPAND_STKTOP: {

	int objc, length, i;
	Tcl_Obj **objv, *valuePtr, *objPtr;

	/*
	 * Make sure that the element at stackTop is a list; if not, remove
	 * the element from the expand link list and leave.
	 */


	valuePtr = *tosPtr;
	if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
	    result = TCL_ERROR;
	    TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
		    Tcl_GetObjResult(interp));
	    objPtr = expandNestList;
	    expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
	    TclDecrRefCount(objPtr);
	    goto checkForCatch;
	}
	tosPtr--;

	/*
	 * Make sure there is enough room in the stack to expand this list
	 * *and* process the rest of the command (at least up to the next
	 * argument expansion or command end).  The operand is the current
	 * stack depth, as seen by the compiler.

	 */

	length = objc + codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1);
	while ((tosPtr + length) > eePtr->endPtr) {
	    DECACHE_STACK_INFO();
	    GrowEvaluationStack(eePtr);
	    CACHE_STACK_INFO();
	}

	/*
	 * Expand the list at stacktop onto the stack; free the list.
	 */

	for (i = 0; i < objc; i++) {
	    PUSH_OBJECT(objv[i]);
	}
	TclDecrRefCount(valuePtr);
	NEXT_INST_F(5, 0, 0);
    }

    {
	/*
	 * INVOCATION BLOCK
	 */

	int objc, pcAdjustment;

    case INST_INVOKE_EXPANDED:
	{
	    Tcl_Obj *objPtr;

	    objPtr = expandNestList;
	    expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
	    objc = tosPtr - eePtr->stackPtr
		    - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;
	    TclDecrRefCount(objPtr);
	}

	if (objc == 0) {
	    /*
	     * Nothing was expanded, return {}.
	     */

	    TclNewObj(objResultPtr);
	    NEXT_INST_F(1, 0, 1);
	}

	pcAdjustment = 1;
	goto doInvocation;

    case INST_INVOKE_STK4:
	objc = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	goto doInvocation;

    case INST_INVOKE_STK1:
	objc = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;

    doInvocation:
	{
	    Tcl_Obj **objv = (tosPtr - (objc-1));
	    int length;
	    char *bytes;

	    /*
	     * We keep the stack reference count as a (char *), as that works
	     * nicely as a portable pointer-sized counter.
	     */

	    char **preservedStackRefCountPtr;

#ifdef TCL_COMPILE_DEBUG
	    if (tclTraceExec >= 2) {
		int i;

		if (traceInstructions) {
		    strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
		    TRACE(("%u => call ", objc));
		} else {
		    fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,

			    (unsigned int)(pc - codePtr->codeStart));
		}
		for (i = 0;  i < objc;  i++) {
		    TclPrintObject(stdout, objv[i], 15);
		    fprintf(stdout, " ");
		}
		fprintf(stdout, "\n");
		fflush(stdout);
	    }
#endif /*TCL_COMPILE_DEBUG*/

	    /*
	     * If trace procedures will be called, we need a command string to
	     * pass to TclEvalObjvInternal; note that a copy of the string

	     * will be made there to include the ending \0.
	     */

	    bytes = NULL;
	    length = 0;
	    if (iPtr->tracePtr != NULL) {
		Trace *tracePtr, *nextTracePtr;

		for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
			tracePtr = nextTracePtr) {
		    nextTracePtr = tracePtr->nextPtr;
		    if (tracePtr->level == 0 ||
			    iPtr->numLevels <= tracePtr->level) {
			/*
			 * Traces will be called: get command string
			 */

			bytes = GetSrcInfoForPc(pc, codePtr, &length);
			break;
		    }
		}
	    } else {
		Command *cmdPtr;

		cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
		if ((cmdPtr!=NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
		    bytes = GetSrcInfoForPc(pc, codePtr, &length);
		}
	    }

	    /*
	     * A reference to part of the stack vector itself escapes our
	     * control: increase its refCount to stop it from being
	     * deallocated by a recursive call to ourselves.  The extra

	     * variable is needed because all others are liable to change due
	     * to the trace procedures.
	     */

	    preservedStackRefCountPtr = (char **) (eePtr->stackPtr-1);
	    ++*preservedStackRefCountPtr;

	    /*
	     * Reset the instructionCount variable, since we're about to check
	     * for async stuff anyway while processing TclEvalObjvInternal.

	     */

	    instructionCount = 1;

	    /*
	     * Finally, let TclEvalObjvInternal handle the command.
	     */

	    DECACHE_STACK_INFO();
	    Tcl_ResetResult(interp);
	    result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
	    CACHE_STACK_INFO();

	    /*
	     * If the old stack is going to be released, it is safe to do so
	     * now, since no references to objv are going to be used from now
	     * on.
	     */

	    --*preservedStackRefCountPtr;
	    if (*preservedStackRefCountPtr == (char *) 0) {
		ckfree((VOID *) preservedStackRefCountPtr);
	    }

	    if (result == TCL_OK) {
		Tcl_Obj *objPtr;
		/*
		 * Push the call's object result and continue execution with
		 * the next instruction.
		 */

		TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
			objc, cmdNameBuf), Tcl_GetObjResult(interp));

		objResultPtr = Tcl_GetObjResult(interp);

		/*
		 * Reset the interp's result to avoid possible duplications of
		 * large objects [Bug 781585]. We do not call Tcl_ResetResult
		 * to avoid any side effects caused by the resetting of
		 * errorInfo and errorCode [Bug 804681], which are not needed
		 * here. We chose instead to manipulate the interp's object
		 * result directly.
		 *
		 * Note that the result object is now in objResultPtr, it
		 * keeps the refCount it had in its role of
		 * iPtr->objResultPtr.
		 */



		TclNewObj(objPtr);
		Tcl_IncrRefCount(objPtr);
		iPtr->objResultPtr = objPtr;


		NEXT_INST_V(pcAdjustment, objc, -1);
	    } else {
		cleanup = objc;
		goto processExceptionReturn;
	    }
	}
    }


    case INST_EVAL_STK: {
	/*
	 * Note to maintainers: it is important that INST_EVAL_STK pop its
	 * argument from the stack before jumping to checkForCatch! DO NOT
	 * OPTIMISE!
	 */


	Tcl_Obj *objPtr;

	objPtr = *tosPtr;
	DECACHE_STACK_INFO();
	result = TclCompEvalObj(interp, objPtr);
	CACHE_STACK_INFO();
	if (result == TCL_OK) {
	    /*
	     * Normal return; push the eval's object result.
	     */

	    objResultPtr = Tcl_GetObjResult(interp);
	    TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
		    Tcl_GetObjResult(interp));

	    /*
	     * Reset the interp's result to avoid possible duplications of
	     * large objects [Bug 781585]. We do not call Tcl_ResetResult to
	     * avoid any side effects caused by the resetting of errorInfo and

	     * errorCode [Bug 804681], which are not needed here. We chose
	     * instead to manipulate the interp's object result directly.
	     *
	     * Note that the result object is now in objResultPtr, it keeps
	     * the refCount it had in its role of iPtr->objResultPtr.
	     */

	    TclNewObj(objPtr);
	    Tcl_IncrRefCount(objPtr);
	    iPtr->objResultPtr = objPtr;
	    NEXT_INST_F(1, 1, -1);
	} else {
	    cleanup = 1;
	    goto processExceptionReturn;
	}
    }

    case INST_EXPR_STK: {

	Tcl_Obj *objPtr, *valuePtr;

	objPtr = *tosPtr;
	DECACHE_STACK_INFO();
	Tcl_ResetResult(interp);
	result = Tcl_ExprObj(interp, objPtr, &valuePtr);
	CACHE_STACK_INFO();
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
		    Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}
	objResultPtr = valuePtr;
	TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
	NEXT_INST_F(1, 1, -1); /* already has right refct */
    }

    /*
     * ---------------------------------------------------------
     *	   Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!  The different
     * instructions set the value of some variables and then jump to somme
     * common execution code.
     */
    {
	int opnd, pcAdjustment;
	char *part1, *part2;
	Var *varPtr, *arrayPtr;
	Tcl_Obj *objPtr;

    case INST_LOAD_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);
	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));
	if (TclIsVarDirectReadable(varPtr)) {
	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_F(2, 0, 1);
	}
	pcAdjustment = 2;
	cleanup = 0;
	arrayPtr = NULL;
	part2 = NULL;
	goto doCallPtrGetVar;

    case INST_LOAD_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));
	if (TclIsVarDirectReadable(varPtr)) {
	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_F(5, 0, 1);
	}
	pcAdjustment = 5;
	cleanup = 0;
	arrayPtr = NULL;
	part2 = NULL;
	goto doCallPtrGetVar;

    case INST_LOAD_ARRAY_STK:
	cleanup = 2;
	part2 = Tcl_GetString(*tosPtr);	/* element name */
	objPtr = *(tosPtr - 1);		/* array name */
	TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
	goto doLoadStk;

    case INST_LOAD_STK:
    case INST_LOAD_SCALAR_STK:
	cleanup = 1;
	part2 = NULL;
	objPtr = *tosPtr;			/* variable name */
	TRACE(("\"%.30s\" => ", O2S(objPtr)));

    doLoadStk:
	part1 = TclGetString(objPtr);
	varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG,

		"read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);

	if (varPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	if (TclIsVarDirectReadable(varPtr)
		&& ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {

	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_V(1, cleanup, 1);
	}
	pcAdjustment = 1;
	goto doCallPtrGetVar;

    case INST_LOAD_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	goto doLoadArray;

    case INST_LOAD_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;

    doLoadArray:
	part2 = TclGetString(*tosPtr);
	arrayPtr = &(compiledLocals[opnd]);
	part1 = arrayPtr->name;
	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;
	}
	TRACE(("%u \"%.30s\" => ", opnd, part2));
	varPtr = TclLookupArrayElement(interp, part1, part2,
		TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
	if (varPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	if (TclIsVarDirectReadable(varPtr)
		&& ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {

	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_F(pcAdjustment, 1, 1);
	}
	cleanup = 1;
	goto doCallPtrGetVar;

    doCallPtrGetVar:
	/*
	 * There are either errors or the variable is traced: call
	 * TclPtrGetVar to process fully.
	 */

	DECACHE_STACK_INFO();
	objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2,
		TCL_LEAVE_ERR_MSG);
	CACHE_STACK_INFO();
	if (objResultPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_V(pcAdjustment, cleanup, 1);
    }

    /*
     *	   End of INST_LOAD instructions.
     * ---------------------------------------------------------
     */

    /*
     * ---------------------------------------------------------
     *	   Start of INST_STORE and related instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!  The different
     * instructions set the value of some variables and then jump to somme
     * common execution code.
     */

    {
	int opnd, pcAdjustment, storeFlags;
	char *part1, *part2;
	Var *varPtr, *arrayPtr;
	Tcl_Obj *objPtr, *valuePtr;

    case INST_LAPPEND_STK:
	valuePtr = *tosPtr; /* value to append */
	part2 = NULL;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreStk;

    case INST_LAPPEND_ARRAY_STK:
	valuePtr = *tosPtr; /* value to append */
	part2 = TclGetString(*(tosPtr - 1));
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreStk;

    case INST_APPEND_STK:
	valuePtr = *tosPtr; /* value to append */
	part2 = NULL;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreStk;

    case INST_APPEND_ARRAY_STK:
	valuePtr = *tosPtr; /* value to append */
	part2 = TclGetString(*(tosPtr - 1));
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreStk;

    case INST_STORE_ARRAY_STK:
	valuePtr = *tosPtr;
	part2 = TclGetString(*(tosPtr - 1));
	storeFlags = TCL_LEAVE_ERR_MSG;
	goto doStoreStk;

    case INST_STORE_STK:
    case INST_STORE_SCALAR_STK:
	valuePtr = *tosPtr;
	part2 = NULL;
	storeFlags = TCL_LEAVE_ERR_MSG;

    doStoreStk:
	objPtr = *(tosPtr - 1 - (part2 != NULL)); /* variable name */
	part1 = TclGetString(objPtr);
#ifdef TCL_COMPILE_DEBUG
	if (part2 == NULL) {
	    TRACE(("\"%.30s\" <- \"%.30s\" =>", part1, O2S(valuePtr)));
	} else {
	    TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
		    part1, part2, O2S(valuePtr)));
	}
#endif
	varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	if (varPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	cleanup = ((part2 == NULL)? 2 : 3);
	pcAdjustment = 1;
	goto doCallPtrSetVar;

    case INST_LAPPEND_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreArray;

    case INST_LAPPEND_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreArray;

    case INST_APPEND_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreArray;

    case INST_APPEND_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreArray;

    case INST_STORE_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = TCL_LEAVE_ERR_MSG;
	goto doStoreArray;

    case INST_STORE_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = TCL_LEAVE_ERR_MSG;

    doStoreArray:
	valuePtr = *tosPtr;
	part2 = TclGetString(*(tosPtr - 1));
	arrayPtr = &(compiledLocals[opnd]);
	part1 = arrayPtr->name;
	TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, part2, O2S(valuePtr)));
	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;
	}
	varPtr = TclLookupArrayElement(interp, part1, part2,
		TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
	if (varPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	cleanup = 2;
	goto doCallPtrSetVar;

    case INST_LAPPEND_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreScalar;

    case INST_LAPPEND_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreScalar;

    case INST_APPEND_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreScalar;

    case INST_APPEND_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreScalar;

    case INST_STORE_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = TCL_LEAVE_ERR_MSG;
	goto doStoreScalar;

    case INST_STORE_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = TCL_LEAVE_ERR_MSG;

    doStoreScalar:
	valuePtr = *tosPtr;
	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	cleanup = 1;
	arrayPtr = NULL;
	part2 = NULL;

    doCallPtrSetVar:
	if ((storeFlags == TCL_LEAVE_ERR_MSG)
		&& TclIsVarDirectWritable(varPtr)
		&& ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
	    /*
	     * No traces, no errors, plain 'set': we can safely inline. The
	     * value *will* be set to what's requested, so that the stack top
	     * remains pointing to the same Tcl_Obj.
	     */
	    valuePtr = varPtr->value.objPtr;
	    objResultPtr = *tosPtr;
	    if (valuePtr != objResultPtr) {
		if (valuePtr != NULL) {
		    TclDecrRefCount(valuePtr);
		} else {
		    TclSetVarScalar(varPtr);
		    TclClearVarUndefined(varPtr);
		}
		varPtr->value.objPtr = objResultPtr;
		Tcl_IncrRefCount(objResultPtr);
	    }
#ifndef TCL_COMPILE_DEBUG
	    if (*(pc+pcAdjustment) == INST_POP) {
		NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	    }
#else
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
	    NEXT_INST_V(pcAdjustment, cleanup, 1);
	} else {
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
		    part1, part2, valuePtr, storeFlags);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }









































































































































































































































	}
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+pcAdjustment) == INST_POP) {
	    NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	}
#endif
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_V(pcAdjustment, cleanup, 1);
    }

    /*
     *	   End of INST_STORE and related instructions.
     * ---------------------------------------------------------
     */

    /*
     * ---------------------------------------------------------
     *	   Start of INST_INCR instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!  The different
     * instructions set the value of some variables and then jump to somme
     * common execution code.
     */

/*TODO: Consider more untangling here;  merge with LOAD and STORE ? */

    {
	Tcl_Obj *objPtr, *incrPtr;
	int opnd, pcAdjustment;
#if 0
	int isWide;
	Tcl_WideInt w;
#endif
	long i;
	char *part1, *part2;
	Var *varPtr, *arrayPtr;

    case INST_INCR_SCALAR1:
    case INST_INCR_ARRAY1:
    case INST_INCR_ARRAY_STK:
    case INST_INCR_SCALAR_STK:
    case INST_INCR_STK:
	opnd = TclGetUInt1AtPtr(pc+1);
#if 0
	objPtr = *tosPtr;
	if (objPtr->typePtr == &tclIntType) {
	    i = objPtr->internalRep.longValue;
	    isWide = 0;
	} else if (objPtr->typePtr == &tclWideIntType) {
	    i = 0; /* lint */
	    w = objPtr->internalRep.wideValue;
	    isWide = 1;
	} else {
	    i = 0; /* lint */
	    REQUIRE_WIDE_OR_INT(result, objPtr, i, w);
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
			opnd, O2S(objPtr)), Tcl_GetObjResult(interp));
		Tcl_AddErrorInfo(interp, "\n    (reading increment)");
		goto checkForCatch;
	    }
	    isWide = (objPtr->typePtr == &tclWideIntType);
	}
	tosPtr--;
	TclDecrRefCount(objPtr);
#else
	incrPtr = *tosPtr;
	tosPtr--;
#endif
	switch (*pc) {
	case INST_INCR_SCALAR1:
	    pcAdjustment = 2;
	    goto doIncrScalar;
	case INST_INCR_ARRAY1:
	    pcAdjustment = 2;
	    goto doIncrArray;
	default:
	    pcAdjustment = 1;
	    goto doIncrStk;
	}

    case INST_INCR_ARRAY_STK_IMM:
    case INST_INCR_SCALAR_STK_IMM:
    case INST_INCR_STK_IMM:
	i = TclGetInt1AtPtr(pc+1);
#if 0
	isWide = 0;
#else
	incrPtr = Tcl_NewIntObj(i);
	Tcl_IncrRefCount(incrPtr);
#endif
	pcAdjustment = 2;

    doIncrStk:
	if ((*pc == INST_INCR_ARRAY_STK_IMM)
		|| (*pc == INST_INCR_ARRAY_STK)) {
	    part2 = TclGetString(*tosPtr);
	    objPtr = *(tosPtr - 1);
	    TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
		    O2S(objPtr), part2, i));
	} else {
	    part2 = NULL;
	    objPtr = *tosPtr;
	    TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
	}
	part1 = TclGetString(objPtr);

	varPtr = TclObjLookupVar(interp, objPtr, part2,
		TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
	if (varPtr == NULL) {
	    Tcl_AddObjErrorInfo(interp,
		    "\n    (reading value of variable to increment)", -1);
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    Tcl_DecrRefCount(incrPtr);
	    goto checkForCatch;
	}
	cleanup = ((part2 == NULL)? 1 : 2);
	goto doIncrVar;

    case INST_INCR_ARRAY1_IMM:
	opnd = TclGetUInt1AtPtr(pc+1);
	i = TclGetInt1AtPtr(pc+2);
#if 0
	isWide = 0;
#else
	incrPtr = Tcl_NewIntObj(i);
	Tcl_IncrRefCount(incrPtr);
#endif
	pcAdjustment = 3;

    doIncrArray:
	part2 = TclGetString(*tosPtr);
	arrayPtr = &(compiledLocals[opnd]);
	part1 = arrayPtr->name;
	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;
	}
	TRACE(("%u \"%.30s\" (by %ld) => ", opnd, part2, i));

	varPtr = TclLookupArrayElement(interp, part1, part2,
		TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
	if (varPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    Tcl_DecrRefCount(incrPtr);
	    goto checkForCatch;
	}
	cleanup = 1;
	goto doIncrVar;

    case INST_INCR_SCALAR1_IMM:
	opnd = TclGetUInt1AtPtr(pc+1);
	i = TclGetInt1AtPtr(pc+2);
#if 0
	isWide = 0;
#else
	incrPtr = Tcl_NewIntObj(i);
	Tcl_IncrRefCount(incrPtr);
#endif
	pcAdjustment = 3;

    doIncrScalar:
	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	arrayPtr = NULL;
	part2 = NULL;
	cleanup = 0;
	TRACE(("%u %ld => ", opnd, i));


    doIncrVar:
#if 0
	objPtr = varPtr->value.objPtr;
	if (TclIsVarDirectReadable(varPtr)
		&& ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {

	    if (objPtr->typePtr == &tclIntType && !isWide) {
		/*
		 * No errors, no traces, the variable already has an integer
		 * value: inline processing.
		 */

		i += objPtr->internalRep.longValue;
		if (Tcl_IsShared(objPtr)) {
		    objPtr->refCount--; /* we know it is shared */
		    TclNewLongObj(objResultPtr, i);

		    Tcl_IncrRefCount(objResultPtr);
		    varPtr->value.objPtr = objResultPtr;
		} else {
		    TclSetLongObj(objPtr, i);
		    objResultPtr = objPtr;
		}
		goto doneIncr;
	    } else if (objPtr->typePtr == &tclWideIntType && isWide) {
		/*
		 * No errors, no traces, the variable already has a wide
		 * integer value: inline processing.
		 */

		w += objPtr->internalRep.wideValue;
		if (Tcl_IsShared(objPtr)) {
		    objPtr->refCount--; /* we know it is shared */
		    TclNewWideIntObj(objResultPtr, w);

		    Tcl_IncrRefCount(objResultPtr);
		    varPtr->value.objPtr = objResultPtr;
		} else {
		    TclSetWideIntObj(objPtr, w);
		    objResultPtr = objPtr;
		}
		goto doneIncr;
	    }
	}
	DECACHE_STACK_INFO();
	if (isWide) {
	    objResultPtr = TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1,
		    part2, w, TCL_LEAVE_ERR_MSG);
	} else {
	    objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
		    part2, i, TCL_LEAVE_ERR_MSG);
	}
	CACHE_STACK_INFO();
#else
	/* TODO: Restore no trace optimization */
	DECACHE_STACK_INFO();
	objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2,
		incrPtr, TCL_LEAVE_ERR_MSG);
	CACHE_STACK_INFO();
	Tcl_DecrRefCount(incrPtr);
#endif
	if (objResultPtr == NULL) {
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
#if 0
    doneIncr:
#endif
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+pcAdjustment) == INST_POP) {
	    NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	}
#endif
	NEXT_INST_V(pcAdjustment, cleanup, 1);
    }

    /*
     *	   End of INST_INCR instructions.
     * ---------------------------------------------------------
     */

    case INST_JUMP1:
	{
	    int opnd;

	    opnd = TclGetInt1AtPtr(pc+1);
	    TRACE(("%d => new pc %u\n", opnd,
			  (unsigned int)(pc + opnd - codePtr->codeStart)));
	    NEXT_INST_F(opnd, 0, 0);
	}

    case INST_JUMP4:
	{
	   int opnd;

	   opnd = TclGetInt4AtPtr(pc+1);
	   TRACE(("%d => new pc %u\n", opnd,
			 (unsigned int)(pc + opnd - codePtr->codeStart)));
	   NEXT_INST_F(opnd, 0, 0);
	}

    {
	int jmpOffset[2];
	int b;
	Tcl_Obj *valuePtr;


/* TODO: consider rewrite so we don't compute the offset we're


 * not going to take. */
    case INST_JUMP_FALSE4:
	jmpOffset[0] = TclGetInt4AtPtr(pc+1);	/* FALSE offset */


	jmpOffset[1] = 5;			/* TRUE  offset*/



	goto doCondJump;





    case INST_JUMP_TRUE4:
	jmpOffset[0] = 5;
	jmpOffset[1] = TclGetInt4AtPtr(pc+1);
	goto doCondJump;


    case INST_JUMP_FALSE1:
	jmpOffset[0] = TclGetInt1AtPtr(pc+1);
	jmpOffset[1] = 2;
	goto doCondJump;

    case INST_JUMP_TRUE1:
	jmpOffset[0] = 2;
	jmpOffset[1] = TclGetInt1AtPtr(pc+1);



    doCondJump:


	valuePtr = *tosPtr;














	/* TODO - check claim that taking address of b harms performance */

	/* TODO - consider optimization search for eePtr->constants */


	result = TclGetBooleanFromObj(interp, valuePtr, &b);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
		    ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))


		    ? 0 : 1]), Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}


#ifdef TCL_COMPILE_DEBUG


	if (b) {
	    if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
		TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], O2S(valuePtr),
			(unsigned int)(pc+jmpOffset[1] - codePtr->codeStart)));
	    } else {
		TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr)));
	    }

	} else {
	    if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
		TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr)));
	    } else {
		TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr),
			(unsigned int)(pc + jmpOffset[1] - codePtr->codeStart)));
	    }

	}
#endif
	NEXT_INST_F(jmpOffset[b], 1, 0);
    }


    /*
     * These two instructions are now redundant: the complete logic of the LOR
     * and LAND is now handled by the expression compiler.
     */

    case INST_LOR:
    case INST_LAND:
    {
	/*
	 * Operands must be boolean or numeric. No int->double conversions are
	 * performed.
	 */

	int i1, i2, iResult;






	Tcl_Obj *value2Ptr = *tosPtr;
	Tcl_Obj *valuePtr  = *(tosPtr - 1);























	result = TclGetBooleanFromObj(NULL, valuePtr, &i1);


	if (result != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}





















	result = TclGetBooleanFromObj(NULL, value2Ptr, &i2);

	if (result != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
		    (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    goto checkForCatch;
	}






	if (*pc == INST_LOR) {
	    iResult = (i1 || i2);
	} else {
	    iResult = (i1 && i2);
	}

	objResultPtr = eePtr->constants[iResult];
	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
	NEXT_INST_F(1, 2, 1);





    }

    /*
     * ---------------------------------------------------------
     *	   Start of INST_LIST and related instructions.
     */

    case INST_LIST: {

	/*
	 * Pop the opnd (objc) top stack elements into a new list obj and then
	 * decrement their ref counts.
	 */

	int opnd;

	opnd = TclGetUInt4AtPtr(pc+1);
	objResultPtr = Tcl_NewListObj(opnd, (tosPtr - (opnd-1)));
	TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	NEXT_INST_V(5, opnd, 1);
    }

    case INST_LIST_LENGTH: {

	Tcl_Obj *valuePtr;
	int length;

	valuePtr = *tosPtr;

	result = Tcl_ListObjLength(interp, valuePtr, &length);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
		    Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}
	TclNewIntObj(objResultPtr, length);
	TRACE(("%.20s => %d\n", O2S(valuePtr), length));
	NEXT_INST_F(1, 1, 1);
    }

    case INST_LIST_INDEX: {

	/*** lindex with objc == 3 ***/

	Tcl_Obj *valuePtr, *value2Ptr;

	/*
	 * Pop the two operands
	 */

	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1);

	/*
	 * Extract the desired list element
	 */

	objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
		    Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Stash the list element on the stack
	 */

	TRACE(("%.20s %.20s => %s\n",
		O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
	NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
    }

    case INST_LIST_INDEX_IMM: {

	/*** lindex with objc==3 and index in bytecode stream ***/

	int listc, idx, opnd;
	Tcl_Obj **listv;
	Tcl_Obj *valuePtr;

	/*
	 * Pop the list and get the index
	 */

	valuePtr = *tosPtr;
	opnd = TclGetInt4AtPtr(pc+1);

	/*
	 * Get the contents of the list, making sure that it really is a list
	 * in the process.
	 */

	result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
		    Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}

	/*
	 * Select the list item based on the index.  Negative operand means
	 * end-based indexing.
	 */

	if (opnd < -1) {
	    idx = opnd+1 + listc;
	} else {
	    idx = opnd;
	}
	if (idx >= 0 && idx < listc) {
	    objResultPtr = listv[idx];
	} else {
	    TclNewObj(objResultPtr);
	}

	TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr);
	NEXT_INST_F(5, 1, 1);
    }

    case INST_LIST_INDEX_MULTI: {

	/*
	 * 'lindex' with multiple index args:
	 *
	 * Determine the count of index args.
	 */

	int numIdx, opnd;

	opnd = TclGetUInt4AtPtr(pc+1);
	numIdx = opnd-1;

	/*
	 * Do the 'lindex' operation.
	 */

	objResultPtr = TclLindexFlat(interp, *(tosPtr - numIdx),
		numIdx, tosPtr - numIdx + 1);

	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */
	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
	NEXT_INST_V(5, opnd, -1);
    }

    case INST_LSET_FLAT: {

	/*
	 * Lset with 3, 5, or more args.  Get the number of index args.

	 */
	int numIdx,opnd;
	Tcl_Obj *valuePtr, *value2Ptr;

	opnd = TclGetUInt4AtPtr(pc + 1);
	numIdx = opnd - 2;

	/*
	 * Get the old value of variable, and remove the stack ref.  This is
	 * safe because the variable still references the object; the ref
	 * count will never go zero here.
	 */
	value2Ptr = POP_OBJECT();
	TclDecrRefCount(value2Ptr); /* This one should be done here */

	/*
	 * Get the new element value.
	 */
	valuePtr = *tosPtr;

	/*
	 * Compute the new variable value
	 */
	objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
		tosPtr - numIdx, valuePtr);

	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */
	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
	NEXT_INST_V(5, (numIdx+1), -1);
    }

    case INST_LSET_LIST: {

	/*
	 * 'lset' with 4 args.
	 */

	Tcl_Obj *objPtr, *valuePtr, *value2Ptr;

	/*
	 * Get the old value of variable, and remove the stack ref.  This is
	 * safe because the variable still references the object; the ref
	 * count will never go zero here.
	 */
	objPtr = POP_OBJECT();
	TclDecrRefCount(objPtr); /* This one should be done here */

	/*
	 * Get the new element value, and the index list
	 */
	valuePtr = *tosPtr;
	value2Ptr = *(tosPtr - 1);

	/*
	 * Compute the new variable value
	 */
	objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);

	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
		    Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */
	TRACE(("=> %s\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 2, -1);
    }

    case INST_LIST_RANGE_IMM: {

	/*** lrange with objc==4 and both indices in bytecode stream ***/

	int listc, fromIdx, toIdx;
	Tcl_Obj **listv;
	Tcl_Obj *valuePtr;

	/*
	 * Pop the list and get the indices
	 */
	valuePtr = *tosPtr;
	fromIdx = TclGetInt4AtPtr(pc+1);
	toIdx = TclGetInt4AtPtr(pc+5);

	/*
	 * Get the contents of the list, making sure that it really is a list
	 * in the process.
	 */
	result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
		    fromIdx, toIdx), Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}

	/*
	 * Skip a lot of work if we're about to throw the result away (common
	 * with uses of [lassign].)
	 */
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+9) == INST_POP) {
	    NEXT_INST_F(10, 1, 0);
	}
#endif

2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
		toIdx = -1;
	    }
	} else if (toIdx > listc) {
	    toIdx = listc;
	}

	/*
	 * Check if we are referring to a valid, non-empty list range,
	 * and if so, build the list of elements in that range.
	 */
	if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) {
	    if (fromIdx<0) {
		fromIdx = 0;
	    }
	    if (toIdx >= listc) {
		toIdx = listc-1;







|
|







2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
		toIdx = -1;
	    }
	} else if (toIdx > listc) {
	    toIdx = listc;
	}

	/*
	 * Check if we are referring to a valid, non-empty list range, and if
	 * so, build the list of elements in that range.
	 */
	if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) {
	    if (fromIdx<0) {
		fromIdx = 0;
	    }
	    if (toIdx >= listc) {
		toIdx = listc-1;
2878
2879
2880
2881
2882
2883
2884

2885
2886
2887
2888
2889
2890
2891
	int found, s1len, s2len, llen, i;
	Tcl_Obj *valuePtr, *value2Ptr, *o;
	char *s1, *s2;

	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);


	s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	result = Tcl_ListObjLength(interp, value2Ptr, &llen);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
		    O2S(value2Ptr)), Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}







>







3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
	int found, s1len, s2len, llen, i;
	Tcl_Obj *valuePtr, *value2Ptr, *o;
	char *s1, *s2;

	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	/* TODO: Consider more efficient tests than strcmp() */
	s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	result = Tcl_ListObjLength(interp, value2Ptr, &llen);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
		    O2S(value2Ptr)), Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}
2910
2911
2912
2913
2914
2915
2916
2917

2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947

2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015

3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066

3067
3068
3069
3070





3071





3072


3073


3074




3075
3076




3077
3078



3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193

3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220

3221
3222
3223
3224
3225
3226
3227
3228

3229
3230
3231


3232
3233
3234



3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294


3295














3296
3297
3298
3299
3300



3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315












3316







3317


3318
3319
3320
3321
3322
3323

3324


3325

3326

3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338



3339







3340

3341

3342



3343


3344







3345
3346
3347

3348
3349
3350

3351
3352
3353



3354
3355
3356
3357
3358

3359




3360
3361

3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381


3382
3383




3384

3385


3386

3387
3388
3389
3390


3391
3392




3393

3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412

3413

3414
3415


3416
3417


3418







3419
3420
3421



3422




3423
3424
3425
3426
3427

3428
3429
3430



3431
3432
3433
3434

3435
3436
3437
3438
3439
3440
3441
3442









3443
3444
3445

3446



3447











3448






3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487





3488















































































































































































































3489
3490
































































3491




























































































































































3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571






















3572
3573
3574
3575
3576
3577








3578
3579
3580

3581

3582
3583
3584
3585
3586
3587

























3588
3589
3590
3591
3592
3593







3594
3595
3596

3597


3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789



































































































































































































































































3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805




3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968

3969
3970
3971

3972





3973


3974
3975

3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015

4016
4017
4018

4019





4020


4021
4022

4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074

4075
4076

4077



4078


4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102







4103
4104
4105

4106
4107
4108
4109
4110








4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121

4122
4123

4124
4125
4126
4127
4128
4129
4130

4131


4132
4133
4134
4135
4136
4137
4138

4139




4140






4141
4142



4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153


4154


4155
4156
4157
4158





4159



4160
4161
4162
4163
4164
4165


4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191



4192
4193



4194
4195
4196

4197
4198



4199



4200




4201

4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214

4215


4216

4217


4218
4219




4220
4221


4222
4223
4224
4225
4226
4227

4228
4229
4230

4231






4232
4233
4234
4235
4236
4237
4238

4239
4240
4241
4242
4243
4244
4245

4246
4247

4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260






4261

4262


4263
4264
4265
4266
4267




4268
4269
4270
4271
4272
4273
4274


4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290





4291


4292



4293



4294



4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308


4309
4310
4311
4312
4313
4314
4315
4316

4317
4318
4319
4320
4321
4322
4323
4324



4325




4326
4327

4328
4329

4330
4331


4332
4333
4334
4335
4336



4337
4338
4339
4340
4341
4342

4343





4344
4345
4346

4347
4348
4349
4350
4351
4352
4353
4354

4355
4356
4357

4358


4359

4360
4361
4362
4363

4364
4365
4366
4367
4368
4369
4370

4371
4372

4373

4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385

4386

4387

4388
4389
4390


4391
4392
4393
4394

4395
4396
4397
4398
4399
4400
4401


4402
4403
4404
4405


4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421


4422
4423
4424
4425

4426
4427
4428
4429
4430
4431
4432
4433
4434

4435

















4436



4437
4438
4439

4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454


4455

4456
4457
4458
4459
4460
4461


4462
4463


4464

4465
4466
4467
4468
4469
4470
4471
4472

4473








4474
4475
4476
4477
4478
4479
4480
4481
4482



4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546

4547

4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609


4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697

4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
























































































































































































































































































































































































































































































































4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
	if (*pc == INST_LIST_NOT_IN) {
	    found = !found;
	}

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump

	 * from here.
	 */

	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	case INST_JUMP_FALSE1:
	    NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE1:
	    NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	case INST_JUMP_FALSE4:
	    NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE4:
	    NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = Tcl_NewBooleanObj(found);
	NEXT_INST_F(0, 2, 1);
    }

    /*
     *     End of INST_LIST and related instructions.
     * ---------------------------------------------------------
     */

    case INST_STR_EQ:
    case INST_STR_NEQ:
    {
	/*
	 * String (in)equality check

	 */
	int iResult;
	Tcl_Obj *valuePtr, *value2Ptr;

	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	if (valuePtr == value2Ptr) {
	    /*
	     * On the off-chance that the objects are the same,
	     * we don't really have to think hard about equality.
	     */
	    iResult = (*pc == INST_STR_EQ);
	} else {
	    char *s1, *s2;
	    int s1len, s2len;

	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    if (s1len == s2len) {
		/*
		 * We only need to check (in)equality when
		 * we have equal length strings.
		 */
		if (*pc == INST_STR_NEQ) {
		    iResult = (strcmp(s1, s2) != 0);
		} else {
		    /* INST_STR_EQ */
		    iResult = (strcmp(s1, s2) == 0);
		}
	    } else {
		iResult = (*pc == INST_STR_NEQ);
	    }
	}

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump
	 * from here.
	 */

	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	    case INST_JUMP_FALSE1:
		NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE1:
		NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	    case INST_JUMP_FALSE4:
		NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE4:
		NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = Tcl_NewIntObj(iResult);
	NEXT_INST_F(0, 2, 1);
    }

    case INST_STR_CMP:
    {
	/*
	 * String compare
	 */
	CONST char *s1, *s2;
	int s1len, s2len, iResult;
	Tcl_Obj *valuePtr, *value2Ptr;
	

	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	/*
	 * The comparison function should compare up to the
	 * minimum byte length only.
	 */
	if (valuePtr == value2Ptr) {
	    /*
	     * In the pure equality case, set lengths too for
	     * the checks below (or we could goto beyond it).
	     */
	    iResult = s1len = s2len = 0;
	} else if ((valuePtr->typePtr == &tclByteArrayType)
	        && (value2Ptr->typePtr == &tclByteArrayType)) {
	    s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
	    s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
	    iResult = memcmp(s1, s2, 
	            (size_t) ((s1len < s2len) ? s1len : s2len));
	} else if (((valuePtr->typePtr == &tclStringType)
	        && (value2Ptr->typePtr == &tclStringType))) {
	    /*
	     * Do a unicode-specific comparison if both of the args are of
	     * String type.  If the char length == byte length, we can do a
	     * memcmp.  In benchmark testing this proved the most efficient
	     * check between the unicode and string comparison operations.
	     */

	    s1len = Tcl_GetCharLength(valuePtr);
	    s2len = Tcl_GetCharLength(value2Ptr);
	    if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
		iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
			(unsigned) ((s1len < s2len) ? s1len : s2len));
	    } else {
		iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
			Tcl_GetUnicode(value2Ptr),
			(unsigned) ((s1len < s2len) ? s1len : s2len));
	    }
	} else {
	    /*
	     * We can't do a simple memcmp in order to handle the
	     * special Tcl \xC0\x80 null encoding for utf-8.
	     */
	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    iResult = TclpUtfNcmp2(s1, s2,
	            (size_t) ((s1len < s2len) ? s1len : s2len));
	}

	/*
	 * Make sure only -1,0,1 is returned

	 */
	if (iResult == 0) {
	    iResult = s1len - s2len;
	}





	if (iResult < 0) {





	    iResult = -1;


	} else if (iResult > 0) {


	    iResult = 1;




	}





	objResultPtr = Tcl_NewIntObj(iResult);
	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));



	NEXT_INST_F(1, 2, 1);
    }

    case INST_STR_LEN:
    {
	int length;
	Tcl_Obj *valuePtr;
		 
	valuePtr = *tosPtr;

	if (valuePtr->typePtr == &tclByteArrayType) {
	    (void) Tcl_GetByteArrayFromObj(valuePtr, &length);
	} else {
	    length = Tcl_GetCharLength(valuePtr);
	}
	objResultPtr = Tcl_NewIntObj(length);
	TRACE(("%.20s => %d\n", O2S(valuePtr), length));
	NEXT_INST_F(1, 1, 1);
    }
	    
    case INST_STR_INDEX:
    {
	/*
	 * String compare
	 */
	int index, length;
	char *bytes;
	Tcl_Obj *valuePtr, *value2Ptr;
	
	bytes = NULL; /* lint */
	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	/*
	 * If we have a ByteArray object, avoid indexing in the
	 * Utf string since the byte array contains one byte per
	 * character.  Otherwise, use the Unicode string rep to
	 * get the index'th char.
	 */

	if (valuePtr->typePtr == &tclByteArrayType) {
	    bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
	} else {
	    /*
	     * Get Unicode char length to calulate what 'end' means.
	     */
	    length = Tcl_GetCharLength(valuePtr);
	}

	result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
	if (result != TCL_OK) {
	    goto checkForCatch;
	}

	if ((index >= 0) && (index < length)) {
	    if (valuePtr->typePtr == &tclByteArrayType) {
		objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
		        (&bytes[index]), 1);
	    } else if (valuePtr->bytes && length == valuePtr->length) {
		objResultPtr = Tcl_NewStringObj((CONST char *)
		        (&valuePtr->bytes[index]), 1);
	    } else {
		char buf[TCL_UTF_MAX];
		Tcl_UniChar ch;

		ch = Tcl_GetUniChar(valuePtr, index);
		/*
		 * This could be:
		 * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
		 * but creating the object as a string seems to be
		 * faster in practical use.
		 */
		length = Tcl_UniCharToUtf(ch, buf);
		objResultPtr = Tcl_NewStringObj(buf, length);
	    }
	} else {
	    TclNewObj(objResultPtr);
	}

	TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), 
	        O2S(objResultPtr)));
	NEXT_INST_F(1, 2, 1);
    }

    case INST_STR_MATCH:
    {
	int nocase, match;
	Tcl_Obj *valuePtr, *value2Ptr;

	nocase    = TclGetInt1AtPtr(pc+1);
	valuePtr  = *tosPtr;	        /* String */
	value2Ptr = *(tosPtr - 1);	/* Pattern */

	/*
	 * Check that at least one of the objects is Unicode before
	 * promoting both.
	 */

	if ((valuePtr->typePtr == &tclStringType)
	        || (value2Ptr->typePtr == &tclStringType)) {
	    Tcl_UniChar *ustring1, *ustring2;
	    int length1, length2;

	    ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
	    ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
	    match = TclUniCharMatch(ustring1, length1, ustring2, length2,
		    nocase);
	} else {
	    match = Tcl_StringCaseMatch(TclGetString(valuePtr),
		    TclGetString(value2Ptr), nocase);
	}

	/*
	 * Reuse value2Ptr object already on stack if possible.
	 * Adjustment is 2 due to the nocase byte

	 */

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
	if (Tcl_IsShared(value2Ptr)) {
	    objResultPtr = Tcl_NewIntObj(match);
	    NEXT_INST_F(2, 2, 1);
	} else {	/* reuse the valuePtr object */
	    Tcl_SetIntObj(value2Ptr, match);
	    NEXT_INST_F(2, 1, 0);
	}
    }

    case INST_EQ:
    case INST_NEQ:
    case INST_LT:
    case INST_GT:
    case INST_LE:
    case INST_GE:
    {
	/*
	 * Any type is allowed but the two operands must have the
	 * same type. We will compute value op value2.
	 */

	Tcl_ObjType *t1Ptr, *t2Ptr;
	char *s1 = NULL;	/* Init. avoids compiler warning. */
	char *s2 = NULL;	/* Init. avoids compiler warning. */

	long i2 = 0;		/* Init. avoids compiler warning. */
	double d1 = 0.0;	/* Init. avoids compiler warning. */
	double d2 = 0.0;	/* Init. avoids compiler warning. */
	long iResult = 0;	/* Init. avoids compiler warning. */
	Tcl_Obj *valuePtr, *value2Ptr;
	int length;
	Tcl_WideInt w;
	long i;

		
	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1);



	/*
	 * Be careful in the equal-object case; 'NaN' isn't supposed



	 * to be equal to even itself. [Bug 761471]
	 */

	t1Ptr = valuePtr->typePtr;
	if (valuePtr == value2Ptr) {
	    /*
	     * If we are numeric already, or a dictionary (which is
	     * never like a single-element list), we can proceed to
	     * the main equality check right now.  Otherwise, we need
	     * to try to coerce to a numeric type so we can see if
	     * we've got a NaN but haven't parsed it as numeric.
	     */
	    if (!IS_NUMERIC_TYPE(t1Ptr) && (t1Ptr != &tclDictType)) {
		if (t1Ptr == &tclListType) {
		    int length;
		    /*
		     * Only a list of length 1 can be NaN or such
		     * things.
		     */
		    (void) Tcl_ListObjLength(NULL, valuePtr, &length);
		    if (length == 1) {
			goto mustConvertForNaNCheck;
		    }
		} else {
		    /*
		     * Too bad, we'll have to compute the string and
		     * try the conversion
		     */

		  mustConvertForNaNCheck:
		    s1 = Tcl_GetStringFromObj(valuePtr, &length);
		    if (TclLooksLikeInt(s1, length)) {
			GET_WIDE_OR_INT(iResult, valuePtr, i, w);
		    } else {
			(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				valuePtr, &d1);
		    }
		    t1Ptr = valuePtr->typePtr;
		}
	    }

	    switch (*pc) {
	    case INST_EQ:
	    case INST_LE:
	    case INST_GE:
		iResult = !((t1Ptr == &tclDoubleType)
			&& IS_NAN(valuePtr->internalRep.doubleValue));
		break;
	    case INST_LT:
	    case INST_GT:
		iResult = 0;
		break;
	    case INST_NEQ:
		iResult = ((t1Ptr == &tclDoubleType)
			&& IS_NAN(valuePtr->internalRep.doubleValue));
		break;
	    }
	    goto foundResult;
	}



	t2Ptr = value2Ptr->typePtr;















	/*
	 * We only want to coerce numeric validation if neither type
	 * is NULL.  A NULL type means the arg is essentially an empty
	 * object ("", {} or [list]).



	 */
	if (!(     (!t1Ptr && !valuePtr->bytes)
	        || (valuePtr->bytes && !valuePtr->length)
		   || (!t2Ptr && !value2Ptr->bytes)
		   || (value2Ptr->bytes && !value2Ptr->length))) {
	    if (!IS_NUMERIC_TYPE(t1Ptr)) {
		s1 = Tcl_GetStringFromObj(valuePtr, &length);
		if (TclLooksLikeInt(s1, length)) {
		    GET_WIDE_OR_INT(iResult, valuePtr, i, w);
		} else {
		    (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, 
		            valuePtr, &d1);
		}
		t1Ptr = valuePtr->typePtr;
	    }












	    if (!IS_NUMERIC_TYPE(t2Ptr)) {







		s2 = Tcl_GetStringFromObj(value2Ptr, &length);


		if (TclLooksLikeInt(s2, length)) {
		    GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
		} else {
		    (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		            value2Ptr, &d2);
		}

		t2Ptr = value2Ptr->typePtr;


	    }

	}

	if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
	    /*
	     * One operand is not numeric. Compare as strings.  NOTE:
	     * strcmp is not correct for \x00 < \x01, but that is
	     * unlikely to occur here.  We could use the TclUtfNCmp2
	     * to handle this.
	     */
	    int s1len, s2len;
	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    switch (*pc) {
	        case INST_EQ:



		    if (s1len == s2len) {







			iResult = (strcmp(s1, s2) == 0);

		    } else {

			iResult = 0;



		    }


		    break;







	        case INST_NEQ:
		    if (s1len == s2len) {
			iResult = (strcmp(s1, s2) != 0);

		    } else {
			iResult = 1;
		    }

		    break;
	        case INST_LT:
		    iResult = (strcmp(s1, s2) < 0);



		    break;
	        case INST_GT:
		    iResult = (strcmp(s1, s2) > 0);
		    break;
	        case INST_LE:

		    iResult = (strcmp(s1, s2) <= 0);




		    break;
	        case INST_GE:

		    iResult = (strcmp(s1, s2) >= 0);
		    break;
	    }
	} else if ((t1Ptr == &tclDoubleType)
		   || (t2Ptr == &tclDoubleType)) {
	    /*
	     * Compare as doubles.
	     */
	    if (t1Ptr == &tclDoubleType) {
		d1 = valuePtr->internalRep.doubleValue;
		GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
	    } else {	/* t1Ptr is integer, t2Ptr is double */
		GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
		d2 = value2Ptr->internalRep.doubleValue;
	    }
	    switch (*pc) {
	        case INST_EQ:
		    iResult = d1 == d2;
		    break;
	        case INST_NEQ:


		    iResult = d1 != d2;
		    break;




	        case INST_LT:

		    iResult = d1 < d2;


		    break;

	        case INST_GT:
		    iResult = d1 > d2;
		    break;
	        case INST_LE:


		    iResult = d1 <= d2;
		    break;




	        case INST_GE:

		    iResult = d1 >= d2;
		    break;
	    }
	} else if ((t1Ptr == &tclWideIntType)
	        || (t2Ptr == &tclWideIntType)) {
	    Tcl_WideInt w2;
	    /*
	     * Compare as wide ints (neither are doubles)
	     */
	    if (t1Ptr == &tclIntType) {
		w  = Tcl_LongAsWide(valuePtr->internalRep.longValue);
		TclGetWide(w2,value2Ptr);
	    } else if (t2Ptr == &tclIntType) {
		TclGetWide(w,valuePtr);
		w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
	    } else {
		TclGetWide(w,valuePtr);
		TclGetWide(w2,value2Ptr);
	    }

	    switch (*pc) {

	        case INST_EQ:
		    iResult = w == w2;


		    break;
	        case INST_NEQ:


		    iResult = w != w2;







		    break;
	        case INST_LT:
		    iResult = w < w2;



		    break;




	        case INST_GT:
		    iResult = w > w2;
		    break;
	        case INST_LE:
		    iResult = w <= w2;

		    break;
	        case INST_GE:
		    iResult = w >= w2;



		    break;
	    }
	} else {
	    /*

	     * Compare as ints.
	     */
	    i  = valuePtr->internalRep.longValue;
	    i2 = value2Ptr->internalRep.longValue;
	    switch (*pc) {
	        case INST_EQ:
		    iResult = i == i2;
		    break;









	        case INST_NEQ:
		    iResult = i != i2;
		    break;

	        case INST_LT:



		    iResult = i < i2;











		    break;






	        case INST_GT:
		    iResult = i > i2;
		    break;
	        case INST_LE:
		    iResult = i <= i2;
		    break;
	        case INST_GE:
		    iResult = i >= i2;
		    break;
	    }
	}

	TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump
	 * from here.
	 */

      foundResult:
	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	    case INST_JUMP_FALSE1:
		NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE1:
		NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	    case INST_JUMP_FALSE4:
		NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE4:
		NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = Tcl_NewIntObj(iResult);
	NEXT_INST_F(0, 2, 1);
    }

    case INST_MOD:
    case INST_LSHIFT:





    case INST_RSHIFT:















































































































































































































    case INST_BITOR:
    case INST_BITXOR:
































































    case INST_BITAND:




























































































































































    {
	/*
	 * Only integers are allowed. We compute value op value2.
	 */

	long i = 0, i2 = 0, rem, negative;
	long iResult = 0; /* Init. avoids compiler warning. */
	Tcl_WideInt w, w2, wResult = W0;
	int doWide = 0;
	Tcl_Obj *valuePtr, *value2Ptr;
	
	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1); 
	if (valuePtr->typePtr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    TclGetWide(w,valuePtr);
	} else {	/* try to convert to int */
	    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
		        O2S(valuePtr), O2S(value2Ptr), 
		        (valuePtr->typePtr? 
			     valuePtr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	}
	if (value2Ptr->typePtr == &tclIntType) {
	    i2 = value2Ptr->internalRep.longValue;
	} else if (value2Ptr->typePtr == &tclWideIntType) {
	    TclGetWide(w2,value2Ptr);
	} else {
	    REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
		        O2S(valuePtr), O2S(value2Ptr),
		        (value2Ptr->typePtr?
			    value2Ptr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);
		goto checkForCatch;
	    }
	}

	switch (*pc) {
	case INST_MOD:
	    /*
	     * This code is tricky: C doesn't guarantee much about
	     * the quotient or remainder, but Tcl does. The
	     * remainder always has the same sign as the divisor and
	     * a smaller absolute value.
	     */
	    if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
		if (valuePtr->typePtr == &tclIntType) {
		    TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
		} else {
		    TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
		}
		goto divideByZero;
	    }
	    if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
		if (valuePtr->typePtr == &tclIntType) {
		    TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
		} else {
		    TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
		}
		goto divideByZero;
	    }
	    negative = 0;
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		Tcl_WideInt wRemainder;
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}






















		if (w2 < 0) {
		    w2 = -w2;
		    w = -w;
		    negative = 1;
		}
		wRemainder  = w % w2;








		if (wRemainder < 0) {
		    wRemainder += w2;
		}

		if (negative) {

		    wRemainder = -wRemainder;
		}
		wResult = wRemainder;
		doWide = 1;
		break;
	    }

























	    if (i2 < 0) {
		i2 = -i2;
		i = -i;
		negative = 1;
	    }
	    rem  = i % i2;







	    if (rem < 0) {
		rem += i2;
	    }

	    if (negative) {


		rem = -rem;
	    }
	    iResult = rem;
	    break;
	case INST_LSHIFT:
	    /*
	     * Shifts are never usefully 64-bits wide!
	     */
	    FORCE_LONG(value2Ptr, i2, w2);
	    if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
		w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
		wResult = w;
		/*
		 * Shift in steps when the shift gets large to prevent
		 * annoying compiler/processor bugs. [Bug 868467]
		 */
		if (i2 >= 64) {
		    wResult = Tcl_LongAsWide(0);
		} else if (i2 > 60) {
		    wResult = w << 30;
		    wResult <<= 30;
		    wResult <<= i2-60;
		} else if (i2 > 30) {
		    wResult = w << 30;
		    wResult <<= i2-30;
		} else {
		    wResult = w << i2;
		}
		doWide = 1;
		break;
	    }
	    /*
	     * Shift in steps when the shift gets large to prevent
	     * annoying compiler/processor bugs. [Bug 868467]
	     */
	    if (i2 >= 64) {
		iResult = 0;
	    } else if (i2 > 60) {
		iResult = i << 30;
		iResult <<= 30;
		iResult <<= i2-60;
	    } else if (i2 > 30) {
		iResult = i << 30;
		iResult <<= i2-30;
	    } else {
		iResult = i << i2;
	    }
	    break;
	case INST_RSHIFT:
	    /*
	     * The following code is a bit tricky: it ensures that
	     * right shifts propagate the sign bit even on machines
	     * where ">>" won't do it by default.
	     */
	    /*
	     * Shifts are never usefully 64-bits wide!
	     */
	    FORCE_LONG(value2Ptr, i2, w2);
	    if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
		w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
		if (w < 0) {
		    wResult = ~w;
		} else {
		    wResult = w;
		}
		/*
		 * Shift in steps when the shift gets large to prevent
		 * annoying compiler/processor bugs. [Bug 868467]
		 */
		if (i2 >= 64) {
		    wResult = Tcl_LongAsWide(0);
		} else if (i2 > 60) {
		    wResult >>= 30;
		    wResult >>= 30;
		    wResult >>= i2-60;
		} else if (i2 > 30) {
		    wResult >>= 30;
		    wResult >>= i2-30;
		} else {
		    wResult >>= i2;
		}
		if (w < 0) {
		    wResult = ~wResult;
		}
		doWide = 1;
		break;
	    }
	    if (i < 0) {
		iResult = ~i;
	    } else {
		iResult = i;
	    }
	    /*
	     * Shift in steps when the shift gets large to prevent
	     * annoying compiler/processor bugs. [Bug 868467]
	     */
	    if (i2 >= 64) {
		iResult = 0;
	    } else if (i2 > 60) {
		iResult >>= 30;
		iResult >>= 30;
		iResult >>= i2-60;
	    } else if (i2 > 30) {
		iResult >>= 30;
		iResult >>= i2-30;
	    } else {
		iResult >>= i2;
	    }
	    if (i < 0) {
		iResult = ~iResult;
	    }
	    break;
	case INST_BITOR:
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		wResult = w | w2;
		doWide = 1;
		break;
	    }
	    iResult = i | i2;
	    break;
	case INST_BITXOR:
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		wResult = w ^ w2;
		doWide = 1;
		break;
	    }
	    iResult = i ^ i2;
	    break;
	case INST_BITAND:
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		wResult = w & w2;
		doWide = 1;
		break;
	    }
	    iResult = i & i2;
	    break;
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */
		
	if (Tcl_IsShared(valuePtr)) {
	    if (doWide) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
	    } else {
		objResultPtr = Tcl_NewLongObj(iResult);
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
	    }
	    NEXT_INST_F(1, 2, 1);
	} else {	/* reuse the valuePtr object */
	    if (doWide) {
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		Tcl_SetWideIntObj(valuePtr, wResult);
	    } else {
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		Tcl_SetLongObj(valuePtr, iResult);
	    }
	    NEXT_INST_F(1, 1, 0);
	}



































































































































































































































































    }

    case INST_ADD:
    case INST_SUB:
    case INST_MULT:
    case INST_DIV:
    case INST_EXPON:
    {
	/*
	 * Operands must be numeric and ints get converted to floats
	 * if necessary. We compute value op value2.
	 */

	Tcl_ObjType *t1Ptr, *t2Ptr;
	long i = 0, i2 = 0, quot, rem;	/* Init. avoids compiler warning. */
	double d1, d2;




	long iResult = 0;	/* Init. avoids compiler warning. */
	double dResult = 0.0;	/* Init. avoids compiler warning. */
	int doDouble = 0;	/* 1 if doing floating arithmetic */
	Tcl_WideInt w, w2, wquot, wrem;
	Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
	int doWide = 0;		/* 1 if doing wide arithmetic. */
	Tcl_Obj *valuePtr,*value2Ptr;
	int length;
	
	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1);
	t1Ptr = valuePtr->typePtr;
	t2Ptr = value2Ptr->typePtr;
		
	if (t1Ptr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
	} else if (t1Ptr == &tclWideIntType) {
	    TclGetWide(w,valuePtr);
	} else if ((t1Ptr == &tclDoubleType)
		   && (valuePtr->bytes == NULL)) {
	    /*
	     * We can only use the internal rep directly if there is
	     * no string rep.  Otherwise the string rep might actually
	     * look like an integer, which is preferred.
	     */

	    d1 = valuePtr->internalRep.doubleValue;
	} else {
	    char *s = Tcl_GetStringFromObj(valuePtr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, valuePtr, i, w);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
					      valuePtr, &d1);
	    }
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
		        s, O2S(valuePtr),
		        (valuePtr->typePtr?
			    valuePtr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	    t1Ptr = valuePtr->typePtr;
	}

	if (t2Ptr == &tclIntType) {
	    i2 = value2Ptr->internalRep.longValue;
	} else if (t2Ptr == &tclWideIntType) {
	    TclGetWide(w2,value2Ptr);
	} else if ((t2Ptr == &tclDoubleType)
		   && (value2Ptr->bytes == NULL)) {
	    /*
	     * We can only use the internal rep directly if there is
	     * no string rep.  Otherwise the string rep might actually
	     * look like an integer, which is preferred.
	     */

	    d2 = value2Ptr->internalRep.doubleValue;
	} else {
	    char *s = Tcl_GetStringFromObj(value2Ptr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		        value2Ptr, &d2);
	    }
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
		        O2S(value2Ptr), s,
		        (value2Ptr->typePtr?
			    value2Ptr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);
		goto checkForCatch;
	    }
	    t2Ptr = value2Ptr->typePtr;
	}

	if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
	    /*
	     * Do double arithmetic.
	     */
	    doDouble = 1;
	    if (t1Ptr == &tclIntType) {
		d1 = i;       /* promote value 1 to double */
	    } else if (t2Ptr == &tclIntType) {
		d2 = i2;      /* promote value 2 to double */
	    } else if (t1Ptr == &tclWideIntType) {
		d1 = Tcl_WideAsDouble(w);
	    } else if (t2Ptr == &tclWideIntType) {
		d2 = Tcl_WideAsDouble(w2);
	    }
	    switch (*pc) {
	        case INST_ADD:
		    dResult = d1 + d2;
		    break;
	        case INST_SUB:
		    dResult = d1 - d2;
		    break;
	        case INST_MULT:
		    dResult = d1 * d2;
		    break;
	        case INST_DIV:
		    if (d2 == 0.0) {
			TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
			goto divideByZero;
		    }
		    dResult = d1 / d2;
		    break;
		case INST_EXPON:
		    if (d1==0.0 && d2<0.0) {
			TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
			goto exponOfZero;
		    }
		    dResult = pow(d1, d2);
		    break;
	    }
		    
	    /*
	     * Check now for IEEE floating-point error.
	     */
		    
	    if (IS_NAN(dResult) || IS_INF(dResult)) {
		TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
		        O2S(valuePtr), O2S(value2Ptr)));
		TclExprFloatError(interp, dResult);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	} else if ((t1Ptr == &tclWideIntType) 
		   || (t2Ptr == &tclWideIntType)) {
	    /*
	     * Do wide integer arithmetic.
	     */
	    doWide = 1;
	    if (t1Ptr == &tclIntType) {
		w = Tcl_LongAsWide(i);
	    } else if (t2Ptr == &tclIntType) {
		w2 = Tcl_LongAsWide(i2);
	    }
	    switch (*pc) {
	        case INST_ADD:
		    wResult = w + w2;
		    break;
	        case INST_SUB:
		    wResult = w - w2;
		    break;
	        case INST_MULT:
		    wResult = w * w2;
		    break;
	        case INST_DIV:
		    /*
		     * This code is tricky: C doesn't guarantee much
		     * about the quotient or remainder, but Tcl does.
		     * The remainder always has the same sign as the
		     * divisor and a smaller absolute value.
		     */
		    if (w2 == W0) {
			TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
			goto divideByZero;
		    }
		    if (w2 < 0) {
			w2 = -w2;

			w = -w;
		    }
		    wquot = w / w2;

		    wrem  = w % w2;





		    if (wrem < W0) {


			wquot -= 1;
		    }

		    wResult = wquot;
		    break;
		case INST_EXPON: {
		    int errExpon;

		    wResult = ExponWide(w, w2, &errExpon);
		    if (errExpon) {
			TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2));
			goto exponOfZero;
		    }
		    break;
		}
	    }
	} else {
	    /*
	     * Do integer arithmetic.
	     */
	    switch (*pc) {
	        case INST_ADD:
		    iResult = i + i2;
		    break;
	        case INST_SUB:
		    iResult = i - i2;
		    break;
	        case INST_MULT:
		    iResult = i * i2;
		    break;
	        case INST_DIV:
		    /*
		     * This code is tricky: C doesn't guarantee much
		     * about the quotient or remainder, but Tcl does.
		     * The remainder always has the same sign as the
		     * divisor and a smaller absolute value.
		     */
		    if (i2 == 0) {
			TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
			goto divideByZero;
		    }
		    if (i2 < 0) {
			i2 = -i2;

			i = -i;
		    }
		    quot = i / i2;

		    rem  = i % i2;





		    if (rem < 0) {


			quot -= 1;
		    }

		    iResult = quot;
		    break;
		case INST_EXPON: {
		    int errExpon;

		    iResult = ExponLong(i, i2, &errExpon);
		    if (errExpon) {
			TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2));
			goto exponOfZero;
		    }
		    break;
		}
	    }
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */
		
	if (Tcl_IsShared(valuePtr)) {
	    if (doDouble) {
		objResultPtr = Tcl_NewDoubleObj(dResult);
		TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
	    } else if (doWide) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
	    } else {
		objResultPtr = Tcl_NewLongObj(iResult);
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
	    } 
	    NEXT_INST_F(1, 2, 1);
	} else {	    /* reuse the valuePtr object */
	    if (doDouble) { /* NB: stack top is off by 1 */
		TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
		Tcl_SetDoubleObj(valuePtr, dResult);
	    } else if (doWide) {
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		Tcl_SetWideIntObj(valuePtr, wResult);
	    } else {
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		Tcl_SetLongObj(valuePtr, iResult);
	    }
	    NEXT_INST_F(1, 1, 0);
	}
    }

    case INST_UPLUS:
    {
	/*
	 * Operand must be numeric.
	 */


	double d;
	Tcl_ObjType *tPtr;

	Tcl_Obj *valuePtr;



	


	valuePtr = *tosPtr;
	tPtr = valuePtr->typePtr;
	if (IS_INTEGER_TYPE(tPtr) 
		|| ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) {
	    /*
	     * We already have a numeric internal rep, either some kind
	     * of integer, or a "pure" double.  (Need "pure" so that we
	     * know the string rep of the double would not prefer to be
	     * interpreted as an integer.)
	     */
	} else {
	    /*
	     * Otherwise, we need to generate a numeric internal rep.
	     * from the string rep.
	     */
	    int length;
	    long i;     /* Set but never used, needed in GET_WIDE_OR_INT */
	    Tcl_WideInt w;
	    char *s = Tcl_GetStringFromObj(valuePtr, &length);

	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, valuePtr, i, w);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);







	    }
	    if (result != TCL_OK) { 
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",

		        s, (tPtr? tPtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	    tPtr = valuePtr->typePtr;








	}

	/*
	 * Ensure that the operand's string rep is the same as the
	 * formatted version of its internal rep. This makes sure
	 * that "expr +000123" yields "83", not "000123". We
	 * implement this by _discarding_ the string rep since we
	 * know it will be regenerated, if needed later, by
	 * formatting the internal rep's value.
	 */


	if (Tcl_IsShared(valuePtr)) {
	    if (tPtr == &tclIntType) {

		objResultPtr = Tcl_NewLongObj(valuePtr->internalRep.longValue);
	    } else if (tPtr == &tclWideIntType) {
		Tcl_WideInt w;

		TclGetWide(w,valuePtr);
		objResultPtr = Tcl_NewWideIntObj(w);
	    } else {

		objResultPtr = Tcl_NewDoubleObj(valuePtr->internalRep.doubleValue);


	    }
	    TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
	    NEXT_INST_F(1, 1, 1);
	} else {
	    Tcl_InvalidateStringRep(valuePtr);
	    TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
	    NEXT_INST_F(1, 0, 0);

	}




    }






	    
    case INST_UMINUS:



    case INST_LNOT:
    {
	/*
	 * The operand must be numeric or a boolean string as
	 * accepted by Tcl_GetBooleanFromObj(). If the operand
	 * object is unshared modify it directly, otherwise
	 * create a copy to modify: this is "copy on write".
	 * Free any old string representation since it is now
	 * invalid.
	 */



	double d;


	int boolvar;
	long i;
	Tcl_WideInt w;
	Tcl_ObjType *tPtr;





	Tcl_Obj *valuePtr;



	
	valuePtr = *tosPtr;
	tPtr = valuePtr->typePtr;
	if (IS_INTEGER_TYPE(tPtr) 
		|| ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) {
	    /*


	     * We already have a numeric internal rep, either some kind
	     * of integer, or a "pure" double.  (Need "pure" so that we
	     * know the string rep of the double would not prefer to be
	     * interpreted as an integer.)
	     */
	} else {
	    /*
	     * Otherwise, we need to generate a numeric internal rep.
	     * from the string rep.
	     */
	    if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
		valuePtr->typePtr = &tclIntType;
	    } else {
		int length;
		char *s = Tcl_GetStringFromObj(valuePtr, &length);
		if (TclLooksLikeInt(s, length)) {
		    GET_WIDE_OR_INT(result, valuePtr, i, w);
		} else {
		    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		            valuePtr, &d);
		}
		if (result == TCL_ERROR && *pc == INST_LNOT) {
		    result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
		            valuePtr, &boolvar);
		    i = (long)boolvar; /* i is long, not int! */
		}



		if (result != TCL_OK) {
		    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",



		            s, (tPtr? tPtr->name : "null")));
		    IllegalExprOperandType(interp, pc, valuePtr);
		    goto checkForCatch;

		}
	    }



	    tPtr = valuePtr->typePtr;



	}






	if (Tcl_IsShared(valuePtr)) {
	    /*
	     * Create a new object.
	     */
	    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
		i = valuePtr->internalRep.longValue;
		objResultPtr = Tcl_NewLongObj(
		    (*pc == INST_UMINUS)? -i : !i);
		TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
	    } else if (tPtr == &tclWideIntType) {
		TclGetWide(w,valuePtr);
		if (*pc == INST_UMINUS) {
		    objResultPtr = Tcl_NewWideIntObj(-w);

		} else {


		    objResultPtr = Tcl_NewLongObj(w == W0);

		}


		TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
	    } else {




		d = valuePtr->internalRep.doubleValue;
		if (*pc == INST_UMINUS) {


		    objResultPtr = Tcl_NewDoubleObj(-d);
		} else {
		    /*
		     * Should be able to use "!d", but apparently
		     * some compilers can't handle it.
		     */

		    objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
		}
		TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);

	    }






	    NEXT_INST_F(1, 1, 1);
	} else {
	    /*
	     * valuePtr is unshared. Modify it directly.
	     */
	    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
		i = valuePtr->internalRep.longValue;

		Tcl_SetLongObj(valuePtr,
	                (*pc == INST_UMINUS)? -i : !i);
		TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
	    } else if (tPtr == &tclWideIntType) {
		TclGetWide(w,valuePtr);
		if (*pc == INST_UMINUS) {
		    Tcl_SetWideIntObj(valuePtr, -w);

		} else {
		    Tcl_SetLongObj(valuePtr, w == W0);

		}
		TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
	    } else {
		d = valuePtr->internalRep.doubleValue;
		if (*pc == INST_UMINUS) {
		    Tcl_SetDoubleObj(valuePtr, -d);
		} else {
		    /*
		     * Should be able to use "!d", but apparently
		     * some compilers can't handle it.
		     */
		    Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
		}






		TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);

	    }


	    NEXT_INST_F(1, 0, 0);
	}
    }

    case INST_BITNOT:




    {
	/*
	 * The operand must be an integer. If the operand object is
	 * unshared modify it directly, otherwise modify a copy. 
	 * Free any old string representation since it is now
	 * invalid.
	 */


		
	Tcl_ObjType *tPtr;
	Tcl_Obj *valuePtr;
	Tcl_WideInt w;
	long i;

	valuePtr = *tosPtr;
	tPtr = valuePtr->typePtr;
	if (!IS_INTEGER_TYPE(tPtr)) {
	    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
	    if (result != TCL_OK) {   /* try to convert to double */
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
		        O2S(valuePtr), (tPtr? tPtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }





	}


		



	if (valuePtr->typePtr == &tclWideIntType) {



	    TclGetWide(w,valuePtr);



	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewWideIntObj(~w);
		TRACE(("0x%llx => (%llu)\n", w, ~w));
		NEXT_INST_F(1, 1, 1);
	    } else {
		/*
		 * valuePtr is unshared. Modify it directly.
		 */
		Tcl_SetWideIntObj(valuePtr, ~w);
		TRACE(("0x%llx => (%llu)\n", w, ~w));
		NEXT_INST_F(1, 0, 0);
	    }
	} else {
	    i = valuePtr->internalRep.longValue;


	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewLongObj(~i);
		TRACE(("0x%lx => (%lu)\n", i, ~i));
		NEXT_INST_F(1, 1, 1);
	    } else {
		/*
		 * valuePtr is unshared. Modify it directly.
		 */

		Tcl_SetLongObj(valuePtr, ~i);
		TRACE(("0x%lx => (%lu)\n", i, ~i));
		NEXT_INST_F(1, 0, 0);
	    }
	}
    }

    case INST_CALL_BUILTIN_FUNC1:



        {




	    int opnd;
	    BuiltinFunc *mathFuncPtr;

	
	    /*

	     * Call one of the built-in Tcl math functions.
	     */



	    opnd = TclGetUInt1AtPtr(pc+1);
	    if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
		TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
		Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);



	    }
	    mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
	    result = (*mathFuncPtr->proc)(interp, tosPtr,
	            mathFuncPtr->clientData);
	    if (result != TCL_OK) {
		goto checkForCatch;

	    }





	    tosPtr -= (mathFuncPtr->numArgs - 1);
	    TRACE_WITH_OBJ(("%d => ", opnd), *tosPtr);
	}

	NEXT_INST_F(2, 0, 0);
		    
    case INST_CALL_FUNC1:
	{
	    /*
	     * Call a non-builtin Tcl math function previously
	     * registered by a call to Tcl_CreateMathFunc.
	     */

		
	    int objc;          /* Number of arguments. The function name
				* is the 0-th argument. */

	    Tcl_Obj **objv;    /* The array of arguments. The function


				* name is objv[0]. */


	    objc = TclGetUInt1AtPtr(pc+1);
	    objv = (tosPtr - (objc-1)); /* "objv[0]" */
	    DECACHE_STACK_INFO();

	    result = ExprCallMathFunc(interp, objc, objv);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		goto checkForCatch;
	    }
	    tosPtr = objv;
	    TRACE_WITH_OBJ(("%d => ", objc), *tosPtr);

	}
	NEXT_INST_F(2, 0, 0);



    case INST_TRY_CVT_TO_NUMERIC:
    {
	/*
	 * Try to convert the topmost stack object to an int or
	 * double object. This is done in order to support Tcl's
	 * policy of interpreting operands if at all possible as
	 * first integers, else floating-point numbers.
	 */
		
	double d;
	char *s;
	Tcl_ObjType *tPtr;

	int converted, needNew, length;

	Tcl_Obj *valuePtr;

	long i;
	Tcl_WideInt w;
	


	valuePtr = *tosPtr;
	tPtr = valuePtr->typePtr;
	converted = 0;
	if (IS_INTEGER_TYPE(tPtr) 

		|| ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) {
	    /*
	     * We already have a numeric internal rep, either some kind
	     * of integer, or a "pure" double.  (Need "pure" so that we
	     * know the string rep of the double would not prefer to be
	     * interpreted as an integer.)
	     */


	} else {
	    /*
	     * Otherwise, we need to generate a numeric internal rep.
	     * from the string rep.


	     */
	    if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
		valuePtr->typePtr = &tclIntType;
		converted = 1;
	    } else {
		s = Tcl_GetStringFromObj(valuePtr, &length);
		if (TclLooksLikeInt(s, length)) {
		    GET_WIDE_OR_INT(result, valuePtr, i, w);
		} else {
		    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		            valuePtr, &d);
		}
		if (result == TCL_OK) {
		    converted = 1;
		}
		result = TCL_OK; /* reset the result variable */


	    }
	    tPtr = valuePtr->typePtr;
	}


	/*
	 * Ensure that the topmost stack object, if numeric, has a
	 * string rep the same as the formatted version of its
	 * internal rep. This is used, e.g., to make sure that "expr
	 * {0001}" yields "1", not "0001". We implement this by
	 * _discarding_ the string rep since we know it will be
	 * regenerated, if needed later, by formatting the internal
	 * rep's value. Also check if there has been an IEEE
	 * floating point error.

	 */

















	



	objResultPtr = valuePtr;
	needNew = 0;
	if (IS_NUMERIC_TYPE(tPtr)) {

	    if (Tcl_IsShared(valuePtr)) {
		if (valuePtr->bytes != NULL) {
		    /*
		     * We only need to make a copy of the object
		     * when it already had a string rep
		     */
		    needNew = 1;
		    if (tPtr == &tclIntType) {
			i = valuePtr->internalRep.longValue;
			objResultPtr = Tcl_NewLongObj(i);
		    } else if (tPtr == &tclWideIntType) {
			TclGetWide(w,valuePtr);
			objResultPtr = Tcl_NewWideIntObj(w);
		    } else {
			d = valuePtr->internalRep.doubleValue;


			objResultPtr = Tcl_NewDoubleObj(d);

		    }
		    tPtr = objResultPtr->typePtr;
		}
	    } else {
		Tcl_InvalidateStringRep(valuePtr);
	    }


		
	    if (tPtr == &tclDoubleType) {


		d = objResultPtr->internalRep.doubleValue;

		if (IS_NAN(d) || IS_INF(d)) {
		    TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
		            O2S(objResultPtr)));
		    TclExprFloatError(interp, d);
		    result = TCL_ERROR;
		    goto checkForCatch;
		}
	    }

	    converted = converted;  /* lint, converted not used. */








	    TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
	            (converted? "converted" : "not converted"),
		    (needNew? "new Tcl_Obj" : "same Tcl_Obj")));
	} else {
	    TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
	}
	if (needNew) {
	    NEXT_INST_F(1, 1, 1);
	} else {



	    NEXT_INST_F(1, 0, 0);
	}
    }
	
    case INST_BREAK:
	DECACHE_STACK_INFO();
	Tcl_ResetResult(interp);
	CACHE_STACK_INFO();
	result = TCL_BREAK;
	cleanup = 0;
	goto processExceptionReturn;

    case INST_CONTINUE:
	DECACHE_STACK_INFO();
	Tcl_ResetResult(interp);
	CACHE_STACK_INFO();
	result = TCL_CONTINUE;
	cleanup = 0;
	goto processExceptionReturn;

    case INST_FOREACH_START4:
	{
	    /*
	     * Initialize the temporary local var that holds the count
	     * of the number of iterations of the loop body to -1.
	     */

	    int opnd;
	    ForeachInfo *infoPtr;
	    int iterTmpIndex;
	    Var *iterVarPtr;
	    Tcl_Obj *oldValuePtr;

	    opnd = TclGetUInt4AtPtr(pc+1);
	    infoPtr = (ForeachInfo *)
	            codePtr->auxDataArrayPtr[opnd].clientData;
	    iterTmpIndex = infoPtr->loopCtTemp;
	    iterVarPtr = &(compiledLocals[iterTmpIndex]);
	    oldValuePtr = iterVarPtr->value.objPtr;
	    
	    if (oldValuePtr == NULL) {
		iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
		Tcl_IncrRefCount(iterVarPtr->value.objPtr);
	    } else {
		Tcl_SetLongObj(oldValuePtr, -1);
	    }
	    TclSetVarScalar(iterVarPtr);
	    TclClearVarUndefined(iterVarPtr);
	    TRACE(("%u => loop iter count temp %d\n", 
		   opnd, iterTmpIndex));
	}
	    
#ifndef TCL_COMPILE_DEBUG
	/* 
	 * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
	 * immediately after INST_FOREACH_START4 - let us just fall
	 * through instead of jumping back to the top.
	 */

	pc += 5;
#else
	NEXT_INST_F(5, 0, 0);
#endif	
    case INST_FOREACH_STEP4:

	{

	    /*
	     * "Step" a foreach loop (i.e., begin its next iteration) by
	     * assigning the next value list element to each loop var.
	     */

	    int opnd;
	    ForeachInfo *infoPtr;
	    ForeachVarList *varListPtr;
	    int numLists;
	    Tcl_Obj *listPtr,*valuePtr, *value2Ptr;
	    List *listRepPtr;
	    Var *iterVarPtr, *listVarPtr;
	    int iterNum, listTmpIndex, listLen, numVars;
	    int varIndex, valIndex, continueLoop, j;
	    long i;
	    Var *varPtr;
	    char *part1;

	    opnd = TclGetUInt4AtPtr(pc+1);
	    infoPtr = (ForeachInfo *)
	            codePtr->auxDataArrayPtr[opnd].clientData;
	    numLists = infoPtr->numLists;

	    /*
	     * Increment the temp holding the loop iteration number.
	     */

	    iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
	    valuePtr = iterVarPtr->value.objPtr;
	    iterNum = (valuePtr->internalRep.longValue + 1);
	    Tcl_SetLongObj(valuePtr, iterNum);
		
	    /*
	     * Check whether all value lists are exhausted and we should
	     * stop the loop.
	     */

	    continueLoop = 0;
	    listTmpIndex = infoPtr->firstValueTemp;
	    for (i = 0;  i < numLists;  i++) {
		varListPtr = infoPtr->varLists[i];
		numVars = varListPtr->numVars;
		    
		listVarPtr = &(compiledLocals[listTmpIndex]);
		listPtr = listVarPtr->value.objPtr;
		result = Tcl_ListObjLength(interp, listPtr, &listLen);
		if (result != TCL_OK) {
		    TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
		            opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
		    goto checkForCatch;
		}
		if (listLen > (iterNum * numVars)) {
		    continueLoop = 1;
		}
		listTmpIndex++;
	    }

	    /*
	     * If some var in some var list still has a remaining list
	     * element iterate one more time. Assign to var the next
	     * element from its value list. We already checked above
	     * that each list temp holds a valid list object.


	     */
		
	    if (continueLoop) {
		listTmpIndex = infoPtr->firstValueTemp;
		for (i = 0;  i < numLists;  i++) {
		    varListPtr = infoPtr->varLists[i];
		    numVars = varListPtr->numVars;

		    listVarPtr = &(compiledLocals[listTmpIndex]);
		    listPtr = listVarPtr->value.objPtr;
		    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
		    listLen = listRepPtr->elemCount;
			
		    valIndex = (iterNum * numVars);
		    for (j = 0;  j < numVars;  j++) {
			int setEmptyStr = 0;
			if (valIndex >= listLen) {
			    setEmptyStr = 1;
			    TclNewObj(valuePtr);
			} else {
			    valuePtr = listRepPtr->elements[valIndex];
			}
			    
			varIndex = varListPtr->varIndexes[j];
			varPtr = &(compiledLocals[varIndex]);
			part1 = varPtr->name;
			while (TclIsVarLink(varPtr)) {
			    varPtr = varPtr->value.linkPtr;
			}
			if (TclIsVarDirectWritable(varPtr)) {
			    value2Ptr = varPtr->value.objPtr;
			    if (valuePtr != value2Ptr) {
				if (value2Ptr != NULL) {
				    TclDecrRefCount(value2Ptr);
				} else {
				    TclSetVarScalar(varPtr);
				    TclClearVarUndefined(varPtr);
				}
				varPtr->value.objPtr = valuePtr;
				Tcl_IncrRefCount(valuePtr);
			    }
			} else {
			    DECACHE_STACK_INFO();
			    value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, 
						     NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			    CACHE_STACK_INFO();
			    if (value2Ptr == NULL) {
				TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
					opnd, varIndex),
					Tcl_GetObjResult(interp));
				if (setEmptyStr) {
				    TclDecrRefCount(valuePtr);
				}
				result = TCL_ERROR;
				goto checkForCatch;
			    }
			}
			valIndex++;
		    }
		    listTmpIndex++;
		}
	    }
	    TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, 
	            iterNum, (continueLoop? "continue" : "exit")));

	    /* 
	     * Run-time peep-hole optimisation: the compiler ALWAYS follows
	     * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
	     * instruction and jump direct from here.
	     */

	    pc += 5;
	    if (*pc == INST_JUMP_FALSE1) {
		NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
	    } else {
		NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
	    }
	}

    case INST_BEGIN_CATCH4:
	/*
	 * Record start of the catch command with exception range index
	 * equal to the operand. Push the current stack depth onto the
	 * special catch stack.
	 */
	eePtr->stackPtr[++catchTop] = (Tcl_Obj *) (tosPtr - eePtr->stackPtr);
	TRACE(("%u => catchTop=%d, stackTop=%d\n",
	       TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), tosPtr - eePtr->stackPtr));

	NEXT_INST_F(5, 0, 0);

    case INST_END_CATCH:
	catchTop--;
	result = TCL_OK;
	TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1)));
	NEXT_INST_F(1, 0, 0);
	    
    case INST_PUSH_RESULT:
	objResultPtr = Tcl_GetObjResult(interp);
	TRACE_WITH_OBJ(("=> "), objResultPtr);

	/*
	 * See the comments at INST_INVOKE_STK
	 */
	{
	    Tcl_Obj *newObjResultPtr;
	    TclNewObj(newObjResultPtr);
	    Tcl_IncrRefCount(newObjResultPtr);
	    iPtr->objResultPtr = newObjResultPtr;
	}

	NEXT_INST_F(1, 0, -1);

    case INST_PUSH_RETURN_CODE:
	objResultPtr = Tcl_NewLongObj(result);
	TRACE(("=> %u\n", result));
	NEXT_INST_F(1, 0, 1);

























































































































































































































































































































































































































































































































    default:
	Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
    } /* end of switch on opCode */

    /*
     * Division by zero in an expression. Control only reaches this
     * point by "goto divideByZero".
     */
	
 divideByZero:
    Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
    Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
            (char *) NULL);

    result = TCL_ERROR;
    goto checkForCatch;

    /*
     * Exponentiation of zero by negative number in an expression.
     * Control only reaches this point by "goto exponOfZero".
     */

 exponOfZero:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "exponentiation of zero by negative power", -1));
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
	    "exponentiation of zero by negative power", (char *) NULL);
    result = TCL_ERROR;
    goto checkForCatch;

    /*
     * Block for variables needed to process exception returns
     */
    
    {

	ExceptionRange *rangePtr;  /* Points to closest loop or catch
				    * exception range enclosing the pc. Used
				    * by various instructions and processCatch
				    * to process break, continue, and
				    * errors. */ 
	Tcl_Obj *valuePtr;
	char *bytes;
	int length;
#if TCL_COMPILE_DEBUG
	int opnd;
#endif

        /*
	 * An external evaluation (INST_INVOKE or INST_EVAL) returned 
	 * something different from TCL_OK, or else INST_BREAK or 
	 * INST_CONTINUE were called.
	 */

	processExceptionReturn:
#if TCL_COMPILE_DEBUG    
	switch (*pc) {
	    case INST_INVOKE_STK1:
		opnd = TclGetUInt1AtPtr(pc+1);
		TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
		break;
	    case INST_INVOKE_STK4:
		opnd = TclGetUInt4AtPtr(pc+1);
		TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
		break;
	    case INST_EVAL_STK:
		/*
		 * Note that the object at stacktop has to be used
		 * before doing the cleanup.
		 */

		TRACE(("\"%.30s\" => ", O2S(*tosPtr)));
		break;
	    default:
		TRACE(("=> "));
	}		    
#endif	   
	if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
	    rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
	    if (rangePtr == NULL) {
		TRACE_APPEND(("no encl. loop or catch, returning %s\n",
				     StringForResultCode(result)));
		goto abnormalReturn;
	    } 
	    if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
		TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
		goto processCatch;
	    }
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
	    if (result == TCL_BREAK) {
		result = TCL_OK;
		pc = (codePtr->codeStart + rangePtr->breakOffset);
		TRACE_APPEND(("%s, range at %d, new pc %d\n",
				     StringForResultCode(result),
				     rangePtr->codeOffset, rangePtr->breakOffset));
		NEXT_INST_F(0, 0, 0);
	    } else {
		if (rangePtr->continueOffset == -1) {
		    TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
					 StringForResultCode(result)));
		    goto checkForCatch;
		} 
		result = TCL_OK;
		pc = (codePtr->codeStart + rangePtr->continueOffset);
		TRACE_APPEND(("%s, range at %d, new pc %d\n",
				     StringForResultCode(result),
				     rangePtr->codeOffset, rangePtr->continueOffset));
		NEXT_INST_F(0, 0, 0);
	    }
#if TCL_COMPILE_DEBUG    
	} else if (traceInstructions) {
	    if ((result != TCL_ERROR) && (result != TCL_RETURN))  {
		Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
		TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", 
			result, O2S(objPtr)));
	    } else {
		Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
		TRACE_APPEND(("%s, result= \"%s\"\n", 
			StringForResultCode(result), O2S(objPtr)));
	    }
#endif
	}
	
	/*
	 * Execution has generated an "exception" such as TCL_ERROR. If the
	 * exception is an error, record information about what was being
	 * executed when the error occurred. Find the closest enclosing
	 * catch range, if any. If no enclosing catch range is found, stop
	 * execution and return the "exception" code.
	 */
	
	checkForCatch:
	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	    bytes = GetSrcInfoForPc(pc, codePtr, &length);
	    if (bytes != NULL) {
		Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
	    }
	}
	iPtr->flags &= ~ERR_ALREADY_LOGGED;

	/*
	 * Clear all expansions that may have started after the last
	 * INST_BEGIN_CATCH. 
	 */

	while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
		((ptrdiff_t) eePtr->stackPtr[catchTop] <=
			(ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
	    Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
	    TclDecrRefCount(expandNestList);
	    expandNestList = objPtr;
	}

	/*
	 * We must not catch an exceeded limit.  Instead, it blows
	 * outwards until we either hit another interpreter (presumably
	 * where the limit is not exceeded) or we get to the top-level.
	 */
	if (Tcl_LimitExceeded(interp)) {
#ifdef TCL_COMPILE_DEBUG
	    if (traceInstructions) {
		fprintf(stdout, "   ... limit exceeded, returning %s\n",
			StringForResultCode(result));
	    }







|
>
|















|




|




|
<


>









|
|










|
|















|
<





|
|
|
|
|
|
|
|


|



|
<






|
>




|
|



|
|



|


|
|

|



















|
|




|




>




>
>
>
>
>
|
>
>
>
>
>
|
>
>
|
>
>
|
>
>
>
>
|
|
>
>
>
>
|
|
>
>
>



|
<


|







|



|
|
<






|





|
|
|
<



















|


|






<
|
|
|








|
|



|
<




|



|
|



|













|
|
>



<
|
|
<
<
<
|
|
<





|
<
<
<
<
<
|
|
<
<
>
|
|
<
<
<
|
|
<
>
|
<
|
>
>
|
<
<
>
>
>
|
<
|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
<
|
<
|
<
<
<
<
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<


|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
<
<
<
>
>
>
|
|
<
|
<
<
<
<
<
<
|
<

<
<
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
|
|

<
|

>
|
>
>
|
>
|
>
|
<
<
<
<
<
<
<
<
<
<
<
>
>
>
|
>
>
>
>
>
>
>
|
>
|
>
|
>
>
>
|
>
>

>
>
>
>
>
>
>
|
|
<
>
|
|
|
>
|
|
|
>
>
>
|
|
|
<
|
>
|
>
>
>
>
|
|
>
|
<
|
|
|
<
|
<
<
<
<
<
<
<
|
|
<
|

<
>
>
|

>
>
>
>
|
>
|
>
>
|
>
|
|

<
>
>
|

>
>
>
>
|
>
|

|
<
<
<
<
<
<
<
<
|
<
<
|
|
<
|
|
>
|
>
|
|
>
>

<
>
>
|
>
>
>
>
>
>
>
|
|
<
>
>
>
|
>
>
>
>
|
<
|
|
|
>
|
|
|
>
>
>

|
<
<
>
|
<
<
<
|
<
<

>
>
>
>
>
>
>
>
>
|
<
|
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
<
<
<

|
<


|



|
|
|
|
|
|
|
|


|



|
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|




|

|








|
|
|












|
|






|
<

|
|
|
|

















<

|









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
>
>
>
>
>
>
>
>
|
|
|
>
|
>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
>
>
>
>
>
>
>
|
|
|
>
|
>
>



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|


|


|






|


|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
<
<
<
|
<

|
|


<
<

>
>
>
>
|
|
|
|
|
|
<

|




|




|
<

|
|
|









|



|
|
<










|
<

|
|
|









|



|
|













|

|






|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
|
|
|
|
|
|
|

|



|
|

|




|
<










|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
<
>
|
|

>
|
>
>
>
>
>
|
>
>


>
|
|
|
|

|
|
|
|
|
|
|






|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
<
>
|
|

>
|
>
>
>
>
>
|
>
>


>
|
|
|
|

|
|
|
|
|
|
|






|


|


|


|

|




|


|


|



<
|
<
<
<
<
<
|
>
|
|
>
|
>
>
>
|
>
>
|
|
<
<
<
<
<
<
|
<
<
<
<
|
<
<
<
<
<
|
<
<
<
|
>
>
>
>
>
>
>

|
|
>
|
|
|
|
|
>
>
>
>
>
>
>
>
|
|
<
<
<
<
<
<
<
<
|
>
|
<
>
|
<
<
|
|
<
|
>
|
>
>
|
|
<
<
<
<
<
>
|
>
>
>
>
|
>
>
>
>
>
>
|
<
>
>
>
|
<
<
<
<
<
<
<
<
<
|
>
>
|
>
>
|
<
|
|
>
>
>
>
>
|
>
>
>
|
<
<
<
<
<
>
>
|
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|

|
<
|
<

>
>
>
|
<
>
>
>
|
<
<
>

<
>
>
>
|
>
>
>
|
>
>
>
>
|
>
|
<
|
<
<
<
|
<
|
|
<
<
|
>
|
>
>
|
>
|
>
>
|
|
>
>
>
>
|
|
>
>
|
<
<
|
|
<
>
|

|
>

>
>
>
>
>
>
|
<
<
<
<
<
<
>
|
<
<
<
|
|
<
>
|
<
>
|
<
|
|
<
|
<
<
<
<
<
<
|
>
>
>
>
>
>
|
>
|
>
>
|
|
|
<
|
>
>
>
>
|
<
<
<
<
|
<
>
>
|
<
<
<
<
|
<
<
<
<
<
|
|
|
|
|
>
>
>
>
>
|
>
>
|
>
>
>
|
>
>
>
|
>
>
>
|
|
<
<
|
<
<
<
|
<
<
|
<
|
>
>
|
|
<
|
<
<
<
<
>
|
<
|
|
|
<
<
|
>
>
>
|
>
>
>
>
|
<
>
|
<
>
|
<
>
>
|
<
|
|
|
>
>
>

<
<
<
|
|
>
|
>
>
>
>
>
|
<
|
>
|
|
<
<
<
<
<
<
>
|
<
|
>
|
>
>
|
>
|
<
<
|
>
|
|
<
<
|
|
<
>
|
<
>
|
>
|
<
<
|
|
|
|
|
|
|
|
|
>
|
>
|
>
|
|
|
>
>
|
|
<
|
>
|
<
<
<
<
<
<
>
>
|
|
<
|
>
>
|
<
<
<
|
|
<
<
<
<
<
|
<
<
|
<
>
>
|
<
|
|
>

|
<
|
<
<
<
<
<
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
<
|
>
|
|
<
<
<
<
<
<
<
<
<
|
<
|
<
>
>
|
>
|
|
|
|
<
|
>
>
|
|
>
>
|
>
|
|
<
<
<
|
|
<
>
|
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<

<
>
>
>
|
|
|
<
















|
<
|
|
|
|

|
|
|
|
|

|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
<

|
|
|
|





|
<
>
|
>
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|
<
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
>
>
|
|
|
|
|
|
|

|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
|



|
|
|



|
>







|

















|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|

|



|





|
|













|

<




|







|
|
|



|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|




|

|












|
|




|

|



|
|


|



|



|




|



|
|
|

|











|




|






|
|
|







3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091

3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133

3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153

3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254

3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270

3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285

3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314

3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331

3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364

3365
3366



3367
3368

3369
3370
3371
3372
3373
3374





3375
3376


3377
3378
3379



3380
3381

3382
3383

3384
3385
3386
3387


3388
3389
3390
3391

3392

3393















3394
3395
3396





3397

3398




3399
3400
3401


3402









3403






3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425



3426
3427
3428
3429
3430

3431






3432

3433


3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459

3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470











3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502

3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516

3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527

3528
3529
3530

3531







3532
3533

3534
3535

3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553

3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566








3567


3568
3569

3570
3571
3572
3573
3574
3575
3576
3577
3578
3579

3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591

3592
3593
3594
3595
3596
3597
3598
3599
3600

3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612


3613
3614



3615


3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626

3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662



3663
3664

3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167

4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189

4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
















4297









4298



4299








































































































































4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583



4584

4585
4586
4587
4588
4589


4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600

4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612

4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631

4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642

4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692







4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713

4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737

4738
4739
4740
4741
4742
4743

4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792

4793
4794
4795
4796
4797
4798

4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859

4860





4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874






4875




4876





4877



4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904








4905
4906
4907

4908
4909


4910
4911

4912
4913
4914
4915
4916
4917
4918





4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932

4933
4934
4935
4936









4937
4938
4939
4940
4941
4942
4943

4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955





4956
4957
4958
4959

4960












4961


4962
4963
4964

4965

4966
4967
4968
4969
4970

4971
4972
4973
4974


4975
4976

4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991

4992



4993

4994
4995


4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016


5017
5018

5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031






5032
5033



5034
5035

5036
5037

5038
5039

5040
5041

5042






5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057

5058
5059
5060
5061
5062
5063




5064

5065
5066
5067




5068





5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095


5096



5097


5098

5099
5100
5101
5102
5103

5104




5105
5106

5107
5108
5109


5110
5111
5112
5113
5114
5115
5116
5117
5118
5119

5120
5121

5122
5123

5124
5125
5126

5127
5128
5129
5130
5131
5132
5133



5134
5135
5136
5137
5138
5139
5140
5141
5142
5143

5144
5145
5146
5147






5148
5149

5150
5151
5152
5153
5154
5155
5156
5157


5158
5159
5160
5161


5162
5163

5164
5165

5166
5167
5168
5169


5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190

5191
5192
5193






5194
5195
5196
5197

5198
5199
5200
5201



5202
5203





5204


5205

5206
5207
5208

5209
5210
5211
5212
5213

5214





5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238

5239
5240
5241
5242









5243

5244

5245
5246
5247
5248
5249
5250
5251
5252

5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263



5264
5265

5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276






5277

5278
5279
5280
5281
5282
5283

5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300

5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313

5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326

5327

5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338

5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361

5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414

5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452

5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059

6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
	if (*pc == INST_LIST_NOT_IN) {
	    found = !found;
	}

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump from here.
	 * We're saving the effort of pushing a boolean value only to pop it
	 * for branching.
	 */

	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	case INST_JUMP_FALSE1:
	    NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE1:
	    NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	case INST_JUMP_FALSE4:
	    NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE4:
	    NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = eePtr->constants[found];
	NEXT_INST_F(0, 2, 1);
    }

    /*
     *	   End of INST_LIST and related instructions.
     * ---------------------------------------------------------
     */

    case INST_STR_EQ:
    case INST_STR_NEQ: {

	/*
	 * String (in)equality check
	 * TODO: Consider merging into INST_STR_CMP
	 */
	int iResult;
	Tcl_Obj *valuePtr, *value2Ptr;

	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	if (valuePtr == value2Ptr) {
	    /*
	     * On the off-chance that the objects are the same, we don't
	     * really have to think hard about equality.
	     */
	    iResult = (*pc == INST_STR_EQ);
	} else {
	    char *s1, *s2;
	    int s1len, s2len;

	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    if (s1len == s2len) {
		/*
		 * We only need to check (in)equality when we have equal
		 * length strings.
		 */
		if (*pc == INST_STR_NEQ) {
		    iResult = (strcmp(s1, s2) != 0);
		} else {
		    /* INST_STR_EQ */
		    iResult = (strcmp(s1, s2) == 0);
		}
	    } else {
		iResult = (*pc == INST_STR_NEQ);
	    }
	}

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump from here.

	 */

	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	case INST_JUMP_FALSE1:
	    NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE1:
	    NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	case INST_JUMP_FALSE4:
	    NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE4:
	    NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = eePtr->constants[iResult];
	NEXT_INST_F(0, 2, 1);
    }

    case INST_STR_CMP: {

	/*
	 * String compare
	 */
	CONST char *s1, *s2;
	int s1len, s2len, iResult;
	Tcl_Obj *valuePtr, *value2Ptr;

    stringCompare:
	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	/*
	 * The comparison function should compare up to the minimum byte
	 * length only.
	 */
	if (valuePtr == value2Ptr) {
	    /*
	     * In the pure equality case, set lengths too for the checks below
	     * (or we could goto beyond it).
	     */
	    iResult = s1len = s2len = 0;
	} else if ((valuePtr->typePtr == &tclByteArrayType)
		&& (value2Ptr->typePtr == &tclByteArrayType)) {
	    s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
	    s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
	    iResult = memcmp(s1, s2,
		    (size_t) ((s1len < s2len) ? s1len : s2len));
	} else if (((valuePtr->typePtr == &tclStringType)
		&& (value2Ptr->typePtr == &tclStringType))) {
	    /*
	     * Do a unicode-specific comparison if both of the args are of
	     * String type.  If the char length == byte length, we can do a
	     * memcmp.  In benchmark testing this proved the most efficient
	     * check between the unicode and string comparison operations.
	     */

	    s1len = Tcl_GetCharLength(valuePtr);
	    s2len = Tcl_GetCharLength(value2Ptr);
	    if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
		iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
			(unsigned) ((s1len < s2len) ? s1len : s2len));
	    } else {
		iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
			Tcl_GetUnicode(value2Ptr),
			(unsigned) ((s1len < s2len) ? s1len : s2len));
	    }
	} else {
	    /*
	     * We can't do a simple memcmp in order to handle the special Tcl
	     * \xC0\x80 null encoding for utf-8.
	     */
	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    iResult = TclpUtfNcmp2(s1, s2,
		    (size_t) ((s1len < s2len) ? s1len : s2len));
	}

	/*
	 * Make sure only -1,0,1 is returned
	 * TODO: consider peephole opt.
	 */
	if (iResult == 0) {
	    iResult = s1len - s2len;
	}

	if (*pc != INST_STR_CMP) {
	    /* Take care of the opcodes that goto'ed into here */
	    switch (*pc) {
	    case INST_EQ:
		iResult = (iResult == 0);
		break;
	    case INST_NEQ:
		iResult = (iResult != 0);
		break;
	    case INST_LT:
		iResult = (iResult < 0);
		break;
	    case INST_GT:
		iResult = (iResult > 0);
		break;
	    case INST_LE:
		iResult = (iResult <= 0);
		break;
	    case INST_GE:
		iResult = (iResult >= 0);
		break;
	    }
	} 
	if (iResult < 0) {
	    TclNewIntObj(objResultPtr, -1);
	    TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
	} else {
	    objResultPtr = eePtr->constants[(iResult>0)];
	    TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr),
		(iResult > 0)));
	}

	NEXT_INST_F(1, 2, 1);
    }

    case INST_STR_LEN: {

	int length;
	Tcl_Obj *valuePtr;

	valuePtr = *tosPtr;

	if (valuePtr->typePtr == &tclByteArrayType) {
	    (void) Tcl_GetByteArrayFromObj(valuePtr, &length);
	} else {
	    length = Tcl_GetCharLength(valuePtr);
	}
	TclNewIntObj(objResultPtr, length);
	TRACE(("%.20s => %d\n", O2S(valuePtr), length));
	NEXT_INST_F(1, 1, 1);
    }

    case INST_STR_INDEX: {

	/*
	 * String compare
	 */
	int index, length;
	char *bytes;
	Tcl_Obj *valuePtr, *value2Ptr;

	bytes = NULL; /* lint */
	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);

	/*
	 * If we have a ByteArray object, avoid indexing in the Utf string
	 * since the byte array contains one byte per character.  Otherwise,
	 * use the Unicode string rep to get the index'th char.

	 */

	if (valuePtr->typePtr == &tclByteArrayType) {
	    bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
	} else {
	    /*
	     * Get Unicode char length to calulate what 'end' means.
	     */
	    length = Tcl_GetCharLength(valuePtr);
	}

	result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
	if (result != TCL_OK) {
	    goto checkForCatch;
	}

	if ((index >= 0) && (index < length)) {
	    if (valuePtr->typePtr == &tclByteArrayType) {
		objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
			(&bytes[index]), 1);
	    } else if (valuePtr->bytes && length == valuePtr->length) {
		objResultPtr = Tcl_NewStringObj((CONST char *)
			(&valuePtr->bytes[index]), 1);
	    } else {
		char buf[TCL_UTF_MAX];
		Tcl_UniChar ch;

		ch = Tcl_GetUniChar(valuePtr, index);
		/*

		 * This could be: Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch,
		 * 1) but creating the object as a string seems to be faster
		 * in practical use.
		 */
		length = Tcl_UniCharToUtf(ch, buf);
		objResultPtr = Tcl_NewStringObj(buf, length);
	    }
	} else {
	    TclNewObj(objResultPtr);
	}

	TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
		O2S(objResultPtr)));
	NEXT_INST_F(1, 2, 1);
    }

    case INST_STR_MATCH: {

	int nocase, match;
	Tcl_Obj *valuePtr, *value2Ptr;

	nocase    = TclGetInt1AtPtr(pc+1);
	valuePtr  = *tosPtr;		/* String */
	value2Ptr = *(tosPtr - 1);	/* Pattern */

	/*
	 * Check that at least one of the objects is Unicode before promoting
	 * both.
	 */

	if ((valuePtr->typePtr == &tclStringType)
		|| (value2Ptr->typePtr == &tclStringType)) {
	    Tcl_UniChar *ustring1, *ustring2;
	    int length1, length2;

	    ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
	    ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
	    match = TclUniCharMatch(ustring1, length1, ustring2, length2,
		    nocase);
	} else {
	    match = Tcl_StringCaseMatch(TclGetString(valuePtr),
		    TclGetString(value2Ptr), nocase);
	}

	/*
	 * Reuse value2Ptr object already on stack if possible.  Adjustment is
	 * 2 due to the nocase byte
	 * TODO: consider peephole opt.
	 */

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));

	objResultPtr = eePtr->constants[match];
	NEXT_INST_F(2, 2, 1);



    }


    case INST_EQ:
    case INST_NEQ:
    case INST_LT:
    case INST_GT:
    case INST_LE:
    case INST_GE: {





	Tcl_Obj *valuePtr = *(tosPtr - 1);
	Tcl_Obj *value2Ptr = *tosPtr;


	ClientData ptr1, ptr2;
	int iResult, compare, type1, type2;
	double d1, d2, tmp;



	long l1, l2;
	Tcl_WideInt w1, w2;

	mp_int big1, big2;


	if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
	    /* At least one non-numeric argument - compare as strings */
	    goto stringCompare;
	}


	if (type1 == TCL_NUMBER_NAN) {
	    /* NaN first arg: NaN != to everything, other compares are false */
	    iResult = (*pc == INST_NEQ);
	    goto foundResult;

	}

	if (valuePtr == value2Ptr) {















	    compare = MP_EQ;
	    goto convertComparison;
	}





	if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {

	    /* At least one non-numeric argument - compare as strings */




	    goto stringCompare;
	}
	if (type2 == TCL_NUMBER_NAN) {


	    /* NaN 2nd arg: NaN != to everything, other compares are false */









	    iResult = (*pc == INST_NEQ);






	    goto foundResult;
	}
	switch (type1) {
	case TCL_NUMBER_LONG:
	    l1 = *((CONST long *)ptr1);
	    switch (type2) {
	    case TCL_NUMBER_LONG:
		l2 = *((CONST long *)ptr2);
	    longCompare:
		compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
		break;
#ifndef NO_WIDE_TYPE
	    case TCL_NUMBER_WIDE:
		w2 = *((CONST Tcl_WideInt *)ptr2);
		w1 = (Tcl_WideInt)l1;
		goto wideCompare;
#endif
	    case TCL_NUMBER_DOUBLE:
		d2 = *((CONST double *)ptr2);
		d1 = (double) l1;

		/* 



		 * If the double has a fractional part, or if the
		 * long can be converted to double without loss of
		 * precision, then compare as doubles.
		 */
		if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))

			|| (l1 == (long) d1) || (modf(d2, &tmp) != 0.0)) {






		    goto doubleCompare;

		}


		/*
		 * Otherwise, to make comparision based on full precision,
		 * need to convert the double to a suitably sized integer.
		 *
		 * Need this to get comparsions like
		 * 	expr 20000000000000003 < 20000000000000004.0 
		 * right.  Converting the first argument to double
		 * will yield two double values that are equivalent
		 * within double precision.  Converting the double to
		 * an integer gets done exactly, then integer comparison
		 * can tell the difference.
		 */
		if (d2 < (double)LONG_MIN) {
		    compare = MP_GT;
		    break;
		}
		if (d2 > (double)LONG_MAX) {
		    compare = MP_LT;
		    break;
		}
		l2 = (long) d2;
		goto longCompare;
	    case TCL_NUMBER_BIG:
		if (Tcl_IsShared(value2Ptr)) {
		    Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
		} else {

		    Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
		}
		if (mp_cmp_d(&big2, 0) == MP_LT) {
		    compare = MP_GT;
		} else {
		    compare = MP_LT;
		}
		mp_clear(&big2);
	    }
	    break;












#ifndef NO_WIDE_TYPE
	case TCL_NUMBER_WIDE:
	    w1 = *((CONST Tcl_WideInt *)ptr1);
	    switch (type2) {
	    case TCL_NUMBER_WIDE:
		w2 = *((CONST Tcl_WideInt *)ptr2);
	    wideCompare:
		compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
		break;
	    case TCL_NUMBER_LONG:
		l2 = *((CONST long *)ptr2);
		w2 = (Tcl_WideInt)l2;
		goto wideCompare;
	    case TCL_NUMBER_DOUBLE:
		d2 = *((CONST double *)ptr2);
		d1 = (double) w1;
		if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt))
			|| (w1 == (Tcl_WideInt) d1) || (modf(d2, &tmp) != 0.0)) {
		    goto doubleCompare;
		}
		if (d2 < (double)LLONG_MIN) {
		    compare = MP_GT;
		    break;
		}
		if (d2 > (double)LLONG_MAX) {
		    compare = MP_LT;
		    break;
		}
		w2 = (Tcl_WideInt) d2;
		goto wideCompare;
	    case TCL_NUMBER_BIG:
		if (Tcl_IsShared(value2Ptr)) {

		    Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
		} else {
		    Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
		}
		if (mp_cmp_d(&big2, 0) == MP_LT) {
		    compare = MP_GT;
		} else {
		    compare = MP_LT;
		}
		mp_clear(&big2);
	    }
	    break;
#endif


	case TCL_NUMBER_DOUBLE:
	    d1 = *((CONST double *)ptr1);
	    switch (type2) {
	    case TCL_NUMBER_DOUBLE:
		d2 = *((CONST double *)ptr2);
	    doubleCompare:
		compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
		break;
	    case TCL_NUMBER_LONG:
		l2 = *((CONST long *)ptr2);
		d2 = (double) l2;


		if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
			|| (l2 == (long) d2) || (modf(d1, &tmp) != 0.0)) {

		    goto doubleCompare;







		}
		if (d1 < (double)LONG_MIN) {

		    compare = MP_LT;
		    break;

		}
		if (d1 > (double)LONG_MAX) {
		    compare = MP_GT;
		    break;
		}
		l1 = (long) d1;
		goto longCompare;
#ifndef NO_WIDE_TYPE
	    case TCL_NUMBER_WIDE:
		w2 = *((CONST Tcl_WideInt *)ptr2);
		d2 = (double) w2;
		if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt))
			|| (w2 == (Tcl_WideInt) d2) || (modf(d1, &tmp) != 0.0)) {
		    goto doubleCompare;
		}
		if (d1 < (double)LLONG_MIN) {
		    compare = MP_LT;
		    break;

		}
		if (d1 > (double)LLONG_MAX) {
		    compare = MP_GT;
		    break;
		}
		w1 = (Tcl_WideInt) d1;
		goto wideCompare;
#endif
	    case TCL_NUMBER_BIG:
		if (TclIsInfinite(d1)) {
		    compare = (d1 > 0.0) ? MP_GT : MP_LT;
		    break;
		}








		if (Tcl_IsShared(value2Ptr)) {


		    Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
		} else {

		    Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
		}
		if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
		    if (mp_cmp_d(&big2, 0) == MP_LT) {
			compare = MP_GT;
		    } else {
			compare = MP_LT;
		    }
		    mp_clear(&big2);
		    break;

		}
		if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
			&& (modf(d1, &tmp) != 0.0)) {
		    d2 = TclBignumToDouble( &big2);
		    mp_clear(&big2);
		    goto doubleCompare;
		}
		TclInitBignumFromDouble(NULL, d1, &big1);
		goto bigCompare;
	    }
	    break;


	case TCL_NUMBER_BIG:
	    if (Tcl_IsShared(valuePtr)) {
		Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1);
	    }
	    switch (type2) {
#ifndef NO_WIDE_TYPE
	    case TCL_NUMBER_WIDE:

#endif
	    case TCL_NUMBER_LONG:
		compare = mp_cmp_d(&big1, 0);
		mp_clear(&big1);
		break;
	    case TCL_NUMBER_DOUBLE:
		d2 = *((CONST double *)ptr2);
		if (TclIsInfinite(d2)) {
		    compare = (d2 > 0.0) ? MP_LT : MP_GT;
		    mp_clear(&big1);
		    break;
		}


		if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
		    compare = mp_cmp_d(&big1, 0);



		    mp_clear(&big1);


		    break;
		}
		if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
			&& (modf(d2, &tmp) != 0.0)) {
		    d1 = TclBignumToDouble( &big1);
		    mp_clear(&big1);
		    goto doubleCompare;
		}
		TclInitBignumFromDouble(NULL, d2, &big2);
		goto bigCompare;
	    case TCL_NUMBER_BIG:

		if (Tcl_IsShared(value2Ptr)) {
		    Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
		} else {
		    Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
		}
	    bigCompare:
		compare = mp_cmp(&big1, &big2);
		mp_clear(&big1);
		mp_clear(&big2);
	    }
	}

	/* Turn comparison outcome into appropriate result for opcode */

    convertComparison:
	switch (*pc) {
	case INST_EQ:
	    iResult = (compare == MP_EQ);
	    break;
	case INST_NEQ:
	    iResult = (compare != MP_EQ);
	    break;
	case INST_LT:
	    iResult = (compare == MP_LT);
	    break;
	case INST_GT:
	    iResult = (compare == MP_GT);
	    break;
	case INST_LE:
	    iResult = (compare != MP_GT);
	    break;
	case INST_GE:
	    iResult = (compare != MP_LT);
	    break;
	}




	/*
	 * Peep-hole optimisation: if you're about to jump, do jump from here.

	 */

    foundResult:
	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	case INST_JUMP_FALSE1:
	    NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE1:
	    NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	case INST_JUMP_FALSE4:
	    NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	case INST_JUMP_TRUE4:
	    NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = eePtr->constants[iResult];
	NEXT_INST_F(0, 2, 1);
    }

    case INST_LSHIFT:
    case INST_RSHIFT: {
	Tcl_Obj *value2Ptr = *tosPtr;
	Tcl_Obj *valuePtr  = *(tosPtr - 1);
	ClientData ptr1, ptr2;
	int invalid, shift, type1, type2;
	long l;

	result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
	if ((result != TCL_OK)
		|| (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
	    result = TCL_ERROR;
	    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
		    O2S(value2Ptr), (valuePtr->typePtr?
		    valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}

	result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
	if ((result != TCL_OK)
		|| (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
	    result = TCL_ERROR;
	    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
		    O2S(value2Ptr), (value2Ptr->typePtr?
		    value2Ptr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    goto checkForCatch;
	}

	/* reject negative shift argument */
	switch (type2) {
	case TCL_NUMBER_LONG:
	    invalid = (*((CONST long *)ptr2) < (long)0);
	    break;
#ifndef NO_WIDE_TYPE
	case TCL_NUMBER_WIDE:
	    invalid = (*((CONST Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
	    break;
#endif
	case TCL_NUMBER_BIG:
	    /* TODO: const correctness ? */
	    invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT);
	}
	if (invalid) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("negative shift argument", -1));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/* Zero shifted any number of bits is still zero */
	if ((type1 == TCL_NUMBER_LONG) && (*((CONST long *)ptr1) == (long)0)) {
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    objResultPtr = eePtr->constants[0];
	    TRACE(("%s\n", O2S(objResultPtr)));
	    NEXT_INST_F(1, 2, 1);
	}

	if (*pc == INST_LSHIFT) {
	    /* Large left shifts create integer overflow */
	    result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift);
	    if (result != TCL_OK) {
		/*
		 * Technically, we could hold the value (1 << (INT_MAX+1))
		 * in an mp_int, but since we're using mp_mul_2d() to do the
		 * work, and it takes only an int argument, that's a good
		 * place to draw the line.
		 */
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"integer value too large to represent", -1));
		goto checkForCatch;
	    }
	    /* Handle shifts within the native long range */
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long))
		    && (l = *((CONST long *)ptr1)) 
		    && !(((l>0) ? l : ~l) 
			    & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) {
		TclNewLongObj(objResultPtr, (l<<shift));
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }

	    /* Handle shifts within the native wide range */
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if ((type1 != TCL_NUMBER_BIG)
		    && (shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
		Tcl_WideInt w;
		TclGetWideIntFromObj(NULL, valuePtr, &w);
		if (!(((w>0) ? w : ~w) 
			& -(((Tcl_WideInt)1)
			<<(CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) {
		    objResultPtr = Tcl_NewWideIntObj(w<<shift);
		    TRACE(("%s\n", O2S(objResultPtr)));
		    NEXT_INST_F(1, 2, 1);
		}
	    }

/*
	    if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long))
		    && (l = *((CONST long *)ptr1)) 
		    && !(((l>0) ? l : ~l) 
			    & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) {
		TclNewLongObj(objResultPtr, (l<<shift));
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
*/



	} else {
	    /* Quickly force large right shifts to 0 or -1 */
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if ((type2 != TCL_NUMBER_LONG)
		    || ( *((CONST long *)ptr2) > INT_MAX)) {
		/*
		 * Again, technically, the value to be shifted could
		 * be an mp_int so huge that a right shift by (INT_MAX+1)
		 * bits could not take us to the result of 0 or -1, but
		 * since we're using mp_div_2d to do the work, and it
		 * takes only an int argument, we draw the line there.
		 */
		int zero;
		switch (type1) {
		case TCL_NUMBER_LONG:
		    zero = (*((CONST long *)ptr1) > (long)0);
		    break;
#ifndef NO_WIDE_TYPE
		case TCL_NUMBER_WIDE: 
		    zero = (*((CONST Tcl_WideInt *)ptr1) > (Tcl_WideInt)0);
		    break;
#endif
		case TCL_NUMBER_BIG:
		    /* TODO: const correctness ? */
		    zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT);
		}
		if (zero) {
		    objResultPtr = eePtr->constants[0];
		} else {
		    TclNewIntObj(objResultPtr, -1);
		}
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    shift = (int)(*((CONST long *)ptr2));
	    /* Handle shifts within the native long range */
	    if (type1 == TCL_NUMBER_LONG) {
		long l = *((CONST long *)ptr1);
		if (shift >= CHAR_BIT*sizeof(long)) {
		    if (l >= (long)0) {
			objResultPtr = eePtr->constants[0];
		    } else {
			TclNewIntObj(objResultPtr, -1);
		    }
		} else {
		    TclNewLongObj(objResultPtr, (l >> shift));
		}
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
#ifndef NO_WIDE_TYPE
	    /* Handle shifts within the native wide range */
	    if (type1 == TCL_NUMBER_WIDE) {
		Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr1);
		if (shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
		    if (w >= (Tcl_WideInt)0) {
			objResultPtr = eePtr->constants[0];
		    } else {
			TclNewIntObj(objResultPtr, -1);
		    }
		} else {
		    objResultPtr = Tcl_NewWideIntObj(w >> shift);
		}
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
#endif
	}

	{
	    mp_int big, bigResult, bigRemainder;

	    if (Tcl_IsShared(valuePtr)) {
		Tcl_GetBignumFromObj(NULL, valuePtr, &big);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
	    }

	    mp_init(&bigResult);
	    if (*pc == INST_LSHIFT) {
		mp_mul_2d(&big, shift, &bigResult);
	    } else {
		mp_init(&bigRemainder);
		mp_div_2d(&big, shift, &bigResult, &bigRemainder);
		if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
		    /* Convert to Tcl's integer division rules */
		    mp_sub_d(&bigResult, 1, &bigResult);
		}
		mp_clear(&bigRemainder);
	    }
	    mp_clear(&big);

	    if (!Tcl_IsShared(valuePtr)) {
		Tcl_SetBignumObj(valuePtr, &bigResult);
		TRACE(("%s\n", O2S(valuePtr)));
		NEXT_INST_F(1, 1, 0);
	    }
	    objResultPtr = Tcl_NewBignumObj(&bigResult);
	}
	TRACE(("%s\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 2, 1);
    }
	
    case INST_BITOR:
    case INST_BITXOR:
    case INST_BITAND: {
	ClientData ptr1, ptr2;
	int type1, type2;
	Tcl_Obj *value2Ptr = *tosPtr;
	Tcl_Obj *valuePtr = *(tosPtr - 1);

	result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
	if ((result != TCL_OK)
		|| (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) {
	    result = TCL_ERROR;
	    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
		    O2S(value2Ptr), (valuePtr->typePtr?
		    valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}
	result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
	if ((result != TCL_OK)
		|| (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) {
	    result = TCL_ERROR;
	    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
		    O2S(value2Ptr), (value2Ptr->typePtr?
		    value2Ptr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    goto checkForCatch;
	}

	if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
	    mp_int big1, big2, bigResult;
	    mp_int *Pos, *Neg, *Other;
	    int numPos = 0;

	    if (Tcl_IsShared(valuePtr)) {
		Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1);
	    }
	    if (Tcl_IsShared(value2Ptr)) {
		Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
	    }

	    if (mp_cmp_d(&big1, 0) != MP_LT) {
		numPos++;
		Pos = &big1;
		if (mp_cmp_d(&big2, 0) != MP_LT) {
		    numPos++;
		    Other = &big2;
		} else {
		    Neg = &big2;
		}
	    } else {
		Neg = &big1;
		if (mp_cmp_d(&big2, 0) != MP_LT) {
		    numPos++;
		    Pos = &big2;
		} else {
		    Other = &big2;
		}
	    }
	    mp_init(&bigResult);

	    switch (*pc) {
	    case INST_BITAND:
		switch (numPos) {
		case 2:
		    /* Both arguments positive, base case */
		    mp_and(Pos, Other, &bigResult);
		    break;
		case 1:
		    /* One arg positive; one negative
		     * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */
		    mp_neg(Neg, Neg);
		    mp_sub_d(Neg, 1, Neg);
		    mp_xor(Pos, Neg, &bigResult);
		    mp_and(Pos, &bigResult, &bigResult);
		    break;
		case 0:
		    /* Both arguments negative 
		     * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */
		    mp_neg(Neg, Neg);
		    mp_sub_d(Neg, 1, Neg);
		    mp_neg(Other, Other);
		    mp_sub_d(Other, 1, Other);
		    mp_or(Neg, Other, &bigResult);
		    mp_neg(&bigResult, &bigResult);
		    mp_sub_d(&bigResult, 1, &bigResult);
		    break;
		}
		break;

	    case INST_BITOR:
		switch (numPos) {
		case 2:
		    /* Both arguments positive, base case */
		    mp_or(Pos, Other, &bigResult);
		    break;
		case 1:
		    /* One arg positive; one negative
		     * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */
		    mp_neg(Neg, Neg);
		    mp_sub_d(Neg, 1, Neg);
		    mp_xor(Pos, Neg, &bigResult);
		    mp_and(Neg, &bigResult, &bigResult);
		    mp_neg(&bigResult, &bigResult);
		    mp_sub_d(&bigResult, 1, &bigResult);
		    break;
		case 0:
		    /* Both arguments negative 
		     * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */
		    mp_neg(Neg, Neg);
		    mp_sub_d(Neg, 1, Neg);
		    mp_neg(Other, Other);
		    mp_sub_d(Other, 1, Other);
		    mp_and(Neg, Other, &bigResult);
		    mp_neg(&bigResult, &bigResult);
		    mp_sub_d(&bigResult, 1, &bigResult);
		    break;
		}
		break;

	    case INST_BITXOR:
		switch (numPos) {
		case 2:
		    /* Both arguments positive, base case */
		    mp_xor(Pos, Other, &bigResult);
		    break;
		case 1:
		    /* One arg positive; one negative
		     * P^N = ~(P^~N) = -(P^(-N-1))-1
		     */
		    mp_neg(Neg, Neg);
		    mp_sub_d(Neg, 1, Neg);
		    mp_xor(Pos, Neg, &bigResult);
		    mp_neg(&bigResult, &bigResult);
		    mp_sub_d(&bigResult, 1, &bigResult);
		    break;
		case 0:
		    /* Both arguments negative 
		     * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */
		    mp_neg(Neg, Neg);
		    mp_sub_d(Neg, 1, Neg);
		    mp_neg(Other, Other);
		    mp_sub_d(Other, 1, Other);
		    mp_xor(Neg, Other, &bigResult);
		    break;
		}
		break;
	    }
	
	    mp_clear(&big1);
	    mp_clear(&big2);
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewBignumObj(&bigResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    Tcl_SetBignumObj(valuePtr, &bigResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	}

#ifndef NO_WIDE_TYPE
	if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
	    Tcl_WideInt wResult, w1, w2;
	    TclGetWideIntFromObj(NULL, valuePtr, &w1);
	    TclGetWideIntFromObj(NULL, value2Ptr, &w2);

	    switch (*pc) {
	    case INST_BITAND:
		wResult = w1 & w2;
		break;
	    case INST_BITOR:
		wResult = w1 | w2;
		break;
	    case INST_BITXOR:
		wResult = w1 ^ w2;
	    }
	
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    Tcl_SetWideIntObj(valuePtr, wResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	}
#endif
	{
	    long lResult, l1 = *((CONST long *)ptr1);
	    long l2 = *((CONST long *)ptr2);

	    switch (*pc) {
	    case INST_BITAND:
		lResult = l1 & l2;
		break;
	    case INST_BITOR:
		lResult = l1 | l2;
		break;
	    case INST_BITXOR:
		lResult = l1 ^ l2;
	    }
	
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		TclNewLongObj(objResultPtr, lResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    TclSetLongObj(valuePtr, lResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	}
    }

#if 0
    case INST_MOD:
    {
	/*
	 * Only integers are allowed. We compute value op value2.
	 */

	long i = 0, i2 = 0, rem, neg_divisor = 0;
	long iResult = 0; /* Init. avoids compiler warning. */
	Tcl_WideInt w, w2, wResult = W0;
	int doWide = 0;
	Tcl_Obj *valuePtr, *value2Ptr;

	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1);
	if (valuePtr->typePtr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    TclGetWide(w,valuePtr);
	} else {	/* try to convert to int */
	    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
			O2S(valuePtr), O2S(value2Ptr),
			(valuePtr->typePtr?
			    valuePtr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	}
	if (value2Ptr->typePtr == &tclIntType) {
	    i2 = value2Ptr->internalRep.longValue;
	} else if (value2Ptr->typePtr == &tclWideIntType) {
	    TclGetWide(w2,value2Ptr);
	} else {
	    REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
			O2S(valuePtr), O2S(value2Ptr),
			(value2Ptr->typePtr?
			    value2Ptr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);
		goto checkForCatch;
	    }
	}

	do {

	    /*
	     * This code is tricky: C doesn't guarantee much about the
	     * quotient or remainder, and results with a negative divisor are
	     * not specified. Tcl guarantees that the remainder will have the
	     * same sign as the divisor and a smaller absolute value.
	     */
	    if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
		if (valuePtr->typePtr == &tclIntType) {
		    TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
		} else {
		    TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
		}
		goto divideByZero;
	    }
	    if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
		if (valuePtr->typePtr == &tclIntType) {
		    TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
		} else {
		    TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
		}
		goto divideByZero;
	    }

	    if (valuePtr->typePtr == &tclWideIntType
		    || value2Ptr->typePtr == &tclWideIntType) {
		Tcl_WideInt wRemainder;
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		if ( w == LLONG_MIN && w2 == -1 ) {
		    /* Integer overflow could happen with (LLONG_MIN % -1)
		     * even though it is not possible in the code below. */
		    wRemainder = 0;
		} else if ( w == LLONG_MIN && w2 == LLONG_MAX ) {
		    wRemainder = LLONG_MAX - 1;
		} else if ( w2 == LLONG_MIN ) {
		    /*
		     * In C, a modulus operation is not well defined when the
		     * divisor is a negative number. So w % LLONG_MIN is not
		     * well defined in the code below because -LLONG_MIN is
		     * still a negative number.
		     */
		    if (w == 0 || w == LLONG_MIN) {
			wRemainder = 0;
		    } else if (w < 0) {
			wRemainder = w;
		    } else {
			wRemainder = LLONG_MIN + w;
		    }
		    neg_divisor = 1;
		} else {
		    if (w2 < 0) {
			w2 = -w2;
			w = -w; /* Note: -LLONG_MIN == LLONG_MIN */
			neg_divisor = 1;
		    }
		    wRemainder = w % w2;

		    /*
		     * remainder is (remainder + divisor) when the remainder
		     * is negative. Watch out for the special case of a
		     * LLONG_MIN dividend and a negative divisor. Don't add
		     * the divisor in that case because the remainder should
		     * not be negative.
		     */
		    if (wRemainder < 0 && !(neg_divisor && (w == LLONG_MIN))) {
			wRemainder += w2;
		    }
		}
		if ((neg_divisor && (wRemainder > 0)) ||
			(!neg_divisor && (wRemainder < 0))) {
		    wRemainder = -wRemainder;
		}
		wResult = wRemainder;
		doWide = 1;
		break;
	    }

	    if ( i == LONG_MIN && i2 == -1 ) {
		/*
		 * Integer overflow could happen with (LONG_MIN % -1) even
		 * though it is not possible in the code below.
		 */
		rem = 0;
	    } else if ( i == LONG_MIN && i2 == LONG_MAX ) {
		rem = LONG_MAX - 1;
	    } else if ( i2 == LONG_MIN ) {
		/*
		 * In C, a modulus operation is not well defined when the
		 * divisor is a negative number. So i % LONG_MIN is not well
		 * defined in the code below because -LONG_MIN is still a
		 * negative number.
		 */
		if (i == 0 || i == LONG_MIN) {
		    rem = 0;
		} else if (i < 0) {
		    rem = i;
		} else {
		    rem = LONG_MIN + i;
		}
		neg_divisor = 1;
	    } else {
		if (i2 < 0) {
		    i2 = -i2;
		    i = -i; /* Note: -LONG_MIN == LONG_MIN */
		    neg_divisor = 1;
		}
		rem = i % i2;

		/*
		 * remainder is (remainder + divisor) when the remainder is
		 * negative. Watch out for the special case of a LONG_MIN
		 * dividend and a negative divisor. Don't add the divisor in
		 * that case because the remainder should not be negative.
		 */
		if (rem < 0 && !(neg_divisor && (i == LONG_MIN))) {
		    rem += i2;
		}
	    }

	    if ((neg_divisor && (rem > 0)) ||
		    (!neg_divisor && (rem < 0))) {
		rem = -rem;
	    }
	    iResult = rem;
















	} while (0);













	/*








































































































































	 * Reuse the valuePtr object already on stack if possible.
	 */

	if (Tcl_IsShared(valuePtr)) {
	    if (doWide) {
		TclNewWideIntObj(objResultPtr, wResult);
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
	    } else {
		TclNewLongObj(objResultPtr, iResult);
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
	    }
	    NEXT_INST_F(1, 2, 1);
	} else {	/* reuse the valuePtr object */
	    if (doWide) {
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		TclSetWideIntObj(valuePtr, wResult);
	    } else {
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		TclSetLongObj(valuePtr, iResult);
	    }
	    NEXT_INST_F(1, 1, 0);
	}
    }
#endif

    case INST_ADD:
    case INST_SUB:
    case INST_DIV:
    case INST_MULT: {
	ClientData ptr1, ptr2;
	int type1, type2;
	Tcl_Obj *value2Ptr = *tosPtr;
	Tcl_Obj *valuePtr = *(tosPtr - 1);

	result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
	if ((result != TCL_OK) 
#ifndef ACCEPT_NAN
		|| (type1 == TCL_NUMBER_NAN)
#endif
		) {
	    result = TCL_ERROR;
	    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
		    O2S(value2Ptr), O2S(valuePtr), 
		    (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}

#ifdef ACCEPT_NAN
	if (type1 == TCL_NUMBER_NAN) {
	    /* NaN first argument -> result is also NaN */
	    NEXT_INST_F(1, 1, 0);
	}
#endif

	result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
	if ((result != TCL_OK) 
#ifndef ACCEPT_NAN
		|| (type2 == TCL_NUMBER_NAN)
#endif
		) {
	    result = TCL_ERROR;
	    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
		    O2S(value2Ptr), O2S(valuePtr), 
		    (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    goto checkForCatch;
	}

#ifdef ACCEPT_NAN
	if (type2 == TCL_NUMBER_NAN) {
	    /* NaN second argument -> result is also NaN */
	    objResultPtr = value2Ptr;
	    NEXT_INST_F(1, 2, 1);
	}
#endif

	if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
	    /* At least one of the values is floating-point, so perform
	     * floating point calculations */
	    double d1, d2, dResult;
	    Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
	    Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);

	    switch (*pc) {
	    case INST_ADD:
		dResult = d1 + d2;
		break;
	    case INST_SUB:
		dResult = d1 - d2;
		break;
	    case INST_MULT:
		dResult = d1 * d2;
		break;
	    case INST_DIV:
#ifndef IEEE_FLOATING_POINT
		if (d2 == 0.0) {
		    TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
		    goto divideByZero;
		}
#endif
		/*
		 * We presume that we are running with zero-divide unmasked if
		 * we're on an IEEE box. Otherwise, this statement might cause
		 * demons to fly out our noses.
		 */
		dResult = d1 / d2;
		break;
	    }

#ifndef ACCEPT_NAN
	    /*
	     * Check now for IEEE floating-point error.
	     */

	    if (TclIsNaN(dResult)) {
		TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
			O2S(valuePtr), O2S(value2Ptr)));
		TclExprFloatError(interp, dResult);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
#endif
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		TclNewDoubleObj(objResultPtr, dResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    TclSetDoubleObj(valuePtr, dResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	}

	if ((*pc == INST_MULT) && (sizeof(Tcl_WideInt) >= 2*sizeof(long))
		&& (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
	    Tcl_WideInt w1, w2, wResult;
	    TclGetWideIntFromObj(NULL, valuePtr, &w1);
	    TclGetWideIntFromObj(NULL, value2Ptr, &w2);

	    wResult = w1 * w2;

	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    Tcl_SetWideIntObj(valuePtr, wResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	} 

	if ((*pc != INST_MULT) 
		&& (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
	    Tcl_WideInt w1, w2, wResult;
	    TclGetWideIntFromObj(NULL, valuePtr, &w1);
	    TclGetWideIntFromObj(NULL, value2Ptr, &w2);

	    switch (*pc) {
	    case INST_ADD:
		wResult = w1 + w2;
#ifndef NO_WIDE_TYPE
		if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
		{
		    /* Check for overflow */
		    if (((w1 < 0) && (w2 < 0) && (wResult > 0))
			    || ((w1 > 0) && (w2 > 0) && (wResult < 0))) {
			goto overflow;
		    }
		}
		break;

	    case INST_SUB:
		wResult = w1 - w2;
#ifndef NO_WIDE_TYPE
		if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
		{
		    /* Must check for overflow */
		    if (((w1 < 0) && (w2 > 0) && (wResult > 0))
			    || ((w1 > 0) && (w2 < 0) && (wResult < 0))) {
			goto overflow;
		    }
		}
		break;

	    case INST_DIV:
		if (w2 == 0) {
		    TRACE(("%s %s => DIVIDE BY ZERO\n",
			    O2S(valuePtr), O2S(value2Ptr)));
		    goto divideByZero;
		}

		/* Need a bignum to represent (LLONG_MIN / -1) */
		if ((w1 == LLONG_MIN) && (w2 == -1)) {
		    goto overflow;
		}
		wResult = w1 / w2;

		/* Force Tcl's integer division rules */
		/* TODO: examine for logic simplification */
		if (((wResult < 0) || ((wResult == 0) &&
			((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
			((wResult * w2) != w1)) {
		    wResult -= 1;
		}
		break;
	    }

	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    Tcl_SetWideIntObj(valuePtr, wResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	}

    overflow:
	{
	    mp_int big1, big2, bigResult, bigRemainder;
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1);
	    }
	    if (Tcl_IsShared(value2Ptr)) {
		Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
	    }
	    mp_init(&bigResult);
	    switch (*pc) {
	    case INST_ADD:
		mp_add(&big1, &big2, &bigResult);
		break;
	    case INST_SUB:
		mp_sub(&big1, &big2, &bigResult);
		break;
	    case INST_MULT:
		mp_mul(&big1, &big2, &bigResult);
		break;
	    case INST_DIV:
		if (mp_iszero(&big2)) {
		    TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
			    O2S(value2Ptr)));
		    mp_clear(&big1);
		    mp_clear(&big2);
		    goto divideByZero;
		}
		mp_init(&bigRemainder);
		mp_div(&big1, &big2, &bigResult, &bigRemainder);
		/* TODO: internals intrusion */
		if (!mp_iszero(&bigRemainder) 
			&& (bigRemainder.sign != big2.sign)) {
		    /* Convert to Tcl's integer division rules */
		    mp_sub_d(&bigResult, 1, &bigResult);
		    mp_add(&bigRemainder, &big2, &bigRemainder);
		}
		if (*pc == INST_MOD) {
		    mp_copy(&bigRemainder, &bigResult);
		}
		mp_clear(&bigRemainder);
		break;
	    }
	    mp_clear(&big1);
	    mp_clear(&big2);
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewBignumObj(&bigResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);
	    }
	    Tcl_SetBignumObj(valuePtr, &bigResult);
	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);
	}
    }

    case INST_MOD:



    case INST_EXPON: {

	/*
	 * Operands must be numeric and ints get converted to floats if
	 * necessary. We compute value op value2.
	 */



	double d1, d2;
	double dResult = 0.0;		/* Init. avoids compiler warning. */
	Tcl_Obj *valuePtr,*value2Ptr;
#if 0
	Tcl_ObjType *t1Ptr, *t2Ptr;
	long i = 0, i2 = 0, quot;	/* Init. avoids compiler warning. */
	long iResult = 0;		/* Init. avoids compiler warning. */
	int doDouble = 0;		/* 1 if doing floating arithmetic */
	Tcl_WideInt w, w2, wquot;
	Tcl_WideInt wResult = W0;	/* Init. avoids compiler warning. */
	int doWide = 0;			/* 1 if doing wide arithmetic. */

	int length;

	value2Ptr = *tosPtr;
	valuePtr  = *(tosPtr - 1);
	t1Ptr = valuePtr->typePtr;
	t2Ptr = value2Ptr->typePtr;

	if (t1Ptr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
	} else if (t1Ptr == &tclWideIntType) {
	    TclGetWide(w,valuePtr);
	} else if ((t1Ptr == &tclDoubleType) && (valuePtr->bytes == NULL)) {

	    /*
	     * We can only use the internal rep directly if there is no string
	     * rep.  Otherwise the string rep might actually look like an
	     * integer, which is preferred.
	     */

	    d1 = valuePtr->internalRep.doubleValue;
	} else {
	    char *s = Tcl_GetStringFromObj(valuePtr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, valuePtr, i, w);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
			valuePtr, &d1);
	    }
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
			s, O2S(valuePtr),
			(valuePtr->typePtr? valuePtr->typePtr->name: "null")));

		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	    t1Ptr = valuePtr->typePtr;
	}

	if (t2Ptr == &tclIntType) {
	    i2 = value2Ptr->internalRep.longValue;
	} else if (t2Ptr == &tclWideIntType) {
	    TclGetWide(w2,value2Ptr);
	} else if ((t2Ptr == &tclDoubleType) && (value2Ptr->bytes == NULL)) {

	    /*
	     * We can only use the internal rep directly if there is no string
	     * rep.  Otherwise the string rep might actually look like an
	     * integer, which is preferred.
	     */

	    d2 = value2Ptr->internalRep.doubleValue;
	} else {
	    char *s = Tcl_GetStringFromObj(value2Ptr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
			value2Ptr, &d2);
	    }
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
			O2S(value2Ptr), s,
			(value2Ptr->typePtr?
			    value2Ptr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);
		goto checkForCatch;
	    }
	    t2Ptr = value2Ptr->typePtr;
	}

	if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
	    /*
	     * Do double arithmetic.
	     */
	    doDouble = 1;
	    if (t1Ptr == &tclIntType) {
		d1 = i;		/* promote value 1 to double */
	    } else if (t2Ptr == &tclIntType) {
		d2 = i2;	/* promote value 2 to double */
	    } else if (t1Ptr == &tclWideIntType) {
		d1 = Tcl_WideAsDouble(w);
	    } else if (t2Ptr == &tclWideIntType) {
		d2 = Tcl_WideAsDouble(w2);
	    }
	    switch (*pc) {
	    case INST_ADD:
		dResult = d1 + d2;
		break;
	    case INST_SUB:
		dResult = d1 - d2;
		break;
	    case INST_MULT:
		dResult = d1 * d2;
		break;







	    case INST_EXPON:
		if (d1==0.0 && d2<0.0) {
		    TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
		    goto exponOfZero;
		}
		dResult = pow(d1, d2);
		break;
	    }

	    /*
	     * Check now for IEEE floating-point error.
	     */

	    if (IS_NAN(dResult)) {
		TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
			O2S(valuePtr), O2S(value2Ptr)));
		TclExprFloatError(interp, dResult);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	} else if ((t1Ptr == &tclWideIntType) || (t2Ptr == &tclWideIntType)) {

	    /*
	     * Do wide integer arithmetic.
	     */
	    doWide = 1;
	    if (t1Ptr == &tclIntType) {
		w = Tcl_LongAsWide(i);
	    } else if (t2Ptr == &tclIntType) {
		w2 = Tcl_LongAsWide(i2);
	    }
	    switch (*pc) {
	    case INST_ADD:
		wResult = w + w2;
		break;
	    case INST_SUB:
		wResult = w - w2;
		break;
	    case INST_MULT:
		wResult = w * w2;
		break;
	    case INST_DIV:
		/*
		 * When performing integer division, protect against integer
		 * overflow. Round towards zero when the quotient is positive,
		 * otherwise round towards -Infinity.

		 */
		if (w2 == W0) {
		    TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
		    goto divideByZero;
		}
		if (w == LLONG_MIN && w2 == -1) {

		    /* Avoid integer overflow on (LLONG_MIN / -1) */
		    wquot = LLONG_MIN;
		} else {
		    wquot = w / w2;
		    /*
		     * Round down to a smaller negative number if there is a
		     * remainder and the quotient is negative or zero and the
		     * signs don't match.  Note that we don't use a modulus to
		     * find the remainder since it is not well defined in C
		     * when the divisor is negative.
		     */
		    if (((wquot < 0) || ((wquot == 0) &&
			    ((w < 0 && w2 > 0) || (w > 0 && w2 < 0)))) &&
			    ((wquot * w2) != w)) {
			wquot -= 1;
		    }
		}
		wResult = wquot;
		break;
	    case INST_EXPON: {
		int errExpon;

		wResult = ExponWide(w, w2, &errExpon);
		if (errExpon) {
		    TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2));
		    goto exponOfZero;
		}
		break;
	    }
	    }
	} else {
	    /*
	     * Do integer arithmetic.
	     */
	    switch (*pc) {
	    case INST_ADD:
		iResult = i + i2;
		break;
	    case INST_SUB:
		iResult = i - i2;
		break;
	    case INST_MULT:
		iResult = i * i2;
		break;
	    case INST_DIV:
		/*
		 * When performing integer division, protect against integer
		 * overflow. Round towards zero when the quotient is positive,
		 * otherwise round towards -Infinity.

		 */
		if (i2 == 0) {
		    TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
		    goto divideByZero;
		}
		if (i == LONG_MIN && i2 == -1) {

		    /* Avoid integer overflow on (LONG_MIN / -1) */
		    quot = LONG_MIN;
		} else {
		    quot = i / i2;
		    /*
		     * Round down to a smaller negative number if there is a
		     * remainder and the quotient is negative or zero and the
		     * signs don't match.  Note that we don't use a modulus to
		     * find the remainder since it is not well defined in C
		     * when the divisor is negative.
		     */
		    if (((quot < 0) || ((quot == 0) &&
			    ((i<0 && i2>0) || (i>0 && i2<0)))) &&
			    ((quot * i2) != i)) {
			quot -= 1;
		    }
		}
		iResult = quot;
		break;
	    case INST_EXPON: {
		int errExpon;

		iResult = ExponLong(i, i2, &errExpon);
		if (errExpon) {
		    TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2));
		    goto exponOfZero;
		}
		break;
	    }
	    }
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */

	if (Tcl_IsShared(valuePtr)) {
	    if (doDouble) {
		TclNewDoubleObj(objResultPtr, dResult);
		TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
	    } else if (doWide) {
		TclNewWideIntObj(objResultPtr, wResult);
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
	    } else {
		TclNewLongObj(objResultPtr, iResult);
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
	    }
	    NEXT_INST_F(1, 2, 1);
	} else {	    /* reuse the valuePtr object */
	    if (doDouble) { /* NB: stack top is off by 1 */
		TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
		TclSetDoubleObj(valuePtr, dResult);
	    } else if (doWide) {
		TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		TclSetWideIntObj(valuePtr, wResult);
	    } else {
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		TclSetLongObj(valuePtr, iResult);
	    }
	    NEXT_INST_F(1, 1, 0);
	}

#else





	value2Ptr = *tosPtr;
	valuePtr = *(tosPtr - 1);
	result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
	if (result != TCL_OK) {
#ifdef ACCEPT_NAN
	    if (valuePtr->typePtr == &tclDoubleType) {
		/* NaN first argument -> result is also NaN */
		result = TCL_OK;
		NEXT_INST_F(1, 1, 0);
	    }
#endif
	    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
		    O2S(value2Ptr), O2S(valuePtr), 
		    (valuePtr->typePtr? valuePtr->typePtr->name: "null")));






	    IllegalExprOperandType(interp, pc, valuePtr);




	    goto checkForCatch;





	}



	result = Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
	if (result != TCL_OK) {
#ifdef ACCEPT_NAN
	    if (value2Ptr->typePtr == &tclDoubleType) {
		/* NaN second argument -> result is also NaN */
		objResultPtr = value2Ptr;
		result = TCL_OK;
		NEXT_INST_F(1, 2, 1);
	    }
#endif
	    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
		    O2S(value2Ptr), O2S(valuePtr), 
		    (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    goto checkForCatch;
	}
	if (valuePtr->typePtr == &tclDoubleType
		|| value2Ptr->typePtr == &tclDoubleType) {
	    /* At least one of the values is floating-point, so perform
	     * floating point calculations */
	    switch (*pc) {
	    case INST_EXPON:
		if (d1==0.0 && d2<0.0) {
		    TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
		    goto exponOfZero;
		}
		dResult = pow(d1, d2);








		break;
	    case INST_MOD:
		if (valuePtr->typePtr == &tclDoubleType) {

		    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
			    O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr?


			    valuePtr->typePtr->name: "null")));
		    IllegalExprOperandType(interp, pc, valuePtr);

		} else {
		    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
			    O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr?
			    value2Ptr->typePtr->name: "null")));
		    IllegalExprOperandType(interp, pc, value2Ptr);
		}
		result = TCL_ERROR;





		goto checkForCatch;
	    }
#ifndef ACCEPT_NAN
	    /*
	     * Check now for IEEE floating-point error.
	     */

	    if (TclIsNaN(dResult)) {
		TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
			O2S(valuePtr), O2S(value2Ptr)));
		TclExprFloatError(interp, dResult);
		result = TCL_ERROR;
		goto checkForCatch;
	    }

#endif
	    if (Tcl_IsShared(valuePtr)) {
		TclNewDoubleObj(objResultPtr, dResult);
		NEXT_INST_F(1, 2, 1);









	    }
	    TclSetDoubleObj(valuePtr, dResult);
	    NEXT_INST_F(1, 1, 0);
	} else {
	    /* Both values are some kind of integer */
	    /* TODO: optimize use of narrower native integers */
	    mp_int big1, big2, bigResult, bigRemainder;

	    Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
	    Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
	    mp_init(&bigResult);
	    switch (*pc) {
	    case INST_MOD:
		if (mp_iszero(&big2)) {
		    TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
			    O2S(value2Ptr)));
		    mp_clear(&big1);
		    mp_clear(&big2);
		    goto divideByZero;
		}





		mp_init(&bigRemainder);
		mp_div(&big1, &big2, &bigResult, &bigRemainder);
		if (!mp_iszero(&bigRemainder) 
			&& (bigRemainder.sign != big2.sign)) {

		    /* Convert to Tcl's integer division rules */












		    mp_sub_d(&bigResult, 1, &bigResult);


		    mp_add(&bigRemainder, &big2, &bigRemainder);
		}
		if (*pc == INST_MOD) {

		    mp_copy(&bigRemainder, &bigResult);

		}
		mp_clear(&bigRemainder);
		break;
	    case INST_EXPON:
		if (mp_iszero(&big2)) {

		    /* Anything to the zero power is 1 */
		    mp_clear(&big1);
		    mp_clear(&big2);
		    objResultPtr = eePtr->constants[1];


		    NEXT_INST_F(1, 2, 1);
		}

		if (mp_iszero(&big1)) {
		    if (mp_cmp_d(&big2, 0) == MP_LT) {
			TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
			    O2S(value2Ptr)));
			mp_clear(&big1);
			mp_clear(&big2);
			goto exponOfZero;
		    }
		    mp_clear(&big1);
		    mp_clear(&big2);
		    objResultPtr = eePtr->constants[0];
		    NEXT_INST_F(1, 2, 1);
		}
		if (mp_cmp_d(&big2, 0) == MP_LT) {
		    switch (mp_cmp_d(&big1, 1)) {

		    case MP_GT:



			objResultPtr = eePtr->constants[0];

			break;
		    case MP_EQ:


			objResultPtr = eePtr->constants[1];
			break;
		    case MP_LT:
			mp_add_d(&big1, 1, &big1);
			if (mp_cmp_d(&big1, 0) == MP_LT) {
			    objResultPtr = eePtr->constants[0];
			    break;
			}
			mp_mod_2d(&big2, 1, &big2);
			if (mp_iszero(&big2)) {
			    objResultPtr = eePtr->constants[1];
			} else {
			    TclNewIntObj(objResultPtr, -1);
			}
		    }
		    mp_clear(&big1);
		    mp_clear(&big2);
		    NEXT_INST_F(1, 2, 1);
		}
		if (big2.used > 1) {
		    Tcl_SetObjResult(interp,


			    Tcl_NewStringObj("exponent too large", -1));
		    mp_clear(&big1);

		    mp_clear(&big2);
		    goto checkForCatch;
		}
		mp_expt_d(&big1, big2.dp[0], &bigResult);
		break;
	    }
	    mp_clear(&big1);
	    mp_clear(&big2);
	    TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewBignumObj(&bigResult);
		TRACE(("%s\n", O2S(objResultPtr)));
		NEXT_INST_F(1, 2, 1);






	    }
	    Tcl_SetBignumObj(valuePtr, &bigResult);



	    TRACE(("%s\n", O2S(valuePtr)));
	    NEXT_INST_F(1, 1, 0);

	}
#endif

    }


    case INST_LNOT: {
	int b;

	Tcl_Obj *valuePtr = *tosPtr;







	/* TODO - check claim that taking address of b harms performance */
	/* TODO - consider optimization search for eePtr->constants */
	result = TclGetBooleanFromObj(NULL, valuePtr, &b);
	if (result != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}
	/* TODO: Consider peephole opt. */
	objResultPtr = eePtr->constants[!b];
	NEXT_INST_F(1, 1, 1);
    }


    case INST_BITNOT: {
	mp_int big;
	ClientData ptr;
	int type;
	Tcl_Obj *valuePtr = *tosPtr;





	result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);

	if ((result != TCL_OK)
		|| (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
	    /* ... ~$NonInteger => raise an error */




	    result = TCL_ERROR;





	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}
	if (type == TCL_NUMBER_LONG) {
	    long l = *((CONST long *)ptr);
	    if (Tcl_IsShared(valuePtr)) {
		TclNewLongObj(objResultPtr, ~l);
		NEXT_INST_F(1, 1, 1);
	    }
	    TclSetLongObj(valuePtr, ~l);
	    NEXT_INST_F(1, 0, 0);
	}
#ifndef NO_WIDE_TYPE
	if (type == TCL_NUMBER_LONG) {
	    Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr);
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewWideIntObj(~w);
		NEXT_INST_F(1, 1, 1);
	    }
	    Tcl_SetWideIntObj(valuePtr, ~w);
	    NEXT_INST_F(1, 0, 0);
	}
#endif
	if (Tcl_IsShared(valuePtr)) {
	    Tcl_GetBignumFromObj(NULL, valuePtr, &big);


	} else {



	    Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);


	}

	/* ~a = - a - 1 */
	mp_neg(&big, &big);
	mp_sub_d(&big, 1, &big);
	if (Tcl_IsShared(valuePtr)) {
	    objResultPtr = Tcl_NewBignumObj(&big);

	    NEXT_INST_F(1, 1, 1);




	}
	Tcl_SetBignumObj(valuePtr, &big);

	NEXT_INST_F(1, 0, 0);
    }



    case INST_UMINUS: {
	ClientData ptr;
	int type;
	Tcl_Obj *valuePtr = *tosPtr;

	result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
	if ((result != TCL_OK)
#ifndef ACCEPT_NAN
		|| (type == TCL_NUMBER_NAN)
#endif

		) {
	    result = TCL_ERROR;

	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));

	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}

	switch (type) {
	case TCL_NUMBER_DOUBLE: {
	    double d;
	    if (Tcl_IsShared(valuePtr)) {
		TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr)));
		NEXT_INST_F(1, 1, 1);
	    }



	    d = *((CONST double *)ptr);
	    TclSetDoubleObj(valuePtr, -d);
	    NEXT_INST_F(1, 0, 0);
	}
	case TCL_NUMBER_LONG: {
	    long l = *((CONST long *)ptr);
	    if (l != LONG_MIN) {
		if (Tcl_IsShared(valuePtr)) {
		    TclNewLongObj(objResultPtr, -l);
		    NEXT_INST_F(1, 1, 1);

		}
		TclSetLongObj(valuePtr, -l);
		NEXT_INST_F(1, 0, 0);
	    }






	    /* FALLTHROUGH */
	}

#ifndef NO_WIDE_TYPE
	case TCL_NUMBER_WIDE: {
	    Tcl_WideInt w;
	    if (type == TCL_NUMBER_LONG) {
		w = (Tcl_WideInt)(*((CONST long *)ptr));
	    } else {
		w = *((CONST Tcl_WideInt *)ptr);
	    }


	    if (w != LLONG_MIN) {
		if (Tcl_IsShared(valuePtr)) {
		    objResultPtr = Tcl_NewWideIntObj(-w);
		    NEXT_INST_F(1, 1, 1);


		}
		Tcl_SetWideIntObj(valuePtr, -w);

		NEXT_INST_F(1, 0, 0);
	    }

	    /* FALLTHROUGH */
	}
#endif
	case TCL_NUMBER_BIG: {


	    mp_int big;
	    switch (type) {
#ifdef NO_WIDE_TYPE
	    case TCL_NUMBER_LONG:
		TclBNInitBignumFromLong(&big, *((CONST long *)ptr));
		break;
#else
	    case TCL_NUMBER_WIDE:
		TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr));
		break;
#endif
	    case TCL_NUMBER_BIG:
		if (Tcl_IsShared(valuePtr)) {
		    Tcl_GetBignumFromObj(NULL, valuePtr, &big);
		} else {
		    Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
		}
	    }
	    mp_neg(&big, &big);
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewBignumObj(&big);

		NEXT_INST_F(1, 1, 1);
	    }
	    Tcl_SetBignumObj(valuePtr, &big);






	    NEXT_INST_F(1, 0, 0);
	}
	case TCL_NUMBER_NAN:
	    /* -NaN => NaN */

	    NEXT_INST_F(1, 0, 0);
	}
    }




    case INST_CALL_BUILTIN_FUNC1: {
	Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");





    }




    case INST_CALL_FUNC1: {
	Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");
    }


    case INST_UPLUS:
    case INST_TRY_CVT_TO_NUMERIC: {
	/*
	 * Try to convert the topmost stack object to numeric object.

	 * This is done in order to support [expr]'s policy of interpreting





	 * operands if at all possible as numbers first, then strings.
	 */

	ClientData ptr;
	int type;
	Tcl_Obj *valuePtr = *tosPtr;

	if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {
	    if (*pc == INST_UPLUS) {
		/* ... +$NonNumeric => raise an error */
		result = TCL_ERROR;
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
			(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    } else {
		/* ... TryConvertToNumeric($NonNumeric) is acceptable */
		TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
		NEXT_INST_F(1, 0, 0);
	    }
	}
#ifndef ACCEPT_NAN
	if (type == TCL_NUMBER_NAN) {
	    result = TCL_ERROR;

	    if (*pc == INST_UPLUS) {
		/* ... +$NonNumeric => raise an error */
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
			(valuePtr->typePtr? valuePtr->typePtr->name : "null")));









		IllegalExprOperandType(interp, pc, valuePtr);

	    } else {

		/* Numeric conversion of NaN -> error */
		TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
			O2S(objResultPtr)));
		TclExprFloatError(interp, *((CONST double *)ptr));
	    }
	    goto checkForCatch;
	}
#endif


	/*
	 * Ensure that the numeric value has a string rep the same as
	 * the formatted version of its internal rep. This is used, e.g.,
	 * to make sure that "expr {0001}" yields "1", not "0001".
	 * We implement this by _discarding_ the string rep since we
	 * know it will be regenerated, if needed later, by formatting
	 * the internal rep's value. 
	 */
	if (valuePtr->bytes == NULL) {
	    TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));



	    NEXT_INST_F(1, 0, 0);
	}

	if (Tcl_IsShared(valuePtr)) {
	    /*
	     * Here we do some surgery within the Tcl_Obj internals.
	     * We want to copy the intrep, but not the string, so we
	     * temporarily hide the string so we do not copy it.
	     */
	    char *savedString = valuePtr->bytes;
	    valuePtr->bytes = NULL;
	    objResultPtr = Tcl_DuplicateObj(valuePtr);
	    valuePtr->bytes = savedString;
	    TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr)));






	    NEXT_INST_F(1, 1, 1);

	}
	TclInvalidateStringRep(valuePtr);
	TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
	NEXT_INST_F(1, 0, 0);
    }


    case INST_BREAK:
	DECACHE_STACK_INFO();
	Tcl_ResetResult(interp);
	CACHE_STACK_INFO();
	result = TCL_BREAK;
	cleanup = 0;
	goto processExceptionReturn;

    case INST_CONTINUE:
	DECACHE_STACK_INFO();
	Tcl_ResetResult(interp);
	CACHE_STACK_INFO();
	result = TCL_CONTINUE;
	cleanup = 0;
	goto processExceptionReturn;

    case INST_FOREACH_START4: {

	/*
	 * Initialize the temporary local var that holds the count of the
	 * number of iterations of the loop body to -1.
	 */

	int opnd;
	ForeachInfo *infoPtr;
	int iterTmpIndex;
	Var *iterVarPtr;
	Tcl_Obj *oldValuePtr;

	opnd = TclGetUInt4AtPtr(pc+1);
	infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;

	iterTmpIndex = infoPtr->loopCtTemp;
	iterVarPtr = &(compiledLocals[iterTmpIndex]);
	oldValuePtr = iterVarPtr->value.objPtr;

	if (oldValuePtr == NULL) {
	    TclNewLongObj(iterVarPtr->value.objPtr, -1);
	    Tcl_IncrRefCount(iterVarPtr->value.objPtr);
	} else {
	    TclSetLongObj(oldValuePtr, -1);
	}
	TclSetVarScalar(iterVarPtr);
	TclClearVarUndefined(iterVarPtr);
	TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));



#ifndef TCL_COMPILE_DEBUG
	/*
	 * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately
	 * after INST_FOREACH_START4 - let us just fall through instead of
	 * jumping back to the top.
	 */

	pc += 5;
#else
	NEXT_INST_F(5, 0, 0);
#endif

    }

    case INST_FOREACH_STEP4: {
	/*
	 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
	 * the next value list element to each loop var.
	 */

	int opnd;
	ForeachInfo *infoPtr;
	ForeachVarList *varListPtr;
	int numLists;
	Tcl_Obj *listPtr,*valuePtr, *value2Ptr;
	Tcl_Obj **elements;
	Var *iterVarPtr, *listVarPtr;
	int iterNum, listTmpIndex, listLen, numVars;
	int varIndex, valIndex, continueLoop, j;
	long i;
	Var *varPtr;
	char *part1;

	opnd = TclGetUInt4AtPtr(pc+1);
	infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;

	numLists = infoPtr->numLists;

	/*
	 * Increment the temp holding the loop iteration number.
	 */

	iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
	valuePtr = iterVarPtr->value.objPtr;
	iterNum = (valuePtr->internalRep.longValue + 1);
	TclSetLongObj(valuePtr, iterNum);

	/*
	 * Check whether all value lists are exhausted and we should stop the
	 * loop.
	 */

	continueLoop = 0;
	listTmpIndex = infoPtr->firstValueTemp;
	for (i = 0;  i < numLists;  i++) {
	    varListPtr = infoPtr->varLists[i];
	    numVars = varListPtr->numVars;

	    listVarPtr = &(compiledLocals[listTmpIndex]);
	    listPtr = listVarPtr->value.objPtr;
	    result = Tcl_ListObjLength(interp, listPtr, &listLen);
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
			opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
		goto checkForCatch;
	    }
	    if (listLen > (iterNum * numVars)) {
		continueLoop = 1;
	    }
	    listTmpIndex++;
	}

	/*
	 * If some var in some var list still has a remaining list element
	 * iterate one more time. Assign to var the next element from its
	 * value list. We already checked above that each list temp holds a
	 * valid list object (by calling Tcl_ListObjLength), but cannot rely
	 * on that check remaining valid: one list could have been shimmered
	 * as a side effect of setting a traced variable.
	 */

	if (continueLoop) {
	    listTmpIndex = infoPtr->firstValueTemp;
	    for (i = 0;  i < numLists;  i++) {
		varListPtr = infoPtr->varLists[i];
		numVars = varListPtr->numVars;

		listVarPtr = &(compiledLocals[listTmpIndex]);
		listPtr = listVarPtr->value.objPtr;

		Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements);

		valIndex = (iterNum * numVars);
		for (j = 0;  j < numVars;  j++) {
		    int setEmptyStr = 0;
		    if (valIndex >= listLen) {
			setEmptyStr = 1;
			TclNewObj(valuePtr);
		    } else {
			valuePtr = elements[valIndex];
		    }

		    varIndex = varListPtr->varIndexes[j];
		    varPtr = &(compiledLocals[varIndex]);
		    part1 = varPtr->name;
		    while (TclIsVarLink(varPtr)) {
			varPtr = varPtr->value.linkPtr;
		    }
		    if (TclIsVarDirectWritable(varPtr)) {
			value2Ptr = varPtr->value.objPtr;
			if (valuePtr != value2Ptr) {
			    if (value2Ptr != NULL) {
				TclDecrRefCount(value2Ptr);
			    } else {
				TclSetVarScalar(varPtr);
				TclClearVarUndefined(varPtr);
			    }
			    varPtr->value.objPtr = valuePtr;
			    Tcl_IncrRefCount(valuePtr);
			}
		    } else {
			DECACHE_STACK_INFO();
			value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			CACHE_STACK_INFO();
			if (value2Ptr == NULL) {
			    TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
				    opnd, varIndex), Tcl_GetObjResult(interp));

			    if (setEmptyStr) {
				TclDecrRefCount(valuePtr);
			    }
			    result = TCL_ERROR;
			    goto checkForCatch;
			}
		    }
		    valIndex++;
		}
		listTmpIndex++;
	    }
	}
	TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
		iterNum, (continueLoop? "continue" : "exit")));

	/*
	 * Run-time peep-hole optimisation: the compiler ALWAYS follows
	 * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
	 * instruction and jump direct from here.
	 */

	pc += 5;
	if (*pc == INST_JUMP_FALSE1) {
	    NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
	} else {
	    NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
	}
    }

    case INST_BEGIN_CATCH4:
	/*
	 * Record start of the catch command with exception range index equal
	 * to the operand. Push the current stack depth onto the special catch
	 * stack.
	 */
	eePtr->stackPtr[++catchTop] = (Tcl_Obj *) (tosPtr - eePtr->stackPtr);
	TRACE(("%u => catchTop=%d, stackTop=%d\n",
		TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1),
		tosPtr - eePtr->stackPtr));
	NEXT_INST_F(5, 0, 0);

    case INST_END_CATCH:
	catchTop--;
	result = TCL_OK;
	TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1)));
	NEXT_INST_F(1, 0, 0);

    case INST_PUSH_RESULT:
	objResultPtr = Tcl_GetObjResult(interp);
	TRACE_WITH_OBJ(("=> "), objResultPtr);

	/*
	 * See the comments at INST_INVOKE_STK
	 */
	{
	    Tcl_Obj *newObjResultPtr;
	    TclNewObj(newObjResultPtr);
	    Tcl_IncrRefCount(newObjResultPtr);
	    iPtr->objResultPtr = newObjResultPtr;
	}

	NEXT_INST_F(1, 0, -1);

    case INST_PUSH_RETURN_CODE:
	TclNewIntObj(objResultPtr, result);
	TRACE(("=> %u\n", result));
	NEXT_INST_F(1, 0, 1);

    case INST_PUSH_RETURN_OPTIONS:
	objResultPtr = Tcl_GetReturnOptions(interp, result);
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(1, 0, 1);

/* TODO: normalize "valPtr" to "valuePtr" */
    {
	int opnd, opnd2, allocateDict;
	Tcl_Obj *dictPtr, *valPtr;
	Var *varPtr;
	char *part1;

    case INST_DICT_GET:
	opnd = TclGetUInt4AtPtr(pc+1);
	TRACE(("%u => ", opnd));
	dictPtr = *(tosPtr - opnd);
	if (opnd > 1) {
	    dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
		    tosPtr - (opnd-1), DICT_PATH_READ);
	    if (dictPtr == NULL) {
		TRACE_WITH_OBJ((
			"%u => ERROR tracing dictionary path into \"%s\": ",
			opnd, O2S(*(tosPtr - opnd))),
			Tcl_GetObjResult(interp));
		result = TCL_ERROR;
		cleanup = opnd + 1;
		goto checkForCatch;
	    }
	}
	result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &objResultPtr);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ((
		    "%u => ERROR reading leaf dictionary key \"%s\": ",
			opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
	    cleanup = opnd + 1;
	    goto checkForCatch;
	}
	if (objResultPtr == NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "key \"", TclGetString(*tosPtr),
		    "\" not known in dictionary", NULL);
	    TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    cleanup = opnd + 1;
	    goto checkForCatch;
	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_V(5, opnd+1, 1);

    case INST_DICT_SET:
    case INST_DICT_UNSET:
    case INST_DICT_INCR_IMM:
	opnd = TclGetUInt4AtPtr(pc+1);
	opnd2 = TclGetUInt4AtPtr(pc+5);

	varPtr = &(compiledLocals[opnd2]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u %u => ", opnd, opnd2));
	if (TclIsVarDirectReadable(varPtr)) {
	    dictPtr = varPtr->value.objPtr;
	} else {
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    TclNewObj(dictPtr);
	    allocateDict = 1;
	} else {
	    allocateDict = Tcl_IsShared(dictPtr);
	    if (allocateDict) {
		dictPtr = Tcl_DuplicateObj(dictPtr);
	    }
	}

	switch (*pc) {
	case INST_DICT_SET:
	    cleanup = opnd + 1;
	    result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, tosPtr-opnd,
		    *tosPtr);
	    break;
	case INST_DICT_INCR_IMM:
	    cleanup = 1;
	    opnd = TclGetInt4AtPtr(pc+1);
	    result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &valPtr);
	    if (result != TCL_OK) {
		break;
	    }
	    if (valPtr == NULL) {
		Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewIntObj(opnd));
	    } else {
		Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd);
		Tcl_IncrRefCount(incrPtr);
		if (Tcl_IsShared(valPtr)) {
		    valPtr = Tcl_DuplicateObj(valPtr);
		    Tcl_DictObjPut(NULL, dictPtr, *tosPtr, valPtr);
		}
		result = TclIncrObj(interp, valPtr, incrPtr);
		if (result == TCL_OK) {
		    Tcl_InvalidateStringRep(dictPtr);
		}
		Tcl_DecrRefCount(incrPtr);
	    }
	    break;
	case INST_DICT_UNSET:
	    cleanup = opnd;
	    result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd,
		    tosPtr - (opnd-1));
	    break;
	default:
	    cleanup = 0; /* stop compiler warning */
	    Tcl_Panic("Should not happen!");
	}

	if (result != TCL_OK) {
	    if (allocateDict) {
		Tcl_DecrRefCount(dictPtr);
	    }
	    TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",opnd,opnd2),
		    Tcl_GetObjResult(interp));
	    goto checkForCatch;
	}

	if (TclIsVarDirectWritable(varPtr)) {
	    if (allocateDict) {
		Tcl_Obj *oldValuePtr = varPtr->value.objPtr;

		Tcl_IncrRefCount(dictPtr);
		if (oldValuePtr != NULL) {
		    Tcl_DecrRefCount(oldValuePtr);
		} else {
		    TclSetVarScalar(varPtr);
		    TclClearVarUndefined(varPtr);
		}
		varPtr->value.objPtr = dictPtr;
	    }
	    objResultPtr = dictPtr;
	} else {
	    Tcl_IncrRefCount(dictPtr);
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
		    dictPtr, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    Tcl_DecrRefCount(dictPtr);
	    if (objResultPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	}
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+9) == INST_POP) {
	    NEXT_INST_V(10, cleanup, 0);
	}
#endif
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_V(9, cleanup, 1);

    case INST_DICT_APPEND:
    case INST_DICT_LAPPEND:
	opnd = TclGetUInt4AtPtr(pc+1);
	cleanup = 2;

	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));
	if (TclIsVarDirectReadable(varPtr)) {
	    dictPtr = varPtr->value.objPtr;
	} else {
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    TclNewObj(dictPtr);
	    allocateDict = 1;
	} else {
	    allocateDict = Tcl_IsShared(dictPtr);
	    if (allocateDict) {
		dictPtr = Tcl_DuplicateObj(dictPtr);
	    }
	}

	result = Tcl_DictObjGet(interp, dictPtr, *(tosPtr - 1), &valPtr);
	if (result != TCL_OK) {
	    if (allocateDict) {
		Tcl_DecrRefCount(dictPtr);
	    }
	    goto checkForCatch;
	}

	/*
	 * Note that a non-existent key results in a NULL valPtr, which is a
	 * case handled separately below. What we *can* say at this point is
	 * that the write-back will always succeed.
	 */

	switch (*pc) {
	case INST_DICT_APPEND:
	    if (valPtr == NULL) {
		valPtr = *tosPtr;
	    } else {
		if (Tcl_IsShared(valPtr)) {
		    valPtr = Tcl_DuplicateObj(valPtr);
		}
		Tcl_AppendObjToObj(valPtr, *tosPtr);
	    }
	    break;
	case INST_DICT_LAPPEND:
	    /*
	     * More complex because list-append can fail.
	     */
	    if (valPtr == NULL) {
		valPtr = Tcl_NewListObj(1, tosPtr);
	    } else if (Tcl_IsShared(valPtr)) {
		valPtr = Tcl_DuplicateObj(valPtr);
		result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr);
		if (result != TCL_OK) {
		    Tcl_DecrRefCount(valPtr);
		    if (allocateDict) {
			Tcl_DecrRefCount(dictPtr);
		    }
		    goto checkForCatch;
		}
	    } else {
		result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr);
		if (result != TCL_OK) {
		    if (allocateDict) {
			Tcl_DecrRefCount(dictPtr);
		    }
		    goto checkForCatch;
		}
	    }
	    break;
	default:
	    Tcl_Panic("Should not happen!");
	}

	Tcl_DictObjPut(NULL, dictPtr, *(tosPtr - 1), valPtr);

	if (TclIsVarDirectWritable(varPtr)) {
	    if (allocateDict) {
		Tcl_Obj *oldValuePtr = varPtr->value.objPtr;

		Tcl_IncrRefCount(dictPtr);
		if (oldValuePtr != NULL) {
		    Tcl_DecrRefCount(oldValuePtr);
		} else {
		    TclSetVarScalar(varPtr);
		    TclClearVarUndefined(varPtr);
		}
		varPtr->value.objPtr = dictPtr;
	    }
	    objResultPtr = dictPtr;
	} else {
	    Tcl_IncrRefCount(dictPtr);
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
		    dictPtr, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    Tcl_DecrRefCount(dictPtr);
	    if (objResultPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	}
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+9) == INST_POP) {
	    NEXT_INST_F(6, 2, 0);
	}
#endif
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_F(5, 2, 1);
    }

    {
	int opnd, done;
	Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr;
	Var *varPtr;
	Tcl_DictSearch *searchPtr;

    case INST_DICT_FIRST:
	opnd = TclGetUInt4AtPtr(pc+1);
	TRACE(("%u => ", opnd));
	dictPtr = POP_OBJECT();
	searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
	result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
		&valuePtr, &done);
	Tcl_DecrRefCount(dictPtr);
	if (result != TCL_OK) {
	    ckfree((char *) searchPtr);
	    cleanup = 0;
	    goto checkForCatch;
	}
	TclNewObj(statePtr);
	statePtr->typePtr = &dictIteratorType;
	statePtr->internalRep.otherValuePtr = (void *) searchPtr;
	varPtr = compiledLocals + opnd;
	if (varPtr->value.objPtr == NULL) {
	    TclSetVarScalar(compiledLocals + opnd);
	    TclClearVarUndefined(compiledLocals + opnd);
	} else if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
	    Tcl_Panic("mis-issued dictFirst!");
	} else {
	    Tcl_DecrRefCount(varPtr->value.objPtr);
	}
	varPtr->value.objPtr = statePtr;
	Tcl_IncrRefCount(statePtr);
	goto pushDictIteratorResult;

    case INST_DICT_NEXT:
	opnd = TclGetUInt4AtPtr(pc+1);
	TRACE(("%u => ", opnd));
	statePtr = compiledLocals[opnd].value.objPtr;
	if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
	    Tcl_Panic("mis-issued dictNext!");
	}
	searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr;
	Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
    pushDictIteratorResult:
	if (done) {
	    TclNewObj(emptyPtr);
	    PUSH_OBJECT(emptyPtr);
	    PUSH_OBJECT(emptyPtr);
	} else {
	    PUSH_OBJECT(valuePtr);
	    PUSH_OBJECT(keyPtr);
	}
	TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
		O2S(*(tosPtr-1)), O2S(*tosPtr), done));
	objResultPtr = eePtr->constants[done];
	/*TODO: consider opt like INST_FOREACH_STEP4 */
	NEXT_INST_F(5, 0, 1);

    case INST_DICT_DONE:
	opnd = TclGetUInt4AtPtr(pc+1);
	TRACE(("%u => ", opnd));
	statePtr = compiledLocals[opnd].value.objPtr;
	if (statePtr == NULL) {
	    Tcl_Panic("mis-issued dictDone!");
	}
	if (statePtr->typePtr == &dictIteratorType) {
	    searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr;
	    Tcl_DictObjDone(searchPtr);
	    ckfree((char *) searchPtr);
	}
	/*
	 * Set the internal variable to an empty object to signify
	 * that we don't hold an iterator.
	 */
	Tcl_DecrRefCount(statePtr);
	TclNewObj(emptyPtr);
	compiledLocals[opnd].value.objPtr = emptyPtr;
	Tcl_IncrRefCount(emptyPtr);
	NEXT_INST_F(5, 0, 0);
    }

    {
	int opnd, i, length, length2, allocdict;
	Tcl_Obj **keyPtrPtr, **varIdxPtrPtr, *dictPtr;
	Var *varPtr;
	char *part1;

    case INST_DICT_UPDATE_START:
	opnd = TclGetUInt4AtPtr(pc+1);
	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));
	if (TclIsVarDirectReadable(varPtr)) {
	    dictPtr = varPtr->value.objPtr;
	} else {
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (dictPtr == NULL) {
		goto dictUpdateStartFailed;
	    }
	}
	if (Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length,
			&keyPtrPtr) != TCL_OK ||
		Tcl_ListObjGetElements(interp, *tosPtr, &length2,
			&varIdxPtrPtr) != TCL_OK) {
	    goto dictUpdateStartFailed;
	}
	if (length != length2) {
	    Tcl_Panic("dictUpdateStart argument length mismatch");
	}
	for (i=0 ; i<length ; i++) {
	    Tcl_Obj *valPtr;
	    int varIdx;

	    if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
		    &valPtr) != TCL_OK) {
		goto dictUpdateStartFailed;
	    }
	    Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx);
	    varPtr = &(compiledLocals[varIdx]);
	    part1 = varPtr->name;
	    while (TclIsVarLink(varPtr)) {
		varPtr = varPtr->value.linkPtr;
	    }
	    DECACHE_STACK_INFO();
	    if (valPtr == NULL) {
		Tcl_UnsetVar(interp, part1, 0);
	    } else if (TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
		    valPtr, TCL_LEAVE_ERR_MSG) == NULL) {
		CACHE_STACK_INFO();
	    dictUpdateStartFailed:
		cleanup = 2;
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    CACHE_STACK_INFO();
	}
	NEXT_INST_F(5, 2, 0);

    case INST_DICT_UPDATE_END:
	opnd = TclGetUInt4AtPtr(pc+1);
	varPtr = &(compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));
	if (TclIsVarDirectReadable(varPtr)) {
	    dictPtr = varPtr->value.objPtr;
	} else {
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    NEXT_INST_F(5, 2, 0);
	}
	if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK ||
		Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length,
			&keyPtrPtr) != TCL_OK ||
		Tcl_ListObjGetElements(interp, *tosPtr, &length2,
			&varIdxPtrPtr) != TCL_OK) {
	    cleanup = 2;
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	allocdict = Tcl_IsShared(dictPtr);
	if (allocdict) {
	    dictPtr = Tcl_DuplicateObj(dictPtr);
	}	
	for (i=0 ; i<length ; i++) {
	    Tcl_Obj *valPtr;
	    int varIdx;
	    Var *var2Ptr;
	    char *part1a;

	    Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx);
	    var2Ptr = &(compiledLocals[varIdx]);
	    part1a = var2Ptr->name;
	    while (TclIsVarLink(var2Ptr)) {
		var2Ptr = var2Ptr->value.linkPtr;
	    }
	    if (TclIsVarDirectReadable(var2Ptr)) {
		valPtr = var2Ptr->value.objPtr;
	    } else {
		DECACHE_STACK_INFO();
		valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0);
		CACHE_STACK_INFO();
	    }
	    if (valPtr == NULL) {
		Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
	    } else {
		Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);
	    }
	}
	if (TclIsVarDirectWritable(varPtr)) {
	    Tcl_IncrRefCount(dictPtr);
	    Tcl_DecrRefCount(varPtr->value.objPtr);
	    varPtr->value.objPtr = dictPtr;
	} else {
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
		    dictPtr, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {
		if (allocdict) {
		    Tcl_DecrRefCount(dictPtr);
		}
		cleanup = 2;
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	}
	NEXT_INST_F(5, 2, 0);
    }

    default:
	Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
    } /* end of switch on opCode */

    /*
     * Division by zero in an expression. Control only reaches this point by
     * "goto divideByZero".
     */

 divideByZero:
    Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
    Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
	    (char *) NULL);

    result = TCL_ERROR;
    goto checkForCatch;

    /*
     * Exponentiation of zero by negative number in an expression.  Control
     * only reaches this point by "goto exponOfZero".
     */

 exponOfZero:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "exponentiation of zero by negative power", -1));
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
	    "exponentiation of zero by negative power", (char *) NULL);
    result = TCL_ERROR;
    goto checkForCatch;

    /*
     * Block for variables needed to process exception returns
     */

    {

	ExceptionRange *rangePtr;  /* Points to closest loop or catch
				    * exception range enclosing the pc. Used
				    * by various instructions and processCatch
				    * to process break, continue, and
				    * errors. */
	Tcl_Obj *valuePtr;
	char *bytes;
	int length;
#if TCL_COMPILE_DEBUG
	int opnd;
#endif

	/*
	 * An external evaluation (INST_INVOKE or INST_EVAL) returned
	 * something different from TCL_OK, or else INST_BREAK or
	 * INST_CONTINUE were called.
	 */

    processExceptionReturn:
#if TCL_COMPILE_DEBUG
	switch (*pc) {
	case INST_INVOKE_STK1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
	    break;
	case INST_INVOKE_STK4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
	    break;
	case INST_EVAL_STK:
	    /*
	     * Note that the object at stacktop has to be used before doing
	     * the cleanup.
	     */

	    TRACE(("\"%.30s\" => ", O2S(*tosPtr)));
	    break;
	default:
	    TRACE(("=> "));
	}
#endif
	if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
	    rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
	    if (rangePtr == NULL) {
		TRACE_APPEND(("no encl. loop or catch, returning %s\n",
			StringForResultCode(result)));
		goto abnormalReturn;
	    }
	    if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
		TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
		goto processCatch;
	    }
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
	    if (result == TCL_BREAK) {
		result = TCL_OK;
		pc = (codePtr->codeStart + rangePtr->breakOffset);
		TRACE_APPEND(("%s, range at %d, new pc %d\n",
			StringForResultCode(result),
			rangePtr->codeOffset, rangePtr->breakOffset));
		NEXT_INST_F(0, 0, 0);
	    } else {
		if (rangePtr->continueOffset == -1) {
		    TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
			    StringForResultCode(result)));
		    goto checkForCatch;
		}
		result = TCL_OK;
		pc = (codePtr->codeStart + rangePtr->continueOffset);
		TRACE_APPEND(("%s, range at %d, new pc %d\n",
			StringForResultCode(result),
			rangePtr->codeOffset, rangePtr->continueOffset));
		NEXT_INST_F(0, 0, 0);
	    }
#if TCL_COMPILE_DEBUG
	} else if (traceInstructions) {
	    if ((result != TCL_ERROR) && (result != TCL_RETURN))  {
		Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
		TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
			result, O2S(objPtr)));
	    } else {
		Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
		TRACE_APPEND(("%s, result= \"%s\"\n",
			StringForResultCode(result), O2S(objPtr)));
	    }
#endif
	}

	/*
	 * Execution has generated an "exception" such as TCL_ERROR. If the
	 * exception is an error, record information about what was being
	 * executed when the error occurred. Find the closest enclosing catch
	 * range, if any. If no enclosing catch range is found, stop execution
	 * and return the "exception" code.
	 */

	checkForCatch:
	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	    bytes = GetSrcInfoForPc(pc, codePtr, &length);
	    if (bytes != NULL) {
		Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
	    }
	}
	iPtr->flags &= ~ERR_ALREADY_LOGGED;

	/*
	 * Clear all expansions that may have started after the last
	 * INST_BEGIN_CATCH.
	 */

	while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
		((ptrdiff_t) eePtr->stackPtr[catchTop] <=
		(ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
	    Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
	    TclDecrRefCount(expandNestList);
	    expandNestList = objPtr;
	}

	/*
	 * We must not catch an exceeded limit.  Instead, it blows outwards
	 * until we either hit another interpreter (presumably where the limit
	 * is not exceeded) or we get to the top-level.
	 */
	if (Tcl_LimitExceeded(interp)) {
#ifdef TCL_COMPILE_DEBUG
	    if (traceInstructions) {
		fprintf(stdout, "   ... limit exceeded, returning %s\n",
			StringForResultCode(result));
	    }
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953

4954
4955
4956
4957
4958
4959
4960
4961










4962
4963
4964
4965
4966
4967
4968
#endif
	    goto abnormalReturn;
	}
	rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
	if (rangePtr == NULL) {
	    /*
	     * This is only possible when compiling a [catch] that sends its
	     * script to INST_EVAL. Cannot correct the compiler without 
	     * breakingcompat with previous .tbc compiled scripts.
	     */
#ifdef TCL_COMPILE_DEBUG
	    if (traceInstructions) {
		fprintf(stdout, "   ... no enclosing catch, returning %s\n",
			StringForResultCode(result));
	    }
#endif
	    goto abnormalReturn;
	}
	
	/*
	 * A catch exception range (rangePtr) was found to handle an
	 * "exception". It was found either by checkForCatch just above or
	 * by an instruction during break, continue, or error processing.
	 * Jump to its catchOffset after unwinding the operand stack to 
	 * the depth it had when starting to execute the range's catch
	 * command.
	 */

	processCatch:
	while (tosPtr > ((ptrdiff_t) (eePtr->stackPtr[catchTop])) + eePtr->stackPtr) {
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	}
#ifdef TCL_COMPILE_DEBUG
	if (traceInstructions) {
	    fprintf(stdout, "  ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
		    rangePtr->codeOffset, (catchTop - initCatchTop - 1), 
		    (int) eePtr->stackPtr[catchTop],
		    (unsigned int)(rangePtr->catchOffset));
	}
#endif	
	pc = (codePtr->codeStart + rangePtr->catchOffset);
	NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
	
	/* 
	 * end of infinite loop dispatching on instructions.
	 */
	
	/*
	 * Abnormal return code. Restore the stack to state it had when starting
	 * to execute the ByteCode. Panic if the stack is below the initial level.

	 */
	
	abnormalReturn:
	{
	    Tcl_Obj **initTosPtr = eePtr->stackPtr + initStackTop;
	    while (tosPtr > initTosPtr) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);










	    }
	    if (tosPtr < initTosPtr) {
		fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
			(unsigned int)(pc - codePtr->codeStart),
			(unsigned int) (tosPtr - eePtr->stackPtr),
			(unsigned int) initStackTop);
		Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");







|










|


|
|
|
|
<










|



|


|
|


|

|
|
>

|




|
|
>
>
>
>
>
>
>
>
>
>







6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224

6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
#endif
	    goto abnormalReturn;
	}
	rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
	if (rangePtr == NULL) {
	    /*
	     * This is only possible when compiling a [catch] that sends its
	     * script to INST_EVAL. Cannot correct the compiler without
	     * breakingcompat with previous .tbc compiled scripts.
	     */
#ifdef TCL_COMPILE_DEBUG
	    if (traceInstructions) {
		fprintf(stdout, "   ... no enclosing catch, returning %s\n",
			StringForResultCode(result));
	    }
#endif
	    goto abnormalReturn;
	}

	/*
	 * A catch exception range (rangePtr) was found to handle an
	 * "exception". It was found either by checkForCatch just above or by
	 * an instruction during break, continue, or error processing.  Jump
	 * to its catchOffset after unwinding the operand stack to the depth
	 * it had when starting to execute the range's catch command.

	 */

	processCatch:
	while (tosPtr > ((ptrdiff_t) (eePtr->stackPtr[catchTop])) + eePtr->stackPtr) {
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	}
#ifdef TCL_COMPILE_DEBUG
	if (traceInstructions) {
	    fprintf(stdout, "  ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
		    rangePtr->codeOffset, (catchTop - initCatchTop - 1),
		    (int) eePtr->stackPtr[catchTop],
		    (unsigned int)(rangePtr->catchOffset));
	}
#endif
	pc = (codePtr->codeStart + rangePtr->catchOffset);
	NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */

	/*
	 * end of infinite loop dispatching on instructions.
	 */

	/*
	 * Abnormal return code. Restore the stack to state it had when
	 * starting to execute the ByteCode. Panic if the stack is below the
	 * initial level.
	 */

	abnormalReturn:
	{
	    Tcl_Obj **initTosPtr = eePtr->stackPtr + initStackTop;
	    while (tosPtr > initTosPtr) {
		Tcl_Obj *objPtr = POP_OBJECT();
		TclDecrRefCount(objPtr);
	    }

	    /*
	     * Clear all expansions.
	     */

	    while (expandNestList) {
		Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
		TclDecrRefCount(expandNestList);
		expandNestList = objPtr;
	    }
	    if (tosPtr < initTosPtr) {
		fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
			(unsigned int)(pc - codePtr->codeStart),
			(unsigned int) (tosPtr - eePtr->stackPtr),
			(unsigned int) initStackTop);
		Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * PrintByteCodeInfo --
 *
 *	This procedure prints a summary about a bytecode object to stdout.
 *	It is called by TclExecuteByteCode when starting to execute the
 *	bytecode object if tclTraceExec has the value 2 or more.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
PrintByteCodeInfo(codePtr)
    register ByteCode *codePtr;	/* The bytecode whose summary is printed
				 * to stdout. */
{
    Proc *procPtr = codePtr->procPtr;
    Interp *iPtr = (Interp *) *codePtr->interpHandle;

    fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
	    (unsigned int) codePtr, codePtr->refCount,
	    codePtr->compileEpoch, (unsigned int) iPtr,
	    iPtr->compileEpoch);
    
    fprintf(stdout, "  Source: ");
    TclPrintSource(stdout, codePtr->source, 60);

    fprintf(stdout, "\n  Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
            codePtr->numCommands, codePtr->numSrcBytes,
	    codePtr->numCodeBytes, codePtr->numLitObjects,
	    codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
	    (codePtr->numSrcBytes?
	            ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
#else
	    0.0);
#endif
#ifdef TCL_COMPILE_STATS
    fprintf(stdout, "  Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
	    codePtr->structureSize,
	    (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
	    codePtr->numCodeBytes,
	    (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (codePtr->numExceptRanges * sizeof(ExceptionRange)),







|
|
|












|
|








|




|



|
|
|

|







6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * PrintByteCodeInfo --
 *
 *	This procedure prints a summary about a bytecode object to stdout.  It
 *	is called by TclExecuteByteCode when starting to execute the bytecode
 *	object if tclTraceExec has the value 2 or more.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
PrintByteCodeInfo(codePtr)
    register ByteCode *codePtr;	/* The bytecode whose summary is printed to
				 * stdout. */
{
    Proc *procPtr = codePtr->procPtr;
    Interp *iPtr = (Interp *) *codePtr->interpHandle;

    fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
	    (unsigned int) codePtr, codePtr->refCount,
	    codePtr->compileEpoch, (unsigned int) iPtr,
	    iPtr->compileEpoch);

    fprintf(stdout, "  Source: ");
    TclPrintSource(stdout, codePtr->source, 60);

    fprintf(stdout, "\n  Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
	    codePtr->numCommands, codePtr->numSrcBytes,
	    codePtr->numCodeBytes, codePtr->numLitObjects,
	    codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
	    codePtr->numSrcBytes?
		((float)codePtr->structureSize)/codePtr->numSrcBytes :
#endif
	    0.0);

#ifdef TCL_COMPILE_STATS
    fprintf(stdout, "  Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
	    codePtr->structureSize,
	    (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
	    codePtr->numCodeBytes,
	    (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (codePtr->numExceptRanges * sizeof(ExceptionRange)),
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
 *	verify that the program counter and stack top are valid during
 *	execution.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Prints a message to stderr and panics if either the pc or stack
 *	top are invalid.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack)
    register ByteCode *codePtr; /* The bytecode whose summary is printed
				 * to stdout. */
    unsigned char *pc;		/* Points to first byte of a bytecode
				 * instruction. The program counter. */
    int stackTop;		/* Current stack top. Must be between
				 * stackLowerBound and stackUpperBound
				 * (inclusive). */
    int stackLowerBound;	/* Smallest legal value for stackTop. */
    int checkStack;             /* 0 if the stack depth check should be
				 * skipped. */
{
    int stackUpperBound = stackLowerBound +  codePtr->maxStackDepth;	
                                /* Greatest legal value for stackTop. */
    unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
    unsigned int codeStart = (unsigned int) codePtr->codeStart;
    unsigned int codeEnd = (unsigned int)
	    (codePtr->codeStart + codePtr->numCodeBytes);
    unsigned char opCode = *pc;

    if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
	fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
		(unsigned int) pc);
	Tcl_Panic("TclExecuteByteCode execution failure: bad pc");
    }
    if ((unsigned int) opCode > LAST_INST_OPCODE) {
	fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
		(unsigned int) opCode, relativePc);
        Tcl_Panic("TclExecuteByteCode execution failure: bad opcode");
    }
    if (checkStack && 
            ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
	int numChars;
	char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
	
	fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
		stackTop, relativePc, stackLowerBound, stackUpperBound);
	if (cmd != NULL) {
	    Tcl_Obj *message = Tcl_NewStringObj("\n executing ", -1);
	    Tcl_IncrRefCount(message);
	    TclAppendLimitedToObj(message, cmd, numChars, 100, NULL);
	    fprintf(stderr,"%s\n", Tcl_GetString(message));







|
|







|
|






|


|
|














|

|
|


|







6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
 *	verify that the program counter and stack top are valid during
 *	execution.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Prints a message to stderr and panics if either the pc or stack top
 *	are invalid.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack)
    register ByteCode *codePtr; /* The bytecode whose summary is printed to
				 * stdout. */
    unsigned char *pc;		/* Points to first byte of a bytecode
				 * instruction. The program counter. */
    int stackTop;		/* Current stack top. Must be between
				 * stackLowerBound and stackUpperBound
				 * (inclusive). */
    int stackLowerBound;	/* Smallest legal value for stackTop. */
    int checkStack;		/* 0 if the stack depth check should be
				 * skipped. */
{
    int stackUpperBound = stackLowerBound +  codePtr->maxStackDepth;
				/* Greatest legal value for stackTop. */
    unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
    unsigned int codeStart = (unsigned int) codePtr->codeStart;
    unsigned int codeEnd = (unsigned int)
	    (codePtr->codeStart + codePtr->numCodeBytes);
    unsigned char opCode = *pc;

    if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
	fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
		(unsigned int) pc);
	Tcl_Panic("TclExecuteByteCode execution failure: bad pc");
    }
    if ((unsigned int) opCode > LAST_INST_OPCODE) {
	fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
		(unsigned int) opCode, relativePc);
	Tcl_Panic("TclExecuteByteCode execution failure: bad opcode");
    }
    if (checkStack &&
	    ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
	int numChars;
	char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);

	fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
		stackTop, relativePc, stackLowerBound, stackUpperBound);
	if (cmd != NULL) {
	    Tcl_Obj *message = Tcl_NewStringObj("\n executing ", -1);
	    Tcl_IncrRefCount(message);
	    TclAppendLimitedToObj(message, cmd, numChars, 100, NULL);
	    fprintf(stderr,"%s\n", Tcl_GetString(message));
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140


5141


5142
5143
5144
5145
5146

5147

5148
5149
5150

5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170

5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * IllegalExprOperandType --
 *
 *	Used by TclExecuteByteCode to append an error message to
 *	the interp result when an illegal operand type is detected by an
 *	expression instruction. The argument opndPtr holds the operand
 *	object in error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is appended to the interp result.
 *
 *----------------------------------------------------------------------
 */

static void
IllegalExprOperandType(interp, pc, opndPtr)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    unsigned char *pc;		/* Points to the instruction being executed
				 * when the illegal type was found. */
    Tcl_Obj *opndPtr;		/* Points to the operand holding the value
				 * with the illegal type. */
{


    unsigned char opCode = *pc;


    CONST char *operator = operatorStrings[opCode - INST_LOR];
    if (opCode == INST_EXPON) {
	operator = "**";
    }


    Tcl_SetObjResult(interp, Tcl_NewObj()); 

    if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
	Tcl_AppendResult(interp, "can't use empty string as operand of \"",
		operator, "\"", (char *) NULL);

    } else {
	char *msg = "non-numeric string";
	char *s, *p;
	int length;
	int looksLikeInt = 0;

	s = Tcl_GetStringFromObj(opndPtr, &length);
	p = s;
	/*
	 * strtod() isn't at all consistent about detecting Inf and
	 * NaN between platforms.
	 */
	if (length == 3) {
	    if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
		    (s[2]=='n' || s[2]=='N')) {
		msg = "non-numeric floating-point value";
		goto makeErrorMessage;
	    }
	    if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
		    (s[2]=='f' || s[2]=='F')) {

		msg = "infinite floating-point value";
		goto makeErrorMessage;
	    }
	}

	/*
	 * We cannot use TclLooksLikeInt here because it passes strings
	 * like "10;" [Bug 587140]. We'll accept as "looking like ints"
	 * for the present purposes any string that looks formally like
	 * a (decimal|octal|hex) integer.
	 */

	while (length && isspace(UCHAR(*p))) {
	    length--;
	    p++;
	}
	if (length && ((*p == '+') || (*p == '-'))) {
	    length--;
	    p++;
	}
	if (length) {
	    if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
		p += 2;
		length -= 2;
		looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
		if (looksLikeInt) {
		    length--;
		    p++;
		    while (length && isxdigit(UCHAR(*p))) {
			length--;
			p++;
		    }
		}
	    } else {
		looksLikeInt = (length && isdigit(UCHAR(*p)));
		if (looksLikeInt) {
		    length--;
		    p++;
		    while (length && isdigit(UCHAR(*p))) {
			length--;
			p++;
		    }
		}
	    }
	    while (length && isspace(UCHAR(*p))) {
		length--;
		p++;
	    }
	    looksLikeInt = !length;
	}
	if (looksLikeInt) {
	    /*
	     * If something that looks like an integer could not be
	     * converted, then it *must* be a bad octal or too large
	     * to represent [Bug 542588].
	     */

	    if (TclCheckBadOctal(NULL, s)) {
		msg = "invalid octal number";
	    } else {
		msg = "integer value too large to represent";
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
		    "integer value too large to represent", (char *) NULL);
	    }
	} else {
	    /*
	     * See if the operand can be interpreted as a double in
	     * order to improve the error message.
	     */

	    double d;

	    if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
		msg = "floating-point value";
	    }
	}
      makeErrorMessage:
	Tcl_AppendResult(interp, "can't use ", msg, " as operand of \"",
		operator, "\"", (char *) NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * GetSrcInfoForPc --
 *
 *	Given a program counter value, finds the closest command in the
 *	bytecode code unit's CmdLocation array and returns information about
 *	that command's source: a pointer to its first byte and the number of
 *	characters.
 *
 * Results:
 *	If a command is found that encloses the program counter value, a
 *	pointer to the command's source is returned and the length of the
 *	source is stored at *lengthPtr. If multiple commands resulted in
 *	code at pc, information about the closest enclosing command is
 *	returned. If no matching command is found, NULL is returned and
 *	*lengthPtr is unchanged.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
GetSrcInfoForPc(pc, codePtr, lengthPtr)
    unsigned char *pc;		/* The program counter value for which to
				 * return the closest command's source info.
				 * This points to a bytecode instruction
				 * in codePtr's code. */
    ByteCode *codePtr;		/* The bytecode sequence in which to look
				 * up the command source for the pc. */
    int *lengthPtr;		/* If non-NULL, the location where the
				 * length of the command's source should be
				 * stored. If NULL, no length is stored. */
{
    register int pcOffset = (pc - codePtr->codeStart);
    int numCmds = codePtr->numCommands;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
    int bestDist = INT_MAX;	/* Distance of pc to best cmd's start pc. */







|
|
|
<



















>
>
|
>
>
|
|



>
|
>
|
|
|
>
|
|
<
<
<
|
<
<
<
<
<
<
|
<
<
|
<
<
<
<
>
|
<
|
<
|
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
<
<
<
<
<
<
<
<















|
|
|
|











|
|
|
|
|
|
|







6418
6419
6420
6421
6422
6423
6424
6425
6426
6427

6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465



6466






6467


6468




6469
6470

6471

6472






6473



6474















6475
























6476












6477

6478








6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * IllegalExprOperandType --
 *
 *	Used by TclExecuteByteCode to append an error message to the interp
 *	result when an illegal operand type is detected by an expression
 *	instruction. The argument opndPtr holds the operand object in error.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is appended to the interp result.
 *
 *----------------------------------------------------------------------
 */

static void
IllegalExprOperandType(interp, pc, opndPtr)
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    unsigned char *pc;		/* Points to the instruction being executed
				 * when the illegal type was found. */
    Tcl_Obj *opndPtr;		/* Points to the operand holding the value
				 * with the illegal type. */
{
    ClientData ptr;
    int type;
    unsigned char opcode = *pc;
    CONST char *description, *operator = operatorStrings[opcode - INST_LOR];
    Tcl_Obj *msg = Tcl_NewObj();

    if (opcode == INST_EXPON) {
	operator = "**";
    }

    if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
	int numBytes;
	CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
	if (numBytes == 0) {
	    description = "empty string";
	} else if (TclCheckBadOctal(NULL, bytes)) {
	    description = "invalid octal number";
	} else {
	    description = "non-numeric string";



	}






    } else if (type == TCL_NUMBER_NAN) {


	description = "non-numeric floating-point value";




    } else if (type == TCL_NUMBER_DOUBLE) {
	description = "floating-point value";

    } else {

	/* TODO: No caller needs this.  Eliminate? */






	description = "(big) integer";



    }








































    TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"",












	    description, operator);

    Tcl_SetObjResult(interp, msg);








}

/*
 *----------------------------------------------------------------------
 *
 * GetSrcInfoForPc --
 *
 *	Given a program counter value, finds the closest command in the
 *	bytecode code unit's CmdLocation array and returns information about
 *	that command's source: a pointer to its first byte and the number of
 *	characters.
 *
 * Results:
 *	If a command is found that encloses the program counter value, a
 *	pointer to the command's source is returned and the length of the
 *	source is stored at *lengthPtr. If multiple commands resulted in code
 *	at pc, information about the closest enclosing command is returned. If
 *	no matching command is found, NULL is returned and *lengthPtr is
 *	unchanged.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
GetSrcInfoForPc(pc, codePtr, lengthPtr)
    unsigned char *pc;		/* The program counter value for which to
				 * return the closest command's source info.
				 * This points to a bytecode instruction in
				 * codePtr's code. */
    ByteCode *codePtr;		/* The bytecode sequence in which to look up
				 * the command source for the pc. */
    int *lengthPtr;		/* If non-NULL, the location where the length
				 * of the command's source should be stored.
				 * If NULL, no length is stored. */
{
    register int pcOffset = (pc - codePtr->codeStart);
    int numCmds = codePtr->numCommands;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
    int bestDist = INT_MAX;	/* Distance of pc to best cmd's start pc. */
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273


6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}
	
	if (codeOffset > pcOffset) {      /* best cmd already found */
	    break;
	} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
	    int dist = (pcOffset - codeOffset);
	    if (dist <= bestDist) {
		bestDist = dist;
		bestSrcOffset = srcOffset;
		bestSrcLength = srcLen;
	    }
	}
    }

    if (bestDist == INT_MAX) {
	return NULL;
    }
    
    if (lengthPtr != NULL) {
	*lengthPtr = bestSrcLength;
    }
    return (codePtr->source + bestSrcOffset);
}

/*
 *----------------------------------------------------------------------
 *
 * GetExceptRangeForPc --
 *
 *	Given a program counter value, return the closest enclosing
 *	ExceptionRange.
 *
 * Results:
 *	In the normal case, catchOnly is 0 (false) and this procedure
 *	returns a pointer to the most closely enclosing ExceptionRange
 *	structure regardless of whether it is a loop or catch exception
 *	range. This is appropriate when processing a TCL_BREAK or
 *	TCL_CONTINUE, which will be "handled" either by a loop exception
 *	range or a closer catch range. If catchOnly is nonzero, this
 *	procedure ignores loop exception ranges and returns a pointer to the
 *	closest catch range. If no matching ExceptionRange is found that
 *	encloses pc, a NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static ExceptionRange *
GetExceptRangeForPc(pc, catchOnly, codePtr)
    unsigned char *pc;		/* The program counter value for which to
				 * search for a closest enclosing exception
				 * range. This points to a bytecode
				 * instruction in codePtr's code. */
    int catchOnly;		/* If 0, consider either loop or catch
				 * ExceptionRanges in search. If nonzero
				 * consider only catch ranges (and ignore
				 * any closer loop ranges). */
    ByteCode* codePtr;		/* Points to the ByteCode in which to search
				 * for the enclosing ExceptionRange. */
{
    ExceptionRange *rangeArrayPtr;
    int numRanges = codePtr->numExceptRanges;
    register ExceptionRange *rangePtr;
    int pcOffset = (pc - codePtr->codeStart);
    register int start;

    if (numRanges == 0) {
	return NULL;
    }

    /* 
     * This exploits peculiarities of our compiler: nested ranges
     * are always *after* their containing ranges, so that by scanning
     * backwards we are sure that the first matching range is indeed
     * the deepest.
     */

    rangeArrayPtr = codePtr->exceptArrayPtr;
    rangePtr = rangeArrayPtr + numRanges;
    while (--rangePtr >= rangeArrayPtr) {
	start = rangePtr->codeOffset;
	if ((start <= pcOffset) &&
	        (pcOffset < (start + rangePtr->numCodeBytes))) {
	    if ((!catchOnly)
		    || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
		return rangePtr;
	    }
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * GetOpcodeName --
 *
 *	This procedure is called by the TRACE and TRACE_WITH_OBJ macros
 *	used in TclExecuteByteCode when debugging. It returns the name of
 *	the bytecode instruction at a specified instruction pc.
 *
 * Results:
 *	A character string for the instruction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_COMPILE_DEBUG
static char *
GetOpcodeName(pc)
    unsigned char *pc;		/* Points to the instruction whose name
				 * should be returned. */
{
    unsigned char opCode = *pc;
    
    return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * VerifyExprObjType --
 *
 *	This procedure is called by the math functions to verify that
 *	the object is either an int or double, coercing it if necessary.
 *	If an error occurs during conversion, an error message is left
 *	in the interpreter's result unless "interp" is NULL.
 *
 * Results:
 *	TCL_OK if it was int or double, TCL_ERROR otherwise
 *
 * Side effects:
 *	objPtr is ensured to be of tclIntType, tclWideIntType or
 *	tclDoubleType.
 *
 *----------------------------------------------------------------------
 */

static int
VerifyExprObjType(interp, objPtr)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj *objPtr;		/* Points to the object to type check. */
{
    if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
	return TCL_OK;
    } else {
	int length, result = TCL_OK;
	char *s = Tcl_GetStringFromObj(objPtr, &length);
	
	if (TclLooksLikeInt(s, length)) {
	    long i;     /* Set but never used, needed in GET_WIDE_OR_INT */
	    Tcl_WideInt w;
	    GET_WIDE_OR_INT(result, objPtr, i, w);
	} else {
	    double d;
	    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
	}
	if ((result != TCL_OK) && (interp != NULL)) {
	    if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"argument to math function was an invalid octal number",
			-1));
	    } else {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"argument to math function didn't have numeric value",
			-1));
	    }
	}
	return result;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Math Functions --
 *
 *	This page contains the procedures that implement all of the
 *	built-in math functions for expressions.
 *
 * Results:
 *	Each procedure returns TCL_OK if it succeeds and pushes an
 *	Tcl object holding the result. If it fails it returns TCL_ERROR
 *	and leaves an error message in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ExprUnaryFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes one double argument and returns a
				 * double result. */
{
    register Tcl_Obj *valuePtr;
    double d, dResult;
    
    double (*func) _ANSI_ARGS_((double)) =
	(double (*)_ANSI_ARGS_((double))) clientData;

    /*
     * Pop the function's argument from the evaluation stack. Convert it
     * to a double if necessary.
     */

    valuePtr = POP_OBJECT();

    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);

    errno = 0;
    dResult = (*func)(d);
    if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
	TclExprFloatError(interp, dResult);
	return TCL_ERROR;
    }
    
    /*
     * Push a Tcl object holding the result.
     */

    PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
    TclDecrRefCount(valuePtr);
    return TCL_OK;
}

static int
ExprBinaryFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes two double arguments and
				 * returns a double result. */
{
    register Tcl_Obj *valuePtr, *value2Ptr;
    double d1, d2, dResult;
    
    double (*func) _ANSI_ARGS_((double, double))
	= (double (*)_ANSI_ARGS_((double, double))) clientData;

    /*
     * Pop the function's two arguments from the evaluation stack. Convert
     * them to doubles if necessary.
     */

    value2Ptr = POP_OBJECT();
    valuePtr  = POP_OBJECT();

    if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
	    (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
	return TCL_ERROR;
    }

    GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
    GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);

    errno = 0;
    dResult = (*func)(d1, d2);
    if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
	TclExprFloatError(interp, dResult);
	return TCL_ERROR;
    }

    /*
     * Push a Tcl object holding the result.
     */

    PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
    TclDecrRefCount(valuePtr);
    TclDecrRefCount(value2Ptr);
    return TCL_OK;
}

static int
ExprAbsFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    register Tcl_Obj *valuePtr;
    long i, iResult;
    double d, dResult;

    /*
     * Pop the argument from the evaluation stack.
     */

    valuePtr = POP_OBJECT();

    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Push a Tcl object with the result.
     */
    if (valuePtr->typePtr == &tclIntType) {
	i = valuePtr->internalRep.longValue;
	if (i < 0) {
	    iResult = -i;
	    if (iResult < 0) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
		        "integer value too large to represent", -1));
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
			"integer value too large to represent", (char *) NULL);
		return TCL_ERROR;
	    }
	} else {
	    iResult = i;
	}	    
	PUSH_OBJECT(Tcl_NewLongObj(iResult));
    } else if (valuePtr->typePtr == &tclWideIntType) {
	Tcl_WideInt wResult, w;
	TclGetWide(w,valuePtr);
	if (w < W0) {
	    wResult = -w;
	    if (wResult < 0) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
		        "integer value too large to represent", -1));
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
			"integer value too large to represent", (char *) NULL);
		return TCL_ERROR;
	    }
	} else {
	    wResult = w;
	}	    
	PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
    } else {
	d = valuePtr->internalRep.doubleValue;
	if (d < 0.0) {
	    dResult = -d;
	} else {
	    dResult = d;
	}
	if (IS_NAN(dResult) || IS_INF(dResult)) {
	    TclExprFloatError(interp, dResult);
	    return TCL_ERROR;
	}
	PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
    }

    TclDecrRefCount(valuePtr);
    return TCL_OK;
}

static int
ExprDoubleFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    register Tcl_Obj *valuePtr;
    double dResult;

    /*
     * Pop the argument from the evaluation stack.
     */

    valuePtr = POP_OBJECT();

    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);

    /*
     * Push a Tcl object with the result.
     */

    PUSH_OBJECT(Tcl_NewDoubleObj(dResult));

    TclDecrRefCount(valuePtr);
    return TCL_OK;
}

static int
ExprIntFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    register Tcl_Obj *valuePtr;
    long iResult;
    double d;

    /*
     * Pop the argument from the evaluation stack.
     */

    valuePtr = POP_OBJECT();
    
    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    
    if (valuePtr->typePtr == &tclIntType) {
	iResult = valuePtr->internalRep.longValue;
    } else if (valuePtr->typePtr == &tclWideIntType) {
	TclGetLongFromWide(iResult,valuePtr);
    } else {
	d = valuePtr->internalRep.doubleValue;
	if (d < 0.0) {
	    if (d < (double) (long) LONG_MIN) {
		tooLarge:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
		        "integer value too large to represent", -1));
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
			"integer value too large to represent", (char *) NULL);
		return TCL_ERROR;
	    }
	} else {
	    if (d > (double) LONG_MAX) {
		goto tooLarge;
	    }
	}
	if (IS_NAN(d) || IS_INF(d)) {
	    TclExprFloatError(interp, d);
	    return TCL_ERROR;
	}
	iResult = (long) d;
    }

    /*
     * Push a Tcl object with the result.
     */
    
    PUSH_OBJECT(Tcl_NewLongObj(iResult));
    TclDecrRefCount(valuePtr);
    return TCL_OK;
}

static int
ExprWideFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    register Tcl_Obj *valuePtr;
    Tcl_WideInt wResult;
    double d;

    /*
     * Pop the argument from the evaluation stack.
     */

    valuePtr = POP_OBJECT();
    
    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    
    if (valuePtr->typePtr == &tclWideIntType) {
	TclGetWide(wResult,valuePtr);
    } else if (valuePtr->typePtr == &tclIntType) {
	wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
    } else {
	d = valuePtr->internalRep.doubleValue;
	if (d < 0.0) {
	    if (d < Tcl_WideAsDouble(LLONG_MIN)) {
		tooLarge:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
		        "integer value too large to represent", -1));
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
			"integer value too large to represent", (char *) NULL);
		return TCL_ERROR;
	    }
	} else {
	    if (d > Tcl_WideAsDouble(LLONG_MAX)) {
		goto tooLarge;
	    }
	}
	if (IS_NAN(d) || IS_INF(d)) {
	    TclExprFloatError(interp, d);
	    return TCL_ERROR;
	}
	wResult = Tcl_DoubleAsWide(d);
    }

    /*
     * Push a Tcl object with the result.
     */
    
    PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
    TclDecrRefCount(valuePtr);
    return TCL_OK;
}

static int
ExprRandFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    Interp *iPtr = (Interp *) interp;
    double dResult;
    long tmp;			/* Algorithm assumes at least 32 bits.
				 * Only long guarantees that.  See below. */

    if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
	iPtr->flags |= RAND_SEED_INITIALIZED;
        
        /* 
	 * Take into consideration the thread this interp is running in order
	 * to insure different seeds in different threads (bug #416643)
	 */

	iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);

	/*
	 * Make sure 1 <= randSeed <= (2^31) - 2.  See below.
	 */

        iPtr->randSeed &= (unsigned long) 0x7fffffff;
	if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
	    iPtr->randSeed ^= 123459876;
	}
    }

    /*
     * Generate the random number using the linear congruential
     * generator defined by the following recurrence:
     *		seed = ( IA * seed ) mod IM
     * where IA is 16807 and IM is (2^31) - 1.  The recurrence maps
     * a seed in the range [1, IM - 1] to a new seed in that same range.
     * The recurrence maps IM to 0, and maps 0 back to 0, so those two
     * values must not be allowed as initial values of seed.
     *
     * In order to avoid potential problems with integer overflow, the
     * recurrence is implemented in terms of additional constants
     * IQ and IR such that
     *		IM = IA*IQ + IR
     * None of the operations in the implementation overflows a 32-bit
     * signed integer, and the C type long is guaranteed to be at least
     * 32 bits wide.
     *
     * For more details on how this algorithm works, refer to the following
     * papers: 
     *
     *	S.K. Park & K.W. Miller, "Random number generators: good ones
     *	are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
     *
     *	W.H. Press & S.A. Teukolsky, "Portable random number
     *	generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
     */

#define RAND_IA		16807
#define RAND_IM		2147483647
#define RAND_IQ		127773
#define RAND_IR		2836
#define RAND_MASK	123459876

    tmp = iPtr->randSeed/RAND_IQ;
    iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
    if (iPtr->randSeed < 0) {
	iPtr->randSeed += RAND_IM;
    }

    /*
     * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
     * dividing by RAND_IM yields a double in the range (0, 1).
     */

    dResult = iPtr->randSeed * (1.0/RAND_IM);

    /*
     * Push a Tcl object with the result.
     */

    PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
    return TCL_OK;
}

static int
ExprRoundFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    Tcl_Obj *valuePtr, *resPtr;
    double d;

    /*
     * Pop the argument from the evaluation stack.
     */

    valuePtr = POP_OBJECT();

    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    
    if ((valuePtr->typePtr == &tclIntType) ||
	    (valuePtr->typePtr == &tclWideIntType)) {
	return TCL_OK;
    }

    d = valuePtr->internalRep.doubleValue;
    if (d < 0.0) {
	if (d <= Tcl_WideAsDouble(LLONG_MIN)-0.5) {
	    goto tooLarge;
	} else if (d <= (((double) (long) LONG_MIN) - 0.5)) {
	    resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d - 0.5));
	} else {
	    resPtr = Tcl_NewLongObj((long) (d - 0.5));
	}			    
    } else {
	if (d >= Tcl_WideAsDouble(LLONG_MAX)+0.5) {
	    goto tooLarge;
	} else if (d >= (((double) LONG_MAX + 0.5))) {
	    resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d + 0.5));
	} else {
	    resPtr = Tcl_NewLongObj((long) (d + 0.5));
	}
    }

    /*
     * Free the argument Tcl_Obj and push the result object.
     */
    
    TclDecrRefCount(valuePtr);
    PUSH_OBJECT(resPtr);
    return TCL_OK;

    /*
     * Error return: result cannot be represented as an integer.
     */
    
    tooLarge:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "integer value too large to represent", -1));
    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
	    "integer value too large to represent",
	    (char *) NULL);
    return TCL_ERROR;
}

static int
ExprSrandFunc(interp, tosPtr, clientData)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    Tcl_Obj **tosPtr;		/* Points to top of evaluation stack. */
    ClientData clientData;	/* Ignored. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *valuePtr;
    long i = 0;			/* Initialized to avoid compiler warning. */

    /*
     * Pop the argument from the evaluation stack.  Use the value
     * to reset the random number seed.
     */

    valuePtr = POP_OBJECT();

    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    if (valuePtr->typePtr == &tclIntType) {
	i = valuePtr->internalRep.longValue;
    } else if (valuePtr->typePtr == &tclWideIntType) {
	TclGetLongFromWide(i,valuePtr);
    } else {
	/*
	 * At this point, the only other possible type is double
	 */
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"can't use floating-point value as argument to srand", -1));
	return TCL_ERROR;
    }
    
    /*
     * Reset the seed.  Make sure 1 <= randSeed <= 2^31 - 2.
     * See comments in ExprRandFunc() for more details.
     */

    iPtr->flags |= RAND_SEED_INITIALIZED;
    iPtr->randSeed = i;
    iPtr->randSeed &= (unsigned long) 0x7fffffff;
    if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
	iPtr->randSeed ^= 123459876;
    }

    /*
     * To avoid duplicating the random number generation code we simply
     * clean up our state and call the real random number function. That
     * function will always succeed.
     */
    
    TclDecrRefCount(valuePtr);
    ExprRandFunc(interp, tosPtr, clientData);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ExprCallMathFunc --
 *
 *	This procedure is invoked to call a non-builtin math function
 *	during the execution of an expression. 
 *
 * Results:
 *	TCL_OK is returned if all went well and the function's value
 *	was computed successfully. If an error occurred, TCL_ERROR
 *	is returned and an error message is left in the interpreter's
 *	result.	After a successful return this procedure pops its
 *      objc arguments and pushes a Tcl object holding the result. 
 *
 * Side effects:
 *	None, unless the called math function has side effects.
 *
 *----------------------------------------------------------------------
 */

static int
ExprCallMathFunc(interp, objc, objv)
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Number of arguments. The function name is
				 * the 0-th argument. */
    Tcl_Obj **objv;		/* The array of arguments. The function name
				 * is objv[0]. */
{
    Interp *iPtr = (Interp *) interp;
    char *funcName;
    Tcl_HashEntry *hPtr;
    MathFunc *mathFuncPtr;	/* Information about math function. */
    Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
    Tcl_Value funcResult;	/* Result of function call as Tcl_Value. */
    register Tcl_Obj *valuePtr;
    long i;
    double d;
    int j, k, result;

    Tcl_ResetResult(interp);

    /*
     * Look up the MathFunc record for the function.
     */

    funcName = TclGetString(objv[0]);
    hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "unknown math function \"", funcName,
		"\"", (char *) NULL);
	return TCL_ERROR;
    }
    mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
    if (mathFuncPtr->numArgs != (objc-1)) {
	Tcl_Panic("ExprCallMathFunc: expected number of args %d != actual number %d",
	        mathFuncPtr->numArgs, objc);
	return TCL_ERROR;
    }

    /*
     * Collect the arguments for the function, if there are any, into the
     * array "args". Note that args[0] will have the Tcl_Value that
     * corresponds to objv[1].
     */

    for (j = 1, k = 0;  j < objc;  j++, k++) {
	valuePtr = objv[j];

	if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * Copy the object's numeric value to the argument record,
	 * converting it if necessary. 
	 */

	if (valuePtr->typePtr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
	    if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = i;
	    } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_LongAsWide(i);
	    } else {
		args[k].type = TCL_INT;
		args[k].intValue = i;
	    }
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    Tcl_WideInt w;
	    TclGetWide(w,valuePtr);
	    if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = Tcl_WideAsDouble(w);
	    } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].intValue = Tcl_WideAsLong(w);
	    } else {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = w;
	    }
	} else {
	    d = valuePtr->internalRep.doubleValue;
	    if (mathFuncPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].intValue = (long) d;
	    } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_DoubleAsWide(d);
	    } else {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = d;
	    }
	}
    }

    /*
     * Invoke the function and copy its result back into valuePtr.
     */

    result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
	    &funcResult);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Pop the objc top stack elements and decrement their ref counts.
     */

    for (k = 0; k < objc; k++) {
	valuePtr = objv[k];
	TclDecrRefCount(valuePtr);
    }
    
    /*
     * Push the call's object result.
     */
    
    if (funcResult.type == TCL_INT) {
	objv[0] = Tcl_NewLongObj(funcResult.intValue);
    } else if (funcResult.type == TCL_WIDE_INT) {
	objv[0] = Tcl_NewWideIntObj(funcResult.wideValue);
    } else {
	d = funcResult.doubleValue;
	if (IS_NAN(d) || IS_INF(d)) {
	    TclExprFloatError(interp, d);
	    return TCL_ERROR;
	}
	objv[0] = Tcl_NewDoubleObj(d);
    }
    Tcl_IncrRefCount(objv[0]);
    
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExprFloatError --
 *
 *	This procedure is called when an error occurs during a
 *	floating-point operation. It reads errno and sets
 *	interp->objResultPtr accordingly.
 *
 * Results:
 *	interp->objResultPtr is set to hold an error message.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclExprFloatError(interp, value)
    Tcl_Interp *interp;		/* Where to store error message. */
    double value;		/* Value returned after error;  used to
				 * distinguish underflows from overflows. */
{
    CONST char *s;

    if ((errno == EDOM) || IS_NAN(value)) {
	s = "domain error: argument not in valid range";
	Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
    } else if ((errno == ERANGE) || IS_INF(value)) {
	if (value == 0.0) {
	    s = "floating-point value too small to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
	}
    } else {
	char msg[64 + TCL_INTEGER_SPACE];
	
	sprintf(msg, "unknown floating-point error, errno = %d", errno);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);


    }
}

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLog2 --
 *
 *	Procedure used while collecting compilation statistics to determine
 *	the log base 2 of an integer.
 *
 * Results:
 *	Returns the log base 2 of the operand. If the argument is less
 *	than or equal to zero, a zero is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclLog2(value)
    register int value;		/* The integer for which to compute the
				 * log base 2. */
{
    register int n = value;
    register int result = 0;

    while (n > 1) {
	n = n >> 1;
	result++;







|
|














|















|
|
|
|
|
<
|
|
|















|
|













|
|
|
|
<







|














|
|
|













|
|


|




<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|
|
<













|




|



|










|
|
|
<
|
>
>













|
|









|
|







6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616

6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653

6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700


6701














































































































































































































































































































































































































































































































































































































































































































































































6702
6703
6704
6705
6706
6707
6708

6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744

6745
6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	if (codeOffset > pcOffset) {	  /* best cmd already found */
	    break;
	} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
	    int dist = (pcOffset - codeOffset);
	    if (dist <= bestDist) {
		bestDist = dist;
		bestSrcOffset = srcOffset;
		bestSrcLength = srcLen;
	    }
	}
    }

    if (bestDist == INT_MAX) {
	return NULL;
    }

    if (lengthPtr != NULL) {
	*lengthPtr = bestSrcLength;
    }
    return (codePtr->source + bestSrcOffset);
}

/*
 *----------------------------------------------------------------------
 *
 * GetExceptRangeForPc --
 *
 *	Given a program counter value, return the closest enclosing
 *	ExceptionRange.
 *
 * Results:
 *	In the normal case, catchOnly is 0 (false) and this procedure returns
 *	a pointer to the most closely enclosing ExceptionRange structure
 *	regardless of whether it is a loop or catch exception range. This is
 *	appropriate when processing a TCL_BREAK or TCL_CONTINUE, which will be
 *	"handled" either by a loop exception range or a closer catch range. If

 *	catchOnly is nonzero, this procedure ignores loop exception ranges and
 *	returns a pointer to the closest catch range. If no matching
 *	ExceptionRange is found that encloses pc, a NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static ExceptionRange *
GetExceptRangeForPc(pc, catchOnly, codePtr)
    unsigned char *pc;		/* The program counter value for which to
				 * search for a closest enclosing exception
				 * range. This points to a bytecode
				 * instruction in codePtr's code. */
    int catchOnly;		/* If 0, consider either loop or catch
				 * ExceptionRanges in search. If nonzero
				 * consider only catch ranges (and ignore any
				 * closer loop ranges). */
    ByteCode* codePtr;		/* Points to the ByteCode in which to search
				 * for the enclosing ExceptionRange. */
{
    ExceptionRange *rangeArrayPtr;
    int numRanges = codePtr->numExceptRanges;
    register ExceptionRange *rangePtr;
    int pcOffset = (pc - codePtr->codeStart);
    register int start;

    if (numRanges == 0) {
	return NULL;
    }

    /*
     * This exploits peculiarities of our compiler: nested ranges are always
     * *after* their containing ranges, so that by scanning backwards we are
     * sure that the first matching range is indeed the deepest.

     */

    rangeArrayPtr = codePtr->exceptArrayPtr;
    rangePtr = rangeArrayPtr + numRanges;
    while (--rangePtr >= rangeArrayPtr) {
	start = rangePtr->codeOffset;
	if ((start <= pcOffset) &&
		(pcOffset < (start + rangePtr->numCodeBytes))) {
	    if ((!catchOnly)
		    || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
		return rangePtr;
	    }
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * GetOpcodeName --
 *
 *	This procedure is called by the TRACE and TRACE_WITH_OBJ macros used
 *	in TclExecuteByteCode when debugging. It returns the name of the
 *	bytecode instruction at a specified instruction pc.
 *
 * Results:
 *	A character string for the instruction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_COMPILE_DEBUG
static char *
GetOpcodeName(pc)
    unsigned char *pc;		/* Points to the instruction whose name should
				 * be returned. */
{
    unsigned char opCode = *pc;

    return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */


















































































































































































































































































































































































































































































































































































































































































































































































/*
 *----------------------------------------------------------------------
 *
 * TclExprFloatError --
 *
 *	This procedure is called when an error occurs during a floating-point
 *	operation. It reads errno and sets interp->objResultPtr accordingly.

 *
 * Results:
 *	interp->objResultPtr is set to hold an error message.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclExprFloatError(interp, value)
    Tcl_Interp *interp;		/* Where to store error message. */
    double value;		/* Value returned after error; used to
				 * distinguish underflows from overflows. */
{
    CONST char *s;

    if ((errno == EDOM) || TclIsNaN(value)) {
	s = "domain error: argument not in valid range";
	Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
    } else if ((errno == ERANGE) || TclIsInfinite(value)) {
	if (value == 0.0) {
	    s = "floating-point value too small to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
	}
    } else {
	Tcl_Obj *objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr,
		"unknown floating-point error, errno = %d", errno);

	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", 
		Tcl_GetString(objPtr), (char *) NULL);
	Tcl_SetObjResult(interp, objPtr);
    }
}

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLog2 --
 *
 *	Procedure used while collecting compilation statistics to determine
 *	the log base 2 of an integer.
 *
 * Results:
 *	Returns the log base 2 of the operand. If the argument is less than or
 *	equal to zero, a zero is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclLog2(value)
    register int value;		/* The integer for which to compute the log
				 * base 2. */
{
    register int n = value;
    register int result = 0;

    while (n > 1) {
	n = n >> 1;
	result++;
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
    int numSharedMultX, numSharedOnce;
    int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
    char *litTableStats;
    LiteralEntry *entryPtr;

    numInstructions = 0.0;
    for (i = 0;  i < 256;  i++) {
        if (statsPtr->instructionCount[i] != 0) {
            numInstructions += statsPtr->instructionCount[i];
        }
    }

    totalLiteralBytes = sizeof(LiteralTable)
	    + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
	    + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
	    + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
	    + statsPtr->totalLitStringBytes;
    totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;

    numCurrentByteCodes =
	    statsPtr->numCompilations - statsPtr->numByteCodesFreed;
    currentHeaderBytes = numCurrentByteCodes
	    * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
    literalMgmtBytes = sizeof(LiteralTable)
	    + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
	    + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
    currentLiteralBytes = literalMgmtBytes
	    + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
	    + statsPtr->currentLitStringBytes;
    currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
    
    /*
     * Summary statistics, total and current source and ByteCode sizes.
     */

    fprintf(stdout, "\n----------------------------------------------------------------\n");
    fprintf(stdout,
	    "Compilation and execution statistics for interpreter 0x%x\n",
	    (unsigned int) iPtr);

    fprintf(stdout, "\nNumber ByteCodes executed	%ld\n",
	    statsPtr->numExecutions);
    fprintf(stdout, "Number ByteCodes compiled	%ld\n",
	    statsPtr->numCompilations);
    fprintf(stdout, "  Mean executions/compile	%.1f\n",
	    ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
    
    fprintf(stdout, "\nInstructions executed		%.0f\n",
	    numInstructions);
    fprintf(stdout, "  Mean inst/compile		%.0f\n",
	    numInstructions / statsPtr->numCompilations);
    fprintf(stdout, "  Mean inst/execution		%.0f\n",
	    numInstructions / statsPtr->numExecutions);








|
|
|




















|















|







6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
    int numSharedMultX, numSharedOnce;
    int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
    char *litTableStats;
    LiteralEntry *entryPtr;

    numInstructions = 0.0;
    for (i = 0;  i < 256;  i++) {
	if (statsPtr->instructionCount[i] != 0) {
	    numInstructions += statsPtr->instructionCount[i];
	}
    }

    totalLiteralBytes = sizeof(LiteralTable)
	    + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
	    + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
	    + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
	    + statsPtr->totalLitStringBytes;
    totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;

    numCurrentByteCodes =
	    statsPtr->numCompilations - statsPtr->numByteCodesFreed;
    currentHeaderBytes = numCurrentByteCodes
	    * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
    literalMgmtBytes = sizeof(LiteralTable)
	    + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
	    + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
    currentLiteralBytes = literalMgmtBytes
	    + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
	    + statsPtr->currentLitStringBytes;
    currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;

    /*
     * Summary statistics, total and current source and ByteCode sizes.
     */

    fprintf(stdout, "\n----------------------------------------------------------------\n");
    fprintf(stdout,
	    "Compilation and execution statistics for interpreter 0x%x\n",
	    (unsigned int) iPtr);

    fprintf(stdout, "\nNumber ByteCodes executed	%ld\n",
	    statsPtr->numExecutions);
    fprintf(stdout, "Number ByteCodes compiled	%ld\n",
	    statsPtr->numCompilations);
    fprintf(stdout, "  Mean executions/compile	%.1f\n",
	    ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));

    fprintf(stdout, "\nInstructions executed		%.0f\n",
	    numInstructions);
    fprintf(stdout, "  Mean inst/compile		%.0f\n",
	    numInstructions / statsPtr->numCompilations);
    fprintf(stdout, "  Mean inst/execution		%.0f\n",
	    numInstructions / statsPtr->numExecutions);

6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
    fprintf(stdout, "  Code + source bytes		%.6g (%0.1f mean code/src)\n",
	    (currentCodeBytes + statsPtr->currentSrcBytes),
	    (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);

    /*
     * Tcl_IsShared statistics check
     *
     * This gives the refcount of each obj as Tcl_IsShared was called
     * for it.  Shared objects must be duplicated before they can be
     * modified.
     */

    numSharedMultX = 0;
    fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
    fprintf(stdout, "  Object had refcount <=1 (not shared)	%ld\n",
	    tclObjsShared[1]);
    for (i = 2;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {







|
|
<







6912
6913
6914
6915
6916
6917
6918
6919
6920

6921
6922
6923
6924
6925
6926
6927
    fprintf(stdout, "  Code + source bytes		%.6g (%0.1f mean code/src)\n",
	    (currentCodeBytes + statsPtr->currentSrcBytes),
	    (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);

    /*
     * Tcl_IsShared statistics check
     *
     * This gives the refcount of each obj as Tcl_IsShared was called for it.
     * Shared objects must be duplicated before they can be modified.

     */

    numSharedMultX = 0;
    fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
    fprintf(stdout, "  Object had refcount <=1 (not shared)	%ld\n",
	    tclObjsShared[1]);
    for (i = 2;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
    numSharedOnce  = 0;
    objBytesIfUnshared  = 0.0;
    strBytesIfUnshared  = 0.0;
    strBytesSharedMultX = 0.0;
    strBytesSharedOnce  = 0.0;
    for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
	for (entryPtr = globalTablePtr->buckets[i];  entryPtr != NULL;
	        entryPtr = entryPtr->nextPtr) {
	    if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
		numByteCodeLits++;
	    }
	    (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
	    refCountSum += entryPtr->refCount;
	    objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
	    strBytesIfUnshared += (entryPtr->refCount * (length+1));







|







6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
    numSharedOnce  = 0;
    objBytesIfUnshared  = 0.0;
    strBytesIfUnshared  = 0.0;
    strBytesSharedMultX = 0.0;
    strBytesSharedOnce  = 0.0;
    for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
	for (entryPtr = globalTablePtr->buckets[i];  entryPtr != NULL;
		entryPtr = entryPtr->nextPtr) {
	    if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
		numByteCodeLits++;
	    }
	    (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
	    refCountSum += entryPtr->refCount;
	    objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
	    strBytesIfUnshared += (entryPtr->refCount * (length+1));
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
	    sizeof(LiteralTable),
	    iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
	    iPtr->literalTable.numEntries * sizeof(LiteralEntry));

    /*
     * Breakdown of current ByteCode space requirements.
     */
    
    fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
    fprintf(stdout, "                         Bytes      Pct of    Avg per\n");
    fprintf(stdout, "                                     total    ByteCode\n");
    fprintf(stdout, "Total             %12.6g     100.00%%   %8.1f\n",
	    statsPtr->currentByteCodeBytes,
	    statsPtr->currentByteCodeBytes / numCurrentByteCodes);
    fprintf(stdout, "Header            %12.6g   %8.1f%%   %8.1f\n",







|







7014
7015
7016
7017
7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028
	    sizeof(LiteralTable),
	    iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
	    iPtr->literalTable.numEntries * sizeof(LiteralEntry));

    /*
     * Breakdown of current ByteCode space requirements.
     */

    fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
    fprintf(stdout, "                         Bytes      Pct of    Avg per\n");
    fprintf(stdout, "                                     total    ByteCode\n");
    fprintf(stdout, "Total             %12.6g     100.00%%   %8.1f\n",
	    statsPtr->currentByteCodeBytes,
	    statsPtr->currentByteCodeBytes / numCurrentByteCodes);
    fprintf(stdout, "Header            %12.6g   %8.1f%%   %8.1f\n",
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745

6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
	    statsPtr->currentCmdMapBytes,
	    ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
	    statsPtr->currentCmdMapBytes / numCurrentByteCodes);

    /*
     * Detailed literal statistics.
     */
    
    fprintf(stdout, "\nLiteral string sizes:\n");
    fprintf(stdout, "	 Up to length		Percentage\n");
    maxSizeDecade = 0;
    for (i = 31;  i >= 0;  i--) {
        if (statsPtr->literalCount[i] > 0) {
            maxSizeDecade = i;
	    break;
        }
    }
    sum = 0;
    for (i = 0;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->literalCount[i];
        fprintf(stdout,	"	%10d		%8.0f%%\n",
		decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
    }

    litTableStats = TclLiteralStats(globalTablePtr);
    fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
            litTableStats);
    ckfree((char *) litTableStats);

    /*
     * Source and ByteCode size distributions.
     */

    fprintf(stdout, "\nSource sizes:\n");
    fprintf(stdout, "	 Up to size		Percentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
        if (statsPtr->srcCount[i] > 0) {
	    minSizeDecade = i;
	    break;
        }
    }
    for (i = 31;  i >= 0;  i--) {
        if (statsPtr->srcCount[i] > 0) {
            maxSizeDecade = i;
	    break;
        }
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->srcCount[i];
        fprintf(stdout,	"	%10d		%8.0f%%\n",
		decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
    }

    fprintf(stdout, "\nByteCode sizes:\n");
    fprintf(stdout, "	 Up to size		Percentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
        if (statsPtr->byteCodeCount[i] > 0) {
	    minSizeDecade = i;
	    break;
        }
    }
    for (i = 31;  i >= 0;  i--) {
        if (statsPtr->byteCodeCount[i] > 0) {
            maxSizeDecade = i;
	    break;
        }
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->byteCodeCount[i];
        fprintf(stdout,	"	%10d		%8.0f%%\n",
		decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
    }

    fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
    fprintf(stdout, "	       Up to ms		Percentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
        if (statsPtr->lifetimeCount[i] > 0) {
	    minSizeDecade = i;
	    break;
        }
    }
    for (i = 31;  i >= 0;  i--) {
        if (statsPtr->lifetimeCount[i] > 0) {
            maxSizeDecade = i;
	    break;
        }
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->lifetimeCount[i];
        fprintf(stdout,	"	%12.3f		%8.0f%%\n",
		decadeHigh / 1000.0,
		(sum * 100.0) / statsPtr->numByteCodesFreed);
    }

    /*
     * Instruction counts.
     */

    fprintf(stdout, "\nInstruction counts:\n");
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
        if (statsPtr->instructionCount[i]) {
            fprintf(stdout, "%20s %8ld %6.1f%%\n",
		    tclInstructionTable[i].name,
		    statsPtr->instructionCount[i],
		    (statsPtr->instructionCount[i]*100.0) / numInstructions);
        }
    }

    fprintf(stdout, "\nInstructions NEVER executed:\n");
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
        if (statsPtr->instructionCount[i] == 0) {
            fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
        }
    }

#ifdef TCL_MEM_DEBUG
    fprintf(stdout, "\nHeap Statistics:\n");
    TclDumpMemoryInfo(stdout);
#endif
    fprintf(stdout, "\n----------------------------------------------------------------\n");
    return TCL_OK;
}
#endif /* TCL_COMPILE_STATS */

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * StringForResultCode --
 *
 *	Procedure that returns a human-readable string representing a
 *	Tcl result code such as TCL_ERROR. 
 *
 * Results:
 *	If the result code is one of the standard Tcl return codes, the
 *	result is a string representing that code such as "TCL_ERROR".
 *	Otherwise, the result string is that code formatted as a
 *	sequence of decimal digit characters. Note that the resulting
 *	string must not be modified by the caller.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
StringForResultCode(result)
    int result;			/* The Tcl result code for which to
				 * generate a string. */
{
    static char buf[TCL_INTEGER_SPACE];
    
    if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
	return resultStrings[result];
    }
    TclFormatInt(buf, result);
    return buf;
}
#endif /* TCL_COMPILE_DEBUG */


/*
 *----------------------------------------------------------------------
 *
 * ExponWide --
 *
 *	Procedure to return w**w2 as wide integer
 *
 * Results:
 *	Return value is w to the power w2, unless the computation
 *	makes no sense mathematically. In that case *errExpon is
 *	set to 1.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|




|
|

|





|





|










|


|


|
|

|





|







|


|


|
|

|





|







|


|


|
|

|





|










|
|



|




|
|
|

















|
|


|
|
|
|
|









|
|


|







>









|
|
<







7049
7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230

7231
7232
7233
7234
7235
7236
7237
	    statsPtr->currentCmdMapBytes,
	    ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
	    statsPtr->currentCmdMapBytes / numCurrentByteCodes);

    /*
     * Detailed literal statistics.
     */

    fprintf(stdout, "\nLiteral string sizes:\n");
    fprintf(stdout, "	 Up to length		Percentage\n");
    maxSizeDecade = 0;
    for (i = 31;  i >= 0;  i--) {
	if (statsPtr->literalCount[i] > 0) {
	    maxSizeDecade = i;
	    break;
	}
    }
    sum = 0;
    for (i = 0;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->literalCount[i];
	fprintf(stdout, "	%10d		%8.0f%%\n",
		decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
    }

    litTableStats = TclLiteralStats(globalTablePtr);
    fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
	    litTableStats);
    ckfree((char *) litTableStats);

    /*
     * Source and ByteCode size distributions.
     */

    fprintf(stdout, "\nSource sizes:\n");
    fprintf(stdout, "	 Up to size		Percentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
	if (statsPtr->srcCount[i] > 0) {
	    minSizeDecade = i;
	    break;
	}
    }
    for (i = 31;  i >= 0;  i--) {
	if (statsPtr->srcCount[i] > 0) {
	    maxSizeDecade = i;
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->srcCount[i];
	fprintf(stdout, "	%10d		%8.0f%%\n",
		decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
    }

    fprintf(stdout, "\nByteCode sizes:\n");
    fprintf(stdout, "	 Up to size		Percentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
	if (statsPtr->byteCodeCount[i] > 0) {
	    minSizeDecade = i;
	    break;
	}
    }
    for (i = 31;  i >= 0;  i--) {
	if (statsPtr->byteCodeCount[i] > 0) {
	    maxSizeDecade = i;
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->byteCodeCount[i];
	fprintf(stdout, "	%10d		%8.0f%%\n",
		decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
    }

    fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
    fprintf(stdout, "	       Up to ms		Percentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
	if (statsPtr->lifetimeCount[i] > 0) {
	    minSizeDecade = i;
	    break;
	}
    }
    for (i = 31;  i >= 0;  i--) {
	if (statsPtr->lifetimeCount[i] > 0) {
	    maxSizeDecade = i;
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->lifetimeCount[i];
	fprintf(stdout, "	%12.3f		%8.0f%%\n",
		decadeHigh / 1000.0,
		(sum * 100.0) / statsPtr->numByteCodesFreed);
    }

    /*
     * Instruction counts.
     */

    fprintf(stdout, "\nInstruction counts:\n");
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
	if (statsPtr->instructionCount[i]) {
	    fprintf(stdout, "%20s %8ld %6.1f%%\n",
		    tclInstructionTable[i].name,
		    statsPtr->instructionCount[i],
		    (statsPtr->instructionCount[i]*100.0) / numInstructions);
	}
    }

    fprintf(stdout, "\nInstructions NEVER executed:\n");
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
	if (statsPtr->instructionCount[i] == 0) {
	    fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
	}
    }

#ifdef TCL_MEM_DEBUG
    fprintf(stdout, "\nHeap Statistics:\n");
    TclDumpMemoryInfo(stdout);
#endif
    fprintf(stdout, "\n----------------------------------------------------------------\n");
    return TCL_OK;
}
#endif /* TCL_COMPILE_STATS */

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * StringForResultCode --
 *
 *	Procedure that returns a human-readable string representing a Tcl
 *	result code such as TCL_ERROR.
 *
 * Results:
 *	If the result code is one of the standard Tcl return codes, the result
 *	is a string representing that code such as "TCL_ERROR".  Otherwise,
 *	the result string is that code formatted as a sequence of decimal
 *	digit characters. Note that the resulting string must not be modified
 *	by the caller.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
StringForResultCode(result)
    int result;			/* The Tcl result code for which to generate a
				 * string. */
{
    static char buf[TCL_INTEGER_SPACE];

    if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
	return resultStrings[result];
    }
    TclFormatInt(buf, result);
    return buf;
}
#endif /* TCL_COMPILE_DEBUG */
#if 0

/*
 *----------------------------------------------------------------------
 *
 * ExponWide --
 *
 *	Procedure to return w**w2 as wide integer
 *
 * Results:
 *	Return value is w to the power w2, unless the computation makes no
 *	sense mathematically. In that case *errExpon is set to 1.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882

	if (w2 < 0) {
	    return W0;
	} else if (w2 == 0) {
	    return Tcl_LongAsWide(1);
	}
    } else if (w == -1) {
	return (w2 & 1) ? Tcl_LongAsWide(-1) :  Tcl_LongAsWide(1);
    } else if (w == 1) {
	return Tcl_LongAsWide(1);
    } else if (w>1 && w2<0) {
	return W0;
    }

    /*
     * The general case.  
     */

    result = Tcl_LongAsWide(1);
    for (; w2>Tcl_LongAsWide(1) ; w*=w,w2/=2) {
	if (w2 & 1) {
	    result *= w;
	}
    }
    return result * w;
}

/*
 *----------------------------------------------------------------------
 *
 * ExponLong --
 *
 *      Procedure to return i**i2 as long integer
 *
 * Results:
 *      Return value is i to the power i2, unless the computation
 *      makes no sense mathematically. In that case *errExpon is
 *      set to 1.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static long
ExponLong(i, i2, errExpon)
    long i;			/* The value that must be exponentiated */
    long i2;			/* The exponent */
    int *errExpon;		/* Error code */
{
    long result;

    *errExpon = 0;

    /*
     * Check for possible errors and simple cases
     */

    if (i == 0) {
        if (i2 < 0) {
            *errExpon = 1;
            return 0L;
        } else if (i2 > 0) {
            return 0L;
        }
	/*
	 * By definition and analysis, 0**0 is 1.
	 */
	return 1L;
    } else if (i < -1) {
        if (i2 < 0) {
            return 0L;
        } else if (i2 == 0) {
	    return 1L;
        }
    } else if (i == -1) {
        return (i2&1) ? -1L : 1L;
    } else if (i == 1) {
        return 1L;
    } else if (i > 1 && i2 < 0) {
        return 0L;
    }

    /*
     * The general case
     */

    result = 1;
    for (; i2>1 ; i*=i,i2/=2) {
	if (i2 & 1) {
	    result *= i;
	}
    }
    return result * i;
}








|






|
















|


|
|
<


|



















|
|
|
|
|
|





|
|
|

|

|
|
|

|














>
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296

7297
7298
7299
7300
7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
	if (w2 < 0) {
	    return W0;
	} else if (w2 == 0) {
	    return Tcl_LongAsWide(1);
	}
    } else if (w == -1) {
	return (w2 & 1) ? Tcl_LongAsWide(-1) :  Tcl_LongAsWide(1);
    } else if ((w == 1) || (w2 == 0)) {
	return Tcl_LongAsWide(1);
    } else if (w>1 && w2<0) {
	return W0;
    }

    /*
     * The general case.
     */

    result = Tcl_LongAsWide(1);
    for (; w2>Tcl_LongAsWide(1) ; w*=w,w2/=2) {
	if (w2 & 1) {
	    result *= w;
	}
    }
    return result * w;
}

/*
 *----------------------------------------------------------------------
 *
 * ExponLong --
 *
 *	Procedure to return i**i2 as long integer
 *
 * Results:
 *	Return value is i to the power i2, unless the computation makes no
 *	sense mathematically. In that case *errExpon is set to 1.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static long
ExponLong(i, i2, errExpon)
    long i;			/* The value that must be exponentiated */
    long i2;			/* The exponent */
    int *errExpon;		/* Error code */
{
    long result;

    *errExpon = 0;

    /*
     * Check for possible errors and simple cases
     */

    if (i == 0) {
	if (i2 < 0) {
	    *errExpon = 1;
	    return 0L;
	} else if (i2 > 0) {
	    return 0L;
	}
	/*
	 * By definition and analysis, 0**0 is 1.
	 */
	return 1L;
    } else if (i < -1) {
	if (i2 < 0) {
	    return 0L;
	} else if (i2 == 0) {
	    return 1L;
	}
    } else if (i == -1) {
	return (i2&1) ? -1L : 1L;
    } else if ((i == 1) || (i2 == 0)) {
	return 1L;
    } else if (i > 1 && i2 < 0) {
	return 0L;
    }

    /*
     * The general case
     */

    result = 1;
    for (; i2>1 ; i*=i,i2/=2) {
	if (i2 & 1) {
	    result *= i;
	}
    }
    return result * i;
}
#endif

Changes to generic/tclFCmd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
/*
 * tclFCmd.c
 *
 *      This file implements the generic portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclFCmd.c,v 1.29 2004/10/19 21:54:07 dgp Exp $
 */

#include "tclInt.h"

/*
 * Declarations for local procedures defined in this file:
 */

static int		CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, 
			    int copyFlag, int force));
static Tcl_Obj *	FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr));
static int		FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int copyFlag));
static int		FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int *forcePtr));

/*
 *---------------------------------------------------------------------------
 *
 * TclFileRenameCmd
 *
 *	This procedure implements the "rename" subcommand of the "file"
 *      command.  Filename arguments need to be translated to native
 *	format before being passed to platform-specific code that
 *	implements rename functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *



|
|



|
|

|





|



|













|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
/*
 * tclFCmd.c
 *
 *	This file implements the generic portion of file manipulation
 *	subcommands of the "file" command.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclFCmd.c,v 1.29.2.3 2005/08/02 18:15:27 dgp Exp $
 */

#include "tclInt.h"

/*
 * Declarations for local functions defined in this file:
 */

static int		CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
			    int copyFlag, int force));
static Tcl_Obj *	FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr));
static int		FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int copyFlag));
static int		FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int *forcePtr));

/*
 *---------------------------------------------------------------------------
 *
 * TclFileRenameCmd
 *
 *	This function implements the "rename" subcommand of the "file"
 *	command. Filename arguments need to be translated to native format
 *	before being passed to platform-specific code that implements rename
 *	functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileCopyCmd
 *
 *	This procedure implements the "copy" subcommand of the "file"
 *	command.  Filename arguments need to be translated to native
 *	format before being passed to platform-specific code that
 *	implements copy functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|
|
<







57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileCopyCmd
 *
 *	This function implements the "copy" subcommand of the "file" command.
 *	Filename arguments need to be translated to native format before being
 *	passed to platform-specific code that implements copy functionality.

 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
}

/*
 *---------------------------------------------------------------------------
 *
 * FileCopyRename --
 *
 *	Performs the work of TclFileRenameCmd and TclFileCopyCmd.
 *	See comments for those procedures.
 *
 * Results:
 *	See above.
 *
 * Side effects:
 *	See above.
 *
 *---------------------------------------------------------------------------
 */

static int
FileCopyRename(interp, objc, objv, copyFlag)
    Tcl_Interp *interp;		/* Used for error reporting. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
    int copyFlag;		/* If non-zero, copy source(s).  Otherwise,
				 * rename them. */
{
    int i, result, force;
    Tcl_StatBuf statBuf; 
    Tcl_Obj *target;

    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", 
		Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), 
		" ?options? source ?source ...? target\"", 
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * If target doesn't exist or isn't a directory, try the copy/rename.
     * More than 2 arguments is only valid if the target is an existing







|
|















|



|








|
|
|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
}

/*
 *---------------------------------------------------------------------------
 *
 * FileCopyRename --
 *
 *	Performs the work of TclFileRenameCmd and TclFileCopyCmd. See
 *	comments for those functions.
 *
 * Results:
 *	See above.
 *
 * Side effects:
 *	See above.
 *
 *---------------------------------------------------------------------------
 */

static int
FileCopyRename(interp, objc, objv, copyFlag)
    Tcl_Interp *interp;		/* Used for error reporting. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
    int copyFlag;		/* If non-zero, copy source(s). Otherwise,
				 * rename them. */
{
    int i, result, force;
    Tcl_StatBuf statBuf;
    Tcl_Obj *target;

    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		TclGetString(objv[0]), " ", TclGetString(objv[1]),
		" ?options? source ?source ...? target\"",
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * If target doesn't exist or isn't a directory, try the copy/rename.
     * More than 2 arguments is only valid if the target is an existing
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

    if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
	if ((objc - i) > 2) {
	    errno = ENOTDIR;
	    Tcl_PosixError(interp);
	    Tcl_AppendResult(interp, "error ",
		    ((copyFlag) ? "copying" : "renaming"), ": target \"",
		    Tcl_GetString(target), "\" is not a directory", 
		    (char *) NULL);
	    result = TCL_ERROR;
	} else {
	    /*
	     * Even though already have target == translated(objv[i+1]),
	     * pass the original argument down, so if there's an error, the
	     * error message will reflect the original arguments.
	     */

	    result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
		    force);
	}
	return result;
    }
    
    /*
     * Move each source file into target directory.  Extract the basename
     * from each source, and append it to the end of the target path.
     */

    for ( ; i < objc - 1; i++) {
	Tcl_Obj *jargv[2];
	Tcl_Obj *source, *newFileName;
	Tcl_Obj *temp;
	
	source = FileBasename(interp, objv[i]);
	if (source == NULL) {
	    result = TCL_ERROR;
	    break;
	}
	jargv[0] = objv[objc - 1];
	jargv[1] = source;







|




|
|
|







|

|
|


|



|







146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

    if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
	if ((objc - i) > 2) {
	    errno = ENOTDIR;
	    Tcl_PosixError(interp);
	    Tcl_AppendResult(interp, "error ",
		    ((copyFlag) ? "copying" : "renaming"), ": target \"",
		    TclGetString(target), "\" is not a directory",
		    (char *) NULL);
	    result = TCL_ERROR;
	} else {
	    /*
	     * Even though already have target == translated(objv[i+1]), pass
	     * the original argument down, so if there's an error, the error
	     * message will reflect the original arguments.
	     */

	    result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
		    force);
	}
	return result;
    }

    /*
     * Move each source file into target directory. Extract the basename from
     * each source, and append it to the end of the target path.
     */

    for ( ; i<objc-1 ; i++) {
	Tcl_Obj *jargv[2];
	Tcl_Obj *source, *newFileName;
	Tcl_Obj *temp;

	source = FileBasename(interp, objv[i]);
	if (source == NULL) {
	    result = TCL_ERROR;
	    break;
	}
	jargv[0] = objv[objc - 1];
	jargv[1] = source;
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileMakeDirsCmd
 *
 *	This procedure implements the "mkdir" subcommand of the "file"
 *      command.  Filename arguments need to be translated to native
 *	format before being passed to platform-specific code that
 *	implements mkdir functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|
|
<







200
201
202
203
204
205
206
207
208
209

210
211
212
213
214
215
216
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileMakeDirsCmd
 *
 *	This function implements the "mkdir" subcommand of the "file" command.
 *	Filename arguments need to be translated to native format before being
 *	passed to platform-specific code that implements mkdir functionality.

 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
245
246
247
248
249
250
251

252
253
254
255
256
257
258
259
260
261
262
263
264







265
















266
267
268







269


270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
	    errno = ENOENT;
	    errfile = objv[i];
	    break;
	}
	for (j = 0; j < pobjc; j++) {
	    target = Tcl_FSJoinPath(split, j + 1);
	    Tcl_IncrRefCount(target);

	    /*
	     * Call Tcl_FSStat() so that if target is a symlink that
	     * points to a directory we will create subdirectories in
	     * that directory.
	     */

	    if (Tcl_FSStat(target, &statBuf) == 0) {
		if (!S_ISDIR(statBuf.st_mode)) {
		    errno = EEXIST;
		    errfile = target;
		    goto done;
		}
	    } else if ((errno != ENOENT)







		    || (Tcl_FSCreateDirectory(target) != TCL_OK)) {
















		errfile = target;
		goto done;
	    }







	    /* Forget about this sub-path */


	    Tcl_DecrRefCount(target);
	    target = NULL;
	}
	Tcl_DecrRefCount(split);
	split = NULL;
    }
	
    done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, "can't create directory \"",
		Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), 
		(char *) NULL);
	result = TCL_ERROR;
    }
    if (split != NULL) {
	Tcl_DecrRefCount(split);
    }
    if (target != NULL) {
	Tcl_DecrRefCount(target);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileDeleteCmd
 *
 *	This procedure implements the "delete" subcommand of the "file"
 *      command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclFileDeleteCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting */
    int objc;			/* Number of arguments */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
{
    int i, force, result;
    Tcl_Obj *errfile;
    Tcl_Obj *errorBuffer = NULL;
    
    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 1) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", 
		Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), 
		" ?options? file ?file ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    errfile = NULL;
    result = TCL_OK;








>

|
|
<








|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
>
>
>
>
>
>
>
|
>
>






|
|


|

















|
|



















|






|
|







243
244
245
246
247
248
249
250
251
252
253

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
	    errno = ENOENT;
	    errfile = objv[i];
	    break;
	}
	for (j = 0; j < pobjc; j++) {
	    target = Tcl_FSJoinPath(split, j + 1);
	    Tcl_IncrRefCount(target);

	    /*
	     * Call Tcl_FSStat() so that if target is a symlink that points to
	     * a directory we will create subdirectories in that directory.

	     */

	    if (Tcl_FSStat(target, &statBuf) == 0) {
		if (!S_ISDIR(statBuf.st_mode)) {
		    errno = EEXIST;
		    errfile = target;
		    goto done;
		}
	    } else if (errno != ENOENT) {
		/*
		 * If Tcl_FSStat() failed and the error is anything other than
		 * non-existence of the target, throw the error.
		 */

		errfile = target;
		goto done;
	    } else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
		/*
		 * Create might have failed because of being in a race
		 * condition with another process trying to create the same
		 * subdirectory.
		 */

		if (errno == EEXIST) {
		    if ((Tcl_FSStat(target, &statBuf) == 0)
			    && S_ISDIR(statBuf.st_mode)) {
			/*
			 * It is a directory that wasn't there before, so keep
			 * going without error.
			 */

			Tcl_ResetResult(interp);
		    } else {
			errfile = target;
			goto done;
		    }
		} else {
		    errfile = target;
		    goto done;
		}
	    }

	    /*
	     * Forget about this sub-path.
	     */

	    Tcl_DecrRefCount(target);
	    target = NULL;
	}
	Tcl_DecrRefCount(split);
	split = NULL;
    }

  done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, "can't create directory \"",
		TclGetString(errfile), "\": ", Tcl_PosixError(interp),
		(char *) NULL);
	result = TCL_ERROR;
    }
    if (split != NULL) {
	Tcl_DecrRefCount(split);
    }
    if (target != NULL) {
	Tcl_DecrRefCount(target);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileDeleteCmd
 *
 *	This function implements the "delete" subcommand of the "file"
 *	command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclFileDeleteCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting */
    int objc;			/* Number of arguments */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
{
    int i, force, result;
    Tcl_Obj *errfile;
    Tcl_Obj *errorBuffer = NULL;

    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 1) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		TclGetString(objv[0]), " ", TclGetString(objv[1]),
		" ?options? file ?file ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    errfile = NULL;
    result = TCL_OK;

343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361

362
363
364
365
366
367
368
369
370
371
372
373
374
375
376


377


378
379
380
381
382
383
384
385
386
387

388
389
390
391
392

393
394
395
396
397
398
399
400
401

402
403
404
405
406
407
408
409

410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537

538

539

540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571

572
573
574
575
576
577
578
579
580
581

582
583
584
585
586
587
588
589
590
591

592

593


594
595
596
597
598
599
600

601
602
603
604
605

606
607
608
609

610
611

612
613
614
615
616
617
618
619
620
621


622


623

624


625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644

645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666

667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688

689

690
691
692
693
694
695
696

697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922

923
924
925
926

927
928
929
930
931
932
933
934
935
936
937
938
939


940


941


942


943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966

967


968
969

970
971

972

973
974
975
976
977

978

979


980
981
982

983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042

1043


1044

1045
1046
1047
1048

1049
1050
1051
1052
1053
1054









	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
	    /*
	     * Trying to delete a file that does not exist is not
	     * considered an error, just a no-op
	     */

	    if (errno != ENOENT) {
		result = TCL_ERROR;
	    }
	} else if (S_ISDIR(statBuf.st_mode)) {
	    /* 
	     * We own a reference count on errorBuffer, if it was set
	     * as a result of this call. 
	     */

	    result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
	    if (result != TCL_OK) {
		if ((force == 0) && (errno == EEXIST)) {
		    Tcl_AppendResult(interp, "error deleting \"", 
			    Tcl_GetString(objv[i]),
			    "\": directory not empty", (char *) NULL);
		    Tcl_PosixError(interp);
		    goto done;
		}

		/* 
		 * If possible, use the untranslated name for the file.
		 */
		 
		errfile = errorBuffer;


		/* FS supposed to check between translated objv and errfile */


		if (Tcl_FSEqualPaths(objv[i], errfile)) {
		    errfile = objv[i];
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(objv[i]);
	}
	
	if (result != TCL_OK) {
	    result = TCL_ERROR;

	    /* 
	     * It is important that we break on error, otherwise we
	     * might end up owning reference counts on numerous
	     * errorBuffers.
	     */

	    break;
	}
    }
    if (result != TCL_OK) {
	if (errfile == NULL) {
	    /* 
	     * We try to accomodate poor error results from our 
	     * Tcl_FS calls 
	     */

	    Tcl_AppendResult(interp, "error deleting unknown file: ", 
		    Tcl_PosixError(interp), (char *) NULL);
	} else {
	    Tcl_AppendResult(interp, "error deleting \"", 
		    Tcl_GetString(errfile), "\": ", 
		    Tcl_PosixError(interp), (char *) NULL);
	}
    } 

    done:
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * CopyRenameOneFile
 *
 *	Copies or renames specified source file or directory hierarchy
 *	to the specified target.  
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Target is overwritten if the force flag is set.  Attempting to
 *	copy/rename a file onto a directory or a directory onto a file
 *	will always result in an error.  
 *
 *----------------------------------------------------------------------
 */

static int
CopyRenameOneFile(interp, source, target, copyFlag, force) 
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *source;		/* Pathname of file to copy.  May need to
				 * be translated. */
    Tcl_Obj *target;		/* Pathname of file to create/overwrite.
				 * May need to be translated. */
    int copyFlag;		/* If non-zero, copy files.  Otherwise,
				 * rename them. */
    int force;			/* If non-zero, overwrite target file if it
				 * exists.  Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    /* If source is a link, then this is the real file/directory */
    Tcl_Obj *actualSource = NULL;
    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }
    
    errfile = NULL;
    errorBuffer = NULL;
    result = TCL_ERROR;
    
    /*
     * We want to copy/rename links and not the files they point to, so we
     * use lstat(). If target is a link, we also want to replace the 
     * link and not the file it points to, so we also use lstat() on the
     * target.
     */

    if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
	errfile = source;
	goto done;
    }
    if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
	if (errno != ENOENT) {
	    errfile = target;
	    goto done;
	}
    } else {
	if (force == 0) {
	    errno = EEXIST;
	    errfile = target;
	    goto done;
	}

        /* 
         * Prevent copying or renaming a file onto itself.  Under Windows, 
         * stat always returns 0 for st_ino.  However, the Windows-specific 
         * code knows how to deal with copying or renaming a file on top of
         * itself.  It might be a good idea to write a stat that worked.
         */
     
        if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
            if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
            	    (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
            	result = TCL_OK;
            	goto done;
            }
        }

	/*
	 * Prevent copying/renaming a file onto a directory and
	 * vice-versa.  This is a policy decision based on the fact that
	 * existing implementations of copy and rename on all platforms
	 * also prevent this.
	 */

	if (S_ISDIR(sourceStatBuf.st_mode)
                && !S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite file \"", 
		    Tcl_GetString(target), "\" with directory \"", 
		    Tcl_GetString(source), "\"", (char *) NULL);
	    goto done;
	}
	if (!S_ISDIR(sourceStatBuf.st_mode)
	        && S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite directory \"", 
		    Tcl_GetString(target), "\" with file \"", 
		    Tcl_GetString(source), "\"", (char *) NULL);
	    goto done;
	}
	
	/* 
	 * The destination exists, but appears to be ok to over-write,
	 * and -force is given.  We now try to adjust permissions to
	 * ensure the operation succeeds.  If we can't adjust
	 * permissions, we'll let the actual copy/rename return
	 * an error later.
	 */
#if !defined(__WIN32__)
	{
	Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1);

	Tcl_IncrRefCount(perm);

	Tcl_FSFileAttrsSet(NULL, 2, target, perm);

	Tcl_DecrRefCount(perm);
	}
#endif
    }

    if (copyFlag == 0) {
	result = Tcl_FSRenameFile(source, target);
	if (result == TCL_OK) {
	    goto done;
	}
	    
	if (errno == EINVAL) {
	    Tcl_AppendResult(interp, "error renaming \"", 
		    Tcl_GetString(source), "\" to \"",
		    Tcl_GetString(target), "\": trying to rename a volume or ",
		    "move a directory into itself", (char *) NULL);
	    goto done;
	} else if (errno != EXDEV) {
	    errfile = target;
	    goto done;
	}
	
	/*
	 * The rename failed because the move was across file systems.
	 * Fall through to copy file and then remove original.  Note that
	 * the low-level Tcl_FSRenameFileProc in the filesystem is allowed 
	 * to implement cross-filesystem moves itself, if it desires.
	 */
    }

    actualSource = source;
    Tcl_IncrRefCount(actualSource);

    /* 
     * Activate the following block to copy files instead of links.
     * However Tcl's semantics currently say we should copy links, so
     * any such change should be the subject of careful study on 
     * the consequences.
     * 
     * Perhaps there could be an optional flag to 'file copy' to
     * dictate which approach to use, with the default being _not_
     * to have this block active.
     */

#if 0
#ifdef S_ISLNK
    if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
	/* 
	 * We want to copy files not links.  Therefore we must follow the
	 * link.  There are two purposes to this 'stat' call here.  First
	 * we want to know if the linked-file/dir actually exists, and
	 * second, in the block of code which follows, some 20 lines
	 * down, we want to check if the thing is a file or directory.
	 */

	if (Tcl_FSStat(source, &sourceStatBuf) != 0) {

	    /* Actual file doesn't exist */


	    Tcl_AppendResult(interp, 
		    "error copying \"", Tcl_GetString(source), 
		    "\": the target of this link doesn't exist",
		    (char *) NULL);
	    goto done;
	} else {
	    int counter = 0;

	    while (1) {
		Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
		if (path == NULL) {
		    break;
		}

		/* 
		 * Now we want to check if this is a relative path,
		 * and if so, to make it absolute
		 */

		if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
		    Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);

		    if (abs == NULL) {
			break;
		    }
		    Tcl_IncrRefCount(abs);
		    Tcl_DecrRefCount(path);
		    path = abs;
		}
		Tcl_DecrRefCount(actualSource);
		actualSource = path;
		counter++;


		/* Arbitrary limit of 20 links to follow */


		if (counter > 20) {

		    /* Too many links */


		    Tcl_SetErrno(EMLINK);
		    errfile = source;
		    goto done;
		}
	    }
	    /* Now 'actualSource' is the correct file */
	}
    }
#endif
#endif

    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
	if (result != TCL_OK) {
	    if (errno == EXDEV) {
		/* 
		 * The copy failed because we're trying to do a
		 * cross-filesystem copy.  We do this through our Tcl
		 * library.
		 */

		Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
		Tcl_IncrRefCount(copyCommand);
		Tcl_ListObjAppendElement(interp, copyCommand, 
			Tcl_NewStringObj("::tcl::CopyDirectory",-1));
		if (copyFlag) {
		    Tcl_ListObjAppendElement(interp, copyCommand, 
					     Tcl_NewStringObj("copying",-1));
		} else {
		    Tcl_ListObjAppendElement(interp, copyCommand, 
					     Tcl_NewStringObj("renaming",-1));
		}
		Tcl_ListObjAppendElement(interp, copyCommand, source);
		Tcl_ListObjAppendElement(interp, copyCommand, target);
		result = Tcl_EvalObjEx(interp, copyCommand, 
				       TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
		Tcl_DecrRefCount(copyCommand);
		if (result != TCL_OK) {
		    /* 
		     * There was an error in the Tcl-level copy.
		     * We will pass on the Tcl error message and
		     * can ensure this by setting errfile to NULL
		     */

		    errfile = NULL;
		}
	    } else {
		errfile = errorBuffer;
		if (Tcl_FSEqualPaths(errfile, source)) {
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(actualSource, target);
	if ((result != TCL_OK) && (errno == EXDEV)) {
	    result = TclCrossFilesystemCopy(interp, source, target);
	}
	if (result != TCL_OK) {
	    /* 
	     * We could examine 'errno' to double-check if the problem
	     * was with the target, but we checked the source above,
	     * so it should be quite clear 
	     */

	    errfile = target;

	    /* 
	     * We now need to reset the result, because the above call,
	     * if it failed, may have put an error message in place.
	     * (Ideally we would prefer not to pass an interpreter in
	     * above, but the channel IO code used by
	     * TclCrossFilesystemCopy currently requires one)
	     */

	    Tcl_ResetResult(interp);
	}
    }
    if ((copyFlag == 0) && (result == TCL_OK)) {
	if (S_ISDIR(sourceStatBuf.st_mode)) {
	    result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
	    if (result != TCL_OK) {
		if (Tcl_FSEqualPaths(errfile, source) == 0) {
		    errfile = source;
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(source);
	    if (result != TCL_OK) {
		errfile = source;
	    }
	}
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "can't unlink \"", 
		Tcl_GetString(errfile), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	    errfile = NULL;
	}
    }
    
    done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, 
		((copyFlag) ? "error copying \"" : "error renaming \""),
		 Tcl_GetString(source), (char *) NULL);
	if (errfile != source) {
	    Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), 
			     (char *) NULL);
	    if (errfile != target) {
		Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), 
				 (char *) NULL);
	    }
	}
	Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
		(char *) NULL);
    }
    if (errorBuffer != NULL) {
        Tcl_DecrRefCount(errorBuffer);
    }
    if (actualSource != NULL) {
	Tcl_DecrRefCount(actualSource);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * FileForceOption --
 *
 *	Helps parse command line options for file commands that take
 *	the "-force" and "--" options.
 *
 * Results:
 *	The return value is how many arguments from argv were consumed
 *	by this function, or -1 if there was an error parsing the
 *	options.  If an error occurred, an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
FileForceOption(interp, objc, objv, forcePtr)
    Tcl_Interp *interp;		/* Interp, for error return. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings.  First command line
				 * option, if it exists, begins at 0. */
    int *forcePtr;		/* If the "-force" was specified, *forcePtr
				 * is filled with 1, otherwise with 0. */
{
    int force, i;
    
    force = 0;
    for (i = 0; i < objc; i++) {
	if (Tcl_GetString(objv[i])[0] != '-') {
	    break;
	}
	if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
	    force = 1;
	} else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
	    i++;
	    break;
	} else {
	    Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), 
		    "\": should be -force or --", (char *)NULL);
	    return -1;
	}
    }
    *forcePtr = force;
    return i;
}
/*
 *---------------------------------------------------------------------------
 *
 * FileBasename --
 *
 *	Given a path in either tcl format (with / separators), or in the
 *	platform-specific format for the current platform, return all the
 *	characters in the path after the last directory separator.  But,
 *	if path is the root directory, returns no characters.
 *
 * Results:
 *	Returns the string object that represents the basename.  If there 
 *	is an error, an error message is left in interp, and NULL is 
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
FileBasename(interp, pathPtr)
    Tcl_Interp *interp;		/* Interp, for error return. */
    Tcl_Obj *pathPtr;		/* Path whose basename to extract. */
{
    int objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;
    
    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);
    
    if (objc != 0) {
	if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
	    Tcl_DecrRefCount(splitPtr);
	    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
	    Tcl_IncrRefCount(splitPtr);
	}

	/*
	 * Return the last component, unless it is the only component, and it
	 * is the root of an absolute path.
	 */

	if (objc > 0) {
	    Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
	    if ((objc == 1) &&
	      (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
		resultPtr = NULL;
	    }
	}
    }
    if (resultPtr == NULL) {
	resultPtr = Tcl_NewObj();
    }
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(splitPtr);
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileAttrsCmd --
 *
 *      Sets or gets the platform-specific attributes of a file.  The
 *      objc-objv points to the file name with the rest of the command
 *      line following.  This routine uses platform-specific tables of
 *      option strings and callbacks.  The callback to get the
 *      attributes take three parameters:
 *	    Tcl_Interp *interp;	    The interp to report errors with.
 *				    Since this is an object-based API,
 *				    the object form of the result should 
 *				    be used.
 *	    CONST char *fileName;   This is extracted using
 *				    Tcl_TranslateFileName.
 *	    TclObj **attrObjPtrPtr; A new object to hold the attribute
 *				    is allocated and put here.
 *	The first two parameters of the callback used to write out the
 *	attributes are the same. The third parameter is:
 *	    CONST *attrObjPtr;	    A pointer to the object that has
 *				    the new attribute.
 *	They both return standard TCL errors; if the routine to get
 *	an attribute fails, no object is allocated and *attrObjPtrPtr
 *	is unchanged.
 *
 * Results:
 *      Standard TCL error.
 *
 * Side effects:
 *      May set file attributes for the file name.
 *      
 *----------------------------------------------------------------------
 */

int
TclFileAttrsCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int objc;			/* Number of command line arguments. */
    Tcl_Obj *CONST objv[];	/* The command line objects. */
{
    int result;
    CONST char ** attributeStrings;
    Tcl_Obj* objStrings = NULL;
    int numObjStrings = -1;
    Tcl_Obj *filePtr;
    
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv,
		"name ?option? ?value? ?option value ...?");
	return TCL_ERROR;
    }

    filePtr = objv[2];
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
    	return TCL_ERROR;
    }
    
    objc -= 3;
    objv += 3;
    result = TCL_ERROR;
    Tcl_SetErrno(0);

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;

	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/* 
		 * There was an error, probably that the filePtr is
		 * not accepted by any filesystem
		 */
		Tcl_AppendResult(interp, "could not read \"",
			Tcl_GetString(filePtr), "\": ", Tcl_PosixError(interp), 
			(char *) NULL);
		return TCL_ERROR;
	    }
	    goto end;
	}


	/* We own the object now */


	Tcl_IncrRefCount(objStrings);


        /* Use objStrings as a list object */


	if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
	    goto end;
	}
	attributeStrings = (CONST char **)
		ckalloc ((1+numObjStrings) * sizeof(char*));
	for (index = 0; index < numObjStrings; index++) {
	    Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
	    attributeStrings[index] = Tcl_GetString(objPtr);
	}
	attributeStrings[index] = NULL;
    }
    if (objc == 0) {
	/*
	 * Get all attributes.
	 */

	int index, res = TCL_OK, nbAtts = 0;
	Tcl_Obj *listPtr;
	 
	listPtr = Tcl_NewListObj(0, NULL);
	for (index = 0; attributeStrings[index] != NULL; index++) {
	    Tcl_Obj *objPtrAttr;
	    
	    if (res != TCL_OK) {

	        /* Clear the error from the last iteration */


	        Tcl_ResetResult(interp);
	    }

	    res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
	    if (res == TCL_OK) {

	        Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);

	        Tcl_ListObjAppendElement(interp, listPtr, objPtr);
	        Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
	        nbAtts++;
	    }
	}

	if (index > 0 && nbAtts == 0) {

	    /* Error: no valid attributes found */


	    Tcl_DecrRefCount(listPtr);
	    goto end;
	}

    	Tcl_SetObjResult(interp, listPtr);
    } else if (objc == 1) {
	/*
	 * Get one attribute.
	 */

	int index;
	Tcl_Obj *objPtr = NULL;

	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"",
		    Tcl_GetString(objv[0]), "\", there are no file attributes"
			     " in this filesystem.", (char *) NULL);
	    goto end;
	}

	if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
		"option", 0, &index) != TCL_OK) {
	    goto end;
	}
	if (Tcl_FSFileAttrsGet(interp, index, filePtr,
		&objPtr) != TCL_OK) {
	    goto end;
	}
	Tcl_SetObjResult(interp, objPtr);
    } else {
	/*
	 * Set option/value pairs.
	 */

	int i, index;
        
	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"",
		    Tcl_GetString(objv[0]), "\", there are no file attributes"
			     " in this filesystem.", (char *) NULL);
	    goto end;
	}

    	for (i = 0; i < objc ; i += 2) {
    	    if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
		    "option", 0, &index) != TCL_OK) {
		goto end;
    	    }
	    if (i + 1 == objc) {
		Tcl_AppendResult(interp, "value for \"",
			Tcl_GetString(objv[i]), "\" missing",
			(char *) NULL);
		goto end;
	    }
    	    if (Tcl_FSFileAttrsSet(interp, index, filePtr,
    	    	    objv[i + 1]) != TCL_OK) {
		goto end;
    	    }
    	}
    }
    result = TCL_OK;

    end:
    if (numObjStrings != -1) {

	/* Free up the array we allocated */


	ckfree((char*)attributeStrings);

	/* 
	 * We don't need this object that was passed to us
	 * any more.
	 */

	if (objStrings != NULL) {
	    Tcl_DecrRefCount(objStrings);
	}
    }
    return result;
}















|
|






|
|
|

>



|
|
|




|


|

>
>
|
>
>







|


>
|
|
|
<

>





|
|
<

>
|


|
|
|

|
>
|











|
|





|
|
|





|

|
|
|
|
|
|

|




|
|








|



|

|
|
|
<


















|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|



|

|
|
|



|

|
|
|


|
|
|
|
|
|
<

|

|
>
|
>
|
>
|

<







|

|
|
|






|

|
|
|
|





>
|
|
|
|
<
|
|
|
|

>



|
|
|
|
|
|

>

>
|
>
>
|
<





>





>
|
|
|

>


>










>
>
|
>
>

>
|
>
>















|

|
<

>


|


|
|

|
|



|
|


|
|
|
|

>

















|
|
|
|

>

>
|
|
|
|
|
|

>


















|
<
|



|
|

|

|

|
|

|
|






|












|
|


|
|
|
<













|
|


|


|


|

|



|














|
|


|
|
<















|


|

|
















|

















|
|
|
<
|
|
|
|
<


|
|


|
|
|
|
|


|


|
|














|










|




>




>


|
|
|


|





>
>
|
>
>

>
>
|
>
>




|


|










|



|

>
|
>
>
|

>


>
|
>
|
|
|


>

>
|
>
>



>










|
|
|


















|

|
|
|










|
<










|

>
|
>
>

>
|
|
<

>






>
>
>
>
>
>
>
>
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426

427
428
429
430
431
432
433
434
435

436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568

569
570
571
572
573
574
575
576
577
578
579

580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636

637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694

695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771

772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813

814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863

864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921

922
923
924
925

926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101

1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121

1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137

	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
	    /*
	     * Trying to delete a file that does not exist is not considered
	     * an error, just a no-op
	     */

	    if (errno != ENOENT) {
		result = TCL_ERROR;
	    }
	} else if (S_ISDIR(statBuf.st_mode)) {
	    /*
	     * We own a reference count on errorBuffer, if it was set as a
	     * result of this call.
	     */

	    result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
	    if (result != TCL_OK) {
		if ((force == 0) && (errno == EEXIST)) {
		    Tcl_AppendResult(interp, "error deleting \"",
			    TclGetString(objv[i]), "\": directory not empty",
			    (char *) NULL);
		    Tcl_PosixError(interp);
		    goto done;
		}

		/*
		 * If possible, use the untranslated name for the file.
		 */

		errfile = errorBuffer;

		/*
		 * FS supposed to check between translated objv and errfile.
		 */

		if (Tcl_FSEqualPaths(objv[i], errfile)) {
		    errfile = objv[i];
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(objv[i]);
	}

	if (result != TCL_OK) {
	    result = TCL_ERROR;

	    /*
	     * It is important that we break on error, otherwise we might end
	     * up owning reference counts on numerous errorBuffers.

	     */

	    break;
	}
    }
    if (result != TCL_OK) {
	if (errfile == NULL) {
	    /*
	     * We try to accomodate poor error results from our Tcl_FS calls.

	     */

	    Tcl_AppendResult(interp, "error deleting unknown file: ",
		    Tcl_PosixError(interp), (char *) NULL);
	} else {
	    Tcl_AppendResult(interp, "error deleting \"",
		    TclGetString(errfile), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
    }

  done:
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * CopyRenameOneFile
 *
 *	Copies or renames specified source file or directory hierarchy to the
 *	specified target.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Target is overwritten if the force flag is set. Attempting to
 *	copy/rename a file onto a directory or a directory onto a file will
 *	always result in an error.
 *
 *----------------------------------------------------------------------
 */

static int
CopyRenameOneFile(interp, source, target, copyFlag, force)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *source;		/* Pathname of file to copy. May need to be
				 * translated. */
    Tcl_Obj *target;		/* Pathname of file to create/overwrite. May
				 * need to be translated. */
    int copyFlag;		/* If non-zero, copy files. Otherwise, rename
				 * them. */
    int force;			/* If non-zero, overwrite target file if it
				 * exists. Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    Tcl_Obj *actualSource=NULL;	/* If source is a link, then this is the real
				 * file/directory. */
    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    errfile = NULL;
    errorBuffer = NULL;
    result = TCL_ERROR;

    /*
     * We want to copy/rename links and not the files they point to, so we use
     * lstat(). If target is a link, we also want to replace the link and not
     * the file it points to, so we also use lstat() on the target.

     */

    if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
	errfile = source;
	goto done;
    }
    if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
	if (errno != ENOENT) {
	    errfile = target;
	    goto done;
	}
    } else {
	if (force == 0) {
	    errno = EEXIST;
	    errfile = target;
	    goto done;
	}

	/*
	 * Prevent copying or renaming a file onto itself. Under Windows, stat
	 * always returns 0 for st_ino. However, the Windows-specific code
	 * knows how to deal with copying or renaming a file on top of itself.
	 * It might be a good idea to write a stat that worked.
	 */

	if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
	    if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
		    (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
		result = TCL_OK;
		goto done;
	    }
	}

	/*
	 * Prevent copying/renaming a file onto a directory and vice-versa.
	 * This is a policy decision based on the fact that existing
	 * implementations of copy and rename on all platforms also prevent
	 * this.
	 */

	if (S_ISDIR(sourceStatBuf.st_mode)
		&& !S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite file \"",
		    TclGetString(target), "\" with directory \"",
		    TclGetString(source), "\"", (char *) NULL);
	    goto done;
	}
	if (!S_ISDIR(sourceStatBuf.st_mode)
		&& S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite directory \"",
		    TclGetString(target), "\" with file \"",
		    TclGetString(source), "\"", (char *) NULL);
	    goto done;
	}

	/*
	 * The destination exists, but appears to be ok to over-write, and
	 * -force is given. We now try to adjust permissions to ensure the
	 * operation succeeds. If we can't adjust permissions, we'll let the
	 * actual copy/rename return an error later.

	 */

	{
	    Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1);
	    int index;
	    Tcl_IncrRefCount(perm);
	    if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) {
		Tcl_FSFileAttrsSet(NULL, index, target, perm);
	    }
	    Tcl_DecrRefCount(perm);
	}

    }

    if (copyFlag == 0) {
	result = Tcl_FSRenameFile(source, target);
	if (result == TCL_OK) {
	    goto done;
	}

	if (errno == EINVAL) {
	    Tcl_AppendResult(interp, "error renaming \"",
		    TclGetString(source), "\" to \"", TclGetString(target),
		    "\": trying to rename a volume or ",
		    "move a directory into itself", (char *) NULL);
	    goto done;
	} else if (errno != EXDEV) {
	    errfile = target;
	    goto done;
	}

	/*
	 * The rename failed because the move was across file systems. Fall
	 * through to copy file and then remove original. Note that the
	 * low-level Tcl_FSRenameFileProc in the filesystem is allowed to
	 * implement cross-filesystem moves itself, if it desires.
	 */
    }

    actualSource = source;
    Tcl_IncrRefCount(actualSource);

    /*
     * Activate the following block to copy files instead of links. However
     * Tcl's semantics currently say we should copy links, so any such change
     * should be the subject of careful study on the consequences.

     *
     * Perhaps there could be an optional flag to 'file copy' to dictate which
     * approach to use, with the default being _not_ to have this block
     * active.
     */

#if 0
#ifdef S_ISLNK
    if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
	/*
	 * We want to copy files not links. Therefore we must follow the link.
	 * There are two purposes to this 'stat' call here. First we want to
	 * know if the linked-file/dir actually exists, and second, in the
	 * block of code which follows, some 20 lines down, we want to check
	 * if the thing is a file or directory.
	 */

	if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
	    /*
	     * Actual file doesn't exist.
	     */

	    Tcl_AppendResult(interp, "error copying \"", TclGetString(source),

		    "\": the target of this link doesn't exist",
		    (char *) NULL);
	    goto done;
	} else {
	    int counter = 0;

	    while (1) {
		Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
		if (path == NULL) {
		    break;
		}

		/*
		 * Now we want to check if this is a relative path, and if so,
		 * to make it absolute.
		 */

		if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
		    Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);

		    if (abs == NULL) {
			break;
		    }
		    Tcl_IncrRefCount(abs);
		    Tcl_DecrRefCount(path);
		    path = abs;
		}
		Tcl_DecrRefCount(actualSource);
		actualSource = path;
		counter++;

		/*
		 * Arbitrary limit of 20 links to follow.
		 */

		if (counter > 20) {
		    /*
		     * Too many links.
		     */

		    Tcl_SetErrno(EMLINK);
		    errfile = source;
		    goto done;
		}
	    }
	    /* Now 'actualSource' is the correct file */
	}
    }
#endif
#endif

    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
	if (result != TCL_OK) {
	    if (errno == EXDEV) {
		/*
		 * The copy failed because we're trying to do a
		 * cross-filesystem copy. We do this through our Tcl library.

		 */

		Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
		Tcl_IncrRefCount(copyCommand);
		Tcl_ListObjAppendElement(interp, copyCommand,
			Tcl_NewStringObj("::tcl::CopyDirectory",-1));
		if (copyFlag) {
		    Tcl_ListObjAppendElement(interp, copyCommand,
			    Tcl_NewStringObj("copying",-1));
		} else {
		    Tcl_ListObjAppendElement(interp, copyCommand,
			    Tcl_NewStringObj("renaming",-1));
		}
		Tcl_ListObjAppendElement(interp, copyCommand, source);
		Tcl_ListObjAppendElement(interp, copyCommand, target);
		result = Tcl_EvalObjEx(interp, copyCommand,
			TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
		Tcl_DecrRefCount(copyCommand);
		if (result != TCL_OK) {
		    /*
		     * There was an error in the Tcl-level copy. We will pass
		     * on the Tcl error message and can ensure this by setting
		     * errfile to NULL
		     */

		    errfile = NULL;
		}
	    } else {
		errfile = errorBuffer;
		if (Tcl_FSEqualPaths(errfile, source)) {
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(actualSource, target);
	if ((result != TCL_OK) && (errno == EXDEV)) {
	    result = TclCrossFilesystemCopy(interp, source, target);
	}
	if (result != TCL_OK) {
	    /*
	     * We could examine 'errno' to double-check if the problem was
	     * with the target, but we checked the source above, so it should
	     * be quite clear
	     */

	    errfile = target;

	    /*
	     * We now need to reset the result, because the above call, if it
	     * failed, may have put an error message in place. (Ideally we
	     * would prefer not to pass an interpreter in above, but the
	     * channel IO code used by TclCrossFilesystemCopy currently
	     * requires one).
	     */

	    Tcl_ResetResult(interp);
	}
    }
    if ((copyFlag == 0) && (result == TCL_OK)) {
	if (S_ISDIR(sourceStatBuf.st_mode)) {
	    result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
	    if (result != TCL_OK) {
		if (Tcl_FSEqualPaths(errfile, source) == 0) {
		    errfile = source;
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(source);
	    if (result != TCL_OK) {
		errfile = source;
	    }
	}
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),

		    "\": ", Tcl_PosixError(interp), (char *) NULL);
	    errfile = NULL;
	}
    }

  done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp,
		((copyFlag) ? "error copying \"" : "error renaming \""),
		 TclGetString(source), (char *) NULL);
	if (errfile != source) {
	    Tcl_AppendResult(interp, "\" to \"", TclGetString(target),
		    (char *) NULL);
	    if (errfile != target) {
		Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),
			(char *) NULL);
	    }
	}
	Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
		(char *) NULL);
    }
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    if (actualSource != NULL) {
	Tcl_DecrRefCount(actualSource);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * FileForceOption --
 *
 *	Helps parse command line options for file commands that take the
 *	"-force" and "--" options.
 *
 * Results:
 *	The return value is how many arguments from argv were consumed by this
 *	function, or -1 if there was an error parsing the options. If an error
 *	occurred, an error message is left in the interp's result.

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
FileForceOption(interp, objc, objv, forcePtr)
    Tcl_Interp *interp;		/* Interp, for error return. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings.  First command line
				 * option, if it exists, begins at 0. */
    int *forcePtr;		/* If the "-force" was specified, *forcePtr is
				 * filled with 1, otherwise with 0. */
{
    int force, i;

    force = 0;
    for (i = 0; i < objc; i++) {
	if (TclGetString(objv[i])[0] != '-') {
	    break;
	}
	if (strcmp(TclGetString(objv[i]), "-force") == 0) {
	    force = 1;
	} else if (strcmp(TclGetString(objv[i]), "--") == 0) {
	    i++;
	    break;
	} else {
	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]),
		    "\": should be -force or --", (char *)NULL);
	    return -1;
	}
    }
    *forcePtr = force;
    return i;
}
/*
 *---------------------------------------------------------------------------
 *
 * FileBasename --
 *
 *	Given a path in either tcl format (with / separators), or in the
 *	platform-specific format for the current platform, return all the
 *	characters in the path after the last directory separator. But, if
 *	path is the root directory, returns no characters.
 *
 * Results:
 *	Returns the string object that represents the basename. If there is an
 *	error, an error message is left in interp, and NULL is returned.

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
FileBasename(interp, pathPtr)
    Tcl_Interp *interp;		/* Interp, for error return. */
    Tcl_Obj *pathPtr;		/* Path whose basename to extract. */
{
    int objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;

    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);

    if (objc != 0) {
	if ((objc == 1) && (*TclGetString(pathPtr) == '~')) {
	    Tcl_DecrRefCount(splitPtr);
	    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
	    Tcl_IncrRefCount(splitPtr);
	}

	/*
	 * Return the last component, unless it is the only component, and it
	 * is the root of an absolute path.
	 */

	if (objc > 0) {
	    Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
	    if ((objc == 1) &&
		    (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
		resultPtr = NULL;
	    }
	}
    }
    if (resultPtr == NULL) {
	resultPtr = Tcl_NewObj();
    }
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(splitPtr);
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileAttrsCmd --
 *
 *	Sets or gets the platform-specific attributes of a file. The objc-objv
 *	points to the file name with the rest of the command line following.
 *	This routine uses platform-specific tables of option strings and

 *	callbacks. The callback to get the attributes take three parameters:
 *	    Tcl_Interp *interp;	    The interp to report errors with. Since
 *				    this is an object-based API, the object
 *				    form of the result should be used.

 *	    CONST char *fileName;   This is extracted using
 *				    Tcl_TranslateFileName.
 *	    TclObj **attrObjPtrPtr; A new object to hold the attribute is
 *				    allocated and put here.
 *	The first two parameters of the callback used to write out the
 *	attributes are the same. The third parameter is:
 *	    CONST *attrObjPtr;	    A pointer to the object that has the new
 *				    attribute.
 *	They both return standard TCL errors; if the routine to get an
 *	attribute fails, no object is allocated and *attrObjPtrPtr is
 *	unchanged.
 *
 * Results:
 *	Standard TCL error.
 *
 * Side effects:
 *	May set file attributes for the file name.
 *
 *----------------------------------------------------------------------
 */

int
TclFileAttrsCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int objc;			/* Number of command line arguments. */
    Tcl_Obj *CONST objv[];	/* The command line objects. */
{
    int result;
    CONST char ** attributeStrings;
    Tcl_Obj* objStrings = NULL;
    int numObjStrings = -1;
    Tcl_Obj *filePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv,
		"name ?option? ?value? ?option value ...?");
	return TCL_ERROR;
    }

    filePtr = objv[2];
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
    	return TCL_ERROR;
    }

    objc -= 3;
    objv += 3;
    result = TCL_ERROR;
    Tcl_SetErrno(0);

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;

	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/*
		 * There was an error, probably that the filePtr is not
		 * accepted by any filesystem
		 */
		Tcl_AppendResult(interp, "could not read \"",
			TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
			(char *) NULL);
		return TCL_ERROR;
	    }
	    goto end;
	}

	/*
	 * We own the object now.
	 */

	Tcl_IncrRefCount(objStrings);

	/*
	 * Use objStrings as a list object.
	 */

	if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
	    goto end;
	}
	attributeStrings = (CONST char **)
		ckalloc((1+numObjStrings) * sizeof(char*));
	for (index = 0; index < numObjStrings; index++) {
	    Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
	    attributeStrings[index] = TclGetString(objPtr);
	}
	attributeStrings[index] = NULL;
    }
    if (objc == 0) {
	/*
	 * Get all attributes.
	 */

	int index, res = TCL_OK, nbAtts = 0;
	Tcl_Obj *listPtr;

	listPtr = Tcl_NewListObj(0, NULL);
	for (index = 0; attributeStrings[index] != NULL; index++) {
	    Tcl_Obj *objPtrAttr;

	    if (res != TCL_OK) {
		/*
		 * Clear the error from the last iteration.
		 */

		Tcl_ResetResult(interp);
	    }

	    res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
	    if (res == TCL_OK) {
		Tcl_Obj *objPtr =
			Tcl_NewStringObj(attributeStrings[index], -1);

		Tcl_ListObjAppendElement(interp, listPtr, objPtr);
		Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
		nbAtts++;
	    }
	}

	if (index > 0 && nbAtts == 0) {
	    /*
	     * Error: no valid attributes found.
	     */

	    Tcl_DecrRefCount(listPtr);
	    goto end;
	}

    	Tcl_SetObjResult(interp, listPtr);
    } else if (objc == 1) {
	/*
	 * Get one attribute.
	 */

	int index;
	Tcl_Obj *objPtr = NULL;

	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
		    "\", there are no file attributes in this filesystem.",
		    (char *) NULL);
	    goto end;
	}

	if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
		"option", 0, &index) != TCL_OK) {
	    goto end;
	}
	if (Tcl_FSFileAttrsGet(interp, index, filePtr,
		&objPtr) != TCL_OK) {
	    goto end;
	}
	Tcl_SetObjResult(interp, objPtr);
    } else {
	/*
	 * Set option/value pairs.
	 */

	int i, index;

	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
		    "\", there are no file attributes in this filesystem.",
		    (char *) NULL);
	    goto end;
	}

    	for (i = 0; i < objc ; i += 2) {
    	    if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
		    "option", 0, &index) != TCL_OK) {
		goto end;
    	    }
	    if (i + 1 == objc) {
		Tcl_AppendResult(interp, "value for \"",
			TclGetString(objv[i]), "\" missing", (char *) NULL);

		goto end;
	    }
    	    if (Tcl_FSFileAttrsSet(interp, index, filePtr,
    	    	    objv[i + 1]) != TCL_OK) {
		goto end;
    	    }
    	}
    }
    result = TCL_OK;

  end:
    if (numObjStrings != -1) {
	/*
	 * Free up the array we allocated.
	 */

	ckfree((char*)attributeStrings);

	/*
	 * We don't need this object that was passed to us any more.

	 */

	if (objStrings != NULL) {
	    Tcl_DecrRefCount(objStrings);
	}
    }
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclFileName.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73

74


75
76

77
78
79
80
81
82
83
84

85


86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

108
109
110
111
112
113
114

115


116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

132


133
134
135
136
137
138
139

140


141
142
143
144
145
146
147
148
149

150


151
152
153
154
155
156
157
158
159
160
161
162





163


164

165


166
167
168
169
170

171

172


173
174
175



176

177


178
179
180
181
182
183


184

185

186

187


188

189

190


191


192

193

194


195
196

197
198
199
200
201
202
203


204


205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286

287
288
289
290
291
292
293
/*
 * tclFileName.c --
 *
 *	This file contains routines for converting file names betwen
 *	native and network form.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclFileName.c,v 1.60 2004/10/07 14:50:21 vincentdarley Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
#include "tclFileSystem.h" /* For TclGetPathType() */

/*
 * The following variable is set in the TclPlatformInit call to one
 * of: TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS.
 */

TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;

/*
 * Prototypes for local procedures defined in this file:
 */

static CONST char *	DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *user, Tcl_DString *resultPtr));
static CONST char *	ExtractWinRoot _ANSI_ARGS_((CONST char *path,
			    Tcl_DString *resultPtr, int offset,
			    Tcl_PathType *typePtr));
static int		SkipToChar _ANSI_ARGS_((char **stringPtr, int match));
static Tcl_Obj*		SplitWinPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj*		SplitUnixPath _ANSI_ARGS_((CONST char *path));
static int              DoGlob _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *resultPtr, char *separators,
			    Tcl_Obj *pathPtr, int flags, char *pattern,
			    Tcl_GlobTypeData *types));


/*
 *----------------------------------------------------------------------
 *
 * ExtractWinRoot --
 *
 *	Matches the root portion of a Windows path and appends it
 *	to the specified Tcl_DString.
 *
 * Results:
 *	Returns the position in the path immediately after the root
 *	including any trailing slashes.
 *	Appends a cleaned up version of the root to the Tcl_DString
 *	at the specified offest.
 *
 * Side effects:
 *	Modifies the specified Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

static CONST char *
ExtractWinRoot(path, resultPtr, offset, typePtr)
    CONST char *path;		/* Path to parse. */
    Tcl_DString *resultPtr;	/* Buffer to hold result. */
    int offset;			/* Offset in buffer where result should be
				 * stored. */
    Tcl_PathType *typePtr;	/* Where to store pathType result */
{
    if (path[0] == '/' || path[0] == '\\') {

	/* Might be a UNC or Vol-Relative path */


	CONST char *host, *share, *tail;
	int hlen, slen;

	if (path[1] != '/' && path[1] != '\\') {
	    Tcl_DStringSetLength(resultPtr, offset);
	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
	    Tcl_DStringAppend(resultPtr, "/", 1);
	    return &path[1];
	}
	host = &path[2];


	/* Skip separators */


	while (host[0] == '/' || host[0] == '\\') {
	    host++;
	}

	for (hlen = 0; host[hlen];hlen++) {
	    if (host[hlen] == '/' || host[hlen] == '\\') {
		break;
	    }
	}
	if (host[hlen] == 0 || host[hlen+1] == 0) {
	    /*
	     * The path given is simply of the form
	     * '/foo', '//foo', '/////foo' or the same
	     * with backslashes.  If there is exactly
	     * one leading '/' the path is volume relative
	     * (see filename man page).  If there are more
	     * than one, we are simply assuming they
	     * are superfluous and we trim them away.
	     * (An alternative interpretation would
	     * be that it is a host name, but we have
	     * been documented that that is not the case).
	     */

	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
	    Tcl_DStringAppend(resultPtr, "/", 1);
	    return &path[2];
	}
	Tcl_DStringSetLength(resultPtr, offset);
	share = &host[hlen];


	/* Skip separators */


	while (share[0] == '/' || share[0] == '\\') {
	    share++;
	}

	for (slen=0; share[slen]; slen++) {
	    if (share[slen] == '/' || share[slen] == '\\') {
		break;
	    }
	}
	Tcl_DStringAppend(resultPtr, "//", 2);
	Tcl_DStringAppend(resultPtr, host, hlen);
	Tcl_DStringAppend(resultPtr, "/", 1);
	Tcl_DStringAppend(resultPtr, share, slen);

	tail = &share[slen];


	/* Skip separators */


	while (tail[0] == '/' || tail[0] == '\\') {
	    tail++;
	}

	*typePtr = TCL_PATH_ABSOLUTE;
	return tail;
    } else if (*path && path[1] == ':') {

	/* Might be a drive sep */


	Tcl_DStringSetLength(resultPtr, offset);

	if (path[2] != '/' && path[2] != '\\') {
	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
	    Tcl_DStringAppend(resultPtr, path, 2);
	    return &path[2];
	} else {
	    char *tail = (char*)&path[3];


	    /* Skip separators */


	    while (*tail && (tail[0] == '/' || tail[0] == '\\')) {
		tail++;
	    }

	    *typePtr = TCL_PATH_ABSOLUTE;
	    Tcl_DStringAppend(resultPtr, path, 2);
	    Tcl_DStringAppend(resultPtr, "/", 1);

	    return tail;
	}
    } else {
	int abs = 0;





	if (path[0] == 'c' && path[1] == 'o') {


	    if (path[2] == 'm' && path[3] >= '1' && path[3] <= '9') {

		/* May have match for 'com[1-9]:?', which is a serial port */


		if (path[4] == '\0') {
		    abs = 4;
		} else if (path [4] == ':' && path[5] == '\0') {
		    abs = 5;
		}

	    } else if (path[2] == 'n' && path[3] == '\0') {

		/* Have match for 'con' */


		abs = 3;
	    }
	} else if (path[0] == 'l' && path[1] == 'p' && path[2] == 't') {



	    if (path[3] >= '1' && path[3] <= '9') {

		/* May have match for 'lpt[1-9]:?' */


		if (path[4] == '\0') {
		    abs = 4;
		} else if (path [4] == ':' && path[5] == '\0') {
		    abs = 5;
		}
	    }


	} else if (path[0] == 'p' && path[1] == 'r'

		&& path[2] == 'n' && path[3] == '\0') {

	    /* Have match for 'prn' */

	    abs = 3;


	} else if (path[0] == 'n' && path[1] == 'u'

		&& path[2] == 'l' && path[3] == '\0') {

	    /* Have match for 'nul' */


	    abs = 3;


	} else if (path[0] == 'a' && path[1] == 'u'

		&& path[2] == 'x' && path[3] == '\0') {

	    /* Have match for 'aux' */


	    abs = 3;
	}

	if (abs != 0) {
	    *typePtr = TCL_PATH_ABSOLUTE;
	    Tcl_DStringSetLength(resultPtr, offset);
	    Tcl_DStringAppend(resultPtr, path, abs);
	    return path + abs;
	}
    }


    /* Anything else is treated as relative */


    *typePtr = TCL_PATH_RELATIVE;
    return path;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetPathType --
 *
 *	Determines whether a given path is relative to the current
 *	directory, relative to the current volume, or absolute.
 *
 *	The objectified Tcl_FSGetPathType should be used in
 *	preference to this function (as you can see below, this
 *	is just a wrapper around that other function).
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
Tcl_GetPathType(path)
    CONST char *path;
{
    Tcl_PathType type;
    Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(tempObj);
    type = Tcl_FSGetPathType(tempObj);
    Tcl_DecrRefCount(tempObj);
    return type;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetNativePathType --
 *
 *	Determines whether a given path is relative to the current
 *	directory, relative to the current volume, or absolute, but
 *	ONLY FOR THE NATIVE FILESYSTEM. This function is called from
 *	tclIOUtil.c (but needs to be here due to its dependence on
 *	static variables/functions in this file).  The exported
 *	function Tcl_FSGetPathType should be used by extensions.

 *
 *	Note that '~' paths are always considered TCL_PATH_ABSOLUTE,
 *	even though expanding the '~' could lead to any possible
 *	path type.  This function should therefore be considered a
 *	low-level, string-manipulation function only -- it doesn't
 *	actually do any expansion in making its determination.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef)
    Tcl_Obj *pathPtr;         /* Native path of interest */
    int *driveNameLengthPtr;  /* Returns length of drive, if non-NULL
                               * and path was absolute */
    Tcl_Obj **driveNameRef;
{
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    int pathLen;
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    if (path[0] == '~') {
	/*
	 * This case is common to all platforms.
	 * Paths that begin with ~ are absolute.
	 */

	if (driveNameLengthPtr != NULL) {
	    char *end = path + 1;
	    while ((*end != '\0') && (*end != '/')) {
		end++;
	    }
	    *driveNameLengthPtr = end - path;
	}



|
|




|
|

|







|
|
















|



<






|
|


|
<
|
|
















>
|
>
>


>








>
|
>
>











|
<
|
|
<
|
|
<
|


>







>
|
>
>
















>
|
>
>







>
|
>
>









>
|
>
>












>
>
>
>
>
|
>
>
|
>
|
>
>





>
|
>
|
>
>


|
>
>
>
|
>
|
>
>






>
>
|
>
|
>
|
>

>
>
|
>
|
>
|
>
>

>
>
|
>
|
>
|
>
>


>







>
>
|
>
>









|
|

|
|
|

















>











|
|
|
<
|
|
>

|
|
|
|
|













|
|
|








|
|

>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

103
104

105
106

107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
/*
 * tclFileName.c --
 *
 *	This file contains routines for converting file names betwen native
 *	and network form.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclFileName.c,v 1.60.2.8 2005/08/02 18:15:28 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"
#include "tclFileSystem.h" /* For TclGetPathType() */

/*
 * The following variable is set in the TclPlatformInit call to one of:
 * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS.
 */

TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;

/*
 * Prototypes for local procedures defined in this file:
 */

static CONST char *	DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *user, Tcl_DString *resultPtr));
static CONST char *	ExtractWinRoot _ANSI_ARGS_((CONST char *path,
			    Tcl_DString *resultPtr, int offset,
			    Tcl_PathType *typePtr));
static int		SkipToChar _ANSI_ARGS_((char **stringPtr, int match));
static Tcl_Obj*		SplitWinPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj*		SplitUnixPath _ANSI_ARGS_((CONST char *path));
static int		DoGlob _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *resultPtr, char *separators,
			    Tcl_Obj *pathPtr, int flags, char *pattern,
			    Tcl_GlobTypeData *types));


/*
 *----------------------------------------------------------------------
 *
 * ExtractWinRoot --
 *
 *	Matches the root portion of a Windows path and appends it to the
 *	specified Tcl_DString.
 *
 * Results:
 *	Returns the position in the path immediately after the root including

 *	any trailing slashes.  Appends a cleaned up version of the root to the
 *	Tcl_DString at the specified offest.
 *
 * Side effects:
 *	Modifies the specified Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

static CONST char *
ExtractWinRoot(path, resultPtr, offset, typePtr)
    CONST char *path;		/* Path to parse. */
    Tcl_DString *resultPtr;	/* Buffer to hold result. */
    int offset;			/* Offset in buffer where result should be
				 * stored. */
    Tcl_PathType *typePtr;	/* Where to store pathType result */
{
    if (path[0] == '/' || path[0] == '\\') {
	/*
	 * Might be a UNC or Vol-Relative path.
	 */

	CONST char *host, *share, *tail;
	int hlen, slen;

	if (path[1] != '/' && path[1] != '\\') {
	    Tcl_DStringSetLength(resultPtr, offset);
	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
	    Tcl_DStringAppend(resultPtr, "/", 1);
	    return &path[1];
	}
	host = &path[2];

	/*
	 * Skip separators.
	 */

	while (host[0] == '/' || host[0] == '\\') {
	    host++;
	}

	for (hlen = 0; host[hlen];hlen++) {
	    if (host[hlen] == '/' || host[hlen] == '\\') {
		break;
	    }
	}
	if (host[hlen] == 0 || host[hlen+1] == 0) {
	    /*
	     * The path given is simply of the form '/foo', '//foo',

	     * '/////foo' or the same with backslashes.  If there is exactly
	     * one leading '/' the path is volume relative (see filename man

	     * page).  If there are more than one, we are simply assuming they
	     * are superfluous and we trim them away.  (An alternative

	     * interpretation would be that it is a host name, but we have
	     * been documented that that is not the case).
	     */

	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
	    Tcl_DStringAppend(resultPtr, "/", 1);
	    return &path[2];
	}
	Tcl_DStringSetLength(resultPtr, offset);
	share = &host[hlen];

	/*
	 * Skip separators.
	 */

	while (share[0] == '/' || share[0] == '\\') {
	    share++;
	}

	for (slen=0; share[slen]; slen++) {
	    if (share[slen] == '/' || share[slen] == '\\') {
		break;
	    }
	}
	Tcl_DStringAppend(resultPtr, "//", 2);
	Tcl_DStringAppend(resultPtr, host, hlen);
	Tcl_DStringAppend(resultPtr, "/", 1);
	Tcl_DStringAppend(resultPtr, share, slen);

	tail = &share[slen];

	/*
	 * Skip separators.
	 */

	while (tail[0] == '/' || tail[0] == '\\') {
	    tail++;
	}

	*typePtr = TCL_PATH_ABSOLUTE;
	return tail;
    } else if (*path && path[1] == ':') {
	/*
	 * Might be a drive separator.
	 */

	Tcl_DStringSetLength(resultPtr, offset);

	if (path[2] != '/' && path[2] != '\\') {
	    *typePtr = TCL_PATH_VOLUME_RELATIVE;
	    Tcl_DStringAppend(resultPtr, path, 2);
	    return &path[2];
	} else {
	    char *tail = (char*)&path[3];

	    /*
	     * Skip separators.
	     */

	    while (*tail && (tail[0] == '/' || tail[0] == '\\')) {
		tail++;
	    }

	    *typePtr = TCL_PATH_ABSOLUTE;
	    Tcl_DStringAppend(resultPtr, path, 2);
	    Tcl_DStringAppend(resultPtr, "/", 1);

	    return tail;
	}
    } else {
	int abs = 0;

	/*
	 * Check for Windows devices.
	 */

	if ((path[0] == 'c' || path[0] == 'C')
		&& (path[1] == 'o' || path[1] == 'O')) {
	    if ((path[2] == 'm' || path[2] == 'M')
		    && path[3] >= '1' && path[3] <= '4') {
		/*
		 * May have match for 'com[1-4]:?', which is a serial port.
		 */

		if (path[4] == '\0') {
		    abs = 4;
		} else if (path [4] == ':' && path[5] == '\0') {
		    abs = 5;
		}

	    } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
		/*
		 * Have match for 'con'.
		 */

		abs = 3;
	    }

	} else if ((path[0] == 'l' || path[0] == 'L')
		&& (path[1] == 'p' || path[1] == 'P')
		&& (path[2] == 't' || path[2] == 'T')) {
	    if (path[3] >= '1' && path[3] <= '3') {
		/*
		 * May have match for 'lpt[1-3]:?'
		 */

		if (path[4] == '\0') {
		    abs = 4;
		} else if (path [4] == ':' && path[5] == '\0') {
		    abs = 5;
		}
	    }

	} else if ((path[0] == 'p' || path[0] == 'P')
		&& (path[1] == 'r' || path[1] == 'R')
		&& (path[2] == 'n' || path[2] == 'N')
		&& path[3] == '\0') {
	    /*
	     * Have match for 'prn'.
	     */
	    abs = 3;

	} else if ((path[0] == 'n' || path[0] == 'N')
		&& (path[1] == 'u' || path[1] == 'U')
		&& (path[2] == 'l' || path[2] == 'L')
		&& path[3] == '\0') {
	    /*
	     * Have match for 'nul'.
	     */

	    abs = 3;

	} else if ((path[0] == 'a' || path[0] == 'A')
		&& (path[1] == 'u' || path[1] == 'U')
		&& (path[2] == 'x' || path[2] == 'X')
		&& path[3] == '\0') {
	    /*
	     * Have match for 'aux'.
	     */

	    abs = 3;
	}

	if (abs != 0) {
	    *typePtr = TCL_PATH_ABSOLUTE;
	    Tcl_DStringSetLength(resultPtr, offset);
	    Tcl_DStringAppend(resultPtr, path, abs);
	    return path + abs;
	}
    }

    /*
     * Anything else is treated as relative.
     */

    *typePtr = TCL_PATH_RELATIVE;
    return path;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetPathType --
 *
 *	Determines whether a given path is relative to the current directory,
 *	relative to the current volume, or absolute.
 *
 *	The objectified Tcl_FSGetPathType should be used in preference to this
 *	function (as you can see below, this is just a wrapper around that
 *	other function).
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
Tcl_GetPathType(path)
    CONST char *path;
{
    Tcl_PathType type;
    Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(tempObj);
    type = Tcl_FSGetPathType(tempObj);
    Tcl_DecrRefCount(tempObj);
    return type;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetNativePathType --
 *
 *	Determines whether a given path is relative to the current directory,
 *	relative to the current volume, or absolute, but ONLY FOR THE NATIVE
 *	FILESYSTEM. This function is called from tclIOUtil.c (but needs to be

 *	here due to its dependence on static variables/functions in this
 *	file).  The exported function Tcl_FSGetPathType should be used by
 *	extensions.
 *
 *	Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even
 *	though expanding the '~' could lead to any possible path type.  This
 *	function should therefore be considered a low-level, string
 *	manipulation function only -- it doesn't actually do any expansion in
 *	making its determination.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef)
    Tcl_Obj *pathPtr;		/* Native path of interest */
    int *driveNameLengthPtr;	/* Returns length of drive, if non-NULL and
				 * path was absolute */
    Tcl_Obj **driveNameRef;
{
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    int pathLen;
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    if (path[0] == '~') {
	/*
	 * This case is common to all platforms.  Paths that begin with ~ are
	 * absolute.
	 */

	if (driveNameLengthPtr != NULL) {
	    char *end = path + 1;
	    while ((*end != '\0') && (*end != '/')) {
		end++;
	    }
	    *driveNameLengthPtr = end - path;
	}
311
312
313
314
315
316
317
318
319
320

321
322
323
324
325
326
327
		    ++path;
		}
	    }
#endif
	    if (path[0] == '/') {
		if (driveNameLengthPtr != NULL) {
		    /*
		     * We need this addition in case the QNX code
		     * was used
		     */

		    *driveNameLengthPtr = (1 + path - origPath);
		}
	    } else {
		type = TCL_PATH_RELATIVE;
	    }
	    break;
	}







|
<

>







370
371
372
373
374
375
376
377

378
379
380
381
382
383
384
385
386
		    ++path;
		}
	    }
#endif
	    if (path[0] == '/') {
		if (driveNameLengthPtr != NULL) {
		    /*
		     * We need this addition in case the QNX code was used.

		     */

		    *driveNameLengthPtr = (1 + path - origPath);
		}
	    } else {
		type = TCL_PATH_RELATIVE;
	    }
	    break;
	}
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeSplitPath --
 *
 *      This function takes the given Tcl_Obj, which should be a valid
 *      path, and returns a Tcl List object containing each segment
 *      of that path as an element.
 *
 *      Note this function currently calls the older Split(Plat)Path
 *      functions, which require more memory allocation than is
 *      desirable.
 *
 * Results:
 *      Returns list object with refCount of zero.  If the passed in
 *      lenPtr is non-NULL, we use it to return the number of elements
 *      in the returned list.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */








|
|
|

|
|
<


|
|
|







407
408
409
410
411
412
413
414
415
416
417
418
419

420
421
422
423
424
425
426
427
428
429
430
431
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeSplitPath --
 *
 *	This function takes the given Tcl_Obj, which should be a valid path,
 *	and returns a Tcl List object containing each segment of that path as
 *	an element.
 *
 *	Note this function currently calls the older Split(Plat)Path
 *	functions, which require more memory allocation than is desirable.

 *
 * Results:
 *	Returns list object with refCount of zero.  If the passed in lenPtr is
 *	non-NULL, we use it to return the number of elements in the returned
 *	list.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

454

455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitPath --
 *
 *	Split a path into a list of path components.  The first element
 *	of the list will have the same path type as the original path.
 *
 * Results:
 *	Returns a standard Tcl result.  The interpreter result contains
 *	a list of path components.
 *	*argvPtr will be filled in with the address of an array
 *	whose elements point to the elements of path, in order.
 *	*argcPtr will get filled in with the number of valid elements
 *	in the array.  A single block of memory is dynamically allocated
 *	to hold both the argv array and a copy of the path elements.
 *	The caller must eventually free this memory by calling ckfree()
 *	on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
 *	if the procedure returns normally.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SplitPath(path, argcPtr, argvPtr)
    CONST char *path;		/* Pointer to string containing a path. */
    int *argcPtr;		/* Pointer to location to fill in with
				 * the number of elements in the path. */
    CONST char ***argvPtr;	/* Pointer to place to store pointer to array
				 * of pointers to path elements. */
{
    Tcl_Obj *resultPtr = NULL;  /* Needed only to prevent gcc warnings. */
    Tcl_Obj *tmpPtr, *eltPtr;
    int i, size, len;
    char *p, *str;

    /*
     * Perform the splitting, using objectified, vfs-aware code.
     */

    tmpPtr = Tcl_NewStringObj(path, -1);
    Tcl_IncrRefCount(tmpPtr);
    resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(tmpPtr);


    /* Calculate space required for the result */


    size = 1;
    for (i = 0; i < *argcPtr; i++) {
	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
	Tcl_GetStringFromObj(eltPtr, &len);
	size += len + 1;
    }

    /*
     * Allocate a buffer large enough to hold the contents of all of
     * the list plus the argv pointers and the terminating NULL pointer.
     */

    *argvPtr = (CONST char **) ckalloc((unsigned)
	    ((((*argcPtr) + 1) * sizeof(char *)) + size));

    /*
     * Position p after the last argv pointer and copy the contents of
     * the list in, piece by piece.
     */

    p = (char *) &(*argvPtr)[(*argcPtr) + 1];
    for (i = 0; i < *argcPtr; i++) {
	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
	str = Tcl_GetStringFromObj(eltPtr, &len);
	memcpy((VOID *) p, (VOID *) str, (size_t) len+1);







|
|


|
<
|
|
|
|
|
|
|
|










|
|


















>
|
>









|
|






|
|







461
462
463
464
465
466
467
468
469
470
471
472

473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitPath --
 *
 *	Split a path into a list of path components.  The first element of the
 *	list will have the same path type as the original path.
 *
 * Results:
 *	Returns a standard Tcl result.  The interpreter result contains a list

 *	of path components.  *argvPtr will be filled in with the address of an
 *	array whose elements point to the elements of path, in order.
 *	*argcPtr will get filled in with the number of valid elements in the
 *	array.  A single block of memory is dynamically allocated to hold both
 *	the argv array and a copy of the path elements.  The caller must
 *	eventually free this memory by calling ckfree() on *argvPtr.  Note:
 *	*argvPtr and *argcPtr are only modified if the procedure returns
 *	normally.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SplitPath(path, argcPtr, argvPtr)
    CONST char *path;		/* Pointer to string containing a path. */
    int *argcPtr;		/* Pointer to location to fill in with the
				 * number of elements in the path. */
    CONST char ***argvPtr;	/* Pointer to place to store pointer to array
				 * of pointers to path elements. */
{
    Tcl_Obj *resultPtr = NULL;  /* Needed only to prevent gcc warnings. */
    Tcl_Obj *tmpPtr, *eltPtr;
    int i, size, len;
    char *p, *str;

    /*
     * Perform the splitting, using objectified, vfs-aware code.
     */

    tmpPtr = Tcl_NewStringObj(path, -1);
    Tcl_IncrRefCount(tmpPtr);
    resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(tmpPtr);

    /*
     * Calculate space required for the result.
     */

    size = 1;
    for (i = 0; i < *argcPtr; i++) {
	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
	Tcl_GetStringFromObj(eltPtr, &len);
	size += len + 1;
    }

    /*
     * Allocate a buffer large enough to hold the contents of all of the list
     * plus the argv pointers and the terminating NULL pointer.
     */

    *argvPtr = (CONST char **) ckalloc((unsigned)
	    ((((*argcPtr) + 1) * sizeof(char *)) + size));

    /*
     * Position p after the last argv pointer and copy the contents of the
     * list in, piece by piece.
     */

    p = (char *) &(*argvPtr)[(*argcPtr) + 1];
    for (i = 0; i < *argcPtr; i++) {
	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
	str = Tcl_GetStringFromObj(eltPtr, &len);
	memcpy((VOID *) p, (VOID *) str, (size_t) len+1);
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
}

/*
 *----------------------------------------------------------------------
 *
 * SplitUnixPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting
 *	Unix paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *







|
|







560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
}

/*
 *----------------------------------------------------------------------
 *
 * SplitUnixPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting Unix
 *	paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
	}
	if (*p++ == '\0') {
	    break;
	}
    }
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * SplitWinPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting
 *	Windows paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *







<






|
|







631
632
633
634
635
636
637

638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
	}
	if (*p++ == '\0') {
	    break;
	}
    }
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * SplitWinPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting Windows
 *	paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *
615
616
617
618
619
620
621
622
623

624
625
626
627
628
629
630
631
632
633

634


635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689

690
691
692
693
694
695
696
697

698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738


739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
    if (p != path) {
	Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
		Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)));
    }
    Tcl_DStringFree(&buf);

    /*
     * Split on slashes.  Embedded elements that start with tilde will be
     * prefixed with "./" so they are not affected by tilde substitution.

     */

    do {
	elementStart = p;
	while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
	    p++;
	}
	length = p - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;

	    if ((elementStart[0] == '~') && (elementStart != path)) {


		nextElt = Tcl_NewStringObj("./",2);
		Tcl_AppendToObj(nextElt, elementStart, length);
	    } else {
		nextElt = Tcl_NewStringObj(elementStart, length);
	    }
	    Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
    } while (*p++ != '\0');

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSJoinToPath --
 *
 *      This function takes the given object, which should usually be a
 *      valid path or NULL, and joins onto it the array of paths
 *      segments given.
 *
 *      The objects in the array given will temporarily have their
 *      refCount increased by one, and then decreased by one when this
 *      function exits (which means if they had zero refCount when we
 *      were called, they will be freed).
 *
 * Results:
 *      Returns object owned by the caller (which should increment its
 *      refCount) - typically an object with refCount of zero.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSJoinToPath(pathPtr, objc, objv)
    Tcl_Obj *pathPtr;      /* Valid path or NULL. */
    int objc;              /* Number of array elements to join */
    Tcl_Obj *CONST objv[]; /* Path elements to join. */
{
    int i;
    Tcl_Obj *lobj, *ret;

    if (pathPtr == NULL) {
	lobj = Tcl_NewListObj(0, NULL);
    } else {
	lobj = Tcl_NewListObj(1, &pathPtr);
    }

    for (i = 0; i<objc;i++) {
	Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
    }
    ret = Tcl_FSJoinPath(lobj, -1);

    /*
     * It is possible that 'ret' is just a member of the list and is
     * therefore going to be freed here.  Therefore we must adjust the
     * refCount manually.  (It would be better if we changed the
     * documentation of this function and Tcl_FSJoinPath so that
     * the returned object already has a refCount for the caller,
     * hence avoiding these subtleties (and code ugliness)).
     */

    Tcl_IncrRefCount(ret);
    Tcl_DecrRefCount(lobj);
    ret->refCount--;
    return ret;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeJoinPath --
 *
 *      'prefix' is absolute, 'joining' is relative to prefix.
 *
 * Results:
 *      modifies prefix
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclpNativeJoinPath(prefix, joining)
    Tcl_Obj *prefix;
    char* joining;
{
    int length, needsSep;
    char *dest, *p, *start;

    start = Tcl_GetStringFromObj(prefix, &length);

    /*
     * Remove the ./ from tilde prefixed elements unless
     * it is the first component.
     */

    p = joining;

    if (length != 0) {
	if ((p[0] == '.') && (p[1] == '/') && (p[2] == '~')) {


	    p += 2;
	}
    }

    if (*p == '\0') {
	return;
    }

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	/*
	 * Append a separator if needed.
	 */

	if (length > 0 && (start[length-1] != '/')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    length++;
	}
	needsSep = 0;

	/*
	 * Append the element, eliminating duplicate and trailing
	 * slashes.
	 */

	Tcl_SetObjLength(prefix, length + (int) strlen(p));

	dest = Tcl_GetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if (*p == '/') {







|
|
>










>
|
>
>

















|
|
<

|
|
|
|


|
|







|

|
|
|














>

|
|
|
<
|
|

>











|


|










|







|
|





|
>
>



<

















|
<







673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715

716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755

756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805

806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823

824
825
826
827
828
829
830
    if (p != path) {
	Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
		Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)));
    }
    Tcl_DStringFree(&buf);

    /*
     * Split on slashes.  Embedded elements that start with tilde or a drive
     * letter will be prefixed with "./" so they are not affected by tilde
     * substitution.
     */

    do {
	elementStart = p;
	while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
	    p++;
	}
	length = p - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;
	    if ((elementStart != path)
		&& ((elementStart[0] == '~')
		    || (isalpha(UCHAR(elementStart[0]))
			&& elementStart[1] == ':'))) {
		nextElt = Tcl_NewStringObj("./",2);
		Tcl_AppendToObj(nextElt, elementStart, length);
	    } else {
		nextElt = Tcl_NewStringObj(elementStart, length);
	    }
	    Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
    } while (*p++ != '\0');

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSJoinToPath --
 *
 *	This function takes the given object, which should usually be a valid
 *	path or NULL, and joins onto it the array of paths segments given.

 *
 *	The objects in the array given will temporarily have their refCount
 *	increased by one, and then decreased by one when this function exits
 *	(which means if they had zero refCount when we were called, they will
 *	be freed).
 *
 * Results:
 *	Returns object owned by the caller (which should increment its
 *	refCount) - typically an object with refCount of zero.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSJoinToPath(pathPtr, objc, objv)
    Tcl_Obj *pathPtr;		/* Valid path or NULL. */
    int objc;			/* Number of array elements to join */
    Tcl_Obj *CONST objv[];	/* Path elements to join. */
{
    int i;
    Tcl_Obj *lobj, *ret;

    if (pathPtr == NULL) {
	lobj = Tcl_NewListObj(0, NULL);
    } else {
	lobj = Tcl_NewListObj(1, &pathPtr);
    }

    for (i = 0; i<objc;i++) {
	Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
    }
    ret = Tcl_FSJoinPath(lobj, -1);

    /*
     * It is possible that 'ret' is just a member of the list and is therefore
     * going to be freed here. Therefore we must adjust the refCount manually.
     * (It would be better if we changed the documentation of this function

     * and Tcl_FSJoinPath so that the returned object already has a refCount
     * for the caller, hence avoiding these subtleties (and code ugliness)).
     */

    Tcl_IncrRefCount(ret);
    Tcl_DecrRefCount(lobj);
    ret->refCount--;
    return ret;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeJoinPath --
 *
 *	'prefix' is absolute, 'joining' is relative to prefix.
 *
 * Results:
 *	modifies prefix
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclpNativeJoinPath(prefix, joining)
    Tcl_Obj *prefix;
    char *joining;
{
    int length, needsSep;
    char *dest, *p, *start;

    start = Tcl_GetStringFromObj(prefix, &length);

    /*
     * Remove the ./ from tilde prefixed elements, and drive-letter prefixed
     * elements on Windows, unless it is the first component.
     */

    p = joining;

    if (length != 0) {
	if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~')
		|| (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2]))
		&& (p[3] == ':')))) {
	    p += 2;
	}
    }

    if (*p == '\0') {
	return;
    }

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	/*
	 * Append a separator if needed.
	 */

	if (length > 0 && (start[length-1] != '/')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    length++;
	}
	needsSep = 0;

	/*
	 * Append the element, eliminating duplicate and trailing slashes.

	 */

	Tcl_SetObjLength(prefix, length + (int) strlen(p));

	dest = Tcl_GetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if (*p == '/') {
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
		(start[length-1] != '/') && (start[length-1] != ':')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    length++;
	}
	needsSep = 0;

	/*
	 * Append the element, eliminating duplicate and
	 * trailing slashes.
	 */

	Tcl_SetObjLength(prefix, length + (int) strlen(p));
	dest = Tcl_GetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if ((*p == '/') || (*p == '\\')) {
		while ((p[1] == '/') || (p[1] == '\\')) {







|
<







852
853
854
855
856
857
858
859

860
861
862
863
864
865
866
		(start[length-1] != '/') && (start[length-1] != ':')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    length++;
	}
	needsSep = 0;

	/*
	 * Append the element, eliminating duplicate and trailing slashes.

	 */

	Tcl_SetObjLength(prefix, length + (int) strlen(p));
	dest = Tcl_GetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if ((*p == '/') || (*p == '\\')) {
		while ((p[1] == '/') || (p[1] == '\\')) {
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853

854


855
856
857
858
859

860


861
862
863
864
865

866


867
868
869
870

871


872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893

894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939

940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinPath --
 *
 *	Combine a list of paths in a platform specific manner.  The
 *	function 'Tcl_FSJoinPath' should be used in preference where
 *	possible.
 *
 * Results:
 *	Appends the joined path to the end of the specified
 *	Tcl_DString returning a pointer to the resulting string.  Note
 *	that the Tcl_DString must already be initialized.
 *
 * Side effects:
 *	Modifies the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_JoinPath(argc, argv, resultPtr)
    int argc;
    CONST char * CONST *argv;
    Tcl_DString *resultPtr;	/* Pointer to previously initialized DString */
{
    int i, len;
    Tcl_Obj *listObj = Tcl_NewObj();
    Tcl_Obj *resultObj;
    char *resultStr;


    /* Build the list of paths */


    for (i = 0; i < argc; i++) {
        Tcl_ListObjAppendElement(NULL, listObj,
		Tcl_NewStringObj(argv[i], -1));
    }


    /* Ask the objectified code to join the paths */


    Tcl_IncrRefCount(listObj);
    resultObj = Tcl_FSJoinPath(listObj, argc);
    Tcl_IncrRefCount(resultObj);
    Tcl_DecrRefCount(listObj);


    /* Store the result */


    resultStr = Tcl_GetStringFromObj(resultObj, &len);
    Tcl_DStringAppend(resultPtr, resultStr, len);
    Tcl_DecrRefCount(resultObj);


    /* Return a pointer to the result */


    return Tcl_DStringValue(resultPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_TranslateFileName --
 *
 *	Converts a file name into a form usable by the native system
 *	interfaces.  If the name starts with a tilde, it will produce a
 *	name where the tilde and following characters have been replaced
 *	by the home directory location for the named user.
 *
 * Results:
 *	The return value is a pointer to a string containing the name
 *	after tilde substitution.  If there was no tilde substitution,
 *	the return value is a pointer to a copy of the original string.
 *	If there was an error in processing the name, then an error
 *	message is left in the interp's result (if interp was not NULL)
 *	and the return value is NULL.  Space for the return value is
 *	allocated in bufferPtr; the caller must call Tcl_DStringFree()
 *	to free the space if the return value was not NULL.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_TranslateFileName(interp, name, bufferPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error
				 * message (if necessary). */
    CONST char *name;		/* File name, which may begin with "~" (to
				 * indicate current user's home directory) or
				 * "~<user>" (to indicate any user's home
				 * directory). */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled
				 * with name after tilde substitution. */
{
    Tcl_Obj *path = Tcl_NewStringObj(name, -1);
    Tcl_Obj *transPtr;

    Tcl_IncrRefCount(path);
    transPtr = Tcl_FSGetTranslatedPath(interp, path);
    if (transPtr == NULL) {
	Tcl_DecrRefCount(path);
	return NULL;
    }

    Tcl_DStringInit(bufferPtr);
    Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
    Tcl_DecrRefCount(path);
    Tcl_DecrRefCount(transPtr);

    /*
     * Convert forward slashes to backslashes in Windows paths because
     * some system interfaces don't accept forward slashes.
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	register char *p;
	for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
	    if (*p == '/') {
		*p = '\\';
	    }
	}
    }

    return Tcl_DStringValue(bufferPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetExtension --
 *
 *	This function returns a pointer to the beginning of the
 *	extension part of a file name.
 *
 * Results:
 *	Returns a pointer into name which indicates where the extension
 *	starts.  If there is no extension, returns NULL.
 *
 * Side effects:
 *	None.







|
|
<


|
|
|


















>
|
>
>

|



>
|
>
>





>
|
>
>




>
|
>
>









|
|
|


|
|
|
|
|
<
|
|
>









|
|




|
|

















|
|










>








|
|







882
883
884
885
886
887
888
889
890

891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962

963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinPath --
 *
 *	Combine a list of paths in a platform specific manner.  The function
 *	'Tcl_FSJoinPath' should be used in preference where possible.

 *
 * Results:
 *	Appends the joined path to the end of the specified Tcl_DString
 *	returning a pointer to the resulting string.  Note that the
 *	Tcl_DString must already be initialized.
 *
 * Side effects:
 *	Modifies the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_JoinPath(argc, argv, resultPtr)
    int argc;
    CONST char * CONST *argv;
    Tcl_DString *resultPtr;	/* Pointer to previously initialized DString */
{
    int i, len;
    Tcl_Obj *listObj = Tcl_NewObj();
    Tcl_Obj *resultObj;
    char *resultStr;

    /*
     * Build the list of paths.
     */

    for (i = 0; i < argc; i++) {
	Tcl_ListObjAppendElement(NULL, listObj,
		Tcl_NewStringObj(argv[i], -1));
    }

    /*
     * Ask the objectified code to join the paths.
     */

    Tcl_IncrRefCount(listObj);
    resultObj = Tcl_FSJoinPath(listObj, argc);
    Tcl_IncrRefCount(resultObj);
    Tcl_DecrRefCount(listObj);

    /*
     * Store the result.
     */

    resultStr = Tcl_GetStringFromObj(resultObj, &len);
    Tcl_DStringAppend(resultPtr, resultStr, len);
    Tcl_DecrRefCount(resultObj);

    /*
     * Return a pointer to the result.
     */

    return Tcl_DStringValue(resultPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_TranslateFileName --
 *
 *	Converts a file name into a form usable by the native system
 *	interfaces.  If the name starts with a tilde, it will produce a name
 *	where the tilde and following characters have been replaced by the
 *	home directory location for the named user.
 *
 * Results:
 *	The return value is a pointer to a string containing the name after
 *	tilde substitution. If there was no tilde substitution, the return
 *	value is a pointer to a copy of the original string. If there was an
 *	error in processing the name, then an error message is left in the
 *	interp's result (if interp was not NULL) and the return value is NULL.

 *	Space for the return value is allocated in bufferPtr; the caller must
 *	call Tcl_DStringFree() to free the space if the return value was not
 *	NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_TranslateFileName(interp, name, bufferPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error message
				 * (if necessary). */
    CONST char *name;		/* File name, which may begin with "~" (to
				 * indicate current user's home directory) or
				 * "~<user>" (to indicate any user's home
				 * directory). */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled with
				 * name after tilde substitution. */
{
    Tcl_Obj *path = Tcl_NewStringObj(name, -1);
    Tcl_Obj *transPtr;

    Tcl_IncrRefCount(path);
    transPtr = Tcl_FSGetTranslatedPath(interp, path);
    if (transPtr == NULL) {
	Tcl_DecrRefCount(path);
	return NULL;
    }

    Tcl_DStringInit(bufferPtr);
    Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
    Tcl_DecrRefCount(path);
    Tcl_DecrRefCount(transPtr);

    /*
     * Convert forward slashes to backslashes in Windows paths because some
     * system interfaces don't accept forward slashes.
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	register char *p;
	for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
	    if (*p == '/') {
		*p = '\\';
	    }
	}
    }

    return Tcl_DStringValue(bufferPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetExtension --
 *
 *	This function returns a pointer to the beginning of the extension part
 *	of a file name.
 *
 * Results:
 *	Returns a pointer into name which indicates where the extension
 *	starts.  If there is no extension, returns NULL.
 *
 * Side effects:
 *	None.
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
 * DoTildeSubst --
 *
 *	Given a string following a tilde, this routine returns the
 *	corresponding home directory.
 *
 * Results:
 *	The result is a pointer to a static string containing the home
 *	directory in native format.  If there was an error in processing
 *	the substitution, then an error message is left in the interp's
 *	result and the return value is NULL.  On success, the results
 *	are appended to resultPtr, and the contents of resultPtr are
 *	returned.
 *
 * Side effects:
 *	Information may be left in resultPtr.
 *
 *----------------------------------------------------------------------
 */

static CONST char *
DoTildeSubst(interp, user, resultPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error
				 * message (if necessary). */
    CONST char *user;		/* Name of user whose home directory should be
				 * substituted, or "" for current user. */
    Tcl_DString *resultPtr;	/* Initialized DString filled with name
				 * after tilde substitution. */
{
    CONST char *dir;

    if (*user == '\0') {
	Tcl_DString dirString;

	dir = TclGetEnv("HOME", &dirString);







|
|
|
|
<









|
|


|
|







1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087

1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
 * DoTildeSubst --
 *
 *	Given a string following a tilde, this routine returns the
 *	corresponding home directory.
 *
 * Results:
 *	The result is a pointer to a static string containing the home
 *	directory in native format. If there was an error in processing the
 *	substitution, then an error message is left in the interp's result and
 *	the return value is NULL. On success, the results are appended to
 *	resultPtr, and the contents of resultPtr are returned.

 *
 * Side effects:
 *	Information may be left in resultPtr.
 *
 *----------------------------------------------------------------------
 */

static CONST char *
DoTildeSubst(interp, user, resultPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error message
				 * (if necessary). */
    CONST char *user;		/* Name of user whose home directory should be
				 * substituted, or "" for current user. */
    Tcl_DString *resultPtr;	/* Initialized DString filled with name after
				 * tilde substitution. */
{
    CONST char *dir;

    if (*user == '\0') {
	Tcl_DString dirString;

	dir = TclGetEnv("HOME", &dirString);
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobObjCmd --
 *
 *	This procedure is invoked to process the "glob" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobObjCmd --
 *
 *	This procedure is invoked to process the "glob" Tcl command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112

1113
1114
1115
1116
1117
1118

1119
1120
1121
1122

1123
1124
1125
1126
1127
1128
1129
    typePtr = NULL;
    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		&index) != TCL_OK) {
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    if (string[0] == '-') {
		/*
		 * It looks like the command contains an option so signal
		 * an error
		 */

		return TCL_ERROR;
	    } else {
		/*
		 * This clearly isn't an option; assume it's the first
		 * glob pattern.  We must clear the error
		 */

		Tcl_ResetResult(interp);
		break;
	    }
	}

	switch (index) {
	case GLOB_NOCOMPLAIN:			/* -nocomplain */
	    globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
	    break;
	case GLOB_DIR:				/* -dir */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(







|
|

>



|
|

>




>







1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
    typePtr = NULL;
    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		&index) != TCL_OK) {
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    if (string[0] == '-') {
		/*
		 * It looks like the command contains an option so signal an
		 * error.
		 */

		return TCL_ERROR;
	    } else {
		/*
		 * This clearly isn't an option; assume it's the first glob
		 * pattern.  We must clear the error.
		 */

		Tcl_ResetResult(interp);
		break;
	    }
	}

	switch (index) {
	case GLOB_NOCOMPLAIN:			/* -nocomplain */
	    globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
	    break;
	case GLOB_DIR:				/* -dir */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
1174
1175
1176
1177
1178
1179
1180

1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201

1202
1203
1204
1205
1206
1207
1208
1209

1210
1211
1212
1213
1214
1215

1216

1217


1218

1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230

1231
1232
1233
1234

1235


1236
1237

1238
1239
1240
1241
1242
1243
1244

1245
1246
1247
1248


1249


1250
1251
1252
1253
1254
1255
1256
	    i++;
	    break;
	case GLOB_LAST:				/* -- */
	    i++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if (objc - i < 1) {
        Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
	return TCL_ERROR;
    }
    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
	Tcl_AppendResult(interp, 
		"\"-tails\" must be used with either ",
		"\"-directory\" or \"-path\"", NULL);
	return TCL_ERROR;
    }

    separators = NULL;		/* lint. */
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	separators = "/";
	break;
    case TCL_PLATFORM_WINDOWS:
	separators = "/\\:";
	break;
    }

    if (dir == PATH_GENERAL) {
	int pathlength;
	char *last;
	char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);

	/*
	 * Find the last path separator in the path
	 */

	last = first + pathlength;
	for (; last != first; last--) {
	    if (strchr(separators, *(last-1)) != NULL) {
		break;
	    }
	}

	if (last == first + pathlength) {

	    /* It's really a directory */


	    dir = PATH_DIR;

	} else {
	    Tcl_DString pref;
	    char *search, *find;
	    Tcl_DStringInit(&pref);
	    if (last == first) {
		/*
		 * The whole thing is a prefix.  This means we must
		 * remove any 'tails' flag too, since it is irrelevant
		 * now (the same effect will happen without it), but in
		 * particular its use in TclGlob requires a non-NULL
		 * pathOrDir.
		 */

		Tcl_DStringAppend(&pref, first, -1);
		globFlags &= ~TCL_GLOBMODE_TAILS;
		pathOrDir = NULL;
	    } else {

		/* Have to split off the end */


		Tcl_DStringAppend(&pref, last, first+pathlength-last);
		pathOrDir = Tcl_NewStringObj(first, last-first-1);

		/*
		 * We must ensure that we haven't cut off too much,
		 * and turned a valid path like '/' or 'C:/' into
		 * an incorrect path like '' or 'C:'.  The way we
		 * do this is to add a separator if there are none
		 * presently in the prefix.
		 */

		if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
		    Tcl_AppendToObj(pathOrDir, last-1, 1);
		}
	    }


	    /* Need to quote 'prefix' */


	    Tcl_DStringInit(&prefix);
	    search = Tcl_DStringValue(&pref);
	    while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
		Tcl_DStringAppend(&prefix, search, find-search);
		Tcl_DStringAppend(&prefix, "\\", 1);
		Tcl_DStringAppend(&prefix, find, 1);
		search = find+1;







>


|



|














>








>






>

>
|
>
>

>






|
|
|
|
<

>




>
|
>
>


>

|
|
<
|
|

>




>
>
|
>
>







1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311

1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327

1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
	    i++;
	    break;
	case GLOB_LAST:				/* -- */
	    i++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if (objc - i < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
	return TCL_ERROR;
    }
    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
	Tcl_AppendResult(interp,
		"\"-tails\" must be used with either ",
		"\"-directory\" or \"-path\"", NULL);
	return TCL_ERROR;
    }

    separators = NULL;		/* lint. */
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	separators = "/";
	break;
    case TCL_PLATFORM_WINDOWS:
	separators = "/\\:";
	break;
    }

    if (dir == PATH_GENERAL) {
	int pathlength;
	char *last;
	char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);

	/*
	 * Find the last path separator in the path
	 */

	last = first + pathlength;
	for (; last != first; last--) {
	    if (strchr(separators, *(last-1)) != NULL) {
		break;
	    }
	}

	if (last == first + pathlength) {
	    /*
	     * It's really a directory.
	     */

	    dir = PATH_DIR;

	} else {
	    Tcl_DString pref;
	    char *search, *find;
	    Tcl_DStringInit(&pref);
	    if (last == first) {
		/*
		 * The whole thing is a prefix.  This means we must remove any
		 * 'tails' flag too, since it is irrelevant now (the same
		 * effect will happen without it), but in particular its use
		 * in TclGlob requires a non-NULL pathOrDir.

		 */

		Tcl_DStringAppend(&pref, first, -1);
		globFlags &= ~TCL_GLOBMODE_TAILS;
		pathOrDir = NULL;
	    } else {
		/*
		 * Have to split off the end.
		 */

		Tcl_DStringAppend(&pref, last, first+pathlength-last);
		pathOrDir = Tcl_NewStringObj(first, last-first-1);

		/*
		 * We must ensure that we haven't cut off too much, and turned
		 * a valid path like '/' or 'C:/' into an incorrect path like

		 * '' or 'C:'.  The way we do this is to add a separator if
		 * there are none presently in the prefix.
		 */

		if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
		    Tcl_AppendToObj(pathOrDir, last-1, 1);
		}
	    }

	    /*
	     * Need to quote 'prefix'.
	     */

	    Tcl_DStringInit(&prefix);
	    search = Tcl_DStringValue(&pref);
	    while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
		Tcl_DStringAppend(&prefix, search, find-search);
		Tcl_DStringAppend(&prefix, "\\", 1);
		Tcl_DStringAppend(&prefix, find, 1);
		search = find+1;
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277

1278
1279
1280
1281
1282
1283

1284
1285
1286

1287
1288
1289
1290
1291
1292
1293

    if (pathOrDir != NULL) {
	Tcl_IncrRefCount(pathOrDir);
    }

    if (typePtr != NULL) {
	/*
	 * The rest of the possible type arguments (except 'd') are
	 * platform specific.  We don't complain when they are used
	 * on an incompatible platform.
	 */

	Tcl_ListObjLength(interp, typePtr, &length);
	globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
	globTypes->type = 0;
	globTypes->perm = 0;
	globTypes->macType = NULL;
	globTypes->macCreator = NULL;

	while (--length >= 0) {
	    int len;
	    char *str;

	    Tcl_ListObjIndex(interp, typePtr, length, &look);
	    str = Tcl_GetStringFromObj(look, &len);
	    if (strcmp("readonly", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_RONLY;
	    } else if (strcmp("hidden", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
	    } else if (len == 1) {







|
|
|

>






>



>







1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387

    if (pathOrDir != NULL) {
	Tcl_IncrRefCount(pathOrDir);
    }

    if (typePtr != NULL) {
	/*
	 * The rest of the possible type arguments (except 'd') are platform
	 * specific.  We don't complain when they are used on an incompatible
	 * platform.
	 */

	Tcl_ListObjLength(interp, typePtr, &length);
	globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
	globTypes->type = 0;
	globTypes->perm = 0;
	globTypes->macType = NULL;
	globTypes->macCreator = NULL;

	while (--length >= 0) {
	    int len;
	    char *str;

	    Tcl_ListObjIndex(interp, typePtr, length, &look);
	    str = Tcl_GetStringFromObj(look, &len);
	    if (strcmp("readonly", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_RONLY;
	    } else if (strcmp("hidden", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
	    } else if (len == 1) {
1321
1322
1323
1324
1325
1326
1327

1328

1329


1330
1331
1332
1333
1334

1335
1336

1337
1338
1339
1340
1341
1342
1343
		    break;
		case 's':
		    globTypes->type |= TCL_GLOB_TYPE_SOCK;
		    break;
		default:
		    goto badTypesArg;
		}

	    } else if (len == 4) {

		/* This is assumed to be a MacOS file type */


		if (globTypes->macType != NULL) {
		    goto badMacTypesArg;
		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);

	    } else {
		Tcl_Obj* item;

		if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
			(len == 3)) {
		    Tcl_ListObjIndex(interp, look, 0, &item);
		    if (!strcmp("macintosh", Tcl_GetString(item))) {
			Tcl_ListObjIndex(interp, look, 1, &item);
			if (!strcmp("type", Tcl_GetString(item))) {
			    Tcl_ListObjIndex(interp, look, 2, &item);







>

>
|
>
>





>


>







1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
		    break;
		case 's':
		    globTypes->type |= TCL_GLOB_TYPE_SOCK;
		    break;
		default:
		    goto badTypesArg;
		}

	    } else if (len == 4) {
		/*
		 * This is assumed to be a MacOS file type.
		 */

		if (globTypes->macType != NULL) {
		    goto badMacTypesArg;
		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);

	    } else {
		Tcl_Obj* item;

		if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
			(len == 3)) {
		    Tcl_ListObjIndex(interp, look, 0, &item);
		    if (!strcmp("macintosh", Tcl_GetString(item))) {
			Tcl_ListObjIndex(interp, look, 1, &item);
			if (!strcmp("type", Tcl_GetString(item))) {
			    Tcl_ListObjIndex(interp, look, 2, &item);
1354
1355
1356
1357
1358
1359
1360

1361
1362
1363
1364
1365

1366
1367
1368
1369
1370
1371
1372
1373

1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390

1391
1392
1393

1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412

1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442

1443


1444
1445
1446

1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464

1465
1466
1467
1468
1469
1470
1471
			    }
			    globTypes->macCreator = item;
			    Tcl_IncrRefCount(item);
			    continue;
			}
		    }
		}

		/*
		 * Error cases.  We reset
		 * the 'join' flag to zero, since we haven't yet
		 * made use of it.
		 */

	      badTypesArg:
		TclNewObj(resultPtr);
		Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
		Tcl_AppendObjToObj(resultPtr, look);
		Tcl_SetObjResult(interp, resultPtr);
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;

	      badMacTypesArg:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"only one MacOS type or creator argument"
			" to \"-types\" allowed", -1));
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;
	    }
	}
    }

    /*
     * Now we perform the actual glob below.  This may involve joining
     * together the pattern arguments, dealing with particular file types
     * etc.  We use a 'goto' to ensure we free any memory allocated along
     * the way.
     */

    objc -= i;
    objv += i;
    result = TCL_OK;

    if (join) {
	if (dir != PATH_GENERAL) {
	    Tcl_DStringInit(&prefix);
	}
	for (i = 0; i < objc; i++) {
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    Tcl_DStringAppend(&prefix, string, length);
	    if (i != objc -1) {
		Tcl_DStringAppend(&prefix, separators, 1);
	    }
	}
	if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir,
		globFlags, globTypes) != TCL_OK) {
	    result = TCL_ERROR;
	    goto endOfGlob;
	}
    } else {
	if (dir == PATH_GENERAL) {
	    Tcl_DString str;

	    for (i = 0; i < objc; i++) {
		Tcl_DStringInit(&str);
		if (dir == PATH_GENERAL) {
		    Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
			    Tcl_DStringLength(&prefix));
		}
		string = Tcl_GetStringFromObj(objv[i], &length);
		Tcl_DStringAppend(&str, string, length);
		if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir,
			globFlags, globTypes) != TCL_OK) {
		    result = TCL_ERROR;
		    Tcl_DStringFree(&str);
		    goto endOfGlob;
		}
	    }
	    Tcl_DStringFree(&str);
	} else {
	    for (i = 0; i < objc; i++) {
		string = Tcl_GetString(objv[i]);
		if (TclGlob(interp, string, pathOrDir,
			globFlags, globTypes) != TCL_OK) {
		    result = TCL_ERROR;
		    goto endOfGlob;
		}
	    }
	}
    }
    if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
	if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
		&length) != TCL_OK) {

	    /* This should never happen.  Maybe we should be more dramatic */


	    result = TCL_ERROR;
	    goto endOfGlob;
	}

	if (length == 0) {
	    Tcl_AppendResult(interp, "no files matched glob pattern",
		    (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL);
	    if (join) {
		Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
			(char *) NULL);
	    } else {
		char *sep = "";
		for (i = 0; i < objc; i++) {
		    string = Tcl_GetString(objv[i]);
		    Tcl_AppendResult(interp, sep, string, (char *) NULL);
		    sep = " ";
		}
	    }
	    Tcl_AppendResult(interp, "\"", (char *) NULL);
	    result = TCL_ERROR;
	}
    }

  endOfGlob:
    if (join || (dir == PATH_GENERAL)) {
	Tcl_DStringFree(&prefix);
    }
    if (pathOrDir != NULL) {
	Tcl_DecrRefCount(pathOrDir);
    }







>

|
<
|

>
|







>
|











|
|
|
<

>



>











|
|



<
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



>
|
>
>



>


















>







1454
1455
1456
1457
1458
1459
1460
1461
1462
1463

1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490

1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512

1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
			    }
			    globTypes->macCreator = item;
			    Tcl_IncrRefCount(item);
			    continue;
			}
		    }
		}

		/*
		 * Error cases.  We reset the 'join' flag to zero, since we

		 * haven't yet made use of it.
		 */

	    badTypesArg:
		TclNewObj(resultPtr);
		Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
		Tcl_AppendObjToObj(resultPtr, look);
		Tcl_SetObjResult(interp, resultPtr);
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;

	    badMacTypesArg:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"only one MacOS type or creator argument"
			" to \"-types\" allowed", -1));
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;
	    }
	}
    }

    /*
     * Now we perform the actual glob below. This may involve joining together
     * the pattern arguments, dealing with particular file types etc. We use a
     * 'goto' to ensure we free any memory allocated along the way.

     */

    objc -= i;
    objv += i;
    result = TCL_OK;

    if (join) {
	if (dir != PATH_GENERAL) {
	    Tcl_DStringInit(&prefix);
	}
	for (i = 0; i < objc; i++) {
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    Tcl_DStringAppend(&prefix, string, length);
	    if (i != objc -1) {
		Tcl_DStringAppend(&prefix, separators, 1);
	    }
	}
	if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags,
		globTypes) != TCL_OK) {
	    result = TCL_ERROR;
	    goto endOfGlob;
	}

    } else if (dir == PATH_GENERAL) {
	Tcl_DString str;

	for (i = 0; i < objc; i++) {
	    Tcl_DStringInit(&str);
	    if (dir == PATH_GENERAL) {
		Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
			Tcl_DStringLength(&prefix));
	    }
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    Tcl_DStringAppend(&str, string, length);
	    if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags,
		    globTypes) != TCL_OK) {
		result = TCL_ERROR;
		Tcl_DStringFree(&str);
		goto endOfGlob;
	    }
	}
	Tcl_DStringFree(&str);
    } else {
	for (i = 0; i < objc; i++) {
	    string = Tcl_GetString(objv[i]);
	    if (TclGlob(interp, string, pathOrDir, globFlags,
		    globTypes) != TCL_OK) {
		result = TCL_ERROR;
		goto endOfGlob;
	    }
	}
    }

    if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
	if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
		&length) != TCL_OK) {
	    /*
	     * This should never happen.  Maybe we should be more dramatic.
	     */

	    result = TCL_ERROR;
	    goto endOfGlob;
	}

	if (length == 0) {
	    Tcl_AppendResult(interp, "no files matched glob pattern",
		    (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL);
	    if (join) {
		Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
			(char *) NULL);
	    } else {
		char *sep = "";
		for (i = 0; i < objc; i++) {
		    string = Tcl_GetString(objv[i]);
		    Tcl_AppendResult(interp, sep, string, (char *) NULL);
		    sep = " ";
		}
	    }
	    Tcl_AppendResult(interp, "\"", (char *) NULL);
	    result = TCL_ERROR;
	}
    }

  endOfGlob:
    if (join || (dir == PATH_GENERAL)) {
	Tcl_DStringFree(&prefix);
    }
    if (pathOrDir != NULL) {
	Tcl_DecrRefCount(pathOrDir);
    }
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
}

/*
 *----------------------------------------------------------------------
 *
 * TclGlob --
 *
 *	This procedure prepares arguments for the DoGlob call.
 *	It sets the separator string based on the platform, performs
 *      tilde substitution, and calls DoGlob.
 *
 *      The interpreter's result, on entry to this function, must
 *      be a valid Tcl list (e.g. it could be empty), since we will
 *      lappend any new results to that list.  If it is not a valid
 *      list, this function will fail to do anything very meaningful.
 *
 *      Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then
 *      pathPrefix cannot be NULL (it is only allowed with -dir or
 *      -path).
 *
 * Results:
 *	The return value is a standard Tcl result indicating whether
 *	an error occurred in globbing.  After a normal return the
 *	result in interp (set by DoGlob) holds all of the file names
 *	given by the pattern and pathPrefix arguments.  After an
 *	error the result in interp will hold an error message, unless
 *	the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
 *	an error results in a TCL_OK return leaving the interpreter's
 *	result unmodified.
 *
 * Side effects:
 *	The 'pattern' is written to.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
TclGlob(interp, pattern, pathPrefix, globFlags, types)
    Tcl_Interp *interp;		/* Interpreter for returning error message
				 * or appending list of matching file names. */
    char *pattern;		/* Glob pattern to match. Must not refer
				 * to a static string. */
    Tcl_Obj *pathPrefix;	/* Path prefix to glob pattern, if non-null,
                        	 * which is considered literally. */
    int globFlags;		/* Stores or'ed combination of flags */
    Tcl_GlobTypeData *types;	/* Struct containing acceptable types.
				 * May be NULL. */
{
    char *separators;
    CONST char *head;
    char *tail, *start;
    int result;
    Tcl_Obj *filenamesObj, *savedResultObj;








|
|
|

|
|
|
|

|
|
<


|
|
|
<
|
|
|
|










|
|
|
|

|

|
|







1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607

1608
1609
1610
1611
1612

1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
}

/*
 *----------------------------------------------------------------------
 *
 * TclGlob --
 *
 *	This procedure prepares arguments for the DoGlob call.  It sets the
 *	separator string based on the platform, performs * tilde substitution,
 *	and calls DoGlob.
 *
 *	The interpreter's result, on entry to this function, must be a valid
 *	Tcl list (e.g. it could be empty), since we will lappend any new
 *	results to that list.  If it is not a valid list, this function will
 *	fail to do anything very meaningful.
 *
 *	Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix
 *	cannot be NULL (it is only allowed with -dir or -path).

 *
 * Results:
 *	The return value is a standard Tcl result indicating whether an error
 *	occurred in globbing.  After a normal return the result in interp (set
 *	by DoGlob) holds all of the file names given by the pattern and

 *	pathPrefix arguments.  After an error the result in interp will hold
 *	an error message, unless the 'TCL_GLOBMODE_NO_COMPLAIN' flag was
 *	given, in which case an error results in a TCL_OK return leaving the
 *	interpreter's result unmodified.
 *
 * Side effects:
 *	The 'pattern' is written to.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
TclGlob(interp, pattern, pathPrefix, globFlags, types)
    Tcl_Interp *interp;		/* Interpreter for returning error message or
				 * appending list of matching file names. */
    char *pattern;		/* Glob pattern to match. Must not refer to a
				 * static string. */
    Tcl_Obj *pathPrefix;	/* Path prefix to glob pattern, if non-null,
				 * which is considered literally. */
    int globFlags;		/* Stores or'ed combination of flags */
    Tcl_GlobTypeData *types;	/* Struct containing acceptable types.  May be
				 * NULL. */
{
    char *separators;
    CONST char *head;
    char *tail, *start;
    int result;
    Tcl_Obj *filenamesObj, *savedResultObj;

1546
1547
1548
1549
1550
1551
1552

1553
1554
1555
1556
1557
1558
1559
1560
1561

1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629

    if (pathPrefix == NULL) {
	char c;
	Tcl_DString buffer;
	Tcl_DStringInit(&buffer);

	start = pattern;

	/*
	 * Perform tilde substitution, if needed.
	 */

	if (start[0] == '~') {

	    /*
	     * Find the first path separator after the tilde.
	     */

	    for (tail = start; *tail != '\0'; tail++) {
		if (*tail == '\\') {
		    if (strchr(separators, tail[1]) != NULL) {
			break;
		    }
		} else if (strchr(separators, *tail) != NULL) {
		    break;
		}
	    }

	    /*
	     * Determine the home directory for the specified user.
	     */

	    c = *tail;
	    *tail = '\0';
	    if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
		/*
		 * We will ignore any error message here, and we
		 * don't want to mess up the interpreter's result.
		 */
		head = DoTildeSubst(NULL, start+1, &buffer);
	    } else {
		head = DoTildeSubst(interp, start+1, &buffer);
	    }
	    *tail = c;
	    if (head == NULL) {
		if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
		    return TCL_OK;
		} else {
		    return TCL_ERROR;
		}
	    }
	    if (head != Tcl_DStringValue(&buffer)) {
		Tcl_DStringAppend(&buffer, head, -1);
	    }
	    pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
					  Tcl_DStringLength(&buffer));
	    Tcl_IncrRefCount(pathPrefix);
	    globFlags |= TCL_GLOBMODE_DIR;
	    if (c != '\0') {
		tail++;
	    }
	    Tcl_DStringFree(&buffer);
	} else {
	    tail = pattern;
	}
    } else {
	Tcl_IncrRefCount(pathPrefix);
	tail = pattern;
    }

    /*
     * Handling empty path prefixes with glob patterns like 'C:' or
     * 'c:////////' is a pain on Windows if we leave it too late, since
     * these aren't really patterns at all!  We therefore check the head
     * of the pattern now for such cases, if we don't have an unquoted
     * prefix yet.
     *
     * Similarly on Unix with '/' at the head of the pattern -- it
     * just indicates the root volume, so we treat it as such.
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	if (pathPrefix == NULL && tail[0] != '\0' && tail[1] == ':') {
	    char *p = tail + 1;
	    pathPrefix = Tcl_NewStringObj(tail, 1);
	    while (*p != '\0') {







>





<



>


















|
|

















|
















|
|
|
<

|
|







1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664

1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725

1726
1727
1728
1729
1730
1731
1732
1733
1734
1735

    if (pathPrefix == NULL) {
	char c;
	Tcl_DString buffer;
	Tcl_DStringInit(&buffer);

	start = pattern;

	/*
	 * Perform tilde substitution, if needed.
	 */

	if (start[0] == '~') {

	    /*
	     * Find the first path separator after the tilde.
	     */

	    for (tail = start; *tail != '\0'; tail++) {
		if (*tail == '\\') {
		    if (strchr(separators, tail[1]) != NULL) {
			break;
		    }
		} else if (strchr(separators, *tail) != NULL) {
		    break;
		}
	    }

	    /*
	     * Determine the home directory for the specified user.
	     */

	    c = *tail;
	    *tail = '\0';
	    if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
		/*
		 * We will ignore any error message here, and we don't want to
		 * mess up the interpreter's result.
		 */
		head = DoTildeSubst(NULL, start+1, &buffer);
	    } else {
		head = DoTildeSubst(interp, start+1, &buffer);
	    }
	    *tail = c;
	    if (head == NULL) {
		if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
		    return TCL_OK;
		} else {
		    return TCL_ERROR;
		}
	    }
	    if (head != Tcl_DStringValue(&buffer)) {
		Tcl_DStringAppend(&buffer, head, -1);
	    }
	    pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
		    Tcl_DStringLength(&buffer));
	    Tcl_IncrRefCount(pathPrefix);
	    globFlags |= TCL_GLOBMODE_DIR;
	    if (c != '\0') {
		tail++;
	    }
	    Tcl_DStringFree(&buffer);
	} else {
	    tail = pattern;
	}
    } else {
	Tcl_IncrRefCount(pathPrefix);
	tail = pattern;
    }

    /*
     * Handling empty path prefixes with glob patterns like 'C:' or
     * 'c:////////' is a pain on Windows if we leave it too late, since these
     * aren't really patterns at all!  We therefore check the head of the
     * pattern now for such cases, if we don't have an unquoted prefix yet.

     *
     * Similarly on Unix with '/' at the head of the pattern -- it just
     * indicates the root volume, so we treat it as such.
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	if (pathPrefix == NULL && tail[0] != '\0' && tail[1] == ':') {
	    char *p = tail + 1;
	    pathPrefix = Tcl_NewStringObj(tail, 1);
	    while (*p != '\0') {
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665

1666
1667
1668
1669
1670
1671
1672
		}
		p++;
	    }
	    tail = p;
	    Tcl_IncrRefCount(pathPrefix);
	} else if (pathPrefix == NULL && (tail[0] == '/'
		|| (tail[0] == '\\' && tail[1] == '\\'))) {
            int driveNameLen;
            Tcl_Obj *driveName;
            Tcl_Obj *temp = Tcl_NewStringObj(tail, -1);
            Tcl_IncrRefCount(temp);

            switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) {
	    case TCL_PATH_VOLUME_RELATIVE: {
		/*
		 * Volume relative path which is equivalent to a path in
		 * the root of the cwd's volume.  We will actually return
		 * non-volume-relative paths here. i.e. 'glob /foo*' will
		 * return 'C:/foobar'.  This is much the same as globbing
		 * for a path with '\\' will return one with '/' on Windows.
		 */

		Tcl_Obj *cwd = Tcl_FSGetCwd(interp);

		if (cwd == NULL) {
		    Tcl_DecrRefCount(temp);
		    if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
			return TCL_OK;
		    } else {







|
|
|
|

|


|
|

|
|

>







1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
		}
		p++;
	    }
	    tail = p;
	    Tcl_IncrRefCount(pathPrefix);
	} else if (pathPrefix == NULL && (tail[0] == '/'
		|| (tail[0] == '\\' && tail[1] == '\\'))) {
	    int driveNameLen;
	    Tcl_Obj *driveName;
	    Tcl_Obj *temp = Tcl_NewStringObj(tail, -1);
	    Tcl_IncrRefCount(temp);

	    switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) {
	    case TCL_PATH_VOLUME_RELATIVE: {
		/*
		 * Volume relative path which is equivalent to a path in the
		 * root of the cwd's volume.  We will actually return
		 * non-volume-relative paths here. i.e. 'glob /foo*' will
		 * return 'C:/foobar'.  This is much the same as globbing for
		 * a path with '\\' will return one with '/' on Windows.
		 */

		Tcl_Obj *cwd = Tcl_FSGetCwd(interp);

		if (cwd == NULL) {
		    Tcl_DecrRefCount(temp);
		    if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
			return TCL_OK;
		    } else {
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691

1692
1693
1694
1695
1696
1697
1698
1699
1700

1701
1702
1703
1704

1705

1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
		    tail+=2;
		}
		Tcl_IncrRefCount(pathPrefix);
		break;
	    }
	    case TCL_PATH_ABSOLUTE:
		/*
		 * Absolute, possibly network path //Machine/Share.
		 * Use that as the path prefix (it already has a
		 * refCount).
		 */

		pathPrefix = driveName;
		tail += driveNameLen;
		break;
	    case TCL_PATH_RELATIVE:
		/* Do nothing */
		break;
            }
            Tcl_DecrRefCount(temp);
	}

	/*
	 * ':' no longer needed as a separator. It is only relevant
	 * to the beginning of the path.
	 */

	separators = "/\\";

    } else if (tclPlatform == TCL_PLATFORM_UNIX) {
	if (pathPrefix == NULL && tail[0] == '/') {
	    pathPrefix = Tcl_NewStringObj(tail, 1);
	    tail++;
	    Tcl_IncrRefCount(pathPrefix);
	}
    }

    /*
     * Finally if we still haven't managed to generate a path
     * prefix, check if the path starts with a current volume.
     */

    if (pathPrefix == NULL) {
	int driveNameLen;
	Tcl_Obj *driveName;
	if (TclFSNonnativePathType(tail, (int) strlen(tail), NULL,
		&driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) {
	    pathPrefix = driveName;
	    tail += driveNameLen;
	}
    }

    /*
     * To process a [glob] invokation, this function may be called
     * multiple times. Each time, the previously discovered filenames
     * are in the interpreter result. We stash that away here so the
     * result is free for error messsages.
     */

    savedResultObj = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(savedResultObj);
    Tcl_ResetResult(interp);
    TclNewObj(filenamesObj);

    /*
     * Now we do the actual globbing, adding filenames as we go to
     * buffer in filenamesObj
     */

    if (*tail == '\0' && pathPrefix != NULL) {
	/*
	 * An empty pattern
	 */
	result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix,







|
|
<

>






|
|

>

|
|

>

>









|
|













|
|
|
|








|
|







1788
1789
1790
1791
1792
1793
1794
1795
1796

1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
		    tail+=2;
		}
		Tcl_IncrRefCount(pathPrefix);
		break;
	    }
	    case TCL_PATH_ABSOLUTE:
		/*
		 * Absolute, possibly network path //Machine/Share. Use that
		 * as the path prefix (it already has a refCount).

		 */

		pathPrefix = driveName;
		tail += driveNameLen;
		break;
	    case TCL_PATH_RELATIVE:
		/* Do nothing */
		break;
	    }
	    Tcl_DecrRefCount(temp);
	}

	/*
	 * ':' no longer needed as a separator. It is only relevant to the
	 * beginning of the path.
	 */

	separators = "/\\";

    } else if (tclPlatform == TCL_PLATFORM_UNIX) {
	if (pathPrefix == NULL && tail[0] == '/') {
	    pathPrefix = Tcl_NewStringObj(tail, 1);
	    tail++;
	    Tcl_IncrRefCount(pathPrefix);
	}
    }

    /*
     * Finally if we still haven't managed to generate a path prefix, check if
     * the path starts with a current volume.
     */

    if (pathPrefix == NULL) {
	int driveNameLen;
	Tcl_Obj *driveName;
	if (TclFSNonnativePathType(tail, (int) strlen(tail), NULL,
		&driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) {
	    pathPrefix = driveName;
	    tail += driveNameLen;
	}
    }

    /*
     * To process a [glob] invokation, this function may be called multiple
     * times. Each time, the previously discovered filenames are in the
     * interpreter result. We stash that away here so the result is free for
     * error messsages.
     */

    savedResultObj = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(savedResultObj);
    Tcl_ResetResult(interp);
    TclNewObj(filenamesObj);

    /*
     * Now we do the actual globbing, adding filenames as we go to buffer in
     * filenamesObj
     */

    if (*tail == '\0' && pathPrefix != NULL) {
	/*
	 * An empty pattern
	 */
	result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix,
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788

1789


1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
	    result = TCL_OK;
	}
	TclDecrRefCount(savedResultObj);
	return result;
    }

    /*
     * If we only want the tails, we must strip off the prefix now.
     * It may seem more efficient to pass the tails flag down into
     * DoGlob, Tcl_FSMatchInDirectory, but those functions are
     * continually adjusting the prefix as the various pieces of
     * the pattern are assimilated, so that would add a lot of
     * complexity to the code.  This way is a little slower (when
     * the -tails flag is given), but much simpler to code.
     *
     * We do it by rewriting the result list in-place.
     */

    if (globFlags & TCL_GLOBMODE_TAILS) {
	int objc, i;
	Tcl_Obj **objv;
	int prefixLen;


	/* If this length has never been set, set it here */


	CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
	if (prefixLen > 0 
	  && (strchr(separators, pre[prefixLen-1]) == NULL)) {
	      
	    /* 
	     * If we're on Windows and the prefix is a volume
	     * relative one like 'C:', then there won't be
	     * a path separator in between, so no need to
	     * skip it here.
	     */
	    
	    if ((tclPlatform != TCL_PLATFORM_WINDOWS) 
		|| (prefixLen != 2) 
		|| (pre[1] != ':')) {
		prefixLen++;
	    }
	}

	Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
	for (i = 0; i< objc; i++) {
	    int len;
	    char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
	    Tcl_Obj* elems[1];

	    if (len == prefixLen) {
		if ((pattern[0] == '\0')
			|| (strchr(separators, pattern[0]) == NULL)) {
		    elems[0] = Tcl_NewStringObj(".", 1);
		} else {
		    elems[0] = Tcl_NewStringObj("/", 1);
		}
	    } else {
		elems[0] = Tcl_NewStringObj(oldStr + prefixLen,
			len - prefixLen);
	    }
	    Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems);
	}
    }

    /*
     * Now we have a list of discovered filenames in filenamesObj and
     * a list of previously discovered (saved earlier from the
     * interpreter result) in savedResultObj. Merge them and put them
     * back in the interpreter result.
     */

    if (Tcl_IsShared(savedResultObj)) {
	TclDecrRefCount(savedResultObj);
	savedResultObj = Tcl_DuplicateObj(savedResultObj);
	Tcl_IncrRefCount(savedResultObj);
    }







|
|
|
|
<
|
|









>
|
>
>

|
|
<
|
|
|
<
|

|
|
<
|


















|
<






|
|
|
<







1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886

1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904

1905
1906
1907

1908
1909
1910
1911

1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931

1932
1933
1934
1935
1936
1937
1938
1939
1940

1941
1942
1943
1944
1945
1946
1947
	    result = TCL_OK;
	}
	TclDecrRefCount(savedResultObj);
	return result;
    }

    /*
     * If we only want the tails, we must strip off the prefix now.  It may
     * seem more efficient to pass the tails flag down into DoGlob,
     * Tcl_FSMatchInDirectory, but those functions are continually adjusting
     * the prefix as the various pieces of the pattern are assimilated, so

     * that would add a lot of complexity to the code.  This way is a little
     * slower (when the -tails flag is given), but much simpler to code.
     *
     * We do it by rewriting the result list in-place.
     */

    if (globFlags & TCL_GLOBMODE_TAILS) {
	int objc, i;
	Tcl_Obj **objv;
	int prefixLen;

	/*
	 * If this length has never been set, set it here.
	 */

	CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
	if (prefixLen > 0
		&& (strchr(separators, pre[prefixLen-1]) == NULL)) {

	    /*
	     * If we're on Windows and the prefix is a volume relative one
	     * like 'C:', then there won't be a path separator in between, so

	     * no need to skip it here.
	     */

	    if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2)

		    || (pre[1] != ':')) {
		prefixLen++;
	    }
	}

	Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
	for (i = 0; i< objc; i++) {
	    int len;
	    char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
	    Tcl_Obj* elems[1];

	    if (len == prefixLen) {
		if ((pattern[0] == '\0')
			|| (strchr(separators, pattern[0]) == NULL)) {
		    elems[0] = Tcl_NewStringObj(".", 1);
		} else {
		    elems[0] = Tcl_NewStringObj("/", 1);
		}
	    } else {
		elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);

	    }
	    Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems);
	}
    }

    /*
     * Now we have a list of discovered filenames in filenamesObj and a list
     * of previously discovered (saved earlier from the interpreter result) in
     * savedResultObj. Merge them and put them back in the interpreter result.

     */

    if (Tcl_IsShared(savedResultObj)) {
	TclDecrRefCount(savedResultObj);
	savedResultObj = Tcl_DuplicateObj(savedResultObj);
	Tcl_IncrRefCount(savedResultObj);
    }
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
}

/*
 *----------------------------------------------------------------------
 *
 * SkipToChar --
 *
 *	This function traverses a glob pattern looking for the next
 *	unquoted occurance of the specified character at the same braces
 *	nesting level.
 *
 * Results:
 *	Updates stringPtr to point to the matching character, or to
 *	the end of the string if nothing matched.  The return value
 *	is 1 if a match was found at the top level, otherwise it is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
<


|
|
|







1957
1958
1959
1960
1961
1962
1963
1964
1965

1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
}

/*
 *----------------------------------------------------------------------
 *
 * SkipToChar --
 *
 *	This function traverses a glob pattern looking for the next unquoted
 *	occurance of the specified character at the same braces nesting level.

 *
 * Results:
 *	Updates stringPtr to point to the matching character, or to the end of
 *	the string if nothing matched.  The return value is 1 if a match was
 *	found at the top level, otherwise it is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971

1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993

1994
1995
1996
1997
1998
1999

2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052

2053
2054
2055

2056

2057
2058

2059

2060

2061

2062
2063
2064
2065

2066


2067
2068
2069
2070
2071
2072

2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
}

/*
 *----------------------------------------------------------------------
 *
 * DoGlob --
 *
 *	This recursive procedure forms the heart of the globbing code.
 *	It performs a depth-first traversal of the tree given by the
 *	path name to be globbed and the pattern.  The directory and
 *	remainder are assumed to be native format paths.  The prefix
 *	contained in 'pathPtr' is either a directory or path from which
 *	to start the search (or NULL).  If pathPtr is NULL, then the
 *	pattern must not start with an absolute path specification
 *	(that case should be handled by moving the absolute path
 *	prefix into pathPtr before calling DoGlob).
 *
 * Results:
 *	The return value is a standard Tcl result indicating whether
 *	an error occurred in globbing.  After a normal return the
 *	result in interp will be set to hold all of the file names
 *	given by the dir and remaining arguments.  After an error the
 *	result in interp will hold an error message.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting
				 * (e.g. unmatched brace). */
    Tcl_Obj *matchesObj;		/* Unshared list object in which to place all
				 * resulting filenames. Caller allocates and
				 * deallocates; DoGlob must not touch the
				 * refCount of this object. */
    char *separators;		/* String containing separator characters
				 * that should be used to identify globbing
				 * boundaries. */
    Tcl_Obj *pathPtr;	        /* Completely expanded prefix. */
    int flags;                  /* If non-zero then pathPtr is a
                                 * directory */
    char *pattern;		/* The pattern to match against.
				 * Must not be a pointer to a static string. */
    Tcl_GlobTypeData *types;	/* List object containing list of acceptable
				 * types. May be NULL. */
{
    int baseLength, quoted, count;
    int result = TCL_OK;
    char *name, *p, *openBrace, *closeBrace, *firstSpecialChar;
    Tcl_Obj *joinedPtr;

    /*
     * Consume any leading directory separators, leaving pattern pointing
     * just past the last initial separator.
     */

    count = 0;
    name = pattern;
    for (; *pattern != '\0'; pattern++) {
	if (*pattern == '\\') {
	    /*
	     * If the first character is escaped, either we have a directory
	     * separator, or we have any other character.  In the latter case
	     * the rest is a pattern, and we must break from the loop.
	     * This is particularly important on Windows where '\' is both
	     * the escaping character and a directory separator.
	     */

	    if (strchr(separators, pattern[1]) != NULL) {
		pattern++;
	    } else {
		break;
	    }
	} else if (strchr(separators, *pattern) == NULL) {
	    break;
	}
	count++;
    }

    /*
     * This block of code is not exercised by the Tcl test suite as of
     * Tcl 8.5a0.  Simplifications to the calling paths suggest it may
     * not be necessary any more, since path separators are handled
     * elsewhere.  It is left in place in case new bugs are reported
     */

#if 0 /* PROBABLY_OBSOLETE */
    /*
     * Deal with path separators.
     */

    if (pathPtr == NULL) {
	/*
	 * Length used to be the length of the prefix, and lastChar
	 * the lastChar of the prefix.  But, none of this is used
	 * any more.
	 */

	int length = 0;
	char lastChar = 0;

	switch (tclPlatform) {
	case TCL_PLATFORM_WINDOWS:
	    /*
	     * If this is a drive relative path, add the colon and the
	     * trailing slash if needed.  Otherwise add the slash if
	     * this is the first absolute element, or a later relative
	     * element.  Add an extra slash if this is a UNC path.
	     */

	    if (*name == ':') {
		Tcl_DStringAppend(&append, ":", 1);
		if (count > 1) {
		    Tcl_DStringAppend(&append, "/", 1);
		}
	    } else if ((*pattern != '\0') && (((length > 0)
		    && (strchr(separators, lastChar) == NULL))
		    || ((length == 0) && (count > 0)))) {
		Tcl_DStringAppend(&append, "/", 1);
		if ((length == 0) && (count > 1)) {
		    Tcl_DStringAppend(&append, "/", 1);
		}
	    }

	    break;
	case TCL_PLATFORM_UNIX:
	    /*
	     * Add a separator if this is the first absolute element, or
	     * a later relative element.
	     */

	    if ((*pattern != '\0') && (((length > 0)
		    && (strchr(separators, lastChar) == NULL))
		    || ((length == 0) && (count > 0)))) {
		Tcl_DStringAppend(&append, "/", 1);
	    }
	    break;
	}
    }
#endif /* PROBABLY_OBSOLETE */

    /*
     * Look for the first matching pair of braces or the first
     * directory separator that is not inside a pair of braces.
     */

    openBrace = closeBrace = NULL;
    quoted = 0;
    for (p = pattern; *p != '\0'; p++) {
	if (quoted) {
	    quoted = 0;

	} else if (*p == '\\') {
	    quoted = 1;
	    if (strchr(separators, p[1]) != NULL) {

		/* Quoted directory separator. */

		break;
	    }

	} else if (strchr(separators, *p) != NULL) {

	    /* Unquoted directory separator. */

	    break;

	} else if (*p == '{') {
	    openBrace = p;
	    p++;
	    if (SkipToChar(&p, '}')) {

		/* Balanced braces. */


		closeBrace = p;
		break;
	    }
	    Tcl_SetResult(interp, "unmatched open-brace in file name",
		    TCL_STATIC);
	    return TCL_ERROR;

	} else if (*p == '}') {
	    Tcl_SetResult(interp, "unmatched close-brace in file name",
		    TCL_STATIC);
	    return TCL_ERROR;
	}
    }

    /*
     * Substitute the alternate patterns from the braces and recurse.
     */

    if (openBrace != NULL) {
	char *element;

	Tcl_DString newName;
	Tcl_DStringInit(&newName);

	/*
	 * For each element within in the outermost pair of braces,
	 * append the element and the remainder to the fixed portion
	 * before the first brace and recursively call DoGlob.
	 */

	Tcl_DStringAppend(&newName, pattern, openBrace-pattern);
	baseLength = Tcl_DStringLength(&newName);
	*closeBrace = '\0';
	for (p = openBrace; p != closeBrace; ) {
	    p++;







|
|
|
<
|
|
|
|



|
|
|
|
|











|



|
|

|
|
<
|
|









|
|









|
|
|

>












|
|
|
|






>


|
|
<

>







|
|
|



















|
|













|
|







>



>
|
>


>

>
|
>

>




>
|
>
>






>


















|
|
|







2008
2009
2010
2011
2012
2013
2014
2015
2016
2017

2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049

2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103

2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
}

/*
 *----------------------------------------------------------------------
 *
 * DoGlob --
 *
 *	This recursive procedure forms the heart of the globbing code. It
 *	performs a depth-first traversal of the tree given by the path name to
 *	be globbed and the pattern. The directory and remainder are assumed to

 *	be native format paths. The prefix contained in 'pathPtr' is either a
 *	directory or path from which to start the search (or NULL). If pathPtr
 *	is NULL, then the pattern must not start with an absolute path
 *	specification (that case should be handled by moving the absolute path
 *	prefix into pathPtr before calling DoGlob).
 *
 * Results:
 *	The return value is a standard Tcl result indicating whether an error
 *	occurred in globbing.  After a normal return the result in interp will
 *	be set to hold all of the file names given by the dir and remaining
 *	arguments.  After an error the result in interp will hold an error
 *	message.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting
				 * (e.g. unmatched brace). */
    Tcl_Obj *matchesObj;	/* Unshared list object in which to place all
				 * resulting filenames. Caller allocates and
				 * deallocates; DoGlob must not touch the
				 * refCount of this object. */
    char *separators;		/* String containing separator characters that
				 * should be used to identify globbing
				 * boundaries. */
    Tcl_Obj *pathPtr;		/* Completely expanded prefix. */
    int flags;			/* If non-zero then pathPtr is a directory */

    char *pattern;		/* The pattern to match against.  Must not be
				 * a pointer to a static string. */
    Tcl_GlobTypeData *types;	/* List object containing list of acceptable
				 * types. May be NULL. */
{
    int baseLength, quoted, count;
    int result = TCL_OK;
    char *name, *p, *openBrace, *closeBrace, *firstSpecialChar;
    Tcl_Obj *joinedPtr;

    /*
     * Consume any leading directory separators, leaving pattern pointing just
     * past the last initial separator.
     */

    count = 0;
    name = pattern;
    for (; *pattern != '\0'; pattern++) {
	if (*pattern == '\\') {
	    /*
	     * If the first character is escaped, either we have a directory
	     * separator, or we have any other character.  In the latter case
	     * the rest is a pattern, and we must break from the loop.  This
	     * is particularly important on Windows where '\' is both the
	     * escaping character and a directory separator.
	     */

	    if (strchr(separators, pattern[1]) != NULL) {
		pattern++;
	    } else {
		break;
	    }
	} else if (strchr(separators, *pattern) == NULL) {
	    break;
	}
	count++;
    }

    /*
     * This block of code is not exercised by the Tcl test suite as of Tcl
     * 8.5a0.  Simplifications to the calling paths suggest it may not be
     * necessary any more, since path separators are handled elsewhere.  It is
     * left in place in case new bugs are reported
     */

#if 0 /* PROBABLY_OBSOLETE */
    /*
     * Deal with path separators.
     */

    if (pathPtr == NULL) {
	/*
	 * Length used to be the length of the prefix, and lastChar the
	 * lastChar of the prefix.  But, none of this is used any more.

	 */

	int length = 0;
	char lastChar = 0;

	switch (tclPlatform) {
	case TCL_PLATFORM_WINDOWS:
	    /*
	     * If this is a drive relative path, add the colon and the
	     * trailing slash if needed.  Otherwise add the slash if this is
	     * the first absolute element, or a later relative element.  Add
	     * an extra slash if this is a UNC path.
	     */

	    if (*name == ':') {
		Tcl_DStringAppend(&append, ":", 1);
		if (count > 1) {
		    Tcl_DStringAppend(&append, "/", 1);
		}
	    } else if ((*pattern != '\0') && (((length > 0)
		    && (strchr(separators, lastChar) == NULL))
		    || ((length == 0) && (count > 0)))) {
		Tcl_DStringAppend(&append, "/", 1);
		if ((length == 0) && (count > 1)) {
		    Tcl_DStringAppend(&append, "/", 1);
		}
	    }

	    break;
	case TCL_PLATFORM_UNIX:
	    /*
	     * Add a separator if this is the first absolute element, or a
	     * later relative element.
	     */

	    if ((*pattern != '\0') && (((length > 0)
		    && (strchr(separators, lastChar) == NULL))
		    || ((length == 0) && (count > 0)))) {
		Tcl_DStringAppend(&append, "/", 1);
	    }
	    break;
	}
    }
#endif /* PROBABLY_OBSOLETE */

    /*
     * Look for the first matching pair of braces or the first directory
     * separator that is not inside a pair of braces.
     */

    openBrace = closeBrace = NULL;
    quoted = 0;
    for (p = pattern; *p != '\0'; p++) {
	if (quoted) {
	    quoted = 0;

	} else if (*p == '\\') {
	    quoted = 1;
	    if (strchr(separators, p[1]) != NULL) {
		/*
		 * Quoted directory separator.
		 */
		break;
	    }

	} else if (strchr(separators, *p) != NULL) {
	    /*
	     * Unquoted directory separator.
	     */
	    break;

	} else if (*p == '{') {
	    openBrace = p;
	    p++;
	    if (SkipToChar(&p, '}')) {
		/*
		 * Balanced braces.
		 */

		closeBrace = p;
		break;
	    }
	    Tcl_SetResult(interp, "unmatched open-brace in file name",
		    TCL_STATIC);
	    return TCL_ERROR;

	} else if (*p == '}') {
	    Tcl_SetResult(interp, "unmatched close-brace in file name",
		    TCL_STATIC);
	    return TCL_ERROR;
	}
    }

    /*
     * Substitute the alternate patterns from the braces and recurse.
     */

    if (openBrace != NULL) {
	char *element;

	Tcl_DString newName;
	Tcl_DStringInit(&newName);

	/*
	 * For each element within in the outermost pair of braces, append the
	 * element and the remainder to the fixed portion before the first
	 * brace and recursively call DoGlob.
	 */

	Tcl_DStringAppend(&newName, pattern, openBrace-pattern);
	baseLength = Tcl_DStringLength(&newName);
	*closeBrace = '\0';
	for (p = openBrace; p != closeBrace; ) {
	    p++;
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
	}
	*closeBrace = '}';
	Tcl_DStringFree(&newName);
	return result;
    }

    /*
     * At this point, there are no more brace substitutions to perform on
     * this path component.  The variable p is pointing at a quoted or
     * unquoted directory separator or the end of the string.  So we need
     * to check for special globbing characters in the current pattern.
     * We avoid modifying pattern if p is pointing at the end of the string.
     *
     * If we find any globbing characters, then we must call
     * Tcl_FSMatchInDirectory.  If we're at the end of the string, then
     * that's all we need to do.  If we're not at the end of the
     * string, then we must recurse, so we do that below.
     *
     * Alternatively, if there are no globbing characters then again
     * there are two cases.  If we're at the end of the string, we just
     * need to check for the given path's existence and type.  If we're
     * not at the end of the string, we recurse.
     */

    if (*p != '\0') {
	/*
	 * Note that we are modifying the string in place.  This won't work
	 * if the string is a static.
	 */

	char savedChar = *p;
	*p = '\0';
	firstSpecialChar = strpbrk(pattern, "*[]?\\");
	*p = savedChar;
    } else {
	firstSpecialChar = strpbrk(pattern, "*[]?\\");
    }

    if (firstSpecialChar != NULL) {
	/*
	 * Look for matching files in the given directory.  The
	 * implementation of this function is filesystem specific.  For
	 * each file that matches, it will add the match onto the
	 * resultPtr given.
	 */

	static Tcl_GlobTypeData dirOnly = {
	    TCL_GLOB_TYPE_DIR, 0, NULL, NULL
	};
	char save = *p;
	Tcl_Obj* subdirsPtr;

	if (*p == '\0') {
	    return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr,
		    pattern, types);
	}

	/*
	 * We do the recursion ourselves.  This makes implementing
	 * Tcl_FSMatchInDirectory for each filesystem much easier.
	 */

	*p = '\0';
	TclNewObj(subdirsPtr);
	result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
		pattern, &dirOnly);







|
|
|
|
|


|
|
|

|
|
|
|




|
|












|
|
|
<














|







2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270

2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
	}
	*closeBrace = '}';
	Tcl_DStringFree(&newName);
	return result;
    }

    /*
     * At this point, there are no more brace substitutions to perform on this
     * path component. The variable p is pointing at a quoted or unquoted
     * directory separator or the end of the string. So we need to check for
     * special globbing characters in the current pattern. We avoid modifying
     * pattern if p is pointing at the end of the string.
     *
     * If we find any globbing characters, then we must call
     * Tcl_FSMatchInDirectory. If we're at the end of the string, then that's
     * all we need to do. If we're not at the end of the string, then we must
     * recurse, so we do that below.
     *
     * Alternatively, if there are no globbing characters then again there are
     * two cases. If we're at the end of the string, we just need to check for
     * the given path's existence and type. If we're not at the end of the
     * string, we recurse.
     */

    if (*p != '\0') {
	/*
	 * Note that we are modifying the string in place. This won't work if
	 * the string is a static.
	 */

	char savedChar = *p;
	*p = '\0';
	firstSpecialChar = strpbrk(pattern, "*[]?\\");
	*p = savedChar;
    } else {
	firstSpecialChar = strpbrk(pattern, "*[]?\\");
    }

    if (firstSpecialChar != NULL) {
	/*
	 * Look for matching files in the given directory. The implementation
	 * of this function is filesystem specific. For each file that
	 * matches, it will add the match onto the resultPtr given.

	 */

	static Tcl_GlobTypeData dirOnly = {
	    TCL_GLOB_TYPE_DIR, 0, NULL, NULL
	};
	char save = *p;
	Tcl_Obj* subdirsPtr;

	if (*p == '\0') {
	    return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr,
		    pattern, types);
	}

	/*
	 * We do the recursion ourselves. This makes implementing
	 * Tcl_FSMatchInDirectory for each filesystem much easier.
	 */

	*p = '\0';
	TclNewObj(subdirsPtr);
	result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
		pattern, &dirOnly);
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
     * We reach here with no pattern char in current section
     */

    if (*p == '\0') {
	/*
	 * This is the code path reached by a command like 'glob foo'.
	 *
	 * There are no more wildcards in the pattern and no more
	 * unprocessed characters in the pattern, so now we can construct
	 * the path, and pass it to Tcl_FSMatchInDirectory with an
	 * empty pattern to verify the existence of the file and check
	 * it is of the correct type (if a 'types' flag it given -- if
	 * no such flag was given, we could just use 'Tcl_FSLStat', but
	 * for simplicity we keep to a common approach).
	 */

	int length;
	Tcl_DString append;

	Tcl_DStringInit(&append);
	Tcl_DStringAppend(&append, pattern, p-pattern);







|
|
|
|
|
|
|







2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
     * We reach here with no pattern char in current section
     */

    if (*p == '\0') {
	/*
	 * This is the code path reached by a command like 'glob foo'.
	 *
	 * There are no more wildcards in the pattern and no more unprocessed
	 * characters in the pattern, so now we can construct the path, and
	 * pass it to Tcl_FSMatchInDirectory with an empty pattern to verify
	 * the existence of the file and check it is of the correct type (if a
	 * 'types' flag it given -- if no such flag was given, we could just
	 * use 'Tcl_FSLStat', but for simplicity we keep to a common
	 * approach).
	 */

	int length;
	Tcl_DString append;

	Tcl_DStringInit(&append);
	Tcl_DStringAppend(&append, pattern, p-pattern);
2225
2226
2227
2228
2229
2230
2231

2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242

2243
2244
2245
2246
2247
2248
2249
2250
2251
2252


2253


2254
2255
2256
2257
2258
2259
2260
2261












2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281


















2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314








		if (((*name == '\\') && (name[1] == '/' ||
			name[1] == '\\')) || (*name == '/')) {
		    Tcl_DStringAppend(&append, "/", 1);
		} else {
		    Tcl_DStringAppend(&append, ".", 1);
		}
	    }

#if defined(__CYGWIN__) && defined(__WIN32__)
	    {
		extern int cygwin_conv_to_win32_path(CONST char *, char *);
		char winbuf[MAX_PATH+1];

		cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf);
		Tcl_DStringFree(&append);
		Tcl_DStringAppend(&append, winbuf, -1);
	    }
#endif /* __CYGWIN__ && __WIN32__ */
	    break;

	case TCL_PLATFORM_UNIX:
	    if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
		if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
		    Tcl_DStringAppend(&append, "/", 1);
		} else {
		    Tcl_DStringAppend(&append, ".", 1);
		}
	    }
	    break;
	}


	/* Common for all platforms */


	if (pathPtr == NULL) {
	    joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append),
		    Tcl_DStringLength(&append));
	} else if (flags) {
	    joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
		    Tcl_DStringLength(&append));
	} else {
	    joinedPtr = Tcl_DuplicateObj(pathPtr);












	    Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
		    Tcl_DStringLength(&append));
	}
	Tcl_IncrRefCount(joinedPtr);
	Tcl_DStringFree(&append);
	Tcl_FSMatchInDirectory(interp, matchesObj, joinedPtr, NULL, types);
	Tcl_DecrRefCount(joinedPtr);
	return TCL_OK;
    }

    /*
     * If it's not the end of the string, we must recurse
     */

    if (pathPtr == NULL) {
	joinedPtr = Tcl_NewStringObj(pattern, p-pattern);
    } else if (flags) {
	joinedPtr = TclNewFSPathObj(pathPtr, pattern, p-pattern);
    } else {
	joinedPtr = Tcl_DuplicateObj(pathPtr);


















	Tcl_AppendToObj(joinedPtr, pattern, p-pattern);
    }

    Tcl_IncrRefCount(joinedPtr);
    result = DoGlob(interp, matchesObj, separators, joinedPtr, 1, p, types);
    Tcl_DecrRefCount(joinedPtr);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_AllocStatBuf
 *
 *     This procedure allocates a Tcl_StatBuf on the heap.  It exists
 *     so that extensions may be used unchanged on systems where
 *     largefile support is optional.
 *
 * Results:
 *     A pointer to a Tcl_StatBuf which may be deallocated by being
 *     passed to ckfree().
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_StatBuf *
Tcl_AllocStatBuf() {
    return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
}















>











>










>
>
|
>
>








>
>
>
>
>
>
>
>
>
>
>
>




















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|

|
|
|


|
|


|








>
>
>
>
>
>
>
>
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
		if (((*name == '\\') && (name[1] == '/' ||
			name[1] == '\\')) || (*name == '/')) {
		    Tcl_DStringAppend(&append, "/", 1);
		} else {
		    Tcl_DStringAppend(&append, ".", 1);
		}
	    }

#if defined(__CYGWIN__) && defined(__WIN32__)
	    {
		extern int cygwin_conv_to_win32_path(CONST char *, char *);
		char winbuf[MAX_PATH+1];

		cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf);
		Tcl_DStringFree(&append);
		Tcl_DStringAppend(&append, winbuf, -1);
	    }
#endif /* __CYGWIN__ && __WIN32__ */
	    break;

	case TCL_PLATFORM_UNIX:
	    if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
		if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
		    Tcl_DStringAppend(&append, "/", 1);
		} else {
		    Tcl_DStringAppend(&append, ".", 1);
		}
	    }
	    break;
	}

	/*
	 * Common for all platforms.
	 */

	if (pathPtr == NULL) {
	    joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append),
		    Tcl_DStringLength(&append));
	} else if (flags) {
	    joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
		    Tcl_DStringLength(&append));
	} else {
	    joinedPtr = Tcl_DuplicateObj(pathPtr);
	    if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
		/*
		 * The current prefix must end in a separator.
		 */

		int len;
		CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len);

		if (strchr(separators, joined[len-1]) == NULL) {
		    Tcl_AppendToObj(joinedPtr, "/", 1);
		}
	    }
	    Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
		    Tcl_DStringLength(&append));
	}
	Tcl_IncrRefCount(joinedPtr);
	Tcl_DStringFree(&append);
	Tcl_FSMatchInDirectory(interp, matchesObj, joinedPtr, NULL, types);
	Tcl_DecrRefCount(joinedPtr);
	return TCL_OK;
    }

    /*
     * If it's not the end of the string, we must recurse
     */

    if (pathPtr == NULL) {
	joinedPtr = Tcl_NewStringObj(pattern, p-pattern);
    } else if (flags) {
	joinedPtr = TclNewFSPathObj(pathPtr, pattern, p-pattern);
    } else {
	joinedPtr = Tcl_DuplicateObj(pathPtr);
	if (strchr(separators, pattern[0]) == NULL) {
	    /*
	     * The current prefix must end in a separator, unless this is a
	     * volume-relative path.  In particular globbing in Windows
	     * shares, when not using -dir or -path, e.g. 'glob [file join
	     * //machine/share/subdir *]' requires adding a separator here.
	     * This behaviour is not currently tested for in the test suite.
	     */

	    int len;
	    CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len);

	    if (strchr(separators, joined[len-1]) == NULL) {
		if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
		    Tcl_AppendToObj(joinedPtr, "/", 1);
		}
	    }
	}
	Tcl_AppendToObj(joinedPtr, pattern, p-pattern);
    }

    Tcl_IncrRefCount(joinedPtr);
    result = DoGlob(interp, matchesObj, separators, joinedPtr, 1, p, types);
    Tcl_DecrRefCount(joinedPtr);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_AllocStatBuf --
 *
 *	This procedure allocates a Tcl_StatBuf on the heap.  It exists so that
 *	extensions may be used unchanged on systems where largefile support is
 *	optional.
 *
 * Results:
 *	A pointer to a Tcl_StatBuf which may be deallocated by being passed to
 *	ckfree().
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_StatBuf *
Tcl_AllocStatBuf() {
    return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclGet.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281

282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

324
325
326
327
328
329
330
331
332
333
334







/* 
 * tclGet.c --
 *
 *	This file contains procedures to convert strings into
 *	other forms, like integers or floating-point numbers or
 *	booleans, doing syntax checking along the way.
 *
 * Copyright (c) 1990-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclGet.c,v 1.9 2004/04/06 22:25:51 dgp Exp $
 */

#include "tclInt.h"
#include <math.h>


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInt --
 *
 *	Given a string, produce the corresponding integer value.
 *
 * Results:
 *	The return value is normally TCL_OK;  in this case *intPtr
 *	will be set to the integer value equivalent to string.  If
 *	string is improperly formed then TCL_ERROR is returned and
 *	an error message will be left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInt(interp, string, intPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    CONST char *string;		/* String containing a (possibly signed)
				 * integer in a form acceptable to strtol. */
    int *intPtr;		/* Place to store converted result. */
{
    char *end;
    CONST char *p = string;
    long i;

    /*
     * Note: use strtoul instead of strtol for integer conversions
     * to allow full-size unsigned numbers, but don't depend on strtoul
     * to handle sign characters;  it won't in some implementations.
     */

    errno = 0;
#ifdef TCL_STRTOUL_SIGN_CHECK
    /*
     * This special sign check actually causes bad numbers to be allowed
     * when strtoul.  I can't find a strtoul that doesn't validly handle
     * signed characters, and the C standard implies that this is all
     * unnecessary. [Bug #634856]
     */
    for ( ; isspace(UCHAR(*p)); p++) {	/* INTL: ISO space. */
	/* Empty loop body. */
    }
    if (*p == '-') {
	p++;
	i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */
    } else if (*p == '+') {
	p++;
	i = strtoul(p, &end, 0); /* INTL: Tcl source. */
    } else
#else
	i = strtoul(p, &end, 0); /* INTL: Tcl source. */
#endif
    if (end == p) {
	badInteger:
        if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "expected integer but got \"", string,
		    "\"", (char *) NULL);
	    TclCheckBadOctal(interp, string);

        }
	return TCL_ERROR;
    }

    /*
     * The second test below is needed on platforms where "long" is
     * larger than "int" to detect values that fit in a long but not in
     * an int.
     */

    if ((errno == ERANGE) || (((long)(int) i) != i)) {
        if (interp != (Tcl_Interp *) NULL) {
	    Tcl_SetResult(interp, "integer value too large to represent",
		    TCL_STATIC);
            Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
		    Tcl_GetStringResult(interp), (char *) NULL);
        }
	return TCL_ERROR;
    }
    while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
	end++;
    }
    if (*end != 0) {
	goto badInteger;
    }
    *intPtr = (int) i;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetLong --
 *
 *	Given a string, produce the corresponding long integer value.
 *	This routine is a version of Tcl_GetInt but returns a "long"
 *	instead of an "int".
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *longPtr
 *	will be set to the long integer value equivalent to string. If
 *	string is improperly formed then TCL_ERROR is returned and
 *	an error message will be left in the interp's result if interp
 *	is non-NULL. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetLong(interp, string, longPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting
				 * if not NULL. */
    CONST char *string;		/* String containing a (possibly signed)
				 * long integer in a form acceptable to
				 * strtoul. */
    long *longPtr;		/* Place to store converted long result. */
{
    char *end;
    CONST char *p = string;
    long i;

    /*
     * Note: don't depend on strtoul to handle sign characters; it won't
     * in some implementations.
     */

    errno = 0;
#ifdef TCL_STRTOUL_SIGN_CHECK
    for ( ; isspace(UCHAR(*p)); p++) {	/* INTL: ISO space. */
	/* Empty loop body. */
    }
    if (*p == '-') {
	p++;
	i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */
    } else if (*p == '+') {
	p++;
	i = strtoul(p, &end, 0); /* INTL: Tcl source. */
    } else
#else
	i = strtoul(p, &end, 0); /* INTL: Tcl source. */
#endif
    if (end == p) {
	badInteger:
        if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "expected integer but got \"", string,
		    "\"", (char *) NULL);
	    TclCheckBadOctal(interp, string);

        }
	return TCL_ERROR;
    }
    if (errno == ERANGE) {
        if (interp != (Tcl_Interp *) NULL) {
	    Tcl_SetResult(interp, "integer value too large to represent",
		    TCL_STATIC);
            Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
                    Tcl_GetStringResult(interp), (char *) NULL);
        }
	return TCL_ERROR;
    }
    while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
	end++;
    }
    if (*end != 0) {
	goto badInteger;

    }
    *longPtr = i;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetDouble --
 *
 *	Given a string, produce the corresponding double-precision
 *	floating-point value.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *doublePtr
 *	will be set to the double-precision value equivalent to string.
 *	If string is improperly formed then TCL_ERROR is returned and
 *	an error message will be left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetDouble(interp, string, doublePtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    CONST char *string;		/* String containing a floating-point number
				 * in a form acceptable to strtod. */
    double *doublePtr;		/* Place to store converted result. */
{
    char *end;
    double d;

    errno = 0;
    d = strtod(string, &end); /* INTL: Tcl source. */
    if (end == string) {
	badDouble:
        if (interp != (Tcl_Interp *) NULL) {
            Tcl_AppendResult(interp,
                    "expected floating-point number but got \"",
                    string, "\"", (char *) NULL);
        }
	return TCL_ERROR;
    }
    if (errno != 0 && (d == HUGE_VAL || d == -HUGE_VAL || d == 0)) {
        if (interp != (Tcl_Interp *) NULL) {
            TclExprFloatError(interp, d); 
        }
	return TCL_ERROR;
    }
    while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */
	end++;
    }
    if (*end != 0) {
	goto badDouble;

    }
    *doublePtr = d;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBoolean --
 *
 *	Given a string, return a 0/1 boolean value corresponding
 *	to the string.
 *
 * Results:
 *	The return value is normally TCL_OK;  in this case *boolPtr
 *	will be set to the 0/1 value equivalent to string.  If
 *	string is improperly formed then TCL_ERROR is returned and
 *	an error message will be left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBoolean(interp, string, boolPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    CONST char *string;		/* String containing a boolean number
				 * specified either as 1/0 or true/false or
				 * yes/no. */
    int *boolPtr;		/* Place to store converted result, which
				 * will be 0 or 1. */
{

    int i;
    char lowerCase[10], c;
    size_t length;

    /*
     * Convert the input string to all lower-case. 
     * INTL: This code will work on UTF strings.
     */

    for (i = 0; i < 9; i++) {
	c = string[i];
	if (c == 0) {
	    break;
	}
	if ((c >= 'A') && (c <= 'Z')) {
	    c += (char) ('a' - 'A');
	}
	lowerCase[i] = c;
    }
    lowerCase[i] = 0;

    length = strlen(lowerCase);
    c = lowerCase[0];
    if ((c == '0') && (lowerCase[1] == '\0')) {
	*boolPtr = 0;
    } else if ((c == '1') && (lowerCase[1] == '\0')) {
	*boolPtr = 1;
    } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {
	*boolPtr = 1;
    } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {
	*boolPtr = 0;
    } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {
	*boolPtr = 1;
    } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {
	*boolPtr = 0;
    } else if ((c == 'o') && (length >= 2)) {
	if (strncmp(lowerCase, "on", length) == 0) {
	    *boolPtr = 1;
	} else if (strncmp(lowerCase, "off", length) == 0) {
	    *boolPtr = 0;
	} else {
	    goto badBoolean;

	}
    } else {
	badBoolean:
        if (interp != (Tcl_Interp *) NULL) {
            Tcl_AppendResult(interp, "expected boolean value but got \"",
                    string, "\"", (char *) NULL);
        }
	return TCL_ERROR;
    }
    return TCL_OK;
}







|


|
|
|




|
|

|



<










|
|
|
|








|

|
|


<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
|
>
|
<
<
|
<
<
<
|
<
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
|







|
|
|


|
|
|
|
<








|
|
|
|
|
<


<
<
<
|
<
<
<
<
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
|
>
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
|
<
>

<
|











|
|
|
|








|

|



|
|

|
|
|
<
<
<
<
|
|
<
<
<
<
|
<
<
<
<
<
<
|
<
>

<
|







|
|


|
|
|
|








|

|


|
|

>
|
<
<

<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
|
|
|
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
>
|
|
<
|
<
<
|
|
|
<
|
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45



46





47










48











49


50
51
52
53


54



55

56






57









58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

75
76
77
78
79
80
81
82
83
84
85
86
87

88
89



90




91




92











93


94
95
96
97






98







99

100
101

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137




138
139




140






141

142
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177


178




179











180
181


182
183
184








185






186
187
188

189


190
191
192

193
194
195
196
197
198
199
200
/*
 * tclGet.c --
 *
 *	This file contains functions to convert strings into other forms, like
 *	integers or floating-point numbers or booleans, doing syntax checking
 *	along the way.
 *
 * Copyright (c) 1990-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclGet.c,v 1.9.2.5 2005/08/02 18:15:29 dgp Exp $
 */

#include "tclInt.h"



/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInt --
 *
 *	Given a string, produce the corresponding integer value.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *intPtr will be set
 *	to the integer value equivalent to src.  If src is improperly formed
 *	then TCL_ERROR is returned and an error message will be left in the
 *	interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInt(interp, src, intPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    CONST char *src;		/* String containing a (possibly signed)
				 * integer in a form acceptable to strtoul. */
    int *intPtr;		/* Place to store converted result. */
{



    Tcl_Obj obj;





    int code;






















    obj.refCount = 1;


    obj.bytes = (char *) src;
    obj.length = strlen(src);
    obj.typePtr = NULL;



    code = Tcl_GetIntFromObj(interp, &obj, intPtr);



    if (obj.refCount > 1) {

	Tcl_Panic("invalid sharing of Tcl_Obj on C stack");






    }









    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetLong --
 *
 *	Given a string, produce the corresponding long integer value. This
 *	routine is a version of Tcl_GetInt but returns a "long" instead of an
 *	"int" (a difference that matters on 64-bit architectures).
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *longPtr will be set
 *	to the long integer value equivalent to src. If src is improperly
 *	formed then TCL_ERROR is returned and an error message will be left in
 *	the interp's result if interp is non-NULL.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetLong(interp, src, longPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting if not
				 * NULL. */
    CONST char *src;		/* String containing a (possibly signed) long
				 * integer in a form acceptable to strtoul. */

    long *longPtr;		/* Place to store converted long result. */
{



    Tcl_Obj obj;




    int code;
















    obj.refCount = 1;


    obj.bytes = (char *) src;
    obj.length = strlen(src);
    obj.typePtr = NULL;







    code = Tcl_GetLongFromObj(interp, &obj, longPtr);







    if (obj.refCount > 1) {

	Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
    }

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetDouble --
 *
 *	Given a string, produce the corresponding double-precision
 *	floating-point value.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *doublePtr will be
 *	set to the double-precision value equivalent to src. If src is
 *	improperly formed then TCL_ERROR is returned and an error message will
 *	be left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetDouble(interp, src, doublePtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    CONST char *src;		/* String containing a floating-point number
				 * in a form acceptable to strtod. */
    double *doublePtr;		/* Place to store converted result. */
{
    Tcl_Obj obj;
    int code;

    obj.refCount = 1;
    obj.bytes = (char *) src;
    obj.length = strlen(src);




    obj.typePtr = NULL;





    code = Tcl_GetDoubleFromObj(interp, &obj, doublePtr);






    if (obj.refCount > 1) {

	Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
    }

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBoolean --
 *
 *	Given a string, return a 0/1 boolean value corresponding to the
 *	string.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *boolPtr will be set
 *	to the 0/1 value equivalent to src. If src is improperly formed then
 *	TCL_ERROR is returned and an error message will be left in the
 *	interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBoolean(interp, src, boolPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    CONST char *src;		/* String containing a boolean number
				 * specified either as 1/0 or true/false or
				 * yes/no. */
    int *boolPtr;		/* Place to store converted result, which will
				 * be 0 or 1. */
{
    Tcl_Obj obj;
    int code;







    obj.refCount = 1;











    obj.bytes = (char *) src;
    obj.length = strlen(src);


    obj.typePtr = NULL;

    code = Tcl_ConvertToType(interp, &obj, &tclBooleanType);








    if (obj.refCount > 1) {






	Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
    }
    if (code == TCL_OK) {

	*boolPtr = obj.internalRep.longValue;


    }
    return code;
}


/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclGetDate.y.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclGetDate.y --
 *
 *	Contains yacc grammar for parsing date and time strings.
 *	The output of this file should be the file tclDate.c which
 *	is used directly in the Tcl sources.
 *
 * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclGetDate.y,v 1.25 2004/09/27 14:31:17 kennykb Exp $
 */

%{
/* 
 * tclDate.c --
 *
 *	This file is generated from a yacc grammar defined in













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclGetDate.y --
 *
 *	Contains yacc grammar for parsing date and time strings.
 *	The output of this file should be the file tclDate.c which
 *	is used directly in the Tcl sources.
 *
 * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclGetDate.y,v 1.25.2.1 2004/12/29 22:47:00 kennykb Exp $
 */

%{
/* 
 * tclDate.c --
 *
 *	This file is generated from a yacc grammar defined in
73
74
75
76
77
78
79


80
81
82
83
84
85
86
    time_t   dateDayOrdinal;
    time_t   dateDayNumber;
    int      dateHaveDay;

    char     *dateInput;
    time_t   *dateRelPointer;



} DateInfo;

#define YYPARSE_PARAM info
#define YYLEX_PARAM info

#define yyDSTmode (((DateInfo*)info)->dateDSTmode)
#define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal)







>
>







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
    time_t   dateDayOrdinal;
    time_t   dateDayNumber;
    int      dateHaveDay;

    char     *dateInput;
    time_t   *dateRelPointer;

    int	     dateDigitCount;

} DateInfo;

#define YYPARSE_PARAM info
#define YYLEX_PARAM info

#define yyDSTmode (((DateInfo*)info)->dateDSTmode)
#define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal)
101
102
103
104
105
106
107

108
109
110
111
112
113
114
#define yySeconds (((DateInfo*)info)->dateSeconds)
#define yyMeridian (((DateInfo*)info)->dateMeridian)
#define yyRelMonth (((DateInfo*)info)->dateRelMonth)
#define yyRelDay (((DateInfo*)info)->dateRelDay)
#define yyRelSeconds (((DateInfo*)info)->dateRelSeconds)
#define yyRelPointer (((DateInfo*)info)->dateRelPointer)
#define yyInput (((DateInfo*)info)->dateInput)


#define EPOCH           1970
#define START_OF_TIME   1902
#define END_OF_TIME     2037

/*
 * The offset of tm_year of struct tm returned by localtime, gmtime, etc.







>







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
#define yySeconds (((DateInfo*)info)->dateSeconds)
#define yyMeridian (((DateInfo*)info)->dateMeridian)
#define yyRelMonth (((DateInfo*)info)->dateRelMonth)
#define yyRelDay (((DateInfo*)info)->dateRelDay)
#define yyRelSeconds (((DateInfo*)info)->dateRelSeconds)
#define yyRelPointer (((DateInfo*)info)->dateRelPointer)
#define yyInput (((DateInfo*)info)->dateInput)
#define yyDigitCount (((DateInfo*)info)->dateDigitCount)

#define EPOCH           1970
#define START_OF_TIME   1902
#define END_OF_TIME     2037

/*
 * The offset of tm_year of struct tm returned by localtime, gmtime, etc.
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417

number  : tUNUMBER
    {
	if (yyHaveTime && yyHaveDate && !yyHaveRel) {
	    yyYear = $1;
	} else {
	    yyHaveTime++;
	    if ($1 < 100) {
		yyHour = $1;
		yyMinutes = 0;
	    } else {
		yyHour = $1 / 100;
		yyMinutes = $1 % 100;
	    }
	    yySeconds = 0;







|







406
407
408
409
410
411
412
413
414
415
416
417
418
419
420

number  : tUNUMBER
    {
	if (yyHaveTime && yyHaveDate && !yyHaveRel) {
	    yyYear = $1;
	} else {
	    yyHaveTime++;
	    if (yyDigitCount <= 2) {
		yyHour = $1;
		yyMinutes = 0;
	    } else {
		yyHour = $1 / 100;
		yyMinutes = $1 % 100;
	    }
	    yySeconds = 0;
797
798
799
800
801
802
803

804
805
806
807
808
809
810
	    Count = 0;
            for (yylval.Number = 0;
		    isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
                yylval.Number = 10 * yylval.Number + c - '0';
		Count++;
	    }
            yyInput--;

	    /* A number with 6 or more digits is considered an ISO 8601 base */
	    if (Count >= 6) {
		return tISOBASE;
	    } else {
		return tUNUMBER;
	    }
        }







>







800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
	    Count = 0;
            for (yylval.Number = 0;
		    isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
                yylval.Number = 10 * yylval.Number + c - '0';
		Count++;
	    }
            yyInput--;
	    yyDigitCount = Count;
	    /* A number with 6 or more digits is considered an ISO 8601 base */
	    if (Count >= 6) {
		return tISOBASE;
	    } else {
		return tUNUMBER;
	    }
        }

Changes to generic/tclHash.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
/* 
 * tclHash.c --
 *
 *	Implementation of in-memory hash tables for Tcl and Tcl-based
 *	applications.
 *
 * Copyright (c) 1991-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclHash.c,v 1.22 2004/11/11 01:17:50 das Exp $
 */

#include "tclInt.h"

/*
 * Prevent macros from clashing with function definitions.
 */

#if TCL_PRESERVE_BINARY_COMPATABILITY
#   undef Tcl_FindHashEntry
#   undef Tcl_CreateHashEntry
#endif

/*
 * When there are this many entries per bucket, on average, rebuild
 * the hash table to make it larger.
 */

#define REBUILD_MULTIPLIER	3

/*
 * The following macro takes a preliminary integer hash value and
 * produces an index into a hash tables bucket list.  The idea is
 * to make it so that preliminary values that are arbitrarily similar
 * will end up in different buckets.  The hash function was taken
 * from a random-number generator.
 */

#define RANDOM_INDEX(tablePtr, i) \
    (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)

/*
 * Prototypes for the array hash key methods.









|
|

|














|
|





|
|
|
<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
/* 
 * tclHash.c --
 *
 *	Implementation of in-memory hash tables for Tcl and Tcl-based
 *	applications.
 *
 * Copyright (c) 1991-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclHash.c,v 1.22.2.1 2005/08/02 18:15:29 dgp Exp $
 */

#include "tclInt.h"

/*
 * Prevent macros from clashing with function definitions.
 */

#if TCL_PRESERVE_BINARY_COMPATABILITY
#   undef Tcl_FindHashEntry
#   undef Tcl_CreateHashEntry
#endif

/*
 * When there are this many entries per bucket, on average, rebuild the hash
 * table to make it larger.
 */

#define REBUILD_MULTIPLIER	3

/*
 * The following macro takes a preliminary integer hash value and produces an
 * index into a hash tables bucket list. The idea is to make it so that
 * preliminary values that are arbitrarily similar will end up in different

 * buckets. The hash function was taken from a random-number generator.
 */

#define RANDOM_INDEX(tablePtr, i) \
    (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)

/*
 * Prototypes for the array hash key methods.
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
			    Tcl_HashTable *tablePtr, VOID *keyPtr));
static int		CompareStringKeys _ANSI_ARGS_((
			    VOID *keyPtr, Tcl_HashEntry *hPtr));
static unsigned int	HashStringKey _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr, VOID *keyPtr));

/*
 * Procedure prototypes for static procedures in this file:
 */

#if TCL_PRESERVE_BINARY_COMPATABILITY
static Tcl_HashEntry *	BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
			    CONST char *key));
static Tcl_HashEntry *	BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
			    CONST char *key, int *newPtr));







|







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
			    Tcl_HashTable *tablePtr, VOID *keyPtr));
static int		CompareStringKeys _ANSI_ARGS_((
			    VOID *keyPtr, Tcl_HashEntry *hPtr));
static unsigned int	HashStringKey _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr, VOID *keyPtr));

/*
 * Function prototypes for static functions in this file:
 */

#if TCL_PRESERVE_BINARY_COMPATABILITY
static Tcl_HashEntry *	BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
			    CONST char *key));
static Tcl_HashEntry *	BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
			    CONST char *key, int *newPtr));
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    HashStringKey,			/* hashKeyProc */
    CompareStringKeys,			/* compareKeysProc */
    AllocStringEntry,			/* allocEntryProc */
    NULL				/* freeEntryProc */
};


/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitHashTable --
 *
 *	Given storage for a hash table, set up the fields to prepare
 *	the hash table for use.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
 *	Tcl_CreateHashEntry.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_InitHashTable
void
Tcl_InitHashTable(tablePtr, keyType)
    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which
					 * is supplied by the caller. */
    int keyType;			/* Type of keys to use in table:
					 * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
					 * or an integer >= 2. */
{
    /*
     * Use a special value to inform the extended version that it must
     * not access any of the new fields in the Tcl_HashTable. If an
     * extension is rebuilt then any calls to this function will be
     * redirected to the extended version by a macro.
     */

    Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitCustomHashTable --
 *
 *	Given storage for a hash table, set up the fields to prepare
 *	the hash table for use. This is an extended version of
 *	Tcl_InitHashTable which supports user defined keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
 *	Tcl_CreateHashEntry.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitCustomHashTable(tablePtr, keyType, typePtr)
    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which
					 * is supplied by the caller. */
    int keyType;			/* Type of keys to use in table:
					 * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
					 * TCL_CUSTOM_TYPE_KEYS,
					 * TCL_CUSTOM_PTR_KEYS,  or an
					 * integer >= 2. */
    Tcl_HashKeyType *typePtr;		/* Pointer to structure which defines
					 * the behaviour of this table. */
{
#if (TCL_SMALL_HASH_TABLE != 4) 
    Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
	    TCL_SMALL_HASH_TABLE);
#endif







<






|
|














|
|





|
|
|
|

>








|
|
|













|
|



|
|







111
112
113
114
115
116
117

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    HashStringKey,			/* hashKeyProc */
    CompareStringKeys,			/* compareKeysProc */
    AllocStringEntry,			/* allocEntryProc */
    NULL				/* freeEntryProc */
};


/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitHashTable --
 *
 *	Given storage for a hash table, set up the fields to prepare the hash
 *	table for use.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
 *	Tcl_CreateHashEntry.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_InitHashTable
void
Tcl_InitHashTable(tablePtr, keyType)
    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which is
					 * supplied by the caller. */
    int keyType;			/* Type of keys to use in table:
					 * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
					 * or an integer >= 2. */
{
    /*
     * Use a special value to inform the extended version that it must not
     * access any of the new fields in the Tcl_HashTable. If an extension is
     * rebuilt then any calls to this function will be redirected to the
     * extended version by a macro.
     */

    Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitCustomHashTable --
 *
 *	Given storage for a hash table, set up the fields to prepare the hash
 *	table for use. This is an extended version of Tcl_InitHashTable which
 *	supports user defined keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
 *	Tcl_CreateHashEntry.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitCustomHashTable(tablePtr, keyType, typePtr)
    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which is
					 * supplied by the caller. */
    int keyType;			/* Type of keys to use in table:
					 * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
					 * TCL_CUSTOM_TYPE_KEYS,
					 * TCL_CUSTOM_PTR_KEYS, or an integer
					 * >= 2. */
    Tcl_HashKeyType *typePtr;		/* Pointer to structure which defines
					 * the behaviour of this table. */
{
#if (TCL_SMALL_HASH_TABLE != 4) 
    Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
	    TCL_SMALL_HASH_TABLE);
#endif
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
224
225
226
227

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243

244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
    if (typePtr == NULL) {
	/*
	 * The caller has been rebuilt so the hash table is an extended
	 * version.
	 */
    } else if (typePtr != (Tcl_HashKeyType *) -1) {
	/*
	 * The caller is requesting a customized hash table so it must be
	 * an extended version.
	 */

	tablePtr->typePtr = typePtr;
    } else {
	/*
	 * The caller has not been rebuilt so the hash table is not
	 * extended.
	 */
    }
#else
    if (typePtr == NULL) {
	/*
	 * Use the key type to decide which key type is needed.
	 */

	if (keyType == TCL_STRING_KEYS) {
	    typePtr = &tclStringHashKeyType;
	} else if (keyType == TCL_ONE_WORD_KEYS) {
	    typePtr = &tclOneWordHashKeyType;
	} else if (keyType == TCL_CUSTOM_TYPE_KEYS) {
	    Tcl_Panic ("No type structure specified for TCL_CUSTOM_TYPE_KEYS");
	} else if (keyType == TCL_CUSTOM_PTR_KEYS) {
	    Tcl_Panic ("No type structure specified for TCL_CUSTOM_PTR_KEYS");
	} else {
	    typePtr = &tclArrayHashKeyType;
	}
    } else if (typePtr == (Tcl_HashKeyType *) -1) {
	/*
	 * If the caller has not been rebuilt then we cannot continue as
	 * the hash table is not an extended version.
	 */

	Tcl_Panic ("Hash table is not compatible");
    }
    tablePtr->typePtr = typePtr;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindHashEntry --
 *
 *	Given a hash table find the entry with a matching key.
 *
 * Results:
 *	The return value is a token for the matching entry in the
 *	hash table, or NULL if there was no matching entry.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|

>



|
<







>













|
|

>
|













|
|







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219

220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
    if (typePtr == NULL) {
	/*
	 * The caller has been rebuilt so the hash table is an extended
	 * version.
	 */
    } else if (typePtr != (Tcl_HashKeyType *) -1) {
	/*
	 * The caller is requesting a customized hash table so it must be an
	 * extended version.
	 */

	tablePtr->typePtr = typePtr;
    } else {
	/*
	 * The caller has not been rebuilt so the hash table is not extended.

	 */
    }
#else
    if (typePtr == NULL) {
	/*
	 * Use the key type to decide which key type is needed.
	 */

	if (keyType == TCL_STRING_KEYS) {
	    typePtr = &tclStringHashKeyType;
	} else if (keyType == TCL_ONE_WORD_KEYS) {
	    typePtr = &tclOneWordHashKeyType;
	} else if (keyType == TCL_CUSTOM_TYPE_KEYS) {
	    Tcl_Panic ("No type structure specified for TCL_CUSTOM_TYPE_KEYS");
	} else if (keyType == TCL_CUSTOM_PTR_KEYS) {
	    Tcl_Panic ("No type structure specified for TCL_CUSTOM_PTR_KEYS");
	} else {
	    typePtr = &tclArrayHashKeyType;
	}
    } else if (typePtr == (Tcl_HashKeyType *) -1) {
	/*
	 * If the caller has not been rebuilt then we cannot continue as the
	 * hash table is not an extended version.
	 */

	Tcl_Panic("Hash table is not compatible");
    }
    tablePtr->typePtr = typePtr;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindHashEntry --
 *
 *	Given a hash table find the entry with a matching key.
 *
 * Results:
 *	The return value is a token for the matching entry in the hash table,
 *	or NULL if there was no matching entry.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
    /*
     * Search all of the entries in the appropriate bucket.
     */

    if (typePtr->compareKeysProc) {
	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
	        hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (compareKeysProc ((VOID *) key, hPtr)) {
		return hPtr;
	    }
	}
    } else {
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
	        hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (key == hPtr->key.oneWordValue) {
		return hPtr;
	    }
	}
    }
    
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateHashEntry --
 *
 *	Given a hash table with string keys, and a string key, find
 *	the entry with a matching key.  If there is no matching entry,
 *	then create a new entry that does match.
 *
 * Results:
 *	The return value is a pointer to the matching entry.  If this
 *	is a newly-created entry, then *newPtr will be set to a non-zero
 *	value;  otherwise *newPtr will be set to 0.  If this is a new
 *	entry the value stored in the entry will initially be 0.
 *
 * Side effects:
 *	A new entry may be added to the hash table.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_CreateHashEntry(tablePtr, key, newPtr)
    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
    CONST char *key;		/* Key to use to find or create matching
				 * entry. */
    int *newPtr;		/* Store info here telling whether a new
				 * entry was created. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_HashKeyType *typePtr;
    unsigned int hash;
    int index;

#if TCL_PRESERVE_BINARY_COMPATABILITY







|











|



















|
|
|


|
|
|
|












|
|







309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
    /*
     * Search all of the entries in the appropriate bucket.
     */

    if (typePtr->compareKeysProc) {
	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (compareKeysProc ((VOID *) key, hPtr)) {
		return hPtr;
	    }
	}
    } else {
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (key == hPtr->key.oneWordValue) {
		return hPtr;
	    }
	}
    }
    
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateHashEntry --
 *
 *	Given a hash table with string keys, and a string key, find the entry
 *	with a matching key. If there is no matching entry, then create a new
 *	entry that does match.
 *
 * Results:
 *	The return value is a pointer to the matching entry. If this is a
 *	newly-created entry, then *newPtr will be set to a non-zero value;
 *	otherwise *newPtr will be set to 0. If this is a new entry the value
 *	stored in the entry will initially be 0.
 *
 * Side effects:
 *	A new entry may be added to the hash table.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_CreateHashEntry(tablePtr, key, newPtr)
    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
    CONST char *key;		/* Key to use to find or create matching
				 * entry. */
    int *newPtr;		/* Store info here telling whether a new entry
				 * was created. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_HashKeyType *typePtr;
    unsigned int hash;
    int index;

#if TCL_PRESERVE_BINARY_COMPATABILITY
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
    /*
     * Search all of the entries in the appropriate bucket.
     */

    if (typePtr->compareKeysProc) {
	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
	        hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (compareKeysProc ((VOID *) key, hPtr)) {
		*newPtr = 0;
		return hPtr;
	    }
	}
    } else {
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
	        hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (key == hPtr->key.oneWordValue) {
		*newPtr = 0;
		return hPtr;
	    }
	}
    }

    /*
     * Entry not found.  Add a new one to the bucket.
     */

    *newPtr = 1;
    if (typePtr->allocEntryProc) {
	hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key);
    } else {
	hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));







|












|













|







408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
    /*
     * Search all of the entries in the appropriate bucket.
     */

    if (typePtr->compareKeysProc) {
	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (compareKeysProc ((VOID *) key, hPtr)) {
		*newPtr = 0;
		return hPtr;
	    }
	}
    } else {
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
	    if (hash != (unsigned int) hPtr->hash) {
		continue;
	    }
#endif
	    if (key == hPtr->key.oneWordValue) {
		*newPtr = 0;
		return hPtr;
	    }
	}
    }

    /*
     * Entry not found. Add a new one to the bucket.
     */

    *newPtr = 1;
    if (typePtr->allocEntryProc) {
	hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key);
    } else {
	hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
    hPtr->nextPtr = *hPtr->bucketPtr;
    *hPtr->bucketPtr = hPtr;
#endif
    hPtr->clientData = 0;
    tablePtr->numEntries++;

    /*
     * If the table has exceeded a decent size, rebuild it with many
     * more buckets.
     */

    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
	RebuildTable(tablePtr);
    }
    return hPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteHashEntry --
 *
 *	Remove a single entry from a hash table.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The entry given by entryPtr is deleted from its table and
 *	should never again be used by the caller.  It is up to the
 *	caller to free the clientData field of the entry, if that
 *	is relevant.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteHashEntry(entryPtr)
    Tcl_HashEntry *entryPtr;







|
|



















|
|
|
<







464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494

495
496
497
498
499
500
501
    hPtr->nextPtr = *hPtr->bucketPtr;
    *hPtr->bucketPtr = hPtr;
#endif
    hPtr->clientData = 0;
    tablePtr->numEntries++;

    /*
     * If the table has exceeded a decent size, rebuild it with many more
     * buckets.
     */

    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
	RebuildTable(tablePtr);
    }
    return hPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteHashEntry --
 *
 *	Remove a single entry from a hash table.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The entry given by entryPtr is deleted from its table and should never
 *	again be used by the caller. It is up to the caller to free the
 *	clientData field of the entry, if that is relevant.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteHashEntry(entryPtr)
    Tcl_HashEntry *entryPtr;
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteHashTable --
 *
 *	Free up everything associated with a hash table except for
 *	the record for the table itself.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The hash table is no longer useable.
 *







|
|







561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteHashTable --
 *
 *	Free up everything associated with a hash table except for the record
 *	for the table itself.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The hash table is no longer useable.
 *
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700

701
702
703
704
705
706
707
708
709
710
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FirstHashEntry --
 *
 *	Locate the first entry in a hash table and set up a record
 *	that can be used to step through all the remaining entries
 *	of the table.
 *
 * Results:
 *	The return value is a pointer to the first entry in tablePtr,
 *	or NULL if tablePtr has no entries in it.  The memory at
 *	*searchPtr is initialized so that subsequent calls to
 *	Tcl_NextHashEntry will return all of the entries in the table,
 *	one at a time.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_FirstHashEntry(tablePtr, searchPtr)
    Tcl_HashTable *tablePtr;		/* Table to search. */
    Tcl_HashSearch *searchPtr;		/* Place to store information about
					 * progress through the table. */
{
    searchPtr->tablePtr = tablePtr;
    searchPtr->nextIndex = 0;
    searchPtr->nextEntryPtr = NULL;
    return Tcl_NextHashEntry(searchPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NextHashEntry --
 *
 *	Once a hash table enumeration has been initiated by calling
 *	Tcl_FirstHashEntry, this procedure may be called to return
 *	successive elements of the table.
 *
 * Results:
 *	The return value is the next entry in the hash table being
 *	enumerated, or NULL if the end of the table is reached.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_NextHashEntry(searchPtr)
    register Tcl_HashSearch *searchPtr;	/* Place to store information about

					 * progress through the table.  Must
					 * have been initialized by calling
					 * Tcl_FirstHashEntry. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *tablePtr = searchPtr->tablePtr;

    while (searchPtr->nextEntryPtr == NULL) {
	if (searchPtr->nextIndex >= tablePtr->numBuckets) {
	    return NULL;







|
|
<


|
|
|
|
<









|
|
|













|
|


|
|









|
>
|
|
|







643
644
645
646
647
648
649
650
651

652
653
654
655
656
657

658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FirstHashEntry --
 *
 *	Locate the first entry in a hash table and set up a record that can be
 *	used to step through all the remaining entries of the table.

 *
 * Results:
 *	The return value is a pointer to the first entry in tablePtr, or NULL
 *	if tablePtr has no entries in it. The memory at *searchPtr is
 *	initialized so that subsequent calls to Tcl_NextHashEntry will return
 *	all of the entries in the table, one at a time.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_FirstHashEntry(tablePtr, searchPtr)
    Tcl_HashTable *tablePtr;	/* Table to search. */
    Tcl_HashSearch *searchPtr;	/* Place to store information about progress
				 * through the table. */
{
    searchPtr->tablePtr = tablePtr;
    searchPtr->nextIndex = 0;
    searchPtr->nextEntryPtr = NULL;
    return Tcl_NextHashEntry(searchPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NextHashEntry --
 *
 *	Once a hash table enumeration has been initiated by calling
 *	Tcl_FirstHashEntry, this function may be called to return successive
 *	elements of the table.
 *
 * Results:
 *	The return value is the next entry in the hash table being enumerated,
 *	or NULL if the end of the table is reached.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashEntry *
Tcl_NextHashEntry(searchPtr)
    register Tcl_HashSearch *searchPtr;
				/* Place to store information about progress
				 * through the table. Must have been
				 * initialized by calling
				 * Tcl_FirstHashEntry. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *tablePtr = searchPtr->tablePtr;

    while (searchPtr->nextEntryPtr == NULL) {
	if (searchPtr->nextIndex >= tablePtr->numBuckets) {
	    return NULL;
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_HashStats --
 *
 *	Return statistics describing the layout of the hash table
 *	in its hash buckets.
 *
 * Results:
 *	The return value is a malloc-ed string containing information
 *	about tablePtr.  It is the caller's responsibility to free
 *	this string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_HashStats(tablePtr)
    Tcl_HashTable *tablePtr;		/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    int count[NUM_COUNTERS], overflow, i, j;
    double average, tmp;
    register Tcl_HashEntry *hPtr;
    char *result, *p;
    Tcl_HashKeyType *typePtr;







|
|


|
|
<









|







718
719
720
721
722
723
724
725
726
727
728
729
730

731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_HashStats --
 *
 *	Return statistics describing the layout of the hash table in its hash
 *	buckets.
 *
 * Results:
 *	The return value is a malloc-ed string containing information about
 *	tablePtr. It is the caller's responsibility to free this string.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_HashStats(tablePtr)
    Tcl_HashTable *tablePtr;	/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    int count[NUM_COUNTERS], overflow, i, j;
    double average, tmp;
    register Tcl_HashEntry *hPtr;
    char *result, *p;
    Tcl_HashKeyType *typePtr;
791
792
793
794
795
796
797

798
799
800
801
802
803
804
	    average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
	}
    }

    /*
     * Print out the histogram and a few other pieces of information.
     */

    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
	result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0);
    } else {
	result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300);
    }
    sprintf(result, "%d entries in table, %d buckets\n",
	    tablePtr->numEntries, tablePtr->numBuckets);







>







789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
	    average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
	}
    }

    /*
     * Print out the histogram and a few other pieces of information.
     */

    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
	result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0);
    } else {
	result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300);
    }
    sprintf(result, "%d entries in table, %d buckets\n",
	    tablePtr->numEntries, tablePtr->numBuckets);
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
 *----------------------------------------------------------------------
 *
 * CompareArrayKeys --
 *
 *	Compares two array keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are
 *	the same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|







861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
 *----------------------------------------------------------------------
 *
 * CompareArrayKeys --
 *
 *	Compares two array keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are the
 *	same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
}

/*
 *----------------------------------------------------------------------
 *
 * HashArrayKey --
 *
 *	Compute a one-word summary of an array, which can be
 *	used to generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in
 *	string.
 *
 * Side effects:
 *	None.







|
|







896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
}

/*
 *----------------------------------------------------------------------
 *
 * HashArrayKey --
 *
 *	Compute a one-word summary of an array, which can be used to generate
 *	a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in
 *	string.
 *
 * Side effects:
 *	None.
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
 *----------------------------------------------------------------------
 *
 * CompareStringKeys --
 *
 *	Compares two string keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are
 *	the same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|







968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
 *----------------------------------------------------------------------
 *
 * CompareStringKeys --
 *
 *	Compares two string keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are the
 *	same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048

1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
}

/*
 *----------------------------------------------------------------------
 *
 * HashStringKey --
 *
 *	Compute a one-word summary of a text string, which can be
 *	used to generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in
 *	string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
HashStringKey(tablePtr, keyPtr)
    Tcl_HashTable *tablePtr;	/* Hash table. */
    VOID *keyPtr;		/* Key from which to compute hash value. */
{
    register CONST char *string = (CONST char *) keyPtr;
    register unsigned int result;
    register int c;

    /*
     * I tried a zillion different hash functions and asked many other
     * people for advice.  Many people had their own favorite functions,
     * all different, but no-one had much idea why they were good ones.
     * I chose the one below (multiply by 9 and add new character)
     * because of the following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings,
     *    and multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
     *    character's bits hang around in the low-order bits of the
     *    hash value for ever, plus they spread fairly rapidly up to
     *    the high-order bits to fill out the hash value.  This seems
     *    works well both for decimal and non-decimal strings.

     */

    result = 0;

    for (c=*string++ ; c ; c=*string++) {
	result += (result<<3) + c;
    }
    return result;
}

#if TCL_PRESERVE_BINARY_COMPATABILITY
/*
 *----------------------------------------------------------------------
 *
 * BogusFind --
 *
 *	This procedure is invoked when an Tcl_FindHashEntry is called
 *	on a table that has been deleted.
 *
 * Results:
 *	If Tcl_Panic returns (which it shouldn't) this procedure returns
 *	NULL.
 *
 * Side effects:
 *	Generates a panic.
 *
 *----------------------------------------------------------------------
 */








|
|


|
<

















|
|
|
|
|

|
|
|
|
|
|
|
>
















|
|


|
<







1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016

1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068

1069
1070
1071
1072
1073
1074
1075
}

/*
 *----------------------------------------------------------------------
 *
 * HashStringKey --
 *
 *	Compute a one-word summary of a text string, which can be used to
 *	generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in string.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
HashStringKey(tablePtr, keyPtr)
    Tcl_HashTable *tablePtr;	/* Hash table. */
    VOID *keyPtr;		/* Key from which to compute hash value. */
{
    register CONST char *string = (CONST char *) keyPtr;
    register unsigned int result;
    register int c;

    /*
     * I tried a zillion different hash functions and asked many other people
     * for advice. Many people had their own favorite functions, all
     * different, but no-one had much idea why they were good ones. I chose
     * the one below (multiply by 9 and add new character) because of the
     * following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
     *	  multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old). This means that each
     *	  character's bits hang around in the low-order bits of the hash value
     *	  for ever, plus they spread fairly rapidly up to the high-order bits
     *	  to fill out the hash value. This seems works well both for decimal
     *	  and non-decimal strings, but isn't strong against maliciously-chosen
     *	  keys.
     */

    result = 0;

    for (c=*string++ ; c ; c=*string++) {
	result += (result<<3) + c;
    }
    return result;
}

#if TCL_PRESERVE_BINARY_COMPATABILITY
/*
 *----------------------------------------------------------------------
 *
 * BogusFind --
 *
 *	This function is invoked when an Tcl_FindHashEntry is called on a
 *	table that has been deleted.
 *
 * Results:
 *	If Tcl_Panic returns (which it shouldn't) this function returns NULL.

 *
 * Side effects:
 *	Generates a panic.
 *
 *----------------------------------------------------------------------
 */

1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
}

/*
 *----------------------------------------------------------------------
 *
 * BogusCreate --
 *
 *	This procedure is invoked when an Tcl_CreateHashEntry is called
 *	on a table that has been deleted.
 *
 * Results:
 *	If panic returns (which it shouldn't) this procedure returns
 *	NULL.
 *
 * Side effects:
 *	Generates a panic.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static Tcl_HashEntry *
BogusCreate(tablePtr, key, newPtr)
    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
    CONST char *key;		/* Key to use to find or create matching
				 * entry. */
    int *newPtr;		/* Store info here telling whether a new
				 * entry was created. */
{
    Tcl_Panic("called Tcl_CreateHashEntry on deleted table");
    return NULL;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * RebuildTable --
 *
 *	This procedure is invoked when the ratio of entries to hash
 *	buckets becomes too large.  It creates a new table with a
 *	larger bucket array and moves all of the entries into the
 *	new table.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets reallocated and entries get re-hashed to new
 *	buckets.
 *
 *----------------------------------------------------------------------
 */

static void
RebuildTable(tablePtr)
    register Tcl_HashTable *tablePtr;	/* Table to enlarge. */







|
|


|
<













|
|











|
|
|
<





|
<







1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095

1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124

1125
1126
1127
1128
1129
1130

1131
1132
1133
1134
1135
1136
1137
}

/*
 *----------------------------------------------------------------------
 *
 * BogusCreate --
 *
 *	This function is invoked when an Tcl_CreateHashEntry is called on a
 *	table that has been deleted.
 *
 * Results:
 *	If panic returns (which it shouldn't) this function returns NULL.

 *
 * Side effects:
 *	Generates a panic.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static Tcl_HashEntry *
BogusCreate(tablePtr, key, newPtr)
    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
    CONST char *key;		/* Key to use to find or create matching
				 * entry. */
    int *newPtr;		/* Store info here telling whether a new entry
				 * was created. */
{
    Tcl_Panic("called Tcl_CreateHashEntry on deleted table");
    return NULL;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * RebuildTable --
 *
 *	This function is invoked when the ratio of entries to hash buckets
 *	becomes too large. It creates a new table with a larger bucket array
 *	and moves all of the entries into the new table.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets reallocated and entries get re-hashed to new buckets.

 *
 *----------------------------------------------------------------------
 */

static void
RebuildTable(tablePtr)
    register Tcl_HashTable *tablePtr;	/* Table to enlarge. */
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
    typePtr = tablePtr->typePtr;
#endif

    oldSize = tablePtr->numBuckets;
    oldBuckets = tablePtr->buckets;

    /*
     * Allocate and initialize the new bucket array, and set up
     * hashing constants for new array size.
     */

    tablePtr->numBuckets *= 4;
    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
	tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
		(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
    } else {







|
|







1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
    typePtr = tablePtr->typePtr;
#endif

    oldSize = tablePtr->numBuckets;
    oldBuckets = tablePtr->buckets;

    /*
     * Allocate and initialize the new bucket array, and set up hashing
     * constants for new array size.
     */

    tablePtr->numBuckets *= 4;
    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
	tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
		(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
    } else {
1232
1233
1234
1235
1236
1237
1238








	if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
	    TclpSysFree((char *) oldBuckets);
	} else {
	    ckfree((char *) oldBuckets);
	}
    }
}















>
>
>
>
>
>
>
>
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
	if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
	    TclpSysFree((char *) oldBuckets);
	} else {
	    ckfree((char *) oldBuckets);
	}
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIO.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49

50
51
52
53
54
55
56
57
58
59

60
61

62
63

64
65
66
67
68
69
70
71
72
/* 
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.c,v 1.81 2004/11/30 19:34:47 dgp Exp $
 */

#include "tclInt.h"
#include "tclIO.h"
#include <assert.h>


/*
 * All static variables used in this file are collected into a single
 * instance of the following structure.  For multi-threaded implementations,
 * there is one instance of this structure for each thread.
 *
 * Notice that different structures with the same name appear in other
 * files.  The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {

    /*
     * This variable holds the list of nested ChannelHandlerEventProc 
     * invocations.
     */
    NextChannelHandler *nestedHandlerPtr;

    /*
     * List of all channels currently open, indexed by ChannelState,
     * as only one ChannelState exists per set of stacked channels.
     */
    ChannelState *firstCSPtr;

#ifdef oldcode
    /*
     * Has a channel exit handler been created yet?
     */
    int channelExitHandlerCreated;

    /*

     * Has the channel event source been created and registered with the
     * notifier?
     */
    int channelEventSourceCreated;
#endif

    /*
     * Static variables to hold channels for stdin, stdout and stderr.
     */
    Tcl_Channel stdinChannel;

    int stdinInitialized;
    Tcl_Channel stdoutChannel;

    int stdoutInitialized;
    Tcl_Channel stderrChannel;

    int stderrInitialized;

} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Static functions in this file:
 */
|











|






<

|
|
|

|
|



>
|
|
|
<
<
|
<
|
|
<
<
|

<
<
<
|
|
<
>
|
|
<
<

<
<
<
<
|
>

|
>

|
>

<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32
33


34

35
36


37
38



39
40

41
42
43


44




45
46
47
48
49
50
51
52
53

54
55
56
57
58
59
60
/*
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.c,v 1.81.2.10 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"
#include "tclIO.h"
#include <assert.h>


/*
 * All static variables used in this file are collected into a single instance
 * of the following structure.  For multi-threaded implementations, there is
 * one instance of this structure for each thread.
 *
 * Notice that different structures with the same name appear in other files.
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {
    NextChannelHandler *nestedHandlerPtr;
					/* This variable holds the list of
					 * nested ChannelHandlerEventProc
					 * invocations. */


    ChannelState *firstCSPtr;		/* List of all channels currently

					 * open, indexed by ChannelState, as
					 * only one ChannelState exists per


					 * set of stacked channels. */
#ifdef oldcode



    int channelExitHandlerCreated;	/* Has a channel exit handler been
					 * created yet? */

    int channelEventSourceCreated;	/* Has the channel event source been
					 * created and registered with the
					 * notifier? */


#endif




    Tcl_Channel stdinChannel;		/* Static variable for the stdin
					 * channel. */
    int stdinInitialized;
    Tcl_Channel stdoutChannel;		/* Static variable for the stdout
					 * channel. */
    int stdoutInitialized;
    Tcl_Channel stderrChannel;		/* Static variable for the stderr
					 * channel. */
    int stderrInitialized;

} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Static functions in this file:
 */
144
145
146
147
148
149
150






151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
			    char *dst, CONST char *src,
			    int *dstLenPtr, int *srcLenPtr));
static void		UpdateInterest _ANSI_ARGS_((Channel *chanPtr));
static int		WriteBytes _ANSI_ARGS_((Channel *chanPtr,
			    CONST char *src, int srcLen));
static int		WriteChars _ANSI_ARGS_((Channel *chanPtr,
			    CONST char *src, int srcLen));







/*
 *---------------------------------------------------------------------------
 *
 * TclInitIOSubsystem --
 *
 *	Initialize all resources used by this subsystem on a per-process
 *	basis.  
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the memory subsystems.
 *
 *---------------------------------------------------------------------------
 */

void
TclInitIOSubsystem()
{
    /*
     * By fetching thread local storage we take care of
     * allocating it for each thread.
     */

    (void) TCL_TSD_INIT(&dataKey);
}   

/*
 *-------------------------------------------------------------------------
 *
 * TclFinalizeIOSubsystem --
 *
 *	Releases all resources used by this subsystem on a per-process 
 *	basis.  Closes all extant channels that have not already been 
 *	closed because they were not owned by any interp.  
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on encoding and memory subsystems.
 *







>
>
>
>
>
>







|














|
|

>

|






|
|
|







132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
			    char *dst, CONST char *src,
			    int *dstLenPtr, int *srcLenPtr));
static void		UpdateInterest _ANSI_ARGS_((Channel *chanPtr));
static int		WriteBytes _ANSI_ARGS_((Channel *chanPtr,
			    CONST char *src, int srcLen));
static int		WriteChars _ANSI_ARGS_((Channel *chanPtr,
			    CONST char *src, int srcLen));
static Tcl_Obj*         FixLevelCode _ANSI_ARGS_ ((Tcl_Obj* msg));


static void SpliceChannel _ANSI_ARGS_ ((Tcl_Channel chan));
static void CutChannel    _ANSI_ARGS_ ((Tcl_Channel chan));


/*
 *---------------------------------------------------------------------------
 *
 * TclInitIOSubsystem --
 *
 *	Initialize all resources used by this subsystem on a per-process
 *	basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the memory subsystems.
 *
 *---------------------------------------------------------------------------
 */

void
TclInitIOSubsystem()
{
    /*
     * By fetching thread local storage we take care of allocating it for each
     * thread.
     */

    (void) TCL_TSD_INIT(&dataKey);
}

/*
 *-------------------------------------------------------------------------
 *
 * TclFinalizeIOSubsystem --
 *
 *	Releases all resources used by this subsystem on a per-process basis.
 *	Closes all extant channels that have not already been closed because
 *	they were not owned by any interp.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on encoding and memory subsystems.
 *
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258

    for (statePtr = tsdPtr->firstCSPtr; statePtr != (ChannelState *) NULL;
	    statePtr = nextCSPtr) {
	chanPtr = statePtr->topChanPtr;
	nextCSPtr = statePtr->nextCSPtr;

	/*
	 * Set the channel back into blocking mode to ensure that we wait
	 * for all data to flush out.
	 */

	(void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
		"-blocking", "on");

	if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
		(chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
		(chanPtr == (Channel *) tsdPtr->stderrChannel)) {

	    /*
	     * Decrement the refcount which was earlier artificially bumped
	     * up to keep the channel from being closed.
	     */

	    statePtr->refCount--;
	}

	if (statePtr->refCount <= 0) {

	    /*
	     * Close it only if the refcount indicates that the channel is not
	     * referenced from any interpreter. If it is, that interpreter will
	     * close the channel when it gets destroyed.
	     */

	    (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);

	} else {

	    /*
	     * The refcount is greater than zero, so flush the channel.
	     */

	    Tcl_Flush((Tcl_Channel) chanPtr);

	    /*
	     * Call the device driver to actually close the underlying
	     * device for this channel.
	     */

	    if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
		(chanPtr->typePtr->closeProc)(chanPtr->instanceData,
			(Tcl_Interp *) NULL);
	    } else {
		(chanPtr->typePtr->close2Proc)(chanPtr->instanceData,







|
|








<

|
|






<


|
|





<







|
|







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

217
218
219
220
221
222
223
224
225

226
227
228
229
230
231
232
233
234

235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250

    for (statePtr = tsdPtr->firstCSPtr; statePtr != (ChannelState *) NULL;
	    statePtr = nextCSPtr) {
	chanPtr = statePtr->topChanPtr;
	nextCSPtr = statePtr->nextCSPtr;

	/*
	 * Set the channel back into blocking mode to ensure that we wait for
	 * all data to flush out.
	 */

	(void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
		"-blocking", "on");

	if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
		(chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
		(chanPtr == (Channel *) tsdPtr->stderrChannel)) {

	    /*
	     * Decrement the refcount which was earlier artificially bumped up
	     * to keep the channel from being closed.
	     */

	    statePtr->refCount--;
	}

	if (statePtr->refCount <= 0) {

	    /*
	     * Close it only if the refcount indicates that the channel is not
	     * referenced from any interpreter. If it is, that interpreter
	     * will close the channel when it gets destroyed.
	     */

	    (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);

	} else {

	    /*
	     * The refcount is greater than zero, so flush the channel.
	     */

	    Tcl_Flush((Tcl_Channel) chanPtr);

	    /*
	     * Call the device driver to actually close the underlying device
	     * for this channel.
	     */

	    if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
		(chanPtr->typePtr->closeProc)(chanPtr->instanceData,
			(Tcl_Interp *) NULL);
	    } else {
		(chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
266
267
268
269
270
271
272

273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
	     * on it.
	     */

	    chanPtr->instanceData = (ClientData) NULL;
	    statePtr->flags |= CHANNEL_DEAD;
	}
    }

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStdChannel --
 *
 *	This function is used to change the channels that are used
 *	for stdin/stdout/stderr in new interpreters.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetStdChannel(channel, type)
    Tcl_Channel channel;
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    switch (type) {
	case TCL_STDIN:
	    tsdPtr->stdinInitialized = 1;
	    tsdPtr->stdinChannel = channel;
	    break;
	case TCL_STDOUT:
	    tsdPtr->stdoutInitialized = 1;
	    tsdPtr->stdoutChannel = channel;
	    break;
	case TCL_STDERR:
	    tsdPtr->stderrInitialized = 1;
	    tsdPtr->stderrChannel = channel;
	    break;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStdChannel --
 *
 *	Returns the specified standard channel.
 *
 * Results:
 *	Returns the specified standard channel, or NULL.
 *
 * Side effects:
 *	May cause the creation of a standard channel and the underlying
 *	file.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_GetStdChannel(type)
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    Tcl_Channel channel = NULL;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * If the channels were not created yet, create them now and
     * store them in the static variables. 
     */

    switch (type) {
	case TCL_STDIN:
	    if (!tsdPtr->stdinInitialized) {
		tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN);
		tsdPtr->stdinInitialized = 1;

		/*
		 * Artificially bump the refcount to ensure that the channel
		 * is only closed on exit.
		 *
		 * NOTE: Must only do this if stdinChannel is not NULL. It
		 * can be NULL in situations where Tcl is unable to connect
		 * to the standard input.
		 */

		if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) {
		    (void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
			    tsdPtr->stdinChannel);
		}
	    }
	    channel = tsdPtr->stdinChannel;
	    break;
	case TCL_STDOUT:
	    if (!tsdPtr->stdoutInitialized) {
		tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT);
		tsdPtr->stdoutInitialized = 1;
		if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) {
		    (void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
			    tsdPtr->stdoutChannel);
		}
	    }
	    channel = tsdPtr->stdoutChannel;
	    break;
	case TCL_STDERR:
	    if (!tsdPtr->stderrInitialized) {
		tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR);
		tsdPtr->stderrInitialized = 1;
		if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) {
		    (void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
			    tsdPtr->stderrChannel);
		}
	    }
	    channel = tsdPtr->stderrChannel;
	    break;
    }
    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCloseHandler
 *
 *	Creates a close callback which will be called when the channel is
 *	closed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Causes the callback to be called in the future when the channel
 *	will be closed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateCloseHandler(chan, proc, clientData)
    Tcl_Channel chan;		/* The channel for which to create the
				 * close callback. */
    Tcl_CloseProc *proc;	/* The callback routine to call when the
				 * channel will be closed. */
    ClientData clientData;	/* Arbitrary data to pass to the
				 * close callback. */
{
    ChannelState *statePtr;
    CloseCallback *cbPtr;

    statePtr = ((Channel *) chan)->state;

    cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback));
    cbPtr->proc = proc;
    cbPtr->clientData = clientData;

    cbPtr->nextPtr = statePtr->closeCbPtr;
    statePtr->closeCbPtr = cbPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCloseHandler --
 *
 *	Removes a callback that would have been called on closing
 *	the channel. If there is no matching callback then this
 *	function has no effect.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The callback will not be called in the future when the channel
 *	is eventually closed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteCloseHandler(chan, proc, clientData)
    Tcl_Channel chan;		/* The channel for which to cancel the
				 * close callback. */
    Tcl_CloseProc *proc;	/* The procedure for the callback to
				 * remove. */
    ClientData clientData;	/* The callback data for the callback
				 * to remove. */
{
    ChannelState *statePtr;
    CloseCallback *cbPtr, *cbPrevPtr;

    statePtr = ((Channel *) chan)->state;
    for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL;
	    cbPtr != (CloseCallback *) NULL;







>







|
|

















|
|
|
|
|
|
|
|
|
|
|
|














|
<












|
|



|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
















|
|






|
|


|
|



















|
|
<





|
|






|
|


|
|







258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318

319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429

430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
	     * on it.
	     */

	    chanPtr->instanceData = (ClientData) NULL;
	    statePtr->flags |= CHANNEL_DEAD;
	}
    }
    TclpFinalizePipes();
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStdChannel --
 *
 *	This function is used to change the channels that are used for
 *	stdin/stdout/stderr in new interpreters.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetStdChannel(channel, type)
    Tcl_Channel channel;
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    switch (type) {
    case TCL_STDIN:
	tsdPtr->stdinInitialized = 1;
	tsdPtr->stdinChannel = channel;
	break;
    case TCL_STDOUT:
	tsdPtr->stdoutInitialized = 1;
	tsdPtr->stdoutChannel = channel;
	break;
    case TCL_STDERR:
	tsdPtr->stderrInitialized = 1;
	tsdPtr->stderrChannel = channel;
	break;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStdChannel --
 *
 *	Returns the specified standard channel.
 *
 * Results:
 *	Returns the specified standard channel, or NULL.
 *
 * Side effects:
 *	May cause the creation of a standard channel and the underlying file.

 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_GetStdChannel(type)
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    Tcl_Channel channel = NULL;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * If the channels were not created yet, create them now and store them in
     * the static variables.
     */

    switch (type) {
    case TCL_STDIN:
	if (!tsdPtr->stdinInitialized) {
	    tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN);
	    tsdPtr->stdinInitialized = 1;

	    /*
	     * Artificially bump the refcount to ensure that the channel is
	     * only closed on exit.
	     *
	     * NOTE: Must only do this if stdinChannel is not NULL. It can be
	     * NULL in situations where Tcl is unable to connect to the
	     * standard input.
	     */

	    if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) {
		(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
			tsdPtr->stdinChannel);
	    }
	}
	channel = tsdPtr->stdinChannel;
	break;
    case TCL_STDOUT:
	if (!tsdPtr->stdoutInitialized) {
	    tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT);
	    tsdPtr->stdoutInitialized = 1;
	    if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) {
		(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
			tsdPtr->stdoutChannel);
	    }
	}
	channel = tsdPtr->stdoutChannel;
	break;
    case TCL_STDERR:
	if (!tsdPtr->stderrInitialized) {
	    tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR);
	    tsdPtr->stderrInitialized = 1;
	    if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) {
		(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
			tsdPtr->stderrChannel);
	    }
	}
	channel = tsdPtr->stderrChannel;
	break;
    }
    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCloseHandler
 *
 *	Creates a close callback which will be called when the channel is
 *	closed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Causes the callback to be called in the future when the channel will
 *	be closed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateCloseHandler(chan, proc, clientData)
    Tcl_Channel chan;		/* The channel for which to create the close
				 * callback. */
    Tcl_CloseProc *proc;	/* The callback routine to call when the
				 * channel will be closed. */
    ClientData clientData;	/* Arbitrary data to pass to the close
				 * callback. */
{
    ChannelState *statePtr;
    CloseCallback *cbPtr;

    statePtr = ((Channel *) chan)->state;

    cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback));
    cbPtr->proc = proc;
    cbPtr->clientData = clientData;

    cbPtr->nextPtr = statePtr->closeCbPtr;
    statePtr->closeCbPtr = cbPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCloseHandler --
 *
 *	Removes a callback that would have been called on closing the channel.
 *	If there is no matching callback then this function has no effect.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The callback will not be called in the future when the channel is
 *	eventually closed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteCloseHandler(chan, proc, clientData)
    Tcl_Channel chan;		/* The channel for which to cancel the close
				 * callback. */
    Tcl_CloseProc *proc;	/* The procedure for the callback to
				 * remove. */
    ClientData clientData;	/* The callback data for the callback to
				 * remove. */
{
    ChannelState *statePtr;
    CloseCallback *cbPtr, *cbPrevPtr;

    statePtr = ((Channel *) chan)->state;
    for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL;
	    cbPtr != (CloseCallback *) NULL;
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
}

/*
 *----------------------------------------------------------------------
 *
 * GetChannelTable --
 *
 *	Gets and potentially initializes the channel table for an
 *	interpreter. If it is initializing the table it also inserts
 *	channels for stdin, stdout and stderr if the interpreter is
 *	trusted.
 *
 * Results:
 *	A pointer to the hash table created, for use by the caller.
 *
 * Side effects:
 *	Initializes the channel table for an interpreter. May create
 *	channels for stdin, stdout and stderr.
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashTable *
GetChannelTable(interp)
    Tcl_Interp *interp;







|
|
|
<





|
|







467
468
469
470
471
472
473
474
475
476

477
478
479
480
481
482
483
484
485
486
487
488
489
490
}

/*
 *----------------------------------------------------------------------
 *
 * GetChannelTable --
 *
 *	Gets and potentially initializes the channel table for an interpreter.
 *	If it is initializing the table it also inserts channels for stdin,
 *	stdout and stderr if the interpreter is trusted.

 *
 * Results:
 *	A pointer to the hash table created, for use by the caller.
 *
 * Side effects:
 *	Initializes the channel table for an interpreter. May create channels
 *	for stdin, stdout and stderr.
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashTable *
GetChannelTable(interp)
    Tcl_Interp *interp;
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
	Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);

	(void) Tcl_SetAssocData(interp, "tclIO",
		(Tcl_InterpDeleteProc *) DeleteChannelTable,
		(ClientData) hTblPtr);

	/*
	 * If the interpreter is trusted (not "safe"), insert channels
	 * for stdin, stdout and stderr (possibly creating them in the
	 * process).
	 */

	if (Tcl_IsSafe(interp) == 0) {
	    stdinChan = Tcl_GetStdChannel(TCL_STDIN);
	    if (stdinChan != NULL) {
		Tcl_RegisterChannel(interp, stdinChan);
	    }







|
|
<







498
499
500
501
502
503
504
505
506

507
508
509
510
511
512
513
	Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);

	(void) Tcl_SetAssocData(interp, "tclIO",
		(Tcl_InterpDeleteProc *) DeleteChannelTable,
		(ClientData) hTblPtr);

	/*
	 * If the interpreter is trusted (not "safe"), insert channels for
	 * stdin, stdout and stderr (possibly creating them in the process).

	 */

	if (Tcl_IsSafe(interp) == 0) {
	    stdinChan = Tcl_GetStdChannel(TCL_STDIN);
	    if (stdinChan != NULL) {
		Tcl_RegisterChannel(interp, stdinChan);
	    }
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553

/*
 *----------------------------------------------------------------------
 *
 * DeleteChannelTable --
 *
 *	Deletes the channel table for an interpreter, closing any open
 *	channels whose refcount reaches zero. This procedure is invoked
 *	when an interpreter is deleted, via the AssocData cleanup
 *	mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the hash table of channels. May close channels. May flush
 *	output on closed channels. Removes any channeEvent handlers that were







|
|
<







526
527
528
529
530
531
532
533
534

535
536
537
538
539
540
541

/*
 *----------------------------------------------------------------------
 *
 * DeleteChannelTable --
 *
 *	Deletes the channel table for an interpreter, closing any open
 *	channels whose refcount reaches zero. This procedure is invoked when
 *	an interpreter is deleted, via the AssocData cleanup mechanism.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the hash table of channels. May close channels. May flush
 *	output on closed channels. Removes any channeEvent handlers that were
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
{
    Tcl_HashTable *hTblPtr;	/* The hash table. */
    Tcl_HashSearch hSearch;	/* Search variable. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    Channel *chanPtr;		/* Channel being deleted. */
    ChannelState *statePtr;	/* State of Channel being deleted. */
    EventScriptRecord *sPtr, *prevPtr, *nextPtr;
    				/* Variables to loop over all channel events
				 * registered, to delete the ones that refer
				 * to the interpreter being deleted. */

    /*
     * Delete all the registered channels - this will close channels whose
     * refcount reaches zero.
     */







|







551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
{
    Tcl_HashTable *hTblPtr;	/* The hash table. */
    Tcl_HashSearch hSearch;	/* Search variable. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    Channel *chanPtr;		/* Channel being deleted. */
    ChannelState *statePtr;	/* State of Channel being deleted. */
    EventScriptRecord *sPtr, *prevPtr, *nextPtr;
				/* Variables to loop over all channel events
				 * registered, to delete the ones that refer
				 * to the interpreter being deleted. */

    /*
     * Delete all the registered channels - this will close channels whose
     * refcount reaches zero.
     */
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
	    } else {
		prevPtr = sPtr;
	    }
	}

	/*
	 * Cannot call Tcl_UnregisterChannel because that procedure calls
	 * Tcl_GetAssocData to get the channel table, which might already
	 * be inaccessible from the interpreter structure. Instead, we
	 * emulate the behavior of Tcl_UnregisterChannel directly here.
	 */

	Tcl_DeleteHashEntry(hPtr);
	statePtr->refCount--;
	if (statePtr->refCount <= 0) {
	    if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
		(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
	    }
	}
    }
    Tcl_DeleteHashTable(hTblPtr);
    ckfree((char *) hTblPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * CheckForStdChannelsBeingClosed --
 *
 *	Perform special handling for standard channels being closed. When
 *	given a standard channel, if the refcount is now 1, it means that
 *	the last reference to the standard channel is being explicitly
 *	closed. Now bump the refcount artificially down to 0, to ensure the
 *	normal handling of channels being closed will occur. Also reset the
 *	static pointer to the channel to NULL, to avoid dangling references.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Manipulates the refcount on standard channels. May smash the global
 *	static pointer to a standard channel.







|
|
|




















|
|
|
|
|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
	    } else {
		prevPtr = sPtr;
	    }
	}

	/*
	 * Cannot call Tcl_UnregisterChannel because that procedure calls
	 * Tcl_GetAssocData to get the channel table, which might already be
	 * inaccessible from the interpreter structure. Instead, we emulate
	 * the behavior of Tcl_UnregisterChannel directly here.
	 */

	Tcl_DeleteHashEntry(hPtr);
	statePtr->refCount--;
	if (statePtr->refCount <= 0) {
	    if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
		(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
	    }
	}
    }
    Tcl_DeleteHashTable(hTblPtr);
    ckfree((char *) hTblPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * CheckForStdChannelsBeingClosed --
 *
 *	Perform special handling for standard channels being closed. When
 *	given a standard channel, if the refcount is now 1, it means that the
 *	last reference to the standard channel is being explicitly closed. Now
 *	bump the refcount artificially down to 0, to ensure the normal
 *	handling of channels being closed will occur. Also reset the static
 *	pointer to the channel to NULL, to avoid dangling references.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Manipulates the refcount on standard channels. May smash the global
 *	static pointer to a standard channel.
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int 
Tcl_IsStandardChannel(chan)
    Tcl_Channel chan;		/* Channel to check. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if ((chan == tsdPtr->stdinChannel) 
	    || (chan == tsdPtr->stdoutChannel)
	    || (chan == tsdPtr->stderrChannel)) {
	return 1;
    } else {
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegisterChannel --
 *
 *	Adds an already-open channel to the channel table of an interpreter.
 *	If the interpreter passed as argument is NULL, it only increments
 *	the channel refCount.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May increment the reference count of a channel.
 *







|





|














|
|







683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsStandardChannel(chan)
    Tcl_Channel chan;		/* Channel to check. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if ((chan == tsdPtr->stdinChannel)
	    || (chan == tsdPtr->stdoutChannel)
	    || (chan == tsdPtr->stderrChannel)) {
	return 1;
    } else {
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegisterChannel --
 *
 *	Adds an already-open channel to the channel table of an interpreter.
 *	If the interpreter passed as argument is NULL, it only increments the
 *	channel refCount.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May increment the reference count of a channel.
 *
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
	Tcl_Panic("Tcl_RegisterChannel: channel without name");
    }
    if (interp != (Tcl_Interp *) NULL) {
	hTblPtr = GetChannelTable(interp);
	hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new);
	if (new == 0) {
	    if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
		return;
	    }

	    Tcl_Panic("Tcl_RegisterChannel: duplicate channel names");
	}
	Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
    }
    statePtr->refCount++;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnregisterChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  (This all happens in the Tcl_DetachChannel helper
 *	function).
 *	
 *	Finally, if the reference count of the channel drops to zero,
 *	it is deleted.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Calls Tcl_DetachChannel which deletes the hash entry for a channel 
 *	associated with an interpreter.
 *	
 *	May delete the channel, which can have a variety of consequences,
 *	especially if we are forced to close the channel.
 *
 *----------------------------------------------------------------------
 */

int







|


















|
|
|





|

|







745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
	Tcl_Panic("Tcl_RegisterChannel: channel without name");
    }
    if (interp != (Tcl_Interp *) NULL) {
	hTblPtr = GetChannelTable(interp);
	hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new);
	if (new == 0) {
	    if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
	        return;
	    }

	    Tcl_Panic("Tcl_RegisterChannel: duplicate channel names");
	}
	Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
    }
    statePtr->refCount++;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnregisterChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  (This all happens in the Tcl_DetachChannel helper
 *	function).
 *
 *	Finally, if the reference count of the channel drops to zero, it is
 *	deleted.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Calls Tcl_DetachChannel which deletes the hash entry for a channel
 *	associated with an interpreter.
 *
 *	May delete the channel, which can have a variety of consequences,
 *	especially if we are forced to close the channel.
 *
 *----------------------------------------------------------------------
 */

int
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850

851


852
853
854
855
856
857
858
    /*
     * If the refCount reached zero, close the actual channel.
     */

    if (statePtr->refCount <= 0) {

	/*
	 * Ensure that if there is another buffer, it gets flushed
	 * whether or not we are doing a background flush.
	 */

	if ((statePtr->curOutPtr != NULL) &&
		(statePtr->curOutPtr->nextAdded >
			statePtr->curOutPtr->nextRemoved)) {
	    statePtr->flags |= BUFFER_READY;
	}
	Tcl_Preserve((ClientData)statePtr);
	if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {

	    /* We don't want to re-enter Tcl_Close */


	    if (!(statePtr->flags & CHANNEL_CLOSED)) {
		if (Tcl_Close(interp, chan) != TCL_OK) {
		    statePtr->flags |= CHANNEL_CLOSED;
		    Tcl_Release((ClientData)statePtr);
		    return TCL_ERROR;
		}
	    }







|
|









>
|
>
>







821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
    /*
     * If the refCount reached zero, close the actual channel.
     */

    if (statePtr->refCount <= 0) {

	/*
	 * Ensure that if there is another buffer, it gets flushed whether or
	 * not we are doing a background flush.
	 */

	if ((statePtr->curOutPtr != NULL) &&
		(statePtr->curOutPtr->nextAdded >
			statePtr->curOutPtr->nextRemoved)) {
	    statePtr->flags |= BUFFER_READY;
	}
	Tcl_Preserve((ClientData)statePtr);
	if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
	    /*
	     * We don't want to re-enter Tcl_Close().
	     */

	    if (!(statePtr->flags & CHANNEL_CLOSED)) {
		if (Tcl_Close(interp, chan) != TCL_OK) {
		    statePtr->flags |= CHANNEL_CLOSED;
		    Tcl_Release((ClientData)statePtr);
		    return TCL_ERROR;
		}
	    }
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  Even if the ref count drops to zero, the 
 *	channel is NOT closed or cleaned up.  This allows a channel to
 *	be detached from an interpreter and left in the same state it
 *	was in when it was originally returned by 'Tcl_OpenFileChannel',
 *	for example.
 *	
 *	This function cannot be used on the standard channels, and
 *	will return TCL_ERROR if that is attempted.
 *	
 *	This function should only be necessary for special purposes
 *	in which you need to generate a pristine channel from one
 *	that has already been used.  All ordinary purposes will almost
 *	always want to use Tcl_UnregisterChannel instead.
 *	
 *	Provided the channel is not attached to any other interpreter,
 *	it can then be closed with Tcl_Close, rather than with 
 *	Tcl_UnregisterChannel.
 *
 * Results:
 *	A standard Tcl result.  If the channel is not currently registered
 *	with the given interpreter, TCL_ERROR is returned, otherwise
 *	TCL_OK.  However no error messages are left in the interp's result.
 *
 * Side effects:
 *	Deletes the hash entry for a channel associated with an 
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DetachChannel(interp, chan)
    Tcl_Interp *interp;		/* Interpreter in which channel is defined. */







|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
<



|
|


|
<







857
858
859
860
861
862
863
864
865
866
867

868
869
870
871
872
873
874
875
876
877
878

879
880
881
882
883
884
885
886

887
888
889
890
891
892
893
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  Even if the ref count drops to zero, the channel is
 *	NOT closed or cleaned up.  This allows a channel to be detached from
 *	an interpreter and left in the same state it was in when it was
 *	originally returned by 'Tcl_OpenFileChannel', for example.

 *
 *	This function cannot be used on the standard channels, and will return
 *	TCL_ERROR if that is attempted.
 *
 *	This function should only be necessary for special purposes in which
 *	you need to generate a pristine channel from one that has already been
 *	used.  All ordinary purposes will almost always want to use
 *	Tcl_UnregisterChannel instead.
 *
 *	Provided the channel is not attached to any other interpreter, it can
 *	then be closed with Tcl_Close, rather than with Tcl_UnregisterChannel.

 *
 * Results:
 *	A standard Tcl result.  If the channel is not currently registered
 *	with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK.
 *	However no error messages are left in the interp's result.
 *
 * Side effects:
 *	Deletes the hash entry for a channel associated with an interpreter.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_DetachChannel(interp, chan)
    Tcl_Interp *interp;		/* Interpreter in which channel is defined. */
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
/*
 *----------------------------------------------------------------------
 *
 * DetachChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  Even if the ref count drops to zero, the 
 *	channel is NOT closed or cleaned up.  This allows a channel to
 *	be detached from an interpreter and left in the same state it
 *	was in when it was originally returned by 'Tcl_OpenFileChannel',
 *	for example.
 *
 * Results:
 *	A standard Tcl result.  If the channel is not currently registered
 *	with the given interpreter, TCL_ERROR is returned, otherwise
 *	TCL_OK.  However no error messages are left in the interp's result.
 *
 * Side effects:
 *	Deletes the hash entry for a channel associated with an 
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
DetachChannel(interp, chan)
    Tcl_Interp *interp;		/* Interpreter in which channel is defined. */







|
|
|
|
<



|
|


|
<







903
904
905
906
907
908
909
910
911
912
913

914
915
916
917
918
919
920
921

922
923
924
925
926
927
928
/*
 *----------------------------------------------------------------------
 *
 * DetachChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  Even if the ref count drops to zero, the channel is
 *	NOT closed or cleaned up.  This allows a channel to be detached from
 *	an interpreter and left in the same state it was in when it was
 *	originally returned by 'Tcl_OpenFileChannel', for example.

 *
 * Results:
 *	A standard Tcl result.  If the channel is not currently registered
 *	with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK.
 *	However no error messages are left in the interp's result.
 *
 * Side effects:
 *	Deletes the hash entry for a channel associated with an interpreter.

 *
 *----------------------------------------------------------------------
 */

static int
DetachChannel(interp, chan)
    Tcl_Interp *interp;		/* Interpreter in which channel is defined. */
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
	}
	if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
	    return TCL_ERROR;
	}
	Tcl_DeleteHashEntry(hPtr);

	/*
	 * Remove channel handlers that refer to this interpreter, so that they
	 * will not be present if the actual close is delayed and more events
	 * happen on the channel. This may occur if the channel is shared
	 * between several interpreters, or if the channel has async
	 * flushing active.
	 */

	CleanupChannelHandlers(interp, chanPtr);
    }

    statePtr->refCount--;







|
|
|
|







953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
	}
	if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
	    return TCL_ERROR;
	}
	Tcl_DeleteHashEntry(hPtr);

	/*
	 * Remove channel handlers that refer to this interpreter, so that
	 * they will not be present if the actual close is delayed and more
	 * events happen on the channel. This may occur if the channel is
	 * shared between several interpreters, or if the channel has async
	 * flushing active.
	 */

	CleanupChannelHandlers(interp, chanPtr);
    }

    statePtr->refCount--;
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
 * Tcl_GetChannel --
 *
 *	Finds an existing Tcl_Channel structure by name in a given
 *	interpreter. This function is public because it is used by
 *	channel-type-specific functions.
 *
 * Results:
 *	A Tcl_Channel or NULL on failure. If failed, interp's result
 *	object contains an error message.  *modePtr is filled with the
 *	modes in which the channel was opened.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Channel
Tcl_GetChannel(interp, chanName, modePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find or create
				 * the channel. */
    CONST char *chanName;	/* The name of the channel. */
    int *modePtr;		/* Where to store the mode in which the
				 * channel was opened? Will contain an ORed
				 * combination of TCL_READABLE and
				 * TCL_WRITABLE, if non-NULL. */
{
    Channel *chanPtr;		/* The actual channel. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    CONST char *name;		/* Translated name. */

    /*
     * Substitute "stdin", etc.  Note that even though we immediately
     * find the channel using Tcl_GetStdChannel, we still need to look
     * it up in the specified interpreter to ensure that it is present
     * in the channel table.  Otherwise, safe interpreters would always
     * have access to the standard channels.
     */

    name = chanName;
    if ((chanName[0] == 's') && (chanName[1] == 't')) {
	chanPtr = NULL;
	if (strcmp(chanName, "stdin") == 0) {
	    chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDIN);







|
|
|









|
|












|
|
|
|
|







978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
 * Tcl_GetChannel --
 *
 *	Finds an existing Tcl_Channel structure by name in a given
 *	interpreter. This function is public because it is used by
 *	channel-type-specific functions.
 *
 * Results:
 *	A Tcl_Channel or NULL on failure. If failed, interp's result object
 *	contains an error message.  *modePtr is filled with the modes in which
 *	the channel was opened.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Channel
Tcl_GetChannel(interp, chanName, modePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find or create the
				 * channel. */
    CONST char *chanName;	/* The name of the channel. */
    int *modePtr;		/* Where to store the mode in which the
				 * channel was opened? Will contain an ORed
				 * combination of TCL_READABLE and
				 * TCL_WRITABLE, if non-NULL. */
{
    Channel *chanPtr;		/* The actual channel. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    CONST char *name;		/* Translated name. */

    /*
     * Substitute "stdin", etc.  Note that even though we immediately find the
     * channel using Tcl_GetStdChannel, we still need to look it up in the
     * specified interpreter to ensure that it is present in the channel
     * table.  Otherwise, safe interpreters would always have access to the
     * standard channels.
     */

    name = chanName;
    if ((chanName[0] == 's') && (chanName[1] == 't')) {
	chanPtr = NULL;
	if (strcmp(chanName, "stdin") == 0) {
	    chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDIN);
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
    if (hPtr == (Tcl_HashEntry *) NULL) {
	Tcl_AppendResult(interp, "can not find channel named \"",
		chanName, "\"", (char *) NULL);
	return NULL;
    }

    /*
     * Always return bottom-most channel in the stack.  This one lives
     * the longest - other channels may go away unnoticed.
     * The other APIs compensate where necessary to retrieve the
     * topmost channel again.
     */

    chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
    chanPtr = chanPtr->state->bottomChanPtr;
    if (modePtr != NULL) {
	*modePtr = (chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE));
    }

    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannel --
 *
 *	Creates a new entry in the hash table for a Tcl_Channel
 *	record.
 *
 * Results:
 *	Returns the new Tcl_Channel.
 *
 * Side effects:
 *	Creates a new Tcl_Channel instance and inserts it into the
 *	hash table.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
    Tcl_ChannelType *typePtr;	/* The channel type record. */
    CONST char *chanName;	/* Name of channel to record. */
    ClientData instanceData;	/* Instance specific data. */
    int mask;			/* TCL_READABLE & TCL_WRITABLE to indicate
				 * if the channel is readable, writable. */
{
    Channel *chanPtr;		/* The channel structure newly created. */
    ChannelState *statePtr;	/* The stack-level independent state info
				 * for the channel. */
    CONST char *name;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * With the change of the Tcl_ChannelType structure to use a version in
     * 8.3.2+, we have to make sure that our assumption that the structure
     * remains a binary compatible size is true.
     *
     * If this assertion fails on some system, then it can be removed
     * only if the user recompiles code with older channel drivers in
     * the new system as well.
     */

    assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*));

    /*
     * JH: We could subsequently memset these to 0 to avoid the
     * numerous assignments to 0/NULL below.
     */

    chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));
    statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState));
    chanPtr->state = statePtr;

    chanPtr->instanceData = instanceData;







|
|
|
<
















|
<





|
<









|
|


|
|








|
|
|





|
|







1035
1036
1037
1038
1039
1040
1041
1042
1043
1044

1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061

1062
1063
1064
1065
1066
1067

1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
    if (hPtr == (Tcl_HashEntry *) NULL) {
	Tcl_AppendResult(interp, "can not find channel named \"",
		chanName, "\"", (char *) NULL);
	return NULL;
    }

    /*
     * Always return bottom-most channel in the stack. This one lives the
     * longest - other channels may go away unnoticed. The other APIs
     * compensate where necessary to retrieve the topmost channel again.

     */

    chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
    chanPtr = chanPtr->state->bottomChanPtr;
    if (modePtr != NULL) {
	*modePtr = (chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE));
    }

    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannel --
 *
 *	Creates a new entry in the hash table for a Tcl_Channel record.

 *
 * Results:
 *	Returns the new Tcl_Channel.
 *
 * Side effects:
 *	Creates a new Tcl_Channel instance and inserts it into the hash table.

 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
    Tcl_ChannelType *typePtr;	/* The channel type record. */
    CONST char *chanName;	/* Name of channel to record. */
    ClientData instanceData;	/* Instance specific data. */
    int mask;			/* TCL_READABLE & TCL_WRITABLE to indicate if
				 * the channel is readable, writable. */
{
    Channel *chanPtr;		/* The channel structure newly created. */
    ChannelState *statePtr;	/* The stack-level independent state info for
				 * the channel. */
    CONST char *name;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * With the change of the Tcl_ChannelType structure to use a version in
     * 8.3.2+, we have to make sure that our assumption that the structure
     * remains a binary compatible size is true.
     *
     * If this assertion fails on some system, then it can be removed only if
     * the user recompiles code with older channel drivers in the new system
     * as well.
     */

    assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*));

    /*
     * JH: We could subsequently memset these to 0 to avoid the numerous
     * assignments to 0/NULL below.
     */

    chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));
    statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState));
    chanPtr->state = statePtr;

    chanPtr->instanceData = instanceData;
1137
1138
1139
1140
1141
1142
1143






1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
	Tcl_Panic("Tcl_CreateChannel: NULL channel name");
    }

    statePtr->flags = mask;

    /*
     * Set the channel to system default encoding.






     */

    statePtr->encoding = NULL;
    name = Tcl_GetEncodingName(NULL);
    if (strcmp(name, "binary") != 0) {
    	statePtr->encoding = Tcl_GetEncoding(NULL, name);
    }
    statePtr->inputEncodingState	= NULL;
    statePtr->inputEncodingFlags	= TCL_ENCODING_START;
    statePtr->outputEncodingState	= NULL;
    statePtr->outputEncodingFlags	= TCL_ENCODING_START;

    /*
     * Set the channel up initially in AUTO input translation mode to
     * accept "\n", "\r" and "\r\n". Output translation mode is set to
     * a platform specific default value. The eofChar is set to 0 for both
     * input and output, so that Tcl does not look for an in-file EOF
     * indicator (e.g. ^Z) and does not append an EOF indicator to files.
     */

    statePtr->inputTranslation	= TCL_TRANSLATE_AUTO;
    statePtr->outputTranslation	= TCL_PLATFORM_TRANSLATION;
    statePtr->inEofChar		= 0;
    statePtr->outEofChar	= 0;








>
>
>
>
>
>





|







|
|
|
|
|







1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
	Tcl_Panic("Tcl_CreateChannel: NULL channel name");
    }

    statePtr->flags = mask;

    /*
     * Set the channel to system default encoding.
     *
     * Note the strange bit of protection taking place here.  If the system
     * encoding name is reported back as "binary", something weird is
     * happening.  Tcl provides no "binary" encoding, so someone else has
     * provided one.  We ignore it so as not to interfere with the "magic"
     * interpretation that Tcl_Channels give to the "-encoding binary" option.
     */

    statePtr->encoding = NULL;
    name = Tcl_GetEncodingName(NULL);
    if (strcmp(name, "binary") != 0) {
	statePtr->encoding = Tcl_GetEncoding(NULL, name);
    }
    statePtr->inputEncodingState	= NULL;
    statePtr->inputEncodingFlags	= TCL_ENCODING_START;
    statePtr->outputEncodingState	= NULL;
    statePtr->outputEncodingFlags	= TCL_ENCODING_START;

    /*
     * Set the channel up initially in AUTO input translation mode to accept
     * "\n", "\r" and "\r\n". Output translation mode is set to a platform
     * specific default value. The eofChar is set to 0 for both input and
     * output, so that Tcl does not look for an in-file EOF indicator
     * (e.g. ^Z) and does not append an EOF indicator to files.
     */

    statePtr->inputTranslation	= TCL_TRANSLATE_AUTO;
    statePtr->outputTranslation	= TCL_PLATFORM_TRANSLATION;
    statePtr->inEofChar		= 0;
    statePtr->outEofChar	= 0;

1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201




1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215

1216



1217
1218
1219

1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284

1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
















1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435

1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468







1469
1470
1471

1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
    statePtr->outputStage	= NULL;
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *)
		ckalloc((unsigned) (statePtr->bufSize + 2));
    }

    /*
     * As we are creating the channel, it is obviously the top for now
     */

    statePtr->topChanPtr	= chanPtr;
    statePtr->bottomChanPtr	= chanPtr;
    chanPtr->downChanPtr	= (Channel *) NULL;
    chanPtr->upChanPtr		= (Channel *) NULL;
    chanPtr->inQueueHead	= (ChannelBuffer *) NULL;
    chanPtr->inQueueTail	= (ChannelBuffer *) NULL;





    /*
     * Link the channel into the list of all channels; create an on-exit
     * handler if there is not one already, to close off all the channels
     * in the list on exit.
     *
     * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
     */

    statePtr->nextCSPtr = tsdPtr->firstCSPtr;
    tsdPtr->firstCSPtr = statePtr;

    /*
     * TIP #10. Mark the current thread as the one managing the new
     *		channel. Note: 'Tcl_GetCurrentThread' returns sensible

     *		values even for a non-threaded core.



     */

    statePtr->managingThread = Tcl_GetCurrentThread();


    /*
     * Install this channel in the first empty standard channel slot, if
     * the channel was previously closed explicitly.
     */

    if ((tsdPtr->stdinChannel == NULL) &&
	    (tsdPtr->stdinInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN);
	Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } else if ((tsdPtr->stdoutChannel == NULL) &&
	    (tsdPtr->stdoutInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT);
	Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } else if ((tsdPtr->stderrChannel == NULL) &&
	    (tsdPtr->stderrInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR);
	Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } 
    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StackChannel --
 *
 *	Replaces an entry in the hash table for a Tcl_Channel
 *	record. The replacement is a new channel with same name,
 *	it supercedes the replaced channel. Input and output of
 *	the superceded channel is now going through the newly
 *	created channel and allows the arbitrary filtering/manipulation
 *	of the dataflow.
 *
 *	Andreas Kupries <[email protected]>, 12/13/1998
 *	"Trf-Patch for filtering channels"
 *
 * Results:
 *	Returns the new Tcl_Channel, which actually contains the
 *	saved information about prevChan.
 *
 * Side effects:
 *    A new channel structure is allocated and linked below
 *    the existing channel.  The channel operations and client
 *    data of the existing channel are copied down to the newly
 *    created channel, and the current channel has its operations
 *    replaced by the new typePtr.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan)
    Tcl_Interp *interp;		/* The interpreter we are working in */
    Tcl_ChannelType *typePtr;	/* The channel type record for the new
				 * channel. */
    ClientData instanceData;	/* Instance specific data for the new
				 * channel. */
    int mask;			/* TCL_READABLE & TCL_WRITABLE to indicate
				 * if the channel is readable, writable. */
    Tcl_Channel prevChan;	/* The channel structure to replace */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr, *prevChanPtr;
    ChannelState *statePtr;


    /*
     * Find the given channel in the list of all channels.
     * If we don't find it, then it was never registered correctly.
     *
     * This operation should occur at the top of a channel stack.
     */

    statePtr = (ChannelState *) tsdPtr->firstCSPtr;
    prevChanPtr = ((Channel *) prevChan)->state->topChanPtr;

    while (statePtr->topChanPtr != prevChanPtr) {
	statePtr = statePtr->nextCSPtr;
    }

    if (statePtr == NULL) {
	Tcl_AppendResult(interp, "couldn't find state for channel \"",
		Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
	return (Tcl_Channel) NULL;
    }

    /*
     * Here we check if the given "mask" matches the "flags"
     * of the already existing channel.
     *
     *	  | - | R | W | RW |
     *	--+---+---+---+----+	<=>  0 != (chan->mask & prevChan->mask)
     *	- |   |   |   |    |
     *	R |   | + |   | +  |	The superceding channel is allowed to
     *	W |   |   | + | +  |	restrict the capabilities of the
     *	RW|   | + | + | +  |	superceded one !
     *	--+---+---+---+----+
     */

    if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
	Tcl_AppendResult(interp,
		"reading and writing both disallowed for channel \"",
		Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
	return (Tcl_Channel) NULL;
    }

    /*
     * Flush the buffers. This ensures that any data still in them
     * at this time is not handled by the new transformation. Restrict
     * this to writable channels. Take care to hide a possible bg-copy
     * in progress from Tcl_Flush and the CheckForChannelErrors inside.
     */

    if ((mask & TCL_WRITABLE) != 0) {
	CopyState *csPtr;

	csPtr = statePtr->csPtr;
	statePtr->csPtr = (CopyState *) NULL;

	if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
	    statePtr->csPtr = csPtr;
	    Tcl_AppendResult(interp, "could not flush channel \"",
		    Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
	    return (Tcl_Channel) NULL;
	}

	statePtr->csPtr = csPtr;
    }
    /*
     * Discard any input in the buffers. They are not yet read by the
     * user of the channel, so they have to go through the new
     * transformation before reading. As the buffers contain the
     * untransformed form their contents are not only useless but actually
     * distorts our view of the system.
     *
     * To preserve the information without having to read them again and
     * to avoid problems with the location in the channel (seeking might
     * be impossible) we move the buffers from the common state structure
     * into the channel itself. We use the buffers in the channel below
     * the new transformation to hold the data. In the future this allows
     * us to write transformations which pre-read data and push the unused
     * part back when they are going away.
     */

    if (((mask & TCL_READABLE) != 0) &&
	    (statePtr->inQueueHead != (ChannelBuffer *) NULL)) {
	/*
	 * Remark: It is possible that the channel buffers contain
	 * data from some earlier push-backs.
	 */

	statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead;
	prevChanPtr->inQueueHead = statePtr->inQueueHead;

	if (prevChanPtr->inQueueTail == (ChannelBuffer *) NULL) {
	    prevChanPtr->inQueueTail = statePtr->inQueueTail;
	}

	statePtr->inQueueHead = (ChannelBuffer *) NULL;
	statePtr->inQueueTail = (ChannelBuffer *) NULL;
    }

    chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));

    /*
     * Save some of the current state into the new structure,
     * reinitialize the parts which will stay with the transformation.
     *
     * Remarks:
     */

    chanPtr->state		= statePtr;
    chanPtr->instanceData	= instanceData;
    chanPtr->typePtr		= typePtr;
    chanPtr->downChanPtr	= prevChanPtr;
    chanPtr->upChanPtr		= (Channel *) NULL;
    chanPtr->inQueueHead	= (ChannelBuffer *) NULL;
    chanPtr->inQueueTail	= (ChannelBuffer *) NULL;

    /*
     * Place new block at the head of a possibly existing list of previously
     * stacked channels.
     */

    prevChanPtr->upChanPtr	= chanPtr;
    statePtr->topChanPtr	= chanPtr;

















    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnstackChannel --
 *
 *	Unstacks an entry in the hash table for a Tcl_Channel
 *	record. This is the reverse to 'Tcl_StackChannel'.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the posix error code will be set
 *	with Tcl_SetErrno.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnstackChannel(interp, chan)
    Tcl_Interp *interp; /* The interpreter we are working in */
    Tcl_Channel chan;   /* The channel to unstack */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;
    int result = 0;


    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;

    if (chanPtr->downChanPtr != (Channel *) NULL) {
	/*
	 * Instead of manipulating the per-thread / per-interp list/hashtable
	 * of registered channels we wind down the state of the transformation,
	 * and then restore the state of underlying channel into the old
	 * structure.
	 */

	Channel *downChanPtr = chanPtr->downChanPtr;

	/*
	 * Flush the buffers. This ensures that any data still in them
	 * at this time _is_ handled by the transformation we are unstacking
	 * right now. Restrict this to writable channels. Take care to hide
	 * a possible bg-copy in progress from Tcl_Flush and the
	 * CheckForChannelErrors inside.
	 */

	if (statePtr->flags & TCL_WRITABLE) {
	    CopyState *csPtr;

	    csPtr = statePtr->csPtr;
	    statePtr->csPtr = (CopyState *) NULL;

	    if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
		statePtr->csPtr = csPtr;







		Tcl_AppendResult(interp, "could not flush channel \"",
			Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
			(char *) NULL);

		return TCL_ERROR;
	    }

	    statePtr->csPtr = csPtr;
	}

	/*
	 * Anything in the input queue and the push-back buffers of
	 * the transformation going away is transformed data, but not
	 * yet read. As unstacking means that the caller does not want
	 * to see transformed data any more we have to discard these
	 * bytes. To avoid writing an analogue to 'DiscardInputQueued'
	 * we move the information in the push back buffers to the
	 * input queue and then call 'DiscardInputQueued' on that.
	 */

	if (((statePtr->flags & TCL_READABLE) != 0) &&
		((statePtr->inQueueHead != (ChannelBuffer *) NULL) ||
		(chanPtr->inQueueHead  != (ChannelBuffer *) NULL))) {

	    if ((statePtr->inQueueHead != (ChannelBuffer *) NULL) &&







|









>
>
>
>


|
|


<
|
<
<
|
<
|
|
>
|
>
>
>


|
>


|
|


|
<










|








|
|
|
<
|
|

|
|


|
|


|
|
|
<
|











|
|





>


|
|


















|
|




|
|
|











|
|
|
|


















|
|
|
<
|

|
|
|
|
|
|
|





|
|
















|
|



















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
|





|
|












>


















|
|
|
|











>
>
>
>
>
>
>
|
|
|
>







|
|
|
|
|
|
|







1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200

1201


1202

1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220

1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242

1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256

1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343

1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
    statePtr->outputStage	= NULL;
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *)
		ckalloc((unsigned) (statePtr->bufSize + 2));
    }

    /*
     * As we are creating the channel, it is obviously the top for now.
     */

    statePtr->topChanPtr	= chanPtr;
    statePtr->bottomChanPtr	= chanPtr;
    chanPtr->downChanPtr	= (Channel *) NULL;
    chanPtr->upChanPtr		= (Channel *) NULL;
    chanPtr->inQueueHead	= (ChannelBuffer *) NULL;
    chanPtr->inQueueTail	= (ChannelBuffer *) NULL;

    /* TIP #219, Tcl Channel Reflection API */
    statePtr->chanMsg           = NULL;
    statePtr->unreportedMsg     = NULL;

    /*
     * Link the channel into the list of all channels; create an on-exit
     * handler if there is not one already, to close off all the channels in
     * the list on exit.
     *
     * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.

     *


     * TIP #218.

     * AK: Just initialize the field to NULL before invoking Tcl_SpliceChannel
     *	   We need Tcl_SpliceChannel, for the threadAction calls.  There is no
     *	   real reason to duplicate all of this.
     * NOTE: All drivers using thread actions now have to perform their TSD
     *	     manipulation only in their thread action proc. Doing it when
     *	     creating their instance structures will collide with the thread
     *	     action activity and lead to damaged lists.
     */

    statePtr->nextCSPtr = (ChannelState *) NULL;
    SpliceChannel ((Tcl_Channel) chanPtr);

    /*
     * Install this channel in the first empty standard channel slot, if the
     * channel was previously closed explicitly.
     */

    if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) {

	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN);
	Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } else if ((tsdPtr->stdoutChannel == NULL) &&
	    (tsdPtr->stdoutInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT);
	Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } else if ((tsdPtr->stderrChannel == NULL) &&
	    (tsdPtr->stderrInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR);
	Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    }
    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StackChannel --
 *
 *	Replaces an entry in the hash table for a Tcl_Channel record. The
 *	replacement is a new channel with same name, it supercedes the
 *	replaced channel. Input and output of the superceded channel is now

 *	going through the newly created channel and allows the arbitrary
 *	filtering/manipulation of the dataflow.
 *
 *	Andreas Kupries <[email protected]>, 12/13/1998 "Trf-Patch for
 *	filtering channels"
 *
 * Results:
 *	Returns the new Tcl_Channel, which actually contains the saved
 *	information about prevChan.
 *
 * Side effects:
 *    A new channel structure is allocated and linked below the existing
 *    channel.  The channel operations and client data of the existing channel
 *    are copied down to the newly created channel, and the current channel

 *    has its operations replaced by the new typePtr.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan)
    Tcl_Interp *interp;		/* The interpreter we are working in */
    Tcl_ChannelType *typePtr;	/* The channel type record for the new
				 * channel. */
    ClientData instanceData;	/* Instance specific data for the new
				 * channel. */
    int mask;			/* TCL_READABLE & TCL_WRITABLE to indicate if
				 * the channel is readable, writable. */
    Tcl_Channel prevChan;	/* The channel structure to replace */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr, *prevChanPtr;
    ChannelState *statePtr;
    Tcl_DriverThreadActionProc *threadActionProc;

    /*
     * Find the given channel (prevChan) in the list of all channels.  If we don't find
     * it, then it was never registered correctly.
     *
     * This operation should occur at the top of a channel stack.
     */

    statePtr = (ChannelState *) tsdPtr->firstCSPtr;
    prevChanPtr = ((Channel *) prevChan)->state->topChanPtr;

    while (statePtr->topChanPtr != prevChanPtr) {
	statePtr = statePtr->nextCSPtr;
    }

    if (statePtr == NULL) {
	Tcl_AppendResult(interp, "couldn't find state for channel \"",
		Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
	return (Tcl_Channel) NULL;
    }

    /*
     * Here we check if the given "mask" matches the "flags" of the already
     * existing channel.
     *
     *	  | - | R | W | RW |
     *	--+---+---+---+----+	<=>  0 != (chan->mask & prevChan->mask)
     *	- |   |   |   |    |
     *	R |   | + |   | +  |	The superceding channel is allowed to restrict
     *	W |   |   | + | +  |	the capabilities of the superceded one!
     *	RW|   | + | + | +  |
     *	--+---+---+---+----+
     */

    if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
	Tcl_AppendResult(interp,
		"reading and writing both disallowed for channel \"",
		Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
	return (Tcl_Channel) NULL;
    }

    /*
     * Flush the buffers. This ensures that any data still in them at this
     * time is not handled by the new transformation. Restrict this to
     * writable channels. Take care to hide a possible bg-copy in progress
     * from Tcl_Flush and the CheckForChannelErrors inside.
     */

    if ((mask & TCL_WRITABLE) != 0) {
	CopyState *csPtr;

	csPtr = statePtr->csPtr;
	statePtr->csPtr = (CopyState *) NULL;

	if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
	    statePtr->csPtr = csPtr;
	    Tcl_AppendResult(interp, "could not flush channel \"",
		    Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
	    return (Tcl_Channel) NULL;
	}

	statePtr->csPtr = csPtr;
    }
    /*
     * Discard any input in the buffers. They are not yet read by the user of
     * the channel, so they have to go through the new transformation before
     * reading. As the buffers contain the untransformed form their contents

     * are not only useless but actually distorts our view of the system.
     *
     * To preserve the information without having to read them again and to
     * avoid problems with the location in the channel (seeking might be
     * impossible) we move the buffers from the common state structure into
     * the channel itself. We use the buffers in the channel below the new
     * transformation to hold the data. In the future this allows us to write
     * transformations which pre-read data and push the unused part back when
     * they are going away.
     */

    if (((mask & TCL_READABLE) != 0) &&
	    (statePtr->inQueueHead != (ChannelBuffer *) NULL)) {
	/*
	 * Remark: It is possible that the channel buffers contain data from
	 * some earlier push-backs.
	 */

	statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead;
	prevChanPtr->inQueueHead = statePtr->inQueueHead;

	if (prevChanPtr->inQueueTail == (ChannelBuffer *) NULL) {
	    prevChanPtr->inQueueTail = statePtr->inQueueTail;
	}

	statePtr->inQueueHead = (ChannelBuffer *) NULL;
	statePtr->inQueueTail = (ChannelBuffer *) NULL;
    }

    chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));

    /*
     * Save some of the current state into the new structure, reinitialize the
     * parts which will stay with the transformation.
     *
     * Remarks:
     */

    chanPtr->state		= statePtr;
    chanPtr->instanceData	= instanceData;
    chanPtr->typePtr		= typePtr;
    chanPtr->downChanPtr	= prevChanPtr;
    chanPtr->upChanPtr		= (Channel *) NULL;
    chanPtr->inQueueHead	= (ChannelBuffer *) NULL;
    chanPtr->inQueueTail	= (ChannelBuffer *) NULL;

    /*
     * Place new block at the head of a possibly existing list of previously
     * stacked channels.
     */

    prevChanPtr->upChanPtr	= chanPtr;
    statePtr->topChanPtr	= chanPtr;

    /* TIP #218, Channel Thread Actions.
     *
     * We call the thread actions for the new channel directly. We _cannot_
     * use SpliceChannel, because the (thread-)global list of all channels
     * always contains the _ChannelState_ for a stack of channels, not the
     * individual channels. And SpliceChannel would not only call the thread
     * actions, but also add the shared ChannelState to this list a second
     * time, mangling it.
     */

    threadActionProc = Tcl_ChannelThreadActionProc (chanPtr->typePtr);
    if (threadActionProc != NULL) {
	(*threadActionProc) (chanPtr->instanceData,
			     TCL_CHANNEL_THREAD_INSERT);
    }

    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnstackChannel --
 *
 *	Unstacks an entry in the hash table for a Tcl_Channel record. This is
 *	the reverse to 'Tcl_StackChannel'.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the posix error code will be set with
 *	Tcl_SetErrno. May leave a message in interp result as well.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnstackChannel(interp, chan)
    Tcl_Interp *interp; /* The interpreter we are working in */
    Tcl_Channel chan;   /* The channel to unstack */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;
    int result = 0;
    Tcl_DriverThreadActionProc *threadActionProc;

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;

    if (chanPtr->downChanPtr != (Channel *) NULL) {
	/*
	 * Instead of manipulating the per-thread / per-interp list/hashtable
	 * of registered channels we wind down the state of the transformation,
	 * and then restore the state of underlying channel into the old
	 * structure.
	 */

	Channel *downChanPtr = chanPtr->downChanPtr;

	/*
	 * Flush the buffers. This ensures that any data still in them at this
	 * time _is_ handled by the transformation we are unstacking right
	 * now. Restrict this to writable channels. Take care to hide a
	 * possible bg-copy in progress from Tcl_Flush and the
	 * CheckForChannelErrors inside.
	 */

	if (statePtr->flags & TCL_WRITABLE) {
	    CopyState *csPtr;

	    csPtr = statePtr->csPtr;
	    statePtr->csPtr = (CopyState *) NULL;

	    if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
		statePtr->csPtr = csPtr;
		/* TIP #219, Tcl Channel Reflection API.
		 * Move error messages put by the driver into the chan/ip
		 * bypass area into the regular interpreter result. Fall back
		 * to the regular message if nothing was found in the
		 * bypasses.
		 */
		if (!TclChanCaughtErrorBypass (interp, chan)) {
		    Tcl_AppendResult(interp, "could not flush channel \"",
				     Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
				     (char *) NULL);
		}
		return TCL_ERROR;
	    }

	    statePtr->csPtr = csPtr;
	}

	/*
	 * Anything in the input queue and the push-back buffers of the
	 * transformation going away is transformed data, but not yet read. As
	 * unstacking means that the caller does not want to see transformed
	 * data any more we have to discard these bytes. To avoid writing an
	 * analogue to 'DiscardInputQueued' we move the information in the
	 * push back buffers to the input queue and then call
	 * 'DiscardInputQueued' on that.
	 */

	if (((statePtr->flags & TCL_READABLE) != 0) &&
		((statePtr->inQueueHead != (ChannelBuffer *) NULL) ||
		(chanPtr->inQueueHead  != (ChannelBuffer *) NULL))) {

	    if ((statePtr->inQueueHead != (ChannelBuffer *) NULL) &&
1501
1502
1503
1504
1505
1506
1507

















1508
1509
1510
1511
1512
1513
1514
	    }

	    chanPtr->inQueueHead = (ChannelBuffer *) NULL;
	    chanPtr->inQueueTail = (ChannelBuffer *) NULL;

	    DiscardInputQueued(statePtr, 0);
	}


















	statePtr->topChanPtr = downChanPtr;
	downChanPtr->upChanPtr = (Channel *) NULL;

	/*
	 * Leave this link intact for closeproc
	 *  chanPtr->downChanPtr = (Channel *) NULL;







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
	    }

	    chanPtr->inQueueHead = (ChannelBuffer *) NULL;
	    chanPtr->inQueueTail = (ChannelBuffer *) NULL;

	    DiscardInputQueued(statePtr, 0);
	}

	/* TIP #218, Channel Thread Actions.
	 *
	 * We call the thread actions for the new channel directly. We
	 * _cannot_ use CutChannel, because the (thread-)global list of all
	 * channels always contains the _ChannelState_ for a stack of
	 * channels, not the individual channels. And SpliceChannel would not
	 * only call the thread actions, but also remove the shared
	 * ChannelState from this list despite there being more channels for
	 * the state which are still active.
	 */

	threadActionProc = Tcl_ChannelThreadActionProc (chanPtr->typePtr);
	if (threadActionProc != NULL) {
	    (*threadActionProc) (chanPtr->instanceData,
				 TCL_CHANNEL_THREAD_REMOVE);
	}

	statePtr->topChanPtr = downChanPtr;
	downChanPtr->upChanPtr = (Channel *) NULL;

	/*
	 * Leave this link intact for closeproc
	 *  chanPtr->downChanPtr = (Channel *) NULL;
1533
1534
1535
1536
1537
1538
1539





1540
1541
1542
1543
1544
1545
1546
1547
1548
1549




1550
1551
1552






1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
	 */

	Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
	UpdateInterest(downChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);





	    return TCL_ERROR;
	}
    } else {
	/*
	 * This channel does not cover another one.
	 * Simply do a close, if necessary.
	 */

	if (statePtr->refCount <= 0) {
	    if (Tcl_Close(interp, chan) != TCL_OK) {




		return TCL_ERROR;
	    }
	}






    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStackedChannel --
 *
 *	Determines whether the specified channel is stacked upon another.
 *
 * Results:
 *	NULL if the channel is not stacked upon another one, or a reference
 *	to the channel it is stacked upon. This reference can be used in
 *	queries, but modification is not allowed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








>
>
>
>
>




|
|




>
>
>
>



>
>
>
>
>
>













|
|
|







1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
	 */

	Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
	UpdateInterest(downChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);
	    /* TIP #219, Tcl Channel Reflection API.
	     * Move error messages put by the driver into the chan/ip bypass
	     * area into the regular interpreter result.
	     */
	    TclChanCaughtErrorBypass (interp, chan);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * This channel does not cover another one.  Simply do a close, if
	 * necessary.
	 */

	if (statePtr->refCount <= 0) {
	    if (Tcl_Close(interp, chan) != TCL_OK) {
		/* TIP #219, Tcl Channel Reflection API.
		 * "TclChanCaughtErrorBypass" is not required here, it was
		 * done already by "Tcl_Close".
		 */
		return TCL_ERROR;
	    }
	}

	/* TIP #218, Channel Thread Actions.
	 * Not required in this branch, this is done by Tcl_Close. If
	 * Tcl_Close is not called then the ChannelState is still active in
	 * the thread and no action has to be taken either.
	 */
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStackedChannel --
 *
 *	Determines whether the specified channel is stacked upon another.
 *
 * Results:
 *	NULL if the channel is not stacked upon another one, or a reference to
 *	the channel it is stacked upon. This reference can be used in queries,
 *	but modification is not allowed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
 *----------------------------------------------------------------------
 *
 * Tcl_GetTopChannel --
 *
 *	Returns the top channel of a channel stack.
 *
 * Results:
 *	NULL if the channel is not stacked upon another one, or a reference
 *	to the channel it is stacked upon. This reference can be used in
 *	queries, but modification is not allowed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|







1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
 *----------------------------------------------------------------------
 *
 * Tcl_GetTopChannel --
 *
 *	Returns the top channel of a channel stack.
 *
 * Results:
 *	NULL if the channel is not stacked upon another one, or a reference to
 *	the channel it is stacked upon. This reference can be used in queries,
 *	but modification is not allowed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656

1657
1658
1659
1660
1661
1662
1663
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelThread --
 *
 *	Given a channel structure, returns the thread managing it.
 *	TIP #10
 *
 * Results:
 *	Returns the id of the thread managing the channel.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadId
Tcl_GetChannelThread(chan)
    Tcl_Channel chan;		/* The channel to return managing thread for. */

{
    Channel *chanPtr = (Channel *) chan;	/* The actual channel. */

    return chanPtr->state->managingThread;
}

/*







|
<












|
>







1683
1684
1685
1686
1687
1688
1689
1690

1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelThread --
 *
 *	Given a channel structure, returns the thread managing it.  TIP #10

 *
 * Results:
 *	Returns the id of the thread managing the channel.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadId
Tcl_GetChannelThread(chan)
    Tcl_Channel chan;		/* The channel to return managing thread
				 * for. */
{
    Channel *chanPtr = (Channel *) chan;	/* The actual channel. */

    return chanPtr->state->managingThread;
}

/*
1676
1677
1678
1679
1680
1681
1682
1683

1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
 *----------------------------------------------------------------------
 */

Tcl_ChannelType *
Tcl_GetChannelType(chan)
    Tcl_Channel chan;		/* The channel to return type for. */
{
    Channel *chanPtr = (Channel *) chan;	/* The actual channel. */


    return chanPtr->typePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelMode --
 *
 *	Computes a mask indicating whether the channel is open for
 *	reading and writing.
 *
 * Results:
 *	An OR-ed combination of TCL_READABLE and TCL_WRITABLE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetChannelMode(chan)
    Tcl_Channel chan;		/* The channel for which the mode is
				 * being computed. */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
					/* State of actual channel. */

    return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE));
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelName --
 *
 *	Returns the string identifying the channel name.
 *
 * Results:
 *	The string containing the channel name. This memory is
 *	owned by the generic layer and should not be modified by
 *	the caller.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
>









|
|












|
|


|












|
|
<







1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774

1775
1776
1777
1778
1779
1780
1781
 *----------------------------------------------------------------------
 */

Tcl_ChannelType *
Tcl_GetChannelType(chan)
    Tcl_Channel chan;		/* The channel to return type for. */
{
    Channel *chanPtr = (Channel *) chan;
				/* The actual channel. */

    return chanPtr->typePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelMode --
 *
 *	Computes a mask indicating whether the channel is open for reading and
 *	writing.
 *
 * Results:
 *	An OR-ed combination of TCL_READABLE and TCL_WRITABLE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetChannelMode(chan)
    Tcl_Channel chan;		/* The channel for which the mode is being
				 * computed. */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of actual channel. */

    return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE));
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelName --
 *
 *	Returns the string identifying the channel name.
 *
 * Results:
 *	The string containing the channel name. This memory is owned by the
 *	generic layer and should not be modified by the caller.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
}

/*
 *---------------------------------------------------------------------------
 *
 * AllocChannelBuffer --
 *
 *	A channel buffer has BUFFER_PADDING bytes extra at beginning to
 *	hold any bytes of a native-encoding character that got split by
 *	the end of the previous buffer and need to be moved to the
 *	beginning of the next buffer to make a contiguous string so it
 *	can be converted to UTF-8.
 *
 *	A channel buffer has BUFFER_PADDING bytes extra at the end to
 *	hold any bytes of a native-encoding character (generated from a
 *	UTF-8 character) that overflow past the end of the buffer and
 *	need to be moved to the next buffer.
 *
 * Results:
 *	A newly allocated channel buffer.
 *
 * Side effects:
 *	None.
 *







|
|
|
|
<

|
|
|
|







1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836

1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
}

/*
 *---------------------------------------------------------------------------
 *
 * AllocChannelBuffer --
 *
 *	A channel buffer has BUFFER_PADDING bytes extra at beginning to hold
 *	any bytes of a native-encoding character that got split by the end of
 *	the previous buffer and need to be moved to the beginning of the next
 *	buffer to make a contiguous string so it can be converted to UTF-8.

 *
 *	A channel buffer has BUFFER_PADDING bytes extra at the end to hold any
 *	bytes of a native-encoding character (generated from a UTF-8
 *	character) that overflow past the end of the buffer and need to be
 *	moved to the next buffer.
 *
 * Results:
 *	A newly allocated channel buffer.
 *
 * Side effects:
 *	None.
 *
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
}

/*
 *----------------------------------------------------------------------
 *
 * RecycleBuffer --
 *
 *	Helper function to recycle input and output buffers. Ensures
 *	that two input buffers are saved (one in the input queue and
 *	another in the saveInBufPtr field) and that curOutPtr is set
 *	to a buffer. Only if these conditions are met is the buffer
 *	freed to the OS.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May free a buffer to the OS.
 *
 *----------------------------------------------------------------------
 */

static void
RecycleBuffer(statePtr, bufPtr, mustDiscard)
    ChannelState *statePtr;	/* ChannelState in which to recycle buffers. */
    ChannelBuffer *bufPtr;	/* The buffer to recycle. */
    int mustDiscard;		/* If nonzero, free the buffer to the
				 * OS, always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */

    if (mustDiscard) {
	ckfree((char *) bufPtr);
	return;
    }

    /*
     * Only save buffers which are at least as big as the requested
     * buffersize for the channel. This is to honor dynamic changes
     * of the buffersize made by the user.
     */

    if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
	ckfree((char *) bufPtr);
	return;
    }

    /*
     * Only save buffers for the input queue if the channel is readable.
     */

    if (statePtr->flags & TCL_READABLE) {
	if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
	    statePtr->inQueueHead = bufPtr;
	    statePtr->inQueueTail = bufPtr;
	    goto keepit;
	}
	if (statePtr->saveInBufPtr == (ChannelBuffer *) NULL) {
	    statePtr->saveInBufPtr = bufPtr;
	    goto keepit;
	}
    }

    /*
     * Only save buffers for the output queue if the channel is writable.
     */

    if (statePtr->flags & TCL_WRITABLE) {
	if (statePtr->curOutPtr == (ChannelBuffer *) NULL) {
	    statePtr->curOutPtr = bufPtr;
	    goto keepit;
	}
    }

    /*
     * If we reached this code we return the buffer to the OS.
     */

    ckfree((char *) bufPtr);
    return;

    keepit:
    bufPtr->nextRemoved = BUFFER_PADDING;
    bufPtr->nextAdded = BUFFER_PADDING;
    bufPtr->nextPtr = (ChannelBuffer *) NULL;
}

/*
 *----------------------------------------------------------------------







|
|
|
|
<














|
|











|
|
|















|



|










|










|







1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876

1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
}

/*
 *----------------------------------------------------------------------
 *
 * RecycleBuffer --
 *
 *	Helper function to recycle input and output buffers. Ensures that two
 *	input buffers are saved (one in the input queue and another in the
 *	saveInBufPtr field) and that curOutPtr is set to a buffer. Only if
 *	these conditions are met is the buffer freed to the OS.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May free a buffer to the OS.
 *
 *----------------------------------------------------------------------
 */

static void
RecycleBuffer(statePtr, bufPtr, mustDiscard)
    ChannelState *statePtr;	/* ChannelState in which to recycle buffers. */
    ChannelBuffer *bufPtr;	/* The buffer to recycle. */
    int mustDiscard;		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */

    if (mustDiscard) {
	ckfree((char *) bufPtr);
	return;
    }

    /*
     * Only save buffers which are at least as big as the requested buffersize
     * for the channel. This is to honor dynamic changes of the buffersize
     * made by the user.
     */

    if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
	ckfree((char *) bufPtr);
	return;
    }

    /*
     * Only save buffers for the input queue if the channel is readable.
     */

    if (statePtr->flags & TCL_READABLE) {
	if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
	    statePtr->inQueueHead = bufPtr;
	    statePtr->inQueueTail = bufPtr;
	    goto keepBuffer;
	}
	if (statePtr->saveInBufPtr == (ChannelBuffer *) NULL) {
	    statePtr->saveInBufPtr = bufPtr;
	    goto keepBuffer;
	}
    }

    /*
     * Only save buffers for the output queue if the channel is writable.
     */

    if (statePtr->flags & TCL_WRITABLE) {
	if (statePtr->curOutPtr == (ChannelBuffer *) NULL) {
	    statePtr->curOutPtr = bufPtr;
	    goto keepBuffer;
	}
    }

    /*
     * If we reached this code we return the buffer to the OS.
     */

    ckfree((char *) bufPtr);
    return;

  keepBuffer:
    bufPtr->nextRemoved = BUFFER_PADDING;
    bufPtr->nextAdded = BUFFER_PADDING;
    bufPtr->nextPtr = (ChannelBuffer *) NULL;
}

/*
 *----------------------------------------------------------------------
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
}

/*
 *----------------------------------------------------------------------
 *
 * CheckForDeadChannel --
 *
 *	This function checks is a given channel is Dead.
 *	(A channel that has been closed but not yet deallocated.)
 *
 * Results:
 *	True (1) if channel is Dead, False (0) if channel is Ok
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static int
CheckForDeadChannel(interp, statePtr)
    Tcl_Interp *interp;		/* For error reporting (can be NULL) */
    ChannelState *statePtr;	/* The channel state to check. */
{
    if (statePtr->flags & CHANNEL_DEAD) {
	Tcl_SetErrno(EINVAL);
	if (interp) {
	    Tcl_AppendResult(interp,
		    "unable to access channel: invalid channel",
		    (char *) NULL);   
	}
	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * FlushChannel --
 *
 *	This function flushes as much of the queued output as is possible
 *	now. If calledFromAsyncFlush is nonzero, it is being called in an
 *	event handler to flush channel output asynchronously.
 *
 * Results:
 *	0 if successful, else the error code that was returned by the
 *	channel type operation.
 *
 * Side effects:
 *	May produce output on a channel. May block indefinitely if the
 *	channel is synchronous. May schedule an async flush on the channel.
 *	May recycle memory for buffers in the output queue.
 *
 *----------------------------------------------------------------------
 */

static int
FlushChannel(interp, chanPtr, calledFromAsyncFlush)
    Tcl_Interp *interp;			/* For error reporting during close. */
    Channel *chanPtr;			/* The channel to flush on. */
    int calledFromAsyncFlush;		/* If nonzero then we are being
					 * called from an asynchronous
					 * flush callback. */
{
    ChannelState *statePtr = chanPtr->state;
					/* State of the channel stack. */
    ChannelBuffer *bufPtr;		/* Iterates over buffered output
					 * queue. */
    int toWrite;			/* Amount of output data in current
					 * buffer available to be written. */
    int written;			/* Amount of output data actually
					 * written in current round. */
    int errorCode = 0;			/* Stores POSIX error codes from
					 * channel driver operations. */
    int wroteSome = 0;			/* Set to one if any data was
					 * written to the driver. */

    /*
     * Prevent writing on a dead channel -- a channel that has been closed
     * but not yet deallocated. This can occur if the exit handler for the
     * channel deallocation runs before all channels are deregistered in
     * all interpreters.
     */

    if (CheckForDeadChannel(interp, statePtr)) {
	return -1;
    }

    /*
     * Loop over the queued buffers and attempt to flush as
     * much as possible of the queued output to the channel.
     */

    while (1) {

	/*
	 * If the queue is empty and there is a ready current buffer, OR if
	 * the current buffer is full, then move the current buffer to the
	 * queue.
	 */

	if (((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&







|
|




















|
















|
|


|
|
|








|
|
|











|
|


|
|
|
|







|
|



<







1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077

2078
2079
2080
2081
2082
2083
2084
}

/*
 *----------------------------------------------------------------------
 *
 * CheckForDeadChannel --
 *
 *	This function checks is a given channel is Dead (a channel that has
 *	been closed but not yet deallocated.)
 *
 * Results:
 *	True (1) if channel is Dead, False (0) if channel is Ok
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static int
CheckForDeadChannel(interp, statePtr)
    Tcl_Interp *interp;		/* For error reporting (can be NULL) */
    ChannelState *statePtr;	/* The channel state to check. */
{
    if (statePtr->flags & CHANNEL_DEAD) {
	Tcl_SetErrno(EINVAL);
	if (interp) {
	    Tcl_AppendResult(interp,
		    "unable to access channel: invalid channel",
		    (char *) NULL);
	}
	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * FlushChannel --
 *
 *	This function flushes as much of the queued output as is possible
 *	now. If calledFromAsyncFlush is nonzero, it is being called in an
 *	event handler to flush channel output asynchronously.
 *
 * Results:
 *	0 if successful, else the error code that was returned by the channel
 *	type operation. May leave a message in the interp result.
 *
 * Side effects:
 *	May produce output on a channel. May block indefinitely if the channel
 *	is synchronous. May schedule an async flush on the channel.  May
 *	recycle memory for buffers in the output queue.
 *
 *----------------------------------------------------------------------
 */

static int
FlushChannel(interp, chanPtr, calledFromAsyncFlush)
    Tcl_Interp *interp;			/* For error reporting during close. */
    Channel *chanPtr;			/* The channel to flush on. */
    int calledFromAsyncFlush;		/* If nonzero then we are being called
					 * from an asynchronous flush
					 * callback. */
{
    ChannelState *statePtr = chanPtr->state;
					/* State of the channel stack. */
    ChannelBuffer *bufPtr;		/* Iterates over buffered output
					 * queue. */
    int toWrite;			/* Amount of output data in current
					 * buffer available to be written. */
    int written;			/* Amount of output data actually
					 * written in current round. */
    int errorCode = 0;			/* Stores POSIX error codes from
					 * channel driver operations. */
    int wroteSome = 0;			/* Set to one if any data was written
					 * to the driver. */

    /*
     * Prevent writing on a dead channel -- a channel that has been closed but
     * not yet deallocated. This can occur if the exit handler for the channel
     * deallocation runs before all channels are deregistered in all
     * interpreters.
     */

    if (CheckForDeadChannel(interp, statePtr)) {
	return -1;
    }

    /*
     * Loop over the queued buffers and attempt to flush as much as possible
     * of the queued output to the channel.
     */

    while (1) {

	/*
	 * If the queue is empty and there is a ready current buffer, OR if
	 * the current buffer is full, then move the current buffer to the
	 * queue.
	 */

	if (((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
	    }
	    statePtr->outQueueTail = statePtr->curOutPtr;
	    statePtr->curOutPtr = (ChannelBuffer *) NULL;
	}
	bufPtr = statePtr->outQueueHead;

	/*
	 * If we are not being called from an async flush and an async
	 * flush is active, we just return without producing any output.
	 */

	if ((!calledFromAsyncFlush) &&
		(statePtr->flags & BG_FLUSH_SCHEDULED)) {
	    return 0;
	}








|
|







2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
	    }
	    statePtr->outQueueTail = statePtr->curOutPtr;
	    statePtr->curOutPtr = (ChannelBuffer *) NULL;
	}
	bufPtr = statePtr->outQueueHead;

	/*
	 * If we are not being called from an async flush and an async flush
	 * is active, we just return without producing any output.
	 */

	if ((!calledFromAsyncFlush) &&
		(statePtr->flags & BG_FLUSH_SCHEDULED)) {
	    return 0;
	}

2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124








2125
2126



2127
2128















2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139

2140
2141



2142

2143
2144
2145
2146
2147
2148
2149
2150
2151
2152

	    if (errorCode == EINTR) {
		errorCode = 0;
		continue;
	    }

	    /*
	     * If the channel is non-blocking and we would have blocked,
	     * start a background flushing handler and break out of the loop.
	     */

	    if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) {
		/*
		 * This used to check for CHANNEL_NONBLOCKING, and panic
		 * if the channel was blocking.	 However, it appears
		 * that setting stdin to -blocking 0 has some effect on
		 * the stdout when it's a tty channel (dup'ed underneath)
		 */

		if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
		    statePtr->flags |= BG_FLUSH_SCHEDULED;
		    UpdateInterest(chanPtr);
		}
		errorCode = 0;
		break;
	    }

	    /*
	     * Decide whether to report the error upwards or defer it.
	     */

	    if (calledFromAsyncFlush) {








		if (statePtr->unreportedError == 0) {
		    statePtr->unreportedError = errorCode;



		}
	    } else {















		Tcl_SetErrno(errorCode);
		if (interp != NULL) {

		    /*
		     * Casting away CONST here is safe because the
		     * TCL_VOLATILE flag guarantees CONST treatment
		     * of the Posix error string.
		     */

		    Tcl_SetResult(interp,
			    (char *) Tcl_PosixError(interp), TCL_VOLATILE);

		}
	    }





	    /*
	     * When we get an error we throw away all the output
	     * currently queued.
	     */

	    DiscardOutputQueued(statePtr);
	    continue;
	} else {
	    wroteSome = 1;
	}







|
|




|
|
|
|















>
>
>
>
>
>
>
>


>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|
|
|
|
|

|
|
>
|
|
>
>
>
|
>

|
|







2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228

	    if (errorCode == EINTR) {
		errorCode = 0;
		continue;
	    }

	    /*
	     * If the channel is non-blocking and we would have blocked, start
	     * a background flushing handler and break out of the loop.
	     */

	    if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) {
		/*
		 * This used to check for CHANNEL_NONBLOCKING, and panic if
		 * the channel was blocking.  However, it appears that setting
		 * stdin to -blocking 0 has some effect on the stdout when
		 * it's a tty channel (dup'ed underneath)
		 */

		if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
		    statePtr->flags |= BG_FLUSH_SCHEDULED;
		    UpdateInterest(chanPtr);
		}
		errorCode = 0;
		break;
	    }

	    /*
	     * Decide whether to report the error upwards or defer it.
	     */

	    if (calledFromAsyncFlush) {
		/* TIP #219, Tcl Channel Reflection API.
		 * When defering the error copy a message from the bypass into
		 * the unreported area. Or discard it if the new error is to be
		 * ignored in favor of an earlier defered error.
		 */

	        Tcl_Obj* msg = statePtr->chanMsg;

		if (statePtr->unreportedError == 0) {
		    statePtr->unreportedError = errorCode;
		    statePtr->unreportedMsg   = msg;
		    if (msg != NULL) {
		        Tcl_IncrRefCount (msg);
		    }
		} else {
		    /* An old unreported error is kept, and this error
		     * thrown away.
		     */
		    statePtr->chanMsg = NULL;
		    if (msg != NULL) {
		        Tcl_DecrRefCount (msg);
		    }
		}
	    } else {
		/* TIP #219, Tcl Channel Reflection API.
		 * Move error messages put by the driver into the chan bypass
		 * area into the regular interpreter result. Fall back to the
		 * regular message if nothing was found in the bypasses.
		 */

		Tcl_SetErrno(errorCode);
		if (interp != NULL) {
		    if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) {
		        /*
			 * Casting away CONST here is safe because the
			 * TCL_VOLATILE flag guarantees CONST treatment
			 * of the Posix error string.
			 */

		        Tcl_SetResult(interp,
				(char *) Tcl_PosixError(interp),
				TCL_VOLATILE);
		    }
		}
		/* An unreportable bypassed message is kept, for the
		 * caller of Tcl_Seek, Tcl_Write, etc.
		 */
	    }

	    /*
	     * When we get an error we throw away all the output currently
	     * queued.
	     */

	    DiscardOutputQueued(statePtr);
	    continue;
	} else {
	    wroteSome = 1;
	}
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
	    }
	    RecycleBuffer(statePtr, bufPtr, 0);
	}
    }	/* Closes "while (1)". */

    /*
     * If we wrote some data while flushing in the background, we are done.
     * We can't finish the background flush until we run out of data and
     * the channel becomes writable again.  This ensures that all of the
     * pending data has been flushed at the system level.
     */

    if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	if (wroteSome) {
	    return errorCode;
	} else if (statePtr->outQueueHead == (ChannelBuffer *) NULL) {
	    statePtr->flags &= (~(BG_FLUSH_SCHEDULED));
	    (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
		    statePtr->interestMask);
	}
    }

    /*
     * If the channel is flagged as closed, delete it when the refCount
     * drops to zero, the output queue is empty and there is no output
     * in the current output buffer.
     */

    if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
	    (statePtr->outQueueHead == (ChannelBuffer *) NULL) &&
	    ((statePtr->curOutPtr == (ChannelBuffer *) NULL) ||
	    (statePtr->curOutPtr->nextAdded ==
		    statePtr->curOutPtr->nextRemoved))) {







|
|
|













|
|
|







2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
	    }
	    RecycleBuffer(statePtr, bufPtr, 0);
	}
    }	/* Closes "while (1)". */

    /*
     * If we wrote some data while flushing in the background, we are done.
     * We can't finish the background flush until we run out of data and the
     * channel becomes writable again.  This ensures that all of the pending
     * data has been flushed at the system level.
     */

    if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	if (wroteSome) {
	    return errorCode;
	} else if (statePtr->outQueueHead == (ChannelBuffer *) NULL) {
	    statePtr->flags &= (~(BG_FLUSH_SCHEDULED));
	    (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
		    statePtr->interestMask);
	}
    }

    /*
     * If the channel is flagged as closed, delete it when the refCount drops
     * to zero, the output queue is empty and there is no output in the
     * current output buffer.
     */

    if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
	    (statePtr->outQueueHead == (ChannelBuffer *) NULL) &&
	    ((statePtr->curOutPtr == (ChannelBuffer *) NULL) ||
	    (statePtr->curOutPtr->nextAdded ==
		    statePtr->curOutPtr->nextRemoved))) {
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
 *
 *	Utility procedure to close a channel and free associated resources.
 *
 *	If the channel was stacked, then the it will copy the necessary
 *	elements of the NEXT channel into the TOP channel, in essence
 *	unstacking the channel.  The NEXT channel will then be freed.
 *
 *	If the channel was not stacked, then we will free all the bits
 *	for the TOP channel, including the data structure itself.
 *
 * Results:
 *	1 if the channel was stacked, 0 otherwise.
 *
 * Side effects:
 *	May close the actual channel; may free memory.
 *	May change the value of errno.
 *
 *----------------------------------------------------------------------
 */

static int
CloseChannel(interp, chanPtr, errorCode)
    Tcl_Interp *interp;			/* For error reporting. */







|
|


|


|
|







2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
 *
 *	Utility procedure to close a channel and free associated resources.
 *
 *	If the channel was stacked, then the it will copy the necessary
 *	elements of the NEXT channel into the TOP channel, in essence
 *	unstacking the channel.  The NEXT channel will then be freed.
 *
 *	If the channel was not stacked, then we will free all the bits for the
 *	TOP channel, including the data structure itself.
 *
 * Results:
 *	Error code from an unreported error or the driver close operation.
 *
 * Side effects:
 *	May close the actual channel, may free memory, may change the value of
 *	errno.
 *
 *----------------------------------------------------------------------
 */

static int
CloseChannel(interp, chanPtr, errorCode)
    Tcl_Interp *interp;			/* For error reporting. */
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276













2277
2278
2279
2280
2281
2282
2283
2284
2285

2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320











2321
2322
2323
2324
2325
2326
2327

    if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
	ckfree((char *) statePtr->curOutPtr);
	statePtr->curOutPtr = (ChannelBuffer *) NULL;
    }

    /*
     * The caller guarantees that there are no more buffers
     * queued for output.
     */

    if (statePtr->outQueueHead != (ChannelBuffer *) NULL) {
	Tcl_Panic("TclFlush, closed channel: queued output left");
    }

    /*
     * If the EOF character is set in the channel, append that to the
     * output device.
     */

    if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) {
	int dummy;
	char c = (char) statePtr->outEofChar;

	(chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy);
    }














    /*
     * Remove this channel from of the list of all channels.
     */

    Tcl_CutChannel((Tcl_Channel) chanPtr);

    /*
     * Close and free the channel driver state.

     */

    if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
	result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp);
    } else {
	result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
		interp, 0);
    }

    /*
     * Some resources can be cleared only if the bottom channel
     * in a stack is closed. All the other channels in the stack
     * are not allowed to remove.
     */

    if (chanPtr == statePtr->bottomChanPtr) {
	if (statePtr->channelName != (char *) NULL) {
	    ckfree((char *) statePtr->channelName);
	    statePtr->channelName = NULL;
	}

	Tcl_FreeEncoding(statePtr->encoding);
	if (statePtr->outputStage != NULL) {
	    ckfree((char *) statePtr->outputStage);
	    statePtr->outputStage = (char *) NULL;
	}
    }

    /*
     * If we are being called synchronously, report either
     * any latent error on the channel or the current error.
     */

    if (statePtr->unreportedError != 0) {
	errorCode = statePtr->unreportedError;











    }
    if (errorCode == 0) {
	errorCode = result;
	if (errorCode != 0) {
	    Tcl_SetErrno(errorCode);
	}
    }







|
<







|
|








>
>
>
>
>
>
>
>
>
>
>
>
>





|



>










|
|
<
















|
|




>
>
>
>
>
>
>
>
>
>
>







2327
2328
2329
2330
2331
2332
2333
2334

2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386

2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426

    if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
	ckfree((char *) statePtr->curOutPtr);
	statePtr->curOutPtr = (ChannelBuffer *) NULL;
    }

    /*
     * The caller guarantees that there are no more buffers queued for output.

     */

    if (statePtr->outQueueHead != (ChannelBuffer *) NULL) {
	Tcl_Panic("TclFlush, closed channel: queued output left");
    }

    /*
     * If the EOF character is set in the channel, append that to the output
     * device.
     */

    if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) {
	int dummy;
	char c = (char) statePtr->outEofChar;

	(chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy);
    }

    /* TIP #219, Tcl Channel Reflection API.
     * Move a leftover error message in the channel bypass into the
     * interpreter bypass. Just clear it if there is no interpreter.
     */

    if (statePtr->chanMsg != NULL) {
	if (interp != NULL) {
	    Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg);
	}
        Tcl_DecrRefCount (statePtr->chanMsg);
	statePtr->chanMsg = NULL;
    }

    /*
     * Remove this channel from of the list of all channels.
     */

    CutChannel((Tcl_Channel) chanPtr);

    /*
     * Close and free the channel driver state.
     * This may leave a TIP #219 error message in the interp.
     */

    if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
	result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp);
    } else {
	result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
		interp, 0);
    }

    /*
     * Some resources can be cleared only if the bottom channel in a stack is
     * closed. All the other channels in the stack are not allowed to remove.

     */

    if (chanPtr == statePtr->bottomChanPtr) {
	if (statePtr->channelName != (char *) NULL) {
	    ckfree((char *) statePtr->channelName);
	    statePtr->channelName = NULL;
	}

	Tcl_FreeEncoding(statePtr->encoding);
	if (statePtr->outputStage != NULL) {
	    ckfree((char *) statePtr->outputStage);
	    statePtr->outputStage = (char *) NULL;
	}
    }

    /*
     * If we are being called synchronously, report either any latent error on
     * the channel or the current error.
     */

    if (statePtr->unreportedError != 0) {
	errorCode = statePtr->unreportedError;

	/* TIP #219, Tcl Channel Reflection API.
	 * Move an error message found in the unreported area into the regular
	 * bypass (interp). This kills any message in the channel bypass area.
	 */

	if (statePtr->chanMsg != NULL) {
	    Tcl_DecrRefCount (statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
        Tcl_SetChannelErrorInterp (interp,statePtr->unreportedMsg);
    }
    if (errorCode == 0) {
	errorCode = result;
	if (errorCode != 0) {
	    Tcl_SetErrno(errorCode);
	}
    }
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372

2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406

2407
2408
2409
2410












































2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429


2430








2431
2432
2433
2434
2435
2436

2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466

2467
2468
2469


































2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483


2484








2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521

2522
2523
2524
2525
2526
2527
2528
	chanPtr->typePtr	= NULL;

	Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
	return Tcl_Close(interp, (Tcl_Channel) downChanPtr);
    }

    /*
     * There is only the TOP Channel, so we free the remaining
     * pointers we have and then ourselves.  Since this is the
     * last of the channels in the stack, make sure to free the
     * ChannelState structure associated with it.  We use
     * Tcl_EventuallyFree to allow for any last
     */

    chanPtr->typePtr = NULL;

    Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC);
    Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);

    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CutChannel --

 *
 *	Removes a channel from the (thread-)global list of all channels
 *	(in that thread).  This is actually the statePtr for the stack
 *	of channel.
 *
 * Results:
 *	Nothing.
 *
 * Side effects:
 *	Resets the field 'nextCSPtr' of the specified channel state to NULL.
 *
 * NOTE:
 *	The channel to splice out of the list must not be referenced
 *	in any interpreter. This is something this procedure cannot
 *	check (despite the refcount) because the caller usually wants
 *	fiddle with the channel (like transfering it to a different
 *	thread) and thus keeps the refcount artifically high to prevent
 *	its destruction.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CutChannel(chan)
    Tcl_Channel chan;			/* The channel being removed. Must
					 * not be referenced in any
					 * interpreter. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelState *prevCSPtr;		/* Preceding channel state in list of
					 * all states - used to splice a
					 * channel out of the list on close. */
    ChannelState *statePtr = ((Channel *) chan)->state;
					/* state of the channel stack. */


    /*
     * Remove this channel from of the list of all channels
     * (in the current thread).












































     */

    if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
	tsdPtr->firstCSPtr = statePtr->nextCSPtr;
    } else {
	for (prevCSPtr = tsdPtr->firstCSPtr;
		prevCSPtr && (prevCSPtr->nextCSPtr != statePtr);
		prevCSPtr = prevCSPtr->nextCSPtr) {
	    /* Empty loop body. */
	}
	if (prevCSPtr == (ChannelState *) NULL) {
	    Tcl_Panic("FlushChannel: damaged channel list");
	}
	prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
    }

    statePtr->nextCSPtr = (ChannelState *) NULL;

    TclpCutFileChannel(chan);


    TclpCutSockChannel(chan);








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SpliceChannel --

 *
 *	Adds a channel to the (thread-)global list of all channels
 *	(in that thread). Expects that the field 'nextChanPtr' in
 *	the channel is set to NULL.
 *
 * Results:
 *	Nothing.
 *
 * Side effects:
 *	Nothing.
 *
 * NOTE:
 *	The channel to add to the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check
 *	(despite the refcount) because the caller usually wants figgle
 *	with the channel (like transfering it to a different thread)
 *	and thus keeps the refcount artifically high to prevent its
 *	destruction.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SpliceChannel(chan)
    Tcl_Channel chan;			/* The channel being added. Must
					 * not be referenced in any
					 * interpreter. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelState *statePtr = ((Channel *) chan)->state;


    if (statePtr->nextCSPtr != (ChannelState *) NULL) {
	Tcl_Panic("Tcl_SpliceChannel: trying to add channel used in different list");


































    }

    statePtr->nextCSPtr = tsdPtr->firstCSPtr;
    tsdPtr->firstCSPtr = statePtr;

    /*
     * TIP #10. Mark the current thread as the new one managing this
     *		channel. Note: 'Tcl_GetCurrentThread' returns sensible
     *		values even for a non-threaded core.
     */

    statePtr->managingThread = Tcl_GetCurrentThread();

    TclpSpliceFileChannel(chan);


    TclpSpliceSockChannel(chan);








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Close --
 *
 *	Closes a channel.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Closes the channel if this is the last reference.
 *
 * NOTE:
 *	Tcl_Close removes the channel as far as the user is concerned.
 *	However, it may continue to exist for a while longer if it has
 *	a background flush scheduled. The device itself is eventually
 *	closed and the channel record removed, in CloseChannel, above.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_Close(interp, chan)
    Tcl_Interp *interp;			/* Interpreter for errors. */
    Tcl_Channel chan;			/* The channel being closed. Must
					 * not be referenced in any
					 * interpreter. */
{
    CloseCallback *cbPtr;		/* Iterate over close callbacks
					 * for this channel. */
    Channel *chanPtr;			/* The real IO channel. */
    ChannelState *statePtr;		/* State of real IO channel. */
    int result;				/* Of calling FlushChannel. */


    if (chan == (Tcl_Channel) NULL) {
	return TCL_OK;
    }

    /*
     * Perform special handling for standard channels being closed. If the







|
|
<
|
|














>

|
|
<








|
|
|
|
|
<




|
|










>


|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


















|
>
>
|
>
>
>
>
>
>
>
>






>

|
|
|








|
|
|
|
|
<




|
|
|
|


|
|
>


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|
|




|
>
>
|
>
>
>
>
>
>
>
>

















|
|
|








|
|


|
|



>







2446
2447
2448
2449
2450
2451
2452
2453
2454

2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474

2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487

2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606

2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
	chanPtr->typePtr	= NULL;

	Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
	return Tcl_Close(interp, (Tcl_Channel) downChanPtr);
    }

    /*
     * There is only the TOP Channel, so we free the remaining pointers we
     * have and then ourselves.  Since this is the last of the channels in the

     * stack, make sure to free the ChannelState structure associated with it.
     * We use Tcl_EventuallyFree to allow for any last references.
     */

    chanPtr->typePtr = NULL;

    Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC);
    Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);

    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CutChannel --
 * CutChannel --
 *
 *	Removes a channel from the (thread-)global list of all channels (in
 *	that thread).  This is actually the statePtr for the stack of channel.

 *
 * Results:
 *	Nothing.
 *
 * Side effects:
 *	Resets the field 'nextCSPtr' of the specified channel state to NULL.
 *
 * NOTE:
 *	The channel to cut out of the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check (despite
 *	the refcount) because the caller usually wants fiddle with the channel
 *	(like transfering it to a different thread) and thus keeps the
 *	refcount artifically high to prevent its destruction.

 *
 *----------------------------------------------------------------------
 */

static void
CutChannel(chan)
    Tcl_Channel chan;			/* The channel being removed. Must
					 * not be referenced in any
					 * interpreter. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelState *prevCSPtr;		/* Preceding channel state in list of
					 * all states - used to splice a
					 * channel out of the list on close. */
    ChannelState *statePtr = ((Channel *) chan)->state;
					/* state of the channel stack. */
    Tcl_DriverThreadActionProc *threadActionProc;

    /*
     * Remove this channel from of the list of all channels (in the current
     * thread).
     */

    if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
	tsdPtr->firstCSPtr = statePtr->nextCSPtr;
    } else {
	for (prevCSPtr = tsdPtr->firstCSPtr;
		prevCSPtr && (prevCSPtr->nextCSPtr != statePtr);
		prevCSPtr = prevCSPtr->nextCSPtr) {
	    /* Empty loop body. */
	}
	if (prevCSPtr == (ChannelState *) NULL) {
	    Tcl_Panic("FlushChannel: damaged channel list");
	}
	prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
    }

    statePtr->nextCSPtr = (ChannelState *) NULL;

    /* TIP #218, Channel Thread Actions */
    threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan));
    if (threadActionProc != NULL) {
	(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
		TCL_CHANNEL_THREAD_REMOVE);
    }
}

void
Tcl_CutChannel(chan)
    Tcl_Channel chan;			/* The channel being added. Must not
					 * be referenced in any
					 * interpreter. */
{
    Channel* chanPtr = ((Channel*) chan)->state->bottomChanPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelState *prevCSPtr;		/* Preceding channel state in list of
					 * all states - used to splice a
					 * channel out of the list on close. */
    ChannelState *statePtr = chanPtr->state;
					/* state of the channel stack. */
    Tcl_DriverThreadActionProc *threadActionProc;

    /*
     * Remove this channel from of the list of all channels (in the current
     * thread).
     */

    if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
	tsdPtr->firstCSPtr = statePtr->nextCSPtr;
    } else {
	for (prevCSPtr = tsdPtr->firstCSPtr;
		prevCSPtr && (prevCSPtr->nextCSPtr != statePtr);
		prevCSPtr = prevCSPtr->nextCSPtr) {
	    /* Empty loop body. */
	}
	if (prevCSPtr == (ChannelState *) NULL) {
	    Tcl_Panic("FlushChannel: damaged channel list");
	}
	prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
    }

    statePtr->nextCSPtr = (ChannelState *) NULL;

    /* TIP #218, Channel Thread Actions
     * For all transformations and the base channel.
     */

    while (chanPtr) {
	threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
	if (threadActionProc != NULL) {
	    (*threadActionProc) (chanPtr->instanceData,
				 TCL_CHANNEL_THREAD_REMOVE);
	}
	chanPtr= chanPtr->upChanPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SpliceChannel --
 * SpliceChannel --
 *
 *	Adds a channel to the (thread-)global list of all channels (in that
 *	thread). Expects that the field 'nextChanPtr' in the channel is set to
 *	NULL.
 *
 * Results:
 *	Nothing.
 *
 * Side effects:
 *	Nothing.
 *
 * NOTE:
 *	The channel to splice into the list must not be referenced in any
 *	interpreter. This is something this procedure cannot check (despite
 *	the refcount) because the caller usually wants figgle with the channel
 *	(like transfering it to a different thread) and thus keeps the
 *	refcount artifically high to prevent its destruction.

 *
 *----------------------------------------------------------------------
 */

static void
SpliceChannel(chan)
    Tcl_Channel chan;			/* The channel being added. Must not
					 * be referenced in any
					 * interpreter. */
{
    ThreadSpecificData	*tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelState	*statePtr = ((Channel *) chan)->state;
    Tcl_DriverThreadActionProc *threadActionProc;

    if (statePtr->nextCSPtr != (ChannelState *) NULL) {
	Tcl_Panic("SpliceChannel: trying to add channel used in different list");
    }

    statePtr->nextCSPtr = tsdPtr->firstCSPtr;
    tsdPtr->firstCSPtr = statePtr;

    /*
     * TIP #10. Mark the current thread as the new one managing this channel.
     *		Note: 'Tcl_GetCurrentThread' returns sensible values even for
     *		a non-threaded core.
     */

    statePtr->managingThread = Tcl_GetCurrentThread();

    /* TIP #218, Channel Thread Actions */
    threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan));
    if (threadActionProc != NULL) {
	(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
		TCL_CHANNEL_THREAD_INSERT);
    }
}

void
Tcl_SpliceChannel(chan)
    Tcl_Channel chan;			/* The channel being added. Must not
					 * be referenced in any
					 * interpreter. */
{
    Channel             *chanPtr  = ((Channel*) chan)->state->bottomChanPtr;
    ThreadSpecificData	*tsdPtr   = TCL_TSD_INIT(&dataKey);
    ChannelState	*statePtr = chanPtr->state;
    Tcl_DriverThreadActionProc *threadActionProc;

    if (statePtr->nextCSPtr != (ChannelState *) NULL) {
	Tcl_Panic("SpliceChannel: trying to add channel used in different list");
    }

    statePtr->nextCSPtr = tsdPtr->firstCSPtr;
    tsdPtr->firstCSPtr = statePtr;

    /*
     * TIP #10. Mark the current thread as the new one managing this channel.
     *		Note: 'Tcl_GetCurrentThread' returns sensible values even for
     *		a non-threaded core.
     */

    statePtr->managingThread = Tcl_GetCurrentThread();

    /* TIP #218, Channel Thread Actions
     * For all transformations and the base channel.
     */

    while (chanPtr) {
	threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
	if (threadActionProc != NULL) {
	    (*threadActionProc) (chanPtr->instanceData,
				 TCL_CHANNEL_THREAD_INSERT);
	}
	chanPtr= chanPtr->upChanPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Close --
 *
 *	Closes a channel.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Closes the channel if this is the last reference.
 *
 * NOTE:
 *	Tcl_Close removes the channel as far as the user is concerned.
 *	However, it may continue to exist for a while longer if it has a
 *	background flush scheduled. The device itself is eventually closed and
 *	the channel record removed, in CloseChannel, above.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_Close(interp, chan)
    Tcl_Interp *interp;			/* Interpreter for errors. */
    Tcl_Channel chan;			/* The channel being closed. Must not
					 * be referenced in any
					 * interpreter. */
{
    CloseCallback *cbPtr;		/* Iterate over close callbacks for
					 * this channel. */
    Channel *chanPtr;			/* The real IO channel. */
    ChannelState *statePtr;		/* State of real IO channel. */
    int result;				/* Of calling FlushChannel. */
    int flushcode;

    if (chan == (Tcl_Channel) NULL) {
	return TCL_OK;
    }

    /*
     * Perform special handling for standard channels being closed. If the
2553
2554
2555
2556
2557
2558
2559

2560
2561
2562
2563













2564
2565
2566
2567
2568
2569
2570
    }
    statePtr->flags |= CHANNEL_INCLOSE;

    /*
     * When the channel has an escape sequence driven encoding such as
     * iso2022, the terminated escape sequence must write to the buffer.
     */

    if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
	    && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	WriteChars(chanPtr, "", 0);













    }

    Tcl_ClearChannelHandlers(chan);

    /*
     * Invoke the registered close callbacks and delete their records.
     */







>




>
>
>
>
>
>
>
>
>
>
>
>
>







2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
    }
    statePtr->flags |= CHANNEL_INCLOSE;

    /*
     * When the channel has an escape sequence driven encoding such as
     * iso2022, the terminated escape sequence must write to the buffer.
     */

    if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
	    && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	WriteChars(chanPtr, "", 0);

	/* TIP #219, Tcl Channel Reflection API.
	 * Move an error message found in the channel bypass into the
	 * interpreter bypass. Just clear it if there is no interpreter.
	 */

	if (statePtr->chanMsg != NULL) {
	    if (interp != NULL) {
		Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg);
	    }
	    Tcl_DecrRefCount (statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
    }

    Tcl_ClearChannelHandlers(chan);

    /*
     * Invoke the registered close callbacks and delete their records.
     */
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608

2609

















2610
2611
2612
2613
2614
2615
2616

    if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
	    (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
	statePtr->flags |= BUFFER_READY;
    }

    /*
     * If this channel supports it, close the read side, since we don't need it
     * anymore and this will help avoid deadlocks on some channel types.
     */

    if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
	result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
		TCL_CLOSE_READ);
    } else {
	result = 0;
    }

    /*
     * The call to FlushChannel will flush any queued output and invoke
     * the close function of the channel driver, or it will set up the
     * channel to be flushed and closed asynchronously.
     */

    statePtr->flags |= CHANNEL_CLOSED;

    if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) {

















	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|
|










|
|
|



>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846

    if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
	    (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
	statePtr->flags |= BUFFER_READY;
    }

    /*
     * If this channel supports it, close the read side, since we don't need
     * it anymore and this will help avoid deadlocks on some channel types.
     */

    if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
	result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
		TCL_CLOSE_READ);
    } else {
	result = 0;
    }

    /*
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    statePtr->flags |= CHANNEL_CLOSED;

    flushcode = FlushChannel(interp, chanPtr, 0);

    /* TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     *
     * Notes: Due to the assertion of CHANNEL_CLOSED in the flags
     * "FlushChannel" has called "CloseChannel" and thus freed all the channel
     * structures. We must not try to access "chan" anymore, hence the NULL
     * argument in the call below. The only place which may still contain a
     * message is the interpreter itself, and "CloseChannel" made sure to lift
     * any channel message it generated into it.
     */
    if (TclChanCaughtErrorBypass (interp, NULL)) {
	result = EINVAL;
    }

    if ((flushcode != 0) || (result != 0)) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
2646
2647
2648
2649
2650
2651
2652






2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
     */

    chanPtr = (Channel *) channel;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;

    /*






     * Remove any references to channel handlers for this channel that
     * may be about to be invoked.
     */

    for (nhPtr = tsdPtr->nestedHandlerPtr;
	    nhPtr != (NextChannelHandler *) NULL;
	    nhPtr = nhPtr->nestedHandlerPtr) {
	if (nhPtr->nextHandlerPtr &&
		(nhPtr->nextHandlerPtr->chanPtr == chanPtr)) {
	    nhPtr->nextHandlerPtr = NULL;
	}
    }

    /*
     * Remove all the channel handler records attached to the channel
     * itself.
     */

    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chNext) {
	chNext = chPtr->nextPtr;
	ckfree((char *) chPtr);







>
>
>
>
>
>
|
|












|
<







2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903

2904
2905
2906
2907
2908
2909
2910
     */

    chanPtr = (Channel *) channel;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;

    /*
     * Cancel any outstanding timer.
     */

    Tcl_DeleteTimerHandler(statePtr->timer);

    /*
     * Remove any references to channel handlers for this channel that may be
     * about to be invoked.
     */

    for (nhPtr = tsdPtr->nestedHandlerPtr;
	    nhPtr != (NextChannelHandler *) NULL;
	    nhPtr = nhPtr->nestedHandlerPtr) {
	if (nhPtr->nextHandlerPtr &&
		(nhPtr->nextHandlerPtr->chanPtr == chanPtr)) {
	    nhPtr->nextHandlerPtr = NULL;
	}
    }

    /*
     * Remove all the channel handler records attached to the channel itself.

     */

    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chNext) {
	chNext = chPtr->nextPtr;
	ckfree((char *) chPtr);
2683
2684
2685
2686
2687
2688
2689





2690
2691
2692

2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
    StopCopy(statePtr->csPtr);

    /*
     * Must set the interest mask now to 0, otherwise infinite loops
     * will occur if Tcl_DoOneEvent is called before the channel is
     * finally deleted in FlushChannel. This can happen if the channel
     * has a background flush active.





     */

    statePtr->interestMask = 0;


    /*
     * Remove any EventScript records for this channel.
     */

    for (ePtr = statePtr->scriptRecordPtr;
	    ePtr != (EventScriptRecord *) NULL;
	    ePtr = eNextPtr) {
	eNextPtr = ePtr->nextPtr;
	TclDecrRefCount(ePtr->scriptPtr);
	ckfree((char *) ePtr);
    }
    statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Write --
 *
 *	Puts a sequence of bytes into an output buffer, may queue the
 *	buffer for output if it gets full, and also remembers whether the
 *	current buffer is ready e.g. if it contains a newline and we are in
 *	line buffering mode. Compensates stacking, i.e. will redirect the
 *	data from the specified channel to the topmost channel in a stack.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *







>
>
>
>
>

|

>




















|
|
|
|
|







2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
    StopCopy(statePtr->csPtr);

    /*
     * Must set the interest mask now to 0, otherwise infinite loops
     * will occur if Tcl_DoOneEvent is called before the channel is
     * finally deleted in FlushChannel. This can happen if the channel
     * has a background flush active.
     * Also, delete all registered file handlers for this channel 
     * (and for the current thread). This prevents executing of pending
     * file-events still sitting in the event queue of the current thread.
     * We deliberately do not call UpdateInterest() because this could
     * re-schedule new events if the channel still needs to be flushed.
     */
        
    statePtr->interestMask = 0;
    (chanPtr->typePtr->watchProc)(chanPtr->instanceData, 0);

    /*
     * Remove any EventScript records for this channel.
     */

    for (ePtr = statePtr->scriptRecordPtr;
	    ePtr != (EventScriptRecord *) NULL;
	    ePtr = eNextPtr) {
	eNextPtr = ePtr->nextPtr;
	TclDecrRefCount(ePtr->scriptPtr);
	ckfree((char *) ePtr);
    }
    statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Write --
 *
 *	Puts a sequence of bytes into an output buffer, may queue the buffer
 *	for output if it gets full, and also remembers whether the current
 *	buffer is ready e.g. if it contains a newline and we are in line
 *	buffering mode. Compensates stacking, i.e. will redirect the data from
 *	the specified channel to the topmost channel in a stack.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WriteRaw --
 *
 *	Puts a sequence of bytes into an output buffer, may queue the
 *	buffer for output if it gets full, and also remembers whether the
 *	current buffer is ready e.g. if it contains a newline and we are in
 *	line buffering mode. Writes directly to the driver of the channel,
 *	does not compensate for stacking.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *







|
|
|
|
|







2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WriteRaw --
 *
 *	Puts a sequence of bytes into an output buffer, may queue the buffer
 *	for output if it gets full, and also remembers whether the current
 *	buffer is ready e.g. if it contains a newline and we are in line
 *	buffering mode. Writes directly to the driver of the channel, does not
 *	compensate for stacking.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843

2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884

2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950

2951
2952
2953
2954
2955
2956
2957

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_WriteChars --
 *
 *	Takes a sequence of UTF-8 characters and converts them for output
 *	using the channel's current encoding, may queue the buffer for
 *	output if it gets full, and also remembers whether the current
 *	buffer is ready e.g. if it contains a newline and we are in
 *	line buffering mode. Compensates stacking, i.e. will redirect the
 *	data from the specified channel to the topmost channel in a stack.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
 *	channel.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WriteChars(chan, src, len)
    Tcl_Channel chan;		/* The channel to buffer output for. */
    CONST char *src;		/* UTF-8 characters to queue in output buffer. */

    int len;			/* Length of string in bytes, or < 0 for 
				 * strlen(). */
{
    ChannelState *statePtr;	/* state info for channel */

    statePtr = ((Channel *) chan)->state;

    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
	return -1;
    }

    return DoWriteChars((Channel *) chan, src, len);
}

/*
 *---------------------------------------------------------------------------
 *
 * DoWriteChars --
 *
 *	Takes a sequence of UTF-8 characters and converts them for output
 *	using the channel's current encoding, may queue the buffer for
 *	output if it gets full, and also remembers whether the current
 *	buffer is ready e.g. if it contains a newline and we are in
 *	line buffering mode. Compensates stacking, i.e. will redirect the
 *	data from the specified channel to the topmost channel in a stack.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
 *	channel.
 *
 *----------------------------------------------------------------------
 */

static int
DoWriteChars(chanPtr, src, len)
    Channel *chanPtr;		/* The channel to buffer output for. */
    CONST char *src;		/* UTF-8 characters to queue in output buffer. */

    int len;			/* Length of string in bytes, or < 0 for 
				 * strlen(). */
{
    /*
     * Always use the topmost channel of the stack
     */

    ChannelState *statePtr;	/* state info for channel */

    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;

    if (len < 0) {
	len = strlen(src);
    }
    if (statePtr->encoding == NULL) {
	/*
	 * Inefficient way to convert UTF-8 to byte-array, but the  
	 * code parallels the way it is done for objects.
	 */

	Tcl_Obj *objPtr;
	int result;

	objPtr = Tcl_NewStringObj(src, len);
	src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
	result = WriteBytes(chanPtr, src, len);
	TclDecrRefCount(objPtr);
	return result;
    }
    return WriteChars(chanPtr, src, len);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_WriteObj --
 *
 *	Takes the Tcl object and queues its contents for output.  If the 
 *	encoding of the channel is NULL, takes the byte-array representation 
 *	of the object and queues those bytes for output.  Otherwise, takes 
 *	the characters in the UTF-8 (string) representation of the object 
 *	and converts them for output using the channel's current encoding.  
 *	May flush internal buffers to output if one becomes full or is ready 
 *	for some other reason, e.g. if it contains a newline and the channel 
 *	is in line buffering mode.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1, 
 *	Tcl_GetErrno() will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
 *	channel.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WriteObj(chan, objPtr)
    Tcl_Channel chan;		/* The channel to buffer output for. */
    Tcl_Obj *objPtr;		/* The object to write. */
{
    /*
     * Always use the topmost channel of the stack
     */

    Channel *chanPtr;
    ChannelState *statePtr;	/* state info for channel */
    char *src;
    int srcLen;

    statePtr = ((Channel *) chan)->state;
    chanPtr = statePtr->topChanPtr;







|
|
|
|
|















|
>
|



















|
|
|
|
|















|
>
|
















|
|



















|
|
|
|
|
|
|
|


|

















>







3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_WriteChars --
 *
 *	Takes a sequence of UTF-8 characters and converts them for output
 *	using the channel's current encoding, may queue the buffer for output
 *	if it gets full, and also remembers whether the current buffer is
 *	ready e.g. if it contains a newline and we are in line buffering
 *	mode. Compensates stacking, i.e. will redirect the data from the
 *	specified channel to the topmost channel in a stack.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
 *	channel.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WriteChars(chan, src, len)
    Tcl_Channel chan;		/* The channel to buffer output for. */
    CONST char *src;		/* UTF-8 characters to queue in output
				 * buffer. */
    int len;			/* Length of string in bytes, or < 0 for
				 * strlen(). */
{
    ChannelState *statePtr;	/* state info for channel */

    statePtr = ((Channel *) chan)->state;

    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
	return -1;
    }

    return DoWriteChars((Channel *) chan, src, len);
}

/*
 *---------------------------------------------------------------------------
 *
 * DoWriteChars --
 *
 *	Takes a sequence of UTF-8 characters and converts them for output
 *	using the channel's current encoding, may queue the buffer for output
 *	if it gets full, and also remembers whether the current buffer is
 *	ready e.g. if it contains a newline and we are in line buffering mode.
 *	Compensates stacking, i.e. will redirect the data from the specified
 *	channel to the topmost channel in a stack.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
 *	channel.
 *
 *----------------------------------------------------------------------
 */

static int
DoWriteChars(chanPtr, src, len)
    Channel *chanPtr;		/* The channel to buffer output for. */
    CONST char *src;		/* UTF-8 characters to queue in output
				 * buffer. */
    int len;			/* Length of string in bytes, or < 0 for
				 * strlen(). */
{
    /*
     * Always use the topmost channel of the stack
     */

    ChannelState *statePtr;	/* state info for channel */

    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;

    if (len < 0) {
	len = strlen(src);
    }
    if (statePtr->encoding == NULL) {
	/*
	 * Inefficient way to convert UTF-8 to byte-array, but the code
	 * parallels the way it is done for objects.
	 */

	Tcl_Obj *objPtr;
	int result;

	objPtr = Tcl_NewStringObj(src, len);
	src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
	result = WriteBytes(chanPtr, src, len);
	TclDecrRefCount(objPtr);
	return result;
    }
    return WriteChars(chanPtr, src, len);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_WriteObj --
 *
 *	Takes the Tcl object and queues its contents for output.  If the
 *	encoding of the channel is NULL, takes the byte-array representation
 *	of the object and queues those bytes for output.  Otherwise, takes the
 *	characters in the UTF-8 (string) representation of the object and
 *	converts them for output using the channel's current encoding.  May
 *	flush internal buffers to output if one becomes full or is ready for
 *	some other reason, e.g. if it contains a newline and the channel is in
 *	line buffering mode.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno() will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
 *	channel.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WriteObj(chan, objPtr)
    Tcl_Channel chan;		/* The channel to buffer output for. */
    Tcl_Obj *objPtr;		/* The object to write. */
{
    /*
     * Always use the topmost channel of the stack
     */

    Channel *chanPtr;
    ChannelState *statePtr;	/* state info for channel */
    char *src;
    int srcLen;

    statePtr = ((Channel *) chan)->state;
    chanPtr = statePtr->topChanPtr;
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
}

/*
 *----------------------------------------------------------------------
 *
 * WriteBytes --
 *
 *	Write a sequence of bytes into an output buffer, may queue the
 *	buffer for output if it gets full, and also remembers whether the
 *	current buffer is ready e.g. if it contains a newline and we are in
 *	line buffering mode.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the







|
|
|
|







3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
}

/*
 *----------------------------------------------------------------------
 *
 * WriteBytes --
 *
 *	Write a sequence of bytes into an output buffer, may queue the buffer
 *	for output if it gets full, and also remembers whether the current
 *	buffer is ready e.g. if it contains a newline and we are in line
 *	buffering mode.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
    int dstMax, sawLF, savedLF, total, dstLen, toWrite;

    total = 0;
    sawLF = 0;
    savedLF = 0;

    /*
     * Loop over all bytes in src, storing them in output buffer with
     * proper EOL translation.
     */

    while (srcLen + savedLF > 0) {
	bufPtr = statePtr->curOutPtr;
	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	    statePtr->curOutPtr = bufPtr;
	}
	dst = bufPtr->buf + bufPtr->nextAdded;
	dstMax = bufPtr->bufLength - bufPtr->nextAdded;
	dstLen = dstMax;

	toWrite = dstLen;
	if (toWrite > srcLen) {
	    toWrite = srcLen;
	}

	if (savedLF) {
	    /*
	     * A '\n' was left over from last call to TranslateOutputEOL()
	     * and we need to store it in this buffer.  If the channel is
	     * line-based, we will need to flush it.
	     */

	    *dst++ = '\n';
	    dstLen--;
	    sawLF++;
	}







|
|



















|
|







3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
    int dstMax, sawLF, savedLF, total, dstLen, toWrite;

    total = 0;
    sawLF = 0;
    savedLF = 0;

    /*
     * Loop over all bytes in src, storing them in output buffer with proper
     * EOL translation.
     */

    while (srcLen + savedLF > 0) {
	bufPtr = statePtr->curOutPtr;
	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	    statePtr->curOutPtr = bufPtr;
	}
	dst = bufPtr->buf + bufPtr->nextAdded;
	dstMax = bufPtr->bufLength - bufPtr->nextAdded;
	dstLen = dstMax;

	toWrite = dstLen;
	if (toWrite > srcLen) {
	    toWrite = srcLen;
	}

	if (savedLF) {
	    /*
	     * A '\n' was left over from last call to TranslateOutputEOL() and
	     * we need to store it in this buffer.  If the channel is
	     * line-based, we will need to flush it.
	     */

	    *dst++ = '\n';
	    dstLen--;
	    sawLF++;
	}
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
}

/*
 *----------------------------------------------------------------------
 *
 * WriteChars --
 *
 *	Convert UTF-8 bytes to the channel's external encoding and
 *	write the produced bytes into an output buffer, may queue the 
 *	buffer for output if it gets full, and also remembers whether the
 *	current buffer is ready e.g. if it contains a newline and we are in
 *	line buffering mode.
 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the







|
|
|
|
<







3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312

3313
3314
3315
3316
3317
3318
3319
}

/*
 *----------------------------------------------------------------------
 *
 * WriteChars --
 *
 *	Convert UTF-8 bytes to the channel's external encoding and write the
 *	produced bytes into an output buffer, may queue the buffer for output
 *	if it gets full, and also remembers whether the current buffer is
 *	ready e.g. if it contains a newline and we are in line buffering mode.

 *
 * Results:
 *	The number of bytes written or -1 in case of error. If -1,
 *	Tcl_GetErrno will return the error code.
 *
 * Side effects:
 *	May buffer up output and may cause output to be produced on the
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
	toWrite = stageLen;
	if (toWrite > srcLen) {
	    toWrite = srcLen;
	}

	if (savedLF) {
	    /*
	     * A '\n' was left over from last call to TranslateOutputEOL()
	     * and we need to store it in the staging buffer.  If the
	     * channel is line-based, we will need to flush the output
	     * buffer (after translating the staging buffer).
	     */

	    *stage++ = '\n';
	    stageLen--;
	    sawLF++;
	}
	if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) {







|
|
|
|







3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
	toWrite = stageLen;
	if (toWrite > srcLen) {
	    toWrite = srcLen;
	}

	if (savedLF) {
	    /*
	     * A '\n' was left over from last call to TranslateOutputEOL() and
	     * we need to store it in the staging buffer. If the channel is
	     * line-based, we will need to flush the output buffer (after
	     * translating the staging buffer).
	     */

	    *stage++ = '\n';
	    stageLen--;
	    sawLF++;
	}
	if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) {
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
		statePtr->curOutPtr = bufPtr;
	    }
	    dst = bufPtr->buf + bufPtr->nextAdded;
	    dstLen = bufPtr->bufLength - bufPtr->nextAdded;

	    if (saved != 0) {
		/*
		 * Here's some translated bytes left over from the last
		 * buffer that we need to stick at the beginning of this
		 * buffer.
		 */

		memcpy((VOID *) dst, (VOID *) safe, (size_t) saved);
		bufPtr->nextAdded += saved;
		dst += saved;
		dstLen -= saved;
		saved = 0;







|
|
<







3405
3406
3407
3408
3409
3410
3411
3412
3413

3414
3415
3416
3417
3418
3419
3420
		statePtr->curOutPtr = bufPtr;
	    }
	    dst = bufPtr->buf + bufPtr->nextAdded;
	    dstLen = bufPtr->bufLength - bufPtr->nextAdded;

	    if (saved != 0) {
		/*
		 * Here's some translated bytes left over from the last buffer
		 * that we need to stick at the beginning of this buffer.

		 */

		memcpy((VOID *) dst, (VOID *) safe, (size_t) saved);
		bufPtr->nextAdded += saved;
		dst += saved;
		dstLen -= saved;
		saved = 0;
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
		savedLF = 0;
		break;
	    }
	    bufPtr->nextAdded += dstWrote;
	    if (bufPtr->nextAdded > bufPtr->bufLength) {
		/*
		 * When translating from UTF-8 to external encoding, we
		 * allowed the translation to produce a character that
		 * crossed the end of the output buffer, so that we would
		 * get a completely full buffer before flushing it.  The
		 * extra bytes will be moved to the beginning of the next
		 * buffer.
		 */

		saved = bufPtr->nextAdded - bufPtr->bufLength;
		memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved);
		bufPtr->nextAdded = bufPtr->bufLength;
	    }
	    if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {







|
|
|
|
<







3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469

3470
3471
3472
3473
3474
3475
3476
		savedLF = 0;
		break;
	    }
	    bufPtr->nextAdded += dstWrote;
	    if (bufPtr->nextAdded > bufPtr->bufLength) {
		/*
		 * When translating from UTF-8 to external encoding, we
		 * allowed the translation to produce a character that crossed
		 * the end of the output buffer, so that we would get a
		 * completely full buffer before flushing it.  The extra bytes
		 * will be moved to the beginning of the next buffer.

		 */

		saved = bufPtr->nextAdded - bufPtr->bufLength;
		memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved);
		bufPtr->nextAdded = bufPtr->bufLength;
	    }
	    if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
3251
3252
3253
3254
3255
3256
3257

3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427

	    if ((stageLen + saved == 0) && (result == 0)) {
		endEncoding = 0;
	    }
	}
    }


    /* If nothing was written and it happened because there was no progress
     * in the UTF conversion, we throw an error.
     */

    if (!consumedSomething && (total == 0)) {
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    return total;
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateOutputEOL --
 *
 *	Helper function for WriteBytes() and WriteChars().  Converts the
 *	'\n' characters in the source buffer into the appropriate EOL
 *	form specified by the output translation mode.
 *
 *	EOL translation stops either when the source buffer is empty
 *	or the output buffer is full.
 *
 *	When converting to CRLF mode and there is only 1 byte left in
 *	the output buffer, this routine stores the '\r' in the last
 *	byte and then stores the '\n' in the byte just past the end of the 
 *	buffer.  The caller is responsible for passing in a buffer that
 *	is large enough to hold the extra byte.
 *
 * Results:
 *	The return value is 1 if a '\n' was translated from the source
 *	buffer, or 0 otherwise -- this can be used by the caller to
 *	decide to flush a line-based channel even though the channel
 *	buffer is not full.
 *
 *	*dstLenPtr is filled with how many bytes of the output buffer
 *	were used.  As mentioned above, this can be one more that
 *	the output buffer's specified length if a CRLF was stored.
 *
 *	*srcLenPtr is filled with how many bytes of the source buffer
 *	were consumed.  
 *
 * Side effects:
 *	It may be obvious, but bears mentioning that when converting
 *	in CRLF mode (which requires two bytes of storage in the output
 *	buffer), the number of bytes consumed from the source buffer
 *	will be less than the number of bytes stored in the output buffer.
 *
 *---------------------------------------------------------------------------
 */

static int
TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr)
    ChannelState *statePtr;	/* Channel being read, for translation and
				 * buffering modes. */
    char *dst;			/* Output buffer filled with UTF-8 chars by
				 * applying appropriate EOL translation to
				 * source characters. */
    CONST char *src;		/* Source UTF-8 characters. */
    int *dstLenPtr;		/* On entry, the maximum length of output
				 * buffer in bytes.  On exit, the number of
				 * bytes actually used in output buffer. */
    int *srcLenPtr;		/* On entry, the length of source buffer.
				 * On exit, the number of bytes read from
				 * the source buffer. */
{
    char *dstEnd;
    int srcLen, newlineFound;

    newlineFound = 0;
    srcLen = *srcLenPtr;

    switch (statePtr->outputTranslation) {
	case TCL_TRANSLATE_LF: {
	    for (dstEnd = dst + srcLen; dst < dstEnd; ) {
		if (*src == '\n') {
		    newlineFound = 1;
		}
		*dst++ = *src++;
	    }
	    *dstLenPtr = srcLen;
	    break;
	}
	case TCL_TRANSLATE_CR: {
	    for (dstEnd = dst + srcLen; dst < dstEnd;) {
		if (*src == '\n') {
		    *dst++ = '\r';
		    newlineFound = 1;
		    src++;
		} else {
		    *dst++ = *src++;
		}
	    }
	    *dstLenPtr = srcLen;
	    break;
	}
	case TCL_TRANSLATE_CRLF: {
	    /*
	     * Since this causes the number of bytes to grow, we
	     * start off trying to put 'srcLen' bytes into the
	     * output buffer, but allow it to store more bytes, as
	     * long as there's still source bytes and room in the
	     * output buffer.
	     */

	    char *dstStart, *dstMax;
	    CONST char *srcStart;

	    dstStart = dst;
	    dstMax = dst + *dstLenPtr;

	    srcStart = src;

	    if (srcLen < *dstLenPtr) {
		dstEnd = dst + srcLen;
	    } else {
		dstEnd = dst + *dstLenPtr;
	    }
	    while (dst < dstEnd) {
		if (*src == '\n') {
		    if (dstEnd < dstMax) {
			dstEnd++;
		    }
		    *dst++ = '\r';
		    newlineFound = 1;
		}
		*dst++ = *src++;
	    }
	    *srcLenPtr = src - srcStart;
	    *dstLenPtr = dst - dstStart;
	    break;
	}
	default: {
	    break;
	}
    }
    return newlineFound;
}

/*
 *---------------------------------------------------------------------------
 *
 * CheckFlush --
 *
 *	Helper function for WriteBytes() and WriteChars().  If the
 *	channel buffer is ready to be flushed, flush it.
 *
 * Results:
 *	The return value is -1 if there was a problem flushing the
 *	channel buffer, or 0 otherwise.
 *
 * Side effects:
 *	The buffer will be recycled if it is flushed.
 *
 *---------------------------------------------------------------------------
 */

static int
CheckFlush(chanPtr, bufPtr, newlineFlag)
    Channel *chanPtr;		/* Channel being read, for buffering mode. */
    ChannelBuffer *bufPtr;	/* Channel buffer to possibly flush. */
    int newlineFlag;		/* Non-zero if a the channel buffer
				 * contains a newline. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    /*
     * The current buffer is ready for output:
     * 1. if it is full.
     * 2. if it contains a newline and this channel is line-buffered.
     * 3. if it contains any output and this channel is unbuffered.







>
|
|














|
|
|

|
|

|
|
|
|
|


|
|
|
<

|
|
|

|
|


|
|
|
|















|
|
|








|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
<
|
|
|
|

|
|

|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<









|
|


|
|











|
|







3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532

3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580

3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592

3593
3594
3595

3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629

3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664

	    if ((stageLen + saved == 0) && (result == 0)) {
		endEncoding = 0;
	    }
	}
    }

    /*
     * If nothing was written and it happened because there was no progress in
     * the UTF conversion, we throw an error.
     */

    if (!consumedSomething && (total == 0)) {
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    return total;
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateOutputEOL --
 *
 *	Helper function for WriteBytes() and WriteChars().  Converts the '\n'
 *	characters in the source buffer into the appropriate EOL form
 *	specified by the output translation mode.
 *
 *	EOL translation stops either when the source buffer is empty or the
 *	output buffer is full.
 *
 *	When converting to CRLF mode and there is only 1 byte left in the
 *	output buffer, this routine stores the '\r' in the last byte and then
 *	stores the '\n' in the byte just past the end of the buffer.  The
 *	caller is responsible for passing in a buffer that is large enough to
 *	hold the extra byte.
 *
 * Results:
 *	The return value is 1 if a '\n' was translated from the source buffer,
 *	or 0 otherwise -- this can be used by the caller to decide to flush a
 *	line-based channel even though the channel buffer is not full.

 *
 *	*dstLenPtr is filled with how many bytes of the output buffer were
 *	used.  As mentioned above, this can be one more that the output
 *	buffer's specified length if a CRLF was stored.
 *
 *	*srcLenPtr is filled with how many bytes of the source buffer were
 *	consumed.
 *
 * Side effects:
 *	It may be obvious, but bears mentioning that when converting in CRLF
 *	mode (which requires two bytes of storage in the output buffer), the
 *	number of bytes consumed from the source buffer will be less than the
 *	number of bytes stored in the output buffer.
 *
 *---------------------------------------------------------------------------
 */

static int
TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr)
    ChannelState *statePtr;	/* Channel being read, for translation and
				 * buffering modes. */
    char *dst;			/* Output buffer filled with UTF-8 chars by
				 * applying appropriate EOL translation to
				 * source characters. */
    CONST char *src;		/* Source UTF-8 characters. */
    int *dstLenPtr;		/* On entry, the maximum length of output
				 * buffer in bytes.  On exit, the number of
				 * bytes actually used in output buffer. */
    int *srcLenPtr;		/* On entry, the length of source buffer.  On
				 * exit, the number of bytes read from the
				 * source buffer. */
{
    char *dstEnd;
    int srcLen, newlineFound;

    newlineFound = 0;
    srcLen = *srcLenPtr;

    switch (statePtr->outputTranslation) {
    case TCL_TRANSLATE_LF:
	for (dstEnd = dst + srcLen; dst < dstEnd; ) {
	    if (*src == '\n') {
		newlineFound = 1;
	    }
	    *dst++ = *src++;
	}
	*dstLenPtr = srcLen;
	break;

    case TCL_TRANSLATE_CR:
	for (dstEnd = dst + srcLen; dst < dstEnd;) {
	    if (*src == '\n') {
		*dst++ = '\r';
		newlineFound = 1;
		src++;
	    } else {
		*dst++ = *src++;
	    }
	}
	*dstLenPtr = srcLen;
	break;

    case TCL_TRANSLATE_CRLF: {
	/*
	 * Since this causes the number of bytes to grow, we start off trying

	 * to put 'srcLen' bytes into the output buffer, but allow it to store
	 * more bytes, as long as there's still source bytes and room in the
	 * output buffer.
	 */

	char *dstStart, *dstMax;
	CONST char *srcStart;

	dstStart = dst;
	dstMax = dst + *dstLenPtr;

	srcStart = src;

	if (srcLen < *dstLenPtr) {
	    dstEnd = dst + srcLen;
	} else {
	    dstEnd = dst + *dstLenPtr;
	}
	while (dst < dstEnd) {
	    if (*src == '\n') {
		if (dstEnd < dstMax) {
		    dstEnd++;
		}
		*dst++ = '\r';
		newlineFound = 1;
	    }
	    *dst++ = *src++;
	}
	*srcLenPtr = src - srcStart;
	*dstLenPtr = dst - dstStart;
	break;
    }
    default:
	break;

    }
    return newlineFound;
}

/*
 *---------------------------------------------------------------------------
 *
 * CheckFlush --
 *
 *	Helper function for WriteBytes() and WriteChars().  If the channel
 *	buffer is ready to be flushed, flush it.
 *
 * Results:
 *	The return value is -1 if there was a problem flushing the channel
 *	buffer, or 0 otherwise.
 *
 * Side effects:
 *	The buffer will be recycled if it is flushed.
 *
 *---------------------------------------------------------------------------
 */

static int
CheckFlush(chanPtr, bufPtr, newlineFlag)
    Channel *chanPtr;		/* Channel being read, for buffering mode. */
    ChannelBuffer *bufPtr;	/* Channel buffer to possibly flush. */
    int newlineFlag;		/* Non-zero if a the channel buffer contains a
				 * newline. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    /*
     * The current buffer is ready for output:
     * 1. if it is full.
     * 2. if it contains a newline and this channel is line-buffered.
     * 3. if it contains any output and this channel is unbuffered.
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
 *
 * Results:
 *	Length of line read (in characters) or -1 if error, EOF, or blocked.
 *	If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the
 *	error or condition that occurred.
 *
 * Side effects:
 *	May flush output on the channel.  May cause input to be consumed
 *	from the channel.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_Gets(chan, lineRead)
    Tcl_Channel chan;		/* Channel from which to read. */







|
|







3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
 *
 * Results:
 *	Length of line read (in characters) or -1 if error, EOF, or blocked.
 *	If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the
 *	error or condition that occurred.
 *
 * Side effects:
 *	May flush output on the channel.  May cause input to be consumed from
 *	the channel.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_Gets(chan, lineRead)
    Tcl_Channel chan;		/* Channel from which to read. */
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_GetsObj --
 *
 *	Accumulate input from the input channel until end-of-line or
 *	end-of-file has been seen.  Bytes read from the input channel
 *	are converted to UTF-8 using the encoding specified by the
 *	channel.
 *
 * Results:
 *	Number of characters accumulated in the object or -1 if error,
 *	blocked, or EOF.  If -1, use Tcl_GetErrno() to retrieve the
 *	POSIX error code for the error or condition that occurred.
 *
 * Side effects:
 *	Consumes input from the channel.
 *
 *	On reading EOF, leave channel pointing at EOF char.
 *	On reading EOL, leave channel pointing after EOL, but don't
 *	return EOL in dst buffer.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_GetsObj(chan, objPtr)
    Tcl_Channel chan;		/* Channel from which to read. */







|
|
<



|
|




|
|
<







3726
3727
3728
3729
3730
3731
3732
3733
3734

3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745

3746
3747
3748
3749
3750
3751
3752

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_GetsObj --
 *
 *	Accumulate input from the input channel until end-of-line or
 *	end-of-file has been seen.  Bytes read from the input channel are
 *	converted to UTF-8 using the encoding specified by the channel.

 *
 * Results:
 *	Number of characters accumulated in the object or -1 if error,
 *	blocked, or EOF.  If -1, use Tcl_GetErrno() to retrieve the POSIX
 *	error code for the error or condition that occurred.
 *
 * Side effects:
 *	Consumes input from the channel.
 *
 *	On reading EOF, leave channel pointing at EOF char.  On reading EOL,
 *	leave channel pointing after EOL, but don't return EOL in dst buffer.

 *
 *---------------------------------------------------------------------------
 */

int
Tcl_GetsObj(chan, objPtr)
    Tcl_Channel chan;		/* Channel from which to read. */
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
	goto done;
    }

    bufPtr = statePtr->inQueueHead;
    encoding = statePtr->encoding;

    /*
     * Preserved so we can restore the channel's state in case we don't
     * find a newline in the available input.
     */

    Tcl_GetStringFromObj(objPtr, &oldLength);
    oldFlags = statePtr->inputEncodingFlags;
    oldState = statePtr->inputEncodingState;
    oldRemoved = BUFFER_PADDING;
    if (bufPtr != NULL) {
	oldRemoved = bufPtr->nextRemoved;
    }

    /*
     * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't
     * produce ByteArray objects.  
     */

    if (encoding == NULL) {
	encoding = Tcl_GetEncoding(NULL, "iso8859-1");
    }

    /*
     * Object used by FilterInputBytes to keep track of how much data has
     * been consumed from the channel buffers.
     */

    gs.objPtr		= objPtr;
    gs.dstPtr		= &dst;
    gs.encoding		= encoding;
    gs.bufPtr		= bufPtr;
    gs.state		= oldState;







|
|












|







|
|







3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
	goto done;
    }

    bufPtr = statePtr->inQueueHead;
    encoding = statePtr->encoding;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.
     */

    Tcl_GetStringFromObj(objPtr, &oldLength);
    oldFlags = statePtr->inputEncodingFlags;
    oldState = statePtr->inputEncodingState;
    oldRemoved = BUFFER_PADDING;
    if (bufPtr != NULL) {
	oldRemoved = bufPtr->nextRemoved;
    }

    /*
     * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't
     * produce ByteArray objects.
     */

    if (encoding == NULL) {
	encoding = Tcl_GetEncoding(NULL, "iso8859-1");
    }

    /*
     * Object used by FilterInputBytes to keep track of how much data has been
     * consumed from the channel buffers.
     */

    gs.objPtr		= objPtr;
    gs.dstPtr		= &dst;
    gs.encoding		= encoding;
    gs.bufPtr		= bufPtr;
    gs.state		= oldState;
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
	    if (FilterInputBytes(chanPtr, &gs) != 0) {
		goto restore;
	    }
	    dstEnd = dst + gs.bytesWrote;
	}

	/*
	 * Remember if EOF char is seen, then look for EOL anyhow, because
	 * the EOL might be before the EOF char.
	 */

	if (inEofChar != '\0') {
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == inEofChar) {
		    dstEnd = eol;
		    eof = eol;
		    break;
		}
	    }
	}

	/*
	 * On EOL, leave current file position pointing after the EOL, but
	 * don't store the EOL in the output string.
	 */

	switch (statePtr->inputTranslation) {
	    case TCL_TRANSLATE_LF: {
		for (eol = dst; eol < dstEnd; eol++) {
		    if (*eol == '\n') {
			skip = 1;
			goto goteol;
		    }
		}
		break;
	    }
	    case TCL_TRANSLATE_CR: {
		for (eol = dst; eol < dstEnd; eol++) {
		    if (*eol == '\r') {
			skip = 1;
			goto goteol;
		    }
		}
		break;
	    }
	    case TCL_TRANSLATE_CRLF: {
		for (eol = dst; eol < dstEnd; eol++) {
		    if (*eol == '\r') {
			eol++;

			/*
			 * If a CR is at the end of the buffer,
			 * then check for a LF at the begining
			 * of the next buffer.
			 */

			if (eol >= dstEnd) {
			    int offset;

			    offset = eol - objPtr->bytes;
			    dst = dstEnd;
			    if (FilterInputBytes(chanPtr, &gs) != 0) {
				goto restore;
			    }
			    dstEnd = dst + gs.bytesWrote;
			    eol = objPtr->bytes + offset;
			    if (eol >= dstEnd) {
				skip = 0;
				goto goteol;
			    }
			}
			if (*eol == '\n') {
			    eol--;
			    skip = 2;
			    goto goteol;
			}
		    }
		}
		break;
	    }
	    case TCL_TRANSLATE_AUTO: {
		eol = dst;
		skip = 1;
		if (statePtr->flags & INPUT_SAW_CR) {
		    statePtr->flags &= ~INPUT_SAW_CR;
		    if ((eol < dstEnd) && (*eol == '\n')) {
			/*
			 * Skip the raw bytes that make up the '\n'.
			 */

			char tmp[1 + TCL_UTF_MAX];
			int rawRead;

			bufPtr = gs.bufPtr;
			Tcl_ExternalToUtf(NULL, gs.encoding,
				bufPtr->buf + bufPtr->nextRemoved,
				gs.rawRead, statePtr->inputEncodingFlags,
				&gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead,
				NULL, NULL);
			bufPtr->nextRemoved += rawRead;
			gs.rawRead -= rawRead;
			gs.bytesWrote--;
			gs.charsWrote--;
			memmove(dst, dst + 1, (size_t) (dstEnd - dst));
			dstEnd--;
		    }
		}
		for (eol = dst; eol < dstEnd; eol++) {
		    if (*eol == '\r') {
			eol++;
			if (eol == dstEnd) {
			    /*
			     * If buffer ended on \r, peek ahead to see if a
			     * \n is available.
			     */

			    int offset;

			    offset = eol - objPtr->bytes;
			    dst = dstEnd;
			    PeekAhead(chanPtr, &dstEnd, &gs);
			    eol = objPtr->bytes + offset;
			    if (eol >= dstEnd) {
				eol--;
				statePtr->flags |= INPUT_SAW_CR;
				goto goteol;
			    }
			}
			if (*eol == '\n') {
			    skip++;
			}
			eol--;
			goto goteol;
		    } else if (*eol == '\n') {
			goto goteol;
		    }
		}
	    }
	}
	if (eof != NULL) {
	    /*
	     * EOF character was seen.  On EOF, leave current file position
	     * pointing at the EOF character, but don't store the EOF







|
|


















|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
<
|
|
|
|

|
|
<
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|

|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<







3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859

3860
3861
3862
3863
3864
3865
3866
3867

3868
3869
3870
3871
3872
3873
3874

3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900

3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918

3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954

3955
3956
3957
3958
3959
3960
3961
	    if (FilterInputBytes(chanPtr, &gs) != 0) {
		goto restore;
	    }
	    dstEnd = dst + gs.bytesWrote;
	}

	/*
	 * Remember if EOF char is seen, then look for EOL anyhow, because the
	 * EOL might be before the EOF char.
	 */

	if (inEofChar != '\0') {
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == inEofChar) {
		    dstEnd = eol;
		    eof = eol;
		    break;
		}
	    }
	}

	/*
	 * On EOL, leave current file position pointing after the EOL, but
	 * don't store the EOL in the output string.
	 */

	switch (statePtr->inputTranslation) {
	case TCL_TRANSLATE_LF:
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == '\n') {
		    skip = 1;
		    goto gotEOL;
		}
	    }
	    break;

	case TCL_TRANSLATE_CR:
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == '\r') {
		    skip = 1;
		    goto gotEOL;
		}
	    }
	    break;

	case TCL_TRANSLATE_CRLF:
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == '\r') {
		    eol++;

		    /*
		     * If a CR is at the end of the buffer, then check for a

		     * LF at the begining of the next buffer.
		     */

		    if (eol >= dstEnd) {
			int offset;

			offset = eol - objPtr->bytes;
			dst = dstEnd;
			if (FilterInputBytes(chanPtr, &gs) != 0) {
			    goto restore;
			}
			dstEnd = dst + gs.bytesWrote;
			eol = objPtr->bytes + offset;
			if (eol >= dstEnd) {
			    skip = 0;
			    goto gotEOL;
			}
		    }
		    if (*eol == '\n') {
			eol--;
			skip = 2;
			goto gotEOL;
		    }
		}
	    }
	    break;

	case TCL_TRANSLATE_AUTO:
	    eol = dst;
	    skip = 1;
	    if (statePtr->flags & INPUT_SAW_CR) {
		statePtr->flags &= ~INPUT_SAW_CR;
		if ((eol < dstEnd) && (*eol == '\n')) {
		    /*
		     * Skip the raw bytes that make up the '\n'.
		     */

		    char tmp[1 + TCL_UTF_MAX];
		    int rawRead;

		    bufPtr = gs.bufPtr;
		    Tcl_ExternalToUtf(NULL, gs.encoding,
			    bufPtr->buf + bufPtr->nextRemoved, gs.rawRead,
			    statePtr->inputEncodingFlags, &gs.state, tmp,
			    1 + TCL_UTF_MAX, &rawRead, NULL, NULL);

		    bufPtr->nextRemoved += rawRead;
		    gs.rawRead -= rawRead;
		    gs.bytesWrote--;
		    gs.charsWrote--;
		    memmove(dst, dst + 1, (size_t) (dstEnd - dst));
		    dstEnd--;
		}
	    }
	    for (eol = dst; eol < dstEnd; eol++) {
		if (*eol == '\r') {
		    eol++;
		    if (eol == dstEnd) {
			/*
			 * If buffer ended on \r, peek ahead to see if a \n is
			 * available.
			 */

			int offset;

			offset = eol - objPtr->bytes;
			dst = dstEnd;
			PeekAhead(chanPtr, &dstEnd, &gs);
			eol = objPtr->bytes + offset;
			if (eol >= dstEnd) {
			    eol--;
			    statePtr->flags |= INPUT_SAW_CR;
			    goto gotEOL;
			}
		    }
		    if (*eol == '\n') {
			skip++;
		    }
		    eol--;
		    goto gotEOL;
		} else if (*eol == '\n') {
		    goto gotEOL;

		}
	    }
	}
	if (eof != NULL) {
	    /*
	     * EOF character was seen.  On EOF, leave current file position
	     * pointing at the EOF character, but don't store the EOF
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
		 */

		Tcl_SetObjLength(objPtr, oldLength);
		CommonGetsCleanup(chanPtr, encoding);
		copiedTotal = -1;
		goto done;
	    }
	    goto goteol;
	}
	dst = dstEnd;
    }

    /*
     * Found EOL or EOF, but the output buffer may now contain too many
     * UTF-8 characters.  We need to know how many raw bytes correspond to
     * the number of UTF-8 characters we want, plus how many raw bytes
     * correspond to the character(s) making up EOL (if any), so we can
     * remove the correct number of bytes from the channel buffer.
     */

    goteol:
    bufPtr = gs.bufPtr;
    statePtr->inputEncodingState = gs.state;
    Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved,
	    gs.rawRead, statePtr->inputEncodingFlags,
	    &statePtr->inputEncodingState, dst,
	    eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL,
	    &gs.charsWrote);







|





|
|
|
|
|


|







3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
		 */

		Tcl_SetObjLength(objPtr, oldLength);
		CommonGetsCleanup(chanPtr, encoding);
		copiedTotal = -1;
		goto done;
	    }
	    goto gotEOL;
	}
	dst = dstEnd;
    }

    /*
     * Found EOL or EOF, but the output buffer may now contain too many UTF-8
     * characters.  We need to know how many raw bytes correspond to the
     * number of UTF-8 characters we want, plus how many raw bytes correspond
     * to the character(s) making up EOL (if any), so we can remove the
     * correct number of bytes from the channel buffer.
     */

  gotEOL:
    bufPtr = gs.bufPtr;
    statePtr->inputEncodingState = gs.state;
    Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved,
	    gs.rawRead, statePtr->inputEncodingFlags,
	    &statePtr->inputEncodingState, dst,
	    eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL,
	    &gs.charsWrote);
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825

3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
    CommonGetsCleanup(chanPtr, encoding);
    statePtr->flags &= ~CHANNEL_BLOCKED;
    copiedTotal = gs.totalChars + gs.charsWrote - skip;
    goto done;

    /*
     * Couldn't get a complete line.  This only happens if we get a error
     * reading from the channel or we are non-blocking and there wasn't
     * an EOL or EOF in the data available.
     */

    restore:
    bufPtr = statePtr->inQueueHead;
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr, encoding);

    statePtr->inputEncodingState = oldState;
    statePtr->inputEncodingFlags = oldFlags;
    Tcl_SetObjLength(objPtr, oldLength);

    /*
     * We didn't get a complete line so we need to indicate to UpdateInterest
     * that the gets blocked.  It will wait for more data instead of firing
     * a timer, avoiding a busy wait.  This is where we are assuming that the
     * next operation is a gets.  No more file events will be delivered on 
     * this channel until new data arrives or some operation is performed
     * on the channel (e.g. gets, read, fconfigure) that changes the blocking
     * state.  Note that this means a file event will not be delivered even
     * though a read would be able to consume the buffered data.
     */

    statePtr->flags |= CHANNEL_NEED_MORE_DATA;
    copiedTotal = -1;

    done:
    /*
     * Update the notifier state so we don't block while there is still
     * data in the buffers.
     */


    UpdateInterest(chanPtr);
    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * FilterInputBytes --
 *
 *	Helper function for Tcl_GetsObj.  Produces UTF-8 characters from
 *	raw bytes read from the channel.  
 *
 *	Consumes available bytes from channel buffers.  When channel
 *	buffers are exhausted, reads more bytes from channel device into
 *	a new channel buffer.  It is the caller's responsibility to
 *	free the channel buffers that have been exhausted.
 *
 * Results:
 *	The return value is -1 if there was an error reading from the
 *	channel, 0 otherwise.
 *
 * Side effects:
 *	Status object keeps track of how much data from channel buffers
 *	has been consumed and where UTF-8 bytes should be stored.
 *
 *---------------------------------------------------------------------------
 */

static int
FilterInputBytes(chanPtr, gsPtr)
    Channel *chanPtr;		/* Channel to read. */
    GetsState *gsPtr;		/* Current state of gets operation. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
    char *raw, *rawStart, *rawEnd;
    char *dst;
    int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length;
    Tcl_Obj *objPtr;
#define ENCODING_LINESIZE   20	/* Lower bound on how many bytes to convert
				 * at a time.  Since we don't know a priori
				 * how many bytes of storage this many source
				 * bytes will use, we actually need at least
				 * ENCODING_LINESIZE * TCL_MAX_UTF bytes of
				 * room. */

    objPtr = gsPtr->objPtr;

    /*







|
|


|














|
|
|
|
|







<

|
|


>









|
|

|
|
|
|


|
|


|
|















|
|
|







4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048

4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
    CommonGetsCleanup(chanPtr, encoding);
    statePtr->flags &= ~CHANNEL_BLOCKED;
    copiedTotal = gs.totalChars + gs.charsWrote - skip;
    goto done;

    /*
     * Couldn't get a complete line.  This only happens if we get a error
     * reading from the channel or we are non-blocking and there wasn't an EOL
     * or EOF in the data available.
     */

  restore:
    bufPtr = statePtr->inQueueHead;
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr, encoding);

    statePtr->inputEncodingState = oldState;
    statePtr->inputEncodingFlags = oldFlags;
    Tcl_SetObjLength(objPtr, oldLength);

    /*
     * We didn't get a complete line so we need to indicate to UpdateInterest
     * that the gets blocked.  It will wait for more data instead of firing a
     * timer, avoiding a busy wait.  This is where we are assuming that the
     * next operation is a gets.  No more file events will be delivered on
     * this channel until new data arrives or some operation is performed on
     * the channel (e.g. gets, read, fconfigure) that changes the blocking
     * state.  Note that this means a file event will not be delivered even
     * though a read would be able to consume the buffered data.
     */

    statePtr->flags |= CHANNEL_NEED_MORE_DATA;
    copiedTotal = -1;


    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * FilterInputBytes --
 *
 *	Helper function for Tcl_GetsObj.  Produces UTF-8 characters from raw
 *	bytes read from the channel.
 *
 *	Consumes available bytes from channel buffers.  When channel buffers
 *	are exhausted, reads more bytes from channel device into a new channel
 *	buffer.  It is the caller's responsibility to free the channel buffers
 *	that have been exhausted.
 *
 * Results:
 *	The return value is -1 if there was an error reading from the channel,
 *	0 otherwise.
 *
 * Side effects:
 *	Status object keeps track of how much data from channel buffers has
 *	been consumed and where UTF-8 bytes should be stored.
 *
 *---------------------------------------------------------------------------
 */

static int
FilterInputBytes(chanPtr, gsPtr)
    Channel *chanPtr;		/* Channel to read. */
    GetsState *gsPtr;		/* Current state of gets operation. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
    char *raw, *rawStart, *rawEnd;
    char *dst;
    int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length;
    Tcl_Obj *objPtr;
#define ENCODING_LINESIZE   20	/* Lower bound on how many bytes to convert at
				 * a time.  Since we don't know a priori how
				 * many bytes of storage this many source
				 * bytes will use, we actually need at least
				 * ENCODING_LINESIZE * TCL_MAX_UTF bytes of
				 * room. */

    objPtr = gsPtr->objPtr;

    /*
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
	    bufPtr = bufPtr->nextPtr;
	}
    }
    gsPtr->totalChars += gsPtr->charsWrote;

    if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
	/*
	 * All channel buffers were exhausted and the caller still hasn't
	 * seen EOL.  Need to read more bytes from the channel device.
	 * Side effect is to allocate another channel buffer.
	 */

	read:
	if (statePtr->flags & CHANNEL_BLOCKED) {
	    if (statePtr->flags & CHANNEL_NONBLOCKING) {
		gsPtr->charsWrote = 0;
		gsPtr->rawRead = 0;
		return -1;
	    }
	    statePtr->flags &= ~CHANNEL_BLOCKED;







|
|
|


|







4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
	    bufPtr = bufPtr->nextPtr;
	}
    }
    gsPtr->totalChars += gsPtr->charsWrote;

    if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
	/*
	 * All channel buffers were exhausted and the caller still hasn't seen
	 * EOL.  Need to read more bytes from the channel device.  Side effect
	 * is to allocate another channel buffer.
	 */

    read:
	if (statePtr->flags & CHANNEL_BLOCKED) {
	    if (statePtr->flags & CHANNEL_NONBLOCKING) {
		gsPtr->charsWrote = 0;
		gsPtr->rawRead = 0;
		return -1;
	    }
	    statePtr->flags &= ~CHANNEL_BLOCKED;
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
     */

    statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;

    if (result == TCL_CONVERT_MULTIBYTE) {
	/*
	 * The last few bytes in this channel buffer were the start of a
	 * multibyte sequence.  If this buffer was full, then move them to
	 * the next buffer so the bytes will be contiguous.  
	 */

	ChannelBuffer *nextPtr;
	int extra;

	nextPtr = bufPtr->nextPtr;
	if (bufPtr->nextAdded < bufPtr->bufLength) {







|
|







4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
     */

    statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;

    if (result == TCL_CONVERT_MULTIBYTE) {
	/*
	 * The last few bytes in this channel buffer were the start of a
	 * multibyte sequence.  If this buffer was full, then move them to the
	 * next buffer so the bytes will be contiguous.
	 */

	ChannelBuffer *nextPtr;
	int extra;

	nextPtr = bufPtr->nextPtr;
	if (bufPtr->nextAdded < bufPtr->bufLength) {
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
		 * There was a partial character followed by EOF on the
		 * device.  Fall through, returning that nothing was found.
		 */

		bufPtr->nextRemoved = bufPtr->nextAdded;
	    } else {
		/*
		 * There are no more cached raw bytes left.  See if we can
		 * get some more.
		 */

		goto read;
	    }
	} else {
	    if (nextPtr == NULL) {
		nextPtr = AllocChannelBuffer(statePtr->bufSize);







|
|







4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
		 * There was a partial character followed by EOF on the
		 * device.  Fall through, returning that nothing was found.
		 */

		bufPtr->nextRemoved = bufPtr->nextAdded;
	    } else {
		/*
		 * There are no more cached raw bytes left.  See if we can get
		 * some more.
		 */

		goto read;
	    }
	} else {
	    if (nextPtr == NULL) {
		nextPtr = AllocChannelBuffer(statePtr->bufSize);
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
}

/*
 *---------------------------------------------------------------------------
 *
 * PeekAhead --
 *
 *	Helper function used by Tcl_GetsObj().  Called when we've seen a
 *	\r at the end of the UTF-8 string and want to look ahead one
 *	character to see if it is a \n.
 *
 * Results:
 *	*gsPtr->dstPtr is filled with a pointer to the start of the range of
 *	UTF-8 characters that were found by peeking and *dstEndPtr is filled
 *	with a pointer to the bytes just after the end of the range.
 *
 * Side effects:
 *	If no more raw bytes were available in one of the channel buffers,
 *	tries to perform a non-blocking read to get more bytes from the
 *	channel device.
 *
 *---------------------------------------------------------------------------
 */

static void
PeekAhead(chanPtr, dstEndPtr, gsPtr)
    Channel *chanPtr;		/* The channel to read. */
    char **dstEndPtr;		/* Filled with pointer to end of new range
				 * of UTF-8 characters. */
    GetsState *gsPtr;		/* Current state of gets operation. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
    Tcl_DriverBlockModeProc *blockModeProc;
    int bytesLeft;

    bufPtr = gsPtr->bufPtr;

    /*
     * If there's any more raw input that's still buffered, we'll peek into
     * that.  Otherwise, only get more data from the channel driver if it
     * looks like there might actually be more data.  The assumption is that
     * if the channel buffer is filled right up to the end, then there
     * might be more data to read.
     */

    blockModeProc = NULL;
    if (bufPtr->nextPtr == NULL) {
	bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead);
	if (bytesLeft == 0) {
	    if (bufPtr->nextAdded < bufPtr->bufLength) {







|
|
|

















|
|











|
|
|
|







4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
}

/*
 *---------------------------------------------------------------------------
 *
 * PeekAhead --
 *
 *	Helper function used by Tcl_GetsObj().  Called when we've seen a \r at
 *	the end of the UTF-8 string and want to look ahead one character to
 *	see if it is a \n.
 *
 * Results:
 *	*gsPtr->dstPtr is filled with a pointer to the start of the range of
 *	UTF-8 characters that were found by peeking and *dstEndPtr is filled
 *	with a pointer to the bytes just after the end of the range.
 *
 * Side effects:
 *	If no more raw bytes were available in one of the channel buffers,
 *	tries to perform a non-blocking read to get more bytes from the
 *	channel device.
 *
 *---------------------------------------------------------------------------
 */

static void
PeekAhead(chanPtr, dstEndPtr, gsPtr)
    Channel *chanPtr;		/* The channel to read. */
    char **dstEndPtr;		/* Filled with pointer to end of new range of
				 * UTF-8 characters. */
    GetsState *gsPtr;		/* Current state of gets operation. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
    Tcl_DriverBlockModeProc *blockModeProc;
    int bytesLeft;

    bufPtr = gsPtr->bufPtr;

    /*
     * If there's any more raw input that's still buffered, we'll peek into
     * that. Otherwise, only get more data from the channel driver if it looks
     * like there might actually be more data.  The assumption is that if the
     * channel buffer is filled right up to the end, then there might be more
     * data to read.
     */

    blockModeProc = NULL;
    if (bufPtr->nextPtr == NULL) {
	bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead);
	if (bytesLeft == 0) {
	    if (bufPtr->nextAdded < bufPtr->bufLength) {
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
	*dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote;
    }
    if (blockModeProc != NULL) {
	StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
    }
    return;

    cleanup:
    bufPtr->nextRemoved += gsPtr->rawRead;
    gsPtr->rawRead = 0;
    gsPtr->totalChars += gsPtr->charsWrote;
    gsPtr->bytesWrote = 0;
    gsPtr->charsWrote = 0;
}

/*
 *---------------------------------------------------------------------------
 *
 * CommonGetsCleanup --
 *
 *	Helper function for Tcl_GetsObj() to restore the channel after
 *	a "gets" operation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Encoding may be freed.
 *







|












|
|







4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
	*dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote;
    }
    if (blockModeProc != NULL) {
	StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
    }
    return;

  cleanup:
    bufPtr->nextRemoved += gsPtr->rawRead;
    gsPtr->rawRead = 0;
    gsPtr->totalChars += gsPtr->charsWrote;
    gsPtr->bytesWrote = 0;
    gsPtr->charsWrote = 0;
}

/*
 *---------------------------------------------------------------------------
 *
 * CommonGetsCleanup --
 *
 *	Helper function for Tcl_GetsObj() to restore the channel after a
 *	"gets" operation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Encoding may be freed.
 *
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270

4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284

4285
4286
4287
4288

4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299

4300
4301
4302

4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325

4326
4327
4328

4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Read --
 *
 *	Reads a given number of bytes from a channel.  EOL and EOF
 *	translation is done on the bytes being read, so the number
 *	of bytes consumed from the channel may not be equal to the
 *	number of bytes stored in the destination buffer.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes read, or -1 on error. Use Tcl_GetErrno()
 *	to retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Read(chan, dst, bytesToRead)
    Tcl_Channel chan;		/* The channel from which to read. */
    char *dst;			/* Where to store input read. */
    int bytesToRead;		/* Maximum number of bytes to read. */
{
    Channel *chanPtr = (Channel *) chan;		
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;

    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	return -1;
    }

    return DoRead(chanPtr, dst, bytesToRead);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadRaw --
 *
 *	Reads a given number of bytes from a channel.  EOL and EOF
 *	translation is done on the bytes being read, so the number
 *	of bytes consumed from the channel may not be equal to the
 *	number of bytes stored in the destination buffer.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes read, or -1 on error. Use Tcl_GetErrno()
 *	to retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ReadRaw(chan, bufPtr, bytesToRead)
    Tcl_Channel chan;		/* The channel from which to read. */
    char *bufPtr;		/* Where to store input read. */
    int bytesToRead;		/* Maximum number of bytes to read. */
{
    Channel *chanPtr = (Channel *) chan;		
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int nread, result;
    int copied, copiedNow;

    /*
     * The check below does too much because it will reject a call to this
     * function with a channel which is part of an 'fcopy'. But we have to
     * allow this here or else the chaining in the transformation drivers
     * will fail with 'file busy' error instead of retrieving and
     * transforming the data to copy.
     *
     * We let the check procedure now believe that there is no fcopy in
     * progress. A better solution than this might be an additional flag
     * argument to switch off specific checks.
     */

    if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
	return -1;
    }

    /*
     * Check for information in the push-back buffers. If there is
     * some, use it. Go to the driver only if there is none (anymore)
     * and the caller requests more bytes.
     */

    for (copied = 0; copied < bytesToRead; copied += copiedNow) {
	copiedNow = CopyBuffer(chanPtr, bufPtr + copied,
		bytesToRead - copied);
	if (copiedNow == 0) {
	    if (statePtr->flags & CHANNEL_EOF) {
		goto done;
	    }
	    if (statePtr->flags & CHANNEL_BLOCKED) {
		if (statePtr->flags & CHANNEL_NONBLOCKING) {
		    goto done;
		}
		statePtr->flags &= (~(CHANNEL_BLOCKED));
	    }

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING

	    /* [SF Tcl Bug 943274]. Better emulation of non-blocking
	     * channels for channels without BlockModeProc, by keeping
	     * track of true fileevents generated by the OS == Data
	     * waiting and reading if and only if we are sure to have
	     * data.
	     */

	    if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
		    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
		    !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
		/*
		 * We bypass the driver, it would block, as no data is
		 * available
		 */

		nread = -1;
		result = EWOULDBLOCK;
	    } else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

		/*
		 * Now go to the driver to get as much as is possible to
		 * fill the remaining request. Do all the error handling
		 * by ourselves.  The code was stolen from 'GetInput' and
		 * slightly adapted (different return value here).
		 *
		 * The case of 'bytesToRead == 0' at this point cannot happen.
		 */

		nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
			bufPtr + copied, bytesToRead - copied, &result);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	    if (nread > 0) {
		/*
		 * If we get a short read, signal up that we may be
		 * BLOCKED. We should avoid calling the driver because
		 * on some platforms we will block in the low level
		 * reading code even though the channel is set into
		 * nonblocking mode.
		 */

		if (nread < (bytesToRead - copied)) {
		    statePtr->flags |= CHANNEL_BLOCKED;
		}

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
		if (nread <= (bytesToRead - copied)) {
		    /*
		     * [SF Tcl Bug 943274] We have read the available
		     * data, clear flag.
		     */

		    statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
		}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	    } else if (nread == 0) {
		statePtr->flags |= CHANNEL_EOF;
		statePtr->inputEncodingFlags |= TCL_ENCODING_END;

	    } else if (nread < 0) {
		if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
		    if (copied > 0) {
			/*
			 * Information that was copied earlier has precedence
			 * over EAGAIN/WOULDBLOCK handling.
			 */

			return copied;
		    }

		    statePtr->flags |= CHANNEL_BLOCKED;
		    result = EAGAIN;
		}

		Tcl_SetErrno(result);
		return -1;
	    } 

	    return copied + nread;
	}
    }

done:
    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ReadChars --
 *
 *	Reads from the channel until the requested number of characters
 *	have been seen, EOF is seen, or the channel would block.  EOL
 *	and EOF translation is done.  If reading binary data, the raw
 *	bytes are wrapped in a Tcl byte array object.  Otherwise, the raw
 *	bytes are converted to UTF-8 using the channel's current encoding
 *	and stored in a Tcl string object.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno()
 *	to retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_ReadChars(chan, objPtr, toRead, appendFlag)
    Tcl_Channel chan;		/* The channel to read. */
    Tcl_Obj *objPtr;		/* Input data is stored in this object. */
    int toRead;			/* Maximum number of characters to store,
				 * or -1 to read all available data (up to EOF
				 * or when channel blocks). */
    int appendFlag;		/* If non-zero, data read from the channel
				 * will be appended to the object.  Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */







|
|
|
|




|
|













|




















|
|
|
|




|
|













|







|
|
|











|
|
|

















>
|
|
|
|
<






|
|

>




>

|
|
|







>



>
















|
|





>



>

















|





|








|
|
|
|
|
|


|
|











|
|
|







4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504

4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Read --
 *
 *	Reads a given number of bytes from a channel.  EOL and EOF translation
 *	is done on the bytes being read, so the number of bytes consumed from
 *	the channel may not be equal to the number of bytes stored in the
 *	destination buffer.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes read, or -1 on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Read(chan, dst, bytesToRead)
    Tcl_Channel chan;		/* The channel from which to read. */
    char *dst;			/* Where to store input read. */
    int bytesToRead;		/* Maximum number of bytes to read. */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;

    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	return -1;
    }

    return DoRead(chanPtr, dst, bytesToRead);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadRaw --
 *
 *	Reads a given number of bytes from a channel.  EOL and EOF translation
 *	is done on the bytes being read, so the number of bytes consumed from
 *	the channel may not be equal to the number of bytes stored in the
 *	destination buffer.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of bytes read, or -1 on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ReadRaw(chan, bufPtr, bytesToRead)
    Tcl_Channel chan;		/* The channel from which to read. */
    char *bufPtr;		/* Where to store input read. */
    int bytesToRead;		/* Maximum number of bytes to read. */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int nread, result;
    int copied, copiedNow;

    /*
     * The check below does too much because it will reject a call to this
     * function with a channel which is part of an 'fcopy'. But we have to
     * allow this here or else the chaining in the transformation drivers will
     * fail with 'file busy' error instead of retrieving and transforming the
     * data to copy.
     *
     * We let the check procedure now believe that there is no fcopy in
     * progress. A better solution than this might be an additional flag
     * argument to switch off specific checks.
     */

    if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
	return -1;
    }

    /*
     * Check for information in the push-back buffers. If there is some, use
     * it. Go to the driver only if there is none (anymore) and the caller
     * requests more bytes.
     */

    for (copied = 0; copied < bytesToRead; copied += copiedNow) {
	copiedNow = CopyBuffer(chanPtr, bufPtr + copied,
		bytesToRead - copied);
	if (copiedNow == 0) {
	    if (statePtr->flags & CHANNEL_EOF) {
		goto done;
	    }
	    if (statePtr->flags & CHANNEL_BLOCKED) {
		if (statePtr->flags & CHANNEL_NONBLOCKING) {
		    goto done;
		}
		statePtr->flags &= (~(CHANNEL_BLOCKED));
	    }

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	    /*
	     * [SF Tcl Bug 943274]. Better emulation of non-blocking channels
	     * for channels without BlockModeProc, by keeping track of true
	     * fileevents generated by the OS == Data waiting and reading if
	     * and only if we are sure to have data.

	     */

	    if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
		    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
		    !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
		/*
		 * We bypass the driver; it would block as no data is
		 * available.
		 */

		nread = -1;
		result = EWOULDBLOCK;
	    } else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

		/*
		 * Now go to the driver to get as much as is possible to fill
		 * the remaining request. Do all the error handling by
		 * ourselves.  The code was stolen from 'GetInput' and
		 * slightly adapted (different return value here).
		 *
		 * The case of 'bytesToRead == 0' at this point cannot happen.
		 */

		nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
			bufPtr + copied, bytesToRead - copied, &result);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	    if (nread > 0) {
		/*
		 * If we get a short read, signal up that we may be
		 * BLOCKED. We should avoid calling the driver because
		 * on some platforms we will block in the low level
		 * reading code even though the channel is set into
		 * nonblocking mode.
		 */

		if (nread < (bytesToRead - copied)) {
		    statePtr->flags |= CHANNEL_BLOCKED;
		}

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
		if (nread <= (bytesToRead - copied)) {
		    /*
		     * [SF Tcl Bug 943274] We have read the available data,
		     * clear flag.
		     */

		    statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
		}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	    } else if (nread == 0) {
		statePtr->flags |= CHANNEL_EOF;
		statePtr->inputEncodingFlags |= TCL_ENCODING_END;

	    } else if (nread < 0) {
		if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
		    if (copied > 0) {
			/*
			 * Information that was copied earlier has precedence
			 * over EAGAIN/WOULDBLOCK handling.
			 */

			return copied;
		    }

		    statePtr->flags |= CHANNEL_BLOCKED;
		    result = EAGAIN;
		}

		Tcl_SetErrno(result);
		return -1;
	    }

	    return copied + nread;
	}
    }

  done:
    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ReadChars --
 *
 *	Reads from the channel until the requested number of characters have
 *	been seen, EOF is seen, or the channel would block.  EOL and EOF
 *	translation is done.  If reading binary data, the raw bytes are
 *	wrapped in a Tcl byte array object.  Otherwise, the raw bytes are
 *	converted to UTF-8 using the channel's current encoding and stored in
 *	a Tcl string object.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_ReadChars(chan, objPtr, toRead, appendFlag)
    Tcl_Channel chan;		/* The channel to read. */
    Tcl_Obj *objPtr;		/* Input data is stored in this object. */
    int toRead;			/* Maximum number of characters to store, or
				 * -1 to read all available data (up to EOF or
				 * when channel blocks). */
    int appendFlag;		/* If non-zero, data read from the channel
				 * will be appended to the object.  Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
    return DoReadChars(chanPtr, objPtr, toRead, appendFlag);
}
/*
 *---------------------------------------------------------------------------
 *
 * DoReadChars --
 *
 *	Reads from the channel until the requested number of characters
 *	have been seen, EOF is seen, or the channel would block.  EOL
 *	and EOF translation is done.  If reading binary data, the raw
 *	bytes are wrapped in a Tcl byte array object.  Otherwise, the raw
 *	bytes are converted to UTF-8 using the channel's current encoding
 *	and stored in a Tcl string object.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno()
 *	to retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */

static int
DoReadChars(chanPtr, objPtr, toRead, appendFlag)
    Channel *chanPtr;		/* The channel to read. */
    Tcl_Obj *objPtr;		/* Input data is stored in this object. */
    int toRead;			/* Maximum number of characters to store,
				 * or -1 to read all available data (up to EOF
				 * or when channel blocks). */
    int appendFlag;		/* If non-zero, data read from the channel
				 * will be appended to the object.  Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;







|
|
|
|
|
|


|
|











|
|
|







4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
    return DoReadChars(chanPtr, objPtr, toRead, appendFlag);
}
/*
 *---------------------------------------------------------------------------
 *
 * DoReadChars --
 *
 *	Reads from the channel until the requested number of characters have
 *	been seen, EOF is seen, or the channel would block.  EOL and EOF
 *	translation is done.  If reading binary data, the raw bytes are
 *	wrapped in a Tcl byte array object.  Otherwise, the raw bytes are
 *	converted to UTF-8 using the channel's current encoding and stored in
 *	a Tcl string object.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */

static int
DoReadChars(chanPtr, objPtr, toRead, appendFlag)
    Channel *chanPtr;		/* The channel to read. */
    Tcl_Obj *objPtr;		/* Input data is stored in this object. */
    int toRead;			/* Maximum number of characters to store, or
				 * -1 to read all available data (up to EOF or
				 * when channel blocks). */
    int appendFlag;		/* If non-zero, data read from the channel
				 * will be appended to the object.  Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
4457
4458
4459
4460
4461
4462
4463

4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
    factor = UTF_EXPANSION_FACTOR;

    if (appendFlag == 0) {
	if (encoding == NULL) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);

	    /* 
	     * We're going to access objPtr->bytes directly, so
	     * we must ensure that this is actually a string
	     * object (otherwise it might have been pure Unicode).
	     */

	    Tcl_GetString(objPtr);
	}
	offset = 0;
    } else {
	if (encoding == NULL) {







>
|
|
|
|







4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
    factor = UTF_EXPANSION_FACTOR;

    if (appendFlag == 0) {
	if (encoding == NULL) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);

	    /*
	     * We're going to access objPtr->bytes directly, so we must ensure
	     * that this is actually a string object (otherwise it might have
	     * been pure Unicode).
	     */

	    Tcl_GetString(objPtr);
	}
	offset = 0;
    } else {
	if (encoding == NULL) {
4500
4501
4502
4503
4504
4505
4506

4507
4508
4509
4510
4511
4512
4513
		RecycleBuffer(statePtr, bufPtr, 0);
		statePtr->inQueueHead = nextPtr;
		if (nextPtr == NULL) {
		    statePtr->inQueueTail = NULL;
		}
	    }
	}

	if (copiedNow < 0) {
	    if (statePtr->flags & CHANNEL_EOF) {
		break;
	    }
	    if (statePtr->flags & CHANNEL_BLOCKED) {
		if (statePtr->flags & CHANNEL_NONBLOCKING) {
		    break;







>







4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
		RecycleBuffer(statePtr, bufPtr, 0);
		statePtr->inQueueHead = nextPtr;
		if (nextPtr == NULL) {
		    statePtr->inQueueTail = NULL;
		}
	    }
	}

	if (copiedNow < 0) {
	    if (statePtr->flags & CHANNEL_EOF) {
		break;
	    }
	    if (statePtr->flags & CHANNEL_BLOCKED) {
		if (statePtr->flags & CHANNEL_NONBLOCKING) {
		    break;
4523
4524
4525
4526
4527
4528
4529

4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542

4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
		goto done;
	    }
	} else {
	    copied += copiedNow;
	    toRead -= copiedNow;
	}
    }

    statePtr->flags &= ~CHANNEL_BLOCKED;
    if (encoding == NULL) {
	Tcl_SetByteArrayLength(objPtr, offset);
    } else {
	Tcl_SetObjLength(objPtr, offset);
    }

    done:
    /*
     * Update the notifier state so we don't block while there is still
     * data in the buffers.
     */


    UpdateInterest(chanPtr);
    return copied;
}
/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --
 *
 *	Reads from the channel until the requested number of bytes have
 *	been seen, EOF is seen, or the channel would block.  Bytes from
 *	the channel are stored in objPtr as a ByteArray object.  EOL
 *	and EOF translation are done.
 *
 *	'bytesToRead' can safely be a very large number because
 *	space is only allocated to hold data read from the channel
 *	as needed.
 *
 * Results:
 *	The return value is the number of bytes appended to the object
 *	and *offsetPtr is filled with the total number of bytes in the
 *	object (greater than the return value if there were already bytes
 *	in the object).
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr)
    ChannelState *statePtr;	/* State of the channel to read. */
    Tcl_Obj *objPtr;		/* Input data is appended to this ByteArray
				 * object.  Its length is how much space
				 * has been allocated to hold data, not how
				 * many bytes of data have been stored in the
				 * object. */
    int bytesToRead;		/* Maximum number of bytes to store,
				 * or < 0 to get all available bytes.
				 * Bytes are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of bytes
				 * available in the first buffer, only the
				 * bytes from the first buffer are
				 * returned. */
    int *offsetPtr;		/* On input, contains how many bytes of
				 * objPtr have been used to hold data.  On
				 * output, filled with how many bytes are now
				 * being used. */
{
    int toRead, srcLen, offset, length, srcRead, dstWrote;
    ChannelBuffer *bufPtr;
    char *src, *dst;

    offset = *offsetPtr;

    bufPtr = statePtr->inQueueHead; 
    src = bufPtr->buf + bufPtr->nextRemoved;
    srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;

    toRead = bytesToRead;
    if ((unsigned) toRead > (unsigned) srcLen) {
	toRead = srcLen;
    }

    dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length);
    if (toRead > length - offset - 1) {
	/*
	 * Double the existing size of the object or make enough room to
	 * hold all the characters we may get from the source buffer,
	 * whichever is larger.
	 */

	length = offset * 2;
	if (offset < toRead) {
	    length = offset + toRead + 1;
	}
	dst = (char *) Tcl_SetByteArrayLength(objPtr, length);







>







<

|
|


>








|
|
|
|

|
|
<


|
|
|
|











|
|
|

|
|
<
|
|
|
|

|
|
|
|







|











|
|
|







4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774

4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795

4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818

4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
		goto done;
	    }
	} else {
	    copied += copiedNow;
	    toRead -= copiedNow;
	}
    }

    statePtr->flags &= ~CHANNEL_BLOCKED;
    if (encoding == NULL) {
	Tcl_SetByteArrayLength(objPtr, offset);
    } else {
	Tcl_SetObjLength(objPtr, offset);
    }


    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    return copied;
}
/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --
 *
 *	Reads from the channel until the requested number of bytes have been
 *	seen, EOF is seen, or the channel would block.  Bytes from the channel
 *	are stored in objPtr as a ByteArray object.  EOL and EOF translation
 *	are done.
 *
 *	'bytesToRead' can safely be a very large number because space is only
 *	allocated to hold data read from the channel as needed.

 *
 * Results:
 *	The return value is the number of bytes appended to the object and
 *	*offsetPtr is filled with the total number of bytes in the object
 *	(greater than the return value if there were already bytes in the
 *	object).
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr)
    ChannelState *statePtr;	/* State of the channel to read. */
    Tcl_Obj *objPtr;		/* Input data is appended to this ByteArray
				 * object.  Its length is how much space has
				 * been allocated to hold data, not how many
				 * bytes of data have been stored in the
				 * object. */
    int bytesToRead;		/* Maximum number of bytes to store, or < 0 to
				 * get all available bytes. Bytes are obtained

				 * from the first buffer in the queue - even
				 * if this number is larger than the number of
				 * bytes available in the first buffer, only
				 * the bytes from the first buffer are
				 * returned. */
    int *offsetPtr;		/* On input, contains how many bytes of objPtr
				 * have been used to hold data.  On output,
				 * filled with how many bytes are now being
				 * used. */
{
    int toRead, srcLen, offset, length, srcRead, dstWrote;
    ChannelBuffer *bufPtr;
    char *src, *dst;

    offset = *offsetPtr;

    bufPtr = statePtr->inQueueHead;
    src = bufPtr->buf + bufPtr->nextRemoved;
    srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;

    toRead = bytesToRead;
    if ((unsigned) toRead > (unsigned) srcLen) {
	toRead = srcLen;
    }

    dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length);
    if (toRead > length - offset - 1) {
	/*
	 * Double the existing size of the object or make enough room to hold
	 * all the characters we may get from the source buffer, whichever is
	 * larger.
	 */

	length = offset * 2;
	if (offset < toRead) {
	    length = offset + toRead + 1;
	}
	dst = (char *) Tcl_SetByteArrayLength(objPtr, length);
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadChars --
 *
 *	Reads from the channel until the requested number of UTF-8
 *	characters have been seen, EOF is seen, or the channel would
 *	block.  Raw bytes from the channel are converted to UTF-8
 *	and stored in objPtr.  EOL and EOF translation is done.
 *
 *	'charsToRead' can safely be a very large number because
 *	space is only allocated to hold data read from the channel
 *	as needed.
 *
 * Results:
 *	The return value is the number of characters appended to
 *	the object, *offsetPtr is filled with the number of bytes that
 *	were appended, and *factorPtr is filled with the expansion
 *	factor used to guess how many bytes of UTF-8 to allocate to
 *	hold N source bytes.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr)
    ChannelState *statePtr;	/* State of channel to read. */
    Tcl_Obj *objPtr;		/* Input data is appended to this object.
				 * objPtr->length is how much space has been
				 * allocated to hold data, not how many bytes
				 * of data have been stored in the object. */
    int charsToRead;		/* Maximum number of characters to store,
				 * or -1 to get all available characters.
				 * Characters are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of characters
				 * available in the first buffer, only the
				 * characters from the first buffer are
				 * returned. */
    int *offsetPtr;		/* On input, contains how many bytes of
				 * objPtr have been used to hold data.  On
				 * output, filled with how many bytes are now
				 * being used. */
    int *factorPtr;		/* On input, contains a guess of how many
				 * bytes need to be allocated to hold the
				 * result of converting N source bytes to
				 * UTF-8.  On output, contains another guess
				 * based on the data seen so far. */
{
    int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded;
    int srcRead, dstWrote, numChars, dstRead;
    ChannelBuffer *bufPtr;
    char *src, *dst;
    Tcl_EncodingState oldState;

    factor = *factorPtr;
    offset = *offsetPtr;

    bufPtr = statePtr->inQueueHead; 
    src = bufPtr->buf + bufPtr->nextRemoved;
    srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;

    toRead = charsToRead;
    if ((unsigned)toRead > (unsigned)srcLen) {
	toRead = srcLen;
    }

    /*
     * 'factor' is how much we guess that the bytes in the source buffer
     * will expand when converted to UTF-8 chars.  This guess comes from
     * analyzing how many characters were produced by the previous
     * pass.
     */

    dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR;
    spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1;

    if (dstNeeded > spaceLeft) {
	/*
	 * Double the existing size of the object or make enough room to
	 * hold all the characters we want from the source buffer,
	 * whichever is larger.
	 */

	length = offset * 2;
	if (offset < dstNeeded) {
	    length = offset + dstNeeded;
	}
	spaceLeft = length - offset;
	length += TCL_UTF_MAX + 1;
	Tcl_SetObjLength(objPtr, length);
    }
    if (toRead == srcLen) {
	/*
	 * Want to convert the whole buffer in one pass.  If we have
	 * enough space, convert it using all available space in object
	 * rather than using the factor.
	 */

	dstNeeded = spaceLeft;
    }
    dst = objPtr->bytes + offset;

    oldState = statePtr->inputEncodingState;







|
|
|
|

|
|
<


|
|
|
<
|














|
|






|
|
|
|















|









|
|
|
<







|
|
|












|
|
|







4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896

4897
4898
4899
4900
4901

4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956

4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadChars --
 *
 *	Reads from the channel until the requested number of UTF-8 characters
 *	have been seen, EOF is seen, or the channel would block. Raw bytes
 *	from the channel are converted to UTF-8 and stored in objPtr. EOL and
 *	EOF translation is done.
 *
 *	'charsToRead' can safely be a very large number because space is only
 *	allocated to hold data read from the channel as needed.

 *
 * Results:
 *	The return value is the number of characters appended to the object,
 *	*offsetPtr is filled with the number of bytes that were appended, and
 *	*factorPtr is filled with the expansion factor used to guess how many

 *	bytes of UTF-8 to allocate to hold N source bytes.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr)
    ChannelState *statePtr;	/* State of channel to read. */
    Tcl_Obj *objPtr;		/* Input data is appended to this object.
				 * objPtr->length is how much space has been
				 * allocated to hold data, not how many bytes
				 * of data have been stored in the object. */
    int charsToRead;		/* Maximum number of characters to store, or
				 * -1 to get all available characters.
				 * Characters are obtained from the first
				 * buffer in the queue -- even if this number
				 * is larger than the number of characters
				 * available in the first buffer, only the
				 * characters from the first buffer are
				 * returned. */
    int *offsetPtr;		/* On input, contains how many bytes of objPtr
				 * have been used to hold data. On output,
				 * filled with how many bytes are now being
				 * used. */
    int *factorPtr;		/* On input, contains a guess of how many
				 * bytes need to be allocated to hold the
				 * result of converting N source bytes to
				 * UTF-8.  On output, contains another guess
				 * based on the data seen so far. */
{
    int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded;
    int srcRead, dstWrote, numChars, dstRead;
    ChannelBuffer *bufPtr;
    char *src, *dst;
    Tcl_EncodingState oldState;

    factor = *factorPtr;
    offset = *offsetPtr;

    bufPtr = statePtr->inQueueHead;
    src = bufPtr->buf + bufPtr->nextRemoved;
    srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;

    toRead = charsToRead;
    if ((unsigned)toRead > (unsigned)srcLen) {
	toRead = srcLen;
    }

    /*
     * 'factor' is how much we guess that the bytes in the source buffer will
     * expand when converted to UTF-8 chars.  This guess comes from analyzing
     * how many characters were produced by the previous pass.

     */

    dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR;
    spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1;

    if (dstNeeded > spaceLeft) {
	/*
	 * Double the existing size of the object or make enough room to hold
	 * all the characters we want from the source buffer, whichever is
	 * larger.
	 */

	length = offset * 2;
	if (offset < dstNeeded) {
	    length = offset + dstNeeded;
	}
	spaceLeft = length - offset;
	length += TCL_UTF_MAX + 1;
	Tcl_SetObjLength(objPtr, length);
    }
    if (toRead == srcLen) {
	/*
	 * Want to convert the whole buffer in one pass. If we have enough
	 * space, convert it using all available space in object rather than
	 * using the factor.
	 */

	dstNeeded = spaceLeft;
    }
    dst = objPtr->bytes + offset;

    oldState = statePtr->inputEncodingState;
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
    }

    Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
	    statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst,
	    dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
    if (srcRead == 0) {
	/*
	 * Not enough bytes in src buffer to make a complete char.  Copy
	 * the bytes to the next buffer to make a new contiguous string,
	 * then tell the caller to fill the buffer with more bytes.
	 */

	ChannelBuffer *nextPtr;

	nextPtr = bufPtr->nextPtr;
	if (nextPtr == NULL) {
	    if (srcLen > 0) {
		/*
		 * There isn't enough data in the buffers to complete the next
		 * character, so we need to wait for more data before the next
		 * file event can be delivered.
		 *
		 * SF #478856.
		 *
		 * The exception to this is if the input buffer was
		 * completely empty before we tried to convert its
		 * contents. Nothing in, nothing out, and no incomplete
		 * character data. The conversion before the current one
		 * was complete.
		 */

		statePtr->flags |= CHANNEL_NEED_MORE_DATA;
	    }
	    return -1;
	}
	nextPtr->nextRemoved -= srcLen;
	memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src,
		(size_t) srcLen);
	RecycleBuffer(statePtr, bufPtr, 0);
	statePtr->inQueueHead = nextPtr;
	return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr);
    }

    dstRead = dstWrote;
    if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) {
	/*
	 * Hit EOF char.  How many bytes of src correspond to where the
	 * EOF was located in dst? Run the conversion again with an
	 * output buffer just big enough to hold the data so we can
	 * get the correct value for srcRead.
	 */

	if (dstWrote == 0) {
	    return -1;
	}
	statePtr->inputEncodingState = oldState;
	Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
		statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
		dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
	TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
    } 

    /*
     * The number of characters that we got may be less than the number
     * that we started with because "\r\n" sequences may have been
     * turned into just '\n' in dst.
     */

    numChars -= (dstRead - dstWrote);

    if ((unsigned) numChars > (unsigned) toRead) {
	/*
	 * Got too many chars.







|
|
|














|
|
|
|
<

















|
|
|
|










|


|
|
|







5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041

5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
    }

    Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
	    statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst,
	    dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
    if (srcRead == 0) {
	/*
	 * Not enough bytes in src buffer to make a complete char.  Copy the
	 * bytes to the next buffer to make a new contiguous string, then tell
	 * the caller to fill the buffer with more bytes.
	 */

	ChannelBuffer *nextPtr;

	nextPtr = bufPtr->nextPtr;
	if (nextPtr == NULL) {
	    if (srcLen > 0) {
		/*
		 * There isn't enough data in the buffers to complete the next
		 * character, so we need to wait for more data before the next
		 * file event can be delivered.
		 *
		 * SF #478856.
		 *
		 * The exception to this is if the input buffer was completely
		 * empty before we tried to convert its contents. Nothing in,
		 * nothing out, and no incomplete character data. The
		 * conversion before the current one was complete.

		 */

		statePtr->flags |= CHANNEL_NEED_MORE_DATA;
	    }
	    return -1;
	}
	nextPtr->nextRemoved -= srcLen;
	memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src,
		(size_t) srcLen);
	RecycleBuffer(statePtr, bufPtr, 0);
	statePtr->inQueueHead = nextPtr;
	return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr);
    }

    dstRead = dstWrote;
    if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) {
	/*
	 * Hit EOF char. How many bytes of src correspond to where the EOF was
	 * located in dst? Run the conversion again with an output buffer just
	 * big enough to hold the data so we can get the correct value for
	 * srcRead.
	 */

	if (dstWrote == 0) {
	    return -1;
	}
	statePtr->inputEncodingState = oldState;
	Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
		statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
		dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
	TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
    }

    /*
     * The number of characters that we got may be less than the number that
     * we started with because "\r\n" sequences may have been turned into just
     * '\n' in dst.
     */

    numChars -= (dstRead - dstWrote);

    if ((unsigned) numChars > (unsigned) toRead) {
	/*
	 * Got too many chars.
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateInputEOL --
 *
 *	Perform input EOL and EOF translation on the source buffer,
 *	leaving the translated result in the destination buffer.  
 *
 * Results:
 *	The return value is 1 if the EOF character was found when copying
 *	bytes to the destination buffer, 0 otherwise.  
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr)
    ChannelState *statePtr;	/* Channel being read, for EOL translation
				 * and EOF character. */
    char *dstStart;		/* Output buffer filled with chars by
				 * applying appropriate EOL translation to
				 * source characters. */
    CONST char *srcStart;	/* Source characters. */
    int *dstLenPtr;		/* On entry, the maximum length of output
				 * buffer in bytes; must be <= *srcLenPtr.  On
				 * exit, the number of bytes actually used in
				 * output buffer. */
    int *srcLenPtr;		/* On entry, the length of source buffer.
				 * On exit, the number of bytes read from
				 * the source buffer. */
{
    int dstLen, srcLen, inEofChar;
    CONST char *eof;

    dstLen = *dstLenPtr;

    eof = NULL;
    inEofChar = statePtr->inEofChar;
    if (inEofChar != '\0') {
	/*
	 * Find EOF in translated buffer then compress out the EOL.  The
	 * source buffer may be much longer than the destination buffer --
	 * we only want to return EOF if the EOF has been copied to the
	 * destination buffer.
	 */

	CONST char *src, *srcMax;

	srcMax = srcStart + *srcLenPtr;
	for (src = srcStart; src < srcMax; src++) {
	    if (*src == inEofChar) {
		eof = src;
		srcLen = src - srcStart;
		if (srcLen < dstLen) {
		    dstLen = srcLen;
		}
		*srcLenPtr = srcLen;
		break;
	    }
	}
    }
    switch (statePtr->inputTranslation) {
	case TCL_TRANSLATE_LF: {
	    if (dstStart != srcStart) {
		memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
	    }
	    srcLen = dstLen;
	    break;
	}
	case TCL_TRANSLATE_CR: {
	    char *dst, *dstEnd;

	    if (dstStart != srcStart) {
		memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
	    }
	    dstEnd = dstStart + dstLen;
	    for (dst = dstStart; dst < dstEnd; dst++) {
		if (*dst == '\r') {
		    *dst = '\n';
		}
	    }
	    srcLen = dstLen;
	    break;
	}
	case TCL_TRANSLATE_CRLF: {
	    char *dst;
	    CONST char *src, *srcEnd, *srcMax;

	    dst = dstStart;
	    src = srcStart;
	    srcEnd = srcStart + dstLen;
	    srcMax = srcStart + *srcLenPtr;

	    for ( ; src < srcEnd; ) {
		if (*src == '\r') {
		    src++;
		    if (src >= srcMax) {
			statePtr->flags |= INPUT_NEED_NL;
		    } else if (*src == '\n') {
			*dst++ = *src++;
		    } else {
			*dst++ = '\r';
		    }
		} else {
		    *dst++ = *src++;
		}
	    }
	    srcLen = src - srcStart;
	    dstLen = dst - dstStart;
	    break;
	}
	case TCL_TRANSLATE_AUTO: {
	    char *dst;
	    CONST char *src, *srcEnd, *srcMax;

	    dst = dstStart;
	    src = srcStart;
	    srcEnd = srcStart + dstLen;
	    srcMax = srcStart + *srcLenPtr;

	    if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) {
		if (*src == '\n') {
		    src++;
		}
		statePtr->flags &= ~INPUT_SAW_CR;
	    }
	    for ( ; src < srcEnd; ) {
		if (*src == '\r') {
		    src++;
		    if (src >= srcMax) {
			statePtr->flags |= INPUT_SAW_CR;
		    } else if (*src == '\n') {
			if (srcEnd < srcMax) {
			    srcEnd++;
			}
			src++;
		    }
		    *dst++ = '\n';
		} else {
		    *dst++ = *src++;
		}
	    }
	    srcLen = src - srcStart;
	    dstLen = dst - dstStart;
	    break;
	}
	default: {		/* lint. */
	    return 0;
	}
    }
    *dstLenPtr = dstLen;

    if ((eof != NULL) && (srcStart + srcLen >= eof)) {
	/*
	 * EOF character was seen in EOL translated range.  Leave current
	 * file position pointing at the EOF character, but don't store the
	 * EOF character in the output string.
	 */

	statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
	statePtr->inputEncodingFlags |= TCL_ENCODING_END;
	statePtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL);
	return 1;
    }

    *srcLenPtr = srcLen;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Ungets --
 *
 *	Causes the supplied string to be added to the input queue of
 *	the channel, at either the head or tail of the queue.
 *
 * Results:
 *	The number of bytes stored in the channel, or -1 on error.
 *
 * Side effects:
 *	Adds input to the input queue of a channel.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Ungets(chan, str, len, atEnd)
    Tcl_Channel chan;		/* The channel for which to add the input. */
    CONST char *str;		/* The input itself. */
    int len;			/* The length of the input. */
    int atEnd;			/* If non-zero, add at end of queue; otherwise
				 * add at head of queue. */    
{
    Channel *chanPtr;		/* The real IO channel. */
    ChannelState *statePtr;	/* State of actual channel. */
    ChannelBuffer *bufPtr;	/* Buffer to contain the data. */
    int i, flags;

    chanPtr = (Channel *) chan;







|
|



|









|
|
|
|
|


|


|
|
|










|
|
|
|


















|
|
|
|
|
|
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<





|
|
|

















|
|
















|







5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179

5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258

5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateInputEOL --
 *
 *	Perform input EOL and EOF translation on the source buffer, leaving
 *	the translated result in the destination buffer.
 *
 * Results:
 *	The return value is 1 if the EOF character was found when copying
 *	bytes to the destination buffer, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr)
    ChannelState *statePtr;	/* Channel being read, for EOL translation and
				 * EOF character. */
    char *dstStart;		/* Output buffer filled with chars by applying
				 * appropriate EOL translation to source
				 * characters. */
    CONST char *srcStart;	/* Source characters. */
    int *dstLenPtr;		/* On entry, the maximum length of output
				 * buffer in bytes; must be <= *srcLenPtr. On
				 * exit, the number of bytes actually used in
				 * output buffer. */
    int *srcLenPtr;		/* On entry, the length of source buffer. On
				 * exit, the number of bytes read from the
				 * source buffer. */
{
    int dstLen, srcLen, inEofChar;
    CONST char *eof;

    dstLen = *dstLenPtr;

    eof = NULL;
    inEofChar = statePtr->inEofChar;
    if (inEofChar != '\0') {
	/*
	 * Find EOF in translated buffer then compress out the EOL. The source
	 * buffer may be much longer than the destination buffer - we only
	 * want to return EOF if the EOF has been copied to the destination
	 * buffer.
	 */

	CONST char *src, *srcMax;

	srcMax = srcStart + *srcLenPtr;
	for (src = srcStart; src < srcMax; src++) {
	    if (*src == inEofChar) {
		eof = src;
		srcLen = src - srcStart;
		if (srcLen < dstLen) {
		    dstLen = srcLen;
		}
		*srcLenPtr = srcLen;
		break;
	    }
	}
    }
    switch (statePtr->inputTranslation) {
    case TCL_TRANSLATE_LF:
	if (dstStart != srcStart) {
	    memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
	}
	srcLen = dstLen;
	break;

    case TCL_TRANSLATE_CR: {
	char *dst, *dstEnd;

	if (dstStart != srcStart) {
	    memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
	}
	dstEnd = dstStart + dstLen;
	for (dst = dstStart; dst < dstEnd; dst++) {
	    if (*dst == '\r') {
		*dst = '\n';
	    }
	}
	srcLen = dstLen;
	break;
    }
    case TCL_TRANSLATE_CRLF: {
	char *dst;
	CONST char *src, *srcEnd, *srcMax;

	dst = dstStart;
	src = srcStart;
	srcEnd = srcStart + dstLen;
	srcMax = srcStart + *srcLenPtr;

	for ( ; src < srcEnd; ) {
	    if (*src == '\r') {
		src++;
		if (src >= srcMax) {
		    statePtr->flags |= INPUT_NEED_NL;
		} else if (*src == '\n') {
		    *dst++ = *src++;
		} else {
		    *dst++ = '\r';
		}
	    } else {
		*dst++ = *src++;
	    }
	}
	srcLen = src - srcStart;
	dstLen = dst - dstStart;
	break;
    }
    case TCL_TRANSLATE_AUTO: {
	char *dst;
	CONST char *src, *srcEnd, *srcMax;

	dst = dstStart;
	src = srcStart;
	srcEnd = srcStart + dstLen;
	srcMax = srcStart + *srcLenPtr;

	if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) {
	    if (*src == '\n') {
		src++;
	    }
	    statePtr->flags &= ~INPUT_SAW_CR;
	}
	for ( ; src < srcEnd; ) {
	    if (*src == '\r') {
		src++;
		if (src >= srcMax) {
		    statePtr->flags |= INPUT_SAW_CR;
		} else if (*src == '\n') {
		    if (srcEnd < srcMax) {
			srcEnd++;
		    }
		    src++;
		}
		*dst++ = '\n';
	    } else {
		*dst++ = *src++;
	    }
	}
	srcLen = src - srcStart;
	dstLen = dst - dstStart;
	break;
    }
    default:
	return 0;

    }
    *dstLenPtr = dstLen;

    if ((eof != NULL) && (srcStart + srcLen >= eof)) {
	/*
	 * EOF character was seen in EOL translated range.  Leave current file
	 * position pointing at the EOF character, but don't store the EOF
	 * character in the output string.
	 */

	statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
	statePtr->inputEncodingFlags |= TCL_ENCODING_END;
	statePtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL);
	return 1;
    }

    *srcLenPtr = srcLen;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Ungets --
 *
 *	Causes the supplied string to be added to the input queue of the
 *	channel, at either the head or tail of the queue.
 *
 * Results:
 *	The number of bytes stored in the channel, or -1 on error.
 *
 * Side effects:
 *	Adds input to the input queue of a channel.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Ungets(chan, str, len, atEnd)
    Tcl_Channel chan;		/* The channel for which to add the input. */
    CONST char *str;		/* The input itself. */
    int len;			/* The length of the input. */
    int atEnd;			/* If non-zero, add at end of queue; otherwise
				 * add at head of queue. */
{
    Channel *chanPtr;		/* The real IO channel. */
    ChannelState *statePtr;	/* State of actual channel. */
    ChannelBuffer *bufPtr;	/* Buffer to contain the data. */
    int i, flags;

    chanPtr = (Channel *) chan;
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	len = -1;
	goto done;
    }
    statePtr->flags = flags;

    /*
     * If we have encountered a sticky EOF, just punt without storing.
     * (sticky EOF is set if we have seen the input eofChar, to prevent
     * reading beyond the eofChar). Otherwise, clear the EOF flags, and
     * clear the BLOCKED bit. We want to discover these conditions anew
     * in each operation.
     */

    if (statePtr->flags & CHANNEL_STICKY_EOF) {
	goto done;
    }
    statePtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF));








|
|
|
|
<







5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333

5334
5335
5336
5337
5338
5339
5340
    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	len = -1;
	goto done;
    }
    statePtr->flags = flags;

    /*
     * If we have encountered a sticky EOF, just punt without storing (sticky
     * EOF is set if we have seen the input eofChar, to prevent reading beyond
     * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED
     * bit. We want to discover these conditions anew in each operation.

     */

    if (statePtr->flags & CHANNEL_STICKY_EOF) {
	goto done;
    }
    statePtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF));

5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135

5136
5137
5138
5139
5140
5141
5142
	statePtr->inQueueTail->nextPtr = bufPtr;
	statePtr->inQueueTail = bufPtr;
    } else {
	bufPtr->nextPtr = statePtr->inQueueHead;
	statePtr->inQueueHead = bufPtr;
    }

    done:
    /*
     * Update the notifier state so we don't block while there is still
     * data in the buffers.
     */


    UpdateInterest(chanPtr);
    return len;
}

/*
 *----------------------------------------------------------------------
 *







<

|
|


>







5352
5353
5354
5355
5356
5357
5358

5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
	statePtr->inQueueTail->nextPtr = bufPtr;
	statePtr->inQueueTail = bufPtr;
    } else {
	bufPtr->nextPtr = statePtr->inQueueHead;
	statePtr->inQueueHead = bufPtr;
    }


    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    return len;
}

/*
 *----------------------------------------------------------------------
 *
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
}

/*
 *----------------------------------------------------------------------
 *
 * DiscardInputQueued --
 *
 *	Discards any input read from the channel but not yet consumed
 *	by Tcl reading commands.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May discard input from the channel. If discardLastBuffer is zero,
 *	leaves one buffer in place for back-filling.
 *
 *----------------------------------------------------------------------
 */

static void
DiscardInputQueued(statePtr, discardSavedBuffers)
    ChannelState *statePtr;	/* Channel on which to discard
				 * the queued input. */
    int discardSavedBuffers;	/* If non-zero, discard all buffers including
				 * last one. */
{
    ChannelBuffer *bufPtr, *nxtPtr;	/* Loop variables. */

    bufPtr = statePtr->inQueueHead;
    statePtr->inQueueHead = (ChannelBuffer *) NULL;







|
|













|
|







5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
}

/*
 *----------------------------------------------------------------------
 *
 * DiscardInputQueued --
 *
 *	Discards any input read from the channel but not yet consumed by Tcl
 *	reading commands.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May discard input from the channel. If discardLastBuffer is zero,
 *	leaves one buffer in place for back-filling.
 *
 *----------------------------------------------------------------------
 */

static void
DiscardInputQueued(statePtr, discardSavedBuffers)
    ChannelState *statePtr;	/* Channel on which to discard the queued
				 * input. */
    int discardSavedBuffers;	/* If non-zero, discard all buffers including
				 * last one. */
{
    ChannelBuffer *bufPtr, *nxtPtr;	/* Loop variables. */

    bufPtr = statePtr->inQueueHead;
    statePtr->inQueueHead = (ChannelBuffer *) NULL;
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInput --
 *
 *	Reads input data from a device into a channel buffer.  
 *
 * Results:
 *	The return value is the Posix error code if an error occurred while
 *	reading from the file, or 0 otherwise.  
 *
 * Side effects:
 *	Reads from the underlying device.
 *
 *---------------------------------------------------------------------------
 */








|



|







5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInput --
 *
 *	Reads input data from a device into a channel buffer.
 *
 * Results:
 *	The return value is the Posix error code if an error occurred while
 *	reading from the file, or 0 otherwise.
 *
 * Side effects:
 *	Reads from the underlying device.
 *
 *---------------------------------------------------------------------------
 */

5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336

5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return EINVAL;
    }

    /*
     * First check for more buffers in the pushback area of the
     * topmost channel in the stack and use them. They can be the
     * result of a transformation which went away without reading all
     * the information placed in the area when it was stacked.
     *
     * Two possibilities for the state: No buffers in it, or a single
     * empty buffer. In the latter case we can recycle it now.
     */

    if (chanPtr->inQueueHead != (ChannelBuffer *) NULL) {
	if (statePtr->inQueueHead != (ChannelBuffer *) NULL) {
	    RecycleBuffer(statePtr, statePtr->inQueueHead, 0);
	    statePtr->inQueueHead = (ChannelBuffer *) NULL;
	}

	statePtr->inQueueHead = chanPtr->inQueueHead;
	statePtr->inQueueTail = chanPtr->inQueueTail;
	chanPtr->inQueueHead = (ChannelBuffer *) NULL;
	chanPtr->inQueueTail = (ChannelBuffer *) NULL;
	return 0;
    }

    /*
     * Nothing in the pushback area, fall back to the usual handling
     * (driver, etc.)
     */

    /*
     * See if we can fill an existing buffer. If we can, read only
     * as much as will fit in it. Otherwise allocate a new buffer,
     * add it to the input queue and attempt to fill it to the max.
     */

    bufPtr = statePtr->inQueueTail;
    if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) {
	toRead = bufPtr->bufLength - bufPtr->nextAdded;
    } else {
	bufPtr = statePtr->saveInBufPtr;
	statePtr->saveInBufPtr = NULL;

	/*
	 * Check the actual buffersize against the requested
	 * buffersize. Buffers which are smaller than requested are
	 * squashed. This is done to honor dynamic changes of the
	 * buffersize made by the user.
	 */

	if ((bufPtr != NULL)
		&& (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) {
	    ckfree((char *) bufPtr);
	    bufPtr = NULL;
	}

	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	}
	bufPtr->nextPtr = (ChannelBuffer *) NULL;


	/* SF #427196: Use the actual size of the buffer to determine
	 * the number of bytes to read from the channel and not the
	 * size for new buffers. They can be different if the
	 * buffersize was changed between reads.
	 *
	 * Note: This affects performance negatively if the buffersize
	 * was extended but this small buffer is reused for all
	 * subsequent reads. The system never uses buffers with the
	 * requested bigger size in that case. An adjunct patch could
	 * try and delete all unused buffers it encounters and which
	 * are smaller than the formally requested buffersize.
	 */

	toRead = bufPtr->bufLength - bufPtr->nextAdded;

	if (statePtr->inQueueTail == NULL) {
	    statePtr->inQueueHead = bufPtr;
	} else {







|
|
|
|

|
|
















|
|



|
|
|












|
|













>
|
|
|
|

|
|
|
|
|
|







5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return EINVAL;
    }

    /*
     * First check for more buffers in the pushback area of the topmost
     * channel in the stack and use them. They can be the result of a
     * transformation which went away without reading all the information
     * placed in the area when it was stacked.
     *
     * Two possibilities for the state: No buffers in it, or a single empty
     * buffer. In the latter case we can recycle it now.
     */

    if (chanPtr->inQueueHead != (ChannelBuffer *) NULL) {
	if (statePtr->inQueueHead != (ChannelBuffer *) NULL) {
	    RecycleBuffer(statePtr, statePtr->inQueueHead, 0);
	    statePtr->inQueueHead = (ChannelBuffer *) NULL;
	}

	statePtr->inQueueHead = chanPtr->inQueueHead;
	statePtr->inQueueTail = chanPtr->inQueueTail;
	chanPtr->inQueueHead = (ChannelBuffer *) NULL;
	chanPtr->inQueueTail = (ChannelBuffer *) NULL;
	return 0;
    }

    /*
     * Nothing in the pushback area, fall back to the usual handling (driver,
     * etc.)
     */

    /*
     * See if we can fill an existing buffer. If we can, read only as much as
     * will fit in it. Otherwise allocate a new buffer, add it to the input
     * queue and attempt to fill it to the max.
     */

    bufPtr = statePtr->inQueueTail;
    if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) {
	toRead = bufPtr->bufLength - bufPtr->nextAdded;
    } else {
	bufPtr = statePtr->saveInBufPtr;
	statePtr->saveInBufPtr = NULL;

	/*
	 * Check the actual buffersize against the requested
	 * buffersize. Buffers which are smaller than requested are
	 * squashed. This is done to honor dynamic changes of the buffersize
	 * made by the user.
	 */

	if ((bufPtr != NULL)
		&& (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) {
	    ckfree((char *) bufPtr);
	    bufPtr = NULL;
	}

	if (bufPtr == NULL) {
	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
	}
	bufPtr->nextPtr = (ChannelBuffer *) NULL;

	/*
	 * SF #427196: Use the actual size of the buffer to determine the
	 * number of bytes to read from the channel and not the size for new
	 * buffers. They can be different if the buffersize was changed
	 * between reads.
	 *
	 * Note: This affects performance negatively if the buffersize was
	 * extended but this small buffer is reused for all subsequent reads.
	 * The system never uses buffers with the requested bigger size in
	 * that case. An adjunct patch could try and delete all unused buffers
	 * it encounters and which are smaller than the formally requested
	 * buffersize.
	 */

	toRead = bufPtr->bufLength - bufPtr->nextAdded;

	if (statePtr->inQueueTail == NULL) {
	    statePtr->inQueueHead = bufPtr;
	} else {
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387

5388
5389

5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419

    if (statePtr->flags & CHANNEL_EOF) {
	return 0;
    }

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    /*
     * [SF Tcl Bug 943274]. Better emulation of non-blocking channels
     * for channels without BlockModeProc, by keeping track of true
     * fileevents generated by the OS == Data waiting and reading if
     * and only if we are sure to have data.
     */

    if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
	    !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
	/*
	 * Bypass the driver, it would block, as no data is available
	 */

	nread = -1;
	result = EWOULDBLOCK;
    } else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
		bufPtr->buf + bufPtr->nextAdded, toRead, &result);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    if (nread > 0) {
	bufPtr->nextAdded += nread;

	/*
	 * If we get a short read, signal up that we may be BLOCKED. We
	 * should avoid calling the driver because on some platforms we
	 * will block in the low level reading code even though the
	 * channel is set into nonblocking mode.
	 */

	if (nread < toRead) {
	    statePtr->flags |= CHANNEL_BLOCKED;
	}

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	if (nread <= toRead) {
	    /*
	     * [SF Tcl Bug 943274] We have read the available data,
	     * clear flag.
	     */

	    statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
	}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    } else if (nread == 0) {







|
|
|
|













>


>








|
|
|
|









|
|







5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651

    if (statePtr->flags & CHANNEL_EOF) {
	return 0;
    }

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    /*
     * [SF Tcl Bug 943274]. Better emulation of non-blocking channels for
     * channels without BlockModeProc, by keeping track of true fileevents
     * generated by the OS == Data waiting and reading if and only if we are
     * sure to have data.
     */

    if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
	    !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
	/*
	 * Bypass the driver, it would block, as no data is available
	 */

	nread = -1;
	result = EWOULDBLOCK;
    } else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
		bufPtr->buf + bufPtr->nextAdded, toRead, &result);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    if (nread > 0) {
	bufPtr->nextAdded += nread;

	/*
	 * If we get a short read, signal up that we may be BLOCKED. We should
	 * avoid calling the driver because on some platforms we will block in
	 * the low level reading code even though the channel is set into
	 * nonblocking mode.
	 */

	if (nread < toRead) {
	    statePtr->flags |= CHANNEL_BLOCKED;
	}

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	if (nread <= toRead) {
	    /*
	     * [SF Tcl Bug 943274] We have read the available data, clear
	     * flag.
	     */

	    statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
	}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    } else if (nread == 0) {
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Seek --
 *
 *	Implements seeking on Tcl Channels. This is a public function
 *	so that other C facilities may be implemented on top of it.
 *
 * Results:
 *	The new access point or -1 on error. If error, use Tcl_GetErrno()
 *	to retrieve the POSIX error code for the error that occurred.
 *
 * Side effects:
 *	May flush output on the channel. May discard queued input.
 *
 *----------------------------------------------------------------------
 */

Tcl_WideInt
Tcl_Seek(chan, offset, mode)
    Tcl_Channel chan;		/* The channel on which to seek. */
    Tcl_WideInt offset;		/* Offset to seek to. */
    int mode;			/* Relative to which location to seek? */
{
    Channel *chanPtr = (Channel *) chan;	/* The real IO channel. */
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int inputBuffered, outputBuffered;
				/* # bytes held in buffers. */
    int result;			/* Of device driver operations. */
    Tcl_WideInt curPos;		/* Position on the device. */
    int wasAsync;		/* Was the channel nonblocking before the
				 * seek operation? If so, must restore to
				 * nonblocking mode after the seek. */

    if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
	return Tcl_LongAsWide(-1);
    }

    /*
     * Disallow seek on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still
     * registered in an interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return Tcl_LongAsWide(-1);
    }

    /*







|
|


|
|



















|
|
|






|
|
|
|







5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Seek --
 *
 *	Implements seeking on Tcl Channels. This is a public function so that
 *	other C facilities may be implemented on top of it.
 *
 * Results:
 *	The new access point or -1 on error. If error, use Tcl_GetErrno() to
 *	retrieve the POSIX error code for the error that occurred.
 *
 * Side effects:
 *	May flush output on the channel. May discard queued input.
 *
 *----------------------------------------------------------------------
 */

Tcl_WideInt
Tcl_Seek(chan, offset, mode)
    Tcl_Channel chan;		/* The channel on which to seek. */
    Tcl_WideInt offset;		/* Offset to seek to. */
    int mode;			/* Relative to which location to seek? */
{
    Channel *chanPtr = (Channel *) chan;	/* The real IO channel. */
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int inputBuffered, outputBuffered;
				/* # bytes held in buffers. */
    int result;			/* Of device driver operations. */
    Tcl_WideInt curPos;		/* Position on the device. */
    int wasAsync;		/* Was the channel nonblocking before the seek
				 * operation? If so, must restore to
				 * non-blocking mode after the seek. */

    if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
	return Tcl_LongAsWide(-1);
    }

    /*
     * Disallow seek on dead channels - channels that have been closed but not
     * yet been deallocated. Such channels can be found if the exit handler
     * for channel cleanup has run but the channel is still registered in an
     * interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return Tcl_LongAsWide(-1);
    }

    /*
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588

    if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
	Tcl_SetErrno(EINVAL);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Compute how much input and output is buffered. If both input and
     * output is buffered, cannot compute the current position.
     */

    inputBuffered = Tcl_InputBuffered(chan);
    outputBuffered = Tcl_OutputBuffered(chan);

    if ((inputBuffered != 0) && (outputBuffered != 0)) {
	Tcl_SetErrno(EFAULT);
	return Tcl_LongAsWide(-1);
    }

    /*
     * If we are seeking relative to the current position, compute the
     * corrected offset taking into account the amount of unread input.
     */

    if (mode == SEEK_CUR) {
	offset -= inputBuffered;
    }

    /*
     * Discard any queued input - this input should not be read after
     * the seek.
     */

    DiscardInputQueued(statePtr, 0);

    /*
     * Reset EOF and BLOCKED flags. We invalidate them by moving the
     * access point. Also clear CR related flags.
     */

    statePtr->flags &=
	~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR);

    /*
     * If the channel is in asynchronous output mode, switch it back
     * to synchronous mode and cancel any async flush that may be
     * scheduled. After the flush, the channel will be put back into
     * asynchronous output mode.
     */

    wasAsync = 0;
    if (statePtr->flags & CHANNEL_NONBLOCKING) {
	wasAsync = 1;
	result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
	if (result != 0) {
	    return Tcl_LongAsWide(-1);
	}
	statePtr->flags &= (~(CHANNEL_NONBLOCKING));
	if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	    statePtr->flags &= (~(BG_FLUSH_SCHEDULED));
	}
    }

    /*
     * If there is data buffered in statePtr->curOutPtr then mark
     * the channel as ready to flush before invoking FlushChannel.
     */

    if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
	    (statePtr->curOutPtr->nextAdded >
		    statePtr->curOutPtr->nextRemoved)) {
	statePtr->flags |= BUFFER_READY;
    }

    /*
     * If the flush fails we cannot recover the original position. In
     * that case the seek is not attempted because we do not know where
     * the access position is - instead we return the error. FlushChannel
     * has already called Tcl_SetErrno() to report the error upwards.
     * If the flush succeeds we do the seek also.
     */

    if (FlushChannel(NULL, chanPtr, 0) != 0) {
	curPos = -1;
    } else {

	/*
	 * Now seek to the new position in the channel as requested by the
	 * caller.  Note that we prefer the wideSeekProc if that is
	 * available and non-NULL...
	 */

	if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
		chanPtr->typePtr->wideSeekProc != NULL) {
	    curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
		    offset, mode, &result);
	} else if (offset < Tcl_LongAsWide(LONG_MIN) ||







|
|




















|
|





|
|






|
|
|
|
















|
|









|
|
|
|
|








|
|







5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820

    if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
	Tcl_SetErrno(EINVAL);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Compute how much input and output is buffered. If both input and output
     * is buffered, cannot compute the current position.
     */

    inputBuffered = Tcl_InputBuffered(chan);
    outputBuffered = Tcl_OutputBuffered(chan);

    if ((inputBuffered != 0) && (outputBuffered != 0)) {
	Tcl_SetErrno(EFAULT);
	return Tcl_LongAsWide(-1);
    }

    /*
     * If we are seeking relative to the current position, compute the
     * corrected offset taking into account the amount of unread input.
     */

    if (mode == SEEK_CUR) {
	offset -= inputBuffered;
    }

    /*
     * Discard any queued input - this input should not be read after the
     * seek.
     */

    DiscardInputQueued(statePtr, 0);

    /*
     * Reset EOF and BLOCKED flags. We invalidate them by moving the access
     * point. Also clear CR related flags.
     */

    statePtr->flags &=
	~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR);

    /*
     * If the channel is in asynchronous output mode, switch it back to
     * synchronous mode and cancel any async flush that may be scheduled.
     * After the flush, the channel will be put back into asynchronous output
     * mode.
     */

    wasAsync = 0;
    if (statePtr->flags & CHANNEL_NONBLOCKING) {
	wasAsync = 1;
	result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
	if (result != 0) {
	    return Tcl_LongAsWide(-1);
	}
	statePtr->flags &= (~(CHANNEL_NONBLOCKING));
	if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	    statePtr->flags &= (~(BG_FLUSH_SCHEDULED));
	}
    }

    /*
     * If there is data buffered in statePtr->curOutPtr then mark the channel
     * as ready to flush before invoking FlushChannel.
     */

    if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
	    (statePtr->curOutPtr->nextAdded >
		    statePtr->curOutPtr->nextRemoved)) {
	statePtr->flags |= BUFFER_READY;
    }

    /*
     * If the flush fails we cannot recover the original position. In that
     * case the seek is not attempted because we do not know where the access
     * position is - instead we return the error. FlushChannel has already
     * called Tcl_SetErrno() to report the error upwards.  If the flush
     * succeeds we do the seek also.
     */

    if (FlushChannel(NULL, chanPtr, 0) != 0) {
	curPos = -1;
    } else {

	/*
	 * Now seek to the new position in the channel as requested by the
	 * caller.  Note that we prefer the wideSeekProc if that is available
	 * and non-NULL...
	 */

	if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
		chanPtr->typePtr->wideSeekProc != NULL) {
	    curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
		    offset, mode, &result);
	} else if (offset < Tcl_LongAsWide(LONG_MIN) ||
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
	    Tcl_SetErrno(result);
	}
    }

    /*
     * Restore to nonblocking mode if that was the previous behavior.
     *
     * NOTE: Even if there was an async flush active we do not restore
     * it now because we already flushed all the queued output, above.
     */

    if (wasAsync) {
	statePtr->flags |= CHANNEL_NONBLOCKING;
	result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
	if (result != 0) {
	    return Tcl_LongAsWide(-1);
	}
    }

    return curPos;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Tell --
 *
 *	Returns the position of the next character to be read/written on
 *	this channel.
 *
 * Results:
 *	A nonnegative integer on success, -1 on failure. If failed,
 *	use Tcl_GetErrno() to retrieve the POSIX error code for the
 *	error that occurred.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


















|
|


|
|
|







5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
	    Tcl_SetErrno(result);
	}
    }

    /*
     * Restore to nonblocking mode if that was the previous behavior.
     *
     * NOTE: Even if there was an async flush active we do not restore it now
     * because we already flushed all the queued output, above.
     */

    if (wasAsync) {
	statePtr->flags |= CHANNEL_NONBLOCKING;
	result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
	if (result != 0) {
	    return Tcl_LongAsWide(-1);
	}
    }

    return curPos;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Tell --
 *
 *	Returns the position of the next character to be read/written on this
 *	channel.
 *
 * Results:
 *	A nonnegative integer on success, -1 on failure. If failed, use
 *	Tcl_GetErrno() to retrieve the POSIX error code for the error that
 *	occurred.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
    if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
	return Tcl_LongAsWide(-1);
    }

    /*
     * Disallow tell on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still
     * registered in an interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return Tcl_LongAsWide(-1);
    }

    /*







|
|







5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
    if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
	return Tcl_LongAsWide(-1);
    }

    /*
     * Disallow tell on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still registered
     * in an interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return Tcl_LongAsWide(-1);
    }

    /*
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703

    if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
	Tcl_SetErrno(EINVAL);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Compute how much input and output is buffered. If both input and
     * output is buffered, cannot compute the current position.
     */

    inputBuffered = Tcl_InputBuffered(chan);
    outputBuffered = Tcl_OutputBuffered(chan);

    if ((inputBuffered != 0) && (outputBuffered != 0)) {
	Tcl_SetErrno(EFAULT);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Get the current position in the device and compute the position
     * where the next character will be read or written.  Note that we
     * prefer the wideSeekProc if that is available and non-NULL...
     */

    if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
	    chanPtr->typePtr->wideSeekProc != NULL) {
	curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
		Tcl_LongAsWide(0), SEEK_CUR, &result);
    } else {







|
|











|
|
|







5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935

    if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
	Tcl_SetErrno(EINVAL);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Compute how much input and output is buffered. If both input and output
     * is buffered, cannot compute the current position.
     */

    inputBuffered = Tcl_InputBuffered(chan);
    outputBuffered = Tcl_OutputBuffered(chan);

    if ((inputBuffered != 0) && (outputBuffered != 0)) {
	Tcl_SetErrno(EFAULT);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Get the current position in the device and compute the position where
     * the next character will be read or written.  Note that we prefer the
     * wideSeekProc if that is available and non-NULL...
     */

    if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
	    chanPtr->typePtr->wideSeekProc != NULL) {
	curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
		Tcl_LongAsWide(0), SEEK_CUR, &result);
    } else {
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SeekOld, Tcl_TellOld --
 *
 *	Backward-compatability versions of the seek/tell interface that
 *	do not support 64-bit offsets.  This interface is not documented
 *	or expected to be supported indefinitely.
 *
 * Results:
 *	As for Tcl_Seek and Tcl_Tell respectively, except truncated to
 *	whatever value will fit in an 'int'.
 *
 * Side effects:
 *	As for Tcl_Seek and Tcl_Tell respectively.







|
|
|







5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SeekOld, Tcl_TellOld --
 *
 *	Backward-compatability versions of the seek/tell interface that do not
 *	support 64-bit offsets.  This interface is not documented or expected
 *	to be supported indefinitely.
 *
 * Results:
 *	As for Tcl_Seek and Tcl_Tell respectively, except truncated to
 *	whatever value will fit in an 'int'.
 *
 * Side effects:
 *	As for Tcl_Seek and Tcl_Tell respectively.
5755
5756
5757
5758
5759
5760
5761




































































5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
    wResult = Tcl_Tell(chan);
    return (int)Tcl_WideAsLong(wResult);
}

/*
 *---------------------------------------------------------------------------
 *




































































 * CheckChannelErrors --
 *
 *	See if the channel is in an ready state and can perform the
 *	desired operation.
 *
 * Results:
 *	The return value is 0 if the channel is OK, otherwise the
 *	return value is -1 and errno is set to indicate the error.
 *
 * Side effects:
 *	May clear the EOF and/or BLOCKED bits if reading from channel.
 *
 *---------------------------------------------------------------------------
 */








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|


|
|







5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
    wResult = Tcl_Tell(chan);
    return (int)Tcl_WideAsLong(wResult);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_TruncateChannel --
 *
 *	Truncate a channel to the given length.
 *
 * Results:
 *	TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not
 *	supported by the type of channel, or the underlying OS operation
 *	failed in some way).
 *
 * Side effects:
 *	Seeks the channel to the current location. Sets errno on OS error.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_TruncateChannel(chan, length)
    Tcl_Channel chan;
    Tcl_WideInt length;
{
    Channel *chanPtr = (Channel *) chan;
    Tcl_DriverTruncateProc *truncateProc =
	    Tcl_ChannelTruncateProc(chanPtr->typePtr);
    int result;

    if (truncateProc == NULL) {
	/*
	 * Feature not supported and it's not emulatable. Pretend it's
	 * returned an EINVAL, a very generic error!
	 */
	Tcl_SetErrno(EINVAL);
	return TCL_ERROR;
    }

    if (!(chanPtr->state->flags & TCL_WRITABLE)) {
	/*
	 * We require that the file was opened of writing. Do that check now
	 * so that we only flush if we think we're going to succeed.
	 */
	Tcl_SetErrno(EINVAL);
	return TCL_ERROR;
    }

    /*
     * Seek first to force a total flush of all pending buffers and ditch any
     * pre-read input data.
     */

    if (Tcl_Seek(chan, 0, SEEK_CUR) == Tcl_LongAsWide(-1)) {
	return TCL_ERROR;
    }

    /*
     * We're all flushed to disk now and we also don't have any unfortunate
     * input baggage around either; can truncate with impunity.
     */

    result = truncateProc(chanPtr->instanceData, length);
    if (result != 0) {
	Tcl_SetErrno(result);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * CheckChannelErrors --
 *
 *	See if the channel is in an ready state and can perform the desired
 *	operation.
 *
 * Results:
 *	The return value is 0 if the channel is OK, otherwise the return value
 *	is -1 and errno is set to indicate the error.
 *
 * Side effects:
 *	May clear the EOF and/or BLOCKED bits if reading from channel.
 *
 *---------------------------------------------------------------------------
 */

5787
5788
5789
5790
5791
5792
5793










5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
    /*
     * Check for unreported error.
     */

    if (statePtr->unreportedError != 0) {
	Tcl_SetErrno(statePtr->unreportedError);
	statePtr->unreportedError = 0;










	return -1;
    }

    /*
     * Only the raw read and write operations are allowed during close
     * in order to drain data from stacked channels.
     */

    if ((statePtr->flags & CHANNEL_CLOSED) &&
	    ((flags & CHANNEL_RAW_MODE) == 0)) {
	Tcl_SetErrno(EACCES);
	return -1;
    }







>
>
>
>
>
>
>
>
>
>




|
|







6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
    /*
     * Check for unreported error.
     */

    if (statePtr->unreportedError != 0) {
	Tcl_SetErrno(statePtr->unreportedError);
	statePtr->unreportedError = 0;

	/* TIP #219, Tcl Channel Reflection API.
	 * Move a defered error message back into the channel bypass.
	 */

	if (statePtr->chanMsg != NULL) {
	    Tcl_DecrRefCount (statePtr->chanMsg);
	}
	statePtr->chanMsg       = statePtr->unreportedMsg;
	statePtr->unreportedMsg = NULL;
	return -1;
    }

    /*
     * Only the raw read and write operations are allowed during close in
     * order to drain data from stacked channels.
     */

    if ((statePtr->flags & CHANNEL_CLOSED) &&
	    ((flags & CHANNEL_RAW_MODE) == 0)) {
	Tcl_SetErrno(EACCES);
	return -1;
    }
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
    if ((statePtr->csPtr != NULL) && ((flags & CHANNEL_RAW_MODE) == 0)) {
	Tcl_SetErrno(EBUSY);
	return -1;
    }

    if (direction == TCL_READABLE) {
	/*
	 * If we have not encountered a sticky EOF, clear the EOF bit
	 * (sticky EOF is set if we have seen the input eofChar, to prevent
	 * reading beyond the eofChar). Also, always clear the BLOCKED bit.
	 * We want to discover these conditions anew in each operation.
	 */

	if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) {
	    statePtr->flags &= ~CHANNEL_EOF;
	}
	statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
    }







|
|
|
|







6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
    if ((statePtr->csPtr != NULL) && ((flags & CHANNEL_RAW_MODE) == 0)) {
	Tcl_SetErrno(EBUSY);
	return -1;
    }

    if (direction == TCL_READABLE) {
	/*
	 * If we have not encountered a sticky EOF, clear the EOF bit (sticky
	 * EOF is set if we have seen the input eofChar, to prevent reading
	 * beyond the eofChar). Also, always clear the BLOCKED bit. We want to
	 * discover these conditions anew in each operation.
	 */

	if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) {
	    statePtr->flags &= ~CHANNEL_EOF;
	}
	statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
    }
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBuffered --
 *
 *	Returns the number of bytes of input currently buffered in the
 *	common internal buffer of a channel.
 *
 * Results:
 *	The number of input bytes buffered, or zero if the channel is not
 *	open for reading.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBuffered --
 *
 *	Returns the number of bytes of input currently buffered in the common
 *	internal buffer of a channel.
 *
 * Results:
 *	The number of input bytes buffered, or zero if the channel is not open
 *	for reading.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OutputBuffered --
 *
 *    Returns the number of bytes of output currently buffered in the
 *    common internal buffer of a channel.
 *
 * Results:
 *    The number of output bytes buffered, or zero if the channel is not
 *    open for writing.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OutputBuffered --
 *
 *    Returns the number of bytes of output currently buffered in the common
 *    internal buffer of a channel.
 *
 * Results:
 *    The number of output bytes buffered, or zero if the channel is not open
 *    for writing.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
 *
 * Tcl_ChannelBuffered --
 *
 *	Returns the number of bytes of input currently buffered in the
 *	internal buffer (push back area) of a channel.
 *
 * Results:
 *	The number of input bytes buffered, or zero if the channel is not
 *	open for reading.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|







6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
 *
 * Tcl_ChannelBuffered --
 *
 *	Returns the number of bytes of input currently buffered in the
 *	internal buffer (push back area) of a channel.
 *
 * Results:
 *	The number of input bytes buffered, or zero if the channel is not open
 *	for reading.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetChannelBufferSize --
 *
 *	Sets the size of buffers to allocate to store input or output
 *	in the channel. The size must be between 10 bytes and 1 MByte.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the size of buffers subsequently allocated for this channel.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetChannelBufferSize(chan, sz)
    Tcl_Channel chan;			/* The channel whose buffer size
					 * to set. */
    int sz;				/* The size to set. */
{
    ChannelState *statePtr;		/* State of real channel structure. */

    /*
     * If the buffer size is smaller than 10 bytes or larger than one MByte,
     * do not accept the requested size and leave the current buffer size.
     */

    if (sz < 10) {
	return;
    }
    if (sz > (1024 * 1024)) {
	return;
    }

    statePtr = ((Channel *) chan)->state;
    statePtr->bufSize = sz;

    if (statePtr->outputStage != NULL) {
	ckfree((char *) statePtr->outputStage);
	statePtr->outputStage = NULL;
    }
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *)
	    ckalloc((unsigned) (statePtr->bufSize + 2));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelBufferSize --







|
|












|
|





|
|


|















|







6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetChannelBufferSize --
 *
 *	Sets the size of buffers to allocate to store input or output in the
 *	channel. The size must be between 1 byte and 1 MByte.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the size of buffers subsequently allocated for this channel.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetChannelBufferSize(chan, sz)
    Tcl_Channel chan;			/* The channel whose buffer size to
					 * set. */
    int sz;				/* The size to set. */
{
    ChannelState *statePtr;		/* State of real channel structure. */

    /*
     * If the buffer size is smaller than 1 byte or larger than one MByte, do
     * not accept the requested size and leave the current buffer size.
     */

    if (sz < 1) {
	return;
    }
    if (sz > (1024 * 1024)) {
	return;
    }

    statePtr = ((Channel *) chan)->state;
    statePtr->bufSize = sz;

    if (statePtr->outputStage != NULL) {
	ckfree((char *) statePtr->outputStage);
	statePtr->outputStage = NULL;
    }
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *)
		ckalloc((unsigned) (statePtr->bufSize + 2));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelBufferSize --
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115

6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BadChannelOption --
 *
 *	This procedure generates a "bad option" error message in an
 *	(optional) interpreter.  It is used by channel drivers when 
 *	a invalid Set/Get option is requested. Its purpose is to concatenate
 *	the generic options list to the specific ones and factorize
 *	the generic options error message string.
 *
 * Results:
 *	TCL_ERROR.
 *
 * Side effects:

 *	An error message is generated in interp's result object to
 *	indicate that a command was invoked with the a bad option
 *	The message has the form
 *		bad option "blah": should be one of 
 *		<...generic options...>+<...specific options...>
 *	"blah" is the optionName argument and "<specific options>"
 *	is a space separated list of specific option words.
 *	The function takes good care of inserting minus signs before
 *	each option, commas after, and an "or" before the last option.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_BadChannelOption(interp, optionName, optionList)
    Tcl_Interp *interp;			/* Current interpreter. (can be NULL)*/
    CONST char *optionName;		/* 'bad option' name */
    CONST char *optionList;		/* Specific options list to append 
					 * to the standard generic options.
					 * can be NULL for generic options 
					 * only. */
{
    if (interp) {
	CONST char *genericopt = 
	    "blocking buffering buffersize encoding eofchar translation";
	CONST char **argv;
	int  argc, i;
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, genericopt, -1);
	if (optionList && (*optionList)) {
	    Tcl_DStringAppend(&ds, " ", 1);
	    Tcl_DStringAppend(&ds, optionList, -1);
	}
	if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), 
		&argc, &argv) != TCL_OK) {
	    Tcl_Panic("malformed option list in channel driver");
	}
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "bad option \"", optionName, 
		"\": should be one of ", (char *) NULL);
	argc--;
	for (i = 0; i < argc; i++) {
	    Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL);
	}
	Tcl_AppendResult(interp, "or -", argv[i], (char *) NULL);
	Tcl_DStringFree(&ds);
	ckfree((char *) argv);
    }
    Tcl_SetErrno(EINVAL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelOption --
 *
 *	Gets a mode associated with an IO channel. If the optionName arg
 *	is non NULL, retrieves the value of that option. If the optionName
 *	arg is NULL, retrieves a list of alternating option names and
 *	values for the given channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the supplied DString to the
 *	string value of the option(s) returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|
|
|





>
|
|
|
|

|
|
|
|






|

|
|
|


|
|
|

|








|




|


















|
|
|
|


|
|







6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BadChannelOption --
 *
 *	This procedure generates a "bad option" error message in an (optional)
 *	interpreter.  It is used by channel drivers when a invalid Set/Get
 *	option is requested. Its purpose is to concatenate the generic options
 *	list to the specific ones and factorize the generic options error
 *	message string.
 *
 * Results:
 *	TCL_ERROR.
 *
 * Side effects:

 *	An error message is generated in interp's result object to indicate
 *	that a command was invoked with the a bad option.  The message has the
 *	form:
 *		bad option "blah": should be one of
 *		<...generic options...>+<...specific options...>
 *	"blah" is the optionName argument and "<specific options>" is a space
 *	separated list of specific option words.  The function takes good care
 *	of inserting minus signs before each option, commas after, and an "or"
 *	before the last option.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_BadChannelOption(interp, optionName, optionList)
    Tcl_Interp *interp;			/* Current interpreter (can be NULL).*/
    CONST char *optionName;		/* 'bad option' name */
    CONST char *optionList;		/* Specific options list to append to
					 * the standard generic options. Can
					 * be NULL for generic options
					 * only. */
{
    if (interp != NULL) {
	CONST char *genericopt =
		"blocking buffering buffersize encoding eofchar translation";
	CONST char **argv;
	int argc, i;
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, genericopt, -1);
	if (optionList && (*optionList)) {
	    Tcl_DStringAppend(&ds, " ", 1);
	    Tcl_DStringAppend(&ds, optionList, -1);
	}
	if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
		&argc, &argv) != TCL_OK) {
	    Tcl_Panic("malformed option list in channel driver");
	}
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "bad option \"", optionName,
		"\": should be one of ", (char *) NULL);
	argc--;
	for (i = 0; i < argc; i++) {
	    Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL);
	}
	Tcl_AppendResult(interp, "or -", argv[i], (char *) NULL);
	Tcl_DStringFree(&ds);
	ckfree((char *) argv);
    }
    Tcl_SetErrno(EINVAL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelOption --
 *
 *	Gets a mode associated with an IO channel. If the optionName arg is
 *	non NULL, retrieves the value of that option. If the optionName arg is
 *	NULL, retrieves a list of alternating option names and values for the
 *	given channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the supplied DString to the string
 *	value of the option(s) returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int flags;

    /*
     * Disallow options on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still
     * registered in an interpreter.
     */

    if (CheckForDeadChannel(interp, statePtr)) {
	return TCL_ERROR;
    }

    /*







|
|







6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int flags;

    /*
     * Disallow options on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still registered
     * in an interpreter.
     */

    if (CheckForDeadChannel(interp, statePtr)) {
	return TCL_ERROR;
    }

    /*
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
	    flags = statePtr->csPtr->writeFlags;
	}
    } else {
	flags = statePtr->flags;
    }

    /*
     * If the optionName is NULL it means that we want a list of all
     * options and values.
     */

    if (optionName == (char *) NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }







|
|







6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
	    flags = statePtr->csPtr->writeFlags;
	}
    } else {
	flags = statePtr->flags;
    }

    /*
     * If the optionName is NULL it means that we want a list of all options
     * and values.
     */

    if (optionName == (char *) NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
	}
	if (len > 0) {
	    return TCL_OK;
	}
    }
    if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) {
	/*
	 * let the driver specific handle additional options
	 * and result code and message.
	 */

	return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData,
		interp, optionName, dsPtr);
    } else {
	/*
	 * no driver specific options case.
	 */

	if (len == 0) {
	    return TCL_OK;
	}
	return Tcl_BadChannelOption(interp, optionName, NULL);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetChannelOption --
 *
 *	Sets an option on a channel.
 *
 * Results:
 *	A standard Tcl result.  On error, sets interp's result object
 *	if interp is not NULL.
 *
 * Side effects:
 *	May modify an option on a device.
 *
 *---------------------------------------------------------------------------
 */








|
|






|

















|
|







6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
	}
	if (len > 0) {
	    return TCL_OK;
	}
    }
    if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) {
	/*
	 * Let the driver specific handle additional options and result code
	 * and message.
	 */

	return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData,
		interp, optionName, dsPtr);
    } else {
	/*
	 * No driver specific options case.
	 */

	if (len == 0) {
	    return TCL_OK;
	}
	return Tcl_BadChannelOption(interp, optionName, NULL);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetChannelOption --
 *
 *	Sets an option on a channel.
 *
 * Results:
 *	A standard Tcl result.  On error, sets interp's result object if
 *	interp is not NULL.
 *
 * Side effects:
 *	May modify an option on a device.
 *
 *---------------------------------------------------------------------------
 */

6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
	}
	return TCL_ERROR;
    }

    /*
     * Disallow options on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still
     * registered in an interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return TCL_ERROR;
    }

    /*







|
|







6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
	}
	return TCL_ERROR;
    }

    /*
     * Disallow options on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
     * handler for channel cleanup has run but the channel is still registered
     * in an interpreter.
     */

    if (CheckForDeadChannel(NULL, statePtr)) {
	return TCL_ERROR;
    }

    /*
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
	    }
	}
	if (argv != NULL) {
	    ckfree((char *) argv);
	}

	/*
	 * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing
	 * the character which signals eof can transform a current eof
	 * condition into a 'go ahead'. Ditto for blocked.
	 */

	statePtr->flags &=
		~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED);

	return TCL_OK;
    } else if ((len > 1) && (optionName[1] == 't') &&







|
|
|







6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
	    }
	}
	if (argv != NULL) {
	    ckfree((char *) argv);
	}

	/*
	 * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing the
	 * character which signals eof can transform a current eof condition
	 * into a 'go ahead'. Ditto for blocked.
	 */

	statePtr->flags &=
		~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED);

	return TCL_OK;
    } else if ((len > 1) && (optionName[1] == 't') &&
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
	    if (*readMode == '\0') {
		translation = statePtr->inputTranslation;
	    } else if (strcmp(readMode, "auto") == 0) {
		translation = TCL_TRANSLATE_AUTO;
	    } else if (strcmp(readMode, "binary") == 0) {
		translation = TCL_TRANSLATE_LF;
		statePtr->inEofChar = 0;
		Tcl_FreeEncoding(statePtr->encoding);		    
		statePtr->encoding = NULL;
	    } else if (strcmp(readMode, "lf") == 0) {
		translation = TCL_TRANSLATE_LF;
	    } else if (strcmp(readMode, "cr") == 0) {
		translation = TCL_TRANSLATE_CR;
	    } else if (strcmp(readMode, "crlf") == 0) {
		translation = TCL_TRANSLATE_CRLF;







|







6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
	    if (*readMode == '\0') {
		translation = statePtr->inputTranslation;
	    } else if (strcmp(readMode, "auto") == 0) {
		translation = TCL_TRANSLATE_AUTO;
	    } else if (strcmp(readMode, "binary") == 0) {
		translation = TCL_TRANSLATE_LF;
		statePtr->inEofChar = 0;
		Tcl_FreeEncoding(statePtr->encoding);
		statePtr->encoding = NULL;
	    } else if (strcmp(readMode, "lf") == 0) {
		translation = TCL_TRANSLATE_LF;
	    } else if (strcmp(readMode, "cr") == 0) {
		translation = TCL_TRANSLATE_CR;
	    } else if (strcmp(readMode, "crlf") == 0) {
		translation = TCL_TRANSLATE_CRLF;
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
			    " or platform", (char *) NULL);
		}
		ckfree((char *) argv);
		return TCL_ERROR;
	    }

	    /*
	     * Reset the EOL flags since we need to look at any buffered
	     * data to see if the new translation mode allows us to
	     * complete the line.
	     */

	    if (translation != statePtr->inputTranslation) {
		statePtr->inputTranslation = translation;
		statePtr->flags &= ~(INPUT_SAW_CR);
		statePtr->flags &= ~(CHANNEL_NEED_MORE_DATA);
		UpdateInterest(chanPtr);
	    }
	}
	if (writeMode) {
	    if (*writeMode == '\0') {
		/* Do nothing. */
	    } else if (strcmp(writeMode, "auto") == 0) {
		/*
		 * This is a hack to get TCP sockets to produce output
		 * in CRLF mode if they are being set into AUTO mode.
		 * A better solution for achieving this effect will be
		 * coded later.
		 */

		if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) {
		    statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
		} else {
		    statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
		}
	    } else if (strcmp(writeMode, "binary") == 0) {
		statePtr->outEofChar = 0;
		statePtr->outputTranslation = TCL_TRANSLATE_LF;
		Tcl_FreeEncoding(statePtr->encoding);		    
		statePtr->encoding = NULL;
	    } else if (strcmp(writeMode, "lf") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_LF;
	    } else if (strcmp(writeMode, "cr") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_CR;
	    } else if (strcmp(writeMode, "crlf") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(writeMode, "platform") == 0) {
		statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_AppendResult(interp,
			    "bad value for -translation: ",
			    "must be one of auto, binary, cr, lf, crlf,",
			    " or platform", (char *) NULL);
		}
		ckfree((char *) argv);
		return TCL_ERROR;
	    }
	}
	ckfree((char *) argv);		  
	return TCL_OK;
    } else if (chanPtr->typePtr->setOptionProc != NULL) {
	return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData,
		interp, optionName, newValue);
    } else {
	return Tcl_BadChannelOption(interp, optionName, (char *) NULL);
    }







|
|
|














|
|
|
<










|




















|







6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972

6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
			    " or platform", (char *) NULL);
		}
		ckfree((char *) argv);
		return TCL_ERROR;
	    }

	    /*
	     * Reset the EOL flags since we need to look at any buffered data
	     * to see if the new translation mode allows us to complete the
	     * line.
	     */

	    if (translation != statePtr->inputTranslation) {
		statePtr->inputTranslation = translation;
		statePtr->flags &= ~(INPUT_SAW_CR);
		statePtr->flags &= ~(CHANNEL_NEED_MORE_DATA);
		UpdateInterest(chanPtr);
	    }
	}
	if (writeMode) {
	    if (*writeMode == '\0') {
		/* Do nothing. */
	    } else if (strcmp(writeMode, "auto") == 0) {
		/*
		 * This is a hack to get TCP sockets to produce output in CRLF
		 * mode if they are being set into AUTO mode.  A better
		 * solution for achieving this effect will be coded later.

		 */

		if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) {
		    statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
		} else {
		    statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
		}
	    } else if (strcmp(writeMode, "binary") == 0) {
		statePtr->outEofChar = 0;
		statePtr->outputTranslation = TCL_TRANSLATE_LF;
		Tcl_FreeEncoding(statePtr->encoding);
		statePtr->encoding = NULL;
	    } else if (strcmp(writeMode, "lf") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_LF;
	    } else if (strcmp(writeMode, "cr") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_CR;
	    } else if (strcmp(writeMode, "crlf") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(writeMode, "platform") == 0) {
		statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_AppendResult(interp,
			    "bad value for -translation: ",
			    "must be one of auto, binary, cr, lf, crlf,",
			    " or platform", (char *) NULL);
		}
		ckfree((char *) argv);
		return TCL_ERROR;
	    }
	}
	ckfree((char *) argv);
	return TCL_OK;
    } else if (chanPtr->typePtr->setOptionProc != NULL) {
	return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData,
		interp, optionName, newValue);
    } else {
	return Tcl_BadChannelOption(interp, optionName, (char *) NULL);
    }
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
     */

    if (statePtr->outputStage != NULL) {
	ckfree((char *) statePtr->outputStage);
	statePtr->outputStage = NULL;
    }
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *) 
	    ckalloc((unsigned) (statePtr->bufSize + 2));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * CleanupChannelHandlers --
 *
 *	Removes channel handlers that refer to the supplied interpreter,
 *	so that if the actual channel is not closed now, these handlers
 *	will not run on subsequent events on the channel. This would be
 *	erroneous, because the interpreter no longer has a reference to
 *	this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes channel handlers.
 *
 *----------------------------------------------------------------------
 */

static void
CleanupChannelHandlers(interp, chanPtr)
    Tcl_Interp *interp;
    Channel *chanPtr;
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    EventScriptRecord *sPtr, *prevPtr, *nextPtr;

    /*
     * Remove fileevent records on this channel that refer to the
     * given interpreter.
     */

    for (sPtr = statePtr->scriptRecordPtr,
	    prevPtr = (EventScriptRecord *) NULL;
	    sPtr != (EventScriptRecord *) NULL;
	    sPtr = nextPtr) {
	nextPtr = sPtr->nextPtr;







|










|
|
|
|
<



















|
|







7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
7048
7049
7050
7051
7052
7053
7054

7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081
7082
     */

    if (statePtr->outputStage != NULL) {
	ckfree((char *) statePtr->outputStage);
	statePtr->outputStage = NULL;
    }
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *)
	    ckalloc((unsigned) (statePtr->bufSize + 2));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * CleanupChannelHandlers --
 *
 *	Removes channel handlers that refer to the supplied interpreter, so
 *	that if the actual channel is not closed now, these handlers will not
 *	run on subsequent events on the channel. This would be erroneous,
 *	because the interpreter no longer has a reference to this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes channel handlers.
 *
 *----------------------------------------------------------------------
 */

static void
CleanupChannelHandlers(interp, chanPtr)
    Tcl_Interp *interp;
    Channel *chanPtr;
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    EventScriptRecord *sPtr, *prevPtr, *nextPtr;

    /*
     * Remove fileevent records on this channel that refer to the given
     * interpreter.
     */

    for (sPtr = statePtr->scriptRecordPtr,
	    prevPtr = (EventScriptRecord *) NULL;
	    sPtr != (EventScriptRecord *) NULL;
	    sPtr = nextPtr) {
	nextPtr = sPtr->nextPtr;
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NotifyChannel --
 *
 *	This procedure is called by a channel driver when a driver
 *	detects an event on a channel.  This procedure is responsible
 *	for actually handling the event by invoking any channel
 *	handler callbacks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the channel handler callback procedure does.
 *







|
|
|
<







7099
7100
7101
7102
7103
7104
7105
7106
7107
7108

7109
7110
7111
7112
7113
7114
7115
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NotifyChannel --
 *
 *	This procedure is called by a channel driver when a driver detects an
 *	event on a channel.  This procedure is responsible for actually
 *	handling the event by invoking any channel handler callbacks.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the channel handler callback procedure does.
 *
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
    ChannelHandler *chPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    NextChannelHandler nh;
    Channel *upChanPtr;
    Tcl_ChannelType *upTypePtr;

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    /* [SF Tcl Bug 943274]
     * For a non-blocking channel without blockmodeproc we keep track
     * of actual input coming from the OS so that we can do a credible
     * imitation of non-blocking behaviour.
     */

    if ((mask & TCL_READABLE) &&
	    (statePtr->flags & CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
	    !(statePtr->flags & CHANNEL_TIMER_FEV)) {

	statePtr->flags |= CHANNEL_HAS_MORE_DATA;
    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    /*
     * In contrast to the other API functions this procedure walks towards
     * the top of a stack and not down from it.
     *
     * The channel calling this procedure is the one who generated the event,
     * and thus does not take part in handling it. IOW, its HandlerProc is
     * not called, instead we begin with the channel above it.
     *
     * This behaviour also allows the transformation channels to
     * generate their own events and pass them upward.
     */

    while (mask && (chanPtr->upChanPtr != ((Channel *) NULL))) {
	Tcl_DriverHandlerProc *upHandlerProc;

	upChanPtr = chanPtr->upChanPtr;
	upTypePtr = upChanPtr->typePtr;
	upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr);
	if (upHandlerProc != NULL) {
	    mask = (*upHandlerProc) (upChanPtr->instanceData, mask);
	}

	/* ELSE:
	 * Ignore transformations which are unable to handle the event
	 * coming from below. Assume that they don't change the mask and
	 * pass it on.
	 */

	chanPtr = upChanPtr;
    }

    channel = (Tcl_Channel) chanPtr;

    /*
     * Here we have either reached the top of the stack or the mask is
     * empty.  We break out of the procedure if it is the latter.
     */

    if (!mask) {
	return;
    }

    /*
     * We are now above the topmost channel in a stack and have events
     * left. Now call the channel handlers as usual.
     *
     * Preserve the channel struct in case the script closes it.
     */

    Tcl_Preserve((ClientData) channel);
    Tcl_Preserve((ClientData) statePtr);

    /*
     * If we are flushing in the background, be sure to call FlushChannel
     * for writable events.  Note that we have to discard the writable
     * event so we don't call any write handlers before the flush is
     * complete.
     */

    if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
	FlushChannel(NULL, chanPtr, 1);
	mask &= ~TCL_WRITABLE;
    }








|
|
|
|












|
|


|
|

|
|












|
|
|
|








|
|







|
|








|
|
|
<







7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205

7206
7207
7208
7209
7210
7211
7212
    ChannelHandler *chPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    NextChannelHandler nh;
    Channel *upChanPtr;
    Tcl_ChannelType *upTypePtr;

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    /*
     * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we
     * keep track of actual input coming from the OS so that we can do a
     * credible imitation of non-blocking behaviour.
     */

    if ((mask & TCL_READABLE) &&
	    (statePtr->flags & CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
	    !(statePtr->flags & CHANNEL_TIMER_FEV)) {

	statePtr->flags |= CHANNEL_HAS_MORE_DATA;
    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    /*
     * In contrast to the other API functions this procedure walks towards the
     * top of a stack and not down from it.
     *
     * The channel calling this procedure is the one who generated the event,
     * and thus does not take part in handling it. IOW, its HandlerProc is not
     * called, instead we begin with the channel above it.
     *
     * This behaviour also allows the transformation channels to generate
     * their own events and pass them upward.
     */

    while (mask && (chanPtr->upChanPtr != ((Channel *) NULL))) {
	Tcl_DriverHandlerProc *upHandlerProc;

	upChanPtr = chanPtr->upChanPtr;
	upTypePtr = upChanPtr->typePtr;
	upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr);
	if (upHandlerProc != NULL) {
	    mask = (*upHandlerProc) (upChanPtr->instanceData, mask);
	}

	/*
	 * ELSE: Ignore transformations which are unable to handle the event
	 * coming from below. Assume that they don't change the mask and pass
	 * it on.
	 */

	chanPtr = upChanPtr;
    }

    channel = (Tcl_Channel) chanPtr;

    /*
     * Here we have either reached the top of the stack or the mask is empty.
     * We break out of the procedure if it is the latter.
     */

    if (!mask) {
	return;
    }

    /*
     * We are now above the topmost channel in a stack and have events left.
     * Now call the channel handlers as usual.
     *
     * Preserve the channel struct in case the script closes it.
     */

    Tcl_Preserve((ClientData) channel);
    Tcl_Preserve((ClientData) statePtr);

    /*
     * If we are flushing in the background, be sure to call FlushChannel for
     * writable events.  Note that we have to discard the writable event so we
     * don't call any write handlers before the flush is complete.

     */

    if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
	FlushChannel(NULL, chanPtr, 1);
	mask &= ~TCL_WRITABLE;
    }

6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
	    chPtr = nh.nextHandlerPtr;
	} else {
	    chPtr = chPtr->nextPtr;
	}
    }

    /*
     * Update the notifier interest, since it may have changed after
     * invoking event handlers. Skip that if the channel was deleted
     * in the call to the channel handler.
     */

    if (chanPtr->typePtr != NULL) {
	UpdateInterest(chanPtr);
    }

    Tcl_Release((ClientData) statePtr);
    Tcl_Release((ClientData) channel);

    tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateInterest --
 *
 *	Arrange for the notifier to call us back at appropriate times
 *	based on the current state of the channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May schedule a timer or driver handler.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateInterest(chanPtr)
    Channel *chanPtr;		/* Channel to update. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int mask = statePtr->interestMask;

    /*
     * If there are flushed buffers waiting to be written, then
     * we need to watch for the channel to become writable.
     */

    if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	mask |= TCL_WRITABLE;
    }

    /*







|
|
|

















|
|


















|
|







7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
	    chPtr = nh.nextHandlerPtr;
	} else {
	    chPtr = chPtr->nextPtr;
	}
    }

    /*
     * Update the notifier interest, since it may have changed after invoking
     * event handlers. Skip that if the channel was deleted in the call to the
     * channel handler.
     */

    if (chanPtr->typePtr != NULL) {
	UpdateInterest(chanPtr);
    }

    Tcl_Release((ClientData) statePtr);
    Tcl_Release((ClientData) channel);

    tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateInterest --
 *
 *	Arrange for the notifier to call us back at appropriate times based on
 *	the current state of the channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May schedule a timer or driver handler.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateInterest(chanPtr)
    Channel *chanPtr;		/* Channel to update. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int mask = statePtr->interestMask;

    /*
     * If there are flushed buffers waiting to be written, then we need to
     * watch for the channel to become writable.
     */

    if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	mask |= TCL_WRITABLE;
    }

    /*
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028
7029
7030
7031
7032
7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
7048
7049
7050
7051
7052
7053
7054
7055
7056
7057
		&& (statePtr->inQueueHead->nextRemoved <
			statePtr->inQueueHead->nextAdded)) {
	    mask &= ~TCL_READABLE;

	    /*
	     * Andreas Kupries, April 11, 2003
	     *
	     * Some operating systems (Solaris 2.6 and higher (but not
	     * Solaris 2.5, go figure)) generate READABLE and
	     * EXCEPTION events when select()'ing [*] on a plain file,
	     * even if EOF was not yet reached. This is a problem in
	     * the following situation:
	     *
	     * - An extension asks to get both READABLE and EXCEPTION
	     *   events.
	     * - It reads data into a buffer smaller than the buffer
	     *   used by Tcl itself.
	     * - It does not process all events in the event queue, but
	     *   only one, at least in some situations.
	     *
	     * In that case we can get into a situation where
	     *
	     * - Tcl drops READABLE here, because it has data in its own
	     *   buffers waiting to be read by the extension.
	     * - A READABLE event is syntesized via timer.
	     * - The OS still reports the EXCEPTION condition on the file.
	     * - And the extension gets the EXCPTION event first, and
	     *   handles this as EOF.
	     *
	     * End result ==> Premature end of reading from a file.
	     *
	     * The concrete example is 'Expect', and its [expect]
	     * command (and at the C-level, deep in the bowels of
	     * Expect, 'exp_get_next_event'. See marker 'SunOS' for
	     * commentary in that function too).
	     *
	     * [*] As the Tcl notifier does. See also for marker
	     * 'SunOS' in file 'exp_event.c' of Expect.
	     *
	     * Our solution here is to drop the interest in the
	     * EXCEPTION events too. This compiles on all platforms,
	     * and also passes the testsuite on all of them.
	     */

	    mask &= ~TCL_EXCEPTION;

	    if (!statePtr->timer) {
		statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
			(ClientData) chanPtr);
	    }
	}
    }
    (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
}

/*
 *----------------------------------------------------------------------
 *
 * ChannelTimerProc --
 *
 *	Timer handler scheduled by UpdateInterest to monitor the
 *	channel buffers until they are empty.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May invoke channel handlers.
 *







|
|
|
<
|

|
<
|
|
|
|




|


|
|



|
|
|
|

|
|

|
|
|


















|
|







7296
7297
7298
7299
7300
7301
7302
7303
7304
7305

7306
7307
7308

7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
		&& (statePtr->inQueueHead->nextRemoved <
			statePtr->inQueueHead->nextAdded)) {
	    mask &= ~TCL_READABLE;

	    /*
	     * Andreas Kupries, April 11, 2003
	     *
	     * Some operating systems (Solaris 2.6 and higher (but not Solaris
	     * 2.5, go figure)) generate READABLE and EXCEPTION events when
	     * select()'ing [*] on a plain file, even if EOF was not yet

	     * reached. This is a problem in the following situation:
	     *
	     * - An extension asks to get both READABLE and EXCEPTION events.

	     * - It reads data into a buffer smaller than the buffer used by
	     *	 Tcl itself.
	     * - It does not process all events in the event queue, but only
	     *	 one, at least in some situations.
	     *
	     * In that case we can get into a situation where
	     *
	     * - Tcl drops READABLE here, because it has data in its own
	     *	 buffers waiting to be read by the extension.
	     * - A READABLE event is syntesized via timer.
	     * - The OS still reports the EXCEPTION condition on the file.
	     * - And the extension gets the EXCPTION event first, and handles
	     *	 this as EOF.
	     *
	     * End result ==> Premature end of reading from a file.
	     *
	     * The concrete example is 'Expect', and its [expect] command
	     * (and at the C-level, deep in the bowels of Expect,
	     * 'exp_get_next_event'. See marker 'SunOS' for commentary in
	     * that function too).
	     *
	     * [*] As the Tcl notifier does. See also for marker 'SunOS' in
	     * file 'exp_event.c' of Expect.
	     *
	     * Our solution here is to drop the interest in the EXCEPTION
	     * events too. This compiles on all platforms, and also passes the
	     * testsuite on all of them.
	     */

	    mask &= ~TCL_EXCEPTION;

	    if (!statePtr->timer) {
		statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
			(ClientData) chanPtr);
	    }
	}
    }
    (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
}

/*
 *----------------------------------------------------------------------
 *
 * ChannelTimerProc --
 *
 *	Timer handler scheduled by UpdateInterest to monitor the channel
 *	buffers until they are empty.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May invoke channel handlers.
 *
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081

7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157

    if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
	    && (statePtr->interestMask & TCL_READABLE)
	    && (statePtr->inQueueHead != (ChannelBuffer *) NULL)
	    && (statePtr->inQueueHead->nextRemoved <
		    statePtr->inQueueHead->nextAdded)) {
	/*
	 * Restart the timer in case a channel handler reenters the
	 * event loop before UpdateInterest gets called by Tcl_NotifyChannel.
	 */

	statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
		(ClientData) chanPtr);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING

	/* Set the TIMER flag to notify the higher levels that the
	 * driver might have no data for us. We do this only if we are
	 * in non-blocking mode and the driver has no BlockModeProc
	 * because only then we really don't know if the driver will
	 * block or not. A similar test is done in "PeekAhead".
	 */

	if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
	    statePtr->flags |= CHANNEL_TIMER_FEV;
	}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	Tcl_Preserve((ClientData) statePtr);
	Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	statePtr->flags &= ~CHANNEL_TIMER_FEV; 
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	Tcl_Release((ClientData) statePtr);
    } else {
	statePtr->timer = NULL;
	UpdateInterest(chanPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannelHandler --
 *
 *	Arrange for a given procedure to be invoked whenever the
 *	channel indicated by the chanPtr arg becomes readable or
 *	writable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	From now on, whenever the I/O channel given by chanPtr becomes
 *	ready in the way indicated by mask, proc will be invoked.
 *	See the manual entry for details on the calling sequence
 *	to proc.  If there is already an event handler for chan, proc
 *	and clientData, then the mask will be updated.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateChannelHandler(chan, mask, proc, clientData)
    Tcl_Channel chan;		/* The channel to create the handler for. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION:
				 * indicates conditions under which
				 * proc should be called. Use 0 to
				 * disable a registered handler. */
    Tcl_ChannelProc *proc;	/* Procedure to call for each
				 * selected event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    ChannelHandler *chPtr;
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */

    /*
     * Check whether this channel handler is not already registered. If
     * it is not, create a new record, else reuse existing record (smash
     * current values).
     */

    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chPtr->nextPtr) {
	if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
		(chPtr->clientData == clientData)) {







|
|






>
|
|
|
|
|












|














|
|
<





|
|
|
|
|








|
|
|
|
|
|







|
|
|







7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421

7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
7461
7462

    if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
	    && (statePtr->interestMask & TCL_READABLE)
	    && (statePtr->inQueueHead != (ChannelBuffer *) NULL)
	    && (statePtr->inQueueHead->nextRemoved <
		    statePtr->inQueueHead->nextAdded)) {
	/*
	 * Restart the timer in case a channel handler reenters the event loop
	 * before UpdateInterest gets called by Tcl_NotifyChannel.
	 */

	statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
		(ClientData) chanPtr);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	/*
	 * Set the TIMER flag to notify the higher levels that the driver
	 * might have no data for us. We do this only if we are in
	 * non-blocking mode and the driver has no BlockModeProc because only
	 * then we really don't know if the driver will block or not. A
	 * similar test is done in "PeekAhead".
	 */

	if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
	    (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
	    statePtr->flags |= CHANNEL_TIMER_FEV;
	}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	Tcl_Preserve((ClientData) statePtr);
	Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	statePtr->flags &= ~CHANNEL_TIMER_FEV;
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	Tcl_Release((ClientData) statePtr);
    } else {
	statePtr->timer = NULL;
	UpdateInterest(chanPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannelHandler --
 *
 *	Arrange for a given procedure to be invoked whenever the channel
 *	indicated by the chanPtr arg becomes readable or writable.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	From now on, whenever the I/O channel given by chanPtr becomes ready
 *	in the way indicated by mask, proc will be invoked. See the manual
 *	entry for details on the calling sequence to proc. If there is already
 *	an event handler for chan, proc and clientData, then the mask will be
 *	updated.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateChannelHandler(chan, mask, proc, clientData)
    Tcl_Channel chan;		/* The channel to create the handler for. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION: indicates
				 * conditions under which proc should be
				 * called. Use 0 to disable a registered
				 * handler. */
    Tcl_ChannelProc *proc;	/* Procedure to call for each selected
				 * event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    ChannelHandler *chPtr;
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */

    /*
     * Check whether this channel handler is not already registered. If it is
     * not, create a new record, else reuse existing record (smash current
     * values).
     */

    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chPtr->nextPtr) {
	if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
		(chPtr->clientData == clientData)) {
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
	chPtr->clientData = clientData;
	chPtr->chanPtr = chanPtr;
	chPtr->nextPtr = statePtr->chPtr;
	statePtr->chPtr = chPtr;
    }

    /*
     * The remainder of the initialization below is done regardless of
     * whether or not this is a new record or a modification of an old
     * one.
     */

    chPtr->mask = mask;

    /*
     * Recompute the interest mask for the channel - this call may actually
     * be disabling an existing handler.
     */

    statePtr->interestMask = 0;
    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chPtr->nextPtr) {
	statePtr->interestMask |= chPtr->mask;
    }

    UpdateInterest(statePtr->topChanPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteChannelHandler --
 *
 *	Cancel a previously arranged callback arrangement for an IO
 *	channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered for this chan, proc and
 *	 clientData , it is removed and the callback will no longer be called
 *	when the channel becomes ready for IO.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteChannelHandler(chan, proc, clientData)
    Tcl_Channel chan;		/* The channel for which to remove the
				 * callback. */
    Tcl_ChannelProc *proc;	/* The procedure in the callback to delete. */
    ClientData clientData;	/* The client data in the callback
				 * to delete. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelHandler *chPtr, *prevChPtr;
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    NextChannelHandler *nhPtr;








|
|
<





|
|

















|
<






|










|
|







7470
7471
7472
7473
7474
7475
7476
7477
7478

7479
7480
7481
7482
7483
7484
7485
7486
7487
7488
7489
7490
7491
7492
7493
7494
7495
7496
7497
7498
7499
7500
7501
7502
7503

7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
7525
7526
7527
7528
7529
	chPtr->clientData = clientData;
	chPtr->chanPtr = chanPtr;
	chPtr->nextPtr = statePtr->chPtr;
	statePtr->chPtr = chPtr;
    }

    /*
     * The remainder of the initialization below is done regardless of whether
     * or not this is a new record or a modification of an old one.

     */

    chPtr->mask = mask;

    /*
     * Recompute the interest mask for the channel - this call may actually be
     * disabling an existing handler.
     */

    statePtr->interestMask = 0;
    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chPtr->nextPtr) {
	statePtr->interestMask |= chPtr->mask;
    }

    UpdateInterest(statePtr->topChanPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteChannelHandler --
 *
 *	Cancel a previously arranged callback arrangement for an IO channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered for this chan, proc and
 *	clientData, it is removed and the callback will no longer be called
 *	when the channel becomes ready for IO.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteChannelHandler(chan, proc, clientData)
    Tcl_Channel chan;		/* The channel for which to remove the
				 * callback. */
    Tcl_ChannelProc *proc;	/* The procedure in the callback to delete. */
    ClientData clientData;	/* The client data in the callback to
				 * delete. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ChannelHandler *chPtr, *prevChPtr;
    Channel *chanPtr = (Channel *) chan;
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    NextChannelHandler *nhPtr;

7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
    } else {
	prevChPtr->nextPtr = chPtr->nextPtr;
    }
    ckfree((char *) chPtr);

    /*
     * Recompute the interest list for the channel, so that infinite loops
     * will not result if Tcl_DeleteChannelHandler is called inside an
     * event.
     */

    statePtr->interestMask = 0;
    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chPtr->nextPtr) {
	statePtr->interestMask |= chPtr->mask;
    }

    UpdateInterest(statePtr->topChanPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteScriptRecord --
 *
 *	Delete a script record for this combination of channel, interp
 *	and mask.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes a script record and cancels a channel event handler.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScriptRecord(interp, chanPtr, mask)
    Tcl_Interp *interp;		/* Interpreter in which script was to be
				 * executed. */
    Channel *chanPtr;		/* The channel for which to delete the
				 * script record (if any). */
    int mask;			/* Events in mask must exactly match mask
				 * of script to delete. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    EventScriptRecord *esPtr, *prevEsPtr;

    for (esPtr = statePtr->scriptRecordPtr,
	    prevEsPtr = (EventScriptRecord *) NULL;
	    esPtr != (EventScriptRecord *) NULL;







|
<

















|
|














|
|
|
|







7571
7572
7573
7574
7575
7576
7577
7578

7579
7580
7581
7582
7583
7584
7585
7586
7587
7588
7589
7590
7591
7592
7593
7594
7595
7596
7597
7598
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
    } else {
	prevChPtr->nextPtr = chPtr->nextPtr;
    }
    ckfree((char *) chPtr);

    /*
     * Recompute the interest list for the channel, so that infinite loops
     * will not result if Tcl_DeleteChannelHandler is called inside an event.

     */

    statePtr->interestMask = 0;
    for (chPtr = statePtr->chPtr;
	    chPtr != (ChannelHandler *) NULL;
	    chPtr = chPtr->nextPtr) {
	statePtr->interestMask |= chPtr->mask;
    }

    UpdateInterest(statePtr->topChanPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteScriptRecord --
 *
 *	Delete a script record for this combination of channel, interp and
 *	mask.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes a script record and cancels a channel event handler.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScriptRecord(interp, chanPtr, mask)
    Tcl_Interp *interp;		/* Interpreter in which script was to be
				 * executed. */
    Channel *chanPtr;		/* The channel for which to delete the script
				 * record (if any). */
    int mask;			/* Events in mask must exactly match mask of
				 * script to delete. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    EventScriptRecord *esPtr, *prevEsPtr;

    for (esPtr = statePtr->scriptRecordPtr,
	    prevEsPtr = (EventScriptRecord *) NULL;
	    esPtr != (EventScriptRecord *) NULL;
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
 *	Causes the script to be stored for later execution.
 *
 *----------------------------------------------------------------------
 */

static void
CreateScriptRecord(interp, chanPtr, mask, scriptPtr)
    Tcl_Interp *interp;			/* Interpreter in which to execute
					 * the stored script. */
    Channel *chanPtr;			/* Channel for which script is to
					 * be stored. */
    int mask;				/* Set of events for which script
					 * will be invoked. */
    Tcl_Obj *scriptPtr;			/* Pointer to script object. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    EventScriptRecord *esPtr;

    for (esPtr = statePtr->scriptRecordPtr;
	    esPtr != (EventScriptRecord *) NULL;







|
|
|
|
|
|







7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
7668
7669
7670
7671
7672
7673
 *	Causes the script to be stored for later execution.
 *
 *----------------------------------------------------------------------
 */

static void
CreateScriptRecord(interp, chanPtr, mask, scriptPtr)
    Tcl_Interp *interp;			/* Interpreter in which to execute the
					 * stored script. */
    Channel *chanPtr;			/* Channel for which script is to be
					 * stored. */
    int mask;				/* Set of events for which script will
					 * be invoked. */
    Tcl_Obj *scriptPtr;			/* Pointer to script object. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    EventScriptRecord *esPtr;

    for (esPtr = statePtr->scriptRecordPtr;
	    esPtr != (EventScriptRecord *) NULL;
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
}

/*
 *----------------------------------------------------------------------
 *
 * TclChannelEventScriptInvoker --
 *
 *	Invokes a script scheduled by "fileevent" for when the channel
 *	becomes ready for IO. This function is invoked by the channel
 *	handler which was created by the Tcl "fileevent" command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the script does.
 *







|
|
|







7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
}

/*
 *----------------------------------------------------------------------
 *
 * TclChannelEventScriptInvoker --
 *
 *	Invokes a script scheduled by "fileevent" for when the channel becomes
 *	ready for IO. This function is invoked by the channel handler which
 *	was created by the Tcl "fileevent" command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the script does.
 *
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
7461
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476
7477
7478
7479
7480
7481
7482
7483
7484
7485
7486
7487
7488
7489
7490
7491
7492

    esPtr	= (EventScriptRecord *) clientData;
    chanPtr	= esPtr->chanPtr;
    mask	= esPtr->mask;
    interp	= esPtr->interp;

    /*
     * We must preserve the interpreter so we can report errors on it
     * later.  Note that we do not need to preserve the channel because
     * that is done by Tcl_NotifyChannel before calling channel handlers.
     */

    Tcl_Preserve((ClientData) interp);
    result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);

    /*
     * On error, cause a background error and remove the channel handler
     * and the script record.
     *
     * NOTE: Must delete channel handler before causing the background error
     * because the background error may want to reinstall the handler.
     */

    if (result != TCL_OK) {
	if (chanPtr->typePtr != NULL) {
	    DeleteScriptRecord(interp, chanPtr, mask);
	}
	Tcl_BackgroundError(interp);
    }
    Tcl_Release((ClientData) interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FileEventObjCmd --
 *
 *	This procedure implements the "fileevent" Tcl command. See the
 *	user documentation for details on what it does. This command is
 *	based on the Tk command "fileevent" which in turn is based on work
 *	contributed by Mark Diekhans.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May create a channel handler for the specified channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FileEventObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Interpreter in which the channel
					 * for which to create the handler
					 * is found. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Channel *chanPtr;			/* The channel to create
					 * the handler for. */
    ChannelState *statePtr;		/* state info for channel */
    Tcl_Channel chan;			/* The opaque type for the channel. */
    char *chanName;
    int modeIndex;			/* Index of mode argument. */
    int mask;
    static CONST char *modeOptions[] = {"readable", "writable", NULL};
    static int maskArray[] = {TCL_READABLE, TCL_WRITABLE};







|
|
|






|
|



















|
|
|
|















|
|



|
|







7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794

    esPtr	= (EventScriptRecord *) clientData;
    chanPtr	= esPtr->chanPtr;
    mask	= esPtr->mask;
    interp	= esPtr->interp;

    /*
     * We must preserve the interpreter so we can report errors on it later.
     * Note that we do not need to preserve the channel because that is done
     * by Tcl_NotifyChannel before calling channel handlers.
     */

    Tcl_Preserve((ClientData) interp);
    result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);

    /*
     * On error, cause a background error and remove the channel handler and
     * the script record.
     *
     * NOTE: Must delete channel handler before causing the background error
     * because the background error may want to reinstall the handler.
     */

    if (result != TCL_OK) {
	if (chanPtr->typePtr != NULL) {
	    DeleteScriptRecord(interp, chanPtr, mask);
	}
	Tcl_BackgroundError(interp);
    }
    Tcl_Release((ClientData) interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FileEventObjCmd --
 *
 *	This procedure implements the "fileevent" Tcl command. See the user
 *	documentation for details on what it does. This command is based on
 *	the Tk command "fileevent" which in turn is based on work contributed
 *	by Mark Diekhans.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May create a channel handler for the specified channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FileEventObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Interpreter in which the channel
					 * for which to create the handler is
					 * found. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Channel *chanPtr;			/* The channel to create the handler
					 * for. */
    ChannelState *statePtr;		/* state info for channel */
    Tcl_Channel chan;			/* The opaque type for the channel. */
    char *chanName;
    int modeIndex;			/* Index of mode argument. */
    int mask;
    static CONST char *modeOptions[] = {"readable", "writable", NULL};
    static int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
7538
7539
7540
7541
7542
7543
7544
7545
7546
7547
7548
7549
7550
7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
7562
7563
7564
7565
7566
7567
7568
7569
7570
7571
7572
7573
7574
7575
7576
7577
7578

    if (*(Tcl_GetString(objv[3])) == '\0') {
	DeleteScriptRecord(interp, chanPtr, mask);
	return TCL_OK;
    }

    /*
     * Make the script record that will link between the event and the
     * script to invoke. This also creates a channel event handler which
     * will evaluate the script in the supplied interpreter.
     */

    CreateScriptRecord(interp, chanPtr, mask, objv[3]);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCopyChannel --
 *
 *	This routine copies data from one channel to another, either
 *	synchronously or asynchronously.  If a command script is
 *	supplied, the operation runs in the background.  The script
 *	is invoked when the copy completes.  Otherwise the function
 *	waits until the copy is completed before returning.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May schedule a background copy operation that causes both
 *	channels to be marked busy.
 *
 *----------------------------------------------------------------------
 */

int
TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
    Tcl_Interp *interp;		/* Current interpreter. */







|
|
|













|
|
|
|





|
|







7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880

    if (*(Tcl_GetString(objv[3])) == '\0') {
	DeleteScriptRecord(interp, chanPtr, mask);
	return TCL_OK;
    }

    /*
     * Make the script record that will link between the event and the script
     * to invoke. This also creates a channel event handler which will
     * evaluate the script in the supplied interpreter.
     */

    CreateScriptRecord(interp, chanPtr, mask, objv[3]);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCopyChannel --
 *
 *	This routine copies data from one channel to another, either
 *	synchronously or asynchronously.  If a command script is supplied, the
 *	operation runs in the background.  The script is invoked when the copy
 *	completes.  Otherwise the function waits until the copy is completed
 *	before returning.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May schedule a background copy operation that causes both channels to
 *	be marked busy.
 *
 *----------------------------------------------------------------------
 */

int
TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627
    }

    readFlags = inStatePtr->flags;
    writeFlags = outStatePtr->flags;

    /*
     * Set up the blocking mode appropriately.  Background copies need
     * non-blocking channels.  Foreground copies need blocking channels.
     * If there is an error, restore the old blocking mode.
     */

    if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
	if (SetBlockMode(interp, inPtr,
		nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
    }	    
    if (inPtr != outPtr) {
	if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) {
	    if (SetBlockMode(NULL, outPtr,
		    nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
		    != TCL_OK) {
		if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
		    SetBlockMode(NULL, inPtr,







|
|








|







7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
    }

    readFlags = inStatePtr->flags;
    writeFlags = outStatePtr->flags;

    /*
     * Set up the blocking mode appropriately.  Background copies need
     * non-blocking channels.  Foreground copies need blocking channels.  If
     * there is an error, restore the old blocking mode.
     */

    if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
	if (SetBlockMode(interp, inPtr,
		nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
    }
    if (inPtr != outPtr) {
	if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) {
	    if (SetBlockMode(NULL, outPtr,
		    nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
		    != TCL_OK) {
		if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
		    SetBlockMode(NULL, inPtr,
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695

7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732

7733
7734
7735
7736
7737

7738
7739
7740
7741
7742
7743
7744
7745
}

/*
 *----------------------------------------------------------------------
 *
 * CopyData --
 *
 *	This function implements the lowest level of the copying
 *	mechanism for TclCopyChannel.
 *
 * Results:
 *	Returns TCL_OK on success, else TCL_ERROR.
 *
 * Side effects:
 *	Moves data between channels, may create channel handlers.
 *
 *----------------------------------------------------------------------
 */

static int
CopyData(csPtr, mask)
    CopyState *csPtr;		/* State of copy operation. */
    int mask;			/* Current channel event flags. */
{
    Tcl_Interp *interp;
    Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL;

    Tcl_Channel inChan, outChan;
    ChannelState *inStatePtr, *outStatePtr;
    int result = TCL_OK, size, total, sizeb;
    char *buffer;

    int inBinary, outBinary, sameEncoding; /* Encoding control */
    int underflow;	/* input underflow */

    inChan	= (Tcl_Channel) csPtr->readPtr;
    outChan	= (Tcl_Channel) csPtr->writePtr;
    inStatePtr	= csPtr->readPtr->state;
    outStatePtr	= csPtr->writePtr->state;
    interp	= csPtr->interp;
    cmdPtr	= csPtr->cmdPtr;

    /*
     * Copy the data the slow way, using the translation mechanism.
     *
     * Note: We have make sure that we use the topmost channel in a stack
     * for the copying. The caller uses Tcl_GetChannel to access it, and
     * thus gets the bottom of the stack.
     */

    inBinary = (inStatePtr->encoding == NULL);
    outBinary = (outStatePtr->encoding == NULL);
    sameEncoding = (inStatePtr->encoding == outStatePtr->encoding);

    if (!(inBinary || sameEncoding)) {
	TclNewObj(bufObj);
	Tcl_IncrRefCount(bufObj);
    }

    while (csPtr->toRead != 0) {
	/*
	 * Check for unreported background errors.
	 */


	if (inStatePtr->unreportedError != 0) {
	    Tcl_SetErrno(inStatePtr->unreportedError);
	    inStatePtr->unreportedError = 0;
	    goto readError;
	}

	if (outStatePtr->unreportedError != 0) {
	    Tcl_SetErrno(outStatePtr->unreportedError);
	    outStatePtr->unreportedError = 0;
	    goto writeError;
	}

	/*
	 * Read up to bufSize bytes.







|
|

















>






|











|
|
|
















>
|




>
|







7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
7984
7985
7986
7987
7988
7989
7990
7991
7992
7993
7994
7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
}

/*
 *----------------------------------------------------------------------
 *
 * CopyData --
 *
 *	This function implements the lowest level of the copying mechanism for
 *	TclCopyChannel.
 *
 * Results:
 *	Returns TCL_OK on success, else TCL_ERROR.
 *
 * Side effects:
 *	Moves data between channels, may create channel handlers.
 *
 *----------------------------------------------------------------------
 */

static int
CopyData(csPtr, mask)
    CopyState *csPtr;		/* State of copy operation. */
    int mask;			/* Current channel event flags. */
{
    Tcl_Interp *interp;
    Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL;
    Tcl_Obj* msg = NULL;
    Tcl_Channel inChan, outChan;
    ChannelState *inStatePtr, *outStatePtr;
    int result = TCL_OK, size, total, sizeb;
    char *buffer;

    int inBinary, outBinary, sameEncoding; /* Encoding control */
    int underflow;		/* input underflow */

    inChan	= (Tcl_Channel) csPtr->readPtr;
    outChan	= (Tcl_Channel) csPtr->writePtr;
    inStatePtr	= csPtr->readPtr->state;
    outStatePtr	= csPtr->writePtr->state;
    interp	= csPtr->interp;
    cmdPtr	= csPtr->cmdPtr;

    /*
     * Copy the data the slow way, using the translation mechanism.
     *
     * Note: We have make sure that we use the topmost channel in a stack for
     * the copying. The caller uses Tcl_GetChannel to access it, and thus gets
     * the bottom of the stack.
     */

    inBinary = (inStatePtr->encoding == NULL);
    outBinary = (outStatePtr->encoding == NULL);
    sameEncoding = (inStatePtr->encoding == outStatePtr->encoding);

    if (!(inBinary || sameEncoding)) {
	TclNewObj(bufObj);
	Tcl_IncrRefCount(bufObj);
    }

    while (csPtr->toRead != 0) {
	/*
	 * Check for unreported background errors.
	 */

        Tcl_GetChannelError (inChan, &msg);
	if ((inStatePtr->unreportedError != 0) || (msg != NULL)) {
	    Tcl_SetErrno(inStatePtr->unreportedError);
	    inStatePtr->unreportedError = 0;
	    goto readError;
	}
        Tcl_GetChannelError (outChan, &msg);
	if ((outStatePtr->unreportedError != 0) || (msg != NULL)) {
	    Tcl_SetErrno(outStatePtr->unreportedError);
	    outStatePtr->unreportedError = 0;
	    goto writeError;
	}

	/*
	 * Read up to bufSize bytes.
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765





7766


7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
	    size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
	} else {
	    size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */);
	}
	underflow = (size >= 0) && (size < sizeb);	/* input underflow */

	if (size < 0) {
	    readError:
	    TclNewObj(errObj);
	    Tcl_AppendStringsToObj(errObj, "error reading \"",
		    Tcl_GetChannelName(inChan), "\": ",





		    Tcl_PosixError(interp), (char *) NULL);


	    break;
	} else if (underflow) {
	    /*
	     * We had an underflow on the read side.  If we are at EOF,
	     * then the copying is done, otherwise set up a channel
	     * handler to detect when the channel becomes readable again.
	     */

	    if ((size == 0) && Tcl_Eof(inChan)) {
		break;
	    }
	    if (! Tcl_Eof(inChan) && !(mask & TCL_READABLE)) {
		if (mask & TCL_WRITABLE) {







|


|
>
>
>
>
>
|
>
>



|
|
|







8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
	    size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
	} else {
	    size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */);
	}
	underflow = (size >= 0) && (size < sizeb);	/* input underflow */

	if (size < 0) {
	readError:
	    TclNewObj(errObj);
	    Tcl_AppendStringsToObj(errObj, "error reading \"",
				   Tcl_GetChannelName(inChan), "\": ",
				   (char *) NULL);
	    if (msg != NULL) {
	        Tcl_AppendObjToObj(errObj,msg);
	    } else {
	        Tcl_AppendStringsToObj(errObj,
		       Tcl_PosixError(interp),
		       (char *) NULL);
	    }
	    break;
	} else if (underflow) {
	    /*
	     * We had an underflow on the read side.  If we are at EOF, then
	     * the copying is done, otherwise set up a channel handler to
	     * detect when the channel becomes readable again.
	     */

	    if ((size == 0) && Tcl_Eof(inChan)) {
		break;
	    }
	    if (! Tcl_Eof(inChan) && !(mask & TCL_READABLE)) {
		if (mask & TCL_WRITABLE) {
7811
7812
7813
7814
7815
7816
7817
7818
7819
7820
7821





7822


7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837

	if (inBinary || sameEncoding) {
	    /* Both read and write counted bytes */
	    size = sizeb;
	} /* else : Read counted characters, write counted bytes, i.e. size != sizeb */

	if (sizeb < 0) {
	    writeError:
	    TclNewObj(errObj);
	    Tcl_AppendStringsToObj(errObj, "error writing \"",
		    Tcl_GetChannelName(outChan), "\": ",





		    Tcl_PosixError(interp), (char *) NULL);


	    break;
	}

	/*
	 * Update the current byte count.  Do it now so the count is
	 * valid before a return or break takes us out of the loop.
	 * The invariant at the top of the loop should be that 
	 * csPtr->toRead holds the number of bytes left to copy.
	 */

	if (csPtr->toRead != -1) {
	    csPtr->toRead -= size;
	}
	csPtr->total += size;








|


|
>
>
>
>
>
|
>
>




|
|
|
|







8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156

	if (inBinary || sameEncoding) {
	    /* Both read and write counted bytes */
	    size = sizeb;
	} /* else : Read counted characters, write counted bytes, i.e. size != sizeb */

	if (sizeb < 0) {
	writeError:
	    TclNewObj(errObj);
	    Tcl_AppendStringsToObj(errObj, "error writing \"",
				   Tcl_GetChannelName(outChan), "\": ",
				   (char *) NULL);
	    if (msg != NULL) {
	        Tcl_AppendObjToObj(errObj,msg);
	    } else {
	        Tcl_AppendStringsToObj(errObj,
		       Tcl_PosixError(interp),
		       (char *) NULL);
	    }
	    break;
	}

	/*
	 * Update the current byte count. Do it now so the count is valid
	 * before a return or break takes us out of the loop. The invariant at
	 * the top of the loop should be that csPtr->toRead holds the number
	 * of bytes left to copy.
	 */

	if (csPtr->toRead != -1) {
	    csPtr->toRead -= size;
	}
	csPtr->total += size;

7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880
7881
7882
7883
7884
7885
7886
7887
7888
7889
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
		TclDecrRefCount(bufObj);
		bufObj = (Tcl_Obj *) NULL;
	    }
	    return TCL_OK;
	}

	/*
	 * For background copies, we only do one buffer per invocation so
	 * we don't starve the rest of the system.
	 */

	if (cmdPtr) {
	    /*
	     * The first time we enter this code, there won't be a
	     * channel handler established yet, so do it here.
	     */

	    if (mask == 0) {
		Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
			CopyEventProc, (ClientData) csPtr);
	    }
	    if (bufObj != (Tcl_Obj *) NULL) {
		TclDecrRefCount(bufObj);
		bufObj = (Tcl_Obj *) NULL;
	    }
	    return TCL_OK;
	}
    } /* while */

    if (bufObj != (Tcl_Obj *) NULL) {
	TclDecrRefCount(bufObj);
	bufObj = (Tcl_Obj *) NULL;
    }

    /*
     * Make the callback or return the number of bytes transferred.
     * The local total is used because StopCopy frees csPtr.
     */

    total = csPtr->total;
    if (cmdPtr) {
	/*
	 * Get a private copy of the command so we can mutate it
	 * by adding arguments.  Note that StopCopy frees our saved
	 * reference to the original command obj.
	 */

	cmdPtr = Tcl_DuplicateObj(cmdPtr);
	Tcl_IncrRefCount(cmdPtr);
	StopCopy(csPtr);
	Tcl_Preserve((ClientData) interp);








|
|




|
|




















|
|





|
|
|







8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
		TclDecrRefCount(bufObj);
		bufObj = (Tcl_Obj *) NULL;
	    }
	    return TCL_OK;
	}

	/*
	 * For background copies, we only do one buffer per invocation so we
	 * don't starve the rest of the system.
	 */

	if (cmdPtr) {
	    /*
	     * The first time we enter this code, there won't be a channel
	     * handler established yet, so do it here.
	     */

	    if (mask == 0) {
		Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
			CopyEventProc, (ClientData) csPtr);
	    }
	    if (bufObj != (Tcl_Obj *) NULL) {
		TclDecrRefCount(bufObj);
		bufObj = (Tcl_Obj *) NULL;
	    }
	    return TCL_OK;
	}
    } /* while */

    if (bufObj != (Tcl_Obj *) NULL) {
	TclDecrRefCount(bufObj);
	bufObj = (Tcl_Obj *) NULL;
    }

    /*
     * Make the callback or return the number of bytes transferred. The local
     * total is used because StopCopy frees csPtr.
     */

    total = csPtr->total;
    if (cmdPtr) {
	/*
	 * Get a private copy of the command so we can mutate it by adding
	 * arguments.  Note that StopCopy frees our saved reference to the
	 * original command obj.
	 */

	cmdPtr = Tcl_DuplicateObj(cmdPtr);
	Tcl_IncrRefCount(cmdPtr);
	StopCopy(csPtr);
	Tcl_Preserve((ClientData) interp);

7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
 * DoRead --
 *
 *	Reads a given number of bytes from a channel.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno()
 *	to retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

static int
DoRead(chanPtr, bufPtr, toRead)
    Channel *chanPtr;		/* The channel from which to read. */
    char *bufPtr;		/* Where to store input read. */
    int toRead;			/* Maximum number of bytes to read. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int copied;			/* How many characters were copied into
				 * the result string? */
    int copiedNow;		/* How many characters were copied from
				 * the current input buffer? */
    int result;			/* Of calling GetInput. */

    /*
     * If we have not encountered a sticky EOF, clear the EOF bit. Either
     * way clear the BLOCKED bit. We want to discover these anew during
     * each operation.
     */

    if (!(statePtr->flags & CHANNEL_STICKY_EOF)) {
	statePtr->flags &= ~CHANNEL_EOF;
    }
    statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);








|
|














|
|
|
|



|
|
|







8260
8261
8262
8263
8264
8265
8266
8267
8268
8269
8270
8271
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298
8299
 * DoRead --
 *
 *	Reads a given number of bytes from a channel.
 *
 *	No encoding conversions are applied to the bytes being read.
 *
 * Results:
 *	The number of characters read, or -1 on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *----------------------------------------------------------------------
 */

static int
DoRead(chanPtr, bufPtr, toRead)
    Channel *chanPtr;		/* The channel from which to read. */
    char *bufPtr;		/* Where to store input read. */
    int toRead;			/* Maximum number of bytes to read. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int copied;			/* How many characters were copied into the
				 * result string? */
    int copiedNow;		/* How many characters were copied from the
				 * current input buffer? */
    int result;			/* Of calling GetInput. */

    /*
     * If we have not encountered a sticky EOF, clear the EOF bit. Either way
     * clear the BLOCKED bit. We want to discover these anew during each
     * operation.
     */

    if (!(statePtr->flags & CHANNEL_STICKY_EOF)) {
	statePtr->flags &= ~CHANNEL_EOF;
    }
    statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);

7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
8010
8011

8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
8117
8118
8119
8120
8121
8122
8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164
8165
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
		goto done;
	    }
	}
    }

    statePtr->flags &= (~(CHANNEL_BLOCKED));

    done:
    /*
     * Update the notifier state so we don't block while there is still
     * data in the buffers.
     */


    UpdateInterest(chanPtr);
    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyAndTranslateBuffer --
 *
 *	Copy at most one buffer of input to the result space, doing
 *	eol translations according to mode in effect currently.
 *
 * Results:
 *	Number of bytes stored in the result buffer (as opposed to the
 *	number of bytes read from the channel).  May return
 *	zero if no input is available to be translated.
 *
 * Side effects:
 *	Consumes buffered input. May deallocate one buffer.
 *
 *----------------------------------------------------------------------
 */

static int
CopyAndTranslateBuffer(statePtr, result, space)
    ChannelState *statePtr;	/* Channel state from which to read input. */
    char *result;		/* Where to store the copied input. */
    int space;			/* How many bytes are available in result
				 * to store the copied input? */
{
    ChannelBuffer *bufPtr;	/* The buffer from which to copy bytes. */
    int bytesInBuffer;		/* How many bytes are available to be
				 * copied in the current input buffer? */
    int copied;			/* How many characters were already copied
				 * into the destination space? */
    int i;			/* Iterates over the copied input looking
				 * for the input eofChar. */

    /*
     * If there is no input at all, return zero. The invariant is that either
     * there is no buffer in the queue, or if the first buffer is empty, it
     * is also the last buffer (and thus there is no input in the queue).
     * Note also that if the buffer is empty, we leave it in the queue.
     */

    if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
	return 0;
    }
    bufPtr = statePtr->inQueueHead;
    bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;

    copied = 0;
    switch (statePtr->inputTranslation) {
	case TCL_TRANSLATE_LF: {
	    if (bytesInBuffer == 0) {
		return 0;
	    }

	    /*
	     * Copy the current chunk into the result buffer.
	     */

	    if (bytesInBuffer < space) {
		space = bytesInBuffer;
	    }
	    memcpy((VOID *) result,
		    (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		    (size_t) space);
	    bufPtr->nextRemoved += space;
	    copied = space;
	    break;
	}
	case TCL_TRANSLATE_CR: {
	    char *end;

	    if (bytesInBuffer == 0) {
		return 0;
	    }

	    /*
	     * Copy the current chunk into the result buffer, then
	     * replace all \r with \n.
	     */

	    if (bytesInBuffer < space) {
		space = bytesInBuffer;
	    }
	    memcpy((VOID *) result,
		    (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		    (size_t) space);
	    bufPtr->nextRemoved += space;
	    copied = space;

	    for (end = result + copied; result < end; result++) {
		if (*result == '\r') {
		    *result = '\n';
		}
	    }
	    break;
	}
	case TCL_TRANSLATE_CRLF: {
	    char *src, *end, *dst;
	    int curByte;

	    /*
	     * If there is a held-back "\r" at EOF, produce it now.
	     */

	    if (bytesInBuffer == 0) {
		if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) ==
			(INPUT_SAW_CR | CHANNEL_EOF)) {
		    result[0] = '\r';
		    statePtr->flags &= ~INPUT_SAW_CR;
		    return 1;
		}
		return 0;
	    }

	    /*
	     * Copy the current chunk and replace "\r\n" with "\n"
	     * (but not standalone "\r"!).
	     */

	    if (bytesInBuffer < space) {
		space = bytesInBuffer;
	    }
	    memcpy((VOID *) result,
		    (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		    (size_t) space);
	    bufPtr->nextRemoved += space;
	    copied = space;

	    end = result + copied;
	    dst = result;
	    for (src = result; src < end; src++) {
		curByte = *src;
		if (curByte == '\n') {
		    statePtr->flags &= ~INPUT_SAW_CR;
		} else if (statePtr->flags & INPUT_SAW_CR) {
		    statePtr->flags &= ~INPUT_SAW_CR;
		    *dst = '\r';
		    dst++;
		}
		if (curByte == '\r') {
		    statePtr->flags |= INPUT_SAW_CR;
		} else {
		    *dst = (char) curByte;
		    dst++;
		}
	    }
	    copied = dst - result;
	    break;
	}
	case TCL_TRANSLATE_AUTO: {
	    char *src, *end, *dst;
	    int curByte;

	    if (bytesInBuffer == 0) {
		return 0;
	    }

	    /*
	     * Loop over the current buffer, converting "\r" and "\r\n"
	     * to "\n".
	     */

	    if (bytesInBuffer < space) {
		space = bytesInBuffer;
	    }
	    memcpy((VOID *) result,
		    (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		    (size_t) space);
	    bufPtr->nextRemoved += space;
	    copied = space;

	    end = result + copied;
	    dst = result;
	    for (src = result; src < end; src++) {
		curByte = *src;
		if (curByte == '\r') {
		    statePtr->flags |= INPUT_SAW_CR;
		    *dst = '\n';
		    dst++;
		} else {
		    if ((curByte != '\n') || 
			    !(statePtr->flags & INPUT_SAW_CR)) {
			*dst = (char) curByte;
			dst++;
		    }
		    statePtr->flags &= ~INPUT_SAW_CR;
		}
	    }
	    copied = dst - result;
	    break;
	}
	default: {
	    Tcl_Panic("unknown eol translation mode");
	}
    }

    /*
     * If an in-stream EOF character is set for this channel, check that
     * the input we copied so far does not contain the EOF char.  If it does,
     * copy only up to and excluding that character.
     */

    if (statePtr->inEofChar != 0) {
	for (i = 0; i < copied; i++) {
	    if (result[i] == (char) statePtr->inEofChar) {
		/*
		 * Set sticky EOF so that no further input is presented
		 * to the caller.
		 */

		statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
		statePtr->inputEncodingFlags |= TCL_ENCODING_END;
		copied = i;
		break;
	    }







<

|
|


>









|
|


|
|
|











|
|


|
|


|
|



|
|
|










|
|
|
|

|
|
|

|
|
|
<
|
|
|
|
|
<
|
|

|
|
|

|
|
|
|

|
|
|
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
<
|

|
|
|
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
<

|
|
|






|
|







8318
8319
8320
8321
8322
8323
8324

8325
8326
8327
8328
8329
8330
8331
8332
8333
8334
8335
8336
8337
8338
8339
8340
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395

8396
8397
8398
8399
8400

8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415

8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453

8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489

8490
8491
8492
8493
8494

8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509

8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522

8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
		goto done;
	    }
	}
    }

    statePtr->flags &= (~(CHANNEL_BLOCKED));


    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyAndTranslateBuffer --
 *
 *	Copy at most one buffer of input to the result space, doing eol
 *	translations according to mode in effect currently.
 *
 * Results:
 *	Number of bytes stored in the result buffer (as opposed to the number
 *	of bytes read from the channel). May return zero if no input is
 *	available to be translated.
 *
 * Side effects:
 *	Consumes buffered input. May deallocate one buffer.
 *
 *----------------------------------------------------------------------
 */

static int
CopyAndTranslateBuffer(statePtr, result, space)
    ChannelState *statePtr;	/* Channel state from which to read input. */
    char *result;		/* Where to store the copied input. */
    int space;			/* How many bytes are available in result to
				 * store the copied input? */
{
    ChannelBuffer *bufPtr;	/* The buffer from which to copy bytes. */
    int bytesInBuffer;		/* How many bytes are available to be copied
				 * in the current input buffer? */
    int copied;			/* How many characters were already copied
				 * into the destination space? */
    int i;			/* Iterates over the copied input looking for
				 * the input eofChar. */

    /*
     * If there is no input at all, return zero. The invariant is that either
     * there is no buffer in the queue, or if the first buffer is empty, it is
     * also the last buffer (and thus there is no input in the queue). Note
     * also that if the buffer is empty, we leave it in the queue.
     */

    if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
	return 0;
    }
    bufPtr = statePtr->inQueueHead;
    bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;

    copied = 0;
    switch (statePtr->inputTranslation) {
    case TCL_TRANSLATE_LF:
	if (bytesInBuffer == 0) {
	    return 0;
	}

	/*
	 * Copy the current chunk into the result buffer.
	 */

	if (bytesInBuffer < space) {
	    space = bytesInBuffer;
	}

	memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		(size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;
	break;

    case TCL_TRANSLATE_CR: {
	char *end;

	if (bytesInBuffer == 0) {
	    return 0;
	}

	/*
	 * Copy the current chunk into the result buffer, then replace all \r
	 * with \n.
	 */

	if (bytesInBuffer < space) {
	    space = bytesInBuffer;
	}

	memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		(size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;

	for (end = result + copied; result < end; result++) {
	    if (*result == '\r') {
		*result = '\n';
	    }
	}
	break;
    }
    case TCL_TRANSLATE_CRLF: {
	char *src, *end, *dst;
	int curByte;

	/*
	 * If there is a held-back "\r" at EOF, produce it now.
	 */

	if (bytesInBuffer == 0) {
	    if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) ==
		    (INPUT_SAW_CR | CHANNEL_EOF)) {
		result[0] = '\r';
		statePtr->flags &= ~INPUT_SAW_CR;
		return 1;
	    }
	    return 0;
	}

	/*
	 * Copy the current chunk and replace "\r\n" with "\n"
	 * (but not standalone "\r"!).
	 */

	if (bytesInBuffer < space) {
	    space = bytesInBuffer;
	}

	memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		(size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;

	end = result + copied;
	dst = result;
	for (src = result; src < end; src++) {
	    curByte = *src;
	    if (curByte == '\n') {
		statePtr->flags &= ~INPUT_SAW_CR;
	    } else if (statePtr->flags & INPUT_SAW_CR) {
		statePtr->flags &= ~INPUT_SAW_CR;
		*dst = '\r';
		dst++;
	    }
	    if (curByte == '\r') {
		statePtr->flags |= INPUT_SAW_CR;
	    } else {
		*dst = (char) curByte;
		dst++;
	    }
	}
	copied = dst - result;
	break;
    }
    case TCL_TRANSLATE_AUTO: {
	char *src, *end, *dst;
	int curByte;

	if (bytesInBuffer == 0) {
	    return 0;
	}

	/*
	 * Loop over the current buffer, converting "\r" and "\r\n" to "\n".

	 */

	if (bytesInBuffer < space) {
	    space = bytesInBuffer;
	}

	memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
		(size_t) space);
	bufPtr->nextRemoved += space;
	copied = space;

	end = result + copied;
	dst = result;
	for (src = result; src < end; src++) {
	    curByte = *src;
	    if (curByte == '\r') {
		statePtr->flags |= INPUT_SAW_CR;
		*dst = '\n';
		dst++;
	    } else {
		if ((curByte != '\n') || !(statePtr->flags & INPUT_SAW_CR)) {

		    *dst = (char) curByte;
		    dst++;
		}
		statePtr->flags &= ~INPUT_SAW_CR;
	    }
	}
	copied = dst - result;
	break;
    }
    default:
	Tcl_Panic("unknown eol translation mode");
    }


    /*
     * If an in-stream EOF character is set for this channel, check that the
     * input we copied so far does not contain the EOF char. If it does, copy
     * only up to and excluding that character.
     */

    if (statePtr->inEofChar != 0) {
	for (i = 0; i < copied; i++) {
	    if (result[i] == (char) statePtr->inEofChar) {
		/*
		 * Set sticky EOF so that no further input is presented to the
		 * caller.
		 */

		statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
		statePtr->inputEncodingFlags |= TCL_ENCODING_END;
		copied = i;
		break;
	    }
8240
8241
8242
8243
8244
8245
8246
8247
8248
8249
8250
8251
8252
8253
8254
8255
8256
8257
8258
8259
8260
8261
8262
8263
8264
8265
8266
8267
8268
8269
8270
8271
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
	if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
	    statePtr->inQueueTail = (ChannelBuffer *) NULL;
	}
	RecycleBuffer(statePtr, bufPtr, 0);
    }

    /*
     * Return the number of characters copied into the result buffer.
     * This may be different from the number of bytes consumed, because
     * of EOL translations.
     */

    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyBuffer --
 *
 *	Copy at most one buffer of input to the result space.
 *
 * Results:
 *	Number of bytes stored in the result buffer.  May return
 *	zero if no input is available.
 *
 * Side effects:
 *	Consumes buffered input. May deallocate one buffer.
 *
 *----------------------------------------------------------------------
 */

static int
CopyBuffer(chanPtr, result, space)
    Channel *chanPtr;		/* Channel from which to read input. */
    char *result;		/* Where to store the copied input. */
    int space;			/* How many bytes are available in result
				 * to store the copied input? */
{
    ChannelBuffer *bufPtr;	/* The buffer from which to copy bytes. */
    int bytesInBuffer;		/* How many bytes are available to be
				 * copied in the current input buffer? */
    int copied;			/* How many characters were already copied
				 * into the destination space? */

    /*
     * If there is no input at all, return zero. The invariant is that
     * either there is no buffer in the queue, or if the first buffer
     * is empty, it is also the last buffer (and thus there is no
     * input in the queue).  Note also that if the buffer is empty, we
     * don't leave it in the queue, but recycle it.
     */

    if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
	return 0;
    }
    bufPtr = chanPtr->inQueueHead;
    bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;







|
|
|













|
|











|
|


|
|




|
|
|
|
|







8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
8603
8604
8605
8606
8607
8608
	if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
	    statePtr->inQueueTail = (ChannelBuffer *) NULL;
	}
	RecycleBuffer(statePtr, bufPtr, 0);
    }

    /*
     * Return the number of characters copied into the result buffer. This may
     * be different from the number of bytes consumed, because of EOL
     * translations.
     */

    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyBuffer --
 *
 *	Copy at most one buffer of input to the result space.
 *
 * Results:
 *	Number of bytes stored in the result buffer. May return zero if no
 *	input is available.
 *
 * Side effects:
 *	Consumes buffered input. May deallocate one buffer.
 *
 *----------------------------------------------------------------------
 */

static int
CopyBuffer(chanPtr, result, space)
    Channel *chanPtr;		/* Channel from which to read input. */
    char *result;		/* Where to store the copied input. */
    int space;			/* How many bytes are available in result to
				 * store the copied input? */
{
    ChannelBuffer *bufPtr;	/* The buffer from which to copy bytes. */
    int bytesInBuffer;		/* How many bytes are available to be copied
				 * in the current input buffer? */
    int copied;			/* How many characters were already copied
				 * into the destination space? */

    /*
     * If there is no input at all, return zero. The invariant is that either
     * there is no buffer in the queue, or if the first buffer is empty, it is
     * also the last buffer (and thus there is no input in the queue). Note
     * also that if the buffer is empty, we don't leave it in the queue, but
     * recycle it.
     */

    if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
	return 0;
    }
    bufPtr = chanPtr->inQueueHead;
    bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;
8309
8310
8311
8312
8313
8314
8315
8316
8317
8318
8319
8320
8321
8322
8323
8324
8325
8326
8327
8328
8329
8330
8331
8332
     * Copy the current chunk into the result buffer.
     */

    if (bytesInBuffer < space) {
	space = bytesInBuffer;
    }

    memcpy((VOID *) result,
	   (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
	   (size_t) space);
    bufPtr->nextRemoved += space;
    copied = space;

    /*
     * We don't care about in-stream EOF characters here as the data
     * read here may still flow through one or more transformations,
     * i.e. is not in its final state yet.
     */

    /*
     * If the current buffer is empty recycle it.
     */

    if (bufPtr->nextRemoved == bufPtr->nextAdded) {







<
|
|




|
|
|







8620
8621
8622
8623
8624
8625
8626

8627
8628
8629
8630
8631
8632
8633
8634
8635
8636
8637
8638
8639
8640
8641
8642
     * Copy the current chunk into the result buffer.
     */

    if (bytesInBuffer < space) {
	space = bytesInBuffer;
    }


    memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
	    (size_t) space);
    bufPtr->nextRemoved += space;
    copied = space;

    /*
     * We don't care about in-stream EOF characters here as the data read here
     * may still flow through one or more transformations, i.e. is not in its
     * final state yet.
     */

    /*
     * If the current buffer is empty recycle it.
     */

    if (bufPtr->nextRemoved == bufPtr->nextAdded) {
8374
8375
8376
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *outBufPtr;		/* Current output buffer. */
    int foundNewline;			/* Did we find a newline in output? */
    char *dPtr;
    CONST char *sPtr;			/* Search variables for newline. */
    int crsent;				/* In CRLF eol translation mode,
					 * remember the fact that a CR was
					 * output to the channel without
					 * its following NL. */
    int i;				/* Loop index for newline search. */
    int destCopied;			/* How many bytes were used in this
					 * destination buffer to hold the
					 * output? */
    int totalDestCopied;		/* How many bytes total were
					 * copied to the channel buffer? */
    int srcCopied;			/* How many bytes were copied from
					 * the source string? */
    char *destPtr;			/* Where in line to copy to? */

    /*
     * If we are in network (or windows) translation mode, record the fact
     * that we have not yet sent a CR to the channel.
     */








|
|




|
|
|
|







8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699
8700
8701
8702
8703
8704
8705
8706
8707
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *outBufPtr;		/* Current output buffer. */
    int foundNewline;			/* Did we find a newline in output? */
    char *dPtr;
    CONST char *sPtr;			/* Search variables for newline. */
    int crsent;				/* In CRLF eol translation mode,
					 * remember the fact that a CR was
					 * output to the channel without its
					 * following NL. */
    int i;				/* Loop index for newline search. */
    int destCopied;			/* How many bytes were used in this
					 * destination buffer to hold the
					 * output? */
    int totalDestCopied;		/* How many bytes total were copied to
					 * the channel buffer? */
    int srcCopied;			/* How many bytes were copied from the
					 * source string? */
    char *destPtr;			/* Where in line to copy to? */

    /*
     * If we are in network (or windows) translation mode, record the fact
     * that we have not yet sent a CR to the channel.
     */

8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
	destCopied = outBufPtr->bufLength - outBufPtr->nextAdded;
	if (destCopied > srcLen) {
	    destCopied = srcLen;
	}

	destPtr = outBufPtr->buf + outBufPtr->nextAdded;
	switch (statePtr->outputTranslation) {
	    case TCL_TRANSLATE_LF:
		srcCopied = destCopied;
		memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
		break;
	    case TCL_TRANSLATE_CR:
		srcCopied = destCopied;
		memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
		for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) {
		    if (*dPtr == '\n') {
			*dPtr = '\r';
		    }
		}
		break;
	    case TCL_TRANSLATE_CRLF:
		for (srcCopied = 0, dPtr = destPtr, sPtr = src;
		     dPtr < destPtr + destCopied;
		     dPtr++, sPtr++, srcCopied++) {
		    if (*sPtr == '\n') {
			if (crsent) {
			    *dPtr = '\n';
			    crsent = 0;
			} else {
			    *dPtr = '\r';
			    crsent = 1;
			    sPtr--, srcCopied--;
			}
		    } else {
			*dPtr = *sPtr;
		    }
		}
		break;
	    case TCL_TRANSLATE_AUTO:
		Tcl_Panic("Tcl_Write: AUTO output translation mode not supported");
	    default:
		Tcl_Panic("Tcl_Write: unknown output translation mode");
	}

	/*
	 * The current buffer is ready for output if it is full, or if it
	 * contains a newline and this channel is line-buffered, or if it
	 * contains any output and this channel is unbuffered.
	 */







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







8730
8731
8732
8733
8734
8735
8736
8737
8738
8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750
8751
8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
8778
	destCopied = outBufPtr->bufLength - outBufPtr->nextAdded;
	if (destCopied > srcLen) {
	    destCopied = srcLen;
	}

	destPtr = outBufPtr->buf + outBufPtr->nextAdded;
	switch (statePtr->outputTranslation) {
	case TCL_TRANSLATE_LF:
	    srcCopied = destCopied;
	    memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
	    break;
	case TCL_TRANSLATE_CR:
	    srcCopied = destCopied;
	    memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
	    for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) {
		if (*dPtr == '\n') {
		    *dPtr = '\r';
		}
	    }
	    break;
	case TCL_TRANSLATE_CRLF:
	    for (srcCopied = 0, dPtr = destPtr, sPtr = src;
		    dPtr < destPtr + destCopied;
		    dPtr++, sPtr++, srcCopied++) {
		if (*sPtr == '\n') {
		    if (crsent) {
			*dPtr = '\n';
			crsent = 0;
		    } else {
			*dPtr = '\r';
			crsent = 1;
			sPtr--, srcCopied--;
		    }
		} else {
		    *dPtr = *sPtr;
		}
	    }
	    break;
	case TCL_TRANSLATE_AUTO:
	    Tcl_Panic("Tcl_Write: AUTO output translation mode not supported");
	default:
	    Tcl_Panic("Tcl_Write: unknown output translation mode");
	}

	/*
	 * The current buffer is ready for output if it is full, or if it
	 * contains a newline and this channel is line-buffered, or if it
	 * contains any output and this channel is unbuffered.
	 */
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
}

/*
 *----------------------------------------------------------------------
 *
 * CopyEventProc --
 *
 *	This routine is invoked as a channel event handler for
 *	the background copy operation.  It is just a trivial wrapper
 *	around the CopyData routine.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
CopyEventProc(clientData, mask)
    ClientData clientData;
    int mask;
{
    (void) CopyData((CopyState *)clientData, mask);
}

/*
 *----------------------------------------------------------------------
 *
 * StopCopy --
 *
 *	This routine halts a copy that is in progress.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes any pending channel handlers and restores the blocking
 *	and buffering modes of the channels.  The CopyState is freed.
 *
 *----------------------------------------------------------------------
 */

static void
StopCopy(csPtr)
    CopyState *csPtr;		/* State for bg copy to stop . */







|
|
|















|













|
|







8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
8823
8824
8825
8826
8827
8828
8829
8830
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
8847
8848
8849
8850
8851
8852
8853
8854
8855
8856
8857
8858
8859
8860
}

/*
 *----------------------------------------------------------------------
 *
 * CopyEventProc --
 *
 *	This routine is invoked as a channel event handler for the background
 *	copy operation. It is just a trivial wrapper around the CopyData
 *	routine.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
CopyEventProc(clientData, mask)
    ClientData clientData;
    int mask;
{
    (void) CopyData((CopyState *) clientData, mask);
}

/*
 *----------------------------------------------------------------------
 *
 * StopCopy --
 *
 *	This routine halts a copy that is in progress.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes any pending channel handlers and restores the blocking and
 *	buffering modes of the channels. The CopyState is freed.
 *
 *----------------------------------------------------------------------
 */

static void
StopCopy(csPtr)
    CopyState *csPtr;		/* State for bg copy to stop . */
8573
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
8603
8604
8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
	if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
	    SetBlockMode(NULL, csPtr->writePtr,
		    nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
	}
    }
    outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
    outStatePtr->flags |=
	csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);

    if (csPtr->cmdPtr) {
	Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->readPtr, CopyEventProc,
		(ClientData)csPtr);
	if (csPtr->readPtr != csPtr->writePtr) {
	    Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->writePtr,
		    CopyEventProc, (ClientData)csPtr);
	}
	TclDecrRefCount(csPtr->cmdPtr);
    }
    inStatePtr->csPtr = NULL;
    outStatePtr->csPtr = NULL;
    ckfree((char *) csPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * StackSetBlockMode --
 *
 *	This function sets the blocking mode for a channel, iterating
 *	through each channel in a stack and updates the state flags.
 *
 * Results:
 *	0 if OK, result code from failed blockModeProc otherwise.
 *
 * Side effects:
 *	Modifies the blocking mode of the channel and possibly generates
 *	an error.
 *
 *----------------------------------------------------------------------
 */

static int
StackSetBlockMode(chanPtr, mode)
    Channel *chanPtr;		/* Channel to modify. */







|


|
|

|
|













|
|





|
|







8883
8884
8885
8886
8887
8888
8889
8890
8891
8892
8893
8894
8895
8896
8897
8898
8899
8900
8901
8902
8903
8904
8905
8906
8907
8908
8909
8910
8911
8912
8913
8914
8915
8916
8917
8918
8919
8920
8921
8922
8923
8924
8925
8926
	if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
	    SetBlockMode(NULL, csPtr->writePtr,
		    nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
	}
    }
    outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
    outStatePtr->flags |=
	    csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);

    if (csPtr->cmdPtr) {
	Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->readPtr, CopyEventProc,
		(ClientData) csPtr);
	if (csPtr->readPtr != csPtr->writePtr) {
	    Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->writePtr,
		    CopyEventProc, (ClientData) csPtr);
	}
	TclDecrRefCount(csPtr->cmdPtr);
    }
    inStatePtr->csPtr = NULL;
    outStatePtr->csPtr = NULL;
    ckfree((char *) csPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * StackSetBlockMode --
 *
 *	This function sets the blocking mode for a channel, iterating through
 *	each channel in a stack and updates the state flags.
 *
 * Results:
 *	0 if OK, result code from failed blockModeProc otherwise.
 *
 * Side effects:
 *	Modifies the blocking mode of the channel and possibly generates an
 *	error.
 *
 *----------------------------------------------------------------------
 */

static int
StackSetBlockMode(chanPtr, mode)
    Channel *chanPtr;		/* Channel to modify. */
8640
8641
8642
8643
8644
8645
8646
8647
8648
8649
8650
8651
8652
8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672










8673
8674








8675
8676
8677
8678
8679
8680
8681
}

/*
 *----------------------------------------------------------------------
 *
 * SetBlockMode --
 *
 *	This function sets the blocking mode for a channel and updates
 *	the state flags.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Modifies the blocking mode of the channel and possibly generates
 *	an error.
 *
 *----------------------------------------------------------------------
 */

static int
SetBlockMode(interp, chanPtr, mode)
    Tcl_Interp *interp;		/* Interp for error reporting. */
    Channel *chanPtr;		/* Channel to modify. */
    int mode;			/* One of TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int result = 0;

    result = StackSetBlockMode(chanPtr, mode);
    if (result != 0) {
	if (interp != (Tcl_Interp *) NULL) {










	    Tcl_AppendResult(interp, "error setting blocking mode: ",
		    Tcl_PosixError(interp), (char *) NULL);








	}
	return TCL_ERROR;
    }
    if (mode == TCL_MODE_BLOCKING) {
	statePtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED));
    } else {
	statePtr->flags |= CHANNEL_NONBLOCKING;







|
|





|
|

















>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>







8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
}

/*
 *----------------------------------------------------------------------
 *
 * SetBlockMode --
 *
 *	This function sets the blocking mode for a channel and updates the
 *	state flags.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Modifies the blocking mode of the channel and possibly generates an
 *	error.
 *
 *----------------------------------------------------------------------
 */

static int
SetBlockMode(interp, chanPtr, mode)
    Tcl_Interp *interp;		/* Interp for error reporting. */
    Channel *chanPtr;		/* Channel to modify. */
    int mode;			/* One of TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int result = 0;

    result = StackSetBlockMode(chanPtr, mode);
    if (result != 0) {
	if (interp != (Tcl_Interp *) NULL) {
	    /* TIP #219.
	     * Move error messages put by the driver into the bypass area and
	     * put them into the regular interpreter result. Fall back to the
	     * regular message if nothing was found in the bypass.
	     *
	     * Note that we cannot have a message in the interpreter bypass
	     * area, StackSetBlockMode is restricted to the channel bypass.
	     * We still need the interp as the destination of the move.
	     */
	    if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) {
		Tcl_AppendResult(interp, "error setting blocking mode: ",
				 Tcl_PosixError(interp), (char *) NULL);
	    }
	} else {
	    /* TIP #219.
	     * If we have no interpreter to put a bypass message into we have
	     * to clear it, to prevent its propagation and use in other places
	     * unrelated to the actual occurence of the problem.
	     */
	    Tcl_SetChannelError ((Tcl_Channel) chanPtr, NULL);
	}
	return TCL_ERROR;
    }
    if (mode == TCL_MODE_BLOCKING) {
	statePtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED));
    } else {
	statePtr->flags |= CHANNEL_NONBLOCKING;
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721
8722
8723
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelNamesEx --
 *
 *	Return the names of open channels in the interp filtered
 *	filtered through a pattern.  If pattern is NULL, it returns
 *	all the open channels.
 *
 * Results:
 *	TCL_OK or TCL_ERROR.
 *
 * Side effects:
 *	Interp result modified with list of channel names.
 *







|
|
|







9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelNamesEx --
 *
 *	Return the names of open channels in the interp filtered filtered
 *	through a pattern.  If pattern is NULL, it returns all the open
 *	channels.
 *
 * Results:
 *	TCL_OK or TCL_ERROR.
 *
 * Side effects:
 *	Interp result modified with list of channel names.
 *
8738
8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750







8751


8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774

8775
8776
8777
8778


8779
8780
8781
8782
8783
8784
8785
8786
8787
8788
8789
8790
8791
8792
8793
8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
    Tcl_HashSearch hSearch;	/* Search variable. */

    if (interp == (Tcl_Interp *) NULL) {
	return TCL_OK;
    }

    /*
     * Get the channel table that stores the channels registered
     * for this interpreter.
     */

    hTblPtr = GetChannelTable(interp);
    TclNewObj(resultPtr);










    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
	    hPtr != (Tcl_HashEntry *) NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {

	statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
	if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
	    name = "stdin";
	} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
	    name = "stdout";
	} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
	    name = "stderr";
	} else {
	    /*
	     * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr),
	     * but it's simpler to just grab the name from the statePtr.
	     */

	    name = statePtr->channelName;
	}

	if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
		(Tcl_ListObjAppendElement(interp, resultPtr,
			Tcl_NewStringObj(name, -1)) != TCL_OK)) {

	    TclDecrRefCount(resultPtr);
	    return TCL_ERROR;
	}
    }


    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsChannelRegistered --
 *
 *	Checks whether the channel is associated with the interp.
 *	See also Tcl_RegisterChannel and Tcl_UnregisterChannel.
 *
 * Results:
 *	0 if the channel is not registered in the interpreter, 1 else.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsChannelRegistered(interp, chan)
     Tcl_Interp *interp;	/* The interp to query of the channel */
     Tcl_Channel chan;		/* The channel to check */
{
    Tcl_HashTable	*hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry	*hPtr;		/* Search variable. */
    Channel		*chanPtr;	/* The real IO channel. */
    ChannelState	*statePtr;	/* State of the real channel. */

    /*
     * Always check bottom-most channel in the stack.  This is the one
     * that gets registered.
     */

    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    statePtr = chanPtr->state;

    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
    if (hTblPtr == (Tcl_HashTable *) NULL) {







|
|




>
>
>
>
>
>
>
|
>
>













|
|








>




>
>









|
|












|
|







|
|







9066
9067
9068
9069
9070
9071
9072
9073
9074
9075
9076
9077
9078
9079
9080
9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
9093
9094
9095
9096
9097
9098
9099
9100
9101
9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
9143
9144
9145
9146
9147
9148
9149
9150
9151
9152
9153
9154
9155
9156
9157
9158
9159
    Tcl_HashSearch hSearch;	/* Search variable. */

    if (interp == (Tcl_Interp *) NULL) {
	return TCL_OK;
    }

    /*
     * Get the channel table that stores the channels registered for this
     * interpreter.
     */

    hTblPtr = GetChannelTable(interp);
    TclNewObj(resultPtr);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)
	    && !((pattern[0] == 's') && (pattern[1] == 't')
	    && (pattern[2] == 'd'))) {
	if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL)
		&& (Tcl_ListObjAppendElement(interp, resultPtr,
		Tcl_NewStringObj(pattern, -1)) != TCL_OK)) {
	    goto error;
	}
	goto done;
    }
    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
	    hPtr != (Tcl_HashEntry *) NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {

	statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
	if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
	    name = "stdin";
	} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
	    name = "stdout";
	} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
	    name = "stderr";
	} else {
	    /*
	     * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), but it's
	     * simpler to just grab the name from the statePtr.
	     */

	    name = statePtr->channelName;
	}

	if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
		(Tcl_ListObjAppendElement(interp, resultPtr,
			Tcl_NewStringObj(name, -1)) != TCL_OK)) {
	error:
	    TclDecrRefCount(resultPtr);
	    return TCL_ERROR;
	}
    }

  done:
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsChannelRegistered --
 *
 *	Checks whether the channel is associated with the interp.  See also
 *	Tcl_RegisterChannel and Tcl_UnregisterChannel.
 *
 * Results:
 *	0 if the channel is not registered in the interpreter, 1 else.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsChannelRegistered(interp, chan)
    Tcl_Interp *interp;	/* The interp to query of the channel */
    Tcl_Channel chan;		/* The channel to check */
{
    Tcl_HashTable	*hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry	*hPtr;		/* Search variable. */
    Channel		*chanPtr;	/* The real IO channel. */
    ChannelState	*statePtr;	/* State of the real channel. */

    /*
     * Always check bottom-most channel in the stack.  This is the one that
     * gets registered.
     */

    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    statePtr = chanPtr->state;

    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
    if (hTblPtr == (Tcl_HashTable *) NULL) {
8858
8859
8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsChannelExisting --
 *
 *	Checks whether a channel of the given name exists in the
 *	(thread)-global list of all channels.
 *	See Tcl_GetChannelNamesEx for function exposed at the Tcl level.
 *
 * Results:
 *	A boolean value (0 = Does not exist, 1 = Does exist).
 *
 * Side effects:
 *	None.
 *







|
|







9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsChannelExisting --
 *
 *	Checks whether a channel of the given name exists in the
 *	(thread)-global list of all channels.  See Tcl_GetChannelNamesEx for
 *	function exposed at the Tcl level.
 *
 * Results:
 *	A boolean value (0 = Does not exist, 1 = Does exist).
 *
 * Side effects:
 *	None.
 *
8949
8950
8951
8952
8953
8954
8955


8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
Tcl_ChannelVersion(chanTypePtr)
    Tcl_ChannelType *chanTypePtr;	/* Pointer to channel type. */
{
    if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
	return TCL_CHANNEL_VERSION_2;
    } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) {
	return TCL_CHANNEL_VERSION_3;


    } else {
	/*
	 * In <v2 channel versions, the version field is occupied
	 * by the Tcl_DriverBlockModeProc
	 */

	return TCL_CHANNEL_VERSION_1;
    }
}

/*







>
>


|
|







9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
Tcl_ChannelVersion(chanTypePtr)
    Tcl_ChannelType *chanTypePtr;	/* Pointer to channel type. */
{
    if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
	return TCL_CHANNEL_VERSION_2;
    } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) {
	return TCL_CHANNEL_VERSION_3;
    } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) {
	return TCL_CHANNEL_VERSION_4;
    } else {
	/*
	 * In <v2 channel versions, the version field is occupied by the
	 * Tcl_DriverBlockModeProc
	 */

	return TCL_CHANNEL_VERSION_1;
    }
}

/*
9303
9304
9305
9306
9307
9308
9309
































































































































































































































































































































9310
9311
9312
9313
9314
9315
9316
9317
9318
9319
9320
9321
9322
9323
9324

9325

9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344

9345
9346
9347
9348
9349
9350








{
    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
	return chanTypePtr->wideSeekProc;
    } else {
	return NULL;
    }
}

































































































































































































































































































































#if 0
/*
 * For future debugging work, a simple function to print the flags of
 * a channel in semi-readable form.
 */

static int
DumpFlags(str, flags)
     char *str;
     int flags;
{
    char buf[20];
    int i = 0;


    if (flags & TCL_READABLE)           buf[i++] = 'r'; else buf[i++]='_';

    if (flags & TCL_WRITABLE)           buf[i++] = 'w'; else buf[i++]='_';
    if (flags & CHANNEL_NONBLOCKING)    buf[i++] = 'n'; else buf[i++]='_';
    if (flags & CHANNEL_LINEBUFFERED)   buf[i++] = 'l'; else buf[i++]='_';
    if (flags & CHANNEL_UNBUFFERED)     buf[i++] = 'u'; else buf[i++]='_';
    if (flags & BUFFER_READY)           buf[i++] = 'R'; else buf[i++]='_';
    if (flags & BG_FLUSH_SCHEDULED)     buf[i++] = 'F'; else buf[i++]='_';
    if (flags & CHANNEL_CLOSED)         buf[i++] = 'c'; else buf[i++]='_';
    if (flags & CHANNEL_EOF)            buf[i++] = 'E'; else buf[i++]='_';
    if (flags & CHANNEL_STICKY_EOF)     buf[i++] = 'S'; else buf[i++]='_';
    if (flags & CHANNEL_BLOCKED)        buf[i++] = 'B'; else buf[i++]='_';
    if (flags & INPUT_SAW_CR)           buf[i++] = '/'; else buf[i++]='_';
    if (flags & INPUT_NEED_NL)          buf[i++] = '*'; else buf[i++]='_';
    if (flags & CHANNEL_DEAD)           buf[i++] = 'D'; else buf[i++]='_';
    if (flags & CHANNEL_RAW_MODE)       buf[i++] = 'R'; else buf[i++]='_';
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    if (flags & CHANNEL_TIMER_FEV)      buf[i++] = 'T'; else buf[i++]='_';
    if (flags & CHANNEL_HAS_MORE_DATA)  buf[i++] = 'H'; else buf[i++]='_';
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
    if (flags & CHANNEL_INCLOSE)        buf[i++] = 'x'; else buf[i++]='_';

    buf[i] ='\0';

    fprintf(stderr,"%s: %s\n", str, buf);
    return 0;
}
#endif















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|




|
|




>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
>


|



>
>
>
>
>
>
>
>
9645
9646
9647
9648
9649
9650
9651
9652
9653
9654
9655
9656
9657
9658
9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
9672
9673
9674
9675
9676
9677
9678
9679
9680
9681
9682
9683
9684
9685
9686
9687
9688
9689
9690
9691
9692
9693
9694
9695
9696
9697
9698
9699
9700
9701
9702
9703
9704
9705
9706
9707
9708
9709
9710
9711
9712
9713
9714
9715
9716
9717
9718
9719
9720
9721
9722
9723
9724
9725
9726
9727
9728
9729
9730
9731
9732
9733
9734
9735
9736
9737
9738
9739
9740
9741
9742
9743
9744
9745
9746
9747
9748
9749
9750
9751
9752
9753
9754
9755
9756
9757
9758
9759
9760
9761
9762
9763
9764
9765
9766
9767
9768
9769
9770
9771
9772
9773
9774
9775
9776
9777
9778
9779
9780
9781
9782
9783
9784
9785
9786
9787
9788
9789
9790
9791
9792
9793
9794
9795
9796
9797
9798
9799
9800
9801
9802
9803
9804
9805
9806
9807
9808
9809
9810
9811
9812
9813
9814
9815
9816
9817
9818
9819
9820
9821
9822
9823
9824
9825
9826
9827
9828
9829
9830
9831
9832
9833
9834
9835
9836
9837
9838
9839
9840
9841
9842
9843
9844
9845
9846
9847
9848
9849
9850
9851
9852
9853
9854
9855
9856
9857
9858
9859
9860
9861
9862
9863
9864
9865
9866
9867
9868
9869
9870
9871
9872
9873
9874
9875
9876
9877
9878
9879
9880
9881
9882
9883
9884
9885
9886
9887
9888
9889
9890
9891
9892
9893
9894
9895
9896
9897
9898
9899
9900
9901
9902
9903
9904
9905
9906
9907
9908
9909
9910
9911
9912
9913
9914
9915
9916
9917
9918
9919
9920
9921
9922
9923
9924
9925
9926
9927
9928
9929
9930
9931
9932
9933
9934
9935
9936
9937
9938
9939
9940
9941
9942
9943
9944
9945
9946
9947
9948
9949
9950
9951
9952
9953
9954
9955
9956
9957
9958
9959
9960
9961
9962
9963
9964
9965
9966
9967
9968
9969
9970
9971
9972
9973
9974
9975
9976
9977
9978
9979
9980
9981
9982
9983
9984
9985
9986
9987
9988
9989
9990
9991
9992
9993
9994
9995
9996
9997
9998
9999
10000
10001
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
10022
10023
{
    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
	return chanTypePtr->wideSeekProc;
    } else {
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChannelThreadActionProc --
 *
 *	TIP #218, Channel Thread Actions.  Return the
 *	Tcl_DriverThreadActionProc of the channel type.
 *
 * Results:
 *	A pointer to the proc.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(chanTypePtr)
    Tcl_ChannelType *chanTypePtr;	/* Pointer to channel type. */
{
    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) {
	return chanTypePtr->threadActionProc;
    } else {
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetChannelErrorInterp --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Store an error message for the I/O system.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Discards a previously stored message.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetChannelErrorInterp (interp, msg)
     Tcl_Interp* interp; /* Interp to store the data into. */
     Tcl_Obj*    msg;    /* Error message to store. */
{
    Interp* iPtr = (Interp*) interp;

    if (iPtr->chanMsg != NULL) {
        Tcl_DecrRefCount (iPtr->chanMsg);
	iPtr->chanMsg  = NULL;
    }

    if (msg != NULL) {
        iPtr->chanMsg  = FixLevelCode (msg);
	Tcl_IncrRefCount (iPtr->chanMsg);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetChannelError --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Store an error message for the I/O system.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Discards a previously stored message.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetChannelError (chan, msg)
     Tcl_Channel chan; /* Channel to store the data into. */
     Tcl_Obj*    msg;  /* Error message to store. */
{
    ChannelState* statePtr = ((Channel*) chan)->state;

    if (statePtr->chanMsg != NULL) {
        Tcl_DecrRefCount (statePtr->chanMsg);
	statePtr->chanMsg  = NULL;
    }

    if (msg != NULL) {
        statePtr->chanMsg  = FixLevelCode (msg);
	Tcl_IncrRefCount (statePtr->chanMsg);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * FixLevelCode --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Scans an error message for bad -code / -level
 *	directives. Returns a modified copy with such
 *	directives corrected, and the input if it had
 *	no problems.
 *
 * Results:
 *	A Tcl_Obj*
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
FixLevelCode (msg)
Tcl_Obj* msg;
{
    int       lc;
    Tcl_Obj** lv;
    int       explicitResult;
    int       numOptions;
    int       lcn;
    Tcl_Obj** lvn;
    int       res, i, j, val, lignore, cignore;
    Tcl_Obj*  newlevel = NULL;
    Tcl_Obj*  newcode  = NULL;

    /* ASSERT msg != NULL */

    /* Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. Because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information.
     */

    res = Tcl_ListObjGetElements (NULL, msg, &lc, &lv);
    if (res != TCL_OK) {
	Tcl_Panic ("Tcl_SetChannelError(Interp): Bad syntax of message");
    }

    explicitResult = (1 == (lc % 2));
    numOptions     = lc - explicitResult;

    /* No options, nothing to do.
     */

    if (numOptions == 0) {
	return msg;
    }

    /* Check for -code x, x != 1|error, and -level x, x != 0 */

    for (i = 0; i < numOptions; i += 2) {
	if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) {
	    /* !"error", !integer, integer != 1 (numeric code for error) */

	    res = Tcl_GetIntFromObj (NULL, lv [i+1], &val);
	    if (((res == TCL_OK) && (val != 1)) ||
		((res != TCL_OK) && (0 != strcmp (Tcl_GetString (lv [i+1]), "error")))) {
		newcode = Tcl_NewIntObj (1);
	    }
	} else if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) {
	    /* !integer, integer != 0 */
	    res = Tcl_GetIntFromObj (NULL, lv [i+1], &val);
	    if ((res != TCL_OK) || (val != 0)) {
		newlevel = Tcl_NewIntObj (0);
	    }
	}
    }

    /* -code, -level are either not present or ok. Nothing to do.
     */

    if (!newlevel && !newcode) {
	return msg;
    }

    lcn = numOptions;
    if (explicitResult) lcn ++;
    if (newlevel)       lcn += 2;
    if (newcode)        lcn += 2;

    lvn = (Tcl_Obj**) ckalloc (lcn * sizeof (Tcl_Obj*));

    /* New level/code information is spliced into the first occurence of
     * -level, -code, further occurences are ignored. The options cannot be
     * not present, we would not come here. Options which are ok are simply
     * copied over.
     */

    lignore = cignore = 0;
    for (i = 0, j = 0; i < numOptions; i += 2) {
	if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) {
	    if (newlevel) {
		lvn [j] = lv [i];   j++;
		lvn [j] = newlevel; j++;
		newlevel = NULL;
		lignore = 1;
		continue;
	    } else if (lignore) {
		continue;
	    }
	} else if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) {
	    if (newcode) {
		lvn [j] = lv [i];  j++;
		lvn [j] = newcode; j++;
		newcode = NULL;
		cignore = 1;
		continue;
	    } else if (cignore) {
		continue;
	    }
	}
	/* Keep everything else, possibly copied down */
	lvn [j] = lv [i];   j++;
	lvn [j] = lv [i+1]; j++;
    }

    if (explicitResult) {
	lvn [j] = lv [i]; j++;
    }

    msg = Tcl_NewListObj (j, lvn);

    ckfree ((char*) lvn);
    return msg;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelErrorInterp --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Return the message stored by the channel driver.
 *
 * Results:
 *	Tcl error message object.
 *
 * Side effects:
 *	Resets the stored data to NULL.
 *
 *----------------------------------------------------------------------
 */

void Tcl_GetChannelErrorInterp (interp, msg)
     Tcl_Interp* interp; /* Interp to query. */
     Tcl_Obj**   msg;    /* Place for error message. */
{
    Interp* iPtr = (Interp*) interp;

    *msg = iPtr->chanMsg;
    iPtr->chanMsg  = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelError --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Return the message stored by the channel driver.
 *
 * Results:
 *	Tcl error message object.
 *
 * Side effects:
 *	Resets the stored data to NULL.
 *
 *----------------------------------------------------------------------
 */

void Tcl_GetChannelError (chan, msg)
     Tcl_Channel chan; /* Channel to query. */
     Tcl_Obj**   msg;  /* Place for error message. */
{
    ChannelState* statePtr = ((Channel*) chan)->state;

    *msg = statePtr->chanMsg;
    statePtr->chanMsg  = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChannelTruncateProc --
 *
 *	TIP #208 (subsection relating to truncation, based on TIP #206).
 *	Return the Tcl_DriverTruncateProc of the channel type.
 *
 * Results:
 *	A pointer to the proc.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_DriverTruncateProc *
Tcl_ChannelTruncateProc(chanTypePtr)
    Tcl_ChannelType *chanTypePtr;	/* Pointer to channel type. */
{
    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) {
	return chanTypePtr->truncateProc;
    } else {
	return NULL;
    }
}

#if 0
/*
 * For future debugging work, a simple function to print the flags of a
 * channel in semi-readable form.
 */

static int
DumpFlags(str, flags)
    char *str;
    int flags;
{
    char buf[20];
    int i = 0;

#define ChanFlag(chr,bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))

    ChanFlag('r', TCL_READABLE);
    ChanFlag('w', TCL_WRITABLE);
    ChanFlag('n', CHANNEL_NONBLOCKING);
    ChanFlag('l', CHANNEL_LINEBUFFERED);
    ChanFlag('u', CHANNEL_UNBUFFERED);
    ChanFlag('R', BUFFER_READY);
    ChanFlag('F', BG_FLUSH_SCHEDULED);
    ChanFlag('c', CHANNEL_CLOSED);
    ChanFlag('E', CHANNEL_EOF);
    ChanFlag('S', CHANNEL_STICKY_EOF);
    ChanFlag('B', CHANNEL_BLOCKED);
    ChanFlag('/', INPUT_SAW_CR);
    ChanFlag('*', INPUT_NEED_NL);
    ChanFlag('D', CHANNEL_DEAD);
    ChanFlag('R', CHANNEL_RAW_MODE);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    ChanFlag('T', CHANNEL_TIMER_FEV);
    ChanFlag('H', CHANNEL_HAS_MORE_DATA);
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
    ChanFlag('x', CHANNEL_INCLOSE);

    buf[i] ='\0';

    fprintf(stderr, "%s: %s\n", str, buf);
    return 0;
}
#endif

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIO.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclIO.h --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.h,v 1.7 2004/07/15 20:46:49 andreas_kupries Exp $
 */

/*
 * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not
 * compile on systems where neither is defined. We want both defined so
 * that we can test safely for both. In the code we still have to test for
 * both because there may be systems on which both are defined and have












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclIO.h --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.h,v 1.7.2.1 2005/08/25 15:46:31 dgp Exp $
 */

/*
 * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not
 * compile on systems where neither is defined. We want both defined so
 * that we can test safely for both. In the code we still have to test for
 * both because there may be systems on which both are defined and have
231
232
233
234
235
236
237














238
239
240
241
242
243
244
    Channel *bottomChanPtr;	/* Refers to bottommost channel in a stack.
				 * This channel can be relied on to live as
				 * long as the channel state. Never NULL. */
    struct ChannelState *nextCSPtr;
				/* Next in list of channels currently open. */
    Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing
				  * this stack of channels. */














} ChannelState;
    
/*
 * Values for the flags field in Channel. Any ORed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.







>
>
>
>
>
>
>
>
>
>
>
>
>
>







231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
    Channel *bottomChanPtr;	/* Refers to bottommost channel in a stack.
				 * This channel can be relied on to live as
				 * long as the channel state. Never NULL. */
    struct ChannelState *nextCSPtr;
				/* Next in list of channels currently open. */
    Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing
				  * this stack of channels. */

    /* TIP #219 ... Info for the I/O system ...
     * Error message set by channel drivers, for the propagation of
     * arbitrary Tcl errors. This information, if present (chanMsg not
     * NULL), takes precedence over a posix error code returned by a
     * channel operation.
     */

    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was
                                 * deferred because it happened in the
                                 * background. The value is the
                                 * chanMg, if any. #219's companion to
                                 * 'unreportedError'. */
} ChannelState;
    
/*
 * Values for the flags field in Channel. Any ORed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.

Changes to generic/tclIOCmd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143






144
145

146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193






194
195

196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252







253
254
255

256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
/* 
 * tclIOCmd.c --
 *
 *	Contains the definitions of most of the Tcl commands relating to IO.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOCmd.c,v 1.22 2004/10/07 00:24:49 dgp Exp $
 */

#include "tclInt.h"

/*
 * Callback structure for accept callback in a TCP server.
 */

typedef struct AcceptCallback {
    char *script;			/* Script to invoke. */
    Tcl_Interp *interp;			/* Interpreter in which to run it. */
} AcceptCallback;

/*
 * Static functions for this file:
 */

static void	AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
	            Tcl_Channel chan, char *address, int port));
static void	RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
	            AcceptCallback *acceptCallbackPtr));
static void	TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
		    ClientData clientData, Tcl_Interp *interp));
static void	TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
static void	UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
		    Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutsObjCmd --
 *
 *	This procedure is invoked to process the "puts" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Produces output on a channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PutsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to puts on. */
    Tcl_Obj *string;			/* String to write. */
    int newline;			/* Add a newline at end? */
    char *channelId;			/* Name of channel for puts. */
    int result;				/* Result of puts operation. */
    int mode;				/* Mode in which channel is opened. */

    switch (objc) {
    case 2: /* puts $x */
	string = objv[1];
	newline = 1;
	channelId = "stdout";
	break;

    case 3: /* puts -nonewline $x  or  puts $chan $x */ 
	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	    newline = 0;
	    channelId = "stdout";
	} else {
	    newline = 1;
	    channelId = Tcl_GetString(objv[1]);
	}
	string = objv[2];
	break;

    case 4: /* puts -nonewline $chan $x  or  puts $chan $x nonewline */
	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	    channelId = Tcl_GetString(objv[2]);
	    string = objv[3];
	} else {
	    /*
	     * The code below provides backwards compatibility with an
	     * old form of the command that is no longer recommended
	     * or documented.
	     */

	    char *arg;
	    int length;

	    arg = Tcl_GetStringFromObj(objv[3], &length);
	    if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
		Tcl_AppendResult(interp, "bad argument \"", arg,
				 "\": should be \"nonewline\"",
				 (char *) NULL);
		return TCL_ERROR;
	    }
	    channelId = Tcl_GetString(objv[1]);
	    string = objv[2];
	}
	newline = 0;
	break;


    default: /* puts  or  puts some bad number of arguments... */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
	return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
                "\" wasn't opened for writing", (char *) NULL);
        return TCL_ERROR;
    }

    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
        goto error;
    }
    if (newline != 0) {
        result = Tcl_WriteChars(chan, "\n", 1);
        if (result < 0) {
            goto error;
        }
    }
    return TCL_OK;

    error:






    Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
	    Tcl_PosixError(interp), (char *) NULL);

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --
 *
 *	This procedure is called to process the Tcl "flush" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May cause output to appear on the specified channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FlushObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to flush on. */
    char *channelId;
    int mode;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }
    channelId = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
		"\" wasn't opened for writing", (char *) NULL);
        return TCL_ERROR;
    }
    
    if (Tcl_Flush(chan) != TCL_OK) {






	Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
		Tcl_PosixError(interp), (char *) NULL);

	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --
 *
 *	This procedure is called to process the Tcl "gets" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May consume input from channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_GetsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to read from. */
    int lineLen;			/* Length of line just read. */
    int mode;				/* Mode in which channel is opened. */
    char *name;
    Tcl_Obj *linePtr;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
    }
    name = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, name, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", name,
		"\" wasn't opened for reading", (char *) NULL);
        return TCL_ERROR;
    }

    linePtr = Tcl_NewObj();

    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
        if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);







	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading \"", name, "\": ",
		    Tcl_PosixError(interp), (char *) NULL);

            return TCL_ERROR;
        }
        lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_DecrRefCount(linePtr);
            return TCL_ERROR;
        }
	Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
        return TCL_OK;
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *
 *	This procedure is invoked to process the Tcl "read" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May consume input from channel.
 *
|






|
|

|


















|

|











|
|


















|
|
|
|
|
|


|





|










|





|
|
|








|
<








>
|






|



|
|




|


|
|
|
|



|
>
>
>
>
>
>
|
|
>








|
|


















|















|

|

>
>
>
>
>
>
|
|
>










|
|


















|
|
|















|






|

>
>
>
>
>
>
>
|
|
|
>
|
|
|





|
|

|











|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
/*
 * tclIOCmd.c --
 *
 *	Contains the definitions of most of the Tcl commands relating to IO.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOCmd.c,v 1.22.2.4 2005/08/25 15:46:31 dgp Exp $
 */

#include "tclInt.h"

/*
 * Callback structure for accept callback in a TCP server.
 */

typedef struct AcceptCallback {
    char *script;			/* Script to invoke. */
    Tcl_Interp *interp;			/* Interpreter in which to run it. */
} AcceptCallback;

/*
 * Static functions for this file:
 */

static void	AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
		    Tcl_Channel chan, char *address, int port));
static void	RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
		    AcceptCallback *acceptCallbackPtr));
static void	TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
		    ClientData clientData, Tcl_Interp *interp));
static void	TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
static void	UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
		    Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutsObjCmd --
 *
 *	This procedure is invoked to process the "puts" Tcl command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Produces output on a channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PutsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to puts on. */
    Tcl_Obj *string;		/* String to write. */
    int newline;		/* Add a newline at end? */
    char *channelId;		/* Name of channel for puts. */
    int result;			/* Result of puts operation. */
    int mode;			/* Mode in which channel is opened. */

    switch (objc) {
    case 2: /* [puts $x] */
	string = objv[1];
	newline = 1;
	channelId = "stdout";
	break;

    case 3: /* [puts -nonewline $x] or [puts $chan $x] */
	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	    newline = 0;
	    channelId = "stdout";
	} else {
	    newline = 1;
	    channelId = Tcl_GetString(objv[1]);
	}
	string = objv[2];
	break;

    case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	    channelId = Tcl_GetString(objv[2]);
	    string = objv[3];
	} else {
	    /*
	     * The code below provides backwards compatibility with an old
	     * form of the command that is no longer recommended or
	     * documented.
	     */

	    char *arg;
	    int length;

	    arg = Tcl_GetStringFromObj(objv[3], &length);
	    if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
		Tcl_AppendResult(interp, "bad argument \"", arg,
			"\": should be \"nonewline\"", (char *) NULL);

		return TCL_ERROR;
	    }
	    channelId = Tcl_GetString(objv[1]);
	    string = objv[2];
	}
	newline = 0;
	break;

    default:
	/* [puts] or [puts some bad number of arguments...] */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
	return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
		"\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    }

    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result < 0) {
	    goto error;
	}
    }
    return TCL_OK;

  error:
    /* TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
     */
    if (!TclChanCaughtErrorBypass (interp, chan)) {
	Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
			 Tcl_PosixError(interp), (char *) NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --
 *
 *	This procedure is called to process the Tcl "flush" command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May cause output to appear on the specified channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FlushObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to flush on. */
    char *channelId;
    int mode;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }
    channelId = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
		"\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    }

    if (Tcl_Flush(chan) != TCL_OK) {
	/* TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */
	if (!TclChanCaughtErrorBypass (interp, chan)) {
	    Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
			     Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --
 *
 *	This procedure is called to process the Tcl "gets" command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May consume input from channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_GetsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    char *name;
    Tcl_Obj *linePtr;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
    }
    name = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, name, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", name,
		"\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }

    linePtr = Tcl_NewObj();

    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);

	    /* TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */
	    if (!TclChanCaughtErrorBypass (interp, chan)) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "error reading \"", name, "\": ",
				 Tcl_PosixError(interp), (char *) NULL);
	    }
	    return TCL_ERROR;
	}
	lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_DecrRefCount(linePtr);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
	return TCL_OK;
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *
 *	This procedure is invoked to process the Tcl "read" command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May consume input from channel.
 *
301
302
303
304
305
306
307


308

309
310






311

312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364






365
366
367
368

369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
    int toRead;			/* How many bytes to read? */
    int charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    char *name;
    Tcl_Obj *resultPtr;

    if ((objc != 2) && (objc != 3)) {


	argerror:

	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
	Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),






		" ?-nonewline? channelId\"", (char *) NULL);

	return TCL_ERROR;
    }

    i = 1;
    newline = 0;
    if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	newline = 1;
	i++;
    }

    if (i == objc) {
        goto argerror;
    }

    name = Tcl_GetString(objv[i]);
    chan = Tcl_GetChannel(interp, name, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", name, 
                "\" wasn't opened for reading", (char *) NULL);
        return TCL_ERROR;
    }
    i++;	/* Consumed channel name. */

    /*
     * Compute how many bytes to read, and see whether the final
     * newline should be dropped.
     */

    toRead = -1;
    if (i < objc) {
	char *arg;
	
	arg = Tcl_GetString(objv[i]);
	if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
	    if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
                return TCL_ERROR;
	    }
	} else if (strcmp(arg, "nonewline") == 0) {
	    newline = 1;
	} else {
	    Tcl_AppendResult(interp, "bad argument \"", arg,
		    "\": should be \"nonewline\"", (char *) NULL);
	    return TCL_ERROR;
        }
    }

    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);
    charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
    if (charactersRead < 0) {






	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "error reading \"", name, "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	Tcl_DecrRefCount(resultPtr);

	return TCL_ERROR;
    }
    
    /*
     * If requested, remove the last newline in the channel if at EOF.
     */
    
    if ((charactersRead > 0) && (newline != 0)) {
	char *result;
	int length;

	result = Tcl_GetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SeekObjCmd --
 *
 *	This procedure is invoked to process the Tcl "seek" command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Moves the position of the access point on the specified channel.
 *	May flush queued output.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SeekObjCmd(clientData, interp, objc, objv)







>
>
|
>

|
>
>
>
>
>
>
|
>











|








|
|
|




|
|





|



|







|






>
>
>
>
>
>
|
|
|
|
>


|



|



















|
|





|
|







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
    int toRead;			/* How many bytes to read? */
    int charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    char *name;
    Tcl_Obj *resultPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:
	iPtr = (Interp *) interp;
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");

	/*
	 * Do not append directly; that makes ensembles using this command as
	 * a subcommand produce the wrong message.
	 */

	iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId");
	iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
	return TCL_ERROR;
    }

    i = 1;
    newline = 0;
    if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	newline = 1;
	i++;
    }

    if (i == objc) {
	goto argerror;
    }

    name = Tcl_GetString(objv[i]);
    chan = Tcl_GetChannel(interp, name, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", name,
		"\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }
    i++;	/* Consumed channel name. */

    /*
     * Compute how many bytes to read, and see whether the final newline
     * should be dropped.
     */

    toRead = -1;
    if (i < objc) {
	char *arg;

	arg = Tcl_GetString(objv[i]);
	if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
	    if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else if (strcmp(arg, "nonewline") == 0) {
	    newline = 1;
	} else {
	    Tcl_AppendResult(interp, "bad argument \"", arg,
		    "\": should be \"nonewline\"", (char *) NULL);
	    return TCL_ERROR;
	}
    }

    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);
    charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
    if (charactersRead < 0) {
	/* TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */
	if (!TclChanCaughtErrorBypass (interp, chan)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading \"", name, "\": ",
			     Tcl_PosixError(interp), (char *) NULL);
	    Tcl_DecrRefCount(resultPtr);
	}
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	char *result;
	int length;

	result = Tcl_GetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SeekObjCmd --
 *
 *	This procedure is invoked to process the Tcl "seek" command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Moves the position of the access point on the specified channel.  May
 *	flush queued output.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SeekObjCmd(clientData, interp, objc, objv)
443
444
445
446
447
448
449






450
451


452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483

484
485
486
487
488

489
490
491
492
493
494
495
496
497
498











499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }

    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {






        Tcl_AppendResult(interp, "error during seek on \"", 
		chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);


        return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --
 *
 *	This procedure is invoked to process the Tcl "tell" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_TellObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to tell on. */
    char *chanName;


    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    /*
     * Try to find a channel with the right name and permissions in
     * the IO channel table of this interpreter.
     */
    
    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }











    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_Tell(chan)));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CloseObjCmd --
 *
 *	This procedure is invoked to process the Tcl "close" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May discard queued input; may flush queued output.
 *







>
>
>
>
>
>
|
|
>
>
|









|
|




















>





>

|
|

|





>
>
>
>
>
>
>
>
>
>
>
|








|
|







482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }

    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
	/* TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */
	if (!TclChanCaughtErrorBypass (interp, chan)) {
	    Tcl_AppendResult(interp, "error during seek on \"",
			     chanName, "\": ", Tcl_PosixError(interp),
			     (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --
 *
 *	This procedure is invoked to process the Tcl "tell" command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_TellObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to tell on. */
    char *chanName;
    Tcl_WideInt newLoc;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    /*
     * Try to find a channel with the right name and permissions in the IO
     * channel table of this interpreter.
     */

    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    newLoc = Tcl_Tell(chan);

    /* TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */
    if (TclChanCaughtErrorBypass (interp, chan)) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CloseObjCmd --
 *
 *	This procedure is invoked to process the Tcl "close" command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May discard queued input; may flush queued output.
 *
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
        /*
         * If there is an error message and it ends with a newline, remove
         * the newline. This is done for command pipeline channels where the
         * error output from the subprocesses is stored in interp's result.
         *
         * NOTE: This is likely to not have any effect on regular error
         * messages produced by drivers during the closing of a channel,
         * because the Tcl convention is that such error messages do not
         * have a terminating newline.
         */

	Tcl_Obj *resultPtr;
	char *string;
	int len;
	
	resultPtr = Tcl_GetObjResult(interp);
	if (Tcl_IsShared(resultPtr)) {
	    resultPtr = Tcl_DuplicateObj(resultPtr);
	    Tcl_SetObjResult(interp, resultPtr);
	}
	string = Tcl_GetStringFromObj(resultPtr, &len);
        if ((len > 0) && (string[len - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, len - 1);
        }
        return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|
|
|
|
|
|
|
|
|
|




|






|

|
|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
	/*
	 * If there is an error message and it ends with a newline, remove the
	 * newline. This is done for command pipeline channels where the error
	 * output from the subprocesses is stored in interp's result.
	 *
	 * NOTE: This is likely to not have any effect on regular error
	 * messages produced by drivers during the closing of a channel,
	 * because the Tcl convention is that such error messages do not have
	 * a terminating newline.
	 */

	Tcl_Obj *resultPtr;
	char *string;
	int len;

	resultPtr = Tcl_GetObjResult(interp);
	if (Tcl_IsShared(resultPtr)) {
	    resultPtr = Tcl_DuplicateObj(resultPtr);
	    Tcl_SetObjResult(interp, resultPtr);
	}
	string = Tcl_GetStringFromObj(resultPtr, &len);
	if ((len > 0) && (string[len - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, len - 1);
	}
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608

609
610
611
612
613

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632

633
634
635
636
637
638
639
640

641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    char *chanName, *optionName, *valueName;
    Tcl_Channel chan;			/* The channel to set a mode on. */
    int i;				/* Iterate over arg-value pairs. */
    Tcl_DString ds;			/* DString to hold result of
                                         * calling Tcl_GetChannelOption. */

    if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"channelId ?optionName? ?value? ?optionName value?...");
        return TCL_ERROR;
    }

    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }

    if (objc == 2) {
        Tcl_DStringInit(&ds);
        if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
	    Tcl_DStringFree(&ds);
	    return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }
    if (objc == 3) {
        Tcl_DStringInit(&ds);
	optionName = Tcl_GetString(objv[2]);
        if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
            Tcl_DStringFree(&ds);
            return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }

    for (i = 3; i < objc; i += 2) {
	optionName = Tcl_GetString(objv[i-1]);
	valueName = Tcl_GetString(objv[i]);
        if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
		!= TCL_OK) {
            return TCL_ERROR;
        }
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_EofObjCmd --
 *
 *	This procedure is invoked to process the Tcl "eof" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether
 *	the specified channel has an EOF condition.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_EofObjCmd(unused, interp, objc, objv)
    ClientData unused;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int dummy;
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
        return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, &dummy);
    if (chan == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan)));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExecObjCmd --
 *
 *	This procedure is invoked to process the "exec" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|




|

>



|

>

|
|


|
|
|
<
|
|

|
|
|
|
|
|

>



|

|
|

>








|
|





|
|


















|

















|
|







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683

684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    char *chanName, *optionName, *valueName;
    Tcl_Channel chan;			/* The channel to set a mode on. */
    int i;				/* Iterate over arg-value pairs. */
    Tcl_DString ds;			/* DString to hold result of calling
					 * Tcl_GetChannelOption. */

    if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"channelId ?optionName? ?value? ?optionName value?...");
	return TCL_ERROR;
    }

    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (objc == 2) {
	Tcl_DStringInit(&ds);
	if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
	    Tcl_DStringFree(&ds);
	    return TCL_ERROR;
	}
	Tcl_DStringResult(interp, &ds);
	return TCL_OK;

    } else if (objc == 3) {
	Tcl_DStringInit(&ds);
	optionName = Tcl_GetString(objv[2]);
	if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
	    Tcl_DStringFree(&ds);
	    return TCL_ERROR;
	}
	Tcl_DStringResult(interp, &ds);
	return TCL_OK;
    }

    for (i = 3; i < objc; i += 2) {
	optionName = Tcl_GetString(objv[i-1]);
	valueName = Tcl_GetString(objv[i]);
	if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
		!= TCL_OK) {
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_EofObjCmd --
 *
 *	This procedure is invoked to process the Tcl "eof" command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether the
 *	specified channel has an EOF condition.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_EofObjCmd(unused, interp, objc, objv)
    ClientData unused;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int dummy;
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, &dummy);
    if (chan == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan)));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExecObjCmd --
 *
 *	This procedure is invoked to process the "exec" Tcl command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822






823
824
825
826

827
828
829

830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
     * See if the command is to be run in background.
     */

    background = 0;
    string = Tcl_GetString(objv[objc - 1]);
    if ((string[0] == '&') && (string[1] == '\0')) {
	objc--;
        background = 1;
    }

    /*
     * Create the string argument array "argv". Make sure argv is large
     * enough to hold the argc arguments plus 1 extra for the zero
     * end-of-argv word.
     */

    argv = argStorage;
    argc = objc - skip;
    if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
	argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
    }

    /*
     * Copy the string conversions of each (post option) object into the
     * argument vector.
     */

    for (i = 0; i < argc; i++) {
	argv[i] = Tcl_GetString(objv[i + skip]);
    }
    argv[argc] = NULL;
    chan = Tcl_OpenCommandChannel(interp, argc, argv,
            (background ? 0 : TCL_STDOUT | TCL_STDERR));

    /*
     * Free the argv array if malloc'ed storage was used.
     */

    if (argv != argStorage) {
	ckfree((char *)argv);
    }

    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (background) {
        /*
	 * Store the list of PIDs from the pipeline in interp's result and
	 * detach the PIDs (instead of waiting for them).
	 */

        TclGetAndDetachPids(interp, chan);
        if (Tcl_Close(interp, chan) != TCL_OK) {
	    return TCL_ERROR;
        }
	return TCL_OK;
    }

    resultPtr = Tcl_NewObj();
    if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
	if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {






	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading output from command: ",
		    Tcl_PosixError(interp), (char *) NULL);
	    Tcl_DecrRefCount(resultPtr);

	    return TCL_ERROR;
	}
    }

    /*
     * If the process produced anything on stderr, it will have been
     * returned in the interpreter result.  It needs to be appended to
     * the result string.
     */

    result = Tcl_Close(interp, chan);
    Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));

    /*
     * If the last character of the result is a newline, then remove
     * the newline character.
     */
    
    if (keepNewline == 0) {
	string = Tcl_GetStringFromObj(resultPtr, &length);
	if ((length > 0) && (string[length - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FblockedObjCmd --
 *
 *	This procedure is invoked to process the Tcl "fblocked" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether
 *	the preceeding input operation on the channel would have blocked.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FblockedObjCmd(unused, interp, objc, objv)
    ClientData unused;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int mode;
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
        return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, &mode);
    if (chan == NULL) {
        return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"",
		arg, "\" wasn't opened for reading", (char *) NULL);
        return TCL_ERROR;
    }
        
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan)));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenObjCmd --
 *
 *	This procedure is invoked to process the "open" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|



|
|
<


















|














|




|
|

|






>
>
>
>
>
>
|
|
|
|
>



>

|
|
|






|
|

|
















|
|





|
|


















|





|


|
|
|

|









|
|







824
825
826
827
828
829
830
831
832
833
834
835
836

837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
     * See if the command is to be run in background.
     */

    background = 0;
    string = Tcl_GetString(objv[objc - 1]);
    if ((string[0] == '&') && (string[1] == '\0')) {
	objc--;
	background = 1;
    }

    /*
     * Create the string argument array "argv". Make sure argv is large enough
     * to hold the argc arguments plus 1 extra for the zero end-of-argv word.

     */

    argv = argStorage;
    argc = objc - skip;
    if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
	argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
    }

    /*
     * Copy the string conversions of each (post option) object into the
     * argument vector.
     */

    for (i = 0; i < argc; i++) {
	argv[i] = Tcl_GetString(objv[i + skip]);
    }
    argv[argc] = NULL;
    chan = Tcl_OpenCommandChannel(interp, argc, argv,
	    (background ? 0 : TCL_STDOUT | TCL_STDERR));

    /*
     * Free the argv array if malloc'ed storage was used.
     */

    if (argv != argStorage) {
	ckfree((char *)argv);
    }

    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (background) {
	/*
	 * Store the list of PIDs from the pipeline in interp's result and
	 * detach the PIDs (instead of waiting for them).
	 */

	TclGetAndDetachPids(interp, chan);
	if (Tcl_Close(interp, chan) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    resultPtr = Tcl_NewObj();
    if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
	if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
	    /* TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */
	    if (!TclChanCaughtErrorBypass (interp, chan)) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "error reading output from command: ",
				 Tcl_PosixError(interp), (char *) NULL);
		Tcl_DecrRefCount(resultPtr);
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * If the process produced anything on stderr, it will have been returned
     * in the interpreter result.  It needs to be appended to the result
     * string.
     */

    result = Tcl_Close(interp, chan);
    Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));

    /*
     * If the last character of the result is a newline, then remove the
     * newline character.
     */

    if (keepNewline == 0) {
	string = Tcl_GetStringFromObj(resultPtr, &length);
	if ((length > 0) && (string[length - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FblockedObjCmd --
 *
 *	This procedure is invoked to process the Tcl "fblocked" command.  See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether the
 *	preceeding input operation on the channel would have blocked.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FblockedObjCmd(unused, interp, objc, objv)
    ClientData unused;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int mode;
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, &mode);
    if (chan == NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", arg,
		"\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan)));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenObjCmd --
 *
 *	This procedure is invoked to process the "open" Tcl command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974

975
976
977
978
979
980
981
982
983
984
985
986
987
988
989


990

991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
    }

    /*
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
        chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
    } else {
	int mode, seekFlag, cmdObjc;
	CONST char **cmdArgv;

        if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
            return TCL_ERROR;
        }

        mode = TclGetOpenMode(interp, modeString, &seekFlag);
        if (mode == -1) {
	    chan = NULL;
        } else {
	    int flags = TCL_STDERR | TCL_ENFORCE_MODE;

	    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
		case O_RDONLY:
		    flags |= TCL_STDOUT;
		    break;
		case O_WRONLY:
		    flags |= TCL_STDIN;
		    break;
		case O_RDWR:
		    flags |= (TCL_STDIN | TCL_STDOUT);
		    break;
		default:
		    Tcl_Panic("Tcl_OpenCmd: invalid mode value");
		    break;
	    }
	    chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);


	}

        ckfree((char *) cmdArgv);
    }
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }
    Tcl_RegisterChannel(interp, chan);
    Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAcceptCallbacksDeleteProc --
 *
 *	Assocdata cleanup routine called when an interpreter is being
 *	deleted to set the interp field of all the accept callback records
 *	registered with	the interpreter to NULL. This will prevent the
 *	interpreter from being used in the future to eval accept scripts.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates memory and sets the interp field of all the accept
 *	callback records to NULL to prevent this interpreter from being
 *	used subsequently to eval accept scripts.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(clientData, interp)
    ClientData clientData;	/* Data which was passed when the assocdata
                                 * was registered. */
    Tcl_Interp *interp;		/* Interpreter being deleted - not used. */
{
    Tcl_HashTable *hTblPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;
    AcceptCallback *acceptCallbackPtr;

    hTblPtr = (Tcl_HashTable *) clientData;
    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
             hPtr != (Tcl_HashEntry *) NULL;
             hPtr = Tcl_NextHashEntry(&hSearch)) {
        acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
        acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
    }
    Tcl_DeleteHashTable(hTblPtr);
    ckfree((char *) hTblPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * RegisterTcpServerInterpCleanup --
 *
 *	Registers an accept callback record to have its interp
 *	field set to NULL when the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When, in the future, the interpreter is deleted, the interp
 *	field of the accept callback data structure will be set to
 *	NULL. This will prevent attempts to eval the accept script
 *	in a deleted interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
    Tcl_Interp *interp;		/* Interpreter for which we want to be
                                 * informed of deletion. */
    AcceptCallback *acceptCallbackPtr;
    				/* The accept callback record whose
                                 * interp field we want set to NULL when
                                 * the interpreter is deleted. */
{
    Tcl_HashTable *hTblPtr;	/* Hash table for accept callback
                                 * records to smash when the interpreter
                                 * will be deleted. */
    Tcl_HashEntry *hPtr;	/* Entry for this record. */
    int new;			/* Is the entry new? */

    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
            "tclTCPAcceptCallbacks",
            NULL);
    if (hTblPtr == (Tcl_HashTable *) NULL) {
        hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
        Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
        (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
                TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
    }
    hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
    if (!new) {
        Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table");
    }
    Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * UnregisterTcpServerInterpCleanupProc --
 *
 *	Unregister a previously registered accept callback record. The
 *	interp field of this record will no longer be set to NULL in
 *	the future when the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Prevents the interp field of the accept callback record from
 *	being set to NULL in the future when the interpreter is deleted.
 *
 *----------------------------------------------------------------------
 */

static void
UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
    Tcl_Interp *interp;		/* Interpreter in which the accept callback
                                 * record was registered. */
    AcceptCallback *acceptCallbackPtr;
    				/* The record for which to delete the
                                 * registration. */
{
    Tcl_HashTable *hTblPtr;
    Tcl_HashEntry *hPtr;

    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
            "tclTCPAcceptCallbacks", NULL);
    if (hTblPtr == (Tcl_HashTable *) NULL) {
        return;
    }
    hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return;
    }
    Tcl_DeleteHashEntry(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AcceptCallbackProc --
 *
 *	This callback is invoked by the TCP channel driver when it
 *	accepts a new connection from a client on a server socket.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the script does.
 *
 *----------------------------------------------------------------------
 */

static void
AcceptCallbackProc(callbackData, chan, address, port)
    ClientData callbackData;		/* The data stored when the callback
                                         * was created in the call to
                                         * Tcl_OpenTcpServer. */
    Tcl_Channel chan;			/* Channel for the newly accepted
                                         * connection. */
    char *address;			/* Address of client that was
                                         * accepted. */
    int port;				/* Port of client that was accepted. */
{
    AcceptCallback *acceptCallbackPtr;
    Tcl_Interp *interp;
    char *script;
    char portBuf[TCL_INTEGER_SPACE];
    int result;

    acceptCallbackPtr = (AcceptCallback *) callbackData;

    /*
     * Check if the callback is still valid; the interpreter may have gone
     * away, this is signalled by setting the interp field of the callback
     * data to NULL.
     */
    
    if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {

        script = acceptCallbackPtr->script;
        interp = acceptCallbackPtr->interp;
        
        Tcl_Preserve((ClientData) script);
        Tcl_Preserve((ClientData) interp);

	TclFormatInt(portBuf, port);
        Tcl_RegisterChannel(interp, chan);

        /*
         * Artificially bump the refcount to protect the channel from
         * being deleted while the script is being evaluated.
         */

        Tcl_RegisterChannel((Tcl_Interp *) NULL,  chan);
        
        result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
                " ", address, " ", portBuf, (char *) NULL);
        if (result != TCL_OK) {
            Tcl_BackgroundError(interp);
	    Tcl_UnregisterChannel(interp, chan);
        }

        /*
         * Decrement the artificially bumped refcount. After this it is
         * not safe anymore to use "chan", because it may now be deleted.
         */

        Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
        
        Tcl_Release((ClientData) interp);
        Tcl_Release((ClientData) script);
    } else {

        /*
         * The interpreter has been deleted, so there is no useful
         * way to utilize the client socket - just close it.
         */

        Tcl_Close((Tcl_Interp *) NULL, chan);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpServerCloseProc --
 *
 *	This callback is called when the TCP server channel for which it
 *	was registered is being closed. It informs the interpreter in
 *	which the accept script is evaluated (if that interpreter still
 *	exists) that this channel no longer needs to be informed if the
 *	interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	In the future, if the interpreter is deleted this channel will
 *	no longer be informed.
 *
 *----------------------------------------------------------------------
 */

static void
TcpServerCloseProc(callbackData)
    ClientData callbackData;	/* The data passed in the call to
                                 * Tcl_CreateCloseHandler. */
{
    AcceptCallback *acceptCallbackPtr;
    				/* The actual data. */

    acceptCallbackPtr = (AcceptCallback *) callbackData;
    if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
        UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
                acceptCallbackPtr);
    }
    Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
    ckfree((char *) acceptCallbackPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SocketObjCmd --
 *
 *	This procedure is invoked to process the "socket" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates a socket based channel.
 *







|

|


|
|
|

|
|

|

>

|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
>
|


|











|
|
|
|






|
|








|









|
|
|
|










|
|





|
|
|
<







|

|
|
|

|
|
|




|
<

|
|
|
|



|









|
|
|





|
|







|

|
|





|

|



|









|
|













|
|

|

|















|


|
|
|
|
|


|

|
|
|
|

|
|
|
|
|
|

|

|
|
|
|

|
|
|
|


|
|
|
|

|








|
|
|
|
|





|
|







|


|



|
|










|
|







1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133

1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154

1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
    }

    /*
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
	chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
    } else {
	int mode, seekFlag, cmdObjc, binary;
	CONST char **cmdArgv;

	if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
	    return TCL_ERROR;
	}

	mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
	if (mode == -1) {
	    chan = NULL;
	} else {
	    int flags = TCL_STDERR | TCL_ENFORCE_MODE;

	    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	    case O_RDONLY:
		flags |= TCL_STDOUT;
		break;
	    case O_WRONLY:
		flags |= TCL_STDIN;
		break;
	    case O_RDWR:
		flags |= (TCL_STDIN | TCL_STDOUT);
		break;
	    default:
		Tcl_Panic("Tcl_OpenCmd: invalid mode value");
		break;
	    }
	    chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
	    if (binary) {
		Tcl_SetChannelOption(interp, chan, "-translation", "binary");
	    }
	}
	ckfree((char *) cmdArgv);
    }
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    Tcl_RegisterChannel(interp, chan);
    Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAcceptCallbacksDeleteProc --
 *
 *	Assocdata cleanup routine called when an interpreter is being deleted
 *	to set the interp field of all the accept callback records registered
 *	with the interpreter to NULL. This will prevent the interpreter from
 *	being used in the future to eval accept scripts.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates memory and sets the interp field of all the accept
 *	callback records to NULL to prevent this interpreter from being used
 *	subsequently to eval accept scripts.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(clientData, interp)
    ClientData clientData;	/* Data which was passed when the assocdata
				 * was registered. */
    Tcl_Interp *interp;		/* Interpreter being deleted - not used. */
{
    Tcl_HashTable *hTblPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;
    AcceptCallback *acceptCallbackPtr;

    hTblPtr = (Tcl_HashTable *) clientData;
    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
	    hPtr != (Tcl_HashEntry *) NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
	acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
    }
    Tcl_DeleteHashTable(hTblPtr);
    ckfree((char *) hTblPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * RegisterTcpServerInterpCleanup --
 *
 *	Registers an accept callback record to have its interp field set to
 *	NULL when the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When, in the future, the interpreter is deleted, the interp field of
 *	the accept callback data structure will be set to NULL. This will
 *	prevent attempts to eval the accept script in a deleted interpreter.

 *
 *----------------------------------------------------------------------
 */

static void
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
    Tcl_Interp *interp;		/* Interpreter for which we want to be
				 * informed of deletion. */
    AcceptCallback *acceptCallbackPtr;
				/* The accept callback record whose interp
				 * field we want set to NULL when the
				 * interpreter is deleted. */
{
    Tcl_HashTable *hTblPtr;	/* Hash table for accept callback records to
				 * smash when the interpreter will be
				 * deleted. */
    Tcl_HashEntry *hPtr;	/* Entry for this record. */
    int new;			/* Is the entry new? */

    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
	    "tclTCPAcceptCallbacks", NULL);

    if (hTblPtr == (Tcl_HashTable *) NULL) {
	hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
	Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
	(void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
		TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
    }
    hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
    if (!new) {
	Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table");
    }
    Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * UnregisterTcpServerInterpCleanupProc --
 *
 *	Unregister a previously registered accept callback record. The interp
 *	field of this record will no longer be set to NULL in the future when
 *	the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Prevents the interp field of the accept callback record from being set
 *	to NULL in the future when the interpreter is deleted.
 *
 *----------------------------------------------------------------------
 */

static void
UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
    Tcl_Interp *interp;		/* Interpreter in which the accept callback
				 * record was registered. */
    AcceptCallback *acceptCallbackPtr;
				/* The record for which to delete the
				 * registration. */
{
    Tcl_HashTable *hTblPtr;
    Tcl_HashEntry *hPtr;

    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
	    "tclTCPAcceptCallbacks", NULL);
    if (hTblPtr == (Tcl_HashTable *) NULL) {
	return;
    }
    hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
    if (hPtr == (Tcl_HashEntry *) NULL) {
	return;
    }
    Tcl_DeleteHashEntry(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AcceptCallbackProc --
 *
 *	This callback is invoked by the TCP channel driver when it accepts a
 *	new connection from a client on a server socket.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the script does.
 *
 *----------------------------------------------------------------------
 */

static void
AcceptCallbackProc(callbackData, chan, address, port)
    ClientData callbackData;		/* The data stored when the callback
					 * was created in the call to
					 * Tcl_OpenTcpServer. */
    Tcl_Channel chan;			/* Channel for the newly accepted
					 * connection. */
    char *address;			/* Address of client that was
					 * accepted. */
    int port;				/* Port of client that was accepted. */
{
    AcceptCallback *acceptCallbackPtr;
    Tcl_Interp *interp;
    char *script;
    char portBuf[TCL_INTEGER_SPACE];
    int result;

    acceptCallbackPtr = (AcceptCallback *) callbackData;

    /*
     * Check if the callback is still valid; the interpreter may have gone
     * away, this is signalled by setting the interp field of the callback
     * data to NULL.
     */

    if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {

	script = acceptCallbackPtr->script;
	interp = acceptCallbackPtr->interp;

	Tcl_Preserve((ClientData) script);
	Tcl_Preserve((ClientData) interp);

	TclFormatInt(portBuf, port);
	Tcl_RegisterChannel(interp, chan);

	/*
	 * Artificially bump the refcount to protect the channel from being
	 * deleted while the script is being evaluated.
	 */

	Tcl_RegisterChannel((Tcl_Interp *) NULL,  chan);

	result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
		" ", address, " ", portBuf, (char *) NULL);
	if (result != TCL_OK) {
	    Tcl_BackgroundError(interp);
	    Tcl_UnregisterChannel(interp, chan);
	}

	/*
	 * Decrement the artificially bumped refcount. After this it is not
	 * safe anymore to use "chan", because it may now be deleted.
	 */

	Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);

	Tcl_Release((ClientData) interp);
	Tcl_Release((ClientData) script);
    } else {

	/*
	 * The interpreter has been deleted, so there is no useful way to
	 * utilize the client socket - just close it.
	 */

	Tcl_Close((Tcl_Interp *) NULL, chan);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpServerCloseProc --
 *
 *	This callback is called when the TCP server channel for which it was
 *	registered is being closed. It informs the interpreter in which the
 *	accept script is evaluated (if that interpreter still exists) that
 *	this channel no longer needs to be informed if the interpreter is
 *	deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	In the future, if the interpreter is deleted this channel will no
 *	longer be informed.
 *
 *----------------------------------------------------------------------
 */

static void
TcpServerCloseProc(callbackData)
    ClientData callbackData;	/* The data passed in the call to
				 * Tcl_CreateCloseHandler. */
{
    AcceptCallback *acceptCallbackPtr;
				/* The actual data. */

    acceptCallbackPtr = (AcceptCallback *) callbackData;
    if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
	UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
		acceptCallbackPtr);
    }
    Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
    ckfree((char *) acceptCallbackPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SocketObjCmd --
 *
 *	This procedure is invoked to process the "socket" Tcl command.  See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates a socket based channel.
 *
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340

1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388


1389
1390
1391
1392

1393
1394
1395

1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static CONST char *socketOptions[] = {
	"-async", "-myaddr", "-myport","-server", (char *) NULL
    };
    enum socketOptions {
	SKT_ASYNC,      SKT_MYADDR,      SKT_MYPORT,      SKT_SERVER  
    };
    int optionIndex, a, server, port;
    char *arg, *copyScript, *host, *script;
    char *myaddr = NULL;
    int myport = 0;
    int async = 0;
    Tcl_Channel chan;
    AcceptCallback *acceptCallbackPtr;
    
    server = 0;
    script = NULL;

    if (TclpHasSockets(interp) != TCL_OK) {
	return TCL_ERROR;
    }

    for (a = 1; a < objc; a++) {
	arg = Tcl_GetString(objv[a]);
	if (arg[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions,
		"option", TCL_EXACT, &optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum socketOptions) optionIndex) {
	    case SKT_ASYNC: {
                if (server == 1) {
                    Tcl_AppendResult(interp,
                            "cannot set -async option for server sockets",
                            (char *) NULL);
                    return TCL_ERROR;
                }
                async = 1;		
		break;
	    }
	    case SKT_MYADDR: {
		a++;
                if (a >= objc) {
		    Tcl_AppendResult(interp,
			    "no argument given for -myaddr option",
                            (char *) NULL);
		    return TCL_ERROR;
		}
                myaddr = Tcl_GetString(objv[a]);
		break;
	    }
	    case SKT_MYPORT: {
		char *myPortName;

		a++;
                if (a >= objc) {
		    Tcl_AppendResult(interp,
			    "no argument given for -myport option",
                            (char *) NULL);
		    return TCL_ERROR;
		}
		myPortName = Tcl_GetString(objv[a]);
		if (TclSockGetPort(interp, myPortName, "tcp", &myport)
			!= TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    }
	    case SKT_SERVER: {
                if (async == 1) {
                    Tcl_AppendResult(interp,
                            "cannot set -async option for server sockets",
                            (char *) NULL);
                    return TCL_ERROR;
                }
		server = 1;
		a++;
		if (a >= objc) {
		    Tcl_AppendResult(interp,
			    "no argument given for -server option",
                            (char *) NULL);
		    return TCL_ERROR;
		}
                script = Tcl_GetString(objv[a]);
		break;
	    }
	    default: {
		Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
	    }
	}
    }
    if (server) {
        host = myaddr;		/* NULL implies INADDR_ANY */
	if (myport != 0) {
	    Tcl_AppendResult(interp, "Option -myport is not valid for servers",
		    NULL);
	    return TCL_ERROR;
	}
    } else if (a < objc) {
	host = Tcl_GetString(objv[a]);
	a++;
    } else {


wrongNumArgs:
	Tcl_AppendResult(interp, "wrong # args: should be either:\n",
		Tcl_GetString(objv[0]),
                " ?-myaddr addr? ?-myport myport? ?-async? host port\n",

		Tcl_GetString(objv[0]),
                " -server command ?-myaddr addr? port",
                (char *) NULL);

        return TCL_ERROR;
    }

    if (a == objc-1) {
	if (TclSockGetPort(interp, Tcl_GetString(objv[a]),
		"tcp", &port) != TCL_OK) {
	    return TCL_ERROR;
	}
    } else {
	goto wrongNumArgs;
    }

    if (server) {
        acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
                sizeof(AcceptCallback));
        copyScript = ckalloc((unsigned) strlen(script) + 1);
        strcpy(copyScript, script);
        acceptCallbackPtr->script = copyScript;
        acceptCallbackPtr->interp = interp;
        chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
                (ClientData) acceptCallbackPtr);
        if (chan == (Tcl_Channel) NULL) {
            ckfree(copyScript);
            ckfree((char *) acceptCallbackPtr);
            return TCL_ERROR;
        }

        /*
         * Register with the interpreter to let us know when the
         * interpreter is deleted (by having the callback set the
         * acceptCallbackPtr->interp field to NULL). This is to
         * avoid trying to eval the script in a deleted interpreter.
         */

        RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
        
        /*
         * Register a close callback. This callback will inform the
         * interpreter (if it still exists) that this channel does not
         * need to be informed when the interpreter is deleted.
         */
        
        Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
                (ClientData) acceptCallbackPtr);
    } else {
        chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
        if (chan == (Tcl_Channel) NULL) {
            return TCL_ERROR;
        }
    }
    Tcl_RegisterChannel(interp, chan);            
    Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FcopyObjCmd --
 *
 *	This procedure is invoked to process the "fcopy" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Moves data between two channels and possibly sets up a
 *	background copy handler.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FcopyObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|








|

















|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
<
|
|
>
|
|
|
|
<
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
<
|
|
<



|









>
>
|
|
|
|
>
|
|
<
>
|



|
|







|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|

|

|








|
|





|
|







1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398

1399
1400
1401
1402
1403

1404
1405
1406
1407

1408
1409
1410
1411
1412
1413
1414

1415
1416
1417
1418

1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434

1435
1436
1437
1438

1439
1440

1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462

1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static CONST char *socketOptions[] = {
	"-async", "-myaddr", "-myport","-server", (char *) NULL
    };
    enum socketOptions {
	SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
    };
    int optionIndex, a, server, port;
    char *arg, *copyScript, *host, *script;
    char *myaddr = NULL;
    int myport = 0;
    int async = 0;
    Tcl_Channel chan;
    AcceptCallback *acceptCallbackPtr;

    server = 0;
    script = NULL;

    if (TclpHasSockets(interp) != TCL_OK) {
	return TCL_ERROR;
    }

    for (a = 1; a < objc; a++) {
	arg = Tcl_GetString(objv[a]);
	if (arg[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions,
		"option", TCL_EXACT, &optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum socketOptions) optionIndex) {
	case SKT_ASYNC:
	    if (server == 1) {
		Tcl_AppendResult(interp,
			"cannot set -async option for server sockets",
			(char *) NULL);
		return TCL_ERROR;
	    }
	    async = 1;
	    break;

	case SKT_MYADDR:
	    a++;
	    if (a >= objc) {
		Tcl_AppendResult(interp,
			"no argument given for -myaddr option", (char *) NULL);

		return TCL_ERROR;
	    }
	    myaddr = Tcl_GetString(objv[a]);
	    break;

	case SKT_MYPORT: {
	    char *myPortName;

	    a++;
	    if (a >= objc) {
		Tcl_AppendResult(interp,
			"no argument given for -myport option", (char *) NULL);

		return TCL_ERROR;
	    }
	    myPortName = Tcl_GetString(objv[a]);
	    if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {

		return TCL_ERROR;
	    }
	    break;
	}
	case SKT_SERVER:
	    if (async == 1) {
		Tcl_AppendResult(interp,
			"cannot set -async option for server sockets",
			(char *) NULL);
		return TCL_ERROR;
	    }
	    server = 1;
	    a++;
	    if (a >= objc) {
		Tcl_AppendResult(interp,
			"no argument given for -server option", (char *) NULL);

		return TCL_ERROR;
	    }
	    script = Tcl_GetString(objv[a]);
	    break;

	default:
	    Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");

	}
    }
    if (server) {
	host = myaddr;		/* NULL implies INADDR_ANY */
	if (myport != 0) {
	    Tcl_AppendResult(interp, "Option -myport is not valid for servers",
		    NULL);
	    return TCL_ERROR;
	}
    } else if (a < objc) {
	host = Tcl_GetString(objv[a]);
	a++;
    } else {
	Interp *iPtr;

    wrongNumArgs:
	iPtr = (Interp *) interp;
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-myaddr addr? ?-myport myport? ?-async? host port");
	iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_WrongNumArgs(interp, 1, objv,
		"-server command ?-myaddr addr? port");

	iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
	return TCL_ERROR;
    }

    if (a == objc-1) {
	if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp",
		&port) != TCL_OK) {
	    return TCL_ERROR;
	}
    } else {
	goto wrongNumArgs;
    }

    if (server) {
	acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
		sizeof(AcceptCallback));
	copyScript = ckalloc((unsigned) strlen(script) + 1);
	strcpy(copyScript, script);
	acceptCallbackPtr->script = copyScript;
	acceptCallbackPtr->interp = interp;
	chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
		(ClientData) acceptCallbackPtr);
	if (chan == (Tcl_Channel) NULL) {
	    ckfree(copyScript);
	    ckfree((char *) acceptCallbackPtr);
	    return TCL_ERROR;
	}

	/*
	 * Register with the interpreter to let us know when the interpreter
	 * is deleted (by having the callback set the interp field of the
	 * acceptCallbackPtr's structure to NULL). This is to avoid trying to
	 * eval the script in a deleted interpreter.
	 */

	RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);

	/*
	 * Register a close callback. This callback will inform the
	 * interpreter (if it still exists) that this channel does not need to
	 * be informed when the interpreter is deleted.
	 */

	Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
		(ClientData) acceptCallbackPtr);
    } else {
	chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
    }
    Tcl_RegisterChannel(interp, chan);
    Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FcopyObjCmd --
 *
 *	This procedure is invoked to process the "fcopy" Tcl command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Moves data between two channels and possibly sets up a background copy
 *	handler.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FcopyObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537




















































































    if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"input output ?-size size? ?-command callback?");
	return TCL_ERROR;
    }

    /*
     * Parse the channel arguments and verify that they are readable
     * or writable, as appropriate.
     */

    arg = Tcl_GetString(objv[1]);
    inChan = Tcl_GetChannel(interp, arg, &mode);
    if (inChan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", arg, 
                "\" wasn't opened for reading", (char *) NULL);
        return TCL_ERROR;
    }
    arg = Tcl_GetString(objv[2]);
    outChan = Tcl_GetChannel(interp, arg, &mode);
    if (outChan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", arg, 
                "\" wasn't opened for writing", (char *) NULL);
        return TCL_ERROR;
    }

    toRead = -1;
    cmdPtr = NULL;
    for (i = 3; i < objc; i += 2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
		(int *) &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	    case FcopySize:
		if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    case FcopyCommand:
		cmdPtr = objv[i+1];
		break;
	}
    }

    return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
}



























































































|
|








|
|
|







|
|
|










|
|
|
|
|
|
|
|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
    if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"input output ?-size size? ?-command callback?");
	return TCL_ERROR;
    }

    /*
     * Parse the channel arguments and verify that they are readable or
     * writable, as appropriate.
     */

    arg = Tcl_GetString(objv[1]);
    inChan = Tcl_GetChannel(interp, arg, &mode);
    if (inChan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", arg,
		"\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }
    arg = Tcl_GetString(objv[2]);
    outChan = Tcl_GetChannel(interp, arg, &mode);
    if (outChan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", arg,
		"\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    }

    toRead = -1;
    cmdPtr = NULL;
    for (i = 3; i < objc; i += 2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
		(int *) &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case FcopySize:
	    if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case FcopyCommand:
	    cmdPtr = objv[i+1];
	    break;
	}
    }

    return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChanTruncateObjCmd --
 *
 *	This procedure is invoked to process the "chan truncate" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Truncates a channel (or rather a file underlying a channel).
 *
 *----------------------------------------------------------------------
 */

int
TclChanTruncateObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int mode;
    Tcl_WideInt length;
    char *chanName;

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?");
	return TCL_ERROR;
    }
    chanName = TclGetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, &mode);
    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (objc == 3) {
	/*
	 * User is supplying an explicit length.
	 */

	if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 0) {
	    Tcl_AppendResult(interp,
		    "cannot truncate to negative length of file", NULL);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * User wants to truncate to the current file position.
	 */

	length = Tcl_Tell(chan);
	if (length == Tcl_WideAsLong(-1)) {
	    Tcl_AppendResult(interp,
		    "could not determine current location in \"", chanName,
		    "\": ", Tcl_PosixError(interp), NULL);
	    return TCL_ERROR;
	}
    }

    if (Tcl_TruncateChannel(chan, length) != TCL_OK) {
	Tcl_AppendResult(interp, "error during truncate on \"", chanName,
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIOGT.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
/*
 * tclIOGT.c --
 *
 *	Implements a generic transformation exposing the underlying API
 *	at the script level.  Contributed by Andreas Kupries.
 *
 * Copyright (c) 2000 Ajuba Solutions
 * Copyright (c) 1999-2000 Andreas Kupries ([email protected])
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * CVS: $Id: tclIOGT.c,v 1.12 2004/11/13 00:19:09 dgp Exp $
 */

#include "tclInt.h"
#include "tclIO.h"


/*
 * Forward declarations of internal procedures.
 * First the driver procedures of the transformation.
 */

static int		TransformBlockModeProc _ANSI_ARGS_ ((
				ClientData instanceData, int mode));
static int		TransformCloseProc _ANSI_ARGS_ ((
				ClientData instanceData, Tcl_Interp* interp));
static int		TransformInputProc _ANSI_ARGS_ ((
				ClientData instanceData,
				char* buf, int toRead, int* errorCodePtr));
static int		TransformOutputProc _ANSI_ARGS_ ((
				ClientData instanceData, CONST char *buf,
				int toWrite, int* errorCodePtr));
static int		TransformSeekProc _ANSI_ARGS_ ((
				ClientData instanceData, long offset,
				int mode, int* errorCodePtr));
static int		TransformSetOptionProc _ANSI_ARGS_((
				ClientData instanceData, Tcl_Interp *interp,
				CONST char *optionName, CONST char *value));
static int		TransformGetOptionProc _ANSI_ARGS_((
				ClientData instanceData, Tcl_Interp *interp,
				CONST char *optionName, Tcl_DString *dsPtr));
static void		TransformWatchProc _ANSI_ARGS_ ((
				ClientData instanceData, int mask));
static int		TransformGetFileHandleProc _ANSI_ARGS_ ((
				ClientData instanceData, int direction,
				ClientData* handlePtr));
static int		TransformNotifyProc _ANSI_ARGS_ ((
				ClientData instanceData, int mask));
static Tcl_WideInt	TransformWideSeekProc _ANSI_ARGS_ ((
				ClientData instanceData, Tcl_WideInt offset,
				int mode, int* errorCodePtr));

/*
 * Forward declarations of internal procedures.
 * Secondly the procedures for handling and generating fileeevents.
 */

static void		TransformChannelHandlerTimer _ANSI_ARGS_ ((
				ClientData clientData));

/*
 * Forward declarations of internal procedures.
 * Third, helper procedures encapsulating essential tasks.
 */

typedef struct TransformChannelData TransformChannelData;

static int		ExecuteCallback _ANSI_ARGS_ ((
				TransformChannelData* ctrl, Tcl_Interp* interp,
				unsigned char* op, unsigned char* buf,
				int bufLen, int transmit, int preserve));

/*
 * Action codes to give to 'ExecuteCallback' (argument 'transmit')
 * confering to the procedure what to do with the result of the script
 * it calls.
 */

#define TRANSMIT_DONT  (0) /* No transfer to do */
#define TRANSMIT_DOWN  (1) /* Transfer to the underlying channel */
#define TRANSMIT_SELF  (2) /* Transfer into our channel. */
#define TRANSMIT_IBUF  (3) /* Transfer to internal input buffer */
#define TRANSMIT_NUM   (4) /* Transfer number to 'maxRead' */

/*
 * Codes for 'preserve' of 'ExecuteCallback'
 */

#define P_PRESERVE    (1)
#define P_NO_PRESERVE (0)

/*
 * Strings for the action codes delivered to the script implementing
 * a transformation. Argument 'op' of 'ExecuteCallback'.
 */

#define A_CREATE_WRITE	(UCHARP ("create/write"))
#define A_DELETE_WRITE	(UCHARP ("delete/write"))
#define A_FLUSH_WRITE	(UCHARP ("flush/write"))
#define A_WRITE		(UCHARP ("write"))

#define A_CREATE_READ	(UCHARP ("create/read"))
#define A_DELETE_READ	(UCHARP ("delete/read"))
#define A_FLUSH_READ	(UCHARP ("flush/read"))
#define A_READ		(UCHARP ("read"))

#define A_QUERY_MAXREAD (UCHARP ("query/maxRead"))
#define A_CLEAR_READ	(UCHARP ("clear/read"))

/*
 * Management of a simple buffer.
 */

typedef struct ResultBuffer ResultBuffer;

static void		ResultClear  _ANSI_ARGS_ ((ResultBuffer* r));
static void		ResultInit   _ANSI_ARGS_ ((ResultBuffer* r));
static int		ResultLength _ANSI_ARGS_ ((ResultBuffer* r));
static int		ResultCopy   _ANSI_ARGS_ ((ResultBuffer* r,
				unsigned char* buf, int toRead));
static void		ResultAdd    _ANSI_ARGS_ ((ResultBuffer* r,
				unsigned char* buf, int toWrite));

/*
 * This structure describes the channel type structure for tcl based
 * transformations.
 */

static Tcl_ChannelType transformChannelType = {
    "transform",			/* Type name. */
    TCL_CHANNEL_VERSION_3,
    TransformCloseProc,			/* Close proc. */












|




|
<

|
|


|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|


|
|


|
|


|
|




|
|
|
|


|
|
<


|
|
|
|
|





|
|


|
|


|
|
|
|

|
|
|
|

|
|







|
|
|
|
|
|
|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
/*
 * tclIOGT.c --
 *
 *	Implements a generic transformation exposing the underlying API
 *	at the script level.  Contributed by Andreas Kupries.
 *
 * Copyright (c) 2000 Ajuba Solutions
 * Copyright (c) 1999-2000 Andreas Kupries ([email protected])
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * CVS: $Id: tclIOGT.c,v 1.12.2.1 2005/08/02 18:15:32 dgp Exp $
 */

#include "tclInt.h"
#include "tclIO.h"


/*
 * Forward declarations of internal procedures.  First the driver procedures
 * of the transformation.
 */

static int		TransformBlockModeProc _ANSI_ARGS_((
			    ClientData instanceData, int mode));
static int		TransformCloseProc _ANSI_ARGS_((
			    ClientData instanceData, Tcl_Interp* interp));
static int		TransformInputProc _ANSI_ARGS_((
			    ClientData instanceData, char *buf, int toRead,
			    int *errorCodePtr));
static int		TransformOutputProc _ANSI_ARGS_((
			    ClientData instanceData, CONST char *buf,
			    int toWrite, int *errorCodePtr));
static int		TransformSeekProc _ANSI_ARGS_((
			    ClientData instanceData, long offset, int mode,
			    int *errorCodePtr));
static int		TransformSetOptionProc _ANSI_ARGS_((
			    ClientData instanceData, Tcl_Interp *interp,
			    CONST char *optionName, CONST char *value));
static int		TransformGetOptionProc _ANSI_ARGS_((
			    ClientData instanceData, Tcl_Interp *interp,
			    CONST char *optionName, Tcl_DString *dsPtr));
static void		TransformWatchProc _ANSI_ARGS_((
			    ClientData instanceData, int mask));
static int		TransformGetFileHandleProc _ANSI_ARGS_((
			    ClientData instanceData, int direction,
			    ClientData *handlePtr));
static int		TransformNotifyProc _ANSI_ARGS_((
			    ClientData instanceData, int mask));
static Tcl_WideInt	TransformWideSeekProc _ANSI_ARGS_((
			    ClientData instanceData, Tcl_WideInt offset,
			    int mode, int *errorCodePtr));

/*
 * Forward declarations of internal procedures.  Secondly the procedures for
 * handling and generating fileeevents.
 */

static void		TransformChannelHandlerTimer _ANSI_ARGS_((
			    ClientData clientData));

/*
 * Forward declarations of internal procedures.  Third, helper procedures
 * encapsulating essential tasks.
 */

typedef struct TransformChannelData TransformChannelData;

static int		ExecuteCallback _ANSI_ARGS_((
			    TransformChannelData *ctrl, Tcl_Interp *interp,
			    unsigned char *op, unsigned char *buf, int bufLen,
			    int transmit, int preserve));

/*
 * Action codes to give to 'ExecuteCallback' (argument 'transmit') confering
 * to the procedure what to do with the result of the script it calls.

 */

#define TRANSMIT_DONT	(0)	/* No transfer to do */
#define TRANSMIT_DOWN	(1)	/* Transfer to the underlying channel */
#define TRANSMIT_SELF	(2)	/* Transfer into our channel. */
#define TRANSMIT_IBUF	(3)	/* Transfer to internal input buffer */
#define TRANSMIT_NUM	(4)	/* Transfer number to 'maxRead' */

/*
 * Codes for 'preserve' of 'ExecuteCallback'
 */

#define P_PRESERVE	(1)
#define P_NO_PRESERVE	(0)

/*
 * Strings for the action codes delivered to the script implementing a
 * transformation. Argument 'op' of 'ExecuteCallback'.
 */

#define A_CREATE_WRITE	(UCHARP("create/write"))
#define A_DELETE_WRITE	(UCHARP("delete/write"))
#define A_FLUSH_WRITE	(UCHARP("flush/write"))
#define A_WRITE		(UCHARP("write"))

#define A_CREATE_READ	(UCHARP("create/read"))
#define A_DELETE_READ	(UCHARP("delete/read"))
#define A_FLUSH_READ	(UCHARP("flush/read"))
#define A_READ		(UCHARP("read"))

#define A_QUERY_MAXREAD	(UCHARP("query/maxRead"))
#define A_CLEAR_READ	(UCHARP("clear/read"))

/*
 * Management of a simple buffer.
 */

typedef struct ResultBuffer ResultBuffer;

static void		ResultClear  _ANSI_ARGS_((ResultBuffer *r));
static void		ResultInit   _ANSI_ARGS_((ResultBuffer *r));
static int		ResultLength _ANSI_ARGS_((ResultBuffer *r));
static int		ResultCopy   _ANSI_ARGS_((ResultBuffer *r,
			    unsigned char *buf, int toRead));
static void		ResultAdd    _ANSI_ARGS_((ResultBuffer *r,
			    unsigned char *buf, int toWrite));

/*
 * This structure describes the channel type structure for Tcl based
 * transformations.
 */

static Tcl_ChannelType transformChannelType = {
    "transform",			/* Type name. */
    TCL_CHANNEL_VERSION_3,
    TransformCloseProc,			/* Close proc. */
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396

/*
 * Definition of the structure containing the information about the
 * internal input buffer.
 */

struct ResultBuffer {
    unsigned char* buf;       /* Reference to the buffer area */
    int		   allocated; /* Allocated size of the buffer area */
    int		   used;      /* Number of bytes in the buffer, <= allocated */

};

/*
 * Additional bytes to allocate during buffer expansion
 */

#define INCREMENT (512)

/*
 * Number of milliseconds to wait before firing an event to flush
 * out information waiting in buffers (fileevent support).
 */

#define FLUSH_DELAY (5)

/*
 * Convenience macro to make some casts easier to use.
 */

#define UCHARP(x) ((unsigned char*) (x))
#define NO_INTERP ((Tcl_Interp*) NULL)

/*
 * Definition of a structure used by all transformations generated here to
 * maintain their local state.
 */

struct TransformChannelData {

    /*
     * General section. Data to integrate the transformation into the channel
     * system.
     */

    Tcl_Channel self;     /* Our own Channel handle */
    int readIsFlushed;    /* Flag to note wether in.flushProc was called or not
			   */
    int flags;            /* Currently CHANNEL_ASYNC or zero */
    int watchMask;        /* Current watch/event/interest mask */
    int mode;             /* mode of parent channel, OR'ed combination of
			   * TCL_READABLE, TCL_WRITABLE */
    Tcl_TimerToken timer; /* Timer for automatic flushing of information
			   * sitting in an internal buffer. Required for full
			   * fileevent support */

    /*
     * Transformation specific data.
     */

    int maxRead;            /* Maximum allowed number of bytes to read, as
			     * given to us by the tcl script implementing the
			     * transformation. */
    Tcl_Interp*    interp;  /* Reference to the interpreter which created the
			     * transformation. Used to execute the code
			     * below. */
    Tcl_Obj*       command; /* Tcl code to execute for a buffer */
    ResultBuffer   result;  /* Internal buffer used to store the result of a
			     * transformation of incoming data. Additionally
			     * serves as buffer of all data not yet consumed by
			     * the reader. */
};


/*
 *----------------------------------------------------------------------
 *
 * TclChannelTransform --
 *
 *	Implements the Tcl "testchannel transform" debugging command.
 *	This is part of the testing environment.  This sets up a tcl
 *	script (cmdObjPtr) to be used as a transform on the channel.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
TclChannelTransform(interp, chan, cmdObjPtr)
    Tcl_Interp	*interp;	/* Interpreter for result. */
    Tcl_Channel chan;		/* Channel to transform. */
    Tcl_Obj	*cmdObjPtr;	/* Script to use for transform. */
{
    Channel			*chanPtr;	/* The actual channel. */
    ChannelState		*statePtr;	/* state info for channel */
    int				mode;		/* rw mode of the channel */
    TransformChannelData	*dataPtr;
    int				res;
    Tcl_DString			ds;

    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    chanPtr	= (Channel *) chan;
    statePtr	= chanPtr->state;
    chanPtr	= statePtr->topChanPtr;
    chan	= (Tcl_Channel) chanPtr;
    mode	= (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));

    /*
     * Now initialize the transformation state and stack it upon the
     * specified channel. One of the necessary things to do is to
     * retrieve the blocking regime of the underlying channel and to
     * use the same for us too.
     */

    dataPtr = (TransformChannelData*) ckalloc(sizeof(TransformChannelData));

    Tcl_DStringInit (&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);

    dataPtr->readIsFlushed = 0;
    dataPtr->flags	= 0;

    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }

    Tcl_DStringFree (&ds);

    dataPtr->self	= chan;
    dataPtr->watchMask	= 0;
    dataPtr->mode	= mode;
    dataPtr->timer	= (Tcl_TimerToken) NULL;
    dataPtr->maxRead	= 4096; /* Initial value not relevant */
    dataPtr->interp	= interp;
    dataPtr->command	= cmdObjPtr;

    Tcl_IncrRefCount(dataPtr->command);

    ResultInit(&dataPtr->result);

    dataPtr->self = Tcl_StackChannel(interp, &transformChannelType,
	    (ClientData) dataPtr, mode, chan);
    if (dataPtr->self == (Tcl_Channel) NULL) {
	Tcl_AppendResult(interp, "\nfailed to stack channel \"",
		Tcl_GetChannelName(chan), "\"", (char *) NULL);

	Tcl_DecrRefCount(dataPtr->command);
	ResultClear(&dataPtr->result);
	ckfree((VOID *) dataPtr);
	return TCL_ERROR;
    }

    /*
     * At last initialize the transformation at the script level.
     */

    if (dataPtr->mode & TCL_WRITABLE) {
	res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_WRITE,
		NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);

	if (res != TCL_OK) {
	    Tcl_UnstackChannel(interp, chan);
	    return TCL_ERROR;
	}
    }

    if (dataPtr->mode & TCL_READABLE) {
	res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_READ,
		NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);

	if (res != TCL_OK) {
	    ExecuteCallback (dataPtr, NO_INTERP, A_DELETE_WRITE,
		    NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);

	    Tcl_UnstackChannel(interp, chan);
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 *------------------------------------------------------*
 *
 *	ExecuteCallback --
 *
 *	Executes the defined callback for buffer and
 *	operation.
 *
 *	Sideeffects:
 *		As of the executed tcl script.
 *
 *	Result:
 *		A standard TCL error code. In case of an
 *		error a message is left in the result area
 *		of the specified interpreter.
 *
 *------------------------------------------------------*
 */

static int
ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve)
    TransformChannelData* dataPtr;  /* Transformation with the callback */
    Tcl_Interp*           interp;   /* Current interpreter, possibly NULL */

    unsigned char*        op;       /* Operation invoking the callback */
    unsigned char*        buf;      /* Buffer to give to the script. */
    int			  bufLen;   /* Ands its length */
    int                   transmit; /* Flag, determines whether the result
				     * of the callback is sent to the
				     * underlying channel or not. */
    int                   preserve; /* Flag. If true the procedure will
				     * preserver the result state of all
				     * accessed interpreters. */
{
    /*
     * Step 1, create the complete command to execute. Do this by appending
     * operation and buffer to operate upon to a copy of the callback
     * definition. We *cannot* create a list containing 3 objects and then use
     * 'Tcl_EvalObjv', because the command may contain additional prefixed
     * arguments. Feather's curried commands would come in handy here.
     */

    Tcl_Obj* resObj;		    /* See below, switch (transmit) */
    int resLen;
    unsigned char* resBuf;
    Tcl_InterpState state = NULL;
    int res = TCL_OK;
    Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command);
    Tcl_Obj* temp;

    if (preserve) {
	state = Tcl_SaveInterpState(dataPtr->interp, res);
    }

    if (command == (Tcl_Obj*) NULL) {
        /* Memory allocation problem */







|
|
|
>






|


|
|


|





|
|







<





|
|
|
|
|
|
|
|
|
|
>




|
|
|
|
|
|
|
|
|
|
|

<






|
|
|

















|
|
|
|
|
|




|
|
|
|
|


|
|
|
<


|











|

|
|
|
|
|
|
|













|








|
|








|
|


|
|










|

|

|
<

|
|

|
|
<
|

|



|
|
|
>
|
|
|
|
|
|
|
|
|









|

|


|
|







152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268

269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344

345
346
347
348
349
350

351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392

/*
 * Definition of the structure containing the information about the
 * internal input buffer.
 */

struct ResultBuffer {
    unsigned char *buf;		/* Reference to the buffer area. */
    int allocated;		/* Allocated size of the buffer area. */
    int used;			/* Number of bytes in the buffer, <=
				 * allocated. */
};

/*
 * Additional bytes to allocate during buffer expansion
 */

#define INCREMENT	(512)

/*
 * Number of milliseconds to wait before firing an event to flush out
 * information waiting in buffers (fileevent support).
 */

#define FLUSH_DELAY	(5)

/*
 * Convenience macro to make some casts easier to use.
 */

#define UCHARP(x)	((unsigned char *) (x))
#define NO_INTERP	((Tcl_Interp *) NULL)

/*
 * Definition of a structure used by all transformations generated here to
 * maintain their local state.
 */

struct TransformChannelData {

    /*
     * General section. Data to integrate the transformation into the channel
     * system.
     */

    Tcl_Channel self;		/* Our own Channel handle. */
    int readIsFlushed;		/* Flag to note whether in.flushProc was
				 * called or not. */
    int flags;			/* Currently CHANNEL_ASYNC or zero. */
    int watchMask;		/* Current watch/event/interest mask. */
    int mode;			/* Mode of parent channel, OR'ed combination
				 * of TCL_READABLE, TCL_WRITABLE. */
    Tcl_TimerToken timer;	/* Timer for automatic flushing of information
				 * sitting in an internal buffer. Required for
				 * full fileevent support. */

    /*
     * Transformation specific data.
     */

    int maxRead;		/* Maximum allowed number of bytes to read, as
				 * given to us by the tcl script implementing
				 * the transformation. */
    Tcl_Interp *interp;		/* Reference to the interpreter which created
				 * the transformation. Used to execute the
				 * code below. */
    Tcl_Obj *command;		/* Tcl code to execute for a buffer */
    ResultBuffer result;	/* Internal buffer used to store the result of
				 * a transformation of incoming data.
				 * Additionally serves as buffer of all data
				 * not yet consumed by the reader. */
};


/*
 *----------------------------------------------------------------------
 *
 * TclChannelTransform --
 *
 *	Implements the Tcl "testchannel transform" debugging command.  This is
 *	part of the testing environment. This sets up a tcl script (cmdObjPtr)
 *	to be used as a transform on the channel.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
TclChannelTransform(interp, chan, cmdObjPtr)
    Tcl_Interp	*interp;	/* Interpreter for result. */
    Tcl_Channel chan;		/* Channel to transform. */
    Tcl_Obj	*cmdObjPtr;	/* Script to use for transform. */
{
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* state info for channel */
    int mode;			/* rw mode of the channel */
    TransformChannelData *dataPtr;
    int res;
    Tcl_DString ds;

    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    chanPtr = (Channel *) chan;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;
    chan = (Tcl_Channel) chanPtr;
    mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));

    /*
     * Now initialize the transformation state and stack it upon the specified
     * channel. One of the necessary things to do is to retrieve the blocking
     * regime of the underlying channel and to use the same for us too.

     */

    dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData));

    Tcl_DStringInit (&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);

    dataPtr->readIsFlushed = 0;
    dataPtr->flags	= 0;

    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }

    Tcl_DStringFree(&ds);

    dataPtr->self = chan;
    dataPtr->watchMask = 0;
    dataPtr->mode = mode;
    dataPtr->timer = (Tcl_TimerToken) NULL;
    dataPtr->maxRead = 4096; /* Initial value not relevant */
    dataPtr->interp = interp;
    dataPtr->command = cmdObjPtr;

    Tcl_IncrRefCount(dataPtr->command);

    ResultInit(&dataPtr->result);

    dataPtr->self = Tcl_StackChannel(interp, &transformChannelType,
	    (ClientData) dataPtr, mode, chan);
    if (dataPtr->self == (Tcl_Channel) NULL) {
	Tcl_AppendResult(interp, "\nfailed to stack channel \"",
		Tcl_GetChannelName(chan), "\"", (char *) NULL);

	Tcl_DecrRefCount(dataPtr->command);
	ResultClear(&dataPtr->result);
	ckfree((char *) dataPtr);
	return TCL_ERROR;
    }

    /*
     * At last initialize the transformation at the script level.
     */

    if (dataPtr->mode & TCL_WRITABLE) {
	res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_WRITE, NULL, 0,
		TRANSMIT_DONT, P_NO_PRESERVE);

	if (res != TCL_OK) {
	    Tcl_UnstackChannel(interp, chan);
	    return TCL_ERROR;
	}
    }

    if (dataPtr->mode & TCL_READABLE) {
	res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_READ, NULL, 0,
		TRANSMIT_DONT, P_NO_PRESERVE);

	if (res != TCL_OK) {
	    ExecuteCallback(dataPtr, NO_INTERP, A_DELETE_WRITE, NULL, 0,
		    TRANSMIT_DONT, P_NO_PRESERVE);

	    Tcl_UnstackChannel(interp, chan);
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteCallback --
 *
 *	Executes the defined callback for buffer and operation.

 *
 * Side effects:
 *	As of the executed tcl script.
 *
 * Result:
 *	A standard TCL error code. In case of an error a message is left in

 *	the result area of the specified interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve)
    TransformChannelData *dataPtr;	/* Transformation with the callback */
    Tcl_Interp *interp;			/* Current interpreter, possibly
					 * NULL. */
    unsigned char *op;			/* Operation invoking the callback */
    unsigned char *buf;			/* Buffer to give to the script. */
    int bufLen;				/* And its length */
    int transmit;			/* Flag, determines whether the result
					 * of the callback is sent to the
					 * underlying channel or not. */
    int preserve;			/* Flag. If true the procedure will
					 * preserver the result state of all
					 * accessed interpreters. */
{
    /*
     * Step 1, create the complete command to execute. Do this by appending
     * operation and buffer to operate upon to a copy of the callback
     * definition. We *cannot* create a list containing 3 objects and then use
     * 'Tcl_EvalObjv', because the command may contain additional prefixed
     * arguments. Feather's curried commands would come in handy here.
     */

    Tcl_Obj *resObj;			/* See below, switch (transmit) */
    int resLen;
    unsigned char *resBuf;
    Tcl_InterpState state = NULL;
    int res = TCL_OK;
    Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command);
    Tcl_Obj *temp;

    if (preserve) {
	state = Tcl_SaveInterpState(dataPtr->interp, res);
    }

    if (command == (Tcl_Obj*) NULL) {
        /* Memory allocation problem */
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675

676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709

710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743

744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762

763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808

809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861

862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968

969
970
971
972
973
974
975
976
977
978
979

980
981
982
983

984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063

1064
1065

1066
1067
1068

1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088

1089
1090
1091
1092
1093
1094

1095
1096
1097
1098
1099
1100
1101
1102
1103
1104

1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163

1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255

1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372

1373
1374
1375
1376
1377
1378
1379

1380
1381
1382
1383
1384
1385
1386
1387
1388

1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401

1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435

1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452









    res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp);
    if (res != TCL_OK) {
	goto cleanup;
    }

    /*
     * Use a byte-array to prevent the misinterpretation of binary data
     * coming through as UTF while at the tcl level.
     */

    temp = Tcl_NewByteArrayObj(buf, bufLen);

    if (temp == (Tcl_Obj*) NULL) {
        /* Memory allocation problem */
	res = TCL_ERROR;
        goto cleanup;
    }

    res = Tcl_ListObjAppendElement (dataPtr->interp, command, temp);
    if (res != TCL_OK) {
        goto cleanup;
    }

    /*
     * Step 2, execute the command at the global level of the interpreter
     * used to create the transformation. Destroy the command afterward.
     * If an error occured and the current interpreter is defined and not
     * equal to the interpreter for the callback, then copy the error
     * message into current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_GlobalEvalObj (dataPtr->interp, command);
    Tcl_DecrRefCount (command);
    command = (Tcl_Obj*) NULL;

    if ((res != TCL_OK) && (interp != NO_INTERP) &&
	    (dataPtr->interp != interp) && !preserve) {
        Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp));
	return res;
    }

    /*
     * Step 3, transmit a possible conversion result to the underlying
     * channel, or ourselves.
     */

    switch (transmit) {
	case TRANSMIT_DONT:
	    /* nothing to do */
	    break;

	case TRANSMIT_DOWN:
	    resObj = Tcl_GetObjResult(dataPtr->interp);
	    resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen);
	    Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self),
		    (char*) resBuf, resLen);
	    break;

	case TRANSMIT_SELF:
	    resObj = Tcl_GetObjResult (dataPtr->interp);
	    resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen);
	    Tcl_WriteRaw(dataPtr->self, (char*) resBuf, resLen);
	    break;

	case TRANSMIT_IBUF:
	    resObj = Tcl_GetObjResult (dataPtr->interp);
	    resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen);
	    ResultAdd(&dataPtr->result, resBuf, resLen);
	    break;

	case TRANSMIT_NUM:
	    /* Interpret result as integer number */
	    resObj = Tcl_GetObjResult (dataPtr->interp);
	    Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
	    break;
    }

    Tcl_ResetResult(dataPtr->interp);

    if (preserve) {
	(void) Tcl_RestoreInterpState(dataPtr->interp, state);
    }

    return res;

    cleanup:
    if (preserve) {
	(void) Tcl_RestoreInterpState(dataPtr->interp, state);
    }

    if (command != (Tcl_Obj*) NULL) {
        Tcl_DecrRefCount(command);
    }

    return res;
}

/*
 *------------------------------------------------------*
 *
 *	TransformBlockModeProc --
 *
 *	Trap handler. Called by the generic IO system
 *	during option processing to change the blocking
 *	mode of the channel.
 *
 *	Sideeffects:
 *		Forwards the request to the underlying
 *		channel.
 *
 *	Result:
 *		0 if successful, errno when failed.
 *
 *------------------------------------------------------*
 */

static int
TransformBlockModeProc (instanceData, mode)
    ClientData  instanceData; /* State of transformation */
    int         mode;         /* New blocking mode */
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
        dataPtr->flags |= CHANNEL_ASYNC;
    } else {
        dataPtr->flags &= ~(CHANNEL_ASYNC);
    }
    return 0;
}

/*
 *------------------------------------------------------*
 *
 *	TransformCloseProc --
 *
 *	Trap handler. Called by the generic IO system
 *	during destruction of the transformation channel.
 *
 *	Sideeffects:
 *		Releases the memory allocated in
 *		'Tcl_TransformObjCmd'.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static int
TransformCloseProc (instanceData, interp)
    ClientData  instanceData;
    Tcl_Interp* interp;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;

    /*
     * Important: In this procedure 'dataPtr->self' already points to
     * the underlying channel.
     */

    /*
     * There is no need to cancel an existing channel handler, this is already
     * done. Either by 'Tcl_UnstackChannel' or by the general cleanup in
     * 'Tcl_Close'.
     *
     * But we have to cancel an active timer to prevent it from firing on the
     * removed channel.
     */

    if (dataPtr->timer != (Tcl_TimerToken) NULL) {
        Tcl_DeleteTimerHandler (dataPtr->timer);
	dataPtr->timer = (Tcl_TimerToken) NULL;
    }

    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver
     * for it anymore. But the scripts might have sideeffects other parts
     * of the system rely on (f.e. signaling the close to interested parties).
     */

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback (dataPtr, interp, A_FLUSH_WRITE,
		NULL, 0, TRANSMIT_DOWN, 1);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = 1;
        ExecuteCallback (dataPtr, interp, A_FLUSH_READ,
		NULL, 0, TRANSMIT_IBUF, 1);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback (dataPtr, interp, A_DELETE_WRITE,
		NULL, 0, TRANSMIT_DONT, 1);
    }

    if (dataPtr->mode & TCL_READABLE) {
        ExecuteCallback (dataPtr, interp, A_DELETE_READ,
		NULL, 0, TRANSMIT_DONT, 1);
    }

    /*
     * General cleanup
     */

    ResultClear(&dataPtr->result);
    Tcl_DecrRefCount(dataPtr->command);
    ckfree((VOID*) dataPtr);

    return TCL_OK;
}

/*
 *------------------------------------------------------*
 *
 *	TransformInputProc --
 *
 *	Called by the generic IO system to convert read data.
 *
 *	Sideeffects:
 *		As defined by the conversion.
 *
 *	Result:
 *		A transformed buffer.
 *
 *------------------------------------------------------*
 */

static int
TransformInputProc (instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;
    char*      buf;
    int	       toRead;
    int*       errorCodePtr;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    int gotBytes, read, res, copied;
    Tcl_Channel downChan;

    /* should assert (dataPtr->mode & TCL_READABLE) */

    if (toRead == 0) {

	/* Catch a no-op.
	 */
	return 0;
    }

    gotBytes = 0;
    downChan = Tcl_GetStackedChannel(dataPtr->self);

    while (toRead > 0) {
        /*
	 * Loop until the request is satisfied (or no data is available from
	 * below, possibly EOF).
	 */

        copied    = ResultCopy (&dataPtr->result, UCHARP (buf), toRead);

	toRead   -= copied;
	buf      += copied;
	gotBytes += copied;

	if (toRead == 0) {

	    /* The request was completely satisfied from our buffers.
	     * We can break out of the loop and return to the caller.
	     */
	    return gotBytes;
	}

	/*
	 * Length (dataPtr->result) == 0, toRead > 0 here . Use the incoming
	 * 'buf'! as target to store the intermediary information read
	 * from the underlying channel.
	 *
	 * Ask the tcl level how much data it allows us to read from
	 * the underlying channel. This feature allows the transform to
	 * signal EOF upstream although there is none downstream. Useful
	 * to control an unbounded 'fcopy', either through counting bytes,
	 * or by pattern matching.
	 */

	ExecuteCallback (dataPtr, NO_INTERP, A_QUERY_MAXREAD,
		NULL, 0, TRANSMIT_NUM /* -> maxRead */, 1);

	if (dataPtr->maxRead >= 0) {
	    if (dataPtr->maxRead < toRead) {
	        toRead = dataPtr->maxRead;
	    }
	} /* else: 'maxRead < 0' == Accept the current value of toRead */

	if (toRead <= 0) {
	    return gotBytes;
	}

	read = Tcl_ReadRaw(downChan, buf, toRead);

	if (read < 0) {

	    /* Report errors to caller. EAGAIN is a special situation.
	     * If we had some data before we report that instead of the
	     * request to re-try.
	     */

	    if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
	        return gotBytes;
	    }

	    *errorCodePtr = Tcl_GetErrno();
	    return -1;      
	}

	if (read == 0) {
	    /*
	     * Check wether we hit on EOF in the underlying channel or
	     * not. If not differentiate between blocking and
	     * non-blocking modes. In non-blocking mode we ran
	     * temporarily out of data. Signal this to the caller via
	     * EWOULDBLOCK and error return (-1). In the other cases
	     * we simply return what we got and let the caller wait
	     * for more. On the other hand, if we got an EOF we have
	     * to convert and flush all waiting partial data.
	     */

	    if (! Tcl_Eof (downChan)) {
	        if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) {
		    *errorCodePtr = EWOULDBLOCK;
		    return -1;
		} else {
		    return gotBytes;
		}
	    } else {
	        if (dataPtr->readIsFlushed) {

		    /* Already flushed, nothing to do anymore
		     */
		    return gotBytes;
		}

		dataPtr->readIsFlushed = 1;

		ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_READ,
			NULL, 0, TRANSMIT_IBUF, P_PRESERVE);

		if (ResultLength (&dataPtr->result) == 0) {
		    /* we had nothing to flush */
		    return gotBytes;
		}

		continue; /* at: while (toRead > 0) */
	    }
	} /* read == 0 */


	/* Transform the read chunk and add the result to our
	 * read buffer (dataPtr->result)
	 */

	res = ExecuteCallback (dataPtr, NO_INTERP, A_READ,
		UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE);

	if (res != TCL_OK) {
	    *errorCodePtr = EINVAL;
	    return -1;
	}
    } /* while toRead > 0 */

    return gotBytes;
}

/*
 *------------------------------------------------------*
 *
 *	TransformOutputProc --
 *
 *	Called by the generic IO system to convert data
 *	waiting to be written.
 *
 *	Sideeffects:
 *		As defined by the transformation.
 *
 *	Result:
 *		A transformed buffer.
 *
 *------------------------------------------------------*
 */

static int
TransformOutputProc (instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;
    CONST char*      buf;
    int        toWrite;
    int*       errorCodePtr;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    int res;

    /* should assert (dataPtr->mode & TCL_WRITABLE) */

    if (toWrite == 0) {

	/* Catch a no-op.
	 */
	return 0;
    }

    res = ExecuteCallback (dataPtr, NO_INTERP, A_WRITE,
	    UCHARP (buf), toWrite,
	    TRANSMIT_DOWN, P_NO_PRESERVE);

    if (res != TCL_OK) {
        *errorCodePtr = EINVAL;
	return -1;
    }

    return toWrite;
}

/*
 *------------------------------------------------------*
 *
 *	TransformSeekProc --
 *
 *	This procedure is called by the generic IO level
 *	to move the access point in a channel.
 *
 *	Sideeffects:
 *		Moves the location at which the channel
 *		will be accessed in future operations.
 *		Flushes all transformation buffers, then
 *		forwards it to the underlying channel.
 *
 *	Result:
 *		-1 if failed, the new position if
 *		successful. An output argument contains
 *		the POSIX error code if an error
 *		occurred, or zero.
 *
 *------------------------------------------------------*
 */

static int
TransformSeekProc (instanceData, offset, mode, errorCodePtr)
    ClientData  instanceData;	/* The channel to manipulate */
    long	offset;		/* Size of movement. */
    int         mode;		/* How to move */
    int*        errorCodePtr;	/* Location of error flag. */
{
    TransformChannelData* dataPtr	= (TransformChannelData*) instanceData;
    Tcl_Channel           parent        = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_ChannelType*      parentType	= Tcl_GetChannelType(parent);
    Tcl_DriverSeekProc*   parentSeekProc = Tcl_ChannelSeekProc(parentType);

    if ((offset == 0) && (mode == SEEK_CUR)) {

        /* This is no seek but a request to tell the caller the current
	 * location. Simply pass the request down.
	 */

	return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
		offset, mode, errorCodePtr);
    }

    /*
     * It is a real request to change the position. Flush all data waiting
     * for output and discard everything in the input buffers. Then pass
     * the request down, unchanged.
     */

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE,
		NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
        ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ,
		NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }

    return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
	    offset, mode, errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TransformWideSeekProc --
 *
 *	This procedure is called by the generic IO level to move the
 *	access point in a channel, with a (potentially) 64-bit offset.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in
 *	future operations.  Flushes all transformation buffers, then
 *	forwards it to the underlying channel.
 *
 * Result:
 *	-1 if failed, the new position if successful. An output
 *	argument contains the POSIX error code if an error occurred,
 *	or zero.
 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
TransformWideSeekProc (instanceData, offset, mode, errorCodePtr)
    ClientData  instanceData;	/* The channel to manipulate */
    Tcl_WideInt offset;		/* Size of movement. */
    int         mode;		/* How to move */
    int*        errorCodePtr;	/* Location of error flag. */
{
    TransformChannelData* dataPtr =
	(TransformChannelData*) instanceData;
    Tcl_Channel parent =
	Tcl_GetStackedChannel(dataPtr->self);
    Tcl_ChannelType* parentType	=
	Tcl_GetChannelType(parent);
    Tcl_DriverSeekProc* parentSeekProc =
	Tcl_ChannelSeekProc(parentType);
    Tcl_DriverWideSeekProc* parentWideSeekProc =
	Tcl_ChannelWideSeekProc(parentType);
    ClientData parentData =
	Tcl_GetChannelInstanceData(parent);

    if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {
        /*
	 * This is no seek but a request to tell the caller the current
	 * location. Simply pass the request down.
	 */

	if (parentWideSeekProc != NULL) {
	    return (*parentWideSeekProc) (parentData, offset, mode,
		    errorCodePtr);
	}

	return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode,
		errorCodePtr));
    }

    /*
     * It is a real request to change the position. Flush all data waiting
     * for output and discard everything in the input buffers. Then pass
     * the request down, unchanged.
     */

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE,
		NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
        ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ,
		NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }

    /*
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc != NULL) {
	return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr);
    }

    /*
     * We're transferring to narrow seeks at this point; this is a bit
     * complex because we have to check whether the seek is possible
     * first (i.e. whether we are losing information in truncating the
     * bits of the offset.)  Luckily, there's a defined error for what
     * happens when trying to go out of the representable range.
     */

    if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
	*errorCodePtr = EOVERFLOW;
	return Tcl_LongAsWide(-1);
    }

    return Tcl_LongAsWide((*parentSeekProc) (parentData,
	    Tcl_WideAsLong(offset), mode, errorCodePtr));
}

/*
 *------------------------------------------------------*
 *
 *	TransformSetOptionProc --
 *
 *	Called by generic layer to handle the reconfi-
 *	guration of channel specific options. As this
 *	channel type does not have such, it simply passes
 *	all requests downstream.
 *
 *	Sideeffects:
 *		As defined by the channel downstream.
 *
 *	Result:
 *		A standard TCL error code.
 *
 *------------------------------------------------------*
 */

static int
TransformSetOptionProc (instanceData, interp, optionName, value)
    ClientData instanceData;
    Tcl_Interp *interp;
    CONST char *optionName;
    CONST char *value;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_DriverSetOptionProc *setOptionProc;

    setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
    if (setOptionProc != NULL) {
	return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan),
		interp, optionName, value);
    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------*
 *
 *	TransformGetOptionProc --
 *
 *	Called by generic layer to handle requests for
 *	the values of channel specific options. As this
 *	channel type does not have such, it simply passes
 *	all requests downstream.
 *
 *	Sideeffects:
 *		As defined by the channel downstream.
 *
 *	Result:
 *		A standard TCL error code.
 *
 *------------------------------------------------------*
 */

static int
TransformGetOptionProc (instanceData, interp, optionName, dsPtr)
    ClientData   instanceData;
    Tcl_Interp*  interp;
    CONST char*        optionName;
    Tcl_DString* dsPtr;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_DriverGetOptionProc *getOptionProc;

    getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
    if (getOptionProc != NULL) {
	return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
		interp, optionName, dsPtr);
    } else if (optionName == (CONST char*) NULL) {
	/*
	 * Request is query for all options, this is ok.
	 */

	return TCL_OK;
    }

    /*
     * Request for a specific option has to fail, we don't have any.
     */

    return TCL_ERROR;
}

/*
 *------------------------------------------------------*
 *
 *	TransformWatchProc --
 *
 *	Initialize the notifier to watch for events from
 *	this channel.
 *
 *	Sideeffects:
 *		Sets up the notifier so that a future
 *		event on the channel will be seen by Tcl.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

	/* ARGSUSED */
static void
TransformWatchProc (instanceData, mask)
    ClientData instanceData;	/* Channel to watch */
    int        mask;		/* Events of interest */
{

    /* The caller expressed interest in events occuring for this
     * channel. We are forwarding the call to the underlying
     * channel now.
     */

    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    Tcl_Channel     downChan;

    dataPtr->watchMask = mask;


    /* No channel handlers any more. We will be notified automatically
     * about events on the channel below via a call to our
     * 'TransformNotifyProc'. But we have to pass the interest down now.
     * We are allowed to add additional 'interest' to the mask if we want
     * to. But this transformation has no such interest. It just passes
     * the request down, unchanged.
     */

    downChan = Tcl_GetStackedChannel(dataPtr->self);

    (Tcl_GetChannelType(downChan))
	->watchProc(Tcl_GetChannelInstanceData(downChan), mask);

    /*
     * Management of the internal timer.
     */

    if ((dataPtr->timer != (Tcl_TimerToken) NULL) &&
	    (!(mask & TCL_READABLE) || (ResultLength(&dataPtr->result) == 0))) {

        /* A pending timer exists, but either is there no (more)
	 * interest in the events it generates or nothing is availablee
	 * for reading, so remove it.
	 */

        Tcl_DeleteTimerHandler (dataPtr->timer);
	dataPtr->timer = (Tcl_TimerToken) NULL;
    }

    if ((dataPtr->timer == (Tcl_TimerToken) NULL) &&
	    (mask & TCL_READABLE) && (ResultLength (&dataPtr->result) > 0)) {

        /* There is no pending timer, but there is interest in readable
	 * events and we actually have data waiting, so generate a timer
	 * to flush that.
	 */

	dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY,
		TransformChannelHandlerTimer, (ClientData) dataPtr);
    }
}

/*
 *------------------------------------------------------*
 *
 *	TransformGetFileHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve
 *	OS specific file handle from inside this channel.
 *
 *	Sideeffects:
 *		None.
 *
 *	Result:
 *		The appropriate Tcl_File or NULL if not
 *		present. 
 *
 *------------------------------------------------------*
 */

static int
TransformGetFileHandleProc (instanceData, direction, handlePtr)
    ClientData  instanceData;	/* Channel to query */
    int         direction;	/* Direction of interest */
    ClientData* handlePtr;	/* Place to store the handle into */
{
    /*
     * Return the handle belonging to parent channel.
     * IOW, pass the request down and the result up.
     */

    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;

    return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self),
	    direction, handlePtr);
}

/*
 *------------------------------------------------------*
 *
 *	TransformNotifyProc --
 *
 *	------------------------------------------------*
 *	Handler called by Tcl to inform us of activity
 *	on the underlying channel.
 *	------------------------------------------------*
 *
 *	Sideeffects:
 *		May process the incoming event by itself.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static int
TransformNotifyProc (clientData, mask)
    ClientData	   clientData; /* The state of the notified transformation */
    int		   mask;       /* The mask of occuring events */
{
    TransformChannelData* dataPtr = (TransformChannelData*) clientData;

    /*
     * An event occured in the underlying channel.  This
     * transformation doesn't process such events thus returns the
     * incoming mask unchanged.
     */

    if (dataPtr->timer != (Tcl_TimerToken) NULL) {
	/*
	 * Delete an existing timer. It was not fired, yet we are
	 * here, so the channel below generated such an event and we
	 * don't have to. The renewal of the interest after the
	 * execution of channel handlers will eventually cause us to
	 * recreate the timer (in TransformWatchProc).
	 */

	Tcl_DeleteTimerHandler (dataPtr->timer);
	dataPtr->timer = (Tcl_TimerToken) NULL;
    }

    return mask;
}

/*
 *------------------------------------------------------*
 *
 *	TransformChannelHandlerTimer --
 *
 *	Called by the notifier (-> timer) to flush out
 *	information waiting in the input buffer.
 *
 *	Sideeffects:
 *		As of 'Tcl_NotifyChannel'.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static void
TransformChannelHandlerTimer (clientData)
    ClientData clientData; /* Transformation to query */
{
    TransformChannelData* dataPtr = (TransformChannelData*) clientData;

    dataPtr->timer = (Tcl_TimerToken) NULL;

    if (!(dataPtr->watchMask & TCL_READABLE) ||
	    (ResultLength (&dataPtr->result) == 0)) {

	/* The timer fired, but either is there no (more)
	 * interest in the events it generates or nothing is available
	 * for reading, so ignore it and don't recreate it.
	 */

	return;
    }

    Tcl_NotifyChannel(dataPtr->self, TCL_READABLE);
}

/*
 *------------------------------------------------------*
 *
 *	ResultClear --
 *
 *	Deallocates any memory allocated by 'ResultAdd'.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static void
ResultClear (r)
    ResultBuffer* r; /* Reference to the buffer to clear out */
{
    r->used = 0;

    if (r->allocated) {
        ckfree((char*) r->buf);
	r->buf       = UCHARP (NULL);
	r->allocated = 0;
    }
}

/*
 *------------------------------------------------------*
 *
 *	ResultInit --
 *
 *	Initializes the specified buffer structure. The
 *	structure will contain valid information for an
 *	emtpy buffer.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static void
ResultInit (r)
    ResultBuffer* r; /* Reference to the structure to initialize */
{
    r->used      = 0;
    r->allocated = 0;
    r->buf       = UCHARP (NULL);
}

/*
 *------------------------------------------------------*
 *
 *	ResultLength --
 *
 *	Returns the number of bytes stored in the buffer.
 *
 *	Sideeffects:
 *		None.
 *
 *	Result:
 *		An integer, see above too.
 *
 *------------------------------------------------------*
 */

static int
ResultLength (r)
    ResultBuffer* r; /* The structure to query */
{
    return r->used;
}

/*
 *------------------------------------------------------*
 *
 *	ResultCopy --
 *
 *	Copies the requested number of bytes from the
 *	buffer into the specified array and removes them
 *	from the buffer afterward. Copies less if there
 *	is not enough data in the buffer.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		The number of actually copied bytes,
 *		possibly less than 'toRead'.
 *
 *------------------------------------------------------*
 */

static int
ResultCopy (r, buf, toRead)
    ResultBuffer*  r;      /* The buffer to read from */
    unsigned char* buf;    /* The buffer to copy into */
    int		   toRead; /* Number of requested bytes */
{
    if (r->used == 0) {

        /* Nothing to copy in the case of an empty buffer.
	 */

        return 0;
    }

    if (r->used == toRead) {

        /* We have just enough. Copy everything to the caller.
	 */

        memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead);
	r->used = 0;
	return toRead;
    }

    if (r->used > toRead) {

        /* The internal buffer contains more than requested.
	 * Copy the requested subset to the caller, and shift
	 * the remaining bytes down.
	 */

        memcpy  ((VOID*) buf,    (VOID*) r->buf,            (size_t) toRead);
	memmove ((VOID*) r->buf, (VOID*) (r->buf + toRead),
		(size_t) r->used - toRead);

	r->used -= toRead;
	return toRead;
    }


    /* There is not enough in the buffer to satisfy the caller, so
     * take everything.
     */

    memcpy((VOID*) buf, (VOID*) r->buf, (size_t) r->used);
    toRead  = r->used;
    r->used = 0;
    return toRead;
}

/*
 *------------------------------------------------------*
 *
 *	ResultAdd --
 *
 *	Adds the bytes in the specified array to the
 *	buffer, by appending it.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static void
ResultAdd (r, buf, toWrite)
    ResultBuffer*  r;       /* The buffer to extend */
    unsigned char* buf;     /* The buffer to read from */
    int		   toWrite; /* The number of bytes in 'buf' */
{
    if ((r->used + toWrite) > r->allocated) {

        /* Extension of the internal buffer is required.
	 */

        if (r->allocated == 0) {
	    r->allocated = toWrite + INCREMENT;
	    r->buf       = UCHARP (ckalloc((unsigned) r->allocated));
	} else {
	    r->allocated += toWrite + INCREMENT;
	    r->buf        = UCHARP (ckrealloc((char*) r->buf,
		    (unsigned) r->allocated));
	}
    }

    /* now copy data */
    memcpy(r->buf + r->used, buf, (size_t) toWrite);
    r->used += toWrite;
}















|
|










|





|
|
|
|
|


|
|














|
|
|

|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|

|
|
|
|
|










|












|

|

|
<
|

|
|
<

|
|

|



|
|
|

|










|

|

|
|

|
|
<

|
|

|



|
|
|

|


|
|












|





|
|
|



|
|




|
|



|
|



|
|








|





|

|



|
|

|
|

|



|

|
|
|

|






>
|













|

|
|



>
|
|





|
|
|

|
|
|
|
|


|
|














>
|
|
|












|
|
<
|
|
|
|
|


|








>
|






|
|

|








>
|
|


|
|











|

|

|
<

|
|

|
|

|



|

|
|
|







>
|




|
<











|

|

|
|

|
|
<
|
|

|
|
<
|
<

|



|
|
|
|
|

|
|
|
|


>
|








|
|
|



|
|



|
|













|
|


|
|
|


|
|
<





|
|

|
|

|
<
<
|
|
<
|
<

|
|
<

















|
|
|



|
|



|
|







>





|
|
|
|
|

>




>





|

|

|
<
|
|

|
|

|
|

|



|


















|

|

|
<
|
|

|
|

|
|

|



|
|
|
|
|













>


>



>




|

|

|
<

|
|
|

|
|

|

>


|

|

>
|
|
<


|
|



>
|
|
|
|
|
|




|
|






|
|
|
|
|


|




|
|
|
|
|


|





|

|

|
|

|
|

|
|
<

|

>

|
|
|
|


|
|


|






|

|

<
|
|
<

|
|

|
|

|



|
|
|

|


|
|
<




|
|
|
|
|


|







|

|

|
|

|
|

|
|

|



|
|

|




|
>
|
|
|









|

|



|
|

|
|

|



|
|




|
|





|

|

|
|
<

|
|

|
|

|



|
|

|

|



|

|



|
|

|
|

|



|
|





|

|

|
|
<
|

|
|

|
|
<

|



|
|
|
|


>
|






>
|


|





>
|
|
<


|
|






>
|
|


|






|

|

|
<

|
|

|
|

|



|
|
|
|


>
|




|


|








>
>
>
>
>
>
>
>
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

510
511
512
513

514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545

546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722

723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781

782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811

812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831

832
833
834
835
836

837

838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901

902
903
904
905
906
907
908
909
910
911
912
913


914
915

916

917
918
919

920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984

985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021

1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069

1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152

1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178

1179
1180

1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200

1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293

1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342

1343
1344
1345
1346
1347
1348
1349

1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381

1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408

1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451

    res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp);
    if (res != TCL_OK) {
	goto cleanup;
    }

    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as UTF while at the tcl level.
     */

    temp = Tcl_NewByteArrayObj(buf, bufLen);

    if (temp == (Tcl_Obj*) NULL) {
        /* Memory allocation problem */
	res = TCL_ERROR;
        goto cleanup;
    }

    res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp);
    if (res != TCL_OK) {
        goto cleanup;
    }

    /*
     * Step 2, execute the command at the global level of the interpreter used
     * to create the transformation. Destroy the command afterward. If an
     * error occured and the current interpreter is defined and not equal to
     * the interpreter for the callback, then copy the error message into
     * current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_GlobalEvalObj(dataPtr->interp, command);
    Tcl_DecrRefCount(command);
    command = (Tcl_Obj*) NULL;

    if ((res != TCL_OK) && (interp != NO_INTERP) &&
	    (dataPtr->interp != interp) && !preserve) {
        Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp));
	return res;
    }

    /*
     * Step 3, transmit a possible conversion result to the underlying
     * channel, or ourselves.
     */

    switch (transmit) {
    case TRANSMIT_DONT:
	/* nothing to do */
	break;

    case TRANSMIT_DOWN:
	resObj = Tcl_GetObjResult(dataPtr->interp);
	resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
		resLen);
	break;

    case TRANSMIT_SELF:
	resObj = Tcl_GetObjResult(dataPtr->interp);
	resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
	break;

    case TRANSMIT_IBUF:
	resObj = Tcl_GetObjResult(dataPtr->interp);
	resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen);
	ResultAdd(&dataPtr->result, resBuf, resLen);
	break;

    case TRANSMIT_NUM:
	/* Interpret result as integer number */
	resObj = Tcl_GetObjResult(dataPtr->interp);
	Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
	break;
    }

    Tcl_ResetResult(dataPtr->interp);

    if (preserve) {
	(void) Tcl_RestoreInterpState(dataPtr->interp, state);
    }

    return res;

  cleanup:
    if (preserve) {
	(void) Tcl_RestoreInterpState(dataPtr->interp, state);
    }

    if (command != (Tcl_Obj*) NULL) {
        Tcl_DecrRefCount(command);
    }

    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformBlockModeProc --
 *
 *	Trap handler. Called by the generic IO system during option processing

 *	to change the blocking mode of the channel.
 *
 * Side effects:
 *	Forwards the request to the underlying channel.

 *
 * Result:
 *	0 if successful, errno when failed.
 *
 *----------------------------------------------------------------------
 */

static int
TransformBlockModeProc(instanceData, mode)
    ClientData instanceData;	/* State of transformation */
    int mode;			/* New blocking mode */
{
    TransformChannelData *dataPtr = (TransformChannelData *) instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
        dataPtr->flags |= CHANNEL_ASYNC;
    } else {
        dataPtr->flags &= ~(CHANNEL_ASYNC);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformCloseProc --
 *
 *	Trap handler. Called by the generic IO system during destruction of
 *	the transformation channel.
 *
 * Side effects:
 *	Releases the memory allocated in 'Tcl_TransformObjCmd'.

 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TransformCloseProc(instanceData, interp)
    ClientData instanceData;
    Tcl_Interp *interp;
{
    TransformChannelData *dataPtr = (TransformChannelData *) instanceData;

    /*
     * Important: In this procedure 'dataPtr->self' already points to the
     * underlying channel.
     */

    /*
     * There is no need to cancel an existing channel handler, this is already
     * done. Either by 'Tcl_UnstackChannel' or by the general cleanup in
     * 'Tcl_Close'.
     *
     * But we have to cancel an active timer to prevent it from firing on the
     * removed channel.
     */

    if (dataPtr->timer != (Tcl_TimerToken) NULL) {
        Tcl_DeleteTimerHandler(dataPtr->timer);
	dataPtr->timer = (Tcl_TimerToken) NULL;
    }

    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver for
     * it anymore. But the scripts might have sideeffects other parts of the
     * system rely on (f.e. signaling the close to interested parties).
     */

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, 1);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = 1;
        ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0,
		TRANSMIT_IBUF, 1);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0,
		TRANSMIT_DONT, 1);
    }

    if (dataPtr->mode & TCL_READABLE) {
        ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0,
		TRANSMIT_DONT, 1);
    }

    /*
     * General cleanup
     */

    ResultClear(&dataPtr->result);
    Tcl_DecrRefCount(dataPtr->command);
    ckfree((char *) dataPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformInputProc --
 *
 *	Called by the generic IO system to convert read data.
 *
 * Side effects:
 *	As defined by the conversion.
 *
 * Result:
 *	A transformed buffer.
 *
 *----------------------------------------------------------------------
 */

static int
TransformInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;
    char *buf;
    int toRead;
    int *errorCodePtr;
{
    TransformChannelData* dataPtr = (TransformChannelData *) instanceData;
    int gotBytes, read, res, copied;
    Tcl_Channel downChan;

    /* should assert (dataPtr->mode & TCL_READABLE) */

    if (toRead == 0) {
	/*
	 * Catch a no-op.
	 */
	return 0;
    }

    gotBytes = 0;
    downChan = Tcl_GetStackedChannel(dataPtr->self);

    while (toRead > 0) {
        /*
	 * Loop until the request is satisfied (or no data is available from
	 * below, possibly EOF).
	 */

        copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead);

	toRead -= copied;
	buf += copied;
	gotBytes += copied;

	if (toRead == 0) {
	    /*
	     * The request was completely satisfied from our buffers.  We can
	     * break out of the loop and return to the caller.
	     */
	    return gotBytes;
	}

	/*
	 * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming
	 * 'buf'! as target to store the intermediary information read from
	 * the underlying channel.
	 *
	 * Ask the tcl level how much data it allows us to read from the
	 * underlying channel. This feature allows the transform to signal EOF
	 * upstream although there is none downstream. Useful to control an
	 * unbounded 'fcopy', either through counting bytes, or by pattern
	 * matching.
	 */

	ExecuteCallback(dataPtr, NO_INTERP, A_QUERY_MAXREAD, NULL, 0,
		TRANSMIT_NUM /* -> maxRead */, 1);

	if (dataPtr->maxRead >= 0) {
	    if (dataPtr->maxRead < toRead) {
	        toRead = dataPtr->maxRead;
	    }
	} /* else: 'maxRead < 0' == Accept the current value of toRead */

	if (toRead <= 0) {
	    return gotBytes;
	}

	read = Tcl_ReadRaw(downChan, buf, toRead);

	if (read < 0) {
	    /*
	     * Report errors to caller. EAGAIN is a special situation.  If we
	     * had some data before we report that instead of the request to
	     * re-try.
	     */

	    if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
	        return gotBytes;
	    }

	    *errorCodePtr = Tcl_GetErrno();
	    return -1;      
	}

	if (read == 0) {
	    /*
	     * Check wether we hit on EOF in the underlying channel or not. If
	     * not differentiate between blocking and non-blocking modes. In

	     * non-blocking mode we ran temporarily out of data. Signal this
	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to
	     * convert and flush all waiting partial data.
	     */

	    if (! Tcl_Eof(downChan)) {
	        if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) {
		    *errorCodePtr = EWOULDBLOCK;
		    return -1;
		} else {
		    return gotBytes;
		}
	    } else {
	        if (dataPtr->readIsFlushed) {
		    /*
		     * Already flushed, nothing to do anymore.
		     */
		    return gotBytes;
		}

		dataPtr->readIsFlushed = 1;

		ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_READ, NULL, 0,
			TRANSMIT_IBUF, P_PRESERVE);

		if (ResultLength(&dataPtr->result) == 0) {
		    /* we had nothing to flush */
		    return gotBytes;
		}

		continue; /* at: while (toRead > 0) */
	    }
	} /* read == 0 */

	/*
	 * Transform the read chunk and add the result to our read buffer
	 * (dataPtr->result)
	 */

	res = ExecuteCallback(dataPtr, NO_INTERP, A_READ, UCHARP(buf), read,
		TRANSMIT_IBUF, P_PRESERVE);

	if (res != TCL_OK) {
	    *errorCodePtr = EINVAL;
	    return -1;
	}
    } /* while toRead > 0 */

    return gotBytes;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformOutputProc --
 *
 *	Called by the generic IO system to convert data waiting to be written.

 *
 * Side effects:
 *	As defined by the transformation.
 *
 * Result:
 *	A transformed buffer.
 *
 *----------------------------------------------------------------------
 */

static int
TransformOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;
    CONST char *buf;
    int toWrite;
    int *errorCodePtr;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    int res;

    /* should assert (dataPtr->mode & TCL_WRITABLE) */

    if (toWrite == 0) {
	/*
	 * Catch a no-op.
	 */
	return 0;
    }

    res = ExecuteCallback(dataPtr, NO_INTERP, A_WRITE, UCHARP(buf), toWrite,

	    TRANSMIT_DOWN, P_NO_PRESERVE);

    if (res != TCL_OK) {
        *errorCodePtr = EINVAL;
	return -1;
    }

    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformSeekProc --
 *
 *	This procedure is called by the generic IO level to move the access
 *	point in a channel.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in future

 *	operations.  Flushes all transformation buffers, then forwards it to
 *	the underlying channel.
 *
 * Result:
 *	-1 if failed, the new position if successful. An output argument

 *	contains the POSIX error code if an error occurred, or zero.

 *
 *----------------------------------------------------------------------
 */

static int
TransformSeekProc(instanceData, offset, mode, errorCodePtr)
    ClientData instanceData;	/* The channel to manipulate */
    long offset;		/* Size of movement. */
    int mode;			/* How to move */
    int *errorCodePtr;		/* Location of error flag. */
{
    TransformChannelData *dataPtr = (TransformChannelData *) instanceData;
    Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
    Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);

    if ((offset == 0) && (mode == SEEK_CUR)) {
        /*
	 * This is no seek but a request to tell the caller the current
	 * location. Simply pass the request down.
	 */

	return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
		offset, mode, errorCodePtr);
    }

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
        ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0,
		TRANSMIT_DONT, P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }

    return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
	    offset, mode, errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TransformWideSeekProc --
 *
 *	This procedure is called by the generic IO level to move the access
 *	point in a channel, with a (potentially) 64-bit offset.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in future
 *	operations.  Flushes all transformation buffers, then forwards it to
 *	the underlying channel.
 *
 * Result:
 *	-1 if failed, the new position if successful. An output argument
 *	contains the POSIX error code if an error occurred, or zero.

 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
TransformWideSeekProc(instanceData, offset, mode, errorCodePtr)
    ClientData instanceData;	/* The channel to manipulate */
    Tcl_WideInt offset;		/* Size of movement. */
    int mode;			/* How to move */
    int *errorCodePtr;		/* Location of error flag. */
{
    TransformChannelData * dataPtr = (TransformChannelData *) instanceData;


    Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_ChannelType* parentType	= Tcl_GetChannelType(parent);

    Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType);

    Tcl_DriverWideSeekProc* parentWideSeekProc =
	    Tcl_ChannelWideSeekProc(parentType);
    ClientData parentData = Tcl_GetChannelInstanceData(parent);


    if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {
        /*
	 * This is no seek but a request to tell the caller the current
	 * location. Simply pass the request down.
	 */

	if (parentWideSeekProc != NULL) {
	    return (*parentWideSeekProc) (parentData, offset, mode,
		    errorCodePtr);
	}

	return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode,
		errorCodePtr));
    }

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */

    if (dataPtr->mode & TCL_WRITABLE) {
        ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
        ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0,
		TRANSMIT_DONT, P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }

    /*
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc != NULL) {
	return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr);
    }

    /*
     * We're transferring to narrow seeks at this point; this is a bit complex
     * because we have to check whether the seek is possible first (i.e.
     * whether we are losing information in truncating the bits of the
     * offset.)  Luckily, there's a defined error for what happens when trying
     * to go out of the representable range.
     */

    if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
	*errorCodePtr = EOVERFLOW;
	return Tcl_LongAsWide(-1);
    }

    return Tcl_LongAsWide((*parentSeekProc) (parentData,
	    Tcl_WideAsLong(offset), mode, errorCodePtr));
}

/*
 *----------------------------------------------------------------------
 *
 * TransformSetOptionProc --
 *
 *	Called by generic layer to handle the reconfiguration of channel

 *	specific options. As this channel type does not have such, it simply
 *	passes all requests downstream.
 *
 * Side effects:
 *	As defined by the channel downstream.
 *
 * Result:
 *	A standard TCL error code.
 *
 *----------------------------------------------------------------------
 */

static int
TransformSetOptionProc(instanceData, interp, optionName, value)
    ClientData instanceData;
    Tcl_Interp *interp;
    CONST char *optionName;
    CONST char *value;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_DriverSetOptionProc *setOptionProc;

    setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
    if (setOptionProc != NULL) {
	return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan),
		interp, optionName, value);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformGetOptionProc --
 *
 *	Called by generic layer to handle requests for the values of channel

 *	specific options. As this channel type does not have such, it simply
 *	passes all requests downstream.
 *
 * Side effects:
 *	As defined by the channel downstream.
 *
 * Result:
 *	A standard TCL error code.
 *
 *----------------------------------------------------------------------
 */

static int
TransformGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;
    Tcl_Interp *interp;
    CONST char *optionName;
    Tcl_DString *dsPtr;
{
    TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
    Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
    Tcl_DriverGetOptionProc *getOptionProc;

    getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
    if (getOptionProc != NULL) {
	return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
		interp, optionName, dsPtr);
    } else if (optionName == (CONST char*) NULL) {
	/*
	 * Request is query for all options, this is ok.
	 */

	return TCL_OK;
    }

    /*
     * Request for a specific option has to fail, we don't have any.
     */

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformWatchProc --
 *
 *	Initialize the notifier to watch for events from this channel.

 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will be
 *	seen by Tcl.
 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TransformWatchProc(instanceData, mask)
    ClientData instanceData;	/* Channel to watch */
    int mask;			/* Events of interest */
{
    /*
     * The caller expressed interest in events occuring for this channel. We
     * are forwarding the call to the underlying channel now.

     */

    TransformChannelData *dataPtr = (TransformChannelData *) instanceData;
    Tcl_Channel downChan;

    dataPtr->watchMask = mask;

    /*
     * No channel handlers any more. We will be notified automatically about
     * events on the channel below via a call to our 'TransformNotifyProc'.
     * But we have to pass the interest down now.  We are allowed to add
     * additional 'interest' to the mask if we want to. But this
     * transformation has no such interest. It just passes the request down,
     * unchanged.
     */

    downChan = Tcl_GetStackedChannel(dataPtr->self);

    Tcl_GetChannelType(downChan)->watchProc(
	    Tcl_GetChannelInstanceData(downChan), mask);

    /*
     * Management of the internal timer.
     */

    if ((dataPtr->timer != (Tcl_TimerToken) NULL) &&
	    (!(mask & TCL_READABLE) || ResultLength(&dataPtr->result)==0)) {
        /*
	 * A pending timer exists, but either is there no (more) interest in
	 * the events it generates or nothing is availablee for reading, so
	 * remove it.
	 */

        Tcl_DeleteTimerHandler(dataPtr->timer);
	dataPtr->timer = (Tcl_TimerToken) NULL;
    }

    if ((dataPtr->timer == (Tcl_TimerToken) NULL) &&
	    (mask & TCL_READABLE) && (ResultLength(&dataPtr->result) > 0)) {
        /*
	 * There is no pending timer, but there is interest in readable events
	 * and we actually have data waiting, so generate a timer to flush
	 * that.
	 */

	dataPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY,
		TransformChannelHandlerTimer, (ClientData) dataPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TransformGetFileHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS specific file handle
 *	from inside this channel.
 *
 * Side effects:
 *	None.
 *
 * Result:
 *	The appropriate Tcl_File or NULL if not present. 

 *
 *----------------------------------------------------------------------
 */

static int
TransformGetFileHandleProc(instanceData, direction, handlePtr)
    ClientData instanceData;	/* Channel to query */
    int direction;		/* Direction of interest */
    ClientData *handlePtr;	/* Place to store the handle into */
{
    /*
     * Return the handle belonging to parent channel.  IOW, pass the request
     * down and the result up.
     */

    TransformChannelData *dataPtr = (TransformChannelData *) instanceData;

    return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self),
	    direction, handlePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TransformNotifyProc --
 *

 *	Handler called by Tcl to inform us of activity on the underlying
 *	channel.

 *
 * Side effects:
 *	May process the incoming event by itself.
 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TransformNotifyProc(clientData, mask)
    ClientData clientData;	/* The state of the notified transformation */
    int mask;			/* The mask of occuring events */
{
    TransformChannelData *dataPtr = (TransformChannelData *) clientData;

    /*
     * An event occured in the underlying channel.  This transformation
     * doesn't process such events thus returns the incoming mask unchanged.

     */

    if (dataPtr->timer != (Tcl_TimerToken) NULL) {
	/*
	 * Delete an existing timer. It was not fired, yet we are here, so the
	 * channel below generated such an event and we don't have to. The
	 * renewal of the interest after the execution of channel handlers
	 * will eventually cause us to recreate the timer (in
	 * TransformWatchProc).
	 */

	Tcl_DeleteTimerHandler(dataPtr->timer);
	dataPtr->timer = (Tcl_TimerToken) NULL;
    }

    return mask;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformChannelHandlerTimer --
 *
 *	Called by the notifier (-> timer) to flush out information waiting in
 *	the input buffer.
 *
 * Side effects:
 *	As of 'Tcl_NotifyChannel'.
 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
TransformChannelHandlerTimer(clientData)
    ClientData clientData;	/* Transformation to query */
{
    TransformChannelData *dataPtr = (TransformChannelData *) clientData;

    dataPtr->timer = (Tcl_TimerToken) NULL;

    if (!(dataPtr->watchMask & TCL_READABLE) ||
	    (ResultLength(&dataPtr->result) == 0)) {
	/*
	 * The timer fired, but either is there no (more) interest in the
	 * events it generates or nothing is available for reading, so ignore
	 * it and don't recreate it.
	 */

	return;
    }

    Tcl_NotifyChannel(dataPtr->self, TCL_READABLE);
}

/*
 *----------------------------------------------------------------------
 *
 * ResultClear --
 *
 *	Deallocates any memory allocated by 'ResultAdd'.
 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultClear(r)
    ResultBuffer *r;		/* Reference to the buffer to clear out. */
{
    r->used = 0;

    if (r->allocated) {
        ckfree((char *) r->buf);
	r->buf = UCHARP(NULL);
	r->allocated = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ResultInit --
 *
 *	Initializes the specified buffer structure. The structure will contain
 *	valid information for an emtpy buffer.

 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultInit(r)
    ResultBuffer *r;		/* Reference to the structure to initialize */
{
    r->used = 0;
    r->allocated = 0;
    r->buf = UCHARP(NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * ResultLength --
 *
 *	Returns the number of bytes stored in the buffer.
 *
 * Side effects:
 *	None.
 *
 * Result:
 *	An integer, see above too.
 *
 *----------------------------------------------------------------------
 */

static int
ResultLength(r)
    ResultBuffer *r;		/* The structure to query */
{
    return r->used;
}

/*
 *----------------------------------------------------------------------
 *
 * ResultCopy --
 *
 *	Copies the requested number of bytes from the buffer into the
 *	specified array and removes them from the buffer afterward. Copies

 *	less if there is not enough data in the buffer.
 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	The number of actually copied bytes, possibly less than 'toRead'.

 *
 *----------------------------------------------------------------------
 */

static int
ResultCopy(r, buf, toRead)
    ResultBuffer *r;		/* The buffer to read from. */
    unsigned char *buf;		/* The buffer to copy into. */
    int toRead;			/* Number of requested bytes. */
{
    if (r->used == 0) {
        /*
	 * Nothing to copy in the case of an empty buffer.
	 */

        return 0;
    }

    if (r->used == toRead) {
        /*
	 * We have just enough. Copy everything to the caller.
	 */

        memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead);
	r->used = 0;
	return toRead;
    }

    if (r->used > toRead) {
        /*
	 * The internal buffer contains more than requested.  Copy the
	 * requested subset to the caller, and shift the remaining bytes down.

	 */

        memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead);
	memmove((VOID *) r->buf, (VOID *) (r->buf + toRead),
		(size_t) r->used - toRead);

	r->used -= toRead;
	return toRead;
    }

    /*
     * There is not enough in the buffer to satisfy the caller, so take
     * everything.
     */

    memcpy((VOID *) buf, (VOID *) r->buf, (size_t) r->used);
    toRead  = r->used;
    r->used = 0;
    return toRead;
}

/*
 *----------------------------------------------------------------------
 *
 * ResultAdd --
 *
 *	Adds the bytes in the specified array to the buffer, by appending it.

 *
 * Side effects:
 *	See above.
 *
 * Result:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultAdd(r, buf, toWrite)
    ResultBuffer *r;		/* The buffer to extend */
    unsigned char *buf;		/* The buffer to read from */
    int toWrite;		/* The number of bytes in 'buf' */
{
    if ((r->used + toWrite) > r->allocated) {
        /*
	 * Extension of the internal buffer is required.
	 */

        if (r->allocated == 0) {
	    r->allocated = toWrite + INCREMENT;
	    r->buf = UCHARP(ckalloc((unsigned) r->allocated));
	} else {
	    r->allocated += toWrite + INCREMENT;
	    r->buf = UCHARP(ckrealloc((char *) r->buf,
		    (unsigned) r->allocated));
	}
    }

    /* now copy data */
    memcpy(r->buf + r->used, buf, (size_t) toWrite);
    r->used += toWrite;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Added generic/tclIORChan.c.









































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
/* 
 * tclIORChan.c --
 *
 *	This file contains the implementation of Tcl's generic
 *	channel reflection code, which allows the implementation
 *	of Tcl channels in Tcl code.
 *
 *	Parts of this file are based on code contributed by 
 *	Jean-Claude Wippler.
 *
 *      See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.6 2005/10/08 13:44:37 dgp Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL
#define EINVAL 9
#endif
#ifndef EOK
#define EOK    0
#endif

/*
 * Signatures of all functions used in the C layer of the reflection.
 */

/* Required */
static int	RcClose _ANSI_ARGS_((ClientData clientData,
		   Tcl_Interp *interp));

/* Required, "read" is optional despite this. */
static int	RcInput _ANSI_ARGS_((ClientData clientData,
		    char *buf, int toRead, int *errorCodePtr));

/* Required, "write" is optional despite this. */
static int	RcOutput _ANSI_ARGS_((ClientData clientData,
	            CONST char *buf, int toWrite, int *errorCodePtr));

/* Required */
static void	RcWatch _ANSI_ARGS_((ClientData clientData, int mask));

/* NULL'able - "blocking", is optional */
static int	RcBlock _ANSI_ARGS_((ClientData clientData,
				       int mode));

/* NULL'able - "seek", is optional */
static Tcl_WideInt RcSeekWide _ANSI_ARGS_((ClientData clientData,
		    Tcl_WideInt offset,
		    int mode, int *errorCodePtr));

static int RcSeek _ANSI_ARGS_((ClientData clientData,
		    long offset, int mode, int *errorCodePtr));

/* NULL'able - "cget" / "cgetall", are optional */
static int	RcGetOption _ANSI_ARGS_((ClientData clientData,
				       Tcl_Interp* interp,
				       CONST char *optionName,
				       Tcl_DString *dsPtr));

/* NULL'able - "configure", is optional */
static int	RcSetOption _ANSI_ARGS_((ClientData clientData,
				       Tcl_Interp* interp,
				       CONST char *optionName,
				       CONST char *newValue));


/*
 * The C layer channel type/driver definition used by the reflection.
 * This is a version 3 structure.
 */

static Tcl_ChannelType tclRChannelType = {
  "tclrchannel",  /* Type name.                                    */
  TCL_CHANNEL_VERSION_3,
  RcClose,        /* Close channel, clean instance data            */
  RcInput,        /* Handle read request                           */
  RcOutput,       /* Handle write request                          */
  RcSeek,         /* Move location of access point.    NULL'able   */
  RcSetOption,    /* Set options.                      NULL'able   */
  RcGetOption,    /* Get options.                      NULL'able   */
  RcWatch,        /* Initialize notifier                           */
  NULL,           /* Get OS handle from the channel.   NULL'able   */
  NULL,           /* No close2 support.                NULL'able   */
  RcBlock,        /* Set blocking/nonblocking.         NULL'able   */
  NULL,           /* Flush channel. Not used by core.  NULL'able   */
  NULL,           /* Handle events.                    NULL'able   */
  RcSeekWide      /* Move access point (64 bit).       NULL'able   */
};

/*
 * Instance data for a reflected channel. ===========================
 */

typedef struct {
  Tcl_Channel chan;    /* Back reference to generic channel structure.
		        */
  Tcl_Interp* interp;  /* Reference to the interpreter containing the
		        * Tcl level part of the channel. */
#ifdef TCL_THREADS
  Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
#endif

  /* See [==] as well.
   * Storage for the command prefix and the additional words required
   * for the invocation of methods in the command handler.
   *
   * argv [0] ... [.] | [argc-2] [argc-1] | [argc]  [argc+2]
   *      cmd ... pfx | method   chan     | detail1 detail2
   *      ~~~~ CT ~~~            ~~ CT ~~
   *
   * CT = Belongs to the 'Command handler Thread'.
   */

  int       argc;       /* Number of preallocated words - 2 */
  Tcl_Obj** argv;       /* Preallocated array for calling the handler.
			 * args [0] is placeholder for cmd word.
			 * Followed by the arguments in the prefix,
			 * plus 4 placeholders for method, channel,
			 * and at most two varying (method specific)
			 * words.
			 */

  int methods;          /* Bitmask of supported methods */

  /* ---------------------------------------- */

  /* NOTE (9): Should we have predefined shared literals
   * NOTE (9): for the method names ?
   */

  /* ---------------------------------------- */

  int mode;             /* Mask of R/W mode */
  int interest;         /* Mask of events the channel is interested in. */

  /* Note regarding the usage of timers.
   *
   * Most channel implementations need a timer in the
   * C level to ensure that data in buffers is flushed
   * out through the generation of fake file events.
   *
   * See 'rechan', 'memchan', etc.
   *
   * Here this is _not_ required. Interest in events is
   * posted to the Tcl level via 'watch'. And posting of
   * events is possible from the Tcl level as well, via
   * 'chan postevent'. This means that the generation of
   * all events, fake or not, timer based or not, is
   * completely in the hands of the Tcl level. Therefore
   * no timer here.
   */

} ReflectingChannel;

/*
 * Event literals. ==================================================
 */

static CONST char *eventOptions[] = {
  "read", "write", (char *) NULL
};
typedef enum {
  EVENT_READ, EVENT_WRITE
} EventOption;

/*
 * Method literals. ==================================================
 */

static CONST char *methodNames[] = {
  "blocking",	/* OPT */
  "cget",	/* OPT \/ Together or none */
  "cgetall",	/* OPT /\ of these two     */
  "configure",	/* OPT */
  "finalize",	/*     */
  "initialize",	/*     */
  "read",	/* OPT */
  "seek",	/* OPT */
  "watch",	/*     */
  "write",	/* OPT */
  (char *) NULL
};
typedef enum {
  METH_BLOCKING,
  METH_CGET,
  METH_CGETALL,
  METH_CONFIGURE,
  METH_FINAL,
  METH_INIT,
  METH_READ,
  METH_SEEK,
  METH_WATCH,
  METH_WRITE,
} MethodName;

#define FLAG(m) (1 << (m))
#define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH))
#define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \
	FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL))

#define RANDW (TCL_READABLE|TCL_WRITABLE)

#define IMPLIES(a,b) ((!(a)) || (b))
#define NEGIMPL(a,b)
#define HAS(x,f) (x & FLAG(f))


#ifdef TCL_THREADS
/*
 * Thread specific types and structures.
 *
 * We are here essentially creating a very specific implementation of
 * 'thread send'.
 */

/*
 * Enumeration of all operations which can be forwarded.
 */

typedef enum {
  RcOpClose,
  RcOpInput,
  RcOpOutput,
  RcOpSeek,
  RcOpWatch,
  RcOpBlock,
  RcOpSetOpt,
  RcOpGetOpt,
  RcOpGetOptAll
} RcOperation;

/*
 * Event used to forward driver invocations to the thread actually
 * managing the channel. We cannot construct the command to execute
 * and forward that. Because then it will contain a mixture of
 * Tcl_Obj's belonging to both the command handler thread (CT), and
 * the thread managing the channel (MT), executed in CT. Tcl_Obj's are
 * not allowed to cross thread boundaries. So we forward an operation
 * code, the argument details ,and reference to results. The command
 * is assembled in the CT and belongs fully to that thread. No sharing
 * problems.
 */

typedef struct RcForwardParamBase {
  int   code; /* O: Ok/Fail of the cmd handler */
  char* msg;  /* O: Error message for handler failure */
  int   vol;  /* O: True - msg is allocated, False - msg is static */
} RcForwardParamBase;

/*
 * Operation specific parameter/result structures.
 */

typedef struct RcForwardParamClose {
  RcForwardParamBase b;
} RcForwardParamClose;

typedef struct RcForwardParamInput {
  RcForwardParamBase b;
  char* buf;    /* O: Where to store the read bytes */
  int   toRead; /* I: #bytes to read,
		 * O: #bytes actually read */
} RcForwardParamInput;

typedef struct RcForwardParamOutput {
  RcForwardParamBase b;
  CONST char* buf;     /* I: Where the bytes to write come from */
  int         toWrite; /* I: #bytes to write,
			* O: #bytes actually written */
} RcForwardParamOutput;

typedef struct RcForwardParamSeek {
  RcForwardParamBase b;
  int         seekMode; /* I: How to seek */
  Tcl_WideInt offset;   /* I: Where to seek,
			 * O: New location */
} RcForwardParamSeek;

typedef struct RcForwardParamWatch {
  RcForwardParamBase b;
  int mask; /* I: What events to watch for */
} RcForwardParamWatch;

typedef struct RcForwardParamBlock {
  RcForwardParamBase b;
  int nonblocking; /* I: What mode to activate */
} RcForwardParamBlock;

typedef struct RcForwardParamSetOpt {
  RcForwardParamBase b;
  CONST char* name;  /* Name of option to set */
  CONST char* value; /* Value to set */
} RcForwardParamSetOpt;

typedef struct RcForwardParamGetOpt {
  RcForwardParamBase b;
  CONST char*  name;  /* Name of option to get, maybe NULL */
  Tcl_DString* value; /* Result */
} RcForwardParamGetOpt;

/*
 * General event structure, with reference to
 * operation specific data.
 */

typedef struct RcForwardingEvent {
  Tcl_Event                  event; /* Basic event data, has to be first item */
  struct RcForwardingResult* resultPtr;

  RcOperation               op;    /* Forwarded driver operation */
  ReflectingChannel*        rcPtr; /* Channel instance */
  CONST RcForwardParamBase* param; /* Arguments, a RcForwardParamXXX pointer */
} RcForwardingEvent;

/*
 * Structure to manage the result of the forwarding.  This is not the
 * result of the operation itself, but about the success of the
 * forward event itself. The event can be successful, even if the
 * operation which was forwarded failed. It is also there to manage
 * the synchronization between the involved threads.
 */

typedef struct RcForwardingResult {

  Tcl_ThreadId  src;    /* Originating thread. */
  Tcl_ThreadId  dst;    /* Thread the op was forwarded to. */
  Tcl_Condition done;   /* Condition variable the forwarder blocks on. */
  int           result; /* TCL_OK or TCL_ERROR */

  struct RcForwardingEvent*  evPtr; /* Event the result belongs to. */

  struct RcForwardingResult* prevPtr; /* Links into the list of pending */
  struct RcForwardingResult* nextPtr; /* forwarded results. */

} RcForwardingResult;

/*
 * List of forwarded operations which have not completed yet, plus the
 * mutex to protect the access to this process global list.
 */

static RcForwardingResult* forwardList = (RcForwardingResult*) NULL;
TCL_DECLARE_MUTEX (rcForwardMutex)

/*
 * Function containing the generic code executing a forward, and
 * wrapper macros for the actual operations we wish to forward.
 */

static void
RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op,
			  Tcl_ThreadId dst, CONST VOID* param));

/*
 * The event function executed by the thread receiving a forwarding
 * event. Executes the appropriate function and collects the result,
 * if any.
 */

static int
RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask));

/*
 * Helpers which intercept when threads are going away, and clean up
 * after pending forwarding events. Different actions depending on
 * which thread went away, originator (src), or receiver (dst).
 */

static void
RcSrcExitProc _ANSI_ARGS_ ((ClientData clientData));

static void
RcDstExitProc _ANSI_ARGS_ ((ClientData clientData));

#define RcFreeReceivedError(pb) \
	if ((pb).vol) {ckfree ((pb).msg);}

#define RcPassReceivedErrorInterp(i,pb) \
	if ((i)) {Tcl_SetChannelErrorInterp ((i), Tcl_NewStringObj ((pb).msg,-1));} \
	RcFreeReceivedError (pb)

#define RcPassReceivedError(c,pb) \
	Tcl_SetChannelError ((c), Tcl_NewStringObj ((pb).msg,-1)); \
	RcFreeReceivedError (pb)

#define RcForwardSetStaticError(p,emsg) \
       (p)->code = TCL_ERROR; (p)->vol  = 0; (p)->msg  = (char*) (emsg);

#define RcForwardSetDynError(p,emsg) \
       (p)->code = TCL_ERROR; (p)->vol  = 1; (p)->msg  = (char*) (emsg);

static void
RcForwardSetObjError _ANSI_ARGS_ ((RcForwardParamBase* p,
				   Tcl_Obj*            obj));

#endif /* TCL_THREADS */

#define RcSetChannelErrorStr(c,msg) \
	Tcl_SetChannelError ((c), Tcl_NewStringObj ((msg),-1))

static Tcl_Obj* RcErrorMarshall _ANSI_ARGS_ ((Tcl_Interp *interp));
static void     RcErrorReturn   _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* msg));



/*
 * Static functions for this file:
 */

static int RcEncodeEventMask _ANSI_ARGS_((Tcl_Interp* interp,
		 CONST char* objName, Tcl_Obj* obj,
		 int* mask));

static Tcl_Obj* RcDecodeEventMask _ANSI_ARGS_ ((int mask));

static ReflectingChannel* RcNew _ANSI_ARGS_ ((Tcl_Interp* interp,
	     Tcl_Obj* cmdpfxObj, int mode,
	     Tcl_Obj* id));

static Tcl_Obj* RcNewHandle _ANSI_ARGS_ ((void));

static void RcFree _ANSI_ARGS_ ((ReflectingChannel* rcPtr));

static void
RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr,
       CONST char* method, Tcl_Obj* argone, Tcl_Obj* argtwo,
       int* result, Tcl_Obj** resultObj, int capture));

#define NO_CAPTURE (0)
#define DO_CAPTURE (1)

/*
 * Global constant strings (messages). ==================
 * These string are used directly as bypass errors, thus they have to be valid
 * Tcl lists where the last element is the message itself. Hence the
 * list-quoting to keep the words of the message together. See also [x].
 */

static CONST char* msg_read_unsup       = "{read not supported by Tcl driver}";
static CONST char* msg_read_toomuch     = "{read delivered more than requested}";
static CONST char* msg_write_unsup      = "{write not supported by Tcl driver}";
static CONST char* msg_write_toomuch    = "{write wrote more than requested}";
static CONST char* msg_seek_beforestart = "{Tried to seek before origin}";

#ifdef TCL_THREADS
static CONST char* msg_send_originlost  = "{Origin thread lost}";
static CONST char* msg_send_dstlost     = "{Destination thread lost}";
#endif /* TCL_THREADS */

/*
 * Main methods to plug into the 'chan' ensemble'. ==================
 */

/*
 *----------------------------------------------------------------------
 *
 * TclChanCreateObjCmd --
 *
 *	This procedure is invoked to process the "chan create" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *	The handle of the new channel is placed in the interp result.
 *
 * Side effects:
 *	Creates a new channel.
 *
 *----------------------------------------------------------------------
 */

int
TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv)
     ClientData      clientData;
     Tcl_Interp*     interp;
     int             objc;
     Tcl_Obj* CONST* objv;
{
    ReflectingChannel* rcPtr;       /* Instance data of the new channel */
    Tcl_Obj*           rcId;        /* Handle of the new channel */
    int                mode;        /* R/W mode of new channel. Has to
				     * match abilities of handler commands */
    Tcl_Obj*           cmdObj;      /* Command prefix, list of words */
    Tcl_Obj*           cmdNameObj;  /* Command name */
    Tcl_Channel        chan;        /* Token for the new channel */
    Tcl_Obj*           modeObj;     /* mode in obj form for method call */
    int                listc;       /* Result of 'initialize', and of */
    Tcl_Obj**          listv;       /* its sublist in the 2nd element */
    int                methIndex;   /* Encoded method name */
    int                res;         /* Result code for 'initialize' */
    Tcl_Obj*           resObj;      /* Result data for 'initialize' */
    int                methods;     /* Bitmask for supported methods. */
    Channel*           chanPtr;     /* 'chan' resolved to internal struct. */

    /* Syntax:   chan create MODE CMDPREFIX
     *           [0]  [1]    [2]  [3]
     *
     * Actually: rCreate MODE CMDPREFIX
     *           [0]     [1]  [2]
     */

#define MODE (1)
#define CMD  (2)

    /* Number of arguments ... */

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix");
	return TCL_ERROR;
    }

    /* First argument is a list of modes. Allowed entries are "read",
     * "write". Expect at least one list element.  Abbreviations are
     * ok.
     */

    modeObj = objv [MODE];
    if (RcEncodeEventMask (interp, "mode", objv [MODE], &mode) != TCL_OK) {
        return TCL_ERROR;
    }

    /* Second argument is command prefix, i.e. list of words, first
     * word is name of handler command, other words are fixed
     * arguments. Run 'initialize' method to get the list of supported
     * methods. Validate this.
     */

    cmdObj = objv [CMD];

    /* Basic check that the command prefix truly is a list. */

    if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) {
        return TCL_ERROR;
    }

    /* Now create the channel.
     */

    rcId  = RcNewHandle ();
    rcPtr = RcNew (interp, cmdObj, mode, rcId);
    chan  = Tcl_CreateChannel (&tclRChannelType,
			       Tcl_GetString (rcId),
			       rcPtr, mode);
    rcPtr->chan = chan;
    chanPtr = (Channel*) chan;

    /* Invoke 'initialize' and validate that the handler
     * is present and ok. Squash the channel if not.
     */

    /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that
     * 'initialize' is invoked with canonical mode names, and no
     * abbreviations. Using modeObj directly could feed abbreviations
     * into the handler, and the handler is not specified to handle
     * such.
     */

    modeObj = RcDecodeEventMask (mode);
    RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL,
		       &res, &resObj, NO_CAPTURE);
    Tcl_DecrRefCount (modeObj);

    if (res != TCL_OK) {
        Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);

	Tcl_AppendObjToObj(err,resObj);
	Tcl_SetObjResult (interp,err);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	goto error;
    }

    /* Verify the result.
     * - List, of method names. Convert to mask.
     *   Check for non-optionals through the mask.
     *   Compare open mode against optional r/w.
     */

    Tcl_AppendResult (interp, "Initialize failure: ", (char*) NULL);

    if (Tcl_ListObjGetElements (interp, resObj,
			&listc, &listv) != TCL_OK) {
        /* The function above replaces my prefix in case of an error,
	 * so more work for us to get the prefix back into the error
	 * message
	 */

        Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);

	Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp));
	Tcl_SetObjResult (interp,err);
	goto error;
    }

    methods = 0;
    while (listc > 0) {
        if (Tcl_GetIndexFromObj (interp, listv [listc-1],
				 methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) {
	    Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);

	    Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp));
	    Tcl_SetObjResult (interp,err);
	    goto error;
	}

	methods |= FLAG (methIndex);
	listc --;
    }

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
        Tcl_AppendResult (interp, "Not all required methods supported",
			  (char*) NULL);
	goto error;
    }

    if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) {
        Tcl_AppendResult (interp, "Reading not supported, but requested",
			  (char*) NULL);
	goto error;
    }

    if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) {
        Tcl_AppendResult (interp, "Writing not supported, but requested",
			  (char*) NULL);
	goto error;
    }

    if (!IMPLIES (HAS(methods,METH_CGET), HAS(methods,METH_CGETALL))) {
        Tcl_AppendResult (interp, "'cgetall' not supported, but should be, as 'cget' is",
			  (char*) NULL);
	goto error;
    }

    if (!IMPLIES (HAS(methods,METH_CGETALL),HAS(methods,METH_CGET))) {
        Tcl_AppendResult (interp, "'cget' not supported, but should be, as 'cgetall' is",
			  (char*) NULL);
	goto error;
    }

    Tcl_ResetResult (interp);

    /* Everything is fine now */

    rcPtr->methods = methods;

    if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
        /* Some of the nullable methods are not supported.  We clone
	 * the channel type, null the associated C functions, and use
	 * the result as the actual channel type.
	 */

        Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType));
	if (clonePtr == (Tcl_ChannelType*) NULL) {
	    Tcl_Panic ("Out of memory in Tcl_RcCreate");
	}

	memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType));

	if (!(methods & FLAG (METH_CONFIGURE))) {
	  clonePtr->setOptionProc = NULL;
	}

	if (
	    !(methods & FLAG (METH_CGET)) &&
	    !(methods & FLAG (METH_CGETALL))
	    ) {
	    clonePtr->getOptionProc = NULL;
	}
	if (!(methods & FLAG (METH_BLOCKING))) {
	    clonePtr->blockModeProc = NULL;
	}
	if (!(methods & FLAG (METH_SEEK))) {
	    clonePtr->seekProc     = NULL;
	    clonePtr->wideSeekProc = NULL;
	}

	chanPtr->typePtr = clonePtr;
    }

    Tcl_RegisterChannel (interp, chan);

    /* Return handle as result of command */

    Tcl_SetObjResult (interp, rcId);
    return TCL_OK;

 error:
    /* Signal to RcClose to not call 'finalize' */
    rcPtr->methods = 0;
    Tcl_Close (interp, chan);
    return TCL_ERROR;

#undef MODE
#undef CMD
}

/*
 *----------------------------------------------------------------------
 *
 * TclChanPostEventObjCmd --
 *
 *	This procedure is invoked to process the "chan postevent"
 *	Tcl command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Posts events to a reflected channel, invokes event handlers.
 *	The latter implies that arbitrary side effects are possible.
 *
 *----------------------------------------------------------------------
 */

int
TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv)
     ClientData      clientData;
     Tcl_Interp*     interp;
     int             objc;
     Tcl_Obj* CONST* objv;
{
    /* Syntax:   chan postevent CHANNEL EVENTSPEC
     *           [0]  [1]       [2]     [3]
     *
     * Actually: rPostevent CHANNEL EVENTSPEC
     *           [0]        [1]     [2]
     *
     *         where EVENTSPEC = {read write ...} (Abbreviations allowed as well.
     */

#define CHAN  (1)
#define EVENT (2)

    CONST char*        chanId;      /* Tcl level channel handle */
    Tcl_Channel        chan;        /* Channel associated to the handle */
    Tcl_ChannelType*   chanTypePtr; /* Its associated driver structure */
    ReflectingChannel* rcPtr;       /* Associated instance data */
    int                mode;        /* Dummy, r|w mode of the channel */
    int                events;      /* Mask of events to post */

    /* Number of arguments ... */

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec");
	return TCL_ERROR;
    }

    /* First argument is a channel, a reflected channel, and the call
     * of this command is done from the interp defining the channel
     * handler cmd.
     */

    chanId = Tcl_GetString (objv [CHAN]);
    chan   = Tcl_GetChannel(interp, chanId, &mode);

    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }

    chanTypePtr = Tcl_GetChannelType (chan);

    /* We use a function referenced by the channel type as our cookie
     * to detect calls to non-reflecting channels. The channel type
     * itself is not suitable, as it might not be the static
     * definition in this file, but a clone thereof. And while we have
     * reserved the name of the type nothing in the core checks
     * against violation, so someone else might have created a channel
     * type using our name, clashing with ourselves.
     */

    if (chanTypePtr->watchProc != &RcWatch) {
        Tcl_AppendResult(interp, "channel \"", chanId,
			 "\" is not a reflected channel",
			 (char *) NULL);
	return TCL_ERROR;
    }

    rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan);

    if (rcPtr->interp != interp) {
        Tcl_AppendResult(interp, "postevent for channel \"", chanId,
			 "\" called from outside interpreter",
			 (char *) NULL);
	return TCL_ERROR;
    }

    /* Second argument is a list of events. Allowed entries are
     * "read", "write". Expect at least one list element.
     * Abbreviations are ok.
     */

    if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) {
        return TCL_ERROR;
    }
    
    /* Check that the channel is actually interested in the provided
     * events.
     */

    if (events & ~rcPtr->interest) {
        Tcl_AppendResult(interp, "tried to post events channel \"", chanId,
			 "\" is not interested in",
			 (char *) NULL);
	return TCL_ERROR;
    }

    /* We have the channel and the events to post.
     */

    Tcl_NotifyChannel (chan, events);

    /* Squash interp results left by the event script.
     */

    Tcl_ResetResult (interp);
    return TCL_OK;

#undef CHAN
#undef EVENT
}


static Tcl_Obj*
RcErrorMarshall (interp)
     Tcl_Interp *interp;
{
    /* Capture the result status of the interpreter into a string.
     * => List of options and values, followed by the error message.
     * The result has refCount 0.
     */
    
    Tcl_Obj* returnOpt = Tcl_GetReturnOptions (interp, TCL_ERROR);

    /* => returnOpt.refCount == 0. We can append directly.
     */

    Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp));
    return returnOpt;
}

static void
RcErrorReturn (interp, msg)
     Tcl_Interp *interp;
     Tcl_Obj    *msg;
{
    int       res;
    int       lc;
    Tcl_Obj** lv;
    int       explicitResult;
    int       numOptions;

    /* Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. Because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information.
     */

    res = Tcl_ListObjGetElements (interp, msg, &lc, &lv);
    if (res != TCL_OK) {
	Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result");
    }

    explicitResult = (1 == (lc % 2));
    numOptions     = lc - explicitResult;

    if (explicitResult) {
	Tcl_SetObjResult (interp, lv [lc-1]);
    }

    (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv));
}

int
TclChanCaughtErrorBypass (interp, chan)
     Tcl_Interp *interp;
     Tcl_Channel chan;
{
    Tcl_Obj* msgc = NULL;
    Tcl_Obj* msgi = NULL;
    Tcl_Obj* msg  = NULL;

    /* Get a bypassed error message from channel and/or interpreter, save the
     * reference, then kill the returned objects, if there were any. If there
     * are messages in both the channel has preference.
     */

    if ((chan == NULL) && (interp == NULL)) {
	return 0;
    }

    if (chan != NULL) {
	Tcl_GetChannelError       (chan,   &msgc);
    }
    if (interp != NULL) {
	Tcl_GetChannelErrorInterp (interp, &msgi);
    }

    if (msgc != NULL) {
	msg = msgc;
	Tcl_IncrRefCount (msg);
    } else if (msgi != NULL) {
	msg = msgi;
	Tcl_IncrRefCount (msg);
    }

    if (msgc != NULL) {
	Tcl_DecrRefCount (msgc);
    }
    if (msgi != NULL) {
	Tcl_DecrRefCount (msgi);
    }

    /* No message returned, nothing caught.
     */

    if (msg == NULL) {
	return 0;
    }

    RcErrorReturn (interp, msg);

    Tcl_DecrRefCount (msg);
    return 1;
}

/*
 * Driver functions. ================================================
 */

/*
 *----------------------------------------------------------------------
 *
 * RcClose --
 *
 *	This function is invoked when the channel is closed, to delete
 *	the driver specific instance data.
 *
 * Results:
 *	A posix error.
 *
 * Side effects:
 *	Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcClose (clientData, interp)
     ClientData  clientData;
     Tcl_Interp* interp;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    int                res;         /* Result code for 'close' */
    Tcl_Obj*           resObj;      /* Result data for 'close' */

    if (interp == (Tcl_Interp*) NULL) {
        /* This call comes from TclFinalizeIOSystem. There are no
	 * interpreters, and therefore we cannot call upon the handler
	 * command anymore. Threading is irrelevant as well.  We
	 * simply clean up all our C level data structures and leave
	 * the Tcl level to the other finalization functions.
	 */

      /* THREADED => Forward this to the origin thread */
      /* Note: Have a thread delete handler for the origin
       * thread. Use this to clean up the structure!
       */

#ifdef TCL_THREADS
        /* Are we in the correct thread ?
	 */

        if (rcPtr->thread != Tcl_GetCurrentThread ()) {
	    RcForwardParamClose p;

	    RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p);
	    res = p.b.code;

	    /* RcFree is done in the forwarded operation!,
	     * in the other thread. rcPtr here is gone!
	     */

	    if (res != TCL_OK) {
	        RcFreeReceivedError (p.b);
	    }
	} else {
#endif
	    RcFree (rcPtr);
#ifdef TCL_THREADS
	}
#endif
	return EOK;
    }

    /* -------- */

    /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */

    /* A cleaned method mask here implies that the channel creation
     * was aborted, and "finalize" must not be called.
     */

    if (rcPtr->methods == 0) {
        RcFree (rcPtr);
        return EOK;
    } else {
#ifdef TCL_THREADS
        /* Are we in the correct thread ?
	 */

        if (rcPtr->thread != Tcl_GetCurrentThread ()) {
	    RcForwardParamClose p;

	    RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p);
	    res = p.b.code;

	    /* RcFree is done in the forwarded operation!,
	     * in the other thread. rcPtr here is gone!
	     */

	    if (res != TCL_OK) {
	        RcPassReceivedErrorInterp (interp, p.b);
	    }
	} else {
#endif
	    RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL,
			       &res, &resObj, DO_CAPTURE);

	    if ((res != TCL_OK) && (interp != NULL)) {
	        Tcl_SetChannelErrorInterp (interp, resObj);
	    }

	    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
#ifdef TCL_THREADS
	    RcFree (rcPtr);
	}
#endif
	return (res == TCL_OK) ? EOK : EINVAL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * RcInput --
 *
 *	This function is invoked when more data is requested from the
 *	channel.
 *
 * Results:
 *	The number of bytes read.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcInput (clientData, buf, toRead, errorCodePtr)
     ClientData clientData;
     char* buf;
     int toRead;
     int* errorCodePtr;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           toReadObj;
    int                bytec;       /* Number of returned bytes */
    unsigned char*     bytev;       /* Array of returned bytes */
    int                res;         /* Result code for 'read' */
    Tcl_Obj*           resObj;      /* Result data for 'read' */

    /* The following check can be done before thread redirection,
     * because we are reading from an item which is readonly, i.e.
     * will never change during the lifetime of the channel.
     */

    if (!(rcPtr->methods & FLAG (METH_READ))) {
        RcSetChannelErrorStr (rcPtr->chan, msg_read_unsup);
	*errorCodePtr = EINVAL;
	return -1;
    }

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamInput p;

	p.buf    = buf;
	p.toRead = toRead;

	RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    RcPassReceivedError (rcPtr->chan, p.b);
	    *errorCodePtr = EINVAL;
	} else {
	    *errorCodePtr = EOK;
	}

	return p.toRead;
    }
#endif

    /* -------- */

    /* ASSERT: rcPtr->method & FLAG (METH_READ) */
    /* ASSERT: rcPtr->mode & TCL_READABLE */

    toReadObj = Tcl_NewIntObj(toRead);
    if (toReadObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcInput");
    }

    RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	*errorCodePtr = EINVAL;
	return -1;
    }

    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

    if (toRead < bytec) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch);
	*errorCodePtr = EINVAL;
	return -1;
    }

    *errorCodePtr = EOK;

    if (bytec > 0) {
        memcpy (buf, bytev, bytec);
    }

    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
    return bytec;
}

/*
 *----------------------------------------------------------------------
 *
 * RcOutput --
 *
 *	This function is invoked when data is writen to the
 *	channel.
 *
 * Results:
 *	The number of bytes actually written.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcOutput (clientData, buf, toWrite, errorCodePtr)
     ClientData clientData;
     CONST char* buf;
     int toWrite;
     int* errorCodePtr;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*       bufObj;
    int            res;         /* Result code for 'write' */
    Tcl_Obj*       resObj;      /* Result data for 'write' */
    int            written;

    /* The following check can be done before thread redirection,
     * because we are reading from an item which is readonly, i.e.
     * will never change during the lifetime of the channel.
     */

    if (!(rcPtr->methods & FLAG (METH_WRITE))) {
        RcSetChannelErrorStr (rcPtr->chan, msg_write_unsup);
        *errorCodePtr = EINVAL;
	return -1;
    }

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
      RcForwardParamOutput p;

      p.buf     = buf;
      p.toWrite = toWrite;

      RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p);

      if (p.b.code != TCL_OK) {
	  RcPassReceivedError (rcPtr->chan, p.b);
	  *errorCodePtr = EINVAL;
      } else {
	  *errorCodePtr = EOK;
      }

      return p.toWrite;
    }
#endif

    /* -------- */

    /* ASSERT: rcPtr->method & FLAG (METH_WRITE) */
    /* ASSERT: rcPtr->mode & TCL_WRITABLE */
    
    bufObj = Tcl_NewByteArrayObj((unsigned char*) buf, toWrite);
    if (bufObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcOutput");
    }

    RcInvokeTclMethod (rcPtr, "write", bufObj, NULL,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	*errorCodePtr = EINVAL;
	return -1;
    }

    res = Tcl_GetIntFromObj (rcPtr->interp, resObj, &written);
    if (res != TCL_OK) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp));
	*errorCodePtr = EINVAL;
	return -1;
    }

    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */

    if ((written == 0) || (toWrite < written)) {
        /* The handler claims to have written more than it was given.
	 * That is bad. Note that the I/O core would crash if we were
	 * to return this information, trying to write -nnn bytes in
	 * the next iteration.
	 */

        RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch);
	*errorCodePtr = EINVAL;
	return -1;
    }

    *errorCodePtr = EOK;
    return written;
}

/*
 *----------------------------------------------------------------------
 *
 * RcSeekWide / RcSeek --
 *
 *	This function is invoked when the user wishes to seek on
 *	the channel.
 *
 * Results:
 *	The new location of the access point.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
RcSeekWide (clientData, offset, seekMode, errorCodePtr)
     ClientData  clientData;
     Tcl_WideInt offset;
     int         seekMode;
     int*        errorCodePtr;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*       offObj;
    Tcl_Obj*       baseObj;
    int            res;         /* Result code for 'seek' */
    Tcl_Obj*       resObj;      /* Result data for 'seek' */
    Tcl_WideInt    newLoc;

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamSeek p;

	p.seekMode = seekMode;
	p.offset   = offset;

	RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    RcPassReceivedError (rcPtr->chan, p.b);
	    *errorCodePtr = EINVAL;
	} else {
	    *errorCodePtr = EOK;
	}

	return p.offset;
    }
#endif

    /* -------- */

    /* ASSERT: rcPtr->method & FLAG (METH_SEEK) */

    offObj = Tcl_NewWideIntObj(offset);
    if (offObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcSeekWide");
    }

    baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ?
			       "start" :
			       ((seekMode == SEEK_CUR) ?
				"current" :
				"end"), -1);

    if (baseObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcSeekWide");
    }

    RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	*errorCodePtr = EINVAL;
	return -1;
    }

    res = Tcl_GetWideIntFromObj (rcPtr->interp, resObj, &newLoc);
    if (res != TCL_OK) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp));
	*errorCodePtr = EINVAL;
	return -1;
    }

    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */

    if (newLoc < Tcl_LongAsWide (0)) {
        RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart);
        *errorCodePtr = EINVAL;
	return -1;
    }

    *errorCodePtr = EOK;
    return newLoc;
}

static int
RcSeek (clientData, offset, seekMode, errorCodePtr)
     ClientData  clientData;
     long        offset;
     int         seekMode;
     int*        errorCodePtr;
{
  /* This function can be invoked from a transformation which is based
   * on standard seeking, i.e. non-wide. Because o this we have to
   * implement it, a dummy is not enough. We simply delegate the call
   * to the wide routine.
   */

  return (int) RcSeekWide (clientData, Tcl_LongAsWide (offset),
			   seekMode, errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * RcWatch --
 *
 *	This function is invoked to tell the channel what events
 *	the I/O system is interested in.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static void
RcWatch (clientData, mask)
     ClientData clientData;
     int mask;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj* maskObj;

    /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */

    /* We restrict the interest to what the channel can support
     * IOW there will never be write events for a channel which is
     * not writable. Analoguous for read events.
     */

    mask = mask & rcPtr->mode; 

    if (mask == rcPtr->interest) {
        /* Same old, same old, why should we do something ? */
      return;
    }

    rcPtr->interest = mask;

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamWatch p;

	p.mask = mask;

	RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p);

	/* Any failure from the forward is ignored. We have no place to
	 * put this.
	 */
	return;
    }
#endif

    /* -------- */

    maskObj = RcDecodeEventMask (mask);
    RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL,
		       NULL, NULL, NO_CAPTURE);
    Tcl_DecrRefCount (maskObj);
}

/*
 *----------------------------------------------------------------------
 *
 * RcBlock --
 *
 *	This function is invoked to tell the channel which blocking
 *	behaviour is required of it.
 *
 * Results:
 *	A posix error number.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcBlock (clientData, nonblocking)
     ClientData clientData;
     int nonblocking;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           blockObj;
    int                res;         /* Result code for 'blocking' */
    Tcl_Obj*           resObj;      /* Result data for 'blocking' */

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamBlock p;

	p.nonblocking = nonblocking;

	RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    RcPassReceivedError (rcPtr->chan, p.b);
	    return EINVAL;
	} else {
	    return EOK;
	}
    }
#endif

    /* -------- */

    blockObj = Tcl_NewBooleanObj(!nonblocking);
    if (blockObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcBlock");
    }

    RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
	res = EINVAL;
    } else {
        res = EOK;
    }

    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * RcSetOption --
 *
 *	This function is invoked to configure a channel option.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Arbitrary, as it calls upon a Tcl script.
 *
 *----------------------------------------------------------------------
 */

static int
RcSetOption (clientData, interp, optionName, newValue)
     ClientData   clientData;	/* Channel to query */
     Tcl_Interp   *interp;	/* Interpreter to leave error messages in */
     CONST char *optionName;	/* Name of requested option */
     CONST char *newValue;	/* The new value */
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           optionObj;
    Tcl_Obj*           valueObj;
    int                res;         /* Result code for 'configure' */
    Tcl_Obj*           resObj;      /* Result data for 'configure' */

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamSetOpt p;

	p.name  = optionName;
	p.value = newValue;

	RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1);

	    RcErrorReturn (interp, err);

	    Tcl_DecrRefCount (err);
	    if (p.b.vol) {ckfree (p.b.msg);}
	}

	return p.b.code;
    }
#endif

  /* -------- */

  optionObj = Tcl_NewStringObj(optionName,-1);
  if (optionObj == (Tcl_Obj*) NULL) {
    Tcl_Panic ("Out of memory in RcSetOption");
  }

  valueObj = Tcl_NewStringObj(newValue,-1);
  if (valueObj == (Tcl_Obj*) NULL) {
    Tcl_Panic ("Out of memory in RcSetOption");
  }

  RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj,
		     &res, &resObj, DO_CAPTURE);

  if (res != TCL_OK) {
    RcErrorReturn (interp, resObj);
  }

  Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
  return res;
}

/*
 *----------------------------------------------------------------------
 *
 * RcGetOption --
 *
 *	This function is invoked to retrieve all or a channel option.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Arbitrary, as it calls upon a Tcl script.
 *
 *----------------------------------------------------------------------
 */

static int
RcGetOption (clientData, interp, optionName, dsPtr)
     ClientData   clientData;	/* Channel to query */
     Tcl_Interp*  interp;	/* Interpreter to leave error messages in */
     CONST char* optionName;	/* Name of reuqested option */
     Tcl_DString* dsPtr;	/* String to place the result into */
{
    /* This code is special. It has regular passing of Tcl result, and
     * errors. The bypass functions are not required.
     */

    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           optionObj;
    int                res;         /* Result code for 'configure' */
    Tcl_Obj*           resObj;      /* Result data for 'configure' */
    int                listc;
    Tcl_Obj**          listv;
    const char*        method;

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        int opcode;
        RcForwardParamGetOpt p;

	p.name  = optionName;
	p.value = dsPtr;

	if (optionName == (char*) NULL) {
	    opcode = RcOpGetOptAll;
	} else {
	    opcode = RcOpGetOpt;
	}

	RcForwardOp (rcPtr, opcode, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1);

	    RcErrorReturn (interp, err);

	    Tcl_DecrRefCount (err);
	    if (p.b.vol) {ckfree (p.b.msg);}
	}

	return p.b.code;
    }
#endif

    /* -------- */

    if (optionName == (char*) NULL) {
        /* Retrieve all options. */
        method    = "cgetall";
	optionObj = NULL;
    } else {
        /* Retrieve the value of one option */
      
        method    = "cget";
	optionObj = Tcl_NewStringObj(optionName,-1);
	if (optionObj == (Tcl_Obj*) NULL) {
	    Tcl_Panic ("Out of memory in RcGetOption");
	}
    }

    RcInvokeTclMethod (rcPtr, method, optionObj, NULL,
			 &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
        RcErrorReturn (interp, resObj);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    /* The result has to go into the 'dsPtr' for propagation to the
     * caller of the driver.
     */

    if (optionObj != NULL) {
        Tcl_DStringAppend (dsPtr, Tcl_GetString (resObj), -1);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    /* Extract the list and append each item as element.
     */

    /* NOTE (4): If we extract the string rep we can assume a
     * NOTE (4): properly quoted string. Together with a separating
     * NOTE (4): space this way of simply appending the whole string
     * NOTE (4): rep might be faster. It also doesn't check if the
     * NOTE (4): result is a valid list. Nor that the list has an
     * NOTE (4): even number elements.
     * NOTE (4): ---
     */

    res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv);

    if (res != TCL_OK) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    if ((listc % 2) == 1) {
        /* Odd number of elements is wrong.
	 */
	Tcl_Obj *objPtr = Tcl_NewObj();
	Tcl_ResetResult(interp);
	TclObjPrintf(NULL, objPtr, "Expected list with even number of "
		"elements, got %d element%s instead", listc, 
		(listc == 1 ? "" : "s"));
	Tcl_SetObjResult(interp, objPtr);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return TCL_ERROR;
    }


    {
        int len;
	char* str = Tcl_GetStringFromObj (resObj, &len);

	if (len) {
	    Tcl_DStringAppend (dsPtr, " ", 1);
	    Tcl_DStringAppend (dsPtr, str, len);
	}
    }
    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
    return res;
}

/*
 * Helpers. =========================================================
 */

/*
 *----------------------------------------------------------------------
 *
 * RcEncodeEventMask --
 *
 *	This function takes a list of event items and constructs the
 *	equivalent internal bitmask. The list has to contain at
 *	least one element. Elements are "read", "write", or any unique
 *	abbreviation thereof. Note that the bitmask is not changed if
 *	problems are encountered.
 *
 * Results:
 *	A standard Tcl error code. A bitmask where TCL_READABLE
 *	and/or TCL_WRITABLE can be set.
 *
 * Side effects:
 *	May shimmer 'obj' to a list representation. May place an
 *	error message into the interp result.
 *
 *----------------------------------------------------------------------
 */

static int
RcEncodeEventMask (interp, objName, obj, mask)
     Tcl_Interp* interp;
     CONST char* objName;
     Tcl_Obj*    obj;
     int*        mask;
{
    int        events;	/* Mask of events to post */
    int        listc;     /* #elements in eventspec list */
    Tcl_Obj**  listv;     /* Elements of eventspec list */
    int        evIndex;   /* Id of event for an element of the
			 * eventspec list */

    if (Tcl_ListObjGetElements (interp, obj,
				&listc, &listv) != TCL_OK) {
        return TCL_ERROR;
    }

    if (listc < 1) {
        Tcl_AppendResult(interp, "bad ", objName, " list: is empty",
			 (char *) NULL);
	return TCL_ERROR;
    }

    events = 0;
    while (listc > 0) {
        if (Tcl_GetIndexFromObj (interp, listv [listc-1],
				 eventOptions, objName, 0, &evIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (evIndex) {
	    case EVENT_READ:  events |= TCL_READABLE; break;
	    case EVENT_WRITE: events |= TCL_WRITABLE; break;
	}
	listc --;
    }

    *mask = events;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * RcDecodeEventMask --
 *
 *	This function takes an internal bitmask of events and
 *	constructs the equivalent list of event items.
 *
 * Results:
 *	A Tcl_Obj reference. The object will have a refCount of
 *	one. The user has to decrement it to release the object.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
RcDecodeEventMask (mask)
     int mask;
{
    Tcl_Obj* evObj = Tcl_NewStringObj (((mask & RANDW) == RANDW) ?
				       "read write" :
				       ((mask & TCL_READABLE) ?
					"read" :
					((mask & TCL_WRITABLE) ?
					 "write" : "")), -1);
    if (evObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcDecodeEventMask");
    }

    Tcl_IncrRefCount (evObj);
    return evObj;
}

/*
 *----------------------------------------------------------------------
 *
 * RcNew --
 *
 *	This function is invoked to allocate and initialize the
 *	instance data of a new reflected channel.
 *
 * Results:
 *	A heap-allocated channel instance.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

static ReflectingChannel*
RcNew (interp, cmdpfxObj, mode, id)
       Tcl_Interp* interp;
       Tcl_Obj*    cmdpfxObj;
       int         mode;
       Tcl_Obj*    id;
{
    ReflectingChannel* rcPtr;
    int                listc;
    Tcl_Obj**          listv;
    Tcl_Obj*           word;
    int                i;

    rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel));

    /* rcPtr->chan    : Assigned by caller. Dummy data here. */
    /* rcPtr->methods : Assigned by caller. Dummy data here. */

    rcPtr->chan     = (Tcl_Channel) NULL;
    rcPtr->methods  = 0;
    rcPtr->interp   = interp;
#ifdef TCL_THREADS
    rcPtr->thread   = Tcl_GetCurrentThread ();
#endif
    rcPtr->mode     = mode;
    rcPtr->interest = 0; /* Initially no interest registered */

    /* Method placeholder */

    /* ASSERT: cmdpfxObj is a Tcl List */

    Tcl_ListObjGetElements (interp, cmdpfxObj, &listc, &listv);

    /* See [==] as well.
     * Storage for the command prefix and the additional words required
     * for the invocation of methods in the command handler.
     *
     * listv [0] [listc-1] | [listc]  [listc+1] |
     * argv  [0]   ... [.] | [argc-2] [argc-1]  | [argc]  [argc+2]
     *       cmd   ... pfx | method   chan      | detail1 detail2
     */

    rcPtr->argc = listc + 2;
    rcPtr->argv = (Tcl_Obj**) ckalloc (sizeof (Tcl_Obj*) * (listc+4));

    for (i = 0; i < listc ; i++) {
        word = rcPtr->argv [i] = listv [i];
        Tcl_IncrRefCount (word);
    }

    i++; /* Skip placeholder for method */

    rcPtr->argv [i] = id ; Tcl_IncrRefCount (id);

    /* The next two objects are kept empty, varying arguments */

    /* Initialization complete */
    return rcPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * RcNewHandle --
 *
 *	This function is invoked to generate a channel handle for
 *	a new reflected channel.
 *
 * Results:
 *	A Tcl_Obj containing the string of the new channel handle.
 *	The refcount of the returned object is -- zero --.
 *
 * Side effects:
 *	May allocate memory. Mutex protected critical section
 *	locks out other threads for a short time.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
RcNewHandle ()
{
    /* Count number of generated reflected channels.  Used for id
     * generation. Ids are never reclaimed and there is no dealing
     * with wrap around. On the other hand, "unsigned long" should be
     * big enough except for absolute longrunners (generate a 100 ids
     * per second => overflow will occur in 1 1/3 years).
     */

#ifdef TCL_THREADS
    TCL_DECLARE_MUTEX (rcCounterMutex)
#endif
    static unsigned long rcCounter = 0;

    Tcl_Obj* res = Tcl_NewObj ();

#ifdef TCL_THREADS
    Tcl_MutexLock (&rcCounterMutex);
#endif

    TclObjPrintf(NULL, res, "rc%lu", rcCounter);
    rcCounter ++;

#ifdef TCL_THREADS
    Tcl_MutexUnlock (&rcCounterMutex);
#endif

    return res;
}


static void
RcFree (rcPtr)
     ReflectingChannel* rcPtr;
{
    Channel* chanPtr = (Channel*) rcPtr->chan;
    int      i, n;

    if (chanPtr->typePtr != &tclRChannelType) {
        /* Delete a cloned ChannelType structure. */
        ckfree ((char*) chanPtr->typePtr);
    }

    n = rcPtr->argc - 2;
    for (i = 0; i < n; i++) {
        Tcl_DecrRefCount (rcPtr->argv[i]);
    }

    ckfree ((char*) rcPtr->argv);
    ckfree ((char*) rcPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * RcInvokeTclMethod --
 *
 *	This function is used to invoke the Tcl level of a reflected
 *	channel. It handles all the command assembly, invokation, and
 *	generic state and result mgmt.
 *
 * Results:
 *      Result code and data as returned by the method.
 *
 * Side effects:
 *	Arbitrary, as it calls upo na Tcl script.
 *
 *----------------------------------------------------------------------
 */

static void
RcInvokeTclMethod (rcPtr, method, argone, argtwo, result, resultObj, capture)
     ReflectingChannel* rcPtr;
     CONST char*        method;
     Tcl_Obj*           argone;    /* NULL'able */
     Tcl_Obj*           argtwo;    /* NULL'able */
     int*               result;    /* NULL'able */
     Tcl_Obj**          resultObj; /* NULL'able */
     int                capture;
{
    /* Thread redirection was done by higher layers */
    /* ASSERT: Tcl_GetCurrentThread () == rcPtr->thread */

    int             cmdc;           /* #words in constructed command */
    Tcl_Obj*        methObj = NULL; /* Method name in object form */
    Tcl_InterpState sr;             /* State of handler interp */
    int             res;            /* Result code of method invokation */
    Tcl_Obj*        resObj  = NULL; /* Result of method invokation. */

    /* NOTE (5): Decide impl. issue: Cache objects with method names ?
     * NOTE (5): Requires TSD data as reflections can be created in
     * NOTE (5): many different threads.
     * NOTE (5): ---
     */

    /* Insert method into the pre-allocated area, after the command
     * prefix, before the channel id.
     */

    methObj = Tcl_NewStringObj (method, -1);
    if (methObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcInvokeTclMethod");
    }
    Tcl_IncrRefCount (methObj);
    rcPtr->argv [rcPtr->argc - 2] = methObj;

    /* Append the additional argument containing method specific
     * details behind the channel id. If specified.
     */

    cmdc = rcPtr->argc ;
    if (argone) {
        Tcl_IncrRefCount (argone);
	rcPtr->argv [cmdc] = argone;
	cmdc++;
    }
    if (argtwo) {
        Tcl_IncrRefCount (argtwo);
	rcPtr->argv [cmdc] = argtwo;
	cmdc++;
    }

    /* And run the handler ...  This is done in auch a manner which
     * leaves any existing state intact.
     */

    sr  = Tcl_SaveInterpState (rcPtr->interp, 0 /* Dummy */);
    res = Tcl_EvalObjv        (rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);

    /* We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */

    if (resultObj) {
	if ((res == TCL_OK) || !capture) {
	    /* Ok result taken as is, also if the caller requests that there
	     * is no capture.
	     */

	    resObj = Tcl_GetObjResult (rcPtr->interp);
	} else {
	    /* Non-ok ressult is always treated as an error.
	     * We have to capture the full state of the result,
	     * including additional options.
	     */

	    res    = TCL_ERROR;
	    resObj = RcErrorMarshall (rcPtr->interp);
	}
	Tcl_IncrRefCount(resObj);
    }
    Tcl_RestoreInterpState (rcPtr->interp, sr);

    /* ... */

    /* Cleanup of the dynamic parts of the command */

    Tcl_DecrRefCount (methObj);
    if (argone) {Tcl_DecrRefCount (argone);}
    if (argtwo) {Tcl_DecrRefCount (argtwo);}

    /* The resObj has a ref count of 1 at this location.  This means
     * that the caller of RcInvoke has to dispose of it (but only if
     * it was returned to it).
     */

    if (result) {
        *result = res;
    }
    if (resultObj) {
        *resultObj = resObj;
    }
    /* There no need to handle the case where nothing is returned, because for
     * that case resObj was not set anyway.
     */
}

#ifdef TCL_THREADS
static void
RcForwardOp (rcPtr, op, dst, param)
  ReflectingChannel* rcPtr; /* Channel instance */
  RcOperation        op;    /* Forwarded driver operation */
  Tcl_ThreadId       dst;   /* Destination thread */
  CONST VOID*        param; /* Arguments */
{
    RcForwardingEvent*  evPtr;
    RcForwardingResult* resultPtr;
    int                 result;

    /* Create and initialize the event and data structures */

    evPtr     = (RcForwardingEvent*)  ckalloc (sizeof (RcForwardingEvent));
    resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult));

    evPtr->event.proc = RcForwardProc;
    evPtr->resultPtr  = resultPtr;
    evPtr->op         = op;
    evPtr->rcPtr      = rcPtr;
    evPtr->param      = param;

    resultPtr->src    = Tcl_GetCurrentThread ();
    resultPtr->dst    = dst;
    resultPtr->done   = (Tcl_Condition) NULL;
    resultPtr->result = -1;
    resultPtr->evPtr  = evPtr;

    /* Now execute the forward */

    Tcl_MutexLock(&rcForwardMutex);
    TclSpliceIn(resultPtr, forwardList);

    /*
     * Ensure cleanup of the event if any of the two involved threads
     * exits while this event is pending or in progress.
     */

    Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr);
    Tcl_CreateThreadExitHandler(RcDstExitProc, (ClientData) evPtr);

    /*
     * Queue the event and poke the other thread's notifier.
     */

    Tcl_ThreadQueueEvent(dst, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(dst);

    /*
     * (*) Block until the other thread has either processed the transfer
     * or rejected it.
     */

    while (resultPtr->result < 0) {
        /* NOTE (1): Is it possible that the current thread goes away while waiting here ?
	 * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ?
	 * NOTE (1): See complementary note (2) in "RcSrcExitProc"
	 * NOTE (1): ---
	 */

        Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL);
    }

    /*
     * Unlink result from the forwarder list.
     */

    TclSpliceOut(resultPtr, forwardList);

    resultPtr->nextPtr  = NULL;
    resultPtr->prevPtr  = NULL;

    Tcl_MutexUnlock(&rcForwardMutex);
    Tcl_ConditionFinalize(&resultPtr->done);

    /*
     * Kill the cleanup handlers now, and the result structure as well,
     * before returning the success code.
     *
     * Note: The event structure has already been deleted.
     */

    Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr);
    Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr);
    
    result =  resultPtr->result;
    ckfree ((char*) resultPtr);
}

static int
RcForwardProc (evGPtr, mask)
     Tcl_Event *evGPtr; 
     int mask;
{
    /* Notes regarding access to the referenced data.
     *
     * In principle the data belongs to the originating thread (see
     * evPtr->src), however this thread is currently blocked at (*),
     * i.e. quiescent. Because of this we can treat the data as
     * belonging to us, without fear of race conditions. I.e. we can
     * read and write as we like.
     *
     * The only thing we cannot be sure of is the resultPtr. This can be
     * be NULLed if the originating thread went away while the event
     * is handled here now.
     */

    RcForwardingEvent*  evPtr     = (RcForwardingEvent*) evGPtr;
    RcForwardingResult* resultPtr = evPtr->resultPtr;
    ReflectingChannel*  rcPtr     = evPtr->rcPtr;
    Tcl_Interp*         interp    = rcPtr->interp;
    RcForwardParamBase* paramPtr  = (RcForwardParamBase*) evPtr->param;
    int                 res       = TCL_OK; /* Result code   of RcInvokeTclMethod */
    Tcl_Obj*            resObj    = NULL;   /* Interp result of RcInvokeTclMethod */

    /* Ignore the event if no one is waiting for its result anymore.
     */

    if (!resultPtr) {
        return 1;
    }

    paramPtr->code = TCL_OK;
    paramPtr->msg  = NULL;
    paramPtr->vol  = 0;

    switch (evPtr->op) {
      /* The destination thread for the following operations is
       * rcPtr->thread, which contains rcPtr->interp, the interp
       * we have to call upon for the driver.
       */

    case RcOpClose:
      {
	  /* No parameters/results */
	  RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	     RcForwardSetObjError (paramPtr, resObj);
	  }

	  /* Freeing is done here, in the origin thread, because the
	   * argv[] objects belong to this thread. Deallocating them
	   * in a different thread is not allowed
	   */

	  RcFree (rcPtr);
      }
      break;

    case RcOpInput:
      {
	  RcForwardParamInput* p = (RcForwardParamInput*) paramPtr;
	  Tcl_Obj*     toReadObj = Tcl_NewIntObj (p->toRead);

	  if (toReadObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcInput");
	  }

	  RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	      p->toRead = -1;
	  } else {
	      /* Process a regular result. */

	      int            bytec; /* Number of returned bytes */
	      unsigned char* bytev; /* Array of returned bytes */

	      bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	      if (p->toRead < bytec) {
		  RcForwardSetStaticError (paramPtr, msg_read_toomuch);
		  p->toRead   = -1;

	      } else {
	          if (bytec > 0) {
		      memcpy (p->buf, bytev, bytec);
		  }

		  p->toRead = bytec;
	      }
	  }
      }
      break;

    case RcOpOutput:
      {
	  RcForwardParamOutput* p = (RcForwardParamOutput*) paramPtr;
	  Tcl_Obj*         bufObj = Tcl_NewByteArrayObj((unsigned char*) p->buf, p->toWrite);

	  if (bufObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcOutput");
	  }

	  RcInvokeTclMethod (rcPtr, "write", bufObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	      p->toWrite = -1;
	  } else {
	      /* Process a regular result. */

	      int written;

	      res = Tcl_GetIntFromObj (interp, resObj, &written);
	      if (res != TCL_OK) {

		  RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
		  p->toWrite = -1;

	      } else if ((written == 0) || (p->toWrite < written)) {

		  RcForwardSetStaticError (paramPtr, msg_write_toomuch);
		  p->toWrite = -1;

	      } else {
		  p->toWrite = written;
	      }
	  }
      }
      break;

    case RcOpSeek:
      {
	  RcForwardParamSeek* p = (RcForwardParamSeek*) paramPtr;

	  Tcl_Obj*       offObj;
	  Tcl_Obj*       baseObj;

	  offObj = Tcl_NewWideIntObj(p->offset);
	  if (offObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSeekWide");
	  }

	  baseObj = Tcl_NewStringObj((p->seekMode == SEEK_SET) ?
				     "start" :
				     ((p->seekMode == SEEK_CUR) ?
				      "current" :
				      "end"), -1);

	  if (baseObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSeekWide");
	  }

	  RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	      p->offset = -1;
	  } else {
	      /* Process a regular result. If the type is wrong this
	       * may change into an error.
	       */

	      Tcl_WideInt newLoc;
	      res = Tcl_GetWideIntFromObj (interp, resObj, &newLoc);

	      if (res == TCL_OK) {
		  if (newLoc < Tcl_LongAsWide (0)) {
		      RcForwardSetStaticError (paramPtr, msg_seek_beforestart);
		      p->offset = -1;
		  } else {
		      p->offset = newLoc;
		  }
	      } else {
		  RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
		  p->offset = -1;
	      }
	  }
      }
      break;

    case RcOpWatch:
      {
	  RcForwardParamWatch* p = (RcForwardParamWatch*) paramPtr;

	  Tcl_Obj* maskObj = RcDecodeEventMask (p->mask);
	  RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL,
			     NULL, NULL, NO_CAPTURE);
	  Tcl_DecrRefCount (maskObj);
      }
    break;

    case RcOpBlock:
      {
	  RcForwardParamBlock* p = (RcForwardParamBlock*) evPtr->param;
	  Tcl_Obj*      blockObj = Tcl_NewBooleanObj(!p->nonblocking);

	  if (blockObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcBlock");
	  }

	  RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  }
      }
      break;

    case RcOpSetOpt:
      {
	  RcForwardParamSetOpt* p = (RcForwardParamSetOpt*) paramPtr;
	  Tcl_Obj* optionObj;
	  Tcl_Obj* valueObj;

	  optionObj = Tcl_NewStringObj(p->name,-1);
	  if (optionObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSetOption");
	  }

	  valueObj = Tcl_NewStringObj(p->value,-1);
	  if (valueObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSetOption");
	  }

	  RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  }
      }
      break;

    case RcOpGetOpt:
      {
	  /* Retrieve the value of one option */

	  RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr;
	  Tcl_Obj*           optionObj;

	  optionObj = Tcl_NewStringObj(p->name,-1);
	  if (optionObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcGetOption");
	  }

	  RcInvokeTclMethod (rcPtr, "cget", optionObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  } else {
	      Tcl_DStringAppend (p->value, Tcl_GetString (resObj), -1);
	  }
      }
      break;

    case RcOpGetOptAll:
      {
	  /* Retrieve all options. */

	  RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr;

	  RcInvokeTclMethod (rcPtr, "cgetall", NULL, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  } else {
	      /* Extract list, validate that it is a list, and
	       * #elements. See NOTE (4) as well.
	       */

	      int       listc;
	      Tcl_Obj** listv;

	      res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv);
	      if (res != TCL_OK) {
		  RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));

	      } else if ((listc % 2) == 1) {
	          /* Odd number of elements is wrong.
		   * [x].
		   */

	          char* buf = ckalloc (200);
		  sprintf (buf,
			   "{Expected list with even number of elements, got %d %s instead}",
			   listc,
			   (listc == 1 ? "element" : "elements"));
		  
		  RcForwardSetDynError (paramPtr, buf);
	      } else {
		  int len;
		  char* str = Tcl_GetStringFromObj (resObj, &len);

		  if (len) {
		      Tcl_DStringAppend (p->value, " ", 1);
		      Tcl_DStringAppend (p->value, str, len);
		  }
	      }
	  }
      }
      break;

    default:
      /* Bad operation code */
      Tcl_Panic ("Bad operation code in RcForwardProc");
      break;
    }

    /* Remove the reference we held on the result of the invoke, if we had
     * such
     */
    if (resObj != NULL) {
	Tcl_DecrRefCount (resObj);
    }

    if (resultPtr) {
        /*
	 * Report the forwarding result synchronously to the waiting
	 * caller. This unblocks (*) as well. This is wrapped into a
	 * conditional because the caller may have exited in the mean
	 * time.
	 */

        Tcl_MutexLock(&rcForwardMutex);
	resultPtr->result = TCL_OK;
	Tcl_ConditionNotify(&resultPtr->done);
	Tcl_MutexUnlock(&rcForwardMutex);
    }

    return 1;
}


static void
RcSrcExitProc (clientData)
     ClientData clientData;
{
  RcForwardingEvent*  evPtr = (RcForwardingEvent*) clientData;
  RcForwardingResult* resultPtr;
  RcForwardParamBase* paramPtr;

  /* NOTE (2): Can this handler be called with the originator blocked ?
   * NOTE (2): ---
   */

  /* The originator for the event exited. It is not sure if this
   * can happen, as the originator should be blocked at (*) while
   * the event is in transit/pending.
   */

  /*
   * We make sure that the event cannot refer to the result anymore,
   * remove it from the list of pending results and free the
   * structure. Locking the access ensures that we cannot get in
   * conflict with "RcForwardProc", should it already execute the
   * event.
   */

  Tcl_MutexLock(&rcForwardMutex);

  resultPtr = evPtr->resultPtr;
  paramPtr  = (RcForwardParamBase*) evPtr->param;

  evPtr->resultPtr  = NULL;
  resultPtr->evPtr  = NULL;
  resultPtr->result = TCL_ERROR;

  RcForwardSetStaticError (paramPtr, msg_send_originlost);

  /* See below: TclSpliceOut(resultPtr, forwardList); */

  Tcl_MutexUnlock(&rcForwardMutex);

  /*
   * This unlocks (*). The structure will be spliced out and freed by
   * "RcForwardProc". Maybe.
   */

  Tcl_ConditionNotify(&resultPtr->done);
}


static void
RcDstExitProc (clientData)
     ClientData clientData;
{
  RcForwardingEvent*  evPtr     = (RcForwardingEvent*) clientData;
  RcForwardingResult* resultPtr = evPtr->resultPtr;
  RcForwardParamBase* paramPtr  = (RcForwardParamBase*) evPtr->param;

  /* NOTE (3): It is not clear if the event still exists when this handler is called..
   * NOTE (3): We might have to use 'resultPtr' as our clientData instead.
   * NOTE (3): ---
   */

  /* The receiver for the event exited, before processing the
   * event. We detach the result now, wake the originator up
   * and signal failure.
   */

  evPtr->resultPtr = NULL;
  resultPtr->evPtr  = NULL;
  resultPtr->result = TCL_ERROR;

  RcForwardSetStaticError (paramPtr, msg_send_dstlost);

  Tcl_ConditionNotify(&resultPtr->done);
}


static void
RcForwardSetObjError (p,obj)
     RcForwardParamBase* p;
     Tcl_Obj*            obj;
{
    int   len;
    char* msg;

    msg = Tcl_GetStringFromObj (obj, &len);

    p->code = TCL_ERROR;
    p->vol  = 1;
    p->msg  = strcpy(ckalloc (1+len), msg);
}
#endif

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIOSock.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
/* 
 * tclIOSock.c --
 *
 *	Common routines used by all socket based channel types.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOSock.c,v 1.8 2004/04/06 22:25:53 dgp Exp $
 */

#include "tclInt.h"

/*
 *---------------------------------------------------------------------------
 *
 * TclSockGetPort --
 *
 *	Maps from a string, which could be a service name, to a port.
 *	Used by socket creation code to get port numbers and resolve
 *	registered service names to port numbers.
 *
 * Results:
 *	A standard Tcl result.  On success, the port number is returned
 *	in portPtr. On failure, an error message is left in the interp's
 *	result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

|






|
|

|









|
|
|


|
|
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
/*
 * tclIOSock.c --
 *
 *	Common routines used by all socket based channel types.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOSock.c,v 1.8.2.1 2005/08/02 18:15:32 dgp Exp $
 */

#include "tclInt.h"

/*
 *---------------------------------------------------------------------------
 *
 * TclSockGetPort --
 *
 *	Maps from a string, which could be a service name, to a port. Used by
 *	socket creation code to get port numbers and resolve registered
 *	service names to port numbers.
 *
 * Results:
 *	A standard Tcl result. On success, the port number is returned in
 *	portPtr. On failure, an error message is left in the interp's result.

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
    Tcl_DString ds;
    CONST char *native;

    if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
	/*
	 * Don't bother translating 'proto' to native.
	 */
	 
	native = Tcl_UtfToExternalDString(NULL, string, -1, &ds);
	sp = getservbyname(native, proto);		/* INTL: Native. */
	Tcl_DStringFree(&ds);
	if (sp != NULL) {
	    *portPtr = ntohs((unsigned short) sp->s_port);
	    return TCL_OK;
	}
    }
    if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (*portPtr > 0xFFFF) {
        Tcl_AppendResult(interp, "couldn't open socket: port number too high",
                (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|












|
|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
    Tcl_DString ds;
    CONST char *native;

    if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
	/*
	 * Don't bother translating 'proto' to native.
	 */

	native = Tcl_UtfToExternalDString(NULL, string, -1, &ds);
	sp = getservbyname(native, proto);		/* INTL: Native. */
	Tcl_DStringFree(&ds);
	if (sp != NULL) {
	    *portPtr = ntohs((unsigned short) sp->s_port);
	    return TCL_OK;
	}
    }
    if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (*portPtr > 0xFFFF) {
	Tcl_AppendResult(interp, "couldn't open socket: port number too high",
		(char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
102
103
104
105
106
107
108








    getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
    if (current < size) {
	len = sizeof(int);
	setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
    }
    return TCL_OK;
}















>
>
>
>
>
>
>
>
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
    getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
    if (current < size) {
	len = sizeof(int);
	setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
    }
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIOUtil.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

55
56
57
58
59
60
61
62
63
64
65
66
67
/* 
 * tclIOUtil.c --
 *
 *	This file contains the implementation of Tcl's generic
 *	filesystem code, which supports a pluggable filesystem
 *	architecture allowing both platform specific filesystems and
 *	'virtual filesystems'.  All filesystem access should go through
 *	the functions defined in this file.  Most of this code was
 *	contributed by Vince Darley.
 *
 *	Parts of this file are based on code contributed by Karl
 *	Lehenbauer, Mark Diekhans and Peter da Silva.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.113 2004/11/17 00:31:47 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#include "tclWinInt.h"
#endif
#include "tclFileSystem.h"

/*
 * Prototypes for procedures defined later in this file.
 */

static FilesystemRecord *	FsGetFirstFilesystem _ANSI_ARGS_((void));
static void			FsThrExitProc _ANSI_ARGS_((ClientData cd));
static Tcl_Obj*			FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, 
				    CONST char *pattern));
static void			FsAddMountsToGlobResult _ANSI_ARGS_((
				    Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
				    CONST char *pattern, 
				    Tcl_GlobTypeData *types));
static void			FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, 
				    ClientData clientData));

#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif

/* 
 * These form part of the native filesystem support.  They are needed
 * here because we have a few native filesystem functions (which are
 * the same for win/unix) in this file.  There is no need to place
 * them in tclInt.h, because they are not (and should not be) used
 * anywhere else.
 */

extern CONST char *		tclpFileAttrStrings[];
extern CONST TclFileAttrProcs	tclpFileAttrProcs[];

/* 
 * The following functions are obsolete string based APIs, and should
 * be removed in a future release (Tcl 9 would be a good time).
 */

/* Obsolete */
int
Tcl_Stat(path, oldStyleBuf)
    CONST char *path;		/* Path of file to stat (in current CP). */
    struct stat *oldStyleBuf;	/* Filled with results of stat call. */
|


|
|
|
|
<
|

|
|



>

|
|

|




|









|



|

|






|
|
|
|
|
<

>



|
|
|







1
2
3
4
5
6
7

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
/*
 * tclIOUtil.c --
 *
 *	This file contains the implementation of Tcl's generic filesystem
 *	code, which supports a pluggable filesystem architecture allowing both
 *	platform specific filesystems and 'virtual filesystems'. All
 *	filesystem access should go through the functions defined in this

 *	file.  Most of this code was contributed by Vince Darley.
 *
 *	Parts of this file are based on code contributed by Karl Lehenbauer,
 *	Mark Diekhans and Peter da Silva.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.7 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"

/*
 * Prototypes for procedures defined later in this file.
 */

static FilesystemRecord *	FsGetFirstFilesystem _ANSI_ARGS_((void));
static void			FsThrExitProc _ANSI_ARGS_((ClientData cd));
static Tcl_Obj*			FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
				    CONST char *pattern));
static void			FsAddMountsToGlobResult _ANSI_ARGS_((
				    Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
				    CONST char *pattern,
				    Tcl_GlobTypeData *types));
static void			FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj,
				    ClientData clientData));

#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif

/*
 * These form part of the native filesystem support.  They are needed here
 * because we have a few native filesystem functions (which are the same for
 * win/unix) in this file.  There is no need to place them in tclInt.h,
 * because they are not (and should not be) used anywhere else.

 */

extern CONST char *		tclpFileAttrStrings[];
extern CONST TclFileAttrProcs	tclpFileAttrProcs[];

/*
 * The following functions are obsolete string based APIs, and should be
 * removed in a future release (Tcl 9 would be a good time).
 */

/* Obsolete */
int
Tcl_Stat(path, oldStyleBuf)
    CONST char *path;		/* Path of file to stat (in current CP). */
    struct stat *oldStyleBuf;	/* Filled with results of stat call. */
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

	/*
	 * Perform the result-buffer overflow check manually.
	 *
	 * Note that ino_t/ino64_t is unsigned...
	 */

        if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
#ifdef HAVE_ST_BLOCKS
		|| OUT_OF_RANGE(buf.st_blocks)
#endif
	    ) {
#ifdef EFBIG
	    errno = EFBIG;
#else







|







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

	/*
	 * Perform the result-buffer overflow check manually.
	 *
	 * Note that ino_t/ino64_t is unsigned...
	 */

	if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
#ifdef HAVE_ST_BLOCKS
		|| OUT_OF_RANGE(buf.st_blocks)
#endif
	    ) {
#ifdef EFBIG
	    errno = EFBIG;
#else
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145

146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

166
167
168
169
170

171
172
173
174
175
176
177
	}

#   undef OUT_OF_RANGE
#   undef OUT_OF_URANGE
#endif /* !TCL_WIDE_INT_IS_LONG */

	/*
	 * Copy across all supported fields, with possible type
	 * coercions on those fields that change between the normal
	 * and lf64 versions of the stat structure (on Solaris at
	 * least.)  This is slow when the structure sizes coincide,
	 * but that's what you get for using an obsolete interface.
	 */

	oldStyleBuf->st_mode    = buf.st_mode;
	oldStyleBuf->st_ino     = (ino_t) buf.st_ino;
	oldStyleBuf->st_dev     = buf.st_dev;
	oldStyleBuf->st_rdev    = buf.st_rdev;
	oldStyleBuf->st_nlink   = buf.st_nlink;
	oldStyleBuf->st_uid     = buf.st_uid;
	oldStyleBuf->st_gid     = buf.st_gid;
	oldStyleBuf->st_size    = (off_t) buf.st_size;
	oldStyleBuf->st_atime   = buf.st_atime;
	oldStyleBuf->st_mtime   = buf.st_mtime;
	oldStyleBuf->st_ctime   = buf.st_ctime;
#ifdef HAVE_ST_BLOCKS
	oldStyleBuf->st_blksize = buf.st_blksize;
	oldStyleBuf->st_blocks  = (blkcnt_t) buf.st_blocks;
#endif
    }
    return ret;
}

/* Obsolete */
int
Tcl_Access(path, mode)
    CONST char *path;		/* Path of file to access (in current CP). */
    int mode;                   /* Permission setting. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSAccess(pathPtr,mode);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(interp, path, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
					 * can be NULL. */
    CONST char *path;                   /* Name of file to open. */
    CONST char *modeString;             /* A list of POSIX open modes or
					 * a string such as "rw". */
    int permissions;                    /* If the open involves creating a
					 * file, with what modes to create
					 * it? */
{
    Tcl_Channel ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
    Tcl_DecrRefCount(pathPtr);
    return ret;


}

/* Obsolete */
int
Tcl_Chdir(dirName)
    CONST char *dirName;
{







|
|
|
|
|


|
|
|
|
|
|
|
|
|
|
|

|
|









|



>



>






|
|
|
|
|
|
|
<



>



<

>







105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170

171
172
173
174
175
176
177
178
179
	}

#   undef OUT_OF_RANGE
#   undef OUT_OF_URANGE
#endif /* !TCL_WIDE_INT_IS_LONG */

	/*
	 * Copy across all supported fields, with possible type coercions on
	 * those fields that change between the normal and lf64 versions of
	 * the stat structure (on Solaris at least.)  This is slow when the
	 * structure sizes coincide, but that's what you get for using an
	 * obsolete interface.
	 */

	oldStyleBuf->st_mode	= buf.st_mode;
	oldStyleBuf->st_ino	= (ino_t) buf.st_ino;
	oldStyleBuf->st_dev	= buf.st_dev;
	oldStyleBuf->st_rdev	= buf.st_rdev;
	oldStyleBuf->st_nlink	= buf.st_nlink;
	oldStyleBuf->st_uid	= buf.st_uid;
	oldStyleBuf->st_gid	= buf.st_gid;
	oldStyleBuf->st_size	= (off_t) buf.st_size;
	oldStyleBuf->st_atime	= buf.st_atime;
	oldStyleBuf->st_mtime	= buf.st_mtime;
	oldStyleBuf->st_ctime	= buf.st_ctime;
#ifdef HAVE_ST_BLOCKS
	oldStyleBuf->st_blksize	= buf.st_blksize;
	oldStyleBuf->st_blocks	= (blkcnt_t) buf.st_blocks;
#endif
    }
    return ret;
}

/* Obsolete */
int
Tcl_Access(path, mode)
    CONST char *path;		/* Path of file to access (in current CP). */
    int mode;			/* Permission setting. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSAccess(pathPtr,mode);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(interp, path, modeString, permissions)
    Tcl_Interp *interp;		/* Interpreter for error reporting; can be
				 * NULL. */
    CONST char *path;		/* Name of file to open. */
    CONST char *modeString;	/* A list of POSIX open modes or a string such
				 * as "rw". */
    int permissions;		/* If the open involves creating a file, with
				 * what modes to create it? */

{
    Tcl_Channel ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
    Tcl_DecrRefCount(pathPtr);


    return ret;
}

/* Obsolete */
int
Tcl_Chdir(dirName)
    CONST char *dirName;
{
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231

232
233
234
235

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

338
339
340
341
342
343
344
    Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSEvalFile(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}


/* 
 * The 3 hooks for Stat, Access and OpenFileChannel are obsolete.  The
 * complete, general hooked filesystem APIs should be used instead.
 * This define decides whether to include the obsolete hooks and
 * related code.  If these are removed, we'll also want to remove them
 * from stubs/tclInt.  The only known users of these APIs are prowrap
 * and mktclapp.  New code/extensions should not use them, since they
 * do not provide as full support as the full filesystem API.
 * 
 * As soon as prowrap and mktclapp are updated to use the full
 * filesystem support, I suggest all these hooks are removed.
 */

#define USE_OBSOLETE_FS_HOOKS


#ifdef USE_OBSOLETE_FS_HOOKS

/*
 * The following typedef declarations allow for hooking into the chain
 * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
 * 'Tcl_OpenFileChannel(...)'.  Basically for each hookable function
 * a linked list is defined.
 */

typedef struct StatProc {
    TclStatProc_ *proc;		 /* Function to process a 'stat()' call */
    struct StatProc *nextPtr;    /* The next 'stat()' function to call */
} StatProc;

typedef struct AccessProc {
    TclAccessProc_ *proc;	 /* Function to process a 'access()' call */
    struct AccessProc *nextPtr;  /* The next 'access()' function to call */
} AccessProc;

typedef struct OpenFileChannelProc {
    TclOpenFileChannelProc_ *proc;  /* Function to process a
				     * 'Tcl_OpenFileChannel()' call */
    struct OpenFileChannelProc *nextPtr;
				    /* The next 'Tcl_OpenFileChannel()'
				     * function to call */
} OpenFileChannelProc;

/*
 * For each type of (obsolete) hookable function, a static node is
 * declared to hold the function pointer for the "built-in" routine
 * (e.g. 'TclpStat(...)') and the respective list is initialized as a
 * pointer to that node.
 * 
 * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
 * these statically declared list entry cannot be inadvertently removed.
 *
 * This method avoids the need to call any sort of "initialization"
 * function.
 *
 * All three lists are protected by a global obsoleteFsHookMutex.
 */

static StatProc *statProcList = NULL;
static AccessProc *accessProcList = NULL;
static OpenFileChannelProc *openFileChannelProcList = NULL;

TCL_DECLARE_MUTEX(obsoleteFsHookMutex)

#endif /* USE_OBSOLETE_FS_HOOKS */

/* 
 * Declare the native filesystem support.  These functions should
 * be considered private to Tcl, and should really not be called
 * directly by any code other than this file (i.e. neither by
 * Tcl's core nor by extensions).  Similarly, the old string-based
 * Tclp... native filesystem functions should not be called.
 * 
 * The correct API to use now is the Tcl_FS... set of functions,
 * which ensure correct and complete virtual filesystem support.
 * 
 * We cannot make all of these static, since some of them
 * are implemented in the platform-specific directories.
 */

static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;

/* 
 * The only reason these functions are not static is that they
 * are either called by code in the native (win/unix) directories
 * or they are actually implemented in those directories.  They
 * should simply not be called by code outside Tcl's native
 * filesystem core.  i.e. they should be considered 'static' to
 * Tcl's filesystem code (if we ever built the native filesystem
 * support into a separate code library, this could actually be
 * enforced).
 */

Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
Tcl_FSStatProc TclpObjStat;
Tcl_FSAccessProc TclpObjAccess;	    
Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;  
Tcl_FSChdirProc TclpObjChdir;	    
Tcl_FSLstatProc TclpObjLstat;	    
Tcl_FSCopyFileProc TclpObjCopyFile; 
Tcl_FSDeleteFileProc TclpObjDeleteFile;	    
Tcl_FSRenameFileProc TclpObjRenameFile;	    
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;	    
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;	    
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;	    
Tcl_FSUnloadFileProc TclpUnloadFile;	    
Tcl_FSLinkProc TclpObjLink; 
Tcl_FSListVolumesProc TclpObjListVolumes;	    

/* 
 * Define the native filesystem dispatch table.  If necessary, it
 * is ok to make this non-static, but it should only be accessed
 * by the functions actually listed within it (or perhaps other
 * helper functions of them).  Anything which is not part of this
 * 'native filesystem implementation' should not be delving inside
 * here!
 */

Tcl_Filesystem tclNativeFilesystem = {
    "native",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_2,
    &TclNativePathInFilesystem,
    &TclNativeDupInternalRep,
    &NativeFreeInternalRep,







<
|

|
|
|
|
|
|
|
|
|

>

|
<

>

|
|
|
|













|
|

|
|



|
|
|
<
|
|
|

|
<












|
|
|
|
|
|
|
|
|
|
|
|

>






|
|
|
|
<
|
|
|
<

>



|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
<

>







214
215
216
217
218
219
220

221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266

267
268
269
270
271

272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307

308
309
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

336
337
338
339
340
341
342
343
344
    Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSEvalFile(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}


/*
 * The 3 hooks for Stat, Access and OpenFileChannel are obsolete.  The
 * complete, general hooked filesystem APIs should be used instead.  This
 * define decides whether to include the obsolete hooks and related code.  If
 * these are removed, we'll also want to remove them from stubs/tclInt.  The
 * only known users of these APIs are prowrap and mktclapp.  New
 * code/extensions should not use them, since they do not provide as full
 * support as the full filesystem API.
 *
 * As soon as prowrap and mktclapp are updated to use the full filesystem
 * support, I suggest all these hooks are removed.
 */

#define USE_OBSOLETE_FS_HOOKS


#ifdef USE_OBSOLETE_FS_HOOKS

/*
 * The following typedef declarations allow for hooking into the chain of
 * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
 * 'Tcl_OpenFileChannel(...)'.  Basically for each hookable function a linked
 * list is defined.
 */

typedef struct StatProc {
    TclStatProc_ *proc;		 /* Function to process a 'stat()' call */
    struct StatProc *nextPtr;    /* The next 'stat()' function to call */
} StatProc;

typedef struct AccessProc {
    TclAccessProc_ *proc;	 /* Function to process a 'access()' call */
    struct AccessProc *nextPtr;  /* The next 'access()' function to call */
} AccessProc;

typedef struct OpenFileChannelProc {
    TclOpenFileChannelProc_ *proc;	/* Function to process a
					 * 'Tcl_OpenFileChannel()' call */
    struct OpenFileChannelProc *nextPtr;
					/* The next 'Tcl_OpenFileChannel()'
					 * function to call */
} OpenFileChannelProc;

/*
 * For each type of (obsolete) hookable function, a static node is declared to
 * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)')
 * and the respective list is initialized as a pointer to that node.

 *
 * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these
 * statically declared list entry cannot be inadvertently removed.
 *
 * This method avoids the need to call any sort of "initialization" function.

 *
 * All three lists are protected by a global obsoleteFsHookMutex.
 */

static StatProc *statProcList = NULL;
static AccessProc *accessProcList = NULL;
static OpenFileChannelProc *openFileChannelProcList = NULL;

TCL_DECLARE_MUTEX(obsoleteFsHookMutex)

#endif /* USE_OBSOLETE_FS_HOOKS */

/*
 * Declare the native filesystem support.  These functions should be
 * considered private to Tcl, and should really not be called directly by any
 * code other than this file (i.e. neither by Tcl's core nor by extensions).
 * Similarly, the old string-based Tclp... native filesystem functions should
 * not be called.
 *
 * The correct API to use now is the Tcl_FS... set of functions, which ensure
 * correct and complete virtual filesystem support.
 *
 * We cannot make all of these static, since some of them are implemented in
 * the platform-specific directories.
 */

static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;

/*
 * The only reason these functions are not static is that they are either
 * called by code in the native (win/unix) directories or they are actually
 * implemented in those directories. They should simply not be called by code

 * outside Tcl's native filesystem core i.e. they should be considered
 * 'static' to Tcl's filesystem code (if we ever built the native filesystem
 * support into a separate code library, this could actually be enforced).

 */

Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
Tcl_FSStatProc TclpObjStat;
Tcl_FSAccessProc TclpObjAccess;
Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
Tcl_FSChdirProc TclpObjChdir;
Tcl_FSLstatProc TclpObjLstat;
Tcl_FSCopyFileProc TclpObjCopyFile;
Tcl_FSDeleteFileProc TclpObjDeleteFile;
Tcl_FSRenameFileProc TclpObjRenameFile;
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
Tcl_FSUnloadFileProc TclpUnloadFile;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;

/*
 * Define the native filesystem dispatch table.  If necessary, it is ok to
 * make this non-static, but it should only be accessed by the functions
 * actually listed within it (or perhaps other helper functions of them).
 * Anything which is not part of this 'native filesystem implementation'
 * should not be delving inside here!

 */

Tcl_Filesystem tclNativeFilesystem = {
    "native",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_2,
    &TclNativePathInFilesystem,
    &TclNativeDupInternalRep,
    &NativeFreeInternalRep,
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

386
387
388
389
390
391
392
393
394
395
396
397
398
399

400
401
402
403
404
405
406

407
408
409
410
411
412

413
414
415
416
417
418
419
420
421
422
423

424
425
426
427
428
429
430
431
432
433

434
435
436
437
438
439
440
441

442

443
444
445
446
447
448
449
450

451


452
453
454
455
456
457


458


459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545

546
547
548
549
550
551
552

553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

570


571
572
573
574
575
576
577
578
579
580
581
582
583
584


585
586
587
588
589
590
591
592
593

594


595
596
597
598
599
600
601
602
603
604
605
606
607

608


609
610
611
612
613
614
615
616
617
    &TclpObjLink,
#endif /* S_IFLNK */
    &TclpObjListVolumes,
    &NativeFileAttrStrings,
    &NativeFileAttrsGet,
    &NativeFileAttrsSet,
    &TclpObjCreateDirectory,
    &TclpObjRemoveDirectory, 
    &TclpObjDeleteFile,
    &TclpObjCopyFile,
    &TclpObjRenameFile,
    &TclpObjCopyDirectory, 
    &TclpObjLstat,
    &TclpDlopen,
    /* Needs a cast since we're using version_2 */
    (Tcl_FSGetCwdProc*)&TclpGetNativeCwd,
    &TclpObjChdir
};

/* 
 * Define the tail of the linked list.  Note that for unconventional
 * uses of Tcl without a native filesystem, we may in the future wish
 * to modify the current approach of hard-coding the native filesystem
 * in the lookup list 'filesystemList' below.
 * 
 * We initialize the record so that it thinks one file uses it.  This
 * means it will never be freed.
 */

static FilesystemRecord nativeFilesystemRecord = {
    NULL,
    &tclNativeFilesystem,
    1,
    NULL
};

/* 
 * This is incremented each time we modify the linked list of
 * filesystems.  Any time it changes, all cached filesystem
 * representations are suspect and must be freed.
 * For multithreading builds, change of the filesystem epoch
 * will trigger cache cleanup in all threads.
 */

static int theFilesystemEpoch = 0;

/*
 * Stores the linked list of filesystems. A 1:1 copy of this
 * list is also maintained in the TSD for each thread. This
 * is to avoid synchronization issues.
 */

static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)

/* 
 * Used to implement Tcl_FSGetCwd in a file-system independent way.
 */

static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)

Tcl_ThreadDataKey tclFsDataKey;

/* 
 * Declare fallback support function and 
 * information for Tcl_FSLoadFile 
 */

static Tcl_FSUnloadFileProc FSUnloadTempFile;

/*
 * One of these structures is used each time we successfully load a
 * file from a file system by way of making a temporary copy of the
 * file on the native filesystem.  We need to store both the actual
 * unloadProc/clientData combination which was used, and the original
 * and modified filenames, so that we can correctly undo the entire
 * operation when we want to unload the code.
 */

typedef struct FsDivertLoad {
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unloadProcPtr;	
    Tcl_Obj *divertedFile;
    Tcl_Filesystem *divertedFilesystem;
    ClientData divertedFileNativeRep;
} FsDivertLoad;


/* Now move on to the basic filesystem implementation */


static void
FsThrExitProc(cd)
    ClientData cd;
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd;
    FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;


    /* Trash the cwd copy */


    if (tsdPtr->cwdPathPtr != NULL) {
	Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
    }
    if (tsdPtr->cwdClientData != NULL) {
	NativeFreeInternalRep(tsdPtr->cwdClientData);
    }


    /* Trash the filesystems cache */


    fsRecPtr = tsdPtr->filesystemList;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr->nextPtr;
	if (--fsRecPtr->fileRefCount <= 0) {
	    ckfree((char *)fsRecPtr);
	}
	fsRecPtr = tmpFsRecPtr;
    }
}

int
TclFSCwdIsNative() 
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (tsdPtr->cwdClientData != NULL) {
	return 1;
    } else {
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSCwdPointerEquals --
 *
 *	Check whether the current working directory is equal to the
 *	path given.  
 *	
 * Results:
 *	1 (equal) or 0 (un-equal) as appropriate.
 *
 * Side effects:
 *	If the paths are equal, but are not the same object, this
 *	method will modify the given pathPtrPtr to refer to the same
 *	object.  In this case the object pointed to by pathPtrPtr will
 *	have its refCount decremented, and it will be adjusted to 
 *	point to the cwd (with a new refCount).
 *
 *----------------------------------------------------------------------
 */

int 
TclFSCwdPointerEquals(pathPtrPtr)
    Tcl_Obj** pathPtrPtr;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    Tcl_MutexLock(&cwdMutex);
    if (tsdPtr->cwdPathPtr == NULL
	    || tsdPtr->cwdPathEpoch != cwdPathEpoch) {
	if (tsdPtr->cwdPathPtr != NULL) {
	    Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
	}
	if (tsdPtr->cwdClientData != NULL) {
	    NativeFreeInternalRep(tsdPtr->cwdClientData);
	}
        if (cwdPathPtr == NULL) {
    	    tsdPtr->cwdPathPtr = NULL;
        } else {
    	    tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
    	    Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
        }
	if (cwdClientData == NULL) {
	    tsdPtr->cwdClientData = NULL;
	} else {
	    tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData);
	}
	tsdPtr->cwdPathEpoch = cwdPathEpoch;
    }
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
	tsdPtr->initialized = 1;
    }

    if (pathPtrPtr == NULL) {
        return (tsdPtr->cwdPathPtr == NULL);
    }
    
    if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
        return 1;
    } else {
	int len1, len2;
	CONST char *str1, *str2;

	str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
	str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
	if (len1 == len2 && !strcmp(str1,str2)) {
	    /* 
	     * They are equal, but different objects.  Update so they
	     * will be the same object in the future.
	     */

	    Tcl_DecrRefCount(*pathPtrPtr);
	    *pathPtrPtr = tsdPtr->cwdPathPtr;
	    Tcl_IncrRefCount(*pathPtrPtr);
	    return 1;
	} else {
	    return 0;
	}
    }
}

#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;


    /* Trash the current cache */


    fsRecPtr = tsdPtr->filesystemList;
    while (fsRecPtr != NULL) {
        tmpFsRecPtr = fsRecPtr->nextPtr;
	if (--fsRecPtr->fileRefCount <= 0) {
	    ckfree((char *)fsRecPtr);
	}
	fsRecPtr = tmpFsRecPtr;
    }
    tsdPtr->filesystemList = NULL;

    /*
     * Code below operates on shared data. We
     * are already called under mutex lock so
     * we can safely proceede.


     */

    /* Locate tail of the global filesystem list */
    fsRecPtr = filesystemList;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr;
	fsRecPtr = fsRecPtr->nextPtr;
    }


    /* Refill the cache honouring the order */


    fsRecPtr = tmpFsRecPtr;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
	*tmpFsRecPtr = *fsRecPtr;
	tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
	tmpFsRecPtr->prevPtr = NULL;
	if (tsdPtr->filesystemList) {
	    tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
	}
	tsdPtr->filesystemList = tmpFsRecPtr;
	fsRecPtr = fsRecPtr->prevPtr;
    }


    /* Make sure the above gets released on thread exit */


    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
	tsdPtr->initialized = 1;
    }
}
#endif /* TCL_THREADS */

static FilesystemRecord *
FsGetFirstFilesystem(void) {







|



|







|
|
|
|
|
|
|
|

>







|
|
|
<
|


>



|
|
|

>



|


>







|
|
<

>



|
|
|
|
|
|

>


|




|
>
|
>





|


>
|
>
>






>
>
|
>
>











|















|
|
|




|
|
|
|
|




|














|
|
|
|
|
|










|




|

|

|



>



|
|
|

>

















>
|
>
>


|








|
<
|
>
>


<






>
|
>
>


|










>
|
>
>

|







358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396

397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424

425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600

601
602
603
604
605

606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
    &TclpObjLink,
#endif /* S_IFLNK */
    &TclpObjListVolumes,
    &NativeFileAttrStrings,
    &NativeFileAttrsGet,
    &NativeFileAttrsSet,
    &TclpObjCreateDirectory,
    &TclpObjRemoveDirectory,
    &TclpObjDeleteFile,
    &TclpObjCopyFile,
    &TclpObjRenameFile,
    &TclpObjCopyDirectory,
    &TclpObjLstat,
    &TclpDlopen,
    /* Needs a cast since we're using version_2 */
    (Tcl_FSGetCwdProc*)&TclpGetNativeCwd,
    &TclpObjChdir
};

/*
 * Define the tail of the linked list.  Note that for unconventional uses of
 * Tcl without a native filesystem, we may in the future wish to modify the
 * current approach of hard-coding the native filesystem in the lookup list
 * 'filesystemList' below.
 *
 * We initialize the record so that it thinks one file uses it.  This means it
 * will never be freed.
 */

static FilesystemRecord nativeFilesystemRecord = {
    NULL,
    &tclNativeFilesystem,
    1,
    NULL
};

/*
 * This is incremented each time we modify the linked list of filesystems.
 * Any time it changes, all cached filesystem representations are suspect and

 * must be freed.  For multithreading builds, change of the filesystem epoch
 * will trigger cache cleanup in all threads.
 */

static int theFilesystemEpoch = 0;

/*
 * Stores the linked list of filesystems. A 1:1 copy of this list is also
 * maintained in the TSD for each thread. This is to avoid synchronization
 * issues.
 */

static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)

/*
 * Used to implement Tcl_FSGetCwd in a file-system independent way.
 */

static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)

Tcl_ThreadDataKey tclFsDataKey;

/*
 * Declare fallback support function and information for Tcl_FSLoadFile

 */

static Tcl_FSUnloadFileProc FSUnloadTempFile;

/*
 * One of these structures is used each time we successfully load a file from
 * a file system by way of making a temporary copy of the file on the native
 * filesystem.  We need to store both the actual unloadProc/clientData
 * combination which was used, and the original and modified filenames, so
 * that we can correctly undo the entire operation when we want to unload the
 * code.
 */

typedef struct FsDivertLoad {
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unloadProcPtr;
    Tcl_Obj *divertedFile;
    Tcl_Filesystem *divertedFilesystem;
    ClientData divertedFileNativeRep;
} FsDivertLoad;

/*
 * Now move on to the basic filesystem implementation
 */

static void
FsThrExitProc(cd)
    ClientData cd;
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd;
    FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;

    /*
     * Trash the cwd copy.
     */

    if (tsdPtr->cwdPathPtr != NULL) {
	Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
    }
    if (tsdPtr->cwdClientData != NULL) {
	NativeFreeInternalRep(tsdPtr->cwdClientData);
    }

    /*
     * Trash the filesystems cache.
     */

    fsRecPtr = tsdPtr->filesystemList;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr->nextPtr;
	if (--fsRecPtr->fileRefCount <= 0) {
	    ckfree((char *)fsRecPtr);
	}
	fsRecPtr = tmpFsRecPtr;
    }
}

int
TclFSCwdIsNative()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (tsdPtr->cwdClientData != NULL) {
	return 1;
    } else {
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSCwdPointerEquals --
 *
 *	Check whether the current working directory is equal to the path
 *	given.
 *
 * Results:
 *	1 (equal) or 0 (un-equal) as appropriate.
 *
 * Side effects:
 *	If the paths are equal, but are not the same object, this method will
 *	modify the given pathPtrPtr to refer to the same object.  In this case
 *	the object pointed to by pathPtrPtr will have its refCount
 *	decremented, and it will be adjusted to point to the cwd (with a new
 *	refCount).
 *
 *----------------------------------------------------------------------
 */

int
TclFSCwdPointerEquals(pathPtrPtr)
    Tcl_Obj** pathPtrPtr;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    Tcl_MutexLock(&cwdMutex);
    if (tsdPtr->cwdPathPtr == NULL
	    || tsdPtr->cwdPathEpoch != cwdPathEpoch) {
	if (tsdPtr->cwdPathPtr != NULL) {
	    Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
	}
	if (tsdPtr->cwdClientData != NULL) {
	    NativeFreeInternalRep(tsdPtr->cwdClientData);
	}
	if (cwdPathPtr == NULL) {
	    tsdPtr->cwdPathPtr = NULL;
	} else {
	    tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
	    Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
	}
	if (cwdClientData == NULL) {
	    tsdPtr->cwdClientData = NULL;
	} else {
	    tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData);
	}
	tsdPtr->cwdPathEpoch = cwdPathEpoch;
    }
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
	tsdPtr->initialized = 1;
    }

    if (pathPtrPtr == NULL) {
	return (tsdPtr->cwdPathPtr == NULL);
    }

    if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
	return 1;
    } else {
	int len1, len2;
	CONST char *str1, *str2;

	str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
	str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
	if (len1 == len2 && !strcmp(str1,str2)) {
	    /*
	     * They are equal, but different objects.  Update so they will be
	     * the same object in the future.
	     */

	    Tcl_DecrRefCount(*pathPtrPtr);
	    *pathPtrPtr = tsdPtr->cwdPathPtr;
	    Tcl_IncrRefCount(*pathPtrPtr);
	    return 1;
	} else {
	    return 0;
	}
    }
}

#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;

    /*
     * Trash the current cache.
     */

    fsRecPtr = tsdPtr->filesystemList;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr->nextPtr;
	if (--fsRecPtr->fileRefCount <= 0) {
	    ckfree((char *)fsRecPtr);
	}
	fsRecPtr = tmpFsRecPtr;
    }
    tsdPtr->filesystemList = NULL;

    /*
     * Code below operates on shared data. We are already called under mutex

     * lock so we can safely proceede.
     *
     * Locate tail of the global filesystem list.
     */


    fsRecPtr = filesystemList;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr;
	fsRecPtr = fsRecPtr->nextPtr;
    }

    /*
     * Refill the cache honouring the order.
     */

    fsRecPtr = tmpFsRecPtr;
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
	*tmpFsRecPtr = *fsRecPtr;
	tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
	tmpFsRecPtr->prevPtr = NULL;
	if (tsdPtr->filesystemList) {
	    tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
	}
	tsdPtr->filesystemList = tmpFsRecPtr;
	fsRecPtr = fsRecPtr->prevPtr;
    }

    /*
     * Make sure the above gets released on thread exit.
     */

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
	tsdPtr->initialized = 1;
    }
}
#endif /* TCL_THREADS */

static FilesystemRecord *
FsGetFirstFilesystem(void) {
630
631
632
633
634
635
636
637
638
639

640
641
642
643
644
645
646
647
648
649
650
651

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671

672
673
674
675

676


677
678
679
680

681
682
683
684
685
686
687
688
689
690

691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749

750


751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791

792
793
794
795
796
797
798
799
800
801
802
803

804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853

854
855
856
857

858
859
860
861
862
863
864
865
866
867
868
869
870
871
872

873
874
875
876
877
878
879
880
881
882
883
884
885

886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942

943
944
945
946
947
948
949
950

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013

1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031

1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096


1097


1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
    Tcl_MutexUnlock(&filesystemMutex);
    fsRecPtr = tsdPtr->filesystemList;
#endif
    return fsRecPtr;
}

/*
 * The epoch can be changed both by filesystems being added or
 * removed and by env(HOME) changing.
 */

int
TclFSEpochOk (filesystemEpoch)
    int filesystemEpoch; 
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    (void) FsGetFirstFilesystem();
    return (filesystemEpoch == tsdPtr->filesystemEpoch);
}

/* 
 * If non-NULL, clientData is owned by us and must be freed later.
 */

static void
FsUpdateCwd(cwdObj, clientData)
    Tcl_Obj *cwdObj;
    ClientData clientData;
{
    int len;
    char *str = NULL;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (cwdObj != NULL) {
	str = Tcl_GetStringFromObj(cwdObj, &len);
    }

    Tcl_MutexLock(&cwdMutex);
    if (cwdPathPtr != NULL) {
        Tcl_DecrRefCount(cwdPathPtr);
    }
    if (cwdClientData != NULL) {
	NativeFreeInternalRep(cwdClientData);
    }

    if (cwdObj == NULL) {
	cwdPathPtr = NULL;
	cwdClientData = NULL;
    } else {

	/* This must be stored as string obj! */


	cwdPathPtr = Tcl_NewStringObj(str, len); 
    	Tcl_IncrRefCount(cwdPathPtr);
	cwdClientData = TclNativeDupInternalRep(clientData);
    }

    cwdPathEpoch++;
    tsdPtr->cwdPathEpoch = cwdPathEpoch;
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->cwdPathPtr) {
        Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
    }
    if (tsdPtr->cwdClientData) {
	NativeFreeInternalRep(tsdPtr->cwdClientData);
    }

    if (cwdObj == NULL) {
	tsdPtr->cwdPathPtr = NULL;
	tsdPtr->cwdClientData = NULL;
    } else {
	tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); 
	tsdPtr->cwdClientData = clientData;
	Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeFilesystem --
 *
 *	Clean up the filesystem.  After this, calls to all Tcl_FS...
 *	functions will fail.
 *	
 *	We will later call TclResetFilesystem to restore the FS
 *	to a pristine state.
 *	
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees any memory allocated by the filesystem.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeFilesystem()
{
    FilesystemRecord *fsRecPtr;

    /* 
     * Assumption that only one thread is active now.  Otherwise
     * we would need to put various mutexes around this code.
     */
    
    if (cwdPathPtr != NULL) {
	Tcl_DecrRefCount(cwdPathPtr);
	cwdPathPtr = NULL;
        cwdPathEpoch = 0;
    }
    if (cwdClientData != NULL) {
	NativeFreeInternalRep(cwdClientData);
	cwdClientData = NULL;
    }

    /* 
     * Remove all filesystems, freeing any allocated memory
     * that is no longer needed
     */

    fsRecPtr = filesystemList;
    while (fsRecPtr != NULL) {
	FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
        if (fsRecPtr->fileRefCount <= 0) {

            /* The native filesystem is static, so we don't free it */


            if (fsRecPtr != &nativeFilesystemRecord) {
                ckfree((char *)fsRecPtr);
            }
        }
        fsRecPtr = tmpFsRecPtr;
    }
    filesystemList = NULL;

    /*
     * Now filesystemList is NULL.  This means that any attempt
     * to use the filesystem is likely to fail.
     */

    statProcList = NULL;
    accessProcList = NULL;
    openFileChannelProcList = NULL;
#ifdef __WIN32__
    TclWinEncodingsCleanup();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclResetFilesystem --
 *
 *	Restore the filesystem to a pristine state.
 *	
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclResetFilesystem()
{
    filesystemList = &nativeFilesystemRecord;

    /* 
     * Note, at this point, I believe nativeFilesystemRecord ->
     * fileRefCount should equal 1 and if not, we should try to track
     * down the cause.
     */
    
#ifdef __WIN32__
    /* 
     * Cleans up the win32 API filesystem proc lookup table. This must
     * happen very late in finalization so that deleting of copied
     * dlls can occur.
     */

    TclWinResetInterfaces();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSRegister --
 *
 *    Insert the filesystem function table at the head of the list of
 *    functions which are used during calls to all file-system
 *    operations.  The filesystem will be added even if it is 
 *    already in the list.  (You can use Tcl_FSData to
 *    check if it is in the list, provided the ClientData used was
 *    not NULL).
 *    
 *    Note that the filesystem handling is head-to-tail of the list.
 *    Each filesystem is asked in turn whether it can handle a
 *    particular request, _until_ one of them says 'yes'. At that
 *    point no further filesystems are asked.
 *    
 *    In particular this means if you want to add a diagnostic
 *    filesystem (which simply reports all fs activity), it must be 
 *    at the head of the list: i.e. it must be the last registered.
 *
 * Results:
 *    Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 *    could not be allocated.
 *
 * Side effects:
 *    Memory allocated and modifies the link list for filesystems.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSRegister(clientData, fsPtr)
    ClientData clientData;    /* Client specific data for this fs */
    Tcl_Filesystem  *fsPtr;   /* The filesystem record for the new fs. */
{
    FilesystemRecord *newFilesystemPtr;

    if (fsPtr == NULL) {
	return TCL_ERROR;
    }

    newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));

    newFilesystemPtr->clientData = clientData;
    newFilesystemPtr->fsPtr = fsPtr;

    /* 
     * We start with a refCount of 1.  If this drops to zero, then
     * anyone is welcome to ckfree us.
     */

    newFilesystemPtr->fileRefCount = 1;

    /* 
     * Is this lock and wait strictly speaking necessary?  Since any
     * iterators out there will have grabbed a copy of the head of
     * the list and be iterating away from that, if we add a new
     * element to the head of the list, it can't possibly have any
     * effect on any of their loops.  In fact it could be better not
     * to wait, since we are adjusting the filesystem epoch, any
     * cached representations calculated by existing iterators are
     * going to have to be thrown away anyway.
     * 
     * However, since registering and unregistering filesystems is
     * a very rare action, this is not a very important point.
     */

    Tcl_MutexLock(&filesystemMutex);

    newFilesystemPtr->nextPtr = filesystemList;
    newFilesystemPtr->prevPtr = NULL;
    if (filesystemList) {
        filesystemList->prevPtr = newFilesystemPtr;
    }
    filesystemList = newFilesystemPtr;

    /* 
     * Increment the filesystem epoch counter, since existing paths
     * might conceivably now belong to different filesystems.
     */

    theFilesystemEpoch++;
    Tcl_MutexUnlock(&filesystemMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSUnregister --
 *
 *    Remove the passed filesystem from the list of filesystem
 *    function tables.  It also ensures that the built-in
 *    (native) filesystem is not removable, although we may wish
 *    to change that decision in the future to allow a smaller
 *    Tcl core, in which the native filesystem is not used at
 *    all (we could, say, initialise Tcl completely over a network
 *    connection).
 *
 * Results:
 *    TCL_OK if the procedure pointer was successfully removed,
 *    TCL_ERROR otherwise.
 *
 * Side effects:
 *    Memory may be deallocated (or will be later, once no "path" 
 *    objects refer to this filesystem), but the list of registered
 *    filesystems is updated immediately.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSUnregister(fsPtr)
    Tcl_Filesystem  *fsPtr;   /* The filesystem record to remove. */
{
    int retVal = TCL_ERROR;
    FilesystemRecord *fsRecPtr;

    Tcl_MutexLock(&filesystemMutex);

    /*
     * Traverse the 'filesystemList' looking for the particular node
     * whose 'fsPtr' member matches 'fsPtr' and remove that one from
     * the list.  Ensure that the "default" node cannot be removed.
     */

    fsRecPtr = filesystemList;
    while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
	if (fsRecPtr->fsPtr == fsPtr) {
	    if (fsRecPtr->prevPtr) {
		fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
	    } else {
		filesystemList = fsRecPtr->nextPtr;
	    }
	    if (fsRecPtr->nextPtr) {
		fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
	    }

	    /* 
	     * Increment the filesystem epoch counter, since existing
	     * paths might conceivably now belong to different
	     * filesystems.  This should also ensure that paths which
	     * have cached the filesystem which is about to be deleted
	     * do not reference that filesystem (which would of course
	     * lead to memory exceptions).
	     */

	    theFilesystemEpoch++;
	    
	    fsRecPtr->fileRefCount--;
	    if (fsRecPtr->fileRefCount <= 0) {
	        ckfree((char *)fsRecPtr);
	    }

	    retVal = TCL_OK;
	} else {
	    fsRecPtr = fsRecPtr->nextPtr;
	}
    }

    Tcl_MutexUnlock(&filesystemMutex);
    return (retVal);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a directory
 *	for all files which match a given pattern.  The appropriate
 *	function for the filesystem to which pathPtr belongs will be
 *	called.  If pathPtr does not belong to any filesystem and if it
 *	is NULL or the empty string, then we assume the pattern is to be
 *	matched in the current working directory.  To avoid each
 *	filesystem's Tcl_FSMatchInDirectoryProc having to deal with this
 *	issue, we create a pathPtr on the fly (equal to the cwd), and
 *	then remove it from the results returned.  This makes filesystems
 *	easy to write, since they can assume the pathPtr passed to them
 *	is an ordinary path.  In fact this means we could remove such
 *	special case handling from Tcl's native filesystems.
 *	
 *	If 'pattern' is NULL, then pathPtr is assumed to be a fully
 *	specified path of a single file/directory which must be
 *	checked for existence and correct type.
 *
 * Results: 
 *	
 *	The return value is a standard Tcl result indicating whether an
 *	error occurred in globbing.  Error messages are placed in
 *	interp, but good results are placed in the resultPtr given.
 *	
 *	Recursive searches, e.g.
 *	
 *	   glob -dir $dir -join * pkgIndex.tcl
 *	   
 *	which must recurse through each directory matching '*' are
 *	handled internally by Tcl, by passing specific flags in a 
 *	modified 'types' parameter.  This means the actual filesystem
 *	only ever sees patterns which match in a single directory.
 *
 * Side effects:
 *	The interpreter may have an error message inserted into it.
 *
 *---------------------------------------------------------------------- 
 */

int
Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive error messages. */

    Tcl_Obj *resultPtr;		/* List object to receive results. */
    Tcl_Obj *pathPtr;	        /* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    Tcl_Filesystem *fsPtr;
    Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
    int resLength, i, ret = -1;

    if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
	/* 
	 * We don't currently allow querying of mounts by external code
	 * (a valuable future step), so since we're the only function
	 * that actually knows about mounts, this means we're being
	 * called recursively by ourself.  Return no matches.
	 */

	return TCL_OK;
    }
    
    if (pathPtr != NULL) {
        fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    } else {
	fsPtr = NULL;
    }
    
    /*
     * Check if we've successfully mapped the path to a filesystem
     * within which to search.
     */

    if (fsPtr != NULL) {
	if (fsPtr->matchInDirectoryProc == NULL) {
	    Tcl_SetErrno(ENOENT);
	    return -1;
	}
	ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr,
		pattern, types);
	if (ret == TCL_OK && pattern != NULL) {
	    FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);
	}
	return ret;
    }

    /* 
     * If the path isn't empty, we have no idea how to match files in
     * a directory which belongs to no known filesystem
     */

    if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
	Tcl_SetErrno(ENOENT);
	return -1;
    }

    /* 
     * We have an empty or NULL path.  This is defined to mean we
     * must search for files within the current 'cwd'.  We
     * therefore use that, but then since the proc we call will
     * return results which include the cwd we must then trim it
     * off the front of each path in the result.  We choose to deal
     * with this here (in the generic code), since if we don't,
     * every single filesystem's implementation of
     * Tcl_FSMatchInDirectory will have to deal with it for us.
     */

    cwd = Tcl_FSGetCwd(NULL);
    if (cwd == NULL) {
	if (interp != NULL) {
	    Tcl_SetResult(interp, "glob couldn't determine "
		    "the current working directory", TCL_STATIC);
	}
	return TCL_ERROR;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(cwd);
    if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {
	TclNewObj(tmpResultPtr);
	Tcl_IncrRefCount(tmpResultPtr);
	ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd,
		pattern, types);
	if (ret == TCL_OK) {
	    FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);


	    /* Note that we know resultPtr and tmpResultPtr are distinct */


	    ret = Tcl_ListObjGetElements(interp, tmpResultPtr,
		    &resLength, &elemsPtr);
	    for (i = 0; ret == TCL_OK && i < resLength; i++) {
		ret = Tcl_ListObjAppendElement(interp, resultPtr,
			TclFSMakePathRelative(interp, elemsPtr[i], cwd));
	    }
	}
	TclDecrRefCount(tmpResultPtr);
    }
    Tcl_DecrRefCount(cwd);
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * FsAddMountsToGlobResult --
 *
 *	This routine is used by the globbing code to take the results
 *	of a directory listing and add any mounted paths to that
 *	listing.  This is required so that simple things like 
 *	'glob *' merge mounts and listings correctly.
 *	
 * Results: 
 *	None.
 *
 * Side effects:
 *	Modifies the resultPtr.
 *
 *---------------------------------------------------------------------- 
 */

static void
FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types)
    Tcl_Obj *resultPtr;		/* The current list of matching paths; must
				 * not be shared! */
    Tcl_Obj *pathPtr;		/* The directory in question */







|
|

>

|
|






|


>















|




>




>
|
>
>
|



>





|




>




|












|
|
|
|














|
|
|

|



|






|
|
|





|
>
|
>
>
|
|
|
|
|




|
|
















|













>
|
|
|
<

|

|
|
|
<

>









|
|
|
<
|
|
|
|
|
|
|
|
|
|
|


|
|


|






|
|











>
|
|
|

>


|
|
|
|
<
|
|
|

|
|
|

>





|



|
|
|

>











|
|
<
|
|
|
|


|
|


|
|
|






|







|
|
|













>
|
|
|
|
|
<
|

>

|


|









|







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

<
|
<
|
|
|
|




|




|
>

|










|
|
|
|
|

>


|

|



|

|
|















|
|
|







|
|
|
<
|
|
|
|
|



















>
>
|
>
>


|















|
|
|
|
|
|





|







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830

831
832
833
834
835
836

837
838
839
840
841
842
843
844
845
846
847
848
849
850

851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899

900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935

936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984

985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033

1034

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108

1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
    Tcl_MutexUnlock(&filesystemMutex);
    fsRecPtr = tsdPtr->filesystemList;
#endif
    return fsRecPtr;
}

/*
 * The epoch can be changed both by filesystems being added or removed and by
 * env(HOME) changing.
 */

int
TclFSEpochOk(filesystemEpoch)
    int filesystemEpoch;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    (void) FsGetFirstFilesystem();
    return (filesystemEpoch == tsdPtr->filesystemEpoch);
}

/*
 * If non-NULL, clientData is owned by us and must be freed later.
 */

static void
FsUpdateCwd(cwdObj, clientData)
    Tcl_Obj *cwdObj;
    ClientData clientData;
{
    int len;
    char *str = NULL;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (cwdObj != NULL) {
	str = Tcl_GetStringFromObj(cwdObj, &len);
    }

    Tcl_MutexLock(&cwdMutex);
    if (cwdPathPtr != NULL) {
	Tcl_DecrRefCount(cwdPathPtr);
    }
    if (cwdClientData != NULL) {
	NativeFreeInternalRep(cwdClientData);
    }

    if (cwdObj == NULL) {
	cwdPathPtr = NULL;
	cwdClientData = NULL;
    } else {
	/*
	 * This must be stored as string obj!
	 */

	cwdPathPtr = Tcl_NewStringObj(str, len);
    	Tcl_IncrRefCount(cwdPathPtr);
	cwdClientData = TclNativeDupInternalRep(clientData);
    }

    cwdPathEpoch++;
    tsdPtr->cwdPathEpoch = cwdPathEpoch;
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->cwdPathPtr) {
	Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
    }
    if (tsdPtr->cwdClientData) {
	NativeFreeInternalRep(tsdPtr->cwdClientData);
    }

    if (cwdObj == NULL) {
	tsdPtr->cwdPathPtr = NULL;
	tsdPtr->cwdClientData = NULL;
    } else {
	tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
	tsdPtr->cwdClientData = clientData;
	Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeFilesystem --
 *
 *	Clean up the filesystem.  After this, calls to all Tcl_FS...
 *	functions will fail.
 *
 *	We will later call TclResetFilesystem to restore the FS to a pristine
 *	state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees any memory allocated by the filesystem.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeFilesystem()
{
    FilesystemRecord *fsRecPtr;

    /*
     * Assumption that only one thread is active now.  Otherwise we would need
     * to put various mutexes around this code.
     */

    if (cwdPathPtr != NULL) {
	Tcl_DecrRefCount(cwdPathPtr);
	cwdPathPtr = NULL;
	cwdPathEpoch = 0;
    }
    if (cwdClientData != NULL) {
	NativeFreeInternalRep(cwdClientData);
	cwdClientData = NULL;
    }

    /*
     * Remove all filesystems, freeing any allocated memory that is no longer
     * needed
     */

    fsRecPtr = filesystemList;
    while (fsRecPtr != NULL) {
	FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
	if (fsRecPtr->fileRefCount <= 0) {
	    /*
	     * The native filesystem is static, so we don't free it.
	     */

	    if (fsRecPtr != &nativeFilesystemRecord) {
		ckfree((char *)fsRecPtr);
	    }
	}
	fsRecPtr = tmpFsRecPtr;
    }
    filesystemList = NULL;

    /*
     * Now filesystemList is NULL. This means that any attempt to use the
     * filesystem is likely to fail.
     */

    statProcList = NULL;
    accessProcList = NULL;
    openFileChannelProcList = NULL;
#ifdef __WIN32__
    TclWinEncodingsCleanup();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclResetFilesystem --
 *
 *	Restore the filesystem to a pristine state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclResetFilesystem()
{
    filesystemList = &nativeFilesystemRecord;

    /*
     * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount
     * should equal 1 and if not, we should try to track down the cause.

     */

#ifdef __WIN32__
    /*
     * Cleans up the win32 API filesystem proc lookup table. This must happen
     * very late in finalization so that deleting of copied dlls can occur.

     */

    TclWinResetInterfaces();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSRegister --
 *
 *	Insert the filesystem function table at the head of the list of
 *	functions which are used during calls to all file-system operations.
 *	The filesystem will be added even if it is already in the list. (You

 *	can use Tcl_FSData to check if it is in the list, provided the
 *	ClientData used was not NULL).
 *
 *	Note that the filesystem handling is head-to-tail of the list.  Each
 *	filesystem is asked in turn whether it can handle a particular
 *	request, until one of them says 'yes'. At that point no further
 *	filesystems are asked.
 *
 *	In particular this means if you want to add a diagnostic filesystem
 *	(which simply reports all fs activity), it must be at the head of the
 *	list: i.e. it must be the last registered.
 *
 * Results:
 *	Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *	not be allocated.
 *
 * Side effects:
 *	Memory allocated and modifies the link list for filesystems.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSRegister(clientData, fsPtr)
    ClientData clientData;	/* Client specific data for this fs */
    Tcl_Filesystem  *fsPtr;	/* The filesystem record for the new fs. */
{
    FilesystemRecord *newFilesystemPtr;

    if (fsPtr == NULL) {
	return TCL_ERROR;
    }

    newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));

    newFilesystemPtr->clientData = clientData;
    newFilesystemPtr->fsPtr = fsPtr;

    /*
     * We start with a refCount of 1.  If this drops to zero, then anyone is
     * welcome to ckfree us.
     */

    newFilesystemPtr->fileRefCount = 1;

    /*
     * Is this lock and wait strictly speaking necessary?  Since any iterators
     * out there will have grabbed a copy of the head of the list and be
     * iterating away from that, if we add a new element to the head of the

     * list, it can't possibly have any effect on any of their loops.  In fact
     * it could be better not to wait, since we are adjusting the filesystem
     * epoch, any cached representations calculated by existing iterators are
     * going to have to be thrown away anyway.
     *
     * However, since registering and unregistering filesystems is a very rare
     * action, this is not a very important point.
     */

    Tcl_MutexLock(&filesystemMutex);

    newFilesystemPtr->nextPtr = filesystemList;
    newFilesystemPtr->prevPtr = NULL;
    if (filesystemList) {
	filesystemList->prevPtr = newFilesystemPtr;
    }
    filesystemList = newFilesystemPtr;

    /*
     * Increment the filesystem epoch counter, since existing paths might
     * conceivably now belong to different filesystems.
     */

    theFilesystemEpoch++;
    Tcl_MutexUnlock(&filesystemMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSUnregister --
 *
 *	Remove the passed filesystem from the list of filesystem function
 *	tables.  It also ensures that the built-in (native) filesystem is not

 *	removable, although we may wish to change that decision in the future
 *	to allow a smaller Tcl core, in which the native filesystem is not
 *	used at all (we could, say, initialise Tcl completely over a network
 *	connection).
 *
 * Results:
 *	TCL_OK if the procedure pointer was successfully removed, TCL_ERROR
 *	otherwise.
 *
 * Side effects:
 *	Memory may be deallocated (or will be later, once no "path" objects
 *	refer to this filesystem), but the list of registered filesystems is
 *	updated immediately.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSUnregister(fsPtr)
    Tcl_Filesystem  *fsPtr;	/* The filesystem record to remove. */
{
    int retVal = TCL_ERROR;
    FilesystemRecord *fsRecPtr;

    Tcl_MutexLock(&filesystemMutex);

    /*
     * Traverse the 'filesystemList' looking for the particular node whose
     * 'fsPtr' member matches 'fsPtr' and remove that one from the list.
     * Ensure that the "default" node cannot be removed.
     */

    fsRecPtr = filesystemList;
    while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
	if (fsRecPtr->fsPtr == fsPtr) {
	    if (fsRecPtr->prevPtr) {
		fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
	    } else {
		filesystemList = fsRecPtr->nextPtr;
	    }
	    if (fsRecPtr->nextPtr) {
		fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
	    }

	    /*
	     * Increment the filesystem epoch counter, since existing paths
	     * might conceivably now belong to different filesystems.  This
	     * should also ensure that paths which have cached the filesystem
	     * which is about to be deleted do not reference that filesystem

	     * (which would of course lead to memory exceptions).
	     */

	    theFilesystemEpoch++;

	    fsRecPtr->fileRefCount--;
	    if (fsRecPtr->fileRefCount <= 0) {
		ckfree((char *)fsRecPtr);
	    }

	    retVal = TCL_OK;
	} else {
	    fsRecPtr = fsRecPtr->nextPtr;
	}
    }

    Tcl_MutexUnlock(&filesystemMutex);
    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a directory for
 *	all files which match a given pattern.  The appropriate function for
 *	the filesystem to which pathPtr belongs will be called.  If pathPtr
 *	does not belong to any filesystem and if it is NULL or the empty
 *	string, then we assume the pattern is to be matched in the current
 *	working directory.  To avoid have the Tcl_FSMatchInDirectoryProc for
 *	each filesystem from having to deal with this issue, we create a
 *	pathPtr on the fly (equal to the cwd), and then remove it from the
 *	results returned.  This makes filesystems easy to write, since they
 *	can assume the pathPtr passed to them is an ordinary path.  In fact
 *	this means we could remove such special case handling from Tcl's
 *	native filesystems.
 *
 *	If 'pattern' is NULL, then pathPtr is assumed to be a fully specified
 *	path of a single file/directory which must be checked for existence
 *	and correct type.
 *
 * Results:
 *
 *	The return value is a standard Tcl result indicating whether an error
 *	occurred in globbing.  Error messages are placed in interp, but good
 *	results are placed in the resultPtr given.
 *
 *	Recursive searches, e.g.

 *		glob -dir $dir -join * pkgIndex.tcl

 *	which must recurse through each directory matching '*' are handled
 *	internally by Tcl, by passing specific flags in a modified 'types'
 *	parameter.  This means the actual filesystem only ever sees patterns
 *	which match in a single directory.
 *
 * Side effects:
 *	The interpreter may have an error message inserted into it.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive error 
                       		 * messages, but may be NULL. */
    Tcl_Obj *resultPtr;		/* List object to receive results. */
    Tcl_Obj *pathPtr;		/* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    Tcl_Filesystem *fsPtr;
    Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
    int resLength, i, ret = -1;

    if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
	/*
	 * We don't currently allow querying of mounts by external code (a
	 * valuable future step), so since we're the only function that
	 * actually knows about mounts, this means we're being called
	 * recursively by ourself.  Return no matches.
	 */

	return TCL_OK;
    }

    if (pathPtr != NULL) {
	fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    } else {
	fsPtr = NULL;
    }

    /*
     * Check if we've successfully mapped the path to a filesystem within
     * which to search.
     */

    if (fsPtr != NULL) {
	if (fsPtr->matchInDirectoryProc == NULL) {
	    Tcl_SetErrno(ENOENT);
	    return -1;
	}
	ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr,
		pattern, types);
	if (ret == TCL_OK && pattern != NULL) {
	    FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);
	}
	return ret;
    }

    /*
     * If the path isn't empty, we have no idea how to match files in a
     * directory which belongs to no known filesystem
     */

    if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
	Tcl_SetErrno(ENOENT);
	return -1;
    }

    /*
     * We have an empty or NULL path. This is defined to mean we must search
     * for files within the current 'cwd'. We therefore use that, but then

     * since the proc we call will return results which include the cwd we
     * must then trim it off the front of each path in the result. We choose
     * to deal with this here (in the generic code), since if we don't, every
     * single filesystem's implementation of Tcl_FSMatchInDirectory will have
     * to deal with it for us.
     */

    cwd = Tcl_FSGetCwd(NULL);
    if (cwd == NULL) {
	if (interp != NULL) {
	    Tcl_SetResult(interp, "glob couldn't determine "
		    "the current working directory", TCL_STATIC);
	}
	return TCL_ERROR;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(cwd);
    if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {
	TclNewObj(tmpResultPtr);
	Tcl_IncrRefCount(tmpResultPtr);
	ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd,
		pattern, types);
	if (ret == TCL_OK) {
	    FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);

	    /*
	     * Note that we know resultPtr and tmpResultPtr are distinct.
	     */

	    ret = Tcl_ListObjGetElements(interp, tmpResultPtr,
		    &resLength, &elemsPtr);
	    for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
		ret = Tcl_ListObjAppendElement(interp, resultPtr,
			TclFSMakePathRelative(interp, elemsPtr[i], cwd));
	    }
	}
	TclDecrRefCount(tmpResultPtr);
    }
    Tcl_DecrRefCount(cwd);
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * FsAddMountsToGlobResult --
 *
 *	This routine is used by the globbing code to take the results of a
 *	directory listing and add any mounted paths to that listing.  This is
 *	required so that simple things like 'glob *' merge mounts and listings
 *	correctly.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the resultPtr.
 *
 *----------------------------------------------------------------------
 */

static void
FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types)
    Tcl_Obj *resultPtr;		/* The current list of matching paths; must
				 * not be shared! */
    Tcl_Obj *pathPtr;		/* The directory in question */
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167

1168


1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186

1187
1188
1189
1190

1191


1192
1193
1194
1195

1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266

1267

1268
1269
1270
1271

1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349

1350
1351

1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388

1389


1390
1391
1392
1393
1394

1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413












1414



















1415
1416
1417

1418
1419
1420
1421
1422
1423
1424
1425
1426


1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443



1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455

1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477


1478
1479
1480
1481
1482
1483
1484






1485
1486
1487


1488


1489
1490

1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534

1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545

1546
1547
1548
1549
1550
1551
1552

1553
1554
1555
1556
1557
1558
1559
1560

1561
1562


1563

1564
1565
1566
1567

1568
1569
1570
1571
1572

1573

1574
1575
1576
1577
1578
1579
1580
1581
1582
1583

1584


1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652

1653
1654
1655
1656
1657

1658

1659
1660
1661
1662
1663

1664
1665
1666
1667
1668
1669
1670

1671
1672
1673
1674
1675
1676
1677

1678
1679
1680
1681
1682
1683
1684
1685
1686
1687

1688
1689
1690
1691
1692

1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709

1710

1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746

    if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
	goto endOfMounts;
    }
    if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
	goto endOfMounts;
    }
    for (i = 0; i < mLength; i++) {
	Tcl_Obj *mElt;
	int j;
	int found = 0;
	
	Tcl_ListObjIndex(NULL, mounts, i, &mElt);

	for (j = 0; j < gLength; j++) {
	    Tcl_Obj *gElt;

	    Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);
	    if (Tcl_FSEqualPaths(mElt, gElt)) {
		found = 1;
		if (!dir) {

		    /* We don't want to list this */


		    Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
		    gLength--;
		}
		/* Break out of for loop */
		break;
	    }
	}
	if (!found && dir) {
            int len, mlen;
            CONST char *path;
            CONST char *mount;

            /* 
             * We know mElt is absolute normalized and lies inside pathPtr, 
             * so now we must add to the result the right
             * representation of mElt, i.e. the representation which
             * is relative to pathPtr.
             */

            mount = Tcl_GetStringFromObj(mElt, &mlen);
            path = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, pathPtr), 
                                        &len);
            if (path[len-1] == '/') {

                /* Deal with the root of the volume */


                len--;
            }
            mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len);
            Tcl_ListObjAppendElement(NULL, resultPtr, mElt);

	    /* 
	     * No need to increment gLength, since we
	     * don't want to compare mounts against
	     * mounts.
	     */
	}
    }

  endOfMounts:
    Tcl_DecrRefCount(mounts);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMountsChanged --
 *
 *    Notify the filesystem that the available mounted filesystems
 *    (or within any one filesystem type, the number or location of
 *    mount points) have changed.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    The global filesystem variable 'theFilesystemEpoch' is
 *    incremented.  The effect of this is to make all cached
 *    path representations invalid.  Clearly it should only therefore
 *    be called when it is really required!  There are a few 
 *    circumstances when it should be called:
 *    
 *    (1) when a new filesystem is registered or unregistered.  
 *    Strictly speaking this is only necessary if the new filesystem
 *    accepts file paths as is (normally the filesystem itself is
 *    really a shell which hasn't yet had any mount points established
 *    and so its 'pathInFilesystem' proc will always fail).  However,
 *    for safety, Tcl always calls this for you in these circumstances.
 * 
 *    (2) when additional mount points are established inside any
 *    existing filesystem (except the native fs)
 *    
 *    (3) when any filesystem (except the native fs) changes the list
 *    of available volumes.
 *    
 *    (4) when the mapping from a string representation of a file to
 *    a full, normalized path changes.  For example, if 'env(HOME)' 
 *    is modified, then any path containing '~' will map to a different
 *    filesystem location.  Therefore all such paths need to have
 *    their internal representation invalidated.
 *    
 *    Tcl has no control over (2) and (3), so any registered filesystem
 *    must make sure it calls this function when those situations
 *    occur.
 *    
 *    (Note: the reason for the exception in 2,3 for the native
 *    filesystem is that the native filesystem by default claims all
 *    unknown files even if it really doesn't understand them or if
 *    they don't exist).
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FSMountsChanged(fsPtr)
    Tcl_Filesystem *fsPtr;
{
    /* 
     * We currently don't do anything with this parameter.  We
     * could in the future only invalidate files for this filesystem
     * or otherwise take more advanced action.
     */

    (void)fsPtr;

    /* 
     * Increment the filesystem epoch counter, since existing paths
     * might now belong to different filesystems.
     */

    Tcl_MutexLock(&filesystemMutex);
    theFilesystemEpoch++;
    Tcl_MutexUnlock(&filesystemMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSData --
 *
 *    Retrieve the clientData field for the filesystem given,
 *    or NULL if that filesystem is not registered.
 *
 * Results:
 *    A clientData value, or NULL.  Note that if the filesystem
 *    was registered with a NULL clientData field, this function
 *    will return that NULL value.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_FSData(fsPtr)
    Tcl_Filesystem  *fsPtr;   /* The filesystem record to query. */
{
    ClientData retVal = NULL;
    FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();

    /*
     * Traverse the list of filesystems look for a particular one.
     * If found, return that filesystem's clientData (originally
     * provided when calling Tcl_FSRegister).
     */

    while ((retVal == NULL) && (fsRecPtr != NULL)) {
	if (fsRecPtr->fsPtr == fsPtr) {
	    retVal = fsRecPtr->clientData;
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSNormalizeToUniquePath --
 *
 * Description:
 *	Takes a path specification containing no ../, ./ sequences,
 *	and converts it into a unique path for the given platform.
 *      On Unix, this means the path must be free of
 *	symbolic links/aliases, and on Windows it means we want the
 *	long form, with that long form's case-dependence (which gives
 *	us a unique, case-dependent path).
 *
 * Results:
 *	The pathPtr is modified in place.  The return value is
 *	the last byte offset which was recognised in the path
 *	string.
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special notes:
 *	If the filesystem-specific normalizePathProcs can re-introduce
 *	../, ./ sequences into the path, then this function will
 *	not return the correct result.  This may be possible with
 *	symbolic links on unix.
 *
 *      Important assumption: if startAt is non-zero, it must point
 *      to a directory separator that we know exists and is already
 *      normalized (so it is important not to point to the char just
 *      after the separator).

 *---------------------------------------------------------------------------
 */

int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
    Tcl_Interp *interp;         /* Used for error messages. */
    Tcl_Obj *pathPtr;           /* The path to normalize in place */
    int startAt;                /* Start at this char-offset */
    ClientData *clientDataPtr;  /* If we generated a complete
                                 * normalized path for a given
                                 * filesystem, we can optionally return
                                 * an fs-specific clientdata here. */ 
{
    FilesystemRecord *fsRecPtr, *firstFsRecPtr;
    /* Ignore this variable */
    (void)clientDataPtr;
    
    /*
     * Call each of the "normalise path" functions in succession. This is
     * a special case, in which if we have a native filesystem handler,
     * we call it first.  This is because the root of Tcl's filesystem
     * is always a native filesystem (i.e. '/' on unix is native).
     */

    firstFsRecPtr = FsGetFirstFilesystem();

    fsRecPtr = firstFsRecPtr; 
    while (fsRecPtr != NULL) {
        if (fsRecPtr == &nativeFilesystemRecord) {
	    Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
	    if (proc != NULL) {
		startAt = (*proc)(interp, pathPtr, startAt);
	    }
	    break;
        }
	fsRecPtr = fsRecPtr->nextPtr;
    }
    
    fsRecPtr = firstFsRecPtr;
    while (fsRecPtr != NULL) {

	/* Skip the native system next time through */


	if (fsRecPtr != &nativeFilesystemRecord) {
	    Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
	    if (proc != NULL) {
		startAt = (*proc)(interp, pathPtr, startAt);
	    }

	    /* 
	     * We could add an efficiency check like this:
	     * 
	     *   if (retVal == length-of(pathPtr)) {break;}
	     * 
	     * but there's not much benefit.
	     */
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return startAt;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetOpenMode --
 *












 * Description:



















 *	Computes a POSIX mode mask for opening a file, from a given string,
 *	and also sets a flag to indicate whether the caller should seek to
 *	EOF after opening the file.

 *
 * Results:
 *	On success, returns mode to pass to "open". If an error occurs, the
 *	return value is -1 and if interp is not NULL, sets interp's result
 *	object to an error message.
 *
 * Side effects:
 *	Sets the integer referenced by seekFlagPtr to 1 to tell the caller
 *	to seek to EOF after opening the file.


 *
 * Special note:
 *	This code is based on a prototype implementation contributed
 *	by Mark Diekhans.
 *
 *---------------------------------------------------------------------------
 */

int
TclGetOpenMode(interp, string, seekFlagPtr)
    Tcl_Interp *interp;			/* Interpreter to use for error
					 * reporting - may be NULL. */
    CONST char *string;			/* Mode string, e.g. "r+" or
					 * "RDONLY CREAT". */
    int *seekFlagPtr;			/* Set this to 1 if the caller
                                         * should seek to EOF during the
                                         * opening of the file. */



{
    int mode, modeArgc, c, i, gotRW;
    CONST char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)

    /*
     * Check for the simpler fopen-like access modes (e.g. "r").  They
     * are distinguished from the POSIX access modes by the presence
     * of a lower-case first letter.
     */

    *seekFlagPtr = 0;

    mode = 0;

    /*
     * Guard against international characters before using byte oriented
     * routines.
     */

    if (!(string[0] & 0x80)
	    && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
	switch (string[0]) {
	    case 'r':
		mode = O_RDONLY;
		break;
	    case 'w':
		mode = O_WRONLY|O_CREAT|O_TRUNC;
		break;
	    case 'a':
		mode = O_WRONLY|O_CREAT;
                *seekFlagPtr = 1;
		break;
	    default:
		error:


                if (interp != (Tcl_Interp *) NULL) {
                    Tcl_AppendResult(interp,
                            "illegal access mode \"", string, "\"",
                            (char *) NULL);
                }
		return -1;
	}






	if (string[1] == '+') {
	    mode &= ~(O_RDONLY|O_WRONLY);
	    mode |= O_RDWR;


	    if (string[2] != 0) {


		goto error;
	    }

	} else if (string[1] != 0) {
	    goto error;
	}
        return mode;
    }

    /*
     * The access modes are specified using a list of POSIX modes
     * such as O_CREAT.
     *
     * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
     * a NULL interpreter is passed in.
     */

    if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
        if (interp != (Tcl_Interp *) NULL) {
            Tcl_AddErrorInfo(interp,
                    "\n    while processing open access modes \"");
            Tcl_AddErrorInfo(interp, string);
            Tcl_AddErrorInfo(interp, "\"");
        }
        return -1;
    }
    
    gotRW = 0;
    for (i = 0; i < modeArgc; i++) {
	flag = modeArgv[i];
	c = flag[0];
	if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
	    mode = (mode & ~RW_MODES) | O_RDONLY;
	    gotRW = 1;
	} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
	    mode = (mode & ~RW_MODES) | O_WRONLY;
	    gotRW = 1;
	} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
	    mode = (mode & ~RW_MODES) | O_RDWR;
	    gotRW = 1;
	} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
	    mode |= O_APPEND;
            *seekFlagPtr = 1;
	} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
	    mode |= O_CREAT;
	} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
	    mode |= O_EXCL;

	} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
	    mode |= O_NOCTTY;
#else
	    if (interp != (Tcl_Interp *) NULL) {
                Tcl_AppendResult(interp, "access mode \"", flag,
                        "\" not supported by this system", (char *) NULL);
            }
            ckfree((char *) modeArgv);
	    return -1;
#endif

	} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#if defined(O_NDELAY) || defined(O_NONBLOCK)
#   ifdef O_NONBLOCK
	    mode |= O_NONBLOCK;
#   else
	    mode |= O_NDELAY;
#   endif

#else
            if (interp != (Tcl_Interp *) NULL) {
                Tcl_AppendResult(interp, "access mode \"", flag,
                        "\" not supported by this system", (char *) NULL);
            }
            ckfree((char *) modeArgv);
	    return -1;
#endif

	} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
	    mode |= O_TRUNC;


	} else {

            if (interp != (Tcl_Interp *) NULL) {
                Tcl_AppendResult(interp, "invalid access mode \"", flag,
                        "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
                        " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);

            }
	    ckfree((char *) modeArgv);
	    return -1;
	}
    }

    ckfree((char *) modeArgv);

    if (!gotRW) {
        if (interp != (Tcl_Interp *) NULL) {
            Tcl_AppendResult(interp, "access mode must include either",
                    " RDONLY, WRONLY, or RDWR", (char *) NULL);
        }
	return -1;
    }
    return mode;
}


/* Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument */


int
Tcl_FSEvalFile(interp, pathPtr)
    Tcl_Interp *interp;		/* Interpreter in which to process file. */
    Tcl_Obj *pathPtr;		/* Path of file to process.  Tilde-substitution
				 * will be performed on this name. */
{
    return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSEvalFileEx --
 *
 *	Read in a file and process the entire file as one gigantic
 *	Tcl command.
 *
 * Results:
 *	A standard Tcl result, which is either the result of executing
 *	the file or an error indicating why the file couldn't be read.
 *
 * Side effects:
 *	Depends on the commands in the file.  During the evaluation
 *	of the contents of the file, iPtr->scriptFile is made to
 *	point to pathPtr (the old value is cached and replaced when
 *	this function returns).
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSEvalFileEx(interp, pathPtr, encodingName)
    Tcl_Interp *interp;		/* Interpreter in which to process file. */
    Tcl_Obj *pathPtr;		/* Path of file to process.  Tilde-substitution
				 * will be performed on this name. */
    CONST char *encodingName;   /* If non-NULL, then use this encoding 
                                 * for the file. */
{
    int result, length;
    Tcl_StatBuf statBuf;
    Tcl_Obj *oldScriptFile;
    Interp *iPtr;
    char *string;
    Tcl_Channel chan;
    Tcl_Obj *objPtr;

    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
	return TCL_ERROR;
    }

    result = TCL_ERROR;
    objPtr = Tcl_NewObj();

    if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
        Tcl_SetErrno(errno);
	Tcl_AppendResult(interp, "couldn't read file \"", 
		Tcl_GetString(pathPtr),
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }
    chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
    if (chan == (Tcl_Channel) NULL) {
        Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "couldn't read file \"", 
		Tcl_GetString(pathPtr),
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    /*
     * The eofchar is \32 (^Z).  This is the usual on Windows, but we
     * effect this cross-platform to allow for scripted documents.
     * [Bug: 2040]
     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");

    /*
     * If the encoding is specified, set it for the channel.
     * Else don't touch it (and use the system encoding)
     * Report error on unknown encoding.
     */

    if (encodingName != NULL) {
	if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
		!= TCL_OK) {
	    Tcl_Close(interp,chan);
	    goto end;
	}
    }

    if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
        Tcl_Close(interp, chan);
	Tcl_AppendResult(interp, "couldn't read file \"", 
		Tcl_GetString(pathPtr),
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    if (Tcl_Close(interp, chan) != TCL_OK) {
        goto end;
    }

    iPtr = (Interp *) interp;
    oldScriptFile = iPtr->scriptFile;
    iPtr->scriptFile = pathPtr;
    Tcl_IncrRefCount(iPtr->scriptFile);
    string = Tcl_GetStringFromObj(objPtr, &length);
    result = Tcl_EvalEx(interp, string, length, 0);

    /* 
     * Now we have to be careful; the script may have changed the
     * iPtr->scriptFile value, so we must reset it without
     * assuming it still points to 'pathPtr'.
     */

    if (iPtr->scriptFile != NULL) {
	Tcl_DecrRefCount(iPtr->scriptFile);
    }
    iPtr->scriptFile = oldScriptFile;

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {

	/*
	 * Record information telling where the error occurred.
	 */

	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
	Tcl_Obj *msg = Tcl_NewStringObj("\n    (file \"", -1);
	CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	Tcl_IncrRefCount(msg);

	Tcl_IncrRefCount(errorLine);

	TclAppendLimitedToObj(msg, pathString, length, 150, "");
	Tcl_AppendToObj(msg, "\" line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    end:
    Tcl_DecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetErrno --
 *
 *	Gets the current value of the Tcl error code variable. This is
 *	currently the global variable "errno" but could in the future
 *	change to something else.
 *
 * Results:
 *	The value of the Tcl error code variable.
 *
 * Side effects:
 *	None. Note that the value of the Tcl error code variable is
 *	UNDEFINED if a call to Tcl_SetErrno did not precede this call.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetErrno()
{







|



|


|






>
|
>
>



|
<



|
|
|

|
|
|
|
<
|
>
|
|
|
|
>
|
>
>
|
|
|
|
>
|
|
<
|













|
|
|


|


|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
<








|
|
|
|

>

>
|
|
|

>










|
|


|
|
|


|












|
|
|

















<
|
|
<
|
|
|


|
|
<





|
|
|
<

|
|
|
<
>


>


|
|
|
|
<
|
|



|
|

|
|
|
|




|

|





|


|


>
|
>
>





>
|

<
|
<














>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
>







|
|
>
>


|
|





|


|
|
|
|
|
>
>
>






|
|
|



>







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
<
|
|
|

>
>
>
>
>
>
|
|
|
>
>
|
>
>


>
|


|



|
|

|
|


|
|
|
|
|
|
|
|

|















|




>





|
|
|
|


>







>

|
|
|
|
|


>


>
>

>
|
|
|
|
>
|




>

>

|
|
|
|





>
|
>
>














|
|


|
|


|
|
|
<









|
|

















|
|






|
|




>

|
|
<

>

>

|
<
|

>







>

|
|




>

|








>
|

|
|

>








<



<
<
<

|
>
|
>
|
<
<
|
<
<
<


|










|
|





|
|







1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215

1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226

1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243

1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267

1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291

1292
1293
1294
1295

1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368

1369
1370

1371
1372
1373
1374
1375
1376
1377

1378
1379
1380
1381
1382
1383
1384
1385

1386
1387
1388
1389

1390
1391
1392
1393
1394
1395
1396
1397
1398
1399

1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441

1442

1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562

1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715

1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761

1762
1763
1764
1765
1766
1767

1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811

1812
1813
1814



1815
1816
1817
1818
1819
1820


1821



1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850

    if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
	goto endOfMounts;
    }
    if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
	goto endOfMounts;
    }
    for (i=0 ; i<mLength ; i++) {
	Tcl_Obj *mElt;
	int j;
	int found = 0;

	Tcl_ListObjIndex(NULL, mounts, i, &mElt);

	for (j=0 ; j<gLength ; j++) {
	    Tcl_Obj *gElt;

	    Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);
	    if (Tcl_FSEqualPaths(mElt, gElt)) {
		found = 1;
		if (!dir) {
		    /*
		     * We don't want to list this.
		     */

		    Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
		    gLength--;
		}
		break;		/* Break out of for loop */

	    }
	}
	if (!found && dir) {
	    int len, mlen;
	    CONST char *path;
	    CONST char *mount;

	    /*
	     * We know mElt is absolute normalized and lies inside pathPtr, so
	     * now we must add to the result the right representation of mElt,
	     * i.e. the representation which is relative to pathPtr.

	     */

	    mount = Tcl_GetStringFromObj(mElt, &mlen);
	    path = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, pathPtr),
		    &len);
	    if (path[len-1] == '/') {
		/*
		 * Deal with the root of the volume.
		 */

		len--;
	    }
	    mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len);
	    Tcl_ListObjAppendElement(NULL, resultPtr, mElt);

	    /*
	     * No need to increment gLength, since we don't want to compare

	     * mounts against mounts.
	     */
	}
    }

  endOfMounts:
    Tcl_DecrRefCount(mounts);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMountsChanged --
 *
 *	Notify the filesystem that the available mounted filesystems (or
 *	within any one filesystem type, the number or location of mount
 *	points) have changed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The global filesystem variable 'theFilesystemEpoch' is incremented.
 *	The effect of this is to make all cached path representations invalid.

 *	Clearly it should only therefore be called when it is really required!
 *	There are a few circumstances when it should be called:
 *
 *	(1) when a new filesystem is registered or unregistered.  Strictly
 *	speaking this is only necessary if the new filesystem accepts file
 *	paths as is (normally the filesystem itself is really a shell which
 *	hasn't yet had any mount points established and so its
 *	'pathInFilesystem' proc will always fail). However, for safety, Tcl
 *	always calls this for you in these circumstances.
 *
 *	(2) when additional mount points are established inside any existing
 *	filesystem (except the native fs)
 *
 *	(3) when any filesystem (except the native fs) changes the list of
 *	available volumes.
 *
 *	(4) when the mapping from a string representation of a file to a full,
 *	normalized path changes. For example, if 'env(HOME)' is modified, then
 *	any path containing '~' will map to a different filesystem location.
 *	Therefore all such paths need to have their internal representation
 *	invalidated.
 *
 *	Tcl has no control over (2) and (3), so any registered filesystem must
 *	make sure it calls this function when those situations occur.

 *
 *	(Note: the reason for the exception in 2,3 for the native filesystem
 *	is that the native filesystem by default claims all unknown files even
 *	if it really doesn't understand them or if they don't exist).

 *
 *----------------------------------------------------------------------
 */

void
Tcl_FSMountsChanged(fsPtr)
    Tcl_Filesystem *fsPtr;
{
    /*
     * We currently don't do anything with this parameter.  We could in the
     * future only invalidate files for this filesystem or otherwise take more
     * advanced action.
     */

    (void)fsPtr;

    /*
     * Increment the filesystem epoch counter, since existing paths might now
     * belong to different filesystems.
     */

    Tcl_MutexLock(&filesystemMutex);
    theFilesystemEpoch++;
    Tcl_MutexUnlock(&filesystemMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSData --
 *
 *	Retrieve the clientData field for the filesystem given, or NULL if
 *	that filesystem is not registered.
 *
 * Results:
 *	A clientData value, or NULL.  Note that if the filesystem was
 *	registered with a NULL clientData field, this function will return
 *	that NULL value.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_FSData(fsPtr)
    Tcl_Filesystem  *fsPtr;   /* The filesystem record to query. */
{
    ClientData retVal = NULL;
    FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();

    /*
     * Traverse the list of filesystems look for a particular one.  If found,
     * return that filesystem's clientData (originally provided when calling
     * Tcl_FSRegister).
     */

    while ((retVal == NULL) && (fsRecPtr != NULL)) {
	if (fsRecPtr->fsPtr == fsPtr) {
	    retVal = fsRecPtr->clientData;
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSNormalizeToUniquePath --
 *

 *	Takes a path specification containing no ../, ./ sequences, and
 *	converts it into a unique path for the given platform.  On Unix, this

 *	means the path must be free of symbolic links/aliases, and on Windows
 *	it means we want the long form, with that long form's case-dependence
 *	(which gives us a unique, case-dependent path).
 *
 * Results:
 *	The pathPtr is modified in place.  The return value is the last byte
 *	offset which was recognised in the path string.

 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special notes:
 *	If the filesystem-specific normalizePathProcs can re-introduce ../, ./
 *	sequences into the path, then this function will not return the
 *	correct result.  This may be possible with symbolic links on unix.

 *
 *	Important assumption: if startAt is non-zero, it must point to a
 *	directory separator that we know exists and is already normalized (so
 *	it is important not to point to the char just after the separator).

 *
 *---------------------------------------------------------------------------
 */

int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
    Tcl_Interp *interp;		/* Used for error messages. */
    Tcl_Obj *pathPtr;		/* The path to normalize in place */
    int startAt;		/* Start at this char-offset */
    ClientData *clientDataPtr;	/* If we generated a complete normalized path

				 * for a given filesystem, we can optionally
				 * return an fs-specific clientdata here. */
{
    FilesystemRecord *fsRecPtr, *firstFsRecPtr;
    /* Ignore this variable */
    (void) clientDataPtr;

    /*
     * Call each of the "normalise path" functions in succession. This is a
     * special case, in which if we have a native filesystem handler, we call
     * it first.  This is because the root of Tcl's filesystem is always a
     * native filesystem (i.e. '/' on unix is native).
     */

    firstFsRecPtr = FsGetFirstFilesystem();

    fsRecPtr = firstFsRecPtr;
    while (fsRecPtr != NULL) {
	if (fsRecPtr == &nativeFilesystemRecord) {
	    Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
	    if (proc != NULL) {
		startAt = (*proc)(interp, pathPtr, startAt);
	    }
	    break;
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    fsRecPtr = firstFsRecPtr;
    while (fsRecPtr != NULL) {
	/*
	 * Skip the native system next time through.
	 */

	if (fsRecPtr != &nativeFilesystemRecord) {
	    Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
	    if (proc != NULL) {
		startAt = (*proc)(interp, pathPtr, startAt);
	    }

	    /*
	     * We could add an efficiency check like this:

	     *		if (retVal == length-of(pathPtr)) {break;}

	     * but there's not much benefit.
	     */
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return startAt;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetOpenMode --
 *
 *	This routine is an obsolete, limited version of TclGetOpenModeEx()
 *	below.  It exists only to satisfy any extensions imprudently using it
 *	via Tcl's internal stubs table.
 *
 * Results:
 *	Same as TclGetOpenModeEx().
 *
 * Side effects:
 *	Same as TclGetOpenModeEx().
 *
 *---------------------------------------------------------------------------
 */

int
TclGetOpenMode(interp, modeString, seekFlagPtr)
    Tcl_Interp *interp;			/* Interpreter to use for error
					 * reporting - may be NULL. */
    CONST char *modeString;		/* Mode string, e.g. "r+" or "RDONLY
					 * CREAT". */
    int *seekFlagPtr;			/* Set this to 1 if the caller should
					 * seek to EOF during the opening of
					 * the file. */
{
    int binary = 0;
    return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetOpenModeEx --
 *
 *	Computes a POSIX mode mask for opening a file, from a given string,
 *	and also sets flags to indicate whether the caller should seek to EOF
 *	after opening the file, and whether the caller should configure the
 *	channel for binary data.
 *
 * Results:
 *	On success, returns mode to pass to "open". If an error occurs, the
 *	return value is -1 and if interp is not NULL, sets interp's result
 *	object to an error message.
 *
 * Side effects:
 *	Sets the integer referenced by seekFlagPtr to 1 to tell the caller to
 *	seek to EOF after opening the file, or to 0 otherwise.  Sets the
 *	integer referenced by binaryPtr to 1 to tell the caller to seek to
 *	configure the channel for binary data, or to 0 otherwise.
 *
 * Special note:
 *	This code is based on a prototype implementation contributed by Mark
 *	Diekhans.
 *
 *---------------------------------------------------------------------------
 */

int
TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr)
    Tcl_Interp *interp;			/* Interpreter to use for error
					 * reporting - may be NULL. */
    CONST char *modeString;		/* Mode string, e.g. "r+" or "RDONLY
					 * CREAT". */
    int *seekFlagPtr;			/* Set this to 1 if the caller should
					 * seek to EOF during the opening of
					 * the file. */
    int *binaryPtr;			/* Set this to 1 if the caller should
					 * configure the opened channel for
					 * binary operations */
{
    int mode, modeArgc, c, i, gotRW;
    CONST char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)

    /*
     * Check for the simpler fopen-like access modes (e.g. "r").  They are
     * distinguished from the POSIX access modes by the presence of a
     * lower-case first letter.
     */

    *seekFlagPtr = 0;
    *binaryPtr = 0;
    mode = 0;

    /*
     * Guard against international characters before using byte oriented
     * routines.
     */

    if (!(modeString[0] & 0x80)
	    && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */
	switch (modeString[0]) {
	case 'r':
	    mode = O_RDONLY;
	    break;
	case 'w':
	    mode = O_WRONLY|O_CREAT|O_TRUNC;
	    break;
	case 'a':
	    mode = O_WRONLY|O_CREAT;
	    *seekFlagPtr = 1;
	    break;
	default:
	error:
	    *seekFlagPtr = 0;
	    *binaryPtr = 0;
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "illegal access mode \"", modeString,

			"\"", (char *) NULL);
	    }
	    return -1;
	}
	i=1;
	while (i<3 && modeString[i]) {
	    if (modeString[i] == modeString[i-1]) {
		goto error;
	    }
	    switch (modeString[i++]) {
	    case '+':
		mode &= ~(O_RDONLY|O_WRONLY);
		mode |= O_RDWR;
		break;
	    case 'b':
		*binaryPtr = 1;
		break;
	    default:
		goto error;
	    }
	}
	if (modeString[i] != 0) {
	    goto error;
	}
	return mode;
    }

    /*
     * The access modes are specified using a list of POSIX modes such as
     * O_CREAT.
     *
     * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL
     * interpreter is passed in.
     */

    if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AddErrorInfo(interp,
		    "\n    while processing open access modes \"");
	    Tcl_AddErrorInfo(interp, modeString);
	    Tcl_AddErrorInfo(interp, "\"");
	}
	return -1;
    }

    gotRW = 0;
    for (i = 0; i < modeArgc; i++) {
	flag = modeArgv[i];
	c = flag[0];
	if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
	    mode = (mode & ~RW_MODES) | O_RDONLY;
	    gotRW = 1;
	} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
	    mode = (mode & ~RW_MODES) | O_WRONLY;
	    gotRW = 1;
	} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
	    mode = (mode & ~RW_MODES) | O_RDWR;
	    gotRW = 1;
	} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
	    mode |= O_APPEND;
	    *seekFlagPtr = 1;
	} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
	    mode |= O_CREAT;
	} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
	    mode |= O_EXCL;

	} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
	    mode |= O_NOCTTY;
#else
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "access mode \"", flag,
			"\" not supported by this system", (char *) NULL);
	    }
	    ckfree((char *) modeArgv);
	    return -1;
#endif

	} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#if defined(O_NDELAY) || defined(O_NONBLOCK)
#   ifdef O_NONBLOCK
	    mode |= O_NONBLOCK;
#   else
	    mode |= O_NDELAY;
#   endif

#else
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "access mode \"", flag,
			"\" not supported by this system", (char *) NULL);
	    }
	    ckfree((char *) modeArgv);
	    return -1;
#endif

	} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
	    mode |= O_TRUNC;
	} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
	    *binaryPtr = 1;
	} else {

	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "invalid access mode \"", flag,
			"\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
			"CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC",
			(char *) NULL);
	    }
	    ckfree((char *) modeArgv);
	    return -1;
	}
    }

    ckfree((char *) modeArgv);

    if (!gotRW) {
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "access mode must include either",
		    " RDONLY, WRONLY, or RDWR", (char *) NULL);
	}
	return -1;
    }
    return mode;
}

/*
 * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
 */

int
Tcl_FSEvalFile(interp, pathPtr)
    Tcl_Interp *interp;		/* Interpreter in which to process file. */
    Tcl_Obj *pathPtr;		/* Path of file to process.  Tilde-substitution
				 * will be performed on this name. */
{
    return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSEvalFileEx --
 *
 *	Read in a file and process the entire file as one gigantic Tcl
 *	command.
 *
 * Results:
 *	A standard Tcl result, which is either the result of executing the
 *	file or an error indicating why the file couldn't be read.
 *
 * Side effects:
 *	Depends on the commands in the file.  During the evaluation of the
 *	contents of the file, iPtr->scriptFile is made to point to pathPtr
 *	(the old value is cached and replaced when this function returns).

 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSEvalFileEx(interp, pathPtr, encodingName)
    Tcl_Interp *interp;		/* Interpreter in which to process file. */
    Tcl_Obj *pathPtr;		/* Path of file to process.  Tilde-substitution
				 * will be performed on this name. */
    CONST char *encodingName;   /* If non-NULL, then use this encoding for the
				 * file. */
{
    int result, length;
    Tcl_StatBuf statBuf;
    Tcl_Obj *oldScriptFile;
    Interp *iPtr;
    char *string;
    Tcl_Channel chan;
    Tcl_Obj *objPtr;

    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
	return TCL_ERROR;
    }

    result = TCL_ERROR;
    objPtr = Tcl_NewObj();

    if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
	Tcl_SetErrno(errno);
	Tcl_AppendResult(interp, "couldn't read file \"",
		Tcl_GetString(pathPtr),
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }
    chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
    if (chan == (Tcl_Channel) NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "couldn't read file \"",
		Tcl_GetString(pathPtr),
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    /*
     * The eofchar is \32 (^Z).  This is the usual on Windows, but we effect
     * this cross-platform to allow for scripted documents.  [Bug: 2040]

     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");

    /*
     * If the encoding is specified, set it for the channel.  Else don't touch

     * it (and use the system encoding) Report error on unknown encoding.
     */

    if (encodingName != NULL) {
	if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
		!= TCL_OK) {
	    Tcl_Close(interp,chan);
	    goto end;
	}
    }

    if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
	Tcl_Close(interp, chan);
	Tcl_AppendResult(interp, "couldn't read file \"",
		Tcl_GetString(pathPtr),
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    if (Tcl_Close(interp, chan) != TCL_OK) {
	goto end;
    }

    iPtr = (Interp *) interp;
    oldScriptFile = iPtr->scriptFile;
    iPtr->scriptFile = pathPtr;
    Tcl_IncrRefCount(iPtr->scriptFile);
    string = Tcl_GetStringFromObj(objPtr, &length);
    result = Tcl_EvalEx(interp, string, length, 0);

    /*
     * Now we have to be careful; the script may have changed the
     * iPtr->scriptFile value, so we must reset it without assuming it still
     * points to 'pathPtr'.
     */

    if (iPtr->scriptFile != NULL) {
	Tcl_DecrRefCount(iPtr->scriptFile);
    }
    iPtr->scriptFile = oldScriptFile;

    if (result == TCL_RETURN) {
	result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {

	/*
	 * Record information telling where the error occurred.
	 */



	CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	int limit = 150;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp, "\n    (file \"%.*s%s\" line %d)",
		(overflow ? limit : length), pathString,


		(overflow ? "..." : ""), interp->errorLine);



    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetErrno --
 *
 *	Gets the current value of the Tcl error code variable. This is
 *	currently the global variable "errno" but could in the future change
 *	to something else.
 *
 * Results:
 *	The value of the Tcl error code variable.
 *
 * Side effects:
 *	None. Note that the value of the Tcl error code variable is UNDEFINED
 *	if a call to Tcl_SetErrno did not precede this call.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetErrno()
{
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867

1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885

1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PosixError --
 *
 *	This procedure is typically called after UNIX kernel calls
 *	return errors.  It stores machine-readable information about
 *	the error in errorCode field of interp and returns an
 *	information string for the caller's use.
 *
 * Results:
 *	The return value is a human-readable string describing the
 *	error.
 *
 * Side effects:
 *	The errorCode field of the interp is set.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PosixError(interp)
    Tcl_Interp *interp;		/* Interpreter whose errorCode field 
				 * is to be set. */
{
    CONST char *id, *msg;

    msg = Tcl_ErrnoMsg(errno);
    id = Tcl_ErrnoId();
    Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
    return msg;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSStat --
 *
 *	This procedure replaces the library version of stat and lsat.
 *	
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *      See stat documentation.
 *
 * Side effects:
 *      See stat documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSStat(pathPtr, buf)
    Tcl_Obj *pathPtr;		/* Path of file to stat (in current CP). */
    Tcl_StatBuf *buf;		/* Filled with results of stat call. */
{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    struct stat oldStyleStatBuffer;
    int retVal = -1;

    /*
     * Call each of the "stat" function in succession.  A non-return
     * value of -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    
    if (statProcList != NULL) {
	StatProc *statProcPtr;
	char *path;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    path = NULL;
	} else {
	    path = Tcl_GetString(transPtr);
	}

	statProcPtr = statProcList;
	while ((retVal == -1) && (statProcPtr != NULL)) {
	    retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
	    statProcPtr = statProcPtr->nextPtr;
	}
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
    }
    
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
	/*
	 * Note that EOVERFLOW is not a problem here, and these
	 * assignments should all be widening (if not identity.)
	 */

	buf->st_mode = oldStyleStatBuffer.st_mode;
	buf->st_ino = oldStyleStatBuffer.st_ino;
	buf->st_dev = oldStyleStatBuffer.st_dev;
	buf->st_rdev = oldStyleStatBuffer.st_rdev;
	buf->st_nlink = oldStyleStatBuffer.st_nlink;
	buf->st_uid = oldStyleStatBuffer.st_uid;
	buf->st_gid = oldStyleStatBuffer.st_gid;
	buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
	buf->st_atime = oldStyleStatBuffer.st_atime;
	buf->st_mtime = oldStyleStatBuffer.st_mtime;
	buf->st_ctime = oldStyleStatBuffer.st_ctime;
#ifdef HAVE_ST_BLOCKS
	buf->st_blksize = oldStyleStatBuffer.st_blksize;
	buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
#endif
        return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSStatProc *proc = fsPtr->statProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, buf);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSLstat --
 *
 *	This procedure replaces the library version of lstat.
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.  If no 'lstat' function is listed,
 *	but a 'stat' function is, then Tcl will fall back on the
 *	stat function.
 *
 * Results:
 *      See lstat documentation.
 *
 * Side effects:
 *      See lstat documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLstat(pathPtr, buf)
    Tcl_Obj *pathPtr;		/* Path of file to stat (in current CP). */







|
|
|
|


|
<









|
















|
|
|


|


|















|
|



|



















|



|
|

>















|


>
















|
|
<
|
|


|


|







1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888

1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008

2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PosixError --
 *
 *	This procedure is typically called after UNIX kernel calls return
 *	errors.  It stores machine-readable information about the error in
 *	errorCode field of interp and returns an information string for the
 *	caller's use.
 *
 * Results:
 *	The return value is a human-readable string describing the error.

 *
 * Side effects:
 *	The errorCode field of the interp is set.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PosixError(interp)
    Tcl_Interp *interp;		/* Interpreter whose errorCode field
				 * is to be set. */
{
    CONST char *id, *msg;

    msg = Tcl_ErrnoMsg(errno);
    id = Tcl_ErrnoId();
    Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
    return msg;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSStat --
 *
 *	This procedure replaces the library version of stat and lsat.
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	See stat documentation.
 *
 * Side effects:
 *	See stat documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSStat(pathPtr, buf)
    Tcl_Obj *pathPtr;		/* Path of file to stat (in current CP). */
    Tcl_StatBuf *buf;		/* Filled with results of stat call. */
{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    struct stat oldStyleStatBuffer;
    int retVal = -1;

    /*
     * Call each of the "stat" function in succession.  A non-return value of
     * -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);

    if (statProcList != NULL) {
	StatProc *statProcPtr;
	char *path;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    path = NULL;
	} else {
	    path = Tcl_GetString(transPtr);
	}

	statProcPtr = statProcList;
	while ((retVal == -1) && (statProcPtr != NULL)) {
	    retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
	    statProcPtr = statProcPtr->nextPtr;
	}
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
    }

    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
	/*
	 * Note that EOVERFLOW is not a problem here, and these assignments
	 * should all be widening (if not identity.)
	 */

	buf->st_mode = oldStyleStatBuffer.st_mode;
	buf->st_ino = oldStyleStatBuffer.st_ino;
	buf->st_dev = oldStyleStatBuffer.st_dev;
	buf->st_rdev = oldStyleStatBuffer.st_rdev;
	buf->st_nlink = oldStyleStatBuffer.st_nlink;
	buf->st_uid = oldStyleStatBuffer.st_uid;
	buf->st_gid = oldStyleStatBuffer.st_gid;
	buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
	buf->st_atime = oldStyleStatBuffer.st_atime;
	buf->st_mtime = oldStyleStatBuffer.st_mtime;
	buf->st_ctime = oldStyleStatBuffer.st_ctime;
#ifdef HAVE_ST_BLOCKS
	buf->st_blksize = oldStyleStatBuffer.st_blksize;
	buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
#endif
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSStatProc *proc = fsPtr->statProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, buf);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSLstat --
 *
 *	This procedure replaces the library version of lstat.  The appropriate
 *	function for the filesystem to which pathPtr belongs will be called.

 *	If no 'lstat' function is listed, but a 'stat' function is, then Tcl
 *	will fall back on the stat function.
 *
 * Results:
 *	See lstat documentation.
 *
 * Side effects:
 *	See lstat documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLstat(pathPtr, buf)
    Tcl_Obj *pathPtr;		/* Path of file to stat (in current CP). */
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSAccess --
 *
 *	This procedure replaces the library version of access.
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *      See access documentation.
 *
 * Side effects:
 *      See access documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;		/* Path of file to access (in current CP). */
    int mode;                   /* Permission setting. */
{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    int retVal = -1;

    /*
     * Call each of the "access" function in succession.  A non-return
     * value of -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);

    if (accessProcList != NULL) {
	AccessProc *accessProcPtr;
	char *path;







|
|
|


|


|







|






|
|







2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSAccess --
 *
 *	This procedure replaces the library version of access.  The
 *	appropriate function for the filesystem to which pathPtr belongs will
 *	be called.
 *
 * Results:
 *	See access documentation.
 *
 * Side effects:
 *	See access documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;		/* Path of file to access (in current CP). */
    int mode;			/* Permission setting. */
{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    int retVal = -1;

    /*
     * Call each of the "access" function in succession.  A non-return value
     * of -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);

    if (accessProcList != NULL) {
	AccessProc *accessProcPtr;
	char *path;
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996

1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080

2081
2082
2083
2084
2085
2086
2087
2088
2089

2090
2091
2092
2093

2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108




2109
2110
2111
2112


2113


2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294













































































2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
	    retVal = (*accessProcPtr->proc)(path, mode);
	    accessProcPtr = accessProcPtr->nextPtr;
	}
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
    }
    
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSAccessProc *proc = fsPtr->accessProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, mode);
	}
    }

    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSOpenFileChannel --
 *
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *	The new channel or NULL, if the named file could not be opened.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Channel
Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
                                         * can be NULL. */
    Tcl_Obj *pathPtr;                   /* Name of file to open. */
    CONST char *modeString;             /* A list of POSIX open modes or
                                         * a string such as "rw". */
    int permissions;                    /* If the open involves creating a
                                         * file, with what modes to create
                                         * it? */
{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    Tcl_Channel retVal = NULL;

    /*
     * Call each of the "Tcl_OpenFileChannel" functions in succession.
     * A non-NULL return value indicates the particular function has
     * succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    if (openFileChannelProcList != NULL) {
	OpenFileChannelProc *openFileChannelProcPtr;
	char *path;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
	
	if (transPtr == NULL) {
	    path = NULL;
	} else {
	    path = Tcl_GetString(transPtr);
	}

	openFileChannelProcPtr = openFileChannelProcList;
	
	while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
	    retVal = (*openFileChannelProcPtr->proc)(interp, path,
						     modeString, permissions);
	    openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
	}
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != NULL) {
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */
    
    /* 
     * We need this just to ensure we return the correct error messages
     * under some circumstances.
     */

    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
        return NULL;
    }
    
    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
	if (proc != NULL) {
	    int mode, seekFlag;

	    mode = TclGetOpenMode(interp, modeString, &seekFlag);
	    if (mode == -1) {
	        return NULL;
	    }

	    retVal = (*proc)(interp, pathPtr, mode, permissions);
	    if (retVal != NULL) {
		if (seekFlag) {
		    if (Tcl_Seek(retVal, (Tcl_WideInt)0, 
				 SEEK_END) < (Tcl_WideInt)0) {
			if (interp != (Tcl_Interp *) NULL) {
			    Tcl_AppendResult(interp,
			      "could not seek to end of file while opening \"",
			      Tcl_GetString(pathPtr), "\": ", 
			      Tcl_PosixError(interp), (char *) NULL);
			}
			Tcl_Close(NULL, retVal);
			return NULL;
		    }
		}




	    }
	    return retVal;
	}
    }


    /* File doesn't belong to any filesystem that can open it */


    Tcl_SetErrno(ENOENT);
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open \"", 
			 Tcl_GetString(pathPtr), "\": ",
			 Tcl_PosixError(interp), (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSUtime --
 *
 *	This procedure replaces the library version of utime.
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *      See utime documentation.
 *
 * Side effects:
 *      See utime documentation.
 *
 *----------------------------------------------------------------------
 */

int 
Tcl_FSUtime (pathPtr, tval)
    Tcl_Obj *pathPtr;       /* File to change access/modification times */
    struct utimbuf *tval;   /* Structure containing access/modification 
                             * times to use.  Should not be modified. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, tval);
	}
    }
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrStrings --
 *
 *	This procedure implements the platform dependent 'file
 *	attributes' subcommand, for the native filesystem, for listing
 *	the set of possible attribute strings.  This function is part
 *	of Tcl's native filesystem support, and is placed here because
 *	it is shared by Unix and Windows code.
 *
 * Results:
 *      An array of strings
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static CONST char**
NativeFileAttrStrings(pathPtr, objPtrRef)
    Tcl_Obj *pathPtr;
    Tcl_Obj** objPtrRef;
{
    return tclpFileAttrStrings;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrsGet --
 *
 *	This procedure implements the platform dependent
 *	'file attributes' subcommand, for the native
 *	filesystem, for 'get' operations.  This function is part
 *	of Tcl's native filesystem support, and is placed here
 *	because it is shared by Unix and Windows code.
 *
 * Results:
 *      Standard Tcl return code.  The object placed in objPtrRef
 *      (if TCL_OK was returned) is likely to have a refCount of zero.
 *      Either way we must either store it somewhere (e.g. the Tcl 
 *      result), or Incr/Decr its refCount to ensure it is properly
 *      freed.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
NativeFileAttrsGet(interp, index, pathPtr, objPtrRef)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int index;			/* index of the attribute command. */
    Tcl_Obj *pathPtr;		/* path of file we are operating on. */
    Tcl_Obj **objPtrRef;	/* for output. */
{
    return (*tclpFileAttrProcs[index].getProc)(interp, index, 
					       pathPtr, objPtrRef);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrsSet --
 *
 *	This procedure implements the platform dependent
 *	'file attributes' subcommand, for the native
 *	filesystem, for 'set' operations. This function is part
 *	of Tcl's native filesystem support, and is placed here
 *	because it is shared by Unix and Windows code.
 *
 * Results:
 *      Standard Tcl return code.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
NativeFileAttrsSet(interp, index, pathPtr, objPtr)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int index;			/* index of the attribute command. */
    Tcl_Obj *pathPtr;		/* path of file we are operating on. */
    Tcl_Obj *objPtr;		/* set to this value. */
{
    return (*tclpFileAttrProcs[index].setProc)(interp, index,
					       pathPtr, objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrStrings --
 *
 *	This procedure implements part of the hookable 'file
 *	attributes' subcommand.  The appropriate function for the
 *	filesystem to which pathPtr belongs will be called.
 *
 * Results:
 *      The called procedure may either return an array of strings,
 *      or may instead return NULL and place a Tcl list into the 
 *      given objPtrRef.  Tcl will take that list and first increment
 *      its refCount before using it.  On completion of that use, Tcl
 *      will decrement its refCount.  Hence if the list should be
 *      disposed of by Tcl when done, it should have a refCount of zero,
 *      and if the list should not be disposed of, the filesystem
 *      should ensure it retains a refCount on the object.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

CONST char **
Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
    Tcl_Obj* pathPtr;
    Tcl_Obj** objPtrRef;
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, objPtrRef);
	}
    }
    Tcl_SetErrno(ENOENT);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *













































































 * Tcl_FSFileAttrsGet --
 *
 *	This procedure implements read access for the hookable 'file
 *	attributes' subcommand.  The appropriate function for the
 *	filesystem to which pathPtr belongs will be called.
 *
 * Results:
 *      Standard Tcl return code.  The object placed in objPtrRef
 *      (if TCL_OK was returned) is likely to have a refCount of zero.
 *      Either way we must either store it somewhere (e.g. the Tcl 
 *      result), or Incr/Decr its refCount to ensure it is properly
 *      freed.

 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */







|





>

















|
|





|
|



|


|
|
|
|
|
|
|
<






|
|
<







|







|


|











|
|
|
|

>

|

|




|
>
|

|

>



|
|



|
|





>
>
>
>




>
>
|
>
>


|
<
|









|
|
<


|


|




|
|
|
|
|
















|
|
|
|
|


|


|

















|
<
|
|
|


|
|
|
|
<


|











|
|







|
<
|
|
|


|


|











|
<







|
|
|


|
|
|
|
<
|
|
|


|






|
|















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|


|
|
|
|
<
<


|







2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140

2141
2142
2143
2144
2145
2146
2147
2148

2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230

2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242

2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302

2303
2304
2305
2306
2307
2308
2309
2310
2311

2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335

2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356

2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372

2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489


2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
	    retVal = (*accessProcPtr->proc)(path, mode);
	    accessProcPtr = accessProcPtr->nextPtr;
	}
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
    }

    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSAccessProc *proc = fsPtr->accessProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, mode);
	}
    }

    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSOpenFileChannel --
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	The new channel or NULL, if the named file could not be opened.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the file
 *	system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
    Tcl_Interp *interp;		/* Interpreter for error reporting; can be
				 * NULL. */
    Tcl_Obj *pathPtr;		/* Name of file to open. */
    CONST char *modeString;	/* A list of POSIX open modes or a string such
				 * as "rw". */
    int permissions;		/* If the open involves creating a file, with
				 * what modes to create it? */

{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    Tcl_Channel retVal = NULL;

    /*
     * Call each of the "Tcl_OpenFileChannel" functions in succession.  A
     * non-NULL return value indicates the particular function has succeeded.

     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    if (openFileChannelProcList != NULL) {
	OpenFileChannelProc *openFileChannelProcPtr;
	char *path;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);

	if (transPtr == NULL) {
	    path = NULL;
	} else {
	    path = Tcl_GetString(transPtr);
	}

	openFileChannelProcPtr = openFileChannelProcList;

	while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
	    retVal = (*openFileChannelProcPtr->proc)(interp, path,
		    modeString, permissions);
	    openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
	}
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != NULL) {
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    /*
     * We need this just to ensure we return the correct error messages under
     * some circumstances.
     */

    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
	return NULL;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
	if (proc != NULL) {
	    int mode, seekFlag, binary;

	    mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
	    if (mode == -1) {
		return NULL;
	    }

	    retVal = (*proc)(interp, pathPtr, mode, permissions);
	    if (retVal != NULL) {
		if (seekFlag) {
		    if (Tcl_Seek(retVal, (Tcl_WideInt)0,
			    SEEK_END) < (Tcl_WideInt)0) {
			if (interp != (Tcl_Interp *) NULL) {
			    Tcl_AppendResult(interp,
			      "could not seek to end of file while opening \"",
				    Tcl_GetString(pathPtr), "\": ",
				    Tcl_PosixError(interp), (char *) NULL);
			}
			Tcl_Close(NULL, retVal);
			return NULL;
		    }
		}
		if (binary) {
		    Tcl_SetChannelOption(interp, retVal,
			    "-translation", "binary");
		}
	    }
	    return retVal;
	}
    }

    /*
     * File doesn't belong to any filesystem that can open it.
     */

    Tcl_SetErrno(ENOENT);
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr),

		"\": ", Tcl_PosixError(interp), (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSUtime --
 *
 *	This procedure replaces the library version of utime.  The appropriate
 *	function for the filesystem to which pathPtr belongs will be called.

 *
 * Results:
 *	See utime documentation.
 *
 * Side effects:
 *	See utime documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSUtime(pathPtr, tval)
    Tcl_Obj *pathPtr;		/* File to change access/modification times */
    struct utimbuf *tval;	/* Structure containing access/modification
				 * times to use.  Should not be modified. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, tval);
	}
    }
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrStrings --
 *
 *	This procedure implements the platform dependent 'file attributes'
 *	subcommand, for the native filesystem, for listing the set of possible
 *	attribute strings.  This function is part of Tcl's native filesystem
 *	support, and is placed here because it is shared by Unix and Windows
 *	code.
 *
 * Results:
 *	An array of strings
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static CONST char**
NativeFileAttrStrings(pathPtr, objPtrRef)
    Tcl_Obj *pathPtr;
    Tcl_Obj** objPtrRef;
{
    return tclpFileAttrStrings;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrsGet --
 *
 *	This procedure implements the platform dependent 'file attributes'

 *	subcommand, for the native filesystem, for 'get' operations.  This
 *	function is part of Tcl's native filesystem support, and is placed
 *	here because it is shared by Unix and Windows code.
 *
 * Results:
 *	Standard Tcl return code.  The object placed in objPtrRef (if TCL_OK
 *	was returned) is likely to have a refCount of zero.  Either way we
 *	must either store it somewhere (e.g. the Tcl result), or Incr/Decr its
 *	refCount to ensure it is properly freed.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
NativeFileAttrsGet(interp, index, pathPtr, objPtrRef)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int index;			/* index of the attribute command. */
    Tcl_Obj *pathPtr;		/* path of file we are operating on. */
    Tcl_Obj **objPtrRef;	/* for output. */
{
    return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr,
	    objPtrRef);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrsSet --
 *
 *	This procedure implements the platform dependent 'file attributes'

 *	subcommand, for the native filesystem, for 'set' operations. This
 *	function is part of Tcl's native filesystem support, and is placed
 *	here because it is shared by Unix and Windows code.
 *
 * Results:
 *	Standard Tcl return code.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
NativeFileAttrsSet(interp, index, pathPtr, objPtr)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int index;			/* index of the attribute command. */
    Tcl_Obj *pathPtr;		/* path of file we are operating on. */
    Tcl_Obj *objPtr;		/* set to this value. */
{
    return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr);

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrStrings --
 *
 *	This procedure implements part of the hookable 'file attributes'
 *	subcommand.  The appropriate function for the filesystem to which
 *	pathPtr belongs will be called.
 *
 * Results:
 *	The called procedure may either return an array of strings, or may
 *	instead return NULL and place a Tcl list into the given objPtrRef.
 *	Tcl will take that list and first increment its refCount before using
 *	it. On completion of that use, Tcl will decrement its refCount. Hence

 *	if the list should be disposed of by Tcl when done, it should have a
 *	refCount of zero, and if the list should not be disposed of, the
 *	filesystem should ensure it retains a refCount on the object.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char **
Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
    Tcl_Obj *pathPtr;
    Tcl_Obj **objPtrRef;
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, objPtrRef);
	}
    }
    Tcl_SetErrno(ENOENT);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSFileAttrIndex --
 *
 *	Helper function for converting an attribute name to an index into the
 *	attribute table.
 *
 * Results:
 *	Tcl result code, index written to *indexPtr on result==TCL_OK
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclFSFileAttrIndex(pathPtr, attributeName, indexPtr)
    Tcl_Obj *pathPtr;			/* File whose attributes are to be
					 * indexed into. */
    CONST char *attributeName;		/* The attribute being looked for. */
    int *indexPtr;			/* Where to write the found index. */
{
    Tcl_Obj *listObj = NULL;
    CONST char **attrTable;

    /*
     * Get the attribute table for the file.
     */

    attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj);
    if (listObj != NULL) {
	Tcl_IncrRefCount(listObj);
    }

    if (attrTable != NULL) {
	/*
	 * It's a constant attribute table, so use T_GIFO.
	 */

	Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1);
	int result;

	result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT,
		indexPtr);
	TclDecrRefCount(tmpObj);
	if (listObj != NULL) {
	    TclDecrRefCount(listObj);
	}
	return result;
    } else if (listObj != NULL) {
	/*
	 * It's a non-constant attribute list, so do a literal search.
	 */

	int i, objc;
	Tcl_Obj **objv;

	if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {
	    TclDecrRefCount(listObj);
	    return TCL_ERROR;
	}
	for (i=0 ; i<objc ; i++) {
	    if (!strcmp(attributeName, TclGetString(objv[i]))) {
		TclDecrRefCount(listObj);
		*indexPtr = i;
		return TCL_OK;
	    }
	}
	TclDecrRefCount(listObj);
	return TCL_ERROR;
    } else {
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsGet --
 *
 *	This procedure implements read access for the hookable 'file
 *	attributes' subcommand.  The appropriate function for the filesystem
 *	to which pathPtr belongs will be called.
 *
 * Results:
 *	Standard Tcl return code.  The object placed in objPtrRef (if TCL_OK
 *	was returned) is likely to have a refCount of zero.  Either way we
 *	must either store it somewhere (e.g. the Tcl result), or Incr/Decr its
 *	refCount to ensure it is properly freed.


 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsSet --
 *
 *	This procedure implements write access for the hookable 'file
 *	attributes' subcommand.  The appropriate function for the
 *	filesystem to which pathPtr belongs will be called.
 *
 * Results:
 *      Standard Tcl return code.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */







|
|


|


|







2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsSet --
 *
 *	This procedure implements write access for the hookable 'file
 *	attributes' subcommand.  The appropriate function for the filesystem
 *	to which pathPtr belongs will be called.
 *
 * Results:
 *	Standard Tcl return code.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439

2440
2441
2442
2443
2444
2445

2446
2447
2448
2449
2450

2451
2452
2453
2454

2455
2456
2457
2458
2459
2460
2461

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetCwd --
 *
 *	This function replaces the library version of getcwd().
 *	
 *	Most VFS's will *not* implement a 'cwdProc'.  Tcl now maintains
 *	its own record (in a Tcl_Obj) of the cwd, and an attempt
 *	is made to synchronise this with the cwd's containing filesystem,
 *	if that filesystem provides a cwdProc (e.g. the native filesystem).
 *	
 *	Note that if Tcl's cwd is not in the native filesystem, then of
 *	course Tcl's cwd and the native cwd are different: extensions
 *	should therefore ensure they only access the cwd through this
 *	function to avoid confusion.
 *	
 *	If a global cwdPathPtr already exists, it is cached in the thread's
 *	private data structures and reference to the cached copy is returned,
 *	subject to a synchronisation attempt in that cwdPathPtr's fs.
 *	
 *	Otherwise, the chain of functions that have been "inserted"
 *	into the filesystem will be called in succession until either a
 *	value other than NULL is returned, or the entire list is
 *	visited.
 *
 * Results:
 *	The result is a pointer to a Tcl_Obj specifying the current
 *	directory, or NULL if the current directory could not be
 *	determined.  If NULL is returned, an error message is left in the
 *	interp's result.  
 *	
 *	The result already has its refCount incremented for the caller.
 *	When it is no longer needed, that refCount should be decremented.
 *
 * Side effects:
 *	Various objects may be freed and allocated.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSGetCwd(interp)
    Tcl_Interp *interp;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    
    if (TclFSCwdPointerEquals(NULL)) {
	FilesystemRecord *fsRecPtr;
	Tcl_Obj *retVal = NULL;

	/* 
	 * We've never been called before, try to find a cwd.  Call
	 * each of the "Tcl_GetCwd" function in succession.  A non-NULL
	 * return value indicates the particular function has
	 * succeeded.
	 */

	fsRecPtr = FsGetFirstFilesystem();
	while ((retVal == NULL) && (fsRecPtr != NULL)) {
	    Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
	    if (proc != NULL) {
		if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
		    ClientData retCd;
		    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
		    
		    retCd = (*proc2)(NULL);
		    if (retCd != NULL) {
			Tcl_Obj *norm;
			/* Looks like a new current directory */
			retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(retCd);

			Tcl_IncrRefCount(retVal);
			norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
			if (norm != NULL) {
			    /* 
			     * We found a cwd, which is now in our global storage.
			     * We must make a copy. Norm already has a refCount of 1.

			     * 
			     * Threading issue: note that multiple threads at system
			     * startup could in principle call this procedure 
			     * simultaneously.  They will therefore each set the
			     * cwdPathPtr independently.  That behaviour is a bit

			     * peculiar, but should be fine.  Once we have a cwd,
			     * we'll always be in the 'else' branch below which
			     * is simpler.
			     */

			    FsUpdateCwd(norm, retCd);
			    Tcl_DecrRefCount(norm);
			} else {
			    (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd);
			}
			Tcl_DecrRefCount(retVal);
			retVal = NULL;







|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
<


|
|
|
<
|
|
|












|




|
|
|
|
<









|




|
>

|

|
|
|
>
|
|
|
|
|
>
|
|
<

>







2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574

2575
2576
2577
2578
2579

2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603

2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634

2635
2636
2637
2638
2639
2640
2641
2642
2643

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetCwd --
 *
 *	This function replaces the library version of getcwd().
 *
 *	Most VFS's will *not* implement a 'cwdProc'.  Tcl now maintains its
 *	own record (in a Tcl_Obj) of the cwd, and an attempt is made to
 *	synchronise this with the cwd's containing filesystem, if that
 *	filesystem provides a cwdProc (e.g. the native filesystem).
 *
 *	Note that if Tcl's cwd is not in the native filesystem, then of course
 *	Tcl's cwd and the native cwd are different: extensions should
 *	therefore ensure they only access the cwd through this function to
 *	avoid confusion.
 *
 *	If a global cwdPathPtr already exists, it is cached in the thread's
 *	private data structures and reference to the cached copy is returned,
 *	subject to a synchronisation attempt in that cwdPathPtr's fs.
 *
 *	Otherwise, the chain of functions that have been "inserted" into the
 *	filesystem will be called in succession until either a value other
 *	than NULL is returned, or the entire list is visited.

 *
 * Results:
 *	The result is a pointer to a Tcl_Obj specifying the current directory,
 *	or NULL if the current directory could not be determined.  If NULL is
 *	returned, an error message is left in the interp's result.

 *
 *	The result already has its refCount incremented for the caller.  When
 *	it is no longer needed, that refCount should be decremented.
 *
 * Side effects:
 *	Various objects may be freed and allocated.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSGetCwd(interp)
    Tcl_Interp *interp;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (TclFSCwdPointerEquals(NULL)) {
	FilesystemRecord *fsRecPtr;
	Tcl_Obj *retVal = NULL;

	/*
	 * We've never been called before, try to find a cwd.  Call each of
	 * the "Tcl_GetCwd" function in succession.  A non-NULL return value
	 * indicates the particular function has succeeded.

	 */

	fsRecPtr = FsGetFirstFilesystem();
	while ((retVal == NULL) && (fsRecPtr != NULL)) {
	    Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
	    if (proc != NULL) {
		if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
		    ClientData retCd;
		    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;

		    retCd = (*proc2)(NULL);
		    if (retCd != NULL) {
			Tcl_Obj *norm;
			/* Looks like a new current directory */
			retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(
				retCd);
			Tcl_IncrRefCount(retVal);
			norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL);
			if (norm != NULL) {
			    /*
			     * We found a cwd, which is now in our global
			     * storage.  We must make a copy. Norm already has
			     * a refCount of 1.
			     *
			     * Threading issue: note that multiple threads at
			     * system startup could in principle call this
			     * procedure simultaneously.  They will therefore
			     * each set the cwdPathPtr independently.  That
			     * behaviour is a bit peculiar, but should be
			     * fine.  Once we have a cwd, we'll always be in
			     * the 'else' branch below which is simpler.

			     */

			    FsUpdateCwd(norm, retCd);
			    Tcl_DecrRefCount(norm);
			} else {
			    (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd);
			}
			Tcl_DecrRefCount(retVal);
			retVal = NULL;
2469
2470
2471
2472
2473
2474
2475

2476
2477
2478
2479
2480
2481
2482
2483

2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498

2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512

2513

2514
2515
2516
2517
2518
2519
2520
2521
2522

2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541

2542


2543
2544
2545
2546
2547
2548
2549
2550

2551
2552
2553
2554
2555

2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571

2572
2573

2574
2575
2576
2577
2578
2579
2580
2581
2582
2583

2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631

2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651

2652
2653

2654


2655

2656
2657
2658
2659
2660
2661

2662
2663
2664

2665


2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712

2713

2714
2715
2716
2717
2718

2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738

2739
2740
2741

2742


2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827

2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909


2910


2911

2912
2913
2914
2915
2916
2917

2918
2919
2920


2921
2922
2923
2924
2925
2926
2927
2928
2929
2930

2931

























































2932
2933
2934

2935
2936


2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948

2949
2950


2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971

2972
2973


2974

2975
2976
2977
2978
2979
2980
2981
2982

2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994

2995
2996
2997
2998
2999

3000
3001

3002
3003
3004
3005
3006
3007
3008
3009

3010
3011
3012

3013
3014

3015
3016
3017
3018
3019

3020
3021
3022
3023
3024
3025
3026

3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039

3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051

3052
3053
3054
3055
3056
3057
3058
3059
3060

3061

3062

3063


3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075

3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141

3142
3143
3144
3145

3146
3147
3148
3149
3150
3151
3152
3153
3154

3155
3156
3157
3158
3159
3160
3161
3162
3163
3164

3165
3166

3167
3168
3169
3170
3171

3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196

3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251

3252
3253
3254
3255
3256
3257
3258

3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419

3420


3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435

3436
3437
3438
3439
3440
3441

3442


3443
3444
3445
3446
3447
3448
3449
		    }
		} else {
		    retVal = (*proc)(interp);
		}
	    }
	    fsRecPtr = fsRecPtr->nextPtr;
	}

	/* 
	 * Now the 'cwd' may NOT be normalized, at least on some
	 * platforms.  For the sake of efficiency, we want a completely
	 * normalized cwd at all times.
	 * 
	 * Finally, if retVal is NULL, we do not have a cwd, which
	 * could be problematic.
	 */

	if (retVal != NULL) {
	    Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
	    if (norm != NULL) {
		/* 
		 * We found a cwd, which is now in our global storage.
		 * We must make a copy. Norm already has a refCount of 1.
		 * 
		 * Threading issue: note that multiple threads at system
		 * startup could in principle call this procedure 
		 * simultaneously.  They will therefore each set the
		 * cwdPathPtr independently.  That behaviour is a bit
		 * peculiar, but should be fine.  Once we have a cwd,
		 * we'll always be in the 'else' branch below which
		 * is simpler.
		 */

		ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
		FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
		Tcl_DecrRefCount(norm);
	    }
	    Tcl_DecrRefCount(retVal);
	}
    } else {
	/* 
	 * We already have a cwd cached, but we want to give the
	 * filesystem it is in a chance to check whether that cwd
	 * has changed, or is perhaps no longer accessible.  This
	 * allows an error to be thrown if, say, the permissions on
	 * that directory have changed.
	 */

	Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);

	/* 
	 * If the filesystem couldn't be found, or if no cwd function
	 * exists for this filesystem, then we simply assume the cached
	 * cwd is ok.  If we do call a cwd, we must watch for errors
	 * (if the cwd returns NULL).  This ensures that, say, on Unix
	 * if the permissions of the cwd change, 'pwd' does actually
	 * throw the correct error in Tcl.  (This is tested for in the
	 * test suite on unix).
	 */

	if (fsPtr != NULL) {
	    Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
	    ClientData retCd = NULL;
	    if (proc != NULL) {
		Tcl_Obj *retVal;
		if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
		    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
		    
		    retCd = (*proc2)(tsdPtr->cwdClientData);
		    if (retCd == NULL && interp != NULL) {
			Tcl_AppendResult(interp,
				"error getting working directory name: ",
				Tcl_PosixError(interp), (char *) NULL);
		    }
		    
		    if (retCd == tsdPtr->cwdClientData) {
			goto cdDidNotChange;
		    }
		    

		    /* Looks like a new current directory */


		    retVal = (*fsPtr->internalToNormalizedProc)(retCd);
		    Tcl_IncrRefCount(retVal);
		} else {
		    retVal = (*proc)(interp);
		}
		if (retVal != NULL) {
		    Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, 
							       NULL);

		    /* 
		     * Check whether cwd has changed from the value
		     * previously stored in cwdPathPtr.  Really 'norm'
		     * shouldn't be null, but we are careful.
		     */

		    if (norm == NULL) {
			/* Do nothing */
			if (retCd != NULL) {
			    (*fsPtr->freeInternalRepProc)(retCd);
			}
		    } else if (norm == tsdPtr->cwdPathPtr) {
			goto cdEqual;
		    } else {
			/* 
			 * Note that both 'norm' and
			 * 'tsdPtr->cwdPathPtr' are normalized paths.
			 * Therefore we can be more efficient than
			 * calling 'Tcl_FSEqualPaths', and in addition
			 * avoid a nasty infinite loop bug when trying
			 * to normalize tsdPtr->cwdPathPtr.
			 */

			int len1, len2;
			char *str1, *str2;

			str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
			str2 = Tcl_GetStringFromObj(norm, &len2);
			if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
			    /* 
			     * If the paths were equal, we can be more
			     * efficient and retain the old path object
			     * which will probably already be shared.  In
			     * this case we can simply free the normalized
			     * path we just calculated.
			     */

			  cdEqual:
			    Tcl_DecrRefCount(norm);
			    if (retCd != NULL) {
				(*fsPtr->freeInternalRepProc)(retCd);
			    }
			} else {
			    FsUpdateCwd(norm, retCd);
			    Tcl_DecrRefCount(norm);
			}
		    }
		    Tcl_DecrRefCount(retVal);
		} else {
		    /* The 'cwd' function returned an error; reset the cwd */
		    FsUpdateCwd(NULL, NULL);
		}
	    }
	}
    }
    
  cdDidNotChange:
    if (tsdPtr->cwdPathPtr != NULL) {
	Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
    }
    
    return tsdPtr->cwdPathPtr; 
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSChdir --
 *
 *	This function replaces the library version of chdir().
 *	
 *	The path is normalized and then passed to the filesystem
 *	which claims it.
 *
 * Results:
 *	See chdir() documentation.  If successful, we keep a 
 *	record of the successful path in cwdPathPtr for subsequent 
 *	calls to getcwd.
 *
 * Side effects:
 *	See chdir() documentation.  The global cwdPathPtr may 
 *	change value.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSChdir(pathPtr)
    Tcl_Obj *pathPtr;
{
    Tcl_Filesystem *fsPtr;
    int retVal = -1;
    
    if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
	Tcl_SetErrno(ENOENT);
	return (retVal);
    }
    
    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSChdirProc *proc = fsPtr->chdirProc;
	if (proc != NULL) {
	    /* 
	     * If this fails, an appropriate errno will have
	     * been stored using 'Tcl_SetErrno()'.
	     */

	    retVal = (*proc)(pathPtr);
	} else {

	    /* Fallback on stat-based implementation */


	    Tcl_StatBuf buf;

	    /* 
	     * If the file can be stat'ed and is a directory and is
	     * readable, then we can chdir.  If any of these actions
	     * fail, then 'Tcl_SetErrno()' should automatically have
	     * been called to set an appropriate error code
	     */

	    if ((Tcl_FSStat(pathPtr, &buf) == 0) 
	      && (S_ISDIR(buf.st_mode))
	      && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {

		/* We allow the chdir */


		retVal = 0;
	    }
	}
    } else {
	Tcl_SetErrno(ENOENT);
    }
    
    /* 
     * The cwd changed, or an error was thrown.  If an error was
     * thrown, we can just continue (and that will report the error
     * to the user).  If there was no error we must assume that the
     * cwd was actually changed to the normalized value we
     * calculated above, and we must therefore cache that
     * information.
     */

    /*
     * If the filesystem in question has a getCwdProc, then the
     * correct logic which performs the part below is already part
     * of the Tcl_FSGetCwd() call, so no need to replicate it again.
     * This will have a side effect though.  The private
     * authoritative representation of the current working directory
     * stored in cwdPathPtr in static memory will be out-of-sync
     * with the real OS-maintained value.  The first call to
     * Tcl_FSGetCwd will however recalculate the private copy to
     * match the OS-value so everything will work right.
     * 
     * However, if there is no getCwdProc, then we _must_ update
     * our private storage of the cwd, since this is the only
     * opportunity to do that!
     * 
     * Note: We currently call this block of code irrespective of
     * whether there was a getCwdProc or not, but the code should
     * all in principle work if we only call this block if 
     * fsPtr->getCwdProc == NULL.
     */

    if (retVal == 0) {
	/* 
	 * Note that this normalized path may be different to what
	 * we found above (or at least a different object), if the
	 * filesystem epoch changed recently.  This can actually
	 * happen with scripted documents very easily.  Therefore
	 * we ask for the normalized path again (the correct value
	 * will have been cached as a result of the
	 * Tcl_FSGetFileSystemForPath call above anyway).
	 */

	Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);

	if (normDirName == NULL) {
	    /* Not really true, but what else to do? */
	    Tcl_SetErrno(ENOENT); 
	    return -1;
	}

	if (fsPtr == &tclNativeFilesystem) {
	    /* 
	     * For the native filesystem, we keep a cache of the
	     * native representation of the cwd.  But, we want to do
	     * that for the exact format that is returned by
	     * 'getcwd' (so that we can later compare the two
	     * representations for equality), which might not be
	     * exactly the same char-string as the native
	     * representation of the fully normalized path (e.g. on
	     * Windows there's a forward-slash vs backslash
	     * difference).  Hence we ask for this again here.  On
	     * Unix it might actually be true that we always have
	     * the correct form in the native rep in which case we
	     * could simply use:
	     * 
	     * cd = Tcl_FSGetNativePath(pathPtr);
	     * 
	     * instead.  This should be examined by someone on
	     * Unix.
	     */

	    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
	    ClientData cd;


	    /* Assumption we are using a filesystem version 2 */


	    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc;
	    cd = (*proc2)(tsdPtr->cwdClientData);
	    FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd));
	} else {
	    FsUpdateCwd(normDirName, NULL);
	}
    }
    
    return (retVal);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they are
 *	defined.  The appropriate function for the filesystem to which
 *	pathPtr belongs will be called.
 *	
 *	Note that the native filesystem doesn't actually assume 'pathPtr'
 *	is a path.  Rather it assumes pathPtr is either a path or just
 *	the name (tail) of a file which can be found somewhere in the
 *	environment's loadable path.  This behaviour is not very
 *	compatible with virtual filesystems (and has other problems
 *	documented in the load man-page), so it is advised that full
 *	paths are always used.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.  This may later be
 *	unloaded by passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, 
	       handlePtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code. */
    CONST char *sym1, *sym2;	/* Names of two procedures to look up in
				 * the file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
				/* Where to return the addresses corresponding
				 * to sym1 and sym2. */
    Tcl_LoadHandle *handlePtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    CONST char *symbols[2];
    Tcl_PackageInitProc **procPtrs[2];
    ClientData clientData;
    int res;
    
    /* Initialize the arrays */
    symbols[0] = sym1;
    symbols[1] = sym2;
    procPtrs[0] = proc1Ptr;
    procPtrs[1] = proc2Ptr;
    
    /* Perform the load */
    res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, 
		      handlePtr, &clientData, unloadProcPtr);
    
    /* 
     * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a
     * shared library, we don't keep the loadHandle (for TclpFindSymbol)
     * and the clientData (for the unloadProc) separately.  In fact we
     * effectively throw away the loadHandle and only use the clientData.
     * It just so happens, for the native filesystem only, that these two
     * are identical.
     * 
     * This also means that the signatures Tcl_FSUnloadFileProc and
     * Tcl_FSLoadFileProc are both misleading.
     */

    *handlePtr = (Tcl_LoadHandle) clientData;
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns the
 *	addresses of a number of given procedures within that file, if
 *	they are defined.  The appropriate function for the filesystem to
 *	which pathPtr belongs will be called.
 *	
 *	Note that the native filesystem doesn't actually assume 'pathPtr'
 *	is a path.  Rather it assumes pathPtr is either a path or just
 *	the name (tail) of a file which can be found somewhere in the
 *	environment's loadable path.  This behaviour is not very
 *	compatible with virtual filesystems (and has other problems
 *	documented in the load man-page), so it is advised that full
 *	paths are always used.
 *	
 *	This function is currently private to Tcl.  It may be exported in
 *	the future and its interface fixed (but we should clean up the
 *	loadHandle/clientData confusion at that time -- see the above
 *	comments in Tcl_FSLoadFile for details).  For a public function,
 *	see Tcl_FSLoadFile.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.  This may later be
 *	unloaded by passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, 
	    handlePtr, clientDataPtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code. */
    int symc;                   /* Number of symbols/procPtrs in the
                                 * next two arrays. */
    CONST char *symbols[];	/* Names of procedures to look up in
				 * the file's symbol table. */
    Tcl_PackageInitProc **procPtrs[];
				/* Where to return the addresses
				 * corresponding to symbols[].  */
    Tcl_LoadHandle *handlePtr;	/* Filled with token for shared
                              	 * library information which can be
                              	 * used in TclpFindSymbol. */
    ClientData *clientDataPtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
                                /* Filled with address of Tcl_FSUnloadFileProc
                                 * function which should be used for
                                 * this file. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
	Tcl_Filesystem *copyFsPtr;
	Tcl_Obj *copyToPtr;
	
	if (proc != NULL) {
	    int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
	    if (retVal == TCL_OK) {
		int i;
		if (*handlePtr == NULL) {
		    return TCL_ERROR;
		}
		for (i = 0;i < symc;i++) {
		    if (symbols[i] != NULL) {
			*procPtrs[i] = TclpFindSymbol(interp, *handlePtr, 
						      symbols[i]);
		    }
		}


		/* Copy this across, since both are equal for the native fs */


		*clientDataPtr = (ClientData)*handlePtr;

		return retVal;
	    }
	    if (Tcl_GetErrno() != EXDEV) {
	        return retVal;
	    }
	}

	/* 
	 * The filesystem doesn't support 'load', so we fall back on
	 * the following technique:


	 */
	
	/* First check if it is readable -- and exists! */
	if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
	    Tcl_AppendResult(interp, "couldn't load library \"",
			     Tcl_GetString(pathPtr), "\": ", 
			     Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
	

	/* 

























































	 * Get a temporary filename to use, first to
	 * copy the file into, and then to load. 
	 */

	copyToPtr = TclpTempFileName();
	if (copyToPtr == NULL) {


	    return -1;
	}
	Tcl_IncrRefCount(copyToPtr);
	
	copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
	if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
	    /* 
	     * We already know we can't use Tcl_FSLoadFile from 
	     * this filesystem, and we must avoid a possible
	     * infinite loop.  Try to delete the file we
	     * probably created, and then exit.
	     */

	    Tcl_FSDeleteFile(copyToPtr);
	    Tcl_DecrRefCount(copyToPtr);


	    return -1;
	}
	
	if (TclCrossFilesystemCopy(interp, pathPtr, 
				   copyToPtr) == TCL_OK) {
	    Tcl_LoadHandle newLoadHandle = NULL;
	    ClientData newClientData = NULL;
	    Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
	    FsDivertLoad *tvdlPtr;
	    int retVal;

#if !defined(__WIN32__)
	    /* 
	     * Do we need to set appropriate permissions 
	     * on the file?  This may be required on some
	     * systems.  On Unix we could loop over
	     * the file attributes, and set any that are
	     * called "-permissions" to 0700.  However,
	     * we just do this directly, like this:
	     */
	    

	    Tcl_Obj* perm = Tcl_NewStringObj("0700",-1);
	    Tcl_IncrRefCount(perm);


	    Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);

	    Tcl_DecrRefCount(perm);
#endif
	    
	    /* 
	     * We need to reset the result now, because the cross-
	     * filesystem copy may have stored the number of bytes
	     * in the result
	     */

	    Tcl_ResetResult(interp);
	    
	    retVal = TclLoadFile(interp, copyToPtr, symc, symbols, 
				 procPtrs, &newLoadHandle, 
				 &newClientData,
				 &newUnloadProcPtr);
	    if (retVal != TCL_OK) {
		/* The file didn't load successfully */
		Tcl_FSDeleteFile(copyToPtr);
		Tcl_DecrRefCount(copyToPtr);
		return retVal;
	    }

	    /* 
	     * Try to delete the file immediately -- this is
	     * possible in some OSes, and avoids any worries
	     * about leaving the copy laying around on exit. 
	     */

	    if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
		Tcl_DecrRefCount(copyToPtr);

		/* 
		 * We tell our caller about the real shared
		 * library which was loaded.  Note that this
		 * does mean that the package list maintained
		 * by 'load' will store the original (vfs)
		 * path alongside the temporary load handle
		 * and unload proc ptr.
		 */

		(*handlePtr) = newLoadHandle;
		(*clientDataPtr) = newClientData;
		(*unloadProcPtr) = newUnloadProcPtr;

		return TCL_OK;
	    }

	    /* 
	     * When we unload this file, we need to divert the 
	     * unloading so we can unload and cleanup the 
	     * temporary file correctly.
	     */

	    tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));

	    /* 
	     * Remember three pieces of information.  This allows
	     * us to cleanup the diverted load completely, on
	     * platforms which allow proper unloading of code.
	     */

	    tvdlPtr->loadHandle = newLoadHandle;
	    tvdlPtr->unloadProcPtr = newUnloadProcPtr;

	    if (copyFsPtr != &tclNativeFilesystem) {
		/* copyToPtr is already incremented for this reference */
		tvdlPtr->divertedFile = copyToPtr;

		/* 
		 * This is the filesystem we loaded it into.  Since
		 * we have a reference to 'copyToPtr', we already
		 * have a refCount on this filesystem, so we don't
		 * need to worry about it disappearing on us.
		 */

		tvdlPtr->divertedFilesystem = copyFsPtr;
		tvdlPtr->divertedFileNativeRep = NULL;
	    } else {
		/* We need the native rep */
		tvdlPtr->divertedFileNativeRep = 
		  TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, 
							    copyFsPtr));
		/* 
		 * We don't need or want references to the copied
		 * Tcl_Obj or the filesystem if it is the native
		 * one.
		 */

		tvdlPtr->divertedFile = NULL;
		tvdlPtr->divertedFilesystem = NULL;
		Tcl_DecrRefCount(copyToPtr);
	    }

	    copyToPtr = NULL;
	    (*handlePtr) = newLoadHandle;
	    (*clientDataPtr) = (ClientData)tvdlPtr;
	    (*unloadProcPtr) = &FSUnloadTempFile;

	    return retVal;

	} else {

	    /* Cross-platform copy failed */


	    Tcl_FSDeleteFile(copyToPtr);
	    Tcl_DecrRefCount(copyToPtr);
	    return TCL_ERROR;
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}
/* 
 * This function used to be in the platform specific directories, but it
 * has now been made to work cross-platform
 */

int
TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, 
	     clientDataPtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    CONST char *sym1, *sym2;	/* Names of two procedures to look up in
				 * the file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
				/* Where to return the addresses corresponding
				 * to sym1 and sym2. */
    ClientData *clientDataPtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    Tcl_LoadHandle handle = NULL;
    int res;
    
    res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
    
    if (res != TCL_OK) {
        return res;
    }

    if (handle == NULL) {
	return TCL_ERROR;
    }
    
    *clientDataPtr = (ClientData)handle;
    
    *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
    *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * FSUnloadTempFile --
 *
 *	This function is called when we loaded a library of code via
 *	an intermediate temporary file.  This function ensures
 *	the library is correctly unloaded and the temporary file
 *	is correctly deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The effects of the 'unload' function called, and of course
 *	the temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */
static void 
FSUnloadTempFile(loadHandle)
    Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
			       * to Tcl_FSLoadFile().  The loadHandle is 
			       * a token that represents the loaded 
			       * file. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;

    /* 
     * This test should never trigger, since we give
     * the client data in the function above.
     */

    if (tvdlPtr == NULL) { return; }
    
    /* 
     * Call the real 'unloadfile' proc we actually used. It is very
     * important that we call this first, so that the shared library
     * is actually unloaded by the OS.  Otherwise, the following
     * 'delete' may well fail because the shared library is still in
     * use.
     */

    if (tvdlPtr->unloadProcPtr != NULL) {
	(*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
    }
    
    if (tvdlPtr->divertedFilesystem == NULL) {
	/* 
	 * It was the native filesystem, and we have a special
	 * function available just for this purpose, which we 
	 * know works even at this late stage.
	 */

	TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
	NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);

    } else {
	/* 
	 * Remove the temporary file we created.  Note, we may crash
	 * here because encodings have been taken down already.
	 */

	if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
	    != TCL_OK) {
	    /* 
	     * The above may have failed because the filesystem, or something
	     * it depends upon (e.g. encodings) have been taken down because
	     * Tcl is exiting.
	     * 
	     * We may need to work out how to delete this file more
	     * robustly (or give the filesystem the information it needs
	     * to delete the file more robustly).
	     * 
	     * In particular, one problem might be that the filesystem
	     * cannot extract the information it needs from the above
	     * path object because Tcl's entire filesystem apparatus
	     * (the code in this file) has been finalized, and it
	     * refuses to pass the internal representation to the
	     * filesystem.
	     */
	}
	
	/* 
	 * And free up the allocations.  This will also of course remove
	 * a refCount from the Tcl_Filesystem to which this file belongs,
	 * which could then free up the filesystem if we are exiting.
	 */

	Tcl_DecrRefCount(tvdlPtr->divertedFile);
    }

    ckfree((char*)tvdlPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSLink --
 *
 *	This function replaces the library version of readlink() and
 *	can also be used to make links.  The appropriate function for
 *	the filesystem to which pathPtr belongs will be called.
 *
 * Results:
 *      If toPtr is NULL, then the result is a Tcl_Obj specifying the 
 *      contents of the symbolic link given by 'pathPtr', or NULL if
 *      the symbolic link could not be read.  The result is owned by
 *      the caller, which should call Tcl_DecrRefCount when the result
 *      is no longer needed.
 *      
 *      If toPtr is non-NULL, then the result is toPtr if the link action
 *      was successful, or NULL if not.  In this case the result has no
 *      additional reference count, and need not be freed.  The actual
 *      action to perform is given by the 'linkAction' flags, which is
 *      an or'd combination of:
 *      
 *        TCL_CREATE_SYMBOLIC_LINK
 *        TCL_CREATE_HARD_LINK
 *      
 *      Note that most filesystems will not support linking across
 *      to different filesystems, so this function will usually
 *      fail unless toPtr is in the same FS as pathPtr.
 *      
 * Side effects:
 *	See readlink() documentation.  A new filesystem link 
 *	object may appear
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;		/* Path of file to readlink or link */
    Tcl_Obj *toPtr;		/* NULL or path to be linked to */
    int linkAction;             /* Action to perform */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLinkProc *proc = fsPtr->linkProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, toPtr, linkAction);
	}
    }

    /*
     * If S_IFLNK isn't defined it means that the machine doesn't
     * support symbolic links, so the file can't possibly be a
     * symbolic link.  Generate an EINVAL error, which is what
     * happens on machines that do support symbolic links when
     * you invoke readlink on a file that isn't a symbolic link.
     */

#ifndef S_IFLNK
    errno = EINVAL;
#else
    Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSListVolumes --
 *
 *	Lists the currently mounted volumes.  The chain of functions
 *	that have been "inserted" into the filesystem will be called in
 *	succession; each may return a list of volumes, all of which are
 *	added to the result until all mounted file systems are listed.
 *	
 *	Notice that we assume the lists returned by each filesystem
 *	(if non NULL) have been given a refCount for us already.
 *	However, we are NOT allowed to hang on to the list itself
 *	(it belongs to the filesystem we called).  Therefore we
 *	quite naturally add its contents to the result we are
 *	building, and then decrement the refCount.
 *
 * Results:
 *	The list of volumes, in an object which has refCount 0.
 *
 * Side effects:
 *	None
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSListVolumes(void)
{
    FilesystemRecord *fsRecPtr;
    Tcl_Obj *resultPtr = Tcl_NewObj();
    
    /*
     * Call each of the "listVolumes" function in succession.
     * A non-NULL return value indicates the particular function has
     * succeeded.  We call all the functions registered, since we want
     * a list of all drives from all filesystems.
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
	Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
	if (proc != NULL) {
	    Tcl_Obj *thisFsVolumes = (*proc)();
	    if (thisFsVolumes != NULL) {
		Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
		Tcl_DecrRefCount(thisFsVolumes);
	    }
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }
    
    return resultPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * FsListMounts --
 *
 *	List all mounts within the given directory, which match the
 *	given pattern.
 *
 * Results:
 *	The list of mounts, in a list object which has refCount 0, or
 *	NULL if we didn't even find any filesystems to try to list
 *	mounts.
 *
 * Side effects:
 *	None
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj*
FsListMounts(pathPtr, pattern)
    Tcl_Obj *pathPtr;	        /* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
{
    FilesystemRecord *fsRecPtr;
    Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
    Tcl_Obj *resultPtr = NULL;
    
    /*
     * Call each of the "matchInDirectory" functions in succession, with
     * the specific type information 'mountsOnly'.  A non-NULL return
     * value indicates the particular function has succeeded.  We call
     * all the functions registered, since we want a list from each
     * filesystems.
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
	if (fsRecPtr != &nativeFilesystemRecord) {
	    Tcl_FSMatchInDirectoryProc *proc = 
	                          fsRecPtr->fsPtr->matchInDirectoryProc;
	    if (proc != NULL) {
		if (resultPtr == NULL) {
		    resultPtr = Tcl_NewObj();
		}
		(*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
	    }
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }
    
    return resultPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSSplitPath --
 *
 *      This function takes the given Tcl_Obj, which should be a valid
 *      path, and returns a Tcl List object containing each segment of
 *      that path as an element.
 *
 * Results:
 *      Returns list object with refCount of zero.  If the passed in
 *      lenPtr is non-NULL, we use it to return the number of elements
 *      in the returned list.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
Tcl_FSSplitPath(pathPtr, lenPtr)
    Tcl_Obj *pathPtr;		/* Path to split. */
    int *lenPtr;		/* int to store number of path elements. */
{
    Tcl_Obj *result = NULL;  /* Needed only to prevent gcc warnings. */
    Tcl_Filesystem *fsPtr;
    char separator = '/';
    int driveNameLength;
    char *p;
    
    /*
     * Perform platform specific splitting. 
     */

    if (TclFSGetPathType(pathPtr, &fsPtr, &driveNameLength) 
	== TCL_PATH_ABSOLUTE) {
	if (fsPtr == &tclNativeFilesystem) {
	    return TclpNativeSplitPath(pathPtr, lenPtr);
	}
    } else {
	return TclpNativeSplitPath(pathPtr, lenPtr);
    }


    /* We assume separators are single characters */


    if (fsPtr->filesystemSeparatorProc != NULL) {
	Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
	if (sep != NULL) {
	    Tcl_IncrRefCount(sep);
	    separator = Tcl_GetString(sep)[0];
	    Tcl_DecrRefCount(sep);
	}
    }
    
    /* 
     * Place the drive name as first element of the
     * result list.  The drive name may contain strange
     * characters, like colons and multiple forward slashes
     * (for example 'ftp://' is a valid vfs drive name)
     */

    result = Tcl_NewObj();
    p = Tcl_GetString(pathPtr);
    Tcl_ListObjAppendElement(NULL, result, 
			     Tcl_NewStringObj(p, driveNameLength));
    p+= driveNameLength;
    			

    /* Add the remaining path elements to the list */


    for (;;) {
	char *elementStart = p;
	int length;
	while ((*p != '\0') && (*p != separator)) {
	    p++;
	}
	length = p - elementStart;







>
|
|
|
|
|
|
|

>



|
|
|
|

|


|
|
<

>







|
|
|
<
|
|

>

>
|
|
|
|
|
|
|
<

>







|






|



|
>
|
>
>






|
|
>
|
|
|
|

>








|
|
<
|
|
|
|

>


>



|

|
|
|
|

>
|

















|




|
|








|
|
|


|
|
<


|
<



>






|


|

|




|
|
|

>


>
|
>
>

>
|
|
|
|
|

>
|
<
|
>
|
>
>






|
|
|
|
|
<
|
|



|
|
|
<
|
|
|
|
|
|
|
|
<
|
|
|
|
<



|
|
|
|
<
|
|


>

>


|


>

|
|
|
|
<
|
|
|
<
|
|
|
|
<
|
<
|
<

>



>
|
>
>







|
|







|
|
|
|
|
|
|
|
|
|
<
|


|
|


|
|





|
|



|
|




|

|

|
|





|





|

|
|
|
|
|
|
|
|
|
<
|



>










|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|


|
|


|
|





|




|
|
|
|

|
|
|
|
|

|

|
|
|
|






|







|

|
|


>
>
|
>
>

>
|


|


>
|
|
|
>
>

|
<


|
|


|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|

>


>
>
|


|


|
|
|
<
|

>


>
>
|

|
|
<







|
|
<
|
|
<
|

|
>


>
>
|
>


|
|
|
|
<

>

|
|
<
<
|






>
|
|
|
|

>


>
|
|
<
|
|
|
<

>



>


>
|
|
<
|

>
|

|
|
|
|

>







|
|
|
|
|

>




|
|
|
|
|
|
<

>







|

>

>

>
|
>
>






|

|
|
|

>

|
|



|
|




|

|

|
|



|

|

|





|

|










|
|
|
<





|
|



|

|
|
|
<


>
|
|
|

>

|
|
|
|
|
|
<

>



|

|
|
|
|

>


>

|
|
|

>

|
|



|
|
|
|
|
|
|
|
|
|
<


|
|
|
|
|

>











|
|
|


|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
|
|
|

|
<








|








>

|
|
|
|
|

>













|
|
|
|
|
|
|
|
<
|
|















|

|
|
|
|














|








|
|


|
|
<









|





|

|
|
|
|
<





|
|









|








|
|
|


|
|
|







|




|




|

|


|
|







>
|
>
>








|
|
|
<
|
|

>


|
|
|
|
>
|
>
>







2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680

2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692

2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705

2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755

2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815

2816
2817
2818

2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859

2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875

2876
2877
2878
2879
2880
2881
2882
2883

2884
2885
2886
2887
2888
2889
2890
2891

2892
2893
2894
2895

2896
2897
2898
2899
2900
2901
2902

2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920

2921
2922
2923

2924
2925
2926
2927

2928

2929

2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964

2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017

3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041

3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124

3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207

3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218

3219
3220
3221
3222
3223
3224
3225
3226
3227

3228
3229

3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245

3246
3247
3248
3249
3250


3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269

3270
3271
3272

3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283

3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318

3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397

3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412

3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427

3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465

3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494

3495
3496
3497
3498
3499

3500
3501
3502
3503
3504
3505
3506
3507
3508
3509

3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556

3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608

3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629

3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708

3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
		    }
		} else {
		    retVal = (*proc)(interp);
		}
	    }
	    fsRecPtr = fsRecPtr->nextPtr;
	}

	/*
	 * Now the 'cwd' may NOT be normalized, at least on some platforms.
	 * For the sake of efficiency, we want a completely normalized cwd at
	 * all times.
	 *
	 * Finally, if retVal is NULL, we do not have a cwd, which could be
	 * problematic.
	 */

	if (retVal != NULL) {
	    Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
	    if (norm != NULL) {
		/*
		 * We found a cwd, which is now in our global storage.  We
		 * must make a copy. Norm already has a refCount of 1.
		 *
		 * Threading issue: note that multiple threads at system
		 * startup could in principle call this procedure
		 * simultaneously.  They will therefore each set the
		 * cwdPathPtr independently.  That behaviour is a bit
		 * peculiar, but should be fine.  Once we have a cwd, we'll
		 * always be in the 'else' branch below which is simpler.

		 */

		ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
		FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
		Tcl_DecrRefCount(norm);
	    }
	    Tcl_DecrRefCount(retVal);
	}
    } else {
	/*
	 * We already have a cwd cached, but we want to give the filesystem it
	 * is in a chance to check whether that cwd has changed, or is perhaps

	 * no longer accessible.  This allows an error to be thrown if, say,
	 * the permissions on that directory have changed.
	 */

	Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);

	/*
	 * If the filesystem couldn't be found, or if no cwd function exists
	 * for this filesystem, then we simply assume the cached cwd is ok.
	 * If we do call a cwd, we must watch for errors (if the cwd returns
	 * NULL).  This ensures that, say, on Unix if the permissions of the
	 * cwd change, 'pwd' does actually throw the correct error in Tcl.
	 * (This is tested for in the test suite on unix).

	 */

	if (fsPtr != NULL) {
	    Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
	    ClientData retCd = NULL;
	    if (proc != NULL) {
		Tcl_Obj *retVal;
		if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
		    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;

		    retCd = (*proc2)(tsdPtr->cwdClientData);
		    if (retCd == NULL && interp != NULL) {
			Tcl_AppendResult(interp,
				"error getting working directory name: ",
				Tcl_PosixError(interp), (char *) NULL);
		    }

		    if (retCd == tsdPtr->cwdClientData) {
			goto cdDidNotChange;
		    }

		    /*
		     * Looks like a new current directory.
		     */

		    retVal = (*fsPtr->internalToNormalizedProc)(retCd);
		    Tcl_IncrRefCount(retVal);
		} else {
		    retVal = (*proc)(interp);
		}
		if (retVal != NULL) {
		    Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp,
			    retVal, NULL);

		    /*
		     * Check whether cwd has changed from the value previously
		     * stored in cwdPathPtr.  Really 'norm' shouldn't be null,
		     * but we are careful.
		     */

		    if (norm == NULL) {
			/* Do nothing */
			if (retCd != NULL) {
			    (*fsPtr->freeInternalRepProc)(retCd);
			}
		    } else if (norm == tsdPtr->cwdPathPtr) {
			goto cdEqual;
		    } else {
			/*
			 * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are

			 * normalized paths.  Therefore we can be more
			 * efficient than calling 'Tcl_FSEqualPaths', and in
			 * addition avoid a nasty infinite loop bug when
			 * trying to normalize tsdPtr->cwdPathPtr.
			 */

			int len1, len2;
			char *str1, *str2;

			str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
			str2 = Tcl_GetStringFromObj(norm, &len2);
			if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
			    /*
			     * If the paths were equal, we can be more
			     * efficient and retain the old path object which
			     * will probably already be shared.  In this case
			     * we can simply free the normalized path we just
			     * calculated.
			     */

			cdEqual:
			    Tcl_DecrRefCount(norm);
			    if (retCd != NULL) {
				(*fsPtr->freeInternalRepProc)(retCd);
			    }
			} else {
			    FsUpdateCwd(norm, retCd);
			    Tcl_DecrRefCount(norm);
			}
		    }
		    Tcl_DecrRefCount(retVal);
		} else {
		    /* The 'cwd' function returned an error; reset the cwd */
		    FsUpdateCwd(NULL, NULL);
		}
	    }
	}
    }

  cdDidNotChange:
    if (tsdPtr->cwdPathPtr != NULL) {
	Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
    }

    return tsdPtr->cwdPathPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSChdir --
 *
 *	This function replaces the library version of chdir().
 *
 *	The path is normalized and then passed to the filesystem which claims
 *	it.
 *
 * Results:
 *	See chdir() documentation.  If successful, we keep a record of the
 *	successful path in cwdPathPtr for subsequent calls to getcwd.

 *
 * Side effects:
 *	See chdir() documentation.  The global cwdPathPtr may change value.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSChdir(pathPtr)
    Tcl_Obj *pathPtr;
{
    Tcl_Filesystem *fsPtr;
    int retVal = -1;

    if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
	Tcl_SetErrno(ENOENT);
	return retVal;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSChdirProc *proc = fsPtr->chdirProc;
	if (proc != NULL) {
	    /*
	     * If this fails, an appropriate errno will have been stored using
	     * 'Tcl_SetErrno()'.
	     */

	    retVal = (*proc)(pathPtr);
	} else {
	    /*
	     * Fallback on stat-based implementation.
	     */

	    Tcl_StatBuf buf;

	    /*
	     * If the file can be stat'ed and is a directory and is readable,
	     * then we can chdir.  If any of these actions fail, then
	     * 'Tcl_SetErrno()' should automatically have been called to set
	     * an appropriate error code
	     */

	    if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))

		    && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
		/*
		 * We allow the chdir.
		 */

		retVal = 0;
	    }
	}
    } else {
	Tcl_SetErrno(ENOENT);
    }

    /*
     * The cwd changed, or an error was thrown.  If an error was thrown, we
     * can just continue (and that will report the error to the user).  If
     * there was no error we must assume that the cwd was actually changed to

     * the normalized value we calculated above, and we must therefore cache
     * that information.
     */

    /*
     * If the filesystem in question has a getCwdProc, then the correct logic
     * which performs the part below is already part of the Tcl_FSGetCwd()
     * call, so no need to replicate it again.  This will have a side effect

     * though.  The private authoritative representation of the current
     * working directory stored in cwdPathPtr in static memory will be
     * out-of-sync with the real OS-maintained value.  The first call to
     * Tcl_FSGetCwd will however recalculate the private copy to match the
     * OS-value so everything will work right.
     *
     * However, if there is no getCwdProc, then we _must_ update our private
     * storage of the cwd, since this is the only opportunity to do that!

     *
     * Note: We currently call this block of code irrespective of whether
     * there was a getCwdProc or not, but the code should all in principle
     * work if we only call this block if fsPtr->getCwdProc == NULL.

     */

    if (retVal == 0) {
	/*
	 * Note that this normalized path may be different to what we found
	 * above (or at least a different object), if the filesystem epoch
	 * changed recently.  This can actually happen with scripted documents

	 * very easily.  Therefore we ask for the normalized path again (the
	 * correct value will have been cached as a result of the
	 * Tcl_FSGetFileSystemForPath call above anyway).
	 */

	Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);

	if (normDirName == NULL) {
	    /* Not really true, but what else to do? */
	    Tcl_SetErrno(ENOENT);
	    return -1;
	}

	if (fsPtr == &tclNativeFilesystem) {
	    /*
	     * For the native filesystem, we keep a cache of the native
	     * representation of the cwd.  But, we want to do that for the
	     * exact format that is returned by 'getcwd' (so that we can later

	     * compare the two representations for equality), which might not
	     * be exactly the same char-string as the native representation of
	     * the fully normalized path (e.g. on Windows there's a

	     * forward-slash vs backslash difference).  Hence we ask for this
	     * again here.  On Unix it might actually be true that we always
	     * have the correct form in the native rep in which case we could
	     * simply use:

	     *		cd = Tcl_FSGetNativePath(pathPtr);

	     * instead.  This should be examined by someone on Unix.

	     */

	    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
	    ClientData cd;

	    /*
	     * Assumption we are using a filesystem version 2.
	     */

	    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc;
	    cd = (*proc2)(tsdPtr->cwdClientData);
	    FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd));
	} else {
	    FsUpdateCwd(normDirName, NULL);
	}
    }

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns the
 *	addresses of two procedures within that file, if they are defined.
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 *	Note that the native filesystem doesn't actually assume 'pathPtr' is a
 *	path.  Rather it assumes pathPtr is either a path or just the name
 *	(tail) of a file which can be found somewhere in the environment's
 *	loadable path.  This behaviour is not very compatible with virtual
 *	filesystems (and has other problems documented in the load man-page),

 *	so it is advised that full paths are always used.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.  This may later be unloaded by
 *	passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
	handlePtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code. */
    CONST char *sym1, *sym2;	/* Names of two procedures to look up in the
				 * file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
				/* Where to return the addresses corresponding
				 * to sym1 and sym2. */
    Tcl_LoadHandle *handlePtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    CONST char *symbols[2];
    Tcl_PackageInitProc **procPtrs[2];
    ClientData clientData;
    int res;

    /* Initialize the arrays */
    symbols[0] = sym1;
    symbols[1] = sym2;
    procPtrs[0] = proc1Ptr;
    procPtrs[1] = proc2Ptr;

    /* Perform the load */
    res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs,
	    handlePtr, &clientData, unloadProcPtr);

    /*
     * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared
     * library, we don't keep the loadHandle (for TclpFindSymbol) and the
     * clientData (for the unloadProc) separately.  In fact we effectively
     * throw away the loadHandle and only use the clientData.  It just so
     * happens, for the native filesystem only, that these two are identical.

     *
     * This also means that the signatures Tcl_FSUnloadFileProc and
     * Tcl_FSLoadFileProc are both misleading.
     */

    *handlePtr = (Tcl_LoadHandle) clientData;
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns the
 *	addresses of a number of given procedures within that file, if they
 *	are defined.  The appropriate function for the filesystem to which
 *	pathPtr belongs will be called.
 *
 *	Note that the native filesystem doesn't actually assume 'pathPtr' is a
 *	path.  Rather it assumes pathPtr is either a path or just the name
 *	(tail) of a file which can be found somewhere in the environment's
 *	loadable path.  This behaviour is not very compatible with virtual
 *	filesystems (and has other problems documented in the load man-page),

 *	so it is advised that full paths are always used.
 *
 *	This function is currently private to Tcl.  It may be exported in the
 *	future and its interface fixed (but we should clean up the
 *	loadHandle/clientData confusion at that time -- see the above comments
 *	in Tcl_FSLoadFile for details).  For a public function, see
 *	Tcl_FSLoadFile.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.  This may later be unloaded by
 *	passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
	    handlePtr, clientDataPtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code. */
    int symc;			/* Number of symbols/procPtrs in the next two
				 * arrays. */
    CONST char *symbols[];	/* Names of procedures to look up in the
				 * file's symbol table. */
    Tcl_PackageInitProc **procPtrs[];
				/* Where to return the addresses corresponding
				 * to symbols[].  */
    Tcl_LoadHandle *handlePtr;	/* Filled with token for shared library
				 * information which can be used in
				 * TclpFindSymbol. */
    ClientData *clientDataPtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
	Tcl_Filesystem *copyFsPtr;
	Tcl_Obj *copyToPtr;

	if (proc != NULL) {
	    int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
	    if (retVal == TCL_OK) {
		int i;
		if (*handlePtr == NULL) {
		    return TCL_ERROR;
		}
		for (i=0 ; i<symc ; i++) {
		    if (symbols[i] != NULL) {
			*procPtrs[i] = TclpFindSymbol(interp, *handlePtr,
				symbols[i]);
		    }
		}

		/*
		 * Copy this across, since both are equal for the native fs.
		 */

		*clientDataPtr = (ClientData)*handlePtr;
		Tcl_ResetResult(interp);
		return TCL_OK;
	    }
	    if (Tcl_GetErrno() != EXDEV) {
		return retVal;
	    }
	}

	/*
	 * The filesystem doesn't support 'load', so we fall back on the
	 * following technique:
	 *
	 * First check if it is readable -- and exists!
	 */


	if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
	    Tcl_AppendResult(interp, "couldn't load library \"",
		    Tcl_GetString(pathPtr), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}

#ifdef TCL_LOAD_FROM_MEMORY
	/*
	 * The platform supports loading code from memory, so ask for a buffer
	 * of the appropriate size, read the file into it and load the code
	 * from the buffer:
	 */

	do {
	    int ret, size;
	    void *buffer;
	    Tcl_StatBuf statBuf;
	    Tcl_Channel data;

	    ret = Tcl_FSStat(pathPtr, &statBuf);
	    if (ret < 0) {
		break;
	    }
	    size = (int) statBuf.st_size;

	    /*
	     * Tcl_Read takes an int: check that file size isn't wide.
	     */

	    if (size != (Tcl_WideInt) statBuf.st_size) {
		break;
	    }
	    data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666);
	    if (!data) {
		break;
	    }
	    buffer = TclpLoadMemoryGetBuffer(interp, size);
	    if (!buffer) {
		Tcl_Close(interp, data);
		break;
	    }
	    Tcl_SetChannelOption(interp, data, "-translation", "binary");
	    ret = Tcl_Read(data, buffer, size);
	    Tcl_Close(interp, data);
	    ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
		    unloadProcPtr);
	    if (ret == TCL_OK) {
		int i;
		if (*handlePtr == NULL) {
		    break;
		}
		for (i = 0;i < symc;i++) {
		    if (symbols[i] != NULL) {
			*procPtrs[i] = TclpFindSymbol(interp, *handlePtr,
				symbols[i]);
		    }
		}
		*clientDataPtr = (ClientData) *handlePtr;
		return TCL_OK;
	    }
	} while (0);
	Tcl_ResetResult(interp);
#endif

	/*
	 * Get a temporary filename to use, first to copy the file into, and
	 * then to load.
	 */

	copyToPtr = TclpTempFileName();
	if (copyToPtr == NULL) {
	    Tcl_AppendResult(interp, "couldn't create temporary file: ",
		    Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
	Tcl_IncrRefCount(copyToPtr);

	copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
	if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
	    /*
	     * We already know we can't use Tcl_FSLoadFile from this
	     * filesystem, and we must avoid a possible infinite loop.  Try to

	     * delete the file we probably created, and then exit.
	     */

	    Tcl_FSDeleteFile(copyToPtr);
	    Tcl_DecrRefCount(copyToPtr);
	    Tcl_AppendResult(interp, "couldn't load from current filesystem",
		    (char *) NULL);
	    return TCL_ERROR;
	}

	if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) {

	    Tcl_LoadHandle newLoadHandle = NULL;
	    ClientData newClientData = NULL;
	    Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
	    FsDivertLoad *tvdlPtr;
	    int retVal;

#if !defined(__WIN32__)
	    /*
	     * Do we need to set appropriate permissions on the file?  This

	     * may be required on some systems.  On Unix we could loop over
	     * the file attributes, and set any that are called "-permissions"

	     * to 0700.  However, we just do this directly, like this:
	     */

	    int index;
	    Tcl_Obj* perm = Tcl_NewStringObj("0700",-1);
	    Tcl_IncrRefCount(perm);
	    if (TclFSFileAttrIndex(copyToPtr, "-permissions",
		    &index) == TCL_OK) {
		Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm);
	    }
	    Tcl_DecrRefCount(perm);
#endif

	    /*
	     * We need to reset the result now, because the cross- filesystem
	     * copy may have stored the number of bytes in the result.

	     */

	    Tcl_ResetResult(interp);

	    retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs,


		    &newLoadHandle, &newClientData, &newUnloadProcPtr);
	    if (retVal != TCL_OK) {
		/* The file didn't load successfully */
		Tcl_FSDeleteFile(copyToPtr);
		Tcl_DecrRefCount(copyToPtr);
		return retVal;
	    }

	    /*
	     * Try to delete the file immediately - this is possible in some
	     * OSes, and avoids any worries about leaving the copy laying
	     * around on exit.
	     */

	    if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
		Tcl_DecrRefCount(copyToPtr);

		/*
		 * We tell our caller about the real shared library which was

		 * loaded.  Note that this does mean that the package list
		 * maintained by 'load' will store the original (vfs) path
		 * alongside the temporary load handle and unload proc ptr.

		 */

		(*handlePtr) = newLoadHandle;
		(*clientDataPtr) = newClientData;
		(*unloadProcPtr) = newUnloadProcPtr;
		Tcl_ResetResult(interp);
		return TCL_OK;
	    }

	    /*
	     * When we unload this file, we need to divert the unloading so we

	     * can unload and cleanup the temporary file correctly.
	     */

	    tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad));

	    /*
	     * Remember three pieces of information.  This allows us to
	     * cleanup the diverted load completely, on platforms which allow
	     * proper unloading of code.
	     */

	    tvdlPtr->loadHandle = newLoadHandle;
	    tvdlPtr->unloadProcPtr = newUnloadProcPtr;

	    if (copyFsPtr != &tclNativeFilesystem) {
		/* copyToPtr is already incremented for this reference */
		tvdlPtr->divertedFile = copyToPtr;

		/*
		 * This is the filesystem we loaded it into.  Since we have a
		 * reference to 'copyToPtr', we already have a refCount on
		 * this filesystem, so we don't need to worry about it
		 * disappearing on us.
		 */

		tvdlPtr->divertedFilesystem = copyFsPtr;
		tvdlPtr->divertedFileNativeRep = NULL;
	    } else {
		/* We need the native rep */
		tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep(
			Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));

		/*
		 * We don't need or want references to the copied Tcl_Obj or
		 * the filesystem if it is the native one.

		 */

		tvdlPtr->divertedFile = NULL;
		tvdlPtr->divertedFilesystem = NULL;
		Tcl_DecrRefCount(copyToPtr);
	    }

	    copyToPtr = NULL;
	    (*handlePtr) = newLoadHandle;
	    (*clientDataPtr) = (ClientData) tvdlPtr;
	    (*unloadProcPtr) = &FSUnloadTempFile;
	    Tcl_ResetResult(interp);
	    return retVal;

	} else {
	    /*
	     * Cross-platform copy failed.
	     */

	    Tcl_FSDeleteFile(copyToPtr);
	    Tcl_DecrRefCount(copyToPtr);
	    return TCL_ERROR;
	}
    }
    Tcl_SetErrno(ENOENT);
    return TCL_ERROR;
}
/*
 * This function used to be in the platform specific directories, but it has
 * now been made to work cross-platform
 */

int
TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
	clientDataPtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    CONST char *sym1, *sym2;	/* Names of two procedures to look up in the
				 * file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
				/* Where to return the addresses corresponding
				 * to sym1 and sym2. */
    ClientData *clientDataPtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_LoadHandle handle = NULL;
    int res;

    res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);

    if (res != TCL_OK) {
	return res;
    }

    if (handle == NULL) {
	return TCL_ERROR;
    }

    *clientDataPtr = (ClientData)handle;

    *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
    *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * FSUnloadTempFile --
 *
 *	This function is called when we loaded a library of code via an
 *	intermediate temporary file.  This function ensures the library is
 *	correctly unloaded and the temporary file is correctly deleted.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The effects of the 'unload' function called, and of course the
 *	temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */
static void
FSUnloadTempFile(loadHandle)
    Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to
				* Tcl_FSLoadFile().  The loadHandle is a token
				* that represents the loaded file. */

{
    FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;

    /*
     * This test should never trigger, since we give the client data in the
     * function above.
     */

    if (tvdlPtr == NULL) { return; }

    /*
     * Call the real 'unloadfile' proc we actually used. It is very important
     * that we call this first, so that the shared library is actually
     * unloaded by the OS.  Otherwise, the following 'delete' may well fail
     * because the shared library is still in use.

     */

    if (tvdlPtr->unloadProcPtr != NULL) {
	(*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
    }

    if (tvdlPtr->divertedFilesystem == NULL) {
	/*
	 * It was the native filesystem, and we have a special function
	 * available just for this purpose, which we know works even at this
	 * late stage.
	 */

	TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
	NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);

    } else {
	/*
	 * Remove the temporary file we created.  Note, we may crash here
	 * because encodings have been taken down already.
	 */

	if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
		!= TCL_OK) {
	    /*
	     * The above may have failed because the filesystem, or something
	     * it depends upon (e.g. encodings) have been taken down because
	     * Tcl is exiting.
	     *
	     * We may need to work out how to delete this file more robustly
	     * (or give the filesystem the information it needs to delete the
	     * file more robustly).
	     *
	     * In particular, one problem might be that the filesystem cannot
	     * extract the information it needs from the above path object
	     * because Tcl's entire filesystem apparatus (the code in this
	     * file) has been finalized, and it refuses to pass the internal
	     * representation to the filesystem.

	     */
	}

	/*
	 * And free up the allocations.  This will also of course remove a
	 * refCount from the Tcl_Filesystem to which this file belongs, which
	 * could then free up the filesystem if we are exiting.
	 */

	Tcl_DecrRefCount(tvdlPtr->divertedFile);
    }

    ckfree((char*)tvdlPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSLink --
 *
 *	This function replaces the library version of readlink() and can also
 *	be used to make links.  The appropriate function for the filesystem to
 *	which pathPtr belongs will be called.
 *
 * Results:
 *	If toPtr is NULL, then the result is a Tcl_Obj specifying the contents
 *	of the symbolic link given by 'pathPtr', or NULL if the symbolic link
 *	could not be read.  The result is owned by the caller, which should
 *	call Tcl_DecrRefCount when the result is no longer needed.

 *
 *	If toPtr is non-NULL, then the result is toPtr if the link action was
 *	successful, or NULL if not.  In this case the result has no additional
 *	reference count, and need not be freed.  The actual action to perform
 *	is given by the 'linkAction' flags, which is an or'd combination of:

 *
 *		TCL_CREATE_SYMBOLIC_LINK
 *		TCL_CREATE_HARD_LINK
 *
 *	Note that most filesystems will not support linking across to
 *	different filesystems, so this function will usually fail unless toPtr
 *	is in the same FS as pathPtr.
 *
 * Side effects:
 *	See readlink() documentation.  A new filesystem link object may appear

 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;		/* Path of file to readlink or link */
    Tcl_Obj *toPtr;		/* NULL or path to be linked to */
    int linkAction;		/* Action to perform */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLinkProc *proc = fsPtr->linkProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, toPtr, linkAction);
	}
    }

    /*
     * If S_IFLNK isn't defined it means that the machine doesn't support
     * symbolic links, so the file can't possibly be a symbolic link.
     * Generate an EINVAL error, which is what happens on machines that do
     * support symbolic links when you invoke readlink on a file that isn't a
     * symbolic link.
     */

#ifndef S_IFLNK
    errno = EINVAL;
#else
    Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSListVolumes --
 *
 *	Lists the currently mounted volumes.  The chain of functions that have
 *	been "inserted" into the filesystem will be called in succession; each
 *	may return a list of volumes, all of which are added to the result
 *	until all mounted file systems are listed.
 *
 *	Notice that we assume the lists returned by each filesystem (if non
 *	NULL) have been given a refCount for us already.  However, we are NOT
 *	allowed to hang on to the list itself (it belongs to the filesystem we

 *	called).  Therefore we quite naturally add its contents to the result
 *	we are building, and then decrement the refCount.
 *
 * Results:
 *	The list of volumes, in an object which has refCount 0.
 *
 * Side effects:
 *	None
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSListVolumes(void)
{
    FilesystemRecord *fsRecPtr;
    Tcl_Obj *resultPtr = Tcl_NewObj();

    /*
     * Call each of the "listVolumes" function in succession.  A non-NULL
     * return value indicates the particular function has succeeded.  We call
     * all the functions registered, since we want a list of all drives from
     * all filesystems.
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
	Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
	if (proc != NULL) {
	    Tcl_Obj *thisFsVolumes = (*proc)();
	    if (thisFsVolumes != NULL) {
		Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
		Tcl_DecrRefCount(thisFsVolumes);
	    }
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return resultPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * FsListMounts --
 *
 *	List all mounts within the given directory, which match the given
 *	pattern.
 *
 * Results:
 *	The list of mounts, in a list object which has refCount 0, or NULL if
 *	we didn't even find any filesystems to try to list mounts.

 *
 * Side effects:
 *	None
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj*
FsListMounts(pathPtr, pattern)
    Tcl_Obj *pathPtr;		/* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
{
    FilesystemRecord *fsRecPtr;
    Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
    Tcl_Obj *resultPtr = NULL;

    /*
     * Call each of the "matchInDirectory" functions in succession, with the
     * specific type information 'mountsOnly'.  A non-NULL return value
     * indicates the particular function has succeeded.  We call all the
     * functions registered, since we want a list from each filesystems.

     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
	if (fsRecPtr != &nativeFilesystemRecord) {
	    Tcl_FSMatchInDirectoryProc *proc =
		    fsRecPtr->fsPtr->matchInDirectoryProc;
	    if (proc != NULL) {
		if (resultPtr == NULL) {
		    resultPtr = Tcl_NewObj();
		}
		(*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
	    }
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return resultPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSSplitPath --
 *
 *	This function takes the given Tcl_Obj, which should be a valid path,
 *	and returns a Tcl List object containing each segment of that path as
 *	an element.
 *
 * Results:
 *	Returns list object with refCount of zero.  If the passed in lenPtr is
 *	non-NULL, we use it to return the number of elements in the returned
 *	list.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSSplitPath(pathPtr, lenPtr)
    Tcl_Obj *pathPtr;		/* Path to split. */
    int *lenPtr;		/* int to store number of path elements. */
{
    Tcl_Obj *result = NULL;	/* Needed only to prevent gcc warnings. */
    Tcl_Filesystem *fsPtr;
    char separator = '/';
    int driveNameLength;
    char *p;

    /*
     * Perform platform specific splitting.
     */

    if (TclFSGetPathType(pathPtr, &fsPtr,
	    &driveNameLength) == TCL_PATH_ABSOLUTE) {
	if (fsPtr == &tclNativeFilesystem) {
	    return TclpNativeSplitPath(pathPtr, lenPtr);
	}
    } else {
	return TclpNativeSplitPath(pathPtr, lenPtr);
    }

    /*
     * We assume separators are single characters.
     */

    if (fsPtr->filesystemSeparatorProc != NULL) {
	Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
	if (sep != NULL) {
	    Tcl_IncrRefCount(sep);
	    separator = Tcl_GetString(sep)[0];
	    Tcl_DecrRefCount(sep);
	}
    }

    /*
     * Place the drive name as first element of the result list.  The drive

     * name may contain strange characters, like colons and multiple forward
     * slashes (for example 'ftp://' is a valid vfs drive name)
     */

    result = Tcl_NewObj();
    p = Tcl_GetString(pathPtr);
    Tcl_ListObjAppendElement(NULL, result,
	    Tcl_NewStringObj(p, driveNameLength));
    p += driveNameLength;

    /*
     * Add the remaining path elements to the list.
     */

    for (;;) {
	char *elementStart = p;
	int length;
	while ((*p != '\0') && (*p != separator)) {
	    p++;
	}
	length = p - elementStart;
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609

3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627

3628

3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643

3644
3645
3646
3647
3648
3649
3650
	    }
	    Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
	if (*p++ == '\0') {
	    break;
	}
    }
			     
    /*
     * Compute the number of elements in the result.
     */

    if (lenPtr != NULL) {
	Tcl_ListObjLength(NULL, result, lenPtr);
    }
    return result;
}

/* Simple helper function */
Tcl_Obj* 
TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
    Tcl_Filesystem *fromFilesystem;
    ClientData clientData;
    FilesystemRecord **fsRecPtrPtr;
{
    FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();

    while (fsRecPtr != NULL) {
	if (fsRecPtr->fsPtr == fromFilesystem) {
	    *fsRecPtrPtr = fsRecPtr;
	    break;
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }
    
    if ((fsRecPtr != NULL) 
      && (fromFilesystem->internalToNormalizedProc != NULL)) {
	return (*fromFilesystem->internalToNormalizedProc)(clientData);
    } else {
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetPathType --
 *
 *	Helper function used by FSGetPathType.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.  The filesystem reference will
 *	be set if and only if it is non-NULL and the function's 
 *	return value is TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
    Tcl_Obj *pathPtr;                   /* Path to determine type for */
    Tcl_Filesystem **filesystemPtrPtr;  /* If absolute path and this is
                                         * non-NULL, then set to the
                                         * filesystem which claims this
                                         * path */  
    int *driveNameLengthPtr;            /* If the path is absolute, and 
                                         * this is non-NULL, then set to
                                         * the length of the driveName */
    Tcl_Obj **driveNameRef;             /* If the path is absolute, and
                                         * this is non-NULL, then set to
                                         * the name of the drive,
                                         * network-volume which contains
                                         * the path, already with a
                                         * refCount for the caller.  */
{
    int pathLen;
    char *path;
    Tcl_PathType type;
    
    path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, 
				  driveNameLengthPtr, driveNameRef);
    
    if (type != TCL_PATH_ABSOLUTE) {
	type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, 
				     driveNameRef);
	if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
	    *filesystemPtrPtr = &tclNativeFilesystem;
	}
    }
    return type;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSNonnativePathType --
 *
 *	Helper function used by TclGetPathType.  Its purpose is to
 *	check whether the given path starts with a string which
 *	corresponds to a file volume in any registered filesystem
 *	except the native one.  For speed and historical reasons the
 *	native filesystem has special hard-coded checks dotted here
 *	and there in the filesystem code.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE.
 *	The filesystem reference will be set if and only if it is
 *	non-NULL and the function's return value is TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, 
		       driveNameLengthPtr, driveNameRef)
    CONST char *path;                   /* Path to determine type for */
    int pathLen;                        /* Length of the path */
    Tcl_Filesystem **filesystemPtrPtr;  /* If absolute path and this is
					 * non-NULL, then set to the
					 * filesystem which claims this
					 * path */  
    int *driveNameLengthPtr;            /* If the path is absolute, and 
					 * this is non-NULL, then set to
					 * the length of the driveName */
    Tcl_Obj **driveNameRef;             /* If the path is absolute, and
					 * this is non-NULL, then set to
					 * the name of the drive,
					 * network-volume which contains
					 * the path, already with a
					 * refCount for the caller.  */
{
    FilesystemRecord *fsRecPtr;
    Tcl_PathType type = TCL_PATH_RELATIVE;

    /*
     * Call each of the "listVolumes" function in succession, checking
     * whether the given path is an absolute path on any of the volumes
     * returned (this is done by checking whether the path's prefix
     * matches).
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
	Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;

	/* 
	 * We want to skip the native filesystem in this loop because
	 * otherwise we won't necessarily pass all the Tcl testsuite --
	 * this is because some of the tests artificially change the
	 * current platform (between win, unix) but the list
	 * of volumes we get by calling (*proc) will reflect the current
	 * (real) platform only and this may cause some tests to fail.
	 * In particular, on unix '/' will match the beginning of 
	 * certain absolute Windows paths starting '//' and those tests
	 * will go wrong.
	 * 
	 * Besides these test-suite issues, there is one other reason
	 * to skip the native filesystem --- since the tclFilename.c
	 * code has nice fast 'absolute path' checkers, we don't want
	 * to waste time repeating that effort here, and this 
	 * function is actually called quite often, so if we can
	 * save the overhead of the native filesystem returning us
	 * a list of volumes all the time, it is better.

	 */

	if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
	    int numVolumes;
	    Tcl_Obj *thisFsVolumes = (*proc)();
	    if (thisFsVolumes != NULL) {
		if (Tcl_ListObjLength(NULL, thisFsVolumes, 
				      &numVolumes) != TCL_OK) {
		    /* 
		     * This is VERY bad; the Tcl_FSListVolumesProc
		     * didn't return a valid list.  Set numVolumes to
		     * -1 so that we skip the while loop below and just
		     * return with the current value of 'type'.
		     * 
		     * It would be better if we could signal an error
		     * here (but Tcl_Panic seems a bit excessive).
		     */

		    numVolumes = -1;
		}
		while (numVolumes > 0) {
		    Tcl_Obj *vol;
		    int len;
		    char *strVol;








|











|














|
|
|















|
|
|









|
|
|
|
<
|
|
|
|
|
<
|
|
|




|


|
|
|

|
|












|
|
|
|
<
|


|
|
|








|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|






|
|
|
<





>
|

|
|
|
|
|
<
|
|
|
|
|
|
|
<
|
|
>

>




|
|
|
|
|
|
|
|
|
|

>







3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804

3805
3806
3807
3808
3809

3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841

3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862

3863
3864
3865
3866
3867

3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878

3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891

3892
3893
3894
3895
3896
3897
3898

3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
	    }
	    Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
	if (*p++ == '\0') {
	    break;
	}
    }

    /*
     * Compute the number of elements in the result.
     */

    if (lenPtr != NULL) {
	Tcl_ListObjLength(NULL, result, lenPtr);
    }
    return result;
}

/* Simple helper function */
Tcl_Obj*
TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
    Tcl_Filesystem *fromFilesystem;
    ClientData clientData;
    FilesystemRecord **fsRecPtrPtr;
{
    FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();

    while (fsRecPtr != NULL) {
	if (fsRecPtr->fsPtr == fromFilesystem) {
	    *fsRecPtrPtr = fsRecPtr;
	    break;
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    if ((fsRecPtr != NULL)
	    && (fromFilesystem->internalToNormalizedProc != NULL)) {
	return (*fromFilesystem->internalToNormalizedProc)(clientData);
    } else {
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetPathType --
 *
 *	Helper function used by FSGetPathType.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.  The filesystem reference will be set if and
 *	only if it is non-NULL and the function's return value is
 *	TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
    Tcl_Obj *pathPtr;			/* Path to determine type for */
    Tcl_Filesystem **filesystemPtrPtr;	/* If absolute path and this is not
					 * NULL, then set to the filesystem
					 * which claims this path. */

    int *driveNameLengthPtr;		/* If the path is absolute, and this
					 * is non-NULL, then set to the length
					 * of the driveName. */
    Tcl_Obj **driveNameRef;		/* If the path is absolute, and this
					 * is non-NULL, then set to the name

					 * of the drive, network-volume which
					 * contains the path, already with a
					 * refCount for the caller. */
{
    int pathLen;
    char *path;
    Tcl_PathType type;

    path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
	    driveNameLengthPtr, driveNameRef);

    if (type != TCL_PATH_ABSOLUTE) {
	type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
		driveNameRef);
	if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
	    *filesystemPtrPtr = &tclNativeFilesystem;
	}
    }
    return type;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSNonnativePathType --
 *
 *	Helper function used by TclGetPathType.  Its purpose is to check
 *	whether the given path starts with a string which corresponds to a
 *	file volume in any registered filesystem except the native one.  For
 *	speed and historical reasons the native filesystem has special

 *	hard-coded checks dotted here and there in the filesystem code.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE.  The filesystem
 *	reference will be set if and only if it is non-NULL and the function's
 *	return value is TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr,
	driveNameRef)
    CONST char *path;			/* Path to determine type for */
    int pathLen;			/* Length of the path */
    Tcl_Filesystem **filesystemPtrPtr;	/* If absolute path and this is not
					 * NULL, then set to the filesystem
					 * which claims this path. */

    int *driveNameLengthPtr;		/* If the path is absolute, and this
					 * is non-NULL, then set to the length
					 * of the driveName. */
    Tcl_Obj **driveNameRef;		/* If the path is absolute, and this
					 * is non-NULL, then set to the name

					 * of the drive, network-volume which
					 * contains the path, already with a
					 * refCount for the caller.  */
{
    FilesystemRecord *fsRecPtr;
    Tcl_PathType type = TCL_PATH_RELATIVE;

    /*
     * Call each of the "listVolumes" function in succession, checking whether
     * the given path is an absolute path on any of the volumes returned (this
     * is done by checking whether the path's prefix matches).

     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
	Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;

	/*
	 * We want to skip the native filesystem in this loop because
	 * otherwise we won't necessarily pass all the Tcl testsuite -- this
	 * is because some of the tests artificially change the current
	 * platform (between win, unix) but the list of volumes we get by
	 * calling (*proc) will reflect the current (real) platform only and
	 * this may cause some tests to fail.  In particular, on unix '/' will

	 * match the beginning of certain absolute Windows paths starting '//'
	 * and those tests will go wrong.
	 *
	 * Besides these test-suite issues, there is one other reason to skip
	 * the native filesystem --- since the tclFilename.c code has nice
	 * fast 'absolute path' checkers, we don't want to waste time
	 * repeating that effort here, and this function is actually called

	 * quite often, so if we can save the overhead of the native
	 * filesystem returning us a list of volumes all the time, it is
	 * better.
	 */

	if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
	    int numVolumes;
	    Tcl_Obj *thisFsVolumes = (*proc)();
	    if (thisFsVolumes != NULL) {
		if (Tcl_ListObjLength(NULL, thisFsVolumes,
			&numVolumes) != TCL_OK) {
		    /*
		     * This is VERY bad; the Tcl_FSListVolumesProc didn't
		     * return a valid list.  Set numVolumes to -1 so that we
		     * skip the while loop below and just return with the
		     * current value of 'type'.
		     *
		     * It would be better if we could signal an error here
		     * (but Tcl_Panic seems a bit excessive).
		     */

		    numVolumes = -1;
		}
		while (numVolumes > 0) {
		    Tcl_Obj *vol;
		    int len;
		    char *strVol;

3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSRenameFile --
 *
 *	If the two paths given belong to the same filesystem, we call
 *	that filesystems rename function.  Otherwise we simply
 *	return the posix error 'EXDEV', and -1.
 *
 * Results:
 *      Standard Tcl error code if a function was called.
 *
 * Side effects:
 *	A file may be renamed.
 *
 *---------------------------------------------------------------------------
 */








|
|
|


|







3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSRenameFile --
 *
 *	If the two paths given belong to the same filesystem, we call that
 *	filesystems rename function.  Otherwise we simply return the posix
 *	error 'EXDEV', and -1.
 *
 * Results:
 *	Standard Tcl error code if a function was called.
 *
 * Side effects:
 *	A file may be renamed.
 *
 *---------------------------------------------------------------------------
 */

3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyFile --
 *
 *	If the two paths given belong to the same filesystem, we call
 *	that filesystem's copy function.  Otherwise we simply
 *	return the posix error 'EXDEV', and -1.
 *	
 *	Note that in the native filesystems, 'copyFileProc' is defined
 *	to copy soft links (i.e. it copies the links themselves, not
 *	the things they point to).
 *
 * Results:
 *      Standard Tcl error code if a function was called.
 *
 * Side effects:
 *	A file may be copied.
 *
 *---------------------------------------------------------------------------
 */

int 
Tcl_FSCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj* srcPathPtr;	/* Pathname of file to be copied (UTF-8). */
    Tcl_Obj *destPathPtr;	/* Pathname of file to copy to (UTF-8). */
{
    int retVal = -1;
    Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);







|
|
|
|
|
|
|


|







|







4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyFile --
 *
 *	If the two paths given belong to the same filesystem, we call that
 *	filesystem's copy function.  Otherwise we simply return the posix
 *	error 'EXDEV', and -1.
 *
 *	Note that in the native filesystems, 'copyFileProc' is defined to copy
 *	soft links (i.e. it copies the links themselves, not the things they
 *	point to).
 *
 * Results:
 *	Standard Tcl error code if a function was called.
 *
 * Side effects:
 *	A file may be copied.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj* srcPathPtr;	/* Pathname of file to be copied (UTF-8). */
    Tcl_Obj *destPathPtr;	/* Pathname of file to copy to (UTF-8). */
{
    int retVal = -1;
    Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797

3798


3799
3800
3801

3802


3803

3804
3805
3806

3807
3808
3809
3810
3811

3812
3813
3814
3815
3816
3817

3818
3819
3820
3821

3822
3823
3824

3825


3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
}

/*
 *---------------------------------------------------------------------------
 *
 * TclCrossFilesystemCopy --
 *
 *	Helper for above function, and for Tcl_FSLoadFile, to copy
 *	files from one filesystem to another.  This function will
 *	overwrite the target file if it already exists.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	A file may be created.
 *
 *---------------------------------------------------------------------------
 */
int 
TclCrossFilesystemCopy(interp, source, target) 
    Tcl_Interp *interp; /* For error messages */
    Tcl_Obj *source;	/* Pathname of file to be copied (UTF-8). */
    Tcl_Obj *target;	/* Pathname of file to copy to (UTF-8). */
{
    int result = TCL_ERROR;
    int prot = 0666;
    
    Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
    if (out != NULL) {

	/* It looks like we can copy it over */


	Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, 
					       "r", prot);
	if (in == NULL) {

	    /* This is very strange, we checked this above */


	    Tcl_Close(interp, out);

	} else {
	    Tcl_StatBuf sourceStatBuf;
	    struct utimbuf tval;

	    /* 
	     * Copy it synchronously.  We might wish to add an
	     * asynchronous option to support vfs's which are
	     * slow (e.g. network sockets).
	     */

	    Tcl_SetChannelOption(interp, in, "-translation", "binary");
	    Tcl_SetChannelOption(interp, out, "-translation", "binary");
	    
	    if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
		result = TCL_OK;
	    }

	    /* 
	     * If the copy failed, assume that copy channel left
	     * a good error message.
	     */

	    Tcl_Close(interp, in);
	    Tcl_Close(interp, out);
	    

	    /* Set modification date of copied file */


	    if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
		tval.actime = sourceStatBuf.st_atime;
		tval.modtime = sourceStatBuf.st_mtime;
		Tcl_FSUtime(target, &tval);
	    }
	}
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSDeleteFile --
 *
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	A file may be deleted.
 *
 *---------------------------------------------------------------------------
 */








|
|
|


|






|
|






|


>
|
>
>
|
|

>
|
>
>

>



>
|
|
|
<

>


|



>
|
|
|

>


|
>
|
>
>















|
|


|







4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093

4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
}

/*
 *---------------------------------------------------------------------------
 *
 * TclCrossFilesystemCopy --
 *
 *	Helper for above function, and for Tcl_FSLoadFile, to copy files from
 *	one filesystem to another.  This function will overwrite the target
 *	file if it already exists.
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	A file may be created.
 *
 *---------------------------------------------------------------------------
 */
int
TclCrossFilesystemCopy(interp, source, target)
    Tcl_Interp *interp; /* For error messages */
    Tcl_Obj *source;	/* Pathname of file to be copied (UTF-8). */
    Tcl_Obj *target;	/* Pathname of file to copy to (UTF-8). */
{
    int result = TCL_ERROR;
    int prot = 0666;

    Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
    if (out != NULL) {
	/*
	 * It looks like we can copy it over.
	 */

	Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, "r", prot);

	if (in == NULL) {
	    /*
	     * This is very strange, we checked this above
	     */

	    Tcl_Close(interp, out);

	} else {
	    Tcl_StatBuf sourceStatBuf;
	    struct utimbuf tval;

	    /*
	     * Copy it synchronously.  We might wish to add an asynchronous
	     * option to support vfs's which are slow (e.g. network sockets).

	     */

	    Tcl_SetChannelOption(interp, in, "-translation", "binary");
	    Tcl_SetChannelOption(interp, out, "-translation", "binary");

	    if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
		result = TCL_OK;
	    }

	    /*
	     * If the copy failed, assume that copy channel left a good error
	     * message.
	     */

	    Tcl_Close(interp, in);
	    Tcl_Close(interp, out);

	    /*
	     * Set modification date of copied file.
	     */

	    if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
		tval.actime = sourceStatBuf.st_atime;
		tval.modtime = sourceStatBuf.st_mtime;
		Tcl_FSUtime(target, &tval);
	    }
	}
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSDeleteFile --
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	A file may be deleted.
 *
 *---------------------------------------------------------------------------
 */

3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCreateDirectory --
 *
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	A directory may be created.
 *
 *---------------------------------------------------------------------------
 */








|
|


|







4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCreateDirectory --
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	A directory may be created.
 *
 *---------------------------------------------------------------------------
 */

3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyDirectory --
 *
 *	If the two paths given belong to the same filesystem, we call
 *	that filesystems copy-directory function.  Otherwise we simply
 *	return the posix error 'EXDEV', and -1.
 *
 * Results:
 *      Standard Tcl error code if a function was called.
 *
 * Side effects:
 *	A directory may be copied.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
    Tcl_Obj* srcPathPtr;	/* Pathname of directory to be copied
				 * (UTF-8). */
    Tcl_Obj *destPathPtr;	/* Pathname of target directory (UTF-8). */
    Tcl_Obj **errorPtr;	        /* If non-NULL, then will be set to a
                       	         * new object containing name of file
                       	         * causing error, with refCount 1. */
{
    int retVal = -1;
    Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
    fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);

    if (fsPtr == fsPtr2 && fsPtr != NULL) {







|
|
|


|












|
|
|







4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyDirectory --
 *
 *	If the two paths given belong to the same filesystem, we call that
 *	filesystems copy-directory function.  Otherwise we simply return the
 *	posix error 'EXDEV', and -1.
 *
 * Results:
 *	Standard Tcl error code if a function was called.
 *
 * Side effects:
 *	A directory may be copied.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
    Tcl_Obj* srcPathPtr;	/* Pathname of directory to be copied
				 * (UTF-8). */
    Tcl_Obj *destPathPtr;	/* Pathname of target directory (UTF-8). */
    Tcl_Obj **errorPtr;		/* If non-NULL, then will be set to a new
				 * object containing name of file causing
				 * error, with refCount 1. */
{
    int retVal = -1;
    Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
    fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);

    if (fsPtr == fsPtr2 && fsPtr != NULL) {
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980

3981

3982
3983
3984
3985

3986
3987
3988
3989
3990
3991
3992
3993
3994

3995
3996

3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075


4076
4077
4078
4079
4080
4081
4082
4083

4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146

4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171

4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218

4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234

4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254

4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSRemoveDirectory --
 *
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	A directory may be deleted.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_Obj *pathPtr;		/* Pathname of directory to be removed
				 * (UTF-8). */
    int recursive;		/* If non-zero, removes directories that
				 * are nonempty.  Otherwise, will only remove
				 * empty directories. */
    Tcl_Obj **errorPtr;	        /* If non-NULL, then will be set to a
				 * new object containing name of file
				 * causing error, with refCount 1. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
	if (proc != NULL) {
	    if (recursive) {
	        /* 
	         * We check whether the cwd lies inside this directory
	         * and move it if it does.
	         */

		Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);

		if (cwdPtr != NULL) {
		    char *cwdStr, *normPathStr;
		    int cwdLen, normLen;
		    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

		    if (normPath != NULL) {
		        normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
			cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
			if ((cwdLen >= normLen) && (strncmp(normPathStr, 
					cwdStr, (size_t) normLen) == 0)) {
			    /* 
			     * the cwd is inside the directory, so we
			     * perform a 'cd [file dirname $path]'
			     */

			    Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, 
							     TCL_PATH_DIRNAME);

			    Tcl_FSChdir(dirPtr);
			    Tcl_DecrRefCount(dirPtr);
			}
		    }
		    Tcl_DecrRefCount(cwdPtr);
		}
	    }
	    return (*proc)(pathPtr, recursive, errorPtr);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetFileSystemForPath --
 *
 *      This function determines which filesystem to use for a
 *      particular path object, and returns the filesystem which
 *      accepts this file.  If no filesystem will accept this object
 *      as a valid file path, then NULL is returned.
 *
 * Results:
.*      NULL or a filesystem which will accept this path.
 *
 * Side effects:
 *	The object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathPtr)
    Tcl_Obj* pathPtr;
{
    FilesystemRecord *fsRecPtr;
    Tcl_Filesystem* retVal = NULL;
    
    if (pathPtr == NULL) {
	Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
	return NULL;
    }
    
    /* 
     * If the object has a refCount of zero, we reject it.  This
     * is to avoid possible segfaults or nondeterministic memory
     * leaks (i.e. the user doesn't know if they should decrement
     * the ref count on return or not).
     */
    
    if (pathPtr->refCount == 0) {
	Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
	return NULL;
    }
    
    /* 
     * Check if the filesystem has changed in some way since
     * this object's internal representation was calculated.
     * Before doing that, assure we have the most up-to-date
     * copy of the master filesystem. This is accomplished
     * by the FsGetFirstFilesystem() call.
     */

    fsRecPtr = FsGetFirstFilesystem();

    if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
	return NULL;
    }

    /*
     * Call each of the "pathInFilesystem" functions in succession.  A
     * non-return value of -1 indicates the particular function has
     * succeeded.
     */

    while ((retVal == NULL) && (fsRecPtr != NULL)) {
	Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;


	if (proc != NULL) {
	    ClientData clientData = NULL;
	    int ret = (*proc)(pathPtr, &clientData);
	    if (ret != -1) {
		/* 
		 * We assume the type of pathPtr hasn't been changed 
		 * by the above call to the pathInFilesystemProc.
		 */

		TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
		retVal = fsRecPtr->fsPtr;
	    }
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetNativePath --
 *
 *      This function is for use by the Win/Unix native filesystems,
 *      so that they can easily retrieve the native (char* or TCHAR*)
 *      representation of a path.  Other filesystems will probably
 *      want to implement similar functions.  They basically act as a 
 *      safety net around Tcl_FSGetInternalRep.  Normally your file-
 *      system procedures will always be called with path objects
 *      already converted to the correct filesystem, but if for 
 *      some reason they are called directly (i.e. by procedures 
 *      not in this file), then one cannot necessarily guarantee that
 *      the path object pointer is from the correct filesystem.
 *      
 *      Note: in the future it might be desireable to have separate
 *      versions of this function with different signatures, for
 *      example Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc.
 *      Right now, since native paths are all string based, we use just
 *      one function.
 *
 * Results:
 *      NULL or a valid native path.
 *
 * Side effects:
 *	See Tcl_FSGetInternalRep.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_FSGetNativePath(pathPtr)
    Tcl_Obj *pathPtr;
{
    return (CONST char *)Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeFreeInternalRep --
 *
 *      Free a native internal representation, which will be non-NULL.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *	Memory is released.
 *
 *---------------------------------------------------------------------------
 */

static void 
NativeFreeInternalRep(clientData)
    ClientData clientData;
{
    ckfree((char*)clientData);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSFileSystemInfo --
 *
 *      This function returns a list of two elements.  The first
 *      element is the name of the filesystem (e.g. "native" or "vfs"),
 *      and the second is the particular type of the given path within
 *      that filesystem.
 *
 * Results:
 *      A list of two elements.
 *
 * Side effects:
 *	The object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSFileSystemInfo(pathPtr)
    Tcl_Obj* pathPtr;
{
    Tcl_Obj *resPtr;
    Tcl_FSFilesystemPathTypeProc *proc;
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    
    if (fsPtr == NULL) {
	return NULL;
    }
    
    resPtr = Tcl_NewListObj(0,NULL);
    
    Tcl_ListObjAppendElement(NULL, resPtr, 
			     Tcl_NewStringObj(fsPtr->typeName,-1));

    proc = fsPtr->filesystemPathTypeProc;
    if (proc != NULL) {
	Tcl_Obj *typePtr = (*proc)(pathPtr);
	if (typePtr != NULL) {
	    Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
	}
    }
    
    return resPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSPathSeparator --
 *
 *      This function returns the separator to be used for a given
 *      path.  The object returned should have a refCount of zero
 *
 * Results:
 *      A Tcl object, with a refCount of zero.  If the caller
 *      needs to retain a reference to the object, it should
 *      call Tcl_IncrRefCount, and should otherwise free the
 *      object.
 *
 * Side effects:
 *	The path object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSPathSeparator(pathPtr)
    Tcl_Obj* pathPtr;
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    
    if (fsPtr == NULL) {
	return NULL;
    }
    if (fsPtr->filesystemSeparatorProc != NULL) {
	return (*fsPtr->filesystemSeparatorProc)(pathPtr);
    } else {
	/* 
	 * Allow filesystems not to provide a filesystemSeparatorProc
	 * if they wish to use the standard forward slash.
	 */

	return Tcl_NewStringObj("/", 1);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeFilesystemSeparator --
 *
 *      This function is part of the native filesystem support, and
 *      returns the separator for the given path.
 *
 * Results:
 *      String object containing the separator character.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj*
NativeFilesystemSeparator(pathPtr)
    Tcl_Obj* pathPtr;
{
    char *separator = NULL; /* lint */
    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    separator = "/";
	    break;
	case TCL_PLATFORM_WINDOWS:
	    separator = "\\";
	    break;
    }
    return Tcl_NewStringObj(separator,1);
}

/* Everything from here on is contained in this obsolete ifdef */
#ifdef USE_OBSOLETE_FS_HOOKS

/*
 *----------------------------------------------------------------------
 *
 * TclStatInsertProc --
 *
 *	Insert the passed procedure pointer at the head of the list of
 *	functions which are used during a call to 'TclStat(...)'. The
 *	passed function should behave exactly like 'TclStat' when called
 *	during that time (see 'TclStat(...)' for more information).
 *	The function will be added even if it already in the list.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 *	could not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for 'TclStat'
 *	functions.
 *
 *----------------------------------------------------------------------
 */

int
TclStatInsertProc (proc)
    TclStatProc_ *proc;







|
|


|











|
|

|
|
|


|

<
|
|
|
|
|
>
|
>
|
|
|
|
>
|
|
|
|
|
|
|
|
|
>
|
|
>
|
|
|
|
|
|
|
|
<










|
|
|
|


|













|




|
|
|
|
|
<

|




|
|
|
|
<
|
|










|
<



|
>
>




|
|
|

>















|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
<


|











|







|


|






>
|



|







|
|
|
<


|






>







|



|

|
|
|








|








|
|


|
|
|
<






>





|






|
|
|

>









|
|


|






>






|
|
|
|
|
|













|
|
|
|


|
|


|
<







4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263

4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297

4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337

4338
4339
4340
4341
4342
4343
4344
4345
4346
4347

4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360

4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396

4397
4398
4399
4400
4401
4402
4403
4404

4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452

4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502

4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583

4584
4585
4586
4587
4588
4589
4590
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSRemoveDirectory --
 *
 *	The appropriate function for the filesystem to which pathPtr belongs
 *	will be called.
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	A directory may be deleted.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_Obj *pathPtr;		/* Pathname of directory to be removed
				 * (UTF-8). */
    int recursive;		/* If non-zero, removes directories that are
				 * nonempty.  Otherwise, will only remove
				 * empty directories. */
    Tcl_Obj **errorPtr;		/* If non-NULL, then will be set to a new
				 * object containing name of file causing
				 * error, with refCount 1. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) {
	Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;

	if (recursive) {
	    /*
	     * We check whether the cwd lies inside this directory and move it
	     * if it does.
	     */

	    Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);

	    if (cwdPtr != NULL) {
		char *cwdStr, *normPathStr;
		int cwdLen, normLen;
		Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

		if (normPath != NULL) {
		    normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
		    cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
		    if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
			    (size_t) normLen) == 0)) {
			/*
			 * The cwd is inside the directory, so we perform a
			 * 'cd [file dirname $path]'.
			 */

			Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
				TCL_PATH_DIRNAME);

			Tcl_FSChdir(dirPtr);
			Tcl_DecrRefCount(dirPtr);
		    }
		}
		Tcl_DecrRefCount(cwdPtr);
	    }
	}
	return (*proc)(pathPtr, recursive, errorPtr);

    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetFileSystemForPath --
 *
 *	This function determines which filesystem to use for a particular path
 *	object, and returns the filesystem which accepts this file.  If no
 *	filesystem will accept this object as a valid file path, then NULL is
 *	returned.
 *
 * Results:
 *	NULL or a filesystem which will accept this path.
 *
 * Side effects:
 *	The object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathPtr)
    Tcl_Obj* pathPtr;
{
    FilesystemRecord *fsRecPtr;
    Tcl_Filesystem* retVal = NULL;

    if (pathPtr == NULL) {
	Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
	return NULL;
    }

    /*
     * If the object has a refCount of zero, we reject it.  This is to avoid
     * possible segfaults or nondeterministic memory leaks (i.e. the user
     * doesn't know if they should decrement the ref count on return or not).

     */

    if (pathPtr->refCount == 0) {
	Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
	return NULL;
    }

    /*
     * Check if the filesystem has changed in some way since this object's
     * internal representation was calculated.  Before doing that, assure we

     * have the most up-to-date copy of the master filesystem. This is
     * accomplished by the FsGetFirstFilesystem() call.
     */

    fsRecPtr = FsGetFirstFilesystem();

    if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
	return NULL;
    }

    /*
     * Call each of the "pathInFilesystem" functions in succession.  A
     * non-return value of -1 indicates the particular function has succeeded.

     */

    while ((retVal == NULL) && (fsRecPtr != NULL)) {
	Tcl_FSPathInFilesystemProc *proc =
		fsRecPtr->fsPtr->pathInFilesystemProc;

	if (proc != NULL) {
	    ClientData clientData = NULL;
	    int ret = (*proc)(pathPtr, &clientData);
	    if (ret != -1) {
		/*
		 * We assume the type of pathPtr hasn't been changed by the
		 * above call to the pathInFilesystemProc.
		 */

		TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
		retVal = fsRecPtr->fsPtr;
	    }
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }

    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetNativePath --
 *
 *	This function is for use by the Win/Unix native filesystems, so that
 *	they can easily retrieve the native (char* or TCHAR*) representation
 *	of a path.  Other filesystems will probably want to implement similar
 *	functions.  They basically act as a safety net around
 *	Tcl_FSGetInternalRep.  Normally your file- system procedures will
 *	always be called with path objects already converted to the correct

 *	filesystem, but if for some reason they are called directly (i.e. by
 *	procedures not in this file), then one cannot necessarily guarantee
 *	that the path object pointer is from the correct filesystem.
 *
 *	Note: in the future it might be desireable to have separate versions
 *	of this function with different signatures, for example
 *	Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc.  Right now, since
 *	native paths are all string based, we use just one function.

 *
 * Results:
 *	NULL or a valid native path.
 *
 * Side effects:
 *	See Tcl_FSGetInternalRep.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_FSGetNativePath(pathPtr)
    Tcl_Obj *pathPtr;
{
    return (CONST char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeFreeInternalRep --
 *
 *	Free a native internal representation, which will be non-NULL.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is released.
 *
 *---------------------------------------------------------------------------
 */

static void
NativeFreeInternalRep(clientData)
    ClientData clientData;
{
    ckfree((char *) clientData);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSFileSystemInfo --
 *
 *	This function returns a list of two elements.  The first element is
 *	the name of the filesystem (e.g. "native" or "vfs"), and the second is
 *	the particular type of the given path within that filesystem.

 *
 * Results:
 *	A list of two elements.
 *
 * Side effects:
 *	The object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSFileSystemInfo(pathPtr)
    Tcl_Obj* pathPtr;
{
    Tcl_Obj *resPtr;
    Tcl_FSFilesystemPathTypeProc *proc;
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr == NULL) {
	return NULL;
    }

    resPtr = Tcl_NewListObj(0,NULL);

    Tcl_ListObjAppendElement(NULL, resPtr,
	    Tcl_NewStringObj(fsPtr->typeName,-1));

    proc = fsPtr->filesystemPathTypeProc;
    if (proc != NULL) {
	Tcl_Obj *typePtr = (*proc)(pathPtr);
	if (typePtr != NULL) {
	    Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
	}
    }

    return resPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSPathSeparator --
 *
 *	This function returns the separator to be used for a given path.  The
 *	object returned should have a refCount of zero
 *
 * Results:
 *	A Tcl object, with a refCount of zero. If the caller needs to retain a
 *	reference to the object, it should call Tcl_IncrRefCount, and should
 *	otherwise free the object.

 *
 * Side effects:
 *	The path object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSPathSeparator(pathPtr)
    Tcl_Obj* pathPtr;
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr == NULL) {
	return NULL;
    }
    if (fsPtr->filesystemSeparatorProc != NULL) {
	return (*fsPtr->filesystemSeparatorProc)(pathPtr);
    } else {
	/*
	 * Allow filesystems not to provide a filesystemSeparatorProc if they
	 * wish to use the standard forward slash.
	 */

	return Tcl_NewStringObj("/", 1);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeFilesystemSeparator --
 *
 *	This function is part of the native filesystem support, and returns
 *	the separator for the given path.
 *
 * Results:
 *	String object containing the separator character.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj*
NativeFilesystemSeparator(pathPtr)
    Tcl_Obj* pathPtr;
{
    char *separator = NULL; /* lint */
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	separator = "/";
	break;
    case TCL_PLATFORM_WINDOWS:
	separator = "\\";
	break;
    }
    return Tcl_NewStringObj(separator,1);
}

/* Everything from here on is contained in this obsolete ifdef */
#ifdef USE_OBSOLETE_FS_HOOKS

/*
 *----------------------------------------------------------------------
 *
 * TclStatInsertProc --
 *
 *	Insert the passed procedure pointer at the head of the list of
 *	functions which are used during a call to 'TclStat(...)'. The passed
 *	function should behave exactly like 'TclStat' when called during that
 *	time (see 'TclStat(...)' for more information).  The function will be
 *	added even if it already in the list.
 *
 * Results:
 *	Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *	not be allocated.
 *
 * Side effects:
 *	Memory allocated and modifies the link list for 'TclStat' functions.

 *
 *----------------------------------------------------------------------
 */

int
TclStatInsertProc (proc)
    TclStatProc_ *proc;
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349

4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360

/*
 *----------------------------------------------------------------------
 *
 * TclStatDeleteProc --
 *
 *	Removed the passed function pointer from the list of 'TclStat'
 *	functions.  Ensures that the built-in stat function is not
 *	removvable.
 *
 * Results:
 *      TCL_OK if the procedure pointer was successfully removed,
 *	TCL_ERROR otherwise.
 *
 * Side effects:
 *      Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclStatDeleteProc (proc)
    TclStatProc_ *proc;
{
    int retVal = TCL_ERROR;
    StatProc *tmpStatProcPtr;
    StatProc *prevStatProcPtr = NULL;

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpStatProcPtr = statProcList;

    /*
     * Traverse the 'statProcList' looking for the particular node
     * whose 'proc' member matches 'proc' and remove that one from
     * the list.  Ensure that the "default" node cannot be removed.
     */

    while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
	if (tmpStatProcPtr->proc == proc) {
	    if (prevStatProcPtr == NULL) {
		statProcList = tmpStatProcPtr->nextPtr;
	    } else {







|
<


|
|


|














>

|
|
|







4612
4613
4614
4615
4616
4617
4618
4619

4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652

/*
 *----------------------------------------------------------------------
 *
 * TclStatDeleteProc --
 *
 *	Removed the passed function pointer from the list of 'TclStat'
 *	functions.  Ensures that the built-in stat function is not removvable.

 *
 * Results:
 *	TCL_OK if the procedure pointer was successfully removed, TCL_ERROR
 *	otherwise.
 *
 * Side effects:
 *	Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclStatDeleteProc (proc)
    TclStatProc_ *proc;
{
    int retVal = TCL_ERROR;
    StatProc *tmpStatProcPtr;
    StatProc *prevStatProcPtr = NULL;

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpStatProcPtr = statProcList;

    /*
     * Traverse the 'statProcList' looking for the particular node whose
     * 'proc' member matches 'proc' and remove that one from the list.  Ensure
     * that the "default" node cannot be removed.
     */

    while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
	if (tmpStatProcPtr->proc == proc) {
	    if (prevStatProcPtr == NULL) {
		statProcList = tmpStatProcPtr->nextPtr;
	    } else {
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403

/*
 *----------------------------------------------------------------------
 *
 * TclAccessInsertProc --
 *
 *	Insert the passed procedure pointer at the head of the list of
 *	functions which are used during a call to 'TclAccess(...)'.
 *	The passed function should behave exactly like 'TclAccess' when
 *	called during that time (see 'TclAccess(...)' for more
 *	information).  The function will be added even if it already in
 *	the list.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 *	could not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for 'TclAccess'
 *	functions.
 *
 *----------------------------------------------------------------------
 */

int
TclAccessInsertProc(proc)
    TclAccessProc_ *proc;







|
|
|
|
<


|
|


|
<







4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679

4680
4681
4682
4683
4684
4685
4686

4687
4688
4689
4690
4691
4692
4693

/*
 *----------------------------------------------------------------------
 *
 * TclAccessInsertProc --
 *
 *	Insert the passed procedure pointer at the head of the list of
 *	functions which are used during a call to 'TclAccess(...)'.  The
 *	passed function should behave exactly like 'TclAccess' when called
 *	during that time (see 'TclAccess(...)' for more information).  The
 *	function will be added even if it already in the list.

 *
 * Results:
 *	Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *	not be allocated.
 *
 * Side effects:
 *	Memory allocated and modifies the link list for 'TclAccess' functions.

 *
 *----------------------------------------------------------------------
 */

int
TclAccessInsertProc(proc)
    TclAccessProc_ *proc;
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
 * TclAccessDeleteProc --
 *
 *	Removed the passed function pointer from the list of 'TclAccess'
 *	functions.  Ensures that the built-in access function is not
 *	removvable.
 *
 * Results:
 *      TCL_OK if the procedure pointer was successfully removed,
 *	TCL_ERROR otherwise.
 *
 * Side effects:
 *      Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclAccessDeleteProc(proc)
    TclAccessProc_ *proc;
{
    int retVal = TCL_ERROR;
    AccessProc *tmpAccessProcPtr;
    AccessProc *prevAccessProcPtr = NULL;

    /*
     * Traverse the 'accessProcList' looking for the particular node
     * whose 'proc' member matches 'proc' and remove that one from
     * the list.  Ensure that the "default" node cannot be removed.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpAccessProcPtr = accessProcList;
    while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
	if (tmpAccessProcPtr->proc == proc) {
	    if (prevAccessProcPtr == NULL) {







|
|


|













|
|
|







4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
 * TclAccessDeleteProc --
 *
 *	Removed the passed function pointer from the list of 'TclAccess'
 *	functions.  Ensures that the built-in access function is not
 *	removvable.
 *
 * Results:
 *	TCL_OK if the procedure pointer was successfully removed, TCL_ERROR
 *	otherwise.
 *
 * Side effects:
 *	Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclAccessDeleteProc(proc)
    TclAccessProc_ *proc;
{
    int retVal = TCL_ERROR;
    AccessProc *tmpAccessProcPtr;
    AccessProc *prevAccessProcPtr = NULL;

    /*
     * Traverse the 'accessProcList' looking for the particular node whose
     * 'proc' member matches 'proc' and remove that one from the list.  Ensure
     * that the "default" node cannot be removed.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpAccessProcPtr = accessProcList;
    while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
	if (tmpAccessProcPtr->proc == proc) {
	    if (prevAccessProcPtr == NULL) {
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588








/*
 *----------------------------------------------------------------------
 *
 * TclOpenFileChannelInsertProc --
 *
 *	Insert the passed procedure pointer at the head of the list of
 *	functions which are used during a call to
 *	'Tcl_OpenFileChannel(...)'. The passed function should behave
 *	exactly like 'Tcl_OpenFileChannel' when called during that time
 *	(see 'Tcl_OpenFileChannel(...)' for more information). The
 *	function will be added even if it already in the list.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 *	could not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for
 *	'Tcl_OpenFileChannel' functions.
 *
 *----------------------------------------------------------------------
 */

int
TclOpenFileChannelInsertProc(proc)
    TclOpenFileChannelProc_ *proc;
{
    int retVal = TCL_ERROR;

    if (proc != NULL) {
	OpenFileChannelProc *newOpenFileChannelProcPtr;

	newOpenFileChannelProcPtr =
		(OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc));

	if (newOpenFileChannelProcPtr != NULL) {
	    newOpenFileChannelProcPtr->proc = proc;
	    Tcl_MutexLock(&obsoleteFsHookMutex);
	    newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
	    openFileChannelProcList = newOpenFileChannelProcPtr;
	    Tcl_MutexUnlock(&obsoleteFsHookMutex);

	    retVal = TCL_OK;
	}
    }

    return (retVal);
}

/*
 *----------------------------------------------------------------------
 *
 * TclOpenFileChannelDeleteProc --
 *
 *	Removed the passed function pointer from the list of
 *	'Tcl_OpenFileChannel' functions.  Ensures that the built-in
 *	open file channel function is not removable.
 *
 * Results:
 *      TCL_OK if the procedure pointer was successfully removed,
 *	TCL_ERROR otherwise.
 *
 * Side effects:
 *      Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclOpenFileChannelDeleteProc(proc)
    TclOpenFileChannelProc_ *proc;
{
    int retVal = TCL_ERROR;
    OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
    OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;

    /*
     * Traverse the 'openFileChannelProcList' looking for the particular
     * node whose 'proc' member matches 'proc' and remove that one from
     * the list.  
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpOpenFileChannelProcPtr = openFileChannelProcList;
    while ((retVal == TCL_ERROR) &&
	    (tmpOpenFileChannelProcPtr != NULL)) {
	if (tmpOpenFileChannelProcPtr->proc == proc) {
	    if (prevOpenFileChannelProcPtr == NULL) {
		openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
	    } else {
		prevOpenFileChannelProcPtr->nextPtr =
			tmpOpenFileChannelProcPtr->nextPtr;
	    }

	    ckfree((char *)tmpOpenFileChannelProcPtr);

	    retVal = TCL_OK;
	} else {
	    prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
	    tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
	}
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);

    return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */















|
|
|
|


|
|


|
|













|
|

<
|
|
|
|
|

|
|
|
<
|








|
|


|
|


|













|
|
<














|












>
>
>
>
>
>
>
>
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806

4807
4808
4809
4810
4811
4812
4813
4814
4815

4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848

4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
/*
 *----------------------------------------------------------------------
 *
 * TclOpenFileChannelInsertProc --
 *
 *	Insert the passed procedure pointer at the head of the list of
 *	functions which are used during a call to
 *	'Tcl_OpenFileChannel(...)'. The passed function should behave exactly
 *	like 'Tcl_OpenFileChannel' when called during that time (see
 *	'Tcl_OpenFileChannel(...)' for more information). The function will be
 *	added even if it already in the list.
 *
 * Results:
 *	Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *	not be allocated.
 *
 * Side effects:
 *	Memory allocated and modifies the link list for 'Tcl_OpenFileChannel'
 *	functions.
 *
 *----------------------------------------------------------------------
 */

int
TclOpenFileChannelInsertProc(proc)
    TclOpenFileChannelProc_ *proc;
{
    int retVal = TCL_ERROR;

    if (proc != NULL) {
	OpenFileChannelProc *newOpenFileChannelProcPtr;

	newOpenFileChannelProcPtr = (OpenFileChannelProc *)
		ckalloc(sizeof(OpenFileChannelProc));


	newOpenFileChannelProcPtr->proc = proc;
	Tcl_MutexLock(&obsoleteFsHookMutex);
	newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
	openFileChannelProcList = newOpenFileChannelProcPtr;
	Tcl_MutexUnlock(&obsoleteFsHookMutex);

	retVal = TCL_OK;
    }


    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * TclOpenFileChannelDeleteProc --
 *
 *	Removed the passed function pointer from the list of
 *	'Tcl_OpenFileChannel' functions.  Ensures that the built-in open file
 *	channel function is not removable.
 *
 * Results:
 *	TCL_OK if the procedure pointer was successfully removed, TCL_ERROR
 *	otherwise.
 *
 * Side effects:
 *	Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclOpenFileChannelDeleteProc(proc)
    TclOpenFileChannelProc_ *proc;
{
    int retVal = TCL_ERROR;
    OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
    OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;

    /*
     * Traverse the 'openFileChannelProcList' looking for the particular node
     * whose 'proc' member matches 'proc' and remove that one from the list.

     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpOpenFileChannelProcPtr = openFileChannelProcList;
    while ((retVal == TCL_ERROR) &&
	    (tmpOpenFileChannelProcPtr != NULL)) {
	if (tmpOpenFileChannelProcPtr->proc == proc) {
	    if (prevOpenFileChannelProcPtr == NULL) {
		openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
	    } else {
		prevOpenFileChannelProcPtr->nextPtr =
			tmpOpenFileChannelProcPtr->nextPtr;
	    }

	    ckfree((char *) tmpOpenFileChannelProcPtr);

	    retVal = TCL_OK;
	} else {
	    prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
	    tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
	}
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);

    return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIndexObj.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101

102
103
104
105
106
107
108
109
110
111
112
113
114

115
116
117
118

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

236
237
238

239
240
241
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268

269
270
271
272
273
274
275
276
277
278
279
280
281
282
/* 
 * tclIndexObj.c --
 *
 *	This file implements objects of type "index".  This object type
 *	is used to lookup a keyword in a table of valid values and cache
 *	the index of the matching entry.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIndexObj.c,v 1.22 2004/11/25 16:37:15 dkf Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for procedures defined later in this file:
 */

static int		SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *dupPtr));
static void		FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr));

/*
 * The structure below defines the index Tcl object type by means of
 * procedures that can be invoked by generic object code.
 */

Tcl_ObjType tclIndexType = {
    "index",				/* name */
    FreeIndex,				/* freeIntRepProc */
    DupIndex,				/* dupIntRepProc */
    UpdateStringOfIndex,		/* updateStringProc */
    SetIndexFromAny			/* setFromAnyProc */
};

/*
 * The definition of the internal representation of the "index"
 * object; The internalRep.otherValuePtr field of an object of "index"
 * type will be a pointer to one of these structures.
 *
 * Keep this structure declaration in sync with tclTestObj.c
 */

typedef struct {
    VOID *tablePtr;			/* Pointer to the table of strings */
    int offset;				/* Offset between table entries */
    int index;				/* Selected index into table. */
} IndexRep;

/*
 * The following macros greatly simplify moving through a table...
 */
#define STRING_AT(table, offset, index) \
	(*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))
#define NEXT_ENTRY(table, offset) \
	(&(STRING_AT(table, offset, 1)))
#define EXPAND_OF(indexRep) \
	STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetIndexFromObj --
 *
 *	This procedure looks up an object's value in a table of strings
 *	and returns the index of the matching string, if any.
 *
 * Results:
 *
 *	If the value of objPtr is identical to or a unique abbreviation
 *	for one of the entries in objPtr, then the return value is
 *	TCL_OK and the index of the matching entry is stored at
 *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is
 *	returned and an error message is left in interp's result (unless
 *	interp is NULL).  The msg argument is used in the error
 *	message; for example, if msg has the value "option" then the
 *	error message will say something flag 'bad option "foo": must be
 *	...'
 *
 * Side effects:
 *	The result of the lookup is cached as the internal rep of
 *	objPtr, so that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */
    CONST char **tablePtr;	/* Array of strings to compare against the
				 * value of objPtr; last entry must be NULL
				 * and there must not be duplicate entries. */
    CONST char *msg;		/* Identifying word to use in error messages. */

    int flags;			/* 0 or TCL_EXACT */
    int *indexPtr;		/* Place to store resulting integer index. */
{

    /*
     * See if there is a valid cached result from a previous lookup
     * (doing the check here saves the overhead of calling
     * Tcl_GetIndexFromObjStruct in the common case where the result
     * is cached).
     */

    if (objPtr->typePtr == &tclIndexType) {
	IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;

	/*
	 * Here's hoping we don't get hit by unfortunate packing
	 * constraints on odd platforms like a Cray PVP...
	 */

	if (indexRep->tablePtr == (VOID *)tablePtr &&
		indexRep->offset == sizeof(char *)) {
	    *indexPtr = indexRep->index;
	    return TCL_OK;
	}
    }
    return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
	    msg, flags, indexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetIndexFromObjStruct --
 *
 *	This procedure looks up an object's value given a starting
 *	string and an offset for the amount of space between strings.
 *	This is useful when the strings are embedded in some other
 *	kind of array.
 *
 * Results:
 *
 *	If the value of objPtr is identical to or a unique abbreviation
 *	for one of the entries in objPtr, then the return value is
 *	TCL_OK and the index of the matching entry is stored at
 *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is
 *	returned and an error message is left in interp's result (unless
 *	interp is NULL).  The msg argument is used in the error
 *	message; for example, if msg has the value "option" then the
 *	error message will say something flag 'bad option "foo": must be
 *	...'
 *
 * Side effects:
 *	The result of the lookup is cached as the internal rep of
 *	objPtr, so that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, 
	indexPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */
    CONST VOID *tablePtr;	/* The first string in the table. The second
				 * string will be at this address plus the
				 * offset, the third plus the offset again,
				 * etc. The last entry must be NULL
				 * and there must not be duplicate entries. */
    int offset;			/* The number of bytes between entries */
    CONST char *msg;		/* Identifying word to use in error messages. */

    int flags;			/* 0 or TCL_EXACT */
    int *indexPtr;		/* Place to store resulting integer index. */
{
    int index, length, i, numAbbrev;
    char *key, *p1;
    CONST char *p2;
    CONST char * CONST *entryPtr;
    Tcl_Obj *resultPtr;
    IndexRep *indexRep;

    /*
     * See if there is a valid cached result from a previous lookup.
     */

    if (objPtr->typePtr == &tclIndexType) {
	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
	if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
	    *indexPtr = indexRep->index;
	    return TCL_OK;
	}
    }

    /*
     * Lookup the value of the object in the table.  Accept unique
     * abbreviations unless TCL_EXACT is set in flags.
     */

    key = Tcl_GetStringFromObj(objPtr, &length);
    index = -1;
    numAbbrev = 0;

    /*
     * The key should not be empty, otherwise it's not a match.
     */
    
    if (key[0] == '\0') {
	goto error;
    }
    
    /*
     * Scan the table looking for one of:
     *  - An exact match (always preferred)
     *  - A single abbreviation (allowed depending on flags)
     *  - Several abbreviations (never allowed, but overridden by exact match)
     */

    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 
	    entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
	    if (*p1 == '\0') {
		index = i;
		goto done;
	    }
	}
	if (*p1 == '\0') {
	    /*
	     * The value is an abbreviation for this entry.  Continue
	     * checking other entries to make sure it's unique.  If we
	     * get more than one unique abbreviation, keep searching to
	     * see if there is an exact match, but remember the number
	     * of unique abbreviations and don't allow either.
	     */

	    numAbbrev++;
	    index = i;
	}
    }

    /*
     * Check if we were instructed to disallow abbreviations.
     */

    if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
	goto error;
    }

    done:
    /*
     * Cache the found representation.  Note that we want to avoid
     * allocating a new internal-rep if at all possible since that is
     * potentially a slow operation.
     */

    if (objPtr->typePtr == &tclIndexType) {
 	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
    } else {
	TclFreeIntRep(objPtr);
 	indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
 	objPtr->internalRep.otherValuePtr = (VOID *) indexRep;
 	objPtr->typePtr = &tclIndexType;
    }
    indexRep->tablePtr = (VOID*) tablePtr;
    indexRep->offset = offset;
    indexRep->index = index;

    *indexPtr = index;
    return TCL_OK;

    error:
    if (interp != NULL) {
	/*
	 * Produce a fancy error message.
	 */

	int count;

	TclNewObj(resultPtr);
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_AppendStringsToObj(resultPtr,
		(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
		key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL);
	for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
		*entryPtr != NULL;
		entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
	    if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
		Tcl_AppendStringsToObj(resultPtr,
			(count > 0) ? ", or " : " or ", *entryPtr,
			(char *) NULL);
|


|
|
|



|
|

|





|










|
|


|








|
|
|



















<






|
|


<
|
|
|
<
|
|
|
|



|
|











|
>





|
|
|
<


|

>

|
|

>















|
|
|
<


<
|
|
|
<
|
|
|
|



|
|





|






|
|

|
>














|



















|



|






>
|









|
|
|
|
|






>



>




|

|
|
|

>
|





|








|




>





|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
73
74

75
76
77

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

136
137

138
139
140

141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
/*
 * tclIndexObj.c --
 *
 *	This file implements objects of type "index". This object type is used
 *	to lookup a keyword in a table of valid values and cache the index of
 *	the matching entry.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIndexObj.c,v 1.22.2.2 2005/08/02 18:15:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for functions defined later in this file:
 */

static int		SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *dupPtr));
static void		FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr));

/*
 * The structure below defines the index Tcl object type by means of functions
 * that can be invoked by generic object code.
 */

static Tcl_ObjType indexType = {
    "index",				/* name */
    FreeIndex,				/* freeIntRepProc */
    DupIndex,				/* dupIntRepProc */
    UpdateStringOfIndex,		/* updateStringProc */
    SetIndexFromAny			/* setFromAnyProc */
};

/*
 * The definition of the internal representation of the "index" object; The
 * internalRep.otherValuePtr field of an object of "index" type will be a
 * pointer to one of these structures.
 *
 * Keep this structure declaration in sync with tclTestObj.c
 */

typedef struct {
    VOID *tablePtr;			/* Pointer to the table of strings */
    int offset;				/* Offset between table entries */
    int index;				/* Selected index into table. */
} IndexRep;

/*
 * The following macros greatly simplify moving through a table...
 */
#define STRING_AT(table, offset, index) \
	(*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))
#define NEXT_ENTRY(table, offset) \
	(&(STRING_AT(table, offset, 1)))
#define EXPAND_OF(indexRep) \
	STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetIndexFromObj --
 *
 *	This function looks up an object's value in a table of strings and
 *	returns the index of the matching string, if any.
 *
 * Results:

 *	If the value of objPtr is identical to or a unique abbreviation for
 *	one of the entries in objPtr, then the return value is TCL_OK and the
 *	index of the matching entry is stored at *indexPtr. If there isn't a

 *	proper match, then TCL_ERROR is returned and an error message is left
 *	in interp's result (unless interp is NULL). The msg argument is used
 *	in the error message; for example, if msg has the value "option" then
 *	the error message will say something flag 'bad option "foo": must be
 *	...'
 *
 * Side effects:
 *	The result of the lookup is cached as the internal rep of objPtr, so
 *	that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */
    CONST char **tablePtr;	/* Array of strings to compare against the
				 * value of objPtr; last entry must be NULL
				 * and there must not be duplicate entries. */
    CONST char *msg;		/* Identifying word to use in error
				 * messages. */
    int flags;			/* 0 or TCL_EXACT */
    int *indexPtr;		/* Place to store resulting integer index. */
{

    /*
     * See if there is a valid cached result from a previous lookup (doing the
     * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in
     * the common case where the result is cached).

     */

    if (objPtr->typePtr == &indexType) {
	IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;

	/*
	 * Here's hoping we don't get hit by unfortunate packing constraints
	 * on odd platforms like a Cray PVP...
	 */

	if (indexRep->tablePtr == (VOID *)tablePtr &&
		indexRep->offset == sizeof(char *)) {
	    *indexPtr = indexRep->index;
	    return TCL_OK;
	}
    }
    return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
	    msg, flags, indexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetIndexFromObjStruct --
 *
 *	This function looks up an object's value given a starting string and
 *	an offset for the amount of space between strings. This is useful when
 *	the strings are embedded in some other kind of array.

 *
 * Results:

 *	If the value of objPtr is identical to or a unique abbreviation for
 *	one of the entries in objPtr, then the return value is TCL_OK and the
 *	index of the matching entry is stored at *indexPtr. If there isn't a

 *	proper match, then TCL_ERROR is returned and an error message is left
 *	in interp's result (unless interp is NULL). The msg argument is used
 *	in the error message; for example, if msg has the value "option" then
 *	the error message will say something flag 'bad option "foo": must be
 *	...'
 *
 * Side effects:
 *	The result of the lookup is cached as the internal rep of objPtr, so
 *	that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
	indexPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */
    CONST VOID *tablePtr;	/* The first string in the table. The second
				 * string will be at this address plus the
				 * offset, the third plus the offset again,
				 * etc. The last entry must be NULL and there
				 * must not be duplicate entries. */
    int offset;			/* The number of bytes between entries */
    CONST char *msg;		/* Identifying word to use in error
				 * messages. */
    int flags;			/* 0 or TCL_EXACT */
    int *indexPtr;		/* Place to store resulting integer index. */
{
    int index, length, i, numAbbrev;
    char *key, *p1;
    CONST char *p2;
    CONST char * CONST *entryPtr;
    Tcl_Obj *resultPtr;
    IndexRep *indexRep;

    /*
     * See if there is a valid cached result from a previous lookup.
     */

    if (objPtr->typePtr == &indexType) {
	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
	if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
	    *indexPtr = indexRep->index;
	    return TCL_OK;
	}
    }

    /*
     * Lookup the value of the object in the table.  Accept unique
     * abbreviations unless TCL_EXACT is set in flags.
     */

    key = Tcl_GetStringFromObj(objPtr, &length);
    index = -1;
    numAbbrev = 0;

    /*
     * The key should not be empty, otherwise it's not a match.
     */

    if (key[0] == '\0') {
	goto error;
    }

    /*
     * Scan the table looking for one of:
     *  - An exact match (always preferred)
     *  - A single abbreviation (allowed depending on flags)
     *  - Several abbreviations (never allowed, but overridden by exact match)
     */

    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
	    entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
	    if (*p1 == '\0') {
		index = i;
		goto done;
	    }
	}
	if (*p1 == '\0') {
	    /*
	     * The value is an abbreviation for this entry. Continue checking
	     * other entries to make sure it's unique. If we get more than one
	     * unique abbreviation, keep searching to see if there is an exact
	     * match, but remember the number of unique abbreviations and
	     * don't allow either.
	     */

	    numAbbrev++;
	    index = i;
	}
    }

    /*
     * Check if we were instructed to disallow abbreviations.
     */

    if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
	goto error;
    }

  done:
    /*
     * Cache the found representation. Note that we want to avoid allocating a
     * new internal-rep if at all possible since that is potentially a slow
     * operation.
     */

    if (objPtr->typePtr == &indexType) {
 	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
    } else {
	TclFreeIntRep(objPtr);
 	indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
 	objPtr->internalRep.otherValuePtr = (VOID *) indexRep;
 	objPtr->typePtr = &indexType;
    }
    indexRep->tablePtr = (VOID*) tablePtr;
    indexRep->offset = offset;
    indexRep->index = index;

    *indexPtr = index;
    return TCL_OK;

  error:
    if (interp != NULL) {
	/*
	 * Produce a fancy error message.
	 */

	int count;

	TclNewObj(resultPtr);
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_AppendStringsToObj(resultPtr,
		(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key,
		"\": must be ", STRING_AT(tablePtr,offset,0), (char*) NULL);
	for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
		*entryPtr != NULL;
		entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
	    if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
		Tcl_AppendStringsToObj(resultPtr,
			(count > 0) ? ", or " : " or ", *entryPtr,
			(char *) NULL);
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
}

/*
 *----------------------------------------------------------------------
 *
 * SetIndexFromAny --
 *
 *	This procedure is called to convert a Tcl object to index
 *	internal form. However, this doesn't make sense (need to have a
 *	table of keywords in order to do the conversion) so the
 *	procedure always generates an error.
 *
 * Results:
 *	The return value is always TCL_ERROR, and an error message is
 *	left in interp's result if interp isn't NULL. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|
|


|
|







292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
}

/*
 *----------------------------------------------------------------------
 *
 * SetIndexFromAny --
 *
 *	This function is called to convert a Tcl object to index internal
 *	form. However, this doesn't make sense (need to have a table of
 *	keywords in order to do the conversion) so the function always
 *	generates an error.
 *
 * Results:
 *	The return value is always TCL_ERROR, and an error message is left in
 *	interp's result if interp isn't NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfIndex --
 *
 *	This procedure is called to convert a Tcl object from index
 *	internal form to its string form.  No abbreviation is ever
 *	generated.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string representation of the object is updated.
 *







|
|
<







323
324
325
326
327
328
329
330
331

332
333
334
335
336
337
338
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfIndex --
 *
 *	This function is called to convert a Tcl object from index internal
 *	form to its string form. No abbreviation is ever generated.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string representation of the object is updated.
 *
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
}

/*
 *----------------------------------------------------------------------
 *
 * DupIndex --
 *
 *	This procedure is called to copy the internal rep of an index
 *	Tcl object from to another object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The internal representation of the target object is updated
 *	and the type is set.
 *
 *----------------------------------------------------------------------
 */

static void
DupIndex(srcPtr, dupPtr)
    Tcl_Obj *srcPtr, *dupPtr;
{
    IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;
    IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));

    memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
    dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;
    dupPtr->typePtr = &tclIndexType;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeIndex --
 *
 *	This procedure is called to delete the internal rep of an index
 *	Tcl object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The internal representation of the target object is deleted.
 *







|
|





|
|













|







|
|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
}

/*
 *----------------------------------------------------------------------
 *
 * DupIndex --
 *
 *	This function is called to copy the internal rep of an index Tcl
 *	object from to another object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The internal representation of the target object is updated and the
 *	type is set.
 *
 *----------------------------------------------------------------------
 */

static void
DupIndex(srcPtr, dupPtr)
    Tcl_Obj *srcPtr, *dupPtr;
{
    IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;
    IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));

    memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
    dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;
    dupPtr->typePtr = &indexType;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeIndex --
 *
 *	This function is called to delete the internal rep of an index Tcl
 *	object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The internal representation of the target object is deleted.
 *
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430















431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451











452
453
454
455
456
457
458
459

460
461

462
463
464




465
466

467
468
469
470
471
472
473




474
475
476
477

478
479



480




481
482

483
484
485
486

487
488
489
490
491
492
493

494
495

496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524

525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541

542
543

544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576

577








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WrongNumArgs --
 *
 *	This procedure generates a "wrong # args" error message in an
 *	interpreter.  It is used as a utility function by many command
 *	procedures.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is generated in interp's result object to
 *	indicate that a command was invoked with the wrong number of
 *	arguments.  The message has the form
 *		wrong # args: should be "foo bar additional stuff"
 *	where "foo" and "bar" are the initial objects in objv (objc
 *	determines how many of these are printed) and "additional stuff"
 *	is the contents of the message argument.















 *
 *----------------------------------------------------------------------
 */

void
Tcl_WrongNumArgs(interp, objc, objv, message)
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments to print
					 * from objv. */
    Tcl_Obj *CONST objv[];		/* Initial argument objects, which
					 * should be included in the error
					 * message. */
    CONST char *message;		/* Error message to print after the
					 * leading objects in objv. The
					 * message may be NULL. */
{
    Tcl_Obj *objPtr;
    int i, len, elemLen, flags;
    register IndexRep *indexRep;
    Interp *iPtr = (Interp *) interp;
    char *elementStr;











#ifndef AVOID_HACKS_FOR_ITCL
    int isFirst = 1;			/* Special flag used to inhibit the
					 * treating of the first word as a
					 * list element so the hacky way Itcl
					 * does error message generation for
					 * ensembles will still work.
					 * [Bug 1066837] */
#define MAY_QUOTE_WORD (!isFirst)

#else /* !AVOID_HACKS_FOR_ITCL */
#define MAY_QUOTE_WORD 1

#endif /* AVOID_HACKS_FOR_ITCL */

    TclNewObj(objPtr);




    Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);


    /*
     * Check to see if we are processing an ensemble implementation,
     * and if so rewrite the results in terms of how the ensemble was
     * invoked.
     */

    if (iPtr->ensembleRewrite.sourceObjs != NULL) {




	/*
	 * We only know how to do rewriting if all the replaced
	 * objects are actually arguments (in objv) to this function.
	 * Otherwise it just gets too complicated...

	 */




	if (objc >= iPtr->ensembleRewrite.numInsertedObjs) {




	    objv += iPtr->ensembleRewrite.numInsertedObjs;
	    objc -= iPtr->ensembleRewrite.numInsertedObjs;

	    /*
	     * We assume no object is of index type.
	     */
	    for (i=0 ; i<iPtr->ensembleRewrite.numRemovedObjs ; i++) {

		/*
		 * Add the element, quoting it if necessary.
		 */

		elementStr = Tcl_GetStringFromObj(
			iPtr->ensembleRewrite.sourceObjs[i], &elemLen);
		len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);

		if (MAY_QUOTE_WORD && len != elemLen) {
		    char *quotedElementStr = ckalloc((unsigned) len);

		    len = Tcl_ConvertCountedElement(elementStr, elemLen,
			    quotedElementStr, flags);
		    Tcl_AppendToObj(objPtr, quotedElementStr, len);
		    ckfree(quotedElementStr);
		} else {
		    Tcl_AppendToObj(objPtr, elementStr, elemLen);
		}
#ifndef AVOID_HACKS_FOR_ITCL
		isFirst = 0;
#endif /* AVOID_HACKS_FOR_ITCL */

		/*
		 * Add a space if the word is not the last one (which
		 * has a moderately complex condition here).
		 */

		if ((i < (iPtr->ensembleRewrite.numRemovedObjs - 1))
			|| objc || message) {
		    Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
		}
	    }
	}
    }

    /*
     * Now add the arguments (other than those rewritten) that the
     * caller took from its calling context.
     */


    for (i = 0; i < objc; i++) {
	/*
	 * If the object is an index type use the index table which allows
	 * for the correct error message even if the subcommand was
	 * abbreviated.  Otherwise, just use the string rep.
	 */
	
	if (objv[i]->typePtr == &tclIndexType) {
	    indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;
	    Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);
	} else {
	    /*
	     * Quote the argument if it contains spaces (Bug 942757).
	     */

	    elementStr = Tcl_GetStringFromObj(objv[i], &elemLen);
	    len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);

	    if (MAY_QUOTE_WORD && len != elemLen) {
		char *quotedElementStr = ckalloc((unsigned) len);

		len = Tcl_ConvertCountedElement(elementStr, elemLen,
			quotedElementStr, flags);
		Tcl_AppendToObj(objPtr, quotedElementStr, len);
		ckfree(quotedElementStr);
	    } else {
		Tcl_AppendToObj(objPtr, elementStr, elemLen);
	    }
	}
#ifndef AVOID_HACKS_FOR_ITCL
	isFirst = 0;
#endif /* AVOID_HACKS_FOR_ITCL */

	/*
	 * Append a space character (" ") if there is more text to follow
	 * (either another element from objv, or the message string).
	 */
	if ((i < (objc - 1)) || message) {

	    Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
	}
    }

    /*
     * Add any trailing message bits and set the resulting string as
     * the interpreter result. Caller is responsible for reporting
     * this as an actual error.
     */

    if (message) {
	Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);
    }
    Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
    Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD

}















|
|
|





|
|
|

|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|
<
|
|
<
|
|
|






>
>
>
>
>
>
>
>
>
>
>

|
|
|
<
|
|
|
>

|
>



>
>
>
>
|
|
>

|
|
<



>
>
>
>

|
|
|
>


>
>
>
|
>
>
>
>
|
|
>
|
|
|
|
>
|
|
|

|
<
|
>
|
|
>
|
|
|
|
|
|
|
|
|
<

|
|
|
|

<
|
|
|
|
|
|
<

|
|


>


|
|
|

|
|









>


>








|
|
<





|
>





|
|
|


|





>

>
>
>
>
>
>
>
>
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454

455
456

457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

536
537
538
539
540
541
542
543
544
545
546
547
548
549

550
551
552
553
554
555

556
557
558
559
560
561

562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598

599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WrongNumArgs --
 *
 *	This function generates a "wrong # args" error message in an
 *	interpreter. It is used as a utility function by many command
 *	functions, including the function that implements procedures.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is generated in interp's result object to indicate
 *	that a command was invoked with the wrong number of arguments. The
 *	message has the form
 *		wrong # args: should be "foo bar additional stuff"
 *	where "foo" and "bar" are the initial objects in objv (objc determines
 *	how many of these are printed) and "additional stuff" is the contents
 *	of the message argument.
 *
 *	The message printed is modified somewhat if the command is wrapped
 *	inside an ensemble. In that case, the error message generated is
 *	rewritten in such a way that it appears to be generated from the
 *	user-visible command and not how that command is actually implemented,
 *	giving a better overall user experience.
 *
 *	Internally, the Tcl core may set the flag INTERP_ALTERNATE_WRONG_ARGS
 *	in the interpreter to generate complex multi-part messages by calling
 *	this function repeatedly. This allows the code that knows how to
 *	handle ensemble-related error messages to be kept here while still
 *	generating suitable error messages for commands like [read] and
 *	[socket]. Ideally, this would be done through an extra flags argument,
 *	but that wouldn't be source-compatible with the existing API and it's
 *	a fairly rare requirement anyway.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_WrongNumArgs(interp, objc, objv, message)
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments to print from objv. */

    Tcl_Obj *CONST objv[];	/* Initial argument objects, which should be
				 * included in the error message. */

    CONST char *message;	/* Error message to print after the leading
				 * objects in objv. The message may be
				 * NULL. */
{
    Tcl_Obj *objPtr;
    int i, len, elemLen, flags;
    register IndexRep *indexRep;
    Interp *iPtr = (Interp *) interp;
    char *elementStr;

    /*
     * [incr Tcl] does something fairly horrific when generating error
     * messages for its ensembles; it passes the whole set of ensemble
     * arguments as a list in the first argument. This means that this code
     * causes a problem in iTcl if it attempts to correctly quote all
     * arguments, which would be the correct thing to do. We work around this
     * nasty behaviour for now, and hope that we can remove it all in the
     * future...
     */

#ifndef AVOID_HACKS_FOR_ITCL
    int isFirst = 1;		/* Special flag used to inhibit the treating
				 * of the first word as a list element so the
				 * hacky way Itcl generates error messages for

				 * its ensembles will still work. [Bug
				 * 1066837] */
#   define MAY_QUOTE_WORD	(!isFirst)
#   define AFTER_FIRST_WORD	(isFirst = 0)
#else /* !AVOID_HACKS_FOR_ITCL */
#   define MAY_QUOTE_WORD	1
#   define AFTER_FIRST_WORD	(void) 0
#endif /* AVOID_HACKS_FOR_ITCL */

    TclNewObj(objPtr);
    if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
	Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
	Tcl_AppendToObj(objPtr, " or \"", -1);
    } else {
	Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
    }

    /*
     * Check to see if we are processing an ensemble implementation, and if so
     * rewrite the results in terms of how the ensemble was invoked.

     */

    if (iPtr->ensembleRewrite.sourceObjs != NULL) {
	int toSkip = iPtr->ensembleRewrite.numInsertedObjs;
	int toPrint = iPtr->ensembleRewrite.numRemovedObjs;
	Tcl_Obj * CONST *origObjv = iPtr->ensembleRewrite.sourceObjs;

	/*
	 * We only know how to do rewriting if all the replaced objects are
	 * actually arguments (in objv) to this function. Otherwise it just
	 * gets too complicated and we'd be better off just giving a slightly
	 * confusing error message...
	 */

	if (objc < toSkip) {
	    goto addNormalArgumentsToMessage;
	}

	/*
	 * Strip out the actual arguments that the ensemble inserted.
	 */

	objv += toSkip;
	objc -= toSkip;

	/*
	 * We assume no object is of index type.
	 */

	for (i=0 ; i<toPrint ; i++) {
	    /*
	     * Add the element, quoting it if necessary.
	     */

	    elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen);

	    len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);

	    if (MAY_QUOTE_WORD && len != elemLen) {
		char *quotedElementStr = ckalloc((unsigned) len);

		len = Tcl_ConvertCountedElement(elementStr, elemLen,
			quotedElementStr, flags);
		Tcl_AppendToObj(objPtr, quotedElementStr, len);
		ckfree(quotedElementStr);
	    } else {
		Tcl_AppendToObj(objPtr, elementStr, elemLen);
	    }

	    AFTER_FIRST_WORD;


	    /*
	     * Add a space if the word is not the last one (which has a
	     * moderately complex condition here).
	     */


	    if (i<toPrint-1 || objc!=0 || message!=NULL) {
		Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
	    }
	}
    }


    /*
     * Now add the arguments (other than those rewritten) that the caller took
     * from its calling context.
     */

  addNormalArgumentsToMessage:
    for (i = 0; i < objc; i++) {
	/*
	 * If the object is an index type use the index table which allows for
	 * the correct error message even if the subcommand was abbreviated.
	 * Otherwise, just use the string rep.
	 */

	if (objv[i]->typePtr == &indexType) {
	    indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;
	    Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);
	} else {
	    /*
	     * Quote the argument if it contains spaces (Bug 942757).
	     */

	    elementStr = Tcl_GetStringFromObj(objv[i], &elemLen);
	    len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);

	    if (MAY_QUOTE_WORD && len != elemLen) {
		char *quotedElementStr = ckalloc((unsigned) len);

		len = Tcl_ConvertCountedElement(elementStr, elemLen,
			quotedElementStr, flags);
		Tcl_AppendToObj(objPtr, quotedElementStr, len);
		ckfree(quotedElementStr);
	    } else {
		Tcl_AppendToObj(objPtr, elementStr, elemLen);
	    }
	}

	AFTER_FIRST_WORD;


	/*
	 * Append a space character (" ") if there is more text to follow
	 * (either another element from objv, or the message string).
	 */

	if (i<objc-1 || message!=NULL) {
	    Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
	}
    }

    /*
     * Add any trailing message bits and set the resulting string as the
     * interpreter result. Caller is responsible for reporting this as an
     * actual error.
     */

    if (message != NULL) {
	Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);
    }
    Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
    Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD
#undef AFTER_FIRST_WORD
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclInt.decls.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tclInt.decls,v 1.84 2004/12/01 23:18:50 dgp Exp $

library tcl

# Define the unsupported generic interfaces.

interface tclInt








|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tclInt.decls,v 1.84.2.12 2005/08/23 06:15:21 dgp Exp $

library tcl

# Define the unsupported generic interfaces.

interface tclInt

110
111
112
113
114
115
116

117
118
119

120
121
122
123
124
125
126
    int TclFindElement(Tcl_Interp *interp, CONST char *listStr,
	    int listLength, CONST char **elementPtr, CONST char **nextPtr,
	    int *sizePtr, int *bracePtr)
}
declare 23 generic {
    Proc *TclFindProc(Interp *iPtr, CONST char *procName)
}

declare 24 generic {
    int TclFormatInt(char *buffer, long n)
}

declare 25 generic {
    void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
#  declare 26 generic {
#      char *TclGetCwd(Tcl_Interp *interp)
#  }







>
|
|
<
>







110
111
112
113
114
115
116
117
118
119

120
121
122
123
124
125
126
127
    int TclFindElement(Tcl_Interp *interp, CONST char *listStr,
	    int listLength, CONST char **elementPtr, CONST char **nextPtr,
	    int *sizePtr, int *bracePtr)
}
declare 23 generic {
    Proc *TclFindProc(Interp *iPtr, CONST char *procName)
}
# Replaced with macro (see tclInt.h) in Tcl 8.5
#declare 24 generic {
#    int TclFormatInt(char *buffer, long n)

#}
declare 25 generic {
    void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
#  declare 26 generic {
#      char *TclGetCwd(Tcl_Interp *interp)
#  }
205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
#	    int localIndex, Tcl_Obj *elemPtr, long incrAmount)
#}
# Removed in 8.4b2:
#declare 48 generic {
#    Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    long incrAmount)
#}
declare 49 generic {
    Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
	    Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
}

declare 50 generic {
    void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
	    Namespace *nsPtr)
}
declare 51 generic {
    int TclInterpInit(Tcl_Interp *interp)
}







|
|
|
<
>







206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
#	    int localIndex, Tcl_Obj *elemPtr, long incrAmount)
#}
# Removed in 8.4b2:
#declare 48 generic {
#    Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    long incrAmount)
#}
#declare 49 generic {
#    Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
#	    Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)

#}
declare 50 generic {
    void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
	    Namespace *nsPtr)
}
declare 51 generic {
    int TclInterpInit(Tcl_Interp *interp)
}
548
549
550
551
552
553
554
555
556
557

558
559
560
561
562
563
564
    CONST84_RETURN char *TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
}
#declare 139 generic {
#    int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
#	    char *sym2, Tcl_PackageInitProc **proc1Ptr,
#	    Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
#}
declare 140 generic {
    int TclLooksLikeInt(CONST char *bytes, int length)
}

# This is used by TclX, but should otherwise be considered private
declare 141 generic {
    CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 generic {
    int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CompileHookProc *hookProc, ClientData clientData)







|
|
<
>







549
550
551
552
553
554
555
556
557

558
559
560
561
562
563
564
565
    CONST84_RETURN char *TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
}
#declare 139 generic {
#    int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
#	    char *sym2, Tcl_PackageInitProc **proc1Ptr,
#	    Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
#}
#declare 140 generic {
#    int TclLooksLikeInt(CONST char *bytes, int length)

#}
# This is used by TclX, but should otherwise be considered private
declare 141 generic {
    CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 generic {
    int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CompileHookProc *hookProc, ClientData clientData)
704
705
706
707
708
709
710
711
712
713
714

715
716
717
718
719
720
721
declare 173 generic {
    int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen,
	    CONST Tcl_UniChar *pattern, int ptnLen, int nocase)
}

# added for 8.4.3

declare 174 generic {
    Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
	    Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
}


# Factoring out of trace code

declare 175 generic {
    int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
	    CONST char *part1, CONST char *part2, int flags, int leaveErrMsg)
}







|
|
|
<
>







705
706
707
708
709
710
711
712
713
714

715
716
717
718
719
720
721
722
declare 173 generic {
    int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen,
	    CONST Tcl_UniChar *pattern, int ptnLen, int nocase)
}

# added for 8.4.3

#declare 174 generic {
#    Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
#	    Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)

#}

# Factoring out of trace code

declare 175 generic {
    int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
	    CONST char *part1, CONST char *part2, int flags, int leaveErrMsg)
}
730
731
732
733
734
735
736

737
738
739
740

741
742
743
744

745
746
747
748
749
750
751
752
753
754
755
756



757
758
759

760
761
762

763
764
765

766
767
768

769
770
771

772
773
774

775
776
777

778
779
780

781
782
783

784
785
786

787
788
789

790
791
792

793
794
795

796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811

812
813
814
815
816
817
818
declare 178 generic {
    void Tcl_SetStartupScript(Tcl_Obj *pathPtr, CONST char* encodingName)
}
declare 179 generic {
    Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr)
}


# Allocate lists without copying arrays
declare 180 generic {
    Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
}

declare 181 generic {
    Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
	    CONST char *file, int line)
}


# TclpGmtime and TclpLocaltime promoted to the generic interface from unix

declare 182 generic {
     struct tm *TclpLocaltime(CONST time_t *clock)
}
declare 183 generic {
     struct tm *TclpGmtime(CONST time_t *clock)
}

# For the new "Thread Storage" subsystem.




declare 184 generic {
     void TclThreadStorageLockInit(void)     
}

declare 185 generic {
     void TclThreadStorageLock(void)     
}

declare 186 generic {
     void TclThreadStorageUnlock(void)     
}

declare 187 generic {
     void TclThreadStoragePrint(FILE *outFile, int flags)     
}

declare 188 generic {
     Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id)     
}

declare 189 generic {
     Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved)     
}

declare 190 generic {
     void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr)     
}

declare 191 generic {
     void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr)     
}

declare 192 generic {
     void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data)     
}

declare 193 generic {
     void TclFinalizeThreadStorageThread(Tcl_ThreadId id)     
}

declare 194 generic {
     void TclFinalizeThreadStorage(void)     
}

declare 195 generic {
     void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr)     
}

declare 196 generic {
     void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr)
}


#
# Added in tcl8.5a5 for compiler/executor experimentation.
#
declare 197 generic {
    int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr)
}

declare 198 generic {
    int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CallFrame **framePtrPtr)
}

declare 199 generic {
    int TclMatchIsTrivial(CONST char *pattern)
}


# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 generic {
    int TclpObjRemoveDirectory (Tcl_Obj *pathPtr, int recursive,
	Tcl_Obj **errorPtr)
}
declare 201 generic {







>

|
|
<
>
|
|
|
<
>












>
>
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>
|
|
<
>













|
|
<
>







731
732
733
734
735
736
737
738
739
740
741

742
743
744
745

746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763

764
765
766

767
768
769

770
771
772

773
774
775

776
777
778

779
780
781

782
783
784

785
786
787

788
789
790

791
792
793

794
795
796

797
798
799

800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815

816
817
818
819
820
821
822
823
declare 178 generic {
    void Tcl_SetStartupScript(Tcl_Obj *pathPtr, CONST char* encodingName)
}
declare 179 generic {
    Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr)
}

# REMOVED
# Allocate lists without copying arrays
# declare 180 generic {
#    Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)

# }
#declare 181 generic {
#    Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
#	    CONST char *file, int line)

#}

# TclpGmtime and TclpLocaltime promoted to the generic interface from unix

declare 182 generic {
     struct tm *TclpLocaltime(CONST time_t *clock)
}
declare 183 generic {
     struct tm *TclpGmtime(CONST time_t *clock)
}

# For the new "Thread Storage" subsystem.

### REMOVED on grounds it should never have been exposed. All these
### functions are now either static in tclThreadStorage.c or
### MODULE_SCOPE.
# declare 184 generic {
#      void TclThreadStorageLockInit(void)

# }
# declare 185 generic {
#      void TclThreadStorageLock(void)

# }
# declare 186 generic {
#      void TclThreadStorageUnlock(void)

# }
# declare 187 generic {
#      void TclThreadStoragePrint(FILE *outFile, int flags)

# }
# declare 188 generic {
#      Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id)

# }
# declare 189 generic {
#      Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved)

# }
# declare 190 generic {
#      void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr)

# }
# declare 191 generic {
#      void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr)

# }
# declare 192 generic {
#      void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data)

# }
# declare 193 generic {
#      void TclFinalizeThreadStorageThread(Tcl_ThreadId id)

# }
# declare 194 generic {
#      void TclFinalizeThreadStorage(void)

# }
# declare 195 generic {
#      void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr)

# }
# declare 196 generic {
#      void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr)

# }

#
# Added in tcl8.5a5 for compiler/executor experimentation.
#
declare 197 generic {
    int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr)
}

declare 198 generic {
    int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CallFrame **framePtrPtr)
}

#declare 199 generic {
#    int TclMatchIsTrivial(CONST char *pattern)

#}

# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 generic {
    int TclpObjRemoveDirectory (Tcl_Obj *pathPtr, int recursive,
	Tcl_Obj **errorPtr)
}
declare 201 generic {
855
856
857
858
859
860
861









































862
863
864
865
866
867
868
}
declare 213 generic {
    Tcl_Obj * TclGetObjNameOfExecutable(void)
}
declare 214 generic {
    void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}










































##############################################################################

# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.

interface tclIntPlat







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
}
declare 213 generic {
    Tcl_Obj * TclGetObjNameOfExecutable(void)
}
declare 214 generic {
    void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 generic {
    char * TclStackAlloc(Tcl_Interp *interp, int numBytes)
}
declare 216 generic {
    void TclStackFree(Tcl_Interp *interp)
}
declare 217 generic {
    int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
            Tcl_Namespace *namespacePtr, int isProcCallFrame )
}
declare 218 generic {
    void TclPopStackFrame(Tcl_Interp *interp)
}

# Entries in tommath needed only by tcltest

declare 219 generic {
    int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
}
declare 220 generic {
    int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *c)
}
declare 221 generic {
    void TclBN_mp_clear(mp_int *a)
}
declare 222 generic {
    int TclBN_mp_init(mp_int *a)
}
declare 223 generic {
    int TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
}
# for use in tclTest.c
declare 224 generic {
    TclPlatformType *TclGetPlatform(void)
}

# 
declare 225 generic {
    Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
	    int keyc, Tcl_Obj *CONST keyv[], int flags)
}

##############################################################################

# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.

interface tclIntPlat
957
958
959
960
961
962
963

964
965
966

967
968
969
970
971
972
973
}
declare 23 win {
    char *TclpGetTZName(int isdst)
}
declare 24 win {
    char *TclWinNoBackslash(char *path)
}

declare 25 win {
    TclPlatformType *TclWinGetPlatform(void)
}

declare 26 win {
    void TclWinSetInterfaces(int wide)
}

# Added in Tcl 8.3.3 / 8.4

declare 27 win {







>
|
|
<
>







1003
1004
1005
1006
1007
1008
1009
1010
1011
1012

1013
1014
1015
1016
1017
1018
1019
1020
}
declare 23 win {
    char *TclpGetTZName(int isdst)
}
declare 24 win {
    char *TclWinNoBackslash(char *path)
}
# replaced by generic TclGetPlatform
#declare 25 win {
#    TclPlatformType *TclWinGetPlatform(void)

#}
declare 26 win {
    void TclWinSetInterfaces(int wide)
}

# Added in Tcl 8.3.3 / 8.4

declare 27 win {

Changes to generic/tclInt.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36



37
38
39
40
41
42
43
/*
 * tclInt.h --
 *
 *	Declarations of things used internally by the Tcl interpreter.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202 2004/12/01 23:18:51 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*







 * Common include files needed by most of the Tcl source files are
 * included here, so that system-dependent personalizations for the
 * include files only have to be made in once place.  This results
 * in a few extra includes, but greater modularity.  The order of
 * the three groups of #includes is important.	For example, stdio.h
 * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is
 * needed by stdlib.h in some configurations.
 */

#ifndef _TCL
#include "tcl.h"
#endif
#ifdef HAVE_TCL_CONFIG_H
#include "tclConfig.h"
#endif




#include <stdio.h>

#include <ctype.h>
#ifdef NO_LIMITS_H
#   include "../compat/limits.h"
#else











|
|

|






>
>
>
>
>
>
>
|
|
|
<
|
|
|


<
<
<



>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

32
33
34
35
36



37
38
39
40
41
42
43
44
45
46
47
48
49
/*
 * tclInt.h --
 *
 *	Declarations of things used internally by the Tcl interpreter.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.42 2005/10/07 20:15:09 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
 */

#undef NO_WIDE_TYPE
#undef ACCEPT_NAN

/*
 * Common include files needed by most of the Tcl source files are included
 * here, so that system-dependent personalizations for the include files only
 * have to be made in once place. This results in a few extra includes, but

 * greater modularity. The order of the three groups of #includes is
 * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_
 * declaration in tcl.h is needed by stdlib.h in some configurations.
 */




#ifdef HAVE_TCL_CONFIG_H
#include "tclConfig.h"
#endif
#ifndef _TCL
#include "tcl.h"
#endif

#include <stdio.h>

#include <ctype.h>
#ifdef NO_LIMITS_H
#   include "../compat/limits.h"
#else
56
57
58
59
60
61
62


























63
64
65
66
67
68
69
70
71
72
73
74
75
76








77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235







236



















237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

305
306
307
308
309
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335


336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512

513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
#ifdef STDC_HEADERS
#include <stddef.h>
#else
typedef int ptrdiff_t;
#endif

/*


























 * Used to tag functions that are only to be visible within the module
 * being built and not outside it (where this is supported by the
 * linker).
 */

#ifndef MODULE_SCOPE
#   ifdef __cplusplus
#	define MODULE_SCOPE extern "C"
#   else
#	define MODULE_SCOPE extern
#   endif
#endif

/*








 * The following procedures allow namespaces to be customized to
 * support special name resolution rules for commands/variables.
 * 
 */

struct Tcl_ResolvedVarInfo;

typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr));

typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_((
    struct Tcl_ResolvedVarInfo *vinfoPtr));

/*
 * The following structure encapsulates the routines needed to resolve a
 * variable reference at runtime.  Any variable specific state will typically
 * be appended to this structure.
 */


typedef struct Tcl_ResolvedVarInfo {
    Tcl_ResolveRuntimeVarProc *fetchProc;
    Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;



typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, CONST84 char* name, int length,
    Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr));

typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context,
    int flags, Tcl_Var *rPtr));

typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
    CONST84 char* name, Tcl_Namespace *context, int flags,
    Tcl_Command *rPtr));
 
typedef struct Tcl_ResolverInfo {
    Tcl_ResolveCmdProc *cmdResProc;	/* Procedure handling command name
					 * resolution. */
    Tcl_ResolveVarProc *varResProc;	/* Procedure handling variable name
					 * resolution for variables that
					 * can only be handled at runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarResProc;
					/* Procedure handling variable name
					 * resolution at compile time. */
} Tcl_ResolverInfo;

/*
 *----------------------------------------------------------------
 * Data structures related to namespaces.
 *----------------------------------------------------------------
 */

typedef struct Tcl_Ensemble Tcl_Ensemble;


/*
 * The structure below defines a namespace.
 * Note: the first five fields must match exactly the fields in a
 * Tcl_Namespace structure (see tcl.h). If you change one, be sure to
 * change the other.
 */

typedef struct Namespace {
    char *name;			/* The namespace's simple (unqualified)
				 * name. This contains no ::'s. The name of
				 * the global namespace is "" although "::"
				 * is an synonym. */
    char *fullName;		/* The namespace's fully qualified name.
				 * This starts with ::. */
    ClientData clientData;	/* An arbitrary value associated with this
				 * namespace. */
    Tcl_NamespaceDeleteProc *deleteProc;
				/* Procedure invoked when deleting the
				 * namespace to, e.g., free clientData. */
    struct Namespace *parentPtr;/* Points to the namespace that contains
				 * this one. NULL if this is the global
				 * namespace. */
    Tcl_HashTable childTable;	/* Contains any child namespaces. Indexed
				 * by strings; values have type
				 * (Namespace *). */
    long nsId;			/* Unique id for the namespace. */
    Tcl_Interp *interp;		/* The interpreter containing this
				 * namespace. */
    int flags;			/* OR-ed combination of the namespace
				 * status flags NS_DYING and NS_DEAD
				 * listed below. */
    int activationCount;	/* Number of "activations" or active call
				 * frames for this namespace that are on
				 * the Tcl call stack. The namespace won't
				 * be freed until activationCount becomes
				 * zero. */
    int refCount;		/* Count of references by namespaceName *
				 * objects. The namespace can't be freed
				 * until refCount becomes zero. */
    Tcl_HashTable cmdTable;	/* Contains all the commands currently
				 * registered in the namespace. Indexed by
				 * strings; values have type (Command *).
				 * Commands imported by Tcl_Import have
				 * Command structures that point (via an
				 * ImportedCmdRef structure) to the
				 * Command structure in the source
				 * namespace's command table. */
    Tcl_HashTable varTable;	/* Contains all the (global) variables
				 * currently in this namespace. Indexed
				 * by strings; values have type (Var *). */
    char **exportArrayPtr;	/* Points to an array of string patterns
				 * specifying which commands are exported.
				 * A pattern may include "string match"
				 * style wildcard characters to specify
				 * multiple commands; however, no namespace
				 * qualifiers are allowed. NULL if no
				 * export patterns are registered. */
    int numExportPatterns;	/* Number of export patterns currently
				 * registered using "namespace export". */
    int maxExportPatterns;	/* Mumber of export patterns for which
				 * space is currently allocated. */
    int cmdRefEpoch;		/* Incremented if a newly added command
				 * shadows a command for which this
				 * namespace has already cached a Command *
				 * pointer; this causes all its cached
				 * Command* pointers to be invalidated. */
    int resolverEpoch;		/* Incremented whenever (a) the name resolution
				 * rules change for this namespace or (b) a 
				 * newly added command shadows a command that
				 * is compiled to bytecodes.
				 * This invalidates all byte codes compiled
				 * in the namespace, causing the code to be
				 * recompiled under the new rules.*/
    Tcl_ResolveCmdProc *cmdResProc;
				/* If non-null, this procedure overrides
				 * the usual command resolution mechanism
				 * in Tcl.  This procedure is invoked
				 * within Tcl_FindCommand to resolve all
				 * command references within the namespace. */
    Tcl_ResolveVarProc *varResProc;
				/* If non-null, this procedure overrides
				 * the usual variable resolution mechanism
				 * in Tcl.  This procedure is invoked
				 * within Tcl_FindNamespaceVar to resolve all
				 * variable references within the namespace
				 * at runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarResProc;
				/* If non-null, this procedure overrides
				 * the usual variable resolution mechanism
				 * in Tcl.  This procedure is invoked
				 * within LookupCompiledLocal to resolve
				 * variable references within the namespace
				 * at compile time. */
    int exportLookupEpoch;	/* Incremented whenever a command is added to
				 * a namespace, removed from a namespace or
				 * the exports of a namespace are changed.
				 * Allows TIP#112-driven command lists to be
				 * validated efficiently. */
    Tcl_Ensemble *ensembles;	/* List of structures that contain the details
				 * of the ensembles that are implemented on
				 * top of this namespace. */







} Namespace;




















/*
 * Flags used to represent the status of a namespace:
 *
 * NS_DYING -	1 means Tcl_DeleteNamespace has been called to delete the
 *		namespace but there are still active call frames on the Tcl
 *		stack that refer to the namespace. When the last call frame
 *		referring to it has been popped, it's variables and command
 *		will be destroyed and it will be marked "dead" (NS_DEAD).
 *		The namespace can no longer be looked up by name.
 * NS_DEAD -	1 means Tcl_DeleteNamespace has been called to delete the
 *		namespace and no call frames still refer to it. Its
 *		variables and command have already been destroyed. This bit
 *		allows the namespace resolution code to recognize that the
 *		namespace is "deleted". When the last namespaceName object
 *		in any byte code unit that refers to the namespace has
 *		been freed (i.e., when the namespace's refCount is 0), the
 *		namespace's storage will be freed.
 */

#define NS_DYING	0x01
#define NS_DEAD		0x02

/*
 * Flags passed to TclGetNamespaceForQualName:
 *
 * TCL_GLOBAL_ONLY		- (see tcl.h) Look only in the global ns. 
 * TCL_NAMESPACE_ONLY		- (see tcl.h) Look only in the context ns.
 * TCL_CREATE_NS_IF_UNKNOWN	- Create unknown namespaces.
 * TCL_FIND_ONLY_NS		- The name sought is a namespace name.
 */

#define TCL_CREATE_NS_IF_UNKNOWN	0x800
#define TCL_FIND_ONLY_NS		0x1000

/*
 *----------------------------------------------------------------
 * Data structures related to variables.   These are used primarily
 * in tclVar.c
 *----------------------------------------------------------------
 */

/*
 * The following structure defines a variable trace, which is used to
 * invoke a specific C procedure whenever certain operations are performed
 * on a variable.
 */

typedef struct VarTrace {
    Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given
				 * by flags are performed on variable. */
    ClientData clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in:  OR-ed combination of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
    struct VarTrace *nextPtr;	/* Next in list of traces associated with
				 * a particular variable. */
} VarTrace;

/*
 * The following structure defines a command trace, which is used to
 * invoke a specific C procedure whenever certain operations are performed
 * on a command.
 */

typedef struct CommandTrace {
    Tcl_CommandTraceProc *traceProc;/* Procedure to call when operations given

				     * by flags are performed on command. */
    ClientData clientData;	    /* Argument to pass to proc. */
    int flags;			    /* What events the trace procedure is
				     * interested in:  OR-ed combination of
				     * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;   /* Next in list of traces associated with

				     * a particular command. */
    int refCount;		    /* Used to ensure this structure is
				     * not deleted too early.  Keeps track
				     * of how many pieces of code have
				     * a pointer to this structure. */
} CommandTrace;

/*
 * When a command trace is active (i.e. its associated procedure is
 * executing), one of the following structures is linked into a list
 * associated with the command's interpreter.  The information in
 * the structure is needed in order for Tcl to behave reasonably
 * if traces are deleted while traces are active.
 */

typedef struct ActiveCommandTrace {
    struct Command *cmdPtr;	/* Command that's being traced. */
    struct ActiveCommandTrace *nextPtr;
				/* Next in list of all active command
				 * traces for the interpreter, or NULL
				 * if no more. */
    CommandTrace *nextTracePtr;	/* Next trace to check after current
				 * trace procedure returns;  if this
				 * trace gets deleted, must update pointer
				 * to avoid using free'd memory. */


} ActiveCommandTrace;

/*
 * When a variable trace is active (i.e. its associated procedure is
 * executing), one of the following structures is linked into a list
 * associated with the variable's interpreter.	The information in
 * the structure is needed in order for Tcl to behave reasonably
 * if traces are deleted while traces are active.
 */

typedef struct ActiveVarTrace {
    struct Var *varPtr;		/* Variable that's being traced. */
    struct ActiveVarTrace *nextPtr;
				/* Next in list of all active variable
				 * traces for the interpreter, or NULL
				 * if no more. */
    VarTrace *nextTracePtr;	/* Next trace to check after current
				 * trace procedure returns;  if this
				 * trace gets deleted, must update pointer
				 * to avoid using free'd memory. */
} ActiveVarTrace;

/*
 * The following structure describes an enumerative search in progress on
 * an array variable;  this are invoked with options to the "array"
 * command.
 */

typedef struct ArraySearch {
    int id;			/* Integer id used to distinguish among
				 * multiple concurrent searches for the
				 * same array. */
    struct Var *varPtr;		/* Pointer to array variable that's being
				 * searched. */
    Tcl_HashSearch search;	/* Info kept by the hash module about
				 * progress through the array. */
    Tcl_HashEntry *nextEntry;	/* Non-null means this is the next element
				 * to be enumerated (it's leftover from
				 * the Tcl_FirstHashEntry call or from
				 * an "array anymore" command).	 NULL
				 * means must call Tcl_NextHashEntry
				 * to get value to return. */
    struct ArraySearch *nextPtr;/* Next in list of all active searches
				 * for this variable, or NULL if this is
				 * the last one. */
} ArraySearch;

/*
 * The structure below defines a variable, which associates a string name
 * with a Tcl_Obj value. These structures are kept in procedure call frames
 * (for local variables recognized by the compiler) or in the heap (for
 * global variables and any variable not known to the compiler). For each
 * Var structure in the heap, a hash table entry holds the variable name and
 * a pointer to the Var structure.
 */

typedef struct Var {
    union {
	Tcl_Obj *objPtr;	/* The variable's object value. Used for 
				 * scalar variables and array elements. */
	Tcl_HashTable *tablePtr;/* For array variables, this points to
				 * information about the hash table used
				 * to implement the associative array. 
				 * Points to malloc-ed data. */
	struct Var *linkPtr;	/* If this is a global variable being
				 * referred to in a procedure, or a variable
				 * created by "upvar", this field points to
				 * the referenced variable's Var struct. */
    } value;
    char *name;			/* NULL if the variable is in a hashtable,
				 * otherwise points to the variable's
				 * name. It is used, e.g., by TclLookupVar
				 * and "info locals". The storage for the
				 * characters of the name is not owned by
				 * the Var and must not be freed when
				 * freeing the Var. */
    Namespace *nsPtr;		/* Points to the namespace that contains
				 * this variable or NULL if the variable is
				 * a local variable in a Tcl procedure. */
    Tcl_HashEntry *hPtr;	/* If variable is in a hashtable, either the
				 * hash table entry that refers to this
				 * variable or NULL if the variable has been
				 * detached from its hash table (e.g. an
				 * array is deleted, but some of its
				 * elements are still referred to in
				 * upvars). NULL if the variable is not in a
				 * hashtable. This is used to delete an
				 * variable from its hashtable if it is no
				 * longer needed. */
    int refCount;		/* Counts number of active uses of this
				 * variable, not including its entry in the
				 * call frame or the hash table: 1 for each
				 * additional variable whose linkPtr points
				 * here, 1 for each nested trace active on
				 * variable, and 1 if the variable is a 
				 * namespace variable. This record can't be
				 * deleted until refCount becomes 0. */
    VarTrace *tracePtr;		/* First in list of all traces set for this
				 * variable. */
    ArraySearch *searchPtr;	/* First in list of all searches active
				 * for this variable, or NULL if none. */
    int flags;			/* Miscellaneous bits of information about
				 * variable. See below for definitions. */
} Var;

/*
 * Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and
 * VAR_LINK) are mutually exclusive and give the "type" of the variable.
 * VAR_UNDEFINED is independent of the variable's type. 
 *
 * VAR_SCALAR -			1 means this is a scalar variable and not
 *				an array or link. The "objPtr" field points
 *				to the variable's value, a Tcl object.
 * VAR_ARRAY -			1 means this is an array variable rather
 *				than a scalar variable or link. The
 *				"tablePtr" field points to the array's
 *				hashtable for its elements.
 * VAR_LINK -			1 means this Var structure contains a
 *				pointer to another Var structure that
 *				either has the real value or is itself
 *				another VAR_LINK pointer. Variables like
 *				this come about through "upvar" and "global"
 *				commands, or through references to variables
 *				in enclosing namespaces.
 * VAR_UNDEFINED -		1 means that the variable is in the process
 *				of being deleted. An undefined variable
 *				logically does not exist and survives only
 *				while it has a trace, or if it is a global
 *				variable currently being used by some
 *				procedure.
 * VAR_IN_HASHTABLE -		1 means this variable is in a hashtable and
 *				the Var structure is malloced. 0 if it is
 *				a local variable that was assigned a slot
 *				in a procedure frame by	the compiler so the
 *				Var storage is part of the call frame.
 * VAR_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a read or write access, so
 *				new read or write accesses should not cause
 *				trace procedures to be called and the
 *				variable can't be deleted.
 * VAR_ARRAY_ELEMENT -		1 means that this variable is an array
 *				element, so it is not legal for it to be
 *				an array itself (the VAR_ARRAY flag had
 *				better not be set).
 * VAR_NAMESPACE_VAR -		1 means that this variable was declared
 *				as a namespace variable. This flag ensures
 *				it persists until its namespace is
 *				destroyed or until the variable is unset;
 *				it will persist even if it has not been
 *				initialized and is marked undefined.
 *				The variable's refCount is incremented to
 *				reflect the "reference" from its namespace.
 *
 * The following additional flags are used with the CompiledLocal type
 * defined below:
 *
 * VAR_ARGUMENT -		1 means that this variable holds a procedure
 *				argument. 
 * VAR_TEMPORARY -		1 if the local variable is an anonymous
 *				temporary variable. Temporaries have a NULL
 *				name.
 * VAR_RESOLVED -		1 if name resolution has been done for this
 *				variable.
 */

#define VAR_SCALAR		0x1
#define VAR_ARRAY		0x2
#define VAR_LINK		0x4
#define VAR_UNDEFINED		0x8
#define VAR_IN_HASHTABLE	0x10
#define VAR_TRACE_ACTIVE	0x20
#define VAR_ARRAY_ELEMENT	0x40
#define VAR_NAMESPACE_VAR	0x80

#define VAR_ARGUMENT		0x100
#define VAR_TEMPORARY		0x200
#define VAR_RESOLVED		0x400	


/*
 * Macros to ensure that various flag bits are set properly for variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclSetVarScalar _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE void	TclSetVarArray _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE void	TclSetVarLink _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE void	TclSetVarArrayElement _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE void	TclSetVarUndefined _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE void	TclClearVarUndefined _ANSI_ARGS_((Var *varPtr));
 */

#define TclSetVarScalar(varPtr) \
    (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR

#define TclSetVarArray(varPtr) \
    (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<











>
>
>
>
>
>
>
>
|
|
<




|
|

|
<



|


<






<
<
|
|
|

|
<
|

|
|
<
|


















>




|
|



|
|
|
|
|
|





|
|

|
|
<



|
|
<

|
|
|
<
|
|
|





|
|
|

|
|

|
|
|
|
|
|


|
|

|
|
|
|
|
|
|
|
|
|


|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|








>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|
|

|
|
|
|
|
|
|



















|
<




|
|
|



|
|


|


|
|



|
|
|



|
>
|
|
|
|
|
|
>
|
|
|
|
|



|
|
<
|
|





|
|
<
|
|
|
|
>
>




|
|
|
|





|
|
<
|
|
|
|



|
|
<




|
|


|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|




|


|
|
|
|
|
|
|


|
|
|
|
<
|
|
|
|



|
|
|
|
|
|
<





|




|
|







|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<

|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|


|


















|
>





|
|
|
|
|
|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124
125

126
127
128
129
130
131

132
133
134
135
136
137


138
139
140
141
142

143
144
145
146

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191

192
193
194
195
196

197
198
199
200

201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330

331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

378
379
380
381
382
383
384
385
386

387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407

408
409
410
411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464

465
466
467
468
469
470
471
472
473
474
475
476
477

478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
#ifdef STDC_HEADERS
#include <stddef.h>
#else
typedef int ptrdiff_t;
#endif

/*
 * Ensure WORDS_BIGENDIAN is defined correcly:
 * Needs to happen here in addition to configure to work with fat compiles on
 * Darwin (i.e. ppc and i386 at the same time).
 */

#ifdef HAVE_SYS_TYPES_H
#    include <sys/types.h>
#endif
#ifdef HAVE_SYS_PARAM_H
#    include <sys/param.h>
#endif
#ifdef BYTE_ORDER
#    ifdef BIG_ENDIAN
#	 if BYTE_ORDER == BIG_ENDIAN
#	     undef WORDS_BIGENDIAN
#	     define WORDS_BIGENDIAN
#	 endif
#    endif
#    ifdef LITTLE_ENDIAN
#	 if BYTE_ORDER == LITTLE_ENDIAN
#	     undef WORDS_BIGENDIAN
#	 endif
#    endif
#endif

/*
 * Used to tag functions that are only to be visible within the module being
 * built and not outside it (where this is supported by the linker).

 */

#ifndef MODULE_SCOPE
#   ifdef __cplusplus
#	define MODULE_SCOPE extern "C"
#   else
#	define MODULE_SCOPE extern
#   endif
#endif

/*
 * When Tcl_WideInt and long are the same type, there's no value in
 * having a tclWideIntType separate from the tclIntType.
 */
#ifdef TCL_WIDE_INT_IS_LONG
#define NO_WIDE_TYPE
#endif

/*
 * The following procedures allow namespaces to be customized to support
 * special name resolution rules for commands/variables.

 */

struct Tcl_ResolvedVarInfo;

typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) (Tcl_Interp* interp,
	struct Tcl_ResolvedVarInfo *vinfoPtr);

typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr);


/*
 * The following structure encapsulates the routines needed to resolve a
 * variable reference at runtime. Any variable specific state will typically
 * be appended to this structure.
 */


typedef struct Tcl_ResolvedVarInfo {
    Tcl_ResolveRuntimeVarProc *fetchProc;
    Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;



typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp* interp,
	CONST84 char* name, int length, Tcl_Namespace *context,
	Tcl_ResolvedVarInfo **rPtr);

typedef int (Tcl_ResolveVarProc) (Tcl_Interp* interp, CONST84 char* name,

	Tcl_Namespace *context, int flags, Tcl_Var *rPtr);

typedef int (Tcl_ResolveCmdProc) (Tcl_Interp* interp, CONST84 char* name,
	Tcl_Namespace *context, int flags, Tcl_Command *rPtr);


typedef struct Tcl_ResolverInfo {
    Tcl_ResolveCmdProc *cmdResProc;	/* Procedure handling command name
					 * resolution. */
    Tcl_ResolveVarProc *varResProc;	/* Procedure handling variable name
					 * resolution for variables that
					 * can only be handled at runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarResProc;
					/* Procedure handling variable name
					 * resolution at compile time. */
} Tcl_ResolverInfo;

/*
 *----------------------------------------------------------------
 * Data structures related to namespaces.
 *----------------------------------------------------------------
 */

typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;

/*
 * The structure below defines a namespace.
 * Note: the first five fields must match exactly the fields in a
 * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change
 * the other.
 */

typedef struct Namespace {
    char *name;			/* The namespace's simple (unqualified) name.
				 * This contains no ::'s. The name of the
				 * global namespace is "" although "::" is an
				 * synonym. */
    char *fullName;		/* The namespace's fully qualified name. This
				 * starts with ::. */
    ClientData clientData;	/* An arbitrary value associated with this
				 * namespace. */
    Tcl_NamespaceDeleteProc *deleteProc;
				/* Procedure invoked when deleting the
				 * namespace to, e.g., free clientData. */
    struct Namespace *parentPtr;/* Points to the namespace that contains this
				 * one. NULL if this is the global
				 * namespace. */
    Tcl_HashTable childTable;	/* Contains any child namespaces. Indexed by
				 * strings; values have type (Namespace *). */

    long nsId;			/* Unique id for the namespace. */
    Tcl_Interp *interp;		/* The interpreter containing this
				 * namespace. */
    int flags;			/* OR-ed combination of the namespace status
				 * flags NS_DYING and NS_DEAD listed below. */

    int activationCount;	/* Number of "activations" or active call
				 * frames for this namespace that are on the
				 * Tcl call stack. The namespace won't be
				 * freed until activationCount becomes zero. */

    int refCount;		/* Count of references by namespaceName
				 * objects. The namespace can't be freed until
				 * refCount becomes zero. */
    Tcl_HashTable cmdTable;	/* Contains all the commands currently
				 * registered in the namespace. Indexed by
				 * strings; values have type (Command *).
				 * Commands imported by Tcl_Import have
				 * Command structures that point (via an
				 * ImportedCmdRef structure) to the Command
				 * structure in the source namespace's command
				 * table. */
    Tcl_HashTable varTable;	/* Contains all the (global) variables
				 * currently in this namespace. Indexed by
				 * strings; values have type (Var *). */
    char **exportArrayPtr;	/* Points to an array of string patterns
				 * specifying which commands are exported. A
				 * pattern may include "string match" style
				 * wildcard characters to specify multiple
				 * commands; however, no namespace qualifiers
				 * are allowed. NULL if no export patterns are
				 * registered. */
    int numExportPatterns;	/* Number of export patterns currently
				 * registered using "namespace export". */
    int maxExportPatterns;	/* Mumber of export patterns for which space
				 * is currently allocated. */
    int cmdRefEpoch;		/* Incremented if a newly added command
				 * shadows a command for which this namespace
				 * has already cached a Command * pointer;
				 * this causes all its cached Command*
				 * pointers to be invalidated. */
    int resolverEpoch;		/* Incremented whenever (a) the name
				 * resolution rules change for this namespace
				 * or (b) a newly added command shadows a
				 * command that is compiled to bytecodes. This
				 * invalidates all byte codes compiled in the
				 * namespace, causing the code to be
				 * recompiled under the new rules.*/
    Tcl_ResolveCmdProc *cmdResProc;
				/* If non-null, this procedure overrides the
				 * usual command resolution mechanism in Tcl.
				 * This procedure is invoked within
				 * Tcl_FindCommand to resolve all command
				 * references within the namespace. */
    Tcl_ResolveVarProc *varResProc;
				/* If non-null, this procedure overrides the
				 * usual variable resolution mechanism in Tcl.
				 * This procedure is invoked within
				 * Tcl_FindNamespaceVar to resolve all
				 * variable references within the namespace at
				 * runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarResProc;
				/* If non-null, this procedure overrides the
				 * usual variable resolution mechanism in Tcl.
				 * This procedure is invoked within
				 * LookupCompiledLocal to resolve variable
				 * references within the namespace at compile
				 * time. */
    int exportLookupEpoch;	/* Incremented whenever a command is added to
				 * a namespace, removed from a namespace or
				 * the exports of a namespace are changed.
				 * Allows TIP#112-driven command lists to be
				 * validated efficiently. */
    Tcl_Ensemble *ensembles;	/* List of structures that contain the details
				 * of the ensembles that are implemented on
				 * top of this namespace. */
    int commandPathLength;	/* The length of the explicit path. */
    NamespacePathEntry *commandPathArray;
				/* The explicit path of the namespace as an
				 * array. */
    NamespacePathEntry *commandPathSourceList;
				/* Linked list of path entries that point to
				 * this namespace. */
} Namespace;

/*
 * An entry on a namespace's command resolution path.
 */

struct NamespacePathEntry {
    Namespace *nsPtr;		/* What does this path entry point to? If it
				 * is NULL, this path entry points is
				 * redundant and should be skipped. */
    Namespace *creatorNsPtr;	/* Where does this path entry point from? This
				 * allows for efficient invalidation of
				 * references when the path entry's target
				 * updates its current list of defined
				 * commands. */
    NamespacePathEntry *prevPtr, *nextPtr;
				/* Linked list pointers or NULL at either end
				 * of the list that hangs off Namespace's
				 * commandPathSourceList field. */
};

/*
 * Flags used to represent the status of a namespace:
 *
 * NS_DYING -	1 means Tcl_DeleteNamespace has been called to delete the
 *		namespace but there are still active call frames on the Tcl
 *		stack that refer to the namespace. When the last call frame
 *		referring to it has been popped, it's variables and command
 *		will be destroyed and it will be marked "dead" (NS_DEAD). The
 *		namespace can no longer be looked up by name.
 * NS_DEAD -	1 means Tcl_DeleteNamespace has been called to delete the
 *		namespace and no call frames still refer to it. Its variables
 *		and command have already been destroyed. This bit allows the
 *		namespace resolution code to recognize that the namespace is
 *		"deleted". When the last namespaceName object in any byte code
 *		unit that refers to the namespace has been freed (i.e., when
 *		the namespace's refCount is 0), the namespace's storage will
 *		be freed.
 */

#define NS_DYING	0x01
#define NS_DEAD		0x02

/*
 * Flags passed to TclGetNamespaceForQualName:
 *
 * TCL_GLOBAL_ONLY		- (see tcl.h) Look only in the global ns. 
 * TCL_NAMESPACE_ONLY		- (see tcl.h) Look only in the context ns.
 * TCL_CREATE_NS_IF_UNKNOWN	- Create unknown namespaces.
 * TCL_FIND_ONLY_NS		- The name sought is a namespace name.
 */

#define TCL_CREATE_NS_IF_UNKNOWN	0x800
#define TCL_FIND_ONLY_NS		0x1000

/*
 *----------------------------------------------------------------
 * Data structures related to variables. These are used primarily in tclVar.c

 *----------------------------------------------------------------
 */

/*
 * The following structure defines a variable trace, which is used to invoke a
 * specific C procedure whenever certain operations are performed on a
 * variable.
 */

typedef struct VarTrace {
    Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
				 * flags are performed on variable. */
    ClientData clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in: OR-ed combination of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
    struct VarTrace *nextPtr;	/* Next in list of traces associated with a
				 * particular variable. */
} VarTrace;

/*
 * The following structure defines a command trace, which is used to invoke a
 * specific C procedure whenever certain operations are performed on a
 * command.
 */

typedef struct CommandTrace {
    Tcl_CommandTraceProc *traceProc;
				/* Procedure to call when operations given by
				 * flags are performed on command. */
    ClientData clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in: OR-ed combination of
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;
				/* Next in list of traces associated with a
				 * particular command. */
    int refCount;		/* Used to ensure this structure is not
				 * deleted too early. Keeps track of how many
				 * pieces of code have a pointer to this
				 * structure. */
} CommandTrace;

/*
 * When a command trace is active (i.e. its associated procedure is executing)
 * one of the following structures is linked into a list associated with the

 * command's interpreter. The information in the structure is needed in order
 * for Tcl to behave reasonably if traces are deleted while traces are active.
 */

typedef struct ActiveCommandTrace {
    struct Command *cmdPtr;	/* Command that's being traced. */
    struct ActiveCommandTrace *nextPtr;
				/* Next in list of all active command traces
				 * for the interpreter, or NULL if no more. */

    CommandTrace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
    int reverseScan;		/* Boolean set true when traces are scanning
				 * in reverse order. */
} ActiveCommandTrace;

/*
 * When a variable trace is active (i.e. its associated procedure is
 * executing) one of the following structures is linked into a list associated
 * with the variable's interpreter. The information in the structure is needed
 * in order for Tcl to behave reasonably if traces are deleted while traces
 * are active.
 */

typedef struct ActiveVarTrace {
    struct Var *varPtr;		/* Variable that's being traced. */
    struct ActiveVarTrace *nextPtr;
				/* Next in list of all active variable traces
				 * for the interpreter, or NULL if no more. */

    VarTrace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
} ActiveVarTrace;

/*
 * The following structure describes an enumerative search in progress on an
 * array variable; this are invoked with options to the "array" command.

 */

typedef struct ArraySearch {
    int id;			/* Integer id used to distinguish among
				 * multiple concurrent searches for the same
				 * array. */
    struct Var *varPtr;		/* Pointer to array variable that's being
				 * searched. */
    Tcl_HashSearch search;	/* Info kept by the hash module about progress
				 * through the array. */
    Tcl_HashEntry *nextEntry;	/* Non-null means this is the next element to
				 * be enumerated (it's leftover from the
				 * Tcl_FirstHashEntry call or from an "array
				 * anymore" command). NULL means must call
				 * Tcl_NextHashEntry to get value to
				 * return. */
    struct ArraySearch *nextPtr;/* Next in list of all active searches for
				 * this variable, or NULL if this is the last
				 * one. */
} ArraySearch;

/*
 * The structure below defines a variable, which associates a string name with
 * a Tcl_Obj value. These structures are kept in procedure call frames (for
 * local variables recognized by the compiler) or in the heap (for global
 * variables and any variable not known to the compiler). For each Var
 * structure in the heap, a hash table entry holds the variable name and a
 * pointer to the Var structure.
 */

typedef struct Var {
    union {
	Tcl_Obj *objPtr;	/* The variable's object value. Used for
				 * scalar variables and array elements. */
	Tcl_HashTable *tablePtr;/* For array variables, this points to
				 * information about the hash table used to
				 * implement the associative array. Points to
				 * ckalloc-ed data. */
	struct Var *linkPtr;	/* If this is a global variable being referred
				 * to in a procedure, or a variable created by
				 * "upvar", this field points to the
				 * referenced variable's Var struct. */
    } value;
    char *name;			/* NULL if the variable is in a hashtable,
				 * otherwise points to the variable's name. It
				 * is used, e.g., by TclLookupVar and "info
				 * locals". The storage for the characters of
				 * the name is not owned by the Var and must

				 * not be freed when freeing the Var. */
    Namespace *nsPtr;		/* Points to the namespace that contains this
				 * variable or NULL if the variable is a local
				 * variable in a Tcl procedure. */
    Tcl_HashEntry *hPtr;	/* If variable is in a hashtable, either the
				 * hash table entry that refers to this
				 * variable or NULL if the variable has been
				 * detached from its hash table (e.g. an array
				 * is deleted, but some of its elements are
				 * still referred to in upvars). NULL if the
				 * variable is not in a hashtable. This is
				 * used to delete an variable from its
				 * hashtable if it is no longer needed. */

    int refCount;		/* Counts number of active uses of this
				 * variable, not including its entry in the
				 * call frame or the hash table: 1 for each
				 * additional variable whose linkPtr points
				 * here, 1 for each nested trace active on
				 * variable, and 1 if the variable is a
				 * namespace variable. This record can't be
				 * deleted until refCount becomes 0. */
    VarTrace *tracePtr;		/* First in list of all traces set for this
				 * variable. */
    ArraySearch *searchPtr;	/* First in list of all searches active for
				 * this variable, or NULL if none. */
    int flags;			/* Miscellaneous bits of information about
				 * variable. See below for definitions. */
} Var;

/*
 * Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and
 * VAR_LINK) are mutually exclusive and give the "type" of the variable.
 * VAR_UNDEFINED is independent of the variable's type.
 *
 * VAR_SCALAR -			1 means this is a scalar variable and not an
 *				array or link. The "objPtr" field points to
 *				the variable's value, a Tcl object.
 * VAR_ARRAY -			1 means this is an array variable rather than
 *				a scalar variable or link. The "tablePtr"
 *				field points to the array's hashtable for its
 *				elements.
 * VAR_LINK -			1 means this Var structure contains a pointer
 *				to another Var structure that either has the
 *				real value or is itself another VAR_LINK
 *				pointer. Variables like this come about
 *				through "upvar" and "global" commands, or
 *				through references to variables in enclosing
 *				namespaces.
 * VAR_UNDEFINED -		1 means that the variable is in the process of
 *				being deleted. An undefined variable logically
 *				does not exist and survives only while it has
 *				a trace, or if it is a global variable
 *				currently being used by some procedure.

 * VAR_IN_HASHTABLE -		1 means this variable is in a hashtable and
 *				the Var structure is malloced. 0 if it is a
 *				local variable that was assigned a slot in a
 *				procedure frame by the compiler so the Var
 *				storage is part of the call frame.
 * VAR_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a read or write access, so new
 *				read or write accesses should not cause trace
 *				procedures to be called and the variable can't
 *				be deleted.
 * VAR_ARRAY_ELEMENT -		1 means that this variable is an array
 *				element, so it is not legal for it to be an
 *				array itself (the VAR_ARRAY flag had better
 *				not be set).
 * VAR_NAMESPACE_VAR -		1 means that this variable was declared as a
 *				namespace variable. This flag ensures it
 *				persists until its namespace is destroyed or
 *				until the variable is unset; it will persist
 *				even if it has not been initialized and is
 *				marked undefined. The variable's refCount is
 *				incremented to reflect the "reference" from
 *				its namespace.
 *
 * The following additional flags are used with the CompiledLocal type defined
 * below:
 *
 * VAR_ARGUMENT -		1 means that this variable holds a procedure
 *				argument.
 * VAR_TEMPORARY -		1 if the local variable is an anonymous
 *				temporary variable. Temporaries have a NULL
 *				name.
 * VAR_RESOLVED -		1 if name resolution has been done for this
 *				variable.
 */

#define VAR_SCALAR		0x1
#define VAR_ARRAY		0x2
#define VAR_LINK		0x4
#define VAR_UNDEFINED		0x8
#define VAR_IN_HASHTABLE	0x10
#define VAR_TRACE_ACTIVE	0x20
#define VAR_ARRAY_ELEMENT	0x40
#define VAR_NAMESPACE_VAR	0x80

#define VAR_ARGUMENT		0x100
#define VAR_TEMPORARY		0x200
#define VAR_RESOLVED		0x400
#define VAR_IS_ARGS		0x800

/*
 * Macros to ensure that various flag bits are set properly for variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclSetVarScalar(Var *varPtr);
 * MODULE_SCOPE void	TclSetVarArray(Var *varPtr);
 * MODULE_SCOPE void	TclSetVarLink(Var *varPtr);
 * MODULE_SCOPE void	TclSetVarArrayElement(Var *varPtr);
 * MODULE_SCOPE void	TclSetVarUndefined(Var *varPtr);
 * MODULE_SCOPE void	TclClearVarUndefined(Var *varPtr);
 */

#define TclSetVarScalar(varPtr) \
    (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR

#define TclSetVarArray(varPtr) \
    (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702

703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745


746
747
748















749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783



784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819


820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874


875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909


910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940

941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971



972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397

1398
1399
1400
1401
1402
1403
1404

1405
1406
1407



1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431










1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443






































1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476




1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488

1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503

1504
1505

1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602

1603
1604




1605

1606
1607
1608







































1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621

1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703

1704

1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722





























1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734









1735
1736
1737
1738

1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752

1753
1754

1755
1756
1757
1758
1759
1760
1761
1762
1763
#define TclClearVarNamespaceVar(varPtr) \
    (varPtr)->flags &= ~VAR_NAMESPACE_VAR

/*
 * Macros to read various flag bits of variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE int	TclIsVarScalar _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarLink _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarArray _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarUndefined _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarArrayElement _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarTemporary _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarArgument _ANSI_ARGS_((Var *varPtr));
 * MODULE_SCOPE int	TclIsVarResolved _ANSI_ARGS_((Var *varPtr));
 */
    
#define TclIsVarScalar(varPtr) \
    ((varPtr)->flags & VAR_SCALAR)

#define TclIsVarLink(varPtr) \
    ((varPtr)->flags & VAR_LINK)

#define TclIsVarArray(varPtr) \
    ((varPtr)->flags & VAR_ARRAY)

#define TclIsVarUndefined(varPtr) \
    ((varPtr)->flags & VAR_UNDEFINED)

#define TclIsVarArrayElement(varPtr) \
    ((varPtr)->flags & VAR_ARRAY_ELEMENT)

#define TclIsVarNamespaceVar(varPtr) \
    ((varPtr)->flags & VAR_NAMESPACE_VAR)

#define TclIsVarTemporary(varPtr) \
    ((varPtr)->flags & VAR_TEMPORARY)
    
#define TclIsVarArgument(varPtr) \
    ((varPtr)->flags & VAR_ARGUMENT)
    
#define TclIsVarResolved(varPtr) \
    ((varPtr)->flags & VAR_RESOLVED)

#define TclIsVarTraceActive(varPtr) \
    ((varPtr)->flags & VAR_TRACE_ACTIVE)

#define TclIsVarUntraced(varPtr) \
    ((varPtr)->tracePtr == NULL)

/*
 * Macros for direct variable access by TEBC
 */

#define TclIsVarDirectReadable(varPtr) \
       (TclIsVarScalar(varPtr) \
    && !TclIsVarUndefined(varPtr) \
    && TclIsVarUntraced(varPtr))

#define TclIsVarDirectWritable(varPtr) \
    (   !(((varPtr)->flags & VAR_IN_HASHTABLE) \
		&& ((varPtr)->hPtr == NULL)) \
     && TclIsVarUntraced(varPtr) \
     && (TclIsVarScalar(varPtr) \
	     || TclIsVarUndefined(varPtr)))

/*
 *----------------------------------------------------------------
 * Data structures related to procedures.  These are used primarily
 * in tclProc.c, tclCompile.c, and tclExecute.c.
 *----------------------------------------------------------------
 */

/*
 * Forward declaration to prevent an error when the forward reference to
 * Command is encountered in the Proc and ImportRef types declared below.
 */

struct Command;

/*
 * The variable-length structure below describes a local variable of a
 * procedure that was recognized by the compiler. These variables have a
 * name, an element in the array of compiler-assigned local variables in the
 * procedure's call frame, and various other items of information. If the
 * local variable is a formal argument, it may also have a default value.
 * The compiler can't recognize local variables whose names are
 * expressions (these names are only known at runtime when the expressions
 * are evaluated) or local variables that are created as a result of an
 * "upvar" or "uplevel" command. These other local variables are kept
 * separately in a hash table in the call frame.
 */

typedef struct CompiledLocal {
    struct CompiledLocal *nextPtr;
				/* Next compiler-recognized local variable
				 * for this procedure, or NULL if this is
				 * the last local. */
    int nameLength;		/* The number of characters in local
				 * variable's name. Used to speed up
				 * variable lookups. */
    int frameIndex;		/* Index in the array of compiler-assigned
				 * variables in the procedure call frame. */
    int flags;			/* Flag bits for the local variable. Same as
				 * the flags for the Var structure above,
				 * although only VAR_SCALAR, VAR_ARRAY, 
				 * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and
				 * VAR_RESOLVED make sense. */
    Tcl_Obj *defValuePtr;	/* Pointer to the default value of an
				 * argument, if any. NULL if not an argument
				 * or, if an argument, no default value. */
    Tcl_ResolvedVarInfo *resolveInfo;
				/* Customized variable resolution info
				 * supplied by the Tcl_ResolveCompiledVarProc
				 * associated with a namespace. Each variable
				 * is marked by a unique ClientData tag
				 * during compilation, and that same tag
				 * is used to find the variable at runtime. */
    char name[4];		/* Name of the local variable starts here.
				 * If the name is NULL, this will just be
				 * '\0'. The actual size of this field will
				 * be large enough to hold the name. MUST
				 * BE THE LAST FIELD IN THE STRUCTURE! */
} CompiledLocal;

/*
 * The structure below defines a command procedure, which consists of a
 * collection of Tcl commands plus information about arguments and other
 * local variables recognized at compile time.
 */

typedef struct Proc {
    struct Interp *iPtr;	  /* Interpreter for which this command
				   * is defined. */
    int refCount;		  /* Reference count: 1 if still present
				   * in command table plus 1 for each call
				   * to the procedure that is currently
				   * active. This structure can be freed
				   * when refCount becomes zero. */
    struct Command *cmdPtr;	  /* Points to the Command structure for
				   * this procedure. This is used to get
				   * the namespace in which to execute
				   * the procedure. */
    Tcl_Obj *bodyPtr;		  /* Points to the ByteCode object for
				   * procedure's body command. */
    int numArgs;		  /* Number of formal parameters. */
    int numCompiledLocals;	  /* Count of local variables recognized by
				   * the compiler including arguments and
				   * temporaries. */
    CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's

				   * compiler-allocated local variables, or
				   * NULL if none. The first numArgs entries
				   * in this list describe the procedure's
				   * formal arguments. */
    CompiledLocal *lastLocalPtr;  /* Pointer to the last allocated local
				   * variable or NULL if none. This has
				   * frame index (numCompiledLocals-1). */
} Proc;

/*
 * The structure below defines a command trace.	 This is used to allow Tcl
 * clients to find out whenever a command is about to be executed.
 */

typedef struct Trace {
    int level;			/* Only trace commands at nesting level
				 * less than or equal to this. */
    Tcl_CmdObjTraceProc *proc;	/* Procedure to call to trace command. */
    ClientData clientData;	/* Arbitrary value to pass to proc. */
    struct Trace *nextPtr;	/* Next in list of traces for this interp. */
    int flags;			/* Flags governing the trace - see
				 * Tcl_CreateObjTrace for details */
    Tcl_CmdObjTraceDeleteProc* delProc;
				/* Procedure to call when trace is deleted */
} Trace;

/*
 * When an interpreter trace is active (i.e. its associated procedure
 * is executing), one of the following structures is linked into a list
 * associated with the interpreter.  The information in the structure
 * is needed in order for Tcl to behave reasonably if traces are
 * deleted while traces are active.
 */

typedef struct ActiveInterpTrace {
    struct ActiveInterpTrace *nextPtr;
				/* Next in list of all active command
				 * traces for the interpreter, or NULL
				 * if no more. */
    Trace *nextTracePtr;	/* Next trace to check after current
				 * trace procedure returns;  if this
				 * trace gets deleted, must update pointer
				 * to avoid using free'd memory. */


} ActiveInterpTrace;

/*















 * The structure below defines an entry in the assocData hash table which
 * is associated with an interpreter. The entry contains a pointer to a
 * function to call when the interpreter is deleted, and a pointer to
 * a user-defined piece of data.
 */

typedef struct AssocData {
    Tcl_InterpDeleteProc *proc;	/* Proc to call when deleting. */
    ClientData clientData;	/* Value to pass to proc. */
} AssocData;	

/*
 * The structure below defines a call frame. A call frame defines a naming
 * context for a procedure call: its local naming scope (for local
 * variables) and its global naming scope (a namespace, perhaps the global
 * :: namespace). A call frame can also define the naming context for a
 * namespace eval or namespace inscope command: the namespace in which the
 * command's code should execute. The Tcl_CallFrame structures exist only
 * while procedures or namespace eval/inscope's are being executed, and
 * provide a kind of Tcl call stack.
 * 
 * WARNING!! The structure definition must be kept consistent with the
 * Tcl_CallFrame structure in tcl.h. If you change one, change the other.
 */

typedef struct CallFrame {
    Namespace *nsPtr;		/* Points to the namespace used to resolve
				 * commands and global variables. */
    int isProcCallFrame;	/* If nonzero, the frame was pushed to
				 * execute a Tcl procedure and may have
				 * local vars. If 0, the frame was pushed
				 * to execute a namespace command and var
				 * references are treated as references to
				 * namespace vars; varTablePtr and
				 * compiledLocals are ignored. */



    int objc;			/* This and objv below describe the
				 * arguments for this procedure call. */
    Tcl_Obj *CONST *objv;	/* Array of argument objects. */
    struct CallFrame *callerPtr;
				/* Value of interp->framePtr when this
				 * procedure was invoked (i.e. next higher
				 * in stack of all active procedures). */
    struct CallFrame *callerVarPtr;
				/* Value of interp->varFramePtr when this
				 * procedure was invoked (i.e. determines
				 * variable scoping within caller). Same
				 * as callerPtr unless an "uplevel" command
				 * or something equivalent was active in
				 * the caller). */
    int level;			/* Level of this procedure, for "uplevel"
				 * purposes (i.e. corresponds to nesting of
				 * callerVarPtr's, not callerPtr's). 1 for
				 * outermost procedure, 0 for top-level. */
    Proc *procPtr;		/* Points to the structure defining the
				 * called procedure. Used to get information
				 * such as the number of compiled local
				 * variables (local variables assigned
				 * entries ["slots"] in the compiledLocals
				 * array below). */
    Tcl_HashTable *varTablePtr;	/* Hash table containing local variables not
				 * recognized by the compiler, or created at
				 * execution time through, e.g., upvar.
				 * Initially NULL and created if needed. */
    int numCompiledLocals;	/* Count of local variables recognized by
				 * the compiler including arguments. */
    Var* compiledLocals;	/* Points to the array of local variables
				 * recognized by the compiler. The compiler
				 * emits code that refers to these variables
				 * using an index into this array. */
} CallFrame;



/*
 *----------------------------------------------------------------
 * Data structures and procedures related to TclHandles, which
 * are a very lightweight method of preserving enough information
 * to determine if an arbitrary malloc'd block has been deleted.
 *----------------------------------------------------------------
 */

typedef VOID **TclHandle;

/*
 *----------------------------------------------------------------
 * Data structures related to expressions.  These are used only in
 * tclExpr.c.
 *----------------------------------------------------------------
 */

/*
 * The data structure below defines a math function (e.g. sin or hypot)
 * for use in Tcl expressions.
 */

#define MAX_MATH_ARGS 5
typedef struct MathFunc {
    int builtinFuncIndex;	/* If this is a builtin math function, its
				 * index in the array of builtin functions.
				 * (tclCompilation.h lists these indices.)
				 * The value is -1 if this is a new function
				 * defined by Tcl_CreateMathFunc. The value
				 * is also -1 if a builtin function is
				 * replaced by a Tcl_CreateMathFunc call. */
    int numArgs;		/* Number of arguments for function. */
    Tcl_ValueType argTypes[MAX_MATH_ARGS];
				/* Acceptable types for each argument. */
    Tcl_MathProc *proc;		/* Procedure that implements this function.
				 * NULL if isBuiltinFunc is 1. */
    ClientData clientData;	/* Additional argument to pass to the
				 * function when invoking it. NULL if
				 * isBuiltinFunc is 1. */
} MathFunc;

/*
 * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet
 * when threads are used, or an emulation if there are no threads.  These
 * are really internal and Tcl clients should use Tcl_GetThreadData.
 */

MODULE_SCOPE VOID *	TclThreadDataKeyGet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
MODULE_SCOPE void	TclThreadDataKeySet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr, VOID *data));

/*
 * This is a convenience macro used to initialize a thread local storage ptr.
 */


#define TCL_TSD_INIT(keyPtr)	(ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))


/*
 *----------------------------------------------------------------
 * Data structures related to bytecode compilation and execution.
 * These are used primarily in tclCompile.c, tclExecute.c, and
 * tclBasic.c.
 *----------------------------------------------------------------
 */

/*
 * Forward declaration to prevent errors when the forward references to
 * Tcl_Parse and CompileEnv are encountered in the procedure type
 * CompileProc declared below.
 */

struct CompileEnv;

/*
 * The type of procedures called by the Tcl bytecode compiler to compile
 * commands. Pointers to these procedures are kept in the Command structure
 * describing each command.  The integer value returned by a CompileProc
 * must be one of the following:
 *
 * TCL_OK		Compilation completed normally.
 * TCL_OUT_LINE_COMPILE	Compilation could not be completed.  This can
 * 			be just a judgment by the CompileProc that the
 * 			command is too complex to compile effectively,
 * 			or it can indicate that in the current state of
 * 			the interp, the command would raise an error.
 * 			In the latter circumstance, we defer error reporting
 * 			until the actual runtime, because by then changes
 * 			in the interp state may allow the command to be
 * 			successfully evaluated.


 */

#define TCL_OUT_LINE_COMPILE	(TCL_CONTINUE + 1)

typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp,
	Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr));

/*
 * The type of procedure called from the compilation hook point in
 * SetByteCodeFromAny.
 */

typedef int (CompileHookProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct CompileEnv *compEnvPtr, ClientData clientData));

/*
 * The data structure defining the execution environment for ByteCode's.
 * There is one ExecEnv structure per Tcl interpreter. It holds the
 * evaluation stack that holds command operands and results. The stack grows
 * towards increasing addresses. The "stackTop" member is cached by
 * TclExecuteByteCode in a local variable: it must be set before calling
 * TclExecuteByteCode and will be restored by TclExecuteByteCode before it
 * returns.
 */

typedef struct ExecEnv {
    Tcl_Obj **stackPtr;		/* Points to the first item in the
				 * evaluation stack on the heap. */
    Tcl_Obj **tosPtr;		/* Points to current top of stack; 
				 * (stackPtr-1) when the stack is empty. */
    Tcl_Obj **endPtr;		/* Points to last usable item in stack. */

} ExecEnv;

/*
 * The definitions for the LiteralTable and LiteralEntry structures. Each
 * interpreter contains a LiteralTable. It is used to reduce the storage
 * needed for all the Tcl objects that hold the literals of scripts compiled
 * by the interpreter. A literal's object is shared by all the ByteCodes
 * that refer to the literal. Each distinct literal has one LiteralEntry
 * entry in the LiteralTable. A literal table is a specialized hash table
 * that is indexed by the literal's string representation, which may contain
 * null characters.
 *
 * Note that we reduce the space needed for literals by sharing literal
 * objects both within a ByteCode (each ByteCode contains a local
 * LiteralTable) and across all an interpreter's ByteCodes (with the
 * interpreter's global LiteralTable).
 */

typedef struct LiteralEntry {
    struct LiteralEntry *nextPtr;	/* Points to next entry in this
					 * hash bucket or NULL if end of
					 * chain. */
    Tcl_Obj *objPtr;			/* Points to Tcl object that
					 * holds the literal's bytes and
					 * length. */
    int refCount;			/* If in an interpreter's global
					 * literal table, the number of
					 * ByteCode structures that share
					 * the literal object; the literal
					 * entry can be freed when refCount
					 * drops to 0. If in a local literal



					 * table, -1. */
} LiteralEntry;

typedef struct LiteralTable {
    LiteralEntry **buckets;		/* Pointer to bucket array. Each
					 * element points to first entry in
					 * bucket's hash chain, or NULL. */
    LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
					/* Bucket array used for small
					 * tables to avoid mallocs and
					 * frees. */
    int numBuckets;			/* Total number of buckets allocated
					 * at **buckets. */
    int numEntries;			/* Total number of entries present
					 * in table. */
    int rebuildSize;			/* Enlarge table when numEntries
					 * gets to be this large. */
    int mask;				/* Mask value used in hashing
					 * function. */
} LiteralTable;

/*
 * The following structure defines for each Tcl interpreter various
 * statistics-related information about the bytecode compiler and
 * interpreter's operation in that interpreter.
 */

#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
    long numExecutions;		  /* Number of ByteCodes executed. */
    long numCompilations;	  /* Number of ByteCodes created. */
    long numByteCodesFreed;	  /* Number of ByteCodes destroyed. */
    long instructionCount[256];	  /* Number of times each instruction was
				   * executed. */

    double totalSrcBytes;	  /* Total source bytes ever compiled. */
    double totalByteCodeBytes;	  /* Total bytes for all ByteCodes. */
    double currentSrcBytes;	  /* Src bytes for all current ByteCodes. */
    double currentByteCodeBytes;  /* Code bytes in all current ByteCodes. */

    long srcCount[32];		  /* Source size distribution: # of srcs of
				   * size [2**(n-1)..2**n), n in [0..32). */
    long byteCodeCount[32];	  /* ByteCode size distribution. */
    long lifetimeCount[32];	  /* ByteCode lifetime distribution (ms). */
    
    double currentInstBytes;	  /* Instruction bytes-current ByteCodes. */
    double currentLitBytes;	  /* Current literal bytes. */
    double currentExceptBytes;	  /* Current exception table bytes. */
    double currentAuxBytes;	  /* Current auxiliary information bytes. */
    double currentCmdMapBytes;	  /* Current src<->code map bytes. */
    
    long numLiteralsCreated;	  /* Total literal objects ever compiled. */
    double totalLitStringBytes;	  /* Total string bytes in all literals. */
    double currentLitStringBytes; /* String bytes in current literals. */

    long literalCount[32];	  /* Distribution of literal string sizes. */
} ByteCodeStats;
#endif /* TCL_COMPILE_STATS */

/*
 *----------------------------------------------------------------
 * Data structures related to commands.
 *----------------------------------------------------------------
 */

/*
 * An imported command is created in an namespace when it imports a "real"
 * command from another namespace. An imported command has a Command
 * structure that points (via its ClientData value) to the "real" Command
 * structure in the source namespace's command table. The real command
 * records all the imported commands that refer to it in a list of ImportRef
 * structures so that they can be deleted when the real command is deleted.  */


typedef struct ImportRef {
    struct Command *importedCmdPtr;
				/* Points to the imported command created in
				 * an importing namespace; this command
				 * redirects its invocations to the "real"
				 * command. */
    struct ImportRef *nextPtr;	/* Next element on the linked list of
				 * imported commands that refer to the
				 * "real" command. The real command deletes
				 * these imported commands on this list when
				 * it is deleted. */
} ImportRef;

/*
 * Data structure used as the ClientData of imported commands: commands
 * created in an namespace when it imports a "real" command from another
 * namespace.
 */

typedef struct ImportedCmdData {
    struct Command *realCmdPtr;	/* "Real" command that this imported command
				 * refers to. */
    struct Command *selfPtr;	/* Pointer to this imported command. Needed
				 * only when deleting it in order to remove
				 * it from the real command's linked list of
				 * imported commands that refer to it. */
} ImportedCmdData;

/*
 * A Command structure exists for each command in a namespace. The
 * Tcl_Command opaque type actually refers to these structures.
 */

typedef struct Command {
    Tcl_HashEntry *hPtr;	/* Pointer to the hash table entry that
				 * refers to this command. The hash table is
				 * either a namespace's command table or an
				 * interpreter's hidden command table. This
				 * pointer is used to get a command's name
				 * from its Tcl_Command handle. NULL means
				 * that the hash table entry has been
				 * removed already (this can happen if
				 * deleteProc causes the command to be
				 * deleted or recreated). */
    Namespace *nsPtr;		/* Points to the namespace containing this
				 * command. */
    int refCount;		/* 1 if in command hashtable plus 1 for each
				 * reference from a CmdName Tcl object
				 * representing a command's name in a
				 * ByteCode instruction sequence. This
				 * structure can be freed when refCount
				 * becomes zero. */
    int cmdEpoch;		/* Incremented to invalidate any references
				 * that point to this command when it is
				 * renamed, deleted, hidden, or exposed. */
    CompileProc *compileProc;	/* Procedure called to compile command. NULL
				 * if no compile proc exists for command. */
    Tcl_ObjCmdProc *objProc;	/* Object-based command procedure. */
    ClientData objClientData;	/* Arbitrary value passed to object proc. */
    Tcl_CmdProc *proc;		/* String-based command procedure. */
    ClientData clientData;	/* Arbitrary value passed to string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* Procedure invoked when deleting command
				 * to, e.g., free all client data. */
    ClientData deleteData;	/* Arbitrary value passed to deleteProc. */
    int flags;			/* Miscellaneous bits of information about
				 * command. See below for definitions. */
    ImportRef *importRefPtr;	/* List of each imported Command created in
				 * another namespace when this command is
				 * imported. These imported commands
				 * redirect invocations back to this
				 * command. The list is used to remove all
				 * those imported commands when deleting
				 * this "real" command. */
    CommandTrace *tracePtr;	/* First in list of all traces set for this
				 * command. */
} Command;

/*
 * Flag bits for commands. 
 *
 * CMD_IS_DELETED -		Means that the command is in the process
 *				of being deleted (its deleteProc is
 *				currently executing). Other attempts to
 *				delete the command should be ignored.
 * CMD_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a rename/delete change.
 *				See the two flags below for which is
 *				currently being processed.
 * CMD_HAS_EXEC_TRACES -	1 means that this command has at least
 *				one execution trace (as opposed to simple
 *				delete/rename traces) in its tracePtr list.
 * TCL_TRACE_RENAME -		A rename trace is in progress. Further
 *				recursive renames will not be traced.
 * TCL_TRACE_DELETE -		A delete trace is in progress. Further 
 *				recursive deletes will not be traced.
 * (these last two flags are defined in tcl.h)
 */

#define CMD_IS_DELETED		0x1
#define CMD_TRACE_ACTIVE	0x2
#define CMD_HAS_EXEC_TRACES	0x4

/*
 *----------------------------------------------------------------
 * Data structures related to name resolution procedures.
 *----------------------------------------------------------------
 */

/*
 * The interpreter keeps a linked list of name resolution schemes.
 * The scheme for a namespace is consulted first, followed by the
 * list of schemes in an interpreter, followed by the default
 * name resolution in Tcl.  Schemes are added/removed from the
 * interpreter's list by calling Tcl_AddInterpResolver and
 * Tcl_RemoveInterpResolver.
 */

typedef struct ResolverScheme {
    char *name;			/* Name identifying this scheme. */
    Tcl_ResolveCmdProc *cmdResProc;
				/* Procedure handling command name
				 * resolution. */
    Tcl_ResolveVarProc *varResProc;
				/* Procedure handling variable name
				 * resolution for variables that
				 * can only be handled at runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarResProc;
				/* Procedure handling variable name
				 * resolution at compile time. */

    struct ResolverScheme *nextPtr;
				/* Pointer to next record in linked list. */
} ResolverScheme;

/*
 * Forward declaration of the TIP#143 limit handler structure.
 */

typedef struct LimitHandler LimitHandler;

/*
 *----------------------------------------------------------------
 * This structure defines an interpreter, which is a collection of
 * commands plus other state information related to interpreting
 * commands, such as variable storage. Primary responsibility for
 * this data structure is in tclBasic.c, but almost every Tcl
 * source file uses something in here.
 *----------------------------------------------------------------
 */

typedef struct Interp {

    /*
     * Note:  the first three fields must match exactly the fields in
     * a Tcl_Interp struct (see tcl.h).	 If you change one, be sure to
     * change the other.
     *
     * The interpreter's result is held in both the string and the
     * objResultPtr fields. These fields hold, respectively, the result's
     * string or object value. The interpreter's result is always in the
     * result field if that is non-empty, otherwise it is in objResultPtr.
     * The two fields are kept consistent unless some C code sets
     * interp->result directly. Programs should not access result and
     * objResultPtr directly; instead, they should always get and set the
     * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult,
     * and Tcl_GetStringResult. See the SetResult man page for details.
     */

    char *result;		/* If the last command returned a string
				 * result, this points to it. Should not be
				 * accessed directly; see comment above. */
    Tcl_FreeProc *freeProc;	/* Zero means a string result is statically
				 * allocated. TCL_DYNAMIC means string
				 * result was allocated with ckalloc and
				 * should be freed with ckfree. Other values
				 * give address of procedure to invoke to
				 * free the string result. Tcl_Eval must
				 * free it before executing next command. */
    int errorLine;		/* When TCL_ERROR is returned, this gives
				 * the line number in the command where the
				 * error occurred (1 means first line). */
    struct TclStubs *stubTable;
				/* Pointer to the exported Tcl stub table.
				 * On previous versions of Tcl this is a
				 * pointer to the objResultPtr or a pointer
				 * to a buckets array in a hash table. We
				 * therefore have to do some careful checking
				 * before we can use this. */

    TclHandle handle;		/* Handle used to keep track of when this
				 * interp is deleted. */

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep
				 * track of hidden commands on a per-interp
				 * basis. */
    ClientData interpInfo;	/* Information used by tclInterp.c to keep
				 * track of master/slave interps on
				 * a per-interp basis. */
    Tcl_HashTable mathFuncTable;/* Contains all the math functions currently
				 * defined for the interpreter.	 Indexed by
				 * strings (function names); values have
				 * type (MathFunc *). */



    /*
     * Information related to procedures and variables. See tclProc.c
     * and tclVar.c for usage.
     */

    int numLevels;		/* Keeps track of how many nested calls to
				 * Tcl_Eval are in progress for this
				 * interpreter.	 It's used to delay deletion
				 * of the table until all Tcl_Eval
				 * invocations are completed. */
    int maxNestingDepth;	/* If numLevels exceeds this value then Tcl
				 * assumes that infinite recursion has
				 * occurred and it generates an error. */
    CallFrame *framePtr;	/* Points to top-most in stack of all nested
				 * procedure invocations.  NULL means there
				 * are no active procedures. */
    CallFrame *varFramePtr;	/* Points to the call frame whose variables
				 * are currently in use (same as framePtr
				 * unless an "uplevel" command is
				 * executing). NULL means no procedure is
				 * active or "uplevel 0" is executing. */
    ActiveVarTrace *activeVarTracePtr;
				/* First in list of active traces for
				 * interp, or NULL if no active traces. */
    int returnCode;		/* [return -code] parameter */
    char *unused3;		/* No longer used (was errorInfo) */
    char *unused4;		/* No longer used (was errorCode) */

    /*
     * Information used by Tcl_AppendResult to keep track of partial
     * results.	 See Tcl_AppendResult code for details.
     */

    char *appendResult;		/* Storage space for results generated
				 * by Tcl_AppendResult.	 Malloc-ed.  NULL
				 * means not yet allocated. */
    int appendAvl;		/* Total amount of space available at
				 * partialResult. */
    int appendUsed;		/* Number of non-null bytes currently
				 * stored at partialResult. */

    /*
     * Information about packages.  Used only in tclPkg.c.
     */

    Tcl_HashTable packageTable;	/* Describes all of the packages loaded
				 * in or available to this interpreter.
				 * Keys are package names, values are
				 * (Package *) pointers. */
    char *packageUnknown;	/* Command to invoke during "package
				 * require" commands for packages that
				 * aren't described in packageTable. 
				 * Malloc'ed, may be NULL. */

    /*
     * Miscellaneous information:
     */

    int cmdCount;		/* Total number of times a command procedure
				 * has been called for this interpreter. */
    int evalFlags;		/* Flags to control next call to Tcl_Eval.
				 * Normally zero, but may be set before
				 * calling Tcl_Eval.  See below for valid
				 * values. */
    int unused1;		/* No longer used (was termOffset) */
    LiteralTable literalTable;	/* Contains LiteralEntry's describing all
				 * Tcl objects holding literals of scripts
				 * compiled by the interpreter. Indexed by
				 * the string representations of literals.
				 * Used to avoid creating duplicate
				 * objects. */
    int compileEpoch;		/* Holds the current "compilation epoch"
				 * for this interpreter. This is
				 * incremented to invalidate existing
				 * ByteCodes when, e.g., a command with a
				 * compile procedure is redefined. */
    Proc *compiledProcPtr;	/* If a procedure is being compiled, a
				 * pointer to its Proc structure; otherwise,
				 * this is NULL. Set by ObjInterpProc in
				 * tclProc.c and used by tclCompile.c to
				 * process local variables appropriately. */
    ResolverScheme *resolverPtr;
				/* Linked list of name resolution schemes
				 * added to this interpreter.  Schemes
				 * are added/removed by calling
				 * Tcl_AddInterpResolvers and
				 * Tcl_RemoveInterpResolver. */
    Tcl_Obj *scriptFile;	/* NULL means there is no nested source
				 * command active;  otherwise this points to
				 * pathPtr of the file being sourced. */
    int flags;			/* Various flag bits.  See below. */
    long randSeed;		/* Seed used for rand() function. */
    Trace *tracePtr;		/* List of traces for this interpreter. */
    Tcl_HashTable *assocData;	/* Hash table for associating data with
				 * this interpreter. Cleaned up when
				 * this interpreter is deleted. */
    struct ExecEnv *execEnvPtr;	/* Execution environment for Tcl bytecode
				 * execution. Contains a pointer to the
				 * Tcl evaluation stack. */
    Tcl_Obj *emptyObjPtr;	/* Points to an object holding an empty
				 * string. Returned by Tcl_ObjSetVar2 when
				 * variable traces change a variable in a
				 * gross way. */
    char resultSpace[TCL_RESULT_SIZE+1];
				/* Static space holding small results. */
    Tcl_Obj *objResultPtr;	/* If the last command returned an object
				 * result, this points to it. Should not be
				 * accessed directly; see comment above. */
    Tcl_ThreadId threadId;	/* ID of thread that owns the interpreter */

    ActiveCommandTrace *activeCmdTracePtr;
				/* First in list of active command traces for
				 * interp, or NULL if no active traces. */
    ActiveInterpTrace *activeInterpTracePtr;
				/* First in list of active traces for
				 * interp, or NULL if no active traces. */

    int tracesForbiddingInline; /* Count of traces (in the list headed by
				 * tracePtr) that forbid inline bytecode
				 * compilation */

    /* Fields used to manage extensible return options (TIP 90) */
    Tcl_Obj *returnOpts;	/* A dictionary holding the options to the
				 * last [return] command */

    Tcl_Obj *errorInfo;		/* errorInfo value (now as a Tcl_Obj) */
    Tcl_Obj *eiVar;		/* cached ref to ::errorInfo variable */
    Tcl_Obj *errorCode;		/* errorCode value (now as a Tcl_Obj) */
    Tcl_Obj *ecVar;		/* cached ref to ::errorInfo variable */
    int returnLevel;		/* [return -level] parameter */

    /*
     * Resource limiting framework support (TIP#143).
     */

    struct {
	int active;		/* Flag values defining which limits have
				 * been set. */
	int granularityTicker;	/* Counter used to determine how often to
				 * check the limits. */
	int exceeded;		/* Which limits have been exceeded, described
				 * as flag values the same as the 'active'
				 * field. */

	int cmdCount;		/* Limit for how many commands to execute
				 * in the interpreter. */
	LimitHandler *cmdHandlers; /* Handlers to execute when the limit

				    * is reached. */
	int cmdGranularity;	/* Mod factor used to determine how often
				 * to evaluate the limit check. */

	Tcl_Time time;		/* Time limit for execution within the
				 * interpreter. */
	LimitHandler *timeHandlers; /* Handlers to execute when the limit

				     * is reached. */
	int timeGranularity;	/* Mod factor used to determine how often
				 * to evaluate the limit check. */




	Tcl_HashTable callbacks; /* Mapping from (interp,type) pair to data
				  * used to install a limit handler callback
				  * to run in _this_ interp when the limit
				  * is exceeded. */
    } limit;

    /*
     * Information for improved default error generation from
     * ensembles (TIP#112).
     */

    struct {
	Tcl_Obj * CONST *sourceObjs;
				/* What arguments were actually input into
				 * the *root* ensemble command?  (Nested
				 * ensembles don't rewrite this.)  NULL if
				 * we're not processing an ensemble. */
	int numRemovedObjs;	/* How many arguments have been stripped off
				 * because of ensemble processing. */
	int numInsertedObjs;	/* How many of the current arguments were
				 * inserted by an ensemble. */
    } ensembleRewrite;











    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation.
     */

#ifdef TCL_COMPILE_STATS
    ByteCodeStats stats;	/* Holds compilation and execution
				 * statistics for this interpreter. */
#endif /* TCL_COMPILE_STATS */	  
} Interp;

/*






































 * EvalFlag bits for Interp structures:
 *
 * TCL_ALLOW_EXCEPTIONS	1 means it's OK for the script to terminate with
 *			a code other than TCL_OK or TCL_ERROR;	0 means
 *			codes other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS	  4

/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of
 *			Tcl_Eval are done.
 * ERR_ALREADY_LOGGED:	Non-zero means information has already been logged
 *			in iPtr->errorInfo for the current Tcl_Eval instance,
 *			so Tcl_Eval needn't log it (used to implement the
 *			"error message log" command).
 * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler
 *			should not compile any commands into an inline
 *			sequence of instructions. This is set 1, for
 *			example, when command traces are requested.
 * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the
 *			interp has not be initialized.	This is set 1
 *			when we first use the rand() or srand() functions.
 * SAFE_INTERP:		Non zero means that the current interp is a
 *			safe interp (ie it has only the safe commands
 *			installed, less priviledge than a regular interp).
 * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
 *			active; so no further trace callbacks should be
 *			invoked.




 *
 * WARNING: For the sake of some extensions that have made use of former
 * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
 * or 8 (formerly ERROR_CODE_SET).
 */

#define DELETED				    1
#define ERR_ALREADY_LOGGED		    4
#define DONT_COMPILE_CMDS_INLINE	 0x20
#define RAND_SEED_INITIALIZED		 0x40
#define SAFE_INTERP			 0x80
#define INTERP_TRACE_IN_PROGRESS	0x200


/*
 * Maximum number of levels of nesting permitted in Tcl commands (used
 * to catch infinite recursion).
 */

#define MAX_NESTING_DEPTH	1000

/*
 * TIP#143 limit handler internal representation.
 */

struct LimitHandler {
    int flags;			/* The state of this particular handler. */
    Tcl_LimitHandlerProc *handlerProc; /* The handler callback. */

    ClientData clientData;	/* Opaque argument to the handler callback. */
    Tcl_LimitHandlerDeleteProc *deleteProc; /* How to delete the clientData */

    LimitHandler *prevPtr;	/* Previous item in linked list of handlers */
    LimitHandler *nextPtr;	/* Next item in linked list of handlers */
};

/*
 * Values for the LimitHandler flags field.
 *	LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
 *		processed; handlers are never to be entered reentrantly.
 *	LIMIT_HANDLER_DELETED - Whether the handler has been deleted.  This
 *		should not normally be observed because when a handler is
 *		deleted it is also spliced out of the list of handlers, but
 *		even so we will be careful.
 */

#define LIMIT_HANDLER_ACTIVE	0x01
#define LIMIT_HANDLER_DELETED	0x02

/*
 * The macro below is used to modify a "char" value (e.g. by casting
 * it to an unsigned character) so that it can be used safely with
 * macros such as isspace.
 */

#define UCHAR(c) ((unsigned char) (c))

/*
 * This macro is used to determine the offset needed to safely allocate any
 * data structure in memory. Given a starting offset or size, it "rounds up"
 * or "aligns" the offset to the next 8-byte boundary so that any data
 * structure can be placed at the resulting offset without fear of an
 * alignment error.
 *
 * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce
 * the wrong result on platforms that allocate addresses that are divisible
 * by 4 or 2. Only use it for offsets or sizes.
 *
 * This macro is only used by tclCompile.c in the core (Bug 926445). It
 * however not be made file static, as extensions that touch bytecodes
 * (notably tbcload) require it.
 */

#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)


/*
 * The following enum values are used to specify the runtime platform
 * setting of the tclPlatform variable.
 */

typedef enum {
    TCL_PLATFORM_UNIX = 0,	/* Any Unix-like OS. */
    TCL_PLATFORM_WINDOWS = 2	/* Any Microsoft Windows OS. */
} TclPlatformType;

/*
 *  The following enum values are used to indicate the translation
 *  of a Tcl channel.  Declared here so that each platform can define
 *  TCL_PLATFORM_TRANSLATION to the native translation on that platform
 */

typedef enum TclEolTranslation {
    TCL_TRANSLATE_AUTO,		/* Eol == \r, \n and \r\n. */
    TCL_TRANSLATE_CR,		/* Eol == \r. */
    TCL_TRANSLATE_LF,		/* Eol == \n. */
    TCL_TRANSLATE_CRLF		/* Eol == \r\n. */
} TclEolTranslation;

/*
 * Flags for TclInvoke:
 *
 * TCL_INVOKE_HIDDEN		Invoke a hidden command; if not set,
 *				invokes an exposed command.
 * TCL_INVOKE_NO_UNKNOWN	If set, "unknown" is not invoked if
 *				the command to be invoked is not found.
 *				Only has an effect if invoking an exposed
 *				command, i.e. if TCL_INVOKE_HIDDEN is not
 *				also set.
 * TCL_INVOKE_NO_TRACEBACK	Does not record traceback information if
 *				the invoked command returns an error.  Used
 *				if the caller plans on recording its own
 *				traceback information.
 */

#define	TCL_INVOKE_HIDDEN	(1<<0)
#define TCL_INVOKE_NO_UNKNOWN	(1<<1)
#define TCL_INVOKE_NO_TRACEBACK	(1<<2)

/*
 * The structure used as the internal representation of Tcl list
 * objects. This is an array of pointers to the element objects. This array
 * is grown (reallocated and copied) as necessary to hold all the list's
 * element pointers. The array might contain more slots than currently used
 * to hold all element pointers. This is done to make append operations
 * faster.
 */

typedef struct List {

    int maxElemCount;		/* Total number of element array slots. */
    int elemCount;		/* Current number of list elements. */




    Tcl_Obj **elements;		/* Array of pointers to element objects. */

} List;

/*







































 *----------------------------------------------------------------
 * Data structures related to the filesystem internals
 *----------------------------------------------------------------
 */


/* 
 * The version_2 filesystem is private to Tcl.  As and when these
 * changes have been thoroughly tested and investigated a new public
 * filesystem interface will be released.  The aim is more versatile
 * virtual filesystem interfaces, more efficiency in 'path' manipulation
 * and usage, and cleaner filesystem code internally.
 */

#define TCL_FILESYSTEM_VERSION_2	((Tcl_FSVersion) 0x2)
typedef ClientData (TclFSGetCwdProc2) _ANSI_ARGS_((ClientData clientData));

/*
 * The following types are used for getting and storing platform-specific
 * file attributes in tclFCmd.c and the various platform-versions of
 * that file. This is done to have as much common code as possible
 * in the file attributes code. For more information about the callbacks,
 * see TclFileAttrsCmd in tclFCmd.c.
 */

typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr));
typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
	int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr));

typedef struct TclFileAttrProcs {
    TclGetFileAttrProc *getProc;	/* The procedure for getting attrs. */
    TclSetFileAttrProc *setProc;	/* The procedure for setting attrs. */
} TclFileAttrProcs;

/*
 * Opaque handle used in pipeline routines to encapsulate platform-dependent
 * state. 
 */

typedef struct TclFile_ *TclFile;
    
/*
 * The "globParameters" argument of the function TclGlob is an
 * or'ed combination of the following values:
 */

#define TCL_GLOBMODE_NO_COMPLAIN	1
#define TCL_GLOBMODE_JOIN		2
#define TCL_GLOBMODE_DIR		4
#define TCL_GLOBMODE_TAILS		8

typedef enum Tcl_PathPart {
    TCL_PATH_DIRNAME,
    TCL_PATH_TAIL,	
    TCL_PATH_EXTENSION,
    TCL_PATH_ROOT
} Tcl_PathPart;

/*
 *----------------------------------------------------------------
 * Data structures related to obsolete filesystem hooks
 *----------------------------------------------------------------
 */

typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf));
typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode));
typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp,
	CONST char *fileName, CONST char *modeString,
	int permissions));


/*
 *----------------------------------------------------------------
 * Data structures related to procedures
 *----------------------------------------------------------------
 */

typedef Tcl_CmdProc *TclCmdProcType;
typedef Tcl_ObjCmdProc *TclObjCmdProcType;

/*
 *----------------------------------------------------------------
 * Data structures for process-global values.
 *----------------------------------------------------------------
 */

typedef void (TclInitProcessGlobalValueProc) _ANSI_ARGS_((char **valuePtr,
	int *lengthPtr, Tcl_Encoding *encodingPtr));

/*
 * A ProcessGlobalValue struct exists for each internal value in
 * Tcl that is to be shared among several threads.  Each thread
 * sees a (Tcl_Obj) copy of the value, and the master is kept as
 * a counted string, with epoch and mutex control.  Each ProcessGlobalValue
 * struct should be a static variable in some file.

 */

typedef struct ProcessGlobalValue {
    int epoch;			/* Epoch counter to detect changes
				 * in the master value */
    int numBytes;		/* Length of the master string */
    char *value;		/* The master string value */
    Tcl_Encoding encoding;	/* system encoding when master string
				 * was initialized */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the
				 * master string copy when a "get"
				 * request comes in before any
				 * "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from
				 * multiple threads */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding
				 * the (Tcl_Obj) copy for each thread */
} ProcessGlobalValue;






























/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

MODULE_SCOPE char *	tclNativeExecutableName;
MODULE_SCOPE int	tclFindExecutableSearchDone;
MODULE_SCOPE char *	tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier;










/*
 * Variables denoting the Tcl object types defined in the core.
 */


MODULE_SCOPE Tcl_ObjType tclBooleanType;
MODULE_SCOPE Tcl_ObjType tclByteArrayType;
MODULE_SCOPE Tcl_ObjType tclByteCodeType;
MODULE_SCOPE Tcl_ObjType tclDoubleType;
MODULE_SCOPE Tcl_ObjType tclEndOffsetType;
MODULE_SCOPE Tcl_ObjType tclIntType;
MODULE_SCOPE Tcl_ObjType tclListType;
MODULE_SCOPE Tcl_ObjType tclDictType;
MODULE_SCOPE Tcl_ObjType tclProcBodyType;
MODULE_SCOPE Tcl_ObjType tclStringType;
MODULE_SCOPE Tcl_ObjType tclArraySearchType;
MODULE_SCOPE Tcl_ObjType tclIndexType;
MODULE_SCOPE Tcl_ObjType tclNsNameType;
MODULE_SCOPE Tcl_ObjType tclEnsembleCmdType;

MODULE_SCOPE Tcl_ObjType tclWideIntType;
MODULE_SCOPE Tcl_ObjType tclLocalVarNameType;

MODULE_SCOPE Tcl_ObjType tclRegexpType;
MODULE_SCOPE Tcl_ObjType tclLevelReferenceType;

/*
 * Variables denoting the hash key types defined in the core.
 */

MODULE_SCOPE Tcl_HashKeyType tclArrayHashKeyType;
MODULE_SCOPE Tcl_HashKeyType tclOneWordHashKeyType;







|
|
|
|
|
|
|
|

|




















|


|














|












|
|












|
|

|
|
|
|
|
|




|
|
|

|
|




|









|
|
|
|
|
|
|
|




|
|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|



|




|
|










|
|
|
|
|




|
|
<
|
|
|
|
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|





|



|
|
|
|
|
|
|
|







<
<
|
|
|
<
|
>
>
>
|
|



|
|



|
|
|
|




|
|
|
|
|
<




|
|






>
>


|
|
|







|
<




|
|








|
|
|





|
|
|




|
|


|
<
|
|




>
>
|




|
|
<





|
|







|
|


|
|
|
|
|
|
|
|
|
>
>


|

|
|






|
|



|
|
|
|
|
<



|
|
|


>






|
|
|
|
|








|
|
|
|
|
<
|
|
<
|
|
|
>
>
>
|



|
|
|

|
<
|
|
|
|
|
|
|
|
<










|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|











|
|
|
|
|
>







|
|
|
|
|












|
|




|
|



|
|
|



|
|
|
|




|
|
<
|










|
|





|
|
|
|
|





|

|
|
|
|

|
|
|
|
|



|



>











|
|
|
<
|
|








|
|
|

|
|













|
|
|
<
|




<

|
|
|








|
|






|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|






|
|


|
|

|
|
|

<
<

|
|




|
|
|




|
|


|
|
|

|
|





|
|


|
|
|


|
|


|


|
|
|
|
|
|
|
|









|


|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|


|
|

|

|

|


|
|
|

|
|















|
|




















|
|






|
|
|
>
|
|
|



|
>
|
|
|
>
>
>

|
|
|
|



|
|




|
|
|
|






>
>
>
>
>
>
>
>
>
>






|
|
|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|
|


|








|
|
|
|
|
|
|
|
|
|
|
|
|
|



>
>
>
>












>


|
|










|
>

|
>








|









|
|
|











|
|
|










|
|








|
|
|












|
|
|
|
|
|
<
|
|
|
|







|
<
|
|
|




>


>
>
>
>
|
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





<
|
|
|
|
|
|

>

|


|
|
|
|
|


|
|
|
|


|
|




|



|

|
|









|










|
|
|
|
<
<
















|
|


|
|
|
<
|
>

>

|
|
|
|
|
|

|
<
|
|
|
|
|
|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>
>
>
>
>
>
>
>
>




>











<

<
>

<
>

<







606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794

795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846


847
848
849

850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876

877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903

904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937

938
939
940
941
942
943
944
945
946
947
948
949
950
951
952

953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003

1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036

1037
1038

1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053

1054
1055
1056
1057
1058
1059
1060
1061

1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166

1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228

1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260

1261
1262
1263
1264
1265

1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295

1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317


1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387

1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707

1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719

1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782

1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845


1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868

1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881

1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955

1956

1957
1958

1959
1960

1961
1962
1963
1964
1965
1966
1967
#define TclClearVarNamespaceVar(varPtr) \
    (varPtr)->flags &= ~VAR_NAMESPACE_VAR

/*
 * Macros to read various flag bits of variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE int	TclIsVarScalar(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarLink(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarArray(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarUndefined(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarArrayElement(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarTemporary(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarArgument(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarResolved(Var *varPtr);
 */

#define TclIsVarScalar(varPtr) \
    ((varPtr)->flags & VAR_SCALAR)

#define TclIsVarLink(varPtr) \
    ((varPtr)->flags & VAR_LINK)

#define TclIsVarArray(varPtr) \
    ((varPtr)->flags & VAR_ARRAY)

#define TclIsVarUndefined(varPtr) \
    ((varPtr)->flags & VAR_UNDEFINED)

#define TclIsVarArrayElement(varPtr) \
    ((varPtr)->flags & VAR_ARRAY_ELEMENT)

#define TclIsVarNamespaceVar(varPtr) \
    ((varPtr)->flags & VAR_NAMESPACE_VAR)

#define TclIsVarTemporary(varPtr) \
    ((varPtr)->flags & VAR_TEMPORARY)

#define TclIsVarArgument(varPtr) \
    ((varPtr)->flags & VAR_ARGUMENT)

#define TclIsVarResolved(varPtr) \
    ((varPtr)->flags & VAR_RESOLVED)

#define TclIsVarTraceActive(varPtr) \
    ((varPtr)->flags & VAR_TRACE_ACTIVE)

#define TclIsVarUntraced(varPtr) \
    ((varPtr)->tracePtr == NULL)

/*
 * Macros for direct variable access by TEBC
 */

#define TclIsVarDirectReadable(varPtr) \
	(TclIsVarScalar(varPtr) \
    && !TclIsVarUndefined(varPtr) \
    && TclIsVarUntraced(varPtr))

#define TclIsVarDirectWritable(varPtr) \
    (   !(((varPtr)->flags & VAR_IN_HASHTABLE) \
		&& ((varPtr)->hPtr == NULL)) \
     && TclIsVarUntraced(varPtr) \
     && (TclIsVarScalar(varPtr) \
	     || TclIsVarUndefined(varPtr)))

/*
 *----------------------------------------------------------------
 * Data structures related to procedures. These are used primarily in
 * tclProc.c, tclCompile.c, and tclExecute.c.
 *----------------------------------------------------------------
 */

/*
 * Forward declaration to prevent an error when the forward reference to
 * Command is encountered in the Proc and ImportRef types declared below.
 */

struct Command;

/*
 * The variable-length structure below describes a local variable of a
 * procedure that was recognized by the compiler. These variables have a name,
 * an element in the array of compiler-assigned local variables in the
 * procedure's call frame, and various other items of information. If the
 * local variable is a formal argument, it may also have a default value. The
 * compiler can't recognize local variables whose names are expressions (these
 * names are only known at runtime when the expressions are evaluated) or
 * local variables that are created as a result of an "upvar" or "uplevel"
 * command. These other local variables are kept separately in a hash table in
 * the call frame.
 */

typedef struct CompiledLocal {
    struct CompiledLocal *nextPtr;
				/* Next compiler-recognized local variable for
				 * this procedure, or NULL if this is the last
				 * local. */
    int nameLength;		/* The number of characters in local
				 * variable's name. Used to speed up variable
				 * lookups. */
    int frameIndex;		/* Index in the array of compiler-assigned
				 * variables in the procedure call frame. */
    int flags;			/* Flag bits for the local variable. Same as
				 * the flags for the Var structure above,
				 * although only VAR_SCALAR, VAR_ARRAY,
				 * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and
				 * VAR_RESOLVED make sense. */
    Tcl_Obj *defValuePtr;	/* Pointer to the default value of an
				 * argument, if any. NULL if not an argument
				 * or, if an argument, no default value. */
    Tcl_ResolvedVarInfo *resolveInfo;
				/* Customized variable resolution info
				 * supplied by the Tcl_ResolveCompiledVarProc
				 * associated with a namespace. Each variable
				 * is marked by a unique ClientData tag during
				 * compilation, and that same tag is used to
				 * find the variable at runtime. */
    char name[4];		/* Name of the local variable starts here. If
				 * the name is NULL, this will just be '\0'.
				 * The actual size of this field will be large
				 * enough to hold the name. MUST BE THE LAST
				 * FIELD IN THE STRUCTURE! */
} CompiledLocal;

/*
 * The structure below defines a command procedure, which consists of a
 * collection of Tcl commands plus information about arguments and other local
 * variables recognized at compile time.
 */

typedef struct Proc {
    struct Interp *iPtr;	/* Interpreter for which this command is
				 * defined. */
    int refCount;		/* Reference count: 1 if still present in
				 * command table plus 1 for each call to the
				 * procedure that is currently active. This
				 * structure can be freed when refCount
				 * becomes zero. */
    struct Command *cmdPtr;	/* Points to the Command structure for this
				 * procedure. This is used to get the
				 * namespace in which to execute the
				 * procedure. */
    Tcl_Obj *bodyPtr;		/* Points to the ByteCode object for
				 * procedure's body command. */
    int numArgs;		/* Number of formal parameters. */
    int numCompiledLocals;	/* Count of local variables recognized by the
				 * compiler including arguments and
				 * temporaries. */
    CompiledLocal *firstLocalPtr;
				/* Pointer to first of the procedure's
				 * compiler-allocated local variables, or NULL
				 * if none. The first numArgs entries in this
				 * list describe the procedure's formal
				 * arguments. */
    CompiledLocal *lastLocalPtr;/* Pointer to the last allocated local
				 * variable or NULL if none. This has frame
				 * index (numCompiledLocals-1). */
} Proc;

/*
 * The structure below defines a command trace. This is used to allow Tcl
 * clients to find out whenever a command is about to be executed.
 */

typedef struct Trace {
    int level;			/* Only trace commands at nesting level less
				 * than or equal to this. */
    Tcl_CmdObjTraceProc *proc;	/* Procedure to call to trace command. */
    ClientData clientData;	/* Arbitrary value to pass to proc. */
    struct Trace *nextPtr;	/* Next in list of traces for this interp. */
    int flags;			/* Flags governing the trace - see
				 * Tcl_CreateObjTrace for details */
    Tcl_CmdObjTraceDeleteProc* delProc;
				/* Procedure to call when trace is deleted */
} Trace;

/*
 * When an interpreter trace is active (i.e. its associated procedure is
 * executing), one of the following structures is linked into a list
 * associated with the interpreter. The information in the structure is needed
 * in order for Tcl to behave reasonably if traces are deleted while traces
 * are active.
 */

typedef struct ActiveInterpTrace {
    struct ActiveInterpTrace *nextPtr;
				/* Next in list of all active command traces
				 * for the interpreter, or NULL if no more. */

    Trace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
    int reverseScan;		/* Boolean set true when traces are scanning
				 * in reverse order. */
} ActiveInterpTrace;

/*
 * Flag values designating types of execution traces. See tclTrace.c for
 * related flag values.
 *
 * TCL_TRACE_ENTER_EXEC		- triggers enter/enterstep traces.
 * 				- passed to Tcl_CreateObjTrace to set up
 *				  "enterstep" traces.
 * TCL_TRACE_LEAVE_EXEC		- triggers leave/leavestep traces.
 * 				- passed to Tcl_CreateObjTrace to set up
 *				  "leavestep" traces.
 *
 */
#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2

/*
 * The structure below defines an entry in the assocData hash table which is
 * associated with an interpreter. The entry contains a pointer to a function
 * to call when the interpreter is deleted, and a pointer to a user-defined
 * piece of data.
 */

typedef struct AssocData {
    Tcl_InterpDeleteProc *proc;	/* Proc to call when deleting. */
    ClientData clientData;	/* Value to pass to proc. */
} AssocData;

/*
 * The structure below defines a call frame. A call frame defines a naming
 * context for a procedure call: its local naming scope (for local variables)
 * and its global naming scope (a namespace, perhaps the global :: namespace).
 * A call frame can also define the naming context for a namespace eval or
 * namespace inscope command: the namespace in which the command's code should
 * execute. The Tcl_CallFrame structures exist only while procedures or
 * namespace eval/inscope's are being executed, and provide a kind of Tcl call
 * stack.
 *
 * WARNING!! The structure definition must be kept consistent with the
 * Tcl_CallFrame structure in tcl.h. If you change one, change the other.
 */

typedef struct CallFrame {
    Namespace *nsPtr;		/* Points to the namespace used to resolve
				 * commands and global variables. */


    int isProcCallFrame;	/* If 0, the frame was pushed to execute a
				 * namespace command and var references are
				 * treated as references to namespace vars;

				 * varTablePtr and compiledLocals are ignored.
				 * If FRAME_IS_PROC is set, the frame was
				 * pushed to execute a Tcl procedure and may
				 * have local vars. */
    int objc;			/* This and objv below describe the arguments
				 * for this procedure call. */
    Tcl_Obj *CONST *objv;	/* Array of argument objects. */
    struct CallFrame *callerPtr;
				/* Value of interp->framePtr when this
				 * procedure was invoked (i.e. next higher in
				 * stack of all active procedures). */
    struct CallFrame *callerVarPtr;
				/* Value of interp->varFramePtr when this
				 * procedure was invoked (i.e. determines
				 * variable scoping within caller). Same as
				 * callerPtr unless an "uplevel" command or
				 * something equivalent was active in the
				 * caller). */
    int level;			/* Level of this procedure, for "uplevel"
				 * purposes (i.e. corresponds to nesting of
				 * callerVarPtr's, not callerPtr's). 1 for
				 * outermost procedure, 0 for top-level. */
    Proc *procPtr;		/* Points to the structure defining the called
				 * procedure. Used to get information such as
				 * the number of compiled local variables
				 * (local variables assigned entries ["slots"]
				 * in the compiledLocals array below). */

    Tcl_HashTable *varTablePtr;	/* Hash table containing local variables not
				 * recognized by the compiler, or created at
				 * execution time through, e.g., upvar.
				 * Initially NULL and created if needed. */
    int numCompiledLocals;	/* Count of local variables recognized by the
				 * compiler including arguments. */
    Var* compiledLocals;	/* Points to the array of local variables
				 * recognized by the compiler. The compiler
				 * emits code that refers to these variables
				 * using an index into this array. */
} CallFrame;

#define FRAME_IS_PROC 0x1

/*
 *----------------------------------------------------------------
 * Data structures and procedures related to TclHandles, which are a very
 * lightweight method of preserving enough information to determine if an
 * arbitrary malloc'd block has been deleted.
 *----------------------------------------------------------------
 */

typedef VOID **TclHandle;

/*
 *----------------------------------------------------------------
 * Data structures related to expressions. These are used only in tclExpr.c.

 *----------------------------------------------------------------
 */

/*
 * The data structure below defines a math function (e.g. sin or hypot) for
 * use in Tcl expressions.
 */

#define MAX_MATH_ARGS 5
typedef struct MathFunc {
    int builtinFuncIndex;	/* If this is a builtin math function, its
				 * index in the array of builtin functions.
				 * (tclCompilation.h lists these indices.)
				 * The value is -1 if this is a new function
				 * defined by Tcl_CreateMathFunc. The value is
				 * also -1 if a builtin function is replaced
				 * by a Tcl_CreateMathFunc call. */
    int numArgs;		/* Number of arguments for function. */
    Tcl_ValueType argTypes[MAX_MATH_ARGS];
				/* Acceptable types for each argument. */
    Tcl_MathProc *proc;		/* Procedure that implements this function.
				 * NULL if isBuiltinFunc is 1. */
    ClientData clientData;	/* Additional argument to pass to the function
				 * when invoking it. NULL if isBuiltinFunc is
				 * 1. */
} MathFunc;

/*
 * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet
 * when threads are used, or an emulation if there are no threads. These are
 * really internal and Tcl clients should use Tcl_GetThreadData.
 */

MODULE_SCOPE VOID *	TclThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);

MODULE_SCOPE void	TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
			    VOID *data);

/*
 * This is a convenience macro used to initialize a thread local storage ptr.
 */

#define TCL_TSD_INIT(keyPtr) \
  (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))


/*
 *----------------------------------------------------------------
 * Data structures related to bytecode compilation and execution. These are
 * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c.

 *----------------------------------------------------------------
 */

/*
 * Forward declaration to prevent errors when the forward references to
 * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc
 * declared below.
 */

struct CompileEnv;

/*
 * The type of procedures called by the Tcl bytecode compiler to compile
 * commands. Pointers to these procedures are kept in the Command structure
 * describing each command. The integer value returned by a CompileProc must
 * be one of the following:
 *
 * TCL_OK		Compilation completed normally.
 * TCL_ERROR 		Compilation could not be completed. This can be just a
 * 			judgment by the CompileProc that the command is too
 * 			complex to compile effectively, or it can indicate
 * 			that in the current state of the interp, the command
 * 			would raise an error. The bytecode compiler will not
 * 			do any error reporting at compiler time. Error
 * 			reporting is deferred until the actual runtime,
 * 			because by then changes in the interp state may allow
 * 			the command to be successfully evaluated.
 * TCL_OUT_LINE_COMPILE	A source-compatible alias for TCL_ERROR, kept for the
 * 			sake of old code only.
 */

#define TCL_OUT_LINE_COMPILE	TCL_ERROR

typedef int (CompileProc) (Tcl_Interp *interp, Tcl_Parse *parsePtr,
	struct CompileEnv *compEnvPtr);

/*
 * The type of procedure called from the compilation hook point in
 * SetByteCodeFromAny.
 */

typedef int (CompileHookProc) (Tcl_Interp *interp,
	struct CompileEnv *compEnvPtr, ClientData clientData);

/*
 * The data structure defining the execution environment for ByteCode's.
 * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
 * stack that holds command operands and results. The stack grows towards
 * increasing addresses. The "stackTop" member is cached by TclExecuteByteCode
 * in a local variable: it must be set before calling TclExecuteByteCode and
 * will be restored by TclExecuteByteCode before it returns.

 */

typedef struct ExecEnv {
    Tcl_Obj **stackPtr;		/* Points to the first item in the evaluation
				 * stack on the heap. */
    Tcl_Obj **tosPtr;		/* Points to current top of stack;
				 * (stackPtr-1) when the stack is empty. */
    Tcl_Obj **endPtr;		/* Points to last usable item in stack. */
    Tcl_Obj *constants[2];	/* Pointers to constant "0" and "1" objs. */
} ExecEnv;

/*
 * The definitions for the LiteralTable and LiteralEntry structures. Each
 * interpreter contains a LiteralTable. It is used to reduce the storage
 * needed for all the Tcl objects that hold the literals of scripts compiled
 * by the interpreter. A literal's object is shared by all the ByteCodes that
 * refer to the literal. Each distinct literal has one LiteralEntry entry in
 * the LiteralTable. A literal table is a specialized hash table that is
 * indexed by the literal's string representation, which may contain null
 * characters.
 *
 * Note that we reduce the space needed for literals by sharing literal
 * objects both within a ByteCode (each ByteCode contains a local
 * LiteralTable) and across all an interpreter's ByteCodes (with the
 * interpreter's global LiteralTable).
 */

typedef struct LiteralEntry {
    struct LiteralEntry *nextPtr;
				/* Points to next entry in this hash bucket or
				 * NULL if end of chain. */
    Tcl_Obj *objPtr;		/* Points to Tcl object that holds the
				 * literal's bytes and length. */

    int refCount;		/* If in an interpreter's global literal
				 * table, the number of ByteCode structures

				 * that share the literal object; the literal
				 * entry can be freed when refCount drops to
				 * 0. If in a local literal table, -1. */
    Namespace *nsPtr;		/* Namespace in which this literal is used. We
				 * try to avoid sharing literal non-FQ command
				 * names among different namespaces to reduce
				 * shimmering. */
} LiteralEntry;

typedef struct LiteralTable {
    LiteralEntry **buckets;	/* Pointer to bucket array. Each element
				 * points to first entry in bucket's hash
				 * chain, or NULL. */
    LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
				/* Bucket array used for small tables to avoid

				 * mallocs and frees. */
    int numBuckets;		/* Total number of buckets allocated at
				 * **buckets. */
    int numEntries;		/* Total number of entries present in
				 * table. */
    int rebuildSize;		/* Enlarge table when numEntries gets to be
				 * this large. */
    int mask;			/* Mask value used in hashing function. */

} LiteralTable;

/*
 * The following structure defines for each Tcl interpreter various
 * statistics-related information about the bytecode compiler and
 * interpreter's operation in that interpreter.
 */

#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
    long numExecutions;		/* Number of ByteCodes executed. */
    long numCompilations;	/* Number of ByteCodes created. */
    long numByteCodesFreed;	/* Number of ByteCodes destroyed. */
    long instructionCount[256];	/* Number of times each instruction was
				 * executed. */

    double totalSrcBytes;	/* Total source bytes ever compiled. */
    double totalByteCodeBytes;	/* Total bytes for all ByteCodes. */
    double currentSrcBytes;	/* Src bytes for all current ByteCodes. */
    double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */

    long srcCount[32];		/* Source size distribution: # of srcs of
				 * size [2**(n-1)..2**n), n in [0..32). */
    long byteCodeCount[32];	/* ByteCode size distribution. */
    long lifetimeCount[32];	/* ByteCode lifetime distribution (ms). */

    double currentInstBytes;	/* Instruction bytes-current ByteCodes. */
    double currentLitBytes;	/* Current literal bytes. */
    double currentExceptBytes;	/* Current exception table bytes. */
    double currentAuxBytes;	/* Current auxiliary information bytes. */
    double currentCmdMapBytes;	/* Current src<->code map bytes. */

    long numLiteralsCreated;	/* Total literal objects ever compiled. */
    double totalLitStringBytes;	/* Total string bytes in all literals. */
    double currentLitStringBytes;
				/* String bytes in current literals. */
    long literalCount[32];	/* Distribution of literal string sizes. */
} ByteCodeStats;
#endif /* TCL_COMPILE_STATS */

/*
 *----------------------------------------------------------------
 * Data structures related to commands.
 *----------------------------------------------------------------
 */

/*
 * An imported command is created in an namespace when it imports a "real"
 * command from another namespace. An imported command has a Command structure
 * that points (via its ClientData value) to the "real" Command structure in
 * the source namespace's command table. The real command records all the
 * imported commands that refer to it in a list of ImportRef structures so
 * that they can be deleted when the real command is deleted.
 */

typedef struct ImportRef {
    struct Command *importedCmdPtr;
				/* Points to the imported command created in
				 * an importing namespace; this command
				 * redirects its invocations to the "real"
				 * command. */
    struct ImportRef *nextPtr;	/* Next element on the linked list of imported
				 * commands that refer to the "real" command.
				 * The real command deletes these imported
				 * commands on this list when it is
				 * deleted. */
} ImportRef;

/*
 * Data structure used as the ClientData of imported commands: commands
 * created in an namespace when it imports a "real" command from another
 * namespace.
 */

typedef struct ImportedCmdData {
    struct Command *realCmdPtr;	/* "Real" command that this imported command
				 * refers to. */
    struct Command *selfPtr;	/* Pointer to this imported command. Needed
				 * only when deleting it in order to remove it
				 * from the real command's linked list of
				 * imported commands that refer to it. */
} ImportedCmdData;

/*
 * A Command structure exists for each command in a namespace. The Tcl_Command
 * opaque type actually refers to these structures.
 */

typedef struct Command {
    Tcl_HashEntry *hPtr;	/* Pointer to the hash table entry that refers
				 * to this command. The hash table is either a
				 * namespace's command table or an
				 * interpreter's hidden command table. This
				 * pointer is used to get a command's name
				 * from its Tcl_Command handle. NULL means
				 * that the hash table entry has been removed
				 * already (this can happen if deleteProc
				 * causes the command to be deleted or
				 * recreated). */
    Namespace *nsPtr;		/* Points to the namespace containing this
				 * command. */
    int refCount;		/* 1 if in command hashtable plus 1 for each
				 * reference from a CmdName Tcl object
				 * representing a command's name in a ByteCode
				 * instruction sequence. This structure can be

				 * freed when refCount becomes zero. */
    int cmdEpoch;		/* Incremented to invalidate any references
				 * that point to this command when it is
				 * renamed, deleted, hidden, or exposed. */
    CompileProc *compileProc;	/* Procedure called to compile command. NULL
				 * if no compile proc exists for command. */
    Tcl_ObjCmdProc *objProc;	/* Object-based command procedure. */
    ClientData objClientData;	/* Arbitrary value passed to object proc. */
    Tcl_CmdProc *proc;		/* String-based command procedure. */
    ClientData clientData;	/* Arbitrary value passed to string proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* Procedure invoked when deleting command to,
				 * e.g., free all client data. */
    ClientData deleteData;	/* Arbitrary value passed to deleteProc. */
    int flags;			/* Miscellaneous bits of information about
				 * command. See below for definitions. */
    ImportRef *importRefPtr;	/* List of each imported Command created in
				 * another namespace when this command is
				 * imported. These imported commands redirect
				 * invocations back to this command. The list
				 * is used to remove all those imported
				 * commands when deleting this "real"
				 * command. */
    CommandTrace *tracePtr;	/* First in list of all traces set for this
				 * command. */
} Command;

/*
 * Flag bits for commands.
 *
 * CMD_IS_DELETED -		Means that the command is in the process of
 *				being deleted (its deleteProc is currently
 *				executing). Other attempts to delete the
 *				command should be ignored.
 * CMD_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a rename/delete change. See the
 *				two flags below for which is currently being
 *				processed.
 * CMD_HAS_EXEC_TRACES -	1 means that this command has at least one
 *				execution trace (as opposed to simple
 *				delete/rename traces) in its tracePtr list.
 * TCL_TRACE_RENAME -		A rename trace is in progress. Further
 *				recursive renames will not be traced.
 * TCL_TRACE_DELETE -		A delete trace is in progress. Further
 *				recursive deletes will not be traced.
 * (these last two flags are defined in tcl.h)
 */

#define CMD_IS_DELETED		0x1
#define CMD_TRACE_ACTIVE	0x2
#define CMD_HAS_EXEC_TRACES	0x4

/*
 *----------------------------------------------------------------
 * Data structures related to name resolution procedures.
 *----------------------------------------------------------------
 */

/*
 * The interpreter keeps a linked list of name resolution schemes. The scheme
 * for a namespace is consulted first, followed by the list of schemes in an
 * interpreter, followed by the default name resolution in Tcl. Schemes are

 * added/removed from the interpreter's list by calling Tcl_AddInterpResolver
 * and Tcl_RemoveInterpResolver.
 */

typedef struct ResolverScheme {
    char *name;			/* Name identifying this scheme. */
    Tcl_ResolveCmdProc *cmdResProc;
				/* Procedure handling command name
				 * resolution. */
    Tcl_ResolveVarProc *varResProc;
				/* Procedure handling variable name resolution
				 * for variables that can only be handled at
				 * runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarResProc;
				/* Procedure handling variable name resolution
				 * at compile time. */

    struct ResolverScheme *nextPtr;
				/* Pointer to next record in linked list. */
} ResolverScheme;

/*
 * Forward declaration of the TIP#143 limit handler structure.
 */

typedef struct LimitHandler LimitHandler;

/*
 *----------------------------------------------------------------
 * This structure defines an interpreter, which is a collection of commands
 * plus other state information related to interpreting commands, such as
 * variable storage. Primary responsibility for this data structure is in

 * tclBasic.c, but almost every Tcl source file uses something in here.
 *----------------------------------------------------------------
 */

typedef struct Interp {

    /*
     * Note: the first three fields must match exactly the fields in a
     * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the
     * other.
     *
     * The interpreter's result is held in both the string and the
     * objResultPtr fields. These fields hold, respectively, the result's
     * string or object value. The interpreter's result is always in the
     * result field if that is non-empty, otherwise it is in objResultPtr.
     * The two fields are kept consistent unless some C code sets
     * interp->result directly. Programs should not access result and
     * objResultPtr directly; instead, they should always get and set the
     * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and
     * Tcl_GetStringResult. See the SetResult man page for details.
     */

    char *result;		/* If the last command returned a string
				 * result, this points to it. Should not be
				 * accessed directly; see comment above. */
    Tcl_FreeProc *freeProc;	/* Zero means a string result is statically
				 * allocated. TCL_DYNAMIC means string result
				 * was allocated with ckalloc and should be
				 * freed with ckfree. Other values give
				 * address of procedure to invoke to free the
				 * string result. Tcl_Eval must free it before
				 * executing next command. */
    int errorLine;		/* When TCL_ERROR is returned, this gives the
				 * line number in the command where the error
				 * occurred (1 means first line). */
    struct TclStubs *stubTable;	/* Pointer to the exported Tcl stub table. On

				 * previous versions of Tcl this is a pointer
				 * to the objResultPtr or a pointer to a
				 * buckets array in a hash table. We therefore
				 * have to do some careful checking before we
				 * can use this. */

    TclHandle handle;		/* Handle used to keep track of when this
				 * interp is deleted. */

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep track
				 * of hidden commands on a per-interp
				 * basis. */
    ClientData interpInfo;	/* Information used by tclInterp.c to keep
				 * track of master/slave interps on a
				 * per-interp basis. */
    Tcl_HashTable mathFuncTable;/* Contains all the math functions currently
				 * defined for the interpreter. Indexed by
				 * strings (function names); values have type
				 * (MathFunc *). */



    /*
     * Information related to procedures and variables. See tclProc.c and
     * tclVar.c for usage.
     */

    int numLevels;		/* Keeps track of how many nested calls to
				 * Tcl_Eval are in progress for this
				 * interpreter. It's used to delay deletion of
				 * the table until all Tcl_Eval invocations
				 * are completed. */
    int maxNestingDepth;	/* If numLevels exceeds this value then Tcl
				 * assumes that infinite recursion has
				 * occurred and it generates an error. */
    CallFrame *framePtr;	/* Points to top-most in stack of all nested
				 * procedure invocations. NULL means there are
				 * no active procedures. */
    CallFrame *varFramePtr;	/* Points to the call frame whose variables
				 * are currently in use (same as framePtr
				 * unless an "uplevel" command is executing).
				 * NULL means no procedure is active or
				 * "uplevel 0" is executing. */
    ActiveVarTrace *activeVarTracePtr;
				/* First in list of active traces for interp,
				 * or NULL if no active traces. */
    int returnCode;		/* [return -code] parameter */
    char *unused3;		/* No longer used (was errorInfo) */
    char *unused4;		/* No longer used (was errorCode) */

    /*
     * Information used by Tcl_AppendResult to keep track of partial results.
     * See Tcl_AppendResult code for details.
     */

    char *appendResult;		/* Storage space for results generated by
				 * Tcl_AppendResult. Ckalloc-ed. NULL means
				 * not yet allocated. */
    int appendAvl;		/* Total amount of space available at
				 * partialResult. */
    int appendUsed;		/* Number of non-null bytes currently stored
				 * at partialResult. */

    /*
     * Information about packages. Used only in tclPkg.c.
     */

    Tcl_HashTable packageTable;	/* Describes all of the packages loaded in or
				 * available to this interpreter. Keys are
				 * package names, values are (Package *)
				 * pointers. */
    char *packageUnknown;	/* Command to invoke during "package require"
				 * commands for packages that aren't described
				 * in packageTable. Ckalloc'ed, may be
				 * NULL. */

    /*
     * Miscellaneous information:
     */

    int cmdCount;		/* Total number of times a command procedure
				 * has been called for this interpreter. */
    int evalFlags;		/* Flags to control next call to Tcl_Eval.
				 * Normally zero, but may be set before
				 * calling Tcl_Eval. See below for valid
				 * values. */
    int unused1;		/* No longer used (was termOffset) */
    LiteralTable literalTable;	/* Contains LiteralEntry's describing all Tcl
				 * objects holding literals of scripts
				 * compiled by the interpreter. Indexed by the
				 * string representations of literals. Used to
				 * avoid creating duplicate objects. */

    int compileEpoch;		/* Holds the current "compilation epoch" for
				 * this interpreter. This is incremented to
				 * invalidate existing ByteCodes when, e.g., a
				 * command with a compile procedure is
				 * redefined. */
    Proc *compiledProcPtr;	/* If a procedure is being compiled, a pointer
				 * to its Proc structure; otherwise, this is
				 * NULL. Set by ObjInterpProc in tclProc.c and
				 * used by tclCompile.c to process local
				 * variables appropriately. */
    ResolverScheme *resolverPtr;
				/* Linked list of name resolution schemes
				 * added to this interpreter. Schemes are
				 * added and removed by calling
				 * Tcl_AddInterpResolvers and
				 * Tcl_RemoveInterpResolver respectively. */
    Tcl_Obj *scriptFile;	/* NULL means there is no nested source
				 * command active; otherwise this points to
				 * pathPtr of the file being sourced. */
    int flags;			/* Various flag bits. See below. */
    long randSeed;		/* Seed used for rand() function. */
    Trace *tracePtr;		/* List of traces for this interpreter. */
    Tcl_HashTable *assocData;	/* Hash table for associating data with this
				 * interpreter. Cleaned up when this
				 * interpreter is deleted. */
    struct ExecEnv *execEnvPtr;	/* Execution environment for Tcl bytecode
				 * execution. Contains a pointer to the Tcl
				 * evaluation stack. */
    Tcl_Obj *emptyObjPtr;	/* Points to an object holding an empty
				 * string. Returned by Tcl_ObjSetVar2 when
				 * variable traces change a variable in a
				 * gross way. */
    char resultSpace[TCL_RESULT_SIZE+1];
				/* Static space holding small results. */
    Tcl_Obj *objResultPtr;	/* If the last command returned an object
				 * result, this points to it. Should not be
				 * accessed directly; see comment above. */
    Tcl_ThreadId threadId;	/* ID of thread that owns the interpreter */

    ActiveCommandTrace *activeCmdTracePtr;
				/* First in list of active command traces for
				 * interp, or NULL if no active traces. */
    ActiveInterpTrace *activeInterpTracePtr;
				/* First in list of active traces for interp,
				 * or NULL if no active traces. */

    int tracesForbiddingInline; /* Count of traces (in the list headed by
				 * tracePtr) that forbid inline bytecode
				 * compilation */

    /* Fields used to manage extensible return options (TIP 90) */
    Tcl_Obj *returnOpts;	/* A dictionary holding the options to the
				 * last [return] command */

    Tcl_Obj *errorInfo;		/* errorInfo value (now as a Tcl_Obj) */
    Tcl_Obj *eiVar;		/* cached ref to ::errorInfo variable */
    Tcl_Obj *errorCode;		/* errorCode value (now as a Tcl_Obj) */
    Tcl_Obj *ecVar;		/* cached ref to ::errorInfo variable */
    int returnLevel;		/* [return -level] parameter */

    /*
     * Resource limiting framework support (TIP#143).
     */

    struct {
	int active;		/* Flag values defining which limits have been
				 * set. */
	int granularityTicker;	/* Counter used to determine how often to
				 * check the limits. */
	int exceeded;		/* Which limits have been exceeded, described
				 * as flag values the same as the 'active'
				 * field. */

	int cmdCount;		/* Limit for how many commands to execute in
				 * the interpreter. */
	LimitHandler *cmdHandlers;
				/* Handlers to execute when the limit is
				 * reached. */
	int cmdGranularity;	/* Mod factor used to determine how often to
				 * evaluate the limit check. */

	Tcl_Time time;		/* Time limit for execution within the
				 * interpreter. */
	LimitHandler *timeHandlers;
				/* Handlers to execute when the limit is
				 * reached. */
	int timeGranularity;	/* Mod factor used to determine how often to
				 * evaluate the limit check. */
	Tcl_TimerToken timeEvent;
				/* Handle for a timer callback that will occur
				 * when the time-limit is exceeded. */

	Tcl_HashTable callbacks;/* Mapping from (interp,type) pair to data
				 * used to install a limit handler callback to
				 * run in _this_ interp when the limit is
				 * exceeded. */
    } limit;

    /*
     * Information for improved default error generation from ensembles
     * (TIP#112).
     */

    struct {
	Tcl_Obj * CONST *sourceObjs;
				/* What arguments were actually input into the
				 * *root* ensemble command? (Nested ensembles
				 * don't rewrite this.) NULL if we're not
				 * processing an ensemble. */
	int numRemovedObjs;	/* How many arguments have been stripped off
				 * because of ensemble processing. */
	int numInsertedObjs;	/* How many of the current arguments were
				 * inserted by an ensemble. */
    } ensembleRewrite;

    /*
     * TIP #219 ... Global info for the I/O system ...
     */

    Tcl_Obj* chanMsg;		/* Error message set by channel drivers, for
				 * the propagation of arbitrary Tcl errors.
				 * This information, if present (chanMsg not
				 * NULL), takes precedence over a posix error
				 * code returned by a channel operation. */

    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation.
     */

#ifdef TCL_COMPILE_STATS
    ByteCodeStats stats;	/* Holds compilation and execution statistics
				 * for this interpreter. */
#endif /* TCL_COMPILE_STATS */
} Interp;

/*
 * General list of interpreters. Doubly linked for easier removal of items
 * deep in the list.
 */

typedef struct InterpList {
    Interp* interpPtr;
    struct InterpList* prevPtr;
    struct InterpList* nextPtr;
} InterpList;

/*
 * Macros for splicing into and out of doubly linked lists. They assume
 * existence of struct items 'prevPtr' and 'nextPtr'.
 *
 * a = element to add or remove.
 * b = list head.
 *
 * TclSpliceIn adds to the head of the list.
 */

#define TclSpliceIn(a,b)			\
    (a)->nextPtr = (b);				\
    if ((b) != NULL) {				\
	(b)->prevPtr = (a);			\
    }						\
    (a)->prevPtr = NULL, (b) = (a);

#define TclSpliceOut(a,b)			\
    if ((a)->prevPtr != NULL) {			\
	(a)->prevPtr->nextPtr = (a)->nextPtr;	\
    } else {					\
	(b) = (a)->nextPtr;			\
    }						\
    if ((a)->nextPtr != NULL) {			\
	(a)->nextPtr->prevPtr = (a)->prevPtr;	\
    }

/*
 * EvalFlag bits for Interp structures:
 *
 * TCL_ALLOW_EXCEPTIONS	1 means it's OK for the script to terminate with a
 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS	4

/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of
 *			Tcl_Eval are done.
 * ERR_ALREADY_LOGGED:	Non-zero means information has already been logged in
 *			iPtr->errorInfo for the current Tcl_Eval instance, so
 *			Tcl_Eval needn't log it (used to implement the "error
 *			message log" command).
 * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler should
 *			not compile any commands into an inline sequence of
 *			instructions. This is set 1, for example, when command
 *			traces are requested.
 * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp
 *			has not be initialized. This is set 1 when we first
 *			use the rand() or srand() functions.
 * SAFE_INTERP:		Non zero means that the current interp is a safe
 *			interp (i.e. it has only the safe commands installed,
 *			less priviledge than a regular interp).
 * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
 *			active; so no further trace callbacks should be
 *			invoked.
 * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms
 *			of the wrong-num-args string in Tcl_WrongNumArgs.
 *			Makes it append instead of replacing and uses
 *			different intermediate text.
 *
 * WARNING: For the sake of some extensions that have made use of former
 * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
 * or 8 (formerly ERROR_CODE_SET).
 */

#define DELETED				    1
#define ERR_ALREADY_LOGGED		    4
#define DONT_COMPILE_CMDS_INLINE	 0x20
#define RAND_SEED_INITIALIZED		 0x40
#define SAFE_INTERP			 0x80
#define INTERP_TRACE_IN_PROGRESS	0x200
#define INTERP_ALTERNATE_WRONG_ARGS	0x400

/*
 * Maximum number of levels of nesting permitted in Tcl commands (used to
 * catch infinite recursion).
 */

#define MAX_NESTING_DEPTH	1000

/*
 * TIP#143 limit handler internal representation.
 */

struct LimitHandler {
    int flags;			/* The state of this particular handler. */
    Tcl_LimitHandlerProc *handlerProc;
				/* The handler callback. */
    ClientData clientData;	/* Opaque argument to the handler callback. */
    Tcl_LimitHandlerDeleteProc *deleteProc;
				/* How to delete the clientData */
    LimitHandler *prevPtr;	/* Previous item in linked list of handlers */
    LimitHandler *nextPtr;	/* Next item in linked list of handlers */
};

/*
 * Values for the LimitHandler flags field.
 *	LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
 *		processed; handlers are never to be entered reentrantly.
 *	LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
 *		should not normally be observed because when a handler is
 *		deleted it is also spliced out of the list of handlers, but
 *		even so we will be careful.
 */

#define LIMIT_HANDLER_ACTIVE	0x01
#define LIMIT_HANDLER_DELETED	0x02

/*
 * The macro below is used to modify a "char" value (e.g. by casting it to an
 * unsigned character) so that it can be used safely with macros such as
 * isspace.
 */

#define UCHAR(c) ((unsigned char) (c))

/*
 * This macro is used to determine the offset needed to safely allocate any
 * data structure in memory. Given a starting offset or size, it "rounds up"
 * or "aligns" the offset to the next 8-byte boundary so that any data
 * structure can be placed at the resulting offset without fear of an
 * alignment error.
 *
 * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the
 * wrong result on platforms that allocate addresses that are divisible by 4
 * or 2. Only use it for offsets or sizes.
 *
 * This macro is only used by tclCompile.c in the core (Bug 926445). It
 * however not be made file static, as extensions that touch bytecodes
 * (notably tbcload) require it.
 */

#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)


/*
 * The following enum values are used to specify the runtime platform setting
 * of the tclPlatform variable.
 */

typedef enum {
    TCL_PLATFORM_UNIX = 0,	/* Any Unix-like OS. */
    TCL_PLATFORM_WINDOWS = 2	/* Any Microsoft Windows OS. */
} TclPlatformType;

/*
 * The following enum values are used to indicate the translation of a Tcl
 * channel. Declared here so that each platform can define
 * TCL_PLATFORM_TRANSLATION to the native translation on that platform
 */

typedef enum TclEolTranslation {
    TCL_TRANSLATE_AUTO,		/* Eol == \r, \n and \r\n. */
    TCL_TRANSLATE_CR,		/* Eol == \r. */
    TCL_TRANSLATE_LF,		/* Eol == \n. */
    TCL_TRANSLATE_CRLF		/* Eol == \r\n. */
} TclEolTranslation;

/*
 * Flags for TclInvoke:
 *
 * TCL_INVOKE_HIDDEN		Invoke a hidden command; if not set, invokes
 *				an exposed command.
 * TCL_INVOKE_NO_UNKNOWN	If set, "unknown" is not invoked if the
 *				command to be invoked is not found. Only has
 *				an effect if invoking an exposed command,
 *				i.e. if TCL_INVOKE_HIDDEN is not also set.

 * TCL_INVOKE_NO_TRACEBACK	Does not record traceback information if the
 *				invoked command returns an error. Used if the
 *				caller plans on recording its own traceback
 *				information.
 */

#define	TCL_INVOKE_HIDDEN	(1<<0)
#define TCL_INVOKE_NO_UNKNOWN	(1<<1)
#define TCL_INVOKE_NO_TRACEBACK	(1<<2)

/*
 * The structure used as the internal representation of Tcl list objects. This

 * struct is grown (reallocated and copied) as necessary to hold all the
 * list's element pointers. The struct might contain more slots than currently
 * used to hold all element pointers. This is done to make append operations
 * faster.
 */

typedef struct List {
    int refCount;
    int maxElemCount;		/* Total number of element array slots. */
    int elemCount;		/* Current number of list elements. */
    int canonicalFlag;		/* Set if the string representation was
				 * derived from the list representation. May
				 * be ignored if there is no string rep at
				 * all.*/
    Tcl_Obj *elements;		/* First list element; the struct is grown to
				 * accomodate all elements. */
} List;

/*
 * Macro used to get the elements of a list object - do NOT forget to verify
 * that it is of list type before using!
 */

#define TclListObjGetElements(listPtr, objc, objv) \
    { \
	List *listRepPtr = \
		(List *) (listPtr)->internalRep.twoPtrValue.ptr1;\
	(objc) = listRepPtr->elemCount;\
	(objv) = &listRepPtr->elements;\
    }

/*
 * Flag values for TclTraceDictPath().
 *
 * DICT_PATH_READ indicates that all entries on the path must exist but no
 * updates will be needed.
 *
 * DICT_PATH_UPDATE indicates that we are going to be doing an update at the
 * tip of the path, so duplication of shared objects should be done along the
 * way.
 *
 * DICT_PATH_EXISTS indicates that we are performing an existance test and a
 * lookup failure should therefore not be an error. If (and only if) this flag
 * is set, TclTraceDictPath() will return the special value
 * DICT_PATH_NON_EXISTENT if the path is not traceable.
 *
 * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set)
 * indicates that we are to create non-existant dictionaries on the path.
 */

#define DICT_PATH_READ		0
#define DICT_PATH_UPDATE	1
#define DICT_PATH_EXISTS	2
#define DICT_PATH_CREATE	5

#define DICT_PATH_NON_EXISTENT	((Tcl_Obj *) (void *) 1)

/*
 *----------------------------------------------------------------
 * Data structures related to the filesystem internals
 *----------------------------------------------------------------
 */


/*
 * The version_2 filesystem is private to Tcl. As and when these changes have
 * been thoroughly tested and investigated a new public filesystem interface
 * will be released. The aim is more versatile virtual filesystem interfaces,
 * more efficiency in 'path' manipulation and usage, and cleaner filesystem
 * code internally.
 */

#define TCL_FILESYSTEM_VERSION_2	((Tcl_FSVersion) 0x2)
typedef ClientData (TclFSGetCwdProc2) (ClientData clientData);

/*
 * The following types are used for getting and storing platform-specific file
 * attributes in tclFCmd.c and the various platform-versions of that file.
 * This is done to have as much common code as possible in the file attributes
 * code. For more information about the callbacks, see TclFileAttrsCmd in
 * tclFCmd.c.
 */

typedef int (TclGetFileAttrProc) (Tcl_Interp *interp, int objIndex,
	Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr);
typedef int (TclSetFileAttrProc) (Tcl_Interp *interp, int objIndex,
	Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);

typedef struct TclFileAttrProcs {
    TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
    TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;

/*
 * Opaque handle used in pipeline routines to encapsulate platform-dependent
 * state.
 */

typedef struct TclFile_ *TclFile;

/*
 * The "globParameters" argument of the function TclGlob is an or'ed
 * combination of the following values:
 */

#define TCL_GLOBMODE_NO_COMPLAIN	1
#define TCL_GLOBMODE_JOIN		2
#define TCL_GLOBMODE_DIR		4
#define TCL_GLOBMODE_TAILS		8

typedef enum Tcl_PathPart {
    TCL_PATH_DIRNAME,
    TCL_PATH_TAIL,
    TCL_PATH_EXTENSION,
    TCL_PATH_ROOT
} Tcl_PathPart;

/*
 *----------------------------------------------------------------
 * Data structures related to obsolete filesystem hooks
 *----------------------------------------------------------------
 */

typedef int (TclStatProc_) (CONST char *path, struct stat *buf);
typedef int (TclAccessProc_) (CONST char *path, int mode);
typedef Tcl_Channel (TclOpenFileChannelProc_) (Tcl_Interp *interp,
	CONST char *fileName, CONST char *modeString, int permissions);



/*
 *----------------------------------------------------------------
 * Data structures related to procedures
 *----------------------------------------------------------------
 */

typedef Tcl_CmdProc *TclCmdProcType;
typedef Tcl_ObjCmdProc *TclObjCmdProcType;

/*
 *----------------------------------------------------------------
 * Data structures for process-global values.
 *----------------------------------------------------------------
 */

typedef void (TclInitProcessGlobalValueProc) (char **valuePtr, int *lengthPtr,
	Tcl_Encoding *encodingPtr);

/*
 * A ProcessGlobalValue struct exists for each internal value in Tcl that is
 * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
 * the value, and the master is kept as a counted string, with epoch and mutex

 * control. Each ProcessGlobalValue struct should be a static variable in some
 * file.
 */

typedef struct ProcessGlobalValue {
    int epoch;			/* Epoch counter to detect changes in the
				 * master value. */
    int numBytes;		/* Length of the master string. */
    char *value;		/* The master string value. */
    Tcl_Encoding encoding;	/* system encoding when master string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the master string

				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;

/*
 *----------------------------------------------------------------------
 * Flags for TclParseNumber
 *----------------------------------------------------------------------
 */

#define TCL_PARSE_DECIMAL_ONLY		1
				/* Leading zero doesn't denote octal or hex */
#define TCL_PARSE_OCTAL_ONLY		2
				/* Parse octal even without prefix */
#define TCL_PARSE_HEXADECIMAL_ONLY	4
				/* Parse hexadecimal even without prefix */
#define TCL_PARSE_INTEGER_ONLY		8
				/* Disable floating point parsing */
#define TCL_PARSE_SCAN_PREFIXES		16
				/* Use [scan] rules dealing with 0? prefixes */

/*
 *----------------------------------------------------------------------
 * Type values TclGetNumberFromObj
 *----------------------------------------------------------------------
 */

#define TCL_NUMBER_LONG		1
#define TCL_NUMBER_WIDE		2
#define TCL_NUMBER_BIG		3
#define TCL_NUMBER_DOUBLE	4
#define TCL_NUMBER_NAN		5

/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

MODULE_SCOPE char *	tclNativeExecutableName;
MODULE_SCOPE int	tclFindExecutableSearchDone;
MODULE_SCOPE char *	tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier;

/*
 * TIP #233 (Virtualized Time)
 * Data for the time hooks, if any.
 */

MODULE_SCOPE Tcl_GetTimeProc*   tclGetTimeProcPtr;
MODULE_SCOPE Tcl_ScaleTimeProc* tclScaleTimeProcPtr;
MODULE_SCOPE ClientData		tclTimeClientData;

/*
 * Variables denoting the Tcl object types defined in the core.
 */

MODULE_SCOPE Tcl_ObjType tclBignumType;
MODULE_SCOPE Tcl_ObjType tclBooleanType;
MODULE_SCOPE Tcl_ObjType tclByteArrayType;
MODULE_SCOPE Tcl_ObjType tclByteCodeType;
MODULE_SCOPE Tcl_ObjType tclDoubleType;
MODULE_SCOPE Tcl_ObjType tclEndOffsetType;
MODULE_SCOPE Tcl_ObjType tclIntType;
MODULE_SCOPE Tcl_ObjType tclListType;
MODULE_SCOPE Tcl_ObjType tclDictType;
MODULE_SCOPE Tcl_ObjType tclProcBodyType;
MODULE_SCOPE Tcl_ObjType tclStringType;
MODULE_SCOPE Tcl_ObjType tclArraySearchType;

MODULE_SCOPE Tcl_ObjType tclNsNameType;

#ifndef NO_WIDE_TYPE
MODULE_SCOPE Tcl_ObjType tclWideIntType;

#endif
MODULE_SCOPE Tcl_ObjType tclRegexpType;


/*
 * Variables denoting the hash key types defined in the core.
 */

MODULE_SCOPE Tcl_HashKeyType tclArrayHashKeyType;
MODULE_SCOPE Tcl_HashKeyType tclOneWordHashKeyType;
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796



1797
1798
1799
1800
1801
1802
1803


1804





1805
1806
1807

1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822

1823
1824









1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836










1837
1838
1839
1840
1841




1842


1843

1844
1845
1846
1847
1848
1849
1850
1851
1852

1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883


1884
1885
1886
1887
1888


1889
1890

1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964

1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977

1978


1979
1980



1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009


2010






2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041



2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074



2075
2076
2077
2078
2079
2080
2081
2082
2083



2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299


2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356





2357
2358
2359
2360
2361
2362
2363


2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523

2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548

2549
2550
2551
2552

2553
2554
2555
2556
2557
2558
2559
MODULE_SCOPE long	tclObjsAlloced;
MODULE_SCOPE long	tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
MODULE_SCOPE long	tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses
 * as the value of an empty string representation for an object. This value
 * is shared by all new objects allocated by Tcl_NewObj.
 */

MODULE_SCOPE char *	tclEmptyStringRep;
MODULE_SCOPE char	tclEmptyString;

/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl modules but not used by the outside
 * world:
 *----------------------------------------------------------------
 */




MODULE_SCOPE void	TclAppendLimitedToObj _ANSI_ARGS_((Tcl_Obj *objPtr, 
			    CONST char *bytes, int length, int limit,
			    CONST char *ellipsis));
MODULE_SCOPE void	TclAppendObjToErrorInfo _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Obj *objPtr));
MODULE_SCOPE int	TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));


MODULE_SCOPE int	TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,





			    CONST char *value));
MODULE_SCOPE void	TclCleanupLiteralTable _ANSI_ARGS_((
			    Tcl_Interp* interp, LiteralTable* tablePtr));

MODULE_SCOPE void	TclExpandTokenArray _ANSI_ARGS_((
			    Tcl_Parse *parsePtr));
MODULE_SCOPE int	TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, 
			    int objc, Tcl_Obj *CONST objv[])) ;
MODULE_SCOPE int	TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[])) ;
MODULE_SCOPE int	TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[])) ;
MODULE_SCOPE void	TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeCompExecEnv _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeCompilation _ANSI_ARGS_((void));

MODULE_SCOPE void	TclFinalizeEncodingSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeEnvironment _ANSI_ARGS_((void));









MODULE_SCOPE void	TclFinalizeExecution _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeIOSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeFilesystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclResetFilesystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeLoad _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeNotifier _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeAsync _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeSynchronization _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeLock _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeThreadData _ANSI_ARGS_((void));
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp));










MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue _ANSI_ARGS_ ((
			    ProcessGlobalValue *pgvPtr));
MODULE_SCOPE int	TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
			    char *pattern, Tcl_Obj *unquotedPrefix, 
			    int globFlags, Tcl_GlobTypeData* types));




MODULE_SCOPE void	TclInitAlloc _ANSI_ARGS_((void));


MODULE_SCOPE void	TclInitDbCkalloc _ANSI_ARGS_((void));

MODULE_SCOPE void	TclInitEmbeddedConfigurationInformation 
			    _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE void	TclInitEncodingSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitIOSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitLimitSupport _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE void	TclInitNamespaceSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitNotifier _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitObjSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclInitSubsystems ();

MODULE_SCOPE int	TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
			    int len));
MODULE_SCOPE int	TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
			    int* result));
MODULE_SCOPE void	TclLimitRemoveAllHandlers _ANSI_ARGS_((
			    Tcl_Interp *interp));
MODULE_SCOPE Tcl_Obj *	TclLindexList _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Obj* listPtr, Tcl_Obj* argPtr));
MODULE_SCOPE Tcl_Obj *	TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Obj* listPtr, int indexCount,
			    Tcl_Obj *CONST indexArray[]));
MODULE_SCOPE int	TclLoadFile _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Obj *pathPtr, int symc,
			    CONST char *symbols[],
			    Tcl_PackageInitProc **procPtrs[],
			    Tcl_LoadHandle *handlePtr,
			    ClientData *clientDataPtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr));
MODULE_SCOPE Tcl_Obj *	TclLsetList _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Obj* listPtr, Tcl_Obj* indexPtr,
			    Tcl_Obj* valuePtr));
MODULE_SCOPE Tcl_Obj *	TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Obj* listPtr, int indexCount,
			    Tcl_Obj *CONST indexArray[], Tcl_Obj* valuePtr));
MODULE_SCOPE int	TclMergeReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Obj **optionsPtrPtr, int *codePtr,
			    int *levelPtr));
MODULE_SCOPE int	TclObjInvokeNamespace _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Namespace *nsPtr, int flags));


MODULE_SCOPE int	TclParseBackslash _ANSI_ARGS_((CONST char *src,
			    int numBytes, int *readPtr, char *dst));
MODULE_SCOPE int	TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,
			    Tcl_UniChar *resultPtr));
MODULE_SCOPE void	TclParseInit _ANSI_ARGS_ ((Tcl_Interp *interp,


			    CONST char *string, int numBytes,
			    Tcl_Parse *parsePtr));

MODULE_SCOPE int	TclParseInteger _ANSI_ARGS_((CONST char *string,
			    int numBytes));
MODULE_SCOPE int	TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
			    int numBytes, Tcl_Parse *parsePtr, char *typePtr));
MODULE_SCOPE int	TclProcessReturn _ANSI_ARGS_((Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts));
MODULE_SCOPE int	TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    Tcl_StatBuf *buf));
MODULE_SCOPE int	TclpCheckStackSpace _ANSI_ARGS_((void));
MODULE_SCOPE Tcl_Obj *	TclpTempFileName _ANSI_ARGS_((void));
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj _ANSI_ARGS_((Tcl_Obj *dirPtr, 
			    CONST char *addStrRep, int len));
MODULE_SCOPE int	TclpDeleteFile _ANSI_ARGS_((CONST char *path));
MODULE_SCOPE void	TclpFinalizeCondition _ANSI_ARGS_((
			    Tcl_Condition *condPtr));
MODULE_SCOPE void	TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
MODULE_SCOPE void	TclpFinalizeThreadData _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
MODULE_SCOPE int	TclpThreadCreate _ANSI_ARGS_((
			    Tcl_ThreadId *idPtr,
			    Tcl_ThreadCreateProc proc,
			    ClientData clientData,
			    int stackSize, int flags));
MODULE_SCOPE void	TclpFinalizeThreadDataKey _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
MODULE_SCOPE int	TclpFindVariable _ANSI_ARGS_((CONST char *name,
			    int *lengthPtr));
MODULE_SCOPE void	TclpInitLibraryPath _ANSI_ARGS_((char **valuePtr,
			    int *lengthPtr, Tcl_Encoding *encodingPtr));
MODULE_SCOPE void	TclpInitLock _ANSI_ARGS_((void));
MODULE_SCOPE void	TclpInitPlatform _ANSI_ARGS_((void));
MODULE_SCOPE void	TclpInitUnlock _ANSI_ARGS_((void));
MODULE_SCOPE int	TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, 
			    Tcl_Obj *pathPtr, CONST char *sym1,
			    CONST char *sym2, Tcl_PackageInitProc **proc1Ptr,
			    Tcl_PackageInitProc **proc2Ptr, 
			    ClientData *clientDataPtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr));
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes _ANSI_ARGS_((void));
MODULE_SCOPE void	TclpMasterLock _ANSI_ARGS_((void));
MODULE_SCOPE void	TclpMasterUnlock _ANSI_ARGS_((void));
MODULE_SCOPE int	TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
			    char *separators, Tcl_DString *dirPtr,
			    char *pattern, char *tail));
MODULE_SCOPE int	TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp, 
			    Tcl_Obj *pathPtr, int nextCheckpoint));
MODULE_SCOPE void	TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix, 
			    char *joining));
MODULE_SCOPE Tcl_Obj *	TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    int *lenPtr));
MODULE_SCOPE Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathPtr,
			    int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
MODULE_SCOPE int 	TclCrossFilesystemCopy _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Obj *source,
			    Tcl_Obj *target));
MODULE_SCOPE int	TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, 
			    Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, 
			    CONST char *pattern, Tcl_GlobTypeData *types));
MODULE_SCOPE ClientData	TclpGetNativeCwd _ANSI_ARGS_((ClientData clientData));
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj*	TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    Tcl_Obj *toPtr, int linkType));
MODULE_SCOPE int	TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
MODULE_SCOPE Tcl_Obj *	TclPathPart _ANSI_ARGS_((Tcl_Interp *interp, 
			    Tcl_Obj *pathPtr, Tcl_PathPart portion));
MODULE_SCOPE void	TclpCutFileChannel _ANSI_ARGS_((Tcl_Channel chan));
MODULE_SCOPE void	TclpCutSockChannel _ANSI_ARGS_((Tcl_Channel chan));
MODULE_SCOPE void	TclpSpliceFileChannel _ANSI_ARGS_((Tcl_Channel chan));
MODULE_SCOPE void	TclpSpliceSockChannel _ANSI_ARGS_((Tcl_Channel chan));
MODULE_SCOPE void	TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,
			    format));
MODULE_SCOPE char *	TclpReadlink _ANSI_ARGS_((CONST char *fileName,
			    Tcl_DString *linkPtr));
MODULE_SCOPE void	TclpReleaseFile _ANSI_ARGS_((TclFile file));

MODULE_SCOPE void	TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE void	TclpUnloadFile _ANSI_ARGS_((
			    Tcl_LoadHandle loadHandle));
MODULE_SCOPE VOID *	TclpThreadDataKeyGet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
MODULE_SCOPE void	TclpThreadDataKeyInit _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
MODULE_SCOPE void	TclpThreadDataKeySet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr, VOID *data));
MODULE_SCOPE void	TclpThreadExit _ANSI_ARGS_((int status));
MODULE_SCOPE int	TclpThreadGetStackSize _ANSI_ARGS_((void));
MODULE_SCOPE void	TclRememberCondition _ANSI_ARGS_((
			    Tcl_Condition *mutex));

MODULE_SCOPE void	TclRememberDataKey _ANSI_ARGS_((


			    Tcl_ThreadDataKey *mutex));
MODULE_SCOPE VOID	TclRememberJoinableThread _ANSI_ARGS_((



			    Tcl_ThreadId id));
MODULE_SCOPE void	TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
MODULE_SCOPE void	TclRemoveScriptLimitCallbacks _ANSI_ARGS_((
			    Tcl_Interp *interp));
MODULE_SCOPE void	TclSetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *cmdPrefix));
MODULE_SCOPE void	TclSetProcessGlobalValue _ANSI_ARGS_ ((
			    ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue,
			    Tcl_Encoding encoding));
MODULE_SCOPE VOID	TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
			    int result));
MODULE_SCOPE int	TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int count,
			    int *tokensLeftPtr));
MODULE_SCOPE void	TclTransferResult _ANSI_ARGS_((
			    Tcl_Interp *sourceInterp, int result,
			    Tcl_Interp *targetInterp));
MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized _ANSI_ARGS_((
			    ClientData clientData));
MODULE_SCOPE Tcl_Obj *	TclpFilesystemPathType _ANSI_ARGS_((
			    Tcl_Obj* pathPtr));
MODULE_SCOPE Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_LoadHandle loadHandle,
			    CONST char *symbol));
MODULE_SCOPE int	TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, 
			    Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, 
			    Tcl_FSUnloadFileProc **unloadProcPtr));
MODULE_SCOPE int	TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr,
			    struct utimbuf *tval));


MODULE_SCOPE int	TclIsEnsemble _ANSI_ARGS_((Command *cmdPtr));







/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_BreakObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));



MODULE_SCOPE int	TclClockClicksObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockGetenvObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockMicrosecondsObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockMillisecondsObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockSecondsObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockLocaltimeObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockMktimeObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	TclClockOldscanObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));



MODULE_SCOPE int	TclDefaultBgErrorHandlerObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_DictObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));



MODULE_SCOPE int	Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ExecObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FconfigureObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FileEventObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ForObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_GlobObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_IfObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_IncrObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LassignObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LrepeatObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LsetObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp* interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_PackageObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_RegsubObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_ScanObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SeekObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SetObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SocketObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SubstObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_TellObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_UnloadObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_VwaitObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
MODULE_SCOPE int	Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));

/*
 *----------------------------------------------------------------
 * Compilation procedures for commands in the generic core:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));


MODULE_SCOPE int	TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileLassignCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileListCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileLsetCmd _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Parse* parsePtr, struct CompileEnv* envPtr));
MODULE_SCOPE int	TclCompileRegexpCmd _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Parse* parsePtr, struct CompileEnv* envPtr));
MODULE_SCOPE int	TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileSwitchCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
MODULE_SCOPE int	TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));

/*
 * Functions defined in generic/tclVar.c and currenttly exported only 
 * for use by the bytecode compiler and engine. Some of these could later 
 * be placed in the public interface.
 */

MODULE_SCOPE Var *	TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *arrayName, CONST char *elName,
			    CONST int flags, CONST char *msg,
			    CONST int createPart1, CONST int createPart2,
			    Var *arrayPtr));	
MODULE_SCOPE Var *	TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *part1Ptr, CONST char *part2, int flags,
			    CONST char *msg, CONST int createPart1,
			    CONST int createPart2, Var **arrayPtrPtr));
MODULE_SCOPE Tcl_Obj *	TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, CONST int flags));
MODULE_SCOPE Tcl_Obj *	TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, Tcl_Obj *newValuePtr,
			    CONST int flags));





MODULE_SCOPE Tcl_Obj *	TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, CONST long i, CONST int flags));
MODULE_SCOPE Tcl_Obj *	TclPtrIncrWideVar _ANSI_ARGS_((Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, CONST Tcl_WideInt i,
			    CONST int flags));



/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count,
 * and frees the object if its reference count is zero.
 * These macros are inline versions of Tcl_NewObj() and
 * Tcl_DecrRefCount(). Notice that the names differ in not having
 * a "_" after the "Tcl". Notice also that these macros reference
 * their argument more than once, so you should avoid calling them
 * with an expression that is expensive to compute or has
 * side effects. The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
 * MODULE_SCOPE void	TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
 *
 * These macros are defined in terms of two macros that depend on 
 * memory allocator in use: TclAllocObjStorage, TclFreeObjStorage.
 * They are defined below.
 *----------------------------------------------------------------
 */

#ifdef TCL_COMPILE_STATS
#  define TclIncrObjsAllocated() \
    tclObjsAlloced++
#  define TclIncrObjsFreed() \
    tclObjsFreed++
#else
#  define TclIncrObjsAllocated()
#  define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */

/*
 * All context references used in the object freeing code are pointers
 * to this structure; every thread will have its own structure
 * instance.  The purpose of this structure is to allow deeply nested
 * collections of Tcl_Objs to be freed without taking a vast depth of
 * C stack (which could cause all sorts of breakage.)
 */

typedef struct PendingObjData {
    int deletionCount;		/* Count of the number of invokations of
				 * TclFreeObj() are on the stack (at least
				 * conceptually; many are actually expanded
				 * macros). */
    Tcl_Obj *deletionStack;	/* Stack of objects that have had TclFreeObj()
				 * invoked upon them but which can't be deleted
				 * yet because they are in a nested invokation
				 * of TclFreeObj(). By postponing this way, we
				 * limit the maximum overall C stack depth when
				 * deleting a complex object. The down-side is
				 * that we alter the overall behaviour by
				 * altering the order in which objects are
				 * deleted, and we change the order in which
				 * the string rep and the internal rep of an
				 * object are deleted. Note that code which
				 * assumes the previous behaviour in either of
				 * these respects is unsafe anyway; it was
				 * never documented as to exactly what would
				 * happen in these cases, and the overall
				 * contract of a user-level Tcl_DecrRefCount()
				 * is still preserved (assuming that a
				 * particular T_DRC would delete an object is
				 * not very safe). */
} PendingObjData;

/*
 * These are separated out so that some semantic content is attached
 * to them.
 */
#define TclObjDeletionLock(contextPtr)   (contextPtr)->deletionCount++
#define TclObjDeletionUnlock(contextPtr) (contextPtr)->deletionCount--
#define TclObjDeletePending(contextPtr)  (contextPtr)->deletionCount > 0
#define TclObjOnStack(contextPtr)	 (contextPtr)->deletionStack != NULL
#define TclPushObjToDelete(contextPtr,objPtr) \
    /* Invalidate the string rep first so we can use the bytes value \
     * for our pointer chain. */ \
    if (((objPtr)->bytes != NULL) \
	    && ((objPtr)->bytes != tclEmptyStringRep)) { \
	ckfree((char *) (objPtr)->bytes); \
    } \
    /* Now push onto the head of the stack. */ \
    (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
    (contextPtr)->deletionStack = (objPtr)
#define TclPopObjToDelete(contextPtr,objPtrVar) \
    (objPtrVar) = (contextPtr)->deletionStack; \
    (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes

/*
 * Macro to set up the local reference to the deletion context.
 */
#ifndef TCL_THREADS
MODULE_SCOPE PendingObjData tclPendingObjData;
#define TclObjInitDeletionContext(contextPtr) \
    PendingObjData *CONST contextPtr = &tclPendingObjData
#else
MODULE_SCOPE Tcl_ThreadDataKey tclPendingObjDataKey;
#define TclObjInitDeletionContext(contextPtr) \
    PendingObjData *CONST contextPtr = (PendingObjData *) \
	    Tcl_GetThreadData(&tclPendingObjDataKey, sizeof(PendingObjData))
#endif

#ifndef TCL_MEM_DEBUG
# define TclNewObj(objPtr) \
    TclIncrObjsAllocated(); \
    TclAllocObjStorage(objPtr); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL

# define TclDecrRefCount(objPtr) \
    if (--(objPtr)->refCount <= 0) { \
	TclObjInitDeletionContext(contextPtr); \
	if (TclObjDeletePending(contextPtr)) { \
	    TclPushObjToDelete(contextPtr,objPtr); \
	} else { \
	    TclFreeObjMacro(contextPtr,objPtr); \
	} \
    }

/*
 * Note that the contents of the while loop assume that the string rep
 * has already been freed and we don't want to do anything fancy with
 * adding to the queue inside ourselves. Must take care to unstack the
 * object first since freeing the internal rep can add further objects
 * to the stack. The code assumes that it is the first thing in a
 * block; all current usages in the core satisfy this.
 *
 * Optimization opportunity: Allocate the context once in a large
 * function (e.g. TclExecuteByteCode) and use it directly instead of
 * looking it up each time.
 */
#define TclFreeObjMacro(contextPtr,objPtr) \
    if (((objPtr)->typePtr != NULL) \
	    && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
	TclObjDeletionLock(contextPtr); \
	(objPtr)->typePtr->freeIntRepProc(objPtr); \
	TclObjDeletionUnlock(contextPtr); \
    } \
    if (((objPtr)->bytes != NULL) \
	    && ((objPtr)->bytes != tclEmptyStringRep)) { \
	ckfree((char *) (objPtr)->bytes); \
    } \
    TclFreeObjStorage(objPtr); \
    TclIncrObjsFreed(); \
    TclObjDeletionLock(contextPtr); \
    while (TclObjOnStack(contextPtr)) { \
	Tcl_Obj *objToFree; \
	TclPopObjToDelete(contextPtr,objToFree); \
	if ((objToFree->typePtr != NULL) \
		&& (objToFree->typePtr->freeIntRepProc != NULL)) { \
	    objToFree->typePtr->freeIntRepProc(objToFree); \
	} \
	TclFreeObjStorage(objToFree); \
	TclIncrObjsFreed(); \
    } \
    TclObjDeletionUnlock(contextPtr)


#if defined(PURIFY)

/*
 * The PURIFY mode is like the regular mode, but instead of doing block
 * Tcl_Obj allocation and keeping a freed list for efficiency, it always
 * allocates and frees a single Tcl_Obj so that tools like Purify can
 * better track memory leaks
 */

#  define TclAllocObjStorage(objPtr) \
	(objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj))

#  define TclFreeObjStorage(objPtr) \
	ckfree((char *) (objPtr))

#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
 * from per-thread caches.
 */

MODULE_SCOPE Tcl_Obj *	TclThreadAllocObj _ANSI_ARGS_((void));
MODULE_SCOPE void	TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));
MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex _ANSI_ARGS_((void));

MODULE_SCOPE void *	TclpGetAllocCache _ANSI_ARGS_((void));
MODULE_SCOPE void	TclpSetAllocCache _ANSI_ARGS_((void *));
MODULE_SCOPE void	TclFinalizeThreadAlloc _ANSI_ARGS_((void));
MODULE_SCOPE void	TclpFreeAllocMutex _ANSI_ARGS_((Tcl_Mutex* mutex));


#  define TclAllocObjStorage(objPtr) \
	(objPtr) = TclThreadAllocObj()

#  define TclFreeObjStorage(objPtr) \
	TclThreadFreeObj((objPtr))








|
|
|







|
<



>
>
>
|

|
|
|
|
|
>
>
|
>
>
>
>
>
|
|
|
>
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
|
<
|
|
|
>
>
>
>
|
>
>
|
>
|
|
|
|
|
|
|
|

>
|
<
|
<
|
<
|
|
|
<
|
|
<
|



|
|
<
|
|
|
|
|
|
<
|
|

|
>
>
|
|
|
|
|
>
>
|
|
>
|
|
|
|
|
|
<
|
|
|
|
|
|
|
<
|
|
<
|
<
|
<
|
<
<
|
<
|
|
|
|
|
|
|
|
|

|
|
|
|
|
<
|
|
|
|
<
|
<
|
|
|
<
|
|
|
|
|

|
|
|
|
|
<
<
<
<
|
<
|
|
|
>
|
|
<
|
<
<
<
|
|
|
|
|
<
>
|
>
>
|
|
>
>
>
<
<
<
<
<
<
<
<
<
|
<
|
<
|
|
<
|
|
<
|
<
|
|
<
|
|
|
<
|
>
>
|
>
>
>
>
>
>







|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
>
>
>
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
>
>
>
|

|
|

|
|

|
>
>
>
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|
|

|







|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|


|



|
|


|
|

|
|


|
>
>
>
>
>
|

|
|


|
>
>





|
|
<
|
|
|
|
|

|
|

|
|
|













<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<











|
<
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
<
<
<
<
<
<
<

<
<
<
<
|
>





|
|











|
|


|
|
|
>
|
|
|
|
>







1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996

1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022

2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070

2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093

2094

2095

2096
2097
2098

2099
2100

2101
2102
2103
2104
2105
2106

2107
2108
2109
2110
2111
2112

2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134

2135
2136
2137
2138
2139
2140
2141

2142
2143

2144

2145

2146


2147

2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162

2163
2164
2165
2166

2167

2168
2169
2170

2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181




2182

2183
2184
2185
2186
2187
2188

2189



2190
2191
2192
2193
2194

2195
2196
2197
2198
2199
2200
2201
2202
2203









2204

2205

2206
2207

2208
2209

2210

2211
2212

2213
2214
2215

2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603

2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628






































































2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640

2641
2642























2643
2644
2645
2646
2647
2648







2649




2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
MODULE_SCOPE long	tclObjsAlloced;
MODULE_SCOPE long	tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
MODULE_SCOPE long	tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses as
 * the value of an empty string representation for an object. This value is
 * shared by all new objects allocated by Tcl_NewObj.
 */

MODULE_SCOPE char *	tclEmptyStringRep;
MODULE_SCOPE char	tclEmptyString;

/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl modules but not used by the outside world:

 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclAppendFormattedObjs(Tcl_Interp *interp,
			    Tcl_Obj *appendObj, CONST char *format,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE void	TclAppendLimitedToObj(Tcl_Obj *objPtr,
			    CONST char *bytes, int length, int limit,
			    CONST char *ellipsis);
MODULE_SCOPE void	TclAppendObjToErrorInfo(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double	TclBignumToDouble(mp_int* bignum);
MODULE_SCOPE double	TclCeil(mp_int* a);
MODULE_SCOPE int	TclCheckBadOctal(Tcl_Interp *interp,CONST char *value);
MODULE_SCOPE int	TclChanCreateObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclChanPostEventObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
			    Tcl_Channel chan);
MODULE_SCOPE void	TclCleanupLiteralTable(Tcl_Interp* interp,
			    LiteralTable* tablePtr);
MODULE_SCOPE int	TclDoubleDigits(char* buf, double value, int* signum);
MODULE_SCOPE void	TclExpandTokenArray(Tcl_Parse *parsePtr);

MODULE_SCOPE int	TclFileAttrsCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclFileCopyCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclFileDeleteCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclFileMakeDirsCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclFileRenameCmd(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE void	TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void	TclFinalizeAsync(void);
MODULE_SCOPE void	TclFinalizeCompilation(void);
MODULE_SCOPE void	TclFinalizeDoubleConversion(void);
MODULE_SCOPE void	TclFinalizeEncodingSubsystem(void);
MODULE_SCOPE void	TclFinalizeEnvironment(void);
MODULE_SCOPE void	TclFinalizeExecution(void);
MODULE_SCOPE void	TclFinalizeIOSubsystem(void);
MODULE_SCOPE void	TclFinalizeFilesystem(void);
MODULE_SCOPE void	TclResetFilesystem(void);
MODULE_SCOPE void	TclFinalizeLoad(void);
MODULE_SCOPE void	TclFinalizeLock(void);
MODULE_SCOPE void	TclFinalizeMemorySubsystem(void);
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE double	TclFloor(mp_int* a);
MODULE_SCOPE void	TclFormatNaN(double value, char* buffer);
MODULE_SCOPE int	TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    CONST char *format, ...);
MODULE_SCOPE int	TclFormatToErrorInfo(Tcl_Interp *interp,
			    CONST char *format, ...);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
MODULE_SCOPE int	TclGetNumberFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, ClientData *clientDataPtr,
			    int *typePtr);
MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
			    CONST char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);

MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData* types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE void	TclInitAlloc(void);
MODULE_SCOPE int	TclInitBignumFromDouble(Tcl_Interp *interp, double d,
			    mp_int *b);
MODULE_SCOPE void	TclInitDbCkalloc(void);
MODULE_SCOPE void	TclInitDoubleConversion(void);
MODULE_SCOPE void	TclInitEmbeddedConfigurationInformation(
			    Tcl_Interp *interp);
MODULE_SCOPE void	TclInitEncodingSubsystem(void);
MODULE_SCOPE void	TclInitIOSubsystem(void);
MODULE_SCOPE void	TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void	TclInitNamespaceSubsystem(void);
MODULE_SCOPE void	TclInitNotifier(void);
MODULE_SCOPE void	TclInitObjSubsystem(void);
MODULE_SCOPE void	TclInitSubsystems ();
MODULE_SCOPE int	TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int	TclIsLocalScalar(CONST char *src, int len);

MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int* result);

MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);

MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp* interp,
			    Tcl_Obj* listPtr, Tcl_Obj* argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp* interp, Tcl_Obj* listPtr,

			    int indexCount, Tcl_Obj *CONST indexArray[]);
MODULE_SCOPE int	TclLoadFile(Tcl_Interp* interp, Tcl_Obj *pathPtr,

			    int symc, CONST char *symbols[],
			    Tcl_PackageInitProc **procPtrs[],
			    Tcl_LoadHandle *handlePtr,
			    ClientData *clientDataPtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr);
MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp* interp, Tcl_Obj* listPtr,

			    Tcl_Obj* indexPtr, Tcl_Obj* valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp* interp, Tcl_Obj* listPtr,
			    int indexCount, Tcl_Obj *CONST indexArray[],
			    Tcl_Obj* valuePtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr,

			    int *codePtr, int *levelPtr);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    CONST char *format, ...);
MODULE_SCOPE int	TclParseBackslash(CONST char *src,
			    int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int	TclParseHex(CONST char *src, int numBytes,
			    Tcl_UniChar *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr,
			    CONST char* type, CONST char* string,
			    size_t length, CONST char** endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, CONST char *string,
			    int numBytes, Tcl_Parse *parsePtr);
#if 0
MODULE_SCOPE int	TclParseInteger(CONST char *string, int numBytes);
#endif
MODULE_SCOPE int	TclParseWhiteSpace(CONST char *src,
			    int numBytes, Tcl_Parse *parsePtr, char *typePtr);
MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts);

MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE int	TclpCheckStackSpace(void);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep,
			    int len);
MODULE_SCOPE int	TclpDeleteFile(CONST char *path);
MODULE_SCOPE void	TclpFinalizeCondition(Tcl_Condition *condPtr);

MODULE_SCOPE void	TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
MODULE_SCOPE void	TclpFinalizePipes(void);

MODULE_SCOPE int	TclpThreadCreate(Tcl_ThreadId *idPtr,

			    Tcl_ThreadCreateProc proc, ClientData clientData,

			    int stackSize, int flags);


MODULE_SCOPE int	TclpFindVariable(CONST char *name, int *lengthPtr);

MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    int *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE int	TclpLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    CONST char *sym1, CONST char *sym2,
			    Tcl_PackageInitProc **proc1Ptr,
			    Tcl_PackageInitProc **proc2Ptr,
			    ClientData *clientDataPtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpMasterLock(void);
MODULE_SCOPE void	TclpMasterUnlock(void);
MODULE_SCOPE int	TclpMatchFiles(Tcl_Interp *interp, char *separators,

			    Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int	TclpObjNormalizePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int nextCheckpoint);
MODULE_SCOPE void	TclpNativeJoinPath(Tcl_Obj *prefix, char *joining);

MODULE_SCOPE Tcl_Obj *	TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);

MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
			    int *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE int 	TclCrossFilesystemCopy(Tcl_Interp *interp,

			    Tcl_Obj *source, Tcl_Obj *target);
MODULE_SCOPE int	TclpMatchInDirectory(Tcl_Interp *interp,
			    Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
			    CONST char *pattern, Tcl_GlobTypeData *types);
MODULE_SCOPE ClientData	TclpGetNativeCwd(ClientData clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj*	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);




MODULE_SCOPE void	TclpPanic(CONST char *format, ...);

MODULE_SCOPE char *	TclpReadlink(CONST char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpReleaseFile(TclFile file);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void	TclpUnloadFile(Tcl_LoadHandle loadHandle);

MODULE_SCOPE VOID *	TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);



MODULE_SCOPE void	TclpThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
			    VOID *data);
MODULE_SCOPE void	TclpThreadExit(int status);
MODULE_SCOPE int	TclpThreadGetStackSize(void);
MODULE_SCOPE void	TclRememberCondition(Tcl_Condition *mutex);

MODULE_SCOPE VOID	TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void	TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void	TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *cmdPrefix);
MODULE_SCOPE void	TclSetBignumIntRep (Tcl_Obj *objPtr,
			    mp_int *bignumValue);
MODULE_SCOPE void	TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
			    Tcl_Obj *newValue, Tcl_Encoding encoding);









MODULE_SCOPE VOID	TclSignalExitThread(Tcl_ThreadId id, int result);

MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,

			    int count, int *tokensLeftPtr);
MODULE_SCOPE void	TclTransferResult(Tcl_Interp *sourceInterp, int result,

			    Tcl_Interp *targetInterp);
MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized(ClientData clientData);

MODULE_SCOPE Tcl_Obj *	TclpFilesystemPathType(Tcl_Obj* pathPtr);

MODULE_SCOPE Tcl_PackageInitProc* TclpFindSymbol(Tcl_Interp *interp,
			    Tcl_LoadHandle loadHandle, CONST char *symbol);

MODULE_SCOPE int	TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr);

MODULE_SCOPE int	TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void*	TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size);
MODULE_SCOPE int	TclpLoadMemory(Tcl_Interp *interp, void *buffer,
			    int size, int codeSize, Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr);
#endif
MODULE_SCOPE void	TclInitThreadStorage(void);
MODULE_SCOPE void	TclpFinalizeThreadDataThread(void);
MODULE_SCOPE void	TclFinalizeThreadStorage(void);

/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	Tcl_AfterObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_AppendObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ArrayObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_BinaryObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_BreakObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_CaseObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_CatchObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_CdObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclChanTruncateObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockClicksObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockGetenvObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockMicrosecondsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockMillisecondsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockSecondsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockLocaltimeObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockMktimeObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclClockOldscanObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_CloseObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ConcatObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ContinueObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler(
			    Tcl_Time *timePtr, Tcl_TimerProc *proc,
			    ClientData clientData);
MODULE_SCOPE int	TclDefaultBgErrorHandlerObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_DictObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_EncodingObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclEncodingDirsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_EofObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ErrorObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_EvalObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ExecObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ExitObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ExprObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FblockedObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FconfigureObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FcopyObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FileObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FileEventObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FlushObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ForObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ForeachObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_FormatObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_GetsObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_GlobalObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_GlobObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_IfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_IncrObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_InfoObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_InterpObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int argc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_JoinObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LappendObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LassignObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LindexObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LinsertObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LlengthObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ListObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LoadObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LrangeObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LrepeatObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LreplaceObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LsearchObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LsetObjCmd(ClientData clientData,
			    Tcl_Interp* interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_LsortObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_NamespaceObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_OpenObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_PackageObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_PidObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_PutsObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_PwdObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ReadObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_RegexpObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_RegsubObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_RenameObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ReturnObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_ScanObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SeekObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SetObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SplitObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SocketObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SourceObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_StringObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SubstObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_SwitchObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_TellObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_TimeObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_TraceObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_UnloadObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_UnsetObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_UpdateObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_UplevelObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_UpvarObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_VariableObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_VwaitObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	Tcl_WhileObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);

/*
 *----------------------------------------------------------------
 * Compilation procedures for commands in the generic core:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclCompileAppendCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileBreakCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileCatchCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileContinueCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileDictCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileExprCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileForCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileForeachCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileIfCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileIncrCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileLappendCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileLassignCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileLindexCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileListCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileLlengthCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp* interp,
			    Tcl_Parse* parsePtr, struct CompileEnv* envPtr);
MODULE_SCOPE int	TclCompileRegexpCmd(Tcl_Interp* interp,
			    Tcl_Parse* parsePtr, struct CompileEnv* envPtr);
MODULE_SCOPE int	TclCompileReturnCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileSetCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileStringCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileSwitchCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileWhileCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, struct CompileEnv *envPtr);

/*
 * Functions defined in generic/tclVar.c and currenttly exported only for use
 * by the bytecode compiler and engine. Some of these could later be placed in
 * the public interface.
 */

MODULE_SCOPE Var *	TclLookupArrayElement(Tcl_Interp *interp,
			    CONST char *arrayName, CONST char *elName,
			    CONST int flags, CONST char *msg,
			    CONST int createPart1, CONST int createPart2,
			    Var *arrayPtr);
MODULE_SCOPE Var *	TclObjLookupVar(Tcl_Interp *interp,
			    Tcl_Obj *part1Ptr, CONST char *part2, int flags,
			    CONST char *msg, CONST int createPart1,
			    CONST int createPart2, Var **arrayPtrPtr);
MODULE_SCOPE Tcl_Obj *	TclPtrGetVar(Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, CONST int flags);
MODULE_SCOPE Tcl_Obj *	TclPtrSetVar(Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, Tcl_Obj *newValuePtr,
			    CONST int flags);
MODULE_SCOPE Tcl_Obj *	TclPtrIncrObjVar (Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, Tcl_Obj *incrPtr,
			    CONST int flags);
#if 0
MODULE_SCOPE Tcl_Obj *	TclPtrIncrVar(Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, CONST long i, CONST int flags);
MODULE_SCOPE Tcl_Obj *	TclPtrIncrWideVar(Tcl_Interp *interp,
			    Var *varPtr, Var *arrayPtr, CONST char *part1,
			    CONST char *part2, CONST Tcl_WideInt i,
			    CONST int flags);
#endif
MODULE_SCOPE void	TclInvalidateNsPath(Namespace *nsPtr);

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count, and frees
 * the object if its reference count is zero. These macros are inline versions

 * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not
 * having a "_" after the "Tcl". Notice also that these macros reference their
 * argument more than once, so you should avoid calling them with an
 * expression that is expensive to compute or has side effects. The ANSI C
 * "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclNewObj(Tcl_Obj *objPtr);
 * MODULE_SCOPE void	TclDecrRefCount(Tcl_Obj *objPtr);
 *
 * These macros are defined in terms of two macros that depend on memory
 * allocator in use: TclAllocObjStorage, TclFreeObjStorage. They are defined
 * below.
 *----------------------------------------------------------------
 */

#ifdef TCL_COMPILE_STATS
#  define TclIncrObjsAllocated() \
    tclObjsAlloced++
#  define TclIncrObjsFreed() \
    tclObjsFreed++
#else
#  define TclIncrObjsAllocated()
#  define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */







































































#ifndef TCL_MEM_DEBUG
# define TclNewObj(objPtr) \
    TclIncrObjsAllocated(); \
    TclAllocObjStorage(objPtr); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL

# define TclDecrRefCount(objPtr) \
    if (--(objPtr)->refCount <= 0) { \
	if ((objPtr)->typePtr && (objPtr)->typePtr->freeIntRepProc) { \

	    TclFreeObj(objPtr); \
	} else { \























	    if ((objPtr)->bytes \
		    && ((objPtr)->bytes != tclEmptyStringRep)) { \
		ckfree((char *) (objPtr)->bytes); \
	    } \
	    TclFreeObjStorage(objPtr); \
	    TclIncrObjsFreed(); \







	} \




    }

#if defined(PURIFY)

/*
 * The PURIFY mode is like the regular mode, but instead of doing block
 * Tcl_Obj allocation and keeping a freed list for efficiency, it always
 * allocates and frees a single Tcl_Obj so that tools like Purify can better
 * track memory leaks
 */

#  define TclAllocObjStorage(objPtr) \
	(objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj))

#  define TclFreeObjStorage(objPtr) \
	ckfree((char *) (objPtr))

#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
 * per-thread caches.
 */

MODULE_SCOPE Tcl_Obj *	TclThreadAllocObj(void);
MODULE_SCOPE void	TclThreadFreeObj(Tcl_Obj *);
MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
MODULE_SCOPE void	TclFreeAllocCache(void *);
MODULE_SCOPE void *	TclpGetAllocCache(void);
MODULE_SCOPE void	TclpSetAllocCache(void *);
MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
MODULE_SCOPE void	TclpFreeAllocMutex(Tcl_Mutex* mutex);
MODULE_SCOPE void	TclpFreeAllocCache(void *);

#  define TclAllocObjStorage(objPtr) \
	(objPtr) = TclThreadAllocObj()

#  define TclFreeObjStorage(objPtr) \
	TclThreadFreeObj((objPtr))

2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614



2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664


2665
2666
2667
2668
2669
2670
2671
2672





2673
2674







2675

2676
2677
2678
2679
2680

2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735








































































































































































2736
2737
2738
2739
2740
2741







	Tcl_MutexLock(&tclObjMutex); \
	(objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
	tclFreeObjList = (objPtr); \
	Tcl_MutexUnlock(&tclObjMutex)
#endif

#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void	TclDbInitNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));

# define TclDbNewObj(objPtr, file, line) \
    TclIncrObjsAllocated(); \
    (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
    TclDbInitNewObj(objPtr);

# define TclNewObj(objPtr) \
    TclDbNewObj(objPtr, __FILE__, __LINE__);

# define TclDecrRefCount(objPtr) \
    Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)

# define TclNewListObjDirect(objc, objv) \
    TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)

#undef USE_THREAD_ALLOC
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to set a Tcl_Obj's string representation
 * to a copy of the "len" bytes starting at "bytePtr". This code
 * works even if the byte array contains NULLs as long as the length
 * is correct. Because "len" is referenced multiple times, it should
 * be as simple an expression as possible. The ANSI C "prototype" for
 * this macro is:
 *
 * MODULE_SCOPE void	TclInitStringRep _ANSI_ARGS_((
 *			    Tcl_Obj *objPtr, char *bytePtr, int len));



 *----------------------------------------------------------------
 */

#define TclInitStringRep(objPtr, bytePtr, len) \
    if ((len) == 0) { \
	(objPtr)->bytes	 = tclEmptyStringRep; \
	(objPtr)->length = 0; \
    } else { \
	(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
	memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \
		(unsigned) (len)); \
	(objPtr)->bytes[len] = '\0'; \
	(objPtr)->length = (len); \
    }

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to get the string representation's
 * byte array pointer from a Tcl_Obj. This is an inline version
 * of Tcl_GetString(). The macro's expression result is the string
 * rep's byte pointer which might be NULL. The bytes referenced by 
 * this pointer must not be modified by the caller.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE char *	TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr));
 *----------------------------------------------------------------
 */

#define TclGetString(objPtr) \
    ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to clean out an object's internal
 * representation.  Does not actually reset the rep's bytes.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclFreeIntRep _ANSI_ARGS_((Tcl_Obj *objPtr));
 *----------------------------------------------------------------
 */

#define TclFreeIntRep(objPtr) \
    if ((objPtr)->typePtr != NULL && \
	    (objPtr)->typePtr->freeIntRepProc != NULL) { \
	(objPtr)->typePtr->freeIntRepProc(objPtr); \
    }

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to get a Tcl_WideInt value out of


 * a Tcl_Obj of the "wideInt" type.  Different implementation on
 * different platforms depending whether TCL_WIDE_INT_IS_LONG.
 *----------------------------------------------------------------
 */

#ifdef TCL_WIDE_INT_IS_LONG
#    define TclGetWide(resultVar, objPtr) \
	(resultVar) = (objPtr)->internalRep.longValue





#    define TclGetLongFromWide(resultVar, objPtr) \
	(resultVar) = (objPtr)->internalRep.longValue







#else

#    define TclGetWide(resultVar, objPtr) \
	(resultVar) = (objPtr)->internalRep.wideValue
#    define TclGetLongFromWide(resultVar, objPtr) \
	(resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue)
#endif


/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core get a unicode char from a utf string.
 * It checks to see if we have a one-byte utf char before calling
 * the real Tcl_UtfToUniChar, as this will save a lot of time for
 * primarily ascii string handling. The macro's expression result
 * is 1 for the 1-byte case or the result of Tcl_UtfToUniChar.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclUtfToUniChar _ANSI_ARGS_((
 *			    CONST char *string, Tcl_UniChar *ch));
 *----------------------------------------------------------------
 */

#define TclUtfToUniChar(str, chPtr) \
	((((unsigned char) *(str)) < 0xC0) ? \
	    ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
	    : Tcl_UtfToUniChar(str, chPtr))

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to compare Unicode strings.  On
 * big-endian systems we can use the more efficient memcmp, but
 * this would not be lexically correct on little-endian systems.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclUniCharNcmp _ANSI_ARGS_((
 *			    CONST Tcl_UniChar *cs,
 *			    CONST Tcl_UniChar *ct, unsigned long n));
 *----------------------------------------------------------------
 */

#ifdef WORDS_BIGENDIAN
#   define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
#else /* !WORDS_BIGENDIAN */
#   define TclUniCharNcmp Tcl_UniCharNcmp
#endif /* WORDS_BIGENDIAN */

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to increment a namespace's export
 * export epoch counter.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup _ANSI_ARGS_((
 *			    Namespace *nsPtr));
 *----------------------------------------------------------------
 */

#define TclInvalidateNsCmdLookup(nsPtr) \
    if ((nsPtr)->numExportPatterns) { \
	(nsPtr)->exportLookupEpoch++; \
    }









































































































































































#include "tclPort.h"
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"

#endif /* _TCLINT */















|




















|
|
|
|
|
<

<
|
>
>
>

















|
|
|
<
|
|

|









|
|

|











|
>
>
|
<



<
|
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
|
>





>



|
|
|
|
<
|

|
<










|
|
|
|

|
<
|











|
<
|

|
<








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
>
>
>
>
>
>
>
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740

2741

2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765

2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797

2798
2799
2800

2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831

2832
2833
2834

2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850

2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863

2864
2865
2866

2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
	Tcl_MutexLock(&tclObjMutex); \
	(objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
	tclFreeObjList = (objPtr); \
	Tcl_MutexUnlock(&tclObjMutex)
#endif

#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr);

# define TclDbNewObj(objPtr, file, line) \
    TclIncrObjsAllocated(); \
    (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
    TclDbInitNewObj(objPtr);

# define TclNewObj(objPtr) \
    TclDbNewObj(objPtr, __FILE__, __LINE__);

# define TclDecrRefCount(objPtr) \
    Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)

# define TclNewListObjDirect(objc, objv) \
    TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)

#undef USE_THREAD_ALLOC
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to set a Tcl_Obj's string representation to a
 * copy of the "len" bytes starting at "bytePtr". This code works even if the
 * byte array contains NULLs as long as the length is correct. Because "len"
 * is referenced multiple times, it should be as simple an expression as
 * possible. The ANSI C "prototype" for this macro is:

 *

 * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len);
 *
 * This macro should only be called on an unshared objPtr where
 *  objPtr->typePtr->freeIntRepProc == NULL
 *----------------------------------------------------------------
 */

#define TclInitStringRep(objPtr, bytePtr, len) \
    if ((len) == 0) { \
	(objPtr)->bytes	 = tclEmptyStringRep; \
	(objPtr)->length = 0; \
    } else { \
	(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
	memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \
		(unsigned) (len)); \
	(objPtr)->bytes[len] = '\0'; \
	(objPtr)->length = (len); \
    }

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to get the string representation's byte array
 * pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The
 * macro's expression result is the string rep's byte pointer which might be

 * NULL. The bytes referenced by this pointer must not be modified by the
 * caller. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE char *	TclGetString(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */

#define TclGetString(objPtr) \
    ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to clean out an object's internal
 * representation. Does not actually reset the rep's bytes. The ANSI C
 * "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclFreeIntRep(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */

#define TclFreeIntRep(objPtr) \
    if ((objPtr)->typePtr != NULL && \
	    (objPtr)->typePtr->freeIntRepProc != NULL) { \
	(objPtr)->typePtr->freeIntRepProc(objPtr); \
    }

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to clean out an object's string representation.
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateStringRep(Tcl_Obj *objPtr);

 *----------------------------------------------------------------
 */


#define TclInvalidateStringRep(objPtr) \
    if (objPtr->bytes != NULL) { \
	if (objPtr->bytes != tclEmptyStringRep) {\
	    ckfree((char *) objPtr->bytes);\
	}\
	objPtr->bytes = NULL;\
    }\


#if 0
/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to get a Tcl_WideInt value out of a Tcl_Obj of
 * the "wideInt" type.  
 *----------------------------------------------------------------
 */

#ifndef NO_WIDE_TYPE
#    define TclGetWide(resultVar, objPtr) \
	(resultVar) = (objPtr)->internalRep.wideValue
#    define TclGetLongFromWide(resultVar, objPtr) \
	(resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue)
#endif
#endif

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core get a unicode char from a utf string. It checks
 * to see if we have a one-byte utf char before calling the real
 * Tcl_UtfToUniChar, as this will save a lot of time for primarily ascii
 * string handling. The macro's expression result is 1 for the 1-byte case or

 * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclUtfToUniChar(CONST char *string, Tcl_UniChar *ch);

 *----------------------------------------------------------------
 */

#define TclUtfToUniChar(str, chPtr) \
	((((unsigned char) *(str)) < 0xC0) ? \
	    ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
	    : Tcl_UtfToUniChar(str, chPtr))

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to compare Unicode strings. On big-endian
 * systems we can use the more efficient memcmp, but this would not be
 * lexically correct on little-endian systems. The ANSI C "prototype" for
 * this macro is:
 *
 * MODULE_SCOPE int	TclUniCharNcmp(CONST Tcl_UniChar *cs,

 *			    CONST Tcl_UniChar *ct, unsigned long n);
 *----------------------------------------------------------------
 */

#ifdef WORDS_BIGENDIAN
#   define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
#else /* !WORDS_BIGENDIAN */
#   define TclUniCharNcmp Tcl_UniCharNcmp
#endif /* WORDS_BIGENDIAN */

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to increment a namespace's export export epoch

 * counter. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup(Namespace *nsPtr);

 *----------------------------------------------------------------
 */

#define TclInvalidateNsCmdLookup(nsPtr) \
    if ((nsPtr)->numExportPatterns) { \
	(nsPtr)->exportLookupEpoch++; \
    }

/*
 *----------------------------------------------------------------------
 *
 * Core procedures added to libtommath for bignum manipulation.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE void *	TclBNAlloc(size_t nBytes);
MODULE_SCOPE void *	TclBNRealloc(void *oldBlock, size_t newNBytes);
MODULE_SCOPE void	TclBNFree(void *block);
MODULE_SCOPE void	TclBNInitBignumFromLong(mp_int *bignum, long initVal);
MODULE_SCOPE void	TclBNInitBignumFromWideInt(mp_int* bignum,
			    Tcl_WideInt initVal);
MODULE_SCOPE void	TclBNInitBignumFromWideUInt(mp_int* bignum,
			    Tcl_WideUInt initVal);

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to check whether a pattern has any characters
 * special to [string match]. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclMatchIsTrivial(CONST char *pattern);
 *----------------------------------------------------------------
 */

#define TclMatchIsTrivial(pattern)	strpbrk((pattern), "*[]]?\\") == NULL

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to write the string rep of a long integer to a
 * character buffer. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclFormatInt(char *buf, long n);
 *----------------------------------------------------------------
 */

#define TclFormatInt(buf, n)		sprintf((buf), "%ld", (long)(n))

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to set a Tcl_Obj's numeric representation
 * avoiding the corresponding function calls in time critical parts of the
 * core. They should only be called on unshared objects. The ANSI C
 * "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclSetIntObj(Tcl_Obj *objPtr, int intValue);
 * MODULE_SCOPE void	TclSetLongObj(Tcl_Obj *objPtr, long longValue);
 * MODULE_SCOPE void	TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue);
 * MODULE_SCOPE void	TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
 * MODULE_SCOPE void	TclSetDoubleObj(Tcl_Obj *objPtr, double d);
 *----------------------------------------------------------------
 */

#define TclSetIntObj(objPtr, i) \
    TclInvalidateStringRep(objPtr);\
    TclFreeIntRep(objPtr); \
    (objPtr)->internalRep.longValue = (long)(i); \
    (objPtr)->typePtr = &tclIntType

#define TclSetLongObj(objPtr, l) \
    TclSetIntObj((objPtr), (l))

/*
 * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
 * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1.
 * The only "boolean" Tcl_Obj's shall be those holding the cached boolean
 * value of strings like: "yes", "no", "true", "false", "on", "off".
 */

#define TclSetBooleanObj(objPtr, b) \
    TclSetIntObj((objPtr), ((b)? 1 : 0));

#ifndef NO_WIDE_TYPE
#define TclSetWideIntObj(objPtr, w) \
    TclInvalidateStringRep(objPtr);\
    TclFreeIntRep(objPtr); \
    (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
    (objPtr)->typePtr = &tclWideIntType
#endif

#define TclSetDoubleObj(objPtr, d) \
    TclInvalidateStringRep(objPtr);\
    TclFreeIntRep(objPtr); \
    (objPtr)->internalRep.doubleValue = (double)(d); \
    (objPtr)->typePtr = &tclDoubleType

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and initialise objects of standard
 * types, avoiding the corresponding function calls in time critical parts of
 * the core. The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE void	TclNewIntObj(Tcl_Obj *objPtr, int i);
 * MODULE_SCOPE void	TclNewLongObj(Tcl_Obj *objPtr, long l);
 * MODULE_SCOPE void	TclNewBooleanObj(Tcl_Obj *objPtr, int b);
 * MODULE_SCOPE void	TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
 * MODULE_SCOPE void	TclNewDoubleObj(Tcl_Obj *objPtr, double d);
 * MODULE_SCOPE void	TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
 *
 *----------------------------------------------------------------
 */

#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, i) \
    TclIncrObjsAllocated(); \
    TclAllocObjStorage(objPtr); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes = NULL; \
    (objPtr)->internalRep.longValue = (long)(i); \
    (objPtr)->typePtr = &tclIntType

#define TclNewLongObj(objPtr, l) \
    TclNewIntObj((objPtr), (l))

/*
 * NOTE: There is to be no such thing as a "pure" boolean.
 * See comment above TclSetBooleanObj macro above.
 */
#define TclNewBooleanObj(objPtr, b) \
    TclNewIntObj((objPtr), ((b)? 1 : 0))

#define TclNewDoubleObj(objPtr, d) \
    TclIncrObjsAllocated(); \
    TclAllocObjStorage(objPtr); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes = NULL; \
    (objPtr)->internalRep.doubleValue = (double)(d); \
    (objPtr)->typePtr = &tclDoubleType

#define TclNewStringObj(objPtr, s, len) \
    TclNewObj(objPtr); \
    TclInitStringRep((objPtr), (s), (len))

#else /* TCL_MEM_DEBUG */
#define TclNewIntObj(objPtr, i)   \
    (objPtr) = Tcl_NewIntObj(i)

#define TclNewLongObj(objPtr, l) \
    (objPtr) = Tcl_NewLongObj(l)

#define TclNewBooleanObj(objPtr, b) \
    (objPtr) = Tcl_NewBooleanObj(b)

#define TclNewDoubleObj(objPtr, d) \
    (objPtr) = Tcl_NewDoubleObj(d)

#define TclNewStringObj(objPtr, s, len) \
    (objPtr) = Tcl_NewStringObj((s), (len))
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to test for some special double values.
 * The ANSI C "prototypes" for these macros are: 
 *
 * MODULE_SCOPE int	TclIsInfinite _ANSI_ARGS_((double d));
 * MODULE_SCOPE int	TclIsNaN _ANSI_ARGS_((double d));
 */

#ifdef _MSC_VER
#define TclIsInfinite(d)	( ! (_finite((d))) )
#define TclIsNaN(d)		(_isnan((d)))
#else
#define TclIsInfinite(d)	( (d) > DBL_MAX || (d) < -DBL_MAX )
#define TclIsNaN(d)		((d) != (d))
#endif

#include "tclPort.h"
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"

#endif /* _TCLINT */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclIntDecls.h.

1
2
3
4
5
6
7
8
9
10
11
12
13

14



15
16
17
18
19
20
21
/*
 * tclIntDecls.h --
 *
 *	This file contains the declarations for all unsupported
 *	functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *

 * RCS: @(#) $Id: tclIntDecls.h,v 1.75 2004/12/01 23:18:52 dgp Exp $



 */

#ifndef _TCLINTDECLS
#define _TCLINTDECLS

#include "tclPort.h"














>
|
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
/*
 * tclIntDecls.h --
 *
 *	This file contains the declarations for all unsupported
 *	functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
<<<<<<< tclIntDecls.h
 * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.12 2005/08/23 06:15:21 dgp Exp $
=======
 * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.12 2005/08/23 06:15:21 dgp Exp $
>>>>>>> 1.83
 */

#ifndef _TCLINTDECLS
#define _TCLINTDECLS

#include "tclPort.h"

166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
#endif
#ifndef TclFindProc_TCL_DECLARED
#define TclFindProc_TCL_DECLARED
/* 23 */
EXTERN Proc *		TclFindProc _ANSI_ARGS_((Interp * iPtr, 
				CONST char * procName));
#endif
#ifndef TclFormatInt_TCL_DECLARED
#define TclFormatInt_TCL_DECLARED
/* 24 */
EXTERN int		TclFormatInt _ANSI_ARGS_((char * buffer, long n));
#endif
#ifndef TclFreePackageInfo_TCL_DECLARED
#define TclFreePackageInfo_TCL_DECLARED
/* 25 */
EXTERN void		TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr));
#endif
/* Slot 26 is reserved */
/* Slot 27 is reserved */







<
<
|
<
<







170
171
172
173
174
175
176


177


178
179
180
181
182
183
184
#endif
#ifndef TclFindProc_TCL_DECLARED
#define TclFindProc_TCL_DECLARED
/* 23 */
EXTERN Proc *		TclFindProc _ANSI_ARGS_((Interp * iPtr, 
				CONST char * procName));
#endif


/* Slot 24 is reserved */


#ifndef TclFreePackageInfo_TCL_DECLARED
#define TclFreePackageInfo_TCL_DECLARED
/* 25 */
EXTERN void		TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr));
#endif
/* Slot 26 is reserved */
/* Slot 27 is reserved */
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
#ifndef TclInExit_TCL_DECLARED
#define TclInExit_TCL_DECLARED
/* 46 */
EXTERN int		TclInExit _ANSI_ARGS_((void));
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
#ifndef TclIncrVar2_TCL_DECLARED
#define TclIncrVar2_TCL_DECLARED
/* 49 */
EXTERN Tcl_Obj *	TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				long incrAmount, int part1NotParsed));
#endif
#ifndef TclInitCompiledLocals_TCL_DECLARED
#define TclInitCompiledLocals_TCL_DECLARED
/* 50 */
EXTERN void		TclInitCompiledLocals _ANSI_ARGS_((
				Tcl_Interp * interp, CallFrame * framePtr, 
				Namespace * nsPtr));
#endif







<
<
|
<
<
<
<







271
272
273
274
275
276
277


278




279
280
281
282
283
284
285
#ifndef TclInExit_TCL_DECLARED
#define TclInExit_TCL_DECLARED
/* 46 */
EXTERN int		TclInExit _ANSI_ARGS_((void));
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */


/* Slot 49 is reserved */




#ifndef TclInitCompiledLocals_TCL_DECLARED
#define TclInitCompiledLocals_TCL_DECLARED
/* 50 */
EXTERN void		TclInitCompiledLocals _ANSI_ARGS_((
				Tcl_Interp * interp, CallFrame * framePtr, 
				Namespace * nsPtr));
#endif
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
#ifndef TclGetEnv_TCL_DECLARED
#define TclGetEnv_TCL_DECLARED
/* 138 */
EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, 
				Tcl_DString * valuePtr));
#endif
/* Slot 139 is reserved */
#ifndef TclLooksLikeInt_TCL_DECLARED
#define TclLooksLikeInt_TCL_DECLARED
/* 140 */
EXTERN int		TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes, 
				int length));
#endif
#ifndef TclpGetCwd_TCL_DECLARED
#define TclpGetCwd_TCL_DECLARED
/* 141 */
EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
#endif
#ifndef TclSetByteCodeFromAny_TCL_DECLARED







<
<
|
<
<
<







678
679
680
681
682
683
684


685



686
687
688
689
690
691
692
#ifndef TclGetEnv_TCL_DECLARED
#define TclGetEnv_TCL_DECLARED
/* 138 */
EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, 
				Tcl_DString * valuePtr));
#endif
/* Slot 139 is reserved */


/* Slot 140 is reserved */



#ifndef TclpGetCwd_TCL_DECLARED
#define TclpGetCwd_TCL_DECLARED
/* 141 */
EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
#endif
#ifndef TclSetByteCodeFromAny_TCL_DECLARED
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
#define TclUniCharMatch_TCL_DECLARED
/* 173 */
EXTERN int		TclUniCharMatch _ANSI_ARGS_((
				CONST Tcl_UniChar * string, int strLen, 
				CONST Tcl_UniChar * pattern, int ptnLen, 
				int nocase));
#endif
#ifndef TclIncrWideVar2_TCL_DECLARED
#define TclIncrWideVar2_TCL_DECLARED
/* 174 */
EXTERN Tcl_Obj *	TclIncrWideVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				Tcl_WideInt wideIncrAmount, 
				int part1NotParsed));
#endif
#ifndef TclCallVarTraces_TCL_DECLARED
#define TclCallVarTraces_TCL_DECLARED
/* 175 */
EXTERN int		TclCallVarTraces _ANSI_ARGS_((Interp * iPtr, 
				Var * arrayPtr, Var * varPtr, 
				CONST char * part1, CONST char * part2, 
				int flags, int leaveErrMsg));







<
<
|
<
<
<
<
<







861
862
863
864
865
866
867


868





869
870
871
872
873
874
875
#define TclUniCharMatch_TCL_DECLARED
/* 173 */
EXTERN int		TclUniCharMatch _ANSI_ARGS_((
				CONST Tcl_UniChar * string, int strLen, 
				CONST Tcl_UniChar * pattern, int ptnLen, 
				int nocase));
#endif


/* Slot 174 is reserved */





#ifndef TclCallVarTraces_TCL_DECLARED
#define TclCallVarTraces_TCL_DECLARED
/* 175 */
EXTERN int		TclCallVarTraces _ANSI_ARGS_((Interp * iPtr, 
				Var * arrayPtr, Var * varPtr, 
				CONST char * part1, CONST char * part2, 
				int flags, int leaveErrMsg));
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
#endif
#ifndef Tcl_GetStartupScript_TCL_DECLARED
#define Tcl_GetStartupScript_TCL_DECLARED
/* 179 */
EXTERN Tcl_Obj *	Tcl_GetStartupScript _ANSI_ARGS_((
				CONST char ** encodingNamePtr));
#endif
#ifndef TclNewListObjDirect_TCL_DECLARED
#define TclNewListObjDirect_TCL_DECLARED
/* 180 */
EXTERN Tcl_Obj *	TclNewListObjDirect _ANSI_ARGS_((int objc, 
				Tcl_Obj ** objv));
#endif
#ifndef TclDbNewListObjDirect_TCL_DECLARED
#define TclDbNewListObjDirect_TCL_DECLARED
/* 181 */
EXTERN Tcl_Obj *	TclDbNewListObjDirect _ANSI_ARGS_((int objc, 
				Tcl_Obj ** objv, CONST char * file, int line));
#endif
#ifndef TclpLocaltime_TCL_DECLARED
#define TclpLocaltime_TCL_DECLARED
/* 182 */
EXTERN struct tm *	TclpLocaltime _ANSI_ARGS_((CONST time_t * clock));
#endif
#ifndef TclpGmtime_TCL_DECLARED
#define TclpGmtime_TCL_DECLARED
/* 183 */
EXTERN struct tm *	TclpGmtime _ANSI_ARGS_((CONST time_t * clock));
#endif
#ifndef TclThreadStorageLockInit_TCL_DECLARED
#define TclThreadStorageLockInit_TCL_DECLARED
/* 184 */
EXTERN void		TclThreadStorageLockInit _ANSI_ARGS_((void));
#endif
#ifndef TclThreadStorageLock_TCL_DECLARED
#define TclThreadStorageLock_TCL_DECLARED
/* 185 */
EXTERN void		TclThreadStorageLock _ANSI_ARGS_((void));
#endif
#ifndef TclThreadStorageUnlock_TCL_DECLARED
#define TclThreadStorageUnlock_TCL_DECLARED
/* 186 */
EXTERN void		TclThreadStorageUnlock _ANSI_ARGS_((void));
#endif
#ifndef TclThreadStoragePrint_TCL_DECLARED
#define TclThreadStoragePrint_TCL_DECLARED
/* 187 */
EXTERN void		TclThreadStoragePrint _ANSI_ARGS_((FILE * outFile, 
				int flags));
#endif
#ifndef TclThreadStorageGetHashTable_TCL_DECLARED
#define TclThreadStorageGetHashTable_TCL_DECLARED
/* 188 */
EXTERN Tcl_HashTable *	TclThreadStorageGetHashTable _ANSI_ARGS_((
				Tcl_ThreadId id));
#endif
#ifndef TclThreadStorageInit_TCL_DECLARED
#define TclThreadStorageInit_TCL_DECLARED
/* 189 */
EXTERN Tcl_HashTable *	TclThreadStorageInit _ANSI_ARGS_((Tcl_ThreadId id, 
				void * reserved));
#endif
#ifndef TclThreadStorageDataKeyInit_TCL_DECLARED
#define TclThreadStorageDataKeyInit_TCL_DECLARED
/* 190 */
EXTERN void		TclThreadStorageDataKeyInit _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr));
#endif
#ifndef TclThreadStorageDataKeyGet_TCL_DECLARED
#define TclThreadStorageDataKeyGet_TCL_DECLARED
/* 191 */
EXTERN void *		TclThreadStorageDataKeyGet _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr));
#endif
#ifndef TclThreadStorageDataKeySet_TCL_DECLARED
#define TclThreadStorageDataKeySet_TCL_DECLARED
/* 192 */
EXTERN void		TclThreadStorageDataKeySet _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr, void * data));
#endif
#ifndef TclFinalizeThreadStorageThread_TCL_DECLARED
#define TclFinalizeThreadStorageThread_TCL_DECLARED
/* 193 */
EXTERN void		TclFinalizeThreadStorageThread _ANSI_ARGS_((
				Tcl_ThreadId id));
#endif
#ifndef TclFinalizeThreadStorage_TCL_DECLARED
#define TclFinalizeThreadStorage_TCL_DECLARED
/* 194 */
EXTERN void		TclFinalizeThreadStorage _ANSI_ARGS_((void));
#endif
#ifndef TclFinalizeThreadStorageData_TCL_DECLARED
#define TclFinalizeThreadStorageData_TCL_DECLARED
/* 195 */
EXTERN void		TclFinalizeThreadStorageData _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr));
#endif
#ifndef TclFinalizeThreadStorageDataKey_TCL_DECLARED
#define TclFinalizeThreadStorageDataKey_TCL_DECLARED
/* 196 */
EXTERN void		TclFinalizeThreadStorageDataKey _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr));
#endif
#ifndef TclCompEvalObj_TCL_DECLARED
#define TclCompEvalObj_TCL_DECLARED
/* 197 */
EXTERN int		TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr));
#endif
#ifndef TclObjGetFrame_TCL_DECLARED
#define TclObjGetFrame_TCL_DECLARED
/* 198 */
EXTERN int		TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, CallFrame ** framePtrPtr));
#endif
#ifndef TclMatchIsTrivial_TCL_DECLARED
#define TclMatchIsTrivial_TCL_DECLARED
/* 199 */
EXTERN int		TclMatchIsTrivial _ANSI_ARGS_((CONST char * pattern));
#endif
#ifndef TclpObjRemoveDirectory_TCL_DECLARED
#define TclpObjRemoveDirectory_TCL_DECLARED
/* 200 */
EXTERN int		TclpObjRemoveDirectory _ANSI_ARGS_((
				Tcl_Obj * pathPtr, int recursive, 
				Tcl_Obj ** errorPtr));
#endif







<
<
|
<
<
<
<
<
|
<
<
<










<
<
|
<
<
<
<
|
<
<
<
<
|
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
|
<
<
<
<
<
|
<
<
<












<
<
|
<
<







895
896
897
898
899
900
901


902





903



904
905
906
907
908
909
910
911
912
913


914




915




916




917





918





919

920









921





922





923





924




925





926



927
928
929
930
931
932
933
934
935
936
937
938


939


940
941
942
943
944
945
946
#endif
#ifndef Tcl_GetStartupScript_TCL_DECLARED
#define Tcl_GetStartupScript_TCL_DECLARED
/* 179 */
EXTERN Tcl_Obj *	Tcl_GetStartupScript _ANSI_ARGS_((
				CONST char ** encodingNamePtr));
#endif


/* Slot 180 is reserved */





/* Slot 181 is reserved */



#ifndef TclpLocaltime_TCL_DECLARED
#define TclpLocaltime_TCL_DECLARED
/* 182 */
EXTERN struct tm *	TclpLocaltime _ANSI_ARGS_((CONST time_t * clock));
#endif
#ifndef TclpGmtime_TCL_DECLARED
#define TclpGmtime_TCL_DECLARED
/* 183 */
EXTERN struct tm *	TclpGmtime _ANSI_ARGS_((CONST time_t * clock));
#endif


/* Slot 184 is reserved */




/* Slot 185 is reserved */




/* Slot 186 is reserved */




/* Slot 187 is reserved */





/* Slot 188 is reserved */





/* Slot 189 is reserved */

/* Slot 190 is reserved */









/* Slot 191 is reserved */





/* Slot 192 is reserved */





/* Slot 193 is reserved */





/* Slot 194 is reserved */




/* Slot 195 is reserved */





/* Slot 196 is reserved */



#ifndef TclCompEvalObj_TCL_DECLARED
#define TclCompEvalObj_TCL_DECLARED
/* 197 */
EXTERN int		TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr));
#endif
#ifndef TclObjGetFrame_TCL_DECLARED
#define TclObjGetFrame_TCL_DECLARED
/* 198 */
EXTERN int		TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, CallFrame ** framePtrPtr));
#endif


/* Slot 199 is reserved */


#ifndef TclpObjRemoveDirectory_TCL_DECLARED
#define TclpObjRemoveDirectory_TCL_DECLARED
/* 200 */
EXTERN int		TclpObjRemoveDirectory _ANSI_ARGS_((
				Tcl_Obj * pathPtr, int recursive, 
				Tcl_Obj ** errorPtr));
#endif
1114
1115
1116
1117
1118
1119
1120
































































1121
1122
1123
1124
1125
1126
1127
#endif
#ifndef TclSetObjNameOfExecutable_TCL_DECLARED
#define TclSetObjNameOfExecutable_TCL_DECLARED
/* 214 */
EXTERN void		TclSetObjNameOfExecutable _ANSI_ARGS_((
				Tcl_Obj * name, Tcl_Encoding encoding));
#endif

































































typedef struct TclIntStubs {
    int magic;
    struct TclIntStubHooks *hooks;

    void *reserved0;
    int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
#endif
#ifndef TclSetObjNameOfExecutable_TCL_DECLARED
#define TclSetObjNameOfExecutable_TCL_DECLARED
/* 214 */
EXTERN void		TclSetObjNameOfExecutable _ANSI_ARGS_((
				Tcl_Obj * name, Tcl_Encoding encoding));
#endif
#ifndef TclStackAlloc_TCL_DECLARED
#define TclStackAlloc_TCL_DECLARED
/* 215 */
EXTERN char *		TclStackAlloc _ANSI_ARGS_((Tcl_Interp * interp, 
				int numBytes));
#endif
#ifndef TclStackFree_TCL_DECLARED
#define TclStackFree_TCL_DECLARED
/* 216 */
EXTERN void		TclStackFree _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef TclPushStackFrame_TCL_DECLARED
#define TclPushStackFrame_TCL_DECLARED
/* 217 */
EXTERN int		TclPushStackFrame _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_CallFrame ** framePtrPtr, 
				Tcl_Namespace * namespacePtr, 
				int isProcCallFrame));
#endif
#ifndef TclPopStackFrame_TCL_DECLARED
#define TclPopStackFrame_TCL_DECLARED
/* 218 */
EXTERN void		TclPopStackFrame _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef TclBN_mp_div_d_TCL_DECLARED
#define TclBN_mp_div_d_TCL_DECLARED
/* 219 */
EXTERN int		TclBN_mp_div_d _ANSI_ARGS_((mp_int * a, mp_digit b, 
				mp_int * c, mp_digit * d));
#endif
#ifndef TclBN_mp_mul_d_TCL_DECLARED
#define TclBN_mp_mul_d_TCL_DECLARED
/* 220 */
EXTERN int		TclBN_mp_mul_d _ANSI_ARGS_((mp_int * a, mp_digit b, 
				mp_int * c));
#endif
#ifndef TclBN_mp_clear_TCL_DECLARED
#define TclBN_mp_clear_TCL_DECLARED
/* 221 */
EXTERN void		TclBN_mp_clear _ANSI_ARGS_((mp_int * a));
#endif
#ifndef TclBN_mp_init_TCL_DECLARED
#define TclBN_mp_init_TCL_DECLARED
/* 222 */
EXTERN int		TclBN_mp_init _ANSI_ARGS_((mp_int * a));
#endif
#ifndef TclBN_mp_read_radix_TCL_DECLARED
#define TclBN_mp_read_radix_TCL_DECLARED
/* 223 */
EXTERN int		TclBN_mp_read_radix _ANSI_ARGS_((mp_int * a, 
				const char * str, int radix));
#endif
#ifndef TclGetPlatform_TCL_DECLARED
#define TclGetPlatform_TCL_DECLARED
/* 224 */
EXTERN TclPlatformType * TclGetPlatform _ANSI_ARGS_((void));
#endif
#ifndef TclTraceDictPath_TCL_DECLARED
#define TclTraceDictPath_TCL_DECLARED
/* 225 */
EXTERN Tcl_Obj *	TclTraceDictPath _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * rootPtr, int keyc, 
				Tcl_Obj *CONST keyv[], int flags));
#endif

typedef struct TclIntStubs {
    int magic;
    struct TclIntStubHooks *hooks;

    void *reserved0;
    int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
    void *reserved17;
    void *reserved18;
    void *reserved19;
    void *reserved20;
    void *reserved21;
    int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
    Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
    int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
    void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
    void *reserved26;
    void *reserved27;
    Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
    void *reserved29;
    void *reserved30;
    CONST char * (*tclGetExtension) _ANSI_ARGS_((CONST char * name)); /* 31 */







|







1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
    void *reserved17;
    void *reserved18;
    void *reserved19;
    void *reserved20;
    void *reserved21;
    int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
    Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
    void *reserved24;
    void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
    void *reserved26;
    void *reserved27;
    Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
    void *reserved29;
    void *reserved30;
    CONST char * (*tclGetExtension) _ANSI_ARGS_((CONST char * name)); /* 31 */
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
    char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
    void *reserved43;
    int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
    int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
    int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
    void *reserved47;
    void *reserved48;
    Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
    void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
    int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
    void *reserved52;
    int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */
    int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
    Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
    void *reserved56;







|







1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
    char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
    void *reserved43;
    int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
    int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
    int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
    void *reserved47;
    void *reserved48;
    void *reserved49;
    void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
    int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
    void *reserved52;
    int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */
    int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
    Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
    void *reserved56;
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
    struct tm * (*tclpGetDate) _ANSI_ARGS_((CONST time_t * time, int useGMT)); /* 133 */
    void *reserved134;
    void *reserved135;
    void *reserved136;
    void *reserved137;
    CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
    void *reserved139;
    int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
    CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
    int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
    int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
    void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
    struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */
    TclHandle (*tclHandleCreate) _ANSI_ARGS_((VOID * ptr)); /* 146 */
    void (*tclHandleFree) _ANSI_ARGS_((TclHandle handle)); /* 147 */







|







1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
    struct tm * (*tclpGetDate) _ANSI_ARGS_((CONST time_t * time, int useGMT)); /* 133 */
    void *reserved134;
    void *reserved135;
    void *reserved136;
    void *reserved137;
    CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
    void *reserved139;
    void *reserved140;
    CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
    int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
    int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
    void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
    struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */
    TclHandle (*tclHandleCreate) _ANSI_ARGS_((VOID * ptr)); /* 146 */
    void (*tclHandleFree) _ANSI_ARGS_((TclHandle handle)); /* 147 */
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355











1356
1357
1358
1359
1360
1361
1362
    void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
    Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
    int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
    int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
    int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
    int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */
    int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */
    Tcl_Obj * (*tclIncrWideVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)); /* 174 */
    int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */
    void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */
    void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */
    void (*tcl_SetStartupScript) _ANSI_ARGS_((Tcl_Obj * pathPtr, CONST char* encodingName)); /* 178 */
    Tcl_Obj * (*tcl_GetStartupScript) _ANSI_ARGS_((CONST char ** encodingNamePtr)); /* 179 */
    Tcl_Obj * (*tclNewListObjDirect) _ANSI_ARGS_((int objc, Tcl_Obj ** objv)); /* 180 */
    Tcl_Obj * (*tclDbNewListObjDirect) _ANSI_ARGS_((int objc, Tcl_Obj ** objv, CONST char * file, int line)); /* 181 */
    struct tm * (*tclpLocaltime) _ANSI_ARGS_((CONST time_t * clock)); /* 182 */
    struct tm * (*tclpGmtime) _ANSI_ARGS_((CONST time_t * clock)); /* 183 */
    void (*tclThreadStorageLockInit) _ANSI_ARGS_((void)); /* 184 */
    void (*tclThreadStorageLock) _ANSI_ARGS_((void)); /* 185 */
    void (*tclThreadStorageUnlock) _ANSI_ARGS_((void)); /* 186 */
    void (*tclThreadStoragePrint) _ANSI_ARGS_((FILE * outFile, int flags)); /* 187 */
    Tcl_HashTable * (*tclThreadStorageGetHashTable) _ANSI_ARGS_((Tcl_ThreadId id)); /* 188 */
    Tcl_HashTable * (*tclThreadStorageInit) _ANSI_ARGS_((Tcl_ThreadId id, void * reserved)); /* 189 */
    void (*tclThreadStorageDataKeyInit) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 190 */
    void * (*tclThreadStorageDataKeyGet) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 191 */
    void (*tclThreadStorageDataKeySet) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, void * data)); /* 192 */
    void (*tclFinalizeThreadStorageThread) _ANSI_ARGS_((Tcl_ThreadId id)); /* 193 */
    void (*tclFinalizeThreadStorage) _ANSI_ARGS_((void)); /* 194 */
    void (*tclFinalizeThreadStorageData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 195 */
    void (*tclFinalizeThreadStorageDataKey) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 196 */
    int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */
    int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */
    int (*tclMatchIsTrivial) _ANSI_ARGS_((CONST char * pattern)); /* 199 */
    int (*tclpObjRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 200 */
    int (*tclpObjCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 201 */
    int (*tclpObjCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 202 */
    int (*tclpObjDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 203 */
    int (*tclpObjCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 204 */
    int (*tclpObjRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 205 */
    int (*tclpObjStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 206 */
    int (*tclpObjAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 207 */
    Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, int mode, int permissions)); /* 208 */
    Tcl_Obj * (*tclGetEncodingSearchPath) _ANSI_ARGS_((void)); /* 209 */
    int (*tclSetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj * searchPath)); /* 210 */
    CONST char * (*tclpGetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString * bufPtr)); /* 211 */
    void (*tclpFindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 212 */
    Tcl_Obj * (*tclGetObjNameOfExecutable) _ANSI_ARGS_((void)); /* 213 */
    void (*tclSetObjNameOfExecutable) _ANSI_ARGS_((Tcl_Obj * name, Tcl_Encoding encoding)); /* 214 */











} TclIntStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus







|





|
|


|
|
|
|
|
|
|
|
|
|
|
|
|


|















>
>
>
>
>
>
>
>
>
>
>







1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
    void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
    Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
    int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
    int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
    int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
    int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */
    int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */
    void *reserved174;
    int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */
    void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */
    void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */
    void (*tcl_SetStartupScript) _ANSI_ARGS_((Tcl_Obj * pathPtr, CONST char* encodingName)); /* 178 */
    Tcl_Obj * (*tcl_GetStartupScript) _ANSI_ARGS_((CONST char ** encodingNamePtr)); /* 179 */
    void *reserved180;
    void *reserved181;
    struct tm * (*tclpLocaltime) _ANSI_ARGS_((CONST time_t * clock)); /* 182 */
    struct tm * (*tclpGmtime) _ANSI_ARGS_((CONST time_t * clock)); /* 183 */
    void *reserved184;
    void *reserved185;
    void *reserved186;
    void *reserved187;
    void *reserved188;
    void *reserved189;
    void *reserved190;
    void *reserved191;
    void *reserved192;
    void *reserved193;
    void *reserved194;
    void *reserved195;
    void *reserved196;
    int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */
    int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */
    void *reserved199;
    int (*tclpObjRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 200 */
    int (*tclpObjCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 201 */
    int (*tclpObjCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 202 */
    int (*tclpObjDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 203 */
    int (*tclpObjCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 204 */
    int (*tclpObjRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 205 */
    int (*tclpObjStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 206 */
    int (*tclpObjAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 207 */
    Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, int mode, int permissions)); /* 208 */
    Tcl_Obj * (*tclGetEncodingSearchPath) _ANSI_ARGS_((void)); /* 209 */
    int (*tclSetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj * searchPath)); /* 210 */
    CONST char * (*tclpGetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString * bufPtr)); /* 211 */
    void (*tclpFindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 212 */
    Tcl_Obj * (*tclGetObjNameOfExecutable) _ANSI_ARGS_((void)); /* 213 */
    void (*tclSetObjNameOfExecutable) _ANSI_ARGS_((Tcl_Obj * name, Tcl_Encoding encoding)); /* 214 */
    char * (*tclStackAlloc) _ANSI_ARGS_((Tcl_Interp * interp, int numBytes)); /* 215 */
    void (*tclStackFree) _ANSI_ARGS_((Tcl_Interp * interp)); /* 216 */
    int (*tclPushStackFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame ** framePtrPtr, Tcl_Namespace * namespacePtr, int isProcCallFrame)); /* 217 */
    void (*tclPopStackFrame) _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */
    int (*tclBN_mp_div_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c, mp_digit * d)); /* 219 */
    int (*tclBN_mp_mul_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c)); /* 220 */
    void (*tclBN_mp_clear) _ANSI_ARGS_((mp_int * a)); /* 221 */
    int (*tclBN_mp_init) _ANSI_ARGS_((mp_int * a)); /* 222 */
    int (*tclBN_mp_read_radix) _ANSI_ARGS_((mp_int * a, const char * str, int radix)); /* 223 */
    TclPlatformType * (*tclGetPlatform) _ANSI_ARGS_((void)); /* 224 */
    Tcl_Obj * (*tclTraceDictPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags)); /* 225 */
} TclIntStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
#define TclFindElement \
	(tclIntStubsPtr->tclFindElement) /* 22 */
#endif
#ifndef TclFindProc
#define TclFindProc \
	(tclIntStubsPtr->tclFindProc) /* 23 */
#endif
#ifndef TclFormatInt
#define TclFormatInt \
	(tclIntStubsPtr->tclFormatInt) /* 24 */
#endif
#ifndef TclFreePackageInfo
#define TclFreePackageInfo \
	(tclIntStubsPtr->tclFreePackageInfo) /* 25 */
#endif
/* Slot 26 is reserved */
/* Slot 27 is reserved */
#ifndef TclpGetDefaultStdChannel







|
<
<
<







1432
1433
1434
1435
1436
1437
1438
1439



1440
1441
1442
1443
1444
1445
1446
#define TclFindElement \
	(tclIntStubsPtr->tclFindElement) /* 22 */
#endif
#ifndef TclFindProc
#define TclFindProc \
	(tclIntStubsPtr->tclFindProc) /* 23 */
#endif
/* Slot 24 is reserved */



#ifndef TclFreePackageInfo
#define TclFreePackageInfo \
	(tclIntStubsPtr->tclFreePackageInfo) /* 25 */
#endif
/* Slot 26 is reserved */
/* Slot 27 is reserved */
#ifndef TclpGetDefaultStdChannel
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
#endif
#ifndef TclInExit
#define TclInExit \
	(tclIntStubsPtr->tclInExit) /* 46 */
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
#ifndef TclIncrVar2
#define TclIncrVar2 \
	(tclIntStubsPtr->tclIncrVar2) /* 49 */
#endif
#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
	(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
#endif
#ifndef TclInterpInit
#define TclInterpInit \
	(tclIntStubsPtr->tclInterpInit) /* 51 */







<
<
|
<







1502
1503
1504
1505
1506
1507
1508


1509

1510
1511
1512
1513
1514
1515
1516
#endif
#ifndef TclInExit
#define TclInExit \
	(tclIntStubsPtr->tclInExit) /* 46 */
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */


/* Slot 49 is reserved */

#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
	(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
#endif
#ifndef TclInterpInit
#define TclInterpInit \
	(tclIntStubsPtr->tclInterpInit) /* 51 */
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
/* Slot 136 is reserved */
/* Slot 137 is reserved */
#ifndef TclGetEnv
#define TclGetEnv \
	(tclIntStubsPtr->tclGetEnv) /* 138 */
#endif
/* Slot 139 is reserved */
#ifndef TclLooksLikeInt
#define TclLooksLikeInt \
	(tclIntStubsPtr->tclLooksLikeInt) /* 140 */
#endif
#ifndef TclpGetCwd
#define TclpGetCwd \
	(tclIntStubsPtr->tclpGetCwd) /* 141 */
#endif
#ifndef TclSetByteCodeFromAny
#define TclSetByteCodeFromAny \
	(tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */







<
<
|
<







1781
1782
1783
1784
1785
1786
1787


1788

1789
1790
1791
1792
1793
1794
1795
/* Slot 136 is reserved */
/* Slot 137 is reserved */
#ifndef TclGetEnv
#define TclGetEnv \
	(tclIntStubsPtr->tclGetEnv) /* 138 */
#endif
/* Slot 139 is reserved */


/* Slot 140 is reserved */

#ifndef TclpGetCwd
#define TclpGetCwd \
	(tclIntStubsPtr->tclpGetCwd) /* 141 */
#endif
#ifndef TclSetByteCodeFromAny
#define TclSetByteCodeFromAny \
	(tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
#define TclInThreadExit \
	(tclIntStubsPtr->tclInThreadExit) /* 172 */
#endif
#ifndef TclUniCharMatch
#define TclUniCharMatch \
	(tclIntStubsPtr->tclUniCharMatch) /* 173 */
#endif
#ifndef TclIncrWideVar2
#define TclIncrWideVar2 \
	(tclIntStubsPtr->tclIncrWideVar2) /* 174 */
#endif
#ifndef TclCallVarTraces
#define TclCallVarTraces \
	(tclIntStubsPtr->tclCallVarTraces) /* 175 */
#endif
#ifndef TclCleanupVar
#define TclCleanupVar \
	(tclIntStubsPtr->tclCleanupVar) /* 176 */
#endif
#ifndef TclVarErrMsg
#define TclVarErrMsg \
	(tclIntStubsPtr->tclVarErrMsg) /* 177 */
#endif
#ifndef Tcl_SetStartupScript
#define Tcl_SetStartupScript \
	(tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
#endif
#ifndef Tcl_GetStartupScript
#define Tcl_GetStartupScript \
	(tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
#endif
#ifndef TclNewListObjDirect
#define TclNewListObjDirect \
	(tclIntStubsPtr->tclNewListObjDirect) /* 180 */
#endif
#ifndef TclDbNewListObjDirect
#define TclDbNewListObjDirect \
	(tclIntStubsPtr->tclDbNewListObjDirect) /* 181 */
#endif
#ifndef TclpLocaltime
#define TclpLocaltime \
	(tclIntStubsPtr->tclpLocaltime) /* 182 */
#endif
#ifndef TclpGmtime
#define TclpGmtime \
	(tclIntStubsPtr->tclpGmtime) /* 183 */
#endif
#ifndef TclThreadStorageLockInit
#define TclThreadStorageLockInit \
	(tclIntStubsPtr->tclThreadStorageLockInit) /* 184 */
#endif
#ifndef TclThreadStorageLock
#define TclThreadStorageLock \
	(tclIntStubsPtr->tclThreadStorageLock) /* 185 */
#endif
#ifndef TclThreadStorageUnlock
#define TclThreadStorageUnlock \
	(tclIntStubsPtr->tclThreadStorageUnlock) /* 186 */
#endif
#ifndef TclThreadStoragePrint
#define TclThreadStoragePrint \
	(tclIntStubsPtr->tclThreadStoragePrint) /* 187 */
#endif
#ifndef TclThreadStorageGetHashTable
#define TclThreadStorageGetHashTable \
	(tclIntStubsPtr->tclThreadStorageGetHashTable) /* 188 */
#endif
#ifndef TclThreadStorageInit
#define TclThreadStorageInit \
	(tclIntStubsPtr->tclThreadStorageInit) /* 189 */
#endif
#ifndef TclThreadStorageDataKeyInit
#define TclThreadStorageDataKeyInit \
	(tclIntStubsPtr->tclThreadStorageDataKeyInit) /* 190 */
#endif
#ifndef TclThreadStorageDataKeyGet
#define TclThreadStorageDataKeyGet \
	(tclIntStubsPtr->tclThreadStorageDataKeyGet) /* 191 */
#endif
#ifndef TclThreadStorageDataKeySet
#define TclThreadStorageDataKeySet \
	(tclIntStubsPtr->tclThreadStorageDataKeySet) /* 192 */
#endif
#ifndef TclFinalizeThreadStorageThread
#define TclFinalizeThreadStorageThread \
	(tclIntStubsPtr->tclFinalizeThreadStorageThread) /* 193 */
#endif
#ifndef TclFinalizeThreadStorage
#define TclFinalizeThreadStorage \
	(tclIntStubsPtr->tclFinalizeThreadStorage) /* 194 */
#endif
#ifndef TclFinalizeThreadStorageData
#define TclFinalizeThreadStorageData \
	(tclIntStubsPtr->tclFinalizeThreadStorageData) /* 195 */
#endif
#ifndef TclFinalizeThreadStorageDataKey
#define TclFinalizeThreadStorageDataKey \
	(tclIntStubsPtr->tclFinalizeThreadStorageDataKey) /* 196 */
#endif
#ifndef TclCompEvalObj
#define TclCompEvalObj \
	(tclIntStubsPtr->tclCompEvalObj) /* 197 */
#endif
#ifndef TclObjGetFrame
#define TclObjGetFrame \
	(tclIntStubsPtr->tclObjGetFrame) /* 198 */
#endif
#ifndef TclMatchIsTrivial
#define TclMatchIsTrivial \
	(tclIntStubsPtr->tclMatchIsTrivial) /* 199 */
#endif
#ifndef TclpObjRemoveDirectory
#define TclpObjRemoveDirectory \
	(tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */
#endif
#ifndef TclpObjCopyDirectory
#define TclpObjCopyDirectory \
	(tclIntStubsPtr->tclpObjCopyDirectory) /* 201 */







<
<
|
<




















<
<
|
<
<
<
|
<








<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
|
<








<
<
|
<







1905
1906
1907
1908
1909
1910
1911


1912

1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932


1933



1934

1935
1936
1937
1938
1939
1940
1941
1942


1943



1944



1945



1946



1947



1948



1949



1950



1951



1952



1953



1954



1955

1956
1957
1958
1959
1960
1961
1962
1963


1964

1965
1966
1967
1968
1969
1970
1971
#define TclInThreadExit \
	(tclIntStubsPtr->tclInThreadExit) /* 172 */
#endif
#ifndef TclUniCharMatch
#define TclUniCharMatch \
	(tclIntStubsPtr->tclUniCharMatch) /* 173 */
#endif


/* Slot 174 is reserved */

#ifndef TclCallVarTraces
#define TclCallVarTraces \
	(tclIntStubsPtr->tclCallVarTraces) /* 175 */
#endif
#ifndef TclCleanupVar
#define TclCleanupVar \
	(tclIntStubsPtr->tclCleanupVar) /* 176 */
#endif
#ifndef TclVarErrMsg
#define TclVarErrMsg \
	(tclIntStubsPtr->tclVarErrMsg) /* 177 */
#endif
#ifndef Tcl_SetStartupScript
#define Tcl_SetStartupScript \
	(tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
#endif
#ifndef Tcl_GetStartupScript
#define Tcl_GetStartupScript \
	(tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
#endif


/* Slot 180 is reserved */



/* Slot 181 is reserved */

#ifndef TclpLocaltime
#define TclpLocaltime \
	(tclIntStubsPtr->tclpLocaltime) /* 182 */
#endif
#ifndef TclpGmtime
#define TclpGmtime \
	(tclIntStubsPtr->tclpGmtime) /* 183 */
#endif


/* Slot 184 is reserved */



/* Slot 185 is reserved */



/* Slot 186 is reserved */



/* Slot 187 is reserved */



/* Slot 188 is reserved */



/* Slot 189 is reserved */



/* Slot 190 is reserved */



/* Slot 191 is reserved */



/* Slot 192 is reserved */



/* Slot 193 is reserved */



/* Slot 194 is reserved */



/* Slot 195 is reserved */



/* Slot 196 is reserved */

#ifndef TclCompEvalObj
#define TclCompEvalObj \
	(tclIntStubsPtr->tclCompEvalObj) /* 197 */
#endif
#ifndef TclObjGetFrame
#define TclObjGetFrame \
	(tclIntStubsPtr->tclObjGetFrame) /* 198 */
#endif


/* Slot 199 is reserved */

#ifndef TclpObjRemoveDirectory
#define TclpObjRemoveDirectory \
	(tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */
#endif
#ifndef TclpObjCopyDirectory
#define TclpObjCopyDirectory \
	(tclIntStubsPtr->tclpObjCopyDirectory) /* 201 */
2096
2097
2098
2099
2100
2101
2102












































2103
2104
2105
2106
2107
2108
2109
2110
2111
#define TclGetObjNameOfExecutable \
	(tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */
#endif
#ifndef TclSetObjNameOfExecutable
#define TclSetObjNameOfExecutable \
	(tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */
#endif













































#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLINTDECLS */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
#define TclGetObjNameOfExecutable \
	(tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */
#endif
#ifndef TclSetObjNameOfExecutable
#define TclSetObjNameOfExecutable \
	(tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */
#endif
#ifndef TclStackAlloc
#define TclStackAlloc \
	(tclIntStubsPtr->tclStackAlloc) /* 215 */
#endif
#ifndef TclStackFree
#define TclStackFree \
	(tclIntStubsPtr->tclStackFree) /* 216 */
#endif
#ifndef TclPushStackFrame
#define TclPushStackFrame \
	(tclIntStubsPtr->tclPushStackFrame) /* 217 */
#endif
#ifndef TclPopStackFrame
#define TclPopStackFrame \
	(tclIntStubsPtr->tclPopStackFrame) /* 218 */
#endif
#ifndef TclBN_mp_div_d
#define TclBN_mp_div_d \
	(tclIntStubsPtr->tclBN_mp_div_d) /* 219 */
#endif
#ifndef TclBN_mp_mul_d
#define TclBN_mp_mul_d \
	(tclIntStubsPtr->tclBN_mp_mul_d) /* 220 */
#endif
#ifndef TclBN_mp_clear
#define TclBN_mp_clear \
	(tclIntStubsPtr->tclBN_mp_clear) /* 221 */
#endif
#ifndef TclBN_mp_init
#define TclBN_mp_init \
	(tclIntStubsPtr->tclBN_mp_init) /* 222 */
#endif
#ifndef TclBN_mp_read_radix
#define TclBN_mp_read_radix \
	(tclIntStubsPtr->tclBN_mp_read_radix) /* 223 */
#endif
#ifndef TclGetPlatform
#define TclGetPlatform \
	(tclIntStubsPtr->tclGetPlatform) /* 224 */
#endif
#ifndef TclTraceDictPath
#define TclTraceDictPath \
	(tclIntStubsPtr->tclTraceDictPath) /* 225 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLINTDECLS */

Changes to generic/tclIntPlatDecls.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclIntPlatDecls.h --
 *
 *	This file contains the declarations for all platform dependent
 *	unsupported functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.26 2004/11/03 19:13:40 davygrvy Exp $
 */

#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclIntPlatDecls.h --
 *
 *	This file contains the declarations for all platform dependent
 *	unsupported functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.26.2.1 2005/05/21 15:10:27 kennykb Exp $
 */

#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
EXTERN char *		TclpGetTZName _ANSI_ARGS_((int isdst));
#endif
#ifndef TclWinNoBackslash_TCL_DECLARED
#define TclWinNoBackslash_TCL_DECLARED
/* 24 */
EXTERN char *		TclWinNoBackslash _ANSI_ARGS_((char * path));
#endif
#ifndef TclWinGetPlatform_TCL_DECLARED
#define TclWinGetPlatform_TCL_DECLARED
/* 25 */
EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void));
#endif
#ifndef TclWinSetInterfaces_TCL_DECLARED
#define TclWinSetInterfaces_TCL_DECLARED
/* 26 */
EXTERN void		TclWinSetInterfaces _ANSI_ARGS_((int wide));
#endif
#ifndef TclWinFlushDirtyChannels_TCL_DECLARED
#define TclWinFlushDirtyChannels_TCL_DECLARED







<
<
|
<
<







245
246
247
248
249
250
251


252


253
254
255
256
257
258
259
EXTERN char *		TclpGetTZName _ANSI_ARGS_((int isdst));
#endif
#ifndef TclWinNoBackslash_TCL_DECLARED
#define TclWinNoBackslash_TCL_DECLARED
/* 24 */
EXTERN char *		TclWinNoBackslash _ANSI_ARGS_((char * path));
#endif


/* Slot 25 is reserved */


#ifndef TclWinSetInterfaces_TCL_DECLARED
#define TclWinSetInterfaces_TCL_DECLARED
/* 26 */
EXTERN void		TclWinSetInterfaces _ANSI_ARGS_((int wide));
#endif
#ifndef TclWinFlushDirtyChannels_TCL_DECLARED
#define TclWinFlushDirtyChannels_TCL_DECLARED
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
    TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */
    TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */
    void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */
    void *reserved21;
    TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
    char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
    char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
    TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */
    void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
    void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
    void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */
    int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int * regs)); /* 29 */
#endif /* __WIN32__ */
#ifdef MAC_OSX_TCL
    int (*tclMacOSXGetFileAttribute) _ANSI_ARGS_((Tcl_Interp * interp, int objIndex, Tcl_Obj * fileName, Tcl_Obj ** attributePtrPtr)); /* 15 */







|







340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
    TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */
    TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */
    void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */
    void *reserved21;
    TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
    char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
    char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
    void *reserved25;
    void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
    void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
    void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */
    int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int * regs)); /* 29 */
#endif /* __WIN32__ */
#ifdef MAC_OSX_TCL
    int (*tclMacOSXGetFileAttribute) _ANSI_ARGS_((Tcl_Interp * interp, int objIndex, Tcl_Obj * fileName, Tcl_Obj ** attributePtrPtr)); /* 15 */
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
#define TclpGetTZName \
	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
#endif
#ifndef TclWinNoBackslash
#define TclWinNoBackslash \
	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
#endif
#ifndef TclWinGetPlatform
#define TclWinGetPlatform \
	(tclIntPlatStubsPtr->tclWinGetPlatform) /* 25 */
#endif
#ifndef TclWinSetInterfaces
#define TclWinSetInterfaces \
	(tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
#endif
#ifndef TclWinFlushDirtyChannels
#define TclWinFlushDirtyChannels \
	(tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */







|
<
<
<







512
513
514
515
516
517
518
519



520
521
522
523
524
525
526
#define TclpGetTZName \
	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
#endif
#ifndef TclWinNoBackslash
#define TclWinNoBackslash \
	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
#endif
/* Slot 25 is reserved */



#ifndef TclWinSetInterfaces
#define TclWinSetInterfaces \
	(tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
#endif
#ifndef TclWinFlushDirtyChannels
#define TclWinFlushDirtyChannels \
	(tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */

Changes to generic/tclInterp.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
/* 
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation
 *	and manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 2004 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInterp.c,v 1.54 2004/12/02 15:31:28 dkf Exp $
 */

#include "tclInt.h"

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script
 * above.  This variable can be modified by the procedure below.
 */
 
static char *          tclPreInitScript = NULL;


/* Forward declaration */
struct Target;

/*
 * struct Alias:
 *
 * Stores information about an alias. Is stored in the slave interpreter
 * and used by the source command to find the target command in the master
 * when the source command is invoked.
 */

typedef struct Alias {
    Tcl_Obj *token;		/* Token for the alias command in the slave
				 * interp. This used to be the command name
				 * in the slave when the alias was first
				 * created. */
    Tcl_Interp *targetInterp;	/* Interp in which target command will be
				 * invoked. */
    Tcl_Command slaveCmd;	/* Source command in slave interpreter,
				 * bound to command that invokes the target
				 * command in the target interpreter. */
    Tcl_HashEntry *aliasEntryPtr;
				/* Entry for the alias hash table in slave.
                                 * This is used by alias deletion to remove
                                 * the alias from the slave interpreter
                                 * alias table. */
    struct Target *targetPtr;	/* Entry for target command in master.
                                 * This is used in the master interpreter to
                                 * map back from the target command to aliases
                                 * redirecting to it. */
    int objc;                   /* Count of Tcl_Obj in the prefix of the
				 * target command to be invoked in the
				 * target interpreter. Additional arguments
				 * specified when calling the alias in the
				 * slave interp will be appended to the prefix
				 * before the command is invoked. */
    Tcl_Obj *objPtr;            /* The first actual prefix object - the target
				 * command name; this has to be at the end of the 
				 * structure, which will be extended to accomodate 
				 * the remaining objects in the prefix. */

} Alias;

/*
 *
 * struct Slave:
 *
 * Used by the "interp" command to record and find information about slave
 * interpreters. Maps from a command name in the master to information about
 * a slave interpreter, e.g. what aliases are defined in it.
 */

typedef struct Slave {
    Tcl_Interp *masterInterp;	/* Master interpreter for this slave. */
    Tcl_HashEntry *slaveEntryPtr;
				/* Hash entry in masters slave table for
                                 * this slave interpreter.  Used to find
                                 * this record, and used when deleting the
                                 * slave interpreter to delete it from the
                                 * master's table. */
    Tcl_Interp	*slaveInterp;	/* The slave interpreter. */
    Tcl_Command interpCmd;	/* Interpreter object command. */
    Tcl_HashTable aliasTable;	/* Table which maps from names of commands
                                 * in slave interpreter to struct Alias
                                 * defined below. */
} Slave;

/*
 * struct Target:
 *
 * Maps from master interpreter commands back to the source commands in slave
 * interpreters. This is needed because aliases can be created between sibling
|


|
|







|









|
|








|
|
|




|
|



|
|
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>







|
|





|
|
|
|
|


|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
/*
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation and
 *	manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 2004 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInterp.c,v 1.54.2.3 2005/08/02 18:15:58 dgp Exp $
 */

#include "tclInt.h"

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script
 * above.  This variable can be modified by the procedure below.
 */

static char *	tclPreInitScript = NULL;


/* Forward declaration */
struct Target;

/*
 * struct Alias:
 *
 * Stores information about an alias. Is stored in the slave interpreter and
 * used by the source command to find the target command in the master when
 * the source command is invoked.
 */

typedef struct Alias {
    Tcl_Obj *token;		/* Token for the alias command in the slave
				 * interp. This used to be the command name in
				 * the slave when the alias was first
				 * created. */
    Tcl_Interp *targetInterp;	/* Interp in which target command will be
				 * invoked. */
    Tcl_Command slaveCmd;	/* Source command in slave interpreter, bound
				 * to command that invokes the target command
				 * in the target interpreter. */
    Tcl_HashEntry *aliasEntryPtr;
				/* Entry for the alias hash table in slave.
				 * This is used by alias deletion to remove
				 * the alias from the slave interpreter alias
				 * table. */
    struct Target *targetPtr;	/* Entry for target command in master.  This
				 * is used in the master interpreter to map
				 * back from the target command to aliases
				 * redirecting to it. */
    int objc;			/* Count of Tcl_Obj in the prefix of the
				 * target command to be invoked in the target
				 * interpreter. Additional arguments specified
				 * when calling the alias in the slave interp
				 * will be appended to the prefix before the
				 * command is invoked. */
    Tcl_Obj *objPtr;		/* The first actual prefix object - the target
				 * command name; this has to be at the end of
				 * the structure, which will be extended to
				 * accomodate the remaining objects in the
				 * prefix. */
} Alias;

/*
 *
 * struct Slave:
 *
 * Used by the "interp" command to record and find information about slave
 * interpreters. Maps from a command name in the master to information about a
 * slave interpreter, e.g. what aliases are defined in it.
 */

typedef struct Slave {
    Tcl_Interp *masterInterp;	/* Master interpreter for this slave. */
    Tcl_HashEntry *slaveEntryPtr;
				/* Hash entry in masters slave table for this
				 * slave interpreter.  Used to find this
				 * record, and used when deleting the slave
				 * interpreter to delete it from the master's
				 * table. */
    Tcl_Interp	*slaveInterp;	/* The slave interpreter. */
    Tcl_Command interpCmd;	/* Interpreter object command. */
    Tcl_HashTable aliasTable;	/* Table which maps from names of commands in
				 * slave interpreter to struct Alias defined
				 * below. */
} Slave;

/*
 * struct Target:
 *
 * Maps from master interpreter commands back to the source commands in slave
 * interpreters. This is needed because aliases can be created between sibling
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    struct Target *prevPtr;	/* Previous in list of target records, or NULL
				 * if at the start of the list of targets. */
} Target;

/*
 * struct Master:
 *
 * This record is used for two purposes: First, slaveTable (a hashtable)
 * maps from names of commands to slave interpreters. This hashtable is
 * used to store information about slave interpreters of this interpreter,
 * to map over all slaves, etc. The second purpose is to store information
 * about all aliases in slaves (or siblings) which direct to target commands
 * in this interpreter (using the targetsPtr doubly-linked list).
 * 
 * NB: the flags field in the interp structure, used with SAFE_INTERP
 * mask denotes whether the interpreter is safe or not. Safe
 * interpreters have restricted functionality, can only create safe slave
 * interpreters and can only load safe extensions.
 */

typedef struct Master {
    Tcl_HashTable slaveTable;	/* Hash table for slave interpreters.
                                 * Maps from command names to Slave records. */
    Target *targetsPtr;		/* The head of a doubly-linked list of all the
				 * target records which denote aliases from
				 * slaves or sibling interpreters that direct
				 * to commands in this interpreter. This list
				 * is used to remove dangling pointers from
				 * the slave (or sibling) interpreters when
				 * this interpreter is deleted. */







|
|
|
|
|
|
|
|
|
|
|



|
|







113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
    struct Target *prevPtr;	/* Previous in list of target records, or NULL
				 * if at the start of the list of targets. */
} Target;

/*
 * struct Master:
 *
 * This record is used for two purposes: First, slaveTable (a hashtable) maps
 * from names of commands to slave interpreters. This hashtable is used to
 * store information about slave interpreters of this interpreter, to map over
 * all slaves, etc. The second purpose is to store information about all
 * aliases in slaves (or siblings) which direct to target commands in this
 * interpreter (using the targetsPtr doubly-linked list).
 *
 * NB: the flags field in the interp structure, used with SAFE_INTERP mask
 * denotes whether the interpreter is safe or not. Safe interpreters have
 * restricted functionality, can only create safe slave interpreters and can
 * only load safe extensions.
 */

typedef struct Master {
    Tcl_HashTable slaveTable;	/* Hash table for slave interpreters. Maps
				 * from command names to Slave records. */
    Target *targetsPtr;		/* The head of a doubly-linked list of all the
				 * target records which denote aliases from
				 * slaves or sibling interpreters that direct
				 * to commands in this interpreter. This list
				 * is used to remove dangling pointers from
				 * the slave (or sibling) interpreters when
				 * this interpreter is deleted. */
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
    Master master;		/* Keeps track of all interps for which this
				 * interp is the Master. */
    Slave slave;		/* Information necessary for this interp to
				 * function as a slave. */
} InterpInfo;

/*
 * Limit callbacks handled by scripts are modelled as structures which
 * are stored in hashes indexed by a two-word key.  Note that the type
 * of the 'type' field in the key is not int; this is to make sure
 * that things are likely to work properly on 64-bit architectures.
 */

struct ScriptLimitCallback {
    Tcl_Interp *interp;
    Tcl_Obj *scriptObj;
    int type;
    Tcl_HashEntry *entryPtr;







|
|
|
|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
    Master master;		/* Keeps track of all interps for which this
				 * interp is the Master. */
    Slave slave;		/* Information necessary for this interp to
				 * function as a slave. */
} InterpInfo;

/*
 * Limit callbacks handled by scripts are modelled as structures which are
 * stored in hashes indexed by a two-word key.  Note that the type of the
 * 'type' field in the key is not int; this is to make sure that things are
 * likely to work properly on 64-bit architectures.
 */

struct ScriptLimitCallback {
    Tcl_Interp *interp;
    Tcl_Obj *scriptObj;
    int type;
    Tcl_HashEntry *entryPtr;
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
			    Tcl_Obj *CONST objv[]));
static int		AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
static int		AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
static int		AliasList _ANSI_ARGS_((Tcl_Interp *interp,
		            Tcl_Interp *slaveInterp));
static int		AliasObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *currentInterp, int objc,
		            Tcl_Obj *CONST objv[]));
static void		AliasObjCmdDeleteProc _ANSI_ARGS_((
			    ClientData clientData));

static Tcl_Interp *	GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr));
static Tcl_Interp *	GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		InterpInfoDeleteProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static int		SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static Tcl_Interp *	SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
		            Tcl_Obj *pathPtr, int safe));
static int		SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp));
static int		SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp,
			    CONST char *namespaceName, 
			    int objc, Tcl_Obj *CONST objv[]));
static int		SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp));
static int		SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		SlaveObjCmdDeleteProc _ANSI_ARGS_((







|


|













|













|







182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
			    Tcl_Obj *CONST objv[]));
static int		AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
static int		AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
static int		AliasList _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp));
static int		AliasObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *currentInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		AliasObjCmdDeleteProc _ANSI_ARGS_((
			    ClientData clientData));

static Tcl_Interp *	GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr));
static Tcl_Interp *	GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		InterpInfoDeleteProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static int		SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static Tcl_Interp *	SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int safe));
static int		SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp));
static int		SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp,
			    CONST char *namespaceName,
			    int objc, Tcl_Obj *CONST objv[]));
static int		SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp));
static int		SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		SlaveObjCmdDeleteProc _ANSI_ARGS_((
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
			    Tcl_Obj *scriptObj));
static void		CallScriptLimitCallback _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static void		DeleteScriptLimitCallback _ANSI_ARGS_((
			    ClientData clientData));
static void		RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr,
			    Tcl_Interp *interp));



/*
 *----------------------------------------------------------------------
 *
 * TclSetPreInitScript --
 *
 *	This routine is used to change the value of the internal
 *	variable, tclPreInitScript.
 *
 * Results:
 *	Returns the current value of tclPreInitScript.
 *
 * Side effects:
 *	Changes the way Tcl_Init() routine behaves.
 *







>







|
|







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
			    Tcl_Obj *scriptObj));
static void		CallScriptLimitCallback _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static void		DeleteScriptLimitCallback _ANSI_ARGS_((
			    ClientData clientData));
static void		RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr,
			    Tcl_Interp *interp));
static void		TimeLimitCallback _ANSI_ARGS_((ClientData clientData));


/*
 *----------------------------------------------------------------------
 *
 * TclSetPreInitScript --
 *
 *	This routine is used to change the value of the internal variable,
 *	tclPreInitScript.
 *
 * Results:
 *	Returns the current value of tclPreInitScript.
 *
 * Side effects:
 *	Changes the way Tcl_Init() routine behaves.
 *
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348

349
350
351
352
353
354
355
356
357
358
359
360
361

362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380

381
382
383
384
385
386
387
388
389
390
391
392

393

394
395


396

397
398
399
400
401
402
403
404

405


406
407

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *      This procedure is typically invoked by Tcl_AppInit procedures
 *      to find and source the "init.tcl" script, which should exist
 *      somewhere on the Tcl library path.
 *
 * Results:
 *      Returns a standard Tcl completion code and sets the interp's
 *      result if there is an error.
 *
 * Side effects:
 *      Depends on what's in the init.tcl script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Init(interp)
    Tcl_Interp *interp;         /* Interpreter to initialize. */
{
    int code;
    Tcl_DString script, encodingName;
    Tcl_Obj *path;

    if (tclPreInitScript != NULL) {
	if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
	    return (TCL_ERROR);
	};
    }

/*
 * In order to find init.tcl during initialization, the following script
 * is invoked by Tcl_Init().  It looks in several different directories:
 *
 *	$tcl_library		- can specify a primary location, if set,
 *				  no other locations will be checked.  This
 *				  is the recommended way for a program that
 *				  embeds Tcl to specifically tell Tcl where
 *				  to find an init.tcl file.
 *
 *	$env(TCL_LIBRARY)	- highest priority so user can always override
 *				  the search path unless the application has
 *				  specified an exact directory above
 *
 *	$tclDefaultLibrary	- INTERNAL:  This variable is set by Tcl
 *				  on those platforms where it can determine
 *				  at runtime the directory where it expects
 *				  the init.tcl file to be.  After [tclInit]
 *				  reads and uses this value, it [unset]s it.
 *				  External users of Tcl should not make use
 *				  of the variable to customize [tclInit].
 *
 *	$tcl_libPath		- OBSOLETE:  This variable is no longer
 *				  set by Tcl itself, but [tclInit] examines
 *				  it in case some program that embeds Tcl
 *				  is customizing [tclInit] by setting this
 *				  variable to a list of directories in which
 *				  to search.
 *
 *      [tcl::pkgconfig get scriptdir,runtime]
 *      			- the directory determined by configure to 
 *      			  be the place where Tcl's script library
 *      			  is to be installed. 
 *
 * The first directory on this path that contains a valid init.tcl script
 * will be set as the value of tcl_library.
 *
 * Note that this entire search mechanism can be bypassed by defining an
 * alternate tclInit procedure before calling Tcl_Init().
 */

    code = Tcl_Eval(interp,
"if {[info proc tclInit]==\"\"} {\n"
"  proc tclInit {} {\n"
"    global tcl_libPath tcl_library\n"
"    global env tclDefaultLibrary\n"
"    variable ::tcl::LibPath\n"
"    rename tclInit {}\n"
"    set errors {}\n"
"    set localPath {}\n"
"    set LibPath {}\n"
"    if {[info exists tcl_library]} {\n"
"	lappend localPath $tcl_library\n"
"    } else {\n"

"	if {[info exists env(TCL_LIBRARY)]\n"
"		&& [string length $env(TCL_LIBRARY)]} {\n"
"	    lappend localPath $env(TCL_LIBRARY)\n"
"	    lappend LibPath $env(TCL_LIBRARY)\n"
"	    if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n"
"		if {$tail ne [info tclversion]} {\n"
"		    lappend localPath [file join [file dirname\\\n"
"			    $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
"		    lappend LibPath [file join [file dirname\\\n"
"			    $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
"		}\n"
"	    }\n"
"	}\n"
"	if {[catch {\n"
"	    lappend localPath $tclDefaultLibrary\n"
"	    unset tclDefaultLibrary\n"
"	}]} {\n"
"	    lappend localPath [::tcl::pkgconfig get scriptdir,runtime]\n"
"	}\n"

"	set parentDir [file normalize [file dirname [file dirname\\\n"
"		[info nameofexecutable]]]]\n"
"	set grandParentDir [file dirname $parentDir]\n"
"	lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n"
"	lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n"
"	lappend LibPath [file join $parentDir library]\n"
"	lappend LibPath [file join $grandParentDir library]\n"
"	lappend LibPath [file join $grandParentDir\\\n"
"       		tcl[info patchlevel] library]\n"
"	lappend LibPath [file join [file dirname $grandParentDir]\\\n"
"       		tcl[info patchlevel] library]\n"
"	catch {\n"

"            set LibPath [concat $LibPath $tcl_libPath]\n"

"	}\n"
"    }\n"


"    foreach i [concat $localPath $LibPath] {\n"

"	set tcl_library $i\n"
"	set tclfile [file join $i init.tcl]\n"
"	if {[file exists $tclfile]} {\n"
"	    if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
"		return\n"
"	    } else {\n"
"		append errors \"$tclfile: $msg\n\"\n"
"		append errors \"[dict get $opts -errorinfo]\n\"\n"

"	    }\n"


"	}\n"
"    }\n"

"    set msg \"Can't find a usable init.tcl in the following directories: \n\"\n"
"    append msg \"    $localPath $LibPath\n\n\"\n"
"    append msg \"$errors\n\n\"\n"
"    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
"    error $msg\n"
"  }\n"
"}\n"
"tclInit");

    if (code != TCL_OK) {
	return code;
    }

    /* 
     * Now that [info library] is initialized, make sure that
     * [file join [info library] encoding] is on the encoding
     * search path.
     *
     * Relying on use of original built-in commands.
     * Should be a safe assumption during interp initialization.
     * More robust would be to use C-coded equivalents, but that's such
     * a pain...
     */

    Tcl_DStringInit(&script);
    Tcl_DStringAppend(&script, "lsearch -exact", -1);
    path = Tcl_DuplicateObj(TclGetEncodingSearchPath());
    Tcl_IncrRefCount(path);
    Tcl_DStringAppendElement(&script, Tcl_GetString(path));
    Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1);
    code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
	    Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
    Tcl_DStringFree(&script);
    if (code == TCL_OK) {
	int index;
	Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index);
	if (index != -1) {
	    /* [info library]/encoding already on the encoding search path */
	    goto done;
	}
    }
    Tcl_DStringInit(&script);
    Tcl_DStringAppend(&script, "file join [info library] encoding", -1);
    code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
	    Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
    Tcl_DStringFree(&script);
    if (code == TCL_OK) {
	Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp));
	TclSetEncodingSearchPath(path);
    }
done:
    /*
     * Now that we know the distributed *.enc files are on the encoding
     * search path, check whether the [encoding system] matches that
     * specified by the environment, and if not, attempt to correct it
     */
    TclpGetEncodingNameFromEnvironment(&encodingName);
    if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
	code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
	if (code == TCL_ERROR) {
	    Tcl_Panic("system encoding \"", Tcl_DStringValue(&encodingName),
		    "\" not available");
	}
    }
    Tcl_DStringFree(&encodingName);
    Tcl_DecrRefCount(path);
    Tcl_ResetResult(interp);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclInterpInit --
 *
 *	Initializes the invoking interpreter for using the master, slave
 *	and safe interp facilities.  This is called from inside
 *	Tcl_CreateInterp().
 *
 * Results:
 *	Always returns TCL_OK for backwards compatibility.
 *
 * Side effects:
 *	Adds the "interp" command to an interpreter and initializes the
 *	interpInfoPtr field of the invoking interpreter.
 *
 *---------------------------------------------------------------------------
 */

int
TclInterpInit(interp)
    Tcl_Interp *interp;			/* Interpreter to initialize. */
{
    InterpInfo *interpInfoPtr;
    Master *masterPtr;
    Slave *slavePtr;	

    interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
    ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;

    masterPtr = &interpInfoPtr->master;
    Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
    masterPtr->targetsPtr = NULL;







|
|
|


|
|


|






|

<
<
<
<





>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|


|
<
<

<
<
<

|

>
|
<
|
|
|
|
<
|
<
<
<
<

<
|
|
|
|

>
<
|
|
|
|
|
|
|
|
|
|
|
>
|
>


>
>
|
>
|
|

|
<
<


>

>
>


>

|






|
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




|
|


















|







277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301




302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352


353



354
355
356
357
358

359
360
361
362

363




364

365
366
367
368
369
370

371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394


395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412


413

414

























































415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures to find
 *	and source the "init.tcl" script, which should exist somewhere on the
 *	Tcl library path.
 *
 * Results:
 *	Returns a standard Tcl completion code and sets the interp's result if
 *	there is an error.
 *
 * Side effects:
 *	Depends on what's in the init.tcl script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Init(interp)
    Tcl_Interp *interp;		/* Interpreter to initialize. */
{




    if (tclPreInitScript != NULL) {
	if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
	    return (TCL_ERROR);
	};
    }

    /*
     * In order to find init.tcl during initialization, the following script
     * is invoked by Tcl_Init().  It looks in several different directories:
     *
     *	$tcl_library		- can specify a primary location, if set, no
     *				  other locations will be checked.  This is
     *				  the recommended way for a program that
     *				  embeds Tcl to specifically tell Tcl where to
     *				  find an init.tcl file.
     *
     *	$env(TCL_LIBRARY)	- highest priority so user can always override
     *				  the search path unless the application has
     *				  specified an exact directory above
     *
     *	$tclDefaultLibrary	- INTERNAL:  This variable is set by Tcl
     *				  on those platforms where it can determine at
     *				  runtime the directory where it expects the
     *				  init.tcl file to be.  After [tclInit] reads
     *				  and uses this value, it [unset]s it.
     *				  External users of Tcl should not make use of
     *				  the variable to customize [tclInit].
     *
     *	$tcl_libPath		- OBSOLETE:  This variable is no longer
     *				  set by Tcl itself, but [tclInit] examines it
     *				  in case some program that embeds Tcl is
     *				  customizing [tclInit] by setting this
     *				  variable to a list of directories in which
     *				  to search.
     *
     *	[tcl::pkgconfig get scriptdir,runtime]
     *				- the directory determined by configure to be
     *				  the place where Tcl's script library is to
     *				  be installed.
     *
     * The first directory on this path that contains a valid init.tcl script
     * will be set as the value of tcl_library.
     *
     * Note that this entire search mechanism can be bypassed by defining an
     * alternate tclInit procedure before calling Tcl_Init().
     */

    return Tcl_Eval(interp,
"if {[info proc tclInit]==\"\"} {\n"
"  proc tclInit {} {\n"
"    global tcl_libPath tcl_library env tclDefaultLibrary\n"


"    rename tclInit {}\n"



"    if {[info exists tcl_library]} {\n"
"	set scripts {{set tcl_library}}\n"
"    } else {\n"
"	set scripts {}\n"
"	if {[info exists env(TCL_LIBRARY)] && ($env(TCL_LIBRARY) ne {})} {\n"

"	    lappend scripts {set env(TCL_LIBRARY)}\n"
"	    lappend scripts {\n"
"if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail] == 0} continue\n"
"if {$tail eq [info tclversion]} continue\n"

"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"




"	}\n"

"	if {[info exists tclDefaultLibrary]} {\n"
"	    lappend scripts {set tclDefaultLibrary}\n"
"	} else {\n"
"	    lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
"	}\n"
"	lappend scripts {\n"

"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
"set grandParentDir [file dirname $parentDir]\n"
"file join $parentDir lib tcl[info tclversion]} \\\n"
"	{file join $grandParentDir lib tcl[info tclversion]} \\\n"
"	{file join $parentDir library} \\\n"
"	{file join $grandParentDir library} \\\n"
"	{file join $grandParentDir tcl[info patchlevel] library} \\\n"
"	{\n"
"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
"	if {[info exists tcl_libPath]\n"
"		&& [catch {llength $tcl_libPath} len] == 0} {\n"
"	    for {set i 0} {$i < $len} {incr i} {\n"
"		lappend scripts [list lindex \\$tcl_libPath $i]\n"
"	    }\n"
"	}\n"
"    }\n"
"    set dirs {}\n"
"    set errors {}\n"
"    foreach script $scripts {\n"
"	lappend dirs [eval $script]\n"
"	set tcl_library [lindex $dirs end]\n"
"	set tclfile [file join $tcl_library init.tcl]\n"
"	if {[file exists $tclfile]} {\n"
"	    if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"


"		append errors \"$tclfile: $msg\n\"\n"
"		append errors \"[dict get $opts -errorinfo]\n\"\n"
"		continue\n"
"	    }\n"
"	    unset -nocomplain tclDefaultLibrary\n"
"	    return\n"
"	}\n"
"    }\n"
"    unset -nocomplain tclDefaultLibrary\n"
"    set msg \"Can't find a usable init.tcl in the following directories: \n\"\n"
"    append msg \"    $dirs\n\n\"\n"
"    append msg \"$errors\n\n\"\n"
"    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
"    error $msg\n"
"  }\n"
"}\n"
"tclInit");
}




/*

























































 *---------------------------------------------------------------------------
 *
 * TclInterpInit --
 *
 *	Initializes the invoking interpreter for using the master, slave and
 *	safe interp facilities.  This is called from inside
 *	Tcl_CreateInterp().
 *
 * Results:
 *	Always returns TCL_OK for backwards compatibility.
 *
 * Side effects:
 *	Adds the "interp" command to an interpreter and initializes the
 *	interpInfoPtr field of the invoking interpreter.
 *
 *---------------------------------------------------------------------------
 */

int
TclInterpInit(interp)
    Tcl_Interp *interp;			/* Interpreter to initialize. */
{
    InterpInfo *interpInfoPtr;
    Master *masterPtr;
    Slave *slavePtr;

    interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
    ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;

    masterPtr = &interpInfoPtr->master;
    Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
    masterPtr->targetsPtr = NULL;
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
}

/*
 *---------------------------------------------------------------------------
 *
 * InterpInfoDeleteProc --
 *
 *	Invoked when an interpreter is being deleted.  It releases all
 *	storage used by the master/slave/safe interpreter facilities.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up storage.  Sets the interpInfoPtr field of the interp
 *	to NULL.
 *
 *---------------------------------------------------------------------------
 */

static void
InterpInfoDeleteProc(clientData, interp)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* Interp being deleted.  All commands for
				 * slave interps should already be deleted. */
{
    InterpInfo *interpInfoPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Target *targetPtr;








|
|





|
<







|







459
460
461
462
463
464
465
466
467
468
469
470
471
472
473

474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
}

/*
 *---------------------------------------------------------------------------
 *
 * InterpInfoDeleteProc --
 *
 *	Invoked when an interpreter is being deleted.  It releases all storage
 *	used by the master/slave/safe interpreter facilities.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up storage. Sets the interpInfoPtr field of the interp to NULL.

 *
 *---------------------------------------------------------------------------
 */

static void
InterpInfoDeleteProc(clientData, interp)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* Interp being deleted. All commands for
				 * slave interps should already be deleted. */
{
    InterpInfo *interpInfoPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Target *targetPtr;

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
    if (masterPtr->slaveTable.numEntries != 0) {
	Tcl_Panic("InterpInfoDeleteProc: still exist commands");
    }
    Tcl_DeleteHashTable(&masterPtr->slaveTable);

    /*
     * Tell any interps that have aliases to this interp that they should
     * delete those aliases.  If the other interp was already dead, it
     * would have removed the target record already. 
     */

    for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) {
	Target *tmpPtr = targetPtr->nextPtr;
	Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
		targetPtr->slaveCmd);
	targetPtr = tmpPtr;
    }

    slavePtr = &interpInfoPtr->slave;
    if (slavePtr->interpCmd != NULL) {
	/*
	 * Tcl_DeleteInterp() was called on this interpreter, rather
	 * "interp delete" or the equivalent deletion of the command in the
	 * master.  First ensure that the cleanup callback doesn't try to
	 * delete the interp again.
	 */

	slavePtr->slaveInterp = NULL;
        Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
		slavePtr->interpCmd);
    }

    /*
     * There shouldn't be any aliases left.
     */

    if (slavePtr->aliasTable.numEntries != 0) {
	Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
    }
    Tcl_DeleteHashTable(&slavePtr->aliasTable);

    ckfree((char *) interpInfoPtr);    
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpObjCmd --
 *
 *	This procedure is invoked to process the "interp" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_InterpObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Unused. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int index;
    static CONST char *options[] = {
        "alias",	"aliases",	"bgerror",	"create",
	"delete",	"eval",		"exists",	"expose",
	"hide",		"hidden",	"issafe",	"invokehidden",
	"limit",	"marktrusted",	"recursionlimit","slaves",
	"share",	"target",	"transfer",
        NULL
    };
    enum option {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_CREATE,
	OPT_DELETE,	OPT_EVAL,	OPT_EXISTS,	OPT_EXPOSE,
	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,	OPT_INVOKEHID,
	OPT_LIMIT,	OPT_MARKTRUSTED,OPT_RECLIMIT,	OPT_SLAVES,
	OPT_SHARE,	OPT_TARGET,	OPT_TRANSFER
    };


    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, 
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum option) index) {
	case OPT_ALIAS: {
	    Tcl_Interp *slaveInterp, *masterInterp;

	    if (objc < 4) {
		aliasArgs:
		Tcl_WrongNumArgs(interp, 2, objv,
			"slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    if (objc == 4) {
		return AliasDescribe(interp, slaveInterp, objv[3]);
	    }
	    if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
		return AliasDelete(interp, slaveInterp, objv[3]);
	    }
	    if (objc > 5) {
		masterInterp = GetInterp(interp, objv[4]);
		if (masterInterp == (Tcl_Interp *) NULL) {
		    return TCL_ERROR;
		}
		if (Tcl_GetString(objv[5])[0] == '\0') {
		    if (objc == 6) {
			return AliasDelete(interp, slaveInterp, objv[3]);
		    }
		} else {
		    return AliasCreate(interp, slaveInterp, masterInterp,
			    objv[3], objv[5], objc - 6, objv + 6);
		}
	    }
	    goto aliasArgs;
	}
	case OPT_ALIASES: {
	    Tcl_Interp *slaveInterp;

	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return AliasList(interp, slaveInterp);
	}
	case OPT_BGERROR: {
	    Tcl_Interp *slaveInterp;

	    if (objc != 3 && objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_CREATE: {
	    int i, last, safe;
	    Tcl_Obj *slavePtr;
	    char buf[16 + TCL_INTEGER_SPACE];
	    static CONST char *options[] = {
		"-safe",	"--",		NULL
	    };
	    enum option {
		OPT_SAFE,	OPT_LAST
	    };

	    safe = Tcl_IsSafe(interp);
	    
	    /*
	     * Weird historical rules: "-safe" is accepted at the end, too.
	     */

	    slavePtr = NULL;
	    last = 0;
	    for (i = 2; i < objc; i++) {
		if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
		    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
			    0, &index) != TCL_OK) {
			return TCL_ERROR;
		    }
		    if (index == OPT_SAFE) {
			safe = 1;
			continue;
		    }
		    i++;
		    last = 1;
		}
		if (slavePtr != NULL) {
		    Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
		    return TCL_ERROR;
		}
		if (i < objc) {
		    slavePtr = objv[i];
		}
	    }
	    buf[0] = '\0';
	    if (slavePtr == NULL) {
		/*
		 * Create an anonymous interpreter -- we choose its name and
		 * the name of the command. We check that the command name
		 * that we use for the interpreter does not collide with an
		 * existing command in the master interpreter.
		 */
		
		for (i = 0; ; i++) {
		    Tcl_CmdInfo cmdInfo;
		    
		    sprintf(buf, "interp%d", i);
		    if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
			break;
		    }
		}
		slavePtr = Tcl_NewStringObj(buf, -1);
	    }
	    if (SlaveCreate(interp, slavePtr, safe) == NULL) {
		if (buf[0] != '\0') {
		    Tcl_DecrRefCount(slavePtr);
		}
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, slavePtr);
	    return TCL_OK;
	}
	case OPT_DELETE: {
	    int i;
	    InterpInfo *iiPtr;
	    Tcl_Interp *slaveInterp;
	    
	    for (i = 2; i < objc; i++) {
		slaveInterp = GetInterp(interp, objv[i]);
		if (slaveInterp == NULL) {
		    return TCL_ERROR;
		} else if (slaveInterp == interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "cannot delete the current interpreter", -1));
		    return TCL_ERROR;
		}
		iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
		Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
			iiPtr->slave.interpCmd);
	    }
	    return TCL_OK;
	}
	case OPT_EVAL: {
	    Tcl_Interp *slaveInterp;

	    if (objc < 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_EXISTS: {
	    int exists;
	    Tcl_Interp *slaveInterp;

	    exists = 1;
	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		if (objc > 3) {
		    return TCL_ERROR;
		}
		Tcl_ResetResult(interp);
		exists = 0;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
	    return TCL_OK;
	}
	case OPT_EXPOSE: {
	    Tcl_Interp *slaveInterp;

	    if ((objc < 4) || (objc > 5)) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path hiddenCmdName ?cmdName?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_HIDE: {
	    Tcl_Interp *slaveInterp;		/* A slave. */

	    if ((objc < 4) || (objc > 5)) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path cmdName ?hiddenCmdName?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_HIDDEN: {
	    Tcl_Interp *slaveInterp;		/* A slave. */

	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveHidden(interp, slaveInterp);
	}
	case OPT_ISSAFE: {
	    Tcl_Interp *slaveInterp;

	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp,
		    Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	    return TCL_OK;
	}
	case OPT_INVOKEHID: {
	    int i, index;
	    CONST char *namespaceName;
	    Tcl_Interp *slaveInterp;
	    static CONST char *hiddenOptions[] = {
		"-global",	"-namespace",	"--",		NULL
	    };
	    enum hiddenOption {
		OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	    };

	    namespaceName = NULL;
	    for (i = 3; i < objc; i++) {
		if (Tcl_GetString(objv[i])[0] != '-') {
		    break;
		}
		if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
			"option", 0, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (index == OPT_GLOBAL) {
		    namespaceName = "::";
		} else {
		    if (index == OPT_NAMESPACE) {
			if (++i == objc) { /* There must be more arguments. */
		            break;
			} else {
		            namespaceName = Tcl_GetString(objv[i]);
			}
		    } else {
			i++;
			break;
		    }
		}
	    }
	    if (objc - i < 1) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
		    objc - i, objv + i);
	}
	case OPT_LIMIT: {
	    Tcl_Interp *slaveInterp;
	    static CONST char *limitTypes[] = {
		"commands", "time", NULL
	    };
	    enum LimitTypes {
		LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
	    };
	    int limitType;

	    if (objc < 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type",
		    0, &limitType) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum LimitTypes) limitType) {
	    case LIMIT_TYPE_COMMANDS:
		return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
	    case LIMIT_TYPE_TIME:
		return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
	    }
	}
	case OPT_MARKTRUSTED: {
	    Tcl_Interp *slaveInterp;

	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "path");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveMarkTrusted(interp, slaveInterp);
	}
	case OPT_RECLIMIT: {
	    Tcl_Interp *slaveInterp;

	    if (objc != 3 && objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
	}
	case OPT_SLAVES: {
	    Tcl_Interp *slaveInterp;
	    InterpInfo *iiPtr;
	    Tcl_Obj *resultPtr;
	    Tcl_HashEntry *hPtr;
	    Tcl_HashSearch hashSearch;
	    char *string;
	    
	    slaveInterp = GetInterp2(interp, objc, objv);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	    resultPtr = Tcl_NewObj();
	    hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
	    for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
		string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
		Tcl_ListObjAppendElement(NULL, resultPtr,
			Tcl_NewStringObj(string, -1));
	    }
	    Tcl_SetObjResult(interp, resultPtr);
	    return TCL_OK;
	}
	case OPT_SHARE: {
	    Tcl_Interp *slaveInterp;		/* A slave. */
	    Tcl_Interp *masterInterp;		/* Its master. */
	    Tcl_Channel chan;

	    if (objc != 5) {
		Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
		return TCL_ERROR;
	    }
	    masterInterp = GetInterp(interp, objv[2]);
	    if (masterInterp == NULL) {
		return TCL_ERROR;
	    }
	    chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
		    NULL);
	    if (chan == NULL) {
		TclTransferResult(masterInterp, TCL_OK, interp);
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[4]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_RegisterChannel(slaveInterp, chan);
	    return TCL_OK;
	}
	case OPT_TARGET: {
	    Tcl_Interp *slaveInterp;
	    InterpInfo *iiPtr;
	    Tcl_HashEntry *hPtr;	
	    Alias *aliasPtr;		
	    char *aliasName;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "path alias");
		return TCL_ERROR;
	    }

	    slaveInterp = GetInterp(interp, objv[2]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }

	    aliasName = Tcl_GetString(objv[3]);

	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
	    if (hPtr == NULL) {
		Tcl_AppendResult(interp, "alias \"", aliasName,
			"\" in path \"", Tcl_GetString(objv[2]),
			"\" not found", (char *) NULL);
		return TCL_ERROR;
	    }
	    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
	    if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "target interpreter for alias \"",
			aliasName, "\" in path \"", Tcl_GetString(objv[2]),
			"\" is not my descendant", (char *) NULL);
		return TCL_ERROR;
	    }
	    return TCL_OK;
	}
	case OPT_TRANSFER: {
	    Tcl_Interp *slaveInterp;		/* A slave. */
	    Tcl_Interp *masterInterp;		/* Its master. */
	    Tcl_Channel chan;
		    
	    if (objc != 5) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"srcPath channelId destPath");
		return TCL_ERROR;
	    }
	    masterInterp = GetInterp(interp, objv[2]);
	    if (masterInterp == NULL) {
		return TCL_ERROR;
	    }
	    chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
	    if (chan == NULL) {
		TclTransferResult(masterInterp, TCL_OK, interp);
		return TCL_ERROR;
	    }
	    slaveInterp = GetInterp(interp, objv[4]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_RegisterChannel(slaveInterp, chan);
	    if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
		TclTransferResult(masterInterp, TCL_OK, interp);
		return TCL_ERROR;
	    }
	    return TCL_OK;
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInterp2 --
 *
 *	Helper function for Tcl_InterpObjCmd() to convert the interp name
 *	potentially specified on the command line to an Tcl_Interp.
 *
 * Results:
 *	The return value is the interp specified on the command line,
 *	or the interp argument itself if no interp was specified on the
 *	command line.  If the interp could not be found or the wrong
 *	number of arguments was specified on the command line, the return
 *	value is NULL and an error message is left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
static Tcl_Interp *
GetInterp2(interp, objc, objv)
    Tcl_Interp *interp;		/* Default interp if no interp was specified
				 * on the command line. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{







|
|












|
|
|
|



|












|







|
|



















|




|









<

|
|

|




|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
<
|
|
|
|
|
|
|
|
|
|

|
|
<
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|

|

|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|













|
|
|
|
|






|







496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580

581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768

769
770
771
772
773
774
775
776
777
778
779
780
781

782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806

807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830

831
832
833
834
835
836
837
838
839
840
841

842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945

946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979

980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999

1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
    if (masterPtr->slaveTable.numEntries != 0) {
	Tcl_Panic("InterpInfoDeleteProc: still exist commands");
    }
    Tcl_DeleteHashTable(&masterPtr->slaveTable);

    /*
     * Tell any interps that have aliases to this interp that they should
     * delete those aliases. If the other interp was already dead, it would
     * have removed the target record already.
     */

    for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) {
	Target *tmpPtr = targetPtr->nextPtr;
	Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
		targetPtr->slaveCmd);
	targetPtr = tmpPtr;
    }

    slavePtr = &interpInfoPtr->slave;
    if (slavePtr->interpCmd != NULL) {
	/*
	 * Tcl_DeleteInterp() was called on this interpreter, rather "interp
	 * delete" or the equivalent deletion of the command in the master.
	 * First ensure that the cleanup callback doesn't try to delete the
	 * interp again.
	 */

	slavePtr->slaveInterp = NULL;
	Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
		slavePtr->interpCmd);
    }

    /*
     * There shouldn't be any aliases left.
     */

    if (slavePtr->aliasTable.numEntries != 0) {
	Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
    }
    Tcl_DeleteHashTable(&slavePtr->aliasTable);

    ckfree((char *) interpInfoPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpObjCmd --
 *
 *	This procedure is invoked to process the "interp" Tcl command.  See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_InterpObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Unused. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int index;
    static CONST char *options[] = {
	"alias",	"aliases",	"bgerror",	"create",
	"delete",	"eval",		"exists",	"expose",
	"hide",		"hidden",	"issafe",	"invokehidden",
	"limit",	"marktrusted",	"recursionlimit","slaves",
	"share",	"target",	"transfer",
	NULL
    };
    enum option {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_CREATE,
	OPT_DELETE,	OPT_EVAL,	OPT_EXISTS,	OPT_EXPOSE,
	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,	OPT_INVOKEHID,
	OPT_LIMIT,	OPT_MARKTRUSTED,OPT_RECLIMIT,	OPT_SLAVES,
	OPT_SHARE,	OPT_TARGET,	OPT_TRANSFER
    };


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum option) index) {
    case OPT_ALIAS: {
	Tcl_Interp *slaveInterp, *masterInterp;

	if (objc < 4) {
	aliasArgs:
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == (Tcl_Interp *) NULL) {
	    return TCL_ERROR;
	}
	if (objc == 4) {
	    return AliasDescribe(interp, slaveInterp, objv[3]);
	}
	if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
	    return AliasDelete(interp, slaveInterp, objv[3]);
	}
	if (objc > 5) {
	    masterInterp = GetInterp(interp, objv[4]);
	    if (masterInterp == (Tcl_Interp *) NULL) {
		return TCL_ERROR;
	    }
	    if (Tcl_GetString(objv[5])[0] == '\0') {
		if (objc == 6) {
		    return AliasDelete(interp, slaveInterp, objv[3]);
		}
	    } else {
		return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
			objv[5], objc - 6, objv + 6);
	    }
	}
	goto aliasArgs;
    }
    case OPT_ALIASES: {
	Tcl_Interp *slaveInterp;

	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return AliasList(interp, slaveInterp);
    }
    case OPT_BGERROR: {
	Tcl_Interp *slaveInterp;

	if (objc != 3 && objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
    }
    case OPT_CREATE: {
	int i, last, safe;
	Tcl_Obj *slavePtr;
	char buf[16 + TCL_INTEGER_SPACE];
	static CONST char *options[] = {
	    "-safe",	"--",		NULL
	};
	enum option {
	    OPT_SAFE,	OPT_LAST
	};

	safe = Tcl_IsSafe(interp);

	/*
	 * Weird historical rules: "-safe" is accepted at the end, too.
	 */

	slavePtr = NULL;
	last = 0;
	for (i = 2; i < objc; i++) {
	    if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
		if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
			&index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (index == OPT_SAFE) {
		    safe = 1;
		    continue;
		}
		i++;
		last = 1;
	    }
	    if (slavePtr != NULL) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
		return TCL_ERROR;
	    }
	    if (i < objc) {
		slavePtr = objv[i];
	    }
	}
	buf[0] = '\0';
	if (slavePtr == NULL) {
	    /*
	     * Create an anonymous interpreter -- we choose its name and the
	     * name of the command. We check that the command name that we use
	     * for the interpreter does not collide with an existing command
	     * in the master interpreter.
	     */

	    for (i = 0; ; i++) {
		Tcl_CmdInfo cmdInfo;

		sprintf(buf, "interp%d", i);
		if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
		    break;
		}
	    }
	    slavePtr = Tcl_NewStringObj(buf, -1);
	}
	if (SlaveCreate(interp, slavePtr, safe) == NULL) {
	    if (buf[0] != '\0') {
		Tcl_DecrRefCount(slavePtr);
	    }
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, slavePtr);
	return TCL_OK;
    }
    case OPT_DELETE: {
	int i;
	InterpInfo *iiPtr;
	Tcl_Interp *slaveInterp;

	for (i = 2; i < objc; i++) {
	    slaveInterp = GetInterp(interp, objv[i]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    } else if (slaveInterp == interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot delete the current interpreter", -1));
		return TCL_ERROR;
	    }
	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	    Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
		    iiPtr->slave.interpCmd);
	}
	return TCL_OK;
    }
    case OPT_EVAL: {
	Tcl_Interp *slaveInterp;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
    }
    case OPT_EXISTS: {
	int exists;
	Tcl_Interp *slaveInterp;

	exists = 1;
	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    if (objc > 3) {
		return TCL_ERROR;
	    }
	    Tcl_ResetResult(interp);
	    exists = 0;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
	return TCL_OK;
    }
    case OPT_EXPOSE: {
	Tcl_Interp *slaveInterp;

	if ((objc < 4) || (objc > 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");

	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
    }
    case OPT_HIDE: {
	Tcl_Interp *slaveInterp;		/* A slave. */

	if ((objc < 4) || (objc > 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");

	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == (Tcl_Interp *) NULL) {
	    return TCL_ERROR;
	}
	return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
    }
    case OPT_HIDDEN: {
	Tcl_Interp *slaveInterp;		/* A slave. */

	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveHidden(interp, slaveInterp);
    }
    case OPT_ISSAFE: {
	Tcl_Interp *slaveInterp;

	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));

	return TCL_OK;
    }
    case OPT_INVOKEHID: {
	int i, index;
	CONST char *namespaceName;
	Tcl_Interp *slaveInterp;
	static CONST char *hiddenOptions[] = {
	    "-global",	"-namespace",	"--",		NULL
	};
	enum hiddenOption {
	    OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	};

	namespaceName = NULL;
	for (i = 3; i < objc; i++) {
	    if (Tcl_GetString(objv[i])[0] != '-') {
		break;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option",
		    0, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (index == OPT_GLOBAL) {
		namespaceName = "::";

	    } else if (index == OPT_NAMESPACE) {
		if (++i == objc) { /* There must be more arguments. */
		    break;
		} else {
		    namespaceName = Tcl_GetString(objv[i]);
		}
	    } else {
		i++;
		break;
	    }
	}

	if (objc - i < 1) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == (Tcl_Interp *) NULL) {
	    return TCL_ERROR;
	}
	return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i,
		objv + i);
    }
    case OPT_LIMIT: {
	Tcl_Interp *slaveInterp;
	static CONST char *limitTypes[] = {
	    "commands", "time", NULL
	};
	enum LimitTypes {
	    LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
	};
	int limitType;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0,
		&limitType) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum LimitTypes) limitType) {
	case LIMIT_TYPE_COMMANDS:
	    return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
	case LIMIT_TYPE_TIME:
	    return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
	}
    }
    case OPT_MARKTRUSTED: {
	Tcl_Interp *slaveInterp;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveMarkTrusted(interp, slaveInterp);
    }
    case OPT_RECLIMIT: {
	Tcl_Interp *slaveInterp;

	if (objc != 3 && objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
    }
    case OPT_SLAVES: {
	Tcl_Interp *slaveInterp;
	InterpInfo *iiPtr;
	Tcl_Obj *resultPtr;
	Tcl_HashEntry *hPtr;
	Tcl_HashSearch hashSearch;
	char *string;

	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	resultPtr = Tcl_NewObj();
	hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
	    string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
	    Tcl_ListObjAppendElement(NULL, resultPtr,
		    Tcl_NewStringObj(string, -1));
	}
	Tcl_SetObjResult(interp, resultPtr);
	return TCL_OK;
    }
    case OPT_SHARE: {
	Tcl_Interp *slaveInterp;		/* A slave. */
	Tcl_Interp *masterInterp;		/* Its master. */
	Tcl_Channel chan;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
	    return TCL_ERROR;
	}
	masterInterp = GetInterp(interp, objv[2]);
	if (masterInterp == NULL) {
	    return TCL_ERROR;
	}
	chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);

	if (chan == NULL) {
	    TclTransferResult(masterInterp, TCL_OK, interp);
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[4]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	Tcl_RegisterChannel(slaveInterp, chan);
	return TCL_OK;
    }
    case OPT_TARGET: {
	Tcl_Interp *slaveInterp;
	InterpInfo *iiPtr;
	Tcl_HashEntry *hPtr;
	Alias *aliasPtr;
	char *aliasName;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path alias");
	    return TCL_ERROR;
	}

	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}

	aliasName = Tcl_GetString(objv[3]);

	iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
	if (hPtr == NULL) {
	    Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"",

		    Tcl_GetString(objv[2]), "\" not found", (char *) NULL);
	    return TCL_ERROR;
	}
	aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
	if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "target interpreter for alias \"",
		    aliasName, "\" in path \"", Tcl_GetString(objv[2]),
		    "\" is not my descendant", (char *) NULL);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    case OPT_TRANSFER: {
	Tcl_Interp *slaveInterp;		/* A slave. */
	Tcl_Interp *masterInterp;		/* Its master. */
	Tcl_Channel chan;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");

	    return TCL_ERROR;
	}
	masterInterp = GetInterp(interp, objv[2]);
	if (masterInterp == NULL) {
	    return TCL_ERROR;
	}
	chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
	if (chan == NULL) {
	    TclTransferResult(masterInterp, TCL_OK, interp);
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[4]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	Tcl_RegisterChannel(slaveInterp, chan);
	if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
	    TclTransferResult(masterInterp, TCL_OK, interp);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * GetInterp2 --
 *
 *	Helper function for Tcl_InterpObjCmd() to convert the interp name
 *	potentially specified on the command line to an Tcl_Interp.
 *
 * Results:
 *	The return value is the interp specified on the command line, or the
 *	interp argument itself if no interp was specified on the command line.
 *	If the interp could not be found or the wrong number of arguments was
 *	specified on the command line, the return value is NULL and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Interp *
GetInterp2(interp, objc, objv)
    Tcl_Interp *interp;		/* Default interp if no interp was specified
				 * on the command line. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
    int argc;			/* How many additional arguments? */
    CONST char * CONST *argv;	/* These are the additional args. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    int i;
    int result;
    
    objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
        objv[i] = Tcl_NewStringObj(argv[i], -1);
        Tcl_IncrRefCount(objv[i]);
    }
    
    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,







|


|
|

|







1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
    int argc;			/* How many additional arguments? */
    CONST char * CONST *argv;	/* These are the additional args. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    int i;
    int result;

    objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
	objv[i] = Tcl_NewStringObj(argv[i], -1);
	Tcl_IncrRefCount(objv[i]);
    }

    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
 *----------------------------------------------------------------------
 *
 * Tcl_GetAlias --
 *
 *	Gets information about an alias.
 *
 * Results:
 *	A standard Tcl result. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
        argvPtr)
    Tcl_Interp *interp;			/* Interp to start search from. */
    CONST char *aliasName;			/* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;	/* (Return) target interpreter. */
    CONST char **targetNamePtr;		/* (Return) name of target command. */
    int *argcPtr;			/* (Return) count of addnl args. */
    CONST char ***argvPtr;		/* (Return) additional arguments. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int i, objc;
    Tcl_Obj **objv;
    
    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == NULL) {
        Tcl_AppendResult(interp, "alias \"", aliasName,
		"\" not found", (char *) NULL);
	return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != NULL) {
	*targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != NULL) {
	*targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (argcPtr != NULL) {
	*argcPtr = objc - 1;
    }
    if (argvPtr != NULL) {
        *argvPtr = (CONST char **) 
		ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
        for (i = 1; i < objc; i++) {
            *argvPtr[i - 1] = Tcl_GetString(objv[i]);
        }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|









|

|










|



|

















|

|
|
|







1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
 *----------------------------------------------------------------------
 *
 * Tcl_GetAlias --
 *
 *	Gets information about an alias.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
	argvPtr)
    Tcl_Interp *interp;			/* Interp to start search from. */
    CONST char *aliasName;		/* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;	/* (Return) target interpreter. */
    CONST char **targetNamePtr;		/* (Return) name of target command. */
    int *argcPtr;			/* (Return) count of addnl args. */
    CONST char ***argvPtr;		/* (Return) additional arguments. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int i, objc;
    Tcl_Obj **objv;

    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "alias \"", aliasName,
		"\" not found", (char *) NULL);
	return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != NULL) {
	*targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != NULL) {
	*targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (argcPtr != NULL) {
	*argcPtr = objc - 1;
    }
    if (argvPtr != NULL) {
	*argvPtr = (CONST char **)
		ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
	for (i = 1; i < objc; i++) {
	    *argvPtr[i - 1] = Tcl_GetString(objv[i]);
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
        objvPtr)
    Tcl_Interp *interp;			/* Interp to start search from. */
    CONST char *aliasName;		/* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;	/* (Return) target interpreter. */
    CONST char **targetNamePtr;		/* (Return) name of target command. */
    int *objcPtr;			/* (Return) count of addnl args. */
    Tcl_Obj ***objvPtr;			/* (Return) additional args. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;	
    int objc;
    Tcl_Obj **objv;

    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendResult(interp, "alias \"", aliasName,
		"\" not found", (char *) NULL);
        return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != (Tcl_Interp **) NULL) {
        *targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != (CONST char **) NULL) {
        *targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (objcPtr != (int *) NULL) {
        *objcPtr = objc - 1;
    }
    if (objvPtr != (Tcl_Obj ***) NULL) {
        *objvPtr = objv + 1;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPreventAliasLoop --
 *
 *	When defining an alias or renaming a command, prevent an alias
 *	loop from being formed.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the function also stores an error message
 *	in the interpreter's result object.
 *
 * NOTE:
 *	This function is public internal (instead of being static to
 *	this file) because it is also used from TclRenameCommand.
 *
 *----------------------------------------------------------------------
 */

int
TclPreventAliasLoop(interp, cmdInterp, cmd)
    Tcl_Interp *interp;			/* Interp in which to report errors. */
    Tcl_Interp *cmdInterp;		/* Interp in which the command is
                                         * being defined. */
    Tcl_Command cmd;                    /* Tcl command we are attempting
                                         * to define. */
{
    Command *cmdPtr = (Command *) cmd;
    Alias *aliasPtr, *nextAliasPtr;
    Tcl_Command aliasCmd;
    Command *aliasCmdPtr;

    /*
     * If we are not creating or renaming an alias, then it is
     * always OK to create or rename the command.
     */
    
    if (cmdPtr->objProc != AliasObjCmd) {
        return TCL_OK;
    }

    /*
     * OK, we are dealing with an alias, so traverse the chain of aliases.
     * If we encounter the alias we are defining (or renaming to) any in
     * the chain then we have a loop.
     */

    aliasPtr = (Alias *) cmdPtr->objClientData;
    nextAliasPtr = aliasPtr;
    while (1) {
	Tcl_Obj *cmdNamePtr;

        /*
         * If the target of the next alias in the chain is the same as
         * the source alias, we have a loop.
	 */

	if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
	    /*
	     * The slave interpreter can be deleted while creating the alias.
	     * [Bug #641195]
	     */

	    Tcl_AppendResult(interp, "cannot define or rename alias \"",
		    Tcl_GetCommandName(cmdInterp, cmd),
		    "\": interpreter deleted", (char *) NULL);
	    return TCL_ERROR;
	}
	cmdNamePtr = nextAliasPtr->objPtr;
	aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
                Tcl_GetString(cmdNamePtr),
		Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
		/*flags*/ 0);
        if (aliasCmd == (Tcl_Command) NULL) {
            return TCL_OK;
        }
	aliasCmdPtr = (Command *) aliasCmd;
        if (aliasCmdPtr == cmdPtr) {
            Tcl_AppendResult(interp, "cannot define or rename alias \"",
		    Tcl_GetCommandName(cmdInterp, cmd),
		    "\": would create a loop", (char *) NULL);
            return TCL_ERROR;
        }

        /*
	 * Otherwise, follow the chain one step further. See if the target
         * command is an alias - if so, follow the loop to its target
         * command. Otherwise we do not have a loop.
	 */

        if (aliasCmdPtr->objProc != AliasObjCmd) {
            return TCL_OK;
        }
        nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
    }

    /* NOTREACHED */
}

/*
 *----------------------------------------------------------------------
 *
 * AliasCreate --
 *
 *	Helper function to do the work to actually create an alias.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	An alias command is created and entered into the alias table
 *	for the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
	objc, objv)







|









|






|
|
|






|


|


|


|









|
|





|
|


|
|








|
|
|







|
|

|

|



|
|
|







|
|
|















|


|
|
|

|
|


|
|

|

|
|


|
|
|
|
















|
|







1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
	objvPtr)
    Tcl_Interp *interp;			/* Interp to start search from. */
    CONST char *aliasName;		/* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;	/* (Return) target interpreter. */
    CONST char **targetNamePtr;		/* (Return) name of target command. */
    int *objcPtr;			/* (Return) count of addnl args. */
    Tcl_Obj ***objvPtr;			/* (Return) additional args. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int objc;
    Tcl_Obj **objv;

    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == (Tcl_HashEntry *) NULL) {
	Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found",
		(char *) NULL);
	return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != (Tcl_Interp **) NULL) {
	*targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != (CONST char **) NULL) {
	*targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (objcPtr != (int *) NULL) {
	*objcPtr = objc - 1;
    }
    if (objvPtr != (Tcl_Obj ***) NULL) {
	*objvPtr = objv + 1;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPreventAliasLoop --
 *
 *	When defining an alias or renaming a command, prevent an alias loop
 *	from being formed.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the function also stores an error message in
 *	the interpreter's result object.
 *
 * NOTE:
 *	This function is public internal (instead of being static to this
 *	file) because it is also used from TclRenameCommand.
 *
 *----------------------------------------------------------------------
 */

int
TclPreventAliasLoop(interp, cmdInterp, cmd)
    Tcl_Interp *interp;			/* Interp in which to report errors. */
    Tcl_Interp *cmdInterp;		/* Interp in which the command is
					 * being defined. */
    Tcl_Command cmd;			/* Tcl command we are attempting to
					 * define. */
{
    Command *cmdPtr = (Command *) cmd;
    Alias *aliasPtr, *nextAliasPtr;
    Tcl_Command aliasCmd;
    Command *aliasCmdPtr;

    /*
     * If we are not creating or renaming an alias, then it is always OK to
     * create or rename the command.
     */

    if (cmdPtr->objProc != AliasObjCmd) {
	return TCL_OK;
    }

    /*
     * OK, we are dealing with an alias, so traverse the chain of aliases. If
     * we encounter the alias we are defining (or renaming to) any in the
     * chain then we have a loop.
     */

    aliasPtr = (Alias *) cmdPtr->objClientData;
    nextAliasPtr = aliasPtr;
    while (1) {
	Tcl_Obj *cmdNamePtr;

	/*
	 * If the target of the next alias in the chain is the same as the
	 * source alias, we have a loop.
	 */

	if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
	    /*
	     * The slave interpreter can be deleted while creating the alias.
	     * [Bug #641195]
	     */

	    Tcl_AppendResult(interp, "cannot define or rename alias \"",
		    Tcl_GetCommandName(cmdInterp, cmd),
		    "\": interpreter deleted", (char *) NULL);
	    return TCL_ERROR;
	}
	cmdNamePtr = nextAliasPtr->objPtr;
	aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
		Tcl_GetString(cmdNamePtr),
		Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
		/*flags*/ 0);
	if (aliasCmd == (Tcl_Command) NULL) {
	    return TCL_OK;
	}
	aliasCmdPtr = (Command *) aliasCmd;
	if (aliasCmdPtr == cmdPtr) {
	    Tcl_AppendResult(interp, "cannot define or rename alias \"",
		    Tcl_GetCommandName(cmdInterp, cmd),
		    "\": would create a loop", (char *) NULL);
	    return TCL_ERROR;
	}

	/*
	 * Otherwise, follow the chain one step further. See if the target
	 * command is an alias - if so, follow the loop to its target command.
	 * Otherwise we do not have a loop.
	 */

	if (aliasCmdPtr->objProc != AliasObjCmd) {
	    return TCL_OK;
	}
	nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
    }

    /* NOTREACHED */
}

/*
 *----------------------------------------------------------------------
 *
 * AliasCreate --
 *
 *	Helper function to do the work to actually create an alias.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	An alias command is created and entered into the alias table for the
 *	slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
	objc, objv)
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
    Tcl_HashEntry *hPtr;
    Target *targetPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Tcl_Obj **prefv;
    int new, i;

    aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) 
            + objc * sizeof(Tcl_Obj *)));
    aliasPtr->token = namePtr;
    Tcl_IncrRefCount(aliasPtr->token);
    aliasPtr->targetInterp = masterInterp;

    aliasPtr->objc = objc + 1;
    prefv = &aliasPtr->objPtr;








|
|







1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
    Tcl_HashEntry *hPtr;
    Target *targetPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Tcl_Obj **prefv;
    int new, i;

    aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
	    + objc * sizeof(Tcl_Obj *)));
    aliasPtr->token = namePtr;
    Tcl_IncrRefCount(aliasPtr->token);
    aliasPtr->targetInterp = masterInterp;

    aliasPtr->objc = objc + 1;
    prefv = &aliasPtr->objPtr;

1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
    aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
	    Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
	    AliasObjCmdDeleteProc);

    if (TclPreventAliasLoop(interp, slaveInterp,
	    aliasPtr->slaveCmd) != TCL_OK) {
	/*
	 * Found an alias loop!	 The last call to Tcl_CreateObjCommand made
	 * the alias point to itself.  Delete the command and its alias
	 * record.  Be careful to wipe out its client data first, so the
	 * command doesn't try to delete itself.
	 */

	Command *cmdPtr;
	
	Tcl_DecrRefCount(aliasPtr->token);
	Tcl_DecrRefCount(targetNamePtr);
	for (i = 0; i < objc; i++) {
	    Tcl_DecrRefCount(objv[i]);
	}
	
	cmdPtr = (Command *) aliasPtr->slaveCmd;
	cmdPtr->clientData = NULL;
	cmdPtr->deleteProc = NULL;
	cmdPtr->deleteData = NULL;
	Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);

	ckfree((char *) aliasPtr);







|






|





|







1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
    aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
	    Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
	    AliasObjCmdDeleteProc);

    if (TclPreventAliasLoop(interp, slaveInterp,
	    aliasPtr->slaveCmd) != TCL_OK) {
	/*
	 * Found an alias loop!  The last call to Tcl_CreateObjCommand made
	 * the alias point to itself.  Delete the command and its alias
	 * record.  Be careful to wipe out its client data first, so the
	 * command doesn't try to delete itself.
	 */

	Command *cmdPtr;

	Tcl_DecrRefCount(aliasPtr->token);
	Tcl_DecrRefCount(targetNamePtr);
	for (i = 0; i < objc; i++) {
	    Tcl_DecrRefCount(objv[i]);
	}

	cmdPtr = (Command *) aliasPtr->slaveCmd;
	cmdPtr->clientData = NULL;
	cmdPtr->deleteProc = NULL;
	cmdPtr->deleteData = NULL;
	Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);

	ckfree((char *) aliasPtr);
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
     * Make an entry in the alias table. If it already exists, retry.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    while (1) {
	Tcl_Obj *newToken;
	char *string;
	
	string = Tcl_GetString(aliasPtr->token);
	hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
	if (new != 0) {
	    break;
	}

	/*
	 * The alias name cannot be used as unique token, it is already
	 * taken. We can produce a unique token by prepending "::"
	 * repeatedly. This algorithm is a stop-gap to try to maintain
	 * the command name as token for most use cases, fearful of
	 * possible backwards compat problems. A better algorithm would
	 * produce unique tokens that need not be related to the command
	 * name.
	 *
	 * ATTENTION: the tests in interp.test and possibly safe.test
	 * depend on the precise definition of these tokens.
	 */
	
	newToken = Tcl_NewStringObj("::",-1);
	Tcl_AppendObjToObj(newToken, aliasPtr->token);
	Tcl_DecrRefCount(aliasPtr->token);
	aliasPtr->token = newToken;
	Tcl_IncrRefCount(aliasPtr->token);
    }

    aliasPtr->aliasEntryPtr = hPtr;
    Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
    
    /*
     * Create the new command. We must do it after deleting any old command,
     * because the alias may be pointing at a renamed alias, as in:
     *
     * interp alias {} foo {} bar		# Create an alias "foo"
     * rename foo zop				# Now rename the alias
     * interp alias {} foo {} zop		# Now recreate "foo"...







|







|
|
|
|
|
|
<

|
|

|









|







1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499

1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
     * Make an entry in the alias table. If it already exists, retry.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    while (1) {
	Tcl_Obj *newToken;
	char *string;

	string = Tcl_GetString(aliasPtr->token);
	hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
	if (new != 0) {
	    break;
	}

	/*
	 * The alias name cannot be used as unique token, it is already taken.
	 * We can produce a unique token by prepending "::" repeatedly. This
	 * algorithm is a stop-gap to try to maintain the command name as
	 * token for most use cases, fearful of possible backwards compat
	 * problems. A better algorithm would produce unique tokens that need
	 * not be related to the command name.

	 *
	 * ATTENTION: the tests in interp.test and possibly safe.test depend
	 * on the precise definition of these tokens.
	 */

	newToken = Tcl_NewStringObj("::",-1);
	Tcl_AppendObjToObj(newToken, aliasPtr->token);
	Tcl_DecrRefCount(aliasPtr->token);
	aliasPtr->token = newToken;
	Tcl_IncrRefCount(aliasPtr->token);
    }

    aliasPtr->aliasEntryPtr = hPtr;
    Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);

    /*
     * Create the new command. We must do it after deleting any old command,
     * because the alias may be pointing at a renamed alias, as in:
     *
     * interp alias {} foo {} bar		# Create an alias "foo"
     * rename foo zop				# Now rename the alias
     * interp alias {} foo {} zop		# Now recreate "foo"...
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
     * the original name (with which it was created) to find the alias to
     * delete it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "alias \"",
		Tcl_GetString(namePtr), "\" not found", NULL);
        return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasDescribe --
 *
 *	Sets the interpreter's result object to a Tcl list describing
 *	the given alias in the given interpreter: its target command
 *	and the additional arguments to prepend to any invocation
 *	of the alias.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
AliasDescribe(interp, slaveInterp, namePtr)
    Tcl_Interp *interp;		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
    Tcl_Obj *namePtr;		/* Name of alias to describe. */
{
    Slave *slavePtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;	
    Tcl_Obj *prefixPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
        return TCL_OK;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
    Tcl_SetObjResult(interp, prefixPtr);
    return TCL_OK;
}








|
|
|











|
|
|
<


















|











|







1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595

1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
     * the original name (with which it was created) to find the alias to
     * delete it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr),
		"\" not found", NULL);
	return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasDescribe --
 *
 *	Sets the interpreter's result object to a Tcl list describing the
 *	given alias in the given interpreter: its target command and the
 *	additional arguments to prepend to any invocation of the alias.

 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
AliasDescribe(interp, slaveInterp, namePtr)
    Tcl_Interp *interp;		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
    Tcl_Obj *namePtr;		/* Name of alias to describe. */
{
    Slave *slavePtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    Tcl_Obj *prefixPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
	return TCL_OK;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
    Tcl_SetObjResult(interp, prefixPtr);
    return TCL_OK;
}

1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
    Alias *aliasPtr;
    Slave *slavePtr;

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;

    entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
    for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
        aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
        Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmd --
 *
 *	This is the procedure that services invocations of aliases in a
 *	slave interpreter. One such command exists for each alias. When
 *	invoked, this procedure redirects the invocation to the target
 *	command in the master interpreter as designated by the Alias
 *	record associated with this command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Causes forwarding of the invocation; all possible side effects
 *	may occur as a result of invoking the command to which the
 *	invocation is forwarded.
 *
 *----------------------------------------------------------------------
 */

static int
AliasObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Alias record. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument vector. */	
{
#define ALIAS_CMDV_PREALLOC 10
    Tcl_Interp *targetInterp;	
    Alias *aliasPtr;		
    int result, prefc, cmdc, i;
    Tcl_Obj **prefv, **cmdv;
    Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
    aliasPtr = (Alias *) clientData;
    targetInterp = aliasPtr->targetInterp;

    /*
     * Append the arguments to the command prefix and invoke the command
     * in the target interp's global namespace.
     */
     
    prefc = aliasPtr->objc;
    prefv = &aliasPtr->objPtr;
    cmdc = prefc + objc - 1;
    if (cmdc <= ALIAS_CMDV_PREALLOC) {
	cmdv = cmdArr;
    } else {
	cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
    }

    prefv = &aliasPtr->objPtr;
    memcpy((VOID *) cmdv, (VOID *) prefv, 
            (size_t) (prefc * sizeof(Tcl_Obj *)));
    memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), 
	    (size_t) ((objc-1) * sizeof(Tcl_Obj *)));

    Tcl_ResetResult(targetInterp);

    for (i=0; i<cmdc; i++) {
	Tcl_IncrRefCount(cmdv[i]);
    }
    if (targetInterp != interp) {
	Tcl_Preserve((ClientData) targetInterp);
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
	TclTransferResult(targetInterp, result, interp);	
	Tcl_Release((ClientData) targetInterp);
    } else {
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
    }
    for (i=0; i<cmdc; i++) {
	Tcl_DecrRefCount(cmdv[i]);
    }

    if (cmdv != cmdArr) {
	ckfree((char *) cmdv);
    }
    return result;        
#undef ALIAS_CMDV_PREALLOC
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *
 *	Is invoked when an alias command is deleted in a slave. Cleans up
 *	all storage associated with this alias.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the alias record and its entry in the alias table for
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
AliasObjCmdDeleteProc(clientData)
    ClientData clientData;	/* The alias record for this alias. */
{
    Alias *aliasPtr;		
    Target *targetPtr;		
    int i;
    Tcl_Obj **objv;

    aliasPtr = (Alias *) clientData;
    
    Tcl_DecrRefCount(aliasPtr->token);
    objv = &aliasPtr->objPtr;
    for (i = 0; i < aliasPtr->objc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);








|
|










|
|
|
|
|





|
|
|









|


|
|







|
|

|










|
|
|










|











|








|
|





|
|








|
|




|







1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
    Alias *aliasPtr;
    Slave *slavePtr;

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;

    entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
    for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
	aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
	Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmd --
 *
 *	This is the procedure that services invocations of aliases in a slave
 *	interpreter. One such command exists for each alias. When invoked,
 *	this procedure redirects the invocation to the target command in the
 *	master interpreter as designated by the Alias record associated with
 *	this command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Causes forwarding of the invocation; all possible side effects may
 *	occur as a result of invoking the command to which the invocation is
 *	forwarded.
 *
 *----------------------------------------------------------------------
 */

static int
AliasObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Alias record. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
    Tcl_Interp *targetInterp;
    Alias *aliasPtr;
    int result, prefc, cmdc, i;
    Tcl_Obj **prefv, **cmdv;
    Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
    aliasPtr = (Alias *) clientData;
    targetInterp = aliasPtr->targetInterp;

    /*
     * Append the arguments to the command prefix and invoke the command in
     * the target interp's global namespace.
     */

    prefc = aliasPtr->objc;
    prefv = &aliasPtr->objPtr;
    cmdc = prefc + objc - 1;
    if (cmdc <= ALIAS_CMDV_PREALLOC) {
	cmdv = cmdArr;
    } else {
	cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
    }

    prefv = &aliasPtr->objPtr;
    memcpy((VOID *) cmdv, (VOID *) prefv,
	    (size_t) (prefc * sizeof(Tcl_Obj *)));
    memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
	    (size_t) ((objc-1) * sizeof(Tcl_Obj *)));

    Tcl_ResetResult(targetInterp);

    for (i=0; i<cmdc; i++) {
	Tcl_IncrRefCount(cmdv[i]);
    }
    if (targetInterp != interp) {
	Tcl_Preserve((ClientData) targetInterp);
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
	TclTransferResult(targetInterp, result, interp);
	Tcl_Release((ClientData) targetInterp);
    } else {
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
    }
    for (i=0; i<cmdc; i++) {
	Tcl_DecrRefCount(cmdv[i]);
    }

    if (cmdv != cmdArr) {
	ckfree((char *) cmdv);
    }
    return result;
#undef ALIAS_CMDV_PREALLOC
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *
 *	Is invoked when an alias command is deleted in a slave. Cleans up all
 *	storage associated with this alias.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the alias record and its entry in the alias table for the
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
AliasObjCmdDeleteProc(clientData)
    ClientData clientData;	/* The alias record for this alias. */
{
    Alias *aliasPtr;
    Target *targetPtr;
    int i;
    Tcl_Obj **objv;

    aliasPtr = (Alias *) clientData;

    Tcl_DecrRefCount(aliasPtr->token);
    objv = &aliasPtr->objPtr;
    for (i = 0; i < aliasPtr->objc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);

1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateSlave --
 *
 *	Creates a slave interpreter. The slavePath argument denotes the
 *	name of the new slave relative to the current interpreter; the
 *	slave is a direct descendant of the one-before-last component of
 *	the path, e.g. it is a descendant of the current interpreter if
 *	the slavePath argument contains only one component. Optionally makes
 *	the slave interpreter safe.
 *
 * Results:
 *	Returns the interpreter structure created, or NULL if an error
 *	occurred.
 *
 * Side effects:
 *	Creates a new interpreter and a new interpreter object command in
 *	the interpreter indicated by the slavePath argument.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateSlave(interp, slavePath, isSafe)
    Tcl_Interp *interp;		/* Interpreter to start search at. */







|
|
|
|
|
|






|
|







1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateSlave --
 *
 *	Creates a slave interpreter. The slavePath argument denotes the name
 *	of the new slave relative to the current interpreter; the slave is a
 *	direct descendant of the one-before-last component of the path,
 *	e.g. it is a descendant of the current interpreter if the slavePath
 *	argument contains only one component. Optionally makes the slave
 *	interpreter safe.
 *
 * Results:
 *	Returns the interpreter structure created, or NULL if an error
 *	occurred.
 *
 * Side effects:
 *	Creates a new interpreter and a new interpreter object command in the
 *	interpreter indicated by the slavePath argument.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateSlave(interp, slavePath, isSafe)
    Tcl_Interp *interp;		/* Interpreter to start search at. */
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
 *----------------------------------------------------------------------
 *
 * Tcl_GetSlave --
 *
 *	Finds a slave interpreter by its path name.
 *
 * Results:
 *	Returns a Tcl_Interp * for the named interpreter or NULL if not
 *	found.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
<







1850
1851
1852
1853
1854
1855
1856
1857

1858
1859
1860
1861
1862
1863
1864
 *----------------------------------------------------------------------
 *
 * Tcl_GetSlave --
 *
 *	Finds a slave interpreter by its path name.
 *
 * Results:
 *	Returns a Tcl_Interp * for the named interpreter or NULL if not found.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
Tcl_Interp *
Tcl_GetMaster(interp)
    Tcl_Interp *interp;		/* Get the master of this interpreter. */
{
    Slave *slavePtr;		/* Slave record of this interpreter. */

    if (interp == (Tcl_Interp *) NULL) {
        return NULL;
    }
    slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
    return slavePtr->masterInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInterpPath --
 *
 *	Sets the result of the asking interpreter to a proper Tcl list
 *	containing the names of interpreters between the asking and
 *	target interpreters. The target interpreter must be either the
 *	same as the asking interpreter or one of its slaves (including
 *	recursively).
 *
 * Results:
 *	TCL_OK if the target interpreter is the same as, or a descendant
 *	of, the asking interpreter; TCL_ERROR else. This way one can
 *	distinguish between the case where the asking and target interps
 *	are the same (an empty list is the result, and TCL_OK is returned)
 *	and when the target is not a descendant of the asking interpreter
 *	(in which case the Tcl result is an error message and the function
 *	returns TCL_ERROR).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInterpPath(askingInterp, targetInterp)
    Tcl_Interp *askingInterp;	/* Interpreter to start search from. */
    Tcl_Interp *targetInterp;	/* Interpreter to find. */
{
    InterpInfo *iiPtr;
    
    if (targetInterp == askingInterp) {
        return TCL_OK;
    }
    if (targetInterp == NULL) {
	return TCL_ERROR;
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
        return TCL_ERROR;
    }
    Tcl_AppendElement(askingInterp,
	    Tcl_GetHashKey(&iiPtr->master.slaveTable,
		    iiPtr->slave.slaveEntryPtr));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --
 *
 *	Helper function to find a slave interpreter given a pathname.
 *
 * Results:
 *	Returns the slave interpreter known by that name in the calling
 *	interpreter, or NULL if no interpreter known by that name exists. 
 *
 * Side effects:
 *	Assigns to the pointer variable passed in, if not NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
GetInterp(interp, pathPtr)
    Tcl_Interp *interp;		/* Interp. to start search from. */
    Tcl_Obj *pathPtr;		/* List object containing name of interp. to 
				 * be found. */
{
    Tcl_HashEntry *hPtr;	/* Search element. */
    Slave *slavePtr;		/* Interim slave record. */
    Tcl_Obj **objv;
    int objc, i;	
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */
    InterpInfo *masterInfoPtr;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }

    searchInterp = interp;
    for (i = 0; i < objc; i++) {
	masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
        hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
		Tcl_GetString(objv[i]));
        if (hPtr == NULL) {
	    searchInterp = NULL;
	    break;
	}
        slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
        searchInterp = slavePtr->slaveInterp;
        if (searchInterp == NULL) {
	    break;
	}
    }
    if (searchInterp == NULL) {
	Tcl_AppendResult(interp, "could not find interpreter \"",
                Tcl_GetString(pathPtr), "\"", (char *) NULL);
    }
    return searchInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveBgerror --
 *
 *	Helper function to set/query the background error handling
 *	command prefix of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *      When (objc == 1), slaveInterp will be set to a new background
 *	handler of objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveBgerror(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp	*slaveInterp;	/* Interp in which limit is set/queried. */
    int objc;			/* Set or Query. */
    Tcl_Obj *CONST objv[];	/* Argument strings. */
{
    if (objc) {
	int length;

	if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) 
		|| (length < 1)) {
	    Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	TclSetBgErrorHandler(interp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCreate --
 *
 *	Helper function to do the actual work of creating a slave interp
 *	and new object command. Also optionally makes the new slave
 *	interpreter "safe".
 *
 * Results:
 *	Returns the new Tcl_Interp * if successful or NULL if not. If failed,
 *	the result of the invoking interpreter contains an error message.
 *
 * Side effects:
 *	Creates a new slave interpreter and a new object command.







|











|
|
|
<


|
|
|
|
|
|
<













|

|






|

|
<
|












|










|





|










|

|



|
|
|





|









|
|





|
|














|
















|
|
|







1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917

1918
1919
1920
1921
1922
1923
1924
1925

1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950

1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
Tcl_Interp *
Tcl_GetMaster(interp)
    Tcl_Interp *interp;		/* Get the master of this interpreter. */
{
    Slave *slavePtr;		/* Slave record of this interpreter. */

    if (interp == (Tcl_Interp *) NULL) {
	return NULL;
    }
    slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
    return slavePtr->masterInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInterpPath --
 *
 *	Sets the result of the asking interpreter to a proper Tcl list
 *	containing the names of interpreters between the asking and target
 *	interpreters. The target interpreter must be either the same as the
 *	asking interpreter or one of its slaves (including recursively).

 *
 * Results:
 *	TCL_OK if the target interpreter is the same as, or a descendant of,
 *	the asking interpreter; TCL_ERROR else. This way one can distinguish
 *	between the case where the asking and target interps are the same (an
 *	empty list is the result, and TCL_OK is returned) and when the target
 *	is not a descendant of the asking interpreter (in which case the Tcl
 *	result is an error message and the function returns TCL_ERROR).

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInterpPath(askingInterp, targetInterp)
    Tcl_Interp *askingInterp;	/* Interpreter to start search from. */
    Tcl_Interp *targetInterp;	/* Interpreter to find. */
{
    InterpInfo *iiPtr;

    if (targetInterp == askingInterp) {
	return TCL_OK;
    }
    if (targetInterp == NULL) {
	return TCL_ERROR;
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
	return TCL_ERROR;
    }
    Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable,

	    iiPtr->slave.slaveEntryPtr));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --
 *
 *	Helper function to find a slave interpreter given a pathname.
 *
 * Results:
 *	Returns the slave interpreter known by that name in the calling
 *	interpreter, or NULL if no interpreter known by that name exists.
 *
 * Side effects:
 *	Assigns to the pointer variable passed in, if not NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
GetInterp(interp, pathPtr)
    Tcl_Interp *interp;		/* Interp. to start search from. */
    Tcl_Obj *pathPtr;		/* List object containing name of interp. to
				 * be found. */
{
    Tcl_HashEntry *hPtr;	/* Search element. */
    Slave *slavePtr;		/* Interim slave record. */
    Tcl_Obj **objv;
    int objc, i;
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */
    InterpInfo *masterInfoPtr;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }

    searchInterp = interp;
    for (i = 0; i < objc; i++) {
	masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
	hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
		Tcl_GetString(objv[i]));
	if (hPtr == NULL) {
	    searchInterp = NULL;
	    break;
	}
	slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
	searchInterp = slavePtr->slaveInterp;
	if (searchInterp == NULL) {
	    break;
	}
    }
    if (searchInterp == NULL) {
	Tcl_AppendResult(interp, "could not find interpreter \"",
		Tcl_GetString(pathPtr), "\"", (char *) NULL);
    }
    return searchInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveBgerror --
 *
 *	Helper function to set/query the background error handling command
 *	prefix of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	When (objc == 1), slaveInterp will be set to a new background handler
 *	of objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveBgerror(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp	*slaveInterp;	/* Interp in which limit is set/queried. */
    int objc;			/* Set or Query. */
    Tcl_Obj *CONST objv[];	/* Argument strings. */
{
    if (objc) {
	int length;

	if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length)
		|| (length < 1)) {
	    Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	TclSetBgErrorHandler(interp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCreate --
 *
 *	Helper function to do the actual work of creating a slave interp and
 *	new object command. Also optionally makes the new slave interpreter
 *	"safe".
 *
 * Results:
 *	Returns the new Tcl_Interp * if successful or NULL if not. If failed,
 *	the result of the invoking interpreter contains an error message.
 *
 * Side effects:
 *	Creates a new slave interpreter and a new object command.
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208

2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219

2220
2221
2222
2223

2224
2225
2226
2227
2228
2229

2230
2231
2232
2233


2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
    Tcl_Interp *masterInterp, *slaveInterp;
    Slave *slavePtr;
    InterpInfo *masterInfoPtr;
    Tcl_HashEntry *hPtr;
    char *path;
    int new, objc;
    Tcl_Obj **objv;
    Tcl_Obj* clockObj;
    int status;

    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }
    if (objc < 2) {
	masterInterp = interp;
	path = Tcl_GetString(pathPtr);
    } else {
	Tcl_Obj *objPtr;
	
	objPtr = Tcl_NewListObj(objc - 1, objv);
	masterInterp = GetInterp(interp, objPtr);
	Tcl_DecrRefCount(objPtr);
	if (masterInterp == NULL) {
	    return NULL;
	}
	path = Tcl_GetString(objv[objc - 1]);
    }
    if (safe == 0) {
	safe = Tcl_IsSafe(masterInterp);
    }

    masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
    hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
    if (new == 0) {
        Tcl_AppendResult(interp, "interpreter named \"", path,
		"\" already exists, cannot create", (char *) NULL);
        return NULL;
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
            SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
    
    /*
     * Inherit the recursion limit.
     */

    ((Interp *) slaveInterp)->maxNestingDepth =
	((Interp *) masterInterp)->maxNestingDepth ;

    if (safe) {
        if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
            goto error;
        }
    } else {
        if (Tcl_Init(slaveInterp) == TCL_ERROR) {
            goto error;
        }

	/*
	 * This will create the "memory" command in slave interpreters
	 * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing.
	 */

	Tcl_InitMemory(slaveInterp);
    }

    /*
     * Inherit the TIP#143 limits.
     */

    InheritLimitsFromMaster(slaveInterp, masterInterp);

    if ( safe ) {
	clockObj = Tcl_NewStringObj( "clock", -1 );


	Tcl_IncrRefCount( clockObj );
	status = AliasCreate( interp, slaveInterp, masterInterp,
			      clockObj, clockObj, 0, (Tcl_Obj *CONST *) NULL );
	Tcl_DecrRefCount( clockObj );
	if ( status != TCL_OK ) {
	    goto error2;
	}
    }
    

    return slaveInterp;

 error:
    TclTransferResult(slaveInterp, TCL_ERROR, interp);
 error2:
    Tcl_DeleteInterp(slaveInterp);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmd --
 *
 *	Command to manipulate an interpreter, e.g. to send commands to it
 *	to be evaluated. One such command exists for each slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See user documentation for details.
 *







<
<









|















|

|








|



|



>

|


|
|
|

|
|
|
>

|
|

>






>


|
|
>
>
|
|
|
|
|



<
















|
|







2076
2077
2078
2079
2080
2081
2082


2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165

2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
    Tcl_Interp *masterInterp, *slaveInterp;
    Slave *slavePtr;
    InterpInfo *masterInfoPtr;
    Tcl_HashEntry *hPtr;
    char *path;
    int new, objc;
    Tcl_Obj **objv;



    if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }
    if (objc < 2) {
	masterInterp = interp;
	path = Tcl_GetString(pathPtr);
    } else {
	Tcl_Obj *objPtr;

	objPtr = Tcl_NewListObj(objc - 1, objv);
	masterInterp = GetInterp(interp, objPtr);
	Tcl_DecrRefCount(objPtr);
	if (masterInterp == NULL) {
	    return NULL;
	}
	path = Tcl_GetString(objv[objc - 1]);
    }
    if (safe == 0) {
	safe = Tcl_IsSafe(masterInterp);
    }

    masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
    hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
    if (new == 0) {
	Tcl_AppendResult(interp, "interpreter named \"", path,
		"\" already exists, cannot create", (char *) NULL);
	return NULL;
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
	    SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);

    /*
     * Inherit the recursion limit.
     */

    ((Interp *) slaveInterp)->maxNestingDepth =
	    ((Interp *) masterInterp)->maxNestingDepth;

    if (safe) {
	if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
	    goto error;
	}
    } else {
	if (Tcl_Init(slaveInterp) == TCL_ERROR) {
	    goto error;
	}

	/*
	 * This will create the "memory" command in slave interpreters if we
	 * compiled with TCL_MEM_DEBUG, otherwise it does nothing.
	 */

	Tcl_InitMemory(slaveInterp);
    }

    /*
     * Inherit the TIP#143 limits.
     */

    InheritLimitsFromMaster(slaveInterp, masterInterp);

    if (safe) {
	Tcl_Obj* clockObj = Tcl_NewStringObj("clock", -1);
	int status;

	Tcl_IncrRefCount(clockObj);
	status = AliasCreate(interp, slaveInterp, masterInterp, clockObj,
		clockObj, 0, (Tcl_Obj *CONST *) NULL);
	Tcl_DecrRefCount(clockObj);
	if (status != TCL_OK) {
	    goto error2;
	}
    }


    return slaveInterp;

 error:
    TclTransferResult(slaveInterp, TCL_ERROR, interp);
 error2:
    Tcl_DeleteInterp(slaveInterp);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmd --
 *
 *	Command to manipulate an interpreter, e.g. to send commands to it to
 *	be evaluated. One such command exists for each slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See user documentation for details.
 *
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379

2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
	"invokehidden",	"limit",	"marktrusted",	"recursionlimit", NULL
    };
    enum options {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_EVAL,
	OPT_EXPOSE,	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,
	OPT_INVOKEHIDDEN, OPT_LIMIT,	OPT_MARKTRUSTED, OPT_RECLIMIT
    };
    
    slaveInterp = (Tcl_Interp *) clientData;
    if (slaveInterp == NULL) {
	Tcl_Panic("SlaveObjCmd: interpreter has been deleted");
    }

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
	case OPT_ALIAS: {
	    if (objc > 2) {
		if (objc == 3) {
		    return AliasDescribe(interp, slaveInterp, objv[2]);
		}
		if (Tcl_GetString(objv[3])[0] == '\0') {
		    if (objc == 4) {
			return AliasDelete(interp, slaveInterp, objv[2]);
		    }
		} else {
		    return AliasCreate(interp, slaveInterp, interp, objv[2],
			    objv[3], objc - 4, objv + 4);
		}
	    }
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "aliasName ?targetName? ?args..?");
            return TCL_ERROR;
	}
	case OPT_ALIASES: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
		return TCL_ERROR;
	    }
	    return AliasList(interp, slaveInterp);
	}
	case OPT_BGERROR: {
	    if (objc != 2 && objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
		return TCL_ERROR;
	    }
	    return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
	}
	case OPT_EVAL: {
	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
		return TCL_ERROR;
	    }
	    return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
	}
        case OPT_EXPOSE: {
	    if ((objc < 3) || (objc > 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
		return TCL_ERROR;
	    }
            return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
	}
	case OPT_HIDE: {
	    if ((objc < 3) || (objc > 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
		return TCL_ERROR;
	    }
            return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
	}
        case OPT_HIDDEN: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
            return SlaveHidden(interp, slaveInterp);
	}
        case OPT_ISSAFE: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp,
		    Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	    return TCL_OK;
	}
        case OPT_INVOKEHIDDEN: {
	    int i, index;
	    CONST char *namespaceName;
	    static CONST char *hiddenOptions[] = {
		"-global",	"-namespace",	"--",		NULL

	    };
	    enum hiddenOption {
		OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	    };

	    namespaceName = NULL;
	    for (i = 2; i < objc; i++) {
		if (Tcl_GetString(objv[i])[0] != '-') {
		    break;
		}
		if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
			"option", 0, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (index == OPT_GLOBAL) {
		    namespaceName = "::";
		} else {
		    if (index == OPT_NAMESPACE) {
			if (++i == objc) { /* There must be more arguments. */
		            break;
			} else {
		            namespaceName = Tcl_GetString(objv[i]);
			}
		    } else {
			i++;
			break;
		    }
		}
	    }
	    if (objc - i < 1) {
		Tcl_WrongNumArgs(interp, 2, objv,
			"?-namespace ns? ?-global? ?--? cmd ?arg ..?");
		return TCL_ERROR;
	    }
	    return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
		    objc - i, objv + i);
	}
	case OPT_LIMIT: {
	    static CONST char *limitTypes[] = {
		"commands", "time", NULL
	    };
	    enum LimitTypes {
		LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
	    };
	    int limitType;

	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?");
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type",
		    0, &limitType) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum LimitTypes) limitType) {
	    case LIMIT_TYPE_COMMANDS:
		return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
	    case LIMIT_TYPE_TIME:
		return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
	    }
	}
	case OPT_MARKTRUSTED: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
            return SlaveMarkTrusted(interp, slaveInterp);
	}
	case OPT_RECLIMIT: {
	    if (objc != 2 && objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
		return TCL_ERROR;
	    }
	    return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
	}
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmdDeleteProc --
 *
 *	Invoked when an object command for a slave interpreter is deleted;
 *	cleans up all state associated with the slave interpreter and destroys
 *	the slave interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up all state associated with the slave interpreter and
 *	destroys the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
SlaveObjCmdDeleteProc(clientData)
    ClientData clientData;		/* The SlaveRecord for the command. */







|






|
|







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
<
|
<
|
|
|
|
|
>
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
<


















|
|







2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243

2244

2245
2246
2247
2248
2249
2250

2251
2252
2253
2254
2255
2256

2257
2258
2259
2260
2261
2262

2263
2264
2265
2266
2267
2268

2269
2270
2271
2272
2273
2274

2275
2276
2277
2278
2279
2280

2281
2282
2283
2284
2285
2286

2287

2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309

2310
2311
2312
2313
2314
2315
2316
2317
2318

2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358

2359
2360
2361
2362
2363
2364

2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
	"invokehidden",	"limit",	"marktrusted",	"recursionlimit", NULL
    };
    enum options {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_EVAL,
	OPT_EXPOSE,	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,
	OPT_INVOKEHIDDEN, OPT_LIMIT,	OPT_MARKTRUSTED, OPT_RECLIMIT
    };

    slaveInterp = (Tcl_Interp *) clientData;
    if (slaveInterp == NULL) {
	Tcl_Panic("SlaveObjCmd: interpreter has been deleted");
    }

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
    case OPT_ALIAS:
	if (objc > 2) {
	    if (objc == 3) {
		return AliasDescribe(interp, slaveInterp, objv[2]);
	    }
	    if (Tcl_GetString(objv[3])[0] == '\0') {
		if (objc == 4) {
		    return AliasDelete(interp, slaveInterp, objv[2]);
		}
	    } else {
		return AliasCreate(interp, slaveInterp, interp, objv[2],
			objv[3], objc - 4, objv + 4);
	    }
	}
	Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?");

	return TCL_ERROR;

    case OPT_ALIASES:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
	    return TCL_ERROR;
	}
	return AliasList(interp, slaveInterp);

    case OPT_BGERROR:
	if (objc != 2 && objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
	    return TCL_ERROR;
	}
	return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);

    case OPT_EVAL:
	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
	    return TCL_ERROR;
	}
	return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);

    case OPT_EXPOSE:
	if ((objc < 3) || (objc > 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
	    return TCL_ERROR;
	}
	return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);

    case OPT_HIDE:
	if ((objc < 3) || (objc > 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
	    return TCL_ERROR;
	}
	return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);

    case OPT_HIDDEN:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return SlaveHidden(interp, slaveInterp);

    case OPT_ISSAFE:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));

	return TCL_OK;

    case OPT_INVOKEHIDDEN: {
	int i, index;
	CONST char *namespaceName;
	static CONST char *hiddenOptions[] = {
	    "-global",	"-namespace",	"--",
	    NULL
	};
	enum hiddenOption {
	    OPT_GLOBAL,	OPT_NAMESPACE,	OPT_LAST
	};

	namespaceName = NULL;
	for (i = 2; i < objc; i++) {
	    if (Tcl_GetString(objv[i])[0] != '-') {
		break;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option",
		    0, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (index == OPT_GLOBAL) {
		namespaceName = "::";

	    } else if (index == OPT_NAMESPACE) {
		if (++i == objc) { /* There must be more arguments. */
		    break;
		} else {
		    namespaceName = Tcl_GetString(objv[i]);
		}
	    } else {
		i++;
		break;

	    }
	}
	if (objc - i < 1) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "?-namespace ns? ?-global? ?--? cmd ?arg ..?");
	    return TCL_ERROR;
	}
	return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
		objc - i, objv + i);
    }
    case OPT_LIMIT: {
	static CONST char *limitTypes[] = {
	    "commands", "time", NULL
	};
	enum LimitTypes {
	    LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
	};
	int limitType;

	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?");
	    return TCL_ERROR;
	}
	if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
		&limitType) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum LimitTypes) limitType) {
	case LIMIT_TYPE_COMMANDS:
	    return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
	case LIMIT_TYPE_TIME:
	    return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
	}
    }
    case OPT_MARKTRUSTED:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return SlaveMarkTrusted(interp, slaveInterp);

    case OPT_RECLIMIT:
	if (objc != 2 && objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
	    return TCL_ERROR;
	}
	return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);

    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmdDeleteProc --
 *
 *	Invoked when an object command for a slave interpreter is deleted;
 *	cleans up all state associated with the slave interpreter and destroys
 *	the slave interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up all state associated with the slave interpreter and destroys
 *	the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
SlaveObjCmdDeleteProc(clientData)
    ClientData clientData;		/* The SlaveRecord for the command. */
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
    /*
     * Unlink the slave from its master interpreter.
     */

    Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);

    /*
     * Set to NULL so that when the InterpInfo is cleaned up in the slave
     * it does not try to delete the command causing all sorts of grief.
     * See SlaveRecordDeleteProc().
     */

    slavePtr->interpCmd = NULL;

    if (slavePtr->slaveInterp != NULL) {
	Tcl_DeleteInterp(slavePtr->slaveInterp);
    }







|
|
|







2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
    /*
     * Unlink the slave from its master interpreter.
     */

    Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);

    /*
     * Set to NULL so that when the InterpInfo is cleaned up in the slave it
     * does not try to delete the command causing all sorts of grief.  See
     * SlaveRecordDeleteProc().
     */

    slavePtr->interpCmd = NULL;

    if (slavePtr->slaveInterp != NULL) {
	Tcl_DeleteInterp(slavePtr->slaveInterp);
    }
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
    Tcl_Interp *slaveInterp;	/* The slave interpreter in which command
				 * will be evaluated. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result;
    Tcl_Obj *objPtr;
    
    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (objc == 1) {
	result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
    } else {
	objPtr = Tcl_ConcatObj(objc, objv);







|







2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
    Tcl_Interp *slaveInterp;	/* The slave interpreter in which command
				 * will be evaluated. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result;
    Tcl_Obj *objPtr;

    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (objc == 1) {
	result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
    } else {
	objPtr = Tcl_ConcatObj(objc, objv);
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
 *
 *	Helper function to expose a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call scripts in the slave will be able to invoke
 *	the newly exposed command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveExpose(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp	*slaveInterp;	/* Interp in which command will be exposed. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings. */
{
    char *name;
    
    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot expose commands",
		-1));
	return TCL_ERROR;
    }








|
|












|







2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
 *
 *	Helper function to expose a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call scripts in the slave will be able to invoke the newly
 *	exposed command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveExpose(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp	*slaveInterp;	/* Interp in which command will be exposed. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings. */
{
    char *name;

    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot expose commands",
		-1));
	return TCL_ERROR;
    }

2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
 *
 *	Helper function to set/query the Recursion limit of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *      When (objc == 1), slaveInterp will be set to a new recursion
 *	limit of objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveRecursionLimit(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */







|
|







2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
 *
 *	Helper function to set/query the Recursion limit of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	When (objc == 1), slaveInterp will be set to a new recursion limit of
 *	objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveRecursionLimit(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
	iPtr = (Interp *) slaveInterp;
	if (interp == slaveInterp && iPtr->numLevels > limit) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "falling back due to new recursion limit", -1));
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, objv[0]);
        return TCL_OK;
    } else {
	limit = Tcl_SetRecursionLimit(slaveInterp, 0);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
        return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveHide --
 *
 *	Helper function to hide a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call scripts in the slave will no longer be able
 *	to invoke the named command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveHide(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp	*slaveInterp;	/* Interp in which command will be exposed. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings. */
{
    char *name;
    
    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot hide commands",
		-1));
	return TCL_ERROR;
    }

    name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
    if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
	    name) != TCL_OK) {
	TclTransferResult(slaveInterp, TCL_ERROR, interp);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*







|



|














|
|












|








|
<







2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596

2597
2598
2599
2600
2601
2602
2603
	iPtr = (Interp *) slaveInterp;
	if (interp == slaveInterp && iPtr->numLevels > limit) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "falling back due to new recursion limit", -1));
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, objv[0]);
	return TCL_OK;
    } else {
	limit = Tcl_SetRecursionLimit(slaveInterp, 0);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveHide --
 *
 *	Helper function to hide a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call scripts in the slave will no longer be able to invoke
 *	the named command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveHide(interp, slaveInterp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp	*slaveInterp;	/* Interp in which command will be exposed. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings. */
{
    char *name;

    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot hide commands",
		-1));
	return TCL_ERROR;
    }

    name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
    if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), name) != TCL_OK) {

	TclTransferResult(slaveInterp, TCL_ERROR, interp);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
    Tcl_Interp *interp;		/* Interp for data return. */
    Tcl_Interp *slaveInterp;	/* Interp whose hidden commands to query. */
{
    Tcl_Obj *listObjPtr = Tcl_NewObj();	/* Local object pointer. */
    Tcl_HashTable *hTblPtr;		/* For local searches. */
    Tcl_HashEntry *hPtr;		/* For local searches. */
    Tcl_HashSearch hSearch;		/* For local searches. */
    
    hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
    if (hTblPtr != (Tcl_HashTable *) NULL) {
	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
	     hPtr != (Tcl_HashEntry *) NULL;
	     hPtr = Tcl_NextHashEntry(&hSearch)) {

	    Tcl_ListObjAppendElement(NULL, listObjPtr,
		    Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    return TCL_OK;
}







|



|
|
<







2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634

2635
2636
2637
2638
2639
2640
2641
    Tcl_Interp *interp;		/* Interp for data return. */
    Tcl_Interp *slaveInterp;	/* Interp whose hidden commands to query. */
{
    Tcl_Obj *listObjPtr = Tcl_NewObj();	/* Local object pointer. */
    Tcl_HashTable *hTblPtr;		/* For local searches. */
    Tcl_HashEntry *hPtr;		/* For local searches. */
    Tcl_HashSearch hSearch;		/* For local searches. */

    hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
    if (hTblPtr != (Tcl_HashTable *) NULL) {
	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
		hPtr != (Tcl_HashEntry *) NULL;
		hPtr = Tcl_NextHashEntry(&hSearch)) {

	    Tcl_ListObjAppendElement(NULL, listObjPtr,
		    Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    return TCL_OK;
}
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
 *
 *----------------------------------------------------------------------
 */

static int
SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp *slaveInterp;	/* The slave interpreter in which command
				 * will be invoked. */
    CONST char *namespaceName;	/* The namespace to use, if any. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result;
    
    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"not allowed to invoke hidden commands from safe interpreter",
		-1));
	return TCL_ERROR;
    }

    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);
    
    if (namespaceName == NULL) {
        result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
    } else {
	Namespace *nsPtr, *dummy1, *dummy2;
	CONST char *tail;

	result = TclGetNamespaceForQualName(slaveInterp, namespaceName,
		(Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY 
		| TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr,
		&dummy1, &dummy2, &tail);
	if (result == TCL_OK) {
	    result = TclObjInvokeNamespace(slaveInterp, objc, objv,
		    (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN);
	}
    }

    TclTransferResult(slaveInterp, result, interp);

    Tcl_Release((ClientData) slaveInterp);
    return result;        
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveMarkTrusted --
 *
 *	Helper function to mark a slave interpreter as trusted (unsafe).
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call the hard-wired security checks in the core no
 *	longer prevent the slave from performing certain operations.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveMarkTrusted(interp, slaveInterp)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp *slaveInterp;	/* The slave interpreter which will be
				 * marked trusted. */
{
    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot mark trusted",
		-1));
	return TCL_ERROR;
    }







|
|





|









|

|





|











|













|
|







|
|







2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
 *
 *----------------------------------------------------------------------
 */

static int
SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp *slaveInterp;	/* The slave interpreter in which command will
				 * be invoked. */
    CONST char *namespaceName;	/* The namespace to use, if any. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int result;

    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"not allowed to invoke hidden commands from safe interpreter",
		-1));
	return TCL_ERROR;
    }

    Tcl_Preserve((ClientData) slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (namespaceName == NULL) {
	result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
    } else {
	Namespace *nsPtr, *dummy1, *dummy2;
	CONST char *tail;

	result = TclGetNamespaceForQualName(slaveInterp, namespaceName,
		(Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY
		| TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr,
		&dummy1, &dummy2, &tail);
	if (result == TCL_OK) {
	    result = TclObjInvokeNamespace(slaveInterp, objc, objv,
		    (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN);
	}
    }

    TclTransferResult(slaveInterp, result, interp);

    Tcl_Release((ClientData) slaveInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveMarkTrusted --
 *
 *	Helper function to mark a slave interpreter as trusted (unsafe).
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call the hard-wired security checks in the core no longer
 *	prevent the slave from performing certain operations.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveMarkTrusted(interp, slaveInterp)
    Tcl_Interp *interp;		/* Interp for error return. */
    Tcl_Interp *slaveInterp;	/* The slave interpreter which will be marked
				 * trusted. */
{
    if (Tcl_IsSafe(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"permission denied: safe interpreter cannot mark trusted",
		-1));
	return TCL_ERROR;
    }
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
int
Tcl_IsSafe(interp)
    Tcl_Interp *interp;		/* Is this interpreter "safe" ? */
{
    Interp *iPtr;

    if (interp == (Tcl_Interp *) NULL) {
        return 0;
    }
    iPtr = (Interp *) interp;

    return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeSafe --
 *
 *	Makes its argument interpreter contain only functionality that is
 *	defined to be part of Safe Tcl. Unsafe commands are hidden, the
 *	env array is unset, and the standard channels are removed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Hides commands in its argument interpreter, and removes settings
 *	and channels.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MakeSafe(interp)
    Tcl_Interp *interp;		/* Interpreter to be made safe. */
{
    Tcl_Channel chan;				/* Channel to remove from
                                                 * safe interpreter. */
    Interp *iPtr = (Interp *) interp;

    TclHideUnsafeCommands(interp);
    
    iPtr->flags |= SAFE_INTERP;

    /*
     *  Unsetting variables : (which should not have been set 
     *  in the first place, but...)
     */

    /*
     * No env array in a safe slave.
     */

    Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);

    /* 
     * Remove unsafe parts of tcl_platform
     */

    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);

    /*
     * Unset path informations variables
     * (the only one remaining is [info nameofexecutable])
     */

    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
    
    /*
     * Remove the standard channels from the interpreter; safe interpreters
     * do not ordinarily have access to stdin, stdout and stderr.
     *
     * NOTE: These channels are not added to the interpreter by the
     * Tcl_CreateInterp call, but may be added later, by another I/O
     * operation. We want to ensure that the interpreter does not have
     * these channels even if it is being made safe after being used for
     * some time..
     */

    chan = Tcl_GetStdChannel(TCL_STDIN);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDOUT);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDERR);
    if (chan != (Tcl_Channel) NULL) {
        Tcl_UnregisterChannel(interp, chan);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitExceeded --
 *
 *	Tests whether any limit has been exceededin the given
 *	interpreter (i.e. whether the interpreter is currently unable
 *	to process further scripts).
 *
 * Results:
 *	A boolean value.
 *
 * Side effects:
 *	None.
 *







|












|
|





|
|








|
<



|



|
|








|









|
|





|

|
|



|
|
<




|



|



|










|
|
|







2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788

2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831

2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
int
Tcl_IsSafe(interp)
    Tcl_Interp *interp;		/* Is this interpreter "safe" ? */
{
    Interp *iPtr;

    if (interp == (Tcl_Interp *) NULL) {
	return 0;
    }
    iPtr = (Interp *) interp;

    return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeSafe --
 *
 *	Makes its argument interpreter contain only functionality that is
 *	defined to be part of Safe Tcl. Unsafe commands are hidden, the env
 *	array is unset, and the standard channels are removed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Hides commands in its argument interpreter, and removes settings and
 *	channels.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MakeSafe(interp)
    Tcl_Interp *interp;		/* Interpreter to be made safe. */
{
    Tcl_Channel chan;		/* Channel to remove from safe interpreter. */

    Interp *iPtr = (Interp *) interp;

    TclHideUnsafeCommands(interp);

    iPtr->flags |= SAFE_INTERP;

    /*
     * Unsetting variables : (which should not have been set in the first
     * place, but...)
     */

    /*
     * No env array in a safe slave.
     */

    Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);

    /*
     * Remove unsafe parts of tcl_platform
     */

    Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);

    /*
     * Unset path informations variables (the only one remaining is [info
     * nameofexecutable])
     */

    Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);

    /*
     * Remove the standard channels from the interpreter; safe interpreters do
     * not ordinarily have access to stdin, stdout and stderr.
     *
     * NOTE: These channels are not added to the interpreter by the
     * Tcl_CreateInterp call, but may be added later, by another I/O
     * operation. We want to ensure that the interpreter does not have these
     * channels even if it is being made safe after being used for some time..

     */

    chan = Tcl_GetStdChannel(TCL_STDIN);
    if (chan != (Tcl_Channel) NULL) {
	Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDOUT);
    if (chan != (Tcl_Channel) NULL) {
	Tcl_UnregisterChannel(interp, chan);
    }
    chan = Tcl_GetStdChannel(TCL_STDERR);
    if (chan != (Tcl_Channel) NULL) {
	Tcl_UnregisterChannel(interp, chan);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitExceeded --
 *
 *	Tests whether any limit has been exceeded in the given interpreter
 *	(i.e. whether the interpreter is currently unable to process further
 *	scripts).
 *
 * Results:
 *	A boolean value.
 *
 * Side effects:
 *	None.
 *
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitReady --
 *
 *	Find out whether any limit has been set on the interpreter,
 *	and if so check whether the granularity of that limit is such
 *	that the full limit check should be carried out.
 *
 * Results:
 *	A boolean value that indicates whether to call Tcl_LimitCheck.
 *
 * Side effects:
 *	Increments the limit granularity counter.
 *







|
|
|







2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitReady --
 *
 *	Find out whether any limit has been set on the interpreter, and if so
 *	check whether the granularity of that limit is such that the full
 *	limit check should be carried out.
 *
 * Results:
 *	A boolean value that indicates whether to call Tcl_LimitCheck.
 *
 * Side effects:
 *	Increments the limit granularity counter.
 *
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
    register Interp *iPtr = (Interp *) interp;

    if (iPtr->limit.active != 0) {
	register int ticker = ++iPtr->limit.granularityTicker;

	if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
		((iPtr->limit.cmdGranularity == 1) ||
			(ticker % iPtr->limit.cmdGranularity == 0))) {
	    return 1;
	}
	if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
		((iPtr->limit.timeGranularity == 1) ||
			(ticker % iPtr->limit.timeGranularity == 0))) {
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitCheck --
 *
 *	Check all currently set limits in the interpreter (where
 *	permitted by granularity).  If a limit is exceeded, call its
 *	callbacks and, if the limit is still exceeded after the
 *	callbacks have run, make the interpreter generate an error
 *	that cannot be caught within the limited interpreter.
 *
 * Results:
 *	A Tcl result value (TCL_OK if no limit is exceeded, and
 *	TCL_ERROR if a limit has been exceeded).
 *
 * Side effects:
 *	May invoke system calls.  May invoke other interpreters.  May
 *	be reentrant.  May put the interpreter into a state where it
 *	can no longer execute commands without outside intervention.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitCheck(interp)
    Tcl_Interp *interp;







|




|











|
|
|
|
|


|
|


|
|
|







2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
    register Interp *iPtr = (Interp *) interp;

    if (iPtr->limit.active != 0) {
	register int ticker = ++iPtr->limit.granularityTicker;

	if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
		((iPtr->limit.cmdGranularity == 1) ||
		    (ticker % iPtr->limit.cmdGranularity == 0))) {
	    return 1;
	}
	if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
		((iPtr->limit.timeGranularity == 1) ||
		    (ticker % iPtr->limit.timeGranularity == 0))) {
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitCheck --
 *
 *	Check all currently set limits in the interpreter (where permitted by
 *	granularity).  If a limit is exceeded, call its callbacks and, if the
 *	limit is still exceeded after the callbacks have run, make the
 *	interpreter generate an error that cannot be caught within the limited
 *	interpreter.
 *
 * Results:
 *	A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a
 *	limit has been exceeded).
 *
 * Side effects:
 *	May invoke system calls. May invoke other interpreters. May be
 *	reentrant. May put the interpreter into a state where it can no longer
 *	execute commands without outside intervention.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LimitCheck(interp)
    Tcl_Interp *interp;
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
	    return TCL_ERROR;
	}
	Tcl_Release(interp);
    }

    if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
	    ((iPtr->limit.timeGranularity == 1) ||
		    (ticker % iPtr->limit.timeGranularity == 0))) {
	Tcl_Time now;

	Tcl_GetTime(&now);
	if (iPtr->limit.time.sec < now.sec ||
		(iPtr->limit.time.sec == now.sec &&
		iPtr->limit.time.usec < now.usec)) {
	    iPtr->limit.exceeded |= TCL_LIMIT_TIME;
	    Tcl_Preserve(interp);
	    RunLimitHandlers(iPtr->limit.timeHandlers, interp);
	    if (iPtr->limit.time.sec >= now.sec ||
		    (iPtr->limit.time.sec == now.sec &&
		    iPtr->limit.time.usec >= now.usec)) {
		iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
	    } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "time limit exceeded", NULL);
		Tcl_Release(interp);







|









|







2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
	    return TCL_ERROR;
	}
	Tcl_Release(interp);
    }

    if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
	    ((iPtr->limit.timeGranularity == 1) ||
		(ticker % iPtr->limit.timeGranularity == 0))) {
	Tcl_Time now;

	Tcl_GetTime(&now);
	if (iPtr->limit.time.sec < now.sec ||
		(iPtr->limit.time.sec == now.sec &&
		iPtr->limit.time.usec < now.usec)) {
	    iPtr->limit.exceeded |= TCL_LIMIT_TIME;
	    Tcl_Preserve(interp);
	    RunLimitHandlers(iPtr->limit.timeHandlers, interp);
	    if (iPtr->limit.time.sec > now.sec ||
		    (iPtr->limit.time.sec == now.sec &&
		    iPtr->limit.time.usec >= now.usec)) {
		iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
	    } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "time limit exceeded", NULL);
		Tcl_Release(interp);
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122

3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151

3152
3153
3154
3155
3156
3157
3158
}

/*
 *----------------------------------------------------------------------
 *
 * RunLimitHandlers --
 *
 *	Invoke all the limit handlers in a list (for a particular
 *	limit).  Note that no particular limit handler callback will
 *	be invoked reentrantly.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the limit handlers.
 *
 *----------------------------------------------------------------------
 */

static void
RunLimitHandlers(handlerPtr, interp)
    LimitHandler *handlerPtr;
    Tcl_Interp *interp;
{
    LimitHandler *nextPtr;
    for (; handlerPtr!=NULL ; handlerPtr=nextPtr) {
	if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) {
	    /*
	     * Reentrant call or something seriously strange in the
	     * delete code.
	     */

	    nextPtr = handlerPtr->nextPtr;
	    continue;
	}

	/*
	 * Set the ACTIVE flag while running the limit handler itself
	 * so we cannot reentrantly call this handler and know to use
	 * the alternate method of deletion if necessary.
	 */

	handlerPtr->flags |= LIMIT_HANDLER_ACTIVE;
	(handlerPtr->handlerProc)(handlerPtr->clientData, interp);
	handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE;

	/*
	 * Rediscover this value; it might have changed during the
	 * processing of a limit handler.  We have to record it here
	 * because we might delete the structure below, and reading a
	 * value out of a deleted structure is unsafe (even if
	 * actually legal with some malloc()/free() implementations.)
	 */

	nextPtr = handlerPtr->nextPtr;

	/*
	 * If we deleted the current handler while we were executing
	 * it, we will have spliced it out of the list and set the
	 * LIMIT_HANDLER_DELETED flag.
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }







|
|
|



















|
|

>





|
|
|







|
|
|
|
|





|
|


>







2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
}

/*
 *----------------------------------------------------------------------
 *
 * RunLimitHandlers --
 *
 *	Invoke all the limit handlers in a list (for a particular limit).
 *	Note that no particular limit handler callback will be invoked
 *	reentrantly.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the limit handlers.
 *
 *----------------------------------------------------------------------
 */

static void
RunLimitHandlers(handlerPtr, interp)
    LimitHandler *handlerPtr;
    Tcl_Interp *interp;
{
    LimitHandler *nextPtr;
    for (; handlerPtr!=NULL ; handlerPtr=nextPtr) {
	if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) {
	    /*
	     * Reentrant call or something seriously strange in the delete
	     * code.
	     */

	    nextPtr = handlerPtr->nextPtr;
	    continue;
	}

	/*
	 * Set the ACTIVE flag while running the limit handler itself so we
	 * cannot reentrantly call this handler and know to use the alternate
	 * method of deletion if necessary.
	 */

	handlerPtr->flags |= LIMIT_HANDLER_ACTIVE;
	(handlerPtr->handlerProc)(handlerPtr->clientData, interp);
	handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE;

	/*
	 * Rediscover this value; it might have changed during the processing
	 * of a limit handler.  We have to record it here because we might
	 * delete the structure below, and reading a value out of a deleted
	 * structure is unsafe (even if actually legal with some
	 * malloc()/free() implementations.)
	 */

	nextPtr = handlerPtr->nextPtr;

	/*
	 * If we deleted the current handler while we were executing it, we
	 * will have spliced it out of the list and set the
	 * LIMIT_HANDLER_DELETED flag.
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
 *
 *	Remove a callback handler for a particular resource limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The handler is spliced out of the internal linked list for the
 *	limit, and if not currently being invoked, deleted.  Otherwise
 *	it is just marked for deletion and removed when the limit
 *	handler has finished executing.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData)
    Tcl_Interp *interp;







|
|
|
|







3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
 *
 *	Remove a callback handler for a particular resource limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The handler is spliced out of the internal linked list for the limit,
 *	and if not currently being invoked, deleted.  Otherwise it is just
 *	marked for deletion and removed when the limit handler has finished
 *	executing.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData)
    Tcl_Interp *interp;
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
    for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) {
	if ((handlerPtr->handlerProc != handlerProc) ||
		(handlerPtr->clientData != clientData)) {
	    continue;
	}

	/*
	 * We've found the handler to delete; mark it as doomed if not
	 * already so marked (which shouldn't actually happen).
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    return;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;








|
|







3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
    for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) {
	if ((handlerPtr->handlerProc != handlerProc) ||
		(handlerPtr->clientData != clientData)) {
	    continue;
	}

	/*
	 * We've found the handler to delete; mark it as doomed if not already
	 * so marked (which shouldn't actually happen).
	 */

	if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
	    return;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;

3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
	    handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr;
	}
	if (handlerPtr->nextPtr != NULL) {
	    handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr;
	}

	/*
	 * If nothing is currently executing the handler, delete its
	 * client data and the overall handler structure now.
	 * Otherwise it will all go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
	return;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclLimitRemoveAllHandlers --
 *
 *	Remove all limit callback handlers for an interpreter.  This
 *	is invoked as part of deleting the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Limit handlers are deleted or marked for deletion (as with
 *	Tcl_LimitRemoveHandler).







|
|
|

















|
|







3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
	    handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr;
	}
	if (handlerPtr->nextPtr != NULL) {
	    handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr;
	}

	/*
	 * If nothing is currently executing the handler, delete its client
	 * data and the overall handler structure now.  Otherwise it will all
	 * go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
	return;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclLimitRemoveAllHandlers --
 *
 *	Remove all limit callback handlers for an interpreter. This is invoked
 *	as part of deleting the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Limit handlers are deleted or marked for deletion (as with
 *	Tcl_LimitRemoveHandler).
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
	    continue;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;
	handlerPtr->prevPtr = NULL;
	handlerPtr->nextPtr = NULL;

	/*
	 * If nothing is currently executing the handler, delete its
	 * client data and the overall handler structure now.
	 * Otherwise it will all go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);







|
|
|







3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
	    continue;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;
	handlerPtr->prevPtr = NULL;
	handlerPtr->nextPtr = NULL;

	/*
	 * If nothing is currently executing the handler, delete its client
	 * data and the overall handler structure now.  Otherwise it will all
	 * go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417










3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
	    continue;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;
	handlerPtr->prevPtr = NULL;
	handlerPtr->nextPtr = NULL;

	/*
	 * If nothing is currently executing the handler, delete its
	 * client data and the overall handler structure now.
	 * Otherwise it will all go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }










}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeEnabled --
 *
 *	Check whether a particular limit has been enabled for an
 *	interpreter.
 *
 * Results:
 *	A boolean value.
 *
 * Side effects:
 *	None.
 *







|
|
|









>
>
>
>
>
>
>
>
>
>







|
<







3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343

3344
3345
3346
3347
3348
3349
3350
	    continue;
	}
	handlerPtr->flags |= LIMIT_HANDLER_DELETED;
	handlerPtr->prevPtr = NULL;
	handlerPtr->nextPtr = NULL;

	/*
	 * If nothing is currently executing the handler, delete its client
	 * data and the overall handler structure now.  Otherwise it will all
	 * go away when the handler returns.
	 */

	if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
	    if (handlerPtr->deleteProc != NULL) {
		(handlerPtr->deleteProc)(handlerPtr->clientData);
	    }
	    ckfree((char *) handlerPtr);
	}
    }

    /*
     * Delete the timer callback that is used to trap limits that occur in
     * [vwait]s...
     */

    if (iPtr->limit.timeEvent != NULL) {
	Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
	iPtr->limit.timeEvent = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeEnabled --
 *
 *	Check whether a particular limit has been enabled for an interpreter.

 *
 * Results:
 *	A boolean value.
 *
 * Side effects:
 *	None.
 *
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeExceeded --
 *
 *	Check whether a particular limit has been exceeded for an
 *	interpreter.
 *
 * Results:
 *	A boolean value (note that Tcl_LimitExceeded will always
 *	return non-zero when this function returns non-zero).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
<


|
|







3362
3363
3364
3365
3366
3367
3368
3369

3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitTypeExceeded --
 *
 *	Check whether a particular limit has been exceeded for an interpreter.

 *
 * Results:
 *	A boolean value (note that Tcl_LimitExceeded will always return
 *	non-zero when this function returns non-zero).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
 *
 *	Enable a particular limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The limit is turned on and will be checked in future at an
 *	interval determined by the frequency of calling of
 *	Tcl_LimitReady and the granularity of the limit in question.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitTypeSet(interp, type)
    Tcl_Interp *interp;







|
|
|







3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
 *
 *	Enable a particular limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The limit is turned on and will be checked in future at an interval
 *	determined by the frequency of calling of Tcl_LimitReady and the
 *	granularity of the limit in question.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitTypeSet(interp, type)
    Tcl_Interp *interp;
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
 *
 *	Disable a particular limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The limit is disabled.  If the limit was exceeded when this
 *	function was called, the limit will no longer be exceeded
 *	afterwards and the interpreter will be free to execute further
 *	scripts (assuming it isn't also deleted, of course).
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitTypeReset(interp, type)
    Tcl_Interp *interp;







|
|
|
|







3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
 *
 *	Disable a particular limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The limit is disabled.  If the limit was exceeded when this function
 *	was called, the limit will no longer be exceeded afterwards and the
 *	interpreter will be free to execute further scripts (assuming it isn't
 *	also deleted, of course).
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitTypeReset(interp, type)
    Tcl_Interp *interp;
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
 *
 *	Set the command limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Also resets whether the command limit was exceeded.  This
 *	might permit a small amount of further execution in the
 *	interpreter even if the limit itself is theoretically
 *	exceeded.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetCommands(interp, commandLimit)
    Tcl_Interp *interp;
    int commandLimit;
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.cmdCount = commandLimit;
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetCommands --
 *
 *	Get the number of commands that may be executed in the
 *	interpreter before the command-limit is reached.
 *
 * Results:
 *	An upper bound on the number of commands.
 *
 * Side effects:
 *	None.
 *







|
|
|
<




















|
|







3453
3454
3455
3456
3457
3458
3459
3460
3461
3462

3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
 *
 *	Set the command limit for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Also resets whether the command limit was exceeded.  This might permit
 *	a small amount of further execution in the interpreter even if the
 *	limit itself is theoretically exceeded.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetCommands(interp, commandLimit)
    Tcl_Interp *interp;
    int commandLimit;
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.cmdCount = commandLimit;
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetCommands --
 *
 *	Get the number of commands that may be executed in the interpreter
 *	before the command-limit is reached.
 *
 * Results:
 *	An upper bound on the number of commands.
 *
 * Side effects:
 *	None.
 *
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613

3614
3615











3616
3617

































3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetTime --
 *
 *	Set the time limit for an interpreter by copying it from the
 *	value pointed to by the timeLimitPtr argument.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Also resets whether the time limit was exceeded.  This might
 *	permit a small amount of further execution in the interpreter
 *	even if the limit itself is theoretically exceeded.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetTime(interp, timeLimitPtr)
    Tcl_Interp *interp;
    Tcl_Time *timeLimitPtr;
{
    Interp *iPtr = (Interp *) interp;


    memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time));











    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}


































/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetTime --
 *
 *	Get the current time limit.
 *
 * Results:
 *	The time limit (by it being copied into the variable pointed
 *	to by the timeLimitPtr).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|





|
|
|










>


>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
|







3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetTime --
 *
 *	Set the time limit for an interpreter by copying it from the value
 *	pointed to by the timeLimitPtr argument.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Also resets whether the time limit was exceeded.  This might permit a
 *	small amount of further execution in the interpreter even if the limit
 *	itself is theoretically exceeded.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetTime(interp, timeLimitPtr)
    Tcl_Interp *interp;
    Tcl_Time *timeLimitPtr;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Time nextMoment;

    memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time));
    if (iPtr->limit.timeEvent != NULL) {
	Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
    }
    nextMoment.sec = timeLimitPtr->sec;
    nextMoment.usec = timeLimitPtr->usec+10;
    if (nextMoment.usec >= 1000000) {
	nextMoment.sec++;
	nextMoment.usec -= 1000000;
    }
    iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment,
	    TimeLimitCallback, (ClientData) interp);
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}

/*
 *----------------------------------------------------------------------
 *
 * TimeLimitCallback --
 *
 *	Callback that allows time limits to be enforced even when doing a
 *	blocking wait for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May put the interpreter into a state where it can no longer execute
 *	commands. May make callbacks into other interpreters.
 *
 *----------------------------------------------------------------------
 */

static void
TimeLimitCallback(clientData)
    ClientData clientData;
{
    Tcl_Interp *interp = (Tcl_Interp *) clientData;

    Tcl_Preserve((ClientData) interp);
    ((Interp *)interp)->limit.timeEvent = NULL;
    if (Tcl_LimitCheck(interp) != TCL_OK) {
	Tcl_AddErrorInfo(interp, "\n    (while waiting for event)");
	Tcl_BackgroundError(interp);
    }
    Tcl_Release((ClientData) interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitGetTime --
 *
 *	Get the current time limit.
 *
 * Results:
 *	The time limit (by it being copied into the variable pointed to by the
 *	timeLimitPtr).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetGranularity --
 *
 *	Set the granularity divisor (which must be positive) for a
 *	particular limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The granularity is updated.
 *







|
|







3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitSetGranularity --
 *
 *	Set the granularity divisor (which must be positive) for a particular
 *	limit.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The granularity is updated.
 *
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
    case TCL_LIMIT_COMMANDS:
	return iPtr->limit.cmdGranularity;
    case TCL_LIMIT_TIME:
	return iPtr->limit.timeGranularity;
    }
    Tcl_Panic("unknown type of resource limit");
    return -1; /* NOT REACHED */
}    

/*
 *----------------------------------------------------------------------
 *
 * DeleteScriptLimitCallback --
 *
 *	Callback for when a script limit (a limit callback implemented
 *	as a Tcl script in a master interpreter, as set up from Tcl)
 *	is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference to the script callback from the controlling
 *	interpreter is removed.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScriptLimitCallback(clientData)
    ClientData clientData;







|






|
|
<





|
|







3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684

3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
    case TCL_LIMIT_COMMANDS:
	return iPtr->limit.cmdGranularity;
    case TCL_LIMIT_TIME:
	return iPtr->limit.timeGranularity;
    }
    Tcl_Panic("unknown type of resource limit");
    return -1; /* NOT REACHED */
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteScriptLimitCallback --
 *
 *	Callback for when a script limit (a limit callback implemented as a
 *	Tcl script in a master interpreter, as set up from Tcl) is deleted.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference to the script callback from the controlling interpreter
 *	is removed.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScriptLimitCallback(clientData)
    ClientData clientData;
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
}

/*
 *----------------------------------------------------------------------
 *
 * CallScriptLimitCallback --
 *
 *	Invoke a script limit callback.  Used to implement limit
 *	callbacks set at the Tcl level on child interpreters.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the callback script.  Errors are reported as
 *	background errors.
 *
 *----------------------------------------------------------------------
 */

static void
CallScriptLimitCallback(clientData, interp)
    ClientData clientData;







|
|





|
|







3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
}

/*
 *----------------------------------------------------------------------
 *
 * CallScriptLimitCallback --
 *
 *	Invoke a script limit callback.  Used to implement limit callbacks set
 *	at the Tcl level on child interpreters.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the callback script.  Errors are reported as background
 *	errors.
 *
 *----------------------------------------------------------------------
 */

static void
CallScriptLimitCallback(clientData, interp)
    ClientData clientData;
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
}

/*
 *----------------------------------------------------------------------
 *
 * SetScriptLimitCallback --
 *
 *	Install (or remove, if scriptObj is NULL) a limit callback
 *	script that is called when the target interpreter exceeds the
 *	type of limit specified.  Each interpreter may only have one
 *	callback set on another interpreter through this mechanism
 *	(though as many interpreters may be limited as the programmer
 *	chooses overall).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A limit callback implemented as an invokation of a Tcl script
 *	in another interpreter is either installed or removed.
 *
 *----------------------------------------------------------------------
 */

static void
SetScriptLimitCallback(interp, type, targetInterp, scriptObj)
    Tcl_Interp *interp;







|
|
|
<
|
|





|
|







3745
3746
3747
3748
3749
3750
3751
3752
3753
3754

3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
}

/*
 *----------------------------------------------------------------------
 *
 * SetScriptLimitCallback --
 *
 *	Install (or remove, if scriptObj is NULL) a limit callback script that
 *	is called when the target interpreter exceeds the type of limit
 *	specified.  Each interpreter may only have one callback set on another

 *	interpreter through this mechanism (though as many interpreters may be
 *	limited as the programmer chooses overall).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A limit callback implemented as an invokation of a Tcl script in
 *	another interpreter is either installed or removed.
 *
 *----------------------------------------------------------------------
 */

static void
SetScriptLimitCallback(interp, type, targetInterp, scriptObj)
    Tcl_Interp *interp;
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
}

/*
 *----------------------------------------------------------------------
 *
 * TclRemoveScriptLimitCallbacks --
 *
 *	Remove all script-implemented limit callbacks that make calls
 *	back into the given interpreter.  This invoked as part of
 *	deleting an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The script limit callbacks are removed or marked for later
 *	removal.
 *
 *----------------------------------------------------------------------
 */

void
TclRemoveScriptLimitCallbacks(interp)
    Tcl_Interp *interp;







|
|
|





|
<







3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830

3831
3832
3833
3834
3835
3836
3837
}

/*
 *----------------------------------------------------------------------
 *
 * TclRemoveScriptLimitCallbacks --
 *
 *	Remove all script-implemented limit callbacks that make calls back
 *	into the given interpreter.  This invoked as part of deleting an
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The script limit callbacks are removed or marked for later removal.

 *
 *----------------------------------------------------------------------
 */

void
TclRemoveScriptLimitCallbacks(interp)
    Tcl_Interp *interp;
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitLimitSupport --
 *
 *	Initialise all the parts of the interpreter relating to
 *	resource limit management.  This allows an interpreter to both
 *	have limits set upon itself and set limits upon other
 *	interpreters.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The resource limit subsystem is initialised for the interpreter.
 *







|
|
|
<







3853
3854
3855
3856
3857
3858
3859
3860
3861
3862

3863
3864
3865
3866
3867
3868
3869
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitLimitSupport --
 *
 *	Initialise all the parts of the interpreter relating to resource limit
 *	management.  This allows an interpreter to both have limits set upon
 *	itself and set limits upon other interpreters.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The resource limit subsystem is initialised for the interpreter.
 *
3924
3925
3926
3927
3928
3929
3930

3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
    iPtr->limit.granularityTicker = 0;
    iPtr->limit.exceeded = 0;
    iPtr->limit.cmdCount = 0;
    iPtr->limit.cmdHandlers = NULL;
    iPtr->limit.cmdGranularity = 1;
    memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
    iPtr->limit.timeHandlers = NULL;

    iPtr->limit.timeGranularity = 10;
    Tcl_InitHashTable(&iPtr->limit.callbacks,
	    sizeof(struct ScriptLimitCallbackKey)/sizeof(int));
}

/*
 *----------------------------------------------------------------------
 *
 * InheritLimitsFromMaster --
 *
 *	Derive the interpreter limit configuration for a slave
 *	interpreter from the limit config for the master.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The slave interpreter limits are set so that if the master has
 *	a limit, it may not exceed it by handing off work to slave
 *	interpreters.  Note that this does not transfer limit
 *	callbacks from the master to the slave.
 *
 *----------------------------------------------------------------------
 */

static void
InheritLimitsFromMaster(slaveInterp, masterInterp)
    Tcl_Interp *slaveInterp, *masterInterp;







>










|
|





|
|
|
|







3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
    iPtr->limit.granularityTicker = 0;
    iPtr->limit.exceeded = 0;
    iPtr->limit.cmdCount = 0;
    iPtr->limit.cmdHandlers = NULL;
    iPtr->limit.cmdGranularity = 1;
    memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
    iPtr->limit.timeHandlers = NULL;
    iPtr->limit.timeEvent = NULL;
    iPtr->limit.timeGranularity = 10;
    Tcl_InitHashTable(&iPtr->limit.callbacks,
	    sizeof(struct ScriptLimitCallbackKey)/sizeof(int));
}

/*
 *----------------------------------------------------------------------
 *
 * InheritLimitsFromMaster --
 *
 *	Derive the interpreter limit configuration for a slave interpreter
 *	from the limit config for the master.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The slave interpreter limits are set so that if the master has a
 *	limit, it may not exceed it by handing off work to slave interpreters.
 *	Note that this does not transfer limit callbacks from the master to
 *	the slave.
 *
 *----------------------------------------------------------------------
 */

static void
InheritLimitsFromMaster(slaveInterp, masterInterp)
    Tcl_Interp *slaveInterp, *masterInterp;
4025
4026
4027
4028
4029
4030
4031

4032
4033
4034
4035
4036
4037
4038
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;

	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], -1), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
		Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,







>







3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;

	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], -1), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
		Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveTimeLimitCmd --
 *
 *	Implementation of the [interp limit $i time] and [$i limit
 *	time] subcommands.  See the interp manual page for a full
 *	description.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Depends on the arguments.
 *







|
|
<







4105
4106
4107
4108
4109
4110
4111
4112
4113

4114
4115
4116
4117
4118
4119
4120
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveTimeLimitCmd --
 *
 *	Implementation of the [interp limit $i time] and [$i limit time]
 *	subcommands.  See the interp manual page for a full description.

 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Depends on the arguments.
 *
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348

4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367

4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386








		limitMoment.sec = tmp;
		break;
	    }
	}
	if (milliObj != NULL || secObj != NULL) {
	    if (milliObj != NULL) {
		/*
		 * Setting -milliseconds but clearing -seconds, or
		 * resetting -milliseconds but not resetting -seconds?
		 * Bad voodoo!
		 */

		if (secObj != NULL && secLen == 0 && milliLen > 0) {
		    Tcl_AppendResult(interp, "may only set -milliseconds ",
			    "if -seconds is not also being reset", NULL);
		    return TCL_ERROR;
		}
		if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
		    Tcl_AppendResult(interp, "may only reset -milliseconds ",
			    "if -seconds is also being reset", NULL);
		    return TCL_ERROR;
		}
	    }

	    if (milliLen > 0 || secLen > 0) {
		/*
		 * Force usec to be in range [0..1000000), possibly
		 * incrementing sec in the process.  This makes it
		 * much easier for people to write scripts that do
		 * small time increments.
		 */

		limitMoment.sec += limitMoment.usec / 1000000;
		limitMoment.usec %= 1000000;

		Tcl_LimitSetTime(slaveInterp, &limitMoment);
		Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME);
	    } else {
		Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME);
	    }
	}
	if (scriptObj != NULL) {
	    SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp,
		    (scriptLen > 0 ? scriptObj : NULL));
	}
	if (granObj != NULL) {
	    Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran);
	}
	return TCL_OK;
    }
}















|
|
<

>















|
|
<

>



















>
>
>
>
>
>
>
>
4295
4296
4297
4298
4299
4300
4301
4302
4303

4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322

4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
		limitMoment.sec = tmp;
		break;
	    }
	}
	if (milliObj != NULL || secObj != NULL) {
	    if (milliObj != NULL) {
		/*
		 * Setting -milliseconds but clearing -seconds, or resetting
		 * -milliseconds but not resetting -seconds?  Bad voodoo!

		 */

		if (secObj != NULL && secLen == 0 && milliLen > 0) {
		    Tcl_AppendResult(interp, "may only set -milliseconds ",
			    "if -seconds is not also being reset", NULL);
		    return TCL_ERROR;
		}
		if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
		    Tcl_AppendResult(interp, "may only reset -milliseconds ",
			    "if -seconds is also being reset", NULL);
		    return TCL_ERROR;
		}
	    }

	    if (milliLen > 0 || secLen > 0) {
		/*
		 * Force usec to be in range [0..1000000), possibly
		 * incrementing sec in the process.  This makes it much easier
		 * for people to write scripts that do small time increments.

		 */

		limitMoment.sec += limitMoment.usec / 1000000;
		limitMoment.usec %= 1000000;

		Tcl_LimitSetTime(slaveInterp, &limitMoment);
		Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME);
	    } else {
		Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME);
	    }
	}
	if (scriptObj != NULL) {
	    SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp,
		    (scriptLen > 0 ? scriptObj : NULL));
	}
	if (granObj != NULL) {
	    Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran);
	}
	return TCL_OK;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclLink.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


36

37



38



39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
/* 
 * tclLink.c --
 *
 *	This file implements linked variables (a C variable that is
 *	tied to a Tcl variable).  The idea of linked variables was
 *	first suggested by Andreas Stolcke and this implementation is
 *	based heavily on a prototype implementation provided by
 *	him.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLink.c,v 1.8 2002/08/05 03:24:41 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each linked variable there is a data structure of the following
 * type, which describes the link and is the clientData for the trace
 * set on the Tcl variable.
 */

typedef struct Link {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Tcl_Obj *varName;		/* Name of variable (must be global).  This
				 * is needed during trace callbacks, since
				 * the actual variable may be aliased at
				 * that time via upvar. */
    char *addr;			/* Location of C variable. */
    int type;			/* Type of link (TCL_LINK_INT, etc.). */
    union {


	int i;

	double d;



	Tcl_WideInt w;



    } lastValue;		/* Last known value of C variable;  used to
				 * avoid string conversions. */
    int flags;			/* Miscellaneous one-bit values;  see below
				 * for definitions. */
} Link;

/*
 * Definitions for flag bits:
 * LINK_READ_ONLY -		1 means errors should be generated if Tcl
 *				script attempts to write variable.
 * LINK_BEING_UPDATED -		1 means that a call to Tcl_UpdateLinkedVar
 *				is in progress for this variable, so
 *				trace callbacks on the variable should
 *				be ignored.
 */

#define LINK_READ_ONLY		1
#define LINK_BEING_UPDATED	2

/*
 * Forward references to procedures defined later in this file:
 */

static char *		LinkTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
                            CONST char *name2, int flags));
static Tcl_Obj *	ObjValue _ANSI_ARGS_((Link *linkPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinkVar --
 *
 *	Link a C variable to a Tcl variable so that changes to either
 *	one causes the other to change.
 *
 * Results:
 *	The return value is TCL_OK if everything went well or TCL_ERROR
 *	if an error occurred (the interp's result is also set after
 *	errors).
 *
 * Side effects:
 *	The value at *addr is linked to the Tcl variable "varName",
 *	using "type" to convert between string values for Tcl and
 *	binary values for *addr.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LinkVar(interp, varName, addr, type)
    Tcl_Interp *interp;		/* Interpreter in which varName exists. */
    CONST char *varName;	/* Name of a global variable in interp. */
    char *addr;			/* Address of a C variable to be linked
				 * to varName. */
    int type;			/* Type of C variable: TCL_LINK_INT, etc. 
				 * Also may have TCL_LINK_READ_ONLY
				 * OR'ed in. */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    int code;

    linkPtr = (Link *) ckalloc(sizeof(Link));
    linkPtr->interp = interp;
|


|
|
|
|
<




|
|

|





|
|
|




|
|
|
|



>
>

>
|
>
>
>

>
>
>
|

|
|






|
|
|
<









|
<
|
|






|
|


|
|
<


|
|
|








|
|
|
|
<







1
2
3
4
5
6
7

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
67
68
69

70
71
72
73
74
75
76
77
78
79
80
81
82
83

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

101
102
103
104
105
106
107
/*
 * tclLink.c --
 *
 *	This file implements linked variables (a C variable that is tied to a
 *	Tcl variable). The idea of linked variables was first suggested by
 *	Andreas Stolcke and this implementation is based heavily on a
 *	prototype implementation provided by him.

 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLink.c,v 1.8.6.5 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each linked variable there is a data structure of the following type,
 * which describes the link and is the clientData for the trace set on the Tcl
 * variable.
 */

typedef struct Link {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    char *addr;			/* Location of C variable. */
    int type;			/* Type of link (TCL_LINK_INT, etc.). */
    union {
	char c;
	unsigned char uc;
	int i;
	unsigned int ui;
	short s;
	unsigned short us;
	long l;
	unsigned long ul;
	Tcl_WideInt w;
	Tcl_WideUInt uw;
	float f;
	double d;
    } lastValue;		/* Last known value of C variable; used to
				 * avoid string conversions. */
    int flags;			/* Miscellaneous one-bit values; see below for
				 * definitions. */
} Link;

/*
 * Definitions for flag bits:
 * LINK_READ_ONLY -		1 means errors should be generated if Tcl
 *				script attempts to write variable.
 * LINK_BEING_UPDATED -		1 means that a call to Tcl_UpdateLinkedVar is
 *				in progress for this variable, so trace
 *				callbacks on the variable should be ignored.

 */

#define LINK_READ_ONLY		1
#define LINK_BEING_UPDATED	2

/*
 * Forward references to procedures defined later in this file:
 */

static char *		LinkTraceProc(ClientData clientData,Tcl_Interp *interp,

			    CONST char *name1, CONST char *name2, int flags);
static Tcl_Obj *	ObjValue(Link *linkPtr);

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinkVar --
 *
 *	Link a C variable to a Tcl variable so that changes to either one
 *	causes the other to change.
 *
 * Results:
 *	The return value is TCL_OK if everything went well or TCL_ERROR if an
 *	error occurred (the interp's result is also set after errors).

 *
 * Side effects:
 *	The value at *addr is linked to the Tcl variable "varName", using
 *	"type" to convert between string values for Tcl and binary values for
 *	*addr.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LinkVar(interp, varName, addr, type)
    Tcl_Interp *interp;		/* Interpreter in which varName exists. */
    CONST char *varName;	/* Name of a global variable in interp. */
    char *addr;			/* Address of a C variable to be linked to
				 * varName. */
    int type;			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */

{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    int code;

    linkPtr = (Link *) ckalloc(sizeof(Link));
    linkPtr->interp = interp;
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
 *
 *	Destroy the link between a Tcl variable and a C variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If "varName" was previously linked to a C variable, the link
 *	is broken to make the variable independent.  If there was no
 *	previous link for "varName" then nothing happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UnlinkVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable to unlink. */
    CONST char *varName;	/* Global variable in interp to unlink. */
{
    Link *linkPtr;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
	    LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {







|
|
|






|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
 *
 *	Destroy the link between a Tcl variable and a C variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If "varName" was previously linked to a C variable, the link is broken
 *	to make the variable independent. If there was no previous link for
 *	"varName" then nothing happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UnlinkVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable to unlink */
    CONST char *varName;	/* Global variable in interp to unlink. */
{
    Link *linkPtr;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
	    LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateLinkedVar --
 *
 *	This procedure is invoked after a linked variable has been
 *	changed by C code.  It updates the Tcl variable so that
 *	traces on the variable will trigger.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The Tcl variable "varName" is updated from its C value,
 *	causing traces on the variable to trigger.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UpdateLinkedVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable. */







|
|
|





|
|







170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateLinkedVar --
 *
 *	This procedure is invoked after a linked variable has been changed by
 *	C code. It updates the Tcl variable so that traces on the variable
 *	will trigger.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The Tcl variable "varName" is updated from its C value, causing traces
 *	on the variable to trigger.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UpdateLinkedVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240



241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
































289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357


358
359
360



361
362
363
364
365
366
367
368






369



370
371
372




373






374












375
376




































































377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
}

/*
 *----------------------------------------------------------------------
 *
 * LinkTraceProc --
 *
 *	This procedure is invoked when a linked Tcl variable is read,
 *	written, or unset from Tcl.  It's responsible for keeping the
 *	C variable in sync with the Tcl variable.
 *
 * Results:
 *	If all goes well, NULL is returned; otherwise an error message
 *	is returned.
 *
 * Side effects:
 *	The C variable may be updated to make it consistent with the
 *	Tcl variable, or the Tcl variable may be overwritten to reject
 *	a modification.
 *
 *----------------------------------------------------------------------
 */

static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Contains information about the link. */
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    CONST char *name1;		/* First part of variable name. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *) clientData;
    int changed, valueLength;
    CONST char *value;
    char **pp, *result;
    Tcl_Obj *objPtr, *valueObj;




    /*
     * If the variable is being unset, then just re-create it (with a
     * trace) unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (flags & TCL_INTERP_DESTROYED) {
	    Tcl_DecrRefCount(linkPtr->varName);
	    ckfree((char *) linkPtr);
	} else if (flags & TCL_TRACE_DESTROYED) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
		    |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
	}
	return NULL;
    }

    /*
     * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
     * don't do anything at all.  In particular, we don't want to get
     * upset that the variable is being modified, even if it is
     * supposed to be read-only.
     */

    if (linkPtr->flags & LINK_BEING_UPDATED) {
	return NULL;
    }

    /*
     * For read accesses, update the Tcl variable if the C variable
     * has changed since the last time we updated the Tcl variable.
     */

    if (flags & TCL_TRACE_READS) {
	switch (linkPtr->type) {
	case TCL_LINK_INT:
	case TCL_LINK_BOOLEAN:
	    changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
	    break;
	case TCL_LINK_DOUBLE:
	    changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
	    break;
	case TCL_LINK_WIDE_INT:
	    changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
	    break;
































	case TCL_LINK_STRING:
	    changed = 1;
	    break;
	default:
	    return "internal error: bad linked variable type";
	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}
	return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable.  Then
     * convert the Tcl value to C if possible.  If the variable isn't
     * writable or can't be converted, then restore the varaible's old
     * value and return an error.  Another tricky thing: we have to save
     * and restore the interpreter's result, since the variable access
     * could occur when the result has been partially set.
     */

    if (linkPtr->flags & LINK_READ_ONLY) {
	Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		TCL_GLOBAL_ONLY);
	return "linked variable is read-only";
    }
    valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
    if (valueObj == NULL) {
	/*
	 * This shouldn't ever happen.
	 */
	return "internal error: linked variable couldn't be read";
    }

    objPtr = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(objPtr);
    Tcl_ResetResult(interp);
    result = NULL;

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
		!= TCL_OK) {
	    Tcl_SetObjResult(interp, objPtr);
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    result = "variable must have integer value";
	    goto end;
	}
	*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
	break;

    case TCL_LINK_WIDE_INT:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
		!= TCL_OK) {
	    Tcl_SetObjResult(interp, objPtr);
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    result = "variable must have integer value";
	    goto end;
	}
	*(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
	break;

    case TCL_LINK_DOUBLE:
	if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
		!= TCL_OK) {
	    Tcl_SetObjResult(interp, objPtr);


	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    result = "variable must have real value";



	    goto end;
	}
	*(double *)(linkPtr->addr) = linkPtr->lastValue.d;
	break;

    case TCL_LINK_BOOLEAN:
	if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
	    != TCL_OK) {






	    Tcl_SetObjResult(interp, objPtr);



	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    result = "variable must have boolean value";




	    goto end;






	}












	*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
	break;





































































    case TCL_LINK_STRING:
	value = Tcl_GetStringFromObj(valueObj, &valueLength);
	valueLength++;
	pp = (char **)(linkPtr->addr);
	if (*pp != NULL) {
	    ckfree(*pp);
	}
	*pp = (char *) ckalloc((unsigned) valueLength);
	memcpy(*pp, value, (unsigned) valueLength);
	break;

    default:
	return "internal error: bad linked variable type";
    }
    end:
    Tcl_DecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ObjValue --
 *
 *	Converts the value of a C variable to a Tcl_Obj* for use in a
 *	Tcl variable to which it is linked.
 *
 * Results:
 *	The return value is a pointer to a Tcl_Obj that represents
 *	the value of the C variable given by linkPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|


|
|


|
|
|















|
|
>
>
>


|
|

















|
|
|
<







|
|














>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>














|
|
|
|
|
|















<
<
<
<
<


|

<


|
<





|

<


|
<





|

|
>
>


|
>
>
>
|





|

>
>
>
>
>
>
|
>
>
>


|
>
>
>
>
|
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>















<
<
|







|
|


|
|







209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361





362
363
364
365

366
367
368

369
370
371
372
373
374
375

376
377
378

379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524


525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
}

/*
 *----------------------------------------------------------------------
 *
 * LinkTraceProc --
 *
 *	This procedure is invoked when a linked Tcl variable is read, written,
 *	or unset from Tcl. It's responsible for keeping the C variable in sync
 *	with the Tcl variable.
 *
 * Results:
 *	If all goes well, NULL is returned; otherwise an error message is
 *	returned.
 *
 * Side effects:
 *	The C variable may be updated to make it consistent with the Tcl
 *	variable, or the Tcl variable may be overwritten to reject a
 *	modification.
 *
 *----------------------------------------------------------------------
 */

static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Contains information about the link. */
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    CONST char *name1;		/* First part of variable name. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *) clientData;
    int changed, valueLength;
    CONST char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    double valueDouble;

    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (flags & TCL_INTERP_DESTROYED) {
	    Tcl_DecrRefCount(linkPtr->varName);
	    ckfree((char *) linkPtr);
	} else if (flags & TCL_TRACE_DESTROYED) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
		    |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
	}
	return NULL;
    }

    /*
     * If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't
     * do anything at all. In particular, we don't want to get upset that the
     * variable is being modified, even if it is supposed to be read-only.

     */

    if (linkPtr->flags & LINK_BEING_UPDATED) {
	return NULL;
    }

    /*
     * For read accesses, update the Tcl variable if the C variable has
     * changed since the last time we updated the Tcl variable.
     */

    if (flags & TCL_TRACE_READS) {
	switch (linkPtr->type) {
	case TCL_LINK_INT:
	case TCL_LINK_BOOLEAN:
	    changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
	    break;
	case TCL_LINK_DOUBLE:
	    changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
	    break;
	case TCL_LINK_WIDE_INT:
	    changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
	    break;
	case TCL_LINK_WIDE_UINT:
	    changed = *(Tcl_WideUInt *)(linkPtr->addr) !=
		    linkPtr->lastValue.uw;
	    break;
	case TCL_LINK_CHAR:
	    changed = *(char *)(linkPtr->addr) != linkPtr->lastValue.c;
	    break;
	case TCL_LINK_UCHAR:
	    changed = *(unsigned char *)(linkPtr->addr) !=
		    linkPtr->lastValue.uc;
	    break;
	case TCL_LINK_SHORT:
	    changed = *(short *)(linkPtr->addr) != linkPtr->lastValue.s;
	    break;
	case TCL_LINK_USHORT:
	    changed = *(unsigned short *)(linkPtr->addr) !=
		    linkPtr->lastValue.us;
	    break;
	case TCL_LINK_UINT:
	    changed = *(unsigned int *)(linkPtr->addr) !=
		    linkPtr->lastValue.ui;
	    break;
	case TCL_LINK_LONG:
	    changed = *(long *)(linkPtr->addr) != linkPtr->lastValue.l;
	    break;
	case TCL_LINK_ULONG:
	    changed = *(unsigned long *)(linkPtr->addr) !=
		    linkPtr->lastValue.ul;
	    break;
	case TCL_LINK_FLOAT:
	    changed = *(float *)(linkPtr->addr) != linkPtr->lastValue.f;
	    break;
	case TCL_LINK_STRING:
	    changed = 1;
	    break;
	default:
	    return "internal error: bad linked variable type";
	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}
	return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable. Then convert
     * the Tcl value to C if possible. If the variable isn't writable or can't
     * be converted, then restore the varaible's old value and return an
     * error. Another tricky thing: we have to save and restore the interp's
     * result, since the variable access could occur when the result has been
     * partially set.
     */

    if (linkPtr->flags & LINK_READ_ONLY) {
	Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		TCL_GLOBAL_ONLY);
	return "linked variable is read-only";
    }
    valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
    if (valueObj == NULL) {
	/*
	 * This shouldn't ever happen.
	 */
	return "internal error: linked variable couldn't be read";
    }






    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
		!= TCL_OK) {

	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have integer value";

	}
	*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
	break;

    case TCL_LINK_WIDE_INT:
	if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
		!= TCL_OK) {

	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have integer value";

	}
	*(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
	break;

    case TCL_LINK_DOUBLE:
	if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
		!= TCL_OK) {
#ifdef ACCEPT_NAN
	  if (valueObj->typePtr != &tclDoubleType) {
#endif
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have real value";
#ifdef ACCEPT_NAN
	  }
	  linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
#endif
	}
	*(double *)(linkPtr->addr) = linkPtr->lastValue.d;
	break;

    case TCL_LINK_BOOLEAN:
	if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
	    != TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have boolean value";
	}
	*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
	break;

    case TCL_LINK_CHAR:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have char value";
	}
	linkPtr->lastValue.c = (char)valueInt;
	*(char *)(linkPtr->addr) = linkPtr->lastValue.c;
	break;

    case TCL_LINK_UCHAR:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < 0 || valueInt > UCHAR_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned char value";
	}
	linkPtr->lastValue.uc = (unsigned char) valueInt;
	*(unsigned char *)(linkPtr->addr) = linkPtr->lastValue.uc;
	break;

    case TCL_LINK_SHORT:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have short value";
	}
	linkPtr->lastValue.s = (short)valueInt;
	*(short *)(linkPtr->addr) = linkPtr->lastValue.s;
	break;

    case TCL_LINK_USHORT:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < 0 || valueInt > USHRT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned short value";
	}
	linkPtr->lastValue.us = (unsigned short)valueInt;
	*(unsigned short *)(linkPtr->addr) = linkPtr->lastValue.us;
	break;

    case TCL_LINK_UINT:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
		|| valueWide < 0 || valueWide > UINT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned int value";
	}
	linkPtr->lastValue.ui = (unsigned int)valueWide;
	*(unsigned int *)(linkPtr->addr) = linkPtr->lastValue.ui;
	break;

    case TCL_LINK_LONG:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
		|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have long value";
	}
	linkPtr->lastValue.l = (long)valueWide;
	*(long *)(linkPtr->addr) = linkPtr->lastValue.l;
	break;

    case TCL_LINK_ULONG:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
		|| valueWide < 0 || valueWide > ULONG_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned long value";
	}
	linkPtr->lastValue.ul = (unsigned long)valueWide;
	*(unsigned long *)(linkPtr->addr) = linkPtr->lastValue.ul;
	break;

    case TCL_LINK_WIDE_UINT:
	/*
	 * FIXME: represent as a bignum.
	 */
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned wide int value";
	}
	linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
	*(Tcl_WideUInt *)(linkPtr->addr) = linkPtr->lastValue.uw;
	break;

    case TCL_LINK_FLOAT:
	if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
		|| valueDouble < FLT_MIN || valueDouble > FLT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have float value";
	}
	linkPtr->lastValue.f = (float)valueDouble;
	*(float *)(linkPtr->addr) = linkPtr->lastValue.f;
	break;

    case TCL_LINK_STRING:
	value = Tcl_GetStringFromObj(valueObj, &valueLength);
	valueLength++;
	pp = (char **)(linkPtr->addr);
	if (*pp != NULL) {
	    ckfree(*pp);
	}
	*pp = (char *) ckalloc((unsigned) valueLength);
	memcpy(*pp, value, (unsigned) valueLength);
	break;

    default:
	return "internal error: bad linked variable type";
    }


    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ObjValue --
 *
 *	Converts the value of a C variable to a Tcl_Obj* for use in a Tcl
 *	variable to which it is linked.
 *
 * Results:
 *	The return value is a pointer to a Tcl_Obj that represents the value
 *	of the C variable given by linkPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

427
428
429
430
431
432
433






























434
435
436
437
438
439
440
441
442
443
444
445
446
447
448








	return Tcl_NewWideIntObj(linkPtr->lastValue.w);
    case TCL_LINK_DOUBLE:
	linkPtr->lastValue.d = *(double *)(linkPtr->addr);
	return Tcl_NewDoubleObj(linkPtr->lastValue.d);
    case TCL_LINK_BOOLEAN:
	linkPtr->lastValue.i = *(int *)(linkPtr->addr);
	return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);






























    case TCL_LINK_STRING:
	p = *(char **)(linkPtr->addr);
	if (p == NULL) {
	    return Tcl_NewStringObj("NULL", 4);
	}
	return Tcl_NewStringObj(p, -1);

    /*
     * This code only gets executed if the link type is unknown
     * (shouldn't ever happen).
     */
    default:
	return Tcl_NewStringObj("??", 2);
    }
}















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|
|





>
>
>
>
>
>
>
>
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
	return Tcl_NewWideIntObj(linkPtr->lastValue.w);
    case TCL_LINK_DOUBLE:
	linkPtr->lastValue.d = *(double *)(linkPtr->addr);
	return Tcl_NewDoubleObj(linkPtr->lastValue.d);
    case TCL_LINK_BOOLEAN:
	linkPtr->lastValue.i = *(int *)(linkPtr->addr);
	return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
    case TCL_LINK_CHAR:
	linkPtr->lastValue.c = *(char *)(linkPtr->addr);
	return Tcl_NewIntObj(linkPtr->lastValue.c);
    case TCL_LINK_UCHAR:
	linkPtr->lastValue.uc = *(unsigned char *)(linkPtr->addr);
	return Tcl_NewIntObj(linkPtr->lastValue.uc);
    case TCL_LINK_SHORT:
	linkPtr->lastValue.s = *(short *)(linkPtr->addr);
	return Tcl_NewIntObj(linkPtr->lastValue.s);
    case TCL_LINK_USHORT:
	linkPtr->lastValue.us = *(unsigned short *)(linkPtr->addr);
	return Tcl_NewIntObj(linkPtr->lastValue.us);
    case TCL_LINK_UINT:
	linkPtr->lastValue.ui = *(unsigned int *)(linkPtr->addr);
	return Tcl_NewWideIntObj(linkPtr->lastValue.ui);
    case TCL_LINK_LONG:
	linkPtr->lastValue.l = *(long *)(linkPtr->addr);
	return Tcl_NewWideIntObj(linkPtr->lastValue.l);
    case TCL_LINK_ULONG:
	linkPtr->lastValue.ul = *(unsigned long *)(linkPtr->addr);
	return Tcl_NewWideIntObj(linkPtr->lastValue.ul);
    case TCL_LINK_FLOAT:
	linkPtr->lastValue.f = *(float *)(linkPtr->addr);
	return Tcl_NewDoubleObj(linkPtr->lastValue.f);
    case TCL_LINK_WIDE_UINT:
	linkPtr->lastValue.uw = *(Tcl_WideUInt *)(linkPtr->addr);
	/*
	 * FIXME: represent as a bignum.
	 */
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
    case TCL_LINK_STRING:
	p = *(char **)(linkPtr->addr);
	if (p == NULL) {
	    return Tcl_NewStringObj("NULL", 4);
	}
	return Tcl_NewStringObj(p, -1);

    /*
     * This code only gets executed if the link type is unknown (shouldn't
     * ever happen).
     */
    default:
	return Tcl_NewStringObj("??", 2);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclListObj.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

52
53
54







































































55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
/* 
 * tclListObj.c --
 *
 *	This file contains procedures that implement the Tcl list object
 *	type.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclListObj.c,v 1.20 2004/11/11 01:17:51 das Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for procedures defined later in this file:
 */


static void		DupListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static void		FreeListInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
static int		SetListFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr));

/*
 * The structure below defines the list Tcl object type by means of
 * procedures that can be invoked by generic object code.
 *
 * The internal representation of a list object is a two-pointer
 * representation.  The first pointer designates a List structure that
 * contains an array of pointers to the element objects, together with
 * integers that represent the current element count and the allocated
 * size of the array.  The second pointer is normally NULL; during
 * execution of functions in this file that operate on nested sublists,
 * it is occasionally used as working storage to avoid an auxiliary
 * stack.
 */

Tcl_ObjType tclListType = {
    "list",				/* name */
    FreeListInternalRep,		/* freeIntRepProc */
    DupListInternalRep,			/* dupIntRepProc */
    UpdateStringOfList,			/* updateStringProc */
    SetListFromAny			/* setFromAnyProc */
};


/*
 *----------------------------------------------------------------------
 *







































































 * Tcl_NewListObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new list object from an
 *	(objc,objv) array: that is, each of the objc elements of the array
 *	referenced by objv is inserted as an element into a new Tcl object.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewListObj.
 *
 * Results:
 *	A new list object is returned that is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned. The new object's string representation
 *	is left NULL. The resulting new list object has ref count 0.
 *
 * Side effects:
 *	The ref counts of the elements in objv are incremented since the
 *	resulting list now refers to them.
 *
 *----------------------------------------------------------------------
 */
|


|
<





|
|

|





|


>
|
<
|
|
<
|


|
|


|
|
|
|
|
|
<



|
|
|
|
|

|
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|




|
|




|
|







1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25

26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
/*
 * tclListObj.c --
 *
 *	This file contains functions that implement the Tcl list object type.

 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclListObj.c,v 1.20.2.4 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for functions defined later in this file:
 */

static List *		NewListIntRep(int objc, Tcl_Obj *CONST objv[]);
static void		DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);

static void		FreeListInternalRep(Tcl_Obj *listPtr);
static int		SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);

static void		UpdateStringOfList(Tcl_Obj *listPtr);

/*
 * The structure below defines the list Tcl object type by means of functions
 * that can be invoked by generic object code.
 *
 * The internal representation of a list object is a two-pointer
 * representation. The first pointer designates a List structure that contains
 * an array of pointers to the element objects, together with integers that
 * represent the current element count and the allocated size of the array.
 * The second pointer is normally NULL; during execution of functions in this
 * file that operate on nested sublists, it is occasionally used as working
 * storage to avoid an auxiliary stack.

 */

Tcl_ObjType tclListType = {
    "list",			/* name */
    FreeListInternalRep,	/* freeIntRepProc */
    DupListInternalRep,		/* dupIntRepProc */
    UpdateStringOfList,		/* updateStringProc */
    NULL			/* setFromAnyProc */
};


/*
 *----------------------------------------------------------------------
 *
 * NewListIntRep --
 *
 *	If objc>0 and objv!=NULL, this function creates a list internal rep
 *	with objc elements given in the array objv.
 *	If objc>0 and objv==NULL it creates the list internal rep of a list
 *	with 0 elements, where enough space has been preallocated to store
 *	objc elements.
 *	If objc<=0, it returns NULL.
 *
 * Results:
 *	A new List struct is returned. If objc<=0 or if the allocation fails
 *	for lack of memory, NULL is returned. The list returned has refCount
 *	0.
 *
 * Side effects:
 *	The ref counts of the elements in objv are incremented since the
 *	resulting list now refers to them.
 *
 *----------------------------------------------------------------------
 */

static List*
NewListIntRep(objc, objv)
    int objc;
    Tcl_Obj *CONST objv[];
{
    Tcl_Obj **elemPtrs;
    List *listRepPtr;
    int i;

    if (objc <= 0) {
	return NULL;
    }

    /*
     * First check to see if we'd overflow and try to allocate an object
     * larger than our memory allocator allows. Note that this is actually a
     * fairly small value when you're on a serious 64-bit machine, but that
     * requires API changes to fix.
     */

    if (objc > INT_MAX/sizeof(Tcl_Obj *)) {
	return NULL;
    }

    listRepPtr = (List *) attemptckalloc(sizeof(List) +
	    ((objc-1) * sizeof(Tcl_Obj *)));
    if (listRepPtr == NULL) {
	return NULL;
    }

    listRepPtr->canonicalFlag = 0;
    listRepPtr->refCount = 0;
    listRepPtr->maxElemCount = objc;

    if (objv) {
	listRepPtr->elemCount = objc;
	elemPtrs = &listRepPtr->elements;
	for (i = 0;  i < objc;  i++) {
	    elemPtrs[i] = objv[i];
	    Tcl_IncrRefCount(elemPtrs[i]);
	}
    } else {
	listRepPtr->elemCount = 0;
    }
    return listRepPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewListObj --
 *
 *	This function is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new list object from an
 *	(objc,objv) array: that is, each of the objc elements of the array
 *	referenced by objv is inserted as an element into a new Tcl object.
 *
 *	When TCL_MEM_DEBUG is defined, this function just returns the result
 *	of calling the debugging version Tcl_DbNewListObj.
 *
 * Results:
 *	A new list object is returned that is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned. The new object's string representation is left
 *	NULL. The resulting new list object has ref count 0.
 *
 * Side effects:
 *	The ref counts of the elements in objv are incremented since the
 *	resulting list now refers to them.
 *
 *----------------------------------------------------------------------
 */
89
90
91
92
93
94
95
96
97
98
99

100
101
102
103
104
105
106



107
108
109
110
111
112
113

114
115
116

117

118
119
120

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176



177
178
179
180
181
182
183

184
185
186

187

188
189
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

386
387
388
389

390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438









439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551








552
553
554
555
556
557
558
559
560
561
562
563
564
565

566
567
568
569








570
571



572

573
574


575

576
577


578
579

580
581
582
583
584
585
586

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635








636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682








683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746

747
748
749
750
751










752
753
754
755
756


757
758
759
760
761
762
763
764
765
766
767
768


769
770

771

772

773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818




819



820




821


822



823


824
825
826
















827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853




854
855
856
857
858
859
860
861
862
863
864
865

866
867

868

869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945

946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975

976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewListObj(objc, objv)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
{
    register Tcl_Obj *listPtr;
    register Tcl_Obj **elemPtrs;
    register List *listRepPtr;
    int i;


    TclNewObj(listPtr);

    if (objc > 0) {
	Tcl_InvalidateStringRep(listPtr);

	elemPtrs = (Tcl_Obj **)



	    ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
	for (i = 0;  i < objc;  i++) {
	    elemPtrs[i] = objv[i];
	    Tcl_IncrRefCount(elemPtrs[i]);
	}

	listRepPtr = (List *) ckalloc(sizeof(List));

	listRepPtr->maxElemCount = objc;
	listRepPtr->elemCount    = objc;
	listRepPtr->elements     = elemPtrs;



	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	listPtr->internalRep.twoPtrValue.ptr2 = NULL;
	listPtr->typePtr = &tclListType;

    }
    return listPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewListObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new list objects. It is the
 *	same as the Tcl_NewListObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command	will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewListObj.
 *
 * Results:
 *	A new list object is returned that is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned. The new object's string representation
 *	is left NULL. The new list object has ref count 0.
 *
 * Side effects:
 *	The ref counts of the elements in objv are incremented since the
 *	resulting list now refers to them.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewListObj(objc, objv, file, line)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *listPtr;
    register Tcl_Obj **elemPtrs;
    register List *listRepPtr;
    int i;

    TclDbNewObj(listPtr, file, line);

    if (objc > 0) {
	Tcl_InvalidateStringRep(listPtr);

	elemPtrs = (Tcl_Obj **)



	    ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
	for (i = 0;  i < objc;  i++) {
	    elemPtrs[i] = objv[i];
	    Tcl_IncrRefCount(elemPtrs[i]);
	}

	listRepPtr = (List *) ckalloc(sizeof(List));

	listRepPtr->maxElemCount = objc;
	listRepPtr->elemCount    = objc;
	listRepPtr->elements     = elemPtrs;



	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	listPtr->internalRep.twoPtrValue.ptr2 = NULL;
	listPtr->typePtr = &tclListType;

    }
    return listPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewListObj(objc, objv, file, line)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclNewListObjDirect, TclDbNewListObjDirect --
 *
 *	Version of Tcl_NewListOb/Tcl_DbNewListObj that does not copy
 *	the array of Tcl_Objs. It still scans it though to update the
 *	reference counts.
 *
 * Results:
 *	A new list object is returned that is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned (and "ownership" of the array of objects is
 *	not transferred.) The new object's string representation is left
 *	NULL. The resulting new list object has ref count 0.
 *
 * Side effects:
 *	The ref counts of the elements in objv are incremented since the
 *	resulting list now refers to them.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef TclNewListObjDirect
Tcl_Obj *
TclNewListObjDirect(objc, objv)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj **objv;		/* An array of pointers to Tcl objects. */
{
    return TclDbNewListObjDirect(objc, objv, "unknown", 0);
}
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *
TclNewListObjDirect(objc, objv)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj **objv;		/* An array of pointers to Tcl objects. */
{
    register Tcl_Obj *listPtr;

    TclNewObj(listPtr);

    if (objc > 0) {
	register List *listRepPtr;
	int i;

	Tcl_InvalidateStringRep(listPtr);

	for (i=0 ; i<objc ; i++) {
	    Tcl_IncrRefCount(objv[i]);
	}

	listRepPtr = (List *) ckalloc(sizeof(List));
	listRepPtr->maxElemCount = objc;
	listRepPtr->elemCount    = objc;
	listRepPtr->elements     = objv;

	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	listPtr->internalRep.twoPtrValue.ptr2 = NULL;
	listPtr->typePtr = &tclListType;
    }
    return listPtr;
}
#endif /* TCL_MEM_DEBUG */

#ifdef TCL_MEM_DEBUG
Tcl_Obj *
TclDbNewListObjDirect(objc, objv, file, line)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj **objv;		/* An array of pointers to Tcl objects. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *listPtr;

    TclDbNewObj(listPtr, file, line);

    if (objc > 0) {
	register List *listRepPtr;
	int i;

	Tcl_InvalidateStringRep(listPtr);

	for (i=0 ; i<objc ; i++) {
	    Tcl_IncrRefCount(objv[i]);
	}

	listRepPtr = (List *) ckalloc(sizeof(List));
	listRepPtr->maxElemCount = objc;
	listRepPtr->elemCount    = objc;
	listRepPtr->elements     = objv;

	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	listPtr->internalRep.twoPtrValue.ptr2 = NULL;
	listPtr->typePtr = &tclListType;
    }
    return listPtr;
}
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *
TclDbNewListObjDirect(objc, objv, file, line)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj **objv;		/* An array of pointers to Tcl objects. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return TclNewListObjDirect(objc, objv);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetListObj --
 *
 *	Modify an object to be a list containing each of the objc elements
 *	of the object array referenced by objv.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object is made a list object and is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned. The new object's string representation
 *	is left NULL. The ref counts of the elements in objv are incremented
 *	since the list now refers to them. The object's old string and
 *	internal representations are freed and its type is set NULL.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetListObj(objPtr, objc, objv)
    Tcl_Obj *objPtr;		/* Object whose internal rep to init. */
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
{
    register Tcl_Obj **elemPtrs;
    register List *listRepPtr;
    int i;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetListObj called with shared object");
    }

    /*
     * Free any old string rep and any internal rep for the old type.
     */

    TclFreeIntRep(objPtr);
    objPtr->typePtr = NULL;
    Tcl_InvalidateStringRep(objPtr);

    /*
     * Set the object's type to "list" and initialize the internal rep.
     * However, if there are no elements to put in the list, just give
     * the object an empty string rep and a NULL type.
     */

    if (objc > 0) {
	elemPtrs = (Tcl_Obj **)
	    ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
	for (i = 0;  i < objc;  i++) {
	    elemPtrs[i] = objv[i];
	    Tcl_IncrRefCount(elemPtrs[i]);
	}

	listRepPtr = (List *) ckalloc(sizeof(List));
	listRepPtr->maxElemCount = objc;
	listRepPtr->elemCount    = objc;
	listRepPtr->elements     = elemPtrs;


	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
	objPtr->typePtr = &tclListType;

    } else {
	objPtr->bytes = tclEmptyStringRep;
	objPtr->length = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjGetElements --
 *
 *	This procedure returns an (objc,objv) array of the elements in a
 *	list object.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *objcPtr is set to
 *	the count of list elements and *objvPtr is set to a pointer to an
 *	array of (*objcPtr) pointers to each list element. If listPtr does
 *	not refer to a list object and the object can not be converted to
 *	one, TCL_ERROR is returned and an error message will be left in
 *	the interpreter's result if interp is not NULL.
 *
 *	The objects referenced by the returned array should be treated as
 *	readonly and their ref counts are _not_ incremented; the caller must
 *	do that if it holds on to a reference. Furthermore, the pointer
 *	and length returned by this procedure may change as soon as any
 *	procedure is called on the list object; be careful about retaining
 *	the pointer in a local data structure.
 *
 * Side effects:
 *	The possible conversion of the object referenced by listPtr
 *	to a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object for which an element array
				 * is to be returned. */
    int *objcPtr;		/* Where to store the count of objects
				 * referenced by objv. */
    Tcl_Obj ***objvPtr;		/* Where to store the pointer to an array
				 * of pointers to the list's objects. */
{
    register List *listRepPtr;

    if (listPtr->typePtr != &tclListType) {









	int result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }
    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    *objcPtr = listRepPtr->elemCount;
    *objvPtr = listRepPtr->elements;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendList --
 *
 *	This procedure appends the objects in the list referenced by
 *	elemListPtr to the list object referenced by listPtr. If listPtr is
 *	not already a list object, an attempt will be made to convert it to
 *	one.
 *
 * Results:
 *	The return value is normally TCL_OK. If listPtr or elemListPtr do
 *	not refer to list objects and they can not be converted to one,
 *	TCL_ERROR is returned and an error message is left in
 *	the interpreter's result if interp is not NULL.
 *
 * Side effects:
 *	The reference counts of the elements in elemListPtr are incremented
 *	since the list now refers to them. listPtr and elemListPtr are
 *	converted, if necessary, to list objects. Also, appending the
 *	new elements may cause listObj's array of element pointers to grow.
 *	listPtr's old string representation, if any, is invalidated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjAppendList(interp, listPtr, elemListPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object to append elements to. */
    Tcl_Obj *elemListPtr;	/* List obj with elements to append. */
{
    register List *listRepPtr;
    int listLen, objc, result;
    Tcl_Obj **objv;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjAppendList called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {
	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }
    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    listLen = listRepPtr->elemCount;

    result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Insert objc new elements starting after the lists's last element.
     * Delete zero existing elements.
     */

    return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendElement --
 *
 *	This procedure is a special purpose version of
 *	Tcl_ListObjAppendList: it appends a single object referenced by
 *	objPtr to the list object referenced by listPtr. If listPtr is not
 *	already a list object, an attempt will be made to convert it to one.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case objPtr is added
 *	to the end of listPtr's list. If listPtr does not refer to a list
 *	object and the object can not be converted to one, TCL_ERROR is
 *	returned and an error message will be left in the interpreter's
 *	result if interp is not NULL.
 *
 * Side effects:
 *	The ref count of objPtr is incremented since the list now refers 
 *	to it. listPtr will be converted, if necessary, to a list object.
 *	Also, appending the new element may cause listObj's array of element
 *	pointers to grow. listPtr's old string representation, if any,
 *	is invalidated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjAppendElement(interp, listPtr, objPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    Tcl_Obj *listPtr;		/* List object to append objPtr to. */
    Tcl_Obj *objPtr;		/* Object to append to listPtr's list. */
{
    register List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    int numElems, numRequired;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjAppendElement called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {








	int result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    elemPtrs = listRepPtr->elements;
    numElems = listRepPtr->elemCount;
    numRequired = numElems + 1 ;

    /*
     * If there is no room in the current array of element pointers,
     * allocate a new, larger array and copy the pointers to it.

     */

    if (numRequired > listRepPtr->maxElemCount) {
	int newMax = (2 * numRequired);








	Tcl_Obj **newElemPtrs = (Tcl_Obj **)
		ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));





	memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs,
		(size_t) (numElems * sizeof(Tcl_Obj *)));




	listRepPtr->maxElemCount = newMax;
	listRepPtr->elements = newElemPtrs;


	ckfree((char *) elemPtrs);
	elemPtrs = newElemPtrs;

    }

    /*
     * Add objPtr to the end of listPtr's array of element
     * pointers. Increment the ref count for the (now shared) objPtr.
     */


    elemPtrs[numElems] = objPtr;
    Tcl_IncrRefCount(objPtr);
    listRepPtr->elemCount++;

    /*
     * Invalidate any old string representation since the list's internal
     * representation has changed.
     */

    Tcl_InvalidateStringRep(listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjIndex --
 *
 *	This procedure returns a pointer to the index'th object from the
 *	list referenced by listPtr. The first element has index 0. If index
 *	is negative or greater than or equal to the number of elements in
 *	the list, a NULL is returned. If listPtr is not a list object, an
 *	attempt will be made to convert it to a list.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case objPtrPtr is set
 *	to the Tcl_Obj pointer for the index'th list element or NULL if
 *	index is out of range. This object should be treated as readonly and
 *	its ref count is _not_ incremented; the caller must do that if it
 *	holds on to the reference. If listPtr does not refer to a list and
 *	can't be converted to one, TCL_ERROR is returned and an error
 *	message is left in the interpreter's result if interp is not NULL.
 *
 * Side effects:
 *	listPtr will be converted, if necessary, to a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object to index into. */
    register int index;		/* Index of element to return. */
    Tcl_Obj **objPtrPtr;	/* The resulting Tcl_Obj* is stored here. */
{
    register List *listRepPtr;

    if (listPtr->typePtr != &tclListType) {








	int result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    if ((index < 0) || (index >= listRepPtr->elemCount)) {
	*objPtrPtr = NULL;
    } else {
	*objPtrPtr = listRepPtr->elements[index];
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjLength --
 *
 *	This procedure returns the number of elements in a list object. If
 *	the object is not already a list object, an attempt will be made to
 *	convert it to one.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *intPtr will be
 *	set to the integer count of list elements. If listPtr does not refer
 *	to a list object and the object can not be converted to one,
 *	TCL_ERROR is returned and an error message will be left in
 *	the interpreter's result if interp is not NULL.
 *
 * Side effects:
 *	The possible conversion of the argument object to a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjLength(interp, listPtr, intPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object whose #elements to return. */
    register int *intPtr;	/* The resulting int is stored here. */
{
    register List *listRepPtr;

    if (listPtr->typePtr != &tclListType) {








	int result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    *intPtr = listRepPtr->elemCount;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjReplace --
 * 
 *	This procedure replaces zero or more elements of the list referenced
 *	by listPtr with the objects from an (objc,objv) array. 
 *	The objc elements of the array referenced by objv replace the
 *	count elements in listPtr starting at first.
 *
 *	If the argument first is zero or negative, it refers to the first
 *	element. If first is greater than or equal to the number of elements
 *	in the list, then no elements are deleted; the new elements are
 *	appended to the list. Count gives the number of elements to
 *	replace. If count is zero or negative then no elements are deleted;
 *	the new elements are simply inserted before first.
 *
 *	The argument objv refers to an array of objc pointers to the new
 *	elements to be added to listPtr in place of those that were
 *	deleted. If objv is NULL, no new elements are added. If listPtr is
 *	not a list object, an attempt will be made to convert it to one.
 *
 * Results:
 *	The return value is normally TCL_OK. If listPtr does
 *	not refer to a list object and can not be converted to one,
 *	TCL_ERROR is returned and an error message will be left in
 *	the interpreter's result if interp is not NULL.
 *
 * Side effects:
 *	The ref counts of the objc elements in objv are incremented since
 *	the resulting list now refers to them. Similarly, the ref counts for
 *	replaced objects are decremented. listPtr is converted, if
 *	necessary, to a list object. listPtr's old string representation, if
 *	any, is freed. 
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *listPtr;		/* List object whose elements to replace. */
    int first;			/* Index of first element to replace. */
    int count;			/* Number of elements to replace. */
    int objc;			/* Number of objects to insert. */
    Tcl_Obj *CONST objv[];	/* An array of objc pointers to Tcl objects
				 * to insert. */
{
    List *listRepPtr;
    register Tcl_Obj **elemPtrs, **newPtrs;
    Tcl_Obj *victimPtr;
    int numElems, numRequired, numAfterLast;
    int start, shift, newMax, i, j, result;


    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjReplace called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {










	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }


    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    elemPtrs = listRepPtr->elements;
    numElems = listRepPtr->elemCount;

    if (first < 0)  {
    	first = 0;
    }
    if (first >= numElems) {
	first = numElems;	/* so we'll insert after last element */
    }
    if (count < 0) {
	count = 0;


    }


    numRequired = (numElems - count + objc);

    if (numRequired <= listRepPtr->maxElemCount) {

	/*
	 * Enough room in the current array. First "delete" count
	 * elements starting at first.
	 */

	for (i = 0, j = first;  i < count;  i++, j++) {
	    victimPtr = elemPtrs[j];
	    TclDecrRefCount(victimPtr);
	}

	/*
	 * Shift the elements after the last one removed to their
	 * new locations.
	 */

	start = (first + count);
	numAfterLast = (numElems - start);
	shift = (objc - count);	/* numNewElems - numDeleted */
	if ((numAfterLast > 0) && (shift != 0)) {
	    Tcl_Obj **src, **dst;

	    src = elemPtrs + start; dst = src + shift;
	    memmove((VOID*) dst, (VOID*) src, 
	            (size_t) (numAfterLast * sizeof(Tcl_Obj*)));
	}

	/*
	 * Insert the new elements into elemPtrs before "first".
	 */

	for (i=0,j=first ; i<objc ; i++,j++) {
	    elemPtrs[j] = objv[i];
	    Tcl_IncrRefCount(objv[i]);
	}

	/*
	 * Update the count of elements.
	 */

	listRepPtr->elemCount = numRequired;
    } else {
	/*
	 * Not enough room in the current array. Allocate a larger array and
	 * insert elements into it. 
	 */





	newMax = (2 * numRequired);



	newPtrs = (Tcl_Obj **)




	    ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));






	/*


	 * Copy over the elements before "first".
	 */

















	if (first > 0) {
	    memcpy((VOID *) newPtrs, (VOID *) elemPtrs,
		    (size_t) (first * sizeof(Tcl_Obj *)));
	}

	/*
	 * "Delete" count elements starting at first.
	 */

	for (i = 0, j = first;  i < count;  i++, j++) {
	    victimPtr = elemPtrs[j];
	    TclDecrRefCount(victimPtr);
	}

	/*
	 * Copy the elements after the last one removed, shifted to
	 * their new locations.
	 */

	start = (first + count);
	numAfterLast = (numElems - start);
	if (numAfterLast > 0) {
	    memcpy((VOID *) &(newPtrs[first + objc]),
		    (VOID *) &(elemPtrs[start]),
		    (size_t) (numAfterLast * sizeof(Tcl_Obj *)));
	}





	/*
	 * Insert the new elements before "first" and update the
	 * count of elements.
	 */

	for (i = 0, j = first;  i < objc;  i++, j++) {
	    newPtrs[j] = objv[i];
	    Tcl_IncrRefCount(objv[i]);
	}

	listRepPtr->elemCount = numRequired;
	listRepPtr->maxElemCount = newMax;

	listRepPtr->elements = newPtrs;
	ckfree((char *) elemPtrs);

    }


    /*
     * Invalidate and free any old string representation since it no longer
     * reflects the list's internal representation.
     */

    Tcl_InvalidateStringRep(listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLsetList --
 *	
 *	Core of the 'lset' command when objc == 4.  Objv[2] may be
 *	either a scalar index or a list of indices.
 *
 * Results:
 *	Returns the new value of the list variable, or NULL if an
 *	error occurs.
 *
 * Side effects:
 *	Surgery is performed on the list value to produce the
 *	result.
 *
 * On entry, the reference count of the variable value does not reflect
 * any references held on the stack.  The first action of this function
 * is to determine whether the object is shared, and to duplicate it if
 * it is.  The reference count of the duplicate is incremented.
 * At this point, the reference count will be 1 for either case, so that
 * the object will appear to be unshared.
 *
 * If an error occurs, and the object has been duplicated, the reference
 * count on the duplicate is decremented so that it is now 0: this dismisses
 * any memory that was allocated by this procedure.
 *
 * If no error occurs, the reference count of the original object is
 * incremented if the object has not been duplicated, and nothing is
 * done to a reference count of the duplicate.  Now the reference count
 * of an unduplicated object is 2 (the returned pointer, plus the one
 * stored in the variable).  The reference count of a duplicate object
 * is 1, reflecting that the returned pointer is the only active
 * reference.  The caller is expected to store the returned value back
 * in the variable and decrement its reference count.  (INST_STORE_*
 * does exactly this.)
 *
 * Tcl_LsetFlat and related functions maintain a linked list of
 * Tcl_Obj's whose string representations must be spoilt by threading
 * via 'ptr2' of the two-pointer internal representation.  On entry
 * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
 * the 'ptr2' field of any Tcl_Obj that has been modified is set to
 * NULL.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
TclLsetList(interp, listPtr, indexArgPtr, valuePtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* Pointer to the list being modified */
    Tcl_Obj* indexArgPtr;	/* Index or index-list arg to 'lset' */
    Tcl_Obj* valuePtr;		/* Value arg to 'lset' */
{
    int indexCount;		/* Number of indices in the index list */
    Tcl_Obj** indices;		/* Vector of indices in the index list*/
    int duplicated;		/* Flag == 1 if the obj has been
				 * duplicated, 0 otherwise */
    Tcl_Obj* retValuePtr;	/* Pointer to the list to be returned */
    int index;			/* Current index in the list - discarded */
    int result;			/* Status return from library calls */
    Tcl_Obj* subListPtr;	/* Pointer to the current sublist */
    int elemCount;		/* Count of elements in the current sublist */
    Tcl_Obj** elemPtrs;		/* Pointers to elements of current sublist  */
    Tcl_Obj* chainPtr;		/* Pointer to the enclosing sublist
				 * of the current sublist */
    int i;


    /*
     * Determine whether the index arg designates a list or a single
     * index.  We have to be careful about the order of the checks to
     * avoid repeated shimmering; see TIP #22 and #23 for details.
     */

    if (indexArgPtr->typePtr != &tclListType
	    && TclGetIntForIndex(NULL, indexArgPtr, 0, &index) == TCL_OK) {
	/*
	 * indexArgPtr designates a single index.
	 */

	return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);

    } else if (Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount,
	    &indices) != TCL_OK) {
	/*
	 * indexArgPtr designates something that is neither an index nor a
	 * well formed list.  Report the error via TclLsetFlat.
	 */

	return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
    }

    /*
     * At this point, we know that argPtr designates a well formed list,
     * and the 'else if' above has parsed it into indexCount and indices.
     * If there are no indices, simply return 'valuePtr', counting the
     * returned pointer as a reference.

     */

    if (indexCount == 0) {
	Tcl_IncrRefCount(valuePtr);
	return valuePtr;
    }

    /*
     * Duplicate the list arg if necessary.
     */

    if (Tcl_IsShared(listPtr)) {
	duplicated = 1;
	listPtr = Tcl_DuplicateObj(listPtr);
	Tcl_IncrRefCount(listPtr);
    } else {
	duplicated = 0;
    }

    /*
     * It would be tempting simply to go off to TclLsetFlat to finish the
     * processing.  Alas, it is also incorrect!  The problem is that
     * 'indexArgPtr' may designate a sublist of 'listPtr' whose value
     * is to be manipulated.  The fact that 'listPtr' is itself unshared
     * does not guarantee that no sublist is.  Therefore, it's necessary
     * to replicate all the work here, expanding the index list on each
     * trip through the loop.
     */

    /*
     * Anchor the linked list of Tcl_Obj's whose string reps must be
     * invalidated if the operation succeeds.
     */

    retValuePtr = listPtr;
    chainPtr = NULL;

    /*
     * Handle each index arg by diving into the appropriate sublist
     */

    for (i=0 ; ; i++) {
	/*
	 * Take the sublist apart.
	 */

	result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, &elemPtrs);
	if (result != TCL_OK) {
	    break;
	}
	listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;

	/*
	 * Reconstitute the index array
	 */

	result = Tcl_ListObjGetElements(interp, indexArgPtr, &indexCount,
		&indices);
	if (result != TCL_OK) {
	    /* 
	     * Shouldn't be able to get here, because we already
	     * parsed the thing successfully once.
	     */
	    break;
	}

	/*
	 * Determine the index of the requested element.
	 */

	result = TclGetIntForIndex(interp, indices[i], elemCount-1, &index);
	if (result != TCL_OK) {
	    break;
	}

	/*
	 * Check that the index is in range.
	 */

	if (index<0 || index>=elemCount) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("list index out of range", -1));
	    result = TCL_ERROR;
	    break;
	}

	/*
	 * Break the loop after extracting the innermost sublist
	 */

	if (i >= indexCount-1) {
	    result = TCL_OK;
	    break;
	}

	/*
	 * Extract the appropriate sublist, and make sure that it is unshared.
	 */

	subListPtr = elemPtrs[index];
	if (Tcl_IsShared(subListPtr)) {
	    subListPtr = Tcl_DuplicateObj(subListPtr);
	    result = TclListObjSetElement(interp, listPtr, index, subListPtr);
	    if (result != TCL_OK) {
		/* 
		 * We actually shouldn't be able to get here, because
		 * we've already checked everything that TclListObjSetElement
		 * checks. If we were to get here, it would result in leaking
		 * subListPtr.
		 */
		break;
	    }
	}

	/* 
	 * Chain the current sublist onto the linked list of Tcl_Obj's
	 * whose string reps must be spoilt.
	 */

	chainPtr = listPtr;
	listPtr = subListPtr;
    }

    /*
     * Store the new element into the correct slot in the innermost sublist.
     */

    if (result == TCL_OK) {
	result = TclListObjSetElement(interp, listPtr, index, valuePtr);
    }

    if (result == TCL_OK) {
	listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;

	/* Spoil all the string reps */

	while (listPtr != NULL) {
	    subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2;
	    Tcl_InvalidateStringRep(listPtr);
	    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
	    listPtr = subListPtr;
	}

	/* Return the new list if everything worked. */

	if (!duplicated) {
	    Tcl_IncrRefCount(retValuePtr);
	}
	return retValuePtr;
    }

    /* Clean up the one dangling reference otherwise */

    if (duplicated) {
	Tcl_DecrRefCount(retValuePtr);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLsetFlat --
 *
 *	Core of the 'lset' command when objc>=5.  Objv[2], ... ,
 *	objv[objc-2] contain scalar indices.
 *
 * Results:
 *	Returns the new value of the list variable, or NULL if an
 *	error occurs.
 *
 * Side effects:
 *	Surgery is performed on the list value to produce the
 *	result.
 *
 * On entry, the reference count of the variable value does not reflect
 * any references held on the stack.  The first action of this function
 * is to determine whether the object is shared, and to duplicate it if
 * it is.  The reference count of the duplicate is incremented.
 * At this point, the reference count will be 1 for either case, so that
 * the object will appear to be unshared.
 *
 * If an error occurs, and the object has been duplicated, the reference
 * count on the duplicate is decremented so that it is now 0: this dismisses
 * any memory that was allocated by this procedure.
 *
 * If no error occurs, the reference count of the original object is
 * incremented if the object has not been duplicated, and nothing is
 * done to a reference count of the duplicate.  Now the reference count
 * of an unduplicated object is 2 (the returned pointer, plus the one
 * stored in the variable).  The reference count of a duplicate object
 * is 1, reflecting that the returned pointer is the only active
 * reference.  The caller is expected to store the returned value back
 * in the variable and decrement its reference count.  (INST_STORE_*
 * does exactly this.)
 *
 * Tcl_LsetList and related functions maintain a linked list of
 * Tcl_Obj's whose string representations must be spoilt by threading
 * via 'ptr2' of the two-pointer internal representation.  On entry
 * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
 * the 'ptr2' field of any Tcl_Obj that has been modified is set to
 * NULL.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
TclLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* Pointer to the list being modified */
    int indexCount;		/* Number of index args */
    Tcl_Obj *CONST indexArray[];
				/* Index args */
    Tcl_Obj* valuePtr;		/* Value arg to 'lset' */
{
    int duplicated;		/* Flag == 1 if the obj has been
				 * duplicated, 0 otherwise */
    Tcl_Obj* retValuePtr;	/* Pointer to the list to be returned */
    int elemCount;		/* Length of one sublist being changed */
    Tcl_Obj** elemPtrs;		/* Pointers to the elements of a sublist */
    Tcl_Obj* subListPtr;	/* Pointer to the current sublist */
    int index;			/* Index of the element to replace in the
				 * current sublist */
    Tcl_Obj* chainPtr;		/* Pointer to the enclosing list of
				 * the current sublist. */
    int result;			/* Status return from library calls */
    int i;

    /*
     * If there are no indices, then simply return the new value,
     * counting the returned pointer as a reference
     */

    if (indexCount == 0) {
	Tcl_IncrRefCount(valuePtr);
	return valuePtr;
    }








<
<
|
<
>



|
|
|
|
>
>
>
|
|
|
|
|

<
>
|
<
<
>

>
|
|
|
>
|









|
|
|


|


|





|
|















|
|
|

|
<
|
<



|
|
|
|
>
>
>
|
|
|
|
|

<
>
|
<
<
>

>
|
|
|
>
|










|
|
|








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
|







|
|
|
|










<
|
<















|
|



<
<
<
<
<
<
|
<
|
<
<
>
|



>











|
|




|
|
|
|



|
|
|
|











|
|


|
|




>
>
>
>
>
>
>
>
>
|






|








|





|
|
|
|




|
|











<






|
|
|
|
|
<
<
<



















|
|
|
|


|
|
|
|
|


|
|
|
|
|












|





>
>
>
>
>
>
>
>
|






<




|
|
>


|
|
>
>
>
>
>
>
>
>
|
|
>
>
>
|
>
|
|
>
>
|
>
|
|
>
>
|
|
>



|
|


>


















|
|
|
|
|


|
|
|
|
|
|
|

















>
>
>
>
>
>
>
>
|









|










|
|



|
|
|
|
|
















>
>
>
>
>
>
>
>
|














|
|
|
|
|




|
|
|


|
|
|


|
|
|
|


|
|
|
|
|











|
|


|



>





>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
>

|


|



|



>
>


>

>
|
>

|
|


|





|
|









|
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
|


>
>
>
>
|
>
>
>
|
>
>
>
>
|
>
>

>
>
>
|
>
>
|
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|

|
|
|

|
|
|
|

|
|
|
|

|
|
|
|
|
|
|

>
>
>
>
|
|
<
|

|
|
|
|

<
<
>
|
<
>
|
>














|
|
|


|
|


|
<

|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
<













<
<


<
<
<
<
<
<

>


|
|
|














|






|
|
|
|
>


|
<
<
<
|
<
<
<
|
<
<
<
<

<
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<

<
<
<

<
<
|
<
<
<
|

<
<
<
<
<
|
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
<
<
<
<
|
<
<
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
|
<
<
<
|
<
<
<
|
<
<
|
|
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<







|
|


|
|


|
<

|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
<













|
|






|
|




|
|







158
159
160
161
162
163
164


165

166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

183
184


185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237

238

239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254

255
256


257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285


















































































































286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310

311

312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331






332

333


334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

441
442
443
444
445
446
447
448
449
450
451



452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813















814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894

895
896
897
898
899
900
901


902
903

904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930

931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957

958
959
960
961
962
963
964
965
966
967
968
969
970


971
972






973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008



1009



1010




1011


1012









1013




1014



1015


1016



1017
1018





1019



1020






























1021


1022




1023


1024
1025














1026




1027



1028



1029


1030
1031


1032

1033












1034








1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050

1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077

1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewListObj(objc, objv)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
{


    List *listRepPtr;

    Tcl_Obj *listPtr;

    TclNewObj(listPtr);

    if (objc <= 0) {
	return listPtr;
    }

    /*
     * Create the internal rep.
     */

    listRepPtr = NewListIntRep(objc, objv);
    if (!listRepPtr) {
	Tcl_Panic("Not enough memory to create the list\n");
    }


    /*
     * Now create the object.


     */

    Tcl_InvalidateStringRep(listPtr);
    listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
    listPtr->typePtr = &tclListType;
    listRepPtr->refCount++;

    return listPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewListObj --
 *
 *	This function is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
 *	as the Tcl_NewListObj function above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this function just returns the
 *	result of calling Tcl_NewListObj.
 *
 * Results:
 *	A new list object is returned that is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned. The new object's string representation is left
 *	NULL. The new list object has ref count 0.
 *
 * Side effects:
 *	The ref counts of the elements in objv are incremented since the
 *	resulting list now refers to them.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewListObj(objc, objv, file, line)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
    CONST char *file;		/* The name of the source file calling this
				 * function; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    Tcl_Obj *listPtr;

    List *listRepPtr;


    TclDbNewObj(listPtr, file, line);

    if (objc <= 0) {
	return listPtr;
    }

    /*
     * Create the internal rep.
     */

    listRepPtr = NewListIntRep(objc, objv);
    if (!listRepPtr) {
	Tcl_Panic("Not enough memory to create the list\n");
    }


    /*
     * Now create the object.


     */

    Tcl_InvalidateStringRep(listPtr);
    listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
    listPtr->typePtr = &tclListType;
    listRepPtr->refCount++;

    return listPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewListObj(objc, objv, file, line)
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
    CONST char *file;		/* The name of the source file calling this
				 * function; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *


















































































































 * Tcl_SetListObj --
 *
 *	Modify an object to be a list containing each of the objc elements of
 *	the object array referenced by objv.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object is made a list object and is initialized from the object
 *	pointers in objv. If objc is less than or equal to zero, an empty
 *	object is returned. The new object's string representation is left
 *	NULL. The ref counts of the elements in objv are incremented since the
 *	list now refers to them. The object's old string and internal
 *	representations are freed and its type is set NULL.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetListObj(objPtr, objc, objv)
    Tcl_Obj *objPtr;		/* Object whose internal rep to init. */
    int objc;			/* Count of objects referenced by objv. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to Tcl objects. */
{

    List *listRepPtr;


    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetListObj called with shared object");
    }

    /*
     * Free any old string rep and any internal rep for the old type.
     */

    TclFreeIntRep(objPtr);
    objPtr->typePtr = NULL;
    Tcl_InvalidateStringRep(objPtr);

    /*
     * Set the object's type to "list" and initialize the internal rep.
     * However, if there are no elements to put in the list, just give the
     * object an empty string rep and a NULL type.
     */

    if (objc > 0) {






	listRepPtr = NewListIntRep(objc, objv);

	if (!listRepPtr) {


	    Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj");
	}
	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
	objPtr->typePtr = &tclListType;
	listRepPtr->refCount++;
    } else {
	objPtr->bytes = tclEmptyStringRep;
	objPtr->length = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjGetElements --
 *
 *	This function returns an (objc,objv) array of the elements in a list
 *	object.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *objcPtr is set to
 *	the count of list elements and *objvPtr is set to a pointer to an
 *	array of (*objcPtr) pointers to each list element. If listPtr does not
 *	refer to a list object and the object can not be converted to one,
 *	TCL_ERROR is returned and an error message will be left in the
 *	interpreter's result if interp is not NULL.
 *
 *	The objects referenced by the returned array should be treated as
 *	readonly and their ref counts are _not_ incremented; the caller must
 *	do that if it holds on to a reference. Furthermore, the pointer and
 *	length returned by this function may change as soon as any function is
 *	called on the list object; be careful about retaining the pointer in a
 *	local data structure.
 *
 * Side effects:
 *	The possible conversion of the object referenced by listPtr
 *	to a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object for which an element array is
				 * to be returned. */
    int *objcPtr;		/* Where to store the count of objects
				 * referenced by objv. */
    Tcl_Obj ***objvPtr;		/* Where to store the pointer to an array of
				 * pointers to the list's objects. */
{
    register List *listRepPtr;

    if (listPtr->typePtr != &tclListType) {
	int result, length;

	(void) Tcl_GetStringFromObj(listPtr, &length);
	if (!length) {
	    *objcPtr = 0;
	    *objvPtr = NULL;
	    return TCL_OK;
	}

	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }
    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    *objcPtr = listRepPtr->elemCount;
    *objvPtr = &listRepPtr->elements;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendList --
 *
 *	This function appends the objects in the list referenced by
 *	elemListPtr to the list object referenced by listPtr. If listPtr is
 *	not already a list object, an attempt will be made to convert it to
 *	one.
 *
 * Results:
 *	The return value is normally TCL_OK. If listPtr or elemListPtr do not
 *	refer to list objects and they can not be converted to one, TCL_ERROR
 *	is returned and an error message is left in the interpreter's result
 *	if interp is not NULL.
 *
 * Side effects:
 *	The reference counts of the elements in elemListPtr are incremented
 *	since the list now refers to them. listPtr and elemListPtr are
 *	converted, if necessary, to list objects. Also, appending the new
 *	elements may cause listObj's array of element pointers to grow.
 *	listPtr's old string representation, if any, is invalidated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjAppendList(interp, listPtr, elemListPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object to append elements to. */
    Tcl_Obj *elemListPtr;	/* List obj with elements to append. */
{

    int listLen, objc, result;
    Tcl_Obj **objv;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjAppendList called with shared object");
    }

    result = Tcl_ListObjLength(interp, listPtr, &listLen);
    if (result != TCL_OK) {
	return result;
    }




    result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Insert objc new elements starting after the lists's last element.
     * Delete zero existing elements.
     */

    return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendElement --
 *
 *	This function is a special purpose version of Tcl_ListObjAppendList:
 *	it appends a single object referenced by objPtr to the list object
 *	referenced by listPtr. If listPtr is not already a list object, an
 *	attempt will be made to convert it to one.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case objPtr is added to
 *	the end of listPtr's list. If listPtr does not refer to a list object
 *	and the object can not be converted to one, TCL_ERROR is returned and
 *	an error message will be left in the interpreter's result if interp is
 *	not NULL.
 *
 * Side effects:
 *	The ref count of objPtr is incremented since the list now refers to
 *	it. listPtr will be converted, if necessary, to a list object. Also,
 *	appending the new element may cause listObj's array of element
 *	pointers to grow. listPtr's old string representation, if any, is
 *	invalidated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjAppendElement(interp, listPtr, objPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    Tcl_Obj *listPtr;		/* List object to append objPtr to. */
    Tcl_Obj *objPtr;		/* Object to append to listPtr's list. */
{
    register List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    int numElems, numRequired, newMax, newSize, i;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjAppendElement called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {
	int result, length;

	(void) Tcl_GetStringFromObj(listPtr, &length);
	if (!length) {
	    Tcl_SetListObj(listPtr, 1, &objPtr);
	    return TCL_OK;
	}

	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;

    numElems = listRepPtr->elemCount;
    numRequired = numElems + 1 ;

    /*
     * If there is no room in the current array of element pointers, allocate
     * a new, larger array and copy the pointers to it. If the List struct is
     * shared, allocate a new one.
     */

    if (numRequired > listRepPtr->maxElemCount){
	newMax = (2 * numRequired);
	newSize = sizeof(List)+((newMax-1)*sizeof(Tcl_Obj*));
    } else {
	newMax = listRepPtr->maxElemCount;
	newSize = 0;
    }

    if (listRepPtr->refCount > 1) {
	List *oldListRepPtr = listRepPtr;
	Tcl_Obj **oldElems;

	listRepPtr = NewListIntRep(newMax, NULL);
	if (!listRepPtr) {
	    Tcl_Panic("Not enough memory to allocate list");
	}
	oldElems = &oldListRepPtr->elements;
	elemPtrs = &listRepPtr->elements;
	for (i=0; i<numElems; i++) {
	    elemPtrs[i] = oldElems[i];
	    Tcl_IncrRefCount(elemPtrs[i]);
	}
	listRepPtr->elemCount = numElems;
	listRepPtr->refCount++;
	oldListRepPtr->refCount--;
	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    } else if (newSize) {
	listRepPtr = (List *) ckrealloc((char *)listRepPtr, newSize);
	listRepPtr->maxElemCount = newMax;
	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    }

    /*
     * Add objPtr to the end of listPtr's array of element pointers. Increment
     * the ref count for the (now shared) objPtr.
     */

    elemPtrs = &listRepPtr->elements;
    elemPtrs[numElems] = objPtr;
    Tcl_IncrRefCount(objPtr);
    listRepPtr->elemCount++;

    /*
     * Invalidate any old string representation since the list's internal
     * representation has changed.
     */

    Tcl_InvalidateStringRep(listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjIndex --
 *
 *	This function returns a pointer to the index'th object from the list
 *	referenced by listPtr. The first element has index 0. If index is
 *	negative or greater than or equal to the number of elements in the
 *	list, a NULL is returned. If listPtr is not a list object, an attempt
 *	will be made to convert it to a list.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case objPtrPtr is set to
 *	the Tcl_Obj pointer for the index'th list element or NULL if index is
 *	out of range. This object should be treated as readonly and its ref
 *	count is _not_ incremented; the caller must do that if it holds on to
 *	the reference. If listPtr does not refer to a list and can't be
 *	converted to one, TCL_ERROR is returned and an error message is left
 *	in the interpreter's result if interp is not NULL.
 *
 * Side effects:
 *	listPtr will be converted, if necessary, to a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object to index into. */
    register int index;		/* Index of element to return. */
    Tcl_Obj **objPtrPtr;	/* The resulting Tcl_Obj* is stored here. */
{
    register List *listRepPtr;

    if (listPtr->typePtr != &tclListType) {
	int result, length;

	(void) Tcl_GetStringFromObj(listPtr, &length);
	if (!length) {
	    *objPtrPtr = NULL;
	    return TCL_OK;
	}

	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    if ((index < 0) || (index >= listRepPtr->elemCount)) {
	*objPtrPtr = NULL;
    } else {
	*objPtrPtr = (&listRepPtr->elements)[index];
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjLength --
 *
 *	This function returns the number of elements in a list object. If the
 *	object is not already a list object, an attempt will be made to
 *	convert it to one.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case *intPtr will be set
 *	to the integer count of list elements. If listPtr does not refer to a
 *	list object and the object can not be converted to one, TCL_ERROR is
 *	returned and an error message will be left in the interpreter's result
 *	if interp is not NULL.
 *
 * Side effects:
 *	The possible conversion of the argument object to a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjLength(interp, listPtr, intPtr)
    Tcl_Interp *interp;		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr;	/* List object whose #elements to return. */
    register int *intPtr;	/* The resulting int is stored here. */
{
    register List *listRepPtr;

    if (listPtr->typePtr != &tclListType) {
	int result, length;

	(void) Tcl_GetStringFromObj(listPtr, &length);
	if (!length) {
	    *intPtr = 0;
	    return TCL_OK;
	}

	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    *intPtr = listRepPtr->elemCount;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjReplace --
 *
 *	This function replaces zero or more elements of the list referenced by
 *	listPtr with the objects from an (objc,objv) array. The objc elements
 *	of the array referenced by objv replace the count elements in listPtr
 *	starting at first.
 *
 *	If the argument first is zero or negative, it refers to the first
 *	element. If first is greater than or equal to the number of elements
 *	in the list, then no elements are deleted; the new elements are
 *	appended to the list. Count gives the number of elements to replace.
 *	If count is zero or negative then no elements are deleted; the new
 *	elements are simply inserted before first.
 *
 *	The argument objv refers to an array of objc pointers to the new
 *	elements to be added to listPtr in place of those that were deleted.
 *	If objv is NULL, no new elements are added. If listPtr is not a list
 *	object, an attempt will be made to convert it to one.
 *
 * Results:
 *	The return value is normally TCL_OK. If listPtr does not refer to a
 *	list object and can not be converted to one, TCL_ERROR is returned and
 *	an error message will be left in the interpreter's result if interp is
 *	not NULL.
 *
 * Side effects:
 *	The ref counts of the objc elements in objv are incremented since the
 *	resulting list now refers to them. Similarly, the ref counts for
 *	replaced objects are decremented. listPtr is converted, if necessary,
 *	to a list object. listPtr's old string representation, if any, is
 *	freed.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *listPtr;		/* List object whose elements to replace. */
    int first;			/* Index of first element to replace. */
    int count;			/* Number of elements to replace. */
    int objc;			/* Number of objects to insert. */
    Tcl_Obj *CONST objv[];	/* An array of objc pointers to Tcl objects to
				 * insert. */
{
    List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    Tcl_Obj *victimPtr;
    int numElems, numRequired, numAfterLast;
    int start, shift, newMax, i, j, result;
    int isShared;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjReplace called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {
	int length;

	(void) Tcl_GetStringFromObj(listPtr, &length);
	if (!length) {
	    if (objc) {
		Tcl_SetListObj(listPtr, objc, NULL);
	    } else {
		return TCL_OK;
	    }
	} else {
	    result = SetListFromAny(interp, listPtr);
	    if (result != TCL_OK) {
		return result;
	    }
	}
    }

    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    elemPtrs = &listRepPtr->elements;
    numElems = listRepPtr->elemCount;

    if (first < 0) {
    	first = 0;
    }
    if (first >= numElems) {
	first = numElems;	/* So we'll insert after last element. */
    }
    if (count < 0) {
	count = 0;
    } else if (numElems < first+count) {
	count = numElems - first;
    }

    isShared = (listRepPtr->refCount > 1);
    numRequired = (numElems - count + objc);

    if ((numRequired <= listRepPtr->maxElemCount)
	    && !isShared) {
	/*
	 * Can use the current List struct. First "delete" count elements
	 * starting at first.
	 */

	for (j = first;  j < first + count;  j++) {
	    victimPtr = elemPtrs[j];
	    TclDecrRefCount(victimPtr);
	}

	/*
	 * Shift the elements after the last one removed to their new
	 * locations.
	 */

	start = (first + count);
	numAfterLast = (numElems - start);
	shift = (objc - count);	/* numNewElems - numDeleted */
	if ((numAfterLast > 0) && (shift != 0)) {
	    Tcl_Obj **src, **dst;

	    src = elemPtrs + start; dst = src + shift;
	    memmove((VOID*) dst, (VOID*) src,
		    (size_t) (numAfterLast * sizeof(Tcl_Obj*)));
	}















    } else {
	/*
	 * Cannot use the current List struct - it is shared, too small, or
	 * both. Allocate a new struct and insert elements into it.
	 */

	List *oldListRepPtr = listRepPtr;
	Tcl_Obj **oldPtrs = elemPtrs;

	if (numRequired > listRepPtr->maxElemCount){
	    newMax = (2 * numRequired);
	} else {
	    newMax = listRepPtr->maxElemCount;
	}

	listRepPtr = NewListIntRep(newMax, NULL);
	if (!listRepPtr) {
	    Tcl_Panic("Not enough memory to allocate list");
	}

	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	listRepPtr->refCount++;

	elemPtrs = &listRepPtr->elements;

	if (isShared) {
	    /*
	     * The old struct will remain in place; need new refCounts for the
	     * new List struct references. Copy over only the surviving
	     * elements.
	     */

	    for (i=0; i < first; i++) {
		elemPtrs[i] = oldPtrs[i];
		Tcl_IncrRefCount(elemPtrs[i]);
	    }
	    for (i= first + count, j = first + objc;
		    j < numRequired; i++, j++) {
		elemPtrs[j] = oldPtrs[i];
		Tcl_IncrRefCount(elemPtrs[j]);
	    }

	    oldListRepPtr->refCount--;
	} else {
	    /*
	     * The old struct will be removed; use its inherited refCounts.
	     */

	    if (first > 0) {
		memcpy((VOID *) elemPtrs, (VOID *) oldPtrs,
			(size_t) (first * sizeof(Tcl_Obj *)));
	    }

	    /*
	     * "Delete" count elements starting at first.
	     */

	    for (j = first;  j < first + count;  j++) {
		victimPtr = oldPtrs[j];
		TclDecrRefCount(victimPtr);
	    }

	    /*
	     * Copy the elements after the last one removed, shifted to their
	     * new locations.
	     */

	    start = (first + count);
	    numAfterLast = (numElems - start);
	    if (numAfterLast > 0) {
		memcpy((VOID *) &(elemPtrs[first + objc]),
			(VOID *) &(oldPtrs[start]),
			(size_t) (numAfterLast * sizeof(Tcl_Obj *)));
	    }

	    ckfree((char *) oldListRepPtr);
	}
    }

    /*
     * Insert the new elements into elemPtrs before "first".

     */

    for (i=0,j=first ; i<objc ; i++,j++) {
	elemPtrs[j] = objv[i];
	Tcl_IncrRefCount(objv[i]);
    }



    /*
     * Update the count of elements.

     */

    listRepPtr->elemCount = numRequired;

    /*
     * Invalidate and free any old string representation since it no longer
     * reflects the list's internal representation.
     */

    Tcl_InvalidateStringRep(listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLsetList --
 *
 *	Core of the 'lset' command when objc == 4. Objv[2] may be either a
 *	scalar index or a list of indices.
 *
 * Results:
 *	Returns the new value of the list variable, or NULL if an error
 *	occurs.
 *
 * Side effects:
 *	Surgery is performed on the list value to produce the result.

 *
 *	On entry, the reference count of the variable value does not reflect
 *	any references held on the stack. The first action of this function is
 *	to determine whether the object is shared, and to duplicate it if it
 *	is. The reference count of the duplicate is incremented. At this
 *	point, the reference count will be 1 for either case, so that the
 *	object will appear to be unshared.
 *
 *	If an error occurs, and the object has been duplicated, the reference
 *	count on the duplicate is decremented so that it is now 0: this
 *	dismisses any memory that was allocated by this function.
 *
 *	If no error occurs, the reference count of the original object is
 *	incremented if the object has not been duplicated, and nothing is done
 *	to a reference count of the duplicate. Now the reference count of an
 *	unduplicated object is 2 (the returned pointer, plus the one stored in
 *	the variable). The reference count of a duplicate object is 1,
 *	reflecting that the returned pointer is the only active reference.
 *	The caller is expected to store the returned value back in the
 *	variable and decrement its reference count. (INST_STORE_* does exactly
 *	this.)
 *
 *	Tcl_LsetFlat and related functions maintain a linked list of Tcl_Obj's
 *	whose string representations must be spoilt by threading via 'ptr2' of
 *	the two-pointer internal representation. On entry to Tcl_LsetList, the
 *	values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
 *	Tcl_Obj that has been modified is set to NULL.

 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
TclLsetList(interp, listPtr, indexArgPtr, valuePtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* Pointer to the list being modified */
    Tcl_Obj* indexArgPtr;	/* Index or index-list arg to 'lset' */
    Tcl_Obj* valuePtr;		/* Value arg to 'lset' */
{
    int indexCount;		/* Number of indices in the index list */
    Tcl_Obj** indices;		/* Vector of indices in the index list*/


    Tcl_Obj* retValuePtr;	/* Pointer to the list to be returned */
    int index;			/* Current index in the list - discarded */






    int i;
    List *indexListRepPtr;

    /*
     * Determine whether the index arg designates a list or a single index.
     * We have to be careful about the order of the checks to avoid repeated
     * shimmering; see TIP #22 and #23 for details.
     */

    if (indexArgPtr->typePtr != &tclListType
	    && TclGetIntForIndex(NULL, indexArgPtr, 0, &index) == TCL_OK) {
	/*
	 * indexArgPtr designates a single index.
	 */

	return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);

    } else if (Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount,
	    &indices) != TCL_OK) {
	/*
	 * indexArgPtr designates something that is neither an index nor a
	 * well formed list. Report the error via TclLsetFlat.
	 */

	return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
    }

    /*
     * At this point, we know that argPtr designates a well formed list, and
     * the 'else if' above has parsed it into indexCount and indices.
     * Increase the reference count of the internal rep of indexArgPtr, in
     * order to insure the validity of pointers even if indexArgPtr shimmers
     * to another type.
     */

    if (indexCount) {



	indexListRepPtr = (List *) indexArgPtr->internalRep.twoPtrValue.ptr1;



	indexListRepPtr->refCount++;




    } else {


	indexListRepPtr = NULL; /* avoid compiler warning*/









    }








    /*


     * Let TclLsetFlat handle the actual lset'ting.



     */






    retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);


































    /*


     * If we are the only users of indexListRepPtr, we free it before




     * returning.


     */















    if (indexCount) {




	if (--indexListRepPtr->refCount <= 0) {



	    for (i=0; i<indexCount; i++) {



		Tcl_DecrRefCount(indices[i]);


	    }
	    ckfree((char *) indexListRepPtr);


	}

    }












    return retValuePtr;








}

/*
 *----------------------------------------------------------------------
 *
 * TclLsetFlat --
 *
 *	Core of the 'lset' command when objc>=5. Objv[2], ... , objv[objc-2]
 *	contain scalar indices.
 *
 * Results:
 *	Returns the new value of the list variable, or NULL if an error
 *	occurs.
 *
 * Side effects:
 *	Surgery is performed on the list value to produce the result.

 *
 *	On entry, the reference count of the variable value does not reflect
 *	any references held on the stack. The first action of this function is
 *	to determine whether the object is shared, and to duplicate it if it
 *	is. The reference count of the duplicate is incremented. At this
 *	point, the reference count will be 1 for either case, so that the
 *	object will appear to be unshared.
 *
 *	If an error occurs, and the object has been duplicated, the reference
 *	count on the duplicate is decremented so that it is now 0: this
 *	dismisses any memory that was allocated by this function.
 *
 *	If no error occurs, the reference count of the original object is
 *	incremented if the object has not been duplicated, and nothing is done
 *	to a reference count of the duplicate. Now the reference count of an
 *	unduplicated object is 2 (the returned pointer, plus the one stored in
 *	the variable). The reference count of a duplicate object is 1,
 *	reflecting that the returned pointer is the only active reference.
 *	The caller is expected to store the returned value back in the
 *	variable and decrement its reference count. (INST_STORE_* does exactly
 *	this.)
 *
 *	Tcl_LsetList and related functions maintain a linked list of Tcl_Obj's
 *	whose string representations must be spoilt by threading via 'ptr2' of
 *	the two-pointer internal representation. On entry to Tcl_LsetList, the
 *	values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
 *	Tcl_Obj that has been modified is set to NULL.

 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
TclLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* Pointer to the list being modified */
    int indexCount;		/* Number of index args */
    Tcl_Obj *CONST indexArray[];
				/* Index args */
    Tcl_Obj* valuePtr;		/* Value arg to 'lset' */
{
    int duplicated;		/* Flag == 1 if the obj has been duplicated, 0
				 * otherwise */
    Tcl_Obj* retValuePtr;	/* Pointer to the list to be returned */
    int elemCount;		/* Length of one sublist being changed */
    Tcl_Obj** elemPtrs;		/* Pointers to the elements of a sublist */
    Tcl_Obj* subListPtr;	/* Pointer to the current sublist */
    int index;			/* Index of the element to replace in the
				 * current sublist */
    Tcl_Obj* chainPtr;		/* Pointer to the enclosing list of the
				 * current sublist. */
    int result;			/* Status return from library calls */
    int i;

    /*
     * If there are no indices, then simply return the new value, counting the
     * returned pointer as a reference.
     */

    if (indexCount == 0) {
	Tcl_IncrRefCount(valuePtr);
	return valuePtr;
    }

1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245






1246
1247
1248
1249
1250
1251
1252
     * invalidated if the operation succeeds.
     */

    retValuePtr = listPtr;
    chainPtr = NULL;

    /*
     * Handle each index arg by diving into the appropriate sublist
     */

    for (i=0 ; ; i++) {
	/*
	 * Take the sublist apart.
	 */

	result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, &elemPtrs);
	if (result != TCL_OK) {
	    break;






	}
	listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;

	/*
	 * Determine the index of the requested element.
	 */








|










>
>
>
>
>
>







1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
     * invalidated if the operation succeeds.
     */

    retValuePtr = listPtr;
    chainPtr = NULL;

    /*
     * Handle each index arg by diving into the appropriate sublist.
     */

    for (i=0 ; ; i++) {
	/*
	 * Take the sublist apart.
	 */

	result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, &elemPtrs);
	if (result != TCL_OK) {
	    break;
	}
	if (elemCount == 0) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("list index out of range", -1));
	    result = TCL_ERROR;
	    break;
	}
	listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;

	/*
	 * Determine the index of the requested element.
	 */

1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292

1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
	 */

	subListPtr = elemPtrs[index];
	if (Tcl_IsShared(subListPtr)) {
	    subListPtr = Tcl_DuplicateObj(subListPtr);
	    result = TclListObjSetElement(interp, listPtr, index, subListPtr);
	    if (result != TCL_OK) {
		/* 
		 * We actually shouldn't be able to get here.
		 * If we do, it would result in leaking subListPtr,
		 * but everything's been validated already; the error
		 * exit from TclListObjSetElement should never happen.
		 */

		break;
	    }
	}

	/* 
	 * Chain the current sublist onto the linked list of Tcl_Obj's
	 * whose string reps must be spoilt.
	 */

	chainPtr = listPtr;
	listPtr = subListPtr;
    }

    /* Store the result in the list element */







|
|
|
|
|

>




|
|
|







1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
	 */

	subListPtr = elemPtrs[index];
	if (Tcl_IsShared(subListPtr)) {
	    subListPtr = Tcl_DuplicateObj(subListPtr);
	    result = TclListObjSetElement(interp, listPtr, index, subListPtr);
	    if (result != TCL_OK) {
		/*
		 * We actually shouldn't be able to get here. If we do, it
		 * would result in leaking subListPtr, but everything's been
		 * validated already; the error exit from TclListObjSetElement
		 * should never happen.
		 */

		break;
	    }
	}

	/*
	 * Chain the current sublist onto the linked list of Tcl_Obj's whose
	 * string reps must be spoilt.
	 */

	chainPtr = listPtr;
	listPtr = subListPtr;
    }

    /* Store the result in the list element */
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386

1387

1388

1389
1390
1391
1392
1393








1394
1395
1396
1397
1398

1399
1400
1401

1402

1403

1404
1405
1406
1407
1408
1409
1410
1411
1412






















1413

1414
1415
1416

1417

1418
1419
1420

1421

1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456

1457
1458
1459
1460
1461
1462

1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
 *----------------------------------------------------------------------
 *
 * TclListObjSetElement --
 *
 *	Set a single element of a list to a specified value
 *
 * Results:
 *
 *	The return value is normally TCL_OK.  If listPtr does not
 *	refer to a list object and cannot be converted to one, TCL_ERROR
 *	is returned and an error message will be left in the interpreter
 *	result if interp is not NULL.  Similarly, if index designates
 *	an element outside the range [0..listLength-1], where
 *	listLength is the count of elements in the list object designated
 *	by listPtr, TCL_ERROR is returned and an error message is left
 *	in the interpreter result.
 *
 * Side effects:
 *
 *	Tcl_Panic if listPtr designates a shared object.  Otherwise,
 *	attempts to convert it to a list.  Decrements the ref count of
 *	the object at the specified index within the list, replaces with
 *	the object designated by valuePtr, and increments the ref count
 *	of the replacement object.  
 *
 * It is the caller's responsibility to invalidate the string
 * representation of the object.
 *
 *----------------------------------------------------------------------
 */

int
TclListObjSetElement(interp, listPtr, index, valuePtr)
    Tcl_Interp* interp;		/* Tcl interpreter; used for error reporting
				 * if not NULL */
    Tcl_Obj* listPtr;		/* List object in which element should be
				 * stored */
    int index;			/* Index of element to store */
    Tcl_Obj* valuePtr;		/* Tcl object to store in the designated
				 * list element */
{
    int result;			/* Return value from this function */
    List* listRepPtr;		/* Internal representation of the list
				 * being modified */
    Tcl_Obj** elemPtrs;		/* Pointers to elements of the list */
    int elemCount;		/* Number of elements in the list */



    /* Ensure that the listPtr parameter designates an unshared list */


    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjSetElement called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {








	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1;
    elemPtrs = listRepPtr->elements;
    elemCount = listRepPtr->elemCount;



    /* Ensure that the index is in bounds */


    if (index<0 || index>=elemCount) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("list index out of range", -1));
	    return TCL_ERROR;
	}
    }























    /* Add a reference to the new list element */


    Tcl_IncrRefCount(valuePtr);


    /* Remove a reference from the old list element */


    Tcl_DecrRefCount(elemPtrs[index]);


    /* Stash the new object in the list */


    elemPtrs[index] = valuePtr;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeListInternalRep --
 *
 *	Deallocate the storage associated with a list object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees listPtr's List* internal representation and sets listPtr's
 *	internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts
 *	of all element objects, which may free them.
 *
 *----------------------------------------------------------------------
 */

static void
FreeListInternalRep(listPtr)
    Tcl_Obj *listPtr;		/* List object with internal rep to free. */
{
    register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    register Tcl_Obj **elemPtrs = listRepPtr->elements;
    register Tcl_Obj *objPtr;
    int numElems = listRepPtr->elemCount;
    int i;


    for (i = 0;  i < numElems;  i++) {
	objPtr = elemPtrs[i];
	Tcl_DecrRefCount(objPtr);
    }
    ckfree((char *) elemPtrs);
    ckfree((char *) listRepPtr);


    listPtr->internalRep.twoPtrValue.ptr1 = NULL;
    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DupListInternalRep --
 *
 *	Initialize the internal representation of a list Tcl_Obj to a
 *	copy of the internal representation of an existing list object. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	"srcPtr"s list internal rep pointer should not be NULL and we assume
 *	it is not NULL. We set "copyPtr"s internal rep to a pointer to a
 *	newly allocated List structure that, in turn, points to "srcPtr"s
 *	element objects. Those element objects are not actually copied but
 *	are shared between "srcPtr" and "copyPtr". The ref count of each
 *	element object is incremented.
 *
 *----------------------------------------------------------------------
 */

static void
DupListInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;		/* Object with internal rep to set. */
{
    List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;
    int numElems = srcListRepPtr->elemCount;
    int maxElems = srcListRepPtr->maxElemCount;
    register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements;
    register Tcl_Obj **copyElemPtrs;
    register List *copyListRepPtr;
    int i;

    /*
     * Allocate a new List structure that points to "srcPtr"s element
     * objects. Increment the ref counts for those (now shared) element
     * objects.
     */

    copyElemPtrs = (Tcl_Obj **)
	ckalloc((unsigned) maxElems * sizeof(Tcl_Obj *));
    for (i = 0;  i < numElems;  i++) {
	copyElemPtrs[i] = srcElemPtrs[i];
	Tcl_IncrRefCount(copyElemPtrs[i]);
    }

    copyListRepPtr = (List *) ckalloc(sizeof(List));
    copyListRepPtr->maxElemCount = maxElems;
    copyListRepPtr->elemCount    = numElems;
    copyListRepPtr->elements     = copyElemPtrs;

    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
    copyPtr->typePtr = &tclListType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetListFromAny --
 *
 *	Attempt to generate a list internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is TCL_OK or TCL_ERROR. If an error occurs during
 *	conversion, an error message is left in the interpreter's result
 *	unless "interp" is NULL.
 *
 * Side effects:







<
|
|
|
|
<
|
|
|


<
|
|
|
|
|

|
|











|
|


|
|


>

>
|
>





>
>
>
>
>
>
>
>





>

<

>

>
|
>









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>



>
|
>



>
|
>



















|
|









|




>
|
|
|
|
<
|
>










|
|





|
<
<
<
<
<









|
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|









|
<







1248
1249
1250
1251
1252
1253
1254

1255
1256
1257
1258

1259
1260
1261
1262
1263

1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315

1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406

1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426





1427
1428
1429
1430
1431
1432
1433
1434
1435
1436






1437














1438



1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449

1450
1451
1452
1453
1454
1455
1456
 *----------------------------------------------------------------------
 *
 * TclListObjSetElement --
 *
 *	Set a single element of a list to a specified value
 *
 * Results:

 *	The return value is normally TCL_OK. If listPtr does not refer to a
 *	list object and cannot be converted to one, TCL_ERROR is returned and
 *	an error message will be left in the interpreter result if interp is
 *	not NULL. Similarly, if index designates an element outside the range

 *	[0..listLength-1], where listLength is the count of elements in the
 *	list object designated by listPtr, TCL_ERROR is returned and an error
 *	message is left in the interpreter result.
 *
 * Side effects:

 *	Tcl_Panic if listPtr designates a shared object. Otherwise, attempts
 *	to convert it to a list with a non-shared internal rep. Decrements the
 *	ref count of the object at the specified index within the list,
 *	replaces with the object designated by valuePtr, and increments the
 *	ref count of the replacement object.
 *
 *	It is the caller's responsibility to invalidate the string
 *	representation of the object.
 *
 *----------------------------------------------------------------------
 */

int
TclListObjSetElement(interp, listPtr, index, valuePtr)
    Tcl_Interp* interp;		/* Tcl interpreter; used for error reporting
				 * if not NULL */
    Tcl_Obj* listPtr;		/* List object in which element should be
				 * stored */
    int index;			/* Index of element to store */
    Tcl_Obj* valuePtr;		/* Tcl object to store in the designated list
				 * element */
{
    int result;			/* Return value from this function */
    List* listRepPtr;		/* Internal representation of the list being
				 * modified */
    Tcl_Obj** elemPtrs;		/* Pointers to elements of the list */
    int elemCount;		/* Number of elements in the list */
    int i;

    /*
     * Ensure that the listPtr parameter designates an unshared list.
     */

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("Tcl_ListObjSetElement called with shared object");
    }
    if (listPtr->typePtr != &tclListType) {
	int length;

	(void) Tcl_GetStringFromObj(listPtr, &length);
	if (!length) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("list index out of range", -1));
	    return TCL_ERROR;
	}
	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1;

    elemCount = listRepPtr->elemCount;
    elemPtrs = &listRepPtr->elements;

    /*
     * Ensure that the index is in bounds.
     */

    if (index<0 || index>=elemCount) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("list index out of range", -1));
	    return TCL_ERROR;
	}
    }

    /*
     * If the internal rep is shared, replace it with an unshared copy.
     */

    if (listRepPtr->refCount > 1) {
	List *oldListRepPtr = listRepPtr;
	Tcl_Obj **oldElemPtrs = elemPtrs;

	listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL);
	listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag;
	elemPtrs = &listRepPtr->elements;
	for (i=0; i < elemCount; i++) {
	    elemPtrs[i] = oldElemPtrs[i];
	    Tcl_IncrRefCount(elemPtrs[i]);
	}
	listRepPtr->refCount++;
	listRepPtr->elemCount = elemCount;
	listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
	oldListRepPtr->refCount--;
    }

    /*
     * Add a reference to the new list element.
     */

    Tcl_IncrRefCount(valuePtr);

    /*
     * Remove a reference from the old list element.
     */

    Tcl_DecrRefCount(elemPtrs[index]);

    /*
     * Stash the new object in the list.
     */

    elemPtrs[index] = valuePtr;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeListInternalRep --
 *
 *	Deallocate the storage associated with a list object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees listPtr's List* internal representation and sets listPtr's
 *	internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all
 *	element objects, which may free them.
 *
 *----------------------------------------------------------------------
 */

static void
FreeListInternalRep(listPtr)
    Tcl_Obj *listPtr;		/* List object with internal rep to free. */
{
    register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    register Tcl_Obj **elemPtrs = &listRepPtr->elements;
    register Tcl_Obj *objPtr;
    int numElems = listRepPtr->elemCount;
    int i;

    if (--listRepPtr->refCount <= 0) {
	for (i = 0;  i < numElems;  i++) {
	    objPtr = elemPtrs[i];
	    Tcl_DecrRefCount(objPtr);
	}

	ckfree((char *) listRepPtr);
    }

    listPtr->internalRep.twoPtrValue.ptr1 = NULL;
    listPtr->internalRep.twoPtrValue.ptr2 = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DupListInternalRep --
 *
 *	Initialize the internal representation of a list Tcl_Obj to share the
 *	internal representation of an existing list object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count of the List internal rep is incremented.





 *
 *----------------------------------------------------------------------
 */

static void
DupListInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;		/* Object with internal rep to set. */
{
    List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;





















    listRepPtr->refCount++;



    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
    copyPtr->typePtr = &tclListType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetListFromAny --
 *
 *	Attempt to generate a list internal form for the Tcl object "objPtr".

 *
 * Results:
 *	The return value is TCL_OK or TCL_ERROR. If an error occurs during
 *	conversion, an error message is left in the interpreter's result
 *	unless "interp" is NULL.
 *
 * Side effects:
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589






1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642

1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681

1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697

1698
1699
1700
1701








1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
















     * Get the string representation. Make it up-to-date if necessary.
     */

    string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Parse the string into separate string objects, and create a List
     * structure that points to the element string objects. We use a
     * modified version of Tcl_SplitList's implementation to avoid one
     * malloc and a string copy for each list element. First, estimate the
     * number of elements by counting the number of space characters in the
     * list.
     */

    limit = (string + length);
    estCount = 1;
    for (p = string;  p < limit;  p++) {
	if (isspace(UCHAR(*p))) { /* INTL: ISO space. */
	    estCount++;
	}
    }

    /*
     * Allocate a new List structure with enough room for "estCount"
     * elements. Each element is a pointer to a Tcl_Obj with the appropriate
     * string rep. The initial "estCount" elements are set using the
     * corresponding "argv" strings.
     */







    elemPtrs = (Tcl_Obj **)
	    ckalloc((unsigned) (estCount * sizeof(Tcl_Obj *)));
    for (p = string, lenRemain = length, i = 0;
	    lenRemain > 0;
	    p = nextElem, lenRemain = (limit - nextElem), i++) {
	result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem,
				&elemSize, &hasBrace);
	if (result != TCL_OK) {
	    for (j = 0;  j < i;  j++) {
		elemPtr = elemPtrs[j];
		Tcl_DecrRefCount(elemPtr);
	    }
	    ckfree((char *) elemPtrs);
	    return result;
	}
	if (elemStart >= limit) {
	    break;
	}
	if (i > estCount) {
	    Tcl_Panic("SetListFromAny: bad size estimate for list");
	}

	/*
	 * Allocate a Tcl object for the element and initialize it from the
	 * "elemSize" bytes starting at "elemStart".
	 */

	s = ckalloc((unsigned) elemSize + 1);
	if (hasBrace) {
	    memcpy((VOID *) s, (VOID *) elemStart,  (size_t) elemSize);
	    s[elemSize] = 0;
	} else {
	    elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
	}

	TclNewObj(elemPtr);
	elemPtr->bytes  = s;
	elemPtr->length = elemSize;
	elemPtrs[i] = elemPtr;
	Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */
    }

    listRepPtr = (List *) ckalloc(sizeof(List));
    listRepPtr->maxElemCount = estCount;
    listRepPtr->elemCount    = i;
    listRepPtr->elements     = elemPtrs;

    /*
     * Free the old internalRep before setting the new one. We do this as
     * late as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */


    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclListType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfList --
 *
 *	Update the string representation for a list object.
 *	Note: This procedure does not invalidate an existing old string rep
 *	so storage will be lost if this has not already been done. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the list-to-string conversion. This string will be empty if the
 *	list has no elements. The list internal representation
 *	should not be NULL and we assume it is not NULL.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfList(listPtr)
    Tcl_Obj *listPtr;		/* List object with string rep to update. */
{
#   define LOCAL_SIZE 20
    int localFlags[LOCAL_SIZE], *flagPtr;
    List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    int numElems = listRepPtr->elemCount;
    register int i;
    char *elem, *dst;
    int length;


    /*
     * Convert each element of the list to string form and then convert it
     * to proper list element form, adding it to the result buffer.
     */

    /*
     * Pass 1: estimate space, gather flags.
     */

    if (numElems <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else {
	flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
    }
    listPtr->length = 1;

    for (i = 0; i < numElems; i++) {
	elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length);
	listPtr->length += Tcl_ScanCountedElement(elem, length,
		&flagPtr[i]) + 1;








    }

    /*
     * Pass 2: copy into string rep buffer.
     */

    listPtr->bytes = ckalloc((unsigned) listPtr->length);
    dst = listPtr->bytes;
    for (i = 0; i < numElems; i++) {
	elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length);
	dst += Tcl_ConvertCountedElement(elem, length, dst,
		flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH));
	*dst = ' ';
	dst++;
    }
    if (flagPtr != localFlags) {
	ckfree((char *) flagPtr);
    }
    if (dst == listPtr->bytes) {
	*dst = 0;
    } else {
	dst--;
	*dst = 0;
    }
    listPtr->length = dst - listPtr->bytes;
}























|
|
|
|
<











|
|
|
|


>
>
>
>
>
>
|
|




|





|
















|






|


|


<
<
|
<


|
|



>












|
|
|





|
|
|
|















>


|
|












>

|


>
>
>
>
>
>
>
>









|















|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488

1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553


1554

1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
     * Get the string representation. Make it up-to-date if necessary.
     */

    string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Parse the string into separate string objects, and create a List
     * structure that points to the element string objects. We use a modified
     * version of Tcl_SplitList's implementation to avoid one malloc and a
     * string copy for each list element. First, estimate the number of
     * elements by counting the number of space characters in the list.

     */

    limit = (string + length);
    estCount = 1;
    for (p = string;  p < limit;  p++) {
	if (isspace(UCHAR(*p))) { /* INTL: ISO space. */
	    estCount++;
	}
    }

    /*
     * Allocate a new List structure with enough room for "estCount" elements.
     * Each element is a pointer to a Tcl_Obj with the appropriate string rep.
     * The initial "estCount" elements are set using the corresponding "argv"
     * strings.
     */

    listRepPtr = NewListIntRep(estCount, NULL);
    if (!listRepPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"Not enough memory to allocate the list internal rep", -1));
	return TCL_ERROR;
    }
    elemPtrs = &listRepPtr->elements;

    for (p = string, lenRemain = length, i = 0;
	    lenRemain > 0;
	    p = nextElem, lenRemain = (limit - nextElem), i++) {
	result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem,
		&elemSize, &hasBrace);
	if (result != TCL_OK) {
	    for (j = 0;  j < i;  j++) {
		elemPtr = elemPtrs[j];
		Tcl_DecrRefCount(elemPtr);
	    }
	    ckfree((char *) listRepPtr);
	    return result;
	}
	if (elemStart >= limit) {
	    break;
	}
	if (i > estCount) {
	    Tcl_Panic("SetListFromAny: bad size estimate for list");
	}

	/*
	 * Allocate a Tcl object for the element and initialize it from the
	 * "elemSize" bytes starting at "elemStart".
	 */

	s = ckalloc((unsigned) elemSize + 1);
	if (hasBrace) {
	    memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize);
	    s[elemSize] = 0;
	} else {
	    elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
	}

	TclNewObj(elemPtr);
	elemPtr->bytes = s;
	elemPtr->length = elemSize;
	elemPtrs[i] = elemPtr;
	Tcl_IncrRefCount(elemPtr);	/* since list now holds ref to it */
    }



    listRepPtr->elemCount = i;


    /*
     * Free the old internalRep before setting the new one. We do this as late
     * as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

    listRepPtr->refCount++;
    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclListType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfList --
 *
 *	Update the string representation for a list object. Note: This
 *	function does not invalidate an existing old string rep so storage
 *	will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from the
 *	list-to-string conversion. This string will be empty if the list has
 *	no elements. The list internal representation should not be NULL and
 *	we assume it is not NULL.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfList(listPtr)
    Tcl_Obj *listPtr;		/* List object with string rep to update. */
{
#   define LOCAL_SIZE 20
    int localFlags[LOCAL_SIZE], *flagPtr;
    List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
    int numElems = listRepPtr->elemCount;
    register int i;
    char *elem, *dst;
    int length;
    Tcl_Obj **elemPtrs;

    /*
     * Convert each element of the list to string form and then convert it to
     * proper list element form, adding it to the result buffer.
     */

    /*
     * Pass 1: estimate space, gather flags.
     */

    if (numElems <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else {
	flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
    }
    listPtr->length = 1;
    elemPtrs = &listRepPtr->elements;
    for (i = 0; i < numElems; i++) {
	elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
	listPtr->length += Tcl_ScanCountedElement(elem, length,
		&flagPtr[i]) + 1;

	/*
	 * Check for continued sanity. [Bug 1267380]
	 */

	if (listPtr->length < 1) {
	    Tcl_Panic("string representation size exceeds sane bounds");
	}
    }

    /*
     * Pass 2: copy into string rep buffer.
     */

    listPtr->bytes = ckalloc((unsigned) listPtr->length);
    dst = listPtr->bytes;
    for (i = 0; i < numElems; i++) {
	elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
	dst += Tcl_ConvertCountedElement(elem, length, dst,
		flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH));
	*dst = ' ';
	dst++;
    }
    if (flagPtr != localFlags) {
	ckfree((char *) flagPtr);
    }
    if (dst == listPtr->bytes) {
	*dst = 0;
    } else {
	dst--;
	*dst = 0;
    }
    listPtr->length = dst - listPtr->bytes;

    /*
     * Mark the list as being canonical; although it has a string rep, it is
     * one we derived through proper "canonical" quoting and so it's known to
     * be free from nasties relating to [concat] and [eval].
     */

    listRepPtr->canonicalFlag = 1;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclLiteral.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
/* 
 * tclLiteral.c --
 *
 *	Implementation of the global and ByteCode-local literal tables
 *	used to manage the Tcl objects created for literal values during
 *	compilation of Tcl scripts. This implementation borrows heavily
 *	from the more general hashtable implementation of Tcl hash tables
 *	that appears in tclHash.c.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLiteral.c,v 1.20 2004/08/02 15:33:36 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
/*
 * When there are this many entries per bucket, on average, rebuild
 * a literal's hash table to make it larger.
 */

#define REBUILD_MULTIPLIER	3

/*
 * Procedure prototypes for static procedures in this file:
 */
|


|
|
|
|
|




|
|

|





|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
/*
 * tclLiteral.c --
 *
 *	Implementation of the global and ByteCode-local literal tables used to
 *	manage the Tcl objects created for literal values during compilation
 *	of Tcl scripts. This implementation borrows heavily from the more
 *	general hashtable implementation of Tcl hash tables that appears in
 *	tclHash.c.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLiteral.c,v 1.20.2.3 2005/08/02 18:16:00 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
/*
 * When there are this many entries per bucket, on average, rebuild a
 * literal's hash table to make it larger.
 */

#define REBUILD_MULTIPLIER	3

/*
 * Procedure prototypes for static procedures in this file:
 */
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

100

101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262


263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305












306
307
308
309
310
311
312

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352

353
354
355
356




357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372
373
374
375

376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395

396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411

412
413
414
415
416
417

418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
 *	This procedure is called to initialize the fields of a literal table
 *	structure for either an interpreter or a compilation's CompileEnv
 *	structure.
 *
 * Results:
 *	None.
 *
 * Side effects: 
 *	The literal table is made ready for use.
 *
 *----------------------------------------------------------------------
 */

void
TclInitLiteralTable(tablePtr)
    register LiteralTable *tablePtr; /* Pointer to table structure, which

				      * is supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4) 
    Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
	    TCL_SMALL_HASH_TABLE);
#endif
    
    tablePtr->buckets = tablePtr->staticBuckets;
    tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
    tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
    tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
    tablePtr->numEntries = 0;
    tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
    tablePtr->mask = 3;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupLiteralTable --
 *
 *	This procedure frees the internal representation of every
 *	literal in a literal table.  It is called prior to deleting
 *	an interp, so that variable refs will be cleaned up properly.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Each literal in the table has its internal representation freed.
 *
 *----------------------------------------------------------------------
 */

void
TclCleanupLiteralTable( interp, tablePtr )
    Tcl_Interp* interp;         /* Interpreter containing literals to purge */

    LiteralTable* tablePtr;     /* Points to the literal table being cleaned */

{
    int i;
    LiteralEntry* entryPtr;     /* Pointer to the current entry in the
                                 * hash table of literals */
    LiteralEntry* nextPtr;      /* Pointer to the next entry in tbe
                                 * bucket */
    Tcl_Obj* objPtr;            /* Pointer to a literal object whose internal
                                 * rep is being freed */
    Tcl_ObjType* typePtr;       /* Pointer to the object's type */
    int didOne;                 /* Flag for whether we've removed a literal
                                 * in the current bucket */

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable( (Interp*) interp );
#endif /* TCL_COMPILE_DEBUG */

    for ( i = 0; i < tablePtr->numBuckets; i++ ) {

        /* 
         * It is tempting simply to walk each hash bucket once and
         * delete the internal representations of each literal in turn.
         * It's also wrong.  The problem is that freeing a literal's
         * internal representation can delete other literals to which
         * it refers, making nextPtr invalid.  So each time we free an
         * internal rep, we start its bucket over again.
         */
        didOne = 1;
        while ( didOne ) {

            didOne = 0;
            entryPtr = tablePtr->buckets[i];
            while ( entryPtr != NULL ) {
                objPtr = entryPtr->objPtr;
                nextPtr = entryPtr->nextPtr;
                typePtr = objPtr->typePtr;
                if ( ( typePtr != NULL )
                     && ( typePtr->freeIntRepProc != NULL ) ) {
                    if ( objPtr->bytes == NULL ) {
                      Tcl_Panic( "literal without a string rep" );
                    }
                    objPtr->typePtr = NULL;
                    typePtr->freeIntRepProc( objPtr );
                    didOne = 1;
                } else {
                    entryPtr = nextPtr;
                }
            }
        }
    }
}
	    

/*
 *----------------------------------------------------------------------
 *
 * TclDeleteLiteralTable --
 *
 *	This procedure frees up everything associated with a literal table
 *	except for the table's structure itself. It is called when the
 *	interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Each literal in the table is released: i.e., its reference count
 *	in the global literal table is decremented and, if it becomes zero,
 *	the literal is freed. In addition, the table's bucket array is
 *	freed.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteLiteralTable(interp, tablePtr)
    Tcl_Interp *interp;		/* Interpreter containing shared literals
				 * referenced by the table to delete. */
    LiteralTable *tablePtr;	/* Points to the literal table to delete. */
{
    LiteralEntry *entryPtr, *nextPtr;
    Tcl_Obj *objPtr;
    int i;
    
    /*
     * Release remaining literals in the table. Note that releasing a
     * literal might release other literals, modifying the table, so we
     * restart the search from the bucket chain we last found an entry.
     */

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable((Interp *) interp);
#endif /*TCL_COMPILE_DEBUG*/

    /*
     * We used to call TclReleaseLiteral for each literal in the table, which
     * is rather inefficient as it causes one lookup-by-hash for each
     * reference to the literal.
     * We now rely at interp-deletion on each bytecode object to release its
     * references to the literal Tcl_Obj without requiring that it updates the
     * global table itself, and deal here only with the table.
     */

    for (i = 0;  i < tablePtr->numBuckets;  i++) {
	entryPtr = tablePtr->buckets[i];
	while (entryPtr != NULL) {
	    objPtr = entryPtr->objPtr;
	    TclDecrRefCount(objPtr);
	    nextPtr = entryPtr->nextPtr;
	    ckfree((char *) entryPtr);
	    entryPtr = nextPtr;
	}
    }
    
    /*
     * Free up the table's bucket array if it was dynamically allocated.
     */

    if (tablePtr->buckets != tablePtr->staticBuckets) {
	ckfree((char *) tablePtr->buckets);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclRegisterLiteral --
 *
 *	Find, or if necessary create, an object in a CompileEnv literal
 *	array that has a string representation matching the argument string.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references a
 *	shared literal matching the string. The object is created if
 *	necessary.
 *
 * Side effects:
 *	To maximize sharing, we look up the string in the interpreter's
 *	global literal table. If not found, we create a new shared literal
 *	in the global table. We then add a reference to the shared
 *	literal in the CompileEnv's literal array. 
 *
 *	If onHeap is 1, this procedure is given ownership of the string: if
 *	an object is created then its string representation is set directly
 *	from string, otherwise the string is freed. Typically, a caller sets
 *	onHeap 1 if "string" is an already heap-allocated buffer holding the
 *	result of backslash substitutions.
 *
 *----------------------------------------------------------------------
 */

int
TclRegisterLiteral(envPtr, bytes, length, onHeap)
    CompileEnv *envPtr;		/* Points to the CompileEnv in whose object
				 * array an object is found or created. */
    register char *bytes;	/* Points to string for which to find or
				 * create an object in CompileEnv's object
				 * array. */
    int length;			/* Number of bytes in the string. If < 0,
				 * the string consists of all bytes up to
				 * the first null character. */
    int onHeap;			/* If 1 then the caller already malloc'd
				 * bytes and ownership is passed to this
				 * procedure. */


{
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *globalTablePtr = &(iPtr->literalTable);
    LiteralTable *localTablePtr = &(envPtr->localLitTable);
    register LiteralEntry *globalPtr, *localPtr;
    register Tcl_Obj *objPtr;
    unsigned int hash;
    int localHash, globalHash, objIndex;
    long n;
    char buf[TCL_INTEGER_SPACE];

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }
    hash = HashString(bytes, length);

    /*
     * Is the literal already in the CompileEnv's local literal array?
     * If so, just return its index.
     */

    localHash = (hash & localTablePtr->mask);
    for (localPtr = localTablePtr->buckets[localHash];
	  localPtr != NULL;  localPtr = localPtr->nextPtr) {
	objPtr = localPtr->objPtr;
	if ((objPtr->length == length) && ((length == 0)
		|| ((objPtr->bytes[0] == bytes[0])
			&& (memcmp(objPtr->bytes, bytes, (unsigned) length)
				== 0)))) {
	    if (onHeap) {
		ckfree(bytes);
	    }
	    objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/

	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. Is it in the interpreter's












     * global literal table?
     */

    globalHash = (hash & globalTablePtr->mask);
    for (globalPtr = globalTablePtr->buckets[globalHash];
	 globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
	objPtr = globalPtr->objPtr;

	if ((objPtr->length == length) && ((length == 0)
		|| ((objPtr->bytes[0] == bytes[0])
			&& (memcmp(objPtr->bytes, bytes, (unsigned) length)
				== 0)))) {
	    /*
	     * A global literal was found. Add an entry to the CompileEnv's
	     * local literal array.
	     */
	    
	    if (onHeap) {
		ckfree(bytes);
	    }
	    objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
	    if (globalPtr->refCount < 1) {
		Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
			(length>60? 60 : length), bytes,
			globalPtr->refCount);
	    }
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/ 
	    return objIndex;
	}
    }

    /*
     * The literal is new to the interpreter. Add it to the global literal
     * table then add an entry to the CompileEnv's local literal array.
     * Convert the object to an integer object if possible.
     */

    TclNewObj(objPtr);
    Tcl_IncrRefCount(objPtr);
    if (onHeap) {
	objPtr->bytes = bytes;
	objPtr->length = length;
    } else {
	TclInitStringRep(objPtr, bytes, length);
    }


    if (TclLooksLikeInt(bytes, length)) {
	/*
	 * From here we use the objPtr, because it is NULL terminated
	 */




	if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
	    TclFormatInt(buf, n);
	    if (strcmp(objPtr->bytes, buf) == 0) {
		objPtr->internalRep.longValue = n;
		objPtr->typePtr = &tclIntType;
	    }
	}
    }

    
#ifdef TCL_COMPILE_DEBUG
    if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
	Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
	        (length>60? 60 : length), bytes);
    }
#endif

    globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
    globalPtr->objPtr = objPtr;
    globalPtr->refCount = 0;

    globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
    globalTablePtr->buckets[globalHash] = globalPtr;
    globalTablePtr->numEntries++;

    /*
     * If the global literal table has exceeded a decent size, rebuild it
     * with more buckets.
     */

    if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
	RebuildLiteralTable(globalTablePtr);
    }
    objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable(iPtr);
    TclVerifyLocalLiteralTable(envPtr);
    {
	LiteralEntry *entryPtr;
	int found, i;

	found = 0;
	for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
	    for (entryPtr = globalTablePtr->buckets[i];
		    entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
		if ((entryPtr == globalPtr)
		        && (entryPtr->objPtr == objPtr)) {
		    found = 1;
		}
	    }
	}
	if (!found) {
	    Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
	            (length>60? 60 : length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

#ifdef TCL_COMPILE_STATS   
    iPtr->stats.numLiteralsCreated++;
    iPtr->stats.totalLitStringBytes   += (double) (length + 1);
    iPtr->stats.currentLitStringBytes += (double) (length + 1);
    iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupLiteralEntry --
 *
 *	Finds the LiteralEntry that corresponds to a literal Tcl object
 *      holding a literal.
 *
 * Results:
 *      Returns the matching LiteralEntry if found, otherwise NULL.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

LiteralEntry *
TclLookupLiteralEntry(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter for which objPtr was created
                                 * to hold a literal. */
    register Tcl_Obj *objPtr;	/* Points to a Tcl object holding a
                                 * literal that was previously created by a
                                 * call to TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
    LiteralTable *globalTablePtr = &(iPtr->literalTable);
    register LiteralEntry *entryPtr;
    char *bytes;
    int length, globalHash;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    globalHash = (HashString(bytes, length) & globalTablePtr->mask);
    for (entryPtr = globalTablePtr->buckets[globalHash];
            entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
        if (entryPtr->objPtr == objPtr) {
            return entryPtr;
        }
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclHideLiteral --
 *
 *	Remove a literal entry from the literal hash tables, leaving it in
 *	the literal array so existing references continue to function.
 *	This makes it possible to turn a shared literal into a private
 *	literal that cannot be shared.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the literal from the local hash table and decrements the
 *	global hash entry's reference count.
 *
 *----------------------------------------------------------------------
 */

void
TclHideLiteral(interp, envPtr, index)
    Tcl_Interp *interp;		 /* Interpreter for which objPtr was created
                                  * to hold a literal. */
    register CompileEnv *envPtr; /* Points to CompileEnv whose literal array
				  * contains the entry being hidden. */
    int index;			 /* The index of the entry in the literal
				  * array. */
{
    LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
    LiteralTable *localTablePtr = &(envPtr->localLitTable);
    int localHash, length;
    char *bytes;
    Tcl_Obj *newObjPtr;

    lPtr = &(envPtr->literalArrayPtr[index]);

    /*
     * To avoid unwanted sharing we need to copy the object and remove it from
     * the local and global literal tables.  It still has a slot in the literal
     * array so it can be referred to by byte codes, but it will not be matched
     * by literal searches.
     */

    newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
    Tcl_IncrRefCount(newObjPtr);
    TclReleaseLiteral(interp, lPtr->objPtr);
    lPtr->objPtr = newObjPtr;

    bytes = Tcl_GetStringFromObj(newObjPtr, &length);
    localHash = (HashString(bytes, length) & localTablePtr->mask);
    nextPtrPtr = &localTablePtr->buckets[localHash];

    for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {
	if (entryPtr == lPtr) {
	    *nextPtrPtr = lPtr->nextPtr;
	    lPtr->nextPtr = NULL;
	    localTablePtr->numEntries--;
	    break;
	}
	nextPtrPtr = &entryPtr->nextPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclAddLiteralObj --
 *
 *	Add a single literal object to the literal array.  This
 *	function does not add the literal to the local or global
 *	literal tables.  The caller is expected to add the entry
 *	to whatever tables are appropriate.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references the
 *	literal.  Stores the pointer to the new literal entry in the
 *	location referenced by the localPtrPtr argument.
 *
 * Side effects:
 *	Expands the literal array if necessary.  Increments the refcount
 *	on the literal object.
 *
 *----------------------------------------------------------------------
 */

int
TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
    register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
				  * array the object is to be inserted. */
    Tcl_Obj *objPtr;		 /* The object to insert into the array. */
    LiteralEntry **litPtrPtr;	 /* The location where the pointer to the
				  * new literal entry should be stored.
				  * May be NULL. */
{
    register LiteralEntry *lPtr;
    int objIndex;

    if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
	ExpandLocalLiteralArray(envPtr);
    }







|







|
>
|

|



|














|
|
|












|
>
|
>


|
|
|
<
|
|
|
|
|





|
<
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|


<














|
|
|
<













|

|
|
|









|
|
|
|












|














|
|


|
|
<


|
|
|
|

|
|
|
|
|





|





|
|
|
|
|
|
>
>








|
<


|




|
|




|



|
<
|












|
>
>
>
>
>
>
>
>
>
>
>
>
|




|

>
|

|
<




|
|






|
<


|












|






>




>
>
>
>








>
|



|






>





|
|













>

|
|
|
|
<






|



>
|

|



>









|


|


|






|
|
|
|
|










|
|
|
|









|
|
|
|













|
|
|
|
|
|











|
|
|











|















|
|
<
|



|
|


|
|






|
|
|
|
|
|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108

109
110
111
112
113
114
115
116
117
118
119

120
121
122
123
124
125
126
127
128

129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149

150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230

231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288

289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325

326
327
328
329
330
331
332
333
334
335
336
337
338

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550

551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
 *	This procedure is called to initialize the fields of a literal table
 *	structure for either an interpreter or a compilation's CompileEnv
 *	structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The literal table is made ready for use.
 *
 *----------------------------------------------------------------------
 */

void
TclInitLiteralTable(tablePtr)
    register LiteralTable *tablePtr;
				/* Pointer to table structure, which is
				 * supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
    Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
	    TCL_SMALL_HASH_TABLE);
#endif

    tablePtr->buckets = tablePtr->staticBuckets;
    tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
    tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
    tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
    tablePtr->numEntries = 0;
    tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
    tablePtr->mask = 3;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupLiteralTable --
 *
 *	This procedure frees the internal representation of every literal in a
 *	literal table.  It is called prior to deleting an interp, so that
 *	variable refs will be cleaned up properly.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Each literal in the table has its internal representation freed.
 *
 *----------------------------------------------------------------------
 */

void
TclCleanupLiteralTable( interp, tablePtr )
    Tcl_Interp* interp;		/* Interpreter containing literals to
				 * purge. */
    LiteralTable* tablePtr;	/* Points to the literal table being
				 * cleaned. */
{
    int i;
    LiteralEntry* entryPtr;	/* Pointer to the current entry in the hash
				 * table of literals. */
    LiteralEntry* nextPtr;	/* Pointer to the next entry in the bucket. */

    Tcl_Obj* objPtr;		/* Pointer to a literal object whose internal
				 * rep is being freed. */
    Tcl_ObjType* typePtr;	/* Pointer to the object's type. */
    int didOne;			/* Flag for whether we've removed a literal in
				 * the current bucket. */

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable( (Interp*) interp );
#endif /* TCL_COMPILE_DEBUG */

    for (i=0 ; i<tablePtr->numBuckets ; i++) {

	/*
	 * It is tempting simply to walk each hash bucket once and delete the
	 * internal representations of each literal in turn. It's also wrong.
	 * The problem is that freeing a literal's internal representation can
	 * delete other literals to which it refers, making nextPtr invalid.
	 * So each time we free an internal rep, we start its bucket over
	 * again.
	 */


	do {
	    didOne = 0;
	    entryPtr = tablePtr->buckets[i];
	    while (entryPtr != NULL) {
		objPtr = entryPtr->objPtr;
		nextPtr = entryPtr->nextPtr;
		typePtr = objPtr->typePtr;

		if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
		    if (objPtr->bytes == NULL) {
			Tcl_Panic( "literal without a string rep" );
		    }
		    objPtr->typePtr = NULL;
		    typePtr->freeIntRepProc(objPtr);
		    didOne = 1;
		} else {
		    entryPtr = nextPtr;
		}
	    }
	} while (didOne);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * TclDeleteLiteralTable --
 *
 *	This procedure frees up everything associated with a literal table
 *	except for the table's structure itself. It is called when the
 *	interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Each literal in the table is released: i.e., its reference count in
 *	the global literal table is decremented and, if it becomes zero, the
 *	literal is freed. In addition, the table's bucket array is freed.

 *
 *----------------------------------------------------------------------
 */

void
TclDeleteLiteralTable(interp, tablePtr)
    Tcl_Interp *interp;		/* Interpreter containing shared literals
				 * referenced by the table to delete. */
    LiteralTable *tablePtr;	/* Points to the literal table to delete. */
{
    LiteralEntry *entryPtr, *nextPtr;
    Tcl_Obj *objPtr;
    int i;

    /*
     * Release remaining literals in the table. Note that releasing a literal
     * might release other literals, modifying the table, so we restart the
     * search from the bucket chain we last found an entry.
     */

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable((Interp *) interp);
#endif /*TCL_COMPILE_DEBUG*/

    /*
     * We used to call TclReleaseLiteral for each literal in the table, which
     * is rather inefficient as it causes one lookup-by-hash for each
     * reference to the literal.  We now rely at interp-deletion on each
     * bytecode object to release its references to the literal Tcl_Obj
     * without requiring that it updates the global table itself, and deal
     * here only with the table.
     */

    for (i = 0;  i < tablePtr->numBuckets;  i++) {
	entryPtr = tablePtr->buckets[i];
	while (entryPtr != NULL) {
	    objPtr = entryPtr->objPtr;
	    TclDecrRefCount(objPtr);
	    nextPtr = entryPtr->nextPtr;
	    ckfree((char *) entryPtr);
	    entryPtr = nextPtr;
	}
    }

    /*
     * Free up the table's bucket array if it was dynamically allocated.
     */

    if (tablePtr->buckets != tablePtr->staticBuckets) {
	ckfree((char *) tablePtr->buckets);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclRegisterLiteral --
 *
 *	Find, or if necessary create, an object in a CompileEnv literal array
 *	that has a string representation matching the argument string.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references a shared
 *	literal matching the string. The object is created if necessary.

 *
 * Side effects:
 *	To maximize sharing, we look up the string in the interpreter's global
 *	literal table. If not found, we create a new shared literal in the
 *	global table. We then add a reference to the shared literal in the
 *	CompileEnv's literal array.
 *
 *	If LITERAL_ON_HEAP is set in flags, this procedure is given ownership
 *	of the string: if an object is created then its string representation
 *	is set directly from string, otherwise the string is freed. Typically,
 *	a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
 *	buffer holding the result of backslash substitutions.
 *
 *----------------------------------------------------------------------
 */

int
TclRegisterLiteral(envPtr, bytes, length, flags)
    CompileEnv *envPtr;		/* Points to the CompileEnv in whose object
				 * array an object is found or created. */
    register char *bytes;	/* Points to string for which to find or
				 * create an object in CompileEnv's object
				 * array. */
    int length;			/* Number of bytes in the string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    int flags;			/* If LITERAL_ON_HEAP then the caller already
				 * malloc'd bytes and ownership is passed to
				 * this procedure. If LITERAL_NS_SCOPE then
				 * the literal shouldnot be shared accross
				 * namespaces. */
{
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *globalTablePtr = &(iPtr->literalTable);
    LiteralTable *localTablePtr = &(envPtr->localLitTable);
    register LiteralEntry *globalPtr, *localPtr;
    register Tcl_Obj *objPtr;
    unsigned int hash;
    int localHash, globalHash, objIndex;
    Namespace *nsPtr;


    if (length < 0) {
	length = (bytes ? strlen(bytes) : 0);
    }
    hash = HashString(bytes, length);

    /*
     * Is the literal already in the CompileEnv's local literal array?  If so,
     * just return its index.
     */

    localHash = (hash & localTablePtr->mask);
    for (localPtr = localTablePtr->buckets[localHash];
	    localPtr != NULL;  localPtr = localPtr->nextPtr) {
	objPtr = localPtr->objPtr;
	if ((objPtr->length == length) && ((length == 0)
		|| ((objPtr->bytes[0] == bytes[0])
		&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {

	    if (flags & LITERAL_ON_HEAP) {
		ckfree(bytes);
	    }
	    objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/

	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. Should it be shared accross
     * namespaces? If it is a fully qualified name, the namespace
     * specification is not needed to avoid sharing.
     */

    if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr
	    && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) {
	nsPtr = iPtr->varFramePtr->nsPtr;
    } else {
	nsPtr = NULL;
    }

    /*
     * Is it in the interpreter's global literal table?
     */

    globalHash = (hash & globalTablePtr->mask);
    for (globalPtr = globalTablePtr->buckets[globalHash];
	    globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
	objPtr = globalPtr->objPtr;
	if ((globalPtr->nsPtr == nsPtr)
		&& (objPtr->length == length) && ((length == 0)
		|| ((objPtr->bytes[0] == bytes[0])
		&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {

	    /*
	     * A global literal was found. Add an entry to the CompileEnv's
	     * local literal array.
	     */

	    if (flags & LITERAL_ON_HEAP) {
		ckfree(bytes);
	    }
	    objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
	    if (globalPtr->refCount < 1) {
		Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
			(length>60? 60 : length), bytes, globalPtr->refCount);

	    }
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
	    return objIndex;
	}
    }

    /*
     * The literal is new to the interpreter. Add it to the global literal
     * table then add an entry to the CompileEnv's local literal array.
     * Convert the object to an integer object if possible.
     */

    TclNewObj(objPtr);
    Tcl_IncrRefCount(objPtr);
    if (flags & LITERAL_ON_HEAP) {
	objPtr->bytes = bytes;
	objPtr->length = length;
    } else {
	TclInitStringRep(objPtr, bytes, length);
    }

#if 0
    if (TclLooksLikeInt(bytes, length)) {
	/*
	 * From here we use the objPtr, because it is NULL terminated
	 */

	long n;
	char buf[TCL_INTEGER_SPACE];

	if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
	    TclFormatInt(buf, n);
	    if (strcmp(objPtr->bytes, buf) == 0) {
		objPtr->internalRep.longValue = n;
		objPtr->typePtr = &tclIntType;
	    }
	}
    }
#endif

#ifdef TCL_COMPILE_DEBUG
    if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
	Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
		(length>60? 60 : length), bytes);
    }
#endif

    globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
    globalPtr->objPtr = objPtr;
    globalPtr->refCount = 0;
    globalPtr->nsPtr = nsPtr;
    globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
    globalTablePtr->buckets[globalHash] = globalPtr;
    globalTablePtr->numEntries++;

    /*
     * If the global literal table has exceeded a decent size, rebuild it with
     * more buckets.
     */

    if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
	RebuildLiteralTable(globalTablePtr);
    }
    objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable(iPtr);
    TclVerifyLocalLiteralTable(envPtr);
    {
	LiteralEntry *entryPtr;
	int found, i;

	found = 0;
	for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
	    for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ;
		    entryPtr=entryPtr->nextPtr) {
		if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {

		    found = 1;
		}
	    }
	}
	if (!found) {
	    Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
		    (length>60? 60 : length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numLiteralsCreated++;
    iPtr->stats.totalLitStringBytes += (double) (length + 1);
    iPtr->stats.currentLitStringBytes += (double) (length + 1);
    iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupLiteralEntry --
 *
 *	Finds the LiteralEntry that corresponds to a literal Tcl object
 *	holding a literal.
 *
 * Results:
 *	Returns the matching LiteralEntry if found, otherwise NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

LiteralEntry *
TclLookupLiteralEntry(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register Tcl_Obj *objPtr;	/* Points to a Tcl object holding a literal
				 * that was previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
    LiteralTable *globalTablePtr = &(iPtr->literalTable);
    register LiteralEntry *entryPtr;
    char *bytes;
    int length, globalHash;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    globalHash = (HashString(bytes, length) & globalTablePtr->mask);
    for (entryPtr = globalTablePtr->buckets[globalHash];
	    entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
	if (entryPtr->objPtr == objPtr) {
	    return entryPtr;
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclHideLiteral --
 *
 *	Remove a literal entry from the literal hash tables, leaving it in the
 *	literal array so existing references continue to function. This makes
 *	it possible to turn a shared literal into a private literal that
 *	cannot be shared.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the literal from the local hash table and decrements the
 *	global hash entry's reference count.
 *
 *----------------------------------------------------------------------
 */

void
TclHideLiteral(interp, envPtr, index)
    Tcl_Interp *interp;		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register CompileEnv *envPtr;/* Points to CompileEnv whose literal array
				 * contains the entry being hidden. */
    int index;			/* The index of the entry in the literal
				 * array. */
{
    LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
    LiteralTable *localTablePtr = &(envPtr->localLitTable);
    int localHash, length;
    char *bytes;
    Tcl_Obj *newObjPtr;

    lPtr = &(envPtr->literalArrayPtr[index]);

    /*
     * To avoid unwanted sharing we need to copy the object and remove it from
     * the local and global literal tables.  It still has a slot in the
     * literal array so it can be referred to by byte codes, but it will not
     * be matched by literal searches.
     */

    newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
    Tcl_IncrRefCount(newObjPtr);
    TclReleaseLiteral(interp, lPtr->objPtr);
    lPtr->objPtr = newObjPtr;

    bytes = Tcl_GetStringFromObj(newObjPtr, &length);
    localHash = (HashString(bytes, length) & localTablePtr->mask);
    nextPtrPtr = &localTablePtr->buckets[localHash];

    for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
	if (entryPtr == lPtr) {
	    *nextPtrPtr = lPtr->nextPtr;
	    lPtr->nextPtr = NULL;
	    localTablePtr->numEntries--;
	    break;
	}
	nextPtrPtr = &entryPtr->nextPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclAddLiteralObj --
 *
 *	Add a single literal object to the literal array. This function does
 *	not add the literal to the local or global literal tables. The caller

 *	is expected to add the entry to whatever tables are appropriate.
 *
 * Results:
 *	The index in the CompileEnv's literal array that references the
 *	literal. Stores the pointer to the new literal entry in the location
 *	referenced by the localPtrPtr argument.
 *
 * Side effects:
 *	Expands the literal array if necessary. Increments the refcount on the
 *	literal object.
 *
 *----------------------------------------------------------------------
 */

int
TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
    register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array
				 * the object is to be inserted. */
    Tcl_Obj *objPtr;		/* The object to insert into the array. */
    LiteralEntry **litPtrPtr;	/* The location where the pointer to the new
				 * literal entry should be stored. May be
				 * NULL. */
{
    register LiteralEntry *lPtr;
    int objIndex;

    if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
	ExpandLocalLiteralArray(envPtr);
    }
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
 *
 * Results:
 *	The index in the CompileEnv's literal array that references the
 *	literal.
 *
 * Side effects:
 *	Increments the ref count of the global LiteralEntry since the
 *	CompileEnv now refers to the literal. Expands the literal array
 *	if necessary. May rebuild the hash bucket array of the CompileEnv's
 *	literal array if it becomes too large.
 *
 *----------------------------------------------------------------------
 */

static int
AddLocalLiteralEntry(envPtr, globalPtr, localHash)
    register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
				  * array the object is to be inserted. */
    LiteralEntry *globalPtr;	 /* Points to the global LiteralEntry for
				  * the literal to add to the CompileEnv. */
    int localHash;		 /* Hash value for the literal's string. */
{
    register LiteralTable *localTablePtr = &(envPtr->localLitTable);
    LiteralEntry *localPtr;
    int objIndex;
    
    objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);

    /*
     * Add the literal to the local table.
     */

    localPtr->nextPtr = localTablePtr->buckets[localHash];







|
|







|
|
|
|
|




|







602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
 *
 * Results:
 *	The index in the CompileEnv's literal array that references the
 *	literal.
 *
 * Side effects:
 *	Increments the ref count of the global LiteralEntry since the
 *	CompileEnv now refers to the literal. Expands the literal array if
 *	necessary. May rebuild the hash bucket array of the CompileEnv's
 *	literal array if it becomes too large.
 *
 *----------------------------------------------------------------------
 */

static int
AddLocalLiteralEntry(envPtr, globalPtr, localHash)
    register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array
				 * the object is to be inserted. */
    LiteralEntry *globalPtr;	/* Points to the global LiteralEntry for the
				 * literal to add to the CompileEnv. */
    int localHash;		/* Hash value for the literal's string. */
{
    register LiteralTable *localTablePtr = &(envPtr->localLitTable);
    LiteralEntry *localPtr;
    int objIndex;

    objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);

    /*
     * Add the literal to the local table.
     */

    localPtr->nextPtr = localTablePtr->buckets[localHash];
631
632
633
634
635
636
637

638
639
640
641
642
643
644
645
646

647
648
649
650
651
652
653

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884

885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(envPtr);
    {
	char *bytes;
	int length, found, i;

	found = 0;
	for (i = 0;  i < localTablePtr->numBuckets;  i++) {
	    for (localPtr = localTablePtr->buckets[i];
		    localPtr != NULL;  localPtr = localPtr->nextPtr) {
		if (localPtr->objPtr == globalPtr->objPtr) {
		    found = 1;
		}
	    }
	}

	if (!found) {
	    bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
	    Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
	            (length>60? 60 : length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * ExpandLocalLiteralArray --
 *
 *	Procedure that uses malloc to allocate more storage for a
 *	CompileEnv's local literal array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The literal array in *envPtr is reallocated to a new array of
 *	double the size, and if envPtr->mallocedLiteralArray is non-zero
 *	the old array is freed. Entries are copied from the old array
 *	to the new one. The local literal table is updated to refer to
 *	the new entries.
 *
 *----------------------------------------------------------------------
 */

static void
ExpandLocalLiteralArray(envPtr)
    register CompileEnv *envPtr; /* Points to the CompileEnv whose object
				  * array must be enlarged. */
{
    /*
     * The current allocated local literal entries are stored between
     * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
     */

    LiteralTable *localTablePtr = &(envPtr->localLitTable);
    int currElems = envPtr->literalArrayNext;
    size_t currBytes = (currElems * sizeof(LiteralEntry));
    register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
    register LiteralEntry *newArrayPtr =
	    (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
    int i;
    
    /*
     * Copy from the old literal array to the new, then update the local
     * literal table's bucket array.
     */

    memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
    for (i = 0;  i < currElems;  i++) {
	if (currArrayPtr[i].nextPtr == NULL) {
	    newArrayPtr[i].nextPtr = NULL;
	} else {
	    newArrayPtr[i].nextPtr = newArrayPtr
		    + (currArrayPtr[i].nextPtr - currArrayPtr);
	}
    }
    for (i = 0;  i < localTablePtr->numBuckets;  i++) {
	if (localTablePtr->buckets[i] != NULL) {
	    localTablePtr->buckets[i] = newArrayPtr
	            + (localTablePtr->buckets[i] - currArrayPtr);
	}
    }

    /*
     * Free the old literal array if needed, and mark the new literal
     * array as malloced.
     */
    
    if (envPtr->mallocedLiteralArray) {
	ckfree((char *) currArrayPtr);
    }
    envPtr->literalArrayPtr = newArrayPtr;
    envPtr->literalArrayEnd = (2 * currElems);
    envPtr->mallocedLiteralArray = 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclReleaseLiteral --
 *
 *	This procedure releases a reference to one of the shared Tcl objects
 *	that hold literals. It is called to release the literals referenced
 *	by a ByteCode that is being destroyed, and it is also called by
 *	TclDeleteLiteralTable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count for the global LiteralTable entry that 
 *	corresponds to the literal is decremented. If no other reference
 *	to a global literal object remains, it is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclReleaseLiteral(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter for which objPtr was created
				 * to hold a literal. */
    register Tcl_Obj *objPtr;	/* Points to a literal object that was
				 * previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
    LiteralTable *globalTablePtr = &(iPtr->literalTable);
    register LiteralEntry *entryPtr, *prevPtr;
    char *bytes;
    int length, index;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    index = (HashString(bytes, length) & globalTablePtr->mask);

    /*
     * Check to see if the object is in the global literal table and 
     * remove this reference.  The object may not be in the table if
     * it is a hidden local literal.
     */

    for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
	    entryPtr != NULL;
	    prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
	if (entryPtr->objPtr == objPtr) {
	    entryPtr->refCount--;

	    /*
	     * If the literal is no longer being used by any ByteCode,
	     * delete the entry then remove the reference corresponding 
	     * to the global literal table entry (decrement the ref count 
	     * of the object).
	     */
		
	    if (entryPtr->refCount == 0) {
		if (prevPtr == NULL) {
		    globalTablePtr->buckets[index] = entryPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = entryPtr->nextPtr;
		}
		ckfree((char *) entryPtr);
		globalTablePtr->numEntries--;

		TclDecrRefCount(objPtr);

#ifdef TCL_COMPILE_STATS
		iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
	    }
	    break;
	}
    }

    /*
     * Remove the reference corresponding to the local literal table
     * entry.
     */

    Tcl_DecrRefCount(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * HashString --
 *
 *	Compute a one-word summary of a text string, which can be
 *	used to generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in
 *	string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
HashString(bytes, length)
    register CONST char *bytes; /* String for which to compute hash
				 * value. */
    int length;			/* Number of bytes in the string. */
{
    register unsigned int result;
    register int i;

    /*
     * I tried a zillion different hash functions and asked many other
     * people for advice.  Many people had their own favorite functions,
     * all different, but no-one had much idea why they were good ones.
     * I chose the one below (multiply by 9 and add new character)
     * because of the following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings,
     *    and multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
     *    character's bits hang around in the low-order bits of the
     *    hash value for ever, plus they spread fairly rapidly up to
     *    the high-order bits to fill out the hash value.  This seems
     *    works well both for decimal and non-decimal strings.
     */

    result = 0;
    for (i=0 ; i<length ; i++) {
	result += (result<<3) + bytes[i];
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * RebuildLiteralTable --
 *
 *	This procedure is invoked when the ratio of entries to hash buckets
 *	becomes too large in a local or global literal table. It allocates
 *	a larger bucket array and moves the entries into the new buckets.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets reallocated and entries get rehashed into new buckets.
 *
 *----------------------------------------------------------------------
 */

static void
RebuildLiteralTable(tablePtr)
    register LiteralTable *tablePtr; /* Local or global table to enlarge. */

{
    LiteralEntry **oldBuckets;
    register LiteralEntry **oldChainPtr, **newChainPtr;
    register LiteralEntry *entryPtr;
    LiteralEntry **bucketPtr;
    char *bytes;
    int oldSize, count, index, length;

    oldSize = tablePtr->numBuckets;
    oldBuckets = tablePtr->buckets;

    /*
     * Allocate and initialize the new bucket array, and set up
     * hashing constants for new array size.
     */

    tablePtr->numBuckets *= 4;
    tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
	    (tablePtr->numBuckets * sizeof(LiteralEntry *)));
    for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
	    count > 0;
	    count--, newChainPtr++) {
	*newChainPtr = NULL;
    }
    tablePtr->rebuildSize *= 4;
    tablePtr->mask = (tablePtr->mask << 2) + 3;

    /*
     * Rehash all of the existing entries into the new bucket array.
     */

    for (oldChainPtr = oldBuckets;
	    oldSize > 0;
	    oldSize--, oldChainPtr++) {
	for (entryPtr = *oldChainPtr;  entryPtr != NULL;
	        entryPtr = *oldChainPtr) {
	    bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
	    index = (HashString(bytes, length) & tablePtr->mask);
	    
	    *oldChainPtr = entryPtr->nextPtr;
	    bucketPtr = &(tablePtr->buckets[index]);
	    entryPtr->nextPtr = *bucketPtr;
	    *bucketPtr = entryPtr;
	}
    }








>

|
|
|





>



|



>








|
|





|
|
|
|
<






|
|


|
|









|






|



|
|


|

|
|




|
|

|














|
|






|
|
|






|
|














|
|
|









|
|
|
<

|




















|
<










|
|


|
<









|
<






|
|
|
|
|

|
|

|
|
|
|















|
|












|
>












|
|

















|
<
<
<
|


|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691

692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801

802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824

825
826
827
828
829
830
831
832
833
834
835
836
837
838
839

840
841
842
843
844
845
846
847
848
849

850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931



932
933
934
935
936
937
938
939
940
941
942
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(envPtr);
    {
	char *bytes;
	int length, found, i;

	found = 0;
	for (i=0 ; i<localTablePtr->numBuckets ; i++) {
	    for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
		    localPtr=localPtr->nextPtr) {
		if (localPtr->objPtr == globalPtr->objPtr) {
		    found = 1;
		}
	    }
	}

	if (!found) {
	    bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
	    Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
		    (length>60? 60 : length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * ExpandLocalLiteralArray --
 *
 *	Procedure that uses malloc to allocate more storage for a CompileEnv's
 *	local literal array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The literal array in *envPtr is reallocated to a new array of double
 *	the size, and if envPtr->mallocedLiteralArray is non-zero the old
 *	array is freed. Entries are copied from the old array to the new one.
 *	The local literal table is updated to refer to the new entries.

 *
 *----------------------------------------------------------------------
 */

static void
ExpandLocalLiteralArray(envPtr)
    register CompileEnv *envPtr;/* Points to the CompileEnv whose object array
				 * must be enlarged. */
{
    /*
     * The current allocated local literal entries are stored between elements
     * 0 and (envPtr->literalArrayNext - 1) [inclusive].
     */

    LiteralTable *localTablePtr = &(envPtr->localLitTable);
    int currElems = envPtr->literalArrayNext;
    size_t currBytes = (currElems * sizeof(LiteralEntry));
    register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
    register LiteralEntry *newArrayPtr =
	    (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
    int i;

    /*
     * Copy from the old literal array to the new, then update the local
     * literal table's bucket array.
     */

    memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
    for (i=0 ; i<currElems ; i++) {
	if (currArrayPtr[i].nextPtr == NULL) {
	    newArrayPtr[i].nextPtr = NULL;
	} else {
	    newArrayPtr[i].nextPtr =
		    newArrayPtr + (currArrayPtr[i].nextPtr - currArrayPtr);
	}
    }
    for (i=0 ; i<localTablePtr->numBuckets ; i++) {
	if (localTablePtr->buckets[i] != NULL) {
	    localTablePtr->buckets[i] =
		    newArrayPtr + (localTablePtr->buckets[i] - currArrayPtr);
	}
    }

    /*
     * Free the old literal array if needed, and mark the new literal array as
     * malloced.
     */

    if (envPtr->mallocedLiteralArray) {
	ckfree((char *) currArrayPtr);
    }
    envPtr->literalArrayPtr = newArrayPtr;
    envPtr->literalArrayEnd = (2 * currElems);
    envPtr->mallocedLiteralArray = 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclReleaseLiteral --
 *
 *	This procedure releases a reference to one of the shared Tcl objects
 *	that hold literals. It is called to release the literals referenced by
 *	a ByteCode that is being destroyed, and it is also called by
 *	TclDeleteLiteralTable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count for the global LiteralTable entry that corresponds
 *	to the literal is decremented. If no other reference to a global
 *	literal object remains, it is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclReleaseLiteral(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register Tcl_Obj *objPtr;	/* Points to a literal object that was
				 * previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
    LiteralTable *globalTablePtr = &(iPtr->literalTable);
    register LiteralEntry *entryPtr, *prevPtr;
    char *bytes;
    int length, index;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    index = (HashString(bytes, length) & globalTablePtr->mask);

    /*
     * Check to see if the object is in the global literal table and remove
     * this reference. The object may not be in the table if it is a hidden
     * local literal.
     */

    for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
	    entryPtr != NULL;
	    prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
	if (entryPtr->objPtr == objPtr) {
	    entryPtr->refCount--;

	    /*
	     * If the literal is no longer being used by any ByteCode, delete
	     * the entry then remove the reference corresponding to the global
	     * literal table entry (decrement the ref count of the object).

	     */

	    if (entryPtr->refCount == 0) {
		if (prevPtr == NULL) {
		    globalTablePtr->buckets[index] = entryPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = entryPtr->nextPtr;
		}
		ckfree((char *) entryPtr);
		globalTablePtr->numEntries--;

		TclDecrRefCount(objPtr);

#ifdef TCL_COMPILE_STATS
		iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
	    }
	    break;
	}
    }

    /*
     * Remove the reference corresponding to the local literal table entry.

     */

    Tcl_DecrRefCount(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * HashString --
 *
 *	Compute a one-word summary of a text string, which can be used to
 *	generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in string.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
HashString(bytes, length)
    register CONST char *bytes; /* String for which to compute hash value. */

    int length;			/* Number of bytes in the string. */
{
    register unsigned int result;
    register int i;

    /*
     * I tried a zillion different hash functions and asked many other people
     * for advice. Many people had their own favorite functions, all
     * different, but no-one had much idea why they were good ones. I chose
     * the one below (multiply by 9 and add new character) because of the
     * following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
     *	  multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
     *	  character's bits hang around in the low-order bits of the hash value
     *	  for ever, plus they spread fairly rapidly up to the high-order bits
     *	  to fill out the hash value. This seems works well both for decimal
     *	  and non-decimal strings.
     */

    result = 0;
    for (i=0 ; i<length ; i++) {
	result += (result<<3) + bytes[i];
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * RebuildLiteralTable --
 *
 *	This procedure is invoked when the ratio of entries to hash buckets
 *	becomes too large in a local or global literal table. It allocates a
 *	larger bucket array and moves the entries into the new buckets.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets reallocated and entries get rehashed into new buckets.
 *
 *----------------------------------------------------------------------
 */

static void
RebuildLiteralTable(tablePtr)
    register LiteralTable *tablePtr;
				/* Local or global table to enlarge. */
{
    LiteralEntry **oldBuckets;
    register LiteralEntry **oldChainPtr, **newChainPtr;
    register LiteralEntry *entryPtr;
    LiteralEntry **bucketPtr;
    char *bytes;
    int oldSize, count, index, length;

    oldSize = tablePtr->numBuckets;
    oldBuckets = tablePtr->buckets;

    /*
     * Allocate and initialize the new bucket array, and set up hashing
     * constants for new array size.
     */

    tablePtr->numBuckets *= 4;
    tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
	    (tablePtr->numBuckets * sizeof(LiteralEntry *)));
    for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
	    count > 0;
	    count--, newChainPtr++) {
	*newChainPtr = NULL;
    }
    tablePtr->rebuildSize *= 4;
    tablePtr->mask = (tablePtr->mask << 2) + 3;

    /*
     * Rehash all of the existing entries into the new bucket array.
     */

    for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {



	for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
	    bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
	    index = (HashString(bytes, length) & tablePtr->mask);

	    *oldChainPtr = entryPtr->nextPtr;
	    bucketPtr = &(tablePtr->buckets[index]);
	    entryPtr->nextPtr = *bucketPtr;
	    *bucketPtr = entryPtr;
	}
    }

939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLiteralStats --
 *
 *	Return statistics describing the layout of the hash table
 *	in its hash buckets.
 *
 * Results:
 *	The return value is a malloc-ed string containing information
 *	about tablePtr.  It is the caller's responsibility to free
 *	this string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclLiteralStats(tablePtr)
    LiteralTable *tablePtr;	/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    int count[NUM_COUNTERS], overflow, i, j;
    double average, tmp;
    register LiteralEntry *entryPtr;
    char *result, *p;

    /*
     * Compute a histogram of bucket usage. For each bucket chain i,
     * j is the number of entries in the chain.
     */

    for (i = 0;  i < NUM_COUNTERS;  i++) {
	count[i] = 0;
    }
    overflow = 0;
    average = 0.0;
    for (i = 0;  i < tablePtr->numBuckets;  i++) {
	j = 0;
	for (entryPtr = tablePtr->buckets[i];  entryPtr != NULL;
	        entryPtr = entryPtr->nextPtr) {
	    j++;
	}
	if (j < NUM_COUNTERS) {
	    count[j]++;
	} else {
	    overflow++;
	}







|
|


|
|
<


















|
|










|







951
952
953
954
955
956
957
958
959
960
961
962
963

964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLiteralStats --
 *
 *	Return statistics describing the layout of the hash table in its hash
 *	buckets.
 *
 * Results:
 *	The return value is a malloc-ed string containing information about
 *	tablePtr. It is the caller's responsibility to free this string.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclLiteralStats(tablePtr)
    LiteralTable *tablePtr;	/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    int count[NUM_COUNTERS], overflow, i, j;
    double average, tmp;
    register LiteralEntry *entryPtr;
    char *result, *p;

    /*
     * Compute a histogram of bucket usage. For each bucket chain i, j is the
     * number of entries in the chain.
     */

    for (i = 0;  i < NUM_COUNTERS;  i++) {
	count[i] = 0;
    }
    overflow = 0;
    average = 0.0;
    for (i = 0;  i < tablePtr->numBuckets;  i++) {
	j = 0;
	for (entryPtr = tablePtr->buckets[i];  entryPtr != NULL;
		entryPtr = entryPtr->nextPtr) {
	    j++;
	}
	if (j < NUM_COUNTERS) {
	    count[j]++;
	} else {
	    overflow++;
	}
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
 *	Tcl_Panic if problems are found.
 *
 *----------------------------------------------------------------------
 */

void
TclVerifyLocalLiteralTable(envPtr)
    CompileEnv *envPtr;		/* Points to CompileEnv whose literal
				 * table is to be validated. */
{
    register LiteralTable *localTablePtr = &(envPtr->localLitTable);
    register LiteralEntry *localPtr;
    char *bytes;
    register int i;
    int length, count;

    count = 0;
    for (i = 0;  i < localTablePtr->numBuckets;  i++) {
	for (localPtr = localTablePtr->buckets[i];
	        localPtr != NULL;  localPtr = localPtr->nextPtr) {
	    count++;
	    if (localPtr->refCount != -1) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
		        (length>60? 60 : length), bytes,
		        localPtr->refCount);
	    }
	    if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
		    localPtr->objPtr) == NULL) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
		         (length>60? 60 : length), bytes);
	    }
	    if (localPtr->objPtr->bytes == NULL) {
		Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
	    }
	}
    }
    if (count != localTablePtr->numEntries) {
	Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
	      count, localTablePtr->numEntries);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclVerifyGlobalLiteralTable --







|
|










|




|
<





|








|







1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063

1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
 *	Tcl_Panic if problems are found.
 *
 *----------------------------------------------------------------------
 */

void
TclVerifyLocalLiteralTable(envPtr)
    CompileEnv *envPtr;		/* Points to CompileEnv whose literal table is
				 * to be validated. */
{
    register LiteralTable *localTablePtr = &(envPtr->localLitTable);
    register LiteralEntry *localPtr;
    char *bytes;
    register int i;
    int length, count;

    count = 0;
    for (i = 0;  i < localTablePtr->numBuckets;  i++) {
	for (localPtr = localTablePtr->buckets[i];
		localPtr != NULL;  localPtr = localPtr->nextPtr) {
	    count++;
	    if (localPtr->refCount != -1) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
			(length>60? 60 : length), bytes, localPtr->refCount);

	    }
	    if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
		    localPtr->objPtr) == NULL) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
			(length>60? 60 : length), bytes);
	    }
	    if (localPtr->objPtr->bytes == NULL) {
		Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
	    }
	}
    }
    if (count != localTablePtr->numEntries) {
	Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
		count, localTablePtr->numEntries);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclVerifyGlobalLiteralTable --
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120








 *	Tcl_Panic if problems are found.
 *
 *----------------------------------------------------------------------
 */

void
TclVerifyGlobalLiteralTable(iPtr)
    Interp *iPtr;		/* Points to interpreter whose global
				 * literal table is to be validated. */
{
    register LiteralTable *globalTablePtr = &(iPtr->literalTable);
    register LiteralEntry *globalPtr;
    char *bytes;
    register int i;
    int length, count;

    count = 0;
    for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
	for (globalPtr = globalTablePtr->buckets[i];
	        globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
	    count++;
	    if (globalPtr->refCount < 1) {
		bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
		Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
		        (length>60? 60 : length), bytes,
		        globalPtr->refCount);
	    }
	    if (globalPtr->objPtr->bytes == NULL) {
		Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
	    }
	}
    }
    if (count != globalTablePtr->numEntries) {
	Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
	      count, globalTablePtr->numEntries);
    }
}
#endif /*TCL_COMPILE_DEBUG*/















|
|










|




|
<








|



>
>
>
>
>
>
>
>
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117

1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
 *	Tcl_Panic if problems are found.
 *
 *----------------------------------------------------------------------
 */

void
TclVerifyGlobalLiteralTable(iPtr)
    Interp *iPtr;		/* Points to interpreter whose global literal
				 * table is to be validated. */
{
    register LiteralTable *globalTablePtr = &(iPtr->literalTable);
    register LiteralEntry *globalPtr;
    char *bytes;
    register int i;
    int length, count;

    count = 0;
    for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
	for (globalPtr = globalTablePtr->buckets[i];
		globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
	    count++;
	    if (globalPtr->refCount < 1) {
		bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
		Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
			(length>60? 60 : length), bytes, globalPtr->refCount);

	    }
	    if (globalPtr->objPtr->bytes == NULL) {
		Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
	    }
	}
    }
    if (count != globalTablePtr->numEntries) {
	Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
		count, globalTablePtr->numEntries);
    }
}
#endif /*TCL_COMPILE_DEBUG*/

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclLoad.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
/* 
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same
 *	on all platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoad.c,v 1.13 2004/03/09 12:59:05 vincentdarley Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded
 * either dynamically (with the "load" command) or statically (as
 * indicated by a call to TclGetLoadedPackages).  All such packages
 * are linked together into a single list for the process.  Packages
 * are never unloaded, until the application exits, when 
 * TclFinalizeLoad is called, and these structures are freed.

 */

typedef struct LoadedPackage {
    char *fileName;		/* Name of the file from which the
				 * package was loaded.  An empty string
				 * means the package is loaded statically.
				 * Malloc-ed. */
    char *packageName;		/* Name of package prefix for the package,
				 * properly capitalized (first letter UC,
				 * others LC), no "_", as in "Net". 
				 * Malloc-ed. */
    Tcl_LoadHandle loadHandle;	/* Token for the loaded file which should be
				 * passed to (*unLoadProcPtr)() when the file
				 * is no longer needed.  If fileName is NULL,
				 * then this field is irrelevant. */
    Tcl_PackageInitProc *initProc;
				/* Initialization procedure to call to
				 * incorporate this package into a trusted
				 * interpreter. */
    Tcl_PackageInitProc *safeInitProc;
				/* Initialization procedure to call to
				 * incorporate this package into a safe
				 * interpreter (one that will execute
				 * untrusted scripts).   NULL means the
				 * package can't be used in unsafe
				 * interpreters. */
    Tcl_PackageUnloadProc *unloadProc;
                                /* Finalisation procedure to unload a package
                                 * from a trusted interpreter.  NULL means
                                 * that the package cannot be unloaded. */
    Tcl_PackageUnloadProc *safeUnloadProc;
                                /* Finalisation procedure to unload a package
                                 * from a safe interpreter.  NULL means
                                 * that the package cannot be unloaded. */
    int interpRefCount;         /* How many times the package has been loaded
                                   in trusted interpreters. */
    int safeInterpRefCount;     /* How many times the package has been loaded
                                   in safe interpreters. */
    Tcl_FSUnloadFileProc *unLoadProcPtr;
				/* Procedure to use to unload this package.
				 * If NULL, then we do not attempt to unload
				 * the package.  If fileName is NULL, then
				 * this field is irrelevant. */
    struct LoadedPackage *nextPtr;
				/* Next in list of all packages loaded into
				 * this application process.  NULL means
				 * end of list. */
} LoadedPackage;

/*
 * TCL_THREADS
 * There is a global list of packages that is anchored at firstPackagePtr.
 * Access to this list is governed by a mutex.
 */

static LoadedPackage *firstPackagePtr = NULL;
				/* First in list of all packages loaded into
				 * this process. */

TCL_DECLARE_MUTEX(packageMutex)

/*
 * The following structure represents a particular package that has
 * been incorporated into a particular interpreter (by calling its
 * initialization procedure).  There is a list of these structures for
 * each interpreter, with an AssocData value (key "load") for the
 * interpreter that points to the first package (if any).
 */

typedef struct InterpPackage {
    LoadedPackage *pkgPtr;	/* Points to detailed information about
				 * package. */
    struct InterpPackage *nextPtr;
				/* Next package in this interpreter, or
				 * NULL for end of list. */
} InterpPackage;

/*
 * Prototypes for procedures that are private to this file:
 */

static void		LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LoadObjCmd --
 *
 *	This procedure is invoked to process the "load" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LoadObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr, *defaultPtr;
    Tcl_DString pkgName, tmp, initName, safeInitName,
                              unloadName, safeUnloadName;
    Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc;
    InterpPackage *ipFirstPtr, *ipPtr;
    int code, namesMatch, filesMatch;
    CONST char *symbols[4];
    Tcl_PackageInitProc **procPtrs[4];
    ClientData clientData;
    char *p, *fullFileName, *packageName;
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
    Tcl_UniChar ch;
    int offset;

    if ((objc < 2) || (objc > 4)) {
        Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
	return TCL_ERROR;
    }
    fullFileName = Tcl_GetString(objv[1]);
    
    Tcl_DStringInit(&pkgName);
    Tcl_DStringInit(&initName);
    Tcl_DStringInit(&safeInitName);
    Tcl_DStringInit(&unloadName);
    Tcl_DStringInit(&safeUnloadName);
    Tcl_DStringInit(&tmp);

|


|
|



|
|

|





|
|
|
|
<
|
>



|
|
|
<


|













|
|
<

|
|
|

|
|
|
|
|
|
|







|
|















|
|
|
|
|






|
|














|
|



















|
|


|







<


|






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
/*
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same on all
 *	platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoad.c,v 1.13.2.1 2005/08/02 18:16:01 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call
 * to TclGetLoadedPackages).  All such packages are linked together into a
 * single list for the process.  Packages are never unloaded, until the

 * application exits, when TclFinalizeLoad is called, and these structures are
 * freed.
 */

typedef struct LoadedPackage {
    char *fileName;		/* Name of the file from which the package was
				 * loaded. An empty string means the package
				 * is loaded statically. Malloc-ed. */

    char *packageName;		/* Name of package prefix for the package,
				 * properly capitalized (first letter UC,
				 * others LC), no "_", as in "Net".
				 * Malloc-ed. */
    Tcl_LoadHandle loadHandle;	/* Token for the loaded file which should be
				 * passed to (*unLoadProcPtr)() when the file
				 * is no longer needed.  If fileName is NULL,
				 * then this field is irrelevant. */
    Tcl_PackageInitProc *initProc;
				/* Initialization procedure to call to
				 * incorporate this package into a trusted
				 * interpreter. */
    Tcl_PackageInitProc *safeInitProc;
				/* Initialization procedure to call to
				 * incorporate this package into a safe
				 * interpreter (one that will execute
				 * untrusted scripts). NULL means the package
				 * can't be used in unsafe interpreters. */

    Tcl_PackageUnloadProc *unloadProc;
				/* Finalisation procedure to unload a package
				 * from a trusted interpreter. NULL means that
				 * the package cannot be unloaded. */
    Tcl_PackageUnloadProc *safeUnloadProc;
				/* Finalisation procedure to unload a package
				 * from a safe interpreter. NULL means that
				 * the package cannot be unloaded. */
    int interpRefCount;		/* How many times the package has been loaded
				 * in trusted interpreters. */
    int safeInterpRefCount;	/* How many times the package has been loaded
				 * in safe interpreters. */
    Tcl_FSUnloadFileProc *unLoadProcPtr;
				/* Procedure to use to unload this package.
				 * If NULL, then we do not attempt to unload
				 * the package.  If fileName is NULL, then
				 * this field is irrelevant. */
    struct LoadedPackage *nextPtr;
				/* Next in list of all packages loaded into
				 * this application process. NULL means end of
				 * list. */
} LoadedPackage;

/*
 * TCL_THREADS
 * There is a global list of packages that is anchored at firstPackagePtr.
 * Access to this list is governed by a mutex.
 */

static LoadedPackage *firstPackagePtr = NULL;
				/* First in list of all packages loaded into
				 * this process. */

TCL_DECLARE_MUTEX(packageMutex)

/*
 * The following structure represents a particular package that has been
 * incorporated into a particular interpreter (by calling its initialization
 * procedure). There is a list of these structures for each interpreter, with
 * an AssocData value (key "load") for the interpreter that points to the
 * first package (if any).
 */

typedef struct InterpPackage {
    LoadedPackage *pkgPtr;	/* Points to detailed information about
				 * package. */
    struct InterpPackage *nextPtr;
				/* Next package in this interpreter, or NULL
				 * for end of list. */
} InterpPackage;

/*
 * Prototypes for procedures that are private to this file:
 */

static void		LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LoadObjCmd --
 *
 *	This procedure is invoked to process the "load" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LoadObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr, *defaultPtr;
    Tcl_DString pkgName, tmp, initName, safeInitName;
    Tcl_DString unloadName, safeUnloadName;
    Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc;
    InterpPackage *ipFirstPtr, *ipPtr;
    int code, namesMatch, filesMatch, offset;
    CONST char *symbols[4];
    Tcl_PackageInitProc **procPtrs[4];
    ClientData clientData;
    char *p, *fullFileName, *packageName;
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
    Tcl_UniChar ch;


    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
	return TCL_ERROR;
    }
    fullFileName = Tcl_GetString(objv[1]);

    Tcl_DStringInit(&pkgName);
    Tcl_DStringInit(&initName);
    Tcl_DStringInit(&safeInitName);
    Tcl_DStringInit(&unloadName);
    Tcl_DStringInit(&safeUnloadName);
    Tcl_DStringInit(&tmp);

178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202

203
204
205
206
207
208
209

    /*
     * Figure out which interpreter we're going to load the package into.
     */

    target = interp;
    if (objc == 4) {
	char *slaveIntName;
	slaveIntName = Tcl_GetString(objv[3]);
	target = Tcl_GetSlave(interp, slaveIntName);
	if (target == NULL) {
	    code = TCL_ERROR;
	    goto done;
	}
    }

    /*
     * Scan through the packages that are currently loaded to see if the
     * package we want is already loaded.  We'll use a loaded package if
     * it meets any of the following conditions:
     *  - Its name and file match the once we're looking for.
     *  - Its file matches, and we weren't given a name.
     *  - Its name matches, the file name was specified as empty, and there
     *    is only no statically loaded package with the same name.
     */

    Tcl_MutexLock(&packageMutex);

    defaultPtr = NULL;
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	if (packageName == NULL) {
	    namesMatch = 0;
	} else {







|
|









|
|


|
|

>







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

    /*
     * Figure out which interpreter we're going to load the package into.
     */

    target = interp;
    if (objc == 4) {
	char *slaveIntName = Tcl_GetString(objv[3]);

	target = Tcl_GetSlave(interp, slaveIntName);
	if (target == NULL) {
	    code = TCL_ERROR;
	    goto done;
	}
    }

    /*
     * Scan through the packages that are currently loaded to see if the
     * package we want is already loaded.  We'll use a loaded package if it
     * meets any of the following conditions:
     *  - Its name and file match the once we're looking for.
     *  - Its file matches, and we weren't given a name.
     *  - Its name matches, the file name was specified as empty, and there is
     *	  only no statically loaded package with the same name.
     */

    Tcl_MutexLock(&packageMutex);

    defaultPtr = NULL;
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	if (packageName == NULL) {
	    namesMatch = 0;
	} else {
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288

289
290
291

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
	    break;
	}
	if (namesMatch && (fullFileName[0] == 0)) {
	    defaultPtr = pkgPtr;
	}
	if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
	    /*
	     * Can't have two different packages loaded from the same
	     * file.
	     */

	    Tcl_AppendResult(interp, "file \"", fullFileName,
		    "\" is already loaded for package \"",
		    pkgPtr->packageName, "\"", (char *) NULL);
	    code = TCL_ERROR;
	    Tcl_MutexUnlock(&packageMutex);
	    goto done;
	}
    }
    Tcl_MutexUnlock(&packageMutex);
    if (pkgPtr == NULL) {
	pkgPtr = defaultPtr;
    }

    /*
     * Scan through the list of packages already loaded in the target
     * interpreter.  If the package we want is already loaded there,
     * then there's nothing for us to do.
     */

    if (pkgPtr != NULL) {
	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->pkgPtr == pkgPtr) {
		code = TCL_OK;
		goto done;
	    }
	}
    }

    if (pkgPtr == NULL) {
	/*
	 * The desired file isn't currently loaded, so load it.  It's an
	 * error if the desired package is a static one.
	 */

	if (fullFileName[0] == 0) {
	    Tcl_AppendResult(interp, "package \"", packageName,
		    "\" isn't loaded statically", (char *) NULL);
	    code = TCL_ERROR;
	    goto done;
	}

	/*
	 * Figure out the module name if it wasn't provided explicitly.
	 */

	if (packageName != NULL) {
	    Tcl_DStringAppend(&pkgName, packageName, -1);
	} else {
	    int retc;

	    /*
	     * Threading note - this call used to be protected by a mutex.
	     */

	    retc = TclGuessPackageName(fullFileName, &pkgName);
	    if (!retc) {
		Tcl_Obj *splitPtr;
		Tcl_Obj *pkgGuessPtr;
		int pElements;
		char *pkgGuess;

		/*
		 * The platform-specific code couldn't figure out the
		 * module name.  Make a guess by taking the last element
		 * of the file name, stripping off any leading "lib",
		 * and then using all of the alphabetic and underline
		 * characters that follow that.
		 */

		splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
		Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
		pkgGuess = Tcl_GetString(pkgGuessPtr);
		if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
			&& (pkgGuess[2] == 'b')) {







|
<

















|
|















|
|

















>



>








|
|
|
|
|







225
226
227
228
229
230
231
232

233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
	    break;
	}
	if (namesMatch && (fullFileName[0] == 0)) {
	    defaultPtr = pkgPtr;
	}
	if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
	    /*
	     * Can't have two different packages loaded from the same file.

	     */

	    Tcl_AppendResult(interp, "file \"", fullFileName,
		    "\" is already loaded for package \"",
		    pkgPtr->packageName, "\"", (char *) NULL);
	    code = TCL_ERROR;
	    Tcl_MutexUnlock(&packageMutex);
	    goto done;
	}
    }
    Tcl_MutexUnlock(&packageMutex);
    if (pkgPtr == NULL) {
	pkgPtr = defaultPtr;
    }

    /*
     * Scan through the list of packages already loaded in the target
     * interpreter.  If the package we want is already loaded there, then
     * there's nothing for us to do.
     */

    if (pkgPtr != NULL) {
	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->pkgPtr == pkgPtr) {
		code = TCL_OK;
		goto done;
	    }
	}
    }

    if (pkgPtr == NULL) {
	/*
	 * The desired file isn't currently loaded, so load it. It's an error
	 * if the desired package is a static one.
	 */

	if (fullFileName[0] == 0) {
	    Tcl_AppendResult(interp, "package \"", packageName,
		    "\" isn't loaded statically", (char *) NULL);
	    code = TCL_ERROR;
	    goto done;
	}

	/*
	 * Figure out the module name if it wasn't provided explicitly.
	 */

	if (packageName != NULL) {
	    Tcl_DStringAppend(&pkgName, packageName, -1);
	} else {
	    int retc;

	    /*
	     * Threading note - this call used to be protected by a mutex.
	     */

	    retc = TclGuessPackageName(fullFileName, &pkgName);
	    if (!retc) {
		Tcl_Obj *splitPtr;
		Tcl_Obj *pkgGuessPtr;
		int pElements;
		char *pkgGuess;

		/*
		 * The platform-specific code couldn't figure out the module
		 * name. Make a guess by taking the last element of the file
		 * name, stripping off any leading "lib", and then using all
		 * of the alphabetic and underline characters that follow
		 * that.
		 */

		splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
		Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
		pkgGuess = Tcl_GetString(pkgGuessPtr);
		if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
			&& (pkgGuess[2] == 'b')) {
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370

371
372
373
374
375
376
377
378

379
380
381
382
383
384
385
	}

	/*
	 * Fix the capitalization in the package name so that the first
	 * character is in caps (or title case) but the others are all
	 * lower-case.
	 */
    
	Tcl_DStringSetLength(&pkgName,
		Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));

	/*
	 * Compute the names of the two initialization procedures,
	 * based on the package name.
	 */
    
	Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&initName, "_Init", 5);
	Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
        Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&unloadName, "_Unload", 7);
        Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11);

	/*
	 * Call platform-specific code to load the package and find the
	 * two initialization procedures.
	 */

        symbols[0] = Tcl_DStringValue(&initName);
        symbols[1] = Tcl_DStringValue(&safeInitName);
        symbols[2] = Tcl_DStringValue(&unloadName);
        symbols[3] = Tcl_DStringValue(&safeUnloadName);
        procPtrs[0] = &initProc;
        procPtrs[1] = &safeInitProc;
        procPtrs[2] = &unloadProc;
        procPtrs[3] = &safeUnloadProc;

	Tcl_MutexLock(&packageMutex);
	code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs,
		&loadHandle, &clientData, &unLoadProcPtr);
	Tcl_MutexUnlock(&packageMutex);
        loadHandle = (Tcl_LoadHandle) clientData;
	if (code != TCL_OK) {
	    goto done;
	}

	if (*procPtrs[0] /* initProc */ == NULL) {
	    Tcl_AppendResult(interp, "couldn't find procedure ",
		    Tcl_DStringValue(&initName), (char *) NULL);
	    if (unLoadProcPtr != NULL) {
		(*unLoadProcPtr)(loadHandle);
	    }
	    code = TCL_ERROR;







|




|
|

|




|

|



|
|


|
|
|
|
|
|
|
|
>




|



>







332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
	}

	/*
	 * Fix the capitalization in the package name so that the first
	 * character is in caps (or title case) but the others are all
	 * lower-case.
	 */

	Tcl_DStringSetLength(&pkgName,
		Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));

	/*
	 * Compute the names of the two initialization procedures, based on
	 * the package name.
	 */

	Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&initName, "_Init", 5);
	Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
	Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&unloadName, "_Unload", 7);
	Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1);
	Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11);

	/*
	 * Call platform-specific code to load the package and find the two
	 * initialization procedures.
	 */

	symbols[0] = Tcl_DStringValue(&initName);
	symbols[1] = Tcl_DStringValue(&safeInitName);
	symbols[2] = Tcl_DStringValue(&unloadName);
	symbols[3] = Tcl_DStringValue(&safeUnloadName);
	procPtrs[0] = &initProc;
	procPtrs[1] = &safeInitProc;
	procPtrs[2] = &unloadProc;
	procPtrs[3] = &safeUnloadProc;

	Tcl_MutexLock(&packageMutex);
	code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs,
		&loadHandle, &clientData, &unLoadProcPtr);
	Tcl_MutexUnlock(&packageMutex);
	loadHandle = (Tcl_LoadHandle) clientData;
	if (code != TCL_OK) {
	    goto done;
	}

	if (*procPtrs[0] /* initProc */ == NULL) {
	    Tcl_AppendResult(interp, "couldn't find procedure ",
		    Tcl_DStringValue(&initName), (char *) NULL);
	    if (unLoadProcPtr != NULL) {
		(*unLoadProcPtr)(loadHandle);
	    }
	    code = TCL_ERROR;
397
398
399
400
401
402
403
404
405
406
407

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443

444
445
446
447
448
449
450

451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
	pkgPtr->packageName	   = (char *) ckalloc((unsigned)
		(Tcl_DStringLength(&pkgName) + 1));
	strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
	pkgPtr->loadHandle	   = loadHandle;
	pkgPtr->unLoadProcPtr	   = unLoadProcPtr;
	pkgPtr->initProc	   = *procPtrs[0];
	pkgPtr->safeInitProc	   = *procPtrs[1];
        pkgPtr->unloadProc         = (Tcl_PackageUnloadProc*) *procPtrs[2];
        pkgPtr->safeUnloadProc     = (Tcl_PackageUnloadProc*) *procPtrs[3];
        pkgPtr->interpRefCount     = 0;
        pkgPtr->safeInterpRefCount = 0;

	Tcl_MutexLock(&packageMutex);
	pkgPtr->nextPtr		   = firstPackagePtr;
	firstPackagePtr		   = pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
    }

    /*
     * Invoke the package's initialization procedure (either the
     * normal one or the safe one, depending on whether or not the
     * interpreter is safe).
     */

    if (Tcl_IsSafe(target)) {
	if (pkgPtr->safeInitProc != NULL) {
	    code = (*pkgPtr->safeInitProc)(target);
	} else {
	    Tcl_AppendResult(interp,
		    "can't use package in a safe interpreter: ",
		    "no ", pkgPtr->packageName, "_SafeInit procedure",
		    (char *) NULL);
	    code = TCL_ERROR;
	    goto done;
	}
    } else {
	code = (*pkgPtr->initProc)(target);
    }

    /*
     * Record the fact that the package has been loaded in the
     * target interpreter.
     */

    if (code == TCL_OK) {
        /*
         * Update the proper reference count.
         */

        Tcl_MutexLock(&packageMutex);
        if (Tcl_IsSafe(target)) {
            ++pkgPtr->safeInterpRefCount;
        } else {
            ++pkgPtr->interpRefCount;
        }
        Tcl_MutexUnlock(&packageMutex);

	/*
	 * Refetch ipFirstPtr: loading the package may have introduced
	 * additional static packages at the head of the linked list!
	 */

	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
	ipPtr->pkgPtr = pkgPtr;
	ipPtr->nextPtr = ipFirstPtr;
	Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
		(ClientData) ipPtr);
    } else {
	TclTransferResult(target, code, interp);
    }

    done:
    Tcl_DStringFree(&pkgName);
    Tcl_DStringFree(&initName);
    Tcl_DStringFree(&safeInitName);
    Tcl_DStringFree(&unloadName);
    Tcl_DStringFree(&safeUnloadName);
    Tcl_DStringFree(&tmp);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnloadObjCmd --
 *
 *	This procedure is invoked to process the "unload" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnloadObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Interp *target;		/* Which interpreter to unload from. */
    LoadedPackage *pkgPtr;
    LoadedPackage *defaultPtr;
    Tcl_DString pkgName;
    Tcl_DString tmp;
    Tcl_PackageUnloadProc *unloadProc;
    InterpPackage *ipFirstPtr;
    InterpPackage *ipPtr;
    int i;
    int index;
    int code;
    int complain = 1;
    int keepLibrary = 0;
    int trustedRefCount = -1;
    int safeRefCount = -1;
    char *fullFileName = "";
    char *packageName;
    static CONST char *options[] = {
	"-nocomplain", "-keeplibrary", "--", NULL
    };
    enum options {
	UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
    };

    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		&index) != TCL_OK) {
	    fullFileName = Tcl_GetString(objv[i]);
	    if (fullFileName[0] == '-') {
		/*
		 * It looks like the command contains an option so signal
		 * an error
		 */

		return TCL_ERROR;
	    } else {
		/*
		 * This clearly isn't an option; assume it's the
		 * filename.  We must clear the error.
		 */

		Tcl_ResetResult(interp);
		break;
	    }
	}
	switch (index) {
	case UNLOAD_NOCOMPLAIN:		/* -nocomplain */
	    complain = 0;
	    break;
	case UNLOAD_KEEPLIB:		/* -keeplibrary */
	    keepLibrary = 1;
	    break;
	case UNLOAD_LAST:		/* -- */
	    i++;
	    goto endOfForLoop;
	}
    }
    endOfForLoop:
    if ((objc-i < 1) || (objc-i > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?switches? fileName ?packageName? ?interp?");
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	return TCL_ERROR;
    }
    
    fullFileName = Tcl_GetString(objv[i]);
    Tcl_DStringInit(&pkgName);
    Tcl_DStringInit(&tmp);

    packageName = NULL;
    if (objc - i >= 2) {
	packageName = Tcl_GetString(objv[i+1]);







|
|
|
|
>







|
|
<







|
|
<








|
|



|
|
|
>
|
|
|
|
|
|
|
>
















|














|
|


















|
<
|
<

|
<
<
<
<
<
|
|
<
|
<













|
|





|
|


















|








|







398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
426
427

428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504

505

506
507





508
509

510

511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
	pkgPtr->packageName	   = (char *) ckalloc((unsigned)
		(Tcl_DStringLength(&pkgName) + 1));
	strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
	pkgPtr->loadHandle	   = loadHandle;
	pkgPtr->unLoadProcPtr	   = unLoadProcPtr;
	pkgPtr->initProc	   = *procPtrs[0];
	pkgPtr->safeInitProc	   = *procPtrs[1];
	pkgPtr->unloadProc	   = (Tcl_PackageUnloadProc*) *procPtrs[2];
	pkgPtr->safeUnloadProc	   = (Tcl_PackageUnloadProc*) *procPtrs[3];
	pkgPtr->interpRefCount	   = 0;
	pkgPtr->safeInterpRefCount = 0;

	Tcl_MutexLock(&packageMutex);
	pkgPtr->nextPtr		   = firstPackagePtr;
	firstPackagePtr		   = pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
    }

    /*
     * Invoke the package's initialization procedure (either the normal one or
     * the safe one, depending on whether or not the interpreter is safe).

     */

    if (Tcl_IsSafe(target)) {
	if (pkgPtr->safeInitProc != NULL) {
	    code = (*pkgPtr->safeInitProc)(target);
	} else {
	    Tcl_AppendResult(interp,
		    "can't use package in a safe interpreter: no ",
		    pkgPtr->packageName, "_SafeInit procedure", (char *) NULL);

	    code = TCL_ERROR;
	    goto done;
	}
    } else {
	code = (*pkgPtr->initProc)(target);
    }

    /*
     * Record the fact that the package has been loaded in the target
     * interpreter.
     */

    if (code == TCL_OK) {
	/*
	 * Update the proper reference count.
	 */

	Tcl_MutexLock(&packageMutex);
	if (Tcl_IsSafe(target)) {
	    ++pkgPtr->safeInterpRefCount;
	} else {
	    ++pkgPtr->interpRefCount;
	}
	Tcl_MutexUnlock(&packageMutex);

	/*
	 * Refetch ipFirstPtr: loading the package may have introduced
	 * additional static packages at the head of the linked list!
	 */

	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
	ipPtr->pkgPtr = pkgPtr;
	ipPtr->nextPtr = ipFirstPtr;
	Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
		(ClientData) ipPtr);
    } else {
	TclTransferResult(target, code, interp);
    }

  done:
    Tcl_DStringFree(&pkgName);
    Tcl_DStringFree(&initName);
    Tcl_DStringFree(&safeInitName);
    Tcl_DStringFree(&unloadName);
    Tcl_DStringFree(&safeUnloadName);
    Tcl_DStringFree(&tmp);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnloadObjCmd --
 *
 *	This procedure is invoked to process the "unload" Tcl command.  See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnloadObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Interp *target;		/* Which interpreter to unload from. */
    LoadedPackage *pkgPtr, *defaultPtr;

    Tcl_DString pkgName, tmp;

    Tcl_PackageUnloadProc *unloadProc;
    InterpPackage *ipFirstPtr, *ipPtr;





    int i, index, code, complain = 1, keepLibrary = 0;
    int trustedRefCount = -1, safeRefCount = -1;

    char *fullFileName = "", *packageName;

    static CONST char *options[] = {
	"-nocomplain", "-keeplibrary", "--", NULL
    };
    enum options {
	UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
    };

    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		&index) != TCL_OK) {
	    fullFileName = Tcl_GetString(objv[i]);
	    if (fullFileName[0] == '-') {
		/*
		 * It looks like the command contains an option so signal an
		 * error
		 */

		return TCL_ERROR;
	    } else {
		/*
		 * This clearly isn't an option; assume it's the filename. We
		 * must clear the error.
		 */

		Tcl_ResetResult(interp);
		break;
	    }
	}
	switch (index) {
	case UNLOAD_NOCOMPLAIN:		/* -nocomplain */
	    complain = 0;
	    break;
	case UNLOAD_KEEPLIB:		/* -keeplibrary */
	    keepLibrary = 1;
	    break;
	case UNLOAD_LAST:		/* -- */
	    i++;
	    goto endOfForLoop;
	}
    }
  endOfForLoop:
    if ((objc-i < 1) || (objc-i > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?switches? fileName ?packageName? ?interp?");
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	return TCL_ERROR;
    }

    fullFileName = Tcl_GetString(objv[i]);
    Tcl_DStringInit(&pkgName);
    Tcl_DStringInit(&tmp);

    packageName = NULL;
    if (objc - i >= 2) {
	packageName = Tcl_GetString(objv[i+1]);
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
	if (target == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Scan through the packages that are currently loaded to see if the
     * package we want is already loaded.  We'll use a loaded package if
     * it meets any of the following conditions:
     *  - Its name and file match the once we're looking for.
     *  - Its file matches, and we weren't given a name.
     *  - Its name matches, the file name was specified as empty, and there
     *    is only no statically loaded package with the same name.
     */

    Tcl_MutexLock(&packageMutex);

    defaultPtr = NULL;
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	int namesMatch, filesMatch;







|
|


|
|







589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
	if (target == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Scan through the packages that are currently loaded to see if the
     * package we want is already loaded.  We'll use a loaded package if it
     * meets any of the following conditions:
     *  - Its name and file match the once we're looking for.
     *  - Its file matches, and we weren't given a name.
     *  - Its name matches, the file name was specified as empty, and there is
     *	  only no statically loaded package with the same name.
     */

    Tcl_MutexLock(&packageMutex);

    defaultPtr = NULL;
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	int namesMatch, filesMatch;
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690

691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
		"\" is loaded statically and cannot be unloaded",
		(char *) NULL);
	code = TCL_ERROR;
	goto done;
    }
    if (pkgPtr == NULL) {
	/*
	 * The DLL pointed by the provided filename has never been
	 * loaded.
	 */

	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" has never been loaded", (char *) NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*
     * Scan through the list of packages already loaded in the target
     * interpreter.  If the package we want is already loaded there,
     * then we should proceed with unloading.
     */

    code = TCL_ERROR;
    if (pkgPtr != NULL) {
	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->pkgPtr == pkgPtr) {
		code = TCL_OK;
		break;
	    }
	}
    }
    if (code != TCL_OK) {
	/*
	 * The package has not been loaded in this interpreter.
	 */

	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" has never been loaded in this interpreter", (char *) NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*
     * Ensure that the DLL can be unloaded. If it is a trusted
     * interpreter, pkgPtr->unloadProc must not be NULL for the DLL to
     * be unloadable. If the interpreter is a safe one,
     * pkgPtr->safeUnloadProc must be non-NULL.
     */

    if (Tcl_IsSafe(target)) {
	if (pkgPtr->safeUnloadProc == NULL) {
	    Tcl_AppendResult(interp, "file \"", fullFileName,
		    "\" cannot be unloaded under a safe interpreter",
		    (char *) NULL);







|
<










|
|

















>







|
|
<
|







646
647
648
649
650
651
652
653

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692

693
694
695
696
697
698
699
700
		"\" is loaded statically and cannot be unloaded",
		(char *) NULL);
	code = TCL_ERROR;
	goto done;
    }
    if (pkgPtr == NULL) {
	/*
	 * The DLL pointed by the provided filename has never been loaded.

	 */

	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" has never been loaded", (char *) NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*
     * Scan through the list of packages already loaded in the target
     * interpreter.  If the package we want is already loaded there, then we
     * should proceed with unloading.
     */

    code = TCL_ERROR;
    if (pkgPtr != NULL) {
	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->pkgPtr == pkgPtr) {
		code = TCL_OK;
		break;
	    }
	}
    }
    if (code != TCL_OK) {
	/*
	 * The package has not been loaded in this interpreter.
	 */

	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" has never been loaded in this interpreter", (char *) NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*
     * Ensure that the DLL can be unloaded. If it is a trusted interpreter,
     * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If

     * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL.
     */

    if (Tcl_IsSafe(target)) {
	if (pkgPtr->safeUnloadProc == NULL) {
	    Tcl_AppendResult(interp, "file \"", fullFileName,
		    "\" cannot be unloaded under a safe interpreter",
		    (char *) NULL);
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
	    goto done;
	}
	unloadProc = pkgPtr->unloadProc;
    }

    /*
     * We are ready to unload the package. First, evaluate the unload
     * procedure. If this fails, we cannot proceed with unload.  Also,
     * we must specify the proper flag to pass to the unload callback.
     * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback
     * should only remove itself from the interpreter; the library
     * will be unloaded in a future call of unload. In case the
     * library will be unloaded just after the callback returns,
     * TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
     */

    code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
    if (!keepLibrary) {
	Tcl_MutexLock(&packageMutex);
	trustedRefCount = pkgPtr->interpRefCount;
	safeRefCount = pkgPtr->safeInterpRefCount;







|
|
|
|
|
<
|







711
712
713
714
715
716
717
718
719
720
721
722

723
724
725
726
727
728
729
730
	    goto done;
	}
	unloadProc = pkgPtr->unloadProc;
    }

    /*
     * We are ready to unload the package. First, evaluate the unload
     * procedure. If this fails, we cannot proceed with unload. Also, we must
     * specify the proper flag to pass to the unload callback.
     * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should
     * only remove itself from the interpreter; the library will be unloaded
     * in a future call of unload. In case the library will be unloaded just

     * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
     */

    code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
    if (!keepLibrary) {
	Tcl_MutexLock(&packageMutex);
	trustedRefCount = pkgPtr->interpRefCount;
	safeRefCount = pkgPtr->safeInterpRefCount;
752
753
754
755
756
757
758
759
760
761
762
763
764
765

766
767
768

769
770
771
772
773

774
775
776

777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
    code = (*unloadProc)(target, code);
    if (code != TCL_OK) {
	TclTransferResult(target, code, interp);
	goto done;
    }

    /*
     * The unload procedure executed fine.  Examine the reference
     * count to see if we unload the DLL.
     */

    Tcl_MutexLock(&packageMutex);
    if (Tcl_IsSafe(target)) {
	--pkgPtr->safeInterpRefCount;

	/*
	 * Do not let counter get negative
	 */

	if (pkgPtr->safeInterpRefCount < 0) {
	    pkgPtr->safeInterpRefCount = 0;
	}
    } else {
	--pkgPtr->interpRefCount;

	/*
	 * Do not let counter get negative
	 */

	if (pkgPtr->interpRefCount < 0) {
	    pkgPtr->interpRefCount = 0;
	}
    }
    trustedRefCount = pkgPtr->interpRefCount;
    safeRefCount = pkgPtr->safeInterpRefCount;
    Tcl_MutexUnlock(&packageMutex);

    code = TCL_OK;
    if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
	    && !keepLibrary) {
	/*
	 * Unload the shared library from the application memory...
	 */

#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
	/*
	 * Some Unix dlls are poorly behaved - registering things like
	 * atexit calls that can't be unregistered.  If you unload
	 * such dlls, you get a core on exit because it wants to call
	 * a function in the dll after it's been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;

	    if (unLoadProcPtr != NULL) {
		Tcl_MutexLock(&packageMutex);







|
|





>

|

>





>

|

>

















|
|
|
|







743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
    code = (*unloadProc)(target, code);
    if (code != TCL_OK) {
	TclTransferResult(target, code, interp);
	goto done;
    }

    /*
     * The unload procedure executed fine.  Examine the reference count to see
     * if we unload the DLL.
     */

    Tcl_MutexLock(&packageMutex);
    if (Tcl_IsSafe(target)) {
	--pkgPtr->safeInterpRefCount;

	/*
	 * Do not let counter get negative.
	 */

	if (pkgPtr->safeInterpRefCount < 0) {
	    pkgPtr->safeInterpRefCount = 0;
	}
    } else {
	--pkgPtr->interpRefCount;

	/*
	 * Do not let counter get negative.
	 */

	if (pkgPtr->interpRefCount < 0) {
	    pkgPtr->interpRefCount = 0;
	}
    }
    trustedRefCount = pkgPtr->interpRefCount;
    safeRefCount = pkgPtr->safeInterpRefCount;
    Tcl_MutexUnlock(&packageMutex);

    code = TCL_OK;
    if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
	    && !keepLibrary) {
	/*
	 * Unload the shared library from the application memory...
	 */

#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
	/*
	 * Some Unix dlls are poorly behaved - registering things like atexit
	 * calls that can't be unregistered. If you unload such dlls, you get
	 * a core on exit because it wants to call a function in the dll after
	 * it's been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;

	    if (unLoadProcPtr != NULL) {
		Tcl_MutexLock(&packageMutex);
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
			    pkgPtr->nextPtr = defaultPtr->nextPtr;
			    break;
			}
		    }
		}

		/*
		 * Remove this library from the interpreter's library
		 * cache.
		 */

		ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
			"tclLoad", (Tcl_InterpDeleteProc **) NULL);
		ipPtr = ipFirstPtr;
		if (ipPtr->pkgPtr == defaultPtr) {
		    ipFirstPtr = ipFirstPtr->nextPtr;







|
<







813
814
815
816
817
818
819
820

821
822
823
824
825
826
827
			    pkgPtr->nextPtr = defaultPtr->nextPtr;
			    break;
			}
		    }
		}

		/*
		 * Remove this library from the interpreter's library cache.

		 */

		ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
			"tclLoad", (Tcl_InterpDeleteProc **) NULL);
		ipPtr = ipFirstPtr;
		if (ipPtr->pkgPtr == defaultPtr) {
		    ipFirstPtr = ipFirstPtr->nextPtr;
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
#else
	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" cannot be unloaded: unloading disabled", (char *) NULL);
	code = TCL_ERROR;
#endif
    }

    done:
    Tcl_DStringFree(&pkgName);
    Tcl_DStringFree(&tmp);
    if (!complain && code!=TCL_OK) {
	code = TCL_OK;
	Tcl_ResetResult(interp);
    }
    if (code == TCL_OK) {
#if 0
	/*
	 * Result of [unload] was not documented in TIP#100, so force
	 * to be the empty string by commenting this out.  DKF.
	 */

	Tcl_Obj *resultObjPtr, *objPtr[2];

	/*
	 * Our result is the two reference counts.
	 */







|









|
|







853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
#else
	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" cannot be unloaded: unloading disabled", (char *) NULL);
	code = TCL_ERROR;
#endif
    }

  done:
    Tcl_DStringFree(&pkgName);
    Tcl_DStringFree(&tmp);
    if (!complain && code!=TCL_OK) {
	code = TCL_OK;
	Tcl_ResetResult(interp);
    }
    if (code == TCL_OK) {
#if 0
	/*
	 * Result of [unload] was not documented in TIP#100, so force to be
	 * the empty string by commenting this out. DKF.
	 */

	Tcl_Obj *resultObjPtr, *objPtr[2];

	/*
	 * Our result is the two reference counts.
	 */
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933

934
935
936

937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StaticPackage --
 *
 *	This procedure is invoked to indicate that a particular
 *	package has been linked statically with an application.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Once this procedure completes, the package becomes loadable
 *	via the "load" command with an empty file name.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
    Tcl_Interp *interp;			/* If not NULL, it means that the
					 * package has already been loaded
					 * into the given interpreter by
					 * calling the appropriate init proc. */
    CONST char *pkgName;		/* Name of package (must be properly
					 * capitalized: first letter upper
					 * case, others lower case). */
    Tcl_PackageInitProc *initProc;	/* Procedure to call to incorporate

					 * this package into a trusted
					 * interpreter. */
    Tcl_PackageInitProc *safeInitProc;	/* Procedure to call to incorporate

					 * this package into a safe interpreter
					 * (one that will execute untrusted
					 * scripts).   NULL means the package
					 * can't be used in safe
					 * interpreters. */
{
    LoadedPackage *pkgPtr;
    InterpPackage *ipPtr, *ipFirstPtr;

    /*
     * Check to see if someone else has already reported this package as
     * statically loaded in the process.
     */

    Tcl_MutexLock(&packageMutex);
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	if ((pkgPtr->initProc == initProc)
		&& (pkgPtr->safeInitProc == safeInitProc)
		&& (strcmp(pkgPtr->packageName, pkgName) == 0)) {
	    break;
	}
    }
    Tcl_MutexUnlock(&packageMutex);

    /*
     * If the package is not yet recorded as being loaded statically,
     * add it to the list now.
     */

    if ( pkgPtr == NULL ) {
	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
	pkgPtr->fileName	= (char *) ckalloc((unsigned) 1);
	pkgPtr->fileName[0]	= 0;
	pkgPtr->packageName	= (char *) ckalloc((unsigned)







|
|





|
|






|
|
|
|
|
|
|
|
>
|
<
|
>
|
|
<
|
|




















|
|







898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929

930
931
932
933

934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StaticPackage --
 *
 *	This procedure is invoked to indicate that a particular package has
 *	been linked statically with an application.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Once this procedure completes, the package becomes loadable via the
 *	"load" command with an empty file name.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
    Tcl_Interp *interp;		/* If not NULL, it means that the package has
				 * already been loaded into the given
				 * interpreter by calling the appropriate init
				 * proc. */
    CONST char *pkgName;	/* Name of package (must be properly
				 * capitalized: first letter upper case,
				 * others lower case). */
    Tcl_PackageInitProc *initProc;
				/* Procedure to call to incorporate this
				 * package into a trusted interpreter. */

    Tcl_PackageInitProc *safeInitProc;
				/* Procedure to call to incorporate this
				 * package into a safe interpreter (one that
				 * will execute untrusted scripts). NULL means

				 * the package can't be used in safe
				 * interpreters. */
{
    LoadedPackage *pkgPtr;
    InterpPackage *ipPtr, *ipFirstPtr;

    /*
     * Check to see if someone else has already reported this package as
     * statically loaded in the process.
     */

    Tcl_MutexLock(&packageMutex);
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	if ((pkgPtr->initProc == initProc)
		&& (pkgPtr->safeInitProc == safeInitProc)
		&& (strcmp(pkgPtr->packageName, pkgName) == 0)) {
	    break;
	}
    }
    Tcl_MutexUnlock(&packageMutex);

    /*
     * If the package is not yet recorded as being loaded statically, add it
     * to the list now.
     */

    if ( pkgPtr == NULL ) {
	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
	pkgPtr->fileName	= (char *) ckalloc((unsigned) 1);
	pkgPtr->fileName[0]	= 0;
	pkgPtr->packageName	= (char *) ckalloc((unsigned)
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
	firstPackagePtr		= pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
    }

    if (interp != NULL) {

	/*
	 * If we're loading the package into an interpreter,
	 * determine whether it's already loaded. 
	 */

	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
	    if ( ipPtr->pkgPtr == pkgPtr ) {
		return;
	    }
	}

	/*
	 * Package isn't loade in the current interp yet. Mark it as
	 * now being loaded.
	 */

	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
	ipPtr->pkgPtr = pkgPtr;
	ipPtr->nextPtr = ipFirstPtr;
	Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
		(ClientData) ipPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetLoadedPackages --
 *
 *	This procedure returns information about all of the files
 *	that are loaded (either in a particular intepreter, or
 *	for all interpreters).
 *
 * Results:
 *	The return value is a standard Tcl completion code.  If
 *	successful, a list of lists is placed in the interp's result.
 *	Each sublist corresponds to one loaded file;  its first
 *	element is the name of the file (or an empty string for
 *	something that's statically loaded) and the second element
 *	is the name of the package in that file.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetLoadedPackages(interp, targetName)
    Tcl_Interp *interp;		/* Interpreter in which to return
				 * information or error message. */
    char *targetName;		/* Name of target interpreter or NULL.
				 * If NULL, return info about all interps;
				 * otherwise, just return info about this
				 * interpreter. */
{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr;
    InterpPackage *ipPtr;
    char *prefix;

    if (targetName == NULL) {
	/* 
	 * Return information about all of the available packages.
	 */

	prefix = "{";
	Tcl_MutexLock(&packageMutex);
	for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
		pkgPtr = pkgPtr->nextPtr) {
	    Tcl_AppendResult(interp, prefix, (char *) NULL);
	    Tcl_AppendElement(interp, pkgPtr->fileName);
	    Tcl_AppendElement(interp, pkgPtr->packageName);
	    Tcl_AppendResult(interp, "}", (char *) NULL);
	    prefix = " {";
	}
	Tcl_MutexUnlock(&packageMutex);
	return TCL_OK;
    }

    /*
     * Return information about only the packages that are loaded in
     * a given interpreter.
     */

    target = Tcl_GetSlave(interp, targetName);
    if (target == NULL) {
	return TCL_ERROR;
    }
    ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",







|
|











|
|















|
|
<


|
|
|
<
|
|









|
|
|
|









|


















|
|







972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010

1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
	firstPackagePtr		= pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
    }

    if (interp != NULL) {

	/*
	 * If we're loading the package into an interpreter, determine whether
	 * it's already loaded.
	 */

	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
	    if ( ipPtr->pkgPtr == pkgPtr ) {
		return;
	    }
	}

	/*
	 * Package isn't loade in the current interp yet. Mark it as now being
	 * loaded.
	 */

	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
	ipPtr->pkgPtr = pkgPtr;
	ipPtr->nextPtr = ipFirstPtr;
	Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
		(ClientData) ipPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetLoadedPackages --
 *
 *	This procedure returns information about all of the files that are
 *	loaded (either in a particular intepreter, or for all interpreters).

 *
 * Results:
 *	The return value is a standard Tcl completion code. If successful, a
 *	list of lists is placed in the interp's result. Each sublist
 *	corresponds to one loaded file; its first element is the name of the

 *	file (or an empty string for something that's statically loaded) and
 *	the second element is the name of the package in that file.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetLoadedPackages(interp, targetName)
    Tcl_Interp *interp;		/* Interpreter in which to return information
				 * or error message. */
    char *targetName;		/* Name of target interpreter or NULL. If
				 * NULL, return info about all interps;
				 * otherwise, just return info about this
				 * interpreter. */
{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr;
    InterpPackage *ipPtr;
    char *prefix;

    if (targetName == NULL) {
	/*
	 * Return information about all of the available packages.
	 */

	prefix = "{";
	Tcl_MutexLock(&packageMutex);
	for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
		pkgPtr = pkgPtr->nextPtr) {
	    Tcl_AppendResult(interp, prefix, (char *) NULL);
	    Tcl_AppendElement(interp, pkgPtr->fileName);
	    Tcl_AppendElement(interp, pkgPtr->packageName);
	    Tcl_AppendResult(interp, "}", (char *) NULL);
	    prefix = " {";
	}
	Tcl_MutexUnlock(&packageMutex);
	return TCL_OK;
    }

    /*
     * Return information about only the packages that are loaded in a given
     * interpreter.
     */

    target = Tcl_GetSlave(interp, targetName);
    if (target == NULL) {
	return TCL_ERROR;
    }
    ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
}

/*
 *----------------------------------------------------------------------
 *
 * LoadCleanupProc --
 *
 *	This procedure is called to delete all of the InterpPackage
 *	structures for an interpreter when the interpreter is deleted.
 *	It gets invoked via the Tcl AssocData mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Storage for all of the InterpPackage procedures for interp
 *	get deleted.
 *
 *----------------------------------------------------------------------
 */

static void
LoadCleanupProc(clientData, interp)
    ClientData clientData;	/* Pointer to first InterpPackage structure







|
|
|





|
|







1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
}

/*
 *----------------------------------------------------------------------
 *
 * LoadCleanupProc --
 *
 *	This procedure is called to delete all of the InterpPackage structures
 *	for an interpreter when the interpreter is deleted. It gets invoked
 *	via the Tcl AssocData mechanism.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Storage for all of the InterpPackage procedures for interp get
 *	deleted.
 *
 *----------------------------------------------------------------------
 */

static void
LoadCleanupProc(clientData, interp)
    ClientData clientData;	/* Pointer to first InterpPackage structure
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157

1158
1159
1160
1161
1162
1163
1164

1165
1166
1167
1168
1169
1170
1171

1172
1173
1174
1175
1176








}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeLoad --
 *
 *	This procedure is invoked just before the application exits.
 *	It frees all of the LoadedPackage structures.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLoad()
{
    LoadedPackage *pkgPtr;

    /*
     * No synchronization here because there should just be
     * one thread alive at this point.  Logically, 
     * packageMutex should be grabbed at this point, but
     * the Mutexes get finalized before the call to this routine.
     * The only subsystem left alive at this point is the
     * memory allocator.
     */

    while (firstPackagePtr != NULL) {
	pkgPtr = firstPackagePtr;
	firstPackagePtr = pkgPtr->nextPtr;

#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
	/*
	 * Some Unix dlls are poorly behaved - registering things like
	 * atexit calls that can't be unregistered.  If you unload
	 * such dlls, you get a core on exit because it wants to
	 * call a function in the dll after it's been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
	    if (unLoadProcPtr != NULL) {
	        (*unLoadProcPtr)(pkgPtr->loadHandle);
	    }
	}
#endif

	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
    }
}















|
|
















|
<
|
|
|
<





>


|
|
|
|

>



|



>





>
>
>
>
>
>
>
>
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139

1140
1141
1142

1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeLoad --
 *
 *	This procedure is invoked just before the application exits. It frees
 *	all of the LoadedPackage structures.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLoad()
{
    LoadedPackage *pkgPtr;

    /*
     * No synchronization here because there should just be one thread alive

     * at this point. Logically, packageMutex should be grabbed at this point,
     * but the Mutexes get finalized before the call to this routine. The
     * only subsystem left alive at this point is the memory allocator.

     */

    while (firstPackagePtr != NULL) {
	pkgPtr = firstPackagePtr;
	firstPackagePtr = pkgPtr->nextPtr;

#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
	/*
	 * Some Unix dlls are poorly behaved - registering things like atexit
	 * calls that can't be unregistered. If you unload such dlls, you get
	 * a core on exit because it wants to call a function in the dll after
	 * it's been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
	    if (unLoadProcPtr != NULL) {
		(*unLoadProcPtr)(pkgPtr->loadHandle);
	    }
	}
#endif

	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclMain.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21






22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83


84
85
86
87
88
89
90
91
/* 
 * tclMain.c --
 *
 *	Main program for Tcl shells and other Tcl-based applications.
 *
 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMain.c,v 1.30 2004/11/13 00:19:10 dgp Exp $
 */

#include "tclInt.h"

# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT

/*






 * Declarations for various library procedures and variables (don't want
 * to include tclPort.h here, because people might copy this file out of
 * the Tcl source directory to make their own modified versions).
 */

extern DLLIMPORT int		isatty _ANSI_ARGS_((int fd));

static Tcl_Obj *tclStartupScriptPath = NULL;
static Tcl_Obj *tclStartupScriptEncoding = NULL;

static Tcl_MainLoopProc *mainLoopProc = NULL;

/* 
 * Structure definition for information used to keep the state of
 * an interactive command processor that reads lines from standard
 * input and writes prompts and results to standard output.
 */

typedef enum {
    PROMPT_NONE,	/* Print no prompt */
    PROMPT_START,	/* Print prompt for command start */
    PROMPT_CONTINUE	/* Print prompt for command continuation */
} PromptType;

typedef struct InteractiveState {
    Tcl_Channel input;		/* The standard input channel from which
				 * lines are read. */
    int tty;                    /* Non-zero means standard input is a 
				 * terminal-like device.  Zero means it's
				 * a file. */
    Tcl_Obj *commandPtr;	/* Used to assemble lines of input into
				 * Tcl commands. */
    PromptType prompt;		/* Next prompt to print */
    Tcl_Interp *interp;		/* Interpreter that evaluates interactive
				 * commands. */
} InteractiveState;

/*
 * Forward declarations for procedures defined later in this file.
 */

static void		Prompt _ANSI_ARGS_((Tcl_Interp *interp,
			    PromptType *promptPtr));
static void		StdinProc _ANSI_ARGS_((ClientData clientData,
			    int mask));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStartupScript --
 *
 *	Sets the path and encoding of the startup script to be evaluated
 *	by Tcl_Main, used to override the command line processing.
 *
 * Results:
 *	None. 
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */


void Tcl_SetStartupScript(path, encoding)
    Tcl_Obj *path;		/* Filesystem path of startup script file */
    CONST char *encoding;	/* Encoding of the data in that file */
{
    Tcl_Obj *newEncoding = NULL;
    if (encoding != NULL) {
	newEncoding = Tcl_NewStringObj(encoding, -1);
    }
|








|
|

|




|
|


>
>
>
>
>
>
|
|
|









|
|
|
|



|
|
|



|
|
|
|
|
|
|













<






|
|


|





>
>
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
/*
 * tclMain.c --
 *
 *	Main program for Tcl shells and other Tcl-based applications.
 *
 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMain.c,v 1.30.2.3 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

/*
 * The default prompt used when the user has not overridden it.
 */

#define DEFAULT_PRIMARY_PROMPT	"% "

/*
 * Declarations for various library procedures and variables (don't want to
 * include tclPort.h here, because people might copy this file out of the Tcl
 * source directory to make their own modified versions).
 */

extern DLLIMPORT int		isatty _ANSI_ARGS_((int fd));

static Tcl_Obj *tclStartupScriptPath = NULL;
static Tcl_Obj *tclStartupScriptEncoding = NULL;

static Tcl_MainLoopProc *mainLoopProc = NULL;

/*
 * Structure definition for information used to keep the state of an
 * interactive command processor that reads lines from standard input and
 * writes prompts and results to standard output.
 */

typedef enum {
    PROMPT_NONE,		/* Print no prompt */
    PROMPT_START,		/* Print prompt for command start */
    PROMPT_CONTINUE		/* Print prompt for command continuation */
} PromptType;

typedef struct InteractiveState {
    Tcl_Channel input;		/* The standard input channel from which lines
				 * are read. */
    int tty;			/* Non-zero means standard input is a
				 * terminal-like device. Zero means it's a
				 * file. */
    Tcl_Obj *commandPtr;	/* Used to assemble lines of input into Tcl
				 * commands. */
    PromptType prompt;		/* Next prompt to print */
    Tcl_Interp *interp;		/* Interpreter that evaluates interactive
				 * commands. */
} InteractiveState;

/*
 * Forward declarations for procedures defined later in this file.
 */

static void		Prompt _ANSI_ARGS_((Tcl_Interp *interp,
			    PromptType *promptPtr));
static void		StdinProc _ANSI_ARGS_((ClientData clientData,
			    int mask));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStartupScript --
 *
 *	Sets the path and encoding of the startup script to be evaluated by
 *	Tcl_Main, used to override the command line processing.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetStartupScript(path, encoding)
    Tcl_Obj *path;		/* Filesystem path of startup script file */
    CONST char *encoding;	/* Encoding of the data in that file */
{
    Tcl_Obj *newEncoding = NULL;
    if (encoding != NULL) {
	newEncoding = Tcl_NewStringObj(encoding, -1);
    }
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129


130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162


163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184


185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206


207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230


231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

283
284
285
286
287
288
289
	Tcl_DecrRefCount(tclStartupScriptEncoding);
    }
    tclStartupScriptEncoding = newEncoding;
    if (tclStartupScriptEncoding != NULL) {
	Tcl_IncrRefCount(tclStartupScriptEncoding);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStartupScript --
 *
 *	Gets the path and encoding of the startup script to be evaluated
 *	by Tcl_Main.
 *
 * Results:
 *	The path of the startup script; NULL if none has been set.
 *
 * Side effects:
 * 	If encodingPtr is not NULL, stores a (CONST char *) in it
 * 	pointing to the encoding name registered for the startup
 * 	script.  Tcl retains ownership of the string, and may free
 * 	it.  Caller should make a copy for long-term use.
 *
 *----------------------------------------------------------------------
 */


Tcl_Obj *Tcl_GetStartupScript(encodingPtr)
    CONST char** encodingPtr;	/* When not NULL, points to storage for
				 * the (CONST char *) that points to the
				 * registered encoding name for the startup
				 * script */
{
    if (encodingPtr != NULL) {
	if (tclStartupScriptEncoding == NULL) {
	    *encodingPtr = NULL;
	} else {
	    *encodingPtr = Tcl_GetString(tclStartupScriptEncoding);
	}
    }
    return tclStartupScriptPath;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetStartupScriptPath --
 *
 *	Primes the startup script VFS path, used to override the
 *      command line processing.
 *
 * Results:
 *	None. 
 *
 * Side effects:
 *	This procedure initializes the VFS path of the Tcl script to
 *      run at startup.
 *
 *----------------------------------------------------------------------
 */


void TclSetStartupScriptPath(path)
    Tcl_Obj *path;
{
    Tcl_SetStartupScript(path, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetStartupScriptPath --
 *
 *	Gets the startup script VFS path, used to override the
 *      command line processing.
 *
 * Results:
 *	The startup script VFS path, NULL if none has been set.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


Tcl_Obj *TclGetStartupScriptPath()
{
    return Tcl_GetStartupScript(NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetStartupScriptFileName --
 *
 *	Primes the startup script file name, used to override the
 *      command line processing.
 *
 * Results:
 *	None. 
 *
 * Side effects:
 *	This procedure initializes the file name of the Tcl script to
 *      run at startup.
 *
 *----------------------------------------------------------------------
 */


void TclSetStartupScriptFileName(fileName)
    CONST char *fileName;
{
    Tcl_Obj *path = Tcl_NewStringObj(fileName,-1);
    Tcl_SetStartupScript(path, NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * TclGetStartupScriptFileName --
 *
 *	Gets the startup script file name, used to override the
 *      command line processing.
 *
 * Results:
 *	The startup script file name, NULL if none has been set.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


CONST char *TclGetStartupScriptFileName()
{
    Tcl_Obj *path = Tcl_GetStartupScript(NULL);

    if (path == NULL) {
	return NULL;
    }
    return Tcl_GetString(path);
}

/*----------------------------------------------------------------------
 *
 * Tcl_SourceRCFile --
 *         
 *      This procedure is typically invoked by Tcl_Main of Tk_Main
 *      procedure to source an application specific rc file into the
 *      interpreter at startup time.
 *                            
 * Results:
 *      None.                                                  
 *
 * Side effects:
 *      Depends on what's in the rc script.                                                
 *
 *----------------------------------------------------------------------
 */
                  
void
Tcl_SourceRCFile(interp)
    Tcl_Interp *interp;         /* Interpreter to source rc file into. */
{
    Tcl_DString temp;                                                      
    CONST char *fileName;
    Tcl_Channel errChannel;

    fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
    if (fileName != NULL) { 
        Tcl_Channel c;
        CONST char *fullName;

	Tcl_DStringInit(&temp);
	fullName = Tcl_TranslateFileName(interp, fileName, &temp);
	if (fullName == NULL) {           
	    /*
	     * Couldn't translate the file name (e.g. it referred to a
	     * bogus user or there was no HOME environment variable).
	     * Just do nothing.
	     */
	} else {
            /*
	     * Test for the existence of the rc file before trying to read it.             
	     */

	    c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
	    if (c != (Tcl_Channel) NULL) {
		Tcl_Close(NULL, c);
		if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
		    errChannel = Tcl_GetStdChannel(TCL_STDERR);
		    if (errChannel) {
			Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));







<






|
|





|
|
|
|



>
>
|
|
|












|





|
|


|


|
|



>
>
|




|





|
|









>
>
|



|





|
|


|


|
|



>
>
|





<






|
|









>
>
|












|
|
|
|
|

|


|



|


|

|




|
|
|



|

|
|
|


|
|

>







109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226

227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
	Tcl_DecrRefCount(tclStartupScriptEncoding);
    }
    tclStartupScriptEncoding = newEncoding;
    if (tclStartupScriptEncoding != NULL) {
	Tcl_IncrRefCount(tclStartupScriptEncoding);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStartupScript --
 *
 *	Gets the path and encoding of the startup script to be evaluated by
 *	Tcl_Main.
 *
 * Results:
 *	The path of the startup script; NULL if none has been set.
 *
 * Side effects:
 * 	If encodingPtr is not NULL, stores a (CONST char *) in it pointing to
 * 	the encoding name registered for the startup script. Tcl retains
 * 	ownership of the string, and may free it. Caller should make a copy
 * 	for long-term use.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetStartupScript(encodingPtr)
    CONST char **encodingPtr;	/* When not NULL, points to storage for the
				 * (CONST char *) that points to the
				 * registered encoding name for the startup
				 * script */
{
    if (encodingPtr != NULL) {
	if (tclStartupScriptEncoding == NULL) {
	    *encodingPtr = NULL;
	} else {
	    *encodingPtr = Tcl_GetString(tclStartupScriptEncoding);
	}
    }
    return tclStartupScriptPath;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetStartupScriptPath --
 *
 *	Primes the startup script VFS path, used to override the command line
 *	processing.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This procedure initializes the VFS path of the Tcl script to run at
 *	startup.
 *
 *----------------------------------------------------------------------
 */

void
TclSetStartupScriptPath(path)
    Tcl_Obj *path;
{
    Tcl_SetStartupScript(path, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetStartupScriptPath --
 *
 *	Gets the startup script VFS path, used to override the command line
 *	processing.
 *
 * Results:
 *	The startup script VFS path, NULL if none has been set.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetStartupScriptPath()
{
    return Tcl_GetStartupScript(NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetStartupScriptFileName --
 *
 *	Primes the startup script file name, used to override the command line
 *	processing.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	This procedure initializes the file name of the Tcl script to run at
 *	startup.
 *
 *----------------------------------------------------------------------
 */

void
TclSetStartupScriptFileName(fileName)
    CONST char *fileName;
{
    Tcl_Obj *path = Tcl_NewStringObj(fileName,-1);
    Tcl_SetStartupScript(path, NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * TclGetStartupScriptFileName --
 *
 *	Gets the startup script file name, used to override the command line
 *	processing.
 *
 * Results:
 *	The startup script file name, NULL if none has been set.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclGetStartupScriptFileName()
{
    Tcl_Obj *path = Tcl_GetStartupScript(NULL);

    if (path == NULL) {
	return NULL;
    }
    return Tcl_GetString(path);
}

/*----------------------------------------------------------------------
 *
 * Tcl_SourceRCFile --
 *
 *	This procedure is typically invoked by Tcl_Main of Tk_Main procedure
 *	to source an application specific rc file into the interpreter at
 *	startup time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on what's in the rc script.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SourceRCFile(interp)
    Tcl_Interp *interp;		/* Interpreter to source rc file into. */
{
    Tcl_DString temp;
    CONST char *fileName;
    Tcl_Channel errChannel;

    fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
    if (fileName != NULL) {
	Tcl_Channel c;
	CONST char *fullName;

	Tcl_DStringInit(&temp);
	fullName = Tcl_TranslateFileName(interp, fileName, &temp);
	if (fullName == NULL) {
	    /*
	     * Couldn't translate the file name (e.g. it referred to a bogus
	     * user or there was no HOME environment variable). Just do
	     * nothing.
	     */
	} else {
	    /*
	     * Test for the existence of the rc file before trying to read it.
	     */

	    c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
	    if (c != (Tcl_Channel) NULL) {
		Tcl_Close(NULL, c);
		if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
		    errChannel = Tcl_GetStdChannel(TCL_STDERR);
		    if (errChannel) {
			Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391




392
393
394





395



396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
/*----------------------------------------------------------------------
 *
 * Tcl_Main --
 *
 *	Main program for tclsh and most other Tcl-based applications.
 *
 * Results:
 *	None. This procedure never returns (it exits the process when
 *	it's done).
 *
 * Side effects:
 *	This procedure initializes the Tcl world and then starts
 *	interpreting commands;  almost anything could happen, depending
 *	on the script being interpreted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Main(argc, argv, appInitProc)
    int argc;			/* Number of arguments. */
    char **argv;		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc;
				/* Application-specific initialization
				 * procedure to call after most
				 * initialization but before starting to
				 * execute commands. */
{
    Tcl_Obj *path;
    Tcl_Obj *resultPtr;
    Tcl_Obj *commandPtr = NULL;
    CONST char *encodingName = NULL;
    char *args;
    PromptType prompt = PROMPT_START;
    int code, length, tty;
    int exitCode = 0;
    Tcl_Channel inChannel, outChannel, errChannel;
    Tcl_Interp *interp;
    Tcl_DString argString;

    Tcl_FindExecutable(argv[0]);

    interp = Tcl_CreateInterp();
    Tcl_InitMemory(interp);

    /*
     * If the application has not already set a startup script, parse
     * the first few command line arguments to determine the script
     * path and encoding.
     */

    if (NULL == Tcl_GetStartupScript(NULL)) {

	/* 
	 * Check whether first 3 args (argv[1] - argv[3]) look like
	 * 	-encoding ENCODING FILENAME
	 * or like
	 * 	FILENAME
	 */

	if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
		&& ('-' != argv[3][0])) {
	    Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
	    argc -= 3;
	    argv += 3;
	} else if ((argc > 1) && ('-' != argv[1][0])) {
	    Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
	    argc--;
	    argv++;
	}
    }

    /*
     * The CONST casting is safe, and better we do it here than force
     * all callers of Tcl_Main to do it.  (Those callers are likely
     * in a main() that can't easily change its signature.)
     */
    
    args = Tcl_Merge(argc-1, (CONST char **)argv+1);
    Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
    Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&argString);
    ckfree(args);

    path = Tcl_GetStartupScript(&encodingName);
    if (path == NULL) {
	Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
    } else {
	CONST char *pathName = Tcl_GetStringFromObj(path, &length);
	Tcl_ExternalToUtfDString(NULL, pathName, length, &argString);
	path = Tcl_NewStringObj(Tcl_DStringValue(&argString), -1);
	Tcl_SetStartupScript(path, encodingName);
    }





    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc-1),
	    TCL_GLOBAL_ONLY);





    Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);




    /*
     * Set the "tcl_interactive" variable.
     */

    tty = isatty(0);
    Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
	    TCL_GLOBAL_ONLY);
    
    /*
     * Invoke application-specific initialization.
     */

    Tcl_Preserve((ClientData) interp);
    if ((*appInitProc)(interp) != TCL_OK) {
	errChannel = Tcl_GetStdChannel(TCL_STDERR);







|
|


|
|
|










|
<
|

|
<
<

<

|
<


|







|
|
|




|


















<
<
<
<
<
<
<
<
<
<
<
<


|


|
|


>
>
>
>

|
|
>
>
>
>
>
|
>
>
>








|







315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339

340
341
342


343

344
345

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381












382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
/*----------------------------------------------------------------------
 *
 * Tcl_Main --
 *
 *	Main program for tclsh and most other Tcl-based applications.
 *
 * Results:
 *	None. This procedure never returns (it exits the process when it's
 *	done).
 *
 * Side effects:
 *	This procedure initializes the Tcl world and then starts interpreting
 *	commands; almost anything could happen, depending on the script being
 *	interpreted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Main(argc, argv, appInitProc)
    int argc;			/* Number of arguments. */
    char **argv;		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc;
				/* Application-specific initialization
				 * procedure to call after most initialization

				 * but before starting to execute commands. */
{
    Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;


    CONST char *encodingName = NULL;

    PromptType prompt = PROMPT_START;
    int code, length, tty, exitCode = 0;

    Tcl_Channel inChannel, outChannel, errChannel;
    Tcl_Interp *interp;
    Tcl_DString appName;

    Tcl_FindExecutable(argv[0]);

    interp = Tcl_CreateInterp();
    Tcl_InitMemory(interp);

    /*
     * If the application has not already set a startup script, parse the
     * first few command line arguments to determine the script path and
     * encoding.
     */

    if (NULL == Tcl_GetStartupScript(NULL)) {

	/*
	 * Check whether first 3 args (argv[1] - argv[3]) look like
	 * 	-encoding ENCODING FILENAME
	 * or like
	 * 	FILENAME
	 */

	if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
		&& ('-' != argv[3][0])) {
	    Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
	    argc -= 3;
	    argv += 3;
	} else if ((argc > 1) && ('-' != argv[1][0])) {
	    Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
	    argc--;
	    argv++;
	}
    }













    path = Tcl_GetStartupScript(&encodingName);
    if (path == NULL) {
	Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
    } else {
	CONST char *pathName = Tcl_GetStringFromObj(path, &length);
	Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
	path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
	Tcl_SetStartupScript(path, encodingName);
    }
    Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&appName);
    argc--;
    argv++;

    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);

    argvPtr = Tcl_NewListObj(0, NULL);
    while (argc--) {
	Tcl_DString ds;
	Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
	Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
		Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
	Tcl_DStringFree(&ds);
    }
    Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */

    tty = isatty(0);
    Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
	    TCL_GLOBAL_ONLY);

    /*
     * Invoke application-specific initialization.
     */

    Tcl_Preserve((ClientData) interp);
    if ((*appInitProc)(interp) != TCL_OK) {
	errChannel = Tcl_GetStdChannel(TCL_STDERR);
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
	goto done;
    }
    if (Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * If a script file was specified then just source that file
     * and quit.  Must fetch it again, as the appInitProc might
     * have reset it.
     */

    path = Tcl_GetStartupScript(&encodingName);
    if (path != NULL) {
	code = Tcl_FSEvalFileEx(interp, path, encodingName);
	if (code != TCL_OK) {
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);







|
|
<







431
432
433
434
435
436
437
438
439

440
441
442
443
444
445
446
	goto done;
    }
    if (Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * If a script file was specified then just source that file and quit.
     * Must fetch it again, as the appInitProc might have reset it.

     */

    path = Tcl_GetStartupScript(&encodingName);
    if (path != NULL) {
	code = Tcl_FSEvalFileEx(interp, path, encodingName);
	if (code != TCL_OK) {
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478

479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
		}
		Tcl_WriteChars(errChannel, "\n", 1);
	    }
	    exitCode = 1;
	}
	goto done;
    }
    Tcl_DStringFree(&argString);

    /*
     * We're running interactively.  Source a user-specific startup
     * file if the application specified one and if the file exists.
     */

    Tcl_SourceRCFile(interp);
    if (Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * Process commands from stdin until there's an end-of-file.  Note
     * that we need to fetch the standard channels again after every
     * eval, since they may have been changed.
     */

    commandPtr = Tcl_NewObj();
    Tcl_IncrRefCount(commandPtr);

    /*
     * Get a new value for tty if anyone writes to ::tcl_interactive
     */

    Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
    inChannel = Tcl_GetStdChannel(TCL_STDIN);
    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
	if (tty) {
	    Prompt(interp, &prompt);
	    if (Tcl_InterpDeleted(interp)) {
		break;
	    }
	    if (Tcl_LimitExceeded(interp)) {
		break;
	    }
	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
	    if (inChannel == (Tcl_Channel) NULL) {
	        break;
	    }
	}
	if (Tcl_IsShared(commandPtr)) {
	    Tcl_DecrRefCount(commandPtr);
	    commandPtr = Tcl_DuplicateObj(commandPtr);
	    Tcl_IncrRefCount(commandPtr);
	}
        length = Tcl_GetsObj(inChannel, commandPtr);
	if (length < 0) {
	    if (Tcl_InputBlocked(inChannel)) {

		/*
		 * This can only happen if stdin has been set to
		 * non-blocking.  In that case cycle back and try
		 * again.  This sets up a tight polling loop (since
		 * we have no event loop running).  If this causes
		 * bad CPU hogging, we might try toggling the blocking
		 * on stdin instead.
		 */

		continue;
	    }

	    /* 
	     * Either EOF, or an error on stdin; we're done
	     */

	    break;
	}

	if (!TclObjCommandComplete(commandPtr)) {







<


|
|








|
|
|








>














|







|


<

|
|
<
|
|






|







458
459
460
461
462
463
464

465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513

514
515
516

517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
		}
		Tcl_WriteChars(errChannel, "\n", 1);
	    }
	    exitCode = 1;
	}
	goto done;
    }


    /*
     * We're running interactively. Source a user-specific startup file if the
     * application specified one and if the file exists.
     */

    Tcl_SourceRCFile(interp);
    if (Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * Process commands from stdin until there's an end-of-file. Note that we
     * need to fetch the standard channels again after every eval, since they
     * may have been changed.
     */

    commandPtr = Tcl_NewObj();
    Tcl_IncrRefCount(commandPtr);

    /*
     * Get a new value for tty if anyone writes to ::tcl_interactive
     */

    Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
    inChannel = Tcl_GetStdChannel(TCL_STDIN);
    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
	if (tty) {
	    Prompt(interp, &prompt);
	    if (Tcl_InterpDeleted(interp)) {
		break;
	    }
	    if (Tcl_LimitExceeded(interp)) {
		break;
	    }
	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
	    if (inChannel == (Tcl_Channel) NULL) {
		break;
	    }
	}
	if (Tcl_IsShared(commandPtr)) {
	    Tcl_DecrRefCount(commandPtr);
	    commandPtr = Tcl_DuplicateObj(commandPtr);
	    Tcl_IncrRefCount(commandPtr);
	}
	length = Tcl_GetsObj(inChannel, commandPtr);
	if (length < 0) {
	    if (Tcl_InputBlocked(inChannel)) {

		/*
		 * This can only happen if stdin has been set to non-blocking.
		 * In that case cycle back and try again. This sets up a tight

		 * polling loop (since we have no event loop running). If this
		 * causes bad CPU hogging, we might try toggling the blocking
		 * on stdin instead.
		 */

		continue;
	    }

	    /*
	     * Either EOF, or an error on stdin; we're done
	     */

	    break;
	}

	if (!TclObjCommandComplete(commandPtr)) {
555
556
557
558
559
560
561
562
563

564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
	    Tcl_GetStringFromObj(resultPtr, &length);
	    if ((length > 0) && outChannel) {
		Tcl_WriteObj(outChannel, resultPtr);
		Tcl_WriteChars(outChannel, "\n", 1);
	    }
	    Tcl_DecrRefCount(resultPtr);
	}
	if (mainLoopProc != NULL) {


	    /*
	     * If a main loop has been defined while running interactively,
	     * we want to start a fileevent based prompt by establishing a
	     * channel handler for stdin.
	     */

	    InteractiveState *isPtr = NULL;

	    if (inChannel) {
	        if (tty) {
		    Prompt(interp, &prompt);
	        }
		isPtr = (InteractiveState *) 
			ckalloc((int) sizeof(InteractiveState));
		isPtr->input = inChannel;
		isPtr->tty = tty;
		isPtr->commandPtr = commandPtr;
		isPtr->prompt = prompt;
		isPtr->interp = interp;








<

>

|
|






|

|
|







563
564
565
566
567
568
569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
	    Tcl_GetStringFromObj(resultPtr, &length);
	    if ((length > 0) && outChannel) {
		Tcl_WriteObj(outChannel, resultPtr);
		Tcl_WriteChars(outChannel, "\n", 1);
	    }
	    Tcl_DecrRefCount(resultPtr);
	}


	if (mainLoopProc != NULL) {
	    /*
	     * If a main loop has been defined while running interactively, we
	     * want to start a fileevent based prompt by establishing a
	     * channel handler for stdin.
	     */

	    InteractiveState *isPtr = NULL;

	    if (inChannel) {
		if (tty) {
		    Prompt(interp, &prompt);
		}
		isPtr = (InteractiveState *)
			ckalloc((int) sizeof(InteractiveState));
		isPtr->input = inChannel;
		isPtr->tty = tty;
		isPtr->commandPtr = commandPtr;
		isPtr->prompt = prompt;
		isPtr->interp = interp;

608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653

654

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	}
#ifdef TCL_MEM_DEBUG

	/*
	 * This code here only for the (unsupported and deprecated)
	 * [checkmem] command.
	 */

	if (tclMemDumpFileName != NULL) {
	    mainLoopProc = NULL;
	    Tcl_DeleteInterp(interp);
	}
#endif
    }

    done:
    if ((exitCode == 0) && (mainLoopProc != NULL)
	    && !Tcl_LimitExceeded(interp)) {

	/*
	 * If everything has gone OK so far, call the main loop proc,
	 * if it exists.  Packages (like Tk) can set it to start processing
	 * events at this point.
	 */

	(*mainLoopProc)();
	mainLoopProc = NULL;
    }
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that
     * users can replace "exit" with some other command to do additional
     * cleanup on exit.  The Tcl_Eval call should never return.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (!Tcl_LimitExceeded(interp)) {
	    char buffer[TCL_INTEGER_SPACE + 5];

	    sprintf(buffer, "exit %d", exitCode);

	    Tcl_Eval(interp, buffer);

	}

        /*
         * If Tcl_Eval returns, trying to eval [exit], something
         * unusual is happening.  Maybe interp has been deleted; maybe
         * [exit] was redefined, maybe we've blown up because of an
         * exceeded limit.  We still want to cleanup and exit.
         */

        if (!Tcl_InterpDeleted(interp)) {
            Tcl_DeleteInterp(interp);
        }
    }
    Tcl_SetStartupScript(NULL, NULL);

    /*
     * If we get here, the master interp has been deleted.  Allow
     * its destruction with the last matching Tcl_Release.
     */

    Tcl_Release((ClientData) interp);
    Tcl_Exit(exitCode);
}

/*
 *---------------------------------------------------------------
 *
 * Tcl_SetMainLoop --
 *
 *	Sets an alternative main loop procedure.
 *
 * Results:
 *	Returns the previously defined main loop procedure.
 *
 * Side effects:
 *	This procedure will be called before Tcl exits, allowing for
 *	the creation of an event loop.
 *
 *---------------------------------------------------------------
 */

void
Tcl_SetMainLoop(proc)
    Tcl_MainLoopProc *proc;
{
    mainLoopProc = proc;
}

/*
 *----------------------------------------------------------------------
 *
 * StdinProc --
 *
 *	This procedure is invoked by the event dispatcher whenever
 *	standard input becomes readable.  It grabs the next line of
 *	input characters, adds them to a command being assembled, and
 *	executes the command if it's complete.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Could be almost arbitrary, depending on the command that's
 *	typed.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
StdinProc(clientData, mask)
    ClientData clientData;		/* The state of interactive cmd line */
    int mask;				/* Not used. */
{
    InteractiveState *isPtr = (InteractiveState *) clientData;
    Tcl_Channel chan = isPtr->input;
    Tcl_Obj *commandPtr = isPtr->commandPtr;
    Tcl_Interp *interp = isPtr->interp;
    int code, length;

    if (Tcl_IsShared(commandPtr)) {
	Tcl_DecrRefCount(commandPtr);
	commandPtr = Tcl_DuplicateObj(commandPtr);
	Tcl_IncrRefCount(commandPtr);
    }
    length = Tcl_GetsObj(chan, commandPtr);
    if (length < 0) {
	if (Tcl_InputBlocked(chan)) {
	    return;
	}
	if (isPtr->tty) {
	    /*
	     * Would be better to find a way to exit the mainLoop?
	     * Or perhaps evaluate [exit]?  Leaving as is for now due
	     * to compatibility concerns.
	     */

	    Tcl_Exit(0);
	}
	Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr);
	return;
    }

    if (!TclObjCommandComplete(commandPtr)) {
	if (Tcl_IsShared(commandPtr)) {
	    Tcl_DecrRefCount(commandPtr);
	    commandPtr = Tcl_DuplicateObj(commandPtr);
	    Tcl_IncrRefCount(commandPtr);
	}
	Tcl_AppendToObj(commandPtr, "\n", 1);
        isPtr->prompt = PROMPT_CONTINUE;
        goto prompt;
    }
    isPtr->prompt = PROMPT_START;

    /*
     * Disable the stdin channel handler while evaluating the command;
     * otherwise if the command re-enters the event loop we might
     * process commands from stdin before the current command is
     * finished.  Among other things, this will trash the text of the
     * command being evaluated.
     */

    Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr);
    code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
    isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
    Tcl_DecrRefCount(commandPtr);
    isPtr->commandPtr = commandPtr = Tcl_NewObj();







|
|









|


<

|
|
|










|
|
|




<
|
|
>
|
>


|
|
|
|
|
|

|
|
|




|
|

















|
|
















|
|
|
|





|
<







|
|



















|
|
|

>













|
|





|
|
|
<







616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636

637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657

658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725

726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781

782
783
784
785
786
787
788
	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	}
#ifdef TCL_MEM_DEBUG

	/*
	 * This code here only for the (unsupported and deprecated) [checkmem]
	 * command.
	 */

	if (tclMemDumpFileName != NULL) {
	    mainLoopProc = NULL;
	    Tcl_DeleteInterp(interp);
	}
#endif
    }

  done:
    if ((exitCode == 0) && (mainLoopProc != NULL)
	    && !Tcl_LimitExceeded(interp)) {

	/*
	 * If everything has gone OK so far, call the main loop proc, if it
	 * exists. Packages (like Tk) can set it to start processing events at
	 * this point.
	 */

	(*mainLoopProc)();
	mainLoopProc = NULL;
    }
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that users can
     * replace "exit" with some other command to do additional cleanup on
     * exit. The Tcl_EvalObjEx call should never return.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (!Tcl_LimitExceeded(interp)) {

	    Tcl_Obj *cmd = Tcl_NewObj();
	    TclObjPrintf(NULL, cmd, "exit %d", exitCode);
	    Tcl_IncrRefCount(cmd);
	    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
	    Tcl_DecrRefCount(cmd);
	}

	/*
	 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
	 * is happening. Maybe interp has been deleted; maybe [exit] was
	 * redefined, maybe we've blown up because of an exceeded limit. We
	 * still want to cleanup and exit.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_DeleteInterp(interp);
	}
    }
    Tcl_SetStartupScript(NULL, NULL);

    /*
     * If we get here, the master interp has been deleted. Allow its
     * destruction with the last matching Tcl_Release.
     */

    Tcl_Release((ClientData) interp);
    Tcl_Exit(exitCode);
}

/*
 *---------------------------------------------------------------
 *
 * Tcl_SetMainLoop --
 *
 *	Sets an alternative main loop procedure.
 *
 * Results:
 *	Returns the previously defined main loop procedure.
 *
 * Side effects:
 *	This procedure will be called before Tcl exits, allowing for the
 *	creation of an event loop.
 *
 *---------------------------------------------------------------
 */

void
Tcl_SetMainLoop(proc)
    Tcl_MainLoopProc *proc;
{
    mainLoopProc = proc;
}

/*
 *----------------------------------------------------------------------
 *
 * StdinProc --
 *
 *	This procedure is invoked by the event dispatcher whenever standard
 *	input becomes readable. It grabs the next line of input characters,
 *	adds them to a command being assembled, and executes the command if
 *	it's complete.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Could be almost arbitrary, depending on the command that's typed.

 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
StdinProc(clientData, mask)
    ClientData clientData;	/* The state of interactive cmd line */
    int mask;			/* Not used. */
{
    InteractiveState *isPtr = (InteractiveState *) clientData;
    Tcl_Channel chan = isPtr->input;
    Tcl_Obj *commandPtr = isPtr->commandPtr;
    Tcl_Interp *interp = isPtr->interp;
    int code, length;

    if (Tcl_IsShared(commandPtr)) {
	Tcl_DecrRefCount(commandPtr);
	commandPtr = Tcl_DuplicateObj(commandPtr);
	Tcl_IncrRefCount(commandPtr);
    }
    length = Tcl_GetsObj(chan, commandPtr);
    if (length < 0) {
	if (Tcl_InputBlocked(chan)) {
	    return;
	}
	if (isPtr->tty) {
	    /*
	     * Would be better to find a way to exit the mainLoop? Or perhaps
	     * evaluate [exit]? Leaving as is for now due to compatibility
	     * concerns.
	     */

	    Tcl_Exit(0);
	}
	Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr);
	return;
    }

    if (!TclObjCommandComplete(commandPtr)) {
	if (Tcl_IsShared(commandPtr)) {
	    Tcl_DecrRefCount(commandPtr);
	    commandPtr = Tcl_DuplicateObj(commandPtr);
	    Tcl_IncrRefCount(commandPtr);
	}
	Tcl_AppendToObj(commandPtr, "\n", 1);
	isPtr->prompt = PROMPT_CONTINUE;
	goto prompt;
    }
    isPtr->prompt = PROMPT_START;

    /*
     * Disable the stdin channel handler while evaluating the command;
     * otherwise if the command re-enters the event loop we might process
     * commands from stdin before the current command is finished. Among other
     * things, this will trash the text of the command being evaluated.

     */

    Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr);
    code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
    isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
    Tcl_DecrRefCount(commandPtr);
    isPtr->commandPtr = commandPtr = Tcl_NewObj();
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851

852
853
854
855
856
857
858
859
860

861
862
863
864
865
866
867
868
869
870
871
872
873
874

875
876
877
878
879
880








	Tcl_DecrRefCount(resultPtr);
    }

    /*
     * If a tty stdin is still around, output a prompt.
     */

    prompt:
    if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
	Prompt(interp, &(isPtr->prompt));
	isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Prompt --
 *
 *	Issue a prompt on standard output, or invoke a script
 *	to issue the prompt.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A prompt gets output, and a Tcl script may be evaluated
 *	in interp.
 *
 *----------------------------------------------------------------------
 */

static void
Prompt(interp, promptPtr)
    Tcl_Interp *interp;			/* Interpreter to use for prompting. */
    PromptType *promptPtr;		/* Points to type of prompt to print.
					 * Filled with PROMPT_NONE after a
					 * prompt is printed. */
{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel outChannel, errChannel;

    if (*promptPtr == PROMPT_NONE) {
	return;
    }

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	    ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
	    NULL, TCL_GLOBAL_ONLY);

    if (Tcl_InterpDeleted(interp)) {
	return;
    }
    if (promptCmdPtr == NULL) {
	defaultPrompt:
	outChannel = Tcl_GetStdChannel(TCL_STDOUT);
	if ((*promptPtr == PROMPT_START)
		&& (outChannel != (Tcl_Channel) NULL)) {
	    Tcl_WriteChars(outChannel, "% ", 2);

	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
            if (errChannel != (Tcl_Channel) NULL) {
                Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
                Tcl_WriteChars(errChannel, "\n", 1);
            }
	    goto defaultPrompt;
	}
    }

    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    if (outChannel != (Tcl_Channel) NULL) {
	Tcl_Flush(outChannel);
    }
    *promptPtr = PROMPT_NONE;
}















|











|
|





|
<






|
|
|
|












>




|



|
>







|
|
|
|



>






>
>
>
>
>
>
>
>
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
	Tcl_DecrRefCount(resultPtr);
    }

    /*
     * If a tty stdin is still around, output a prompt.
     */

  prompt:
    if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
	Prompt(interp, &(isPtr->prompt));
	isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Prompt --
 *
 *	Issue a prompt on standard output, or invoke a script to issue the
 *	prompt.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A prompt gets output, and a Tcl script may be evaluated in interp.

 *
 *----------------------------------------------------------------------
 */

static void
Prompt(interp, promptPtr)
    Tcl_Interp *interp;		/* Interpreter to use for prompting. */
    PromptType *promptPtr;	/* Points to type of prompt to print. Filled
				 * with PROMPT_NONE after a prompt is
				 * printed. */
{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel outChannel, errChannel;

    if (*promptPtr == PROMPT_NONE) {
	return;
    }

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	    ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
	    NULL, TCL_GLOBAL_ONLY);

    if (Tcl_InterpDeleted(interp)) {
	return;
    }
    if (promptCmdPtr == NULL) {
    defaultPrompt:
	outChannel = Tcl_GetStdChannel(TCL_STDOUT);
	if ((*promptPtr == PROMPT_START)
		&& (outChannel != (Tcl_Channel) NULL)) {
	    Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
		    strlen(DEFAULT_PRIMARY_PROMPT));
	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		Tcl_WriteChars(errChannel, "\n", 1);
	    }
	    goto defaultPrompt;
	}
    }

    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    if (outChannel != (Tcl_Channel) NULL) {
	Tcl_Flush(outChannel);
    }
    *promptPtr = PROMPT_NONE;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclNamesp.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183




184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231






232
233
234
235
236
237
238
239
240
241
242

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274



275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
/*
 * tclNamesp.c --
 *
 *	Contains support for namespaces, which provide a separate context of
 *	commands and global variables. The global :: namespace is the
 *	traditional Tcl "global" scope. Other namespaces are created as
 *	children of the global namespace. These other namespaces contain
 *	special-purpose commands and variables for packages.  Also includes
 *	the TIP#112 ensemble machinery.
 *
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2002-2004 Donal K. Fellows.
 *
 * Originally implemented by
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [email protected]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.66 2004/12/02 10:48:30 dkf Exp $
 */

#include "tclInt.h"

/*
 * Initial size of stack allocated space for tail list - used when resetting
 * shadowed command references in the functin: TclResetShadowedCmdRefs.
 */

#define NUM_TRAIL_ELEMS 5

/*
 * Thread-local storage used to avoid having a global lock on data
 * that is not limited to a single interpreter.
 */

typedef struct ThreadSpecificData {
    long numNsCreated;		/* Count of the number of namespaces created
				 * within the thread. This value is used as a
				 * unique id for each namespace. Cannot be
				 * per-interp because the nsId is used to
				 * distinguish objects which can be passed
				 * around between interps in the same thread,
				 * but does not need to be global because
				 * object internal reps are always per-thread
				 * anyway. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * This structure contains a cached pointer to a namespace that is the
 * result of resolving the namespace's name in some other namespace. It is
 * the internal representation for a nsName object. It contains the
 * pointer along with some information that is used to check the cached
 * pointer's validity.
 */

typedef struct ResolvedNsName {
    Namespace *nsPtr;		/* A cached namespace pointer. */
    long nsId;			/* nsPtr's unique namespace id. Used to
				 * verify that nsPtr is still valid
				 * (e.g., it's possible that the namespace
				 * was deleted and a new one created at
				 * the same address). */
    Namespace *refNsPtr;	/* Points to the namespace containing the
				 * reference (not the namespace that
				 * contains the referenced namespace). */
    int refCount;		/* Reference count: 1 for each nsName
				 * object that has a pointer to this
				 * ResolvedNsName structure as its internal
				 * rep. This structure can be freed when
				 * refCount becomes zero. */
} ResolvedNsName;

/*
 * The client data for an ensemble command.  This consists of the
 * table of commands that are actually exported by the namespace, and
 * an epoch counter that, combined with the exportLookupEpoch field of
 * the namespace structure, defines whether the table contains valid
 * data or will need to be recomputed next time the ensemble command
 * is called.
 */

typedef struct EnsembleConfig {
    Namespace *nsPtr;		/* The namspace backing this ensemble up. */
    Tcl_Command token;		/* The token for the command that provides
				 * ensemble support for the namespace, or
				 * NULL if the command has been deleted (or
				 * never existed; the global namespace never
				 * has an ensemble command.) */
    int epoch;			/* The epoch at which this ensemble's table of
				 * exported commands is valid. */
    char **subcommandArrayPtr;	/* Array of ensemble subcommand names.  At all
				 * consistent points, this will have the same
				 * number of entries as there are entries in
				 * the subcommandTable hash. */
    Tcl_HashTable subcommandTable;
				/* Hash table of ensemble subcommand names,
				 * which are its keys so this also provides
				 * the storage management for those subcommand
				 * names.  The contents of the entry values are
				 * object version the prefix lists to use when
				 * substituting for the command/subcommand to
				 * build the ensemble implementation command.
				 * Has to be stored here as well as in
				 * subcommandDict because that field is NULL
				 * when we are deriving the ensemble from the
				 * namespace exports list.
				 * FUTURE WORK: use object hash table here. */
    struct EnsembleConfig *next;/* The next ensemble in the linked list of
				 * ensembles associated with a namespace. If
				 * this field points to this ensemble, the
				 * structure has already been unlinked from
				 * all lists, and cannot be found by scanning
				 * the list from the namespace's ensemble
				 * field. */
    int flags;			/* ORed combo of ENS_DEAD and ENS_PREFIX. */


    /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */

    Tcl_Obj *subcommandDict;	/* Dictionary providing mapping from
				 * subcommands to their implementing command
				 * prefixes, or NULL if we are to build the
				 * map automatically from the namespace
				 * exports. */
    Tcl_Obj *subcmdList;	/* List of commands that this ensemble
				 * actually provides, and whose implementation
				 * will be built using the subcommandDict (if
				 * present and defined) and by simple mapping
				 * to the namespace otherwise.  If NULL,
				 * indicates that we are using the (dynamic)
				 * list of currently exported commands. */
    Tcl_Obj *unknownHandler;	/* Script prefix used to handle the case when
				 * no match is found (according to the rule
				 * defined by flag bit ENS_PREFIX) or NULL to
				 * use the default error-generating behaviour.
				 * The script execution gets all the arguments
				 * to the ensemble command (including objv[0])

				 * and will have the results passed directly
				 * back to the caller (including the error
				 * code) unless the code is TCL_CONTINUE in
				 * which case the subcommand will be reparsed
				 * by the ensemble core, presumably because
				 * the ensemble itself has been updated. */
} EnsembleConfig;

#define ENS_DEAD	0x1	/* Flag value to say that the ensemble is dead
				 * and on its way out. */
#define ENS_PREFIX	0x2	/* Flag value to say whether to allow
				 * unambiguous prefixes of commands or to
				 * require exact matches for command names. */

/*
 * The data cached in a subcommand's Tcl_Obj rep.  This structure is
 * not shared between Tcl_Objs referring to the same subcommand, even
 * where one is a duplicate of another.
 */

typedef struct EnsembleCmdRep {
    Namespace *nsPtr;		/* The namespace backing the ensemble which
				 * this is a subcommand of. */
    int epoch;			/* Used to confirm when the data in this
				 * really structure matches up with the
				 * ensemble. */
    Tcl_Command token;		/* Reference to the comamnd for which this
				 * structure is a cache of the resolution. */
    char *fullSubcmdName;	/* The full (local) name of the subcommand,
				 * allocated with ckalloc(). */
    Tcl_Obj *realPrefixObj;	/* Object containing the prefix words of the
				 * command that implements this ensemble
				 * subcommand. */
} EnsembleCmdRep;

/*
 * Declarations for procedures local to this file:
 */

static void		DeleteImportedCmd _ANSI_ARGS_((ClientData clientData));




static void		DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static char *		ErrorCodeRead _ANSI_ARGS_(( ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1,
			    CONST char *name2, int flags));
static char *		ErrorInfoRead _ANSI_ARGS_(( ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1,
			    CONST char *name2, int flags));
static char *		EstablishErrorCodeTraces _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    CONST char *name1, CONST char *name2, int flags));
static char *		EstablishErrorInfoTraces _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    CONST char *name1, CONST char *name2, int flags));
static void		FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		GetNamespaceFromObj _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Obj *objPtr,
			    Tcl_Namespace **nsPtrPtr));
static int		InvokeImportedCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceChildrenCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceCodeCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceCurrentCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceDeleteCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceEnsembleCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceEvalCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceExistsCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceExportCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceForgetCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));






static void		NamespaceFree _ANSI_ARGS_((Namespace *nsPtr));
static int		NamespaceImportCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceInscopeCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceOriginCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceParentCmd _ANSI_ARGS_((

			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceQualifiersCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceTailCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		NamespaceWhichCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		SetNsNameFromAny _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Obj *objPtr));
static void		UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
static EnsembleConfig *	FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *cmdNameObj, int flags));
static int		NsEnsembleImplementationCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static void		BuildEnsembleConfig _ANSI_ARGS_((
			    EnsembleConfig *ensemblePtr));
static int		NsEnsembleStringOrder _ANSI_ARGS_((CONST VOID *strPtr1,
			    CONST VOID *strPtr2));
static void		DeleteEnsembleConfig _ANSI_ARGS_((
			    ClientData clientData));
static void		MakeCachedEnsembleCommand _ANSI_ARGS_((
			    Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr,
			    CONST char *subcmdName, Tcl_Obj *prefixObjPtr));
static void		FreeEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static void		StringOfEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr));




/*
 * This structure defines a Tcl object type that contains a
 * namespace reference.  It is used in commands that take the
 * name of a namespace as an argument.  The namespace reference
 * is resolved, and the result in cached in the object.
 */

Tcl_ObjType tclNsNameType = {
    "nsName",			/* the type's name */
    FreeNsNameInternalRep,	/* freeIntRepProc */
    DupNsNameInternalRep,	/* dupIntRepProc */
    UpdateStringOfNsName,	/* updateStringProc */
    SetNsNameFromAny		/* setFromAnyProc */
};

/*
 * This structure defines a Tcl object type that contains a reference
 * to an ensemble subcommand (e.g. the "length" in [string length ab])
 * It is used to cache the mapping between the subcommand itself and
 * the real command that implements it.
 */

Tcl_ObjType tclEnsembleCmdType = {
    "ensembleCommand",		/* the type's name */
    FreeEnsembleCmdRep,		/* freeIntRepProc */
    DupEnsembleCmdRep,		/* dupIntRepProc */
    StringOfEnsembleCmdRep,	/* updateStringProc */
    NULL			/* setFromAnyProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclInitNamespaceSubsystem --
 *
 *	This procedure is called to initialize all the structures that 
 *	are used by namespaces on a per-process basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|





|









|












|
|

















|
|
|
|
<




|
|
|
<
|

|
|
|
|
|
|
|



|
|
|
|
|
<





|
|
|
|


|







|






|
|







|
>












|




|
|
|
|
>
|
|
|
|
|
|




<
<
<


|
|
|


















|


|
>
>
>
>
|
<
|
<
|
|
<
|
|
|
|
|
|
|
|
<
<
<
|
<
|
|
|
<
|
<
|
|
|
<
|
<
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
|
>
>
>
>
>
>
|
|
<
|
|
|
<
|
<
|
|
>
|
|
|
|
<
|
<
|
|
<
|
<
|
|
<
<
|
<
|
|
<
|
|
|
<
|
|
|
|
|
<
|
>
>
>


|
|
|
|











|
|
|
|


|












|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152



153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184

185

186
187

188
189
190
191
192
193
194
195



196

197
198
199

200

201
202
203

204

205
206
207











208
209
210
211
212
213
214
215
216
217

218
219
220

221

222
223
224
225
226
227
228

229

230
231

232

233
234


235

236
237

238
239
240

241
242
243
244
245

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
/*
 * tclNamesp.c --
 *
 *	Contains support for namespaces, which provide a separate context of
 *	commands and global variables. The global :: namespace is the
 *	traditional Tcl "global" scope. Other namespaces are created as
 *	children of the global namespace. These other namespaces contain
 *	special-purpose commands and variables for packages. Also includes
 *	the TIP#112 ensemble machinery.
 *
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2002-2005 Donal K. Fellows.
 *
 * Originally implemented by
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [email protected]
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.10 2005/09/15 20:58:39 dgp Exp $
 */

#include "tclInt.h"

/*
 * Initial size of stack allocated space for tail list - used when resetting
 * shadowed command references in the functin: TclResetShadowedCmdRefs.
 */

#define NUM_TRAIL_ELEMS 5

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.
 */

typedef struct ThreadSpecificData {
    long numNsCreated;		/* Count of the number of namespaces created
				 * within the thread. This value is used as a
				 * unique id for each namespace. Cannot be
				 * per-interp because the nsId is used to
				 * distinguish objects which can be passed
				 * around between interps in the same thread,
				 * but does not need to be global because
				 * object internal reps are always per-thread
				 * anyway. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * This structure contains a cached pointer to a namespace that is the result
 * of resolving the namespace's name in some other namespace. It is the
 * internal representation for a nsName object. It contains the pointer along
 * with some information that is used to check the cached pointer's validity.

 */

typedef struct ResolvedNsName {
    Namespace *nsPtr;		/* A cached namespace pointer. */
    long nsId;			/* nsPtr's unique namespace id. Used to verify
				 * that nsPtr is still valid (e.g., it's
				 * possible that the namespace was deleted and

				 * a new one created at the same address). */
    Namespace *refNsPtr;	/* Points to the namespace containing the
				 * reference (not the namespace that contains
				 * the referenced namespace). */
    int refCount;		/* Reference count: 1 for each nsName object
				 * that has a pointer to this ResolvedNsName
				 * structure as its internal rep. This
				 * structure can be freed when refCount
				 * becomes zero. */
} ResolvedNsName;

/*
 * The client data for an ensemble command. This consists of the table of
 * commands that are actually exported by the namespace, and an epoch counter
 * that, combined with the exportLookupEpoch field of the namespace structure,
 * defines whether the table contains valid data or will need to be recomputed
 * next time the ensemble command is called.

 */

typedef struct EnsembleConfig {
    Namespace *nsPtr;		/* The namspace backing this ensemble up. */
    Tcl_Command token;		/* The token for the command that provides
				 * ensemble support for the namespace, or NULL
				 * if the command has been deleted (or never
				 * existed; the global namespace never has an
				 * ensemble command.) */
    int epoch;			/* The epoch at which this ensemble's table of
				 * exported commands is valid. */
    char **subcommandArrayPtr;	/* Array of ensemble subcommand names. At all
				 * consistent points, this will have the same
				 * number of entries as there are entries in
				 * the subcommandTable hash. */
    Tcl_HashTable subcommandTable;
				/* Hash table of ensemble subcommand names,
				 * which are its keys so this also provides
				 * the storage management for those subcommand
				 * names. The contents of the entry values are
				 * object version the prefix lists to use when
				 * substituting for the command/subcommand to
				 * build the ensemble implementation command.
				 * Has to be stored here as well as in
				 * subcommandDict because that field is NULL
				 * when we are deriving the ensemble from the
				 * namespace exports list. FUTURE WORK: use
				 * object hash table here. */
    struct EnsembleConfig *next;/* The next ensemble in the linked list of
				 * ensembles associated with a namespace. If
				 * this field points to this ensemble, the
				 * structure has already been unlinked from
				 * all lists, and cannot be found by scanning
				 * the list from the namespace's ensemble
				 * field. */
    int flags;			/* ORed combo of ENS_DEAD and
				 * TCL_ENSEMBLE_PREFIX. */

    /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */

    Tcl_Obj *subcommandDict;	/* Dictionary providing mapping from
				 * subcommands to their implementing command
				 * prefixes, or NULL if we are to build the
				 * map automatically from the namespace
				 * exports. */
    Tcl_Obj *subcmdList;	/* List of commands that this ensemble
				 * actually provides, and whose implementation
				 * will be built using the subcommandDict (if
				 * present and defined) and by simple mapping
				 * to the namespace otherwise. If NULL,
				 * indicates that we are using the (dynamic)
				 * list of currently exported commands. */
    Tcl_Obj *unknownHandler;	/* Script prefix used to handle the case when
				 * no match is found (according to the rule
				 * defined by flag bit TCL_ENSEMBLE_PREFIX) or
				 * NULL to use the default error-generating
				 * behaviour. The script execution gets all
				 * the arguments to the ensemble command
				 * (including objv[0]) and will have the
				 * results passed directly back to the caller
				 * (including the error code) unless the code
				 * is TCL_CONTINUE in which case the
				 * subcommand will be reparsed by the ensemble
				 * core, presumably because the ensemble
				 * itself has been updated. */
} EnsembleConfig;

#define ENS_DEAD	0x1	/* Flag value to say that the ensemble is dead
				 * and on its way out. */




/*
 * The data cached in a subcommand's Tcl_Obj rep. This structure is not shared
 * between Tcl_Objs referring to the same subcommand, even where one is a
 * duplicate of another.
 */

typedef struct EnsembleCmdRep {
    Namespace *nsPtr;		/* The namespace backing the ensemble which
				 * this is a subcommand of. */
    int epoch;			/* Used to confirm when the data in this
				 * really structure matches up with the
				 * ensemble. */
    Tcl_Command token;		/* Reference to the comamnd for which this
				 * structure is a cache of the resolution. */
    char *fullSubcmdName;	/* The full (local) name of the subcommand,
				 * allocated with ckalloc(). */
    Tcl_Obj *realPrefixObj;	/* Object containing the prefix words of the
				 * command that implements this ensemble
				 * subcommand. */
} EnsembleCmdRep;

/*
 * Declarations for functions local to this file:
 */

static void		DeleteImportedCmd(ClientData clientData);
static int		DoImport(Tcl_Interp *interp,
			    Namespace *nsPtr, Tcl_HashEntry *hPtr,
			    CONST char *cmdName, CONST char *pattern,
			    Namespace *importNsPtr, int allowOverwrite);
static void		DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr);

static char *		ErrorCodeRead(ClientData clientData,Tcl_Interp *interp,

			    CONST char *name1, CONST char *name2, int flags);
static char *		ErrorInfoRead(ClientData clientData,Tcl_Interp *interp,

			    CONST char *name1, CONST char *name2, int flags);
static char *		EstablishErrorCodeTraces(ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1,
			    CONST char *name2, int flags);
static char *		EstablishErrorInfoTraces(ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1,
			    CONST char *name2, int flags);
static void		FreeNsNameInternalRep(Tcl_Obj *objPtr);



static int		InvokeImportedCmd(ClientData clientData,

			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);
static int		NamespaceChildrenCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);

static int		NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceCurrentCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);

static int		NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceEnsembleCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);











static int		NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static void		NamespaceFree(Namespace *nsPtr);
static int		NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);

static int		NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespacePathCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceQualifiersCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);

static int		NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);
static int		NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,

			    int objc, Tcl_Obj *CONST objv[]);

static int		SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		UpdateStringOfNsName(Tcl_Obj *objPtr);


static int		NsEnsembleImplementationCmd(ClientData clientData,

			    Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);
static void		BuildEnsembleConfig(EnsembleConfig *ensemblePtr);

static int		NsEnsembleStringOrder(CONST VOID *strPtr1,
			    CONST VOID *strPtr2);
static void		DeleteEnsembleConfig(ClientData clientData);

static void		MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
			    EnsembleConfig *ensemblePtr,
			    CONST char *subcmdName, Tcl_Obj *prefixObjPtr);
static void		FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void		DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);

static void		StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void		UnlinkNsPath(Namespace *nsPtr);
static void		SetNsPath(Namespace *nsPtr, int pathLength,
			    Tcl_Namespace *pathAry[]);

/*
 * This structure defines a Tcl object type that contains a namespace
 * reference. It is used in commands that take the name of a namespace as an
 * argument. The namespace reference is resolved, and the result in cached in
 * the object.
 */

Tcl_ObjType tclNsNameType = {
    "nsName",			/* the type's name */
    FreeNsNameInternalRep,	/* freeIntRepProc */
    DupNsNameInternalRep,	/* dupIntRepProc */
    UpdateStringOfNsName,	/* updateStringProc */
    SetNsNameFromAny		/* setFromAnyProc */
};

/*
 * This structure defines a Tcl object type that contains a reference to an
 * ensemble subcommand (e.g. the "length" in [string length ab]) It is used to
 * cache the mapping between the subcommand itself and the real command that
 * implements it.
 */

static Tcl_ObjType ensembleCmdType = {
    "ensembleCommand",		/* the type's name */
    FreeEnsembleCmdRep,		/* freeIntRepProc */
    DupEnsembleCmdRep,		/* dupIntRepProc */
    StringOfEnsembleCmdRep,	/* updateStringProc */
    NULL			/* setFromAnyProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclInitNamespaceSubsystem --
 *
 *	This function is called to initialize all the structures that are used
 *	by namespaces on a per-process basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_GetCurrentNamespace(interp)
    register Tcl_Interp *interp; /* Interpreter whose current namespace is
				  * being queried. */
{
    register Interp *iPtr = (Interp *) interp;
    register Namespace *nsPtr;

    if (iPtr->varFramePtr != NULL) {
	nsPtr = iPtr->varFramePtr->nsPtr;
    } else {







|
|







317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_GetCurrentNamespace(interp)
    register Tcl_Interp *interp;/* Interpreter whose current namespace is
				 * being queried. */
{
    register Interp *iPtr = (Interp *) interp;
    register Namespace *nsPtr;

    if (iPtr->varFramePtr != NULL) {
	nsPtr = iPtr->varFramePtr->nsPtr;
    } else {
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434

435
436
437
438
439
440
441
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_GetGlobalNamespace(interp)
    register Tcl_Interp *interp; /* Interpreter whose global namespace 
				  * should be returned. */
{
    register Interp *iPtr = (Interp *) interp;

    return (Tcl_Namespace *) iPtr->globalNsPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PushCallFrame --
 *
 *	Pushes a new call frame onto the interpreter's Tcl call stack.
 *	Called when executing a Tcl procedure or a "namespace eval" or
 *	"namespace inscope" command. 
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result object) if something goes wrong.
 *
 * Side effects:
 *	Modifies the interpreter's Tcl call stack.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
    Tcl_Interp *interp;		 /* Interpreter in which the new call frame
				  * is to be pushed. */
    Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to
				  * push. Storage for this has already been
				  * allocated by the caller; typically this
				  * is the address of a CallFrame structure
				  * allocated on the caller's C stack.  The
				  * call frame will be initialized by this
				  * procedure. The caller can pop the frame
				  * later with Tcl_PopCallFrame, and it is
				  * responsible for freeing the frame's
				  * storage. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace in which the
				  * frame will execute. If NULL, the
				  * interpreter's current namespace will
				  * be used. */
    int isProcCallFrame;	 /* If nonzero, the frame represents a
				  * called Tcl procedure and may have local
				  * vars. Vars will ordinarily be looked up
				  * in the frame. If new variables are
				  * created, they will be created in the
				  * frame. If 0, the frame is for a
				  * "namespace eval" or "namespace inscope"
				  * command and var references are treated
				  * as references to namespace variables. */

{
    Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = (CallFrame *) callFramePtr;
    register Namespace *nsPtr;

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);







|
|











|
|
|













|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
<
|
|
|
|
<
|
|
|
|
>







349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395

396
397
398

399
400
401
402

403
404
405
406
407
408
409
410
411
412
413
414
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_GetGlobalNamespace(interp)
    register Tcl_Interp *interp;/* Interpreter whose global namespace should
				 * be returned. */
{
    register Interp *iPtr = (Interp *) interp;

    return (Tcl_Namespace *) iPtr->globalNsPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PushCallFrame --
 *
 *	Pushes a new call frame onto the interpreter's Tcl call stack. Called
 *	when executing a Tcl procedure or a "namespace eval" or "namespace
 *	inscope" command.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result object) if something goes wrong.
 *
 * Side effects:
 *	Modifies the interpreter's Tcl call stack.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
    Tcl_Interp *interp;		/* Interpreter in which the new call frame is
				 * to be pushed. */
    Tcl_CallFrame *callFramePtr;/* Points to a call frame structure to push.
				 * Storage for this has already been allocated
				 * by the caller; typically this is the
				 * address of a CallFrame structure allocated
				 * on the caller's C stack. The call frame
				 * will be initialized by this function. The
				 * caller can pop the frame later with
				 * Tcl_PopCallFrame, and it is responsible for
				 * freeing the frame's storage. */

    Tcl_Namespace *namespacePtr;/* Points to the namespace in which the frame
				 * will execute. If NULL, the interpreter's
				 * current namespace will be used. */

    int isProcCallFrame;	/* If nonzero, the frame represents a called
				 * Tcl procedure and may have local vars. Vars
				 * will ordinarily be looked up in the frame.
				 * If new variables are created, they will be

				 * created in the frame. If 0, the frame is
				 * for a "namespace eval" or "namespace
				 * inscope" command and var references are
				 * treated as references to namespace
				 * variables. */
{
    Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = (CallFrame *) callFramePtr;
    register Namespace *nsPtr;

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536



















































537
538
539
540
541
542
543
    framePtr->callerPtr = iPtr->framePtr;
    framePtr->callerVarPtr = iPtr->varFramePtr;
    if (iPtr->varFramePtr != NULL) {
	framePtr->level = (iPtr->varFramePtr->level + 1);
    } else {
	framePtr->level = 1;
    }
    framePtr->procPtr = NULL; 	   /* no called procedure */
    framePtr->varTablePtr = NULL;  /* and no local variables */
    framePtr->numCompiledLocals = 0;
    framePtr->compiledLocals = NULL;

    /*
     * Push the new call frame onto the interpreter's stack of procedure
     * call frames making it the current frame.
     */

    iPtr->framePtr = framePtr;
    iPtr->varFramePtr = framePtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PopCallFrame --
 *
 *	Removes a call frame from the Tcl call stack for the interpreter.
 *	Called to remove a frame previously pushed by Tcl_PushCallFrame.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the call stack of the interpreter. Resets various fields of
 *	the popped call frame. If a namespace has been deleted and
 *	has no more activations on the call stack, the namespace is
 *	destroyed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PopCallFrame(interp)
    Tcl_Interp* interp;		/* Interpreter with call frame to pop. */
{
    register Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = iPtr->framePtr;
    Namespace *nsPtr;

    /*
     * It's important to remove the call frame from the interpreter's stack
     * of call frames before deleting local variables, so that traces
     * invoked by the variable deletion don't see the partially-deleted
     * frame.
     */

    iPtr->framePtr = framePtr->callerPtr;
    iPtr->varFramePtr = framePtr->callerVarPtr;

    if (framePtr->varTablePtr != NULL) {
	TclDeleteVars(iPtr, framePtr->varTablePtr);
	ckfree((char *) framePtr->varTablePtr);
	framePtr->varTablePtr = NULL;
    }
    if (framePtr->numCompiledLocals > 0) {
	TclDeleteCompiledLocalVars(iPtr, framePtr);
    }

    /*
     * Decrement the namespace's count of active call frames. If the
     * namespace is "dying" and there are no more active call frames,
     * call Tcl_DeleteNamespace to destroy it.
     */

    nsPtr = framePtr->nsPtr;
    nsPtr->activationCount--;
    if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;
}




















































/*
 *----------------------------------------------------------------------
 *
 * EstablishErrorCodeTraces --
 *
 *	Creates traces on the ::errorCode variable to keep its value







|
|




|
|




















|
|
<













|
|
|
<















|
|
|









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464

465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
    framePtr->callerPtr = iPtr->framePtr;
    framePtr->callerVarPtr = iPtr->varFramePtr;
    if (iPtr->varFramePtr != NULL) {
	framePtr->level = (iPtr->varFramePtr->level + 1);
    } else {
	framePtr->level = 1;
    }
    framePtr->procPtr = NULL;		/* no called procedure */
    framePtr->varTablePtr = NULL;	/* and no local variables */
    framePtr->numCompiledLocals = 0;
    framePtr->compiledLocals = NULL;

    /*
     * Push the new call frame onto the interpreter's stack of procedure call
     * frames making it the current frame.
     */

    iPtr->framePtr = framePtr;
    iPtr->varFramePtr = framePtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PopCallFrame --
 *
 *	Removes a call frame from the Tcl call stack for the interpreter.
 *	Called to remove a frame previously pushed by Tcl_PushCallFrame.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the call stack of the interpreter. Resets various fields of
 *	the popped call frame. If a namespace has been deleted and has no more
 *	activations on the call stack, the namespace is destroyed.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_PopCallFrame(interp)
    Tcl_Interp* interp;		/* Interpreter with call frame to pop. */
{
    register Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = iPtr->framePtr;
    Namespace *nsPtr;

    /*
     * It's important to remove the call frame from the interpreter's stack of
     * call frames before deleting local variables, so that traces invoked by
     * the variable deletion don't see the partially-deleted frame.

     */

    iPtr->framePtr = framePtr->callerPtr;
    iPtr->varFramePtr = framePtr->callerVarPtr;

    if (framePtr->varTablePtr != NULL) {
	TclDeleteVars(iPtr, framePtr->varTablePtr);
	ckfree((char *) framePtr->varTablePtr);
	framePtr->varTablePtr = NULL;
    }
    if (framePtr->numCompiledLocals > 0) {
	TclDeleteCompiledLocalVars(iPtr, framePtr);
    }

    /*
     * Decrement the namespace's count of active call frames. If the namespace
     * is "dying" and there are no more active call frames, call
     * Tcl_DeleteNamespace to destroy it.
     */

    nsPtr = framePtr->nsPtr;
    nsPtr->activationCount--;
    if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushStackFrame --
 *
 *	Allocates a new call frame in the interpreter's execution stack, then
 *	pushes it onto the interpreter's Tcl call stack. Called when executing
 *	a Tcl procedure or a "namespace eval" or "namespace inscope" command.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result object) if something goes wrong.
 *
 * Side effects:
 *	Modifies the interpreter's Tcl call stack.
 *
 *----------------------------------------------------------------------
 */

int
TclPushStackFrame(interp, framePtrPtr, namespacePtr, isProcCallFrame)
    Tcl_Interp *interp;		/* Interpreter in which the new call frame is
				 * to be pushed. */
    Tcl_CallFrame **framePtrPtr;/* Place to store a pointer to the stack
				 * allocated call frame.*/
    Tcl_Namespace *namespacePtr;/* Points to the namespace in which the frame
				 * will execute. If NULL, the interpreter's
				 * current namespace will be used. */
    int isProcCallFrame;	/* If nonzero, the frame represents a called
				 * Tcl procedure and may have local vars. Vars
				 * will ordinarily be looked up in the frame.
				 * If new variables are created, they will be
				 * created in the frame. If 0, the frame is
				 * for a "namespace eval" or "namespace
				 * inscope" command and var references are
				 * treated as references to namespace
				 * variables. */
{
    *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
    return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
	    isProcCallFrame);
}

void
TclPopStackFrame(interp)
    Tcl_Interp* interp;		/* Interpreter with call frame to pop. */
{
    Tcl_PopCallFrame(interp);
    TclStackFree(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * EstablishErrorCodeTraces --
 *
 *	Creates traces on the ::errorCode variable to keep its value
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598

599

600
601
602
603
604
605
606
}

/*
 *----------------------------------------------------------------------
 *
 * ErrorCodeRead --
 *
 *	Called when the ::errorCode variable is read.  Copies the
 *	current value of the interp's errorCode field into ::errorCode.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
ErrorCodeRead(clientData, interp, name1, name2, flags)
    ClientData clientData;
    Tcl_Interp *interp;
    CONST char *name1;
    CONST char *name2;
    int flags;
{
    Interp *iPtr = (Interp *)interp;

    if (flags & TCL_INTERP_DESTROYED) return NULL;
    if (iPtr->errorCode == NULL) return NULL;

    Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * EstablishErrorInfoTraces --







|
|




















|
|
>
|
>







590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
}

/*
 *----------------------------------------------------------------------
 *
 * ErrorCodeRead --
 *
 *	Called when the ::errorCode variable is read. Copies the current value
 *	of the interp's errorCode field into ::errorCode.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
ErrorCodeRead(clientData, interp, name1, name2, flags)
    ClientData clientData;
    Tcl_Interp *interp;
    CONST char *name1;
    CONST char *name2;
    int flags;
{
    Interp *iPtr = (Interp *)interp;

    if (flags & TCL_INTERP_DESTROYED || iPtr->errorCode == NULL) {
	return NULL;
    }
    Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode,
	    TCL_GLOBAL_ONLY);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * EstablishErrorInfoTraces --
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663

664

665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
}

/*
 *----------------------------------------------------------------------
 *
 * ErrorInfoRead --
 *
 *	Called when the ::errorInfo variable is read.  Copies the
 *	current value of the interp's errorInfo field into ::errorInfo.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
ErrorInfoRead(clientData, interp, name1, name2, flags)
    ClientData clientData;
    Tcl_Interp *interp;
    CONST char *name1;
    CONST char *name2;
    int flags;
{
    Interp *iPtr = (Interp *)interp;

    if (flags & TCL_INTERP_DESTROYED) return NULL;
    if (iPtr->errorInfo == NULL) return NULL;

    Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateNamespace --
 *
 *	Creates a new namespace with the given name. If there is no
 *	active namespace (i.e., the interpreter is being initialized),
 *	the global :: namespace is created and returned.
 *
 * Results:
 *	Returns a pointer to the new namespace if successful. If the
 *	namespace already exists or if another error occurs, this routine
 *	returns NULL, along with an error message in the interpreter's
 *	result object.
 *
 * Side effects:
 *	If the name contains "::" qualifiers and a parent namespace does
 *	not already exist, it is automatically created. 
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_CreateNamespace(interp, name, clientData, deleteProc)
    Tcl_Interp *interp;		    /* Interpreter in which a new namespace
				     * is being created. Also used for
				     * error reporting. */
    CONST char *name;		    /* Name for the new namespace. May be a
				     * qualified name with names of ancestor
				     * namespaces separated by "::"s. */
    ClientData clientData;	    /* One-word value to store with
				     * namespace. */
    Tcl_NamespaceDeleteProc *deleteProc;
    				    /* Procedure called to delete client
				     * data when the namespace is deleted.
				     * NULL if no procedure should be
				     * called. */
{
    Interp *iPtr = (Interp *) interp;
    register Namespace *nsPtr, *ancestorPtr;
    Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
    Namespace *globalNsPtr = iPtr->globalNsPtr;
    CONST char *simpleName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer1, buffer2;
    int newEntry;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * If there is no active namespace, the interpreter is being
     * initialized. 
     */

    if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
	/*
	 * Treat this namespace as the global namespace, and avoid
	 * looking for a parent.
	 */

	parentPtr = NULL;
	simpleName = "";
    } else if (*name == '\0') {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "can't create namespace \"\": ",
		"only global namespace can have empty name", NULL);
	return NULL;
    } else {
	/*
	 * Find the parent for the new namespace.
	 */

	TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
		/*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
		&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);

	/*
	 * If the unqualified name at the end is empty, there were trailing
	 * "::"s after the namespace's name which we ignore. The new
	 * namespace was already (recursively) created and is pointed to
	 * by parentPtr.
	 */

	if (*simpleName == '\0') {
	    return (Tcl_Namespace *) parentPtr;
	}

	/*
	 * Check for a bad namespace name and make sure that the name
	 * does not already exist in the parent namespace.
	 */

	if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
	    Tcl_AppendResult(interp, "can't create namespace \"", name,
    	    	    "\": already exists", (char *) NULL);
	    return NULL;
	}
    }

    /*
     * Create the new namespace and root it in its parent. Increment the
     * count of namespaces created.
     */

    nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
    nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
    strcpy(nsPtr->name, simpleName);
    nsPtr->fullName = NULL;			/* set below */
    nsPtr->clientData = clientData;







|
|




















|
|
>
|
>








|
|
|


|
|
|
<


|
|






|
|
|
|
|
|
|
<

|
|
<
|












|
<




|
|




















|
|
<







|
|




|





|
|







657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706

707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723

724
725
726

727
728
729
730
731
732
733
734
735
736
737
738
739
740

741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768

769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
}

/*
 *----------------------------------------------------------------------
 *
 * ErrorInfoRead --
 *
 *	Called when the ::errorInfo variable is read. Copies the current value
 *	of the interp's errorInfo field into ::errorInfo.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
ErrorInfoRead(clientData, interp, name1, name2, flags)
    ClientData clientData;
    Tcl_Interp *interp;
    CONST char *name1;
    CONST char *name2;
    int flags;
{
    Interp *iPtr = (Interp *)interp;

    if (flags & TCL_INTERP_DESTROYED || iPtr->errorInfo == NULL) {
	return NULL;
    }
    Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
	    TCL_GLOBAL_ONLY);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateNamespace --
 *
 *	Creates a new namespace with the given name. If there is no active
 *	namespace (i.e., the interpreter is being initialized), the global ::
 *	namespace is created and returned.
 *
 * Results:
 *	Returns a pointer to the new namespace if successful. If the namespace
 *	already exists or if another error occurs, this routine returns NULL,
 *	along with an error message in the interpreter's result object.

 *
 * Side effects:
 *	If the name contains "::" qualifiers and a parent namespace does not
 *	already exist, it is automatically created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_CreateNamespace(interp, name, clientData, deleteProc)
    Tcl_Interp *interp;		/* Interpreter in which a new namespace is
				 * being created. Also used for error
				 * reporting. */
    CONST char *name;		/* Name for the new namespace. May be a
				 * qualified name with names of ancestor
				 * namespaces separated by "::"s. */
    ClientData clientData;	/* One-word value to store with namespace. */

    Tcl_NamespaceDeleteProc *deleteProc;
				/* Function called to delete client data when
				 * the namespace is deleted. NULL if no

				 * function should be called. */
{
    Interp *iPtr = (Interp *) interp;
    register Namespace *nsPtr, *ancestorPtr;
    Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
    Namespace *globalNsPtr = iPtr->globalNsPtr;
    CONST char *simpleName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer1, buffer2;
    int newEntry;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * If there is no active namespace, the interpreter is being initialized.

     */

    if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
	/*
	 * Treat this namespace as the global namespace, and avoid looking for
	 * a parent.
	 */

	parentPtr = NULL;
	simpleName = "";
    } else if (*name == '\0') {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "can't create namespace \"\": ",
		"only global namespace can have empty name", NULL);
	return NULL;
    } else {
	/*
	 * Find the parent for the new namespace.
	 */

	TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
		/*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
		&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);

	/*
	 * If the unqualified name at the end is empty, there were trailing
	 * "::"s after the namespace's name which we ignore. The new namespace
	 * was already (recursively) created and is pointed to by parentPtr.

	 */

	if (*simpleName == '\0') {
	    return (Tcl_Namespace *) parentPtr;
	}

	/*
	 * Check for a bad namespace name and make sure that the name does not
	 * already exist in the parent namespace.
	 */

	if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
	    Tcl_AppendResult(interp, "can't create namespace \"", name,
		    "\": already exists", (char *) NULL);
	    return NULL;
	}
    }

    /*
     * Create the new namespace and root it in its parent. Increment the count
     * of namespaces created.
     */

    nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
    nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
    strcpy(nsPtr->name, simpleName);
    nsPtr->fullName = NULL;			/* set below */
    nsPtr->clientData = clientData;
789
790
791
792
793
794
795



796
797
798
799
800
801
802
803
804
805

806
807
808
809
810
811
812
    nsPtr->cmdRefEpoch = 0;
    nsPtr->resolverEpoch = 0;
    nsPtr->cmdResProc = NULL;
    nsPtr->varResProc = NULL;
    nsPtr->compiledVarResProc = NULL;
    nsPtr->exportLookupEpoch = 0;
    nsPtr->ensembles = NULL;




    if (parentPtr != NULL) {
	entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
		&newEntry);
	Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
    } else {
	/* 
	 * In the global namespace create traces to maintain the
	 * ::errorInfo and ::errorCode variables.
	 */

	iPtr->globalNsPtr = nsPtr;
	EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
	EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
    }

    /*
     * Build the fully qualified name for this namespace.







>
>
>






|
|
|

>







810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    nsPtr->cmdRefEpoch = 0;
    nsPtr->resolverEpoch = 0;
    nsPtr->cmdResProc = NULL;
    nsPtr->varResProc = NULL;
    nsPtr->compiledVarResProc = NULL;
    nsPtr->exportLookupEpoch = 0;
    nsPtr->ensembles = NULL;
    nsPtr->commandPathLength = 0;
    nsPtr->commandPathArray = NULL;
    nsPtr->commandPathSourceList = NULL;

    if (parentPtr != NULL) {
	entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
		&newEntry);
	Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
    } else {
	/*
	 * In the global namespace create traces to maintain the ::errorInfo
	 * and ::errorCode variables.
	 */

	iPtr->globalNsPtr = nsPtr;
	EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
	EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
    }

    /*
     * Build the fully qualified name for this namespace.
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881


882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
 *	Deletes a namespace and all of the commands, variables, and other
 *	namespaces within it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When a namespace is deleted, it is automatically removed as a
 *	child of its parent namespace. Also, all its commands, variables
 *	and child namespaces are deleted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteNamespace(namespacePtr)
    Tcl_Namespace *namespacePtr;   /* Points to the namespace to delete. */
{
    register Namespace *nsPtr = (Namespace *) namespacePtr;
    Interp *iPtr = (Interp *) nsPtr->interp;
    Namespace *globalNsPtr =
	    (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
    Tcl_HashEntry *entryPtr;

    /*
     * If the namespace has associated ensemble commands, delete them
     * first.  This leaves the actual contents of the namespace alone
     * (unless they are linked ensemble commands, of course.)  Note
     * that this code is actually reentrant so command delete traces
     * won't purturb things badly.
     */

    while (nsPtr->ensembles != NULL) {


	/*
	 * Splice out and link to indicate that we've already been
	 * killed.
	 */
	EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;
	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
	ensemblePtr->next = ensemblePtr;
	Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
    }

    /*
     * If the namespace is on the call frame stack, it is marked as "dying"
     * (NS_DYING is OR'd into its flags): the namespace can't be looked up
     * by name but its commands and variables are still usable by those
     * active call frames. When all active call frames referring to the
     * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will
     * call this procedure again to delete everything in the namespace.
     * If no nsName objects refer to the namespace (i.e., if its refCount 
     * is zero), its commands and variables are deleted and the storage for
     * its namespace structure is freed. Otherwise, if its refCount is
     * nonzero, the namespace's commands and variables are deleted but the
     * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
     * flags to allow the namespace resolution code to recognize that the
     * namespace is "deleted". The structure's storage is freed by
     * FreeNsNameInternalRep when its refCount reaches 0.
     */

    if (nsPtr->activationCount > 0) {
	nsPtr->flags |= NS_DYING;
	if (nsPtr->parentPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
		    nsPtr->name);







|
|
|






|








|
|
|
<
|



>
>

|
<

|







|
|
|
|
|
|
|
|
|
|
|
|
|







874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901

902
903
904
905
906
907
908
909

910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
 *	Deletes a namespace and all of the commands, variables, and other
 *	namespaces within it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When a namespace is deleted, it is automatically removed as a child of
 *	its parent namespace. Also, all its commands, variables and child
 *	namespaces are deleted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteNamespace(namespacePtr)
    Tcl_Namespace *namespacePtr;	/* Points to the namespace to delete */
{
    register Namespace *nsPtr = (Namespace *) namespacePtr;
    Interp *iPtr = (Interp *) nsPtr->interp;
    Namespace *globalNsPtr =
	    (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
    Tcl_HashEntry *entryPtr;

    /*
     * If the namespace has associated ensemble commands, delete them first.
     * This leaves the actual contents of the namespace alone (unless they are
     * linked ensemble commands, of course). Note that this code is actually

     * reentrant so command delete traces won't purturb things badly.
     */

    while (nsPtr->ensembles != NULL) {
	EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;

	/*
	 * Splice out and link to indicate that we've already been killed.

	 */

	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
	ensemblePtr->next = ensemblePtr;
	Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
    }

    /*
     * If the namespace is on the call frame stack, it is marked as "dying"
     * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
     * name but its commands and variables are still usable by those active
     * call frames. When all active call frames referring to the namespace
     * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
     * function again to delete everything in the namespace. If no nsName
     * objects refer to the namespace (i.e., if its refCount is zero), its
     * commands and variables are deleted and the storage for its namespace
     * structure is freed. Otherwise, if its refCount is nonzero, the
     * namespace's commands and variables are deleted but the structure isn't
     * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
     * namespace resolution code to recognize that the namespace is "deleted".
     * The structure's storage is freed by FreeNsNameInternalRep when its
     * refCount reaches 0.
     */

    if (nsPtr->activationCount > 0) {
	nsPtr->flags |= NS_DYING;
	if (nsPtr->parentPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
		    nsPtr->name);
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951

952


953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
	 */

	TclTeardownNamespace(nsPtr);

	if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
	    /*
	     * If this is the global namespace, then it may have residual
	     * "errorInfo" and "errorCode" variables for errors that
	     * occurred while it was being torn down.  Try to clear the
	     * variable list one last time.
	     */

	    TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable);

	    Tcl_DeleteHashTable(&nsPtr->childTable);
	    Tcl_DeleteHashTable(&nsPtr->cmdTable);

	    /*
	     * If the reference count is 0, then discard the namespace.
	     * Otherwise, mark it as "dead" so that it can't be used.
	     */

	    if (nsPtr->refCount == 0) {
		NamespaceFree(nsPtr);
	    } else {
		nsPtr->flags |= NS_DEAD;
	    }
	} else {

	    /* Restore the ::errorInfo and ::errorCode traces */


	    EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
	    EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclTeardownNamespace --
 *
 *	Used internally to dismantle and unlink a namespace when it is
 *	deleted. Divorces the namespace from its parent, and deletes all
 *	commands, variables, and child namespaces.
 *
 *	This is kept separate from Tcl_DeleteNamespace so that the global
 *	namespace can be handled specially. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes this namespace from its parent's child namespace hashtable.
 *	Deletes all commands, variables and namespaces in this namespace.







|
|
|


















>
|
>
>
















|







949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
	 */

	TclTeardownNamespace(nsPtr);

	if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
	    /*
	     * If this is the global namespace, then it may have residual
	     * "errorInfo" and "errorCode" variables for errors that occurred
	     * while it was being torn down. Try to clear the variable list
	     * one last time.
	     */

	    TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable);

	    Tcl_DeleteHashTable(&nsPtr->childTable);
	    Tcl_DeleteHashTable(&nsPtr->cmdTable);

	    /*
	     * If the reference count is 0, then discard the namespace.
	     * Otherwise, mark it as "dead" so that it can't be used.
	     */

	    if (nsPtr->refCount == 0) {
		NamespaceFree(nsPtr);
	    } else {
		nsPtr->flags |= NS_DEAD;
	    }
	} else {
	    /*
	     * Restore the ::errorInfo and ::errorCode traces.
	     */

	    EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
	    EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclTeardownNamespace --
 *
 *	Used internally to dismantle and unlink a namespace when it is
 *	deleted. Divorces the namespace from its parent, and deletes all
 *	commands, variables, and child namespaces.
 *
 *	This is kept separate from Tcl_DeleteNamespace so that the global
 *	namespace can be handled specially.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes this namespace from its parent's child namespace hashtable.
 *	Deletes all commands, variables and namespaces in this namespace.
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049















































1050
1051
1052
1053
1054
1055
1056
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Namespace *childNsPtr;
    Tcl_Command cmd;
    int i;

    /*
     * Start by destroying the namespace's variable table,
     * since variables might trigger traces.
     * Variable table should be cleared but not freed!
     * TclDeleteVars frees it, so we reinitialize it afterwards.
     */

    TclDeleteVars(iPtr, &nsPtr->varTable);
    Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);

    /*
     * Remove the namespace from its parent's child hashtable.
     */

    if (nsPtr->parentPtr != NULL) {
	entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
		nsPtr->name);
	if (entryPtr != NULL) {
	    Tcl_DeleteHashEntry(entryPtr);
	}
    }
    nsPtr->parentPtr = NULL;

    /*
     * Delete all the child namespaces.
     *
     * BE CAREFUL: When each child is deleted, it will divorce
     *    itself from its parent. You can't traverse a hash table
     *    properly if its elements are being deleted. We use only
     *    the Tcl_FirstHashEntry function to be safe.
     *
     * Don't optimize to Tcl_NextHashEntry() because of traces.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
	childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
	Tcl_DeleteNamespace(childNsPtr);
    }

    /*
     * Delete all commands in this namespace. Be careful when traversing the
     * hash table: when each command is deleted, it removes itself from the
     * command table.
     *
     * Don't optimize to Tcl_NextHashEntry() because of traces.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
	cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
	Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
    }
    Tcl_DeleteHashTable(&nsPtr->cmdTable);
    Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
















































    /*
     * Free the namespace's export pattern array.
     */

    if (nsPtr->exportArrayPtr != NULL) {
	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {







|
<
|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1015
1016
1017
1018
1019
1020
1021
1022

1023
1024
1025
1026
1027
1028
1029































1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Namespace *childNsPtr;
    Tcl_Command cmd;
    int i;

    /*
     * Start by destroying the namespace's variable table, since variables

     * might trigger traces. Variable table should be cleared but not freed!
     * TclDeleteVars frees it, so we reinitialize it afterwards.
     */

    TclDeleteVars(iPtr, &nsPtr->varTable);
    Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
































    /*
     * Delete all commands in this namespace. Be careful when traversing the
     * hash table: when each command is deleted, it removes itself from the
     * command table.
     *
     * Don't optimize to Tcl_NextHashEntry() because of traces.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
	cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
	Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
    }
    Tcl_DeleteHashTable(&nsPtr->cmdTable);
    Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);

    /*
     * Remove the namespace from its parent's child hashtable.
     */

    if (nsPtr->parentPtr != NULL) {
	entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
		nsPtr->name);
	if (entryPtr != NULL) {
	    Tcl_DeleteHashEntry(entryPtr);
	}
    }
    nsPtr->parentPtr = NULL;

    /*
     * Delete the namespace path if one is installed.
     */

    if (nsPtr->commandPathLength != 0) {
	UnlinkNsPath(nsPtr);
	nsPtr->commandPathLength = 0;
    }
    if (nsPtr->commandPathSourceList != NULL) {
	NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
	do {
	    nsPathPtr->nsPtr = NULL;
	    nsPathPtr = nsPathPtr->nextPtr;
	} while (nsPathPtr != NULL);
    }

    /*
     * Delete all the child namespaces.
     *
     * BE CAREFUL: When each child is deleted, it will divorce itself from its
     *	  parent. You can't traverse a hash table properly if its elements are
     *	  being deleted. We use only the Tcl_FirstHashEntry function to be
     *	  safe.
     *
     * Don't optimize to Tcl_NextHashEntry() because of traces.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
	childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
	Tcl_DeleteNamespace(childNsPtr);
    }

    /*
     * Free the namespace's export pattern array.
     */

    if (nsPtr->exportArrayPtr != NULL) {
	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
    if (nsPtr->deleteProc != NULL) {
	(*nsPtr->deleteProc)(nsPtr->clientData);
    }
    nsPtr->deleteProc = NULL;
    nsPtr->clientData = NULL;

    /*
     * Reset the namespace's id field to ensure that this namespace won't
     * be interpreted as valid by, e.g., the cache validation code for
     * cached command references in Tcl_GetCommandFromObj.
     */

    nsPtr->nsId = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceFree --
 *
 *	Called after a namespace has been deleted, when its
 *	reference count reaches 0.  Frees the data structure
 *	representing the namespace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|
|
|










|
<
|







1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132

1133
1134
1135
1136
1137
1138
1139
1140
    if (nsPtr->deleteProc != NULL) {
	(*nsPtr->deleteProc)(nsPtr->clientData);
    }
    nsPtr->deleteProc = NULL;
    nsPtr->clientData = NULL;

    /*
     * Reset the namespace's id field to ensure that this namespace won't be
     * interpreted as valid by, e.g., the cache validation code for cached
     * command references in Tcl_GetCommandFromObj.
     */

    nsPtr->nsId = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceFree --
 *
 *	Called after a namespace has been deleted, when its reference count

 *	reaches 0. Frees the data structure representing the namespace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Export --
 *
 *	Makes all the commands matching a pattern available to later be
 *	imported from the namespace specified by namespacePtr (or the
 *	current namespace if namespacePtr is NULL). The specified pattern is
 *	appended onto the namespace's export pattern list, which is
 *	optionally cleared beforehand.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result) if something goes wrong.
 *
 * Side effects:
 *	Appends the export pattern onto the namespace's export list.
 *	Optionally reset the namespace's export pattern list.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
    Tcl_Interp *interp;		 /* Current interpreter. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace from which 
				  * commands are to be exported. NULL for
				  * the current namespace. */
    CONST char *pattern;	 /* String pattern indicating which commands
				  * to export. This pattern may not include
				  * any namespace qualifiers; only commands
				  * in the specified namespace may be
				  * exported. */
    int resetListFirst;		 /* If nonzero, resets the namespace's
				  * export list before appending. */
{
#define INIT_EXPORT_PATTERNS 5    
    Namespace *nsPtr, *exportNsPtr, *dummyPtr;
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    CONST char *simplePattern;
    char *patternCpy;
    int neededElems, len, i;

    /*







|
|
|
|














|
|
|
|
|
|
|
|
<
|
|

|







1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191

1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Export --
 *
 *	Makes all the commands matching a pattern available to later be
 *	imported from the namespace specified by namespacePtr (or the current
 *	namespace if namespacePtr is NULL). The specified pattern is appended
 *	onto the namespace's export pattern list, which is optionally cleared
 *	beforehand.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result) if something goes wrong.
 *
 * Side effects:
 *	Appends the export pattern onto the namespace's export list.
 *	Optionally reset the namespace's export pattern list.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Namespace *namespacePtr;/* Points to the namespace from which commands
				 * are to be exported. NULL for the current
				 * namespace. */
    CONST char *pattern;	/* String pattern indicating which commands to
				 * export. This pattern may not include any
				 * namespace qualifiers; only commands in the
				 * specified namespace may be exported. */

    int resetListFirst;		/* If nonzero, resets the namespace's export
				 * list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
    Namespace *nsPtr, *exportNsPtr, *dummyPtr;
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    CONST char *simplePattern;
    char *patternCpy;
    int neededElems, len, i;

    /*
1199
1200
1201
1202
1203
1204
1205

1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
		"\": pattern can't specify a namespace", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Make sure that we don't already have the pattern in the array
     */

    if (nsPtr->exportArrayPtr != NULL) {
	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	    if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
		/*
		 * The pattern already exists in the list
		 */
		return TCL_OK;
	    }
	}
    }

    /*
     * Make sure there is room in the namespace's pattern array for the
     * new pattern.
     */

    neededElems = nsPtr->numExportPatterns + 1;
    if (nsPtr->exportArrayPtr == NULL) {
	nsPtr->exportArrayPtr = (char **)
		ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
	nsPtr->numExportPatterns = 0;
	nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
    } else if (neededElems > nsPtr->maxExportPatterns) {
	int numNewElems = 2 * nsPtr->maxExportPatterns;
	size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
	size_t newBytes  = numNewElems * sizeof(char *);
	char **newPtr = (char **) ckalloc((unsigned) newBytes);

	memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes);
	ckfree((char *) nsPtr->exportArrayPtr);
	nsPtr->exportArrayPtr = (char **) newPtr;
	nsPtr->maxExportPatterns = numNewElems;
    }

    /*
     * Add the pattern to the namespace's array of export patterns.
     */

    len = strlen(pattern);
    patternCpy = (char *) ckalloc((unsigned) (len + 1));
    strcpy(patternCpy, pattern);

    nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
    nsPtr->numExportPatterns++;

    /*
     * The list of commands actually exported from the namespace might
     * have changed (probably will have!)  However, we do not need to
     * recompute this just yet; next time we need the info will be
     * soon enough.
     */

    TclInvalidateNsCmdLookup(nsPtr);

    return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendExportList --
 *
 *	Appends onto the argument object the list of export patterns for the
 *	specified namespace.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case the object
 *	referenced by objPtr has each export pattern appended to it. If an
 *	error occurs, TCL_ERROR is returned and the interpreter's result
 *	holds an error message.
 *
 * Side effects:
 *	If necessary, the object referenced by objPtr is converted into
 *	a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppendExportList(interp, namespacePtr, objPtr)
    Tcl_Interp *interp;		 /* Interpreter used for error reporting. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace whose export
				  * pattern list is appended onto objPtr.
				  * NULL for the current namespace. */
    Tcl_Obj *objPtr;		 /* Points to the Tcl object onto which the
				  * export pattern list is appended. */
{
    Namespace *nsPtr;
    int i, result;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */







>












|
|











|




















|
|
|
<



















|
|


|
|






|
|
|
|
|
|







1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296

1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
		"\": pattern can't specify a namespace", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Make sure that we don't already have the pattern in the array
     */

    if (nsPtr->exportArrayPtr != NULL) {
	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	    if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
		/*
		 * The pattern already exists in the list
		 */
		return TCL_OK;
	    }
	}
    }

    /*
     * Make sure there is room in the namespace's pattern array for the new
     * pattern.
     */

    neededElems = nsPtr->numExportPatterns + 1;
    if (nsPtr->exportArrayPtr == NULL) {
	nsPtr->exportArrayPtr = (char **)
		ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
	nsPtr->numExportPatterns = 0;
	nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
    } else if (neededElems > nsPtr->maxExportPatterns) {
	int numNewElems = 2 * nsPtr->maxExportPatterns;
	size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
	size_t newBytes = numNewElems * sizeof(char *);
	char **newPtr = (char **) ckalloc((unsigned) newBytes);

	memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes);
	ckfree((char *) nsPtr->exportArrayPtr);
	nsPtr->exportArrayPtr = (char **) newPtr;
	nsPtr->maxExportPatterns = numNewElems;
    }

    /*
     * Add the pattern to the namespace's array of export patterns.
     */

    len = strlen(pattern);
    patternCpy = (char *) ckalloc((unsigned) (len + 1));
    strcpy(patternCpy, pattern);

    nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
    nsPtr->numExportPatterns++;

    /*
     * The list of commands actually exported from the namespace might have
     * changed (probably will have!) However, we do not need to recompute this
     * just yet; next time we need the info will be soon enough.

     */

    TclInvalidateNsCmdLookup(nsPtr);

    return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendExportList --
 *
 *	Appends onto the argument object the list of export patterns for the
 *	specified namespace.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case the object
 *	referenced by objPtr has each export pattern appended to it. If an
 *	error occurs, TCL_ERROR is returned and the interpreter's result holds
 *	an error message.
 *
 * Side effects:
 *	If necessary, the object referenced by objPtr is converted into a list
 *	object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppendExportList(interp, namespacePtr, objPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    Tcl_Namespace *namespacePtr;/* Points to the namespace whose export
				 * pattern list is appended onto objPtr. NULL
				 * for the current namespace. */
    Tcl_Obj *objPtr;		/* Points to the Tcl object onto which the
				 * export pattern list is appended. */
{
    Namespace *nsPtr;
    int i, result;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Import --
 *
 *	Imports all of the commands matching a pattern into the namespace
 *	specified by namespacePtr (or the current namespace if contextNsPtr
 *	is NULL). This is done by creating a new command (the "imported
 *	command") that points to the real command in its original namespace.
 *
 *	If matching commands are on the autoload path but haven't been
 *	loaded yet, this command forces them to be loaded, then creates
 *	the links to them.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result) if something goes wrong.
 *
 * Side effects:
 *	Creates new commands in the importing namespace. These indirect
 *	calls back to the real command and are deleted if the real commands
 *	are deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
    Tcl_Interp *interp;		 /* Current interpreter. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace into which the
				  * commands are to be imported. NULL for
				  * the current namespace. */
    CONST char *pattern;	 /* String pattern indicating which commands
				  * to import. This pattern should be
				  * qualified by the name of the namespace
				  * from which to import the command(s). */
    int allowOverwrite;		 /* If nonzero, allow existing commands to
				  * be overwritten by imported commands.
				  * If 0, return an error if an imported
				  * cmd conflicts with an existing one. */
{
    Namespace *nsPtr, *importNsPtr, *dummyPtr;
    CONST char *simplePattern;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * First, invoke the "auto_import" command with the pattern
     * being imported.  This command is part of the Tcl library.
     * It looks for imported commands in autoloaded libraries and
     * loads them in.  That way, they will be found when we try
     * to create links below.
     *
     * Note that we don't just call Tcl_EvalObjv() directly because we
     * do not want absence of the command to be a failure case.
     */

    if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
	Tcl_Obj *objv[2];
	int result;

	objv[0] = Tcl_NewStringObj("auto_import", -1);







|
|
|

|
|
|






|
|
|






|
|
|
|
|
|
|
|
|
|
|
|

















|
|
|
|
<

|
|







1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422

1423
1424
1425
1426
1427
1428
1429
1430
1431
1432

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Import --
 *
 *	Imports all of the commands matching a pattern into the namespace
 *	specified by namespacePtr (or the current namespace if contextNsPtr is
 *	NULL). This is done by creating a new command (the "imported command")
 *	that points to the real command in its original namespace.
 *
 *	If matching commands are on the autoload path but haven't been loaded
 *	yet, this command forces them to be loaded, then creates the links to
 *	them.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result) if something goes wrong.
 *
 * Side effects:
 *	Creates new commands in the importing namespace. These indirect calls
 *	back to the real command and are deleted if the real commands are
 *	deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Namespace *namespacePtr;/* Points to the namespace into which the
				 * commands are to be imported. NULL for the
				 * current namespace. */
    CONST char *pattern;	/* String pattern indicating which commands to
				 * import. This pattern should be qualified by
				 * the name of the namespace from which to
				 * import the command(s). */
    int allowOverwrite;		/* If nonzero, allow existing commands to be
				 * overwritten by imported commands. If 0,
				 * return an error if an imported cmd
				 * conflicts with an existing one. */
{
    Namespace *nsPtr, *importNsPtr, *dummyPtr;
    CONST char *simplePattern;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * First, invoke the "auto_import" command with the pattern being
     * imported. This command is part of the Tcl library. It looks for
     * imported commands in autoloaded libraries and loads them in. That way,
     * they will be found when we try to create links below.

     *
     * Note that we don't just call Tcl_EvalObjv() directly because we do not
     * want absence of the command to be a failure case.
     */

    if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
	Tcl_Obj *objv[2];
	int result;

	objv[0] = Tcl_NewStringObj("auto_import", -1);
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }

    /*
     * From the pattern, find the namespace from which we are importing
     * and get the simple pattern (no namespace qualifiers or ::'s) at
     * the end.
     */

    if (strlen(pattern) == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1));
	return TCL_ERROR;
    }
    TclGetNamespaceForQualName(interp, pattern, nsPtr,







|
|
<







1441
1442
1443
1444
1445
1446
1447
1448
1449

1450
1451
1452
1453
1454
1455
1456
	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }

    /*
     * From the pattern, find the namespace from which we are importing and
     * get the simple pattern (no namespace qualifiers or ::'s) at the end.

     */

    if (strlen(pattern) == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1));
	return TCL_ERROR;
    }
    TclGetNamespaceForQualName(interp, pattern, nsPtr,
1439
1440
1441
1442
1443
1444
1445








1446
1447
1448
1449








1450




1451
1452

1453








1454
1455
1456









1457
1458
1459
1460

1461




1462


1463
1464
1465

1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543





1544
1545
1546



1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625


1626
1627







1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640

1641

1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656

1657
1658
1659
1660
1661
1662
1663
    /*
     * Scan through the command table in the source namespace and look for
     * exported commands that match the string pattern. Create an "imported
     * command" in the current namespace for each imported command; these
     * commands redirect their invocations to the "real" command.
     */









    for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
	    (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
	char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
	if (Tcl_StringMatch(cmdName, simplePattern)) {








	    /*




	     * The command cmdName in the source namespace matches the
	     * pattern. Check whether it was exported. If it wasn't,

	     * we ignore it.








	     */
	    Tcl_HashEntry *found;
	    int wasExported = 0, i;










	    for (i = 0;  i < importNsPtr->numExportPatterns;  i++) {
		if (Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i])) {
		    wasExported = 1;

		    break;




		}


	    }
	    if (!wasExported) {
		continue;

	    }

	    /*
	     * Unless there is a name clash, create an imported command
	     * in the current namespace that refers to cmdPtr.
	     */

	    found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
	    if ((found == NULL) || allowOverwrite) {
		/*
		 * Create the imported command and its client data.
		 * To create the new command in the current namespace, 
		 * generate a fully qualified name for it.
		 */

		Tcl_DString ds;
		Tcl_Command importedCmd;
		ImportedCmdData *dataPtr;
		Command *cmdPtr;
		ImportRef *refPtr;

		Tcl_DStringInit(&ds);
		Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
		if (nsPtr != ((Interp *) interp)->globalNsPtr) {
		    Tcl_DStringAppend(&ds, "::", 2);
		}
		Tcl_DStringAppend(&ds, cmdName, -1);

		/*
		 * Check whether creating the new imported command in the
		 * current namespace would create a cycle of imported
		 * command references.
		 */

		cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
		if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
		    Command *overwrite = (Command *) Tcl_GetHashValue(found);
		    Command *link = cmdPtr;

		    while (link->deleteProc == DeleteImportedCmd) {
			ImportedCmdData *dataPtr;

			dataPtr = (ImportedCmdData *) link->objClientData;
			link = dataPtr->realCmdPtr;
			if (overwrite == link) {
			    Tcl_AppendResult(interp, "import pattern \"",
				    pattern,
				    "\" would create a loop containing ",
				    "command \"", Tcl_DStringValue(&ds),
				    "\"", (char *) NULL);
			    Tcl_DStringFree(&ds);
			    return TCL_ERROR;
			}
		    }
		}

		dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
		importedCmd = Tcl_CreateObjCommand(interp, 
			Tcl_DStringValue(&ds), InvokeImportedCmd,
			(ClientData) dataPtr, DeleteImportedCmd);
		dataPtr->realCmdPtr = cmdPtr;
		dataPtr->selfPtr = (Command *) importedCmd;
		dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
		Tcl_DStringFree(&ds);

		/*
		 * Create an ImportRef structure describing this new import
		 * command and add it to the import ref list in the "real"
		 * command.
		 */

		refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
		refPtr->importedCmdPtr = (Command *) importedCmd;
		refPtr->nextPtr = cmdPtr->importRefPtr;
		cmdPtr->importRefPtr = refPtr;
	    } else {
		Tcl_AppendResult(interp, "can't import command \"", cmdName,
			"\": already exists", (char *) NULL);





		return TCL_ERROR;
	    }
	}



    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForgetImport --
 *
 *	Deletes commands previously imported into the namespace indicated.  The
 *	by namespacePtr, or the current namespace of interp, when
 *	namespacePtr is NULL.  The pattern controls which imported commands
 *	are deleted.  A simple pattern, one without namespace separators,
 *	matches the current command names of imported commands in the
 *	namespace.  Matching imported commands are deleted.  A qualified
 *	pattern is interpreted as deletion selection on the basis of where
 *	the command is imported from.  The original command and "first link"
 *	command for each imported command are determined, and they are matched
 *	against the pattern.  A match leads to deletion of the imported
 *	command.
 *
 * Results:
 * 	Returns TCL_ERROR and records an error message in the interp
 * 	result if a namespace qualified pattern refers to a namespace
 * 	that does not exist.  Otherwise, returns TCL_OK.
 *
 * Side effects:
 *	May delete commands. 
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ForgetImport(interp, namespacePtr, pattern)
    Tcl_Interp *interp;		 /* Current interpreter. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace from which
				  * previously imported commands should be
				  * removed. NULL for current namespace. */
    CONST char *pattern;	 /* String pattern indicating which imported
				  * commands to remove. */
{
    Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
    CONST char *simplePattern;
    char *cmdName;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Parse the pattern into its namespace-qualification (if any)
     * and the simple pattern.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
	    &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if (sourceNsPtr == NULL) {
	Tcl_AppendResult(interp,
		"unknown namespace in namespace forget pattern \"",
		pattern, "\"", (char *) NULL);
	return TCL_ERROR;
    }

    if (strcmp(pattern, simplePattern) == 0) {
	/*
	 * The pattern is simple.
	 * Delete any imported commands that match it.
	 */



	for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
		(hPtr != NULL);







		hPtr = Tcl_NextHashEntry(&search)) {
	    Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
	    if (cmdPtr->deleteProc != DeleteImportedCmd) {
		continue;
	    }
	    cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
	    if (Tcl_StringMatch(cmdName, simplePattern)) {
		Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	    }
	}
	return TCL_OK;
    }


    /* The pattern was namespace-qualified */


    for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
	    hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_CmdInfo info;
	Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
	Tcl_Command origin = TclGetOriginalCommand(token);

	if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
	    continue;	/* Not an imported command */
	}
	if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
	    /*
	     * Original not in namespace we're matching.
	     * Check the first link in the import chain.
	     */

	    Command *cmdPtr = (Command *) token;
	    ImportedCmdData *dataPtr =
		    (ImportedCmdData *) cmdPtr->objClientData;
	    Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
	    if (firstToken == origin) {
		continue;
	    }







>
>
>
>
>
>
>
>



|
>
>
>
>
>
>
>
>
|
>
>
>
>
|
|
>
|
>
>
>
>
>
>
>
>
|
|
<
>
>
>
>
>
>
>
>
>
|
<
<
|
>
|
>
>
>
>
|
>
>
|
|
<
>
|

|
|
|
|

|
|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|

|
|
|
<
|

|
|
|
|

|
|

|
|
|
|
<
|
<
|
|
|
|
|
|

|
|
<
|
|
|
|
|

|
|
|
<
|

|
|
|
|
|
|
|
>
>
>
>
>
|


>
>
>









|
|
|
|
|
|
|
|
|
|
<


|
|
|


|






|
|
|
|
|
|


















|
|















|
<


>
>
|
|
>
>
>
>
>
>
>
|












>
|
>








|



|
|

>







1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523

1524
1525
1526
1527
1528
1529
1530
1531
1532
1533


1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545

1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577

1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591

1592

1593
1594
1595
1596
1597
1598
1599
1600
1601

1602
1603
1604
1605
1606
1607
1608
1609
1610

1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649

1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705

1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
    /*
     * Scan through the command table in the source namespace and look for
     * exported commands that match the string pattern. Create an "imported
     * command" in the current namespace for each imported command; these
     * commands redirect their invocations to the "real" command.
     */

    if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) {
	hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern);
	if (hPtr == NULL) {
	    return TCL_OK;
	}
	return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
		importNsPtr, allowOverwrite);
    }
    for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
	    (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
	char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
	if (Tcl_StringMatch(cmdName, simplePattern) &&
		DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
		allowOverwrite) == TCL_ERROR) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * DoImport --
 *
 *	Import a particular command from one namespace into another. Helper
 *	for Tcl_Import().
 *
 * Results:
 *	Standard Tcl result code. If TCL_ERROR, appends an error message to
 *	the interpreter result.
 *
 * Side effects:
 *	A new command is created in the target namespace unless this is a
 *	reimport of exactly the same command as before.
 *
 *----------------------------------------------------------------------
 */


static int
DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite)
    Tcl_Interp *interp;
    Namespace *nsPtr;
    Tcl_HashEntry *hPtr;
    CONST char *cmdName;
    CONST char *pattern;
    Namespace *importNsPtr;
    int allowOverwrite;
{


    int i = 0, exported = 0;
    Tcl_HashEntry *found;

    /*
     * The command cmdName in the source namespace matches the pattern. Check
     * whether it was exported. If it wasn't, we ignore it.
     */

    while (!exported && (i < importNsPtr->numExportPatterns)) {
	exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]);
    }
    if (!exported) {

	return TCL_OK;
    }

    /*
     * Unless there is a name clash, create an imported command in the current
     * namespace that refers to cmdPtr.
     */

    found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
    if ((found == NULL) || allowOverwrite) {
	/*
	 * Create the imported command and its client data. To create the new
	 * command in the current namespace, generate a fully qualified name
	 * for it.
	 */

	Tcl_DString ds;
	Tcl_Command importedCmd;
	ImportedCmdData *dataPtr;
	Command *cmdPtr;
	ImportRef *refPtr;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	if (nsPtr != ((Interp *) interp)->globalNsPtr) {
	    Tcl_DStringAppend(&ds, "::", 2);
	}
	Tcl_DStringAppend(&ds, cmdName, -1);

	/*
	 * Check whether creating the new imported command in the current
	 * namespace would create a cycle of imported command references.

	 */

	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
	if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
	    Command *overwrite = (Command *) Tcl_GetHashValue(found);
	    Command *link = cmdPtr;

	    while (link->deleteProc == DeleteImportedCmd) {
		ImportedCmdData *dataPtr;

		dataPtr = (ImportedCmdData *) link->objClientData;
		link = dataPtr->realCmdPtr;
		if (overwrite == link) {
		    Tcl_AppendResult(interp, "import pattern \"", pattern,

			    "\" would create a loop containing command \"",

			    Tcl_DStringValue(&ds), "\"", (char *) NULL);
		    Tcl_DStringFree(&ds);
		    return TCL_ERROR;
		}
	    }
	}

	dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
	importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),

		InvokeImportedCmd, (ClientData) dataPtr, DeleteImportedCmd);
	dataPtr->realCmdPtr = cmdPtr;
	dataPtr->selfPtr = (Command *) importedCmd;
	dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
	Tcl_DStringFree(&ds);

	/*
	 * Create an ImportRef structure describing this new import command
	 * and add it to the import ref list in the "real" command.

	 */

	refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
	refPtr->importedCmdPtr = (Command *) importedCmd;
	refPtr->nextPtr = cmdPtr->importRefPtr;
	cmdPtr->importRefPtr = refPtr;
    } else {
	Command *overwrite = (Command *) Tcl_GetHashValue(found);

	if (overwrite->deleteProc == DeleteImportedCmd) {
	    ImportedCmdData *dataPtr = (ImportedCmdData *)
		    overwrite->objClientData;
	    if (dataPtr->realCmdPtr == (Command *) Tcl_GetHashValue(hPtr)) {
		/* Repeated import of same command -- acceptable */
		return TCL_OK;
	    }
	}
	Tcl_AppendResult(interp, "can't import command \"", cmdName,
		"\": already exists", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForgetImport --
 *
 *	Deletes commands previously imported into the namespace indicated.
 *	The by namespacePtr, or the current namespace of interp, when
 *	namespacePtr is NULL. The pattern controls which imported commands are
 *	deleted. A simple pattern, one without namespace separators, matches
 *	the current command names of imported commands in the namespace.
 *	Matching imported commands are deleted. A qualified pattern is
 *	interpreted as deletion selection on the basis of where the command is
 *	imported from. The original command and "first link" command for each
 *	imported command are determined, and they are matched against the
 *	pattern. A match leads to deletion of the imported command.

 *
 * Results:
 *	Returns TCL_ERROR and records an error message in the interp result if
 *	a namespace qualified pattern refers to a namespace that does not
 *	exist. Otherwise, returns TCL_OK.
 *
 * Side effects:
 *	May delete commands.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ForgetImport(interp, namespacePtr, pattern)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Namespace *namespacePtr;/* Points to the namespace from which
				 * previously imported commands should be
				 * removed. NULL for current namespace. */
    CONST char *pattern;	/* String pattern indicating which imported
				 * commands to remove. */
{
    Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
    CONST char *simplePattern;
    char *cmdName;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Parse the pattern into its namespace-qualification (if any) and the
     * simple pattern.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
	    &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if (sourceNsPtr == NULL) {
	Tcl_AppendResult(interp,
		"unknown namespace in namespace forget pattern \"",
		pattern, "\"", (char *) NULL);
	return TCL_ERROR;
    }

    if (strcmp(pattern, simplePattern) == 0) {
	/*
	 * The pattern is simple. Delete any imported commands that match it.

	 */

	if (TclMatchIsTrivial(simplePattern)) {
	    Command *cmdPtr;
	    hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
	    if ((hPtr != NULL)
		    && (cmdPtr = (Command *) Tcl_GetHashValue(hPtr))
		    && (cmdPtr->deleteProc == DeleteImportedCmd)) {
		Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	    }
	    return TCL_OK;
	}
	for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
		(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
	    Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
	    if (cmdPtr->deleteProc != DeleteImportedCmd) {
		continue;
	    }
	    cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
	    if (Tcl_StringMatch(cmdName, simplePattern)) {
		Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	    }
	}
	return TCL_OK;
    }

    /*
     * The pattern was namespace-qualified.
     */

    for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
	    hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_CmdInfo info;
	Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
	Tcl_Command origin = TclGetOriginalCommand(token);

	if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
	    continue;			/* Not an imported command */
	}
	if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
	    /*
	     * Original not in namespace we're matching. Check the first link
	     * in the import chain.
	     */

	    Command *cmdPtr = (Command *) token;
	    ImportedCmdData *dataPtr =
		    (ImportedCmdData *) cmdPtr->objClientData;
	    Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
	    if (firstToken == origin) {
		continue;
	    }
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
/*
 *----------------------------------------------------------------------
 *
 * TclGetOriginalCommand --
 *
 *	An imported command is created in an namespace when a "real" command
 *	is imported from another namespace. If the specified command is an
 *	imported command, this procedure returns the original command it
 *	refers to. 
 *
 * Results:
 *	If the command was imported into a sequence of namespaces a, b,...,n
 *	where each successive namespace just imports the command from the
 *	previous namespace, this procedure returns the Tcl_Command token in
 *	the first namespace, a. Otherwise, if the specified command is not
 *	an imported command, the procedure returns NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclGetOriginalCommand(command)
    Tcl_Command command;	/* The imported command for which the
				 * original command should be returned. */
{
    register Command *cmdPtr = (Command *) command;
    ImportedCmdData *dataPtr;

    if (cmdPtr->deleteProc != DeleteImportedCmd) {
	return (Tcl_Command) NULL;
    }

    while (cmdPtr->deleteProc == DeleteImportedCmd) {
	dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
	cmdPtr = dataPtr->realCmdPtr;
    }
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeImportedCmd --
 *
 *	Invoked by Tcl whenever the user calls an imported command that
 *	was created by Tcl_Import. Finds the "real" command (in another
 *	namespace), and passes control to it.
 *
 * Results:
 *	Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result object is set to an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InvokeImportedCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Points to the imported command's







|
|




|
|
|









|
|




















|
|



|


|
|







1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
/*
 *----------------------------------------------------------------------
 *
 * TclGetOriginalCommand --
 *
 *	An imported command is created in an namespace when a "real" command
 *	is imported from another namespace. If the specified command is an
 *	imported command, this function returns the original command it refers
 *	to.
 *
 * Results:
 *	If the command was imported into a sequence of namespaces a, b,...,n
 *	where each successive namespace just imports the command from the
 *	previous namespace, this function returns the Tcl_Command token in the
 *	first namespace, a. Otherwise, if the specified command is not an
 *	imported command, the function returns NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclGetOriginalCommand(command)
    Tcl_Command command;	/* The imported command for which the original
				 * command should be returned. */
{
    register Command *cmdPtr = (Command *) command;
    ImportedCmdData *dataPtr;

    if (cmdPtr->deleteProc != DeleteImportedCmd) {
	return (Tcl_Command) NULL;
    }

    while (cmdPtr->deleteProc == DeleteImportedCmd) {
	dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
	cmdPtr = dataPtr->realCmdPtr;
    }
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeImportedCmd --
 *
 *	Invoked by Tcl whenever the user calls an imported command that was
 *	created by Tcl_Import. Finds the "real" command (in another
 *	namespace), and passes control to it.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result object is set to an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InvokeImportedCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Points to the imported command's
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770

/*
 *----------------------------------------------------------------------
 *
 * DeleteImportedCmd --
 *
 *	Invoked by Tcl whenever an imported command is deleted. The "real"
 *	command keeps a list of all the imported commands that refer to it,
 *	so those imported commands can be deleted when the real command is
 *	deleted. This procedure removes the imported command reference from
 *	the real command's list, and frees up the memory associated with
 *	the imported command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the imported command from the real command's import list.
 *







|
|
|
|
|







1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864

/*
 *----------------------------------------------------------------------
 *
 * DeleteImportedCmd --
 *
 *	Invoked by Tcl whenever an imported command is deleted. The "real"
 *	command keeps a list of all the imported commands that refer to it, so
 *	those imported commands can be deleted when the real command is
 *	deleted. This function removes the imported command reference from the
 *	real command's list, and frees up the memory associated with the
 *	imported command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the imported command from the real command's import list.
 *
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceForQualName --
 *
 *	Given a qualified name specifying a command, variable, or namespace,
 *	and a namespace in which to resolve the name, this procedure returns
 *	a pointer to the namespace that contains the item. A qualified name
 *	consists of the "simple" name of an item qualified by the names of
 *	an arbitrary number of containing namespace separated by "::"s. If
 *	the qualified name starts with "::", it is interpreted absolutely
 *	from the global namespace. Otherwise, it is interpreted relative to
 *	the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
 *	is NULL, the name is interpreted relative to the current namespace.
 *
 *	A relative name like "foo::bar::x" can be found starting in either
 *	the current namespace or in the global namespace. So each search
 *	usually follows two tracks, and two possible namespaces are
 *	returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to
 *	NULL, then that path failed.
 *
 *	If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
 *	sought only in the global :: namespace. The alternate search
 *	(also) starting from the global namespace is ignored and
 *	*altNsPtrPtr is set NULL. 
 *
 *	If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
 *	name is sought only in the namespace specified by cxtNsPtr. The
 *	alternate search starting from the global namespace is ignored and
 *	*altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
 *	TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
 *	the search starts from the namespace specified by cxtNsPtr.
 *
 *	If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace
 *	components of the qualified name that cannot be found are
 *	automatically created within their specified parent. This makes sure
 *	that functions like Tcl_CreateCommand always succeed. There is no
 *	alternate search path, so *altNsPtrPtr is set NULL.
 *
 *	If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as a
 *	reference to a namespace, and the entire qualified name is
 *	followed. If the name is relative, the namespace is looked up only
 *	in the current namespace. A pointer to the namespace is stored in
 *	*nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if
 *	TCL_FIND_ONLY_NS is not specified, only the leading components are
 *	treated as namespace names, and a pointer to the simple name of the
 *	final component is stored in *simpleNamePtr.
 *
 * Results:
 *	It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
 *	namespaces which represent the last (containing) namespace in the
 *	qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
 *	to NULL, then the search along that path failed.  The procedure also
 *	stores a pointer to the simple name of the final component in
 *	*simpleNamePtr. If the qualified name is "::" or was treated as a
 *	namespace reference (TCL_FIND_ONLY_NS), the procedure stores a pointer
 *	to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
 *	*simpleNamePtr to point to an empty string.
 *
 *	If there is an error, this procedure returns TCL_ERROR. If "flags"
 *	contains TCL_LEAVE_ERR_MSG, an error message is returned in the
 *	interpreter's result object. Otherwise, the interpreter's result
 *	object is left unchanged.
 *
 *	*actualCxtPtrPtr is set to the actual context namespace. It is
 *	set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr
 *	is NULL, it is set to the current namespace context.
 *
 *	For backwards compatibility with the TclPro byte code loader,
 *	this function always returns TCL_OK.
 *
 * Side effects:
 *	If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be
 *	created.
 *
 *----------------------------------------------------------------------
 */

int
TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
	nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
    Tcl_Interp *interp;		 /* Interpreter in which to find the
				  * namespace containing qualName. */
    CONST char *qualName;	 /* A namespace-qualified name of an
				  * command, variable, or namespace. */
    Namespace *cxtNsPtr;	 /* The namespace in which to start the
				  * search for qualName's namespace. If NULL
				  * start from the current namespace.
				  * Ignored if TCL_GLOBAL_ONLY is set. */
    int flags;			 /* Flags controlling the search: an OR'd
				  * combination of TCL_GLOBAL_ONLY,
				  * TCL_NAMESPACE_ONLY,
				  * TCL_CREATE_NS_IF_UNKNOWN, and
				  * TCL_FIND_ONLY_NS. */
    Namespace **nsPtrPtr;	 /* Address where procedure stores a pointer
				  * to containing namespace if qualName is
				  * found starting from *cxtNsPtr or, if
				  * TCL_GLOBAL_ONLY is set, if qualName is
				  * found in the global :: namespace. NULL
				  * is stored otherwise. */
    Namespace **altNsPtrPtr;	 /* Address where procedure stores a pointer
				  * to containing namespace if qualName is
				  * found starting from the global ::
				  * namespace. NULL is stored if qualName
				  * isn't found starting from :: or if the
				  * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				  * TCL_CREATE_NS_IF_UNKNOWN, TCL_FIND_ONLY_NS
				  * flag is set. */
    Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer
				  * to the actual namespace from which the
				  * search started. This is either cxtNsPtr,
				  * the :: namespace if TCL_GLOBAL_ONLY was
				  * specified, or the current namespace if
				  * cxtNsPtr was NULL. */
    CONST char **simpleNamePtr;	 /* Address where procedure stores the
				  * simple name at end of the qualName, or
				  * NULL if qualName is "::" or the flag
				  * TCL_FIND_ONLY_NS was specified. */
{
    Interp *iPtr = (Interp *) interp;
    Namespace *nsPtr = cxtNsPtr;
    Namespace *altNsPtr;
    Namespace *globalNsPtr = iPtr->globalNsPtr;
    CONST char *start, *end;
    CONST char *nsName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer;
    int len;

    /*
     * Determine the context namespace nsPtr in which to start the primary
     * search.  If the qualName name starts with a "::" or TCL_GLOBAL_ONLY
     * was specified, search from the global namespace. Otherwise, use the
     * namespace given in cxtNsPtr, or if that is NULL, use the current
     * namespace context. Note that we always treat two or more
     * adjacent ":"s as a namespace separator.
     */

    if (flags & TCL_GLOBAL_ONLY) {
	nsPtr = globalNsPtr;
    } else if (nsPtr == NULL) {
	if (iPtr->varFramePtr != NULL) {
	    nsPtr = iPtr->varFramePtr->nsPtr;







|
|
|
|
|
|
|
|

|
|
|
|
|


|
|
|

|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
|
|




|
|


|



|




|
|
|

|
|











|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|













|
|

|
|







1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994

1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007

2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceForQualName --
 *
 *	Given a qualified name specifying a command, variable, or namespace,
 *	and a namespace in which to resolve the name, this function returns a
 *	pointer to the namespace that contains the item. A qualified name
 *	consists of the "simple" name of an item qualified by the names of an
 *	arbitrary number of containing namespace separated by "::"s. If the
 *	qualified name starts with "::", it is interpreted absolutely from the
 *	global namespace. Otherwise, it is interpreted relative to the
 *	namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is
 *	NULL, the name is interpreted relative to the current namespace.
 *
 *	A relative name like "foo::bar::x" can be found starting in either the
 *	current namespace or in the global namespace. So each search usually
 *	follows two tracks, and two possible namespaces are returned. If the
 *	function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path
 *	failed.
 *
 *	If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
 *	sought only in the global :: namespace. The alternate search (also)
 *	starting from the global namespace is ignored and *altNsPtrPtr is set
 *	NULL.
 *
 *	If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is
 *	sought only in the namespace specified by cxtNsPtr. The alternate
 *	search starting from the global namespace is ignored and *altNsPtrPtr
 *	is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are
 *	specified, TCL_GLOBAL_ONLY is ignored and the search starts from the
 *	namespace specified by cxtNsPtr.
 *
 *	If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components
 *	of the qualified name that cannot be found are automatically created
 *	within their specified parent. This makes sure that functions like
 *	Tcl_CreateCommand always succeed. There is no alternate search path,
 *	so *altNsPtrPtr is set NULL.
 *
 *	If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as
 *	a reference to a namespace, and the entire qualified name is followed.
 *	If the name is relative, the namespace is looked up only in the
 *	current namespace. A pointer to the namespace is stored in *nsPtrPtr
 *	and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS
 *	is not specified, only the leading components are treated as namespace
 *	names, and a pointer to the simple name of the final component is
 *	stored in *simpleNamePtr.
 *
 * Results:
 *	It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
 *	namespaces which represent the last (containing) namespace in the
 *	qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr
 *	to NULL, then the search along that path failed. The function also
 *	stores a pointer to the simple name of the final component in
 *	*simpleNamePtr. If the qualified name is "::" or was treated as a
 *	namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer
 *	to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
 *	*simpleNamePtr to point to an empty string.
 *
 *	If there is an error, this function returns TCL_ERROR. If "flags"
 *	contains TCL_LEAVE_ERR_MSG, an error message is returned in the
 *	interpreter's result object. Otherwise, the interpreter's result
 *	object is left unchanged.
 *
 *	*actualCxtPtrPtr is set to the actual context namespace. It is set to
 *	the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL,
 *	it is set to the current namespace context.
 *
 *	For backwards compatibility with the TclPro byte code loader, this
 *	function always returns TCL_OK.
 *
 * Side effects:
 *	If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be
 *	created.
 *
 *----------------------------------------------------------------------
 */

int
TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
	nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find the namespace
				 * containing qualName. */
    CONST char *qualName;	/* A namespace-qualified name of an command,
				 * variable, or namespace. */
    Namespace *cxtNsPtr;	/* The namespace in which to start the search
				 * for qualName's namespace. If NULL start
				 * from the current namespace. Ignored if
				 * TCL_GLOBAL_ONLY is set. */
    int flags;			/* Flags controlling the search: an OR'd
				 * combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and
				 * TCL_CREATE_NS_IF_UNKNOWN. */

    Namespace **nsPtrPtr;	/* Address where function stores a pointer to
				 * containing namespace if qualName is found
				 * starting from *cxtNsPtr or, if
				 * TCL_GLOBAL_ONLY is set, if qualName is
				 * found in the global :: namespace. NULL is
				 * stored otherwise. */
    Namespace **altNsPtrPtr;	/* Address where function stores a pointer to
				 * containing namespace if qualName is found
				 * starting from the global :: namespace.
				 * NULL is stored if qualName isn't found
				 * starting from :: or if the TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS,
				 * TCL_CREATE_NS_IF_UNKNOWN flag is set. */

    Namespace **actualCxtPtrPtr;/* Address where function stores a pointer to
				 * the actual namespace from which the search
				 * started. This is either cxtNsPtr, the ::
				 * namespace if TCL_GLOBAL_ONLY was specified,
				 * or the current namespace if cxtNsPtr was
				 * NULL. */
    CONST char **simpleNamePtr; /* Address where function stores the simple
				 * name at end of the qualName, or NULL if
				 * qualName is "::" or the flag
				 * TCL_FIND_ONLY_NS was specified. */
{
    Interp *iPtr = (Interp *) interp;
    Namespace *nsPtr = cxtNsPtr;
    Namespace *altNsPtr;
    Namespace *globalNsPtr = iPtr->globalNsPtr;
    CONST char *start, *end;
    CONST char *nsName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer;
    int len;

    /*
     * Determine the context namespace nsPtr in which to start the primary
     * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was
     * specified, search from the global namespace. Otherwise, use the
     * namespace given in cxtNsPtr, or if that is NULL, use the current
     * namespace context. Note that we always treat two or more adjacent ":"s
     * as a namespace separator.
     */

    if (flags & TCL_GLOBAL_ONLY) {
	nsPtr = globalNsPtr;
    } else if (nsPtr == NULL) {
	if (iPtr->varFramePtr != NULL) {
	    nsPtr = iPtr->varFramePtr->nsPtr;
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
     * Loop to resolve each namespace qualifier in qualName.
     */

    Tcl_DStringInit(&buffer);
    end = start;
    while (*start != '\0') {
	/*
	 * Find the next namespace qualifier (i.e., a name ending in "::")
	 * or the end of the qualified name  (i.e., a name ending in "\0").
	 * Set len to the number of characters, starting from start,
	 * in the name; set end to point after the "::"s or at the "\0".
	 */

	len = 0;
	for (end = start;  *end != '\0';  end++) {
	    if ((*end == ':') && (*(end+1) == ':')) {
		end += 2;	/* skip over the initial :: */
		while (*end == ':') {
		    end++;	/* skip over the subsequent : */
		}
		break;		/* exit for loop; end is after ::'s */
	    }
	    len++;
	}

	if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) {
	    /*
	     * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
	     * was specified, look this up as a namespace. Otherwise,
	     * start is the name of a cmd or var and we are done.
	     */

	    if (flags & TCL_FIND_ONLY_NS) {
		nsName = start;
	    } else {
		*nsPtrPtr = nsPtr;
		*altNsPtrPtr = altNsPtr;
		*simpleNamePtr = start;
		Tcl_DStringFree(&buffer);
		return TCL_OK;
	    }
	} else {
	    /*
	     * start points to the beginning of a namespace qualifier ending
	     * in "::". end points to the start of a name in that namespace
	     * that might be empty. Copy the namespace qualifier to a
	     * buffer so it can be null terminated. We can't modify the
	     * incoming qualName since it may be a string constant.
	     */

	    Tcl_DStringSetLength(&buffer, 0);
	    Tcl_DStringAppend(&buffer, start, len);
	    nsName = Tcl_DStringValue(&buffer);
	}

	/*
	 * Look up the namespace qualifier nsName in the current namespace
	 * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
	 * create that qualifying namespace. This is needed for procedures
	 * like Tcl_CreateCommand that cannot fail.
	 */

	if (nsPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
	    if (entryPtr != NULL) {
		nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
	    } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
		Tcl_CallFrame frame;

		(void) Tcl_PushCallFrame(interp, &frame,
			(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);

		nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
			(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
		Tcl_PopCallFrame(interp);

		if (nsPtr == NULL) {
		    Tcl_Panic("Could not create namespace '%s'", nsName);
		}
	    } else {		/* namespace not found and wasn't created */
		nsPtr = NULL;
	    }







|
|
|
|

















|
|















|
|
|










|
|







|

|




|







2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
     * Loop to resolve each namespace qualifier in qualName.
     */

    Tcl_DStringInit(&buffer);
    end = start;
    while (*start != '\0') {
	/*
	 * Find the next namespace qualifier (i.e., a name ending in "::") or
	 * the end of the qualified name (i.e., a name ending in "\0"). Set
	 * len to the number of characters, starting from start, in the name;
	 * set end to point after the "::"s or at the "\0".
	 */

	len = 0;
	for (end = start;  *end != '\0';  end++) {
	    if ((*end == ':') && (*(end+1) == ':')) {
		end += 2;	/* skip over the initial :: */
		while (*end == ':') {
		    end++;	/* skip over the subsequent : */
		}
		break;		/* exit for loop; end is after ::'s */
	    }
	    len++;
	}

	if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) {
	    /*
	     * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
	     * was specified, look this up as a namespace. Otherwise, start is
	     * the name of a cmd or var and we are done.
	     */

	    if (flags & TCL_FIND_ONLY_NS) {
		nsName = start;
	    } else {
		*nsPtrPtr = nsPtr;
		*altNsPtrPtr = altNsPtr;
		*simpleNamePtr = start;
		Tcl_DStringFree(&buffer);
		return TCL_OK;
	    }
	} else {
	    /*
	     * start points to the beginning of a namespace qualifier ending
	     * in "::". end points to the start of a name in that namespace
	     * that might be empty. Copy the namespace qualifier to a buffer
	     * so it can be null terminated. We can't modify the incoming
	     * qualName since it may be a string constant.
	     */

	    Tcl_DStringSetLength(&buffer, 0);
	    Tcl_DStringAppend(&buffer, start, len);
	    nsName = Tcl_DStringValue(&buffer);
	}

	/*
	 * Look up the namespace qualifier nsName in the current namespace
	 * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
	 * create that qualifying namespace. This is needed for functions like
	 * Tcl_CreateCommand that cannot fail.
	 */

	if (nsPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
	    if (entryPtr != NULL) {
		nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
	    } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
		Tcl_CallFrame *framePtr;

		(void) TclPushStackFrame(interp, &framePtr,
			(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);

		nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
			(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
		TclPopStackFrame(interp);

		if (nsPtr == NULL) {
		    Tcl_Panic("Could not create namespace '%s'", nsName);
		}
	    } else {		/* namespace not found and wasn't created */
		nsPtr = NULL;
	    }
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245

2246
2247
2248
2249
2250
2251
2252
2253
2254
2255

2256
2257
2258
2259
2260
2261
2262

    /*
     * We ignore trailing "::"s in a namespace name, but in a command or
     * variable name, trailing "::"s refer to the cmd or var named {}.
     */

    if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) {
	*simpleNamePtr = NULL; /* found namespace name */
    } else {
	*simpleNamePtr = end;  /* found cmd/var: points to empty string */
    }

    /*
     * As a special case, if we are looking for a namespace and qualName
     * is "" and the current active namespace (nsPtr) is not the global
     * namespace, return NULL (no namespace was found). This is because
     * namespaces can not have empty names except for the global namespace.
     */

    if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
	    && (nsPtr != globalNsPtr)) {
	nsPtr = NULL;
    }

    *nsPtrPtr    = nsPtr;
    *altNsPtrPtr = altNsPtr;
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespace --
 *
 *	Searches for a namespace.
 *
 * Results:
 *	Returns a pointer to the namespace if it is found. Otherwise,
 *	returns NULL and leaves an error message in the interpreter's
 *	result object if "flags" contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_FindNamespace(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		 /* The interpreter in which to find the
				  * namespace. */
    CONST char *name;		 /* Namespace name. If it starts with "::",
				  * will be looked up in global namespace.
				  * Else, looked up first in contextNsPtr
				  * (current namespace if contextNsPtr is
				  * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set
				  * or if the name starts with "::".
				  * Otherwise, points to namespace in which
				  * to resolve name; if NULL, look up name
				  * in the current namespace. */
    register int flags;		 /* Flags controlling namespace lookup: an
				  * OR'd combination of TCL_GLOBAL_ONLY and
				  * TCL_LEAVE_ERR_MSG flags. */
{
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    CONST char *dummy;

    /*
     * Find the namespace(s) that contain the specified namespace name.
     * Add the TCL_FIND_ONLY_NS flag to resolve the name all the way down
     * to its last component, a namespace.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
	    flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);

    if (nsPtr != NULL) {
	return (Tcl_Namespace *) nsPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "unknown namespace \"", name,
		"\"", (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindCommand --
 *
 *	Searches for a command.
 *
 * Results:
 *	Returns a token for the command if it is found. Otherwise, if it
 *	can't be found or there is an error, returns NULL and leaves an
 *	error message in the interpreter's result object if "flags"
 *	contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_FindCommand(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		 /* The interpreter in which to find the
				  * command and to report errors. */
    CONST char *name;		 /* Command's name. If it starts with "::",
				  * will be looked up in global namespace.
				  * Else, looked up first in contextNsPtr
				  * (current namespace if contextNsPtr is
				  * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
				  * Otherwise, points to namespace in which
				  * to resolve name. If NULL, look up name
				  * in the current namespace. */
    int flags;			 /* An OR'd combination of flags:
				  * TCL_GLOBAL_ONLY (look up name only in
				  * global namespace), TCL_NAMESPACE_ONLY
				  * (look up only in contextNsPtr, or the
				  * current namespace if contextNsPtr is
				  * NULL), and TCL_LEAVE_ERR_MSG. If both
				  * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
				  * are given, TCL_GLOBAL_ONLY is
				  * ignored. */
{
    Interp *iPtr = (Interp*)interp;

    ResolverScheme *resPtr;
    Namespace *nsPtr[2], *cxtNsPtr;
    CONST char *simpleName;
    register Tcl_HashEntry *entryPtr;
    register Command *cmdPtr;
    register int search;
    int result;
    Tcl_Command cmd;

    /*
     * If this namespace has a command resolver, then give it first
     * crack at the command resolution.  If the interpreter has any
     * command resolvers, consult them next.  The command resolver
     * procedures may return a Tcl_Command value, they may signal
     * to continue onward, or they may signal an error.
     */

    if ((flags & TCL_GLOBAL_ONLY) != 0) {
	cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    } else if (contextNsPtr != NULL) {
	cxtNsPtr = (Namespace *) contextNsPtr;
    } else {
	cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    }

    if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
	resPtr = iPtr->resolverPtr;


	if (cxtNsPtr->cmdResProc) {
	    result = (*cxtNsPtr->cmdResProc)(interp, name,
		    (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
	} else {
	    result = TCL_CONTINUE;
	}







|

|



|
|
|
|







|













|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|





|
|
|









|
|












|
|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<


<
<
|
<


|

<


|
|
|
|
|

>
|








|
>







2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317

2318
2319


2320

2321
2322
2323
2324

2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351

    /*
     * We ignore trailing "::"s in a namespace name, but in a command or
     * variable name, trailing "::"s refer to the cmd or var named {}.
     */

    if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) {
	*simpleNamePtr = NULL;	/* found namespace name */
    } else {
	*simpleNamePtr = end;	/* found cmd/var: points to empty string */
    }

    /*
     * As a special case, if we are looking for a namespace and qualName is ""
     * and the current active namespace (nsPtr) is not the global namespace,
     * return NULL (no namespace was found). This is because namespaces can
     * not have empty names except for the global namespace.
     */

    if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
	    && (nsPtr != globalNsPtr)) {
	nsPtr = NULL;
    }

    *nsPtrPtr = nsPtr;
    *altNsPtrPtr = altNsPtr;
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespace --
 *
 *	Searches for a namespace.
 *
 * Results:
 *	Returns a pointer to the namespace if it is found. Otherwise, returns
 *	NULL and leaves an error message in the interpreter's result object if
 *	"flags" contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_FindNamespace(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		/* The interpreter in which to find the
				 * namespace. */
    CONST char *name;		/* Namespace name. If it starts with "::",
				 * will be looked up in global namespace.
				 * Else, looked up first in contextNsPtr
				 * (current namespace if contextNsPtr is
				 * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag is set or
				 * if the name starts with "::". Otherwise,
				 * points to namespace in which to resolve
				 * name; if NULL, look up name in the current
				 * namespace. */
    register int flags;		/* Flags controlling namespace lookup: an OR'd
				 * combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG flags. */
{
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    CONST char *dummy;

    /*
     * Find the namespace(s) that contain the specified namespace name. Add
     * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its
     * last component, a namespace.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
	    flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);

    if (nsPtr != NULL) {
	return (Tcl_Namespace *) nsPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "unknown namespace \"", name, "\"",
		(char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindCommand --
 *
 *	Searches for a command.
 *
 * Results:
 *	Returns a token for the command if it is found. Otherwise, if it can't
 *	be found or there is an error, returns NULL and leaves an error
 *	message in the interpreter's result object if "flags" contains
 *	TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_FindCommand(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		/* The interpreter in which to find the
				 * command and to report errors. */
    CONST char *name;		/* Command's name. If it starts with "::",
				 * will be looked up in global namespace.
				 * Else, looked up first in contextNsPtr
				 * (current namespace if contextNsPtr is
				 * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag set.
				 * Otherwise, points to namespace in which to
				 * resolve name. If NULL, look up name in the
				 * current namespace. */
    int flags;			/* An OR'd combination of flags:
				 * TCL_GLOBAL_ONLY (look up name only in
				 * global namespace), TCL_NAMESPACE_ONLY (look
				 * up only in contextNsPtr, or the current
				 * namespace if contextNsPtr is NULL), and
				 * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY are given,
				 * TCL_GLOBAL_ONLY is ignored. */

{
    Interp *iPtr = (Interp*)interp;


    Namespace *cxtNsPtr;

    register Tcl_HashEntry *entryPtr;
    register Command *cmdPtr;
    CONST char *simpleName;
    int result;


    /*
     * If this namespace has a command resolver, then give it first crack at
     * the command resolution. If the interpreter has any command resolvers,
     * consult them next. The command resolver functions may return a
     * Tcl_Command value, they may signal to continue onward, or they may
     * signal an error.
     */

    if (flags & TCL_GLOBAL_ONLY) {
	cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    } else if (contextNsPtr != NULL) {
	cxtNsPtr = (Namespace *) contextNsPtr;
    } else {
	cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    }

    if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
	ResolverScheme *resPtr = iPtr->resolverPtr;
	Tcl_Command cmd;

	if (cxtNsPtr->cmdResProc) {
	    result = (*cxtNsPtr->cmdResProc)(interp, name,
		    (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
	} else {
	    result = TCL_CONTINUE;
	}
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293



2294
2295
2296
2297
2298
2299
2300
2301




























































2302
2303


2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372

2373
2374
2375
2376
2377
2378
2379
	}
    }

    /*
     * Find the namespace(s) that contain the command.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
	    flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);

    /*
     * Look for the command in the command table of its namespace.
     * Be sure to check both possible search paths: from the specified
     * namespace context and from the global namespace.
     */

    cmdPtr = NULL;
    for (search = 0;  (search < 2) && (cmdPtr == NULL);  search++) {



	if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
		    simpleName);
	    if (entryPtr != NULL) {
		cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
	    }
	}
    }




























































    if (cmdPtr != NULL) {
	return (Tcl_Command) cmdPtr;


    } else if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "unknown command \"", name,
		"\"", (char *) NULL);
    }

    return (Tcl_Command) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespaceVar --
 *
 *	Searches for a namespace variable, a variable not local to a
 *	procedure. The variable can be either a scalar or an array, but
 *	may not be an element of an array.
 *
 * Results:
 *	Returns a token for the variable if it is found. Otherwise, if it
 *	can't be found or there is an error, returns NULL and leaves an
 *	error message in the interpreter's result object if "flags"
 *	contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		 /* The interpreter in which to find the
				  * variable. */
    CONST char *name;		 /* Variable's name. If it starts with "::",
				  * will be looked up in global namespace.
				  * Else, looked up first in contextNsPtr
				  * (current namespace if contextNsPtr is
				  * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
				  * Otherwise, points to namespace in which
				  * to resolve name. If NULL, look up name
				  * in the current namespace. */
    int flags;			 /* An OR'd combination of flags:
				  * TCL_GLOBAL_ONLY (look up name only in
				  * global namespace), TCL_NAMESPACE_ONLY
				  * (look up only in contextNsPtr, or the
				  * current namespace if contextNsPtr is
				  * NULL), and TCL_LEAVE_ERR_MSG. If both
				  * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
				  * are given, TCL_GLOBAL_ONLY is
				  * ignored. */
{
    Interp *iPtr = (Interp*)interp;
    ResolverScheme *resPtr;
    Namespace *nsPtr[2], *cxtNsPtr;
    CONST char *simpleName;
    Tcl_HashEntry *entryPtr;
    Var *varPtr;
    register int search;
    int result;
    Tcl_Var var;

    /*
     * If this namespace has a variable resolver, then give it first
     * crack at the variable resolution.  It may return a Tcl_Var
     * value, it may signal to continue onward, or it may signal
     * an error.
     */

    if ((flags & TCL_GLOBAL_ONLY) != 0) {
	cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    } else if (contextNsPtr != NULL) {
	cxtNsPtr = (Namespace *) contextNsPtr;
    } else {
	cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    }







|
|
|
<
<
<
|
<

<
<
>
>
>
|
|
<




|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
|




<









|
|



|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<












|
|
|
<

>







2365
2366
2367
2368
2369
2370
2371
2372
2373
2374



2375

2376


2377
2378
2379
2380
2381

2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455

2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500

2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515

2516
2517
2518
2519
2520
2521
2522
2523
2524
	}
    }

    /*
     * Find the namespace(s) that contain the command.
     */

    cmdPtr = NULL;
    if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)) {
	int i;



	Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;




	(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
		TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		&simpleName);
	if (realNsPtr != NULL && simpleName != NULL) {
	    entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);

	    if (entryPtr != NULL) {
		cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
	    }
	}

	/*
	 * Next, check along the path.
	 */

	for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
	    pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
	    if (pathNsPtr == NULL) {
		continue;
	    }
	    (void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
		    TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		    &simpleName);
	    if (realNsPtr != NULL && simpleName != NULL) {
		entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
		}
	    }
	}

	/*
	 * If we've still not found the command, look in the global namespace
	 * as a last resort.
	 */

	if (cmdPtr == NULL) {
	    (void) TclGetNamespaceForQualName(interp, name, NULL,
		    TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		    &simpleName);
	    if (realNsPtr != NULL && simpleName != NULL) {
		entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
		}
	    }
	}
    } else {
	Namespace *nsPtr[2];
	register int search;

	TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
		flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);

	/*
	 * Look for the command in the command table of its namespace. Be sure
	 * to check both possible search paths: from the specified namespace
	 * context and from the global namespace.
	 */

	for (search = 0;  (search < 2) && (cmdPtr == NULL);  search++) {
	    if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
		entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
			simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
		}
	    }
	}
    }

    if (cmdPtr != NULL) {
	return (Tcl_Command) cmdPtr;
    }

    if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "unknown command \"", name,
		"\"", (char *) NULL);
    }

    return (Tcl_Command) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespaceVar --
 *
 *	Searches for a namespace variable, a variable not local to a
 *	procedure. The variable can be either a scalar or an array, but may
 *	not be an element of an array.
 *
 * Results:
 *	Returns a token for the variable if it is found. Otherwise, if it
 *	can't be found or there is an error, returns NULL and leaves an error
 *	message in the interpreter's result object if "flags" contains
 *	TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		/* The interpreter in which to find the
				 * variable. */
    CONST char *name;		/* Variable's name. If it starts with "::",
				 * will be looked up in global namespace.
				 * Else, looked up first in contextNsPtr
				 * (current namespace if contextNsPtr is
				 * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag set.
				 * Otherwise, points to namespace in which to
				 * resolve name. If NULL, look up name in the
				 * current namespace. */
    int flags;			/* An OR'd combination of flags:
				 * TCL_GLOBAL_ONLY (look up name only in
				 * global namespace), TCL_NAMESPACE_ONLY (look
				 * up only in contextNsPtr, or the current
				 * namespace if contextNsPtr is NULL), and
				 * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY are given,
				 * TCL_GLOBAL_ONLY is ignored. */

{
    Interp *iPtr = (Interp*)interp;
    ResolverScheme *resPtr;
    Namespace *nsPtr[2], *cxtNsPtr;
    CONST char *simpleName;
    Tcl_HashEntry *entryPtr;
    Var *varPtr;
    register int search;
    int result;
    Tcl_Var var;

    /*
     * If this namespace has a variable resolver, then give it first crack at
     * the variable resolution. It may return a Tcl_Var value, it may signal
     * to continue onward, or it may signal an error.

     */

    if ((flags & TCL_GLOBAL_ONLY) != 0) {
	cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    } else if (contextNsPtr != NULL) {
	cxtNsPtr = (Namespace *) contextNsPtr;
    } else {
	cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    }
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547

2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
     * Find the namespace(s) that contain the variable.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
	    flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);

    /*
     * Look for the variable in the variable table of its namespace.
     * Be sure to check both possible search paths: from the specified
     * namespace context and from the global namespace.
     */

    varPtr = NULL;
    for (search = 0;  (search < 2) && (varPtr == NULL);  search++) {
	if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName);
	    if (entryPtr != NULL) {
		varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    }
	}
    }
    if (varPtr != NULL) {
	return (Tcl_Var) varPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "unknown variable \"", name,
		"\"", (char *) NULL);
    }
    return (Tcl_Var) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclResetShadowedCmdRefs --
 *
 *	Called when a command is added to a namespace to check for existing
 *	command references that the new command may invalidate. Consider the
 *	following cases that could happen when you add a command "foo" to a
 *	namespace "b":
 *	   1. It could shadow a command named "foo" at the global scope.
 *	      If it does, all command references in the namespace "b" are
 *	      suspect.
 *	   2. Suppose the namespace "b" resides in a namespace "a".
 *	      Then to "a" the new command "b::foo" could shadow another
 *	      command "b::foo" in the global namespace. If so, then all
 *	      command references in "a" are suspect.
 *	The same checks are applied to all parent namespaces, until we
 *	reach the global :: namespace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the new command shadows an existing command, the cmdRefEpoch
 *	counter is incremented in each namespace that sees the shadow.
 *	This invalidates all command references that were previously cached
 *	in that namespace. The next time the commands are used, they are
 *	resolved from scratch.
 *
 *----------------------------------------------------------------------
 */

void
TclResetShadowedCmdRefs(interp, newCmdPtr)
    Tcl_Interp *interp;		/* Interpreter containing the new command. */
    Command *newCmdPtr;		/* Points to the new command. */
{
    char *cmdName;
    Tcl_HashEntry *hPtr;
    register Namespace *nsPtr;
    Namespace *trailNsPtr, *shadowNsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    int found, i;

    /*
     * This procedure generates an array used to hold the trail list. This
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */

    Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
    Namespace **trailPtr = trailStorage;
    int trailFront = -1;
    int trailSize = NUM_TRAIL_ELEMS;

    /*
     * Start at the namespace containing the new command, and work up
     * through the list of parents. Stop just before the global namespace,
     * since the global namespace can't "shadow" its own entries.
     *
     * The namespace "trail" list we build consists of the names of each
     * namespace that encloses the new command, in order from outermost to
     * innermost: for example, "a" then "b". Each iteration of this loop
     * eventually extends the trail upwards by one namespace, nsPtr. We use
     * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
     * now-invalid cached command references. This will happen if nsPtr
     * (e.g. "a") contains a sequence of child namespaces (e.g. "b")
     * such that there is a identically-named sequence of child namespaces
     * starting from :: (e.g. "::b") whose tail namespace contains a command
     * also named cmdName.
     */

    cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
    for (nsPtr = newCmdPtr->nsPtr;
	    (nsPtr != NULL) && (nsPtr != globalNsPtr);
	    nsPtr = nsPtr->parentPtr) {
	/*
	 * Find the maximal sequence of child namespaces contained in nsPtr
	 * such that there is a identically-named sequence of child
	 * namespaces starting from ::. shadowNsPtr will be the tail of this
	 * sequence, or the deepest namespace under :: that might contain a
	 * command now shadowed by cmdName. We check below if shadowNsPtr
	 * actually contains a command cmdName.
	 */

	found = 1;
	shadowNsPtr = globalNsPtr;

	for (i = trailFront;  i >= 0;  i--) {
	    trailNsPtr = trailPtr[i];
	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
		    trailNsPtr->name);
	    if (hPtr != NULL) {
		shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
	    } else {
		found = 0;
		break;
	    }
	}

	/*
	 * If shadowNsPtr contains a command named cmdName, we invalidate
	 * all of the command refs cached in nsPtr. As a boundary case,
	 * shadowNsPtr is initially :: and we check for case 1. above.
	 */

	if (found) {
	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
	    if (hPtr != NULL) {
		nsPtr->cmdRefEpoch++;


		/* 
		 * If the shadowed command was compiled to bytecodes, we
		 * invalidate all the bytecodes in nsPtr, to force a new
		 * compilation. We use the resolverEpoch to signal the need
		 * for a fresh compilation of every bytecode.
		 */

		if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) {
		    nsPtr->resolverEpoch++;
		}
	    }
	}

	/*
	 * Insert nsPtr at the front of the trail list: i.e., at the end
	 * of the trailPtr array.
	 */

	trailFront++;
	if (trailFront == trailSize) {
	    size_t currBytes = trailSize * sizeof(Namespace *);
	    int newSize = 2*trailSize;
	    size_t newBytes = newSize * sizeof(Namespace *);
	    Namespace **newPtr =
		    (Namespace **) ckalloc((unsigned) newBytes);

	    memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes);
	    if (trailPtr != trailStorage) {
		ckfree((char *) trailPtr);
	    }
	    trailPtr = newPtr;
	    trailSize = newSize;







|
|
|















|
|













|
|

|
|
|
|
|
|






|
|
|
|

















|










|
|
|







|
|
|
|



|
<
|


|
|
|
|
|


















|
|







>

|













|
|







<
|







2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656

2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716

2717
2718
2719
2720
2721
2722
2723
2724
     * Find the namespace(s) that contain the variable.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
	    flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);

    /*
     * Look for the variable in the variable table of its namespace. Be sure
     * to check both possible search paths: from the specified namespace
     * context and from the global namespace.
     */

    varPtr = NULL;
    for (search = 0;  (search < 2) && (varPtr == NULL);  search++) {
	if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
	    entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName);
	    if (entryPtr != NULL) {
		varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    }
	}
    }
    if (varPtr != NULL) {
	return (Tcl_Var) varPtr;
    } else if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "unknown variable \"", name, "\"",
		(char *) NULL);
    }
    return (Tcl_Var) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclResetShadowedCmdRefs --
 *
 *	Called when a command is added to a namespace to check for existing
 *	command references that the new command may invalidate. Consider the
 *	following cases that could happen when you add a command "foo" to a
 *	namespace "b":
 *	   1. It could shadow a command named "foo" at the global scope. If
 *	      it does, all command references in the namespace "b" are
 *	      suspect.
 *	   2. Suppose the namespace "b" resides in a namespace "a". Then to
 *	      "a" the new command "b::foo" could shadow another command
 *	      "b::foo" in the global namespace. If so, then all command
 *	      references in "a" * are suspect.
 *	The same checks are applied to all parent namespaces, until we reach
 *	the global :: namespace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the new command shadows an existing command, the cmdRefEpoch
 *	counter is incremented in each namespace that sees the shadow. This
 *	invalidates all command references that were previously cached in that
 *	namespace. The next time the commands are used, they are resolved from
 *	scratch.
 *
 *----------------------------------------------------------------------
 */

void
TclResetShadowedCmdRefs(interp, newCmdPtr)
    Tcl_Interp *interp;		/* Interpreter containing the new command. */
    Command *newCmdPtr;		/* Points to the new command. */
{
    char *cmdName;
    Tcl_HashEntry *hPtr;
    register Namespace *nsPtr;
    Namespace *trailNsPtr, *shadowNsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    int found, i;

    /*
     * This function generates an array used to hold the trail list. This
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */

    Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
    Namespace **trailPtr = trailStorage;
    int trailFront = -1;
    int trailSize = NUM_TRAIL_ELEMS;

    /*
     * Start at the namespace containing the new command, and work up through
     * the list of parents. Stop just before the global namespace, since the
     * global namespace can't "shadow" its own entries.
     *
     * The namespace "trail" list we build consists of the names of each
     * namespace that encloses the new command, in order from outermost to
     * innermost: for example, "a" then "b". Each iteration of this loop
     * eventually extends the trail upwards by one namespace, nsPtr. We use
     * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
     * now-invalid cached command references. This will happen if nsPtr
     * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that
     * there is a identically-named sequence of child namespaces starting from
     * :: (e.g. "::b") whose tail namespace contains a command also named
     * cmdName.
     */

    cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
    for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;

	    nsPtr=nsPtr->parentPtr) {
	/*
	 * Find the maximal sequence of child namespaces contained in nsPtr
	 * such that there is a identically-named sequence of child namespaces
	 * starting from ::. shadowNsPtr will be the tail of this sequence, or
	 * the deepest namespace under :: that might contain a command now
	 * shadowed by cmdName. We check below if shadowNsPtr actually
	 * contains a command cmdName.
	 */

	found = 1;
	shadowNsPtr = globalNsPtr;

	for (i = trailFront;  i >= 0;  i--) {
	    trailNsPtr = trailPtr[i];
	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
		    trailNsPtr->name);
	    if (hPtr != NULL) {
		shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
	    } else {
		found = 0;
		break;
	    }
	}

	/*
	 * If shadowNsPtr contains a command named cmdName, we invalidate all
	 * of the command refs cached in nsPtr. As a boundary case,
	 * shadowNsPtr is initially :: and we check for case 1. above.
	 */

	if (found) {
	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
	    if (hPtr != NULL) {
		nsPtr->cmdRefEpoch++;
		TclInvalidateNsPath(nsPtr);

		/*
		 * If the shadowed command was compiled to bytecodes, we
		 * invalidate all the bytecodes in nsPtr, to force a new
		 * compilation. We use the resolverEpoch to signal the need
		 * for a fresh compilation of every bytecode.
		 */

		if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) {
		    nsPtr->resolverEpoch++;
		}
	    }
	}

	/*
	 * Insert nsPtr at the front of the trail list: i.e., at the end of
	 * the trailPtr array.
	 */

	trailFront++;
	if (trailFront == trailSize) {
	    size_t currBytes = trailSize * sizeof(Namespace *);
	    int newSize = 2*trailSize;
	    size_t newBytes = newSize * sizeof(Namespace *);

	    Namespace **newPtr = (Namespace **) ckalloc((unsigned) newBytes);

	    memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes);
	    if (trailPtr != trailStorage) {
		ckfree((char *) trailPtr);
	    }
	    trailPtr = newPtr;
	    trailSize = newSize;
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
	ckfree((char *) trailPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * GetNamespaceFromObj --
 *
 *	Gets the namespace specified by the name in a Tcl_Obj.
 *
 * Results:
 *	Returns TCL_OK if the namespace was resolved successfully, and
 *	stores a pointer to the namespace in the location specified by
 *	nsPtrPtr. If the namespace can't be found, the procedure stores
 *	NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong,
 *	this procedure returns TCL_ERROR.
 *
 * Side effects:
 *	May update the internal representation for the object, caching the
 *	namespace reference. The next time this procedure is called, the
 *	namespace value can be found quickly.
 *
 *	If anything goes wrong, an error message is left in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
GetNamespaceFromObj(interp, objPtr, nsPtrPtr)
    Tcl_Interp *interp;		/* The current interpreter. */
    Tcl_Obj *objPtr;		/* The object to be resolved as the name
				 * of a namespace. */
    Tcl_Namespace **nsPtrPtr;	/* Result namespace pointer goes here. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedNsName *resNamePtr;
    register Namespace *nsPtr;
    Namespace *currNsPtr;
    CallFrame *savedFramePtr;
    int result = TCL_OK;
    char *name;

    /*
     * If the namespace name is fully qualified, do as if the lookup were
     * done from the global namespace; this helps avoid repeated lookups 
     * of fully qualified names. 
     */

    savedFramePtr = iPtr->varFramePtr;
    name = TclGetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	iPtr->varFramePtr = NULL;
    }

    currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);

    /*
     * Get the internal representation, converting to a namespace type if
     * needed. The internal representation is a ResolvedNsName that points
     * to the actual namespace.
     */

    if (objPtr->typePtr != &tclNsNameType) {
	result = tclNsNameType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    goto done;
	}
    }
    resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;

    /*
     * Check the context namespace of the resolved symbol to make sure that
     * it is fresh. If not, then force another conversion to the namespace
     * type, to discard the old rep and create a new one. Note that we
     * verify that the namespace id of the cached namespace is the same as
     * the id when we cached it; this insures that the namespace wasn't
     * deleted and a new one created at the same address.
     */

    nsPtr = NULL;
    if ((resNamePtr != NULL)
	    && (resNamePtr->refNsPtr == currNsPtr)
	    && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
	nsPtr = resNamePtr->nsPtr;
	if (nsPtr->flags & NS_DEAD) {
	    nsPtr = NULL;
	}
    }
    if (nsPtr == NULL) {	/* try again */







|




|
|
|
|
|



|


|
|




|
|

|
|











|
|
|












|
|











|
|
|
|
|
|



|
<







2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816

2817
2818
2819
2820
2821
2822
2823
	ckfree((char *) trailPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceFromObj --
 *
 *	Gets the namespace specified by the name in a Tcl_Obj.
 *
 * Results:
 *	Returns TCL_OK if the namespace was resolved successfully, and stores
 *	a pointer to the namespace in the location specified by nsPtrPtr. If
 *	the namespace can't be found, the function stores NULL in *nsPtrPtr
 *	and returns TCL_OK. If anything else goes wrong, this function returns
 *	TCL_ERROR.
 *
 * Side effects:
 *	May update the internal representation for the object, caching the
 *	namespace reference. The next time this function is called, the
 *	namespace value can be found quickly.
 *
 *	If anything goes wrong, an error message is left in the interpreter's
 *	result object.
 *
 *----------------------------------------------------------------------
 */

int
TclGetNamespaceFromObj(interp, objPtr, nsPtrPtr)
    Tcl_Interp *interp;		/* The current interpreter. */
    Tcl_Obj *objPtr;		/* The object to be resolved as the name of a
				 * namespace. */
    Tcl_Namespace **nsPtrPtr;	/* Result namespace pointer goes here. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedNsName *resNamePtr;
    register Namespace *nsPtr;
    Namespace *currNsPtr;
    CallFrame *savedFramePtr;
    int result = TCL_OK;
    char *name;

    /*
     * If the namespace name is fully qualified, do as if the lookup were done
     * from the global namespace; this helps avoid repeated lookups of fully
     * qualified names.
     */

    savedFramePtr = iPtr->varFramePtr;
    name = TclGetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	iPtr->varFramePtr = NULL;
    }

    currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);

    /*
     * Get the internal representation, converting to a namespace type if
     * needed. The internal representation is a ResolvedNsName that points to
     * the actual namespace.
     */

    if (objPtr->typePtr != &tclNsNameType) {
	result = tclNsNameType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    goto done;
	}
    }
    resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;

    /*
     * Check the context namespace of the resolved symbol to make sure that it
     * is fresh. If not, then force another conversion to the namespace type,
     * to discard the old rep and create a new one. Note that we verify that
     * the namespace id of the cached namespace is the same as the id when we
     * cached it; this insures that the namespace wasn't deleted and a new one
     * created at the same address.
     */

    nsPtr = NULL;
    if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr)

	    && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
	nsPtr = resNamePtr->nsPtr;
	if (nsPtr->flags & NS_DEAD) {
	    nsPtr = NULL;
	}
    }
    if (nsPtr == NULL) {	/* try again */
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711

2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NamespaceObjCmd --
 *
 *	Invoked to implement the "namespace" command that creates, deletes,
 *	or manipulates Tcl namespaces. Handles the following syntax:
 *
 *	    namespace children ?name? ?pattern?
 *	    namespace code arg
 *	    namespace current
 *	    namespace delete ?name name...?

 *	    namespace eval name arg ?arg...?
 *	    namespace exists name
 *	    namespace export ?-clear? ?pattern pattern...?
 *	    namespace forget ?pattern pattern...?
 *	    namespace import ?-force? ?pattern pattern...?
 *	    namespace inscope name arg ?arg...?
 *	    namespace origin name
 *	    namespace parent ?name?
 *	    namespace qualifiers string
 *	    namespace tail string
 *	    namespace which ?-command? ?-variable? name
 *
 * Results:
 *	Returns TCL_OK if the command is successful. Returns TCL_ERROR if
 *	anything goes wrong.
 *
 * Side effects:
 *	Based on the subcommand name (e.g., "import"), this procedure
 *	dispatches to a corresponding procedure NamespaceXXXCmd defined
 *	statically in this file. This procedure's side effects depend on
 *	whatever that subcommand procedure does. If there is an error, this
 *	procedure returns an error message in the interpreter's result
 *	object. Otherwise it may return a result in the interpreter's result
 *	object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Arbitrary value passed to cmd. */
    Tcl_Interp *interp;			/* Current interpreter. */
    register int objc;			/* Number of arguments. */
    register Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    static CONST char *subCmds[] = {
	"children", "code", "current", "delete", "ensemble",
	"eval", "exists", "export", "forget", "import",
	"inscope", "origin", "parent", "qualifiers",
	"tail", "which", (char *) NULL
    };
    enum NSSubCmdIdx {
	NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
	NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
	NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
	NSTailIdx, NSWhichIdx
    };
    int index, result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
	return TCL_ERROR;







|
|





>

















|
|
|
|
|
|
<














|





|







2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878

2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NamespaceObjCmd --
 *
 *	Invoked to implement the "namespace" command that creates, deletes, or
 *	manipulates Tcl namespaces. Handles the following syntax:
 *
 *	    namespace children ?name? ?pattern?
 *	    namespace code arg
 *	    namespace current
 *	    namespace delete ?name name...?
 *	    namespace ensemble subcommand ?arg...?
 *	    namespace eval name arg ?arg...?
 *	    namespace exists name
 *	    namespace export ?-clear? ?pattern pattern...?
 *	    namespace forget ?pattern pattern...?
 *	    namespace import ?-force? ?pattern pattern...?
 *	    namespace inscope name arg ?arg...?
 *	    namespace origin name
 *	    namespace parent ?name?
 *	    namespace qualifiers string
 *	    namespace tail string
 *	    namespace which ?-command? ?-variable? name
 *
 * Results:
 *	Returns TCL_OK if the command is successful. Returns TCL_ERROR if
 *	anything goes wrong.
 *
 * Side effects:
 *	Based on the subcommand name (e.g., "import"), this function
 *	dispatches to a corresponding function NamespaceXXXCmd defined
 *	statically in this file. This function's side effects depend on
 *	whatever that subcommand function does. If there is an error, this
 *	function returns an error message in the interpreter's result object.
 *	Otherwise it may return a result in the interpreter's result object.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Arbitrary value passed to cmd. */
    Tcl_Interp *interp;			/* Current interpreter. */
    register int objc;			/* Number of arguments. */
    register Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    static CONST char *subCmds[] = {
	"children", "code", "current", "delete", "ensemble",
	"eval", "exists", "export", "forget", "import",
	"inscope", "origin", "parent", "path", "qualifiers",
	"tail", "which", (char *) NULL
    };
    enum NSSubCmdIdx {
	NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
	NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
	NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
	NSTailIdx, NSWhichIdx
    };
    int index, result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
	return TCL_ERROR;
2809
2810
2811
2812
2813
2814
2815



2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
	break;
    case NSOriginIdx:
	result = NamespaceOriginCmd(clientData, interp, objc, objv);
	break;
    case NSParentIdx:
	result = NamespaceParentCmd(clientData, interp, objc, objv);
	break;



    case NSQualifiersIdx:
	result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
	break;
    case NSTailIdx:
	result = NamespaceTailCmd(clientData, interp, objc, objv);
	break;
    case NSWhichIdx:
	result = NamespaceWhichCmd(clientData, interp, objc, objv);
	break;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceChildrenCmd --
 *
 *	Invoked to implement the "namespace children" command that returns a
 *	list containing the fully-qualified names of the child namespaces of
 *	a given namespace. Handles the following syntax:
 *
 *	    namespace children ?name? ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceChildrenCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







>
>
>



















|
|







|
|







2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
	break;
    case NSOriginIdx:
	result = NamespaceOriginCmd(clientData, interp, objc, objv);
	break;
    case NSParentIdx:
	result = NamespaceParentCmd(clientData, interp, objc, objv);
	break;
    case NSPathIdx:
	result = NamespacePathCmd(clientData, interp, objc, objv);
	break;
    case NSQualifiersIdx:
	result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
	break;
    case NSTailIdx:
	result = NamespaceTailCmd(clientData, interp, objc, objv);
	break;
    case NSWhichIdx:
	result = NamespaceWhichCmd(clientData, interp, objc, objv);
	break;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceChildrenCmd --
 *
 *	Invoked to implement the "namespace children" command that returns a
 *	list containing the fully-qualified names of the child namespaces of a
 *	given namespace. Handles the following syntax:
 *
 *	    namespace children ?name? ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceChildrenCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
    /*
     * Get a pointer to the specified namespace, or the current namespace.
     */

    if (objc == 2) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else if ((objc == 3) || (objc == 4)) {
	if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (namespacePtr == NULL) {
	    Tcl_AppendResult(interp, "unknown namespace \"",
		    TclGetString(objv[2]),
		    "\" in namespace children command", (char *) NULL);
	    return TCL_ERROR;







|







3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
    /*
     * Get a pointer to the specified namespace, or the current namespace.
     */

    if (objc == 2) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else if ((objc == 3) || (objc == 4)) {
	if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (namespacePtr == NULL) {
	    Tcl_AppendResult(interp, "unknown namespace \"",
		    TclGetString(objv[2]),
		    "\" in namespace children command", (char *) NULL);
	    return TCL_ERROR;
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913







2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924

2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
	    }
	    Tcl_DStringAppend(&buffer, name, -1);
	    pattern = Tcl_DStringValue(&buffer);
	}
    }

    /*
     * Create a list containing the full names of all child namespaces
     * whose names match the specified pattern, if any.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);







    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
    while (entryPtr != NULL) {
	childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
	if ((pattern == NULL)
		|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
	    elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
	    Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
	}
	entryPtr = Tcl_NextHashEntry(&search);
    }


    Tcl_SetObjResult(interp, listPtr);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceCodeCmd --
 *
 *	Invoked to implement the "namespace code" command to capture the
 *	namespace context of a command. Handles the following syntax:
 *
 *	    namespace code arg
 *
 *	Here "arg" can be a list. "namespace code arg" produces a result
 *	equivalent to that produced by the command
 *
 *	    list ::namespace inscope [namespace current] $arg
 *
 *	However, if "arg" is itself a scoped value starting with
 *	"::namespace inscope", then the result is just "arg".
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error
 *	message as the result in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceCodeCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|



>
>
>
>
>
>
>











>




















|
|





|
|







3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
	    }
	    Tcl_DStringAppend(&buffer, name, -1);
	    pattern = Tcl_DStringValue(&buffer);
	}
    }

    /*
     * Create a list containing the full names of all child namespaces whose
     * names match the specified pattern, if any.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
	if (Tcl_FindHashEntry(&nsPtr->childTable, pattern) != NULL) {
	    Tcl_ListObjAppendElement(interp, listPtr,
		    Tcl_NewStringObj(pattern, -1));
	}
	goto searchDone;
    }
    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
    while (entryPtr != NULL) {
	childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
	if ((pattern == NULL)
		|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
	    elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
	    Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
	}
	entryPtr = Tcl_NextHashEntry(&search);
    }

  searchDone:
    Tcl_SetObjResult(interp, listPtr);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceCodeCmd --
 *
 *	Invoked to implement the "namespace code" command to capture the
 *	namespace context of a command. Handles the following syntax:
 *
 *	    namespace code arg
 *
 *	Here "arg" can be a list. "namespace code arg" produces a result
 *	equivalent to that produced by the command
 *
 *	    list ::namespace inscope [namespace current] $arg
 *
 *	However, if "arg" is itself a scoped value starting with "::namespace
 *	inscope", then the result is just "arg".
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this function returns an error message as the
 *	result in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceCodeCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
	    Tcl_SetObjResult(interp, objv[2]);
	    return TCL_OK;
	}
    }

    /*
     * Otherwise, construct a scoped command by building a list with
     * "namespace inscope", the full name of the current namespace, and 
     * the argument "arg". By constructing a list, we ensure that scoped
     * commands are interpreted properly when they are executed later,
     * by the "namespace inscope" command.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    Tcl_ListObjAppendElement(interp, listPtr,
	    Tcl_NewStringObj("::namespace", -1));
    Tcl_ListObjAppendElement(interp, listPtr,
	    Tcl_NewStringObj("inscope", -1));







|
|
|
|







3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
	    Tcl_SetObjResult(interp, objv[2]);
	    return TCL_OK;
	}
    }

    /*
     * Otherwise, construct a scoped command by building a list with
     * "namespace inscope", the full name of the current namespace, and the
     * argument "arg". By constructing a list, we ensure that scoped commands
     * are interpreted properly when they are executed later, by the
     * "namespace inscope" command.
     */

    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    Tcl_ListObjAppendElement(interp, listPtr,
	    Tcl_NewStringObj("::namespace", -1));
    Tcl_ListObjAppendElement(interp, listPtr,
	    Tcl_NewStringObj("inscope", -1));
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceCurrentCmd --
 *
 *	Invoked to implement the "namespace current" command which returns
 *	the fully-qualified name of the current namespace. Handles the
 *	following syntax:
 *
 *	    namespace current
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceCurrentCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Namespace *currNsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 2, objv, NULL);
	return TCL_ERROR;
    }

    /*
     * The "real" name of the global namespace ("::") is the null string,
     * but we return "::" for it as a convenience to programmers. Note that
     * "" and "::" are treated as synonyms by the namespace code so that it
     * is still easy to do things like:
     *
     *    namespace [namespace current]::bar { ... }
     */

    currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));







|
|
|







|
|



















|
|
|
|







3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceCurrentCmd --
 *
 *	Invoked to implement the "namespace current" command which returns the
 *	fully-qualified name of the current namespace. Handles the following
 *	syntax:
 *
 *	    namespace current
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceCurrentCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Namespace *currNsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 2, objv, NULL);
	return TCL_ERROR;
    }

    /*
     * The "real" name of the global namespace ("::") is the null string, but
     * we return "::" for it as a convenience to programmers. Note that "" and
     * "::" are treated as synonyms by the namespace code so that it is still
     * easy to do things like:
     *
     *    namespace [namespace current]::bar { ... }
     */

    currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
 *	namespace(s). Handles the following syntax:
 *
 *	    namespace delete ?name name...?
 *
 *	Each name identifies a namespace. It may include a sequence of
 *	namespace qualifiers separated by "::"s. If a namespace is found, it
 *	is deleted: all variables and procedures contained in that namespace
 *	are deleted. If that namespace is being used on the call stack, it
 *	is kept alive (but logically deleted) until it is removed from the
 *	call stack: that is, it can no longer be referenced by name but any
 *	currently executing procedure that refers to it is allowed to do so
 *	until the procedure returns. If the namespace can't be found, this
 *	procedure returns an error. If no namespaces are specified, this
 *	command does nothing.
 *
 * Results:
 *	Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Deletes the specified namespaces. If anything goes wrong, this
 *	procedure returns an error message in the interpreter's
 *	result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceDeleteCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|


|



|



|
<







3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255

3256
3257
3258
3259
3260
3261
3262
 *	namespace(s). Handles the following syntax:
 *
 *	    namespace delete ?name name...?
 *
 *	Each name identifies a namespace. It may include a sequence of
 *	namespace qualifiers separated by "::"s. If a namespace is found, it
 *	is deleted: all variables and procedures contained in that namespace
 *	are deleted. If that namespace is being used on the call stack, it is
 *	kept alive (but logically deleted) until it is removed from the call
 *	stack: that is, it can no longer be referenced by name but any
 *	currently executing procedure that refers to it is allowed to do so
 *	until the procedure returns. If the namespace can't be found, this
 *	function returns an error. If no namespaces are specified, this
 *	command does nothing.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Deletes the specified namespaces. If anything goes wrong, this
 *	function returns an error message in the interpreter's result object.

 *
 *----------------------------------------------------------------------
 */

static int
NamespaceDeleteCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
	return TCL_ERROR;
    }

    /*
     * Destroying one namespace may cause another to be destroyed. Break
     * this into two passes: first check to make sure that all namespaces on
     * the command line are valid, and report any errors.
     */

    for (i = 2;  i < objc;  i++) {
	name = TclGetString(objv[i]);
	namespacePtr = Tcl_FindNamespace(interp, name,
		(Tcl_Namespace *) NULL, /*flags*/ 0);
	if (namespacePtr == NULL) {







|
|
|







3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
	return TCL_ERROR;
    }

    /*
     * Destroying one namespace may cause another to be destroyed. Break this
     * into two passes: first check to make sure that all namespaces on the
     * command line are valid, and report any errors.
     */

    for (i = 2;  i < objc;  i++) {
	name = TclGetString(objv[i]);
	namespacePtr = Tcl_FindNamespace(interp, name,
		(Tcl_Namespace *) NULL, /*flags*/ 0);
	if (namespacePtr == NULL) {
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235

3236
3237
3238
3239
3240
3241
3242
3243
3244
3245

3246
3247
3248
3249
3250



3251

3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceEvalCmd --
 *
 *	Invoked to implement the "namespace eval" command. Executes
 *	commands in a namespace. If the namespace does not already exist,
 *	it is created. Handles the following syntax:
 *
 *	    namespace eval name arg ?arg...?
 *
 *	If more than one arg argument is specified, the command that is
 *	executed is the result of concatenating the arguments together with
 *	a space between each argument.
 *
 * Results:
 *	Returns TCL_OK if the namespace is found and the commands are
 *	executed successfully. Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns the result of the command in the interpreter's result
 *	object. If anything goes wrong, this procedure returns an error
 *	message as the result.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceEvalCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    CallFrame frame, *framePtr;
    Tcl_Obj *objPtr;
    int result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
	return TCL_ERROR;
    }

    /*
     * Try to resolve the namespace reference, caching the result in the
     * namespace object along the way.
     */

    result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * If the namespace wasn't found, try to create it.
     */

    if (namespacePtr == NULL) {
	char *name = TclGetString(objv[2]);
	namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, 
		(Tcl_NamespaceDeleteProc *) NULL);
	if (namespacePtr == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Make the specified namespace the current namespace and evaluate
     * the command(s).
     */

    /* This is needed to satisfy GCC 3.3's strict aliasing rules */
    framePtr = &frame;
    result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, 
	    namespacePtr, /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    frame.objc = objc;

    frame.objv = objv;	/* ref counts do not need to be incremented here */

    if (objc == 4) {
	result = Tcl_EvalObjEx(interp, objv[3], 0);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result.  Tcl_EvalObjEx will delete
	 * the object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-3, objv+3);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }

    if (result == TCL_ERROR) {



	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);

	Tcl_Obj *msg = Tcl_NewStringObj("\n    (in namespace eval \"", -1);
	Tcl_IncrRefCount(errorLine);
	Tcl_IncrRefCount(msg);
	TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
	Tcl_AppendToObj(msg, "\" script line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    /*
     * Restore the previous "current" namespace.
     */

    Tcl_PopCallFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceExistsCmd --
 *
 *	Invoked to implement the "namespace exists" command that returns 
 *	true if the given namespace currently exists, and false otherwise.
 *	Handles the following syntax:
 *
 *	    namespace exists name
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceExistsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|




|
|


|
|


|
|
|












|













|










|







|
|



|
|




|
>
|






|
|

>





>
>
>
|
>
|
<
<
|
<
<
|
<
<
<






|








|
|
|







|
|







3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411


3412


3413



3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceEvalCmd --
 *
 *	Invoked to implement the "namespace eval" command. Executes commands
 *	in a namespace. If the namespace does not already exist, it is
 *	created. Handles the following syntax:
 *
 *	    namespace eval name arg ?arg...?
 *
 *	If more than one arg argument is specified, the command that is
 *	executed is the result of concatenating the arguments together with a
 *	space between each argument.
 *
 * Results:
 *	Returns TCL_OK if the namespace is found and the commands are executed
 *	successfully. Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns the result of the command in the interpreter's result object.
 *	If anything goes wrong, this function returns an error message as the
 *	result.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceEvalCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    CallFrame *framePtr, **framePtrPtr;
    Tcl_Obj *objPtr;
    int result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
	return TCL_ERROR;
    }

    /*
     * Try to resolve the namespace reference, caching the result in the
     * namespace object along the way.
     */

    result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * If the namespace wasn't found, try to create it.
     */

    if (namespacePtr == NULL) {
	char *name = TclGetString(objv[2]);
	namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL,
		(Tcl_NamespaceDeleteProc *) NULL);
	if (namespacePtr == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Make the specified namespace the current namespace and evaluate the
     * command(s).
     */

    /* This is needed to satisfy GCC 3.3's strict aliasing rules */
    framePtrPtr = &framePtr;
    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
	    namespacePtr, /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    framePtr->objc = objc;
    framePtr->objv = objv;	/* Reference counts do not need to be
				 * incremented here. */

    if (objc == 4) {
	result = Tcl_EvalObjEx(interp, objv[3], 0);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-3, objv+3);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp,
		"\n    (in namespace eval \"%.*s%s\" script line %d)",


		(overflow ? limit : length), namespacePtr->fullName,


		(overflow ? "..." : ""), interp->errorLine);



    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceExistsCmd --
 *
 *	Invoked to implement the "namespace exists" command that returns true
 *	if the given namespace currently exists, and false otherwise. Handles
 *	the following syntax:
 *
 *	    namespace exists name
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceExistsCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
	return TCL_ERROR;
    }

    /*
     * Check whether the given namespace exists
     */

    if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceExportCmd --
 *
 *	Invoked to implement the "namespace export" command that specifies
 *	which commands are exported from a namespace. The exported commands
 *	are those that can be imported into another namespace using
 *	"namespace import". Both commands defined in a namespace and
 *	commands the namespace has imported can be exported by a
 *	namespace. This command has the following syntax:
 *
 *	    namespace export ?-clear? ?pattern pattern...?
 *
 *	Each pattern may contain "string match"-style pattern matching
 *	special characters, but the pattern may not include any namespace
 *	qualifiers: that is, the pattern must specify commands in the
 *	current (exporting) namespace. The specified patterns are appended
 *	onto the namespace's list of export patterns.
 *
 *	To reset the namespace's export pattern list, specify the "-clear"
 *	flag.
 *
 *	If there are no export patterns and the "-clear" flag isn't given,
 *	this command returns the namespace's current export list.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceExportCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|














|
|
|
|



|
|
|
|
|











|
|







3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
	return TCL_ERROR;
    }

    /*
     * Check whether the given namespace exists
     */

    if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceExportCmd --
 *
 *	Invoked to implement the "namespace export" command that specifies
 *	which commands are exported from a namespace. The exported commands
 *	are those that can be imported into another namespace using "namespace
 *	import". Both commands defined in a namespace and commands the
 *	namespace has imported can be exported by a namespace. This command
 *	has the following syntax:
 *
 *	    namespace export ?-clear? ?pattern pattern...?
 *
 *	Each pattern may contain "string match"-style pattern matching special
 *	characters, but the pattern may not include any namespace qualifiers:
 *	that is, the pattern must specify commands in the current (exporting)
 *	namespace. The specified patterns are appended onto the namespace's
 *	list of export patterns.
 *
 *	To reset the namespace's export pattern list, specify the "-clear"
 *	flag.
 *
 *	If there are no export patterns and the "-clear" flag isn't given,
 *	this command returns the namespace's current export list.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceExportCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
	if (strcmp(string, "-clear") == 0) {
	    resetListFirst = 1;
	    firstArg++;
	}
    }

    /*
     * If no pattern arguments are given, and "-clear" isn't specified,
     * return the namespace's current export pattern list.
     */

    patternCt = (objc - firstArg);
    if (patternCt == 0) {
	if (firstArg > 2) {
	    return TCL_OK;
	} else {		/* create list with export patterns */







|
|







3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
	if (strcmp(string, "-clear") == 0) {
	    resetListFirst = 1;
	    firstArg++;
	}
    }

    /*
     * If no pattern arguments are given, and "-clear" isn't specified, return
     * the namespace's current export pattern list.
     */

    patternCt = (objc - firstArg);
    if (patternCt == 0) {
	if (firstArg > 2) {
	    return TCL_OK;
	} else {		/* create list with export patterns */
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceForgetCmd --
 *
 *	Invoked to implement the "namespace forget" command to remove
 *	imported commands from a namespace. Handles the following syntax:
 *
 *	    namespace forget ?pattern pattern...?
 *
 *	Each pattern is a name like "foo::*" or "a::b::x*". That is, the
 *	pattern may include the special pattern matching characters
 *	recognized by the "string match" command, but only in the command
 *	name at the end of the qualified name; the special pattern
 *	characters may not appear in a namespace name. All of the commands
 *	that match that pattern are checked to see if they have an imported
 *	command in the current namespace that refers to the matched
 *	command. If there is an alias, it is removed.
 *	
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Imported commands are removed from the current namespace. If
 *	anything goes wrong, this procedure returns an error message in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceForgetCmd(dummy, interp, objc, objv)







|
|




|
|
|
|
|
|
|
|




|
|







3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceForgetCmd --
 *
 *	Invoked to implement the "namespace forget" command to remove imported
 *	commands from a namespace. Handles the following syntax:
 *
 *	    namespace forget ?pattern pattern...?
 *
 *	Each pattern is a name like "foo::*" or "a::b::x*". That is, the
 *	pattern may include the special pattern matching characters recognized
 *	by the "string match" command, but only in the command name at the end
 *	of the qualified name; the special pattern characters may not appear
 *	in a namespace name. All of the commands that match that pattern are
 *	checked to see if they have an imported command in the current
 *	namespace that refers to the matched command. If there is an alias, it
 *	is removed.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Imported commands are removed from the current namespace. If anything
 *	goes wrong, this function returns an error message in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceForgetCmd(dummy, interp, objc, objv)
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
 * NamespaceImportCmd --
 *
 *	Invoked to implement the "namespace import" command that imports
 *	commands into a namespace. Handles the following syntax:
 *
 *	    namespace import ?-force? ?pattern pattern...?
 *
 *	Each pattern is a namespace-qualified name like "foo::*",
 *	"a::b::x*", or "bar::p". That is, the pattern may include the
 *	special pattern matching characters recognized by the "string match"
 *	command, but only in the command name at the end of the qualified
 *	name; the special pattern characters may not appear in a namespace
 *	name. All of the commands that match the pattern and which are
 *	exported from their namespace are made accessible from the current
 *	namespace context. This is done by creating a new "imported command"
 *	in the current namespace that points to the real command in its
 *	original namespace; when the imported command is called, it invokes
 *	the real command.
 *
 *	If an imported command conflicts with an existing command, it is
 *	treated as an error. But if the "-force" option is included, then
 *	existing commands are overwritten by the imported commands.
 *	
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Adds imported commands to the current namespace. If anything goes
 *	wrong, this procedure returns an error message in the interpreter's
 *	result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceImportCmd(dummy, interp, objc, objv)







|
|
|
|
|
|
|
|
|
|
<




|





|







3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647

3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
 * NamespaceImportCmd --
 *
 *	Invoked to implement the "namespace import" command that imports
 *	commands into a namespace. Handles the following syntax:
 *
 *	    namespace import ?-force? ?pattern pattern...?
 *
 *	Each pattern is a namespace-qualified name like "foo::*", "a::b::x*",
 *	or "bar::p". That is, the pattern may include the special pattern
 *	matching characters recognized by the "string match" command, but only
 *	in the command name at the end of the qualified name; the special
 *	pattern characters may not appear in a namespace name. All of the
 *	commands that match the pattern and which are exported from their
 *	namespace are made accessible from the current namespace context. This
 *	is done by creating a new "imported command" in the current namespace
 *	that points to the real command in its original namespace; when the
 *	imported command is called, it invokes the real command.

 *
 *	If an imported command conflicts with an existing command, it is
 *	treated as an error. But if the "-force" option is included, then
 *	existing commands are overwritten by the imported commands.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Adds imported commands to the current namespace. If anything goes
 *	wrong, this function returns an error message in the interpreter's
 *	result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceImportCmd(dummy, interp, objc, objv)
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
/*
 *----------------------------------------------------------------------
 *
 * NamespaceInscopeCmd --
 *
 *	Invoked to implement the "namespace inscope" command that executes a
 *	script in the context of a particular namespace. This command is not
 *	expected to be used directly by programmers; calls to it are
 *	generated implicitly when programs use "namespace code" commands
 *	to register callback scripts. Handles the following syntax:
 *
 *	    namespace inscope name arg ?arg...?
 *
 *	The "namespace inscope" command is much like the "namespace eval"
 *	command except that it has lappend semantics and the namespace must
 *	already exist. It treats the first argument as a list, and appends
 *	any arguments after the first onto the end as proper list elements.
 *	For example,
 *
 *	    namespace inscope ::foo a b c d
 *
 *	is equivalent to
 *
 *	    namespace eval ::foo [concat a [list b c d]]
 *
 *	This lappend semantics is important because many callback scripts
 *	are actually prefixes.
 *
 * Results:
 *	Returns TCL_OK to indicate success, or TCL_ERROR to indicate
 *	failure.
 *
 * Side effects:
 *	Returns a result in the Tcl interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceInscopeCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    Tcl_CallFrame frame;
    int i, result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
	return TCL_ERROR;
    }

    /*
     * Resolve the namespace reference.
     */

    result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
    if (result != TCL_OK) {
	return result;
    }
    if (namespacePtr == NULL) {
	Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]),
		"\" in inscope namespace command", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Make the specified namespace the current namespace.
     */

    result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
	    /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Execute the command. If there is just one argument, just treat it as
     * a script and evaluate it. Otherwise, create a list from the arguments
     * after the first one, then concatenate the first argument and the list
     * of extra arguments to form the command to evaluate.
     */

    if (objc == 4) {
	result = Tcl_EvalObjEx(interp, objv[3], 0);
    } else {







|
|
|





|
|
|

|



|

|
|


|
<















|











|













|






|
|







3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738

3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
/*
 *----------------------------------------------------------------------
 *
 * NamespaceInscopeCmd --
 *
 *	Invoked to implement the "namespace inscope" command that executes a
 *	script in the context of a particular namespace. This command is not
 *	expected to be used directly by programmers; calls to it are generated
 *	implicitly when programs use "namespace code" commands to register
 *	callback scripts. Handles the following syntax:
 *
 *	    namespace inscope name arg ?arg...?
 *
 *	The "namespace inscope" command is much like the "namespace eval"
 *	command except that it has lappend semantics and the namespace must
 *	already exist. It treats the first argument as a list, and appends any
 *	arguments after the first onto the end as proper list elements. For
 *	example,
 *
 *	    namespace inscope ::foo {a b} c d e
 *
 *	is equivalent to
 *
 *	    namespace eval ::foo [concat {a b} [list c d e]]
 *
 *	This lappend semantics is important because many callback scripts are
 *	actually prefixes.
 *
 * Results:
 *	Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure.

 *
 * Side effects:
 *	Returns a result in the Tcl interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceInscopeCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    Tcl_CallFrame *framePtr;
    int i, result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
	return TCL_ERROR;
    }

    /*
     * Resolve the namespace reference.
     */

    result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr);
    if (result != TCL_OK) {
	return result;
    }
    if (namespacePtr == NULL) {
	Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]),
		"\" in inscope namespace command", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Make the specified namespace the current namespace.
     */

    result = TclPushStackFrame(interp, &framePtr, namespacePtr,
	    /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Execute the command. If there is just one argument, just treat it as a
     * script and evaluate it. Otherwise, create a list from the arguments
     * after the first one, then concatenate the first argument and the list
     * of extra arguments to form the command to evaluate.
     */

    if (objc == 4) {
	result = Tcl_EvalObjEx(interp, objv[3], 0);
    } else {
3659
3660
3661
3662
3663
3664
3665



3666

3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
	Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }

    if (result == TCL_ERROR) {



	Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);

	Tcl_Obj *msg = Tcl_NewStringObj("\n    (in namespace inscope \"", -1);
	Tcl_IncrRefCount(errorLine);
	Tcl_IncrRefCount(msg);
	TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
	Tcl_AppendToObj(msg, "\" script line ", -1);
	Tcl_AppendObjToObj(msg, errorLine);
	Tcl_DecrRefCount(errorLine);
	Tcl_AppendToObj(msg, ")", -1);
	TclAppendObjToErrorInfo(interp, msg);
	Tcl_DecrRefCount(msg);
    }

    /*
     * Restore the previous "current" namespace.
     */

    Tcl_PopCallFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceOriginCmd --







>
>
>
|
>
|
<
<
|
<
<
|
<
<
<






|







3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821


3822


3823



3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
	Tcl_DecrRefCount(listPtr);    /* we're done with the list object */
    }

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);

	TclFormatToErrorInfo(interp,
		"\n    (in namespace inscope \"%.*s%s\" script line %d)",


		(overflow ? limit : length), namespacePtr->fullName,


		(overflow ? "..." : ""), interp->errorLine);



    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceOriginCmd --
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
 *	An imported command is created in an namespace when that namespace
 *	imports a command from another namespace. If a command is imported
 *	into a sequence of namespaces a, b,...,n where each successive
 *	namespace just imports the command from the previous namespace, this
 *	command returns the fully-qualified name of the original command in
 *	the first namespace, a. If "name" does not refer to an alias, its
 *	fully-qualified name is returned. The returned name is stored in the
 *	interpreter's result object. This procedure returns TCL_OK if
 *	successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error message in
 *	the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceOriginCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|



|
|







3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
 *	An imported command is created in an namespace when that namespace
 *	imports a command from another namespace. If a command is imported
 *	into a sequence of namespaces a, b,...,n where each successive
 *	namespace just imports the command from the previous namespace, this
 *	command returns the fully-qualified name of the original command in
 *	the first namespace, a. If "name" does not refer to an alias, its
 *	fully-qualified name is returned. The returned name is stored in the
 *	interpreter's result object. This function returns TCL_OK if
 *	successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this function returns an error message in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceOriginCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
	return TCL_ERROR;
    }
    origCommand = TclGetOriginalCommand(command);
    resultPtr = Tcl_NewObj();
    if (origCommand == (Tcl_Command) NULL) {
	/*
	 * The specified command isn't an imported command. Return the
	 * command's name qualified by the full name of the namespace it
	 * was defined in.
	 */

	Tcl_GetCommandFullName(interp, command, resultPtr);
    } else {
	Tcl_GetCommandFullName(interp, origCommand, resultPtr);
    }
    Tcl_SetObjResult(interp, resultPtr);







|
|







3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
	return TCL_ERROR;
    }
    origCommand = TclGetOriginalCommand(command);
    resultPtr = Tcl_NewObj();
    if (origCommand == (Tcl_Command) NULL) {
	/*
	 * The specified command isn't an imported command. Return the
	 * command's name qualified by the full name of the namespace it was
	 * defined in.
	 */

	Tcl_GetCommandFullName(interp, command, resultPtr);
    } else {
	Tcl_GetCommandFullName(interp, origCommand, resultPtr);
    }
    Tcl_SetObjResult(interp, resultPtr);
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
 *
 *	    namespace parent ?name?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceParentCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Namespace *nsPtr;
    int result;

    if (objc == 2) {
	nsPtr = Tcl_GetCurrentNamespace(interp);
    } else if (objc == 3) {
	result = GetNamespaceFromObj(interp, objv[2], &nsPtr);
	if (result != TCL_OK) {
	    return result;
	}
	if (nsPtr == NULL) {
	    Tcl_AppendResult(interp, "unknown namespace \"",
		    TclGetString(objv[2]),
		    "\" in namespace parent command", (char *) NULL);







|
|

















|







3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
 *
 *	    namespace parent ?name?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceParentCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Namespace *nsPtr;
    int result;

    if (objc == 2) {
	nsPtr = Tcl_GetCurrentNamespace(interp);
    } else if (objc == 3) {
	result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr);
	if (result != TCL_OK) {
	    return result;
	}
	if (nsPtr == NULL) {
	    Tcl_AppendResult(interp, "unknown namespace \"",
		    TclGetString(objv[2]),
		    "\" in namespace parent command", (char *) NULL);
3810
3811
3812
3813
3814
3815
3816














































































































































































































































3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *














































































































































































































































 * NamespaceQualifiersCmd --
 *
 *	Invoked to implement the "namespace qualifiers" command that returns
 *	any leading namespace qualifiers in a string. These qualifiers are
 *	namespace names separated by "::"s. For example, for "::foo::p" this
 *	command returns "::foo", and for "::" it returns "". This command
 *	is the complement of the "namespace tail" command. Note that this
 *	command does not check whether the "namespace" names are, in fact,
 *	the names of currently defined namespaces. Handles the following
 *	syntax:
 *
 *	    namespace qualifiers string
 *
 * Results:
 *	Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceQualifiersCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register char *name, *p;
    int length;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "string");
	return TCL_ERROR;
    }

    /*
     * Find the end of the string, then work backward and find
     * the start of the last "::" qualifier.
     */

    name = TclGetString(objv[2]);
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p >= name) {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|
|
|
<




|


|
|




















|
|







3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210

4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespacePathCmd --
 *
 *	Invoked to implement the "namespace path" command that reads and
 *	writes the current namespace's command resolution path. Has one
 *	optional argument: if present, it is a list of named namespaces to set
 *	the path to, and if absent, the current path should be returned.
 *	Handles the following syntax:
 *
 *	    namespace path ?nsList?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong
 *	(most notably if the namespace list contains the name of something
 *	other than a namespace). In the successful-exit case, may set the
 *	interpreter result to the list of names of the namespaces on the
 *	current namespace's path.
 *
 * Side effects:
 *	May update the namespace path (triggering a recomputing of all command
 *	names that depend on the namespace for resolution).
 *
 *----------------------------------------------------------------------
 */

static int
NamespacePathCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    int i, nsObjc, result = TCL_ERROR;
    Tcl_Obj **nsObjv;
    Tcl_Namespace **namespaceList = NULL;
    Tcl_Namespace *staticNs[4];

    if (objc > 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "?pathList?");
	return TCL_ERROR;
    }

    /*
     * If no path is given, return the current path.
     */

    if (objc == 2) {
	/*
	 * Not a very fast way to compute this, but easy to get right.
	 */

	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	    if (nsPtr->commandPathArray[i].nsPtr != NULL) {
		Tcl_AppendElement(interp,
			nsPtr->commandPathArray[i].nsPtr->fullName);
	    }
	}
	return TCL_OK;
    }

    /*
     * There is a path given, so parse it into an array of namespace pointers.
     */

    if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
	goto badNamespace;
    }
    if (nsObjc != 0) {
	if (nsObjc > 4) {
	    namespaceList = (Tcl_Namespace **)
		    ckalloc(sizeof(Tcl_Namespace *) * nsObjc);
	} else {
	    namespaceList = staticNs;
	}

	for (i=0 ; i<nsObjc ; i++) {
	    if (TclGetNamespaceFromObj(interp, nsObjv[i],
		    &namespaceList[i]) != TCL_OK) {
		goto badNamespace;
	    }
	    if (namespaceList[i] == NULL) {
		Tcl_AppendResult(interp, "unknown namespace \"",
			TclGetString(nsObjv[i]), "\"", NULL);
		goto badNamespace;
	    }
	}
    }

    /*
     * Now we have the list of valid namespaces, install it as the path.
     */

    SetNsPath(nsPtr, nsObjc, namespaceList);

    result = TCL_OK;
  badNamespace:
    if (namespaceList != NULL && namespaceList != staticNs) {
	ckfree((char *) namespaceList);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SetNsPath --
 *
 *	Sets the namespace command name resolution path to the given list of
 *	namespaces. If the list is empty (of zero length) the path is set to
 *	empty and the default old-style behaviour of command name resolution
 *	is used.
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Invalidates the command name resolution caches for any command
 *	resolved in the given namespace.
 *
 *----------------------------------------------------------------------
 */

/* EXPOSE ME? */
static void
SetNsPath(nsPtr, pathLength, pathAry)
    Namespace *nsPtr;		/* Namespace whose path is to be set. */
    int pathLength;		/* Length of pathAry */
    Tcl_Namespace *pathAry[];	/* Array of namespaces that are the path. */
{
    NamespacePathEntry *tmpPathArray;
    int i;

    if (pathLength != 0) {
	tmpPathArray = (NamespacePathEntry *)
		ckalloc(sizeof(NamespacePathEntry) * pathLength);
	for (i=0 ; i<pathLength ; i++) {
	    tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
	    tmpPathArray[i].creatorNsPtr = nsPtr;
	    tmpPathArray[i].prevPtr = NULL;
	    tmpPathArray[i].nextPtr =
		    tmpPathArray[i].nsPtr->commandPathSourceList;
	    if (tmpPathArray[i].nextPtr != NULL) {
		tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i];
	    }
	    tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i];
	}
	if (nsPtr->commandPathLength != 0) {
	    UnlinkNsPath(nsPtr);
	}
	nsPtr->commandPathArray = tmpPathArray;
    } else {
	if (nsPtr->commandPathLength != 0) {
	    UnlinkNsPath(nsPtr);
	}
    }

    nsPtr->commandPathLength = pathLength;
    nsPtr->cmdRefEpoch++;
    nsPtr->resolverEpoch++;
}

/*
 *----------------------------------------------------------------------
 *
 * UnlinkNsPath --
 *
 *	Delete the given namespace's command name resolution path. Only call
 *	if the path is non-empty. Caller must reset the counter containing the
 *	path size.
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Deletes the array of path entries and unlinks those path entries from
 *	the target namespace's list of interested namespaces.
 *
 *----------------------------------------------------------------------
 */

static void
UnlinkNsPath(nsPtr)
    Namespace *nsPtr;
{
    int i;
    for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
	if (nsPathPtr->prevPtr != NULL) {
	    nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
	}
	if (nsPathPtr->nextPtr != NULL) {
	    nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
	}
	if (nsPathPtr->nsPtr != NULL) {
	    if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
		nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
	    }
	}
    }
    ckfree((char *) nsPtr->commandPathArray);
}

/*
 *----------------------------------------------------------------------
 *
 * TclInvalidateNsPath --
 *
 *	Invalidate the name resolution caches for all names looked up in
 *	namespaces whose name path includes the given namespace.
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Increments the command reference epoch in each namespace whose path
 *	includes the given namespace. This causes any cached resolved names
 *	whose root cacheing context starts at that namespace to be recomputed
 *	the next time they are used.
 *
 *----------------------------------------------------------------------
 */

void
TclInvalidateNsPath(nsPtr)
    Namespace *nsPtr;
{
    NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
    while (nsPathPtr != NULL) {
	if (nsPathPtr->nsPtr != NULL) {
	    nsPathPtr->creatorNsPtr->cmdRefEpoch++;
	}
	nsPathPtr = nsPathPtr->nextPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceQualifiersCmd --
 *
 *	Invoked to implement the "namespace qualifiers" command that returns
 *	any leading namespace qualifiers in a string. These qualifiers are
 *	namespace names separated by "::"s. For example, for "::foo::p" this
 *	command returns "::foo", and for "::" it returns "". This command is
 *	the complement of the "namespace tail" command. Note that this command
 *	does not check whether the "namespace" names are, in fact, the names
 *	of currently defined namespaces. Handles the following syntax:

 *
 *	    namespace qualifiers string
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceQualifiersCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register char *name, *p;
    int length;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "string");
	return TCL_ERROR;
    }

    /*
     * Find the end of the string, then work backward and find the start of
     * the last "::" qualifier.
     */

    name = TclGetString(objv[2]);
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p >= name) {
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930

/*
 *----------------------------------------------------------------------
 *
 * NamespaceTailCmd --
 *
 *	Invoked to implement the "namespace tail" command that returns the
 *	trailing name at the end of a string with "::" namespace
 *	qualifiers. These qualifiers are namespace names separated by
 *	"::"s. For example, for "::foo::p" this command returns "p", and for
 *	"::" it returns "". This command is the complement of the "namespace
 *	qualifiers" command. Note that this command does not check whether
 *	the "namespace" names are, in fact, the names of currently defined
 *	namespaces. Handles the following syntax:
 *
 *	    namespace tail string
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceTailCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register char *name, *p;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "string");
	return TCL_ERROR;
    }

    /*
     * Find the end of the string, then work backward and find the
     * last "::" qualifier.
     */

    name = TclGetString(objv[2]);
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p > name) {







|
|
|
|
|
|
|







|
|



















|
|







4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314

/*
 *----------------------------------------------------------------------
 *
 * NamespaceTailCmd --
 *
 *	Invoked to implement the "namespace tail" command that returns the
 *	trailing name at the end of a string with "::" namespace qualifiers.
 *	These qualifiers are namespace names separated by "::"s. For example,
 *	for "::foo::p" this command returns "p", and for "::" it returns "".
 *	This command is the complement of the "namespace qualifiers" command.
 *	Note that this command does not check whether the "namespace" names
 *	are, in fact, the names of currently defined namespaces. Handles the
 *	following syntax:
 *
 *	    namespace tail string
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceTailCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register char *name, *p;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "string");
	return TCL_ERROR;
    }

    /*
     * Find the end of the string, then work backward and find the last "::"
     * qualifier.
     */

    name = TclGetString(objv[2]);
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p > name) {
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
 *
 *	    namespace which ?-command? ?-variable? name
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceWhichCmd(dummy, interp, objc, objv)
     ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static CONST char *opts[] = {
	"-command", "-variable", NULL
    };







|
|






|







4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
 *
 *	    namespace which ?-command? ?-variable? name
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceWhichCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static CONST char *opts[] = {
	"-command", "-variable", NULL
    };
3985
3986
3987
3988
3989
3990
3991

3992
3993
3994
3995
3996
3997
3998
3999
4000

4001
4002
4003
4004
4005
4006
4007
4008

4009
4010
4011
4012
4013
4014
4015
	 */

	if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
		&lookupType) != TCL_OK) {
	    /*
	     * Preserve old style of error message!
	     */

	    Tcl_ResetResult(interp);
	    goto badArgs;
	}
    }

    resultPtr = Tcl_NewObj();
    switch (lookupType) {
    case 0: {			/* -command */
	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);

	if (cmd != (Tcl_Command) NULL) {	
	    Tcl_GetCommandFullName(interp, cmd, resultPtr);
	}
	break;
    }
    case 1: {			/* -variable */
	Tcl_Var var = Tcl_FindNamespaceVar(interp,
		TclGetString(objv[objc-1]), NULL, /*flags*/ 0);

	if (var != (Tcl_Var) NULL) {
	    Tcl_GetVariableFullName(interp, var, resultPtr);
	}
	break;
    }
    }
    Tcl_SetObjResult(interp, resultPtr);







>









>
|







>







4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
	 */

	if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
		&lookupType) != TCL_OK) {
	    /*
	     * Preserve old style of error message!
	     */

	    Tcl_ResetResult(interp);
	    goto badArgs;
	}
    }

    resultPtr = Tcl_NewObj();
    switch (lookupType) {
    case 0: {			/* -command */
	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);

	if (cmd != (Tcl_Command) NULL) {
	    Tcl_GetCommandFullName(interp, cmd, resultPtr);
	}
	break;
    }
    case 1: {			/* -variable */
	Tcl_Var var = Tcl_FindNamespaceVar(interp,
		TclGetString(objv[objc-1]), NULL, /*flags*/ 0);

	if (var != (Tcl_Var) NULL) {
	    Tcl_GetVariableFullName(interp, var, resultPtr);
	}
	break;
    }
    }
    Tcl_SetObjResult(interp, resultPtr);
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
 *	Frees the resources associated with a nsName object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Decrements the ref count of any Namespace structure pointed
 *	to by the nsName's internal representation. If there are no more
 *	references to the namespace, it's structure will be freed.
 *
 *----------------------------------------------------------------------
 */

static void
FreeNsNameInternalRep(objPtr)
    register Tcl_Obj *objPtr;   /* nsName object with internal
				 * representation to free */
{
    register ResolvedNsName *resNamePtr = (ResolvedNsName *)
	    objPtr->internalRep.otherValuePtr;
    Namespace *nsPtr;

    /*
     * Decrement the reference count of the namespace. If there are no
     * more references, free it up.
     */

    if (resNamePtr != NULL) {
	resNamePtr->refCount--;
	if (resNamePtr->refCount == 0) {

	    /*
	     * Decrement the reference count for the cached namespace.  If
	     * the namespace is dead, and there are no more references to
	     * it, free it.
	     */

	    nsPtr = resNamePtr->nsPtr;
	    nsPtr->refCount--;
	    if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
		NamespaceFree(nsPtr);
	    }







|
|
|






|
|






|
|







|
|
|







4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
 *	Frees the resources associated with a nsName object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Decrements the ref count of any Namespace structure pointed to by the
 *	nsName's internal representation. If there are no more references to
 *	the namespace, it's structure will be freed.
 *
 *----------------------------------------------------------------------
 */

static void
FreeNsNameInternalRep(objPtr)
    register Tcl_Obj *objPtr;	/* nsName object with internal representation
				 * to free */
{
    register ResolvedNsName *resNamePtr = (ResolvedNsName *)
	    objPtr->internalRep.otherValuePtr;
    Namespace *nsPtr;

    /*
     * Decrement the reference count of the namespace. If there are no more
     * references, free it up.
     */

    if (resNamePtr != NULL) {
	resNamePtr->refCount--;
	if (resNamePtr->refCount == 0) {

	    /*
	     * Decrement the reference count for the cached namespace. If the
	     * namespace is dead, and there are no more references to it, free
	     * it.
	     */

	    nsPtr = resNamePtr->nsPtr;
	    nsPtr->refCount--;
	    if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
		NamespaceFree(nsPtr);
	    }
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
 *	of the internal representation of another nsName object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	copyPtr's internal rep is set to refer to the same namespace
 *	referenced by srcPtr's internal rep. Increments the ref count of
 *	the ResolvedNsName structure used to hold the namespace reference.
 *
 *----------------------------------------------------------------------
 */

static void
DupNsNameInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */







|
|







4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
 *	of the internal representation of another nsName object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	copyPtr's internal rep is set to refer to the same namespace
 *	referenced by srcPtr's internal rep. Increments the ref count of the
 *	ResolvedNsName structure used to hold the namespace reference.
 *
 *----------------------------------------------------------------------
 */

static void
DupNsNameInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
}

/*
 *----------------------------------------------------------------------
 *
 * SetNsNameFromAny --
 *
 *	Attempt to generate a nsName internal representation for a
 *	Tcl object.
 *
 * Results:
 *	Returns TCL_OK if the value could be converted to a proper
 *	namespace reference. Otherwise, it returns TCL_ERROR, along
 *	with an error message in the interpreter's result object.
 *
 * Side effects:
 *	If successful, the object is made a nsName object. Its internal rep
 *	is set to point to a ResolvedNsName, which contains a cached pointer
 *	to the Namespace. Reference counts are kept on both the
 *	ResolvedNsName and the Namespace, so we can keep track of their
 *	usage and free them when appropriate.
 *
 *----------------------------------------------------------------------
 */

static int
SetNsNameFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Points to the namespace in which to
				 * resolve name. Also used for error
				 * reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    char *name;
    CONST char *dummy;
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    register ResolvedNsName *resNamePtr;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    name = objPtr->bytes;
    if (name == NULL) {
	name = TclGetString(objPtr);
    }

    /*
     * Look for the namespace "name" in the current namespace. If there is
     * an error parsing the (possibly qualified) name, return an error.
     * If the namespace isn't found, we convert the object to an nsName
     * object with a NULL ResolvedNsName* internal rep.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
	    TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);

    /*
     * If we found a namespace, then create a new ResolvedNsName structure







|
<


|
|
|


|
|
|
|
|






|
|
|

















|
|
|
|







4491
4492
4493
4494
4495
4496
4497
4498

4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
}

/*
 *----------------------------------------------------------------------
 *
 * SetNsNameFromAny --
 *
 *	Attempt to generate a nsName internal representation for a Tcl object.

 *
 * Results:
 *	Returns TCL_OK if the value could be converted to a proper namespace
 *	reference. Otherwise, it returns TCL_ERROR, along with an error
 *	message in the interpreter's result object.
 *
 * Side effects:
 *	If successful, the object is made a nsName object. Its internal rep is
 *	set to point to a ResolvedNsName, which contains a cached pointer to
 *	the Namespace. Reference counts are kept on both the ResolvedNsName
 *	and the Namespace, so we can keep track of their usage and free them
 *	when appropriate.
 *
 *----------------------------------------------------------------------
 */

static int
SetNsNameFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Points to the namespace in which to resolve
				 * name. Also used for error reporting if not
				 * NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    char *name;
    CONST char *dummy;
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    register ResolvedNsName *resNamePtr;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    name = objPtr->bytes;
    if (name == NULL) {
	name = TclGetString(objPtr);
    }

    /*
     * Look for the namespace "name" in the current namespace. If there is an
     * error parsing the (possibly qualified) name, return an error. If the
     * namespace isn't found, we convert the object to an nsName object with a
     * NULL ResolvedNsName* internal rep.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
	    TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);

    /*
     * If we found a namespace, then create a new ResolvedNsName structure
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
	resNamePtr->refNsPtr = currNsPtr;
	resNamePtr->refCount = 1;
    } else {
	resNamePtr = NULL;
    }

    /*
     * Free the old internalRep before setting the new one.
     * We do this as late as possible to allow the conversion code
     * (in particular, Tcl_GetStringFromObj) to use that old internalRep.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
    objPtr->typePtr = &tclNsNameType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfNsName --
 *
 *	Updates the string representation for a nsName object.
 *	Note: This procedure does not free an existing old string rep
 *	so storage will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a copy of the fully qualified
 *	namespace name.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfNsName(objPtr)
    register Tcl_Obj *objPtr; /* nsName object with string rep to update. */







|
|
|













|
|
|





|
|







4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
	resNamePtr->refNsPtr = currNsPtr;
	resNamePtr->refCount = 1;
    } else {
	resNamePtr = NULL;
    }

    /*
     * Free the old internalRep before setting the new one. We do this as late
     * as possible to allow the conversion code (in particular,
     * Tcl_GetStringFromObj) to use that old internalRep.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
    objPtr->typePtr = &tclNsNameType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfNsName --
 *
 *	Updates the string representation for a nsName object. Note: This
 *	function does not free an existing old string rep so storage will be
 *	lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a copy of the fully qualified namespace
 *	name.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfNsName(objPtr)
    register Tcl_Obj *objPtr; /* nsName object with string rep to update. */
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
	}
	if (nsPtr != NULL) {
	    name = nsPtr->fullName;
	}
    }

    /*
     * The following sets the string rep to an empty string on the heap
     * if the internal rep is NULL.
     */

    length = strlen(name);
    if (length == 0) {
	objPtr->bytes = tclEmptyStringRep;
    } else {
	objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
	memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length);
	objPtr->bytes[length] = '\0';
    }
    objPtr->length = length;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceEnsembleCmd --
 *
 *	Invoked to implement the "namespace ensemble" command that
 *	creates and manipulates ensembles built on top of namespaces.
 *	Handles the following syntax:
 *
 *	    namespace ensemble name ?dictionary?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Creates the ensemble for the namespace if one did not
 *	previously exist.  Alternatively, alters the way that the
 *	ensemble's subcommand => implementation prefix is configured.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceEnsembleCmd(dummy, interp, objc, objv)
    ClientData dummy;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST objv[];
{
    Namespace *nsPtr;
    EnsembleConfig *ensemblePtr;
    static CONST char *subcommands[] = {
	"configure", "create", "exists", NULL
    };
    enum EnsSubcmds {
	ENS_CONFIG, ENS_CREATE, ENS_EXISTS
    };
    static CONST char *createOptions[] = {







|
|


















|
|
|







|
|
|












|







4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
	}
	if (nsPtr != NULL) {
	    name = nsPtr->fullName;
	}
    }

    /*
     * The following sets the string rep to an empty string on the heap if the
     * internal rep is NULL.
     */

    length = strlen(name);
    if (length == 0) {
	objPtr->bytes = tclEmptyStringRep;
    } else {
	objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
	memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length);
	objPtr->bytes[length] = '\0';
    }
    objPtr->length = length;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceEnsembleCmd --
 *
 *	Invoked to implement the "namespace ensemble" command that creates and
 *	manipulates ensembles built on top of namespaces. Handles the
 *	following syntax:
 *
 *	    namespace ensemble name ?dictionary?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Creates the ensemble for the namespace if one did not previously
 *	exist. Alternatively, alters the way that the ensemble's subcommand =>
 *	implementation prefix is configured.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceEnsembleCmd(dummy, interp, objc, objv)
    ClientData dummy;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST objv[];
{
    Namespace *nsPtr;
    Tcl_Command token;
    static CONST char *subcommands[] = {
	"configure", "create", "exists", NULL
    };
    enum EnsSubcmds {
	ENS_CONFIG, ENS_CREATE, ENS_EXISTS
    };
    static CONST char *createOptions[] = {
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
	return TCL_ERROR;
    }

    switch ((enum EnsSubcmds) index) {
    case ENS_CREATE: {
	char *name;
	Tcl_DictSearch search;
	Tcl_Obj *listObj, *nameObj = NULL;
	int done, len, allocatedMapFlag = 0;
	/*
	 * Defaults
	 */
	Tcl_Obj *subcmdObj = NULL;
	Tcl_Obj *mapObj = NULL;
	int permitPrefix = 1;
	Tcl_Obj *unknownObj = NULL;

	objv += 3;
	objc -= 3;

	/*
	 * Work out what name to use for the command to create.  If
	 * supplied, it is either fully specified or relative to the
	 * current namespace.  If not supplied, it is exactly the name
	 * of the current namespace.
	 */

	name = nsPtr->fullName;

	/*
	 * Parse the option list, applying type checks as we go.  Note
	 * that we are not incrementing any reference counts in the
	 * objects at this stage, so the presence of an option
	 * multiple times won't cause any memory leaks.
	 */

	for (; objc>1 ; objc-=2,objv+=2 ) {
	    if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
		    0, &index) != TCL_OK) {
		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);







|













|
|
|
<





|
|
|
|







4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722

4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
	return TCL_ERROR;
    }

    switch ((enum EnsSubcmds) index) {
    case ENS_CREATE: {
	char *name;
	Tcl_DictSearch search;
	Tcl_Obj *listObj;
	int done, len, allocatedMapFlag = 0;
	/*
	 * Defaults
	 */
	Tcl_Obj *subcmdObj = NULL;
	Tcl_Obj *mapObj = NULL;
	int permitPrefix = 1;
	Tcl_Obj *unknownObj = NULL;

	objv += 3;
	objc -= 3;

	/*
	 * Work out what name to use for the command to create. If supplied,
	 * it is either fully specified or relative to the current namespace.
	 * If not supplied, it is exactly the name of the current namespace.

	 */

	name = nsPtr->fullName;

	/*
	 * Parse the option list, applying type checks as we go. Note that we
	 * are not incrementing any reference counts in the objects at this
	 * stage, so the presence of an option multiple times won't cause any
	 * memory leaks.
	 */

	for (; objc>1 ; objc-=2,objv+=2 ) {
	    if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
		    0, &index) != TCL_OK) {
		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);
4365
4366
4367
4368
4369
4370
4371

4372
4373
4374

4375
4376
4377
4378
4379
4380
4381
		    }
		    return TCL_ERROR;
		}
		subcmdObj = (len > 0 ? objv[1] : NULL);
		continue;
	    case CRT_MAP: {
		Tcl_Obj *patchedDict = NULL, *subcmdObj;

		/*
		 * Verify that the map is sensible.
		 */

		if (Tcl_DictObjFirst(interp, objv[1], &search,
			&subcmdObj, &listObj, &done) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}







>



>







4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
		    }
		    return TCL_ERROR;
		}
		subcmdObj = (len > 0 ? objv[1] : NULL);
		continue;
	    case CRT_MAP: {
		Tcl_Obj *patchedDict = NULL, *subcmdObj;

		/*
		 * Verify that the map is sensible.
		 */

		if (Tcl_DictObjFirst(interp, objv[1], &search,
			&subcmdObj, &listObj, &done) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
		    }
		    return TCL_ERROR;
		}
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430

4431
4432
4433
4434
4435
4436
4437
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    cmd = TclGetString(listv[0]);
		    if (!(cmd[0] == ':' && cmd[1] == ':')) {
			Tcl_Obj *newList = Tcl_NewListObj(len, listv);
			Tcl_Obj *newCmd =
				Tcl_NewStringObj(nsPtr->fullName, -1);
			if (nsPtr->parentPtr) {
			    Tcl_AppendStringsToObj(newCmd, "::", NULL);
			}
			Tcl_AppendObjToObj(newCmd, listv[0]);
			Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
			if (patchedDict == NULL) {
			    patchedDict = Tcl_DuplicateObj(objv[1]);
			}
			Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
		    }
		    Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
		} while (!done);

		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);
		}
		mapObj = (patchedDict ? patchedDict : objv[1]);
		if (patchedDict) {
		    allocatedMapFlag = 1;
		}







|
|












>







4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    cmd = TclGetString(listv[0]);
		    if (!(cmd[0] == ':' && cmd[1] == ':')) {
			Tcl_Obj *newList = Tcl_NewListObj(len, listv);
			Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);

			if (nsPtr->parentPtr) {
			    Tcl_AppendStringsToObj(newCmd, "::", NULL);
			}
			Tcl_AppendObjToObj(newCmd, listv[0]);
			Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
			if (patchedDict == NULL) {
			    patchedDict = Tcl_DuplicateObj(objv[1]);
			}
			Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
		    }
		    Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
		} while (!done);

		if (allocatedMapFlag) {
		    Tcl_DecrRefCount(mapObj);
		}
		mapObj = (patchedDict ? patchedDict : objv[1]);
		if (patchedDict) {
		    allocatedMapFlag = 1;
		}
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498

4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511

4512
4513
4514
4515
4516
4517
4518


4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541


4542
4543
4544
4545
4546
4547

4548
4549
4550
4551
4552

4553
4554
4555
4556
4557



4558
4559
4560

4561



4562
4563
4564

4565

4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578


4579
4580


4581
4582

4583
4584
4585
4586
4587
4588


4589
4590

4591


4592

4593
4594

4595
4596


4597
4598

4599
4600
4601
4602
4603
4604


4605
4606

4607
4608
4609
4610
4611
4612

4613
4614
4615
4616
4617
4618
4619
4620
4621

4622
4623
4624
4625

4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
		}
		unknownObj = (len > 0 ? objv[1] : NULL);
		continue;
	    }
	}

	/*
	 * Make the name of the ensemble into a fully qualified name.
	 * This might allocate an object.
	 */

	if (!(name[0] == ':' && name[1] == ':')) {
	    nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
	    if (nsPtr->parentPtr == NULL) {
		Tcl_AppendStringsToObj(nameObj, name, NULL);
	    } else {
		Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
	    }
	    Tcl_IncrRefCount(nameObj);
	    name = TclGetString(nameObj);
	}

	/*
	 * Create the ensemble.  Note that this might delete another
	 * ensemble linked to the same namespace, so we must be
	 * careful.  However, we should be OK because we only link the
	 * namespace into the list once we've created it (and after
	 * any deletions have occurred.)
	 */

	ensemblePtr = (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig));
	ensemblePtr->nsPtr = nsPtr;
	ensemblePtr->epoch = 0;
	Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
	ensemblePtr->subcommandArrayPtr = NULL;
	ensemblePtr->subcmdList = subcmdObj;
	if (subcmdObj != NULL) {
	    Tcl_IncrRefCount(subcmdObj);
	}
	ensemblePtr->subcommandDict = mapObj;
	if (mapObj != NULL) {
	    Tcl_IncrRefCount(mapObj);
	}
	ensemblePtr->flags = (permitPrefix ? ENS_PREFIX : 0);

	ensemblePtr->unknownHandler = unknownObj;
	if (unknownObj != NULL) {
	    Tcl_IncrRefCount(unknownObj);
	}
	ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
		NsEnsembleImplementationCmd, (ClientData)ensemblePtr,
		DeleteEnsembleConfig);
	ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
	/*
	 * Trigger an eventual recomputation of the ensemble command
	 * set.  Note that this is slightly tricky, as it means that
	 * we are not actually counting the number of namespace export

	 * actions, but it is the simplest way to go!
	 */
	nsPtr->exportLookupEpoch++;
	Tcl_SetResult(interp, name, TCL_VOLATILE);
	if (nameObj != NULL) {
	    Tcl_DecrRefCount(nameObj);
	}


	return TCL_OK;
    }

    case ENS_EXISTS:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
		FindEnsemble(interp, objv[3], 0) != NULL));
	return TCL_OK;

    case ENS_CONFIG:
	if (objc < 4 || (objc != 5 && objc & 1)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
	    return TCL_ERROR;
	}
	ensemblePtr = FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
	if (ensemblePtr == NULL) {
	    return TCL_ERROR;
	}

	if (objc == 5) {


	    if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
		    0, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum EnsConfigOpts) index) {
	    case CONF_SUBCMDS:

		if (ensemblePtr->subcmdList != NULL) {
		    Tcl_SetObjResult(interp, ensemblePtr->subcmdList);
		}
		break;
	    case CONF_MAP:

		if (ensemblePtr->subcommandDict != NULL) {
		    Tcl_SetObjResult(interp, ensemblePtr->subcommandDict);
		}
		break;
	    case CONF_NAMESPACE:



		Tcl_SetResult(interp, ensemblePtr->nsPtr->fullName,
			TCL_VOLATILE);
		break;

	    case CONF_PREFIX:



		Tcl_SetObjResult(interp,
			Tcl_NewBooleanObj(ensemblePtr->flags & ENS_PREFIX));
		break;

	    case CONF_UNKNOWN:

		if (ensemblePtr->unknownHandler != NULL) {
		    Tcl_SetObjResult(interp, ensemblePtr->unknownHandler);
		}
		break;
	    }
	    return TCL_OK;

	} else if (objc == 4) {
	    /*
	     * Produce list of all information.
	     */

	    Tcl_Obj *resultObj;



	    TclNewObj(resultObj);


	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_MAP], -1));

	    if (ensemblePtr->subcommandDict != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj,
			ensemblePtr->subcommandDict);
	    } else {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
	    }


	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));

	    Tcl_ListObjAppendElement(NULL, resultObj,


		    Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1));

	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_PREFIX], -1));

	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewBooleanObj(ensemblePtr->flags & ENS_PREFIX));


	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));

	    if (ensemblePtr->subcmdList != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj,
			ensemblePtr->subcmdList);
	    } else {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
	    }


	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));

	    if (ensemblePtr->unknownHandler != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj,
			ensemblePtr->unknownHandler);
	    } else {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
	    }

	    Tcl_SetObjResult(interp, resultObj);
	    return TCL_OK;

	} else {
	    Tcl_DictSearch search;
	    Tcl_Obj *listObj;
	    int done, len, allocatedMapFlag = 0;
	    /*
	     * Defaults

	     */
	    Tcl_Obj *subcmdObj = ensemblePtr->subcmdList;
	    Tcl_Obj *mapObj = ensemblePtr->subcommandDict;
	    Tcl_Obj *unknownObj = ensemblePtr->unknownHandler;

	    int permitPrefix = ensemblePtr->flags & ENS_PREFIX;

	    objv += 4;
	    objc -= 4;

	    /*
	     * Parse the option list, applying type checks as we go.
	     * Note that we are not incrementing any reference counts
	     * in the objects at this stage, so the presence of an
	     * option multiple times won't cause any memory leaks.
	     */

	    for (; objc>0 ; objc-=2,objv+=2 ) {
		if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
			"option", 0, &index) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
|


<
<
|
<
<
<
<
<
<
<
<
<
<
|
>
|
<
|
|
<
<
<
<
<

<
|
<
>
|

<
<
<
<
|
>
>









|







|
|




>
>






>
|
|



>
|
|


|
>
>
>
|


>
|
>
>
>

|

>

>
|
|










|
>
>


>
>


>
|
|
<



>
>


>

>
>
|
>


>

|
>
>


>
|
|
<



>
>


>
|
|
<



>


<




<
|
>
|
|
|
|
>
|





|
|
|
|







4843
4844
4845
4846
4847
4848
4849
















4850
4851
4852

4853
4854
4855


4856










4857
4858
4859

4860
4861





4862

4863

4864
4865
4866




4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953

4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978

4979
4980
4981
4982
4983
4984
4985
4986
4987
4988

4989
4990
4991
4992
4993
4994

4995
4996
4997
4998

4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
		}
		unknownObj = (len > 0 ? objv[1] : NULL);
		continue;
	    }
	}

	/*
















	 * Create the ensemble. Note that this might delete another ensemble
	 * linked to the same namespace, so we must be careful. However, we
	 * should be OK because we only link the namespace into the list once

	 * we've created it (and after any deletions have occurred.)
	 */



	token = Tcl_CreateEnsemble(interp, name, NULL,










		(permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
	Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
	Tcl_SetEnsembleMappingDict(interp, token, mapObj);

	Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);






	/*

	 * Tricky! Must ensure that the result is not shared (command delete

	 * traces could have corrupted the pristine object that we started
	 * with). [Snit test rename-1.5]
	 */





	Tcl_ResetResult(interp);
	Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
	return TCL_OK;
    }

    case ENS_EXISTS:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
		Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
	return TCL_OK;

    case ENS_CONFIG:
	if (objc < 4 || (objc != 5 && objc & 1)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
	    return TCL_ERROR;
	}
	token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
	if (token == NULL) {
	    return TCL_ERROR;
	}

	if (objc == 5) {
	    Tcl_Obj *resultObj;

	    if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
		    0, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum EnsConfigOpts) index) {
	    case CONF_SUBCMDS:
		Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    case CONF_MAP:
		Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    case CONF_NAMESPACE: {
		Tcl_Namespace *namespacePtr;

		Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
		Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName,
			TCL_VOLATILE);
		break;
	    }
	    case CONF_PREFIX: {
		int flags;

		Tcl_GetEnsembleFlags(NULL, token, &flags);
		Tcl_SetObjResult(interp,
			Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
		break;
	    }
	    case CONF_UNKNOWN:
		Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
		if (resultObj != NULL) {
		    Tcl_SetObjResult(interp, resultObj);
		}
		break;
	    }
	    return TCL_OK;

	} else if (objc == 4) {
	    /*
	     * Produce list of all information.
	     */

	    Tcl_Obj *resultObj, *tmpObj;
	    Tcl_Namespace *namespacePtr;
	    int flags;

	    TclNewObj(resultObj);

	    /* -map option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_MAP], -1));
	    Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
	    if (tmpObj != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);

	    } else {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
	    }

	    /* -namespace option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));
	    Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName,
		    -1));

	    /* -prefix option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_PREFIX], -1));
	    Tcl_GetEnsembleFlags(NULL, token, &flags);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));

	    /* -subcommands option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));
	    Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
	    if (tmpObj != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);

	    } else {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
	    }

	    /* -unknown option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));
	    Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
	    if (tmpObj != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);

	    } else {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
	    }

	    Tcl_SetObjResult(interp, resultObj);
	    return TCL_OK;

	} else {
	    Tcl_DictSearch search;
	    Tcl_Obj *listObj;
	    int done, len, allocatedMapFlag = 0;

	    Tcl_Obj *subcmdObj, *mapObj, *unknownObj;	/* Defaults */
	    int permitPrefix, flags;

	    Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
	    Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
	    Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
	    Tcl_GetEnsembleFlags(NULL, token, &flags);
	    permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;

	    objv += 4;
	    objc -= 4;

	    /*
	     * Parse the option list, applying type checks as we go. Note that
	     * we are not incrementing any reference counts in the objects at
	     * this stage, so the presence of an option multiple times won't
	     * cause any memory leaks.
	     */

	    for (; objc>0 ; objc-=2,objv+=2 ) {
		if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
			"option", 0, &index) != TCL_OK) {
		    if (allocatedMapFlag) {
			Tcl_DecrRefCount(mapObj);
4651
4652
4653
4654
4655
4656
4657

4658
4659
4660

4661
4662
4663
4664
4665
4666
4667
			}
			return TCL_ERROR;
		    }
		    subcmdObj = (len > 0 ? objv[1] : NULL);
		    continue;
		case CONF_MAP: {
		    Tcl_Obj *patchedDict = NULL, *subcmdObj;

		    /*
		     * Verify that the map is sensible.
		     */

		    if (Tcl_DictObjFirst(interp, objv[1], &search,
			    &subcmdObj, &listObj, &done) != TCL_OK) {
			if (allocatedMapFlag) {
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }







>



>







5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
			}
			return TCL_ERROR;
		    }
		    subcmdObj = (len > 0 ? objv[1] : NULL);
		    continue;
		case CONF_MAP: {
		    Tcl_Obj *patchedDict = NULL, *subcmdObj;

		    /*
		     * Verify that the map is sensible.
		     */

		    if (Tcl_DictObjFirst(interp, objv[1], &search,
			    &subcmdObj, &listObj, &done) != TCL_OK) {
			if (allocatedMapFlag) {
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814











































































































































































































































































































































































































































































































































4815
4816
4817
4818
4819
4820
4821
4822

4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846

4847
4848
4849
4850
4851

4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862

4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885

4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953

4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005

5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035

5036
5037
5038
5039
5040
5041
5042
5043
5044

5045
5046
5047
5048
5049
5050
5051

5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
		    }
		    unknownObj = (len > 0 ? objv[1] : NULL);
		    continue;
		}
	    }

	    /*
	     * Update the namespace now that we've finished the
	     * parsing stage.
	     */

	    if (ensemblePtr->subcmdList != subcmdObj) {
		if (ensemblePtr->subcmdList != NULL) {
		    Tcl_DecrRefCount(ensemblePtr->subcmdList);
		}
		ensemblePtr->subcmdList = subcmdObj;
		if (subcmdObj != NULL) {
		    Tcl_IncrRefCount(subcmdObj);
		}
	    }
	    if (ensemblePtr->subcommandDict != mapObj) {
		if (ensemblePtr->subcommandDict != NULL) {
		    Tcl_DecrRefCount(ensemblePtr->subcommandDict);
		}
		ensemblePtr->subcommandDict = mapObj;
		if (mapObj != NULL) {
		    Tcl_IncrRefCount(mapObj);
		}
	    }
	    if (ensemblePtr->unknownHandler != unknownObj) {
		if (ensemblePtr->unknownHandler != NULL) {
		    Tcl_DecrRefCount(ensemblePtr->unknownHandler);
		}
		ensemblePtr->unknownHandler = unknownObj;
		if (unknownObj != NULL) {
		    Tcl_IncrRefCount(unknownObj);
		}
	    }
	    if (permitPrefix) {
		ensemblePtr->flags |= ENS_PREFIX;
	    } else {
		ensemblePtr->flags &= ~ENS_PREFIX;
	    }
	    /*
	     * Trigger an eventual recomputation of the ensemble
	     * command set.  Note that this is slightly tricky, as it
	     * means that we are not actually counting the number of
	     * namespace export actions, but it is the simplest way to
	     * go!  Also note that this nsPtr and ensemblePtr->nsPtr
	     * are quite possibly not the same namespace; we want to
	     * bump the epoch for the ensemble's namespace, not the
	     * current namespace.
	     */
	    ensemblePtr->nsPtr->exportLookupEpoch++;
	    return TCL_OK;
	}

    default:
	Tcl_Panic("unexpected ensemble command");
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *











































































































































































































































































































































































































































































































































 * FindEnsemble --
 *
 *	Given a command name, get the ensemble configuration structure
 *	for it, allowing for [namespace import]s. [Bug 1017022]
 *
 * Results:
 *	A pointer to the config struct, or NULL if the command either
 *	does not exist or is not an ensemble.

 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static EnsembleConfig *
FindEnsemble(interp, cmdNameObj, flags)
    Tcl_Interp *interp;			/* Where to do the lookup, and where
					 * to write the errors if
					 * TCL_LEAVE_ERR_MSG is set in the
					 * flags. */
    Tcl_Obj *cmdNameObj;		/* Name of command to look up. */
    int flags;				/* Either 0 or TCL_LEAVE_ERR_MSG; other
					 * flags are probably not useful. */
{
    Command *cmdPtr;

    cmdPtr = (Command *)
	    Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
    if (cmdPtr == NULL) {
	return NULL;
    }

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	/*
	 * Reuse existing infrastructure for following import link
	 * chains rather than duplicating it.
	 */

	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);

	if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
			"\" is not an ensemble command", NULL);
	    }
	    return NULL;
	}
    }
    return (EnsembleConfig *) cmdPtr->objClientData;

}

/*
 *----------------------------------------------------------------------
 *
 * TclIsEnsemble --
 *
 *	Simple test for ensemble-hood that takes into account imported
 *	ensemble commands as well.
 *
 * Results:
 *	Boolean value
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
TclIsEnsemble(cmdPtr)
    Command *cmdPtr;
{

    if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
	return 1;
    }
    cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
    if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
	return 0;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleImplementationCmd --
 *
 *	Implements an ensemble of commands (being those exported by a
 *	namespace other than the global namespace) as a command with
 *	the same (short) name as the namespace in the parent namespace.
 *
 * Results:
 *	A standard Tcl result code.  Will be TCL_ERROR if the command
 *	is not an unambiguous prefix of any command exported by the
 *	ensemble's namespace.
 *
 * Side effects:
 *	Depends on the command within the namespace that gets executed.
 *	If the ensemble itself returns TCL_ERROR, a descriptive error
 *	message will be placed in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

static int
NsEnsembleImplementationCmd(clientData, interp, objc, objv)
    ClientData clientData;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST objv[];
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
					/* The ensemble itself. */
    Tcl_Obj **tempObjv;			/* Space used to construct the list of
					 * arguments to pass to the command
					 * that implements the ensemble
					 * subcommand. */
    int result;				/* The result of the subcommand
					 * execution. */
    Tcl_Obj *prefixObj;			/* An object containing the prefix
					 * words of the command that implements
					 * the subcommand. */
    Tcl_HashEntry *hPtr;		/* Used for efficient lookup of fully
					 * specified but not yet cached command
					 * names. */
    Tcl_Obj **prefixObjv;		/* The list of objects to substitute in
					 * as the target command prefix. */
    int prefixObjc;			/* Size of prefixObjv of course! */
    int reparseCount = 0;		/* Number of reparses. */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?");
	return TCL_ERROR;
    }

  restartEnsembleParse:
    if (ensemblePtr->nsPtr->flags & NS_DEAD) {
	/*
	 * Don't know how we got here, but make things give up quickly.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_AppendResult(interp,
		    "ensemble activated for deleted namespace", NULL);
	}
	return TCL_ERROR;
    }

    if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) {
	ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
	BuildEnsembleConfig(ensemblePtr);
    } else {
	/*
	 * Table of subcommands is still valid; therefore there might
	 * be a valid cache of discovered information which we can
	 * reuse.  Do the check here, and if we're still valid, we can
	 * jump straight to the part where we do the invocation of the
	 * subcommand.
	 */

	if (objv[1]->typePtr == &tclEnsembleCmdType) {
	    EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
		    objv[1]->internalRep.otherValuePtr;
	    if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
		ensembleCmd->epoch == ensemblePtr->epoch &&
		ensembleCmd->token == ensemblePtr->token) {
		prefixObj = ensembleCmd->realPrefixObj;
		Tcl_IncrRefCount(prefixObj);
		goto runResultingSubcommand;
	    }
	}
    }

    /*
     * Look in the hashtable for the subcommand name; this is the
     * fastest way of all.
     */

    hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
	    TclGetString(objv[1]));
    if (hPtr != NULL) {
	char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
	prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
    } else if (!(ensemblePtr->flags & ENS_PREFIX)) {
	/*
	 * Can't find and we are prohibited from using unambiguous prefixes.
	 */

	goto unknownOrAmbiguousSubcommand;
    } else {
	/*
	 * If we've not already confirmed the command with the hash as
	 * part of building our export table, we need to scan the
	 * sorted array for matches.
	 */

	char *subcmdName;		/* Name of the subcommand, or unique
					 * prefix of it (will be an error for
					 * a non-unique prefix). */
	char *fullName = NULL;		/* Full name of the subcommand. */
	int stringLength, i;
	int tableLength = ensemblePtr->subcommandTable.numEntries;

	subcmdName = TclGetString(objv[1]);
	stringLength = objv[1]->length;
	for (i=0 ; i<tableLength ; i++) {
	    register int cmp = strncmp(subcmdName,
		    ensemblePtr->subcommandArrayPtr[i],
		    (unsigned)stringLength);
	    if (cmp == 0) {
		if (fullName != NULL) {
		    /*
		     * Since there's never the exact-match case to
		     * worry about (hash search filters this), getting
		     * here indicates that our subcommand is an
		     * ambiguous prefix of (at least) two exported
		     * subcommands, which is an error case.
		     */

		    goto unknownOrAmbiguousSubcommand;
		}
		fullName = ensemblePtr->subcommandArrayPtr[i];
	    } else if (cmp < 0) {
		/*
		 * Because we are searching a sorted table, we can now
		 * stop searching because we have gone past anything
		 * that could possibly match.
		 */

		break;
	    }
	}
	if (fullName == NULL) {
	    /*
	     * The subcommand is not a prefix of anything, so bail out!
	     */

	    goto unknownOrAmbiguousSubcommand;
	}
	hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
	if (hPtr == NULL) {
	    Tcl_Panic("full name %s not found in supposedly synchronized hash",
		    fullName);
	}
	prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
    }

    /*
     * Do the real work of execution of the subcommand by building an
     * array of objects (note that this is potentially not the same
     * length as the number of arguments to this ensemble command),
     * populating it and then feeding it back through the main
     * command-lookup engine.  In theory, we could look up the command
     * in the namespace ourselves, as we already have the namespace in
     * which it is guaranteed to exist, but we don't do that (the
     * cacheing of the command object used should help with that.)
     */

    Tcl_IncrRefCount(prefixObj);
  runResultingSubcommand:
    {
	Interp *iPtr = (Interp *) interp;
	int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);







|
<


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
|
<
<
|
<
<
<
|
<
<
<
<
|












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

|
|


|
|
>







|
|
|
<
|
|
|
|
|








>


|
|

>










|
>





|














|
|

>
















|
|


|
|
|


|
|
|












|
|
|
|
<
|
<
|
|
|
|
|
|
|
|
|
|











>












|
|
|
|
<


|













|
|













|



>



|
|
|


|
|
|
|








|



|
|
<
|
|

>





|
|
|

>







>

















|
|
|
|
<
|
|
|







5131
5132
5133
5134
5135
5136
5137
5138

5139
5140



























5141
5142

5143


5144



5145




5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700

5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800

5801

5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839

5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901

5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944

5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
		    }
		    unknownObj = (len > 0 ? objv[1] : NULL);
		    continue;
		}
	    }

	    /*
	     * Update the namespace now that we've finished the parsing stage.

	     */




























	    flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
		    : flags&~TCL_ENSEMBLE_PREFIX);

	    Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj);


	    Tcl_SetEnsembleMappingDict(NULL, token, mapObj);



	    Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj);




	    Tcl_SetEnsembleFlags(NULL, token, flags);
	    return TCL_OK;
	}

    default:
	Tcl_Panic("unexpected ensemble command");
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateEnsemble --
 *
 *	Create a simple ensemble attached to the given namespace.
 *
 * Results:
 *	The token for the command created.
 *
 * Side effects:
 *	The ensemble is created and marked for compilation.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_CreateEnsemble(interp, name, namespacePtr, flags)
    Tcl_Interp *interp;
    CONST char *name;
    Tcl_Namespace *namespacePtr;
    int flags;
{
    Namespace *nsPtr = (Namespace *) namespacePtr;
    EnsembleConfig *ensemblePtr =
	    (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig));
    Tcl_Obj *nameObj = NULL;

    if (nsPtr == NULL) {
	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    }

    /*
     * Make the name of the ensemble into a fully qualified name. This might
     * allocate a temporary object.
     */

    if (!(name[0] == ':' && name[1] == ':')) {
	nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
	if (nsPtr->parentPtr == NULL) {
	    Tcl_AppendStringsToObj(nameObj, name, NULL);
	} else {
	    Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
	}
	Tcl_IncrRefCount(nameObj);
	name = TclGetString(nameObj);
    }

    ensemblePtr->nsPtr = nsPtr;
    ensemblePtr->epoch = 0;
    Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
    ensemblePtr->subcommandArrayPtr = NULL;
    ensemblePtr->subcmdList = NULL;
    ensemblePtr->subcommandDict = NULL;
    ensemblePtr->flags = flags;
    ensemblePtr->unknownHandler = NULL;
    ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
	    NsEnsembleImplementationCmd, (ClientData)ensemblePtr,
	    DeleteEnsembleConfig);
    ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
    nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    nsPtr->exportLookupEpoch++;

    if (nameObj != NULL) {
	TclDecrRefCount(nameObj);
    }
    return ensemblePtr->token;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleSubcommandList --
 *
 *	Set the subcommand list for a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an ensemble
 *	or the subcommand list - if non-NULL - is not a list).
 *
 * Side effects:
 *	The ensemble is updated and marked for recompilation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleSubcommandList(interp, token, subcmdList)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Obj *subcmdList;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }
    if (subcmdList != NULL) {
	int length;
	if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    subcmdList = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    oldList = ensemblePtr->subcmdList;
    ensemblePtr->subcmdList = subcmdList;
    if (subcmdList != NULL) {
	Tcl_IncrRefCount(subcmdList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleMappingDict --
 *
 *	Set the mapping dictionary for a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an ensemble
 *	or the mapping - if non-NULL - is not a dict).
 *
 * Side effects:
 *	The ensemble is updated and marked for recompilation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleMappingDict(interp, token, mapDict)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Obj *mapDict;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldDict;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }
    if (mapDict != NULL) {
	int size;
	if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (size < 1) {
	    mapDict = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    oldDict = ensemblePtr->subcommandDict;
    ensemblePtr->subcommandDict = mapDict;
    if (mapDict != NULL) {
	Tcl_IncrRefCount(mapDict);
    }
    if (oldDict != NULL) {
	TclDecrRefCount(oldDict);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleUnknownHandler --
 *
 *	Set the unknown handler for a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an ensemble
 *	or the unknown handler - if non-NULL - is not a list).
 *
 * Side effects:
 *	The ensemble is updated and marked for recompilation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleUnknownHandler(interp, token, unknownList)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Obj *unknownList;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }
    if (unknownList != NULL) {
	int length;

	if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    unknownList = NULL;
	}
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    oldList = ensemblePtr->unknownHandler;
    ensemblePtr->unknownHandler = unknownList;
    if (unknownList != NULL) {
	Tcl_IncrRefCount(unknownList);
    }
    if (oldList != NULL) {
	TclDecrRefCount(oldList);
    }

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetEnsembleFlags --
 *
 *	Set the flags for a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an
 *	ensemble).
 *
 * Side effects:
 *	The ensemble is updated and marked for recompilation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetEnsembleFlags(interp, token, flags)
    Tcl_Interp *interp;
    Tcl_Command token;
    int flags;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    /*
     * This API refuses to set the ENS_DEAD flag...
     */
    ensemblePtr->flags &= ENS_DEAD;
    ensemblePtr->flags |= flags & ~ENS_DEAD;

    /*
     * Trigger an eventual recomputation of the ensemble command set. Note
     * that this is slightly tricky, as it means that we are not actually
     * counting the number of namespace export actions, but it is the simplest
     * way to go!
     */

    ensemblePtr->nsPtr->exportLookupEpoch++;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetEnsembleSubcommandList --
 *
 *	Get the list of subcommands associated with a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an
 *	ensemble). The list of subcommands is returned by updating the
 *	variable pointed to by the last parameter (NULL if this is to be
 *	derived from the mapping dictionary or the associated namespace's
 *	exported commands).
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleSubcommandList(interp, token, subcmdListPtr)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Obj **subcmdListPtr;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    *subcmdListPtr = ensemblePtr->subcmdList;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetEnsembleMappingDict --
 *
 *	Get the command mapping dictionary associated with a particular
 *	ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an
 *	ensemble). The mapping dict is returned by updating the variable
 *	pointed to by the last parameter (NULL if none is installed).
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleMappingDict(interp, token, mapDictPtr)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Obj **mapDictPtr;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    *mapDictPtr = ensemblePtr->subcommandDict;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetEnsembleUnknownHandler --
 *
 *	Get the unknown handler associated with a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an
 *	ensemble). The unknown handler is returned by updating the variable
 *	pointed to by the last parameter (NULL if no handler is installed).
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleUnknownHandler(interp, token, unknownListPtr)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Obj **unknownListPtr;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    *unknownListPtr = ensemblePtr->unknownHandler;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetEnsembleFlags --
 *
 *	Get the flags for a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an
 *	ensemble). The flags are returned by updating the variable pointed to
 *	by the last parameter.
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleFlags(interp, token, flagsPtr)
    Tcl_Interp *interp;
    Tcl_Command token;
    int *flagsPtr;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    *flagsPtr = ensemblePtr->flags;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetEnsembleNamespace --
 *
 *	Get the namespace associated with a particular ensemble.
 *
 * Results:
 *	Tcl result code (error if command token does not indicate an
 *	ensemble). Namespace is returned by updating the variable pointed to
 *	by the last parameter.
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetEnsembleNamespace(interp, token, namespacePtrPtr)
    Tcl_Interp *interp;
    Tcl_Command token;
    Tcl_Namespace **namespacePtrPtr;
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "command is not an ensemble", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
    *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindEnsemble --
 *
 *	Given a command name, get the ensemble token for it, allowing for
 *	[namespace import]s. [Bug 1017022]
 *
 * Results:
 *	The token for the ensemble command with the given name, or NULL if the
 *	command either does not exist or is not an ensemble (when an error
 *	message will be written into the interp if thats non-NULL).
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_FindEnsemble(interp, cmdNameObj, flags)
    Tcl_Interp *interp;		/* Where to do the lookup, and where to write

				 * the errors if TCL_LEAVE_ERR_MSG is set in
				 * the flags. */
    Tcl_Obj *cmdNameObj;	/* Name of command to look up. */
    int flags;			/* Either 0 or TCL_LEAVE_ERR_MSG; other flags
				 * are probably not useful. */
{
    Command *cmdPtr;

    cmdPtr = (Command *)
	    Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
    if (cmdPtr == NULL) {
	return NULL;
    }

    if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
	/*
	 * Reuse existing infrastructure for following import link chains
	 * rather than duplicating it.
	 */

	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);

	if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
			"\" is not an ensemble command", NULL);
	    }
	    return NULL;
	}
    }

    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsEnsemble --
 *
 *	Simple test for ensemble-hood that takes into account imported
 *	ensemble commands as well.
 *
 * Results:
 *	Boolean value
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsEnsemble(token)
    Tcl_Command token;
{
    Command *cmdPtr = (Command *) token;
    if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
	return 1;
    }
    cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
    if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
	return 0;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleImplementationCmd --
 *
 *	Implements an ensemble of commands (being those exported by a
 *	namespace other than the global namespace) as a command with the same
 *	(short) name as the namespace in the parent namespace.
 *
 * Results:
 *	A standard Tcl result code. Will be TCL_ERROR if the command is not an
 *	unambiguous prefix of any command exported by the ensemble's
 *	namespace.
 *
 * Side effects:
 *	Depends on the command within the namespace that gets executed. If the
 *	ensemble itself returns TCL_ERROR, a descriptive error message will be
 *	placed in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */

static int
NsEnsembleImplementationCmd(clientData, interp, objc, objv)
    ClientData clientData;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *CONST objv[];
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
				/* The ensemble itself. */
    Tcl_Obj **tempObjv;		/* Space used to construct the list of
				 * arguments to pass to the command that
				 * implements the ensemble subcommand. */

    int result;			/* The result of the subcommand execution. */

    Tcl_Obj *prefixObj;		/* An object containing the prefix words of
				 * the command that implements the
				 * subcommand. */
    Tcl_HashEntry *hPtr;	/* Used for efficient lookup of fully
				 * specified but not yet cached command
				 * names. */
    Tcl_Obj **prefixObjv;	/* The list of objects to substitute in as the
				 * target command prefix. */
    int prefixObjc;		/* Size of prefixObjv of course! */
    int reparseCount = 0;	/* Number of reparses. */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?");
	return TCL_ERROR;
    }

  restartEnsembleParse:
    if (ensemblePtr->nsPtr->flags & NS_DEAD) {
	/*
	 * Don't know how we got here, but make things give up quickly.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_AppendResult(interp,
		    "ensemble activated for deleted namespace", NULL);
	}
	return TCL_ERROR;
    }

    if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) {
	ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
	BuildEnsembleConfig(ensemblePtr);
    } else {
	/*
	 * Table of subcommands is still valid; therefore there might be a
	 * valid cache of discovered information which we can reuse. Do the
	 * check here, and if we're still valid, we can jump straight to the
	 * part where we do the invocation of the subcommand.

	 */

	if (objv[1]->typePtr == &ensembleCmdType) {
	    EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
		    objv[1]->internalRep.otherValuePtr;
	    if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
		ensembleCmd->epoch == ensemblePtr->epoch &&
		ensembleCmd->token == ensemblePtr->token) {
		prefixObj = ensembleCmd->realPrefixObj;
		Tcl_IncrRefCount(prefixObj);
		goto runResultingSubcommand;
	    }
	}
    }

    /*
     * Look in the hashtable for the subcommand name; this is the fastest way
     * of all.
     */

    hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
	    TclGetString(objv[1]));
    if (hPtr != NULL) {
	char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
	prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
    } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
	/*
	 * Can't find and we are prohibited from using unambiguous prefixes.
	 */

	goto unknownOrAmbiguousSubcommand;
    } else {
	/*
	 * If we've not already confirmed the command with the hash as part of
	 * building our export table, we need to scan the sorted array for
	 * matches.
	 */

	char *subcmdName;	/* Name of the subcommand, or unique prefix of
				 * it (will be an error for a non-unique
				 * prefix). */
	char *fullName = NULL;	/* Full name of the subcommand. */
	int stringLength, i;
	int tableLength = ensemblePtr->subcommandTable.numEntries;

	subcmdName = TclGetString(objv[1]);
	stringLength = objv[1]->length;
	for (i=0 ; i<tableLength ; i++) {
	    register int cmp = strncmp(subcmdName,
		    ensemblePtr->subcommandArrayPtr[i],
		    (unsigned) stringLength);
	    if (cmp == 0) {
		if (fullName != NULL) {
		    /*
		     * Since there's never the exact-match case to worry about
		     * (hash search filters this), getting here indicates that

		     * our subcommand is an ambiguous prefix of (at least) two
		     * exported subcommands, which is an error case.
		     */

		    goto unknownOrAmbiguousSubcommand;
		}
		fullName = ensemblePtr->subcommandArrayPtr[i];
	    } else if (cmp < 0) {
		/*
		 * Because we are searching a sorted table, we can now stop
		 * searching because we have gone past anything that could
		 * possibly match.
		 */

		break;
	    }
	}
	if (fullName == NULL) {
	    /*
	     * The subcommand is not a prefix of anything, so bail out!
	     */

	    goto unknownOrAmbiguousSubcommand;
	}
	hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
	if (hPtr == NULL) {
	    Tcl_Panic("full name %s not found in supposedly synchronized hash",
		    fullName);
	}
	prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
    }

    /*
     * Do the real work of execution of the subcommand by building an array of
     * objects (note that this is potentially not the same length as the
     * number of arguments to this ensemble command), populating it and then
     * feeding it back through the main command-lookup engine. In theory, we

     * could look up the command in the namespace ourselves, as we already
     * have the namespace in which it is guaranteed to exist, but we don't do
     * that (the cacheing of the command object used should help with that.)
     */

    Tcl_IncrRefCount(prefixObj);
  runResultingSubcommand:
    {
	Interp *iPtr = (Interp *) interp;
	int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
	    iPtr->ensembleRewrite.numInsertedObjs = 0;
	}
	return result;
    }

  unknownOrAmbiguousSubcommand:
    /*
     * Have not been able to match the subcommand asked for with a
     * real subcommand that we export.  See whether a handler has been
     * registered for dealing with this situation.  Will only call (at
     * most) once for any particular ensemble invocation.
     */

    if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
	int paramc, i;
	Tcl_Obj **paramv, *unknownCmd, *ensObj;

	unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);







|
|
|
|







5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
	    iPtr->ensembleRewrite.numInsertedObjs = 0;
	}
	return result;
    }

  unknownOrAmbiguousSubcommand:
    /*
     * Have not been able to match the subcommand asked for with a real
     * subcommand that we export. See whether a handler has been registered
     * for dealing with this situation. Will only call (at most) once for any
     * particular ensemble invocation.
     */

    if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
	int paramc, i;
	Tcl_Obj **paramv, *unknownCmd, *ensObj;

	unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
		Tcl_SetResult(interp,
			"unknown subcommand handler deleted its ensemble",
			TCL_STATIC);
		return TCL_ERROR;
	    }

	    /*
	     * Namespace is still there.  Check if the result is a
	     * valid list.  If it is, and it is non-empty, that list
	     * is what we are using as our replacement.
	     */

	    if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
		Tcl_DecrRefCount(prefixObj);
		Tcl_AddErrorInfo(interp,
			"\n    while parsing result of ensemble unknown subcommand handler");
		return TCL_ERROR;







|
|
|







6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
		Tcl_SetResult(interp,
			"unknown subcommand handler deleted its ensemble",
			TCL_STATIC);
		return TCL_ERROR;
	    }

	    /*
	     * Namespace is still there. Check if the result is a valid list.
	     * If it is, and it is non-empty, that list is what we are using
	     * as our replacement.
	     */

	    if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
		Tcl_DecrRefCount(prefixObj);
		Tcl_AddErrorInfo(interp,
			"\n    while parsing result of ensemble unknown subcommand handler");
		return TCL_ERROR;
5185
5186
5187
5188
5189
5190
5191

5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282

5283
5284
5285
5286
5287
5288
5289
5290
5291

5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
		    Tcl_AppendResult(interp, "break", NULL);
		    break;
		case TCL_CONTINUE:
		    Tcl_AppendResult(interp, "continue", NULL);
		    break;
		default: {
		    char buf[TCL_INTEGER_SPACE];

		    sprintf(buf, "%d", result);
		    Tcl_AppendResult(interp, buf, NULL);
		}
		}
		Tcl_AddErrorInfo(interp,
			"\n    result of ensemble unknown subcommand handler: ");
		Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
	    } else {
		Tcl_AddErrorInfo(interp,
			"\n    (ensemble unknown subcommand handler)");
	    }
	}
	Tcl_DecrRefCount(unknownCmd);
	Tcl_Release(ensemblePtr);
	return TCL_ERROR;
    }

    /*
     * Cannot determine what subcommand to hand off to, so generate a
     * (standard) failure message.  Note the one odd case compared
     * with standard ensemble-like command, which is where a namespace
     * has no exported commands at all...
     */

    Tcl_ResetResult(interp);
    if (ensemblePtr->subcommandTable.numEntries == 0) {
	Tcl_AppendResult(interp, "unknown subcommand \"", TclGetString(objv[1]),
		"\": namespace ", ensemblePtr->nsPtr->fullName,
		" does not export any commands", NULL);
	return TCL_ERROR;
    }
    Tcl_AppendResult(interp, "unknown ",
	    (ensemblePtr->flags & ENS_PREFIX ? "or ambiguous " : ""),
	    "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL);
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
    } else {
	int i;
	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
	    Tcl_AppendResult(interp,
		    ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
	}
	Tcl_AppendResult(interp, "or ",
		ensemblePtr->subcommandArrayPtr[i], NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeCachedEnsembleCommand --
 *
 *	Cache what we've computed so far; it's not nice to repeatedly
 *	copy strings about.  Note that to do this, we start by
 *	deleting any old representation that there was (though if it
 *	was an out of date ensemble rep, we can skip some of the
 *	deallocation process.)
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Alters the internal representation of the first object parameter.
 *
 *----------------------------------------------------------------------
 */
static void
MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr)
    Tcl_Obj *objPtr;
    EnsembleConfig *ensemblePtr;
    CONST char *subcommandName;
    Tcl_Obj *prefixObjPtr;
{
    register EnsembleCmdRep *ensembleCmd;
    int length;

    if (objPtr->typePtr == &tclEnsembleCmdType) {
	ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr;
	Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
	ensembleCmd->nsPtr->refCount--;
	if ((ensembleCmd->nsPtr->refCount == 0)
		&& (ensembleCmd->nsPtr->flags & NS_DEAD)) {
	    NamespaceFree(ensembleCmd->nsPtr);
	}
	ckfree(ensembleCmd->fullSubcmdName);
    } else {
	/*
	 * Kill the old internal rep, and replace it with a brand new
	 * one of our own.
	 */

	TclFreeIntRep(objPtr);
	ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
	objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd;
	objPtr->typePtr = &tclEnsembleCmdType;
    }

    /*
     * Populate the internal rep.
     */

    ensembleCmd->nsPtr = ensemblePtr->nsPtr;
    ensembleCmd->epoch = ensemblePtr->epoch;
    ensembleCmd->token = ensemblePtr->token;
    ensemblePtr->nsPtr->refCount++;
    ensembleCmd->realPrefixObj = prefixObjPtr;
    length = strlen(subcommandName)+1;
    ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
    memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
    Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteEnsembleConfig --
 *
 *	Destroys the data structure used to represent an ensemble.
 *	This is called when the ensemble's command is deleted (which
 *	happens automatically if the ensemble's namespace is deleted.)
 *	Maintainers should note that ensembles should be deleted by
 *	deleting their commands.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is (eventually) deallocated.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteEnsembleConfig(clientData)
    ClientData clientData;
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
    Namespace *nsPtr = ensemblePtr->nsPtr;
    Tcl_HashSearch search;
    Tcl_HashEntry *hEnt;

    /*
     * Unlink from the ensemble chain if it has not been marked as
     * having been done already.
     */

    if (ensemblePtr->next != ensemblePtr) {
	EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
	if (ensPtr == ensemblePtr) {
	    nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
	} else {
	    while (ensPtr != NULL) {
		if (ensPtr->next == ensemblePtr) {
		    ensPtr->next = ensemblePtr->next;
		    break;
		}
		ensPtr = ensPtr->next;
	    }
	}
    }

    /*
     * Mark the namespace as dead so code that uses Tcl_Preserve() can
     * tell whether disaster happened anyway.
     */

    ensemblePtr->flags |= ENS_DEAD;

    /*
     * Kill the pointer-containing fields.
     */







>



















|
|
|




|





|




















|
|
|
|
<



















|










|
|

>



|





>
















|
|
|
|
|




















|
|


















|
|







6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120

6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
		    Tcl_AppendResult(interp, "break", NULL);
		    break;
		case TCL_CONTINUE:
		    Tcl_AppendResult(interp, "continue", NULL);
		    break;
		default: {
		    char buf[TCL_INTEGER_SPACE];

		    sprintf(buf, "%d", result);
		    Tcl_AppendResult(interp, buf, NULL);
		}
		}
		Tcl_AddErrorInfo(interp,
			"\n    result of ensemble unknown subcommand handler: ");
		Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
	    } else {
		Tcl_AddErrorInfo(interp,
			"\n    (ensemble unknown subcommand handler)");
	    }
	}
	Tcl_DecrRefCount(unknownCmd);
	Tcl_Release(ensemblePtr);
	return TCL_ERROR;
    }

    /*
     * Cannot determine what subcommand to hand off to, so generate a
     * (standard) failure message. Note the one odd case compared with
     * standard ensemble-like command, which is where a namespace has no
     * exported commands at all...
     */

    Tcl_ResetResult(interp);
    if (ensemblePtr->subcommandTable.numEntries == 0) {
	Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]),
		"\": namespace ", ensemblePtr->nsPtr->fullName,
		" does not export any commands", NULL);
	return TCL_ERROR;
    }
    Tcl_AppendResult(interp, "unknown ",
	    (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
	    "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL);
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
    } else {
	int i;
	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
	    Tcl_AppendResult(interp,
		    ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
	}
	Tcl_AppendResult(interp, "or ",
		ensemblePtr->subcommandArrayPtr[i], NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeCachedEnsembleCommand --
 *
 *	Cache what we've computed so far; it's not nice to repeatedly copy
 *	strings about. Note that to do this, we start by deleting any old
 *	representation that there was (though if it was an out of date
 *	ensemble rep, we can skip some of the deallocation process.)

 *
 * Results:
 *	None
 *
 * Side effects:
 *	Alters the internal representation of the first object parameter.
 *
 *----------------------------------------------------------------------
 */
static void
MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr)
    Tcl_Obj *objPtr;
    EnsembleConfig *ensemblePtr;
    CONST char *subcommandName;
    Tcl_Obj *prefixObjPtr;
{
    register EnsembleCmdRep *ensembleCmd;
    int length;

    if (objPtr->typePtr == &ensembleCmdType) {
	ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr;
	Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
	ensembleCmd->nsPtr->refCount--;
	if ((ensembleCmd->nsPtr->refCount == 0)
		&& (ensembleCmd->nsPtr->flags & NS_DEAD)) {
	    NamespaceFree(ensembleCmd->nsPtr);
	}
	ckfree(ensembleCmd->fullSubcmdName);
    } else {
	/*
	 * Kill the old internal rep, and replace it with a brand new one of
	 * our own.
	 */

	TclFreeIntRep(objPtr);
	ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
	objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd;
	objPtr->typePtr = &ensembleCmdType;
    }

    /*
     * Populate the internal rep.
     */

    ensembleCmd->nsPtr = ensemblePtr->nsPtr;
    ensembleCmd->epoch = ensemblePtr->epoch;
    ensembleCmd->token = ensemblePtr->token;
    ensemblePtr->nsPtr->refCount++;
    ensembleCmd->realPrefixObj = prefixObjPtr;
    length = strlen(subcommandName)+1;
    ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
    memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
    Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteEnsembleConfig --
 *
 *	Destroys the data structure used to represent an ensemble. This is
 *	called when the ensemble's command is deleted (which happens
 *	automatically if the ensemble's namespace is deleted.) Maintainers
 *	should note that ensembles should be deleted by deleting their
 *	commands.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is (eventually) deallocated.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteEnsembleConfig(clientData)
    ClientData clientData;
{
    EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
    Namespace *nsPtr = ensemblePtr->nsPtr;
    Tcl_HashSearch search;
    Tcl_HashEntry *hEnt;

    /*
     * Unlink from the ensemble chain if it has not been marked as having been
     * done already.
     */

    if (ensemblePtr->next != ensemblePtr) {
	EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
	if (ensPtr == ensemblePtr) {
	    nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
	} else {
	    while (ensPtr != NULL) {
		if (ensPtr->next == ensemblePtr) {
		    ensPtr->next = ensemblePtr->next;
		    break;
		}
		ensPtr = ensPtr->next;
	    }
	}
    }

    /*
     * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
     * whether disaster happened anyway.
     */

    ensemblePtr->flags |= ENS_DEAD;

    /*
     * Kill the pointer-containing fields.
     */
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429

5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464

5465
5466
5467

5468
5469
5470
5471
5472
5473
5474
5475
5476

5477
5478
5479
5480
5481
5482

5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499

5500
5501
5502
5503
5504
5505
5506
5507

5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
	Tcl_DecrRefCount(ensemblePtr->subcommandDict);
    }
    if (ensemblePtr->unknownHandler != NULL) {
	Tcl_DecrRefCount(ensemblePtr->unknownHandler);
    }

    /*
     * Arrange for the structure to be reclaimed.  Note that this is
     * complex because we have to make sure that we can react sensibly
     * when an ensemble is deleted during the process of initialising
     * the ensemble (especially the unknown callback.)
     */

    Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC);
}

/*
 *----------------------------------------------------------------------
 *
 * BuildEnsembleConfig -- 
 *
 *	Create the internal data structures that describe how an
 *	ensemble looks, being a hash mapping from the full command
 *	name to the Tcl list that describes the implementation prefix
 *	words, and a sorted array of all the full command names to
 *	allow for reasonably efficient unambiguous prefix handling.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Reallocates and rebuilds the hash table and array stored at
 *	the ensemblePtr argument.  For large ensembles or large
 *	namespaces, this is a potentially expensive operation.
 *
 *----------------------------------------------------------------------
 */

static void
BuildEnsembleConfig(ensemblePtr)
    EnsembleConfig *ensemblePtr;
{
    Tcl_HashSearch search;		/* Used for scanning the set of
					 * commands in the namespace that
					 * backs up this ensemble. */
    int i, j, isNew;
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
    Tcl_HashEntry *hPtr;

    if (hash->numEntries != 0) {
	/*
	 * Remove pre-existing table.
	 */

	Tcl_HashSearch search;

	ckfree((char *)ensemblePtr->subcommandArrayPtr);
	hPtr = Tcl_FirstHashEntry(hash, &search);
	while (hPtr != NULL) {
	    Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
	    Tcl_DecrRefCount(prefixObj);
	    hPtr = Tcl_NextHashEntry(&search);
	}
	Tcl_DeleteHashTable(hash);
	Tcl_InitHashTable(hash, TCL_STRING_KEYS);
    }

    /*
     * See if we've got an export list.  If so, we will only export
     * exactly those commands, which may be either implemented by the
     * prefix in the subcommandDict or mapped directly onto the
     * namespace's commands.
     */

    if (ensemblePtr->subcmdList != NULL) {
	Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
	int subcmdc;

	Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
		&subcmdv);
	for (i=0 ; i<subcmdc ; i++) {
	    char *name = TclGetString(subcmdv[i]);

	    hPtr = Tcl_CreateHashEntry(hash, name, &isNew);

	    /* Skip non-unique cases. */
	    if (!isNew) {
		continue;
	    }

	    /*
	     * Look in our dictionary (if present) for the command.
	     */

	    if (ensemblePtr->subcommandDict != NULL) {
		Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
			&target);
		if (target != NULL) {
		    Tcl_SetHashValue(hPtr, (ClientData) target);
		    Tcl_IncrRefCount(target);
		    continue;
		}
	    }

	    /*
	     * Not there, so map onto the namespace.  Note in this
	     * case that we do not guarantee that the command is
	     * actually there; that is the programmer's responsibility
	     * (or [::unknown] of course).
	     */

	    cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
	    if (ensemblePtr->nsPtr->parentPtr != NULL) {
		Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
	    } else {
		Tcl_AppendStringsToObj(cmdObj, name, NULL);
	    }
	    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
	    Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj);
	    Tcl_IncrRefCount(cmdPrefixObj);
	}
    } else if (ensemblePtr->subcommandDict != NULL) {
	/*
	 * No subcmd list, but we do have a mapping dictionary so we
	 * should use the keys of that.  Convert the dictionary's
	 * contents into the form required for the ensemble's internal
	 * hashtable.
	 */

	Tcl_DictSearch dictSearch;
	Tcl_Obj *keyObj, *valueObj;
	int done;

	Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
		&keyObj, &valueObj, &done);
	while (!done) {
	    char *name = TclGetString(keyObj);

	    hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
	    Tcl_SetHashValue(hPtr, (ClientData) valueObj);
	    Tcl_IncrRefCount(valueObj);
	    Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
	}
    } else {
	/*
	 * Discover what commands are actually exported by the
	 * namespace.  What we have is an array of patterns and a hash
	 * table whose keys are the command names exported by the
	 * namespace (the contents do not matter here.)  We must find
	 * out what commands are actually exported by filtering each
	 * command in the namespace against each of the patterns in
	 * the export list.  Note that we use an intermediate hash
	 * table to make memory management easier, and because that
	 * makes exact matching far easier too.
	 *
	 * Suggestion for future enhancement: compute the unique
	 * prefixes and place them in the hash too, which should make
	 * for even faster matching.
	 */

	hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
	for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
	    char *nsCmdName =		/* Name of command in namespace. */
		    Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);

	    for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
		if (Tcl_StringMatch(nsCmdName,
			ensemblePtr->nsPtr->exportArrayPtr[i])) {
		    hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);

		    /*
		     * Remember, hash entries have a full reference to
		     * the substituted part of the command (as a list)
		     * as their content!
		     */

		    if (isNew) {
			Tcl_Obj *cmdObj, *cmdPrefixObj;

			TclNewObj(cmdObj);
			Tcl_AppendStringsToObj(cmdObj,







|
|
|
|








|

|
|
|
|
|





|
|
|








|
|
|








>














|
|
|
<

















>



>









>

|
|
<
|

>












|
|
|
<

>








>







|
|
|
<
|
|
|
|
|

|
|
|













|
|
|







6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320

6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355

6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373

6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394

6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
	Tcl_DecrRefCount(ensemblePtr->subcommandDict);
    }
    if (ensemblePtr->unknownHandler != NULL) {
	Tcl_DecrRefCount(ensemblePtr->unknownHandler);
    }

    /*
     * Arrange for the structure to be reclaimed. Note that this is complex
     * because we have to make sure that we can react sensibly when an
     * ensemble is deleted during the process of initialising the ensemble
     * (especially the unknown callback.)
     */

    Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC);
}

/*
 *----------------------------------------------------------------------
 *
 * BuildEnsembleConfig --
 *
 *	Create the internal data structures that describe how an ensemble
 *	looks, being a hash mapping from the full command name to the Tcl list
 *	that describes the implementation prefix words, and a sorted array of
 *	all the full command names to allow for reasonably efficient
 *	unambiguous prefix handling.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Reallocates and rebuilds the hash table and array stored at the
 *	ensemblePtr argument. For large ensembles or large namespaces, this is
 *	a potentially expensive operation.
 *
 *----------------------------------------------------------------------
 */

static void
BuildEnsembleConfig(ensemblePtr)
    EnsembleConfig *ensemblePtr;
{
    Tcl_HashSearch search;	/* Used for scanning the set of commands in
				 * the namespace that backs up this
				 * ensemble. */
    int i, j, isNew;
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
    Tcl_HashEntry *hPtr;

    if (hash->numEntries != 0) {
	/*
	 * Remove pre-existing table.
	 */

	Tcl_HashSearch search;

	ckfree((char *)ensemblePtr->subcommandArrayPtr);
	hPtr = Tcl_FirstHashEntry(hash, &search);
	while (hPtr != NULL) {
	    Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
	    Tcl_DecrRefCount(prefixObj);
	    hPtr = Tcl_NextHashEntry(&search);
	}
	Tcl_DeleteHashTable(hash);
	Tcl_InitHashTable(hash, TCL_STRING_KEYS);
    }

    /*
     * See if we've got an export list. If so, we will only export exactly
     * those commands, which may be either implemented by the prefix in the
     * subcommandDict or mapped directly onto the namespace's commands.

     */

    if (ensemblePtr->subcmdList != NULL) {
	Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
	int subcmdc;

	Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
		&subcmdv);
	for (i=0 ; i<subcmdc ; i++) {
	    char *name = TclGetString(subcmdv[i]);

	    hPtr = Tcl_CreateHashEntry(hash, name, &isNew);

	    /* Skip non-unique cases. */
	    if (!isNew) {
		continue;
	    }

	    /*
	     * Look in our dictionary (if present) for the command.
	     */

	    if (ensemblePtr->subcommandDict != NULL) {
		Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
			&target);
		if (target != NULL) {
		    Tcl_SetHashValue(hPtr, (ClientData) target);
		    Tcl_IncrRefCount(target);
		    continue;
		}
	    }

	    /*
	     * Not there, so map onto the namespace. Note in this case that we
	     * do not guarantee that the command is actually there; that is

	     * the programmer's responsibility (or [::unknown] of course).
	     */

	    cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
	    if (ensemblePtr->nsPtr->parentPtr != NULL) {
		Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
	    } else {
		Tcl_AppendStringsToObj(cmdObj, name, NULL);
	    }
	    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
	    Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj);
	    Tcl_IncrRefCount(cmdPrefixObj);
	}
    } else if (ensemblePtr->subcommandDict != NULL) {
	/*
	 * No subcmd list, but we do have a mapping dictionary so we should
	 * use the keys of that. Convert the dictionary's contents into the
	 * form required for the ensemble's internal hashtable.

	 */

	Tcl_DictSearch dictSearch;
	Tcl_Obj *keyObj, *valueObj;
	int done;

	Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
		&keyObj, &valueObj, &done);
	while (!done) {
	    char *name = TclGetString(keyObj);

	    hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
	    Tcl_SetHashValue(hPtr, (ClientData) valueObj);
	    Tcl_IncrRefCount(valueObj);
	    Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
	}
    } else {
	/*
	 * Discover what commands are actually exported by the namespace.
	 * What we have is an array of patterns and a hash table whose keys
	 * are the command names exported by the namespace (the contents do

	 * not matter here.) We must find out what commands are actually
	 * exported by filtering each command in the namespace against each of
	 * the patterns in the export list. Note that we use an intermediate
	 * hash table to make memory management easier, and because that makes
	 * exact matching far easier too.
	 *
	 * Suggestion for future enhancement: compute the unique prefixes and
	 * place them in the hash too, which should make for even faster
	 * matching.
	 */

	hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
	for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
	    char *nsCmdName =		/* Name of command in namespace. */
		    Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);

	    for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
		if (Tcl_StringMatch(nsCmdName,
			ensemblePtr->nsPtr->exportArrayPtr[i])) {
		    hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);

		    /*
		     * Remember, hash entries have a full reference to the
		     * substituted part of the command (as a list) as their
		     * content!
		     */

		    if (isNew) {
			Tcl_Obj *cmdObj, *cmdPrefixObj;

			TclNewObj(cmdObj);
			Tcl_AppendStringsToObj(cmdObj,
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610

    if (hash->numEntries == 0) {
	ensemblePtr->subcommandArrayPtr = NULL;
	return;
    }

    /*
     * Create a sorted array of all subcommands in the ensemble; hash
     * tables are all very well for a quick look for an exact match,
     * but they can't determine things like whether a string is a
     * prefix of another (not without lots of preparation anyway) and
     * they're no good for when we're generating the error message
     * either.
     *
     * We do this by filling an array with the names (we use the hash
     * keys directly to save a copy, since any time we change the
     * array we change the hash too, and vice versa) and running
     * quicksort over the array.
     */

    ensemblePtr->subcommandArrayPtr = (char **)
	    ckalloc(sizeof(char *) * hash->numEntries);

    /*
     * Fill array from both ends as this makes us less likely to end
     * up with performance problems in qsort(), which is good.  Note
     * that doing this makes this code much more opaque, but the naive
     * alternatve:
     *
     * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; 
     *	   hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
     *     ensemblePtr->subcommandArrayPtr[i] =
     *	       Tcl_GetHashKey(hash, &hPtr);
     * }
     *
     * can produce long runs of precisely ordered table entries when
     * the commands in the namespace are declared in a sorted fashion
     * (an ordering some people like) and the hashing functions (or
     * the command names themselves) are fairly unfortunate.  By
     * filling from both ends, it requires active malice (and probably
     * a debugger) to get qsort() to have awful runtime behaviour.
     */

    i = 0;
    j = hash->numEntries;
    hPtr = Tcl_FirstHashEntry(hash, &search);
    while (hPtr != NULL) {
	ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);







|
|
|
|
|
<

|
|
|
<






|
|
|
<

|
|
|
<


|
|
|
|
|
|







6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450

6451
6452
6453
6454

6455
6456
6457
6458
6459
6460
6461
6462
6463

6464
6465
6466
6467

6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482

    if (hash->numEntries == 0) {
	ensemblePtr->subcommandArrayPtr = NULL;
	return;
    }

    /*
     * Create a sorted array of all subcommands in the ensemble; hash tables
     * are all very well for a quick look for an exact match, but they can't
     * determine things like whether a string is a prefix of another (not
     * without lots of preparation anyway) and they're no good for when we're
     * generating the error message either.

     *
     * We do this by filling an array with the names (we use the hash keys
     * directly to save a copy, since any time we change the array we change
     * the hash too, and vice versa) and running quicksort over the array.

     */

    ensemblePtr->subcommandArrayPtr = (char **)
	    ckalloc(sizeof(char *) * hash->numEntries);

    /*
     * Fill array from both ends as this makes us less likely to end up with
     * performance problems in qsort(), which is good. Note that doing this
     * makes this code much more opaque, but the naive alternatve:

     *
     * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
     *	       hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
     *     ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);

     * }
     *
     * can produce long runs of precisely ordered table entries when the
     * commands in the namespace are declared in a sorted fashion (an ordering
     * some people like) and the hashing functions (or the command names
     * themselves) are fairly unfortunate. By filling from both ends, it
     * requires active malice (and probably a debugger) to get qsort() to have
     * awful runtime behaviour.
     */

    i = 0;
    j = hash->numEntries;
    hPtr = Tcl_FirstHashEntry(hash, &search);
    while (hPtr != NULL) {
	ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleStringOrder --
 *
 *	Helper function to compare two pointers to two strings for use
 *	with qsort().
 *
 * Results:
 *	-1 if the first string is smaller, 1 if the second string is
 *	smaller, and 0 if they are equal.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleStringOrder --
 *
 *	Helper function to compare two pointers to two strings for use with
 *	qsort().
 *
 * Results:
 *	-1 if the first string is smaller, 1 if the second string is smaller,
 *	and 0 if they are equal.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
 *	Destroys the internal representation of a Tcl_Obj that has been
 *	holding information about a command in an ensemble.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is deallocated.  If this held the last reference to a
 *	namespace's main structure, that main structure will also be
 *	destroyed.
 *
 *----------------------------------------------------------------------
 */

static void







|







6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
 *	Destroys the internal representation of a Tcl_Obj that has been
 *	holding information about a command in an ensemble.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is deallocated. If this held the last reference to a
 *	namespace's main structure, that main structure will also be
 *	destroyed.
 *
 *----------------------------------------------------------------------
 */

static void
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
}

/*
 *----------------------------------------------------------------------
 *
 * DupEnsembleCmdRep --
 *
 *	Makes one Tcl_Obj into a copy of another that is a subcommand
 *	of an ensemble.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is allocated, and the namespace that the ensemble is
 *	built on top of gains another reference.
 *
 *----------------------------------------------------------------------
 */

static void
DupEnsembleCmdRep(objPtr, copyPtr)
    Tcl_Obj *objPtr, *copyPtr;
{
    EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
	    objPtr->internalRep.otherValuePtr;
    EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
	    ckalloc(sizeof(EnsembleCmdRep));
    int length = strlen(ensembleCmd->fullSubcmdName);

    copyPtr->typePtr = &tclEnsembleCmdType;
    copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy;
    ensembleCopy->nsPtr = ensembleCmd->nsPtr;
    ensembleCopy->epoch = ensembleCmd->epoch;
    ensembleCopy->token = ensembleCmd->token;
    ensembleCopy->nsPtr->refCount++;
    ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
    Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
    ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
    memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
	    (unsigned) length+1);
}

/*
 *----------------------------------------------------------------------
 *
 * StringOfEnsembleCmdRep --
 *
 *	Creates a string representation of a Tcl_Obj that holds a
 *	subcommand of an ensemble.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object gains a string (UTF-8) representation.
 *







|
|





|
|














|

















|
|







6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
}

/*
 *----------------------------------------------------------------------
 *
 * DupEnsembleCmdRep --
 *
 *	Makes one Tcl_Obj into a copy of another that is a subcommand of an
 *	ensemble.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is allocated, and the namespace that the ensemble is built on
 *	top of gains another reference.
 *
 *----------------------------------------------------------------------
 */

static void
DupEnsembleCmdRep(objPtr, copyPtr)
    Tcl_Obj *objPtr, *copyPtr;
{
    EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
	    objPtr->internalRep.otherValuePtr;
    EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
	    ckalloc(sizeof(EnsembleCmdRep));
    int length = strlen(ensembleCmd->fullSubcmdName);

    copyPtr->typePtr = &ensembleCmdType;
    copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy;
    ensembleCopy->nsPtr = ensembleCmd->nsPtr;
    ensembleCopy->epoch = ensembleCmd->epoch;
    ensembleCopy->token = ensembleCmd->token;
    ensembleCopy->nsPtr->refCount++;
    ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
    Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
    ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
    memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
	    (unsigned) length+1);
}

/*
 *----------------------------------------------------------------------
 *
 * StringOfEnsembleCmdRep --
 *
 *	Creates a string representation of a Tcl_Obj that holds a subcommand
 *	of an ensemble.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object gains a string (UTF-8) representation.
 *
5748
5749
5750
5751
5752
5753
5754








	    objPtr->internalRep.otherValuePtr;
    int length = strlen(ensembleCmd->fullSubcmdName);

    objPtr->length = length;
    objPtr->bytes = ckalloc((unsigned) length+1);
    memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
}















>
>
>
>
>
>
>
>
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
	    objPtr->internalRep.otherValuePtr;
    int length = strlen(ensembleCmd->fullSubcmdName);

    objPtr->length = length;
    objPtr->bytes = ckalloc((unsigned) length+1);
    memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclNotify.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
/* 
 * tclNotify.c --
 *
 *	This file implements the generic portion of the Tcl notifier.
 *	The notifier is lowest-level part of the event system.  It
 *	manages an event queue that holds Tcl_Event structures.  The
 *	platform specific portion of the notifier is defined in the
 *	tcl*Notify.c files in each platform directory.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNotify.c,v 1.16 2004/11/30 19:34:49 dgp Exp $
 */

#include "tclInt.h"

extern TclStubs tclStubs;

/*
 * For each event source (created with Tcl_CreateEventSource) there
 * is a structure of the following type:
 */

typedef struct EventSource {
    Tcl_EventSetupProc *setupProc;
    Tcl_EventCheckProc *checkProc;
    ClientData clientData;
    struct EventSource *nextPtr;
} EventSource;

/*
 * The following structure keeps track of the state of the notifier on a
 * per-thread basis. The first three elements keep track of the event queue.
 * In addition to the first (next to be serviced) and last events in the queue,
 * we keep track of a "marker" event.  This provides a simple priority
 * mechanism whereby events can be inserted at the front of the queue but
 * behind all other high-priority events already in the queue (this is used for
 * things like a sequence of Enter and Leave events generated during a grab in
 * Tk).  These elements are protected by the queueMutex so that any thread
 * can queue an event on any notifier.  Note that all of the values in this
 * structure will be initialized to 0.
 */

typedef struct ThreadSpecificData {
    Tcl_Event *firstEventPtr;	/* First pending event, or NULL if none. */
    Tcl_Event *lastEventPtr;	/* Last pending event, or NULL if none. */
    Tcl_Event *markerEventPtr;	/* Last high-priority event in queue, or
				 * NULL if none. */
    Tcl_Mutex queueMutex;	/* Mutex to protect access to the previous
				 * three fields. */
    int serviceMode;		/* One of TCL_SERVICE_NONE or
				 * TCL_SERVICE_ALL. */
    int blockTimeSet;		/* 0 means there is no maximum block
				 * time:  block forever. */
    Tcl_Time blockTime;		/* If blockTimeSet is 1, gives the
				 * maximum elapsed time for the next block. */
    int inTraversal;		/* 1 if Tcl_SetMaxBlockTime is being
				 * called during an event source traversal. */
    EventSource *firstEventSourcePtr;
				/* Pointer to first event source in
				 * list of event sources for this thread. */
    Tcl_ThreadId threadId;	/* Thread that owns this notifier instance. */
    ClientData clientData;	/* Opaque handle for platform specific
				 * notifier. */

    struct ThreadSpecificData *nextPtr;
				/* Next notifier in global list of notifiers.
				 * Access is controlled by the listLock global
				 * mutex. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Global list of notifiers.  Access to this list is controlled by the
 * listLock mutex.  If this becomes a performance bottleneck, this could
 * be replaced with a hashtable.
 */

static ThreadSpecificData *firstNotifierPtr = NULL;
TCL_DECLARE_MUTEX(listLock)

/*
 * Declarations for routines used only in this file.
|


|
|
|
|
|





|
|

|







|
|












|
|

|
|
|
|
|





|
|




|
|
|
|
|
|

|
|



>









|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
/*
 * tclNotify.c --
 *
 *	This file implements the generic portion of the Tcl notifier. The
 *	notifier is lowest-level part of the event system. It manages an event
 *	queue that holds Tcl_Event structures. The platform specific portion
 *	of the notifier is defined in the tcl*Notify.c files in each platform
 *	directory.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNotify.c,v 1.16.2.2 2005/08/02 18:16:02 dgp Exp $
 */

#include "tclInt.h"

extern TclStubs tclStubs;

/*
 * For each event source (created with Tcl_CreateEventSource) there is a
 * structure of the following type:
 */

typedef struct EventSource {
    Tcl_EventSetupProc *setupProc;
    Tcl_EventCheckProc *checkProc;
    ClientData clientData;
    struct EventSource *nextPtr;
} EventSource;

/*
 * The following structure keeps track of the state of the notifier on a
 * per-thread basis. The first three elements keep track of the event queue.
 * In addition to the first (next to be serviced) and last events in the
 * queue, we keep track of a "marker" event. This provides a simple priority
 * mechanism whereby events can be inserted at the front of the queue but
 * behind all other high-priority events already in the queue (this is used
 * for things like a sequence of Enter and Leave events generated during a
 * grab in Tk). These elements are protected by the queueMutex so that any
 * thread can queue an event on any notifier. Note that all of the values in
 * this structure will be initialized to 0.
 */

typedef struct ThreadSpecificData {
    Tcl_Event *firstEventPtr;	/* First pending event, or NULL if none. */
    Tcl_Event *lastEventPtr;	/* Last pending event, or NULL if none. */
    Tcl_Event *markerEventPtr;	/* Last high-priority event in queue, or NULL
				 * if none. */
    Tcl_Mutex queueMutex;	/* Mutex to protect access to the previous
				 * three fields. */
    int serviceMode;		/* One of TCL_SERVICE_NONE or
				 * TCL_SERVICE_ALL. */
    int blockTimeSet;		/* 0 means there is no maximum block time:
				 * block forever. */
    Tcl_Time blockTime;		/* If blockTimeSet is 1, gives the maximum
				 * elapsed time for the next block. */
    int inTraversal;		/* 1 if Tcl_SetMaxBlockTime is being called
				 * during an event source traversal. */
    EventSource *firstEventSourcePtr;
				/* Pointer to first event source in list of
				 * event sources for this thread. */
    Tcl_ThreadId threadId;	/* Thread that owns this notifier instance. */
    ClientData clientData;	/* Opaque handle for platform specific
				 * notifier. */
    int initialized;		/* 1 if notifier has been initialized. */
    struct ThreadSpecificData *nextPtr;
				/* Next notifier in global list of notifiers.
				 * Access is controlled by the listLock global
				 * mutex. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Global list of notifiers. Access to this list is controlled by the listLock
 * mutex. If this becomes a performance bottleneck, this could be replaced
 * with a hashtable.
 */

static ThreadSpecificData *firstNotifierPtr = NULL;
TCL_DECLARE_MUTEX(listLock)

/*
 * Declarations for routines used only in this file.
112
113
114
115
116
117
118
119
120
121

122

123


124
125
126

127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
TclInitNotifier()
{
    ThreadSpecificData *tsdPtr;
    Tcl_ThreadId threadId = Tcl_GetCurrentThread();

    Tcl_MutexLock(&listLock);
    for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
	     tsdPtr = tsdPtr->nextPtr) {
	/* Empty loop body. */
    }

    if (NULL == tsdPtr) {

	/* Notifier not yet initialized in this thread */


	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->threadId = threadId;
	tsdPtr->clientData = tclStubs.tcl_InitNotifier();

	tsdPtr->nextPtr = firstNotifierPtr;
	firstNotifierPtr = tsdPtr;
    }
    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeNotifier --
 *
 *	Finalize the thread local data structures for the notifier
 *	subsystem.
 *
 * Results:
 *	None.	
 *
 * Side effects:
 *	Removes the notifier associated with the current thread from
 *	the global notifier list. This is done only if the notifier
 *	was initialized for this thread by call to TclInitNotifier().
 *	This is always true for threads which have been seeded with
 * 	an Tcl interpreter, since the call to Tcl_CreateInterp will,
 * 	among other things, call TclInitializeSubsystems() and this
 *	one will, in turn, call the TclInitNotifier() for the thread.
 *	For threads created without the Tcl interpreter, though,
 *	nobody is explicitly nor implicitly calling the TclInitNotifier 
 *	hence, TclFinalizeNotifier should not be performed at all.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadSpecificData **prevPtrPtr;
    Tcl_Event *evPtr, *hold;

    if (tsdPtr->threadId == (Tcl_ThreadId)0) {
        return; /* Notifier not initialized for the current thread */
    }

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) {
	hold = evPtr;
	evPtr = evPtr->nextPtr;
	ckfree((char *) hold);
    }
    tsdPtr->firstEventPtr = NULL;
    tsdPtr->lastEventPtr = NULL;
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));

    Tcl_MutexLock(&listLock);

    if (tclStubs.tcl_FinalizeNotifier) {
	tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
    }
    Tcl_MutexFinalize(&(tsdPtr->queueMutex));
    for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
	 prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
	if (*prevPtrPtr == tsdPtr) {
	    *prevPtrPtr = tsdPtr->nextPtr;
	    break;
	}
    }


    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetNotifier --
 *
 *	Install a set of alternate functions for use with the notifier.
 #	In particular, this can be used to install the Xt-based
 *	notifier for use with the Browser plugin.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Overstomps part of the stub vector.  This relies on hooks
 *	added to the default procedures in case those are called
 *	directly (i.e., not through the stub table.)
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetNotifier(notifierProcPtr)
    Tcl_NotifierProcs *notifierProcPtr;







|


>

>
|
>
>



>











|
<


|


|
|
|
|
|
|
|
|
|
|











|
|



















|





>









|
|
|





|
|
|







113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
TclInitNotifier()
{
    ThreadSpecificData *tsdPtr;
    Tcl_ThreadId threadId = Tcl_GetCurrentThread();

    Tcl_MutexLock(&listLock);
    for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
	    tsdPtr = tsdPtr->nextPtr) {
	/* Empty loop body. */
    }

    if (NULL == tsdPtr) {
	/*
	 * Notifier not yet initialized in this thread.
	 */

	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->threadId = threadId;
	tsdPtr->clientData = tclStubs.tcl_InitNotifier();
	tsdPtr->initialized = 1;
	tsdPtr->nextPtr = firstNotifierPtr;
	firstNotifierPtr = tsdPtr;
    }
    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeNotifier --
 *
 *	Finalize the thread local data structures for the notifier subsystem.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the notifier associated with the current thread from the
 *	global notifier list. This is done only if the notifier was
 *	initialized for this thread by call to TclInitNotifier(). This is
 *	always true for threads which have been seeded with an Tcl
 *	interpreter, since the call to Tcl_CreateInterp will, among other
 *	things, call TclInitializeSubsystems() and this one will, in turn,
 *	call the TclInitNotifier() for the thread. For threads created without
 *	the Tcl interpreter, though, nobody is explicitly nor implicitly
 *	calling the TclInitNotifier hence, TclFinalizeNotifier should not be
 *	performed at all.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadSpecificData **prevPtrPtr;
    Tcl_Event *evPtr, *hold;

    if (!tsdPtr->initialized) {
	return;		/* Notifier not initialized for the current thread */
    }

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) {
	hold = evPtr;
	evPtr = evPtr->nextPtr;
	ckfree((char *) hold);
    }
    tsdPtr->firstEventPtr = NULL;
    tsdPtr->lastEventPtr = NULL;
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));

    Tcl_MutexLock(&listLock);

    if (tclStubs.tcl_FinalizeNotifier) {
	tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
    }
    Tcl_MutexFinalize(&(tsdPtr->queueMutex));
    for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
	    prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
	if (*prevPtrPtr == tsdPtr) {
	    *prevPtrPtr = tsdPtr->nextPtr;
	    break;
	}
    }
    tsdPtr->initialized = 0;

    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetNotifier --
 *
 *	Install a set of alternate functions for use with the notifier. In
 *	particular, this can be used to install the Xt-based notifier for use
 *	with the Browser plugin.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Overstomps part of the stub vector. This relies on hooks added to the
 *	default functions in case those are called directly (i.e., not through
 *	the stub table.)
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetNotifier(notifierProcPtr)
    Tcl_NotifierProcs *notifierProcPtr;
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

272
273

274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309

310
311

312
313
314
315
316
317
318
319
320
321
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateEventSource --
 *
 *	This procedure is invoked to create a new source of events.
 *	The source is identified by a procedure that gets invoked
 *	during Tcl_DoOneEvent to check for events on that source
 *	and queue them.
 *
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent
 *	runs out of things to do.  SetupProc will be invoked before
 *	Tcl_DoOneEvent calls select or whatever else it uses to wait
 *	for events.  SetupProc typically calls functions like
 *	Tcl_SetMaxBlockTime to indicate what to wait for.
 *
 *	CheckProc is called after select or whatever operation was actually
 *	used to wait.  It figures out whether anything interesting actually
 *	happened (e.g. by calling Tcl_AsyncReady), and then calls
 *	Tcl_QueueEvent to queue any events that are ready.
 *
 *	Each of these procedures is passed two arguments, e.g.
 *		(*checkProc)(ClientData clientData, int flags));
 *	ClientData is the same as the clientData argument here, and flags
 *	is a combination of things like TCL_FILE_EVENTS that indicates
 *	what events are of interest:  setupProc and checkProc use flags
 *	to figure out whether their events are relevant or not.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateEventSource(setupProc, checkProc, clientData)
    Tcl_EventSetupProc *setupProc;	/* Procedure to invoke to figure out

					 * what to wait for. */
    Tcl_EventCheckProc *checkProc;	/* Procedure to call after waiting

					 * to see what happened. */
    ClientData clientData;		/* One-word argument to pass to
					 * setupProc and checkProc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));

    sourcePtr->setupProc = setupProc;
    sourcePtr->checkProc = checkProc;
    sourcePtr->clientData = clientData;
    sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
    tsdPtr->firstEventSourcePtr = sourcePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteEventSource --
 *
 *	This procedure is invoked to delete the source of events
 *	given by proc and clientData.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The given event source is cancelled, so its procedure will
 *	never again be called.  If no such source exists, nothing
 *	happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteEventSource(setupProc, checkProc, clientData)
    Tcl_EventSetupProc *setupProc;	/* Procedure to invoke to figure out

					 * what to wait for. */
    Tcl_EventCheckProc *checkProc;	/* Procedure to call after waiting

					 * to see what happened. */
    ClientData clientData;		/* One-word argument to pass to
					 * setupProc and checkProc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    EventSource *sourcePtr, *prevPtr;

    for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL;
	    sourcePtr != NULL;
	    prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) {







|
|
|
<







|
|
|
|


|



|

|
|
|
|






|
>
|
|
>
|
|
|
















|
|





|
|
<






|
>
|
|
>
|
|
|







237
238
239
240
241
242
243
244
245
246

247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateEventSource --
 *
 *	This function is invoked to create a new source of events. The source
 *	is identified by a function that gets invoked during Tcl_DoOneEvent to
 *	check for events on that source and queue them.

 *
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent
 *	runs out of things to do. SetupProc will be invoked before
 *	Tcl_DoOneEvent calls select or whatever else it uses to wait for
 *	events. SetupProc typically calls functions like Tcl_SetMaxBlockTime
 *	to indicate what to wait for.
 *
 *	CheckProc is called after select or whatever operation was actually
 *	used to wait. It figures out whether anything interesting actually
 *	happened (e.g. by calling Tcl_AsyncReady), and then calls
 *	Tcl_QueueEvent to queue any events that are ready.
 *
 *	Each of these functions is passed two arguments, e.g.
 *		(*checkProc)(ClientData clientData, int flags));
 *	ClientData is the same as the clientData argument here, and flags is a
 *	combination of things like TCL_FILE_EVENTS that indicates what events
 *	are of interest: setupProc and checkProc use flags to figure out
 *	whether their events are relevant or not.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateEventSource(setupProc, checkProc, clientData)
    Tcl_EventSetupProc *setupProc;
				/* Function to invoke to figure out what to
				 * wait for. */
    Tcl_EventCheckProc *checkProc;
				/* Function to call after waiting to see what
				 * happened. */
    ClientData clientData;	/* One-word argument to pass to setupProc and
				 * checkProc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));

    sourcePtr->setupProc = setupProc;
    sourcePtr->checkProc = checkProc;
    sourcePtr->clientData = clientData;
    sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
    tsdPtr->firstEventSourcePtr = sourcePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteEventSource --
 *
 *	This function is invoked to delete the source of events given by proc
 *	and clientData.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The given event source is cancelled, so its function will never again
 *	be called. If no such source exists, nothing happens.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteEventSource(setupProc, checkProc, clientData)
    Tcl_EventSetupProc *setupProc;
				/* Function to invoke to figure out what to
				 * wait for. */
    Tcl_EventCheckProc *checkProc;
				/* Function to call after waiting to see what
				 * happened. */
    ClientData clientData;	/* One-word argument to pass to setupProc and
				 * checkProc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    EventSource *sourcePtr, *prevPtr;

    for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL;
	    sourcePtr != NULL;
	    prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) {
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_QueueEvent --
 *
 *	Queue an event on the event queue associated with the
 *	current thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_QueueEvent(evPtr, position)
    Tcl_Event* evPtr;		/* Event to add to queue.  The storage
				 * space must have been allocated the caller
				 * with malloc (ckalloc), and it becomes
				 * the property of the event queue.  It
				 * will be freed after the event has been
				 * handled. */
    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
				 * TCL_QUEUE_MARK. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    QueueEvent(tsdPtr, evPtr, position);
}








|
<












|
|
|
|
|
<







343
344
345
346
347
348
349
350

351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367

368
369
370
371
372
373
374
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_QueueEvent --
 *
 *	Queue an event on the event queue associated with the current thread.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_QueueEvent(evPtr, position)
    Tcl_Event* evPtr;		/* Event to add to queue. The storage space
				 * must have been allocated the caller with
				 * malloc (ckalloc), and it becomes the
				 * property of the event queue. It will be
				 * freed after the event has been handled. */

    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
				 * TCL_QUEUE_MARK. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    QueueEvent(tsdPtr, evPtr, position);
}

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ThreadQueueEvent(threadId, evPtr, position)
    Tcl_ThreadId threadId;	/* Identifier for thread to use. */
    Tcl_Event* evPtr;		/* Event to add to queue.  The storage
				 * space must have been allocated the caller
				 * with malloc (ckalloc), and it becomes
				 * the property of the event queue.  It
				 * will be freed after the event has been
				 * handled. */
    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
				 * TCL_QUEUE_MARK. */
{
    ThreadSpecificData *tsdPtr;

    /*
     * Find the notifier associated with the specified thread.
     */

    Tcl_MutexLock(&listLock);
    for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
	     tsdPtr = tsdPtr->nextPtr) {
	/* Empty loop body. */
    }

    /*
     * Queue the event if there was a notifier associated with the thread.
     */

    if (tsdPtr) {
	QueueEvent(tsdPtr, evPtr, position);
    }
    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
 * QueueEvent --
 *
 *	Insert an event into the specified thread's event queue at one
 *	of three positions: the head, the tail, or before a floating
 *	marker. Events inserted before the marker will be processed in
 *	first-in-first-out order, but before any events inserted at
 *	the tail of the queue.  Events inserted at the head of the
 *	queue will be processed in last-in-first-out order.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
QueueEvent(tsdPtr, evPtr, position)
    ThreadSpecificData *tsdPtr;	/* Handle to thread local data that indicates
				 * which event queue to use. */
    Tcl_Event* evPtr;		/* Event to add to queue.  The storage
				 * space must have been allocated the caller
				 * with malloc (ckalloc), and it becomes
				 * the property of the event queue.  It
				 * will be freed after the event has been
				 * handled. */
    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
				 * TCL_QUEUE_MARK. */
{
    Tcl_MutexLock(&(tsdPtr->queueMutex));
    if (position == TCL_QUEUE_TAIL) {
	/*
	 * Append the event on the end of the queue.







|
|
|
|
|
<











|


















|
|
|
|
|
|














|
|
|
|
|
<







387
388
389
390
391
392
393
394
395
396
397
398

399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

454
455
456
457
458
459
460
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ThreadQueueEvent(threadId, evPtr, position)
    Tcl_ThreadId threadId;	/* Identifier for thread to use. */
    Tcl_Event* evPtr;		/* Event to add to queue. The storage space
				 * must have been allocated the caller with
				 * malloc (ckalloc), and it becomes the
				 * property of the event queue. It will be
				 * freed after the event has been handled. */

    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
				 * TCL_QUEUE_MARK. */
{
    ThreadSpecificData *tsdPtr;

    /*
     * Find the notifier associated with the specified thread.
     */

    Tcl_MutexLock(&listLock);
    for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
	    tsdPtr = tsdPtr->nextPtr) {
	/* Empty loop body. */
    }

    /*
     * Queue the event if there was a notifier associated with the thread.
     */

    if (tsdPtr) {
	QueueEvent(tsdPtr, evPtr, position);
    }
    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
 * QueueEvent --
 *
 *	Insert an event into the specified thread's event queue at one of
 *	three positions: the head, the tail, or before a floating marker.
 *	Events inserted before the marker will be processed in first-in-
 *	first-out order, but before any events inserted at the tail of the
 *	queue. Events inserted at the head of the queue will be processed in
 *	last-in-first-out order.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
QueueEvent(tsdPtr, evPtr, position)
    ThreadSpecificData *tsdPtr;	/* Handle to thread local data that indicates
				 * which event queue to use. */
    Tcl_Event* evPtr;		/* Event to add to queue.  The storage space
				 * must have been allocated the caller with
				 * malloc (ckalloc), and it becomes the
				 * property of the event queue. It will be
				 * freed after the event has been handled. */

    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
				 * TCL_QUEUE_MARK. */
{
    Tcl_MutexLock(&(tsdPtr->queueMutex));
    if (position == TCL_QUEUE_TAIL) {
	/*
	 * Append the event on the end of the queue.
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
	/*
	 * Push the event on the head of the queue.
	 */

	evPtr->nextPtr = tsdPtr->firstEventPtr;
	if (tsdPtr->firstEventPtr == NULL) {
	    tsdPtr->lastEventPtr = evPtr;
	}	    
	tsdPtr->firstEventPtr = evPtr;
    } else if (position == TCL_QUEUE_MARK) {
	/*
	 * Insert the event after the current marker event and advance
	 * the marker to the new event.
	 */

	if (tsdPtr->markerEventPtr == NULL) {
	    evPtr->nextPtr = tsdPtr->firstEventPtr;
	    tsdPtr->firstEventPtr = evPtr;
	} else {
	    evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr;







|



|
|







471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
	/*
	 * Push the event on the head of the queue.
	 */

	evPtr->nextPtr = tsdPtr->firstEventPtr;
	if (tsdPtr->firstEventPtr == NULL) {
	    tsdPtr->lastEventPtr = evPtr;
	}
	tsdPtr->firstEventPtr = evPtr;
    } else if (position == TCL_QUEUE_MARK) {
	/*
	 * Insert the event after the current marker event and advance the
	 * marker to the new event.
	 */

	if (tsdPtr->markerEventPtr == NULL) {
	    evPtr->nextPtr = tsdPtr->firstEventPtr;
	    tsdPtr->firstEventPtr = evPtr;
	} else {
	    evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr;
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteEvents --
 *
 *	Calls a procedure for each event in the queue and deletes those
 *	for which the procedure returns 1. Events for which the
 *	procedure returns 0 are left in the queue.  Operates on the
 *	queue associated with the current thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Potentially removes one or more events from the event queue.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteEvents(proc, clientData)
    Tcl_EventDeleteProc *proc;		/* The procedure to call. */
    ClientData clientData;    		/* type-specific data. */
{
    Tcl_Event *evPtr, *prevPtr, *hold;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr;
             evPtr != (Tcl_Event *) NULL;
             ) {
        if ((*proc) (evPtr, clientData) == 1) {
            if (tsdPtr->firstEventPtr == evPtr) {
                tsdPtr->firstEventPtr = evPtr->nextPtr;
            } else {
                prevPtr->nextPtr = evPtr->nextPtr;
            }
            if (evPtr->nextPtr == (Tcl_Event *) NULL) {
                tsdPtr->lastEventPtr = prevPtr;
            }
            if (tsdPtr->markerEventPtr == evPtr) {
                tsdPtr->markerEventPtr = prevPtr;
            }
            hold = evPtr;
            evPtr = evPtr->nextPtr;
            ckfree((char *) hold);
        } else {
            prevPtr = evPtr;
            evPtr = evPtr->nextPtr;
        }
    }
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceEvent --
 *
 *	Process one event from the event queue, or invoke an
 *	asynchronous event handler.  Operates on event queue for
 *	current thread.
 *
 * Results:
 *	The return value is 1 if the procedure actually found an event
 *	to process.  If no processing occurred, then 0 is returned.
 *
 * Side effects:
 *	Invokes all of the event handlers for the highest priority
 *	event in the event queue.  May collapse some events into a
 *	single event or discard stale events.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ServiceEvent(flags)
    int flags;			/* Indicates what events should be processed.
				 * May be any combination of TCL_WINDOW_EVENTS
				 * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other
				 * flags defined elsewhere.  Events not
				 * matching this will be skipped for processing
				 * later. */
{
    Tcl_Event *evPtr, *prevPtr;
    Tcl_EventProc *proc;
    int result;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Asynchronous event handlers are considered to be the highest
     * priority events, and so must be invoked before we process events
     * on the event queue.
     */
    
    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
	return 1;
    }

    /*
     * No event flags is equivalent to TCL_ALL_EVENTS.
     */
    
    if ((flags & TCL_ALL_EVENTS) == 0) {
	flags |= TCL_ALL_EVENTS;
    }

    /*
     * Loop through all the events in the queue until we find one
     * that can actually be handled.
     */

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL;
	 evPtr = evPtr->nextPtr) {
	/*
	 * Call the handler for the event.  If it actually handles the
	 * event then free the storage for the event.  There are two
	 * tricky things here, both stemming from the fact that the event
	 * code may be re-entered while servicing the event:
	 *
	 * 1. Set the "proc" field to NULL.  This is a signal to ourselves
	 *    that we shouldn't reexecute the handler if the event loop
	 *    is re-entered.
	 * 2. When freeing the event, must search the queue again from the
	 *    front to find it.  This is because the event queue could
	 *    change almost arbitrarily while handling the event, so we
	 *    can't depend on pointers found now still being valid when
	 *    the handler returns.
	 */

	proc = evPtr->proc;
	if (proc == NULL) {
	    continue;
	}
	evPtr->proc = NULL;

	/*
	 * Release the lock before calling the event procedure.  This
	 * allows other threads to post events if we enter a recursive
	 * event loop in this thread.  Note that we are making the assumption
	 * that if the proc returns 0, the event is still in the list.
	 */

	Tcl_MutexUnlock(&(tsdPtr->queueMutex));
	result = (*proc)(evPtr, flags);
	Tcl_MutexLock(&(tsdPtr->queueMutex));

	if (result) {







|
|
|
|












|
|






|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|









|
|
<


|
|


|
|
|









|
|
|







|
|
|

|








|





|
|




|

|
|
|
|


|
|

|
|
|
|









|
|
|
|







499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530

531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteEvents --
 *
 *	Calls a function for each event in the queue and deletes those for
 *	which the function returns 1. Events for which the function returns 0
 *	are left in the queue. Operates on the queue associated with the
 *	current thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Potentially removes one or more events from the event queue.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteEvents(proc, clientData)
    Tcl_EventDeleteProc *proc;	/* The function to call. */
    ClientData clientData;    	/* The type-specific data. */
{
    Tcl_Event *evPtr, *prevPtr, *hold;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr;
	    evPtr != (Tcl_Event *) NULL; /*EMPTY STEP*/) {

	if ((*proc) (evPtr, clientData) == 1) {
	    if (tsdPtr->firstEventPtr == evPtr) {
		tsdPtr->firstEventPtr = evPtr->nextPtr;
	    } else {
		prevPtr->nextPtr = evPtr->nextPtr;
	    }
	    if (evPtr->nextPtr == (Tcl_Event *) NULL) {
		tsdPtr->lastEventPtr = prevPtr;
	    }
	    if (tsdPtr->markerEventPtr == evPtr) {
		tsdPtr->markerEventPtr = prevPtr;
	    }
	    hold = evPtr;
	    evPtr = evPtr->nextPtr;
	    ckfree((char *) hold);
	} else {
	    prevPtr = evPtr;
	    evPtr = evPtr->nextPtr;
	}
    }
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceEvent --
 *
 *	Process one event from the event queue, or invoke an asynchronous
 *	event handler. Operates on event queue for current thread.

 *
 * Results:
 *	The return value is 1 if the function actually found an event to
 *	process. If no processing occurred, then 0 is returned.
 *
 * Side effects:
 *	Invokes all of the event handlers for the highest priority event in
 *	the event queue. May collapse some events into a single event or
 *	discard stale events.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ServiceEvent(flags)
    int flags;			/* Indicates what events should be processed.
				 * May be any combination of TCL_WINDOW_EVENTS
				 * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other
				 * flags defined elsewhere. Events not
				 * matching this will be skipped for
				 * processing later. */
{
    Tcl_Event *evPtr, *prevPtr;
    Tcl_EventProc *proc;
    int result;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Asynchronous event handlers are considered to be the highest priority
     * events, and so must be invoked before we process events on the event
     * queue.
     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
	return 1;
    }

    /*
     * No event flags is equivalent to TCL_ALL_EVENTS.
     */

    if ((flags & TCL_ALL_EVENTS) == 0) {
	flags |= TCL_ALL_EVENTS;
    }

    /*
     * Loop through all the events in the queue until we find one that can
     * actually be handled.
     */

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL;
	    evPtr = evPtr->nextPtr) {
	/*
	 * Call the handler for the event. If it actually handles the event
	 * then free the storage for the event. There are two tricky things
	 * here, both stemming from the fact that the event code may be
	 * re-entered while servicing the event:
	 *
	 * 1. Set the "proc" field to NULL.  This is a signal to ourselves
	 *    that we shouldn't reexecute the handler if the event loop is
	 *    re-entered.
	 * 2. When freeing the event, must search the queue again from the
	 *    front to find it. This is because the event queue could change
	 *    almost arbitrarily while handling the event, so we can't depend
	 *    on pointers found now still being valid when the handler
	 *    returns.
	 */

	proc = evPtr->proc;
	if (proc == NULL) {
	    continue;
	}
	evPtr->proc = NULL;

	/*
	 * Release the lock before calling the event function. This allows
	 * other threads to post events if we enter a recursive event loop in
	 * this thread. Note that we are making the assumption that if the
	 * proc returns 0, the event is still in the list.
	 */

	Tcl_MutexUnlock(&(tsdPtr->queueMutex));
	result = (*proc)(evPtr, flags);
	Tcl_MutexLock(&(tsdPtr->queueMutex));

	if (result) {
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
		    tsdPtr->lastEventPtr = NULL;
		}
		if (tsdPtr->markerEventPtr == evPtr) {
		    tsdPtr->markerEventPtr = NULL;
		}
	    } else {
		for (prevPtr = tsdPtr->firstEventPtr;
		     prevPtr && prevPtr->nextPtr != evPtr;
		     prevPtr = prevPtr->nextPtr) {
		    /* Empty loop body. */
		}
		if (prevPtr) {
		    prevPtr->nextPtr = evPtr->nextPtr;
		    if (evPtr->nextPtr == NULL) {
			tsdPtr->lastEventPtr = prevPtr;
		    }







|
|







656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
		    tsdPtr->lastEventPtr = NULL;
		}
		if (tsdPtr->markerEventPtr == evPtr) {
		    tsdPtr->markerEventPtr = NULL;
		}
	    } else {
		for (prevPtr = tsdPtr->firstEventPtr;
			prevPtr && prevPtr->nextPtr != evPtr;
			prevPtr = prevPtr->nextPtr) {
		    /* Empty loop body. */
		}
		if (prevPtr) {
		    prevPtr->nextPtr = evPtr->nextPtr;
		    if (evPtr->nextPtr == NULL) {
			tsdPtr->lastEventPtr = prevPtr;
		    }
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
	    if (evPtr) {
		ckfree((char *) evPtr);
	    }
	    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
	    return 1;
	} else {
	    /*
	     * The event wasn't actually handled, so we have to restore
	     * the proc field to allow the event to be attempted again.
	     */

	    evPtr->proc = proc;
	}
    }
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
    return 0;







|
|







679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
	    if (evPtr) {
		ckfree((char *) evPtr);
	    }
	    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
	    return 1;
	} else {
	    /*
	     * The event wasn't actually handled, so we have to restore the
	     * proc field to allow the event to be attempted again.
	     */

	    evPtr->proc = proc;
	}
    }
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
    return 0;
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
 *
 *	This routine sets the current service mode of the tsdPtr->
 *
 * Results:
 *	Returns the previous service mode.
 *
 * Side effects:
 *	Invokes the notifier service mode hook procedure.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetServiceMode(mode)
    int mode;			/* New service mode: TCL_SERVICE_ALL or







|







725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
 *
 *	This routine sets the current service mode of the tsdPtr->
 *
 * Results:
 *	Returns the previous service mode.
 *
 * Side effects:
 *	Invokes the notifier service mode hook function.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetServiceMode(mode)
    int mode;			/* New service mode: TCL_SERVICE_ALL or
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetMaxBlockTime --
 *
 *	This procedure is invoked by event sources to tell the notifier
 *	how long it may block the next time it blocks.  The timePtr
 *	argument gives a maximum time;  the actual time may be less if
 *	some other event source requested a smaller time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May reduce the length of the next sleep in the tsdPtr->
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetMaxBlockTime(timePtr)
    Tcl_Time *timePtr;		/* Specifies a maximum elapsed time for
				 * the next blocking operation in the
				 * event tsdPtr-> */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec)
	    || ((timePtr->sec == tsdPtr->blockTime.sec)
	    && (timePtr->usec < tsdPtr->blockTime.usec))) {
	tsdPtr->blockTime = *timePtr;
	tsdPtr->blockTimeSet = 1;
    }

    /*
     * If we are called outside an event source traversal, set the
     * timeout immediately.
     */

    if (!tsdPtr->inTraversal) {
	if (tsdPtr->blockTimeSet) {
	    Tcl_SetTimer(&tsdPtr->blockTime);
	} else {
	    Tcl_SetTimer(NULL);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DoOneEvent --
 *
 *	Process a single event of some sort.  If there's no work to
 *	do, wait for an event to occur, then process it.
 *
 * Results:
 *	The return value is 1 if the procedure actually found an event
 *	to process.  If no processing occurred, then 0 is returned (this
 *	can happen if the TCL_DONT_WAIT flag is set or if there are no
 *	event handlers to wait for in the set specified by flags).
 *
 * Side effects:
 *	May delay execution of process while waiting for an event,
 *	unless TCL_DONT_WAIT is set in the flags argument.  Event
 *	sources are invoked to check for and queue events.  Event
 *	handlers may produce arbitrary side effects.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DoOneEvent(flags)
    int flags;			/* Miscellaneous flag values:  may be any
				 * combination of TCL_DONT_WAIT,
				 * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS,
				 * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or
				 * others defined by event sources. */
{
    int result = 0, oldMode;
    EventSource *sourcePtr;
    Tcl_Time *timePtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * The first thing we do is to service any asynchronous event
     * handlers.
     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
	return 1;
    }

    /*
     * No event flags is equivalent to TCL_ALL_EVENTS.
     */

    if ((flags & TCL_ALL_EVENTS) == 0) {
	flags |= TCL_ALL_EVENTS;
    }

    /*
     * Set the service mode to none so notifier event routines won't
     * try to service events recursively.
     */

    oldMode = tsdPtr->serviceMode;
    tsdPtr->serviceMode = TCL_SERVICE_NONE;

    /*
     * The core of this procedure is an infinite loop, even though
     * we only service one event.  The reason for this is that we
     * may be processing events that don't do anything inside of Tcl.
     */

    while (1) {

	/*
	 * If idle events are the only things to service, skip the
	 * main part of the loop and go directly to handle idle
	 * events (i.e. don't wait even if TCL_DONT_WAIT isn't set).
	 */

	if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) {
	    flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
	    goto idleEvents;
	}

	/*
	 * Ask Tcl to service a queued event, if there are any.
	 */

	if (Tcl_ServiceEvent(flags)) {
	    result = 1;
	    break;
	}

	/*
	 * If TCL_DONT_WAIT is set, be sure to poll rather than
	 * blocking, otherwise reset the block time to infinity.
	 */

	if (flags & TCL_DONT_WAIT) {
	    tsdPtr->blockTime.sec = 0;
	    tsdPtr->blockTime.usec = 0;
	    tsdPtr->blockTimeSet = 1;
	} else {
	    tsdPtr->blockTimeSet = 0;
	}

	/*
	 * Set up all the event sources for new events.  This will
	 * cause the block time to be updated if necessary.
	 */

	tsdPtr->inTraversal = 1;
	for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
	     sourcePtr = sourcePtr->nextPtr) {
	    if (sourcePtr->setupProc) {
		(sourcePtr->setupProc)(sourcePtr->clientData, flags);
	    }
	}
	tsdPtr->inTraversal = 0;

	if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
	    timePtr = &tsdPtr->blockTime;
	} else {
	    timePtr = NULL;
	}

	/*
	 * Wait for a new event or a timeout.  If Tcl_WaitForEvent
	 * returns -1, we should abort Tcl_DoOneEvent.
	 */

	result = Tcl_WaitForEvent(timePtr);
	if (result < 0) {
	    result = 0;
	    break;
	}

	/*
	 * Check all the event sources for new events.
	 */

	for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
	     sourcePtr = sourcePtr->nextPtr) {
	    if (sourcePtr->checkProc) {
		(sourcePtr->checkProc)(sourcePtr->clientData, flags);
	    }
	}

	/*
	 * Check for events queued by the notifier or event sources.
	 */

	if (Tcl_ServiceEvent(flags)) {
	    result = 1;
	    break;
	}

	/*
	 * We've tried everything at this point, but nobody we know
	 * about had anything to do.  Check for idle events.  If none,
	 * either quit or go back to the top and try again.
	 */

	idleEvents:
	if (flags & TCL_IDLE_EVENTS) {
	    if (TclServiceIdle()) {
		result = 1;
		break;
	    }
	}
	if (flags & TCL_DONT_WAIT) {
	    break;
	}

	/*
	 * If Tcl_WaitForEvent has returned 1,
	 * indicating that one system event has been dispatched
	 * (and thus that some Tcl code might have been indirectly executed),
	 * we break out of the loop.
	 * We do this to give VwaitCmd for instance a chance to check 
	 * if that system event had the side effect of changing the 
	 * variable (so the vwait can return and unwind properly).
	 *
	 * NB: We will process idle events if any first, because
	 *     otherwise we might never do the idle events if the notifier
	 *     always gets system events.
	 */

	if (result) {
	    break;
	}

    }

    tsdPtr->serviceMode = oldMode;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceAll --
 *
 *	This routine checks all of the event sources, processes
 *	events that are on the Tcl event queue, and then calls the
 *	any idle handlers.  Platform specific notifier callbacks that
 *	generate events should call this routine before returning to
 *	the system in order to ensure that Tcl gets a chance to
 *	process the new events.
 *
 * Results:
 *	Returns 1 if an event or idle handler was invoked, else 0.
 *
 * Side effects:
 *	Anything that an event or idle handler may do.
 *







|
|
|
|












|
|
|











|
|
















|
|


|
|
|
|


|
|
|
|






|











|
<
















|
|






|
|
|



<

|
|
|



|













|
|











|
|




|













|
|













|















|
|
|


|











|
<
|
|
|
|
|

|
|
|





<











|
|
|
|
<
|







751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838

839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868

869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971

972
973
974
975
976
977
978
979
980
981
982
983
984
985

986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000

1001
1002
1003
1004
1005
1006
1007
1008
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetMaxBlockTime --
 *
 *	This function is invoked by event sources to tell the notifier how
 *	long it may block the next time it blocks. The timePtr argument gives
 *	a maximum time; the actual time may be less if some other event source
 *	requested a smaller time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May reduce the length of the next sleep in the tsdPtr->
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetMaxBlockTime(timePtr)
    Tcl_Time *timePtr;		/* Specifies a maximum elapsed time for the
				 * next blocking operation in the event
				 * tsdPtr-> */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec)
	    || ((timePtr->sec == tsdPtr->blockTime.sec)
	    && (timePtr->usec < tsdPtr->blockTime.usec))) {
	tsdPtr->blockTime = *timePtr;
	tsdPtr->blockTimeSet = 1;
    }

    /*
     * If we are called outside an event source traversal, set the timeout
     * immediately.
     */

    if (!tsdPtr->inTraversal) {
	if (tsdPtr->blockTimeSet) {
	    Tcl_SetTimer(&tsdPtr->blockTime);
	} else {
	    Tcl_SetTimer(NULL);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DoOneEvent --
 *
 *	Process a single event of some sort. If there's no work to do, wait
 *	for an event to occur, then process it.
 *
 * Results:
 *	The return value is 1 if the function actually found an event to
 *	process. If no processing occurred, then 0 is returned (this can
 *	happen if the TCL_DONT_WAIT flag is set or if there are no event
 *	handlers to wait for in the set specified by flags).
 *
 * Side effects:
 *	May delay execution of process while waiting for an event, unless
 *	TCL_DONT_WAIT is set in the flags argument. Event sources are invoked
 *	to check for and queue events. Event handlers may produce arbitrary
 *	side effects.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DoOneEvent(flags)
    int flags;			/* Miscellaneous flag values: may be any
				 * combination of TCL_DONT_WAIT,
				 * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS,
				 * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or
				 * others defined by event sources. */
{
    int result = 0, oldMode;
    EventSource *sourcePtr;
    Tcl_Time *timePtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * The first thing we do is to service any asynchronous event handlers.

     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
	return 1;
    }

    /*
     * No event flags is equivalent to TCL_ALL_EVENTS.
     */

    if ((flags & TCL_ALL_EVENTS) == 0) {
	flags |= TCL_ALL_EVENTS;
    }

    /*
     * Set the service mode to none so notifier event routines won't try to
     * service events recursively.
     */

    oldMode = tsdPtr->serviceMode;
    tsdPtr->serviceMode = TCL_SERVICE_NONE;

    /*
     * The core of this function is an infinite loop, even though we only
     * service one event. The reason for this is that we may be processing
     * events that don't do anything inside of Tcl.
     */

    while (1) {

	/*
	 * If idle events are the only things to service, skip the main part
	 * of the loop and go directly to handle idle events (i.e. don't wait
	 * even if TCL_DONT_WAIT isn't set).
	 */

	if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) {
	    flags = TCL_IDLE_EVENTS | TCL_DONT_WAIT;
	    goto idleEvents;
	}

	/*
	 * Ask Tcl to service a queued event, if there are any.
	 */

	if (Tcl_ServiceEvent(flags)) {
	    result = 1;
	    break;
	}

	/*
	 * If TCL_DONT_WAIT is set, be sure to poll rather than blocking,
	 * otherwise reset the block time to infinity.
	 */

	if (flags & TCL_DONT_WAIT) {
	    tsdPtr->blockTime.sec = 0;
	    tsdPtr->blockTime.usec = 0;
	    tsdPtr->blockTimeSet = 1;
	} else {
	    tsdPtr->blockTimeSet = 0;
	}

	/*
	 * Set up all the event sources for new events. This will cause the
	 * block time to be updated if necessary.
	 */

	tsdPtr->inTraversal = 1;
	for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
		sourcePtr = sourcePtr->nextPtr) {
	    if (sourcePtr->setupProc) {
		(sourcePtr->setupProc)(sourcePtr->clientData, flags);
	    }
	}
	tsdPtr->inTraversal = 0;

	if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
	    timePtr = &tsdPtr->blockTime;
	} else {
	    timePtr = NULL;
	}

	/*
	 * Wait for a new event or a timeout. If Tcl_WaitForEvent returns -1,
	 * we should abort Tcl_DoOneEvent.
	 */

	result = Tcl_WaitForEvent(timePtr);
	if (result < 0) {
	    result = 0;
	    break;
	}

	/*
	 * Check all the event sources for new events.
	 */

	for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
		sourcePtr = sourcePtr->nextPtr) {
	    if (sourcePtr->checkProc) {
		(sourcePtr->checkProc)(sourcePtr->clientData, flags);
	    }
	}

	/*
	 * Check for events queued by the notifier or event sources.
	 */

	if (Tcl_ServiceEvent(flags)) {
	    result = 1;
	    break;
	}

	/*
	 * We've tried everything at this point, but nobody we know about had
	 * anything to do. Check for idle events. If none, either quit or go
	 * back to the top and try again.
	 */

    idleEvents:
	if (flags & TCL_IDLE_EVENTS) {
	    if (TclServiceIdle()) {
		result = 1;
		break;
	    }
	}
	if (flags & TCL_DONT_WAIT) {
	    break;
	}

	/*
	 * If Tcl_WaitForEvent has returned 1, indicating that one system

	 * event has been dispatched (and thus that some Tcl code might have
	 * been indirectly executed), we break out of the loop. We do this to
	 * give VwaitCmd for instance a chance to check if that system event
	 * had the side effect of changing the variable (so the vwait can
	 * return and unwind properly).
	 *
	 * NB: We will process idle events if any first, because otherwise we
	 *     might never do the idle events if the notifier always gets
	 *     system events.
	 */

	if (result) {
	    break;
	}

    }

    tsdPtr->serviceMode = oldMode;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceAll --
 *
 *	This routine checks all of the event sources, processes events that
 *	are on the Tcl event queue, and then calls the any idle handlers.
 *	Platform specific notifier callbacks that generate events should call
 *	this routine before returning to the system in order to ensure that

 *	Tcl gets a chance to process the new events.
 *
 * Results:
 *	Returns 1 if an event or idle handler was invoked, else 0.
 *
 * Side effects:
 *	Anything that an event or idle handler may do.
 *
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->serviceMode == TCL_SERVICE_NONE) {
	return result;
    }

    /*
     * We need to turn off event servicing like we to in Tcl_DoOneEvent,
     * to avoid recursive calls.
     */
    
    tsdPtr->serviceMode = TCL_SERVICE_NONE;

    /*
     * Check async handlers first.
     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
    }

    /*
     * Make a single pass through all event sources, queued events,
     * and idle handlers.  Note that we wait to update the notifier
     * timer until the end so we can avoid multiple changes.
     */

    tsdPtr->inTraversal = 1;
    tsdPtr->blockTimeSet = 0;

    for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
	 sourcePtr = sourcePtr->nextPtr) {
	if (sourcePtr->setupProc) {
	    (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
	}
    }
    for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
	 sourcePtr = sourcePtr->nextPtr) {
	if (sourcePtr->checkProc) {
	    (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
	}
    }

    while (Tcl_ServiceEvent(0)) {
	result = 1;







|
|

|











|
|
|






|





|







1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->serviceMode == TCL_SERVICE_NONE) {
	return result;
    }

    /*
     * We need to turn off event servicing like we to in Tcl_DoOneEvent, to
     * avoid recursive calls.
     */

    tsdPtr->serviceMode = TCL_SERVICE_NONE;

    /*
     * Check async handlers first.
     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
    }

    /*
     * Make a single pass through all event sources, queued events, and idle
     * handlers. Note that we wait to update the notifier timer until the end
     * so we can avoid multiple changes.
     */

    tsdPtr->inTraversal = 1;
    tsdPtr->blockTimeSet = 0;

    for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
	    sourcePtr = sourcePtr->nextPtr) {
	if (sourcePtr->setupProc) {
	    (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
	}
    }
    for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
	    sourcePtr = sourcePtr->nextPtr) {
	if (sourcePtr->checkProc) {
	    (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
	}
    }

    while (Tcl_ServiceEvent(0)) {
	result = 1;
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ThreadAlert --
 *
 *	This function wakes up the notifier associated with the
 *	specified thread (if there is one).  
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ThreadAlert(threadId)
    Tcl_ThreadId threadId;	/* Identifier for thread to use. */
{
    ThreadSpecificData *tsdPtr;

    /*
     * Find the notifier associated with the specified thread.
     * Note that we need to hold the listLock while calling
     * Tcl_AlertNotifier to avoid a race condition where
     * the specified thread might destroy its notifier.
     */

    Tcl_MutexLock(&listLock);
    for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	if (tsdPtr->threadId == threadId) {
	    if (tclStubs.tcl_AlertNotifier) {
		tclStubs.tcl_AlertNotifier(tsdPtr->clientData);
	    }
	    break;
	}
    }
    Tcl_MutexUnlock(&listLock);
}















|
|

















|
|
<
|













>
>
>
>
>
>
>
>
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102

1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ThreadAlert --
 *
 *	This function wakes up the notifier associated with the specified
 *	thread (if there is one).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ThreadAlert(threadId)
    Tcl_ThreadId threadId;	/* Identifier for thread to use. */
{
    ThreadSpecificData *tsdPtr;

    /*
     * Find the notifier associated with the specified thread. Note that we
     * need to hold the listLock while calling Tcl_AlertNotifier to avoid a

     * race condition where the specified thread might destroy its notifier.
     */

    Tcl_MutexLock(&listLock);
    for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	if (tsdPtr->threadId == threadId) {
	    if (tclStubs.tcl_AlertNotifier) {
		tclStubs.tcl_AlertNotifier(tsdPtr->clientData);
	    }
	    break;
	}
    }
    Tcl_MutexUnlock(&listLock);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclObj.c.

1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16
17
18



19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

64
65
66






67
68
69

























70
71
72

73
74


75














76







77





78

79
80
81

82
83













84
85









86

87
88
89
90

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

166
167
168
169




170
171
172




173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337






338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427

428
429



430




431

432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545

546
547
548
549
550
551
552
553

554
555
556
557
558

559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
/*
 * tclObj.c --
 *
 *	This file contains Tcl object-related procedures that are used by
 * 	many Tcl commands.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.72 2004/10/06 15:59:25 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"




/*
 * Table of all object types.
 */

static Tcl_HashTable typeTable;
static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)

/*
 * Head of the list of free Tcl_Obj structs we maintain.
 */

Tcl_Obj *tclFreeObjList = NULL;

/*
 * The object allocator is single threaded.  This mutex is referenced
 * by the TclNewObj macro, however, so must be visible.
 */

#ifdef TCL_THREADS
Tcl_Mutex tclObjMutex;
#endif

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses
 * as the value of an empty string representation for an object. This value
 * is shared by all new objects allocated by Tcl_NewObj.
 */

char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;

#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
 * Thread local table that is used to check that a Tcl_Obj
 * was not allocated by some other thread.
 */
typedef struct ThreadSpecificData {
    Tcl_HashTable *objThreadMap;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */


/*
 * Nested Tcl_Obj deletion management support.  Note that the code
 * that implements all this is written as macros in tclInt.h






 */

#ifdef TCL_THREADS


























/*
 * Lookup key for the thread-local data used in the implementation in

 * tclInt.h.
 */


Tcl_ThreadDataKey tclPendingObjDataKey;






















#else







/*
 * Declaration of the singleton structure referenced in the
 * implementation in tclInt.h.

 */
PendingObjData tclPendingObjData = { 0, NULL };














#endif











/*
 * Prototypes for procedures defined later in this file:
 */


static int		SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
							 Tcl_Obj *objPtr));
static void		UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

#ifndef TCL_WIDE_INT_IS_LONG
static void		UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
#endif








/*
 * Prototypes for the array hash key methods.
 */

static Tcl_HashEntry *	AllocObjEntry _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr, VOID *keyPtr));
static int		CompareObjKeys _ANSI_ARGS_((
			    VOID *keyPtr, Tcl_HashEntry *hPtr));
static void		FreeObjEntry _ANSI_ARGS_((
			    Tcl_HashEntry *hPtr));
static unsigned int	HashObjKey _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr,
			    VOID *keyPtr));

/*
 * Prototypes for the CommandName object type.
 */

static void		DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static void		FreeCmdNameInternalRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr));
static int		SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));


/*
 * The structures below defines the Tcl object types defined in this file by
 * means of procedures that can be invoked by generic object code. See also
 * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
 * implementations.
 */

Tcl_ObjType tclBooleanType = {
    "boolean",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    UpdateStringOfBoolean,		/* updateStringProc */
    SetBooleanFromAny			/* setFromAnyProc */
};

Tcl_ObjType tclDoubleType = {
    "double",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    UpdateStringOfDouble,		/* updateStringProc */
    SetDoubleFromAny			/* setFromAnyProc */
};

Tcl_ObjType tclIntType = {
    "int",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    UpdateStringOfInt,			/* updateStringProc */
    SetIntFromAny			/* setFromAnyProc */
};


Tcl_ObjType tclWideIntType = {
    "wideInt",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */




#ifdef TCL_WIDE_INT_IS_LONG
    UpdateStringOfInt,			/* updateStringProc */
#else /* !TCL_WIDE_INT_IS_LONG */




    UpdateStringOfWideInt,		/* updateStringProc */
#endif /* TCL_WIDE_INT_IS_LONG */
    SetWideIntFromAny			/* setFromAnyProc */
};

/*
 * The structure below defines the Tcl obj hash key type.
 */
Tcl_HashKeyType tclObjHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    HashObjKey,				/* hashKeyProc */
    CompareObjKeys,			/* compareKeysProc */
    AllocObjEntry,			/* allocEntryProc */
    FreeObjEntry			/* freeEntryProc */
};

/*
 * The structure below defines the command name Tcl object type by means of
 * procedures that can be invoked by generic object code. Objects of this
 * type cache the Command pointer that results from looking up command names
 * in the command hashtable. Such objects appear as the zeroth ("command
 * name") argument in a Tcl command.
 *
 * NOTE: the ResolvedCmdName that gets cached is stored in the
 * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused.
 * You might think you could use the simpler otherValuePtr field to
 * store the single ResolvedCmdName pointer, but DO NOT DO THIS.  It
 * seems that some extensions use the second internal pointer field
 * of the twoPtrValue field for their own purposes.
 */

static Tcl_ObjType tclCmdNameType = {
    "cmdName",				/* name */
    FreeCmdNameInternalRep,		/* freeIntRepProc */
    DupCmdNameInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetCmdNameFromAny			/* setFromAnyProc */
};


/*
 * Structure containing a cached pointer to a command that is the result
 * of resolving the command's name in some namespace. It is the internal
 * representation for a cmdName object. It contains the pointer along
 * with some information that is used to check the pointer's validity.
 */

typedef struct ResolvedCmdName {
    Command *cmdPtr;		/* A cached Command pointer. */
    Namespace *refNsPtr;	/* Points to the namespace containing the
				 * reference (not the namespace that
				 * contains the referenced command). */
    long refNsId;		/* refNsPtr's unique namespace id. Used to
				 * verify that refNsPtr is still valid
				 * (e.g., it's possible that the cmd's
				 * containing namespace was deleted and a
				 * new one created at the same address). */
    int refNsCmdEpoch;		/* Value of the referencing namespace's
				 * cmdRefEpoch when the pointer was cached.
				 * Before using the cached pointer, we check
				 * if the namespace's epoch was incremented;
				 * if so, this cached pointer is invalid. */
    int cmdEpoch;		/* Value of the command's cmdEpoch when this
				 * pointer was cached. Before using the
				 * cached pointer, we check if the cmd's
				 * epoch was incremented; if so, the cmd was
				 * renamed, deleted, hidden, or exposed, and
				 * so the pointer is invalid. */
    int refCount;		/* Reference count: 1 for each cmdName
				 * object that has a pointer to this
				 * ResolvedCmdName structure as its internal
				 * rep. This structure can be freed when
				 * refCount becomes zero. */
} ResolvedCmdName;


/*
 *-------------------------------------------------------------------------
 *
 * TclInitObjectSubsystem --
 *
 *	This procedure is invoked to perform once-only initialization of
 *	the type table. It also registers the object types defined in
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes the table of defined object types "typeTable" with
 *	builtin object types defined in this file.
 *
 *-------------------------------------------------------------------------
 */

void
TclInitObjSubsystem()
{
    Tcl_MutexLock(&tableMutex);
    typeTableInitialized = 1;
    Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&tableMutex);

    Tcl_RegisterObjType(&tclBooleanType);
    Tcl_RegisterObjType(&tclByteArrayType);
    Tcl_RegisterObjType(&tclDoubleType);
    Tcl_RegisterObjType(&tclEndOffsetType);
    Tcl_RegisterObjType(&tclIntType);
    Tcl_RegisterObjType(&tclWideIntType);
    Tcl_RegisterObjType(&tclStringType);
    Tcl_RegisterObjType(&tclListType);
    Tcl_RegisterObjType(&tclDictType);
    Tcl_RegisterObjType(&tclByteCodeType);
    Tcl_RegisterObjType(&tclProcBodyType);
    Tcl_RegisterObjType(&tclArraySearchType);
    Tcl_RegisterObjType(&tclIndexType);
    Tcl_RegisterObjType(&tclNsNameType);
    Tcl_RegisterObjType(&tclEnsembleCmdType);
    Tcl_RegisterObjType(&tclCmdNameType);
    Tcl_RegisterObjType(&tclLocalVarNameType);
    Tcl_RegisterObjType(&tclRegexpType);
    Tcl_RegisterObjType(&tclLevelReferenceType);

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    tclObjsAlloced = 0;
    tclObjsFreed = 0;
    {
	int i;
	for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
	    tclObjsShared[i] = 0;
	}
    }
    Tcl_MutexUnlock(&tclObjMutex);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeCompExecEnv --
 *
 *	This procedure is called by Tcl_Finalize to clean up the Tcl
 *	compilation and execution environment so it can later be properly
 *	reinitialized.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up the compilation and execution environment
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeCompExecEnv()
{
    Tcl_MutexLock(&tableMutex);
    if (typeTableInitialized) {
	Tcl_DeleteHashTable(&typeTable);
	typeTableInitialized = 0;
    }
    Tcl_MutexUnlock(&tableMutex);






    Tcl_MutexLock(&tclObjMutex);
    tclFreeObjList = NULL;
    Tcl_MutexUnlock(&tclObjMutex);

    TclFinalizeCompilation();
    TclFinalizeExecution();
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *
 *	This procedure is called to register a new Tcl object type
 *	in the table of all object types supported by Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The type is registered in the Tcl type table. If there was already
 *	a type with the same name as in typePtr, it is replaced with the
 *	new type.
 *
 *--------------------------------------------------------------
 */

void
Tcl_RegisterObjType(typePtr)
    Tcl_ObjType *typePtr;	/* Information about object type;
				 * storage must be statically
				 * allocated (must live forever). */
{
    register Tcl_HashEntry *hPtr;
    int new;

    /*
     * If there's already an object type with the given name, remove it.
     */
    Tcl_MutexLock(&tableMutex);
    hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
    if (hPtr != (Tcl_HashEntry *) NULL) {
	Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Now insert the new object type.
     */

    hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
    if (new) {
	Tcl_SetHashValue(hPtr, typePtr);
    }
    Tcl_MutexUnlock(&tableMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendAllObjTypes --
 *
 *	This procedure appends onto the argument object the name of each
 *	object type as a list element. This includes the builtin object
 *	types (e.g. int, list) as well as those added using
 *	Tcl_NewObj. These names can be used, for example, with
 *	Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
 *	structures.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case the object
 *	referenced by objPtr has each type name appended to it. If an
 *	error occurs, TCL_ERROR is returned and the interpreter's result
 *	holds an error message.
 *
 * Side effects:
 *	If necessary, the object referenced by objPtr is converted into
 *	a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppendAllObjTypes(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    Tcl_Obj *objPtr;		/* Points to the Tcl object onto which the
				 * name of each registered type is appended
				 * as a list element. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    Tcl_ObjType *typePtr;
    int result;








    /*

     * This code assumes that types names do not contain embedded NULLs.
     */

    Tcl_MutexLock(&tableMutex);
    for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
	    hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
	typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
	result = Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(typePtr->name, -1));
	if (result == TCL_ERROR) {
	    Tcl_MutexUnlock(&tableMutex);
	    return result;
	}
    }
    Tcl_MutexUnlock(&tableMutex);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetObjType --
 *
 *	This procedure looks up an object type by name.
 *
 * Results:
 *	If an object type with name matching "typeName" is found, a pointer
 *	to its Tcl_ObjType structure is returned; otherwise, NULL is
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_ObjType *
Tcl_GetObjType(typeName)
    CONST char *typeName;	/* Name of Tcl object type to look up. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_ObjType *typePtr;

    Tcl_MutexLock(&tableMutex);
    hPtr = Tcl_FindHashEntry(&typeTable, typeName);
    if (hPtr != (Tcl_HashEntry *) NULL) {
	typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
	Tcl_MutexUnlock(&tableMutex);
	return typePtr;
    }
    Tcl_MutexUnlock(&tableMutex);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertToType --
 *
 *	Convert the Tcl object "objPtr" to have type "typePtr" if possible.
 *
 * Results:
 *	The return value is TCL_OK on success and TCL_ERROR on failure. If
 *	TCL_ERROR is returned, then the interpreter's result contains an
 *	error message unless "interp" is NULL. Passing a NULL "interp"
 *	allows this procedure to be used as a test whether the conversion
 *	could be done (and in fact was done).
 *
 * Side effects:
 *	Any internal representation for the old type is freed.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertToType(interp, objPtr, typePtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* The object to convert. */
    Tcl_ObjType *typePtr;	/* The target type. */
{
    if (objPtr->typePtr == typePtr) {
	return TCL_OK;
    }

    /*
     * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
     * form as appropriate for the target type. This frees the old internal
     * representation.
     */

    if (typePtr->setFromAnyProc == NULL) {
	Tcl_Panic("may not convert object to type %s", typePtr->name);
    }

    return typePtr->setFromAnyProc(interp, objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclDbInitNewObj --
 *
 *	Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG
 *	is enabled. This function will initialize the members of a
 *	Tcl_Obj struct. Initilization would be done inline via the
 *	TclNewObj macro when compiling without TCL_MEM_DEBUG.
 *
 * Results:
 *	The Tcl_Obj struct members are initialized.
 *
 * Side effects:
 *	None.
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
void TclDbInitNewObj(objPtr)
    register Tcl_Obj *objPtr;
{
    objPtr->refCount = 0;
    objPtr->bytes = tclEmptyStringRep;
    objPtr->length = 0;
    objPtr->typePtr = NULL;

# ifdef TCL_THREADS
    /*
     * Add entry to a thread local map used to check if a Tcl_Obj
     * was allocated by the currently executing thread.
     */

    if (!TclInExit()) {
	Tcl_HashEntry *hPtr;
	Tcl_HashTable *tablePtr;
	int new;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (tsdPtr->objThreadMap == NULL) {
	    tsdPtr->objThreadMap = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
	    Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
	}
	tablePtr = tsdPtr->objThreadMap;
	hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &new);
	if (!new) {
	    Tcl_Panic("expected to create new entry for object map");
	}
	Tcl_SetHashValue(hPtr, NULL);
    }
# endif /* TCL_THREADS */
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
 *	the empty string. These objects have a NULL object type and NULL
 *	string representation byte pointer. Type managers call this routine
 *	to allocate new objects that they further initialize.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewObj.
 *
 * Results:
 *	The result is a newly allocated object that represents the empty
 *	string. The new object's typePtr is set NULL and its ref count
 *	is set to 0.
 *
 * Side effects:
 *	If compiling with TCL_COMPILE_STATS, this procedure increments
 *	the global count of allocated objects (tclObjsAlloced).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewObj




|
|




>

|
|

|



|
>
>
>
















|
|







|
|
|







|
|








>

|
<
>
>
>
>
>
>


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


<
>
|

>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>
>
>
>

>
>
>
>
>

>

<
<
>

|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
|
>




>






<
<
<


<
<

|



>
>
>
>
>
>
>











|
<







|
<















|



















>




>
>
>
>
|
|
|
>
>
>
>
|
<
|
















|
|
|
|


|
|
|
|
|












|
|
|
|





|
|

|
|
|
|






|
|
|
|
|
|
|
|
|
|








|
|
<





|
|












<




<

<


<

<

<

<

|


















|

|
<
|





|





|







>
>
>
>
>
>



<
<
<







|
|





|
|
|






|
|
|

<

<
<
<
<

<
<
<
<
|
<
<
<
<
|
<
<
<









|
|
|
|
<



|
|
|


|
|








|
|



>
|
|
>
>
>

>
>
>
>

>
|





<
|
|
<
<
<
<













|
|
<












|





<
<


|











|
|
|
|


















|
|















|
|
|
|








>








>
|

|
|

>


















|











|
|

|
|



|
|


|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143


144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183



184
185


186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209

210
211
212
213
214
215
216
217

218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269

270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370

371
372
373
374

375

376
377

378

379

380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403

404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432



433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459

460




461




462




463



464
465
466
467
468
469
470
471
472
473
474
475
476

477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

519
520




521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553


554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
/*
 * tclObj.c --
 *
 *	This file contains Tcl object-related procedures that are used by many
 *	Tcl commands.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.72.2.42 2005/10/08 06:07:58 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <float.h>

#define BIGNUM_AUTO_NARROW 1

/*
 * Table of all object types.
 */

static Tcl_HashTable typeTable;
static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)

/*
 * Head of the list of free Tcl_Obj structs we maintain.
 */

Tcl_Obj *tclFreeObjList = NULL;

/*
 * The object allocator is single threaded.  This mutex is referenced by the
 * TclNewObj macro, however, so must be visible.
 */

#ifdef TCL_THREADS
Tcl_Mutex tclObjMutex;
#endif

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses as
 * the value of an empty string representation for an object. This value is
 * shared by all new objects allocated by Tcl_NewObj.
 */

char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;

#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
 * Thread local table that is used to check that a Tcl_Obj was not allocated
 * by some other thread.
 */
typedef struct ThreadSpecificData {
    Tcl_HashTable *objThreadMap;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */


/*
 * Nested Tcl_Obj deletion management support

 *
 * All context references used in the object freeing code are pointers to this
 * structure; every thread will have its own structure instance.  The purpose
 * of this structure is to allow deeply nested collections of Tcl_Objs to be
 * freed without taking a vast depth of C stack (which could cause all sorts
 * of breakage.)
 */

typedef struct PendingObjData {
    int deletionCount;		/* Count of the number of invokations of
				 * TclFreeObj() are on the stack (at least
				 * conceptually; many are actually expanded
				 * macros). */
    Tcl_Obj *deletionStack;	/* Stack of objects that have had TclFreeObj()
				 * invoked upon them but which can't be
				 * deleted yet because they are in a nested
				 * invokation of TclFreeObj(). By postponing
				 * this way, we limit the maximum overall C
				 * stack depth when deleting a complex object.
				 * The down-side is that we alter the overall
				 * behaviour by altering the order in which
				 * objects are deleted, and we change the
				 * order in which the string rep and the
				 * internal rep of an object are deleted. Note
				 * that code which assumes the previous
				 * behaviour in either of these respects is
				 * unsafe anyway; it was never documented as
				 * to exactly what would happen in these
				 * cases, and the overall contract of a
				 * user-level Tcl_DecrRefCount() is still
				 * preserved (assuming that a particular T_DRC
				 * would delete an object is not very
				 * safe). */
} PendingObjData;

/*

 * These are separated out so that some semantic content is attached
 * to them.
 */
#define ObjDeletionLock(contextPtr)	((contextPtr)->deletionCount++)
#define ObjDeletionUnlock(contextPtr)	((contextPtr)->deletionCount--)
#define ObjDeletePending(contextPtr)	((contextPtr)->deletionCount > 0)
#define ObjOnStack(contextPtr)		((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr,objPtr) \
    /* Invalidate the string rep first so we can use the bytes value \
     * for our pointer chain. */ \
    if (((objPtr)->bytes != NULL) \
	    && ((objPtr)->bytes != tclEmptyStringRep)) { \
	ckfree((char *) (objPtr)->bytes); \
    } \
    /* Now push onto the head of the stack. */ \
    (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
    (contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr,objPtrVar) \
    (objPtrVar) = (contextPtr)->deletionStack; \
    (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes

/*
 * Macro to set up the local reference to the deletion context.
 */
#ifndef TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
    PendingObjData *CONST contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
    PendingObjData *CONST contextPtr = (PendingObjData *) \
	    Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif


/*


 * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
 */

#define PACK_BIGNUM(bignum, objPtr) \
    if ((bignum).used > 0x7fff) { \
	mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
	*temp = bignum; \
	(objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \
	(objPtr)->internalRep.ptrAndLongRep.value = -1; \
    } else { \
	if ((bignum).alloc > 0x7fff) { \
	    mp_shrink(&(bignum)); \
	} \
	(objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \
	(objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \
		| ((bignum).alloc << 15) | ((bignum).used)); \
    }

#define UNPACK_BIGNUM(objPtr, bignum) \
    if ((objPtr)->internalRep.ptrAndLongRep.value == -1) { \
	(bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \
    } else { \
	(bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \
	(bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \
	(bignum).alloc = \
		((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \
	(bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \
    }

/*
 * Prototypes for procedures defined later in this file:
 */

static int		ParseBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));



static void		UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));



#ifndef NO_WIDE_TYPE
static void		UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
#endif

static void		FreeBignum _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupBignum _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static void		UpdateStringOfBignum _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		GetBignumFromObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, int copy, mp_int *bignumValue));

/*
 * Prototypes for the array hash key methods.
 */

static Tcl_HashEntry *	AllocObjEntry _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr, VOID *keyPtr));
static int		CompareObjKeys _ANSI_ARGS_((
			    VOID *keyPtr, Tcl_HashEntry *hPtr));
static void		FreeObjEntry _ANSI_ARGS_((
			    Tcl_HashEntry *hPtr));
static unsigned int	HashObjKey _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr, VOID *keyPtr));


/*
 * Prototypes for the CommandName object type.
 */

static void		DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static void		FreeCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));

static int		SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));


/*
 * The structures below defines the Tcl object types defined in this file by
 * means of procedures that can be invoked by generic object code. See also
 * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
 * implementations.
 */

Tcl_ObjType tclBooleanType = {
    "boolean",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetBooleanFromAny			/* setFromAnyProc */
};

Tcl_ObjType tclDoubleType = {
    "double",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    UpdateStringOfDouble,		/* updateStringProc */
    SetDoubleFromAny			/* setFromAnyProc */
};

Tcl_ObjType tclIntType = {
    "int",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    UpdateStringOfInt,			/* updateStringProc */
    SetIntFromAny			/* setFromAnyProc */
};

#ifndef NO_WIDE_TYPE
Tcl_ObjType tclWideIntType = {
    "wideInt",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
    UpdateStringOfWideInt,		/* updateStringProc */
    NULL				/* setFromAnyProc */
};
#endif



Tcl_ObjType tclBignumType = {
    "bignum",				/* name */
    FreeBignum,				/* freeIntRepProc */
    DupBignum,				/* dupIntRepProc */
    UpdateStringOfBignum,		/* updateStringProc */

    NULL				/* setFromAnyProc */
};

/*
 * The structure below defines the Tcl obj hash key type.
 */
Tcl_HashKeyType tclObjHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    0,					/* flags */
    HashObjKey,				/* hashKeyProc */
    CompareObjKeys,			/* compareKeysProc */
    AllocObjEntry,			/* allocEntryProc */
    FreeObjEntry			/* freeEntryProc */
};

/*
 * The structure below defines the command name Tcl object type by means of
 * procedures that can be invoked by generic object code. Objects of this type
 * cache the Command pointer that results from looking up command names in the
 * command hashtable. Such objects appear as the zeroth ("command name")
 * argument in a Tcl command.
 *
 * NOTE: the ResolvedCmdName that gets cached is stored in the
 * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might
 * think you could use the simpler otherValuePtr field to store the single
 * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions
 * use the second internal pointer field of the twoPtrValue field for their
 * own purposes.
 */

static Tcl_ObjType tclCmdNameType = {
    "cmdName",				/* name */
    FreeCmdNameInternalRep,		/* freeIntRepProc */
    DupCmdNameInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetCmdNameFromAny			/* setFromAnyProc */
};


/*
 * Structure containing a cached pointer to a command that is the result of
 * resolving the command's name in some namespace. It is the internal
 * representation for a cmdName object. It contains the pointer along with
 * some information that is used to check the pointer's validity.
 */

typedef struct ResolvedCmdName {
    Command *cmdPtr;		/* A cached Command pointer. */
    Namespace *refNsPtr;	/* Points to the namespace containing the
				 * reference (not the namespace that contains
				 * the referenced command). */
    long refNsId;		/* refNsPtr's unique namespace id. Used to
				 * verify that refNsPtr is still valid (e.g.,
				 * it's possible that the cmd's containing
				 * namespace was deleted and a new one created
				 * at the same address). */
    int refNsCmdEpoch;		/* Value of the referencing namespace's
				 * cmdRefEpoch when the pointer was cached.
				 * Before using the cached pointer, we check
				 * if the namespace's epoch was incremented;
				 * if so, this cached pointer is invalid. */
    int cmdEpoch;		/* Value of the command's cmdEpoch when this
				 * pointer was cached. Before using the cached
				 * pointer, we check if the cmd's epoch was
				 * incremented; if so, the cmd was renamed,
				 * deleted, hidden, or exposed, and so the
				 * pointer is invalid. */
    int refCount;		/* Reference count: 1 for each cmdName object
				 * that has a pointer to this ResolvedCmdName
				 * structure as its internal rep. This
				 * structure can be freed when refCount
				 * becomes zero. */
} ResolvedCmdName;


/*
 *-------------------------------------------------------------------------
 *
 * TclInitObjectSubsystem --
 *
 *	This procedure is invoked to perform once-only initialization of the
 *	type table. It also registers the object types defined in this file.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes the table of defined object types "typeTable" with builtin
 *	object types defined in this file.
 *
 *-------------------------------------------------------------------------
 */

void
TclInitObjSubsystem()
{
    Tcl_MutexLock(&tableMutex);
    typeTableInitialized = 1;
    Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&tableMutex);


    Tcl_RegisterObjType(&tclByteArrayType);
    Tcl_RegisterObjType(&tclDoubleType);
    Tcl_RegisterObjType(&tclEndOffsetType);
    Tcl_RegisterObjType(&tclIntType);

    Tcl_RegisterObjType(&tclStringType);

    Tcl_RegisterObjType(&tclDictType);
    Tcl_RegisterObjType(&tclByteCodeType);

    Tcl_RegisterObjType(&tclArraySearchType);

    Tcl_RegisterObjType(&tclNsNameType);

    Tcl_RegisterObjType(&tclCmdNameType);

    Tcl_RegisterObjType(&tclRegexpType);
    Tcl_RegisterObjType(&tclProcBodyType);

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    tclObjsAlloced = 0;
    tclObjsFreed = 0;
    {
	int i;
	for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
	    tclObjsShared[i] = 0;
	}
    }
    Tcl_MutexUnlock(&tclObjMutex);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeObjects --
 *
 *	This procedure is called by Tcl_Finalize to clean up all

 *	registered Tcl_ObjType's and to reset the tclFreeObjList.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeObjects()
{
    Tcl_MutexLock(&tableMutex);
    if (typeTableInitialized) {
	Tcl_DeleteHashTable(&typeTable);
	typeTableInitialized = 0;
    }
    Tcl_MutexUnlock(&tableMutex);

    /*
     * All we do here is reset the head pointer of the linked list of
     * free Tcl_Obj's to NULL;  the memory finalization will take care
     * of releasing memory for us.
     */
    Tcl_MutexLock(&tclObjMutex);
    tclFreeObjList = NULL;
    Tcl_MutexUnlock(&tclObjMutex);



}

/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *
 *	This procedure is called to register a new Tcl object type in the
 *	table of all object types supported by Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The type is registered in the Tcl type table. If there was already a
 *	type with the same name as in typePtr, it is replaced with the new
 *	type.
 *
 *--------------------------------------------------------------
 */

void
Tcl_RegisterObjType(typePtr)
    Tcl_ObjType *typePtr;	/* Information about object type; storage must
				 * be statically allocated (must live
				 * forever). */
{

    int new;




    Tcl_MutexLock(&tableMutex);




    Tcl_SetHashValue(




	    Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);



    Tcl_MutexUnlock(&tableMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendAllObjTypes --
 *
 *	This procedure appends onto the argument object the name of each
 *	object type as a list element. This includes the builtin object types
 *	(e.g. int, list) as well as those added using Tcl_NewObj. These names
 *	can be used, for example, with Tcl_GetObjType to get pointers to the
 *	corresponding Tcl_ObjType structures.

 *
 * Results:
 *	The return value is normally TCL_OK; in this case the object
 *	referenced by objPtr has each type name appended to it. If an error
 *	occurs, TCL_ERROR is returned and the interpreter's result holds an
 *	error message.
 *
 * Side effects:
 *	If necessary, the object referenced by objPtr is converted into a list
 *	object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppendAllObjTypes(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    Tcl_Obj *objPtr;		/* Points to the Tcl object onto which the
				 * name of each registered type is appended as
				 * a list element. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    int objc;
    Tcl_Obj **objv;

    /* 
     * Get the test for a valid list out of the way first.
     */

    if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Type names are NUL-terminated, not counted strings.
     * This code relies on that.
     */

    Tcl_MutexLock(&tableMutex);
    for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
	    hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {

	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));




    }
    Tcl_MutexUnlock(&tableMutex);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetObjType --
 *
 *	This procedure looks up an object type by name.
 *
 * Results:
 *	If an object type with name matching "typeName" is found, a pointer to
 *	its Tcl_ObjType structure is returned; otherwise, NULL is returned.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_ObjType *
Tcl_GetObjType(typeName)
    CONST char *typeName;	/* Name of Tcl object type to look up. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_ObjType *typePtr = NULL;

    Tcl_MutexLock(&tableMutex);
    hPtr = Tcl_FindHashEntry(&typeTable, typeName);
    if (hPtr != (Tcl_HashEntry *) NULL) {
	typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);


    }
    Tcl_MutexUnlock(&tableMutex);
    return typePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertToType --
 *
 *	Convert the Tcl object "objPtr" to have type "typePtr" if possible.
 *
 * Results:
 *	The return value is TCL_OK on success and TCL_ERROR on failure. If
 *	TCL_ERROR is returned, then the interpreter's result contains an error
 *	message unless "interp" is NULL. Passing a NULL "interp" allows this
 *	procedure to be used as a test whether the conversion could be done
 *	(and in fact was done).
 *
 * Side effects:
 *	Any internal representation for the old type is freed.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertToType(interp, objPtr, typePtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* The object to convert. */
    Tcl_ObjType *typePtr;	/* The target type. */
{
    if (objPtr->typePtr == typePtr) {
	return TCL_OK;
    }

    /*
     * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form
     * as appropriate for the target type. This frees the old internal
     * representation.
     */

    if (typePtr->setFromAnyProc == NULL) {
	Tcl_Panic("may not convert object to type %s", typePtr->name);
    }

    return typePtr->setFromAnyProc(interp, objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclDbInitNewObj --
 *
 *	Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is
 *	enabled. This function will initialize the members of a Tcl_Obj
 *	struct. Initilization would be done inline via the TclNewObj macro
 *	when compiling without TCL_MEM_DEBUG.
 *
 * Results:
 *	The Tcl_Obj struct members are initialized.
 *
 * Side effects:
 *	None.
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
void TclDbInitNewObj(objPtr)
    register Tcl_Obj *objPtr;
{
    objPtr->refCount = 0;
    objPtr->bytes = tclEmptyStringRep;
    objPtr->length = 0;
    objPtr->typePtr = NULL;

#ifdef TCL_THREADS
    /*
     * Add entry to a thread local map used to check if a Tcl_Obj was
     * allocated by the currently executing thread.
     */

    if (!TclInExit()) {
	Tcl_HashEntry *hPtr;
	Tcl_HashTable *tablePtr;
	int new;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (tsdPtr->objThreadMap == NULL) {
	    tsdPtr->objThreadMap = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
	    Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
	}
	tablePtr = tsdPtr->objThreadMap;
	hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &new);
	if (!new) {
	    Tcl_Panic("expected to create new entry for object map");
	}
	Tcl_SetHashValue(hPtr, NULL);
    }
#endif /* TCL_THREADS */
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
 *	the empty string. These objects have a NULL object type and NULL
 *	string representation byte pointer. Type managers call this routine to
 *	allocate new objects that they further initialize.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the result
 *	of calling the debugging version Tcl_DbNewObj.
 *
 * Results:
 *	The result is a newly allocated object that represents the empty
 *	string. The new object's typePtr is set NULL and its ref count is set
 *	to 0.
 *
 * Side effects:
 *	If compiling with TCL_COMPILE_STATS, this procedure increments the
 *	global count of allocated objects (tclObjsAlloced).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewObj

617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705

Tcl_Obj *
Tcl_NewObj()
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the
     * correct allocator.
     */

    TclNewObj(objPtr);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
 *	empty string. It is the same as the Tcl_NewObj procedure above
 *	except that it calls Tcl_DbCkalloc directly with the file name and
 *	line number from its caller. This simplifies debugging since then
 *	the [memory active] command will report the correct file name and line
 *	number when reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewObj.
 *
 * Results:
 *	The result is a newly allocated that represents the empty string.
 *	The new object's typePtr is set NULL and its ref count is set to 0.
 *
 * Side effects:
 *	If compiling with TCL_COMPILE_STATS, this procedure increments
 *	the global count of allocated objects (tclObjsAlloced).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewObj(file, line)
    register CONST char *file;	/* The name of the source file calling this
				 * procedure; used for debugging. */
    register int line;		/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the
     * correct allocator.
     */

    TclDbNewObj(objPtr, file, line);
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewObj(file, line)
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclAllocateFreeObjects --
 *
 *	Procedure to allocate a number of free Tcl_Objs. This is done using
 *	a single ckalloc to reduce the overhead for Tcl_Obj allocation.
 *
 *	Assumes mutex is held.
 *
 * Results:
 *	None.
 *
 * Side effects:







|
<














|
|
|
|






|
|


|
|










|
|




|
<











|
|










|
|







693
694
695
696
697
698
699
700

701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747

748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779

Tcl_Obj *
Tcl_NewObj()
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the correct allocator.

     */

    TclNewObj(objPtr);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
 *	empty string. It is the same as the Tcl_NewObj procedure above except
 *	that it calls Tcl_DbCkalloc directly with the file name and line
 *	number from its caller. This simplifies debugging since then the
 *	[memory active] command will report the correct file name and line
 *	number when reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewObj.
 *
 * Results:
 *	The result is a newly allocated that represents the empty string. The
 *	new object's typePtr is set NULL and its ref count is set to 0.
 *
 * Side effects:
 *	If compiling with TCL_COMPILE_STATS, this procedure increments the
 *	global count of allocated objects (tclObjsAlloced).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewObj(file, line)
    register CONST char *file;	/* The name of the source file calling this
				 * procedure; used for debugging. */
    register int line;		/* Line number in the source file; used for
				 * debugging. */
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the correct allocator.

     */

    TclDbNewObj(objPtr, file, line);
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewObj(file, line)
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclAllocateFreeObjects --
 *
 *	Procedure to allocate a number of free Tcl_Objs. This is done using a
 *	single ckalloc to reduce the overhead for Tcl_Obj allocation.
 *
 *	Assumes mutex is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
719
720
721
722
723
724
725
726
727


728
729
730
731
732
733
734
    char *basePtr;
    register Tcl_Obj *prevPtr, *objPtr;
    register int i;

    /*
     * This has been noted by Purify to be a potential leak.  The problem is
     * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
     * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
     * actually freeing the memory.  These never do get freed properly.


     */

    basePtr = (char *) ckalloc(bytesToAlloc);
    memset(basePtr, 0, bytesToAlloc);

    prevPtr = NULL;
    objPtr = (Tcl_Obj *) basePtr;







|
|
>
>







793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
    char *basePtr;
    register Tcl_Obj *prevPtr, *objPtr;
    register int i;

    /*
     * This has been noted by Purify to be a potential leak.  The problem is
     * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
     * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
     * freeing the memory.  TclFinalizeObjects() does not ckfree() this memory,
     * but leaves it to Tcl's memory subsystem finalization to release it.
     * Purify apparently can't figure that out, and fires a false alarm.
     */

    basePtr = (char *) ckalloc(bytesToAlloc);
    memset(basePtr, 0, bytesToAlloc);

    prevPtr = NULL;
    objPtr = (Tcl_Obj *) basePtr;
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774

775
776
777

778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
















823

824
825
826

















827














828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
#undef OBJS_TO_ALLOC_EACH_TIME

/*
 *----------------------------------------------------------------------
 *
 * TclFreeObj --
 *
 *	This procedure frees the memory associated with the argument
 *	object. It is called by the tcl.h macro Tcl_DecrRefCount when an
 *	object's ref count is zero. It is only "public" since it must
 *	be callable by that macro wherever the macro is used. It should not
 *	be directly called by clients.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates the storage for the object's Tcl_Obj structure
 *	after deallocating the string representation and calling the
 *	type-specific Tcl_FreeInternalRepProc to deallocate the object's
 *	internal representation. If compiling with TCL_COMPILE_STATS,
 *	this procedure increments the global count of freed objects
 *	(tclObjsFreed).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
void
TclFreeObj(objPtr)
    register Tcl_Obj *objPtr;	/* The object to be freed. */
{
    register Tcl_ObjType *typePtr = objPtr->typePtr;

    /*
     * This macro declares a variable, so must come here...
     */

    TclObjInitDeletionContext(context);

    if (objPtr->refCount < -1) {
	Tcl_Panic("Reference count for %lx was negative", objPtr);
    }

    if (TclObjDeletePending(context)) {
	TclPushObjToDelete(context, objPtr);
    } else {
	if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	    TclObjDeletionLock(context);
	    typePtr->freeIntRepProc(objPtr);
	    TclObjDeletionUnlock(context);
	}
	Tcl_InvalidateStringRep(objPtr);

	Tcl_MutexLock(&tclObjMutex);
	ckfree((char *) objPtr);
	Tcl_MutexUnlock(&tclObjMutex);
#ifdef TCL_COMPILE_STATS
	tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
	TclObjDeletionLock(context);
	while (TclObjOnStack(context)) {
	    Tcl_Obj *objToFree;

	    TclPopObjToDelete(context,objToFree);
	    TclFreeIntRep(objToFree);

	    Tcl_MutexLock(&tclObjMutex);
	    ckfree((char *) objToFree);
	    Tcl_MutexUnlock(&tclObjMutex);
#ifdef TCL_COMPILE_STATS
	    tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
	}
	TclObjDeletionUnlock(context);
    }
}
#else /* TCL_MEM_DEBUG */

void
TclFreeObj(objPtr)
    register Tcl_Obj *objPtr;	/* The object to be freed. */
{
















    TclObjInitDeletionContext(context);

    if (TclObjDeletePending(context)) {
	TclPushObjToDelete(context, objPtr);
    } else {

















	TclFreeObjMacro(context, objPtr);














    }
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DuplicateObj --
 *
 *	Create and return a new object that is a duplicate of the argument
 *	object.
 *
 * Results:
 *	The return value is a pointer to a newly created Tcl_Obj. This
 *	object has reference count 0 and the same type, if any, as the
 *	source object objPtr. Also:
 *	  1) If the source object has a valid string rep, we copy it;
 *	     otherwise, the duplicate's string rep is set NULL to mark
 *	     it invalid.
 *	  2) If the source object has an internal representation (i.e. its
 *	     typePtr is non-NULL), the new object's internal rep is set to
 *	     a copy; otherwise the new internal rep is marked invalid.
 *
 * Side effects:
 *	What constitutes "copying" the internal representation depends on
 *	the type. For example, if the argument object is a list,
 *	the element objects it points to will not actually be copied but
 *	will be shared with the duplicate list. That is, the ref counts of
 *	the element objects will be incremented.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_DuplicateObj(objPtr)
    register Tcl_Obj *objPtr;		/* The object to duplicate. */







|
|
|
|
|





|
|
|
|
|
<










>



>
|





|
|


|

|

|







|
|


|









|








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|
|
|

|
|

|
|


|
|
|
|
|







818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839

840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
#undef OBJS_TO_ALLOC_EACH_TIME

/*
 *----------------------------------------------------------------------
 *
 * TclFreeObj --
 *
 *	This procedure frees the memory associated with the argument object.
 *	It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref
 *	count is zero. It is only "public" since it must be callable by that
 *	macro wherever the macro is used. It should not be directly called by
 *	clients.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates the storage for the object's Tcl_Obj structure after
 *	deallocating the string representation and calling the type-specific
 *	Tcl_FreeInternalRepProc to deallocate the object's internal
 *	representation. If compiling with TCL_COMPILE_STATS, this procedure
 *	increments the global count of freed objects (tclObjsFreed).

 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
void
TclFreeObj(objPtr)
    register Tcl_Obj *objPtr;	/* The object to be freed. */
{
    register Tcl_ObjType *typePtr = objPtr->typePtr;

    /*
     * This macro declares a variable, so must come here...
     */

    ObjInitDeletionContext(context);

    if (objPtr->refCount < -1) {
	Tcl_Panic("Reference count for %lx was negative", objPtr);
    }

    if (ObjDeletePending(context)) {
	PushObjToDelete(context, objPtr);
    } else {
	if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	    ObjDeletionLock(context);
	    typePtr->freeIntRepProc(objPtr);
	    ObjDeletionUnlock(context);
	}
	TclInvalidateStringRep(objPtr);

	Tcl_MutexLock(&tclObjMutex);
	ckfree((char *) objPtr);
	Tcl_MutexUnlock(&tclObjMutex);
#ifdef TCL_COMPILE_STATS
	tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
	ObjDeletionLock(context);
	while (ObjOnStack(context)) {
	    Tcl_Obj *objToFree;

	    PopObjToDelete(context,objToFree);
	    TclFreeIntRep(objToFree);

	    Tcl_MutexLock(&tclObjMutex);
	    ckfree((char *) objToFree);
	    Tcl_MutexUnlock(&tclObjMutex);
#ifdef TCL_COMPILE_STATS
	    tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
	}
	ObjDeletionUnlock(context);
    }
}
#else /* TCL_MEM_DEBUG */

void
TclFreeObj(objPtr)
    register Tcl_Obj *objPtr;	/* The object to be freed. */
{
    if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
	/*
	 * objPtr can be freed safely, as it will not attempt to free any
	 * other objects: it will not cause recursive calls to this function.
	 */

	if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) {
	    ckfree((char *) objPtr->bytes);
	}
	TclFreeObjStorage(objPtr);
	TclIncrObjsFreed();
    } else {
	/*
	 * This macro declares a variable, so must come here...
	 */

	ObjInitDeletionContext(context);

	if (ObjDeletePending(context)) {
	    PushObjToDelete(context, objPtr);
	} else {
	    /*
	     * Note that the contents of the while loop assume that the string
	     * rep has already been freed and we don't want to do anything
	     * fancy with adding to the queue inside ourselves. Must take care
	     * to unstack the object first since freeing the internal rep can
	     * add further objects to the stack. The code assumes that it is
	     * the first thing in a block; all current usages in the core
	     * satisfy this.
	     */

	    ObjDeletionLock(context);
	    objPtr->typePtr->freeIntRepProc(objPtr);
	    ObjDeletionUnlock(context);

	    if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) {
		ckfree((char *) objPtr->bytes);
	    }
	    TclFreeObjStorage(objPtr);
	    TclIncrObjsFreed();
	    ObjDeletionLock(context);
	    while (ObjOnStack(context)) {
		Tcl_Obj *objToFree;
		PopObjToDelete(context,objToFree);
		if ((objToFree->typePtr != NULL)
			&& (objToFree->typePtr->freeIntRepProc != NULL)) {
		    objToFree->typePtr->freeIntRepProc(objToFree);
		}
		TclFreeObjStorage(objToFree);
		TclIncrObjsFreed();
	    }
	    ObjDeletionUnlock(context);
	}
    }
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DuplicateObj --
 *
 *	Create and return a new object that is a duplicate of the argument
 *	object.
 *
 * Results:
 *	The return value is a pointer to a newly created Tcl_Obj. This object
 *	has reference count 0 and the same type, if any, as the source object
 *	objPtr. Also:
 *	  1) If the source object has a valid string rep, we copy it;
 *	     otherwise, the duplicate's string rep is set NULL to mark it
 *	     invalid.
 *	  2) If the source object has an internal representation (i.e. its
 *	     typePtr is non-NULL), the new object's internal rep is set to a
 *	     copy; otherwise the new internal rep is marked invalid.
 *
 * Side effects:
 *	What constitutes "copying" the internal representation depends on the
 *	type. For example, if the argument object is a list, the element
 *	objects it points to will not actually be copied but will be shared
 *	with the duplicate list. That is, the ref counts of the element
 *	objects will be incremented.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_DuplicateObj(objPtr)
    register Tcl_Obj *objPtr;		/* The object to duplicate. */
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
 *	representation from the internal representation.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetString(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer
				 * should be returned. */
{
    if (objPtr->bytes != NULL) {
	return objPtr->bytes;
    }

    if (objPtr->typePtr->updateStringProc == NULL) {
	Tcl_Panic("UpdateStringProc should not be invoked for type %s",
		objPtr->typePtr->name);
    }
    (*objPtr->typePtr->updateStringProc)(objPtr);
    return objPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStringFromObj --
 *
 *	Returns the string representation's byte array pointer and length
 *	for an object.
 *
 * Results:
 *	Returns a pointer to the string representation of objPtr. If
 *	lengthPtr isn't NULL, the length of the string representation is
 *	stored at *lengthPtr. The byte array referenced by the returned
 *	pointer must not be modified by the caller. Furthermore, the
 *	caller must copy the bytes if they need to retain them since the
 *	object's string rep can change as a result of other operations.
 *
 * Side effects:
 *	May call the object's updateStringProc to update the string
 *	representation from the internal representation.
 *
 *----------------------------------------------------------------------
 */







|
|


















|
|


|
|
|
|
|
|







1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
 *	representation from the internal representation.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetString(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer should
				 * be returned. */
{
    if (objPtr->bytes != NULL) {
	return objPtr->bytes;
    }

    if (objPtr->typePtr->updateStringProc == NULL) {
	Tcl_Panic("UpdateStringProc should not be invoked for type %s",
		objPtr->typePtr->name);
    }
    (*objPtr->typePtr->updateStringProc)(objPtr);
    return objPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStringFromObj --
 *
 *	Returns the string representation's byte array pointer and length for
 *	an object.
 *
 * Results:
 *	Returns a pointer to the string representation of objPtr. If lengthPtr
 *	isn't NULL, the length of the string representation is stored at
 *	*lengthPtr. The byte array referenced by the returned pointer must not
 *	be modified by the caller. Furthermore, the caller must copy the bytes
 *	if they need to retain them since the object's string rep can change
 *	as a result of other operations.
 *
 * Side effects:
 *	May call the object's updateStringProc to update the string
 *	representation from the internal representation.
 *
 *----------------------------------------------------------------------
 */
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
 *	This procedure is called to invalidate an object's string
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates the storage for any old string representation, then
 *	sets the string representation NULL to mark it invalid.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InvalidateStringRep(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer
				 * should be freed. */
{
    if (objPtr->bytes != NULL) {
	if (objPtr->bytes != tclEmptyStringRep) {
	    ckfree((char *) objPtr->bytes);
	}
	objPtr->bytes = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewBooleanObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new boolean object and
 *	initializes it from the argument boolean value. A nonzero
 *	"boolValue" is coerced to 1.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewBooleanObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|






|
|

<
|
<
|
<
|
<







|
|
|

|
|


|
|







1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117

1118

1119

1120

1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
 *	This procedure is called to invalidate an object's string
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates the storage for any old string representation, then sets
 *	the string representation NULL to mark it invalid.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InvalidateStringRep(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer should
				 * be freed. */
{

    TclInvalidateStringRep(objPtr);

}




/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewBooleanObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
 *	initializes it from the argument boolean value. A nonzero "boolValue"
 *	is coerced to 1.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the result
 *	of calling the debugging version Tcl_DbNewBooleanObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an invalid
 *	string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170



1171
1172
1173

1174









1175
1176

1177


1178






1179



1180

1181




1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217


1218
1219
1220




1221
1222
1223
1224
1225

1226

1227
1228
1229









1230



1231




1232


1233








1234

1235




1236



1237
1238
1239
1240
1241

1242


1243
1244
1245





1246
1247
1248


1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270












1271
1272




1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454

1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474

Tcl_Obj *
Tcl_NewBooleanObj(boolValue)
    register int boolValue;	/* Boolean used to initialize new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclBooleanType;
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewBooleanObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
 *	same as the Tcl_NewBooleanObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command	will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewBooleanObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
    register int boolValue;	/* Boolean used to initialize new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclBooleanType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
    register int boolValue;	/* Boolean used to initialize new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetBooleanObj --
 *
 *	Modify an object to be a boolean object and to have the specified
 *	boolean value. A nonzero "boolValue" is coerced to 1.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetBooleanObj(objPtr, boolValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register int boolValue;	/* Boolean used to set object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetBooleanObj called with shared object");
    }

    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclBooleanType;
    Tcl_InvalidateStringRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBooleanFromObj --
 *
 *	Attempt to return a boolean from the Tcl object "objPtr". If the
 *	object is not already a boolean, an attempt will be made to convert
 *	it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already a boolean, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get boolean. */
    register int *boolPtr;	/* Place to store resulting boolean. */
{



    register int result;

    if (objPtr->typePtr == &tclBooleanType) {

	result = TCL_OK;









    } else {
	result = SetBooleanFromAny(interp, objPtr);

    }









    if (result == TCL_OK) {



	*boolPtr = (int) objPtr->internalRep.longValue;

    }




    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SetBooleanFromAny --
 *
 *	Attempt to generate a boolean internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs during
 *	conversion, an error message is left in the interpreter's result
 *	unless "interp" is NULL.
 *
 * Side effects:
 *	If no error occurs, an integer 1 or 0 is stored as "objPtr"s
 *	internal representation and the type of "objPtr" is set to boolean.
 *
 *----------------------------------------------------------------------
 */

static int
SetBooleanFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    char *string, *end;
    register char c;
    char lowerCase[8];
    int newBool, length;
    register int i;

    /*
     * Get the string representation. Make it up-to-date if necessary.


     */

    string = Tcl_GetStringFromObj(objPtr, &length);





    /*
     * Use the obvious shortcuts for numerical values; if objPtr is not
     * of numerical type, parse its string rep.
     */



    if (objPtr->typePtr == &tclIntType) {
	newBool = (objPtr->internalRep.longValue != 0);
	goto goodBoolean;









    } else if (objPtr->typePtr == &tclDoubleType) {



	newBool = (objPtr->internalRep.doubleValue != 0.0);




	goto goodBoolean;


    } else if (objPtr->typePtr == &tclWideIntType) {








	newBool = (objPtr->internalRep.wideValue != 0);

	goto goodBoolean;




    }




    /*
     * Parse the string as a boolean. We use an implementation here
     * that doesn't report errors in interp if interp is NULL.
     *

     * First we define a macro to factor out the to-lower-case code.


     * The len parameter is the maximum number of characters to copy
     * to allow the following comparisons to proceed correctly,
     * including (properly) the trailing \0 character.  This is done





     * in multiple places so the number of copying steps is minimised
     * and only performed when needed.
     */



#define SBFA_TOLOWER(len)					\
	for (i=0 ; i<(len) && i<length ; i++) {			\
	    c = string[i];					\
	    if (c & 0x80) {					\
		goto badBoolean;				\
	    }							\
	    if (Tcl_UniCharIsUpper(UCHAR(c))) {			\
		c = (char) Tcl_UniCharToLower(UCHAR(c));	\
	    }							\
	    lowerCase[i] = c;					\
	}							\
	lowerCase[i] = 0;

    switch (string[0]) {
    case 'y': case 'Y':
	/*
	 * Copy the string converting its characters to lower case.
	 * This also weeds out international characters so we can
	 * safely operate on single bytes.
	 */













	SBFA_TOLOWER(4);





	/*
	 * Checking the 'y' is redundant, but makes the code clearer.
	 */
	if (strncmp(lowerCase, "yes", (size_t) length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	}
	goto badBoolean;
    case 'n': case 'N':
	SBFA_TOLOWER(3);
	if (strncmp(lowerCase, "no", (size_t) length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	goto badBoolean;
    case 't': case 'T':
	SBFA_TOLOWER(5);
	if (strncmp(lowerCase, "true", (size_t) length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	}
	goto badBoolean;
    case 'f': case 'F':
	SBFA_TOLOWER(6);
	if (strncmp(lowerCase, "false", (size_t) length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	goto badBoolean;
    case 'o': case 'O':
	if (length < 2) {
	    goto badBoolean;
	}
	SBFA_TOLOWER(4);
	if (strncmp(lowerCase, "on", (size_t) length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	goto badBoolean;
#undef SBFA_TOLOWER
    case '0':
	if (string[1] == '\0') {
	    newBool = 0;
	    goto goodBoolean;
	}
	goto parseNumeric;
    case '1':
	if (string[1] == '\0') {
	    newBool = 1;
	    goto goodBoolean;
	}
	/* deliberate fall-through */
    default:
    parseNumeric:
	{
	    double dbl;
	    /*
	     * Boolean values can be extracted from ints or doubles.
	     * Note that we don't use strtoul or strtoull here because
	     * we don't care about what the value is, just whether it
	     * is equal to zero or not.
	     */
#ifdef TCL_WIDE_INT_IS_LONG
	    newBool = strtol(string, &end, 0);
	    if (end != string) {
		/*
		 * Make sure the string has no garbage after the end of
		 * the int.
		 */
		while ((end < (string+length))
			&& isspace(UCHAR(*end))) { /* INTL: ISO only */
		    end++;
		}
		if (end == (string+length)) {
		    newBool = (newBool != 0);
		    goto goodBoolean;
		}
	    }
#else /* !TCL_WIDE_INT_IS_LONG */
	    Tcl_WideInt wide = strtoll(string, &end, 0);
	    if (end != string) {
		/*
		 * Make sure the string has no garbage after the end of
		 * the wide int.
		 */
		while ((end < (string+length))
			&& isspace(UCHAR(*end))) { /* INTL: ISO only */
		    end++;
		}
		if (end == (string+length)) {
		    newBool = (wide != Tcl_LongAsWide(0));
		    goto goodBoolean;
		}
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    /*
	     * Still might be a string containing the characters
	     * representing an int or double that wasn't handled
	     * above. This would be a string like "27" or "1.0" that
	     * is non-zero and not "1". Such a string would result in
	     * the boolean value true. We try converting to double. If
	     * that succeeds and the resulting double is non-zero, we
	     * have a "true".  Note that numbers can't have embedded
	     * NULLs.
	     */

	    dbl = strtod(string, &end);
	    if (end == string) {
		goto badBoolean;
	    }

	    /*
	     * Make sure the string has no garbage after the end of
	     * the double.
	     */

	    while ((end < (string+length))
		    && isspace(UCHAR(*end))) { /* INTL: ISO only */
		end++;
	    }
	    if (end != (string+length)) {
		goto badBoolean;
	    }
	    newBool = (dbl != 0.0);
	}
    }

    /*
     * Free the old internalRep before setting the new one. We do this as
     * late as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

    goodBoolean:
    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = newBool;
    objPtr->typePtr = &tclBooleanType;
    return TCL_OK;

    badBoolean:
    if (interp != NULL) {
	Tcl_Obj *msg =
		Tcl_NewStringObj("expected boolean value but got \"", -1);
	TclAppendLimitedToObj(msg, string, length, 50, "");
	Tcl_AppendToObj(msg, "\"", -1);
	Tcl_SetObjResult(interp, msg);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfBoolean --
 *
 *	Update the string representation for a boolean object.
 *	Note: This procedure does not free an existing old string rep
 *	so storage will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the boolean-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfBoolean(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
{
    char *s = ckalloc((unsigned) 2);

    s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
    s[1] = '\0';
    objPtr->bytes = s;
    objPtr->length = 1;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewDoubleObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new double object and
 *	initializes it from the argument double value.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewDoubleObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.







|
<
<
<
<














|






|
|














|
|







|










|
|

















|
|













|
<
<
<







|
|
<







<
|










>
>
>
|
|
|
>
|
>
>
>
>
>
>
>
>
>
|
|
>
|
>
>
|
>
>
>
>
>
>
|
>
>
>
|
>
|
>
>
>
>
|
















|
|









<
<
<
<
<
<

|
>
>


|
>
>
>
>
|
<
<
<
<
>
|
>
|
<
|
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
|
>
>
>
|
<
<
<
|
>
|
>
>
|
<
<
>
>
>
>
>
|
<
<
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<

<
<
|
|
|
<
|

>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>







|
|
<




|
|
<




|
|
<




|
|

|

<







<
|
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|

|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|



|





|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
<
>











|
|







1156
1157
1158
1159
1160
1161
1162
1163




1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255



1256
1257
1258
1259
1260
1261
1262
1263
1264

1265
1266
1267
1268
1269
1270
1271

1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351






1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363




1364
1365
1366
1367

1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410



1411
1412
1413
1414
1415
1416


1417
1418
1419
1420
1421
1422


1423
1424
1425












1426


1427
1428
1429

1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458

1459
1460
1461
1462
1463
1464

1465
1466
1467
1468
1469
1470

1471
1472
1473
1474
1475
1476
1477
1478
1479

1480
1481
1482
1483
1484
1485
1486

1487












1488




















































1489



1490
1491
1492
















1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504









1505

























1506

1507

1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528

Tcl_Obj *
Tcl_NewBooleanObj(boolValue)
    register int boolValue;	/* Boolean used to initialize new object. */
{
    register Tcl_Obj *objPtr;

    TclNewBooleanObj(objPtr, boolValue);




    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewBooleanObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
 *	same as the Tcl_NewBooleanObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewBooleanObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an invalid
 *	string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
    register int boolValue;	/* Boolean used to initialize new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclIntType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
    register int boolValue;	/* Boolean used to initialize new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetBooleanObj --
 *
 *	Modify an object to be a boolean object and to have the specified
 *	boolean value. A nonzero "boolValue" is coerced to 1.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old internal
 *	rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetBooleanObj(objPtr, boolValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register int boolValue;	/* Boolean used to set object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetBooleanObj called with shared object");
    }

    TclSetBooleanObj(objPtr, boolValue);



}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBooleanFromObj --
 *
 *	Attempt to return a boolean from the Tcl object "objPtr". This
 *	includes conversion from any of Tcl's numeric types.

 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:

 *	The intrep of *objPtr may be changed.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get boolean. */
    register int *boolPtr;	/* Place to store resulting boolean. */
{
    do {
	if (objPtr->typePtr == &tclIntType) {
	    *boolPtr = (objPtr->internalRep.longValue != 0);
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclBooleanType) {
	    *boolPtr = (int) objPtr->internalRep.longValue;
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclDoubleType) {
	    /*
	     * Caution: Don't be tempted to check directly for the "double"
	     * Tcl_ObjType and then compare the intrep to 0.0. This isn't
	     * reliable because a "double" Tcl_ObjType can hold the NaN value.
	     * Use the API Tcl_GetDoubleFromObj, which does the checking and
	     * sets the proper error message for us.
	     */
            double d;
	    if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
		return TCL_ERROR;
	    }
	    *boolPtr = (d != 0.0);
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclBignumType) {
#ifdef BIGNUM_AUTO_NARROW
	    *boolPtr = 1;
#else
	    *boolPtr = ((objPtr->internalRep.ptrAndLongRep.value & 0x7fff)!=0);
#endif
	    return TCL_OK;
	}
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {
	    *boolPtr = (objPtr->internalRep.wideValue != 0);
	    return TCL_OK;
	}
#endif
    } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
	    TclParseNumber(interp, objPtr, "boolean value",
			   NULL, -1, NULL, 0)));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SetBooleanFromAny --
 *
 *	Attempt to generate a boolean internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs during
 *	conversion, an error message is left in the interpreter's result
 *	unless "interp" is NULL.
 *
 * Side effects:
 *	If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal
 *	representation and the type of "objPtr" is set to boolean.
 *
 *----------------------------------------------------------------------
 */

static int
SetBooleanFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{






    /*
     * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
     * whether a boolean conversion is possible without generating the string
     * rep.
     */

    if (objPtr->bytes == NULL) {
	if (objPtr->typePtr == &tclIntType) {
	    switch (objPtr->internalRep.longValue) {
	    case 0L: case 1L:
		return TCL_OK;
	    }




	    goto badBoolean;
	}
#ifdef BIGNUM_AUTO_NARROW
	if (objPtr->typePtr == &tclBignumType) {

	    goto badBoolean;
	}
#else
	/* TODO: Consider tests to discover values 0 and 1 while preserving
	 * pure bignum.  For now, pass through string rep. */
#endif
#ifndef NO_WIDE_TYPE
	/* TODO: Consider tests to discover values 0 and 1 while preserving
	 * pure wide.  For now, pass through string rep. */
#endif
	if (objPtr->typePtr == &tclDoubleType) {
	    goto badBoolean;
	}
    }

    if (ParseBoolean(objPtr) == TCL_OK) {
	return TCL_OK;
    }

  badBoolean:
    if (interp != NULL) {
	int length;
	char *str = Tcl_GetStringFromObj(objPtr, &length);
	Tcl_Obj *msg =
		Tcl_NewStringObj("expected boolean value but got \"", -1);
	TclAppendLimitedToObj(msg, str, length, 50, "");
	Tcl_AppendToObj(msg, "\"", -1);
	Tcl_SetObjResult(interp, msg);
    }
    return TCL_ERROR;
}

static int
ParseBoolean(objPtr)
    register Tcl_Obj *objPtr;	/* The object to parse/convert. */
{
    int i, length, newBool;
    char lowerCase[6], *str = Tcl_GetStringFromObj(objPtr, &length);

    if ((length == 0) || (length > 5)) {
	/* longest valid boolean string rep. is "false" */
	return TCL_ERROR;
    }




    switch (str[0]) {
    case '0':
	if (length == 1) {
	    newBool = 0;
	    goto numericBoolean;


	}
	return TCL_ERROR;
    case '1':
	if (length == 1) {
	    newBool = 1;
	    goto numericBoolean;


	}
	return TCL_ERROR;
    }















    /*
     * Force to lower case for case-insensitive detection.  Filter out known
     * invalid characters at the same time.

     */

    for (i=0; i < length; i++) {
	char c = str[i];
	switch (c) {
	case 'A': case 'E': case 'F': case 'L': case 'N':
	case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y':
	    lowerCase[i] = c + (char) ('a' - 'A');
	    break;
	case 'a': case 'e': case 'f': case 'l': case 'n':
	case 'o': case 'r': case 's': case 't': case 'u': case 'y':
	    lowerCase[i] = c;
	    break;
	default:
	    return TCL_ERROR;
	}
    }
    lowerCase[length] = 0;
    switch (lowerCase[0]) {
    case 'y':
	/*
	 * Checking the 'y' is redundant, but makes the code clearer.
	 */
	if (strncmp(lowerCase, "yes", (size_t) length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'n':

	if (strncmp(lowerCase, "no", (size_t) length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 't':

	if (strncmp(lowerCase, "true", (size_t) length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'f':

	if (strncmp(lowerCase, "false", (size_t) length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'o':
	if (length < 2) {
	    return TCL_ERROR;
	}

	if (strncmp(lowerCase, "on", (size_t) length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}

	return TCL_ERROR;












    default:




















































	return TCL_ERROR;



    }

    /*
















     * Free the old internalRep before setting the new one. We do this as late
     * as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

  goodBoolean:
    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = newBool;
    objPtr->typePtr = &tclBooleanType;
    return TCL_OK;

  numericBoolean:









    TclFreeIntRep(objPtr);

























    objPtr->internalRep.longValue = newBool;

    objPtr->typePtr = &tclIntType;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewDoubleObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new double object and
 *	initializes it from the argument double value.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the result
 *	of calling the debugging version Tcl_DbNewDoubleObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629







1630

1631
1632
1633
1634





1635

1636
1637
1638

1639


1640
1641
1642
1643
1644
1645
1646
1647

Tcl_Obj *
Tcl_NewDoubleObj(dblValue)
    register double dblValue;	/* Double used to initialize the object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;

    objPtr->internalRep.doubleValue = dblValue;
    objPtr->typePtr = &tclDoubleType;
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewDoubleObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new double objects. It is the
 *	same as the Tcl_NewDoubleObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command	will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewDoubleObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
    register double dblValue;	/* Double used to initialize the object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.doubleValue = dblValue;
    objPtr->typePtr = &tclDoubleType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
    register double dblValue;	/* Double used to initialize the object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetDoubleObj --
 *
 *	Modify an object to be a double object and to have the specified
 *	double value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetDoubleObj(objPtr, dblValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register double dblValue;	/* Double used to set the object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetDoubleObj called with shared object");
    }

    TclFreeIntRep(objPtr);
    objPtr->internalRep.doubleValue = dblValue;
    objPtr->typePtr = &tclDoubleType;
    Tcl_InvalidateStringRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetDoubleFromObj --
 *
 *	Attempt to return a double from the Tcl object "objPtr". If the
 *	object is not already a double, an attempt will be made to convert
 *	it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already a double, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a double. */
    register double *dblPtr;	/* Place to store resulting double. */
{
    register int result;

    if (objPtr->typePtr == &tclDoubleType) {
	*dblPtr = objPtr->internalRep.doubleValue;







	return TCL_OK;

    } else if (objPtr->typePtr == &tclIntType) {
	*dblPtr = objPtr->internalRep.longValue;
	return TCL_OK;
    }







    result = SetDoubleFromAny(interp, objPtr);
    if (result == TCL_OK) {
	*dblPtr = objPtr->internalRep.doubleValue;

    }


    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SetDoubleFromAny --
 *







|
<
<
<
<














|






|
|














|
|


















|
|

















|
|













|
<
<
<







|
|
<







|
|










<
|
|
|
>
>
>
>
>
>
>
|
>
|
|
|
|
>
>
>
>
>
|
>
|
<
|
>
|
>
>
|







1544
1545
1546
1547
1548
1549
1550
1551




1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643



1644
1645
1646
1647
1648
1649
1650
1651
1652

1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671

1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695

1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708

Tcl_Obj *
Tcl_NewDoubleObj(dblValue)
    register double dblValue;	/* Double used to initialize the object. */
{
    register Tcl_Obj *objPtr;

    TclNewDoubleObj(objPtr, dblValue);




    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewDoubleObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new double objects. It is the
 *	same as the Tcl_NewDoubleObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewDoubleObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an invalid
 *	string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
    register double dblValue;	/* Double used to initialize the object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.doubleValue = dblValue;
    objPtr->typePtr = &tclDoubleType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
    register double dblValue;	/* Double used to initialize the object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetDoubleObj --
 *
 *	Modify an object to be a double object and to have the specified
 *	double value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old internal
 *	rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetDoubleObj(objPtr, dblValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register double dblValue;	/* Double used to set the object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetDoubleObj called with shared object");
    }

    TclSetDoubleObj(objPtr, dblValue);



}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetDoubleFromObj --
 *
 *	Attempt to return a double from the Tcl object "objPtr". If the object
 *	is not already a double, an attempt will be made to convert it to one.

 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already a double, the conversion will free any
 *	old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a double. */
    register double *dblPtr;	/* Place to store resulting double. */
{

    do {
	if (objPtr->typePtr == &tclDoubleType) {
	    if (TclIsNaN(objPtr->internalRep.doubleValue)) {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "floating point value is Not a Number", -1));
		}
		return TCL_ERROR;
	    }
	    *dblPtr = (double) objPtr->internalRep.doubleValue;
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclIntType) {
	    *dblPtr = objPtr->internalRep.longValue;
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclBignumType) {
	    mp_int big;
	    UNPACK_BIGNUM( objPtr, big );
	    *dblPtr = TclBignumToDouble( &big );
	    return TCL_OK;
	}
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {

	    *dblPtr = (double) objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
#endif
    } while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SetDoubleFromAny --
 *
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
 */

static int
SetDoubleFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    char *string, *end;
    double newDouble;
    int length;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Now parse "objPtr"s string as an double. Numbers can't have embedded
     * NULLs. We use an implementation here that doesn't report errors in
     * interp if interp is NULL.
     */

    errno = 0;
    newDouble = strtod(string, &end);
    if (end == string) {
	badDouble:
	if (interp != NULL) {
	    Tcl_Obj *msg = Tcl_NewStringObj(
		    "expected floating-point number but got \"", -1);
	    TclAppendLimitedToObj(msg, string, length, 50, "");
	    Tcl_AppendToObj(msg, "\"", -1);
	    Tcl_SetObjResult(interp, msg);
	}
	return TCL_ERROR;
    }
    if (errno != 0) {
	if (interp != NULL) {
	    TclExprFloatError(interp, newDouble);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the string has no garbage after the end of the double.
     */

    while ((end < (string+length))
	    && isspace(UCHAR(*end))) { /* INTL: ISO space. */
	end++;
    }
    if (end != (string+length)) {
	goto badDouble;
    }

    /*
     * The conversion to double succeeded. Free the old internalRep before
     * setting the new one. We do this as late as possible to allow the
     * conversion code, in particular Tcl_GetStringFromObj, to use that old
     * internalRep.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.doubleValue = newDouble;
    objPtr->typePtr = &tclDoubleType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfDouble --
 *
 *	Update the string representation for a double-precision floating
 *	point object. This must obey the current tcl_precision value for
 *	double-to-string conversions. Note: This procedure does not free an
 *	existing old string rep so storage will be lost if this has not
 *	already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the double-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfDouble(objPtr)
    register Tcl_Obj *objPtr;	/* Double obj with string rep to update. */







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
<
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<




|
|








|
|







1722
1723
1724
1725
1726
1727
1728






















1729












1730



1731



1732




1733













1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
 */

static int
SetDoubleFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{






















    return TclParseNumber( interp, objPtr, "floating-point number",












			   NULL, -1, NULL, 0);



}








/*













 *----------------------------------------------------------------------
 *
 * UpdateStringOfDouble --
 *
 *	Update the string representation for a double-precision floating point
 *	object. This must obey the current tcl_precision value for
 *	double-to-string conversions. Note: This procedure does not free an
 *	existing old string rep so storage will be lost if this has not
 *	already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from the
 *	double-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfDouble(objPtr)
    register Tcl_Obj *objPtr;	/* Double obj with string rep to update. */
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewIntObj to create a new integer object end up calling the
 *	debugging procedure Tcl_DbNewLongObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewIntObj result in a call to one of the two
 *	Tcl_NewIntObj implementations below. We provide two implementations
 *	so that the Tcl core can be compiled to do memory debugging of the
 *	core even if a client does not request it for itself.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by
 *	an int.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|



|
|


|
|







1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewIntObj to create a new integer object end up calling the
 *	debugging procedure Tcl_DbNewLongObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewIntObj result in a call to one of the two
 *	Tcl_NewIntObj implementations below. We provide two implementations so
 *	that the Tcl core can be compiled to do memory debugging of the core
 *	even if a client does not request it for itself.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by an
 *	int.
 *
 * Results:
 *	The newly created object is returned. This object will have an invalid
 *	string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929

1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130

Tcl_Obj *
Tcl_NewIntObj(intValue)
    register int intValue;	/* Int used to initialize the new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = (long)intValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetIntObj --
 *
 *	Modify an object to be an integer and to have the specified integer
 *	value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetIntObj(objPtr, intValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register int intValue;	/* Integer used to set object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetIntObj called with shared object");
    }

    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = (long) intValue;
    objPtr->typePtr = &tclIntType;
    Tcl_InvalidateStringRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetIntFromObj --
 *
 *	Attempt to return an int from the Tcl object "objPtr". If the object
 *	is not already an int, an attempt will be made to convert it to one.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by
 *	an int.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion or if the long integer held by the object
 *	can not be represented by an int, an error message is left in
 *	the interpreter's result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntFromObj(interp, objPtr, intPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a int. */
    register int *intPtr;	/* Place to store resulting int. */
{
    register long l = 0;
    int result;

    /* If the object isn't already an integer of any width, try to
     * convert it to one.
     */

    if (objPtr->typePtr != &tclIntType
	    && objPtr->typePtr != &tclWideIntType) {
	result = SetIntOrWideFromAny(interp, objPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    /* Object should now be either int or wide. Get its value. */

    if (objPtr->typePtr == &tclIntType) {
	l = objPtr->internalRep.longValue;
    } else if (objPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
	/*
	 * If the object is already a wide integer, don't convert it.
	 * This code allows for any integer in the range -ULONG_MAX to
	 * ULONG_MAX to be converted to a long, ignoring overflow.
	 * The rule preserves existing semantics for conversion of
	 * integers on input, but avoids inadvertent demotion of
	 * wide integers to 32-bit ones in the internal rep.
	 */
	Tcl_WideInt w = objPtr->internalRep.wideValue;
	if (w >= -(Tcl_WideInt)(ULONG_MAX)
		&& w <= (Tcl_WideInt)(ULONG_MAX)) {
	    l = Tcl_WideAsLong(w);
	} else {
	    goto tooBig;
	}
#else
	l = objPtr->internalRep.longValue;
#endif
    } else {
	Tcl_Panic("string->integer conversion failed to convert the obj.");
    }


    if (((long)((int)l)) == l) {
	*intPtr = (int)l;
	return TCL_OK;
    }
#ifndef TCL_WIDE_INT_IS_LONG
  tooBig:
#endif
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"integer value too large to represent as non-long integer",
		-1));
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SetIntFromAny --
 *
 *	Attempts to force the internal representation for a Tcl object
 *	to tclIntType, specifically.
 *
 * Results:
 *	The return value is a standard object Tcl result.  If an
 *	error occurs during conversion, an error message is left in
 *	the interpreter's result unless "interp" is NULL.
 *
 *----------------------------------------------------------------------
 */

static int
SetIntFromAny(interp, objPtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* objPtr;		/* Pointer to the object to convert */
{
    int result;

    result = SetIntOrWideFromAny(interp, objPtr);
    if (result != TCL_OK) {
	return result;
    }
    if (objPtr->typePtr != &tclIntType) {
	if (interp != NULL) {
	    CONST char *s = "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SetIntOrWideFromAny --
 *
 *	Attempt to generate an integer internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is a standard object Tcl result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If no error occurs, an int is stored as "objPtr"s internal
 *	representation.
 *
 *----------------------------------------------------------------------
 */

static int
SetIntOrWideFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    char *string, *end;
    int length;
    register char *p;
    unsigned long newLong;
    int isNegative = 0;
    int isWide = 0;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    p = string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Now parse "objPtr"s string as an int. We use an implementation here
     * that doesn't report errors in interp if interp is NULL. Note: use
     * strtoul instead of strtol for integer conversions to allow full-size
     * unsigned numbers, but don't depend on strtoul to handle sign
     * characters; it won't in some implementations.
     */

    errno = 0;
    for (; isspace(UCHAR(*p)) ; p++) {	/* INTL: ISO space. */
	/* Empty loop body. */
    }
    if (*p == '-') {
	isNegative = 1;
	p++;
    } else if (*p == '+') {
	p++;
    }
    if (!isdigit(UCHAR(*p))) {
      badInteger:
	if (interp != NULL) {
	    Tcl_Obj *msg =
		    Tcl_NewStringObj("expected integer but got \"", -1);
	    TclAppendLimitedToObj(msg, string, length, 50, "");
	    Tcl_AppendToObj(msg, "\"", -1);
	    Tcl_SetObjResult(interp, msg);
	    TclCheckBadOctal(interp, string);
	}
	return TCL_ERROR;
    }
    newLong = strtoul(p, &end, 0);
    if (end == p) {
	goto badInteger;
    }
    if (errno == ERANGE) {
	if (interp != NULL) {
	    CONST char *s = "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the string has no garbage after the end of the int.
     */

    while ((end < (string+length))
	    && isspace(UCHAR(*end))) { /* INTL: ISO space. */
	end++;
    }
    if (end != (string+length)) {
	goto badInteger;
    }

    /*
     * If the resulting integer will exceed the range of a long,
     * put it into a wide instead.  (Tcl Bug #868489)
     */

#ifndef TCL_WIDE_INT_IS_LONG
    if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
	    || (!isNegative && newLong > LONG_MAX)) {
	isWide = 1;
    }
#endif

    /*
     * The conversion to int succeeded. Free the old internalRep before
     * setting the new one. We do this as late as possible to allow the
     * conversion code, in particular Tcl_GetStringFromObj, to use that old
     * internalRep.
     */

    TclFreeIntRep(objPtr);
    if (isWide) {
	objPtr->internalRep.wideValue =
		(isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
	objPtr->typePtr = &tclWideIntType;
    } else {
	objPtr->internalRep.longValue =
		(isNegative ? -(long)newLong : (long)newLong);
	objPtr->typePtr = &tclIntType;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfInt --
 *
 *	Update the string representation for an integer object.
 *	Note: This procedure does not free an existing old string rep
 *	so storage will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the int-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfInt(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */







|
<
<
<
<
















|
|













|
<
<
<












|
|



|
|
|


|
|










|
<

<
<
<
|
<
<
<
<
|
|
<
|
<
|
<
<
<
<
|
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
|
<
<
<
|
>
|
<
|
|
<
<
<
<
<
<
<
<
<
<







|
|


|
|
|









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







|
|
|





|
|







1811
1812
1813
1814
1815
1816
1817
1818




1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850



1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885

1886



1887




1888
1889

1890

1891




1892




1893





1894




1895



1896
1897
1898

1899
1900










1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923













































1924





























































































1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949

Tcl_Obj *
Tcl_NewIntObj(intValue)
    register int intValue;	/* Int used to initialize the new object. */
{
    register Tcl_Obj *objPtr;

    TclNewIntObj(objPtr, intValue);




    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetIntObj --
 *
 *	Modify an object to be an integer and to have the specified integer
 *	value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old internal
 *	rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetIntObj(objPtr, intValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register int intValue;	/* Integer used to set object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetIntObj called with shared object");
    }

    TclSetIntObj(objPtr, intValue);



}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetIntFromObj --
 *
 *	Attempt to return an int from the Tcl object "objPtr". If the object
 *	is not already an int, an attempt will be made to convert it to one.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by an
 *	int.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion or if the long integer held by the object can not be
 *	represented by an int, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int, the conversion will free any old
 *	internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntFromObj(interp, objPtr, intPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a int. */
    register int *intPtr;	/* Place to store resulting int. */
{
    long l;





    if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) {




	return TCL_ERROR;
    }

    if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {

	if (interp != NULL) {




	    CONST char *s




		= "integer value too large to represent as non-long integer";





	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));




	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);



	}
	return TCL_ERROR;
    }

    *intPtr = (int)l;
    return TCL_OK;










}

/*
 *----------------------------------------------------------------------
 *
 * SetIntFromAny --
 *
 *	Attempts to force the internal representation for a Tcl object to
 *	tclIntType, specifically.
 *
 * Results:
 *	The return value is a standard object Tcl result.  If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 *----------------------------------------------------------------------
 */

static int
SetIntFromAny(interp, objPtr)
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* objPtr;		/* Pointer to the object to convert */
{













































    long l;





























































































    return Tcl_GetLongFromObj(interp, objPtr, &l);
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfInt --
 *
 *	Update the string representation for an integer object.  Note: This
 *	procedure does not free an existing old string rep so storage will be
 *	lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from the
 *	int-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfInt(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewLongObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewLongObj to create a new long integer object end up calling
 *	the debugging procedure Tcl_DbNewLongObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewLongObj result in a call to one of the two
 *	Tcl_NewLongObj implementations below. We provide two implementations
 *	so that the Tcl core can be compiled to do memory debugging of the
 *	core even if a client does not request it for itself.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by
 *	an int.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|









|
|


|
|







1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewLongObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewLongObj to create a new long integer object end up calling the
 *	debugging procedure Tcl_DbNewLongObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewLongObj result in a call to one of the two
 *	Tcl_NewLongObj implementations below. We provide two implementations
 *	so that the Tcl core can be compiled to do memory debugging of the
 *	core even if a client does not request it for itself.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by an
 *	int.
 *
 * Results:
 *	The newly created object is returned. This object will have an invalid
 *	string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350

2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361

2362
2363
2364
2365
2366
2367




2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388

2389
2390
2391


2392

2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418




2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477

2478
2479

2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513

2514

2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
Tcl_Obj *
Tcl_NewLongObj(longValue)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewLongObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
 *	long integer objects end up calling the debugging procedure
 *	Tcl_DbNewLongObj instead. We provide two implementations of
 *	Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
 *	memory debugging of the core is independent of whether a client
 *	requests debugging for itself.
 *
 *	When the core is compiled with TCL_MEM_DEBUG defined,
 *	Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
 *	line number from its caller. This simplifies debugging since then
 *	the [memory active] command will report the caller's file name and
 *	line number when reporting objects that haven't been freed.
 *
 *	Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
 *	this procedure just returns the result of calling Tcl_NewLongObj.
 *
 * Results:
 *	The newly created long integer object is returned. This object
 *	will have an invalid string representation. The returned object has
 *	ref count 0.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewLongObj(longValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetLongObj --
 *
 *	Modify an object to be an integer object and to have the specified
 *	long integer value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetLongObj(objPtr, longValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register long longValue;	/* Long integer used to initialize the
				 * object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetLongObj called with shared object");
    }

    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
    Tcl_InvalidateStringRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetLongFromObj --
 *
 *	Attempt to return an long integer from the Tcl object "objPtr". If
 *	the object is not already an int object, an attempt will be made to
 *	convert it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int object, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetLongFromObj(interp, objPtr, longPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a long. */
    register long *longPtr;	/* Place to store resulting long. */
{
    register int result;

    if (objPtr->typePtr != &tclIntType
	    && objPtr->typePtr != &tclWideIntType) {
	result = SetIntOrWideFromAny(interp, objPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

#ifndef TCL_WIDE_INT_IS_LONG
    if (objPtr->typePtr == &tclWideIntType) {
	/*
	 * If the object is already a wide integer, don't convert it.
	 * This code allows for any integer in the range -ULONG_MAX to
	 * ULONG_MAX to be converted to a long, ignoring overflow.
	 * The rule preserves existing semantics for conversion of
	 * integers on input, but avoids inadvertent demotion of
	 * wide integers to 32-bit ones in the internal rep.
	 */

	Tcl_WideInt w = objPtr->internalRep.wideValue;
	if (w >= -(Tcl_WideInt)(ULONG_MAX)
		&& w <= (Tcl_WideInt)(ULONG_MAX)) {
	    *longPtr = Tcl_WideAsLong(w);
	    return TCL_OK;
	} else {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"integer value too large to represent", -1));
	    }
	    return TCL_ERROR;

	}
    }
#endif

    *longPtr = objPtr->internalRep.longValue;
    return TCL_OK;




}

/*
 *----------------------------------------------------------------------
 *
 * SetWideIntFromAny --
 *
 *	Attempt to generate an integer internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is a standard object Tcl result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If no error occurs, an int is stored as "objPtr"s internal
 *	representation.
 *
 *----------------------------------------------------------------------
 */


static int
SetWideIntFromAny(interp, objPtr)


    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */

    register Tcl_Obj *objPtr;	/* The object to convert. */
{
#ifndef TCL_WIDE_INT_IS_LONG
    char *string, *end;
    int length;
    register char *p;
    Tcl_WideInt newWide;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    p = string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Now parse "objPtr"s string as an int. We use an implementation here
     * that doesn't report errors in interp if interp is NULL. Note: use
     * strtoull instead of strtoll for integer conversions to allow full-size
     * unsigned numbers, but don't depend on strtoull to handle sign
     * characters; it won't in some implementations.
     */

    errno = 0;
#ifdef TCL_STRTOUL_SIGN_CHECK
    for (; isspace(UCHAR(*p)) ; p++) {	/* INTL: ISO space. */
	/* Empty loop body. */




    }
    if (*p == '-') {
	p++;
	newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
    } else if (*p == '+') {
	p++;
	newWide = strtoull(p, &end, 0);
    } else
#else
	newWide = strtoull(p, &end, 0);
#endif
    if (end == p) {
	badInteger:
	if (interp != NULL) {
	    Tcl_Obj *msg =
		    Tcl_NewStringObj("expected integer but got \"", -1);
	    TclAppendLimitedToObj(msg, string, length, 50, "");
	    Tcl_AppendToObj(msg, "\"", -1);
	    Tcl_SetObjResult(interp, msg);
	    TclCheckBadOctal(interp, string);
	}
	return TCL_ERROR;
    }
    if (errno == ERANGE) {
	if (interp != NULL) {
	    CONST char *s = "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the string has no garbage after the end of the int.
     */

    while ((end < (string+length))
	    && isspace(UCHAR(*end))) { /* INTL: ISO space. */
	end++;
    }
    if (end != (string+length)) {
	goto badInteger;
    }

    /*
     * The conversion to int succeeded. Free the old internalRep before
     * setting the new one. We do this as late as possible to allow the
     * conversion code, in particular Tcl_GetStringFromObj, to use that old
     * internalRep.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.wideValue = newWide;
#else
    if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
	return TCL_ERROR;
    }
#endif
    objPtr->typePtr = &tclWideIntType;

    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfWideInt --
 *
 *	Update the string representation for a wide integer object.
 *	Note: This procedure does not free an existing old string rep
 *	so storage will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the wideInt-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

#ifndef TCL_WIDE_INT_IS_LONG
static void
UpdateStringOfWideInt(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
{
    char buffer[TCL_INTEGER_SPACE+2];
    register unsigned len;
    register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;

    /*
     * Note that sprintf will generate a compiler warning under
     * Mingw claiming %I64 is an unknown format specifier.
     * Just ignore this warning. We can't use %L as the format
     * specifier since that gets printed as a 32 bit value.

     */

    sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
    len = strlen(buffer);
    objPtr->bytes = ckalloc((unsigned) len + 1);
    memcpy(objPtr->bytes, buffer, len + 1);
    objPtr->length = len;
}
#endif /* TCL_WIDE_INT_IS_LONG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewWideIntObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
 *	the debugging procedure Tcl_DbNewWideIntObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewWideIntObj result in a call to one of the two
 *	Tcl_NewWideIntObj implementations below. We provide two implementations
 *	so that the Tcl core can be compiled to do memory debugging of the
 *	core even if a client does not request it for itself.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
<
<
<
<










|
|
|
|
<
|

|
|
|
|
|





|
|
|











|
|


|
|















|
|


|
|

















|
|














<
|
<
<







|
|




















<
|
|
|
<
<
|

<
|
<
|
|
<
|
|
|
|
|
|
>
|
|
|
|
|
<
<
<
<

<
>

<

|
|
|
>
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
<
|
>
>
|
>
|
<
<
<
|
<
<
|
<
<
<
|
<
|
<
<
<
<
<
<
<
|
<
<
<
|
>
>
>
>
|
|
<
|
<
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
<
<
<
|
|
<
<
<
|
<
<
|
<
|
|
<
|
<
|
<
<
|
<
|
<
<
<
<
|
|
<
|
>
|

>






|
|
|





|
|




<









|
|
<
|
>

>






|












|
|
|


|
|







2004
2005
2006
2007
2008
2009
2010
2011




2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025

2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111

2112


2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141

2142
2143
2144


2145
2146

2147

2148
2149

2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161




2162

2163
2164

2165
2166
2167
2168
2169
2170
2171
2172
2173




















2174
2175

2176
2177
2178
2179
2180
2181



2182


2183



2184

2185







2186



2187
2188
2189
2190
2191
2192
2193

2194



2195

2196










2197
2198
2199







2200
2201



2202


2203

2204
2205

2206

2207


2208

2209




2210
2211

2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236

2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247

2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
Tcl_Obj *
Tcl_NewLongObj(longValue)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
{
    register Tcl_Obj *objPtr;

    TclNewLongObj(objPtr, longValue);




    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewLongObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer
 *	objects end up calling the debugging procedure Tcl_DbNewLongObj
 *	instead. We provide two implementations of Tcl_DbNewLongObj so that
 *	whether the Tcl core is compiled to do memory debugging of the core is

 *	independent of whether a client requests debugging for itself.
 *
 *	When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj
 *	calls Tcl_DbCkalloc directly with the file name and line number from
 *	its caller. This simplifies debugging since then the [memory active]
 *	command will report the caller's file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
 *	this procedure just returns the result of calling Tcl_NewLongObj.
 *
 * Results:
 *	The newly created long integer object is returned. This object will
 *	have an invalid string representation. The returned object has ref
 *	count 0.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
    register long longValue;	/* Long integer used to initialize the new
				 * object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
    register long longValue;	/* Long integer used to initialize the new
				 * object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewLongObj(longValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetLongObj --
 *
 *	Modify an object to be an integer object and to have the specified
 *	long integer value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old internal
 *	rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetLongObj(objPtr, longValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register long longValue;	/* Long integer used to initialize the
				 * object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetLongObj called with shared object");
    }


    TclSetLongObj(objPtr, longValue);


}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetLongFromObj --
 *
 *	Attempt to return an long integer from the Tcl object "objPtr". If the
 *	object is not already an int object, an attempt will be made to
 *	convert it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int object, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetLongFromObj(interp, objPtr, longPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a long. */
    register long *longPtr;	/* Place to store resulting long. */
{

    do {
	if (objPtr->typePtr == &tclIntType) {
	    *longPtr = objPtr->internalRep.longValue;


	    return TCL_OK;
	}

#ifndef NO_WIDE_TYPE

	if (objPtr->typePtr == &tclWideIntType) {
	    /*

	     * We return any integer in the range -ULONG_MAX to ULONG_MAX
	     * converted to a long, ignoring overflow.  The rule preserves
	     * existing semantics for conversion of integers on input, but
	     * avoids inadvertent demotion of wide integers to 32-bit ones
	     * in the internal rep.
	     */

	    Tcl_WideInt w = objPtr->internalRep.wideValue;
	    if (w >= -(Tcl_WideInt)(ULONG_MAX)
		    && w <= (Tcl_WideInt)(ULONG_MAX)) {
		*longPtr = Tcl_WideAsLong(w);
		return TCL_OK;




	    }

	    goto tooLarge;
	}

#endif
        if (objPtr->typePtr == &tclDoubleType) {
            if (interp != NULL) {
		Tcl_Obj* msg = 
			Tcl_NewStringObj("expected integer but got \"", -1);
		Tcl_AppendObjToObj(msg, objPtr);
		Tcl_AppendToObj(msg, "\"", -1);
		Tcl_SetObjResult(interp, msg);
	    }




















	    return TCL_ERROR;
	}

        if (objPtr->typePtr == &tclBignumType) {
	    /* Must check for those bignum values that can fit in 
	     * a long, even when auto-narrowing is enabled.  Only those
	     * values in the signed long range get auto-narrowed to
	     * tclIntType, while all the values in the unsigned long
	     * range will fit in a long. */



	    mp_int big;


	    UNPACK_BIGNUM(objPtr, big);



	    if (big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)

		    / DIGIT_BIT) {







		unsigned long value = 0, numBytes = sizeof(long);



		long scratch;
		unsigned char *bytes = (unsigned char *)&scratch;
		if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
		    while (numBytes-- > 0) {
			value = (value << CHAR_BIT) | *bytes++;
		    }
		    if (big.sign) {

			*longPtr = - (long) value;



		    } else {

			*longPtr = (long) value;










		    }
		    return TCL_OK;
		}







	    }
#ifndef NO_WIDE_TYPE



	tooLarge:


#endif

	    if (interp != NULL) {
		char *s = "integer value too large to represent";

		Tcl_Obj* msg = Tcl_NewStringObj(s, -1);

		Tcl_SetObjResult(interp, msg);


		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);

	    }




	    return TCL_ERROR;
	}

    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}
#ifndef NO_WIDE_TYPE

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfWideInt --
 *
 *	Update the string representation for a wide integer object.  Note:
 *	This procedure does not free an existing old string rep so storage
 *	will be lost if this has not already been done.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from the
 *	wideInt-to-string conversion.
 *
 *----------------------------------------------------------------------
 */


static void
UpdateStringOfWideInt(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
{
    char buffer[TCL_INTEGER_SPACE+2];
    register unsigned len;
    register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;

    /*
     * Note that sprintf will generate a compiler warning under Mingw claiming
     * %I64 is an unknown format specifier. Just ignore this warning. We can't

     * use %L as the format specifier since that gets printed as a 32 bit
     * value.
     */

    sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
    len = strlen(buffer);
    objPtr->bytes = ckalloc((unsigned) len + 1);
    memcpy(objPtr->bytes, buffer, len + 1);
    objPtr->length = len;
}
#endif /* !NO_WIDE_TYPE */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewWideIntObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
 *	the debugging procedure Tcl_DbNewWideIntObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewWideIntObj result in a call to one of the two
 *	Tcl_NewWideIntObj implementations below. We provide two
 *	implementations so that the Tcl core can be compiled to do memory
 *	debugging of the core even if a client does not request it for itself.
 *
 * Results:
 *	The newly created object is returned. This object will have an invalid
 *	string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676


2677


2678


2679
2680


2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709

































































































































































































































































2710




















































































































































































































2711

































2712
2713





2714
2715
2716


2717




2718

2719







2720




2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758

2759
2760
2761
2762
2763
2764
2765

2766
2767
2768
2769

2770
2771
2772
2773
2774
2775
2776
Tcl_NewWideIntObj(wideValue)
    register Tcl_WideInt wideValue;	/* Wide integer used to initialize
					 * the new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;

    objPtr->internalRep.wideValue = wideValue;
    objPtr->typePtr = &tclWideIntType;
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewWideIntObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewWideIntObj to create new wide integer end up calling
 *	the debugging procedure Tcl_DbNewWideIntObj instead. We
 *	provide two implementations of Tcl_DbNewWideIntObj so that
 *	whether the Tcl core is compiled to do memory debugging of the
 *	core is independent of whether a client requests debugging for
 *	itself.
 *
 *	When the core is compiled with TCL_MEM_DEBUG defined,
 *	Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file
 *	name and line number from its caller. This simplifies
 *	debugging since then the checkmem command will report the
 *	caller's file name and line number when reporting objects that
 *	haven't been freed.
 *
 *	Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
 *	this procedure just returns the result of calling Tcl_NewWideIntObj.
 *
 * Results:
 *	The newly created wide integer object is returned. This object
 *	will have an invalid string representation. The returned object has
 *	ref count 0.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
    register Tcl_WideInt wideValue;	/* Wide integer used to initialize
					 * the new object. */
    CONST char *file;			/* The name of the source file
					 * calling this procedure; used for
					 * debugging. */
    int line;				/* Line number in the source file;
					 * used for debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.wideValue = wideValue;
    objPtr->typePtr = &tclWideIntType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
    register Tcl_WideInt wideValue;	/* Long integer used to initialize
					 * the new object. */
    CONST char *file;			/* The name of the source file
					 * calling this procedure; used for
					 * debugging. */
    int line;				/* Line number in the source file;
					 * used for debugging. */
{
    return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetWideIntObj --
 *
 *	Modify an object to be a wide integer object and to have the
 *	specified wide integer value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetWideIntObj(objPtr, wideValue)
    register Tcl_Obj *objPtr;		/* Object w. internal rep to init. */
    register Tcl_WideInt wideValue;	/* Wide integer used to initialize
					 * the object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetWideIntObj called with shared object");
    }



    TclFreeIntRep(objPtr);


    objPtr->internalRep.wideValue = wideValue;


    objPtr->typePtr = &tclWideIntType;
    Tcl_InvalidateStringRep(objPtr);


}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetWideIntFromObj --
 *
 *	Attempt to return a wide integer from the Tcl object "objPtr". If
 *	the object is not already a wide int object, an attempt will be made
 *	to convert it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int object, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* Object from which to get a wide int. */
    register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
{

































































































































































































































































    register int result;






















































































































































































































































    if (objPtr->typePtr == &tclWideIntType) {
	*wideIntPtr = objPtr->internalRep.wideValue;





	return TCL_OK;
    }
    result = SetWideIntFromAny(interp, objPtr);


    if (result == TCL_OK) {




	*wideIntPtr = objPtr->internalRep.wideValue;

    }







    return result;




}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIncrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not
 *	the memory has been freed before incrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just increments
 *	the reference count of the object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DbIncrRefCount(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are registering a
				 * reference to. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("Trying to increment refCount of previously disposed object.");
    }

# ifdef TCL_THREADS
    /*
     * Check to make sure that the Tcl_Obj was allocated by the
     * current thread. Don't do this check when shutting down
     * since thread local storage can be finalized before the
     * last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",







<
|
<
<










|
|
|
|
|
<


|
|
|
|
<





|
|
|











|
|
|
|







<
|
<
<







|
|
|
|













|
|





|
|














>
>
|
>
>
|
>
>
|
|
>
>







|
|
|



















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
|
|
|
>
>
|
>
>
>
>
|
>
|
>
>
>
>
>
>
>
|
>
>
>
>








|
|

|
|












|
|


|
|







>


|
|
|
<

>




>







2299
2300
2301
2302
2303
2304
2305

2306


2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321

2322
2323
2324
2325
2326
2327

2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357

2358


2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026

3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
Tcl_NewWideIntObj(wideValue)
    register Tcl_WideInt wideValue;	/* Wide integer used to initialize
					 * the new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);

    Tcl_SetWideIntObj(objPtr, wideValue);


    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewWideIntObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewWideIntObj to create new wide integer end up calling the
 *	debugging procedure Tcl_DbNewWideIntObj instead. We provide two
 *	implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is
 *	compiled to do memory debugging of the core is independent of whether
 *	a client requests debugging for itself.

 *
 *	When the core is compiled with TCL_MEM_DEBUG defined,
 *	Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name
 *	and line number from its caller. This simplifies debugging since then
 *	the checkmem command will report the caller's file name and line
 *	number when reporting objects that haven't been freed.

 *
 *	Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
 *	this procedure just returns the result of calling Tcl_NewWideIntObj.
 *
 * Results:
 *	The newly created wide integer object is returned. This object will
 *	have an invalid string representation. The returned object has ref
 *	count 0.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
    register Tcl_WideInt wideValue;	/* Wide integer used to initialize the
					 * new object. */
    CONST char *file;			/* The name of the source file calling
					 * this procedure; used for
					 * debugging. */
    int line;				/* Line number in the source file;
					 * used for debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);

    Tcl_SetWideIntObj(objPtr, wideValue);


    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
    register Tcl_WideInt wideValue;	/* Long integer used to initialize the
					 * new object. */
    CONST char *file;			/* The name of the source file calling
					 * this procedure; used for
					 * debugging. */
    int line;				/* Line number in the source file;
					 * used for debugging. */
{
    return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetWideIntObj --
 *
 *	Modify an object to be a wide integer object and to have the specified
 *	wide integer value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old internal
 *	rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetWideIntObj(objPtr, wideValue)
    register Tcl_Obj *objPtr;		/* Object w. internal rep to init. */
    register Tcl_WideInt wideValue;	/* Wide integer used to initialize
					 * the object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetWideIntObj called with shared object");
    }

    if ((wideValue >= (Tcl_WideInt) LONG_MIN)
	    && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
	TclSetLongObj(objPtr, (long) wideValue);
    } else {
#ifndef NO_WIDE_TYPE
	TclSetWideIntObj(objPtr, wideValue);
#else
	mp_int big;
	TclBNInitBignumFromWideInt(&big, wideValue);
	Tcl_SetBignumObj(objPtr, &big);
#endif
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetWideIntFromObj --
 *
 *	Attempt to return a wide integer from the Tcl object "objPtr". If the
 *	object is not already a wide int object, an attempt will be made to
 *	convert it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int object, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* Object from which to get a wide int. */
    register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
{
    do {
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {
	    *wideIntPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
#endif
	if (objPtr->typePtr == &tclIntType) {
	    *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
	    return TCL_OK;
	}
        if (objPtr->typePtr == &tclDoubleType) {
            if (interp != NULL) {
		Tcl_Obj* msg = 
			Tcl_NewStringObj("expected integer but got \"", -1);
		Tcl_AppendObjToObj(msg, objPtr);
		Tcl_AppendToObj(msg, "\"", -1);
		Tcl_SetObjResult(interp, msg);
	    }
	    return TCL_ERROR;
	}
        if (objPtr->typePtr == &tclBignumType) {
	    /* Must check for those bignum values that can fit in 
	     * a Tcl_WideInt, even when auto-narrowing is enabled. */
	    mp_int big;
	    UNPACK_BIGNUM(objPtr, big);
	    if (big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1)
		    / DIGIT_BIT) {
		Tcl_WideUInt value = 0;
		unsigned long numBytes = sizeof(Tcl_WideInt);
		Tcl_WideInt scratch;
		unsigned char *bytes = (unsigned char *)&scratch;
		if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
		    while (numBytes-- > 0) {
			value = (value << CHAR_BIT) | *bytes++;
		    }
		    if (big.sign) {
			*wideIntPtr = - (Tcl_WideInt) value;
		    } else {
			*wideIntPtr = (Tcl_WideInt) value;
		    }
		    return TCL_OK;
		}
	    }
	    if (interp != NULL) {
		char *s = "integer value too large to represent";
		Tcl_Obj* msg = Tcl_NewStringObj(s, -1);
		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeBignum --
 *
 *	This procedure frees the internal rep of a bignum.
 *
 * Results:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FreeBignum(Tcl_Obj *objPtr)
{
    mp_int toFree;		/* Bignum to free */

    UNPACK_BIGNUM(objPtr, toFree);
    mp_clear(&toFree);
    if (objPtr->internalRep.ptrAndLongRep.value < 0) {
	ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DupBignum --
 *
 *	This procedure duplicates the internal rep of a bignum.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The destination object receies a copy of the source object
 *
 *----------------------------------------------------------------------
 */

static void
DupBignum(srcPtr, copyPtr)
    Tcl_Obj* srcPtr;
    Tcl_Obj* copyPtr;
{
    mp_int bignumVal;
    mp_int bignumCopy;

    copyPtr->typePtr = &tclBignumType;
    UNPACK_BIGNUM(srcPtr, bignumVal);
    if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
	Tcl_Panic("initialization failure in DupBignum");
    }
    PACK_BIGNUM(bignumCopy, copyPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfBignum --
 *
 *	This procedure updates the string representation of a bignum object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to whatever results from the bignum-
 *	to-string conversion.
 *
 * The object's existing string representation is NOT freed; memory will leak
 * if the string rep is still valid at the time this procedure is called.
 */

static void
UpdateStringOfBignum(Tcl_Obj* objPtr)
{
    mp_int bignumVal;
    int size;
    int status;
    char* stringVal;

    UNPACK_BIGNUM(objPtr, bignumVal);
    status = mp_radix_size(&bignumVal, 10, &size);
    if (status != MP_OKAY) {
	Tcl_Panic("radix size failure in UpdateStringOfBignum");
    }
    if (size == 3
#ifndef BIGNUM_AUTO_NARROW
	    && bignumVal.used > 1
#endif
	    ) {
	/*
	 * mp_radix_size() returns 3 when more than INT_MAX bytes would
	 * be needed to hold the string rep (because mp_radix_size
	 * ignores integer overflow issues).  When we know the string
	 * rep will be more than 3, we can conclude the string rep would
	 * overflow our string length limits.
	 *
	 * Note that so long as we enforce our bignums to the size that
	 * fits in a packed bignum, this branch will never be taken.
	 */
	Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
    }
    stringVal = Tcl_Alloc((size_t) size);
    status = mp_toradix_n(&bignumVal, stringVal, 10, size);
    if (status != MP_OKAY) {
	Tcl_Panic("conversion failure in UpdateStringOfBignum");
    }
    objPtr->bytes = stringVal;
    objPtr->length = size - 1;	/* size includes a trailing null byte */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewBignumObj --
 *
 *	Creates an initializes a bignum object.
 *
 * Results:
 *	Returns the newly created object.
 *
 * Side effects:
 *	The bignum value is cleared, since ownership has transferred to Tcl.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBignumObj
Tcl_Obj*
Tcl_NewBignumObj(mp_int* bignumValue)
{
    return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
}
#else
Tcl_Obj *
Tcl_NewBignumObj(mp_int* bignumValue)
{
    Tcl_Obj* objPtr;
    TclNewObj(objPtr);
    Tcl_SetBignumObj(objPtr, bignumValue);
    return objPtr;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewBignumObj --
 *
 *	This procedure is normally called when debugging: that is, when
 *	TCL_MEM_DEBUG is defined.  It constructs a bignum object, recording
 *	the creation point so that [memory active] can report it.
 *
 * Results:
 *	Returns the newly created object.
 *
 * Side effects:
 *	The bignum value is cleared, since ownership has transferred to Tcl.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
Tcl_Obj*
Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line)
{
    Tcl_Obj* objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetBignumObj(objPtr, bignumValue);
    return objPtr;
}
#else
Tcl_Obj*
Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line)
{
    return Tcl_NewBignumObj(bignumValue);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * GetBignumFromObj --
 *
 *	This procedure retrieves a 'bignum' value from a Tcl object,
 *	converting the object if necessary.  Either copies or transfers
 * 	the mp_int value depending on the copy flag value passed in.
 *
 * Results:
 *	Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
 *
 * Side effects:
 *	A copy of bignum is stored in *bignumValue, which is expected to be
 *	uninitialized or cleared.  If conversion fails, and the 'interp'
 *	argument is not NULL, an error message is stored in the interpreter
 *	result.
 *
 *----------------------------------------------------------------------
 */

int
GetBignumFromObj(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    Tcl_Obj* objPtr,		/* Object to read */
    int copy,			/* Whether to copy the returned bignum value */
    mp_int* bignumValue)	/* Returned bignum value. */
{
    do {
	if (objPtr->typePtr == &tclBignumType) {
	    if (copy) {
		mp_int temp;
		UNPACK_BIGNUM(objPtr, temp);
		mp_init_copy(bignumValue, &temp);
	    } else {
		if (Tcl_IsShared(objPtr)) {
		    Tcl_Panic("Tcl_GetBignumAndClearObj called on shared Tcl_Obj");
		}
		UNPACK_BIGNUM(objPtr, *bignumValue);
		objPtr->internalRep.ptrAndLongRep.ptr = NULL;
		objPtr->internalRep.ptrAndLongRep.value = 0;
		objPtr->typePtr = NULL;
		if (objPtr->bytes == NULL) {
		    TclInitStringRep(objPtr, NULL, 0);
		}
	    }
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclIntType) {
	    TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
	    return TCL_OK;
	}
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {
	    TclBNInitBignumFromWideInt(bignumValue, 
		    objPtr->internalRep.wideValue);
	    return TCL_OK;
	}
#endif
	if (objPtr->typePtr == &tclDoubleType) {
	    if (interp != NULL) {
		Tcl_Obj* msg =
			Tcl_NewStringObj("expected integer but got \"", -1);
		Tcl_AppendObjToObj(msg, objPtr);
		Tcl_AppendToObj(msg, "\"", -1);
		Tcl_SetObjResult(interp, msg);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBignumFromObj --
 *
 *	This procedure retrieves a 'bignum' value from a Tcl object,
 *	converting the object if necessary.
 *
 * Results:
 *	Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
 *
 * Side effects:
 *	A copy of bignum is stored in *bignumValue, which is expected to be
 *	uninitialized or cleared.  If conversion fails, an the 'interp'
 *	argument is not NULL, an error message is stored in the interpreter
 *	result.
 *
 *	It is expected that the caller will NOT have invoked mp_init on the
 *	bignum value before passing it in.  Tcl will initialize the mp_int
 *	as it sets the value.  The value is a copy of the value in objPtr,
 *	so it becomes the responsibility of the caller to call mp_clear on
 *	it.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBignumFromObj(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    Tcl_Obj* objPtr,		/* Object to read */
    mp_int* bignumValue)	/* Returned bignum value. */
{
    return GetBignumFromObj(interp, objPtr, 1, bignumValue);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBignumAndClearObj --
 *
 *	This procedure retrieves a 'bignum' value from a Tcl object,
 *	converting the object if necessary.
 *
 * Results:
 *	Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
 *
 * Side effects:
 *	A copy of bignum is stored in *bignumValue, which is expected to be
 *	uninitialized or cleared.  If conversion fails, an the 'interp'
 *	argument is not NULL, an error message is stored in the interpreter
 *	result.
 *
 *	It is expected that the caller will NOT have invoked mp_init on the
 *	bignum value before passing it in.  Tcl will initialize the mp_int
 *	as it sets the value.  The value is transferred from the internals
 *	of objPtr to the caller, passing responsibility of the caller to
 *	call mp_clear on it.  The objPtr is cleared to hold an empty value.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBignumAndClearObj(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    Tcl_Obj* objPtr,		/* Object to read */
    mp_int* bignumValue)	/* Returned bignum value. */
{
    return GetBignumFromObj(interp, objPtr, 0, bignumValue);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetBignumObj --
 *
 *	This procedure sets the value of a Tcl_Obj to a large integer.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Object value is stored.  The bignum value is cleared, since ownership
 *	has transferred to Tcl.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetBignumObj(
    Tcl_Obj* objPtr,		/* Object to set */
    mp_int* bignumValue)	/* Value to store */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetBignumObj called with shared object");
    }
#ifdef BIGNUM_AUTO_NARROW
    if (bignumValue->used
	    <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) {
	unsigned long value = 0, numBytes = sizeof(long);
	long scratch;
	unsigned char *bytes = (unsigned char *)&scratch;
	if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
	    goto tooLargeForLong;
	}
	while (numBytes-- > 0) {
	    value = (value << CHAR_BIT) | *bytes++;
	}
	if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
	    goto tooLargeForLong;
	}
	if (bignumValue->sign) {
	    TclSetLongObj(objPtr, -(long)value);
	} else {
	    TclSetLongObj(objPtr, (long)value);
	}
	mp_clear(bignumValue);
	return;
    }
  tooLargeForLong:
#ifndef NO_WIDE_TYPE
    if (bignumValue->used
	    <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
	Tcl_WideUInt value = 0;
	unsigned long numBytes = sizeof(Tcl_WideInt);
	Tcl_WideInt scratch;
	unsigned char *bytes = (unsigned char *)&scratch;
	if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
	    goto tooLargeForWide;
	}
	while (numBytes-- > 0) {
	    value = (value << CHAR_BIT) | *bytes++;
	}
	if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) {
	    goto tooLargeForWide;
	}
	if (bignumValue->sign) {
	    TclSetWideIntObj(objPtr, -(Tcl_WideInt)value);
	} else {
	    TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
	}
	mp_clear(bignumValue);
	return;
    }
  tooLargeForWide:
#endif
#endif
    TclInvalidateStringRep(objPtr);
    TclFreeIntRep(objPtr);
    TclSetBignumIntRep(objPtr, bignumValue);
}

void
TclSetBignumIntRep(objPtr, bignumValue)
    Tcl_Obj *objPtr;
    mp_int *bignumValue;
{
    objPtr->typePtr = &tclBignumType;
    PACK_BIGNUM(*bignumValue, objPtr);

    /*
     * Clear the mp_int value.
     * Don't call mp_clear() because it would free the digit array
     * we just packed into the Tcl_Obj.
     */

    bignumValue->dp = NULL;
    bignumValue->alloc = bignumValue->used = 0;
    bignumValue->sign = MP_NEG;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNumberFromObj --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int TclGetNumberFromObj(interp, objPtr, clientDataPtr, typePtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
    ClientData *clientDataPtr;
    int *typePtr;
{
    do {
	if (objPtr->typePtr == &tclDoubleType) {
	    if (TclIsNaN(objPtr->internalRep.doubleValue)) {
		*typePtr = TCL_NUMBER_NAN;
	    } else {
		*typePtr = TCL_NUMBER_DOUBLE;
	    }
	    *clientDataPtr = &(objPtr->internalRep.doubleValue);
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclIntType) {
	    *typePtr = TCL_NUMBER_LONG;
	    *clientDataPtr = &(objPtr->internalRep.longValue);
	    return TCL_OK;
	}
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {
	    *typePtr = TCL_NUMBER_WIDE;
	    *clientDataPtr = &(objPtr->internalRep.wideValue);
	    return TCL_OK;
	}
#endif
	if (objPtr->typePtr == &tclBignumType) {
	    static Tcl_ThreadDataKey bignumKey;
	    mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int)sizeof(mp_int));
	    UNPACK_BIGNUM( objPtr, *bigPtr );
	    *typePtr = TCL_NUMBER_BIG;
	    *clientDataPtr = bigPtr;
	    return TCL_OK;
	}
    } while (TCL_OK ==
	    TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIncrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not the memory
 *	has been freed before incrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just increments the
 *	reference count of the object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DbIncrRefCount(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are registering a reference
				 * to. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("Trying to increment refCount of previously disposed object.");
    }

# ifdef TCL_THREADS
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.

     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821

2822
2823
2824
2825
2826
2827
2828

2829
2830
2831
2832

2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbDecrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not
 *	the memory has been freed before decrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just decrements
 *	the reference count of the object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DbDecrRefCount(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are releasing a reference
				 * to. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("Trying to decrement refCount of previously disposed object.");
    }

# ifdef TCL_THREADS
    /*
     * Check to make sure that the Tcl_Obj was allocated by the
     * current thread. Don't do this check when shutting down
     * since thread local storage can be finalized before the
     * last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to decr ref count of",
		    "Tcl_Obj allocated in another thread");
	}

	/* If the Tcl_Obj is going to be deleted, remove the entry */
	if ((((objPtr)->refCount) - 1) <= 0) {
	    Tcl_DeleteHashEntry(hPtr);
	}







|
|

|
|
















|
|







>


|
|
|
<

>




>







|







3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091

3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbDecrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not the memory
 *	has been freed before decrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just decrements the
 *	reference count of the object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DbDecrRefCount(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are releasing a reference
				 * to. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("Trying to decrement refCount of previously disposed object.");
    }

# ifdef TCL_THREADS
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.

     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to decr ref count of ",
		    "Tcl_Obj allocated in another thread");
	}

	/* If the Tcl_Obj is going to be deleted, remove the entry */
	if ((((objPtr)->refCount) - 1) <= 0) {
	    Tcl_DeleteHashEntry(hPtr);
	}
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890

2891
2892
2893
2894
2895
2896
2897

2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914

2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925

2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949

2950
2951
2952
2953
2954
2955
2956
2957

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIsShared --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It tests whether the object has a ref
 *	count greater than one.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just tests
 *	if the object has a ref count greater than one.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbIsShared(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object to test for being shared. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("Trying to check whether previously disposed object is shared.");
    }

# ifdef TCL_THREADS
    /*
     * Check to make sure that the Tcl_Obj was allocated by the
     * current thread. Don't do this check when shutting down
     * since thread local storage can be finalized before the
     * last Tcl_Obj is freed.
     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to check shared status of",
		    "Tcl_Obj allocated in another thread");
	}
    }
# endif
#endif

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    if ((objPtr)->refCount <= 1) {
	tclObjsShared[1]++;
    } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
	tclObjsShared[(objPtr)->refCount]++;
    } else {
	tclObjsShared[0]++;
    }
    Tcl_MutexUnlock(&tclObjMutex);
#endif

    return ((objPtr)->refCount > 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitObjHashTable --
 *
 *	Given storage for a hash table, set up the fields to prepare
 *	the hash table for use, the keys are Tcl_Obj *.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
 *	Tcl_CreateHashEntry.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitObjHashTable(tablePtr)
    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which

					 * is supplied by the caller. */
{
    Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
	    &tclObjHashKeyType);
}

/*
 *----------------------------------------------------------------------







|
|

|
|















|
|







>


|
|
|
<

>

















>











>








|
|













|
>
|







3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162

3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIsShared --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It tests whether the object has a ref count
 *	greater than one.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just tests if the
 *	object has a ref count greater than one.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbIsShared(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object to test for being shared. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("Trying to check whether previously disposed object is shared.");
    }

# ifdef TCL_THREADS
    /*
     * Check to make sure that the Tcl_Obj was allocated by the current
     * thread. Don't do this check when shutting down since thread local
     * storage can be finalized before the last Tcl_Obj is freed.

     */

    if (!TclInExit()) {
	Tcl_HashTable *tablePtr;
	Tcl_HashEntry *hPtr;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	tablePtr = tsdPtr->objThreadMap;
	if (!tablePtr) {
	    Tcl_Panic("object table not initialized");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s%s",
		    "Trying to check shared status of",
		    "Tcl_Obj allocated in another thread");
	}
    }
# endif
#endif

#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    if ((objPtr)->refCount <= 1) {
	tclObjsShared[1]++;
    } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
	tclObjsShared[(objPtr)->refCount]++;
    } else {
	tclObjsShared[0]++;
    }
    Tcl_MutexUnlock(&tclObjMutex);
#endif

    return ((objPtr)->refCount > 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitObjHashTable --
 *
 *	Given storage for a hash table, set up the fields to prepare the hash
 *	table for use, the keys are Tcl_Obj *.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
 *	Tcl_CreateHashEntry.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitObjHashTable(tablePtr)
    register Tcl_HashTable *tablePtr;
				/* Pointer to table record, which is supplied
				 * by the caller. */
{
    Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
	    &tclObjHashKeyType);
}

/*
 *----------------------------------------------------------------------
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016

3017
3018
3019
3020
3021
3022
3023
3024

3025
3026
3027
3028
3029
3030
3031
3032

3033
3034
3035
3036
3037
3038
3039
 *----------------------------------------------------------------------
 *
 * CompareObjKeys --
 *
 *	Compares two Tcl_Obj * keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are
 *	the same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CompareObjKeys(keyPtr, hPtr)
    VOID *keyPtr;		/* New key to compare. */
    Tcl_HashEntry *hPtr;		/* Existing key to compare. */
{
    Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
    Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
    register CONST char *p1, *p2;
    register int l1, l2;

    /*
     * If the object pointers are the same then they match.
     */

    if (objPtr1 == objPtr2) {
	return 1;
    }

    /*
     * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
     * in a register.
     */

    p1 = TclGetString(objPtr1);
    l1 = objPtr1->length;
    p2 = TclGetString(objPtr2);
    l2 = objPtr2->length;

    /*
     * Only compare if the string representations are of the same length.
     */

    if (l1 == l2) {
	for (;; p1++, p2++, l1--) {
	    if (*p1 != *p2) {
		break;
	    }
	    if (l1 == 0) {
		return 1;







|
|




















>








>








>







3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
 *----------------------------------------------------------------------
 *
 * CompareObjKeys --
 *
 *	Compares two Tcl_Obj * keys.
 *
 * Results:
 *	The return value is 0 if they are different and 1 if they are the
 *	same.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CompareObjKeys(keyPtr, hPtr)
    VOID *keyPtr;		/* New key to compare. */
    Tcl_HashEntry *hPtr;		/* Existing key to compare. */
{
    Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
    Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
    register CONST char *p1, *p2;
    register int l1, l2;

    /*
     * If the object pointers are the same then they match.
     */

    if (objPtr1 == objPtr2) {
	return 1;
    }

    /*
     * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
     * in a register.
     */

    p1 = TclGetString(objPtr1);
    l1 = objPtr1->length;
    p2 = TclGetString(objPtr2);
    l2 = objPtr2->length;

    /*
     * Only compare if the string representations are of the same length.
     */

    if (l1 == l2) {
	for (;; p1++, p2++, l1--) {
	    if (*p1 != *p2) {
		break;
	    }
	    if (l1 == 0) {
		return 1;
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
 *
 * HashObjKey --
 *
 *	Compute a one-word summary of the string representation of the
 *	Tcl_Obj, which can be used to generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in
 *	the string representation of the Tcl_Obj.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
HashObjKey(tablePtr, keyPtr)
    Tcl_HashTable *tablePtr;	/* Hash table. */
    VOID *keyPtr;		/* Key from which to compute hash value. */
{
    Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
    CONST char *string = TclGetString(objPtr);
    int length = objPtr->length;
    unsigned int result = 0;
    int i;

    /*
     * I tried a zillion different hash functions and asked many other
     * people for advice.  Many people had their own favorite functions,
     * all different, but no-one had much idea why they were good ones.
     * I chose the one below (multiply by 9 and add new character)
     * because of the following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings,
     *    and multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
     *    character's bits hang around in the low-order bits of the
     *    hash value for ever, plus they spread fairly rapidly up to
     *    the high-order bits to fill out the hash value.  This seems
     *    works well both for decimal and non-decimal strings.
     */

    for (i=0 ; i<length ; i++) {
	result += (result << 3) + string[i];
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandFromObj --
 *
 *	Returns the command specified by the name in a Tcl_Obj.
 *
 * Results:
 *	Returns a token for the command if it is found. Otherwise, if it
 *	can't be found or there is an error, returns NULL.
 *
 * Side effects:
 *	May update the internal representation for the object, caching
 *	the command reference so that the next time this procedure is
 *	called with the same object, the command can be found quickly.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
    Tcl_Interp *interp;		/* The interpreter in which to resolve the
				 * command and to report errors. */
    register Tcl_Obj *objPtr;	/* The object containing the command's
				 * name. If the name starts with "::", will
				 * be looked up in global namespace. Else,
				 * looked up first in the current namespace,
				 * then in global namespace. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedCmdName *resPtr;
    register Command *cmdPtr;
    Namespace *currNsPtr;
    int result;
    CallFrame *savedFramePtr;
    char *name;

    /*
     * If the variable name is fully qualified, do as if the lookup were
     * done from the global namespace; this helps avoid repeated lookups
     * of fully qualified names. It costs close to nothing, and may be very
     * helpful for OO applications which pass along a command name ("this"),
     * [Patch 456668]
     */

    savedFramePtr = iPtr->varFramePtr;
    name = Tcl_GetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	iPtr->varFramePtr = NULL;
    }

    /*
     * Get the internal representation, converting to a command type if
     * needed. The internal representation is a ResolvedCmdName that points
     * to the actual command.
     */

    if (objPtr->typePtr != &tclCmdNameType) {
	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    iPtr->varFramePtr = savedFramePtr;
	    return (Tcl_Command) NULL;







|
|



















|
|
|
|
|

|
|

|
|
|
|
















|
|


|
|
|








|
|
|
|
|










|
|
|
|
|










|
|







3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
 *
 * HashObjKey --
 *
 *	Compute a one-word summary of the string representation of the
 *	Tcl_Obj, which can be used to generate a hash index.
 *
 * Results:
 *	The return value is a one-word summary of the information in the
 *	string representation of the Tcl_Obj.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
HashObjKey(tablePtr, keyPtr)
    Tcl_HashTable *tablePtr;	/* Hash table. */
    VOID *keyPtr;		/* Key from which to compute hash value. */
{
    Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
    CONST char *string = TclGetString(objPtr);
    int length = objPtr->length;
    unsigned int result = 0;
    int i;

    /*
     * I tried a zillion different hash functions and asked many other people
     * for advice.  Many people had their own favorite functions, all
     * different, but no-one had much idea why they were good ones.  I chose
     * the one below (multiply by 9 and add new character) because of the
     * following reasons:
     *
     * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
     *	  multiplying by 9 is just about as good.
     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
     *	  character's bits hang around in the low-order bits of the hash value
     *	  for ever, plus they spread fairly rapidly up to the high-order bits
     *	  to fill out the hash value.  This seems works well both for decimal
     *	  and *non-decimal strings.
     */

    for (i=0 ; i<length ; i++) {
	result += (result << 3) + string[i];
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandFromObj --
 *
 *	Returns the command specified by the name in a Tcl_Obj.
 *
 * Results:
 *	Returns a token for the command if it is found. Otherwise, if it can't
 *	be found or there is an error, returns NULL.
 *
 * Side effects:
 *	May update the internal representation for the object, caching the
 *	command reference so that the next time this procedure is called with
 *	the same object, the command can be found quickly.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
    Tcl_Interp *interp;		/* The interpreter in which to resolve the
				 * command and to report errors. */
    register Tcl_Obj *objPtr;	/* The object containing the command's name.
				 * If the name starts with "::", will be
				 * looked up in global namespace. Else, looked
				 * up first in the current namespace, then in
				 * global namespace. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedCmdName *resPtr;
    register Command *cmdPtr;
    Namespace *currNsPtr;
    int result;
    CallFrame *savedFramePtr;
    char *name;

    /*
     * If the variable name is fully qualified, do as if the lookup were done
     * from the global namespace; this helps avoid repeated lookups of fully
     * qualified names. It costs close to nothing, and may be very helpful for
     * OO applications which pass along a command name ("this"), [Patch
     * 456668]
     */

    savedFramePtr = iPtr->varFramePtr;
    name = Tcl_GetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	iPtr->varFramePtr = NULL;
    }

    /*
     * Get the internal representation, converting to a command type if
     * needed. The internal representation is a ResolvedCmdName that points to
     * the actual command.
     */

    if (objPtr->typePtr != &tclCmdNameType) {
	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    iPtr->varFramePtr = savedFramePtr;
	    return (Tcl_Command) NULL;
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
    } else {
	currNsPtr = iPtr->globalNsPtr;
    }

    /*
     * Check the context namespace and the namespace epoch of the resolved
     * symbol to make sure that it is fresh. If not, then force another
     * conversion to the command type, to discard the old rep and create a
     * new one. Note that we verify that the namespace id of the context
     * namespace is the same as the one we cached; this insures that the
     * namespace wasn't deleted and a new one created at the same address
     * with the same command epoch.
     */

    cmdPtr = NULL;
    if ((resPtr != NULL)
	    && (resPtr->refNsPtr == currNsPtr)
	    && (resPtr->refNsId == currNsPtr->nsId)
	    && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {







|
|
|
|
|







3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
    } else {
	currNsPtr = iPtr->globalNsPtr;
    }

    /*
     * Check the context namespace and the namespace epoch of the resolved
     * symbol to make sure that it is fresh. If not, then force another
     * conversion to the command type, to discard the old rep and create a new
     * one. Note that we verify that the namespace id of the context namespace
     * is the same as the one we cached; this insures that the namespace
     * wasn't deleted and a new one created at the same address with the same
     * command epoch.
     */

    cmdPtr = NULL;
    if ((resPtr != NULL)
	    && (resPtr->refNsPtr == currNsPtr)
	    && (resPtr->refNsId == currNsPtr->nsId)
	    && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267


3268
3269
3270
3271














3272
3273
3274
3275
3276
3277
3278
 *	Command structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old internal rep is freed. It's string rep is not
 *	changed. The refcount in the Command structure is incremented to
 *	keep it from being freed if the command is later deleted until
 *	TclExecuteByteCode has a chance to recognize that it was deleted.
 *
 *----------------------------------------------------------------------
 */

void
TclSetCmdNameObj(interp, objPtr, cmdPtr)
    Tcl_Interp *interp;		/* Points to interpreter containing command
				 * that should be cached in objPtr. */
    register Tcl_Obj *objPtr;	/* Points to Tcl object to be changed to
				 * a CmdName object. */
    Command *cmdPtr;		/* Points to Command structure that the
				 * CmdName object should refer to. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedCmdName *resPtr;
    register Namespace *currNsPtr;



    if (objPtr->typePtr == &tclCmdNameType) {
	return;
    }















    /*
     * Get the current namespace.
     */

    if (iPtr->varFramePtr != NULL) {
	currNsPtr = iPtr->varFramePtr->nsPtr;







|
|









|
|






>
>




>
>
>
>
>
>
>
>
>
>
>
>
>
>







3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
 *	Command structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old internal rep is freed. It's string rep is not
 *	changed. The refcount in the Command structure is incremented to keep
 *	it from being freed if the command is later deleted until
 *	TclExecuteByteCode has a chance to recognize that it was deleted.
 *
 *----------------------------------------------------------------------
 */

void
TclSetCmdNameObj(interp, objPtr, cmdPtr)
    Tcl_Interp *interp;		/* Points to interpreter containing command
				 * that should be cached in objPtr. */
    register Tcl_Obj *objPtr;	/* Points to Tcl object to be changed to a
				 * CmdName object. */
    Command *cmdPtr;		/* Points to Command structure that the
				 * CmdName object should refer to. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedCmdName *resPtr;
    register Namespace *currNsPtr;
    CallFrame *savedFramePtr;
    char *name;

    if (objPtr->typePtr == &tclCmdNameType) {
	return;
    }

    /*
     * If the variable name is fully qualified, do as if the lookup were done
     * from the global namespace; this helps avoid repeated lookups of fully
     * qualified names. It costs close to nothing, and may be very helpful for
     * OO applications which pass along a command name ("this"), [Patch
     * 456668] (Copied over from Tcl_GetCommandFromObj)
     */

    savedFramePtr = iPtr->varFramePtr;
    name = Tcl_GetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	iPtr->varFramePtr = NULL;
    }

    /*
     * Get the current namespace.
     */

    if (iPtr->varFramePtr != NULL) {
	currNsPtr = iPtr->varFramePtr->nsPtr;
3289
3290
3291
3292
3293
3294
3295


3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
    resPtr->cmdEpoch = cmdPtr->cmdEpoch;
    resPtr->refCount = 1;

    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclCmdNameType;


}

/*
 *----------------------------------------------------------------------
 *
 * FreeCmdNameInternalRep --
 *
 *	Frees the resources associated with a cmdName object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Decrements the ref count of any cached ResolvedCmdName structure
 *	pointed to by the cmdName's internal representation. If this is
 *	the last use of the ResolvedCmdName, it is freed. This in turn
 *	decrements the ref count of the Command structure pointed to by
 *	the ResolvedSymbol, which may free the Command structure.
 *
 *----------------------------------------------------------------------
 */

static void
FreeCmdNameInternalRep(objPtr)
    register Tcl_Obj *objPtr;	/* CmdName object with internal
				 * representation to free. */
{
    register ResolvedCmdName *resPtr =
	(ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;

    if (resPtr != NULL) {
	/*
	 * Decrement the reference count of the ResolvedCmdName structure.
	 * If there are no more uses, free the ResolvedCmdName structure.
	 */

	resPtr->refCount--;
	if (resPtr->refCount == 0) {
	    /*
	     * Now free the cached command, unless it is still in its
	     * hash table or if there are other references to it
	     * from other cmdName objects.
	     */

	    Command *cmdPtr = resPtr->cmdPtr;
	    TclCleanupCommand(cmdPtr);
	    ckfree((char *) resPtr);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DupCmdNameInternalRep --
 *
 *	Initialize the internal representation of an cmdName Tcl_Obj to a
 *	copy of the internal representation of an existing cmdName object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	"copyPtr"s internal rep is set to point to the ResolvedCmdName
 *	structure corresponding to "srcPtr"s internal rep. Increments the
 *	ref count of the ResolvedCmdName structure pointed to by the
 *	cmdName's internal representation.
 *
 *----------------------------------------------------------------------
 */

static void
DupCmdNameInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. */
{
    register ResolvedCmdName *resPtr =
	    (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1;

    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
    if (resPtr != NULL) {
	resPtr->refCount++;
    }
    copyPtr->typePtr = &tclCmdNameType;







>
>















|
|
|
|














|
|





|
|
|














|
|






|
|
|









|
|







3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
    resPtr->cmdEpoch = cmdPtr->cmdEpoch;
    resPtr->refCount = 1;

    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclCmdNameType;

    iPtr->varFramePtr = savedFramePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeCmdNameInternalRep --
 *
 *	Frees the resources associated with a cmdName object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Decrements the ref count of any cached ResolvedCmdName structure
 *	pointed to by the cmdName's internal representation. If this is the
 *	last use of the ResolvedCmdName, it is freed. This in turn decrements
 *	the ref count of the Command structure pointed to by the
 *	ResolvedSymbol, which may free the Command structure.
 *
 *----------------------------------------------------------------------
 */

static void
FreeCmdNameInternalRep(objPtr)
    register Tcl_Obj *objPtr;	/* CmdName object with internal
				 * representation to free. */
{
    register ResolvedCmdName *resPtr =
	(ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;

    if (resPtr != NULL) {
	/*
	 * Decrement the reference count of the ResolvedCmdName structure.  If
	 * there are no more uses, free the ResolvedCmdName structure.
	 */

	resPtr->refCount--;
	if (resPtr->refCount == 0) {
	    /*
	     * Now free the cached command, unless it is still in its hash
	     * table or if there are other references to it from other cmdName
	     * objects.
	     */

	    Command *cmdPtr = resPtr->cmdPtr;
	    TclCleanupCommand(cmdPtr);
	    ckfree((char *) resPtr);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DupCmdNameInternalRep --
 *
 *	Initialize the internal representation of an cmdName Tcl_Obj to a copy
 *	of the internal representation of an existing cmdName object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	"copyPtr"s internal rep is set to point to the ResolvedCmdName
 *	structure corresponding to "srcPtr"s internal rep. Increments the ref
 *	count of the ResolvedCmdName structure pointed to by the cmdName's
 *	internal representation.
 *
 *----------------------------------------------------------------------
 */

static void
DupCmdNameInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. */
{
    register ResolvedCmdName *resPtr = (ResolvedCmdName *)
	    srcPtr->internalRep.twoPtrValue.ptr1;

    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
    if (resPtr != NULL) {
	resPtr->refCount++;
    }
    copyPtr->typePtr = &tclCmdNameType;
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
 *
 * Results:
 *	The return value is a standard Tcl result. The conversion always
 *	succeeds and TCL_OK is returned.
 *
 * Side effects:
 *	A pointer to a ResolvedCmdName structure that holds a cached pointer
 *	to the command with a name that matches objPtr's string rep is
 *	stored as objPtr's internal representation. This ResolvedCmdName
 *	pointer will be NULL if no matching command was found. The ref count
 *	of the cached Command's structure (if any) is also incremented.
 *
 *----------------------------------------------------------------------
 */

static int
SetCmdNameFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */







|
|
|
|







3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
 *
 * Results:
 *	The return value is a standard Tcl result. The conversion always
 *	succeeds and TCL_OK is returned.
 *
 * Side effects:
 *	A pointer to a ResolvedCmdName structure that holds a cached pointer
 *	to the command with a name that matches objPtr's string rep is stored
 *	as objPtr's internal representation. This ResolvedCmdName pointer will
 *	be NULL if no matching command was found. The ref count of the cached
 *	Command's structure (if any) is also incremented.
 *
 *----------------------------------------------------------------------
 */

static int
SetCmdNameFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472








	resPtr->cmdEpoch	= cmdPtr->cmdEpoch;
	resPtr->refCount	= 1;
    } else {
	resPtr = NULL;	/* no command named "name" was found */
    }

    /*
     * Free the old internalRep before setting the new one. We do this as
     * late as possible to allow the conversion code, in particular
     * GetStringFromObj, to use that old internalRep. If no Command
     * structure was found, leave NULL as the cached value.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclCmdNameType;
    return TCL_OK;
}















|
|
|
|








>
>
>
>
>
>
>
>
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
	resPtr->cmdEpoch	= cmdPtr->cmdEpoch;
	resPtr->refCount	= 1;
    } else {
	resPtr = NULL;	/* no command named "name" was found */
    }

    /*
     * Free the old internalRep before setting the new one. We do this as late
     * as possible to allow the conversion code, in particular
     * GetStringFromObj, to use that old internalRep. If no Command structure
     * was found, leave NULL as the cached value.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    objPtr->typePtr = &tclCmdNameType;
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPanic.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
/* 
 * tclPanic.c --
 *
 *	Source code for the "Tcl_Panic" library procedure for Tcl;
 *	individual applications will probably call Tcl_SetPanicProc()
 *	to set an application-specific panic procedure.
 *
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPanic.c,v 1.5 2004/04/06 22:25:54 dgp Exp $
 */

#include "tclInt.h"

/*
 * The panicProc variable contains a pointer to an application
 * specific panic procedure.
 */

static Tcl_PanicProc *panicProc = NULL;

/*
 * The platformPanicProc variable contains a pointer to a platform
 * specific panic procedure, if any.  ( TclpPanic may be NULL via
 * a macro. )
 */

static Tcl_PanicProc * CONST platformPanicProc = TclpPanic;


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetPanicProc --
 *
 *	Replace the default panic behavior with the specified functiion.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the panicProc variable.
 *
|


|
|
|





|
|

|





|
|





|
|
<


|
<






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32

33
34
35
36
37
38
39
40
41
42
43
44
45
46
/*
 * tclPanic.c --
 *
 *	Source code for the "Tcl_Panic" library procedure for Tcl; individual
 *	applications will probably call Tcl_SetPanicProc() to set an
 *	application-specific panic procedure.
 *
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPanic.c,v 1.5.2.2 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * The panicProc variable contains a pointer to an application specific panic
 * procedure.
 */

static Tcl_PanicProc *panicProc = NULL;

/*
 * The platformPanicProc variable contains a pointer to a platform specific
 * panic procedure, if any. (TclpPanic may be NULL via a macro.)

 */

static Tcl_PanicProc *CONST platformPanicProc = TclpPanic;


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetPanicProc --
 *
 *	Replace the default panic behavior with the specified function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the panicProc variable.
 *
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PanicVA (format, argList)
    CONST char *format;		/* Format string, suitable for passing to
				 * fprintf. */
    va_list argList;		/* Variable argument list. */
{
    char *arg1, *arg2, *arg3, *arg4;	/* Additional arguments (variable in
					 * number) to pass to fprintf. */
    char *arg5, *arg6, *arg7, *arg8;

    arg1 = va_arg(argList, char *);
    arg2 = va_arg(argList, char *);
    arg3 = va_arg(argList, char *);
    arg4 = va_arg(argList, char *);
    arg5 = va_arg(argList, char *);
    arg6 = va_arg(argList, char *);
    arg7 = va_arg(argList, char *);
    arg8 = va_arg(argList, char *);
    
    if (panicProc != NULL) {
	(void) (*panicProc)(format, arg1, arg2, arg3, arg4,
		arg5, arg6, arg7, arg8);
    } else if (platformPanicProc != NULL) {
	(void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4,
		arg5, arg6, arg7, arg8);
    } else {







|
















|







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PanicVA(format, argList)
    CONST char *format;		/* Format string, suitable for passing to
				 * fprintf. */
    va_list argList;		/* Variable argument list. */
{
    char *arg1, *arg2, *arg3, *arg4;	/* Additional arguments (variable in
					 * number) to pass to fprintf. */
    char *arg5, *arg6, *arg7, *arg8;

    arg1 = va_arg(argList, char *);
    arg2 = va_arg(argList, char *);
    arg3 = va_arg(argList, char *);
    arg4 = va_arg(argList, char *);
    arg5 = va_arg(argList, char *);
    arg6 = va_arg(argList, char *);
    arg7 = va_arg(argList, char *);
    arg8 = va_arg(argList, char *);

    if (panicProc != NULL) {
	(void) (*panicProc)(format, arg1, arg2, arg3, arg4,
		arg5, arg6, arg7, arg8);
    } else if (platformPanicProc != NULL) {
	(void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4,
		arg5, arg6, arg7, arg8);
    } else {
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135








 *
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

	/* VARARGS ARGSUSED */
void
Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1)
{
    va_list argList;
    CONST char *format;

    format = TCL_VARARGS_START(CONST char *,arg1,argList);
    Tcl_PanicVA(format, argList);
    va_end (argList);
}















|

|


<

|



>
>
>
>
>
>
>
>
116
117
118
119
120
121
122
123
124
125
126
127

128
129
130
131
132
133
134
135
136
137
138
139
140
 *
 * Side effects:
 *	The process dies, entering the debugger if possible.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
void
Tcl_Panic(CONST char *format, ...)
{
    va_list argList;


    va_start(argList, format);
    Tcl_PanicVA(format, argList);
    va_end (argList);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclParse.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
/* 
 * tclParse.c --
 *
 *	This file contains procedures that parse Tcl scripts.  They
 *	do so in a general-purpose fashion that can be used for many
 *	different purposes, including compilation, direct execution,
 *	code analysis, etc.  
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParse.c,v 1.39 2004/10/26 21:52:37 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following table provides parsing information about each possible
 * 8-bit character.  The table is designed to be referenced with either
 * signed or unsigned characters, so it has 384 entries.  The first 128
 * entries correspond to negative character values, the next 256 correspond
 * to positive character values.  The last 128 entries are identical to the
 * first 128.  The table is always indexed with a 128-byte offset (the 128th
 * entry corresponds to a character value of 0).
 *
 * The macro CHAR_TYPE is used to index into the table and return
 * information about its character argument.  The following return
 * values are defined.
 *
 * TYPE_NORMAL -        All characters that don't have special significance
 *                      to the Tcl parser.
 * TYPE_SPACE -         The character is a whitespace character other
 *                      than newline.
 * TYPE_COMMAND_END -   Character is newline or semicolon.
 * TYPE_SUBS -          Character begins a substitution or has other
 *                      special meaning in ParseTokens: backslash, dollar
 *                      sign, or open bracket.
 * TYPE_QUOTE -         Character is a double quote.
 * TYPE_CLOSE_PAREN -   Character is a right parenthesis.
 * TYPE_CLOSE_BRACK -   Character is a right square bracket.
 * TYPE_BRACE -         Character is a curly brace (either left or right).
 */

#define TYPE_NORMAL             0
#define TYPE_SPACE              0x1
#define TYPE_COMMAND_END        0x2
#define TYPE_SUBS               0x4
#define TYPE_QUOTE              0x8
#define TYPE_CLOSE_PAREN        0x10
#define TYPE_CLOSE_BRACK        0x20
#define TYPE_BRACE              0x40

#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]

static CONST char charTypeTable[] = {
    /*
     * Negative character values, from -128 to -1:
     */
|


|
|
|
<





|
|

|





|
|
|
|
|
|
|

|
|
<

|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|







1
2
3
4
5
6

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
/*
 * tclParse.c --
 *
 *	This file contains functions that parse Tcl scripts. They do so in a
 *	general-purpose fashion that can be used for many different purposes,
 *	including compilation, direct execution, code analysis, etc.

 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParse.c,v 1.39.2.4 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following table provides parsing information about each possible 8-bit
 * character. The table is designed to be referenced with either signed or
 * unsigned characters, so it has 384 entries. The first 128 entries
 * correspond to negative character values, the next 256 correspond to
 * positive character values. The last 128 entries are identical to the first
 * 128. The table is always indexed with a 128-byte offset (the 128th entry
 * corresponds to a character value of 0).
 *
 * The macro CHAR_TYPE is used to index into the table and return information
 * about its character argument. The following return values are defined.

 *
 * TYPE_NORMAL -	All characters that don't have special significance to
 *			the Tcl parser.
 * TYPE_SPACE -		The character is a whitespace character other than
 *			newline.
 * TYPE_COMMAND_END -	Character is newline or semicolon.
 * TYPE_SUBS -		Character begins a substitution or has other special
 *			meaning in ParseTokens: backslash, dollar sign, or
 *			open bracket.
 * TYPE_QUOTE -		Character is a double quote.
 * TYPE_CLOSE_PAREN -	Character is a right parenthesis.
 * TYPE_CLOSE_BRACK -	Character is a right square bracket.
 * TYPE_BRACE -		Character is a curly brace (either left or right).
 */

#define TYPE_NORMAL		0
#define TYPE_SPACE		0x1
#define TYPE_COMMAND_END	0x2
#define TYPE_SUBS		0x4
#define TYPE_QUOTE		0x8
#define TYPE_CLOSE_PAREN	0x10
#define TYPE_CLOSE_BRACK	0x20
#define TYPE_BRACE		0x40

#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]

static CONST char charTypeTable[] = {
    /*
     * Negative character values, from -128 to -1:
     */
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218

219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

/*
 * Prototypes for local procedures defined in this file:
 */

static int		CommandComplete _ANSI_ARGS_((CONST char *script,
			    int numBytes));
static int		ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
			    Tcl_Parse *parsePtr));
static int		ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
			    int mask, int flags, Tcl_Parse *parsePtr));

/*
 *----------------------------------------------------------------------
 *
 * TclParseInit --
 *
 * 	Initialize the fields of a Tcl_Parse struct.
 *
 * Results:
 * 	None.
 *
 * Side effects:
 * 	The Tcl_Parse struct pointed to by parsePtr gets initialized.
 *
 *----------------------------------------------------------------------
 */

void
TclParseInit(interp, string, numBytes, parsePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting */
    CONST char *string;		/* String to be parsed. */
    int numBytes;		/* Total number of bytes in string.  If < 0,
				 * the script consists of all bytes up to 
				 * the first null character. */
    Tcl_Parse *parsePtr;	/* Points to struct to initialize */
{
    parsePtr->numWords = 0;
    parsePtr->tokenPtr = parsePtr->staticTokens;
    parsePtr->numTokens = 0;
    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
    parsePtr->string = string;
    parsePtr->end = string + numBytes;
    parsePtr->term = parsePtr->end;
    parsePtr->interp = interp;
    parsePtr->incomplete = 0;
    parsePtr->errorType = TCL_PARSE_SUCCESS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseCommand --
 *
 *	Given a string, this procedure parses the first Tcl command
 *	in the string and returns information about the structure of
 *	the command.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed
 *	successfully and TCL_ERROR otherwise.  If an error occurs
 *	and interp isn't NULL then an error message is left in
 *	its result.  On a successful return, parsePtr is filled in
 *	with information about the command that was parsed.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the command, then additional space is
 *	malloc-ed.  If the procedure returns TCL_OK then the caller must
 *	eventually invoke Tcl_FreeParse to release any additional space
 *	that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* First character of string containing
				 * one or more Tcl commands. */
    register int numBytes;	/* Total number of bytes in string.  If < 0,
				 * the script consists of all bytes up to 
				 * the first null character. */
    int nested;			/* Non-zero means this is a nested command:
				 * close bracket should be considered
				 * a command terminator. If zero, then close
				 * bracket has no special meaning. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information
				 * about the parsed command; any previous
				 * information in the structure is
				 * ignored. */
{
    register CONST char *src;	/* Points to current character
				 * in the command. */
    char type;			/* Result returned by CHAR_TYPE(*src). */
    Tcl_Token *tokenPtr;	/* Pointer to token being filled in. */
    int wordIndex;		/* Index of word token for current word. */
    int terminators;		/* CHAR_TYPE bits that indicate the end
				 * of a command. */
    CONST char *termPtr;	/* Set by Tcl_ParseBraces/QuotedString to
				 * point to char after terminating one. */
    int scanned;
    
    if ((string == NULL) && (numBytes>0)) {
	if (interp != NULL) {
	    Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
	}
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(string);
    }
    TclParseInit(interp, string, numBytes, parsePtr);
    parsePtr->commentStart = NULL;
    parsePtr->commentSize = 0;
    parsePtr->commandStart = NULL;
    parsePtr->commandSize = 0;
    if (nested != 0) {
	terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
    } else {
	terminators = TYPE_COMMAND_END;
    }

    /*
     * Parse any leading space and comments before the first word of the
     * command.
     */

    scanned = ParseComment(string, numBytes, parsePtr);

    src = (string + scanned); numBytes -= scanned;
    if (numBytes == 0) {
	if (nested) {
	    parsePtr->incomplete = nested;
	}
    }

    /*
     * The following loop parses the words of the command, one word
     * in each iteration through the loop.
     */

    parsePtr->commandStart = src;
    while (1) {
	int expandWord = 0;

	/*







|




|
|


|




















|
|
|













>





|
|
<


|
<
|
|
|


|
|
|
<
|





|
|
|
<
|
|

|
|

|
|


|
|
|
<

|
|



|
|



|
|






|

|















|
>
|







|
|







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224

225
226
227

228
229
230
231
232
233
234
235

236
237
238
239
240
241
242
243
244

245
246
247
248
249
250
251
252
253
254
255
256
257

258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

/*
 * Prototypes for local functions defined in this file:
 */

static int		CommandComplete _ANSI_ARGS_((CONST char *script,
			    int numBytes));
static int		ParseComment _ANSI_ARGS_((CONST char *src,
			    int numBytes, Tcl_Parse *parsePtr));
static int		ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
			    int mask, int flags, Tcl_Parse *parsePtr));

/*
 *----------------------------------------------------------------------
 *
 * TclParseInit --
 *
 * 	Initialize the fields of a Tcl_Parse struct.
 *
 * Results:
 * 	None.
 *
 * Side effects:
 * 	The Tcl_Parse struct pointed to by parsePtr gets initialized.
 *
 *----------------------------------------------------------------------
 */

void
TclParseInit(interp, string, numBytes, parsePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting */
    CONST char *string;		/* String to be parsed. */
    int numBytes;		/* Total number of bytes in string. If < 0,
				 * the script consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Points to struct to initialize */
{
    parsePtr->numWords = 0;
    parsePtr->tokenPtr = parsePtr->staticTokens;
    parsePtr->numTokens = 0;
    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
    parsePtr->string = string;
    parsePtr->end = string + numBytes;
    parsePtr->term = parsePtr->end;
    parsePtr->interp = interp;
    parsePtr->incomplete = 0;
    parsePtr->errorType = TCL_PARSE_SUCCESS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseCommand --
 *
 *	Given a string, this function parses the first Tcl command in the
 *	string and returns information about the structure of the command.

 *
 * Results:
 *	The return value is TCL_OK if the command was parsed successfully and

 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
 *	error message is left in its result. On a successful return, parsePtr
 *	is filled in with information about the command that was parsed.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the command, then additional space is malloc-ed. If the function
 *	returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to

 *	release any additional space that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */

    CONST char *start;		/* First character of string containing one or
				 * more Tcl commands. */
    register int numBytes;	/* Total number of bytes in string.  If < 0,
				 * the script consists of all bytes up to the
				 * first null character. */
    int nested;			/* Non-zero means this is a nested command:
				 * close bracket should be considered a
				 * command terminator. If zero, then close
				 * bracket has no special meaning. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information about
				 * the parsed command; any previous
				 * information in the structure is ignored. */

{
    register CONST char *src;	/* Points to current character in the
				 * command. */
    char type;			/* Result returned by CHAR_TYPE(*src). */
    Tcl_Token *tokenPtr;	/* Pointer to token being filled in. */
    int wordIndex;		/* Index of word token for current word. */
    int terminators;		/* CHAR_TYPE bits that indicate the end of a
				 * command. */
    CONST char *termPtr;	/* Set by Tcl_ParseBraces/QuotedString to
				 * point to char after terminating one. */
    int scanned;

    if ((start == NULL) && (numBytes>0)) {
	if (interp != NULL) {
	    Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
	}
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(start);
    }
    TclParseInit(interp, start, numBytes, parsePtr);
    parsePtr->commentStart = NULL;
    parsePtr->commentSize = 0;
    parsePtr->commandStart = NULL;
    parsePtr->commandSize = 0;
    if (nested != 0) {
	terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
    } else {
	terminators = TYPE_COMMAND_END;
    }

    /*
     * Parse any leading space and comments before the first word of the
     * command.
     */

    scanned = ParseComment(start, numBytes, parsePtr);
    src = (start + scanned);
    numBytes -= scanned;
    if (numBytes == 0) {
	if (nested) {
	    parsePtr->incomplete = nested;
	}
    }

    /*
     * The following loop parses the words of the command, one word in each
     * iteration through the loop.
     */

    parsePtr->commandStart = src;
    while (1) {
	int expandWord = 0;

	/*
328
329
330
331
332
333
334
335

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360

361
362
363
364
365
366
367
368
369
370
371

372
373
374
375
376
377
378
379
380
381
382
383
384
385


386







387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437

438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494

495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511

512
513
514
515
516
517
518

	/*
	 * Skip white space before the word. Also skip a backslash-newline
	 * sequence: it should be treated just like white space.
	 */

	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
	src += scanned; numBytes -= scanned;

	if (numBytes == 0) {
	    parsePtr->term = src;
	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++;
	    break;
	}
	tokenPtr->start = src;
	parsePtr->numTokens++;
	parsePtr->numWords++;

	/*
	 * At this point the word can have one of four forms: something
	 * enclosed in quotes, something enclosed in braces, and
	 * expanding word, or an unquoted word (anything else).
	 */

parseWord:
	if (*src == '"') {
	    if (Tcl_ParseQuotedString(interp, src, numBytes,
		    parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }

	    src = termPtr; numBytes = parsePtr->end - src;
	} else if (*src == '{') {
	    static char expPfx[] = "expand";
	    CONST size_t expPfxLen = sizeof(expPfx) - 1;
	    int expIdx = wordIndex + 1;
	    Tcl_Token *expPtr;

	    if (Tcl_ParseBraces(interp, src, numBytes,
		    parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }

	    src = termPtr; numBytes = parsePtr->end - src;

	    /* 
	     * Check whether the braces contained
	     * the word expansion prefix.
	     */

	    expPtr = &parsePtr->tokenPtr[expIdx];
	    if ( (expPfxLen == (size_t) expPtr->size)
					/* Same length as prefix */
		    && (0 == expandWord)
		    			/* Haven't seen prefix already */
		    && (1 == parsePtr->numTokens - expIdx)
	    				/* Only one token */


		    && (0 == strncmp(expPfx,expPtr->start,expPfxLen))







					/* Is the prefix */
		    && (numBytes > 0)
		    && (TclParseWhiteSpace(termPtr, numBytes, parsePtr, &type)
			    == 0)
		    && (type != TYPE_COMMAND_END)
					/* Non-whitespace follows */
		    ) {
		expandWord = 1;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word.  Call ParseTokens and let it do
	     * all of the work.
	     */

	    if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
		    TCL_SUBST_ALL, parsePtr) != TCL_OK) {
		goto error;
	    }
	    src = parsePtr->term; numBytes = parsePtr->end - src;

	}

	/*
	 * Finish filling in the token for the word and check for the
	 * special case of a word consisting of a single range of
	 * literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
	if ((tokenPtr->numComponents == 1)
		&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
	    tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
	}
	if (expandWord) {
	    tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
	}

	/*
	 * Do two additional checks: (a) make sure we're really at the
	 * end of a word (there might have been garbage left after a
	 * quoted or braced word), and (b) check for the end of the
	 * command.
	 */

	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
	if (scanned) {
	    src += scanned; numBytes -= scanned;

	    continue;
	}

	if (numBytes == 0) {
	    parsePtr->term = src;
	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++; 
	    break;
	}
	if (src[-1] == '"') { 
	    if (interp != NULL) {
		Tcl_SetResult(interp, "extra characters after close-quote",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
	} else {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "extra characters after close-brace",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
	}
	parsePtr->term = src;
	goto error;
    }

    parsePtr->commandSize = src - parsePtr->commandStart;
    return TCL_OK;

    error:
    Tcl_FreeParse(parsePtr);
    parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseWhiteSpace --
 *
 *	Scans up to numBytes bytes starting at src, consuming white
 *	space as defined by Tcl's parsing rules.  
 *
 * Results:
 *	Returns the number of bytes recognized as white space.  Records
 *	at parsePtr, information about the parse.  Records at typePtr
 *	the character type of the non-whitespace character that terminated
 *	the scan.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
    CONST char *src;		/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated if parsing indicates
				 * an incomplete command. */
    char *typePtr;		/* Points to location to store character
				 * type of character that ends run
				 * of whitespace */
{
    register char type = TYPE_NORMAL;
    register CONST char *p = src;

    while (1) {
	while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
	    numBytes--; p++;

	}
	if (numBytes && (type & TYPE_SUBS)) {
	    if (*p != '\\') {
		break;
	    }
	    if (--numBytes == 0) {
		break;







|
>















|
|


|





>
|










>
|

|
|
<



|
<
|
|
|
|
>
>
|
>
>
>
>
>
>
>
|
|
|
|
|
|
|






|
|






|
>



|
|
<














|
|
|
<




|
>









|


|



















|




|





|
|


|
|
|
|






>





|
|
|
|
<






|
>







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373

374
375
376
377

378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436

437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

510
511
512
513
514
515
516
517
518
519
520
521
522
523
524

	/*
	 * Skip white space before the word. Also skip a backslash-newline
	 * sequence: it should be treated just like white space.
	 */

	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
	src += scanned;
	numBytes -= scanned;
	if (numBytes == 0) {
	    parsePtr->term = src;
	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++;
	    break;
	}
	tokenPtr->start = src;
	parsePtr->numTokens++;
	parsePtr->numWords++;

	/*
	 * At this point the word can have one of four forms: something
	 * enclosed in quotes, something enclosed in braces, and expanding
	 * word, or an unquoted word (anything else).
	 */

    parseWord:
	if (*src == '"') {
	    if (Tcl_ParseQuotedString(interp, src, numBytes,
		    parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr;
	    numBytes = parsePtr->end - src;
	} else if (*src == '{') {
	    static char expPfx[] = "expand";
	    CONST size_t expPfxLen = sizeof(expPfx) - 1;
	    int expIdx = wordIndex + 1;
	    Tcl_Token *expPtr;

	    if (Tcl_ParseBraces(interp, src, numBytes,
		    parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr;
	    numBytes = parsePtr->end - src;

	    /*
	     * Check whether the braces contained the word expansion prefix.

	     */

	    expPtr = &parsePtr->tokenPtr[expIdx];
	    if (

		(0 == expandWord)
		/* Haven't seen prefix already */
		&& (1 == parsePtr->numTokens - expIdx)
		/* Only one token */
		&& (((expPfxLen == (size_t) expPtr->size)
			    /* Same length as prefix */
			    && (0 == strncmp(expPfx,expPtr->start,expPfxLen)))
#ifdef ALLOW_EMPTY_EXPAND
			/*
			 * Allow {} in addition to {expand}
			 */
			|| (0 == (size_t) expPtr->size)
#endif
		    )
		/* Is the prefix */
		&& (numBytes > 0)
		&& (TclParseWhiteSpace(termPtr, numBytes, parsePtr,
			    &type) == 0)
		&& (type != TYPE_COMMAND_END)
		/* Non-whitespace follows */
		) {
		expandWord = 1;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word. Call ParseTokens and let it do all of
	     * the work.
	     */

	    if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
		    TCL_SUBST_ALL, parsePtr) != TCL_OK) {
		goto error;
	    }
	    src = parsePtr->term;
	    numBytes = parsePtr->end - src;
	}

	/*
	 * Finish filling in the token for the word and check for the special
	 * case of a word consisting of a single range of literal text.

	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
	if ((tokenPtr->numComponents == 1)
		&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
	    tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
	}
	if (expandWord) {
	    tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
	}

	/*
	 * Do two additional checks: (a) make sure we're really at the end of
	 * a word (there might have been garbage left after a quoted or braced
	 * word), and (b) check for the end of the command.

	 */

	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
	if (scanned) {
	    src += scanned;
	    numBytes -= scanned;
	    continue;
	}

	if (numBytes == 0) {
	    parsePtr->term = src;
	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++;
	    break;
	}
	if (src[-1] == '"') {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "extra characters after close-quote",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
	} else {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "extra characters after close-brace",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
	}
	parsePtr->term = src;
	goto error;
    }

    parsePtr->commandSize = src - parsePtr->commandStart;
    return TCL_OK;

  error:
    Tcl_FreeParse(parsePtr);
    parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseWhiteSpace --
 *
 *	Scans up to numBytes bytes starting at src, consuming white space as
 *	defined by Tcl's parsing rules.
 *
 * Results:
 *	Returns the number of bytes recognized as white space. Records at
 *	parsePtr, information about the parse. Records at typePtr the
 *	character type of the non-whitespace character that terminated the
 *	scan.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
    CONST char *src;		/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated if parsing indicates an incomplete
				 * command. */
    char *typePtr;		/* Points to location to store character type
				 * of character that ends run of whitespace */

{
    register char type = TYPE_NORMAL;
    register CONST char *p = src;

    while (1) {
	while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
	    numBytes--;
	    p++;
	}
	if (numBytes && (type & TYPE_SUBS)) {
	    if (*p != '\\') {
		break;
	    }
	    if (--numBytes == 0) {
		break;
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557

558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseHex --
 *
 *	Scans a hexadecimal number as a Tcl_UniChar value.
 *	(e.g., for parsing \x and \u escape sequences).
 *	At most numBytes bytes are scanned.
 *
 * Results:
 *	The numeric value is stored in *resultPtr.
 *	Returns the number of bytes consumed.
 *
 * Notes:
 *	Relies on the following properties of the ASCII
 *	character set, with which UTF-8 is compatible:
 *
 *	The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' 
 *	occupy consecutive code points, and '0' < 'A' < 'a'.
 *
 *----------------------------------------------------------------------
 */

int
TclParseHex(src, numBytes, resultPtr)
    CONST char *src;		/* First character to parse. */
    int numBytes;		/* Max number of byes to scan */
    Tcl_UniChar *resultPtr;	/* Points to storage provided by
				 * caller where the Tcl_UniChar
				 * resulting from the conversion is
				 * to be written. */
{
    Tcl_UniChar result = 0;
    register CONST char *p = src;

    while (numBytes--) {
	unsigned char digit = UCHAR(*p);








|
<
|


|
|


|
|

|
|



>




|
|
<
|







540
541
542
543
544
545
546
547

548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

570
571
572
573
574
575
576
577
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseHex --
 *
 *	Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing

 *	\x and \u escape sequences). At most numBytes bytes are scanned.
 *
 * Results:
 *	The numeric value is stored in *resultPtr. Returns the number of bytes
 *	consumed.
 *
 * Notes:
 *	Relies on the following properties of the ASCII character set, with
 *	which UTF-8 is compatible:
 *
 *	The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy
 *	consecutive code points, and '0' < 'A' < 'a'.
 *
 *----------------------------------------------------------------------
 */

int
TclParseHex(src, numBytes, resultPtr)
    CONST char *src;		/* First character to parse. */
    int numBytes;		/* Max number of byes to scan */
    Tcl_UniChar *resultPtr;	/* Points to storage provided by caller where
				 * the Tcl_UniChar resulting from the

				 * conversion is to be written. */
{
    Tcl_UniChar result = 0;
    register CONST char *p = src;

    while (numBytes--) {
	unsigned char digit = UCHAR(*p);

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642

643


644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682

683


684
685

686

687
688
689
690
691
692

693

694
695
696
697
698
699

700
701
702
703
704
705
706
707
708
709
710
711

712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729

730
731
732
733
734
735

736
737
738
739

740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770

771
772
773
774
775
776
777
778
779
780
781
782

783
784
785

786

787
788
789
790
791
792

793
794
795
796
797

798
799
800
801
802
803
804

805
806

807
808

809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904

905
906
907

908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924

925
926
927

928
929
930
931
932
933

934
935
936
937
938
939
940
941
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseBackslash --
 *
 *	Scans up to numBytes bytes starting at src, consuming a
 *	backslash sequence as defined by Tcl's parsing rules.  
 *
 * Results:
 * 	Records at readPtr the number of bytes making up the backslash
 * 	sequence.  Records at dst the UTF-8 encoded equivalent of
 * 	that backslash sequence.  Returns the number of bytes written
 * 	to dst, at most TCL_UTF_MAX.  Either readPtr or dst may be
 * 	NULL, if the results are not needed, but the return value is
 * 	the same either way.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseBackslash(src, numBytes, readPtr, dst)
    CONST char * src;	/* Points to the backslash character of a
			 * a backslash sequence */
    int numBytes;	/* Max number of bytes to scan */
    int *readPtr;	/* NULL, or points to storage where the
			 * number of bytes scanned should be written. */
    char *dst;		/* NULL, or points to buffer where the UTF-8
			 * encoding of the backslash sequence is to be
			 * written.  At most TCL_UTF_MAX bytes will be
			 * written there. */
{
    register CONST char *p = src+1;
    Tcl_UniChar result;
    int count;
    char buf[TCL_UTF_MAX];

    if (numBytes == 0) {
	if (readPtr != NULL) {
	    *readPtr = 0;
	}
	return 0;
    }

    if (dst == NULL) {
        dst = buf;
    }

    if (numBytes == 1) {

	/* Can only scan the backslash.  Return it. */


	result = '\\';
	count = 1;
	goto done;
    }

    count = 2;
    switch (*p) {
        /*
         * Note: in the conversions below, use absolute values (e.g.,
         * 0xa) rather than symbolic values (e.g. \n) that get converted
         * by the compiler.  It's possible that compilers on some
         * platforms will do the symbolic conversions differently, which
         * could result in non-portable Tcl scripts.
         */

        case 'a':
            result = 0x7;
            break;
        case 'b':
            result = 0x8;
            break;
        case 'f':
            result = 0xc;
            break;
        case 'n':
            result = 0xa;
            break;
        case 'r':
            result = 0xd;
            break;
        case 't':
            result = 0x9;
            break;
        case 'v':
            result = 0xb;
            break;
        case 'x':
	    count += TclParseHex(p+1, numBytes-1, &result);
	    if (count == 2) {

		/* No hexadigits -> This is just "x". */


		result = 'x';
	    } else {

		/* Keep only the last byte (2 hex digits) */

		result = (unsigned char) result;
	    }
            break;
        case 'u':
	    count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
	    if (count == 2) {

		/* No hexadigits -> This is just "u". */

		result = 'u';
	    }
            break;
        case '\n':
            count--;
            do {

                p++; count++;
            } while ((count < numBytes) && ((*p == ' ') || (*p == '\t')));
            result = ' ';
            break;
        case 0:
            result = '\\';
            count = 1;
            break;
        default:
            /*
             * Check for an octal number \oo?o?
             */

            if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
                result = (unsigned char)(*p - '0');
                p++;
                if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
			|| (UCHAR(*p) >= '8')) { 
                    break;
                }
                count = 3;
                result = (unsigned char)((result << 3) + (*p - '0'));
                p++;
                if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
			|| (UCHAR(*p) >= '8')) {
                    break;
                }
                count = 4;
                result = (unsigned char)((result << 3) + (*p - '0'));
                break;
            }

            /*
             * We have to convert here in case the user has put a
             * backslash in front of a multi-byte utf-8 character.
             * While this means nothing special, we shouldn't break up
             * a correct utf-8 character. [Bug #217987] test subst-3.2
             */

	    if (Tcl_UtfCharComplete(p, numBytes - 1)) {
	        count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
	    } else {
		char utfBytes[TCL_UTF_MAX];

		memcpy(utfBytes, p, (size_t) (numBytes - 1));
		utfBytes[numBytes - 1] = '\0';
	        count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
	    }
            break;
    }

    done:
    if (readPtr != NULL) {
        *readPtr = count;
    }
    return Tcl_UniCharToUtf((int) result, dst);
}

/*
 *----------------------------------------------------------------------
 *
 * ParseComment --
 *
 *	Scans up to numBytes bytes starting at src, consuming a
 *	Tcl comment as defined by Tcl's parsing rules.  
 *
 * Results:
 * 	Records in parsePtr information about the parse.  Returns the
 * 	number of bytes consumed.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseComment(src, numBytes, parsePtr)
    CONST char *src;		/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated if parsing indicates
				 * an incomplete command. */
{
    register CONST char *p = src;
    while (numBytes) {
	char type;
	int scanned;

	do {
	    scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
	    p += scanned; numBytes -= scanned;

	} while (numBytes && (*p == '\n') && (p++,numBytes--));

	if ((numBytes == 0) || (*p != '#')) {
	    break;
	}
	if (parsePtr->commentStart == NULL) {
	    parsePtr->commentStart = p;
	}

	while (numBytes) {
	    if (*p == '\\') {
		scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
		if (scanned) {
		    p += scanned; numBytes -= scanned;

		} else {
		    /*
		     * General backslash substitution in comments isn't
		     * part of the formal spec, but test parse-15.47
		     * and history indicate that it has been the de facto
		     * rule.  Don't change it now.
		     */

		    TclParseBackslash(p, numBytes, &scanned, NULL);
		    p += scanned; numBytes -= scanned;

		}
	    } else {

		p++; numBytes--;
		if (p[-1] == '\n') {
		    break;
		}
	    }
	}
	parsePtr->commentSize = p - parsePtr->commentStart;
    }
    return (p - src);
}

/*
 *----------------------------------------------------------------------
 *
 * ParseTokens --
 *
 *	This procedure forms the heart of the Tcl parser.  It parses one
 *	or more tokens from a string, up to a termination point
 *	specified by the caller.  This procedure is used to parse
 *	unquoted command words (those not in quotes or braces), words in
 *	quotes, and array indices for variables.  No more than numBytes
 *	bytes will be scanned.
 *
 * Results:
 *	Tokens are added to parsePtr and parsePtr->term is filled in
 *	with the address of the character that terminated the parse (the
 *	first one whose CHAR_TYPE matched mask or the character at
 *	parsePtr->end).  The return value is TCL_OK if the parse
 *	completed successfully and TCL_ERROR otherwise.  If a parse
 *	error occurs and parsePtr->interp isn't NULL, then an error
 *	message is left in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(src, numBytes, mask, flags, parsePtr)
    register CONST char *src;	/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    int flags;			/* OR-ed bits indicating what substitutions
				   to perform: TCL_SUBST_COMMANDS,
				   TCL_SUBST_VARIABLES, and 
				   TCL_SUBST_BACKSLASHES */
    int mask;			/* Specifies when to stop parsing.  The
				 * parse stops at the first unquoted
				 * character whose CHAR_TYPE contains
				 * any of the bits in mask. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated with additional tokens and
				 * termination information. */
{
    char type; 
    int originalTokens, varToken;
    int noSubstCmds = !(flags & TCL_SUBST_COMMANDS);
    int noSubstVars = !(flags & TCL_SUBST_VARIABLES);
    int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES);
    Tcl_Token *tokenPtr;
    Tcl_Parse nested;

    /*
     * Each iteration through the following loop adds one token of
     * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
     * TCL_TOKEN_VARIABLE to parsePtr.  For TCL_TOKEN_VARIABLE tokens,
     * additional tokens are added for the parsed variable name.
     */

    originalTokens = parsePtr->numTokens;
    while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	if ((type & TYPE_SUBS) == 0) {
	    /*
	     * This is a simple range of characters.  Scan to find the end
	     * of the range.
	     */

	    while ((++src, --numBytes) 
		    && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {
		/* empty loop */
	    }
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '$') {
	    if (noSubstVars) {
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->size = 1;
		parsePtr->numTokens++;

		src++; numBytes--;
		continue;
	    }

	    /*
	     * This is a variable reference.  Call Tcl_ParseVarName to do
	     * all the dirty work of parsing the name.
	     */

	    varToken = parsePtr->numTokens;
	    if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
		    parsePtr, 1) != TCL_OK) {
		return TCL_ERROR;
	    }
	    src += parsePtr->tokenPtr[varToken].size;
	    numBytes -= parsePtr->tokenPtr[varToken].size;
	} else if (*src == '[') {
	    if (noSubstCmds) {
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->size = 1;
		parsePtr->numTokens++;

		src++; numBytes--;
		continue;
	    }

	    /*
	     * Command substitution.  Call Tcl_ParseCommand recursively
	     * (and repeatedly) to parse the nested command(s), then
	     * throw away the parse information.
	     */


	    src++; numBytes--;
	    while (1) {
		if (Tcl_ParseCommand(parsePtr->interp, src,
			numBytes, 1, &nested) != TCL_OK) {
		    parsePtr->errorType = nested.errorType;
		    parsePtr->term = nested.term;
		    parsePtr->incomplete = nested.incomplete;
		    return TCL_ERROR;







|
|



|
|
|
|
<






>


|
|
|
|
|
|
|
|
|














|



>
|
>
>







|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
|
|
>
|
>
|
|
|
|
|
|
>
|
>
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
>
|
|
|
|
|


|

|









|
|


|
|






>





|
|





>


|
>

>






>




|
>


|
|
|
|

>

|
>


>
|









|





|
|
<
|
|
|


|
|
|
|
<
|
|











|
|
|

|
|
|
|




|








|
|
|
|













|
|


|











>
|


>

|
|














>
|


>

|
|
|


>
|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611

612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855

856
857
858
859
860
861
862
863
864

865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseBackslash --
 *
 *	Scans up to numBytes bytes starting at src, consuming a backslash
 *	sequence as defined by Tcl's parsing rules.
 *
 * Results:
 * 	Records at readPtr the number of bytes making up the backslash
 * 	sequence. Records at dst the UTF-8 encoded equivalent of that
 * 	backslash sequence. Returns the number of bytes written to dst, at
 * 	most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results
 * 	are not needed, but the return value is the same either way.

 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseBackslash(src, numBytes, readPtr, dst)
    CONST char *src;		/* Points to the backslash character of a a
				 * backslash sequence. */
    int numBytes;		/* Max number of bytes to scan. */
    int *readPtr;		/* NULL, or points to storage where the number
				 * of bytes scanned should be written. */
    char *dst;			/* NULL, or points to buffer where the UTF-8
				 * encoding of the backslash sequence is to be
				 * written. At most TCL_UTF_MAX bytes will be
				 * written there. */
{
    register CONST char *p = src+1;
    Tcl_UniChar result;
    int count;
    char buf[TCL_UTF_MAX];

    if (numBytes == 0) {
	if (readPtr != NULL) {
	    *readPtr = 0;
	}
	return 0;
    }

    if (dst == NULL) {
	dst = buf;
    }

    if (numBytes == 1) {
	/*
	 * Can only scan the backslash, so return it.
	 */

	result = '\\';
	count = 1;
	goto done;
    }

    count = 2;
    switch (*p) {
	/*
	 * Note: in the conversions below, use absolute values (e.g., 0xa)
	 * rather than symbolic values (e.g. \n) that get converted by the
	 * compiler. It's possible that compilers on some platforms will do
	 * the symbolic conversions differently, which could result in
	 * non-portable Tcl scripts.
	 */

    case 'a':
	result = 0x7;
	break;
    case 'b':
	result = 0x8;
	break;
    case 'f':
	result = 0xc;
	break;
    case 'n':
	result = 0xa;
	break;
    case 'r':
	result = 0xd;
	break;
    case 't':
	result = 0x9;
	break;
    case 'v':
	result = 0xb;
	break;
    case 'x':
	count += TclParseHex(p+1, numBytes-1, &result);
	if (count == 2) {
	    /*
	     * No hexadigits -> This is just "x".
	     */

	    result = 'x';
	} else {
	    /*
	     * Keep only the last byte (2 hex digits).
	     */
	    result = (unsigned char) result;
	}
	break;
    case 'u':
	count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
	if (count == 2) {
	    /*
	     * No hexadigits -> This is just "u".
	     */
	    result = 'u';
	}
	break;
    case '\n':
	count--;
	do {
	    p++;
	    count++;
	} while ((count < numBytes) && ((*p == ' ') || (*p == '\t')));
	result = ' ';
	break;
    case 0:
	result = '\\';
	count = 1;
	break;
    default:
	/*
	 * Check for an octal number \oo?o?
	 */

	if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) {	/* INTL: digit */
	    result = (unsigned char)(*p - '0');
	    p++;
	    if ((numBytes == 2) || !isdigit(UCHAR(*p))	/* INTL: digit */
		    || (UCHAR(*p) >= '8')) {
		break;
	    }
	    count = 3;
	    result = (unsigned char)((result << 3) + (*p - '0'));
	    p++;
	    if ((numBytes == 3) || !isdigit(UCHAR(*p))	/* INTL: digit */
		    || (UCHAR(*p) >= '8')) {
		break;
	    }
	    count = 4;
	    result = (unsigned char)((result << 3) + (*p - '0'));
	    break;
	}

	/*
	 * We have to convert here in case the user has put a backslash in
	 * front of a multi-byte utf-8 character. While this means nothing
	 * special, we shouldn't break up a correct utf-8 character. [Bug
	 * #217987] test subst-3.2
	 */

	if (Tcl_UtfCharComplete(p, numBytes - 1)) {
	    count = Tcl_UtfToUniChar(p, &result) + 1;	/* +1 for '\' */
	} else {
	    char utfBytes[TCL_UTF_MAX];

	    memcpy(utfBytes, p, (size_t) (numBytes - 1));
	    utfBytes[numBytes - 1] = '\0';
	    count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
	}
	break;
    }

  done:
    if (readPtr != NULL) {
	*readPtr = count;
    }
    return Tcl_UniCharToUtf((int) result, dst);
}

/*
 *----------------------------------------------------------------------
 *
 * ParseComment --
 *
 *	Scans up to numBytes bytes starting at src, consuming a Tcl comment as
 *	defined by Tcl's parsing rules.
 *
 * Results:
 * 	Records in parsePtr information about the parse. Returns the number of
 * 	bytes consumed.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseComment(src, numBytes, parsePtr)
    CONST char *src;		/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated if parsing indicates an incomplete
				 * command. */
{
    register CONST char *p = src;
    while (numBytes) {
	char type;
	int scanned;

	do {
	    scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
	    p += scanned;
	    numBytes -= scanned;
	} while (numBytes && (*p == '\n') && (p++,numBytes--));

	if ((numBytes == 0) || (*p != '#')) {
	    break;
	}
	if (parsePtr->commentStart == NULL) {
	    parsePtr->commentStart = p;
	}

	while (numBytes) {
	    if (*p == '\\') {
		scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
		if (scanned) {
		    p += scanned;
		    numBytes -= scanned;
		} else {
		    /*
		     * General backslash substitution in comments isn't part
		     * of the formal spec, but test parse-15.47 and history
		     * indicate that it has been the de facto rule. Don't
		     * change it now.
		     */

		    TclParseBackslash(p, numBytes, &scanned, NULL);
		    p += scanned;
		    numBytes -= scanned;
		}
	    } else {
		p++;
		numBytes--;
		if (p[-1] == '\n') {
		    break;
		}
	    }
	}
	parsePtr->commentSize = p - parsePtr->commentStart;
    }
    return (p - src);
}

/*
 *----------------------------------------------------------------------
 *
 * ParseTokens --
 *
 *	This function forms the heart of the Tcl parser. It parses one or more
 *	tokens from a string, up to a termination point specified by the

 *	caller. This function is used to parse unquoted command words (those
 *	not in quotes or braces), words in quotes, and array indices for
 *	variables. No more than numBytes bytes will be scanned.
 *
 * Results:
 *	Tokens are added to parsePtr and parsePtr->term is filled in with the
 *	address of the character that terminated the parse (the first one
 *	whose CHAR_TYPE matched mask or the character at parsePtr->end). The
 *	return value is TCL_OK if the parse completed successfully and

 *	TCL_ERROR otherwise. If a parse error occurs and parsePtr->interp is
 *	not NULL, then an error message is left in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(src, numBytes, mask, flags, parsePtr)
    register CONST char *src;	/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    int flags;			/* OR-ed bits indicating what substitutions to
				   perform: TCL_SUBST_COMMANDS,
				   TCL_SUBST_VARIABLES, and
				   TCL_SUBST_BACKSLASHES */
    int mask;			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated with additional tokens and
				 * termination information. */
{
    char type;
    int originalTokens, varToken;
    int noSubstCmds = !(flags & TCL_SUBST_COMMANDS);
    int noSubstVars = !(flags & TCL_SUBST_VARIABLES);
    int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES);
    Tcl_Token *tokenPtr;
    Tcl_Parse nested;

    /*
     * Each iteration through the following loop adds one token of type
     * TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or TCL_TOKEN_VARIABLE
     * to parsePtr. For TCL_TOKEN_VARIABLE tokens, additional tokens are added
     * for the parsed variable name.
     */

    originalTokens = parsePtr->numTokens;
    while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	if ((type & TYPE_SUBS) == 0) {
	    /*
	     * This is a simple range of characters. Scan to find the end of
	     * the range.
	     */

	    while ((++src, --numBytes)
		    && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {
		/* empty loop */
	    }
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '$') {
	    if (noSubstVars) {
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->size = 1;
		parsePtr->numTokens++;
		src++;
		numBytes--;
		continue;
	    }

	    /*
	     * This is a variable reference. Call Tcl_ParseVarName to do all
	     * the dirty work of parsing the name.
	     */

	    varToken = parsePtr->numTokens;
	    if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
		    parsePtr, 1) != TCL_OK) {
		return TCL_ERROR;
	    }
	    src += parsePtr->tokenPtr[varToken].size;
	    numBytes -= parsePtr->tokenPtr[varToken].size;
	} else if (*src == '[') {
	    if (noSubstCmds) {
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->size = 1;
		parsePtr->numTokens++;
		src++;
		numBytes--;
		continue;
	    }

	    /*
	     * Command substitution. Call Tcl_ParseCommand recursively (and
	     * repeatedly) to parse the nested command(s), then throw away the
	     * parse information.
	     */

	    src++;
	    numBytes--;
	    while (1) {
		if (Tcl_ParseCommand(parsePtr->interp, src,
			numBytes, 1, &nested) != TCL_OK) {
		    parsePtr->errorType = nested.errorType;
		    parsePtr->term = nested.term;
		    parsePtr->incomplete = nested.incomplete;
		    return TCL_ERROR;
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983

984
985
986

987
988
989

990
991
992

993


994
995

996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037

1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200

1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226

1227
1228
1229
1230
1231
1232
1233

1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252

1253
1254
1255
1256
1257

1258
1259
1260
1261
1262
1263
1264

1265
1266
1267
1268

1269

1270
1271
1272
1273
1274
1275
1276
1277
1278
1279

1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611









1612








































1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767

1768


1769
1770
1771
1772
1773
1774
1775
1776
1777
1778

1779
1780
1781
1782
1783

1784
1785
1786
1787
1788
1789
1790
1791
1792
1793

1794
1795
1796
1797
1798
1799

1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833

1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848

1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883

1884


1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002


2003


2004
2005
2006


2007
2008
2009

2010
2011
2012

2013

2014


2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038

2039
2040


2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057

2058

2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074

2075


2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135

		if (nested.tokenPtr != nested.staticTokens) {
		    ckfree((char *) nested.tokenPtr);
		}

		/*
		 * Check for the closing ']' that ends the command
		 * substitution.  It must have been the last character of
		 * the parsed command.
		 */

		if ((nested.term < parsePtr->end) && (*nested.term == ']')
			&& !nested.incomplete) {
		    break;
		}
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			Tcl_SetResult(parsePtr->interp,
			    "missing close-bracket", TCL_STATIC);
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    return TCL_ERROR;
		}
	    }
	    tokenPtr->type = TCL_TOKEN_COMMAND;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '\\') {
	    if (noSubstBS) {
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->size = 1;
		parsePtr->numTokens++;

		src++; numBytes--;
		continue;
	    }

	    /*
	     * Backslash substitution.
	     */

	    TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);

	    if (tokenPtr->size == 1) {

		/* Just a backslash, due to end of string */


		tokenPtr->type = TCL_TOKEN_TEXT;
		parsePtr->numTokens++;

		src++; numBytes--;
		continue;
	    }

	    if (src[1] == '\n') {
		if (numBytes == 2) {
		    parsePtr->incomplete = 1;
		}

		/*
		 * Note: backslash-newline is special in that it is
		 * treated the same as a space character would be.  This
		 * means that it could terminate the token.
		 */

		if (mask & TYPE_SPACE) {
		    if (parsePtr->numTokens == originalTokens) {
			goto finishToken;
		    }
		    break;
		}
	    }

	    tokenPtr->type = TCL_TOKEN_BS;
	    parsePtr->numTokens++;
	    src += tokenPtr->size;
	    numBytes -= tokenPtr->size;
	} else if (*src == 0) {
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = 1;
	    parsePtr->numTokens++;

	    src++; numBytes--;
	} else {
	    Tcl_Panic("ParseTokens encountered unknown character");
	}
    }
    if (parsePtr->numTokens == originalTokens) {
	/*
	 * There was nothing in this range of text.  Add an empty token
	 * for the empty range, so that there is always at least one
	 * token added.
	 */

	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	finishToken:
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->size = 0;
	parsePtr->numTokens++;
    }
    parsePtr->term = src;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeParse --
 *
 *	This procedure is invoked to free any dynamic storage that may
 *	have been allocated by a previous call to Tcl_ParseCommand.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is any dynamically allocated memory in *parsePtr,
 *	it is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FreeParse(parsePtr)
    Tcl_Parse *parsePtr;	/* Structure that was filled in by a
				 * previous call to Tcl_ParseCommand. */
{
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
	parsePtr->tokenPtr = parsePtr->staticTokens;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandTokenArray --
 *
 *	This procedure is invoked when the current space for tokens in
 *	a Tcl_Parse structure fills up; it allocates memory to grow the
 *	token array
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is allocated for a new larger token array; the memory
 *	for the old array is freed, if it had been dynamically allocated.
 *
 *----------------------------------------------------------------------
 */

void
TclExpandTokenArray(parsePtr)
    Tcl_Parse *parsePtr;	/* Parse structure whose token space
				 * has overflowed. */
{
    int newCount;
    Tcl_Token *newPtr;

    newCount = parsePtr->tokensAvailable*2;
    newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
    memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
	    (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    parsePtr->tokenPtr = newPtr;
    parsePtr->tokensAvailable = newCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVarName --
 *
 *	Given a string starting with a $ sign, parse off a variable
 *	name and return information about the parse.  No more than
 *	numBytes bytes will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed
 *	successfully and TCL_ERROR otherwise.  If an error occurs and
 *	interp isn't NULL then an error message is left in its result. 
 *	On a successful return, tokenPtr and numTokens fields of
 *	parsePtr are filled in with information about the variable name
 *	that was parsed.  The "size" field of the first new token gives
 *	the total number of bytes in the variable name.  Other fields in
 *	parsePtr are undefined.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the command, then additional space is
 *	malloc-ed.  If the procedure returns TCL_OK then the caller must
 *	eventually invoke Tcl_FreeParse to release any additional space
 *	that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* String containing variable name.  First
				 * character must be "$". */
    register int numBytes;	/* Total number of bytes in string.  If < 0,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill in with information
				 * about the variable name. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and reinitialize
				 * it. */
{
    Tcl_Token *tokenPtr;
    register CONST char *src;
    unsigned char c;
    int varIndex, offset;
    Tcl_UniChar ch;
    unsigned array;

    if ((numBytes == 0) || (string == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(string);
    }

    if (!append) {
	TclParseInit(interp, string, numBytes, parsePtr);
    }

    /*
     * Generate one token for the variable, an additional token for the
     * name, plus any number of additional tokens for the index, if
     * there is one.
     */

    src = string;
    if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
    tokenPtr->type = TCL_TOKEN_VARIABLE;
    tokenPtr->start = src;
    varIndex = parsePtr->numTokens;
    parsePtr->numTokens++;
    tokenPtr++;

    src++; numBytes--;
    if (numBytes == 0) {
	goto justADollarSign;
    }
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src;
    tokenPtr->numComponents = 0;

    /*
     * The name of the variable can have three forms:
     * 1. The $ sign is followed by an open curly brace.  Then 
     *    the variable name is everything up to the next close
     *    curly brace, and the variable is a scalar variable.
     * 2. The $ sign is not followed by an open curly brace.  Then
     *    the variable name is everything up to the next
     *    character that isn't a letter, digit, or underscore.
     *    :: sequences are also considered part of the variable
     *    name, in order to support namespaces. If the following
     *    character is an open parenthesis, then the information
     *    between parentheses is the array element name.
     * 3. The $ sign is followed by something that isn't a letter,
     *    digit, or underscore:  in this case, there is no variable
     *    name and the token is just "$".
     */

    if (*src == '{') {

	src++; numBytes--;
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	while (numBytes && (*src != '}')) {
	    numBytes--; src++;

	}
	if (numBytes == 0) {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "missing close-brace for variable name",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = 1;
	    goto error;
	}
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr[-1].size = src - tokenPtr[-1].start;
	parsePtr->numTokens++;
	src++;
    } else {
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	while (numBytes) {
	    if (Tcl_UtfCharComplete(src, numBytes)) {
	        offset = Tcl_UtfToUniChar(src, &ch);
	    } else {
		char utfBytes[TCL_UTF_MAX];

		memcpy(utfBytes, src, (size_t) numBytes);
		utfBytes[numBytes] = '\0';
	        offset = Tcl_UtfToUniChar(utfBytes, &ch);
	    }
	    c = UCHAR(ch);
	    if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
		src += offset;  numBytes -= offset;

		continue;
	    }
	    if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
		src += 2; numBytes -= 2;

		while (numBytes && (*src == ':')) {

		    src++; numBytes--; 
		}
		continue;
	    }
	    break;
	}

	/*
	 * Support for empty array names here.
	 */

	array = (numBytes && (*src == '('));
	tokenPtr->size = src - tokenPtr->start;
	if ((tokenPtr->size == 0) && !array) {
	    goto justADollarSign;
	}
	parsePtr->numTokens++;
	if (array) {
	    /*
	     * This is a reference to an array element.  Call
	     * ParseTokens recursively to parse the element name,
	     * since it could contain any number of substitutions.
	     */

	    if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
		    TCL_SUBST_ALL, parsePtr)) {
		goto error;
	    }
	    if ((parsePtr->term == (src + numBytes)) 
		    || (*parsePtr->term != ')')) { 
		if (parsePtr->interp != NULL) {
		    Tcl_SetResult(parsePtr->interp, "missing )",
			    TCL_STATIC);
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = 1;
		goto error;
	    }
	    src = parsePtr->term + 1;
	}
    }
    tokenPtr = &parsePtr->tokenPtr[varIndex];
    tokenPtr->size = src - tokenPtr->start;
    tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
    return TCL_OK;

    /*
     * The dollar sign isn't followed by a variable name.
     * replace the TCL_TOKEN_VARIABLE token with a
     * TCL_TOKEN_TEXT token for the dollar sign.
     */

    justADollarSign:
    tokenPtr = &parsePtr->tokenPtr[varIndex];
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->size = 1;
    tokenPtr->numComponents = 0;
    return TCL_OK;

    error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVar --
 *
 *	Given a string starting with a $ sign, parse off a variable
 *	name and return its value.
 *
 * Results:
 *	The return value is the contents of the variable given by
 *	the leading characters of string.  If termPtr isn't NULL,
 *	*termPtr gets filled in with the address of the character
 *	just after the last one in the variable specifier.  If the
 *	variable doesn't exist, then the return value is NULL and
 *	an error message will be left in interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ParseVar(interp, string, termPtr)
    Tcl_Interp *interp;			/* Context for looking up variable. */
    register CONST char *string;	/* String containing variable name.
					 * First character must be "$". */
    CONST char **termPtr;		/* If non-NULL, points to word to fill
					 * in with character just after last
					 * one in the variable specifier. */

{
    Tcl_Parse parse;
    register Tcl_Obj *objPtr;
    int code;

    if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
	return NULL;
    }

    if (termPtr != NULL) {
	*termPtr = string + parse.tokenPtr->size;
    }
    if (parse.numTokens == 1) {
	/*
	 * There isn't a variable name after all: the $ is just a $.
	 */

	return "$";
    }

    code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL);
    if (code != TCL_OK) {
	return NULL;
    }
    objPtr = Tcl_GetObjResult(interp);

    /*
     * At this point we should have an object containing the value of
     * a variable.  Just return the string from that object.
     *
     * This should have returned the object for the user to manage, but
     * instead we have some weak reference to the string value in the
     * object, which is why we make sure the object exists after resetting
     * the result.  This isn't ideal, but it's the best we can do with the
     * current documented interface. -- hobbs
     */

    if (!Tcl_IsShared(objPtr)) {
	Tcl_IncrRefCount(objPtr);
    }
    Tcl_ResetResult(interp);
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseBraces --
 *
 *	Given a string in braces such as a Tcl command argument or a string
 *	value in a Tcl expression, this procedure parses the string and
 *	returns information about the parse.  No more than numBytes bytes
 *	will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the string was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
 *	an error message is left in its result. On a successful return,
 *	tokenPtr and numTokens fields of parsePtr are filled in with
 *	information about the string that was parsed. Other fields in
 *	parsePtr are undefined. termPtr is set to point to the character
 *	just after the last one in the braced string.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the command, then additional space is
 *	malloc-ed. If the procedure returns TCL_OK then the caller must
 *	eventually invoke Tcl_FreeParse to release any additional space
 *	that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* String containing the string in braces.
				 * The first character must be '{'. */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to
				 * the first null character. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information
				 * about the string. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means
				 * ignore existing tokens in parsePtr and
				 * reinitialize it. */
    CONST char **termPtr;	/* If non-NULL, points to word in which to
				 * store a pointer to the character just
				 * after the terminating '}' if the parse
				 * was successful. */

{
    Tcl_Token *tokenPtr;
    register CONST char *src;
    int startIndex, level, length;

    if ((numBytes == 0) || (string == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(string);
    }

    if (!append) {
	TclParseInit(interp, string, numBytes, parsePtr);
    }

    src = string;
    startIndex = parsePtr->numTokens;

    if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    tokenPtr = &parsePtr->tokenPtr[startIndex];
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src+1;
    tokenPtr->numComponents = 0;
    level = 1;
    while (1) {
	while (++src, --numBytes) {
	    if (CHAR_TYPE(*src) != TYPE_NORMAL) {
		break;
	    }
	}
	if (numBytes == 0) {
	    register int openBrace = 0;

	    parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
	    parsePtr->term = string;
	    parsePtr->incomplete = 1;
	    if (interp == NULL) {
		/*
		 * Skip straight to the exit code since we have no
		 * interpreter to put error message in.
		 */
		goto error;
	    }

	    Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);

	    /*
	     *  Guess if the problem is due to comments by searching
	     *  the source string for a possible open brace within the
	     *  context of a comment.  Since we aren't performing a
	     *  full Tcl parse, just look for an open brace preceded
	     *  by a '<whitespace>#' on the same line.
	     */

	    for (; src > string; src--) {
		switch (*src) {
		    case '{':
			openBrace = 1;
			break;
		    case '\n':
			openBrace = 0;
			break;
		    case '#' :
			if (openBrace && (isspace(UCHAR(src[-1])))) {
			    Tcl_AppendResult(interp,
				    ": possible unbalanced brace in comment",
				    (char *) NULL);
			    goto error;
			}
			break;
		}
	    }

	    error:
	    Tcl_FreeParse(parsePtr);
	    return TCL_ERROR;
	}
	switch (*src) {
	    case '{':
		level++;
		break;
	    case '}':
		if (--level == 0) {

		    /*
		     * Decide if we need to finish emitting a
		     * partially-finished token.  There are 3 cases:
		     *     {abc \newline xyz} or {xyz}
		     *		- finish emitting "xyz" token
		     *     {abc \newline}
		     *		- don't emit token after \newline
		     *     {}	- finish emitting zero-sized token
		     *
		     * The last case ensures that there is a token
		     * (even if empty) that describes the braced string.
		     */
    
		    if ((src != tokenPtr->start)
			    || (parsePtr->numTokens == startIndex)) {
			tokenPtr->size = (src - tokenPtr->start);
			parsePtr->numTokens++;
		    }
		    if (termPtr != NULL) {
			*termPtr = src+1;
		    }
		    return TCL_OK;
		}
		break;
	    case '\\':
		TclParseBackslash(src, numBytes, &length, NULL);
		if ((length > 1) && (src[1] == '\n')) {
		    /*
		     * A backslash-newline sequence must be collapsed, even
		     * inside braces, so we have to split the word into
		     * multiple tokens so that the backslash-newline can be
		     * represented explicitly.
		     */
		
		    if (numBytes == 2) {
			parsePtr->incomplete = 1;
		    }
		    tokenPtr->size = (src - tokenPtr->start);
		    if (tokenPtr->size != 0) {
			parsePtr->numTokens++;
		    }
		    if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
			TclExpandTokenArray(parsePtr);
		    }
		    tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
		    tokenPtr->type = TCL_TOKEN_BS;
		    tokenPtr->start = src;
		    tokenPtr->size = length;
		    tokenPtr->numComponents = 0;
		    parsePtr->numTokens++;
		
		    src += length - 1;
		    numBytes -= length - 1;
		    tokenPtr++;
		    tokenPtr->type = TCL_TOKEN_TEXT;
		    tokenPtr->start = src + 1;
		    tokenPtr->numComponents = 0;
		} else {
		    src += length - 1;
		    numBytes -= length - 1;
		}
		break;
	}
    }
}


















































/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseQuotedString --
 *
 *	Given a double-quoted string such as a quoted Tcl command argument
 *	or a quoted value in a Tcl expression, this procedure parses the
 *	string and returns information about the parse.  No more than
 *	numBytes bytes will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the string was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
 *	an error message is left in its result. On a successful return,
 *	tokenPtr and numTokens fields of parsePtr are filled in with
 *	information about the string that was parsed. Other fields in
 *	parsePtr are undefined. termPtr is set to point to the character
 *	just after the quoted string's terminating close-quote.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the command, then additional space is
 *	malloc-ed. If the procedure returns TCL_OK then the caller must
 *	eventually invoke Tcl_FreeParse to release any additional space
 *	that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* String containing the quoted string. 
				 * The first character must be '"'. */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to
				 * the first null character. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information
				 * about the string. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means
				 * ignore existing tokens in parsePtr and
				 * reinitialize it. */
    CONST char **termPtr;	/* If non-NULL, points to word in which to
				 * store a pointer to the character just
				 * after the quoted string's terminating
				 * close-quote if the parse succeeds. */
{
    if ((numBytes == 0) || (string == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(string);
    }

    if (!append) {
	TclParseInit(interp, string, numBytes, parsePtr);
    }
    
    if (TCL_OK != ParseTokens(string+1, numBytes-1, TYPE_QUOTE,
	    TCL_SUBST_ALL, parsePtr)) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (interp != NULL) {
	    Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = string;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {
	*termPtr = (parsePtr->term + 1);
    }
    return TCL_OK;

    error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SubstObj --
 *
 *      This function performs the substitutions specified on the
 *      given string as described in the user documentation for the
 *      "subst" Tcl command.       
 *
 * Results:
 *      A Tcl_Obj* containing the substituted string, or NULL to
 *      indicate that an error occurred.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_SubstObj(interp, objPtr, flags)
    Tcl_Interp *interp;	/* Interpreter in which substitution occurs */
    Tcl_Obj *objPtr;	/* The value to be substituted */
    int flags;		/* What substitutions to do */
{
    int length, tokensLeft, code;
    Tcl_Parse parse;
    Tcl_Token *endTokenPtr;
    Tcl_Obj *result;
    Tcl_Obj *errMsg = NULL;
    CONST char *p = Tcl_GetStringFromObj(objPtr, &length);

    TclParseInit(interp, p, length, &parse);

    /*
     * First parse the string rep of objPtr, as if it were enclosed
     * as a "-quoted word in a normal Tcl command.  Honor flags that
     * selectively inhibit types of substitution.
     */

    if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) {

	/*
	 * There was a parse error.  Save the error message for
	 * possible reporting later.
	 */

	errMsg = Tcl_GetObjResult(interp);
	Tcl_IncrRefCount(errMsg);

	/*
	 * We need to re-parse to get the portion of the string we can
	 * [subst] before the parse error.  Sadly, all the Tcl_Token's
	 * created by the first parse attempt are gone, freed according to the
	 * public spec for the Tcl_Parse* routines.  The only clue we have
	 * is parse.term, which points to either the unmatched opener, or
	 * to characters that follow a close brace or close quote.
	 *
	 * Call ParseTokens again, working on the string up to parse.term.
	 * Keep repeating until we get a good parse on a prefix.
	 */

	do {
	    parse.numTokens = 0;
	    parse.tokensAvailable = NUM_STATIC_TOKENS;
	    parse.end = parse.term;
	    parse.incomplete = 0;
	    parse.errorType = TCL_PARSE_SUCCESS;
	} while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse));


	/* The good parse will have to be followed by {, (, or [. */


	switch (*parse.term) {
	    case '{':
		/*
		 * Parse error was a missing } in a ${varname} variable
		 * substitution at the toplevel.  We will subst everything
		 * up to that broken variable substitution before reporting
		 * the parse error.  Substituting the leftover '$' will
		 * have no side-effects, so the current token stream is fine.
		 */
		break;

	    case '(':
		/*
		 * Parse error was during the parsing of the index part of
		 * an array variable substitution at the toplevel.  
		 */

		if (*(parse.term - 1) == '$') {
		    /*
		     * Special case where removing the array index left
		     * us with just a dollar sign (array variable with
		     * name the empty string as its name), instead of
		     * with a scalar variable reference.  
		     *
		     * As in the previous case, existing token stream is OK.
		     */
		} else {

		   /* The current parse includes a successful parse of a
		    * scalar variable substitution where there should have
		    * been an array variable substitution.  We remove that
		    * mistaken part of the parse before moving on.  A scalar
		    * variable substitution is two tokens.
		    */

		    Tcl_Token *varTokenPtr =
			    parse.tokenPtr + parse.numTokens - 2;

		    if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
			Tcl_Panic("Tcl_SubstObj: programming error");
		    }
		    if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
			Tcl_Panic("Tcl_SubstObj: programming error");
		    }
		    parse.numTokens -= 2;
		}
		break;
	    case '[':
		/*
		 * Parse error occurred during parsing of a toplevel
		 * command substitution.  
		 */

		parse.end = p + length;
		p = parse.term + 1;
		length = parse.end - p;
		if (length == 0) {
		    /*
		     * No commands, just an unmatched [.  
		     * As in previous cases, existing token stream is OK.
		     */
		} else {
		    /* 
		     * We want to add the parsing of as many commands as we
		     * can within that substitution until we reach the
		     * actual parse error.  We'll do additional parsing to
		     * determine what length to claim for the final
		     * TCL_TOKEN_COMMAND token.
		     */

		    Tcl_Token *tokenPtr;
		    Tcl_Parse nested;
		    CONST char *lastTerm = parse.term;

		    while (TCL_OK == 
			    Tcl_ParseCommand(NULL, p, length, 0, &nested)) {
			Tcl_FreeParse(&nested);
			p = nested.term + (nested.term < nested.end);
			length = nested.end - p;
			if ((length == 0) && (nested.term == nested.end)) {
			    /*
			     * If we run out of string, blame the missing
			     * close bracket on the last command, and do
			     * not evaluate it during substitution.
			     */

			    break;
			}
			lastTerm = nested.term;
		    }

		    if (lastTerm == parse.term) {
			/*
			 * Parse error in first command.  No commands
			 * to subst, add no more tokens.
			 */
			break;
		    }

		    /*
		     * Create a command substitution token for whatever
		     * commands got parsed.
		     */

		    if (parse.numTokens == parse.tokensAvailable) {
			TclExpandTokenArray(&parse);
		    }
		    tokenPtr = &parse.tokenPtr[parse.numTokens];
		    tokenPtr->start = parse.term;
		    tokenPtr->numComponents = 0;
		    tokenPtr->type = TCL_TOKEN_COMMAND;
		    tokenPtr->size = lastTerm - tokenPtr->start + 1;
		    parse.numTokens++;
		}
		break;

	    default:
		Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]);
	}
    }


    /* Next, substitute the parsed tokens just as in normal Tcl evaluation */


    endTokenPtr = parse.tokenPtr + parse.numTokens;
    tokensLeft = parse.numTokens;
    code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
	    &tokensLeft);
    if (code == TCL_OK) {
	Tcl_FreeParse(&parse);
	if (errMsg != NULL) {
	    Tcl_SetObjResult(interp, errMsg);
	    Tcl_DecrRefCount(errMsg);
	    return NULL;
	}
	return Tcl_GetObjResult(interp);
    }

    result = Tcl_NewObj();
    while (1) {
	switch (code) {
	    case TCL_ERROR:
		Tcl_FreeParse(&parse);
		Tcl_DecrRefCount(result);
		if (errMsg != NULL) {
		    Tcl_DecrRefCount(errMsg);
		}
		return NULL;
	    case TCL_BREAK:
		tokensLeft = 0;		/* Halt substitution */
	    default:
		Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
	}

	if (tokensLeft == 0) {
	    Tcl_FreeParse(&parse);
	    if (errMsg != NULL) {
		if (code != TCL_BREAK) {
		    Tcl_DecrRefCount(result);
		    Tcl_SetObjResult(interp, errMsg);
		    Tcl_DecrRefCount(errMsg);
		    return NULL;
		}
		Tcl_DecrRefCount(errMsg);
	    }
	    return result;
	}

	code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
		&tokensLeft);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclSubstTokens --
 *
 *	Accepts an array of count Tcl_Token's, and creates a result
 *	value in the interp from concatenating the results of 
 *	performing Tcl substitution on each Tcl_Token.  Substitution
 *	is interrupted if any non-TCL_OK completion code arises.
 *
 * Results:
 * 	The return value is a standard Tcl completion code.  The
 * 	result in interp is the substituted value, or an error message
 * 	if TCL_ERROR is returned.  If tokensLeftPtr is not NULL, then
 * 	it points to an int where the number of tokens remaining to
 * 	be processed is written.
 *
 * Side effects:
 * 	Can be anything, depending on the types of substitution done.
 *
 *----------------------------------------------------------------------
 */

int
TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr)
    Tcl_Interp *interp;         /* Interpreter in which to lookup
                                 * variables, execute nested commands,
                                 * and report errors. */
    Tcl_Token *tokenPtr;        /* Pointer to first in an array of tokens
                                 * to evaluate and concatenate. */
    int count;                  /* Number of tokens to consider at tokenPtr.
                                 * Must be at least 1. */
    int *tokensLeftPtr;		/* If not NULL, points to memory where an
				 * integer representing the number of tokens
				 * left to be substituted will be written */
{
    Tcl_Obj *result;
    int code = TCL_OK;

    /*
     * Each pass through this loop will substitute one token, and its
     * components, if any.  The only thing tricky here is that we go to
     * some effort to pass Tcl_Obj's through untouched, to avoid string
     * copying and Tcl_Obj creation if possible, to aid performance and
     * limit shimmering.
     *
     * Further optimization opportunities might be to check for the
     * equivalent of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp))
     * and omit them.
     */

    result = NULL;
    for ( ; (count > 0) && (code == TCL_OK); count--, tokenPtr++) {
	Tcl_Obj *appendObj = NULL;
	CONST char *append = NULL;
	int appendByteLength = 0;
	char utfCharBytes[TCL_UTF_MAX];

	switch (tokenPtr->type) {
	    case TCL_TOKEN_TEXT:
		append = tokenPtr->start;
		appendByteLength = tokenPtr->size;
		break;

	    case TCL_TOKEN_BS: {
		appendByteLength = Tcl_UtfBackslash(tokenPtr->start,
			(int *) NULL, utfCharBytes);
		append = utfCharBytes;
		break;
	    }





	    case TCL_TOKEN_COMMAND:
		code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
			0);


		appendObj = Tcl_GetObjResult(interp);
		break;


	    case TCL_TOKEN_VARIABLE: {
		Tcl_Obj *arrayIndex = NULL;
		Tcl_Obj *varName = NULL;

		if (tokenPtr->numComponents > 1) {

		    /* Subst the index part of an array variable reference */


		    code = TclSubstTokens(interp, tokenPtr+2,
			    tokenPtr->numComponents - 1, NULL);
		    arrayIndex = Tcl_GetObjResult(interp);
		    Tcl_IncrRefCount(arrayIndex);
		}

		if (code == TCL_OK) {
		    varName = Tcl_NewStringObj(tokenPtr[1].start,
			    tokenPtr[1].size);
		    appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex,
			    TCL_LEAVE_ERR_MSG);
		    Tcl_DecrRefCount(varName);
		    if (appendObj == NULL) {
			code = TCL_ERROR;
		    }
		}

		switch (code) {
		    case TCL_OK:	/* Got value */
		    case TCL_ERROR:	/* Already have error message */
		    case TCL_BREAK:	/* Will not substitute anyway */
		    case TCL_CONTINUE:	/* Will not substitute anyway */
			break;
		    default:

			/* All other return codes, we will subst the
			 * result from the code-throwing evaluation */


			appendObj = Tcl_GetObjResult(interp);
		}

		if (arrayIndex != NULL) {
		    Tcl_DecrRefCount(arrayIndex);
		}
		count -= tokenPtr->numComponents;
		tokenPtr += tokenPtr->numComponents;
		break;
	    }

	    default:
		Tcl_Panic("unexpected token type in TclSubstTokens: %d",
			tokenPtr->type);
	}

	if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) {

	    /* Inhibit substitution */

	    continue;
	}

	if (result == NULL) {
	    /* 
	     * First pass through.  If we have a Tcl_Obj, just use it.
	     * If not, create one from our string. 
	     */

	    if (appendObj != NULL) {
		result = appendObj;
	    } else {
		result = Tcl_NewStringObj(append, appendByteLength);;
	    }
	    Tcl_IncrRefCount(result);
	} else {

	    /* Subsequent passes.  Append to result. */


	    if (Tcl_IsShared(result)) {
		Tcl_DecrRefCount(result);
		result = Tcl_DuplicateObj(result);
		Tcl_IncrRefCount(result);
	    }
	    if (appendObj != NULL) {
		Tcl_AppendObjToObj(result, appendObj);
	    } else {
		Tcl_AppendToObj(result, append, appendByteLength);
	    }
	}
    }

    if (code != TCL_ERROR) {	/* Keep error message in result! */
	if (result != NULL) {
	    Tcl_SetObjResult(interp, result);
	} else {
	    Tcl_ResetResult(interp);
	}
    }
    if (tokensLeftPtr != NULL) {
	*tokensLeftPtr = count;
    }
    if (result != NULL) {
	Tcl_DecrRefCount(result);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * CommandComplete --
 *
 *	This procedure is shared by TclCommandComplete and
 *	Tcl_ObjCommandComplete; it does all the real work of seeing
 *	whether a script is complete
 *
 * Results:
 *	1 is returned if the script is complete, 0 if there are open
 *	delimiters such as " or (. 1 is also returned if there is a
 *	parse error in the script other than unmatched delimiters.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(script, numBytes)
    CONST char *script;			/* Script to check. */
    int numBytes;			/* Number of bytes in script. */
{
    Tcl_Parse parse;
    CONST char *p, *end;
    int result;

    p = script;
    end = p + numBytes;







|
|









|















>
|


>



>



>
|
>
>


>
|









|
|
|


















>
|






|
|
<

>







|







|





|
|





|
|






|
|






|





|
|
|





|
|






|
|














|





|
|
|


|
|
|
<
|
|
|
|


|
|
|
<
|





|
|
|
<
|
|
|


|
|


|
|








|



|



|



|
|
<


|









>
|









|
|
|
|
|
<
|
|
|
|
|
|
|



>
|





|
>



















>


|


>


|



|
>



|
>

>
|









>








|
|
|






|
<


















|
|
|


|






|



|





|
|


|
|
|
<
|
|








|

|




<





|




|
















|
|


|
|
|
|








|






|
|
|



|
|
|
|
|
|


|
|
|
<
|





|
|
|
<
|
|

|
|

|
|

|
|


|
|
|






|



|



|


|

















<
|
<
<
<
<
<
<
<
<
<
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
>
>
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|
|
|



|
|
|
|
|
|


|
|
|
<
|





|
|
|
<
|
|

|
|

|
|

|
|


|
|
|

|



|



|

|
|








|








|



|





|
|
<


|
|


|






|
|
|











|
|
|



<

|
|






|
|
|
|
|
|













>
|
>
>

|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|

|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|

|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|



>
|
>
>













>



|
|
|
|
|
|
|
|
|
|
|




















|





|
|
|
|


|
|
|
|
<









|
|
|
|
|
|
|









|
|
|
<

|
|
<



|






|
|
|
|

|
|
|
|
|
|
>
>

>
>
|


>
>
|
|
|
>
|
|
|
>
|
>
|
>
>
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
>
|
|
>
>
|
|

|
|
|
|
|
|
|

|
|
|



>
|
>




|
|
|





|



>
|
>
>













|




















|
|
|



|
|









|
|







982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075

1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173

1174
1175
1176
1177
1178
1179
1180
1181
1182

1183
1184
1185
1186
1187
1188
1189
1190
1191

1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224

1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252

1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341

1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388

1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405

1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472

1473
1474
1475
1476
1477
1478
1479
1480
1481

1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532

1533









1534
1535

































1536
1537
1538
1539
1540
1541

1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679

1680
1681
1682
1683
1684
1685
1686
1687
1688

1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746

1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779

1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878

1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999

2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027

2028
2029
2030

2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203

		if (nested.tokenPtr != nested.staticTokens) {
		    ckfree((char *) nested.tokenPtr);
		}

		/*
		 * Check for the closing ']' that ends the command
		 * substitution. It must have been the last character of the
		 * parsed command.
		 */

		if ((nested.term < parsePtr->end) && (*nested.term == ']')
			&& !nested.incomplete) {
		    break;
		}
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			Tcl_SetResult(parsePtr->interp,
				"missing close-bracket", TCL_STATIC);
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    return TCL_ERROR;
		}
	    }
	    tokenPtr->type = TCL_TOKEN_COMMAND;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '\\') {
	    if (noSubstBS) {
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->size = 1;
		parsePtr->numTokens++;
		src++;
		numBytes--;
		continue;
	    }

	    /*
	     * Backslash substitution.
	     */

	    TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);

	    if (tokenPtr->size == 1) {
		/*
		 * Just a backslash, due to end of string.
		 */

		tokenPtr->type = TCL_TOKEN_TEXT;
		parsePtr->numTokens++;
		src++;
		numBytes--;
		continue;
	    }

	    if (src[1] == '\n') {
		if (numBytes == 2) {
		    parsePtr->incomplete = 1;
		}

		/*
		 * Note: backslash-newline is special in that it is treated
		 * the same as a space character would be. This means that it
		 * could terminate the token.
		 */

		if (mask & TYPE_SPACE) {
		    if (parsePtr->numTokens == originalTokens) {
			goto finishToken;
		    }
		    break;
		}
	    }

	    tokenPtr->type = TCL_TOKEN_BS;
	    parsePtr->numTokens++;
	    src += tokenPtr->size;
	    numBytes -= tokenPtr->size;
	} else if (*src == 0) {
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = 1;
	    parsePtr->numTokens++;
	    src++;
	    numBytes--;
	} else {
	    Tcl_Panic("ParseTokens encountered unknown character");
	}
    }
    if (parsePtr->numTokens == originalTokens) {
	/*
	 * There was nothing in this range of text.  Add an empty token for
	 * the empty range, so that there is always at least one token added.

	 */

	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

    finishToken:
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->size = 0;
	parsePtr->numTokens++;
    }
    parsePtr->term = src;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeParse --
 *
 *	This function is invoked to free any dynamic storage that may have
 *	been allocated by a previous call to Tcl_ParseCommand.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is any dynamically allocated memory in *parsePtr, it is
 *	freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FreeParse(parsePtr)
    Tcl_Parse *parsePtr;	/* Structure that was filled in by a previous
				 * call to Tcl_ParseCommand. */
{
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
	parsePtr->tokenPtr = parsePtr->staticTokens;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandTokenArray --
 *
 *	This function is invoked when the current space for tokens in a
 *	Tcl_Parse structure fills up; it allocates memory to grow the token
 *	array
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is allocated for a new larger token array; the memory for the
 *	old array is freed, if it had been dynamically allocated.
 *
 *----------------------------------------------------------------------
 */

void
TclExpandTokenArray(parsePtr)
    Tcl_Parse *parsePtr;	/* Parse structure whose token space has
				 * overflowed. */
{
    int newCount;
    Tcl_Token *newPtr;

    newCount = parsePtr->tokensAvailable*2;
    newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
    memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
	    (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    parsePtr->tokenPtr = newPtr;
    parsePtr->tokensAvailable = newCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVarName --
 *
 *	Given a string starting with a $ sign, parse off a variable name and
 *	return information about the parse.  No more than numBytes bytes will
 *	be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
 *	error message is left in its result. On a successful return, tokenPtr

 *	and numTokens fields of parsePtr are filled in with information about
 *	the variable name that was parsed. The "size" field of the first new
 *	token gives the total number of bytes in the variable name. Other
 *	fields in parsePtr are undefined.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the command, then additional space is malloc-ed. If the function
 *	returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to

 *	release any additional space that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseVarName(interp, start, numBytes, parsePtr, append)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */

    CONST char *start;		/* Start of variable substitution string.
				 * First character must be "$". */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill in with information about
				 * the variable name. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
{
    Tcl_Token *tokenPtr;
    register CONST char *src;
    unsigned char c;
    int varIndex, offset;
    Tcl_UniChar ch;
    unsigned array;

    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(start);
    }

    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }

    /*
     * Generate one token for the variable, an additional token for the name,
     * plus any number of additional tokens for the index, if there is one.

     */

    src = start;
    if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
    tokenPtr->type = TCL_TOKEN_VARIABLE;
    tokenPtr->start = src;
    varIndex = parsePtr->numTokens;
    parsePtr->numTokens++;
    tokenPtr++;
    src++;
    numBytes--;
    if (numBytes == 0) {
	goto justADollarSign;
    }
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src;
    tokenPtr->numComponents = 0;

    /*
     * The name of the variable can have three forms:
     * 1. The $ sign is followed by an open curly brace. Then the variable
     *	  name is everything up to the next close curly brace, and the
     *	  variable is a scalar variable.
     * 2. The $ sign is not followed by an open curly brace.  Then the
     *	  variable name is everything up to the next character that isn't a

     *	  letter, digit, or underscore.  :: sequences are also considered part
     *	  of the variable name, in order to support namespaces. If the
     *	  following character is an open parenthesis, then the information
     *	  between parentheses is the array element name.
     * 3. The $ sign is followed by something that isn't a letter, digit, or
     *	  underscore: in this case, there is no variable name and the token is
     *	  just "$".
     */

    if (*src == '{') {
	src++;
	numBytes--;
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	while (numBytes && (*src != '}')) {
	    numBytes--;
	    src++;
	}
	if (numBytes == 0) {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "missing close-brace for variable name",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = 1;
	    goto error;
	}
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr[-1].size = src - tokenPtr[-1].start;
	parsePtr->numTokens++;
	src++;
    } else {
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	while (numBytes) {
	    if (Tcl_UtfCharComplete(src, numBytes)) {
		offset = Tcl_UtfToUniChar(src, &ch);
	    } else {
		char utfBytes[TCL_UTF_MAX];

		memcpy(utfBytes, src, (size_t) numBytes);
		utfBytes[numBytes] = '\0';
		offset = Tcl_UtfToUniChar(utfBytes, &ch);
	    }
	    c = UCHAR(ch);
	    if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
		src += offset;
		numBytes -= offset;
		continue;
	    }
	    if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
		src += 2;
		numBytes -= 2;
		while (numBytes && (*src == ':')) {
		    src++;
		    numBytes--;
		}
		continue;
	    }
	    break;
	}

	/*
	 * Support for empty array names here.
	 */

	array = (numBytes && (*src == '('));
	tokenPtr->size = src - tokenPtr->start;
	if ((tokenPtr->size == 0) && !array) {
	    goto justADollarSign;
	}
	parsePtr->numTokens++;
	if (array) {
	    /*
	     * This is a reference to an array element. Call ParseTokens
	     * recursively to parse the element name, since it could contain
	     * any number of substitutions.
	     */

	    if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
		    TCL_SUBST_ALL, parsePtr)) {
		goto error;
	    }
	    if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')) {

		if (parsePtr->interp != NULL) {
		    Tcl_SetResult(parsePtr->interp, "missing )",
			    TCL_STATIC);
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = 1;
		goto error;
	    }
	    src = parsePtr->term + 1;
	}
    }
    tokenPtr = &parsePtr->tokenPtr[varIndex];
    tokenPtr->size = src - tokenPtr->start;
    tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
    return TCL_OK;

    /*
     * The dollar sign isn't followed by a variable name.  Replace the
     * TCL_TOKEN_VARIABLE token with a TCL_TOKEN_TEXT token for the dollar
     * sign.
     */

  justADollarSign:
    tokenPtr = &parsePtr->tokenPtr[varIndex];
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->size = 1;
    tokenPtr->numComponents = 0;
    return TCL_OK;

  error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVar --
 *
 *	Given a string starting with a $ sign, parse off a variable name and
 *	return its value.
 *
 * Results:
 *	The return value is the contents of the variable given by the leading
 *	characters of string.  If termPtr isn't NULL, *termPtr gets filled in
 *	with the address of the character just after the last one in the

 *	variable specifier.  If the variable doesn't exist, then the return
 *	value is NULL and an error message will be left in interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ParseVar(interp, start, termPtr)
    Tcl_Interp *interp;			/* Context for looking up variable. */
    register CONST char *start;		/* Start of variable substitution.
					 * First character must be "$". */
    CONST char **termPtr;		/* If non-NULL, points to word to fill
					 * in with character just after last
					 * one in the variable specifier. */

{
    Tcl_Parse parse;
    register Tcl_Obj *objPtr;
    int code;

    if (Tcl_ParseVarName(interp, start, -1, &parse, 0) != TCL_OK) {
	return NULL;
    }

    if (termPtr != NULL) {
	*termPtr = start + parse.tokenPtr->size;
    }
    if (parse.numTokens == 1) {
	/*
	 * There isn't a variable name after all: the $ is just a $.
	 */

	return "$";
    }

    code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL);
    if (code != TCL_OK) {
	return NULL;
    }
    objPtr = Tcl_GetObjResult(interp);

    /*
     * At this point we should have an object containing the value of a
     * variable. Just return the string from that object.
     *
     * This should have returned the object for the user to manage, but
     * instead we have some weak reference to the string value in the object,
     * which is why we make sure the object exists after resetting the result.
     * This isn't ideal, but it's the best we can do with the current
     * documented interface. -- hobbs
     */

    if (!Tcl_IsShared(objPtr)) {
	Tcl_IncrRefCount(objPtr);
    }
    Tcl_ResetResult(interp);
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseBraces --
 *
 *	Given a string in braces such as a Tcl command argument or a string
 *	value in a Tcl expression, this function parses the string and returns
 *	information about the parse. No more than numBytes bytes will be
 *	scanned.
 *
 * Results:
 *	The return value is TCL_OK if the string was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
 *	error message is left in its result. On a successful return, tokenPtr
 *	and numTokens fields of parsePtr are filled in with information about
 *	the string that was parsed. Other fields in parsePtr are undefined.
 *	termPtr is set to point to the character just after the last one in
 *	the braced string.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the command, then additional space is malloc-ed. If the function
 *	returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to

 *	release any additional space that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */

    CONST char *start;		/* Start of string enclosed in braces.  The
				 * first character must be {'. */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to the
				 * first null character. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information about
				 * the string. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
    CONST char **termPtr;	/* If non-NULL, points to word in which to
				 * store a pointer to the character just after
				 * the terminating '}' if the parse was
				 * successful. */

{
    Tcl_Token *tokenPtr;
    register CONST char *src;
    int startIndex, level, length;

    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(start);
    }

    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }

    src = start;
    startIndex = parsePtr->numTokens;

    if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    tokenPtr = &parsePtr->tokenPtr[startIndex];
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src+1;
    tokenPtr->numComponents = 0;
    level = 1;
    while (1) {
	while (++src, --numBytes) {
	    if (CHAR_TYPE(*src) != TYPE_NORMAL) {
		break;
	    }
	}
	if (numBytes == 0) {

	    goto missingBraceError;









	}


































	switch (*src) {
	case '{':
	    level++;
	    break;
	case '}':
	    if (--level == 0) {

		/*
		 * Decide if we need to finish emitting a partially-finished
		 * token. There are 3 cases:
		 *     {abc \newline xyz} or {xyz}
		 *		- finish emitting "xyz" token
		 *     {abc \newline}
		 *		- don't emit token after \newline
		 *     {}	- finish emitting zero-sized token
		 *
		 * The last case ensures that there is a token (even if empty)
		 * that describes the braced string.
		 */

		if ((src != tokenPtr->start)
			|| (parsePtr->numTokens == startIndex)) {
		    tokenPtr->size = (src - tokenPtr->start);
		    parsePtr->numTokens++;
		}
		if (termPtr != NULL) {
		    *termPtr = src+1;
		}
		return TCL_OK;
	    }
	    break;
	case '\\':
	    TclParseBackslash(src, numBytes, &length, NULL);
	    if ((length > 1) && (src[1] == '\n')) {
		/*
		 * A backslash-newline sequence must be collapsed, even inside
		 * braces, so we have to split the word into multiple tokens
		 * so that the backslash-newline can be represented
		 * explicitly.
		 */

		if (numBytes == 2) {
		    parsePtr->incomplete = 1;
		}
		tokenPtr->size = (src - tokenPtr->start);
		if (tokenPtr->size != 0) {
		    parsePtr->numTokens++;
		}
		if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
		    TclExpandTokenArray(parsePtr);
		}
		tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
		tokenPtr->type = TCL_TOKEN_BS;
		tokenPtr->start = src;
		tokenPtr->size = length;
		tokenPtr->numComponents = 0;
		parsePtr->numTokens++;

		src += length - 1;
		numBytes -= length - 1;
		tokenPtr++;
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->start = src + 1;
		tokenPtr->numComponents = 0;
	    } else {
		src += length - 1;
		numBytes -= length - 1;
	    }
	    break;
	}
    }

  missingBraceError:
    parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
    parsePtr->term = start;
    parsePtr->incomplete = 1;
    if (interp == NULL) {
	/*
	 * Skip straight to the exit code since we have no interpreter to put
	 * error message in.
	 */

	goto error;
    }

    Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);

    /*
     * Guess if the problem is due to comments by searching the source string
     * for a possible open brace within the context of a comment. Since we
     * aren't performing a full Tcl parse, just look for an open brace
     * preceded by a '<whitespace>#' on the same line.
     */

    {
	register int openBrace = 0;

	for (; src > start; src--) {
	    switch (*src) {
	    case '{':
		openBrace = 1;
		break;
	    case '\n':
		openBrace = 0;
		break;
	    case '#' :
		if (openBrace && (isspace(UCHAR(src[-1])))) {
		    Tcl_AppendResult(interp,
			    ": possible unbalanced brace in comment",
			    (char *) NULL);
		    goto error;
		}
		break;
	    }
	}
    }

  error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseQuotedString --
 *
 *	Given a double-quoted string such as a quoted Tcl command argument or
 *	a quoted value in a Tcl expression, this function parses the string
 *	and returns information about the parse. No more than numBytes bytes
 *	will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the string was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
 *	error message is left in its result. On a successful return, tokenPtr
 *	and numTokens fields of parsePtr are filled in with information about
 *	the string that was parsed. Other fields in parsePtr are undefined.
 *	termPtr is set to point to the character just after the quoted
 *	string's terminating close-quote.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the command, then additional space is malloc-ed. If the function
 *	returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to

 *	release any additional space that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */

    CONST char *start;		/* Start of the quoted string.  The first
				 * character must be '"'. */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to the
				 * first null character. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information about
				 * the string. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
    CONST char **termPtr;	/* If non-NULL, points to word in which to
				 * store a pointer to the character just after
				 * the quoted string's terminating close-quote
				 * if the parse succeeds. */
{
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(start);
    }

    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }

    if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE,
	    TCL_SUBST_ALL, parsePtr)) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (interp != NULL) {
	    Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = start;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {
	*termPtr = (parsePtr->term + 1);
    }
    return TCL_OK;

  error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SubstObj --
 *
 *	This function performs the substitutions specified on the given string
 *	as described in the user documentation for the "subst" Tcl command.

 *
 * Results:
 *	A Tcl_Obj* containing the substituted string, or NULL to indicate that
 *	an error occurred.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_SubstObj(interp, objPtr, flags)
    Tcl_Interp *interp;		/* Interpreter in which substitution occurs */
    Tcl_Obj *objPtr;		/* The value to be substituted. */
    int flags;			/* What substitutions to do. */
{
    int length, tokensLeft, code;
    Tcl_Parse parse;
    Tcl_Token *endTokenPtr;
    Tcl_Obj *result;
    Tcl_Obj *errMsg = NULL;
    CONST char *p = Tcl_GetStringFromObj(objPtr, &length);

    TclParseInit(interp, p, length, &parse);

    /*
     * First parse the string rep of objPtr, as if it were enclosed as a
     * "-quoted word in a normal Tcl command. Honor flags that selectively
     * inhibit types of substitution.
     */

    if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) {

	/*
	 * There was a parse error. Save the error message for possible
	 * reporting later.
	 */

	errMsg = Tcl_GetObjResult(interp);
	Tcl_IncrRefCount(errMsg);

	/*
	 * We need to re-parse to get the portion of the string we can [subst]
	 * before the parse error. Sadly, all the Tcl_Token's created by the
	 * first parse attempt are gone, freed according to the public spec
	 * for the Tcl_Parse* routines. The only clue we have is parse.term,
	 * which points to either the unmatched opener, or to characters that
	 * follow a close brace or close quote.
	 *
	 * Call ParseTokens again, working on the string up to parse.term.
	 * Keep repeating until we get a good parse on a prefix.
	 */

	do {
	    parse.numTokens = 0;
	    parse.tokensAvailable = NUM_STATIC_TOKENS;
	    parse.end = parse.term;
	    parse.incomplete = 0;
	    parse.errorType = TCL_PARSE_SUCCESS;
	} while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse));

	/*
	 * The good parse will have to be followed by {, (, or [.
	 */

	switch (*parse.term) {
	case '{':
	    /*
	     * Parse error was a missing } in a ${varname} variable
	     * substitution at the toplevel. We will subst everything up to
	     * that broken variable substitution before reporting the parse
	     * error. Substituting the leftover '$' will have no side-effects,
	     * so the current token stream is fine.
	     */
	    break;

	case '(':
	    /*
	     * Parse error was during the parsing of the index part of an
	     * array variable substitution at the toplevel.
	     */

	    if (*(parse.term - 1) == '$') {
		/*
		 * Special case where removing the array index left us with
		 * just a dollar sign (array variable with name the empty
		 * string as its name), instead of with a scalar variable
		 * reference.
		 *
		 * As in the previous case, existing token stream is OK.
		 */
	    } else {
		/*
		 * The current parse includes a successful parse of a scalar
		 * variable substitution where there should have been an array
		 * variable substitution. We remove that mistaken part of the
		 * parse before moving on. A scalar variable substitution is
		 * two tokens.
		 */

		Tcl_Token *varTokenPtr =
			parse.tokenPtr + parse.numTokens - 2;

		if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
		    Tcl_Panic("Tcl_SubstObj: programming error");
		}
		if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
		    Tcl_Panic("Tcl_SubstObj: programming error");
		}
		parse.numTokens -= 2;
	    }
	    break;
	case '[':
	    /*
	     * Parse error occurred during parsing of a toplevel command
	     * substitution.
	     */

	    parse.end = p + length;
	    p = parse.term + 1;
	    length = parse.end - p;
	    if (length == 0) {
		/*
		 * No commands, just an unmatched [.  As in previous cases,
		 * existing token stream is OK.
		 */
	    } else {
		/*
		 * We want to add the parsing of as many commands as we can
		 * within that substitution until we reach the actual parse
		 * error.  We'll do additional parsing to determine what
		 * length to claim for the final TCL_TOKEN_COMMAND token.

		 */

		Tcl_Token *tokenPtr;
		Tcl_Parse nested;
		CONST char *lastTerm = parse.term;

		while (TCL_OK ==
			Tcl_ParseCommand(NULL, p, length, 0, &nested)) {
		    Tcl_FreeParse(&nested);
		    p = nested.term + (nested.term < nested.end);
		    length = nested.end - p;
		    if ((length == 0) && (nested.term == nested.end)) {
			/*
			 * If we run out of string, blame the missing close
			 * bracket on the last command, and do not evaluate it
			 * during substitution.
			 */

			break;
		    }
		    lastTerm = nested.term;
		}

		if (lastTerm == parse.term) {
		    /*
		     * Parse error in first command.  No commands to subst,
		     * add no more tokens.
		     */
		    break;
		}

		/*
		 * Create a command substitution token for whatever commands
		 * got parsed.
		 */

		if (parse.numTokens == parse.tokensAvailable) {
		    TclExpandTokenArray(&parse);
		}
		tokenPtr = &parse.tokenPtr[parse.numTokens];
		tokenPtr->start = parse.term;
		tokenPtr->numComponents = 0;
		tokenPtr->type = TCL_TOKEN_COMMAND;
		tokenPtr->size = lastTerm - tokenPtr->start + 1;
		parse.numTokens++;
	    }
	    break;

	default:
	    Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]);
	}
    }

    /*
     * Next, substitute the parsed tokens just as in normal Tcl evaluation.
     */

    endTokenPtr = parse.tokenPtr + parse.numTokens;
    tokensLeft = parse.numTokens;
    code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
	    &tokensLeft);
    if (code == TCL_OK) {
	Tcl_FreeParse(&parse);
	if (errMsg != NULL) {
	    Tcl_SetObjResult(interp, errMsg);
	    Tcl_DecrRefCount(errMsg);
	    return NULL;
	}
	return Tcl_GetObjResult(interp);
    }

    result = Tcl_NewObj();
    while (1) {
	switch (code) {
	case TCL_ERROR:
	    Tcl_FreeParse(&parse);
	    Tcl_DecrRefCount(result);
	    if (errMsg != NULL) {
		Tcl_DecrRefCount(errMsg);
	    }
	    return NULL;
	case TCL_BREAK:
	    tokensLeft = 0;		/* Halt substitution */
	default:
	    Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
	}

	if (tokensLeft == 0) {
	    Tcl_FreeParse(&parse);
	    if (errMsg != NULL) {
		if (code != TCL_BREAK) {
		    Tcl_DecrRefCount(result);
		    Tcl_SetObjResult(interp, errMsg);
		    Tcl_DecrRefCount(errMsg);
		    return NULL;
		}
		Tcl_DecrRefCount(errMsg);
	    }
	    return result;
	}

	code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
		&tokensLeft);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclSubstTokens --
 *
 *	Accepts an array of count Tcl_Token's, and creates a result value in
 *	the interp from concatenating the results of performing Tcl
 *	substitution on each Tcl_Token. Substitution is interrupted if any
 *	non-TCL_OK completion code arises.
 *
 * Results:
 * 	The return value is a standard Tcl completion code. The result in
 * 	interp is the substituted value, or an error message if TCL_ERROR is
 * 	returned. If tokensLeftPtr is not NULL, then it points to an int where
 * 	the number of tokens remaining to be processed is written.

 *
 * Side effects:
 * 	Can be anything, depending on the types of substitution done.
 *
 *----------------------------------------------------------------------
 */

int
TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr)
    Tcl_Interp *interp;		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    int *tokensLeftPtr;		/* If not NULL, points to memory where an
				 * integer representing the number of tokens
				 * left to be substituted will be written */
{
    Tcl_Obj *result;
    int code = TCL_OK;

    /*
     * Each pass through this loop will substitute one token, and its
     * components, if any. The only thing tricky here is that we go to some
     * effort to pass Tcl_Obj's through untouched, to avoid string copying and
     * Tcl_Obj creation if possible, to aid performance and limit shimmering.

     *
     * Further optimization opportunities might be to check for the equivalent
     * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.

     */

    result = NULL;
    for (; count>0 && code==TCL_OK ; count--, tokenPtr++) {
	Tcl_Obj *appendObj = NULL;
	CONST char *append = NULL;
	int appendByteLength = 0;
	char utfCharBytes[TCL_UTF_MAX];

	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
	    append = tokenPtr->start;
	    appendByteLength = tokenPtr->size;
	    break;

	case TCL_TOKEN_BS:
	    appendByteLength = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
		    utfCharBytes);
	    append = utfCharBytes;
	    break;

	case TCL_TOKEN_COMMAND: {
	    Interp *iPtr = (Interp *) interp;

	    iPtr->numLevels++;
	    code = TclInterpReady(interp);
	    if (code == TCL_OK) {
		code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
			0);
	    }
	    iPtr->numLevels--;
	    appendObj = Tcl_GetObjResult(interp);
	    break;
	}

	case TCL_TOKEN_VARIABLE: {
	    Tcl_Obj *arrayIndex = NULL;
	    Tcl_Obj *varName = NULL;

	    if (tokenPtr->numComponents > 1) {
		/*
		 * Subst the index part of an array variable reference.
		 */

		code = TclSubstTokens(interp, tokenPtr+2,
			tokenPtr->numComponents - 1, NULL);
		arrayIndex = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(arrayIndex);
	    }

	    if (code == TCL_OK) {
		varName = Tcl_NewStringObj(tokenPtr[1].start,
			tokenPtr[1].size);
		appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex,
			TCL_LEAVE_ERR_MSG);
		Tcl_DecrRefCount(varName);
		if (appendObj == NULL) {
		    code = TCL_ERROR;
		}
	    }

	    switch (code) {
	    case TCL_OK:	/* Got value */
	    case TCL_ERROR:	/* Already have error message */
	    case TCL_BREAK:	/* Will not substitute anyway */
	    case TCL_CONTINUE:	/* Will not substitute anyway */
		break;
	    default:
		/*
		 * All other return codes, we will subst the result from the
		 * code-throwing evaluation.
		 */

		appendObj = Tcl_GetObjResult(interp);
	    }

	    if (arrayIndex != NULL) {
		Tcl_DecrRefCount(arrayIndex);
	    }
	    count -= tokenPtr->numComponents;
	    tokenPtr += tokenPtr->numComponents;
	    break;
	}

	default:
	    Tcl_Panic("unexpected token type in TclSubstTokens: %d",
		    tokenPtr->type);
	}

	if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) {
	    /*
	     * Inhibit substitution.
	     */
	    continue;
	}

	if (result == NULL) {
	    /*
	     * First pass through. If we have a Tcl_Obj, just use it. If not,
	     * create one from our string.
	     */

	    if (appendObj != NULL) {
		result = appendObj;
	    } else {
		result = Tcl_NewStringObj(append, appendByteLength);
	    }
	    Tcl_IncrRefCount(result);
	} else {
	    /*
	     * Subsequent passes. Append to result.
	     */

	    if (Tcl_IsShared(result)) {
		Tcl_DecrRefCount(result);
		result = Tcl_DuplicateObj(result);
		Tcl_IncrRefCount(result);
	    }
	    if (appendObj != NULL) {
		Tcl_AppendObjToObj(result, appendObj);
	    } else {
		Tcl_AppendToObj(result, append, appendByteLength);
	    }
	}
    }

    if (code != TCL_ERROR) {		/* Keep error message in result! */
	if (result != NULL) {
	    Tcl_SetObjResult(interp, result);
	} else {
	    Tcl_ResetResult(interp);
	}
    }
    if (tokensLeftPtr != NULL) {
	*tokensLeftPtr = count;
    }
    if (result != NULL) {
	Tcl_DecrRefCount(result);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * CommandComplete --
 *
 *	This function is shared by TclCommandComplete and
 *	Tcl_ObjCommandComplete; it does all the real work of seeing whether a
 *	script is complete
 *
 * Results:
 *	1 is returned if the script is complete, 0 if there are open
 *	delimiters such as " or (. 1 is also returned if there is a parse
 *	error in the script other than unmatched delimiters.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(script, numBytes)
    CONST char *script;		/* Script to check. */
    int numBytes;		/* Number of bytes in script. */
{
    Tcl_Parse parse;
    CONST char *p, *end;
    int result;

    p = script;
    end = p + numBytes;
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258








	result = 0;
    } else {
	result = 1;
    }
    Tcl_FreeParse(&parse);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandComplete --
 *
 *	Given a partial or complete Tcl script, this procedure
 *	determines whether the script is complete in the sense
 *	of having matched braces and quotes and brackets.
 *
 * Results:
 *	1 is returned if the script is complete, 0 otherwise.
 *	1 is also returned if there is a parse error in the script
 *	other than unmatched delimiters.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CommandComplete(script)
    CONST char *script;			/* Script to check. */
{
    return CommandComplete(script, (int) strlen(script));
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjCommandComplete --
 *
 *	Given a partial or complete Tcl command in a Tcl object, this
 *	procedure determines whether the command is complete in the sense of
 *	having matched braces and quotes and brackets.
 *
 * Results:
 *	1 is returned if the command is complete, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclObjCommandComplete(objPtr)
    Tcl_Obj *objPtr;			/* Points to object holding script
					 * to check. */
{
    CONST char *script;
    int length;

    script = Tcl_GetStringFromObj(objPtr, &length);
    return CommandComplete(script, length);
}

/*
 *----------------------------------------------------------------------
 *
 * TclIsLocalScalar --
 *
 *	Check to see if a given string is a legal scalar variable
 *	name with no namespace qualifiers or substitutions.
 *
 * Results:
 *	Returns 1 if the variable is a local scalar.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclIsLocalScalar(src, len)
    CONST char *src;
    int len;
{
    CONST char *p;
    CONST char *lastChar = src + (len - 1);

    for (p = src; p <= lastChar; p++) {
	if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
		(CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
	    /*
	     * TCL_COMMAND_END is returned for the last character
	     * of the string.  By this point we know it isn't
	     * an array or namespace reference.
	     */

	    return 0;
	}
	if  (*p == '(') {
	    if (*lastChar == ')') { /* we have an array element */
		return 0;
	    }
	} else if (*p == ':') {
	    if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
		return 0;
	    }
	}
    }
	
    return 1;
}















|





|
|
|


|
|
|









|



|





|
|
|












|
|







|





|
|


















|



|
|
|














|


>
>
>
>
>
>
>
>
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
	result = 0;
    } else {
	result = 1;
    }
    Tcl_FreeParse(&parse);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandComplete --
 *
 *	Given a partial or complete Tcl script, this function determines
 *	whether the script is complete in the sense of having matched braces
 *	and quotes and brackets.
 *
 * Results:
 *	1 is returned if the script is complete, 0 otherwise.  1 is also
 *	returned if there is a parse error in the script other than unmatched
 *	delimiters.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CommandComplete(script)
    CONST char *script;		/* Script to check. */
{
    return CommandComplete(script, (int) strlen(script));
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjCommandComplete --
 *
 *	Given a partial or complete Tcl command in a Tcl object, this function
 *	determines whether the command is complete in the sense of having
 *	matched braces and quotes and brackets.
 *
 * Results:
 *	1 is returned if the command is complete, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclObjCommandComplete(objPtr)
    Tcl_Obj *objPtr;		/* Points to object holding script to
				 * check. */
{
    CONST char *script;
    int length;

    script = Tcl_GetStringFromObj(objPtr, &length);
    return CommandComplete(script, length);
}

/*
 *----------------------------------------------------------------------
 *
 * TclIsLocalScalar --
 *
 *	Check to see if a given string is a legal scalar variable name with no
 *	namespace qualifiers or substitutions.
 *
 * Results:
 *	Returns 1 if the variable is a local scalar.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclIsLocalScalar(src, len)
    CONST char *src;
    int len;
{
    CONST char *p;
    CONST char *lastChar = src + (len - 1);

    for (p=src ; p<=lastChar ; p++) {
	if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
		(CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
	    /*
	     * TCL_COMMAND_END is returned for the last character of the
	     * string. By this point we know it isn't an array or namespace
	     * reference.
	     */

	    return 0;
	}
	if  (*p == '(') {
	    if (*lastChar == ')') { /* we have an array element */
		return 0;
	    }
	} else if (*p == ':') {
	    if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
		return 0;
	    }
	}
    }

    return 1;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclParseExpr.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
/* 
 * tclParseExpr.c --
 *
 *	This file contains procedures that parse Tcl expressions. They
 *	do so in a general-purpose fashion that can be used for many
 *	different purposes, including compilation, direct execution,
 *	code analysis, etc.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParseExpr.c,v 1.23 2004/10/08 15:39:55 dkf Exp $
 */

#include "tclInt.h"

/*
 * The stuff below is a bit of a hack so that this file can be used in
 * environments that include no UNIX, i.e. no errno: just arrange to use
 * the errno from tclExecute.c here.
 */

#ifdef TCL_GENERIC_ONLY
#define NO_ERRNO_H
#endif

#ifdef NO_ERRNO_H
extern int errno;			/* Use errno from tclExecute.c. */
#define ERANGE 34
#endif

/*
 * Boolean variable that controls whether expression parse tracing
 * is enabled.
 */

#ifdef TCL_COMPILE_DEBUG
static int traceParseExpr = 0;
#endif /* TCL_COMPILE_DEBUG */

/*
 * The ParseInfo structure holds state while parsing an expression.
 * A pointer to an ParseInfo record is passed among the routines in
 * this module.
 */

typedef struct ParseInfo {
    Tcl_Parse *parsePtr;	/* Points to structure to fill in with
				 * information about the expression. */
    int lexeme;			/* Type of last lexeme scanned in expr.
				 * See below for definitions. Corresponds to
				 * size characters beginning at start. */
    CONST char *start;		/* First character in lexeme. */
    int size;			/* Number of bytes in lexeme. */
    CONST char *next;		/* Position of the next character to be
				 * scanned in the expression string. */
    CONST char *prevEnd;	/* Points to the character just after the
				 * last one in the previous lexeme. Used to
				 * compute size of subexpression tokens. */
    CONST char *originalExpr;	/* Points to the start of the expression
				 * originally passed to Tcl_ParseExpr. */
    CONST char *lastChar;	/* Points just after last byte of expr. */
} ParseInfo;

/*
 * Definitions of the different lexemes that appear in expressions. The
 * order of these must match the corresponding entries in the
 * operatorStrings array below.
 *
 * Basic lexemes:
 */

#define LITERAL		0
#define FUNC_NAME	1
#define OPEN_BRACKET	2
|


|
|
|
<





|
|

|





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<







|
|
<





|
|
|




|
|
|






|
|
|







1
2
3
4
5
6

7
8
9
10
11
12
13
14
15
16
17
18
19
20















21

22
23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
/*
 * tclParseExpr.c --
 *
 *	This file contains functions that parse Tcl expressions. They do so in
 *	a general-purpose fashion that can be used for many different
 *	purposes, including compilation, direct execution, code analysis, etc.

 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParseExpr.c,v 1.23.2.12 2005/08/23 18:28:51 kennykb Exp $
 */

#include "tclInt.h"

/*















 * Boolean variable that controls whether expression parse tracing is enabled.

 */

#ifdef TCL_COMPILE_DEBUG
static int traceParseExpr = 0;
#endif /* TCL_COMPILE_DEBUG */

/*
 * The ParseInfo structure holds state while parsing an expression. A pointer
 * to an ParseInfo record is passed among the routines in this module.

 */

typedef struct ParseInfo {
    Tcl_Parse *parsePtr;	/* Points to structure to fill in with
				 * information about the expression. */
    int lexeme;			/* Type of last lexeme scanned in expr.  See
				 * below for definitions. Corresponds to size
				 * characters beginning at start. */
    CONST char *start;		/* First character in lexeme. */
    int size;			/* Number of bytes in lexeme. */
    CONST char *next;		/* Position of the next character to be
				 * scanned in the expression string. */
    CONST char *prevEnd;	/* Points to the character just after the last
				 * one in the previous lexeme. Used to compute
				 * size of subexpression tokens. */
    CONST char *originalExpr;	/* Points to the start of the expression
				 * originally passed to Tcl_ParseExpr. */
    CONST char *lastChar;	/* Points just after last byte of expr. */
} ParseInfo;

/*
 * Definitions of the different lexemes that appear in expressions. The order
 * of these must match the corresponding entries in the operatorStrings array
 * below.
 *
 * Basic lexemes:
 */

#define LITERAL		0
#define FUNC_NAME	1
#define OPEN_BRACKET	2
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208



209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
 * List containment operators
 */

#define IN_LIST		37
#define NOT_IN_LIST	38

/*
 * Mapping from lexemes to strings; used for debugging messages. These
 * entries must match the order and number of the lexeme definitions above.
 */

static char *lexemeStrings[] = {
    "LITERAL", "FUNCNAME",
    "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR",
    "*", "/", "%", "+", "-",
    "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
    "&", "^", "|", "&&", "||", "?", ":",
    "!", "~", "eq", "ne", "**", "in", "ni"
};

/*
 * Declarations for local procedures to this file:
 */

static int		GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
static void		LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr,
				CONST char *extraInfo));
static int		ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string,
				CONST char *end));
static int		ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseExponentialExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static void		PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
				int opBytes, CONST char *src, int srcBytes,
				int firstIndex, ParseInfo *infoPtr));

/*
 * Macro used to debug the execution of the recursive descent parser used
 * to parse expressions.
 */

#ifdef TCL_COMPILE_DEBUG
#define HERE(production, level) \
    if (traceParseExpr) { \
	fprintf(stderr, "%*s%s: lexeme=%s, next=\"%.20s\"\n", \
		(level), " ", (production), \
		lexemeStrings[infoPtr->lexeme], infoPtr->next); \
    }
#else
#define HERE(production, level)
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseExpr --
 *
 *	Given a string, this procedure parses the first Tcl expression
 *	in the string and returns information about the structure of
 *	the expression. This procedure is the top-level interface to the
 *	the expression parsing module.  No more that numBytes bytes will



 *	be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed successfully
 *	and TCL_ERROR otherwise. If an error occurs and interp isn't NULL
 *	then an error message is left in its result. On a successful return,
 *	parsePtr is filled in with information about the expression that 
 *	was parsed.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the expression, then additional space is
 *	malloc-ed. If the procedure returns TCL_OK then the caller must
 *	eventually invoke Tcl_FreeParse to release any additional space
 *	that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *string;		/* The source string to parse. */
    int numBytes;		/* Number of bytes in string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill with information about
				 * the parsed expression; any previous
				 * information in the structure is
				 * ignored. */
{
    ParseInfo info;
    int code;

    if (numBytes < 0) {
	numBytes = (string? strlen(string) : 0);
    }
#ifdef TCL_COMPILE_DEBUG
    if (traceParseExpr) {
	fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",
	        numBytes, string);
    }
#endif /* TCL_COMPILE_DEBUG */
    
    TclParseInit(interp, string, numBytes, parsePtr);

    /*
     * Initialize the ParseInfo structure that holds state while parsing
     * the expression.
     */

    info.parsePtr = parsePtr;
    info.lexeme = UNKNOWN;
    info.start = NULL;
    info.size = 0;
    info.next = string;
    info.prevEnd = string;
    info.originalExpr = string;
    info.lastChar = (string + numBytes); /* just after last char of expr */

    /*
     * Get the first lexeme then parse the expression.
     */

    code = GetLexeme(&info);
    if (code != TCL_OK) {
	goto error;
    }
    code = ParseCondExpr(&info);
    if (code != TCL_OK) {
	goto error;
    }
    if (info.lexeme != END) {
	LogSyntaxError(&info, "extra tokens at end of expression");
	goto error;
    }
    return TCL_OK;
    
    error:
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseCondExpr --
 *
 *	This procedure parses a Tcl conditional expression:
 *	condExpr ::= lorExpr ['?' condExpr ':' condExpr]
 *
 *	Note that this is the topmost recursive-descent parsing routine used
 *	by Tcl_ParseExpr to parse expressions. This avoids an extra procedure
 *	call since such a procedure would only return the result of calling
 *	ParseCondExpr. Other recursive-descent procedures that need to parse
 *	complete expressions also call ParseCondExpr.
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseCondExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
    int firstIndex, numToMove, code;
    CONST char *srcStart;
    
    HERE("condExpr", 1);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseLorExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }
    
    if (infoPtr->lexeme == QUESTY) {
	/*
	 * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire
	 * conditional expression, and a TCL_TOKEN_OPERATOR token for 
	 * the "?" operator. Note that these two tokens must be inserted
	 * before the LOR operand tokens generated above.
	 */

	if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
	tokenPtr = (firstTokenPtr + 2);
	numToMove = (parsePtr->numTokens - firstIndex);
	memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
	        (size_t) (numToMove * sizeof(Tcl_Token)));
	parsePtr->numTokens += 2;
	
	tokenPtr = firstTokenPtr;
	tokenPtr->type = TCL_TOKEN_SUB_EXPR;
	tokenPtr->start = srcStart;
	
	tokenPtr++;
	tokenPtr->type = TCL_TOKEN_OPERATOR;
	tokenPtr->start = infoPtr->start;
	tokenPtr->size = 1;
	tokenPtr->numComponents = 0;
    
	/*
	 * Skip over the '?'.
	 */
	
	code = GetLexeme(infoPtr); 
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Parse the "then" expression.
	 */







|
|












|




|








<
<







|
|


|
|


















|
|
|
|
>
>
>
|


|
|
|
|
<


|
|
|
|
<





|

|





|
<





|




|


|
|


|
|






|
|
|
|


















|
|











|



|
|
|



|
|



|
|
<






|
|





|



|




|



|
|
|









|

|



|





|



|
|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153


154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198

199
200
201
202
203
204

205
206
207
208
209
210
211
212
213
214
215
216
217
218

219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295

296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
 * List containment operators
 */

#define IN_LIST		37
#define NOT_IN_LIST	38

/*
 * Mapping from lexemes to strings; used for debugging messages. These entries
 * must match the order and number of the lexeme definitions above.
 */

static char *lexemeStrings[] = {
    "LITERAL", "FUNCNAME",
    "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR",
    "*", "/", "%", "+", "-",
    "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
    "&", "^", "|", "&&", "||", "?", ":",
    "!", "~", "eq", "ne", "**", "in", "ni"
};

/*
 * Declarations for local functions to this file:
 */

static int		GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
static void		LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr,
			    CONST char *extraInfo));
static int		ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));


static int		ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseExponentialExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static void		PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
			    int opBytes, CONST char *src, int srcBytes,
			    int firstIndex, ParseInfo *infoPtr));

/*
 * Macro used to debug the execution of the recursive descent parser used to
 * parse expressions.
 */

#ifdef TCL_COMPILE_DEBUG
#define HERE(production, level) \
    if (traceParseExpr) { \
	fprintf(stderr, "%*s%s: lexeme=%s, next=\"%.20s\"\n", \
		(level), " ", (production), \
		lexemeStrings[infoPtr->lexeme], infoPtr->next); \
    }
#else
#define HERE(production, level)
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseExpr --
 *
 *	Given a string, this function parses the first Tcl expression in the
 *	string and returns information about the structure of the expression.
 *	This function is the top-level interface to the the expression parsing
 *	module. No more than numBytes bytes will be scanned.
 *
 *	Note that this parser is a LL(1) parser; the operator precedence rules
 *	are completely hard coded in the recursive structure of the parser
 *	itself.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
 *	error message is left in its result. On a successful return, parsePtr
 *	is filled in with information about the expression that was parsed.

 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the expression, then additional space is malloc-ed. If the
 *	function returns TCL_OK then the caller must eventually invoke
 *	Tcl_FreeParse to release any additional space that was allocated.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(interp, start, numBytes, parsePtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *start;		/* Start of source string to parse. */
    int numBytes;		/* Number of bytes in string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill with information about
				 * the parsed expression; any previous
				 * information in the structure is ignored. */

{
    ParseInfo info;
    int code;

    if (numBytes < 0) {
	numBytes = (start? strlen(start) : 0);
    }
#ifdef TCL_COMPILE_DEBUG
    if (traceParseExpr) {
	fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",
		numBytes, start);
    }
#endif /* TCL_COMPILE_DEBUG */

    TclParseInit(interp, start, numBytes, parsePtr);

    /*
     * Initialize the ParseInfo structure that holds state while parsing the
     * expression.
     */

    info.parsePtr = parsePtr;
    info.lexeme = UNKNOWN;
    info.start = NULL;
    info.size = 0;
    info.next = start;
    info.prevEnd = start;
    info.originalExpr = start;
    info.lastChar = (start + numBytes); /* just after last char of expr */

    /*
     * Get the first lexeme then parse the expression.
     */

    code = GetLexeme(&info);
    if (code != TCL_OK) {
	goto error;
    }
    code = ParseCondExpr(&info);
    if (code != TCL_OK) {
	goto error;
    }
    if (info.lexeme != END) {
	LogSyntaxError(&info, "extra tokens at end of expression");
	goto error;
    }
    return TCL_OK;

  error:
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseCondExpr --
 *
 *	This function parses a Tcl conditional expression:
 *	condExpr ::= lorExpr ['?' condExpr ':' condExpr]
 *
 *	Note that this is the topmost recursive-descent parsing routine used
 *	by Tcl_ParseExpr to parse expressions. This avoids an extra function
 *	call since such a function would only return the result of calling
 *	ParseCondExpr. Other recursive-descent functions that need to parse
 *	complete expressions also call ParseCondExpr.
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseCondExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
    int firstIndex, numToMove, code;
    CONST char *srcStart;

    HERE("condExpr", 1);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseLorExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    if (infoPtr->lexeme == QUESTY) {
	/*
	 * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire
	 * conditional expression, and a TCL_TOKEN_OPERATOR token for the "?"
	 * operator. Note that these two tokens must be inserted before the
	 * LOR operand tokens generated above.
	 */

	if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
	tokenPtr = (firstTokenPtr + 2);
	numToMove = (parsePtr->numTokens - firstIndex);
	memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
		(size_t) (numToMove * sizeof(Tcl_Token)));
	parsePtr->numTokens += 2;

	tokenPtr = firstTokenPtr;
	tokenPtr->type = TCL_TOKEN_SUB_EXPR;
	tokenPtr->start = srcStart;

	tokenPtr++;
	tokenPtr->type = TCL_TOKEN_OPERATOR;
	tokenPtr->start = infoPtr->start;
	tokenPtr->size = 1;
	tokenPtr->numComponents = 0;

	/*
	 * Skip over the '?'.
	 */

	code = GetLexeme(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Parse the "then" expression.
	 */
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
}

/*
 *----------------------------------------------------------------------
 *
 * ParseLorExpr --
 *
 *	This procedure parses a Tcl logical or expression:
 *	lorExpr ::= landExpr {'||' landExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseLorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;
    
    HERE("lorExpr", 2);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseLandExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == OR) {
	operator = infoPtr->start;







|



|
|



|
|
<






|
|




|



|







391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
}

/*
 *----------------------------------------------------------------------
 *
 * ParseLorExpr --
 *
 *	This function parses a Tcl logical or expression:
 *	lorExpr ::= landExpr {'||' landExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseLorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("lorExpr", 2);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseLandExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == OR) {
	operator = infoPtr->start;
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
	}

	/*
	 * Generate tokens for the LOR subexpression and the '||' operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseLandExpr --
 *
 *	This procedure parses a Tcl logical and expression:
 *	landExpr ::= bitOrExpr {'&&' bitOrExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseLandExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("landExpr", 3);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitOrExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == AND) {
	operator = infoPtr->start;







|









|



|
|



|
|
<






|
|








|







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467

468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
	}

	/*
	 * Generate tokens for the LOR subexpression and the '||' operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseLandExpr --
 *
 *	This function parses a Tcl logical and expression:
 *	landExpr ::= bitOrExpr {'&&' bitOrExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseLandExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("landExpr", 3);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseBitOrExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == AND) {
	operator = infoPtr->start;
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
	}

	/*
	 * Generate tokens for the LAND subexpression and the '&&' operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseBitOrExpr --
 *
 *	This procedure parses a Tcl bitwise or expression:
 *	bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseBitOrExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitOrExpr", 4);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitXorExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }
    
    while (infoPtr->lexeme == BIT_OR) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the '|' */
	if (code != TCL_OK) {
	    return code;
	}

	code = ParseBitXorExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}
	
	/*
	 * Generate tokens for the BITOR subexpression and the '|' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseBitXorExpr --
 *
 *	This procedure parses a Tcl bitwise exclusive or expression:
 *	bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseBitXorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitXorExpr", 5);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitAndExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }
    
    while (infoPtr->lexeme == BIT_XOR) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the '^' */
	if (code != TCL_OK) {
	    return code;
	}

	code = ParseBitAndExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}
	
	/*
	 * Generate tokens for the XOR subexpression and the '^' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseBitAndExpr --
 *
 *	This procedure parses a Tcl bitwise and expression:
 *	bitAndExpr ::= equalityExpr {'&' equalityExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseBitAndExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitAndExpr", 6);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseEqualityExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }
    
    while (infoPtr->lexeme == BIT_AND) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the '&' */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseEqualityExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}
	
	/*
	 * Generate tokens for the BITAND subexpression and '&' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseEqualityExpr --
 *
 *	This procedure parses a Tcl equality (inequality) expression:
 *	equalityExpr ::= relationalExpr
 *		{('==' | '!=' | 'ne' | 'eq') relationalExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseEqualityExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("equalityExpr", 7);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseRelationalExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while (lexeme == EQUAL || lexeme == NEQ || lexeme == NOT_IN_LIST ||







|









|



|
|



|
|
<






|
|








|




|











|





|









|



|
|



|
|
<






|
|








|




|











|





|









|



|
|



|
|
<






|
|








|




|










|





|









|




|
|



|
|
<






|
|








|







499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526

527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706

707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
	}

	/*
	 * Generate tokens for the LAND subexpression and the '&&' operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseBitOrExpr --
 *
 *	This function parses a Tcl bitwise or expression:
 *	bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseBitOrExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitOrExpr", 4);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseBitXorExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == BIT_OR) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the '|' */
	if (code != TCL_OK) {
	    return code;
	}

	code = ParseBitXorExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the BITOR subexpression and the '|' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseBitXorExpr --
 *
 *	This function parses a Tcl bitwise exclusive or expression:
 *	bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseBitXorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitXorExpr", 5);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseBitAndExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == BIT_XOR) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the '^' */
	if (code != TCL_OK) {
	    return code;
	}

	code = ParseBitAndExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the XOR subexpression and the '^' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseBitAndExpr --
 *
 *	This function parses a Tcl bitwise and expression:
 *	bitAndExpr ::= equalityExpr {'&' equalityExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseBitAndExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitAndExpr", 6);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseEqualityExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    while (infoPtr->lexeme == BIT_AND) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the '&' */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseEqualityExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the BITAND subexpression and '&' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseEqualityExpr --
 *
 *	This function parses a Tcl equality (inequality) expression:
 *	equalityExpr ::= relationalExpr
 *		{('==' | '!=' | 'ne' | 'eq') relationalExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseEqualityExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("equalityExpr", 7);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseRelationalExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while (lexeme == EQUAL || lexeme == NEQ || lexeme == NOT_IN_LIST ||
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951

	/*
	 * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne'
	 * operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseRelationalExpr --
 *
 *	This procedure parses a Tcl relational expression:
 *	relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseRelationalExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, operatorSize, code;
    CONST char *srcStart, *operator;

    HERE("relationalExpr", 8);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseShiftExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ)
            || (lexeme == GEQ)) {
	operator = infoPtr->start;
	if ((lexeme == LEQ) || (lexeme == GEQ)) {
	    operatorSize = 2;
	} else {
	    operatorSize = 1;
	}
	code = GetLexeme(infoPtr); /* skip over the operator */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseShiftExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and the operator.
	 */

	PrependSubExprTokens(operator, operatorSize, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseShiftExpr --
 *
 *	This procedure parses a Tcl shift expression:
 *	shiftExpr ::= addExpr {('<<' | '>>') addExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseShiftExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("shiftExpr", 9);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseAddExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over << or >> */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseAddExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and '<<' or '>>' operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseAddExpr --
 *
 *	This procedure parses a Tcl addition expression:
 *	addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseAddExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("addExpr", 10);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseMultiplyExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == PLUS) || (lexeme == MINUS)) {







|










|



|
|



|
|
<






|
|








|







|




















|










|



|
|



|
|
<






|
|








|








|













|










|



|
|



|
|
<






|
|








|







741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769

770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836

837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897

898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921

	/*
	 * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne'
	 * operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseRelationalExpr --
 *
 *	This function parses a Tcl relational expression:
 *	relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseRelationalExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, operatorSize, code;
    CONST char *srcStart, *operator;

    HERE("relationalExpr", 8);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseShiftExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ)
	    || (lexeme == GEQ)) {
	operator = infoPtr->start;
	if ((lexeme == LEQ) || (lexeme == GEQ)) {
	    operatorSize = 2;
	} else {
	    operatorSize = 1;
	}
	code = GetLexeme(infoPtr); /* skip over the operator */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseShiftExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and the operator.
	 */

	PrependSubExprTokens(operator, operatorSize, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseShiftExpr --
 *
 *	This function parses a Tcl shift expression:
 *	shiftExpr ::= addExpr {('<<' | '>>') addExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseShiftExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("shiftExpr", 9);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseAddExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr);	/* skip over << or >> */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseAddExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and '<<' or '>>' operator.
	 */

	PrependSubExprTokens(operator, 2, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseAddExpr --
 *
 *	This function parses a Tcl addition expression:
 *	addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseAddExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("addExpr", 10);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseMultiplyExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == PLUS) || (lexeme == MINUS)) {
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
	}

	/*
	 * Generate tokens for the subexpression and '+' or '-' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseMultiplyExpr --
 *
 *	This procedure parses a Tcl multiply expression:
 *	multiplyExpr ::= exponentialExpr {('*' | '/' | '%') exponentialExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseMultiplyExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("multiplyExpr", 11);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseExponentialExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over * or / or % */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseExponentialExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and * or / or % operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseExponentialExpr --
 *
 *	This procedure parses a Tcl exponential expression:
 *	exponentialExpr ::= unaryExpr {'**' unaryExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseExponentialExpr(infoPtr)
    ParseInfo *infoPtr;			/* Holds the parse state for the
					 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("exponentiateExpr", 12);
    srcStart = infoPtr->start;







|










|



|
|



|
|
<






|
|








|








|













|










|



|
|



|
|
<






|
|







930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958

959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019

1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
	}

	/*
	 * Generate tokens for the subexpression and '+' or '-' operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseMultiplyExpr --
 *
 *	This function parses a Tcl multiply expression:
 *	multiplyExpr ::= exponentialExpr {('*' | '/' | '%') exponentialExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseMultiplyExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("multiplyExpr", 11);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    code = ParseExponentialExpr(infoPtr);
    if (code != TCL_OK) {
	return code;
    }

    lexeme = infoPtr->lexeme;
    while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr);	/* skip over * or / or % */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseExponentialExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and * or / or % operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseExponentialExpr --
 *
 *	This function parses a Tcl exponential expression:
 *	exponentialExpr ::= unaryExpr {'**' unaryExpr}
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseExponentialExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("exponentiateExpr", 12);
    srcStart = infoPtr->start;
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192

	PrependSubExprTokens(operator, 2, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * ParseUnaryExpr --
 *
 *	This procedure parses a Tcl unary expression:
 *	unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseUnaryExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("unaryExpr", 13);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    lexeme = infoPtr->lexeme;
    if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)
            || (lexeme == NOT)) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the unary operator */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseUnaryExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and the operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
	        (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    } else {			/* must be a primaryExpr */
	code = ParsePrimaryExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParsePrimaryExpr --
 *
 *	This procedure parses a Tcl primary expression:
 *	primaryExpr ::= literal | varReference | quotedString |
 *			'[' command ']' | mathFuncCall | '(' condExpr ')'
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static int
ParsePrimaryExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Interp *interp = parsePtr->interp;
    Tcl_Token *tokenPtr, *exprTokenPtr;
    Tcl_Parse nested;
    CONST char *dollarPtr, *stringStart, *termPtr, *src;
    int lexeme, exprIndex, firstIndex, numToMove, code;







<






|



|
|



|
|
<






|
|








|


|















|














|




|
|



|
|
<






|
|







1057
1058
1059
1060
1061
1062
1063

1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080

1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142

1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157

	PrependSubExprTokens(operator, 2, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
	lexeme = infoPtr->lexeme;
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * ParseUnaryExpr --
 *
 *	This function parses a Tcl unary expression:
 *	unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParseUnaryExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("unaryExpr", 13);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;

    lexeme = infoPtr->lexeme;
    if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)
	    || (lexeme == NOT)) {
	operator = infoPtr->start;
	code = GetLexeme(infoPtr); /* skip over the unary operator */
	if (code != TCL_OK) {
	    return code;
	}
	code = ParseUnaryExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}

	/*
	 * Generate tokens for the subexpression and the operator.
	 */

	PrependSubExprTokens(operator, 1, srcStart,
		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
    } else {			/* must be a primaryExpr */
	code = ParsePrimaryExpr(infoPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ParsePrimaryExpr --
 *
 *	This function parses a Tcl primary expression:
 *	primaryExpr ::= literal | varReference | quotedString |
 *			'[' command ']' | mathFuncCall | '(' condExpr ')'
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR on
 *	failure. If TCL_ERROR is returned, then the interpreter's result
 *	contains an error message.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed.

 *
 *----------------------------------------------------------------------
 */

static int
ParsePrimaryExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Interp *interp = parsePtr->interp;
    Tcl_Token *tokenPtr, *exprTokenPtr;
    Tcl_Parse nested;
    CONST char *dollarPtr, *stringStart, *termPtr, *src;
    int lexeme, exprIndex, firstIndex, numToMove, code;
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246

1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
    exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
    exprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
    exprTokenPtr->start = infoPtr->start;
    parsePtr->numTokens++;

    /*
     * Process the primary then finish setting the fields of the
     * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now
     * stored in "exprTokenPtr" in the code below since the token array
     * might be reallocated.
     */

    firstIndex = parsePtr->numTokens;
    switch (lexeme) {
    case LITERAL:
	/*
	 * Int or double number.
	 */
	

	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = infoPtr->start;
	tokenPtr->size = infoPtr->size;
	tokenPtr->numComponents = 0;
	parsePtr->numTokens++;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = infoPtr->size;
	exprTokenPtr->numComponents = 1;
	break;

    case DOLLAR:
	/*
	 * $var variable reference.
	 */
	
	dollarPtr = (infoPtr->next - 1);
	code = Tcl_ParseVarName(interp, dollarPtr,
	        (infoPtr->lastChar - dollarPtr), parsePtr, 1);
	if (code != TCL_OK) {
	    return code;
	}
	infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size;
	exprTokenPtr->numComponents =
	        (parsePtr->tokenPtr[firstIndex].numComponents + 1);
	break;
	
    case QUOTE:
	/*
	 * '"' string '"'
	 */
	
	stringStart = infoPtr->next;
	code = Tcl_ParseQuotedString(interp, infoPtr->start,
	        (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr);
	if (code != TCL_OK) {
	    return code;
	}
	infoPtr->next = termPtr;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = (termPtr - exprTokenPtr->start);
	exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;

	/*
	 * If parsing the quoted string resulted in more than one token,
	 * insert a TCL_TOKEN_WORD token before them. This indicates that
	 * the quoted string represents a concatenation of multiple tokens.
	 */

	if (exprTokenPtr->numComponents > 1) {
	    if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
		TclExpandTokenArray(parsePtr);
	    }
	    tokenPtr = &parsePtr->tokenPtr[firstIndex];
	    numToMove = (parsePtr->numTokens - firstIndex);
	    memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
	            (size_t) (numToMove * sizeof(Tcl_Token)));
	    parsePtr->numTokens++;

	    exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	    exprTokenPtr->numComponents++;

	    tokenPtr->type = TCL_TOKEN_WORD;
	    tokenPtr->start = exprTokenPtr->start;
	    tokenPtr->size = exprTokenPtr->size;
	    tokenPtr->numComponents = (exprTokenPtr->numComponents - 1);
	}
	break;
	
    case OPEN_BRACKET:
	/*
	 * '[' command {command} ']'
	 */

	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->type = TCL_TOKEN_COMMAND;
	tokenPtr->start = infoPtr->start;
	tokenPtr->numComponents = 0;
	parsePtr->numTokens++;

	/*
	 * Call Tcl_ParseCommand repeatedly to parse the nested command(s)
	 * to find their end, then throw away that parse information.
	 */
	
	src = infoPtr->next;
	while (1) {
	    if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1,
		    &nested) != TCL_OK) {
		parsePtr->term = nested.term;
		parsePtr->errorType = nested.errorType;
		parsePtr->incomplete = nested.incomplete;
		return TCL_ERROR;
	    }
	    src = (nested.commandStart + nested.commandSize);

	    /*
	     * This is equivalent to Tcl_FreeParse(&nested), but
	     * presumably inlined here for sake of runtime optimization
	     */

	    if (nested.tokenPtr != nested.staticTokens) {
		ckfree((char *) nested.tokenPtr);
	    }

	    /*
	     * Check for the closing ']' that ends the command substitution.
	     * It must have been the last character of the parsed command.
	     */

	    if ((nested.term < parsePtr->end) && (*nested.term == ']') 
		    && !nested.incomplete) {
		break;
	    }
	    if (src == parsePtr->end) {
		if (parsePtr->interp != NULL) {
		    Tcl_SetResult(interp, "missing close-bracket",
			    TCL_STATIC);







|
|
|








|
>



















|


|








|

|




|


|











|
|









|











|















|
|

|












|
|











|







1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
    exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
    exprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
    exprTokenPtr->start = infoPtr->start;
    parsePtr->numTokens++;

    /*
     * Process the primary then finish setting the fields of the
     * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now stored
     * in "exprTokenPtr" in the code below since the token array might be
     * reallocated.
     */

    firstIndex = parsePtr->numTokens;
    switch (lexeme) {
    case LITERAL:
	/*
	 * Int or double number.
	 */

    tokenizeLiteral:
	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = infoPtr->start;
	tokenPtr->size = infoPtr->size;
	tokenPtr->numComponents = 0;
	parsePtr->numTokens++;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = infoPtr->size;
	exprTokenPtr->numComponents = 1;
	break;

    case DOLLAR:
	/*
	 * $var variable reference.
	 */

	dollarPtr = (infoPtr->next - 1);
	code = Tcl_ParseVarName(interp, dollarPtr,
		(infoPtr->lastChar - dollarPtr), parsePtr, 1);
	if (code != TCL_OK) {
	    return code;
	}
	infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size;
	exprTokenPtr->numComponents =
		(parsePtr->tokenPtr[firstIndex].numComponents + 1);
	break;

    case QUOTE:
	/*
	 * '"' string '"'
	 */

	stringStart = infoPtr->next;
	code = Tcl_ParseQuotedString(interp, infoPtr->start,
		(infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr);
	if (code != TCL_OK) {
	    return code;
	}
	infoPtr->next = termPtr;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = (termPtr - exprTokenPtr->start);
	exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;

	/*
	 * If parsing the quoted string resulted in more than one token,
	 * insert a TCL_TOKEN_WORD token before them. This indicates that the
	 * quoted string represents a concatenation of multiple tokens.
	 */

	if (exprTokenPtr->numComponents > 1) {
	    if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
		TclExpandTokenArray(parsePtr);
	    }
	    tokenPtr = &parsePtr->tokenPtr[firstIndex];
	    numToMove = (parsePtr->numTokens - firstIndex);
	    memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
		    (size_t) (numToMove * sizeof(Tcl_Token)));
	    parsePtr->numTokens++;

	    exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	    exprTokenPtr->numComponents++;

	    tokenPtr->type = TCL_TOKEN_WORD;
	    tokenPtr->start = exprTokenPtr->start;
	    tokenPtr->size = exprTokenPtr->size;
	    tokenPtr->numComponents = (exprTokenPtr->numComponents - 1);
	}
	break;

    case OPEN_BRACKET:
	/*
	 * '[' command {command} ']'
	 */

	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->type = TCL_TOKEN_COMMAND;
	tokenPtr->start = infoPtr->start;
	tokenPtr->numComponents = 0;
	parsePtr->numTokens++;

	/*
	 * Call Tcl_ParseCommand repeatedly to parse the nested command(s) to
	 * find their end, then throw away that parse information.
	 */

	src = infoPtr->next;
	while (1) {
	    if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1,
		    &nested) != TCL_OK) {
		parsePtr->term = nested.term;
		parsePtr->errorType = nested.errorType;
		parsePtr->incomplete = nested.incomplete;
		return TCL_ERROR;
	    }
	    src = (nested.commandStart + nested.commandSize);

	    /*
	     * This is equivalent to Tcl_FreeParse(&nested), but presumably
	     * inlined here for sake of runtime optimization
	     */

	    if (nested.tokenPtr != nested.staticTokens) {
		ckfree((char *) nested.tokenPtr);
	    }

	    /*
	     * Check for the closing ']' that ends the command substitution.
	     * It must have been the last character of the parsed command.
	     */

	    if ((nested.term < parsePtr->end) && (*nested.term == ']')
		    && !nested.incomplete) {
		break;
	    }
	    if (src == parsePtr->end) {
		if (parsePtr->interp != NULL) {
		    Tcl_SetResult(interp, "missing close-bracket",
			    TCL_STATIC);
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433




1434
1435
1436
1437
1438














































1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518

1519
1520
1521
1522
1523
1524
1525
1526
1527

1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543

1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617

1618
1619
1620

1621

1622

1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914

1915
1916
1917
1918
1919
1920
1921
1922
1923

1924
1925
1926
1927

1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014

2015


2016
2017
2018


2019
2020
2021
2022
2023
2024

2025


2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187









    case OPEN_BRACE:
	/*
	 * '{' string '}'
	 */

	code = Tcl_ParseBraces(interp, infoPtr->start,
	        (infoPtr->lastChar - infoPtr->start), parsePtr, 1,
		&termPtr);
	if (code != TCL_OK) {
	    return code;
	}
	infoPtr->next = termPtr;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = (termPtr - infoPtr->start);
	exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;

	/*
	 * If parsing the braced string resulted in more than one token,
	 * insert a TCL_TOKEN_WORD token before them. This indicates that
	 * the braced string represents a concatenation of multiple tokens.
	 */

	if (exprTokenPtr->numComponents > 1) {
	    if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
		TclExpandTokenArray(parsePtr);
	    }
	    tokenPtr = &parsePtr->tokenPtr[firstIndex];
	    numToMove = (parsePtr->numTokens - firstIndex);
	    memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
	            (size_t) (numToMove * sizeof(Tcl_Token)));
	    parsePtr->numTokens++;

	    exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	    exprTokenPtr->numComponents++;
	    
	    tokenPtr->type = TCL_TOKEN_WORD;
	    tokenPtr->start = exprTokenPtr->start;
	    tokenPtr->size = exprTokenPtr->size;
	    tokenPtr->numComponents = exprTokenPtr->numComponents-1;
	}
	break;
	




    case FUNC_NAME:
	/*
	 * math_func '(' expr {',' expr} ')'
	 */
	














































	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->type = TCL_TOKEN_OPERATOR;
	tokenPtr->start = infoPtr->start;
	tokenPtr->size = infoPtr->size;
	tokenPtr->numComponents = 0;
	parsePtr->numTokens++;
	
	code = GetLexeme(infoPtr); /* skip over function name */
	if (code != TCL_OK) {
	    return code;
	}
	if (infoPtr->lexeme != OPEN_PAREN) {
	    /*
	     * Guess what kind of error we have by trying to tell
	     * whether we have a function or variable name here.
	     * Alas, this makes the parser more tightly bound with the
	     * rest of the interpreter, but that is the only way to
	     * give a sensible message here.  Still, it is not too
	     * serious as this is only done when generating an error.
	     */
	    Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
	    Tcl_DString functionName;
	    Tcl_HashEntry *hPtr;

	    /*
	     * Look up the name as a function name.  We need a writable
	     * copy (DString) so we can terminate it with a NULL for
	     * the benefit of Tcl_FindHashEntry which operates on
	     * NULL-terminated string keys.
	     */
	    Tcl_DStringInit(&functionName);
	    hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, 
	    	Tcl_DStringAppend(&functionName, tokenPtr->start,
		tokenPtr->size));
	    Tcl_DStringFree(&functionName);

	    /*
	     * Assume that we have an attempted variable reference
	     * unless we've got a function name, as the set of
	     * potential function names is typically much smaller.
	     */
	    if (hPtr != NULL) {
		LogSyntaxError(infoPtr,
			"expected parenthesis enclosing function arguments");
	    } else {
		LogSyntaxError(infoPtr,
			"variable references require preceding $");
	    }
	    return TCL_ERROR;
	}
	code = GetLexeme(infoPtr); /* skip over '(' */
	if (code != TCL_OK) {
	    return code;
	}

	while (infoPtr->lexeme != CLOSE_PAREN) {
	    code = ParseCondExpr(infoPtr);
	    if (code != TCL_OK) {
		return code;
	    }
	    
	    if (infoPtr->lexeme == COMMA) {
		code = GetLexeme(infoPtr); /* skip over , */
		if (code != TCL_OK) {
		    return code;
		}
	    } else if (infoPtr->lexeme != CLOSE_PAREN) {
		LogSyntaxError(infoPtr,
			"missing close parenthesis at end of function call");
		return TCL_ERROR;
	    }
	}

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
	exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
	break;


    case COMMA:
	LogSyntaxError(infoPtr,
		"commas can only separate function arguments");
	return TCL_ERROR;
    case END:
	LogSyntaxError(infoPtr, "premature end of expression");
	return TCL_ERROR;
    case UNKNOWN:

	LogSyntaxError(infoPtr, "single equality character not legal in expressions");
	return TCL_ERROR;
    case UNKNOWN_CHAR:
	LogSyntaxError(infoPtr, "character not legal in expressions");
	return TCL_ERROR;
    case QUESTY:
	LogSyntaxError(infoPtr, "unexpected ternary 'then' separator");
	return TCL_ERROR;
    case COLON:
	LogSyntaxError(infoPtr, "unexpected ternary 'else' separator");
	return TCL_ERROR;
    case CLOSE_PAREN:
	LogSyntaxError(infoPtr, "unexpected close parenthesis");
	return TCL_ERROR;

    default: {

	char buf[64];

	sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]);
	LogSyntaxError(infoPtr, buf);
	return TCL_ERROR;
	}
    }

    /*
     * Advance to the next lexeme before returning.
     */
    
    code = GetLexeme(infoPtr);
    if (code != TCL_OK) {
	return code;
    }
    parsePtr->term = infoPtr->next;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetLexeme --
 *
 *	Lexical scanner for Tcl expressions: scans a single operator or
 *	other syntactic element from an expression string.
 *
 * Results:
 *	TCL_OK is returned unless an error occurred. In that case a standard
 *	Tcl error code is returned and, if infoPtr->parsePtr->interp is
 *	non-NULL, the interpreter's result is set to hold an error
 *	message. TCL_ERROR is returned if an integer overflow, or a
 *	floating-point overflow or underflow occurred while reading in a
 *	number. If the lexical analysis is successful, infoPtr->lexeme
 *	refers to the next symbol in the expression string, and
 *	infoPtr->next is advanced past the lexeme. Also, if the lexeme is a
 *	LITERAL or FUNC_NAME, then infoPtr->start is set to the first
 *	character of the lexeme; otherwise it is set NULL.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the
 *	information about the subexpression, then additional space is
 *	malloc-ed..
 *
 *----------------------------------------------------------------------
 */

static int
GetLexeme(infoPtr)
    ParseInfo *infoPtr;		/* Holds state needed to parse the expr,
				 * including the resulting lexeme. */
{
    register CONST char *src;	/* Points to current source char. */
    char c;
    int offset, length, numBytes;
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Interp *interp = parsePtr->interp;
    Tcl_UniChar ch;

    /*
     * Record where the previous lexeme ended. Since we always read one
     * lexeme ahead during parsing, this helps us know the source length of
     * subexpression tokens.
     */

    infoPtr->prevEnd = infoPtr->next;

    /*
     * Scan over leading white space at the start of a lexeme. 
     */

    src = infoPtr->next;
    numBytes = parsePtr->end - src;

    do {
	char type;
	int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);

	src += scanned; numBytes -= scanned;

    } while  (numBytes && (*src == '\n') && (src++,numBytes--));

    parsePtr->term = src;
    if (numBytes == 0) {
	infoPtr->lexeme = END;
	infoPtr->next = src;
	return TCL_OK;
    }

    /*
     * Try to parse the lexeme first as an integer or floating-point
     * number. Don't check for a number if the first character c is
     * "+" or "-". If we did, we might treat a binary operator as unary
     * by mistake, which would eventually cause a syntax error.
     */

    c = *src;
    if ((c != '+') && (c != '-')) {
	CONST char *end = infoPtr->lastChar;
	if ((length = TclParseInteger(src, (end - src)))) {
	    /*
	     * First length bytes look like an integer.  Verify by
	     * attempting the conversion to the largest integer we have.
	     */
	    int code;
	    Tcl_WideInt wide;
	    Tcl_Obj *value = Tcl_NewStringObj(src, length);

	    Tcl_IncrRefCount(value);
	    code = Tcl_GetWideIntFromObj(interp, value, &wide);
	    Tcl_DecrRefCount(value);
	    if (code == TCL_ERROR) {
		parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		return TCL_ERROR;
	    }
            infoPtr->lexeme = LITERAL;
	    infoPtr->start = src;
	    infoPtr->size = length;
            infoPtr->next = (src + length);
	    parsePtr->term = infoPtr->next;
            return TCL_OK;
	} else if ((length = ParseMaxDoubleLength(src, end))) {
	    /*
	     * There are length characters that could be a double.
	     * Let strtod() tells us for sure.  Need a writable copy
	     * so we can set an terminating NULL to keep strtod from
	     * scanning too far.
	     */
	    char *startPtr, *termPtr;
	    double doubleValue;
	    Tcl_DString toParse;

	    errno = 0;
	    Tcl_DStringInit(&toParse);
	    startPtr = Tcl_DStringAppend(&toParse, src, length);
	    doubleValue = strtod(startPtr, &termPtr);
	    Tcl_DStringFree(&toParse);
	    if (termPtr != startPtr) {
		if (errno != 0) {
		    if (interp != NULL) {
			TclExprFloatError(interp, doubleValue);
		    }
		    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		    return TCL_ERROR;
		}
		
		/*
                 * startPtr was the start of a valid double, copied
		 * from src.
                 */
		
		infoPtr->lexeme = LITERAL;
		infoPtr->start = src;
		if ((termPtr - startPtr) > length) {
		    infoPtr->size = length;
		} else {
		    infoPtr->size = (termPtr - startPtr);
		}
		infoPtr->next = src + infoPtr->size;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    }
	}
    }

    /*
     * Not an integer or double literal. Initialize the lexeme's fields
     * assuming the common case of a single character lexeme.
     */

    infoPtr->start = src;
    infoPtr->size = 1;
    infoPtr->next = src+1;
    parsePtr->term = infoPtr->next;
    
    switch (*src) {
	case '[':
	    infoPtr->lexeme = OPEN_BRACKET;
	    return TCL_OK;

        case '{':
	    infoPtr->lexeme = OPEN_BRACE;
	    return TCL_OK;

	case '(':
	    infoPtr->lexeme = OPEN_PAREN;
	    return TCL_OK;

	case ')':
	    infoPtr->lexeme = CLOSE_PAREN;
	    return TCL_OK;

	case '$':
	    infoPtr->lexeme = DOLLAR;
	    return TCL_OK;

	case '\"':
	    infoPtr->lexeme = QUOTE;
	    return TCL_OK;

	case ',':
	    infoPtr->lexeme = COMMA;
	    return TCL_OK;

	case '*':
	    infoPtr->lexeme = MULT;
	    if ((infoPtr->lastChar - src)>1  &&  src[1]=='*') {
		infoPtr->lexeme = EXPON;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
	    }
	    return TCL_OK;

	case '/':
	    infoPtr->lexeme = DIVIDE;
	    return TCL_OK;

	case '%':
	    infoPtr->lexeme = MOD;
	    return TCL_OK;

	case '+':
	    infoPtr->lexeme = PLUS;
	    return TCL_OK;

	case '-':
	    infoPtr->lexeme = MINUS;
	    return TCL_OK;

	case '?':
	    infoPtr->lexeme = QUESTY;
	    return TCL_OK;

	case ':':
	    infoPtr->lexeme = COLON;
	    return TCL_OK;

	case '<':
	    infoPtr->lexeme = LESS;
	    if ((infoPtr->lastChar - src) > 1) {
		switch (src[1]) {
		    case '<':
			infoPtr->lexeme = LEFT_SHIFT;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;
		    case '=':
			infoPtr->lexeme = LEQ;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;
		}
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '>':
	    infoPtr->lexeme = GREATER;
	    if ((infoPtr->lastChar - src) > 1) {
		switch (src[1]) {
		    case '>':
			infoPtr->lexeme = RIGHT_SHIFT;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;
		    case '=':
			infoPtr->lexeme = GEQ;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;
		}
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '=':
	    infoPtr->lexeme = UNKNOWN;
	    if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = EQUAL;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '!':
	    infoPtr->lexeme = NOT;
	    if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = NEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '&':
	    infoPtr->lexeme = BIT_AND;
	    if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = AND;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '^':
	    infoPtr->lexeme = BIT_XOR;
	    return TCL_OK;

	case '|':
	    infoPtr->lexeme = BIT_OR;
	    if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = OR;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '~':
	    infoPtr->lexeme = BIT_NOT;
	    return TCL_OK;

	case 'e':
	    if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) &&
		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
		infoPtr->lexeme = STREQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else {
		goto checkFuncName;
	    }

	case 'n':
	    if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) &&
		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
		infoPtr->lexeme = STRNEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) &&
		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
		infoPtr->lexeme = NOT_IN_LIST;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else {
		goto checkFuncName;
	    }

	case 'i':
	    if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) &&
		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
		infoPtr->lexeme = IN_LIST;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else {
		goto checkFuncName;
	    }

	default:
	checkFuncName:
	    length = (infoPtr->lastChar - src);
	    if (Tcl_UtfCharComplete(src, length)) {
		offset = Tcl_UtfToUniChar(src, &ch);
	    } else {
		char utfBytes[TCL_UTF_MAX];

		memcpy(utfBytes, src, (size_t) length);
		utfBytes[length] = '\0';
		offset = Tcl_UtfToUniChar(utfBytes, &ch);
	    }
	    c = UCHAR(ch);
	    if (isalpha(UCHAR(c))) {	/* INTL: ISO only. */
		infoPtr->lexeme = FUNC_NAME;
		while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
		    src += offset; length -= offset;

		    if (Tcl_UtfCharComplete(src, length)) {
			offset = Tcl_UtfToUniChar(src, &ch);
		    } else {
			char utfBytes[TCL_UTF_MAX];

			memcpy(utfBytes, src, (size_t) length);
			utfBytes[length] = '\0';
			offset = Tcl_UtfToUniChar(utfBytes, &ch);
		    }
		    c = UCHAR(ch);
		}
		infoPtr->size = (src - infoPtr->start);
		infoPtr->next = src;
		parsePtr->term = infoPtr->next;
		/*
		 * Check for boolean literals (true, false, yes, no, on, off)
		 */
		switch (infoPtr->start[0]) {
		case 'f':
		    if (infoPtr->size == 5 &&
			strncmp("false", infoPtr->start, 5) == 0) {
			infoPtr->lexeme = LITERAL;
			return TCL_OK;
		    }
		    break;
		case 'n':
		    if (infoPtr->size == 2 &&
			strncmp("no", infoPtr->start, 2) == 0) {
			infoPtr->lexeme = LITERAL;
			return TCL_OK;
		    }
		    break;
		case 'o':
		    if (infoPtr->size == 3 &&
			strncmp("off", infoPtr->start, 3) == 0) {
			infoPtr->lexeme = LITERAL;
			return TCL_OK;
		    } else if (infoPtr->size == 2 &&
			strncmp("on", infoPtr->start, 2) == 0) {
			infoPtr->lexeme = LITERAL;
			return TCL_OK;
		    }
		    break;
		case 't':
		    if (infoPtr->size == 4 &&
			strncmp("true", infoPtr->start, 4) == 0) {
			infoPtr->lexeme = LITERAL;
			return TCL_OK;
		    }
		    break;
		case 'y':
		    if (infoPtr->size == 3 &&
			strncmp("yes", infoPtr->start, 3) == 0) {
			infoPtr->lexeme = LITERAL;
			return TCL_OK;
		    }
		    break;
		}
		return TCL_OK;
	    }
	    infoPtr->lexeme = UNKNOWN_CHAR;
	    return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseInteger --
 *
 *	Scans up to numBytes bytes starting at src, and checks whether
 *	the leading bytes look like an integer's string representation.
 *
 * Results:
 *	Returns 0 if the leading bytes do not look like an integer.
 *	Otherwise, returns the number of bytes examined that look
 *	like an integer.  This may be less than numBytes if the integer
 *	is only the leading part of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseInteger(string, numBytes)
    register CONST char *string;/* The string to examine. */
    register int numBytes;	/* Max number of bytes to scan. */
{
    register CONST char *p = string;


    /* Take care of introductory "0x" */


    if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
	int scanned;
	Tcl_UniChar ch;


	p+=2; numBytes -= 2;
 	scanned = TclParseHex(p, numBytes, &ch);
	if (scanned) {
	    return scanned + 2;
	}


	/* Recognize the 0 as valid integer, but x is left behind */


	return 1;
    }
    while (numBytes && isdigit(UCHAR(*p))) {	/* INTL: digit */
	numBytes--; p++;
    }
    if (numBytes == 0) {
        return (p - string);
    }
    if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
        return (p - string);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseMaxDoubleLength --
 *
 *      Scans a sequence of bytes checking that the characters could
 *	be in a string rep of a double.
 *
 * Results:
 *	Returns the number of bytes starting with string, runing to, but
 *	not including end, all of which could be part of a string rep.
 *	of a double.  Only character identity is used, no actual
 *	parsing is done.
 *
 *	The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', 
 *	'.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x',  and 'X'.
 *	This covers the values "Inf" and "Nan" as well as the
 *	decimal and hexadecimal representations recognized by a
 *	C99-compliant strtod().
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseMaxDoubleLength(string, end)
    register CONST char *string;/* The string to examine. */
    CONST char *end;		/* Point to the first character past the end
				 * of the string we are examining. */
{
    CONST char *p = string;
    while (p < end) {
	switch (*p) {
	    case '0': case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9': case 'A': case 'B':
	    case 'C': case 'D': case 'E': case 'F': case 'I': case 'N':
	    case 'P': case 'X': case 'a': case 'b': case 'c': case 'd':
	    case 'e': case 'f': case 'i': case 'n': case 'p': case 'x':
	    case '.': case '+': case '-':
		p++;
		break;
	    default:
		goto done;
	}
    }
    done:
    return (p - string);
}

/*
 *----------------------------------------------------------------------
 *
 * PrependSubExprTokens --
 *
 *	This procedure is called after the operands of an subexpression have
 *	been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
 *	the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
 *	These two tokens are inserted before the operand tokens.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold the new tokens,
 *	additional space is malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
    CONST char *op;		/* Points to first byte of the operator
				 * in the source script. */
    int opBytes;		/* Number of bytes in the operator. */
    CONST char *src;		/* Points to first byte of the subexpression
				 * in the source script. */
    int srcBytes;		/* Number of bytes in subexpression's
				 * source. */
    int firstIndex;		/* Index of first token already emitted for
				 * operator's first (or only) operand. */
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Token *tokenPtr, *firstTokenPtr;
    int numToMove;

    if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
    tokenPtr = (firstTokenPtr + 2);
    numToMove = (parsePtr->numTokens - firstIndex);
    memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
            (size_t) (numToMove * sizeof(Tcl_Token)));
    parsePtr->numTokens += 2;
    
    tokenPtr = firstTokenPtr;
    tokenPtr->type = TCL_TOKEN_SUB_EXPR;
    tokenPtr->start = src;
    tokenPtr->size = srcBytes;
    tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1);
    
    tokenPtr++;
    tokenPtr->type = TCL_TOKEN_OPERATOR;
    tokenPtr->start = op;
    tokenPtr->size = opBytes;
    tokenPtr->numComponents = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * LogSyntaxError --
 *
 *	This procedure is invoked after an error occurs when parsing an
 *	expression. It sets the interpreter result to an error message
 *	describing the error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the interpreter result to an error message describing the
 *	expression that was being parsed when the error occurred, and why
 *	the parser considers that to be a syntax error at all.
 *
 *----------------------------------------------------------------------
 */

static void
LogSyntaxError(infoPtr, extraInfo)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
    CONST char *extraInfo;	/* String to provide extra information
				 * about the syntax error. */
{
    Tcl_Obj *result =
	    Tcl_NewStringObj("syntax error in expression \"", -1);
    TclAppendLimitedToObj(result, infoPtr->originalExpr, 
	    (int)(infoPtr->lastChar - infoPtr->originalExpr), 63, NULL);
    Tcl_AppendStringsToObj(result, "\": ", extraInfo, (char *) NULL);
    Tcl_SetObjResult(infoPtr->parsePtr->interp, result);
    infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
    infoPtr->parsePtr->term = infoPtr->start;
}















|
<











|
|









|




|






|
>
>
>
>
|



|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|









|
















>









>
|














|
>
|

|
|
|






|













|
|




|
|
|
|
|
|
|
|


|
|
<













<



|
|






|




>



>
|
>

>








|
|
|
|





<
|
<
<
<
|
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<


<
|
<
<
<
|















|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
>
|
|
|
|
>
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
|
|
<
<
<
<
|
|
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|





|
|



|
|
|














>
|
>
>



>
>
|


|


>
|
>
>


|



|


|



|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|
















|
|







|
|












|

|





|












|








|
|






|
|
|
|



|






>
>
>
>
>
>
>
>
1356
1357
1358
1359
1360
1361
1362
1363

1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463











































1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561

1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574

1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616

1617



1618


1619



1620



















1621













1622





1623
1624

1625



1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866








1867
1868




1869
1870
1871










1872






1873















1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934


1935
















































1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040

    case OPEN_BRACE:
	/*
	 * '{' string '}'
	 */

	code = Tcl_ParseBraces(interp, infoPtr->start,
		(infoPtr->lastChar - infoPtr->start), parsePtr, 1, &termPtr);

	if (code != TCL_OK) {
	    return code;
	}
	infoPtr->next = termPtr;

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = (termPtr - infoPtr->start);
	exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;

	/*
	 * If parsing the braced string resulted in more than one token,
	 * insert a TCL_TOKEN_WORD token before them. This indicates that the
	 * braced string represents a concatenation of multiple tokens.
	 */

	if (exprTokenPtr->numComponents > 1) {
	    if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
		TclExpandTokenArray(parsePtr);
	    }
	    tokenPtr = &parsePtr->tokenPtr[firstIndex];
	    numToMove = (parsePtr->numTokens - firstIndex);
	    memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
		    (size_t) (numToMove * sizeof(Tcl_Token)));
	    parsePtr->numTokens++;

	    exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	    exprTokenPtr->numComponents++;

	    tokenPtr->type = TCL_TOKEN_WORD;
	    tokenPtr->start = exprTokenPtr->start;
	    tokenPtr->size = exprTokenPtr->size;
	    tokenPtr->numComponents = exprTokenPtr->numComponents-1;
	}
	break;

    case STREQ:
    case STRNEQ:
    case IN_LIST:
    case NOT_IN_LIST:
    case FUNC_NAME: {
	/*
	 * math_func '(' expr {',' expr} ')'
	 */

	ParseInfo savedInfo = *infoPtr;

	code = GetLexeme(infoPtr);	/* skip over function name */
	if (code != TCL_OK) {
	    return code;
	}
	if (infoPtr->lexeme != OPEN_PAREN) {

	    int code;
	    Tcl_Obj *errMsg, *objPtr =
		    Tcl_NewStringObj(savedInfo.start, savedInfo.size);

	    /*
	     * Check for boolean literals (true, false, yes, no, on, off).
	     */

	    Tcl_IncrRefCount(objPtr);
	    code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType);
	    Tcl_DecrRefCount(objPtr);
	    if (code == TCL_OK) {
		*infoPtr = savedInfo;
		goto tokenizeLiteral;
	    }

	    /*
	     * Either there's a math function without a (, or a variable name
	     * without a '$'.
	     */

	    errMsg = Tcl_NewStringObj( "syntax error in expression \"", -1 );
	    TclAppendLimitedToObj(errMsg, infoPtr->originalExpr,
		    (int) (infoPtr->lastChar - infoPtr->originalExpr),
		    63, NULL);
	    Tcl_AppendToObj(errMsg, "\": the word \"", -1);
	    Tcl_AppendToObj(errMsg, savedInfo.start, savedInfo.size);
	    Tcl_AppendToObj(errMsg,
		    "\" requires a preceding $ if it's a variable ", -1);
	    Tcl_AppendToObj(errMsg,
		    "or function arguments if it's a function", -1);
	    Tcl_SetObjResult(infoPtr->parsePtr->interp, errMsg);
	    infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
	    infoPtr->parsePtr->term = infoPtr->start;
	    return TCL_ERROR;

	}

	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->type = TCL_TOKEN_OPERATOR;
	tokenPtr->start = savedInfo.start;
	tokenPtr->size = savedInfo.size;
	tokenPtr->numComponents = 0;
	parsePtr->numTokens++;












































	code = GetLexeme(infoPtr);	/* skip over '(' */
	if (code != TCL_OK) {
	    return code;
	}

	while (infoPtr->lexeme != CLOSE_PAREN) {
	    code = ParseCondExpr(infoPtr);
	    if (code != TCL_OK) {
		return code;
	    }

	    if (infoPtr->lexeme == COMMA) {
		code = GetLexeme(infoPtr); /* skip over , */
		if (code != TCL_OK) {
		    return code;
		}
	    } else if (infoPtr->lexeme != CLOSE_PAREN) {
		LogSyntaxError(infoPtr,
			"missing close parenthesis at end of function call");
		return TCL_ERROR;
	    }
	}

	exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
	exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
	exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
	break;
    }

    case COMMA:
	LogSyntaxError(infoPtr,
		"commas can only separate function arguments");
	return TCL_ERROR;
    case END:
	LogSyntaxError(infoPtr, "premature end of expression");
	return TCL_ERROR;
    case UNKNOWN:
	LogSyntaxError(infoPtr,
		"single equality character not legal in expressions");
	return TCL_ERROR;
    case UNKNOWN_CHAR:
	LogSyntaxError(infoPtr, "character not legal in expressions");
	return TCL_ERROR;
    case QUESTY:
	LogSyntaxError(infoPtr, "unexpected ternary 'then' separator");
	return TCL_ERROR;
    case COLON:
	LogSyntaxError(infoPtr, "unexpected ternary 'else' separator");
	return TCL_ERROR;
    case CLOSE_PAREN:
	LogSyntaxError(infoPtr, "unexpected close parenthesis");
	return TCL_ERROR;

    default:
	{
	    char buf[64];

	    sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]);
	    LogSyntaxError(infoPtr, buf);
	    return TCL_ERROR;
	}
    }

    /*
     * Advance to the next lexeme before returning.
     */

    code = GetLexeme(infoPtr);
    if (code != TCL_OK) {
	return code;
    }
    parsePtr->term = infoPtr->next;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetLexeme --
 *
 *	Lexical scanner for Tcl expressions: scans a single operator or other
 *	syntactic element from an expression string.
 *
 * Results:
 *	TCL_OK is returned unless an error occurred. In that case a standard
 *	Tcl error code is returned and, if infoPtr->parsePtr->interp is
 *	non-NULL, the interpreter's result is set to hold an error message.
 *	TCL_ERROR is returned if an integer overflow, or a floating-point
 *	overflow or underflow occurred while reading in a number. If the
 *	lexical analysis is successful, infoPtr->lexeme refers to the next
 *	symbol in the expression string, and infoPtr->next is advanced past
 *	the lexeme. Also, if the lexeme is a LITERAL or FUNC_NAME, then
 *	infoPtr->start is set to the first character of the lexeme; otherwise
 *	it is set NULL.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold all the information
 *	about the subexpression, then additional space is malloc-ed..

 *
 *----------------------------------------------------------------------
 */

static int
GetLexeme(infoPtr)
    ParseInfo *infoPtr;		/* Holds state needed to parse the expr,
				 * including the resulting lexeme. */
{
    register CONST char *src;	/* Points to current source char. */
    char c;
    int offset, length, numBytes;
    Tcl_Parse *parsePtr = infoPtr->parsePtr;

    Tcl_UniChar ch;

    /*
     * Record where the previous lexeme ended. Since we always read one lexeme
     * ahead during parsing, this helps us know the source length of
     * subexpression tokens.
     */

    infoPtr->prevEnd = infoPtr->next;

    /*
     * Scan over leading white space at the start of a lexeme.
     */

    src = infoPtr->next;
    numBytes = parsePtr->end - src;

    do {
	char type;
	int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);

	src += scanned;
	numBytes -= scanned;
    } while  (numBytes && (*src == '\n') && (src++,numBytes--));

    parsePtr->term = src;
    if (numBytes == 0) {
	infoPtr->lexeme = END;
	infoPtr->next = src;
	return TCL_OK;
    }

    /*
     * Try to parse the lexeme first as an integer or floating-point number.
     * Don't check for a number if the first character c is "+" or "-". If we
     * did, we might treat a binary operator as unary by mistake, which would
     * eventually cause a syntax error.
     */

    c = *src;
    if ((c != '+') && (c != '-')) {
	CONST char *end = infoPtr->lastChar;

	CONST char* end2;



	int code = TclParseNumber(NULL, NULL, NULL,


				  src, (unsigned)(end-src), &end2, 0);



	if ( code == TCL_OK ) {



















	    length = end2-src;













	    if ( length > 0 ) {





		infoPtr->lexeme = LITERAL;
		infoPtr->start = src;

		infoPtr->size = length;



		infoPtr->next = (src + length);
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    }
	}
    }

    /*
     * Not an integer or double literal. Initialize the lexeme's fields
     * assuming the common case of a single character lexeme.
     */

    infoPtr->start = src;
    infoPtr->size = 1;
    infoPtr->next = src+1;
    parsePtr->term = infoPtr->next;

    switch (*src) {
    case '[':
	infoPtr->lexeme = OPEN_BRACKET;
	return TCL_OK;

    case '{':
	infoPtr->lexeme = OPEN_BRACE;
	return TCL_OK;

    case '(':
	infoPtr->lexeme = OPEN_PAREN;
	return TCL_OK;

    case ')':
	infoPtr->lexeme = CLOSE_PAREN;
	return TCL_OK;

    case '$':
	infoPtr->lexeme = DOLLAR;
	return TCL_OK;

    case '\"':
	infoPtr->lexeme = QUOTE;
	return TCL_OK;

    case ',':
	infoPtr->lexeme = COMMA;
	return TCL_OK;

    case '*':
	infoPtr->lexeme = MULT;
	if ((infoPtr->lastChar - src)>1  &&  src[1]=='*') {
	    infoPtr->lexeme = EXPON;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	    parsePtr->term = infoPtr->next;
	}
	return TCL_OK;

    case '/':
	infoPtr->lexeme = DIVIDE;
	return TCL_OK;

    case '%':
	infoPtr->lexeme = MOD;
	return TCL_OK;

    case '+':
	infoPtr->lexeme = PLUS;
	return TCL_OK;

    case '-':
	infoPtr->lexeme = MINUS;
	return TCL_OK;

    case '?':
	infoPtr->lexeme = QUESTY;
	return TCL_OK;

    case ':':
	infoPtr->lexeme = COLON;
	return TCL_OK;

    case '<':
	infoPtr->lexeme = LESS;
	if ((infoPtr->lastChar - src) > 1) {
	    switch (src[1]) {
	    case '<':
		infoPtr->lexeme = LEFT_SHIFT;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		break;
	    case '=':
		infoPtr->lexeme = LEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		break;
	    }
	}
	parsePtr->term = infoPtr->next;
	return TCL_OK;

    case '>':
	infoPtr->lexeme = GREATER;
	if ((infoPtr->lastChar - src) > 1) {
	    switch (src[1]) {
	    case '>':
		infoPtr->lexeme = RIGHT_SHIFT;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		break;
	    case '=':
		infoPtr->lexeme = GEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		break;
	    }
	}
	parsePtr->term = infoPtr->next;
	return TCL_OK;

    case '=':
	infoPtr->lexeme = UNKNOWN;
	if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
	    infoPtr->lexeme = EQUAL;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	}
	parsePtr->term = infoPtr->next;
	return TCL_OK;

    case '!':
	infoPtr->lexeme = NOT;
	if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
	    infoPtr->lexeme = NEQ;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	}
	parsePtr->term = infoPtr->next;
	return TCL_OK;

    case '&':
	infoPtr->lexeme = BIT_AND;
	if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) {
	    infoPtr->lexeme = AND;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	}
	parsePtr->term = infoPtr->next;
	return TCL_OK;

    case '^':
	infoPtr->lexeme = BIT_XOR;
	return TCL_OK;

    case '|':
	infoPtr->lexeme = BIT_OR;
	if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) {
	    infoPtr->lexeme = OR;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	}
	parsePtr->term = infoPtr->next;
	return TCL_OK;

    case '~':
	infoPtr->lexeme = BIT_NOT;
	return TCL_OK;

    case 'e':
	if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) &&
		(infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
	    infoPtr->lexeme = STREQ;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;
	} else {
	    goto checkFuncName;
	}

    case 'n':
	if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) &&
		(infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
	    infoPtr->lexeme = STRNEQ;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;
	} else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) &&
		(infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
	    infoPtr->lexeme = NOT_IN_LIST;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;
	} else {
	    goto checkFuncName;
	}

    case 'i':
	if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) &&
		(infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
	    infoPtr->lexeme = IN_LIST;
	    infoPtr->size = 2;
	    infoPtr->next = src+2;
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;
	} else {
	    goto checkFuncName;
	}

    default:
    checkFuncName:
	length = (infoPtr->lastChar - src);
	if (Tcl_UtfCharComplete(src, length)) {
	    offset = Tcl_UtfToUniChar(src, &ch);
	} else {
	    char utfBytes[TCL_UTF_MAX];

	    memcpy(utfBytes, src, (size_t) length);
	    utfBytes[length] = '\0';
	    offset = Tcl_UtfToUniChar(utfBytes, &ch);
	}
	c = UCHAR(ch);
	if (isalpha(UCHAR(c))) {			/* INTL: ISO only. */
	    infoPtr->lexeme = FUNC_NAME;
	    while (isalnum(UCHAR(c)) || (c == '_')) {	/* INTL: ISO only. */
		src += offset;
		length -= offset;
		if (Tcl_UtfCharComplete(src, length)) {
		    offset = Tcl_UtfToUniChar(src, &ch);
		} else {
		    char utfBytes[TCL_UTF_MAX];

		    memcpy(utfBytes, src, (size_t) length);
		    utfBytes[length] = '\0';
		    offset = Tcl_UtfToUniChar(utfBytes, &ch);
		}
		c = UCHAR(ch);
	    }
	    infoPtr->size = (src - infoPtr->start);
	    infoPtr->next = src;
	    parsePtr->term = infoPtr->next;








	    return TCL_OK;
	}




	infoPtr->lexeme = UNKNOWN_CHAR;
	return TCL_OK;
    }










}






















#if 0
/*
 *----------------------------------------------------------------------
 *
 * TclParseInteger --
 *
 *	Scans up to numBytes bytes starting at src, and checks whether the
 *	leading bytes look like an integer's string representation.
 *
 * Results:
 *	Returns 0 if the leading bytes do not look like an integer.
 *	Otherwise, returns the number of bytes examined that look like an
 *	integer.  This may be less than numBytes if the integer is only the
 *	leading part of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseInteger(string, numBytes)
    register CONST char *string;/* The string to examine. */
    register int numBytes;	/* Max number of bytes to scan. */
{
    register CONST char *p = string;

    /*
     * Take care of introductory "0x".
     */

    if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
	int scanned;
	Tcl_UniChar ch;

	p += 2;
	numBytes -= 2;
 	scanned = TclParseHex(p, numBytes, &ch);
	if (scanned) {
	    return scanned+2;
	}

	/*
	 * Recognize the 0 as valid integer, but x is left behind.
	 */

	return 1;
    }
    while (numBytes && isdigit(UCHAR(*p))) {		/* INTL: digit */
	numBytes--; p++;
    }
    if (numBytes == 0) {
	return (p - string);
    }
    if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
	return (p - string);
    }
    return 0;
}
#endif



















































/*
 *----------------------------------------------------------------------
 *
 * PrependSubExprTokens --
 *
 *	This function is called after the operands of an subexpression have
 *	been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
 *	the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
 *	These two tokens are inserted before the operand tokens.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold the new tokens,
 *	additional space is malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
    CONST char *op;		/* Points to first byte of the operator in the
				 * source script. */
    int opBytes;		/* Number of bytes in the operator. */
    CONST char *src;		/* Points to first byte of the subexpression
				 * in the source script. */
    int srcBytes;		/* Number of bytes in subexpression's
				 * source. */
    int firstIndex;		/* Index of first token already emitted for
				 * operator's first (or only) operand. */
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Token *tokenPtr, *firstTokenPtr;
    int numToMove;

    if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
    tokenPtr = (firstTokenPtr + 2);
    numToMove = (parsePtr->numTokens - firstIndex);
    memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
	    (size_t) (numToMove * sizeof(Tcl_Token)));
    parsePtr->numTokens += 2;

    tokenPtr = firstTokenPtr;
    tokenPtr->type = TCL_TOKEN_SUB_EXPR;
    tokenPtr->start = src;
    tokenPtr->size = srcBytes;
    tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1);

    tokenPtr++;
    tokenPtr->type = TCL_TOKEN_OPERATOR;
    tokenPtr->start = op;
    tokenPtr->size = opBytes;
    tokenPtr->numComponents = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * LogSyntaxError --
 *
 *	This function is invoked after an error occurs when parsing an
 *	expression. It sets the interpreter result to an error message
 *	describing the error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the interpreter result to an error message describing the
 *	expression that was being parsed when the error occurred, and why the
 *	parser considers that to be a syntax error at all.
 *
 *----------------------------------------------------------------------
 */

static void
LogSyntaxError(infoPtr, extraInfo)
    ParseInfo *infoPtr;		/* Holds the parse state for the expression
				 * being parsed. */
    CONST char *extraInfo;	/* String to provide extra information about
				 * the syntax error. */
{
    Tcl_Obj *result =
	    Tcl_NewStringObj("syntax error in expression \"", -1);
    TclAppendLimitedToObj(result, infoPtr->originalExpr,
	    (int)(infoPtr->lastChar - infoPtr->originalExpr), 63, NULL);
    Tcl_AppendStringsToObj(result, "\": ", extraInfo, (char *) NULL);
    Tcl_SetObjResult(infoPtr->parsePtr->interp, result);
    infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
    infoPtr->parsePtr->term = infoPtr->start;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPathObj.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223

224


225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240


241


242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267

268
269
270
271
272
273
274
275
276
277


278


279
280
281
282
283
284
285
286
287
288
289
290


291


292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
/* 
 * tclPathObj.c --
 *
 *	This file contains the implementation of Tcl's "path" object
 *	type used to represent and manipulate a general (virtual)
 *	filesystem entity in an efficient manner.
 *
 * Copyright (c) 2003 Vince Darley.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPathObj.c,v 1.38 2004/11/22 12:53:06 vincentdarley Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

/*
 * Prototypes for procedures defined later in this file.
 */

static void	DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
		    Tcl_Obj *copyPtr));
static void	FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr));
static void	UpdateStringOfFsPath  _ANSI_ARGS_((Tcl_Obj *pathPtr));
static int	SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *pathPtr));
static int	FindSplitPos _ANSI_ARGS_((CONST char *path, int separator));
static int      IsSeparatorOrNull _ANSI_ARGS_((int ch));
static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr));

/*
 * Define the 'path' object type, which Tcl uses to represent
 * file paths internally.
 */

Tcl_ObjType tclFsPathType = {
    "path",				/* name */
    FreeFsPathInternalRep,		/* freeIntRepProc */
    DupFsPathInternalRep,	        /* dupIntRepProc */
    UpdateStringOfFsPath,		/* updateStringProc */
    SetFsPathFromAny			/* setFromAnyProc */
};

/* 
 * struct FsPath --
 * 
 * Internal representation of a Tcl_Obj of "path" type.  This
 * can be used to represent relative or absolute paths, and has
 * certain optimisations when used to represent paths which are
 * already normalized and absolute.
 * 
 * Note that both 'translatedPathPtr' and 'normPathPtr' can be a
 * circular reference to the container Tcl_Obj of this FsPath.
 * 
 * There are two cases, with the first being the most common:
 * 
 * (i) flags == 0, => Ordinary path.  
 * 
 * translatedPathPtr contains the translated path (which may be
 * a circular reference to the object itself).  If it is NULL
 * then the path is pure normalized (and the normPathPtr will be
 * a circular reference).  cwdPtr is null for an absolute path,
 * and non-null for a relative path (unless the cwd has never been
 * set, in which case the cwdPtr may also be null for a relative path).

 * 
 * (ii) flags != 0, => Special path, see TclNewFSPathObj
 * 
 * Now, this is a path like 'file join $dir $tail' where, cwdPtr is
 * the $dir and normPathPtr is the $tail.
 * 
 */

typedef struct FsPath {
    Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
				 * If this is NULL, then this is a 
				 * pure normalized, absolute path
				 * object, in which the parent Tcl_Obj's
				 * string rep is already both translated
				 * and normalized. */
    Tcl_Obj *normPathPtr;       /* Normalized absolute path, without 
				 * ., .. or ~user sequences. If the 
				 * Tcl_Obj containing 
				 * this FsPath is already normalized, 
				 * this may be a circular reference back
				 * to the container.  If that is NOT the
				 * case, we have a refCount on the object. */
    Tcl_Obj *cwdPtr;            /* If null, path is absolute, else
				 * this points to the cwd object used
				 * for this path.  We have a refCount
				 * on the object. */
    int flags;                  /* Flags to describe interpretation -
                                 * see below. */
    ClientData nativePathPtr;   /* Native representation of this path,
				 * which is filesystem dependent. */
    int filesystemEpoch;        /* Used to ensure the path representation
				 * was generated during the correct
				 * filesystem epoch.  The epoch changes
				 * when filesystem-mounts are changed. */ 
    struct FilesystemRecord *fsRecPtr;
				/* Pointer to the filesystem record 
				 * entry to use for this path. */
} FsPath;

/*
 * Flag values for FsPath->flags.
 */

#define TCLPATH_APPENDED 1

/* 
 * Define some macros to give us convenient access to path-object
 * specific fields.
 */

#define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr)
#define PATHFLAGS(pathPtr) \
	(((FsPath*)(pathPtr->internalRep.otherValuePtr))->flags)


/*
 *---------------------------------------------------------------------------
 *
 * TclFSNormalizeAbsolutePath --
 *
 * Description:
 *	Takes an absolute path specification and computes a 'normalized'
 *	path from it.
 *	
 *	A normalized path is one which has all '../', './' removed.
 *	Also it is one which is in the 'standard' format for the native
 *	platform.  On Unix, this means the path must be free of
 *	symbolic links/aliases, and on Windows it means we want the
 *	long form, with that long form's case-dependence (which gives
 *	us a unique, case-dependent path).
 *	
 *	The behaviour of this function if passed a non-absolute path
 *	is NOT defined.
 *	
 *	pathPtr may have a refCount of zero, or may be a shared
 *	object.
 *
 * Results:
 *	The result is returned in a Tcl_Obj with a refCount of 1,
 *	which is therefore owned by the caller.  It must be
 *	freed (with Tcl_DecrRefCount) by the caller when no longer needed.
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special note:
 *	This code was originally based on code from Matt Newman and
 *	Jean-Claude Wippler, but has since been totally rewritten by
 *	Vince Darley to deal with symbolic links.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
    Tcl_Interp* interp;        /* Interpreter to use */
    Tcl_Obj *pathPtr;          /* Absolute path to normalize */
    ClientData *clientDataPtr; /* If non-NULL, then may be set to the
                                * fs-specific clientData for this path.
                                * This will happen when that extra
                                * information can be calculated efficiently
                                * as a side-effect of normalization. */
{
    ClientData clientData = NULL;
    CONST char *dirSep, *oldDirSep;
    int first = 1;   /* Set to zero once we've passed the first
                      * directory separator - we can't use '..' to 
                      * remove the volume in a path. */
    Tcl_Obj *retVal = NULL;
    dirSep = TclGetString(pathPtr);
    
    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
        if (dirSep[0] != 0 && dirSep[1] == ':' && 
	    (dirSep[2] == '/' || dirSep[2] == '\\')) {
	    /* Do nothing */
	} else if ((dirSep[0] == '/' || dirSep[0] == '\\') 
	    && (dirSep[1] == '/' || dirSep[1] == '\\')) {
	    /* 
	     * UNC style path, where we must skip over the
	     * first separator, since the first two segments
	     * are actually inseparable.
	     */

	    dirSep += 2;
	    dirSep += FindSplitPos(dirSep, '/');
	    if (*dirSep != 0) {
	        dirSep++;
	    }
	}
    }
    
    /* 
     * Scan forward from one directory separator to the next,
     * checking for '..' and '.' sequences which must be handled
     * specially.  In particular handling of '..' can be complicated
     * if the directory before is a link, since we will have to
     * expand the link to be able to back up one level.
     */

    while (*dirSep != 0) {
	oldDirSep = dirSep;
	if (!first) {
	    dirSep++;
	}
        dirSep += FindSplitPos(dirSep, '/');
	if (dirSep[0] == 0 || dirSep[1] == 0) {
	    if (retVal != NULL) {
		Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
	    }
	    break;
	}
	if (dirSep[1] == '.') {
	    if (retVal != NULL) {
		Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
		oldDirSep = dirSep;
	    }
	  again:
	    if (IsSeparatorOrNull(dirSep[2])) {

		/* Need to skip '.' in the path */


		if (retVal == NULL) {
		    CONST char *path = TclGetString(pathPtr);
		    retVal = Tcl_NewStringObj(path, dirSep - path);
		    Tcl_IncrRefCount(retVal);
		}
		dirSep += 2;
		oldDirSep = dirSep;
		if (dirSep[0] != 0 && dirSep[1] == '.') {
		    goto again;
		}
		continue;
	    }
	    if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
		Tcl_Obj *link;
		int curLen;
		char *linkStr;


		/* Have '..' so need to skip previous directory */


		if (retVal == NULL) {
		    CONST char *path = TclGetString(pathPtr);
		    retVal = Tcl_NewStringObj(path, dirSep - path);
		    Tcl_IncrRefCount(retVal);
		}
		if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
		    link = Tcl_FSLink(retVal, NULL, 0);
		    if (link != NULL) {
			/* 
			 * Got a link.  Need to check if the link
			 * is relative or absolute, for those platforms
			 * where relative links exist.
			 */

			if (tclPlatform != TCL_PLATFORM_WINDOWS &&
				Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) {

			    /* 
			     * We need to follow this link which is
			     * relative to retVal's directory.  This
			     * means concatenating the link onto
			     * the directory of the path so far.
			     */

			    CONST char *path =
				    Tcl_GetStringFromObj(retVal, &curLen);

			    while (--curLen >= 0) {
			        if (IsSeparatorOrNull(path[curLen])) {
			            break;
			        }
			    }
			    if (Tcl_IsShared(retVal)) {
				TclDecrRefCount(retVal);
				retVal = Tcl_DuplicateObj(retVal);
				Tcl_IncrRefCount(retVal);
			    }


			    /* We want the trailing slash */


			    Tcl_SetObjLength(retVal, curLen+1);
			    Tcl_AppendObjToObj(retVal, link);
			    TclDecrRefCount(link);
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);
			} else {
			    /*
			     * Absolute link.
			     */

			    TclDecrRefCount(retVal);
			    retVal = link;
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);


			    /* Convert to forward-slashes on windows */


			    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
				int i;
				for (i = 0; i < curLen; i++) {
				    if (linkStr[i] == '\\') {
					linkStr[i] = '/';
				    }
				}
			    }
			}
		    } else {
			linkStr = Tcl_GetStringFromObj(retVal, &curLen);
		    }

		    /*
		     * Either way, we now remove the last path element
		     */

		    while (--curLen >= 0) {
			if (IsSeparatorOrNull(linkStr[curLen])) {
			    Tcl_SetObjLength(retVal, curLen);
			    break;
			}
|


|
|
|



|
|

|






|









|



|
|





|




|

|
|
|
<
|
|
|
|
|

|
|
|
|
|
|
<
|
|
>
|

|
|
|
|



|
|
<
|
|
|
|
|
<
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|

|
|








|
|
|












<
|
|
|
|
|
|
<
|
|
|
|
|
|
|
<


|
|
|






|
|






|
|
|
|
|
|
|



|
|
|


|

|
|

|
|
|
|
<
|

>



|



|
|
|
|
|
<
|







|











|

>
|
>
>
















>
>
|
>
>








|
|
|
|




<
|
|
|
<
|




>

|
|
|






>
>
|
>
>












>
>
|
>
>














|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78
79
80
81

82
83
84
85
86
87
88

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

123
124
125
126
127
128

129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178

179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256

257
258
259

260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
/*
 * tclPathObj.c --
 *
 *	This file contains the implementation of Tcl's "path" object type used
 *	to represent and manipulate a general (virtual) filesystem entity in
 *	an efficient manner.
 *
 * Copyright (c) 2003 Vince Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPathObj.c,v 1.38.2.5 2005/08/15 18:13:59 dgp Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

/*
 * Prototypes for functions defined later in this file.
 */

static void	DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
		    Tcl_Obj *copyPtr));
static void	FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr));
static void	UpdateStringOfFsPath  _ANSI_ARGS_((Tcl_Obj *pathPtr));
static int	SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *pathPtr));
static int	FindSplitPos _ANSI_ARGS_((CONST char *path, int separator));
static int	IsSeparatorOrNull _ANSI_ARGS_((int ch));
static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr));

/*
 * Define the 'path' object type, which Tcl uses to represent file paths
 * internally.
 */

Tcl_ObjType tclFsPathType = {
    "path",				/* name */
    FreeFsPathInternalRep,		/* freeIntRepProc */
    DupFsPathInternalRep,		/* dupIntRepProc */
    UpdateStringOfFsPath,		/* updateStringProc */
    SetFsPathFromAny			/* setFromAnyProc */
};

/*
 * struct FsPath --
 *
 * Internal representation of a Tcl_Obj of "path" type.  This can be used to
 * represent relative or absolute paths, and has certain optimisations when

 * used to represent paths which are already normalized and absolute.
 *
 * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular
 * reference to the container Tcl_Obj of this FsPath.
 *
 * There are two cases, with the first being the most common:
 *
 * (i) flags == 0, => Ordinary path.
 *
 * translatedPathPtr contains the translated path (which may be a circular
 * reference to the object itself).  If it is NULL then the path is pure
 * normalized (and the normPathPtr will be a circular reference).  cwdPtr is

 * null for an absolute path, and non-null for a relative path (unless the cwd
 * has never been set, in which case the cwdPtr may also be null for a
 * relative path).
 *
 * (ii) flags != 0, => Special path, see TclNewFSPathObj
 *
 * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir
 * and normPathPtr is the $tail.
 *
 */

typedef struct FsPath {
    Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.  If this
				 * is NULL, then this is a pure normalized,

				 * absolute path object, in which the parent
				 * Tcl_Obj's string rep is already both
				 * translated and normalized. */
    Tcl_Obj *normPathPtr;	/* Normalized absolute path, without ., .. or
				 * ~user sequences. If the Tcl_Obj containing

				 * this FsPath is already normalized, this may
				 * be a circular reference back to the
				 * container. If that is NOT the case, we have
				 * a refCount on the object. */
    Tcl_Obj *cwdPtr;		/* If null, path is absolute, else this points
				 * to the cwd object used for this path.  We
				 * have a refCount on the object. */

    int flags;			/* Flags to describe interpretation - see
				 * below. */
    ClientData nativePathPtr;   /* Native representation of this path, which
				 * is filesystem dependent. */
    int filesystemEpoch;	/* Used to ensure the path representation was
				 * generated during the correct filesystem
				 * epoch. The epoch changes when
				 * filesystem-mounts are changed. */
    struct FilesystemRecord *fsRecPtr;
				/* Pointer to the filesystem record entry to
				 * use for this path. */
} FsPath;

/*
 * Flag values for FsPath->flags.
 */

#define TCLPATH_APPENDED 1

/*
 * Define some macros to give us convenient access to path-object specific
 * fields.
 */

#define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr)
#define PATHFLAGS(pathPtr) \
	(((FsPath*)(pathPtr->internalRep.otherValuePtr))->flags)


/*
 *---------------------------------------------------------------------------
 *
 * TclFSNormalizeAbsolutePath --
 *

 *	Takes an absolute path specification and computes a 'normalized' path
 *	from it.
 *
 *	A normalized path is one which has all '../', './' removed.  Also it
 *	is one which is in the 'standard' format for the native platform.  On
 *	Unix, this means the path must be free of symbolic links/aliases, and

 *	on Windows it means we want the long form, with that long form's
 *	case-dependence (which gives us a unique, case-dependent path).
 *
 *	The behaviour of this function if passed a non-absolute path is NOT
 *	defined.
 *
 *	pathPtr may have a refCount of zero, or may be a shared object.

 *
 * Results:
 *	The result is returned in a Tcl_Obj with a refCount of 1, which is
 *	therefore owned by the caller. It must be freed (with
 *	Tcl_DecrRefCount) by the caller when no longer needed.
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special note:
 *	This code was originally based on code from Matt Newman and
 *	Jean-Claude Wippler, but has since been totally rewritten by Vince
 *	Darley to deal with symbolic links.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
    Tcl_Interp* interp;		/* Interpreter to use */
    Tcl_Obj *pathPtr;		/* Absolute path to normalize */
    ClientData *clientDataPtr;	/* If non-NULL, then may be set to the
				 * fs-specific clientData for this path.  This
				 * will happen when that extra information can
				 * be calculated efficiently as a side-effect
				 * of normalization. */
{
    ClientData clientData = NULL;
    CONST char *dirSep, *oldDirSep;
    int first = 1;		/* Set to zero once we've passed the first
				 * directory separator - we can't use '..' to
				 * remove the volume in a path. */
    Tcl_Obj *retVal = NULL;
    dirSep = TclGetString(pathPtr);

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	if (dirSep[0] != 0 && dirSep[1] == ':' &&
		(dirSep[2] == '/' || dirSep[2] == '\\')) {
	    /* Do nothing */
	} else if ((dirSep[0] == '/' || dirSep[0] == '\\')
		&& (dirSep[1] == '/' || dirSep[1] == '\\')) {
	    /*
	     * UNC style path, where we must skip over the first separator,

	     * since the first two segments are actually inseparable.
	     */

	    dirSep += 2;
	    dirSep += FindSplitPos(dirSep, '/');
	    if (*dirSep != 0) {
		dirSep++;
	    }
	}
    }

    /*
     * Scan forward from one directory separator to the next, checking for
     * '..' and '.' sequences which must be handled specially.  In particular
     * handling of '..' can be complicated if the directory before is a link,

     * since we will have to expand the link to be able to back up one level.
     */

    while (*dirSep != 0) {
	oldDirSep = dirSep;
	if (!first) {
	    dirSep++;
	}
	dirSep += FindSplitPos(dirSep, '/');
	if (dirSep[0] == 0 || dirSep[1] == 0) {
	    if (retVal != NULL) {
		Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
	    }
	    break;
	}
	if (dirSep[1] == '.') {
	    if (retVal != NULL) {
		Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
		oldDirSep = dirSep;
	    }
	again:
	    if (IsSeparatorOrNull(dirSep[2])) {
		/*
		 * Need to skip '.' in the path.
		 */

		if (retVal == NULL) {
		    CONST char *path = TclGetString(pathPtr);
		    retVal = Tcl_NewStringObj(path, dirSep - path);
		    Tcl_IncrRefCount(retVal);
		}
		dirSep += 2;
		oldDirSep = dirSep;
		if (dirSep[0] != 0 && dirSep[1] == '.') {
		    goto again;
		}
		continue;
	    }
	    if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
		Tcl_Obj *link;
		int curLen;
		char *linkStr;

		/*
		 * Have '..' so need to skip previous directory.
		 */

		if (retVal == NULL) {
		    CONST char *path = TclGetString(pathPtr);
		    retVal = Tcl_NewStringObj(path, dirSep - path);
		    Tcl_IncrRefCount(retVal);
		}
		if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
		    link = Tcl_FSLink(retVal, NULL, 0);
		    if (link != NULL) {
			/*
			 * Got a link. Need to check if the link is relative
			 * or absolute, for those platforms where relative
			 * links exist.
			 */

			if (tclPlatform != TCL_PLATFORM_WINDOWS &&
				Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) {

			    /*
			     * We need to follow this link which is relative
			     * to retVal's directory. This means concatenating

			     * the link onto the directory of the path so far.
			     */

			    CONST char *path =
				    Tcl_GetStringFromObj(retVal, &curLen);

			    while (--curLen >= 0) {
				if (IsSeparatorOrNull(path[curLen])) {
				    break;
				}
			    }
			    if (Tcl_IsShared(retVal)) {
				TclDecrRefCount(retVal);
				retVal = Tcl_DuplicateObj(retVal);
				Tcl_IncrRefCount(retVal);
			    }

			    /*
			     * We want the trailing slash.
			     */

			    Tcl_SetObjLength(retVal, curLen+1);
			    Tcl_AppendObjToObj(retVal, link);
			    TclDecrRefCount(link);
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);
			} else {
			    /*
			     * Absolute link.
			     */

			    TclDecrRefCount(retVal);
			    retVal = link;
			    linkStr = Tcl_GetStringFromObj(retVal, &curLen);

			    /*
			     * Convert to forward-slashes on windows.
			     */

			    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
				int i;
				for (i = 0; i < curLen; i++) {
				    if (linkStr[i] == '\\') {
					linkStr[i] = '/';
				    }
				}
			    }
			}
		    } else {
			linkStr = Tcl_GetStringFromObj(retVal, &curLen);
		    }

		    /*
		     * Either way, we now remove the last path element.
		     */

		    while (--curLen >= 0) {
			if (IsSeparatorOrNull(linkStr[curLen])) {
			    Tcl_SetObjLength(retVal, curLen);
			    break;
			}
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349

350
351
352
353
354
355
356
357
358
359
360
361
362

363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396


397


398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
	    }
	}
	first = 0;
	if (retVal != NULL) {
	    Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
	}
    }
    
    /* 
     * If we didn't make any changes, just use the input path 
     */

    if (retVal == NULL) {
	retVal = pathPtr;
	Tcl_IncrRefCount(retVal);
	
	if (Tcl_IsShared(retVal)) {
	    /* 
	     * Unfortunately, the platform-specific normalization code
	     * which will be called below has no way of dealing with the
	     * case where an object is shared.  It is expecting to
	     * modify an object in place.  So, we must duplicate this
	     * here to ensure an object with a single ref-count.
	     * 
	     * If that changes in the future (e.g. the normalize proc is
	     * given one object and is able to return a different one),
	     * then we could remove this code.
	     */

	    TclDecrRefCount(retVal);
	    retVal = Tcl_DuplicateObj(pathPtr);
	    Tcl_IncrRefCount(retVal);
	}
    }

    /* 
     * Ensure a windows drive like C:/ has a trailing separator 
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	int len;
	CONST char *path = Tcl_GetStringFromObj(retVal, &len);

	if (len == 2 && path[0] != 0 && path[1] == ':') {
	    if (Tcl_IsShared(retVal)) {
		TclDecrRefCount(retVal);
		retVal = Tcl_DuplicateObj(retVal);
		Tcl_IncrRefCount(retVal);
	    }
	    Tcl_AppendToObj(retVal, "/", 1);
	}
    }

    /* 
     * Now we have an absolute path, with no '..', '.' sequences,
     * but it still may not be in 'unique' form, depending on the
     * platform.  For instance, Unix is case-sensitive, so the
     * path is ok.  Windows is case-insensitive, and also has the
     * weird 'longname/shortname' thing (e.g. C:/Program Files/ and
     * C:/Progra~1/ are equivalent).
     * 
     * Virtual file systems which may be registered may have
     * other criteria for normalizing a path.
     */

    TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData);

    /* 
     * Since we know it is a normalized path, we can
     * actually convert this object into an FsPath for
     * greater efficiency 
     */

    TclFSMakePathFromNormalized(interp, retVal, clientData);
    if (clientDataPtr != NULL) {
	*clientDataPtr = clientData;
    }


    /* This has a refCount of 1 for the caller */


    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetPathType --
 *
 *	Determines whether a given path is relative to the current
 *	directory, relative to the current volume, or absolute.  
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.
 *
 * Side effects:
 *	None.







|
|
|





|

|
|
|
|
|
|
|
|
|
|

>






|
|





>










|
|
|
|
<
|
|
|
|
|




|
|
|
<






>
>
|
>
>








|
|







328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384

385
386
387
388
389
390
391
392
393
394
395
396

397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
	    }
	}
	first = 0;
	if (retVal != NULL) {
	    Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
	}
    }

    /*
     * If we didn't make any changes, just use the input path.
     */

    if (retVal == NULL) {
	retVal = pathPtr;
	Tcl_IncrRefCount(retVal);

	if (Tcl_IsShared(retVal)) {
	    /*
	     * Unfortunately, the platform-specific normalization code which
	     * will be called below has no way of dealing with the case where
	     * an object is shared.  It is expecting to modify an object in
	     * place.  So, we must duplicate this here to ensure an object
	     * with a single ref-count.
	     *
	     * If that changes in the future (e.g. the normalize proc is given
	     * one object and is able to return a different one), then we
	     * could remove this code.
	     */

	    TclDecrRefCount(retVal);
	    retVal = Tcl_DuplicateObj(pathPtr);
	    Tcl_IncrRefCount(retVal);
	}
    }

    /*
     * Ensure a windows drive like C:/ has a trailing separator
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
	int len;
	CONST char *path = Tcl_GetStringFromObj(retVal, &len);

	if (len == 2 && path[0] != 0 && path[1] == ':') {
	    if (Tcl_IsShared(retVal)) {
		TclDecrRefCount(retVal);
		retVal = Tcl_DuplicateObj(retVal);
		Tcl_IncrRefCount(retVal);
	    }
	    Tcl_AppendToObj(retVal, "/", 1);
	}
    }

    /*
     * Now we have an absolute path, with no '..', '.' sequences, but it still
     * may not be in 'unique' form, depending on the platform.  For instance,
     * Unix is case-sensitive, so the path is ok. Windows is case-insensitive,

     * and also has the weird 'longname/shortname' thing (e.g. C:/Program
     * Files/ and C:/Progra~1/ are equivalent).
     *
     * Virtual file systems which may be registered may have other criteria
     * for normalizing a path.
     */

    TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData);

    /*
     * Since we know it is a normalized path, we can actually convert this
     * object into an FsPath for greater efficiency

     */

    TclFSMakePathFromNormalized(interp, retVal, clientData);
    if (clientDataPtr != NULL) {
	*clientDataPtr = clientData;
    }

    /*
     * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs.
     */

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetPathType --
 *
 *	Determines whether a given path is relative to the current directory,
 *	relative to the current volume, or absolute.
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.
 *
 * Side effects:
 *	None.
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460

461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527

528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553

554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

571
572
573
574
575
576
577
578

579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602









603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625

626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760

761
762
763
764
765
766
767
768
769
770
771

772


773

774
775
776

777
778
779
780

781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813

814
815
816
817
818
819
820
821
822
823
824
825
826

827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849

850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872

873
874
875
876
877
878
879
880
881
882
883
884
885
886
887

888


889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920

921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948

949
950
951
952

953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSGetPathType --
 *
 *	Determines whether a given path is relative to the current
 *	directory, relative to the current volume, or absolute.  If the
 *	caller wishes to know which filesystem claimed the path (in the
 *	case for which the path is absolute), then a reference to a
 *	filesystem pointer can be passed in (but passing NULL is
 *	acceptable).
 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE.  The filesystem reference will
 *	be set if and only if it is non-NULL and the function's 
 *	return value is TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr)
    Tcl_Obj *pathPtr;
    Tcl_Filesystem **filesystemPtrPtr;
    int *driveNameLengthPtr;
{
    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return TclGetPathType(pathPtr, filesystemPtrPtr, 
		driveNameLengthPtr, NULL);
    } else {
	FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);

	if (fsPathPtr->cwdPtr != NULL) {
	    if (PATHFLAGS(pathPtr) == 0) {
		return TCL_PATH_RELATIVE;
	    }
	    return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, 
		    driveNameLengthPtr);
	} else {
	    return TclGetPathType(pathPtr, filesystemPtrPtr, 
		    driveNameLengthPtr, NULL);
	}
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclPathPart
 *
 *	This procedure calculates the requested part of the given
 *	path, which can be:
 *	
 *	- the directory above ('file dirname')
 *	- the tail            ('file tail')
 *	- the extension       ('file extension')
 *	- the root            ('file root')
 *	
 *	The 'portion' parameter dictates which of these to calculate.
 *	There are a number of special cases both to be more efficient,
 *	and because the behaviour when given a path with only a single
 *	element is defined to require the expansion of that single
 *	element, where possible.
 *
 *      Should look into integrating 'FileBasename' in tclFCmd.c into
 *      this function.
 *      
 * Results:
 *	NULL if an error occurred, otherwise a Tcl_Obj owned by
 *	the caller (i.e. most likely with refCount 1).
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclPathPart(interp, pathPtr, portion)
    Tcl_Interp *interp;		/* Used for error reporting */
    Tcl_Obj *pathPtr;           /* Path to take dirname of */
    Tcl_PathPart portion;       /* Requested portion of name */
{
    if (pathPtr->typePtr == &tclFsPathType) {
	FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (TclFSEpochOk(fsPathPtr->filesystemEpoch) 
		&& (PATHFLAGS(pathPtr) != 0)) {
	    switch (portion) {
		case TCL_PATH_DIRNAME: {
		    /* 
		     * Check if the joined-on bit has any directory
		     * delimiters in it.  If so, the 'dirname' would
		     * be a joining of the main part with the dirname
		     * of the joined-on bit.  We could handle that
		     * special case here, but we don't, and instead
		     * just use the standardPath code.
		     */

		    CONST char *rest = TclGetString(fsPathPtr->normPathPtr);

		    if (strchr(rest, '/') != NULL) {
			goto standardPath;
		    }
		    if (tclPlatform == TCL_PLATFORM_WINDOWS
			    && strchr(rest, '\\') != NULL) {
			goto standardPath;
		    }

		    /* 
		     * The joined-on path is simple, so we can just
		     * return here.
		     */

		    Tcl_IncrRefCount(fsPathPtr->cwdPtr);
		    return fsPathPtr->cwdPtr;
		}
		case TCL_PATH_TAIL: {
		    /* 
		     * Check if the joined-on bit has any directory
		     * delimiters in it.  If so, the 'tail' would
		     * be only the part following the last delimiter.
		     * We could handle that special case here, but we
		     * don't, and instead just use the standardPath code.
		     */

		    CONST char *rest = TclGetString(fsPathPtr->normPathPtr);

		    if (strchr(rest, '/') != NULL) {
			goto standardPath;
		    }
		    if (tclPlatform == TCL_PLATFORM_WINDOWS
			    && strchr(rest, '\\') != NULL) {
			goto standardPath;
		    }
		    Tcl_IncrRefCount(fsPathPtr->normPathPtr);
		    return fsPathPtr->normPathPtr;
		}
		case TCL_PATH_EXTENSION: {
		    return GetExtension(fsPathPtr->normPathPtr);
		}
		case TCL_PATH_ROOT: {
		    /* Unimplemented */
		    CONST char *fileName, *extension;
		    int length;

		    fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, 
						    &length);
		    extension = TclGetExtension(fileName);
		    if (extension == NULL) {
			/* 
			 * There is no extension so the root is the
			 * same as the path we were given.
			 */

			Tcl_IncrRefCount(pathPtr);
			return pathPtr;
		    } else {
			/*
			 * Duplicate the object we were given and
			 * then trim off the extension of the
			 * tail component of the path.
			 */

			FsPath *fsDupPtr;
			Tcl_Obj *root = Tcl_DuplicateObj(pathPtr);

			Tcl_IncrRefCount(root);
			fsDupPtr = (FsPath*) PATHOBJ(root);
			if (Tcl_IsShared(fsDupPtr->normPathPtr)) {
			    TclDecrRefCount(fsDupPtr->normPathPtr);
			    fsDupPtr->normPathPtr =
				    Tcl_NewStringObj(fileName,
				    (int)(length - strlen(extension)));
			    Tcl_IncrRefCount(fsDupPtr->normPathPtr);
			} else {
			    Tcl_SetObjLength(fsDupPtr->normPathPtr, 
				    (int)(length - strlen(extension)));
			}









			return root;
		    }
		}
		default: {
		    /* We should never get here */
		    Tcl_Panic("Bad portion to TclPathPart");
		    /* For less clever compilers */
		    return NULL;
		}
	    }
	} else if (fsPathPtr->cwdPtr != NULL) {
	    /* Relative path */
	    goto standardPath;
	} else {
	    /* Absolute path */
	    goto standardPath;
	}
    } else {
	int splitElements;
	Tcl_Obj *splitPtr;
	Tcl_Obj *resultPtr;
      standardPath:


       	resultPtr = NULL;
        if (portion == TCL_PATH_EXTENSION) {
	    return GetExtension(pathPtr);
        } else if (portion == TCL_PATH_ROOT) {
	    int length;
	    CONST char *fileName, *extension;
	    
	    fileName = Tcl_GetStringFromObj(pathPtr, &length);
	    extension = TclGetExtension(fileName);
	    if (extension == NULL) {
		Tcl_IncrRefCount(pathPtr);
		return pathPtr;
	    } else {
		Tcl_Obj *root = Tcl_NewStringObj(fileName, 
			(int) (length - strlen(extension)));
		Tcl_IncrRefCount(root);
		return root;
	    }
        }
        
	/* 
	 * The behaviour we want here is slightly different to
	 * the standard Tcl_FSSplitPath in the handling of home
	 * directories; Tcl_FSSplitPath preserves the "~" while 
	 * this code computes the actual full path name, if we
	 * had just a single component.
	 */    

	splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
	Tcl_IncrRefCount(splitPtr);
	if (splitElements == 1  &&  TclGetString(pathPtr)[0] == '~') {
	    Tcl_Obj *norm;

	    TclDecrRefCount(splitPtr);
	    norm = Tcl_FSGetNormalizedPath(interp, pathPtr);
	    if (norm == NULL) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(norm, &splitElements);
	    Tcl_IncrRefCount(splitPtr);
	}
	if (portion == TCL_PATH_TAIL) {
	    /*
	     * Return the last component, unless it is the only component,
	     * and it is the root of an absolute path.
	     */

	    if ((splitElements > 0) && ((splitElements > 1) ||
		    (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
		Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
	    } else {
		resultPtr = Tcl_NewObj();
	    }
	} else {
	    /*
	     * Return all but the last component.  If there is only one
	     * component, return it if the path was non-relative, otherwise
	     * return the current directory.
	     */

	    if (splitElements > 1) {
		resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
	    } else if (splitElements == 0 || 
		    (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
		resultPtr = Tcl_NewStringObj(".", 1);
	    } else {
		Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr);
	    }
	}
	Tcl_IncrRefCount(resultPtr);
	TclDecrRefCount(splitPtr);
	return resultPtr;
    }
}

/*
 * Simple helper function 
 */

static Tcl_Obj*
GetExtension(pathPtr) 
    Tcl_Obj *pathPtr;
{
    CONST char *tail, *extension;
    Tcl_Obj *ret;
    
    tail = TclGetString(pathPtr);
    extension = TclGetExtension(tail);
    if (extension == NULL) {
	ret = Tcl_NewObj();
    } else {
	ret = Tcl_NewStringObj(extension, -1);
    }
    Tcl_IncrRefCount(ret);
    return ret;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSJoinPath --
 *
 *      This function takes the given Tcl_Obj, which should be a valid
 *      list, and returns the path object given by considering the
 *      first 'elements' elements as valid path segments (each path
 *      segment may be a complete path, a partial path or just a single
 *      possible directory or file name).   If any path segment is
 *      actually an absolute path, then all prior path segments are 
 *      discarded.
 *      
 *      If elements < 0, we use the entire list that was given.
 *      
 *      It is possible that the returned object is actually an element
 *      of the given list, so the caller should be careful to store a
 *      refCount to it before freeing the list.
 *      
 * Results:
 *      Returns object with refCount of zero, (or if non-zero, it has
 *      references elsewhere in Tcl).  Either way, the caller must
 *      increment its refCount before use.  Note that in the case where
 *      the caller has asked to join zero elements of the list, the
 *      return value will be an empty-string Tcl_Obj.
 *      
 *      If the given listObj was invalid, then the calling routine has
 *      a bug, and this function will just return NULL.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
Tcl_FSJoinPath(listObj, elements)
    Tcl_Obj *listObj;  /* Path elements to join, may have refCount 0 */

    int elements;      /* Number of elements to use (-1 = all) */
{
    Tcl_Obj *res;
    int i;
    Tcl_Filesystem *fsPtr = NULL;
    
    if (elements < 0) {
	if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
	    return NULL;
	}
    } else {

	/* Just make sure it is a valid list */


	int listTest;

	if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
	    return NULL;
	}

	/* 
	 * Correct this if it is too large, otherwise we will
	 * waste our time joining null elements to the path 
	 */

	if (elements > listTest) {
	    elements = listTest;
	}
    }
    
    res = NULL;
    
    for (i = 0; i < elements; i++) {
	Tcl_Obj *elt;
	int driveNameLength;
	Tcl_PathType type;
	char *strElt;
	int strEltLen;
	int length;
	char *ptr;
	Tcl_Obj *driveName = NULL;
	
	Tcl_ListObjIndex(NULL, listObj, i, &elt);
	
	/* 
	 * This is a special case where we can be much more
	 * efficient, where we are joining a single relative path
	 * onto an object that is already of path type.  The 
	 * 'TclNewFSPathObj' call below creates an object which
	 * can be normalized more efficiently.  Currently we only
	 * use the special case when we have exactly two elements,
	 * but we could expand that in the future.
	 */

	if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
		&& !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
	    Tcl_Obj *tail;
	    Tcl_PathType type;

	    Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
	    type = TclGetPathType(tail, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		CONST char *str;
		int len;

		str = Tcl_GetStringFromObj(tail, &len);
		if (len == 0) {
		    /* 
		     * This happens if we try to handle the root volume
		     * '/'.  There's no need to return a special path
		     * object, when the base itself is just fine!
		     */

		    if (res != NULL) {
			TclDecrRefCount(res);
		    }
		    return elt;
		}

		/* 
		 * If it doesn't begin with '.'  and is a unix
		 * path or it a windows path without backslashes, then we
		 * can be very efficient here.  (In fact even a windows
		 * path with backslashes can be joined efficiently, but
		 * the path object would not have forward slashes only,
		 * and this would therefore contradict our 'file join'
		 * documentation).
		 */

		if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) 
			|| (strchr(str, '\\') == NULL))) {
		    /* 
		     * Finally, on Windows, 'file join' is defined to 
		     * convert all backslashes to forward slashes,
		     * so the base part cannot have backslashes either.
		     */

		    if ((tclPlatform != TCL_PLATFORM_WINDOWS)
			|| (strchr(Tcl_GetString(elt), '\\') == NULL)) {
			if (res != NULL) {
			    TclDecrRefCount(res);
			}
			return TclNewFSPathObj(elt, str, len);
		    }
		}

		/* 
		 * Otherwise we don't have an easy join, and
		 * we must let the more general code below handle
		 * things
		 */
	    } else {
		if (tclPlatform == TCL_PLATFORM_UNIX) {
		    if (res != NULL) {
			TclDecrRefCount(res);
		    }
		    return tail;
		} else {
		    CONST char *str;
		    int len;

		    str = Tcl_GetStringFromObj(tail, &len);
		    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
			if (strchr(str, '\\') == NULL) {
			    if (res != NULL) {
				TclDecrRefCount(res);
			    }
			    return tail;
			}
		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
	if (type != TCL_PATH_RELATIVE) {

	    /* Zero out the current result */


	    if (res != NULL) {
		TclDecrRefCount(res);
	    }

	    if (driveName != NULL) {
		/*
		 * We've been given a separate drive-name object,
		 * because the prefix in 'elt' is not in a suitable
		 * format for us (e.g. it may contain irrelevant
		 * multiple separators, like C://///foo).
		 */

		res = Tcl_DuplicateObj(driveName);
		TclDecrRefCount(driveName);

		/* 
		 * Do not set driveName to NULL, because we will check
		 * its value below (but we won't access the contents,
		 * since those have been cleaned-up).
		 */
	    } else {
		res = Tcl_NewStringObj(strElt, driveNameLength);
	    }
	    strElt += driveNameLength;
	}
	
	/* 
	 * Optimisation block: if this is the last element to be
	 * examined, and it is absolute or the only element, and the
	 * drive-prefix was ok (if there is one), it might be that the
	 * path is already in a suitable form to be returned.  Then we
	 * can short-cut the rest of this procedure.

	 */

	if ((driveName == NULL) && (i == (elements - 1)) 
		&& (type != TCL_PATH_RELATIVE || res == NULL)) {
	    /* 
	     * It's the last path segment.  Perform a quick check if
	     * the path is already in a suitable form.
	     */
	    
	    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
		if (strchr(strElt, '\\') != NULL) {
		    goto noQuickReturn;
		}
	    }
            ptr = strElt;
            while (*ptr != '\0') {
                if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) {
                    /* 
                     * We have a repeated file separator, which
                     * means the path is not in normalized form
                     */
                    goto noQuickReturn;
                }
                ptr++;
            }
            if (res != NULL) {
		TclDecrRefCount(res);
	    }

            /* 
             * This element is just what we want to return already -
             * no further manipulation is requred.
             */

            return elt;
	}

        /* 
         * The path element was not of a suitable form to be
         * returned as is.  We need to perform a more complex
         * operation here.
         */

      noQuickReturn:
	
	if (res == NULL) {
	    res = Tcl_NewObj();
	    ptr = Tcl_GetStringFromObj(res, &length);
	} else {
	    ptr = Tcl_GetStringFromObj(res, &length);
	}
	
	/* 
	 * Strip off any './' before a tilde, unless this is the
	 * beginning of the path.
	 */

	if (length > 0 && strEltLen > 0 && (strElt[0] == '.') &&
		(strElt[1] == '/') && (strElt[2] == '~')) {
	    strElt += 2;
	}

	/* 
	 * A NULL value for fsPtr at this stage basically means
	 * we're trying to join a relative path onto something
	 * which is also relative (or empty).  There's nothing
	 * particularly wrong with that.
	 */

	if (*strElt == '\0') {
	    continue;
	}
	
	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;
	    
	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
		if (sep != NULL) {
		    separator = TclGetString(sep)[0];
		}
	    }








|
|
|
|
|
<



|
|
|














|



>




|


|










|
|
|




|
|
|
|
|
<

|
|
|

|
|


|







|
|



|


|
|
|
|
<
|
|
|
|

|
>
|
|
|
|
|
|
|

|
|
<
|

|
|
|
|
|
|
<
|
|
|
|

|
>
|
|
|
|
|
|
|
|
|
|
|
|
<
|
<
|
|
>
|
|
|
|
|
|
|
|
>
|
|
|
|
|
<
|
|

|
|

|
|
|
|
|
<
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
<












<

>
|
|

|


|






|




|
|
|
|
|
|
<
|
|
















|
|










|






|













|



|




|
















|
|
|
|
<
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|







|

|
>
|




|





>
|
>
>

>



>
|
|
|

>




|

|









|

|
|
|
|
<
|
|
|
|






>








|
|
|
|

>






|
|
|
|
|
|
|
<


|

|
|
|
|

>

|







|
|
|
<

<
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
<







>
|
>
>






|
|
|
|





|
|
|
|






|
|
|
|
|
<
|
>


|

|
|
|

|





|
|
|
|
|
|
|
|
|
|
|
|


>
|
|
|
|
>
|


|
|
|
<
|

|
|






|
|
|
|







|
|
|
<
|





|





|







434
435
436
437
438
439
440
441
442
443
444
445

446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529

530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546

547
548
549
550
551
552
553
554

555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573

574

575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591

592
593
594
595
596
597
598
599
600
601
602

603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625

626
627
628
629
630
631
632
633
634
635
636
637

638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663

664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744

745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821

822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859

860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881

882

883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898

899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939

940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981

982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005

1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSGetPathType --
 *
 *	Determines whether a given path is relative to the current directory,
 *	relative to the current volume, or absolute. If the caller wishes to
 *	know which filesystem claimed the path (in the case for which the path
 *	is absolute), then a reference to a filesystem pointer can be passed
 *	in (but passing NULL is acceptable).

 *
 * Results:
 *	Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *	TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and
 *	only if it is non-NULL and the function's return value is
 *	TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr)
    Tcl_Obj *pathPtr;
    Tcl_Filesystem **filesystemPtrPtr;
    int *driveNameLengthPtr;
{
    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return TclGetPathType(pathPtr, filesystemPtrPtr,
		driveNameLengthPtr, NULL);
    } else {
	FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);

	if (fsPathPtr->cwdPtr != NULL) {
	    if (PATHFLAGS(pathPtr) == 0) {
		return TCL_PATH_RELATIVE;
	    }
	    return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
		    driveNameLengthPtr);
	} else {
	    return TclGetPathType(pathPtr, filesystemPtrPtr,
		    driveNameLengthPtr, NULL);
	}
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclPathPart
 *
 *	This function calculates the requested part of the given path, which
 *	can be:
 *
 *	- the directory above ('file dirname')
 *	- the tail            ('file tail')
 *	- the extension       ('file extension')
 *	- the root            ('file root')
 *
 *	The 'portion' parameter dictates which of these to calculate.  There
 *	are a number of special cases both to be more efficient, and because
 *	the behaviour when given a path with only a single element is defined
 *	to require the expansion of that single element, where possible.

 *
 *	Should look into integrating 'FileBasename' in tclFCmd.c into this
 *	function.
 *
 * Results:
 *	NULL if an error occurred, otherwise a Tcl_Obj owned by the caller
 *	(i.e. most likely with refCount 1).
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclPathPart(interp, pathPtr, portion)
    Tcl_Interp *interp;		/* Used for error reporting */
    Tcl_Obj *pathPtr;		/* Path to take dirname of */
    Tcl_PathPart portion;	/* Requested portion of name */
{
    if (pathPtr->typePtr == &tclFsPathType) {
	FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (TclFSEpochOk(fsPathPtr->filesystemEpoch)
		&& (PATHFLAGS(pathPtr) != 0)) {
	    switch (portion) {
	    case TCL_PATH_DIRNAME: {
		/*
		 * Check if the joined-on bit has any directory delimiters in
		 * it. If so, the 'dirname' would be a joining of the main

		 * part with the dirname of the joined-on bit. We could handle
		 * that special case here, but we don't, and instead just use
		 * the standardPath code.
		 */

		CONST char *rest = TclGetString(fsPathPtr->normPathPtr);

		if (strchr(rest, '/') != NULL) {
		    goto standardPath;
		}
		if (tclPlatform == TCL_PLATFORM_WINDOWS
			&& strchr(rest, '\\') != NULL) {
		    goto standardPath;
		}

		/*
		 * The joined-on path is simple, so we can just return here.

		 */

		Tcl_IncrRefCount(fsPathPtr->cwdPtr);
		return fsPathPtr->cwdPtr;
	    }
	    case TCL_PATH_TAIL: {
		/*
		 * Check if the joined-on bit has any directory delimiters in

		 * it. If so, the 'tail' would be only the part following the
		 * last delimiter. We could handle that special case here, but
		 * we don't, and instead just use the standardPath code.
		 */

		CONST char *rest = TclGetString(fsPathPtr->normPathPtr);

		if (strchr(rest, '/') != NULL) {
		    goto standardPath;
		}
		if (tclPlatform == TCL_PLATFORM_WINDOWS
			&& strchr(rest, '\\') != NULL) {
		    goto standardPath;
		}
		Tcl_IncrRefCount(fsPathPtr->normPathPtr);
		return fsPathPtr->normPathPtr;
	    }
	    case TCL_PATH_EXTENSION:
		return GetExtension(fsPathPtr->normPathPtr);

	    case TCL_PATH_ROOT: {

		CONST char *fileName, *extension;
		int length;

		fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
			&length);
		extension = TclGetExtension(fileName);
		if (extension == NULL) {
		    /*
		     * There is no extension so the root is the same as the
		     * path we were given.
		     */

		    Tcl_IncrRefCount(pathPtr);
		    return pathPtr;
		} else {
		    /*
		     * Duplicate the object we were given and then trim off

		     * the extension of the tail component of the path.
		     */

		    FsPath *fsDupPtr;
		    Tcl_Obj *root = Tcl_DuplicateObj(pathPtr);

		    Tcl_IncrRefCount(root);
		    fsDupPtr = (FsPath*) PATHOBJ(root);
		    if (Tcl_IsShared(fsDupPtr->normPathPtr)) {
			TclDecrRefCount(fsDupPtr->normPathPtr);
			fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName,

				(int)(length - strlen(extension)));
			Tcl_IncrRefCount(fsDupPtr->normPathPtr);
		    } else {
			Tcl_SetObjLength(fsDupPtr->normPathPtr,
				(int)(length - strlen(extension)));
		    }

		    /*
		     * Must also trim the string representation if we have it.
		     */

		    if (root->bytes != NULL && root->length > 0) {
			root->length -= strlen(extension);
			root->bytes[root->length] = 0;
		    }
		    return root;
		}
	    }
	    default:
		/* We should never get here */
		Tcl_Panic("Bad portion to TclPathPart");
		/* For less clever compilers */
		return NULL;

	    }
	} else if (fsPathPtr->cwdPtr != NULL) {
	    /* Relative path */
	    goto standardPath;
	} else {
	    /* Absolute path */
	    goto standardPath;
	}
    } else {
	int splitElements;
	Tcl_Obj *splitPtr;
	Tcl_Obj *resultPtr;


    standardPath:
	resultPtr = NULL;
	if (portion == TCL_PATH_EXTENSION) {
	    return GetExtension(pathPtr);
	} else if (portion == TCL_PATH_ROOT) {
	    int length;
	    CONST char *fileName, *extension;

	    fileName = Tcl_GetStringFromObj(pathPtr, &length);
	    extension = TclGetExtension(fileName);
	    if (extension == NULL) {
		Tcl_IncrRefCount(pathPtr);
		return pathPtr;
	    } else {
		Tcl_Obj *root = Tcl_NewStringObj(fileName,
			(int) (length - strlen(extension)));
		Tcl_IncrRefCount(root);
		return root;
	    }
	}

	/*
	 * The behaviour we want here is slightly different to the standard
	 * Tcl_FSSplitPath in the handling of home directories;
	 * Tcl_FSSplitPath preserves the "~" while this code computes the

	 * actual full path name, if we had just a single component.
	 */

	splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
	Tcl_IncrRefCount(splitPtr);
	if (splitElements == 1  &&  TclGetString(pathPtr)[0] == '~') {
	    Tcl_Obj *norm;

	    TclDecrRefCount(splitPtr);
	    norm = Tcl_FSGetNormalizedPath(interp, pathPtr);
	    if (norm == NULL) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(norm, &splitElements);
	    Tcl_IncrRefCount(splitPtr);
	}
	if (portion == TCL_PATH_TAIL) {
	    /*
	     * Return the last component, unless it is the only component, and
	     * it is the root of an absolute path.
	     */

	    if ((splitElements > 0) && ((splitElements > 1) ||
		    (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
		Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
	    } else {
		resultPtr = Tcl_NewObj();
	    }
	} else {
	    /*
	     * Return all but the last component. If there is only one
	     * component, return it if the path was non-relative, otherwise
	     * return the current directory.
	     */

	    if (splitElements > 1) {
		resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
	    } else if (splitElements == 0 ||
		    (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
		resultPtr = Tcl_NewStringObj(".", 1);
	    } else {
		Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr);
	    }
	}
	Tcl_IncrRefCount(resultPtr);
	TclDecrRefCount(splitPtr);
	return resultPtr;
    }
}

/*
 * Simple helper function
 */

static Tcl_Obj*
GetExtension(pathPtr)
    Tcl_Obj *pathPtr;
{
    CONST char *tail, *extension;
    Tcl_Obj *ret;

    tail = TclGetString(pathPtr);
    extension = TclGetExtension(tail);
    if (extension == NULL) {
	ret = Tcl_NewObj();
    } else {
	ret = Tcl_NewStringObj(extension, -1);
    }
    Tcl_IncrRefCount(ret);
    return ret;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSJoinPath --
 *
 *	This function takes the given Tcl_Obj, which should be a valid list,
 *	and returns the path object given by considering the first 'elements'
 *	elements as valid path segments (each path segment may be a complete
 *	path, a partial path or just a single possible directory or file

 *	name). If any path segment is actually an absolute path, then all
 *	prior path segments are discarded.
 *
 *	If elements < 0, we use the entire list that was given.
 *
 *	It is possible that the returned object is actually an element of the
 *	given list, so the caller should be careful to store a refCount to it
 *	before freeing the list.
 *
 * Results:
 *	Returns object with refCount of zero, (or if non-zero, it has
 *	references elsewhere in Tcl). Either way, the caller must increment
 *	its refCount before use. Note that in the case where the caller has
 *	asked to join zero elements of the list, the return value will be an
 *	empty-string Tcl_Obj.
 *
 *	If the given listObj was invalid, then the calling routine has a bug,
 *	and this function will just return NULL.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSJoinPath(listObj, elements)
    Tcl_Obj *listObj;		/* Path elements to join, may have a zero
				 * reference count. */
    int elements;		/* Number of elements to use (-1 = all) */
{
    Tcl_Obj *res;
    int i;
    Tcl_Filesystem *fsPtr = NULL;

    if (elements < 0) {
	if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
	    return NULL;
	}
    } else {
	/*
	 * Just make sure it is a valid list.
	 */

	int listTest;

	if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
	    return NULL;
	}

	/*
	 * Correct this if it is too large, otherwise we will waste our time
	 * joining null elements to the path.
	 */

	if (elements > listTest) {
	    elements = listTest;
	}
    }

    res = NULL;

    for (i = 0; i < elements; i++) {
	Tcl_Obj *elt;
	int driveNameLength;
	Tcl_PathType type;
	char *strElt;
	int strEltLen;
	int length;
	char *ptr;
	Tcl_Obj *driveName = NULL;

	Tcl_ListObjIndex(NULL, listObj, i, &elt);

	/*
	 * This is a special case where we can be much more efficient, where
	 * we are joining a single relative path onto an object that is

	 * already of path type. The 'TclNewFSPathObj' call below creates an
	 * object which can be normalized more efficiently. Currently we only
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
	 */

	if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
		&& !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
	    Tcl_Obj *tail;
	    Tcl_PathType type;

	    Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
	    type = TclGetPathType(tail, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		CONST char *str;
		int len;

		str = Tcl_GetStringFromObj(tail, &len);
		if (len == 0) {
		    /*
		     * This happens if we try to handle the root volume '/'.
		     * There's no need to return a special path object, when
		     * the base itself is just fine!
		     */

		    if (res != NULL) {
			TclDecrRefCount(res);
		    }
		    return elt;
		}

		/*
		 * If it doesn't begin with '.'  and is a unix path or it a
		 * windows path without backslashes, then we can be very
		 * efficient here. (In fact even a windows path with
		 * backslashes can be joined efficiently, but the path object
		 * would not have forward slashes only, and this would
		 * therefore contradict our 'file join' documentation).

		 */

		if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
			|| (strchr(str, '\\') == NULL))) {
		    /*
		     * Finally, on Windows, 'file join' is defined to convert
		     * all backslashes to forward slashes, so the base part
		     * cannot have backslashes either.
		     */

		    if ((tclPlatform != TCL_PLATFORM_WINDOWS)
			    || (strchr(Tcl_GetString(elt), '\\') == NULL)) {
			if (res != NULL) {
			    TclDecrRefCount(res);
			}
			return TclNewFSPathObj(elt, str, len);
		    }
		}

		/*
		 * Otherwise we don't have an easy join, and we must let the
		 * more general code below handle things

		 */

	    } else if (tclPlatform == TCL_PLATFORM_UNIX) {
		if (res != NULL) {
		    TclDecrRefCount(res);
		}
		return tail;
	    } else {
		CONST char *str;
		int len;

		str = Tcl_GetStringFromObj(tail, &len);
		if (tclPlatform == TCL_PLATFORM_WINDOWS) {
		    if (strchr(str, '\\') == NULL) {
			if (res != NULL) {
			    TclDecrRefCount(res);
			}
			return tail;

		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
	if (type != TCL_PATH_RELATIVE) {
	    /*
	     * Zero out the current result.
	     */

	    if (res != NULL) {
		TclDecrRefCount(res);
	    }

	    if (driveName != NULL) {
		/*
		 * We've been given a separate drive-name object, because the
		 * prefix in 'elt' is not in a suitable format for us (e.g. it
		 * may contain irrelevant multiple separators, like
		 * C://///foo).
		 */

		res = Tcl_DuplicateObj(driveName);
		TclDecrRefCount(driveName);

		/*
		 * Do not set driveName to NULL, because we will check its
		 * value below (but we won't access the contents, since those
		 * have been cleaned-up).
		 */
	    } else {
		res = Tcl_NewStringObj(strElt, driveNameLength);
	    }
	    strElt += driveNameLength;
	}

	/*
	 * Optimisation block: if this is the last element to be examined, and
	 * it is absolute or the only element, and the drive-prefix was ok (if
	 * there is one), it might be that the path is already in a suitable

	 * form to be returned.  Then we can short-cut the rest of this
	 * function.
	 */

	if ((driveName == NULL) && (i == (elements - 1))
		&& (type != TCL_PATH_RELATIVE || res == NULL)) {
	    /*
	     * It's the last path segment.  Perform a quick check if the path
	     * is already in a suitable form.
	     */

	    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
		if (strchr(strElt, '\\') != NULL) {
		    goto noQuickReturn;
		}
	    }
	    ptr = strElt;
	    while (*ptr != '\0') {
		if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) {
		    /*
		     * We have a repeated file separator, which means the path
		     * is not in normalized form
		     */
		    goto noQuickReturn;
		}
		ptr++;
	    }
	    if (res != NULL) {
		TclDecrRefCount(res);
	    }

	    /*
	     * This element is just what we want to return already - no
	     * further manipulation is requred.
	     */

	    return elt;
	}

	/*
	 * The path element was not of a suitable form to be returned as is.
	 * We need to perform a more complex operation here.

	 */

    noQuickReturn:

	if (res == NULL) {
	    res = Tcl_NewObj();
	    ptr = Tcl_GetStringFromObj(res, &length);
	} else {
	    ptr = Tcl_GetStringFromObj(res, &length);
	}

	/*
	 * Strip off any './' before a tilde, unless this is the beginning of
	 * the path.
	 */

	if (length > 0 && strEltLen > 0 && (strElt[0] == '.') &&
		(strElt[1] == '/') && (strElt[2] == '~')) {
	    strElt += 2;
	}

	/*
	 * A NULL value for fsPtr at this stage basically means we're trying
	 * to join a relative path onto something which is also relative (or

	 * empty). There's nothing particularly wrong with that.
	 */

	if (*strElt == '\0') {
	    continue;
	}

	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;

	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
		if (sep != NULL) {
		    separator = TclGetString(sep)[0];
		}
	    }

1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074

1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
		}
	    }
	    length = ptr - TclGetString(res);
	    Tcl_SetObjLength(res, length);
	}
    }
    if (res == NULL) {
        res = Tcl_NewObj();
    }
    return res;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSConvertToPathType --
 *
 *      This function tries to convert the given Tcl_Obj to a valid
 *      Tcl path type, taking account of the fact that the cwd may
 *      have changed even if this object is already supposedly of
 *      the correct type.
 *      
 *      The filename may begin with "~" (to indicate current user's
 *      home directory) or "~<user>" (to indicate any user's home
 *      directory).
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

int 
Tcl_FSConvertToPathType(interp, pathPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error
				 * message (if necessary). */
    Tcl_Obj *pathPtr;		/* Object to convert to a valid, current
				 * path type. */
{
    /* 
     * While it is bad practice to examine an object's type directly,
     * this is actually the best thing to do here.  The reason is that
     * if we are converting this object to FsPath type for the first
     * time, we don't need to worry whether the 'cwd' has changed.
     * On the other hand, if this object is already of FsPath type,
     * and is a relative path, we do have to worry about the cwd.
     * If the cwd has changed, we must recompute the path.

     */

    if (pathPtr->typePtr == &tclFsPathType) {
	FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (!TclFSEpochOk(fsPathPtr->filesystemEpoch)) {
	    if (pathPtr->bytes == NULL) {
		UpdateStringOfFsPath(pathPtr);
	    }
	    FreeFsPathInternalRep(pathPtr);
	    pathPtr->typePtr = NULL;
	    return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
	}
	return TCL_OK;
	/* 
	 * We used to have more complex code here:
	 * 
	 * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) {
	 *     return TCL_OK;
	 * } else {
	 *     if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
	 *         return TCL_OK;
	 *     } else {
	 *         if (pathPtr->bytes == NULL) {
	 *             UpdateStringOfFsPath(pathPtr);
	 *         }
	 *         FreeFsPathInternalRep(pathPtr);
	 *         pathPtr->typePtr = NULL;
	 *         return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
	 *     }
	 * }
	 * 
	 * But we no longer believe this is necessary.
	 */
    } else {
	return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
    }
}

/* 
 * Helper function for normalization.
 */

static int
IsSeparatorOrNull(ch)
    int ch;
{
    if (ch == 0) {
        return 1;
    }
    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX: {
	    return (ch == '/' ? 1 : 0);
	}
	case TCL_PLATFORM_WINDOWS: {
	    return ((ch == '/' || ch == '\\') ? 1 : 0);
	}
    }
    return 0;
}

/* 
 * Helper function for SetFsPathFromAny.  Returns position of first
 * directory delimiter in the path.  If no separator is found, then
 * returns the position of the end of the string.
 */

static int
FindSplitPos(path, separator)
    CONST char *path;
    int separator;
{







|









|
|
|
<
|
|
|
<


|







|

|
|
|
|

|
|
|
|
|
<
|
|
>













|

|














|







|








|


|
|
<
|
|
<




|
|
|
|







1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065

1066
1067
1068

1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090

1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145

1146
1147

1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
		}
	    }
	    length = ptr - TclGetString(res);
	    Tcl_SetObjLength(res, length);
	}
    }
    if (res == NULL) {
	res = Tcl_NewObj();
    }
    return res;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSConvertToPathType --
 *
 *	This function tries to convert the given Tcl_Obj to a valid Tcl path
 *	type, taking account of the fact that the cwd may have changed even if
 *	this object is already supposedly of the correct type.

 *
 *	The filename may begin with "~" (to indicate current user's home
 *	directory) or "~<user>" (to indicate any user's home directory).

 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSConvertToPathType(interp, pathPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error message
				 * (if necessary). */
    Tcl_Obj *pathPtr;		/* Object to convert to a valid, current path
				 * type. */
{
    /*
     * While it is bad practice to examine an object's type directly, this is
     * actually the best thing to do here.  The reason is that if we are
     * converting this object to FsPath type for the first time, we don't need
     * to worry whether the 'cwd' has changed.  On the other hand, if this

     * object is already of FsPath type, and is a relative path, we do have to
     * worry about the cwd.  If the cwd has changed, we must recompute the
     * path.
     */

    if (pathPtr->typePtr == &tclFsPathType) {
	FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (!TclFSEpochOk(fsPathPtr->filesystemEpoch)) {
	    if (pathPtr->bytes == NULL) {
		UpdateStringOfFsPath(pathPtr);
	    }
	    FreeFsPathInternalRep(pathPtr);
	    pathPtr->typePtr = NULL;
	    return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
	}
	return TCL_OK;
	/*
	 * We used to have more complex code here:
	 *
	 * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) {
	 *     return TCL_OK;
	 * } else {
	 *     if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
	 *         return TCL_OK;
	 *     } else {
	 *         if (pathPtr->bytes == NULL) {
	 *             UpdateStringOfFsPath(pathPtr);
	 *         }
	 *         FreeFsPathInternalRep(pathPtr);
	 *         pathPtr->typePtr = NULL;
	 *         return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
	 *     }
	 * }
	 *
	 * But we no longer believe this is necessary.
	 */
    } else {
	return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
    }
}

/*
 * Helper function for normalization.
 */

static int
IsSeparatorOrNull(ch)
    int ch;
{
    if (ch == 0) {
	return 1;
    }
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	return (ch == '/' ? 1 : 0);

    case TCL_PLATFORM_WINDOWS:
	return ((ch == '/' || ch == '\\') ? 1 : 0);

    }
    return 0;
}

/*
 * Helper function for SetFsPathFromAny.  Returns position of first directory
 * delimiter in the path.  If no separator is found, then returns the position
 * of the end of the string.
 */

static int
FindSplitPos(path, separator)
    CONST char *path;
    int separator;
{
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203

1204


1205
1206
1207
1208
1209
1210
1211
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNewFSPathObj --
 *
 *      Creates a path object whose string representation is '[file join
 *      dirPtr addStrRep]', but does so in a way that allows for more
 *      efficient creation and caching of normalized paths, and more
 *      efficient 'file dirname', 'file tail', etc.
 *      
 * Assumptions:
 *      'dirPtr' must be an absolute path.  
 *      'len' may not be zero.
 *      
 * Results:
 *      The new Tcl object, with refCount zero.
 *
 * Side effects:
 *	Memory is allocated.  'dirPtr' gets an additional refCount.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
{
    FsPath *fsPathPtr;
    Tcl_Obj *pathPtr;
    ThreadSpecificData *tsdPtr;
    
    tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    
    pathPtr = Tcl_NewObj();
    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
    

    /* Setup the path */


    fsPathPtr->translatedPathPtr = NULL;
    fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
    Tcl_IncrRefCount(fsPathPtr->normPathPtr);
    fsPathPtr->cwdPtr = dirPtr;
    Tcl_IncrRefCount(dirPtr);
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;







|
|
|
|
|

|
<
|

|













|

|


|
>
|
>
>







1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197

1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNewFSPathObj --
 *
 *	Creates a path object whose string representation is '[file join
 *	dirPtr addStrRep]', but does so in a way that allows for more
 *	efficient creation and caching of normalized paths, and more efficient
 *	'file dirname', 'file tail', etc.
 *
 * Assumptions:
 *	'dirPtr' must be an absolute path.  'len' may not be zero.

 *
 * Results:
 *	The new Tcl object, with refCount zero.
 *
 * Side effects:
 *	Memory is allocated.  'dirPtr' gets an additional refCount.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
{
    FsPath *fsPathPtr;
    Tcl_Obj *pathPtr;
    ThreadSpecificData *tsdPtr;

    tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    pathPtr = Tcl_NewObj();
    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));

    /*
     * Set up the path.
     */

    fsPathPtr->translatedPathPtr = NULL;
    fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
    Tcl_IncrRefCount(fsPathPtr->normPathPtr);
    fsPathPtr->cwdPtr = dirPtr;
    Tcl_IncrRefCount(dirPtr);
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234






1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260


1261


1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275













1276
1277
1278

1279


1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364

1365


1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381


1382


1383


1384


1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444

1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457


1458


1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514

1515
1516
1517

1518


1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555

1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676


1677


1678
1679
1680
1681
1682
1683
1684


1685


1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796


1797

1798
1799

1800

1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSMakePathRelative --
 *
 *      Only for internal use.
 *      
 *      Takes a path and a directory, where we _assume_ both path and
 *      directory are absolute, normalized and that the path lies
 *      inside the directory.  Returns a Tcl_Obj representing filename 
 *      of the path relative to the directory.
 *      






 * Results:
 *      NULL on error, otherwise a valid object, typically with
 *      refCount of zero, which it is assumed the caller will
 *      increment.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclFSMakePathRelative(interp, pathPtr, cwdPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr;		/* The path we have. */
    Tcl_Obj *cwdPtr;		/* Make it relative to this. */
{
    int cwdLen, len;
    CONST char *tempStr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    
    if (pathPtr->typePtr == &tclFsPathType) {
	FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (PATHFLAGS(pathPtr) != 0 
		&& fsPathPtr->cwdPtr == cwdPtr) {
	    pathPtr = fsPathPtr->normPathPtr;


	    /* Free old representation */


	    if (pathPtr->typePtr != NULL) {
		if (pathPtr->bytes == NULL) {
		    if (pathPtr->typePtr->updateStringProc == NULL) {
			if (interp != NULL) {
			    Tcl_ResetResult(interp);
			    Tcl_AppendResult(interp, "can't find object",
				    "string representation", (char *) NULL);
			}
			return NULL;
		    }
		    pathPtr->typePtr->updateStringProc(pathPtr);
		}
		TclFreeIntRep(pathPtr);
	    }














	    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));


	    /* Circular reference, by design */


	    fsPathPtr->translatedPathPtr = pathPtr;
	    fsPathPtr->normPathPtr = NULL;
	    fsPathPtr->cwdPtr = cwdPtr;
	    Tcl_IncrRefCount(cwdPtr);
	    fsPathPtr->nativePathPtr = NULL;
	    fsPathPtr->fsRecPtr = NULL;
	    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

	    PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
	    PATHFLAGS(pathPtr) = 0;
	    pathPtr->typePtr = &tclFsPathType;

	    return pathPtr;
	}
    }

    /* 
     * We know the cwd is a normalised object which does not end in a
     * directory delimiter, unless the cwd is the name of a volume, in
     * which case it will end in a delimiter!  We handle this
     * situation here.  A better test than the '!= sep' might be to
     * simply check if 'cwd' is a root volume.
     * 
     * Note that if we get this wrong, we will strip off either too
     * much or too little below, leading to wrong answers returned by
     * glob.
     */

    tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);

    /* 
     * Should we perhaps use 'Tcl_FSPathSeparator'?  But then what
     * about the Windows special case?  Perhaps we should just check
     * if cwd is a root volume.
     */

    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    if (tempStr[cwdLen-1] != '/') {
		cwdLen++;
	    }
	    break;
	case TCL_PLATFORM_WINDOWS:
	    if (tempStr[cwdLen-1] != '/' 
		    && tempStr[cwdLen-1] != '\\') {
		cwdLen++;
	    }
	    break;
    }
    tempStr = Tcl_GetStringFromObj(pathPtr, &len);

    return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSMakePathFromNormalized --
 *
 *      Like SetFsPathFromAny, but assumes the given object is an
 *      absolute normalized path. Only for internal use.
 *      
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

int
TclFSMakePathFromNormalized(interp, pathPtr, nativeRep)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr;		/* The object to convert. */
    ClientData nativeRep;	/* The native rep for the object, if known
				 * else NULL. */
{
    FsPath *fsPathPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (pathPtr->typePtr == &tclFsPathType) {
	return TCL_OK;
    }
    

    /* Free old representation */


    if (pathPtr->typePtr != NULL) {
	if (pathPtr->bytes == NULL) {
	    if (pathPtr->typePtr->updateStringProc == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "can't find object",
				     "string representation", (char *) NULL);
		}
		return TCL_ERROR;
	    }
	    pathPtr->typePtr->updateStringProc(pathPtr);
	}
	TclFreeIntRep(pathPtr);
    }

    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));


    /* It's a pure normalized absolute path */


    fsPathPtr->translatedPathPtr = NULL;


    /* Circular reference by design */


    fsPathPtr->normPathPtr = pathPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = nativeRep;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
    PATHFLAGS(pathPtr) = 0;
    pathPtr->typePtr = &tclFsPathType;

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSNewNativePath --
 *
 *      This function performs the something like that reverse of the 
 *      usual obj->path->nativerep conversions.  If some code retrieves
 *      a path in native form (from, e.g. readlink or a native dialog),
 *      and that path is to be used at the Tcl level, then calling
 *      this function is an efficient way of creating the appropriate
 *      path object type.
 *      
 *      Any memory which is allocated for 'clientData' should be retained
 *      until clientData is passed to the filesystem's freeInternalRepProc
 *      when it can be freed.  The built in platform-specific filesystems
 *      use 'ckalloc' to allocate clientData, and ckfree to free it.
 *
 * Results:
 *      NULL or a valid path object pointer, with refCount zero.
 *
 * Side effects:
 *	New memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
    Tcl_Filesystem* fromFilesystem;
    ClientData clientData;
{
    Tcl_Obj *pathPtr;
    FsPath *fsPathPtr;

    FilesystemRecord *fsFromPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    
    pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
                                       &fsFromPtr);
    if (pathPtr == NULL) {
	return NULL;
    }
    
    /* 
     * Free old representation; shouldn't normally be any,
     * but best to be safe. 
     */

    if (pathPtr->typePtr != NULL) {
	if (pathPtr->bytes == NULL) {
	    if (pathPtr->typePtr->updateStringProc == NULL) {
		return NULL;
	    }
	    pathPtr->typePtr->updateStringProc(pathPtr);
	}
	TclFreeIntRep(pathPtr);
    }
    
    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));

    fsPathPtr->translatedPathPtr = NULL;


    /* Circular reference, by design */


    fsPathPtr->normPathPtr = pathPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = clientData;
    fsPathPtr->fsRecPtr = fsFromPtr;
    fsPathPtr->fsRecPtr->fileRefCount++;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;  

    PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
    PATHFLAGS(pathPtr) = 0;
    pathPtr->typePtr = &tclFsPathType;

    return pathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetTranslatedPath --
 *
 *      This function attempts to extract the translated path
 *      from the given Tcl_Obj.  If the translation succeeds (i.e. the
 *      object is a valid path), then it is returned.  Otherwise NULL
 *      will be returned, and an error message may be left in the
 *      interpreter (if it is non-NULL)
 *
 * Results:
 *      NULL or a valid Tcl_Obj pointer.
 *
 * Side effects:
 *	Only those of 'Tcl_FSConvertToPathType'
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
Tcl_FSGetTranslatedPath(interp, pathPtr)
    Tcl_Interp *interp;
    Tcl_Obj* pathPtr;
{
    Tcl_Obj *retObj = NULL;
    FsPath *srcFsPathPtr;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    if (srcFsPathPtr->translatedPathPtr == NULL) {
	if (PATHFLAGS(pathPtr) != 0) {
	    retObj = Tcl_FSGetNormalizedPath(interp, pathPtr);
	} else {
	    /* 
	     * It is a pure absolute, normalized path object.
	     * This is something like being a 'pure list'.  The
	     * object's string, translatedPath and normalizedPath
	     * are all identical.
	     */

	    retObj = srcFsPathPtr->normPathPtr;
	}
    } else {

	/* It is an ordinary path object */


	retObj = srcFsPathPtr->translatedPathPtr;
    }

    Tcl_IncrRefCount(retObj);
    return retObj;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetTranslatedStringPath --
 *
 *      This function attempts to extract the translated path
 *      from the given Tcl_Obj.  If the translation succeeds (i.e. the
 *      object is a valid path), then the path is returned.  Otherwise NULL
 *      will be returned, and an error message may be left in the
 *      interpreter (if it is non-NULL)
 *
 * Results:
 *      NULL or a valid string.
 *
 * Side effects:
 *	Only those of 'Tcl_FSConvertToPathType'
 *
 *---------------------------------------------------------------------------
 */

CONST char*
Tcl_FSGetTranslatedStringPath(interp, pathPtr)
    Tcl_Interp *interp;
    Tcl_Obj* pathPtr;
{
    Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);

    if (transPtr != NULL) {
	int len;
	CONST char *result, *orig;

	orig = Tcl_GetStringFromObj(transPtr, &len);
	result = (char*) ckalloc((unsigned)(len+1));
	memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1));
	TclDecrRefCount(transPtr);
	return result;
    }

    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetNormalizedPath --
 *
 *      This important function attempts to extract from the given Tcl_Obj
 *      a unique normalised path representation, whose string value can
 *      be used as a unique identifier for the file.
 *
 * Results:
 *      NULL or a valid path object pointer.
 *
 * Side effects:
 *	New memory may be allocated.  The Tcl 'errno' may be modified
 *      in the process of trying to examine various path possibilities.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
Tcl_FSGetNormalizedPath(interp, pathPtr)
    Tcl_Interp *interp;
    Tcl_Obj* pathPtr;
{
    FsPath *fsPathPtr;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return NULL;
    }
    fsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    if (PATHFLAGS(pathPtr) != 0) {
	/* 
	 * This is a special path object which is the result of
	 * something like 'file join' 
	 */

	Tcl_Obj *dir, *copy;
	int cwdLen;
	int pathType;
	CONST char *cwdStr;
	ClientData clientData = NULL;
	
	pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
	dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
	if (dir == NULL) {
	    return NULL;
	}
	if (pathPtr->bytes == NULL) {
	    UpdateStringOfFsPath(pathPtr);
	}
	copy = Tcl_DuplicateObj(dir);
	Tcl_IncrRefCount(copy);
	Tcl_IncrRefCount(dir);

	/*
	 * We now own a reference on both 'dir' and 'copy'
	 */
	
	cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

	/* 
	 * Should we perhaps use 'Tcl_FSPathSeparator'?
	 * But then what about the Windows special case?
	 * Perhaps we should just check if cwd is a root volume.
	 * We should never get cwdLen == 0 in this code path.
	 */

	switch (tclPlatform) {
	    case TCL_PLATFORM_UNIX:
		if (cwdStr[cwdLen-1] != '/') {
		    Tcl_AppendToObj(copy, "/", 1);
		    cwdLen++;
		}
		break;
	    case TCL_PLATFORM_WINDOWS:
		if (cwdStr[cwdLen-1] != '/' 
			&& cwdStr[cwdLen-1] != '\\') {
		    Tcl_AppendToObj(copy, "/", 1);
		    cwdLen++;
		}
		break;
	}
	Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);

	/* 
	 * Normalize the combined string, but only starting after
	 * the end of the previously normalized 'dir'.  This should
	 * be much faster!  We use 'cwdLen-1' so that we are
	 * already pointing at the dir-separator that we know about.
	 * The normalization code will actually start off directly
	 * after that separator.
	 */

	TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, 
		(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));

	/*
	 * Now we need to construct the new path object
	 */
	
	if (pathType == TCL_PATH_RELATIVE) {
	    FsPath* origDirFsPathPtr;
	    Tcl_Obj *origDir = fsPathPtr->cwdPtr;
	    origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);
	    
	    fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
	    Tcl_IncrRefCount(fsPathPtr->cwdPtr);
	    
	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;


	    /* That's our reference to copy used */


	    TclDecrRefCount(dir);
	    TclDecrRefCount(origDir);
	} else {
	    TclDecrRefCount(fsPathPtr->cwdPtr);
	    fsPathPtr->cwdPtr = NULL;
	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;


	    /* That's our reference to copy used */


	    TclDecrRefCount(dir);
	}
	if (clientData != NULL) {
	    fsPathPtr->nativePathPtr = clientData;
	}
	PATHFLAGS(pathPtr) = 0;
    }

    /*
     * Ensure cwd hasn't changed
     */

    if (fsPathPtr->cwdPtr != NULL) {
	if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
	    if (pathPtr->bytes == NULL) {
		UpdateStringOfFsPath(pathPtr);
	    }
	    FreeFsPathInternalRep(pathPtr);
	    pathPtr->typePtr = NULL;
	    if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
		return NULL;
	    }
	    fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	} else if (fsPathPtr->normPathPtr == NULL) {
	    int cwdLen;
	    Tcl_Obj *copy;
	    CONST char *cwdStr;
	    ClientData clientData = NULL;
	    
	    copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
	    Tcl_IncrRefCount(copy);
	    cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

	    /* 
	     * Should we perhaps use 'Tcl_FSPathSeparator'?
	     * But then what about the Windows special case?
	     * Perhaps we should just check if cwd is a root volume.
	     * We should never get cwdLen == 0 in this code path.
	     */

	    switch (tclPlatform) {
		case TCL_PLATFORM_UNIX:
		    if (cwdStr[cwdLen-1] != '/') {
			Tcl_AppendToObj(copy, "/", 1);
			cwdLen++;
		    }
		    break;
		case TCL_PLATFORM_WINDOWS:
		    if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {
			Tcl_AppendToObj(copy, "/", 1);
			cwdLen++;
		    }
		    break;
	    }
	    Tcl_AppendObjToObj(copy, pathPtr);

	    /* 
	     * Normalize the combined string, but only starting after
	     * the end of the previously normalized 'dir'.  This should
	     * be much faster!
	     */

	    TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, 
		    (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
	    fsPathPtr->normPathPtr = copy;
	    if (clientData != NULL) {
		fsPathPtr->nativePathPtr = clientData;
	    }
	}
    }
    if (fsPathPtr->normPathPtr == NULL) {
	ClientData clientData = NULL;
	Tcl_Obj *useThisCwd = NULL;

	/* 
	 * Since normPathPtr is NULL, but this is a valid path
	 * object, we know that the translatedPathPtr cannot be NULL.
	 */

	Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
	CONST char *path = TclGetString(absolutePath);

	/* 
	 * We have to be a little bit careful here to avoid infinite loops
	 * we're asking Tcl_FSGetPathType to return the path's type, but
	 * that call can actually result in a lot of other filesystem
	 * action, which might loop back through here.
	 */

	if (path[0] != '\0') {

	    /*
	     * We don't ask for the type of 'pathPtr' here, because
	     * that is not correct for our purposes when we have a
	     * path like '~'.  Tcl has a bit of a contradiction in
	     * that '~' paths are defined as 'absolute', but in
	     * reality can be just about anything, depending on
	     * how env(HOME) is set.
	     */

	    Tcl_PathType type = Tcl_FSGetPathType(absolutePath);

	    if (type == TCL_PATH_RELATIVE) {
		useThisCwd = Tcl_FSGetCwd(interp);

		if (useThisCwd == NULL) {
		    return NULL;
		}

		absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
		Tcl_IncrRefCount(absolutePath);


		/* We have a refCount on the cwd */

#ifdef __WIN32__
	    } else if (type == TCL_PATH_VOLUME_RELATIVE) {

		/* Only Windows has volume-relative paths */

		absolutePath = TclWinVolumeRelativeNormalize(interp, path, 
							     &useThisCwd);
		if (absolutePath == NULL) {
		    return NULL;
		}
#endif /* __WIN32__ */
	    }
	}

	/*
	 * Already has refCount incremented
	 */

	fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
		absolutePath, 
		(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
	if (0 && (clientData != NULL)) {
	    fsPathPtr->nativePathPtr = 
		(*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
	}

	/* 
	 * Check if path is pure normalized (this can only be the case
	 * if it is an absolute path).
	 */

	if (useThisCwd == NULL) {
	    if (!strcmp(TclGetString(fsPathPtr->normPathPtr),
		    TclGetString(pathPtr))) {
		/* 
		 * The path was already normalized.  
		 * Get rid of the duplicate.
		 */

		TclDecrRefCount(fsPathPtr->normPathPtr);

		/* 
		 * We do *not* increment the refCount for 
		 * this circular reference 
		 */

		fsPathPtr->normPathPtr = pathPtr;
	    }
	} else {
	    /* 
	     * We just need to free an object we allocated above for
	     * relative paths (this was returned by Tcl_FSJoinToPath
	     * above), and then of course store the cwd.
	     */

	    TclDecrRefCount(absolutePath);
	    fsPathPtr->cwdPtr = useThisCwd;
	}
    }

    return fsPathPtr->normPathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetInternalRep --
 *
 *      Extract the internal representation of a given path object,
 *      in the given filesystem.  If the path object belongs to a
 *      different filesystem, we return NULL.
 *      
 *      If the internal representation is currently NULL, we attempt
 *      to generate it, by calling the filesystem's 
 *      'Tcl_FSCreateInternalRepProc'.
 *
 * Results:
 *      NULL or a valid internal representation.
 *
 * Side effects:
 *	An attempt may be made to convert the object.
 *
 *---------------------------------------------------------------------------
 */

ClientData 
Tcl_FSGetInternalRep(pathPtr, fsPtr)
    Tcl_Obj* pathPtr;
    Tcl_Filesystem *fsPtr;
{
    FsPath* srcFsPathPtr;
    
    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    
    /* 
     * We will only return the native representation for the caller's
     * filesystem.  Otherwise we will simply return NULL. This means
     * that there must be a unique bi-directional mapping between paths
     * and filesystems, and that this mapping will not allow 'remapped'
     * files -- files which are in one filesystem but mapped into
     * another.  Another way of putting this is that 'stacked'
     * filesystems are not allowed.  We recognise that this is a
     * potentially useful feature for the future.
     * 
     * Even something simple like a 'pass through' filesystem which
     * logs all activity and passes the calls onto the native system
     * would be nice, but not easily achievable with the current
     * implementation.
     */

    if (srcFsPathPtr->fsRecPtr == NULL) {
	/* 
	 * This only usually happens in wrappers like TclpStat which
	 * create a string object and pass it to TclpObjStat.  Code
	 * which calls the Tcl_FS..  functions should always have a
	 * filesystem already set.  Whether this code path is legal or
	 * not depends on whether we decide to allow external code to
	 * call the native filesystem directly.  It is at least safer
	 * to allow this sub-optimal routing.
	 */

	Tcl_FSGetFileSystemForPath(pathPtr);
	
	/* 
	 * If we fail through here, then the path is probably not a
	 * valid path in the filesystsem, and is most likely to be a
	 * use of the empty path "" via a direct call to one of the
	 * objectified interfaces (e.g. from the Tcl testsuite).
	 */

	srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (srcFsPathPtr->fsRecPtr == NULL) {
	    return NULL;
	}
    }

    /* 
     * There is still one possibility we should consider; if the file
     * belongs to a different filesystem, perhaps it is actually
     * linked through to a file in our own filesystem which we do care
     * about.  The way we can check for this is we ask what filesystem
     * this path belongs to.
     */

    if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
	Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);

	if (actualFs == fsPtr) {
	    return Tcl_FSGetInternalRep(pathPtr, fsPtr);







|
|
|
|
|
|
|
>
>
>
>
>
>

|
|
<
















|


|


>
>
|
>
>














>
>
>
>
>
>
>
>
>
>
>
>
>



>
|
>
>
















|

|
|
|
|
|
|
|
<




|
|
|
|



|
|
|
|
|
|
|
<
|
|
|











|
|
|

|




















|
>
|
>
>






|









>
>
|
>
>

>
>
|
>
>


















|
|
|
|
|
<
|
|
|
|
|


|

















|

|



|
|
|
|

>









|
|


>
>
|
>
>





|













|
|
|
<
|


|







|















|
|
|
|
<

>



>
|
>
>












|
|
|
|
<


|

















>















|
|
|


|


|
|




|












|
|
|







|















|


|
|
<
|
|



|
|
|
|
|
|
|
|
<
|
|
|
|



|
|
|
<
|
|
|


|





|




|


|


>
>
|
>
>







>
>
|
>
>









|


















|




|
|
|
|
|



|
|
|
|
|
|
|
|
|
|
|
|



|
|
|
<


|











|
|
|





|

|
|
|



<

|
|
|
<
|
|













>
>
|
>


>
|
>
|
|








|



|


|



|
|
|





|
|
<




|
|
|





|
|
|
|















|
|
|
|
|
|
|


|







|





|




|
|

|
|
|
|
|
<
|
|
|
|
|
<



|
|
|
|
|
<
|
|



|
|
|
|
|
|








|
|
|
|
|
<







1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262

1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348

1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366

1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460

1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537

1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568

1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593

1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687

1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700

1701
1702
1703
1704
1705
1706
1707
1708
1709
1710

1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808

1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838

1839
1840
1841
1842

1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964

1965
1966
1967
1968
1969

1970
1971
1972
1973
1974
1975
1976
1977

1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001

2002
2003
2004
2005
2006
2007
2008
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSMakePathRelative --
 *
 *	Only for internal use.
 *
 *	Takes a path and a directory, where we _assume_ both path and
 *	directory are absolute, normalized and that the path lies inside the
 *	directory.  Returns a Tcl_Obj representing filename of the path
 *	relative to the directory.
 *
 *	In the case where the resulting path would start with a '~', we take
 *	special care to return an ordinary string.  This means to use that
 *	path (and not have it interpreted as a user name), one must prepend
 *	'./'.  This may seem strange, but that is how 'glob' is currently
 *	defined.
 *
 * Results:
 *	NULL on error, otherwise a valid object, typically with refCount of
 *	zero, which it is assumed the caller will increment.

 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclFSMakePathRelative(interp, pathPtr, cwdPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr;		/* The path we have. */
    Tcl_Obj *cwdPtr;		/* Make it relative to this. */
{
    int cwdLen, len;
    CONST char *tempStr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (pathPtr->typePtr == &tclFsPathType) {
	FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (PATHFLAGS(pathPtr) != 0
		&& fsPathPtr->cwdPtr == cwdPtr) {
	    pathPtr = fsPathPtr->normPathPtr;

	    /*
	     * Free old representation.
	     */

	    if (pathPtr->typePtr != NULL) {
		if (pathPtr->bytes == NULL) {
		    if (pathPtr->typePtr->updateStringProc == NULL) {
			if (interp != NULL) {
			    Tcl_ResetResult(interp);
			    Tcl_AppendResult(interp, "can't find object",
				    "string representation", (char *) NULL);
			}
			return NULL;
		    }
		    pathPtr->typePtr->updateStringProc(pathPtr);
		}
		TclFreeIntRep(pathPtr);
	    }

	    /*
	     * Now pathPtr is a string object.
	     */

	    if (Tcl_GetString(pathPtr)[0] == '~') {
		/*
		 * If the first character of the path is a tilde, we must just
		 * return the path as is, to agree with the defined behaviour
		 * of 'glob'.
		 */
		return pathPtr;
	    }

	    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));

	    /*
	     * Circular reference, by design.
	     */

	    fsPathPtr->translatedPathPtr = pathPtr;
	    fsPathPtr->normPathPtr = NULL;
	    fsPathPtr->cwdPtr = cwdPtr;
	    Tcl_IncrRefCount(cwdPtr);
	    fsPathPtr->nativePathPtr = NULL;
	    fsPathPtr->fsRecPtr = NULL;
	    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

	    PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
	    PATHFLAGS(pathPtr) = 0;
	    pathPtr->typePtr = &tclFsPathType;

	    return pathPtr;
	}
    }

    /*
     * We know the cwd is a normalised object which does not end in a
     * directory delimiter, unless the cwd is the name of a volume, in which
     * case it will end in a delimiter! We handle this situation here. A
     * better test than the '!= sep' might be to simply check if 'cwd' is a
     * root volume.
     *
     * Note that if we get this wrong, we will strip off either too much or
     * too little below, leading to wrong answers returned by glob.

     */

    tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);

    /*
     * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
     * Windows special case? Perhaps we should just check if cwd is a root
     * volume.
     */

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	if (tempStr[cwdLen-1] != '/') {
	    cwdLen++;
	}
	break;
    case TCL_PLATFORM_WINDOWS:
	if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') {

	    cwdLen++;
	}
	break;
    }
    tempStr = Tcl_GetStringFromObj(pathPtr, &len);

    return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSMakePathFromNormalized --
 *
 *	Like SetFsPathFromAny, but assumes the given object is an absolute
 *	normalized path. Only for internal use.
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

int
TclFSMakePathFromNormalized(interp, pathPtr, nativeRep)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr;		/* The object to convert. */
    ClientData nativeRep;	/* The native rep for the object, if known
				 * else NULL. */
{
    FsPath *fsPathPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (pathPtr->typePtr == &tclFsPathType) {
	return TCL_OK;
    }

    /*
     * Free old representation
     */

    if (pathPtr->typePtr != NULL) {
	if (pathPtr->bytes == NULL) {
	    if (pathPtr->typePtr->updateStringProc == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "can't find object",
			    "string representation", (char *) NULL);
		}
		return TCL_ERROR;
	    }
	    pathPtr->typePtr->updateStringProc(pathPtr);
	}
	TclFreeIntRep(pathPtr);
    }

    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));

    /*
     * It's a pure normalized absolute path.
     */

    fsPathPtr->translatedPathPtr = NULL;

    /*
     * Circular reference by design.
     */

    fsPathPtr->normPathPtr = pathPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = nativeRep;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
    PATHFLAGS(pathPtr) = 0;
    pathPtr->typePtr = &tclFsPathType;

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSNewNativePath --
 *
 *	This function performs the something like the reverse of the usual
 *	obj->path->nativerep conversions. If some code retrieves a path in
 *	native form (from, e.g. readlink or a native dialog), and that path is
 *	to be used at the Tcl level, then calling this function is an
 *	efficient way of creating the appropriate path object type.

 *
 *	Any memory which is allocated for 'clientData' should be retained
 *	until clientData is passed to the filesystem's freeInternalRepProc
 *	when it can be freed. The built in platform-specific filesystems use
 *	'ckalloc' to allocate clientData, and ckfree to free it.
 *
 * Results:
 *	NULL or a valid path object pointer, with refCount zero.
 *
 * Side effects:
 *	New memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
    Tcl_Filesystem* fromFilesystem;
    ClientData clientData;
{
    Tcl_Obj *pathPtr;
    FsPath *fsPathPtr;

    FilesystemRecord *fsFromPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
	    &fsFromPtr);
    if (pathPtr == NULL) {
	return NULL;
    }

    /*
     * Free old representation; shouldn't normally be any, but best to be
     * safe.
     */

    if (pathPtr->typePtr != NULL) {
	if (pathPtr->bytes == NULL) {
	    if (pathPtr->typePtr->updateStringProc == NULL) {
		return NULL;
	    }
	    pathPtr->typePtr->updateStringProc(pathPtr);
	}
	TclFreeIntRep(pathPtr);
    }

    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));

    fsPathPtr->translatedPathPtr = NULL;

    /*
     * Circular reference, by design.
     */

    fsPathPtr->normPathPtr = pathPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = clientData;
    fsPathPtr->fsRecPtr = fsFromPtr;
    fsPathPtr->fsRecPtr->fileRefCount++;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
    PATHFLAGS(pathPtr) = 0;
    pathPtr->typePtr = &tclFsPathType;

    return pathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetTranslatedPath --
 *
 *	This function attempts to extract the translated path from the given
 *	Tcl_Obj. If the translation succeeds (i.e. the object is a valid
 *	path), then it is returned. Otherwise NULL will be returned, and an

 *	error message may be left in the interpreter (if it is non-NULL)
 *
 * Results:
 *	NULL or a valid Tcl_Obj pointer.
 *
 * Side effects:
 *	Only those of 'Tcl_FSConvertToPathType'
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSGetTranslatedPath(interp, pathPtr)
    Tcl_Interp *interp;
    Tcl_Obj* pathPtr;
{
    Tcl_Obj *retObj = NULL;
    FsPath *srcFsPathPtr;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    if (srcFsPathPtr->translatedPathPtr == NULL) {
	if (PATHFLAGS(pathPtr) != 0) {
	    retObj = Tcl_FSGetNormalizedPath(interp, pathPtr);
	} else {
	    /*
	     * It is a pure absolute, normalized path object.  This is
	     * something like being a 'pure list'.  The object's string,
	     * translatedPath and normalizedPath are all identical.

	     */

	    retObj = srcFsPathPtr->normPathPtr;
	}
    } else {
	/*
	 * It is an ordinary path object.
	 */

	retObj = srcFsPathPtr->translatedPathPtr;
    }

    Tcl_IncrRefCount(retObj);
    return retObj;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetTranslatedStringPath --
 *
 *	This function attempts to extract the translated path from the given
 *	Tcl_Obj. If the translation succeeds (i.e. the object is a valid
 *	path), then the path is returned. Otherwise NULL will be returned, and
 *	an error message may be left in the interpreter (if it is non-NULL)

 *
 * Results:
 *	NULL or a valid string.
 *
 * Side effects:
 *	Only those of 'Tcl_FSConvertToPathType'
 *
 *---------------------------------------------------------------------------
 */

CONST char*
Tcl_FSGetTranslatedStringPath(interp, pathPtr)
    Tcl_Interp *interp;
    Tcl_Obj* pathPtr;
{
    Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);

    if (transPtr != NULL) {
	int len;
	CONST char *result, *orig;

	orig = Tcl_GetStringFromObj(transPtr, &len);
	result = (char*) ckalloc((unsigned)(len+1));
	memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1));
	TclDecrRefCount(transPtr);
	return result;
    }

    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetNormalizedPath --
 *
 *	This important function attempts to extract from the given Tcl_Obj a
 *	unique normalised path representation, whose string value can be used
 *	as a unique identifier for the file.
 *
 * Results:
 *	NULL or a valid path object pointer.
 *
 * Side effects:
 *	New memory may be allocated.  The Tcl 'errno' may be modified in the
 *	process of trying to examine various path possibilities.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSGetNormalizedPath(interp, pathPtr)
    Tcl_Interp *interp;
    Tcl_Obj* pathPtr;
{
    FsPath *fsPathPtr;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return NULL;
    }
    fsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    if (PATHFLAGS(pathPtr) != 0) {
	/*
	 * This is a special path object which is the result of something like
	 * 'file join'
	 */

	Tcl_Obj *dir, *copy;
	int cwdLen;
	int pathType;
	CONST char *cwdStr;
	ClientData clientData = NULL;

	pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
	dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
	if (dir == NULL) {
	    return NULL;
	}
	if (pathPtr->bytes == NULL) {
	    UpdateStringOfFsPath(pathPtr);
	}
	copy = Tcl_DuplicateObj(dir);
	Tcl_IncrRefCount(copy);
	Tcl_IncrRefCount(dir);

	/*
	 * We now own a reference on both 'dir' and 'copy'
	 */

	cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

	/*
	 * Should we perhaps use 'Tcl_FSPathSeparator'?  But then what about

	 * the Windows special case?  Perhaps we should just check if cwd is a
	 * root volume.  We should never get cwdLen == 0 in this code path.
	 */

	switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    if (cwdStr[cwdLen-1] != '/') {
		Tcl_AppendToObj(copy, "/", 1);
		cwdLen++;
	    }
	    break;
	case TCL_PLATFORM_WINDOWS:
	    if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {

		Tcl_AppendToObj(copy, "/", 1);
		cwdLen++;
	    }
	    break;
	}
	Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);

	/*
	 * Normalize the combined string, but only starting after the end of
	 * the previously normalized 'dir'.  This should be much faster!  We

	 * use 'cwdLen-1' so that we are already pointing at the dir-separator
	 * that we know about.  The normalization code will actually start off
	 * directly after that separator.
	 */

	TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
		(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));

	/*
	 * Now we need to construct the new path object
	 */

	if (pathType == TCL_PATH_RELATIVE) {
	    FsPath* origDirFsPathPtr;
	    Tcl_Obj *origDir = fsPathPtr->cwdPtr;
	    origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);

	    fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
	    Tcl_IncrRefCount(fsPathPtr->cwdPtr);

	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;

	    /*
	     * That's our reference to copy used.
	     */

	    TclDecrRefCount(dir);
	    TclDecrRefCount(origDir);
	} else {
	    TclDecrRefCount(fsPathPtr->cwdPtr);
	    fsPathPtr->cwdPtr = NULL;
	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;

	    /*
	     * That's our reference to copy used.
	     */

	    TclDecrRefCount(dir);
	}
	if (clientData != NULL) {
	    fsPathPtr->nativePathPtr = clientData;
	}
	PATHFLAGS(pathPtr) = 0;
    }

    /*
     * Ensure cwd hasn't changed.
     */

    if (fsPathPtr->cwdPtr != NULL) {
	if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
	    if (pathPtr->bytes == NULL) {
		UpdateStringOfFsPath(pathPtr);
	    }
	    FreeFsPathInternalRep(pathPtr);
	    pathPtr->typePtr = NULL;
	    if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
		return NULL;
	    }
	    fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	} else if (fsPathPtr->normPathPtr == NULL) {
	    int cwdLen;
	    Tcl_Obj *copy;
	    CONST char *cwdStr;
	    ClientData clientData = NULL;

	    copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
	    Tcl_IncrRefCount(copy);
	    cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

	    /*
	     * Should we perhaps use 'Tcl_FSPathSeparator'?  But then what
	     * about the Windows special case?  Perhaps we should just check
	     * if cwd is a root volume.  We should never get cwdLen == 0 in
	     * this code path.
	     */

	    switch (tclPlatform) {
	    case TCL_PLATFORM_UNIX:
		if (cwdStr[cwdLen-1] != '/') {
		    Tcl_AppendToObj(copy, "/", 1);
		    cwdLen++;
		}
		break;
	    case TCL_PLATFORM_WINDOWS:
		if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {
		    Tcl_AppendToObj(copy, "/", 1);
		    cwdLen++;
		}
		break;
	    }
	    Tcl_AppendObjToObj(copy, pathPtr);

	    /*
	     * Normalize the combined string, but only starting after the end
	     * of the previously normalized 'dir'. This should be much faster!

	     */

	    TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
		    (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
	    fsPathPtr->normPathPtr = copy;
	    if (clientData != NULL) {
		fsPathPtr->nativePathPtr = clientData;
	    }
	}
    }
    if (fsPathPtr->normPathPtr == NULL) {
	ClientData clientData = NULL;
	Tcl_Obj *useThisCwd = NULL;

	/*
	 * Since normPathPtr is NULL, but this is a valid path object, we know
	 * that the translatedPathPtr cannot be NULL.
	 */

	Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
	CONST char *path = TclGetString(absolutePath);

	/*
	 * We have to be a little bit careful here to avoid infinite loops
	 * we're asking Tcl_FSGetPathType to return the path's type, but that
	 * call can actually result in a lot of other filesystem action, which
	 * might loop back through here.
	 */

	if (path[0] != '\0') {

	    /*
	     * We don't ask for the type of 'pathPtr' here, because that is
	     * not correct for our purposes when we have a path like '~'. Tcl
	     * has a bit of a contradiction in that '~' paths are defined as

	     * 'absolute', but in reality can be just about anything,
	     * depending on how env(HOME) is set.
	     */

	    Tcl_PathType type = Tcl_FSGetPathType(absolutePath);

	    if (type == TCL_PATH_RELATIVE) {
		useThisCwd = Tcl_FSGetCwd(interp);

		if (useThisCwd == NULL) {
		    return NULL;
		}

		absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
		Tcl_IncrRefCount(absolutePath);

		/*
		 * We have a refCount on the cwd.
		 */
#ifdef __WIN32__
	    } else if (type == TCL_PATH_VOLUME_RELATIVE) {
		/*
		 * Only Windows has volume-relative paths.
		 */
		absolutePath = TclWinVolumeRelativeNormalize(interp,
			path, &useThisCwd);
		if (absolutePath == NULL) {
		    return NULL;
		}
#endif /* __WIN32__ */
	    }
	}

	/*
	 * Already has refCount incremented.
	 */

	fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
		absolutePath,
		(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
	if (0 && (clientData != NULL)) {
	    fsPathPtr->nativePathPtr =
		(*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
	}

	/*
	 * Check if path is pure normalized (this can only be the case if it
	 * is an absolute path).
	 */

	if (useThisCwd == NULL) {
	    if (!strcmp(TclGetString(fsPathPtr->normPathPtr),
		    TclGetString(pathPtr))) {
		/*
		 * The path was already normalized. Get rid of the duplicate.

		 */

		TclDecrRefCount(fsPathPtr->normPathPtr);

		/*
		 * We do *not* increment the refCount for this circular
		 * reference.
		 */

		fsPathPtr->normPathPtr = pathPtr;
	    }
	} else {
	    /*
	     * We just need to free an object we allocated above for relative
	     * paths (this was returned by Tcl_FSJoinToPath above), and then
	     * of course store the cwd.
	     */

	    TclDecrRefCount(absolutePath);
	    fsPathPtr->cwdPtr = useThisCwd;
	}
    }

    return fsPathPtr->normPathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetInternalRep --
 *
 *	Extract the internal representation of a given path object, in the
 *	given filesystem.  If the path object belongs to a different
 *	filesystem, we return NULL.
 *
 *	If the internal representation is currently NULL, we attempt to
 *	generate it, by calling the filesystem's
 *	'Tcl_FSCreateInternalRepProc'.
 *
 * Results:
 *	NULL or a valid internal representation.
 *
 * Side effects:
 *	An attempt may be made to convert the object.
 *
 *---------------------------------------------------------------------------
 */

ClientData
Tcl_FSGetInternalRep(pathPtr, fsPtr)
    Tcl_Obj* pathPtr;
    Tcl_Filesystem *fsPtr;
{
    FsPath* srcFsPathPtr;

    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    /*
     * We will only return the native representation for the caller's
     * filesystem.  Otherwise we will simply return NULL. This means that
     * there must be a unique bi-directional mapping between paths and
     * filesystems, and that this mapping will not allow 'remapped' files --
     * files which are in one filesystem but mapped into another.  Another way
     * of putting this is that 'stacked' filesystems are not allowed.  We

     * recognise that this is a potentially useful feature for the future.
     *
     * Even something simple like a 'pass through' filesystem which logs all
     * activity and passes the calls onto the native system would be nice, but
     * not easily achievable with the current implementation.

     */

    if (srcFsPathPtr->fsRecPtr == NULL) {
	/*
	 * This only usually happens in wrappers like TclpStat which create a
	 * string object and pass it to TclpObjStat. Code which calls the
	 * Tcl_FS.. functions should always have a filesystem already set.
	 * Whether this code path is legal or not depends on whether we decide

	 * to allow external code to call the native filesystem directly.  It
	 * is at least safer to allow this sub-optimal routing.
	 */

	Tcl_FSGetFileSystemForPath(pathPtr);

	/*
	 * If we fail through here, then the path is probably not a valid path
	 * in the filesystsem, and is most likely to be a use of the empty
	 * path "" via a direct call to one of the objectified interfaces
	 * (e.g. from the Tcl testsuite).
	 */

	srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
	if (srcFsPathPtr->fsRecPtr == NULL) {
	    return NULL;
	}
    }

    /*
     * There is still one possibility we should consider; if the file belongs
     * to a different filesystem, perhaps it is actually linked through to a
     * file in our own filesystem which we do care about.  The way we can
     * check for this is we ask what filesystem this path belongs to.

     */

    if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
	Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);

	if (actualFs == fsPtr) {
	    return Tcl_FSGetInternalRep(pathPtr, fsPtr);
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSEnsureEpochOk --
 *
 *      This will ensure the pathPtr is up to date and can be
 *      converted into a "path" type, and that we are able to generate a
 *      complete normalized path which is used to determine the
 *      filesystem match.
 *
 * Results:
 *      Standard Tcl return code.
 *
 * Side effects:
 *	An attempt may be made to convert the object.
 *
 *---------------------------------------------------------------------------
 */

int 
TclFSEnsureEpochOk(pathPtr, fsPtrPtr)
    Tcl_Obj* pathPtr;
    Tcl_Filesystem **fsPtrPtr;
{
    FsPath* srcFsPathPtr;

    if (pathPtr->typePtr != &tclFsPathType) {
	return TCL_OK;
    }

    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    /* 
     * Check if the filesystem has changed in some way since
     * this object's internal representation was calculated.
     */

    if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
	/* 
	 * We have to discard the stale representation and 
	 * recalculate it 
	 */

	if (pathPtr->bytes == NULL) {
	    UpdateStringOfFsPath(pathPtr);
	}
	FreeFsPathInternalRep(pathPtr);
	pathPtr->typePtr = NULL;
	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    }

    /*
     * Check whether the object is already assigned to a fs
     */

    if (srcFsPathPtr->fsRecPtr != NULL) {
	*fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
    }
    return TCL_OK;
}







|
|
|
<


|







|












|
|
|



|
|
<














|







2024
2025
2026
2027
2028
2029
2030
2031
2032
2033

2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064

2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSEnsureEpochOk --
 *
 *	This will ensure the pathPtr is up to date and can be converted into a
 *	"path" type, and that we are able to generate a complete normalized
 *	path which is used to determine the filesystem match.

 *
 * Results:
 *	Standard Tcl return code.
 *
 * Side effects:
 *	An attempt may be made to convert the object.
 *
 *---------------------------------------------------------------------------
 */

int
TclFSEnsureEpochOk(pathPtr, fsPtrPtr)
    Tcl_Obj* pathPtr;
    Tcl_Filesystem **fsPtrPtr;
{
    FsPath* srcFsPathPtr;

    if (pathPtr->typePtr != &tclFsPathType) {
	return TCL_OK;
    }

    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    /*
     * Check if the filesystem has changed in some way since this object's
     * internal representation was calculated.
     */

    if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
	/*
	 * We have to discard the stale representation and recalculate it.

	 */

	if (pathPtr->bytes == NULL) {
	    UpdateStringOfFsPath(pathPtr);
	}
	FreeFsPathInternalRep(pathPtr);
	pathPtr->typePtr = NULL;
	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    }

    /*
     * Check whether the object is already assigned to a fs.
     */

    if (srcFsPathPtr->fsRecPtr != NULL) {
	*fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
    }
    return TCL_OK;
}
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053

2054


2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249

2250
2251

2252

2253
2254
2255
2256
2257
2258
2259
2260
2261
2262

2263


2264


2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
 *
 * Side effects:
 *	???
 *
 *---------------------------------------------------------------------------
 */

void 
TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) 
    Tcl_Obj *pathPtr;
    FilesystemRecord *fsRecPtr;
    ClientData clientData;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    FsPath* srcFsPathPtr;
    

    /* Make sure pathPtr is of the correct type */


    if (pathPtr->typePtr != &tclFsPathType) {
	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
	    return;
	}
    }
    
    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    srcFsPathPtr->fsRecPtr = fsRecPtr;
    srcFsPathPtr->nativePathPtr = clientData;
    srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 
    fsRecPtr->fileRefCount++;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSEqualPaths --
 *
 *      This function tests whether the two paths given are equal path
 *      objects.  If either or both is NULL, 0 is always returned.
 *
 * Results:
 *      1 or 0.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int 
Tcl_FSEqualPaths(firstPtr, secondPtr)
    Tcl_Obj* firstPtr;
    Tcl_Obj* secondPtr;
{
    char *firstStr, *secondStr;
    int firstLen, secondLen, tempErrno;

    if (firstPtr == secondPtr) {
	return 1;
    }

    if (firstPtr == NULL || secondPtr == NULL) {
	return 0;
    }
    firstStr  = Tcl_GetStringFromObj(firstPtr, &firstLen);
    secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
    if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
	return 1;
    }

    /* 
     * Try the most thorough, correct method of comparing fully
     * normalized paths
     */

    tempErrno = Tcl_GetErrno();
    firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
    secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
    Tcl_SetErrno(tempErrno);

    if (firstPtr == NULL || secondPtr == NULL) {
	return 0;
    }

    firstStr  = Tcl_GetStringFromObj(firstPtr, &firstLen);
    secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
    return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0);
}

/*
 *---------------------------------------------------------------------------
 *
 * SetFsPathFromAny --
 *
 *      This function tries to convert the given Tcl_Obj to a valid
 *      Tcl path type.
 *      
 *      The filename may begin with "~" (to indicate current user's
 *      home directory) or "~<user>" (to indicate any user's home
 *      directory).
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

static int
SetFsPathFromAny(interp, pathPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr;		/* The object to convert. */
{
    int len;
    FsPath *fsPathPtr;
    Tcl_Obj *transPtr;
    char *name;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    
    if (pathPtr->typePtr == &tclFsPathType) {
	return TCL_OK;
    }
    
    /* 
     * First step is to translate the filename.  This is similar to
     * Tcl_TranslateFilename, but shouldn't convert everything to
     * windows backslashes on that platform.  The current
     * implementation of this piece is a slightly optimised version
     * of the various Tilde/Split/Join stuff to avoid multiple
     * split/join operations.
     * 
     * We remove any trailing directory separator.
     * 
     * However, the split/join routines are quite complex, and
     * one has to make sure not to break anything on Unix or Win
     * (fCmd.test, fileName.test and cmdAH.test exercise
     * most of the code).
     */

    name = Tcl_GetStringFromObj(pathPtr, &len);

    /*
     * Handle tilde substitutions, if needed.
     */

    if (name[0] == '~') {
	char *expandedUser;
	Tcl_DString temp;
	int split;
	char separator='/';
	
	split = FindSplitPos(name, separator);
	if (split != len) {
	    /* We have multiple pieces '~user/foo/bar...' */
	    name[split] = '\0';
	}

	/*
	 * Do some tilde substitution
	 */

	if (name[1] == '\0') {
	    /*
	     * We have just '~'
	     */

	    CONST char *dir;
	    Tcl_DString dirString;

	    if (split != len) {
		name[split] = separator;
	    }
	    
	    dir = TclGetEnv("HOME", &dirString);
	    if (dir == NULL) {
		if (interp) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't find HOME environment ",
			    "variable to expand path", (char *) NULL);
		}
		return TCL_ERROR;
	    }
	    Tcl_DStringInit(&temp);
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */

	    Tcl_DStringInit(&temp);
	    if (TclpGetUserHome(name+1, &temp) == NULL) {	
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "user \"", (name+1), 
				     "\" doesn't exist", (char *) NULL);
		}
		Tcl_DStringFree(&temp);
		if (split != len) {
		    name[split] = separator;
		}
		return TCL_ERROR;
	    }
	    if (split != len) {
		name[split] = separator;
	    }
	}
	
	expandedUser = Tcl_DStringValue(&temp);
	transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));

	if (split != len) {

	    /* Join up the tilde substitution with the rest */
	    if (name[split+1] == separator) {



		/*
		 * Somewhat tricky case like ~//foo/bar.
		 * Make use of Split/Join machinery to get it right.
		 * Assumes all paths beginning with ~ are part of the
		 * native filesystem.
		 */

		int objc;
		Tcl_Obj **objv;
		Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);

		Tcl_ListObjGetElements(NULL, parts, &objc, &objv);


		/* Skip '~'.  It's replaced by its expansion */


		objc--; objv++;
		while (objc--) {
		    TclpNativeJoinPath(transPtr, TclGetString(*objv++));
		}
		TclDecrRefCount(parts);
	    } else {
		/* 
		 * Simple case. "rest" is relative path.  Just join it. 
		 * The "rest" object will be freed when
		 * Tcl_FSJoinToPath returns (unless something else
		 * claims a refCount on it).
		 */

		Tcl_Obj *joined;
		Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1);

		Tcl_IncrRefCount(transPtr);
		joined = Tcl_FSJoinToPath(transPtr, 1, &rest);







|
|






|
>
|
>
>





|



|








|
|


|







|




















|
|
|











|









|
|
|
|
|
<


|

















|



|
|
|
|
|
<
|
|
|

|
|
|
<
|













|







|













|


















|


|
|











|




>
|
<
>

>

|
|
|
<





>

>
>
|
>
>






|
|
|
<
|







2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196

2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225

2226
2227
2228
2229
2230
2231
2232

2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310

2311
2312
2313
2314
2315
2316
2317

2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338

2339
2340
2341
2342
2343
2344
2345
2346
 *
 * Side effects:
 *	???
 *
 *---------------------------------------------------------------------------
 */

void
TclFSSetPathDetails(pathPtr, fsRecPtr, clientData)
    Tcl_Obj *pathPtr;
    FilesystemRecord *fsRecPtr;
    ClientData clientData;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    FsPath* srcFsPathPtr;

    /*
     * Make sure pathPtr is of the correct type.
     */

    if (pathPtr->typePtr != &tclFsPathType) {
	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
	    return;
	}
    }

    srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    srcFsPathPtr->fsRecPtr = fsRecPtr;
    srcFsPathPtr->nativePathPtr = clientData;
    srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
    fsRecPtr->fileRefCount++;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSEqualPaths --
 *
 *	This function tests whether the two paths given are equal path
 *	objects. If either or both is NULL, 0 is always returned.
 *
 * Results:
 *	1 or 0.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSEqualPaths(firstPtr, secondPtr)
    Tcl_Obj* firstPtr;
    Tcl_Obj* secondPtr;
{
    char *firstStr, *secondStr;
    int firstLen, secondLen, tempErrno;

    if (firstPtr == secondPtr) {
	return 1;
    }

    if (firstPtr == NULL || secondPtr == NULL) {
	return 0;
    }
    firstStr  = Tcl_GetStringFromObj(firstPtr, &firstLen);
    secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
    if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
	return 1;
    }

    /*
     * Try the most thorough, correct method of comparing fully normalized
     * paths.
     */

    tempErrno = Tcl_GetErrno();
    firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
    secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
    Tcl_SetErrno(tempErrno);

    if (firstPtr == NULL || secondPtr == NULL) {
	return 0;
    }

    firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
    secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
    return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0);
}

/*
 *---------------------------------------------------------------------------
 *
 * SetFsPathFromAny --
 *
 *	This function tries to convert the given Tcl_Obj to a valid Tcl path
 *	type.
 *
 *	The filename may begin with "~" (to indicate current user's home
 *	directory) or "~<user>" (to indicate any user's home directory).

 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
 *---------------------------------------------------------------------------
 */

static int
SetFsPathFromAny(interp, pathPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr;		/* The object to convert. */
{
    int len;
    FsPath *fsPathPtr;
    Tcl_Obj *transPtr;
    char *name;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (pathPtr->typePtr == &tclFsPathType) {
	return TCL_OK;
    }

    /*
     * First step is to translate the filename. This is similar to
     * Tcl_TranslateFilename, but shouldn't convert everything to windows
     * backslashes on that platform. The current implementation of this piece

     * is a slightly optimised version of the various Tilde/Split/Join stuff
     * to avoid multiple split/join operations.
     *
     * We remove any trailing directory separator.
     *
     * However, the split/join routines are quite complex, and one has to make
     * sure not to break anything on Unix or Win (fCmd.test, fileName.test and

     * cmdAH.test exercise most of the code).
     */

    name = Tcl_GetStringFromObj(pathPtr, &len);

    /*
     * Handle tilde substitutions, if needed.
     */

    if (name[0] == '~') {
	char *expandedUser;
	Tcl_DString temp;
	int split;
	char separator='/';

	split = FindSplitPos(name, separator);
	if (split != len) {
	    /* We have multiple pieces '~user/foo/bar...' */
	    name[split] = '\0';
	}

	/*
	 * Do some tilde substitution.
	 */

	if (name[1] == '\0') {
	    /*
	     * We have just '~'
	     */

	    CONST char *dir;
	    Tcl_DString dirString;

	    if (split != len) {
		name[split] = separator;
	    }

	    dir = TclGetEnv("HOME", &dirString);
	    if (dir == NULL) {
		if (interp) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't find HOME environment ",
			    "variable to expand path", (char *) NULL);
		}
		return TCL_ERROR;
	    }
	    Tcl_DStringInit(&temp);
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */

	    Tcl_DStringInit(&temp);
	    if (TclpGetUserHome(name+1, &temp) == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "user \"", (name+1),
			    "\" doesn't exist", (char *) NULL);
		}
		Tcl_DStringFree(&temp);
		if (split != len) {
		    name[split] = separator;
		}
		return TCL_ERROR;
	    }
	    if (split != len) {
		name[split] = separator;
	    }
	}

	expandedUser = Tcl_DStringValue(&temp);
	transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));

	if (split != len) {
	    /*
	     * Join up the tilde substitution with the rest.

	     */

	    if (name[split+1] == separator) {
		/*
		 * Somewhat tricky case like ~//foo/bar. Make use of
		 * Split/Join machinery to get it right. Assumes all paths
		 * beginning with ~ are part of the native filesystem.

		 */

		int objc;
		Tcl_Obj **objv;
		Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);

		Tcl_ListObjGetElements(NULL, parts, &objc, &objv);

		/*
		 * Skip '~'. It's replaced by its expansion.
		 */

		objc--; objv++;
		while (objc--) {
		    TclpNativeJoinPath(transPtr, TclGetString(*objv++));
		}
		TclDecrRefCount(parts);
	    } else {
		/*
		 * Simple case. "rest" is relative path. Just join it. The
		 * "rest" object will be freed when Tcl_FSJoinToPath returns

		 * (unless something else claims a refCount on it).
		 */

		Tcl_Obj *joined;
		Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1);

		Tcl_IncrRefCount(transPtr);
		joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330

#if defined(__CYGWIN__) && defined(__WIN32__)
    {
	extern int cygwin_conv_to_win32_path(CONST char *, char *);
	char winbuf[MAX_PATH+1];

	/*
	 * In the Cygwin world, call conv_to_win32_path in order to
	 * use the mount table to translate the file name into
	 * something Windows will understand.  Take care when
	 * converting empty strings!
	 */

	name = Tcl_GetStringFromObj(transPtr, &len);
	if (len > 0) {
	    cygwin_conv_to_win32_path(name, winbuf);
	    TclWinNoBackslash(winbuf);
	    Tcl_SetStringObj(transPtr, winbuf, -1);
	}
    }
#endif /* __CYGWIN__ && __WIN32__ */

    /* 
     * Now we have a translated filename in 'transPtr'.  This will have
     * forward slashes on Windows, and will not contain any ~user
     * sequences.
     */
    
    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));

    fsPathPtr->translatedPathPtr = transPtr;
    if (transPtr != pathPtr) {
        Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
    }
    fsPathPtr->normPathPtr = NULL;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;








|
|
<
|











|
|
|
<

|
|



|







2355
2356
2357
2358
2359
2360
2361
2362
2363

2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378

2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392

#if defined(__CYGWIN__) && defined(__WIN32__)
    {
	extern int cygwin_conv_to_win32_path(CONST char *, char *);
	char winbuf[MAX_PATH+1];

	/*
	 * In the Cygwin world, call conv_to_win32_path in order to use the
	 * mount table to translate the file name into something Windows will

	 * understand. Take care when converting empty strings!
	 */

	name = Tcl_GetStringFromObj(transPtr, &len);
	if (len > 0) {
	    cygwin_conv_to_win32_path(name, winbuf);
	    TclWinNoBackslash(winbuf);
	    Tcl_SetStringObj(transPtr, winbuf, -1);
	}
    }
#endif /* __CYGWIN__ && __WIN32__ */

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.

     */

    fsPathPtr = (FsPath *) ckalloc((unsigned)sizeof(FsPath));

    fsPathPtr->translatedPathPtr = transPtr;
    if (transPtr != pathPtr) {
	Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
    }
    fsPathPtr->normPathPtr = NULL;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
    pathPtr->typePtr = &tclFsPathType;

    return TCL_OK;
}

static void
FreeFsPathInternalRep(pathPtr)
    Tcl_Obj *pathPtr;	/* Path object with internal rep to free. */
{
    FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    if (fsPathPtr->translatedPathPtr != NULL) {
	if (fsPathPtr->translatedPathPtr != pathPtr) {
	    TclDecrRefCount(fsPathPtr->translatedPathPtr);
	}







|







2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
    pathPtr->typePtr = &tclFsPathType;

    return TCL_OK;
}

static void
FreeFsPathInternalRep(pathPtr)
    Tcl_Obj *pathPtr;		/* Path object with internal rep to free. */
{
    FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);

    if (fsPathPtr->translatedPathPtr != NULL) {
	if (fsPathPtr->translatedPathPtr != pathPtr) {
	    TclDecrRefCount(fsPathPtr->translatedPathPtr);
	}
2367
2368
2369
2370
2371
2372
2373

2374


2375
2376
2377
2378
2379
2380
2381
2382
	    (*freeProc)(fsPathPtr->nativePathPtr);
	    fsPathPtr->nativePathPtr = NULL;
	}
    }
    if (fsPathPtr->fsRecPtr != NULL) {
	fsPathPtr->fsRecPtr->fileRefCount--;
	if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {

	    /* It has been unregistered already */


	    ckfree((char *)fsPathPtr->fsRecPtr);
	}
    }

    ckfree((char*) fsPathPtr);
}

static void







>
|
>
>
|







2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
	    (*freeProc)(fsPathPtr->nativePathPtr);
	    fsPathPtr->nativePathPtr = NULL;
	}
    }
    if (fsPathPtr->fsRecPtr != NULL) {
	fsPathPtr->fsRecPtr->fileRefCount--;
	if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
	    /*
	     * It has been unregistered already.
	     */

	    ckfree((char *) fsPathPtr->fsRecPtr);
	}
    }

    ckfree((char*) fsPathPtr);
}

static void
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
	copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
	if (copyFsPathPtr->translatedPathPtr != copyPtr) {
	    Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
	}
    } else {
	copyFsPathPtr->translatedPathPtr = NULL;
    }
    
    if (srcFsPathPtr->normPathPtr != NULL) {
	copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
	if (copyFsPathPtr->normPathPtr != copyPtr) {
	    Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
	}
    } else {
	copyFsPathPtr->normPathPtr = NULL;
    }
    
    if (srcFsPathPtr->cwdPtr != NULL) {
	copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
	Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
    } else {
	copyFsPathPtr->cwdPtr = NULL;
    }

    copyFsPathPtr->flags = srcFsPathPtr->flags;
    
    if (srcFsPathPtr->fsRecPtr != NULL 
	    && srcFsPathPtr->nativePathPtr != NULL) {
	Tcl_FSDupInternalRepProc *dupProc =
		srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
	if (dupProc != NULL) {
	    copyFsPathPtr->nativePathPtr = 
		    (*dupProc)(srcFsPathPtr->nativePathPtr);
	} else {
	    copyFsPathPtr->nativePathPtr = NULL;
	}
    } else {
	copyFsPathPtr->nativePathPtr = NULL;
    }







|








|








|
|




|







2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
	copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
	if (copyFsPathPtr->translatedPathPtr != copyPtr) {
	    Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
	}
    } else {
	copyFsPathPtr->translatedPathPtr = NULL;
    }

    if (srcFsPathPtr->normPathPtr != NULL) {
	copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
	if (copyFsPathPtr->normPathPtr != copyPtr) {
	    Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
	}
    } else {
	copyFsPathPtr->normPathPtr = NULL;
    }

    if (srcFsPathPtr->cwdPtr != NULL) {
	copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
	Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
    } else {
	copyFsPathPtr->cwdPtr = NULL;
    }

    copyFsPathPtr->flags = srcFsPathPtr->flags;

    if (srcFsPathPtr->fsRecPtr != NULL
	    && srcFsPathPtr->nativePathPtr != NULL) {
	Tcl_FSDupInternalRepProc *dupProc =
		srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
	if (dupProc != NULL) {
	    copyFsPathPtr->nativePathPtr =
		    (*dupProc)(srcFsPathPtr->nativePathPtr);
	} else {
	    copyFsPathPtr->nativePathPtr = NULL;
	}
    } else {
	copyFsPathPtr->nativePathPtr = NULL;
    }
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505

2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552

2553

2554
2555

2556

2557
2558
2559
2560
2561
2562
2563
2564

2565
2566

2567

2568
2569
2570
2571
2572
2573
2574
2575

2576
2577








}

/*
 *---------------------------------------------------------------------------
 *
 * UpdateStringOfFsPath --
 *
 *      Gives an object a valid string rep.
 *      
 * Results:
 *      None.
 *
 * Side effects:
 *	Memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

static void
UpdateStringOfFsPath(pathPtr)
    register Tcl_Obj *pathPtr;	/* path obj with string rep to update. */
{
    FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    CONST char *cwdStr;
    int cwdLen;
    Tcl_Obj *copy;
    
    if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
	Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
    }
    
    copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
    Tcl_IncrRefCount(copy);
    
    cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

    /* 
     * Should we perhaps use 'Tcl_FSPathSeparator'?
     * But then what about the Windows special case?
     * Perhaps we should just check if cwd is a root volume.
     * We should never get cwdLen == 0 in this code path.
     */

    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    if (cwdStr[cwdLen-1] != '/') {
		Tcl_AppendToObj(copy, "/", 1);
		cwdLen++;
	    }
	    break;

	case TCL_PLATFORM_WINDOWS:
	    /* 
	     * We need the extra 'cwdLen != 2', and ':' checks because 
	     * a volume relative path doesn't get a '/'.  For example 
	     * 'glob C:*cat*.exe' will return 'C:cat32.exe'
	     */

	    if (cwdStr[cwdLen-1] != '/'
		    && cwdStr[cwdLen-1] != '\\') {
		if (cwdLen != 2 || cwdStr[1] != ':') {
		    Tcl_AppendToObj(copy, "/", 1);
		    cwdLen++;
		}
	    }
	    break;
    }

    Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
    pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
    pathPtr->length = cwdLen;
    copy->bytes = tclEmptyStringRep;
    copy->length = 0;
    TclDecrRefCount(copy);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativePathInFilesystem --
 *
 *      Any path object is acceptable to the native filesystem, by
 *      default (we will throw errors when illegal paths are actually
 *      tried to be used).
 *      
 *      However, this behavior means the native filesystem must be
 *      the last filesystem in the lookup list (otherwise it will
 *      claim all files belong to it, and other filesystems will
 *      never get a look in).
 *
 * Results:
 *      TCL_OK, to indicate 'yes', -1 to indicate no.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int 
TclNativePathInFilesystem(pathPtr, clientDataPtr)
    Tcl_Obj *pathPtr;
    ClientData *clientDataPtr;
{
    /* 
     * A special case is required to handle the empty path "". 
     * This is a valid path (i.e. the user should be able
     * to do 'file exists ""' without throwing an error), but
     * equally the path doesn't exist.  Those are the semantics
     * of Tcl (at present anyway), so we have to abide by them
     * here.
     */

    if (pathPtr->typePtr == &tclFsPathType) {
	if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {

	    /* We reject the empty path "" */

	    return -1;
	}

	/* Otherwise there is no way this path can be empty */

    } else {
	/* 
	 * It is somewhat unusual to reach this code path without
	 * the object being of tclFsPathType.  However, we do
	 * our best to deal with the situation.
	 */

	int len;

	Tcl_GetStringFromObj(pathPtr, &len);
	if (len == 0) {

	    /* We reject the empty path "" */

	    return -1;
	}
    }

    /* 
     * Path is of correct type, or is of non-zero length, 
     * so we accept it.
     */

    return TCL_OK;
}















|
|

|















|



|


|


|
|
<
|
|



|
|
|
|
|
|

|
|
|
|
|
|

|
<
|
|
|
|
|
|

>













|
|
<
|
|
|
|
<


|







|




|
|
|
<
|
|
<




>
|
>


>
|
>

|
|
|
|



>


>
|
>




|
|
<

>


>
>
>
>
>
>
>
>
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541

2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561

2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584

2585
2586
2587
2588

2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606

2607
2608

2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640

2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
}

/*
 *---------------------------------------------------------------------------
 *
 * UpdateStringOfFsPath --
 *
 *	Gives an object a valid string rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

static void
UpdateStringOfFsPath(pathPtr)
    register Tcl_Obj *pathPtr;	/* path obj with string rep to update. */
{
    FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
    CONST char *cwdStr;
    int cwdLen;
    Tcl_Obj *copy;

    if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
	Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
    }

    copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
    Tcl_IncrRefCount(copy);

    cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

    /*
     * Should we perhaps use 'Tcl_FSPathSeparator'?  But then what about the

     * Windows special case?  Perhaps we should just check if cwd is a root
     * volume.  We should never get cwdLen == 0 in this code path.
     */

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	if (cwdStr[cwdLen-1] != '/') {
	    Tcl_AppendToObj(copy, "/", 1);
	    cwdLen++;
	}
	break;

    case TCL_PLATFORM_WINDOWS:
	/*
	 * We need the extra 'cwdLen != 2', and ':' checks because a volume
	 * relative path doesn't get a '/'. For example 'glob C:*cat*.exe'
	 * will return 'C:cat32.exe'
	 */

	if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {

	    if (cwdLen != 2 || cwdStr[1] != ':') {
		Tcl_AppendToObj(copy, "/", 1);
		cwdLen++;
	    }
	}
	break;
    }

    Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
    pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
    pathPtr->length = cwdLen;
    copy->bytes = tclEmptyStringRep;
    copy->length = 0;
    TclDecrRefCount(copy);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativePathInFilesystem --
 *
 *	Any path object is acceptable to the native filesystem, by default (we
 *	will throw errors when illegal paths are actually tried to be used).

 *
 *	However, this behavior means the native filesystem must be the last
 *	filesystem in the lookup list (otherwise it will claim all files
 *	belong to it, and other filesystems will never get a look in).

 *
 * Results:
 *	TCL_OK, to indicate 'yes', -1 to indicate no.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclNativePathInFilesystem(pathPtr, clientDataPtr)
    Tcl_Obj *pathPtr;
    ClientData *clientDataPtr;
{
    /*
     * A special case is required to handle the empty path "". This is a valid
     * path (i.e. the user should be able to do 'file exists ""' without

     * throwing an error), but equally the path doesn't exist. Those are the
     * semantics of Tcl (at present anyway), so we have to abide by them here.

     */

    if (pathPtr->typePtr == &tclFsPathType) {
	if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
	    /*
	     * We reject the empty path "".
	     */
	    return -1;
	}
	/*
	 * Otherwise there is no way this path can be empty.
	 */
    } else {
	/*
	 * It is somewhat unusual to reach this code path without the object
	 * being of tclFsPathType. However, we do our best to deal with the
	 * situation.
	 */

	int len;

	Tcl_GetStringFromObj(pathPtr, &len);
	if (len == 0) {
	    /*
	     * We reject the empty path "".
	     */
	    return -1;
	}
    }

    /*
     * Path is of correct type, or is of non-zero length, so we accept it.

     */

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPipe.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
/* 
 * tclPipe.c --
 *
 *	This file contains the generic portion of the command channel
 *	driver as well as various utility routines used in managing
 *	subprocesses.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPipe.c,v 1.10 2004/10/26 20:24:15 davygrvy Exp $
 */

#include "tclInt.h"

/*
 * A linked list of the following structures is used to keep track
 * of child processes that have been detached but haven't exited
 * yet, so we can make sure that they're properly "reaped" (officially
 * waited for) and don't lie around as zombies cluttering the
 * system.
 */

typedef struct Detached {
    Tcl_Pid pid;			/* Id of process that's been detached
					 * but isn't known to have exited. */
    struct Detached *nextPtr;		/* Next in list of all detached
					 * processes. */
} Detached;

static Detached *detList = NULL;	/* List of all detached proceses. */
TCL_DECLARE_MUTEX(pipeMutex)		/* Guard access to detList. */

/*
 * Declarations for local procedures defined in this file:
 */

static TclFile	FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
	            CONST char *spec, int atOk, CONST char *arg, 
		    CONST char *nextArg, int flags, int *skipPtr,
		    int *closePtr, int *releasePtr));

/*
 *----------------------------------------------------------------------
 *
 * FileForRedirect --
 *
 *	This procedure does much of the work of parsing redirection
 *	operators.  It handles "@" if specified and allowed, and a file
 *	name, and opens the file if necessary.
 *
 * Results:
 *	The return value is the descriptor number for the file.  If an
 *	error occurs then NULL is returned and an error message is left
 *	in the interp's result.  Several arguments are side-effected; see
 *	the argument list below for details.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static TclFile
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
	releasePtr)
    Tcl_Interp *interp;		/* Intepreter to use for error reporting. */
    CONST char *spec;		/* Points to character just after
				 * redirection character. */
    int atOK;			/* Non-zero means that '@' notation can be 
				 * used to specify a channel, zero means that
				 * it isn't. */
    CONST char *arg;		/* Pointer to entire argument containing 
				 * spec:  used for error reporting. */
    CONST char *nextArg;	/* Next argument in argc/argv array, if needed 
				 * for file name or channel name.  May be 
				 * NULL. */
    int flags;			/* Flags to use for opening file or to 
				 * specify mode for channel. */
    int *skipPtr;		/* Filled with 1 if redirection target was
				 * in spec, 2 if it was in nextArg. */
    int *closePtr;		/* Filled with one if the caller should 
				 * close the file when done with it, zero
				 * otherwise. */
    int *releasePtr;
{
    int writing = (flags & O_WRONLY);
    Tcl_Channel chan;
    TclFile file;




|
|
<



|
|

|





|
|
|
|
<



|
|
|
<


|
|


|


|
|
|
|






|
|
|


|
|
|
|











|
|
|


|
|
|
|

|
|
|
|
|
|







1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
/* 
 * tclPipe.c --
 *
 *	This file contains the generic portion of the command channel driver
 *	as well as various utility routines used in managing subprocesses.

 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPipe.c,v 1.10.2.2 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"

/*
 * A linked list of the following structures is used to keep track of child
 * processes that have been detached but haven't exited yet, so we can make
 * sure that they're properly "reaped" (officially waited for) and don't lie
 * around as zombies cluttering the system.

 */

typedef struct Detached {
    Tcl_Pid pid;		/* Id of process that's been detached but
				 * isn't known to have exited. */
    struct Detached *nextPtr;	/* Next in list of all detached processes. */

} Detached;

static Detached *detList = NULL;/* List of all detached proceses. */
TCL_DECLARE_MUTEX(pipeMutex)	/* Guard access to detList. */

/*
 * Declarations for local functions defined in this file:
 */

static TclFile		FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *spec, int atOk, CONST char *arg, 
			    CONST char *nextArg, int flags, int *skipPtr,
			    int *closePtr, int *releasePtr));

/*
 *----------------------------------------------------------------------
 *
 * FileForRedirect --
 *
 *	This function does much of the work of parsing redirection operators.
 *	It handles "@" if specified and allowed, and a file name, and opens
 *	the file if necessary.
 *
 * Results:
 *	The return value is the descriptor number for the file. If an error
 *	occurs then NULL is returned and an error message is left in the
 *	interp's result. Several arguments are side-effected; see the argument
 *	list below for details.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static TclFile
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
	releasePtr)
    Tcl_Interp *interp;		/* Intepreter to use for error reporting. */
    CONST char *spec;		/* Points to character just after redirection
				 * character. */
    int atOK;			/* Non-zero means that '@' notation can be
				 * used to specify a channel, zero means that
				 * it isn't. */
    CONST char *arg;		/* Pointer to entire argument containing spec:
				 * used for error reporting. */
    CONST char *nextArg;	/* Next argument in argc/argv array, if needed
				 * for file name or channel name. May be
				 * NULL. */
    int flags;			/* Flags to use for opening file or to specify
				 * mode for channel. */
    int *skipPtr;		/* Filled with 1 if redirection target was in
				 * spec, 2 if it was in nextArg. */
    int *closePtr;		/* Filled with one if the caller should close
				 * the file when done with it, zero
				 * otherwise. */
    int *releasePtr;
{
    int writing = (flags & O_WRONLY);
    Tcl_Channel chan;
    TclFile file;

109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
	    Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
		    "\" wasn't opened for ",
		    ((writing) ? "writing" : "reading"), (char *) NULL);
            return NULL;
        }
	*releasePtr = 1;
	if (writing) {

	    /*
	     * Be sure to flush output to the file, so that anything
	     * written by the child appears after stuff we've already
	     * written.
	     */

            Tcl_Flush(chan);
	}
    } else {
	CONST char *name;
	Tcl_DString nameString;







<

|
|
<







106
107
108
109
110
111
112

113
114
115

116
117
118
119
120
121
122
	    Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
		    "\" wasn't opened for ",
		    ((writing) ? "writing" : "reading"), (char *) NULL);
            return NULL;
        }
	*releasePtr = 1;
	if (writing) {

	    /*
	     * Be sure to flush output to the file, so that anything written
	     * by the child appears after stuff we've already written.

	     */

            Tcl_Flush(chan);
	}
    } else {
	CONST char *name;
	Tcl_DString nameString;
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
		    Tcl_PosixError(interp), (char *) NULL);
	    return NULL;
	}
        *closePtr = 1;
    }
    return file;

    badLastArg:
    Tcl_AppendResult(interp, "can't specify \"", arg,
	    "\" as last word in command", (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachPids --
 *
 *	This procedure is called to indicate that one or more child
 *	processes have been placed in background and will never be
 *	waited for;  they should eventually be reaped by
 *	Tcl_ReapDetachedProcs.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DetachPids(numPids, pidPtr)
    int numPids;		/* Number of pids to detach:  gives size
				 * of array pointed to by pidPtr. */
    Tcl_Pid *pidPtr;		/* Array of pids to detach. */
{
    register Detached *detPtr;
    int i;

    Tcl_MutexLock(&pipeMutex);
    for (i = 0; i < numPids; i++) {







|










|
|
|
<












|
|







141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
		    Tcl_PosixError(interp), (char *) NULL);
	    return NULL;
	}
        *closePtr = 1;
    }
    return file;

  badLastArg:
    Tcl_AppendResult(interp, "can't specify \"", arg,
	    "\" as last word in command", (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachPids --
 *
 *	This function is called to indicate that one or more child processes
 *	have been placed in background and will never be waited for; they
 *	should eventually be reaped by Tcl_ReapDetachedProcs.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DetachPids(numPids, pidPtr)
    int numPids;		/* Number of pids to detach: gives size of
				 * array pointed to by pidPtr. */
    Tcl_Pid *pidPtr;		/* Array of pids to detach. */
{
    register Detached *detPtr;
    int i;

    Tcl_MutexLock(&pipeMutex);
    for (i = 0; i < numPids; i++) {
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReapDetachedProcs --
 *
 *	This procedure checks to see if any detached processes have
 *	exited and, if so, it "reaps" them by officially waiting on
 *	them.  It should be called "occasionally" to make sure that
 *	all detached processes are eventually reaped.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Processes are waited on, so that they can be reaped by the
 *	system.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ReapDetachedProcs()
{







|
|
|
|





|
<







190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206

207
208
209
210
211
212
213
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReapDetachedProcs --
 *
 *	This function checks to see if any detached processes have exited and,
 *	if so, it "reaps" them by officially waiting on them. It should be
 *	called "occasionally" to make sure that all detached processes are
 *	eventually reaped.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Processes are waited on, so that they can be reaped by the system.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_ReapDetachedProcs()
{
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupChildren --
 *
 *	This is a utility procedure used to wait for child processes
 *	to exit, record information about abnormal exits, and then
 *	collect any stderr output generated by them.
 *
 * Results:
 *	The return value is a standard Tcl result.  If anything at
 *	weird happened with the child processes, TCL_ERROR is returned
 *	and a message is left in the interp's result.
 *
 * Side effects:
 *	If the last character of the interp's result is a newline, then it
 *	is removed unless keepNewline is non-zero.  File errorId gets
 *	closed, and pidPtr is freed back to the storage allocator.
 *
 *----------------------------------------------------------------------
 */

int
TclCleanupChildren(interp, numPids, pidPtr, errorChan)
    Tcl_Interp *interp;		/* Used for error messages. */
    int numPids;		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr;		/* Array of process ids of children. */
    Tcl_Channel errorChan;	/* Channel for file containing stderr output
				 * from pipeline.  NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int i, abnormalExit, anyErrorInfo;
    Tcl_Pid pid;
    WAIT_STATUS_TYPE waitStatus;
    CONST char *msg;
    unsigned long resolvedPid;

    abnormalExit = 0;
    for (i = 0; i < numPids; i++) {
	/*
	 * We need to get the resolved pid before we wait on it as
	 * the windows implimentation of Tcl_WaitPid deletes the
	 * information such that any following calls to TclpGetPid
	 * fail.
	 */

	resolvedPid = TclpGetPid(pidPtr[i]);
        pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
	if (pid == (Tcl_Pid) -1) {
	    result = TCL_ERROR;
            if (interp != (Tcl_Interp *) NULL) {
                msg = Tcl_PosixError(interp);
                if (errno == ECHILD) {
		    /*
                     * This changeup in message suggested by Mark Diekhans
                     * to remind people that ECHILD errors can occur on
                     * some systems if SIGCHLD isn't in its default state.
                     */

                    msg =
                        "child process lost (is SIGCHLD ignored or trapped?)";
                }
                Tcl_AppendResult(interp, "error waiting for process to exit: ",
                        msg, (char *) NULL);
            }
	    continue;
	}

	/*
	 * Create error messages for unusual process exits.  An
	 * extra newline gets appended to each error message, but
	 * it gets removed below (in the same fashion that an
	 * extra newline in the command's output is removed).
	 */

	if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
	    char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];

	    result = TCL_ERROR;
	    sprintf(msg1, "%lu", resolvedPid);







|
|
|


|
|
|


|
|
|










|












|
|
|
<

>








|
|
|












|
|
|
|







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupChildren --
 *
 *	This is a utility function used to wait for child processes to exit,
 *	record information about abnormal exits, and then collect any stderr
 *	output generated by them.
 *
 * Results:
 *	The return value is a standard Tcl result. If anything at weird
 *	happened with the child processes, TCL_ERROR is returned and a message
 *	is left in the interp's result.
 *
 * Side effects:
 *	If the last character of the interp's result is a newline, then it is
 *	removed unless keepNewline is non-zero. File errorId gets closed, and
 *	pidPtr is freed back to the storage allocator.
 *
 *----------------------------------------------------------------------
 */

int
TclCleanupChildren(interp, numPids, pidPtr, errorChan)
    Tcl_Interp *interp;		/* Used for error messages. */
    int numPids;		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr;		/* Array of process ids of children. */
    Tcl_Channel errorChan;	/* Channel for file containing stderr output
				 * from pipeline. NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int i, abnormalExit, anyErrorInfo;
    Tcl_Pid pid;
    WAIT_STATUS_TYPE waitStatus;
    CONST char *msg;
    unsigned long resolvedPid;

    abnormalExit = 0;
    for (i = 0; i < numPids; i++) {
	/*
	 * We need to get the resolved pid before we wait on it as the windows
	 * implimentation of Tcl_WaitPid deletes the information such that any
	 * following calls to TclpGetPid fail.

	 */

	resolvedPid = TclpGetPid(pidPtr[i]);
        pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
	if (pid == (Tcl_Pid) -1) {
	    result = TCL_ERROR;
            if (interp != (Tcl_Interp *) NULL) {
                msg = Tcl_PosixError(interp);
                if (errno == ECHILD) {
		    /*
                     * This changeup in message suggested by Mark Diekhans to
                     * remind people that ECHILD errors can occur on some
                     * systems if SIGCHLD isn't in its default state.
                     */

                    msg =
                        "child process lost (is SIGCHLD ignored or trapped?)";
                }
                Tcl_AppendResult(interp, "error waiting for process to exit: ",
                        msg, (char *) NULL);
            }
	    continue;
	}

	/*
	 * Create error messages for unusual process exits. An extra newline
	 * gets appended to each error message, but it gets removed below (in
	 * the same fashion that an extra newline in the command's output is
	 * removed).
	 */

	if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
	    char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];

	    result = TCL_ERROR;
	    sprintf(msg1, "%lu", resolvedPid);
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
                            (char *) NULL);
                }
	    }
	}
    }

    /*
     * Read the standard error file.  If there's anything there,
     * then return an error and add the file's contents to the result
     * string.
     */

    anyErrorInfo = 0;
    if (errorChan != NULL) {

	/*
	 * Make sure we start at the beginning of the file.
	 */

        if (interp != NULL) {
	    int count;
	    Tcl_Obj *objPtr;







|
|
<




<







352
353
354
355
356
357
358
359
360

361
362
363
364

365
366
367
368
369
370
371
                            (char *) NULL);
                }
	    }
	}
    }

    /*
     * Read the standard error file. If there's anything there, then return an
     * error and add the file's contents to the result string.

     */

    anyErrorInfo = 0;
    if (errorChan != NULL) {

	/*
	 * Make sure we start at the beginning of the file.
	 */

        if (interp != NULL) {
	    int count;
	    Tcl_Obj *objPtr;
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487

488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

510
511
512
513
514
515
516
		Tcl_DecrRefCount(objPtr);
	    }
	}
	Tcl_Close(NULL, errorChan);
    }

    /*
     * If a child exited abnormally but didn't output any error information
     * at all, generate an error message here.
     */

    if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
	Tcl_AppendResult(interp, "child process exited abnormally",
		(char *) NULL);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreatePipeline --
 *
 *	Given an argc/argv array, instantiate a pipeline of processes
 *	as described by the argv.
 *
 *	This procedure is unofficially exported for use by BLT.
 *
 * Results:
 *	The return value is a count of the number of new processes
 *	created, or -1 if an error occurred while creating the pipeline.
 *	*pidArrayPtr is filled in with the address of a dynamically
 *	allocated array giving the ids of all of the processes.  It
 *	is up to the caller to free this array when it isn't needed
 *	anymore.  If inPipePtr is non-NULL, *inPipePtr is filled in
 *	with the file id for the input pipe for the pipeline (if any):
 *	the caller must eventually close this file.  If outPipePtr
 *	isn't NULL, then *outPipePtr is filled in with the file id
 *	for the output pipe from the pipeline:  the caller must close
 *	this file.  If errFilePtr isn't NULL, then *errFilePtr is filled
 *	with a file id that may be used to read error output after the
 *	pipeline completes.
 *
 * Side effects:
 *	Processes and pipes are created.
 *
 *----------------------------------------------------------------------
 */

int
TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
	outPipePtr, errFilePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    int argc;			/* Number of entries in argv. */
    CONST char **argv;		/* Array of strings describing commands in
				 * pipeline plus I/O redirection with <,
				 * <<,  >, etc.  Argv[argc] must be NULL. */
    Tcl_Pid **pidArrayPtr;	/* Word at *pidArrayPtr gets filled in with
				 * address of array of pids for processes
				 * in pipeline (first pid is first process
				 * in pipeline). */
    TclFile *inPipePtr;		/* If non-NULL, input to the pipeline comes
				 * from a pipe (unless overridden by
				 * redirection in the command).  The file
				 * id with which to write to this pipe is
				 * stored at *inPipePtr.  NULL means command
				 * specified its own input source. */
    TclFile *outPipePtr;	/* If non-NULL, output to the pipeline goes
				 * to a pipe, unless overriden by redirection
				 * in the command.  The file id with which to
				 * read frome this pipe is stored at
				 * *outPipePtr.  NULL means command specified
				 * its own output sink. */
    TclFile *errFilePtr;	/* If non-NULL, all stderr output from the
				 * pipeline will go to a temporary file
				 * created here, and a descriptor to read
				 * the file will be left at *errFilePtr.
				 * The file will be removed already, so
				 * closing this descriptor will be the end
				 * of the file.  If this is NULL, then
				 * all stderr output goes to our stderr.
				 * If the pipeline specifies redirection
				 * then the file will still be created
				 * but it will never get any data. */
{
    Tcl_Pid *pidPtr = NULL;	/* Points to malloc-ed array holding all
				 * the pids of child processes. */
    int numPids;		/* Actual number of processes that exist
				 * at *pidPtr right now. */
    int cmdCount;		/* Count of number of distinct commands
				 * found in argc/argv. */
    CONST char *inputLiteral = NULL;	/* If non-null, then this points to a

				 * string containing input data (specified
				 * via <<) to be piped to the first process
				 * in the pipeline. */
    TclFile inputFile = NULL;	/* If != NULL, gives file to use as input for
				 * first process in pipeline (specified via <
				 * or <@). */
    int inputClose = 0;		/* If non-zero, then inputFile should be 
    				 * closed when cleaning up. */
    int inputRelease = 0;
    TclFile outputFile = NULL;	/* Writable file for output from last command
				 * in pipeline (could be file or pipe).  NULL
				 * means use stdout. */
    int outputClose = 0;	/* If non-zero, then outputFile should be 
    				 * closed when cleaning up. */
    int outputRelease = 0;
    TclFile errorFile = NULL;	/* Writable file for error output from all
				 * commands in pipeline.  NULL means use
				 * stderr. */
    int errorClose = 0;		/* If non-zero, then errorFile should be 
    				 * closed when cleaning up. */
    int errorRelease = 0;
    CONST char *p;

    int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput = 0;
    Tcl_DString execBuffer;
    TclFile pipeIn;
    TclFile curInFile, curOutFile, curErrFile;
    Tcl_Channel channel;

    if (inPipePtr != NULL) {







|
|














|
|

|


|
|
|
<
|
|
|
|
|
|
|
|
<













|
|

|
|
|


|
|
|
|
|
|
|
|
|
|


|
|
|
|
<
|
|
|
|

|
|
|
|
|
|
|
>
|
|
|



|



|

|



|

|



>







387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
426

427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463

464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
		Tcl_DecrRefCount(objPtr);
	    }
	}
	Tcl_Close(NULL, errorChan);
    }

    /*
     * If a child exited abnormally but didn't output any error information at
     * all, generate an error message here.
     */

    if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
	Tcl_AppendResult(interp, "child process exited abnormally",
		(char *) NULL);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreatePipeline --
 *
 *	Given an argc/argv array, instantiate a pipeline of processes as
 *	described by the argv.
 *
 *	This function is unofficially exported for use by BLT.
 *
 * Results:
 *	The return value is a count of the number of new processes created, or
 *	-1 if an error occurred while creating the pipeline. *pidArrayPtr is
 *	filled in with the address of a dynamically allocated array giving the

 *	ids of all of the processes. It is up to the caller to free this array
 *	when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is
 *	filled in with the file id for the input pipe for the pipeline (if
 *	any): the caller must eventually close this file. If outPipePtr isn't
 *	NULL, then *outPipePtr is filled in with the file id for the output
 *	pipe from the pipeline: the caller must close this file. If errFilePtr
 *	isn't NULL, then *errFilePtr is filled with a file id that may be used
 *	to read error output after the pipeline completes.

 *
 * Side effects:
 *	Processes and pipes are created.
 *
 *----------------------------------------------------------------------
 */

int
TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
	outPipePtr, errFilePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    int argc;			/* Number of entries in argv. */
    CONST char **argv;		/* Array of strings describing commands in
				 * pipeline plus I/O redirection with <, <<,
				 * >, etc. Argv[argc] must be NULL. */
    Tcl_Pid **pidArrayPtr;	/* Word at *pidArrayPtr gets filled in with
				 * address of array of pids for processes in
				 * pipeline (first pid is first process in
				 * pipeline). */
    TclFile *inPipePtr;		/* If non-NULL, input to the pipeline comes
				 * from a pipe (unless overridden by
				 * redirection in the command). The file id
				 * with which to write to this pipe is stored
				 * at *inPipePtr. NULL means command specified
				 * its own input source. */
    TclFile *outPipePtr;	/* If non-NULL, output to the pipeline goes to
				 * a pipe, unless overriden by redirection in
				 * the command. The file id with which to read
				 * frome this pipe is stored at *outPipePtr.
				 * NULL means command specified its own output
				 * sink. */
    TclFile *errFilePtr;	/* If non-NULL, all stderr output from the
				 * pipeline will go to a temporary file
				 * created here, and a descriptor to read the
				 * file will be left at *errFilePtr. The file
				 * will be removed already, so closing this
				 * descriptor will be the end of the file. If

				 * this is NULL, then all stderr output goes
				 * to our stderr. If the pipeline specifies
				 * redirection then the file will still be
				 * created but it will never get any data. */
{
    Tcl_Pid *pidPtr = NULL;	/* Points to malloc-ed array holding all the
				 * pids of child processes. */
    int numPids;		/* Actual number of processes that exist at
				 * *pidPtr right now. */
    int cmdCount;		/* Count of number of distinct commands found
				 * in argc/argv. */
    CONST char *inputLiteral = NULL;
				/* If non-null, then this points to a string
				 * containing input data (specified via <<) to
				 * be piped to the first process in the
				 * pipeline. */
    TclFile inputFile = NULL;	/* If != NULL, gives file to use as input for
				 * first process in pipeline (specified via <
				 * or <@). */
    int inputClose = 0;		/* If non-zero, then inputFile should be
    				 * closed when cleaning up. */
    int inputRelease = 0;
    TclFile outputFile = NULL;	/* Writable file for output from last command
				 * in pipeline (could be file or pipe). NULL
				 * means use stdout. */
    int outputClose = 0;	/* If non-zero, then outputFile should be
    				 * closed when cleaning up. */
    int outputRelease = 0;
    TclFile errorFile = NULL;	/* Writable file for error output from all
				 * commands in pipeline. NULL means use
				 * stderr. */
    int errorClose = 0;		/* If non-zero, then errorFile should be
    				 * closed when cleaning up. */
    int errorRelease = 0;
    CONST char *p;
    CONST char *nextArg;
    int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput = 0;
    Tcl_DString execBuffer;
    TclFile pipeIn;
    TclFile curInFile, curOutFile, curErrFile;
    Tcl_Channel channel;

    if (inPipePtr != NULL) {
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543

544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
    
    pipeIn = NULL;
    curInFile = NULL;
    curOutFile = NULL;
    numPids = 0;

    /*
     * First, scan through all the arguments to figure out the structure
     * of the pipeline.  Process all of the input and output redirection
     * arguments and remove them from the argument list in the pipeline.
     * Count the number of distinct processes (it's the number of "|"
     * arguments plus one) but don't remove the "|" arguments because 
     * they'll be used in the second pass to seperate the individual 
     * child processes.  Cannot start the child processes in this pass 
     * because the redirection symbols may appear anywhere in the 
     * command line -- e.g., the '<' that specifies the input to the 
     * entire pipe may appear at the very end of the argument list.

     */

    lastBar = -1;
    cmdCount = 1;
    for (i = 0; i < argc; i++) {
	errorToOutput = 0;
	skip = 0;
	p = argv[i];
	switch (*p++) {
	case '|':
	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
		    Tcl_SetResult(interp,
			    "illegal use of | or |& in command",
			    TCL_STATIC);
		    goto error;
		}
	    }
	    lastBar = i;
	    cmdCount++;
	    break;







|
|
|
|
|
|
<
|
|
|
>















|
<







517
518
519
520
521
522
523
524
525
526
527
528
529

530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

550
551
552
553
554
555
556
    
    pipeIn = NULL;
    curInFile = NULL;
    curOutFile = NULL;
    numPids = 0;

    /*
     * First, scan through all the arguments to figure out the structure of
     * the pipeline. Process all of the input and output redirection arguments
     * and remove them from the argument list in the pipeline. Count the
     * number of distinct processes (it's the number of "|" arguments plus
     * one) but don't remove the "|" arguments because they'll be used in the
     * second pass to seperate the individual child processes. Cannot start

     * the child processes in this pass because the redirection symbols may
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = -1;
    cmdCount = 1;
    for (i = 0; i < argc; i++) {
	errorToOutput = 0;
	skip = 0;
	p = argv[i];
	switch (*p++) {
	case '|':
	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
		    Tcl_SetResult(interp, "illegal use of | or |& in command",

			    TCL_STATIC);
		    goto error;
		}
	    }
	    lastBar = i;
	    cmdCount++;
	    break;
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591

592
593
594
595
596
597
598
599
600
601
602
603
604
605
606






607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638

639
640
641
642
643
644
645
646
647
		TclpReleaseFile(inputFile);
	    }
	    if (*p == '<') {
		inputFile = NULL;
		inputLiteral = p + 1;
		skip = 1;
		if (*inputLiteral == '\0') {
		    inputLiteral = argv[i + 1];
		    if (inputLiteral == NULL) {
			Tcl_AppendResult(interp, "can't specify \"", argv[i],
				"\" as last word in command", (char *) NULL);
			goto error;
		    }
		    skip = 2;
		}
	    } else {

		inputLiteral = NULL;
		inputFile = FileForRedirect(interp, p, 1, argv[i], 
			argv[i + 1], O_RDONLY, &skip, &inputClose, &inputRelease);
		if (inputFile == NULL) {
		    goto error;
		}
	    }
	    break;

	case '>':
	    atOK = 1;
	    flags = O_WRONLY | O_CREAT | O_TRUNC;
	    if (*p == '>') {
		p++;
		atOK = 0;






		flags = O_WRONLY | O_CREAT;
	    }
	    if (*p == '&') {
		if (errorClose != 0) {
		    errorClose = 0;
		    TclpCloseFile(errorFile);
		}
		errorToOutput = 1;
		p++;
	    }

	    /*
	     * Close the old output file, but only if the error file is
	     * not also using it.
	     */

	    if (outputClose != 0) {
		outputClose = 0;
		if (errorFile == outputFile) {
		    errorClose = 1;
		} else {
		    TclpCloseFile(outputFile);
		}
	    }
	    if (outputRelease != 0) {
		outputRelease = 0;
		if (errorFile == outputFile) {
		    errorRelease = 1;
		} else {
		    TclpReleaseFile(outputFile);
		}
	    }

	    outputFile = FileForRedirect(interp, p, atOK, argv[i], 
		    argv[i + 1], flags, &skip, &outputClose, &outputRelease);
	    if (outputFile == NULL) {
		goto error;
	    }
	    if (errorToOutput) {
		if (errorClose != 0) {
		    errorClose = 0;
		    TclpCloseFile(errorFile);







|








>

|
|












>
>
>
>
>
>
|











|
|


















>
|
|







565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
		TclpReleaseFile(inputFile);
	    }
	    if (*p == '<') {
		inputFile = NULL;
		inputLiteral = p + 1;
		skip = 1;
		if (*inputLiteral == '\0') {
		    inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
		    if (inputLiteral == NULL) {
			Tcl_AppendResult(interp, "can't specify \"", argv[i],
				"\" as last word in command", (char *) NULL);
			goto error;
		    }
		    skip = 2;
		}
	    } else {
		nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
		inputLiteral = NULL;
		inputFile = FileForRedirect(interp, p, 1, argv[i], nextArg,
			O_RDONLY, &skip, &inputClose, &inputRelease);
		if (inputFile == NULL) {
		    goto error;
		}
	    }
	    break;

	case '>':
	    atOK = 1;
	    flags = O_WRONLY | O_CREAT | O_TRUNC;
	    if (*p == '>') {
		p++;
		atOK = 0;

		/*
		 * Note that the O_APPEND flag only has an effect on POSIX
		 * platforms. On Windows, we just have to carry on regardless.
		 */

		flags = O_WRONLY | O_CREAT | O_APPEND;
	    }
	    if (*p == '&') {
		if (errorClose != 0) {
		    errorClose = 0;
		    TclpCloseFile(errorFile);
		}
		errorToOutput = 1;
		p++;
	    }

	    /*
	     * Close the old output file, but only if the error file is not
	     * also using it.
	     */

	    if (outputClose != 0) {
		outputClose = 0;
		if (errorFile == outputFile) {
		    errorClose = 1;
		} else {
		    TclpCloseFile(outputFile);
		}
	    }
	    if (outputRelease != 0) {
		outputRelease = 0;
		if (errorFile == outputFile) {
		    errorRelease = 1;
		} else {
		    TclpReleaseFile(outputFile);
		}
	    }
	    nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
	    outputFile = FileForRedirect(interp, p, atOK, argv[i], nextArg,
		    flags, &skip, &outputClose, &outputRelease);
	    if (outputFile == NULL) {
		goto error;
	    }
	    if (errorToOutput) {
		if (errorClose != 0) {
		    errorClose = 0;
		    TclpCloseFile(errorFile);
673
674
675
676
677
678
679
680
681
682

683
684
685
686
687
688
689
690
691

692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
	    if (errorRelease != 0) {
		errorRelease = 0;
		TclpReleaseFile(errorFile);
	    }
	    if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') {
		/*
		 * Special case handling of 2>@1 to redirect stderr to the
		 * exec/open output pipe as well.  This is meant for the end
		 * of the command string, otherwise use |& between commands.
		 */

		if (i != argc - 1) {
		    Tcl_AppendResult(interp, "must specify \"", argv[i],
			    "\" as last word in command", (char *) NULL);
		    goto error;
		}
		errorFile = outputFile;
		errorToOutput = 2;
		skip = 1;
	    } else {

		errorFile = FileForRedirect(interp, p, atOK, argv[i], 
			argv[i + 1], flags, &skip, &errorClose, &errorRelease);
		if (errorFile == NULL) {
		    goto error;
		}
	    }
	    break;
	}

	if (skip != 0) {
	    for (j = i + skip; j < argc; j++) {
		argv[j - skip] = argv[j];
	    }
	    argc -= skip;
	    i -= 1;
	}
    }

    if (inputFile == NULL) {
	if (inputLiteral != NULL) {
	    /*
	     * The input for the first process is immediate data coming from
	     * Tcl.  Create a temporary file for it and put the data into the
	     * file.
	     */

	    inputFile = TclpCreateTempFile(inputLiteral);
	    if (inputFile == NULL) {
		Tcl_AppendResult(interp,
			"couldn't create input file for command: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;
	    }
	    inputClose = 1;
	} else if (inPipePtr != NULL) {
	    /*
	     * The input for the first process in the pipeline is to
	     * come from a pipe that can be written from by the caller.
	     */

	    if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
		Tcl_AppendResult(interp, 
			"couldn't create input pipe for command: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;







|
|

>
|








>

|




















|


>










|
|







670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
	    if (errorRelease != 0) {
		errorRelease = 0;
		TclpReleaseFile(errorFile);
	    }
	    if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') {
		/*
		 * Special case handling of 2>@1 to redirect stderr to the
		 * exec/open output pipe as well. This is meant for the end of
		 * the command string, otherwise use |& between commands.
		 */

		if (i != argc-1) {
		    Tcl_AppendResult(interp, "must specify \"", argv[i],
			    "\" as last word in command", (char *) NULL);
		    goto error;
		}
		errorFile = outputFile;
		errorToOutput = 2;
		skip = 1;
	    } else {
		nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
		errorFile = FileForRedirect(interp, p, atOK, argv[i], 
			nextArg, flags, &skip, &errorClose, &errorRelease);
		if (errorFile == NULL) {
		    goto error;
		}
	    }
	    break;
	}

	if (skip != 0) {
	    for (j = i + skip; j < argc; j++) {
		argv[j - skip] = argv[j];
	    }
	    argc -= skip;
	    i -= 1;
	}
    }

    if (inputFile == NULL) {
	if (inputLiteral != NULL) {
	    /*
	     * The input for the first process is immediate data coming from
	     * Tcl. Create a temporary file for it and put the data into the
	     * file.
	     */

	    inputFile = TclpCreateTempFile(inputLiteral);
	    if (inputFile == NULL) {
		Tcl_AppendResult(interp,
			"couldn't create input file for command: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;
	    }
	    inputClose = 1;
	} else if (inPipePtr != NULL) {
	    /*
	     * The input for the first process in the pipeline is to come from
	     * a pipe that can be written from by the caller.
	     */

	    if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
		Tcl_AppendResult(interp, 
			"couldn't create input pipe for command: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
	    }
	}
    }

    if (outputFile == NULL) {
	if (outPipePtr != NULL) {
	    /*
	     * Output from the last process in the pipeline is to go to a
	     * pipe that can be read by the caller.
	     */

	    if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
		Tcl_AppendResult(interp, 
			"couldn't create output pipe for command: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;







|
|







749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
	    }
	}
    }

    if (outputFile == NULL) {
	if (outPipePtr != NULL) {
	    /*
	     * Output from the last process in the pipeline is to go to a pipe
	     * that can be read by the caller.
	     */

	    if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
		Tcl_AppendResult(interp, 
			"couldn't create output pipe for command: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;
778
779
780
781
782
783
784
785
786

787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
	    }
	}
    }

    if (errorFile == NULL) {
	if (errorToOutput == 2) {
	    /*
	     * Handle 2>@1 special case at end of cmd line
	     */

	    errorFile = outputFile;
	} else if (errFilePtr != NULL) {
	    /*
	     * Set up the standard error output sink for the pipeline, if
	     * requested.  Use a temporary file which is opened, then deleted.
	     * Could potentially just use pipe, but if it filled up it could
	     * cause the pipeline to deadlock:  we'd be waiting for processes
	     * to complete before reading stderr, and processes couldn't 
	     * complete because stderr was backed up.
	     */

	    errorFile = TclpCreateTempFile(NULL);
	    if (errorFile == NULL) {
		Tcl_AppendResult(interp,
			"couldn't create error file for command: ",







|

>




|

|
|







778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
	    }
	}
    }

    if (errorFile == NULL) {
	if (errorToOutput == 2) {
	    /*
	     * Handle 2>@1 special case at end of cmd line.
	     */

	    errorFile = outputFile;
	} else if (errFilePtr != NULL) {
	    /*
	     * Set up the standard error output sink for the pipeline, if
	     * requested. Use a temporary file which is opened, then deleted.
	     * Could potentially just use pipe, but if it filled up it could
	     * cause the pipeline to deadlock: we'd be waiting for processes
	     * to complete before reading stderr, and processes couldn't
	     * complete because stderr was backed up.
	     */

	    errorFile = TclpCreateTempFile(NULL);
	    if (errorFile == NULL) {
		Tcl_AppendResult(interp,
			"couldn't create error file for command: ",
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
		    errorRelease = 1;
		}
	    }
	}
    }
	
    /*
     * Scan through the argc array, creating a process for each
     * group of arguments between the "|" characters.
     */

    Tcl_ReapDetachedProcs();
    pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid)));

    curInFile = inputFile;








|
|







816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
		    errorRelease = 1;
		}
	    }
	}
    }
	
    /*
     * Scan through the argc array, creating a process for each group of
     * arguments between the "|" characters.
     */

    Tcl_ReapDetachedProcs();
    pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid)));

    curInFile = inputFile;

853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870

871
872
873
874
875
876
877
		}
		if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
		    joinThisError = 1;
		    break;
		}
	    }
	}
	argv[lastArg] = NULL;

	/*
	 * If this is the last segment, use the specified outputFile.
	 * Otherwise create an intermediate pipe.  pipeIn will become the
	 * curInFile for the next segment of the pipe.
	 */

	if (lastArg == argc) { 
	    curOutFile = outputFile;
	} else {

	    if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
		Tcl_AppendResult(interp, "couldn't create pipe: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;
	    }
	}








<



|



|


>







854
855
856
857
858
859
860

861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
		}
		if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
		    joinThisError = 1;
		    break;
		}
	    }
	}


	/*
	 * If this is the last segment, use the specified outputFile.
	 * Otherwise create an intermediate pipe. pipeIn will become the
	 * curInFile for the next segment of the pipe.
	 */

	if (lastArg == argc) {
	    curOutFile = outputFile;
	} else {
	    argv[lastArg] = NULL;
	    if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
		Tcl_AppendResult(interp, "couldn't create pipe: ",
			Tcl_PosixError(interp), (char *) NULL);
		goto error;
	    }
	}

896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
	}
	Tcl_DStringFree(&execBuffer);

	pidPtr[numPids] = pid;
	numPids++;

	/*
	 * Close off our copies of file descriptors that were set up for
	 * this child, then set up the input for the next child.
	 */

	if ((curInFile != NULL) && (curInFile != inputFile)) {
	    TclpCloseFile(curInFile);
	}
	curInFile = pipeIn;
	pipeIn = NULL;

	if ((curOutFile != NULL) && (curOutFile != outputFile)) {
	    TclpCloseFile(curOutFile);
	}
	curOutFile = NULL;
    }

    *pidArrayPtr = pidPtr;

    /*
     * All done.  Cleanup open files lying around and then return.
     */

cleanup:
    Tcl_DStringFree(&execBuffer);

    if (inputClose) {
	TclpCloseFile(inputFile);
    } else if (inputRelease) {
	TclpReleaseFile(inputFile);
    }
    if (outputClose) {
	TclpCloseFile(outputFile);
    } else if (outputRelease) {
	TclpReleaseFile(outputFile);
    }
    if (errorClose) {
	TclpCloseFile(errorFile);
    } else if (errorRelease) {
	TclpReleaseFile(errorFile);
    }
    return numPids;

    /*
     * An error occurred.  There could have been extra files open, such
     * as pipes between children.  Clean them all up.  Detach any child
     * processes that have been created.
     */

error:
    if (pipeIn != NULL) {
	TclpCloseFile(pipeIn);
    }
    if ((curOutFile != NULL) && (curOutFile != outputFile)) {
	TclpCloseFile(curOutFile);
    }
    if ((curInFile != NULL) && (curInFile != inputFile)) {







|
|

















|


|




















|
|
|


|







897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
	}
	Tcl_DStringFree(&execBuffer);

	pidPtr[numPids] = pid;
	numPids++;

	/*
	 * Close off our copies of file descriptors that were set up for this
	 * child, then set up the input for the next child.
	 */

	if ((curInFile != NULL) && (curInFile != inputFile)) {
	    TclpCloseFile(curInFile);
	}
	curInFile = pipeIn;
	pipeIn = NULL;

	if ((curOutFile != NULL) && (curOutFile != outputFile)) {
	    TclpCloseFile(curOutFile);
	}
	curOutFile = NULL;
    }

    *pidArrayPtr = pidPtr;

    /*
     * All done. Cleanup open files lying around and then return.
     */

  cleanup:
    Tcl_DStringFree(&execBuffer);

    if (inputClose) {
	TclpCloseFile(inputFile);
    } else if (inputRelease) {
	TclpReleaseFile(inputFile);
    }
    if (outputClose) {
	TclpCloseFile(outputFile);
    } else if (outputRelease) {
	TclpReleaseFile(outputFile);
    }
    if (errorClose) {
	TclpCloseFile(errorFile);
    } else if (errorRelease) {
	TclpReleaseFile(errorFile);
    }
    return numPids;

    /*
     * An error occurred. There could have been extra files open, such as
     * pipes between children. Clean them all up. Detach any child processes
     * that have been created.
     */

  error:
    if (pipeIn != NULL) {
	TclpCloseFile(pipeIn);
    }
    if ((curOutFile != NULL) && (curOutFile != outputFile)) {
	TclpCloseFile(curOutFile);
    }
    if ((curInFile != NULL) && (curInFile != inputFile)) {
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenCommandChannel --
 *
 *	Opens an I/O channel to one or more subprocesses specified
 *	by argc and argv.  The flags argument determines the
 *	disposition of the stdio handles.  If the TCL_STDIN flag is
 *	set then the standard input for the first subprocess will
 *	be tied to the channel:  writing to the channel will provide
 *	input to the subprocess.  If TCL_STDIN is not set, then
 *	standard input for the first subprocess will be the same as
 *	this application's standard input.  If TCL_STDOUT is set then
 *	standard output from the last subprocess can be read from the
 *	channel;  otherwise it goes to this application's standard
 *	output.  If TCL_STDERR is set, standard error output for all
 *	subprocesses is returned to the channel and results in an error
 *	when the channel is closed;  otherwise it goes to this
 *	application's standard error.  If TCL_ENFORCE_MODE is not set,
 *	then argc and argv can redirect the stdio handles to override
 *	TCL_STDIN, TCL_STDOUT, and TCL_STDERR;  if it is set, then it 
 *	is an error for argc and argv to override stdio channels for
 *	which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set.
 *
 * Results:
 *	A new command channel, or NULL on failure with an error
 *	message left in interp.
 *
 * Side effects:
 *	Creates processes, opens pipes.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenCommandChannel(interp, argc, argv, flags)
    Tcl_Interp *interp;		/* Interpreter for error reporting. Can
                                 * NOT be NULL. */
    int argc;			/* How many arguments. */
    CONST char **argv;		/* Array of arguments for command pipe. */
    int flags;			/* Or'ed combination of TCL_STDIN, TCL_STDOUT,
				 * TCL_STDERR, and TCL_ENFORCE_MODE. */
{
    TclFile *inPipePtr, *outPipePtr, *errFilePtr;
    TclFile inPipe, outPipe, errFile;







|
|
|
|
<
|
|
|
|
|
|
|
<
|
|
|
|
|


|
|









|
|







984
985
986
987
988
989
990
991
992
993
994

995
996
997
998
999
1000
1001

1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenCommandChannel --
 *
 *	Opens an I/O channel to one or more subprocesses specified by argc and
 *	argv. The flags argument determines the disposition of the stdio
 *	handles. If the TCL_STDIN flag is set then the standard input for the
 *	first subprocess will be tied to the channel: writing to the channel

 *	will provide input to the subprocess. If TCL_STDIN is not set, then
 *	standard input for the first subprocess will be the same as this
 *	application's standard input. If TCL_STDOUT is set then standard
 *	output from the last subprocess can be read from the channel;
 *	otherwise it goes to this application's standard output. If TCL_STDERR
 *	is set, standard error output for all subprocesses is returned to the
 *	channel and results in an error when the channel is closed; otherwise

 *	it goes to this application's standard error. If TCL_ENFORCE_MODE is
 *	not set, then argc and argv can redirect the stdio handles to override
 *	TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it is an
 *	error for argc and argv to override stdio channels for which
 *	TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set.
 *
 * Results:
 *	A new command channel, or NULL on failure with an error message left
 *	in interp.
 *
 * Side effects:
 *	Creates processes, opens pipes.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenCommandChannel(interp, argc, argv, flags)
    Tcl_Interp *interp;		/* Interpreter for error reporting. Can NOT be
                                 * NULL. */
    int argc;			/* How many arguments. */
    CONST char **argv;		/* Array of arguments for command pipe. */
    int flags;			/* Or'ed combination of TCL_STDIN, TCL_STDOUT,
				 * TCL_STDERR, and TCL_ENFORCE_MODE. */
{
    TclFile *inPipePtr, *outPipePtr, *errFilePtr;
    TclFile inPipe, outPipe, errFile;
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
            outPipePtr, errFilePtr);

    if (numPids < 0) {
	goto error;
    }

    /*
     * Verify that the pipes that were created satisfy the
     * readable/writable constraints. 
     */

    if (flags & TCL_ENFORCE_MODE) {
	if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
	    Tcl_AppendResult(interp, "can't read output from command:",
		    " standard output was redirected", (char *) NULL);
	    goto error;







|
|







1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
            outPipePtr, errFilePtr);

    if (numPids < 0) {
	goto error;
    }

    /*
     * Verify that the pipes that were created satisfy the readable/writable
     * constraints.
     */

    if (flags & TCL_ENFORCE_MODE) {
	if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
	    Tcl_AppendResult(interp, "can't read output from command:",
		    " standard output was redirected", (char *) NULL);
	    goto error;
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090








    if (channel == (Tcl_Channel) NULL) {
        Tcl_AppendResult(interp, "pipe for command could not be created",
                (char *) NULL);
	goto error;
    }
    return channel;

error:
    if (numPids > 0) {
	Tcl_DetachPids(numPids, pidPtr);
	ckfree((char *) pidPtr);
    }
    if (inPipe != NULL) {
	TclpCloseFile(inPipe);
    }
    if (outPipe != NULL) {
	TclpCloseFile(outPipe);
    }
    if (errFile != NULL) {
	TclpCloseFile(errFile);
    }
    return NULL;
}















|















>
>
>
>
>
>
>
>
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
    if (channel == (Tcl_Channel) NULL) {
        Tcl_AppendResult(interp, "pipe for command could not be created",
                (char *) NULL);
	goto error;
    }
    return channel;

  error:
    if (numPids > 0) {
	Tcl_DetachPids(numPids, pidPtr);
	ckfree((char *) pidPtr);
    }
    if (inPipe != NULL) {
	TclpCloseFile(inPipe);
    }
    if (outPipe != NULL) {
	TclpCloseFile(outPipe);
    }
    if (errFile != NULL) {
	TclpCloseFile(errFile);
    }
    return NULL;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPkg.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
/* 
 * tclPkg.c --
 *
 *	This file implements package and version control for Tcl via
 *	the "package" command and a few C APIs.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPkg.c,v 1.11 2004/10/06 15:59:25 dgp Exp $
 */

#include "tclInt.h"

/*
 * Each invocation of the "package ifneeded" command creates a structure
 * of the following type, which is used to load the package into the
 * interpreter if it is requested with a "package require" command.
 */

typedef struct PkgAvail {
    char *version;		/* Version string; malloc'ed. */
    char *script;		/* Script to invoke to provide this version
				 * of the package.  Malloc'ed and protected
				 * by Tcl_Preserve and Tcl_Release. */
    struct PkgAvail *nextPtr;	/* Next in list of available versions of
				 * the same package. */
} PkgAvail;

/*
 * For each package that is known in any way to an interpreter, there
 * is one record of the following type.  These records are stored in
 * the "packageTable" hash table in the interpreter, keyed by
 * package name such as "Tk" (no version number).
 */

typedef struct Package {
    char *version;		/* Version that has been supplied in this
				 * interpreter via "package provide"
				 * (malloc'ed).  NULL means the package doesn't
				 * exist in this interpreter yet. */
    PkgAvail *availPtr;		/* First in list of all available versions
				 * of this package. */
    ClientData clientData;	/* Client data. */
} Package;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *string));
static int		ComparePkgVersions _ANSI_ARGS_((CONST char *v1, 
                            CONST char *v2,
			    int *satPtr));
static Package *	FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *name));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgProvide / Tcl_PkgProvideEx --
 *
 *	This procedure is invoked to declare that a particular version
 *	of a particular package is now present in an interpreter.  There
 *	must not be any other version of this package already
 *	provided in the interpreter.
 *
 * Results:
 *	Normally returns TCL_OK;  if there is already another version
 *	of the package loaded then TCL_ERROR is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	The interpreter remembers that this package is available,
 *	so that no other version of the package may be provided for
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PkgProvide(interp, name, version)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of package. */
    CONST char *version;	/* Version string for package. */
{
    return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}

int
Tcl_PkgProvideEx(interp, name, version, clientData)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of package. */
    CONST char *version;	/* Version string for package. */
    ClientData clientData;      /* clientdata for this package (normally
                                 * used for C callback function table) */
{
    Package *pkgPtr;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
	strcpy(pkgPtr->version, version);
|


|
|



|
|

|





|
|
|




|
|
|
|
|



|
|
|
|





|
|
|
|









|
|
<








|
|
|
<


|
|
|


|
|
<




















|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
/*
 * tclPkg.c --
 *
 *	This file implements package and version control for Tcl via the
 *	"package" command and a few C APIs.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPkg.c,v 1.11.2.1 2005/08/02 18:16:06 dgp Exp $
 */

#include "tclInt.h"

/*
 * Each invocation of the "package ifneeded" command creates a structure of
 * the following type, which is used to load the package into the interpreter
 * if it is requested with a "package require" command.
 */

typedef struct PkgAvail {
    char *version;		/* Version string; malloc'ed. */
    char *script;		/* Script to invoke to provide this version of
				 * the package.  Malloc'ed and protected by
				 * Tcl_Preserve and Tcl_Release. */
    struct PkgAvail *nextPtr;	/* Next in list of available versions of the
				 * same package. */
} PkgAvail;

/*
 * For each package that is known in any way to an interpreter, there is one
 * record of the following type.  These records are stored in the
 * "packageTable" hash table in the interpreter, keyed by package name such as
 * "Tk" (no version number).
 */

typedef struct Package {
    char *version;		/* Version that has been supplied in this
				 * interpreter via "package provide"
				 * (malloc'ed).  NULL means the package
				 * doesn't exist in this interpreter yet. */
    PkgAvail *availPtr;		/* First in list of all available versions of
				 * this package. */
    ClientData clientData;	/* Client data. */
} Package;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *string));
static int		ComparePkgVersions _ANSI_ARGS_((CONST char *v1,
			    CONST char *v2, int *satPtr));

static Package *	FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *name));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgProvide / Tcl_PkgProvideEx --
 *
 *	This procedure is invoked to declare that a particular version of a
 *	particular package is now present in an interpreter. There must not be
 *	any other version of this package already provided in the interpreter.

 *
 * Results:
 *	Normally returns TCL_OK; if there is already another version of the
 *	package loaded then TCL_ERROR is returned and an error message is left
 *	in the interp's result.
 *
 * Side effects:
 *	The interpreter remembers that this package is available, so that no
 *	other version of the package may be provided for the interpreter.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_PkgProvide(interp, name, version)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of package. */
    CONST char *version;	/* Version string for package. */
{
    return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}

int
Tcl_PkgProvideEx(interp, name, version, clientData)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of package. */
    CONST char *version;	/* Version string for package. */
    ClientData clientData;	/* clientdata for this package (normally used
				 * for C callback function table) */
{
    Package *pkgPtr;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
	strcpy(pkgPtr->version, version);
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgRequire / Tcl_PkgRequireEx --
 *
 *	This procedure is called by code that depends on a particular
 *	version of a particular package.  If the package is not already
 *	provided in the interpreter, this procedure invokes a Tcl script
 *	to provide it.  If the package is already provided, this
 *	procedure makes sure that the caller's needs don't conflict with
 *	the version that is present.
 *
 * Results:
 *	If successful, returns the version string for the currently
 *	provided version of the package, which may be different from
 *	the "version" argument.  If the caller's requirements
 *	cannot be met (e.g. the version requested conflicts with
 *	a currently provided version, or the required version cannot
 *	be found, or the script to provide the required version
 *	generates an error), NULL is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	The script from some previous "package ifneeded" command may
 *	be invoked to provide the package.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgRequire(interp, name, version, exact)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version
				 * available. */
    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means
				 * use the latest compatible version. */
{
    return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version
				 * available. */
    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means
				 * use the latest compatible version. */
    ClientData *clientDataPtr;	/* Used to return the client data for this
				 * package. If it is NULL then the client
				 * data is not returned. This is unchanged
				 * if this call fails for any reason. */
{
    Package *pkgPtr;
    PkgAvail *availPtr, *bestPtr;
    char *script;
    int code, satisfies, result, pass;
    Tcl_DString command;

    /*
     * If an attempt is being made to load this into a standalone executable
     * on a platform where backlinking is not supported then this must be
     * a shared version of Tcl (Otherwise the load would have failed).
     * Detect this situation by checking that this library has been correctly
     * initialised. If it has not been then return immediately as nothing will
     * work.
     */
    
    if (tclEmptyStringRep == NULL) {

	/*
	 * OK, so what's going on here?
	 *
	 * First, what are we doing?  We are performing a check on behalf of
	 * one particular caller, Tcl_InitStubs().  When a package is
	 * stub-enabled, it is statically linked to libtclstub.a, which
	 * contains a copy of Tcl_InitStubs().  When a stub-enabled package
	 * is loaded, its *_Init() function is supposed to call
	 * Tcl_InitStubs() before calling any other functions in the Tcl
	 * library.  The first Tcl function called by Tcl_InitStubs() through
	 * the stub table is Tcl_PkgRequireEx(), so this code right here is
	 * the first code that is part of the original Tcl library in the
	 * executable that gets executed on behalf of a newly loaded
	 * stub-enabled package.
	 *
	 * One easy error for the developer/builder of a stub-enabled package
	 * to make is to forget to define USE_TCL_STUBS when compiling the
	 * package.  When that happens, the package will contain symbols
	 * that are references to the Tcl library, rather than function
	 * pointers referencing the stub table.  On platforms that lack
	 * backlinking, those unresolved references may cause the loading
	 * of the package to also load a second copy of the Tcl library,
	 * leading to all kinds of trouble.  We would like to catch that
	 * error and report a useful message back to the user.  That's
	 * what we're doing.
	 *
	 * Second, how does this work?  If we reach this point, then the
	 * global variable tclEmptyStringRep has the value NULL.  Compare
	 * that with the definition of tclEmptyStringRep near the top of
	 * the file generic/tclObj.c.  It clearly should not have the value
	 * NULL; it should point to the char tclEmptyString.  If we see it
	 * having the value NULL, then somehow we are seeing a Tcl library
	 * that isn't completely initialized, and that's an indicator for the
	 * error condition described above.  (Further explanation is welcome.)
	 *
	 * Third, so what do we do about it?  This situation indicates
	 * the package we just loaded wasn't properly compiled to be
	 * stub-enabled, yet it thinks it is stub-enabled (it called
	 * Tcl_InitStubs()).  We want to report that the package just
	 * loaded is broken, so we want to place an error message in
	 * the interpreter result and return NULL to indicate failure
	 * to Tcl_InitStubs() so that it will also fail.  (Further
	 * explanation why we don't want to Tcl_Panic() is welcome.
	 * After all, two Tcl libraries can't be a good thing!)
	 *
	 * Trouble is that's going to be tricky.  We're now using a Tcl
	 * library that's not fully initialized.  In particular, it 
	 * doesn't have a proper value for tclEmptyStringRep.  The
	 * Tcl_Obj system heavily depends on the value of tclEmptyStringRep
	 * and all of Tcl depends (increasingly) on the Tcl_Obj system, we
	 * need to correct that flaw before making the calls to set the 
	 * interpreter result to the error message.  That's the only flaw
	 * corrected; other problems with initialization of the Tcl library
	 * are not remedied, so be very careful about adding any other calls
	 * here without checking how they behave when initialization is
	 * incomplete.
	 */

	tclEmptyStringRep = &tclEmptyString;
        Tcl_AppendResult(interp, "Cannot load package \"", name, 
                "\" in standalone executable: This package is not ",
                "compiled with stub support", NULL);
        return NULL;
    }

    /*
     * It can take up to three passes to find the package:  one pass to
     * run the "package unknown" script, one to run the "package ifneeded"
     * script for a specific version, and a final pass to lookup the
     * package loaded by the "package ifneeded" script.
     */

    for (pass = 1; ; pass++) {
	pkgPtr = FindPackage(interp, name);
	if (pkgPtr->version != NULL) {
	    break;
	}

	/*
	 * The package isn't yet present.  Search the list of available
	 * versions and invoke the script for the best available version.
	 */
    
	bestPtr = NULL;
	for (availPtr = pkgPtr->availPtr; availPtr != NULL;
		availPtr = availPtr->nextPtr) {
	    if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
		    bestPtr->version, (int *) NULL) <= 0)) {
		continue;
	    }







|
|
|
|
|
<


|
|
<
|
|
|
|
|


|
|









|
|
<

|
|









|
|
<

|
|

|
|
|









|
|
|



|





|
|
|
|
|
|
|
|
|
|
<



|
|
|
|
|
|
<
|

|
|
|
|
|
|
|
|

|
|
|
|
<
|
|
|


|
|
|
|
|
|
|
|
|
|
<



|
|
|
|



|
|
|
|












|







118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205

206
207
208
209
210
211
212
213
214

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgRequire / Tcl_PkgRequireEx --
 *
 *	This procedure is called by code that depends on a particular version
 *	of a particular package. If the package is not already provided in the
 *	interpreter, this procedure invokes a Tcl script to provide it. If the
 *	package is already provided, this procedure makes sure that the
 *	caller's needs don't conflict with the version that is present.

 *
 * Results:
 *	If successful, returns the version string for the currently provided
 *	version of the package, which may be different from the "version"

 *	argument. If the caller's requirements cannot be met (e.g. the version
 *	requested conflicts with a currently provided version, or the required
 *	version cannot be found, or the script to provide the required version
 *	generates an error), NULL is returned and an error message is left in
 *	the interp's result.
 *
 * Side effects:
 *	The script from some previous "package ifneeded" command may be
 *	invoked to provide the package.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgRequire(interp, name, version, exact)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version; NULL
				 * means use the latest version available. */

    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means use
				 * the latest compatible version. */
{
    return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version; NULL
				 * means use the latest version available. */

    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means use
				 * the latest compatible version. */
    ClientData *clientDataPtr;	/* Used to return the client data for this
				 * package. If it is NULL then the client data
				 * is not returned. This is unchanged if this
				 * call fails for any reason. */
{
    Package *pkgPtr;
    PkgAvail *availPtr, *bestPtr;
    char *script;
    int code, satisfies, result, pass;
    Tcl_DString command;

    /*
     * If an attempt is being made to load this into a standalone executable
     * on a platform where backlinking is not supported then this must be a
     * shared version of Tcl (Otherwise the load would have failed). Detect
     * this situation by checking that this library has been correctly
     * initialised. If it has not been then return immediately as nothing will
     * work.
     */

    if (tclEmptyStringRep == NULL) {

	/*
	 * OK, so what's going on here?
	 *
	 * First, what are we doing? We are performing a check on behalf of
	 * one particular caller, Tcl_InitStubs(). When a package is stub-
	 * enabled, it is statically linked to libtclstub.a, which contains a
	 * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its
	 * *_Init() function is supposed to call Tcl_InitStubs() before
	 * calling any other functions in the Tcl library. The first Tcl
	 * function called by Tcl_InitStubs() through the stub table is
	 * Tcl_PkgRequireEx(), so this code right here is the first code that
	 * is part of the original Tcl library in the executable that gets
	 * executed on behalf of a newly loaded stub-enabled package.

	 *
	 * One easy error for the developer/builder of a stub-enabled package
	 * to make is to forget to define USE_TCL_STUBS when compiling the
	 * package. When that happens, the package will contain symbols that
	 * are references to the Tcl library, rather than function pointers
	 * referencing the stub table. On platforms that lack backlinking,
	 * those unresolved references may cause the loading of the package to
	 * also load a second copy of the Tcl library, leading to all kinds of
	 * trouble. We would like to catch that error and report a useful

	 * message back to the user. That's what we're doing.
	 *
	 * Second, how does this work? If we reach this point, then the global
	 * variable tclEmptyStringRep has the value NULL. Compare that with
	 * the definition of tclEmptyStringRep near the top of the file
	 * generic/tclObj.c. It clearly should not have the value NULL; it
	 * should point to the char tclEmptyString. If we see it having the
	 * value NULL, then somehow we are seeing a Tcl library that isn't
	 * completely initialized, and that's an indicator for the error
	 * condition described above. (Further explanation is welcome.)
	 *
	 * Third, so what do we do about it? This situation indicates the
	 * package we just loaded wasn't properly compiled to be stub-enabled,
	 * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We
	 * want to report that the package just loaded is broken, so we want

	 * to place an error message in the interpreter result and return NULL
	 * to indicate failure to Tcl_InitStubs() so that it will also fail.
	 * (Further explanation why we don't want to Tcl_Panic() is welcome.
	 * After all, two Tcl libraries can't be a good thing!)
	 *
	 * Trouble is that's going to be tricky. We're now using a Tcl library
	 * that's not fully initialized. In particular, it doesn't have a
	 * proper value for tclEmptyStringRep. The Tcl_Obj system heavily
	 * depends on the value of tclEmptyStringRep and all of Tcl depends
	 * (increasingly) on the Tcl_Obj system, we need to correct that flaw
	 * before making the calls to set the interpreter result to the error
	 * message. That's the only flaw corrected; other problems with
	 * initialization of the Tcl library are not remedied, so be very
	 * careful about adding any other calls here without checking how they
	 * behave when initialization is incomplete.

	 */

	tclEmptyStringRep = &tclEmptyString;
	Tcl_AppendResult(interp, "Cannot load package \"", name,
		"\" in standalone executable: This package is not ",
		"compiled with stub support", NULL);
	return NULL;
    }

    /*
     * It can take up to three passes to find the package: one pass to run the
     * "package unknown" script, one to run the "package ifneeded" script for
     * a specific version, and a final pass to lookup the package loaded by
     * the "package ifneeded" script.
     */

    for (pass = 1; ; pass++) {
	pkgPtr = FindPackage(interp, name);
	if (pkgPtr->version != NULL) {
	    break;
	}

	/*
	 * The package isn't yet present.  Search the list of available
	 * versions and invoke the script for the best available version.
	 */

	bestPtr = NULL;
	for (availPtr = pkgPtr->availPtr; availPtr != NULL;
		availPtr = availPtr->nextPtr) {
	    if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
		    bestPtr->version, (int *) NULL) <= 0)) {
		continue;
	    }
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
		}
	    }
	    bestPtr = availPtr;
	}
	if (bestPtr != NULL) {
	    /*
	     * We found an ifneeded script for the package.  Be careful while
	     * executing it:  this could cause reentrancy, so (a) protect the
	     * script itself from deletion and (b) don't assume that bestPtr
	     * will still exist when the script completes.
	     */
	
	    script = bestPtr->script;
	    Tcl_Preserve((ClientData) script);
	    code = Tcl_GlobalEval(interp, script);
	    Tcl_Release((ClientData) script);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    Tcl_AddErrorInfo(interp,
			    "\n    (\"package ifneeded\" script)");
		}
		return NULL;
	    }
	    Tcl_ResetResult(interp);
	    pkgPtr = FindPackage(interp, name);
	    break;
	}

	/*
	 * Package not in the database.  If there is a "package unknown"
	 * command, invoke it (but only on the first pass;  after that,
	 * we should not get here in the first place).
	 */

	if (pass > 1) {
	    break;
	}
	script = ((Interp *) interp)->packageUnknown;
	if (script != NULL) {







|



|


















|
|







287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
		}
	    }
	    bestPtr = availPtr;
	}
	if (bestPtr != NULL) {
	    /*
	     * We found an ifneeded script for the package.  Be careful while
	     * executing it: this could cause reentrancy, so (a) protect the
	     * script itself from deletion and (b) don't assume that bestPtr
	     * will still exist when the script completes.
	     */

	    script = bestPtr->script;
	    Tcl_Preserve((ClientData) script);
	    code = Tcl_GlobalEval(interp, script);
	    Tcl_Release((ClientData) script);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    Tcl_AddErrorInfo(interp,
			    "\n    (\"package ifneeded\" script)");
		}
		return NULL;
	    }
	    Tcl_ResetResult(interp);
	    pkgPtr = FindPackage(interp, name);
	    break;
	}

	/*
	 * Package not in the database.  If there is a "package unknown"
	 * command, invoke it (but only on the first pass; after that, we
	 * should not get here in the first place).
	 */

	if (pass > 1) {
	    break;
	}
	script = ((Interp *) interp)->packageUnknown;
	if (script != NULL) {
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

    /*
     * At this point we know that the package is present.  Make sure that the
     * provided version meets the current requirement.
     */

    if (version == NULL) {
        if (clientDataPtr) {
	    *clientDataPtr = pkgPtr->clientData;
	}
	return pkgPtr->version;
    }
    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
    if ((satisfies && !exact) || (result == 0)) {
	if (clientDataPtr) {
	    *clientDataPtr = pkgPtr->clientData;
	}
	return pkgPtr->version;
    }
    Tcl_AppendResult(interp, "version conflict for package \"",
	    name, "\": have ", pkgPtr->version, ", need ", version,
	    (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
 *
 *	Checks to see whether the specified package is present. If it
 *	is not then no additional action is taken.
 *
 * Results:
 *	If successful, returns the version string for the currently
 *	provided version of the package, which may be different from
 *	the "version" argument.  If the caller's requirements
 *	cannot be met (e.g. the version requested conflicts with
 *	a currently provided version), NULL is returned and an error
 *	message is left in interp->result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgPresent(interp, name, version, exact)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version
				 * available. */
    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means
				 * use the latest compatible version. */
{
    return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version
				 * available. */
    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means
				 * use the latest compatible version. */
    ClientData *clientDataPtr;	/* Used to return the client data for this
				 * package. If it is NULL then the client
				 * data is not returned. This is unchanged
				 * if this call fails for any reason. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Package *pkgPtr;
    int satisfies, result;

    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
    if (hPtr) {
	pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	if (pkgPtr->version != NULL) {
	    
	    /*
	     * At this point we know that the package is present.  Make sure
	     * that the provided version meets the current requirement.
	     */

	    if (version == NULL) {
		if (clientDataPtr) {
		    *clientDataPtr = pkgPtr->clientData;
		}
		
		return pkgPtr->version;
	    }
	    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
	    if ((satisfies && !exact) || (result == 0)) {
		if (clientDataPtr) {
		    *clientDataPtr = pkgPtr->clientData;
		}
    
		return pkgPtr->version;
	    }
	    Tcl_AppendResult(interp, "version conflict for package \"",
			     name, "\": have ", pkgPtr->version,
			     ", need ", version, (char *) NULL);
	    return NULL;
	}
    }

    if (version != NULL) {
	Tcl_AppendResult(interp, "package ", name, " ", version,
			 " is not present", (char *) NULL);
    } else {
	Tcl_AppendResult(interp, "package ", name, " is not present",
			 (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PackageObjCmd --
 *
 *	This procedure is invoked to process the "package" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PackageObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    static CONST char *pkgOptions[] = {
	"forget", "ifneeded", "names", "present", "provide", "require",
	"unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
    };
    enum pkgOptions {







|



















|


|
|


|
|
<
|
|
|












|
|
<

|
|









|
|
<

|
|

|
|
|










<

|







|







|


|
|
|






|


|









|
|













|
|
|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391

392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

409
410
411
412
413
414
415
416
417
418
419
420
421
422

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439

440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506

    /*
     * At this point we know that the package is present.  Make sure that the
     * provided version meets the current requirement.
     */

    if (version == NULL) {
	if (clientDataPtr) {
	    *clientDataPtr = pkgPtr->clientData;
	}
	return pkgPtr->version;
    }
    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
    if ((satisfies && !exact) || (result == 0)) {
	if (clientDataPtr) {
	    *clientDataPtr = pkgPtr->clientData;
	}
	return pkgPtr->version;
    }
    Tcl_AppendResult(interp, "version conflict for package \"",
	    name, "\": have ", pkgPtr->version, ", need ", version,
	    (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *q
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
 *
 *	Checks to see whether the specified package is present. If it is not
 *	then no additional action is taken.
 *
 * Results:
 *	If successful, returns the version string for the currently provided
 *	version of the package, which may be different from the "version"

 *	argument. If the caller's requirements cannot be met (e.g. the version
 *	requested conflicts with a currently provided version), NULL is
 *	returned and an error message is left in interp->result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgPresent(interp, name, version, exact)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version; NULL
				 * means use the latest version available. */

    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means use
				 * the latest compatible version. */
{
    return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version; NULL
				 * means use the latest version available. */

    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means use
				 * the latest compatible version. */
    ClientData *clientDataPtr;	/* Used to return the client data for this
				 * package. If it is NULL then the client data
				 * is not returned. This is unchanged if this
				 * call fails for any reason. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Package *pkgPtr;
    int satisfies, result;

    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
    if (hPtr) {
	pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	if (pkgPtr->version != NULL) {

	    /*
	     * At this point we know that the package is present. Make sure
	     * that the provided version meets the current requirement.
	     */

	    if (version == NULL) {
		if (clientDataPtr) {
		    *clientDataPtr = pkgPtr->clientData;
		}

		return pkgPtr->version;
	    }
	    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
	    if ((satisfies && !exact) || (result == 0)) {
		if (clientDataPtr) {
		    *clientDataPtr = pkgPtr->clientData;
		}

		return pkgPtr->version;
	    }
	    Tcl_AppendResult(interp, "version conflict for package \"", name,
		    "\": have ", pkgPtr->version, ", need ", version,
		    (char *) NULL);
	    return NULL;
	}
    }

    if (version != NULL) {
	Tcl_AppendResult(interp, "package ", name, " ", version,
		" is not present", (char *) NULL);
    } else {
	Tcl_AppendResult(interp, "package ", name, " is not present",
		(char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PackageObjCmd --
 *
 *	This procedure is invoked to process the "package" Tcl command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PackageObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    static CONST char *pkgOptions[] = {
	"forget", "ifneeded", "names", "present", "provide", "require",
	"unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
    };
    enum pkgOptions {
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547

548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571

572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727

728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    CONST char *version;
    char *argv2, *argv3, *argv4;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
	    &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum pkgOptions) optionIndex) {
	case PKG_FORGET: {
	    char *keyString;

	    for (i = 2; i < objc; i++) {
		keyString = Tcl_GetString(objv[i]);
		hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
		if (hPtr == NULL) {
		    continue;	
		}
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		Tcl_DeleteHashEntry(hPtr);
		if (pkgPtr->version != NULL) {
		    ckfree(pkgPtr->version);
		}
		while (pkgPtr->availPtr != NULL) {
		    availPtr = pkgPtr->availPtr;
		    pkgPtr->availPtr = availPtr->nextPtr;
		    ckfree(availPtr->version);
		    Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
		    ckfree((char *) availPtr);
		}
		ckfree((char *) pkgPtr);
	    }
	    break;
	}
	case PKG_IFNEEDED: {
	    int length;

	    if ((objc != 4) && (objc != 5)) {
		Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
		return TCL_ERROR;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    if (CheckVersion(interp, argv3) != TCL_OK) {
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if (objc == 4) {
		hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
		if (hPtr == NULL) {
		    return TCL_OK;
		}
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	    } else {
		pkgPtr = FindPackage(interp, argv2);
	    }
	    argv3 = Tcl_GetStringFromObj(objv[3], &length);
	    for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
		 prevPtr = availPtr, availPtr = availPtr->nextPtr) {
		if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
			== 0) {
		    if (objc == 4) {
			Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
			return TCL_OK;
		    }
		    Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
		    break;
		}
	    }
	    if (objc == 4) {
		return TCL_OK;
	    }
	    if (availPtr == NULL) {
		availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
		availPtr->version = ckalloc((unsigned) (length + 1));
		strcpy(availPtr->version, argv3);
		if (prevPtr == NULL) {
		    availPtr->nextPtr = pkgPtr->availPtr;
		    pkgPtr->availPtr = availPtr;
		} else {
		    availPtr->nextPtr = prevPtr->nextPtr;
		    prevPtr->nextPtr = availPtr;
		}
	    }
	    argv4 = Tcl_GetStringFromObj(objv[4], &length);
	    availPtr->script = ckalloc((unsigned) (length + 1));
	    strcpy(availPtr->script, argv4);
	    break;
	}
	case PKG_NAMES: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
	    tablePtr = &iPtr->packageTable;
	    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
		 hPtr = Tcl_NextHashEntry(&search)) {
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
		    Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
		}
	    }
	    break;
	}
	case PKG_PRESENT: {
	    if (objc < 3) {
		presentSyntax:
		Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
		exact = 1;
	    } else {
		exact = 0;
	    }
	    version = NULL;
	    if (objc == (4 + exact)) {
		version =  Tcl_GetString(objv[3 + exact]);
		if (CheckVersion(interp, version) != TCL_OK) {
		    return TCL_ERROR;
		}
	    } else if ((objc != 3) || exact) {
		goto presentSyntax;
	    }
	    if (exact) {
		argv3 =  Tcl_GetString(objv[3]);
		version = Tcl_PkgPresent(interp, argv3, version, exact);
	    } else {
		version = Tcl_PkgPresent(interp, argv2, version, exact);
	    }
	    if (version == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
	    break;
	}
	case PKG_PROVIDE: {
	    if ((objc != 3) && (objc != 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if (objc == 3) {
		hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
		if (hPtr != NULL) {
		    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		    if (pkgPtr->version != NULL) {
			Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
		    }
		}
		return TCL_OK;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    if (CheckVersion(interp, argv3) != TCL_OK) {
		return TCL_ERROR;
	    }
	    return Tcl_PkgProvide(interp, argv2, argv3);
	}
	case PKG_REQUIRE: {
	    if (objc < 3) {
		requireSyntax:
		Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
		exact = 1;
	    } else {
		exact = 0;
	    }
	    version = NULL;
	    if (objc == (4 + exact)) {
		version =  Tcl_GetString(objv[3 + exact]);
		if (CheckVersion(interp, version) != TCL_OK) {
		    return TCL_ERROR;
		}
	    } else if ((objc != 3) || exact) {
		goto requireSyntax;
	    }
	    if (exact) {
		argv3 =  Tcl_GetString(objv[3]);
		version = Tcl_PkgRequire(interp, argv3, version, exact);
	    } else {
		version = Tcl_PkgRequire(interp, argv2, version, exact);
	    }
	    if (version == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
	    break;
	}
	case PKG_UNKNOWN: {
	    int length;

	    if (objc == 2) {
		if (iPtr->packageUnknown != NULL) {
		    Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
		}
	    } else if (objc == 3) {
		if (iPtr->packageUnknown != NULL) {
		    ckfree(iPtr->packageUnknown);
		}
		argv2 = Tcl_GetStringFromObj(objv[2], &length);
		if (argv2[0] == 0) {
		    iPtr->packageUnknown = NULL;
		} else {
		    iPtr->packageUnknown = (char *) ckalloc((unsigned)
			    (length + 1));
		    strcpy(iPtr->packageUnknown, argv2);
		}
	    } else {
		Tcl_WrongNumArgs(interp, 2, objv, "?command?");
		return TCL_ERROR;
	    }
	    break;
	}
	case PKG_VCOMPARE: {
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
		return TCL_ERROR;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    argv2 = Tcl_GetString(objv[2]);
	    if ((CheckVersion(interp, argv2) != TCL_OK)
		    || (CheckVersion(interp, argv3) != TCL_OK)) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(
		    ComparePkgVersions(argv2, argv3, (int *) NULL)));
	    break;
	}
	case PKG_VERSIONS: {
	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "package");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		for (availPtr = pkgPtr->availPtr; availPtr != NULL;
		     availPtr = availPtr->nextPtr) {
		    Tcl_AppendElement(interp, availPtr->version);
		}
	    }
	    break;
	}
	case PKG_VSATISFIES: {
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
		return TCL_ERROR;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    argv2 = Tcl_GetString(objv[2]);
	    if ((CheckVersion(interp, argv2) != TCL_OK)
		    || (CheckVersion(interp, argv3) != TCL_OK)) {
		return TCL_ERROR;
	    }
	    ComparePkgVersions(argv2, argv3, &satisfies);
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
	    break;
	}
	default: {
	    Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindPackage --
 *
 *	This procedure finds the Package record for a particular package
 *	in a particular interpreter, creating a record if one doesn't
 *	already exist.
 *
 * Results:
 *	The return value is a pointer to the Package record for the
 *	package.
 *
 * Side effects:
 *	A new Package record may be created.
 *
 *----------------------------------------------------------------------
 */








|








|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<









|
|
|


|
<







515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580

581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622

623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675

676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707

708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723

724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745

746
747
748
749
750
751
752
753
754
755
756
757
758
759
760

761
762
763
764
765
766
767
768
769
770
771
772
773
774

775
776

777
778
779
780
781
782
783
784
785
786
787
788
789
790
791

792
793
794
795
796
797
798
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    CONST char *version;
    char *argv2, *argv3, *argv4;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
	    &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum pkgOptions) optionIndex) {
    case PKG_FORGET: {
	char *keyString;

	for (i = 2; i < objc; i++) {
	    keyString = Tcl_GetString(objv[i]);
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
	    if (hPtr == NULL) {
		continue;
	    }
	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    if (pkgPtr->version != NULL) {
		ckfree(pkgPtr->version);
	    }
	    while (pkgPtr->availPtr != NULL) {
		availPtr = pkgPtr->availPtr;
		pkgPtr->availPtr = availPtr->nextPtr;
		ckfree(availPtr->version);
		Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
		ckfree((char *) availPtr);
	    }
	    ckfree((char *) pkgPtr);
	}
	break;
    }
    case PKG_IFNEEDED: {
	int length;

	if ((objc != 4) && (objc != 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
	    return TCL_ERROR;
	}
	argv3 = Tcl_GetString(objv[3]);
	if (CheckVersion(interp, argv3) != TCL_OK) {
	    return TCL_ERROR;
	}
	argv2 = Tcl_GetString(objv[2]);
	if (objc == 4) {
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr == NULL) {
		return TCL_OK;
	    }
	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	} else {
	    pkgPtr = FindPackage(interp, argv2);
	}
	argv3 = Tcl_GetStringFromObj(objv[3], &length);
	for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
		prevPtr = availPtr, availPtr = availPtr->nextPtr) {
	    if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)==0){

		if (objc == 4) {
		    Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
		    return TCL_OK;
		}
		Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
		break;
	    }
	}
	if (objc == 4) {
	    return TCL_OK;
	}
	if (availPtr == NULL) {
	    availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
	    availPtr->version = ckalloc((unsigned) (length + 1));
	    strcpy(availPtr->version, argv3);
	    if (prevPtr == NULL) {
		availPtr->nextPtr = pkgPtr->availPtr;
		pkgPtr->availPtr = availPtr;
	    } else {
		availPtr->nextPtr = prevPtr->nextPtr;
		prevPtr->nextPtr = availPtr;
	    }
	}
	argv4 = Tcl_GetStringFromObj(objv[4], &length);
	availPtr->script = ckalloc((unsigned) (length + 1));
	strcpy(availPtr->script, argv4);
	break;
    }
    case PKG_NAMES:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	tablePtr = &iPtr->packageTable;
	for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
		hPtr = Tcl_NextHashEntry(&search)) {
	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	    if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
		Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
	    }
	}
	break;

    case PKG_PRESENT:
	if (objc < 3) {
	presentSyntax:
	    Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
	    return TCL_ERROR;
	}
	argv2 = Tcl_GetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    exact = 1;
	} else {
	    exact = 0;
	}
	version = NULL;
	if (objc == (4 + exact)) {
	    version =  Tcl_GetString(objv[3 + exact]);
	    if (CheckVersion(interp, version) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else if ((objc != 3) || exact) {
	    goto presentSyntax;
	}
	if (exact) {
	    argv3 =  Tcl_GetString(objv[3]);
	    version = Tcl_PkgPresent(interp, argv3, version, exact);
	} else {
	    version = Tcl_PkgPresent(interp, argv2, version, exact);
	}
	if (version == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
	break;

    case PKG_PROVIDE:
	if ((objc != 3) && (objc != 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
	    return TCL_ERROR;
	}
	argv2 = Tcl_GetString(objv[2]);
	if (objc == 3) {
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		if (pkgPtr->version != NULL) {
		    Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
		}
	    }
	    return TCL_OK;
	}
	argv3 = Tcl_GetString(objv[3]);
	if (CheckVersion(interp, argv3) != TCL_OK) {
	    return TCL_ERROR;
	}
	return Tcl_PkgProvide(interp, argv2, argv3);

    case PKG_REQUIRE:
	if (objc < 3) {
	requireSyntax:
	    Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
	    return TCL_ERROR;
	}
	argv2 = Tcl_GetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    exact = 1;
	} else {
	    exact = 0;
	}
	version = NULL;
	if (objc == (4 + exact)) {
	    version =  Tcl_GetString(objv[3 + exact]);
	    if (CheckVersion(interp, version) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else if ((objc != 3) || exact) {
	    goto requireSyntax;
	}
	if (exact) {
	    argv3 =  Tcl_GetString(objv[3]);
	    version = Tcl_PkgRequire(interp, argv3, version, exact);
	} else {
	    version = Tcl_PkgRequire(interp, argv2, version, exact);
	}
	if (version == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1));
	break;

    case PKG_UNKNOWN: {
	int length;

	if (objc == 2) {
	    if (iPtr->packageUnknown != NULL) {
		Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
	    }
	} else if (objc == 3) {
	    if (iPtr->packageUnknown != NULL) {
		ckfree(iPtr->packageUnknown);
	    }
	    argv2 = Tcl_GetStringFromObj(objv[2], &length);
	    if (argv2[0] == 0) {
		iPtr->packageUnknown = NULL;
	    } else {
		iPtr->packageUnknown = (char *) ckalloc((unsigned) (length+1));

		strcpy(iPtr->packageUnknown, argv2);
	    }
	} else {
	    Tcl_WrongNumArgs(interp, 2, objv, "?command?");
	    return TCL_ERROR;
	}
	break;
    }
    case PKG_VCOMPARE:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
	    return TCL_ERROR;
	}
	argv3 = Tcl_GetString(objv[3]);
	argv2 = Tcl_GetString(objv[2]);
	if ((CheckVersion(interp, argv2) != TCL_OK)
		|| (CheckVersion(interp, argv3) != TCL_OK)) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(
		ComparePkgVersions(argv2, argv3, (int *) NULL)));
	break;

    case PKG_VERSIONS:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "package");
	    return TCL_ERROR;
	}
	argv2 = Tcl_GetString(objv[2]);
	hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	if (hPtr != NULL) {
	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	    for (availPtr = pkgPtr->availPtr; availPtr != NULL;
		    availPtr = availPtr->nextPtr) {
		Tcl_AppendElement(interp, availPtr->version);
	    }
	}
	break;

    case PKG_VSATISFIES:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
	    return TCL_ERROR;
	}
	argv3 = Tcl_GetString(objv[3]);
	argv2 = Tcl_GetString(objv[2]);
	if ((CheckVersion(interp, argv2) != TCL_OK)
		|| (CheckVersion(interp, argv3) != TCL_OK)) {
	    return TCL_ERROR;
	}
	ComparePkgVersions(argv2, argv3, &satisfies);
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
	break;

    default:
	Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");

    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindPackage --
 *
 *	This procedure finds the Package record for a particular package in a
 *	particular interpreter, creating a record if one doesn't already
 *	exist.
 *
 * Results:
 *	The return value is a pointer to the Package record for the package.

 *
 * Side effects:
 *	A new Package record may be created.
 *
 *----------------------------------------------------------------------
 */

843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreePackageInfo --
 *
 *	This procedure is called during interpreter deletion to
 *	free all of the package-related information for the
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *







|
|
<







820
821
822
823
824
825
826
827
828

829
830
831
832
833
834
835
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreePackageInfo --
 *
 *	This procedure is called during interpreter deletion to free all of
 *	the package-related information for the interpreter.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
}

/*
 *----------------------------------------------------------------------
 *
 * CheckVersion --
 *
 *	This procedure checks to see whether a version number has
 *	valid syntax.
 *
 * Results:
 *	If string is a properly formed version number the TCL_OK
 *	is returned.  Otherwise TCL_ERROR is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CheckVersion(interp, string)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *string;		/* Supposedly a version number, which is
				 * groups of decimal digits separated
				 * by dots. */
{
    CONST char *p = string;
    char prevChar;
    
    if (!isdigit(UCHAR(*p))) {	/* INTL: digit */
	goto error;
    }
    for (prevChar = *p, p++; *p != 0; p++) {
	if (!isdigit(UCHAR(*p)) &&
		((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
	    goto error;
	}
	prevChar = *p;
    }
    if (prevChar != '.') {
	return TCL_OK;
    }

    error:
    Tcl_AppendResult(interp, "expected version number but got \"",
	    string, "\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ComparePkgVersions --
 *
 *	This procedure compares two version numbers.
 *
 * Results:
 *	The return value is -1 if v1 is less than v2, 0 if the two
 *	version numbers are the same, and 1 if v1 is greater than v2.
 *	If *satPtr is non-NULL, the word it points to is filled in
 *	with 1 if v2 >= v1 and both numbers have the same major number
 *	or 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ComparePkgVersions(v1, v2, satPtr)
    CONST char *v1;
    CONST char *v2;		/* Versions strings, of form 2.1.3 (any
				 * number of version numbers). */
    int *satPtr;		/* If non-null, the word pointed to is
				 * filled in with a 0/1 value.  1 means
				 * v1 "satisfies" v2:  v1 is greater than
				 * or equal to v2 and both version numbers
				 * have the same major number. */
{
    int thisIsMajor, n1, n2;

    /*
     * Each iteration of the following loop processes one number from
     * each string, terminated by a ".".  If those numbers don't match
     * then the comparison is over;  otherwise, we loop back for the
     * next number.
     */

    thisIsMajor = 1;
    while (1) {
	/*
	 * Parse one decimal number from the front of each string.
	 */

	n1 = n2 = 0;
	while ((*v1 != 0) && (*v1 != '.')) {
	    n1 = 10*n1 + (*v1 - '0');
	    v1++;
	}
	while ((*v2 != 0) && (*v2 != '.')) {
	    n2 = 10*n2 + (*v2 - '0');
	    v2++;
	}

	/*
	 * Compare and go on to the next version number if the
	 * current numbers match.
	 */

	if (n1 != n2) {
	    break;
	}
	if (*v1 != 0) {
	    v1++;







|
|


|
|
|











|
|



|














|
|
|











|
|
|
|
<










|
|
|
|
|
|
|




|
|
|
<



















|
|







867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929

930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953

954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
}

/*
 *----------------------------------------------------------------------
 *
 * CheckVersion --
 *
 *	This procedure checks to see whether a version number has valid
 *	syntax.
 *
 * Results:
 *	If string is a properly formed version number the TCL_OK is returned.
 *	Otherwise TCL_ERROR is returned and an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CheckVersion(interp, string)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *string;		/* Supposedly a version number, which is
				 * groups of decimal digits separated by
				 * dots. */
{
    CONST char *p = string;
    char prevChar;

    if (!isdigit(UCHAR(*p))) {	/* INTL: digit */
	goto error;
    }
    for (prevChar = *p, p++; *p != 0; p++) {
	if (!isdigit(UCHAR(*p)) &&
		((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
	    goto error;
	}
	prevChar = *p;
    }
    if (prevChar != '.') {
	return TCL_OK;
    }

  error:
    Tcl_AppendResult(interp, "expected version number but got \"", string,
	    "\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ComparePkgVersions --
 *
 *	This procedure compares two version numbers.
 *
 * Results:
 *	The return value is -1 if v1 is less than v2, 0 if the two version
 *	numbers are the same, and 1 if v1 is greater than v2.  If *satPtr is
 *	non-NULL, the word it points to is filled in with 1 if v2 >= v1 and
 *	both numbers have the same major number or 0 otherwise.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ComparePkgVersions(v1, v2, satPtr)
    CONST char *v1;
    CONST char *v2;		/* Versions strings, of form 2.1.3 (any number
				 * of version numbers). */
    int *satPtr;		/* If non-null, the word pointed to is filled
				 * in with a 0/1 value. 1 means v1 "satisfies"
				 * v2: v1 is greater than or equal to v2 and
				 * both version numbers have the same major
				 * number. */
{
    int thisIsMajor, n1, n2;

    /*
     * Each iteration of the following loop processes one number from each
     * string, terminated by a ".".  If those numbers don't match then the
     * comparison is over; otherwise, we loop back for the next number.

     */

    thisIsMajor = 1;
    while (1) {
	/*
	 * Parse one decimal number from the front of each string.
	 */

	n1 = n2 = 0;
	while ((*v1 != 0) && (*v1 != '.')) {
	    n1 = 10*n1 + (*v1 - '0');
	    v1++;
	}
	while ((*v2 != 0) && (*v2 != '.')) {
	    n2 = 10*n2 + (*v2 - '0');
	    v2++;
	}

	/*
	 * Compare and go on to the next version number if the current numbers
	 * match.
	 */

	if (n1 != n2) {
	    break;
	}
	if (*v1 != 0) {
	    v1++;
1020
1021
1022
1023
1024
1025
1026








	return 1;
    } else if (n1 == n2) {
	return 0;
    } else {
	return -1;
    }
}















>
>
>
>
>
>
>
>
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
	return 1;
    } else if (n1 == n2) {
	return 0;
    } else {
	return -1;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPkgConfig.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

44
45
46
47
48
49

50
51
52
53
54

55
56
57
58
59

60
61
62
63
64

65
66
67
68
69

70
71
72
73
74

75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122








/* 
 * tclPkgConfig.c --
 *
 *	This file contains the configuration information to
 *	embed into the tcl binary library.
 *
 * Copyright (c) 2002 Andreas Kupries <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPkgConfig.c,v 1.2 2003/06/09 22:48:33 andreas_kupries Exp $
 */

/* Note, the definitions in this module are influenced by the
 * following C preprocessor macros:
 *
 * OSCMa  = shortcut for "old style configuration macro activates"
 * NSCMdt = shortcut for "new style configuration macro declares that"
 *
 * - TCL_THREADS		OSCMa  compilation as threaded core.
 * - TCL_MEM_DEBUG		OSCMa  memory debugging.
 * - TCL_COMPILE_DEBUG		OSCMa  debugging of bytecode compiler.
 * - TCL_COMPILE_STATS		OSCMa  bytecode compiler statistics.
 *
 * - TCL_CFG_DO64BIT		NSCMdt tcl is compiled for a 64bit system.
 * - TCL_CFG_DEBUG		NSCMdt tcl is compiled with symbol info on.
 * - TCL_CFG_OPTIMIZED		NSCMdt tcl is compiled with cc optimizations on.
 * - TCL_CFG_PROFILED		NSCMdt tcl is compiled with profiling info.
 *
 * - CFG_RUNTIME_*		Paths to various stuff at runtime.
 * - CFG_INSTALL_*		Paths to various stuff at installation time.
 *
 * - TCL_CFGVAL_ENCODING	string containing the encoding used for the
 *                              configuration values.
 */

#include "tclInt.h"



/* Use C preprocessor statements to define the various values for the
 * embedded configuration information.  */


#ifdef TCL_THREADS
#  define  CFG_THREADED "1"
#else
#  define  CFG_THREADED "0"
#endif

#ifdef TCL_MEM_DEBUG
#  define CFG_MEMDEBUG "1"
#else
#  define CFG_MEMDEBUG "0"
#endif

#ifdef TCL_COMPILE_DEBUG
#  define CFG_COMPILE_DEBUG "1"
#else
#  define CFG_COMPILE_DEBUG "0"
#endif

#ifdef TCL_COMPILE_STATS
#  define CFG_COMPILE_STATS "1"
#else
#  define CFG_COMPILE_STATS "0"
#endif

#ifdef TCL_CFG_DO64BIT
#  define CFG_64            "1"
#else
#  define CFG_64            "0"
#endif

#ifdef TCL_CFG_DEBUG
#  define CFG_DEBUG         "1"
#else
#  define CFG_DEBUG         "0"
#endif

#ifdef TCL_CFG_OPTIMIZED
#  define CFG_OPTIMIZED     "1"
#else
#  define CFG_OPTIMIZED     "0"
#endif

#ifdef TCL_CFG_PROFILED
#  define CFG_PROFILED     "1"
#else
#  define CFG_PROFILED     "0"
#endif

static Tcl_Config cfg [] = {
  {"debug",               CFG_DEBUG},
  {"threaded",            CFG_THREADED},
  {"profiled",            CFG_PROFILED},
  {"64bit",               CFG_64},
  {"optimized",           CFG_OPTIMIZED},
  {"mem_debug",           CFG_MEMDEBUG},
  {"compile_debug",       CFG_COMPILE_DEBUG},
  {"compile_stats",       CFG_COMPILE_STATS},

  /* Runtime paths to various stuff */

  {"libdir,runtime",     CFG_RUNTIME_LIBDIR},
  {"bindir,runtime",     CFG_RUNTIME_BINDIR},
  {"scriptdir,runtime",  CFG_RUNTIME_SCRDIR},
  {"includedir,runtime", CFG_RUNTIME_INCDIR},
  {"docdir,runtime",     CFG_RUNTIME_DOCDIR},

  /* Installation paths to various stuff */

  {"libdir,install",     CFG_INSTALL_LIBDIR},
  {"bindir,install",     CFG_INSTALL_BINDIR},
  {"scriptdir,install",  CFG_INSTALL_SCRDIR},
  {"includedir,install", CFG_INSTALL_INCDIR},
  {"docdir,install",     CFG_INSTALL_DOCDIR},

  /* Last entry, closes the array */
  {NULL, NULL}
};

void
TclInitEmbeddedConfigurationInformation (interp)
     Tcl_Interp* interp;            /* Interpreter the configuration
				     * command is registered in. */
{
  Tcl_RegisterConfig (interp, "tcl", cfg, TCL_CFGVAL_ENCODING);
}








|


|
|



|
|

|


|
|




|
|
|
|



|






|



|
|
<
|
|
>


|

|

>

|

|

>

|

|

>

|

|

>

|

|

>

|

|

>

|

|

>

|

|


|
|
|
|
|
|
|
|
|

|

|
|
|
|
|

|

|
|
|
|
|

|
|

|

|
|
|

|

>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
/*
 * tclPkgConfig.c --
 *
 *	This file contains the configuration information to embed into the tcl
 *	binary library.
 *
 * Copyright (c) 2002 Andreas Kupries <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPkgConfig.c,v 1.2.4.1 2005/08/02 18:16:06 dgp Exp $
 */

/* Note, the definitions in this module are influenced by the following C
 * preprocessor macros:
 *
 * OSCMa  = shortcut for "old style configuration macro activates"
 * NSCMdt = shortcut for "new style configuration macro declares that"
 *
 * - TCL_THREADS		OSCMa compilation as threaded core.
 * - TCL_MEM_DEBUG		OSCMa memory debugging.
 * - TCL_COMPILE_DEBUG		OSCMa debugging of bytecode compiler.
 * - TCL_COMPILE_STATS		OSCMa bytecode compiler statistics.
 *
 * - TCL_CFG_DO64BIT		NSCMdt tcl is compiled for a 64bit system.
 * - TCL_CFG_DEBUG		NSCMdt tcl is compiled with symbol info on.
 * - TCL_CFG_OPTIMIZED		NSCMdt tcl is compiled with cc optimizations on
 * - TCL_CFG_PROFILED		NSCMdt tcl is compiled with profiling info.
 *
 * - CFG_RUNTIME_*		Paths to various stuff at runtime.
 * - CFG_INSTALL_*		Paths to various stuff at installation time.
 *
 * - TCL_CFGVAL_ENCODING	string containing the encoding used for the
 *				configuration values.
 */

#include "tclInt.h"

/*

 * Use C preprocessor statements to define the various values for the embedded
 * configuration information.
 */

#ifdef TCL_THREADS
#  define  CFG_THREADED		"1"
#else
#  define  CFG_THREADED		"0"
#endif

#ifdef TCL_MEM_DEBUG
#  define CFG_MEMDEBUG		"1"
#else
#  define CFG_MEMDEBUG		"0"
#endif

#ifdef TCL_COMPILE_DEBUG
#  define CFG_COMPILE_DEBUG	"1"
#else
#  define CFG_COMPILE_DEBUG	"0"
#endif

#ifdef TCL_COMPILE_STATS
#  define CFG_COMPILE_STATS	"1"
#else
#  define CFG_COMPILE_STATS	"0"
#endif

#ifdef TCL_CFG_DO64BIT
#  define CFG_64		"1"
#else
#  define CFG_64		"0"
#endif

#ifdef TCL_CFG_DEBUG
#  define CFG_DEBUG		"1"
#else
#  define CFG_DEBUG		"0"
#endif

#ifdef TCL_CFG_OPTIMIZED
#  define CFG_OPTIMIZED		"1"
#else
#  define CFG_OPTIMIZED		"0"
#endif

#ifdef TCL_CFG_PROFILED
#  define CFG_PROFILED		"1"
#else
#  define CFG_PROFILED		"0"
#endif

static Tcl_Config cfg[] = {
    {"debug",			CFG_DEBUG},
    {"threaded",		CFG_THREADED},
    {"profiled",		CFG_PROFILED},
    {"64bit",			CFG_64},
    {"optimized",		CFG_OPTIMIZED},
    {"mem_debug",		CFG_MEMDEBUG},
    {"compile_debug",		CFG_COMPILE_DEBUG},
    {"compile_stats",		CFG_COMPILE_STATS},

    /* Runtime paths to various stuff */

    {"libdir,runtime",		CFG_RUNTIME_LIBDIR},
    {"bindir,runtime",		CFG_RUNTIME_BINDIR},
    {"scriptdir,runtime",	CFG_RUNTIME_SCRDIR},
    {"includedir,runtime",	CFG_RUNTIME_INCDIR},
    {"docdir,runtime",		CFG_RUNTIME_DOCDIR},

    /* Installation paths to various stuff */

    {"libdir,install",		CFG_INSTALL_LIBDIR},
    {"bindir,install",		CFG_INSTALL_BINDIR},
    {"scriptdir,install",	CFG_INSTALL_SCRDIR},
    {"includedir,install",	CFG_INSTALL_INCDIR},
    {"docdir,install",		CFG_INSTALL_DOCDIR},

    /* Last entry, closes the array */
    {NULL, NULL}
};

void
TclInitEmbeddedConfigurationInformation(interp)
    Tcl_Interp* interp;		/* Interpreter the configuration command is
				 * registered in. */
{
    Tcl_RegisterConfig(interp, "tcl", cfg, TCL_CFGVAL_ENCODING);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPort.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
/*
 * tclPort.h --
 *
 *	This header file handles porting issues that occur because
 *	of differences between systems.  It reads in platform specific
 *	portability files.
 *
 * Copyright (c) 1994-1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPort.h,v 1.13 2004/11/24 21:37:31 davygrvy Exp $
 */

#ifndef _TCLPORT
#define _TCLPORT

#include "tcl.h"
#ifdef HAVE_TCL_CONFIG_H
#include "tclConfig.h"
#endif


#if defined(__WIN32__)
#   include "../win/tclWinPort.h"
#else
#   include "tclUnixPort.h"
#endif













|





<



>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
/*
 * tclPort.h --
 *
 *	This header file handles porting issues that occur because
 *	of differences between systems.  It reads in platform specific
 *	portability files.
 *
 * Copyright (c) 1994-1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPort.h,v 1.13.2.2 2005/01/20 19:13:50 kennykb Exp $
 */

#ifndef _TCLPORT
#define _TCLPORT


#ifdef HAVE_TCL_CONFIG_H
#include "tclConfig.h"
#endif
#include "tcl.h"

#if defined(__WIN32__)
#   include "../win/tclWinPort.h"
#else
#   include "tclUnixPort.h"
#endif

Changes to generic/tclPosixStr.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179








/* 
 * tclPosixStr.c --
 *
 *	This file contains procedures that generate strings
 *	corresponding to various POSIX-related codes, such
 *	as errno and signals.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPosixStr.c,v 1.10 2004/04/06 22:25:54 dgp Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrnoId --
 *
 *	Return a textual identifier for the current errno value.
 *
 * Results:
 *	This procedure returns a machine-readable textual identifier
 *	that corresponds to the current errno value (e.g. "EPERM").
 *	The identifier is the same as the #define name in errno.h.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ErrnoId()
{
    switch (errno) {
#ifdef E2BIG
	case E2BIG: return "E2BIG";
#endif
#ifdef EACCES
	case EACCES: return "EACCES";
#endif
#ifdef EADDRINUSE
	case EADDRINUSE: return "EADDRINUSE";
#endif
#ifdef EADDRNOTAVAIL
	case EADDRNOTAVAIL: return "EADDRNOTAVAIL";
#endif
#ifdef EADV
	case EADV: return "EADV";
#endif
#ifdef EAFNOSUPPORT
	case EAFNOSUPPORT: return "EAFNOSUPPORT";
#endif
#ifdef EAGAIN
	case EAGAIN: return "EAGAIN";
#endif
#ifdef EALIGN
	case EALIGN: return "EALIGN";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY ))
	case EALREADY: return "EALREADY";
#endif
#ifdef EBADE
	case EBADE: return "EBADE";
#endif
#ifdef EBADF
	case EBADF: return "EBADF";
#endif
#ifdef EBADFD
	case EBADFD: return "EBADFD";
#endif
#ifdef EBADMSG
	case EBADMSG: return "EBADMSG";
#endif
#ifdef EBADR
	case EBADR: return "EBADR";
#endif
#ifdef EBADRPC
	case EBADRPC: return "EBADRPC";
#endif
#ifdef EBADRQC
	case EBADRQC: return "EBADRQC";
#endif
#ifdef EBADSLT
	case EBADSLT: return "EBADSLT";
#endif
#ifdef EBFONT
	case EBFONT: return "EBFONT";
#endif
#ifdef EBUSY
	case EBUSY: return "EBUSY";
#endif
#ifdef ECHILD
	case ECHILD: return "ECHILD";
#endif
#ifdef ECHRNG
	case ECHRNG: return "ECHRNG";
#endif
#ifdef ECOMM
	case ECOMM: return "ECOMM";
#endif
#ifdef ECONNABORTED
	case ECONNABORTED: return "ECONNABORTED";
#endif
#ifdef ECONNREFUSED
	case ECONNREFUSED: return "ECONNREFUSED";
#endif
#ifdef ECONNRESET
	case ECONNRESET: return "ECONNRESET";
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
	case EDEADLK: return "EDEADLK";
#endif
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
	case EDEADLOCK: return "EDEADLOCK";
#endif
#ifdef EDESTADDRREQ
	case EDESTADDRREQ: return "EDESTADDRREQ";
#endif
#ifdef EDIRTY
	case EDIRTY: return "EDIRTY";
#endif
#ifdef EDOM
	case EDOM: return "EDOM";
#endif
#ifdef EDOTDOT
	case EDOTDOT: return "EDOTDOT";
#endif
#ifdef EDQUOT
	case EDQUOT: return "EDQUOT";
#endif
#ifdef EDUPPKG
	case EDUPPKG: return "EDUPPKG";
#endif
#ifdef EEXIST
	case EEXIST: return "EEXIST";
#endif
#ifdef EFAULT
	case EFAULT: return "EFAULT";
#endif
#ifdef EFBIG
	case EFBIG: return "EFBIG";
#endif
#ifdef EHOSTDOWN
	case EHOSTDOWN: return "EHOSTDOWN";
#endif
#ifdef EHOSTUNREACH
	case EHOSTUNREACH: return "EHOSTUNREACH";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
	case EIDRM: return "EIDRM";
#endif
#ifdef EINIT
	case EINIT: return "EINIT";
#endif
#ifdef EINPROGRESS
	case EINPROGRESS: return "EINPROGRESS";
#endif
#ifdef EINTR
	case EINTR: return "EINTR";
#endif
#ifdef EINVAL
	case EINVAL: return "EINVAL";
#endif
#ifdef EIO
	case EIO: return "EIO";
#endif
#ifdef EISCONN
	case EISCONN: return "EISCONN";
#endif
#ifdef EISDIR
	case EISDIR: return "EISDIR";
#endif
#ifdef EISNAME
	case EISNAM: return "EISNAM";
#endif
#ifdef ELBIN
	case ELBIN: return "ELBIN";
#endif
#ifdef EL2HLT
	case EL2HLT: return "EL2HLT";
#endif
#ifdef EL2NSYNC
	case EL2NSYNC: return "EL2NSYNC";
#endif
#ifdef EL3HLT
	case EL3HLT: return "EL3HLT";
#endif
#ifdef EL3RST
	case EL3RST: return "EL3RST";
#endif
#ifdef ELIBACC
	case ELIBACC: return "ELIBACC";
#endif
#ifdef ELIBBAD
	case ELIBBAD: return "ELIBBAD";
#endif
#ifdef ELIBEXEC
	case ELIBEXEC: return "ELIBEXEC";
#endif
#ifdef ELIBMAX
	case ELIBMAX: return "ELIBMAX";
#endif
#ifdef ELIBSCN
	case ELIBSCN: return "ELIBSCN";
#endif
#ifdef ELNRNG
	case ELNRNG: return "ELNRNG";
#endif
#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT))
	case ELOOP: return "ELOOP";
#endif
#ifdef EMFILE
	case EMFILE: return "EMFILE";
#endif
#ifdef EMLINK
	case EMLINK: return "EMLINK";
#endif
#ifdef EMSGSIZE
	case EMSGSIZE: return "EMSGSIZE";
#endif
#ifdef EMULTIHOP
	case EMULTIHOP: return "EMULTIHOP";
#endif
#ifdef ENAMETOOLONG
	case ENAMETOOLONG: return "ENAMETOOLONG";
#endif
#ifdef ENAVAIL
	case ENAVAIL: return "ENAVAIL";
#endif
#ifdef ENET
	case ENET: return "ENET";
#endif
#ifdef ENETDOWN
	case ENETDOWN: return "ENETDOWN";
#endif
#ifdef ENETRESET
	case ENETRESET: return "ENETRESET";
#endif
#ifdef ENETUNREACH
	case ENETUNREACH: return "ENETUNREACH";
#endif
#ifdef ENFILE
	case ENFILE: return "ENFILE";
#endif
#ifdef ENOANO
	case ENOANO: return "ENOANO";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
	case ENOBUFS: return "ENOBUFS";
#endif
#ifdef ENOCSI
	case ENOCSI: return "ENOCSI";
#endif
#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED))
	case ENODATA: return "ENODATA";
#endif
#ifdef ENODEV
	case ENODEV: return "ENODEV";
#endif
#ifdef ENOENT
	case ENOENT: return "ENOENT";
#endif
#ifdef ENOEXEC
	case ENOEXEC: return "ENOEXEC";
#endif
#ifdef ENOLCK
	case ENOLCK: return "ENOLCK";
#endif
#ifdef ENOLINK
	case ENOLINK: return "ENOLINK";
#endif
#ifdef ENOMEM
	case ENOMEM: return "ENOMEM";
#endif
#ifdef ENOMSG
	case ENOMSG: return "ENOMSG";
#endif
#ifdef ENONET
	case ENONET: return "ENONET";
#endif
#ifdef ENOPKG
	case ENOPKG: return "ENOPKG";
#endif
#ifdef ENOPROTOOPT
	case ENOPROTOOPT: return "ENOPROTOOPT";
#endif
#ifdef ENOSPC
	case ENOSPC: return "ENOSPC";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
	case ENOSR: return "ENOSR";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
	case ENOSTR: return "ENOSTR";
#endif
#ifdef ENOSYM
	case ENOSYM: return "ENOSYM";
#endif
#ifdef ENOSYS
	case ENOSYS: return "ENOSYS";
#endif
#ifdef ENOTBLK
	case ENOTBLK: return "ENOTBLK";
#endif
#ifdef ENOTCONN
	case ENOTCONN: return "ENOTCONN";
#endif
#ifdef ENOTDIR
	case ENOTDIR: return "ENOTDIR";
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
	case ENOTEMPTY: return "ENOTEMPTY";
#endif
#ifdef ENOTNAM
	case ENOTNAM: return "ENOTNAM";
#endif
#ifdef ENOTSOCK
	case ENOTSOCK: return "ENOTSOCK";
#endif
#ifdef ENOTSUP
	case ENOTSUP: return "ENOTSUP";
#endif
#ifdef ENOTTY
	case ENOTTY: return "ENOTTY";
#endif
#ifdef ENOTUNIQ
	case ENOTUNIQ: return "ENOTUNIQ";
#endif
#ifdef ENXIO
	case ENXIO: return "ENXIO";
#endif
#if defined(EOPNOTSUPP) &&  (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
	case EOPNOTSUPP: return "EOPNOTSUPP";
#endif
#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) )
        case EOVERFLOW: return "EOVERFLOW";
#endif
#ifdef EPERM
	case EPERM: return "EPERM";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
	case EPFNOSUPPORT: return "EPFNOSUPPORT";
#endif
#ifdef EPIPE
	case EPIPE: return "EPIPE";
#endif
#ifdef EPROCLIM
	case EPROCLIM: return "EPROCLIM";
#endif
#ifdef EPROCUNAVAIL
	case EPROCUNAVAIL: return "EPROCUNAVAIL";
#endif
#ifdef EPROGMISMATCH
	case EPROGMISMATCH: return "EPROGMISMATCH";
#endif
#ifdef EPROGUNAVAIL
	case EPROGUNAVAIL: return "EPROGUNAVAIL";
#endif
#ifdef EPROTO
	case EPROTO: return "EPROTO";
#endif
#ifdef EPROTONOSUPPORT
	case EPROTONOSUPPORT: return "EPROTONOSUPPORT";
#endif
#ifdef EPROTOTYPE
	case EPROTOTYPE: return "EPROTOTYPE";
#endif
#ifdef ERANGE
	case ERANGE: return "ERANGE";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
	case EREFUSED: return "EREFUSED";
#endif
#ifdef EREMCHG
	case EREMCHG: return "EREMCHG";
#endif
#ifdef EREMDEV
	case EREMDEV: return "EREMDEV";
#endif
#ifdef EREMOTE
	case EREMOTE: return "EREMOTE";
#endif
#ifdef EREMOTEIO
	case EREMOTEIO: return "EREMOTEIO";
#endif
#ifdef EREMOTERELEASE
	case EREMOTERELEASE: return "EREMOTERELEASE";
#endif
#ifdef EROFS
	case EROFS: return "EROFS";
#endif
#ifdef ERPCMISMATCH
	case ERPCMISMATCH: return "ERPCMISMATCH";
#endif
#ifdef ERREMOTE
	case ERREMOTE: return "ERREMOTE";
#endif
#ifdef ESHUTDOWN
	case ESHUTDOWN: return "ESHUTDOWN";
#endif
#ifdef ESOCKTNOSUPPORT
	case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT";
#endif
#ifdef ESPIPE
	case ESPIPE: return "ESPIPE";
#endif
#ifdef ESRCH
	case ESRCH: return "ESRCH";
#endif
#ifdef ESRMNT
	case ESRMNT: return "ESRMNT";
#endif
#ifdef ESTALE
	case ESTALE: return "ESTALE";
#endif
#ifdef ESUCCESS
	case ESUCCESS: return "ESUCCESS";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
	case ETIME: return "ETIME";
#endif
#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR))
	case ETIMEDOUT: return "ETIMEDOUT";
#endif
#ifdef ETOOMANYREFS
	case ETOOMANYREFS: return "ETOOMANYREFS";
#endif
#ifdef ETXTBSY
	case ETXTBSY: return "ETXTBSY";
#endif
#ifdef EUCLEAN
	case EUCLEAN: return "EUCLEAN";
#endif
#ifdef EUNATCH
	case EUNATCH: return "EUNATCH";
#endif
#ifdef EUSERS
	case EUSERS: return "EUSERS";
#endif
#ifdef EVERSION
	case EVERSION: return "EVERSION";
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
	case EWOULDBLOCK: return "EWOULDBLOCK";
#endif
#ifdef EXDEV
	case EXDEV: return "EXDEV";
#endif
#ifdef EXFULL
	case EXFULL: return "EXFULL";
#endif
    }
    return "unknown error";
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrnoMsg --
 *
 *	Return a human-readable message corresponding to a given
 *	errno value.
 *
 * Results:
 *	The return value is the standard POSIX error message for
 *	errno.  This procedure is used instead of strerror because
 *	strerror returns slightly different values on different
 *	machines (e.g. different capitalizations), which cause
 *	problems for things such as regression tests.  This procedure
 *	provides messages for most standard errors, then it calls
 *	strerror for things it doesn't understand.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ErrnoMsg(err)
    int err;			/* Error number (such as in errno variable). */
{
    switch (err) {
#ifdef E2BIG
	case E2BIG: return "argument list too long";
#endif
#ifdef EACCES
	case EACCES: return "permission denied";
#endif
#ifdef EADDRINUSE
	case EADDRINUSE: return "address already in use";
#endif
#ifdef EADDRNOTAVAIL
	case EADDRNOTAVAIL: return "can't assign requested address";
#endif
#ifdef EADV
	case EADV: return "advertise error";
#endif
#ifdef EAFNOSUPPORT
	case EAFNOSUPPORT: return "address family not supported by protocol family";
#endif
#ifdef EAGAIN
	case EAGAIN: return "resource temporarily unavailable";
#endif
#ifdef EALIGN
	case EALIGN: return "EALIGN";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY ))
	case EALREADY: return "operation already in progress";
#endif
#ifdef EBADE
	case EBADE: return "bad exchange descriptor";
#endif
#ifdef EBADF
	case EBADF: return "bad file number";
#endif
#ifdef EBADFD
	case EBADFD: return "file descriptor in bad state";
#endif
#ifdef EBADMSG
	case EBADMSG: return "not a data message";
#endif
#ifdef EBADR
	case EBADR: return "bad request descriptor";
#endif
#ifdef EBADRPC
	case EBADRPC: return "RPC structure is bad";
#endif
#ifdef EBADRQC
	case EBADRQC: return "bad request code";
#endif
#ifdef EBADSLT
	case EBADSLT: return "invalid slot";
#endif
#ifdef EBFONT
	case EBFONT: return "bad font file format";
#endif
#ifdef EBUSY
	case EBUSY: return "file busy";
#endif
#ifdef ECHILD
	case ECHILD: return "no children";
#endif
#ifdef ECHRNG
	case ECHRNG: return "channel number out of range";
#endif
#ifdef ECOMM
	case ECOMM: return "communication error on send";
#endif
#ifdef ECONNABORTED
	case ECONNABORTED: return "software caused connection abort";
#endif
#ifdef ECONNREFUSED
	case ECONNREFUSED: return "connection refused";
#endif
#ifdef ECONNRESET
	case ECONNRESET: return "connection reset by peer";
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
	case EDEADLK: return "resource deadlock avoided";
#endif
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
	case EDEADLOCK: return "resource deadlock avoided";
#endif
#ifdef EDESTADDRREQ
	case EDESTADDRREQ: return "destination address required";
#endif
#ifdef EDIRTY
	case EDIRTY: return "mounting a dirty fs w/o force";
#endif
#ifdef EDOM
	case EDOM: return "math argument out of range";
#endif
#ifdef EDOTDOT
	case EDOTDOT: return "cross mount point";
#endif
#ifdef EDQUOT
	case EDQUOT: return "disk quota exceeded";
#endif
#ifdef EDUPPKG
	case EDUPPKG: return "duplicate package name";
#endif
#ifdef EEXIST
	case EEXIST: return "file already exists";
#endif
#ifdef EFAULT
	case EFAULT: return "bad address in system call argument";
#endif
#ifdef EFBIG
	case EFBIG: return "file too large";
#endif
#ifdef EHOSTDOWN
	case EHOSTDOWN: return "host is down";
#endif
#ifdef EHOSTUNREACH
	case EHOSTUNREACH: return "host is unreachable";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
	case EIDRM: return "identifier removed";
#endif
#ifdef EINIT
	case EINIT: return "initialization error";
#endif
#ifdef EINPROGRESS
	case EINPROGRESS: return "operation now in progress";
#endif
#ifdef EINTR
	case EINTR: return "interrupted system call";
#endif
#ifdef EINVAL
	case EINVAL: return "invalid argument";
#endif
#ifdef EIO
	case EIO: return "I/O error";
#endif
#ifdef EISCONN
	case EISCONN: return "socket is already connected";
#endif
#ifdef EISDIR
	case EISDIR: return "illegal operation on a directory";
#endif
#ifdef EISNAME
	case EISNAM: return "is a name file";
#endif
#ifdef ELBIN
	case ELBIN: return "ELBIN";
#endif
#ifdef EL2HLT
	case EL2HLT: return "level 2 halted";
#endif
#ifdef EL2NSYNC
	case EL2NSYNC: return "level 2 not synchronized";
#endif
#ifdef EL3HLT
	case EL3HLT: return "level 3 halted";
#endif
#ifdef EL3RST
	case EL3RST: return "level 3 reset";
#endif
#ifdef ELIBACC
	case ELIBACC: return "can not access a needed shared library";
#endif
#ifdef ELIBBAD
	case ELIBBAD: return "accessing a corrupted shared library";
#endif
#ifdef ELIBEXEC
	case ELIBEXEC: return "can not exec a shared library directly";
#endif
#ifdef ELIBMAX
	case ELIBMAX: return
		"attempting to link in more shared libraries than system limit";
#endif
#ifdef ELIBSCN
	case ELIBSCN: return ".lib section in a.out corrupted";
#endif
#ifdef ELNRNG
	case ELNRNG: return "link number out of range";
#endif
#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT))
	case ELOOP: return "too many levels of symbolic links";
#endif
#ifdef EMFILE
	case EMFILE: return "too many open files";
#endif
#ifdef EMLINK
	case EMLINK: return "too many links";
#endif
#ifdef EMSGSIZE
	case EMSGSIZE: return "message too long";
#endif
#ifdef EMULTIHOP
	case EMULTIHOP: return "multihop attempted";
#endif
#ifdef ENAMETOOLONG
	case ENAMETOOLONG: return "file name too long";
#endif
#ifdef ENAVAIL
	case ENAVAIL: return "not available";
#endif
#ifdef ENET
	case ENET: return "ENET";
#endif
#ifdef ENETDOWN
	case ENETDOWN: return "network is down";
#endif
#ifdef ENETRESET
	case ENETRESET: return "network dropped connection on reset";
#endif
#ifdef ENETUNREACH
	case ENETUNREACH: return "network is unreachable";
#endif
#ifdef ENFILE
	case ENFILE: return "file table overflow";
#endif
#ifdef ENOANO
	case ENOANO: return "anode table overflow";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
	case ENOBUFS: return "no buffer space available";
#endif
#ifdef ENOCSI
	case ENOCSI: return "no CSI structure available";
#endif
#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED))
	case ENODATA: return "no data available";
#endif
#ifdef ENODEV
	case ENODEV: return "no such device";
#endif
#ifdef ENOENT
	case ENOENT: return "no such file or directory";
#endif
#ifdef ENOEXEC
	case ENOEXEC: return "exec format error";
#endif
#ifdef ENOLCK
	case ENOLCK: return "no locks available";
#endif
#ifdef ENOLINK
	case ENOLINK: return "link has be severed";
#endif
#ifdef ENOMEM
	case ENOMEM: return "not enough memory";
#endif
#ifdef ENOMSG
	case ENOMSG: return "no message of desired type";
#endif
#ifdef ENONET
	case ENONET: return "machine is not on the network";
#endif
#ifdef ENOPKG
	case ENOPKG: return "package not installed";
#endif
#ifdef ENOPROTOOPT
	case ENOPROTOOPT: return "bad protocol option";
#endif
#ifdef ENOSPC
	case ENOSPC: return "no space left on device";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
	case ENOSR: return "out of stream resources";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
	case ENOSTR: return "not a stream device";
#endif
#ifdef ENOSYM
	case ENOSYM: return "unresolved symbol name";
#endif
#ifdef ENOSYS
	case ENOSYS: return "function not implemented";
#endif
#ifdef ENOTBLK
	case ENOTBLK: return "block device required";
#endif
#ifdef ENOTCONN
	case ENOTCONN: return "socket is not connected";
#endif
#ifdef ENOTDIR
	case ENOTDIR: return "not a directory";
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
	case ENOTEMPTY: return "directory not empty";
#endif
#ifdef ENOTNAM
	case ENOTNAM: return "not a name file";
#endif
#ifdef ENOTSOCK
	case ENOTSOCK: return "socket operation on non-socket";
#endif
#ifdef ENOTSUP
	case ENOTSUP: return "operation not supported";
#endif
#ifdef ENOTTY
	case ENOTTY: return "inappropriate device for ioctl";
#endif
#ifdef ENOTUNIQ
	case ENOTUNIQ: return "name not unique on network";
#endif
#ifdef ENXIO
	case ENXIO: return "no such device or address";
#endif
#if defined(EOPNOTSUPP) &&  (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
	case EOPNOTSUPP: return "operation not supported on socket";
#endif
#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) )
        case EOVERFLOW: return "file too big";
#endif
#ifdef EPERM
	case EPERM: return "not owner";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
	case EPFNOSUPPORT: return "protocol family not supported";
#endif
#ifdef EPIPE
	case EPIPE: return "broken pipe";
#endif
#ifdef EPROCLIM
	case EPROCLIM: return "too many processes";
#endif
#ifdef EPROCUNAVAIL
	case EPROCUNAVAIL: return "bad procedure for program";
#endif
#ifdef EPROGMISMATCH
	case EPROGMISMATCH: return "program version wrong";
#endif
#ifdef EPROGUNAVAIL
	case EPROGUNAVAIL: return "RPC program not available";
#endif
#ifdef EPROTO
	case EPROTO: return "protocol error";
#endif
#ifdef EPROTONOSUPPORT
	case EPROTONOSUPPORT: return "protocol not suppored";
#endif
#ifdef EPROTOTYPE
	case EPROTOTYPE: return "protocol wrong type for socket";
#endif
#ifdef ERANGE
	case ERANGE: return "math result unrepresentable";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
	case EREFUSED: return "EREFUSED";
#endif
#ifdef EREMCHG
	case EREMCHG: return "remote address changed";
#endif
#ifdef EREMDEV
	case EREMDEV: return "remote device";
#endif
#ifdef EREMOTE
	case EREMOTE: return "pathname hit remote file system";
#endif
#ifdef EREMOTEIO
	case EREMOTEIO: return "remote i/o error";
#endif
#ifdef EREMOTERELEASE
	case EREMOTERELEASE: return "EREMOTERELEASE";
#endif
#ifdef EROFS
	case EROFS: return "read-only file system";
#endif
#ifdef ERPCMISMATCH
	case ERPCMISMATCH: return "RPC version is wrong";
#endif
#ifdef ERREMOTE
	case ERREMOTE: return "object is remote";
#endif
#ifdef ESHUTDOWN
	case ESHUTDOWN: return "can't send afer socket shutdown";
#endif
#ifdef ESOCKTNOSUPPORT
	case ESOCKTNOSUPPORT: return "socket type not supported";
#endif
#ifdef ESPIPE
	case ESPIPE: return "invalid seek";
#endif
#ifdef ESRCH
	case ESRCH: return "no such process";
#endif
#ifdef ESRMNT
	case ESRMNT: return "srmount error";
#endif
#ifdef ESTALE
	case ESTALE: return "stale remote file handle";
#endif
#ifdef ESUCCESS
	case ESUCCESS: return "Error 0";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
	case ETIME: return "timer expired";
#endif
#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR))
	case ETIMEDOUT: return "connection timed out";
#endif
#ifdef ETOOMANYREFS
	case ETOOMANYREFS: return "too many references: can't splice";
#endif
#ifdef ETXTBSY
	case ETXTBSY: return "text file or pseudo-device busy";
#endif
#ifdef EUCLEAN
	case EUCLEAN: return "structure needs cleaning";
#endif
#ifdef EUNATCH
	case EUNATCH: return "protocol driver not attached";
#endif
#ifdef EUSERS
	case EUSERS: return "too many users";
#endif
#ifdef EVERSION
	case EVERSION: return "version mismatch";
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
	case EWOULDBLOCK: return "operation would block";
#endif
#ifdef EXDEV
	case EXDEV: return "cross-domain link";
#endif
#ifdef EXFULL
	case EXFULL: return "message tables full";
#endif
	default:
#ifdef NO_STRERROR
	    return "unknown POSIX error";
#else
	    return strerror(errno);
#endif
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SignalId --
 *
 *	Return a textual identifier for a signal number.
 *
 * Results:
 *	This procedure returns a machine-readable textual identifier
 *	that corresponds to sig.  The identifier is the same as the
 *	#define name in signal.h.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SignalId(sig)
    int sig;			/* Number of signal. */
{
    switch (sig) {
#ifdef SIGABRT
	case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
	case SIGALRM: return "SIGALRM";
#endif
#ifdef SIGBUS
	case SIGBUS: return "SIGBUS";
#endif
#ifdef SIGCHLD
	case SIGCHLD: return "SIGCHLD";
#endif
#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
	case SIGCLD: return "SIGCLD";
#endif
#ifdef SIGCONT
	case SIGCONT: return "SIGCONT";
#endif
#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU))
	case SIGEMT: return "SIGEMT";
#endif
#ifdef SIGFPE
	case SIGFPE: return "SIGFPE";
#endif
#ifdef SIGHUP
	case SIGHUP: return "SIGHUP";
#endif
#ifdef SIGILL
	case SIGILL: return "SIGILL";
#endif
#ifdef SIGINT
	case SIGINT: return "SIGINT";
#endif
#ifdef SIGIO
	case SIGIO: return "SIGIO";
#endif
#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT))
	case SIGIOT: return "SIGIOT";
#endif
#ifdef SIGKILL
	case SIGKILL: return "SIGKILL";
#endif
#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
	case SIGLOST: return "SIGLOST";
#endif
#ifdef SIGPIPE
	case SIGPIPE: return "SIGPIPE";
#endif
#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
	case SIGPOLL: return "SIGPOLL";
#endif
#ifdef SIGPROF
	case SIGPROF: return "SIGPROF";
#endif
#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST))
	case SIGPWR: return "SIGPWR";
#endif
#ifdef SIGQUIT
	case SIGQUIT: return "SIGQUIT";
#endif
#ifdef SIGSEGV
	case SIGSEGV: return "SIGSEGV";
#endif
#ifdef SIGSTOP
	case SIGSTOP: return "SIGSTOP";
#endif
#ifdef SIGSYS
	case SIGSYS: return "SIGSYS";
#endif
#ifdef SIGTERM
	case SIGTERM: return "SIGTERM";
#endif
#ifdef SIGTRAP
	case SIGTRAP: return "SIGTRAP";
#endif
#ifdef SIGTSTP
	case SIGTSTP: return "SIGTSTP";
#endif
#ifdef SIGTTIN
	case SIGTTIN: return "SIGTTIN";
#endif
#ifdef SIGTTOU
	case SIGTTOU: return "SIGTTOU";
#endif
#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO))
	case SIGURG: return "SIGURG";
#endif
#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO))
	case SIGUSR1: return "SIGUSR1";
#endif
#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG))
	case SIGUSR2: return "SIGUSR2";
#endif
#ifdef SIGVTALRM
	case SIGVTALRM: return "SIGVTALRM";
#endif
#ifdef SIGWINCH
	case SIGWINCH: return "SIGWINCH";
#endif
#ifdef SIGXCPU
	case SIGXCPU: return "SIGXCPU";
#endif
#ifdef SIGXFSZ
	case SIGXFSZ: return "SIGXFSZ";
#endif
    }
    return "unknown signal";
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SignalMsg --
 *
 *	Return a human-readable message describing a signal.
 *
 * Results:
 *	This procedure returns a string describing sig that should
 *	make sense to a human.  It may not be easy for a machine
 *	to parse.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SignalMsg(sig)
    int sig;			/* Number of signal. */
{
    switch (sig) {
#ifdef SIGABRT
	case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
	case SIGALRM: return "alarm clock";
#endif
#ifdef SIGBUS
	case SIGBUS: return "bus error";
#endif
#ifdef SIGCHLD
	case SIGCHLD: return "child status changed";
#endif
#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
	case SIGCLD: return "child status changed";
#endif
#ifdef SIGCONT
	case SIGCONT: return "continue after stop";
#endif
#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU))
	case SIGEMT: return "EMT instruction";
#endif
#ifdef SIGFPE
	case SIGFPE: return "floating-point exception";
#endif
#ifdef SIGHUP
	case SIGHUP: return "hangup";
#endif
#ifdef SIGILL
	case SIGILL: return "illegal instruction";
#endif
#ifdef SIGINT
	case SIGINT: return "interrupt";
#endif
#ifdef SIGIO
	case SIGIO: return "input/output possible on file";
#endif
#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT))
	case SIGIOT: return "IOT instruction";
#endif
#ifdef SIGKILL
	case SIGKILL: return "kill signal";
#endif
#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
	case SIGLOST: return "resource lost";
#endif
#ifdef SIGPIPE
	case SIGPIPE: return "write on pipe with no readers";
#endif
#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
	case SIGPOLL: return "input/output possible on file";
#endif
#ifdef SIGPROF
	case SIGPROF: return "profiling alarm";
#endif
#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST))
	case SIGPWR: return "power-fail restart";
#endif
#ifdef SIGQUIT
	case SIGQUIT: return "quit signal";
#endif
#ifdef SIGSEGV
	case SIGSEGV: return "segmentation violation";
#endif
#ifdef SIGSTOP
	case SIGSTOP: return "stop";
#endif
#ifdef SIGSYS
	case SIGSYS: return "bad argument to system call";
#endif
#ifdef SIGTERM
	case SIGTERM: return "software termination signal";
#endif
#ifdef SIGTRAP
	case SIGTRAP: return "trace trap";
#endif
#ifdef SIGTSTP
	case SIGTSTP: return "stop signal from tty";
#endif
#ifdef SIGTTIN
	case SIGTTIN: return "background tty read";
#endif
#ifdef SIGTTOU
	case SIGTTOU: return "background tty write";
#endif
#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO))
	case SIGURG: return "urgent I/O condition";
#endif
#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO))
	case SIGUSR1: return "user-defined signal 1";
#endif
#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG))
	case SIGUSR2: return "user-defined signal 2";
#endif
#ifdef SIGVTALRM
	case SIGVTALRM: return "virtual time alarm";
#endif
#ifdef SIGWINCH
	case SIGWINCH: return "window changed";
#endif
#ifdef SIGXCPU
	case SIGXCPU: return "exceeded CPU time limit";
#endif
#ifdef SIGXFSZ
	case SIGXFSZ: return "exceeded file size limit";
#endif
    }
    return "unknown signal";
}











|
|
<







|












|
|
|












|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|










|
<


|
|
|
<
|
|
|









|



|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|
|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|

|

|

|












|
|
|









|



|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|













|
|
<









|



|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|




>
>
>
>
>
>
>
>
1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

467
468
469
470
471

472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055

1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
/* 
 * tclPosixStr.c --
 *
 *	This file contains procedures that generate strings corresponding to
 *	various POSIX-related codes, such as errno and signals.

 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPosixStr.c,v 1.10.2.1 2005/08/02 18:16:06 dgp Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrnoId --
 *
 *	Return a textual identifier for the current errno value.
 *
 * Results:
 *	This procedure returns a machine-readable textual identifier that
 *	corresponds to the current errno value (e.g. "EPERM"). The identifier
 *	is the same as the #define name in errno.h.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ErrnoId()
{
    switch (errno) {
#ifdef E2BIG
    case E2BIG: return "E2BIG";
#endif
#ifdef EACCES
    case EACCES: return "EACCES";
#endif
#ifdef EADDRINUSE
    case EADDRINUSE: return "EADDRINUSE";
#endif
#ifdef EADDRNOTAVAIL
    case EADDRNOTAVAIL: return "EADDRNOTAVAIL";
#endif
#ifdef EADV
    case EADV: return "EADV";
#endif
#ifdef EAFNOSUPPORT
    case EAFNOSUPPORT: return "EAFNOSUPPORT";
#endif
#ifdef EAGAIN
    case EAGAIN: return "EAGAIN";
#endif
#ifdef EALIGN
    case EALIGN: return "EALIGN";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY ))
    case EALREADY: return "EALREADY";
#endif
#ifdef EBADE
    case EBADE: return "EBADE";
#endif
#ifdef EBADF
    case EBADF: return "EBADF";
#endif
#ifdef EBADFD
    case EBADFD: return "EBADFD";
#endif
#ifdef EBADMSG
    case EBADMSG: return "EBADMSG";
#endif
#ifdef EBADR
    case EBADR: return "EBADR";
#endif
#ifdef EBADRPC
    case EBADRPC: return "EBADRPC";
#endif
#ifdef EBADRQC
    case EBADRQC: return "EBADRQC";
#endif
#ifdef EBADSLT
    case EBADSLT: return "EBADSLT";
#endif
#ifdef EBFONT
    case EBFONT: return "EBFONT";
#endif
#ifdef EBUSY
    case EBUSY: return "EBUSY";
#endif
#ifdef ECHILD
    case ECHILD: return "ECHILD";
#endif
#ifdef ECHRNG
    case ECHRNG: return "ECHRNG";
#endif
#ifdef ECOMM
    case ECOMM: return "ECOMM";
#endif
#ifdef ECONNABORTED
    case ECONNABORTED: return "ECONNABORTED";
#endif
#ifdef ECONNREFUSED
    case ECONNREFUSED: return "ECONNREFUSED";
#endif
#ifdef ECONNRESET
    case ECONNRESET: return "ECONNRESET";
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
    case EDEADLK: return "EDEADLK";
#endif
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
    case EDEADLOCK: return "EDEADLOCK";
#endif
#ifdef EDESTADDRREQ
    case EDESTADDRREQ: return "EDESTADDRREQ";
#endif
#ifdef EDIRTY
    case EDIRTY: return "EDIRTY";
#endif
#ifdef EDOM
    case EDOM: return "EDOM";
#endif
#ifdef EDOTDOT
    case EDOTDOT: return "EDOTDOT";
#endif
#ifdef EDQUOT
    case EDQUOT: return "EDQUOT";
#endif
#ifdef EDUPPKG
    case EDUPPKG: return "EDUPPKG";
#endif
#ifdef EEXIST
    case EEXIST: return "EEXIST";
#endif
#ifdef EFAULT
    case EFAULT: return "EFAULT";
#endif
#ifdef EFBIG
    case EFBIG: return "EFBIG";
#endif
#ifdef EHOSTDOWN
    case EHOSTDOWN: return "EHOSTDOWN";
#endif
#ifdef EHOSTUNREACH
    case EHOSTUNREACH: return "EHOSTUNREACH";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
    case EIDRM: return "EIDRM";
#endif
#ifdef EINIT
    case EINIT: return "EINIT";
#endif
#ifdef EINPROGRESS
    case EINPROGRESS: return "EINPROGRESS";
#endif
#ifdef EINTR
    case EINTR: return "EINTR";
#endif
#ifdef EINVAL
    case EINVAL: return "EINVAL";
#endif
#ifdef EIO
    case EIO: return "EIO";
#endif
#ifdef EISCONN
    case EISCONN: return "EISCONN";
#endif
#ifdef EISDIR
    case EISDIR: return "EISDIR";
#endif
#ifdef EISNAME
    case EISNAM: return "EISNAM";
#endif
#ifdef ELBIN
    case ELBIN: return "ELBIN";
#endif
#ifdef EL2HLT
    case EL2HLT: return "EL2HLT";
#endif
#ifdef EL2NSYNC
    case EL2NSYNC: return "EL2NSYNC";
#endif
#ifdef EL3HLT
    case EL3HLT: return "EL3HLT";
#endif
#ifdef EL3RST
    case EL3RST: return "EL3RST";
#endif
#ifdef ELIBACC
    case ELIBACC: return "ELIBACC";
#endif
#ifdef ELIBBAD
    case ELIBBAD: return "ELIBBAD";
#endif
#ifdef ELIBEXEC
    case ELIBEXEC: return "ELIBEXEC";
#endif
#ifdef ELIBMAX
    case ELIBMAX: return "ELIBMAX";
#endif
#ifdef ELIBSCN
    case ELIBSCN: return "ELIBSCN";
#endif
#ifdef ELNRNG
    case ELNRNG: return "ELNRNG";
#endif
#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT))
    case ELOOP: return "ELOOP";
#endif
#ifdef EMFILE
    case EMFILE: return "EMFILE";
#endif
#ifdef EMLINK
    case EMLINK: return "EMLINK";
#endif
#ifdef EMSGSIZE
    case EMSGSIZE: return "EMSGSIZE";
#endif
#ifdef EMULTIHOP
    case EMULTIHOP: return "EMULTIHOP";
#endif
#ifdef ENAMETOOLONG
    case ENAMETOOLONG: return "ENAMETOOLONG";
#endif
#ifdef ENAVAIL
    case ENAVAIL: return "ENAVAIL";
#endif
#ifdef ENET
    case ENET: return "ENET";
#endif
#ifdef ENETDOWN
    case ENETDOWN: return "ENETDOWN";
#endif
#ifdef ENETRESET
    case ENETRESET: return "ENETRESET";
#endif
#ifdef ENETUNREACH
    case ENETUNREACH: return "ENETUNREACH";
#endif
#ifdef ENFILE
    case ENFILE: return "ENFILE";
#endif
#ifdef ENOANO
    case ENOANO: return "ENOANO";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
    case ENOBUFS: return "ENOBUFS";
#endif
#ifdef ENOCSI
    case ENOCSI: return "ENOCSI";
#endif
#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED))
    case ENODATA: return "ENODATA";
#endif
#ifdef ENODEV
    case ENODEV: return "ENODEV";
#endif
#ifdef ENOENT
    case ENOENT: return "ENOENT";
#endif
#ifdef ENOEXEC
    case ENOEXEC: return "ENOEXEC";
#endif
#ifdef ENOLCK
    case ENOLCK: return "ENOLCK";
#endif
#ifdef ENOLINK
    case ENOLINK: return "ENOLINK";
#endif
#ifdef ENOMEM
    case ENOMEM: return "ENOMEM";
#endif
#ifdef ENOMSG
    case ENOMSG: return "ENOMSG";
#endif
#ifdef ENONET
    case ENONET: return "ENONET";
#endif
#ifdef ENOPKG
    case ENOPKG: return "ENOPKG";
#endif
#ifdef ENOPROTOOPT
    case ENOPROTOOPT: return "ENOPROTOOPT";
#endif
#ifdef ENOSPC
    case ENOSPC: return "ENOSPC";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
    case ENOSR: return "ENOSR";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
    case ENOSTR: return "ENOSTR";
#endif
#ifdef ENOSYM
    case ENOSYM: return "ENOSYM";
#endif
#ifdef ENOSYS
    case ENOSYS: return "ENOSYS";
#endif
#ifdef ENOTBLK
    case ENOTBLK: return "ENOTBLK";
#endif
#ifdef ENOTCONN
    case ENOTCONN: return "ENOTCONN";
#endif
#ifdef ENOTDIR
    case ENOTDIR: return "ENOTDIR";
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
    case ENOTEMPTY: return "ENOTEMPTY";
#endif
#ifdef ENOTNAM
    case ENOTNAM: return "ENOTNAM";
#endif
#ifdef ENOTSOCK
    case ENOTSOCK: return "ENOTSOCK";
#endif
#ifdef ENOTSUP
    case ENOTSUP: return "ENOTSUP";
#endif
#ifdef ENOTTY
    case ENOTTY: return "ENOTTY";
#endif
#ifdef ENOTUNIQ
    case ENOTUNIQ: return "ENOTUNIQ";
#endif
#ifdef ENXIO
    case ENXIO: return "ENXIO";
#endif
#if defined(EOPNOTSUPP) &&  (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
    case EOPNOTSUPP: return "EOPNOTSUPP";
#endif
#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) )
    case EOVERFLOW: return "EOVERFLOW";
#endif
#ifdef EPERM
    case EPERM: return "EPERM";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
    case EPFNOSUPPORT: return "EPFNOSUPPORT";
#endif
#ifdef EPIPE
    case EPIPE: return "EPIPE";
#endif
#ifdef EPROCLIM
    case EPROCLIM: return "EPROCLIM";
#endif
#ifdef EPROCUNAVAIL
    case EPROCUNAVAIL: return "EPROCUNAVAIL";
#endif
#ifdef EPROGMISMATCH
    case EPROGMISMATCH: return "EPROGMISMATCH";
#endif
#ifdef EPROGUNAVAIL
    case EPROGUNAVAIL: return "EPROGUNAVAIL";
#endif
#ifdef EPROTO
    case EPROTO: return "EPROTO";
#endif
#ifdef EPROTONOSUPPORT
    case EPROTONOSUPPORT: return "EPROTONOSUPPORT";
#endif
#ifdef EPROTOTYPE
    case EPROTOTYPE: return "EPROTOTYPE";
#endif
#ifdef ERANGE
    case ERANGE: return "ERANGE";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
    case EREFUSED: return "EREFUSED";
#endif
#ifdef EREMCHG
    case EREMCHG: return "EREMCHG";
#endif
#ifdef EREMDEV
    case EREMDEV: return "EREMDEV";
#endif
#ifdef EREMOTE
    case EREMOTE: return "EREMOTE";
#endif
#ifdef EREMOTEIO
    case EREMOTEIO: return "EREMOTEIO";
#endif
#ifdef EREMOTERELEASE
    case EREMOTERELEASE: return "EREMOTERELEASE";
#endif
#ifdef EROFS
    case EROFS: return "EROFS";
#endif
#ifdef ERPCMISMATCH
    case ERPCMISMATCH: return "ERPCMISMATCH";
#endif
#ifdef ERREMOTE
    case ERREMOTE: return "ERREMOTE";
#endif
#ifdef ESHUTDOWN
    case ESHUTDOWN: return "ESHUTDOWN";
#endif
#ifdef ESOCKTNOSUPPORT
    case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT";
#endif
#ifdef ESPIPE
    case ESPIPE: return "ESPIPE";
#endif
#ifdef ESRCH
    case ESRCH: return "ESRCH";
#endif
#ifdef ESRMNT
    case ESRMNT: return "ESRMNT";
#endif
#ifdef ESTALE
    case ESTALE: return "ESTALE";
#endif
#ifdef ESUCCESS
    case ESUCCESS: return "ESUCCESS";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
    case ETIME: return "ETIME";
#endif
#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR))
    case ETIMEDOUT: return "ETIMEDOUT";
#endif
#ifdef ETOOMANYREFS
    case ETOOMANYREFS: return "ETOOMANYREFS";
#endif
#ifdef ETXTBSY
    case ETXTBSY: return "ETXTBSY";
#endif
#ifdef EUCLEAN
    case EUCLEAN: return "EUCLEAN";
#endif
#ifdef EUNATCH
    case EUNATCH: return "EUNATCH";
#endif
#ifdef EUSERS
    case EUSERS: return "EUSERS";
#endif
#ifdef EVERSION
    case EVERSION: return "EVERSION";
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
    case EWOULDBLOCK: return "EWOULDBLOCK";
#endif
#ifdef EXDEV
    case EXDEV: return "EXDEV";
#endif
#ifdef EXFULL
    case EXFULL: return "EXFULL";
#endif
    }
    return "unknown error";
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ErrnoMsg --
 *
 *	Return a human-readable message corresponding to a given errno value.

 *
 * Results:
 *	The return value is the standard POSIX error message for errno.  This
 *	procedure is used instead of strerror because strerror returns
 *	slightly different values on different machines (e.g. different

 *	capitalizations), which cause problems for things such as regression
 *	tests. This procedure provides messages for most standard errors, then
 *	it calls strerror for things it doesn't understand.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ErrnoMsg(err)
     int err;			/* Error number (such as in errno variable). */
{
    switch (err) {
#ifdef E2BIG
    case E2BIG: return "argument list too long";
#endif
#ifdef EACCES
    case EACCES: return "permission denied";
#endif
#ifdef EADDRINUSE
    case EADDRINUSE: return "address already in use";
#endif
#ifdef EADDRNOTAVAIL
    case EADDRNOTAVAIL: return "can't assign requested address";
#endif
#ifdef EADV
    case EADV: return "advertise error";
#endif
#ifdef EAFNOSUPPORT
    case EAFNOSUPPORT: return "address family not supported by protocol family";
#endif
#ifdef EAGAIN
    case EAGAIN: return "resource temporarily unavailable";
#endif
#ifdef EALIGN
    case EALIGN: return "EALIGN";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY ))
    case EALREADY: return "operation already in progress";
#endif
#ifdef EBADE
    case EBADE: return "bad exchange descriptor";
#endif
#ifdef EBADF
    case EBADF: return "bad file number";
#endif
#ifdef EBADFD
    case EBADFD: return "file descriptor in bad state";
#endif
#ifdef EBADMSG
    case EBADMSG: return "not a data message";
#endif
#ifdef EBADR
    case EBADR: return "bad request descriptor";
#endif
#ifdef EBADRPC
    case EBADRPC: return "RPC structure is bad";
#endif
#ifdef EBADRQC
    case EBADRQC: return "bad request code";
#endif
#ifdef EBADSLT
    case EBADSLT: return "invalid slot";
#endif
#ifdef EBFONT
    case EBFONT: return "bad font file format";
#endif
#ifdef EBUSY
    case EBUSY: return "file busy";
#endif
#ifdef ECHILD
    case ECHILD: return "no children";
#endif
#ifdef ECHRNG
    case ECHRNG: return "channel number out of range";
#endif
#ifdef ECOMM
    case ECOMM: return "communication error on send";
#endif
#ifdef ECONNABORTED
    case ECONNABORTED: return "software caused connection abort";
#endif
#ifdef ECONNREFUSED
    case ECONNREFUSED: return "connection refused";
#endif
#ifdef ECONNRESET
    case ECONNRESET: return "connection reset by peer";
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
    case EDEADLK: return "resource deadlock avoided";
#endif
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
    case EDEADLOCK: return "resource deadlock avoided";
#endif
#ifdef EDESTADDRREQ
    case EDESTADDRREQ: return "destination address required";
#endif
#ifdef EDIRTY
    case EDIRTY: return "mounting a dirty fs w/o force";
#endif
#ifdef EDOM
    case EDOM: return "math argument out of range";
#endif
#ifdef EDOTDOT
    case EDOTDOT: return "cross mount point";
#endif
#ifdef EDQUOT
    case EDQUOT: return "disk quota exceeded";
#endif
#ifdef EDUPPKG
    case EDUPPKG: return "duplicate package name";
#endif
#ifdef EEXIST
    case EEXIST: return "file already exists";
#endif
#ifdef EFAULT
    case EFAULT: return "bad address in system call argument";
#endif
#ifdef EFBIG
    case EFBIG: return "file too large";
#endif
#ifdef EHOSTDOWN
    case EHOSTDOWN: return "host is down";
#endif
#ifdef EHOSTUNREACH
    case EHOSTUNREACH: return "host is unreachable";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
    case EIDRM: return "identifier removed";
#endif
#ifdef EINIT
    case EINIT: return "initialization error";
#endif
#ifdef EINPROGRESS
    case EINPROGRESS: return "operation now in progress";
#endif
#ifdef EINTR
    case EINTR: return "interrupted system call";
#endif
#ifdef EINVAL
    case EINVAL: return "invalid argument";
#endif
#ifdef EIO
    case EIO: return "I/O error";
#endif
#ifdef EISCONN
    case EISCONN: return "socket is already connected";
#endif
#ifdef EISDIR
    case EISDIR: return "illegal operation on a directory";
#endif
#ifdef EISNAME
    case EISNAM: return "is a name file";
#endif
#ifdef ELBIN
    case ELBIN: return "ELBIN";
#endif
#ifdef EL2HLT
    case EL2HLT: return "level 2 halted";
#endif
#ifdef EL2NSYNC
    case EL2NSYNC: return "level 2 not synchronized";
#endif
#ifdef EL3HLT
    case EL3HLT: return "level 3 halted";
#endif
#ifdef EL3RST
    case EL3RST: return "level 3 reset";
#endif
#ifdef ELIBACC
    case ELIBACC: return "can not access a needed shared library";
#endif
#ifdef ELIBBAD
    case ELIBBAD: return "accessing a corrupted shared library";
#endif
#ifdef ELIBEXEC
    case ELIBEXEC: return "can not exec a shared library directly";
#endif
#ifdef ELIBMAX
    case ELIBMAX: return
		      "attempting to link in more shared libraries than system limit";
#endif
#ifdef ELIBSCN
    case ELIBSCN: return ".lib section in a.out corrupted";
#endif
#ifdef ELNRNG
    case ELNRNG: return "link number out of range";
#endif
#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT))
    case ELOOP: return "too many levels of symbolic links";
#endif
#ifdef EMFILE
    case EMFILE: return "too many open files";
#endif
#ifdef EMLINK
    case EMLINK: return "too many links";
#endif
#ifdef EMSGSIZE
    case EMSGSIZE: return "message too long";
#endif
#ifdef EMULTIHOP
    case EMULTIHOP: return "multihop attempted";
#endif
#ifdef ENAMETOOLONG
    case ENAMETOOLONG: return "file name too long";
#endif
#ifdef ENAVAIL
    case ENAVAIL: return "not available";
#endif
#ifdef ENET
    case ENET: return "ENET";
#endif
#ifdef ENETDOWN
    case ENETDOWN: return "network is down";
#endif
#ifdef ENETRESET
    case ENETRESET: return "network dropped connection on reset";
#endif
#ifdef ENETUNREACH
    case ENETUNREACH: return "network is unreachable";
#endif
#ifdef ENFILE
    case ENFILE: return "file table overflow";
#endif
#ifdef ENOANO
    case ENOANO: return "anode table overflow";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
    case ENOBUFS: return "no buffer space available";
#endif
#ifdef ENOCSI
    case ENOCSI: return "no CSI structure available";
#endif
#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED))
    case ENODATA: return "no data available";
#endif
#ifdef ENODEV
    case ENODEV: return "no such device";
#endif
#ifdef ENOENT
    case ENOENT: return "no such file or directory";
#endif
#ifdef ENOEXEC
    case ENOEXEC: return "exec format error";
#endif
#ifdef ENOLCK
    case ENOLCK: return "no locks available";
#endif
#ifdef ENOLINK
    case ENOLINK: return "link has be severed";
#endif
#ifdef ENOMEM
    case ENOMEM: return "not enough memory";
#endif
#ifdef ENOMSG
    case ENOMSG: return "no message of desired type";
#endif
#ifdef ENONET
    case ENONET: return "machine is not on the network";
#endif
#ifdef ENOPKG
    case ENOPKG: return "package not installed";
#endif
#ifdef ENOPROTOOPT
    case ENOPROTOOPT: return "bad protocol option";
#endif
#ifdef ENOSPC
    case ENOSPC: return "no space left on device";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
    case ENOSR: return "out of stream resources";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
    case ENOSTR: return "not a stream device";
#endif
#ifdef ENOSYM
    case ENOSYM: return "unresolved symbol name";
#endif
#ifdef ENOSYS
    case ENOSYS: return "function not implemented";
#endif
#ifdef ENOTBLK
    case ENOTBLK: return "block device required";
#endif
#ifdef ENOTCONN
    case ENOTCONN: return "socket is not connected";
#endif
#ifdef ENOTDIR
    case ENOTDIR: return "not a directory";
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
    case ENOTEMPTY: return "directory not empty";
#endif
#ifdef ENOTNAM
    case ENOTNAM: return "not a name file";
#endif
#ifdef ENOTSOCK
    case ENOTSOCK: return "socket operation on non-socket";
#endif
#ifdef ENOTSUP
    case ENOTSUP: return "operation not supported";
#endif
#ifdef ENOTTY
    case ENOTTY: return "inappropriate device for ioctl";
#endif
#ifdef ENOTUNIQ
    case ENOTUNIQ: return "name not unique on network";
#endif
#ifdef ENXIO
    case ENXIO: return "no such device or address";
#endif
#if defined(EOPNOTSUPP) &&  (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
    case EOPNOTSUPP: return "operation not supported on socket";
#endif
#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) )
    case EOVERFLOW: return "file too big";
#endif
#ifdef EPERM
    case EPERM: return "not owner";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
    case EPFNOSUPPORT: return "protocol family not supported";
#endif
#ifdef EPIPE
    case EPIPE: return "broken pipe";
#endif
#ifdef EPROCLIM
    case EPROCLIM: return "too many processes";
#endif
#ifdef EPROCUNAVAIL
    case EPROCUNAVAIL: return "bad procedure for program";
#endif
#ifdef EPROGMISMATCH
    case EPROGMISMATCH: return "program version wrong";
#endif
#ifdef EPROGUNAVAIL
    case EPROGUNAVAIL: return "RPC program not available";
#endif
#ifdef EPROTO
    case EPROTO: return "protocol error";
#endif
#ifdef EPROTONOSUPPORT
    case EPROTONOSUPPORT: return "protocol not suppored";
#endif
#ifdef EPROTOTYPE
    case EPROTOTYPE: return "protocol wrong type for socket";
#endif
#ifdef ERANGE
    case ERANGE: return "math result unrepresentable";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
    case EREFUSED: return "EREFUSED";
#endif
#ifdef EREMCHG
    case EREMCHG: return "remote address changed";
#endif
#ifdef EREMDEV
    case EREMDEV: return "remote device";
#endif
#ifdef EREMOTE
    case EREMOTE: return "pathname hit remote file system";
#endif
#ifdef EREMOTEIO
    case EREMOTEIO: return "remote i/o error";
#endif
#ifdef EREMOTERELEASE
    case EREMOTERELEASE: return "EREMOTERELEASE";
#endif
#ifdef EROFS
    case EROFS: return "read-only file system";
#endif
#ifdef ERPCMISMATCH
    case ERPCMISMATCH: return "RPC version is wrong";
#endif
#ifdef ERREMOTE
    case ERREMOTE: return "object is remote";
#endif
#ifdef ESHUTDOWN
    case ESHUTDOWN: return "can't send afer socket shutdown";
#endif
#ifdef ESOCKTNOSUPPORT
    case ESOCKTNOSUPPORT: return "socket type not supported";
#endif
#ifdef ESPIPE
    case ESPIPE: return "invalid seek";
#endif
#ifdef ESRCH
    case ESRCH: return "no such process";
#endif
#ifdef ESRMNT
    case ESRMNT: return "srmount error";
#endif
#ifdef ESTALE
    case ESTALE: return "stale remote file handle";
#endif
#ifdef ESUCCESS
    case ESUCCESS: return "Error 0";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
    case ETIME: return "timer expired";
#endif
#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR))
    case ETIMEDOUT: return "connection timed out";
#endif
#ifdef ETOOMANYREFS
    case ETOOMANYREFS: return "too many references: can't splice";
#endif
#ifdef ETXTBSY
    case ETXTBSY: return "text file or pseudo-device busy";
#endif
#ifdef EUCLEAN
    case EUCLEAN: return "structure needs cleaning";
#endif
#ifdef EUNATCH
    case EUNATCH: return "protocol driver not attached";
#endif
#ifdef EUSERS
    case EUSERS: return "too many users";
#endif
#ifdef EVERSION
    case EVERSION: return "version mismatch";
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
    case EWOULDBLOCK: return "operation would block";
#endif
#ifdef EXDEV
    case EXDEV: return "cross-domain link";
#endif
#ifdef EXFULL
    case EXFULL: return "message tables full";
#endif
    default:
#ifdef NO_STRERROR
	return "unknown POSIX error";
#else
	return strerror(errno);
#endif
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SignalId --
 *
 *	Return a textual identifier for a signal number.
 *
 * Results:
 *	This procedure returns a machine-readable textual identifier that
 *	corresponds to sig.  The identifier is the same as the #define name in
 *	signal.h.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SignalId(sig)
     int sig;			/* Number of signal. */
{
    switch (sig) {
#ifdef SIGABRT
    case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
    case SIGALRM: return "SIGALRM";
#endif
#ifdef SIGBUS
    case SIGBUS: return "SIGBUS";
#endif
#ifdef SIGCHLD
    case SIGCHLD: return "SIGCHLD";
#endif
#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
    case SIGCLD: return "SIGCLD";
#endif
#ifdef SIGCONT
    case SIGCONT: return "SIGCONT";
#endif
#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU))
    case SIGEMT: return "SIGEMT";
#endif
#ifdef SIGFPE
    case SIGFPE: return "SIGFPE";
#endif
#ifdef SIGHUP
    case SIGHUP: return "SIGHUP";
#endif
#ifdef SIGILL
    case SIGILL: return "SIGILL";
#endif
#ifdef SIGINT
    case SIGINT: return "SIGINT";
#endif
#ifdef SIGIO
    case SIGIO: return "SIGIO";
#endif
#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT))
    case SIGIOT: return "SIGIOT";
#endif
#ifdef SIGKILL
    case SIGKILL: return "SIGKILL";
#endif
#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
    case SIGLOST: return "SIGLOST";
#endif
#ifdef SIGPIPE
    case SIGPIPE: return "SIGPIPE";
#endif
#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
    case SIGPOLL: return "SIGPOLL";
#endif
#ifdef SIGPROF
    case SIGPROF: return "SIGPROF";
#endif
#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST))
    case SIGPWR: return "SIGPWR";
#endif
#ifdef SIGQUIT
    case SIGQUIT: return "SIGQUIT";
#endif
#ifdef SIGSEGV
    case SIGSEGV: return "SIGSEGV";
#endif
#ifdef SIGSTOP
    case SIGSTOP: return "SIGSTOP";
#endif
#ifdef SIGSYS
    case SIGSYS: return "SIGSYS";
#endif
#ifdef SIGTERM
    case SIGTERM: return "SIGTERM";
#endif
#ifdef SIGTRAP
    case SIGTRAP: return "SIGTRAP";
#endif
#ifdef SIGTSTP
    case SIGTSTP: return "SIGTSTP";
#endif
#ifdef SIGTTIN
    case SIGTTIN: return "SIGTTIN";
#endif
#ifdef SIGTTOU
    case SIGTTOU: return "SIGTTOU";
#endif
#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO))
    case SIGURG: return "SIGURG";
#endif
#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO))
    case SIGUSR1: return "SIGUSR1";
#endif
#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG))
    case SIGUSR2: return "SIGUSR2";
#endif
#ifdef SIGVTALRM
    case SIGVTALRM: return "SIGVTALRM";
#endif
#ifdef SIGWINCH
    case SIGWINCH: return "SIGWINCH";
#endif
#ifdef SIGXCPU
    case SIGXCPU: return "SIGXCPU";
#endif
#ifdef SIGXFSZ
    case SIGXFSZ: return "SIGXFSZ";
#endif
    }
    return "unknown signal";
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SignalMsg --
 *
 *	Return a human-readable message describing a signal.
 *
 * Results:
 *	This procedure returns a string describing sig that should make sense
 *	to a human.  It may not be easy for a machine to parse.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SignalMsg(sig)
     int sig;			/* Number of signal. */
{
    switch (sig) {
#ifdef SIGABRT
    case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
    case SIGALRM: return "alarm clock";
#endif
#ifdef SIGBUS
    case SIGBUS: return "bus error";
#endif
#ifdef SIGCHLD
    case SIGCHLD: return "child status changed";
#endif
#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
    case SIGCLD: return "child status changed";
#endif
#ifdef SIGCONT
    case SIGCONT: return "continue after stop";
#endif
#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU))
    case SIGEMT: return "EMT instruction";
#endif
#ifdef SIGFPE
    case SIGFPE: return "floating-point exception";
#endif
#ifdef SIGHUP
    case SIGHUP: return "hangup";
#endif
#ifdef SIGILL
    case SIGILL: return "illegal instruction";
#endif
#ifdef SIGINT
    case SIGINT: return "interrupt";
#endif
#ifdef SIGIO
    case SIGIO: return "input/output possible on file";
#endif
#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT))
    case SIGIOT: return "IOT instruction";
#endif
#ifdef SIGKILL
    case SIGKILL: return "kill signal";
#endif
#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
    case SIGLOST: return "resource lost";
#endif
#ifdef SIGPIPE
    case SIGPIPE: return "write on pipe with no readers";
#endif
#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
    case SIGPOLL: return "input/output possible on file";
#endif
#ifdef SIGPROF
    case SIGPROF: return "profiling alarm";
#endif
#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST))
    case SIGPWR: return "power-fail restart";
#endif
#ifdef SIGQUIT
    case SIGQUIT: return "quit signal";
#endif
#ifdef SIGSEGV
    case SIGSEGV: return "segmentation violation";
#endif
#ifdef SIGSTOP
    case SIGSTOP: return "stop";
#endif
#ifdef SIGSYS
    case SIGSYS: return "bad argument to system call";
#endif
#ifdef SIGTERM
    case SIGTERM: return "software termination signal";
#endif
#ifdef SIGTRAP
    case SIGTRAP: return "trace trap";
#endif
#ifdef SIGTSTP
    case SIGTSTP: return "stop signal from tty";
#endif
#ifdef SIGTTIN
    case SIGTTIN: return "background tty read";
#endif
#ifdef SIGTTOU
    case SIGTTOU: return "background tty write";
#endif
#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO))
    case SIGURG: return "urgent I/O condition";
#endif
#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO))
    case SIGUSR1: return "user-defined signal 1";
#endif
#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG))
    case SIGUSR2: return "user-defined signal 2";
#endif
#ifdef SIGVTALRM
    case SIGVTALRM: return "virtual time alarm";
#endif
#ifdef SIGWINCH
    case SIGWINCH: return "window changed";
#endif
#ifdef SIGXCPU
    case SIGXCPU: return "exceeded CPU time limit";
#endif
#ifdef SIGXFSZ
    case SIGXFSZ: return "exceeded file size limit";
#endif
    }
    return "unknown signal";
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPreserve.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36





37
38
39
40
41
42
43
44


45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
/* 
 * tclPreserve.c --
 *
 *	This file contains a collection of procedures that are used
 *	to make sure that widget records and other data structures
 *	aren't reallocated when there are nested procedures that
 *	depend on their existence.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPreserve.c,v 1.5 2003/12/24 04:18:20 davygrvy Exp $
 */

#include "tclInt.h"

/*
 * The following data structure is used to keep track of all the
 * Tcl_Preserve calls that are still in effect.  It grows as needed
 * to accommodate any number of calls in effect.
 */

typedef struct {
    ClientData clientData;	/* Address of preserved block. */
    int refCount;		/* Number of Tcl_Preserve calls in effect
				 * for block. */
    int mustFree;		/* Non-zero means Tcl_EventuallyFree was
				 * called while a Tcl_Preserve call was in
				 * effect, so the structure must be freed
				 * when refCount becomes zero. */
    Tcl_FreeProc *freeProc;	/* Procedure to call to free. */
} Reference;






static Reference *refArray;	/* First in array of references. */
static int spaceAvl = 0;	/* Total number of structures available
				 * at *firstRefPtr. */
static int inUse = 0;		/* Count of structures currently in use
				 * in refArray. */
#define INITIAL_SIZE 2
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */



/*
 * The following data structure is used to keep track of whether an
 * arbitrary block of memory has been deleted.  This is used by the
 * TclHandle code to avoid the more time-expensive algorithm of
 * Tcl_Preserve().  This mechanism is mainly used when we have lots of
 * references to a few big, expensive objects that we don't want to live
 * any longer than necessary.
 */

typedef struct HandleStruct {
    VOID *ptr;			/* Pointer to the memory block being
				 * tracked.  This field will become NULL when
				 * the memory block is deleted.  This field
				 * must be the first in the structure. */
#ifdef TCL_MEM_DEBUG
    VOID *ptr2;			/* Backup copy of the abpve pointer used to
				 * ensure that the contents of the handle are
				 * not changed by anyone else. */
#endif
    int refCount;		/* Number of TclHandlePreserve() calls in
				 * effect on this handle. */
} HandleStruct;


/*
 * Static routines in this file:
 */

static void	PreserveExitProc _ANSI_ARGS_((ClientData clientData));


/*
 *----------------------------------------------------------------------
 *
 * PreserveExitProc --
 *
 *	Called during exit processing to clean up the reference array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees the storage of the reference array.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
PreserveExitProc(clientData)
    ClientData clientData;		/* NULL -Unused. */
{
    Tcl_MutexLock(&preserveMutex);
    if (spaceAvl != 0) {
        ckfree((char *) refArray);
        refArray = (Reference *) NULL;
        inUse = 0;
        spaceAvl = 0;
    }
    Tcl_MutexUnlock(&preserveMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Preserve --
 *
 *	This procedure is used by a procedure to declare its interest
 *	in a particular block of memory, so that the block will not be
 *	reallocated until a matching call to Tcl_Release has been made.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information is retained so that the block of memory will
 *	not be freed until at least the matching call to Tcl_Release.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Preserve(clientData)
    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    int i;

    /*
     * See if there is already a reference for this pointer.  If so,
     * just increment its reference count.
     */

    Tcl_MutexLock(&preserveMutex);
    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData == clientData) {
	    refPtr->refCount++;
	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}
    }

    /*
     * Make a reference array if it doesn't already exist, or make it
     * bigger if it is full.
     */

    if (inUse == spaceAvl) {
	if (spaceAvl == 0) {
            Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc,
                    (ClientData) NULL);
	    refArray = (Reference *) ckalloc((unsigned)
		    (INITIAL_SIZE*sizeof(Reference)));
	    spaceAvl = INITIAL_SIZE;
	} else {
	    Reference *new;

	    new = (Reference *) ckalloc((unsigned)
|


|
|
<
|




|
|

|





|
|
|




|
|


|
|
|


>
>
>
>
>

|
|
|
|
<


>
>

|
|
|
|
<
|



|
|
|
|

|






<
<
<
<
<
<
<
<




|













|
|
<
















|
|
|





|
|












|
|



|








|
|




<
<







1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

46
47
48
49
50
51
52
53
54

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70








71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148


149
150
151
152
153
154
155
/*
 * tclPreserve.c --
 *
 *	This file contains a collection of functions that are used to make
 *	sure that widget records and other data structures aren't reallocated

 *	when there are nested functions that depend on their existence.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPreserve.c,v 1.5.2.2 2005/08/02 18:16:07 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following data structure is used to keep track of all the Tcl_Preserve
 * calls that are still in effect. It grows as needed to accommodate any
 * number of calls in effect.
 */

typedef struct {
    ClientData clientData;	/* Address of preserved block. */
    int refCount;		/* Number of Tcl_Preserve calls in effect for
				 * block. */
    int mustFree;		/* Non-zero means Tcl_EventuallyFree was
				 * called while a Tcl_Preserve call was in
				 * effect, so the structure must be freed when
				 * refCount becomes zero. */
    Tcl_FreeProc *freeProc;	/* Function to call to free. */
} Reference;

/*
 * Global data structures used to hold the list of preserved data references.
 * These variables are protected by "preserveMutex".
 */

static Reference *refArray;	/* First in array of references. */
static int spaceAvl = 0;	/* Total number of structures available at
				 * *firstRefPtr. */
static int inUse = 0;		/* Count of structures currently in use in
				 * refArray. */

TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */

#define INITIAL_SIZE	2	/* Initial number of reference slots to make */

/*
 * The following data structure is used to keep track of whether an arbitrary
 * block of memory has been deleted. This is used by the TclHandle code to
 * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism
 * is mainly used when we have lots of references to a few big, expensive

 * objects that we don't want to live any longer than necessary.
 */

typedef struct HandleStruct {
    VOID *ptr;			/* Pointer to the memory block being tracked.
				 * This field will become NULL when the memory
				 * block is deleted. This field must be the
				 * first in the structure. */
#ifdef TCL_MEM_DEBUG
    VOID *ptr2;			/* Backup copy of the above pointer used to
				 * ensure that the contents of the handle are
				 * not changed by anyone else. */
#endif
    int refCount;		/* Number of TclHandlePreserve() calls in
				 * effect on this handle. */
} HandleStruct;









/*
 *----------------------------------------------------------------------
 *
 * TclFinalizePreserve --
 *
 *	Called during exit processing to clean up the reference array.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees the storage of the reference array.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
void
TclFinalizePreserve()

{
    Tcl_MutexLock(&preserveMutex);
    if (spaceAvl != 0) {
        ckfree((char *) refArray);
        refArray = (Reference *) NULL;
        inUse = 0;
        spaceAvl = 0;
    }
    Tcl_MutexUnlock(&preserveMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Preserve --
 *
 *	This function is used by a function to declare its interest in a
 *	particular block of memory, so that the block will not be reallocated
 *	until a matching call to Tcl_Release has been made.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information is retained so that the block of memory will not be freed
 *	until at least the matching call to Tcl_Release.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Preserve(clientData)
    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    int i;

    /*
     * See if there is already a reference for this pointer. If so, just
     * increment its reference count.
     */

    Tcl_MutexLock(&preserveMutex);
    for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
	if (refPtr->clientData == clientData) {
	    refPtr->refCount++;
	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}
    }

    /*
     * Make a reference array if it doesn't already exist, or make it bigger
     * if it is full.
     */

    if (inUse == spaceAvl) {
	if (spaceAvl == 0) {


	    refArray = (Reference *) ckalloc((unsigned)
		    (INITIAL_SIZE*sizeof(Reference)));
	    spaceAvl = INITIAL_SIZE;
	} else {
	    Reference *new;

	    new = (Reference *) ckalloc((unsigned)
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214



215
216
217
218
219
220


221

222
223
224
225
226
227
228
229
230
231
232
233
234









235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295

296
297
298
299
300
301
302
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Release --
 *
 *	This procedure is called to cancel a previous call to
 *	Tcl_Preserve, thereby allowing a block of memory to be
 *	freed (if no one else cares about it).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If Tcl_EventuallyFree has been called for clientData, and if
 *	no other call to Tcl_Preserve is still in effect, the block of
 *	memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Release(clientData)
    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;
    int mustFree;
    Tcl_FreeProc *freeProc;
    int i;

    Tcl_MutexLock(&preserveMutex);



    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData != clientData) {
	    continue;
	}
	refPtr->refCount--;
	if (refPtr->refCount == 0) {




            /*
             * Must remove information from the slot before calling freeProc
             * to avoid reentrancy problems if the freeProc calls Tcl_Preserve
             * on the same clientData. Copy down the last reference in the
             * array to overwrite the current slot.
             */

            freeProc = refPtr->freeProc;
            mustFree = refPtr->mustFree;
	    inUse--;
	    if (i < inUse) {
		refArray[i] = refArray[inUse];
	    }









	    if (mustFree) {
		if (freeProc == TCL_DYNAMIC) {
		    ckfree((char *) clientData);
		} else {
		    Tcl_MutexUnlock(&preserveMutex);
		    (*freeProc)((char *) clientData);
		    return;
		}
	    }
	}
	Tcl_MutexUnlock(&preserveMutex);
	return;
    }
    Tcl_MutexUnlock(&preserveMutex);

    /*
     * Reference not found.  This is a bug in the caller.
     */

    Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EventuallyFree --
 *
 *	Free up a block of memory, unless a call to Tcl_Preserve is in
 *	effect for that block.  In this case, defer the free until all
 *	calls to Tcl_Preserve have been undone by matching calls to
 *	Tcl_Release.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Ptr may be released by calling free().
 *
 *----------------------------------------------------------------------
 */

void
Tcl_EventuallyFree(clientData, freeProc)
    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
    Tcl_FreeProc *freeProc;	/* Procedure to actually do free. */
{
    Reference *refPtr;
    int i;

    /*
     * See if there is a reference for this pointer.  If so, set its
     * "mustFree" flag (the flag had better not be set already!).
     */

    Tcl_MutexLock(&preserveMutex);
    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData != clientData) {
	    continue;
	}
	if (refPtr->mustFree) {
	    Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData);

        }
        refPtr->mustFree = 1;
	refPtr->freeProc = freeProc;
	Tcl_MutexUnlock(&preserveMutex);
        return;
    }
    Tcl_MutexUnlock(&preserveMutex);







|
|
|





|
|
<









<
<



>
>
>
|



|
|
>
>
|
>
|
|
|
|
|
|

|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
|
|
|
|
<
|
<
|
|
<
<





|










|
|
|
<













|





|
|








|
>







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

193
194
195
196
197
198
199
200
201


202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243

244

245
246


247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Release --
 *
 *	This function is called to cancel a previous call to Tcl_Preserve,
 *	thereby allowing a block of memory to be freed (if no one else cares
 *	about it).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If Tcl_EventuallyFree has been called for clientData, and if no other
 *	call to Tcl_Preserve is still in effect, the block of memory is freed.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_Release(clientData)
    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
{
    Reference *refPtr;


    int i;

    Tcl_MutexLock(&preserveMutex);
    for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
	int mustFree;
	Tcl_FreeProc *freeProc;

	if (refPtr->clientData != clientData) {
	    continue;
	}

	if (--refPtr->refCount != 0) {
	    Tcl_MutexUnlock(&preserveMutex);
	    return;
	}

	/*
	 * Must remove information from the slot before calling freeProc to
	 * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the
	 * same clientData. Copy down the last reference in the array to
	 * overwrite the current slot.
	 */

	freeProc = refPtr->freeProc;
	mustFree = refPtr->mustFree;
	inUse--;
	if (i < inUse) {
	    refArray[i] = refArray[inUse];
	}

	/*
	 * Now committed to disposing the data. But first, we've patched up
	 * all the global data structures so we should release the mutex now.
	 * Only then should we dabble around with potentially-slow memory
	 * managers...
	 */

	Tcl_MutexUnlock(&preserveMutex);
	if (mustFree) {
	    if (freeProc == TCL_DYNAMIC) {
		ckfree((char *) clientData);
	    } else {

		(*freeProc)((char *) clientData);

	    }
	}


	return;
    }
    Tcl_MutexUnlock(&preserveMutex);

    /*
     * Reference not found. This is a bug in the caller.
     */

    Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EventuallyFree --
 *
 *	Free up a block of memory, unless a call to Tcl_Preserve is in effect
 *	for that block. In this case, defer the free until all calls to
 *	Tcl_Preserve have been undone by matching calls to Tcl_Release.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Ptr may be released by calling free().
 *
 *----------------------------------------------------------------------
 */

void
Tcl_EventuallyFree(clientData, freeProc)
    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
    Tcl_FreeProc *freeProc;	/* Function to actually do free. */
{
    Reference *refPtr;
    int i;

    /*
     * See if there is a reference for this pointer. If so, set its "mustFree"
     * flag (the flag had better not be set already!).
     */

    Tcl_MutexLock(&preserveMutex);
    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData != clientData) {
	    continue;
	}
	if (refPtr->mustFree) {
	    Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n",
		    clientData);
        }
        refPtr->mustFree = 1;
	refPtr->freeProc = freeProc;
	Tcl_MutexUnlock(&preserveMutex);
        return;
    }
    Tcl_MutexUnlock(&preserveMutex);
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandleCreate --
 *
 *	Allocate a handle that contains enough information to determine
 *	if an arbitrary malloc'd block has been deleted.  This is 
 *	used to avoid the more time-expensive algorithm of Tcl_Preserve().
 *
 * Results:
 *	The return value is a TclHandle that refers to the given malloc'd
 *	block.  Doubly dereferencing the returned handle will give
 *	back the pointer to the block, or will give NULL if the block has
 *	been deleted.
 *
 * Side effects:
 *	The caller must keep track of this handle (generally by storing
 *	it in a field in the malloc'd block) and call TclHandleFree()
 *	on this handle when the block is deleted.  Everything else that
 *	wishes to keep track of whether the malloc'd block has been deleted
 *	should use calls to TclHandlePreserve() and TclHandleRelease()
 *	on the associated handle.
 *
 *---------------------------------------------------------------------------
 */

TclHandle
TclHandleCreate(ptr)
    VOID *ptr;			/* Pointer to an arbitrary block of memory
				 * to be tracked for deletion.  Must not be
				 * NULL. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct));
    handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
    handlePtr->ptr2 = ptr;
#endif
    handlePtr->refCount = 0;
    return (TclHandle) handlePtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandleFree --
 *
 *	Called when the arbitrary malloc'd block associated with the
 *	handle is being deleted.  Modifies the handle so that doubly
 *	dereferencing it will give NULL.  This informs any user of the
 *	handle that the block of memory formerly referenced by the
 *	handle has been freed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If nothing is referring to the handle, the handle will be reclaimed.
 *
 *---------------------------------------------------------------------------
 */

void
TclHandleFree(handle)
    TclHandle handle;		/* Previously created handle associated
				 * with a malloc'd block that is being
				 * deleted.  The handle is modified so that
				 * doubly dereferencing it will give NULL. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
    if (handlePtr->refCount == 0x61616161) {
	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);







|
|
|



|
|
<


|
|
|
|
|
<






|
|


















|
|
|
|
<












|
|
|
|







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328

329
330
331
332
333
334
335

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandleCreate --
 *
 *	Allocate a handle that contains enough information to determine if an
 *	arbitrary malloc'd block has been deleted. This is used to avoid the
 *	more time-expensive algorithm of Tcl_Preserve().
 *
 * Results:
 *	The return value is a TclHandle that refers to the given malloc'd
 *	block. Doubly dereferencing the returned handle will give back the
 *	pointer to the block, or will give NULL if the block has been deleted.

 *
 * Side effects:
 *	The caller must keep track of this handle (generally by storing it in
 *	a field in the malloc'd block) and call TclHandleFree() on this handle
 *	when the block is deleted. Everything else that wishes to keep track
 *	of whether the malloc'd block has been deleted should use calls to
 *	TclHandlePreserve() and TclHandleRelease() on the associated handle.

 *
 *---------------------------------------------------------------------------
 */

TclHandle
TclHandleCreate(ptr)
    VOID *ptr;			/* Pointer to an arbitrary block of memory to
				 * be tracked for deletion. Must not be
				 * NULL. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct));
    handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
    handlePtr->ptr2 = ptr;
#endif
    handlePtr->refCount = 0;
    return (TclHandle) handlePtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandleFree --
 *
 *	Called when the arbitrary malloc'd block associated with the handle is
 *	being deleted. Modifies the handle so that doubly dereferencing it
 *	will give NULL. This informs any user of the handle that the block of
 *	memory formerly referenced by the handle has been freed.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If nothing is referring to the handle, the handle will be reclaimed.
 *
 *---------------------------------------------------------------------------
 */

void
TclHandleFree(handle)
    TclHandle handle;		/* Previously created handle associated with a
				 * malloc'd block that is being deleted. The
				 * handle is modified so that doubly
				 * dereferencing it will give NULL. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
    if (handlePtr->refCount == 0x61616161) {
	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488







}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandlePreserve --
 *
 *	Declare an interest in the arbitrary malloc'd block associated
 *	with the handle.  
 *
 * Results:
 *	The return value is the handle argument, with its ref count
 *	incremented.
 *
 * Side effects:
 *	For each call to TclHandlePreserve(), there should be a matching
 *	call to TclHandleRelease() when the caller is no longer interested
 *	in the malloc'd block associated with the handle.
 *
 *---------------------------------------------------------------------------
 */

TclHandle
TclHandlePreserve(handle)
    TclHandle handle;		/* Declare an interest in the block of
				 * memory referenced by this handle. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
    if (handlePtr->refCount == 0x61616161) {
	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
    }
    if ((handlePtr->ptr != NULL)
	    && (handlePtr->ptr != handlePtr->ptr2)) {
	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
		handlePtr, handlePtr->ptr2, handlePtr->ptr);
    }
#endif
    handlePtr->refCount++;

    return handle;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandleRelease --
 *
 *	This procedure is called to release an interest in the malloc'd
 *	block associated with the handle.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The ref count of the handle is decremented.  If the malloc'd block
 *	has been freed and if no one is using the handle any more, the
 *	handle will be reclaimed.
 *
 *---------------------------------------------------------------------------
 */
 
void
TclHandleRelease(handle)
    TclHandle handle;		/* Unregister interest in the block of
				 * memory referenced by this handle. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
    if (handlePtr->refCount == 0x61616161) {
	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
    }
    if ((handlePtr->ptr != NULL)
	    && (handlePtr->ptr != handlePtr->ptr2)) {
	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
		handlePtr, handlePtr->ptr2, handlePtr->ptr);
    }
#endif
    handlePtr->refCount--;
    if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
	ckfree((char *) handlePtr);
    }
}
    














|
|






|
|
|






|
|








|
<














|
|





|
|
|



|


|
|








|
<









|
>
>
>
>
>
>
>
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474

475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandlePreserve --
 *
 *	Declare an interest in the arbitrary malloc'd block associated with
 *	the handle.
 *
 * Results:
 *	The return value is the handle argument, with its ref count
 *	incremented.
 *
 * Side effects:
 *	For each call to TclHandlePreserve(), there should be a matching call
 *	to TclHandleRelease() when the caller is no longer interested in the
 *	malloc'd block associated with the handle.
 *
 *---------------------------------------------------------------------------
 */

TclHandle
TclHandlePreserve(handle)
    TclHandle handle;		/* Declare an interest in the block of memory
				 * referenced by this handle. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
    if (handlePtr->refCount == 0x61616161) {
	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
    }
    if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {

	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
		handlePtr, handlePtr->ptr2, handlePtr->ptr);
    }
#endif
    handlePtr->refCount++;

    return handle;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclHandleRelease --
 *
 *	This function is called to release an interest in the malloc'd block
 *	associated with the handle.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The ref count of the handle is decremented. If the malloc'd block has
 *	been freed and if no one is using the handle any more, the handle will
 *	be reclaimed.
 *
 *---------------------------------------------------------------------------
 */

void
TclHandleRelease(handle)
    TclHandle handle;		/* Unregister interest in the block of memory
				 * referenced by this handle. */
{
    HandleStruct *handlePtr;

    handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
    if (handlePtr->refCount == 0x61616161) {
	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
    }
    if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {

	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
		handlePtr, handlePtr->ptr2, handlePtr->ptr);
    }
#endif
    handlePtr->refCount--;
    if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
	ckfree((char *) handlePtr);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclProc.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29




30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66 2004/11/25 16:37:15 dkf Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
 */

static void	ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
static void	ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
static int	ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
		    char *procName, int nameLen, int returnCode));
static int	TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));





/*
 * The ProcBodyObjType type
 */

Tcl_ObjType tclProcBodyType = {
    "procbody",			/* name for this type */
    ProcBodyFree,		/* FreeInternalRep procedure */
    ProcBodyDup,		/* DupInternalRep procedure */
    NULL,			/* UpdateString procedure; Tcl_GetString
				 * and Tcl_GetStringFromObj should panic
				 * instead. */
    NULL			/* SetFromAny procedure; Tcl_ConvertToType
				 * should panic instead. */
};

/*
 * The [upvar]/[uplevel] level reference type.  Uses the twoPtrValue
 * field, encoding the type of level reference in ptr1 and the actual
 * parsed out offset in ptr2.
 *
 * Uses the default behaviour throughout, and never disposes of the
 * string rep; it's just a cache type.
 */

Tcl_ObjType tclLevelReferenceType = {
    "levelReference",
    NULL, NULL, NULL, NULL
};

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ProcObjCmd --
 *
 *	This object-based procedure is invoked to process the "proc" Tcl 
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A new procedure gets created.
|


|
|




|
|

|
















>
>
>
>






|
|
|
|

|




|
|
|

|
|


|









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
/*
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures, including
 *	the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66.2.8 2005/09/27 18:42:54 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
 */

static void	ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
static void	ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
static int	ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
		    char *procName, int nameLen, int returnCode));
static int	TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));

static void	InitCompiledLocals _ANSI_ARGS_((Tcl_Interp *interp,
		    ByteCode *codePtr, CompiledLocal *localPtr,
		    Var *varPtr, Namespace *nsPtr));

/*
 * The ProcBodyObjType type
 */

Tcl_ObjType tclProcBodyType = {
    "procbody",			/* name for this type */
    ProcBodyFree,		/* FreeInternalRep function */
    ProcBodyDup,		/* DupInternalRep function */
    NULL,			/* UpdateString function; Tcl_GetString and
				 * Tcl_GetStringFromObj should panic
				 * instead. */
    NULL			/* SetFromAny function; Tcl_ConvertToType
				 * should panic instead. */
};

/*
 * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field,
 * encoding the type of level reference in ptr1 and the actual parsed out
 * offset in ptr2.
 *
 * Uses the default behaviour throughout, and never disposes of the string
 * rep; it's just a cache type.
 */

static Tcl_ObjType levelReferenceType = {
    "levelReference",
    NULL, NULL, NULL, NULL
};

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ProcObjCmd --
 *
 *	This object-based function is invoked to process the "proc" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A new procedure gets created.
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
	return TCL_ERROR;
    }

    /*
     * Determine the namespace where the procedure should reside. Unless
     * the command name includes namespace qualifiers, this will be the
     * current namespace.
     */

    fullName = TclGetString(objv[1]);
    TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
	    0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);

    if (nsPtr == NULL) {
	Tcl_AppendResult(interp, "can't create procedure \"", fullName,
		"\": unknown namespace", (char *) NULL);
	return TCL_ERROR;
    }
    if (procName == NULL) {







|
|
|



|
|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
	return TCL_ERROR;
    }

    /*
     * Determine the namespace where the procedure should reside. Unless the
     * command name includes namespace qualifiers, this will be the current
     * namespace.
     */

    fullName = TclGetString(objv[1]);
    TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, 0,
	    &nsPtr, &altNsPtr, &cxtNsPtr, &procName);

    if (nsPtr == NULL) {
	Tcl_AppendResult(interp, "can't create procedure \"", fullName,
		"\": unknown namespace", (char *) NULL);
	return TCL_ERROR;
    }
    if (procName == NULL) {
121
122
123
124
125
126
127

128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150

151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

241
242
243
244
245
246
247
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Create the data structure to represent the procedure.
     */

    if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
	    &procPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Now create a command for the procedure. This will initially be in
     * the current namespace unless the procedure's name included namespace
     * qualifiers. To create the new command in the right namespace, we
     * generate a fully qualified name for it.
     */

    Tcl_DStringInit(&ds);
    if (nsPtr != iPtr->globalNsPtr) {
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	Tcl_DStringAppend(&ds, "::", 2);
    }
    Tcl_DStringAppend(&ds, procName, -1);

    cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
	    TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);

    Tcl_DStringFree(&ds);

    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.
     */

    procPtr->cmdPtr = (Command *) cmd;

    /*
     * Optimize for no-op procs: if the body is not precompiled (like a TclPro
     * procbody), and the argument list is just "args" and the body is empty,
     * define a compileProc to compile a no-op.
     *
     * Notes: 
     *   - cannot be done for any argument list without having different
     *     compiled/not-compiled behaviour in the "wrong argument #" case, 
     *     or making this code much more complicated. In any case, it doesn't 
     *     seem to make a lot of sense to verify the number of arguments we 
     *     are about to ignore ...
     *   - could be enhanced to handle also non-empty bodies that contain 
     *     only comments; however, parsing the body will slow down the 
     *     compilation of all procs whose argument list is just _args_ */


    if (objv[3]->typePtr == &tclProcBodyType) {
	goto done;
    }

    procArgs = TclGetString(objv[2]);

    while (*procArgs == ' ') {
	procArgs++;
    }

    if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
	procArgs +=4;
	while(*procArgs != '\0') {
	    if (*procArgs != ' ') {
		goto done;
	    }
	    procArgs++;
	}	

	/* 
	 * The argument list is just "args"; check the body
	 */

	procBody = TclGetString(objv[3]);
	while (*procBody != '\0') {
	    if (!isspace(UCHAR(*procBody))) {
		goto done;
	    }
	    procBody++;
	}	

	/* 
	 * The body is just spaces: link the compileProc
	 */

	((Command *) cmd)->compileProc = TclCompileNoOp;
    }

 done:
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateProc --
 *
 *	Creates the data associated with a Tcl procedure definition.
 *	This procedure knows how to handle two types of body objects:
 *	strings and procbody. Strings are the traditional (and common) value
 *	for bodies, procbody are values created by extensions that have
 *	loaded a previously compiled script. 
 *
 * Results:
 *	Returns TCL_OK on success, along with a pointer to a Tcl
 *	procedure definition in procPtrPtr where the cmdPtr field is not
 *	initialised. This definition should be freed by calling
 *	TclProcCleanupProc() when it is no longer needed.  Returns TCL_ERROR if
 *	anything goes wrong. 
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error
 *	message in the interpreter.
 *
 *----------------------------------------------------------------------
 */

int
TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
    Tcl_Interp *interp;		/* interpreter containing proc */
    Namespace *nsPtr;		/* namespace containing this proc */
    CONST char *procName;	/* unqualified name of this proc */
    Tcl_Obj *argsPtr;		/* description of arguments */
    Tcl_Obj *bodyPtr;		/* command body */







>






|
|















>














|
|
|
|
|
|
|
|
|
>


















|

|









|

|






|








|
|
|
|
|


|
|
|
<
|


|
|



>







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238

239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Create the data structure to represent the procedure.
     */

    if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
	    &procPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Now create a command for the procedure. This will initially be in the
     * current namespace unless the procedure's name included namespace
     * qualifiers. To create the new command in the right namespace, we
     * generate a fully qualified name for it.
     */

    Tcl_DStringInit(&ds);
    if (nsPtr != iPtr->globalNsPtr) {
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	Tcl_DStringAppend(&ds, "::", 2);
    }
    Tcl_DStringAppend(&ds, procName, -1);

    cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
	    TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);

    Tcl_DStringFree(&ds);

    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.
     */

    procPtr->cmdPtr = (Command *) cmd;

    /*
     * Optimize for no-op procs: if the body is not precompiled (like a TclPro
     * procbody), and the argument list is just "args" and the body is empty,
     * define a compileProc to compile a no-op.
     *
     * Notes:
     *	 - cannot be done for any argument list without having different
     *	   compiled/not-compiled behaviour in the "wrong argument #" case, or
     *	   making this code much more complicated. In any case, it doesn't
     *	   seem to make a lot of sense to verify the number of arguments we
     *	   are about to ignore ...
     *	 - could be enhanced to handle also non-empty bodies that contain only
     *	   comments; however, parsing the body will slow down the compilation
     *	   of all procs whose argument list is just _args_
     */

    if (objv[3]->typePtr == &tclProcBodyType) {
	goto done;
    }

    procArgs = TclGetString(objv[2]);

    while (*procArgs == ' ') {
	procArgs++;
    }

    if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
	procArgs +=4;
	while(*procArgs != '\0') {
	    if (*procArgs != ' ') {
		goto done;
	    }
	    procArgs++;
	}

	/*
	 * The argument list is just "args"; check the body
	 */

	procBody = TclGetString(objv[3]);
	while (*procBody != '\0') {
	    if (!isspace(UCHAR(*procBody))) {
		goto done;
	    }
	    procBody++;
	}

	/*
	 * The body is just spaces: link the compileProc
	 */

	((Command *) cmd)->compileProc = TclCompileNoOp;
    }

  done:
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateProc --
 *
 *	Creates the data associated with a Tcl procedure definition. This
 *	function knows how to handle two types of body objects: strings and
 *	procbody. Strings are the traditional (and common) value for bodies,
 *	procbody are values created by extensions that have loaded a
 *	previously compiled script.
 *
 * Results:
 *	Returns TCL_OK on success, along with a pointer to a Tcl procedure
 *	definition in procPtrPtr where the cmdPtr field is not initialised.
 *	This definition should be freed by calling TclProcCleanupProc() when

 *	it is no longer needed. Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this function returns an error message in the
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

int
TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
    Tcl_Interp *interp;		/* interpreter containing proc */
    Namespace *nsPtr;		/* namespace containing this proc */
    CONST char *procName;	/* unqualified name of this proc */
    Tcl_Obj *argsPtr;		/* description of arguments */
    Tcl_Obj *bodyPtr;		/* command body */
272
273
274
275
276
277
278
279
280
281
282
283

284
285
286
287
288
289
290
291
292
293
294
295
296

	procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
	procPtr->iPtr = iPtr;
	procPtr->refCount++;
	precompiled = 1;
    } else {
	/*
	 * If the procedure's body object is shared because its string value is
	 * identical to, e.g., the body of another procedure, we must create a
	 * private copy for this procedure to use. Such sharing of procedure
	 * bodies is rare but can cause problems. A procedure body is compiled
	 * in a context that includes the number of compiler-allocated "slots"

	 * for local variables. Each formal parameter is given a local variable
	 * slot (the "procPtr->numCompiledLocals = numArgs" assignment
	 * below). This means that the same code can not be shared by two
	 * procedures that have a different number of arguments, even if their
	 * bodies are identical. Note that we don't use Tcl_DuplicateObj since
	 * we would not want any bytecode internal representation.
	 */

	if (Tcl_IsShared(bodyPtr)) {
	    bytes = Tcl_GetStringFromObj(bodyPtr, &length);
	    bodyPtr = Tcl_NewStringObj(bytes, length);
	}








|
|
|
|
|
>
|
|
|
|
|
|







279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

	procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
	procPtr->iPtr = iPtr;
	procPtr->refCount++;
	precompiled = 1;
    } else {
	/*
	 * If the procedure's body object is shared because its string value
	 * is identical to, e.g., the body of another procedure, we must
	 * create a private copy for this procedure to use. Such sharing of
	 * procedure bodies is rare but can cause problems. A procedure body
	 * is compiled in a context that includes the number of
	 * compiler-allocated "slots" for local variables. Each formal
	 * parameter is given a local variable slot (the
	 * "procPtr->numCompiledLocals = numArgs" assignment below). This
	 * means that the same code can not be shared by two procedures that
	 * have a different number of arguments, even if their bodies are
	 * identical. Note that we don't use Tcl_DuplicateObj since we would
	 * not want any bytecode internal representation.
	 */

	if (Tcl_IsShared(bodyPtr)) {
	    bytes = Tcl_GetStringFromObj(bodyPtr, &length);
	    bodyPtr = Tcl_NewStringObj(bytes, length);
	}

309
310
311
312
313
314
315
316
317
318
319
320

321
322
323
324
325
326
327
328
329
330
331
332


333
334
335
336
337
338
339
340
341
342
343

344
345
346
347
348
349
350
	procPtr->numArgs = 0;	/* actual argument count is set below. */
	procPtr->numCompiledLocals = 0;
	procPtr->firstLocalPtr = NULL;
	procPtr->lastLocalPtr = NULL;
    }

    /*
     * Break up the argument list into argument specifiers, then process
     * each argument specifier.
     * If the body is precompiled, processing is limited to checking that
     * the parsed argument is consistent with the one stored in the
     * Proc.

     * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
     */

    args = Tcl_GetStringFromObj(argsPtr, &length);
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
	goto procError;
    }

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    char buf[40 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];


	    sprintf(buf, "%d entries, precompiled header expects %d",
		    numArgs, procPtr->numArgs);
	    Tcl_AppendResult(interp, "procedure \"", procName,
		    "\": arg list contains ", buf, NULL);
	    goto procError;
	}
	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }

    for (i = 0; i < numArgs; i++) {
	int fieldCount, nameLength, valueLength;
	CONST char **fieldValues;

	/*
	 * Now divide the specifier up into name and default.
	 */







|
<
|
|
|
>











|
>
>
|
|
|
<







>







317
318
319
320
321
322
323
324

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
	procPtr->numArgs = 0;	/* actual argument count is set below. */
	procPtr->numCompiledLocals = 0;
	procPtr->firstLocalPtr = NULL;
	procPtr->lastLocalPtr = NULL;
    }

    /*
     * Break up the argument list into argument specifiers, then process each

     * argument specifier.  If the body is precompiled, processing is limited
     * to checking that the parsed argument is consistent with the one stored
     * in the Proc.
     *
     * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
     */

    args = Tcl_GetStringFromObj(argsPtr, &length);
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
	goto procError;
    }

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    Tcl_Obj *objPtr = Tcl_NewObj();
	    TclObjPrintf(NULL, objPtr,
		    "procedure \"%s\": arg list contains %d entries, "
		    "precompiled header expects %d", procName, numArgs,
		    procPtr->numArgs);
	    Tcl_SetObjResult(interp, objPtr);

	    goto procError;
	}
	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }

    for (i = 0; i < numArgs; i++) {
	int fieldCount, nameLength, valueLength;
	CONST char **fieldValues;

	/*
	 * Now divide the specifier up into name and default.
	 */
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

441

442
443
444


445
446
447






448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
		goto procError;
	    }
	    p++;
	}

	if (precompiled) {
	    /*
	     * Compare the parsed argument with the stored one.
	     * For the flags, we and out VAR_UNDEFINED to support bridging
	     * precompiled <= 8.3 code in 8.4 where this is now used as an
	     * optimization indicator.	Yes, this is a hack. -- hobbs
	     */

	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		char buf[40 + TCL_INTEGER_SPACE];

		ckfree((char *) fieldValues);
		sprintf(buf, "%d is inconsistent with precompiled body", i);
		Tcl_AppendResult(interp, "procedure \"", procName,
			"\": formal parameter ", buf, (char *) NULL);
		goto procError;
	    }

	    /*
	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);
		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {

		    Tcl_AppendResult(interp, "procedure \"", procName,

			    "\": formal parameter \"", fieldValues[0],
			    "\" has default value inconsistent with precompiled body",
			    (char *) NULL);


		    ckfree((char *) fieldValues);
		    goto procError;
		}






	    }

	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of
	     * local variables for the argument. 
	     */

	    localPtr = (CompiledLocal *) ckalloc((unsigned) 
		    (sizeof(CompiledLocal) - sizeof(localPtr->name)
			    + nameLength + 1));
	    if (procPtr->firstLocalPtr == NULL) {
		procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	    } else {
		procPtr->lastLocalPtr->nextPtr = localPtr;
		procPtr->lastLocalPtr = localPtr;







|
|
|
|









|
|
|
|
|
|













>
|
>
|
|
<
>
>



>
>
>
>
>
>






|


|







412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455

456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
		goto procError;
	    }
	    p++;
	}

	if (precompiled) {
	    /*
	     * Compare the parsed argument with the stored one. For the flags,
	     * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3
	     * code in 8.4 where this is now used as an optimization
	     * indicator. Yes, this is a hack. -- hobbs
	     */

	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		Tcl_Obj *objPtr = Tcl_NewObj();
		TclObjPrintf(NULL, objPtr,
			"procedure \"%s\": formal parameter %d is "
			"inconsistent with precompiled body", procName, i);
		Tcl_SetObjResult(interp, objPtr);
		ckfree((char *) fieldValues);
		goto procError;
	    }

	    /*
	     * compare the default value if any
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
			&tmpLength);
		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_Obj *objPtr = Tcl_NewObj();

		    TclObjPrintf(NULL, objPtr,
			    "procedure \"%s\": formal parameter \"%s\" has "
			    "default value inconsistent with precompiled body",

			    procName, fieldValues[0]);
		    Tcl_SetObjResult(interp, objPtr);
		    ckfree((char *) fieldValues);
		    goto procError;
		}
		if ((i == numArgs - 1)
			&& (localPtr->nameLength == 4)
			&& (localPtr->name[0] == 'a')
			&& (strcmp(localPtr->name, "args") == 0)) {
		    localPtr->flags |= VAR_IS_ARGS;
		}
	    }

	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of
	     * local variables for the argument.
	     */

	    localPtr = (CompiledLocal *) ckalloc((unsigned)
		    (sizeof(CompiledLocal) - sizeof(localPtr->name)
			    + nameLength + 1));
	    if (procPtr->firstLocalPtr == NULL) {
		procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	    } else {
		procPtr->lastLocalPtr->nextPtr = localPtr;
		procPtr->lastLocalPtr = localPtr;
473
474
475
476
477
478
479






480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
		localPtr->defValuePtr =
			Tcl_NewStringObj(fieldValues[1], valueLength);
		Tcl_IncrRefCount(localPtr->defValuePtr);
	    } else {
		localPtr->defValuePtr = NULL;
	    }
	    strcpy(localPtr->name, fieldValues[0]);






	}

	ckfree((char *) fieldValues);
    }

    *procPtrPtr = procPtr;
    ckfree((char *) argArray);
    return TCL_OK;

procError:
    if (precompiled) {
	procPtr->refCount--;
    } else {
	Tcl_DecrRefCount(bodyPtr);
	while (procPtr->firstLocalPtr != NULL) {
	    localPtr = procPtr->firstLocalPtr;
	    procPtr->firstLocalPtr = localPtr->nextPtr;







>
>
>
>
>
>









|







492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
		localPtr->defValuePtr =
			Tcl_NewStringObj(fieldValues[1], valueLength);
		Tcl_IncrRefCount(localPtr->defValuePtr);
	    } else {
		localPtr->defValuePtr = NULL;
	    }
	    strcpy(localPtr->name, fieldValues[0]);
	    if ((i == numArgs - 1)
		    && (localPtr->nameLength == 4)
		    && (localPtr->name[0] == 'a')
		    && (strcmp(localPtr->name, "args") == 0)) {
		localPtr->flags |= VAR_IS_ARGS;
	    }
	}

	ckfree((char *) fieldValues);
    }

    *procPtrPtr = procPtr;
    ckfree((char *) argArray);
    return TCL_OK;

  procError:
    if (precompiled) {
	procPtr->refCount--;
    } else {
	Tcl_DecrRefCount(bodyPtr);
	while (procPtr->firstLocalPtr != NULL) {
	    localPtr = procPtr->firstLocalPtr;
	    procPtr->firstLocalPtr = localPtr->nextPtr;
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetFrame --
 *
 *	Given a description of a procedure frame, such as the first
 *	argument to an "uplevel" or "upvar" command, locate the
 *	call frame for the appropriate level of procedure.
 *
 * Results:
 *	The return value is -1 if an error occurred in finding the frame
 *	(in this case an error message is left in the interp's result).
 *	1 is returned if string was either a number or a number preceded
 *	by "#" and it specified a valid frame.  0 is returned if string
 *	isn't one of the two things above (in this case, the lookup
 *	acts as if string were "1").  The variable pointed to by
 *	framePtrPtr is filled in with the address of the desired frame
 *	(unless an error occurs, in which case it isn't modified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetFrame(interp, name, framePtrPtr)
    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
    CONST char *name;		/* String describing frame. */
    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
				 * if global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;

    /*
     * Parse string to figure out which level number to go to.







|
|
|


|
|
|
|
|
|
|
|











|
|







536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetFrame --
 *
 *	Given a description of a procedure frame, such as the first argument
 *	to an "uplevel" or "upvar" command, locate the call frame for the
 *	appropriate level of procedure.
 *
 * Results:
 *	The return value is -1 if an error occurred in finding the frame (in
 *	this case an error message is left in the interp's result). 1 is
 *	returned if string was either a number or a number preceded by "#" and
 *	it specified a valid frame.  0 is returned if string isn't one of the
 *	two things above (in this case, the lookup acts as if string were
 *	"1"). The variable pointed to by framePtrPtr is filled in with the
 *	address of the desired frame (unless an error occurs, in which case it
 *	isn't modified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetFrame(interp, name, framePtrPtr)
    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
    CONST char *name;		/* String describing frame. */
    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;

    /*
     * Parse string to figure out which level number to go to.
562
563
564
565
566
567
568

569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644

645

646


647
648
649
650
651
652
653
654
655

656
657


658

659
660
661
662
663
664
665
666

667
668


669

670
671
672
673
674
675
676
677
678

679
680
681
682
683

684

685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
	}
	level = curLevel - level;
    } else {
	level = curLevel - 1;
	result = 0;
    }


    /* Figure out which frame to use, and return it to the caller */


    if (level == 0) {
	framePtr = NULL;
    } else {
	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		framePtr = framePtr->callerVarPtr) {
	    if (framePtr->level == level) {
		break;
	    }
	}
	if (framePtr == NULL) {
	    goto levelError;
	}
    }
    *framePtrPtr = framePtr;
    return result;

 levelError:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjGetFrame --
 *
 *	Given a description of a procedure frame, such as the first
 *	argument to an "uplevel" or "upvar" command, locate the
 *	call frame for the appropriate level of procedure.
 *
 * Results:
 *	The return value is -1 if an error occurred in finding the frame
 *	(in this case an error message is left in the interp's result).
 *	1 is returned if objPtr was either a number or a number preceded
 *	by "#" and it specified a valid frame.  0 is returned if objPtr
 *	isn't one of the two things above (in this case, the lookup
 *	acts as if objPtr were "1").  The variable pointed to by
 *	framePtrPtr is filled in with the address of the desired frame
 *	(unless an error occurs, in which case it isn't modified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclObjGetFrame(interp, objPtr, framePtrPtr)
    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
    Tcl_Obj *objPtr;		/* Object describing frame. */
    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
				 * if global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;
    CONST char *name = TclGetString(objPtr);

    /*
     * Parse object to figure out which level number to go to.
     */

    result = 1;
    curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
    if (objPtr->typePtr == &tclLevelReferenceType) {
	if ((int) objPtr->internalRep.twoPtrValue.ptr1) {
	    level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2;
	} else {
	    level = (int) objPtr->internalRep.twoPtrValue.ptr2;
	}
	if (level < 0) {
	    goto levelError;
	}

    } else if (objPtr->typePtr == &tclIntType ||

	    objPtr->typePtr == &tclWideIntType) {


	if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
	    goto levelError;
	}
	level = curLevel - level;
    } else {
	if (*name == '#') {
	    if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
		goto levelError;
	    }

	    /*
	     * Cache for future reference.


	     */

	    TclFreeIntRep(objPtr);
	    objPtr->typePtr = &tclLevelReferenceType;
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0;
	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
	} else if (isdigit(UCHAR(*name))) { /* INTL: digit */
	    if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
		return -1;
	    }

	    /*
	     * Cache for future reference.


	     */

	    TclFreeIntRep(objPtr);
	    objPtr->typePtr = &tclLevelReferenceType;
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1;
	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
	    level = curLevel - level;
	} else {
	    /*
	     * Don't cache as the object *isn't* a level reference.
	     */

	    level = curLevel - 1;
	    result = 0;
	}
    }


    /* Figure out which frame to use, and return it to the caller */


    if (level == 0) {
	framePtr = NULL;
    } else {
	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		framePtr = framePtr->callerVarPtr) {
	    if (framePtr->level == level) {
		break;
	    }
	}
	if (framePtr == NULL) {
	    goto levelError;
	}
    }
    *framePtrPtr = framePtr;
    return result;

levelError:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UplevelObjCmd --
 *
 *	This object procedure is invoked to process the "uplevel" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	See the user documentation.
 *







>
|
>

















|










|
|
|


|
|
|
|
|
|
|
|











|
|












|








>
|
>
|
>
>









>


>
>

>

|






>


>
>

>

|







>





>
|
>

















|










|
|







587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
	}
	level = curLevel - level;
    } else {
	level = curLevel - 1;
	result = 0;
    }

    /*
     * Figure out which frame to use, and return it to the caller.
     */

    if (level == 0) {
	framePtr = NULL;
    } else {
	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		framePtr = framePtr->callerVarPtr) {
	    if (framePtr->level == level) {
		break;
	    }
	}
	if (framePtr == NULL) {
	    goto levelError;
	}
    }
    *framePtrPtr = framePtr;
    return result;

  levelError:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjGetFrame --
 *
 *	Given a description of a procedure frame, such as the first argument
 *	to an "uplevel" or "upvar" command, locate the call frame for the
 *	appropriate level of procedure.
 *
 * Results:
 *	The return value is -1 if an error occurred in finding the frame (in
 *	this case an error message is left in the interp's result). 1 is
 *	returned if objPtr was either a number or a number preceded by "#" and
 *	it specified a valid frame. 0 is returned if objPtr isn't one of the
 *	two things above (in this case, the lookup acts as if objPtr were
 *	"1"). The variable pointed to by framePtrPtr is filled in with the
 *	address of the desired frame (unless an error occurs, in which case it
 *	isn't modified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclObjGetFrame(interp, objPtr, framePtrPtr)
    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
    Tcl_Obj *objPtr;		/* Object describing frame. */
    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;
    CONST char *name = TclGetString(objPtr);

    /*
     * Parse object to figure out which level number to go to.
     */

    result = 1;
    curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
    if (objPtr->typePtr == &levelReferenceType) {
	if ((int) objPtr->internalRep.twoPtrValue.ptr1) {
	    level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2;
	} else {
	    level = (int) objPtr->internalRep.twoPtrValue.ptr2;
	}
	if (level < 0) {
	    goto levelError;
	}
	/* TODO: Consider skipping the typePtr checks */
    } else if (objPtr->typePtr == &tclIntType
#ifndef NO_WIDE_TYPE
	    || objPtr->typePtr == &tclWideIntType
#endif
	    ) {
	if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
	    goto levelError;
	}
	level = curLevel - level;
    } else {
	if (*name == '#') {
	    if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
		goto levelError;
	    }

	    /*
	     * Cache for future reference.
	     *
	     * TODO: Use the new ptrAndLongRep intrep
	     */

	    TclFreeIntRep(objPtr);
	    objPtr->typePtr = &levelReferenceType;
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0;
	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
	} else if (isdigit(UCHAR(*name))) { /* INTL: digit */
	    if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
		return -1;
	    }

	    /*
	     * Cache for future reference.
	     *
	     * TODO: Use the new ptrAndLongRep intrep
	     */

	    TclFreeIntRep(objPtr);
	    objPtr->typePtr = &levelReferenceType;
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1;
	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
	    level = curLevel - level;
	} else {
	    /*
	     * Don't cache as the object *isn't* a level reference.
	     */

	    level = curLevel - 1;
	    result = 0;
	}
    }

    /*
     * Figure out which frame to use, and return it to the caller.
     */

    if (level == 0) {
	framePtr = NULL;
    } else {
	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		framePtr = framePtr->callerVarPtr) {
	    if (framePtr->level == level) {
		break;
	    }
	}
	if (framePtr == NULL) {
	    goto levelError;
	}
    }
    *framePtrPtr = framePtr;
    return result;

  levelError:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UplevelObjCmd --
 *
 *	This object function is invoked to process the "uplevel" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	See the user documentation.
 *
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr, *framePtr;

    if (objc < 2) {
	uplevelSyntax:
	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Find the level to use for executing the command.
     */







|







773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr, *framePtr;

    if (objc < 2) {
    uplevelSyntax:
	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Find the level to use for executing the command.
     */
766
767
768
769
770
771
772
773
774
775

776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
     */

    if (objc == 1) {
	result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result.  Tcl_EvalObjEx will delete
	 * the object when it decrements its refcount after eval'ing it.
	 */

	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];
	sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);
    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *
 *	Given the name of a procedure, return a pointer to the
 *	record describing the procedure. The procedure will be
 *	looked up using the usual rules: first in the current
 *	namespace and then in the global namespace.
 *
 * Results:
 *	NULL is returned if the name doesn't correspond to any
 *	procedure. Otherwise, the return value is a pointer to
 *	the procedure's record. If the name is found but refers
 *	to an imported command that points to a "real" procedure
 *	defined in another namespace, a pointer to that "real"
 *	procedure's structure is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|

>






<
|
|















|
|
|
|


|
|
<
|
|
|







808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824

825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849

850
851
852
853
854
855
856
857
858
859
     */

    if (objc == 1) {
	result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result.  Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {

	TclFormatToErrorInfo(interp, "\n    (\"uplevel\" body line %d)",
		interp->errorLine);
    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *
 *	Given the name of a procedure, return a pointer to the record
 *	describing the procedure. The procedure will be looked up using the
 *	usual rules: first in the current namespace and then in the global
 *	namespace.
 *
 * Results:
 *	NULL is returned if the name doesn't correspond to any procedure.
 *	Otherwise, the return value is a pointer to the procedure's record. If

 *	the name is found but refers to an imported command that points to a
 *	"real" procedure defined in another namespace, a pointer to that
 *	"real" procedure's structure is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
 *----------------------------------------------------------------------
 *
 * TclIsProc --
 *
 *	Tells whether a command is a Tcl procedure or not.
 *
 * Results:
 *	If the given command is actually a Tcl procedure, the
 *	return value is the address of the record describing
 *	the procedure.  Otherwise the return value is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|







887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
 *----------------------------------------------------------------------
 *
 * TclIsProc --
 *
 *	Tells whether a command is a Tcl procedure or not.
 *
 * Results:
 *	If the given command is actually a Tcl procedure, the return value is
 *	the address of the record describing the procedure. Otherwise the
 *	return value is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

875
876
877
878
879
880
881











































































































































































882
883
884
885
886
887
888
889
890
891
    }
    return (Proc *) 0;
}

/*
 *----------------------------------------------------------------------
 *











































































































































































 * TclObjInterpProc --
 *
 *	When a Tcl procedure gets invoked during bytecode evaluation, this 
 *	object-based routine gets invoked to interpret the procedure.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Depends on the commands in the procedure.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|







916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
    }
    return (Proc *) 0;
}

/*
 *----------------------------------------------------------------------
 *
 * InitCompiledLocals --
 *
 *	This routine is invoked in order to initialize the compiled locals
 *	table for a new call frame.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May invoke various name resolvers in order to determine which
 *	variables are being referenced at runtime.
 *
 *----------------------------------------------------------------------
 */

static void
InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
    ByteCode *codePtr;
    CompiledLocal *localPtr;
    Var *varPtr;
    Namespace *nsPtr;		/* Pointer to current namespace. */
{
    Interp *iPtr = (Interp*) interp;
    int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
    CompiledLocal *firstLocalPtr;

    if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) {
	/*
	 * This is the first run after a recompile, or else the resolver epoch
	 * has changed: update the resolver cache.
	 */

	firstLocalPtr = localPtr;
	for (; localPtr != NULL; localPtr = localPtr->nextPtr) {

	    if (localPtr->resolveInfo) {
		if (localPtr->resolveInfo->deleteProc) {
		    localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
		} else {
		    ckfree((char*)localPtr->resolveInfo);
		}
		localPtr->resolveInfo = NULL;
	    }
	    localPtr->flags &= ~VAR_RESOLVED;

	    if (haveResolvers &&
		    !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
		ResolverScheme *resPtr = iPtr->resolverPtr;
		Tcl_ResolvedVarInfo *vinfo;
		int result;

		if (nsPtr->compiledVarResProc) {
		    result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
			    localPtr->name, localPtr->nameLength,
			    (Tcl_Namespace *) nsPtr, &vinfo);
		} else {
		    result = TCL_CONTINUE;
		}

		while ((result == TCL_CONTINUE) && resPtr) {
		    if (resPtr->compiledVarResProc) {
			result = (*resPtr->compiledVarResProc)(nsPtr->interp,
				localPtr->name, localPtr->nameLength,
				(Tcl_Namespace *) nsPtr, &vinfo);
		    }
		    resPtr = resPtr->nextPtr;
		}
		if (result == TCL_OK) {
		    localPtr->resolveInfo = vinfo;
		    localPtr->flags |= VAR_RESOLVED;
		}
	    }
	}
	localPtr = firstLocalPtr;
	codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS;
    }

    /*
     * Initialize the array of local variables stored in the call frame. Some
     * variables may have special resolution rules. In that case, we call
     * their "resolver" procs to get our hands on the variable, and we make
     * the compiled local a link to the real variable.
     */

    if (haveResolvers) {
	Tcl_ResolvedVarInfo *resVarInfo;
	for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
	    varPtr->value.objPtr = NULL;
	    varPtr->name = localPtr->name; /* will be just '\0' if temp var */
	    varPtr->nsPtr = NULL;
	    varPtr->hPtr = NULL;
	    varPtr->refCount = 0;
	    varPtr->tracePtr = NULL;
	    varPtr->searchPtr = NULL;
	    varPtr->flags = localPtr->flags;

	    /*
	     * Now invoke the resolvers to determine the exact variables that
	     * should be used.
	     */

	    resVarInfo = localPtr->resolveInfo;
	    if (resVarInfo && resVarInfo->fetchProc) {
		Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
			resVarInfo);
		if (resolvedVarPtr) {
		    resolvedVarPtr->refCount++;
		    varPtr->value.linkPtr = resolvedVarPtr;
		    varPtr->flags = VAR_LINK;
		}
	    }
	}
    } else {
	for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
	    varPtr->value.objPtr = NULL;
	    varPtr->name = localPtr->name; /* will be just '\0' if temp var */
	    varPtr->nsPtr = NULL;
	    varPtr->hPtr = NULL;
	    varPtr->refCount = 0;
	    varPtr->tracePtr = NULL;
	    varPtr->searchPtr = NULL;
	    varPtr->flags = localPtr->flags;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitCompiledLocals --
 *
 *	This routine is invoked in order to initialize the compiled locals
 *	table for a new call frame.
 *
 *	DEPRECATED: functionality has been inlined elsewhere; this function
 *	remains to insure binary compatibility with Itcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May invoke various name resolvers in order to determine which
 *	variables are being referenced at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclInitCompiledLocals(interp, framePtr, nsPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
    CallFrame *framePtr;	/* Call frame to initialize. */
    Namespace *nsPtr;		/* Pointer to current namespace. */
{
    Var *varPtr = framePtr->compiledLocals;
    Tcl_Obj *bodyPtr;
    ByteCode *codePtr;
    CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr;

    bodyPtr = framePtr->procPtr->bodyPtr;
    if (bodyPtr->typePtr != &tclByteCodeType) {
	Tcl_Panic("body object for proc attached to frame is not a byte code type");
    }
    codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;

    InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProc --
 *
 *	When a Tcl procedure gets invoked during bytecode evaluation, this
 *	object-based routine gets invoked to interpret the procedure.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Depends on the commands in the procedure.
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964

965
966
967
968
969
970

971
972
973

974
975
976


977
978
979

980
981
982
983
984
985
986
987
988
989
990
991
992

993
994

995
996
997
998
999
1000
1001





1002

1003
1004

1005











1006

1007

1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035

1036


1037

1038




1039








1040

1041





1042



1043
1044
1045
1046
1047
1048

1049
1050
1051
1052
1053

1054
1055
1056
1057
1058
1059
1060
				  * invoked. */
    int objc;			 /* Count of number of arguments to this
				  * procedure. */
    Tcl_Obj *CONST objv[];	 /* Argument value objects. */
{
    register Proc *procPtr = (Proc *) clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame frame;
    register CallFrame *framePtr = &frame;
    register Var *varPtr;
    register CompiledLocal *localPtr;
    char *procName;
    int nameLen, localCt, numArgs, argCt, i, result;

    /*
     * This procedure generates an array "compiledLocals" that holds the
     * storage for local variables. It starts out with stack-allocated space
     * but uses dynamically-allocated storage if needed.
     */

#define NUM_LOCALS 20
    Var localStorage[NUM_LOCALS];
    Var *compiledLocals = localStorage;

    /*
     * Get the procedure's name.
     */

    procName = Tcl_GetStringFromObj(objv[0], &nameLen);

    /*
     * If necessary, compile the procedure's body. The compiler will
     * allocate frame slots for the procedure's non-argument local
     * variables.  Note that compiling the body might increase
     * procPtr->numCompiledLocals if new local variables are found
     * while compiling.
     */

    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
	    "body of proc", procName);

    if (result != TCL_OK) {
	return result;
    }

    /*
     * Create the "compiledLocals" array. Make sure it is large enough to
     * hold all the procedure's compiled local variables, including its
     * formal parameters.
     */

    localCt = procPtr->numCompiledLocals;
    if (localCt > NUM_LOCALS) {
	compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
    }

    /*
     * Set up and push a new call frame for the new procedure invocation.
     * This call frame will execute in the proc's namespace, which might
     * be different than the current namespace. The proc's namespace is
     * that of its command, which can change if the command is renamed
     * from one namespace to another.
     */


    result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
	    (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);

    if (result != TCL_OK) {
	return result;
    }


    framePtr->objc = objc;
    framePtr->objv = objv;  /* ref counts for args are incremented below */


    /*
     * Initialize and resolve compiled variable references.


     */

    framePtr->procPtr = procPtr;

    framePtr->numCompiledLocals = localCt;
    framePtr->compiledLocals = compiledLocals;

    TclInitCompiledLocals(interp, framePtr, nsPtr);

    /*
     * Match and assign the call's actual parameters to the procedure's
     * formal arguments. The formal arguments are described by the first
     * numArgs entries in both the Proc structure's local variable list and
     * the call frame's local variable array.
     */

    numArgs = procPtr->numArgs;

    varPtr = framePtr->compiledLocals;
    localPtr = procPtr->firstLocalPtr;

    argCt = objc;
    for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
	if (!TclIsVarArgument(localPtr)) {
	    Tcl_Panic("TclObjInterpProc: local variable %s is not argument but should be",
		  localPtr->name);
	    return TCL_ERROR;
	}





	if (TclIsVarTemporary(localPtr)) {

	    Tcl_Panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
	    return TCL_ERROR;

	}













	/*

	 * Handle the special case of the last formal being "args".  When
	 * it occurs, assign it a list consisting of all the remaining
	 * actual arguments.
	 */

	if ((i == numArgs) && ((localPtr->name[0] == 'a')
		&& (strcmp(localPtr->name, "args") == 0))) {
	    Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
	    varPtr->value.objPtr = listPtr;
	    Tcl_IncrRefCount(listPtr); /* local var is a reference */
	    TclClearVarUndefined(varPtr);
	    argCt = 0;
	    break;		/* done processing args */
	} else if (argCt > 0) {
	    Tcl_Obj *objPtr = objv[i];
	    varPtr->value.objPtr = objPtr;
	    TclClearVarUndefined(varPtr);
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else if (localPtr->defValuePtr != NULL) {
	    Tcl_Obj *objPtr = localPtr->defValuePtr;
	    varPtr->value.objPtr = objPtr;
	    TclClearVarUndefined(varPtr);
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else {
	    goto incorrectArgs;
	}

	varPtr++;


	localPtr = localPtr->nextPtr;

    }




    if (argCt > 0) {








	Tcl_Obj **desiredObjs, *argObj;







    incorrectArgs:



	/*
	 * Build up desired argument list for Tcl_WrongNumArgs
	 */

	desiredObjs = (Tcl_Obj **)
		ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));

#ifdef AVOID_HACKS_FOR_ITCL
	desiredObjs[0] = objv[0];
#else
	desiredObjs[0] = Tcl_NewListObj(1, objv);
#endif /* AVOID_HACKS_FOR_ITCL */

	localPtr = procPtr->firstLocalPtr;
	for (i=1 ; i<=numArgs ; i++) {
	    TclNewObj(argObj);
	    if (localPtr->defValuePtr != NULL) {
		Tcl_AppendStringsToObj(argObj,
			"?", localPtr->name, "?", (char *) NULL);
	    } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) {







|
<



|
<
<
<
<
<
<
<
<
<
|








|
|
|
<
|









<
<
<
<
<
<
<
<
<
<



|
|
|
|


>
|
|




>



>


|
>
>


|
>



<
<

|
|
|
|



>


>
|
|
<
<
|
|

>
>
>
>
>
|
>
|
<
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>

>
|
<
<


|
|
|
|
|
|
|
<
<
|
|
|
<
<
|
|
|
<
|
<



>
|
>
>
|
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>

>

>
>
>
>
>

>
>
>






>





>







1113
1114
1115
1116
1117
1118
1119
1120

1121
1122
1123
1124









1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136

1137
1138
1139
1140
1141
1142
1143
1144
1145
1146










1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179


1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193


1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204

1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222


1223
1224
1225
1226
1227
1228
1229
1230
1231


1232
1233
1234


1235
1236
1237

1238

1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
				  * invoked. */
    int objc;			 /* Count of number of arguments to this
				  * procedure. */
    Tcl_Obj *CONST objv[];	 /* Argument value objects. */
{
    register Proc *procPtr = (Proc *) clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame *framePtr, **framePtrPtr;

    register Var *varPtr;
    register CompiledLocal *localPtr;
    char *procName;
    int nameLen, localCt, numArgs, argCt, i, imax, result;









    Var *compiledLocals;

    /*
     * Get the procedure's name.
     */

    procName = Tcl_GetStringFromObj(objv[0], &nameLen);

    /*
     * If necessary, compile the procedure's body. The compiler will allocate
     * frame slots for the procedure's non-argument local variables. Note that
     * compiling the body might increase procPtr->numCompiledLocals if new

     * local variables are found while compiling.
     */

    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
	    "body of proc", procName);

    if (result != TCL_OK) {
	return result;
    }












    /*
     * Set up and push a new call frame for the new procedure invocation.
     * This call frame will execute in the proc's namespace, which might be
     * different than the current namespace. The proc's namespace is that of
     * its command, which can change if the command is renamed from one
     * namespace to another.
     */

    framePtrPtr = &framePtr;
    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
	    (Tcl_Namespace *) nsPtr, FRAME_IS_PROC);

    if (result != TCL_OK) {
	return result;
    }


    framePtr->objc = objc;
    framePtr->objv = objv;  /* ref counts for args are incremented below */
    framePtr->procPtr = procPtr;

    /*
     * Create the "compiledLocals" array. Make sure it is large enough to hold
     * all the procedure's compiled local variables, including its formal
     * parameters.
     */

    localCt = procPtr->numCompiledLocals;
    compiledLocals = (Var *) TclStackAlloc(interp, localCt*sizeof(Var));
    framePtr->numCompiledLocals = localCt;
    framePtr->compiledLocals = compiledLocals;



    /*
     * Match and assign the call's actual parameters to the procedure's formal
     * arguments. The formal arguments are described by the first numArgs
     * entries in both the Proc structure's local variable list and the call
     * frame's local variable array.
     */

    numArgs = procPtr->numArgs;
    argCt = objc-1; /* set it to the number of args to the proc */
    varPtr = framePtr->compiledLocals;
    localPtr = procPtr->firstLocalPtr;
    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;


	} else {
	    goto runProc;
	}
    }
    imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
    for (i = 1; i <= imax; i++) {
	/*
	 * "Normal" arguments; last formal is special, depends on it being
	 * 'args'.
	 */


	Tcl_Obj *objPtr = objv[i];

	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);  /* local var is a reference */
	varPtr->name = localPtr->name;
	varPtr->nsPtr = NULL;
	varPtr->hPtr = NULL;
	varPtr->refCount = 0;
	varPtr->tracePtr = NULL;
	varPtr->searchPtr = NULL;
	varPtr->flags = localPtr->flags;
	varPtr++;
	localPtr = localPtr->nextPtr;
    }
    for (; i < numArgs; i++) {
	/*
	 * This loop is entered if argCt < (numArgs-1).  Set default values;
	 * last formal is special.


	 */

	if (localPtr->defValuePtr != NULL) {
	    Tcl_Obj *objPtr = localPtr->defValuePtr;

	    varPtr->value.objPtr = objPtr;
	    Tcl_IncrRefCount(objPtr);  /* local var is a reference */
	    varPtr->name = localPtr->name;
	    varPtr->nsPtr = NULL;


	    varPtr->hPtr = NULL;
	    varPtr->refCount = 0;
	    varPtr->tracePtr = NULL;


	    varPtr->searchPtr = NULL;
	    varPtr->flags = localPtr->flags;
	    varPtr++;

	    localPtr = localPtr->nextPtr;

	} else {
	    goto incorrectArgs;
	}
    }

    /*
     * When we get here, the last formal argument remains to be defined:
     * localPtr and varPtr point to the last argument to be initialized.
     */

    if (localPtr->flags & VAR_IS_ARGS) {
	Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs]));
	varPtr->value.objPtr = listPtr;
	Tcl_IncrRefCount(listPtr); /* local var is a reference */
    } else if (argCt == numArgs) {
	Tcl_Obj *objPtr = objv[numArgs];
	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);  /* local var is a reference */
    } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
	Tcl_Obj *objPtr = localPtr->defValuePtr;
	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);  /* local var is a reference */
    } else {
	Tcl_Obj **desiredObjs, *argObj;
	ByteCode *codePtr;

	/*
	 * Do initialise all compiled locals, to avoid problems at
	 * DeleteLocalVars.
	 */

    incorrectArgs:
	codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr;
	InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);

	/*
	 * Build up desired argument list for Tcl_WrongNumArgs
	 */

	desiredObjs = (Tcl_Obj **)
		ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));

#ifdef AVOID_HACKS_FOR_ITCL
	desiredObjs[0] = objv[0];
#else
	desiredObjs[0] = Tcl_NewListObj(1, objv);
#endif /* AVOID_HACKS_FOR_ITCL */

	localPtr = procPtr->firstLocalPtr;
	for (i=1 ; i<=numArgs ; i++) {
	    TclNewObj(argObj);
	    if (localPtr->defValuePtr != NULL) {
		Tcl_AppendStringsToObj(argObj,
			"?", localPtr->name, "?", (char *) NULL);
	    } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) {
1078
1079
1080
1081
1082
1083
1084























1085
1086
1087
1088
1089
1090
1091
	for (i=0 ; i<=numArgs ; i++) {
	    TclDecrRefCount(desiredObjs[i]);
	}
#endif /* AVOID_HACKS_FOR_ITCL */
	ckfree((char *) desiredObjs);
	goto procDone;
    }
























    /*
     * Invoke the commands in the procedure's body.
     */

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 1) {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
	for (i=0 ; i<=numArgs ; i++) {
	    TclDecrRefCount(desiredObjs[i]);
	}
#endif /* AVOID_HACKS_FOR_ITCL */
	ckfree((char *) desiredObjs);
	goto procDone;
    }

    varPtr->name = localPtr->name;
    varPtr->nsPtr = NULL;
    varPtr->hPtr = NULL;
    varPtr->refCount = 0;
    varPtr->tracePtr = NULL;
    varPtr->searchPtr = NULL;
    varPtr->flags = localPtr->flags;

    localPtr = localPtr->nextPtr;
    varPtr++;

    /*
     * Initialise and resolve the remaining compiledLocals.
     */

  runProc:
    if (localPtr) {
	ByteCode *codePtr = (ByteCode *)
		procPtr->bodyPtr->internalRep.otherValuePtr;

	InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
    }

    /*
     * Invoke the commands in the procedure's body.
     */

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 1) {
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118

1119
1120

1121


1122



1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
    }

    if (result != TCL_OK) {
	result = ProcessProcResultCode(interp, procName, nameLen, result);
    }

    /*
     * Pop and free the call frame for this procedure invocation, then
     * free the compiledLocals array if malloc'ed storage was used.
     */

    procDone:

    Tcl_PopCallFrame(interp);
    if (compiledLocals != localStorage) {

	ckfree((char *) compiledLocals);


    }



    return result;
#undef NUM_LOCALS
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcCompileProc --
 *
 *	Called just before a procedure is executed to compile the
 *	body to byte codes.  If the type of the body is not
 *	"byte code" or if the compile conditions have changed
 *	(namespace context, epoch counters, etc.) then the body
 *	is recompiled.  Otherwise, this procedure does nothing.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May change the internal representation of the body object
 *	to compiled code.
 *
 *----------------------------------------------------------------------
 */

int
TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
    Tcl_Interp *interp;		/* Interpreter containing procedure. */
    Proc *procPtr;		/* Data associated with procedure. */
    Tcl_Obj *bodyPtr;		/* Body of proc. (Usually procPtr->bodyPtr,
 				 * but could be any code fragment compiled
 				 * in the context of this procedure.) */
    Namespace *nsPtr;		/* Namespace containing procedure. */
    CONST char *description;	/* string describing this body of code. */
    CONST char *procName;	/* Name of this procedure. */
{
    Interp *iPtr = (Interp*)interp;
    int result;
    Tcl_CallFrame frame;
    Proc *saveProcPtr;
    ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;

    /*
     * If necessary, compile the procedure's body. The compiler will
     * allocate frame slots for the procedure's non-argument local
     * variables. If the ByteCode already exists, make sure it hasn't been
     * invalidated by someone redefining a core command (this might make the
     * compiled code wrong). Also, if the code was compiled in/for a
     * different interpreter, we recompile it. Note that compiling the body
     * might increase procPtr->numCompiledLocals if new local variables are
     * found while compiling.
     *
     * Precompiled procedure bodies, however, are immutable and therefore
     * they are not recompiled, even if things have changed.
     */

    if (bodyPtr->typePtr == &tclByteCodeType) {
 	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != nsPtr)) {
	    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {







|
|


|
>
|
|
>
|
>
>
|
>
>
>









|
|
<
|
|





|
|









|
|






|




|
|
|
|
|
|
|
|

|
|







1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396

1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
    }

    if (result != TCL_OK) {
	result = ProcessProcResultCode(interp, procName, nameLen, result);
    }

    /*
     * Pop and free the call frame for this procedure invocation, then free
     * the compiledLocals array if malloc'ed storage was used.
     */

  procDone:
    /*
     * Free the stack-allocated compiled locals and CallFrame. It is important
     * to pop the call frame without freeing it first: the compiledLocals
     * cannot be freed before the frame is popped, as the local variables must
     * be deleted. But the compiledLocals must be freed first, as they were
     * allocated later on the stack.
     */

    Tcl_PopCallFrame(interp);	/* pop but do not free */
    TclStackFree(interp);	/* free compiledLocals */
    TclStackFree(interp);	/* free CallFrame */
    return result;
#undef NUM_LOCALS
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcCompileProc --
 *
 *	Called just before a procedure is executed to compile the body to byte
 *	codes. If the type of the body is not "byte code" or if the compile

 *	conditions have changed (namespace context, epoch counters, etc.) then
 *	the body is recompiled.  Otherwise, this function does nothing.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May change the internal representation of the body object to compiled
 *	code.
 *
 *----------------------------------------------------------------------
 */

int
TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
    Tcl_Interp *interp;		/* Interpreter containing procedure. */
    Proc *procPtr;		/* Data associated with procedure. */
    Tcl_Obj *bodyPtr;		/* Body of proc. (Usually procPtr->bodyPtr,
 				 * but could be any code fragment compiled in
 				 * the context of this procedure.) */
    Namespace *nsPtr;		/* Namespace containing procedure. */
    CONST char *description;	/* string describing this body of code. */
    CONST char *procName;	/* Name of this procedure. */
{
    Interp *iPtr = (Interp*)interp;
    int result;
    Tcl_CallFrame *framePtr;
    Proc *saveProcPtr;
    ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;

    /*
     * If necessary, compile the procedure's body. The compiler will allocate
     * frame slots for the procedure's non-argument local variables. If the
     * ByteCode already exists, make sure it hasn't been invalidated by
     * someone redefining a core command (this might make the compiled code
     * wrong). Also, if the code was compiled in/for a different interpreter,
     * we recompile it. Note that compiling the body might increase
     * procPtr->numCompiledLocals if new local variables are found while
     * compiling.
     *
     * Precompiled procedure bodies, however, are immutable and therefore they
     * are not recompiled, even if things have changed.
     */

    if (bodyPtr->typePtr == &tclByteCodeType) {
 	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != nsPtr)) {
	    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203

1204

1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238



1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
	    }
 	}
    }
    if (bodyPtr->typePtr != &tclByteCodeType) {
#ifdef TCL_COMPILE_DEBUG
 	if (tclTraceCompile >= 1) {
 	    /*
 	     * Display a line summarizing the top level command we
 	     * are about to compile.
 	     */

	    Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1);

	    Tcl_IncrRefCount(message);
	    Tcl_AppendStringsToObj(message, description, " \"", NULL);
	    TclAppendLimitedToObj(message, procName, -1, 50, NULL);
 	    fprintf(stdout, "%s\"\n", TclGetString(message));
	    Tcl_DecrRefCount(message);
 	}
#endif

 	/*
 	 * Plug the current procPtr into the interpreter and coerce
 	 * the code body to byte codes.  The interpreter needs to
 	 * know which proc it's compiling so that it can access its
 	 * list of compiled locals.
 	 *
 	 * TRICKY NOTE:  Be careful to push a call frame with the
 	 *   proper namespace context, so that the byte codes are
 	 *   compiled in the appropriate class context.
 	 */

 	saveProcPtr = iPtr->compiledProcPtr;
 	iPtr->compiledProcPtr = procPtr;

 	result = Tcl_PushCallFrame(interp, &frame,
		(Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);

 	if (result == TCL_OK) {
	    result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
	    Tcl_PopCallFrame(interp);
	}

 	iPtr->compiledProcPtr = saveProcPtr;

 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {



		Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
		Tcl_Obj *message =
			Tcl_NewStringObj("\n    (compiling ", -1);
		Tcl_IncrRefCount(message);
		Tcl_AppendStringsToObj(message, description, " \"", NULL);
		TclAppendLimitedToObj(message, procName, -1, 50, NULL);
		Tcl_AppendToObj(message, "\", line ", -1);
		Tcl_AppendObjToObj(message, errorLine);
		Tcl_DecrRefCount(errorLine);
		Tcl_AppendToObj(message, ")", -1);
 		TclAppendObjToErrorInfo(interp, message);
		Tcl_DecrRefCount(message);
	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
	register CompiledLocal *localPtr;

	/*
	 * The resolver epoch has changed, but we only need to invalidate
	 * the resolver cache.
	 */

	for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
		localPtr = localPtr->nextPtr) {
	    localPtr->flags &= ~(VAR_RESOLVED);
	    if (localPtr->resolveInfo) {
		if (localPtr->resolveInfo->deleteProc) {
		    localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
		} else {
		    ckfree((char*)localPtr->resolveInfo);
		}
		localPtr->resolveInfo = NULL;
	    }
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcessProcResultCode --
 *
 *	Procedure called by TclObjInterpProc to process a return code other
 *	than TCL_OK returned by a Tcl procedure.
 *
 * Results:
 *	Depending on the argument return code, the result returned is
 *	another return code and the interpreter's result is set to a value
 *	to supplement that return code.
 *
 * Side effects:
 *	If the result returned is TCL_ERROR, traceback information about
 *	the procedure just executed is appended to the interpreter's
 *	errorInfo field.
 *
 *----------------------------------------------------------------------
 */

static int
ProcessProcResultCode(interp, procName, nameLen, returnCode)
    Tcl_Interp *interp;		/* The interpreter in which the procedure
				 * was called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *message, *errorLine;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
    if (returnCode == TCL_RETURN) {
	return TclUpdateReturnInfo(iPtr);
    } 
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    errorLine = Tcl_NewIntObj(interp->errorLine);
    message = Tcl_NewStringObj("\n    (procedure \"", -1);
    Tcl_IncrRefCount(message);
    TclAppendLimitedToObj(message, procName, nameLen, 60, NULL);
    Tcl_AppendToObj(message, "\" line ", -1);
    Tcl_AppendObjToObj(message, errorLine);
    Tcl_DecrRefCount(errorLine);
    Tcl_AppendToObj(message, ")", -1);
    TclAppendObjToErrorInfo(interp, message);
    Tcl_DecrRefCount(message);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --
 *
 *	This procedure is invoked just before a command procedure is
 *	removed from an interpreter.  Its job is to release all the
 *	resources allocated to the procedure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed, unless the procedure is actively being
 *	executed.  In this case the cleanup is delayed until the
 *	last call to the current procedure completes.
 *
 *----------------------------------------------------------------------
 */

void
TclProcDeleteProc(clientData)
    ClientData clientData;	/* Procedure to be deleted. */







|
|

>

>









|
|
|
<

|
|
|





|
|



|






>
>
>
|
|
|
<
|
<
<
<
|
<
<
<




<
<

|
|


<
<
|
<
<
<
<
<
<
<
<
<









|



|
|
|


|
|
|






|
|






|









|






|
|
<
|
<
<
|
<
<
<








|
|
|





|
|
|







1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480

1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507

1508



1509



1510
1511
1512
1513


1514
1515
1516
1517
1518


1519









1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573

1574


1575



1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
	    }
 	}
    }
    if (bodyPtr->typePtr != &tclByteCodeType) {
#ifdef TCL_COMPILE_DEBUG
 	if (tclTraceCompile >= 1) {
 	    /*
 	     * Display a line summarizing the top level command we are about
 	     * to compile.
 	     */

	    Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1);

	    Tcl_IncrRefCount(message);
	    Tcl_AppendStringsToObj(message, description, " \"", NULL);
	    TclAppendLimitedToObj(message, procName, -1, 50, NULL);
 	    fprintf(stdout, "%s\"\n", TclGetString(message));
	    Tcl_DecrRefCount(message);
 	}
#endif

 	/*
 	 * Plug the current procPtr into the interpreter and coerce the code
 	 * body to byte codes. The interpreter needs to know which proc it's
 	 * compiling so that it can access its list of compiled locals.

 	 *
 	 * TRICKY NOTE: Be careful to push a call frame with the proper
 	 *   namespace context, so that the byte codes are compiled in the
 	 *   appropriate class context.
 	 */

 	saveProcPtr = iPtr->compiledProcPtr;
 	iPtr->compiledProcPtr = procPtr;

 	result = TclPushStackFrame(interp, &framePtr,
		(Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0);

 	if (result == TCL_OK) {
	    result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
	    TclPopStackFrame(interp);
	}

 	iPtr->compiledProcPtr = saveProcPtr;

 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {
		int length = strlen(procName);
		int limit = 50;
		int overflow = (length > limit);

		TclFormatToErrorInfo(interp,
			"\n    (compiling %s \"%.*s%s\", line %d)",

			description, (overflow ? limit : length), procName,



			(overflow ? "..." : ""), interp->errorLine);



	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {


	/*
	 * The resolver epoch has changed, but we only need to invalidate the
	 * resolver cache.
	 */



	codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS;









    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcessProcResultCode --
 *
 *	Function called by TclObjInterpProc to process a return code other
 *	than TCL_OK returned by a Tcl procedure.
 *
 * Results:
 *	Depending on the argument return code, the result returned is another
 *	return code and the interpreter's result is set to a value to
 *	supplement that return code.
 *
 * Side effects:
 *	If the result returned is TCL_ERROR, traceback information about the
 *	procedure just executed is appended to the interpreter's errorInfo
 *	field.
 *
 *----------------------------------------------------------------------
 */

static int
ProcessProcResultCode(interp, procName, nameLen, returnCode)
    Tcl_Interp *interp;		/* The interpreter in which the procedure was
				 * called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 60;

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
    if (returnCode == TCL_RETURN) {
	return TclUpdateReturnInfo(iPtr);
    }
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((returnCode == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
    }
    overflow = (nameLen > limit);
    TclFormatToErrorInfo(interp, "\n    (procedure \"%.*s%s\" line %d)",

	    (overflow ? limit : nameLen), procName,


	    (overflow ? "..." : ""), interp->errorLine);



    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --
 *
 *	This function is invoked just before a command procedure is removed
 *	from an interpreter. Its job is to release all the resources allocated
 *	to the procedure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed, unless the procedure is actively being executed.
 *	In this case the cleanup is delayed until the last call to the current
 *	procedure completes.
 *
 *----------------------------------------------------------------------
 */

void
TclProcDeleteProc(clientData)
    ClientData clientData;	/* Procedure to be deleted. */
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcCleanupProc --
 *
 *	This procedure does all the real work of freeing up a Proc
 *	structure.  It's called only when the structure's reference
 *	count becomes zero.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed.
 *







|
|
<







1609
1610
1611
1612
1613
1614
1615
1616
1617

1618
1619
1620
1621
1622
1623
1624
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcCleanupProc --
 *
 *	This function does all the real work of freeing up a Proc structure.
 *	It's called only when the structure's reference count becomes zero.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed.
 *
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453

1454


1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
}

/*
 *----------------------------------------------------------------------
 *
 * TclUpdateReturnInfo --
 *
 *	This procedure is called when procedures return, and at other
 *	points where the TCL_RETURN code is used.  It examines the
 *	returnLevel and returnCode to determine the real return status.
 *
 * Results:
 *	The return value is the true completion code to use for
 *	the procedure or script, instead of TCL_RETURN.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclUpdateReturnInfo(iPtr)
    Interp *iPtr;		/* Interpreter for which TCL_RETURN
				 * exception is being processed. */
{
    int code = TCL_RETURN;

    iPtr->returnLevel--;
    if (iPtr->returnLevel < 0) {
	Tcl_Panic("TclUpdateReturnInfo: negative return level");
    }
    if (iPtr->returnLevel == 0) {

	/* Now we've reached the level to return the requested -code */


	return iPtr->returnCode;
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetObjInterpProc --
 *
 *	Returns a pointer to the TclObjInterpProc procedure; this is
 *	different from the value obtained from the TclObjInterpProc
 *	reference on systems like Windows where import and export
 *	versions of a procedure exported by a DLL exist.
 *
 * Results:
 *	Returns the internal address of the TclObjInterpProc procedure.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclObjCmdProcType
TclGetObjInterpProc()
{
    return (TclObjCmdProcType) TclObjInterpProc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNewProcBodyObj --
 *
 *	Creates a new object, of type "procbody", whose internal
 *	representation is the given Proc struct.  The newly created
 *	object's reference count is 0.
 *
 * Results:
 *	Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
 *
 * Side effects:
 *	The reference count in the ByteCode attached to the Proc is
 *	bumped up by one, since the internal rep stores a pointer to
 *	it.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclNewProcBodyObj(procPtr)
    Proc *procPtr;		/* the Proc struct to store as the internal







|
|
|


|
|









|
|








>
|
>
>
|









|
|
|
|


|



















|
|





|
|
<







1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741

1742
1743
1744
1745
1746
1747
1748
}

/*
 *----------------------------------------------------------------------
 *
 * TclUpdateReturnInfo --
 *
 *	This function is called when procedures return, and at other points
 *	where the TCL_RETURN code is used.  It examines the returnLevel and
 *	returnCode to determine the real return status.
 *
 * Results:
 *	The return value is the true completion code to use for the procedure
 *	or script, instead of TCL_RETURN.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclUpdateReturnInfo(iPtr)
    Interp *iPtr;		/* Interpreter for which TCL_RETURN exception
				 * is being processed. */
{
    int code = TCL_RETURN;

    iPtr->returnLevel--;
    if (iPtr->returnLevel < 0) {
	Tcl_Panic("TclUpdateReturnInfo: negative return level");
    }
    if (iPtr->returnLevel == 0) {
	/*
	 * Now we've reached the level to return the requested -code.
	 */

	code = iPtr->returnCode;
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetObjInterpProc --
 *
 *	Returns a pointer to the TclObjInterpProc function; this is different
 *	from the value obtained from the TclObjInterpProc reference on systems
 *	like Windows where import and export versions of a function exported
 *	by a DLL exist.
 *
 * Results:
 *	Returns the internal address of the TclObjInterpProc function.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclObjCmdProcType
TclGetObjInterpProc()
{
    return (TclObjCmdProcType) TclObjInterpProc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNewProcBodyObj --
 *
 *	Creates a new object, of type "procbody", whose internal
 *	representation is the given Proc struct.  The newly created object's
 *	reference count is 0.
 *
 * Results:
 *	Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
 *
 * Side effects:
 *	The reference count in the ByteCode attached to the Proc is bumped up
 *	by one, since the internal rep stores a pointer to it.

 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclNewProcBodyObj(procPtr)
    Proc *procPtr;		/* the Proc struct to store as the internal
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyDup --
 *
 *	Tcl_ObjType's Dup function for the proc body object.
 *	Bumps the reference count on the Proc stored in the internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
 *







|
|
<







1767
1768
1769
1770
1771
1772
1773
1774
1775

1776
1777
1778
1779
1780
1781
1782
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyDup --
 *
 *	Tcl_ObjType's Dup function for the proc body object.  Bumps the
 *	reference count on the Proc stored in the internal representation.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
 *
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629








}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyFree --
 *
 *	Tcl_ObjType's Free function for the proc body object.  The
 *	reference count on its Proc struct is decreased by 1; if the
 *	count reaches 0, the proc is freed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the reference count on the Proc struct reaches 0, the
 *	struct is freed.
 *
 *----------------------------------------------------------------------
 */

static void
ProcBodyFree(objPtr)
    Tcl_Obj *objPtr;		/* the object to clean up */
{
    Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileNoOp --
 *
 *	Procedure called to compile no-op's
 *
 * Results:
 *	The return value is TCL_OK, indicating successful compilation.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute a no-op at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
TclCompileNoOp(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int i;
    int savedStackDepth = envPtr->currStackDepth;

    tokenPtr = parsePtr->tokenPtr;
    for(i = 1; i < parsePtr->numWords; i++) {
	tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
	envPtr->currStackDepth = savedStackDepth;

	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 
	    TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
		    envPtr);
	    TclEmitOpcode(INST_POP, envPtr);
	} 
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
    return TCL_OK;
}















|
|
|





|
|




















|













|
|











|



|


|


>
>
>
>
>
>
>
>
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyFree --
 *
 *	Tcl_ObjType's Free function for the proc body object. The reference
 *	count on its Proc struct is decreased by 1; if the count reaches 0,
 *	the proc is freed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the reference count on the Proc struct reaches 0, the struct is
 *	freed.
 *
 *----------------------------------------------------------------------
 */

static void
ProcBodyFree(objPtr)
    Tcl_Obj *objPtr;		/* the object to clean up */
{
    Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileNoOp --
 *
 *	Function called to compile no-op's
 *
 * Results:
 *	The return value is TCL_OK, indicating successful compilation.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute a no-op at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
TclCompileNoOp(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int i;
    int savedStackDepth = envPtr->currStackDepth;

    tokenPtr = parsePtr->tokenPtr;
    for(i = 1; i < parsePtr->numWords; i++) {
	tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
	envPtr->currStackDepth = savedStackDepth;

	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
		    envPtr);
	    TclEmitOpcode(INST_POP, envPtr);
	}
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclRegexp.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
/* 
 * tclRegexp.c --
 *
 *	This file contains the public interfaces to the Tcl regular
 *	expression mechanism.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclRegexp.c,v 1.17 2004/09/29 22:23:25 dkf Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 *----------------------------------------------------------------------
 * The routines in this file use Henry Spencer's regular expression
 * package contained in the following additional source files:
 *
 *	regc_color.c	regc_cvec.c	regc_lex.c
 *	regc_nfa.c	regcomp.c	regcustom.h
 *	rege_dfa.c	regerror.c	regerrs.h
 *	regex.h		regexec.c	regfree.c
 *	regfronts.c	regguts.h
 *
 * Copyright (c) 1998 Henry Spencer.  All rights reserved.
 * 
 * Development of this software was funded, in part, by Cray Research Inc.,
 * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
 * Corporation, none of whom are responsible for the results.  The author
 * thanks all of them. 
 * 
 * Redistribution and use in source and binary forms -- with or without
 * modification -- are permitted for any purpose, provided that
 * redistributions in source form retain this entire copyright notice and
 * indicate the origin and nature of any modifications.
 * 
 * I'd appreciate being given credit for this package in the documentation
 * of software which uses it, but that is not a requirement.
 * 
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
 * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL
 * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|


|
|




|
|

|







|
|








|


|
|
|




|
|
|
|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
/*
 * tclRegexp.c --
 *
 *	This file contains the public interfaces to the Tcl regular expression
 *	mechanism.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclRegexp.c,v 1.17.2.2 2005/08/02 18:16:07 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

/*
 *----------------------------------------------------------------------
 * The routines in this file use Henry Spencer's regular expression package
 * contained in the following additional source files:
 *
 *	regc_color.c	regc_cvec.c	regc_lex.c
 *	regc_nfa.c	regcomp.c	regcustom.h
 *	rege_dfa.c	regerror.c	regerrs.h
 *	regex.h		regexec.c	regfree.c
 *	regfronts.c	regguts.h
 *
 * Copyright (c) 1998 Henry Spencer.  All rights reserved.
 *
 * Development of this software was funded, in part, by Cray Research Inc.,
 * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
 * Corporation, none of whom are responsible for the results. The author
 * thanks all of them.
 *
 * Redistribution and use in source and binary forms -- with or without
 * modification -- are permitted for any purpose, provided that
 * redistributions in source form retain this entire copyright notice and
 * indicate the origin and nature of any modifications.
 *
 * I'd appreciate being given credit for this package in the documentation of
 * software which uses it, but that is not a requirement.
 *
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
 * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
 * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
 * regular expressions.
 */

#define NUM_REGEXPS 30

typedef struct ThreadSpecificData {
    int initialized;		/* Set to 1 when the module is initialized. */
    char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled
				 * regular expression patterns.	 NULL
				 * means that this slot isn't used.
				 * Malloc-ed. */
    int patLengths[NUM_REGEXPS];/* Number of non-null characters in
				 * corresponding entry in patterns.
				 * -1 means entry isn't used. */
    struct TclRegexp *regexps[NUM_REGEXPS];
				/* Compiled forms of above strings.  Also
				 * malloc-ed, or NULL if not in use yet. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Declarations for functions used only in this file.







|
|
<
|

|
|

|







64
65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
81
82
83
84
85
 * regular expressions.
 */

#define NUM_REGEXPS 30

typedef struct ThreadSpecificData {
    int initialized;		/* Set to 1 when the module is initialized. */
    char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
				 * expression patterns. NULL means that this

				 * slot isn't used. Malloc-ed. */
    int patLengths[NUM_REGEXPS];/* Number of non-null characters in
				 * corresponding entry in patterns. -1 means
				 * entry isn't used. */
    struct TclRegexp *regexps[NUM_REGEXPS];
				/* Compiled forms of above strings. Also
				 * malloc-ed, or NULL if not in use yet. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Declarations for functions used only in this file.
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
static int		RegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_RegExp re, CONST Tcl_UniChar *uniString,
			    int numChars, int nmatches, int flags));
static int		SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * The regular expression Tcl object type.  This serves as a cache
 * of the compiled form of the regular expression.
 */

Tcl_ObjType tclRegexpType = {
    "regexp",				/* name */
    FreeRegexpInternalRep,		/* freeIntRepProc */
    DupRegexpInternalRep,		/* dupIntRepProc */
    NULL,				/* updateStringProc */
    SetRegexpFromAny			/* setFromAnyProc */
};


/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpCompile --
 *
 *	Compile a regular expression into a form suitable for fast
 *	matching.  This procedure is DEPRECATED in favor of the
 *	object version of the command.
 *
 * Results:
 *	The return value is a pointer to the compiled form of string,
 *	suitable for passing to Tcl_RegExpExec.  This compiled form
 *	is only valid up until the next call to this procedure, so
 *	don't keep these around for a long time!  If an error occurred
 *	while compiling the pattern, then NULL is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	Updates the cache of compiled regexps.
 *
 *----------------------------------------------------------------------
 */

Tcl_RegExp
Tcl_RegExpCompile(interp, string)
    Tcl_Interp *interp;		/* For use in error reporting and
				 * to access the interp regexp cache. */
    CONST char *string;		/* String for which to produce
				 * compiled regular expression. */
{
    return (Tcl_RegExp) CompileRegexp(interp, string, (int) strlen(string),
	    REG_ADVANCED);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpExec --
 *
 *	Execute the regular expression matcher using a compiled form
 *	of a regular expression and save information about any match
 *	that is found.
 *
 * Results:
 *	If an error occurs during the matching operation then -1
 *	is returned and the interp's result contains an error message.
 *	Otherwise the return value is 1 if a matching range is
 *	found and 0 if there is no matching range.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpExec(interp, re, string, start)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    Tcl_RegExp re;		/* Compiled regular expression;  must have
				 * been returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    CONST char *string;		/* String against which to match re. */
    CONST char *start;		/* If string is part of a larger string,
				 * this identifies beginning of larger
				 * string, so that "^" won't match. */
{
    int flags, result, numChars;
    TclRegexp *regexp = (TclRegexp *)re;
    Tcl_DString ds;
    CONST Tcl_UniChar *ustr;

    /*
     * If the starting point is offset from the beginning of the buffer,
     * then we need to tell the regexp engine not to match "^".
     */

    if (string > start) {
	flags = REG_NOTBOL;
    } else {
	flags = 0;
    }

    /*
     * Remember the string for use by Tcl_RegExpRange().
     */

    regexp->string = string;
    regexp->objPtr = NULL;

    /*
     * Convert the string to Unicode and perform the match.
     */

    Tcl_DStringInit(&ds);
    ustr = Tcl_UtfToUniCharDString(string, -1, &ds);
    numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
    result = RegExpExecUniChar(interp, re, ustr, numChars,
	    -1 /* nmatches */, flags);
    Tcl_DStringFree(&ds);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_RegExpRange --
 *
 *	Returns pointers describing the range of a regular expression match,
 *	or one of the subranges within the match.
 *
 * Results:
 *	The variables at *startPtr and *endPtr are modified to hold the
 *	addresses of the endpoints of the range given by index.  If the
 *	specified range doesn't exist then NULLs are returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_RegExpRange(re, index, startPtr, endPtr)
    Tcl_RegExp re;		/* Compiled regular expression that has
				 * been passed to Tcl_RegExpExec. */
    int index;			/* 0 means give the range of the entire
				 * match, > 0 means give the range of
				 * a matching subrange. */
    CONST char **startPtr;	/* Store address of first character in
				 * (sub-) range here. */
    CONST char **endPtr;	/* Store address of character just after last
				 * in (sub-) range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    CONST char *string;

    if ((size_t) index > regexpPtr->re.re_nsub) {
	*startPtr = *endPtr = NULL;
    } else if (regexpPtr->matches[index].rm_so < 0) {







|
|









<






|
|
|


|
|
|
<
|
|








|
|
|
|
|

|








|
|
<


|
|
|
|








|

|
|

|
|
|
|







|
|


|









|







|

|
|















|










|
|
|
|
|

|

|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

113
114
115
116
117
118
119
120
121
122
123
124
125
126

127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
static int		RegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_RegExp re, CONST Tcl_UniChar *uniString,
			    int numChars, int nmatches, int flags));
static int		SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * The regular expression Tcl object type. This serves as a cache of the
 * compiled form of the regular expression.
 */

Tcl_ObjType tclRegexpType = {
    "regexp",				/* name */
    FreeRegexpInternalRep,		/* freeIntRepProc */
    DupRegexpInternalRep,		/* dupIntRepProc */
    NULL,				/* updateStringProc */
    SetRegexpFromAny			/* setFromAnyProc */
};


/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpCompile --
 *
 *	Compile a regular expression into a form suitable for fast matching.
 *	This function is DEPRECATED in favor of the object version of the
 *	command.
 *
 * Results:
 *	The return value is a pointer to the compiled form of string, suitable
 *	for passing to Tcl_RegExpExec. This compiled form is only valid up
 *	until the next call to this function, so don't keep these around for a

 *	long time! If an error occurred while compiling the pattern, then NULL
 *	is returned and an error message is left in the interp's result.
 *
 * Side effects:
 *	Updates the cache of compiled regexps.
 *
 *----------------------------------------------------------------------
 */

Tcl_RegExp
Tcl_RegExpCompile(interp, pattern)
    Tcl_Interp *interp;		/* For use in error reporting and to access
				 * the interp regexp cache. */
    CONST char *pattern;	/* String for which to produce compiled
				 * regular expression. */
{
    return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern),
	    REG_ADVANCED);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpExec --
 *
 *	Execute the regular expression matcher using a compiled form of a
 *	regular expression and save information about any match that is found.

 *
 * Results:
 *	If an error occurs during the matching operation then -1 is returned
 *	and the interp's result contains an error message. Otherwise the
 *	return value is 1 if a matching range is found and 0 if there is no
 *	matching range.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpExec(interp, re, text, start)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    Tcl_RegExp re;		/* Compiled regular expression; must have been
				 * returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    CONST char *text;		/* Text against which to match re. */
    CONST char *start;		/* If text is part of a larger string, this
				 * identifies beginning of larger string, so
				 * that "^" won't match. */
{
    int flags, result, numChars;
    TclRegexp *regexp = (TclRegexp *)re;
    Tcl_DString ds;
    CONST Tcl_UniChar *ustr;

    /*
     * If the starting point is offset from the beginning of the buffer, then
     * we need to tell the regexp engine not to match "^".
     */

    if (text > start) {
	flags = REG_NOTBOL;
    } else {
	flags = 0;
    }

    /*
     * Remember the string for use by Tcl_RegExpRange().
     */

    regexp->string = text;
    regexp->objPtr = NULL;

    /*
     * Convert the string to Unicode and perform the match.
     */

    Tcl_DStringInit(&ds);
    ustr = Tcl_UtfToUniCharDString(text, -1, &ds);
    numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
    result = RegExpExecUniChar(interp, re, ustr, numChars, -1 /* nmatches */,
	    flags);
    Tcl_DStringFree(&ds);

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_RegExpRange --
 *
 *	Returns pointers describing the range of a regular expression match,
 *	or one of the subranges within the match.
 *
 * Results:
 *	The variables at *startPtr and *endPtr are modified to hold the
 *	addresses of the endpoints of the range given by index. If the
 *	specified range doesn't exist then NULLs are returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_RegExpRange(re, index, startPtr, endPtr)
    Tcl_RegExp re;		/* Compiled regular expression that has been
				 * passed to Tcl_RegExpExec. */
    int index;			/* 0 means give the range of the entire match,
				 * > 0 means give the range of a matching
				 * subrange. */
    CONST char **startPtr;	/* Store address of first character in
				 * (sub-)range here. */
    CONST char **endPtr;	/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    CONST char *string;

    if ((size_t) index > regexpPtr->re.re_nsub) {
	*startPtr = *endPtr = NULL;
    } else if (regexpPtr->matches[index].rm_so < 0) {
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306

/*
 *---------------------------------------------------------------------------
 *
 * RegExpExecUniChar --
 *
 *	Execute the regular expression matcher using a compiled form of a
 *	regular expression and save information about any match that is
 *	found.
 *
 * Results:
 *	If an error occurs during the matching operation then -1 is
 *	returned and an error message is left in interp's result.
 *	Otherwise the return value is 1 if a matching range was found or
 *	0 if there was no matching range.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    Tcl_RegExp re;		/* Compiled regular expression; returned by
				 * a previous call to Tcl_GetRegExpFromObj */
    CONST Tcl_UniChar *wString;	/* String against which to match re. */
    int numChars;		/* Length of Tcl_UniChar string (must
				 * be >= 0). */
    int nmatches;		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are
				 * of interest.  -1 means "don't know". */
    int flags;			/* Regular expression flags. */
{
    int status;
    TclRegexp *regexpPtr = (TclRegexp *) re;
    size_t last = regexpPtr->re.re_nsub + 1;
    size_t nm = last;








|
<


|
|
|
|










|
|

|
|

|
|







263
264
265
266
267
268
269
270

271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

/*
 *---------------------------------------------------------------------------
 *
 * RegExpExecUniChar --
 *
 *	Execute the regular expression matcher using a compiled form of a
 *	regular expression and save information about any match that is found.

 *
 * Results:
 *	If an error occurs during the matching operation then -1 is returned
 *	and an error message is left in interp's result. Otherwise the return
 *	value is 1 if a matching range was found or 0 if there was no matching
 *	range.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    Tcl_RegExp re;		/* Compiled regular expression; returned by a
				 * previous call to Tcl_GetRegExpFromObj */
    CONST Tcl_UniChar *wString;	/* String against which to match re. */
    int numChars;		/* Length of Tcl_UniChar string (must be
				 * >=0). */
    int nmatches;		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means "don't know". */
    int flags;			/* Regular expression flags. */
{
    int status;
    TclRegexp *regexpPtr = (TclRegexp *) re;
    size_t last = regexpPtr->re.re_nsub + 1;
    size_t nm = last;

335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
 *
 *	Returns pointers describing the range of a regular expression match,
 *	or one of the subranges within the match, or the hypothetical range
 *	represented by the rm_extend field of the rm_detail_t.
 *
 * Results:
 *	The variables at *startPtr and *endPtr are modified to hold the
 *	offsets of the endpoints of the range given by index.  If the
 *	specified range doesn't exist then -1s are supplied.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclRegExpRangeUniChar(re, index, startPtr, endPtr)
    Tcl_RegExp re;		/* Compiled regular expression that has
				 * been passed to Tcl_RegExpExec. */
    int index;			/* 0 means give the range of the entire
				 * match, > 0 means give the range of
				 * a matching subrange, -1 means the
				 * range of the rm_extend field. */
    int *startPtr;		/* Store address of first character in
				 * (sub-) range here. */
    int *endPtr;		/* Store address of character just after last
				 * in (sub-) range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;

    if ((regexpPtr->flags&REG_EXPECT) && index == -1) {
	*startPtr = regexpPtr->details.rm_extend.rm_so;
	*endPtr = regexpPtr->details.rm_extend.rm_eo;
    } else if ((size_t) index > regexpPtr->re.re_nsub) {







|
|









|
|
|
|
|
|

|

|







330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
 *
 *	Returns pointers describing the range of a regular expression match,
 *	or one of the subranges within the match, or the hypothetical range
 *	represented by the rm_extend field of the rm_detail_t.
 *
 * Results:
 *	The variables at *startPtr and *endPtr are modified to hold the
 *	offsets of the endpoints of the range given by index. If the specified
 *	range doesn't exist then -1s are supplied.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclRegExpRangeUniChar(re, index, startPtr, endPtr)
    Tcl_RegExp re;		/* Compiled regular expression that has been
				 * passed to Tcl_RegExpExec. */
    int index;			/* 0 means give the range of the entire match,
				 * > 0 means give the range of a matching
				 * subrange, -1 means the range of the
				 * rm_extend field. */
    int *startPtr;		/* Store address of first character in
				 * (sub-)range here. */
    int *endPtr;		/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;

    if ((regexpPtr->flags&REG_EXPECT) && index == -1) {
	*startPtr = regexpPtr->details.rm_extend.rm_so;
	*endPtr = regexpPtr->details.rm_extend.rm_eo;
    } else if ((size_t) index > regexpPtr->re.re_nsub) {
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpMatch --
 *
 *	See if a string matches a regular expression.
 *
 * Results:
 *	If an error occurs during the matching operation then -1
 *	is returned and the interp's result contains an error message.
 *	Otherwise the return value is 1 if "string" matches "pattern"
 *	and 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpMatch(interp, string, pattern)
    Tcl_Interp *interp;		/* Used for error reporting. May be NULL. */
    CONST char *string;		/* String. */
    CONST char *pattern;	/* Regular expression to match against
				 * string. */
{
    Tcl_RegExp re;

    re = Tcl_RegExpCompile(interp, pattern);
    if (re == NULL) {
	return -1;
    }
    return Tcl_RegExpExec(interp, re, string, string);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpExecObj --
 *
 *	Execute a precompiled regexp against the given object.
 *
 * Results:
 *	If an error occurs during the matching operation then -1
 *	is returned and the interp's result contains an error message.
 *	Otherwise the return value is 1 if "string" matches "pattern"
 *	and 0 otherwise.
 *
 * Side effects:
 *	Converts the object to a Unicode object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpExecObj(interp, re, objPtr, offset, nmatches, flags)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    Tcl_RegExp re;		/* Compiled regular expression;  must have
				 * been returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    Tcl_Obj *objPtr;		/* String against which to match re. */
    int offset;			/* Character index that marks where matching
				 * should begin. */
    int nmatches;		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are
				 * of interest.  -1 means all of them. */
    int flags;			/* Regular expression execution flags. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    Tcl_UniChar *udata;
    int length;

    /*
     * Save the target object so we can extract strings from it later.
     */

    regexpPtr->string = NULL;
    regexpPtr->objPtr = objPtr;

    udata = Tcl_GetUnicodeFromObj(objPtr, &length);

    if (offset > length) {
	offset = length;
    }
    udata += offset;
    length -= offset;
    
    return RegExpExecUniChar(interp, re, udata, length, nmatches, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpMatchObj --
 *
 *	See if an object matches a regular expression.
 *
 * Results:
 *	If an error occurs during the matching operation then -1
 *	is returned and the interp's result contains an error message.
 *	Otherwise the return value is 1 if "string" matches "pattern"
 *	and 0 otherwise.
 *
 * Side effects:
 *	Changes the internal rep of the pattern and string objects.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpMatchObj(interp, stringObj, patternObj)
    Tcl_Interp *interp;		/* Used for error reporting. May be NULL. */
    Tcl_Obj *stringObj;		/* Object containing the String to search. */
    Tcl_Obj *patternObj;	/* Regular expression to match against
				 * string. */
{
    Tcl_RegExp re;

    re = Tcl_GetRegExpFromObj(interp, patternObj,
	    TCL_REG_ADVANCED | TCL_REG_NOSUB);
    if (re == NULL) {
	return -1;
    }
    return Tcl_RegExpExecObj(interp, re, stringObj, 0 /* offset */,
	    0 /* nmatches */, 0 /* flags */);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpGetInfo --







|
|
|
<








|

|
|
<







|










|
|
|
<








|

|
|

|



|
|











|

|






|











|
|
|
<








|

|










|







374
375
376
377
378
379
380
381
382
383

384
385
386
387
388
389
390
391
392
393
394
395

396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470

471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpMatch --
 *
 *	See if a string matches a regular expression.
 *
 * Results:
 *	If an error occurs during the matching operation then -1 is returned
 *	and the interp's result contains an error message. Otherwise the
 *	return value is 1 if "text" matches "pattern" and 0 otherwise.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpMatch(interp, text, pattern)
    Tcl_Interp *interp;		/* Used for error reporting. May be NULL. */
    CONST char *text;		/* Text to search for pattern matches. */
    CONST char *pattern;	/* Regular expression to match against text. */

{
    Tcl_RegExp re;

    re = Tcl_RegExpCompile(interp, pattern);
    if (re == NULL) {
	return -1;
    }
    return Tcl_RegExpExec(interp, re, text, text);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpExecObj --
 *
 *	Execute a precompiled regexp against the given object.
 *
 * Results:
 *	If an error occurs during the matching operation then -1 is returned
 *	and the interp's result contains an error message. Otherwise the
 *	return value is 1 if "string" matches "pattern" and 0 otherwise.

 *
 * Side effects:
 *	Converts the object to a Unicode object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpExecObj(interp, re, textObj, offset, nmatches, flags)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    Tcl_RegExp re;		/* Compiled regular expression; must have been
				 * returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    Tcl_Obj *textObj;		/* Text against which to match re. */
    int offset;			/* Character index that marks where matching
				 * should begin. */
    int nmatches;		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means all of them. */
    int flags;			/* Regular expression execution flags. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    Tcl_UniChar *udata;
    int length;

    /*
     * Save the target object so we can extract strings from it later.
     */

    regexpPtr->string = NULL;
    regexpPtr->objPtr = textObj;

    udata = Tcl_GetUnicodeFromObj(textObj, &length);

    if (offset > length) {
	offset = length;
    }
    udata += offset;
    length -= offset;

    return RegExpExecUniChar(interp, re, udata, length, nmatches, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpMatchObj --
 *
 *	See if an object matches a regular expression.
 *
 * Results:
 *	If an error occurs during the matching operation then -1 is returned
 *	and the interp's result contains an error message. Otherwise the
 *	return value is 1 if "text" matches "pattern" and 0 otherwise.

 *
 * Side effects:
 *	Changes the internal rep of the pattern and string objects.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpMatchObj(interp, textObj, patternObj)
    Tcl_Interp *interp;		/* Used for error reporting. May be NULL. */
    Tcl_Obj *textObj;		/* Object containing the String to search. */
    Tcl_Obj *patternObj;	/* Regular expression to match against
				 * string. */
{
    Tcl_RegExp re;

    re = Tcl_GetRegExpFromObj(interp, patternObj,
	    TCL_REG_ADVANCED | TCL_REG_NOSUB);
    if (re == NULL) {
	return -1;
    }
    return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
	    0 /* nmatches */, 0 /* flags */);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpGetInfo --
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
 *
 *----------------------------------------------------------------------
 */

void
Tcl_RegExpGetInfo(regexp, infoPtr)
    Tcl_RegExp regexp;		/* Pattern from which to get subexpressions. */
    Tcl_RegExpInfo *infoPtr;	/* Match information is stored here.  */
{
    TclRegexp *regexpPtr = (TclRegexp *) regexp;

    infoPtr->nsubs = regexpPtr->re.re_nsub;
    infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches;
    infoPtr->extendStart = regexpPtr->details.rm_extend.rm_so;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetRegExpFromObj --
 *
 *	Compile a regular expression into a form suitable for fast
 *	matching.  This procedure caches the result in a Tcl_Obj.
 *
 * Results:
 *	The return value is a pointer to the compiled form of string,
 *	suitable for passing to Tcl_RegExpExec.  If an error occurred
 *	while compiling the pattern, then NULL is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	Updates the native rep of the Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

Tcl_RegExp
Tcl_GetRegExpFromObj(interp, objPtr, flags)
    Tcl_Interp *interp;		/* For use in error reporting, and to access
				 * the interp regexp cache. */
    Tcl_Obj *objPtr;		/* Object whose string rep contains regular
				 * expression pattern.  Internal rep will be
				 * changed to compiled form of this regular
				 * expression. */
    int flags;			/* Regular expression compilation flags. */
{
    int length;
    TclRegexp *regexpPtr;
    char *pattern;

    /*
     * This is OK because we only actually interpret this value
     * properly as a TclRegexp* when the type is tclRegexpType.
     */

    regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;

    if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
	pattern = Tcl_GetStringFromObj(objPtr, &length);

	regexpPtr = CompileRegexp(interp, pattern, length, flags);
	if (regexpPtr == NULL) {
	    return NULL;
	}

	/*
	 * Add a reference to the regexp so it will persist even if it is
	 * pushed out of the current thread's regexp cache.  This reference
	 * will be removed when the object's internal rep is freed.
	 */

	regexpPtr->refCount++;

	/*
	 * Free the old representation and set our type.







|













|
|


|
|
|
|












|









|
|

>












|







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
 *
 *----------------------------------------------------------------------
 */

void
Tcl_RegExpGetInfo(regexp, infoPtr)
    Tcl_RegExp regexp;		/* Pattern from which to get subexpressions. */
    Tcl_RegExpInfo *infoPtr;	/* Match information is stored here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) regexp;

    infoPtr->nsubs = regexpPtr->re.re_nsub;
    infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches;
    infoPtr->extendStart = regexpPtr->details.rm_extend.rm_so;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetRegExpFromObj --
 *
 *	Compile a regular expression into a form suitable for fast matching.
 *	This function caches the result in a Tcl_Obj.
 *
 * Results:
 *	The return value is a pointer to the compiled form of string, suitable
 *	for passing to Tcl_RegExpExec. If an error occurred while compiling
 *	the pattern, then NULL is returned and an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	Updates the native rep of the Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

Tcl_RegExp
Tcl_GetRegExpFromObj(interp, objPtr, flags)
    Tcl_Interp *interp;		/* For use in error reporting, and to access
				 * the interp regexp cache. */
    Tcl_Obj *objPtr;		/* Object whose string rep contains regular
				 * expression pattern. Internal rep will be
				 * changed to compiled form of this regular
				 * expression. */
    int flags;			/* Regular expression compilation flags. */
{
    int length;
    TclRegexp *regexpPtr;
    char *pattern;

    /*
     * This is OK because we only actually interpret this value properly as a
     * TclRegexp* when the type is tclRegexpType.
     */

    regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;

    if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
	pattern = Tcl_GetStringFromObj(objPtr, &length);

	regexpPtr = CompileRegexp(interp, pattern, length, flags);
	if (regexpPtr == NULL) {
	    return NULL;
	}

	/*
	 * Add a reference to the regexp so it will persist even if it is
	 * pushed out of the current thread's regexp cache. This reference
	 * will be removed when the object's internal rep is freed.
	 */

	regexpPtr->refCount++;

	/*
	 * Free the old representation and set our type.
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
 *----------------------------------------------------------------------
 *
 * TclRegAbout --
 *
 *	Return information about a compiled regular expression.
 *
 * Results:
 *	The return value is -1 for failure, 0 for success, although at
 *	the moment there's nothing that could fail.  On success, a list
 *	is left in the interp's result:  first element is the subexpression
 *	count, second is a list of re_info bit names.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|
|







593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
 *----------------------------------------------------------------------
 *
 * TclRegAbout --
 *
 *	Return information about a compiled regular expression.
 *
 * Results:
 *	The return value is -1 for failure, 0 for success, although at the
 *	moment there's nothing that could fail. On success, a list is left in
 *	the interp's result: first element is the subexpression count, second
 *	is a list of re_info bit names.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

648
649
650
651
652
653
654
655
656
657

658
659
660
661
662
663
664

    Tcl_ResetResult(interp);

    sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub));
    Tcl_AppendElement(interp, buf);

    /*
     * Must count bits before generating list, because we must know
     * whether {} are needed before we start appending names.
     */

    n = 0;
    for (inf = infonames; inf->bit != 0; inf++) {
	if (regexpPtr->re.re_info&inf->bit) {
	    n++;
	}
    }
    if (n != 1) {







|
|

>







640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657

    Tcl_ResetResult(interp);

    sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub));
    Tcl_AppendElement(interp, buf);

    /*
     * Must count bits before generating list, because we must know whether {}
     * are needed before we start appending names.
     */

    n = 0;
    for (inf = infonames; inf->bit != 0; inf++) {
	if (regexpPtr->re.re_info&inf->bit) {
	    n++;
	}
    }
    if (n != 1) {
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
    p = (n > sizeof(buf)) ? "..." : "";
    Tcl_AppendResult(interp, msg, buf, p, NULL);

    sprintf(cbuf, "%d", status);
    (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf));
    Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * FreeRegexpInternalRep --
 *
 *	Deallocate the storage associated with a regexp object's internal







<







701
702
703
704
705
706
707

708
709
710
711
712
713
714
    p = (n > sizeof(buf)) ? "..." : "";
    Tcl_AppendResult(interp, msg, buf, p, NULL);

    sprintf(cbuf, "%d", status);
    (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf));
    Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * FreeRegexpInternalRep --
 *
 *	Deallocate the storage associated with a regexp object's internal
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771

772
773
774
775
776
777
778
}

/*
 *----------------------------------------------------------------------
 *
 * DupRegexpInternalRep --
 *
 *	We copy the reference to the compiled regexp and bump its
 *	reference count.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Increments the reference count of the regexp.
 *
 *----------------------------------------------------------------------
 */

static void
DupRegexpInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;		/* Object with internal rep to set. */
{
    TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr;

    regexpPtr->refCount++;
    copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
    copyPtr->typePtr = &tclRegexpType;
}

/*
 *----------------------------------------------------------------------







|
|
















>







739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
}

/*
 *----------------------------------------------------------------------
 *
 * DupRegexpInternalRep --
 *
 *	We copy the reference to the compiled regexp and bump its reference
 *	count.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Increments the reference count of the regexp.
 *
 *----------------------------------------------------------------------
 */

static void
DupRegexpInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;		/* Object with internal rep to set. */
{
    TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr;

    regexpPtr->refCount++;
    copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
    copyPtr->typePtr = &tclRegexpType;
}

/*
 *----------------------------------------------------------------------
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
}

/*
 *---------------------------------------------------------------------------
 *
 * CompileRegexp --
 *
 *	Attempt to compile the given regexp pattern.  If the compiled
 *	regular expression can be found in the per-thread cache, it
 *	will be used instead of compiling a new copy.
 *
 * Results:
 *	The return value is a pointer to a newly allocated TclRegexp
 *	that represents the compiled pattern, or NULL if the pattern
 *	could not be compiled.  If NULL is returned, an error message is
 *	left in the interp's result.
 *
 * Side effects:
 *	The thread-local regexp cache is updated and a new TclRegexp may
 *	be allocated.
 *
 *----------------------------------------------------------------------
 */

static TclRegexp *
CompileRegexp(interp, string, length, flags)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    CONST char *string;		/* The regexp to compile (UTF-8). */
    int length;			/* The length of the string in bytes. */
    int flags;			/* Compilation flags. */
{
    TclRegexp *regexpPtr;
    CONST Tcl_UniChar *uniString;
    int numChars;
    Tcl_DString stringBuf;
    int status, i;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
    if (!tsdPtr->initialized) {
	tsdPtr->initialized = 1;
	Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
    }

    /*
     * This routine maintains a second-level regular expression cache in
     * addition to the per-object regexp cache.  The per-thread cache is needed
     * to handle the case where for various reasons the object is lost between
     * invocations of the regexp command, but the literal pattern is the same.
     */

    /*
     * Check the per-thread compiled regexp cache.  We can only reuse
     * a regexp if it has the same pattern and the same flags.
     */

    for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	if ((length == tsdPtr->patLengths[i])
		&& (tsdPtr->regexps[i]->flags == flags)
		&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
	    /*
	     * Move the matched pattern to the first slot in the
	     * cache and shift the other patterns down one position.
	     */

	    if (i != 0) {
		int j;
		char *cachedString;

		cachedString = tsdPtr->patterns[i];







|
|
|


|
|
|
|


|
|

















|







|





|
|







|
|







799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
}

/*
 *---------------------------------------------------------------------------
 *
 * CompileRegexp --
 *
 *	Attempt to compile the given regexp pattern. If the compiled regular
 *	expression can be found in the per-thread cache, it will be used
 *	instead of compiling a new copy.
 *
 * Results:
 *	The return value is a pointer to a newly allocated TclRegexp that
 *	represents the compiled pattern, or NULL if the pattern could not be
 *	compiled. If NULL is returned, an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	The thread-local regexp cache is updated and a new TclRegexp may be
 *	allocated.
 *
 *----------------------------------------------------------------------
 */

static TclRegexp *
CompileRegexp(interp, string, length, flags)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    CONST char *string;		/* The regexp to compile (UTF-8). */
    int length;			/* The length of the string in bytes. */
    int flags;			/* Compilation flags. */
{
    TclRegexp *regexpPtr;
    CONST Tcl_UniChar *uniString;
    int numChars;
    Tcl_DString stringBuf;
    int status, i;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->initialized) {
	tsdPtr->initialized = 1;
	Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
    }

    /*
     * This routine maintains a second-level regular expression cache in
     * addition to the per-object regexp cache. The per-thread cache is needed
     * to handle the case where for various reasons the object is lost between
     * invocations of the regexp command, but the literal pattern is the same.
     */

    /*
     * Check the per-thread compiled regexp cache. We can only reuse a regexp
     * if it has the same pattern and the same flags.
     */

    for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	if ((length == tsdPtr->patLengths[i])
		&& (tsdPtr->regexps[i]->flags == flags)
		&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
	    /*
	     * Move the matched pattern to the first slot in the cache and
	     * shift the other patterns down one position.
	     */

	    if (i != 0) {
		int j;
		char *cachedString;

		cachedString = tsdPtr->patterns[i];
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
	    return tsdPtr->regexps[0];
	}
    }

    /*
     * This is a new expression, so compile it and add it to the cache.
     */
    
    regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
    regexpPtr->objPtr = NULL;
    regexpPtr->string = NULL;
    regexpPtr->details.rm_extend.rm_so = -1;
    regexpPtr->details.rm_extend.rm_eo = -1;

    /*







|







878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
	    return tsdPtr->regexps[0];
	}
    }

    /*
     * This is a new expression, so compile it and add it to the cache.
     */

    regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
    regexpPtr->objPtr = NULL;
    regexpPtr->string = NULL;
    regexpPtr->details.rm_extend.rm_so = -1;
    regexpPtr->details.rm_extend.rm_eo = -1;

    /*
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
		    "couldn't compile regular expression pattern: ",
		    status);
	}
	return NULL;
    }

    /*
     * Allocate enough space for all of the subexpressions, plus one
     * extra for the entire pattern.
     */

    regexpPtr->matches = (regmatch_t *) ckalloc(
	    sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));

    /*
     * Initialize the refcount to one initially, since it is in the cache.







|
|







916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
		    "couldn't compile regular expression pattern: ",
		    status);
	}
	return NULL;
    }

    /*
     * Allocate enough space for all of the subexpressions, plus one extra for
     * the entire pattern.
     */

    regexpPtr->matches = (regmatch_t *) ckalloc(
	    sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));

    /*
     * Initialize the refcount to one initially, since it is in the cache.
1021
1022
1023
1024
1025
1026
1027








	regexpPtr = tsdPtr->regexps[i];
	if (--(regexpPtr->refCount) <= 0) {
	    FreeRegexp(regexpPtr);
	}
	ckfree(tsdPtr->patterns[i]);
    }
}















>
>
>
>
>
>
>
>
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
	regexpPtr = tsdPtr->regexps[i];
	if (--(regexpPtr->refCount) <= 0) {
	    FreeRegexp(regexpPtr);
	}
	ckfree(tsdPtr->patterns[i]);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclResolve.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84

85
86
87
88
89
90
91
92
93
94
95
96

97
98
99
100
101
102
103
104
105
106
107
108

109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

366
367
368
369
370
371

372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418








/*
 * tclResolve.c --
 *
 *      Contains hooks for customized command/variable name resolution
 *      schemes.  These hooks allow extensions like [incr Tcl] to add
 *      their own name resolution rules to the Tcl language.  Rules can
 *      be applied to a particular namespace, to the interpreter as a
 *      whole, or both.
 *
 * Copyright (c) 1998 Lucent Technologies, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResolve.c,v 1.4 2002/01/25 22:01:32 dgp Exp $
 */

#include "tclInt.h"

/*
 * Declarations for procedures local to this file:
 */

static void		BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddInterpResolvers --
 *
 *	Adds a set of command/variable resolution procedures to an
 *	interpreter.  These procedures are consulted when commands
 *	are resolved in Tcl_FindCommand, and when variables are
 *	resolved in TclLookupVar and LookupCompiledLocal.  Each
 *	namespace may also have its own set of resolution procedures
 *	which take precedence over those for the interpreter.

 *
 *	When a name is resolved, it is handled as follows.  First,
 *	the name is passed to the resolution procedures for the
 *	namespace.  If not resolved, the name is passed to each of
 *	the resolution procedures added to the interpreter.  Finally,
 *	if still not resolved, the name is handled using the default
 *	Tcl rules for name resolution.
 *
 * Results:
 *	Returns pointers to the current name resolution procedures
 *	in the cmdProcPtr, varProcPtr and compiledVarProcPtr
 *	arguments.
 *
 * Side effects:
 *	If a compiledVarProc is specified, this procedure bumps the
 *	compileEpoch for the interpreter, forcing all code to be
 *	recompiled.  If a cmdProc is specified, this procedure bumps
 *	the cmdRefEpoch in all namespaces, forcing commands to be
 *	resolved again using the new rules.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)

    Tcl_Interp *interp;			/* Interpreter whose name resolution
					 * rules are being modified. */
    CONST char *name;			/* Name of this resolution scheme. */
    Tcl_ResolveCmdProc *cmdProc;	/* New procedure for command
					 * resolution */
    Tcl_ResolveVarProc *varProc;	/* Procedure for variable resolution
					 * at runtime */
    Tcl_ResolveCompiledVarProc *compiledVarProc;
					/* Procedure for variable resolution
					 * at compile time. */
{
    Interp *iPtr = (Interp*)interp;
    ResolverScheme *resPtr;

    /*
     *  Since we're adding a new name resolution scheme, we must force
     *  all code to be recompiled to use the new scheme.  If there
     *  are new compiled variable resolution rules, bump the compiler
     *  epoch to invalidate compiled code.  If there are new command
     *  resolution rules, bump the cmdRefEpoch in all namespaces.
     */

    if (compiledVarProc) {
        iPtr->compileEpoch++;
    }
    if (cmdProc) {
        BumpCmdRefEpochs(iPtr->globalNsPtr);
    }

    /*
     *  Look for an existing scheme with the given name.  If found,
     *  then replace its rules.
     */
    for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {

        if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
            resPtr->cmdResProc = cmdProc;
            resPtr->varResProc = varProc;
            resPtr->compiledVarResProc = compiledVarProc;
            return;
        }
    }

    /*
     *  Otherwise, this is a new scheme.  Add it to the FRONT
     *  of the linked list, so that it overrides existing schemes.
     */

    resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
    resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
    strcpy(resPtr->name, name);
    resPtr->cmdResProc = cmdProc;
    resPtr->varResProc = varProc;
    resPtr->compiledVarResProc = compiledVarProc;
    resPtr->nextPtr = iPtr->resolverPtr;
    iPtr->resolverPtr = resPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInterpResolvers --
 *
 *	Looks for a set of command/variable resolution procedures with
 *	the given name in an interpreter.  These procedures are
 *	registered by calling Tcl_AddInterpResolvers.
 *
 * Results:
 *	If the name is recognized, this procedure returns non-zero,
 *	along with pointers to the name resolution procedures in
 *	the Tcl_ResolverInfo structure.  If the name is not recognized,
 *	this procedure returns zero.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInterpResolvers(interp, name, resInfoPtr)

    Tcl_Interp *interp;			/* Interpreter whose name resolution
					 * rules are being queried. */
    CONST char *name;                   /* Look for a scheme with this name. */
    Tcl_ResolverInfo *resInfoPtr;	/* Returns pointers to the procedures,
					 * if found */
{
    Interp *iPtr = (Interp*)interp;
    ResolverScheme *resPtr;

    /*
     *  Look for an existing scheme with the given name.  If found,
     *  then return pointers to its procedures.
     */
    for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {

        if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
	    resInfoPtr->cmdResProc = resPtr->cmdResProc;
	    resInfoPtr->varResProc = resPtr->varResProc;
	    resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
            return 1;
        }
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RemoveInterpResolvers --
 *
 *	Removes a set of command/variable resolution procedures
 *	previously added by Tcl_AddInterpResolvers.  The next time
 *	a command/variable name is resolved, these procedures
 *	won't be consulted.
 *
 * Results:
 *	Returns non-zero if the name was recognized and the
 *	resolution scheme was deleted.  Returns zero otherwise.
 *
 * Side effects:
 *	If a scheme with a compiledVarProc was deleted, this procedure
 *	bumps the compileEpoch for the interpreter, forcing all code
 *	to be recompiled.  If a scheme with a cmdProc was deleted,
 *	this procedure bumps the cmdRefEpoch in all namespaces,
 *	forcing commands to be resolved again using the new rules.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RemoveInterpResolvers(interp, name)

    Tcl_Interp *interp;			/* Interpreter whose name resolution
					 * rules are being modified. */
    CONST char *name;                   /* Name of the scheme to be removed. */
{
    Interp *iPtr = (Interp*)interp;
    ResolverScheme **prevPtrPtr, *resPtr;

    /*
     *  Look for an existing scheme with the given name.
     */

    prevPtrPtr = &iPtr->resolverPtr;
    for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
        if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
            break;
        }
        prevPtrPtr = &resPtr->nextPtr;
    }

    /*
     *  If we found the scheme, delete it.
     */

    if (resPtr) {
        /*
         *  If we're deleting a scheme with compiled variable resolution
         *  rules, bump the compiler epoch to invalidate compiled code.
         *  If we're deleting a scheme with command resolution rules,
         *  bump the cmdRefEpoch in all namespaces.
         */

        if (resPtr->compiledVarResProc) {
            iPtr->compileEpoch++;
        }
        if (resPtr->cmdResProc) {
            BumpCmdRefEpochs(iPtr->globalNsPtr);
        }

        *prevPtrPtr = resPtr->nextPtr;
        ckfree(resPtr->name);
        ckfree((char *) resPtr);

        return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * BumpCmdRefEpochs --
 *
 *	This procedure is used to bump the cmdRefEpoch counters in
 *	the specified namespace and all of its child namespaces.
 *	It is used whenever name resolution schemes are added/removed
 *	from an interpreter, to invalidate all command references.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Bumps the cmdRefEpoch in the specified namespace and its
 *	children, recursively.
 *
 *----------------------------------------------------------------------
 */

static void
BumpCmdRefEpochs(nsPtr)
    Namespace *nsPtr;			/* Namespace being modified. */
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    Namespace *childNsPtr;

    nsPtr->cmdRefEpoch++;

    for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
	    entry != NULL;
	    entry = Tcl_NextHashEntry(&search)) {

        childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
        BumpCmdRefEpochs(childNsPtr);
    }

}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetNamespaceResolvers --
 *
 *	Sets the command/variable resolution procedures for a namespace,
 *	thereby changing the way that command/variable names are
 *	interpreted.  This allows extension writers to support different
 *	name resolution schemes, such as those for object-oriented
 *	packages.
 *
 *	Command resolution is handled by a procedure of the following
 *	type:
 *
 *	  typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((
 *		Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
 *              int flags, Tcl_Command *rPtr));
 *          
 *	Whenever a command is executed or Tcl_FindCommand is invoked
 *	within the namespace, this procedure is called to resolve the
 *	command name.  If this procedure is able to resolve the name,
 *	it should return the status code TCL_OK, along with the
 *	corresponding Tcl_Command in the rPtr argument.  Otherwise,
 *	the procedure can return TCL_CONTINUE, and the command will
 *	be treated under the usual name resolution rules.  Or, it can
 *	return TCL_ERROR, and the command will be considered invalid.

 *
 *	Variable resolution is handled by two procedures.  The first
 *	is called whenever a variable needs to be resolved at compile
 *	time:
 *
 *        typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
 *	        Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
 *	        Tcl_ResolvedVarInfo *rPtr));
 *
 *      If this procedure is able to resolve the name, it should return
 *      the status code TCL_OK, along with variable resolution info in
 *      the rPtr argument; this info will be used to set up compiled
 *	locals in the call frame at runtime.  The procedure may also
 *	return TCL_CONTINUE, and the variable will be treated under
 *	the usual name resolution rules.  Or, it can return TCL_ERROR,
 *	and the variable will be considered invalid.
 *
 *	Another procedure is used whenever a variable needs to be
 *	resolved at runtime but it is not recognized as a compiled local.
 *	(For example, the variable may be requested via
 *	Tcl_FindNamespaceVar.) This procedure has the following type:
 *
 *	  typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
 *	        Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
 *	        int flags, Tcl_Var *rPtr));
 *
 *	This procedure is quite similar to the compile-time version.
 *	It returns the same status codes, but if variable resolution
 *	succeeds, this procedure returns a Tcl_Var directly via the
 *	rPtr argument.
 *
 * Results:
 *	Nothing.
 *
 * Side effects:
 *	Bumps the command epoch counter for the namespace, invalidating
 *	all command references in that namespace.  Also bumps the
 *	resolver epoch counter for the namespace, forcing all code
 *	in the namespace to be recompiled.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
    Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
					 * are being modified. */
    Tcl_ResolveCmdProc *cmdProc;	/* Procedure for command resolution */
    Tcl_ResolveVarProc *varProc;	/* Procedure for variable resolution
					 * at runtime */
    Tcl_ResolveCompiledVarProc *compiledVarProc;
					/* Procedure for variable resolution
					 * at compile time. */
{
    Namespace *nsPtr = (Namespace*)namespacePtr;

    /*
     *  Plug in the new command resolver, and bump the epoch counters
     *  so that all code will have to be recompiled and all commands
     *  will have to be resolved again using the new policy.
     */

    nsPtr->cmdResProc = cmdProc;
    nsPtr->varResProc = varProc;
    nsPtr->compiledVarResProc = compiledVarProc;

    nsPtr->cmdRefEpoch++;
    nsPtr->resolverEpoch++;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetNamespaceResolvers --
 *
 *	Returns the current command/variable resolution procedures
 *	for a namespace.  By default, these procedures are NULL.
 *	New procedures can be installed by calling
 *	Tcl_SetNamespaceResolvers, to provide new name resolution
 *	rules.
 *
 * Results:
 *	Returns non-zero if any name resolution procedures have been
 *	assigned to this namespace; also returns pointers to the
 *	procedures in the Tcl_ResolverInfo structure.  Returns zero
 *	otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr)

    Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
					 * are being modified. */
    Tcl_ResolverInfo *resInfoPtr;	/* Returns: pointers for all
					 * name resolution procedures
					 * assigned to this namespace. */
{
    Namespace *nsPtr = (Namespace*)namespacePtr;

    resInfoPtr->cmdResProc = nsPtr->cmdResProc;
    resInfoPtr->varResProc = nsPtr->varResProc;
    resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;

    if (nsPtr->cmdResProc != NULL ||
        nsPtr->varResProc != NULL ||
        nsPtr->compiledVarResProc != NULL) {
	return 1;
    }
    return 0;
}











|
|
|
|
<



|
|

|





|



<






|
|
|
<
|
|
>

|
|
|
<
|
|


|
|
<


|
|
|
<
|






<



|
|
|
|

|
|

|



|
|
|
|
|

>

|


|



|
|

|
>
|
|
|
|
|
|



|
|

>

|













|
|
|


|
|
|
<









<


|
|


|



|
|

|
>
|



|
|










|
|
<
|


|
|


|
|
|
|
|






<


|

|



|

>

|
|
|
|
|



|

>

|
|
|
|
|
|
>
|
|
|
|
|
|

|
|
|

|









|
|
|
|





|
|










<




<
|
<
|
|

>

<






|
|
|
|
<

|
<

|
|
|
|
|
|
|
|
<
|
|
|
>

|
|
<

|
|
|

|
|
|
<
|
|
|

|
|
|
|

|
|
|

|
|
|
<





|
|
|
|








|
|
|

|
|

|


|
|
|

>






>







|
|
<
|
|


|
|
|
<









<


|
|
|

|





|
<
|




>
>
>
>
>
>
>
>
1
2
3
4
5
6
7

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39

40
41
42
43
44
45

46
47
48
49
50

51
52
53
54
55
56
57

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128

129
130
131
132
133
134
135
136
137

138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261

262
263
264
265

266

267
268
269
270
271

272
273
274
275
276
277
278
279
280
281

282
283

284
285
286
287
288
289
290
291
292

293
294
295
296
297
298
299

300
301
302
303
304
305
306
307

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371

372
373
374
375
376
377
378

379
380
381
382
383
384
385
386
387

388
389
390
391
392
393
394
395
396
397
398
399
400

401
402
403
404
405
406
407
408
409
410
411
412
413
/*
 * tclResolve.c --
 *
 *	Contains hooks for customized command/variable name resolution
 *	schemes. These hooks allow extensions like [incr Tcl] to add their own
 *	name resolution rules to the Tcl language. Rules can be applied to a
 *	particular namespace, to the interpreter as a whole, or both.

 *
 * Copyright (c) 1998 Lucent Technologies, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResolve.c,v 1.4.6.2 2005/08/02 18:16:07 dgp Exp $
 */

#include "tclInt.h"

/*
 * Declarations for functions local to this file:
 */

static void		BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddInterpResolvers --
 *
 *	Adds a set of command/variable resolution functions to an interpreter.
 *	These functions are consulted when commands are resolved in
 *	Tcl_FindCommand, and when variables are resolved in TclLookupVar and

 *	LookupCompiledLocal. Each namespace may also have its own set of
 *	resolution functions which take precedence over those for the
 *	interpreter.
 *
 *	When a name is resolved, it is handled as follows. First, the name is
 *	passed to the resolution functions for the namespace. If not resolved,
 *	the name is passed to each of the resolution functions added to the

 *	interpreter. Finally, if still not resolved, the name is handled using
 *	the default Tcl rules for name resolution.
 *
 * Results:
 *	Returns pointers to the current name resolution functions in the
 *	cmdProcPtr, varProcPtr and compiledVarProcPtr arguments.

 *
 * Side effects:
 *	If a compiledVarProc is specified, this function bumps the
 *	compileEpoch for the interpreter, forcing all code to be recompiled.
 *	If a cmdProc is specified, this function bumps the cmdRefEpoch in all

 *	namespaces, forcing commands to be resolved again using the new rules.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)

    Tcl_Interp *interp;			/* Interpreter whose name resolution
					 * rules are being modified. */
    CONST char *name;			/* Name of this resolution scheme. */
    Tcl_ResolveCmdProc *cmdProc;	/* New function for command
					 * resolution. */
    Tcl_ResolveVarProc *varProc;	/* Function for variable resolution at
					 * runtime. */
    Tcl_ResolveCompiledVarProc *compiledVarProc;
					/* Function for variable resolution at
					 * compile time. */
{
    Interp *iPtr = (Interp *) interp;
    ResolverScheme *resPtr;

    /*
     * Since we're adding a new name resolution scheme, we must force all code
     * to be recompiled to use the new scheme. If there are new compiled
     * variable resolution rules, bump the compiler epoch to invalidate
     * compiled code. If there are new command resolution rules, bump the
     * cmdRefEpoch in all namespaces.
     */

    if (compiledVarProc) {
	iPtr->compileEpoch++;
    }
    if (cmdProc) {
	BumpCmdRefEpochs(iPtr->globalNsPtr);
    }

    /*
     * Look for an existing scheme with the given name. If found, then replace
     * its rules.
     */

    for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) {
	if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
	    resPtr->cmdResProc = cmdProc;
	    resPtr->varResProc = varProc;
	    resPtr->compiledVarResProc = compiledVarProc;
	    return;
	}
    }

    /*
     * Otherwise, this is a new scheme. Add it to the FRONT of the linked
     * list, so that it overrides existing schemes.
     */

    resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
    resPtr->name = (char *) ckalloc((unsigned)(strlen(name) + 1));
    strcpy(resPtr->name, name);
    resPtr->cmdResProc = cmdProc;
    resPtr->varResProc = varProc;
    resPtr->compiledVarResProc = compiledVarProc;
    resPtr->nextPtr = iPtr->resolverPtr;
    iPtr->resolverPtr = resPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetInterpResolvers --
 *
 *	Looks for a set of command/variable resolution functions with the
 *	given name in an interpreter. These functions are registered by
 *	calling Tcl_AddInterpResolvers.
 *
 * Results:
 *	If the name is recognized, this function returns non-zero, along with
 *	pointers to the name resolution functions in the Tcl_ResolverInfo
 *	structure. If the name is not recognized, this function returns zero.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetInterpResolvers(interp, name, resInfoPtr)

    Tcl_Interp *interp;			/* Interpreter whose name resolution
					 * rules are being queried. */
    CONST char *name;			/* Look for a scheme with this name. */
    Tcl_ResolverInfo *resInfoPtr;	/* Returns pointers to the functions,
					 * if found */
{
    Interp *iPtr = (Interp *) interp;
    ResolverScheme *resPtr;

    /*
     * Look for an existing scheme with the given name. If found, then return
     * pointers to its functions.
     */

    for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) {
	if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
	    resInfoPtr->cmdResProc = resPtr->cmdResProc;
	    resInfoPtr->varResProc = resPtr->varResProc;
	    resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
	    return 1;
	}
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RemoveInterpResolvers --
 *
 *	Removes a set of command/variable resolution functions previously
 *	added by Tcl_AddInterpResolvers. The next time a command/variable name

 *	is resolved, these functions won't be consulted.
 *
 * Results:
 *	Returns non-zero if the name was recognized and the resolution scheme
 *	was deleted. Returns zero otherwise.
 *
 * Side effects:
 *	If a scheme with a compiledVarProc was deleted, this function bumps
 *	the compileEpoch for the interpreter, forcing all code to be
 *	recompiled. If a scheme with a cmdProc was deleted, this function
 *	bumps the cmdRefEpoch in all namespaces, forcing commands to be
 *	resolved again using the new rules.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RemoveInterpResolvers(interp, name)

    Tcl_Interp *interp;			/* Interpreter whose name resolution
					 * rules are being modified. */
    CONST char *name;			/* Name of the scheme to be removed. */
{
    Interp *iPtr = (Interp *) interp;
    ResolverScheme **prevPtrPtr, *resPtr;

    /*
     * Look for an existing scheme with the given name.
     */

    prevPtrPtr = &iPtr->resolverPtr;
    for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) {
	if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
	    break;
	}
	prevPtrPtr = &resPtr->nextPtr;
    }

    /*
     * If we found the scheme, delete it.
     */

    if (resPtr) {
	/*
	 * If we're deleting a scheme with compiled variable resolution rules,
	 * bump the compiler epoch to invalidate compiled code. If we're
	 * deleting a scheme with command resolution rules, bump the
	 * cmdRefEpoch in all namespaces.
	 */

	if (resPtr->compiledVarResProc) {
	    iPtr->compileEpoch++;
	}
	if (resPtr->cmdResProc) {
	    BumpCmdRefEpochs(iPtr->globalNsPtr);
	}

	*prevPtrPtr = resPtr->nextPtr;
	ckfree(resPtr->name);
	ckfree((char *) resPtr);

	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * BumpCmdRefEpochs --
 *
 *	This function is used to bump the cmdRefEpoch counters in the
 *	specified namespace and all of its child namespaces. It is used
 *	whenever name resolution schemes are added/removed from an
 *	interpreter, to invalidate all command references.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Bumps the cmdRefEpoch in the specified namespace and its children,
 *	recursively.
 *
 *----------------------------------------------------------------------
 */

static void
BumpCmdRefEpochs(nsPtr)
    Namespace *nsPtr;			/* Namespace being modified. */
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;


    nsPtr->cmdRefEpoch++;

    for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);

	    entry != NULL; entry = Tcl_NextHashEntry(&search)) {

	Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
	BumpCmdRefEpochs(childNsPtr);
    }
    TclInvalidateNsPath(nsPtr);
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetNamespaceResolvers --
 *
 *	Sets the command/variable resolution functions for a namespace,
 *	thereby changing the way that command/variable names are interpreted.
 *	This allows extension writers to support different name resolution
 *	schemes, such as those for object-oriented packages.

 *
 *	Command resolution is handled by a function of the following type:

 *
 *	  typedef int (*Tcl_ResolveCmdProc)(Tcl_Interp *interp,
 *		  CONST char *name, Tcl_Namespace *context,
 *		  int flags, Tcl_Command *rPtr);
 *
 *	Whenever a command is executed or Tcl_FindCommand is invoked within
 *	the namespace, this function is called to resolve the command name.
 *	If this function is able to resolve the name, it should return the
 *	status code TCL_OK, along with the corresponding Tcl_Command in the

 *	rPtr argument. Otherwise, the function can return TCL_CONTINUE, and
 *	the command will be treated under the usual name resolution rules.
 *	Or, it can return TCL_ERROR, and the command will be considered
 *	invalid.
 *
 *	Variable resolution is handled by two functions. The first is called
 *	whenever a variable needs to be resolved at compile time:

 *
 *	  typedef int (*Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
 *		  CONST char *name, Tcl_Namespace *context,
 *		  Tcl_ResolvedVarInfo *rPtr);
 *
 *	If this function is able to resolve the name, it should return the
 *	status code TCL_OK, along with variable resolution info in the rPtr
 *	argument; this info will be used to set up compiled locals in the call

 *	frame at runtime. The function may also return TCL_CONTINUE, and the
 *	variable will be treated under the usual name resolution rules. Or, it
 *	can return TCL_ERROR, and the variable will be considered invalid.
 *
 *	Another function is used whenever a variable needs to be resolved at
 *	runtime but it is not recognized as a compiled local. (For example,
 *	the variable may be requested via Tcl_FindNamespaceVar.) This function
 *	has the following type:
 *
 *	  typedef int (*Tcl_ResolveVarProc)(Tcl_Interp *interp,
 *		  CONST char *name, Tcl_Namespace *context,
 *		  int flags, Tcl_Var *rPtr);
 *
 *	This function is quite similar to the compile-time version. It returns
 *	the same status codes, but if variable resolution succeeds, this
 *	function returns a Tcl_Var directly via the rPtr argument.

 *
 * Results:
 *	Nothing.
 *
 * Side effects:
 *	Bumps the command epoch counter for the namespace, invalidating all
 *	command references in that namespace. Also bumps the resolver epoch
 *	counter for the namespace, forcing all code in the namespace to be
 *	recompiled.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
    Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
					 * are being modified. */
    Tcl_ResolveCmdProc *cmdProc;	/* Function for command resolution */
    Tcl_ResolveVarProc *varProc;	/* Function for variable resolution at
					 * run-time */
    Tcl_ResolveCompiledVarProc *compiledVarProc;
					/* Function for variable resolution at
					 * compile time. */
{
    Namespace *nsPtr = (Namespace *) namespacePtr;

    /*
     * Plug in the new command resolver, and bump the epoch counters so that
     * all code will have to be recompiled and all commands will have to be
     * resolved again using the new policy.
     */

    nsPtr->cmdResProc = cmdProc;
    nsPtr->varResProc = varProc;
    nsPtr->compiledVarResProc = compiledVarProc;

    nsPtr->cmdRefEpoch++;
    nsPtr->resolverEpoch++;
    TclInvalidateNsPath(nsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetNamespaceResolvers --
 *
 *	Returns the current command/variable resolution functions for a
 *	namespace. By default, these functions are NULL. New functions can be

 *	installed by calling Tcl_SetNamespaceResolvers, to provide new name
 *	resolution rules.
 *
 * Results:
 *	Returns non-zero if any name resolution functions have been assigned
 *	to this namespace; also returns pointers to the functions in the
 *	Tcl_ResolverInfo structure. Returns zero otherwise.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr)

    Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
					 * are being modified. */
    Tcl_ResolverInfo *resInfoPtr;	/* Returns: pointers for all name
					 * resolution functions assigned to
					 * this namespace. */
{
    Namespace *nsPtr = (Namespace *) namespacePtr;

    resInfoPtr->cmdResProc = nsPtr->cmdResProc;
    resInfoPtr->varResProc = nsPtr->varResProc;
    resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;

    if (nsPtr->cmdResProc != NULL || nsPtr->varResProc != NULL ||

	    nsPtr->compiledVarResProc != NULL) {
	return 1;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclResult.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16


17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
/* 
 * tclResult.c --
 *
 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResult.c,v 1.23 2004/11/23 00:12:57 dkf Exp $
 */

#include "tclInt.h"


/* Indices of the standard return options dictionary keys */


enum returnKeys {
    KEY_CODE,	KEY_ERRORCODE,	KEY_ERRORINFO,	KEY_ERRORLINE,
    KEY_LEVEL,	KEY_OPTIONS,	KEY_LAST
};

/*
 * Function prototypes for local procedures in this file:
 */

static Tcl_Obj **	GetKeys();
static void		ReleaseKeys _ANSI_ARGS_((ClientData clientData));
static void             ResetObjResult _ANSI_ARGS_((Interp *iPtr));
static void		SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
			    int newSpace));

/*
 *  This structure is used to take a snapshot of the interpreter
 *  state in Tcl_SaveInterpState.  You can snapshot the state,
 *  execute a command, and then back up to the result or the
 *  error that was previously in progress.
 */

typedef struct InterpState {
    int status;			/* return code status */
    int flags;			/* Each remaining field saves */
    int returnLevel;		/* the corresponding field of */
    int returnCode;		/* the Interp struct.  These */
    Tcl_Obj *errorInfo;		/* fields take together are the */
    Tcl_Obj *errorCode;		/* "state" of the interp. */
    Tcl_Obj *returnOpts;
    Tcl_Obj *objResult;
} InterpState;


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SaveInterpState --
 *
 *      Fills a token with a snapshot of the current state of the
 *      interpreter.  The snapshot can be restored at any point by
 *      TclRestoreInterpState. 
 *
 *      The token returned must be eventally passed to one of the
 *      routines TclRestoreInterpState or TclDiscardInterpState,
 *      or there will be a memory leak.
 *
 * Results:
 *	Returns a token representing the interp state.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_InterpState
Tcl_SaveInterpState(interp, status)
    Tcl_Interp* interp;     /* Interpreter's state to be saved */
    int status;             /* status code for current operation */
{
    Interp *iPtr = (Interp *)interp;
    InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));

    statePtr->status = status;
    statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
    statePtr->returnLevel = iPtr->returnLevel;
|






|
|

|




>
|
>
>






|


|

|




|
|
|
<

>


|
|
|
|
|



<






|
|
<

|
|
|












|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
/*
 * tclResult.c --
 *
 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclResult.c,v 1.23.2.5 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */

enum returnKeys {
    KEY_CODE,	KEY_ERRORCODE,	KEY_ERRORINFO,	KEY_ERRORLINE,
    KEY_LEVEL,	KEY_OPTIONS,	KEY_LAST
};

/*
 * Function prototypes for local functions in this file:
 */

static Tcl_Obj **	GetKeys _ANSI_ARGS_((void));
static void		ReleaseKeys _ANSI_ARGS_((ClientData clientData));
static void		ResetObjResult _ANSI_ARGS_((Interp *iPtr));
static void		SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
			    int newSpace));

/*
 * This structure is used to take a snapshot of the interpreter state in
 * Tcl_SaveInterpState. You can snapshot the state, execute a command, and
 * then back up to the result or the error that was previously in progress.

 */

typedef struct InterpState {
    int status;			/* return code status */
    int flags;			/* Each remaining field saves the */
    int returnLevel;		/* corresponding field of the Interp */
    int returnCode;		/* struct. These fields taken together are */
    Tcl_Obj *errorInfo;		/* the "state" of the interp. */
    Tcl_Obj *errorCode;
    Tcl_Obj *returnOpts;
    Tcl_Obj *objResult;
} InterpState;


/*
 *----------------------------------------------------------------------
 *
 * Tcl_SaveInterpState --
 *
 *	Fills a token with a snapshot of the current state of the interpreter.
 *	The snapshot can be restored at any point by TclRestoreInterpState.

 *
 *	The token returned must be eventally passed to one of the routines
 *	TclRestoreInterpState or TclDiscardInterpState, or there will be a
 *	memory leak.
 *
 * Results:
 *	Returns a token representing the interp state.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_InterpState
Tcl_SaveInterpState(interp, status)
    Tcl_Interp* interp;		/* Interpreter's state to be saved */
    int status;			/* status code for current operation */
{
    Interp *iPtr = (Interp *)interp;
    InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));

    statePtr->status = status;
    statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
    statePtr->returnLevel = iPtr->returnLevel;
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RestoreInterpState --
 *
 *      Accepts an interp and a token previously returned by
 *      Tcl_SaveInterpState.  Restore the state of the interp
 *      to what it was at the time of the Tcl_SaveInterpState call.
 *
 * Results:
 *	Returns the status value originally passed in to Tcl_SaveInterpState.
 *
 * Side effects:
 *	Restores the interp state and frees memory held by token.
 *







|
|
|







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RestoreInterpState --
 *
 *	Accepts an interp and a token previously returned by
 *	Tcl_SaveInterpState. Restore the state of the interp to what it was at
 *	the time of the Tcl_SaveInterpState call.
 *
 * Results:
 *	Returns the status value originally passed in to Tcl_SaveInterpState.
 *
 * Side effects:
 *	Restores the interp state and frees memory held by token.
 *
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DiscardInterpState --
 *
 *      Accepts a token previously returned by Tcl_SaveInterpState.
 *      Frees the memory it uses.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DiscardInterpState(state)
    Tcl_InterpState state;	/* saved interpreter state */
{
    InterpState *statePtr = (InterpState *)state;

    if (statePtr->errorInfo) {
        Tcl_DecrRefCount(statePtr->errorInfo);
    }
    if (statePtr->errorCode) {
        Tcl_DecrRefCount(statePtr->errorCode);
    }
    if (statePtr->returnOpts) {
        Tcl_DecrRefCount(statePtr->returnOpts);
    }
    Tcl_DecrRefCount(statePtr->objResult);
    ckfree((char*) statePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SaveResult --
 *
 *      Takes a snapshot of the current result state of the interpreter.
 *      The snapshot can be restored at any point by
 *      Tcl_RestoreResult. Note that this routine does not 
 *	preserve the errorCode, errorInfo, or flags fields so it
 *	should not be used if an error is in progress.
 *
 *      Once a snapshot is saved, it must be restored by calling
 *      Tcl_RestoreResult, or discarded by calling
 *      Tcl_DiscardResult.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the interpreter result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SaveResult(interp, statePtr)
    Tcl_Interp *interp;		/* Interpreter to save. */
    Tcl_SavedResult *statePtr;	/* Pointer to state structure. */
{
    Interp *iPtr = (Interp *) interp;

    /*
     * Move the result object into the save state.  Note that we don't need
     * to change its refcount because we're moving it, not adding a new
     * reference.  Put an empty object into the interpreter.
     */

    statePtr->objResultPtr = iPtr->objResultPtr;
    iPtr->objResultPtr = Tcl_NewObj(); 
    Tcl_IncrRefCount(iPtr->objResultPtr); 

    /*
     * Save the string result. 
     */

    statePtr->freeProc = iPtr->freeProc;
    if (iPtr->result == iPtr->resultSpace) {
	/*
	 * Copy the static string data out of the interp buffer.
	 */







|
|

















|


|


|










|
|
<
|
|

|
|
<


















|
|
|



|
|


|







158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202

203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DiscardInterpState --
 *
 *	Accepts a token previously returned by Tcl_SaveInterpState. Frees the
 *	memory it uses.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DiscardInterpState(state)
    Tcl_InterpState state;	/* saved interpreter state */
{
    InterpState *statePtr = (InterpState *)state;

    if (statePtr->errorInfo) {
	Tcl_DecrRefCount(statePtr->errorInfo);
    }
    if (statePtr->errorCode) {
	Tcl_DecrRefCount(statePtr->errorCode);
    }
    if (statePtr->returnOpts) {
	Tcl_DecrRefCount(statePtr->returnOpts);
    }
    Tcl_DecrRefCount(statePtr->objResult);
    ckfree((char*) statePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SaveResult --
 *
 *	Takes a snapshot of the current result state of the interpreter. The
 *	snapshot can be restored at any point by Tcl_RestoreResult. Note that

 *	this routine does not preserve the errorCode, errorInfo, or flags
 *	fields so it should not be used if an error is in progress.
 *
 *	Once a snapshot is saved, it must be restored by calling
 *	Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the interpreter result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SaveResult(interp, statePtr)
    Tcl_Interp *interp;		/* Interpreter to save. */
    Tcl_SavedResult *statePtr;	/* Pointer to state structure. */
{
    Interp *iPtr = (Interp *) interp;

    /*
     * Move the result object into the save state. Note that we don't need to
     * change its refcount because we're moving it, not adding a new
     * reference. Put an empty object into the interpreter.
     */

    statePtr->objResultPtr = iPtr->objResultPtr;
    iPtr->objResultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(iPtr->objResultPtr);

    /*
     * Save the string result.
     */

    statePtr->freeProc = iPtr->freeProc;
    if (iPtr->result == iPtr->resultSpace) {
	/*
	 * Copy the static string data out of the interp buffer.
	 */
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RestoreResult --
 *
 *      Restores the state of the interpreter to a snapshot taken
 *      by Tcl_SaveResult.  After this call, the token for
 *      the interpreter state is no longer valid.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Restores the interpreter result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_RestoreResult(interp, statePtr)
    Tcl_Interp* interp;		/* Interpreter being restored. */







|
|
|


|


|







272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RestoreResult --
 *
 *	Restores the state of the interpreter to a snapshot taken by
 *	Tcl_SaveResult. After this call, the token for the interpreter state
 *	is no longer valid.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Restores the interpreter result.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_RestoreResult(interp, statePtr)
    Tcl_Interp* interp;		/* Interpreter being restored. */
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DiscardResult --
 *
 *      Frees the memory associated with an interpreter snapshot
 *      taken by Tcl_SaveResult.  If the snapshot is not
 *      restored, this procedure must be called to discard it,
 *      or the memory will be lost.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DiscardResult(statePtr)
    Tcl_SavedResult *statePtr;	/* State returned by Tcl_SaveResult. */







|
|
<
|


|


|







340
341
342
343
344
345
346
347
348

349
350
351
352
353
354
355
356
357
358
359
360
361
362
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DiscardResult --
 *
 *	Frees the memory associated with an interpreter snapshot taken by
 *	Tcl_SaveResult. If the snapshot is not restored, this function must be

 *	called to discard it, or the memory will be lost.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DiscardResult(statePtr)
    Tcl_SavedResult *statePtr;	/* State returned by Tcl_SaveResult. */
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetResult --
 *
 *	Arrange for "string" to be the Tcl return value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	interp->result is left pointing either to "string" (if "copy" is 0)
 *	or to a copy of string. Also, the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetResult(interp, stringPtr, freeProc)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    register char *stringPtr;	/* Value to be returned.  If NULL, the
				 * result is set to an empty string. */
    Tcl_FreeProc *freeProc;	/* Gives information about the string:
				 * TCL_STATIC, TCL_VOLATILE, or the address
				 * of a Tcl_FreeProc such as free. */
{
    Interp *iPtr = (Interp *) interp;
    int length;
    register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
    char *oldResult = iPtr->result;

    if (stringPtr == NULL) {
	iPtr->resultSpace[0] = 0;
	iPtr->result = iPtr->resultSpace;
	iPtr->freeProc = 0;
    } else if (freeProc == TCL_VOLATILE) {
	length = strlen(stringPtr);
	if (length > TCL_RESULT_SIZE) {
	    iPtr->result = (char *) ckalloc((unsigned) length+1);
	    iPtr->freeProc = TCL_DYNAMIC;
	} else {
	    iPtr->result = iPtr->resultSpace;
	    iPtr->freeProc = 0;
	}
	strcpy(iPtr->result, stringPtr);
    } else {
	iPtr->result = stringPtr;
	iPtr->freeProc = freeProc;
    }

    /*
     * If the old result was dynamically-allocated, free it up.  Do it
     * here, rather than at the beginning, in case the new result value
     * was part of the old result value.
     */

    if (oldFreeProc != 0) {
	if (oldFreeProc == TCL_DYNAMIC) {
	    ckfree(oldResult);
	} else {
	    (*oldFreeProc)(oldResult);







|





|
|





|


|
|

|
|






|




|







|

|




|
|
|







375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetResult --
 *
 *	Arrange for "result" to be the Tcl return value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	interp->result is left pointing either to "result" or to a copy of it.
 *	Also, the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetResult(interp, result, freeProc)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    register char *result;	/* Value to be returned. If NULL, the result
				 * is set to an empty string. */
    Tcl_FreeProc *freeProc;	/* Gives information about the string:
				 * TCL_STATIC, TCL_VOLATILE, or the address of
				 * a Tcl_FreeProc such as free. */
{
    Interp *iPtr = (Interp *) interp;
    int length;
    register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
    char *oldResult = iPtr->result;

    if (result == NULL) {
	iPtr->resultSpace[0] = 0;
	iPtr->result = iPtr->resultSpace;
	iPtr->freeProc = 0;
    } else if (freeProc == TCL_VOLATILE) {
	length = strlen(result);
	if (length > TCL_RESULT_SIZE) {
	    iPtr->result = (char *) ckalloc((unsigned) length+1);
	    iPtr->freeProc = TCL_DYNAMIC;
	} else {
	    iPtr->result = iPtr->resultSpace;
	    iPtr->freeProc = 0;
	}
	strcpy(iPtr->result, result);
    } else {
	iPtr->result = result;
	iPtr->freeProc = freeProc;
    }

    /*
     * If the old result was dynamically-allocated, free it up. Do it here,
     * rather than at the beginning, in case the new result value was part of
     * the old result value.
     */

    if (oldFreeProc != 0) {
	if (oldFreeProc == TCL_DYNAMIC) {
	    ckfree(oldResult);
	} else {
	    (*oldFreeProc)(oldResult);
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
 *	string result, then the object result is reset.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetStringResult(interp)
     register Tcl_Interp *interp; /* Interpreter whose result to return. */
{
    /*
     * If the string result is empty, move the object result to the
     * string result, then reset the object result.
     */
    
    if (*(interp->result) == 0) {
	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
	        TCL_VOLATILE);
    }
    return interp->result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjResult --
 *
 *	Arrange for objPtr to be an interpreter's result value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	interp->objResultPtr is left pointing to the object referenced
 *	by objPtr. The object's reference count is incremented since
 *	there is now a new reference to it. The reference count for any
 *	old objResultPtr value is decremented. Also, the string result
 *	is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjResult(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return object value. */
    register Tcl_Obj *objPtr;	/* Tcl object to be returned. If NULL, the
				 * obj result is made an empty string
				 * object. */
{
    register Interp *iPtr = (Interp *) interp;
    register Tcl_Obj *oldObjResult = iPtr->objResultPtr;

    iPtr->objResultPtr = objPtr;
    Tcl_IncrRefCount(objPtr);	/* since interp result is a reference */

    /*
     * We wait until the end to release the old object result, in case
     * we are setting the result to itself.
     */
    
    TclDecrRefCount(oldObjResult);

    /*
     * Reset the string result since we just set the result object.
     */

    if (iPtr->freeProc != NULL) {







|


|
|

|


|















|
|
|
|
<








|
|
<








|
|

|







461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496

497
498
499
500
501
502
503
504
505
506

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
 *	string result, then the object result is reset.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetStringResult(interp)
    register Tcl_Interp *interp;/* Interpreter whose result to return. */
{
    /*
     * If the string result is empty, move the object result to the string
     * result, then reset the object result.
     */

    if (*(interp->result) == 0) {
	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
		TCL_VOLATILE);
    }
    return interp->result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjResult --
 *
 *	Arrange for objPtr to be an interpreter's result value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	interp->objResultPtr is left pointing to the object referenced by
 *	objPtr. The object's reference count is incremented since there is now
 *	a new reference to it. The reference count for any old objResultPtr
 *	value is decremented. Also, the string result is reset.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjResult(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return object value. */
    register Tcl_Obj *objPtr;	/* Tcl object to be returned. If NULL, the obj
				 * result is made an empty string object. */

{
    register Interp *iPtr = (Interp *) interp;
    register Tcl_Obj *oldObjResult = iPtr->objResultPtr;

    iPtr->objResultPtr = objPtr;
    Tcl_IncrRefCount(objPtr);	/* since interp result is a reference */

    /*
     * We wait until the end to release the old object result, in case we are
     * setting the result to itself.
     */

    TclDecrRefCount(oldObjResult);

    /*
     * Reset the string result since we just set the result object.
     */

    if (iPtr->freeProc != NULL) {
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631

632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748

749
750
751
752
753

754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetObjResult --
 *
 *	Returns an interpreter's result value as a Tcl object. The object's
 *	reference count is not modified; the caller must do that if it
 *	needs to hold on to a long-term reference to it.
 *
 * Results:
 *	The interpreter's result as an object.
 *
 * Side effects:
 *	If the interpreter has a non-empty string result, the result object
 *	is either empty or stale because some procedure set interp->result
 *	directly. If so, the string result is moved to the result object
 *	then the string result is reset.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetObjResult(interp)
    Tcl_Interp *interp;		/* Interpreter whose result to return. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_Obj *objResultPtr;
    int length;

    /*
     * If the string result is non-empty, move the string result to the
     * object result, then reset the string result.
     */
    
    if (*(iPtr->result) != 0) {
	ResetObjResult(iPtr);
	
	objResultPtr = iPtr->objResultPtr;
	length = strlen(iPtr->result);
	TclInitStringRep(objResultPtr, iPtr->result, length);
	
	if (iPtr->freeProc != NULL) {
	    if (iPtr->freeProc == TCL_DYNAMIC) {
		ckfree(iPtr->result);
	    } else {
		(*iPtr->freeProc)(iPtr->result);
	    }
	    iPtr->freeProc = 0;
	}
	iPtr->result = iPtr->resultSpace;
	iPtr->resultSpace[0] = 0;
    }
    return iPtr->objResultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResultVA --
 *
 *	Append a variable number of strings onto the interpreter's
 *	result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result of the interpreter given by the first argument is
 *	extended by the strings in the va_list (up to a terminating
 *	NULL argument).
 *
 *	If the string result is non-empty, the object result forced to
 *	be a duplicate of it first. There will be a string result
 *	afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResultVA(interp, argList)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    va_list argList;		/* Variable argument list. */
{
    Tcl_Obj *objPtr = Tcl_GetObjResult(interp);

    if (Tcl_IsShared(objPtr)) {
	objPtr = Tcl_DuplicateObj(objPtr);
    }
    Tcl_AppendStringsToObjVA(objPtr, argList);
    Tcl_SetObjResult(interp, objPtr);

    /*
     * Strictly we should call Tcl_GetStringResult(interp) here to
     * make sure that interp->result is correct according to the old
     * contract, but that makes the performance of much code (e.g. in
     * Tk) absolutely awful. So we leave it out; code that really
     * wants interp->result can just insert the calls to
     * Tcl_GetStringResult() itself. [Patch 1041072 discussion]
     */

#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
    /*
     * Ensure that the interp->result is legal so old Tcl 7.* code
     * still works. There's still embarrasingly much of it about...
     */

    (void) Tcl_GetStringResult(interp);
#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResult --
 *
 *	Append a variable number of strings onto the interpreter's
 *	result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result of the interpreter given by the first argument is
 *	extended by the strings given by the second and following
 *	arguments (up to a terminating NULL argument).
 *
 *	If the string result is non-empty, the object result forced to
 *	be a duplicate of it first. There will be a string result
 *	afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    Tcl_AppendResultVA(interp, argList);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendElement --
 *
 *	Convert a string to a valid Tcl list element and append it to the
 *	result (which is ostensibly a list).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result in the interpreter given by the first argument is
 *	extended with a list element converted from string. A separator
 *	space is added before the converted list element unless the current
 *	result is empty, contains the single character "{", or ends in " {".
 *
 *	If the string result is empty, the object result is moved to the
 *	string result, then the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendElement(interp, stringPtr)
    Tcl_Interp *interp;		/* Interpreter whose result is to be
				 * extended. */
    CONST char *stringPtr;	/* String to convert to list element and
				 * add to result. */
{
    Interp *iPtr = (Interp *) interp;
    char *dst;
    int size;
    int flags;

    /*
     * If the string result is empty, move the object result to the
     * string result, then reset the object result.
     */

    (void) Tcl_GetStringResult(interp);

    /*
     * See how much space is needed, and grow the append buffer if
     * needed to accommodate the list element.
     */

    size = Tcl_ScanElement(stringPtr, &flags) + 1;
    if ((iPtr->result != iPtr->appendResult)
	    || (iPtr->appendResult[iPtr->appendUsed] != 0)
	    || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
       SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
    }

    /*
     * Convert the string into a list element and copy it to the
     * buffer that's forming, with a space separator if needed.
     */

    dst = iPtr->appendResult + iPtr->appendUsed;
    if (TclNeedSpace(iPtr->appendResult, dst)) {
	iPtr->appendUsed++;
	*dst = ' ';
	dst++;

	/*
	 * If we need a space to separate this element from preceding
	 * stuff, then this element will not lead a list, and need not
	 * have it's leading '#' quoted.
	 */

	flags |= TCL_DONT_QUOTE_HASH;
    }
    iPtr->appendUsed += Tcl_ConvertElement(stringPtr, dst, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * SetupAppendBuffer --
 *
 *	This procedure makes sure that there is an append buffer properly
 *	initialized, if necessary, from the interpreter's result, and
 *	that it has at least enough room to accommodate newSpace new
 *	bytes of information.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
SetupAppendBuffer(iPtr, newSpace)
    Interp *iPtr;		/* Interpreter whose result is being set up. */
    int newSpace;		/* Make sure that at least this many bytes
				 * of new information may be added. */
{
    int totalSpace;

    /*
     * Make the append buffer larger, if that's necessary, then copy the
     * result into the append buffer and make the append buffer the official
     * Tcl result.
     */

    if (iPtr->result != iPtr->appendResult) {
	/*
	 * If an oversized buffer was used recently, then free it up
	 * so we go back to a smaller buffer.  This avoids tying up
	 * memory forever after a large operation.
	 */

	if (iPtr->appendAvl > 500) {
	    ckfree(iPtr->appendResult);
	    iPtr->appendResult = NULL;
	    iPtr->appendAvl = 0;
	}
	iPtr->appendUsed = strlen(iPtr->result);
    } else if (iPtr->result[iPtr->appendUsed] != 0) {
	/*
	 * Most likely someone has modified a result created by
	 * Tcl_AppendResult et al. so that it has a different size.
	 * Just recompute the size.
	 */

	iPtr->appendUsed = strlen(iPtr->result);
    }
    
    totalSpace = newSpace + iPtr->appendUsed;
    if (totalSpace >= iPtr->appendAvl) {
	char *new;

	if (totalSpace < 100) {
	    totalSpace = 200;
	} else {
	    totalSpace *= 2;
	}
	new = (char *) ckalloc((unsigned) totalSpace);
	strcpy(new, iPtr->result);
	if (iPtr->appendResult != NULL) {
	    ckfree(iPtr->appendResult);
	}
	iPtr->appendResult = new;
	iPtr->appendAvl = totalSpace;
    } else if (iPtr->result != iPtr->appendResult) {
	strcpy(iPtr->appendResult, iPtr->result);
    }
    
    Tcl_FreeResult((Tcl_Interp *) iPtr);
    iPtr->result = iPtr->appendResult;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeResult --
 *
 *	This procedure frees up the memory associated with an interpreter's
 *	string result. It also resets the interpreter's result object.
 *	Tcl_FreeResult is most commonly used when a procedure is about to
 *	replace one result value with another.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees the memory associated with interp's string result and sets
 *	interp->freeProc to zero, but does not change interp->result or
 *	clear error state. Resets interp's result object to an unshared
 *	empty object.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FreeResult(interp)
    register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
    register Interp *iPtr = (Interp *) interp;
    
    if (iPtr->freeProc != NULL) {
	if (iPtr->freeProc == TCL_DYNAMIC) {
	    ckfree(iPtr->result);
	} else {
	    (*iPtr->freeProc)(iPtr->result);
	}
	iPtr->freeProc = 0;
    }
    
    ResetObjResult(iPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ResetResult --
 *
 *	This procedure resets both the interpreter's string and object
 *	results.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	It resets the result object to an unshared empty object. It
 *	then restores the interpreter's string result area to its default
 *	initialized state, freeing up any memory that may have been
 *	allocated. It also clears any error information for the interpreter.
 *
 *----------------------------------------------------------------------
 */

void







|
|





|
|
|
|













|
|

|


|



|



















|
<





|
|
<

|
|
<

















>

|
|
|
<
|
|




|
|











|
<





|
|
|

|
|
<





|

<


|
















|
|
|
|








|


|
|







|
|





|
|


|



|



|
|







>

|
|
|

>


|







|
|
|
|













|
|











|
|
|











|
|




|



















|









|

|







|
|
|









|








|








|
<





|
|







536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597

598
599
600
601
602
603
604

605
606
607

608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629

630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649

650
651
652
653
654
655
656
657
658
659
660

661
662
663
664
665
666
667

668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876

877
878
879
880
881
882
883
884
885
886
887
888
889
890

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetObjResult --
 *
 *	Returns an interpreter's result value as a Tcl object. The object's
 *	reference count is not modified; the caller must do that if it needs
 *	to hold on to a long-term reference to it.
 *
 * Results:
 *	The interpreter's result as an object.
 *
 * Side effects:
 *	If the interpreter has a non-empty string result, the result object is
 *	either empty or stale because some function set interp->result
 *	directly. If so, the string result is moved to the result object then
 *	the string result is reset.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetObjResult(interp)
    Tcl_Interp *interp;		/* Interpreter whose result to return. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_Obj *objResultPtr;
    int length;

    /*
     * If the string result is non-empty, move the string result to the object
     * result, then reset the string result.
     */

    if (*(iPtr->result) != 0) {
	ResetObjResult(iPtr);

	objResultPtr = iPtr->objResultPtr;
	length = strlen(iPtr->result);
	TclInitStringRep(objResultPtr, iPtr->result, length);

	if (iPtr->freeProc != NULL) {
	    if (iPtr->freeProc == TCL_DYNAMIC) {
		ckfree(iPtr->result);
	    } else {
		(*iPtr->freeProc)(iPtr->result);
	    }
	    iPtr->freeProc = 0;
	}
	iPtr->result = iPtr->resultSpace;
	iPtr->resultSpace[0] = 0;
    }
    return iPtr->objResultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResultVA --
 *
 *	Append a variable number of strings onto the interpreter's result.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result of the interpreter given by the first argument is extended
 *	by the strings in the va_list (up to a terminating NULL argument).

 *
 *	If the string result is non-empty, the object result forced to be a
 *	duplicate of it first. There will be a string result afterwards.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResultVA(interp, argList)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    va_list argList;		/* Variable argument list. */
{
    Tcl_Obj *objPtr = Tcl_GetObjResult(interp);

    if (Tcl_IsShared(objPtr)) {
	objPtr = Tcl_DuplicateObj(objPtr);
    }
    Tcl_AppendStringsToObjVA(objPtr, argList);
    Tcl_SetObjResult(interp, objPtr);

    /*
     * Strictly we should call Tcl_GetStringResult(interp) here to make sure
     * that interp->result is correct according to the old contract, but that
     * makes the performance of much code (e.g. in Tk) absolutely awful. So we

     * leave it out; code that really wants interp->result can just insert the
     * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
     */

#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
    /*
     * Ensure that the interp->result is legal so old Tcl 7.* code still
     * works. There's still embarrasingly much of it about...
     */

    (void) Tcl_GetStringResult(interp);
#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResult --
 *
 *	Append a variable number of strings onto the interpreter's result.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result of the interpreter given by the first argument is extended
 *	by the strings given by the second and following arguments (up to a
 *	terminating NULL argument).
 *
 *	If the string result is non-empty, the object result forced to be a
 *	duplicate of it first. There will be a string result afterwards.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResult(Tcl_Interp *interp, ...)
{

    va_list argList;

    va_start(argList, interp);
    Tcl_AppendResultVA(interp, argList);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendElement --
 *
 *	Convert a string to a valid Tcl list element and append it to the
 *	result (which is ostensibly a list).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result in the interpreter given by the first argument is extended
 *	with a list element converted from string. A separator space is added
 *	before the converted list element unless the current result is empty,
 *	contains the single character "{", or ends in " {".
 *
 *	If the string result is empty, the object result is moved to the
 *	string result, then the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendElement(interp, element)
    Tcl_Interp *interp;		/* Interpreter whose result is to be
				 * extended. */
    CONST char *element;	/* String to convert to list element and add
				 * to result. */
{
    Interp *iPtr = (Interp *) interp;
    char *dst;
    int size;
    int flags;

    /*
     * If the string result is empty, move the object result to the string
     * result, then reset the object result.
     */

    (void) Tcl_GetStringResult(interp);

    /*
     * See how much space is needed, and grow the append buffer if needed to
     * accommodate the list element.
     */

    size = Tcl_ScanElement(element, &flags) + 1;
    if ((iPtr->result != iPtr->appendResult)
	    || (iPtr->appendResult[iPtr->appendUsed] != 0)
	    || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
	SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
    }

    /*
     * Convert the string into a list element and copy it to the buffer that's
     * forming, with a space separator if needed.
     */

    dst = iPtr->appendResult + iPtr->appendUsed;
    if (TclNeedSpace(iPtr->appendResult, dst)) {
	iPtr->appendUsed++;
	*dst = ' ';
	dst++;

	/*
	 * If we need a space to separate this element from preceding stuff,
	 * then this element will not lead a list, and need not have it's
	 * leading '#' quoted.
	 */

	flags |= TCL_DONT_QUOTE_HASH;
    }
    iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * SetupAppendBuffer --
 *
 *	This function makes sure that there is an append buffer properly
 *	initialized, if necessary, from the interpreter's result, and that it
 *	has at least enough room to accommodate newSpace new bytes of
 *	information.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
SetupAppendBuffer(iPtr, newSpace)
    Interp *iPtr;		/* Interpreter whose result is being set up. */
    int newSpace;		/* Make sure that at least this many bytes of
				 * new information may be added. */
{
    int totalSpace;

    /*
     * Make the append buffer larger, if that's necessary, then copy the
     * result into the append buffer and make the append buffer the official
     * Tcl result.
     */

    if (iPtr->result != iPtr->appendResult) {
	/*
	 * If an oversized buffer was used recently, then free it up so we go
	 * back to a smaller buffer. This avoids tying up memory forever after
	 * a large operation.
	 */

	if (iPtr->appendAvl > 500) {
	    ckfree(iPtr->appendResult);
	    iPtr->appendResult = NULL;
	    iPtr->appendAvl = 0;
	}
	iPtr->appendUsed = strlen(iPtr->result);
    } else if (iPtr->result[iPtr->appendUsed] != 0) {
	/*
	 * Most likely someone has modified a result created by
	 * Tcl_AppendResult et al. so that it has a different size. Just
	 * recompute the size.
	 */

	iPtr->appendUsed = strlen(iPtr->result);
    }

    totalSpace = newSpace + iPtr->appendUsed;
    if (totalSpace >= iPtr->appendAvl) {
	char *new;

	if (totalSpace < 100) {
	    totalSpace = 200;
	} else {
	    totalSpace *= 2;
	}
	new = (char *) ckalloc((unsigned) totalSpace);
	strcpy(new, iPtr->result);
	if (iPtr->appendResult != NULL) {
	    ckfree(iPtr->appendResult);
	}
	iPtr->appendResult = new;
	iPtr->appendAvl = totalSpace;
    } else if (iPtr->result != iPtr->appendResult) {
	strcpy(iPtr->appendResult, iPtr->result);
    }

    Tcl_FreeResult((Tcl_Interp *) iPtr);
    iPtr->result = iPtr->appendResult;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeResult --
 *
 *	This function frees up the memory associated with an interpreter's
 *	string result. It also resets the interpreter's result object.
 *	Tcl_FreeResult is most commonly used when a function is about to
 *	replace one result value with another.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees the memory associated with interp's string result and sets
 *	interp->freeProc to zero, but does not change interp->result or clear
 *	error state. Resets interp's result object to an unshared empty
 *	object.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FreeResult(interp)
    register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
    register Interp *iPtr = (Interp *) interp;

    if (iPtr->freeProc != NULL) {
	if (iPtr->freeProc == TCL_DYNAMIC) {
	    ckfree(iPtr->result);
	} else {
	    (*iPtr->freeProc)(iPtr->result);
	}
	iPtr->freeProc = 0;
    }

    ResetObjResult(iPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ResetResult --
 *
 *	This function resets both the interpreter's string and object results.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	It resets the result object to an unshared empty object. It then
 *	restores the interpreter's string result area to its default
 *	initialized state, freeing up any memory that may have been
 *	allocated. It also clears any error information for the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
923
924
925
926
927
928
929


930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113

1114

1115


1116

1117
1118
1119
1120
1121
1122

1123
1124
1125


1126


1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154

1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
    if (iPtr->errorInfo) {
	/* Legacy support */
	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		iPtr->errorInfo, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(iPtr->errorInfo);
	iPtr->errorInfo = NULL;
    }


    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
	iPtr->returnOpts = NULL;
    }
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
}

/*
 *----------------------------------------------------------------------
 *
 * ResetObjResult --
 *
 *	Procedure used to reset an interpreter's Tcl result object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the interpreter's result object to an unshared empty string
 *	object with ref count one. It does not clear any error information
 *	in the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
ResetObjResult(iPtr)
    register Interp *iPtr;	/* Points to the interpreter whose result
				 * object should be reset. */
{
    register Tcl_Obj *objResultPtr = iPtr->objResultPtr;

    if (Tcl_IsShared(objResultPtr)) {
	TclDecrRefCount(objResultPtr);
	TclNewObj(objResultPtr);
	Tcl_IncrRefCount(objResultPtr);
	iPtr->objResultPtr = objResultPtr;
    } else {
	if ((objResultPtr->bytes != NULL)
	        && (objResultPtr->bytes != tclEmptyStringRep)) {
	    ckfree((char *) objResultPtr->bytes);
	}
	objResultPtr->bytes  = tclEmptyStringRep;
	objResultPtr->length = 0;
	TclFreeIntRep(objResultPtr);
	objResultPtr->typePtr = (Tcl_ObjType *) NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCodeVA --
 *
 *	This procedure is called to record machine-readable information
 *	about an error that is about to be returned.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this procedure, in a list form with each argument
 *	becoming one element of the list.  
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorCodeVA (interp, argList)
    Tcl_Interp *interp;		/* Interpreter in which to set errorCode */
    va_list argList;		/* Variable argument list. */
{
    Tcl_Obj *errorObj = Tcl_NewObj();

    /*
     * Scan through the arguments one at a time, appending them to
     * the errorCode field as list elements.
     */

    while (1) {
	char *elem = va_arg(argList, char *);
	if (elem == NULL) {
	    break;
	}
	Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
    }
    Tcl_SetObjErrorCode(interp, errorObj);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCode --
 *
 *	This procedure is called to record machine-readable information
 *	about an error that is about to be returned.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this procedure, in a list form with each argument
 *	becoming one element of the list.  
 *
 *----------------------------------------------------------------------
 */
	/* VARARGS2 */
void
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    Tcl_Interp *interp;
    va_list argList;

    /*
     * Scan through the arguments one at a time, appending them to
     * the errorCode field as list elements.
     */

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjErrorCode --
 *
 *	This procedure is called to record machine-readable information
 *	about an error that is about to be returned. The caller should
 *	build a list object up and pass it to this routine.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode field of the interp is set to the new value.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjErrorCode(interp, errorObjPtr)
    Tcl_Interp *interp;
    Tcl_Obj *errorObjPtr;
{
    Interp *iPtr = (Interp *) interp;
    
    if (iPtr->errorCode) {
	Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = errorObjPtr;
    Tcl_IncrRefCount(iPtr->errorCode);
}

/*
 *----------------------------------------------------------------------
 *
 * GetKeys --
 *
 *	Returns a Tcl_Obj * array of the standard keys used in the
 *	return options dictionary.
 *
 *	Broadly sharing one copy of these key values helps with both
 *	memory efficiency and dictionary lookup times.
 *
 * Results:
 *	A Tcl_Obj * array.
 *
 * Side effects:
 * 	First time called in a thread, creates the keys (allocating
 * 	memory) and arranges for their cleanup at thread exit.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj **
GetKeys()
{
    static Tcl_ThreadDataKey returnKeysKey;
    Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
	    (int) (KEY_LAST * sizeof(Tcl_Obj *)));

    if (keys[0] == NULL) {

	/* First call in this thread, create the keys... */


	int i;

	keys[KEY_CODE]		 = Tcl_NewStringObj("-code", -1);
	keys[KEY_ERRORCODE]	 = Tcl_NewStringObj("-errorcode", -1);
	keys[KEY_ERRORINFO]	 = Tcl_NewStringObj("-errorinfo", -1);
	keys[KEY_ERRORLINE]	 = Tcl_NewStringObj("-errorline", -1);
	keys[KEY_LEVEL]		 = Tcl_NewStringObj("-level", -1);
	keys[KEY_OPTIONS]	 = Tcl_NewStringObj("-options", -1);

	for (i = KEY_CODE; i < KEY_LAST; i++) {
	    Tcl_IncrRefCount(keys[i]);
	}


	/* ... and arrange for their clenaup. */


	Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
    }
    return keys;
}

/*
 *----------------------------------------------------------------------
 *
 * ReleaseKeys --
 *
 *	Called as a thread exit handler to cleanup return options
 *	dictionary keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	Frees memory.
 *
 *----------------------------------------------------------------------
 */

void
ReleaseKeys(clientData)
    ClientData clientData;
{
    Tcl_Obj **keys = (Tcl_Obj **)clientData;
    int i;

    for (i = KEY_CODE; i < KEY_LAST; i++) {
	Tcl_DecrRefCount(keys[i]);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcessReturn --
 *
 *	Does the work of the [return] command based on the code,
 *	level, and returnOpts arguments.  Note that the code argument
 *	must agree with the -code entry in returnOpts and the level
 *	argument must agree with the -level entry in returnOpts, as
 *	is the case for values returned from TclMergeReturnOptions.
 *
 * Results:
 *	Returns the return code the [return] command should return.
 *
 * Side effects:
 * 	None.
 *







>
>












|






|
|


















|














|
|






|
|





|






|
|

















|
|






|
|



|

|

<



|
|


|









|
|
|
















|












|
|

|
|





|
|










>

>
|
>
>

>
|
|
|
|
|
|
>



>
>
|
>
>










|
|










|





>










|
|
|
|
|







914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
    if (iPtr->errorInfo) {
	/* Legacy support */
	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		iPtr->errorInfo, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(iPtr->errorInfo);
	iPtr->errorInfo = NULL;
    }
    iPtr->returnLevel = 1;
    iPtr->returnCode = TCL_OK;
    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
	iPtr->returnOpts = NULL;
    }
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
}

/*
 *----------------------------------------------------------------------
 *
 * ResetObjResult --
 *
 *	Function used to reset an interpreter's Tcl result object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the interpreter's result object to an unshared empty string
 *	object with ref count one. It does not clear any error information in
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
ResetObjResult(iPtr)
    register Interp *iPtr;	/* Points to the interpreter whose result
				 * object should be reset. */
{
    register Tcl_Obj *objResultPtr = iPtr->objResultPtr;

    if (Tcl_IsShared(objResultPtr)) {
	TclDecrRefCount(objResultPtr);
	TclNewObj(objResultPtr);
	Tcl_IncrRefCount(objResultPtr);
	iPtr->objResultPtr = objResultPtr;
    } else {
	if ((objResultPtr->bytes != NULL)
		&& (objResultPtr->bytes != tclEmptyStringRep)) {
	    ckfree((char *) objResultPtr->bytes);
	}
	objResultPtr->bytes  = tclEmptyStringRep;
	objResultPtr->length = 0;
	TclFreeIntRep(objResultPtr);
	objResultPtr->typePtr = (Tcl_ObjType *) NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCodeVA --
 *
 *	This function is called to record machine-readable information about
 *	an error that is about to be returned.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this function, in a list form with each argument becoming
 *	one element of the list.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorCodeVA(interp, argList)
    Tcl_Interp *interp;		/* Interpreter in which to set errorCode */
    va_list argList;		/* Variable argument list. */
{
    Tcl_Obj *errorObj = Tcl_NewObj();

    /*
     * Scan through the arguments one at a time, appending them to the
     * errorCode field as list elements.
     */

    while (1) {
	char *elem = va_arg(argList, char *);
	if (elem == NULL) {
	    break;
	}
	Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
    }
    Tcl_SetObjErrorCode(interp, errorObj);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCode --
 *
 *	This function is called to record machine-readable information about
 *	an error that is about to be returned.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode field of the interp is modified to hold all of the
 *	arguments to this function, in a list form with each argument becoming
 *	one element of the list.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorCode(Tcl_Interp *interp, ...)
{

    va_list argList;

    /*
     * Scan through the arguments one at a time, appending them to the
     * errorCode field as list elements.
     */

    va_start(argList, interp);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjErrorCode --
 *
 *	This function is called to record machine-readable information about
 *	an error that is about to be returned. The caller should build a list
 *	object up and pass it to this routine.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode field of the interp is set to the new value.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjErrorCode(interp, errorObjPtr)
    Tcl_Interp *interp;
    Tcl_Obj *errorObjPtr;
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr->errorCode) {
	Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = errorObjPtr;
    Tcl_IncrRefCount(iPtr->errorCode);
}

/*
 *----------------------------------------------------------------------
 *
 * GetKeys --
 *
 *	Returns a Tcl_Obj * array of the standard keys used in the return
 *	options dictionary.
 *
 *	Broadly sharing one copy of these key values helps with both memory
 *	efficiency and dictionary lookup times.
 *
 * Results:
 *	A Tcl_Obj * array.
 *
 * Side effects:
 * 	First time called in a thread, creates the keys (allocating memory)
 * 	and arranges for their cleanup at thread exit.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj **
GetKeys()
{
    static Tcl_ThreadDataKey returnKeysKey;
    Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
	    (int) (KEY_LAST * sizeof(Tcl_Obj *)));

    if (keys[0] == NULL) {
	/*
	 * First call in this thread, create the keys...
	 */

	int i;

	keys[KEY_CODE]	    = Tcl_NewStringObj("-code", -1);
	keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1);
	keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1);
	keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1);
	keys[KEY_LEVEL]	    = Tcl_NewStringObj("-level", -1);
	keys[KEY_OPTIONS]   = Tcl_NewStringObj("-options", -1);

	for (i = KEY_CODE; i < KEY_LAST; i++) {
	    Tcl_IncrRefCount(keys[i]);
	}

	/*
	 * ... and arrange for their clenaup.
	 */

	Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
    }
    return keys;
}

/*
 *----------------------------------------------------------------------
 *
 * ReleaseKeys --
 *
 *	Called as a thread exit handler to cleanup return options dictionary
 *	keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	Frees memory.
 *
 *----------------------------------------------------------------------
 */

static void
ReleaseKeys(clientData)
    ClientData clientData;
{
    Tcl_Obj **keys = (Tcl_Obj **)clientData;
    int i;

    for (i = KEY_CODE; i < KEY_LAST; i++) {
	Tcl_DecrRefCount(keys[i]);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcessReturn --
 *
 *	Does the work of the [return] command based on the code, level, and
 *	returnOpts arguments. Note that the code argument must agree with the
 *	-code entry in returnOpts and the level argument must agree with the
 *	-level entry in returnOpts, as is the case for values returned from
 *	TclMergeReturnOptions.
 *
 * Results:
 *	Returns the return code the [return] command should return.
 *
 * Side effects:
 * 	None.
 *
1184
1185
1186
1187
1188
1189
1190

1191


1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207

1208
1209
1210
1211
1212
1213
1214
    int level;
    Tcl_Obj *returnOpts;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *valuePtr;
    Tcl_Obj **keys = GetKeys();


    /* Store the merged return options */


    if (iPtr->returnOpts != returnOpts) {
	if (iPtr->returnOpts) {
	    Tcl_DecrRefCount(iPtr->returnOpts);
	}
	iPtr->returnOpts = returnOpts;
	Tcl_IncrRefCount(iPtr->returnOpts);
    }

    if (code == TCL_ERROR) {
	if (iPtr->errorInfo) {
	    Tcl_DecrRefCount(iPtr->errorInfo);
	    iPtr->errorInfo = NULL;
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
	if (valuePtr != NULL) {
	    int infoLen;

	    (void) Tcl_GetStringFromObj(valuePtr, &infoLen);
	    if (infoLen) {
		iPtr->errorInfo = valuePtr;
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}







>
|
>
>
















>







1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
    int level;
    Tcl_Obj *returnOpts;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *valuePtr;
    Tcl_Obj **keys = GetKeys();

    /*
     * Store the merged return options.
     */

    if (iPtr->returnOpts != returnOpts) {
	if (iPtr->returnOpts) {
	    Tcl_DecrRefCount(iPtr->returnOpts);
	}
	iPtr->returnOpts = returnOpts;
	Tcl_IncrRefCount(iPtr->returnOpts);
    }

    if (code == TCL_ERROR) {
	if (iPtr->errorInfo) {
	    Tcl_DecrRefCount(iPtr->errorInfo);
	    iPtr->errorInfo = NULL;
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
	if (valuePtr != NULL) {
	    int infoLen;

	    (void) Tcl_GetStringFromObj(valuePtr, &infoLen);
	    if (infoLen) {
		iPtr->errorInfo = valuePtr;
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
 *----------------------------------------------------------------------
 *
 * TclMergeReturnOptions --
 *
 *	Parses, checks, and stores the options to the [return] command.
 *
 * Results:
 *	Returns TCL_ERROR is any of the option values are invalid.
 *	Otherwise, returns TCL_OK, and writes the returnOpts, code,
 *	and level values to the pointers provided.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

int
TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
    Tcl_Obj **optionsPtrPtr;	/* If not NULL, points to space for a
				 * (Tcl_Obj *) where the pointer to the
				 * merged return options dictionary should
				 * be written */
    int *codePtr;		/* If not NULL, points to space where the
				 * -code value should be written */
    int *levelPtr;		/* If not NULL, points to space where the
				 * -level value should be written */
{
    int code=TCL_OK;
    int level = 1;







|
|
|












|
|
|
<







1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267

1268
1269
1270
1271
1272
1273
1274
 *----------------------------------------------------------------------
 *
 * TclMergeReturnOptions --
 *
 *	Parses, checks, and stores the options to the [return] command.
 *
 * Results:
 *	Returns TCL_ERROR is any of the option values are invalid. Otherwise,
 *	returns TCL_OK, and writes the returnOpts, code, and level values to
 *	the pointers provided.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

int
TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
    Tcl_Obj **optionsPtrPtr;	/* If not NULL, points to space for a (Tcl_Obj
				 * *) where the pointer to the merged return
				 * options dictionary should be written */

    int *codePtr;		/* If not NULL, points to space where the
				 * -code value should be written */
    int *levelPtr;		/* If not NULL, points to space where the
				 * -level value should be written */
{
    int code=TCL_OK;
    int level = 1;
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288

1289


1290
1291
1292
1293
1294
1295
1296
1297
1298
1299

	if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
	    Tcl_DictSearch search;
	    int done = 0;
	    Tcl_Obj *keyPtr;
	    Tcl_Obj *dict = objv[1];

	    nestedOptions:
	    if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
		    &search, &keyPtr, &valuePtr, &done)) {

		/* Value is not a legal dictionary */


		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "bad ",
			compare, " value: expected dictionary but got \"",
			TclGetString(objv[1]), "\"", (char *) NULL);
		goto error;
	    }

	    while (!done) {
		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);







|
|
|
>
|
>
>

|
|







1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308

	if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
	    Tcl_DictSearch search;
	    int done = 0;
	    Tcl_Obj *keyPtr;
	    Tcl_Obj *dict = objv[1];

	nestedOptions:
	    if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
		    &keyPtr, &valuePtr, &done)) {
		/*
		 * Value is not a legal dictionary.
		 */

		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "bad ", compare,
			" value: expected dictionary but got \"",
			TclGetString(objv[1]), "\"", (char *) NULL);
		goto error;
	    }

	    while (!done) {
		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
1307
1308
1309
1310
1311
1312
1313

1314


1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334

1335


1336
1337
1338
1339

1340


1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353

1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364

1365

1366


1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
	    }

	} else {
	    Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
	}
    }


    /* Check for bogus -code value */


    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
    if ((valuePtr != NULL) 
	    && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
	static CONST char *returnCodes[] = {
	    "ok", "error", "return", "break", "continue", NULL
	};

	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
		NULL, TCL_EXACT, &code)) {
	    /* Value is not a legal return code */
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad completion code \"",
		    TclGetString(valuePtr),
		    "\": must be ok, error, return, break, ",
		    "continue, or an integer", (char *) NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
    }


    /* Check for bogus -level value */


    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
    if (valuePtr != NULL) {
	if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) 
		|| (level < 0)) {

	    /* Value is not a legal level */


	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad -level value: ",
		"expected non-negative integer but got \"",
		TclGetString(valuePtr), "\"", (char *) NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
    }

    /* 
     * Convert [return -code return -level X] to
     * [return -code ok -level X+1]
     */

    if (code == TCL_RETURN) {
	level++;
	code = TCL_OK;
    }

    if (codePtr != NULL) {
	*codePtr = code;
    }
    if (levelPtr != NULL) {
	*levelPtr = level;
    }

    if (optionsPtrPtr == NULL) {

	/* Not passing back the options (?!), so clean them up */


	Tcl_DecrRefCount(returnOpts);
    } else {
	*optionsPtrPtr = returnOpts;
    }
    return TCL_OK;

error:
    Tcl_DecrRefCount(returnOpts);
    return TCL_ERROR;
}

/*
 *-------------------------------------------------------------------------
 *







>
|
>
>

|


















>
|
>
>


|

>
|
>
>


|
|





|
|
<

>











>

>
|
>
>






|







1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369

1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
	    }

	} else {
	    Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
	}
    }

    /*
     * Check for bogus -code value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
    if ((valuePtr != NULL)
	    && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
	static CONST char *returnCodes[] = {
	    "ok", "error", "return", "break", "continue", NULL
	};

	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
		NULL, TCL_EXACT, &code)) {
	    /* Value is not a legal return code */
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad completion code \"",
		    TclGetString(valuePtr),
		    "\": must be ok, error, return, break, ",
		    "continue, or an integer", (char *) NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
    }

    /*
     * Check for bogus -level value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
    if (valuePtr != NULL) {
	if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level))
		|| (level < 0)) {
	    /*
	     * Value is not a legal level.
	     */

	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad -level value: ",
		    "expected non-negative integer but got \"",
		    TclGetString(valuePtr), "\"", (char *) NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
    }

    /*
     * Convert [return -code return -level X] to [return -code ok -level X+1]

     */

    if (code == TCL_RETURN) {
	level++;
	code = TCL_OK;
    }

    if (codePtr != NULL) {
	*codePtr = code;
    }
    if (levelPtr != NULL) {
	*levelPtr = level;
    }

    if (optionsPtrPtr == NULL) {
	/*
	 * Not passing back the options (?!), so clean them up.
	 */

	Tcl_DecrRefCount(returnOpts);
    } else {
	*optionsPtrPtr = returnOpts;
    }
    return TCL_OK;

  error:
    Tcl_DecrRefCount(returnOpts);
    return TCL_ERROR;
}

/*
 *-------------------------------------------------------------------------
 *
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425

1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
		Tcl_NewIntObj(result));
	Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
		Tcl_NewIntObj(0));
    }

    if (result == TCL_ERROR) {
	/*
	 * When result was an error, fill in any missing values
	 * for -errorinfo, -errorcode, and -errorline
	 */

        Tcl_AddObjErrorInfo(interp, "", -1);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
		Tcl_NewIntObj(iPtr->errorLine));
    }
    return options;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_SetReturnOptions --
 *
 *	Accepts an interp and a  dictionary of return options, and sets
 *	the return options of the interp to match the dictionary.
 *
 * Results:
 *	A standard status code.  Usually TCL_OK, but TCL_ERROR if an
 *	invalid option value was found in the dictionary.  If a -level
 *	value of 0 is in the dictionary, then the -code value in the
 *	dictionary will be returned (TCL_OK default).
 *
 * Side effects:
 *	Sets the state of the interp.
 *
 *-------------------------------------------------------------------------
 */








|
|

>
|













|
|


|
|
|
|







1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
		Tcl_NewIntObj(result));
	Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
		Tcl_NewIntObj(0));
    }

    if (result == TCL_ERROR) {
	/*
	 * When result was an error, fill in any missing values for
	 * -errorinfo, -errorcode, and -errorline
	 */

	Tcl_AddObjErrorInfo(interp, "", -1);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
		Tcl_NewIntObj(iPtr->errorLine));
    }
    return options;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_SetReturnOptions --
 *
 *	Accepts an interp and a dictionary of return options, and sets the
 *	return options of the interp to match the dictionary.
 *
 * Results:
 *	A standard status code. Usually TCL_OK, but TCL_ERROR if an invalid
 *	option value was found in the dictionary. If a -level value of 0 is in
 *	the dictionary, then the -code value in the dictionary will be
 *	returned (TCL_OK default).
 *
 * Side effects:
 *	Sets the state of the interp.
 *
 *-------------------------------------------------------------------------
 */

1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533








}

/*
 *-------------------------------------------------------------------------
 *
 * TclTransferResult --
 *
 *	Copy the result (and error information) from one interp to 
 *	another.  Used when one interp has caused another interp to 
 *	evaluate a script and then wants to transfer the results back
 *	to itself.
 *
 *	This routine copies the string reps of the result and error 
 *	information.  It does not simply increment the refcounts of the
 *	result and error information objects themselves.
 *	It is not legal to exchange objects between interps, because an
 *	object may be kept alive by one interp, but have an internal rep 
 *	that is only valid while some other interp is alive.  
 *
 * Results:
 *	The target interp's result is set to a copy of the source interp's
 *	result.  The source's errorInfo field may be transferred to the
 *	target's errorInfo field, and the source's errorCode field may be
 *	transferred to the target's errorCode field.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */
	
void
TclTransferResult(sourceInterp, result, targetInterp)
    Tcl_Interp *sourceInterp;	/* Interp whose result and error information
				 * should be moved to the target interp.  
				 * After moving result, this interp's result 
				 * is reset. */
    int result;			/* TCL_OK if just the result should be copied, 
				 * TCL_ERROR if both the result and error 
				 * information should be copied. */
    Tcl_Interp *targetInterp;	/* Interp where result and error information 
				 * should be stored.  If source and target
				 * are the same, nothing is done. */
{
    Interp *iPtr = (Interp *) targetInterp;

    if (sourceInterp == targetInterp) {
	return;
    }

    Tcl_SetReturnOptions(targetInterp,
	    Tcl_GetReturnOptions(sourceInterp, result));
    iPtr->flags &= ~(ERR_ALREADY_LOGGED);
    Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
    Tcl_ResetResult(sourceInterp);
}















|
|
|
<

|
|
|
|
|
|



|








|



|
|

|
|

|
|
|













>
>
>
>
>
>
>
>
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510

1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
}

/*
 *-------------------------------------------------------------------------
 *
 * TclTransferResult --
 *
 *	Copy the result (and error information) from one interp to another.
 *	Used when one interp has caused another interp to evaluate a script
 *	and then wants to transfer the results back to itself.

 *
 *	This routine copies the string reps of the result and error
 *	information. It does not simply increment the refcounts of the result
 *	and error information objects themselves. It is not legal to exchange
 *	objects between interps, because an object may be kept alive by one
 *	interp, but have an internal rep that is only valid while some other
 *	interp is alive.
 *
 * Results:
 *	The target interp's result is set to a copy of the source interp's
 *	result. The source's errorInfo field may be transferred to the
 *	target's errorInfo field, and the source's errorCode field may be
 *	transferred to the target's errorCode field.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

void
TclTransferResult(sourceInterp, result, targetInterp)
    Tcl_Interp *sourceInterp;	/* Interp whose result and error information
				 * should be moved to the target interp.
				 * After moving result, this interp's result
				 * is reset. */
    int result;			/* TCL_OK if just the result should be copied,
				 * TCL_ERROR if both the result and error
				 * information should be copied. */
    Tcl_Interp *targetInterp;	/* Interp where result and error information
				 * should be stored. If source and target are
				 * the same, nothing is done. */
{
    Interp *iPtr = (Interp *) targetInterp;

    if (sourceInterp == targetInterp) {
	return;
    }

    Tcl_SetReturnOptions(targetInterp,
	    Tcl_GetReturnOptions(sourceInterp, result));
    iPtr->flags &= ~(ERR_ALREADY_LOGGED);
    Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
    Tcl_ResetResult(sourceInterp);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclScan.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30

31
32

33
34
35
36
37
38
39
40
41
42
43
/* 
 * tclScan.c --
 *
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclScan.c,v 1.16 2004/10/06 15:59:25 dgp Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

#define SCAN_NOSKIP	0x1		  /* Don't skip blanks. */
#define SCAN_SUPPRESS	0x2		  /* Suppress assignment. */
#define SCAN_UNSIGNED	0x4		  /* Read an unsigned value. */
#define SCAN_WIDTH	0x8		  /* A width value was supplied. */


#define SCAN_SIGNOK	0x10		  /* A +/- character is allowed. */
#define SCAN_NODIGITS	0x20		  /* No digits have been scanned. */
#define SCAN_NOZERO	0x40		  /* No zero digits have been scanned. */
#define SCAN_XOK	0x80		  /* An 'x' is allowed. */
#define SCAN_PTOK	0x100		  /* Decimal point is allowed. */
#define SCAN_EXPOK	0x200		  /* An exponent is allowed. */


#define SCAN_LONGER	0x400		  /* Asked for a wide value. */


/*
 * The following structure contains the information associated with
 * a character set.
 */

typedef struct CharSet {
    int exclude;		/* 1 if this is an exclusion set. */
    int nchars;
    Tcl_UniChar *chars;
    int nranges;
|






|
|

|








|
|
|
|

>
|
|
|
|
|
|
>

|
>


|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
/*
 * tclScan.c --
 *
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclScan.c,v 1.16.2.6 2005/09/28 00:23:46 dgp Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

#define SCAN_NOSKIP	0x1		/* Don't skip blanks. */
#define SCAN_SUPPRESS	0x2		/* Suppress assignment. */
#define SCAN_UNSIGNED	0x4		/* Read an unsigned value. */
#define SCAN_WIDTH	0x8		/* A width value was supplied. */

#if 0
#define SCAN_SIGNOK	0x10		/* A +/- character is allowed. */
#define SCAN_NODIGITS	0x20		/* No digits have been scanned. */
#define SCAN_NOZERO	0x40		/* No zero digits have been scanned. */
#define SCAN_XOK	0x80		/* An 'x' is allowed. */
#define SCAN_PTOK	0x100		/* Decimal point is allowed. */
#define SCAN_EXPOK	0x200		/* An exponent is allowed. */
#endif

#define SCAN_LONGER	0x400		/* Asked for a wide value. */
#define SCAN_BIG	0x800		/* Asked for a bignum value. */

/*
 * The following structure contains the information associated with a
 * character set.
 */

typedef struct CharSet {
    int exclude;		/* 1 if this is an exclusion set. */
    int nchars;
    Tcl_UniChar *chars;
    int nranges;
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
		    int numVars, int *totalVars));

/*
 *----------------------------------------------------------------------
 *
 * BuildCharSet --
 *
 *	This function examines a character set format specification
 *	and builds a CharSet containing the individual characters and
 *	character ranges specified.
 *
 * Results:
 *	Returns the next format position.
 *
 * Side effects:
 *	Initializes the charset.
 *
 *----------------------------------------------------------------------
 */

static char *
BuildCharSet(cset, format)
    CharSet *cset;
    char *format;		/* Points to first char of set. */
{
    Tcl_UniChar ch, start;
    int offset, nranges;
    char *end;

    memset(cset, 0, sizeof(CharSet));
    
    offset = Tcl_UtfToUniChar(format, &ch);
    if (ch == '^') {
	cset->exclude = 1;
	format += offset;
	offset = Tcl_UtfToUniChar(format, &ch);
    }
    end = format + offset;







|
|
|




















|







61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
		    int numVars, int *totalVars));

/*
 *----------------------------------------------------------------------
 *
 * BuildCharSet --
 *
 *	This function examines a character set format specification and builds
 *	a CharSet containing the individual characters and character ranges
 *	specified.
 *
 * Results:
 *	Returns the next format position.
 *
 * Side effects:
 *	Initializes the charset.
 *
 *----------------------------------------------------------------------
 */

static char *
BuildCharSet(cset, format)
    CharSet *cset;
    char *format;		/* Points to first char of set. */
{
    Tcl_UniChar ch, start;
    int offset, nranges;
    char *end;

    memset(cset, 0, sizeof(CharSet));

    offset = Tcl_UtfToUniChar(format, &ch);
    if (ch == '^') {
	cset->exclude = 1;
	format += offset;
	offset = Tcl_UtfToUniChar(format, &ch);
    }
    end = format + offset;
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
    if (ch == ']' || ch == '-') {
	cset->chars[cset->nchars++] = ch;
	format += Tcl_UtfToUniChar(format, &ch);
    }
    while (ch != ']') {
	if (*format == '-') {
	    /*
	     * This may be the first character of a range, so don't add
	     * it yet.
	     */

	    start = ch;
	} else if (ch == '-') {
	    /*
	     * Check to see if this is the last character in the set, in which
	     * case it is not a range and we should add the previous character







|
|







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
    if (ch == ']' || ch == '-') {
	cset->chars[cset->nchars++] = ch;
	format += Tcl_UtfToUniChar(format, &ch);
    }
    while (ch != ']') {
	if (*format == '-') {
	    /*
	     * This may be the first character of a range, so don't add it
	     * yet.
	     */

	    start = ch;
	} else if (ch == '-') {
	    /*
	     * Check to see if this is the last character in the set, in which
	     * case it is not a range and we should add the previous character
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

		if (start < ch) {
		    cset->ranges[cset->nranges].start = start;
		    cset->ranges[cset->nranges].end = ch;
		} else {
		    cset->ranges[cset->nranges].start = ch;
		    cset->ranges[cset->nranges].end = start;
		}		    
		cset->nranges++;
	    }
	} else {
	    cset->chars[cset->nchars++] = ch;
	}
	format += Tcl_UtfToUniChar(format, &ch);
    }







|







158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

		if (start < ch) {
		    cset->ranges[cset->nranges].start = start;
		    cset->ranges[cset->nranges].end = ch;
		} else {
		    cset->ranges[cset->nranges].start = ch;
		    cset->ranges[cset->nranges].end = start;
		}
		cset->nranges++;
	    }
	} else {
	    cset->chars[cset->nchars++] = ch;
	}
	format += Tcl_UtfToUniChar(format, &ch);
    }
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
 *
 *----------------------------------------------------------------------
 */

static int
CharInSet(cset, c)
    CharSet *cset;
    int c;			/* Character to test, passed as int because
				 * of non-ANSI prototypes. */
{
    Tcl_UniChar ch = (Tcl_UniChar) c;
    int i, match = 0;
    for (i = 0; i < cset->nchars; i++) {
	if (cset->chars[i] == ch) {
	    match = 1;
	    break;
	}
    }
    if (!match) {
	for (i = 0; i < cset->nranges; i++) {
	    if ((cset->ranges[i].start <= ch)
		    && (ch <= cset->ranges[i].end)) {
		match = 1;
		break;
	    }
	}
    }
    return (cset->exclude ? !match : match);    
}

/*
 *----------------------------------------------------------------------
 *
 * ReleaseCharSet --
 *







|
|


















|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
 *
 *----------------------------------------------------------------------
 */

static int
CharInSet(cset, c)
    CharSet *cset;
    int c;			/* Character to test, passed as int because of
				 * non-ANSI prototypes. */
{
    Tcl_UniChar ch = (Tcl_UniChar) c;
    int i, match = 0;
    for (i = 0; i < cset->nchars; i++) {
	if (cset->chars[i] == ch) {
	    match = 1;
	    break;
	}
    }
    if (!match) {
	for (i = 0; i < cset->nranges; i++) {
	    if ((cset->ranges[i].start <= ch)
		    && (ch <= cset->ranges[i].end)) {
		match = 1;
		break;
	    }
	}
    }
    return (cset->exclude ? !match : match);
}

/*
 *----------------------------------------------------------------------
 *
 * ReleaseCharSet --
 *
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
}

/*
 *----------------------------------------------------------------------
 *
 * ValidateFormat --
 *
 *	Parse the format string and verify that it is properly formed
 *	and that there are exactly enough variables on the command line.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May place an error in the interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
ValidateFormat(interp, format, numVars, totalSubs)
    Tcl_Interp *interp;		/* Current interpreter. */
    char *format;		/* The format string. */
    int numVars;		/* The number of variables passed to the
				 * scan command. */
    int *totalSubs;		/* The number of variables that will be
				 * required. */
{
#define STATIC_LIST_SIZE 16
    int gotXpg, gotSequential, value, i, flags;
    char *end;
    Tcl_UniChar ch;
    int staticAssign[STATIC_LIST_SIZE];
    int *nassign = staticAssign;
    int objIndex, xpgSize, nspace = STATIC_LIST_SIZE;
    char buf[TCL_UTF_MAX+1];

    /*
     * Initialize an array that records the number of times a variable
     * is assigned to by the format string.  We use this to detect if
     * a variable is multiply assigned or left unassigned.
     */

    if (numVars > nspace) {
	nassign = (int*)ckalloc(sizeof(int) * numVars);
	nspace = numVars;
    }
    for (i = 0; i < nspace; i++) {







|
|














|
|













|
|
|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
}

/*
 *----------------------------------------------------------------------
 *
 * ValidateFormat --
 *
 *	Parse the format string and verify that it is properly formed and that
 *	there are exactly enough variables on the command line.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May place an error in the interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
ValidateFormat(interp, format, numVars, totalSubs)
    Tcl_Interp *interp;		/* Current interpreter. */
    char *format;		/* The format string. */
    int numVars;		/* The number of variables passed to the scan
				 * command. */
    int *totalSubs;		/* The number of variables that will be
				 * required. */
{
#define STATIC_LIST_SIZE 16
    int gotXpg, gotSequential, value, i, flags;
    char *end;
    Tcl_UniChar ch;
    int staticAssign[STATIC_LIST_SIZE];
    int *nassign = staticAssign;
    int objIndex, xpgSize, nspace = STATIC_LIST_SIZE;
    char buf[TCL_UTF_MAX+1];

    /*
     * Initialize an array that records the number of times a variable is
     * assigned to by the format string. We use this to detect if a variable
     * is multiply assigned or left unassigned.
     */

    if (numVars > nspace) {
	nassign = (int*)ckalloc(sizeof(int) * numVars);
	nspace = numVars;
    }
    for (i = 0; i < nspace; i++) {
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368






369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413

414





415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

467
468
469
470
471
472
473
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	    goto xpgCheckDone;
	}

	if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
	    /*
	     * Check for an XPG3-style %n$ specification.  Note: there
	     * must not be a mixture of XPG3 specs and non-XPG3 specs
	     * in the same format string.
	     */

	    value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
	    if (*end != '$') {
		goto notXpg;
	    }
	    format = end+1;
	    format += Tcl_UtfToUniChar(format, &ch);
	    gotXpg = 1;
	    if (gotSequential) {
		goto mixedXPG;
	    }
	    objIndex = value - 1;
	    if ((objIndex < 0) || (numVars && (objIndex >= numVars))) {
		goto badIndex;
	    } else if (numVars == 0) {
		/*
		 * In the case where no vars are specified, the user can
		 * specify %9999$ legally, so we have to consider special
		 * rules for growing the assign array.  'value' is
		 * guaranteed to be > 0.
		 */
		xpgSize = (xpgSize > value) ? xpgSize : value;
	    }
	    goto xpgCheckDone;
	}

	notXpg:
	gotSequential = 1;
	if (gotXpg) {
	    mixedXPG:
	    Tcl_SetResult(interp,
		    "cannot mix \"%\" and \"%n$\" conversion specifiers",
		    TCL_STATIC);
	    goto error;
	}

	xpgCheckDone:
	/*
	 * Parse any width specifier.
	 */

	if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
	    value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
	    flags |= SCAN_WIDTH;
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':






	case 'L':
	    flags |= SCAN_LONGER;
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
	    goto badIndex;
	}

	/*
	 * Handle the various field types.
	 */

	switch (ch) {
	    case 'c':
                if (flags & SCAN_WIDTH) {
		    Tcl_SetResult(interp,
			    "field width may not be specified in %c conversion",
			    TCL_STATIC);
		    goto error;
                }
		/*
		 * Fall through!
		 */
	    case 'n':
	    case 's':
		if (flags & SCAN_LONGER) {
		invalidLonger:
		    buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		    Tcl_AppendResult(interp,
			   "'l' modifier may not be specified in %", buf,
			   " conversion", NULL);
		    goto error;
		}
		/*
		 * Fall through!
		 */
	    case 'd':
	    case 'e':
	    case 'f':
	    case 'g':
	    case 'i':
	    case 'o':
	    case 'u':

	    case 'x':





 		break;
		/*
		 * Bracket terms need special checking
		 */
	    case '[':
		if (flags & SCAN_LONGER) {
		    goto invalidLonger;
		}
		if (*format == '\0') {
		    goto badSet;
		}
		format += Tcl_UtfToUniChar(format, &ch);
		if (ch == '^') {
		    if (*format == '\0') {
			goto badSet;
		    }
		    format += Tcl_UtfToUniChar(format, &ch);
		}
		if (ch == ']') {
		    if (*format == '\0') {
			goto badSet;
		    }
		    format += Tcl_UtfToUniChar(format, &ch);
		}
		while (ch != ']') {
		    if (*format == '\0') {
			goto badSet;
		    }
		    format += Tcl_UtfToUniChar(format, &ch);
		}
		break;
	    badSet:
		Tcl_SetResult(interp, "unmatched [ in format string",
			TCL_STATIC);
		goto error;
	    default:
	    {
		char buf[TCL_UTF_MAX+1];

		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp, "bad scan conversion character \"",
			buf, "\"", NULL);
		goto error;
	    }
	}
	if (!(flags & SCAN_SUPPRESS)) {
	    if (objIndex >= nspace) {
		/*
		 * Expand the nassign buffer.  If we are using XPG specifiers,
		 * make sure that we grow to a large enough size.  xpgSize is
		 * guaranteed to be at least one larger than objIndex.
		 */

		value = nspace;
		if (xpgSize) {
		    nspace = xpgSize;
		} else {
		    nspace += STATIC_LIST_SIZE;
		}
		if (nassign == staticAssign) {







|
|
|



















|
|






|


|






|
















>
>
>
>
>
>















|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|












|
|


>







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	    goto xpgCheckDone;
	}

	if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
	    /*
	     * Check for an XPG3-style %n$ specification. Note: there must
	     * not be a mixture of XPG3 specs and non-XPG3 specs in the same
	     * format string.
	     */

	    value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
	    if (*end != '$') {
		goto notXpg;
	    }
	    format = end+1;
	    format += Tcl_UtfToUniChar(format, &ch);
	    gotXpg = 1;
	    if (gotSequential) {
		goto mixedXPG;
	    }
	    objIndex = value - 1;
	    if ((objIndex < 0) || (numVars && (objIndex >= numVars))) {
		goto badIndex;
	    } else if (numVars == 0) {
		/*
		 * In the case where no vars are specified, the user can
		 * specify %9999$ legally, so we have to consider special
		 * rules for growing the assign array. 'value' is guaranteed
		 * to be > 0.
		 */
		xpgSize = (xpgSize > value) ? xpgSize : value;
	    }
	    goto xpgCheckDone;
	}

    notXpg:
	gotSequential = 1;
	if (gotXpg) {
	mixedXPG:
	    Tcl_SetResult(interp,
		    "cannot mix \"%\" and \"%n$\" conversion specifiers",
		    TCL_STATIC);
	    goto error;
	}

    xpgCheckDone:
	/*
	 * Parse any width specifier.
	 */

	if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
	    value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
	    flags |= SCAN_WIDTH;
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += Tcl_UtfToUniChar(format, &ch);
		break;
	    }
	case 'L':
	    flags |= SCAN_LONGER;
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
	    goto badIndex;
	}

	/*
	 * Handle the various field types.
	 */

	switch (ch) {
	case 'c':
	    if (flags & SCAN_WIDTH) {
		Tcl_SetResult(interp,
			"field width may not be specified in %c conversion",
			TCL_STATIC);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'n':
	case 's':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
	    invalidFieldSize:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp,
			"field size modifier may not be specified in %", buf,
			" conversion", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'd':
	case 'e':
	case 'f':
	case 'g':
	case 'i':
	case 'o':
	case 'x':
	    break;
	case 'u':
	    if (flags & SCAN_BIG) {
		Tcl_SetResult(interp,
			"unsigned bignum scans are invalid", TCL_STATIC);
		goto error;
	    }
	    break;
	    /*
	     * Bracket terms need special checking
	     */
	case '[':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
		goto invalidFieldSize;
	    }
	    if (*format == '\0') {
		goto badSet;
	    }
	    format += Tcl_UtfToUniChar(format, &ch);
	    if (ch == '^') {
		if (*format == '\0') {
		    goto badSet;
		}
		format += Tcl_UtfToUniChar(format, &ch);
	    }
	    if (ch == ']') {
		if (*format == '\0') {
		    goto badSet;
		}
		format += Tcl_UtfToUniChar(format, &ch);
	    }
	    while (ch != ']') {
		if (*format == '\0') {
		    goto badSet;
		}
		format += Tcl_UtfToUniChar(format, &ch);
	    }
	    break;
	badSet:
	    Tcl_SetResult(interp, "unmatched [ in format string",
		    TCL_STATIC);
	    goto error;
	default:
	    {
		char buf[TCL_UTF_MAX+1];

		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp, "bad scan conversion character \"",
			buf, "\"", NULL);
		goto error;
	    }
	}
	if (!(flags & SCAN_SUPPRESS)) {
	    if (objIndex >= nspace) {
		/*
		 * Expand the nassign buffer. If we are using XPG specifiers,
		 * make sure that we grow to a large enough size. xpgSize is
		 * guaranteed to be at least one larger than objIndex.
		 */

		value = nspace;
		if (xpgSize) {
		    nspace = xpgSize;
		} else {
		    nspace += STATIC_LIST_SIZE;
		}
		if (nassign == staticAssign) {
500
501
502
503
504
505
506

507

508
509
510
511
512
513


514

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
	}
    }
    if (totalSubs) {
	*totalSubs = numVars;
    }
    for (i = 0; i < numVars; i++) {
	if (nassign[i] > 1) {

	    Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC);

	    goto error;
	} else if (!xpgSize && (nassign[i] == 0)) {
	    /*
	     * If the space is empty, and xpgSize is 0 (means XPG wasn't
	     * used, and/or numVars != 0), then too many vars were given
	     */


	    Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC);

	    goto error;
	}
    }

    if (nassign != staticAssign) {
	ckfree((char *)nassign);
    }
    return TCL_OK;

    badIndex:
    if (gotXpg) {
	Tcl_SetResult(interp, "\"%n$\" argument index out of range",
		TCL_STATIC);
    } else {
	Tcl_SetResult(interp, 
		"different numbers of variable names and field specifiers",
		TCL_STATIC);
    }

    error:
    if (nassign != staticAssign) {
	ckfree((char *)nassign);
    }
    return TCL_ERROR;
#undef STATIC_LIST_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanObjCmd --
 *
 *	This procedure is invoked to process the "scan" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







>
|
>



|
|

>
>
|
>









|




|




|












|
|







516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
	}
    }
    if (totalSubs) {
	*totalSubs = numVars;
    }
    for (i = 0; i < numVars; i++) {
	if (nassign[i] > 1) {
	    Tcl_SetResult(interp,
		    "variable is assigned by multiple \"%n$\" conversion specifiers",
		    TCL_STATIC);
	    goto error;
	} else if (!xpgSize && (nassign[i] == 0)) {
	    /*
	     * If the space is empty, and xpgSize is 0 (means XPG wasn't used,
	     * and/or numVars != 0), then too many vars were given
	     */

	    Tcl_SetResult(interp,
		    "variable is not assigned by any conversion specifiers",
		    TCL_STATIC);
	    goto error;
	}
    }

    if (nassign != staticAssign) {
	ckfree((char *)nassign);
    }
    return TCL_OK;

  badIndex:
    if (gotXpg) {
	Tcl_SetResult(interp, "\"%n$\" argument index out of range",
		TCL_STATIC);
    } else {
	Tcl_SetResult(interp,
		"different numbers of variable names and field specifiers",
		TCL_STATIC);
    }

  error:
    if (nassign != staticAssign) {
	ckfree((char *)nassign);
    }
    return TCL_ERROR;
#undef STATIC_LIST_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanObjCmd --
 *
 *	This function is invoked to process the "scan" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586







587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674

675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699






700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724


725
726
727
728
729

730
731
732


733
734
735
736
737

738
739
740


741
742
743
744
745

746
747
748


749
750
751
752
753

754
755
756
757
758


759
760
761

762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899

900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048

















































1049
1050
1051
1052
1053
1054


1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068

1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164

1165
1166


1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180

1181
1182
1183
1184
1185
1186
1187
1188
1189
1190

1191
1192
1193
1194
1195
1196
1197
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    char *string, *end, *baseString;
    char op = 0;
    int base = 0;
    int underflow = 0;
    size_t width;
    long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
    Tcl_WideInt wideValue;
#endif
    Tcl_UniChar ch, sch;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];			  /* Temporary buffer to hold scanned
					   * number strings before they are
					   * passed to strtoul. */








    if (objc < 3) {
        Tcl_WrongNumArgs(interp, 1, objv,
		"string format ?varName varName ...?");
	return TCL_ERROR;
    }

    format = Tcl_GetStringFromObj(objv[2], NULL);
    numVars = objc-3;

    /*
     * Check for errors in the format string.
     */
    
    if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
	return TCL_ERROR;
    }

    /*
     * Allocate space for the result objects.
     */

    if (totalVars > 0) {
	objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars);
	for (i = 0; i < totalVars; i++) {
	    objs[i] = NULL;
	}
    }

    string = Tcl_GetStringFromObj(objv[1], NULL);
    baseString = string;

    /*
     * Iterate over the format string filling in the result objects until
     * we reach the end of input, the end of the format string, or there
     * is a mismatch.
     */

    objIndex = 0;
    nconversions = 0;
    while (*format != '\0') {

	format += Tcl_UtfToUniChar(format, &ch);

	flags = 0;

	/*
	 * If we see whitespace in the format, skip whitespace in the string.
	 */

	if (Tcl_UniCharIsSpace(ch)) {
	    offset = Tcl_UtfToUniChar(string, &sch);
	    while (Tcl_UniCharIsSpace(sch)) {
		if (*string == '\0') {
		    goto done;
		}
		string += offset;
		offset = Tcl_UtfToUniChar(string, &sch);
	    }
	    continue;
	}
	    
	if (ch != '%') {
	    literal:
	    if (*string == '\0') {
		underflow = 1;
		goto done;
	    }
	    string += Tcl_UtfToUniChar(string, &sch);
	    if (ch != sch) {
		goto done;
	    }
	    continue;
	}

	format += Tcl_UtfToUniChar(format, &ch);
	if (ch == '%') {
	    goto literal;
	}

	/*
	 * Check for assignment suppression ('*') or an XPG3-style
	 * assignment ('%n$').
	 */

	if (ch == '*') {
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */

	    value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
	    if (*end == '$') {
		format = end+1;
		format += Tcl_UtfToUniChar(format, &ch);
		objIndex = (int) value - 1;
	    }
	}

	/*
	 * Parse any width specifier.
	 */

	if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
	    width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
	    format += Tcl_UtfToUniChar(format, &ch);
	} else {
	    width = 0;
	}

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':






	case 'L':
	    flags |= SCAN_LONGER;
	    /*
	     * Fall through so we skip to the next character.
	     */
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	/*
	 * Handle the various field types.
	 */

	switch (ch) {
	    case 'n':
		if (!(flags & SCAN_SUPPRESS)) {
		    objPtr = Tcl_NewIntObj(string - baseString);
		    Tcl_IncrRefCount(objPtr);
		    objs[objIndex++] = objPtr;
		}
		nconversions++;
		continue;

	    case 'd':
		op = 'i';


		base = 10;
		fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
		lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif

		break;
	    case 'i':
		op = 'i';


		base = 0;
		fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
		lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif

		break;
	    case 'o':
		op = 'i';


		base = 8;
		fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
		lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif

		break;
	    case 'x':
		op = 'i';


		base = 16;
		fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
		lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif

		break;
	    case 'u':
		op = 'i';
		base = 10;
		flags |= SCAN_UNSIGNED;


		fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
		lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;

#endif
		break;

	    case 'f':
	    case 'e':
	    case 'g':
		op = 'f';
		break;

	    case 's':
		op = 's';
		break;

	    case 'c':
		op = 'c';
		flags |= SCAN_NOSKIP;
		break;
	    case '[':
		op = '[';
		flags |= SCAN_NOSKIP;
		break;
	}

	/*
	 * At this point, we will need additional characters from the
	 * string to proceed.
	 */

	if (*string == '\0') {
	    underflow = 1;
	    goto done;
	}
	
	/*
	 * Skip any leading whitespace at the beginning of a field unless
	 * the format suppresses this behavior.
	 */

	if (!(flags & SCAN_NOSKIP)) {
	    while (*string != '\0') {
		offset = Tcl_UtfToUniChar(string, &sch);
		if (!Tcl_UniCharIsSpace(sch)) {
		    break;
		}
		string += offset;
	    }
	    if (*string == '\0') {
		underflow = 1;
		goto done;
	    }
	}

	/*
	 * Perform the requested scanning operation.
	 */
	
	switch (op) {
	    case 's':
		/*
		 * Scan a string up to width characters or whitespace.
		 */

		if (width == 0) {
		    width = (size_t) ~0;
		}
		end = string;
		while (*end != '\0') {
		    offset = Tcl_UtfToUniChar(end, &sch);
		    if (Tcl_UniCharIsSpace(sch)) {
			break;
		    }
		    end += offset;
		    if (--width == 0) {
			break;
		    }
		}
		if (!(flags & SCAN_SUPPRESS)) {
		    objPtr = Tcl_NewStringObj(string, end-string);
		    Tcl_IncrRefCount(objPtr);
		    objs[objIndex++] = objPtr;
		}
		string = end;
		break;

	    case '[': {
		CharSet cset;

		if (width == 0) {
		    width = (size_t) ~0;
		}
		end = string;

		format = BuildCharSet(&cset, format);
		while (*end != '\0') {
		    offset = Tcl_UtfToUniChar(end, &sch);
		    if (!CharInSet(&cset, (int)sch)) {
			break;
		    }
		    end += offset;
		    if (--width == 0) {
			break;
		    }
		}
		ReleaseCharSet(&cset);

		if (string == end) {
		    /*
		     * Nothing matched the range, stop processing
		     */
		    goto done;
		}
		if (!(flags & SCAN_SUPPRESS)) {
		    objPtr = Tcl_NewStringObj(string, end-string);
		    Tcl_IncrRefCount(objPtr);
		    objs[objIndex++] = objPtr;
		}
		string = end;
		
		break;
	    }
	    case 'c':
		/*
		 * Scan a single Unicode character.
		 */

		string += Tcl_UtfToUniChar(string, &sch);
		if (!(flags & SCAN_SUPPRESS)) {
		    objPtr = Tcl_NewIntObj((int)sch);
		    Tcl_IncrRefCount(objPtr);
		    objs[objIndex++] = objPtr;
		}
		break;

	    case 'i':
		/*
		 * Scan an unsigned or signed integer.
		 */


		if ((width == 0) || (width > sizeof(buf) - 1)) {
		    width = sizeof(buf) - 1;
		}
		flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
		for (end = buf; width > 0; width--) {
		    switch (*string) {
			/*
			 * The 0 digit has special meaning at the beginning of
			 * a number.  If we are unsure of the base, it
			 * indicates that we are in base 8 or base 16 (if it is
			 * followed by an 'x').
			 *
			 * 8.1 - 8.3.4 incorrectly handled 0x... base-16
			 * cases for %x by not reading the 0x as the
			 * auto-prelude for base-16. [Bug #495213]
			 */
			case '0':
			    if (base == 0) {
				base = 8;
				flags |= SCAN_XOK;
			    }
			    if (base == 16) {
				flags |= SCAN_XOK;
			    }
			    if (flags & SCAN_NOZERO) {
				flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS
					| SCAN_NOZERO);
			    } else {
				flags &= ~(SCAN_SIGNOK | SCAN_XOK
					| SCAN_NODIGITS);
			    }
			    goto addToInt;

			case '1': case '2': case '3': case '4':
			case '5': case '6': case '7':
			    if (base == 0) {
				base = 10;
			    }
			    flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
			    goto addToInt;

			case '8': case '9':
			    if (base == 0) {
				base = 10;
			    }
			    if (base <= 8) {
				break;
			    }
			    flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
			    goto addToInt;

			case 'A': case 'B': case 'C':
			case 'D': case 'E': case 'F': 
			case 'a': case 'b': case 'c':
			case 'd': case 'e': case 'f':
			    if (base <= 10) {
				break;
			    }
			    flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
			    goto addToInt;

			case '+': case '-':
			    if (flags & SCAN_SIGNOK) {
				flags &= ~SCAN_SIGNOK;
				goto addToInt;
			    }
			    break;

			case 'x': case 'X':
			    if ((flags & SCAN_XOK) && (end == buf+1)) {
				base = 16;
				flags &= ~SCAN_XOK;
				goto addToInt;
			    }
			    break;
		    }

		    /*
		     * We got an illegal character so we are done accumulating.
		     */

		    break;

		    addToInt:
		    /*
		     * Add the character to the temporary buffer.
		     */

		    *end++ = *string++;
		    if (*string == '\0') {
			break;
		    }
		}

		/*
		 * Check to see if we need to back up because we only got a
		 * sign or a trailing x after a 0.
		 */

		if (flags & SCAN_NODIGITS) {
		    if (*string == '\0') {
			underflow = 1;
		    }
		    goto done;
		} else if (end[-1] == 'x' || end[-1] == 'X') {
		    end--;
		    string--;
		}


		/*
		 * Scan the value from the temporary buffer.  If we are
		 * returning a large unsigned value, we have to convert it back
		 * to a string since Tcl only supports signed values.
		 */

		if (!(flags & SCAN_SUPPRESS)) {
		    *end = '\0';
#ifndef TCL_WIDE_INT_IS_LONG
		    if (flags & SCAN_LONGER) {
			wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base);
			if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
			    /* INTL: ISO digit */
			    sprintf(buf, "%" TCL_LL_MODIFIER "u",
				    (Tcl_WideUInt)wideValue);
			    objPtr = Tcl_NewStringObj(buf, -1);
			} else {
			    objPtr = Tcl_NewWideIntObj(wideValue);
			}
		    } else {
#endif /* !TCL_WIDE_INT_IS_LONG */
			value = (long) (*fn)(buf, NULL, base);
			if ((flags & SCAN_UNSIGNED) && (value < 0)) {
			    sprintf(buf, "%lu", value); /* INTL: ISO digit */
			    objPtr = Tcl_NewStringObj(buf, -1);
			} else if ((flags & SCAN_LONGER)
				|| (unsigned long) value > UINT_MAX) {
			    objPtr = Tcl_NewLongObj(value);
			} else {
			    objPtr = Tcl_NewIntObj(value);
			}
#ifndef TCL_WIDE_INT_IS_LONG
		    }
#endif
		    Tcl_IncrRefCount(objPtr);
		    objs[objIndex++] = objPtr;
		}

		break;


















































	    case 'f':
		/*
		 * Scan a floating point number
		 */



		if ((width == 0) || (width > sizeof(buf) - 1)) {
		    width = sizeof(buf) - 1;
		}
		flags &= ~SCAN_LONGER;
		flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK;
		for (end = buf; width > 0; width--) {
		    switch (*string) {
			case '0': case '1': case '2': case '3':
			case '4': case '5': case '6': case '7':
			case '8': case '9':
			    flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS);
			    goto addToFloat;
			case '+': case '-':
			    if (flags & SCAN_SIGNOK) {

				flags &= ~SCAN_SIGNOK;
				goto addToFloat;
			    }
			    break;
			case '.':
			    if (flags & SCAN_PTOK) {
				flags &= ~(SCAN_SIGNOK | SCAN_PTOK);
				goto addToFloat;
			    }
			    break;
			case 'e': case 'E':
			    /*
			     * An exponent is not allowed until there has
			     * been at least one digit.
			     */

			    if ((flags & (SCAN_NODIGITS | SCAN_EXPOK))
				    == SCAN_EXPOK) {
				flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK))
				    | SCAN_SIGNOK | SCAN_NODIGITS;
				goto addToFloat;
			    }
			    break;
		    }

		    /*
		     * We got an illegal character so we are done accumulating.
		     */

		    break;

		    addToFloat:
		    /*
		     * Add the character to the temporary buffer.
		     */

		    *end++ = *string++;
		    if (*string == '\0') {
			break;
		    }
		}

		/*
		 * Check to see if we need to back up because we saw a
		 * trailing 'e' or sign.
		 */

		if (flags & SCAN_NODIGITS) {
		    if (flags & SCAN_EXPOK) {
			/*
			 * There were no digits at all so scanning has
			 * failed and we are done.
			 */
			if (*string == '\0') {
			    underflow = 1;
			}
			goto done;
		    }

		    /*
		     * We got a bad exponent ('e' and maybe a sign).
		     */

		    end--;
		    string--;
		    if (*end != 'e' && *end != 'E') {
			end--;
			string--;
		    }
		}

		/*
		 * Scan the value from the temporary buffer.
		 */

		if (!(flags & SCAN_SUPPRESS)) {
		    double dvalue;
		    *end = '\0';
		    dvalue = strtod(buf, NULL);
		    objPtr = Tcl_NewDoubleObj(dvalue);
		    Tcl_IncrRefCount(objPtr);
		    objs[objIndex++] = objPtr;

		}
		break;
	}
	nconversions++;
    }

    done:
    result = 0;
    code = TCL_OK;

    if (numVars) {
	/*
	 * In this case, variables were specified (classic scan)
	 */

	for (i = 0; i < totalVars; i++) {
	    if (objs[i] != NULL) {


		result++;
		if (Tcl_ObjSetVar2(interp, objv[i+3], NULL,
			objs[i], 0) == NULL) {
		    Tcl_AppendResult(interp, "couldn't set variable \"",
			    Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
		    code = TCL_ERROR;
		}
		Tcl_DecrRefCount(objs[i]);
	    }
	}
    } else {
	/*
	 * Here no vars were specified, we want a list returned (inline scan)
	 */

	objPtr = Tcl_NewObj();
	for (i = 0; i < totalVars; i++) {
	    if (objs[i] != NULL) {
		Tcl_ListObjAppendElement(NULL, objPtr, objs[i]);
		Tcl_DecrRefCount(objs[i]);
	    } else {
		/*
		 * More %-specifiers than matching chars, so we
		 * just spit out empty strings for these
		 */

		Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
	    }
	}
    }
    if (objs != NULL) {
	ckfree((char*) objs);
    }







|

<


<
<
<

<



|
|
|
>
>
>
>
>
>
>


|










|



















|
|
|





>



















|

|

















|
|





|
>
|
|
|









|
|











>
>
>
>
>
>














|
|
|
|
|
|
|
|

|
|
>
>
|
|

|

>
|
|
|
>
>
|
|

|

>
|
|
|
>
>
|
|

|

>
|
|
|
>
>
|
|

|

>
|
|
|
<
|
>
>
|

|
>

|

|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|



|
|






|

|
|



















|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|

|
|
|
|

>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|

|

|
|
|
|

|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|

<
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|

|
|
|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
|
|

>
>
|
|
|
<
<
|
|
|
|
<
<
|
<
|
>
|
<
|
<
|
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
|
|
|
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
>
|
<




|





|

>

|
>
>
|
|
<
|
|
|
|
|
<





>







|
|

>







585
586
587
588
589
590
591
592
593

594
595



596

597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799

800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971

972
973

974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052

1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151


1152
1153
1154
1155


1156

1157
1158
1159

1160

1161
1162









1163








1164



1165
1166
1167




1168





1169














1170
1171
1172



1173


















1174
1175
1176

1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195

1196
1197
1198
1199
1200

1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    CONST char *string, *end, *baseString;
    char op = 0;

    int underflow = 0;
    size_t width;



    Tcl_WideInt wideValue;

    Tcl_UniChar ch, sch;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];		/* Temporary buffer to hold scanned number
				 * strings before they are passed to
				 * strtoul. */
#if 0
    int base = 0;
    long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#endif
#endif

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"string format ?varName varName ...?");
	return TCL_ERROR;
    }

    format = Tcl_GetStringFromObj(objv[2], NULL);
    numVars = objc-3;

    /*
     * Check for errors in the format string.
     */

    if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
	return TCL_ERROR;
    }

    /*
     * Allocate space for the result objects.
     */

    if (totalVars > 0) {
	objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars);
	for (i = 0; i < totalVars; i++) {
	    objs[i] = NULL;
	}
    }

    string = Tcl_GetStringFromObj(objv[1], NULL);
    baseString = string;

    /*
     * Iterate over the format string filling in the result objects until we
     * reach the end of input, the end of the format string, or there is a
     * mismatch.
     */

    objIndex = 0;
    nconversions = 0;
    while (*format != '\0') {
	int parseFlag = 0;
	format += Tcl_UtfToUniChar(format, &ch);

	flags = 0;

	/*
	 * If we see whitespace in the format, skip whitespace in the string.
	 */

	if (Tcl_UniCharIsSpace(ch)) {
	    offset = Tcl_UtfToUniChar(string, &sch);
	    while (Tcl_UniCharIsSpace(sch)) {
		if (*string == '\0') {
		    goto done;
		}
		string += offset;
		offset = Tcl_UtfToUniChar(string, &sch);
	    }
	    continue;
	}

	if (ch != '%') {
	literal:
	    if (*string == '\0') {
		underflow = 1;
		goto done;
	    }
	    string += Tcl_UtfToUniChar(string, &sch);
	    if (ch != sch) {
		goto done;
	    }
	    continue;
	}

	format += Tcl_UtfToUniChar(format, &ch);
	if (ch == '%') {
	    goto literal;
	}

	/*
	 * Check for assignment suppression ('*') or an XPG3-style assignment
	 * ('%n$').
	 */

	if (ch == '*') {
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	} else if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */
	    char *formatEnd;
	    value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
	    if (*formatEnd == '$') {
		format = formatEnd+1;
		format += Tcl_UtfToUniChar(format, &ch);
		objIndex = (int) value - 1;
	    }
	}

	/*
	 * Parse any width specifier.
	 */

	if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */
	    width = strtoul(format-1, &format, 10);	/* INTL: "C" locale. */
	    format += Tcl_UtfToUniChar(format, &ch);
	} else {
	    width = 0;
	}

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += Tcl_UtfToUniChar(format, &ch);
		break;
	    }
	case 'L':
	    flags |= SCAN_LONGER;
	    /*
	     * Fall through so we skip to the next character.
	     */
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	/*
	 * Handle the various field types.
	 */

	switch (ch) {
	case 'n':
	    if (!(flags & SCAN_SUPPRESS)) {
		objPtr = Tcl_NewIntObj(string - baseString);
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }
	    nconversions++;
	    continue;

	case 'd':
	    op = 'i';
	    parseFlag = TCL_PARSE_DECIMAL_ONLY;
#if 0
	    base = 10;
	    fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
#endif
	    break;
	case 'i':
	    op = 'i';
	    parseFlag = TCL_PARSE_SCAN_PREFIXES;
#if 0
	    base = 0;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
#endif
	    break;
	case 'o':
	    op = 'i';
	    parseFlag = TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
#if 0
	    base = 8;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;
	case 'x':
	    op = 'i';
	    parseFlag = TCL_PARSE_HEXADECIMAL_ONLY;
#if 0
	    base = 16;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;
	case 'u':
	    op = 'i';

	    flags |= SCAN_UNSIGNED;
#if 0
	    base = 10;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;

	case 'f':
	case 'e':
	case 'g':
	    op = 'f';
	    break;

	case 's':
	    op = 's';
	    break;

	case 'c':
	    op = 'c';
	    flags |= SCAN_NOSKIP;
	    break;
	case '[':
	    op = '[';
	    flags |= SCAN_NOSKIP;
	    break;
	}

	/*
	 * At this point, we will need additional characters from the string
	 * to proceed.
	 */

	if (*string == '\0') {
	    underflow = 1;
	    goto done;
	}

	/*
	 * Skip any leading whitespace at the beginning of a field unless the
	 * format suppresses this behavior.
	 */

	if (!(flags & SCAN_NOSKIP)) {
	    while (*string != '\0') {
		offset = Tcl_UtfToUniChar(string, &sch);
		if (!Tcl_UniCharIsSpace(sch)) {
		    break;
		}
		string += offset;
	    }
	    if (*string == '\0') {
		underflow = 1;
		goto done;
	    }
	}

	/*
	 * Perform the requested scanning operation.
	 */

	switch (op) {
	case 's':
	    /*
	     * Scan a string up to width characters or whitespace.
	     */

	    if (width == 0) {
		width = (size_t) ~0;
	    }
	    end = string;
	    while (*end != '\0') {
		offset = Tcl_UtfToUniChar(end, &sch);
		if (Tcl_UniCharIsSpace(sch)) {
		    break;
		}
		end += offset;
		if (--width == 0) {
		    break;
		}
	    }
	    if (!(flags & SCAN_SUPPRESS)) {
		objPtr = Tcl_NewStringObj(string, end-string);
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }
	    string = end;
	    break;

	case '[': {
	    CharSet cset;

	    if (width == 0) {
		width = (size_t) ~0;
	    }
	    end = string;

	    format = BuildCharSet(&cset, format);
	    while (*end != '\0') {
		offset = Tcl_UtfToUniChar(end, &sch);
		if (!CharInSet(&cset, (int)sch)) {
		    break;
		}
		end += offset;
		if (--width == 0) {
		    break;
		}
	    }
	    ReleaseCharSet(&cset);

	    if (string == end) {
		/*
		 * Nothing matched the range, stop processing.
		 */
		goto done;
	    }
	    if (!(flags & SCAN_SUPPRESS)) {
		objPtr = Tcl_NewStringObj(string, end-string);
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }
	    string = end;

	    break;
	}
	case 'c':
	    /*
	     * Scan a single Unicode character.
	     */

	    string += Tcl_UtfToUniChar(string, &sch);
	    if (!(flags & SCAN_SUPPRESS)) {
		objPtr = Tcl_NewIntObj((int)sch);
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }
	    break;

	case 'i':
	    /*
	     * Scan an unsigned or signed integer.
	     */

#if 0
	    if ((width == 0) || (width > sizeof(buf) - 1)) {
		width = sizeof(buf) - 1;
	    }
	    flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
	    for (end = buf; width > 0; width--) {
		switch (*string) {
		    /*
		     * The 0 digit has special meaning at the beginning of a
		     * number. If we are unsure of the base, it indicates that
		     * we are in base 8 or base 16 (if it is followed by an
		     * 'x').
		     *
		     * 8.1 - 8.3.4 incorrectly handled 0x... base-16 cases for
		     * %x by not reading the 0x as the auto-prelude for
		     * base-16. [Bug #495213]
		     */
		case '0':
		    if (base == 0) {
			base = 8;
			flags |= SCAN_XOK;
		    }
		    if (base == 16) {
			flags |= SCAN_XOK;
		    }
		    if (flags & SCAN_NOZERO) {
			flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO);

		    } else {
			flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);

		    }
		    goto addToInt;

		case '1': case '2': case '3': case '4':
		case '5': case '6': case '7':
		    if (base == 0) {
			base = 10;
		    }
		    flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
		    goto addToInt;

		case '8': case '9':
		    if (base == 0) {
			base = 10;
		    }
		    if (base <= 8) {
			break;
		    }
		    flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
		    goto addToInt;

		case 'A': case 'B': case 'C':
		case 'D': case 'E': case 'F':
		case 'a': case 'b': case 'c':
		case 'd': case 'e': case 'f':
		    if (base <= 10) {
			break;
		    }
		    flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
		    goto addToInt;

		case '+': case '-':
		    if (flags & SCAN_SIGNOK) {
			flags &= ~SCAN_SIGNOK;
			goto addToInt;
		    }
		    break;

		case 'x': case 'X':
		    if ((flags & SCAN_XOK) && (end == buf+1)) {
			base = 16;
			flags &= ~SCAN_XOK;
			goto addToInt;
		    }
		    break;
		}

		/*
		 * We got an illegal character so we are done accumulating.
		 */

		break;

	    addToInt:
		/*
		 * Add the character to the temporary buffer.
		 */

		*end++ = *string++;
		if (*string == '\0') {
		    break;
		}
	    }

	    /*
	     * Check to see if we need to back up because we only got a sign
	     * or a trailing x after a 0.
	     */

	    if (flags & SCAN_NODIGITS) {
		if (*string == '\0') {
		    underflow = 1;
		}
		goto done;
	    } else if (end[-1] == 'x' || end[-1] == 'X') {
		end--;
		string--;
	    }


	    /*
	     * Scan the value from the temporary buffer. If we are returning a
	     * large unsigned value, we have to convert it back to a string
	     * since Tcl only supports signed values.
	     */

	    if (!(flags & SCAN_SUPPRESS)) {
		*end = '\0';
#ifndef TCL_WIDE_INT_IS_LONG
		if (flags & SCAN_LONGER) {
		    wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base);
		    if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
			/* INTL: ISO digit */
			sprintf(buf, "%" TCL_LL_MODIFIER "u",
				(Tcl_WideUInt)wideValue);
			objPtr = Tcl_NewStringObj(buf, -1);
		    } else {
			objPtr = Tcl_NewWideIntObj(wideValue);
		    }
		} else {
#endif /* !TCL_WIDE_INT_IS_LONG */
		    value = (long) (*fn)(buf, NULL, base);
		    if ((flags & SCAN_UNSIGNED) && (value < 0)) {
			sprintf(buf, "%lu", value);	/* INTL: ISO digit */
			objPtr = Tcl_NewStringObj(buf, -1);
		    } else if ((flags & SCAN_LONGER)
			    || (unsigned long) value > UINT_MAX) {
			objPtr = Tcl_NewLongObj(value);
		    } else {
			objPtr = Tcl_NewIntObj(value);
		    }
#ifndef TCL_WIDE_INT_IS_LONG
		}
#endif
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }

	    break;
#else
	    objPtr = Tcl_NewLongObj(0);
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;
	    }
	    if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
		    TCL_PARSE_INTEGER_ONLY | parseFlag) != TCL_OK) {
		Tcl_DecrRefCount(objPtr);
		/* TODO: set underflow?  test scan-4.44 */
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		break;
	    }
	    if (flags & SCAN_LONGER) {
		if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
		    wideValue = ~(Tcl_WideUInt)0 >> 1;	/* WIDE_MAX */
		    if (Tcl_GetString(objPtr)[0] == '-') {
			wideValue++;	/* WIDE_MAX + 1 = WIDE_MIN */
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
		    sprintf(buf, "%" TCL_LL_MODIFIER "u",
			    (Tcl_WideUInt)wideValue);
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    Tcl_SetWideIntObj(objPtr, wideValue);
		}
	    } else if (!(flags & SCAN_BIG)) {
		if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (Tcl_GetString(objPtr)[0] == '-') {
			value = LONG_MIN;
		    } else {
			value = LONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
		    sprintf(buf, "%lu", value);	/* INTL: ISO digit */
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    Tcl_SetLongObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;
#endif

	case 'f':
	    /*
	     * Scan a floating point number
	     */

	    objPtr = Tcl_NewDoubleObj(0.0);
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;
	    }


	    if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
			       TCL_PARSE_DECIMAL_ONLY) != TCL_OK) {
		/* TODO: set underflow?  test scan-4.55 */
		Tcl_DecrRefCount(objPtr);


		goto done;

	    } else if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		string = end;

	    } else {

		double dvalue;
		if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {









#ifdef ACCEPT_NAN








		    if (objPtr->typePtr == &tclDoubleType) {



			dValue = objPtr->internalRep.doubleValue;
		    } else
#endif




		    {





		    Tcl_DecrRefCount(objPtr);














		    goto done;
		    }
		}



		Tcl_SetDoubleObj(objPtr, dvalue);


















		objs[objIndex++] = objPtr;
		string = end;
	    }

	}
	nconversions++;
    }

  done:
    result = 0;
    code = TCL_OK;

    if (numVars) {
	/*
	 * In this case, variables were specified (classic scan).
	 */

	for (i = 0; i < totalVars; i++) {
	    if (objs[i] == NULL) {
		continue;
	    }
	    result++;
	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {

		Tcl_AppendResult(interp, "couldn't set variable \"",
			TclGetString(objv[i+3]), "\"", (char *) NULL);
		code = TCL_ERROR;
	    }
	    Tcl_DecrRefCount(objs[i]);

	}
    } else {
	/*
	 * Here no vars were specified, we want a list returned (inline scan)
	 */

	objPtr = Tcl_NewObj();
	for (i = 0; i < totalVars; i++) {
	    if (objs[i] != NULL) {
		Tcl_ListObjAppendElement(NULL, objPtr, objs[i]);
		Tcl_DecrRefCount(objs[i]);
	    } else {
		/*
		 * More %-specifiers than matching chars, so we just spit out
		 * empty strings for these.
		 */

		Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
	    }
	}
    }
    if (objs != NULL) {
	ckfree((char*) objs);
    }
1209
1210
1211
1212
1213
1214
1215








	} else if (numVars) {
	    objPtr = Tcl_NewIntObj(result);
	}
	Tcl_SetObjResult(interp, objPtr);
    }
    return code;
}















>
>
>
>
>
>
>
>
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
	} else if (numVars) {
	    objPtr = Tcl_NewIntObj(result);
	}
	Tcl_SetObjResult(interp, objPtr);
    }
    return code;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Added generic/tclStrToD.c.





































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
/*
 *----------------------------------------------------------------------
 *
 * tclDouble.c --
 *
 *	This file contains a collection of procedures for managing
 *	conversions to/from floating-point in Tcl.  They include
 *	TclParseNumber, which parses numbers from strings; TclDoubleDigits,
 *	which formats numbers into strings of digits, and procedures for
 *	interconversion among 'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.39 2005/09/26 20:16:53 kennykb Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>
#include <float.h>
#include <limits.h>
#include <math.h>
#include <ctype.h>
#include <tommath.h>

/*
 * Define TIP_114_FORMATS to accept 0b and 0o for binary and octal strings.
 * Define KILL_OCTAL as well as TIP_114_FORMATS to suppress interpretation
 * of numbers with leading zero as octal. (Ceterum censeo: numeros octonarios
 * delendos esse.)
 */

#define	TIP_114_FORMATS
#undef	KILL_OCTAL

#ifndef TIP_114_FORMATS
#undef	KILL_OCTAL
#endif

/*
 * This code supports (at least hypothetically), IBM, Cray, VAX and
 * IEEE-754 floating point; of these, only IEEE-754 can represent NaN.
 * IEEE-754 can be uniquely determined by radix and by the widths of
 * significand and exponent.
 */

#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
#   define IEEE_FLOATING_POINT
#endif

/*
 * gcc on x86 needs access to rounding controls, because of a questionable
 * feature where it retains intermediate results as IEEE 'long double' values
 * somewhat unpredictably.  It is tempting to include fpu_control.h, but
 * that file exists only on Linux; it is missing on Cygwin and MinGW. Most 
 * gcc-isms and ix86-isms are factored out here.
 */

#if defined(__GNUC__) && defined(__i386)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
#   define FPU_IEEE_ROUNDING	0x027f
#   define ADJUST_FPU_CONTROL_WORD
#endif

/*
 * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN.
 * Everyone else uses 7ff8000000000000.  (Why, HP, why?)
 */

#ifdef __hppa
#   define NAN_START 0x7ff4
#   define NAN_MASK (((Tcl_WideUInt) 1) << 50)
#else
#   define NAN_START 0x7ff8
#   define NAN_MASK (((Tcl_WideUInt) 1) << 51)
#endif

/* The powers of ten that can be represented exactly as wide integers */

static int maxpow10_wide;
static Tcl_WideUInt *pow10_wide;

/* The number of decimal digits that fit in an mp_digit */

static int log10_DIGIT_MAX;

/* The powers of ten that can be represented exactly as IEEE754 doubles. */

#define MAXPOW 22
static double pow10 [MAXPOW+1];

static int mmaxpow;		/* Largest power of ten that can be
				 * represented exactly in a 'double'. */

/* Inexact higher powers of ten */

static CONST double pow_10_2_n [] = {
    1.0,
    100.0,
    10000.0,
    1.0e+8,
    1.0e+16,
    1.0e+32,
    1.0e+64,
    1.0e+128,
    1.0e+256
};

 /* Logarithm of the floating point radix. */

static int log2FLT_RADIX;

/* Number of bits in a double's significand */

static int mantBits;

/* Table of powers of 5**(2**n), up to 5**256 */

static mp_int pow5[9];

/* The smallest representable double */

static double tiny;

/* The maximum number of digits to the left of the decimal point of a
 * double. */

static int maxDigits;

/* The maximum number of digits to the right of the decimal point in a
 * double. */

static int minDigits;

/* Number of mp_digit's needed to hold the significand of a double */

static int mantDIGIT;

/* Static functions defined in this file */

static int AccumulateDecimalDigit _ANSI_ARGS_((unsigned, int, 
					       Tcl_WideUInt*, mp_int*, int));
static double MakeLowPrecisionDouble _ANSI_ARGS_((int signum,
						  Tcl_WideUInt significand,
						  int nSigDigs,
						  int exponent));
static double MakeHighPrecisionDouble _ANSI_ARGS_((int signum,
						   mp_int* significand,
						   int nSigDigs,
						   int exponent));
static double MakeNaN _ANSI_ARGS_(( int signum, Tcl_WideUInt tag ));
static double RefineApproximation _ANSI_ARGS_((double approx,
					       mp_int* exactSignificand,
					       int exponent));
static double AbsoluteValue(double v, int* signum);
static int GetIntegerTimesPower(double v, mp_int* r, int* e);
static double BignumToBiasedFrExp _ANSI_ARGS_(( mp_int* big, int* machexp ));
static double Pow10TimesFrExp _ANSI_ARGS_(( int exponent,
					    double fraction,
					    int* machexp ));
static double SafeLdExp _ANSI_ARGS_(( double fraction, int exponent ));


/*
 *----------------------------------------------------------------------
 *
 * TclParseNumber --
 *
 *	Place a "numeric" internal representation on a Tcl object.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Stores an internal representation appropriate to the string.
 *	The internal representation may be an integer, a wide integer,
 *	a bignum, or a double.
 *
 * TclMakeObjNumeric is called as a common scanner in routines
 * that expect numbers in Tcl_Obj's.  It scans the string representation
 * of a given Tcl_Obj and stores an internal rep that represents
 * a "canonical" version of its numeric value.  The value of the
 * canonicalization is that a routine can determine simply by
 * examining the type pointer whether an object LooksLikeInt,
 * what size of integer is needed to hold it, and similar questions,
 * and never needs to refer back to the string representation, even
 * for "impure" objects.
 *
 * The 'strPtr' and 'endPtrPtr' arguments allow for recognizing a number
 * that is in a substring of a Tcl_Obj, for example a screen metric or
 * "end-" index.  If 'strPtr' is not NULL, it designates where the
 * number begins within the string.  (The default is the start of
 * objPtr's string rep, which will be constructed if necessary.)
 *
 * If 'strPtr' is supplied, 'objPtr' may be NULL.  In this case,
 * no internal representation will be generated; instead, the routine
 * will simply check for a syntactically correct number, returning
 * TCL_OK or TCL_ERROR as appropriate, and setting *endPtrPtr if
 * necessary.
 *
 * If 'endPtrPtr' is not NULL, it designates the first character
 * after the scanned number.  In this case, successfully recognizing
 * any digits will yield a return code of TCL_OK.  Only in the case
 * where no leading string of 'strPtr' (or of objPtr's internal rep)
 * represents a number will TCL_ERROR be returned.
 *
 * When only a partial string is being recognized, it is the caller's
 * responsibility to destroy the internal representation, or at
 * least change its type.  Failure to do so will lead to subsequent
 * problems where a string that does not represent a number will
 * be recognized as one because it has a numeric internal representation.
 *
 * When the 'flags' word includes TCL_PARSE_DECIMAL_ONLY, only decimal
 * numbers are recognized; leading 0 has no special interpretation as
 * octal and leading '0x' is forbidden.
 *
 *----------------------------------------------------------------------
 */

int
TclParseNumber( Tcl_Interp* interp,
				/* Tcl interpreter for error reporting.
				 * May be NULL */
		Tcl_Obj* objPtr,
				/* Object to receive the internal rep */
		CONST char* type,
				/* Type of number being parsed ("integer",
				 * "wide integer", etc. */
		CONST char* string,
				/* Pointer to the start of the string to
				 * scan, see above */
		size_t length,	/* Maximum length of the string to scan,
				 * see above. */
		CONST char** endPtrPtr,
				/* (Output) pointer to the end of the
				 * scanned number, see above */
		int flags)	/* Flags governing the parse */
{

    enum State {
	INITIAL, SIGNUM, ZERO, ZERO_X, 
#ifdef TIP_114_FORMATS
	ZERO_O, ZERO_B, BINARY,
#endif
	HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, 
	LEADING_RADIX_POINT, FRACTION,
	EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
	sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY
#ifdef IEEE_FLOATING_POINT
	, sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH
#endif
    } state = INITIAL;
    enum State acceptState = INITIAL;

    int signum = 0;		/* Sign of the number being parsed */
    Tcl_WideUInt significandWide = 0;
				/* Significand of the number being
				 * parsed (if no overflow) */
    mp_int significandBig;	/* Significand of the number being
				 * parsed (if it overflows significandWide) */
    int significandOverflow = 0;
				/* Flag==1 iff significandBig is used */
    Tcl_WideUInt octalSignificandWide = 0;
				/* Significand of an octal number; needed
				 * because we don't know whether a number
				 * with a leading zero is octal or decimal
				 * until we've scanned forward to a '.' or
				 * 'e' */
    mp_int octalSignificandBig;	/* Significand of octal number once
				 * octalSignificandWide overflows */
    int octalSignificandOverflow = 0;
				/* Flag==1 if octalSignificandBig is used */
    int numSigDigs = 0;		/* Number of significant digits in the
				 * decimal significand */
    int numTrailZeros = 0;	/* Number of trailing zeroes at the
				 * current point in the parse. */
    int numDigitsAfterDp = 0;	/* Number of digits scanned after the
				 * decimal point */
    int exponentSignum = 0;	/* Signum of the exponent of a floating
				 * point number */
    long exponent = 0;		/* Exponent of a floating point number */
    CONST char* p;		/* Pointer to next character to scan */
    size_t len;			/* Number of characters remaining after p */
    CONST char* acceptPoint;	/* Pointer to position after last character
				 * in an acceptable number */
    size_t acceptLen;		/* Number of characters following that point */
    int status = TCL_OK;	/* Status to return to caller */
    char d;			/* Last hexadecimal digit scanned */
    int shift = 0;		/* Amount to shift when accumulating binary */
#ifdef TIP_114_FORMATS
    int explicitOctal = 0;
#endif

    /* 
     * Initialize string to start of the object's string rep if
     * the caller didn't pass anything else.
     */

    if ( string == NULL ) {
	string = Tcl_GetStringFromObj( objPtr, NULL );
    }

    p = string;
    len = length;
    acceptPoint = p;
    acceptLen = len;
    while ( 1 ) {
	char c = len ? *p : '\0';
	switch (state) {

	case INITIAL:
	    /*
	     * Initial state. Acceptable characters are +, -, digits,
	     * period, I, N, and whitespace.
	     */
	    if (isspace(UCHAR(c))) {
		break;
	    } else if (c == '+') {
		state = SIGNUM;
		break;
	    } else if (c == '-') {
		signum = 1;
		state = SIGNUM;
		break;
	    } 
	    /* FALLTHROUGH */
	    
	case SIGNUM:
	    /*
	     * Scanned a leading + or -. Acceptable characters are
	     * digits, period, I, and N.
	     */
	    if (c == '0') {
		if (flags & TCL_PARSE_DECIMAL_ONLY) {
		    state = DECIMAL;
		} else {
		    state = ZERO;
		}
		break;
	    } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
		goto zerox;
	    } else if (flags & TCL_PARSE_OCTAL_ONLY) {
		goto zeroo;
	    } else if (isdigit(UCHAR(c))) {
		significandWide = c - '0';
		numSigDigs = 1;
		state = DECIMAL;
		break;
	    } else if (flags & TCL_PARSE_INTEGER_ONLY) {
		goto endgame;
	    } else if (c == '.') {
		state = LEADING_RADIX_POINT;
		break;
	    } else if (c == 'I' || c == 'i') {
		state = sI;
		break;
#ifdef IEEE_FLOATING_POINT
	    } else if (c == 'N' || c == 'n') {
		state = sN;
		break;
#endif
	    }
	    goto endgame;

	case ZERO:
	    /*
	     * Scanned a leading zero (perhaps with a + or -).
	     * Acceptable inputs are digits, period, X, and E.
	     * If 8 or 9 is encountered, the number can't be
	     * octal.  This state and the OCTAL state differ only
	     * in whether they recognize 'X'.
	     */
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if (c == 'x' || c == 'X') {
		state = ZERO_X;
		break;
	    }
	    if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
		goto zerox;
	    }
#ifdef TIP_114_FORMATS 
	    if (flags & TCL_PARSE_SCAN_PREFIXES) {
		goto zeroo;
	    }
	    if (c == 'b' || c == 'B') {
		state = ZERO_B;
		break;
	    }
	    if (c == 'o' || c == 'O') {
		explicitOctal = 1;
		state = ZERO_O;
		break;
	    }
#ifdef KILL_OCTAL
	    goto decimal;
#endif
#endif
	    /* FALLTHROUGH */

	case OCTAL:
	    /*
	     * Scanned an optional + or -, followed by a string of
	     * octal digits.  Acceptable inputs are more digits,
	     * period, or E.  If 8 or 9 is encountered, commit to
	     * floating point.
	     */
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
#ifdef TIP_114_FORMATS
	    /* FALLTHROUGH */
	case ZERO_O:
#endif
	zeroo:
	    if (c == '0') {
		++numTrailZeros;
		state = OCTAL;
		break;
	    } else if (c >= '1' && c <= '7') {
		if (objPtr != NULL) {
		    shift = 3 * (numTrailZeros + 1);
		    significandOverflow = 
			AccumulateDecimalDigit((unsigned)(c-'0'),
					       numTrailZeros, 
					       &significandWide,
					       &significandBig, 
					       significandOverflow);
		    
		    if (!octalSignificandOverflow) {
			/*
			 * Shifting by more bits than are in the value being
			 * shifted is at least de facto nonportable.  Check
			 * for too large shifts first.
			 */
			if ((octalSignificandWide != 0) 
				&& ((shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) 
				|| (octalSignificandWide 
				> (~(Tcl_WideUInt)0 >> shift)))) {
			    octalSignificandOverflow = 1;
			    TclBNInitBignumFromWideUInt(&octalSignificandBig,
							octalSignificandWide);
			}
		    }
		    if (!octalSignificandOverflow) {
			octalSignificandWide
			    = (octalSignificandWide << shift) + (c - '0');
		    } else {
			mp_mul_2d(&octalSignificandBig, shift,
				  &octalSignificandBig);
			mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
				 &octalSignificandBig);
		    }
		}
		if ( numSigDigs != 0 ) {
		    numSigDigs += ( numTrailZeros + 1 );
		} else {
		    numSigDigs = 1;
		}
		numTrailZeros = 0;
		state = OCTAL;
		break;
	    }
	    /* FALLTHROUGH */

	case BAD_OCTAL:
#ifdef TIP_114_FORMATS
	    if (explicitOctal) {
		/* No forgiveness for bad digits in explicitly octal numbers */
		goto endgame;
	    }
#endif
	    if (flags & TCL_PARSE_INTEGER_ONLY) {
		/* No seeking floating point when parsing only integer */
		goto endgame;
	    }
#ifndef KILL_OCTAL
	    /*
	     * Scanned a number with a leading zero that contains an
	     * 8, 9, radix point or E.  This is an invalid octal number,
	     * but might still be floating point.  
	     */
	    if (c == '0') {
		++numTrailZeros;
		state = BAD_OCTAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		if (objPtr != NULL) {
		    significandOverflow = 
			AccumulateDecimalDigit((unsigned)(c-'0'),
					       numTrailZeros, 
					       &significandWide,
					       &significandBig, 
					       significandOverflow);
		}
		if ( numSigDigs != 0 ) {
		    numSigDigs += ( numTrailZeros + 1 );
		} else {
		    numSigDigs = 1;
		}
		numTrailZeros = 0;
		state = BAD_OCTAL;
		break;
	    } else if (c == '.') {
		state = FRACTION;
		break;
	    } else if (c == 'E' || c == 'e') {
		state = EXPONENT_START;
		break;
	    } 
#endif
	    goto endgame;

	    /*
	     * Scanned 0x.  If state is HEXADECIMAL, scanned at least
	     * one character following the 0x.  The only acceptable
	     * inputs are hexadecimal digits.
	     */
	case HEXADECIMAL:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    /* FALLTHROUGH */
	case ZERO_X:
	zerox:
	    if (c == '0') {
		++numTrailZeros;
		state = HEXADECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		d = (c-'0');
	    } else if (c >= 'A' && c <= 'F') {
		d = (c-'A'+10);
	    } else if (c >= 'a' && c <= 'f') {
		d = (c-'a'+10);
	    } else {
		goto endgame;
	    }
	    if (objPtr != NULL) {
		shift = 4 * (numTrailZeros + 1);
		if (!significandOverflow) {
		    /*
		     * Shifting by more bits than are in the value being
		     * shifted is at least de facto nonportable.  Check
		     * for too large shifts first.
		     */
		    if (significandWide != 0 
			    && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
			    || significandWide > (~(Tcl_WideUInt)0 >> shift))) {
			significandOverflow = 1;
			TclBNInitBignumFromWideUInt(&significandBig,
						    significandWide);
		    }
		}
		if (!significandOverflow) {
		    significandWide
			= (significandWide << shift) + d;
		} else {
		    mp_mul_2d(&significandBig, shift,
			      &significandBig);
		    mp_add_d(&significandBig, (mp_digit) d,
			     &significandBig);
		}
	    }
	    numTrailZeros = 0;
	    state = HEXADECIMAL;
	    break;

#ifdef TIP_114_FORMATS
	case BINARY:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	case ZERO_B:
	    if (c == '0') {
		++numTrailZeros;
		state = BINARY;
		break;
	    } else if (c != '1') {
		goto endgame;
	    }
	    if (objPtr != NULL) {
		shift = numTrailZeros + 1;
		if (!significandOverflow) {
		    /*
		     * Shifting by more bits than are in the value being
		     * shifted is at least de facto nonportable.  Check
		     * for too large shifts first.
		     */
		    if (significandWide != 0 
			    && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
			    || significandWide > (~(Tcl_WideUInt)0 >> shift))) {
			significandOverflow = 1;
			TclBNInitBignumFromWideUInt(&significandBig,
						    significandWide);
		    }
		}
		if (!significandOverflow) {
		    significandWide
			= (significandWide << shift) + 1;
		} else {
		    mp_mul_2d(&significandBig, shift,
			      &significandBig);
		    mp_add_d(&significandBig, (mp_digit) 1,
			     &significandBig);
		}
	    }
	    numTrailZeros = 0;
	    state = BINARY;
	    break;
#endif

	case DECIMAL:
	    /*
	     * Scanned an optional + or - followed by a string of
	     * decimal digits.
	     */
#ifdef KILL_OCTAL
	decimal:
#endif
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if (c == '0') {
		++numTrailZeros;
		state = DECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		if (objPtr != NULL) {
		    significandOverflow = 
			AccumulateDecimalDigit((unsigned)(c - '0'), 
					       numTrailZeros, 
					       &significandWide,
					       &significandBig, 
					       significandOverflow);
		}
		numSigDigs += ( numTrailZeros + 1 );
		numTrailZeros = 0;
		state = DECIMAL;
		break;
	    } else if (flags & TCL_PARSE_INTEGER_ONLY) {
		goto endgame;
	    } else if (c == '.') {
		state = FRACTION;
		break;
	    } else if (c == 'E' || c == 'e') {
		state = EXPONENT_START;
		break;
	    }
	    goto endgame;

	    /* 
	     * Found a decimal point.  If no digits have yet been scanned,
	     * E is not allowed; otherwise, it introduces the exponent.
	     * If at least one digit has been found, we have a possible
	     * complete number.
	     */
	case FRACTION:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if (c == 'E' || c=='e') {
		state = EXPONENT_START;
		break;
	    }
	    /* FALLTHROUGH */
	case LEADING_RADIX_POINT:
	    if (c == '0') {
		++numDigitsAfterDp;
		++numTrailZeros;
		state = FRACTION;
		break;
	    } else if (isdigit(UCHAR(c))) {
		++numDigitsAfterDp;
		if (objPtr != NULL) {
		    significandOverflow = 
			AccumulateDecimalDigit((unsigned)(c-'0'),
					       numTrailZeros, 
					       &significandWide,
					       &significandBig, 
					       significandOverflow);
		}
		if ( numSigDigs != 0 ) {
		    numSigDigs += ( numTrailZeros + 1 );
		} else {
		    numSigDigs = 1;
		}
		numTrailZeros = 0;
		state = FRACTION;
		break;
	    }
	    goto endgame;

	case EXPONENT_START:
	    /* 
	     * Scanned the E at the start of an exponent. Make sure
	     * a legal character follows before using the C library
	     * strtol routine, which allows whitespace.
	     */
	    if (c == '+') {
		state = EXPONENT_SIGNUM;
		break;
	    } else if (c == '-') {
		exponentSignum = 1;
		state = EXPONENT_SIGNUM;
		break;
	    }
	    /* FALLTHROUGH */

	case EXPONENT_SIGNUM:
	    /*
	     * Found the E at the start of the exponent, followed by
	     * a sign character.
	     */
	    if (isdigit(UCHAR(c))) {
		exponent = c - '0';
		state = EXPONENT;
		break;
	    }
	    goto endgame;

	case EXPONENT:
	    /* 
	     * Found an exponent with at least one digit. 
	     * Accumulate it, making sure to hard-pin it to LONG_MAX
	     * on overflow.
	     */
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if (isdigit(UCHAR(c))) {
		if (exponent < (LONG_MAX - 9) / 10) {
		    exponent = 10 * exponent + (c - '0');
		} else {
		    exponent = LONG_MAX;
		}
		state = EXPONENT;
		break;
	    }
	    goto endgame;

	    /*
	     * Parse out INFINITY by simply spelling it out.
	     * INF is accepted as an abbreviation; other prefices are
	     * not.
	     */
	case sI:
	    if ( c == 'n' || c == 'N' ) {
		state = sIN;
		break;
	    } 
	    goto endgame;
	case sIN:
	    if ( c == 'f' || c == 'F' ) {
		state = sINF;
		break;
	    } 
	    goto endgame;
	case sINF:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if ( c == 'i' || c == 'I' ) {
		state = sINFI;
		break;
	    }
	    goto endgame;
	case sINFI:
	    if ( c == 'n' || c == 'N' ) {
		state = sINFIN;
		break;
	    }
	    goto endgame;
	case sINFIN:
	    if ( c == 'i' || c == 'I' ) {
		state = sINFINI;
		break;
	    }
	    goto endgame;
	case sINFINI:
	    if ( c == 't' || c == 'T' ) {
		state = sINFINIT;
		break;
	    }
	    goto endgame;
	case sINFINIT:
	    if ( c == 'y' || c == 'Y' ) {
		state = sINFINITY;
		break;
	    }
	    goto endgame;

	    /*
	     * Parse NaN's.
	     */
#ifdef IEEE_FLOATING_POINT
	case sN:
	    if ( c == 'a' || c == 'A' ) {
		state = sNA;
		break;
	    }
	    goto endgame;
	case sNA:
	    if ( c == 'n' || c == 'N' ) {
		state = sNAN;
		break;
	    }
	case sNAN:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    if ( c == '(' ) {
		state = sNANPAREN;
		break;
	    }
	    goto endgame;

	    /*
	     * Parse NaN(hexdigits)
	     */
	case sNANHEX:
	    if ( c == ')' ) {
		state = sNANFINISH;
		break;
	    }
	    /* FALLTHROUGH */
	case sNANPAREN:
	    if ( isspace(UCHAR(c)) ) {
		break;
	    }
	    if ( numSigDigs < 13 ) {
		if ( c >= '0' && c <= '9' ) {
		    d = c - '0';
		} else if ( c >= 'a' && c <= 'f' ) {
		    d = 10 + c - 'a';
		} else if ( c >= 'A' && c <= 'F' ) {
		    d = 10 + c - 'A';
		}
		significandWide = (significandWide << 4) + d;
		state = sNANHEX;
		break;
	    }
	    goto endgame;
	case sNANFINISH:
#endif
	case sINFINITY:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    goto endgame;
	}
	++p; 
	--len;
    }

  endgame:

    /* Back up to the last accepting state in the lexer */

    if (acceptState == INITIAL) {
	status = TCL_ERROR;
    }
    p = acceptPoint;
    len = acceptLen;

    /* Skip past trailing whitespace */

    if (endPtrPtr != NULL) {
	*endPtrPtr = p;
    }

    while (len > 0 && isspace(UCHAR(*p))) {
	++p;
	--len;
    }

    /* Determine whether a partial string is acceptable. */

    if (endPtrPtr == NULL && len != 0 && *p != '\0') {
	status = TCL_ERROR;
    }

    /* Generate and store the appropriate internal rep */

    if (status == TCL_OK && objPtr != NULL) {
	if ( acceptState != INITIAL ) {
	    TclFreeIntRep( objPtr );
	}
	switch (acceptState) {

	case INITIAL:
	    status = TCL_ERROR;
	    break;

	case SIGNUM:
	case BAD_OCTAL:
	case ZERO_X:
#ifdef TIP_114_FORMATS
	case ZERO_O:
	case ZERO_B:
#endif
	case LEADING_RADIX_POINT:
	case EXPONENT_START:
	case EXPONENT_SIGNUM:
	case sI:
	case sIN:
	case sINFI:
	case sINFIN:
	case sINFINI:
	case sINFINIT:
	case sN:
	case sNA:
	case sNANPAREN:
	case sNANHEX:
	    panic("in TclParseNumber: bad acceptState, can't happen.");

#ifdef TIP_114_FORMATS
	case BINARY:
	    shift = numTrailZeros;
	    if (!significandOverflow) {
		if (significandWide !=0 
			&& (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) 
			|| significandWide 
			> (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) {
		    significandOverflow = 1;
		    TclBNInitBignumFromWideUInt(&significandBig,
						significandWide);
		}
	    }
	    if (shift) {
		if ( !significandOverflow ) {
		    significandWide <<= shift;
		} else {
		    mp_mul_2d( &significandBig, shift, &significandBig );
		}
	    }
	    goto returnInteger;
#endif
	case HEXADECIMAL:
	    /* Returning a hex integer.  Final scaling step */
	    shift = 4 * numTrailZeros;
	    if (!significandOverflow) {
		if (significandWide !=0 
			&& (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) 
			|| significandWide 
			> (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) {
		    significandOverflow = 1;
		    TclBNInitBignumFromWideUInt(&significandBig,
						significandWide);
		}
	    }
	    if (shift) {
		if ( !significandOverflow ) {
		    significandWide <<= shift;
		} else {
		    mp_mul_2d( &significandBig, shift, &significandBig );
		}
	    }
	    goto returnInteger;

	case OCTAL:
	    /* Returning an octal integer.  Final scaling step */
	    shift = 3 * numTrailZeros;
	    if (!octalSignificandOverflow) {
		if (octalSignificandWide != 0
			&& (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) 
			|| octalSignificandWide 
			> (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) {
		    octalSignificandOverflow = 1;
		    TclBNInitBignumFromWideUInt(&octalSignificandBig,
						octalSignificandWide);
		}
	    }
	    if ( shift ) {
		if ( !octalSignificandOverflow ) {
		    octalSignificandWide <<= shift;
		} else {
		    mp_mul_2d( &octalSignificandBig, shift,
			       &octalSignificandBig );
		}
	    }
	    if (!octalSignificandOverflow) {
		if (octalSignificandWide > 
			(Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
#ifndef NO_WIDE_TYPE
		    if (octalSignificandWide 
			    <= (((~(Tcl_WideUInt)0) >> 1) + signum)) {
			objPtr->typePtr = &tclWideIntType;
			if (signum) {
			    objPtr->internalRep.wideValue =
				    - (Tcl_WideInt) octalSignificandWide;
			} else {
			    objPtr->internalRep.wideValue =
				    (Tcl_WideInt) octalSignificandWide;
			}
			break;
		    }
#endif
		    TclBNInitBignumFromWideUInt(&octalSignificandBig,
						octalSignificandWide);
		    octalSignificandOverflow = 1;
		} else {
		    objPtr->typePtr = &tclIntType;
		    if (signum) {
			objPtr->internalRep.longValue =
				- (long) octalSignificandWide;
		    } else {
			objPtr->internalRep.longValue =
				(long) octalSignificandWide;
		    }
		}
	    }
	    if (octalSignificandOverflow) {
		if (signum) {
		    mp_neg(&octalSignificandBig, &octalSignificandBig);
		}
		TclSetBignumIntRep(objPtr, &octalSignificandBig);
	    }		
	    break;

	case ZERO:
	case DECIMAL:
	    significandOverflow =
		AccumulateDecimalDigit( 0, numTrailZeros-1,
					&significandWide, &significandBig,
					significandOverflow );
	    if (!significandOverflow
		&& (significandWide
		    > (((~(Tcl_WideUInt)0) >> 1) + signum))) {
		significandOverflow = 1;
		TclBNInitBignumFromWideUInt(&significandBig,
					    significandWide);
	    }
	  returnInteger:
	    if (!significandOverflow) {
		if (significandWide > 
			(Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
#ifndef NO_WIDE_TYPE
		    if (significandWide 
			    <= (((~(Tcl_WideUInt)0) >> 1) + signum)) {
			objPtr->typePtr = &tclWideIntType;
			if (signum) {
			    objPtr->internalRep.wideValue =
				    - (Tcl_WideInt) significandWide;
			} else {
			    objPtr->internalRep.wideValue =
				    (Tcl_WideInt) significandWide;
			}
			break;
		    }
#endif
		    TclBNInitBignumFromWideUInt(&significandBig,
						significandWide);
		    significandOverflow = 1;
		} else {
		    objPtr->typePtr = &tclIntType;
		    if (signum) {
			objPtr->internalRep.longValue =
				- (long) significandWide;
		    } else {
			objPtr->internalRep.longValue =
				(long) significandWide;
		    }
		}
	    }
	    if (significandOverflow) {
		if (signum) {
		    mp_neg(&significandBig, &significandBig);
		}
		TclSetBignumIntRep(objPtr, &significandBig);
	    }
	    break;

	case FRACTION:
	case EXPONENT:

	    /*
	     * Here, we're parsing a floating-point number.
	     * 'significandWide' or 'significandBig' contains the
	     * exact significand, according to whether
	     * 'significandOverflow' is set.  The desired floating
	     * point value is significand * 10**k, where
	     * k = numTrailZeros+exponent-numDigitsAfterDp.
	     */

	    objPtr->typePtr = &tclDoubleType;
	    if ( exponentSignum ) {
		exponent = - exponent;
	    }
	    if ( !significandOverflow ) {
		objPtr->internalRep.doubleValue = 
		    MakeLowPrecisionDouble( signum, 
					    significandWide,
					    numSigDigs,
					    ( numTrailZeros
					      + exponent
					      - numDigitsAfterDp ) );
	    } else {
		objPtr->internalRep.doubleValue =
		    MakeHighPrecisionDouble( signum,
					     &significandBig,
					     numSigDigs,
					     ( numTrailZeros
					       + exponent
					       - numDigitsAfterDp ) );
	    }
	    break;

	case sINF:
	case sINFINITY:
	    if ( signum ) {
		objPtr->internalRep.doubleValue = -HUGE_VAL;
	    } else {
		objPtr->internalRep.doubleValue = HUGE_VAL;
	    }
	    objPtr->typePtr = &tclDoubleType;
	    break;

	case sNAN:
	case sNANFINISH:
	    objPtr->internalRep.doubleValue
		= MakeNaN( signum, significandWide );
	    objPtr->typePtr = &tclDoubleType;
	    break;
	    
	}
    }

    /* Format an error message when an invalid number is encountered. */

    if ( status != TCL_OK ) {
	if ( interp != NULL ) {
	    Tcl_Obj *msg = Tcl_NewStringObj( "expected ", -1 );
	    Tcl_AppendToObj( msg, type, -1 );
	    Tcl_AppendToObj( msg, " but got \"", -1 );
	    TclAppendLimitedToObj( msg, string, length, 50, "" );
	    Tcl_AppendToObj( msg, "\"", -1 );
	    if ( state == BAD_OCTAL ) {
		Tcl_AppendToObj( msg, " (looks like invalid octal number)",
				 -1 );
	    }
	    Tcl_SetObjResult( interp, msg );
	}
    }

    /* Free memory */

    if (octalSignificandOverflow) {
	mp_clear(&octalSignificandBig);
    }
    if (significandOverflow) {
	mp_clear(&significandBig);
    }
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * AccumulateDecimalDigit --
 *
 *	Consume a decimal digit in a number being scanned.
 *
 * Results:
 *	Returns 1 if the number has overflowed to a bignum, 0 if it
 *	still fits in a wide integer.
 *
 * Side effects:
 *	Updates either the wide or bignum representation.
 *
 *----------------------------------------------------------------------
 */

static int
AccumulateDecimalDigit( unsigned digit,
				/* Digit being scanned */
			int numZeros,
				/* Count of zero digits preceding the
				 * digit being scanned */
			Tcl_WideUInt* wideRepPtr,
				/* Representation of the partial number
				 * as a wide integer */
			mp_int* bignumRepPtr,
				/* Representation of the partial number
				 * as a bignum */
			int bignumFlag )
				/* Flag == 1 if the number overflowed
				 * previous to this digit. */
{
    int i, n;

    /* Check if the number still fits in a wide */

    if (!bignumFlag) {
	if (*wideRepPtr != 0) {
	    if ((numZeros >= maxpow10_wide)
		|| (*wideRepPtr > (((~(Tcl_WideUInt)0) - digit)
				   / pow10_wide[numZeros+1]))) {
		/* Oops, it's overflowed, have to allocate a bignum */
		TclBNInitBignumFromWideUInt (bignumRepPtr, *wideRepPtr);
		bignumFlag = 1;
	    }
	}
    }

    /* Multiply the number by 10**numZeros+1 and add in the new digit. */

    if (!bignumFlag) {

	/* Wide multiplication */

	*wideRepPtr = *wideRepPtr * pow10_wide[numZeros+1] + digit;
    } else if (numZeros < log10_DIGIT_MAX ) {

	/* Up to about 8 zeros - single digit multiplication */

	mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
		  bignumRepPtr);
	mp_add_d (bignumRepPtr, (mp_digit) digit, bignumRepPtr);

    } else {

	/* 
	 * More than single digit multiplication. Multiply by the appropriate
	 * small powers of 5, and then shift.  Large strings of zeroes are
	 * eaten 256 at a time; this is less efficient than it could be,
	 * but seems implausible.  We presume that DIGIT_BIT is at least 27.
	 * The first multiplication, by up to 10**7, is done with a
	 * one-DIGIT multiply (this presumes that DIGIT_BIT >= 24).
	 */

	n = numZeros + 1;
	mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
	for (i = 3; i <= 7; ++i) {
	    if (n & (1 << i)) {
		mp_mul (bignumRepPtr, pow5+i, bignumRepPtr);
	    }
	}
	while (n >= 256) {
	    mp_mul (bignumRepPtr, pow5+8, bignumRepPtr);
	    n -= 256;
	}
	mp_mul_2d (bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr);
    }

    return bignumFlag;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeLowPrecisionDouble --
 *
 *	Makes the double precision number, signum*significand*10**exponent.
 *
 * Results:
 *	Returns the constructed number.
 *
 * Common cases, where there are few enough digits that the number can
 * be represented with at most roundoff, are handled specially here.
 * If the number requires more than one rounded operation to compute,
 * the code promotes the significand to a bignum and calls
 * MakeHighPrecisionDouble to do it instead.
 *
 *----------------------------------------------------------------------
 */

static double
MakeLowPrecisionDouble( int signum,
				/* 1 if the number is negative, 0 otherwise */
			Tcl_WideUInt significand,
				/* Significand of the number */
			int numSigDigs,
				/* Number of digits in the significand */
			int exponent )
				/* Power of ten */
{
    double retval;		/* Value of the number */
    mp_int significandBig;	/* Significand expressed as a bignum */

    /*
     * With gcc on x86, the floating point rounding mode is double-extended.
     * This causes the result of double-precision calculations to be rounded
     * twice: once to the precision of double-extended and then again to the
     * precision of double.  Double-rounding introduces gratuitous errors of
     * 1 ulp, so we need to change rounding mode to 53-bits.
     */

#if defined(__GNUC__) && defined(__i386)
    fpu_control_t roundTo53Bits = 0x027f;
    fpu_control_t oldRoundingMode;
    _FPU_GETCW( oldRoundingMode );
    _FPU_SETCW( roundTo53Bits );
#endif

    /* Test for the easy cases */

    if ( numSigDigs <= DBL_DIG ) {
	if ( exponent >= 0 ) {
	    if ( exponent <= mmaxpow ) {

		/* 
		 * The significand is an exact integer, and so is 
		 * 10**exponent. The product will be correct to within
		 * 1/2 ulp without special handling.
		 */

		retval = (double)(Tcl_WideInt)significand * pow10[ exponent ];
		goto returnValue;

	    } else {
		int diff = DBL_DIG - numSigDigs;
		if ( exponent-diff <= mmaxpow ) {

		    /* 
		     * 10**exponent is not an exact integer, but
		     * 10**(exponent-diff) is exact, and so is
		     * significand*10**diff, so we can still compute
		     * the value with only one roundoff.
		     */
		    volatile double factor
			= (double)(Tcl_WideInt)significand * pow10[diff];
		    retval = factor * pow10[exponent-diff];
		    goto returnValue;
		}
	    }
	} else {
	    if ( exponent >= -mmaxpow ) {

		/* 
		 * 10**-exponent is an exact integer, and so is the
		 * significand. Compute the result by one division,
		 * again with only one rounding.
		 */

		retval = (double)(Tcl_WideInt)significand / pow10[-exponent];
		goto returnValue;
	    }
	}
    }

    /*
     * All the easy cases have failed.  Promote ths significand
     * to bignum and call MakeHighPrecisionDouble to do it the hard way.
     */

    TclBNInitBignumFromWideUInt (&significandBig, significand);
    retval = MakeHighPrecisionDouble( 0, &significandBig, numSigDigs,
				      exponent );
    
    /* Come here to return the computed value */

  returnValue:

    if ( signum ) {
	retval = -retval;
    }

    /* On gcc on x86, restore the floating point mode word. */

#if defined(__GNUC__) && defined(__i386)
    _FPU_SETCW( oldRoundingMode );
#endif

    return retval;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeHighPrecisionDouble --
 *
 *	Makes the double precision number, signum*significand*10**exponent.
 *
 * Results:
 *	Returns the constructed number.
 *
 * MakeHighPrecisionDouble is used when arbitrary-precision arithmetic
 * is needed to ensure correct rounding.  It begins by calculating a
 * low-precision approximation to the desired number, and then refines
 * the answer in high precision.
 *
 *----------------------------------------------------------------------
 */

static double
MakeHighPrecisionDouble( int signum,
				/* 1=negative, 0=nonnegative */
			 mp_int* significand,
				/* Exact significand of the number */
			 int numSigDigs,
				/* Number of significant digits */
			 int exponent )
				/* Power of 10 by which to multiply */
{

    double retval;
    int machexp;		/* Machine exponent of a power of 10 */

    /*
     * With gcc on x86, the floating point rounding mode is double-extended.
     * This causes the result of double-precision calculations to be rounded
     * twice: once to the precision of double-extended and then again to the
     * precision of double.  Double-rounding introduces gratuitous errors of
     * 1 ulp, so we need to change rounding mode to 53-bits.
     */

#if defined(__GNUC__) && defined(__i386)
    fpu_control_t roundTo53Bits = 0x027f;
    fpu_control_t oldRoundingMode;
    _FPU_GETCW( oldRoundingMode );
    _FPU_SETCW( roundTo53Bits );
#endif

    /* Quick checks for over/underflow */

    if ( numSigDigs + exponent - 1 > maxDigits ) {
	retval = HUGE_VAL;
	goto returnValue;
    }
    if ( numSigDigs + exponent - 1 < minDigits ) {
	retval = 0;
	goto returnValue;
    }

    /* 
     * Develop a first approximation to the significand. It is tempting
     * simply to force bignum to double, but that will overflow on input
     * numbers like 1.[string repeat 0 1000]1; while this is a not terribly
     * likely scenario, we still have to deal with it. Use fraction and
     * exponent instead.  Once we have the significand, multiply by
     * 10**exponent. Test for overflow. Convert back to a double, and
     * test for underflow.
     */

    retval = BignumToBiasedFrExp( significand, &machexp );
    retval = Pow10TimesFrExp( exponent, retval, &machexp );
    if ( machexp > DBL_MAX_EXP * log2FLT_RADIX ) {
	retval = HUGE_VAL;
	goto returnValue;
    }
    retval = SafeLdExp( retval, machexp );
    if ( retval < tiny ) {
	retval = tiny;
    }

    /* 
     * Refine the result twice. (The second refinement should be 
     * necessary only if the best approximation is a power of 2
     * minus 1/2 ulp).
     */

    retval = RefineApproximation( retval, significand, exponent );
    retval = RefineApproximation( retval, significand, exponent );

    /* Come here to return the computed value */

  returnValue:
    if ( signum ) {
	retval = -retval;
    }

    /* On gcc on x86, restore the floating point mode word. */

#if defined(__GNUC__) && defined(__i386)
    _FPU_SETCW( oldRoundingMode );
#endif
    return retval;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeNaN --
 *
 *	Makes a "Not a Number" given a set of bits to put in the
 *	tag bits
 *
 * Note that a signalling NaN is never returned.
 *
 *----------------------------------------------------------------------
 */

#ifdef IEEE_FLOATING_POINT
static double
MakeNaN( int signum,		/* Sign bit (1=negative, 0=nonnegative */
	 Tcl_WideUInt tags ) 	/* Tag bits to put in the NaN */
{
    union {
	Tcl_WideUInt iv;
	double dv;
    } theNaN;

    theNaN.iv = tags;
    theNaN.iv &= ( ((Tcl_WideUInt) 1) << 51 ) - 1;
    if ( signum ) {
	theNaN.iv |= ((Tcl_WideUInt) (0x8000 | NAN_START)) << 48;
    } else {
	theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48;
    }

    return theNaN.dv;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * RefineApproximation --
 *
 *	Given a poor approximation to a floating point number, returns
 *	a better one (The better approximation is correct to within
 *	1 ulp, and is entirely correct if the poor approximation is
 *	correct to 1 ulp.)
 *
 * Results:
 *	Returns the improved result.
 *
 *----------------------------------------------------------------------
 */

static double
RefineApproximation( double approxResult, 
				/* Approximate result of conversion */
		     mp_int* exactSignificand,
				/* Integer significand */
		     int exponent )
				/* Power of 10 to multiply by significand */
{

    int M2, M5;			/*  Powers of 2 and of 5 needed to put
				 * the decimal and binary numbers over
				 * a common denominator. */
    double significand;		/* Sigificand of the binary number */
    int binExponent;		/* Exponent of the binary number */

    int msb;			/* Most significant bit position of an
				 * intermediate result */
    int nDigits;		/* Number of mp_digit's in an intermediate
				 * result */
    mp_int twoMv;		/* Approx binary value expressed as an
				 * exact integer scaled by the multiplier 2M */
    mp_int twoMd;		/* Exact decimal value expressed as an
				 * exact integer scaled by the multiplier 2M */
    int scale;			/* Scale factor for M */
    int multiplier;		/* Power of two to scale M */
    double num, den;		/* Numerator and denominator of the
				 * correction term */
    double quot;		/* Correction term */
    double minincr;		/* Lower bound on the absolute value
				 * of the correction term. */
    int i;

    /*
     * The first approximation is always low.  If we find that
     * it's HUGE_VAL, we're done.
     */

    if ( approxResult == HUGE_VAL ) {
	return approxResult;
    }

    /*
     * Find a common denominator for the decimal and binary fractions.
     * The common denominator will be 2**M2 + 5**M5.
     */

    significand = frexp( approxResult, &binExponent );
    i = mantBits - binExponent;
    if ( i < 0 ) {
	M2 = 0;
    } else {
	M2 = i;
    }
    if ( exponent > 0 ) {
	M5 = 0;
    } else {
	M5 = -exponent;
	if ( (M5-1) > M2 ) {
	    M2 = M5-1;
	}
    }

    /* 
     * The floating point number is significand*2**binExponent.
     * Compute the large integer significand*2**(binExponent+M2+1)
     * The 2**-1 bit of the significand (the most significant) 
     * corresponds to the 2**(binExponent+M2 + 1) bit of 2*M2*v.
     * Allocate enough digits to hold that quantity, then
     * convert the significand to a large integer, scaled
     * appropriately. Then multiply by the appropriate power of 5.
     */

    msb = binExponent + M2;  /* 1008 */
    nDigits = msb / DIGIT_BIT + 1;
    mp_init_size( &twoMv, nDigits );
    i = ( msb % DIGIT_BIT + 1 ); 
    twoMv.used = nDigits;
    significand *= SafeLdExp( 1.0, i );
    while ( -- nDigits >= 0 ) {
	twoMv.dp[nDigits] = (mp_digit) significand;
	significand -= (mp_digit) significand;
	significand = SafeLdExp( significand, DIGIT_BIT );
    }
    for ( i = 0; i <= 8; ++i ) {
	if ( M5 & ( 1 << i ) ) {
	    mp_mul( &twoMv, pow5+i, &twoMv );
	}
    }
    
    /* 
     * Collect the decimal significand as a high precision integer.
     * The least significant bit corresponds to bit M2+exponent+1
     * so it will need to be shifted left by that many bits after
     * being multiplied by 5**(M5+exponent).
     */

    mp_init_copy( &twoMd, exactSignificand );
    for ( i = 0; i <= 8; ++i ) {
	if ( (M5+exponent) & ( 1 << i ) ) {
	    mp_mul( &twoMd, pow5+i, &twoMd );
	}
    }
    mp_mul_2d( &twoMd, M2+exponent+1, &twoMd );
    mp_sub( &twoMd, &twoMv, &twoMd );

    /*
     * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction
     * term. Because 2M may well overflow a double, we need to scale the
     * denominator by a factor of 2**binExponent-mantBits
     */

    scale = binExponent - mantBits - 1;

    mp_set( &twoMv, 1 );
    for ( i = 0; i <= 8; ++i ) {
	if ( M5 & ( 1 << i ) ) {
	    mp_mul( &twoMv, pow5+i, &twoMv );
	}
    }
    multiplier = M2 + scale + 1;
    if ( multiplier > 0 ) {
	mp_mul_2d( &twoMv, multiplier, &twoMv );
    } else if ( multiplier < 0 ) {
	mp_div_2d( &twoMv, -multiplier, &twoMv, NULL );
    }

    /*
     * If the result is less than unity, the error is less than 1/2 unit
     * in the last place, so there's no correction to make.
     */

    if ( mp_cmp_mag( &twoMd, &twoMv ) == MP_LT ) {
	return approxResult;
    }

    /* 
     * Convert the numerator and denominator of the corrector term
     * accurately to floating point numbers.
     */

    num = TclBignumToDouble( &twoMd );
    den = TclBignumToDouble( &twoMv );

    quot = SafeLdExp( num/den, scale );
    minincr = SafeLdExp( 1.0, binExponent - mantBits );

    if ( quot < 0. && quot > -minincr ) {
	quot = -minincr;
    } else if ( quot > 0. && quot < minincr ) {
	quot = minincr;
    }

    mp_clear( &twoMd );
    mp_clear( &twoMv );

    
    return approxResult + quot;
}

/*
 *----------------------------------------------------------------------
 *
 * TclDoubleDigits --
 *
 *	Converts a double to a string of digits.
 *
 * Results:
 *	Returns the position of the character in the string after which the
 *	decimal point should appear.  Since the string contains only
 *	significant digits, the position may be less than zero or greater than
 *	the length of the string.
 *
 * Side effects:
 *	Stores the digits in the given buffer and sets 'signum' according to
 *	the sign of the number.
 *
 *----------------------------------------------------------------------
 */

int
TclDoubleDigits( char * string,	/* Buffer in which to store the result,
				 * must have at least 18 chars */
		 double v,	/* Number to convert. Must be
				 * finite, and not NaN */
		 int *signum )	/* Output: 1 if the number is negative.
				 * Should handle -0 correctly on the
				 * IEEE architecture. */
{
    int e;			/* Power of FLT_RADIX that satisfies
				 * v = f * FLT_RADIX**e */
    int lowOK, highOK;
    mp_int r;			/* Scaled significand. */
    mp_int s;			/* Divisor such that v = r / s */
    int smallestSig;		/* Flag == 1 iff v's significand is
				 * the smallest that can be represented. */
    mp_int mplus;		/* Scaled epsilon: (r + 2* mplus) == v(+)
				 * where v(+) is the floating point successor
				 * of v. */
    mp_int mminus;		/* Scaled epsilon: (r - 2*mminus) == v(-)
				 * where v(-) is the floating point
				 * predecessor of v. */
    mp_int temp;
    int rfac2 = 0;		/* Powers of 2 and 5 by which large */
    int rfac5 = 0;		/* integers should be scaled.	    */
    int sfac2 = 0;
    int sfac5 = 0;
    int mplusfac2 = 0;
    int mminusfac2 = 0;
    char c;
    int i, k, n;

    /* Split the number into absolute value and signum. */

    v = AbsoluteValue(v, signum);

    /*
     * Handle zero specially.
     */

    if ( v == 0.0 ) {
	*string++ = '0';
	*string++ = '\0';
	return 1;
    }

    /* 
     * Find a large integer r, and integer e, such that 
     *         v = r * FLT_RADIX**e
     * and r is as small as possible.  Also determine whether the
     * significand is the smallest possible.
     */

    smallestSig = GetIntegerTimesPower(v, &r, &e);

    lowOK = highOK = (mp_iseven(&r));

    /*
     * We are going to want to develop integers r, s, mplus, and mminus such
     * that v = r / s, v(+)-v / 2 = mplus / s; v-v(-) / 2 = mminus / s and
     * then scale either s or r, mplus, mminus by an appropriate power of ten.
     *
     * We actually do this by keeping track of the powers of 2 and 5 by which
     * f is multiplied to yield v and by which 1 is multiplied to yield s,
     * mplus, and mminus.
     */

    if (e >= 0) {
	int bits = e * log2FLT_RADIX;

	if (!smallestSig) {
	    /*
	     * Normal case, m+ and m- are both FLT_RADIX**e
	     */

	    rfac2 = bits + 1;
	    sfac2 = 1;
	    mplusfac2 = bits;
	    mminusfac2 = bits;
	} else {
	    /*
	     * If f is equal to the smallest significand, then we need another
	     * factor of FLT_RADIX in s to cope with stepping to the next
	     * smaller exponent when going to e's predecessor.
	     */

	    rfac2 = bits + log2FLT_RADIX + 1;
	    sfac2 = 1 + log2FLT_RADIX;
	    mplusfac2 = bits + log2FLT_RADIX;
	    mminusfac2 = bits;
	}
    } else {
	/*
	 * v has digits after the binary point
	 */

	if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) {
	    /*
	     * Either f isn't the smallest significand or e is the smallest
	     * exponent.  mplus and mminus will both be 1.
	     */

	    rfac2 = 1;
	    sfac2 = 1 - e * log2FLT_RADIX;
	    mplusfac2 = 0;
	    mminusfac2 = 0;
	} else {
	    /*
	     * f is the smallest significand, but e is not the smallest
	     * exponent. We need to scale by FLT_RADIX again to cope with the
	     * fact that v's predecessor has a smaller exponent.
	     */

	    rfac2 = 1 + log2FLT_RADIX;
	    sfac2 = 1 + log2FLT_RADIX * (1 - e);
	    mplusfac2 = FLT_RADIX;
	    mminusfac2 = 0;
	}
    }

    /*
     * Estimate the highest power of ten that will be needed to hold the
     * result.
     */

    k = (int) ceil(log(v) / log(10.));
    if (k >= 0) {
	sfac2 += k;
	sfac5 = k;
    } else {
	rfac2 -= k;
	mplusfac2 -= k;
	mminusfac2 -= k;
	rfac5 = -k;
    }

    /*
     * Scale r, s, mplus, mminus by the appropriate powers of 2 and 5.
     */

    mp_init_set(&mplus, 1);
    for (i=0 ; i<=8 ; ++i) {
	if (rfac5 & (1 << i)) {
	    mp_mul(&mplus, pow5+i, &mplus);
	}
    }
    mp_mul(&r, &mplus, &r);
    mp_mul_2d(&r, rfac2, &r);
    mp_init_copy(&mminus, &mplus);
    mp_mul_2d(&mplus, mplusfac2, &mplus);
    mp_mul_2d(&mminus, mminusfac2, &mminus);
    mp_init_set(&s, 1);
    for (i=0 ; i<=8 ; ++i) {
	if (sfac5 & (1 << i)) {
	    mp_mul(&s, pow5+i, &s);
	}
    }
    mp_mul_2d(&s, sfac2, &s);

    /*
     * It is possible for k to be off by one because we used an inexact
     * logarithm.
     */

    mp_init(&temp);
    mp_add(&r, &mplus, &temp);
    i = mp_cmp_mag(&temp, &s);
    if (i>0 || (highOK && i==0)) {
	mp_mul_d(&s, 10, &s);
	++k;
    } else {
	mp_mul_d(&temp, 10, &temp);
	i = mp_cmp_mag(&temp, &s);
	if (i<0 || (highOK && i==0)) {
	    mp_mul_d(&r, 10, &r);
	    mp_mul_d(&mplus, 10, &mplus);
	    mp_mul_d(&mminus, 10, &mminus);
	    --k;
	}
    }

    /*
     * At this point, k contains the power of ten by which we're scaling the
     * result. r/s is at least 1/10 and strictly less than ten, and v = r/s *
     * 10**k.  mplus and mminus give the rounding limits.
     */

    for (;;) {
	int tc1, tc2;

	mp_mul_d(&r, 10, &r);
	mp_div(&r, &s, &temp, &r);	/* temp = 10r / s; r = 10r mod s */
	i = temp.dp[0];
	mp_mul_d(&mplus, 10, &mplus);
	mp_mul_d(&mminus, 10, &mminus);
	tc1 = mp_cmp_mag(&r, &mminus);
	if (lowOK) {
	    tc1 = (tc1 <= 0);
	} else {
	    tc1 = (tc1 < 0);
	}
	mp_add(&r, &mplus, &temp);
	tc2 = mp_cmp_mag(&temp, &s);
	if (highOK) {
	    tc2 = (tc2 >= 0);
	} else {
	    tc2= (tc2 > 0);
	}
	if ( ! tc1 ) {
	    if ( !tc2 ) {
		*string++ = '0' + i;
	    } else {
		c = (char) (i + '1');
		break;
	    }
	} else {
	    if (!tc2) {
		c = (char) (i + '0');
	    } else {
		mp_mul_2d(&r, 1, &r);
		n = mp_cmp_mag(&r, &s);
		if (n < 0) {
		    c = (char) (i + '0');
		} else {
		    c = (char) (i + '1');
		}
	    }
	    break;
	}
    };
    *string++ = c;
    *string++ = '\0';

    /*
     * Free memory, and return.
     */

    mp_clear_multi(&r, &s, &mplus, &mminus, &temp, NULL);
    return k;
}

/*
 *----------------------------------------------------------------------
 *
 * AbsoluteValue --
 *
 *	Splits a 'double' into its absolute value and sign.
 *
 * Results:
 *	Returns the absolute value.
 *
 * Side effects:
 *	Stores the signum in '*signum'.
 *
 *----------------------------------------------------------------------
 */

static double
AbsoluteValue (double v,	/* Number to split */
	       int* signum)	/* (Output) Sign of the number 1=-, 0=+ */
{
    /*
     * Take the absolute value of the number, and report the number's sign.
     * Take special steps to preserve signed zeroes in IEEE floating point.
     * (We can't use fpclassify, because that's a C9x feature and we still
     * have to build on C89 compilers.)
     */

#ifndef IEEE_FLOATING_POINT
    if (v >= 0.0) {
	*signum = 0;
    } else {
	*signum = 1;
	v = -v;
    }
#else
    union {
	Tcl_WideUInt iv;
	double dv;
    } bitwhack;
    bitwhack.dv = v;
    if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) {
	*signum = 1;
	bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63);
	v = bitwhack.dv;
    } else {
	*signum = 0;
    }
#endif
    return v;
}

/*
 *----------------------------------------------------------------------
 *
 * GetIntegerTimesPower --
 *
 *	Converts a floating point number to an exact integer times a
 *	power of the floating point radix.
 *
 * Results:
 *	Returns 1 if it converted the smallest significand, 0 otherwise.
 *
 * Side effects:
 *	Initializes the integer value (does not just assign it),
 *	and stores the exponent.
 *
 *----------------------------------------------------------------------
 */

static int
GetIntegerTimesPower(double v,	/* Value to convert */
		     mp_int* rPtr,
				/* (Output) Integer value */
		     int* ePtr)	/* (Output) Power of FLT_RADIX by which
				 * r must be multiplied to yield v*/
{

    double a;
    double f;
    int e;
    int i;
    int n;

    /*
     * Develop f and e such that v = f * FLT_RADIX**e, with
     * 1.0/FLT_RADIX <= f < 1.
     */

    f = frexp(v, &e);
#if FLT_RADIX > 2
    n = e % log2FLT_RADIX;
    if (n > 0) {
	n -= log2FLT_RADIX;
	e += 1;
	f *= ldexp(1.0, n);
    }
    e = (e - n) / log2FLT_RADIX;
#endif
    if (f == 1.0) {
	f = 1.0 / FLT_RADIX;
	e += 1;
    }

    /*
     * If the original number was denormalized, adjust e and f to be denormal
     * as well.
     */

    if (e < DBL_MIN_EXP) {
	n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX;
	f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX);
	e = DBL_MIN_EXP;
	n = (n + DIGIT_BIT - 1) / DIGIT_BIT;
    } else {
	n = mantDIGIT;
    }

    /*
     * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision
     * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by
     * adjusting e.
     */

    a = f;
    n = mantDIGIT;
    mp_init_size(rPtr, n);
    rPtr->used = n;
    rPtr->sign = MP_ZPOS;
    i = (mantBits % DIGIT_BIT);
    if (i == 0) {
	i = DIGIT_BIT;
    }
    while (n > 0) {
	a *= ldexp(1.0, i);
	i = DIGIT_BIT;
	rPtr->dp[--n] = (mp_digit) a;
	a -= (mp_digit) a;
    }
    *ePtr = e - DBL_MANT_DIG;
    return (f == 1.0 / FLT_RADIX);
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitDoubleConversion --
 *
 *	Initializes constants that are needed for conversions to and from
 *	'double'
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The log base 2 of the floating point radix, the number of bits in a
 *	double mantissa, and a table of the powers of five and ten are
 *	computed and stored.
 *
 *----------------------------------------------------------------------
 */

void
TclInitDoubleConversion(void)
{
    int i;
    int x;
    Tcl_WideUInt u;
    double d;

    /*
     * Initialize table of powers of 10 expressed as wide integers.
     */

    maxpow10_wide =
	(int) floor(sizeof (Tcl_WideUInt) * CHAR_BIT * log (2.) / log (10.));
    pow10_wide = (Tcl_WideUInt*) Tcl_Alloc ((maxpow10_wide + 1)
					    * sizeof (Tcl_WideUInt));
    u = 1;
    for (i = 0; i < maxpow10_wide; ++i) {
	pow10_wide[i] = u;
	u *= 10;
    }
    pow10_wide[i] = u;

    /*
     * Determine how many bits of precision a double has, and how many
     * decimal digits that represents.
     */

    if ( frexp( (double) FLT_RADIX, &log2FLT_RADIX ) != 0.5 ) {
	Tcl_Panic( "This code doesn't work on a decimal machine!" );
    }
    --log2FLT_RADIX;
    mantBits = DBL_MANT_DIG * log2FLT_RADIX;
    d = 1.0;

    /* 
     * Initialize a table of powers of ten that can be exactly represented
     * in a double.
     */

    x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log( 5.0 ));
    if ( x < MAXPOW ) {
	mmaxpow = x;
    } else {
	mmaxpow = MAXPOW;
    }
    for (i=0 ; i<=mmaxpow ; ++i) {
	pow10[i] = d;
	d *= 10.0;
    }

    /* Initialize a table of large powers of five. */

    for ( i = 0; i < 9; ++i ) {
	mp_init( pow5 + i );
    }
    mp_set( pow5, 5 );
    for ( i = 0; i < 8; ++i ) {
	mp_sqr( pow5+i, pow5+i+1 );
    }

    /* 
     * Determine the number of decimal digits to the left and right of the
     * decimal point in the largest and smallest double, the smallest double
     * that differs from zero, and the number of mp_digits needed to represent 
     * the significand of a double.
     */

    tiny = SafeLdExp( 1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits );
    maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
			+ 0.5 * log(10.))
		       / log( 10. ));
    minDigits = (int) floor ( ( DBL_MIN_EXP - DBL_MANT_DIG )
			      * log( (double) FLT_RADIX ) / log( 10. ) );
    mantDIGIT = ( mantBits + DIGIT_BIT - 1 ) / DIGIT_BIT;
    log10_DIGIT_MAX = (int) floor (DIGIT_BIT * log(2.) / log (10.));
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeDoubleConversion --
 *
 *	Cleans up this file on exit.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Memory allocated by TclInitDoubleConversion is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeDoubleConversion()
{
    int i;
    Tcl_Free ((char*)pow10_wide);
    for ( i = 0; i < 9; ++i ) {
	mp_clear( pow5 + i );
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitBignumFromDouble --
 *
 *	Extracts the integer part of a double and converts it to
 *	an arbitrary precision integer.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes the bignum supplied, and stores the converted number
 *      in it.
 *
 *----------------------------------------------------------------------
 */

int
TclInitBignumFromDouble(Tcl_Interp *interp,	/* For error message */
			double d,	/* Number to convert */
			mp_int* b)	/* Place to store the result */
{
    double fract;
    int expt;

    /* Infinite values can't convert to bignum */
    if (TclIsInfinite(d)) {
	if (interp != NULL) {
	    char *s = "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
    }
    fract = frexp(d,&expt);
    if (expt <= 0) {
	mp_init(b);
	mp_zero(b);
    } else {
	Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits);
	int shift = expt - mantBits;
	TclBNInitBignumFromWideInt(b, w);
	if (shift < 0) {
	    mp_div_2d(b, -shift, b, NULL);
	} else if (shift > 0) {
	    mp_mul_2d(b, shift, b);
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclBignumToDouble --
 *
 *	Convert an arbitrary-precision integer to a native floating point
 *	number.
 *
 * Results:
 *	Returns the converted number.  Sets errno to ERANGE if the number is
 *	too large to convert.
 *
 *----------------------------------------------------------------------
 */

double
TclBignumToDouble(mp_int *a)	/* Integer to convert. */
{
    mp_int b;
    int bits;
    int shift;
    int i;
    double r;

    /*
     * Determine how many bits we need, and extract that many from the input.
     * Round to nearest unit in the last place.
     */

    bits = mp_count_bits(a);
    if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	errno = ERANGE;
	if (a->sign == MP_ZPOS) {
	    return HUGE_VAL;
	} else {
	    return -HUGE_VAL;
	}
    }
    shift = mantBits + 1 - bits;
    mp_init(&b);
    if (shift > 0) {
	mp_mul_2d(a, shift, &b);
    } else if (shift < 0) {
	mp_div_2d(a, -shift, &b, NULL);
    } else {
	mp_copy(a, &b);
    }
    mp_add_d(&b, 1, &b);
    mp_div_2d(&b, 1, &b, NULL);

    /*
     * Accumulate the result, one mp_digit at a time.
     */

    r = 0.0;
    for (i=b.used-1 ; i>=0 ; --i) {
	r = ldexp(r, DIGIT_BIT) + b.dp[i];
    }
    mp_clear(&b);

    /*
     * Scale the result to the correct number of bits.
     */

    r = ldexp(r, bits - mantBits);

    /*
     * Return the result with the appropriate sign.
     */

    if (a->sign == MP_ZPOS) {
	return r;
    } else {
	return -r;
    }
}

double
TclCeil(mp_int *a)	/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;

    mp_init(&b);
    if (mp_cmp_d(a, 0) == MP_LT) {
	mp_neg(a, &b);
	r = -TclFloor(&b);
    } else {
	int bits = mp_count_bits(a);

	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	    r = HUGE_VAL;
	} else {
	    int i, exact = 1, shift = mantBits - bits;

	    if (shift > 0) {
		mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_int d;
		mp_init(&d);
		mp_div_2d(a, -shift, &b, &d);
		exact = mp_iszero(&d);
		mp_clear(&d);
	    } else {
		mp_copy(a, &b);
	    }
	    if (!exact) {
		mp_add_d(&b, 1, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}

double
TclFloor(mp_int *a)	/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;

    mp_init(&b);
    if (mp_cmp_d(a, 0) == MP_LT) {
	mp_neg(a, &b);
	r = -TclCeil(&b);
    } else {
	int bits = mp_count_bits(a);

	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	    r = DBL_MAX;
	} else {
	    int i, shift = mantBits - bits;

	    if (shift > 0) {
		mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_div_2d(a, -shift, &b, NULL);
	    } else {
		mp_copy(a, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}

/*
 *----------------------------------------------------------------------
 *
 * BignumToBiasedFrExp --
 *
 *	Convert an arbitrary-precision integer to a native floating
 *	point number in the range [0.5,1) times a power of two.
 *	NOTE: Intentionally converts to a number that's a few
 *	ulp too small, so that RefineApproximation will not overflow
 *	near the high end of the machine's arithmetic range.
 *
 * Results:
 *	Returns the converted number.
 *
 * Side effects:
 *	Stores the exponent of two in 'machexp'.
 *
 *----------------------------------------------------------------------
 */

static double
BignumToBiasedFrExp( mp_int* a,
				/* Integer to convert */
		     int* machexp )
				/* Power of two */
{
    mp_int b;
    int bits;
    int shift;
    int i;
    double r;

    /* Determine how many bits we need, and extract that many from 
     * the input. Round to nearest unit in the last place. */

    bits = mp_count_bits( a );
    shift = mantBits - 2 - bits;
    mp_init( &b );
    if ( shift > 0 ) {
	mp_mul_2d( a, shift, &b );
    } else if ( shift < 0 ) {
	mp_div_2d( a, -shift, &b, NULL );
    } else {
	mp_copy( a, &b );
    }

    /* Accumulate the result, one mp_digit at a time */

    r = 0.0;
    for ( i = b.used-1; i >= 0; --i ) {
	r = ldexp( r, DIGIT_BIT ) + b.dp[i];
    }
    mp_clear( &b );

    /* Return the result with the appropriate sign. */

    *machexp = bits - mantBits + 2;
    if ( a->sign == MP_ZPOS ) {
	return r;
    } else {
	return -r;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Pow10TimesFrExp --
 *
 *	Multiply a power of ten by a number expressed as fraction and
 *	exponent.
 *
 * Results:
 *	Returns the significand of the result.
 *
 * Side effects:
 *	Overwrites the 'machexp' parameter with the exponent of the
 *	result.
 *
 * Assumes that 'exponent' is such that 10**exponent would be a double,
 * even though 'fraction*10**(machexp+exponent)' might overflow.
 *
 *----------------------------------------------------------------------
 */

static double
Pow10TimesFrExp( int exponent, 	/* Power of 10 to multiply by */
		 double fraction,
				/* Significand of multiplicand */
		 int* machexp )	/* On input, exponent of multiplicand.
				 * On output, exponent of result. */
{
    int i, j;
    int expt = *machexp;
    double retval = fraction;

    if ( exponent > 0 ) {

	/* Multiply by 10**exponent */
	
	retval = frexp( retval * pow10[ exponent & 0xf ], &j );
	expt += j;
	for ( i = 4; i < 9; ++i ) {
	    if ( exponent & (1<<i) ) {
		retval = frexp( retval * pow_10_2_n[ i ], &j );
		expt += j;
	    }
	}
    } else if ( exponent < 0 ) {

	/* Divide by 10**-exponent */

	retval = frexp( retval / pow10[ (-exponent) & 0xf ], &j );
	expt += j;
	for ( i = 4; i < 9; ++i ) {
	    if ( (-exponent) & (1<<i) ) {
		retval = frexp( retval / pow_10_2_n[ i ], &j );
		expt += j;
	    }
	}
    }

    *machexp = expt;
    return retval;
    
}

/*
 *----------------------------------------------------------------------
 *
 * SafeLdExp --
 *
 *	Do an 'ldexp' operation, but handle denormals gracefully.
 *
 * Results:
 *	Returns the appropriately scaled value.
 *
 *	On some platforms, 'ldexp' fails when presented with a number too
 *	small to represent as a normalized double. This routine does 'ldexp'
 *	in two steps for those numbers, to return correctly denormalized
 *	values.
 *
 *----------------------------------------------------------------------
 */

static double
SafeLdExp(double fract, int expt)
{
    int minexpt = DBL_MIN_EXP * log2FLT_RADIX;
    volatile double a, b, retval;
    if (expt < minexpt) {
	a = ldexp(fract, expt - mantBits - minexpt);
	b = ldexp(1.0, mantBits + minexpt);
	retval = a * b;
    } else {
	retval = ldexp(fract, expt);
    }
    return retval;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatNaN --
 *
 *	Makes the string representation of a "Not a Number"
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores the string representation in the supplied buffer, which must be
 *	at least TCL_DOUBLE_SPACE characters.
 *
 *----------------------------------------------------------------------
 */

void
TclFormatNaN(double value,	/* The Not-a-Number to format. */
	     char *buffer)	/* String representation. */
{
#ifndef IEEE_FLOATING_POINT
    strcpy(buffer, "NaN");
    return;
#else
    union {
	double dv;
	Tcl_WideUInt iv;
    } bitwhack;

    bitwhack.dv = value;
    if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) {
	bitwhack.iv &= ~ ((Tcl_WideUInt) 1 << 63);
	*buffer++ = '-';
    }
    *buffer++ = 'N';
    *buffer++ = 'a';
    *buffer++ = 'N';
    bitwhack.iv &= (((Tcl_WideUInt) 1) << 51) - 1;
    if (bitwhack.iv != 0) {
	sprintf(buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv);
    } else {
	*buffer = '\0';
    }
#endif /* IEEE_FLOATING_POINT */
}

Changes to generic/tclStringObj.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56





57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84





85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325


326
327
328
329
330
331
332
/* 
 * tclStringObj.c --
 *
 *	This file contains procedures that implement string operations on Tcl
 *	objects.  Some string operations work with UTF strings and others
 *	require Unicode format.  Functions that require knowledge of the width
 *	of each character, such as indexing, operate on Unicode data.
 *
 *	A Unicode string is an internationalized string.  Conceptually, a
 *	Unicode string is an array of 16-bit quantities organized as a sequence
 *	of properly formed UTF-8 characters.  There is a one-to-one map between
 *	Unicode and UTF characters.  Because Unicode characters have a fixed
 *	width, operations such as indexing operate on Unicode data.  The String
 *	object is optimized for the case where each UTF char in a string is
 *	only one byte.  In this case, we store the value of numChars, but we
 *	don't store the Unicode data (unless Tcl_GetUnicode is explicitly
 *	called).
 *
 *	The String object type stores one or both formats.  The default
 *	behavior is to store UTF.  Once Unicode is calculated by a function, it
 *	is stored in the internal rep for future access (without an additional
 *	O(n) cost).
 *
 *	To allow many appends to be done to an object without constantly
 *	reallocating the space for the string or Unicode representation, we
 *	allocate double the space for the string or Unicode and use the
 *	internal representation to keep track of how much space is used
 *	vs. allocated.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStringObj.c,v 1.35 2004/09/29 22:17:29 dkf Exp $ */

#include "tclInt.h"


/*
 * Prototypes for procedures defined later in this file:
 */

static void		AppendUnicodeToUnicodeRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
			    int appendNumChars));
static void		AppendUnicodeToUtfRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
			    int numChars));
static void		AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
    			    CONST char *bytes, int numBytes));
static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
    			    CONST char *bytes, int numBytes));

static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));






static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static int		SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));

/*
 * The structure below defines the string Tcl object type by means of
 * procedures that can be invoked by generic object code.
 */

Tcl_ObjType tclStringType = {
    "string",				/* name */
    FreeStringInternalRep,		/* freeIntRepPro */
    DupStringInternalRep,		/* dupIntRepProc */
    UpdateStringOfString,		/* updateStringProc */
    SetStringFromAny			/* setFromAnyProc */
};

/*
 * The following structure is the internal rep for a String object.
 * It keeps track of how much memory has been used and how much has been
 * allocated for the Unicode and UTF string to enable growing and
 * shrinking of the UTF and Unicode reps of the String object with fewer
 * mallocs.  To optimize string length and indexing operations, this
 * structure also stores the number of characters (same of UTF and Unicode!)
 * once that value has been computed.





 */

typedef struct String {
    int numChars;		/* The number of chars in the string.
				 * -1 means this value has not been
				 * calculated. >= 0 means that there is a
				 * valid Unicode rep, or that the number
				 * of UTF bytes == the number of chars. */
    size_t allocated;		/* The amount of space actually allocated
				 * for the UTF string (minus 1 byte for
				 * the termination char). */
    size_t uallocated;		/* The amount of space actually allocated
				 * for the Unicode string (minus 2 bytes for
				 * the termination char). */
    int hasUnicode;		/* Boolean determining whether the string
				 * has a Unicode representation. */
    Tcl_UniChar unicode[2];	/* The array of Unicode chars.  The actual
				 * size of this field depends on the
				 * 'uallocated' field above. */
} String;

#define STRING_UALLOC(numChars)	\
		(numChars * sizeof(Tcl_UniChar))
#define STRING_SIZE(ualloc)	\
		((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc))
#define GET_STRING(objPtr) \
		((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
		(objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)

/*
 * TCL STRING GROWTH ALGORITHM
 *
 * When growing strings (during an append, for example), the following growth
 * algorithm is used:
 *
 *   Attempt to allocate 2 * (originalLength + appendLength)
 *   On failure:
 *	attempt to allocate originalLength + 2*appendLength +
 *			TCL_GROWTH_MIN_ALLOC 
 *
 * This algorithm allows very good performance, as it rapidly increases the
 * memory allocated for a given string, which minimizes the number of
 * reallocations that must be performed.  However, using only the doubling
 * algorithm can lead to a significant waste of memory.  In particular, it
 * may fail even when there is sufficient memory available to complete the
 * append request (but there is not 2 * totalLength memory available).  So when
 * the doubling fails (because there is not enough memory available), the
 * algorithm requests a smaller amount of memory, which is still enough to
 * cover the request, but which hopefully will be less than the total available
 * memory.
 * 
 * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling
 * of very small appends.  Without this extra slush factor, a sequence
 * of several small appends would cause several memory allocations.
 * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can
 * avoid that behavior.
 *
 * The growth algorithm can be tuned by adjusting the following parameters:
 *
 * TCL_GROWTH_MIN_ALLOC		Additional space, in bytes, to allocate when
 *				the double allocation has failed.
 *				Default is 1024 (1 kilobyte).
 */

#ifndef TCL_GROWTH_MIN_ALLOC
#define TCL_GROWTH_MIN_ALLOC	1024
#endif


/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewStringObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new string object and
 *	initializes it from the byte pointer and length arguments.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewStringObj.
 *
 * Results:
 *	A newly created string object is returned that has ref count zero.
 *
 * Side effects:
 *	The new object's internal string representation will be set to a
 *	copy of the length bytes starting at "bytes". If "length" is
 *	negative, use bytes up to the first NULL byte; i.e., assume "bytes"
 *	points to a C-style NULL-terminated string. The object's type is set
 *	to NULL. An extra NULL is added to the end of the new object's byte
 *	array.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj

Tcl_Obj *
Tcl_NewStringObj(bytes, length)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    int length;			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If 
				 * negative, use bytes up to the first
				 * NULL byte. */
{
    return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewStringObj(bytes, length)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    int length;			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If 
				 * negative, use bytes up to the first
				 * NULL byte. */
{
    register Tcl_Obj *objPtr;

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }
    TclNewObj(objPtr);
    TclInitStringRep(objPtr, bytes, length);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewStringObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new string objects. It is the
 *	same as the Tcl_NewStringObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command	will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewStringObj.
 *
 * Results:
 *	A newly created string object is returned that has ref count zero.
 *
 * Side effects:
 *	The new object's internal string representation will be set to a
 *	copy of the length bytes starting at "bytes". If "length" is
 *	negative, use bytes up to the first NULL byte; i.e., assume "bytes"
 *	points to a C-style NULL-terminated string. The object's type is set
 *	to NULL. An extra NULL is added to the end of the new object's byte
 *	array.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    int length;			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If 
				 * negative, use bytes up to the first
				 * NULL byte. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }
    TclDbNewObj(objPtr, file, line);
    TclInitStringRep(objPtr, bytes, length);
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    register int length;	/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If 
				 * negative, use bytes up to the first
				 * NULL byte. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewStringObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_NewUnicodeObj --
 *
 *	This procedure is creates a new String object and initializes
 *	it from the given Unicode String.  If the Utf String is the same size
 *	as the Unicode string, don't duplicate the data.
 *
 * Results:
 *	The newly created object is returned.  This object will have no
 *	initial string representation.  The returned object has a ref count
 *	of 0.
 *
 * Side effects:
 *	Memory allocated for new object and copy of Unicode argument.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_NewUnicodeObj(unicode, numChars)
    CONST Tcl_UniChar *unicode;	/* The unicode string used to initialize
				 * the new object. */
    int numChars;		/* Number of characters in the unicode
				 * string. */
{
    Tcl_Obj *objPtr;
    String *stringPtr;
    size_t uallocated;

    if (numChars < 0) {
	numChars = 0;
	if (unicode) {
	    while (unicode[numChars] != 0) { numChars++; }


	}
    }
    uallocated = STRING_UALLOC(numChars);

    /*
     * Create a new obj with an invalid string rep.
     */
|


|
|
|


|
|
|
|
|
|
|
|
|

|
|






|
|




|
|

|


>


|



|


|


|

|
<

|
>
>
>
>
>









|



|
|
|
|
|



|
|
|
|
|
|
<
>
>
>
>
>



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|

|

|

|










|



|
|
|
|
|

|
|
|
|
|
|
|
<




|
|

>



<






|



|
|





|
|
|
|
|
<






<





|
|
|



<

<





|
|
|






<
|









|

|


|


|






|
|
|
|
|
<





<





|
|
|

|
|
|










<

<





|
|
|

|
|
|










|
|
|


|
|
<









|
|










|
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

150
151
152
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

183
184
185
186
187
188

189
190
191
192
193
194
195
196
197
198
199

200

201
202
203
204
205
206
207
208
209
210
211
212
213
214

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

245
246
247
248
249

250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

272

273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
/*
 * tclStringObj.c --
 *
 *	This file contains functions that implement string operations on Tcl
 *	objects. Some string operations work with UTF strings and others
 *	require Unicode format. Functions that require knowledge of the width
 *	of each character, such as indexing, operate on Unicode data.
 *
 *	A Unicode string is an internationalized string. Conceptually, a
 *	Unicode string is an array of 16-bit quantities organized as a
 *	sequence of properly formed UTF-8 characters. There is a one-to-one
 *	map between Unicode and UTF characters. Because Unicode characters
 *	have a fixed width, operations such as indexing operate on Unicode
 *	data. The String object is optimized for the case where each UTF char
 *	in a string is only one byte. In this case, we store the value of
 *	numChars, but we don't store the Unicode data (unless Tcl_GetUnicode
 *	is explicitly called).
 *
 *	The String object type stores one or both formats. The default
 *	behavior is to store UTF. Once Unicode is calculated by a function, it
 *	is stored in the internal rep for future access (without an additional
 *	O(n) cost).
 *
 *	To allow many appends to be done to an object without constantly
 *	reallocating the space for the string or Unicode representation, we
 *	allocate double the space for the string or Unicode and use the
 *	internal representation to keep track of how much space is used vs.
 *	allocated.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.11 2005/09/30 17:02:03 dgp Exp $ */

#include "tclInt.h"
#include "tommath.h"

/*
 * Prototypes for functions defined later in this file:
 */

static void		AppendUnicodeToUnicodeRep _ANSI_ARGS_((
			    Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
			    int appendNumChars));
static void		AppendUnicodeToUtfRep _ANSI_ARGS_((
			    Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
			    int numChars));
static void		AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));
static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    CONST char *bytes, int numBytes));

static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int		FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, CONST char *format,
			    va_list argList));
static int		ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, CONST char *format,
			    va_list argList));
static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr));
static int		SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));

/*
 * The structure below defines the string Tcl object type by means of
 * functions that can be invoked by generic object code.
 */

Tcl_ObjType tclStringType = {
    "string",			/* name */
    FreeStringInternalRep,	/* freeIntRepPro */
    DupStringInternalRep,	/* dupIntRepProc */
    UpdateStringOfString,	/* updateStringProc */
    SetStringFromAny		/* setFromAnyProc */
};

/*
 * The following structure is the internal rep for a String object. It keeps
 * track of how much memory has been used and how much has been allocated for
 * the Unicode and UTF string to enable growing and shrinking of the UTF and
 * Unicode reps of the String object with fewer mallocs. To optimize string
 * length and indexing operations, this structure also stores the number of
 * characters (same of UTF and Unicode!) once that value has been computed.

 *
 * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
 * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
 * can be officially modified by altering the definition of Tcl_UniChar in
 * tcl.h, but do not do that unless you are sure what you're doing!
 */

typedef struct String {
    int numChars;		/* The number of chars in the string. -1 means
				 * this value has not been calculated. >= 0
				 * means that there is a valid Unicode rep, or
				 * that the number of UTF bytes == the number
				 * of chars. */
    size_t allocated;		/* The amount of space actually allocated for
				 * the UTF string (minus 1 byte for the
				 * termination char). */
    size_t uallocated;		/* The amount of space actually allocated for
				 * the Unicode string (minus 2 bytes for the
				 * termination char). */
    int hasUnicode;		/* Boolean determining whether the string has
				 * a Unicode representation. */
    Tcl_UniChar unicode[2];	/* The array of Unicode chars. The actual size
				 * of this field depends on the 'uallocated'
				 * field above. */
} String;

#define STRING_UALLOC(numChars)	\
	(numChars * sizeof(Tcl_UniChar))
#define STRING_SIZE(ualloc)	\
	((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc))
#define GET_STRING(objPtr) \
	((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
	((objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr))

/*
 * TCL STRING GROWTH ALGORITHM
 *
 * When growing strings (during an append, for example), the following growth
 * algorithm is used:
 *
 *   Attempt to allocate 2 * (originalLength + appendLength)
 *   On failure:
 *	attempt to allocate originalLength + 2*appendLength +
 *			TCL_GROWTH_MIN_ALLOC
 *
 * This algorithm allows very good performance, as it rapidly increases the
 * memory allocated for a given string, which minimizes the number of
 * reallocations that must be performed. However, using only the doubling
 * algorithm can lead to a significant waste of memory. In particular, it may
 * fail even when there is sufficient memory available to complete the append
 * request (but there is not 2*totalLength memory available). So when the
 * doubling fails (because there is not enough memory available), the
 * algorithm requests a smaller amount of memory, which is still enough to
 * cover the request, but which hopefully will be less than the total
 * available memory.
 *
 * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very
 * small appends. Without this extra slush factor, a sequence of several small
 * appends would cause several memory allocations. As long as
 * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior.

 *
 * The growth algorithm can be tuned by adjusting the following parameters:
 *
 * TCL_GROWTH_MIN_ALLOC		Additional space, in bytes, to allocate when
 *				the double allocation has failed. Default is
 *				1024 (1 kilobyte).
 */

#ifndef TCL_GROWTH_MIN_ALLOC
#define TCL_GROWTH_MIN_ALLOC	1024
#endif


/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewStringObj --
 *
 *	This function is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new string object and
 *	initializes it from the byte pointer and length arguments.
 *
 *	When TCL_MEM_DEBUG is defined, this function just returns the result
 *	of calling the debugging version Tcl_DbNewStringObj.
 *
 * Results:
 *	A newly created string object is returned that has ref count zero.
 *
 * Side effects:
 *	The new object's internal string representation will be set to a copy
 *	of the length bytes starting at "bytes". If "length" is negative, use
 *	bytes up to the first NULL byte; i.e., assume "bytes" points to a
 *	C-style NULL-terminated string. The object's type is set to NULL. An
 *	extra NULL is added to the end of the new object's byte array.

 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj

Tcl_Obj *
Tcl_NewStringObj(bytes, length)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    int length;			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * negative, use bytes up to the first NULL
				 * byte. */
{
    return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewStringObj(bytes, length)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    int length;			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * negative, use bytes up to the first NULL
				 * byte. */
{
    register Tcl_Obj *objPtr;

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }

    TclNewStringObj(objPtr, bytes, length);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewStringObj --
 *
 *	This function is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new string objects. It is the
 *	same as the Tcl_NewStringObj function above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this function just returns the
 *	result of calling Tcl_NewStringObj.
 *
 * Results:
 *	A newly created string object is returned that has ref count zero.
 *
 * Side effects:
 *	The new object's internal string representation will be set to a copy
 *	of the length bytes starting at "bytes". If "length" is negative, use
 *	bytes up to the first NULL byte; i.e., assume "bytes" points to a
 *	C-style NULL-terminated string. The object's type is set to NULL. An
 *	extra NULL is added to the end of the new object's byte array.

 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    int length;			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * negative, use bytes up to the first NULL
				 * byte. */
    CONST char *file;		/* The name of the source file calling this
				 * function; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    register Tcl_Obj *objPtr;

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }
    TclDbNewObj(objPtr, file, line);
    TclInitStringRep(objPtr, bytes, length);
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    register int length;	/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * negative, use bytes up to the first NULL
				 * byte. */
    CONST char *file;		/* The name of the source file calling this
				 * function; used for debugging. */
    int line;			/* Line number in the source file; used for
				 * debugging. */
{
    return Tcl_NewStringObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_NewUnicodeObj --
 *
 *	This function is creates a new String object and initializes it from
 *	the given Unicode String.  If the Utf String is the same size as the
 *	Unicode string, don't duplicate the data.
 *
 * Results:
 *	The newly created object is returned. This object will have no initial
 *	string representation. The returned object has a ref count of 0.

 *
 * Side effects:
 *	Memory allocated for new object and copy of Unicode argument.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_NewUnicodeObj(unicode, numChars)
    CONST Tcl_UniChar *unicode;	/* The unicode string used to initialize the
				 * new object. */
    int numChars;		/* Number of characters in the unicode
				 * string. */
{
    Tcl_Obj *objPtr;
    String *stringPtr;
    size_t uallocated;

    if (numChars < 0) {
	numChars = 0;
	if (unicode) {
	    while (unicode[numChars] != 0) {
		numChars++;
	    }
	}
    }
    uallocated = STRING_UALLOC(numChars);

    /*
     * Create a new obj with an invalid string rep.
     */
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368

369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388


389
390
391



392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510

511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
 *
 *	Get the length of the Unicode string from the Tcl object.
 *
 * Results:
 *	Pointer to unicode string representing the unicode object.
 *
 * Side effects:
 *	Frees old internal rep.  Allocates memory for new "String"
 *	internal rep.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCharLength(objPtr)
    Tcl_Obj *objPtr;	/* The String object to get the num chars of. */

{
    String *stringPtr;
    
    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If numChars is unknown, then calculate the number of characaters
     * while populating the Unicode string.
     */
    
    if (stringPtr->numChars == -1) {
	register int i = objPtr->length;
	register unsigned char *str = (unsigned char *) objPtr->bytes;

	/*
	 * This is a speed sensitive function, so run specially over the
	 * string to count continuous ascii characters before resorting
	 * to the Tcl_NumUtfChars call.  This is a long form of:
	 stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);


	*/

	while (i && (*str < 0xC0)) { i--; str++; }



	stringPtr->numChars = objPtr->length - i;
	if (i) {
	    stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes
		    + (objPtr->length - i), i);
	}

 	if (stringPtr->numChars == objPtr->length) {

	    /*
	     * Since we've just calculated the number of chars, and all
	     * UTF chars are 1-byte long, we don't need to store the
	     * unicode string.
	     */

	    stringPtr->hasUnicode = 0;

	} else {
    
	    /*
	     * Since we've just calucalated the number of chars, and not
	     * all UTF chars are 1-byte long, go ahead and populate the
	     * unicode string.
	     */

	    FillUnicodeRep(objPtr);

	    /*
	     * We need to fetch the pointer again because we have just
	     * reallocated the structure to make room for the Unicode data.
	     */
	    
	    stringPtr = GET_STRING(objPtr);
	}
    }
    return stringPtr->numChars;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUniChar --
 *
 *	Get the index'th Unicode character from the String object.  The
 *	index is assumed to be in the appropriate range.
 *
 * Results:
 *	Returns the index'th Unicode character in the Object.
 *
 * Side effects:
 *	Fills unichar with the index'th Unicode character.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar
Tcl_GetUniChar(objPtr, index)
    Tcl_Obj *objPtr;	/* The object to get the Unicode charater from. */

    int index;		/* Get the index'th Unicode character. */
{
    Tcl_UniChar unichar;
    String *stringPtr;
    
    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->numChars == -1) {

	/*
	 * We haven't yet calculated the length, so we don't have the
	 * Unicode str.  We need to know the number of chars before we
	 * can do indexing.
	 */

	Tcl_GetCharLength(objPtr);

	/*
	 * We need to fetch the pointer again because we may have just
	 * reallocated the structure.
	 */
	
	stringPtr = GET_STRING(objPtr);
    }
    if (stringPtr->hasUnicode == 0) {

	/*
	 * All of the characters in the Utf string are 1 byte chars,
	 * so we don't store the unicode char.  We get the Utf string
	 * and convert the index'th byte to a Unicode character.
	 */

	unichar = (Tcl_UniChar) objPtr->bytes[index];
    } else {
	unichar = stringPtr->unicode[index];
    }
    return unichar;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUnicode --
 *
 *	Get the Unicode form of the String object.  If
 *	the object is not already a String object, it will be converted
 *	to one.  If the String object does not have a Unicode rep, then
 *	one is create from the UTF string format.
 *
 * Results:
 *	Returns a pointer to the object's internal Unicode string.
 *
 * Side effects:
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicode(objPtr)
    Tcl_Obj *objPtr;	/* The object to find the unicode string for. */

{
    String *stringPtr;
    
    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);
    
    if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {

	/*
	 * We haven't yet calculated the length, or all of the characters
	 * in the Utf string are 1 byte chars (so we didn't store the
	 * unicode str).  Since this function must return a unicode string,
	 * and one has not yet been stored, force the Unicode to be
	 * calculated and stored now.
	 */

	FillUnicodeRep(objPtr);

	/*
	 * We need to fetch the pointer again because we have just
	 * reallocated the structure to make room for the Unicode data.
	 */
	
	stringPtr = GET_STRING(objPtr);
    }
    return stringPtr->unicode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUnicodeFromObj --
 *
 *	Get the Unicode form of the String object with length.  If
 *	the object is not already a String object, it will be converted
 *	to one.  If the String object does not have a Unicode rep, then
 *	one is create from the UTF string format.
 *
 * Results:
 *	Returns a pointer to the object's internal Unicode string.
 *
 * Side effects:
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
    Tcl_Obj *objPtr;	/* The object to find the unicode string for. */

    int *lengthPtr;	/* If non-NULL, the location where the
			 * string rep's unichar length should be
			 * stored. If NULL, no length is stored. */
{
    String *stringPtr;
    
    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);
    
    if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {

	/*
	 * We haven't yet calculated the length, or all of the characters
	 * in the Utf string are 1 byte chars (so we didn't store the
	 * unicode str).  Since this function must return a unicode string,
	 * and one has not yet been stored, force the Unicode to be
	 * calculated and stored now.
	 */

	FillUnicodeRep(objPtr);

	/*
	 * We need to fetch the pointer again because we have just
	 * reallocated the structure to make room for the Unicode data.
	 */
	
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	*lengthPtr = stringPtr->numChars;
    }
    return stringPtr->unicode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetRange --
 *
 *	Create a Tcl Object that contains the chars between first and last
 *	of the object indicated by "objPtr".  If the object is not already
 *	a String object, convert it to one.  The first and last indices
 *	are assumed to be in the appropriate range.
 *
 * Results:
 *	Returns a new Tcl Object of the String type.
 *
 * Side effects:
 *	Changes the internal rep of "objPtr" to the String type.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetRange(objPtr, first, last)
    Tcl_Obj *objPtr;		/* The Tcl object to find the range of. */
    int first;			/* First index of the range. */
    int last;			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;
    
    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->numChars == -1) {
    
	/*
	 * We haven't yet calculated the length, so we don't have the
	 * Unicode str.  We need to know the number of chars before we
	 * can do indexing.
	 */

	Tcl_GetCharLength(objPtr);

	/*
	 * We need to fetch the pointer again because we may have just
	 * reallocated the structure.
	 */
	
	stringPtr = GET_STRING(objPtr);
    }

    if (stringPtr->numChars == objPtr->length) {
	char *str = Tcl_GetString(objPtr);

	/*
	 * All of the characters in the Utf string are 1 byte chars,
	 * so we don't store the unicode char.  Create a new string
	 * object containing the specified range of chars.
	 */
	
	newObjPtr = Tcl_NewStringObj(&str[first], last-first+1);

	/*
	 * Since we know the new string only has 1-byte chars, we
	 * can set it's numChars field.
	 */
	
	SetStringFromAny(NULL, newObjPtr);
	stringPtr = GET_STRING(newObjPtr);
	stringPtr->numChars = last-first+1;
    } else {
	newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first,
		last-first+1);
    }
    return newObjPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStringObj --
 *
 *	Modify an object to hold a string that is a copy of the bytes
 *	indicated by the byte pointer and length arguments. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string representation will be set to a copy of
 *	the "length" bytes starting at "bytes". If "length" is negative, use
 *	bytes up to the first NULL byte; i.e., assume "bytes" points to a
 *	C-style NULL-terminated string. The object's old string and internal
 *	representations are freed and the object's type is set NULL.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetStringObj(objPtr, bytes, length)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the object. */
    register int length;	/* The number of bytes to copy from "bytes"
				 * when initializing the object. If 
				 * negative, use bytes up to the first
				 * NULL byte.*/
{
    /*
     * Free any old string rep, then set the string rep to a copy of
     * the length bytes starting at "bytes".
     */

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetStringObj called with shared object");
    }

    /*







|
|






|
>


|




|
|

|






|
|
|
>
>
|

|
>
>
>






|
<

|
|
|



<

<

|
|
|








|











|
|












|
>
|



|




<

|
|
<








|



<

|
|
|














|
|
|
|












|
>


|


|

<

|
|
|
|
|





|
|

|










|
|
|
|












|
>
|
|
|


|


|

<

|
|
|
|
|





|
|

|














|
|
|
|


















|




<

|
|
<








|







|
|
|

|



|
|

|
















|





|
|
|
|











|
|
<


|
|







353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404

405
406
407
408
409
410
411

412

413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

462
463
464

465
466
467
468
469
470
471
472
473
474
475
476

477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519

520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628

629
630
631

632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698

699
700
701
702
703
704
705
706
707
708
709
 *
 *	Get the length of the Unicode string from the Tcl object.
 *
 * Results:
 *	Pointer to unicode string representing the unicode object.
 *
 * Side effects:
 *	Frees old internal rep. Allocates memory for new "String" internal
 *	rep.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCharLength(objPtr)
    Tcl_Obj *objPtr;		/* The String object to get the num chars
				 * of. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If numChars is unknown, then calculate the number of characaters while
     * populating the Unicode string.
     */

    if (stringPtr->numChars == -1) {
	register int i = objPtr->length;
	register unsigned char *str = (unsigned char *) objPtr->bytes;

	/*
	 * This is a speed sensitive function, so run specially over the
	 * string to count continuous ascii characters before resorting to the
	 * Tcl_NumUtfChars call. This is a long form of:
	 stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length);
	 *
	 * TODO: Consider macro-izing this.
	 */

	while (i && (*str < 0xC0)) {
	    i--;
	    str++;
	}
	stringPtr->numChars = objPtr->length - i;
	if (i) {
	    stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes
		    + (objPtr->length - i), i);
	}

	if (stringPtr->numChars == objPtr->length) {

	    /*
	     * Since we've just calculated the number of chars, and all UTF
	     * chars are 1-byte long, we don't need to store the unicode
	     * string.
	     */

	    stringPtr->hasUnicode = 0;

	} else {

	    /*
	     * Since we've just calucalated the number of chars, and not all
	     * UTF chars are 1-byte long, go ahead and populate the unicode
	     * string.
	     */

	    FillUnicodeRep(objPtr);

	    /*
	     * We need to fetch the pointer again because we have just
	     * reallocated the structure to make room for the Unicode data.
	     */

	    stringPtr = GET_STRING(objPtr);
	}
    }
    return stringPtr->numChars;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUniChar --
 *
 *	Get the index'th Unicode character from the String object. The index
 *	is assumed to be in the appropriate range.
 *
 * Results:
 *	Returns the index'th Unicode character in the Object.
 *
 * Side effects:
 *	Fills unichar with the index'th Unicode character.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar
Tcl_GetUniChar(objPtr, index)
    Tcl_Obj *objPtr;		/* The object to get the Unicode charater
				 * from. */
    int index;			/* Get the index'th Unicode character. */
{
    Tcl_UniChar unichar;
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->numChars == -1) {

	/*
	 * We haven't yet calculated the length, so we don't have the Unicode
	 * str. We need to know the number of chars before we can do indexing.

	 */

	Tcl_GetCharLength(objPtr);

	/*
	 * We need to fetch the pointer again because we may have just
	 * reallocated the structure.
	 */

	stringPtr = GET_STRING(objPtr);
    }
    if (stringPtr->hasUnicode == 0) {

	/*
	 * All of the characters in the Utf string are 1 byte chars, so we
	 * don't store the unicode char. We get the Utf string and convert the
	 * index'th byte to a Unicode character.
	 */

	unichar = (Tcl_UniChar) objPtr->bytes[index];
    } else {
	unichar = stringPtr->unicode[index];
    }
    return unichar;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUnicode --
 *
 *	Get the Unicode form of the String object. If the object is not
 *	already a String object, it will be converted to one. If the String
 *	object does not have a Unicode rep, then one is create from the UTF
 *	string format.
 *
 * Results:
 *	Returns a pointer to the object's internal Unicode string.
 *
 * Side effects:
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicode(objPtr)
    Tcl_Obj *objPtr;		/* The object to find the unicode string
				 * for. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {

	/*
	 * We haven't yet calculated the length, or all of the characters in
	 * the Utf string are 1 byte chars (so we didn't store the unicode
	 * str). Since this function must return a unicode string, and one has
	 * not yet been stored, force the Unicode to be calculated and stored
	 * now.
	 */

	FillUnicodeRep(objPtr);

	/*
	 * We need to fetch the pointer again because we have just reallocated
	 * the structure to make room for the Unicode data.
	 */

	stringPtr = GET_STRING(objPtr);
    }
    return stringPtr->unicode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUnicodeFromObj --
 *
 *	Get the Unicode form of the String object with length. If the object
 *	is not already a String object, it will be converted to one. If the
 *	String object does not have a Unicode rep, then one is create from the
 *	UTF string format.
 *
 * Results:
 *	Returns a pointer to the object's internal Unicode string.
 *
 * Side effects:
 *	Converts the object to have the String internal rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
    Tcl_Obj *objPtr;		/* The object to find the unicode string
				 * for. */
    int *lengthPtr;		/* If non-NULL, the location where the string
				 * rep's unichar length should be stored. If
				 * NULL, no length is stored. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {

	/*
	 * We haven't yet calculated the length, or all of the characters in
	 * the Utf string are 1 byte chars (so we didn't store the unicode
	 * str). Since this function must return a unicode string, and one has
	 * not yet been stored, force the Unicode to be calculated and stored
	 * now.
	 */

	FillUnicodeRep(objPtr);

	/*
	 * We need to fetch the pointer again because we have just reallocated
	 * the structure to make room for the Unicode data.
	 */

	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	*lengthPtr = stringPtr->numChars;
    }
    return stringPtr->unicode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetRange --
 *
 *	Create a Tcl Object that contains the chars between first and last of
 *	the object indicated by "objPtr". If the object is not already a
 *	String object, convert it to one. The first and last indices are
 *	assumed to be in the appropriate range.
 *
 * Results:
 *	Returns a new Tcl Object of the String type.
 *
 * Side effects:
 *	Changes the internal rep of "objPtr" to the String type.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetRange(objPtr, first, last)
    Tcl_Obj *objPtr;		/* The Tcl object to find the range of. */
    int first;			/* First index of the range. */
    int last;			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->numChars == -1) {

	/*
	 * We haven't yet calculated the length, so we don't have the Unicode
	 * str. We need to know the number of chars before we can do indexing.

	 */

	Tcl_GetCharLength(objPtr);

	/*
	 * We need to fetch the pointer again because we may have just
	 * reallocated the structure.
	 */

	stringPtr = GET_STRING(objPtr);
    }

    if (stringPtr->numChars == objPtr->length) {
	char *str = Tcl_GetString(objPtr);

	/*
	 * All of the characters in the Utf string are 1 byte chars, so we
	 * don't store the unicode char. Create a new string object containing
	 * the specified range of chars.
	 */

	newObjPtr = Tcl_NewStringObj(&str[first], last-first+1);

	/*
	 * Since we know the new string only has 1-byte chars, we can set it's
	 * numChars field.
	 */

	SetStringFromAny(NULL, newObjPtr);
	stringPtr = GET_STRING(newObjPtr);
	stringPtr->numChars = last-first+1;
    } else {
	newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first,
		last-first+1);
    }
    return newObjPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStringObj --
 *
 *	Modify an object to hold a string that is a copy of the bytes
 *	indicated by the byte pointer and length arguments.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string representation will be set to a copy of the
 *	"length" bytes starting at "bytes". If "length" is negative, use bytes
 *	up to the first NULL byte; i.e., assume "bytes" points to a C-style
 *	NULL-terminated string. The object's old string and internal
 *	representations are freed and the object's type is set NULL.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetStringObj(objPtr, bytes, length)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    CONST char *bytes;		/* Points to the first of the length bytes
				 * used to initialize the object. */
    register int length;	/* The number of bytes to copy from "bytes"
				 * when initializing the object. If negative,
				 * use bytes up to the first NULL byte.*/

{
    /*
     * Free any old string rep, then set the string rep to a copy of the
     * length bytes starting at "bytes".
     */

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetStringObj called with shared object");
    }

    /*
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

766

767
768
769
770
771
772
773
774
775

776
777
778
779
780
781
782
783
784
785
786
787
788


789


790
791
792
793
794
795

796


797
798


799


800
801
802

803


804

805
806
807
808
809
810
811
812


813


814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860

861

862
863
864
865
866
867
868
869
870

871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889


890


891
892
893
894
895
896

897


898
899


900


901
902
903

904


905

906
907
908
909
910
911
912
913
914
915
916


917


918
919
920
921
922
923
924
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjLength --
 *
 *	This procedure changes the length of the string representation
 *	of an object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the size of objPtr's string representation is greater than
 *	length, then it is reduced to length and a new terminating null
 *	byte is stored in the strength.  If the length of the string
 *	representation is greater than length, the storage space is
 *	reallocated to the given length; a null byte is stored at the
 *	end, but other bytes past the end of the original string
 *	representation are undefined.  The object's internal
 *	representation is changed to "expendable string".
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjLength(objPtr, length)
    register Tcl_Obj *objPtr;	/* Pointer to object.  This object must
				 * not currently be shared. */
    register int length;	/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetObjLength called with shared object");
    }
    SetStringFromAny(NULL, objPtr);
    
    stringPtr = GET_STRING(objPtr);
    

    /* Check that we're not extending a pure unicode string */

    
    if (length > (int) stringPtr->allocated && 
	    (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
	char *new;

	/*
	 * Not enough space in current string. Reallocate the string
	 * space and free the old string.
	 */

	if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
	    new = (char *) ckrealloc((char *)objPtr->bytes,
		    (unsigned)(length+1));
	} else {
	    new = (char *) ckalloc((unsigned) (length+1));
	    if (objPtr->bytes != NULL && objPtr->length != 0) {
		memcpy((VOID *) new, (VOID *) objPtr->bytes,
			(size_t) objPtr->length);
		Tcl_InvalidateStringRep(objPtr);
	    }
	}
	objPtr->bytes = new;
	stringPtr->allocated = length;


	/* Invalidate the unicode data. */


	stringPtr->hasUnicode = 0;
    }
    
    if (objPtr->bytes != NULL) {
        objPtr->length = length;
        if (objPtr->bytes != tclEmptyStringRep) {

            /* Ensure the string is NULL-terminated */


            objPtr->bytes[length] = 0;
        }


        /* Invalidate the unicode data. */


        stringPtr->numChars = -1;
        stringPtr->hasUnicode = 0;
    } else {

        /* Changing length of pure unicode string */


        size_t uallocated = STRING_UALLOC(length);

        if (uallocated > stringPtr->uallocated) {
            stringPtr = (String *) ckrealloc((char*) stringPtr,
                    STRING_SIZE(uallocated));
            SET_STRING(objPtr, stringPtr);
            stringPtr->uallocated = uallocated;
        }
        stringPtr->numChars = length;
        stringPtr->hasUnicode = (length > 0);


        /* Ensure the string is NULL-terminated */


        stringPtr->unicode[length] = 0;
        stringPtr->allocated = 0;
        objPtr->length = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptSetObjLength --
 *
 *	This procedure changes the length of the string representation
 *	of an object.  It uses the attempt* (non-panic'ing) memory allocators.
 *
 * Results:
 *	1 if the requested memory was allocated, 0 otherwise.
 *
 * Side effects:
 *	If the size of objPtr's string representation is greater than
 *	length, then it is reduced to length and a new terminating null
 *	byte is stored in the strength.  If the length of the string
 *	representation is greater than length, the storage space is
 *	reallocated to the given length; a null byte is stored at the
 *	end, but other bytes past the end of the original string
 *	representation are undefined.  The object's internal
 *	representation is changed to "expendable string".
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AttemptSetObjLength(objPtr, length)
    register Tcl_Obj *objPtr;	/* Pointer to object.  This object must
				 * not currently be shared. */
    register int length;	/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_AttemptSetObjLength called with shared object");
    }
    SetStringFromAny(NULL, objPtr);
        
    stringPtr = GET_STRING(objPtr);


    /* Check that we're not extending a pure unicode string */


    if (length > (int) stringPtr->allocated && 
	    (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
	char *new;

	/*
	 * Not enough space in current string. Reallocate the string
	 * space and free the old string.
	 */

	if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
	    new = (char *) attemptckrealloc((char *)objPtr->bytes,
		    (unsigned)(length+1));
	    if (new == NULL) {
		return 0;
	    }
	} else {
	    new = (char *) attemptckalloc((unsigned) (length+1));
	    if (new == NULL) {
		return 0;
	    }
	    if (objPtr->bytes != NULL && objPtr->length != 0) {
 	    	memcpy((VOID *) new, (VOID *) objPtr->bytes,
 		    	(size_t) objPtr->length);
 	    	Tcl_InvalidateStringRep(objPtr);
	    }
	}
	objPtr->bytes = new;
	stringPtr->allocated = length;


	/* Invalidate the unicode data. */


	stringPtr->hasUnicode = 0;
    }
    
    if (objPtr->bytes != NULL) {
	objPtr->length = length;
	if (objPtr->bytes != tclEmptyStringRep) {

	    /* Ensure the string is NULL-terminated */


	    objPtr->bytes[length] = 0;
	}


	/* Invalidate the unicode data. */


	stringPtr->numChars = -1;
	stringPtr->hasUnicode = 0;
    } else {

	/* Changing length of pure unicode string */


	size_t uallocated = STRING_UALLOC(length);

	if (uallocated > stringPtr->uallocated) {
	    stringPtr = (String *) attemptckrealloc((char*) stringPtr,
		    STRING_SIZE(uallocated));
	    if (stringPtr == NULL) {
	        return 0;
	    }
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->uallocated = uallocated;
	}
	stringPtr->numChars = length;
	stringPtr->hasUnicode = (length > 0);


	/* Ensure the string is NULL-terminated */


	stringPtr->unicode[length] = 0;
	stringPtr->allocated = 0;
	objPtr->length = 0;
    }
    return 1;
}








|
|





|
|
|
|
<
|
|







|
|










|

|
>
|
>
|
|




|
|

>













>
>
|
>
>


|

|
|
>
|
>
>
|
|
>
>
|
>
>
|
|

>
|
>
>
|
>
|
|
|
|
|
|
|
|
>
>
|
>
>
|
|
|








|
|





|
|
|
|
<
|
|







|
|










|


>
|
>

|




|
|

>












|
|
|




>
>
|
>
>


|



>
|
>
>


>
>
|
>
>



>
|
>
>

>




|






>
>
|
>
>







721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738

739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854

855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjLength --
 *
 *	This function changes the length of the string representation of an
 *	object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the size of objPtr's string representation is greater than length,
 *	then it is reduced to length and a new terminating null byte is stored
 *	in the strength. If the length of the string representation is greater
 *	than length, the storage space is reallocated to the given length; a

 *	null byte is stored at the end, but other bytes past the end of the
 *	original string representation are undefined. The object's internal
 *	representation is changed to "expendable string".
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjLength(objPtr, length)
    register Tcl_Obj *objPtr;	/* Pointer to object. This object must not
				 * currently be shared. */
    register int length;	/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_SetObjLength called with shared object");
    }
    SetStringFromAny(NULL, objPtr);

    stringPtr = GET_STRING(objPtr);

    /*
     * Check that we're not extending a pure unicode string.
     */

    if (length > (int) stringPtr->allocated &&
	    (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
	char *new;

	/*
	 * Not enough space in current string. Reallocate the string space and
	 * free the old string.
	 */

	if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
	    new = (char *) ckrealloc((char *)objPtr->bytes,
		    (unsigned)(length+1));
	} else {
	    new = (char *) ckalloc((unsigned) (length+1));
	    if (objPtr->bytes != NULL && objPtr->length != 0) {
		memcpy((VOID *) new, (VOID *) objPtr->bytes,
			(size_t) objPtr->length);
		Tcl_InvalidateStringRep(objPtr);
	    }
	}
	objPtr->bytes = new;
	stringPtr->allocated = length;

	/*
	 * Invalidate the unicode data.
	 */

	stringPtr->hasUnicode = 0;
    }

    if (objPtr->bytes != NULL) {
	objPtr->length = length;
	if (objPtr->bytes != tclEmptyStringRep) {
	    /*
	     * Ensure the string is NULL-terminated.
	     */

	    objPtr->bytes[length] = 0;
	}

	/*
	 * Invalidate the unicode data.
	 */

	stringPtr->numChars = -1;
	stringPtr->hasUnicode = 0;
    } else {
	/*
	 * Changing length of pure unicode string.
	 */

	size_t uallocated = STRING_UALLOC(length);

	if (uallocated > stringPtr->uallocated) {
	    stringPtr = (String *) ckrealloc((char*) stringPtr,
		    STRING_SIZE(uallocated));
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->uallocated = uallocated;
	}
	stringPtr->numChars = length;
	stringPtr->hasUnicode = (length > 0);

	/*
	 * Ensure the string is NULL-terminated.
	 */

	stringPtr->unicode[length] = 0;
	stringPtr->allocated = 0;
	objPtr->length = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptSetObjLength --
 *
 *	This function changes the length of the string representation of an
 *	object. It uses the attempt* (non-panic'ing) memory allocators.
 *
 * Results:
 *	1 if the requested memory was allocated, 0 otherwise.
 *
 * Side effects:
 *	If the size of objPtr's string representation is greater than length,
 *	then it is reduced to length and a new terminating null byte is stored
 *	in the strength. If the length of the string representation is greater
 *	than length, the storage space is reallocated to the given length; a

 *	null byte is stored at the end, but other bytes past the end of the
 *	original string representation are undefined. The object's internal
 *	representation is changed to "expendable string".
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AttemptSetObjLength(objPtr, length)
    register Tcl_Obj *objPtr;	/* Pointer to object.  This object must not
				 * currently be shared. */
    register int length;	/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_AttemptSetObjLength called with shared object");
    }
    SetStringFromAny(NULL, objPtr);

    stringPtr = GET_STRING(objPtr);

    /*
     * Check that we're not extending a pure unicode string.
     */

    if (length > (int) stringPtr->allocated &&
	    (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
	char *new;

	/*
	 * Not enough space in current string. Reallocate the string space and
	 * free the old string.
	 */

	if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
	    new = (char *) attemptckrealloc((char *)objPtr->bytes,
		    (unsigned)(length+1));
	    if (new == NULL) {
		return 0;
	    }
	} else {
	    new = (char *) attemptckalloc((unsigned) (length+1));
	    if (new == NULL) {
		return 0;
	    }
	    if (objPtr->bytes != NULL && objPtr->length != 0) {
		memcpy((VOID *) new, (VOID *) objPtr->bytes,
		       (size_t) objPtr->length);
		Tcl_InvalidateStringRep(objPtr);
	    }
	}
	objPtr->bytes = new;
	stringPtr->allocated = length;

	/*
	 * Invalidate the unicode data.
	 */

	stringPtr->hasUnicode = 0;
    }

    if (objPtr->bytes != NULL) {
	objPtr->length = length;
	if (objPtr->bytes != tclEmptyStringRep) {
	    /*
	     * Ensure the string is NULL-terminated.
	     */

	    objPtr->bytes[length] = 0;
	}

	/*
	 * Invalidate the unicode data.
	 */

	stringPtr->numChars = -1;
	stringPtr->hasUnicode = 0;
    } else {
	/*
	 * Changing length of pure unicode string.
	 */

	size_t uallocated = STRING_UALLOC(length);

	if (uallocated > stringPtr->uallocated) {
	    stringPtr = (String *) attemptckrealloc((char*) stringPtr,
		    STRING_SIZE(uallocated));
	    if (stringPtr == NULL) {
		return 0;
	    }
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->uallocated = uallocated;
	}
	stringPtr->numChars = length;
	stringPtr->hasUnicode = (length > 0);

	/*
	 * Ensure the string is NULL-terminated.
	 */

	stringPtr->unicode[length] = 0;
	stringPtr->allocated = 0;
	objPtr->length = 0;
    }
    return 1;
}

937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955


956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977

978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_SetUnicodeObj(objPtr, unicode, numChars)
    Tcl_Obj *objPtr;		/* The object to set the string of. */
    CONST Tcl_UniChar *unicode;	/* The unicode string used to initialize
				 * the object. */
    int numChars;		/* Number of characters in the unicode
				 * string. */
{
    String *stringPtr;
    size_t uallocated;

    if (numChars < 0) {
	numChars = 0;
	if (unicode) {
	    while (unicode[numChars] != 0) { numChars++; }


	}
    }
    uallocated = STRING_UALLOC(numChars);

    /*
     * Free the internal rep if one exists, and invalidate the string rep.
     */

    TclFreeIntRep(objPtr);
    objPtr->typePtr = &tclStringType;

    /*
     * Allocate enough space for the String structure + Unicode string.
     */
	
    stringPtr = (String *) ckalloc(STRING_SIZE(uallocated));
    stringPtr->numChars = numChars;
    stringPtr->uallocated = uallocated;
    stringPtr->hasUnicode = (numChars > 0);
    stringPtr->allocated = 0;
    memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated);
    stringPtr->unicode[numChars] = 0;

    SET_STRING(objPtr, stringPtr);
    Tcl_InvalidateStringRep(objPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * TclAppendLimitedToObj --
 *
 *	This procedure appends a limited number of bytes from a sequence
 *	of bytes to an object, marking any limitation with an ellipsis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The bytes at *bytes are appended to the string representation
 *	of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
    register Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST char *bytes;		/* Points to the bytes to append to the
				 * object. */
    register int length;	/* The number of bytes available to be
				 * appended from "bytes".  If < 0, then
				 * all bytes up to a NULL byte are available. */
    register int limit;		/* The maximum number of bytes to append
				 * to the object. */
    CONST char *ellipsis;	/* Ellipsis marker string, appended to
				 * the object to indicate not all available
				 * bytes at "bytes" were appended. */
{
    String *stringPtr;
    int toCopy = 0;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("TclAppendLimitedToObj called with shared object");
    }







|
|









|
>
>














|







>










|
|





|
|










|
|
|
|
|
|
|







977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_SetUnicodeObj(objPtr, unicode, numChars)
    Tcl_Obj *objPtr;		/* The object to set the string of. */
    CONST Tcl_UniChar *unicode;	/* The unicode string used to initialize the
				 * object. */
    int numChars;		/* Number of characters in the unicode
				 * string. */
{
    String *stringPtr;
    size_t uallocated;

    if (numChars < 0) {
	numChars = 0;
	if (unicode) {
	    while (unicode[numChars] != 0) {
		numChars++;
	    }
	}
    }
    uallocated = STRING_UALLOC(numChars);

    /*
     * Free the internal rep if one exists, and invalidate the string rep.
     */

    TclFreeIntRep(objPtr);
    objPtr->typePtr = &tclStringType;

    /*
     * Allocate enough space for the String structure + Unicode string.
     */

    stringPtr = (String *) ckalloc(STRING_SIZE(uallocated));
    stringPtr->numChars = numChars;
    stringPtr->uallocated = uallocated;
    stringPtr->hasUnicode = (numChars > 0);
    stringPtr->allocated = 0;
    memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated);
    stringPtr->unicode[numChars] = 0;

    SET_STRING(objPtr, stringPtr);
    Tcl_InvalidateStringRep(objPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * TclAppendLimitedToObj --
 *
 *	This function appends a limited number of bytes from a sequence of
 *	bytes to an object, marking any limitation with an ellipsis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The bytes at *bytes are appended to the string representation of
 *	objPtr.
 *
 *----------------------------------------------------------------------
 */

void
TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
    register Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST char *bytes;		/* Points to the bytes to append to the
				 * object. */
    register int length;	/* The number of bytes available to be
				 * appended from "bytes". If < 0, then all
				 * bytes up to a NULL byte are available. */
    register int limit;		/* The maximum number of bytes to append to
				 * the object. */
    CONST char *ellipsis;	/* Ellipsis marker string, appended to the
				 * object to indicate not all available bytes
				 * at "bytes" were appended. */
{
    String *stringPtr;
    int toCopy = 0;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("TclAppendLimitedToObj called with shared object");
    }
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
	if (ellipsis == NULL) {
	    ellipsis = "...";
	}
	toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
    }

    /*
     * If objPtr has a valid Unicode rep, then append the Unicode
     * conversion of "bytes" to the objPtr's Unicode rep, otherwise
     * append "bytes" to objPtr's string rep.
     */

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->hasUnicode != 0) {
	AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
    } else {
	AppendUtfToUtfRep(objPtr, bytes, toCopy);
    }

    if (length <= limit) {
	return;
    }

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->hasUnicode != 0) {
	AppendUtfToUnicodeRep(objPtr, ellipsis, -1);
    } else {
	AppendUtfToUtfRep(objPtr, ellipsis, -1);
    }

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendToObj --
 *
 *	This procedure appends a sequence of bytes to an object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The bytes at *bytes are appended to the string representation
 *	of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendToObj(objPtr, bytes, length)
    register Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST char *bytes;		/* Points to the bytes to append to the
				 * object. */
    register int length;	/* The number of bytes to append from
				 * "bytes". If < 0, then append all bytes
				 * up to NULL byte. */
{
    TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendUnicodeToObj --
 *
 *	This procedure appends a Unicode string to an object in the
 *	most efficient manner possible.  Length must be >= 0.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invalidates the string rep and creates a new Unicode string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendUnicodeToObj(objPtr, unicode, length)
    register Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST Tcl_UniChar *unicode;	/* The unicode string to append to the
			         * object. */
    int length;			/* Number of chars in "unicode". */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_AppendUnicodeToObj called with shared object");
    }

    if (length == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If objPtr has a valid Unicode rep, then append the "unicode"
     * to the objPtr's Unicode rep, otherwise the UTF conversion of
     * "unicode" to objPtr's string rep.
     */

    if (stringPtr->hasUnicode != 0) {
	AppendUnicodeToUnicodeRep(objPtr, unicode, length);
    } else {
	AppendUnicodeToUtfRep(objPtr, unicode, length);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendObjToObj --
 *
 *	This procedure appends the string rep of one object to another.
 *	"objPtr" cannot be a shared object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string rep of appendObjPtr is appended to the string 
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendObjToObj(objPtr, appendObjPtr)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
    Tcl_Obj *appendObjPtr;	/* Object to append. */
{
    String *stringPtr;
    int length, numChars, allOneByteChars;
    char *bytes;

    SetStringFromAny(NULL, objPtr);

    /*
     * If objPtr has a valid Unicode rep, then get a Unicode string
     * from appendObjPtr and append it.
     */

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->hasUnicode != 0) {
	
	/*
	 * If appendObjPtr is not of the "String" type, don't convert it.
	 */

	if (appendObjPtr->typePtr == &tclStringType) {
	    stringPtr = GET_STRING(appendObjPtr);
	    if ((stringPtr->numChars == -1)
		    || (stringPtr->hasUnicode == 0)) {
		
		/*
		 * If appendObjPtr is a string obj with no valid Unicode
		 * rep, then fill its unicode rep.
		 */

		FillUnicodeRep(appendObjPtr);
		stringPtr = GET_STRING(appendObjPtr);
	    }
	    AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode,
		    stringPtr->numChars);
	} else {
	    bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
	    AppendUtfToUnicodeRep(objPtr, bytes, length);
	}
	return;
    }

    /*
     * Append to objPtr's UTF string rep.  If we know the number of
     * characters in both objects before appending, then set the combined
     * number of characters in the final (appended-to) object.
     */

    bytes = Tcl_GetStringFromObj(appendObjPtr, &length);

    allOneByteChars = 0;
    numChars = stringPtr->numChars;
    if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {







|
|
|



















<







|





|
|









|
|
|









|
|














|
















|
|
|














|






|

















|
|




<






|
<
<

|
|















|
|
|







1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105

1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222

1223
1224
1225
1226
1227
1228
1229


1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
	if (ellipsis == NULL) {
	    ellipsis = "...";
	}
	toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
    }

    /*
     * If objPtr has a valid Unicode rep, then append the Unicode conversion
     * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
     * objPtr's string rep.
     */

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->hasUnicode != 0) {
	AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
    } else {
	AppendUtfToUtfRep(objPtr, bytes, toCopy);
    }

    if (length <= limit) {
	return;
    }

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->hasUnicode != 0) {
	AppendUtfToUnicodeRep(objPtr, ellipsis, -1);
    } else {
	AppendUtfToUtfRep(objPtr, ellipsis, -1);
    }

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendToObj --
 *
 *	This function appends a sequence of bytes to an object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The bytes at *bytes are appended to the string representation of
 *	objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendToObj(objPtr, bytes, length)
    register Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST char *bytes;		/* Points to the bytes to append to the
				 * object. */
    register int length;	/* The number of bytes to append from "bytes".
				 * If < 0, then append all bytes up to NULL
				 * byte. */
{
    TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendUnicodeToObj --
 *
 *	This function appends a Unicode string to an object in the most
 *	efficient manner possible. Length must be >= 0.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invalidates the string rep and creates a new Unicode string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendUnicodeToObj(objPtr, unicode, length)
    register Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST Tcl_UniChar *unicode;	/* The unicode string to append to the
				 * object. */
    int length;			/* Number of chars in "unicode". */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_AppendUnicodeToObj called with shared object");
    }

    if (length == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If objPtr has a valid Unicode rep, then append the "unicode" to the
     * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to
     * objPtr's string rep.
     */

    if (stringPtr->hasUnicode != 0) {
	AppendUnicodeToUnicodeRep(objPtr, unicode, length);
    } else {
	AppendUnicodeToUtfRep(objPtr, unicode, length);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendObjToObj --
 *
 *	This function appends the string rep of one object to another.
 *	"objPtr" cannot be a shared object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string rep of appendObjPtr is appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendObjToObj(objPtr, appendObjPtr)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
    Tcl_Obj *appendObjPtr;	/* Object to append. */
{
    String *stringPtr;
    int length, numChars, allOneByteChars;
    char *bytes;

    SetStringFromAny(NULL, objPtr);

    /*
     * If objPtr has a valid Unicode rep, then get a Unicode string from
     * appendObjPtr and append it.
     */

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->hasUnicode != 0) {

	/*
	 * If appendObjPtr is not of the "String" type, don't convert it.
	 */

	if (appendObjPtr->typePtr == &tclStringType) {
	    stringPtr = GET_STRING(appendObjPtr);
	    if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {


		/*
		 * If appendObjPtr is a string obj with no valid Unicode rep,
		 * then fill its unicode rep.
		 */

		FillUnicodeRep(appendObjPtr);
		stringPtr = GET_STRING(appendObjPtr);
	    }
	    AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode,
		    stringPtr->numChars);
	} else {
	    bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
	    AppendUtfToUnicodeRep(objPtr, bytes, length);
	}
	return;
    }

    /*
     * Append to objPtr's UTF string rep. If we know the number of characters
     * in both objects before appending, then set the combined number of
     * characters in the final (appended-to) object.
     */

    bytes = Tcl_GetStringFromObj(appendObjPtr, &length);

    allOneByteChars = 0;
    numChars = stringPtr->numChars;
    if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263


1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUnicodeToUnicodeRep --
 *
 *	This procedure appends the contents of "unicode" to the Unicode
 *	rep of "objPtr".  objPtr must already have a valid Unicode rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
    Tcl_Obj *objPtr;	        /* Points to the object to append to. */
    CONST Tcl_UniChar *unicode; /* String to append. */
    int appendNumChars;	        /* Number of chars of "unicode" to append. */
{
    String *stringPtr, *tmpString;
    size_t numChars;

    if (appendNumChars < 0) {
	appendNumChars = 0;
	if (unicode) {
	    while (unicode[appendNumChars] != 0) { appendNumChars++; }


	}
    }
    if (appendNumChars == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If not enough space has been allocated for the unicode rep,
     * reallocate the internal rep object with additional space.  First
     * try to double the required allocation; if that fails, try a more
     * modest increase.  See the "TCL STRING GROWTH ALGORITHM" comment at
     * the top of this file for an explanation of this growth algorithm.
     */

    numChars = stringPtr->numChars + appendNumChars;

    if (STRING_UALLOC(numChars) >= stringPtr->uallocated) {
     	stringPtr->uallocated = STRING_UALLOC(2 * numChars);
	tmpString = (String *) attemptckrealloc((char *)stringPtr,
		STRING_SIZE(stringPtr->uallocated));
	if (tmpString == NULL) {
	    stringPtr->uallocated =
	        STRING_UALLOC(numChars + appendNumChars) 
		+ TCL_GROWTH_MIN_ALLOC;
	    tmpString = (String *) ckrealloc((char *)stringPtr,
		    STRING_SIZE(stringPtr->uallocated));
	}
	stringPtr = tmpString;
	SET_STRING(objPtr, stringPtr);
    }








|
|












|
|
|







|
>
>










|
|
|
|
|





|




|
|







1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUnicodeToUnicodeRep --
 *
 *	This function appends the contents of "unicode" to the Unicode rep of
 *	"objPtr". objPtr must already have a valid Unicode rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
    CONST Tcl_UniChar *unicode;	/* String to append. */
    int appendNumChars;		/* Number of chars of "unicode" to append. */
{
    String *stringPtr, *tmpString;
    size_t numChars;

    if (appendNumChars < 0) {
	appendNumChars = 0;
	if (unicode) {
	    while (unicode[appendNumChars] != 0) {
		appendNumChars++;
	    }
	}
    }
    if (appendNumChars == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If not enough space has been allocated for the unicode rep, reallocate
     * the internal rep object with additional space. First try to double the
     * required allocation; if that fails, try a more modest increase. See the
     * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
     * explanation of this growth algorithm.
     */

    numChars = stringPtr->numChars + appendNumChars;

    if (STRING_UALLOC(numChars) >= stringPtr->uallocated) {
	stringPtr->uallocated = STRING_UALLOC(2 * numChars);
	tmpString = (String *) attemptckrealloc((char *)stringPtr,
		STRING_SIZE(stringPtr->uallocated));
	if (tmpString == NULL) {
	    stringPtr->uallocated =
		    STRING_UALLOC(numChars + appendNumChars)
		    + TCL_GROWTH_MIN_ALLOC;
	    tmpString = (String *) ckrealloc((char *)stringPtr,
		    STRING_SIZE(stringPtr->uallocated));
	}
	stringPtr = tmpString;
	SET_STRING(objPtr, stringPtr);
    }

1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340


1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUnicodeToUtfRep --
 *
 *	This procedure converts the contents of "unicode" to UTF and
 *	appends the UTF to the string rep of "objPtr".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUtfRep(objPtr, unicode, numChars)
    Tcl_Obj *objPtr;	        /* Points to the object to append to. */
    CONST Tcl_UniChar *unicode; /* String to convert to UTF. */
    int numChars;	        /* Number of chars of "unicode" to convert. */
{
    Tcl_DString dsPtr;
    CONST char *bytes;
    
    if (numChars < 0) {
	numChars = 0;
	if (unicode) {
	    while (unicode[numChars] != 0) { numChars++; }


	}
    }
    if (numChars == 0) {
	return;
    }

    Tcl_DStringInit(&dsPtr);
    bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr);
    AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr));
    Tcl_DStringFree(&dsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUtfToUnicodeRep --
 *
 *	This procedure converts the contents of "bytes" to Unicode and
 *	appends the Unicode to the Unicode rep of "objPtr".  objPtr must
 *	already have a valid Unicode rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
    Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST char *bytes;	/* String to convert to Unicode. */
    int numBytes;	/* Number of bytes of "bytes" to convert. */
{
    Tcl_DString dsPtr;
    int numChars;
    Tcl_UniChar *unicode;

    if (numBytes < 0) {
	numBytes = (bytes ? strlen(bytes) : 0);
    }
    if (numBytes == 0) {
	return;
    }
    
    Tcl_DStringInit(&dsPtr);
    numChars = Tcl_NumUtfChars(bytes, numBytes);
    unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr);
    AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
    Tcl_DStringFree(&dsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUtfToUtfRep --
 *
 *	This procedure appends "numBytes" bytes of "bytes" to the UTF string
 *	rep of "objPtr".  objPtr must already have a valid String rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUtfRep(objPtr, bytes, numBytes)
    Tcl_Obj *objPtr;	/* Points to the object to append to. */
    CONST char *bytes;	/* String to append. */
    int numBytes;	/* Number of bytes of "bytes" to append. */
{
    String *stringPtr;
    int newLength, oldLength;

    if (numBytes < 0) {
	numBytes = (bytes ? strlen(bytes) : 0);
    }







|
|












|
|
|



|



|
>
>

















|
|
|












|
|
|











|












|
|












|
|
|







1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUnicodeToUtfRep --
 *
 *	This function converts the contents of "unicode" to UTF and appends
 *	the UTF to the string rep of "objPtr".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUtfRep(objPtr, unicode, numChars)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
    CONST Tcl_UniChar *unicode;	/* String to convert to UTF. */
    int numChars;		/* Number of chars of "unicode" to convert. */
{
    Tcl_DString dsPtr;
    CONST char *bytes;

    if (numChars < 0) {
	numChars = 0;
	if (unicode) {
	    while (unicode[numChars] != 0) {
		numChars++;
	    }
	}
    }
    if (numChars == 0) {
	return;
    }

    Tcl_DStringInit(&dsPtr);
    bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr);
    AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr));
    Tcl_DStringFree(&dsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUtfToUnicodeRep --
 *
 *	This function converts the contents of "bytes" to Unicode and appends
 *	the Unicode to the Unicode rep of "objPtr". objPtr must already have a
 *	valid Unicode rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
    CONST char *bytes;		/* String to convert to Unicode. */
    int numBytes;		/* Number of bytes of "bytes" to convert. */
{
    Tcl_DString dsPtr;
    int numChars;
    Tcl_UniChar *unicode;

    if (numBytes < 0) {
	numBytes = (bytes ? strlen(bytes) : 0);
    }
    if (numBytes == 0) {
	return;
    }

    Tcl_DStringInit(&dsPtr);
    numChars = Tcl_NumUtfChars(bytes, numBytes);
    unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr);
    AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
    Tcl_DStringFree(&dsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AppendUtfToUtfRep --
 *
 *	This function appends "numBytes" bytes of "bytes" to the UTF string
 *	rep of "objPtr". objPtr must already have a valid String rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	objPtr's internal rep is reallocated.
 *
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUtfRep(objPtr, bytes, numBytes)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
    CONST char *bytes;		/* String to append. */
    int numBytes;		/* Number of bytes of "bytes" to append. */
{
    String *stringPtr;
    int newLength, oldLength;

    if (numBytes < 0) {
	numBytes = (bytes ? strlen(bytes) : 0);
    }
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
     */

    oldLength = objPtr->length;
    newLength = numBytes + oldLength;

    stringPtr = GET_STRING(objPtr);
    if (newLength > (int) stringPtr->allocated) {

	/*
	 * There isn't currently enough space in the string representation
	 * so allocate additional space.  First, try to double the length
	 * required.  If that fails, try a more modest allocation.  See the
	 * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
	 * explanation of this growth algorithm.
	 */

	if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) {
	    Tcl_SetObjLength(objPtr,
		    newLength + numBytes + TCL_GROWTH_MIN_ALLOC);
	}
    }

    /*
     * Invalidate the unicode data.
     */
    
    stringPtr->numChars = -1;
    stringPtr->hasUnicode = 0;
    
    memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes,
	    (size_t) numBytes);
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendStringsToObjVA --
 *
 *	This procedure appends one or more null-terminated strings
 *	to an object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of all the string arguments are appended to the
 *	string representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObjVA (objPtr, argList)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */







<

|
|
|
|












|


|











|
|





|
|







1474
1475
1476
1477
1478
1479
1480

1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
     */

    oldLength = objPtr->length;
    newLength = numBytes + oldLength;

    stringPtr = GET_STRING(objPtr);
    if (newLength > (int) stringPtr->allocated) {

	/*
	 * There isn't currently enough space in the string representation so
	 * allocate additional space. First, try to double the length
	 * required. If that fails, try a more modest allocation. See the "TCL
	 * STRING GROWTH ALGORITHM" comment at the top of this file for an
	 * explanation of this growth algorithm.
	 */

	if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) {
	    Tcl_SetObjLength(objPtr,
		    newLength + numBytes + TCL_GROWTH_MIN_ALLOC);
	}
    }

    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = -1;
    stringPtr->hasUnicode = 0;

    memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes,
	    (size_t) numBytes);
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendStringsToObjVA --
 *
 *	This function appends one or more null-terminated strings to an
 *	object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of all the string arguments are appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObjVA (objPtr, argList)
    Tcl_Obj *objPtr;		/* Points to the object to append to. */
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522

1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
















































































































































































































































































































































































































































































































































































































































































































































































































































1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658

1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_AppendStringsToObj called with shared object");
    }

    SetStringFromAny(NULL, objPtr);

    /*
     * Figure out how much space is needed for all the strings, and
     * expand the string representation if it isn't big enough. If no
     * bytes would be appended, just return.  Note that on some platforms
     * (notably OS/390) the argList is an array so we need to use memcpy.
     */

    nargs = 0;
    newLength = 0;
    oldLength = objPtr->length;
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
 	if (nargs >= nargs_space) {
 	    /* 
 	     * Expand the args buffer
 	     */

 	    nargs_space += STATIC_LIST_SIZE;
 	    if (args == static_list) {
 	    	args = (void *)ckalloc(nargs_space * sizeof(char *));
 		for (i = 0; i < nargs; ++i) {
 		    args[i] = static_list[i];
 		}
 	    } else {
 		args = (void *)ckrealloc((void *)args,
			nargs_space * sizeof(char *));
 	    }
 	}
	newLength += strlen(string);
	args[nargs++] = string;
    }
    if (newLength == 0) {
	goto done;
    }

    stringPtr = GET_STRING(objPtr);
    if (oldLength + newLength > (int) stringPtr->allocated) {

	/*
	 * There isn't currently enough space in the string
	 * representation, so allocate additional space.  If the current
	 * string representation isn't empty (i.e. it looks like we're
	 * doing a series of appends) then try to allocate extra space to
	 * accomodate future growth: first try to double the required memory;
	 * if that fails, try a more modest allocation.  See the "TCL STRING
	 * GROWTH ALGORITHM" comment at the top of this file for an explanation
	 * of this growth algorithm.  Otherwise, if the current string
	 * representation is empty, exactly enough memory is allocated.
	 */

	if (oldLength == 0) {
	    Tcl_SetObjLength(objPtr, newLength);
	} else {
	    attemptLength = 2 * (oldLength + newLength);
	    if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
		attemptLength = oldLength + (2 * newLength) +
		    TCL_GROWTH_MIN_ALLOC;
		Tcl_SetObjLength(objPtr, attemptLength);
	    }
	}
    }

    /*
     * Make a second pass through the arguments, appending all the
     * strings to the object.
     */

    dst = objPtr->bytes + oldLength;
    for (i = 0; i < nargs; ++i) {
 	string = args[i];
	if (string == NULL) {
	    break;
	}
	while (*string != 0) {
	    *dst = *string;
	    dst++;
	    string++;
	}
    }

    /*
     * Add a null byte to terminate the string.  However, be careful:
     * it's possible that the object is totally empty (if it was empty
     * originally and there was nothing to append).  In this case dst is
     * NULL; just leave everything alone.
     */

    if (dst != NULL) {
	*dst = 0;
    }
    objPtr->length = oldLength + newLength;

    done:
    /*
     * If we had to allocate a buffer from the heap, 
     * free it now.
     */
 
    if (args != static_list) {
     	ckfree((void *)args);
    }
#undef STATIC_LIST_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendStringsToObj --
 *
 *	This procedure appends one or more null-terminated strings
 *	to an object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of all the string arguments are appended to the
 *	string representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
{
    register Tcl_Obj *objPtr;
    va_list argList;

    objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList);
    Tcl_AppendStringsToObjVA(objPtr, argList);
    va_end(argList);
}

















































































































































































































































































































































































































































































































































































































































































































































































































































/*
 *---------------------------------------------------------------------------
 *
 * FillUnicodeRep --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string
 *	rep.  The object must alread have a "String" internal rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static void
FillUnicodeRep(objPtr)
    Tcl_Obj *objPtr;	/* The object in which to fill the unicode rep. */

{
    String *stringPtr;
    size_t uallocated;
    char *src, *srcEnd;
    Tcl_UniChar *dst;
    src = objPtr->bytes;
    
    stringPtr = GET_STRING(objPtr);
    if (stringPtr->numChars == -1) {
	stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length);
    }
    stringPtr->hasUnicode = (stringPtr->numChars > 0);

    uallocated = STRING_UALLOC(stringPtr->numChars);
    if (uallocated > stringPtr->uallocated) {
    
	/*
	 * If not enough space has been allocated for the unicode rep,
	 * reallocate the internal rep object.
	 */

	/*
	 * There isn't currently enough space in the Unicode
	 * representation so allocate additional space.  If the current
	 * Unicode representation isn't empty (i.e. it looks like we've
	 * done some appends) then overallocate the space so
	 * that we won't have to do as much reallocation in the future.
	 */

	if (stringPtr->uallocated > 0) {
	    uallocated *= 2;
	}
	stringPtr = (String *) ckrealloc((char*) stringPtr,
		STRING_SIZE(uallocated));
	stringPtr->uallocated = uallocated;
    }

    /*
     * Convert src to Unicode and store the coverted data in "unicode".
     */
    
    srcEnd = src + objPtr->length;
    for (dst = stringPtr->unicode; src < srcEnd; dst++) {
	src += TclUtfToUniChar(src, dst);
    }
    *dst = 0;
    
    SET_STRING(objPtr, stringPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * DupStringInternalRep --
 *
 *	Initialize the internal representation of a new Tcl_Obj to a
 *	copy of the internal representation of an existing string object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	copyPtr's internal rep is set to a copy of srcPtr's internal
 *	representation.
 *
 *----------------------------------------------------------------------
 */

static void
DupStringInternalRep(srcPtr, copyPtr)
    register Tcl_Obj *srcPtr;	/* Object with internal rep to copy.  Must
				 * have an internal rep of type "String". */
    register Tcl_Obj *copyPtr;	/* Object with internal rep to set.  Must
				 * not currently have an internal rep.*/
{
    String *srcStringPtr = GET_STRING(srcPtr);
    String *copyStringPtr = NULL;

    /*
     * If the src obj is a string of 1-byte Utf chars, then copy the
     * string rep of the source object and create an "empty" Unicode
     * internal rep for the new object.  Otherwise, copy Unicode
     * internal rep, and invalidate the string rep of the new object.
     */
    
    if (srcStringPtr->hasUnicode == 0) {
    	copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0)));
	copyStringPtr->uallocated = STRING_UALLOC(0);
    } else {
	copyStringPtr = (String *) ckalloc(
	    STRING_SIZE(srcStringPtr->uallocated));
	copyStringPtr->uallocated = srcStringPtr->uallocated;

	memcpy((VOID *) copyStringPtr->unicode,
		(VOID *) srcStringPtr->unicode,
		(size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar));
	copyStringPtr->unicode[srcStringPtr->numChars] = 0;
    }
    copyStringPtr->numChars = srcStringPtr->numChars;
    copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
    copyStringPtr->allocated = srcStringPtr->allocated;

    /*
     * Tricky point: the string value was copied by generic object
     * management code, so it doesn't contain any extra bytes that
     * might exist in the source object.
     */

    copyStringPtr->allocated = copyPtr->length;

    SET_STRING(copyPtr, copyStringPtr);
    copyPtr->typePtr = &tclStringType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetStringFromAny --
 *
 *	Create an internal representation of type "String" for an object.
 *
 * Results:
 *	This operation always succeeds and returns TCL_OK.
 *
 * Side effects:
 *	Any old internal reputation for objPtr is freed and the
 *	internal representation is set to "String".
 *
 *----------------------------------------------------------------------
 */

static int
SetStringFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    /*
     * The Unicode object is optimized for the case where each UTF char
     * in a string is only one byte.  In this case, we store the value of
     * numChars, but we don't copy the bytes to the unicodeObj->unicode.
     */

    if (objPtr->typePtr != &tclStringType) {
	String *stringPtr;

	if (objPtr->typePtr != NULL) {
	    if (objPtr->bytes == NULL) {







|
|
|
|










|
|
|
|
>
|
|
|
|
|
|
|
|

|
|









<

|
|
|
|
|
|
|
|
|








|






|
|




|











|
|
|
|







|

|
<

|

|









|
|





|
|





|

<


|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







|












|
>






|








<



<
|
<
|
|
|
|
|













|





|








|
|













|
|
|
|





|
|
|
|

|

|



|












|
|
|



















|
|










|
|
|







1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585

1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642

1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671

1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530

2531
2532
2533

2534

2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("Tcl_AppendStringsToObj called with shared object");
    }

    SetStringFromAny(NULL, objPtr);

    /*
     * Figure out how much space is needed for all the strings, and expand the
     * string representation if it isn't big enough. If no bytes would be
     * appended, just return. Note that on some platforms (notably OS/390) the
     * argList is an array so we need to use memcpy.
     */

    nargs = 0;
    newLength = 0;
    oldLength = objPtr->length;
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	if (nargs >= nargs_space) {
	    /*
	     * Expand the args buffer.
	     */

	    nargs_space += STATIC_LIST_SIZE;
	    if (args == static_list) {
		args = (void *) ckalloc(nargs_space * sizeof(char *));
		for (i = 0; i < nargs; ++i) {
		    args[i] = static_list[i];
		}
	    } else {
		args = (void *) ckrealloc((void *) args,
			nargs_space * sizeof(char *));
	    }
	}
	newLength += strlen(string);
	args[nargs++] = string;
    }
    if (newLength == 0) {
	goto done;
    }

    stringPtr = GET_STRING(objPtr);
    if (oldLength + newLength > (int) stringPtr->allocated) {

	/*
	 * There isn't currently enough space in the string representation, so
	 * allocate additional space. If the current string representation
	 * isn't empty (i.e. it looks like we're doing a series of appends)
	 * then try to allocate extra space to accomodate future growth: first
	 * try to double the required memory; if that fails, try a more modest
	 * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the
	 * top of this file for an explanation of this growth algorithm.
	 * Otherwise, if the current string representation is empty, exactly
	 * enough memory is allocated.
	 */

	if (oldLength == 0) {
	    Tcl_SetObjLength(objPtr, newLength);
	} else {
	    attemptLength = 2 * (oldLength + newLength);
	    if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
		attemptLength = oldLength + (2 * newLength) +
			TCL_GROWTH_MIN_ALLOC;
		Tcl_SetObjLength(objPtr, attemptLength);
	    }
	}
    }

    /*
     * Make a second pass through the arguments, appending all the strings to
     * the object.
     */

    dst = objPtr->bytes + oldLength;
    for (i = 0; i < nargs; ++i) {
	string = args[i];
	if (string == NULL) {
	    break;
	}
	while (*string != 0) {
	    *dst = *string;
	    dst++;
	    string++;
	}
    }

    /*
     * Add a null byte to terminate the string. However, be careful: it's
     * possible that the object is totally empty (if it was empty originally
     * and there was nothing to append). In this case dst is NULL; just leave
     * everything alone.
     */

    if (dst != NULL) {
	*dst = 0;
    }
    objPtr->length = oldLength + newLength;

  done:
    /*
     * If we had to allocate a buffer from the heap, free it now.

     */

    if (args != static_list) {
	ckfree((void *)args);
    }
#undef STATIC_LIST_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendStringsToObj --
 *
 *	This function appends one or more null-terminated strings to an
 *	object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of all the string arguments are appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
{

    va_list argList;

    va_start(argList, objPtr);
    Tcl_AppendStringsToObjVA(objPtr, argList);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * TclAppendFormattedObjs --
 *
 *	This function appends a list of Tcl_Obj's to a Tcl_Obj according
 *	to the formatting instructions embedded in the format string.  The
 *	formatting instructions are inspired by sprintf().  Returns TCL_OK
 *	when successful.  If there's an error in the arguments, TCL_ERROR is
 *	returned, and an error message is written to the interp, if non-NULL.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
    Tcl_Interp *interp;
    Tcl_Obj *appendObj;
    CONST char *format;
    int objc;
    Tcl_Obj *CONST objv[];
{
    CONST char *span = format;
    int numBytes = 0;
    int objIndex = 0;
    int gotXpg = 0, gotSequential = 0;
    int originalLength;
    CONST char *msg;
    CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers";
    CONST char *badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };

    if (Tcl_IsShared(appendObj)) {
	Tcl_Panic("TclAppendFormattedObjs called with shared object");
    }
    Tcl_GetStringFromObj(appendObj, &originalLength);

    /* format string is NUL-terminated */
    while (*format != '\0') {
	char *end;
	int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
	int width, gotPrecision, precision, useShort, useWide, useBig;
	int newXpg, numChars, allocSegment = 0;
	Tcl_Obj *segment;
	Tcl_UniChar ch;
	int step = Tcl_UtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;
	    continue;
	}
	if (numBytes) {
	    Tcl_AppendToObj(appendObj, span, numBytes);
	    numBytes = 0;
	}

	/* Saw a % : process the format specifier */
	/* 0. %% : Escape format handling */

	step = Tcl_UtfToUniChar(format, &ch);
	if (ch == '%') {
	    span = format;
	    numBytes = step;
	    format += step;
	    continue;
	}

	/* 1. XPG3 position specifier */

	newXpg = 0;
	if (isdigit(UCHAR(ch))) {
	    int position = strtoul(format, &end, 10);
	    if (*end == '$') {
		newXpg = 1;
		objIndex = position - 1;
		format = end + 1;
		step = Tcl_UtfToUniChar(format, &ch);
	    }
	}
	if (newXpg) {
	    if (gotSequential) {
		msg = mixedXPG;
		goto errorMsg;
	    }
	    gotXpg = 1;
	} else {
	    if (gotXpg) {
		msg = mixedXPG;
		goto errorMsg;
	    }
	    gotSequential = 1;
	}
	if ((objIndex < 0) || (objIndex >= objc)) {
	    msg = badIndex[gotXpg];
	    goto errorMsg;
	}

	/* 2. Set of flags */

	gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0;
	sawFlag = 1;
	do {
	    switch (ch) {
	    case '-':
		gotMinus = 1;
		break;
	    case '#':
		gotHash = 1;
		break;
	    case '0':
		gotZero = 1;
		break;
	    case ' ':
		gotSpace = 1;
		break;
	    case '+':
		gotPlus = 1;
		break;
	    default:
		sawFlag = 0;
	    }
	    if (sawFlag) {
		format += step;
		step = Tcl_UtfToUniChar(format, &ch);
	    }
	} while (sawFlag);

	/* 3. Minimum field width */

	width = 0;
	if (isdigit(UCHAR(ch))) {
	    width = strtoul(format, &end, 10);
	    format = end;
	    step = Tcl_UtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		goto errorMsg;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
		goto error;
	    }
	    if (width < 0) {
		width = -width;
		gotMinus = 1;
	    }
	    objIndex++;
	    format += step;
	    step = Tcl_UtfToUniChar(format, &ch);
	}

	/* 4. Precision */

	gotPrecision = precision = 0;
	if (ch == '.') {
	    gotPrecision = 1;
	    format += step;
	    step = Tcl_UtfToUniChar(format, &ch);
	}
	if (isdigit(UCHAR(ch))) {
	    precision = strtoul(format, &end, 10);
	    format = end;
	    step = Tcl_UtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		goto errorMsg;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[objIndex], &precision)
		    != TCL_OK) {
		goto error;
	    }
	    /* TODO: Check this truncation logic */
	    if (precision < 0) {
		precision = 0;
	    }
	    objIndex++;
	    format += step;
	    step = Tcl_UtfToUniChar(format, &ch);
	}

	/* 5. Length modifier */

	useShort = useWide = useBig = 0;
	if (ch == 'h') {
	    useShort = 1;
	    format += step;
	    step = Tcl_UtfToUniChar(format, &ch);
	} else if (ch == 'l') {
	    format += step;
	    step = Tcl_UtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = 1;
		format += step;
		step = Tcl_UtfToUniChar(format, &ch);
	    } else {
#ifndef TCL_WIDE_INT_IS_LONG
	    useWide = 1;
#endif
	    }
	}

	format += step;
	span = format;

	/* 6. Conversion character */
	segment = objv[objIndex];
	if (ch == 'i') {
	    ch = 'd';
	}
	switch (ch) {
	case '\0':
	    msg = "format string ended in middle of field specifier";
	    goto errorMsg;
	case 's': {
	    numChars = Tcl_GetCharLength(segment);
	    if (gotPrecision && (precision < numChars)) {
		segment = Tcl_GetRange(segment, 0, precision - 1);
		Tcl_IncrRefCount(segment);
		allocSegment = 1;
	    }
	    break;
	}
	case 'c': {
	    char buf[TCL_UTF_MAX];
	    int code, length;
	    if (Tcl_GetIntFromObj(interp, segment, &code) != TCL_OK) {
		goto error;
	    }
	    length = Tcl_UniCharToUtf(code, buf);
	    segment = Tcl_NewStringObj(buf, length);
	    Tcl_IncrRefCount(segment);
	    allocSegment = 1;
	    break;
	}
	
	case 'u':
	    if (useBig) {
		msg = "unsigned bignum format is invalid";
		goto errorMsg;
	    }
	case 'd':
	case 'o':
	case 'x':
	case 'X': {
	    short int s;
	    long l;
	    Tcl_WideInt w;
	    mp_int big;
	    int isNegative = 0;

	    if (useBig) {
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		isNegative = (mp_cmp_d(&big, 0) == MP_LT);
	    } else if (useWide) {
		if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
		    Tcl_Obj *objPtr;
		    if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
			goto error;
		    }
		    mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
		    objPtr = Tcl_NewBignumObj(&big);
		    Tcl_IncrRefCount(objPtr);
		    Tcl_GetWideIntFromObj(NULL, objPtr, &w);
		    Tcl_DecrRefCount(objPtr);
		}
		isNegative = (w < (Tcl_WideInt)0);
	    } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) {
		if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
		    Tcl_Obj *objPtr;
		    if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
			goto error;
		    }
		    mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
		    objPtr = Tcl_NewBignumObj(&big);
		    Tcl_IncrRefCount(objPtr);
		    Tcl_GetLongFromObj(NULL, objPtr, &l);
		    Tcl_DecrRefCount(objPtr);
		} else {
		    l = Tcl_WideAsLong(w);
		}
		if (useShort) {
		    s = (short int) l;
		    isNegative = (s < (short int)0);
		} else {
		    isNegative = (l < (long)0);
		}
	    } else {
		if (useShort) {
		    s = (short int) l;
		    isNegative = (s < (short int)0);
		} else {
		    isNegative = (l < (long)0);
		}
	    }

	    segment = Tcl_NewObj();
	    allocSegment = 1;
	    Tcl_IncrRefCount(segment);

	    if (isNegative || gotPlus) {
		if (useBig || (ch == 'd')) {
		    if (isNegative) {
			Tcl_AppendToObj(segment, "-", 1);
		    } else {
			Tcl_AppendToObj(segment, "+", 1);
		    }
		}
	    }

	    if (gotHash) {
		switch (ch) {
		case 'o':
		    Tcl_AppendToObj(segment, "0", 1);
		    precision--;
		    break;
		case 'x':
		case 'X':
		    Tcl_AppendToObj(segment, "0x", 2);
		    break;
		}
	    }

	    switch (ch) {
	    case 'd': {
		int length;
		Tcl_Obj *pure;
		CONST char *bytes;

		if (useShort) {
		    pure = Tcl_NewIntObj((int)(s));
		} else if (useWide) {
		    pure = Tcl_NewWideIntObj(w);
		} else if (useBig) {
		    pure = Tcl_NewBignumObj(&big);
		} else {
		    pure = Tcl_NewLongObj(l);
		}
		Tcl_IncrRefCount(pure);
		bytes = Tcl_GetStringFromObj(pure, &length);
		/* Already did the sign above */
		if (*bytes == '-') {
		    length--; bytes++;
		}
		/* Canonical decimal string reps for integers are composed
		 * entirely of one-byte encoded characters, so "length" is
		 * the number of chars */
		if (gotPrecision) {
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    while (length < width) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		}
		Tcl_AppendToObj(segment, bytes, -1);
		Tcl_DecrRefCount(pure);
		break;
	    }
		
	    case 'u':
	    case 'o':
	    case 'x':
	    case 'X': {
		Tcl_WideUInt bits = (Tcl_WideUInt)0;
		int length, numBits = 4, numDigits = 0, base = 16;
		int index = 0, shift = 0;
		Tcl_Obj *pure;
		char *bytes;

		if (ch == 'u') {
		    base = 10;
		}
		if (ch == 'o') {
		    base = 8;
		    numBits = 3;
		}
		if (useShort) {
		    unsigned short int us = (unsigned short int) s;
		    bits = (Tcl_WideUInt) us;
		    while (us) {
			numDigits++;
			us /= base;
		    }
		} else if (useWide) {
		    Tcl_WideUInt uw = (Tcl_WideUInt) w;
		    bits = uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }
		} else if (useBig) {
		    int leftover = (big.used * DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
		    numDigits = 1 + ((big.used * DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
			numDigits--;
			mask >>= numBits;
		    }
		} else {
		    unsigned long int ul = (unsigned long int) l;
		    bits = (Tcl_WideUInt) ul;
		    while (ul) {
			numDigits++;
			ul /= base;
		    }
		}
		/* Need to be sure zero becomes "0", not "" */
		if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
		    numDigits = 1;
		}
		pure = Tcl_NewObj();
		Tcl_SetObjLength(pure, numDigits);
		bytes = Tcl_GetString(pure);
		length = numDigits;
		while (numDigits--) {
		    int digitOffset;
		    if (useBig) {
			if (shift<CHAR_BIT*sizeof(Tcl_WideUInt)-DIGIT_BIT) {
			    bits |= (((Tcl_WideUInt)big.dp[index++]) << shift);
			    shift += DIGIT_BIT;
			}
			shift -= numBits;
		    }
		    digitOffset = (int) (bits % base);
		    if (digitOffset > 9) {
			bytes[numDigits] = 'a' + digitOffset - 10;
		    } else {
			bytes[numDigits] = '0' + digitOffset;
		    }
		    bits /= base;
		}
		if (gotPrecision) {
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    while (length < width) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		}
		Tcl_AppendObjToObj(segment, pure);
		Tcl_DecrRefCount(pure);
		break;
	    }

	    }
	    break;
	}

	case 'e':
	case 'E':
	case 'f':
	case 'g':
	case 'G': {
#define MAX_FLOAT_SIZE 320
	    char spec[2*TCL_INTEGER_SPACE + 9], *p = spec;
	    double d;
	    int length = MAX_FLOAT_SIZE;
	    char *bytes;

	    if (Tcl_GetDoubleFromObj(interp, segment, &d) != TCL_OK) {
		goto error;
	    }
	    *p++ = '%';
	    if (gotMinus) {
		*p++ = '-';
	    }
	    if (gotHash) {
		*p++ = '#';
	    }
	    if (gotZero) {
		*p++ = '0';
	    }
	    if (gotSpace) {
		*p++ = ' ';
	    }
	    if (gotPlus) {
		*p++ = '+';
	    }
	    if (width) {
		p += sprintf(p, "%d", width);
	    }
	    if (gotPrecision) {
		*p++ = '.';
		p += sprintf(p, "%d", precision);
		length += precision;
	    }
	    /* Don't pass length modifiers ! */
	    *p++ = (char) ch;
	    *p = '\0';

	    segment = Tcl_NewObj();
	    allocSegment = 1;
	    Tcl_SetObjLength(segment, length);
	    bytes = Tcl_GetString(segment);
	    Tcl_SetObjLength(segment, sprintf(bytes, spec, d));
	    break;
	}
	default: {
	    char buf[40];
	    sprintf(buf, "bad field specifier \"%c\"", ch);
	    msg = buf;
	    goto errorMsg;
	}
	}

	switch (ch) {
	case 'E':
	case 'G':
	case 'X': {
	    Tcl_SetObjLength(segment, Tcl_UtfToUpper(Tcl_GetString(segment)));
	}
	}

	numChars = Tcl_GetCharLength(segment);
	if (!gotMinus) {
	    while (numChars < width) {
		Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
		numChars++;
	    }
	}
	Tcl_AppendObjToObj(appendObj, segment);
	if (allocSegment) {
	    Tcl_DecrRefCount(segment);
	}
	while (numChars < width) {
	    Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
	    numChars++;
	}

	objIndex += gotSequential;
    }
    if (numBytes) {
	Tcl_AppendToObj(appendObj, span, numBytes);
	numBytes = 0;
    }

    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
    }
  error:
    Tcl_SetObjLength(appendObj, originalLength);
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * FormatObjVA --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string
 *	rep. The object must alread have a "String" internal rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static int
FormatObjVA(Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    CONST char *format,
    va_list argList)
{
    int code, objc;
    Tcl_Obj **objv, *element, *list = Tcl_NewObj();

    Tcl_IncrRefCount(list);
    element = va_arg(argList, Tcl_Obj *);
    while (element != NULL) {
	Tcl_ListObjAppendElement(NULL, list, element);
	element = va_arg(argList, Tcl_Obj *);
    }
    Tcl_ListObjGetElements(NULL, list, &objc, &objv);
    code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFormatObj --
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...)
{
    va_list argList;
    int result;

    va_start(argList, format);
    result = FormatObjVA(interp, objPtr, format, argList);
    va_end(argList);
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * ObjPrintfVA --
 *
 * Results:
 *
 * Side effects:
 *
 *---------------------------------------------------------------------------
 */

static int
ObjPrintfVA(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    CONST char *format,
    va_list argList)
{
    int code, objc;
    Tcl_Obj **objv, *list = Tcl_NewObj();
    CONST char *p;
    char *end;

    p = format;
    Tcl_IncrRefCount(list);
    while (*p != '\0') {
	int size = 0, seekingConversion = 1, gotPrecision = 0;
	int lastNum = -1, numBytes = -1;

	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {

	    case '\0':
		seekingConversion = 0;
		break;
	    case 's': {
		char *bytes = va_arg(argList, char *);
		seekingConversion = 0;
		if (gotPrecision) {
		    char *end = bytes + lastNum;
		    char *q = bytes;
		    while ((q < end) && (*q != '\0')) {
			q++;
		    }
		    numBytes = (int)(q - bytes);
		}
		Tcl_ListObjAppendElement(NULL, list,
			Tcl_NewStringObj(bytes , numBytes));
		/* We took no more than numBytes bytes from the (char *).
		 * In turn, [format] will take no more than numBytes
		 * characters from the Tcl_Obj.  Since numBytes characters
		 * must be no less than numBytes bytes, the character limit
		 * will have no effect and we can just pass it through.
		 */
		break;
	    }
	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
		seekingConversion = 0;
		switch (size) {
		case -1:
		case 0:
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
			    (long int)va_arg(argList, int)));
		    break;
		case 1:
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
			    va_arg(argList, long int)));
		    break;
		}
		break;
	    case 'e':
	    case 'E':
	    case 'f':
	    case 'g':
	    case 'G':
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			va_arg(argList, double)));
		seekingConversion = 0;
		break;
	    case '*':
		lastNum = (int)va_arg(argList, int);
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
		p++;
		break;
	    case '0': case '1': case '2': case '3': case '4':
	    case '5': case '6': case '7': case '8': case '9':
		lastNum = (int) strtoul(p, &end, 10);
		p = end;
		break;
	    case '.':
		gotPrecision = 1;
		p++;
		break;
	    /* TODO: support for wide (and bignum?) arguments */
	    case 'l':
		size = 1;
		p++;
		break;
	    case 'h':
		size = -1;
	    default:
		p++;
	    }
	} while (seekingConversion);
    }
    Tcl_ListObjGetElements(NULL, list, &objc, &objv);
    code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclObjPrintf --
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 * 	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...)
{
    va_list argList;
    int result;

    va_start(argList, format);
    result = ObjPrintfVA(interp, objPtr, format, argList);
    va_end(argList);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatToErrorInfo --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int
TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...)
{
    int code;
    va_list argList;
    Tcl_Obj *objPtr = Tcl_NewObj();

    va_start(argList, format);
    code = ObjPrintfVA(interp, objPtr, format, argList);
    va_end(argList);
    if (code != TCL_OK) {
        return code;
    }
    TclAppendObjToErrorInfo(interp, objPtr);
    Tcl_DecrRefCount(objPtr);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * FillUnicodeRep --
 *
 *	Populate the Unicode internal rep with the Unicode form of its string
 *	rep. The object must alread have a "String" internal rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Reallocates the String internal rep.
 *
 *---------------------------------------------------------------------------
 */

static void
FillUnicodeRep(objPtr)
    Tcl_Obj *objPtr;		/* The object in which to fill the unicode
				 * rep. */
{
    String *stringPtr;
    size_t uallocated;
    char *src, *srcEnd;
    Tcl_UniChar *dst;
    src = objPtr->bytes;

    stringPtr = GET_STRING(objPtr);
    if (stringPtr->numChars == -1) {
	stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length);
    }
    stringPtr->hasUnicode = (stringPtr->numChars > 0);

    uallocated = STRING_UALLOC(stringPtr->numChars);
    if (uallocated > stringPtr->uallocated) {

	/*
	 * If not enough space has been allocated for the unicode rep,
	 * reallocate the internal rep object.

	 *

	 * There isn't currently enough space in the Unicode representation so
	 * allocate additional space. If the current Unicode representation
	 * isn't empty (i.e. it looks like we've done some appends) then
	 * overallocate the space so that we won't have to do as much
	 * reallocation in the future.
	 */

	if (stringPtr->uallocated > 0) {
	    uallocated *= 2;
	}
	stringPtr = (String *) ckrealloc((char*) stringPtr,
		STRING_SIZE(uallocated));
	stringPtr->uallocated = uallocated;
    }

    /*
     * Convert src to Unicode and store the coverted data in "unicode".
     */

    srcEnd = src + objPtr->length;
    for (dst = stringPtr->unicode; src < srcEnd; dst++) {
	src += TclUtfToUniChar(src, dst);
    }
    *dst = 0;

    SET_STRING(objPtr, stringPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * DupStringInternalRep --
 *
 *	Initialize the internal representation of a new Tcl_Obj to a copy of
 *	the internal representation of an existing string object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	copyPtr's internal rep is set to a copy of srcPtr's internal
 *	representation.
 *
 *----------------------------------------------------------------------
 */

static void
DupStringInternalRep(srcPtr, copyPtr)
    register Tcl_Obj *srcPtr;	/* Object with internal rep to copy. Must have
				 * an internal rep of type "String". */
    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. Must not
				 * currently have an internal rep.*/
{
    String *srcStringPtr = GET_STRING(srcPtr);
    String *copyStringPtr = NULL;

    /*
     * If the src obj is a string of 1-byte Utf chars, then copy the string
     * rep of the source object and create an "empty" Unicode internal rep for
     * the new object. Otherwise, copy Unicode internal rep, and invalidate
     * the string rep of the new object.
     */

    if (srcStringPtr->hasUnicode == 0) {
	copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0)));
	copyStringPtr->uallocated = STRING_UALLOC(0);
    } else {
	copyStringPtr = (String *) ckalloc(
		STRING_SIZE(srcStringPtr->uallocated));
	copyStringPtr->uallocated = srcStringPtr->uallocated;

	memcpy((VOID *) copyStringPtr->unicode,
		(VOID *) srcStringPtr->unicode,
		(size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar));
	copyStringPtr->unicode[srcStringPtr->numChars] = 0;
    }
    copyStringPtr->numChars = srcStringPtr->numChars;
    copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
    copyStringPtr->allocated = srcStringPtr->allocated;

    /*
     * Tricky point: the string value was copied by generic object management
     * code, so it doesn't contain any extra bytes that might exist in the
     * source object.
     */

    copyStringPtr->allocated = copyPtr->length;

    SET_STRING(copyPtr, copyStringPtr);
    copyPtr->typePtr = &tclStringType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetStringFromAny --
 *
 *	Create an internal representation of type "String" for an object.
 *
 * Results:
 *	This operation always succeeds and returns TCL_OK.
 *
 * Side effects:
 *	Any old internal reputation for objPtr is freed and the internal
 *	representation is set to "String".
 *
 *----------------------------------------------------------------------
 */

static int
SetStringFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    /*
     * The Unicode object is optimized for the case where each UTF char in a
     * string is only one byte. In this case, we store the value of numChars,
     * but we don't copy the bytes to the unicodeObj->unicode.
     */

    if (objPtr->typePtr != &tclStringType) {
	String *stringPtr;

	if (objPtr->typePtr != NULL) {
	    if (objPtr->bytes == NULL) {
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922









	stringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0)));
	stringPtr->numChars = -1;
	stringPtr->uallocated = STRING_UALLOC(0);
	stringPtr->hasUnicode = 0;

	if (objPtr->bytes != NULL) {
	    stringPtr->allocated = objPtr->length;	    
 	    objPtr->bytes[objPtr->length] = 0;
	} else {
	    objPtr->length = 0;
	}
	SET_STRING(objPtr, stringPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfString --
 *
 *	Update the string representation for an object whose internal
 *	representation is "String".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string may be set by converting its Unicode
 *	represention to UTF format.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfString(objPtr)
    Tcl_Obj *objPtr;		/* Object with string rep to update. */
{
    int i, size;
    Tcl_UniChar *unicode;
    char dummy[TCL_UTF_MAX];
    char *dst;
    String *stringPtr;

    stringPtr = GET_STRING(objPtr);
    if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) {

	if (stringPtr->numChars <= 0) {

	    /*
	     * If there is no Unicode rep, or the string has 0 chars,
	     * then set the string rep to an empty string.
	     */

	    objPtr->bytes = tclEmptyStringRep;
	    objPtr->length = 0;
	    return;
	}

	unicode = stringPtr->unicode;

	/*
	 * Translate the Unicode string to UTF.  "size" will hold the
	 * amount of space the UTF string needs.
	 */

	size = 0;
	for (i = 0; i < stringPtr->numChars; i++) {
	    size += Tcl_UniCharToUtf((int) unicode[i], dummy);
	}
	
	dst = (char *) ckalloc((unsigned) (size + 1));
	objPtr->bytes = dst;
	objPtr->length = size;
	stringPtr->allocated = size;

	for (i = 0; i < stringPtr->numChars; i++) {
	    dst += Tcl_UniCharToUtf(unicode[i], dst);
	}
	*dst = '\0';
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeStringInternalRep --
 *
 *	Deallocate the storage associated with a String data object's
 *	internal representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory. 
 *
 *----------------------------------------------------------------------
 */

static void
FreeStringInternalRep(objPtr)
    Tcl_Obj *objPtr;		/* Object with internal rep to free. */
{
    ckfree((char *) GET_STRING(objPtr));
}















|
|




















|
|
















<

<

|
|










|
|






|


















|
|





|










>
>
>
>
>
>
>
>
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715

2716

2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782

	stringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0)));
	stringPtr->numChars = -1;
	stringPtr->uallocated = STRING_UALLOC(0);
	stringPtr->hasUnicode = 0;

	if (objPtr->bytes != NULL) {
	    stringPtr->allocated = objPtr->length;
	    objPtr->bytes[objPtr->length] = 0;
	} else {
	    objPtr->length = 0;
	}
	SET_STRING(objPtr, stringPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfString --
 *
 *	Update the string representation for an object whose internal
 *	representation is "String".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string may be set by converting its Unicode represention
 *	to UTF format.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfString(objPtr)
    Tcl_Obj *objPtr;		/* Object with string rep to update. */
{
    int i, size;
    Tcl_UniChar *unicode;
    char dummy[TCL_UTF_MAX];
    char *dst;
    String *stringPtr;

    stringPtr = GET_STRING(objPtr);
    if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) {

	if (stringPtr->numChars <= 0) {

	    /*
	     * If there is no Unicode rep, or the string has 0 chars, then set
	     * the string rep to an empty string.
	     */

	    objPtr->bytes = tclEmptyStringRep;
	    objPtr->length = 0;
	    return;
	}

	unicode = stringPtr->unicode;

	/*
	 * Translate the Unicode string to UTF. "size" will hold the amount of
	 * space the UTF string needs.
	 */

	size = 0;
	for (i = 0; i < stringPtr->numChars; i++) {
	    size += Tcl_UniCharToUtf((int) unicode[i], dummy);
	}

	dst = (char *) ckalloc((unsigned) (size + 1));
	objPtr->bytes = dst;
	objPtr->length = size;
	stringPtr->allocated = size;

	for (i = 0; i < stringPtr->numChars; i++) {
	    dst += Tcl_UniCharToUtf(unicode[i], dst);
	}
	*dst = '\0';
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeStringInternalRep --
 *
 *	Deallocate the storage associated with a String data object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory.
 *
 *----------------------------------------------------------------------
 */

static void
FreeStringInternalRep(objPtr)
    Tcl_Obj *objPtr;		/* Object with internal rep to free. */
{
    ckfree((char *) GET_STRING(objPtr));
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclStubInit.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.109 2004/12/01 23:18:53 dgp Exp $
 */

#include "tclInt.h"

/*
 * Remove macros that will interfere with the definitions below.
 */










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.17 2005/09/20 14:11:52 dgp Exp $
 */

#include "tclInt.h"

/*
 * Remove macros that will interfere with the definitions below.
 */
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
    NULL, /* 17 */
    NULL, /* 18 */
    NULL, /* 19 */
    NULL, /* 20 */
    NULL, /* 21 */
    TclFindElement, /* 22 */
    TclFindProc, /* 23 */
    TclFormatInt, /* 24 */
    TclFreePackageInfo, /* 25 */
    NULL, /* 26 */
    NULL, /* 27 */
    TclpGetDefaultStdChannel, /* 28 */
    NULL, /* 29 */
    NULL, /* 30 */
    TclGetExtension, /* 31 */







|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
    NULL, /* 17 */
    NULL, /* 18 */
    NULL, /* 19 */
    NULL, /* 20 */
    NULL, /* 21 */
    TclFindElement, /* 22 */
    TclFindProc, /* 23 */
    NULL, /* 24 */
    TclFreePackageInfo, /* 25 */
    NULL, /* 26 */
    NULL, /* 27 */
    TclpGetDefaultStdChannel, /* 28 */
    NULL, /* 29 */
    NULL, /* 30 */
    TclGetExtension, /* 31 */
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
    TclpGetUserHome, /* 42 */
    NULL, /* 43 */
    TclGuessPackageName, /* 44 */
    TclHideUnsafeCommands, /* 45 */
    TclInExit, /* 46 */
    NULL, /* 47 */
    NULL, /* 48 */
    TclIncrVar2, /* 49 */
    TclInitCompiledLocals, /* 50 */
    TclInterpInit, /* 51 */
    NULL, /* 52 */
    TclInvokeObjectCommand, /* 53 */
    TclInvokeStringCommand, /* 54 */
    TclIsProc, /* 55 */
    NULL, /* 56 */







|







124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
    TclpGetUserHome, /* 42 */
    NULL, /* 43 */
    TclGuessPackageName, /* 44 */
    TclHideUnsafeCommands, /* 45 */
    TclInExit, /* 46 */
    NULL, /* 47 */
    NULL, /* 48 */
    NULL, /* 49 */
    TclInitCompiledLocals, /* 50 */
    TclInterpInit, /* 51 */
    NULL, /* 52 */
    TclInvokeObjectCommand, /* 53 */
    TclInvokeStringCommand, /* 54 */
    TclIsProc, /* 55 */
    NULL, /* 56 */
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
    TclpGetDate, /* 133 */
    NULL, /* 134 */
    NULL, /* 135 */
    NULL, /* 136 */
    NULL, /* 137 */
    TclGetEnv, /* 138 */
    NULL, /* 139 */
    TclLooksLikeInt, /* 140 */
    TclpGetCwd, /* 141 */
    TclSetByteCodeFromAny, /* 142 */
    TclAddLiteralObj, /* 143 */
    TclHideLiteral, /* 144 */
    TclGetAuxDataType, /* 145 */
    TclHandleCreate, /* 146 */
    TclHandleFree, /* 147 */







|







220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
    TclpGetDate, /* 133 */
    NULL, /* 134 */
    NULL, /* 135 */
    NULL, /* 136 */
    NULL, /* 137 */
    TclGetEnv, /* 138 */
    NULL, /* 139 */
    NULL, /* 140 */
    TclpGetCwd, /* 141 */
    TclSetByteCodeFromAny, /* 142 */
    TclAddLiteralObj, /* 143 */
    TclHideLiteral, /* 144 */
    TclGetAuxDataType, /* 145 */
    TclHandleCreate, /* 146 */
    TclHandleFree, /* 147 */
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301











302
303
304
305
306
307
308
    TclSetStartupScriptPath, /* 167 */
    TclGetStartupScriptPath, /* 168 */
    TclpUtfNcmp2, /* 169 */
    TclCheckInterpTraces, /* 170 */
    TclCheckExecutionTraces, /* 171 */
    TclInThreadExit, /* 172 */
    TclUniCharMatch, /* 173 */
    TclIncrWideVar2, /* 174 */
    TclCallVarTraces, /* 175 */
    TclCleanupVar, /* 176 */
    TclVarErrMsg, /* 177 */
    Tcl_SetStartupScript, /* 178 */
    Tcl_GetStartupScript, /* 179 */
    TclNewListObjDirect, /* 180 */
    TclDbNewListObjDirect, /* 181 */
    TclpLocaltime, /* 182 */
    TclpGmtime, /* 183 */
    TclThreadStorageLockInit, /* 184 */
    TclThreadStorageLock, /* 185 */
    TclThreadStorageUnlock, /* 186 */
    TclThreadStoragePrint, /* 187 */
    TclThreadStorageGetHashTable, /* 188 */
    TclThreadStorageInit, /* 189 */
    TclThreadStorageDataKeyInit, /* 190 */
    TclThreadStorageDataKeyGet, /* 191 */
    TclThreadStorageDataKeySet, /* 192 */
    TclFinalizeThreadStorageThread, /* 193 */
    TclFinalizeThreadStorage, /* 194 */
    TclFinalizeThreadStorageData, /* 195 */
    TclFinalizeThreadStorageDataKey, /* 196 */
    TclCompEvalObj, /* 197 */
    TclObjGetFrame, /* 198 */
    TclMatchIsTrivial, /* 199 */
    TclpObjRemoveDirectory, /* 200 */
    TclpObjCopyDirectory, /* 201 */
    TclpObjCreateDirectory, /* 202 */
    TclpObjDeleteFile, /* 203 */
    TclpObjCopyFile, /* 204 */
    TclpObjRenameFile, /* 205 */
    TclpObjStat, /* 206 */
    TclpObjAccess, /* 207 */
    TclpOpenFileChannel, /* 208 */
    TclGetEncodingSearchPath, /* 209 */
    TclSetEncodingSearchPath, /* 210 */
    TclpGetEncodingNameFromEnvironment, /* 211 */
    TclpFindExecutable, /* 212 */
    TclGetObjNameOfExecutable, /* 213 */
    TclSetObjNameOfExecutable, /* 214 */











};

TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    NULL,
#if !defined(__WIN32__) /* UNIX */
    TclGetAndDetachPids, /* 0 */







|





|
|


|
|
|
|
|
|
|
|
|
|
|
|
|


|















>
>
>
>
>
>
>
>
>
>
>







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
    TclSetStartupScriptPath, /* 167 */
    TclGetStartupScriptPath, /* 168 */
    TclpUtfNcmp2, /* 169 */
    TclCheckInterpTraces, /* 170 */
    TclCheckExecutionTraces, /* 171 */
    TclInThreadExit, /* 172 */
    TclUniCharMatch, /* 173 */
    NULL, /* 174 */
    TclCallVarTraces, /* 175 */
    TclCleanupVar, /* 176 */
    TclVarErrMsg, /* 177 */
    Tcl_SetStartupScript, /* 178 */
    Tcl_GetStartupScript, /* 179 */
    NULL, /* 180 */
    NULL, /* 181 */
    TclpLocaltime, /* 182 */
    TclpGmtime, /* 183 */
    NULL, /* 184 */
    NULL, /* 185 */
    NULL, /* 186 */
    NULL, /* 187 */
    NULL, /* 188 */
    NULL, /* 189 */
    NULL, /* 190 */
    NULL, /* 191 */
    NULL, /* 192 */
    NULL, /* 193 */
    NULL, /* 194 */
    NULL, /* 195 */
    NULL, /* 196 */
    TclCompEvalObj, /* 197 */
    TclObjGetFrame, /* 198 */
    NULL, /* 199 */
    TclpObjRemoveDirectory, /* 200 */
    TclpObjCopyDirectory, /* 201 */
    TclpObjCreateDirectory, /* 202 */
    TclpObjDeleteFile, /* 203 */
    TclpObjCopyFile, /* 204 */
    TclpObjRenameFile, /* 205 */
    TclpObjStat, /* 206 */
    TclpObjAccess, /* 207 */
    TclpOpenFileChannel, /* 208 */
    TclGetEncodingSearchPath, /* 209 */
    TclSetEncodingSearchPath, /* 210 */
    TclpGetEncodingNameFromEnvironment, /* 211 */
    TclpFindExecutable, /* 212 */
    TclGetObjNameOfExecutable, /* 213 */
    TclSetObjNameOfExecutable, /* 214 */
    TclStackAlloc, /* 215 */
    TclStackFree, /* 216 */
    TclPushStackFrame, /* 217 */
    TclPopStackFrame, /* 218 */
    TclBN_mp_div_d, /* 219 */
    TclBN_mp_mul_d, /* 220 */
    TclBN_mp_clear, /* 221 */
    TclBN_mp_init, /* 222 */
    TclBN_mp_read_radix, /* 223 */
    TclGetPlatform, /* 224 */
    TclTraceDictPath, /* 225 */
};

TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    NULL,
#if !defined(__WIN32__) /* UNIX */
    TclGetAndDetachPids, /* 0 */
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
    TclpMakeFile, /* 18 */
    TclpOpenFile, /* 19 */
    TclWinAddProcess, /* 20 */
    NULL, /* 21 */
    TclpCreateTempFile, /* 22 */
    TclpGetTZName, /* 23 */
    TclWinNoBackslash, /* 24 */
    TclWinGetPlatform, /* 25 */
    TclWinSetInterfaces, /* 26 */
    TclWinFlushDirtyChannels, /* 27 */
    TclWinResetInterfaces, /* 28 */
    TclWinCPUID, /* 29 */
#endif /* __WIN32__ */
#ifdef MAC_OSX_TCL
    TclMacOSXGetFileAttribute, /* 15 */







|







354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
    TclpMakeFile, /* 18 */
    TclpOpenFile, /* 19 */
    TclWinAddProcess, /* 20 */
    NULL, /* 21 */
    TclpCreateTempFile, /* 22 */
    TclpGetTZName, /* 23 */
    TclWinNoBackslash, /* 24 */
    NULL, /* 25 */
    TclWinSetInterfaces, /* 26 */
    TclWinFlushDirtyChannels, /* 27 */
    TclWinResetInterfaces, /* 28 */
    TclWinCPUID, /* 29 */
#endif /* __WIN32__ */
#ifdef MAC_OSX_TCL
    TclMacOSXGetFileAttribute, /* 15 */
948
949
950
951
952
953
954


























955
956
957
    Tcl_LimitGetTime, /* 533 */
    Tcl_LimitGetGranularity, /* 534 */
    Tcl_SaveInterpState, /* 535 */
    Tcl_RestoreInterpState, /* 536 */
    Tcl_DiscardInterpState, /* 537 */
    Tcl_SetReturnOptions, /* 538 */
    Tcl_GetReturnOptions, /* 539 */


























};

/* !END!: Do not edit above this line. */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
    Tcl_LimitGetTime, /* 533 */
    Tcl_LimitGetGranularity, /* 534 */
    Tcl_SaveInterpState, /* 535 */
    Tcl_RestoreInterpState, /* 536 */
    Tcl_DiscardInterpState, /* 537 */
    Tcl_SetReturnOptions, /* 538 */
    Tcl_GetReturnOptions, /* 539 */
    Tcl_IsEnsemble, /* 540 */
    Tcl_CreateEnsemble, /* 541 */
    Tcl_FindEnsemble, /* 542 */
    Tcl_SetEnsembleSubcommandList, /* 543 */
    Tcl_SetEnsembleMappingDict, /* 544 */
    Tcl_SetEnsembleUnknownHandler, /* 545 */
    Tcl_SetEnsembleFlags, /* 546 */
    Tcl_GetEnsembleSubcommandList, /* 547 */
    Tcl_GetEnsembleMappingDict, /* 548 */
    Tcl_GetEnsembleUnknownHandler, /* 549 */
    Tcl_GetEnsembleFlags, /* 550 */
    Tcl_GetEnsembleNamespace, /* 551 */
    Tcl_SetTimeProc, /* 552 */
    Tcl_QueryTimeProc, /* 553 */
    Tcl_ChannelThreadActionProc, /* 554 */
    Tcl_NewBignumObj, /* 555 */
    Tcl_DbNewBignumObj, /* 556 */
    Tcl_SetBignumObj, /* 557 */
    Tcl_GetBignumFromObj, /* 558 */
    Tcl_GetBignumAndClearObj, /* 559 */
    Tcl_TruncateChannel, /* 560 */
    Tcl_ChannelTruncateProc, /* 561 */
    Tcl_SetChannelErrorInterp, /* 562 */
    Tcl_GetChannelErrorInterp, /* 563 */
    Tcl_SetChannelError, /* 564 */
    Tcl_GetChannelError, /* 565 */
};

/* !END!: Do not edit above this line. */

Changes to generic/tclTest.c.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.86 2004/11/30 19:34:50 dgp Exp $
 */

#define TCL_TEST
#include "tclInt.h"

/*
 * Required for Testregexp*Cmd







|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.86.2.7 2005/09/09 18:48:40 dgp Exp $
 */

#define TCL_TEST
#include "tclInt.h"

/*
 * Required for Testregexp*Cmd
116
117
118
119
120
121
122














123
124
125
126
127
128
129
 */
typedef struct TestEvent {
    Tcl_Event header;		/* Header common to all events */
    Tcl_Interp* interp;		/* Interpreter that will handle the event */
    Tcl_Obj* command;		/* Command to evaluate when the event occurs */
    Tcl_Obj* tag;		/* Tag for this event used to delete it */
} TestEvent;















/*
 * Forward declarations for procedures defined later in this file:
 */

int			Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,







>
>
>
>
>
>
>
>
>
>
>
>
>
>







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
 */
typedef struct TestEvent {
    Tcl_Event header;		/* Header common to all events */
    Tcl_Interp* interp;		/* Interpreter that will handle the event */
    Tcl_Obj* command;		/* Command to evaluate when the event occurs */
    Tcl_Obj* tag;		/* Tag for this event used to delete it */
} TestEvent;


/*
 * Simple detach/attach facility for testchannel cut|splice.
 * Allow testing of channel transfer in core testsuite.
 */

typedef struct TestChannel {
    Tcl_Channel         chan;    /* Detached channel */
    struct TestChannel* nextPtr; /* Next in pool of detached channels */
} TestChannel;

static TestChannel* firstDetached;


/*
 * Forward declarations for procedures defined later in this file:
 */

int			Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
240
241
242
243
244
245
246








247
248
249
250
251
252
253
static int		TesteventDeleteProc _ANSI_ARGS_((
			    Tcl_Event* event,
			    ClientData clientData));
static int		TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));








static int		TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestfileCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));







>
>
>
>
>
>
>
>







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
static int		TesteventDeleteProc _ANSI_ARGS_((
			    Tcl_Event* event,
			    ClientData clientData));
static int		TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestexprdoubleCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexprdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestfileCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
304
305
306
307
308
309
310



311
312
313
314
315
316
317
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,



			    Tcl_Obj *CONST objv[]));
static void		TestregexpXflags _ANSI_ARGS_((char *string,
			    int length, int *cflagsPtr, int *eflagsPtr));
static int		TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestsaveresultFree _ANSI_ARGS_((char *blockPtr));







>
>
>







326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestreturnObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestregexpXflags _ANSI_ARGS_((char *string,
			    int length, int *cflagsPtr, int *eflagsPtr));
static int		TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
619
620
621
622
623
624
625






626
627
628
629
630
631
632
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,
			  (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);






    Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
            (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, 







>
>
>
>
>
>







644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,
			  (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
            (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, 
659
660
661
662
663
664
665


666
667
668
669
670
671
672
    Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,


	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);







>
>







690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
    Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
2273
2274
2275
2276
2277
2278
2279
2280





2281
2282










































2283
2284
2285
2286
2287
2288
2289























































































2290
2291
2292
2293
2294
2295
2296
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    long exprResult;
    char buf[4 + TCL_INTEGER_SPACE];
    int result;
    





    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprLong(interp, "4+1", &exprResult);










































    if (result != TCL_OK) {
        return result;
    }
    sprintf(buf, ": %ld", exprResult);
    Tcl_AppendResult(interp, buf, NULL);
    return TCL_OK;
}
























































































/*
 *----------------------------------------------------------------------
 *
 * TestexprstringCmd --
 *
 *	This procedure tests the basic operation of Tcl_ExprString.







|
>
>
>
>
>

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    long exprResult;
    char buf[4 + TCL_INTEGER_SPACE];
    int result;

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " expression\"", (char *) NULL);
        return TCL_ERROR;
    }
    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprLong(interp, argv[1], &exprResult);
    if (result != TCL_OK) {
        return result;
    }
    sprintf(buf, ": %ld", exprResult);
    Tcl_AppendResult(interp, buf, NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestexprlongobjCmd --
 *
 *	This procedure verifies that Tcl_ExprLongObj does not modify the
 *	interpreter result if there is no error.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprlongobjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST *objv;		/* Argument objects. */
{
    long exprResult;
    char buf[4 + TCL_INTEGER_SPACE];
    int result;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "expression");
	return TCL_ERROR;
    }
    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
    if (result != TCL_OK) {
        return result;
    }
    sprintf(buf, ": %ld", exprResult);
    Tcl_AppendResult(interp, buf, NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestexprdoubleCmd --
 *
 *	This procedure verifies that Tcl_ExprDouble does not modify the
 *	interpreter result if there is no error.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprdoubleCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    double exprResult;
    char buf[4 + TCL_DOUBLE_SPACE];
    int result;

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " expression\"", (char *) NULL);
        return TCL_ERROR;
    }
    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprDouble(interp, argv[1], &exprResult);
    if (result != TCL_OK) {
        return result;
    }
    strcpy(buf, ": ");
    Tcl_PrintDouble(interp, exprResult, buf+2);
    Tcl_AppendResult(interp, buf, NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestexprdoubleobjCmd --
 *
 *	This procedure verifies that Tcl_ExprLongObj does not modify the
 *	interpreter result if there is no error.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprdoubleobjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST *objv;		/* Argument objects. */
{
    double exprResult;
    char buf[4 + TCL_DOUBLE_SPACE];
    int result;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "expression");
	return TCL_ERROR;
    }
    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
    if (result != TCL_OK) {
        return result;
    }
    strcpy(buf, ": ");
    Tcl_PrintDouble(interp, exprResult, buf+2);
    Tcl_AppendResult(interp, buf, NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestexprstringCmd --
 *
 *	This procedure tests the basic operation of Tcl_ExprString.
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    static CONST char *platformStrings[] = { "unix", "mac", "windows" };
    TclPlatformType *platform;

#ifdef __WIN32__
    platform = TclWinGetPlatform();
#else
    platform = &tclPlatform;
#endif
    
    if (argc != 1) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		(char *) NULL);
        return TCL_ERROR;
    }








<
|
<
<
<







2615
2616
2617
2618
2619
2620
2621

2622



2623
2624
2625
2626
2627
2628
2629
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    static CONST char *platformStrings[] = { "unix", "mac", "windows" };
    TclPlatformType *platform;


    platform = TclGetPlatform();



    
    if (argc != 1) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		(char *) NULL);
        return TCL_ERROR;
    }

2536
2537
2538
2539
2540
2541
2542









2543
2544
2545
2546
2547
2548
2549
2550

2551
2552
2553
2554
2555
2556
2557


2558
2559
2560
2561
2562
2563
2564
2565









2566
2567
2568
2569
2570
2571
2572
    CONST char **argv;			/* Argument strings. */
{
    static int intVar = 43;
    static int boolVar = 4;
    static double realVar = 1.23;
    static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
    static char *stringVar = NULL;









    static int created = 0;
    char buffer[2*TCL_DOUBLE_SPACE];
    int writable, flag;
    Tcl_Obj *tmp;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option ?arg arg arg arg arg?\"", (char *) NULL);

	return TCL_ERROR;
    }
    if (strcmp(argv[1], "create") == 0) {
	if (argc != 7) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " ", argv[1],
		" intRO realRO boolRO stringRO wideRO\"", (char *) NULL);


	    return TCL_ERROR;
	}
	if (created) {
	    Tcl_UnlinkVar(interp, "int");
	    Tcl_UnlinkVar(interp, "real");
	    Tcl_UnlinkVar(interp, "bool");
	    Tcl_UnlinkVar(interp, "string");
	    Tcl_UnlinkVar(interp, "wide");









	}
	created = 1;
	if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "int", (char *) &intVar,







>
>
>
>
>
>
>
>
>







|
>



|


|
>
>








>
>
>
>
>
>
>
>
>







2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
    CONST char **argv;			/* Argument strings. */
{
    static int intVar = 43;
    static int boolVar = 4;
    static double realVar = 1.23;
    static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
    static char *stringVar = NULL;
    static char charVar = '@';
    static unsigned char ucharVar = 130;
    static short shortVar = 3000;
    static unsigned short ushortVar = 60000;
    static unsigned int uintVar = 0xbeeffeed;
    static long longVar = 123456789L;
    static unsigned long ulongVar = 3456789012UL;
    static float floatVar = 4.5;
    static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123);
    static int created = 0;
    char buffer[2*TCL_DOUBLE_SPACE];
    int writable, flag;
    Tcl_Obj *tmp;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option ?arg arg arg arg arg arg arg arg arg arg arg arg",
		" arg arg?\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "create") == 0) {
	if (argc != 16) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " ", argv[1],
		" intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO",
		" ushortRO uintRO longRO ulongRO floatRO uwideRO\"",
		(char *) NULL);
	    return TCL_ERROR;
	}
	if (created) {
	    Tcl_UnlinkVar(interp, "int");
	    Tcl_UnlinkVar(interp, "real");
	    Tcl_UnlinkVar(interp, "bool");
	    Tcl_UnlinkVar(interp, "string");
	    Tcl_UnlinkVar(interp, "wide");
	    Tcl_UnlinkVar(interp, "char");
	    Tcl_UnlinkVar(interp, "uchar");
	    Tcl_UnlinkVar(interp, "short");
	    Tcl_UnlinkVar(interp, "ushort");
	    Tcl_UnlinkVar(interp, "uint");
	    Tcl_UnlinkVar(interp, "long");
	    Tcl_UnlinkVar(interp, "ulong");
	    Tcl_UnlinkVar(interp, "float");
	    Tcl_UnlinkVar(interp, "uwide");
	}
	created = 1;
	if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "int", (char *) &intVar,
2601
2602
2603
2604
2605
2606
2607









































































2608
2609
2610
2611
2612
2613









2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628





















2629


2630
2631
2632
2633


2634
2635
2636
2637
2638
2639
2640
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,
			TCL_LINK_WIDE_INT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}









































































    } else if (strcmp(argv[1], "delete") == 0) {
	Tcl_UnlinkVar(interp, "int");
	Tcl_UnlinkVar(interp, "real");
	Tcl_UnlinkVar(interp, "bool");
	Tcl_UnlinkVar(interp, "string");
	Tcl_UnlinkVar(interp, "wide");









	created = 0;
    } else if (strcmp(argv[1], "get") == 0) {
	TclFormatInt(buffer, intVar);
	Tcl_AppendElement(interp, buffer);
	Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
	Tcl_AppendElement(interp, buffer);
	TclFormatInt(buffer, boolVar);
	Tcl_AppendElement(interp, buffer);
	Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
	/*
	 * Wide ints only have an object-based interface.
	 */
	tmp = Tcl_NewWideIntObj(wideVar);
	Tcl_AppendElement(interp, Tcl_GetString(tmp));
	Tcl_DecrRefCount(tmp);





















    } else if (strcmp(argv[1], "set") == 0) {


	if (argc != 7) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1],
		    " intValue realValue boolValue stringValue wideValue\"",


		    (char *) NULL);
	    return TCL_ERROR;
	}
	if (argv[2][0] != 0) {
	    if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
		return TCL_ERROR;
	    }







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>
>
>
>
>
>
>
>
>















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
|


|
>
>







2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,
			TCL_LINK_WIDE_INT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "char", (char *) &charVar,
		TCL_LINK_CHAR | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "uchar", (char *) &ucharVar,
		TCL_LINK_UCHAR | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "short", (char *) &shortVar,
		TCL_LINK_SHORT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "ushort", (char *) &ushortVar,
		TCL_LINK_USHORT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "uint", (char *) &uintVar,
		TCL_LINK_UINT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "long", (char *) &longVar,
		TCL_LINK_LONG | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "ulong", (char *) &ulongVar,
		TCL_LINK_ULONG | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "float", (char *) &floatVar,
		TCL_LINK_FLOAT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) {
	    return TCL_ERROR;
	}
	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
	if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar,
		TCL_LINK_WIDE_UINT | flag) != TCL_OK) {
	    return TCL_ERROR;
	}

    } else if (strcmp(argv[1], "delete") == 0) {
	Tcl_UnlinkVar(interp, "int");
	Tcl_UnlinkVar(interp, "real");
	Tcl_UnlinkVar(interp, "bool");
	Tcl_UnlinkVar(interp, "string");
	Tcl_UnlinkVar(interp, "wide");
	Tcl_UnlinkVar(interp, "char");
	Tcl_UnlinkVar(interp, "uchar");
	Tcl_UnlinkVar(interp, "short");
	Tcl_UnlinkVar(interp, "ushort");
	Tcl_UnlinkVar(interp, "uint");
	Tcl_UnlinkVar(interp, "long");
	Tcl_UnlinkVar(interp, "ulong");
	Tcl_UnlinkVar(interp, "float");
	Tcl_UnlinkVar(interp, "uwide");
	created = 0;
    } else if (strcmp(argv[1], "get") == 0) {
	TclFormatInt(buffer, intVar);
	Tcl_AppendElement(interp, buffer);
	Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
	Tcl_AppendElement(interp, buffer);
	TclFormatInt(buffer, boolVar);
	Tcl_AppendElement(interp, buffer);
	Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
	/*
	 * Wide ints only have an object-based interface.
	 */
	tmp = Tcl_NewWideIntObj(wideVar);
	Tcl_AppendElement(interp, Tcl_GetString(tmp));
	Tcl_DecrRefCount(tmp);
	TclFormatInt(buffer, (int) charVar);
	Tcl_AppendElement(interp, buffer);
	TclFormatInt(buffer, (int) ucharVar);
	Tcl_AppendElement(interp, buffer);
	TclFormatInt(buffer, (int) shortVar);
	Tcl_AppendElement(interp, buffer);
	TclFormatInt(buffer, (int) ushortVar);
	Tcl_AppendElement(interp, buffer);
	TclFormatInt(buffer, (int) uintVar);
	Tcl_AppendElement(interp, buffer);
	tmp = Tcl_NewLongObj(longVar);
	Tcl_AppendElement(interp, Tcl_GetString(tmp));
	Tcl_DecrRefCount(tmp);
	tmp = Tcl_NewLongObj((long)ulongVar);
	Tcl_AppendElement(interp, Tcl_GetString(tmp));
	Tcl_DecrRefCount(tmp);
	Tcl_PrintDouble((Tcl_Interp *) NULL, (double)floatVar, buffer);
	Tcl_AppendElement(interp, buffer);
	tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
	Tcl_AppendElement(interp, Tcl_GetString(tmp));
	Tcl_DecrRefCount(tmp);
    } else if (strcmp(argv[1], "set") == 0) {
	int v;

	if (argc != 16) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1],
		    " intValue realValue boolValue stringValue wideValue",
		    " charValue ucharValue shortValue ushortValue uintValue",
		    " longValue ulongValue floatValue uwideValue\"",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	if (argv[2][0] != 0) {
	    if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
		return TCL_ERROR;
	    }
2664
2665
2666
2667
2668
2669
2670



























































2671


2672
2673
2674
2675


2676
2677
2678
2679
2680
2681
2682
	    tmp = Tcl_NewStringObj(argv[6], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	}



























































    } else if (strcmp(argv[1], "update") == 0) {


	if (argc != 7) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1],
		    "intValue realValue boolValue stringValue wideValue\"",


		    (char *) NULL);
	    return TCL_ERROR;
	}
	if (argv[2][0] != 0) {
	    if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
		return TCL_ERROR;
	    }







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
|


|
>
>







2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
	    tmp = Tcl_NewStringObj(argv[6], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	}
	if (argv[7][0]) {
	    if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    charVar = (char) v;
	}
	if (argv[8][0]) {
	    if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ucharVar = (unsigned char) v;
	}
	if (argv[9][0]) {
	    if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    shortVar = (short) v;
	}
	if (argv[10][0]) {
	    if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ushortVar = (unsigned short) v;
	}
	if (argv[11][0]) {
	    if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    uintVar = (unsigned int) v;
	}
	if (argv[12][0]) {
	    if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    longVar = (long) v;
	}
	if (argv[13][0]) {
	    if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ulongVar = (unsigned long) v;
	}
	if (argv[14][0]) {
	    double d;
	    if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
		return TCL_ERROR;
	    }
	    floatVar = (float) d;
	}
	if (argv[15][0]) {
	    Tcl_WideInt w;
	    tmp = Tcl_NewStringObj(argv[15], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    uwideVar = (Tcl_WideUInt) w;
	}
    } else if (strcmp(argv[1], "update") == 0) {
	int v;

	if (argc != 16) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1],
		    " intValue realValue boolValue stringValue wideValue",
		    " charValue ucharValue shortValue ushortValue uintValue",
		    " longValue ulongValue floatValue uwideValue\"",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	if (argv[2][0] != 0) {
	    if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
		return TCL_ERROR;
	    }
2711
2712
2713
2714
2715
2716
2717




































































2718
2719
2720
2721
2722
2723
2724
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    Tcl_UpdateLinkedVar(interp, "wide");
	}




































































    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be create, delete, get, set, or update",
		(char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    Tcl_UpdateLinkedVar(interp, "wide");
	}
	if (argv[7][0]) {
	    if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    charVar = (char) v;
	    Tcl_UpdateLinkedVar(interp, "char");
	}
	if (argv[8][0]) {
	    if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ucharVar = (unsigned char) v;
	    Tcl_UpdateLinkedVar(interp, "uchar");
	}
	if (argv[9][0]) {
	    if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    shortVar = (short) v;
	    Tcl_UpdateLinkedVar(interp, "short");
	}
	if (argv[10][0]) {
	    if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ushortVar = (unsigned short) v;
	    Tcl_UpdateLinkedVar(interp, "ushort");
	}
	if (argv[11][0]) {
	    if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    uintVar = (unsigned int) v;
	    Tcl_UpdateLinkedVar(interp, "uint");
	}
	if (argv[12][0]) {
	    if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    longVar = (long) v;
	    Tcl_UpdateLinkedVar(interp, "long");
	}
	if (argv[13][0]) {
	    if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ulongVar = (unsigned long) v;
	    Tcl_UpdateLinkedVar(interp, "ulong");
	}
	if (argv[14][0]) {
	    double d;
	    if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
		return TCL_ERROR;
	    }
	    floatVar = (float) d;
	    Tcl_UpdateLinkedVar(interp, "float");
	}
	if (argv[15][0]) {
	    Tcl_WideInt w;
	    tmp = Tcl_NewStringObj(argv[15], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    uwideVar = (Tcl_WideUInt) w;
	    Tcl_UpdateLinkedVar(interp, "uwide");
	}
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be create, delete, get, set, or update",
		(char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
3610
3611
3612
3613
3614
3615
3616































3617
3618
3619
3620
3621
3622
3623
    *cflagsPtr = cflags;
    *eflagsPtr = eflags;
}

/*
 *----------------------------------------------------------------------
 *































 * TestsetassocdataCmd --
 *
 *	This procedure implements the "testsetassocdata" command. It is used
 *	to test Tcl_SetAssocData.
 *
 * Results:
 *	A standard Tcl result.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
    *cflagsPtr = cflags;
    *eflagsPtr = eflags;
}

/*
 *----------------------------------------------------------------------
 *
 * TestreturnObjCmd --
 *
 *	This procedure implements the "testreturn" command. It is
 *	used to verify that a
 *		return TCL_RETURN;
 *	has same behavior as
 *		return Tcl_SetReturnOptions(interp, Tcl_NewObj());
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TestreturnObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    return TCL_RETURN;
}

/*
 *----------------------------------------------------------------------
 *
 * TestsetassocdataCmd --
 *
 *	This procedure implements the "testsetassocdata" command. It is used
 *	to test Tcl_SetAssocData.
 *
 * Results:
 *	A standard Tcl result.
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    size_t length;
    TclPlatformType *platform;

#ifdef __WIN32__
    platform = TclWinGetPlatform();
#else
    platform = &tclPlatform;
#endif
    
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " platform\"", (char *) NULL);
        return TCL_ERROR;
    }








<
|
<
<
<







4141
4142
4143
4144
4145
4146
4147

4148



4149
4150
4151
4152
4153
4154
4155
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    size_t length;
    TclPlatformType *platform;


    platform = TclGetPlatform();



    
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " platform\"", (char *) NULL);
        return TCL_ERROR;
    }

4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    char *name, *arg;
    int flags = 0;
    Tcl_Namespace *namespacePtr;
    Tcl_CallFrame frame;
    Tcl_Var variable;
    int result;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name scope");
        return TCL_ERROR;
    }







|







4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    char *name, *arg;
    int flags = 0;
    Tcl_Namespace *namespacePtr;
    Tcl_CallFrame *framePtr;
    Tcl_Var variable;
    int result;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name scope");
        return TCL_ERROR;
    }
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243

    if (flags == TCL_NAMESPACE_ONLY) {
	namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
	        (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
	if (namespacePtr == NULL) {
	    return TCL_ERROR;
	}
	result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
                /*isProcCallFrame*/ 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
    
    variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
	    (flags | TCL_LEAVE_ERR_MSG));

    if (flags == TCL_NAMESPACE_ONLY) {
	Tcl_PopCallFrame(interp);
    }
    if (variable == (Tcl_Var) NULL) {
	return TCL_ERROR;
    }
    Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
    return TCL_OK;
}







|










|







4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692

    if (flags == TCL_NAMESPACE_ONLY) {
	namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
	        (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
	if (namespacePtr == NULL) {
	    return TCL_ERROR;
	}
	result = TclPushStackFrame(interp, &framePtr, namespacePtr,
                /*isProcCallFrame*/ 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
    
    variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
	    (flags | TCL_LEAVE_ERR_MSG));

    if (flags == TCL_NAMESPACE_ONLY) {
	TclPopStackFrame(interp);
    }
    if (variable == (Tcl_Var) NULL) {
	return TCL_ERROR;
    }
    Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
    return TCL_OK;
}
5315
5316
5317
5318
5319
5320
5321






















5322

5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335



































5336


5337
5338
5339
5340
5341




5342








5343
5344
5345
5346
5347
5348
5349
    }
    cmdName = argv[1];
    len = strlen(cmdName);

    chanPtr = (Channel *) NULL;

    if (argc > 2) {






















        chan = Tcl_GetChannel(interp, argv[2], &mode);

        if (chan == (Tcl_Channel) NULL) {
            return TCL_ERROR;
        }
        chanPtr		= (Channel *) chan;
	statePtr	= chanPtr->state;
        chanPtr		= statePtr->topChanPtr;
	chan		= (Tcl_Channel) chanPtr;
    } else {
	/* lint */
	statePtr	= NULL;
	chan		= NULL;
    }




































    if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {


        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " cut channelName\"", (char *) NULL);
            return TCL_ERROR;
        }




        Tcl_CutChannel(chan);








        return TCL_OK;
    }

    if ((cmdName[0] == 'c') &&
	    (strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>





>
>
>
>

>
>
>
>
>
>
>
>







5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
    }
    cmdName = argv[1];
    len = strlen(cmdName);

    chanPtr = (Channel *) NULL;

    if (argc > 2) {
        if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
	    /* For splice access the pool of detached channels.
	     * Locate channel, remove from the list.
	     */

	    TestChannel** nextPtrPtr;
	    TestChannel*  curPtr;

	    chan = (Tcl_Channel) NULL;
	    for (nextPtrPtr = &firstDetached, curPtr = firstDetached;
		 curPtr != NULL;
		 nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {

	        if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) {
		    *nextPtrPtr    = curPtr->nextPtr;
		    curPtr->nextPtr = NULL;
		    chan = curPtr->chan;
		    ckfree ((char*) curPtr);
		    break;
		}
	    }
	} else {
	    chan = Tcl_GetChannel(interp, argv[2], &mode);
	}
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
        chanPtr		= (Channel *) chan;
	statePtr	= chanPtr->state;
        chanPtr		= statePtr->topChanPtr;
	chan		= (Tcl_Channel) chanPtr;
    } else {
	/* lint */
	statePtr	= NULL;
	chan		= NULL;
    }

    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {

	Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1);

	Tcl_IncrRefCount (msg);
	Tcl_SetChannelError (chan, msg);
	Tcl_DecrRefCount (msg);

	Tcl_GetChannelError (chan, &msg);
	Tcl_SetObjResult (interp, msg);
	Tcl_DecrRefCount (msg);
	return TCL_OK;
    }
    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {

	Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1);

	Tcl_IncrRefCount (msg);
	Tcl_SetChannelErrorInterp (interp, msg);
	Tcl_DecrRefCount (msg);

	Tcl_GetChannelErrorInterp (interp, &msg);
	Tcl_SetObjResult (interp, msg);
	Tcl_DecrRefCount (msg);
	return TCL_OK;
    }

    /*
     * "cut" is actually more a simplified detach facility as provided
     * by the Thread package. Without the safeguards of a regular
     * command (no checking that the command is truly cut'able, no
     * mutexes for thread-safety). Its complementary command is
     * "splice", see below.
     */

    if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
        TestChannel* det;

        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " cut channelName\"", (char *) NULL);
            return TCL_ERROR;
        }

	Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); /* prevent closing */
	Tcl_UnregisterChannel(interp, chan);

        Tcl_CutChannel(chan);

	/* Remember the channel in the pool of detached channels */

	det = (TestChannel*) ckalloc (sizeof(TestChannel));
	det->chan     = chan;
	det->nextPtr  = firstDetached;
	firstDetached = det;

        return TCL_OK;
    }

    if ((cmdName[0] == 'c') &&
	    (strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
5589
5590
5591
5592
5593
5594
5595








5596
5597
5598
5599
5600
5601
5602




5603
5604
5605
5606
5607
5608
5609
        }
        
        TclFormatInt(buf, statePtr->refCount);
        Tcl_AppendResult(interp, buf, (char *) NULL);
        return TCL_OK;
    }









    if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required", (char *) NULL);
            return TCL_ERROR;
        }

        Tcl_SpliceChannel(chan);




        return TCL_OK;
    }

    if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required",
                    (char *) NULL);







>
>
>
>
>
>
>
>







>
>
>
>







6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
        }
        
        TclFormatInt(buf, statePtr->refCount);
        Tcl_AppendResult(interp, buf, (char *) NULL);
        return TCL_OK;
    }

    /*
     * "splice" is actually more a simplified attach facility as
     * provided by the Thread package. Without the safeguards of a
     * regular command (no checking that the command is truly
     * cut'able, no mutexes for thread-safety). Its complementary
     * command is "cut", see above.
     */

    if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required", (char *) NULL);
            return TCL_ERROR;
        }

        Tcl_SpliceChannel(chan);

	Tcl_RegisterChannel(interp, chan);
	Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan);

        return TCL_OK;
    }

    if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required",
                    (char *) NULL);
6635
6636
6637
6638
6639
6640
6641








	    total += val;
	}
	TclFormatInt(buf, total);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
    }
}















>
>
>
>
>
>
>
>
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
	    total += val;
	}
	TclFormatInt(buf, total);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclTestObj.c.

1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
/* 
 * tclTestObj.c --
 *
 *	This file contains C command procedures for the additional Tcl
 *	commands that are used for testing implementations of the Tcl object
 *	types. These commands are not normally included in Tcl
 *	applications; they're only used for testing.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTestObj.c,v 1.12 2002/12/04 13:09:24 vincentdarley Exp $
 */

#include "tclInt.h"


/*
 * An array of Tcl_Obj pointers used in the commands that operate on or get
 * the values of Tcl object-valued variables. varPtr[i] is the i-th
 * variable's Tcl_Obj *.
 */











>




|



>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
/* 
 * tclTestObj.c --
 *
 *	This file contains C command procedures for the additional Tcl
 *	commands that are used for testing implementations of the Tcl object
 *	types. These commands are not normally included in Tcl
 *	applications; they're only used for testing.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTestObj.c,v 1.12.6.5 2005/08/22 16:11:37 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * An array of Tcl_Obj pointers used in the commands that operate on or get
 * the values of Tcl object-valued variables. varPtr[i] is the i-th
 * variable's Tcl_Obj *.
 */

33
34
35
36
37
38
39



40
41
42

43
44
45

46
47
48
49
50
51
52
static int		CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
			    int varIndex));
static int		GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
			    char *string, int *indexPtr));
static void		SetVarToObj _ANSI_ARGS_((int varIndex,
			    Tcl_Obj *objPtr));
int			TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));



static int		TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));

static int		TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));

static int		TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestintobjCmd _ANSI_ARGS_((ClientData dummy,







>
>
>



>



>







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
static int		CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
			    int varIndex));
static int		GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
			    char *string, int *indexPtr));
static void		SetVarToObj _ANSI_ARGS_((int varIndex,
			    Tcl_Obj *objPtr));
int			TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int		TestbignumobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
#if 0
static int		TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
#endif
static int		TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestintobjCmd _ANSI_ARGS_((ClientData dummy,
91
92
93
94
95
96
97


98
99

100
101

102
103
104
105
106
107
108
109
110
111
112
113



























































































































































114
115
116
117
118
119
120
{
    register int i;
    
    for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
        varPtr[i] = NULL;
    }
	


    Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}




























































































































































/*
 *----------------------------------------------------------------------
 *
 * TestbooleanobjCmd --
 *
 *	This procedure implements the "testbooleanobj" command.  It is used







>
>


>


>












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
{
    register int i;
    
    for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
        varPtr[i] = NULL;
    }
	
    Tcl_CreateObjCommand( interp, "testbignumobj", TestbignumobjCmd,
			  (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
    Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
#if 0
    Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
#endif
    Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestbignumobjCmd --
 *
 *	This procedure implmenets the "testbignumobj" command.  It is used
 *	to exercise the bignum Tcl object type implementation.
 *
 * Results:
 *	Returns a standard Tcl object result.
 *
 * Side effects:
 *	Creates and frees bignum objects; converts objects to have bignum
 *	type.
 *
 *----------------------------------------------------------------------
 */

static int
TestbignumobjCmd( clientData, interp, objc, objv )
    ClientData clientData;	/* unused */
    Tcl_Interp* interp;		/* Tcl interpreter */
    int objc;			/* Argument count */
    Tcl_Obj* CONST objv[];	/* Argument vector */
{
    const char * subcmds[] = {
	"set",      "get",      "mult10",      "div10", 
	NULL
    };
    enum options {
	BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
    };

    int index, varIndex;
    char* string;
    mp_int bignumValue, newValue;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }
    string = Tcl_GetString(objv[2]);
    if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case BIGNUM_SET:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "var value");
	    return TCL_ERROR;
	}
	string = Tcl_GetString(objv[3]);
	if (mp_init(&bignumValue) != MP_OKAY) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_init", -1));
	    return TCL_ERROR;
	}
	if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_read_radix", -1));
	    return TCL_ERROR;
	}

	/*
	 * If the object currently bound to the variable with index
	 * varIndex has ref count 1 (i.e. the object is unshared) we can
	 * modify that object directly.  Otherwise, if RC>1 (i.e. the
	 * object is shared), we must create a new object to modify/set and
	 * decrement the old formerly-shared object's ref count. This is
	 * "copy on write".
	 */

	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
	} else {
	    SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
	}
	break;
	    
    case BIGNUM_GET:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
	    return TCL_ERROR;
	}
	if (CheckIfVarUnset(interp, varIndex)) {
	    return TCL_ERROR;
	}
	break;

    case BIGNUM_MULT10:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
	    return TCL_ERROR;
	}
	if (CheckIfVarUnset(interp, varIndex)) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_init(&newValue) != MP_OKAY 
		|| (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) {
	    mp_clear(&bignumValue);
	    mp_clear(&newValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_mul_d", -1));
	    return TCL_ERROR;
	}
	mp_clear(&bignumValue);
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &newValue);
	} else {
	    SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
	}
	break;

    case BIGNUM_DIV10:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
	    return TCL_ERROR;
	}
	if (CheckIfVarUnset(interp, varIndex)) {
	    return TCL_ERROR;
	}
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_init(&newValue) != MP_OKAY 
		|| (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) {
	    mp_clear(&bignumValue);
	    mp_clear(&newValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_div_d", -1));
	    return TCL_ERROR;
	}
	mp_clear(&bignumValue);
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &newValue);
	} else {
	    SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
	}
    }

    Tcl_SetObjResult(interp, varPtr[varIndex]);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestbooleanobjCmd --
 *
 *	This procedure implements the "testbooleanobj" command.  It is used
204
205
206
207
208
209
210

211
212
213
214
215
216
217
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, or not", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TestconvertobjCmd --
 *
 *	This procedure implements the "testconvertobj" command. It is used
 *	to test converting objects to new types.







>







370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, or not", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

#if 0
/*
 *----------------------------------------------------------------------
 *
 * TestconvertobjCmd --
 *
 *	This procedure implements the "testconvertobj" command. It is used
 *	to test converting objects to new types.
257
258
259
260
261
262
263

264
265
266
267
268
269
270
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be double", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TestdoubleobjCmd --
 *
 *	This procedure implements the "testdoubleobj" command.  It is used







>







424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be double", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TestdoubleobjCmd --
 *
 *	This procedure implements the "testdoubleobj" command.  It is used

Changes to generic/tclThread.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
/* 
 * tclThread.c --
 *
 *	This file implements   Platform independent thread operations.
 *	Most of the real work is done in the platform dependent files.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThread.c,v 1.8 2004/06/24 01:29:02 mistachkin Exp $
 */

#include "tclInt.h"

/*
 * There are three classes of synchronization objects:
 * mutexes, thread data keys, and condition variables.
 * The following are used to record the memory used for these
 * objects so they can be finalized.
 *
 * These statics are guarded by the mutex in the caller of
 * TclRememberThreadData, e.g., TclpThreadDataKeyInit
 */

typedef struct {
    int num;		/* Number of objects remembered */
    int max;		/* Max size of the array */
    char **list;	/* List of pointers */
} SyncObjRecord;

static SyncObjRecord keyRecord = {0, 0, NULL};
static SyncObjRecord mutexRecord = {0, 0, NULL};
static SyncObjRecord condRecord = {0, 0, NULL};

/*
 * Prototypes of functions used only in this file
 */
 
static void		RememberSyncObject _ANSI_ARGS_((char *objPtr,
			    SyncObjRecord *recPtr));
static void		ForgetSyncObject _ANSI_ARGS_((char *objPtr,
			    SyncObjRecord *recPtr));

/* 
 * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
 * specified.  Here we undo that so the procedures are defined in the
 * stubs table.
 */

#ifndef TCL_THREADS
#undef Tcl_MutexLock
#undef Tcl_MutexUnlock
#undef Tcl_MutexFinalize
#undef Tcl_ConditionNotify
#undef Tcl_ConditionWait
#undef Tcl_ConditionFinalize
#endif


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetThreadData --
 *
 *	This procedure allocates and initializes a chunk of thread
 *	local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure.
 *
 * Side effects:
 *	Will allocate memory the first time this thread calls for
 *	this chunk of storage.
 *
 *----------------------------------------------------------------------
 */

VOID *
Tcl_GetThreadData(keyPtr, size)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk */
    int size;			/* Size of storage block */
{
    VOID *result;
#ifdef TCL_THREADS

    /*
     * See if this is the first thread to init this key.
     */

    if (*keyPtr == NULL) {
#ifdef USE_THREAD_STORAGE
	TclThreadStorageDataKeyInit(keyPtr);
#else
	TclpThreadDataKeyInit(keyPtr);
#endif
    }

    /*
     * Initialize the key for this thread.
     */
#ifdef USE_THREAD_STORAGE
    result = TclThreadStorageDataKeyGet(keyPtr);
#else
    result = TclpThreadDataKeyGet(keyPtr);
#endif

    if (result == NULL) {
	result  = (VOID *)ckalloc((size_t)size);
	memset(result, 0, (size_t)size);
#ifdef USE_THREAD_STORAGE
  TclThreadStorageDataKeySet(keyPtr, result);
#else
	TclpThreadDataKeySet(keyPtr, result);
#endif
    }
#else
    if (*keyPtr == NULL) {
	result = (VOID *)ckalloc((size_t)size);
	memset((char *)result, 0, (size_t)size);
	*keyPtr = (Tcl_ThreadDataKey)result;
	TclRememberDataKey(keyPtr);
    }
    result = *(VOID **)keyPtr;
#endif
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadDataKeyGet --
 *
 *	This procedure returns a pointer to a block of thread local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure, or NULL
 *	if the memory has not been assigned to this key for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

VOID *
TclThreadDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
{
#ifdef TCL_THREADS
#ifdef USE_THREAD_STORAGE
    return (VOID *)TclThreadStorageDataKeyGet(keyPtr);
#else
    return (VOID *)TclpThreadDataKeyGet(keyPtr);
#endif
#else
    char *result = *(char **)keyPtr;
    return (VOID *)result;
#endif /* TCL_THREADS */
}


/*
 *----------------------------------------------------------------------
 *
 * TclThreadDataKeySet --
 *
 *	This procedure sets a thread local storage pointer.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The assigned value will be returned by TclpThreadDataKeyGet.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadDataKeySet(keyPtr, data)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
    VOID *data;			/* Thread local storage */
{
#ifdef TCL_THREADS
    if (*keyPtr == NULL) {
#ifdef USE_THREAD_STORAGE
	TclThreadStorageDataKeyInit(keyPtr);
#else
	TclpThreadDataKeyInit(keyPtr);
#endif
    }
#ifdef USE_THREAD_STORAGE
    TclThreadStorageDataKeySet(keyPtr, data);
#else
    TclpThreadDataKeySet(keyPtr, data);
#endif
#else
    *keyPtr = (Tcl_ThreadDataKey)data;
#endif /* TCL_THREADS */
}



/*
 *----------------------------------------------------------------------
 *
 * RememberSyncObject
 *
 *      Keep a list of (mutexes/condition variable/data key)
 *	used during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the appropriate list.
 *
 *----------------------------------------------------------------------
 */

static void
RememberSyncObject(objPtr, recPtr)
    char *objPtr;		/* Pointer to sync object */
    SyncObjRecord *recPtr;	/* Record of sync objects */
{
    char **newList;
    int i, j;

    /*
     * Save the pointer to the allocated object so it can be finalized.
     * Grow the list of pointers if necessary, copying only non-NULL
     * pointers to the new list.
     */

    if (recPtr->num >= recPtr->max) {
	recPtr->max += 8;
	newList = (char **)ckalloc(recPtr->max * sizeof(char *));
	for (i=0,j=0 ; i<recPtr->num ; i++) {
            if (recPtr->list[i] != NULL) {
		newList[j++] = recPtr->list[i];
            }
	}
	if (recPtr->list != NULL) {
	    ckfree((char *)recPtr->list);
	}
	recPtr->list = newList;
	recPtr->num = j;
    }
    recPtr->list[recPtr->num] = objPtr;
    recPtr->num++;
}

/*
 *----------------------------------------------------------------------
 *
 * ForgetSyncObject
 *
 *      Remove a single object from the list.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove from the appropriate list.
 *



|
|



|
|

|





|
<
|
|
















|









|
|

>















|
|





|
|











<
<
<
<
<
<
<
<
<
<
<
<
<



<
<
<

<




<
<
<

<

|




|


|








|


|
|









|
|


<
<
<

<
|









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
|



















|
|
|






|

|
















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85













86
87
88



89

90
91
92
93



94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130



131

132
133
134
135
136
137
138
139
140
141










































142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
/* 
 * tclThread.c --
 *
 *	This file implements Platform independent thread operations. Most of
 *	the real work is done in the platform dependent files.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThread.c,v 1.8.2.4 2005/08/15 18:13:59 dgp Exp $
 */

#include "tclInt.h"

/*
 * There are three classes of synchronization objects: mutexes, thread data

 * keys, and condition variables. The following are used to record the memory
 * used for these objects so they can be finalized.
 *
 * These statics are guarded by the mutex in the caller of
 * TclRememberThreadData, e.g., TclpThreadDataKeyInit
 */

typedef struct {
    int num;		/* Number of objects remembered */
    int max;		/* Max size of the array */
    char **list;	/* List of pointers */
} SyncObjRecord;

static SyncObjRecord keyRecord = {0, 0, NULL};
static SyncObjRecord mutexRecord = {0, 0, NULL};
static SyncObjRecord condRecord = {0, 0, NULL};

/*
 * Prototypes of functions used only in this file.
 */
 
static void		RememberSyncObject _ANSI_ARGS_((char *objPtr,
			    SyncObjRecord *recPtr));
static void		ForgetSyncObject _ANSI_ARGS_((char *objPtr,
			    SyncObjRecord *recPtr));

/* 
 * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
 * specified. Here we undo that so the functions are defined in the stubs
 * table.
 */

#ifndef TCL_THREADS
#undef Tcl_MutexLock
#undef Tcl_MutexUnlock
#undef Tcl_MutexFinalize
#undef Tcl_ConditionNotify
#undef Tcl_ConditionWait
#undef Tcl_ConditionFinalize
#endif


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetThreadData --
 *
 *	This function allocates and initializes a chunk of thread local
 *	storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure.
 *
 * Side effects:
 *	Will allocate memory the first time this thread calls for this chunk
 *	of storage.
 *
 *----------------------------------------------------------------------
 */

VOID *
Tcl_GetThreadData(keyPtr, size)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk */
    int size;			/* Size of storage block */
{
    VOID *result;
#ifdef TCL_THREADS













    /*
     * Initialize the key for this thread.
     */



    result = TclpThreadDataKeyGet(keyPtr);


    if (result == NULL) {
	result  = (VOID *)ckalloc((size_t)size);
	memset(result, 0, (size_t)size);



	TclpThreadDataKeySet(keyPtr, result);

    }
#else /* TCL_THREADS */
    if (*keyPtr == NULL) {
	result = (VOID *)ckalloc((size_t)size);
	memset((char *)result, 0, (size_t)size);
	*keyPtr = (Tcl_ThreadDataKey)result;
	RememberSyncObject((char *)keyPtr, &keyRecord);
    }
    result = *(VOID **)keyPtr;
#endif /* TCL_THREADS */
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadDataKeyGet --
 *
 *	This function returns a pointer to a block of thread local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure, or NULL if the memory
 *	has not been assigned to this key for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

VOID *
TclThreadDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk, really
				 * (pthread_key_t **) */
{
#ifdef TCL_THREADS



    return (VOID *)TclpThreadDataKeyGet(keyPtr);

#else /* TCL_THREADS */
    char *result = *(char **)keyPtr;
    return (VOID *)result;
#endif /* TCL_THREADS */
}


/*
 *----------------------------------------------------------------------
 *










































 * RememberSyncObject
 *
 *	Keep a list of (mutexes/condition variable/data key) used during
 *	finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the appropriate list.
 *
 *----------------------------------------------------------------------
 */

static void
RememberSyncObject(objPtr, recPtr)
    char *objPtr;		/* Pointer to sync object */
    SyncObjRecord *recPtr;	/* Record of sync objects */
{
    char **newList;
    int i, j;

    /*
     * Save the pointer to the allocated object so it can be finalized. Grow
     * the list of pointers if necessary, copying only non-NULL pointers to
     * the new list.
     */

    if (recPtr->num >= recPtr->max) {
	recPtr->max += 8;
	newList = (char **)ckalloc(recPtr->max * sizeof(char *));
	for (i=0,j=0 ; i<recPtr->num ; i++) {
	    if (recPtr->list[i] != NULL) {
		newList[j++] = recPtr->list[i];
	    }
	}
	if (recPtr->list != NULL) {
	    ckfree((char *)recPtr->list);
	}
	recPtr->list = newList;
	recPtr->num = j;
    }
    recPtr->list[recPtr->num] = objPtr;
    recPtr->num++;
}

/*
 *----------------------------------------------------------------------
 *
 * ForgetSyncObject
 *
 *	Remove a single object from the list.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove from the appropriate list.
 *
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberMutex
 *
 *      Keep a list of mutexes used during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the mutex list.
 *
 *----------------------------------------------------------------------
 */

void
TclRememberMutex(mutexPtr)
    Tcl_Mutex *mutexPtr;
{
    RememberSyncObject((char *)mutexPtr, &mutexRecord);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexFinalize
 *
 *      Finalize a single mutex and remove it from the
 *	list of remembered objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove the mutex from the list.
 *







|




















|

|
|







217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberMutex
 *
 *	Keep a list of mutexes used during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the mutex list.
 *
 *----------------------------------------------------------------------
 */

void
TclRememberMutex(mutexPtr)
    Tcl_Mutex *mutexPtr;
{
    RememberSyncObject((char *)mutexPtr, &mutexRecord);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexFinalize --
 *
 *	Finalize a single mutex and remove it from the list of remembered
 *	objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove the mutex from the list.
 *
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
#endif
    ForgetSyncObject((char *)mutexPtr, &mutexRecord);
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberDataKey
 *
 *      Keep a list of thread data keys used during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the key list.
 *
 *----------------------------------------------------------------------
 */

void
TclRememberDataKey(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    RememberSyncObject((char *)keyPtr, &keyRecord);
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberCondition
 *
 *      Keep a list of condition variables used during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the condition variable list.
 *
 *----------------------------------------------------------------------
 */

void
TclRememberCondition(condPtr)
    Tcl_Condition *condPtr;
{
    RememberSyncObject((char *)condPtr, &condRecord);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionFinalize
 *
 *      Finalize a single condition variable and remove it from the
 *	list of remembered objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove the condition variable from the list.
 *







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|




















|

|
|







265
266
267
268
269
270
271























272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
#endif
    ForgetSyncObject((char *)mutexPtr, &mutexRecord);
}

/*
 *----------------------------------------------------------------------
 *























 * TclRememberCondition
 *
 *	Keep a list of condition variables used during finalization.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the condition variable list.
 *
 *----------------------------------------------------------------------
 */

void
TclRememberCondition(condPtr)
    Tcl_Condition *condPtr;
{
    RememberSyncObject((char *)condPtr, &condRecord);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionFinalize --
 *
 *	Finalize a single condition variable and remove it from the list of
 *	remembered objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove the condition variable from the list.
 *
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471

472
473
474
475
476
477






478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493

494


495
496
497
498
499
500
501
502
503
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
 *	This procedure cleans up the thread-local storage.  This is
 *	called once for each thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up all thread local storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadData()
{
    int i;
    Tcl_ThreadDataKey *keyPtr;

    TclpMasterLock();
    for (i=0 ; i<keyRecord.num ; i++) {
	keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i];
#ifdef TCL_THREADS
#ifdef USE_THREAD_STORAGE
  TclFinalizeThreadStorageData(keyPtr);
#else
	TclpFinalizeThreadData(keyPtr);
#endif
#else
	if (*keyPtr != NULL) {
	    ckfree((char *)*keyPtr);
	    *keyPtr = NULL;
	}
#endif
    }
    TclpMasterUnlock();
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeSynchronization --
 *
 *      This procedure cleans up all synchronization objects:
 *      mutexes, condition variables, and thread-local storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up the memory.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeSynchronization()
{
#ifdef TCL_THREADS

    Tcl_ThreadDataKey *keyPtr;
    Tcl_Mutex *mutexPtr;
    Tcl_Condition *condPtr;
    int i;

    TclpMasterLock();






    for (i=0 ; i<keyRecord.num ; i++) {
	keyPtr = (Tcl_ThreadDataKey *)keyRecord.list[i];
#ifdef USE_THREAD_STORAGE
  TclFinalizeThreadStorageDataKey(keyPtr);
#else
	TclpFinalizeThreadDataKey(keyPtr);
#endif
    }
    if (keyRecord.list != NULL) {
	ckfree((char *)keyRecord.list);
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;

#ifdef USE_THREAD_STORAGE

    /* call platform specific thread storage master cleanup */


    TclFinalizeThreadStorage();
#endif

    for (i=0 ; i<mutexRecord.num ; i++) {
	mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
	if (mutexPtr != NULL) {
	    TclpFinalizeMutex(mutexPtr);
	}
    }







|
|













<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<







|
|














>






>
>
>
>
>
>


<
|
<
|
<








<
>
|
>
>

<







317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338










339









340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

378

379

380
381
382
383
384
385
386
387

388
389
390
391
392

393
394
395
396
397
398
399
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
 *	This function cleans up the thread-local storage. This is called once
 *	for each thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up all thread local storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadData()
{










    TclpFinalizeThreadDataThread();









}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeSynchronization --
 *
 *	This function cleans up all synchronization objects: mutexes,
 *	condition variables, and thread-local storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up the memory.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeSynchronization()
{
#ifdef TCL_THREADS
    void* blockPtr;
    Tcl_ThreadDataKey *keyPtr;
    Tcl_Mutex *mutexPtr;
    Tcl_Condition *condPtr;
    int i;

    TclpMasterLock();

    /* 
     * If we're running unthreaded, the TSD blocks are simply stored
     * inside their thread data keys.  Free them here.
     */

    for (i=0 ; i<keyRecord.num ; i++) {
	keyPtr = (Tcl_ThreadDataKey *)keyRecord.list[i];

	blockPtr = (void*) *keyPtr;

	ckfree(blockPtr);

    }
    if (keyRecord.list != NULL) {
	ckfree((char *)keyRecord.list);
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;


    /*
     * Call thread storage master cleanup.
     */

    TclFinalizeThreadStorage();


    for (i=0 ; i<mutexRecord.num ; i++) {
	mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
	if (mutexPtr != NULL) {
	    TclpFinalizeMutex(mutexPtr);
	}
    }
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
	ckfree((char *)condRecord.list);
	condRecord.list = NULL;
    }
    condRecord.max = 0;
    condRecord.num = 0;

    TclpMasterUnlock();
#else
    if (keyRecord.list != NULL) {
	ckfree((char *)keyRecord.list);
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;
#endif
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitThread --
 *
 *	This procedure is called to terminate the current thread.
 *	This should be used by extensions that create threads with
 *	additional interpreters in them.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	All thread exit handlers are invoked, then the thread dies.
 *







|






|








|
|
|







414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
	ckfree((char *)condRecord.list);
	condRecord.list = NULL;
    }
    condRecord.max = 0;
    condRecord.num = 0;

    TclpMasterUnlock();
#else /* TCL_THREADS */
    if (keyRecord.list != NULL) {
	ckfree((char *)keyRecord.list);
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;
#endif /* TCL_THREADS */
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitThread --
 *
 *	This function is called to terminate the current thread. This should
 *	be used by extensions that create threads with additional interpreters
 *	in them.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	All thread exit handlers are invoked, then the thread dies.
 *
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
#ifndef TCL_THREADS

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionWait, et al. --
 *
 *	These noop procedures are provided so the stub table does
 *	not have to be conditionalized for threads.  The real
 *	implementations of these functions live in the platform
 *	specific files.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|
|
|
<







460
461
462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
#ifndef TCL_THREADS

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionWait, et al. --
 *
 *	These noop functions are provided so the stub table does not have to
 *	be conditionalized for threads. The real implementations of these
 *	functions live in the platform specific files.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
607
608
609
610
611
612
613
614









#undef Tcl_MutexUnlock
void
Tcl_MutexUnlock(mutexPtr)
    Tcl_Mutex *mutexPtr;
{
}
#endif















|
>
>
>
>
>
>
>
>
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

#undef Tcl_MutexUnlock
void
Tcl_MutexUnlock(mutexPtr)
    Tcl_Mutex *mutexPtr;
{
}
#endif /* !TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclThreadAlloc.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
/*
 * tclThreadAlloc.c --
 *
 *	This is a very fast storage allocator for used with threads (designed
 *	avoid lock contention).  The basic strategy is to allocate memory in
 *	fixed size blocks from block caches.
 *
 * The Initial Developer of the Original Code is America Online, Inc.
 * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadAlloc.c,v 1.14 2004/07/21 01:45:44 hobbs Exp $
 */

#include "tclInt.h"
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * If range checking is enabled, an additional byte will be allocated
 * to store the magic number at the end of the requested memory.
 */

#ifndef RCHECK
#ifdef  NDEBUG
#define RCHECK		0
#else
#define RCHECK		1
#endif
#endif

/*
 * The following define the number of Tcl_Obj's to allocate/move
 * at a time and the high water mark to prune a per-thread cache.
 * On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
 */

#define NOBJALLOC	 800
#define NOBJHIGH	1200

/*
 * The following defines the number of buckets in the bucket
 * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS))
 */

#define NBUCKETS	  11
#define MAXALLOC	  16284

/*
 * The following union stores accounting information for
 * each block including two small magic numbers and
 * a bucket number when in use or a next pointer when
 * free.  The original requested size (not including
 * the Block overhead) is also maintained.
 */

typedef struct Block {
    union {
	struct Block *next;		/* Next in free list. */
	struct {
	    unsigned char magic1;	/* First magic number. */
	    unsigned char bucket;	/* Bucket block allocated from. */
	    unsigned char unused;	/* Padding. */
	    unsigned char magic2;	/* Second magic number. */
	} s;
    } u;
    size_t reqSize;			/* Requested allocation size. */
} Block;
#define nextBlock	u.next
#define sourceBucket	u.s.bucket
#define magicNum1	u.s.magic1
#define magicNum2	u.s.magic2
#define MAGIC		0xEF

/*
 * The following structure defines a bucket of blocks with
 * various accounting and statistics information.
 */

typedef struct Bucket {
    Block *firstPtr;			/* First block available */
    int numFree;			/* Number of blocks available */

    /* All fields below for accounting only */

    int numRemoves;			/* Number of removes from bucket */
    int numInserts;			/* Number of inserts into bucket */
    int numWaits;			/* Number of waits to acquire a lock */
    int numLocks;			/* Number of locks acquired */
    int totalAssigned;			/* Total space assigned to bucket */
} Bucket;

/*
 * The following structure defines a cache of buckets and objs, of
 * which there will be (at most) one per thread.
 */

typedef struct Cache {
    struct Cache *nextPtr;		/* Linked list of cache entries */
    Tcl_ThreadId owner;			/* Which thread's cache is this? */
    Tcl_Obj *firstObjPtr;		/* List of free objects for thread */
    int numObjects;			/* Number of objects for thread */
    int totalAssigned;			/* Total space assigned to thread */
    Bucket buckets[NBUCKETS];		/* The buckets for this thread */
} Cache;

/*
 * The following array specifies various per-bucket limits and locks.
 * The values are statically initialized to avoid calculating them
 * repeatedly.
 */

static struct {
    size_t blockSize;			/* Bucket blocksize. */
    int maxBlocks;			/* Max blocks before move to share. */
    int numMove;			/* Num blocks to move to share. */
    Tcl_Mutex *lockPtr;			/* Share bucket lock. */
} bucketInfo[NBUCKETS] = {
    {   16, 1024, 512, NULL},
    {   32,  512, 256, NULL},
    {   64,  256, 128, NULL},
    {  128,  128,  64, NULL},
    {  256,   64,  32, NULL},
    {  512,   32,  16, NULL},




|





|
|

|






|
|











|
|
|


|



|
|


|
|


|
<
|
|
|




|







|








|
|



|
|



|
|
|
|
|



|
|



|
|
|
|
|
|



|
|
<



|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109

110
111
112
113
114
115
116
117
118
119
120
121
122
123
/*
 * tclThreadAlloc.c --
 *
 *	This is a very fast storage allocator for used with threads (designed
 *	avoid lock contention). The basic strategy is to allocate memory in
 *	fixed size blocks from block caches.
 *
 * The Initial Developer of the Original Code is America Online, Inc.
 * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadAlloc.c,v 1.14.2.2 2005/08/02 18:16:10 dgp Exp $
 */

#include "tclInt.h"
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * If range checking is enabled, an additional byte will be allocated to store
 * the magic number at the end of the requested memory.
 */

#ifndef RCHECK
#ifdef  NDEBUG
#define RCHECK		0
#else
#define RCHECK		1
#endif
#endif

/*
 * The following define the number of Tcl_Obj's to allocate/move at a time and
 * the high water mark to prune a per-thread cache. On a 32 bit system,
 * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
 */

#define NOBJALLOC	800
#define NOBJHIGH	1200

/*
 * The following defines the number of buckets in the bucket cache and those
 * block sizes from (1<<4) to (1<<(3+NBUCKETS))
 */

#define NBUCKETS	11
#define MAXALLOC	16284

/*
 * The following union stores accounting information for each block including

 * two small magic numbers and a bucket number when in use or a next pointer
 * when free. The original requested size (not including the Block overhead)
 * is also maintained.
 */

typedef struct Block {
    union {
	struct Block *next;	/* Next in free list. */
	struct {
	    unsigned char magic1;	/* First magic number. */
	    unsigned char bucket;	/* Bucket block allocated from. */
	    unsigned char unused;	/* Padding. */
	    unsigned char magic2;	/* Second magic number. */
	} s;
    } u;
    size_t reqSize;		/* Requested allocation size. */
} Block;
#define nextBlock	u.next
#define sourceBucket	u.s.bucket
#define magicNum1	u.s.magic1
#define magicNum2	u.s.magic2
#define MAGIC		0xEF

/*
 * The following structure defines a bucket of blocks with various accounting
 * and statistics information.
 */

typedef struct Bucket {
    Block *firstPtr;		/* First block available */
    int numFree;		/* Number of blocks available */

    /* All fields below for accounting only */

    int numRemoves;		/* Number of removes from bucket */
    int numInserts;		/* Number of inserts into bucket */
    int numWaits;		/* Number of waits to acquire a lock */
    int numLocks;		/* Number of locks acquired */
    int totalAssigned;		/* Total space assigned to bucket */
} Bucket;

/*
 * The following structure defines a cache of buckets and objs, of which there
 * will be (at most) one per thread.
 */

typedef struct Cache {
    struct Cache *nextPtr;	/* Linked list of cache entries */
    Tcl_ThreadId owner;		/* Which thread's cache is this? */
    Tcl_Obj *firstObjPtr;	/* List of free objects for thread */
    int numObjects;		/* Number of objects for thread */
    int totalAssigned;		/* Total space assigned to thread */
    Bucket buckets[NBUCKETS];	/* The buckets for this thread */
} Cache;

/*
 * The following array specifies various per-bucket limits and locks. The
 * values are statically initialized to avoid calculating them repeatedly.

 */

static struct {
    size_t blockSize;		/* Bucket blocksize. */
    int maxBlocks;		/* Max blocks before move to share. */
    int numMove;		/* Num blocks to move to share. */
    Tcl_Mutex *lockPtr;		/* Share bucket lock. */
} bucketInfo[NBUCKETS] = {
    {   16, 1024, 512, NULL},
    {   32,  512, 256, NULL},
    {   64,  256, 128, NULL},
    {  128,  128,  64, NULL},
    {  256,   64,  32, NULL},
    {  512,   32,  16, NULL},
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
static Block *	Ptr2Block _ANSI_ARGS_((char *ptr));
static char *	Block2Ptr _ANSI_ARGS_((Block *blockPtr, int bucket,
		    unsigned int reqSize));
static void	MoveObjs _ANSI_ARGS_((Cache *fromPtr, Cache *toPtr,
		    int numMove));

/*
 * Local variables defined in this file and initialized at
 * startup.
 */

static Tcl_Mutex *listLockPtr;
static Tcl_Mutex *objLockPtr;
static Cache sharedCache;
static Cache *sharedPtr = &sharedCache;
static Cache *firstCachePtr = &sharedCache;







|
<







140
141
142
143
144
145
146
147

148
149
150
151
152
153
154
static Block *	Ptr2Block _ANSI_ARGS_((char *ptr));
static char *	Block2Ptr _ANSI_ARGS_((Block *blockPtr, int bucket,
		    unsigned int reqSize));
static void	MoveObjs _ANSI_ARGS_((Cache *fromPtr, Cache *toPtr,
		    int numMove));

/*
 * Local variables defined in this file and initialized at startup.

 */

static Tcl_Mutex *listLockPtr;
static Tcl_Mutex *objLockPtr;
static Cache sharedCache;
static Cache *sharedPtr = &sharedCache;
static Cache *firstCachePtr = &sharedCache;
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
    size_t size;

    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * Increment the requested size to include room for
     * the Block structure.  Call malloc() directly if the
     * required amount is greater than the largest block,
     * otherwise pop the smallest block large enough,
     * allocating more blocks if necessary.
     */

    blockPtr = NULL;
    size = reqSize + sizeof(Block);
#if RCHECK
    ++size;







|
<
|
|







299
300
301
302
303
304
305
306

307
308
309
310
311
312
313
314
315
    size_t size;

    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * Increment the requested size to include room for the Block structure.

     * Call malloc() directly if the required amount is greater than the
     * largest block, otherwise pop the smallest block large enough,
     * allocating more blocks if necessary.
     */

    blockPtr = NULL;
    size = reqSize + sizeof(Block);
#if RCHECK
    ++size;
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392

393
394
395
396
397

398
399
400
401
402
403
404

    cachePtr = TclpGetAllocCache();
    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * Get the block back from the user pointer and call system free
     * directly for large blocks.  Otherwise, push the block back on
     * the bucket and move blocks to the shared cache if there are now
     * too many free.
     */

    blockPtr = Ptr2Block(ptr);
    bucket = blockPtr->sourceBucket;
    if (bucket == NBUCKETS) {
	cachePtr->totalAssigned -= blockPtr->reqSize;
	free(blockPtr);
	return;
    }

    cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize;
    blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
    cachePtr->buckets[bucket].firstPtr = blockPtr;
    ++cachePtr->buckets[bucket].numFree;
    ++cachePtr->buckets[bucket].numInserts;

    if (cachePtr != sharedPtr &&
	    cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
	PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove);
    }
}

/*







|
|
|
<









>





>







369
370
371
372
373
374
375
376
377
378

379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401

    cachePtr = TclpGetAllocCache();
    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * Get the block back from the user pointer and call system free directly
     * for large blocks. Otherwise, push the block back on the bucket and move
     * blocks to the shared cache if there are now too many free.

     */

    blockPtr = Ptr2Block(ptr);
    bucket = blockPtr->sourceBucket;
    if (bucket == NBUCKETS) {
	cachePtr->totalAssigned -= blockPtr->reqSize;
	free(blockPtr);
	return;
    }

    cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize;
    blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
    cachePtr->buckets[bucket].firstPtr = blockPtr;
    ++cachePtr->buckets[bucket].numFree;
    ++cachePtr->buckets[bucket].numInserts;

    if (cachePtr != sharedPtr &&
	    cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
	PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove);
    }
}

/*
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
    }

    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * If the block is not a system block and fits in place,
     * simply return the existing pointer.  Otherwise, if the block
     * is a system block and the new size would also require a system
     * block, call realloc() directly.
     */

    blockPtr = Ptr2Block(ptr);
    size = reqSize + sizeof(Block);
#if RCHECK
    ++size;
#endif







|
<
|
|







430
431
432
433
434
435
436
437

438
439
440
441
442
443
444
445
446
    }

    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * If the block is not a system block and fits in place, simply return the

     * existing pointer. Otherwise, if the block is a system block and the new
     * size would also require a system block, call realloc() directly.
     */

    blockPtr = Ptr2Block(ptr);
    size = reqSize + sizeof(Block);
#if RCHECK
    ++size;
#endif
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522


523
524
525
526
527
528
529
530
531
532


533
534
535
536
537
538
539
 *
 *	Allocate a Tcl_Obj from the per-thread cache.
 *
 * Results:
 *	Pointer to uninitialized Tcl_Obj.
 *
 * Side effects:
 *	May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's
 *	if list is empty.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclThreadAllocObj(void)
{
    register Cache *cachePtr = TclpGetAllocCache();
    register int numMove;
    register Tcl_Obj *objPtr;
    Tcl_Obj *newObjsPtr;

    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * Get this thread's obj list structure and move
     * or allocate new objs if necessary.
     */

    if (cachePtr->numObjects == 0) {


	Tcl_MutexLock(objLockPtr);
	numMove = sharedPtr->numObjects;
	if (numMove > 0) {
	    if (numMove > NOBJALLOC) {
		numMove = NOBJALLOC;
	    }
	    MoveObjs(sharedPtr, cachePtr, numMove);
	}
	Tcl_MutexUnlock(objLockPtr);
	if (cachePtr->numObjects == 0) {


	    cachePtr->numObjects = numMove = NOBJALLOC;
	    newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove);
	    if (newObjsPtr == NULL) {
		Tcl_Panic("alloc: could not allocate %d new objects", numMove);
	    }
	    while (--numMove >= 0) {
		objPtr = &newObjsPtr[numMove];







|
|








<

<






|
|



>
>










>
>







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504

505

506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
 *
 *	Allocate a Tcl_Obj from the per-thread cache.
 *
 * Results:
 *	Pointer to uninitialized Tcl_Obj.
 *
 * Side effects:
 *	May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if
 *	list is empty.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclThreadAllocObj(void)
{
    register Cache *cachePtr = TclpGetAllocCache();

    register Tcl_Obj *objPtr;


    if (cachePtr == NULL) {
	cachePtr = GetCache();
    }

    /*
     * Get this thread's obj list structure and move or allocate new objs if
     * necessary.
     */

    if (cachePtr->numObjects == 0) {
	register int numMove;

	Tcl_MutexLock(objLockPtr);
	numMove = sharedPtr->numObjects;
	if (numMove > 0) {
	    if (numMove > NOBJALLOC) {
		numMove = NOBJALLOC;
	    }
	    MoveObjs(sharedPtr, cachePtr, numMove);
	}
	Tcl_MutexUnlock(objLockPtr);
	if (cachePtr->numObjects == 0) {
	    Tcl_Obj *newObjsPtr;

	    cachePtr->numObjects = numMove = NOBJALLOC;
	    newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove);
	    if (newObjsPtr == NULL) {
		Tcl_Panic("alloc: could not allocate %d new objects", numMove);
	    }
	    while (--numMove >= 0) {
		objPtr = &newObjsPtr[numMove];
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
 *
 *	Return a free Tcl_Obj to the per-thread cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May move free Tcl_Obj's to shared list upon hitting high
 *	water mark.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadFreeObj(objPtr)
    Tcl_Obj *objPtr;







|
<







558
559
560
561
562
563
564
565

566
567
568
569
570
571
572
 *
 *	Return a free Tcl_Obj to the per-thread cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May move free Tcl_Obj's to shared list upon hitting high water mark.

 *
 *----------------------------------------------------------------------
 */

void
TclThreadFreeObj(objPtr)
    Tcl_Obj *objPtr;
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
     */

    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
    cachePtr->firstObjPtr = objPtr;
    ++cachePtr->numObjects;

    /*
     * If the number of free objects has exceeded the high
     * water mark, move some blocks to the shared list.
     */

    if (cachePtr->numObjects > NOBJHIGH) {
	Tcl_MutexLock(objLockPtr);
	MoveObjs(cachePtr, sharedPtr, NOBJALLOC);
	Tcl_MutexUnlock(objLockPtr);
    }







|
|







582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
     */

    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
    cachePtr->firstObjPtr = objPtr;
    ++cachePtr->numObjects;

    /*
     * If the number of free objects has exceeded the high water mark, move
     * some blocks to the shared list.
     */

    if (cachePtr->numObjects > NOBJHIGH) {
	Tcl_MutexLock(objLockPtr);
	MoveObjs(cachePtr, sharedPtr, NOBJALLOC);
	Tcl_MutexUnlock(objLockPtr);
    }
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
    register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
    Tcl_Obj *fromFirstObjPtr = objPtr;

    toPtr->numObjects += numMove;
    fromPtr->numObjects -= numMove;

    /*
     * Find the last object to be moved; set the next one
     * (the first one not to be moved) as the first object
     * in the 'from' cache.
     */

    while (--numMove) {
	objPtr = objPtr->internalRep.otherValuePtr;
    }
    fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;

    /*
     * Move all objects as a block - they are already linked to
     * each other, we just have to update the first and last.
     */

    objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
    toPtr->firstObjPtr = fromFirstObjPtr;
}

/*







|
|
<








|
|







672
673
674
675
676
677
678
679
680

681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
    register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
    Tcl_Obj *fromFirstObjPtr = objPtr;

    toPtr->numObjects += numMove;
    fromPtr->numObjects -= numMove;

    /*
     * Find the last object to be moved; set the next one (the first one not
     * to be moved) as the first object in the 'from' cache.

     */

    while (--numMove) {
	objPtr = objPtr->internalRep.otherValuePtr;
    }
    fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;

    /*
     * Move all objects as a block - they are already linked to each other, we
     * just have to update the first and last.
     */

    objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
    toPtr->firstObjPtr = fromFirstObjPtr;
}

/*
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
 *
 *	Set/unset the lock to access a bucket in the shared cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Lock activity and contention are monitored globally and on
 *	a per-cache basis.
 *
 *----------------------------------------------------------------------
 */

static void
LockBucket(cachePtr, bucket)
    Cache *cachePtr;







|
|







756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
 *
 *	Set/unset the lock to access a bucket in the shared cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Lock activity and contention are monitored globally and on a per-cache
 *	basis.
 *
 *----------------------------------------------------------------------
 */

static void
LockBucket(cachePtr, bucket)
    Cache *cachePtr;
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
    Cache *cachePtr;
    int bucket, numMove;
{
    register Block *lastPtr, *firstPtr;
    register int n = numMove;

    /*
     * Before acquiring the lock, walk the block list to find
     * the last block to be moved.
     */

    firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
    while (--n > 0) {
	lastPtr = lastPtr->nextBlock;
    }
    cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock;
    cachePtr->buckets[bucket].numFree -= numMove;

    /*
     * Aquire the lock and place the list of blocks at the front
     * of the shared cache bucket.
     */

    LockBucket(cachePtr, bucket);
    lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr;
    sharedPtr->buckets[bucket].firstPtr = firstPtr;
    sharedPtr->buckets[bucket].numFree += numMove;
    UnlockBucket(cachePtr, bucket);







|
|










|
|







813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
    Cache *cachePtr;
    int bucket, numMove;
{
    register Block *lastPtr, *firstPtr;
    register int n = numMove;

    /*
     * Before acquiring the lock, walk the block list to find the last block
     * to be moved.
     */

    firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
    while (--n > 0) {
	lastPtr = lastPtr->nextBlock;
    }
    cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock;
    cachePtr->buckets[bucket].numFree -= numMove;

    /*
     * Aquire the lock and place the list of blocks at the front of the shared
     * cache bucket.
     */

    LockBucket(cachePtr, bucket);
    lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr;
    sharedPtr->buckets[bucket].firstPtr = firstPtr;
    sharedPtr->buckets[bucket].numFree += numMove;
    UnlockBucket(cachePtr, bucket);
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
static int
GetBlocks(cachePtr, bucket)
    Cache *cachePtr;
    int bucket;
{
    register Block *blockPtr;
    register int n;
    register size_t size;

    /*
     * First, atttempt to move blocks from the shared cache.  Note
     * the potentially dirty read of numFree before acquiring the lock
     * which is a slight performance enhancement.  The value is
     * verified after the lock is actually acquired.
     */

    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
	LockBucket(cachePtr, bucket);
	if (sharedPtr->buckets[bucket].numFree > 0) {

	    /*
	     * Either move the entire list or walk the list to find
	     * the last block to move.
	     */

	    n = bucketInfo[bucket].numMove;
	    if (n >= sharedPtr->buckets[bucket].numFree) {
		cachePtr->buckets[bucket].firstPtr =
			sharedPtr->buckets[bucket].firstPtr;
		cachePtr->buckets[bucket].numFree =







<


|
|
|
|







|
|







859
860
861
862
863
864
865

866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
static int
GetBlocks(cachePtr, bucket)
    Cache *cachePtr;
    int bucket;
{
    register Block *blockPtr;
    register int n;


    /*
     * First, atttempt to move blocks from the shared cache. Note the
     * potentially dirty read of numFree before acquiring the lock which is a
     * slight performance enhancement. The value is verified after the lock is
     * actually acquired.
     */

    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
	LockBucket(cachePtr, bucket);
	if (sharedPtr->buckets[bucket].numFree > 0) {

	    /*
	     * Either move the entire list or walk the list to find the last
	     * block to move.
	     */

	    n = bucketInfo[bucket].numMove;
	    if (n >= sharedPtr->buckets[bucket].numFree) {
		cachePtr->buckets[bucket].firstPtr =
			sharedPtr->buckets[bucket].firstPtr;
		cachePtr->buckets[bucket].numFree =
905
906
907
908
909
910
911

912
913
914
915
916
917
918
919
920
921
922
		blockPtr->nextBlock = NULL;
	    }
	}
	UnlockBucket(cachePtr, bucket);
    }

    if (cachePtr->buckets[bucket].numFree == 0) {


	/*
	 * If no blocks could be moved from shared, first look for a
	 * larger block in this cache to split up.
	 */

	blockPtr = NULL;
	n = NBUCKETS;
	size = 0; /* lint */
	while (--n > bucket) {
	    if (cachePtr->buckets[n].numFree > 0) {







>


|
|







900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
		blockPtr->nextBlock = NULL;
	    }
	}
	UnlockBucket(cachePtr, bucket);
    }

    if (cachePtr->buckets[bucket].numFree == 0) {
	register size_t size;

	/*
	 * If no blocks could be moved from shared, first look for a larger
	 * block in this cache to split up.
	 */

	blockPtr = NULL;
	n = NBUCKETS;
	size = 0; /* lint */
	while (--n > bucket) {
	    if (cachePtr->buckets[n].numFree > 0) {
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990


991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016

1017
1018






}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadAlloc --
 *
 *	This procedure is used to destroy all private resources used in
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadAlloc()
{
    int i;
    for (i = 0; i < NBUCKETS; ++i) {
        TclpFreeAllocMutex(bucketInfo[i].lockPtr); 
        bucketInfo[i].lockPtr = NULL;
    }

    TclpFreeAllocMutex(objLockPtr);
    objLockPtr = NULL;

    TclpFreeAllocMutex(listLockPtr);
    listLockPtr = NULL;


}

#else

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadAlloc --
 *
 *	This procedure is used to destroy all private resources used in
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadAlloc()
{
    Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use.");
}


#endif /* TCL_THREADS */













|
|















|








>
>



<





|
|















>
|
|
>
>
>
>
>
>
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991

992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadAlloc --
 *
 *	This procedure is used to destroy all private resources used in this
 *	file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadAlloc()
{
    int i;
    for (i = 0; i < NBUCKETS; ++i) {
        TclpFreeAllocMutex(bucketInfo[i].lockPtr);
        bucketInfo[i].lockPtr = NULL;
    }

    TclpFreeAllocMutex(objLockPtr);
    objLockPtr = NULL;

    TclpFreeAllocMutex(listLockPtr);
    listLockPtr = NULL;

    TclpFreeAllocCache(NULL);
}

#else

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadAlloc --
 *
 *	This procedure is used to destroy all private resources used in this
 *	file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadAlloc()
{
    Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use.");
}
#endif /* TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclThreadJoin.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88



89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

114

115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
130
131

132
133
134
135
136
137
138
139
140
141
142
143

144
145
146
147
148
149
150
151
152

153
154
155
156
157
158
159
160
161
162
163
164

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

187
188
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

284

285
286
287
288
289
290
291

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309

310
311






/* 
 * tclThreadJoin.c --
 *
 *	This file implements a platform independent emulation layer for
 *	the handling of joinable threads. The Windows platform
 *	uses this code to provide the functionality of joining threads.
 *	This code is currently not necessary on Unix.
 *
 * Copyright (c) 2000 by Scriptics Corporation
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadJoin.c,v 1.5 2004/03/17 18:14:14 das Exp $
 */

#include "tclInt.h"

#if defined(WIN32)


/* The information about each joinable thread is remembered in a
 * structure as defined below.
 */

typedef struct JoinableThread {
  Tcl_ThreadId  id;                     /* The id of the joinable thread */
  int           result;                 /* A place for the result after the
					 * demise of the thread */
  int           done;                   /* Boolean flag. Initialized to 0
					 * and set to 1 after the exit of
					 * the thread. This allows a thread
					 * requesting a join to detect when
					 * waiting is not necessary. */
  int           waitedUpon;             /* Boolean flag. Initialized to 0
					 * and set to 1 by the thread waiting
					 * for this one via Tcl_JoinThread.
					 * Used to lock any other thread
					 * trying to wait on this one.
					 */
  Tcl_Mutex     threadMutex;            /* The mutex used to serialize access
					 * to this structure. */
  Tcl_Condition cond;                   /* This is the condition a thread has
					 * to wait upon to get notified of the
					 * end of the described thread. It is
					 * signaled indirectly by
					 * Tcl_ExitThread. */

  struct JoinableThread* nextThreadPtr; /* Reference to the next thread in the
					 * list of joinable threads */
} JoinableThread;


/* The following variable is used to maintain the global list of all
 * joinable threads. Usage by a thread is allowed only if the
 * thread acquired the 'joinMutex'.
 */

TCL_DECLARE_MUTEX(joinMutex)

static JoinableThread* firstThreadPtr;



/*
 *----------------------------------------------------------------------
 *
 * TclJoinThread --
 *
 *	This procedure waits for the exit of the thread with the specified
 *	id and returns its result.
 *
 * Results:
 *	A standard tcl result signaling the overall success/failure of the
 *	operation and an integer result delivered by the thread which was
 *	waited upon.
 *
 * Side effects:
 *	Deallocates the memory allocated by TclRememberJoinableThread.
 *	Removes the data associated to the thread waited upon from the
 *	list of joinable threads.
 *
 *----------------------------------------------------------------------
 */

int
TclJoinThread(id, result)
    Tcl_ThreadId id;     /* The id of the thread to wait upon. */
    int*         result; /* Reference to a location for the result
			  * of the thread we are waiting upon. */
{



    /* Steps done here:
     * i.    Acquire the joinMutex and search for the thread.
     * ii.   Error out if it could not be found.
     * iii.  If found, switch from exclusive access to the list to exclusive
     *       access to the thread structure.
     * iv.   Error out if some other is already waiting.
     * v.    Skip the waiting part of the thread is already done.
     * vi.   Wait for the thread to exit, mark it as waited upon too.
     * vii.  Get the result form the structure, 
     * viii. switch to exclusive access of the list,
     * ix.   remove the structure from the list,
     * x.    then switch back to exclusive access to the structure
     * xi.   and delete it.
     */

    JoinableThread* threadPtr;

    Tcl_MutexLock (&joinMutex);

    for (threadPtr = firstThreadPtr;
	 (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id);
	 threadPtr = threadPtr->nextThreadPtr)
        /* empty body */
      ;


    if (threadPtr == (JoinableThread*) NULL) {

        /* Thread not found. Either not joinable, or already waited
	 * upon and exited. Whatever, an error is in order.
	 */

      Tcl_MutexUnlock (&joinMutex);
      return TCL_ERROR;
    }


    /* [1] If we don't lock the structure before giving up exclusive access
     * to the list some other thread just completing its wait on the same
     * thread can delete the structure from under us, leaving us with a
     * dangling pointer.
     */

    Tcl_MutexLock   (&threadPtr->threadMutex);
    Tcl_MutexUnlock (&joinMutex);


    /* [2] Now that we have the structure mutex any other thread that just
     * tries to delete structure will wait at location [3] until we are
     * done with the structure. And in that case we are done with it
     * rather quickly as 'waitedUpon' will be set and we will have to
     * error out.
     */

    if (threadPtr->waitedUpon) {
        Tcl_MutexUnlock (&threadPtr->threadMutex);
	return TCL_ERROR;
    }


    /* We are waiting now, let other threads recognize this
     */

    threadPtr->waitedUpon = 1;

    while (!threadPtr->done) {
      Tcl_ConditionWait (&threadPtr->cond, &threadPtr->threadMutex, NULL);
    }


    /* We have to release the structure before trying to access the list
     * again or we can run into deadlock with a thread at [1] (see above)
     * because of us holding the structure and the other holding the list.
     * There is no problem with dangling pointers here as 'waitedUpon == 1'
     * is still valid and any other thread will error out and not come to
     * this place. IOW, the fact that we are here also means that no other
     * thread came here before us and is able to delete the structure.
     */

    Tcl_MutexUnlock (&threadPtr->threadMutex);
    Tcl_MutexLock   (&joinMutex);


    /* We have to search the list again as its structure may (may, almost
     * certainly) have changed while we were waiting. Especially now is the
     * time to compute the predecessor in the list. Any earlier result can
     * be dangling by now.
     */

    if (firstThreadPtr == threadPtr) {
        firstThreadPtr = threadPtr->nextThreadPtr;
    } else {
        JoinableThread* prevThreadPtr;

	for (prevThreadPtr = firstThreadPtr;
	     prevThreadPtr->nextThreadPtr != threadPtr;
	     prevThreadPtr = prevThreadPtr->nextThreadPtr)
	    /* empty body */
	  ;

	prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr;
    }

    Tcl_MutexUnlock (&joinMutex);


    /* [3] Now that the structure is not part of the list anymore no other
     * thread can acquire its mutex from now on. But it is possible that
     * another thread is still holding the mutex though, see location [2].
     * So we have to acquire the mutex one more time to wait for that thread
     * to finish. We can (and have to) release the mutex immediately.
     */

    Tcl_MutexLock   (&threadPtr->threadMutex);
    Tcl_MutexUnlock (&threadPtr->threadMutex);


    /* Copy the result to us, finalize the synchronisation objects, then
     * free the structure and return.
     */

    *result = threadPtr->result;

    Tcl_ConditionFinalize (&threadPtr->cond);
    Tcl_MutexFinalize (&threadPtr->threadMutex);
    ckfree ((VOID*) threadPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberJoinableThread --
 *
 *	This procedure remebers a thread as joinable. Only a call to
 *	TclJoinThread will remove the structre created (and initialized)
 *	here. IOW, not waiting upon a joinable thread will cause memory
 *	leaks.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory, adds it to the global list of all joinable
 *	threads.
 *
 *----------------------------------------------------------------------
 */

VOID
TclRememberJoinableThread(id)
    Tcl_ThreadId id; /* The thread to remember as joinable */
{
    JoinableThread* threadPtr;

    threadPtr = (JoinableThread*) ckalloc (sizeof (JoinableThread));
    threadPtr->id          = id;
    threadPtr->done        = 0;
    threadPtr->waitedUpon  = 0;
    threadPtr->threadMutex = (Tcl_Mutex) NULL;
    threadPtr->cond        = (Tcl_Condition) NULL;

    Tcl_MutexLock (&joinMutex);

    threadPtr->nextThreadPtr = firstThreadPtr;
    firstThreadPtr           = threadPtr;

    Tcl_MutexUnlock (&joinMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSignalExitThread --
 *
 *	This procedure signals that the specified thread is done with
 *	its work. If the thread is joinable this signal is propagated
 *	to the thread waiting upon it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the associated structure to hold the result.
 *
 *----------------------------------------------------------------------
 */

VOID
TclSignalExitThread(id,result)
    Tcl_ThreadId id;     /* Id of the thread signaling its exit */
    int          result; /* The result from the thread */
{
    JoinableThread* threadPtr;

    Tcl_MutexLock (&joinMutex);

    for (threadPtr = firstThreadPtr;
	 (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id);
	 threadPtr = threadPtr->nextThreadPtr)
        /* empty body */
      ;


    if (threadPtr == (JoinableThread*) NULL) {

        /* Thread not found. Not joinable. No problem, nothing to do.
	 */

        Tcl_MutexUnlock (&joinMutex);
	return;
    }


    /* Switch over the exclusive access from the list to the structure,
     * then store the result, set the flag and notify the waiting thread,
     * provided that it exists. The order of lock/unlock ensures that a
     * thread entering 'TclJoinThread' will not interfere with us.
     */

    Tcl_MutexLock   (&threadPtr->threadMutex);
    Tcl_MutexUnlock (&joinMutex);

    threadPtr->done   = 1;
    threadPtr->result = result;

    if (threadPtr->waitedUpon) {
      Tcl_ConditionNotify (&threadPtr->cond);
    }

    Tcl_MutexUnlock (&threadPtr->threadMutex);
}


#endif /* WIN32 */






|


|
|
|
|



|
|

|




|

>
|
|



|
|
|
|
<
|
|
|
|
|
<
|
|
<
|
|
|
|
|
<
|
>
|
|


>
|
|
|





<
<






|
|








|
|






|
|
|

>
>
>
|



|



|






<
<
|

|
|
|
<
<
|
>
|
>
|
|


|
|


>
|
|
|
|


|
|

>
|
|
|
|
<



|



>
|





|


>
|
|
|
|
|
|
|


|
|

>
|

|
|



|

|

<
|
|
<
<
|



|

>
|

|
|
|


|
|

>
|
|




|
|
|










|
|
<





|
<








|

|
|
|
|

|

|


|

|







|
|
|












|
|

|

|

|
|
|
<
<
|
>
|
>
|


|



>
|
|
|
|


|
|

|



|


|

>
|
|
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

31
32
33
34
35

36
37

38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57


58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103


104
105
106
107
108


109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177

178
179


180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218

219
220
221
222
223
224

225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279


280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
/*
 * tclThreadJoin.c --
 *
 *	This file implements a platform independent emulation layer for the
 *	handling of joinable threads. The Windows platform uses this code to
 *	provide the functionality of joining threads.  This code is currently
 *	not necessary on Unix.
 *
 * Copyright (c) 2000 by Scriptics Corporation
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadJoin.c,v 1.5.2.1 2005/08/02 18:16:10 dgp Exp $
 */

#include "tclInt.h"

#ifdef WIN32

/*
 * The information about each joinable thread is remembered in a structure as
 * defined below.
 */

typedef struct JoinableThread {
    Tcl_ThreadId  id;		/* The id of the joinable thread. */
    int result;			/* A place for the result after the demise of
				 * the thread. */
    int done;			/* Boolean flag. Initialized to 0 and set to 1

				 * after the exit of the thread. This allows a
				 * thread requesting a join to detect when
				 * waiting is not necessary. */
    int waitedUpon;		/* Boolean flag. Initialized to 0 and set to 1
				 * by the thread waiting for this one via

				 * Tcl_JoinThread.  Used to lock any other
				 * thread trying to wait on this one. */

    Tcl_Mutex threadMutex;	/* The mutex used to serialize access to this
				 * structure. */
    Tcl_Condition cond;		/* This is the condition a thread has to wait
				 * upon to get notified of the end of the
				 * described thread. It is signaled indirectly

				 * by Tcl_ExitThread. */
    struct JoinableThread *nextThreadPtr;
				/* Reference to the next thread in the list of
				 * joinable threads. */
} JoinableThread;

/*
 * The following variable is used to maintain the global list of all joinable
 * threads. Usage by a thread is allowed only if the thread acquired the
 * 'joinMutex'.
 */

TCL_DECLARE_MUTEX(joinMutex)

static JoinableThread* firstThreadPtr;



/*
 *----------------------------------------------------------------------
 *
 * TclJoinThread --
 *
 *	This procedure waits for the exit of the thread with the specified id
 *	and returns its result.
 *
 * Results:
 *	A standard tcl result signaling the overall success/failure of the
 *	operation and an integer result delivered by the thread which was
 *	waited upon.
 *
 * Side effects:
 *	Deallocates the memory allocated by TclRememberJoinableThread.
 *	Removes the data associated to the thread waited upon from the list of
 *	joinable threads.
 *
 *----------------------------------------------------------------------
 */

int
TclJoinThread(id, result)
    Tcl_ThreadId id;		/* The id of the thread to wait upon. */
    int *result;		/* Reference to a location for the result of
				 * the thread we are waiting upon. */
{
    JoinableThread *threadPtr;

    /*
     * Steps done here:
     * i.    Acquire the joinMutex and search for the thread.
     * ii.   Error out if it could not be found.
     * iii.  If found, switch from exclusive access to the list to exclusive
     *	     access to the thread structure.
     * iv.   Error out if some other is already waiting.
     * v.    Skip the waiting part of the thread is already done.
     * vi.   Wait for the thread to exit, mark it as waited upon too.
     * vii.  Get the result form the structure,
     * viii. switch to exclusive access of the list,
     * ix.   remove the structure from the list,
     * x.    then switch back to exclusive access to the structure
     * xi.   and delete it.
     */



    Tcl_MutexLock(&joinMutex);

    threadPtr = firstThreadPtr;
    while (threadPtr!=NULL && threadPtr->id!=id) {
	threadPtr = threadPtr->nextThreadPtr;


    }

    if (threadPtr == NULL) {
	/*
	 * Thread not found. Either not joinable, or already waited upon and
	 * exited. Whatever, an error is in order.
	 */

	Tcl_MutexUnlock(&joinMutex);
	return TCL_ERROR;
    }

    /*
     * [1] If we don't lock the structure before giving up exclusive access to
     * the list some other thread just completing its wait on the same thread
     * can delete the structure from under us, leaving us with a dangling
     * pointer.
     */

    Tcl_MutexLock(&threadPtr->threadMutex);
    Tcl_MutexUnlock(&joinMutex);

    /*
     * [2] Now that we have the structure mutex any other thread that just
     * tries to delete structure will wait at location [3] until we are done
     * with the structure. And in that case we are done with it rather quickly
     * as 'waitedUpon' will be set and we will have to error out.

     */

    if (threadPtr->waitedUpon) {
	Tcl_MutexUnlock(&threadPtr->threadMutex);
	return TCL_ERROR;
    }

    /*
     * We are waiting now, let other threads recognize this.
     */

    threadPtr->waitedUpon = 1;

    while (!threadPtr->done) {
	Tcl_ConditionWait(&threadPtr->cond, &threadPtr->threadMutex, NULL);
    }

    /*
     * We have to release the structure before trying to access the list again
     * or we can run into deadlock with a thread at [1] (see above) because of
     * us holding the structure and the other holding the list.  There is no
     * problem with dangling pointers here as 'waitedUpon == 1' is still valid
     * and any other thread will error out and not come to this place. IOW,
     * the fact that we are here also means that no other thread came here
     * before us and is able to delete the structure.
     */

    Tcl_MutexUnlock(&threadPtr->threadMutex);
    Tcl_MutexLock(&joinMutex);

    /*
     * We have to search the list again as its structure may (may, almost
     * certainly) have changed while we were waiting. Especially now is the
     * time to compute the predecessor in the list. Any earlier result can be
     * dangling by now.
     */

    if (firstThreadPtr == threadPtr) {
	firstThreadPtr = threadPtr->nextThreadPtr;
    } else {
	JoinableThread *prevThreadPtr = firstThreadPtr;


	while (prevThreadPtr->nextThreadPtr != threadPtr) {
	    prevThreadPtr = prevThreadPtr->nextThreadPtr;


	}
	prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr;
    }

    Tcl_MutexUnlock(&joinMutex);

    /*
     * [3] Now that the structure is not part of the list anymore no other
     * thread can acquire its mutex from now on. But it is possible that
     * another thread is still holding the mutex though, see location [2].  So
     * we have to acquire the mutex one more time to wait for that thread to
     * finish. We can (and have to) release the mutex immediately.
     */

    Tcl_MutexLock(&threadPtr->threadMutex);
    Tcl_MutexUnlock(&threadPtr->threadMutex);

    /*
     * Copy the result to us, finalize the synchronisation objects, then free
     * the structure and return.
     */

    *result = threadPtr->result;

    Tcl_ConditionFinalize(&threadPtr->cond);
    Tcl_MutexFinalize(&threadPtr->threadMutex);
    ckfree((char *) threadPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclRememberJoinableThread --
 *
 *	This procedure remebers a thread as joinable. Only a call to
 *	TclJoinThread will remove the structre created (and initialized) here.
 *	IOW, not waiting upon a joinable thread will cause memory leaks.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory, adds it to the global list of all joinable threads.

 *
 *----------------------------------------------------------------------
 */

VOID
TclRememberJoinableThread(id)
    Tcl_ThreadId id; /* The thread to remember as joinable */
{
    JoinableThread *threadPtr;

    threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread));
    threadPtr->id = id;
    threadPtr->done = 0;
    threadPtr->waitedUpon = 0;
    threadPtr->threadMutex = (Tcl_Mutex) NULL;
    threadPtr->cond = (Tcl_Condition) NULL;

    Tcl_MutexLock(&joinMutex);

    threadPtr->nextThreadPtr = firstThreadPtr;
    firstThreadPtr = threadPtr;

    Tcl_MutexUnlock(&joinMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSignalExitThread --
 *
 *	This procedure signals that the specified thread is done with its
 *	work. If the thread is joinable this signal is propagated to the
 *	thread waiting upon it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the associated structure to hold the result.
 *
 *----------------------------------------------------------------------
 */

VOID
TclSignalExitThread(id,result)
    Tcl_ThreadId id;		/* Id of the thread signaling its exit. */
    int result;			/* The result from the thread. */
{
    JoinableThread *threadPtr;

    Tcl_MutexLock(&joinMutex);

    threadPtr = firstThreadPtr;
    while ((threadPtr != NULL) && (threadPtr->id != id)) {
	threadPtr = threadPtr->nextThreadPtr;


    }

    if (threadPtr == NULL) {
	/*
	 * Thread not found. Not joinable. No problem, nothing to do.
	 */

	Tcl_MutexUnlock(&joinMutex);
	return;
    }

    /*
     * Switch over the exclusive access from the list to the structure, then
     * store the result, set the flag and notify the waiting thread, provided
     * that it exists. The order of lock/unlock ensures that a thread entering
     * 'TclJoinThread' will not interfere with us.
     */

    Tcl_MutexLock(&threadPtr->threadMutex);
    Tcl_MutexUnlock(&joinMutex);

    threadPtr->done = 1;
    threadPtr->result = result;

    if (threadPtr->waitedUpon) {
	Tcl_ConditionNotify(&threadPtr->cond);
    }

    Tcl_MutexUnlock(&threadPtr->threadMutex);
}
#endif /* WIN32 */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclThreadStorage.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55
56

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
/*
 * tclThreadStorage.c --
 *
 *	This file implements platform independent thread storage operations.
 *
 * Copyright (c) 2003-2004 by Joe Mistachkin
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadStorage.c,v 1.4 2004/06/24 09:05:46 dkf Exp $
 */

#include "tclInt.h"

#if defined(TCL_THREADS) && defined(USE_THREAD_STORAGE)

/*
 * This is the thread storage cache array and it's accompanying mutex.
 * The elements are pairs of thread Id and an associated hash table
 * pointer; the hash table being pointed to contains the thread storage
 * for it's associated thread. The purpose of this cache is to minimize
 * the number of hash table lookups in the master thread storage hash
 * table.
 */

static Tcl_Mutex threadStorageLock;

/*
 * This is the struct used for a thread storage cache slot. It contains
 * the owning thread Id and the associated hash table pointer.
 */

typedef struct ThreadStorage {
    Tcl_ThreadId id;			/* the owning thread id */
    Tcl_HashTable *hashTablePtr;	/* the hash table for the thread */
} ThreadStorage;

/*
 * These are the prototypes for the custom hash table allocation
 * functions used by the thread storage subsystem.
 */

static Tcl_HashEntry *	AllocThreadStorageEntry _ANSI_ARGS_((
			    Tcl_HashTable *tablePtr, void *keyPtr));
static void		FreeThreadStorageEntry _ANSI_ARGS_((
			    Tcl_HashEntry *hPtr));

/*
 * This is the hash key type for thread storage. We MUST use this in
 * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH
 * because these hash tables MAY be used by the threaded memory allocator.
 */

Tcl_HashKeyType tclThreadStorageHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    TCL_HASH_KEY_SYSTEM_HASH,		/* flags */

    NULL,				/* hashKeyProc */
    NULL,				/* compareKeysProc */
    AllocThreadStorageEntry,		/* allocEntryProc */
    FreeThreadStorageEntry		/* freeEntryProc */
};

/*
 * This is an invalid thread value.
 */

#define STORAGE_INVALID_THREAD  (Tcl_ThreadId)0

/*
 * This is the value for an invalid thread storage key.
 */

#define STORAGE_INVALID_KEY	0

/*
 * This is the first valid key for use by external callers.
 * All the values below this are RESERVED for future use.
 */

#define STORAGE_FIRST_KEY	101

/*
 * This is the default number of thread storage cache slots.
 * This define may need to be fine tuned for maximum performance.
 */

#define STORAGE_CACHE_SLOTS	97

/*
 * This is the master thread storage hash table. It is keyed on
 * thread Id and contains values that are hash tables for each thread.
 * The thread specific hash tables contain the actual thread storage.
 */

static Tcl_HashTable *threadStorageHashTablePtr = NULL;

/*
 * This is the next thread data key value to use. We increment this
 * everytime we "allocate" one. It is initially set to 1 in
 * TclThreadStorageInit.
 */

static int nextThreadStorageKey = STORAGE_INVALID_KEY;

/*
 * Have we initialized the thread storage mutex yet?
 */

static int initThreadStorage = 0;

/*
 * This is the master thread storage cache. Per kennykb's idea, this
 * prevents unnecessary lookups for threads that use a lot of thread
 * storage.
 */

static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS];

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageLockInit
 *
 *	This procedure is used to initialize the lock that serializes
 *	creation of thread storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The master lock is acquired and possibly initialized for the
 *	first time.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadStorageLockInit()
{
    if (!initThreadStorage) {
	/*
	 * Mutexes in Tcl are self initializing, and we are taking
	 * advantage of that fact since this file cannot contain
	 * platform specific calls.
	 */
	initThreadStorage = 1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageLock
 *
 *	This procedure is used to grab a lock that serializes creation
 *	of thread storage.
 *
 *	This lock must be different than the initLock because the
 *	initLock is held during creation of syncronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the thread storage mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadStorageLock()
{
    TclThreadStorageLockInit();
    Tcl_MutexLock(&threadStorageLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageUnlock
 *
 *	This procedure is used to release a lock that serializes creation
 *	of thread storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the thread storage mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadStorageUnlock()
{
    Tcl_MutexUnlock(&threadStorageLock);
}

/*
 *----------------------------------------------------------------------
 *
 * AllocThreadStorageEntry --
 *
 *	Allocate space for a Tcl_HashEntry using TclpSysAlloc (not
 *	ckalloc). We do this because the threaded memory allocator MAY
 *	use the thread storage hash tables.
 *
 * Results:
 *	The return value is a pointer to the created entry.
 *
 * Side effects:
 *	None.
 *







|
|

|




|


|
|
|
|
|
<





|
|



|
|



|
|


|
|
|
|






>


|
>



















|
|


|


|
|





|
|
|


|


|
|
<





<
<
<
<
<
<
|
|
<







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

101
102
103
104
105






106
107

108
109
110
111
112
113
114

















































































115
116
117
118
119
120
121
122
123
124
125
126
/*
 * tclThreadStorage.c --
 *
 *	This file implements platform independent thread storage operations.
 *
 * Copyright (c) 2003-2004 by Joe Mistachkin
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadStorage.c,v 1.4.4.2 2005/08/15 18:13:59 dgp Exp $
 */

#include "tclInt.h"

#if defined(TCL_THREADS)

/*
 * This is the thread storage cache array and it's accompanying mutex.  The
 * elements are pairs of thread Id and an associated hash table pointer; the
 * hash table being pointed to contains the thread storage for it's associated
 * thread. The purpose of this cache is to minimize the number of hash table
 * lookups in the master thread storage hash table.

 */

static Tcl_Mutex threadStorageLock;

/*
 * This is the struct used for a thread storage cache slot. It contains the
 * owning thread Id and the associated hash table pointer.
 */

typedef struct ThreadStorage {
    Tcl_ThreadId id;		/* the owning thread id */
    Tcl_HashTable *hashTablePtr;/* the hash table for the thread */
} ThreadStorage;

/*
 * These are the prototypes for the custom hash table allocation functions
 * used by the thread storage subsystem.
 */

static Tcl_HashEntry *	AllocThreadStorageEntry(Tcl_HashTable *tablePtr,
			    void *keyPtr);
static void		FreeThreadStorageEntry(Tcl_HashEntry *hPtr);
static Tcl_HashTable *	ThreadStorageGetHashTable(Tcl_ThreadId id);

/*
 * This is the hash key type for thread storage. We MUST use this in
 * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH
 * because these hash tables MAY be used by the threaded memory allocator.
 */

Tcl_HashKeyType tclThreadStorageHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,		/* version */
    TCL_HASH_KEY_SYSTEM_HASH | TCL_HASH_KEY_RANDOMIZE_HASH,
				        /* flags */
    NULL,				/* hashKeyProc */
    NULL,				/* compareKeysProc */
    AllocThreadStorageEntry,		/* allocEntryProc */
    FreeThreadStorageEntry		/* freeEntryProc */
};

/*
 * This is an invalid thread value.
 */

#define STORAGE_INVALID_THREAD  (Tcl_ThreadId)0

/*
 * This is the value for an invalid thread storage key.
 */

#define STORAGE_INVALID_KEY	0

/*
 * This is the first valid key for use by external callers. All the values
 * below this are RESERVED for future use.
 */

#define STORAGE_FIRST_KEY	1

/*
 * This is the default number of thread storage cache slots. This define may
 * need to be fine tuned for maximum performance.
 */

#define STORAGE_CACHE_SLOTS	97

/*
 * This is the master thread storage hash table. It is keyed on thread Id and
 * contains values that are hash tables for each thread.  The thread specific
 * hash tables contain the actual thread storage.
 */

static Tcl_HashTable threadStorageHashTable;

/*
 * This is the next thread data key value to use. We increment this everytime
 * we "allocate" one. It is initially set to 1 in TclInitThreadStorage.

 */

static int nextThreadStorageKey = STORAGE_INVALID_KEY;

/*






 * This is the master thread storage cache. Per Kevin Kenny's idea, this
 * prevents unnecessary lookups for threads that use a lot of thread storage.

 */

static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS];

/*
 *----------------------------------------------------------------------
 *

















































































 * AllocThreadStorageEntry --
 *
 *	Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc).
 *	We do this because the threaded memory allocator MAY use the thread
 *	storage hash tables.
 *
 * Results:
 *	The return value is a pointer to the created entry.
 *
 * Side effects:
 *	None.
 *
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410

411
412
413
414
415

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479

480
481
482
483




484







485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680

681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705

706
707
708
709
710
711
712
713


714
715
716
717
718





719
720
721
722
723
724

725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764






























765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794

795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112








}

/*
 *----------------------------------------------------------------------
 *
 * FreeThreadStorageEntry --
 *
 *	Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree).
 *	We do this because the threaded memory allocator MAY use the
 *	thread storage hash tables.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FreeThreadStorageEntry(hPtr)
    Tcl_HashEntry *hPtr;	/* Hash entry to free. */
{
    TclpSysFree((char *)hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 *  TclThreadStoragePrint --
 *
 *	This procedure prints out the contents of the master thread
 *	storage hash table, the thread storage cache, and the next key
 *	value to the specified file.
 *
 *	This assumes that thread storage lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The thread storage lock is acquired and released.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadStoragePrint(outFile, flags)
    FILE *outFile;		/* The file to print the information to. */
    int flags;			/* Reserved for future use. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    int header, index;

    if (threadStorageHashTablePtr != NULL) {
	hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search);

	if (hPtr != NULL) {
	    fprintf(outFile, "master thread storage hash table:\n");
	    for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
		fprintf(outFile,
			"master entry ptr %p, thread %p, thread table ptr %p\n",
			hPtr, Tcl_GetHashKey(threadStorageHashTablePtr, hPtr),
			Tcl_GetHashValue(hPtr));
	    }
	} else {
	    fprintf(outFile,
		    "master thread storage hash table has no entries\n");
	}
    } else {
	fprintf(outFile,
		"master thread storage hash table not initialized\n");
    }

    header = 0; /* we have not output the header yet. */
    for (index = 0; index < STORAGE_CACHE_SLOTS; index++) {
	if (threadStorageCache[index].id != STORAGE_INVALID_THREAD) {
	    if (!header) {
		fprintf(outFile, "thread storage cache (%d total slots):\n",
			STORAGE_CACHE_SLOTS);
		header = 1;
	    }

	    fprintf(outFile, "slot %d, thread %p, thread table ptr %p\n",
		    index, threadStorageCache[index].id,
		    threadStorageCache[index].hashTablePtr);
#ifdef VERBOSE_THREAD_STORAGE_DEBUGGING
	    /*
	     * Currently not enabled by default due to Tcl_HashStats
	     * use of ckalloc and ckfree.  Please note that this can
	     * produce a LOT of output.
	     */
	    if (threadStorageCache[index].hashTablePtr != NULL) {
		CONST char *stats =
			Tcl_HashStats(threadStorageCache[index].hashTablePtr);
		if (stats != NULL) {
		    fprintf(outFile, "%s\n", stats);
		    ckfree((void *)stats);
		} else {
		    fprintf(outFile,
			    "could not get table statistics for slot %d\n",
			    index);
		}
	    }
#endif
	} else {
	    /* fprintf(outFile, "cache slot %d not used\n", index); */
	}
    }

    if (!header) {
	fprintf(outFile, "thread storage cache is empty (%d total slots)\n",
		STORAGE_CACHE_SLOTS);
	header = 1;
    }

    /*
     * Show the next data key value.
     */

    fprintf(outFile, "next data key value is: %d\n", nextThreadStorageKey);
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageGetHashTable --
 *
 *	This procedure returns a hash table pointer to be used for thread
 *	storage for the specified thread.
 *
 *	This assumes that thread storage lock is held.
 *
 * Results:
 *	A hash table pointer for the specified thread, or NULL
 *	if the hash table has not been created yet.
 *
 * Side effects:
 *	May change an entry in the master thread storage cache to point
 *	to the specified thread and it's associated hash table.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashTable *
TclThreadStorageGetHashTable(id)
    Tcl_ThreadId id;		/* Id of thread to get hash table for */
{
    int index = (unsigned int)id % STORAGE_CACHE_SLOTS;
    Tcl_HashEntry *hPtr;
    int new;

    /*
     * It's important that we pick up the hash table pointer BEFORE
     * comparing thread Id in case another thread is in the critical
     * region changing things out from under you.
     */

    Tcl_HashTable *hashTablePtr = threadStorageCache[index].hashTablePtr;

    if (threadStorageCache[index].id != id) {
	TclThreadStorageLock();

	/*
	 * Make sure the master hash table is initialized.
	 */

	TclThreadStorageInit(STORAGE_INVALID_THREAD, NULL);

	if (threadStorageHashTablePtr != NULL) {
	    /*
	     * It's not in the cache, so we look it up...
	     */

	    hPtr = Tcl_FindHashEntry(threadStorageHashTablePtr, (char *)id);

	    if (hPtr != NULL) {
		/*
		 * We found it, extract the hash table pointer.
		 */

		hashTablePtr = Tcl_GetHashValue(hPtr);
	    } else {
		/*
		 * The thread specific hash table is not found.
		 */

		hashTablePtr = NULL;
	    }

	    if (hashTablePtr == NULL) {
		hashTablePtr = (Tcl_HashTable *)
			TclpSysAlloc(sizeof(Tcl_HashTable), 0);

		if (hashTablePtr == NULL) {
		    Tcl_Panic("could not allocate thread specific hash "
			    "table, TclpSysAlloc failed from "
			    "TclThreadStorageGetHashTable!");
		}
		Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS,
			&tclThreadStorageHashKeyType);

		/*
		 * Add new thread storage hash table to the master
		 * hash table.
		 */

		hPtr = Tcl_CreateHashEntry(threadStorageHashTablePtr,
			(char *)id, &new);

		if (hPtr == NULL) {
		    Tcl_Panic("Tcl_CreateHashEntry failed from "
			    "TclThreadStorageInit!");
		}
		Tcl_SetHashValue(hPtr, hashTablePtr);
	    }

	    /*
	     * Now, we put it in the cache since it is highly likely
	     * it will be needed again shortly.
	     */

	    threadStorageCache[index].id = id;
	    threadStorageCache[index].hashTablePtr = hashTablePtr;
	} else {
	    /*
	     * We cannot look it up, the master hash table has not
	     * been initialized.
	     */
	    hashTablePtr = NULL;
	}
	TclThreadStorageUnlock();
    }

    return hashTablePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageInit --
 *
 *	This procedure initializes a thread specific hash table for the
 *	current thread. It may also initialize the master hash table which
 *	stores all the thread specific hash tables.
 *
 *	This assumes that thread storage lock is held.
 *
 * Results:
 *	A hash table pointer for the specified thread, or NULL if we are
 *	be called to initialize the master hash table only.

 *
 * Side effects:
 *	The thread specific hash table may be initialized and added to the
 *	master hash table.




 *







 *----------------------------------------------------------------------
 */

Tcl_HashTable *
TclThreadStorageInit(id, reserved)
    Tcl_ThreadId id;		/* Id of thread to get hash table for */
    void *reserved;		/* reserved for future use */
{
#if 0 /* #ifdef TCL_THREAD_STORAGE_DEBUG */
    TclThreadStoragePrint(stderr, 0);
#endif

    if (threadStorageHashTablePtr == NULL) {
	/*
	 * Looks like we haven't created the outer hash table yet we
	 * can just do that now.
	 */

	threadStorageHashTablePtr = (Tcl_HashTable *)
		TclpSysAlloc(sizeof(Tcl_HashTable), 0);
	if (threadStorageHashTablePtr == NULL) {
	    Tcl_Panic("could not allocate master thread storage hash table, "
		    "TclpSysAlloc failed from TclThreadStorageInit!");
	}
	Tcl_InitCustomHashTable(threadStorageHashTablePtr,
		TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType);

	/*
	 * We also initialize the cache.
	 */

	memset((ThreadStorage *)&threadStorageCache, 0,
		sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS);

	/*
	 * Now, we set the first value to be used for a thread data key.
	 */

	nextThreadStorageKey = STORAGE_FIRST_KEY;
    }

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageDataKeyInit --
 *
 *	This procedure initializes a thread specific data block key.
 *	Each thread has table of pointers to thread specific data.
 *	all threads agree on which table entry is used by each module.
 *	this is remembered in a "data key", that is just an index into
 *	this table.  To allow self initialization, the interface
 *	passes a pointer to this key and the first thread to use
 *	the key fills in the pointer to the key.  The key should be
 *	a process-wide static.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Will allocate memory the first time this process calls for
 *	this key.  In this case it modifies its argument
 *	to hold the pointer to information about the key.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadStorageDataKeyInit(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (int **) */
{
    int *indexPtr;
    int newKey;

    if (*keyPtr == NULL) {
	indexPtr = (int *)TclpSysAlloc(sizeof(int), 0);
	if (indexPtr == NULL) {
	    Tcl_Panic("TclpSysAlloc failed from TclThreadStorageDataKeyInit!");
	}

	/*
	 * We must call this now to make sure that
	 * nextThreadStorageKey has a well defined value.
	 */

	TclThreadStorageLock();

	/*
	 * Make sure the master hash table is initialized.
	 */

	TclThreadStorageInit(STORAGE_INVALID_THREAD, NULL);

	/*
	 * These data key values are sequentially assigned and we must
	 * use the storage lock to prevent serious problems here.
	 * Also note that the caller should NOT make any assumptions
	 * about the provided values. In particular, we may need to
	 * reserve some values in the future.
	 */

	newKey = nextThreadStorageKey++;
	TclThreadStorageUnlock();

	*indexPtr = newKey;
	*keyPtr = (Tcl_ThreadDataKey)indexPtr;
	TclRememberDataKey(keyPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageDataKeyGet --
 *
 *	This procedure returns a pointer to a block of thread local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure, or NULL
 *	if the memory has not been assigned to this key for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void *
TclThreadStorageDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (int **) */
{
    int *indexPtr = *(int **)keyPtr;

    if (indexPtr == NULL) {
	return NULL;
    } else {
	Tcl_HashTable *hashTablePtr =
		TclThreadStorageGetHashTable(Tcl_GetCurrentThread());
	Tcl_HashEntry *hPtr;

	if (hashTablePtr == NULL) {
	    Tcl_Panic("TclThreadStorageGetHashTable failed from "
		    "TclThreadStorageDataKeyGet!");
	}

	hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);

	if (hPtr == NULL) {
	    return NULL;
	}
	return (void *)Tcl_GetHashValue(hPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadStorageDataKeySet --
 *
 *	This procedure sets the pointer to a block of thread local storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the thread so future calls to TclThreadStorageDataKeyGet
 *	with this key will return the data pointer.
 *
 *----------------------------------------------------------------------
 */

void
TclThreadStorageDataKeySet(keyPtr, data)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
    void *data;			/* Thread local storage */
{
    int *indexPtr = *(int **)keyPtr;
    Tcl_HashTable *hashTablePtr;
    Tcl_HashEntry *hPtr;

    hashTablePtr = TclThreadStorageGetHashTable(Tcl_GetCurrentThread());
    if (hashTablePtr == NULL) {
	Tcl_Panic("TclThreadStorageGetHashTable failed from "
		"TclThreadStorageDataKeySet!");
    }

    hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);

    /*
     * Does the item need to be created?
     */

    if (hPtr == NULL) {
	int new;
	hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)*indexPtr, &new);
	if (hPtr == NULL) {
	    Tcl_Panic("could not create hash entry value from "
		    "TclThreadStorageDataKeySet");
	}
    }

    Tcl_SetHashValue(hPtr, data);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorageThread --
 *
 *	This procedure cleans up the thread storage hash table for the
 *	specified thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.

 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorageThread(id)
    Tcl_ThreadId id;		/* Id of the thread to finalize */
{


    int index = (unsigned int)id % STORAGE_CACHE_SLOTS;
    Tcl_HashTable *hashTablePtr; /* Hash table for current thread */
    Tcl_HashEntry *hPtr;	/* Hash entry for current thread in master
				 * table */






    TclThreadStorageLock();

    if (threadStorageHashTablePtr != NULL) {
	hPtr = Tcl_FindHashEntry(threadStorageHashTablePtr, (char *)id);

	if (hPtr != NULL) {

	    /*
	     * We found it, extract the hash table pointer.
	     */

	    hashTablePtr = Tcl_GetHashValue(hPtr);

	    if (hashTablePtr != NULL) {
		/*
		 * Delete thread specific hash table and free the
		 * struct.
		 */

		Tcl_DeleteHashTable(hashTablePtr);
		TclpSysFree((char *)hashTablePtr);
	    }

	    /*
	     * Delete thread specific entry from master hash table.
	     */

	    Tcl_DeleteHashEntry(hPtr);
	}
    }

    /*
     * Make sure cache entry for this thread is NULL.
     */

    if (threadStorageCache[index].id == id) {
	/*
	 * We do not step on another thread's cache entry.  This is
	 * especially important if we are creating and exiting a lot
	 * of threads.
	 */

	threadStorageCache[index].id = STORAGE_INVALID_THREAD;
	threadStorageCache[index].hashTablePtr = NULL;
    }

    TclThreadStorageUnlock();






























}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorage --
 *
 *	This procedure cleans up the master thread storage hash table,
 *	all thread specific hash tables, and the thread storage cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The master thread storage hash table and thread storage cache are
 *	reset to their initial (empty) state.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorage()
{
    TclThreadStorageLock();

    if (threadStorageHashTablePtr != NULL) {
	Tcl_HashSearch search;		/* We need to hit every thread with
					 * this search. */
	Tcl_HashEntry *hPtr;		/* Hash entry for current thread in
					 * master table. */


	/*
	 * We are going to delete the hash table for every thread now.
	 * This hash table should be empty at this point, except for
	 * one entry for the current thread.
	 */

	for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr);

	    if (hashTablePtr != NULL) {
		/*
		 * Delete thread specific hash table for the thread in
		 * question and free the struct.
		 */

		Tcl_DeleteHashTable(hashTablePtr);
		TclpSysFree((char *)hashTablePtr);
	    }

	    /*
	     * Delete thread specific entry from master hash table.
	     */

	    Tcl_SetHashValue(hPtr, NULL);
	}

	Tcl_DeleteHashTable(threadStorageHashTablePtr);
	TclpSysFree((char *)threadStorageHashTablePtr);

	/*
	 * Reset this so that next time around we know it's not valid.
	 */

	threadStorageHashTablePtr = NULL;
    }

    /*
     * Clear out the thread storage cache as well.
     */

    memset((ThreadStorage *)&threadStorageCache, 0,
	    sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS);

    /*
     * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the
     * thread storage subsystem gets reinitialized
     */

    nextThreadStorageKey = STORAGE_INVALID_KEY;

    TclThreadStorageUnlock();
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorageData --
 *
 *	This procedure cleans up the thread-local storage.  This is
 *	called once for each thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up the memory.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorageData(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    if (*keyPtr != NULL) {
	Tcl_ThreadId id = Tcl_GetCurrentThread();
	Tcl_HashTable *hashTablePtr;	/* Hash table for current thread */
	Tcl_HashEntry *hPtr;		/* Hash entry for data key in current
					 * thread. */
	int *indexPtr = *(int **)keyPtr;

	hashTablePtr = TclThreadStorageGetHashTable(id);
	if (hashTablePtr == NULL) {
	    Tcl_Panic("TclThreadStorageGetHashTable failed from "
		    "TclFinalizeThreadStorageData!");
	}

	hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);
	if (hPtr != NULL) {
	    void *result = Tcl_GetHashValue(hPtr);

	    if (result != NULL) {
		/*
		 * This must be ckfree because tclThread.c allocates
		 * these using ckalloc.
		 */
		ckfree((char *)result);
	    }

	    Tcl_SetHashValue(hPtr, NULL);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorageDataKey --
 *
 *	This procedure is invoked to clean up one key.  This is a
 *	process-wide storage identifier.  The thread finalization code
 *	cleans up the thread local storage itself.
 *
 *	This assumes the master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The key is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorageDataKey(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    int *indexPtr;
    Tcl_HashTable *hashTablePtr;/* Hash table for current thread */
    Tcl_HashSearch search;	/* Need to hit every thread with this search */
    Tcl_HashEntry *hPtr;	/* Hash entry for current thread in master
				 * table. */
    Tcl_HashEntry *hDataPtr;	/* Hash entry for data key in current thread */

    if (*keyPtr != NULL) {
	indexPtr = *(int **)keyPtr;

	TclThreadStorageLock();

	if (threadStorageHashTablePtr != NULL) {
	    /*
	     * We are going to delete the specified data key entry
	     * from every thread.
	     */

	    for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search);
		    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

		/*
		 * Get the hash table corresponding to the thread in question.
		 */
		hashTablePtr = Tcl_GetHashValue(hPtr);

		if (hashTablePtr != NULL) {
		    /*
		     * Now find the entry for the specified data key.
		     */
		    hDataPtr = Tcl_FindHashEntry(hashTablePtr,
			    (char *)*indexPtr);

		    if (hDataPtr != NULL) {
			/*
			 * Delete the data key for this thread.
			 */
			Tcl_DeleteHashEntry(hDataPtr);
		    }
		}
	    }
	}

	TclThreadStorageUnlock();

	TclpSysFree((char *)indexPtr);
	*keyPtr = NULL;
    }
}

#else /* !defined(TCL_THREADS) || !defined(USE_THREAD_STORAGE) */

static void ThreadStoragePanic _ANSI_ARGS_((CONST char *message));

/*
 *----------------------------------------------------------------------
 *
 * ThreadStoragePanic --
 *
 *      Panic if Tcl was compiled without TCL_THREADS or without
 *      USE_THREAD_STORAGE and a thread storage function has been
 *      called.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *	    None.
 *
 *----------------------------------------------------------------------
 */
static void ThreadStoragePanic(message)
    CONST char *message;	/* currently ignored */
{
#ifdef TCL_THREADS
#   ifdef USE_THREAD_STORAGE
    /*
     * Do nothing, everything is OK. However, this should never happen
     * because this function only gets called by the dummy thread
     * storage functions (used when one or both of these DEFINES are
     * not present).
     */
#   else
    Tcl_Panic("Tcl was not compiled with thread storage enabled.");
#   endif /* USE_THREAD_STORAGE */
#else
    Tcl_Panic("Tcl was not compiled with threads enabled.");
#endif /* TCL_THREADS */
}

/*
 * Stub functions that just call ThreadStoragePanic.
 */

void
TclThreadStorageLockInit()
{
    ThreadStoragePanic(NULL);
}

void
TclThreadStorageLock()
{
    ThreadStoragePanic(NULL);
}

void
TclThreadStorageUnlock()
{
    ThreadStoragePanic(NULL);
}

void
TclThreadStoragePrint(outFile, flags)
    FILE *outFile;
    int flags;
{
    ThreadStoragePanic(NULL);
}

Tcl_HashTable *
TclThreadStorageGetHashTable(id)
    Tcl_ThreadId id;
{
    ThreadStoragePanic(NULL);
    return NULL;
}

Tcl_HashTable *
TclThreadStorageInit(id, reserved)
    Tcl_ThreadId id;
    void *reserved;
{
    ThreadStoragePanic(NULL);
    return NULL;
}

void
TclThreadStorageDataKeyInit(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    ThreadStoragePanic(NULL);
}

void *
TclThreadStorageDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    ThreadStoragePanic(NULL);
    return NULL;
}

void
TclThreadStorageDataKeySet(keyPtr, data)
    Tcl_ThreadDataKey *keyPtr;
    void *data;
{
    ThreadStoragePanic(NULL);
}

void
TclFinalizeThreadStorageThread(id)
    Tcl_ThreadId id;
{
    ThreadStoragePanic(NULL);
}

void
TclFinalizeThreadStorage()
{
    ThreadStoragePanic(NULL);
}

void
TclFinalizeThreadStorageData(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    ThreadStoragePanic(NULL);
}

void
TclFinalizeThreadStorageDataKey(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    ThreadStoragePanic(NULL);
}

#endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */















|
|
|




















<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







|
|


|
|




|
|







|
|
|





|


<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
<
<
<
<
<
<
|
|








|

<
<
|

<
<

<
<
>


<
|
>
>
>
>

>
>
>
>
>
>
>



<
<
<
<
<
<
<
<
|
|
<
<
<
<
|
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|




|
|








|
|
|

<
<
<
<
<
|
|
|
<
<
<
<
<
<
|
<
|
|
|
|
<





|







|
|





|
|
|


<



|
<
<
<
<
<
|




>


|
<
<
<
<








|


|





|
>





|
<

>
>

<

|
|
>
>
>
>
>
|

|
|
|
|
>
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<

|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







|
|














<
<
<
|

|

>

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
|
|
<








|
|




|


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<

|
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<

<





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



>
>
>
>
>
>
>
>
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170


































































































171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208







209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260






261
262
263
264
265
266
267
268
269
270
271
272


273
274


275


276
277
278

279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294








295
296




297





298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315



316
317
318





































































319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337





338
339
340






341

342
343
344
345

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370

371
372
373
374





375
376
377
378
379
380
381
382
383




384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

409
410
411
412

413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432















433


434
435
436
437
438
439
440
441
442
443
444

445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502



503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535







536
537

538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
















555



556


















557





558























559
560
561




























































562















563














564
565




566


































































567

568

569
570
571
572
573















574
575
576
577
578
579
580
581
582
583
584
}

/*
 *----------------------------------------------------------------------
 *
 * FreeThreadStorageEntry --
 *
 *	Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). We do
 *	this because the threaded memory allocator MAY use the thread storage
 *	hash tables.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FreeThreadStorageEntry(hPtr)
    Tcl_HashEntry *hPtr;	/* Hash entry to free. */
{
    TclpSysFree((char *)hPtr);
}

/*
 *----------------------------------------------------------------------
 *


































































































 * ThreadStorageGetHashTable --
 *
 *	This procedure returns a hash table pointer to be used for thread
 *	storage for the specified thread.
 *
 *	This assumes that thread storage lock is held.
 *
 * Results:
 *	A hash table pointer for the specified thread, or NULL if the hash
 *	table has not been created yet.
 *
 * Side effects:
 *	May change an entry in the master thread storage cache to point to the
 *	specified thread and it's associated hash table.
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashTable *
ThreadStorageGetHashTable(id)
    Tcl_ThreadId id;		/* Id of thread to get hash table for */
{
    int index = (unsigned int)id % STORAGE_CACHE_SLOTS;
    Tcl_HashEntry *hPtr;
    int new;

    /*
     * It's important that we pick up the hash table pointer BEFORE comparing
     * thread Id in case another thread is in the critical region changing
     * things out from under you.
     */

    Tcl_HashTable *hashTablePtr = threadStorageCache[index].hashTablePtr;

    if (threadStorageCache[index].id != id) {
	Tcl_MutexLock(&threadStorageLock);

	/*







	 * It's not in the cache, so we look it up...
	 */
	
	hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char *)id);
	
	if (hPtr != NULL) {
	    /*
	     * We found it, extract the hash table pointer.
	     */
	    
	    hashTablePtr = Tcl_GetHashValue(hPtr);
	} else {
	    /*
	     * The thread specific hash table is not found.
	     */
	    
	    hashTablePtr = NULL;
	}

	if (hashTablePtr == NULL) {
	    hashTablePtr = (Tcl_HashTable *)
		TclpSysAlloc(sizeof(Tcl_HashTable), 0);
	    
	    if (hashTablePtr == NULL) {
		Tcl_Panic("could not allocate thread specific hash "
			  "table, TclpSysAlloc failed from "
			  "ThreadStorageGetHashTable!");
	    }
	    Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS,
				    &tclThreadStorageHashKeyType);
	    
	    /*
	     * Add new thread storage hash table to the master hash table.

	     */
	    
	    hPtr = Tcl_CreateHashEntry(&threadStorageHashTable,
				       (char *)id, &new);
	    
	    if (hPtr == NULL) {
		Tcl_Panic("Tcl_CreateHashEntry failed from "
			  "ThreadStorageGetHashTable!");
	    }
	    Tcl_SetHashValue(hPtr, hashTablePtr);
	}

	/*
	 * Now, we put it in the cache since it is highly likely it will
	 * be needed again shortly.
	 */
	
	threadStorageCache[index].id = id;
	threadStorageCache[index].hashTablePtr = hashTablePtr;







	Tcl_MutexUnlock(&threadStorageLock);
    }

    return hashTablePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitThreadStorage --
 *


 *	Initializes the thread storage allocator.
 *


 * Results:


 *	None.
 *
 * Side effects:

 *	This procedure initializes the master hash table that maps
 *	thread ID onto the individual index tables that map thread data
 *	key to thread data. It also creates a cache that enables
 *	fast lookup of the thread data block array for a recently
 *	executing thread without using spinlocks.
 *
 * This procedure is called from an extremely early point in Tcl's
 * initialization.  In particular, it may not use ckalloc/ckfree
 * because they may depend on thread-local storage (it uses TclpSysAlloc
 * and TclpSysFree instead).  It may not depend on synchronization
 * primitives - but no threads other than the master thread have yet
 * been launched.
 *
 *----------------------------------------------------------------------
 */









void
TclInitThreadStorage()




{






    Tcl_InitCustomHashTable(&threadStorageHashTable,
			    TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType);
    
    /*
     * We also initialize the cache.
     */
    
    memset((ThreadStorage *)&threadStorageCache, 0,
	   sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS);
    
    /*
     * Now, we set the first value to be used for a thread data key.
     */
    
    nextThreadStorageKey = STORAGE_FIRST_KEY;
}




/*
 *----------------------------------------------------------------------
 *





































































 * TclpThreadDataKeyGet --
 *
 *	This procedure returns a pointer to a block of thread local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure, or NULL if the memory
 *	has not been assigned to this key for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void *
TclpThreadDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk, really
				 * (int**) */
{





    Tcl_HashTable *hashTablePtr =
	ThreadStorageGetHashTable(Tcl_GetCurrentThread());
    Tcl_HashEntry *hPtr =






	Tcl_FindHashEntry(hashTablePtr, (char *) keyPtr);

    if (hPtr == NULL) {
	return NULL;
    }
    return (void *) Tcl_GetHashValue(hPtr);

}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeySet --
 *
 *	This procedure sets the pointer to a block of thread local storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the thread so future calls to TclpThreadDataKeyGet with
 *	this key will return the data pointer.
 *
 *----------------------------------------------------------------------
 */

void
TclpThreadDataKeySet(keyPtr, data)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk, really
				 * (pthread_key_t **) */
    void *data;			/* Thread local storage */
{

    Tcl_HashTable *hashTablePtr;
    Tcl_HashEntry *hPtr;

    hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread());





    hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)keyPtr);

    /*
     * Does the item need to be created?
     */

    if (hPtr == NULL) {
	int new;
	hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)keyPtr, &new);




    }

    Tcl_SetHashValue(hPtr, data);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeThreadDataThread --
 *
 *	This procedure cleans up the thread storage hash table for the
 *	current thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees all associated thread storage, all hash table entries for
 *	the thread's thread storage, and the hash table itself.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeThreadDataThread()

{
    Tcl_ThreadId id = Tcl_GetCurrentThread();
				/* Id of the thread to finalize. */
    int index = (unsigned int)id % STORAGE_CACHE_SLOTS;

    Tcl_HashEntry *hPtr;	/* Hash entry for current thread in master
				 * table. */
    Tcl_HashTable* hashTablePtr;
				/* Pointer to the hash table holding
				 * TSD blocks for the current thread*/
    Tcl_HashSearch search;	/* Search object to walk the TSD blocks
				 * in the designated thread */
    Tcl_HashEntry *hPtr2;	/* Hash entry for a TSD block in the
				 * designated thread. */

    Tcl_MutexLock(&threadStorageLock);
    hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char*)id);
    if (hPtr == NULL) {
	hashTablePtr = NULL;
    } else {
	/*
	 * We found it, extract the hash table pointer.
	 */
	
	hashTablePtr = Tcl_GetHashValue(hPtr);















	Tcl_DeleteHashEntry(hPtr);



	/*
	 * Make sure cache entry for this thread is NULL.
	 */
	
	if (threadStorageCache[index].id == id) {
	    /*
	     * We do not step on another thread's cache entry.  This is 
	     * especially important if we are creating and exiting a lot
	     * of threads.
	     */

	    threadStorageCache[index].id = STORAGE_INVALID_THREAD;
	    threadStorageCache[index].hashTablePtr = NULL;
	}
    }
    Tcl_MutexUnlock(&threadStorageLock);

    /* 
     * The thread's hash table has been extracted and removed from the master
     * hash table.  Now clean up the thread.
     */

    if (hashTablePtr != NULL) {

	/* Free all TSD */
	
	for (hPtr2 = Tcl_FirstHashEntry(hashTablePtr, &search);
	     hPtr2 != NULL;
	     hPtr2 = Tcl_NextHashEntry(&search)) {
	    void* blockPtr = Tcl_GetHashValue(hPtr2);
	    if (blockPtr != NULL) {
		/* 
		 * The block itself was allocated in Tcl_GetThreadData
		 * using ckalloc; use ckfree to dispose of it.
		 */
		ckfree(blockPtr);
	    }
	}
	
	/*
	 * Delete thread specific hash table and free the struct.
	 */
	    
	Tcl_DeleteHashTable(hashTablePtr);
	TclpSysFree((char *)hashTablePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorage --
 *
 *	This procedure cleans up the master thread storage hash table, all
 *	thread specific hash tables, and the thread storage cache.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The master thread storage hash table and thread storage cache are
 *	reset to their initial (empty) state.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorage()
{



    Tcl_HashSearch search;		/* We need to hit every thread with
					 * this search. */
    Tcl_HashEntry *hPtr;		/* Hash entry for current thread in
					 * master table. */
    Tcl_MutexLock(&threadStorageLock);

    /*
     * We are going to delete the hash table for every thread now.  This
     * hash table should be empty at this point, except for one entry for
     * the current thread.
     */
    
    for (hPtr = Tcl_FirstHashEntry(&threadStorageHashTable, &search);
	 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr);
	
	if (hashTablePtr != NULL) {
	    /*
	     * Delete thread specific hash table for the thread in
	     * question and free the struct.
	     */
	    
	    Tcl_DeleteHashTable(hashTablePtr);
	    TclpSysFree((char *)hashTablePtr);
	}
	
	/*
	 * Delete thread specific entry from master hash table.
	 */
	
	Tcl_SetHashValue(hPtr, NULL);
    }
    







    Tcl_DeleteHashTable(&threadStorageHashTable);
    

    /*
     * Clear out the thread storage cache as well.
     */

    memset((ThreadStorage *)&threadStorageCache, 0,
	    sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS);

    /*
     * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the thread
     * storage subsystem gets reinitialized
     */

    nextThreadStorageKey = STORAGE_INVALID_KEY;

    Tcl_MutexUnlock(&threadStorageLock);
}

















#else /* !defined(TCL_THREADS) */






















/*





 * Stub functions for non-threaded builds























 */

void




























































TclInitThreadStorage()















{














}





void


































































TclpFinalizeThreadDataThread()

{

}

void
TclFinalizeThreadStorage()
{















}

#endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclThreadTest.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17


18
19
20
21
22
23
24
/* 
 * tclThreadTest.c --
 *
 *	This file implements the testthread command.  Eventually this
 *	should be tclThreadCmd.c
 *	Some of this code is based on work done by Richard Hipp on behalf of
 *	Conservation Through Innovation, Limited, with their permission.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadTest.c,v 1.17 2004/10/20 05:28:39 dgp Exp $
 */

#include "tclInt.h"



#ifdef TCL_THREADS
/*
 * Each thread has an single instance of the following structure.  There
 * is one instance of this structure per thread even if that thread contains
 * multiple interpreters.  The interpreter identified by this structure is
 * the main interpreter for the thread.  













|



>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
/* 
 * tclThreadTest.c --
 *
 *	This file implements the testthread command.  Eventually this
 *	should be tclThreadCmd.c
 *	Some of this code is based on work done by Richard Hipp on behalf of
 *	Conservation Through Innovation, Limited, with their permission.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadTest.c,v 1.17.2.4 2005/09/26 20:16:53 kennykb Exp $
 */

#include "tclInt.h"

extern int Tcltest_Init( Tcl_Interp* );

#ifdef TCL_THREADS
/*
 * Each thread has an single instance of the following structure.  There
 * is one instance of this structure per thread even if that thread contains
 * multiple interpreters.  The interpreter identified by this structure is
 * the main interpreter for the thread.  
132
133
134
135
136
137
138






139
140
141
142
143
144
145
static int	ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
static void	ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
static void	ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
static int	ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
	ClientData clientData));
static void	ThreadExitProc _ANSI_ARGS_((ClientData clientData));








/*
 *----------------------------------------------------------------------
 *
 * TclThread_Init --
 *
 *	Initialize the test thread command.







>
>
>
>
>
>







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
static int	ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
static void	ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
static void	ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
static int	ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
	ClientData clientData));
static void	ThreadExitProc _ANSI_ARGS_((ClientData clientData));


/* Forward declaration of function import from "tclTest.c".
 */

int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));


/*
 *----------------------------------------------------------------------
 *
 * TclThread_Init --
 *
 *	Initialize the test thread command.
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
int
TclThread_Init(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    
    Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, 
	    (ClientData)NULL ,NULL);
    if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *







<
<
<







164
165
166
167
168
169
170



171
172
173
174
175
176
177
int
TclThread_Init(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    
    Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, 
	    (ClientData)NULL ,NULL);



    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
478
479
480
481
482
483
484






485
486
487
488
489
490
491
     * Initialize the interpreter.  This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
    result = TclThread_Init(tsdPtr->interp);







    /*
     * Update the list of threads.
     */

    Tcl_MutexLock(&threadMutex);
    ListUpdateInner(tsdPtr);
    /*







>
>
>
>
>
>







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
     * Initialize the interpreter.  This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
    result = TclThread_Init(tsdPtr->interp);

    /* This is part of the test facility.
     * Initialize _ALL_ test commands for
     * use by the new thread.
     */
    result = Tcltest_Init(tsdPtr->interp);

    /*
     * Update the list of threads.
     */

    Tcl_MutexLock(&threadMutex);
    ListUpdateInner(tsdPtr);
    /*

Changes to generic/tclTimer.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115


















116
117
118
119
120

121
122
123
124
125
126
127
/* 
 * tclTimer.c --
 *
 *	This file provides timer event management facilities for Tcl,
 *	including the "after" command.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTimer.c,v 1.12 2004/10/06 15:59:25 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each timer callback that's pending there is one record of the following
 * type.  The normal handlers (created by Tcl_CreateTimerHandler) are chained
 * together in a list sorted by time (earliest event first).
 */

typedef struct TimerHandler {
    Tcl_Time time;			/* When timer is to fire. */
    Tcl_TimerProc *proc;		/* Procedure to call. */
    ClientData clientData;		/* Argument to pass to proc. */
    Tcl_TimerToken token;		/* Identifies handler so it can be
					 * deleted. */
    struct TimerHandler *nextPtr;	/* Next event in queue, or NULL for

					 * end of queue. */
} TimerHandler;

/*
 * The data structure below is used by the "after" command to remember
 * the command to be executed later.  All of the pending "after" commands
 * for an interpreter are linked together in a list.
 */

typedef struct AfterInfo {
    struct AfterAssocData *assocPtr;
				/* Pointer to the "tclAfter" assocData for
				 * the interp in which command will be
				 * executed. */
    Tcl_Obj *commandPtr;	/* Command to execute. */
    int id;			/* Integer identifier for command;  used to
				 * cancel it. */
    Tcl_TimerToken token;	/* Used to cancel the "after" command.  NULL
				 * means that the command is run as an
				 * idle handler rather than as a timer
				 * handler.  NULL means this is an "after
				 * idle" handler rather than a
                                 * timer handler. */
    struct AfterInfo *nextPtr;	/* Next in list of all "after" commands for
				 * this interpreter. */
} AfterInfo;

/*
 * One of the following structures is associated with each interpreter
 * for which an "after" command has ever been invoked.  A pointer to
 * this structure is stored in the AssocData for the "tclAfter" key.
 */

typedef struct AfterAssocData {
    Tcl_Interp *interp;		/* The interpreter for which this data is
				 * registered. */
    AfterInfo *firstAfterPtr;	/* First in list of all "after" commands
				 * still pending for this interpreter, or
				 * NULL if none. */
} AfterAssocData;

/*
 * There is one of the following structures for each of the
 * handlers declared in a call to Tcl_DoWhenIdle.  All of the
 * currently-active handlers are linked together into a list.
 */

typedef struct IdleHandler {
    Tcl_IdleProc (*proc);	/* Procedure to call. */
    ClientData clientData;	/* Value to pass to proc. */
    int generation;		/* Used to distinguish older handlers from
				 * recently-created ones. */
    struct IdleHandler *nextPtr;/* Next in list of active handlers. */
} IdleHandler;

/*
 * The timer and idle queues are per-thread because they are associated
 * with the notifier, which is also per-thread.
 *
 * All static variables used in this file are collected into a single
 * instance of the following structure.  For multi-threaded implementations,
 * there is one instance of this structure for each thread.
 *
 * Notice that different structures with the same name appear in other
 * files.  The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {
    TimerHandler *firstTimerHandlerPtr;	/* First event in queue. */
    int lastTimerId;		/* Timer identifier of most recently
				 * created timer. */
    int timerPending;		/* 1 if a timer event is in the queue. */
    IdleHandler *idleList;	/* First in list of all idle handlers. */
    IdleHandler *lastIdlePtr;	/* Last in list (or NULL for empty list). */
    int idleGeneration;		/* Used to fill in the "generation" fields
				 * of IdleHandler structures.  Increments
				 * each time Tcl_DoOneEvent starts calling
				 * idle handlers, so that all old handlers
				 * can be called without calling any of the
				 * new ones created by old ones. */
    int afterId;		/* For unique identifiers of after events. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*


















 * Prototypes for procedures referenced only in this file:
 */

static void		AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));

static void		AfterProc _ANSI_ARGS_((ClientData clientData));
static void		FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
static AfterInfo *	GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
			    Tcl_Obj *commandPtr));
static ThreadSpecificData *InitTimer _ANSI_ARGS_((void));
static void		TimerExitProc _ANSI_ARGS_((ClientData clientData));
static int		TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
|







|
|

|






|




|
|
|
|
<
|
>
|



|
|
|




|
|


|

|
|
|
|
<
|





|
|
|





|
|
|



|
|
|



|







|
|

|
|
|

|
|




|
|



|
|
|
|
|
|






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|




>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
/*
 * tclTimer.c --
 *
 *	This file provides timer event management facilities for Tcl,
 *	including the "after" command.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTimer.c,v 1.12.2.6 2005/10/08 13:44:37 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each timer callback that's pending there is one record of the following
 * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
 * together in a list sorted by time (earliest event first).
 */

typedef struct TimerHandler {
    Tcl_Time time;		/* When timer is to fire. */
    Tcl_TimerProc *proc;	/* Function to call. */
    ClientData clientData;	/* Argument to pass to proc. */
    Tcl_TimerToken token;	/* Identifies handler so it can be deleted. */

    struct TimerHandler *nextPtr;
				/* Next event in queue, or NULL for end of
				 * queue. */
} TimerHandler;

/*
 * The data structure below is used by the "after" command to remember the
 * command to be executed later. All of the pending "after" commands for an
 * interpreter are linked together in a list.
 */

typedef struct AfterInfo {
    struct AfterAssocData *assocPtr;
				/* Pointer to the "tclAfter" assocData for the
				 * interp in which command will be
				 * executed. */
    Tcl_Obj *commandPtr;	/* Command to execute. */
    int id;			/* Integer identifier for command; used to
				 * cancel it. */
    Tcl_TimerToken token;	/* Used to cancel the "after" command. NULL
				 * means that the command is run as an idle
				 * handler rather than as a timer handler.
				 * NULL means this is an "after idle" handler

				 * rather than a timer handler. */
    struct AfterInfo *nextPtr;	/* Next in list of all "after" commands for
				 * this interpreter. */
} AfterInfo;

/*
 * One of the following structures is associated with each interpreter for
 * which an "after" command has ever been invoked. A pointer to this structure
 * is stored in the AssocData for the "tclAfter" key.
 */

typedef struct AfterAssocData {
    Tcl_Interp *interp;		/* The interpreter for which this data is
				 * registered. */
    AfterInfo *firstAfterPtr;	/* First in list of all "after" commands still
				 * pending for this interpreter, or NULL if
				 * none. */
} AfterAssocData;

/*
 * There is one of the following structures for each of the handlers declared
 * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are
 * linked together into a list.
 */

typedef struct IdleHandler {
    Tcl_IdleProc (*proc);	/* Function to call. */
    ClientData clientData;	/* Value to pass to proc. */
    int generation;		/* Used to distinguish older handlers from
				 * recently-created ones. */
    struct IdleHandler *nextPtr;/* Next in list of active handlers. */
} IdleHandler;

/*
 * The timer and idle queues are per-thread because they are associated with
 * the notifier, which is also per-thread.
 *
 * All static variables used in this file are collected into a single instance
 * of the following structure. For multi-threaded implementations, there is
 * one instance of this structure for each thread.
 *
 * Notice that different structures with the same name appear in other files.
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData {
    TimerHandler *firstTimerHandlerPtr;	/* First event in queue. */
    int lastTimerId;		/* Timer identifier of most recently created
				 * timer. */
    int timerPending;		/* 1 if a timer event is in the queue. */
    IdleHandler *idleList;	/* First in list of all idle handlers. */
    IdleHandler *lastIdlePtr;	/* Last in list (or NULL for empty list). */
    int idleGeneration;		/* Used to fill in the "generation" fields of
				 * IdleHandler structures. Increments each
				 * time Tcl_DoOneEvent starts calling idle
				 * handlers, so that all old handlers can be
				 * called without calling any of the new ones
				 * created by old ones. */
    int afterId;		/* For unique identifiers of after events. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write
 * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes
 * the number of milliseconds difference between two times. Both macros use
 * both of their arguments multiple times, so make sure they are cheap and
 * side-effect free. The "prototypes" for these macros are:
 *
 * static int	TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2);
 * static long	TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2);
 */

#define TCL_TIME_BEFORE(t1, t2) \
    (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec))

#define TCL_TIME_DIFF_MS(t1, t2) \
    (1000*((long)(t1).sec - (long)(t2).sec) + \
	    ((long)(t1).usec - (long)(t2).usec)/1000)

/*
 * Prototypes for functions referenced only in this file:
 */

static void		AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static int		AfterDelay _ANSI_ARGS_((Tcl_Interp *interp, int ms));
static void		AfterProc _ANSI_ARGS_((ClientData clientData));
static void		FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
static AfterInfo *	GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
			    Tcl_Obj *commandPtr));
static ThreadSpecificData *InitTimer _ANSI_ARGS_((void));
static void		TimerExitProc _ANSI_ARGS_((ClientData clientData));
static int		TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

245

246































247
248
249

250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
 *
 *----------------------------------------------------------------------
 */

static ThreadSpecificData *
InitTimer()
{
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);

    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
	Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
    }
    return tsdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TimerExitProc --
 *
 *	This function is call at exit or unload time to remove the
 *	timer and idle event sources.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the timer and idle event sources and remaining events.
 *
 *----------------------------------------------------------------------
 */

static void
TimerExitProc(clientData)
    ClientData clientData;	/* Not used. */
{
    ThreadSpecificData *tsdPtr =
	(ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);

    Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
    if (tsdPtr != NULL) {
	register TimerHandler *timerHandlerPtr;

	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	while (timerHandlerPtr != NULL) {
	    tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
	    ckfree((char *) timerHandlerPtr);
	    timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	}
    }
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_CreateTimerHandler --
 *
 *	Arrange for a given procedure to be invoked at a particular
 *	time in the future.
 *
 * Results:
 *	The return value is a token for the timer event, which
 *	may be used to delete the event before it fires.
 *
 * Side effects:
 *	When milliseconds have elapsed, proc will be invoked
 *	exactly once.
 *
 *--------------------------------------------------------------
 */

Tcl_TimerToken
Tcl_CreateTimerHandler(milliseconds, proc, clientData)
    int milliseconds;		/* How many milliseconds to wait
				 * before invoking proc. */
    Tcl_TimerProc *proc;	/* Procedure to invoke. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
    Tcl_Time time;
    ThreadSpecificData *tsdPtr;

    tsdPtr = InitTimer();

    timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));

    /*
     * Compute when the event should fire.
     */

    Tcl_GetTime(&time);
    timerHandlerPtr->time.sec = time.sec + milliseconds/1000;
    timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000;
    if (timerHandlerPtr->time.usec >= 1000000) {
	timerHandlerPtr->time.usec -= 1000000;
	timerHandlerPtr->time.sec += 1;
    }



    /*































     * Fill in other fields for the event.
     */


    timerHandlerPtr->proc = proc;
    timerHandlerPtr->clientData = clientData;
    tsdPtr->lastTimerId++;
    timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId;

    /*
     * Add the event to the queue in the correct position
     * (ordered by event firing time).
     */

    for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
	    prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
	if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
		|| ((tPtr2->time.sec == timerHandlerPtr->time.sec)
		&& (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
	    break;
	}
    }
    timerHandlerPtr->nextPtr = tPtr2;
    if (prevPtr == NULL) {
	tsdPtr->firstTimerHandlerPtr = timerHandlerPtr;
    } else {







|
|














|
|














|
|




>














|
|


|
|


|
<






|
|
|


<

<
<
<
<
<






|
|
|
|
|

>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|


>












|
<
<







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

233
234
235
236
237
238
239
240
241
242
243

244





245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308


309
310
311
312
313
314
315
 *
 *----------------------------------------------------------------------
 */

static ThreadSpecificData *
InitTimer()
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
	Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
    }
    return tsdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TimerExitProc --
 *
 *	This function is call at exit or unload time to remove the timer and
 *	idle event sources.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the timer and idle event sources and remaining events.
 *
 *----------------------------------------------------------------------
 */

static void
TimerExitProc(clientData)
    ClientData clientData;	/* Not used. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
    if (tsdPtr != NULL) {
	register TimerHandler *timerHandlerPtr;

	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	while (timerHandlerPtr != NULL) {
	    tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
	    ckfree((char *) timerHandlerPtr);
	    timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	}
    }
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_CreateTimerHandler --
 *
 *	Arrange for a given function to be invoked at a particular time in the
 *	future.
 *
 * Results:
 *	The return value is a token for the timer event, which may be used to
 *	delete the event before it fires.
 *
 * Side effects:
 *	When milliseconds have elapsed, proc will be invoked exactly once.

 *
 *--------------------------------------------------------------
 */

Tcl_TimerToken
Tcl_CreateTimerHandler(milliseconds, proc, clientData)
    int milliseconds;		/* How many milliseconds to wait before
				 * invoking proc. */
    Tcl_TimerProc *proc;	/* Function to invoke. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{

    Tcl_Time time;






    /*
     * Compute when the event should fire.
     */

    Tcl_GetTime(&time);
    time.sec += milliseconds/1000;
    time.usec += (milliseconds%1000)*1000;
    if (time.usec >= 1000000) {
	time.usec -= 1000000;
	time.sec += 1;
    }
    return TclCreateAbsoluteTimerHandler(&time, proc, clientData);
}

/*
 *--------------------------------------------------------------
 *
 * TclCreateAbsoluteTimerHandler --
 *
 *	Arrange for a given function to be invoked at a particular time in the
 *	future.
 *
 * Results:
 *	The return value is a token for the timer event, which may be used to
 *	delete the event before it fires.
 *
 * Side effects:
 *	When the time in timePtr has been reached, proc will be invoked
 *	exactly once.
 *
 *--------------------------------------------------------------
 */

Tcl_TimerToken
TclCreateAbsoluteTimerHandler(timePtr, proc, clientData)
    Tcl_Time *timePtr;
    Tcl_TimerProc *proc;
    ClientData clientData;
{
    register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
    ThreadSpecificData *tsdPtr;

    tsdPtr = InitTimer();
    timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));

    /*
     * Fill in fields for the event.
     */

    memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time));
    timerHandlerPtr->proc = proc;
    timerHandlerPtr->clientData = clientData;
    tsdPtr->lastTimerId++;
    timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId;

    /*
     * Add the event to the queue in the correct position
     * (ordered by event firing time).
     */

    for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
	    prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
	if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {


	    break;
	}
    }
    timerHandlerPtr->nextPtr = tPtr2;
    if (prevPtr == NULL) {
	tsdPtr->firstTimerHandlerPtr = timerHandlerPtr;
    } else {
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306



307
308
309
310
311
312
313
314
 *
 *	Delete a previously-registered timer handler.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroy the timer callback identified by TimerToken,
 *	so that its associated procedure will not be called.
 *	If the callback has already fired, or if the given
 *	token doesn't exist, then nothing happens.
 *
 *--------------------------------------------------------------
 */

void
Tcl_DeleteTimerHandler(token)
    Tcl_TimerToken token;	/* Result previously returned by
				 * Tcl_DeleteTimerHandler. */
{
    register TimerHandler *timerHandlerPtr, *prevPtr;
    ThreadSpecificData *tsdPtr;




    tsdPtr = InitTimer();
    for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
	    timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
	    timerHandlerPtr = timerHandlerPtr->nextPtr) {
	if (timerHandlerPtr->token != token) {
	    continue;
	}
	if (prevPtr == NULL) {







|
<
|
|










|

>
>
>
|







328
329
330
331
332
333
334
335

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
 *
 *	Delete a previously-registered timer handler.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroy the timer callback identified by TimerToken, so that its

 *	associated function will not be called. If the callback has already
 *	fired, or if the given token doesn't exist, then nothing happens.
 *
 *--------------------------------------------------------------
 */

void
Tcl_DeleteTimerHandler(token)
    Tcl_TimerToken token;	/* Result previously returned by
				 * Tcl_DeleteTimerHandler. */
{
    register TimerHandler *timerHandlerPtr, *prevPtr;
    ThreadSpecificData *tsdPtr = InitTimer();

    if (token == NULL) {
	return;
    }

    for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
	    timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
	    timerHandlerPtr = timerHandlerPtr->nextPtr) {
	if (timerHandlerPtr->token != token) {
	    continue;
	}
	if (prevPtr == NULL) {
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
}

/*
 *----------------------------------------------------------------------
 *
 * TimerSetupProc --
 *
 *	This function is called by Tcl_DoOneEvent to setup the timer
 *	event source for before blocking.  This routine checks both the
 *	idle and after timer lists.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May update the maximum notifier block time.
 *







|
|
|







368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
}

/*
 *----------------------------------------------------------------------
 *
 * TimerSetupProc --
 *
 *	This function is called by Tcl_DoOneEvent to setup the timer event
 *	source for before blocking. This routine checks both the idle and
 *	after timer lists.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May update the maximum notifier block time.
 *
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
	if (blockTime.sec < 0) {
	    blockTime.sec = 0;
	    blockTime.usec = 0;
	}
    } else {
	return;
    }
	
    Tcl_SetMaxBlockTime(&blockTime);
}

/*
 *----------------------------------------------------------------------
 *
 * TimerCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the timer
 *	event source for events.  This routine checks both the
 *	idle and after timer lists.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event and update the maximum notifier block time.
 *







|








|
|
|







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
	if (blockTime.sec < 0) {
	    blockTime.sec = 0;
	    blockTime.usec = 0;
	}
    } else {
	return;
    }

    Tcl_SetMaxBlockTime(&blockTime);
}

/*
 *----------------------------------------------------------------------
 *
 * TimerCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the timer event
 *	source for events. This routine checks both the idle and after timer
 *	lists.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event and update the maximum notifier block time.
 *
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
}

/*
 *----------------------------------------------------------------------
 *
 * TimerHandlerEventProc --
 *
 *	This procedure is called by Tcl_ServiceEvent when a timer event
 *	reaches the front of the event queue.  This procedure handles
 *	the event by invoking the callbacks for all timers that are
 *	ready.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_TIMER_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the timer handler callback procedures do.
 *
 *----------------------------------------------------------------------
 */

static int
TimerHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    TimerHandler *timerHandlerPtr, **nextPtrPtr;
    Tcl_Time time;
    int currentTimerId;
    ThreadSpecificData *tsdPtr = InitTimer();

    /*
     * Do nothing if timers aren't enabled.  This leaves the event on the
     * queue, so we will get to it as soon as ServiceEvents() is called
     * with timers enabled.
     */

    if (!(flags & TCL_TIMER_EVENTS)) {
	return 0;
    }

    /*
     * The code below is trickier than it may look, for the following
     * reasons:
     *
     * 1. New handlers can get added to the list while the current
     *    one is being processed.  If new ones get added, we don't
     *    want to process them during this pass through the list to avoid
     *	  starving other event sources.  This is implemented using the
     *	  token number in the handler:  new handlers will have a
     *    newer token than any of the ones currently on the list.
     * 2. The handler can call Tcl_DoOneEvent, so we have to remove
     *    the handler from the list before calling it. Otherwise an
     *    infinite loop could result.
     * 3. Tcl_DeleteTimerHandler can be called to remove an element from
     *    the list while a handler is executing, so the list could
     *    change structure during the call.
     * 4. Because we only fetch the current time before entering the loop,
     *    the only way a new timer will even be considered runnable is if
     *	  its expiration time is within the same millisecond as the
     *	  current time.  This is fairly likely on Windows, since it has
     *	  a course granularity clock.  Since timers are placed
     *	  on the queue in time order with the most recently created
     *    handler appearing after earlier ones with the same expiration
     *	  time, we don't have to worry about newer generation timers
     *	  appearing before later ones.
     */

    tsdPtr->timerPending = 0;
    currentTimerId = tsdPtr->lastTimerId;
    Tcl_GetTime(&time);
    while (1) {
	nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	if (timerHandlerPtr == NULL) {
	    break;
	}
	    
	if ((timerHandlerPtr->time.sec > time.sec)
		|| ((timerHandlerPtr->time.sec == time.sec)
			&& (timerHandlerPtr->time.usec > time.usec))) {
	    break;
	}

	/*
	 * Bail out if the next timer is of a newer generation.
	 */

	if ((currentTimerId - (int)timerHandlerPtr->token) < 0) {
	    break;
	}

	/*
	 * Remove the handler from the queue before invoking it,
	 * to avoid potential reentrancy problems.
	 */

	(*nextPtrPtr) = timerHandlerPtr->nextPtr;
	(*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
	ckfree((char *) timerHandlerPtr);
    }
    TimerSetupProc(NULL, TCL_TIMER_EVENTS);
    return 1;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_DoWhenIdle --
 *
 *	Arrange for proc to be invoked the next time the system is
 *	idle (i.e., just before the next time that Tcl_DoOneEvent
 *	would have to wait for something to happen).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Proc will eventually be called, with clientData as argument.
 *	See the manual entry for details.
 *
 *--------------------------------------------------------------
 */

void
Tcl_DoWhenIdle(proc, clientData)
    Tcl_IdleProc *proc;		/* Procedure to invoke. */
    ClientData clientData;	/* Arbitrary value to pass to proc. */
{
    register IdleHandler *idlePtr;
    Tcl_Time blockTime;
    ThreadSpecificData *tsdPtr = InitTimer();

    idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));







|
|
|
<


|
|
|
|


|







|
|







|
|
|







|
<

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|











|
|
<
<












|
|















|
|
|





|
|






|







486
487
488
489
490
491
492
493
494
495

496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548

549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565


566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
}

/*
 *----------------------------------------------------------------------
 *
 * TimerHandlerEventProc --
 *
 *	This function is called by Tcl_ServiceEvent when a timer event reaches
 *	the front of the event queue. This function handles the event by
 *	invoking the callbacks for all timers that are ready.

 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_TIMER_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the timer handler callback functions do.
 *
 *----------------------------------------------------------------------
 */

static int
TimerHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    TimerHandler *timerHandlerPtr, **nextPtrPtr;
    Tcl_Time time;
    int currentTimerId;
    ThreadSpecificData *tsdPtr = InitTimer();

    /*
     * Do nothing if timers aren't enabled. This leaves the event on the
     * queue, so we will get to it as soon as ServiceEvents() is called with
     * timers enabled.
     */

    if (!(flags & TCL_TIMER_EVENTS)) {
	return 0;
    }

    /*
     * The code below is trickier than it may look, for the following reasons:

     *
     * 1. New handlers can get added to the list while the current one is
     *	  being processed. If new ones get added, we don't want to process
     *	  them during this pass through the list to avoid starving other event
     *	  sources. This is implemented using the token number in the handler:
     *	  new handlers will have a newer token than any of the ones currently
     *	  on the list.
     * 2. The handler can call Tcl_DoOneEvent, so we have to remove the
     *	  handler from the list before calling it. Otherwise an infinite loop
     *	  could result.
     * 3. Tcl_DeleteTimerHandler can be called to remove an element from the
     *	  list while a handler is executing, so the list could change
     *	  structure during the call.
     * 4. Because we only fetch the current time before entering the loop, the
     *	  only way a new timer will even be considered runnable is if its
     *	  expiration time is within the same millisecond as the current time.
     *	  This is fairly likely on Windows, since it has a course granularity

     *	  clock. Since timers are placed on the queue in time order with the
     *	  most recently created handler appearing after earlier ones with the
     *	  same expiration time, we don't have to worry about newer generation
     *	  timers appearing before later ones.
     */

    tsdPtr->timerPending = 0;
    currentTimerId = tsdPtr->lastTimerId;
    Tcl_GetTime(&time);
    while (1) {
	nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	if (timerHandlerPtr == NULL) {
	    break;
	}

	if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) {


	    break;
	}

	/*
	 * Bail out if the next timer is of a newer generation.
	 */

	if ((currentTimerId - (int)timerHandlerPtr->token) < 0) {
	    break;
	}

	/*
	 * Remove the handler from the queue before invoking it, to avoid
	 * potential reentrancy problems.
	 */

	(*nextPtrPtr) = timerHandlerPtr->nextPtr;
	(*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
	ckfree((char *) timerHandlerPtr);
    }
    TimerSetupProc(NULL, TCL_TIMER_EVENTS);
    return 1;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_DoWhenIdle --
 *
 *	Arrange for proc to be invoked the next time the system is idle (i.e.,
 *	just before the next time that Tcl_DoOneEvent would have to wait for
 *	something to happen).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Proc will eventually be called, with clientData as argument. See the
 *	manual entry for details.
 *
 *--------------------------------------------------------------
 */

void
Tcl_DoWhenIdle(proc, clientData)
    Tcl_IdleProc *proc;		/* Function to invoke. */
    ClientData clientData;	/* Arbitrary value to pass to proc. */
{
    register IdleHandler *idlePtr;
    Tcl_Time blockTime;
    ThreadSpecificData *tsdPtr = InitTimer();

    idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CancelIdleCall --
 *
 *	If there are any when-idle calls requested to a given procedure
 *	with given clientData, cancel all of them.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the proc/clientData combination were on the when-idle list,
 *	they are removed so that they will never be called.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CancelIdleCall(proc, clientData)
    Tcl_IdleProc *proc;		/* Procedure that was previously registered. */
    ClientData clientData;	/* Arbitrary value to pass to proc. */
{
    register IdleHandler *idlePtr, *prevPtr;
    IdleHandler *nextPtr;
    ThreadSpecificData *tsdPtr = InitTimer();

    for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;







|
|





|
|






|







633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CancelIdleCall --
 *
 *	If there are any when-idle calls requested to a given function with
 *	given clientData, cancel all of them.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the proc/clientData combination were on the when-idle list, they
 *	are removed so that they will never be called.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CancelIdleCall(proc, clientData)
    Tcl_IdleProc *proc;		/* Function that was previously registered. */
    ClientData clientData;	/* Arbitrary value to pass to proc. */
{
    register IdleHandler *idlePtr, *prevPtr;
    IdleHandler *nextPtr;
    ThreadSpecificData *tsdPtr = InitTimer();

    for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
}

/*
 *----------------------------------------------------------------------
 *
 * TclServiceIdle --
 *
 *	This procedure is invoked by the notifier when it becomes
 *	idle.  It will invoke all idle handlers that are present at
 *	the time the call is invoked, but not those added during idle
 *	processing.
 *
 * Results:
 *	The return value is 1 if TclServiceIdle found something to
 *	do, otherwise return value is 0.
 *
 * Side effects:
 *	Invokes all pending idle handlers.
 *
 *----------------------------------------------------------------------
 */








|
|
|
<


|
|







680
681
682
683
684
685
686
687
688
689

690
691
692
693
694
695
696
697
698
699
700
}

/*
 *----------------------------------------------------------------------
 *
 * TclServiceIdle --
 *
 *	This function is invoked by the notifier when it becomes idle. It will
 *	invoke all idle handlers that are present at the time the call is
 *	invoked, but not those added during idle processing.

 *
 * Results:
 *	The return value is 1 if TclServiceIdle found something to do,
 *	otherwise return value is 0.
 *
 * Side effects:
 *	Invokes all pending idle handlers.
 *
 *----------------------------------------------------------------------
 */

670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
	return 0;
    }

    oldGeneration = tsdPtr->idleGeneration;
    tsdPtr->idleGeneration++;

    /*
     * The code below is trickier than it may look, for the following
     * reasons:
     *
     * 1. New handlers can get added to the list while the current
     *    one is being processed.  If new ones get added, we don't
     *    want to process them during this pass through the list (want
     *    to check for other work to do first).  This is implemented
     *    using the generation number in the handler:  new handlers
     *    will have a different generation than any of the ones currently
     *    on the list.
     * 2. The handler can call Tcl_DoOneEvent, so we have to remove
     *    the handler from the list before calling it. Otherwise an
     *    infinite loop could result.
     * 3. Tcl_CancelIdleCall can be called to remove an element from
     *    the list while a handler is executing, so the list could
     *    change structure during the call.
     */

    for (idlePtr = tsdPtr->idleList;
	    ((idlePtr != NULL)
		    && ((oldGeneration - idlePtr->generation) >= 0));
	    idlePtr = tsdPtr->idleList) {
	tsdPtr->idleList = idlePtr->nextPtr;







|
<

|
|
|
<
|
|
|
|
|
|
|
|
|







710
711
712
713
714
715
716
717

718
719
720
721

722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
	return 0;
    }

    oldGeneration = tsdPtr->idleGeneration;
    tsdPtr->idleGeneration++;

    /*
     * The code below is trickier than it may look, for the following reasons:

     *
     * 1. New handlers can get added to the list while the current one is
     *	  being processed. If new ones get added, we don't want to process
     *	  them during this pass through the list (want to check for other work

     *	  to do first). This is implemented using the generation number in the
     *	  handler: new handlers will have a different generation than any of
     *	  the ones currently on the list.
     * 2. The handler can call Tcl_DoOneEvent, so we have to remove the
     *	  handler from the list before calling it. Otherwise an infinite loop
     *	  could result.
     * 3. Tcl_CancelIdleCall can be called to remove an element from the list
     *	  while a handler is executing, so the list could change structure
     *	  during the call.
     */

    for (idlePtr = tsdPtr->idleList;
	    ((idlePtr != NULL)
		    && ((oldGeneration - idlePtr->generation) >= 0));
	    idlePtr = tsdPtr->idleList) {
	tsdPtr->idleList = idlePtr->nextPtr;
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AfterObjCmd --
 *
 *	This procedure is invoked to process the "after" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AfterObjCmd --
 *
 *	This function is invoked to process the "after" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
742
743
744
745
746
747
748

749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
    int length;
    char *argString;
    int index;
    char buf[16 + TCL_INTEGER_SPACE];
    static CONST char *afterSubCmds[] = {
	"cancel", "idle", "info", (char *) NULL
    };

    enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
    ThreadSpecificData *tsdPtr = InitTimer();

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    /*
     * Create the "after" information associated for this interpreter,
     * if it doesn't already exist.  Associate it with the command too,
     * so that it will be passed in as the ClientData argument in the
     * future.
     */

    assocPtr = Tcl_GetAssocData( interp, "tclAfter", NULL );
    if (assocPtr == NULL) {
	assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
	assocPtr->interp = interp;
	assocPtr->firstAfterPtr = NULL;
	Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
		(ClientData) assocPtr);
    }







>









|
|
<
<


|







780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798


799
800
801
802
803
804
805
806
807
808
    int length;
    char *argString;
    int index;
    char buf[16 + TCL_INTEGER_SPACE];
    static CONST char *afterSubCmds[] = {
	"cancel", "idle", "info", (char *) NULL
    };
    Tcl_Obj *objPtr;
    enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
    ThreadSpecificData *tsdPtr = InitTimer();

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    /*
     * Create the "after" information associated for this interpreter, if it
     * doesn't already exist.


     */

    assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
    if (assocPtr == NULL) {
	assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
	assocPtr->interp = interp;
	assocPtr->firstAfterPtr = NULL;
	Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
		(ClientData) assocPtr);
    }
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801

802
803
804
805
806
807
808
809
810

811
812
813
814
815
816

817
818
819
820
821
822
823

824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893

894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929



























































930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
	goto processInteger;
    }
    argString = Tcl_GetStringFromObj(objv[1], &length);
    if (isdigit(UCHAR(argString[0]))) {	/* INTL: digit */
	if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
	    return TCL_ERROR;
	}
processInteger:
	if (ms < 0) {
	    ms = 0;
	}
	if (objc == 2) {
	    Tcl_Sleep(ms);
	    return TCL_OK;
	}
	afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
	afterPtr->assocPtr = assocPtr;
	if (objc == 3) {
	    afterPtr->commandPtr = objv[2];
	} else {
 	    afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
	}
	Tcl_IncrRefCount(afterPtr->commandPtr);

	/*
	 * The variable below is used to generate unique identifiers for
	 * after commands.  This id can wrap around, which can potentially
	 * cause problems.  However, there are not likely to be problems
	 * in practice, because after commands can only be requested to
	 * about a month in the future, and wrap-around is unlikely to
	 * occur in less than about 1-10 years.  Thus it's unlikely that
	 * any old ids will still be around when wrap-around occurs.
	 */

	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
		(ClientData) afterPtr);
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;

	sprintf(buf, "after#%d", afterPtr->id);
	Tcl_AppendResult(interp, buf, (char *) NULL);
	return TCL_OK;
    }

    /*
     * If it's not a number it must be a subcommand.

     */

    if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument",
            0, &index) != TCL_OK) {
	Tcl_AppendResult(interp, "bad argument \"", argString,
		"\": must be cancel, idle, info, or a number",
		(char *) NULL);
	return TCL_ERROR;
    }
    switch ((enum afterSubCmds) index) {
        case AFTER_CANCEL: {
	    Tcl_Obj *commandPtr;
	    char *command, *tempCommand;
	    int tempLength;

	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "id|command");
		return TCL_ERROR;
	    }
	    if (objc == 3) {
		commandPtr = objv[2];
	    } else {
		commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
	    }
	    command = Tcl_GetStringFromObj(commandPtr, &length);
	    for (afterPtr = assocPtr->firstAfterPtr;  afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {
		tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
			&tempLength);
		if ((length == tempLength)
		        && (memcmp((void*) command, (void*) tempCommand,
			        (unsigned) length) == 0)) {
		    break;
		}
	    }
	    if (afterPtr == NULL) {
		afterPtr = GetAfterEvent(assocPtr, commandPtr);
	    }
	    if (objc != 3) {
		Tcl_DecrRefCount(commandPtr);
	    }
	    if (afterPtr != NULL) {
		if (afterPtr->token != NULL) {
		    Tcl_DeleteTimerHandler(afterPtr->token);
		} else {
		    Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
		}
		FreeAfterPtr(afterPtr);
	    }
	    break;
	}
	case AFTER_IDLE:
	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
		return TCL_ERROR;
	    }
	    afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
	    afterPtr->assocPtr = assocPtr;
	    if (objc == 3) {
 		afterPtr->commandPtr = objv[2];
	    } else {
		afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
	    }
	    Tcl_IncrRefCount(afterPtr->commandPtr);
	    afterPtr->id = tsdPtr->afterId;
	    tsdPtr->afterId += 1;
	    afterPtr->token = NULL;
	    afterPtr->nextPtr = assocPtr->firstAfterPtr;
	    assocPtr->firstAfterPtr = afterPtr;
	    Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);

	    sprintf(buf, "after#%d", afterPtr->id);
	    Tcl_AppendResult(interp, buf, (char *) NULL);
	    break;
	case AFTER_INFO: {
	    Tcl_Obj *resultListPtr;

	    if (objc == 2) {
		for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		     afterPtr = afterPtr->nextPtr) {
		    if (assocPtr->interp == interp) {
			sprintf(buf, "after#%d", afterPtr->id);
			Tcl_AppendElement(interp, buf);
		    }
		}
		return TCL_OK;
	    }
	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "?id?");
		return TCL_ERROR;
	    }
	    afterPtr = GetAfterEvent(assocPtr, objv[2]);
	    if (afterPtr == NULL) {
		Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
			"\" doesn't exist", (char *) NULL);
		return TCL_ERROR;
	    }
	    resultListPtr = Tcl_NewObj();
 	    Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
 	    Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
 		(afterPtr->token == NULL) ? "idle" : "timer", -1));
	    Tcl_SetObjResult(interp, resultListPtr);
	    break;
	}
	default: {
	    Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
	}



























































    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetAfterEvent --
 *
 *	This procedure parses an "after" id such as "after#4" and
 *	returns a pointer to the AfterInfo structure.
 *
 * Results:
 *	The return value is either a pointer to an AfterInfo structure,
 *	if one is found that corresponds to "cmdString" and is for interp,
 *	or NULL if no corresponding after event can be found.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static AfterInfo *
GetAfterEvent(assocPtr, commandPtr)
    AfterAssocData *assocPtr;	/* Points to "after"-related information for
				 * this interpreter. */
    Tcl_Obj *commandPtr;
{
    char *cmdString;		/* Textual identifier for after event, such
				 * as "after#6". */
    AfterInfo *afterPtr;
    int id;
    char *end;

    cmdString = Tcl_GetString(commandPtr);
    if (strncmp(cmdString, "after#", 6) != 0) {
	return NULL;







|




<
|









>

|
|
|
|
|
|
|

>






>
|
|




|
>


|
|






|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
|


|
|
|













|
|







816
817
818
819
820
821
822
823
824
825
826
827

828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
	goto processInteger;
    }
    argString = Tcl_GetStringFromObj(objv[1], &length);
    if (isdigit(UCHAR(argString[0]))) {	/* INTL: digit */
	if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
	    return TCL_ERROR;
	}
    processInteger:
	if (ms < 0) {
	    ms = 0;
	}
	if (objc == 2) {

	    return AfterDelay(interp, ms);
	}
	afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
	afterPtr->assocPtr = assocPtr;
	if (objc == 3) {
	    afterPtr->commandPtr = objv[2];
	} else {
 	    afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
	}
	Tcl_IncrRefCount(afterPtr->commandPtr);

	/*
	 * The variable below is used to generate unique identifiers for after
	 * commands. This id can wrap around, which can potentially cause
	 * problems. However, there are not likely to be problems in practice,
	 * because after commands can only be requested to about a month in
	 * the future, and wrap-around is unlikely to occur in less than about
	 * 1-10 years. Thus it's unlikely that any old ids will still be
	 * around when wrap-around occurs.
	 */

	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
		(ClientData) afterPtr);
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id);
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }

    /*
     * If it's not a number it must be a subcommand. Note that we're using a
     * custom error message here, so we do not pass an interpreter to T_GIFO.
     */

    if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", 0,
	    &index) != TCL_OK) {
	Tcl_AppendResult(interp, "bad argument \"", argString,
		"\": must be cancel, idle, info, or a number",
		(char *) NULL);
	return TCL_ERROR;
    }
    switch ((enum afterSubCmds) index) {
    case AFTER_CANCEL: {
	Tcl_Obj *commandPtr;
	char *command, *tempCommand;
	int tempLength;

	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "id|command");
	    return TCL_ERROR;
	}
	if (objc == 3) {
	    commandPtr = objv[2];
	} else {
	    commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
	}
	command = Tcl_GetStringFromObj(commandPtr, &length);
	for (afterPtr = assocPtr->firstAfterPtr;  afterPtr != NULL;
		afterPtr = afterPtr->nextPtr) {
	    tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
		    &tempLength);
	    if ((length == tempLength)
		    && (memcmp((void*) command, (void*) tempCommand,
			    (unsigned) length) == 0)) {
		break;
	    }
	}
	if (afterPtr == NULL) {
	    afterPtr = GetAfterEvent(assocPtr, commandPtr);
	}
	if (objc != 3) {
	    Tcl_DecrRefCount(commandPtr);
	}
	if (afterPtr != NULL) {
	    if (afterPtr->token != NULL) {
		Tcl_DeleteTimerHandler(afterPtr->token);
	    } else {
		Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
	    }
	    FreeAfterPtr(afterPtr);
	}
	break;
    }
    case AFTER_IDLE:
	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
	    return TCL_ERROR;
	}
	afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
	afterPtr->assocPtr = assocPtr;
	if (objc == 3) {
	    afterPtr->commandPtr = objv[2];
	} else {
	    afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
	}
	Tcl_IncrRefCount(afterPtr->commandPtr);
	afterPtr->id = tsdPtr->afterId;
	tsdPtr->afterId += 1;
	afterPtr->token = NULL;
	afterPtr->nextPtr = assocPtr->firstAfterPtr;
	assocPtr->firstAfterPtr = afterPtr;
	Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
	objPtr = Tcl_NewObj();
	TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id);
	Tcl_SetObjResult(interp, objPtr);
	break;
    case AFTER_INFO: {
	Tcl_Obj *resultListPtr;

	if (objc == 2) {
	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
		    afterPtr = afterPtr->nextPtr) {
		if (assocPtr->interp == interp) {
		    sprintf(buf, "after#%d", afterPtr->id);
		    Tcl_AppendElement(interp, buf);
		}
	    }
	    return TCL_OK;
	}
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?id?");
	    return TCL_ERROR;
	}
	afterPtr = GetAfterEvent(assocPtr, objv[2]);
	if (afterPtr == NULL) {
	    Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
		    "\" doesn't exist", (char *) NULL);
	    return TCL_ERROR;
	}
	resultListPtr = Tcl_NewObj();
	Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
	Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
 		(afterPtr->token == NULL) ? "idle" : "timer", -1));
	Tcl_SetObjResult(interp, resultListPtr);
	break;
    }
    default:
	Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AfterDelay --
 *
 *	Implements the blocking delay behaviour of [after $time]. Tricky
 *	because it has to take into account any time limit that has been set.
 *
 * Results:
 *	Standard Tcl result code (with error set if an error occurred due to a
 *	time limit being exceeded).
 *
 * Side effects:
 *	May adjust the time limit granularity marker.
 *
 *----------------------------------------------------------------------
 */

static int
AfterDelay(interp, ms)
    Tcl_Interp *interp;
    int ms;
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr->limit.timeEvent != NULL) {
	Tcl_Time endTime, now;

	Tcl_GetTime(&endTime);
	endTime.sec += ms/1000;
	endTime.usec += (ms%1000)*1000;
	if (endTime.usec >= 1000000) {
	    endTime.sec++;
	    endTime.usec -= 1000000;
	}

	do {
	    Tcl_GetTime(&now);
	    if (TCL_TIME_BEFORE(iPtr->limit.time, now)) {
		iPtr->limit.granularityTicker = 0;
		if (Tcl_LimitCheck(interp) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
		Tcl_Sleep(TCL_TIME_DIFF_MS(endTime, now));
		break;
	    } else {
		Tcl_Sleep(TCL_TIME_DIFF_MS(iPtr->limit.time, now));
		if (Tcl_LimitCheck(interp) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	} while (TCL_TIME_BEFORE(now, endTime));
    } else {
	Tcl_Sleep(ms);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetAfterEvent --
 *
 *	This function parses an "after" id such as "after#4" and returns a
 *	pointer to the AfterInfo structure.
 *
 * Results:
 *	The return value is either a pointer to an AfterInfo structure, if one
 *	is found that corresponds to "cmdString" and is for interp, or NULL if
 *	no corresponding after event can be found.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static AfterInfo *
GetAfterEvent(assocPtr, commandPtr)
    AfterAssocData *assocPtr;	/* Points to "after"-related information for
				 * this interpreter. */
    Tcl_Obj *commandPtr;
{
    char *cmdString;		/* Textual identifier for after event, such as
				 * "after#6". */
    AfterInfo *afterPtr;
    int id;
    char *end;

    cmdString = Tcl_GetString(commandPtr);
    if (strncmp(cmdString, "after#", 6) != 0) {
	return NULL;
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
}

/*
 *----------------------------------------------------------------------
 *
 * AfterProc --
 *
 *	Timer callback to execute commands registered with the
 *	"after" command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Executes whatever command was specified.  If the command
 *	returns an error, then the command "bgerror" is invoked
 *	to process the error;  if bgerror fails then information
 *	about the error is output on stderr.
 *
 *----------------------------------------------------------------------
 */

static void
AfterProc(clientData)
    ClientData clientData;	/* Describes command to execute. */
{
    AfterInfo *afterPtr = (AfterInfo *) clientData;
    AfterAssocData *assocPtr = afterPtr->assocPtr;
    AfterInfo *prevPtr;
    int result;
    Tcl_Interp *interp;
    char *script;
    int numBytes;

    /*
     * First remove the callback from our list of callbacks;  otherwise
     * someone could delete the callback while it's being executed, which
     * could cause a core dump.
     */

    if (assocPtr->firstAfterPtr == afterPtr) {
	assocPtr->firstAfterPtr = afterPtr->nextPtr;
    } else {
	for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
		prevPtr = prevPtr->nextPtr) {







|
|





|
|
<
|

















|
|
|







1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096

1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
}

/*
 *----------------------------------------------------------------------
 *
 * AfterProc --
 *
 *	Timer callback to execute commands registered with the "after"
 *	command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Executes whatever command was specified. If the command returns an
 *	error, then the command "bgerror" is invoked to process the error; if

 *	bgerror fails then information about the error is output on stderr.
 *
 *----------------------------------------------------------------------
 */

static void
AfterProc(clientData)
    ClientData clientData;	/* Describes command to execute. */
{
    AfterInfo *afterPtr = (AfterInfo *) clientData;
    AfterAssocData *assocPtr = afterPtr->assocPtr;
    AfterInfo *prevPtr;
    int result;
    Tcl_Interp *interp;
    char *script;
    int numBytes;

    /*
     * First remove the callback from our list of callbacks; otherwise someone
     * could delete the callback while it's being executed, which could cause
     * a core dump.
     */

    if (assocPtr->firstAfterPtr == afterPtr) {
	assocPtr->firstAfterPtr = afterPtr->nextPtr;
    } else {
	for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
		prevPtr = prevPtr->nextPtr) {
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
    script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes);
    result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL);
    if (result != TCL_OK) {
	Tcl_AddErrorInfo(interp, "\n    (\"after\" script)");
	Tcl_BackgroundError(interp);
    }
    Tcl_Release((ClientData) interp);
    
    /*
     * Free the memory for the callback.
     */

    Tcl_DecrRefCount(afterPtr->commandPtr);
    ckfree((char *) afterPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeAfterPtr --
 *
 *	This procedure removes an "after" command from the list of
 *	those that are pending and frees its resources.  This procedure
 *	does *not* cancel the timer handler;  if that's needed, the
 *	caller must do it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The memory associated with afterPtr is released.
 *







|













|
|
<
|







1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158

1159
1160
1161
1162
1163
1164
1165
1166
    script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes);
    result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL);
    if (result != TCL_OK) {
	Tcl_AddErrorInfo(interp, "\n    (\"after\" script)");
	Tcl_BackgroundError(interp);
    }
    Tcl_Release((ClientData) interp);

    /*
     * Free the memory for the callback.
     */

    Tcl_DecrRefCount(afterPtr->commandPtr);
    ckfree((char *) afterPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeAfterPtr --
 *
 *	This function removes an "after" command from the list of those that
 *	are pending and frees its resources. This function does *not* cancel

 *	the timer handler; if that's needed, the caller must do it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The memory associated with afterPtr is released.
 *
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
}

/*
 *----------------------------------------------------------------------
 *
 * AfterCleanupProc --
 *
 *	This procedure is invoked whenever an interpreter is deleted
 *	to cleanup the AssocData for "tclAfter".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	After commands are removed.







|







1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
}

/*
 *----------------------------------------------------------------------
 *
 * AfterCleanupProc --
 *
 *	This function is invoked whenever an interpreter is deleted
 *	to cleanup the AssocData for "tclAfter".
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	After commands are removed.
1125
1126
1127
1128
1129
1130
1131








	    Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
	}
	Tcl_DecrRefCount(afterPtr->commandPtr);
	ckfree((char *) afterPtr);
    }
    ckfree((char *) assocPtr);
}















>
>
>
>
>
>
>
>
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
	    Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
	}
	Tcl_DecrRefCount(afterPtr->commandPtr);
	ckfree((char *) afterPtr);
    }
    ckfree((char *) assocPtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Added generic/tclTomMath.h.





































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
/*
 * tclTomMath.h --
 *
 *	Interface information that comes in at the head of
 *	<tommath.h> to adapt the API to Tcl's linkage conventions.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTomMath.h,v 1.1.2.7 2005/09/26 20:16:53 kennykb Exp $
 */

#ifndef TCLTOMMATH_H
#define TCLTOMMATH_H 1

#include <tcl.h>
#include <stdlib.h>


/* Define TOMMATH_DLLIMPORT and TOMMATH_DLLEXPORT to suit the compiler */

#ifdef STATIC_BUILD
#   define TOMMATH_DLLIMPORT
#   define TOMMATH_DLLEXPORT
#else
#   if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
#	define TOMMATH_DLLIMPORT __declspec(dllimport)
#	define TOMMATH_DLLEXPORT __declspec(dllexport)
#   else
#	define TOMMATH_DLLIMPORT
#	define TOMMATH_DLLEXPORT
#   endif
#endif

/* Define TOMMATH_STORAGE_CLASS according to the build options. */

#undef TOMMATH_STORAGE_CLASS
#ifdef BUILD_tcl
#   define TOMMATH_STORAGE_CLASS TOMMATH_DLLEXPORT
#else
#   ifdef USE_TCL_STUBS
#      define TOMMATH_STORAGE_CLASS
#   else
#      define TOMMATH_STORAGE_CLASS TOMMATH_DLLIMPORT
#   endif
#endif

/* Define custom memory allocation for libtommath */

#define XMALLOC(x) TclBNAlloc(x)
#define XFREE(x) TclBNFree(x)
#define XREALLOC(x,n) TclBNRealloc(x,n)
#define XCALLOC(n,x) TclBNCalloc(n,x)
void* TclBNAlloc( size_t );
void* TclBNRealloc( void*, size_t );
void TclBNFree( void* );
void* TclBNCalloc( size_t, size_t );

/* Rename all global symboles in libtommath to avoid linkage conflicts */

#define KARATSUBA_MUL_CUTOFF TclBNKaratsubaMulCutoff
#define KARATSUBA_SQR_CUTOFF TclBNKaratsubaSqrCutoff
#define TOOM_MUL_CUTOFF TclBNToomMulCutoff
#define TOOM_SQR_CUTOFF TclBNToomSqrCutoff

#define mp_s_rmap TclBNMpSRmap

#define bn_reverse TclBN_reverse
#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add
#define mp_add_d TclBN_mp_add_d
#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
#define mp_cmp_d TclBN_mp_cmp_d
#define mp_cmp_mag TclBN_mp_cmp_mag
#define mp_copy TclBN_mp_copy
#define mp_count_bits TclBN_mp_count_bits
#define mp_div TclBN_mp_div
#define mp_div_d TclBN_mp_div_d
#define mp_div_2 TclBN_mp_div_2
#define mp_div_2d TclBN_mp_div_2d
#define mp_div_3 TclBN_mp_div_3
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
#define mp_init_multi TclBN_mp_init_multi
#define mp_init_set TclBN_mp_init_set
#define mp_init_size TclBN_mp_init_size
#define mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
#define mp_mul TclBN_mp_mul
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
#define mp_mul_d TclBN_mp_mul_d
#define mp_neg TclBN_mp_neg
#define mp_or TclBN_mp_or
#define mp_radix_size TclBN_mp_radix_size
#define mp_read_radix TclBN_mp_read_radix
#define mp_rshd TclBN_mp_rshd
#define mp_shrink TclBN_mp_shrink
#define mp_set TclBN_mp_set
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_sub_d TclBN_mp_sub_d
#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul
#define mp_toom_sqr TclBN_mp_toom_sqr
#define mp_toradix_n TclBN_mp_toradix_n
#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
#define s_mp_mul_digs TclBN_s_mp_mul_digs
#define s_mp_sqr TclBN_s_mp_sqr
#define s_mp_sub TclBN_s_mp_sub

#endif

Added generic/tclTomMathInterface.c.































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
/*
 *----------------------------------------------------------------------
 *
 * tclTomMathInterface.c --
 *
 *	This file contains procedures that are used as a 'glue'
 *	layer between Tcl and libtommath.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTomMathInterface.c,v 1.1.2.4 2005/09/16 19:29:02 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <limits.h>

/*
 *----------------------------------------------------------------------
 *
 * TclBNAlloc --
 *
 *	Allocate memory for libtommath.
 *
 * Results:
 *	Returns a pointer to the allocated block.
 *
 * This procedure is a wrapper around Tcl_Alloc, needed because of
 * a mismatched type signature between Tcl_Alloc and malloc.
 *
 *----------------------------------------------------------------------
 */	

extern void *
TclBNAlloc( size_t x )
{
    return (void*) Tcl_Alloc( (unsigned int) x );
}

/*
 *----------------------------------------------------------------------
 *
 * TclBNAlloc --
 *
 *	Change the size of an allocated block of memory in libtommath
 *
 * Results:
 *	Returns a pointer to the allocated block.
 *
 * This procedure is a wrapper around Tcl_Realloc, needed because of
 * a mismatched type signature between Tcl_Realloc and realloc.
 *
 *----------------------------------------------------------------------
 */	

extern void *
TclBNRealloc( void* p, size_t s  )
{
    return (void*) Tcl_Realloc( (char*) p, (unsigned int) s );
}

/*
 *----------------------------------------------------------------------
 *
 * TclBNFree --
 *
 *	Free allocated memory in libtommath.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *
 * This function is simply a wrapper around Tcl_Free, needed in
 * libtommath because of a type mismatch between free and Tcl_Free.
 *
 *----------------------------------------------------------------------
 */

extern void
TclBNFree( void* p )
{
    Tcl_Free( (char*) p);
}

/*
 *----------------------------------------------------------------------
 *
 * TclBNInitBignumFromLong --
 *
 *	Allocate and initialize a 'bignum' from a native 'long'.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The 'bignum' is constructed.
 *
 *----------------------------------------------------------------------
 */

extern void
TclBNInitBignumFromLong( mp_int* a, long initVal )
{

    int status;
    unsigned long v;
    mp_digit* p;

    /*
     * Allocate enough memory to hold the largest possible long
     */

    status = mp_init_size( a, ( ( CHAR_BIT * sizeof( long ) + DIGIT_BIT - 1 )
				/ DIGIT_BIT ) );
    if ( status != MP_OKAY ) {
	Tcl_Panic( "initialization failure in TclBNInitBignumFromLong" );
    }
    
    /* Convert arg to sign and magnitude */

    if ( initVal < 0 ) {
	a->sign = MP_NEG;
	v = -initVal;
    } else {
	a->sign = MP_ZPOS;
	v = initVal;
    }

    /* Store the magnitude in the bignum. */

    p = a->dp;
    while ( v ) {
	*p++ = (mp_digit) ( v & MP_MASK );
	v >>= MP_DIGIT_BIT;
    }
    a->used = p - a->dp;
    
}

/*
 *----------------------------------------------------------------------
 *
 * TclBNInitBignumFromWideInt --
 *
 *	Allocate and initialize a 'bignum' from a Tcl_WideInt
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The 'bignum' is constructed.
 *
 *----------------------------------------------------------------------
 */

extern void
TclBNInitBignumFromWideInt(mp_int* a, 
				/* Bignum to initialize */
			    Tcl_WideInt v)
				/* Initial value */
{
    if (v < (Tcl_WideInt)0) {
	TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v));
	mp_neg(a, a);
    } else {
	TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclBNInitBignumFromWideUInt --
 *
 *	Allocate and initialize a 'bignum' from a Tcl_WideUInt
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The 'bignum' is constructed.
 *
 *----------------------------------------------------------------------
 */

extern void
TclBNInitBignumFromWideUInt(mp_int* a, 
				/* Bignum to initialize */
			    Tcl_WideUInt v)
				/* Initial value */
{

    int status;
    mp_digit* p;

    /*
     * Allocate enough memory to hold the largest possible Tcl_WideUInt 
     */

    status = mp_init_size(a, ((CHAR_BIT * sizeof( Tcl_WideUInt )
			       + DIGIT_BIT - 1)
			      / DIGIT_BIT));
    if (status != MP_OKAY) {
	Tcl_Panic( "initialization failure in TclBNInitBignumFromWideUInt" );
    }
    
    a->sign = MP_ZPOS;

    /* Store the magnitude in the bignum. */

    p = a->dp;
    while ( v ) {
	*p++ = (mp_digit) ( v & MP_MASK );
	v >>= MP_DIGIT_BIT;
    }
    a->used = p - a->dp;
    
}

Changes to generic/tclTrace.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107
108
109
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
/* 
 * tclTrace.c --
 *
 *	This file contains code to handle most trace management.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTrace.c,v 1.21 2004/11/15 21:47:23 dgp Exp $
 */

#include "tclInt.h"

/*
 * Structure used to hold information about variable traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is
				 * to be invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    char command[4];		/* Space for Tcl command to invoke.  Actual
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceVarInfo;

/*
 * Structure used to hold information about command traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is
				 * to be invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    Tcl_Trace stepTrace;        /* Used for execution traces, when tracing
                                 * inside the given command */
    int startLevel;             /* Used for bookkeeping with step execution
                                 * traces, store the level at which the step
                                 * trace was invoked */
    char *startCmd;             /* Used for bookkeeping with step execution
                                 * traces, store the command name which invoked
                                 * step trace */
    int curFlags;               /* Trace flags for the current command */
    int curCode;                /* Return code for the current command */
    int refCount;               /* Used to ensure this structure is
                                 * not deleted too early.  Keeps track
                                 * of how many pieces of code have
                                 * a pointer to this structure. */
    char command[4];		/* Space for Tcl command to invoke.  Actual
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceCommandInfo;

/* 
 * Used by command execution traces.  Note that we assume in the code
 * that the first two defines are exactly 4 times the
 * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
 * 
 * TCL_TRACE_ENTER_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, before execution.
 * TCL_TRACE_LEAVE_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, after execution.
 * TCL_TRACE_ANY_EXEC           - OR'd combination of all EXEC flags.
 * TCL_TRACE_EXEC_IN_PROGRESS   - The callback procedure on this trace
 *                                is currently executing.  Therefore we
 *                                don't let further traces execute.
 * TCL_TRACE_EXEC_DIRECT        - This execution trace is triggered directly
 *                                by the command being traced, not because
 *                                of an internal trace.
 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
 * be used in command execution traces.
 */

#define TCL_TRACE_ENTER_DURING_EXEC	4
#define TCL_TRACE_LEAVE_DURING_EXEC	8
#define TCL_TRACE_ANY_EXEC              15
#define TCL_TRACE_EXEC_IN_PROGRESS      0x10
#define TCL_TRACE_EXEC_DIRECT           0x20

/*
 * Forward declarations for procedures defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
	int optionIndex, int objc, Tcl_Obj *CONST objv[]));

Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;

/* 
 * Each subcommand has a number of 'types' to which it can apply.
 * Currently 'execution', 'command' and 'variable' are the only
 * types supported.  These three arrays MUST be kept in sync!
 * In the future we may provide an API to add to the list of
 * supported trace types.
 */

static CONST char *traceTypeOptions[] = {
    "execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
    TclTraceExecutionObjCmd,
    TclTraceCommandObjCmd,
    TclTraceVariableObjCmd,
};

/*
 * Declarations for local procedures to this file:
 */

static int              CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
                            Trace *tracePtr, Command *cmdPtr,
                            CONST char *command, int numChars,
                            int objc, Tcl_Obj *CONST objv[]));
static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
                            CONST char *name2, int flags));
static void		TraceCommandProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *oldName,
                            CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;
static int	        StringTraceProc _ANSI_ARGS_((ClientData clientData,
						     Tcl_Interp* interp,
						     int level,
						     CONST char* command,
						    Tcl_Command commandInfo,
						    int objc,
						    Tcl_Obj *CONST objv[]));
static void           StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));

static void		DisposeTraceResult _ANSI_ARGS_((int flags,
			    char *result));

/*
 * The following structure holds the client data for string-based
 * trace procs
 */

typedef struct StringTraceData {
    ClientData clientData;	/* Client data from Tcl_CreateTrace */
    Tcl_CmdTraceProc* proc;	/* Trace procedure from Tcl_CreateTrace */
} StringTraceData;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceObjCmd --
 *
 *	This procedure is invoked to process the "trace" Tcl command.
 *	See the user documentation for details on what it does.
 *	
 *	Standard syntax as of Tcl 8.4 is
 *	
 *	 trace {add|info|remove} {command|variable} name ops cmd
 *
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *----------------------------------------------------------------------
|









|
|

|









|
|

|
|
|
|
|







|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|

|

|
|
|
|
|
|
|
|
|
|

>


|
|
|


|









|
|
|
<
|
|

>










|

>
|
|
|
|

|
|


|

|
|
<
|
<
<
|
|
>










|







|
|
|
|
<
|
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

133


134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158

159

160
161
162
163
164
165
166
/*
 * tclTrace.c --
 *
 *	This file contains code to handle most trace management.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTrace.c,v 1.21.2.3 2005/08/02 18:16:10 dgp Exp $
 */

#include "tclInt.h"

/*
 * Structure used to hold information about variable traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is to be
				 * invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    char command[4];		/* Space for Tcl command to invoke. Actual
				 * size will be as large as necessary to hold
				 * command. This field must be the last in the
				 * structure, so that it can be larger than 4
				 * bytes. */
} TraceVarInfo;

/*
 * Structure used to hold information about command traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is to be
				 * invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    Tcl_Trace stepTrace;	/* Used for execution traces, when tracing
				 * inside the given command */
    int startLevel;		/* Used for bookkeeping with step execution
				 * traces, store the level at which the step
				 * trace was invoked */
    char *startCmd;		/* Used for bookkeeping with step execution
				 * traces, store the command name which
				 * invoked step trace */
    int curFlags;		/* Trace flags for the current command */
    int curCode;		/* Return code for the current command */
    int refCount;		/* Used to ensure this structure is not
				 * deleted too early. Keeps track of how many
				 * pieces of code have a pointer to this
				 * structure. */
    char command[4];		/* Space for Tcl command to invoke. Actual
				 * size will be as large as necessary to hold
				 * command. This field must be the last in the
				 * structure, so that it can be larger than 4
				 * bytes. */
} TraceCommandInfo;

/*
 * Used by command execution traces. Note that we assume in the code that
 * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that
 * TCL_TRACE_LEAVE_DURING_EXEC == 4 * TCL_TRACE_LEAVE_EXEC.
 *
 * TCL_TRACE_ENTER_DURING_EXEC  - Trace each command inside the command
 *				  currently being traced, before execution.
 * TCL_TRACE_LEAVE_DURING_EXEC  - Trace each command inside the command
 *				  currently being traced, after execution.
 * TCL_TRACE_ANY_EXEC		- OR'd combination of all EXEC flags.
 * TCL_TRACE_EXEC_IN_PROGRESS   - The callback function on this trace is
 *				  currently executing. Therefore we don't let
 *				  further traces execute.
 * TCL_TRACE_EXEC_DIRECT	- This execution trace is triggered directly
 *				  by the command being traced, not because of
 *				  an internal trace.
 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used
 * in command execution traces.
 */

#define TCL_TRACE_ENTER_DURING_EXEC	4
#define TCL_TRACE_LEAVE_DURING_EXEC	8
#define TCL_TRACE_ANY_EXEC		15
#define TCL_TRACE_EXEC_IN_PROGRESS	0x10
#define TCL_TRACE_EXEC_DIRECT		0x20

/*
 * Forward declarations for functions defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
	int optionIndex, int objc, Tcl_Obj *CONST objv[]));

Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;

/*
 * Each subcommand has a number of 'types' to which it can apply. Currently
 * 'execution', 'command' and 'variable' are the only types supported. These

 * three arrays MUST be kept in sync! In the future we may provide an API to
 * add to the list of supported trace types.
 */

static CONST char *traceTypeOptions[] = {
    "execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
    TclTraceExecutionObjCmd,
    TclTraceCommandObjCmd,
    TclTraceVariableObjCmd,
};

/*
 * Declarations for local functions to this file:
 */

static int		CallTraceFunction _ANSI_ARGS_((Tcl_Interp *interp,
			    Trace *tracePtr, Command *cmdPtr,
			    CONST char *command, int numChars,
			    int objc, Tcl_Obj *CONST objv[]));
static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1,
			    CONST char *name2, int flags));
static void		TraceCommandProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *oldName,
			    CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;
static int		StringTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp* interp, int level,

			    CONST char* command, Tcl_Command commandInfo,


			    int objc, Tcl_Obj *CONST objv[]));
static void		StringTraceDeleteProc _ANSI_ARGS_((
			    ClientData clientData));
static void		DisposeTraceResult _ANSI_ARGS_((int flags,
			    char *result));

/*
 * The following structure holds the client data for string-based
 * trace procs
 */

typedef struct StringTraceData {
    ClientData clientData;	/* Client data from Tcl_CreateTrace */
    Tcl_CmdTraceProc* proc;	/* Trace function from Tcl_CreateTrace */
} StringTraceData;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceObjCmd --
 *
 *	This function is invoked to process the "trace" Tcl command. See the
 *	user documentation for details on what it does.
 *
 *	Standard syntax as of Tcl 8.4 is:

 *	    trace {add|info|remove} {command|variable} name ops cmd

 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *----------------------------------------------------------------------
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213

214

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230

231
232
233
234
235
236

237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388

389

390
391


392
393

394
395
396
397
398
399
400

401
402
403
404

405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444

445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488
489
490

491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639

640
641
642
643

644
645
646
647
648
649
650
651
652
653
654
655
656
657
658

659
660
661
662
663
664
665
666
667
668
669
670
671
672

673
674
675
676

677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733

734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825

826
827

828
829
830
831
832
833
834

835
836
837
838

839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924

925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178



1179

1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199

1200
1201
1202
1203

1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280

1281
1282
1283
1284

1285
1286

1287
1288
1289
1290
1291
1292
1293
1294
1295

1296


1297
1298

1299
1300
1301
1302
1303
1304

1305
1306
1307
1308
1309
1310
1311
1312
1313

1314
1315
1316
1317



1318


1319
1320

1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353

1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390

1391



1392
1393
1394
1395
1396
1397
1398

1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414

1415

1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445

1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490


1491
1492
1493
1494
1495
1496
1497

1498
1499

1500
1501
1502

1503
1504
1505
1506
1507
1508
1509
1510

1511
1512
1513
1514
1515
1516

1517

1518

1519
1520


1521
1522
1523

1524
1525
1526
1527
1528
1529
1530

1531

1532
1533
1534
1535
1536
1537

1538
1539
1540
1541
1542
1543
1544

1545

1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628

1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661

1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678

1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690

1691
1692
1693
1694
1695
1696

1697
1698
1699
1700
1701

1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715

1716
1717
1718
1719
1720
1721
1722


1723


1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734

1735


1736
1737
1738
1739
1740
1741
1742
1743
1744

1745


1746
1747
1748
1749
1750

1751


1752


1753


1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770

1771
1772
1773
1774
1775

1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792

1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int optionIndex;
    char *name, *flagOps, *p;
    /* Main sub commands to 'trace' */
    static CONST char *traceOptions[] = {
	"add", "info", "remove", 
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	"variable", "vdelete", "vinfo", 
#endif
	(char *) NULL
    };
    /* 'OLD' options are pre-Tcl-8.4 style */
    enum traceOptions {
	TRACE_ADD, TRACE_INFO, TRACE_REMOVE, 
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
		"option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE: {
	    /* 
	     * All sub commands of trace add/remove must take at least
	     * one more argument.  Beyond that we let the subcommand itself
	     * control the argument structure.
	     */

	    int typeIndex;

	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
			"option", 0, &typeIndex) != TCL_OK) {
		return TCL_ERROR;
	    }
	    return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
	}
	case TRACE_INFO: {
	    /* 
	     * All sub commands of trace info must take exactly two
	     * more arguments which name the type of thing being
	     * traced and the name of the thing being traced.
	     */

	    int typeIndex;
	    if (objc < 3) {
		/*
		 * Delegate other complaints to the type-specific code
		 * which can give a better error message.
		 */

		Tcl_WrongNumArgs(interp, 2, objv, "type name");
		return TCL_ERROR;
	    }
	    if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
			"option", 0, &typeIndex) != TCL_OK) {
		return TCL_ERROR;
	    }
	    return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
	    break;
	}

#ifndef TCL_REMOVE_OBSOLETE_TRACES
	case TRACE_OLD_VARIABLE:
	case TRACE_OLD_VDELETE: {
	    Tcl_Obj *copyObjv[6];
	    Tcl_Obj *opsList;
	    int code, numFlags;

	    if (objc != 5) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
		return TCL_ERROR;
	    }

	    opsList = Tcl_NewObj();
	    Tcl_IncrRefCount(opsList);
	    flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
	    if (numFlags == 0) {
		Tcl_DecrRefCount(opsList);
		goto badVarOps;
	    }
	    for (p = flagOps; *p != 0; p++) {
		if (*p == 'r') {
		    Tcl_ListObjAppendElement(NULL, opsList,
			    Tcl_NewStringObj("read", -1));
		} else if (*p == 'w') {
		    Tcl_ListObjAppendElement(NULL, opsList,
			    Tcl_NewStringObj("write", -1));
		} else if (*p == 'u') {
		    Tcl_ListObjAppendElement(NULL, opsList,
			    Tcl_NewStringObj("unset", -1));
		} else if (*p == 'a') {
		    Tcl_ListObjAppendElement(NULL, opsList,
			    Tcl_NewStringObj("array", -1));
		} else {
		    Tcl_DecrRefCount(opsList);
		    goto badVarOps;
		}
	    }
	    copyObjv[0] = NULL;
	    memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
	    copyObjv[4] = opsList;
	    if  (optionIndex == TRACE_OLD_VARIABLE) {
		code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
	    } else {
		code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
	    }
	    Tcl_DecrRefCount(opsList);
	    return code;
	}
	case TRACE_OLD_VINFO: {
	    ClientData clientData;
	    char ops[5];
	    Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;

	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "name");
		return TCL_ERROR;
	    }
	    resultListPtr = Tcl_NewObj();
	    clientData = 0;
	    name = Tcl_GetString(objv[2]);
	    while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
		    TraceVarProc, clientData)) != 0) {

		TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

		pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		p = ops;
		if (tvarPtr->flags & TCL_TRACE_READS) {
		    *p = 'r';
		    p++;
		}
		if (tvarPtr->flags & TCL_TRACE_WRITES) {
		    *p = 'w';
		    p++;
		}
		if (tvarPtr->flags & TCL_TRACE_UNSETS) {
		    *p = 'u';
		    p++;
		}
		if (tvarPtr->flags & TCL_TRACE_ARRAY) {
		    *p = 'a';
		    p++;
		}
		*p = '\0';

		/*
		 * Build a pair (2-item list) with the ops string as
		 * the first obj element and the tvarPtr->command string
		 * as the second obj element.  Append the pair (as an
		 * element) to the end of the result object list.
		 */

		elemObjPtr = Tcl_NewStringObj(ops, -1);
		Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
		elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
		Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
		Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
	    }
	    Tcl_SetObjResult(interp, resultListPtr);
	    break;
	}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
    }
    return TCL_OK;

    badVarOps:
    Tcl_AppendResult(interp, "bad operations \"", flagOps,
	    "\": should be one or more of rwua", (char *) NULL);
    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceExecutionObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|remove|info} execution ...] subcommands.
 *	See the user documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed;
 *	may add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;

    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };

    static CONST char *opStrings[] = { "enter", "leave", 
                                 "enterstep", "leavestep", (char *) NULL };


    enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
                      TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };

    
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE: {
	    int flags = 0;
	    int i, listLen, result;
	    Tcl_Obj **elemPtrs;

	    if (objc != 6) {
		Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
		return TCL_ERROR;
	    }

	    /*
	     * Make sure the ops argument is a list object; get its length and
	     * a pointer to its array of element pointers.
	     */

	    result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
		    &elemPtrs);
	    if (result != TCL_OK) {
		return result;
	    }
	    if (listLen == 0) {
		Tcl_SetResult(interp, "bad operation list \"\": must be "
	          "one or more of enter, leave, enterstep, or leavestep", 
		  TCL_STATIC);
		return TCL_ERROR;
	    }
	    for (i = 0; i < listLen; i++) {
		if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
			"operation", TCL_EXACT, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		switch ((enum operations) index) {
		    case TRACE_EXEC_ENTER:
			flags |= TCL_TRACE_ENTER_EXEC;
			break;
		    case TRACE_EXEC_LEAVE:
			flags |= TCL_TRACE_LEAVE_EXEC;
			break;
		    case TRACE_EXEC_ENTER_STEP:
			flags |= TCL_TRACE_ENTER_DURING_EXEC;
			break;
		    case TRACE_EXEC_LEAVE_STEP:
			flags |= TCL_TRACE_LEAVE_DURING_EXEC;
			break;
		}
	    }
	    command = Tcl_GetStringFromObj(objv[5], &commandLength);
	    length = (size_t) commandLength;
	    if ((enum traceOptions) optionIndex == TRACE_ADD) {
		TraceCommandInfo *tcmdPtr;

		tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
			(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
				+ length + 1));
		tcmdPtr->flags = flags;
		tcmdPtr->stepTrace = NULL;
		tcmdPtr->startLevel = 0;
		tcmdPtr->startCmd = NULL;
		tcmdPtr->length = length;
		tcmdPtr->refCount = 1;
		flags |= TCL_TRACE_DELETE;
		if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
			     TCL_TRACE_LEAVE_DURING_EXEC)) {
		    flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
		}
		strcpy(tcmdPtr->command, command);
		name = Tcl_GetString(objv[3]);
		if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
			(ClientData) tcmdPtr) != TCL_OK) {
		    ckfree((char *) tcmdPtr);
		    return TCL_ERROR;
		}
	    } else {
		/*
		 * Search through all of our traces on this command to
		 * see if there's one with the given command.  If so, then
		 * delete the first one that matches.
		 */
		
		TraceCommandInfo *tcmdPtr;
		ClientData clientData = NULL;
		name = Tcl_GetString(objv[3]);

		/* First ensure the name given is valid */
		if (Tcl_FindCommand(interp, name, NULL, 
				    TCL_LEAVE_ERR_MSG) == NULL) {
		    return TCL_ERROR;
		}
				    
		while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
			TraceCommandProc, clientData)) != NULL) {
		    tcmdPtr = (TraceCommandInfo *) clientData;

		    /* 
		     * In checking the 'flags' field we must remove any
		     * extraneous flags which may have been temporarily
		     * added by various pieces of the trace mechanism.
		     */

		    if ((tcmdPtr->length == length)
			    && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | 
						   TCL_TRACE_RENAME | 
						   TCL_TRACE_DELETE)) == flags)
			    && (strncmp(command, tcmdPtr->command,
				    (size_t) length) == 0)) {
			flags |= TCL_TRACE_DELETE;
			if (flags & (TCL_TRACE_ENTER_DURING_EXEC | 
				     TCL_TRACE_LEAVE_DURING_EXEC)) {
			    flags |= (TCL_TRACE_ENTER_EXEC | 
				      TCL_TRACE_LEAVE_EXEC);
			}
			Tcl_UntraceCommand(interp, name,
				flags, TraceCommandProc, clientData);
			if (tcmdPtr->stepTrace != NULL) {
			    /* 
			     * We need to remove the interpreter-wide trace 
			     * which we created to allow 'step' traces.
			     */

			    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
			    tcmdPtr->stepTrace = NULL;
                            if (tcmdPtr->startCmd != NULL) {
			        ckfree((char *)tcmdPtr->startCmd);
			    }
			}
			if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
			    /* Postpone deletion */
			    tcmdPtr->flags = 0;
			}
			if ((--tcmdPtr->refCount) <= 0) {
			    ckfree((char*)tcmdPtr);
			}
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_INFO: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }

	    clientData = NULL;
	    name = Tcl_GetString(objv[3]);
	    
	    /* First ensure the name given is valid */
	    if (Tcl_FindCommand(interp, name, NULL, 
				TCL_LEAVE_ERR_MSG) == NULL) {
		return TCL_ERROR;
	    }
				
	    resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		    TraceCommandProc, clientData)) != NULL) {
		int numOps = 0;

		TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;

		/*
		 * Build a list with the ops list as the first obj
		 * element and the tcmdPtr->command string as the
		 * second obj element.  Append this list (as an
		 * element) to the end of the result object list.
		 */

		elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		Tcl_IncrRefCount(elemObjPtr);
		if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("enter",5));
		}
		if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("leave",5));
		}
		if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("enterstep",9));
		}
		if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("leavestep",9));
		}
		Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
		if (0 == numOps) {
		    Tcl_DecrRefCount(elemObjPtr);
		    continue;
		}
		eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
		Tcl_DecrRefCount(elemObjPtr);
		elemObjPtr = NULL;
		
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, 
			Tcl_NewStringObj(tcmdPtr->command, -1));
		Tcl_ListObjAppendElement(interp, resultListPtr,
			eachTraceObjPtr);
	    }
	    Tcl_SetObjResult(interp, resultListPtr);
	    break;
	}
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceCommandObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|info|remove} command ...] subcommands.
 *	See the user documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed;
 *	may add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
    enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
    
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE: {
	    int flags = 0;
	    int i, listLen, result;
	    Tcl_Obj **elemPtrs;

	    if (objc != 6) {
		Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
		return TCL_ERROR;
	    }

	    /*
	     * Make sure the ops argument is a list object; get its length and
	     * a pointer to its array of element pointers.
	     */

	    result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
		    &elemPtrs);
	    if (result != TCL_OK) {
		return result;
	    }
	    if (listLen == 0) {
		Tcl_SetResult(interp, "bad operation list \"\": must be "
			"one or more of delete or rename", TCL_STATIC);
		return TCL_ERROR;
	    }

	    for (i = 0; i < listLen; i++) {
		if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
			"operation", TCL_EXACT, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		switch ((enum operations) index) {
		    case TRACE_CMD_RENAME:
			flags |= TCL_TRACE_RENAME;
			break;
		    case TRACE_CMD_DELETE:
			flags |= TCL_TRACE_DELETE;
			break;
		}
	    }

	    command = Tcl_GetStringFromObj(objv[5], &commandLength);
	    length = (size_t) commandLength;
	    if ((enum traceOptions) optionIndex == TRACE_ADD) {
		TraceCommandInfo *tcmdPtr;

		tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
			(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
				+ length + 1));
		tcmdPtr->flags = flags;
		tcmdPtr->stepTrace = NULL;
		tcmdPtr->startLevel = 0;
		tcmdPtr->startCmd = NULL;
		tcmdPtr->length = length;
		tcmdPtr->refCount = 1;
		flags |= TCL_TRACE_DELETE;
		strcpy(tcmdPtr->command, command);
		name = Tcl_GetString(objv[3]);
		if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
			(ClientData) tcmdPtr) != TCL_OK) {
		    ckfree((char *) tcmdPtr);
		    return TCL_ERROR;
		}
	    } else {
		/*
		 * Search through all of our traces on this command to
		 * see if there's one with the given command.  If so, then
		 * delete the first one that matches.
		 */
		
		TraceCommandInfo *tcmdPtr;
		ClientData clientData = NULL;
		name = Tcl_GetString(objv[3]);
		
		/* First ensure the name given is valid */
		if (Tcl_FindCommand(interp, name, NULL, 
				    TCL_LEAVE_ERR_MSG) == NULL) {
		    return TCL_ERROR;
		}
				    
		while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
			TraceCommandProc, clientData)) != NULL) {
		    tcmdPtr = (TraceCommandInfo *) clientData;
		    if ((tcmdPtr->length == length)
			    && (tcmdPtr->flags == flags)
			    && (strncmp(command, tcmdPtr->command,
				    (size_t) length) == 0)) {
			Tcl_UntraceCommand(interp, name,
				flags | TCL_TRACE_DELETE,
				TraceCommandProc, clientData);
			tcmdPtr->flags |= TCL_TRACE_DESTROYED;
			if ((--tcmdPtr->refCount) <= 0) {
			    ckfree((char *) tcmdPtr);
			}
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_INFO: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }

	    clientData = NULL;
	    name = Tcl_GetString(objv[3]);
	    
	    /* First ensure the name given is valid */
	    if (Tcl_FindCommand(interp, name, NULL, 
				TCL_LEAVE_ERR_MSG) == NULL) {
		return TCL_ERROR;
	    }
				
	    resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		    TraceCommandProc, clientData)) != NULL) {
		int numOps = 0;

		TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;

		/*
		 * Build a list with the ops list as
		 * the first obj element and the tcmdPtr->command string
		 * as the second obj element.  Append this list (as an
		 * element) to the end of the result object list.
		 */

		elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		Tcl_IncrRefCount(elemObjPtr);
		if (tcmdPtr->flags & TCL_TRACE_RENAME) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("rename",6));
		}
		if (tcmdPtr->flags & TCL_TRACE_DELETE) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("delete",6));
		}
		Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
		if (0 == numOps) {
		    Tcl_DecrRefCount(elemObjPtr);
		    continue;
		}
		eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
		Tcl_DecrRefCount(elemObjPtr);

		elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
		Tcl_ListObjAppendElement(interp, resultListPtr,
			eachTraceObjPtr);
	    }
	    Tcl_SetObjResult(interp, resultListPtr);
	    break;
	}
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceVariableObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|info|remove} variable ...] subcommands.
 *	See the user documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed;
 *	may add or remove variable traces on a variable.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = { "array", "read", "unset", "write",
				     (char *) NULL };

    enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
			  TRACE_VAR_WRITE };

        
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE: {
	    int flags = 0;
	    int i, listLen, result;
	    Tcl_Obj **elemPtrs;

	    if (objc != 6) {
		Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
		return TCL_ERROR;
	    }

	    /*
	     * Make sure the ops argument is a list object; get its length and
	     * a pointer to its array of element pointers.
	     */

	    result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
		    &elemPtrs);
	    if (result != TCL_OK) {
		return result;
	    }
	    if (listLen == 0) {
		Tcl_SetResult(interp, "bad operation list \"\": must be "
			"one or more of array, read, unset, or write",
			TCL_STATIC);
		return TCL_ERROR;
	    }
	    for (i = 0; i < listLen ; i++) {
		if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
			"operation", TCL_EXACT, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		switch ((enum operations) index) {
		    case TRACE_VAR_ARRAY:
			flags |= TCL_TRACE_ARRAY;
			break;
		    case TRACE_VAR_READ:
			flags |= TCL_TRACE_READS;
			break;
		    case TRACE_VAR_UNSET:
			flags |= TCL_TRACE_UNSETS;
			break;
		    case TRACE_VAR_WRITE:
			flags |= TCL_TRACE_WRITES;
			break;
		}
	    }
	    command = Tcl_GetStringFromObj(objv[5], &commandLength);
	    length = (size_t) commandLength;
	    if ((enum traceOptions) optionIndex == TRACE_ADD) {
		TraceVarInfo *tvarPtr;
		tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
			(sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
				+ length + 1));
		tvarPtr->flags = flags;
		if (objv[0] == NULL) {
		    tvarPtr->flags |= TCL_TRACE_OLD_STYLE;
		}
		tvarPtr->length = length;
		flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
		strcpy(tvarPtr->command, command);
		name = Tcl_GetString(objv[3]);
		if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
			(ClientData) tvarPtr) != TCL_OK) {
		    ckfree((char *) tvarPtr);
		    return TCL_ERROR;
		}
	    } else {
		/*
		 * Search through all of our traces on this variable to
		 * see if there's one with the given command.  If so, then
		 * delete the first one that matches.
		 */
		
		TraceVarInfo *tvarPtr;
		ClientData clientData = 0;
		name = Tcl_GetString(objv[3]);
		while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
			TraceVarProc, clientData)) != 0) {
		    tvarPtr = (TraceVarInfo *) clientData;
		    if ((tvarPtr->length == length)
			    && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
			    && (strncmp(command, tvarPtr->command,
				    (size_t) length) == 0)) {
			Tcl_UntraceVar2(interp, name, NULL, 
			  flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
				TraceVarProc, clientData);
			Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_INFO: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;

	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }

	    resultListPtr = Tcl_NewObj();
	    clientData = 0;
	    name = Tcl_GetString(objv[3]);
	    while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
		    TraceVarProc, clientData)) != 0) {

		TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

		/*
		 * Build a list with the ops list as
		 * the first obj element and the tcmdPtr->command string
		 * as the second obj element.  Append this list (as an
		 * element) to the end of the result object list.
		 */

		elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		if (tvarPtr->flags & TCL_TRACE_ARRAY) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("array", 5));
		}
		if (tvarPtr->flags & TCL_TRACE_READS) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("read", 4));
		}
		if (tvarPtr->flags & TCL_TRACE_WRITES) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("write", 5));
		}
		if (tvarPtr->flags & TCL_TRACE_UNSETS) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("unset", 5));
		}
		eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);

		elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
		Tcl_ListObjAppendElement(interp, resultListPtr,
			eachTraceObjPtr);
	    }
	    Tcl_SetObjResult(interp, resultListPtr);
	    break;
	}
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandTraceInfo --
 *
 *	Return the clientData value associated with a trace on a
 *	command.  This procedure can also be used to step through
 *	all of the traces on a particular command that have the
 *	same trace procedure.
 *
 * Results:
 *	The return value is the clientData value associated with
 *	a trace on the given command.  Information will only be
 *	returned for a trace with proc as trace procedure.  If
 *	the clientData argument is NULL then the first such trace is
 *	returned;  otherwise, the next relevant one after the one
 *	given by clientData will be returned.  If the command
 *	doesn't exist then an error message is left in the interpreter
 *	and NULL is returned.  Also, if there are no (more) traces for 
 *	the given command, NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_CommandTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
				 * by this procedure, so this call will
				 * return the next trace after that one.
				 * If NULL, this call will return the
				 * first trace. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 
		NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return NULL;
    }

    /*
     * Find the relevant trace, if any, and return its clientData.
     */

    tracePtr = cmdPtr->tracePtr;
    if (prevClientData != NULL) {
	for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
	    if ((tracePtr->clientData == prevClientData)
		    && (tracePtr->traceProc == proc)) {
		tracePtr = tracePtr->nextPtr;
		break;
	    }
	}
    }
    for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
	if (tracePtr->traceProc == proc) {
	    return tracePtr->clientData;
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceCommand --
 *
 *	Arrange for rename/deletes to a command to cause a
 *	procedure to be invoked, which can monitor the operations.
 *	
 *	Also optionally arrange for execution of that command
 *	to cause a procedure to be invoked.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the command given by cmdName, such that
 *	future changes to the command will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which command is
				 * to be traced. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
				 * and any of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon cmdName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
	    NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Set up trace information.
     */

    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
			       | TCL_TRACE_ANY_EXEC);
    tracePtr->nextPtr = cmdPtr->tracePtr;
    tracePtr->refCount = 1;
    cmdPtr->tracePtr = tracePtr;
    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
        cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceCommand --
 *
 *	Remove a previously-created trace for a command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there exists a trace for the command given by cmdName
 *	with the given flags, proc, and clientData, then that trace
 *	is removed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
				 * and any of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    register CommandTrace *tracePtr;
    CommandTrace *prevPtr;
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveCommandTrace *activePtr;
    int hasExecTraces = 0;
    
    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 
		NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);

    for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL;  ;
	 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc) 
	    && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | 
				    TCL_TRACE_ANY_EXEC)) == flags)
		&& (tracePtr->clientData == clientData)) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
		hasExecTraces = 1;
	    }
	    break;
	}
    }
    
    /*
     * The code below makes it possible to delete traces while traces
     * are active: it makes sure that the deleted trace won't be
     * processed by CallCommandTraces.
     */

    for (activePtr = iPtr->activeCmdTracePtr;  activePtr != NULL;
	 activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {



	    activePtr->nextTracePtr = tracePtr->nextPtr;

	}
    }
    if (prevPtr == NULL) {
	cmdPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }
    tracePtr->flags = 0;
    
    if ((--tracePtr->refCount) <= 0) {
	ckfree((char*)tracePtr);
    }
    
    if (hasExecTraces) {
	for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
	     prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
	        return;
	    }
	}

	/* 
	 * None of the remaining traces on this command are execution
	 * traces.  We therefore remove this flag:
	 */

	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TraceCommandProc --
 *
 *	This procedure is called to handle command changes that have
 *	been traced using the "trace" command, when using the 
 *	'rename' or 'delete' options.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
    ClientData clientData;	/* Information about the command trace. */
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *oldName;	/* Name of command being changed. */
    CONST char *newName;	/* New name of command.  Empty string
                  		 * or NULL means command is being deleted
                  		 * (renamed to ""). */
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
    int code;
    Tcl_DString cmd;
    
    tcmdPtr->refCount++;
    
    if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)
	    && !Tcl_LimitExceeded(interp)) {
	/*
	 * Generate a command to execute by appending list elements
	 * for the old and new command name and the operation.
	 */

	Tcl_DStringInit(&cmd);
	Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
	Tcl_DStringAppendElement(&cmd, oldName);
	Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
	if (flags & TCL_TRACE_RENAME) {
	    Tcl_DStringAppend(&cmd, " rename", 7);
	} else if (flags & TCL_TRACE_DELETE) {
	    Tcl_DStringAppend(&cmd, " delete", 7);
	}

	/*
	 * Execute the command.  
	 * We discard any object result the command returns.
	 *
	 * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to
	 * other areas that this will be destroyed by us, otherwise a
	 * double-free might occur depending on what the eval does.
	 */

	if (flags & TCL_TRACE_DESTROYED) {
	    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
	}
	code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
		Tcl_DStringLength(&cmd), 0);
	if (code != TCL_OK) {	     
	    /* We ignore errors in these traced commands */
	    /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/
	}
	Tcl_DStringFree(&cmd);
    }

    /*
     * We delete when the trace was destroyed or if this is a delete trace,
     * because command deletes are unconditional, so the trace must go away.
     */

    if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
	int untraceFlags = tcmdPtr->flags;


	if (tcmdPtr->stepTrace != NULL) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
            if (tcmdPtr->startCmd != NULL) {
	        ckfree((char *)tcmdPtr->startCmd);
	    }
	}
	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {

	    /* Postpone deletion, until exec trace returns */


	    tcmdPtr->flags = 0;
	}

	/*
	 * We need to construct the same flags for Tcl_UntraceCommand
	 * as were passed to Tcl_TraceCommand.  Reproduce the processing
	 * of [trace add execution/command].  Be careful to keep this
	 * code in sync with that.
	 */

	if (untraceFlags & TCL_TRACE_ANY_EXEC) {
	    untraceFlags |= TCL_TRACE_DELETE;
	    if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC 
		    | TCL_TRACE_LEAVE_DURING_EXEC)) {
		untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	    }
	} else if (untraceFlags & TCL_TRACE_RENAME) {
	    untraceFlags |= TCL_TRACE_DELETE;
	}

	/*
	 * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
	 * command we're tracing has just gone away.  Then decrement the
	 * clientData refCount that was set up by trace creation.



	 */


	Tcl_UntraceCommand(interp, oldName, untraceFlags,
		TraceCommandProc, clientData);

	tcmdPtr->refCount--;
    }
    if ((--tcmdPtr->refCount) <= 0) {
        ckfree((char*)tcmdPtr);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckExecutionTraces --
 *
 *	Checks on all current command execution traces, and invokes
 *	procedures which have been registered.  This procedure can be
 *	used by other code which performs execution to unify the
 *	tracing system, so that execution traces will function for that
 *	other code.
 *	
 *	For instance extensions like [incr Tcl] which use their
 *	own execution technique can make use of Tcl's tracing.
 *	
 *	This procedure is called by 'TclEvalObjvInternal'
 *
 * Results:
 *      The return value is a standard Tcl completion code such as
 *      TCL_OK or TCL_ERROR, etc.
 *
 * Side effects:
 *	Those side effects made by any trace procedures called.
 *
 *----------------------------------------------------------------------
 */

int 
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, 
			traceFlags, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    CONST char *command;        /* Pointer to beginning of the current 
				 * command string. */
    int numChars;               /* The number of characters in 'command' 
				 * which are part of the command string. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    int code;                   /* The current result code. */
    int traceFlags;             /* Current tracing situation. */
    int objc;			/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    CommandTrace *tracePtr, *lastTracePtr;
    ActiveCommandTrace active;
    int curLevel;
    int traceCode = TCL_OK;
    TraceCommandInfo* tcmdPtr;
    Tcl_InterpState state = NULL;
    
    if (command == NULL || cmdPtr->tracePtr == NULL) {
	return traceCode;
    }
    
    curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
    
    active.nextPtr = iPtr->activeCmdTracePtr;
    iPtr->activeCmdTracePtr = &active;

    active.cmdPtr = cmdPtr;
    lastTracePtr = NULL;
    for (tracePtr = cmdPtr->tracePtr; 
	 (traceCode == TCL_OK) && (tracePtr != NULL);
	 tracePtr = active.nextTracePtr) {
        if (traceFlags & TCL_TRACE_LEAVE_EXEC) {

            /* execute the trace command in order of creation for "leave" */



	    active.nextTracePtr = NULL;
            tracePtr = cmdPtr->tracePtr;
            while (tracePtr->nextPtr != lastTracePtr) {
	        active.nextTracePtr = tracePtr;
	        tracePtr = tracePtr->nextPtr;
            }
        } else {

	    active.nextTracePtr = tracePtr->nextPtr;
        }
	tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
	if (tcmdPtr->flags != 0) {
            tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
            tcmdPtr->curCode  = code;
	    tcmdPtr->refCount++;
	    if (state == NULL) {
		state = Tcl_SaveInterpState(interp, code);
	    }
	    traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, 
	          curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
	    if ((--tcmdPtr->refCount) <= 0) {
	        ckfree((char*)tcmdPtr);
	    }
	}

        lastTracePtr = tracePtr;

    }
    iPtr->activeCmdTracePtr = active.nextPtr;
    if (state) {
	(void) Tcl_RestoreInterpState(interp, state);
    }
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckInterpTraces --
 *
 *	Checks on all current traces, and invokes procedures which
 *	have been registered.  This procedure can be used by other
 *	code which performs execution to unify the tracing system.
 *	For instance extensions like [incr Tcl] which use their
 *	own execution technique can make use of Tcl's tracing.
 *	
 *	This procedure is called by 'TclEvalObjvInternal'
 *
 * Results:
 *      The return value is a standard Tcl completion code such as
 *      TCL_OK or TCL_ERROR, etc.
 *
 * Side effects:
 *	Those side effects made by any trace procedures called.
 *
 *----------------------------------------------------------------------
 */

int 
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, 
		     traceFlags, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    CONST char *command;        /* Pointer to beginning of the current 
				 * command string. */
    int numChars;               /* The number of characters in 'command' 
				 * which are part of the command string. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    int code;                   /* The current result code. */
    int traceFlags;             /* Current tracing situation. */
    int objc;			/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    Trace *tracePtr, *lastTracePtr;
    ActiveInterpTrace active;
    int curLevel;
    int traceCode = TCL_OK;
    TraceCommandInfo* tcmdPtr;
    Tcl_InterpState state = NULL;
    
    if (command == NULL || iPtr->tracePtr == NULL ||
           (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
	return(traceCode);
    }
    
    curLevel = iPtr->numLevels;
    
    active.nextPtr = iPtr->activeInterpTracePtr;
    iPtr->activeInterpTracePtr = &active;

    lastTracePtr = NULL;
    for ( tracePtr = iPtr->tracePtr;
          (traceCode == TCL_OK) && (tracePtr != NULL);
	  tracePtr = active.nextTracePtr) {
        if (traceFlags & TCL_TRACE_ENTER_EXEC) {
            /* 
             * Execute the trace command in reverse order of creation
             * for "enterstep" operation. The order is changed for
             * "enterstep" instead of for "leavestep" as was done in 
             * TclCheckExecutionTraces because for step traces,
             * Tcl_CreateObjTrace creates one more linked list of traces
             * which results in one more reversal of trace invocation.
             */


	    active.nextTracePtr = NULL;
            tracePtr = iPtr->tracePtr;
            while (tracePtr->nextPtr != lastTracePtr) {
	        active.nextTracePtr = tracePtr;
	        tracePtr = tracePtr->nextPtr;
            }
        } else {

	    active.nextTracePtr = tracePtr->nextPtr;
        }

	if (tracePtr->level > 0 && curLevel > tracePtr->level) {
	    continue;
	}

	if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
            /*
	     * The proc invoked might delete the traced command which 
	     * which might try to free tracePtr.  We want to use tracePtr
	     * until the end of this if section, so we use
	     * Tcl_Preserve() and Tcl_Release() to be sure it is not
	     * freed while we still need it.
	     */

	    Tcl_Preserve((ClientData) tracePtr);
	    tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
	    if (state == NULL) {
		state = Tcl_SaveInterpState(interp, code);
	    }
	    

	    if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {

	        /* New style trace */

		if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) &&
		    ((tracePtr->flags & traceFlags) != 0)) {


		    tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
		    tcmdPtr->curFlags = traceFlags;
		    tcmdPtr->curCode  = code;

		    traceCode = (tracePtr->proc)((ClientData)tcmdPtr, 
						 (Tcl_Interp*)interp,
						 curLevel, command,
						 (Tcl_Command)cmdPtr,
						 objc, objv);
		}
	    } else {

		/* Old-style trace */

		
		if (traceFlags & TCL_TRACE_ENTER_EXEC) {
		    /* 
		     * Old-style interpreter-wide traces only trigger
		     * before the command is executed.
		     */

		    traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
				       command, numChars, objc, objv);
		}
	    }
	    tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
	    Tcl_Release((ClientData) tracePtr);
	}

        lastTracePtr = tracePtr;

    }
    iPtr->activeInterpTracePtr = active.nextPtr;
    if (state) {
	if (traceCode == TCL_OK) {
	    (void) Tcl_RestoreInterpState(interp, state);
	} else {
	    Tcl_DiscardInterpState(state);
	}
    }
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CallTraceProcedure --
 *
 *	Invokes a trace procedure registered with an interpreter. These
 *	procedures trace command execution. Currently this trace procedure
 *	is called with the address of the string-based Tcl_CmdProc for the
 *	command, not the Tcl_ObjCmdProc.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Those side effects made by the trace procedure.
 *
 *----------------------------------------------------------------------
 */

static int
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    register Trace *tracePtr;	/* Describes the trace procedure to call. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    CONST char *command;	/* Points to the first character of the
				 * command's source before substitutions. */
    int numChars;		/* The number of characters in the
				 * command's source. */
    register int objc;		/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    char *commandCopy;
    int traceCode;

   /*
     * Copy the command characters into a new string.
     */

    commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
    memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
    commandCopy[numChars] = '\0';
    
    /*
     * Call the trace procedure then free allocated storage.
     */
    
    traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
                              iPtr->numLevels, commandCopy,
                              (Tcl_Command) cmdPtr, objc, objv );

    ckfree((char *) commandCopy);
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CommandObjTraceDeleted --
 *
 *	Ensure the trace is correctly deleted by decrementing its
 *	refCount and only deleting if no other references exist.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *	May release memory.
 *
 *----------------------------------------------------------------------
 */

static void 
CommandObjTraceDeleted(ClientData clientData) {
    TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
    if ((--tcmdPtr->refCount) <= 0) {
	ckfree((char*)tcmdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TraceExecutionProc --
 *
 *	This procedure is invoked whenever code relevant to a
 *	'trace execution' command is executed.  It is called in one
 *	of two ways in Tcl's core:
 *	
 *	(i) by the TclCheckExecutionTraces, when an execution trace 
 *	has been triggered.
 *	(ii) by TclCheckInterpTraces, when a prior execution trace has
 *	created a trace of the internals of a procedure, passing in
 *	this procedure as the one to be called.
 *
 * Results:
 *      The return value is a standard Tcl completion code such as
 *      TCL_OK or TCL_ERROR, etc.
 *
 * Side effects:
 *	May invoke an arbitrary Tcl procedure, and may create or
 *	delete an interpreter-wide trace.
 *
 *----------------------------------------------------------------------
 */

static int
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, 
	      int level, CONST char* command, Tcl_Command cmdInfo,
	      int objc, struct Tcl_Obj *CONST objv[]) {
    int call = 0;
    Interp *iPtr = (Interp *) interp;
    TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
    int flags = tcmdPtr->curFlags;
    int code  = tcmdPtr->curCode;
    int traceCode  = TCL_OK;
    
    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
	/* 
	 * Inside any kind of execution trace callback, we do
	 * not allow any further execution trace callbacks to
	 * be called for the same trace.
	 */

	return traceCode;
    }
    
    if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) {
	/*
	 * Check whether the current call is going to eval arbitrary
	 * Tcl code with a generated trace, or whether we are only
	 * going to setup interpreter-wide traces to implement the
	 * 'step' traces.  This latter situation can happen if
	 * we create a command trace without either before or after
	 * operations, but with either of the step operations.
	 */

	if (flags & TCL_TRACE_EXEC_DIRECT) {
	    call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | 
					     TCL_TRACE_LEAVE_EXEC);
	} else {
	    call = 1;
	}

	/*
	 * First, if we have returned back to the level at which we
	 * created an interpreter trace for enterstep and/or leavestep
         * execution traces, we remove it here.
	 */

	if (flags & TCL_TRACE_LEAVE_EXEC) {
	    if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)
                && (strcmp(command, tcmdPtr->startCmd) == 0)) {
		Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
		tcmdPtr->stepTrace = NULL;
                if (tcmdPtr->startCmd != NULL) {
	            ckfree((char *)tcmdPtr->startCmd);
	        }
	    }
	}
	
	/*
	 * Second, create the tcl callback, if required.
	 */

	if (call) {
	    Tcl_DString cmd;
	    Tcl_DString sub;
	    int i;

	    Tcl_DStringInit(&cmd);
	    Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);


	    /* Append command with arguments */


	    Tcl_DStringInit(&sub);
	    for (i = 0; i < objc; i++) {
	        char* str;
	        int len;
	        str = Tcl_GetStringFromObj(objv[i],&len);
	        Tcl_DStringAppendElement(&sub, str);
	    }
	    Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
	    Tcl_DStringFree(&sub);

	    if (flags & TCL_TRACE_ENTER_EXEC) {

		/* Append trace operation */


		if (flags & TCL_TRACE_EXEC_DIRECT) {
		    Tcl_DStringAppendElement(&cmd, "enter");
		} else {
		    Tcl_DStringAppendElement(&cmd, "enterstep");
		}
	    } else if (flags & TCL_TRACE_LEAVE_EXEC) {
		Tcl_Obj* resultCode;
		char* resultCodeStr;


		/* Append result code */


		resultCode = Tcl_NewIntObj(code);
		resultCodeStr = Tcl_GetString(resultCode);
		Tcl_DStringAppendElement(&cmd, resultCodeStr);
		Tcl_DecrRefCount(resultCode);
		

		/* Append result string */


		Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));


		/* Append trace operation */


		if (flags & TCL_TRACE_EXEC_DIRECT) {
		    Tcl_DStringAppendElement(&cmd, "leave");
		} else {
		    Tcl_DStringAppendElement(&cmd, "leavestep");
		}
	    } else {
		Tcl_Panic("TraceExecutionProc: bad flag combination");
	    }
	    
	    /*
	     * Execute the command.  
	     * We discard any object result the command returns.
	     */

	    tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
	    iPtr->flags    |= INTERP_TRACE_IN_PROGRESS;
	    tcmdPtr->refCount++;

	    /* 
	     * This line can have quite arbitrary side-effects,
	     * including deleting the trace, the command being
	     * traced, or even the interpreter.
	     */

	    traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
	    tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
	    iPtr->flags    &= ~INTERP_TRACE_IN_PROGRESS;
	    if (tcmdPtr->flags == 0) {
		flags |= TCL_TRACE_DESTROYED;
	    }
	    Tcl_DStringFree(&cmd);
	}
	
	/*
	 * Third, if there are any step execution traces for this proc,
         * we register an interpreter trace to invoke enterstep and/or
	 * leavestep traces.
	 * We also need to save the current stack level and the proc
         * string in startLevel and startCmd so that we can delete this
         * interpreter trace when it reaches the end of this proc.
	 */

	if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
	    && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | 
				  TCL_TRACE_LEAVE_DURING_EXEC))) {
		tcmdPtr->startLevel = level;
		tcmdPtr->startCmd = 
		    (char *) ckalloc((unsigned) (strlen(command) + 1));
		strcpy(tcmdPtr->startCmd, command);
		tcmdPtr->refCount++;
		tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
		   (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, 
		   TraceExecutionProc, (ClientData)tcmdPtr, 
		   CommandObjTraceDeleted);
	}
    }
    if (flags & TCL_TRACE_DESTROYED) {
	if (tcmdPtr->stepTrace != NULL) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
            if (tcmdPtr->startCmd != NULL) {
	        ckfree((char *)tcmdPtr->startCmd);
	    }
	}
    }
    if (call) {
	if ((--tcmdPtr->refCount) <= 0) {
	    ckfree((char*)tcmdPtr);
	}
    }
    return traceCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *	This procedure is called to handle variable accesses that have
 *	been traced using the "trace" command.
 *
 * Results:
 *	Normally returns NULL.  If the trace command returns an error,
 *	then this procedure returns an error string.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Information about the variable trace. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable or array. */
    CONST char *name2;		/* Name of element within array;  NULL means
				 * scalar variable is being referenced. */
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
    char *result;
    int code;
    Tcl_DString cmd;

    /* 
     * We might call Tcl_Eval() below, and that might evaluate
     * [trace vdelete] which might try to free tvarPtr.  We want
     * to use tvarPtr until the end of this function, so we use
     * Tcl_Preserve() and Tcl_Release() to be sure it is not 
     * freed while we still need it.
     */

    Tcl_Preserve((ClientData) tvarPtr);

    result = NULL;
    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)
	    && !Tcl_LimitExceeded(interp)) {
	if (tvarPtr->length != (size_t) 0) {
	    /*
	     * Generate a command to execute by appending list elements
	     * for the two variable names and the operation. 
	     */

	    Tcl_DStringInit(&cmd);
	    Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
	    Tcl_DStringAppendElement(&cmd, name1);
	    Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES







|

|





|















|
|
|
|
|
|
|
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|




|




<






|
|
|





|
|














>
|
>
|
|
>
>
|
|
>
|

|
|
|
|
|
>
|
|
|
|
>
|
|
|
|

|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|

|

|
|
|
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



<






|
|
|





|
|

















|

|
|
|
|
|
>
|
|
|
|
>
|
|
|
|

|
<
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|

|

|
|
|
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
<
|
|
|
|



<






|
|
|





|
|















|
|
>
|
|
>
|

|
|
|
|
|
>
|
|
|
|
>
|
|
|
|

|
<
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|

|
|
|
|
|

|

|
|
|
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|



<






|
|
|
<


|
|
<
|
|
|
|
|
|













|
|
|
|
|
<




|
|










|







|












|
|
|
|
|





|
|
|
<






|
|

|
|
|
|






|
|











|
|




|















|
|
<








|
|
|
|








|
|
|







|



|
|
|







|

|
|
|



|

>
>
>
|
>








|



|


|

|


>
|
|
|

>









|
|
|
















|
|
|






|

|



|
|













|
|

|
|
|







|





>




>


>




|
|



>
|
>
>


>

|
|
|
<

>


|






>


|

>
>
>

>
>


>



|









|
|
|
|
<
|
|
|
|
|


|
|


|



>
|
|
|

|
|
|
|

|
|










|



|

|





|
|
|
|
>
|
>
>
>

|
|
|
|
|
|
>

|


|
|




|
|

|


>
|
>













|
|
|
|
|
|
|


|
|


|



>
|
|
|

|
|
|
|

|
|








<

|
|
|


|

|




|
|
|
|
|
|
|
|
|
|
|
|
>
>

|
|
|
|
|
|
>

|
>



>

|
|
|
|
|
|

>





|
>
|
>
|
>
|
|
>
>
|
|
|
>
|
<
|
<
|


>
|
>
|

|
|
|

>
|
|





>
|
>















|

|
|
|






|





|

|



|
|







|






|

|

|
|
|
<










|
|


|






>
|












|
<
|
|
|
|
|
|
|


|
|


|
|



>

|
|
|






|

|
|
|
<

>


|


|
|
|
<
|
|

>

|
|



>

|
|
|

>
|
|
|
|
|
|
|
|
|
|
<



>







>
>
|
>
>


<
<
<
|





>
|
>
>









>
|
>
>




|
>
|
>
>

>
>
|
>
>








|

|
|





>
|
|
|
|

>








|

|
|
<
|
|
|

>

|
|
|
|

|
|
|
|
|







|
|
















|
|


|
|













|









|
|
|
<
|
|









|
|







174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359

360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503

504
505
506
507
508
509

510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551

552
553
554
555
556
557
558
559
560
561
562
563
564

565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606

607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658

659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729

730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754

755
756
757
758
759
760
761
762
763
764
765
766
767

768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792

793
794
795
796
797
798
799

800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855

856
857
858
859
860
861

862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984

985
986
987
988
989
990
991
992
993

994
995
996
997

998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021

1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071

1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127

1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318

1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360

1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495

1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566

1567

1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651

1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687

1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721

1722
1723
1724
1725
1726
1727
1728
1729
1730
1731

1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758

1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776



1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850

1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923

1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int optionIndex;
    char *name, *flagOps, *p;
    /* Main sub commands to 'trace' */
    static CONST char *traceOptions[] = {
	"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	"variable", "vdelete", "vinfo",
#endif
	(char *) NULL
    };
    /* 'OLD' options are pre-Tcl-8.4 style */
    enum traceOptions {
	TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
		"option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum traceOptions) optionIndex) {
    case TRACE_ADD:
    case TRACE_REMOVE: {
	/*
	 * All sub commands of trace add/remove must take at least one more
	 * argument. Beyond that we let the subcommand itself control the
	 * argument structure.
	 */

	int typeIndex;

	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
	    return TCL_ERROR;
	}
	if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option",
		0, &typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
    }
    case TRACE_INFO: {
	/*
	 * All sub commands of trace info must take exactly two more arguments
	 * which name the type of thing being traced and the name of the thing
	 * being traced.
	 */

	int typeIndex;
	if (objc < 3) {
	    /*
	     * Delegate other complaints to the type-specific code which can
	     * give a better error message.
	     */

	    Tcl_WrongNumArgs(interp, 2, objv, "type name");
	    return TCL_ERROR;
	}
	if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option",
		0, &typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
	break;
    }

#ifndef TCL_REMOVE_OBSOLETE_TRACES
    case TRACE_OLD_VARIABLE:
    case TRACE_OLD_VDELETE: {
	Tcl_Obj *copyObjv[6];
	Tcl_Obj *opsList;
	int code, numFlags;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
	    return TCL_ERROR;
	}

	opsList = Tcl_NewObj();
	Tcl_IncrRefCount(opsList);
	flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
	if (numFlags == 0) {
	    Tcl_DecrRefCount(opsList);
	    goto badVarOps;
	}
	for (p = flagOps; *p != 0; p++) {
	    if (*p == 'r') {
		Tcl_ListObjAppendElement(NULL, opsList,
			Tcl_NewStringObj("read", -1));
	    } else if (*p == 'w') {
		Tcl_ListObjAppendElement(NULL, opsList,
			Tcl_NewStringObj("write", -1));
	    } else if (*p == 'u') {
		Tcl_ListObjAppendElement(NULL, opsList,
			Tcl_NewStringObj("unset", -1));
	    } else if (*p == 'a') {
		Tcl_ListObjAppendElement(NULL, opsList,
			Tcl_NewStringObj("array", -1));
	    } else {
		Tcl_DecrRefCount(opsList);
		goto badVarOps;
	    }
	}
	copyObjv[0] = NULL;
	memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
	copyObjv[4] = opsList;
	if (optionIndex == TRACE_OLD_VARIABLE) {
	    code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
	} else {
	    code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
	}
	Tcl_DecrRefCount(opsList);
	return code;
    }
    case TRACE_OLD_VINFO: {
	ClientData clientData;
	char ops[5];
	Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "name");
	    return TCL_ERROR;
	}
	resultListPtr = Tcl_NewObj();
	clientData = 0;
	name = Tcl_GetString(objv[2]);
	while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
		TraceVarProc, clientData)) != 0) {

	    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

	    pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    p = ops;
	    if (tvarPtr->flags & TCL_TRACE_READS) {
		*p = 'r';
		p++;
	    }
	    if (tvarPtr->flags & TCL_TRACE_WRITES) {
		*p = 'w';
		p++;
	    }
	    if (tvarPtr->flags & TCL_TRACE_UNSETS) {
		*p = 'u';
		p++;
	    }
	    if (tvarPtr->flags & TCL_TRACE_ARRAY) {
		*p = 'a';
		p++;
	    }
	    *p = '\0';

	    /*
	     * Build a pair (2-item list) with the ops string as the first obj
	     * element and the tvarPtr->command string as the second obj
	     * element. Append the pair (as an element) to the end of the
	     * result object list.
	     */

	    elemObjPtr = Tcl_NewStringObj(ops, -1);
	    Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
	    elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
	    Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
	}
	Tcl_SetObjResult(interp, resultListPtr);
	break;
    }
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
    }
    return TCL_OK;

  badVarOps:
    Tcl_AppendResult(interp, "bad operations \"", flagOps,
	    "\": should be one or more of rwua", (char *) NULL);
    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceExecutionObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the [trace
 *	{add|remove|info} execution ...] subcommands. See the user
 *	documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed; may
 *	add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions {
	TRACE_ADD, TRACE_INFO, TRACE_REMOVE
    };
    static CONST char *opStrings[] = {
	"enter", "leave", "enterstep", "leavestep", (char *) NULL
    };
    enum operations {
	TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
	TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP
    };

    switch ((enum traceOptions) optionIndex) {
    case TRACE_ADD:
    case TRACE_REMOVE: {
	int flags = 0;
	int i, listLen, result;
	Tcl_Obj **elemPtrs;

	if (objc != 6) {
	    Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
	    return TCL_ERROR;
	}

	/*
	 * Make sure the ops argument is a list object; get its length and a
	 * pointer to its array of element pointers.
	 */

	result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);

	if (result != TCL_OK) {
	    return result;
	}
	if (listLen == 0) {
	    Tcl_SetResult(interp, "bad operation list \"\": must be "
		    "one or more of enter, leave, enterstep, or leavestep",
		    TCL_STATIC);
	    return TCL_ERROR;
	}
	for (i = 0; i < listLen; i++) {
	    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
		    "operation", TCL_EXACT, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum operations) index) {
	    case TRACE_EXEC_ENTER:
		flags |= TCL_TRACE_ENTER_EXEC;
		break;
	    case TRACE_EXEC_LEAVE:
		flags |= TCL_TRACE_LEAVE_EXEC;
		break;
	    case TRACE_EXEC_ENTER_STEP:
		flags |= TCL_TRACE_ENTER_DURING_EXEC;
		break;
	    case TRACE_EXEC_LEAVE_STEP:
		flags |= TCL_TRACE_LEAVE_DURING_EXEC;
		break;
	    }
	}
	command = Tcl_GetStringFromObj(objv[5], &commandLength);
	length = (size_t) commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceCommandInfo *tcmdPtr;

	    tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
		    (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
			    + length + 1));
	    tcmdPtr->flags = flags;
	    tcmdPtr->stepTrace = NULL;
	    tcmdPtr->startLevel = 0;
	    tcmdPtr->startCmd = NULL;
	    tcmdPtr->length = length;
	    tcmdPtr->refCount = 1;
	    flags |= TCL_TRACE_DELETE;
	    if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
		    TCL_TRACE_LEAVE_DURING_EXEC)) {
		flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	    }
	    strcpy(tcmdPtr->command, command);
	    name = Tcl_GetString(objv[3]);
	    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
		    (ClientData) tcmdPtr) != TCL_OK) {
		ckfree((char *) tcmdPtr);
		return TCL_ERROR;
	    }
	} else {
	    /*
	     * Search through all of our traces on this command to see if
	     * there's one with the given command. If so, then delete the
	     * first one that matches.
	     */

	    TraceCommandInfo *tcmdPtr;
	    ClientData clientData = NULL;
	    name = Tcl_GetString(objv[3]);

	    /* First ensure the name given is valid */
	    if (Tcl_FindCommand(interp, name, NULL,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		return TCL_ERROR;
	    }

	    while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		    TraceCommandProc, clientData)) != NULL) {
		tcmdPtr = (TraceCommandInfo *) clientData;

		/*
		 * In checking the 'flags' field we must remove any extraneous
		 * flags which may have been temporarily added by various
		 * pieces of the trace mechanism.
		 */

		if ((tcmdPtr->length == length)
			&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
				TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags)

			&& (strncmp(command, tcmdPtr->command,
				(size_t) length) == 0)) {
		    flags |= TCL_TRACE_DELETE;
		    if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
			    TCL_TRACE_LEAVE_DURING_EXEC)) {
			flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);

		    }
		    Tcl_UntraceCommand(interp, name, flags,
			    TraceCommandProc, clientData);
		    if (tcmdPtr->stepTrace != NULL) {
			/*
			 * We need to remove the interpreter-wide trace which
			 * we created to allow 'step' traces.
			 */

			Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
			tcmdPtr->stepTrace = NULL;
			if (tcmdPtr->startCmd != NULL) {
			    ckfree((char *)tcmdPtr->startCmd);
			}
		    }
		    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
			/* Postpone deletion */
			tcmdPtr->flags = 0;
		    }
		    if ((--tcmdPtr->refCount) <= 0) {
			ckfree((char*)tcmdPtr);
		    }
		    break;
		}
	    }
	}
	break;
    }
    case TRACE_INFO: {
	ClientData clientData;
	Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "name");
	    return TCL_ERROR;
	}

	clientData = NULL;
	name = Tcl_GetString(objv[3]);

	/* First ensure the name given is valid */
	if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {

	    return TCL_ERROR;
	}

	resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		TraceCommandProc, clientData)) != NULL) {
	    int numOps = 0;

	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;

	    /*
	     * Build a list with the ops list as the first obj element and the
	     * tcmdPtr->command string as the second obj element. Append this

	     * list (as an element) to the end of the result object list.
	     */

	    elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    Tcl_IncrRefCount(elemObjPtr);
	    if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("enter",5));
	    }
	    if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("leave",5));
	    }
	    if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("enterstep",9));
	    }
	    if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("leavestep",9));
	    }
	    Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
	    if (0 == numOps) {
		Tcl_DecrRefCount(elemObjPtr);
		continue;
	    }
	    eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
	    Tcl_DecrRefCount(elemObjPtr);
	    elemObjPtr = NULL;

	    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr,
		    Tcl_NewStringObj(tcmdPtr->command, -1));
	    Tcl_ListObjAppendElement(interp, resultListPtr,
		    eachTraceObjPtr);
	}
	Tcl_SetObjResult(interp, resultListPtr);
	break;
    }
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceCommandObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the [trace
 *	{add|info|remove} command ...] subcommands. See the user documentation
 *	for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed; may
 *	add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
    enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };

    switch ((enum traceOptions) optionIndex) {
    case TRACE_ADD:
    case TRACE_REMOVE: {
	int flags = 0;
	int i, listLen, result;
	Tcl_Obj **elemPtrs;

	if (objc != 6) {
	    Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
	    return TCL_ERROR;
	}

	/*
	 * Make sure the ops argument is a list object; get its length and a
	 * pointer to its array of element pointers.
	 */

	result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);

	if (result != TCL_OK) {
	    return result;
	}
	if (listLen == 0) {
	    Tcl_SetResult(interp, "bad operation list \"\": must be "
		    "one or more of delete or rename", TCL_STATIC);
	    return TCL_ERROR;
	}

	for (i = 0; i < listLen; i++) {
	    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
		    "operation", TCL_EXACT, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum operations) index) {
	    case TRACE_CMD_RENAME:
		flags |= TCL_TRACE_RENAME;
		break;
	    case TRACE_CMD_DELETE:
		flags |= TCL_TRACE_DELETE;
		break;
	    }
	}

	command = Tcl_GetStringFromObj(objv[5], &commandLength);
	length = (size_t) commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceCommandInfo *tcmdPtr;

	    tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
		    (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
			    + length + 1));
	    tcmdPtr->flags = flags;
	    tcmdPtr->stepTrace = NULL;
	    tcmdPtr->startLevel = 0;
	    tcmdPtr->startCmd = NULL;
	    tcmdPtr->length = length;
	    tcmdPtr->refCount = 1;
	    flags |= TCL_TRACE_DELETE;
	    strcpy(tcmdPtr->command, command);
	    name = Tcl_GetString(objv[3]);
	    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
		    (ClientData) tcmdPtr) != TCL_OK) {
		ckfree((char *) tcmdPtr);
		return TCL_ERROR;
	    }
	} else {
	    /*
	     * Search through all of our traces on this command to see if
	     * there's one with the given command. If so, then delete the
	     * first one that matches.
	     */

	    TraceCommandInfo *tcmdPtr;
	    ClientData clientData = NULL;
	    name = Tcl_GetString(objv[3]);

	    /* First ensure the name given is valid */
	    if (Tcl_FindCommand(interp, name, NULL,
		    TCL_LEAVE_ERR_MSG) == NULL) {
		return TCL_ERROR;
	    }

	    while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		    TraceCommandProc, clientData)) != NULL) {
		tcmdPtr = (TraceCommandInfo *) clientData;
		if ((tcmdPtr->length == length)
			&& (tcmdPtr->flags == flags)
			&& (strncmp(command, tcmdPtr->command,
				(size_t) length) == 0)) {
		    Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE,

			    TraceCommandProc, clientData);
		    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
		    if ((--tcmdPtr->refCount) <= 0) {
			ckfree((char *) tcmdPtr);
		    }
		    break;
		}
	    }
	}
	break;
    }
    case TRACE_INFO: {
	ClientData clientData;
	Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "name");
	    return TCL_ERROR;
	}

	clientData = NULL;
	name = Tcl_GetString(objv[3]);

	/* First ensure the name given is valid */
	if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {

	    return TCL_ERROR;
	}

	resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		TraceCommandProc, clientData)) != NULL) {
	    int numOps = 0;

	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;

	    /*
	     * Build a list with the ops list as the first obj element and the
	     * tcmdPtr->command string as the second obj element. Append this

	     * list (as an element) to the end of the result object list.
	     */

	    elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    Tcl_IncrRefCount(elemObjPtr);
	    if (tcmdPtr->flags & TCL_TRACE_RENAME) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("rename",6));
	    }
	    if (tcmdPtr->flags & TCL_TRACE_DELETE) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("delete",6));
	    }
	    Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
	    if (0 == numOps) {
		Tcl_DecrRefCount(elemObjPtr);
		continue;
	    }
	    eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
	    Tcl_DecrRefCount(elemObjPtr);

	    elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
	    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr);

	}
	Tcl_SetObjResult(interp, resultListPtr);
	break;
    }
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceVariableObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the [trace
 *	{add|info|remove} variable ...] subcommands. See the user
 *	documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed; may
 *	add or remove variable traces on a variable.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = {
	"array", "read", "unset", "write", (char *) NULL
    };
    enum operations {
	TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE
    };

    switch ((enum traceOptions) optionIndex) {
    case TRACE_ADD:
    case TRACE_REMOVE: {
	int flags = 0;
	int i, listLen, result;
	Tcl_Obj **elemPtrs;

	if (objc != 6) {
	    Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
	    return TCL_ERROR;
	}

	/*
	 * Make sure the ops argument is a list object; get its length and a
	 * pointer to its array of element pointers.
	 */

	result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);

	if (result != TCL_OK) {
	    return result;
	}
	if (listLen == 0) {
	    Tcl_SetResult(interp, "bad operation list \"\": must be "
		    "one or more of array, read, unset, or write", TCL_STATIC);

	    return TCL_ERROR;
	}
	for (i = 0; i < listLen ; i++) {
	    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
		    "operation", TCL_EXACT, &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch ((enum operations) index) {
	    case TRACE_VAR_ARRAY:
		flags |= TCL_TRACE_ARRAY;
		break;
	    case TRACE_VAR_READ:
		flags |= TCL_TRACE_READS;
		break;
	    case TRACE_VAR_UNSET:
		flags |= TCL_TRACE_UNSETS;
		break;
	    case TRACE_VAR_WRITE:
		flags |= TCL_TRACE_WRITES;
		break;
	    }
	}
	command = Tcl_GetStringFromObj(objv[5], &commandLength);
	length = (size_t) commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceVarInfo *tvarPtr;
	    tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
		    (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
			    + length + 1));
	    tvarPtr->flags = flags;
	    if (objv[0] == NULL) {
		tvarPtr->flags |= TCL_TRACE_OLD_STYLE;
	    }
	    tvarPtr->length = length;
	    flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
	    strcpy(tvarPtr->command, command);
	    name = Tcl_GetString(objv[3]);
	    if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
		    (ClientData) tvarPtr) != TCL_OK) {
		ckfree((char *) tvarPtr);
		return TCL_ERROR;
	    }
	} else {
	    /*
	     * Search through all of our traces on this variable to see if
	     * there's one with the given command. If so, then delete the
	     * first one that matches.
	     */

	    TraceVarInfo *tvarPtr;
	    ClientData clientData = 0;
	    name = Tcl_GetString(objv[3]);
	    while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
		    TraceVarProc, clientData)) != 0) {
		tvarPtr = (TraceVarInfo *) clientData;
		if ((tvarPtr->length == length)
			&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
			&& (strncmp(command, tvarPtr->command,
				(size_t) length) == 0)) {
		    Tcl_UntraceVar2(interp, name, NULL,
			    flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
			    TraceVarProc, clientData);
		    Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
		    break;
		}
	    }
	}
	break;
    }
    case TRACE_INFO: {
	ClientData clientData;
	Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "name");
	    return TCL_ERROR;
	}

	resultListPtr = Tcl_NewObj();
	clientData = 0;
	name = Tcl_GetString(objv[3]);
	while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc,
		clientData)) != 0) {

	    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

	    /*
	     * Build a list with the ops list as the first obj element and the
	     * tcmdPtr->command string as the second obj element. Append this

	     * list (as an element) to the end of the result object list.
	     */

	    elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    if (tvarPtr->flags & TCL_TRACE_ARRAY) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("array", 5));
	    }
	    if (tvarPtr->flags & TCL_TRACE_READS) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("read", 4));
	    }
	    if (tvarPtr->flags & TCL_TRACE_WRITES) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("write", 5));
	    }
	    if (tvarPtr->flags & TCL_TRACE_UNSETS) {
		Tcl_ListObjAppendElement(NULL, elemObjPtr,
			Tcl_NewStringObj("unset", 5));
	    }
	    eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);

	    elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
	    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr,
		    eachTraceObjPtr);
	}
	Tcl_SetObjResult(interp, resultListPtr);
	break;
    }
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandTraceInfo --
 *
 *	Return the clientData value associated with a trace on a command.
 *	This function can also be used to step through all of the traces on a
 *	particular command that have the same trace function.

 *
 * Results:
 *	The return value is the clientData value associated with a trace on
 *	the given command. Information will only be returned for a trace with

 *	proc as trace function. If the clientData argument is NULL then the
 *	first such trace is returned; otherwise, the next relevant one after
 *	the one given by clientData will be returned. If the command doesn't
 *	exist then an error message is left in the interpreter and NULL is
 *	returned. Also, if there are no (more) traces for the given command,
 *	NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_CommandTraceProc *proc;	/* Function assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */

{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
	    TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return NULL;
    }

    /*
     * Find the relevant trace, if any, and return its clientData.
     */

    tracePtr = cmdPtr->tracePtr;
    if (prevClientData != NULL) {
	for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
	    if ((tracePtr->clientData == prevClientData)
		    && (tracePtr->traceProc == proc)) {
		tracePtr = tracePtr->nextPtr;
		break;
	    }
	}
    }
    for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
	if (tracePtr->traceProc == proc) {
	    return tracePtr->clientData;
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceCommand --
 *
 *	Arrange for rename/deletes to a command to cause a function to be
 *	invoked, which can monitor the operations.
 *
 *	Also optionally arrange for execution of that command to cause a
 *	function to be invoked.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the command given by cmdName, such that future
 *	changes to the command will be intermediated by proc. See the manual
 *	entry for complete details on the calling sequence for proc.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which command is to be
				 * traced. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any of
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
				 * of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc;	/* Function to call when specified ops are
				 * invoked upon cmdName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
	    TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Set up trace information.
     */

    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags &
	    (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
    tracePtr->nextPtr = cmdPtr->tracePtr;
    tracePtr->refCount = 1;
    cmdPtr->tracePtr = tracePtr;
    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceCommand --
 *
 *	Remove a previously-created trace for a command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there exists a trace for the command given by cmdName with the
 *	given flags, proc, and clientData, then that trace is removed.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any of
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
				 * of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc;	/* Function assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    register CommandTrace *tracePtr;
    CommandTrace *prevPtr;
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveCommandTrace *activePtr;
    int hasExecTraces = 0;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL,
	    TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);

    for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL;  ;
	    prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc)
		&& ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE |
			TCL_TRACE_ANY_EXEC)) == flags)
		&& (tracePtr->clientData == clientData)) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
		hasExecTraces = 1;
	    }
	    break;
	}
    }

    /*
     * The code below makes it possible to delete traces while traces are
     * active: it makes sure that the deleted trace won't be processed by
     * CallCommandTraces.
     */

    for (activePtr = iPtr->activeCmdTracePtr;  activePtr != NULL;
	    activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    if (activePtr->reverseScan) {
		activePtr->nextTracePtr = prevPtr;
	    } else {
		activePtr->nextTracePtr = tracePtr->nextPtr;
	    }
	}
    }
    if (prevPtr == NULL) {
	cmdPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }
    tracePtr->flags = 0;

    if ((--tracePtr->refCount) <= 0) {
	ckfree((char*)tracePtr);
    }

    if (hasExecTraces) {
	for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
		prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
		return;
	    }
	}

	/*
	 * None of the remaining traces on this command are execution traces.
	 * We therefore remove this flag:
	 */

	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TraceCommandProc --
 *
 *	This function is called to handle command changes that have been
 *	traced using the "trace" command, when using the 'rename' or 'delete'
 *	options.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
    ClientData clientData;	/* Information about the command trace. */
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *oldName;	/* Name of command being changed. */
    CONST char *newName;	/* New name of command. Empty string or NULL
				 * means command is being deleted (renamed to
				 * ""). */
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
    int code;
    Tcl_DString cmd;

    tcmdPtr->refCount++;

    if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)
	    && !Tcl_LimitExceeded(interp)) {
	/*
	 * Generate a command to execute by appending list elements for the
	 * old and new command name and the operation.
	 */

	Tcl_DStringInit(&cmd);
	Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
	Tcl_DStringAppendElement(&cmd, oldName);
	Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
	if (flags & TCL_TRACE_RENAME) {
	    Tcl_DStringAppend(&cmd, " rename", 7);
	} else if (flags & TCL_TRACE_DELETE) {
	    Tcl_DStringAppend(&cmd, " delete", 7);
	}

	/*
	 * Execute the command. We discard any object result the command
	 * returns.
	 *
	 * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to other
	 * areas that this will be destroyed by us, otherwise a double-free
	 * might occur depending on what the eval does.
	 */

	if (flags & TCL_TRACE_DESTROYED) {
	    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
	}
	code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
		Tcl_DStringLength(&cmd), 0);
	if (code != TCL_OK) {
	    /* We ignore errors in these traced commands */
	    /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/
	}
	Tcl_DStringFree(&cmd);
    }

    /*
     * We delete when the trace was destroyed or if this is a delete trace,
     * because command deletes are unconditional, so the trace must go away.
     */

    if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
	int untraceFlags = tcmdPtr->flags;
	Tcl_InterpState state;

	if (tcmdPtr->stepTrace != NULL) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
	    if (tcmdPtr->startCmd != NULL) {
		ckfree((char *)tcmdPtr->startCmd);
	    }
	}
	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
	    /*
	     * Postpone deletion, until exec trace returns.
	     */

	    tcmdPtr->flags = 0;
	}

	/*
	 * We need to construct the same flags for Tcl_UntraceCommand as were
	 * passed to Tcl_TraceCommand. Reproduce the processing of [trace add
	 * execution/command]. Be careful to keep this code in sync with that.

	 */

	if (untraceFlags & TCL_TRACE_ANY_EXEC) {
	    untraceFlags |= TCL_TRACE_DELETE;
	    if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC
		    | TCL_TRACE_LEAVE_DURING_EXEC)) {
		untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	    }
	} else if (untraceFlags & TCL_TRACE_RENAME) {
	    untraceFlags |= TCL_TRACE_DELETE;
	}

	/*
	 * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
	 * command we're tracing has just gone away. Then decrement the
	 * clientData refCount that was set up by trace creation.
	 *
	 * Note that we save the (return) state of the interpreter to prevent
	 * bizarre error messages.
	 */

	state = Tcl_SaveInterpState(interp, TCL_OK);
	Tcl_UntraceCommand(interp, oldName, untraceFlags,
		TraceCommandProc, clientData);
	(void) Tcl_RestoreInterpState(interp, state);
	tcmdPtr->refCount--;
    }
    if ((--tcmdPtr->refCount) <= 0) {
	ckfree((char*)tcmdPtr);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckExecutionTraces --
 *
 *	Checks on all current command execution traces, and invokes functions
 *	which have been registered. This function can be used by other code
 *	which performs execution to unify the tracing system, so that
 *	execution traces will function for that other code.

 *
 *	For instance extensions like [incr Tcl] which use their own execution
 *	technique can make use of Tcl's tracing.
 *
 *	This function is called by 'TclEvalObjvInternal'
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR, etc.
 *
 * Side effects:
 *	Those side effects made by any trace functions called.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags,
	objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    CONST char *command;	/* Pointer to beginning of the current command
				 * string. */
    int numChars;		/* The number of characters in 'command' which
				 * are part of the command string. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    int code;			/* The current result code. */
    int traceFlags;		/* Current tracing situation. */
    int objc;			/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    CommandTrace *tracePtr, *lastTracePtr;
    ActiveCommandTrace active;
    int curLevel;
    int traceCode = TCL_OK;
    TraceCommandInfo* tcmdPtr;
    Tcl_InterpState state = NULL;

    if (command == NULL || cmdPtr->tracePtr == NULL) {
	return traceCode;
    }

    curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);

    active.nextPtr = iPtr->activeCmdTracePtr;
    iPtr->activeCmdTracePtr = &active;

    active.cmdPtr = cmdPtr;
    lastTracePtr = NULL;
    for (tracePtr = cmdPtr->tracePtr;
	    (traceCode == TCL_OK) && (tracePtr != NULL);
	    tracePtr = active.nextTracePtr) {
	if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
	    /*
	     * Execute the trace command in order of creation for "leave".
	     */

	    active.reverseScan = 1;
	    active.nextTracePtr = NULL;
	    tracePtr = cmdPtr->tracePtr;
	    while (tracePtr->nextPtr != lastTracePtr) {
		active.nextTracePtr = tracePtr;
		tracePtr = tracePtr->nextPtr;
	    }
	} else {
	    active.reverseScan = 0;
	    active.nextTracePtr = tracePtr->nextPtr;
	}
	tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
	if (tcmdPtr->flags != 0) {
	    tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
	    tcmdPtr->curCode  = code;
	    tcmdPtr->refCount++;
	    if (state == NULL) {
		state = Tcl_SaveInterpState(interp, code);
	    }
	    traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
		    curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
	    if ((--tcmdPtr->refCount) <= 0) {
		ckfree((char*)tcmdPtr);
	    }
	}
	if (active.nextTracePtr) {
	    lastTracePtr = active.nextTracePtr->nextPtr;
	}
    }
    iPtr->activeCmdTracePtr = active.nextPtr;
    if (state) {
	(void) Tcl_RestoreInterpState(interp, state);
    }
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckInterpTraces --
 *
 *	Checks on all current traces, and invokes functions which have been
 *	registered. This function can be used by other code which performs
 *	execution to unify the tracing system. For instance extensions like
 *	[incr Tcl] which use their own execution technique can make use of
 *	Tcl's tracing.
 *
 *	This function is called by 'TclEvalObjvInternal'
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR, etc.
 *
 * Side effects:
 *	Those side effects made by any trace functions called.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags,
	objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    CONST char *command;	/* Pointer to beginning of the current command
				 * string. */
    int numChars;		/* The number of characters in 'command' which
				 * are part of the command string. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    int code;			/* The current result code. */
    int traceFlags;		/* Current tracing situation. */
    int objc;			/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    Trace *tracePtr, *lastTracePtr;
    ActiveInterpTrace active;
    int curLevel;
    int traceCode = TCL_OK;

    Tcl_InterpState state = NULL;

    if (command == NULL || iPtr->tracePtr == NULL
	    || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
	return(traceCode);
    }

    curLevel = iPtr->numLevels;

    active.nextPtr = iPtr->activeInterpTracePtr;
    iPtr->activeInterpTracePtr = &active;

    lastTracePtr = NULL;
    for (tracePtr = iPtr->tracePtr;
	    (traceCode == TCL_OK) && (tracePtr != NULL);
	    tracePtr = active.nextTracePtr) {
	if (traceFlags & TCL_TRACE_ENTER_EXEC) {
	    /*
	     * Execute the trace command in reverse order of creation for
	     * "enterstep" operation. The order is changed for "enterstep"
	     * instead of for "leavestep" as was done in
	     * TclCheckExecutionTraces because for step traces,
	     * Tcl_CreateObjTrace creates one more linked list of traces which
	     * results in one more reversal of trace invocation.
	     */

	    active.reverseScan = 1;
	    active.nextTracePtr = NULL;
	    tracePtr = iPtr->tracePtr;
	    while (tracePtr->nextPtr != lastTracePtr) {
		active.nextTracePtr = tracePtr;
		tracePtr = tracePtr->nextPtr;
	    }
	} else {
	    active.reverseScan = 0;
	    active.nextTracePtr = tracePtr->nextPtr;
	}

	if (tracePtr->level > 0 && curLevel > tracePtr->level) {
	    continue;
	}

	if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
	    /*
	     * The proc invoked might delete the traced command which which
	     * might try to free tracePtr. We want to use tracePtr until the
	     * end of this if section, so we use Tcl_Preserve() and
	     * Tcl_Release() to be sure it is not freed while we still need
	     * it.
	     */

	    Tcl_Preserve((ClientData) tracePtr);
	    tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
	    if (state == NULL) {
		state = Tcl_SaveInterpState(interp, code);
	    }

	    if (tracePtr->flags &
		    (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
		/*
		 * New style trace.
		 */

		if (tracePtr->flags & traceFlags) {
		    if (tracePtr->proc == TraceExecutionProc) {
			TraceCommandInfo* tcmdPtr =
				(TraceCommandInfo *) tracePtr->clientData;
			tcmdPtr->curFlags = traceFlags;
			tcmdPtr->curCode  = code;
		    }
		    traceCode = (tracePtr->proc)(tracePtr->clientData,

			    interp, curLevel, command, (Tcl_Command) cmdPtr,

			    objc, objv);
		}
	    } else {
		/*
		 * Old-style trace.
		 */

		if (traceFlags & TCL_TRACE_ENTER_EXEC) {
		    /*
		     * Old-style interpreter-wide traces only trigger before
		     * the command is executed.
		     */

		    traceCode = CallTraceFunction(interp, tracePtr, cmdPtr,
			    command, numChars, objc, objv);
		}
	    }
	    tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
	    Tcl_Release((ClientData) tracePtr);
	}
	if (active.nextTracePtr) {
	    lastTracePtr = active.nextTracePtr->nextPtr;
	}
    }
    iPtr->activeInterpTracePtr = active.nextPtr;
    if (state) {
	if (traceCode == TCL_OK) {
	    (void) Tcl_RestoreInterpState(interp, state);
	} else {
	    Tcl_DiscardInterpState(state);
	}
    }
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CallTraceFunction --
 *
 *	Invokes a trace function registered with an interpreter. These
 *	functions trace command execution. Currently this trace function is
 *	called with the address of the string-based Tcl_CmdProc for the
 *	command, not the Tcl_ObjCmdProc.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Those side effects made by the trace function.
 *
 *----------------------------------------------------------------------
 */

static int
CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    register Trace *tracePtr;	/* Describes the trace function to call. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    CONST char *command;	/* Points to the first character of the
				 * command's source before substitutions. */
    int numChars;		/* The number of characters in the command's
				 * source. */
    register int objc;		/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    char *commandCopy;
    int traceCode;

    /*
     * Copy the command characters into a new string.
     */

    commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
    memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
    commandCopy[numChars] = '\0';

    /*
     * Call the trace function then free allocated storage.
     */

    traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp*) iPtr,
	    iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv);


    ckfree((char *) commandCopy);
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CommandObjTraceDeleted --
 *
 *	Ensure the trace is correctly deleted by decrementing its refCount and
 *	only deleting if no other references exist.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May release memory.
 *
 *----------------------------------------------------------------------
 */

static void
CommandObjTraceDeleted(ClientData clientData) {
    TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
    if ((--tcmdPtr->refCount) <= 0) {
	ckfree((char*)tcmdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TraceExecutionProc --
 *
 *	This function is invoked whenever code relevant to a 'trace execution'

 *	command is executed. It is called in one of two ways in Tcl's core:
 *
 *	(i) by the TclCheckExecutionTraces, when an execution trace has been
 *	triggered.
 *	(ii) by TclCheckInterpTraces, when a prior execution trace has created
 *	a trace of the internals of a procedure, passing in this function as
 *	the one to be called.
 *
 * Results:
 *	The return value is a standard Tcl completion code such as TCL_OK or
 *	TCL_ERROR, etc.
 *
 * Side effects:
 *	May invoke an arbitrary Tcl procedure, and may create or delete an
 *	interpreter-wide trace.
 *
 *----------------------------------------------------------------------
 */

static int
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level,
	CONST char* command, Tcl_Command cmdInfo, int objc,
	struct Tcl_Obj *CONST objv[]) {
    int call = 0;
    Interp *iPtr = (Interp *) interp;
    TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
    int flags = tcmdPtr->curFlags;
    int code  = tcmdPtr->curCode;
    int traceCode  = TCL_OK;

    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
	/*
	 * Inside any kind of execution trace callback, we do not allow any
	 * further execution trace callbacks to be called for the same trace.

	 */

	return traceCode;
    }

    if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) {
	/*
	 * Check whether the current call is going to eval arbitrary Tcl code
	 * with a generated trace, or whether we are only going to setup
	 * interpreter-wide traces to implement the 'step' traces. This latter

	 * situation can happen if we create a command trace without either
	 * before or after operations, but with either of the step operations.
	 */

	if (flags & TCL_TRACE_EXEC_DIRECT) {
	    call = flags & tcmdPtr->flags &
		    (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	} else {
	    call = 1;
	}

	/*
	 * First, if we have returned back to the level at which we created an
	 * interpreter trace for enterstep and/or leavestep execution traces,
	 * we remove it here.
	 */

	if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL)
		&& (level == tcmdPtr->startLevel)
		&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
	    if (tcmdPtr->startCmd != NULL) {
		ckfree((char *)tcmdPtr->startCmd);
	    }
	}


	/*
	 * Second, create the tcl callback, if required.
	 */

	if (call) {
	    Tcl_DString cmd;
	    Tcl_DString sub;
	    int i;

	    Tcl_DStringInit(&cmd);
	    Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);

	    /*
	     * Append command with arguments.
	     */

	    Tcl_DStringInit(&sub);
	    for (i = 0; i < objc; i++) {



		Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i]));
	    }
	    Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
	    Tcl_DStringFree(&sub);

	    if (flags & TCL_TRACE_ENTER_EXEC) {
		/*
		 * Append trace operation.
		 */

		if (flags & TCL_TRACE_EXEC_DIRECT) {
		    Tcl_DStringAppendElement(&cmd, "enter");
		} else {
		    Tcl_DStringAppendElement(&cmd, "enterstep");
		}
	    } else if (flags & TCL_TRACE_LEAVE_EXEC) {
		Tcl_Obj* resultCode;
		char* resultCodeStr;

		/*
		 * Append result code.
		 */

		resultCode = Tcl_NewIntObj(code);
		resultCodeStr = Tcl_GetString(resultCode);
		Tcl_DStringAppendElement(&cmd, resultCodeStr);
		Tcl_DecrRefCount(resultCode);

		/*
		 * Append result string.
		 */

		Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));

		/*
		 * Append trace operation.
		 */

		if (flags & TCL_TRACE_EXEC_DIRECT) {
		    Tcl_DStringAppendElement(&cmd, "leave");
		} else {
		    Tcl_DStringAppendElement(&cmd, "leavestep");
		}
	    } else {
		Tcl_Panic("TraceExecutionProc: bad flag combination");
	    }

	    /*
	     * Execute the command. We discard any object result the command
	     * returns.
	     */

	    tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
	    iPtr->flags    |= INTERP_TRACE_IN_PROGRESS;
	    tcmdPtr->refCount++;

	    /*
	     * This line can have quite arbitrary side-effects, including
	     * deleting the trace, the command being traced, or even the
	     * interpreter.
	     */

	    traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
	    tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
	    iPtr->flags    &= ~INTERP_TRACE_IN_PROGRESS;
	    if (tcmdPtr->flags == 0) {
		flags |= TCL_TRACE_DESTROYED;
	    }
	    Tcl_DStringFree(&cmd);
	}

	/*
	 * Third, if there are any step execution traces for this proc, we
	 * register an interpreter trace to invoke enterstep and/or leavestep

	 * traces. We also need to save the current stack level and the proc
	 * string in startLevel and startCmd so that we can delete this
	 * interpreter trace when it reaches the end of this proc.
	 */

	if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
		&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
			TCL_TRACE_LEAVE_DURING_EXEC))) {
	    tcmdPtr->startLevel = level;
	    tcmdPtr->startCmd =
		    (char *) ckalloc((unsigned) (strlen(command) + 1));
	    strcpy(tcmdPtr->startCmd, command);
	    tcmdPtr->refCount++;
	    tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
		   (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
		   TraceExecutionProc, (ClientData)tcmdPtr,
		   CommandObjTraceDeleted);
	}
    }
    if (flags & TCL_TRACE_DESTROYED) {
	if (tcmdPtr->stepTrace != NULL) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
	    if (tcmdPtr->startCmd != NULL) {
		ckfree((char *)tcmdPtr->startCmd);
	    }
	}
    }
    if (call) {
	if ((--tcmdPtr->refCount) <= 0) {
	    ckfree((char*)tcmdPtr);
	}
    }
    return traceCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *	This function is called to handle variable accesses that have been
 *	traced using the "trace" command.
 *
 * Results:
 *	Normally returns NULL. If the trace command returns an error, then
 *	this function returns an error string.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Information about the variable trace. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable or array. */
    CONST char *name2;		/* Name of element within array; NULL means
				 * scalar variable is being referenced. */
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
    char *result;
    int code;
    Tcl_DString cmd;

    /*
     * We might call Tcl_Eval() below, and that might evaluate [trace vdelete]
     * which might try to free tvarPtr. We want to use tvarPtr until the end

     * of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
     * it is not freed while we still need it.
     */

    Tcl_Preserve((ClientData) tvarPtr);

    result = NULL;
    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)
	    && !Tcl_LimitExceeded(interp)) {
	if (tvarPtr->length != (size_t) 0) {
	    /*
	     * Generate a command to execute by appending list elements for
	     * the two variable names and the operation.
	     */

	    Tcl_DStringInit(&cmd);
	    Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
	    Tcl_DStringAppendElement(&cmd, name1);
	    Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
		    Tcl_DStringAppend(&cmd, " write", 6);
		} else if (flags & TCL_TRACE_UNSETS) {
		    Tcl_DStringAppend(&cmd, " unset", 6);
		}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	    }
#endif
	    
	    /*
	     * Execute the command.  
	     * We discard any object result the command returns.
	     *
	     * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
	     * other areas that this will be destroyed by us, otherwise a
	     * double-free might occur depending on what the eval does.
	     */

	    if (flags & TCL_TRACE_DESTROYED) {
		tvarPtr->flags |= TCL_TRACE_DESTROYED;
	    }
	    code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
		    Tcl_DStringLength(&cmd), 0);
	    if (code != TCL_OK) {	     /* copy error msg to result */
		Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(errMsgObj);
		result = (char *) errMsgObj;
	    }
	    Tcl_DStringFree(&cmd);
	}
    }







|

|
|











|







1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
		    Tcl_DStringAppend(&cmd, " write", 6);
		} else if (flags & TCL_TRACE_UNSETS) {
		    Tcl_DStringAppend(&cmd, " unset", 6);
		}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	    }
#endif

	    /*
	     * Execute the command. We discard any object result the command
	     * returns.
	     *
	     * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
	     * other areas that this will be destroyed by us, otherwise a
	     * double-free might occur depending on what the eval does.
	     */

	    if (flags & TCL_TRACE_DESTROYED) {
		tvarPtr->flags |= TCL_TRACE_DESTROYED;
	    }
	    code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
		    Tcl_DStringLength(&cmd), 0);
	    if (code != TCL_OK) {		/* copy error msg to result */
		Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(errMsgObj);
		result = (char *) errMsgObj;
	    }
	    Tcl_DStringFree(&cmd);
	}
    }
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015

2016

2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateObjTrace --
 *
 *	Arrange for a procedure to be called to trace command execution.
 *
 * Results:
 *	The return value is a token for the trace, which may be passed
 *	to Tcl_DeleteTrace to eliminate the trace.
 *
 * Side effects:
 *	From now on, proc will be called just before a command procedure
 *	is called to execute a Tcl command.  Calls to proc will have the
 *	following form:
 *
 *      void proc( ClientData     clientData,
 *                 Tcl_Interp*    interp,
 *                 int            level,
 *                 CONST char*    command,
 *                 Tcl_Command    commandInfo,
 *                 int            objc,
 *                 Tcl_Obj *CONST objv[] );
 *
 *      The 'clientData' and 'interp' arguments to 'proc' will be the
 *      same as the arguments to Tcl_CreateObjTrace.  The 'level'
 *	argument gives the nesting depth of command interpretation within
 *	the interpreter.  The 'command' argument is the ASCII text of
 *	the command being evaluated -- before any substitutions are
 *	performed.  The 'commandInfo' argument gives a handle to the
 *	command procedure that will be evaluated.  The 'objc' and 'objv'
 *	parameters give the parameter vector that will be passed to the
 *	command procedure.  proc does not return a value.
 *
 *      It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
 *      to change the command procedure or client data for the command
 *      being evaluated, and these changes will take effect with the
 *      current evaluation.
 *
 * The 'level' argument specifies the maximum nesting level of calls
 * to be traced.  If the execution depth of the interpreter exceeds
 * 'level', the trace callback is not executed.
 *
 * The 'flags' argument is either zero or the value,
 * TCL_ALLOW_INLINE_COMPILATION.  If the TCL_ALLOW_INLINE_COMPILATION
 * flag is not present, the bytecode compiler will not generate inline
 * code for Tcl's built-in commands.  This behavior will have a significant
 * impact on performance, but will ensure that all command evaluations are
 * traced.  If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
 * bytecode compiler will have its normal behavior of compiling in-line
 * code for some of Tcl's built-in commands.  In this case, the tracing
 * will be imprecise -- in-line code will not be traced -- but run-time
 * performance will be improved.  The latter behavior is desired for
 * many applications such as profiling of run time.
 *
 * When the trace is deleted, the 'delProc' procedure will be invoked,
 * passing it the original client data.  
 *
 *----------------------------------------------------------------------
 */

Tcl_Trace
Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
    Tcl_Interp* interp;		/* Tcl interpreter */
    int level;			/* Maximum nesting level */
    int flags;			/* Flags, see above */
    Tcl_CmdObjTraceProc* proc;	/* Trace callback */
    ClientData clientData;	/* Client data for the callback */
    Tcl_CmdObjTraceDeleteProc* delProc;
				/* Procedure to call when trace is deleted */
{
    register Trace *tracePtr;
    register Interp *iPtr = (Interp *) interp;


    /* Test if this trace allows inline compilation of commands */


    if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
	if (iPtr->tracesForbiddingInline == 0) {

	    /*
	     * When the first trace forbidding inline compilation is
	     * created, invalidate existing compiled code for this
	     * interpreter and arrange (by setting the
	     * DONT_COMPILE_CMDS_INLINE flag) that when compiling new
	     * code, no commands will be compiled inline (i.e., into
	     * an inline sequence of instructions). We do this because
	     * commands that were compiled inline will never result in
	     * a command trace being called.
	     */

	    iPtr->compileEpoch++;
	    iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
	}
	iPtr->tracesForbiddingInline++;
    }
    
    tracePtr = (Trace *) ckalloc(sizeof(Trace));
    tracePtr->level		= level;
    tracePtr->proc		= proc;
    tracePtr->clientData	= clientData;
    tracePtr->delProc           = delProc;
    tracePtr->nextPtr		= iPtr->tracePtr;
    tracePtr->flags		= flags;
    iPtr->tracePtr		= tracePtr;

    return (Tcl_Trace) tracePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateTrace --
 *
 *	Arrange for a procedure to be called to trace command execution.
 *
 * Results:
 *	The return value is a token for the trace, which may be passed
 *	to Tcl_DeleteTrace to eliminate the trace.
 *
 * Side effects:
 *	From now on, proc will be called just before a command procedure
 *	is called to execute a Tcl command.  Calls to proc will have the
 *	following form:
 *
 *	void
 *	proc(clientData, interp, level, command, cmdProc, cmdClientData,
 *		argc, argv)
 *	    ClientData clientData;
 *	    Tcl_Interp *interp;
 *	    int level;
 *	    char *command;
 *	    int (*cmdProc)();
 *	    ClientData cmdClientData;
 *	    int argc;
 *	    char **argv;
 *	{
 *	}
 *
 *	The clientData and interp arguments to proc will be the same
 *	as the corresponding arguments to this procedure.  Level gives
 *	the nesting level of command interpretation for this interpreter
 *	(0 corresponds to top level).  Command gives the ASCII text of
 *	the raw command, cmdProc and cmdClientData give the procedure that
 *	will be called to process the command and the ClientData value it
 *	will receive, and argc and argv give the arguments to the
 *	command, after any argument parsing and substitution.  Proc
 *	does not return a value.
 *
 *----------------------------------------------------------------------
 */

Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which to create trace. */
    int level;			/* Only call proc for commands at nesting
				 * level<=argument level (1=>top level). */
    Tcl_CmdTraceProc *proc;	/* Procedure to call before executing each
				 * command. */
    ClientData clientData;	/* Arbitrary value word to pass to proc. */
{
    StringTraceData* data;
    data = (StringTraceData*) ckalloc( sizeof( *data ));
    data->clientData = clientData;
    data->proc = proc;
    return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
			       (ClientData) data, StringTraceDeleteProc );
}

/*
 *----------------------------------------------------------------------
 *
 * StringTraceProc --
 *
 *	Invoke a string-based trace procedure from an object-based
 *	callback.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the string-based trace procedure does.
 *
 *----------------------------------------------------------------------
 */

static int
StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
    ClientData clientData;
    Tcl_Interp* interp;
    int level;
    CONST char* command;
    Tcl_Command commandInfo;
    int objc;
    Tcl_Obj *CONST *objv;
{
    StringTraceData* data = (StringTraceData*) clientData;
    Command* cmdPtr = (Command*) commandInfo;

    CONST char** argv;		/* Args to pass to string trace proc */

    int i;

    /*
     * This is a bit messy because we have to emulate the old trace
     * interface, which uses strings for everything.
     */
	    
    argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
						* sizeof(CONST char *) ));
    for (i = 0; i < objc; i++) {
	argv[i] = Tcl_GetString(objv[i]);
    }
    argv[objc] = 0;

    /*
     * Invoke the command procedure.  Note that we cast away const-ness
     * on two parameters for compatibility with legacy code; the code
     * MUST NOT modify either command or argv.
     */
          
    ( data->proc )( data->clientData, interp, level,
		    (char*) command, cmdPtr->proc, cmdPtr->clientData,
		    objc, argv );
    ckfree( (char*) argv );

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


|
|


|
|
|

|
|
|
|
|
|
|

|
|
|
|
|
<
|
|
|

|
|
|
<

|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|





|






|




>
|
>



<

|
|
<
|
|
|
|








|

|
|
|
|
|
|
|









|


|
|


|
|
|















|
|
|
|
<
|
|
|
|









|




|


|
|







|
<





|





|










<

<



|
|

|
|
|






|
|
|

|
|
|
<
|







2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032

2033
2034
2035
2036
2037
2038
2039

2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081

2082
2083
2084

2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143

2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174

2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196

2197

2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219

2220
2221
2222
2223
2224
2225
2226
2227
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateObjTrace --
 *
 *	Arrange for a function to be called to trace command execution.
 *
 * Results:
 *	The return value is a token for the trace, which may be passed to
 *	Tcl_DeleteTrace to eliminate the trace.
 *
 * Side effects:
 *	From now on, proc will be called just before a command function is
 *	called to execute a Tcl command. Calls to proc will have the following
 *	form:
 *
 *	void proc(ClientData	 clientData,
 *		  Tcl_Interp*	 interp,
 *		  int		 level,
 *		  CONST char*	 command,
 *		  Tcl_Command	 commandInfo,
 *		  int		 objc,
 *		  Tcl_Obj *CONST objv[]);
 *
 *	The 'clientData' and 'interp' arguments to 'proc' will be the same as
 *	the arguments to Tcl_CreateObjTrace. The 'level' argument gives the
 *	nesting depth of command interpretation within the interpreter. The
 *	'command' argument is the ASCII text of the command being evaluated -
 *	before any substitutions are performed. The 'commandInfo' argument

 *	gives a handle to the command procedure that will be evaluated. The
 *	'objc' and 'objv' parameters give the parameter vector that will be
 *	passed to the command procedure. Proc does not return a value.
 *
 *	It is permissible for 'proc' to call Tcl_SetCommandTokenInfo to change
 *	the command procedure or client data for the command being evaluated,
 *	and these changes will take effect with the current evaluation.

 *
 *	The 'level' argument specifies the maximum nesting level of calls to
 *	be traced. If the execution depth of the interpreter exceeds 'level',
 *	the trace callback is not executed.
 *
 *	The 'flags' argument is either zero or the value,
 *	TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION flag
 *	is not present, the bytecode compiler will not generate inline code
 *	for Tcl's built-in commands. This behavior will have a significant
 *	impact on performance, but will ensure that all command evaluations
 *	are traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
 *	bytecode compiler will have its normal behavior of compiling in-line
 *	code for some of Tcl's built-in commands. In this case, the tracing
 *	will be imprecise - in-line code will not be traced - but run-time
 *	performance will be improved. The latter behavior is desired for many
 *	applications such as profiling of run time.
 *
 *	When the trace is deleted, the 'delProc' function will be invoked,
 *	passing it the original client data.
 *
 *----------------------------------------------------------------------
 */

Tcl_Trace
Tcl_CreateObjTrace(interp, level, flags, proc, clientData, delProc)
    Tcl_Interp* interp;		/* Tcl interpreter */
    int level;			/* Maximum nesting level */
    int flags;			/* Flags, see above */
    Tcl_CmdObjTraceProc* proc;	/* Trace callback */
    ClientData clientData;	/* Client data for the callback */
    Tcl_CmdObjTraceDeleteProc* delProc;
				/* Function to call when trace is deleted */
{
    register Trace *tracePtr;
    register Interp *iPtr = (Interp *) interp;

    /*
     * Test if this trace allows inline compilation of commands.
     */

    if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
	if (iPtr->tracesForbiddingInline == 0) {

	    /*
	     * When the first trace forbidding inline compilation is created,
	     * invalidate existing compiled code for this interpreter and

	     * arrange (by setting the DONT_COMPILE_CMDS_INLINE flag) that
	     * when compiling new code, no commands will be compiled inline
	     * (i.e., into an inline sequence of instructions). We do this
	     * because commands that were compiled inline will never result in
	     * a command trace being called.
	     */

	    iPtr->compileEpoch++;
	    iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
	}
	iPtr->tracesForbiddingInline++;
    }

    tracePtr = (Trace *) ckalloc(sizeof(Trace));
    tracePtr->level = level;
    tracePtr->proc = proc;
    tracePtr->clientData = clientData;
    tracePtr->delProc = delProc;
    tracePtr->nextPtr = iPtr->tracePtr;
    tracePtr->flags = flags;
    iPtr->tracePtr = tracePtr;

    return (Tcl_Trace) tracePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateTrace --
 *
 *	Arrange for a function to be called to trace command execution.
 *
 * Results:
 *	The return value is a token for the trace, which may be passed to
 *	Tcl_DeleteTrace to eliminate the trace.
 *
 * Side effects:
 *	From now on, proc will be called just before a command procedure is
 *	called to execute a Tcl command. Calls to proc will have the following
 *	form:
 *
 *	void
 *	proc(clientData, interp, level, command, cmdProc, cmdClientData,
 *		argc, argv)
 *	    ClientData clientData;
 *	    Tcl_Interp *interp;
 *	    int level;
 *	    char *command;
 *	    int (*cmdProc)();
 *	    ClientData cmdClientData;
 *	    int argc;
 *	    char **argv;
 *	{
 *	}
 *
 *	The clientData and interp arguments to proc will be the same as the
 *	corresponding arguments to this function. Level gives the nesting
 *	level of command interpretation for this interpreter (0 corresponds to
 *	top level). Command gives the ASCII text of the raw command, cmdProc

 *	and cmdClientData give the function that will be called to process the
 *	command and the ClientData value it will receive, and argc and argv
 *	give the arguments to the command, after any argument parsing and
 *	substitution. Proc does not return a value.
 *
 *----------------------------------------------------------------------
 */

Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which to create trace. */
    int level;			/* Only call proc for commands at nesting
				 * level<=argument level (1=>top level). */
    Tcl_CmdTraceProc *proc;	/* Function to call before executing each
				 * command. */
    ClientData clientData;	/* Arbitrary value word to pass to proc. */
{
    StringTraceData* data;
    data = (StringTraceData *) ckalloc(sizeof(*data));
    data->clientData = clientData;
    data->proc = proc;
    return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
	    (ClientData) data, StringTraceDeleteProc);
}

/*
 *----------------------------------------------------------------------
 *
 * StringTraceProc --
 *
 *	Invoke a string-based trace function from an object-based callback.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Whatever the string-based trace function does.
 *
 *----------------------------------------------------------------------
 */

static int
StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv)
    ClientData clientData;
    Tcl_Interp* interp;
    int level;
    CONST char* command;
    Tcl_Command commandInfo;
    int objc;
    Tcl_Obj *CONST *objv;
{
    StringTraceData* data = (StringTraceData*) clientData;
    Command* cmdPtr = (Command*) commandInfo;

    CONST char** argv;		/* Args to pass to string trace proc */

    int i;

    /*
     * This is a bit messy because we have to emulate the old trace interface,
     * which uses strings for everything.
     */

    argv = (CONST char **)
	    ckalloc((unsigned) ((objc + 1) * sizeof(CONST char *)));
    for (i = 0; i < objc; i++) {
	argv[i] = Tcl_GetString(objv[i]);
    }
    argv[objc] = 0;

    /*
     * Invoke the command function. Note that we cast away const-ness on two
     * parameters for compatibility with legacy code; the code MUST NOT modify
     * either command or argv.
     */

    (data->proc)(data->clientData, interp, level, (char *) command,
	    cmdPtr->proc, cmdPtr->clientData, objc, argv);

    ckfree((char *) argv);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218

2219
2220
2221
2222
2223
2224

2225

2226
2227
2228
2229
2230
2231

















2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255

2256

2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410

2411
2412
2413
2414
2415
2416
2417
 * Side effects:
 *	Allocated memory is returned to the system.
 *
 *----------------------------------------------------------------------
 */

static void
StringTraceDeleteProc( clientData )
    ClientData clientData;
{
    ckfree( (char*) clientData );
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteTrace --
 *
 *	Remove a trace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	From now on there will be no more calls to the procedure given
 *	in trace.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteTrace(interp, trace)
    Tcl_Interp *interp;		/* Interpreter that contains trace. */
    Tcl_Trace trace;		/* Token for trace (returned previously by
				 * Tcl_CreateTrace). */
{
    Interp *iPtr = (Interp *) interp;
    Trace *tracePtr = (Trace *) trace;
    register Trace **tracePtr2 = &(iPtr->tracePtr);


    /*
     * Locate the trace entry in the interpreter's trace list,
     * and remove it from the list.
     */


    while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {

	tracePtr2 = &((*tracePtr2)->nextPtr);
    }
    if (*tracePtr2 == NULL) {
	return;
    }
    (*tracePtr2) = (*tracePtr2)->nextPtr;


















    /*
     * If the trace forbids bytecode compilation, change the interpreter's
     * state.  If bytecode compilation is now permitted, flag the fact and
     * advance the compilation epoch so that procs will be recompiled to
     * take advantage of it.
     */

    if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) {
	iPtr->tracesForbiddingInline--;
	if (iPtr->tracesForbiddingInline == 0) {
	    iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
	    iPtr->compileEpoch++;
	}
    }

    /*
     * Execute any delete callback.
     */

    if (tracePtr->delProc != NULL) {
	(tracePtr->delProc)(tracePtr->clientData);
    }


    /* Delete the trace object */


    Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC);
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceVarExists --
 *
 *	This is called from info exists.  We need to trigger read
 *	and/or array traces because they may end up creating a
 *	variable that doesn't currently exist.
 *
 * Results:
 *	A pointer to the Var structure, or NULL.
 *
 * Side effects:
 *	May fill in error messages in the interp.
 *
 *----------------------------------------------------------------------
 */

Var *
TclVarTraceExists(interp, varName)
    Tcl_Interp *interp;		/* The interpreter */
    CONST char *varName;	/* The variable name */
{
    Var *varPtr;
    Var *arrayPtr;

    /*
     * The choice of "create" flag values is delicate here, and
     * matches the semantics of GetVar.  Things are still not perfect,
     * however, because if you do "info exists x" you get a varPtr
     * and therefore trigger traces.  However, if you do 
     * "info exists x(i)", then you only get a varPtr if x is already
     * known to be an array.  Otherwise you get NULL, and no trace
     * is triggered.  This matches Tcl 7.6 semantics.
     */

    varPtr = TclLookupVar(interp, varName, (char *) NULL,
            0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);

    if (varPtr == NULL) {
	return NULL;
    }

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
		TCL_TRACE_READS, /* leaveErrMsg */ 0);
    }

    /*
     * If the variable doesn't exist anymore and no-one's using
     * it, then free up the relevant structures and hash table entries.
     */

    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
	return NULL;
    }

    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCallVarTraces --
 *
 *	This procedure is invoked to find and invoke relevant
 *	trace procedures associated with a particular operation on
 *	a variable. This procedure invokes traces both on the
 *	variable and on its containing array (where relevant).
 *
 * Results:
 *      Returns TCL_OK to indicate normal operation.  Returns TCL_ERROR
 *      if invocation of a trace procedure indicated an error.  When
 *      TCL_ERROR is returned and leaveErrMsg is true, then the
 *      errorInfo field of iPtr has information about the error
 *      placed in it.
 *
 * Side effects:
 *	Almost anything can happen, depending on trace; this procedure
 *	itself doesn't have any side effects.
 *
 *----------------------------------------------------------------------
 */

int
TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
    Interp *iPtr;		/* Interpreter containing variable. */
    register Var *arrayPtr;	/* Pointer to array variable that contains
				 * the variable, or NULL if the variable
				 * isn't an element of an array. */
    Var *varPtr;		/* Variable whose traces are to be
				 * invoked. */
    CONST char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    int flags;			/* Flags passed to trace procedures:
				 * indicates what's happening to variable,
				 * plus other stuff like TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, and
				 * TCL_INTERP_DESTROYED. */
    int leaveErrMsg;	        /* If true, and one of the traces indicates an
				 * error, then leave an error message and stack
				 * trace information in *iPTr. */
{
    register VarTrace *tracePtr;
    ActiveVarTrace active;
    char *result;
    CONST char *openParen, *p;
    Tcl_DString nameCopy;
    int copiedName;
    int code = TCL_OK;
    int disposeFlags = 0;
    Tcl_InterpState state = NULL;

    /*
     * If there are already similar trace procedures active for the
     * variable, don't call them again.
     */

    if (TclIsVarTraceActive(varPtr)) {
	return code;
    }
    TclSetVarTraceActive(varPtr);
    varPtr->refCount++;
    if (arrayPtr != NULL) {
	arrayPtr->refCount++;
    }

    /*
     * If the variable name hasn't been parsed into array name and
     * element, do it here.  If there really is an array element,
     * make a copy of the original name so that NULLs can be
     * inserted into it to separate the names (can't modify the name
     * string in place, because the string might get used by the
     * callbacks we invoke).
     */

    copiedName = 0;
    if (part2 == NULL) {
	for (p = part1; *p ; p++) {
	    if (*p == '(') {
		openParen = p;
		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p == ')') {
		    int offset = (openParen - part1);
		    char *newPart1;

		    Tcl_DStringInit(&nameCopy);
		    Tcl_DStringAppend(&nameCopy, part1, (p-part1));
		    newPart1 = Tcl_DStringValue(&nameCopy);
		    newPart1[offset] = 0;
		    part1 = newPart1;
		    part2 = newPart1 + offset + 1;
		    copiedName = 1;







|


|













|
|











|

>


|
|


>

>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|
|


















>
|
>









|
|
|



















|
|
|
<
|
|
|


|
|












|
|















|
|
|
|


|
|
|
|
<


|
|







|
|
|
|
<


|
|
|


|
|
|












|
|












|
|
|
<
|
|














>







2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367

2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413

2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428

2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467

2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
 * Side effects:
 *	Allocated memory is returned to the system.
 *
 *----------------------------------------------------------------------
 */

static void
StringTraceDeleteProc(clientData)
    ClientData clientData;
{
    ckfree((char *) clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteTrace --
 *
 *	Remove a trace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	From now on there will be no more calls to the function given in
 *	trace.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteTrace(interp, trace)
    Tcl_Interp *interp;		/* Interpreter that contains trace. */
    Tcl_Trace trace;		/* Token for trace (returned previously by
				 * Tcl_CreateTrace). */
{
    Interp *iPtr = (Interp *) interp;
    Trace *prevPtr, *tracePtr = (Trace *) trace;
    register Trace **tracePtr2 = &(iPtr->tracePtr);
    ActiveInterpTrace *activePtr;

    /*
     * Locate the trace entry in the interpreter's trace list, and remove it
     * from the list.
     */

    prevPtr = NULL;
    while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {
	prevPtr = *tracePtr2;
	tracePtr2 = &((*tracePtr2)->nextPtr);
    }
    if (*tracePtr2 == NULL) {
	return;
    }
    (*tracePtr2) = (*tracePtr2)->nextPtr;

    /*
     * The code below makes it possible to delete traces while traces are
     * active: it makes sure that the deleted trace won't be processed by
     * TclCheckInterpTraces.
     */

    for (activePtr = iPtr->activeInterpTracePtr;  activePtr != NULL;
	    activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    if (activePtr->reverseScan) {
		activePtr->nextTracePtr = prevPtr;
	    } else {
		activePtr->nextTracePtr = tracePtr->nextPtr;
	    }
	}
    }

    /*
     * If the trace forbids bytecode compilation, change the interpreter's
     * state. If bytecode compilation is now permitted, flag the fact and
     * advance the compilation epoch so that procs will be recompiled to take
     * advantage of it.
     */

    if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) {
	iPtr->tracesForbiddingInline--;
	if (iPtr->tracesForbiddingInline == 0) {
	    iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
	    iPtr->compileEpoch++;
	}
    }

    /*
     * Execute any delete callback.
     */

    if (tracePtr->delProc != NULL) {
	(tracePtr->delProc)(tracePtr->clientData);
    }

    /*
     * Delete the trace object.
     */

    Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC);
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceVarExists --
 *
 *	This is called from info exists. We need to trigger read and/or array
 *	traces because they may end up creating a variable that doesn't
 *	currently exist.
 *
 * Results:
 *	A pointer to the Var structure, or NULL.
 *
 * Side effects:
 *	May fill in error messages in the interp.
 *
 *----------------------------------------------------------------------
 */

Var *
TclVarTraceExists(interp, varName)
    Tcl_Interp *interp;		/* The interpreter */
    CONST char *varName;	/* The variable name */
{
    Var *varPtr;
    Var *arrayPtr;

    /*
     * The choice of "create" flag values is delicate here, and matches the
     * semantics of GetVar. Things are still not perfect, however, because if
     * you do "info exists x" you get a varPtr and therefore trigger traces.

     * However, if you do "info exists x(i)", then you only get a varPtr if x
     * is already known to be an array. Otherwise you get NULL, and no trace
     * is triggered. This matches Tcl 7.6 semantics.
     */

    varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, "access",
	    /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);

    if (varPtr == NULL) {
	return NULL;
    }

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
		TCL_TRACE_READS, /* leaveErrMsg */ 0);
    }

    /*
     * If the variable doesn't exist anymore and no-one's using it, then free
     * up the relevant structures and hash table entries.
     */

    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
	return NULL;
    }

    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCallVarTraces --
 *
 *	This function is invoked to find and invoke relevant trace functions
 *	associated with a particular operation on a variable. This function
 *	invokes traces both on the variable and on its containing array (where
 *	relevant).
 *
 * Results:
 *	Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if
 *	invocation of a trace function indicated an error. When TCL_ERROR is
 *	returned and leaveErrMsg is true, then the errorInfo field of iPtr has
 *	information about the error placed in it.

 *
 * Side effects:
 *	Almost anything can happen, depending on trace; this function itself
 *	doesn't have any side effects.
 *
 *----------------------------------------------------------------------
 */

int
TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
    Interp *iPtr;		/* Interpreter containing variable. */
    register Var *arrayPtr;	/* Pointer to array variable that contains the
				 * variable, or NULL if the variable isn't an
				 * element of an array. */
    Var *varPtr;		/* Variable whose traces are to be invoked. */

    CONST char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    int flags;			/* Flags passed to trace functions: indicates
				 * what's happening to variable, plus other
				 * stuff like TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, and
				 * TCL_INTERP_DESTROYED. */
    int leaveErrMsg;		/* If true, and one of the traces indicates an
				 * error, then leave an error message and
				 * stack trace information in *iPTr. */
{
    register VarTrace *tracePtr;
    ActiveVarTrace active;
    char *result;
    CONST char *openParen, *p;
    Tcl_DString nameCopy;
    int copiedName;
    int code = TCL_OK;
    int disposeFlags = 0;
    Tcl_InterpState state = NULL;

    /*
     * If there are already similar trace functions active for the variable,
     * don't call them again.
     */

    if (TclIsVarTraceActive(varPtr)) {
	return code;
    }
    TclSetVarTraceActive(varPtr);
    varPtr->refCount++;
    if (arrayPtr != NULL) {
	arrayPtr->refCount++;
    }

    /*
     * If the variable name hasn't been parsed into array name and element, do
     * it here. If there really is an array element, make a copy of the
     * original name so that NULLs can be inserted into it to separate the

     * names (can't modify the name string in place, because the string might
     * get used by the callbacks we invoke).
     */

    copiedName = 0;
    if (part2 == NULL) {
	for (p = part1; *p ; p++) {
	    if (*p == '(') {
		openParen = p;
		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p == ')') {
		    int offset = (openParen - part1);
		    char *newPart1;

		    Tcl_DStringInit(&nameCopy);
		    Tcl_DStringAppend(&nameCopy, part1, (p-part1));
		    newPart1 = Tcl_DStringValue(&nameCopy);
		    newPart1[offset] = 0;
		    part1 = newPart1;
		    part2 = newPart1 + offset + 1;
		    copiedName = 1;
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447

2448


2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483

2484


2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
    result = NULL;
    active.nextPtr = iPtr->activeVarTracePtr;
    iPtr->activeVarTracePtr = &active;
    Tcl_Preserve((ClientData) iPtr);
    if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) {
	active.varPtr = arrayPtr;
	for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
	     tracePtr = active.nextTracePtr) {
	    active.nextTracePtr = tracePtr->nextPtr;
	    if (!(tracePtr->flags & flags)) {
		continue;
	    }
	    Tcl_Preserve((ClientData) tracePtr);
	    if (state == NULL) {
		state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
	    }
	    result = (*tracePtr->traceProc)(tracePtr->clientData,
		    (Tcl_Interp *) iPtr, part1, part2, flags);
	    if (result != NULL) {
		if (flags & TCL_TRACE_UNSETS) {

		    /* Ignore errors in unset traces */


		    DisposeTraceResult(tracePtr->flags, result);
		} else {
	            disposeFlags = tracePtr->flags;
		    code = TCL_ERROR;
		}
	    }
	    Tcl_Release((ClientData) tracePtr);
	    if (code == TCL_ERROR) {
		goto done;
	    }
	}
    }

    /*
     * Invoke traces on the variable itself.
     */

    if (flags & TCL_TRACE_UNSETS) {
	flags |= TCL_TRACE_DESTROYED;
    }
    active.varPtr = varPtr;
    for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
	 tracePtr = active.nextTracePtr) {
	active.nextTracePtr = tracePtr->nextPtr;
	if (!(tracePtr->flags & flags)) {
	    continue;
	}
	Tcl_Preserve((ClientData) tracePtr);
	if (state == NULL) {
	    state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
	}
	result = (*tracePtr->traceProc)(tracePtr->clientData,
		(Tcl_Interp *) iPtr, part1, part2, flags);
	if (result != NULL) {
	    if (flags & TCL_TRACE_UNSETS) {

		/* Ignore errors in unset traces */


		DisposeTraceResult(tracePtr->flags, result);
	    } else {
		disposeFlags = tracePtr->flags;
		code = TCL_ERROR;
	    }
	}
	Tcl_Release((ClientData) tracePtr);
	if (code == TCL_ERROR) {
	    goto done;
	}
    }

    /*
     * Restore the variable's flags, remove the record of our active
     * traces, and then return.
     */

    done:
    if (code == TCL_ERROR) {
	if (leaveErrMsg) {
	    CONST char *type = "";
	    Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code);
	    Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1);
	    Tcl_Obj *errorInfo;

	    Tcl_IncrRefCount(errorInfoKey);
	    Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo);
	    Tcl_IncrRefCount(errorInfo);
	    Tcl_DictObjRemove(NULL, options, errorInfoKey);
	    if (Tcl_IsShared(errorInfo)) {
		Tcl_DecrRefCount(errorInfo);
		errorInfo = Tcl_DuplicateObj(errorInfo);
		Tcl_IncrRefCount(errorInfo);
	    }
	    Tcl_AppendToObj(errorInfo, "\n    (", -1);
	    switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
		case TCL_TRACE_READS:
		    type = "read";
		    Tcl_AppendToObj(errorInfo, type, -1);
		    break;
		case TCL_TRACE_WRITES:
		    type = "set";
		    Tcl_AppendToObj(errorInfo, "write", -1);
		    break;
		case TCL_TRACE_ARRAY:
		    type = "trace array";
		    Tcl_AppendToObj(errorInfo, "array", -1);
		    break;
	    }
	    if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
			Tcl_GetString((Tcl_Obj *) result));
	    } else {
		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
	    }







|












>
|
>
>


|



















|












>
|
>
>













|
|


|


















|
|
|
|
|
|
|
|
|
|
|
|







2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
    result = NULL;
    active.nextPtr = iPtr->activeVarTracePtr;
    iPtr->activeVarTracePtr = &active;
    Tcl_Preserve((ClientData) iPtr);
    if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) {
	active.varPtr = arrayPtr;
	for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
		tracePtr = active.nextTracePtr) {
	    active.nextTracePtr = tracePtr->nextPtr;
	    if (!(tracePtr->flags & flags)) {
		continue;
	    }
	    Tcl_Preserve((ClientData) tracePtr);
	    if (state == NULL) {
		state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
	    }
	    result = (*tracePtr->traceProc)(tracePtr->clientData,
		    (Tcl_Interp *) iPtr, part1, part2, flags);
	    if (result != NULL) {
		if (flags & TCL_TRACE_UNSETS) {
		    /*
		     * Ignore errors in unset traces.
		     */

		    DisposeTraceResult(tracePtr->flags, result);
		} else {
		    disposeFlags = tracePtr->flags;
		    code = TCL_ERROR;
		}
	    }
	    Tcl_Release((ClientData) tracePtr);
	    if (code == TCL_ERROR) {
		goto done;
	    }
	}
    }

    /*
     * Invoke traces on the variable itself.
     */

    if (flags & TCL_TRACE_UNSETS) {
	flags |= TCL_TRACE_DESTROYED;
    }
    active.varPtr = varPtr;
    for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
	    tracePtr = active.nextTracePtr) {
	active.nextTracePtr = tracePtr->nextPtr;
	if (!(tracePtr->flags & flags)) {
	    continue;
	}
	Tcl_Preserve((ClientData) tracePtr);
	if (state == NULL) {
	    state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
	}
	result = (*tracePtr->traceProc)(tracePtr->clientData,
		(Tcl_Interp *) iPtr, part1, part2, flags);
	if (result != NULL) {
	    if (flags & TCL_TRACE_UNSETS) {
		/*
		 * Ignore errors in unset traces.
		 */

		DisposeTraceResult(tracePtr->flags, result);
	    } else {
		disposeFlags = tracePtr->flags;
		code = TCL_ERROR;
	    }
	}
	Tcl_Release((ClientData) tracePtr);
	if (code == TCL_ERROR) {
	    goto done;
	}
    }

    /*
     * Restore the variable's flags, remove the record of our active traces,
     * and then return.
     */

  done:
    if (code == TCL_ERROR) {
	if (leaveErrMsg) {
	    CONST char *type = "";
	    Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code);
	    Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1);
	    Tcl_Obj *errorInfo;

	    Tcl_IncrRefCount(errorInfoKey);
	    Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo);
	    Tcl_IncrRefCount(errorInfo);
	    Tcl_DictObjRemove(NULL, options, errorInfoKey);
	    if (Tcl_IsShared(errorInfo)) {
		Tcl_DecrRefCount(errorInfo);
		errorInfo = Tcl_DuplicateObj(errorInfo);
		Tcl_IncrRefCount(errorInfo);
	    }
	    Tcl_AppendToObj(errorInfo, "\n    (", -1);
	    switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
	    case TCL_TRACE_READS:
		type = "read";
		Tcl_AppendToObj(errorInfo, type, -1);
		break;
	    case TCL_TRACE_WRITES:
		type = "set";
		Tcl_AppendToObj(errorInfo, "write", -1);
		break;
	    case TCL_TRACE_ARRAY:
		type = "trace array";
		Tcl_AppendToObj(errorInfo, "array", -1);
		break;
	    }
	    if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
			Tcl_GetString((Tcl_Obj *) result));
	    } else {
		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
	    }
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688

2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700

2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
}

/*
 *----------------------------------------------------------------------
 *
 * DisposeTraceResult--
 *
 *	This procedure is called to dispose of the result returned from
 *	a trace procedure.  The disposal method appropriate to the type
 *	of result is determined by flags.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The memory allocated for the trace result may be freed.
 *
 *----------------------------------------------------------------------
 */

static void
DisposeTraceResult(flags, result)
    int flags;			/* Indicates type of result to determine
				 * proper disposal method */
    char *result;		/* The result returned from a trace
				 * procedure to be disposed */
{
    if (flags & TCL_TRACE_RESULT_DYNAMIC) {
	ckfree(result);
    } else if (flags & TCL_TRACE_RESULT_OBJECT) {
	Tcl_DecrRefCount((Tcl_Obj *) result);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceVar --
 *
 *	Remove a previously-created trace for a variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there exists a trace for the variable given by varName
 *	with the given flags, proc, and clientData, then that trace
 *	is removed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of variable; may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits describing
				 * current trace, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceVar2 --
 *
 *	Remove a previously-created trace for a variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there exists a trace for the variable given by part1
 *	and part2 with the given flags, proc, and clientData, then
 *	that trace is removed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits describing
				 * current trace, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
				 * and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    register VarTrace *tracePtr;
    VarTrace *prevPtr;
    Var *varPtr, *arrayPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveVarTrace *activePtr;
    int flagMask;
    
    /*
     * Set up a mask to mask out the parts of the flags that we are not
     * interested in now.
     */

    flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
    varPtr = TclLookupVar(interp, part1, part2, flags & flagMask,
	    /*msg*/ (char *) NULL,
	    /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
	return;
    }

    /*
     * Set up a mask to mask out the parts of the flags that we are not
     * interested in now.
     */

    flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; 
#ifndef TCL_REMOVE_OBSOLETE_TRACES
    flagMask |= TCL_TRACE_OLD_STYLE;
#endif
    flags &= flagMask;
    for (tracePtr = varPtr->tracePtr, prevPtr = NULL;  ;
	 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
		&& (tracePtr->clientData == clientData)) {
	    break;
	}
    }

    /*
     * The code below makes it possible to delete traces while traces
     * are active: it makes sure that the deleted trace won't be
     * processed by TclCallVarTraces.
     */

    for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
	 activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    activePtr->nextTracePtr = tracePtr->nextPtr;
	}
    }
    if (prevPtr == NULL) {
	varPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }
    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);

    /*
     * If this is the last trace on the variable, and the variable is
     * unset and unused, then free up the variable.
     */

    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, (Var *) NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo --
 *
 *	Return the clientData value associated with a trace on a
 *	variable.  This procedure can also be used to step through
 *	all of the traces on a particular variable that have the
 *	same trace procedure.
 *
 * Results:
 *	The return value is the clientData value associated with
 *	a trace on the given variable.  Information will only be
 *	returned for a trace with proc as trace procedure.  If
 *	the clientData argument is NULL then the first such trace is
 *	returned;  otherwise, the next relevant one after the one
 *	given by clientData will be returned.  If the variable
 *	doesn't exist, or if there are no (more) traces for it,
 *	then NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
				 * by this procedure, so this call will
				 * return the next trace after that one.
				 * If NULL, this call will return the
				 * first trace. */
{
    return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
	    flags, proc, prevClientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo2 --
 *
 *	Same as Tcl_VarTraceInfo, except takes name in two pieces
 *	instead of one.
 *
 * Results:
 *	Same as Tcl_VarTraceInfo.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
				 * by this procedure, so this call will
				 * return the next trace after that one.
				 * If NULL, this call will return the
				 * first trace. */
{
    register VarTrace *tracePtr;
    Var *varPtr, *arrayPtr;

    varPtr = TclLookupVar(interp, part1, part2,
	    flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
	    /*msg*/ (char *) NULL,







|
|
|













|
|
|



















|
|
<







|
|
|
|
|
<
|
|
















|
|
<








|


|
|
|
<
|
|








|




>












>

|




|
|










|
|
|



|












|
|












|
|
|
<


|
|
<
|
|
|
|
<










|
|


|
|
|
|
|
<










|
|














|




|
|
|
|
|
<







2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703

2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715

2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735

2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749

2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832

2833
2834
2835
2836

2837
2838
2839
2840

2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859

2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895

2896
2897
2898
2899
2900
2901
2902
}

/*
 *----------------------------------------------------------------------
 *
 * DisposeTraceResult--
 *
 *	This function is called to dispose of the result returned from a trace
 *	function. The disposal method appropriate to the type of result is
 *	determined by flags.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The memory allocated for the trace result may be freed.
 *
 *----------------------------------------------------------------------
 */

static void
DisposeTraceResult(flags, result)
    int flags;			/* Indicates type of result to determine
				 * proper disposal method. */
    char *result;		/* The result returned from a trace function
				 * to be disposed. */
{
    if (flags & TCL_TRACE_RESULT_DYNAMIC) {
	ckfree(result);
    } else if (flags & TCL_TRACE_RESULT_OBJECT) {
	Tcl_DecrRefCount((Tcl_Obj *) result);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceVar --
 *
 *	Remove a previously-created trace for a variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there exists a trace for the variable given by varName with the
 *	given flags, proc, and clientData, then that trace is removed.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of variable; may end with "(index)" to
				 * signify an array reference. */
    int flags;			/* OR-ed collection of bits describing current
				 * trace, including any of TCL_TRACE_READS,
				 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS,

				 * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Function assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceVar2 --
 *
 *	Remove a previously-created trace for a variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there exists a trace for the variable given by part1 and part2 with
 *	the given flags, proc, and clientData, then that trace is removed.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits describing current
				 * trace, including any of TCL_TRACE_READS,
				 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS,

				 * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Function assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    register VarTrace *tracePtr;
    VarTrace *prevPtr;
    Var *varPtr, *arrayPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveVarTrace *activePtr;
    int flagMask;

    /*
     * Set up a mask to mask out the parts of the flags that we are not
     * interested in now.
     */

    flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
    varPtr = TclLookupVar(interp, part1, part2, flags & flagMask,
	    /*msg*/ (char *) NULL,
	    /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
	return;
    }

    /*
     * Set up a mask to mask out the parts of the flags that we are not
     * interested in now.
     */

    flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	  TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
    flagMask |= TCL_TRACE_OLD_STYLE;
#endif
    flags &= flagMask;
    for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
	    prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
		&& (tracePtr->clientData == clientData)) {
	    break;
	}
    }

    /*
     * The code below makes it possible to delete traces while traces are
     * active: it makes sure that the deleted trace won't be processed by
     * TclCallVarTraces.
     */

    for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
	    activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    activePtr->nextTracePtr = tracePtr->nextPtr;
	}
    }
    if (prevPtr == NULL) {
	varPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }
    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);

    /*
     * If this is the last trace on the variable, and the variable is unset
     * and unused, then free up the variable.
     */

    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, (Var *) NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo --
 *
 *	Return the clientData value associated with a trace on a variable.
 *	This function can also be used to step through all of the traces on a
 *	particular variable that have the same trace function.

 *
 * Results:
 *	The return value is the clientData value associated with a trace on
 *	the given variable. Information will only be returned for a trace with

 *	proc as trace function. If the clientData argument is NULL then the
 *	first such trace is returned; otherwise, the next relevant one after
 *	the one given by clientData will be returned. If the variable doesn't
 *	exist, or if there are no (more) traces for it, then NULL is returned.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of variable; may end with "(index)" to
				 * signify an array reference. */
    int flags;			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc;	/* Function assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */

{
    return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
	    flags, proc, prevClientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo2 --
 *
 *	Same as Tcl_VarTraceInfo, except takes name in two pieces instead of
 *	one.
 *
 * Results:
 *	Same as Tcl_VarTraceInfo.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Function assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned by
				 * this function, so this call will return the
				 * next trace after that one. If NULL, this
				 * call will return the first trace. */

{
    register VarTrace *tracePtr;
    Var *varPtr, *arrayPtr;

    varPtr = TclLookupVar(interp, part1, part2,
	    flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
	    /*msg*/ (char *) NULL,
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942

2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955

2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973

2974
2975
2976








	    if ((tracePtr->clientData == prevClientData)
		    && (tracePtr->traceProc == proc)) {
		tracePtr = tracePtr->nextPtr;
		break;
	    }
	}
    }
    for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
	if (tracePtr->traceProc == proc) {
	    return tracePtr->clientData;
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar --
 *
 *	Arrange for reads and/or writes to a variable to cause a
 *	procedure to be invoked, which can monitor the operations
 *	and/or change their actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by varName, such that
 *	future references to the variable will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    CONST char *varName;	/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    return Tcl_TraceVar2(interp, varName, (char *) NULL, 
	    flags, proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar2 --
 *
 *	Arrange for reads and/or writes to a variable to cause a
 *	procedure to be invoked, which can monitor the operations
 *	and/or change their actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such
 *	that future references to the variable will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    CONST char *part1;		/* Name of scalar variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
				 * and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Var *varPtr, *arrayPtr;
    register VarTrace *tracePtr;
    int flagMask;
    
    /* 
     * We strip 'flags' down to just the parts which are relevant to
     * TclLookupVar, to avoid conflicts between trace flags and
     * internal namespace flags such as 'TCL_FIND_ONLY_NS'.  This can
     * now occur since we have trace flags with values 0x1000 and higher.
     */

    flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
    varPtr = TclLookupVar(interp, part1, part2,
	    (flags & flagMask) | TCL_LEAVE_ERR_MSG,
	    "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Check for a nonsense flag combination.  Note that this is a
     * Tcl_Panic() because there should be no code path that ever sets
     * both flags.
     */

    if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) {
	Tcl_Panic("bad result flag combination");
    }

    /*
     * Set up trace information.
     */

    flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | 
	TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
    flagMask |= TCL_TRACE_OLD_STYLE;
#endif
    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
    tracePtr->traceProc		= proc;
    tracePtr->clientData	= clientData;
    tracePtr->flags		= flags & flagMask;
    tracePtr->nextPtr		= varPtr->tracePtr;

    varPtr->tracePtr		= tracePtr;
    return TCL_OK;
}















|












|
|
|





|
|
|
<






|
|
|
|
|
|


|



|








|
|
|





|
|
|
|






|
|

|


|
|
|
|
|






|
|

|
|
|

>









|
|
<

>








|
|




|
|
|
|
>
|


>
>
>
>
>
>
>
>
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945

2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026

3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
	    if ((tracePtr->clientData == prevClientData)
		    && (tracePtr->traceProc == proc)) {
		tracePtr = tracePtr->nextPtr;
		break;
	    }
	}
    }
    for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
	if (tracePtr->traceProc == proc) {
	    return tracePtr->clientData;
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar --
 *
 *	Arrange for reads and/or writes to a variable to cause a function to
 *	be invoked, which can monitor the operations and/or change their
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by varName, such that future
 *	references to the variable will be intermediated by proc. See the
 *	manual entry for complete details on the calling sequence for proc.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is to be
				 * traced. */
    CONST char *varName;	/* Name of variable; may end with "(index)" to
				 * signify an array reference. */
    int flags;			/* OR-ed collection of bits, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Function to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    return Tcl_TraceVar2(interp, varName, (char *) NULL,
	    flags, proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar2 --
 *
 *	Arrange for reads and/or writes to a variable to cause a function to
 *	be invoked, which can monitor the operations and/or change their
 *	actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such that
 *	future references to the variable will be intermediated by proc. See
 *	the manual entry for complete details on the calling sequence for
 *	proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is to be
				 * traced. */
    CONST char *part1;		/* Name of scalar variable or array. */
    CONST char *part2;		/* Name of element within array; NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Function to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Var *varPtr, *arrayPtr;
    register VarTrace *tracePtr;
    int flagMask;

    /*
     * We strip 'flags' down to just the parts which are relevant to
     * TclLookupVar, to avoid conflicts between trace flags and internal
     * namespace flags such as 'TCL_FIND_ONLY_NS'. This can now occur since we
     * have trace flags with values 0x1000 and higher.
     */

    flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
    varPtr = TclLookupVar(interp, part1, part2,
	    (flags & flagMask) | TCL_LEAVE_ERR_MSG,
	    "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Check for a nonsense flag combination. Note that this is a Tcl_Panic()
     * because there should be no code path that ever sets both flags.

     */

    if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) {
	Tcl_Panic("bad result flag combination");
    }

    /*
     * Set up trace information.
     */

    flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	  TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
    flagMask |= TCL_TRACE_OLD_STYLE;
#endif
    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags & flagMask;
    tracePtr->nextPtr = varPtr->tracePtr;

    varPtr->tracePtr = tracePtr;
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclUtf.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
/*
 * tclUtf.c --
 *
 *	Routines for manipulating UTF-8 strings.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUtf.c,v 1.32 2003/10/08 14:24:41 dkf Exp $
 */

#include "tclInt.h"

/*
 * Include the static character classification tables and macros.
 */

#include "tclUniData.c"

/*
 * The following macros are used for fast character category tests.  The
 * x_BITS values are shifted right by the category value to determine whether
 * the given category is included in the set.
 */ 

#define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \
    | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1 << OTHER_LETTER))

#define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER)

#define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \
    | (1 << PARAGRAPH_SEPARATOR))

#define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION)

#define PRINT_BITS (ALPHA_BITS | DIGIT_BITS | SPACE_BITS | \
	    (1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \
	    (1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \
	    (1 << OTHER_NUMBER) | (1 << CONNECTOR_PUNCTUATION) | \
	    (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \
	    (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \
	    (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION) | \
	    (1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \
	    (1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL))

#define PUNCT_BITS ((1 << CONNECTOR_PUNCTUATION) | \
	    (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \
	    (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \
	    (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION))

/*
 * Unicode characters less than this value are represented by themselves 
 * in UTF-8 strings. 
 */

#define UNICODE_SELF	0x80







|
|

|











|
|
|



|




|




|
|
|
|
|
|
|
|


|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
/*
 * tclUtf.c --
 *
 *	Routines for manipulating UTF-8 strings.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUtf.c,v 1.32.2.3 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

/*
 * Include the static character classification tables and macros.
 */

#include "tclUniData.c"

/*
 * The following macros are used for fast character category tests. The x_BITS
 * values are shifted right by the category value to determine whether the
 * given category is included in the set.
 */ 

#define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \
	| (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1<<OTHER_LETTER))

#define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER)

#define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \
	| (1 << PARAGRAPH_SEPARATOR))

#define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION)

#define PRINT_BITS (ALPHA_BITS | DIGIT_BITS | SPACE_BITS | \
	(1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \
	(1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \
	(1 << OTHER_NUMBER) | (1 << CONNECTOR_PUNCTUATION) | \
	(1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \
	(1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \
	(1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION) | \
	(1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \
	(1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL))

#define PUNCT_BITS ((1 << CONNECTOR_PUNCTUATION) | \
	(1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \
	(1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \
	(1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION))

/*
 * Unicode characters less than this value are represented by themselves 
 * in UTF-8 strings. 
 */

#define UNICODE_SELF	0x80
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
};

/*
 * Procedures used only in this module.
 */

static int UtfCount _ANSI_ARGS_((int ch));


/*
 *---------------------------------------------------------------------------
 *
 * UtfCount --
 *
 *	Find the number of bytes in the Utf character "ch".







<







89
90
91
92
93
94
95

96
97
98
99
100
101
102
};

/*
 * Procedures used only in this module.
 */

static int UtfCount _ANSI_ARGS_((int ch));


/*
 *---------------------------------------------------------------------------
 *
 * UtfCount --
 *
 *	Find the number of bytes in the Utf character "ch".
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340

341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtf --
 *
 *	Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
 *	provided buffer.  Equivalent to Plan 9 runetochar().
 *
 * Results:
 *	The return values is the number of bytes in the buffer that
 *	were consumed.  
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
INLINE int
Tcl_UniCharToUtf(ch, str)
    int ch;			/* The Tcl_UniChar to be stored in the
				 * buffer. */
    char *str;			/* Buffer in which the UTF-8 representation
				 * of the Tcl_UniChar is stored.  Buffer must
				 * be large enough to hold the UTF-8 character
				 * (at most TCL_UTF_MAX bytes). */
{
    if ((ch > 0) && (ch < UNICODE_SELF)) {
	str[0] = (char) ch;
	return 1;
    }

    if (ch <= 0x7FF) {
	str[1] = (char) ((ch | 0x80) & 0xBF);
	str[0] = (char) ((ch >> 6) | 0xC0);
	return 2;
    }
    if (ch <= 0xFFFF) {
	three:
	str[2] = (char) ((ch | 0x80) & 0xBF);
	str[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
	str[0] = (char) ((ch >> 12) | 0xE0);
	return 3;
    }

#if TCL_UTF_MAX > 3
    if (ch <= 0x1FFFFF) {
	str[3] = (char) ((ch | 0x80) & 0xBF);
	str[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
	str[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
	str[0] = (char) ((ch >> 18) | 0xF0);
	return 4;
    }
    if (ch <= 0x3FFFFFF) {
	str[4] = (char) ((ch | 0x80) & 0xBF);
	str[3] = (char) (((ch >> 6) | 0x80) & 0xBF);
	str[2] = (char) (((ch >> 12) | 0x80) & 0xBF);
	str[1] = (char) (((ch >> 18) | 0x80) & 0xBF);
	str[0] = (char) ((ch >> 24) | 0xF8);
	return 5;
    }
    if (ch <= 0x7FFFFFFF) {
	str[5] = (char) ((ch | 0x80) & 0xBF);
	str[4] = (char) (((ch >> 6) | 0x80) & 0xBF);
	str[3] = (char) (((ch >> 12) | 0x80) & 0xBF);
	str[2] = (char) (((ch >> 18) | 0x80) & 0xBF);
	str[1] = (char) (((ch >> 24) | 0x80) & 0xBF);
	str[0] = (char) ((ch >> 30) | 0xFC);
	return 6;
    }
#endif


    ch = 0xFFFD;
    goto three;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtfDString --
 *
 *	Convert the given Unicode string to UTF-8.
 *
 * Results:
 *	The return value is a pointer to the UTF-8 representation of the
 *	Unicode string.  Storage for the return value is appended to the
 *	end of dsPtr.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
char *
Tcl_UniCharToUtfDString(wString, numChars, dsPtr)
    CONST Tcl_UniChar *wString;	/* Unicode string to convert to UTF-8. */
    int numChars;		/* Length of Unicode string in Tcl_UniChars
				 * (must be >= 0). */
    Tcl_DString *dsPtr;		/* UTF-8 representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    CONST Tcl_UniChar *w, *wEnd;
    char *p, *string;
    int oldLength;

    /*
     * UTF-8 string length in bytes will be <= Unicode string length *
     * TCL_UTF_MAX.
     */

    oldLength = Tcl_DStringLength(dsPtr);
    Tcl_DStringSetLength(dsPtr, (oldLength + numChars + 1) * TCL_UTF_MAX);
    string = Tcl_DStringValue(dsPtr) + oldLength;

    p = string;
    wEnd = wString + numChars;
    for (w = wString; w < wEnd; ) {
	p += Tcl_UniCharToUtf(*w, p);
	w++;
    }
    Tcl_DStringSetLength(dsPtr, oldLength + (p - string));

    return string;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfToUniChar --
 *
 *	Extract the Tcl_UniChar represented by the UTF-8 string.  Bad
 *	UTF-8 sequences are converted to valid Tcl_UniChars and processing
 *	continues.  Equivalent to Plan 9 chartorune().
 *
 *	The caller must ensure that the source buffer is long enough that
 *	this routine does not run off the end and dereference non-existent
 *	memory looking for trail bytes.  If the source buffer is known to
 *	be '\0' terminated, this cannot happen.  Otherwise, the caller
 *	should call Tcl_UtfCharComplete() before calling this routine to
 *	ensure that enough bytes remain in the string.
 *
 * Results:
 *	*chPtr is filled with the Tcl_UniChar, and the return value is the
 *	number of bytes from the UTF-8 string that were consumed.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
int
Tcl_UtfToUniChar(str, chPtr)
    register CONST char *str;	 /* The UTF-8 string. */
    register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented
				  * by the UTF-8 string. */
{
    register int byte;
    
    /*
     * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones.
     */

    byte = *((unsigned char *) str);
    if (byte < 0xC0) {
	/*
	 * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
	 * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
	 * characters representing themselves.
	 */

	*chPtr = (Tcl_UniChar) byte;
	return 1;
    } else if (byte < 0xE0) {
	if ((str[1] & 0xC0) == 0x80) {
	    /*
	     * Two-byte-character lead-byte followed by a trail-byte.
	     */

	    *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F));
	    return 2;
	}

	/*
	 * A two-byte-character lead-byte not followed by trail-byte
	 * represents itself.
	 */

	*chPtr = (Tcl_UniChar) byte;
	return 1;
    } else if (byte < 0xF0) {
	if (((str[1] & 0xC0) == 0x80) && ((str[2] & 0xC0) == 0x80)) {
	    /*
	     * Three-byte-character lead byte followed by two trail bytes.
	     */

	    *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12) 
		    | ((str[1] & 0x3F) << 6) | (str[2] & 0x3F));
	    return 3;
	}

	/*
	 * A three-byte-character lead-byte not followed by two trail-bytes
	 * represents itself.
	 */

	*chPtr = (Tcl_UniChar) byte;
	return 1;
    }
#if TCL_UTF_MAX > 3
    else {
	int ch, total, trail;

	total = totalBytes[byte];
	trail = total - 1;
	if (trail > 0) {
	    ch = byte & (0x3F >> trail);
	    do {
		str++;
		if ((*str & 0xC0) != 0x80) {
		    *chPtr = byte;
		    return 1;
		}
		ch <<= 6;
		ch |= (*str & 0x3F);
		trail--;
	    } while (trail > 0);
	    *chPtr = ch;
	    return total;
	}
    }
#endif







|


|
|








|


|
|
|



|


>
|
|
|
|
|
|

|
|
|
|
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

>














|
|








|
|
|

|
|
<











|



|
|













|
|
|

|
|
|
|
|
|












|
|
|
|







|










|




|


>








|





|


>

















|
|




|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtf --
 *
 *	Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
 *	provided buffer. Equivalent to Plan 9 runetochar().
 *
 * Results:
 *	The return values is the number of bytes in the buffer that were
 *	consumed.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
INLINE int
Tcl_UniCharToUtf(ch, buf)
    int ch;			/* The Tcl_UniChar to be stored in the
				 * buffer. */
    char *buf;			/* Buffer in which the UTF-8 representation of
				 * the Tcl_UniChar is stored. Buffer must be
				 * large enough to hold the UTF-8 character
				 * (at most TCL_UTF_MAX bytes). */
{
    if ((ch > 0) && (ch < UNICODE_SELF)) {
	buf[0] = (char) ch;
	return 1;
    }
    if (ch >= 0) {
	if (ch <= 0x7FF) {
	    buf[1] = (char) ((ch | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 6) | 0xC0);
	    return 2;
	}
	if (ch <= 0xFFFF) {
	three:
	    buf[2] = (char) ((ch | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 12) | 0xE0);
	    return 3;
	}

#if TCL_UTF_MAX > 3
	if (ch <= 0x1FFFFF) {
	    buf[3] = (char) ((ch | 0x80) & 0xBF);
	    buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 18) | 0xF0);
	    return 4;
	}
	if (ch <= 0x3FFFFFF) {
	    buf[4] = (char) ((ch | 0x80) & 0xBF);
	    buf[3] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[2] = (char) (((ch >> 12) | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 18) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 24) | 0xF8);
	    return 5;
	}
	if (ch <= 0x7FFFFFFF) {
	    buf[5] = (char) ((ch | 0x80) & 0xBF);
	    buf[4] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[3] = (char) (((ch >> 12) | 0x80) & 0xBF);
	    buf[2] = (char) (((ch >> 18) | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 24) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 30) | 0xFC);
	    return 6;
	}
#endif
    }

    ch = 0xFFFD;
    goto three;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtfDString --
 *
 *	Convert the given Unicode string to UTF-8.
 *
 * Results:
 *	The return value is a pointer to the UTF-8 representation of the
 *	Unicode string. Storage for the return value is appended to the end of
 *	dsPtr.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
char *
Tcl_UniCharToUtfDString(uniStr, uniLength, dsPtr)
    CONST Tcl_UniChar *uniStr;	/* Unicode string to convert to UTF-8. */
    int uniLength;		/* Length of Unicode string in Tcl_UniChars
				 * (must be >= 0). */
    Tcl_DString *dsPtr;		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */

{
    CONST Tcl_UniChar *w, *wEnd;
    char *p, *string;
    int oldLength;

    /*
     * UTF-8 string length in bytes will be <= Unicode string length *
     * TCL_UTF_MAX.
     */

    oldLength = Tcl_DStringLength(dsPtr);
    Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * TCL_UTF_MAX);
    string = Tcl_DStringValue(dsPtr) + oldLength;

    p = string;
    wEnd = uniStr + uniLength;
    for (w = uniStr; w < wEnd; ) {
	p += Tcl_UniCharToUtf(*w, p);
	w++;
    }
    Tcl_DStringSetLength(dsPtr, oldLength + (p - string));

    return string;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfToUniChar --
 *
 *	Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8
 *	sequences are converted to valid Tcl_UniChars and processing
 *	continues. Equivalent to Plan 9 chartorune().
 *
 *	The caller must ensure that the source buffer is long enough that this
 *	routine does not run off the end and dereference non-existent memory
 *	looking for trail bytes. If the source buffer is known to be '\0'
 *	terminated, this cannot happen. Otherwise, the caller should call
 *	Tcl_UtfCharComplete() before calling this routine to ensure that
 *	enough bytes remain in the string.
 *
 * Results:
 *	*chPtr is filled with the Tcl_UniChar, and the return value is the
 *	number of bytes from the UTF-8 string that were consumed.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
int
Tcl_UtfToUniChar(src, chPtr)
    register CONST char *src;	 /* The UTF-8 string. */
    register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented by
				  * the UTF-8 string. */
{
    register int byte;
    
    /*
     * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones.
     */

    byte = *((unsigned char *) src);
    if (byte < 0xC0) {
	/*
	 * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
	 * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
	 * characters representing themselves.
	 */

	*chPtr = (Tcl_UniChar) byte;
	return 1;
    } else if (byte < 0xE0) {
	if ((src[1] & 0xC0) == 0x80) {
	    /*
	     * Two-byte-character lead-byte followed by a trail-byte.
	     */

	    *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (src[1] & 0x3F));
	    return 2;
	}

	/*
	 * A two-byte-character lead-byte not followed by trail-byte
	 * represents itself.
	 */

	*chPtr = (Tcl_UniChar) byte;
	return 1;
    } else if (byte < 0xF0) {
	if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
	    /*
	     * Three-byte-character lead byte followed by two trail bytes.
	     */

	    *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12) 
		    | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F));
	    return 3;
	}

	/*
	 * A three-byte-character lead-byte not followed by two trail-bytes
	 * represents itself.
	 */

	*chPtr = (Tcl_UniChar) byte;
	return 1;
    }
#if TCL_UTF_MAX > 3
    else {
	int ch, total, trail;

	total = totalBytes[byte];
	trail = total - 1;
	if (trail > 0) {
	    ch = byte & (0x3F >> trail);
	    do {
		src++;
		if ((*src & 0xC0) != 0x80) {
		    *chPtr = byte;
		    return 1;
		}
		ch <<= 6;
		ch |= (*src & 0x3F);
		trail--;
	    } while (trail > 0);
	    *chPtr = ch;
	    return total;
	}
    }
#endif
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
 *
 * Tcl_UtfToUniCharDString --
 *
 *	Convert the UTF-8 string to Unicode.
 *
 * Results:
 *	The return value is a pointer to the Unicode representation of the
 *	UTF-8 string.  Storage for the return value is appended to the
 *	end of dsPtr.  The Unicode string is terminated with a Unicode
 *	NULL character.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_UtfToUniCharDString(string, length, dsPtr)
    CONST char *string;		/* UTF-8 string to convert to Unicode. */
    int length;			/* Length of UTF-8 string in bytes, or -1
				 * for strlen(). */
    Tcl_DString *dsPtr;		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    Tcl_UniChar *w, *wString;
    CONST char *p, *end;
    int oldLength;

    if (length < 0) {
	length = strlen(string);
    }

    /*
     * Unicode string length in Tcl_UniChars will be <= UTF-8 string length
     * in bytes.
     */

    oldLength = Tcl_DStringLength(dsPtr);
    Tcl_DStringSetLength(dsPtr,
	    (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar)));
    wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);

    w = wString;
    end = string + length;
    for (p = string; p < end; ) {
	p += TclUtfToUniChar(p, w);
	w++;
    }
    *w = '\0';
    Tcl_DStringSetLength(dsPtr,
	    (oldLength + ((char *) w - (char *) wString)));

    return wString;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfCharComplete --
 *
 *	Determine if the UTF-8 string of the given length is long enough
 *	to be decoded by Tcl_UtfToUniChar().  This does not ensure that the
 *	UTF-8 string is properly formed.  Equivalent to Plan 9 fullrune().
 *
 * Results:
 *	The return value is 0 if the string is not long enough, non-zero
 *	otherwise.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UtfCharComplete(str, len)
    CONST char *str;		/* String to check if first few bytes
				 * contain a complete UTF-8 character. */
    int len;			/* Length of above string in bytes. */
{
    int ch;

    ch = *((unsigned char *) str);
    return len >= totalBytes[ch];
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_NumUtfChars --
 *
 *	Returns the number of characters (not bytes) in the UTF-8 string,
 *	not including the terminating NULL byte.  This is equivalent to
 *	Plan 9 utflen() and utfnlen().
 *
 * Results:
 *	As above.  
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
int 
Tcl_NumUtfChars(str, len)
    register CONST char *str;	/* The UTF-8 string to measure. */
    int len;			/* The length of the string in bytes, or -1
				 * for strlen(string). */
{
    Tcl_UniChar ch;
    register Tcl_UniChar *chPtr = &ch;
    register int i;

    /*
     * The separate implementations are faster.
     *
     * Since this is a time-sensitive function, we also do the check for
     * the single-byte char case specially.
     */

    i = 0;
    if (len < 0) {
	while (*str != '\0') {
	    str += TclUtfToUniChar(str, chPtr);
	    i++;
	}
    } else {
	register int n;

	while (len > 0) {
	    if (UCHAR(*str) < 0xC0) {
		len--;
		str++;
	    } else {
		n = Tcl_UtfToUniChar(str, chPtr);
		len -= n;
		str += n;
	    }
	    i++;
	}
    }
    return i;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfFindFirst --
 *
 *	Returns a pointer to the first occurance of the given Tcl_UniChar
 *	in the NULL-terminated UTF-8 string.  The NULL terminator is
 *	considered part of the UTF-8 string.  Equivalent to Plan 9
 *	utfrune().
 *
 * Results:
 *	As above.  If the Tcl_UniChar does not exist in the given string,
 *	the return value is NULL.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
CONST char *
Tcl_UtfFindFirst(string, ch)
    CONST char *string;		/* The UTF-8 string to be searched. */
    int ch;			/* The Tcl_UniChar to search for. */
{
    int len;
    Tcl_UniChar find;
    
    while (1) {
	len = TclUtfToUniChar(string, &find);
	if (find == ch) {
	    return string;
	}
	if (*string == '\0') {
	    return NULL;
	}
	string += len;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfFindLast --
 *
 *	Returns a pointer to the last occurance of the given Tcl_UniChar
 *	in the NULL-terminated UTF-8 string.  The NULL terminator is
 *	considered part of the UTF-8 string.  Equivalent to Plan 9
 *	utfrrune().
 *
 * Results:
 *	As above.  If the Tcl_UniChar does not exist in the given string,
 *	the return value is NULL.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_UtfFindLast(string, ch)
    CONST char *string;		/* The UTF-8 string to be searched. */
    int ch;			/* The Tcl_UniChar to search for. */
{
    int len;
    Tcl_UniChar find;
    CONST char *last;
	
    last = NULL;
    while (1) {
	len = TclUtfToUniChar(string, &find);
	if (find == ch) {
	    last = string;
	}
	if (*string == '\0') {
	    break;
	}
	string += len;
    }
    return last;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfNext --
 *
 *	Given a pointer to some current location in a UTF-8 string,
 *	move forward one character.  The caller must ensure that they
 *	are not asking for the next character after the last character
 *	in the string.
 *
 * Results:
 *	The return value is the pointer to the next character in
 *	the UTF-8 string.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
CONST char *
Tcl_UtfNext(str) 
    CONST char *str;		    /* The current location in the string. */
{
    Tcl_UniChar ch;

    return str + TclUtfToUniChar(str, &ch);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfPrev --
 *
 *	Given a pointer to some current location in a UTF-8 string,
 *	move backwards one character.  This works correctly when the
 *	pointer is in the middle of a UTF-8 character.
 *
 * Results:
 *	The return value is a pointer to the previous character in the
 *	UTF-8 string.  If the current location was already at the
 *	beginning of the string, the return value will also be a
 *	pointer to the beginning of the string.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_UtfPrev(str, start)
    CONST char *str;		    /* The current location in the string. */
    CONST char *start;		    /* Pointer to the beginning of the
				     * string, to avoid going backwards too
				     * far. */
{
    CONST char *look;
    int i, byte;
    
    str--;
    look = str;
    for (i = 0; i < TCL_UTF_MAX; i++) {
	if (look < start) {
	    if (str < start) {
		str = start;
	    }
	    break;
	}
	byte = *((unsigned char *) look);
	if (byte < 0x80) {
	    break;
	}
	if (byte >= 0xC0) {
	    return look;
	}
	look--;
    }
    return str;
}
	
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharAtIndex --
 *
 *	Returns the Unicode character represented at the specified
 *	character (not byte) position in the UTF-8 string.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *







|
|
<








|
|
|
|









|



|
|








|
|















|
|
|












|
|
|
|



|
|







|
|
|











|
|
|









|
|



|
|
|





|
|
|
|

|
|
|












|
|
|
<


|
|







|
|






|

|

|


|








|
|
|
<


|
|








|
|








|

|

|


|









|
|
|
<


|
|








|
|



|







|
|
|


|
|
|
|








|
|
|
|
<




|
|


|
|












|







|
|







381
382
383
384
385
386
387
388
389

390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534

535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614

615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660

661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
 *
 * Tcl_UtfToUniCharDString --
 *
 *	Convert the UTF-8 string to Unicode.
 *
 * Results:
 *	The return value is a pointer to the Unicode representation of the
 *	UTF-8 string. Storage for the return value is appended to the end of
 *	dsPtr. The Unicode string is terminated with a Unicode NULL character.

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_UtfToUniCharDString(src, length, dsPtr)
    CONST char *src;		/* UTF-8 string to convert to Unicode. */
    int length;			/* Length of UTF-8 string in bytes, or -1 for
				 * strlen(). */
    Tcl_DString *dsPtr;		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    Tcl_UniChar *w, *wString;
    CONST char *p, *end;
    int oldLength;

    if (length < 0) {
	length = strlen(src);
    }

    /*
     * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
     * bytes.
     */

    oldLength = Tcl_DStringLength(dsPtr);
    Tcl_DStringSetLength(dsPtr,
	    (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar)));
    wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);

    w = wString;
    end = src + length;
    for (p = src; p < end; ) {
	p += TclUtfToUniChar(p, w);
	w++;
    }
    *w = '\0';
    Tcl_DStringSetLength(dsPtr,
	    (oldLength + ((char *) w - (char *) wString)));

    return wString;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfCharComplete --
 *
 *	Determine if the UTF-8 string of the given length is long enough to be
 *	decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8
 *	string is properly formed. Equivalent to Plan 9 fullrune().
 *
 * Results:
 *	The return value is 0 if the string is not long enough, non-zero
 *	otherwise.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UtfCharComplete(src, length)
    CONST char *src;		/* String to check if first few bytes contain
				 * a complete UTF-8 character. */
    int length;			/* Length of above string in bytes. */
{
    int ch;

    ch = *((unsigned char *) src);
    return length >= totalBytes[ch];
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_NumUtfChars --
 *
 *	Returns the number of characters (not bytes) in the UTF-8 string, not
 *	including the terminating NULL byte. This is equivalent to Plan 9
 *	utflen() and utfnlen().
 *
 * Results:
 *	As above.  
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
int 
Tcl_NumUtfChars(src, length)
    register CONST char *src;	/* The UTF-8 string to measure. */
    int length;			/* The length of the string in bytes, or -1
				 * for strlen(string). */
{
    Tcl_UniChar ch;
    register Tcl_UniChar *chPtr = &ch;
    register int i;

    /*
     * The separate implementations are faster.
     *
     * Since this is a time-sensitive function, we also do the check for the
     * single-byte char case specially.
     */

    i = 0;
    if (length < 0) {
	while (*src != '\0') {
	    src += TclUtfToUniChar(src, chPtr);
	    i++;
	}
    } else {
	register int n;

	while (length > 0) {
	    if (UCHAR(*src) < 0xC0) {
		length--;
		src++;
	    } else {
		n = Tcl_UtfToUniChar(src, chPtr);
		length -= n;
		src += n;
	    }
	    i++;
	}
    }
    return i;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfFindFirst --
 *
 *	Returns a pointer to the first occurance of the given Tcl_UniChar in
 *	the NULL-terminated UTF-8 string. The NULL terminator is considered
 *	part of the UTF-8 string. Equivalent to Plan 9 utfrune().

 *
 * Results:
 *	As above. If the Tcl_UniChar does not exist in the given string, the
 *	return value is NULL.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
CONST char *
Tcl_UtfFindFirst(src, ch)
    CONST char *src;		/* The UTF-8 string to be searched. */
    int ch;			/* The Tcl_UniChar to search for. */
{
    int len;
    Tcl_UniChar find;
    
    while (1) {
	len = TclUtfToUniChar(src, &find);
	if (find == ch) {
	    return src;
	}
	if (*src == '\0') {
	    return NULL;
	}
	src += len;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfFindLast --
 *
 *	Returns a pointer to the last occurance of the given Tcl_UniChar in
 *	the NULL-terminated UTF-8 string. The NULL terminator is considered
 *	part of the UTF-8 string. Equivalent to Plan 9 utfrrune().

 *
 * Results:
 *	As above. If the Tcl_UniChar does not exist in the given string, the
 *	return value is NULL.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_UtfFindLast(src, ch)
    CONST char *src;		/* The UTF-8 string to be searched. */
    int ch;			/* The Tcl_UniChar to search for. */
{
    int len;
    Tcl_UniChar find;
    CONST char *last;
	
    last = NULL;
    while (1) {
	len = TclUtfToUniChar(src, &find);
	if (find == ch) {
	    last = src;
	}
	if (*src == '\0') {
	    break;
	}
	src += len;
    }
    return last;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfNext --
 *
 *	Given a pointer to some current location in a UTF-8 string, move
 *	forward one character. The caller must ensure that they are not asking
 *	for the next character after the last character in the string.

 *
 * Results:
 *	The return value is the pointer to the next character in the UTF-8
 *	string.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
CONST char *
Tcl_UtfNext(src) 
    CONST char *src;		    /* The current location in the string. */
{
    Tcl_UniChar ch;

    return src + TclUtfToUniChar(src, &ch);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfPrev --
 *
 *	Given a pointer to some current location in a UTF-8 string, move
 *	backwards one character. This works correctly when the pointer is in
 *	the middle of a UTF-8 character.
 *
 * Results:
 *	The return value is a pointer to the previous character in the UTF-8
 *	string. If the current location was already at the beginning of the
 *	string, the return value will also be a pointer to the beginning of
 *	the string.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_UtfPrev(src, start)
    CONST char *src;		/* The current location in the string. */
    CONST char *start;		/* Pointer to the beginning of the string, to
				 * avoid going backwards too far. */

{
    CONST char *look;
    int i, byte;
    
    src--;
    look = src;
    for (i = 0; i < TCL_UTF_MAX; i++) {
	if (look < start) {
	    if (src < start) {
		src = start;
	    }
	    break;
	}
	byte = *((unsigned char *) look);
	if (byte < 0x80) {
	    break;
	}
	if (byte >= 0xC0) {
	    return look;
	}
	look--;
    }
    return src;
}
	
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharAtIndex --
 *
 *	Returns the Unicode character represented at the specified character
 *	(not byte) position in the UTF-8 string.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfAtIndex --
 *
 *	Returns a pointer to the specified character (not byte) position
 *	in the UTF-8 string.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *







|
|







715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfAtIndex --
 *
 *	Returns a pointer to the specified character (not byte) position in
 *	the UTF-8 string.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
 *
 * Tcl_UtfBackslash --
 *
 *	Figure out how to handle a backslash sequence.
 *
 * Results:
 *	Stores the bytes represented by the backslash sequence in dst and
 *	returns the number of bytes written to dst.  At most TCL_UTF_MAX
 *	bytes are written to dst; dst must have been large enough to accept
 *	those bytes.  If readPtr isn't NULL then it is filled in with a
 *	count of the number of bytes in the backslash sequence.  
 *
 * Side effects:
 *	The maximum number of bytes it takes to represent a Unicode
 *	character in UTF-8 is guaranteed to be less than the number of
 *	bytes used to express the backslash sequence that represents
 *	that Unicode character.  If the target buffer into which the
 *	caller is going to store the bytes that represent the Unicode
 *	character is at least as large as the source buffer from which
 *	the backslashed sequence was extracted, no buffer overruns should
 *	occur.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UtfBackslash(src, readPtr, dst)
    CONST char *src;		/* Points to the backslash character of
				 * a backslash sequence. */
    int *readPtr;		/* Fill in with number of characters read
				 * from src, unless NULL. */
    char *dst;			/* Filled with the bytes represented by the
				 * backslash sequence. */
{
#define LINE_LENGTH 128
    int numRead;
    int result;








|
|
|
|


|
|
|
|
|
<
|
|






|
|
|
|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767

768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
 *
 * Tcl_UtfBackslash --
 *
 *	Figure out how to handle a backslash sequence.
 *
 * Results:
 *	Stores the bytes represented by the backslash sequence in dst and
 *	returns the number of bytes written to dst. At most TCL_UTF_MAX bytes
 *	are written to dst; dst must have been large enough to accept those
 *	bytes. If readPtr isn't NULL then it is filled in with a count of the
 *	number of bytes in the backslash sequence.
 *
 * Side effects:
 *	The maximum number of bytes it takes to represent a Unicode character
 *	in UTF-8 is guaranteed to be less than the number of bytes used to
 *	express the backslash sequence that represents that Unicode character.
 *	If the target buffer into which the caller is going to store the bytes
 *	that represent the Unicode character is at least as large as the

 *	source buffer from which the backslashed sequence was extracted, no
 *	buffer overruns should occur.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UtfBackslash(src, readPtr, dst)
    CONST char *src;		/* Points to the backslash character of a
				 * backslash sequence. */
    int *readPtr;		/* Fill in with number of characters read from
				 * src, unless NULL. */
    char *dst;			/* Filled with the bytes represented by the
				 * backslash sequence. */
{
#define LINE_LENGTH 128
    int numRead;
    int result;

800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToUpper --
 *
 *	Convert lowercase characters to uppercase characters in a UTF
 *	string in place.  The conversion may shrink the UTF string.
 *
 * Results:
 *	Returns the number of bytes in the resulting string
 *	excluding the trailing null.
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToUpper --
 *
 *	Convert lowercase characters to uppercase characters in a UTF string
 *	in place. The conversion may shrink the UTF string.
 *
 * Results:
 *	Returns the number of bytes in the resulting string excluding the
 *	trailing null.
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {
        bytes = TclUtfToUniChar(src, &ch);
	upChar = Tcl_UniCharToUpper(ch);

	/*
	 * To keep badly formed Utf strings from getting inflated by
	 * the conversion (thereby causing a segfault), only copy the
	 * upper case char to dst if its size is <= the original char.
	 */
	
	if (bytes < UtfCount(upChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(upChar, dst);
	}
	src += bytes;
    }
    *dst = '\0';
    return (dst - str);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToLower --
 *
 *	Convert uppercase characters to lowercase characters in a UTF
 *	string in place.  The conversion may shrink the UTF string.
 *
 * Results:
 *	Returns the number of bytes in the resulting string
 *	excluding the trailing null.
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */








|



|
|
|



















|
|


|
|







823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	upChar = Tcl_UniCharToUpper(ch);

	/*
	 * To keep badly formed Utf strings from getting inflated by the
	 * conversion (thereby causing a segfault), only copy the upper case
	 * char to dst if its size is <= the original char.
	 */
	
	if (bytes < UtfCount(upChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(upChar, dst);
	}
	src += bytes;
    }
    *dst = '\0';
    return (dst - str);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToLower --
 *
 *	Convert uppercase characters to lowercase characters in a UTF string
 *	in place. The conversion may shrink the UTF string.
 *
 * Results:
 *	Returns the number of bytes in the resulting string excluding the
 *	trailing null.
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926

    src = dst = str;
    while (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	lowChar = Tcl_UniCharToLower(ch);

	/*
	 * To keep badly formed Utf strings from getting inflated by
	 * the conversion (thereby causing a segfault), only copy the
	 * lower case char to dst if its size is <= the original char.
	 */
	
	if (bytes < UtfCount(lowChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(lowChar, dst);
	}
	src += bytes;
    }
    *dst = '\0';
    return (dst - str);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToTitle --
 *
 *	Changes the first character of a UTF string to title case or
 *	uppercase and the rest of the string to lowercase.  The
 *	conversion happens in place and may shrink the UTF string.
 *
 * Results:
 *	Returns the number of bytes in the resulting string
 *	excluding the trailing null.
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */








|
|
|



















|
|
|


|
|







880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922

    src = dst = str;
    while (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	lowChar = Tcl_UniCharToLower(ch);

	/*
	 * To keep badly formed Utf strings from getting inflated by the
	 * conversion (thereby causing a segfault), only copy the lower case
	 * char to dst if its size is <= the original char.
	 */
	
	if (bytes < UtfCount(lowChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(lowChar, dst);
	}
	src += bytes;
    }
    *dst = '\0';
    return (dst - str);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToTitle --
 *
 *	Changes the first character of a UTF string to title case or uppercase
 *	and the rest of the string to lowercase. The conversion happens in
 *	place and may shrink the UTF string.
 *
 * Results:
 *	Returns the number of bytes in the resulting string excluding the
 *	trailing null.
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

998
999
1000
1001
1002
1003
1004
1005
1006
1007

1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038

1039
1040
1041
1042
1043

1044
1045
1046
1047
1048
1049

1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUtfNcmp2 --
 *
 *	Compare at most n bytes of utf-8 strings cs and ct.  Both cs
 *	and ct are assumed to be at least n bytes long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpUtfNcmp2(cs, ct, n)
    CONST char *cs;		/* UTF string to compare to ct. */
    CONST char *ct;		/* UTF string cs is compared to. */
    unsigned long n;		/* Number of *bytes* to compare. */
{
    /*
     * We can't simply call 'memcmp(cs, ct, n);' because we need to check
     * for Tcl's \xC0\x80 non-utf-8 null encoding.
     * Otherwise utf-8 lexes fine in the strcmp manner.
     */

    register int result = 0;

    for ( ; n != 0; n--, cs++, ct++) {
	if (*cs != *ct) {
	    result = UCHAR(*cs) - UCHAR(*ct);
	    break;
	}
    }
    if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) {
	unsigned char c1, c2;

	c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs);
	c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct);
	result = (c1 - c2);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfNcmp --
 *
 *	Compare at most n UTF chars of string cs to string ct.  Both cs
 *	and ct are assumed to be at least n UTF chars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UtfNcmp(cs, ct, n)
    CONST char *cs;		/* UTF string to compare to ct. */
    CONST char *ct;		/* UTF string cs is compared to. */
    unsigned long n;		/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1, ch2;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of
     * \u0000 (the pair of bytes 0xc0,0x80) is larger than byte
     * representation of \u0001 (the byte 0x01.)
     */

    while (n-- > 0) {
	/*
	 * n must be interpreted as chars, not bytes.
	 * This should be called only when both strings are of
	 * at least n chars long (no need for \0 check)
	 */

	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
	if (ch1 != ch2) {
	    return (ch1 - ch2);
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfNcasecmp --
 *
 *	Compare at most n UTF chars of string cs to string ct case
 *	insensitive.  Both cs and ct are assumed to be at least n
 *	UTF chars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UtfNcasecmp(cs, ct, n)
    CONST char *cs;		/* UTF string to compare to ct. */
    CONST char *ct;		/* UTF string cs is compared to. */
    unsigned long n;			/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1, ch2;
    while (n-- > 0) {
	/*
	 * n must be interpreted as chars, not bytes.
	 * This should be called only when both strings are of
	 * at least n chars long (no need for \0 check)
	 */
	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);







|
|

















|
|
|

>










>












|
|











|


|


>

|
|
|

>
|

|
|
|

>














|
|












|


|


|







964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUtfNcmp2 --
 *
 *	Compare at most n bytes of utf-8 strings cs and ct. Both cs and ct are
 *	assumed to be at least n bytes long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpUtfNcmp2(cs, ct, n)
    CONST char *cs;		/* UTF string to compare to ct. */
    CONST char *ct;		/* UTF string cs is compared to. */
    unsigned long n;		/* Number of *bytes* to compare. */
{
    /*
     * We can't simply call 'memcmp(cs, ct, n);' because we need to check for
     * Tcl's \xC0\x80 non-utf-8 null encoding.  Otherwise utf-8 lexes fine in
     * the strcmp manner.
     */

    register int result = 0;

    for ( ; n != 0; n--, cs++, ct++) {
	if (*cs != *ct) {
	    result = UCHAR(*cs) - UCHAR(*ct);
	    break;
	}
    }
    if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) {
	unsigned char c1, c2;

	c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs);
	c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct);
	result = (c1 - c2);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfNcmp --
 *
 *	Compare at most numChars UTF chars of string cs to string ct. Both cs
 *	and ct are assumed to be at least numChars UTF chars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UtfNcmp(cs, ct, numChars)
    CONST char *cs;		/* UTF string to compare to ct. */
    CONST char *ct;		/* UTF string cs is compared to. */
    unsigned long numChars;	/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1, ch2;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
     * pair of bytes 0xc0,0x80) is larger than byte representation of \u0001
     * (the byte 0x01.)
     */

    while (numChars-- > 0) {
	/*
	 * n must be interpreted as chars, not bytes. This should be called
	 * only when both strings are of at least n chars long (no need for \0
	 * check)
	 */

	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
	if (ch1 != ch2) {
	    return (ch1 - ch2);
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfNcasecmp --
 *
 *	Compare at most numChars UTF chars of string cs to string ct case
 *	insensitive.  Both cs and ct are assumed to be at least numChars
 *	UTF chars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UtfNcasecmp(cs, ct, numChars)
    CONST char *cs;		/* UTF string to compare to ct. */
    CONST char *ct;		/* UTF string cs is compared to. */
    unsigned long numChars;	/* Number of UTF chars to compare. */
{
    Tcl_UniChar ch1, ch2;
    while (numChars-- > 0) {
	/*
	 * n must be interpreted as chars, not bytes.
	 * This should be called only when both strings are of
	 * at least n chars long (no need for \0 check)
	 */
	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253

1254
1255
1256
1257
1258
1259
1260

1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharLen(str)
    CONST Tcl_UniChar *str;	/* Unicode string to find length of. */
{
    int len = 0;
    
    while (*str != '\0') {
	len++;
	str++;
    }
    return len;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharNcmp --
 *
 *	Compare at most n unichars of string cs to string ct.  Both cs
 *	and ct are assumed to be at least n unichars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcmp(cs, ct, n)
    CONST Tcl_UniChar *cs;		/* Unicode string to compare to ct. */
    CONST Tcl_UniChar *ct;		/* Unicode string cs is compared to. */
    unsigned long n;			/* Number of unichars to compare. */
{
#ifdef WORDS_BIGENDIAN
    /*
     * We are definitely on a big-endian machine; memcmp() is safe
     */

    return memcmp(cs, ct, n*sizeof(Tcl_UniChar));

#else /* !WORDS_BIGENDIAN */
    /*
     * We can't simply call memcmp() because that is not lexically correct.
     */
    for ( ; n != 0; cs++, ct++, n--) {

	if (*cs != *ct) {
	    return (*cs - *ct);
	}
    }
    return 0;
#endif /* WORDS_BIGENDIAN */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharNcasecmp --
 *
 *	Compare at most n unichars of string cs to string ct case
 *	insensitive.  Both cs and ct are assumed to be at least n
 *	unichars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcasecmp(cs, ct, n)
    CONST Tcl_UniChar *cs;		/* Unicode string to compare to ct. */
    CONST Tcl_UniChar *ct;		/* Unicode string cs is compared to. */
    unsigned long n;			/* Number of unichars to compare. */
{
    for ( ; n != 0; n--, cs++, ct++) {
	if (*cs != *ct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*cs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*ct);
	    if (lcs != lct) {
		return (lcs - lct);
	    }
	}
    }
    return 0;
}







|
|



|

|









|
|


|








|
|
|
|





>
|





|
>
|
|











|
|



|








|
|
|
|

|
|
|
|







1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharLen(uniStr)
    CONST Tcl_UniChar *uniStr;	/* Unicode string to find length of. */
{
    int len = 0;
    
    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }
    return len;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharNcmp --
 *
 *	Compare at most numChars unichars of string ucs to string uct.
 *	Both ucs and uct are assumed to be at least numChars unichars long.
 *
 * Results:
 *	Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcmp(ucs, uct, numChars)
    CONST Tcl_UniChar *ucs;		/* Unicode string to compare to uct. */
    CONST Tcl_UniChar *uct;		/* Unicode string ucs is compared to. */
    unsigned long numChars;		/* Number of unichars to compare. */
{
#ifdef WORDS_BIGENDIAN
    /*
     * We are definitely on a big-endian machine; memcmp() is safe
     */

    return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));

#else /* !WORDS_BIGENDIAN */
    /*
     * We can't simply call memcmp() because that is not lexically correct.
     */

    for ( ; numChars != 0; ucs++, uct++, numChars--) {
	if (*ucs != *uct) {
	    return (*ucs - *uct);
	}
    }
    return 0;
#endif /* WORDS_BIGENDIAN */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharNcasecmp --
 *
 *	Compare at most numChars unichars of string ucs to string uct case
 *	insensitive.  Both ucs and uct are assumed to be at least numChars
 *	unichars long.
 *
 * Results:
 *	Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcasecmp(ucs, uct, numChars)
    CONST Tcl_UniChar *ucs;		/* Unicode string to compare to uct. */
    CONST Tcl_UniChar *uct;		/* Unicode string ucs is compared to. */
    unsigned long numChars;		/* Number of unichars to compare. */
{
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
	    if (lcs != lct) {
		return (lcs - lct);
	    }
	}
    }
    return 0;
}
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsWordChar --
 *
 *	Test if a character is alphanumeric or a connector punctuation
 *	mark.
 *
 * Results:
 *	Returns 1 if character is a word character.
 *
 * Side effects:
 *	None.
 *







|
<







1555
1556
1557
1558
1559
1560
1561
1562

1563
1564
1565
1566
1567
1568
1569
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsWordChar --
 *
 *	Test if a character is alphanumeric or a connector punctuation mark.

 *
 * Results:
 *	Returns 1 if character is a word character.
 *
 * Side effects:
 *	None.
 *
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605

1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640

1641


1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654

1655
1656
1657
1658
1659
1660
1661
1662

1663
1664

1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702

1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751

1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825

1826


1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839

1840
1841
1842
1843
1844
1845
1846

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharCaseMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.
 *	Allows case insensitivity.  This is the Unicode equivalent of
 *	the char* Tcl_StringCaseMatch.  The UniChar strings must be
 *	NULL-terminated.  This has no provision for counted UniChar
 *	strings, thus should not be used where NULLs are expected in the
 *	UniChar string.  Use TclUniCharMatch where possible.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and
 *	0 otherwise.  The matching operation permits the following
 *	special characters in the pattern: *?\[] (see the manual
 *	entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharCaseMatch(string, pattern, nocase)

    CONST Tcl_UniChar *string;	/* Unicode String. */
    CONST Tcl_UniChar *pattern;	/* Pattern, which may contain special
				 * characters. */
    int nocase;			/* 0 for case sensitive, 1 for insensitive */
{
    Tcl_UniChar ch1, p;
    
    while (1) {
	p = *pattern;
	
	/*
	 * See if we're at the end of both the pattern and the string.  If
	 * so, we succeeded.  If we're at the end of the pattern but not at
	 * the end of the string, we failed.
	 */
	
	if (p == 0) {
	    return (*string == 0);
	}
	if ((*string == 0) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character.  It matches any
	 * substring.  We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */
	
	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++pattern) == '*') {}


	    p = *pattern;
	    if (p == 0) {
		return 1;
	    }
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    if (nocase) {
			while (*string && (p != *string)
				&& (p != Tcl_UniCharToLower(*string))) {
			    string++;
			}
		    } else {
			while (*string && (p != *string)) { string++; }

		    }
		}

		if (Tcl_UniCharCaseMatch(string, pattern, nocase)) {
		    return 1;
		}
		if (*string == 0) {
		    return 0;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character.  It matches
	 * any single character.
	 */

	if (p == '?') {
	    pattern++;
	    string++;
	    continue;
	}

	/*
	 * Check for a "[" as the next pattern character.  It is followed
	 * by a list of characters that are acceptable, or by a range
	 * (two characters separated by "-").
	 */
	
	if (p == '[') {
	    Tcl_UniChar startChar, endChar;

	    pattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
	    string++;
	    while (1) {
		if ((*pattern == ']') || (*pattern == 0)) {
		    return 0;
		}
		startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);

		pattern++;
		if (*pattern == '-') {
		    pattern++;
		    if (*pattern == 0) {
			return 0;
		    }
		    endChar = (nocase ? Tcl_UniCharToLower(*pattern)
			    : *pattern);
		    pattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
			 * Matches ranges of form [a-z] or [z-a].
			 */
			break;
		    }
		} else if (startChar == ch1) {
		    break;
		}
	    }
	    while (*pattern != ']') {
		if (*pattern == 0) {
		    pattern--;
		    break;
		}
		pattern++;
	    }
	    pattern++;
	    continue;
	}

	/*
	 * If the next pattern character is '\', just strip off the '\'
	 * so we do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (*(++pattern) == '\0') {
		return 0;
	    }
	}

	/*
	 * There's no special character.  Just make sure that the next
	 * bytes of each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {

		return 0;
	    }
	} else if (*string != *pattern) {
	    return 0;
	}
	string++;
	pattern++;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclUniCharMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.
 *	Allows case insensitivity.  This is the Unicode equivalent of the
 *	char* Tcl_StringCaseMatch.  This variant of Tcl_UniCharCaseMatch
 *	uses counted Strings, so embedded NULLs are allowed.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and
 *	0 otherwise.  The matching operation permits the following
 *	special characters in the pattern: *?\[] (see the manual
 *	entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclUniCharMatch(string, strLen, pattern, ptnLen, nocase)
    CONST Tcl_UniChar *string;	/* Unicode String. */
    int strLen;			/* length of String */
    CONST Tcl_UniChar *pattern;	/* Pattern, which may contain special
				 * characters. */
    int ptnLen;			/* length of Pattern */
    int nocase;			/* 0 for case sensitive, 1 for insensitive */
{
    CONST Tcl_UniChar *stringEnd, *patternEnd;
    Tcl_UniChar p;

    stringEnd  = string + strLen;
    patternEnd = pattern + ptnLen;

    while (1) {
	/*
	 * See if we're at the end of both the pattern and the string.  If
	 * so, we succeeded.  If we're at the end of the pattern but not at
	 * the end of the string, we failed.
	 */

	if (pattern == patternEnd) {
	    return (string == stringEnd);
	}
	p = *pattern;
	if ((string == stringEnd) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character.  It matches any
	 * substring.  We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */
	
	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++pattern) == '*') {}


	    if (pattern == patternEnd) {
		return 1;
	    }
	    p = *pattern;
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    if (nocase) {
			while ((string < stringEnd) && (p != *string)
				&& (p != Tcl_UniCharToLower(*string))) {
			    string++;
			}
		    } else {







|
|
|
|
|


|
|
<
|








|
>
|
|






|


|
|
|



|

|




|
|









>
|
>
>
|












>


|
|
|


|
>
|
|
>
|


|


|




|
|



|
|




|
|
|





|
|
|

|


|
>
|
|
|
|


|
|
|











|
|
|


|

|




|
|



|





|
|



|
>


|


|
|









|
|
|


|
|
<
|



















|




|
|
|











|
|







|

>
|
>
>











|

>







1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596

1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784

1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharCaseMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.
 *	Allows case insensitivity. This is the Unicode equivalent of the char*
 *	Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated.
 *	This has no provision for counted UniChar strings, thus should not be
 *	used where NULLs are expected in the UniChar string. Use
 *	TclUniCharMatch where possible.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the

 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)
    CONST Tcl_UniChar *uniStr;	/* Unicode String. */
    CONST Tcl_UniChar *uniPattern;
				/* Pattern, which may contain special
				 * characters. */
    int nocase;			/* 0 for case sensitive, 1 for insensitive */
{
    Tcl_UniChar ch1, p;
    
    while (1) {
	p = *uniPattern;
	
	/*
	 * See if we're at the end of both the pattern and the string. If so,
	 * we succeeded. If we're at the end of the pattern but not at the end
	 * of the string, we failed.
	 */
	
	if (p == 0) {
	    return (*uniStr == 0);
	}
	if ((*uniStr == 0) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */
	
	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++uniPattern) == '*') {
		/* empty body */
	    }
	    p = *uniPattern;
	    if (p == 0) {
		return 1;
	    }
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    if (nocase) {
			while (*uniStr && (p != *uniStr)
				&& (p != Tcl_UniCharToLower(*uniStr))) {
			    uniStr++;
			}
		    } else {
			while (*uniStr && (p != *uniStr)) {
			    uniStr++;
			}
		    }
		}
		if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) {
		    return 1;
		}
		if (*uniStr == 0) {
		    return 0;
		}
		uniStr++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
	 * single character.
	 */

	if (p == '?') {
	    uniPattern++;
	    uniStr++;
	    continue;
	}

	/*
	 * Check for a "[" as the next pattern character. It is followed by a
	 * list of characters that are acceptable, or by a range (two
	 * characters separated by "-").
	 */
	
	if (p == '[') {
	    Tcl_UniChar startChar, endChar;

	    uniPattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
	    uniStr++;
	    while (1) {
		if ((*uniPattern == ']') || (*uniPattern == 0)) {
		    return 0;
		}
		startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
			: *uniPattern);
		uniPattern++;
		if (*uniPattern == '-') {
		    uniPattern++;
		    if (*uniPattern == 0) {
			return 0;
		    }
		    endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
			    : *uniPattern);
		    uniPattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
			 * Matches ranges of form [a-z] or [z-a].
			 */
			break;
		    }
		} else if (startChar == ch1) {
		    break;
		}
	    }
	    while (*uniPattern != ']') {
		if (*uniPattern == 0) {
		    uniPattern--;
		    break;
		}
		uniPattern++;
	    }
	    uniPattern++;
	    continue;
	}

	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (*(++uniPattern) == '\0') {
		return 0;
	    }
	}

	/*
	 * There's no special character.  Just make sure that the next bytes
	 * of each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*uniStr) !=
		    Tcl_UniCharToLower(*uniPattern)) {
		return 0;
	    }
	} else if (*uniStr != *uniPattern) {
	    return 0;
	}
	uniStr++;
	uniPattern++;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclUniCharMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.
 *	Allows case insensitivity. This is the Unicode equivalent of the char*
 *	Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted
 *	Strings, so embedded NULLs are allowed.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the

 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclUniCharMatch(string, strLen, pattern, ptnLen, nocase)
    CONST Tcl_UniChar *string;	/* Unicode String. */
    int strLen;			/* length of String */
    CONST Tcl_UniChar *pattern;	/* Pattern, which may contain special
				 * characters. */
    int ptnLen;			/* length of Pattern */
    int nocase;			/* 0 for case sensitive, 1 for insensitive */
{
    CONST Tcl_UniChar *stringEnd, *patternEnd;
    Tcl_UniChar p;

    stringEnd = string + strLen;
    patternEnd = pattern + ptnLen;

    while (1) {
	/*
	 * See if we're at the end of both the pattern and the string. If so,
	 * we succeeded. If we're at the end of the pattern but not at the end
	 * of the string, we failed.
	 */

	if (pattern == patternEnd) {
	    return (string == stringEnd);
	}
	p = *pattern;
	if ((string == stringEnd) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */
	
	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern.
	     */

	    while (*(++pattern) == '*') {
		/* empty body */
	    }
	    if (pattern == patternEnd) {
		return 1;
	    }
	    p = *pattern;
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character.
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    if (nocase) {
			while ((string < stringEnd) && (p != *string)
				&& (p != Tcl_UniCharToLower(*string))) {
			    string++;
			}
		    } else {
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
		    return 0;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character.  It matches
	 * any single character.
	 */

	if (p == '?') {
	    pattern++;
	    string++;
	    continue;
	}

	/*
	 * Check for a "[" as the next pattern character.  It is followed
	 * by a list of characters that are acceptable, or by a range
	 * (two characters separated by "-").
	 */
	
	if (p == '[') {
	    Tcl_UniChar ch1, startChar, endChar;

	    pattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);







|
|









|
|
|







1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
		    return 0;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
	 * single character.
	 */

	if (p == '?') {
	    pattern++;
	    string++;
	    continue;
	}

	/*
	 * Check for a "[" as the next pattern character. It is followed by a
	 * list of characters that are acceptable, or by a range (two
	 * characters separated by "-").
	 */
	
	if (p == '[') {
	    Tcl_UniChar ch1, startChar, endChar;

	    pattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948








		pattern++;
	    }
	    pattern++;
	    continue;
	}

	/*
	 * If the next pattern character is '\', just strip off the '\'
	 * so we do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (++pattern == patternEnd) {
		return 0;
	    }
	}

	/*
	 * There's no special character.  Just make sure that the next
	 * bytes of each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
		return 0;
	    }
	} else if (*string != *pattern) {
	    return 0;
	}
	string++;
	pattern++;
    }
}















|
|









|
|













>
>
>
>
>
>
>
>
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
		pattern++;
	    }
	    pattern++;
	    continue;
	}

	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (++pattern == patternEnd) {
		return 0;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
		return 0;
	    }
	} else if (*string != *pattern) {
	    return 0;
	}
	string++;
	pattern++;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclUtil.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17


18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75


76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
/* 
 * tclUtil.c --
 *
 *	This file contains utility procedures that are used by many Tcl
 *	commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.51 2004/12/02 00:09:40 dgp Exp $
 */

#include "tclInt.h"



/*
 * The absolute pathname of the executable in which this Tcl library
 * is running.
 */
static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL};

/*
 * The following values are used in the flags returned by Tcl_ScanElement
 * and used by Tcl_ConvertElement.  The values TCL_DONT_USE_BRACES and
 * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value
 * overlaps with any of the values below.  
 *
 * TCL_DONT_USE_BRACES -	1 means the string mustn't be enclosed in
 *				braces (e.g. it contains unmatched braces,
 *				or ends in a backslash character, or user
 *				just doesn't want braces);  handle all
 *				special characters by adding backslashes.
 * USE_BRACES -			1 means the string contains a special
 *				character that can be handled simply by
 *				enclosing the entire argument in braces.
 * BRACES_UNMATCHED -		1 means that braces aren't properly matched
 *				in the argument.
 * TCL_DONT_QUOTE_HASH -	1 means the caller insists that a leading
 * 				hash character ('#') should *not* be quoted.
 * 				This is appropriate when the caller can
 * 				guarantee the element is not the first element
 * 				of a list, so [eval] cannot mis-parse the
 * 				element as a comment.
 */

#define USE_BRACES		2
#define BRACES_UNMATCHED	4

/*
 * The following values determine the precision used when converting
 * floating-point values to strings.  This information is linked to all
 * of the tcl_precision variables in all interpreters via the procedure
 * TclPrecTraceProc.
 */

static char precisionString[10] = "12";
				/* The string value of all the tcl_precision
				 * variables. */
static char precisionFormat[10] = "%.12g";
				/* The format string actually used in calls
				 * to sprintf. */
TCL_DECLARE_MUTEX(precisionMutex)

/*
 * Prototypes for procedures defined later in this file.
 */

static void		ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr));
static void		FreeProcessGlobalValue _ANSI_ARGS_((
			    ClientData clientData));
static void		FreeThreadHash _ANSI_ARGS_ ((ClientData clientData));
static Tcl_HashTable *	GetThreadHash _ANSI_ARGS_ ((Tcl_ThreadDataKey *keyPtr));


static int		SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
					    Tcl_Obj* objPtr));
static void		UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));

/*
 * The following is the Tcl object type definition for an object
 * that represents a list index in the form, "end-offset".  It is
 * used as a performance optimization in TclGetIntForIndex.  The
 * internal rep is an integer, so no memory management is required
 * for it.
 */

Tcl_ObjType tclEndOffsetType = {
    "end-offset",			/* name */
    (Tcl_FreeInternalRepProc*) NULL,    /* freeIntRepProc */
    (Tcl_DupInternalRepProc*) NULL,     /* dupIntRepProc */
    UpdateStringOfEndOffset,		/* updateStringProc */
    SetEndOffsetFromAny    
};


/*
 *----------------------------------------------------------------------
 *
 * TclFindElement --
 *
 *	Given a pointer into a Tcl list, locate the first (or next)
 *	element in the list.
 *
 * Results:
 *	The return value is normally TCL_OK, which means that the
 *	element was successfully located.  If TCL_ERROR is returned
 *	it means that list didn't have proper list structure;
 *	the interp's result contains a more detailed error message.
 *
 *	If TCL_OK is returned, then *elementPtr will be set to point to the
 *	first element of list, and *nextPtr will be set to point to the
 *	character just after any white space following the last character
 *	that's part of the element. If this is the last argument in the
 *	list, then *nextPtr will point just after the last character in the
 *	list (i.e., at the character at list+listLength). If sizePtr is
 *	non-NULL, *sizePtr is filled in with the number of characters in the
 *	element.  If the element is in braces, then *elementPtr will point
 *	to the character after the opening brace and *sizePtr will not
 *	include either of the braces. If there isn't an element in the list,
 *	*sizePtr will be zero, and both *elementPtr and *termPtr will point
 *	just after the last character in the list. Note: this procedure does
 *	NOT collapse backslash sequences.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
	       bracePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. 
				 * If NULL, then no error message is left
				 * after errors. */
    CONST char *list;		/* Points to the first byte of a string
				 * containing a Tcl list with zero or more
				 * elements (possibly in braces). */
    int listLength;		/* Number of bytes in the list's string. */
    CONST char **elementPtr;	/* Where to put address of first significant
				 * character in first element of list. */
    CONST char **nextPtr;	/* Fill in with location of character just
				 * after all white space following end of
				 * argument (next arg or end of list). */
    int *sizePtr;		/* If non-zero, fill in with size of
				 * element. */
    int *bracePtr;		/* If non-zero, fill in with non-zero/zero
				 * to indicate that arg was/wasn't
				 * in braces. */
{
    CONST char *p = list;
    CONST char *elemStart;	/* Points to first byte of first element. */
    CONST char *limit;		/* Points just after list's last byte. */
    int openBraces = 0;		/* Brace nesting level during parse. */
    int inQuotes = 0;
    int size = 0;		/* lint. */
    int numChars;
    CONST char *p2;
    
    /*
     * Skim off leading white space and check for an opening brace or
     * quote. We treat embedded NULLs in the list as bytes belonging to
     * a list element.
     */

    limit = (list + listLength);
    while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
	p++;
    }
    if (p == limit) {		/* no element found */
|


|






|
|

|



>
>








|
|
|
|


|
|
|
|



|
|
|
|
|
|
|
|






|
<
|
<


<
<
<
<
<
<
|


|





|
|
>
>

|



|
|
|
|
<





|

|








|
|


|
|
|
|




|
|
|
|
|
|
|
|
|
|









|
|
|
|











|
|
<









|

|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

56

57
58






59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
/*
 * tclUtil.c --
 *
 *	This file contains utility functions that are used by many Tcl
 *	commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.51.2.20 2005/09/15 20:58:40 dgp Exp $
 */

#include "tclInt.h"
#include <float.h>
#include <math.h>

/*
 * The absolute pathname of the executable in which this Tcl library
 * is running.
 */
static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL};

/*
 * The following values are used in the flags returned by Tcl_ScanElement and
 * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and
 * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps
 * with any of the values below.
 *
 * TCL_DONT_USE_BRACES -	1 means the string mustn't be enclosed in
 *				braces (e.g. it contains unmatched braces, or
 *				ends in a backslash character, or user just
 *				doesn't want braces); handle all special
 *				characters by adding backslashes.
 * USE_BRACES -			1 means the string contains a special
 *				character that can be handled simply by
 *				enclosing the entire argument in braces.
 * BRACES_UNMATCHED -		1 means that braces aren't properly matched in
 *				the argument.
 * TCL_DONT_QUOTE_HASH -	1 means the caller insists that a leading hash
 * 				character ('#') should *not* be quoted. This
 * 				is appropriate when the caller can guarantee
 * 				the element is not the first element of a
 * 				list, so [eval] cannot mis-parse the element
 * 				as a comment.
 */

#define USE_BRACES		2
#define BRACES_UNMATCHED	4

/*
 * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to

 * access the precision to be used for double formatting.

 */







static Tcl_ThreadDataKey precisionKey;

/*
 * Prototypes for functions defined later in this file.
 */

static void		ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr));
static void		FreeProcessGlobalValue _ANSI_ARGS_((
			    ClientData clientData));
static void		FreeThreadHash _ANSI_ARGS_((ClientData clientData));
static Tcl_HashTable *	GetThreadHash _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr));
static int		ParseInteger _ANSI_ARGS_((CONST char *bytes,
			    int numBytes));
static int		SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
			    Tcl_Obj* objPtr));
static void		UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));

/*
 * The following is the Tcl object type definition for an object that
 * represents a list index in the form, "end-offset". It is used as a
 * performance optimization in TclGetIntForIndex. The internal rep is an
 * integer, so no memory management is required for it.

 */

Tcl_ObjType tclEndOffsetType = {
    "end-offset",			/* name */
    (Tcl_FreeInternalRepProc*) NULL,    /* freeIntRepProc */
    (Tcl_DupInternalRepProc*) NULL,	/* dupIntRepProc */
    UpdateStringOfEndOffset,		/* updateStringProc */
    SetEndOffsetFromAny
};


/*
 *----------------------------------------------------------------------
 *
 * TclFindElement --
 *
 *	Given a pointer into a Tcl list, locate the first (or next) element in
 *	the list.
 *
 * Results:
 *	The return value is normally TCL_OK, which means that the element was
 *	successfully located. If TCL_ERROR is returned it means that list
 *	didn't have proper list structure; the interp's result contains a more
 *	detailed error message.
 *
 *	If TCL_OK is returned, then *elementPtr will be set to point to the
 *	first element of list, and *nextPtr will be set to point to the
 *	character just after any white space following the last character
 *	that's part of the element. If this is the last argument in the list,
 *	then *nextPtr will point just after the last character in the list
 *	(i.e., at the character at list+listLength). If sizePtr is non-NULL,
 *	*sizePtr is filled in with the number of characters in the element. If
 *	the element is in braces, then *elementPtr will point to the character
 *	after the opening brace and *sizePtr will not include either of the
 *	braces. If there isn't an element in the list, *sizePtr will be zero,
 *	and both *elementPtr and *termPtr will point just after the last
 *	character in the list. Note: this function does NOT collapse backslash
 *	sequences.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
	bracePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    CONST char *list;		/* Points to the first byte of a string
				 * containing a Tcl list with zero or more
				 * elements (possibly in braces). */
    int listLength;		/* Number of bytes in the list's string. */
    CONST char **elementPtr;	/* Where to put address of first significant
				 * character in first element of list. */
    CONST char **nextPtr;	/* Fill in with location of character just
				 * after all white space following end of
				 * argument (next arg or end of list). */
    int *sizePtr;		/* If non-zero, fill in with size of
				 * element. */
    int *bracePtr;		/* If non-zero, fill in with non-zero/zero to
				 * indicate that arg was/wasn't in braces. */

{
    CONST char *p = list;
    CONST char *elemStart;	/* Points to first byte of first element. */
    CONST char *limit;		/* Points just after list's last byte. */
    int openBraces = 0;		/* Brace nesting level during parse. */
    int inQuotes = 0;
    int size = 0;		/* lint. */
    int numChars;
    CONST char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
     * We treat embedded NULLs in the list as bytes belonging to a list
     * element.
     */

    limit = (list + listLength);
    while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
	p++;
    }
    if (p == limit) {		/* no element found */
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

    /*
     * Find element's end (a space, close brace, or the end of the string).
     */

    while (p < limit) {
	switch (*p) {

	    /*
	     * Open brace: don't treat specially unless the element is in
	     * braces. In this case, keep a nesting count.
	     */

	    case '{':
		if (openBraces != 0) {
		    openBraces++;
		}
		break;

	    /*
	     * Close brace: if element is in braces, keep nesting count and
	     * quit when the last close brace is seen.
	     */

	    case '}':
		if (openBraces > 1) {
		    openBraces--;
		} else if (openBraces == 1) {
		    size = (p - elemStart);
		    p++;
		    if ((p >= limit)
			    || isspace(UCHAR(*p))) { /* INTL: ISO space. */
			goto done;
		    }

		    /*
		     * Garbage after the closing brace; return an error.
		     */
		    
		    if (interp != NULL) {
			char buf[100];
			
			p2 = p;
			while ((p2 < limit)
				&& (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
			        && (p2 < p+20)) {
			    p2++;
			}
			sprintf(buf,
				"list element in braces followed by \"%.*s\" instead of space",
				(int) (p2-p), p);
			Tcl_SetResult(interp, buf, TCL_VOLATILE);
		    }
		    return TCL_ERROR;
		}
		break;

	    /*
	     * Backslash:  skip over everything up to the end of the
	     * backslash sequence.
	     */

	    case '\\': {
		Tcl_UtfBackslash(p, &numChars, NULL);
		p += (numChars - 1);
		break;
	    }

	    /*
	     * Space: ignore if element is in braces or quotes; otherwise
	     * terminate element.
	     */

	    case ' ':
	    case '\f':
	    case '\n':
	    case '\r':
	    case '\t':
	    case '\v':
		if ((openBraces == 0) && !inQuotes) {
		    size = (p - elemStart);
		    goto done;
		}
		break;

	    /*
	     * Double-quote: if element is in quotes then terminate it.
	     */

	    case '"':
		if (inQuotes) {
		    size = (p - elemStart);
		    p++;
		    if ((p >= limit)
			    || isspace(UCHAR(*p))) { /* INTL: ISO space */
			goto done;
		    }

		    /*
		     * Garbage after the closing quote; return an error.
		     */
		    
		    if (interp != NULL) {
			char buf[100];
			
			p2 = p;
			while ((p2 < limit)
				&& (!isspace(UCHAR(*p2))) /* INTL: ISO space */
				 && (p2 < p+20)) {
			    p2++;
			}
			sprintf(buf,
				"list element in quotes followed by \"%.*s\" %s",
				(int) (p2-p), p, "instead of space");
			Tcl_SetResult(interp, buf, TCL_VOLATILE);
		    }
		    return TCL_ERROR;
		}
		break;
	}
	p++;
    }


    /*
     * End of list: terminate element.
     */

    if (p == limit) {
	if (openBraces != 0) {







<





|
|
|
|
|






|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|


|
|
|
|
<






|
|
|
|
|
|
|
|
|
|
|





|
|
|
|
|
|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



<







181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219

220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280

281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298

299
300
301
302
303
304
305

    /*
     * Find element's end (a space, close brace, or the end of the string).
     */

    while (p < limit) {
	switch (*p) {

	    /*
	     * Open brace: don't treat specially unless the element is in
	     * braces. In this case, keep a nesting count.
	     */

	case '{':
	    if (openBraces != 0) {
		openBraces++;
	    }
	    break;

	    /*
	     * Close brace: if element is in braces, keep nesting count and
	     * quit when the last close brace is seen.
	     */

	case '}':
	    if (openBraces > 1) {
		openBraces--;
	    } else if (openBraces == 1) {
		size = (p - elemStart);
		p++;
		if ((p >= limit)
			|| isspace(UCHAR(*p))) {	/* INTL: ISO space. */
		    goto done;
		}

		/*
		 * Garbage after the closing brace; return an error.
		 */

		if (interp != NULL) {

		    Tcl_Obj *objPtr = Tcl_NewObj();
		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space. */
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclObjPrintf(NULL, objPtr,
			    "list element in braces followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p);
		    Tcl_SetObjResult(interp, objPtr);
		}
		return TCL_ERROR;
	    }
	    break;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
	     * sequence.
	     */

	case '\\':
	    Tcl_UtfBackslash(p, &numChars, NULL);
	    p += (numChars - 1);
	    break;


	    /*
	     * Space: ignore if element is in braces or quotes; otherwise
	     * terminate element.
	     */

	case ' ':
	case '\f':
	case '\n':
	case '\r':
	case '\t':
	case '\v':
	    if ((openBraces == 0) && !inQuotes) {
		size = (p - elemStart);
		goto done;
	    }
	    break;

	    /*
	     * Double-quote: if element is in quotes then terminate it.
	     */

	case '"':
	    if (inQuotes) {
		size = (p - elemStart);
		p++;
		if ((p >= limit)
			|| isspace(UCHAR(*p))) {	/* INTL: ISO space */
		    goto done;
		}

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {

		    Tcl_Obj *objPtr = Tcl_NewObj();
		    p2 = p;
		    while ((p2 < limit)
			    && (!isspace(UCHAR(*p2)))	/* INTL: ISO space */
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclObjPrintf(NULL, objPtr,
			    "list element in quotes followed by \"%.*s\" "
			    "instead of space", (int) (p2-p), p);
		    Tcl_SetObjResult(interp, objPtr);
		}
		return TCL_ERROR;
	    }
	    break;
	}
	p++;
    }


    /*
     * End of list: terminate element.
     */

    if (p == limit) {
	if (openBraces != 0) {
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
			TCL_STATIC);
	    }
	    return TCL_ERROR;
	}
	size = (p - elemStart);
    }

    done:
    while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
	p++;
    }
    *elementPtr = elemStart;
    *nextPtr = p;
    if (sizePtr != 0) {
	*sizePtr = size;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCopyAndCollapse --
 *
 *	Copy a string and eliminate any backslashes that aren't in braces.
 *
 * Results:
 *	Count characters get copied from src to	dst. Along the way, if
 *	backslash sequences are found outside braces, the backslashes are
 *	eliminated in the copy. After scanning count chars from source, a
 *	null character is placed at the end of dst.  Returns the number
 *	of characters that got copied.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|



















|

|
|
|







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
			TCL_STATIC);
	    }
	    return TCL_ERROR;
	}
	size = (p - elemStart);
    }

  done:
    while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
	p++;
    }
    *elementPtr = elemStart;
    *nextPtr = p;
    if (sizePtr != 0) {
	*sizePtr = size;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCopyAndCollapse --
 *
 *	Copy a string and eliminate any backslashes that aren't in braces.
 *
 * Results:
 *	Count characters get copied from src to dst. Along the way, if
 *	backslash sequences are found outside braces, the backslashes are
 *	eliminated in the copy. After scanning count chars from source, a null
 *	character is placed at the end of dst. Returns the number of
 *	characters that got copied.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
 *----------------------------------------------------------------------
 *
 * Tcl_SplitList --
 *
 *	Splits a list up into its constituent fields.
 *
 * Results
 *	The return value is normally TCL_OK, which means that
 *	the list was successfully split up.  If TCL_ERROR is
 *	returned, it means that "list" didn't have proper list
 *	structure;  the interp's result will contain a more detailed
 *	error message.
 *
 *	*argvPtr will be filled in with the address of an array
 *	whose elements point to the elements of list, in order.
 *	*argcPtr will get filled in with the number of valid elements
 *	in the array.  A single block of memory is dynamically allocated
 *	to hold both the argv array and a copy of the list (with
 *	backslashes and braces removed in the standard way).
 *	The caller must eventually free this memory by calling free()
 *	on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
 *	if the procedure returns normally.
 *
 * Side effects:
 *	Memory is allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. 
				 * If NULL, no error message is left. */
    CONST char *list;		/* Pointer to string with list structure. */
    int *argcPtr;		/* Pointer to location to fill in with
				 * the number of elements in the list. */
    CONST char ***argvPtr;	/* Pointer to place to store pointer to
				 * array of pointers to list elements. */
{
    CONST char **argv;
    CONST char *l;
    char *p;
    int length, size, i, result, elSize, brace;
    CONST char *element;

    /*
     * Figure out how much space to allocate.  There must be enough
     * space for both the array of pointers and also for a copy of
     * the list.  To estimate the number of pointers needed, count
     * the number of space characters in the list.
     */

    for (size = 1, l = list; *l != 0; l++) {
	if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
	    size++;
	}
    }
    size++;			/* Leave space for final NULL pointer. */
    argv = (CONST char **) ckalloc((unsigned)
	    ((size * sizeof(char *)) + (l - list) + 1));
    length = strlen(list);
    for (i = 0, p = ((char *) argv) + size*sizeof(char *);
	    *list != 0;  i++) {
	CONST char *prevList = list;
	
	result = TclFindElement(interp, list, length, &element,
				&list, &elSize, &brace);
	length -= (list - prevList);
	if (result != TCL_OK) {
	    ckfree((char *) argv);
	    return result;
	}







|
|
|
<
|

|
|
|
<
|
|
|
|
|









|
|

|
|
|
|








|
|
|
|














|







382
383
384
385
386
387
388
389
390
391

392
393
394
395
396

397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
 *----------------------------------------------------------------------
 *
 * Tcl_SplitList --
 *
 *	Splits a list up into its constituent fields.
 *
 * Results
 *	The return value is normally TCL_OK, which means that the list was
 *	successfully split up. If TCL_ERROR is returned, it means that "list"
 *	didn't have proper list structure; the interp's result will contain a

 *	more detailed error message.
 *
 *	*argvPtr will be filled in with the address of an array whose elements
 *	point to the elements of list, in order. *argcPtr will get filled in
 *	with the number of valid elements in the array. A single block of

 *	memory is dynamically allocated to hold both the argv array and a copy
 *	of the list (with backslashes and braces removed in the standard way).
 *	The caller must eventually free this memory by calling free() on
 *	*argvPtr. Note: *argvPtr and *argcPtr are only modified if the
 *	function returns normally.
 *
 * Side effects:
 *	Memory is allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. If
				 * NULL, no error message is left. */
    CONST char *list;		/* Pointer to string with list structure. */
    int *argcPtr;		/* Pointer to location to fill in with the
				 * number of elements in the list. */
    CONST char ***argvPtr;	/* Pointer to place to store pointer to array
				 * of pointers to list elements. */
{
    CONST char **argv;
    CONST char *l;
    char *p;
    int length, size, i, result, elSize, brace;
    CONST char *element;

    /*
     * Figure out how much space to allocate. There must be enough space for
     * both the array of pointers and also for a copy of the list. To estimate
     * the number of pointers needed, count the number of space characters in
     * the list.
     */

    for (size = 1, l = list; *l != 0; l++) {
	if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
	    size++;
	}
    }
    size++;			/* Leave space for final NULL pointer. */
    argv = (CONST char **) ckalloc((unsigned)
	    ((size * sizeof(char *)) + (l - list) + 1));
    length = strlen(list);
    for (i = 0, p = ((char *) argv) + size*sizeof(char *);
	    *list != 0;  i++) {
	CONST char *prevList = list;

	result = TclFindElement(interp, list, length, &element,
				&list, &elSize, &brace);
	length -= (list - prevList);
	if (result != TCL_OK) {
	    ckfree((char *) argv);
	    return result;
	}
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanElement --
 *
 *	This procedure is a companion procedure to Tcl_ConvertElement.
 *	It scans a string to see what needs to be done to it (e.g. add
 *	backslashes or enclosing braces) to make the string into a
 *	valid Tcl list element.
 *
 * Results:
 *	The return value is an overestimate of the number of characters
 *	that will be needed by Tcl_ConvertElement to produce a valid
 *	list element from string.  The word at *flagPtr is filled in
 *	with a value needed by Tcl_ConvertElement when doing the actual
 *	conversion.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|
<


|
|
|
|
<







479
480
481
482
483
484
485
486
487
488

489
490
491
492
493
494

495
496
497
498
499
500
501
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanElement --
 *
 *	This function is a companion function to Tcl_ConvertElement. It scans
 *	a string to see what needs to be done to it (e.g. add backslashes or
 *	enclosing braces) to make the string into a valid Tcl list element.

 *
 * Results:
 *	The return value is an overestimate of the number of characters that
 *	will be needed by Tcl_ConvertElement to produce a valid list element
 *	from string. The word at *flagPtr is filled in with a value needed by
 *	Tcl_ConvertElement when doing the actual conversion.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanCountedElement --
 *
 *	This procedure is a companion procedure to
 *	Tcl_ConvertCountedElement.  It scans a string to see what
 *	needs to be done to it (e.g. add backslashes or enclosing
 *	braces) to make the string into a valid Tcl list element.
 *	If length is -1, then the string is scanned up to the first
 *	null byte.
 *
 * Results:
 *	The return value is an overestimate of the number of characters
 *	that will be needed by Tcl_ConvertCountedElement to produce a
 *	valid list element from string.  The word at *flagPtr is
 *	filled in with a value needed by Tcl_ConvertCountedElement
 *	when doing the actual conversion.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ScanCountedElement(string, length, flagPtr)
    CONST char *string;		/* String to convert to Tcl list element. */
    int length;			/* Number of bytes in string, or -1. */
    int *flagPtr;		/* Where to store information to guide
				 * Tcl_ConvertElement. */
{
    int flags, nestingLevel;
    register CONST char *p, *lastChar;

    /*
     * This procedure and Tcl_ConvertElement together do two things:
     *
     * 1. They produce a proper list, one that will yield back the
     * argument strings when evaluated or when disassembled with
     * Tcl_SplitList.  This is the most important thing.
     * 
     * 2. They try to produce legible output, which means minimizing the
     * use of backslashes (using braces instead).  However, there are
     * some situations where backslashes must be used (e.g. an element
     * like "{abc": the leading brace will have to be backslashed.
     * For each element, one of three things must be done:
     *
     * (a) Use the element as-is (it doesn't contain any special
     * characters).  This is the most desirable option.
     *
     * (b) Enclose the element in braces, but leave the contents alone.
     * This happens if the element contains embedded space, or if it
     * contains characters with special interpretation ($, [, ;, or \),
     * or if it starts with a brace or double-quote, or if there are
     * no characters in the element.
     *
     * (c) Don't enclose the element in braces, but add backslashes to
     * prevent special interpretation of special characters.  This is a
     * last resort used when the argument would normally fall under case
     * (b) but contains unmatched braces.  It also occurs if the last
     * character of the argument is a backslash or if the element contains
     * a backslash followed by newline.
     *
     * The procedure figures out how many bytes will be needed to store
     * the result (actually, it overestimates). It also collects information
     * about the element in the form of a flags word.
     *
     * Note: list elements produced by this procedure and
     * Tcl_ConvertCountedElement must have the property that they can be
     * enclosing in curly braces to make sub-lists.  This means, for
     * example, that we must not leave unmatched curly braces in the
     * resulting list element.  This property is necessary in order for
     * procedures like Tcl_DStringStartSublist to work.
     */

    nestingLevel = 0;
    flags = 0;
    if (string == NULL) {
	string = "";
    }
    if (length == -1) {
	length = strlen(string);
    }
    lastChar = string + length;
    p = string;
    if ((p == lastChar) || (*p == '{') || (*p == '"')) {
	flags |= USE_BRACES;
    }
    for ( ; p < lastChar; p++) {
	switch (*p) {
	    case '{':
		nestingLevel++;
		break;
	    case '}':
		nestingLevel--;
		if (nestingLevel < 0) {
		    flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
		}
		break;
	    case '[':
	    case '$':
	    case ';':
	    case ' ':
	    case '\f':
	    case '\n':
	    case '\r':
	    case '\t':
	    case '\v':
		flags |= USE_BRACES;
		break;
	    case '\\':
		if ((p+1 == lastChar) || (p[1] == '\n')) {
		    flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
		} else {
		    int size;

		    Tcl_UtfBackslash(p, &size, NULL);
		    p += size-1;
		    flags |= USE_BRACES;
		}
		break;
	}
    }
    if (nestingLevel != 0) {
	flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
    }
    *flagPtr = flags;

    /*
     * Allow enough space to backslash every character plus leave
     * two spaces for braces.
     */

    return 2*(p-string) + 2;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertElement --
 *
 *	This is a companion procedure to Tcl_ScanElement.  Given
 *	the information produced by Tcl_ScanElement, this procedure
 *	converts a string to a list element equal to that string.
 *
 * Results:
 *	Information is copied to *dst in the form of a list element
 *	identical to src (i.e. if Tcl_SplitList is applied to dst it
 *	will produce a string identical to src).  The return value is
 *	a count of the number of characters copied (not including the
 *	terminating NULL character).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








<
|
|
|
|
|


|
|
|
<
|


















|

|
|
|
|
|
|
|
|
|

|
|

|
|
|
|
|

|
|
|
|
|
|

|
|
|

|

|
|
|
|















|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|








|
|










|
|
|


|
|
|
|
<







509
510
511
512
513
514
515

516
517
518
519
520
521
522
523
524
525

526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659

660
661
662
663
664
665
666
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanCountedElement --
 *

 *	This function is a companion function to Tcl_ConvertCountedElement. It
 *	scans a string to see what needs to be done to it (e.g. add
 *	backslashes or enclosing braces) to make the string into a valid Tcl
 *	list element. If length is -1, then the string is scanned up to the
 *	first null byte.
 *
 * Results:
 *	The return value is an overestimate of the number of characters that
 *	will be needed by Tcl_ConvertCountedElement to produce a valid list
 *	element from string. The word at *flagPtr is filled in with a value

 *	needed by Tcl_ConvertCountedElement when doing the actual conversion.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ScanCountedElement(string, length, flagPtr)
    CONST char *string;		/* String to convert to Tcl list element. */
    int length;			/* Number of bytes in string, or -1. */
    int *flagPtr;		/* Where to store information to guide
				 * Tcl_ConvertElement. */
{
    int flags, nestingLevel;
    register CONST char *p, *lastChar;

    /*
     * This function and Tcl_ConvertElement together do two things:
     *
     * 1. They produce a proper list, one that will yield back the argument
     *	  strings when evaluated or when disassembled with Tcl_SplitList. This
     *	  is the most important thing.
     *
     * 2. They try to produce legible output, which means minimizing the use
     *	  of backslashes (using braces instead). However, there are some
     *	  situations where backslashes must be used (e.g. an element like
     *	  "{abc": the leading brace will have to be backslashed. For each
     *	  element, one of three things must be done:
     *
     * 	  (a) Use the element as-is (it doesn't contain any special
     *	      characters). This is the most desirable option.
     *
     *	  (b) Enclose the element in braces, but leave the contents alone.
     *	      This happens if the element contains embedded space, or if it
     *	      contains characters with special interpretation ($, [, ;, or \),
     *	      or if it starts with a brace or double-quote, or if there are no
     *	      characters in the element.
     *
     *	  (c) Don't enclose the element in braces, but add backslashes to
     *	      prevent special interpretation of special characters. This is a
     *	      last resort used when the argument would normally fall under
     *	      case (b) but contains unmatched braces. It also occurs if the
     *	      last character of the argument is a backslash or if the element
     *	      contains a backslash followed by newline.
     *
     * The function figures out how many bytes will be needed to store the
     * result (actually, it overestimates). It also collects information about
     * the element in the form of a flags word.
     *
     * Note: list elements produced by this function and
     * Tcl_ConvertCountedElement must have the property that they can be
     * enclosing in curly braces to make sub-lists. This means, for example,
     * that we must not leave unmatched curly braces in the resulting list
     * element. This property is necessary in order for functions like
     * Tcl_DStringStartSublist to work.
     */

    nestingLevel = 0;
    flags = 0;
    if (string == NULL) {
	string = "";
    }
    if (length == -1) {
	length = strlen(string);
    }
    lastChar = string + length;
    p = string;
    if ((p == lastChar) || (*p == '{') || (*p == '"')) {
	flags |= USE_BRACES;
    }
    for (; p < lastChar; p++) {
	switch (*p) {
	case '{':
	    nestingLevel++;
	    break;
	case '}':
	    nestingLevel--;
	    if (nestingLevel < 0) {
		flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
	    }
	    break;
	case '[':
	case '$':
	case ';':
	case ' ':
	case '\f':
	case '\n':
	case '\r':
	case '\t':
	case '\v':
	    flags |= USE_BRACES;
	    break;
	case '\\':
	    if ((p+1 == lastChar) || (p[1] == '\n')) {
		flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
	    } else {
		int size;

		Tcl_UtfBackslash(p, &size, NULL);
		p += size-1;
		flags |= USE_BRACES;
	    }
	    break;
	}
    }
    if (nestingLevel != 0) {
	flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
    }
    *flagPtr = flags;

    /*
     * Allow enough space to backslash every character plus leave two spaces
     * for braces.
     */

    return 2*(p-string) + 2;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertElement --
 *
 *	This is a companion function to Tcl_ScanElement. Given the information
 *	produced by Tcl_ScanElement, this function converts a string to a list
 *	element equal to that string.
 *
 * Results:
 *	Information is copied to *dst in the form of a list element identical
 *	to src (i.e. if Tcl_SplitList is applied to dst it will produce a
 *	string identical to src). The return value is a count of the number of
 *	characters copied (not including the terminating NULL character).

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertCountedElement --
 *
 *	This is a companion procedure to Tcl_ScanCountedElement.  Given
 *	the information produced by Tcl_ScanCountedElement, this
 *	procedure converts a string to a list element equal to that
 *	string.
 *
 * Results:
 *	Information is copied to *dst in the form of a list element
 *	identical to src (i.e. if Tcl_SplitList is applied to dst it
 *	will produce a string identical to src).  The return value is
 *	a count of the number of characters copied (not including the
 *	terminating NULL character).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertCountedElement(src, length, dst, flags)
    register CONST char *src;	/* Source information for list element. */
    int length;			/* Number of bytes in src, or -1. */
    char *dst;			/* Place to put list-ified element. */
    int flags;			/* Flags produced by Tcl_ScanElement. */
{
    register char *p = dst;
    register CONST char *lastChar;

    /*
     * See the comment block at the beginning of the Tcl_ScanElement
     * code for details of how this works.
     */

    if (src && length == -1) {
	length = strlen(src);
    }
    if ((src == NULL) || (length == 0)) {
	p[0] = '{';
	p[1] = '}';
	p[2] = 0;
	return 2;
    }
    lastChar = src + length;
    if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	flags |= USE_BRACES;
    }
    if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
	*p = '{';
	p++;
	for ( ; src != lastChar; src++, p++) {
	    *p = *src;
	}
	*p = '}';
	p++;
    } else {
	if (*src == '{') {
	    /*
	     * Can't have a leading brace unless the whole element is
	     * enclosed in braces.  Add a backslash before the brace.
	     * Furthermore, this may destroy the balance between open
	     * and close braces, so set BRACES_UNMATCHED.
	     */

	    p[0] = '\\';
	    p[1] = '{';
	    p += 2;
	    src++;
	    flags |= BRACES_UNMATCHED;
	} else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	    /*
	     * Leading '#' could be seen by [eval] as the start of
	     * a comment, if on the first element of a list, so
	     * quote it.
	     */

	    p[0] = '\\';
	    p[1] = '#';
	    p += 2;
	    src++;
	}
	for (; src != lastChar; src++) {
	    switch (*src) {
		case ']':
		case '[':
		case '$':
		case ';':
		case ' ':
		case '\\':
		case '"':
		    *p = '\\';
		    p++;
		    break;
		case '{':
		case '}':
		    /*
		     * It may not seem necessary to backslash braces, but
		     * it is.  The reason for this is that the resulting
		     * list element may actually be an element of a sub-list
		     * enclosed in braces (e.g. if Tcl_DStringStartSublist
		     * has been invoked), so there may be a brace mismatch
		     * if the braces aren't backslashed.
		     */

		    if (flags & BRACES_UNMATCHED) {
			*p = '\\';
			p++;
		    }
		    break;
		case '\f':
		    *p = '\\';
		    p++;
		    *p = 'f';
		    p++;
		    continue;
		case '\n':
		    *p = '\\';
		    p++;
		    *p = 'n';
		    p++;
		    continue;
		case '\r':
		    *p = '\\';
		    p++;
		    *p = 'r';
		    p++;
		    continue;
		case '\t':
		    *p = '\\';
		    p++;
		    *p = 't';
		    p++;
		    continue;
		case '\v':
		    *p = '\\';
		    p++;
		    *p = 'v';
		    p++;
		    continue;
	    }
	    *p = *src;
	    p++;
	}
    }
    *p = '\0';
    return p-dst;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Merge --
 *
 *	Given a collection of strings, merge them together into a
 *	single string that has proper Tcl list structured (i.e.
 *	Tcl_SplitList may be used to retrieve strings equal to the
 *	original elements, and Tcl_Eval will parse the string back
 *	into its original elements).
 *
 * Results:
 *	The return value is the address of a dynamically-allocated
 *	string containing the merged list.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|
<


|
|
|
|
<


















|
|


















|







|
|
|
|









|
|
<









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|














|
|
|
<
|


|
|







674
675
676
677
678
679
680
681
682
683

684
685
686
687
688
689

690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832

833
834
835
836
837
838
839
840
841
842
843
844
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertCountedElement --
 *
 *	This is a companion function to Tcl_ScanCountedElement. Given the
 *	information produced by Tcl_ScanCountedElement, this function converts
 *	a string to a list element equal to that string.

 *
 * Results:
 *	Information is copied to *dst in the form of a list element identical
 *	to src (i.e. if Tcl_SplitList is applied to dst it will produce a
 *	string identical to src). The return value is a count of the number of
 *	characters copied (not including the terminating NULL character).

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertCountedElement(src, length, dst, flags)
    register CONST char *src;	/* Source information for list element. */
    int length;			/* Number of bytes in src, or -1. */
    char *dst;			/* Place to put list-ified element. */
    int flags;			/* Flags produced by Tcl_ScanElement. */
{
    register char *p = dst;
    register CONST char *lastChar;

    /*
     * See the comment block at the beginning of the Tcl_ScanElement code for
     * details of how this works.
     */

    if (src && length == -1) {
	length = strlen(src);
    }
    if ((src == NULL) || (length == 0)) {
	p[0] = '{';
	p[1] = '}';
	p[2] = 0;
	return 2;
    }
    lastChar = src + length;
    if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	flags |= USE_BRACES;
    }
    if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
	*p = '{';
	p++;
	for (; src != lastChar; src++, p++) {
	    *p = *src;
	}
	*p = '}';
	p++;
    } else {
	if (*src == '{') {
	    /*
	     * Can't have a leading brace unless the whole element is enclosed
	     * in braces. Add a backslash before the brace. Furthermore, this
	     * may destroy the balance between open and close braces, so set
	     * BRACES_UNMATCHED.
	     */

	    p[0] = '\\';
	    p[1] = '{';
	    p += 2;
	    src++;
	    flags |= BRACES_UNMATCHED;
	} else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	    /*
	     * Leading '#' could be seen by [eval] as the start of a comment,
	     * if on the first element of a list, so quote it.

	     */

	    p[0] = '\\';
	    p[1] = '#';
	    p += 2;
	    src++;
	}
	for (; src != lastChar; src++) {
	    switch (*src) {
	    case ']':
	    case '[':
	    case '$':
	    case ';':
	    case ' ':
	    case '\\':
	    case '"':
		*p = '\\';
		p++;
		break;
	    case '{':
	    case '}':
		/*
		 * It may not seem necessary to backslash braces, but it is.
		 * The reason for this is that the resulting list element may
		 * actually be an element of a sub-list enclosed in braces
		 * (e.g. if Tcl_DStringStartSublist has been invoked), so
		 * there may be a brace mismatch if the braces aren't
		 * backslashed.
		 */

		if (flags & BRACES_UNMATCHED) {
		    *p = '\\';
		    p++;
		}
		break;
	    case '\f':
		*p = '\\';
		p++;
		*p = 'f';
		p++;
		continue;
	    case '\n':
		*p = '\\';
		p++;
		*p = 'n';
		p++;
		continue;
	    case '\r':
		*p = '\\';
		p++;
		*p = 'r';
		p++;
		continue;
	    case '\t':
		*p = '\\';
		p++;
		*p = 't';
		p++;
		continue;
	    case '\v':
		*p = '\\';
		p++;
		*p = 'v';
		p++;
		continue;
	    }
	    *p = *src;
	    p++;
	}
    }
    *p = '\0';
    return p-dst;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Merge --
 *
 *	Given a collection of strings, merge them together into a single
 *	string that has proper Tcl list structured (i.e. Tcl_SplitList may be
 *	used to retrieve strings equal to the original elements, and Tcl_Eval

 *	will parse the string back into its original elements).
 *
 * Results:
 *	The return value is the address of a dynamically-allocated string
 *	containing the merged list.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
    /*
     * Pass two: copy into the result area.
     */

    result = (char *) ckalloc((unsigned) numChars);
    dst = result;
    for (i = 0; i < argc; i++) {
	numChars = Tcl_ConvertElement(argv[i], dst, 
		flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) );
	dst += numChars;
	*dst = ' ';
	dst++;
    }
    if (dst == result) {
	*dst = 0;







|







871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
    /*
     * Pass two: copy into the result area.
     */

    result = (char *) ckalloc((unsigned) numChars);
    dst = result;
    for (i = 0; i < argc; i++) {
	numChars = Tcl_ConvertElement(argv[i], dst,
		flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) );
	dst += numChars;
	*dst = ' ';
	dst++;
    }
    if (dst == result) {
	*dst = 0;
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
 *----------------------------------------------------------------------
 *
 * Tcl_Backslash --
 *
 *	Figure out how to handle a backslash sequence.
 *
 * Results:
 *	The return value is the character that should be substituted
 *	in place of the backslash sequence that starts at src.  If
 *	readPtr isn't NULL then it is filled in with a count of the
 *	number of characters in the backslash sequence.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char
Tcl_Backslash(src, readPtr)
    CONST char *src;		/* Points to the backslash character of
				 * a backslash sequence. */
    int *readPtr;		/* Fill in with number of characters read
				 * from src, unless NULL. */
{
    char buf[TCL_UTF_MAX];
    Tcl_UniChar ch;

    Tcl_UtfBackslash(src, readPtr, buf);
    TclUtfToUniChar(buf, &ch);
    return (char) ch;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Concat --
 *
 *	Concatenate a set of strings into a single large string.
 *
 * Results:
 *	The return value is dynamically-allocated string containing
 *	a concatenation of all the strings in argv, with spaces between
 *	the original argv elements.
 *
 * Side effects:
 *	Memory is allocated for the result;  the caller is responsible
 *	for freeing the memory.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Concat(argc, argv)
    int argc;			/* Number of strings to concatenate. */







|
|
|
|









|
|
|
|

















|
|
|


|
|







897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
 *----------------------------------------------------------------------
 *
 * Tcl_Backslash --
 *
 *	Figure out how to handle a backslash sequence.
 *
 * Results:
 *	The return value is the character that should be substituted in place
 *	of the backslash sequence that starts at src. If readPtr isn't NULL
 *	then it is filled in with a count of the number of characters in the
 *	backslash sequence.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char
Tcl_Backslash(src, readPtr)
    CONST char *src;		/* Points to the backslash character of a
				 * backslash sequence. */
    int *readPtr;		/* Fill in with number of characters read from
				 * src, unless NULL. */
{
    char buf[TCL_UTF_MAX];
    Tcl_UniChar ch;

    Tcl_UtfBackslash(src, readPtr, buf);
    TclUtfToUniChar(buf, &ch);
    return (char) ch;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Concat --
 *
 *	Concatenate a set of strings into a single large string.
 *
 * Results:
 *	The return value is dynamically-allocated string containing a
 *	concatenation of all the strings in argv, with spaces between the
 *	original argv elements.
 *
 * Side effects:
 *	Memory is allocated for the result; the caller is responsible for
 *	freeing the memory.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Concat(argc, argv)
    int argc;			/* Number of strings to concatenate. */
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
	return result;
    }
    for (p = result, i = 0; i < argc; i++) {
	CONST char *element;
	int length;

	/*
	 * Clip white space off the front and back of the string
	 * to generate a neater result, and ignore any empty
	 * elements.
	 */

	element = argv[i];
	while (isspace(UCHAR(*element))) { /* INTL: ISO space. */
	    element++;
	}
	for (length = strlen(element);
		(length > 0)
		&& (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
		&& ((length < 2) || (element[length-2] != '\\'));
	        length--) {
	    /* Null loop body. */
	}
	if (length == 0) {
	    continue;
	}
	memcpy((VOID *) p, (VOID *) element, (size_t) length);
	p += length;







|
|
<










|







964
965
966
967
968
969
970
971
972

973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
	return result;
    }
    for (p = result, i = 0; i < argc; i++) {
	CONST char *element;
	int length;

	/*
	 * Clip white space off the front and back of the string to generate a
	 * neater result, and ignore any empty elements.

	 */

	element = argv[i];
	while (isspace(UCHAR(*element))) { /* INTL: ISO space. */
	    element++;
	}
	for (length = strlen(element);
		(length > 0)
		&& (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
		&& ((length < 2) || (element[length-2] != '\\'));
		length--) {
	    /* Null loop body. */
	}
	if (length == 0) {
	    continue;
	}
	memcpy((VOID *) p, (VOID *) element, (size_t) length);
	p += length;
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061

1062


1063
1064




1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079

1080
1081
1082
1083
1084
1085





1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245

1246
1247
1248
1249
1250

1251
1252
1253

1254
1255
1256
1257
1258
1259
1260
1261

1262
1263
1264
1265
1266
1267
1268

1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283

1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
 *
 * Tcl_ConcatObj --
 *
 *	Concatenate the strings from a set of objects into a single string
 *	object with spaces between the original strings.
 *
 * Results:
 *	The return value is a new string object containing a concatenation
 *	of the strings in objv. Its ref count is zero.
 *
 * Side effects:
 *	A new object is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ConcatObj(objc, objv)
    int objc;			/* Number of objects to concatenate. */
    Tcl_Obj *CONST objv[];	/* Array of objects to concatenate. */
{
    int allocSize, finalSize, length, elemLength, i;
    char *p;
    char *element;
    char *concatStr;
    Tcl_Obj *objPtr;

    /*
     * Check first to see if all the items are of list type.  If so,
     * we will concat them together as lists, and return a list object.
     * This is only valid when the lists have no current string
     * representation, since we don't know what the original type was.
     * An original string rep may have lost some whitespace info when
     * converted which could be important.
     */

    for (i = 0;  i < objc;  i++) {


	objPtr = objv[i];
	if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) {




	    break;
	}
    }
    if (i == objc) {
	Tcl_Obj **listv;
	int listc;

	objPtr = Tcl_NewListObj(0, NULL);
	for (i = 0;  i < objc;  i++) {
	    /*
	     * Tcl_ListObjAppendList could be used here, but this saves
	     * us a bit of type checking (since we've already done it)
	     * Use of INT_MAX tells us to always put the new stuff on
	     * the end.  It will be set right in Tcl_ListObjReplace.
	     */

	    Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv);
	    Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv);
	}
	return objPtr;
    }






    allocSize = 0;
    for (i = 0;  i < objc;  i++) {
	objPtr = objv[i];
	element = Tcl_GetStringFromObj(objPtr, &length);
	if ((element != NULL) && (length > 0)) {
	    allocSize += (length + 1);
	}
    }
    if (allocSize == 0) {
	allocSize = 1;		/* enough for the NULL byte at end */
    }

    /*
     * Allocate storage for the concatenated result. Note that allocSize
     * is one more than the total number of characters, and so includes
     * room for the terminating NULL byte.
     */
    
    concatStr = (char *) ckalloc((unsigned) allocSize);

    /*
     * Now concatenate the elements. Clip white space off the front and back
     * to generate a neater result, and ignore any empty elements. Also put
     * a null byte at the end.
     */

    finalSize = 0;
    if (objc == 0) {
	*concatStr = '\0';
    } else {
	p = concatStr;
        for (i = 0;  i < objc;  i++) {
	    objPtr = objv[i];
	    element = Tcl_GetStringFromObj(objPtr, &elemLength);
	    while ((elemLength > 0) && (UCHAR(*element) < 127)
		    && isspace(UCHAR(*element))) { /* INTL: ISO C space. */
	         element++;
		 elemLength--;
	    }

	    /*
	     * Trim trailing white space.  But, be careful not to trim
	     * a space character if it is preceded by a backslash: in
	     * this case it could be significant.
	     */

	    while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127)
		    && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */
		    && ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
		elemLength--;
	    }
	    if (elemLength == 0) {
	         continue;	/* nothing left of this element */
	    }
	    memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
	    p += elemLength;
	    *p = ' ';
	    p++;
	    finalSize += (elemLength + 1);
        }
        if (p != concatStr) {
	    p[-1] = 0;
	    finalSize -= 1;	/* we overwrote the final ' ' */
        } else {
	    *p = 0;
        }
    }
    
    TclNewObj(objPtr);
    objPtr->bytes  = concatStr;
    objPtr->length = finalSize;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringMatch --
 *
 *	See if a particular string matches a particular pattern.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and
 *	0 otherwise.  The matching operation permits the following
 *	special characters in the pattern: *?\[] (see the manual
 *	entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_StringMatch(string, pattern)
    CONST char *string;		/* String. */
    CONST char *pattern;	/* Pattern, which may contain special
				 * characters. */
{
    return Tcl_StringCaseMatch(string, pattern, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringCaseMatch --
 *
 *	See if a particular string matches a particular pattern.
 *	Allows case insensitivity.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and
 *	0 otherwise.  The matching operation permits the following
 *	special characters in the pattern: *?\[] (see the manual
 *	entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_StringCaseMatch(string, pattern, nocase)
    CONST char *string;		/* String. */
    CONST char *pattern;	/* Pattern, which may contain special
				 * characters. */
    int nocase;			/* 0 for case sensitive, 1 for insensitive */
{
    int p, charLen;
    CONST char *pstart = pattern;
    Tcl_UniChar ch1, ch2;
    
    while (1) {
	p = *pattern;
	
	/*
	 * See if we're at the end of both the pattern and the string.  If
	 * so, we succeeded.  If we're at the end of the pattern but not at
	 * the end of the string, we failed.
	 */
	
	if (p == '\0') {
	    return (*string == '\0');
	}
	if ((*string == '\0') && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character.  It matches
	 * any substring.  We handle this by calling ourselves
	 * recursively for each postfix of string, until either we
	 * match or we reach the end of the string.
	 */
	
	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++pattern) == '*') {}
	    p = *pattern;
	    if (p == '\0') {
		return 1;
	    }

	    /*
	     * This is a special case optimization for single-byte utf.
	     */

	    if (UCHAR(*pattern) < 0x80) {
		ch2 = (Tcl_UniChar)
		    (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
	    } else {
		Tcl_UtfToUniChar(pattern, &ch2);
		if (nocase) {
		    ch2 = Tcl_UniCharToLower(ch2);
		}

	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    if (nocase) {
			while (*string) {
			    charLen = TclUtfToUniChar(string, &ch1);
			    if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
				break;
			    }
			    string += charLen;
			}
		    } else {
			/*
			 * There's no point in trying to make this code
			 * shorter, as the number of bytes you want to
			 * compare each time is non-constant.
			 */

			while (*string) {
			    charLen = TclUtfToUniChar(string, &ch1);
			    if (ch2 == ch1) {
				break;
			    }
			    string += charLen;
			}
		    }
		}
		if (Tcl_StringCaseMatch(string, pattern, nocase)) {
		    return 1;
		}
		if (*string == '\0') {
		    return 0;
		}
		string += TclUtfToUniChar(string, &ch1);
	    }
	}

	/*
	 * Check for a "?" as the next pattern character.  It matches
	 * any single character.
	 */

	if (p == '?') {
	    pattern++;
	    string += TclUtfToUniChar(string, &ch1);
	    continue;
	}

	/*
	 * Check for a "[" as the next pattern character.  It is followed
	 * by a list of characters that are acceptable, or by a range
	 * (two characters separated by "-").
	 */

	if (p == '[') {
	    Tcl_UniChar startChar, endChar;

	    pattern++;
	    if (UCHAR(*string) < 0x80) {
		ch1 = (Tcl_UniChar)
		    (nocase ? tolower(UCHAR(*string)) : UCHAR(*string));
		string++;
	    } else {
		string += Tcl_UtfToUniChar(string, &ch1);
		if (nocase) {
		    ch1 = Tcl_UniCharToLower(ch1);
		}
	    }
	    while (1) {
		if ((*pattern == ']') || (*pattern == '\0')) {
		    return 0;







|
|



















|
|
|
|
<
|

>

>
>

|
>
>
>
>










|
|
|
|

>






>
>
>
>
>













|
|
|

|




|
|







|




|
|



|
|
|








|






|
|


|

|

|














|
|
<
|








|
|



|







|
|


|
|
<
|








|
|







|


|

|
|
|

|

|

|




|
|
|
|

|




>





>



>








>







>


|
|



|




|
|

>
|
|



|



|


|


|




|
|




|




|
|
|






|

|
|

|







1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035

1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158

1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186

1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
 *
 * Tcl_ConcatObj --
 *
 *	Concatenate the strings from a set of objects into a single string
 *	object with spaces between the original strings.
 *
 * Results:
 *	The return value is a new string object containing a concatenation of
 *	the strings in objv. Its ref count is zero.
 *
 * Side effects:
 *	A new object is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ConcatObj(objc, objv)
    int objc;			/* Number of objects to concatenate. */
    Tcl_Obj *CONST objv[];	/* Array of objects to concatenate. */
{
    int allocSize, finalSize, length, elemLength, i;
    char *p;
    char *element;
    char *concatStr;
    Tcl_Obj *objPtr;

    /*
     * Check first to see if all the items are of list type. If so, we will
     * concat them together as lists, and return a list object. This is only
     * valid when the lists have no current string representation, since we
     * don't know what the original type was. An original string rep may have

     * lost some whitespace info when converted which could be important.
     */

    for (i = 0;  i < objc;  i++) {
	List *listRepPtr;

	objPtr = objv[i];
	if (objPtr->typePtr != &tclListType) {
	    break;
	}
	listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1;
	if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) {
	    break;
	}
    }
    if (i == objc) {
	Tcl_Obj **listv;
	int listc;

	objPtr = Tcl_NewListObj(0, NULL);
	for (i = 0;  i < objc;  i++) {
	    /*
	     * Tcl_ListObjAppendList could be used here, but this saves us a
	     * bit of type checking (since we've already done it). Use of
	     * INT_MAX tells us to always put the new stuff on the end. It
	     * will be set right in Tcl_ListObjReplace.
	     */

	    Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv);
	    Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv);
	}
	return objPtr;
    }

    /*
     * Something cannot be determined to be safe, so build the concatenation
     * the slow way, using the string representations.
     */

    allocSize = 0;
    for (i = 0;  i < objc;  i++) {
	objPtr = objv[i];
	element = Tcl_GetStringFromObj(objPtr, &length);
	if ((element != NULL) && (length > 0)) {
	    allocSize += (length + 1);
	}
    }
    if (allocSize == 0) {
	allocSize = 1;		/* enough for the NULL byte at end */
    }

    /*
     * Allocate storage for the concatenated result. Note that allocSize is
     * one more than the total number of characters, and so includes room for
     * the terminating NULL byte.
     */

    concatStr = (char *) ckalloc((unsigned) allocSize);

    /*
     * Now concatenate the elements. Clip white space off the front and back
     * to generate a neater result, and ignore any empty elements. Also put a
     * null byte at the end.
     */

    finalSize = 0;
    if (objc == 0) {
	*concatStr = '\0';
    } else {
	p = concatStr;
	for (i = 0;  i < objc;  i++) {
	    objPtr = objv[i];
	    element = Tcl_GetStringFromObj(objPtr, &elemLength);
	    while ((elemLength > 0) && (UCHAR(*element) < 127)
		    && isspace(UCHAR(*element))) { /* INTL: ISO C space. */
		element++;
		elemLength--;
	    }

	    /*
	     * Trim trailing white space. But, be careful not to trim a space
	     * character if it is preceded by a backslash: in this case it
	     * could be significant.
	     */

	    while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127)
		    && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */
		    && ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
		elemLength--;
	    }
	    if (elemLength == 0) {
		continue;	/* nothing left of this element */
	    }
	    memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
	    p += elemLength;
	    *p = ' ';
	    p++;
	    finalSize += (elemLength + 1);
	}
	if (p != concatStr) {
	    p[-1] = 0;
	    finalSize -= 1;	/* we overwrote the final ' ' */
	} else {
	    *p = 0;
	}
    }

    TclNewObj(objPtr);
    objPtr->bytes  = concatStr;
    objPtr->length = finalSize;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringMatch --
 *
 *	See if a particular string matches a particular pattern.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the

 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_StringMatch(str, pattern)
    CONST char *str;		/* String. */
    CONST char *pattern;	/* Pattern, which may contain special
				 * characters. */
{
    return Tcl_StringCaseMatch(str, pattern, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringCaseMatch --
 *
 *	See if a particular string matches a particular pattern. Allows case
 *	insensitivity.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the

 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_StringCaseMatch(str, pattern, nocase)
    CONST char *str;		/* String. */
    CONST char *pattern;	/* Pattern, which may contain special
				 * characters. */
    int nocase;			/* 0 for case sensitive, 1 for insensitive */
{
    int p, charLen;
    CONST char *pstart = pattern;
    Tcl_UniChar ch1, ch2;

    while (1) {
	p = *pattern;

	/*
	 * See if we're at the end of both the pattern and the string. If so,
	 * we succeeded. If we're at the end of the pattern but not at the end
	 * of the string, we failed.
	 */

	if (p == '\0') {
	    return (*str == '\0');
	}
	if ((*str == '\0') && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by calling ourselves recursively for each
	 * postfix of string, until either we match or we reach the end of the
	 * string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++pattern) == '*') {}
	    p = *pattern;
	    if (p == '\0') {
		return 1;
	    }

	    /*
	     * This is a special case optimization for single-byte utf.
	     */

	    if (UCHAR(*pattern) < 0x80) {
		ch2 = (Tcl_UniChar)
		    (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
	    } else {
		Tcl_UtfToUniChar(pattern, &ch2);
		if (nocase) {
		    ch2 = Tcl_UniCharToLower(ch2);
		}

	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    if (nocase) {
			while (*str) {
			    charLen = TclUtfToUniChar(str, &ch1);
			    if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
				break;
			    }
			    str += charLen;
			}
		    } else {
			/*
			 * There's no point in trying to make this code
			 * shorter, as the number of bytes you want to compare
			 * each time is non-constant.
			 */

			while (*str) {
			    charLen = TclUtfToUniChar(str, &ch1);
			    if (ch2 == ch1) {
				break;
			    }
			    str += charLen;
			}
		    }
		}
		if (Tcl_StringCaseMatch(str, pattern, nocase)) {
		    return 1;
		}
		if (*str == '\0') {
		    return 0;
		}
		str += TclUtfToUniChar(str, &ch1);
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
	 * single character.
	 */

	if (p == '?') {
	    pattern++;
	    str += TclUtfToUniChar(str, &ch1);
	    continue;
	}

	/*
	 * Check for a "[" as the next pattern character. It is followed by a
	 * list of characters that are acceptable, or by a range (two
	 * characters separated by "-").
	 */

	if (p == '[') {
	    Tcl_UniChar startChar, endChar;

	    pattern++;
	    if (UCHAR(*str) < 0x80) {
		ch1 = (Tcl_UniChar)
		    (nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
		str++;
	    } else {
		str += Tcl_UtfToUniChar(str, &ch1);
		if (nocase) {
		    ch1 = Tcl_UniCharToLower(ch1);
		}
	    }
	    while (1) {
		if ((*pattern == ']') || (*pattern == '\0')) {
		    return 0;
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
		pattern++;
	    }
	    pattern++;
	    continue;
	}

	/*
	 * If the next pattern character is '\', just strip off the '\'
	 * so we do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    pattern++;
	    if (*pattern == '\0') {
		return 0;
	    }
	}

	/*
	 * There's no special character.  Just make sure that the next
	 * bytes of each string match.
	 */

	string  += TclUtfToUniChar(string, &ch1);
	pattern += TclUtfToUniChar(pattern, &ch2);
	if (nocase) {
	    if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
		return 0;
	    }
	} else if (ch1 != ch2) {
	    return 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclMatchIsTrivial --
 *
 *	Test whether a particular glob pattern is a trivial pattern.
 *	(i.e. where matching is the same as equality testing).
 *
 * Results:
 *	A boolean indicating whether the pattern is free of all of the
 *	glob special chars.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclMatchIsTrivial(pattern)
    CONST char *pattern;
{
    CONST char *p = pattern;

    while (1) {
	switch (*p++) {
	case '\0':
	    return 1;
	case '*':
	case '?':
	case '[':
	case '\\':
	    return 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringInit --
 *
 *	Initializes a dynamic string, discarding any previous contents
 *	of the string (Tcl_DStringFree should have been called already
 *	if the dynamic string was previously in use).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The dynamic string is initialized to be empty.
 *







|
|










|
|


|














<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
|
|







1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411





































1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
		pattern++;
	    }
	    pattern++;
	    continue;
	}

	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    pattern++;
	    if (*pattern == '\0') {
		return 0;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	str  += TclUtfToUniChar(str, &ch1);
	pattern += TclUtfToUniChar(pattern, &ch2);
	if (nocase) {
	    if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
		return 0;
	    }
	} else if (ch1 != ch2) {
	    return 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *





































 * Tcl_DStringInit --
 *
 *	Initializes a dynamic string, discarding any previous contents of the
 *	string (Tcl_DStringFree should have been called already if the dynamic
 *	string was previously in use).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The dynamic string is initialized to be empty.
 *
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616

1617
1618
1619
1620
1621

1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringAppend --
 *
 *	Append more characters to the current value of a dynamic string.
 *
 * Results:
 *	The return value is a pointer to the dynamic string's new value.
 *
 * Side effects:
 *	Length bytes from string (or all of string if length is less
 *	than zero) are added to the current value of the string. Memory
 *	gets reallocated if needed to accomodate the string's new size.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DStringAppend(dsPtr, string, length)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
    CONST char *string;		/* String to append.  If length is -1 then
				 * this must be null-terminated. */
    int length;			/* Number of characters from string to
				 * append.  If < 0, then append all of string,
				 * up to null at end. */
{
    int newSize;
    char *dst;
    CONST char *end;

    if (length < 0) {
	length = strlen(string);
    }
    newSize = length + dsPtr->length;

    /*
     * Allocate a larger buffer for the string if the current one isn't
     * large enough. Allocate extra space in the new buffer so that there
     * will be room to grow before we have to allocate again.
     */

    if (newSize >= dsPtr->spaceAvl) {
	dsPtr->spaceAvl = newSize * 2;
	if (dsPtr->string == dsPtr->staticSpace) {
	    char *newString;

	    newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
	    memcpy((VOID *) newString, (VOID *) dsPtr->string,
		    (size_t) dsPtr->length);
	    dsPtr->string = newString;
	} else {
	    dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
		    (size_t) dsPtr->spaceAvl);
	}
    }

    /*
     * Copy the new string into the buffer at the end of the old
     * one.
     */

    for (dst = dsPtr->string + dsPtr->length, end = string+length;
	    string < end; string++, dst++) {
	*dst = *string;
    }
    *dst = '\0';
    dsPtr->length += length;
    return dsPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringAppendElement --
 *
 *	Append a list element to the current value of a dynamic string.
 *
 * Results:
 *	The return value is a pointer to the dynamic string's new value.
 *
 * Side effects:
 *	String is reformatted as a list element and added to the current
 *	value of the string.  Memory gets reallocated if needed to
 *	accomodate the string's new size.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DStringAppendElement(dsPtr, string)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
    CONST char *string;		/* String to append.  Must be
				 * null-terminated. */
{
    int newSize, flags, strSize;
    char *dst;

    strSize = ((string == NULL) ? 0 : strlen(string));
    newSize = Tcl_ScanCountedElement(string, strSize, &flags)
	+ dsPtr->length + 1;

    /*
     * Allocate a larger buffer for the string if the current one isn't
     * large enough.  Allocate extra space in the new buffer so that there
     * will be room to grow before we have to allocate again.
     * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
     * to a larger buffer, since there may be embedded NULLs in the
     * string in some cases.
     */

    if (newSize >= dsPtr->spaceAvl) {
	dsPtr->spaceAvl = newSize * 2;
	if (dsPtr->string == dsPtr->staticSpace) {
	    char *newString;

	    newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
	    memcpy((VOID *) newString, (VOID *) dsPtr->string,
		    (size_t) dsPtr->length);
	    dsPtr->string = newString;
	} else {
	    dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
		    (size_t) dsPtr->spaceAvl);
	}
    }

    /*
     * Convert the new string to a list element and copy it into the
     * buffer at the end, with a space, if needed.
     */

    dst = dsPtr->string + dsPtr->length;
    if (TclNeedSpace(dsPtr->string, dst)) {
	*dst = ' ';
	dst++;
	dsPtr->length++;

	/*
	 * If we need a space to separate this element from preceding
	 * stuff, then this element will not lead a list, and need not
	 * have it's leading '#' quoted.
	 */

	flags |= TCL_DONT_QUOTE_HASH;
    }
    dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags);
    return dsPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringSetLength --
 *
 *	Change the length of a dynamic string.  This can cause the
 *	string to either grow or shrink, depending on the value of
 *	length.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The length of dsPtr is changed to length and a null byte is
 *	stored at that position in the string.  If length is larger
 *	than the space allocated for dsPtr, then a panic occurs.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringSetLength(dsPtr, length)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
    int length;			/* New length for dynamic string. */
{
    int newsize;

    if (length < 0) {
	length = 0;
    }
    if (length >= dsPtr->spaceAvl) {
	/*
	 * There are two interesting cases here.  In the first case, the user
	 * may be trying to allocate a large buffer of a specific size.  It
	 * would be wasteful to overallocate that buffer, so we just allocate
	 * enough for the requested size plus the trailing null byte.  In the
	 * second case, we are growing the buffer incrementally, so we need
	 * behavior similar to Tcl_DStringAppend.  The requested length will
	 * usually be a small delta above the current spaceAvl, so we'll end up
	 * doubling the old size.  This won't grow the buffer quite as quickly,
	 * but it should be close enough.
	 */

	newsize = dsPtr->spaceAvl * 2;
	if (length < newsize) {
	    dsPtr->spaceAvl = newsize;
	} else {
	    dsPtr->spaceAvl = length + 1;







|





|
|
|





|

|
|
|
|
|






|




|
|
|


















|
<


|
|
|

















|
|
|





|

|





|
|



|
|
|
|
|
<


















|
|







>

|
|
|

>


|








|
|
<





|
|
|
















|
|

|

|
|
|
|







1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495

1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543

1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590

1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringAppend --
 *
 *	Append more bytes to the current value of a dynamic string.
 *
 * Results:
 *	The return value is a pointer to the dynamic string's new value.
 *
 * Side effects:
 *	Length bytes from "bytes" (or all of "bytes" if length is less than
 *	zero) are added to the current value of the string. Memory gets
 *	reallocated if needed to accomodate the string's new size.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DStringAppend(dsPtr, bytes, length)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
    CONST char *bytes;		/* String to append. If length is -1 then this
				 * must be null-terminated. */
    int length;			/* Number of bytes from "bytes" to append. If
				 * < 0, then append all of bytes, up to null
				 * at end. */
{
    int newSize;
    char *dst;
    CONST char *end;

    if (length < 0) {
	length = strlen(bytes);
    }
    newSize = length + dsPtr->length;

    /*
     * Allocate a larger buffer for the string if the current one isn't large
     * enough. Allocate extra space in the new buffer so that there will be
     * room to grow before we have to allocate again.
     */

    if (newSize >= dsPtr->spaceAvl) {
	dsPtr->spaceAvl = newSize * 2;
	if (dsPtr->string == dsPtr->staticSpace) {
	    char *newString;

	    newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
	    memcpy((VOID *) newString, (VOID *) dsPtr->string,
		    (size_t) dsPtr->length);
	    dsPtr->string = newString;
	} else {
	    dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
		    (size_t) dsPtr->spaceAvl);
	}
    }

    /*
     * Copy the new string into the buffer at the end of the old one.

     */

    for (dst = dsPtr->string + dsPtr->length, end = bytes+length;
	    bytes < end; bytes++, dst++) {
	*dst = *bytes;
    }
    *dst = '\0';
    dsPtr->length += length;
    return dsPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringAppendElement --
 *
 *	Append a list element to the current value of a dynamic string.
 *
 * Results:
 *	The return value is a pointer to the dynamic string's new value.
 *
 * Side effects:
 *	String is reformatted as a list element and added to the current value
 *	of the string. Memory gets reallocated if needed to accomodate the
 *	string's new size.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DStringAppendElement(dsPtr, element)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
    CONST char *element;	/* String to append. Must be
				 * null-terminated. */
{
    int newSize, flags, strSize;
    char *dst;

    strSize = ((element== NULL) ? 0 : strlen(element));
    newSize = Tcl_ScanCountedElement(element, strSize, &flags)
	+ dsPtr->length + 1;

    /*
     * Allocate a larger buffer for the string if the current one isn't large
     * enough. Allocate extra space in the new buffer so that there will be
     * room to grow before we have to allocate again. SPECIAL NOTE: must use
     * memcpy, not strcpy, to copy the string to a larger buffer, since there
     * may be embedded NULLs in the string in some cases.

     */

    if (newSize >= dsPtr->spaceAvl) {
	dsPtr->spaceAvl = newSize * 2;
	if (dsPtr->string == dsPtr->staticSpace) {
	    char *newString;

	    newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
	    memcpy((VOID *) newString, (VOID *) dsPtr->string,
		    (size_t) dsPtr->length);
	    dsPtr->string = newString;
	} else {
	    dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
		    (size_t) dsPtr->spaceAvl);
	}
    }

    /*
     * Convert the new string to a list element and copy it into the buffer at
     * the end, with a space, if needed.
     */

    dst = dsPtr->string + dsPtr->length;
    if (TclNeedSpace(dsPtr->string, dst)) {
	*dst = ' ';
	dst++;
	dsPtr->length++;

	/*
	 * If we need a space to separate this element from preceding stuff,
	 * then this element will not lead a list, and need not have it's
	 * leading '#' quoted.
	 */

	flags |= TCL_DONT_QUOTE_HASH;
    }
    dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags);
    return dsPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringSetLength --
 *
 *	Change the length of a dynamic string. This can cause the string to
 *	either grow or shrink, depending on the value of length.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The length of dsPtr is changed to length and a null byte is stored at
 *	that position in the string. If length is larger than the space
 *	allocated for dsPtr, then a panic occurs.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringSetLength(dsPtr, length)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
    int length;			/* New length for dynamic string. */
{
    int newsize;

    if (length < 0) {
	length = 0;
    }
    if (length >= dsPtr->spaceAvl) {
	/*
	 * There are two interesting cases here. In the first case, the user
	 * may be trying to allocate a large buffer of a specific size. It
	 * would be wasteful to overallocate that buffer, so we just allocate
	 * enough for the requested size plus the trailing null byte. In the
	 * second case, we are growing the buffer incrementally, so we need
	 * behavior similar to Tcl_DStringAppend. The requested length will
	 * usually be a small delta above the current spaceAvl, so we'll end
	 * up doubling the old size. This won't grow the buffer quite as
	 * quickly, but it should be close enough.
	 */

	newsize = dsPtr->spaceAvl * 2;
	if (length < newsize) {
	    dsPtr->spaceAvl = newsize;
	} else {
	    dsPtr->spaceAvl = length + 1;
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708

1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringFree --
 *
 *	Frees up any memory allocated for the dynamic string and
 *	reinitializes the string to an empty state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The previous contents of the dynamic string are lost, and
 *	the new value is an empty string.
 *
 *---------------------------------------------------------------------- */


void
Tcl_DStringFree(dsPtr)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
{
    if (dsPtr->string != dsPtr->staticSpace) {
	ckfree(dsPtr->string);
    }
    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = '\0';
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringResult --
 *
 *	This procedure moves the value of a dynamic string into an
 *	interpreter as its string result. Afterwards, the dynamic string
 *	is reset to an empty string.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string is "moved" to interp's result, and any existing
 *	string result for interp is freed. dsPtr is reinitialized to
 *	an empty string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringResult(interp, dsPtr)
    Tcl_Interp *interp;		/* Interpreter whose result is to be reset. */
    Tcl_DString *dsPtr;		/* Dynamic string that is to become the
				 * result of interp. */
{
    Tcl_ResetResult(interp);
    
    if (dsPtr->string != dsPtr->staticSpace) {
	interp->result = dsPtr->string;
	interp->freeProc = TCL_DYNAMIC;
    } else if (dsPtr->length < TCL_RESULT_SIZE) {
	interp->result = ((Interp *) interp)->resultSpace;
	strcpy(interp->result, dsPtr->string);
    } else {
	Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
    }
    
    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = '\0';
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringGetResult --
 *
 *	This procedure moves an interpreter's result into a dynamic string.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter's string result is cleared, and the previous
 *	contents of dsPtr are freed.
 *
 *	If the string result is empty, the object result is moved to the
 *	string result, then the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringGetResult(interp, dsPtr)
    Tcl_Interp *interp;		/* Interpreter whose result is to be reset. */
    Tcl_DString *dsPtr;		/* Dynamic string that is to become the
				 * result of interp. */
{
    Interp *iPtr = (Interp *) interp;
    
    if (dsPtr->string != dsPtr->staticSpace) {
	ckfree(dsPtr->string);
    }

    /*
     * If the string result is empty, move the object result to the
     * string result, then reset the object result.
     */

    (void) Tcl_GetStringResult(interp);

    dsPtr->length = strlen(iPtr->result);
    if (iPtr->freeProc != NULL) {
	if (iPtr->freeProc == TCL_DYNAMIC) {







|
|





|
|

|
>



















|
|
|





|
|
<











|









|











|





|
|










|
|


|





|
|







1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693

1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringFree --
 *
 *	Frees up any memory allocated for the dynamic string and reinitializes
 *	the string to an empty state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The previous contents of the dynamic string are lost, and the new
 *	value is an empty string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringFree(dsPtr)
    Tcl_DString *dsPtr;		/* Structure describing dynamic string. */
{
    if (dsPtr->string != dsPtr->staticSpace) {
	ckfree(dsPtr->string);
    }
    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = '\0';
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringResult --
 *
 *	This function moves the value of a dynamic string into an interpreter
 *	as its string result. Afterwards, the dynamic string is reset to an
 *	empty string.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string is "moved" to interp's result, and any existing string
 *	result for interp is freed. dsPtr is reinitialized to an empty string.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringResult(interp, dsPtr)
    Tcl_Interp *interp;		/* Interpreter whose result is to be reset. */
    Tcl_DString *dsPtr;		/* Dynamic string that is to become the
				 * result of interp. */
{
    Tcl_ResetResult(interp);

    if (dsPtr->string != dsPtr->staticSpace) {
	interp->result = dsPtr->string;
	interp->freeProc = TCL_DYNAMIC;
    } else if (dsPtr->length < TCL_RESULT_SIZE) {
	interp->result = ((Interp *) interp)->resultSpace;
	strcpy(interp->result, dsPtr->string);
    } else {
	Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
    }

    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = '\0';
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringGetResult --
 *
 *	This function moves an interpreter's result into a dynamic string.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter's string result is cleared, and the previous contents
 *	of dsPtr are freed.
 *
 *	If the string result is empty, the object result is moved to the
 *	string result, then the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringGetResult(interp, dsPtr)
    Tcl_Interp *interp;		/* Interpreter whose result is to be reset. */
    Tcl_DString *dsPtr;		/* Dynamic string that is to become the result
				 * of interp. */
{
    Interp *iPtr = (Interp *) interp;

    if (dsPtr->string != dsPtr->staticSpace) {
	ckfree(dsPtr->string);
    }

    /*
     * If the string result is empty, move the object result to the string
     * result, then reset the object result.
     */

    (void) Tcl_GetStringResult(interp);

    dsPtr->length = strlen(iPtr->result);
    if (iPtr->freeProc != NULL) {
	if (iPtr->freeProc == TCL_DYNAMIC) {
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918



1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931





























































































1932
1933
1934
1935
1936
1937
1938
1939
1940
1941





1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979

1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068

2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258

2259
2260
2261
2262
2263























































2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337


2338
2339

2340
2341
2342
2343
2344
2345





2346
2347
2348
2349








2350
2351



2352

2353
2354


2355





2356
2357
2358
2359

2360
2361

2362
2363
2364
2365
2366

2367
2368

2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
	    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
	} else {
	    dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
	    dsPtr->spaceAvl = dsPtr->length + 1;
	}
	strcpy(dsPtr->string, iPtr->result);
    }
    
    iPtr->result = iPtr->resultSpace;
    iPtr->resultSpace[0] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringStartSublist --
 *
 *	This procedure adds the necessary information to a dynamic
 *	string (e.g. " {" to start a sublist.  Future element
 *	appends will be in the sublist rather than the main list.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Characters get added to the dynamic string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringStartSublist(dsPtr)
    Tcl_DString *dsPtr;			/* Dynamic string. */
{
    if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
	Tcl_DStringAppend(dsPtr, " {", -1);
    } else {
	Tcl_DStringAppend(dsPtr, "{", -1);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringEndSublist --
 *
 *	This procedure adds the necessary characters to a dynamic
 *	string to end a sublist (e.g. "}").  Future element appends
 *	will be in the enclosing (sub)list rather than the current
 *	sublist.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringEndSublist(dsPtr)
    Tcl_DString *dsPtr;			/* Dynamic string. */
{
    Tcl_DStringAppend(dsPtr, "}", -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PrintDouble --
 *
 *	Given a floating-point value, this procedure converts it to
 *	an ASCII string using.
 *
 * Results:
 *	The ASCII equivalent of "value" is written at "dst".  It is
 *	written using the current precision, and it is guaranteed to
 *	contain a decimal point or exponent, so that it looks like
 *	a floating-point value and not an integer.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PrintDouble(interp, value, dst)
    Tcl_Interp *interp;			/* Interpreter whose tcl_precision
					 * variable used to be used to control
					 * printing.  It's ignored now. */
    double value;			/* Value to print as string. */
    char *dst;				/* Where to store converted value;
					 * must have at least TCL_DOUBLE_SPACE
					 * characters. */
{
    char *p, c;



    Tcl_UniChar ch;

    Tcl_MutexLock(&precisionMutex);
    sprintf(dst, precisionFormat, value);
    Tcl_MutexUnlock(&precisionMutex);

    /*
     * If the ASCII result looks like an integer, add ".0" so that it
     * doesn't look like an integer anymore.  This prevents floating-point
     * values from being converted to integers unintentionally.
     * Check for ASCII specifically to speed up the function.
     */






























































































    for (p = dst; *p != 0; ) {
	if (UCHAR(*p) < 0x80) {
	    c = *p++;
	} else {
	    p += Tcl_UtfToUniChar(p, &ch);
	    c = UCHAR(ch);
	}
	if ((c == '.') || isalpha(UCHAR(c))) {	/* INTL: ISO only. */
	    return;
	}





    }
    p[0] = '.';
    p[1] = '0';
    p[2] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPrecTraceProc --
 *
 *	This procedure is invoked whenever the variable "tcl_precision"
 *	is written.
 *
 * Results:
 *	Returns NULL if all went well, or an error message if the
 *	new value for the variable doesn't make sense.
 *
 * Side effects:
 *	If the new value doesn't make sense then this procedure
 *	undoes the effect of the variable modification.  Otherwise
 *	it modifies the format string that's used by Tcl_PrintDouble.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    CONST char *value;
    char *end;
    int prec;


    /*
     * If the variable is unset, then recreate the trace.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
	    Tcl_TraceVar2(interp, name1, name2,
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
		    |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
	}
	return (char *) NULL;
    }

    /*
     * When the variable is read, reset its value from our shared
     * value.  This is needed in case the variable was modified in
     * some other interpreter so that this interpreter's value is
     * out of date.
     */

    Tcl_MutexLock(&precisionMutex);

    if (flags & TCL_TRACE_READS) {
	Tcl_SetVar2(interp, name1, name2, precisionString,
		flags & TCL_GLOBAL_ONLY);
	Tcl_MutexUnlock(&precisionMutex);
	return (char *) NULL;
    }

    /*
     * The variable is being written.  Check the new value and disallow
     * it if it isn't reasonable or if this is a safe interpreter (we
     * don't want safe interpreters messing up the precision of other
     * interpreters).
     */

    if (Tcl_IsSafe(interp)) {
	Tcl_SetVar2(interp, name1, name2, precisionString,
		flags & TCL_GLOBAL_ONLY);
	Tcl_MutexUnlock(&precisionMutex);
	return "can't modify precision from a safe interpreter";
    }
    value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL) {
	value = "";
    }
    prec = strtoul(value, &end, 10);
    if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
	    (end == value) || (*end != 0)) {
	Tcl_SetVar2(interp, name1, name2, precisionString,
		flags & TCL_GLOBAL_ONLY);
	Tcl_MutexUnlock(&precisionMutex);
	return "improper value for precision";
    }
    TclFormatInt(precisionString, prec);
    sprintf(precisionFormat, "%%.%dg", prec);
    Tcl_MutexUnlock(&precisionMutex);
    return (char *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNeedSpace --
 *
 *	This procedure checks to see whether it is appropriate to
 *	add a space before appending a new list element to an
 *	existing string.
 *
 * Results:
 *	The return value is 1 if a space is appropriate, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclNeedSpace(start, end)
    CONST char *start;		/* First character in string. */
    CONST char *end;		/* End of string (place where space will
				 * be added, if appropriate). */
{
    /*
     * A space is needed unless either
     * (a) we're at the start of the string, or
     */

    if (end == start) {
	return 0;
    }

    /*
     * (b) we're at the start of a nested list-element, quoted with an
     *     open curly brace; we can be nested arbitrarily deep, so long
     *     as the first curly brace starts an element, so backtrack over
     *     open curly braces that are trailing characters of the string; and
     */

    end = Tcl_UtfPrev(end, start);
    while (*end == '{') {
	if (end == start) {
	    return 0;
	}
	end = Tcl_UtfPrev(end, start);
    }

    /*
     * (c) the trailing character of the string is already a list-element
     *     separator (according to TclFindElement); that is, one of these
     *     characters:
     *     	\u0009	\t	TAB
     *     	\u000A	\n	NEWLINE
     *     	\u000B	\v	VERTICAL TAB
     *     	\u000C	\f	FORM FEED
     *     	\u000D	\r	CARRIAGE RETURN
     *     	\u0020		SPACE
     *     with the condition that the penultimate character is not a
     *     backslash.
     */

    if (*end > 0x20) {
	/*
	 * Performance tweak.  All ASCII spaces are <= 0x20. So get
	 * a quick answer for most characters before comparing against
	 * all spaces in the switch below.
	 *
	 * NOTE: Remove this if other Unicode spaces ever get accepted
	 * as list-element separators.
	 */
	return 1;
    }
    switch (*end) {
	case ' ':
        case '\t':
        case '\n':
        case '\r':
        case '\v':
        case '\f':
	    if ((end == start) || (end[-1] != '\\')) {
		return 0;
	    }
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatInt --
 *
 *	This procedure formats an integer into a sequence of decimal digit
 *	characters in a buffer. If the integer is negative, a minus sign is
 *	inserted at the start of the buffer. A null character is inserted at
 *	the end of the formatted characters. It is the caller's
 *	responsibility to ensure that enough storage is available. This
 *	procedure has the effect of sprintf(buffer, "%d", n) but is faster.
 *
 * Results:
 *	An integer representing the number of characters formatted, not
 *	including the terminating \0.
 *
 * Side effects:
 *	The formatted characters are written into the storage pointer to
 *	by the "buffer" argument.
 *
 *----------------------------------------------------------------------
 */

int
TclFormatInt(buffer, n)
    char *buffer;		/* Points to the storage into which the
				 * formatted characters are written. */
    long n;			/* The integer to format. */
{
    long intVal;
    int i;
    int numFormatted, j;
    char *digits = "0123456789";

    /*
     * Check first whether "n" is zero.
     */

    if (n == 0) {
	buffer[0] = '0';
	buffer[1] = 0;
	return 1;
    }

    /*
     * Check whether "n" is the maximum negative value. This is
     * -2^(m-1) for an m-bit word, and has no positive equivalent;
     * negating it produces the same value.
     */

    if (n == -n) {
	sprintf(buffer, "%ld", n);
	return strlen(buffer);
    }

    /*
     * Generate the characters of the result backwards in the buffer.
     */

    intVal = (n < 0? -n : n);
    i = 0;
    buffer[0] = '\0';
    do {
	i++;
	buffer[i] = digits[intVal % 10];
	intVal = intVal/10;
    } while (intVal > 0);
    if (n < 0) {
	i++;
	buffer[i] = '-';
    }
    numFormatted = i;

    /*
     * Now reverse the characters.
     */

    for (j = 0;  j < i;  j++, i--) {
	char tmp = buffer[i];
	buffer[i] = buffer[j];
	buffer[j] = tmp;
    }
    return numFormatted;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLooksLikeInt --
 *
 *	This procedure decides whether the leading characters of a
 *	string look like an integer or something else (such as a
 *	floating-point number or string).
 *
 * Results:
 *	The return value is 1 if the leading characters of p look
 *	like a valid Tcl integer.  If they look like a floating-point
 *	number (e.g. "e01" or "2.4"), or if they don't look like a
 *	number at all, then 0 is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclLooksLikeInt(bytes, length)
    register CONST char *bytes;	/* Points to first byte of the string. */
    int length;			/* Number of bytes in the string. If < 0
				 * bytes up to the first null byte are
				 * considered (if they may appear in an 
				 * integer). */
{
    register CONST char *p;

    if ((bytes == NULL) && (length > 0)) {
	Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
    }

    if (length < 0) {
        length = (bytes? strlen(bytes) : 0);
    }

    p = bytes;
    while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
	length--; p++;
    }
    if (length == 0) {
        return 0;
    }
    if ((*p == '+') || (*p == '-')) {

        p++; length--;
    }

    return (0 != TclParseInteger(p, length));
}
























































/*
 *----------------------------------------------------------------------
 *
 * TclGetIntForIndex --
 *
 *	This procedure returns an integer corresponding to the list index
 *	held in a Tcl object. The Tcl object's value is expected to be
 *	either an integer or a string of the form "end([+-]integer)?". 
 *
 * Results:
 *	The return value is normally TCL_OK, which means that the index was
 *	successfully stored into the location referenced by "indexPtr".  If
 *	the Tcl object referenced by "objPtr" has the value "end", the
 *	value stored is "endValue". If "objPtr"s values is not of the form
 *	"end([+-]integer)?" and
 *	can not be converted to an integer, TCL_ERROR is returned and, if
 *	"interp" is non-NULL, an error message is left in the interpreter's
 *	result object.
 *
 * Side effects:
 *	The object referenced by "objPtr" might be converted to an
 *	integer, wide integer, or end-based-index object.
 *
 *----------------------------------------------------------------------
 */

int
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. 
				 * If NULL, then no error message is left
				 * after errors. */
    Tcl_Obj *objPtr;		/* Points to an object containing either
				 * "end" or an integer. */
    int endValue;		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */
    int *indexPtr;		/* Location filled in with an integer
				 * representing an index. */
{
    char *bytes;
    int offset;
    Tcl_WideInt wideOffset;

    /*
     * If the object is already an integer, use it.
     */

    if (objPtr->typePtr == &tclIntType) {
	*indexPtr = (int)objPtr->internalRep.longValue;
	return TCL_OK;
    }

    /*
     * If the object is already a wide-int, and it is not out of range
     * for an integer, use it. [Bug #526717]
     */
    if (objPtr->typePtr == &tclWideIntType) {
	TclGetWide(wideOffset,objPtr);
	if (wideOffset >= Tcl_LongAsWide(INT_MIN)
	    && wideOffset <= Tcl_LongAsWide(INT_MAX)) {
	    *indexPtr = (int) Tcl_WideAsLong(wideOffset);
	    return TCL_OK;
	}
    }

    if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
	/*
	 * If the object is already an offset from the end of the
	 * list, or can be converted to one, use it.
	 */

	*indexPtr = endValue + objPtr->internalRep.longValue;

    } else if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideOffset) == TCL_OK) {


	/*
	 * If the object can be converted to a wide integer, use

	 * that. [Bug #526717]
	 */

	offset = (int) Tcl_WideAsLong(wideOffset);
	if (Tcl_LongAsWide(offset) == wideOffset) {
	    /*





	     * But it is representable as a narrow integer, so we
	     * prefer that (so preserving old behaviour in the
	     * majority of cases.)
	     */








	    objPtr->typePtr = &tclIntType;
	    objPtr->internalRep.longValue = offset;



	}

	*indexPtr = offset;



    } else {





	/*
	 * Report a parse error.
	 */


	if (interp != NULL) {
	    bytes = Tcl_GetString(objPtr);

	    /*
	     * The result might not be empty; this resets it which
	     * should be both a cheap operation, and of little problem
	     * because this is an error-generation path anyway.
	     */

	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad index \"", bytes,

		    "\": must be integer or end?-integer?", (char *) NULL);
	    if (!strncmp(bytes, "end-", 3)) {
		bytes += 3;
	    }
	    TclCheckBadOctal(interp, bytes);
	}

	return TCL_ERROR;
    }
	    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfEndOffset --
 *
 *	Update the string rep of a Tcl object holding an "end-offset"
 *	expression.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores a valid string in the object's string rep.
 *
 * This procedure does NOT free any earlier string rep.  If it is
 * called on an object that already has a valid string rep, it will
 * leak memory.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfEndOffset(objPtr)
    register Tcl_Obj* objPtr;







|









|
|
|












|













|
|
|
<












|









|
|


|
|
|
|









|
|
|
|
|
|
<


>
>
>


|
<
<


|
|
|
|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>

<
<
<







|
|


|
|


|
|
|













|
<

>















|
|
|
<


<


|

<




|
|
|
<



<
<
<


|
|
<
<
|
|
<
<
<
<


<
<
|








|
|
<













|
|


|


>





|
|
|
|












|
|
|
|
|
|
|
|
|
|




|
|
|

|
|




|
|
|
|
|
|
|
|
|



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






|
|
|


|
|
|
|










|
|
|
<








|







|


>
|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|
|



|
|
|
<
|
|
<


|
|






|
|
|
|
|





<
<
<
|
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<




|
|




|
>
>
|
|
>
|
<
|
<
|
<
>
>
>
>
>
|
<
|
<
>
>
>
>
>
>
>
>
|
|
>
>
>
|
>
|
|
>
>
|
>
>
>
>
>




>

|
>

|
|
|

>


>
|








|

















|
|
<







1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824

1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869

1870
1871
1872
1873
1874
1875
1876
1877


1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994



1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026

2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046

2047
2048

2049
2050
2051
2052

2053
2054
2055
2056
2057
2058
2059

2060
2061
2062



2063
2064
2065
2066


2067
2068




2069
2070


2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081

2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159




































































2160
















2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188

2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283

2284
2285

2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305



2306






2307













2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324

2325

2326

2327
2328
2329
2330
2331
2332

2333

2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404

2405
2406
2407
2408
2409
2410
2411
	    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
	} else {
	    dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
	    dsPtr->spaceAvl = dsPtr->length + 1;
	}
	strcpy(dsPtr->string, iPtr->result);
    }

    iPtr->result = iPtr->resultSpace;
    iPtr->resultSpace[0] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringStartSublist --
 *
 *	This function adds the necessary information to a dynamic string
 *	(e.g. " {") to start a sublist. Future element appends will be in the
 *	sublist rather than the main list.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Characters get added to the dynamic string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringStartSublist(dsPtr)
    Tcl_DString *dsPtr;		/* Dynamic string. */
{
    if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
	Tcl_DStringAppend(dsPtr, " {", -1);
    } else {
	Tcl_DStringAppend(dsPtr, "{", -1);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringEndSublist --
 *
 *	This function adds the necessary characters to a dynamic string to end
 *	a sublist (e.g. "}"). Future element appends will be in the enclosing
 *	(sub)list rather than the current sublist.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringEndSublist(dsPtr)
    Tcl_DString *dsPtr;		/* Dynamic string. */
{
    Tcl_DStringAppend(dsPtr, "}", -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PrintDouble --
 *
 *	Given a floating-point value, this function converts it to an ASCII
 *	string using.
 *
 * Results:
 *	The ASCII equivalent of "value" is written at "dst". It is written
 *	using the current precision, and it is guaranteed to contain a decimal
 *	point or exponent, so that it looks like a floating-point value and
 *	not an integer.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PrintDouble(interp, value, dst)
    Tcl_Interp *interp;		/* Interpreter whose tcl_precision variable
				 * used to be used to control printing. It's
				 * ignored now. */
    double value;		/* Value to print as string. */
    char *dst;			/* Where to store converted value; must have
				 * at least TCL_DOUBLE_SPACE characters. */

{
    char *p, c;
    int exp;
    int signum;
    char buffer[TCL_DOUBLE_SPACE];
    Tcl_UniChar ch;

    int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int));



    /*
     * If *precisionPtr == 0, then use TclDoubleDigits to develop a decimal
     * significand and exponent, then format it in E or F format as
     * appropriate.  If *precisionPtr != 0, use the native sprintf and then
     * add a trailing ".0" if there is no decimal point in the rep.
     */

    if ( *precisionPtr == 0 ) {
	/*
	 * Handle NaN.
	 */

	if (TclIsNaN(value)) {
	    TclFormatNaN(value, dst);
	    return;
	}

	/*
	 * Handle infinities.
	 */

	if (TclIsInfinite(value)) {
	    if (value < 0) {
		strcpy(dst, "-Inf");
	    } else {
		strcpy(dst, "Inf");
	    }
	    return;
	}

	/*
	 * Ordinary (normal and denormal) values.
	 */

	exp = TclDoubleDigits(buffer, value, &signum);
	if (signum) {
	    *dst++ = '-';
	}
	p = buffer;
	if (exp < -3 || exp > 17) {
	    /*
	     * E format for numbers < 1e-3 or >= 1e17.
	     */

	    *dst++ = *p++;
	    c = *p;
	    if (c != '\0') {
		*dst++ = '.';
		while (c != '\0') {
		    *dst++ = c;
		    c = *++p;
		}
	    }
	    sprintf(dst, "e%+d", exp-1);
	} else {
	    /*
	     * F format for others.
	     */

	    if (exp <= 0) {
		*dst++ = '0';
	    }
	    c = *p;
	    while (exp-- > 0) {
		if (c != '\0') {
		    *dst++ = c;
		    c = *++p;
		} else {
		    *dst++ = '0';
		}
	    }
	    *dst++ = '.';
	    if (c == '\0') {
		*dst++ = '0';
	    } else {
		while (++exp < 0) {
		    *dst++ = '0';
		}
		while (c != '\0') {
		    *dst++ = c;
		    c = *++p;
		}
	    }
	    *dst++ = '\0';
	}

    } else {
	/*
	 * tcl_precision is supplied, pass it to the native sprintf.
	 */

	sprintf(dst, "%.*g", *precisionPtr, value);

	/*
	 * If the ASCII result looks like an integer, add ".0" so that it
	 * doesn't look like an integer anymore. This prevents floating-point
	 * values from being converted to integers unintentionally.  Check for
	 * ASCII specifically to speed up the function.
	 */

	for (p = dst; *p != 0; ) {
	    if (UCHAR(*p) < 0x80) {
		c = *p++;
	    } else {
		p += Tcl_UtfToUniChar(p, &ch);
		c = UCHAR(ch);
	    }
	    if ((c == '.') || isalpha(UCHAR(c))) {	/* INTL: ISO only. */
		return;
	    }
	}
	p[0] = '.';
	p[1] = '0';
	p[2] = 0;

    }



}

/*
 *----------------------------------------------------------------------
 *
 * TclPrecTraceProc --
 *
 *	This function is invoked whenever the variable "tcl_precision" is
 *	written.
 *
 * Results:
 *	Returns NULL if all went well, or an error message if the new value
 *	for the variable doesn't make sense.
 *
 * Side effects:
 *	If the new value doesn't make sense then this function undoes the
 *	effect of the variable modification. Otherwise it modifies the format
 *	string that's used by Tcl_PrintDouble.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    Tcl_Obj* value;

    int prec;
    int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int));

    /*
     * If the variable is unset, then recreate the trace.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
	    Tcl_TraceVar2(interp, name1, name2,
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
		    |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
	}
	return (char *) NULL;
    }

    /*
     * When the variable is read, reset its value from our shared value. This
     * is needed in case the variable was modified in some other interpreter
     * so that this interpreter's value is out of date.

     */



    if (flags & TCL_TRACE_READS) {
	Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr),
		flags & TCL_GLOBAL_ONLY);

	return (char *) NULL;
    }

    /*
     * The variable is being written. Check the new value and disallow it if
     * it isn't reasonable or if this is a safe interpreter (we don't want
     * safe interpreters messing up the precision of other interpreters).

     */

    if (Tcl_IsSafe(interp)) {



	return "can't modify precision from a safe interpreter";
    }
    value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL


	    || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK
	    || prec < 0 || prec > TCL_MAX_PREC) {




	return "improper value for precision";
    }


    *precisionPtr = prec;
    return (char *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNeedSpace --
 *
 *	This function checks to see whether it is appropriate to add a space
 *	before appending a new list element to an existing string.

 *
 * Results:
 *	The return value is 1 if a space is appropriate, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclNeedSpace(start, end)
    CONST char *start;		/* First character in string. */
    CONST char *end;		/* End of string (place where space will be
				 * added, if appropriate). */
{
    /*
     * A space is needed unless either:
     * (a) we're at the start of the string, or
     */

    if (end == start) {
	return 0;
    }

    /*
     * (b) we're at the start of a nested list-element, quoted with an open
     *	   curly brace; we can be nested arbitrarily deep, so long as the
     *	   first curly brace starts an element, so backtrack over open curly
     *	   braces that are trailing characters of the string; and
     */

    end = Tcl_UtfPrev(end, start);
    while (*end == '{') {
	if (end == start) {
	    return 0;
	}
	end = Tcl_UtfPrev(end, start);
    }

    /*
     * (c) the trailing character of the string is already a list-element
     *	   separator (according to TclFindElement); that is, one of these
     *	   characters:
     *		\u0009	\t	TAB
     *		\u000A	\n	NEWLINE
     *		\u000B	\v	VERTICAL TAB
     *		\u000C	\f	FORM FEED
     *		\u000D	\r	CARRIAGE RETURN
     *		\u0020		SPACE
     *	   with the condition that the penultimate character is not a
     *	   backslash.
     */

    if (*end > 0x20) {
	/*
	 * Performance tweak. All ASCII spaces are <= 0x20. So get a quick
	 * answer for most characters before comparing against all spaces in
	 * the switch below.
	 *
	 * NOTE: Remove this if other Unicode spaces ever get accepted as
	 * list-element separators.
	 */
	return 1;
    }
    switch (*end) {
    case ' ':
    case '\t':
    case '\n':
    case '\r':
    case '\v':
    case '\f':
	if ((end == start) || (end[-1] != '\\')) {
	    return 0;
	}
    }
    return 1;
}




































































#if 0

















/*
 *----------------------------------------------------------------------
 *
 * TclLooksLikeInt --
 *
 *	This function decides whether the leading characters of a string look
 *	like an integer or something else (such as a floating-point number or
 *	string).
 *
 * Results:
 *	The return value is 1 if the leading characters of p look like a valid
 *	Tcl integer. If they look like a floating-point number (e.g. "e01" or
 *	"2.4"), or if they don't look like a number at all, then 0 is
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclLooksLikeInt(bytes, length)
    register CONST char *bytes;	/* Points to first byte of the string. */
    int length;			/* Number of bytes in the string. If < 0 bytes
				 * up to the first null byte are considered
				 * (if they may appear in an integer). */

{
    register CONST char *p;

    if ((bytes == NULL) && (length > 0)) {
	Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
    }

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }

    p = bytes;
    while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
	length--; p++;
    }
    if (length == 0) {
	return 0;
    }
    if ((*p == '+') || (*p == '-')) {
	p++;
	length--;
    }

    return (0 != TclParseInteger(p, length));
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * ParseInteger --
 *
 *	Scans up to numBytes bytes starting at bytes, and checks whether the
 *	leading bytes look like an integer's string representation.
 *
 * Results:
 *	Returns 0 if the leading bytes do not look like an integer.
 *	Otherwise, returns the number of bytes examined that look like an
 *	integer.  This may be less than numBytes if the integer is only the
 *	leading part of the string.     
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseInteger(bytes, numBytes)
    CONST char *bytes;	/* The string to examine. */
    int numBytes;	/* Max number of bytes to scan. */
{
    register CONST char *p = bytes;

    /* Take care of introductory "0x". */
    if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
	int scanned;
	Tcl_UniChar ch;

	p += 2;
	numBytes -= 2;
	scanned = TclParseHex(p, numBytes, &ch);
	if (scanned) {
	    return scanned+2;
	}

	/* Recognize the 0 as valid integer, but x is left behind. */
	return 1;
    }
    while (numBytes && isdigit(UCHAR(*p))) {            /* INTL: digit */
	numBytes--; p++;
    }
    if (numBytes == 0) {
	return (p - bytes);
    }
    if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
	return (p - bytes);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetIntForIndex --
 *
 *	This function returns an integer corresponding to the list index held
 *	in a Tcl object. The Tcl object's value is expected to be in the
 *	format integer([+-]integer)? or the format end([+-]integer)?.
 *
 * Results:
 *	The return value is normally TCL_OK, which means that the index was
 *	successfully stored into the location referenced by "indexPtr". If the
 *	Tcl object referenced by "objPtr" has the value "end", the value
 *	stored is "endValue". If "objPtr"s values is not of one of the

 *	expected formats, TCL_ERROR is returned and, if "interp" is non-NULL,
 *	an error message is left in the interpreter's result object.

 *
 * Side effects:
 *	The object referenced by "objPtr" might be converted to an integer,
 *	wide integer, or end-based-index object.
 *
 *----------------------------------------------------------------------
 */

int
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    Tcl_Obj *objPtr;		/* Points to an object containing either "end"
				 * or an integer. */
    int endValue;		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */
    int *indexPtr;		/* Location filled in with an integer
				 * representing an index. */
{



    if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {






	return TCL_OK;













    }

    if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
	/*
	 * If the object is already an offset from the end of the list, or can
	 * be converted to one, use it.
	 */

	*indexPtr = endValue + objPtr->internalRep.longValue;

    } else {
	int opIdx, length;
	char *bytes = Tcl_GetStringFromObj(objPtr, &length);
	char *p = bytes;

	while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
	    length--; p++;

	}

	if (length == 0) {

	    goto parseError;
	}
	if ((*p == '+') || (*p == '-')) {
	    p++; length--;
	}
	opIdx = ParseInteger(p, length) + (int) (p-bytes);

	if (opIdx) {

	    int code, first, second;
	    char savedOp = bytes[opIdx];
	    if ((savedOp != '+') && (savedOp != '-')) {
		goto parseError;
	    }
	    if (isspace(UCHAR(bytes[opIdx+1]))) {
		goto parseError;
	    }
	    bytes[opIdx] = '\0';
	    code = Tcl_GetInt(interp, bytes, &first);
	    bytes[opIdx] = savedOp;
	    if (code == TCL_ERROR)  {
		goto parseError;
	    }
	    if (TCL_ERROR == Tcl_GetInt(interp, bytes+opIdx+1, &second))  {
		goto parseError;
	    }
	    if (savedOp == '+') {
		*indexPtr = first + second;
	    } else {
		*indexPtr = first - second;
	    }
	    return TCL_OK;
	}

	/*
	 * Report a parse error.
	 */

    parseError:
	if (interp != NULL) {
	    char *bytes = Tcl_GetString(objPtr);

	    /*
	     * The result might not be empty; this resets it which should be
	     * both a cheap operation, and of little problem because this is
	     * an error-generation path anyway.
	     */

	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad index \"", bytes,
		    "\": must be integer?[+-]integer? or end?[+-]integer?",
		    (char *) NULL);
	    if (!strncmp(bytes, "end-", 3)) {
		bytes += 3;
	    }
	    TclCheckBadOctal(interp, bytes);
	}

	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfEndOffset --
 *
 *	Update the string rep of a Tcl object holding an "end-offset"
 *	expression.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores a valid string in the object's string rep.
 *
 * This function does NOT free any earlier string rep. If it is called on an
 * object that already has a valid string rep, it will leak memory.

 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfEndOffset(objPtr)
    register Tcl_Obj* objPtr;
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447

2448

2449
2450
2451
2452
2453

2454

2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466

2467

2468
2469
2470
2471
2472
2473
2474
2475




2476
2477
2478

2479

2480
2481
2482
2483

2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548

2549


2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567

2568
2569
2570
2571
2572
2573
2574
}

/*
 *----------------------------------------------------------------------
 *
 * SetEndOffsetFromAny --
 *
 *	Look for a string of the form "end-offset" and convert it
 *	to an internal representation holding the offset.
 *
 * Results:
 *	Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
 *
 * Side effects:
 *	If interp is not NULL, stores an error message in the
 *	interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
SetEndOffsetFromAny(interp, objPtr)
     Tcl_Interp* interp;	/* Tcl interpreter or NULL */
     Tcl_Obj* objPtr;		/* Pointer to the object to parse */
{
    int offset;			/* Offset in the "end-offset" expression */
    register char* bytes;	/* String rep of the object */
    int length;			/* Length of the object's string rep */


    /* If it's already the right type, we're fine. */


    if (objPtr->typePtr == &tclEndOffsetType) {
	return TCL_OK;
    }


    /* Check for a string rep of the right form. */


    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
	    (size_t)((length > 3) ? 3 : length)) != 0)) {
	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad index \"", bytes,
		    "\": must be end?-integer?", (char*) NULL);
	}
	return TCL_ERROR;
    }


    /* Convert the string rep */


    if (length <= 3) {
	offset = 0;
    } else if ((length > 4) && (bytes[3] == '-')) {
	/*
	 * This is our limited string expression evaluator.  Pass everything
	 * after "end-" to Tcl_GetInt, then reverse for offset.
	 */




	if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
	    return TCL_ERROR;
	}

	offset = -offset;

    } else {
	/*
	 * Conversion failed.  Report the error.
	 */

	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad index \"", bytes,
		    "\": must be integer or end?-integer?", (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * The conversion succeeded. Free the old internal rep and set
     * the new one.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = offset;
    objPtr->typePtr = &tclEndOffsetType;

    return TCL_OK;
}    

/*
 *----------------------------------------------------------------------
 *
 * TclCheckBadOctal --
 *
 *	This procedure checks for a bad octal value and appends a
 *	meaningful error to the interp's result.
 *
 * Results:
 *	1 if the argument was a bad octal, else 0.
 *
 * Side effects:
 *	The interpreter's result is modified.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckBadOctal(interp, value)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. 
				 * If NULL, then no error message is left
				 * after errors. */
    CONST char *value;		/* String to check. */
{
    register CONST char *p = value;

    /*
     * A frequent mistake is invalid octal values due to an unwanted
     * leading zero. Try to generate a meaningful error message.
     */

    while (isspace(UCHAR(*p))) {	/* INTL: ISO space. */
	p++;
    }
    if (*p == '+' || *p == '-') {
	p++;
    }
    if (*p == '0') {
	while (isdigit(UCHAR(*p))) {	/* INTL: digit. */
	    p++;
	}
	while (isspace(UCHAR(*p))) {	/* INTL: ISO space. */
	    p++;
	}
	if (*p == '\0') {

	    /* Reached end of string */


	    if (interp != NULL) {
		/*
		 * Don't reset the result here because we want this result
		 * to be added to an existing error message as extra info.
		 */
		Tcl_AppendResult(interp, " (looks like invalid octal number)",
			(char *) NULL);
	    }
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ClearHash --

 *      Remove all the entries in the hash table *tablePtr.
 *
 *----------------------------------------------------------------------
 */

static void
ClearHash(tablePtr)







|
|





|
|






|
|





>
|
>





>
|
>







|




>
|
>



|

|


>
>
>
>



>
|
>


|

>



|





|
|







|






|
|












|
|
|





|
|
















>
|
>
>


|
|














>







2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
}

/*
 *----------------------------------------------------------------------
 *
 * SetEndOffsetFromAny --
 *
 *	Look for a string of the form "end[+-]offset" and convert it to an
 *	internal representation holding the offset.
 *
 * Results:
 *	Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
 *
 * Side effects:
 *	If interp is not NULL, stores an error message in the interpreter
 *	result.
 *
 *----------------------------------------------------------------------
 */

static int
SetEndOffsetFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Tcl interpreter or NULL */
    Tcl_Obj* objPtr;		/* Pointer to the object to parse */
{
    int offset;			/* Offset in the "end-offset" expression */
    register char* bytes;	/* String rep of the object */
    int length;			/* Length of the object's string rep */

    /*
     * If it's already the right type, we're fine.
     */

    if (objPtr->typePtr == &tclEndOffsetType) {
	return TCL_OK;
    }

    /*
     * Check for a string rep of the right form.
     */

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
	    (size_t)((length > 3) ? 3 : length)) != 0)) {
	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad index \"", bytes,
		    "\": must be end?[+-]integer?", (char*) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Convert the string rep.
     */

    if (length <= 3) {
	offset = 0;
    } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
	/*
	 * This is our limited string expression evaluator. Pass everything
	 * after "end-" to Tcl_GetInt, then reverse for offset.
	 */

	if (isspace(UCHAR(bytes[4]))) {
	    return TCL_ERROR;
	}
	if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (bytes[3] == '-') {
	    offset = -offset;
	}
    } else {
	/*
	 * Conversion failed. Report the error.
	 */

	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad index \"", bytes,
		    "\": must be end?[+-]integer?", (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * The conversion succeeded. Free the old internal rep and set the new
     * one.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.longValue = offset;
    objPtr->typePtr = &tclEndOffsetType;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckBadOctal --
 *
 *	This function checks for a bad octal value and appends a meaningful
 *	error to the interp's result.
 *
 * Results:
 *	1 if the argument was a bad octal, else 0.
 *
 * Side effects:
 *	The interpreter's result is modified.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckBadOctal(interp, value)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    CONST char *value;		/* String to check. */
{
    register CONST char *p = value;

    /*
     * A frequent mistake is invalid octal values due to an unwanted leading
     * zero. Try to generate a meaningful error message.
     */

    while (isspace(UCHAR(*p))) {	/* INTL: ISO space. */
	p++;
    }
    if (*p == '+' || *p == '-') {
	p++;
    }
    if (*p == '0') {
	while (isdigit(UCHAR(*p))) {	/* INTL: digit. */
	    p++;
	}
	while (isspace(UCHAR(*p))) {	/* INTL: ISO space. */
	    p++;
	}
	if (*p == '\0') {
	    /*
	     * Reached end of string.
	     */

	    if (interp != NULL) {
		/*
		 * Don't reset the result here because we want this result to
		 * be added to an existing error message as extra info.
		 */
		Tcl_AppendResult(interp, " (looks like invalid octal number)",
			(char *) NULL);
	    }
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ClearHash --
 *
 *      Remove all the entries in the hash table *tablePtr.
 *
 *----------------------------------------------------------------------
 */

static void
ClearHash(tablePtr)
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
}

/*
 *----------------------------------------------------------------------
 *
 * GetThreadHash --
 *
 *	Get a thread-specific (Tcl_HashTable *) associated with a
 *	thread data key.
 *
 * Results:
 *	The Tcl_HashTable * corresponding to *keyPtr.  
 *
 * Side effects:
 *	The first call on a keyPtr in each thread creates a new
 *	Tcl_HashTable, and registers a thread exit handler to
 *	dispose of it.
 *
 *----------------------------------------------------------------------
 */

static Tcl_HashTable *
GetThreadHash(keyPtr)
    Tcl_ThreadDataKey *keyPtr;







|
|


|


|
|
<







2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624

2625
2626
2627
2628
2629
2630
2631
}

/*
 *----------------------------------------------------------------------
 *
 * GetThreadHash --
 *
 *	Get a thread-specific (Tcl_HashTable *) associated with a thread data
 *	key.
 *
 * Results:
 *	The Tcl_HashTable * corresponding to *keyPtr.
 *
 * Side effects:
 *	The first call on a keyPtr in each thread creates a new Tcl_HashTable,
 *	and registers a thread exit handler to dispose of it.

 *
 *----------------------------------------------------------------------
 */

static Tcl_HashTable *
GetThreadHash(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
2618
2619
2620
2621
2622
2623
2624

2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638

2639
2640
2641
2642
2643
2644
2645
2646

2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678

2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690


2691


2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708

2709


2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
    return *tablePtrPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeThreadHash --

 *	Thread exit handler used by GetThreadHash to dispose
 *	of a thread hash table.
 *
 * Side effects:
 *	Frees a Tcl_HashTable.
 *
 *----------------------------------------------------------------------
 */

static void
FreeThreadHash(clientData)
    ClientData clientData; 
{
    Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;

    Tcl_DeleteHashTable(tablePtr);
    ckfree((char *) tablePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeProcessGlobalValue --

 *	Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup
 *	a ProcessGlobalValue at exit.
 *
 *----------------------------------------------------------------------
 */

static void
FreeProcessGlobalValue(clientData)
    ClientData clientData; 
{
    ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData;
    pgvPtr->epoch++;
    pgvPtr->numBytes = 0;
    ckfree(pgvPtr->value);
    pgvPtr->value = NULL;
    if (pgvPtr->encoding) {
	Tcl_FreeEncoding(pgvPtr->encoding);
	pgvPtr->encoding = NULL;
    }
    Tcl_MutexFinalize(&pgvPtr->mutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetProcessGlobalValue --
 *
 *	Utility routine to set a global value shared by all threads in
 *	the process while keeping a thread-local copy as well.
 *
 *----------------------------------------------------------------------
 */

void
TclSetProcessGlobalValue(pgvPtr, newValue, encoding)
    ProcessGlobalValue *pgvPtr;
    Tcl_Obj *newValue;
    Tcl_Encoding encoding;
{
    CONST char *bytes;
    Tcl_HashTable *cacheMap;
    Tcl_HashEntry *hPtr;
    int dummy;

    Tcl_MutexLock(&pgvPtr->mutex);


    /* Fill the global string value */


    pgvPtr->epoch++;
    if (NULL != pgvPtr->value) {
	ckfree(pgvPtr->value);
    } else {
	Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
    }
    bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
    pgvPtr->value = ckalloc((unsigned int) pgvPtr->numBytes + 1);
    strcpy(pgvPtr->value, bytes);
    if (pgvPtr->encoding) {
	Tcl_FreeEncoding(pgvPtr->encoding);
    }
    pgvPtr->encoding = encoding;

    /*
     * Fill the local thread copy directly with the Tcl_Obj
     * value to avoid loss of the intrep 

     */


    cacheMap = GetThreadHash(&pgvPtr->key);
    ClearHash(cacheMap);
    hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
    Tcl_SetHashValue(hPtr, (ClientData) newValue);
    Tcl_IncrRefCount(newValue);
    Tcl_MutexUnlock(&pgvPtr->mutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetProcessGlobalValue --







>
|
|









|


>








>
|
|






|


















|
|



>












>
>
|
>
>















|
|
>

>
>




<







2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746

2747
2748
2749
2750
2751
2752
2753
    return *tablePtrPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeThreadHash --
 *
 *	Thread exit handler used by GetThreadHash to dispose of a thread hash
 *	table.
 *
 * Side effects:
 *	Frees a Tcl_HashTable.
 *
 *----------------------------------------------------------------------
 */

static void
FreeThreadHash(clientData)
    ClientData clientData;
{
    Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
    ClearHash(tablePtr);
    Tcl_DeleteHashTable(tablePtr);
    ckfree((char *) tablePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeProcessGlobalValue --
 *
 *	Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a
 *	ProcessGlobalValue at exit.
 *
 *----------------------------------------------------------------------
 */

static void
FreeProcessGlobalValue(clientData)
    ClientData clientData;
{
    ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData;
    pgvPtr->epoch++;
    pgvPtr->numBytes = 0;
    ckfree(pgvPtr->value);
    pgvPtr->value = NULL;
    if (pgvPtr->encoding) {
	Tcl_FreeEncoding(pgvPtr->encoding);
	pgvPtr->encoding = NULL;
    }
    Tcl_MutexFinalize(&pgvPtr->mutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetProcessGlobalValue --
 *
 *	Utility routine to set a global value shared by all threads in the
 *	process while keeping a thread-local copy as well.
 *
 *----------------------------------------------------------------------
 */

void
TclSetProcessGlobalValue(pgvPtr, newValue, encoding)
    ProcessGlobalValue *pgvPtr;
    Tcl_Obj *newValue;
    Tcl_Encoding encoding;
{
    CONST char *bytes;
    Tcl_HashTable *cacheMap;
    Tcl_HashEntry *hPtr;
    int dummy;

    Tcl_MutexLock(&pgvPtr->mutex);

    /*
     * Fill the global string value.
     */

    pgvPtr->epoch++;
    if (NULL != pgvPtr->value) {
	ckfree(pgvPtr->value);
    } else {
	Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
    }
    bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
    pgvPtr->value = ckalloc((unsigned int) pgvPtr->numBytes + 1);
    strcpy(pgvPtr->value, bytes);
    if (pgvPtr->encoding) {
	Tcl_FreeEncoding(pgvPtr->encoding);
    }
    pgvPtr->encoding = encoding;

    /*
     * Fill the local thread copy directly with the Tcl_Obj value to avoid
     * loss of the intrep. Increment newValue refCount early to handle case
     * where we set a PGV to itself.
     */

    Tcl_IncrRefCount(newValue);
    cacheMap = GetThreadHash(&pgvPtr->key);
    ClearHash(cacheMap);
    hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
    Tcl_SetHashValue(hPtr, (ClientData) newValue);

    Tcl_MutexUnlock(&pgvPtr->mutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetProcessGlobalValue --
2736
2737
2738
2739
2740
2741
2742
2743
2744

2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778

2779

2780
2781


2782
2783

2784


2785
2786
2787
2788
2789
2790
2791
2792

2793

2794
2795

2796


2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
    Tcl_Obj *value = NULL;
    Tcl_HashTable *cacheMap;
    Tcl_HashEntry *hPtr;
    int epoch = pgvPtr->epoch;

    if (pgvPtr->encoding) {
	Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
	if (pgvPtr->encoding != current) {


	    /*
	     * The system encoding has changed since the master
	     * string value was saved.  Convert the master value
	     * to be based on the new system encoding.  
	     */

	    Tcl_DString native, newValue;

	    Tcl_MutexLock(&pgvPtr->mutex);
	    pgvPtr->epoch++;
	    epoch = pgvPtr->epoch;
	    Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
		    pgvPtr->numBytes, &native);
	    Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
	    Tcl_DStringLength(&native), &newValue);
	    Tcl_DStringFree(&native);
	    ckfree(pgvPtr->value);
	    pgvPtr->value = ckalloc((unsigned int)
		    Tcl_DStringLength(&newValue) + 1);
	    memcpy((VOID *) pgvPtr->value, (VOID *) Tcl_DStringValue(&newValue),
		    (size_t) Tcl_DStringLength(&newValue) + 1);
	    Tcl_DStringFree(&newValue);
	    Tcl_FreeEncoding(pgvPtr->encoding);
	    pgvPtr->encoding = current;
	    Tcl_MutexUnlock(&pgvPtr->mutex);
	} else {
	    Tcl_FreeEncoding(current);
	}
    }
    cacheMap = GetThreadHash(&pgvPtr->key);
    hPtr = Tcl_FindHashEntry(cacheMap, (char *)epoch);
    if (NULL == hPtr) {
	int dummy;


	/* No cache for the current epoch - must be a new one */

	/* First, clear the cacheMap, as anything in it must
	 * refer to some expired epoch.*/


	ClearHash(cacheMap);


	/* If no thread has set the shared value, call the initializer */


	Tcl_MutexLock(&pgvPtr->mutex);
	if (NULL == pgvPtr->value) {
	    if (pgvPtr->proc) {
		pgvPtr->epoch++;
		(*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes,
			&pgvPtr->encoding);
		Tcl_CreateExitHandler(FreeProcessGlobalValue,
			(ClientData) pgvPtr);

	    }

	}


	/* Store a copy of the shared value in our epoch-indexed cache */


	value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
	hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
	Tcl_MutexUnlock(&pgvPtr->mutex);
	Tcl_SetHashValue(hPtr, (ClientData) value);
	Tcl_IncrRefCount(value);
    }
    return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetObjNameOfExecutable --
 *
 *	This procedure stores the absolute pathname of
 *	the executable file (normally as computed by
 *	TclpFindExecutable).
 *
 * Results:
 * 	None.
 *
 * Side effects:
 *	Stores the executable name.
 *







<

>

|
|
|















|














>
|
>
|
|
>
>


>
|
>
>

|
<
|
|
|
<
|
>

>


>
|
>
>














|
<
|







2768
2769
2770
2771
2772
2773
2774

2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825

2826
2827
2828

2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853

2854
2855
2856
2857
2858
2859
2860
2861
    Tcl_Obj *value = NULL;
    Tcl_HashTable *cacheMap;
    Tcl_HashEntry *hPtr;
    int epoch = pgvPtr->epoch;

    if (pgvPtr->encoding) {
	Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);


	if (pgvPtr->encoding != current) {
	    /*
	     * The system encoding has changed since the master string value
	     * was saved. Convert the master value to be based on the new
	     * system encoding.
	     */

	    Tcl_DString native, newValue;

	    Tcl_MutexLock(&pgvPtr->mutex);
	    pgvPtr->epoch++;
	    epoch = pgvPtr->epoch;
	    Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
		    pgvPtr->numBytes, &native);
	    Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
	    Tcl_DStringLength(&native), &newValue);
	    Tcl_DStringFree(&native);
	    ckfree(pgvPtr->value);
	    pgvPtr->value = ckalloc((unsigned int)
		    Tcl_DStringLength(&newValue) + 1);
	    memcpy((VOID*) pgvPtr->value, (VOID*) Tcl_DStringValue(&newValue),
		    (size_t) Tcl_DStringLength(&newValue) + 1);
	    Tcl_DStringFree(&newValue);
	    Tcl_FreeEncoding(pgvPtr->encoding);
	    pgvPtr->encoding = current;
	    Tcl_MutexUnlock(&pgvPtr->mutex);
	} else {
	    Tcl_FreeEncoding(current);
	}
    }
    cacheMap = GetThreadHash(&pgvPtr->key);
    hPtr = Tcl_FindHashEntry(cacheMap, (char *)epoch);
    if (NULL == hPtr) {
	int dummy;

	/*
	 * No cache for the current epoch - must be a new one.
	 *
	 * First, clear the cacheMap, as anything in it must refer to some
	 * expired epoch.
	 */

	ClearHash(cacheMap);

	/*
	 * If no thread has set the shared value, call the initializer.
	 */

	Tcl_MutexLock(&pgvPtr->mutex);
	if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {

	    pgvPtr->epoch++;
	    (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes,
		    &pgvPtr->encoding);

	    if (pgvPtr->value == NULL) {
		Tcl_Panic("PGV Initializer did not initialize.");
	    }
	    Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
	}

	/*
	 * Store a copy of the shared value in our epoch-indexed cache.
	 */

	value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
	hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
	Tcl_MutexUnlock(&pgvPtr->mutex);
	Tcl_SetHashValue(hPtr, (ClientData) value);
	Tcl_IncrRefCount(value);
    }
    return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetObjNameOfExecutable --
 *
 *	This function stores the absolute pathname of the executable file

 *	(normally as computed by TclpFindExecutable).
 *
 * Results:
 * 	None.
 *
 * Side effects:
 *	Stores the executable name.
 *
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetObjNameOfExecutable --
 *
 *	This procedure retrieves the absolute pathname of the
 *	application in which the Tcl library is running, usually
 *	as previously stored by TclpFindExecutable().
 *	This procedure call is the C API equivalent to the
 *	"info nameofexecutable" command.
 *
 * Results:
 *	A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if
 *	the pathname of the application is unknown.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetObjNameOfExecutable()
{
    return TclGetProcessGlobalValue(&executableName);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetNameOfExecutable --
 *
 *	This procedure retrieves the absolute pathname of the
 *	application in which the Tcl library is running, and
 *	returns it in string form.
 *
 * 	The returned string belongs to Tcl and should be copied
 * 	if the caller plans to keep it, to guard against it
 * 	becoming invalid.
 *
 * Results:
 *	A pointer to the internal string or NULL if the internal full
 *	path name has not been computed or unknown.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|
<
|


|
|


















|
|
<

|
|
<


|
|







2871
2872
2873
2874
2875
2876
2877
2878
2879
2880

2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905

2906
2907
2908

2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetObjNameOfExecutable --
 *
 *	This function retrieves the absolute pathname of the application in
 *	which the Tcl library is running, usually as previously stored by
 *	TclpFindExecutable(). This function call is the C API equivalent to

 *	the "info nameofexecutable" command.
 *
 * Results:
 *	A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the
 *	pathname of the application is unknown.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetObjNameOfExecutable()
{
    return TclGetProcessGlobalValue(&executableName);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetNameOfExecutable --
 *
 *	This function retrieves the absolute pathname of the application in
 *	which the Tcl library is running, and returns it in string form.

 *
 * 	The returned string belongs to Tcl and should be copied if the caller
 * 	plans to keep it, to guard against it becoming invalid.

 *
 * Results:
 *	A pointer to the internal string or NULL if the internal full path
 *	name has not been computed or unknown.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

2892
2893
2894
2895
2896
2897
2898
2899


2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918































}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTime --
 *
 *	Deprecated synonym for Tcl_GetTime.


 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores current time in the buffer designated by "timePtr"
 *
 * This procedure is provided for the benefit of extensions written
 * before Tcl_GetTime was exported from the library.
 *
 *----------------------------------------------------------------------
 */

void
TclpGetTime(timePtr)
    Tcl_Time* timePtr;
{
    Tcl_GetTime(timePtr);
}






































|
>
>







<
<
<









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946



2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTime --
 *
 *	Deprecated synonym for Tcl_GetTime. This function is provided for the
 *	benefit of extensions written before Tcl_GetTime was exported from the
 *	library.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores current time in the buffer designated by "timePtr"
 *



 *----------------------------------------------------------------------
 */

void
TclpGetTime(timePtr)
    Tcl_Time* timePtr;
{
    Tcl_GetTime(timePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetPlatform --
 *
 *	This is a kludge that allows the test library to get access the
 *	internal tclPlatform variable.
 *
 * Results:
 *	Returns a pointer to the tclPlatform variable.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclPlatformType *
TclGetPlatform()
{
    return &tclPlatform;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclVar.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108

109
110
111
112
113
114
115
/* 
 * tclVar.c --
 *
 *	This file contains routines that implement Tcl variables
 *	(both scalars and arrays).
 *
 *	The implementation of arrays is modelled after an initial
 *	implementation by Mark Diekhans and Karl Lehenbauer.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.99 2004/11/12 19:16:53 dgp Exp $
 */

#include "tclInt.h"

/*
 * The strings below are used to indicate what went wrong when a
 * variable access is denied.
 */

static CONST char *noSuchVar =		"no such variable";
static CONST char *isArray =		"variable is array";
static CONST char *needArray =		"variable isn't array";
static CONST char *noSuchElement =	"no such element in array";
static CONST char *danglingElement =
				"upvar refers to element in deleted array";
static CONST char *danglingVar =	
				"upvar refers to variable in deleted namespace";
static CONST char *badNamespace =	"parent namespace doesn't exist";
static CONST char *missingName =	"missing variable name";
static CONST char *isArrayElement =	"name refers to an element in an array";


/*
 * Forward references to procedures defined later in this file:
 */

static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void		DeleteArray _ANSI_ARGS_((Interp *iPtr,
			    CONST char *arrayName, Var *varPtr, int flags));
static int              ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, 
                            CallFrame *framePtr, Tcl_Obj *otherP1Ptr, 
                            CONST char *otherP2, CONST int otherFlags,
		            CONST char *myName, int myFlags, int index));
static Var *		NewVar _ANSI_ARGS_((void));
static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST Var *varPtr, CONST char *varName,
			    Tcl_Obj *handleObj));
static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * Functions defined in this file that may be exported in the future
 * for use by the bytecode compiler and engine or to the public interface.
 */

Var *		TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
		    CONST char *varName, int flags, CONST int create,
		    CONST char **errMsgPtr, int *indexPtr));
int		TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *part1Ptr, CONST char *part2, int flags));

static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
static Tcl_UpdateStringProc UpdateParsedVarName;

static Tcl_UpdateStringProc PanicOnUpdateVarName;
static Tcl_SetFromAnyProc PanicOnSetVarName;

/*
 * Types of Tcl_Objs used to cache variable lookups.
 *
 * 
 * localVarName - INTERNALREP DEFINITION:
 *   longValue = index into locals table
 *
 * nsVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1: pointer to the namespace containing the 
 *                     reference
 *   twoPtrValue.ptr2: pointer to the corresponding Var 
 *
 * parsedVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, 
 *                      or NULL if it is a scalar variable
 *   twoPtrValue.ptr2 = pointer to the element name string
 *                      (owned by this Tcl_Obj), or NULL if 
 *                      it is a scalar variable
 */

Tcl_ObjType tclLocalVarNameType = {
    "localVarName",
    NULL, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
};

/*
 * Caching of namespace variables disabled: no simple way was found to
 * avoid interfering with the resolver's idea of variable existence.
 * A cached varName may keep a variable's name in the namespace's hash
 * table, which is the resolver's criterion for existence (see test
 * namespace-17.10).
 */	

#define ENABLE_NS_VARNAME_CACHING 0

#if ENABLE_NS_VARNAME_CACHING
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;

Tcl_ObjType tclNsVarNameType = {
|


|
|









|
|

|





|
|







|
|
|


|
>








|
|
|
|








|
|



















<

|


|
<
|


|
|
|
<
|


|





|
|
|
|
<
|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

81
82
83
84
85

86
87
88
89
90
91

92
93
94
95
96
97
98
99
100
101
102
103
104

105
106
107
108
109
110
111
112
113
/*
 * tclVar.c --
 *
 *	This file contains routines that implement Tcl variables (both scalars
 *	and arrays).
 *
 *	The implementation of arrays is modelled after an initial
 *	implementation by Mark Diekhans and Karl Lehenbauer.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.99.2.8 2005/08/19 05:17:48 dgp Exp $
 */

#include "tclInt.h"

/*
 * The strings below are used to indicate what went wrong when a variable
 * access is denied.
 */

static CONST char *noSuchVar =		"no such variable";
static CONST char *isArray =		"variable is array";
static CONST char *needArray =		"variable isn't array";
static CONST char *noSuchElement =	"no such element in array";
static CONST char *danglingElement =
	"upvar refers to element in deleted array";
static CONST char *danglingVar =
	"upvar refers to variable in deleted namespace";
static CONST char *badNamespace =	"parent namespace doesn't exist";
static CONST char *missingName =	"missing variable name";
static CONST char *isArrayElement =
	"name refers to an element in an array";

/*
 * Forward references to procedures defined later in this file:
 */

static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void		DeleteArray _ANSI_ARGS_((Interp *iPtr,
			    CONST char *arrayName, Var *varPtr, int flags));
static int		ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp,
			    CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
			    CONST char *otherP2, CONST int otherFlags,
			    CONST char *myName, int myFlags, int index));
static Var *		NewVar _ANSI_ARGS_((void));
static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST Var *varPtr, CONST char *varName,
			    Tcl_Obj *handleObj));
static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * Functions defined in this file that may be exported in the future for use
 * by the bytecode compiler and engine or to the public interface.
 */

Var *		TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
		    CONST char *varName, int flags, CONST int create,
		    CONST char **errMsgPtr, int *indexPtr));
int		TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *part1Ptr, CONST char *part2, int flags));

static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
static Tcl_UpdateStringProc UpdateParsedVarName;

static Tcl_UpdateStringProc PanicOnUpdateVarName;
static Tcl_SetFromAnyProc PanicOnSetVarName;

/*
 * Types of Tcl_Objs used to cache variable lookups.
 *

 * localVarName - INTERNALREP DEFINITION:
 *   longValue:		index into locals table
 *
 * nsVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:	pointer to the namespace containing the reference

 *   twoPtrValue.ptr2:	pointer to the corresponding Var
 *
 * parsedVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:	pointer to the array name Tcl_Obj, or NULL if it is a
 *			scalar variable
 *   twoPtrValue.ptr2:	pointer to the element name string (owned by this

 *			Tcl_Obj), or NULL if it is a scalar variable
 */

static Tcl_ObjType localVarNameType = {
    "localVarName",
    NULL, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
};

/*
 * Caching of namespace variables disabled: no simple way was found to avoid
 * interfering with the resolver's idea of variable existence. A cached
 * varName may keep a variable's name in the namespace's hash table, which is
 * the resolver's criterion for existence (see test namespace-17.10).

 */

#define ENABLE_NS_VARNAME_CACHING 0

#if ENABLE_NS_VARNAME_CACHING
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;

Tcl_ObjType tclNsVarNameType = {
123
124
125
126
127
128
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

233
234
235
236
237
238
239
    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
};

/*
 * Type of Tcl_Objs used to speed up array searches.
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
 *   twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
 *
 * Note that the value stored in ptr2 is the offset into the string of
 * the start of the variable name and not the address of the variable
 * name itself, as this can be safely copied.
 */

Tcl_ObjType tclArraySearchType = {
    "array search",
    NULL, NULL, NULL, SetArraySearchObj
};


/*
 *----------------------------------------------------------------------
 *
 * TclLookupVar --
 *
 *	This procedure is used to locate a variable given its name(s). It
 *      has been mostly superseded by TclObjLookupVar, it is now only used 
 *      by the string-based interfaces. It is kept in tcl8.4 mainly because 
 *      it is in the internal stubs table, so that some extension may be 
 *      calling it. 
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1 and part2, or NULL if the variable couldn't be found. If the
 *	variable is found, *arrayPtrPtr is filled in with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags. 
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if createPart1 or createPart2 are 1 (these only cause the hash
 *	table entry or array to be created). For example, the variable might
 *	be a global that has been unset but is still referenced by a
 *	procedure, or a variable that has been unset but it only being kept
 *	in existence (if VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
        arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *part1;	        /* If part2 isn't NULL, this is the name of
				 * an array. Otherwise, this
				 * is a full variable name that could
				 * include a parenthesized array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST char *msg;			/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    int createPart1;		/* If 1, create hash table entry for part 1
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    int createPart2;		/* If 1, create hash table entry for part 2
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    Var **arrayPtrPtr;		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise
				 * this is set to NULL. */
{
    Var *varPtr;
    CONST char *elName;		/* Name of array element or NULL; may be
				 * same as part2, or may be openParen+1. */
    int openParen, closeParen;
                                /* If this procedure parses a name into
				 * array and index, these are the offsets to 
				 * the parens around the index.  Otherwise 
				 * they are -1. */
    register CONST char *p;
    CONST char *errMsg = NULL;
    int index;
#define VAR_NAME_BUF_SIZE 26
    char buffer[VAR_NAME_BUF_SIZE];
    char *newVarName = buffer;

    varPtr = NULL;
    *arrayPtrPtr = NULL;
    openParen = closeParen = -1;

    /*
     * Parse part1 into array name and index.
     * Always check if part1 is an array element name and allow it only if
     * part2 is not given.   
     * (if one does not care about creating array elements that can't be used
     *  from tcl, and prefer slightly better performance, one can put
     *  the following in an   if (part2 == NULL) { ... } block and remove
     *  the part2's test and error reporting  or move that code in array set)

     */

    elName = part2;
    for (p = part1; *p ; p++) {
	if (*p == '(') {
	    openParen = p - part1;
	    do {







|
|

|
|
|

>




<






|
|
|
|
<













|

|
|
|
|
|
|







>


|

|
|
|
|



|
|
|
|
|
|
|
|
|


|
|


|
|
|
<
|
|
|














<
|
|
|
|
>







121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
148
149

150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224

225
226
227
228
229
230
231
232
233
234
235
236
    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
};

/*
 * Type of Tcl_Objs used to speed up array searches.
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1:	searchIdNumber as offset from (char*)NULL
 *   twoPtrValue.ptr2:	variableNameStartInString as offset from (char*)NULL
 *
 * Note that the value stored in ptr2 is the offset into the string of the
 * start of the variable name and not the address of the variable name itself,
 * as this can be safely copied.
 */

Tcl_ObjType tclArraySearchType = {
    "array search",
    NULL, NULL, NULL, SetArraySearchObj
};


/*
 *----------------------------------------------------------------------
 *
 * TclLookupVar --
 *
 *	This procedure is used to locate a variable given its name(s). It has
 *	been mostly superseded by TclObjLookupVar, it is now only used by the
 *	string-based interfaces. It is kept in tcl8.4 mainly because it is in
 *	the internal stubs table, so that some extension may be calling it.

 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1 and part2, or NULL if the variable couldn't be found. If the
 *	variable is found, *arrayPtrPtr is filled in with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED even
 *	if createPart1 or createPart2 are 1 (these only cause the hash table
 *	entry or array to be created). For example, the variable might be a
 *	global that has been unset but is still referenced by a procedure, or
 *	a variable that has been unset but it only being kept in existence (if
 *	VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
	arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *part1;		/* If part2 isn't NULL, this is the name of an
				 * array. Otherwise, this is a full variable
				 * name that could include a parenthesized
				 * array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST char *msg;		/* Verb to use in error messages, e.g.  "read"
				 * or "set". Only needed if TCL_LEAVE_ERR_MSG
				 * is set in flags. */
    int createPart1;		/* If 1, create hash table entry for part 1 of
				 * name, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    int createPart2;		/* If 1, create hash table entry for part 2 of
				 * name, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    Var **arrayPtrPtr;		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Var *varPtr;
    CONST char *elName;		/* Name of array element or NULL; may be same
				 * as part2, or may be openParen+1. */
    int openParen, closeParen;	/* If this procedure parses a name into array

				 * and index, these are the offsets to the
				 * parens around the index.  Otherwise they
				 * are -1. */
    register CONST char *p;
    CONST char *errMsg = NULL;
    int index;
#define VAR_NAME_BUF_SIZE 26
    char buffer[VAR_NAME_BUF_SIZE];
    char *newVarName = buffer;

    varPtr = NULL;
    *arrayPtrPtr = NULL;
    openParen = closeParen = -1;

    /*
     * Parse part1 into array name and index.
     * Always check if part1 is an array element name and allow it only if

     * part2 is not given. (If one does not care about creating array elements
     * that can't be used from tcl, and prefer slightly better performance,
     * one can put the following in an if (part2 == NULL) { ... } block and
     * remove the part2's test and error reporting or move that code in array
     * set.)
     */

    elName = part2;
    for (p = part1; *p ; p++) {
	if (*p == '(') {
	    openParen = p - part1;
	    do {
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406

407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426

427
428
429
430
431
432

433
434

435
436
437
438
439

440
441
442
443
444
445
446
447
448
449
450
451
452

453
454
455
456
457
458
459
460
461
462
463

464
465

466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551

552
553
554
555
556
557
558
559
560
561
562
563

564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623

624
625
626
627

628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755

756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799

800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
	memcpy(newVarName, part1, (unsigned int) closeParen);
	newVarName[openParen] = '\0';
	newVarName[closeParen] = '\0';
	part1 = newVarName;
	elName = newVarName + openParen + 1;
    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, 
            createPart1, &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    TclVarErrMsg(interp, part1, elName, msg, errMsg);
	}
    } else {
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	if (elName != NULL) {
	    *arrayPtrPtr = varPtr;
	    varPtr = TclLookupArrayElement(interp, part1, elName, flags, 
		    msg, createPart1, createPart2, varPtr);
	}
    }
    if (newVarName != buffer) {
	ckfree(newVarName);
    }

    return varPtr;
	
#undef VAR_NAME_BUF_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjLookupVar --
 *
 *	This procedure is used by virtually all of the variable code to
 *	locate a variable given its name(s). The parsing into array/element
 *      components and (if possible) the lookup results are cached in 
 *      part1Ptr, which is converted to one of the varNameTypes.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1Ptr and part2, or NULL if the variable couldn't be found. If 
 *      the variable is found, *arrayPtrPtr is filled with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags. 
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if createPart1 or createPart2 are 1 (these only cause the hash
 *	table entry or array to be created). For example, the variable might
 *	be a global that has been unset but is still referenced by a
 *	procedure, or a variable that has been unset but it only being kept
 *	in existence (if VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *      The object part1Ptr is converted to one of tclLocalVarNameType, 
 *      tclNsVarNameType or tclParsedVarNameType and caches as much of the
 *      lookup as it can.
 *
 *----------------------------------------------------------------------
 */

Var *
TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
        arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    register Tcl_Obj *part1Ptr;	/* If part2 isn't NULL, this is the name 
				 * of an array. Otherwise, this is a full 
				 * variable name that could include a parenthesized 
				 * array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST char *msg;		/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    CONST int createPart1;	/* If 1, create hash table entry for part 1
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    CONST int createPart2;	/* If 1, create hash table entry for part 2
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    Var **arrayPtrPtr;		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise
				 * this is set to NULL. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    char *part1;
    int index, len1, len2;
    int parsed = 0;
    Tcl_Obj *objPtr;
    Tcl_ObjType *typePtr = part1Ptr->typePtr;
    CONST char *errMsg = NULL;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Namespace *nsPtr;

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the 
     * pre-parsed parts.
     */

    *arrayPtrPtr = NULL;
    if (typePtr == &tclParsedVarNameType) {
	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
	    if (part2 != NULL) {
		/*
		 * ERROR: part1Ptr is already an array element, cannot 
		 * specify a part2.
		 */

		if (flags & TCL_LEAVE_ERR_MSG) {
		    part1 = TclGetString(part1Ptr);
		    TclVarErrMsg(interp, part1, part2, msg, needArray);
		}
		return NULL;
	    }
	    part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
	    part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
	    typePtr = part1Ptr->typePtr;
	}
	parsed = 1;
    }
    part1 = Tcl_GetStringFromObj(part1Ptr, &len1);    

    nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
    if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
	goto doParse;
    }
    
    if (typePtr == &tclLocalVarNameType) {
	int localIndex = (int) part1Ptr->internalRep.longValue;

	if ((varFramePtr != NULL) && varFramePtr->isProcCallFrame

	        && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		&& (localIndex < varFramePtr->numCompiledLocals)) {
	    /*
	     * use the cached index if the names coincide.
	     */
	    
	    varPtr = &(varFramePtr->compiledLocals[localIndex]);
	    if ((varPtr->name != NULL)
		    && (strcmp(part1, varPtr->name) == 0)) {
		goto donePart1;
	    }
	}
	goto doneParsing;
#if ENABLE_NS_VARNAME_CACHING
    } else if (typePtr == &tclNsVarNameType) {
	Namespace *cachedNsPtr;
	int useGlobal, useReference;

	varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
	cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;

	useGlobal = (cachedNsPtr == iPtr->globalNsPtr) 
	    && ((flags & TCL_GLOBAL_ONLY) 
		|| ((*part1 == ':') && (*(part1+1) == ':'))
		|| (varFramePtr == NULL) 
		|| (!varFramePtr->isProcCallFrame 
		    && (nsPtr == iPtr->globalNsPtr)));

	useReference = useGlobal || ((cachedNsPtr == nsPtr) 
	        && ((flags & TCL_NAMESPACE_ONLY) 

		    || (varFramePtr && !varFramePtr->isProcCallFrame 
			&& !(flags & TCL_GLOBAL_ONLY)
			/* careful: an undefined ns variable could
			 * be hiding a valid global reference. */
			&& !TclIsVarUndefined(varPtr))));

	if (useReference && (varPtr->hPtr != NULL)) {
	    /*
	     * A straight global or namespace reference, use it. It isn't 
	     * so simple to deal with 'implicit' namespace references, i.e., 
	     * those where the reference could be to either a namespace 
	     * or a global variable. Those we lookup again.
	     *
	     * If (varPtr->hPtr == NULL), this might be a reference to a
	     * variable in a deleted namespace, kept alive by e.g. part1Ptr.
	     * We could conceivably be so unlucky that a new namespace was
	     * created at the same address as the deleted one, so to be 
	     * safe we test for a valid hPtr.
	     */

	    goto donePart1;
	}
	goto doneParsing;
#endif
    }

    doParse:
    if (!parsed && (*(part1 + len1 - 1) == ')')) {
	/*
	 * part1Ptr is possibly an unparsed array element.
	 */

	register int i;
	char *newPart2;

	len2 = -1;
	for (i = 0; i < len1; i++) {
	    if (*(part1 + i) == '(') {
		if (part2 != NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			TclVarErrMsg(interp, part1, part2, msg, needArray);
		    }
		}			

		/*
		 * part1Ptr points to an array element; first copy 
		 * the element name to a new string part2.
		 */

		part2 = part1 + i + 1;
		len2 = len1 - i - 2;
		len1 = i;

		newPart2 = ckalloc((unsigned int) (len2+1));
		memcpy(newPart2, part2, (unsigned int) len2);
		*(newPart2+len2) = '\0';
		part2 = newPart2;

		/*
		 * Free the internal rep of the original part1Ptr, now
		 * renamed objPtr, and set it to tclParsedVarNameType.
		 */

		objPtr = part1Ptr;
		TclFreeIntRep(objPtr);
		objPtr->typePtr = &tclParsedVarNameType;

		/*
		 * Define a new string object to hold the new part1Ptr, i.e., 
		 * the array name. Set the internal rep of objPtr, reset
		 * typePtr and part1 to contain the references to the
		 * array name.
		 */

		part1Ptr = Tcl_NewStringObj(part1, len1);
		Tcl_IncrRefCount(part1Ptr);

		objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
		objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;		

		typePtr = part1Ptr->typePtr;
		part1 = TclGetString(part1Ptr);
		break;
	    }
	}
    }
    
    doneParsing:
    /*
     * part1Ptr is not an array element; look it up, and convert 
     * it to one of the cached types if possible.
     */

    TclFreeIntRep(part1Ptr);
    part1Ptr->typePtr = NULL;

    varPtr = TclLookupSimpleVar(interp, part1, flags, 
            createPart1, &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    TclVarErrMsg(interp, part1, part2, msg, errMsg);
	}
	return NULL;
    }

    /*
     * Cache the newly found variable if possible.
     */

    if (index >= 0) {
        /*
	 * An indexed local variable.
	 */

	part1Ptr->typePtr = &tclLocalVarNameType;
	part1Ptr->internalRep.longValue = (long) index;
#if ENABLE_NS_VARNAME_CACHING
    } else if (index > -3) {
	/*
	 * A cacheable namespace or global variable.
	 */

	Namespace *nsPtr;
    
	nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
	varPtr->refCount++;
	part1Ptr->typePtr = &tclNsVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
	part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
#endif
    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */

	part1Ptr->typePtr = &tclParsedVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
	part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
    }
    
    donePart1:
#if 0
    if (varPtr == NULL) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    part1 = TclGetString(part1Ptr);
	    TclVarErrMsg(interp, part1, part2, msg, 
		    "Cached variable reference is NULL.");
	}
	return NULL;
    }
#endif
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    if (part2 != NULL) {
	/*
	 * Array element sought: look it up.
	 */

	part1 = TclGetString(part1Ptr);
	*arrayPtrPtr = varPtr;
	varPtr = TclLookupArrayElement(interp, part1, part2, 
                flags, msg, createPart1, createPart2, varPtr);
    }
    return varPtr;
}

/*
 * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
 * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for 
 * upvar (or similar) purposes, with slightly different rules:
 *   - Bug #696893 - variable is either proc-local or in the current
 *     namespace; never follow the second (global) resolution path 
 *   - Bug #631741 - do not use special namespace or interp resolvers
 *
 * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag
 * (Bug #835020)
 */

#define LOOKUP_FOR_UPVAR 0x40000

/*
 *----------------------------------------------------------------------
 *
 * TclLookupSimpleVar --
 *
 *	This procedure is used by to locate a simple variable (i.e., not
 *      an array element) given its name.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	varName, or NULL if the variable couldn't be found. If the variable 
 *      can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) 
 *      variable structure is created, entered into a hash table, and returned.

 *
 *      If the current CallFrame corresponds to a proc and the variable found is
 *      one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
 *      *indexPtr will be set to (according to the needs of TclObjLookupVar):

 *               -1 a global reference
 *               -2 a reference to a namespace variable
 *               -3 a non-cachable reference, i.e., one of:
 *                    . non-indexed local var
 *                    . a reference of unknown origin;
 *                    . resolution by a namespace or interp resolver
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and the corresponding error
 *	message is left in *errMsgPtr. 
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if create is 1 (this only causes the hash table entry to be
 *	created).  For example, the variable might be a global that has been
 *	unset but is still referenced by a procedure, or a variable that has
 *	been unset but it only being kept in existence (if VAR_UNDEFINED) by
 *	a trace.
 *
 * Side effects:
 *	A new hashtable entry may be created if create is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *varName;        /* This is a simple variable name that could
				 * representa scalar or an array. */
    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits 
				 * matter. */
    CONST int create;		/* If 1, create hash table entry for varname,
				 * if it doesn't already exist. If 0, return 
				 * error if it doesn't exist. */
    CONST char **errMsgPtr;
    int *indexPtr;
{    
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,
				 * unless an "uplevel" is executing. */
    Tcl_HashTable *tablePtr;	/* Points to the hashtable, if any, in which
				 * to look up the variable. */
    Tcl_Var var;                /* Used to search for global names. */
    Var *varPtr;		/* Points to the Var structure returned for
				 * the variable. */
    Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
    ResolverScheme *resPtr;
    Tcl_HashEntry *hPtr;
    int new, i, result;

    varPtr = NULL;
    varNsPtr = NULL;		/* set non-NULL if a nonlocal variable */
    *indexPtr = -3;

    if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
        cxtNsPtr = iPtr->globalNsPtr;
    } else {
        cxtNsPtr = iPtr->varFramePtr->nsPtr;
    }

    /*
     * If this namespace has a variable resolver, then give it first
     * crack at the variable resolution.  It may return a Tcl_Var
     * value, it may signal to continue onward, or it may signal
     * an error.
     */

    if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) 
	    && !(flags & LOOKUP_FOR_UPVAR)) {
        resPtr = iPtr->resolverPtr;

        if (cxtNsPtr->varResProc) {
            result = (*cxtNsPtr->varResProc)(interp, varName,
		    (Tcl_Namespace *) cxtNsPtr, flags, &var);
        } else {
            result = TCL_CONTINUE;
        }

        while (result == TCL_CONTINUE && resPtr) {
            if (resPtr->varResProc) {
                result = (*resPtr->varResProc)(interp, varName,
			(Tcl_Namespace *) cxtNsPtr, flags, &var);
            }
            resPtr = resPtr->nextPtr;
        }

        if (result == TCL_OK) {
            varPtr = (Var *) var;
	    return varPtr;
        } else if (result != TCL_CONTINUE) {
	    return NULL;
        }
    }

    /*
     * Look up varName. Look it up as either a namespace variable or as a
     * local variable in a procedure call frame (varFramePtr).
     * Interpret varName as a namespace variable if:
     *    1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
     *    2) there is no active frame (we're at the global :: scope),
     *    3) the active frame was pushed to define the namespace context
     *       for a "namespace eval" or "namespace inscope" command,
     *    4) the name has namespace qualifiers ("::"s).
     * Otherwise, if varName is a local variable, search first in the
     * frame's array of compiler-allocated local variables, then in its
     * hashtable for runtime-created local variables.
     *
     * If create and the variable isn't found, create the variable and,
     * if necessary, create varFramePtr's local var hashtable.
     */

    if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
	    || (varFramePtr == NULL)
	    || !varFramePtr->isProcCallFrame
	    || (strstr(varName, "::") != NULL)) {
	CONST char *tail;
	int lookGlobal;
	
	lookGlobal = (flags & TCL_GLOBAL_ONLY) 
	    || (cxtNsPtr == iPtr->globalNsPtr)
	    || ((*varName == ':') && (*(varName+1) == ':'));
	if (lookGlobal) {
	    *indexPtr = -1;
	    flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR);

	} else {
	    if (flags & LOOKUP_FOR_UPVAR) {
		flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR;
	    }
	    if (flags & TCL_NAMESPACE_ONLY) {
		*indexPtr = -2;
	    }
	} 

        /*
	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
	 * or otherwise generate our own error!
	 */

	var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
		flags & ~TCL_LEAVE_ERR_MSG);

	if (var != (Tcl_Var) NULL) {
            varPtr = (Var *) var;
        }

	if (varPtr == NULL) {
	    if (create) {   /* var wasn't found so create it  */
		TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
			flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
		if (varNsPtr == NULL) {
		    *errMsgPtr = badNamespace;
		    return NULL;
		}
		if (tail == NULL) {
		    *errMsgPtr = missingName;
		    return NULL;
		}
		hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = varNsPtr;
		if (lookGlobal) {
		    /*
		     * The variable was created starting from the global
		     * namespace: a global reference is returned even if 
		     * it wasn't explicitly requested.
		     */

		    *indexPtr = -1;
		} else {
		    *indexPtr = -2;
		}
	    } else {		/* var wasn't found and not to create it */
		*errMsgPtr = noSuchVar;
		return NULL;
	    }
	}
    } else {			/* local var: look in frame varFramePtr */
	Proc *procPtr = varFramePtr->procPtr;
	int localCt = procPtr->numCompiledLocals;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	Var *localVarPtr = varFramePtr->compiledLocals;
	int varNameLen = strlen(varName);
	
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		register char *localName = localVarPtr->name;
		if ((varName[0] == localName[0])
		        && (varNameLen == localPtr->nameLength)
		        && (strcmp(varName, localName) == 0)) {
		    *indexPtr = i;
		    return localVarPtr;
		}
	    }
	    localVarPtr++;
	    localPtr = localPtr->nextPtr;
	}
	tablePtr = varFramePtr->varTablePtr;
	if (create) {
	    if (tablePtr == NULL) {
		tablePtr = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
		Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
		varFramePtr->varTablePtr = tablePtr;
	    }
	    hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
	    if (new) {
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = NULL; /* a local variable */
	    } else {
		varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }
	} else {
	    hPtr = NULL;
	    if (tablePtr != NULL) {
		hPtr = Tcl_FindHashEntry(tablePtr, varName);







|
|










|








<








|
|
|
|



|
|








|

|
|
|
|
|
|



<
|
|
|



>


|

|
|
|


|

|
|
|
|
|
|
|
|
|


|
|














|
|







|
|














|





|
|


|
>
|




|

|
<






<

|
|
|
>
|
|
|
|
|
|
>
|
|
>
|
|
|
|
|
>


|
|
|
|




|
|

>






|




>


>







|


|
|












|
|







|

|
|


|



|







|
|

|
|





|
|












|



|






>

|










>




|
|




|
















|
|






|

|
|
|












|
|



|
|
|
>

|
|
|
>
|
|
|
|
|
|



|

|
|
|
|
|
<










|
|
|
|


|



|



|
|
|


|












|

|



|
|
|
<


|

|
<
|
|

|
|
|

|
|
|

|
|
|

|
|
<
|

|




|
|


|
|

|
|
|

|
|




|



|
|
|
|


|
>







|

|
|
|






|
|


|


















|
|

>















|




|
|




















|







258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411

412
413
414
415
416
417

418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649

650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700

701
702
703
704
705

706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722

723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
	memcpy(newVarName, part1, (unsigned int) closeParen);
	newVarName[openParen] = '\0';
	newVarName[closeParen] = '\0';
	part1 = newVarName;
	elName = newVarName + openParen + 1;
    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1,
	    &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    TclVarErrMsg(interp, part1, elName, msg, errMsg);
	}
    } else {
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	if (elName != NULL) {
	    *arrayPtrPtr = varPtr;
	    varPtr = TclLookupArrayElement(interp, part1, elName, flags,
		    msg, createPart1, createPart2, varPtr);
	}
    }
    if (newVarName != buffer) {
	ckfree(newVarName);
    }

    return varPtr;

#undef VAR_NAME_BUF_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjLookupVar --
 *
 *	This procedure is used by virtually all of the variable code to locate
 *	a variable given its name(s). The parsing into array/element
 *	components and (if possible) the lookup results are cached in
 *	part1Ptr, which is converted to one of the varNameTypes.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1Ptr and part2, or NULL if the variable couldn't be found. If *
 *	the variable is found, *arrayPtrPtr is filled with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED even
 *	if createPart1 or createPart2 are 1 (these only cause the hash table
 *	entry or array to be created). For example, the variable might be a
 *	global that has been unset but is still referenced by a procedure, or
 *	a variable that has been unset but it only being kept in existence (if
 *	VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2

 *	are 1. The object part1Ptr is converted to one of localVarNameType,
 *	tclNsVarNameType or tclParsedVarNameType and caches as much of the
 *	lookup as it can.
 *
 *----------------------------------------------------------------------
 */

Var *
TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
	arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    register Tcl_Obj *part1Ptr;	/* If part2 isn't NULL, this is the name of an
				 * array. Otherwise, this is a full variable
				 * name that could include a parenthesized
				 * array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST char *msg;		/* Verb to use in error messages, e.g. "read"
				 * or "set". Only needed if TCL_LEAVE_ERR_MSG
				 * is set in flags. */
    CONST int createPart1;	/* If 1, create hash table entry for part 1 of
				 * name, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    CONST int createPart2;	/* If 1, create hash table entry for part 2 of
				 * name, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    Var **arrayPtrPtr;		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    char *part1;
    int index, len1, len2;
    int parsed = 0;
    Tcl_Obj *objPtr;
    Tcl_ObjType *typePtr = part1Ptr->typePtr;
    CONST char *errMsg = NULL;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Namespace *nsPtr;

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
     * parts.
     */

    *arrayPtrPtr = NULL;
    if (typePtr == &tclParsedVarNameType) {
	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
	    if (part2 != NULL) {
		/*
		 * ERROR: part1Ptr is already an array element, cannot specify
		 * a part2.
		 */

		if (flags & TCL_LEAVE_ERR_MSG) {
		    part1 = TclGetString(part1Ptr);
		    TclVarErrMsg(interp, part1, part2, msg, needArray);
		}
		return NULL;
	    }
	    part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
	    part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
	    typePtr = part1Ptr->typePtr;
	}
	parsed = 1;
    }
    part1 = Tcl_GetStringFromObj(part1Ptr, &len1);

    nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
    if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
	goto doParse;
    }

    if (typePtr == &localVarNameType) {
	int localIndex = (int) part1Ptr->internalRep.longValue;

	if ((varFramePtr != NULL)
		&& (varFramePtr->isProcCallFrame & FRAME_IS_PROC)
		&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		&& (localIndex < varFramePtr->numCompiledLocals)) {
	    /*
	     * use the cached index if the names coincide.
	     */

	    varPtr = &(varFramePtr->compiledLocals[localIndex]);
	    if ((varPtr->name != NULL) && (strcmp(part1, varPtr->name) == 0)) {

		goto donePart1;
	    }
	}
	goto doneParsing;
#if ENABLE_NS_VARNAME_CACHING
    } else if (typePtr == &tclNsVarNameType) {

	int useGlobal, useReference;
	Namespace *cachedNsPtr = (Namespace *)
		part1Ptr->internalRep.twoPtrValue.ptr1;
	varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;

	useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && (
		(flags & TCL_GLOBAL_ONLY) ||
		(*part1==':' && *(part1+1)==':') ||
		(varFramePtr == NULL) ||
		(!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
			&& (nsPtr == iPtr->globalNsPtr)));

	useReference = useGlobal || ((cachedNsPtr == nsPtr) && (
		(flags & TCL_NAMESPACE_ONLY) ||
		(varFramePtr &&
		!(varFramePtr->isProcCallFrame & FRAME_IS_PROC) &&
		!(flags & TCL_GLOBAL_ONLY) &&
		/* Careful: an undefined ns variable could be hiding a valid
		 * global reference. */
		!TclIsVarUndefined(varPtr))));

	if (useReference && (varPtr->hPtr != NULL)) {
	    /*
	     * A straight global or namespace reference, use it. It isn't so
	     * simple to deal with 'implicit' namespace references, i.e.,
	     * those where the reference could be to either a namespace or a
	     * global variable. Those we lookup again.
	     *
	     * If (varPtr->hPtr == NULL), this might be a reference to a
	     * variable in a deleted namespace, kept alive by e.g. part1Ptr.
	     * We could conceivably be so unlucky that a new namespace was
	     * created at the same address as the deleted one, so to be safe
	     * we test for a valid hPtr.
	     */

	    goto donePart1;
	}
	goto doneParsing;
#endif
    }

  doParse:
    if (!parsed && (*(part1 + len1 - 1) == ')')) {
	/*
	 * part1Ptr is possibly an unparsed array element.
	 */

	register int i;
	char *newPart2;

	len2 = -1;
	for (i = 0; i < len1; i++) {
	    if (*(part1 + i) == '(') {
		if (part2 != NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			TclVarErrMsg(interp, part1, part2, msg, needArray);
		    }
		}

		/*
		 * part1Ptr points to an array element; first copy the element
		 * name to a new string part2.
		 */

		part2 = part1 + i + 1;
		len2 = len1 - i - 2;
		len1 = i;

		newPart2 = ckalloc((unsigned int) (len2+1));
		memcpy(newPart2, part2, (unsigned int) len2);
		*(newPart2+len2) = '\0';
		part2 = newPart2;

		/*
		 * Free the internal rep of the original part1Ptr, now renamed
		 * objPtr, and set it to tclParsedVarNameType.
		 */

		objPtr = part1Ptr;
		TclFreeIntRep(objPtr);
		objPtr->typePtr = &tclParsedVarNameType;

		/*
		 * Define a new string object to hold the new part1Ptr, i.e.,
		 * the array name. Set the internal rep of objPtr, reset
		 * typePtr and part1 to contain the references to the array
		 * name.
		 */

		TclNewStringObj(part1Ptr, part1, len1);
		Tcl_IncrRefCount(part1Ptr);

		objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
		objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;

		typePtr = part1Ptr->typePtr;
		part1 = TclGetString(part1Ptr);
		break;
	    }
	}
    }

  doneParsing:
    /*
     * part1Ptr is not an array element; look it up, and convert it to one of
     * the cached types if possible.
     */

    TclFreeIntRep(part1Ptr);
    part1Ptr->typePtr = NULL;

    varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1,
	    &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    TclVarErrMsg(interp, part1, part2, msg, errMsg);
	}
	return NULL;
    }

    /*
     * Cache the newly found variable if possible.
     */

    if (index >= 0) {
	/*
	 * An indexed local variable.
	 */

	part1Ptr->typePtr = &localVarNameType;
	part1Ptr->internalRep.longValue = (long) index;
#if ENABLE_NS_VARNAME_CACHING
    } else if (index > -3) {
	/*
	 * A cacheable namespace or global variable.
	 */

	Namespace *nsPtr;

	nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
	varPtr->refCount++;
	part1Ptr->typePtr = &tclNsVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
	part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
#endif
    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */

	part1Ptr->typePtr = &tclParsedVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
	part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
    }

  donePart1:
#if 0
    if (varPtr == NULL) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    part1 = TclGetString(part1Ptr);
	    TclVarErrMsg(interp, part1, part2, msg,
		    "Cached variable reference is NULL.");
	}
	return NULL;
    }
#endif
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    if (part2 != NULL) {
	/*
	 * Array element sought: look it up.
	 */

	part1 = TclGetString(part1Ptr);
	*arrayPtrPtr = varPtr;
	varPtr = TclLookupArrayElement(interp, part1, part2, flags, msg,
		createPart1, createPart2, varPtr);
    }
    return varPtr;
}

/*
 * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
 * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for
 * upvar (or similar) purposes, with slightly different rules:
 *    - Bug #696893 - variable is either proc-local or in the current
 *	namespace; never follow the second (global) resolution path
 *    - Bug #631741 - do not use special namespace or interp resolvers
 *
 * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag
 * (Bug #835020)
 */

#define LOOKUP_FOR_UPVAR 0x40000

/*
 *----------------------------------------------------------------------
 *
 * TclLookupSimpleVar --
 *
 *	This procedure is used by to locate a simple variable (i.e., not an
 *	array element) given its name.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	varName, or NULL if the variable couldn't be found. If the variable
 *	can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED)
 *	variable structure is created, entered into a hash table, and
 *	returned.
 *
 *	If the current CallFrame corresponds to a proc and the variable found
 *	is one of the compiledLocals, its index is placed in *indexPtr.
 *	Otherwise, *indexPtr will be set to (according to the needs of
 *	TclObjLookupVar):
 *	    -1 a global reference
 *	    -2 a reference to a namespace variable
 *	    -3 a non-cachable reference, i.e., one of:
 *		. non-indexed local var
 *		. a reference of unknown origin;
 *		. resolution by a namespace or interp resolver
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and the corresponding error
 *	message is left in *errMsgPtr.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED even
 *	if create is 1 (this only causes the hash table entry to be created).
 *	For example, the variable might be a global that has been unset but is
 *	still referenced by a procedure, or a variable that has been unset but
 *	it only being kept in existence (if VAR_UNDEFINED) by a trace.

 *
 * Side effects:
 *	A new hashtable entry may be created if create is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *varName;	/* This is a simple variable name that could
				 * represent a scalar or an array. */
    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits
				 * matter. */
    CONST int create;		/* If 1, create hash table entry for varname,
				 * if it doesn't already exist. If 0, return
				 * error if it doesn't exist. */
    CONST char **errMsgPtr;
    int *indexPtr;
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as the
				 * current procedure's frame, if any, unless
				 * an "uplevel" is executing. */
    Tcl_HashTable *tablePtr;	/* Points to the hashtable, if any, in which
				 * to look up the variable. */
    Tcl_Var var;		/* Used to search for global names. */
    Var *varPtr;		/* Points to the Var structure returned for
				 * the variable. */
    Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
    ResolverScheme *resPtr;
    Tcl_HashEntry *hPtr;
    int new, i, result;

    varPtr = NULL;
    varNsPtr = NULL;		/* set non-NULL if a nonlocal variable */
    *indexPtr = -3;

    if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
	cxtNsPtr = iPtr->globalNsPtr;
    } else {
	cxtNsPtr = iPtr->varFramePtr->nsPtr;
    }

    /*
     * If this namespace has a variable resolver, then give it first crack at
     * the variable resolution.  It may return a Tcl_Var value, it may signal
     * to continue onward, or it may signal an error.

     */

    if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)
	    && !(flags & LOOKUP_FOR_UPVAR)) {
	resPtr = iPtr->resolverPtr;

	if (cxtNsPtr->varResProc) {
	    result = (*cxtNsPtr->varResProc)(interp, varName,
		    (Tcl_Namespace *) cxtNsPtr, flags, &var);
	} else {
	    result = TCL_CONTINUE;
	}

	while (result == TCL_CONTINUE && resPtr) {
	    if (resPtr->varResProc) {
		result = (*resPtr->varResProc)(interp, varName,
			(Tcl_Namespace *) cxtNsPtr, flags, &var);
	    }
	    resPtr = resPtr->nextPtr;
	}

	if (result == TCL_OK) {
	    return (Var *) var;

	} else if (result != TCL_CONTINUE) {
	    return NULL;
	}
    }

    /*
     * Look up varName. Look it up as either a namespace variable or as a
     * local variable in a procedure call frame (varFramePtr).  Interpret
     * varName as a namespace variable if:
     *    1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
     *    2) there is no active frame (we're at the global :: scope),
     *    3) the active frame was pushed to define the namespace context for a
     *	     "namespace eval" or "namespace inscope" command,
     *    4) the name has namespace qualifiers ("::"s).
     * Otherwise, if varName is a local variable, search first in the frame's
     * array of compiler-allocated local variables, then in its hashtable for
     * runtime-created local variables.
     *
     * If create and the variable isn't found, create the variable and, if
     * necessary, create varFramePtr's local var hashtable.
     */

    if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
	    || (varFramePtr == NULL)
	    || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
	    || (strstr(varName, "::") != NULL)) {
	CONST char *tail;
	int lookGlobal;

	lookGlobal = (flags & TCL_GLOBAL_ONLY)
		|| (cxtNsPtr == iPtr->globalNsPtr)
		|| ((*varName == ':') && (*(varName+1) == ':'));
	if (lookGlobal) {
	    *indexPtr = -1;
	    flags = (flags | TCL_GLOBAL_ONLY) &
		    ~(TCL_NAMESPACE_ONLY | LOOKUP_FOR_UPVAR);
	} else {
	    if (flags & LOOKUP_FOR_UPVAR) {
		flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR;
	    }
	    if (flags & TCL_NAMESPACE_ONLY) {
		*indexPtr = -2;
	    }
	}

	/*
	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or
	 * otherwise generate our own error!
	 */

	var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
		flags & ~TCL_LEAVE_ERR_MSG);

	if (var != (Tcl_Var) NULL) {
	    varPtr = (Var *) var;
	}

	if (varPtr == NULL) {
	    if (create) {	/* var wasn't found so create it  */
		TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
			flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
		if (varNsPtr == NULL) {
		    *errMsgPtr = badNamespace;
		    return NULL;
		}
		if (tail == NULL) {
		    *errMsgPtr = missingName;
		    return NULL;
		}
		hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = varNsPtr;
		if (lookGlobal) {
		    /*
		     * The variable was created starting from the global
		     * namespace: a global reference is returned even if it
		     * wasn't explicitly requested.
		     */

		    *indexPtr = -1;
		} else {
		    *indexPtr = -2;
		}
	    } else {		/* var wasn't found and not to create it */
		*errMsgPtr = noSuchVar;
		return NULL;
	    }
	}
    } else {			/* local var: look in frame varFramePtr */
	Proc *procPtr = varFramePtr->procPtr;
	int localCt = procPtr->numCompiledLocals;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	Var *localVarPtr = varFramePtr->compiledLocals;
	int varNameLen = strlen(varName);

	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		register char *localName = localVarPtr->name;
		if ((varName[0] == localName[0])
			&& (varNameLen == localPtr->nameLength)
			&& (strcmp(varName, localName) == 0)) {
		    *indexPtr = i;
		    return localVarPtr;
		}
	    }
	    localVarPtr++;
	    localPtr = localPtr->nextPtr;
	}
	tablePtr = varFramePtr->varTablePtr;
	if (create) {
	    if (tablePtr == NULL) {
		tablePtr = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
		Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
		varFramePtr->varTablePtr = tablePtr;
	    }
	    hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
	    if (new) {
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = NULL;	/* a local variable */
	    } else {
		varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }
	} else {
	    hPtr = NULL;
	    if (tablePtr != NULL) {
		hPtr = Tcl_FindHashEntry(tablePtr, varName);
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936

937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupArrayElement --
 *
 *	This procedure is used to locate a variable which is in an array's 
 *      hashtable given a pointer to the array's Var structure and the 
 *      element's name.
 *
 * Results:
 *	The return value is a pointer to the variable structure , or NULL if 
 *      the variable couldn't be found. 
 *
 *      If arrayPtr points to a variable that isn't an array and createPart1 
 *      is 1, the corresponding variable will be converted to an array. 
 *      Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *      If the variable is not found and createPart2 is 1, the variable is
 *      created. Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if createPart1 or createPart2 are 1 (these only cause the hash
 *	table entry or array to be created). For example, the variable might
 *	be a global that has been unset but is still referenced by a
 *	procedure, or a variable that has been unset but it only being kept
 *	in existence (if VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *      The variable at arrayPtr may be converted to be an array if 
 *      createPart1 is 1. A new hashtable entry may be created if createPart2 
 *      is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *arrayName;	        /* This is the name of the array. */
    CONST char *elName;		/* Name of element within array. */
    CONST int flags;		/* Only TCL_LEAVE_ERR_MSG bit matters. */
    CONST char *msg;			/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    CONST int createArray;	/* If 1, transform arrayName to be an array
				 * if it isn't one yet and the transformation 
				 * is possible. If 0, return error if it 
				 * isn't already an array. */
    CONST int createElem;	/* If 1, create hash table entry for the 
				 * element, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    Var *arrayPtr;	        /* Pointer to the array's Var structure. */
{
    Tcl_HashEntry *hPtr;
    int new;
    Var *varPtr;

    /*
     * We're dealing with an array element. Make sure the variable is an
     * array and look up the element (create the element if desired).
     */

    if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
	if (!createArray) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		TclVarErrMsg(interp, arrayName, elName, msg, noSuchVar);
	    }
	    return NULL;
	}

	/*
	 * Make sure we are not resurrecting a namespace variable from a
	 * deleted namespace!
	 */

	if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		TclVarErrMsg(interp, arrayName, elName, msg, danglingVar);
	    }
	    return NULL;
	}

	TclSetVarArray(arrayPtr);
	TclClearVarUndefined(arrayPtr);
	arrayPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
    } else if (!TclIsVarArray(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclVarErrMsg(interp, arrayName, elName, msg, needArray);
	}
	return NULL;
    }







|
|
|


|
|

|
|
|
|

|
|


|
|
|
|
|
|


|
|
|







|


|
|
|
|
|
|
|
|
|
|
|






|
|














>









|
|







863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupArrayElement --
 *
 *	This procedure is used to locate a variable which is in an array's
 *	hashtable given a pointer to the array's Var structure and the
 *	element's name.
 *
 * Results:
 *	The return value is a pointer to the variable structure , or NULL if
 *	the variable couldn't be found.
 *
 *	If arrayPtr points to a variable that isn't an array and createPart1
 *	is 1, the corresponding variable will be converted to an array.
 *	Otherwise, NULL is returned and an error message is left in the
 *	interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	If the variable is not found and createPart2 is 1, the variable is
 *	created. Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED even
 *	if createPart1 or createPart2 are 1 (these only cause the hash table
 *	entry or array to be created). For example, the variable might be a
 *	global that has been unset but is still referenced by a procedure, or
 *	a variable that has been unset but it only being kept in existence (if
 *	VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	The variable at arrayPtr may be converted to be an array if
 *	createPart1 is 1. A new hashtable entry may be created if createPart2
 *	is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *arrayName;	/* This is the name of the array. */
    CONST char *elName;		/* Name of element within array. */
    CONST int flags;		/* Only TCL_LEAVE_ERR_MSG bit matters. */
    CONST char *msg;		/* Verb to use in error messages, e.g.  "read"
				 * or "set". Only needed if TCL_LEAVE_ERR_MSG
				 * is set in flags. */
    CONST int createArray;	/* If 1, transform arrayName to be an array if
				 * it isn't one yet and the transformation is
				 * possible. If 0, return error if it isn't
				 * already an array. */
    CONST int createElem;	/* If 1, create hash table entry for the
				 * element, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    Var *arrayPtr;		/* Pointer to the array's Var structure. */
{
    Tcl_HashEntry *hPtr;
    int new;
    Var *varPtr;

    /*
     * We're dealing with an array element. Make sure the variable is an array
     * and look up the element (create the element if desired).
     */

    if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
	if (!createArray) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		TclVarErrMsg(interp, arrayName, elName, msg, noSuchVar);
	    }
	    return NULL;
	}

	/*
	 * Make sure we are not resurrecting a namespace variable from a
	 * deleted namespace!
	 */

	if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		TclVarErrMsg(interp, arrayName, elName, msg, danglingVar);
	    }
	    return NULL;
	}

	TclSetVarArray(arrayPtr);
	TclClearVarUndefined(arrayPtr);
	arrayPtr->value.tablePtr = (Tcl_HashTable *)
		ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
    } else if (!TclIsVarArray(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclVarErrMsg(interp, arrayName, elName, msg, needArray);
	}
	return NULL;
    }
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098

1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155

1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
 *
 * Tcl_GetVar --
 *
 *	Return the value of a Tcl variable as a string.
 *
 * Results:
 *	The return value points to the current value of varName as a string.
 *	If the variable is not defined or can't be read because of a clash
 *	in array usage then a NULL pointer is returned and an error message
 *	is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
 *	Note: the return value is only valid up until the next change to the
 *	variable; if you depend on the value lasting longer than that, then
 *	make yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
				 * bits. */
{
    return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2 --
 *
 *	Return the value of a Tcl variable as a string, given a two-part
 *	name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current value of the variable given
 *	by part1 and part2 as a string. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interp's result if the
 *	TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid
 *	up until the next change to the variable; if you depend on the value
 *	lasting longer than that, then make yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
                                 * bits. */
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
    if (objPtr == NULL) {
	return NULL;
    }
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2Ex --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a
 *	two-part name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetVar2Ex(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;

    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */

    varPtr = TclLookupVar(interp, part1, part2, flags, "read",
            /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjGetVar2 --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a
 *	two-part name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register Tcl_Obj *part1Ptr;	/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));
    
    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
            /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrGetVar --
 *
 *	Return the value of a Tcl variable as a Tcl object, given the
 *      pointers to the variable's (and possibly containing array's) 
 *      VAR structure.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by varPtr. If the specified variable doesn't exist, or if there 
 *      is a clash in array usage, then NULL is returned and a message will be 
 *      left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register Var *varPtr;       /* The variable to be read.*/
    Var *arrayPtr;              /* NULL for scalar variables, pointer to
				 * the containing array otherwise. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    CONST int flags;		/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits. */
{
    Interp *iPtr = (Interp *) interp;
    CONST char *msg;

    /*
     * Invoke any traces that have been set for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
		| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto errorReturn;
	}
    }

    /*
     * Return the element if it's an existing scalar variable.
     */
    
    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }
    
    if (flags & TCL_LEAVE_ERR_MSG) {
	if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
	        && !TclIsVarUndefined(arrayPtr)) {
	    msg = noSuchElement;
	} else if (TclIsVarArray(varPtr)) {
	    msg = isArray;
	} else {
	    msg = noSuchVar;
	}
	TclVarErrMsg(interp, part1, part2, "read", msg);
    }

    /*
     * An error. If the variable doesn't exist anymore and no-one's using
     * it, then free up the relevant structures and hash table entries.
     */

    errorReturn:
    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjCmd --
 *
 *	This procedure is invoked to process the "set" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SetObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Obj *varValueObj;

    if (objc == 2) {
	varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
	if (varValueObj == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, varValueObj);
	return TCL_OK;
    } else if (objc == 3) {

	varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
		TCL_LEAVE_ERR_MSG);
	if (varValueObj == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, varValueObj);
	return TCL_OK;







|
|
|












|
|













|
|


|
|
|
|
|
|
|









|
|
|
|



|
|















|
|









|
|
|






|
|
|
|


|
|








>

|













|
|









|
|
|






|
|
|
|
|











|





>

|













|
|
<



|
|
|


|
|
|






|
|
|
|
|
|
|


|
|




















|



|


|










|
|


|











|
|













|
|
|
|











<







987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179

1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291

1292
1293
1294
1295
1296
1297
1298
 *
 * Tcl_GetVar --
 *
 *	Return the value of a Tcl variable as a string.
 *
 * Results:
 *	The return value points to the current value of varName as a string.
 *	If the variable is not defined or can't be read because of a clash in
 *	array usage then a NULL pointer is returned and an error message is
 *	left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
 *	Note: the return value is only valid up until the next change to the
 *	variable; if you depend on the value lasting longer than that, then
 *	make yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is to
				 * be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
				 * bits. */
{
    return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2 --
 *
 *	Return the value of a Tcl variable as a string, given a two-part name
 *	consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current value of the variable given by
 *	part1 and part2 as a string. If the specified variable doesn't exist,
 *	or if there is a clash in array usage, then NULL is returned and a
 *	message will be left in the interp's result if the TCL_LEAVE_ERR_MSG
 *	flag is set. Note: the return value is only valid up until the next
 *	change to the variable; if you depend on the value lasting longer than
 *	that, then make yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be looked up. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
				 * bits. */
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
    if (objPtr == NULL) {
	return NULL;
    }
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2Ex --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a two-part
 *	name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to reflect
 *	the returned reference; if you want to keep a reference to the object
 *	you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetVar2Ex(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be looked up. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY, and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;

    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */

    varPtr = TclLookupVar(interp, part1, part2, flags, "read",
	    /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjGetVar2 --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a two-part
 *	name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to reflect
 *	the returned reference; if you want to keep a reference to the object
 *	you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be looked up. */
    register Tcl_Obj *part1Ptr;	/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));

    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
	    /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrGetVar --
 *
 *	Return the value of a Tcl variable as a Tcl object, given the pointers
 *	to the variable's (and possibly containing array's) VAR structure.

 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by varPtr. If the specified variable doesn't exist, or if there
 *	is a clash in array usage, then NULL is returned and a message will be
 *	left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to reflect
 *	the returned reference; if you want to keep a reference to the object
 *	you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be looked up. */
    register Var *varPtr;	/* The variable to be read.*/
    Var *arrayPtr;		/* NULL for scalar variables, pointer to the
				 * containing array otherwise. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    CONST int flags;		/* OR-ed combination of TCL_GLOBAL_ONLY, and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Interp *iPtr = (Interp *) interp;
    CONST char *msg;

    /*
     * Invoke any traces that have been set for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
		| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto errorReturn;
	}
    }

    /*
     * Return the element if it's an existing scalar variable.
     */

    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }

    if (flags & TCL_LEAVE_ERR_MSG) {
	if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
		&& !TclIsVarUndefined(arrayPtr)) {
	    msg = noSuchElement;
	} else if (TclIsVarArray(varPtr)) {
	    msg = isArray;
	} else {
	    msg = noSuchVar;
	}
	TclVarErrMsg(interp, part1, part2, "read", msg);
    }

    /*
     * An error. If the variable doesn't exist anymore and no-one's using it,
     * then free up the relevant structures and hash table entries.
     */

  errorReturn:
    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjCmd --
 *
 *	This procedure is invoked to process the "set" Tcl command.  See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SetObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    register Tcl_Interp *interp;/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *varValueObj;

    if (objc == 2) {
	varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
	if (varValueObj == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, varValueObj);
	return TCL_OK;
    } else if (objc == 3) {

	varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
		TCL_LEAVE_ERR_MSG);
	if (varValueObj == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, varValueObj);
	return TCL_OK;
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
 *	modify this string. If the write operation was disallowed then NULL
 *	is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
 *	explanatory message will be left in the interp's result. Note that the
 *	returned string may not be the same as newValue; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	If varName is defined as a local or global variable in interp,
 *	its value is changed to newValue. If varName isn't currently
 *	defined, then a new global variable by that name is created.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    CONST char *newValue;	/* New value for varName. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2 --
 *
 *      Given a two-part variable name, which may refer either to a
 *      scalar variable or an element of an array, change the value
 *      of the variable.  If the named scalar or array or element
 *      doesn't exist then create one.
 *
 * Results:
 *	Returns a pointer to the malloc'ed string which is the character
 *	representation of the variable's new value. The caller must not
 *	modify this string. If the write operation was disallowed because an
 *	array was expected but not found (or vice versa), then NULL is
 *	returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
 *	message will be left in the interp's result. Note that the returned
 *	string may not be the same as newValue; this is because variable
 *	traces may modify the variable's value.
 *
 * Side effects:
 *      The value of the given variable is set. If either the array
 *      or the entry didn't exist then a new one is created.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
    Tcl_Interp *interp;         /* Command interpreter in which variable is
                                 * to be looked up. */
    CONST char *part1;          /* If part2 is NULL, this is name of scalar
                                 * variable. Otherwise it is the name of
                                 * an array. */
    CONST char *part2;		/* Name of an element within an array, or
				 * NULL. */
    CONST char *newValue;       /* New value for variable. */
    int flags;                  /* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */
{
    register Tcl_Obj *valuePtr;
    Tcl_Obj *varValuePtr;

    /*
     * Create an object holding the variable's new value and use
     * Tcl_SetVar2Ex to actually set the variable.
     */

    valuePtr = Tcl_NewStringObj(newValue, -1);
    Tcl_IncrRefCount(valuePtr);

    varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags);
    Tcl_DecrRefCount(valuePtr); /* done with the object */
    
    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2Ex --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, change the value of the variable
 *	to a new Tcl object value. If the named scalar or array or element
 *	doesn't exist then create one.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if
 *	the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
 *	be left in the interpreter's result. Note that the returned object
 *	may not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *	The reference count is decremented for any old value of the variable
 *	and incremented for its new value. If the new value for the variable
 *	is not the same one referenced by newValuePtr (perhaps as a result
 *	of a variable trace), then newValuePtr's ref count is left unchanged
 *	by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
 *	we are appending it as a string value: that is, if "flags" includes
 *	TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
 *
 *	The reference count for the returned object is _not_ incremented: if
 *	you want to keep a reference to the object you must increment its
 *	ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;

    varPtr = TclLookupVar(interp, part1, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, 
            newValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjSetVar2 --
 *
 *	This function is the same as Tcl_SetVar2Ex above, except the
 *	variable names are passed in Tcl object instead of strings.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if
 *	the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
 *	be left in the interpreter's result. Note that the returned object
 *	may not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    register Tcl_Obj *part1Ptr;	/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));    

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, 
            newValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrSetVar --
 *
 *	This function is the same as Tcl_SetVar2Ex above, except that
 *      it requires pointers to the variable's Var structs in addition
 *	to the variable names.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if
 *	the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
 *	be left in the interpreter's result. Note that the returned object
 *	may not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    CONST int flags;		/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;
    int result;

    /*
     * If the variable is in a hashtable and its hPtr field is NULL, then we
     * may have an upvar to an array element where the array was deleted
     * or an upvar to a namespace variable whose namespace was deleted.
     * Generate an error (allowing the variable to be reset would screw up
     * our storage allocation and is meaningless anyway).
     */

    if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArrayElement(varPtr)) {
		TclVarErrMsg(interp, part1, part2, "set", danglingElement);
	    } else {







|
|
|






|
|



|
|
|









|
|
|
<



|
|
|
|
|
|
|


|
|






|
|
|
|
|


|
|
|
|
|





|
|






|
|



















|
|
|
|








|
|
|
|



|
|






|
|
|
|




|
|
|









|
|







|
|




|
|
|
|











|
|
|
|
|





|
|
|





|







|
|







|
|
|




|
|
|
|











|
|


|
|



|
|








|
|
|
|







1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350

1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
 *	modify this string. If the write operation was disallowed then NULL
 *	is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
 *	explanatory message will be left in the interp's result. Note that the
 *	returned string may not be the same as newValue; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	If varName is defined as a local or global variable in interp, its
 *	value is changed to newValue. If varName isn't currently defined, then
 *	a new global variable by that name is created.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is to
				 * be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    CONST char *newValue;	/* New value for varName. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2 --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, change the value of the variable.
 *	If the named scalar or array or element doesn't exist then create one.

 *
 * Results:
 *	Returns a pointer to the malloc'ed string which is the character
 *	representation of the variable's new value. The caller must not modify
 *	this string. If the write operation was disallowed because an array
 *	was expected but not found (or vice versa), then NULL is returned; if
 *	the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be
 *	left in the interp's result. Note that the returned string may not be
 *	the same as newValue; this is because variable traces may modify the
 *	variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new one is created.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be looked up. */
    CONST char *part1;		/* If part2 is NULL, this is name of scalar
				 * variable. Otherwise it is the name of an
				 * array. */
    CONST char *part2;		/* Name of an element within an array, or
				 * NULL. */
    CONST char *newValue;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
				 * TCL_LEAVE_ERR_MSG */
{
    register Tcl_Obj *valuePtr;
    Tcl_Obj *varValuePtr;

    /*
     * Create an object holding the variable's new value and use Tcl_SetVar2Ex
     * to actually set the variable.
     */

    valuePtr = Tcl_NewStringObj(newValue, -1);
    Tcl_IncrRefCount(valuePtr);

    varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags);
    TclDecrRefCount(valuePtr); /* done with the object */

    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2Ex --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, change the value of the variable
 *	to a new Tcl object value. If the named scalar or array or element
 *	doesn't exist then create one.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if the
 *	TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be
 *	left in the interpreter's result. Note that the returned object may
 *	not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *	The reference count is decremented for any old value of the variable
 *	and incremented for its new value. If the new value for the variable
 *	is not the same one referenced by newValuePtr (perhaps as a result of
 *	a variable trace), then newValuePtr's ref count is left unchanged by
 *	Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if we
 *	are appending it as a string value: that is, if "flags" includes
 *	TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
 *
 *	The reference count for the returned object is _not_ incremented: if
 *	you want to keep a reference to the object you must increment its ref
 *	count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
				 * TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;

    varPtr = TclLookupVar(interp, part1, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
	    newValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjSetVar2 --
 *
 *	This function is the same as Tcl_SetVar2Ex above, except the variable
 *	names are passed in Tcl object instead of strings.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if the
 *	TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be
 *	left in the interpreter's result. Note that the returned object may
 *	not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    register Tcl_Obj *part1Ptr;	/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
				 * TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
	    newValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrSetVar --
 *
 *	This function is the same as Tcl_SetVar2Ex above, except that it
 *	requires pointers to the variable's Var structs in addition to the
 *	variable names.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if the
 *	TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be
 *	left in the interpreter's result. Note that the returned object may
 *	not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be looked up. */
    register Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    CONST int flags;		/* OR-ed combination of TCL_GLOBAL_ONLY, and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;
    int result;

    /*
     * If the variable is in a hashtable and its hPtr field is NULL, then we
     * may have an upvar to an array element where the array was deleted or an
     * upvar to a namespace variable whose namespace was deleted.  Generate an
     * error (allowing the variable to be reset would screw up our storage
     * allocation and is meaningless anyway).
     */

    if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArrayElement(varPtr)) {
		TclVarErrMsg(interp, part1, part2, "set", danglingElement);
	    } else {
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717

1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclVarErrMsg(interp, part1, part2, "set", isArray);
	}
	return NULL;
    }

    /*
     * Invoke any read traces that have been set for the variable if it
     * is requested; this is only done in the core when lappending.
     */

    if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) 
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    return NULL;
	}
    }

    /*
     * Set the variable's new value. If appending, append the new value to
     * the variable, either as a list element or as a string. Also, if
     * appending, then if the variable's old value is unshared we can modify
     * it directly, otherwise we must create a new copy to modify: this is
     * "copy on write".
     */

    if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
	TclSetVarUndefined(varPtr);
    }
    oldValuePtr = varPtr->value.objPtr;
    if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
	    varPtr->value.objPtr = NULL;
	    oldValuePtr = NULL;
	}
	if (flags & TCL_LIST_ELEMENT) {	       /* append list element */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		Tcl_DecrRefCount(oldValuePtr);
		oldValuePtr = varPtr->value.objPtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    }
	    result = Tcl_ListObjAppendElement(interp, oldValuePtr,
		    newValuePtr);
	    if (result != TCL_OK) {
		return NULL;
	    }
	} else {		               /* append string */
	    /*
	     * We append newValuePtr's bytes but don't change its ref count.
	     */

	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {   /* append to copy */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		    TclDecrRefCount(oldValuePtr);
		    oldValuePtr = varPtr->value.objPtr;
		    Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
		}
		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
	    }
	}
    } else if (newValuePtr != oldValuePtr) {
	/*
	 * In this case we are replacing the value, so we don't need to
	 * do more than swap the objects.
	 */

	varPtr->value.objPtr = newValuePtr;
	Tcl_IncrRefCount(newValuePtr);      /* var is another ref */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);   /* discard old value */
	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);
    if (arrayPtr != NULL) {
	TclClearVarUndefined(arrayPtr);
    }

    /*
     * Invoke any write traces for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
	        (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto cleanup;
	}
    }

    /*
     * Return the variable's value unless the variable was changed in some
     * gross way by a trace (e.g. it was unset and then recreated as an
     * array). 
     */

    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }

    /*
     * A trace changed the value in some gross way. Return an empty string
     * object.
     */
    
    resultPtr = iPtr->emptyObjPtr;

    /*
     * If the variable doesn't exist anymore and no-one's using it, then
     * free up the relevant structures and hash table entries.
     */

    cleanup:
    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
    }
    return resultPtr;
}


/*
 *----------------------------------------------------------------------
 *
 * TclIncrVar2 --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, increment the Tcl object value
 *	of the variable by a specified amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in
 *	the interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    Tcl_Obj *part1Ptr;		/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    Tcl_Obj *part2Ptr;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    long incrAmount;		/* Amount to be added to variable. */
    int flags;                  /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));








|
|


|








|
|
|
|
<








|



|



|


|

|






|








|



|






|
|



|

|















|








|










|



|
|


|





>







|
|



|

|
|













|
|
|
|
|




|
|
|
|







1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615

1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclVarErrMsg(interp, part1, part2, "set", isArray);
	}
	return NULL;
    }

    /*
     * Invoke any read traces that have been set for the variable if it is
     * requested; this is only done in the core when lappending.
     */

    if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    return NULL;
	}
    }

    /*
     * Set the variable's new value. If appending, append the new value to the
     * variable, either as a list element or as a string. Also, if appending,
     * then if the variable's old value is unshared we can modify it directly,
     * otherwise we must create a new copy to modify: this is "copy on write".

     */

    if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
	TclSetVarUndefined(varPtr);
    }
    oldValuePtr = varPtr->value.objPtr;
    if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
	    TclDecrRefCount(oldValuePtr);	/* discard old value */
	    varPtr->value.objPtr = NULL;
	    oldValuePtr = NULL;
	}
	if (flags & TCL_LIST_ELEMENT) {		/* append list element */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr);	/* since var is referenced */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		TclDecrRefCount(oldValuePtr);
		oldValuePtr = varPtr->value.objPtr;
		Tcl_IncrRefCount(oldValuePtr);	/* since var is referenced */
	    }
	    result = Tcl_ListObjAppendElement(interp, oldValuePtr,
		    newValuePtr);
	    if (result != TCL_OK) {
		return NULL;
	    }
	} else {				/* append string */
	    /*
	     * We append newValuePtr's bytes but don't change its ref count.
	     */

	    if (oldValuePtr == NULL) {
		varPtr->value.objPtr = newValuePtr;
		Tcl_IncrRefCount(newValuePtr);
	    } else {
		if (Tcl_IsShared(oldValuePtr)) {    /* append to copy */
		    varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		    TclDecrRefCount(oldValuePtr);
		    oldValuePtr = varPtr->value.objPtr;
		    Tcl_IncrRefCount(oldValuePtr);  /* since var is ref */
		}
		Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
	    }
	}
    } else if (newValuePtr != oldValuePtr) {
	/*
	 * In this case we are replacing the value, so we don't need to do
	 * more than swap the objects.
	 */

	varPtr->value.objPtr = newValuePtr;
	Tcl_IncrRefCount(newValuePtr);		/* var is another ref */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);	/* discard old value */
	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);
    if (arrayPtr != NULL) {
	TclClearVarUndefined(arrayPtr);
    }

    /*
     * Invoke any write traces for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto cleanup;
	}
    }

    /*
     * Return the variable's value unless the variable was changed in some
     * gross way by a trace (e.g. it was unset and then recreated as an
     * array).
     */

    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }

    /*
     * A trace changed the value in some gross way. Return an empty string
     * object.
     */

    resultPtr = iPtr->emptyObjPtr;

    /*
     * If the variable doesn't exist anymore and no-one's using it, then free
     * up the relevant structures and hash table entries.
     */

  cleanup:
    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
    }
    return resultPtr;
}
#if 0

/*
 *----------------------------------------------------------------------
 *
 * TclIncrVar2 --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, increment the Tcl object value of
 *	the variable by a specified amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable.  If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in the
 *	interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    Tcl_Obj *part1Ptr;		/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    Tcl_Obj *part2Ptr;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    long incrAmount;		/* Amount to be added to variable. */
    int flags;			/* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));

1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858

1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880































































































































1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrIncrVar --
 *
 *	Given the pointers to a variable and possible containing array, 
 *      increment the Tcl object value of the variable by a specified 
 *      amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in
 *	the interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    CONST char *part2;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    CONST long incrAmount;	/* Amount to be added to variable. */
    CONST int flags;            /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    register Tcl_Obj *varValuePtr;
    int createdNewObj;		/* Set 1 if var's value object is shared
				 * so we must increment a copy (i.e. copy
				 * on write). */
    long i;

    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);

    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
     * Increment the variable's value. If the object is unshared we can
     * modify it directly, otherwise we must create a new copy to modify:
     * this is "copy on write". Then free the variable's old string
     * representation, if any, since it will no longer be valid.
     */

    createdNewObj = 0;
    if (Tcl_IsShared(varValuePtr)) {
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
	createdNewObj = 1;
    }
    if (varValuePtr->typePtr == &tclWideIntType) {
	Tcl_WideInt wide;
	TclGetWide(wide,varValuePtr);
	Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
    } else if (varValuePtr->typePtr == &tclIntType) {
	i = varValuePtr->internalRep.longValue;
	Tcl_SetIntObj(varValuePtr, i + incrAmount);
    } else {
	/*
	 * Not an integer or wide internal-rep...
	 */

	Tcl_WideInt wide;
	if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
	    if (createdNewObj) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
	    }
	    return NULL;
	}
	if (wide <= Tcl_LongAsWide(LONG_MAX)
		&& wide >= Tcl_LongAsWide(LONG_MIN)) {
	    Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
	} else {
	    Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
	}
    }

    /*
     * Store the variable's new value and run any write traces.
     */
    
    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
	    varValuePtr, flags);
}
































































































































/*
 *----------------------------------------------------------------------
 *
 * TclIncrWideVar2 --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, increment the Tcl object value
 *	of the variable by a specified amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in
 *	the interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrWideVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    Tcl_Obj *part1Ptr;		/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    Tcl_Obj *part2Ptr;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_WideInt incrAmount;	/* Amount to be added to variable. */
    int flags;                  /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));








|
|
<



|

|
|













|
|


|
|
|




|
|
|
|


|
|
|











|
|
|
|










|


|




>



|





|

|






|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







|
|



|

|
|













|
|
|
|
|




|
|
|
|







1780
1781
1782
1783
1784
1785
1786
1787
1788

1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrIncrVar --
 *
 *	Given the pointers to a variable and possible containing array,
 *	increment the Tcl object value of the variable by a specified amount.

 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable.  If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in the
 *	interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    CONST char *part2;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    CONST long incrAmount;	/* Amount to be added to variable. */
    CONST int flags;		/* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    register Tcl_Obj *varValuePtr;
    int createdNewObj;		/* Set 1 if var's value object is shared so we
				 * must increment a copy (i.e. copy on
				 * write). */
    long i;

    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);

    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
     * Increment the variable's value. If the object is unshared we can modify
     * it directly, otherwise we must create a new copy to modify: this is
     * "copy on write". Then free the variable's old string representation, if
     * any, since it will no longer be valid.
     */

    createdNewObj = 0;
    if (Tcl_IsShared(varValuePtr)) {
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
	createdNewObj = 1;
    }
    if (varValuePtr->typePtr == &tclWideIntType) {
	Tcl_WideInt wide;
	TclGetWide(wide,varValuePtr);
	TclSetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
    } else if (varValuePtr->typePtr == &tclIntType) {
	i = varValuePtr->internalRep.longValue;
	TclSetIntObj(varValuePtr, i + incrAmount);
    } else {
	/*
	 * Not an integer or wide internal-rep...
	 */

	Tcl_WideInt wide;
	if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
	    if (createdNewObj) {
		TclDecrRefCount(varValuePtr); /* free unneeded copy */
	    }
	    return NULL;
	}
	if (wide <= Tcl_LongAsWide(LONG_MAX)
		&& wide >= Tcl_LongAsWide(LONG_MIN)) {
	    TclSetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
	} else {
	    TclSetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
	}
    }

    /*
     * Store the variable's new value and run any write traces.
     */

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
	    varValuePtr, flags);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclIncrObjVar2 --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, increment the Tcl object value of
 *	the variable by a specified Tcl_Obj increment value.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable.  If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in the
 *	interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrObjVar2(interp, part1Ptr, part2Ptr, incrPtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    Tcl_Obj *part1Ptr;		/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    Tcl_Obj *part2Ptr;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_Obj *incrPtr;		/* Amount to be added to variable. */
    int flags;			/* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
	    0, 1, &arrayPtr);
    if (varPtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }
    return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2,
	    incrPtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrIncrObjVar --
 *
 *	Given the pointers to a variable and possible containing array,
 *	increment the Tcl object value of the variable by a Tcl_Obj increment.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable.  If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in the
 *	interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    CONST char *part2;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_Obj *incrPtr;		/* Increment value */
/* TODO: Which of these flag values really make sense? */
    CONST int flags;		/* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
    int code;

    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }
    if (Tcl_IsShared(varValuePtr)) {
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
    }
    code = TclIncrObj(interp, varValuePtr, incrPtr);
    Tcl_IncrRefCount(varValuePtr);
    if (code == TCL_OK) {
	newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
		varValuePtr, flags);
    }
    Tcl_DecrRefCount(varValuePtr);
    return newValuePtr;
}
#if 0

/*
 *----------------------------------------------------------------------
 *
 * TclIncrWideVar2 --
 *
 *	Given a two-part variable name, which may refer either to a scalar
 *	variable or an element of an array, increment the Tcl object value of
 *	the variable by a specified amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable.  If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in the
 *	interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrWideVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    Tcl_Obj *part1Ptr;		/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    Tcl_Obj *part2Ptr;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_WideInt incrAmount;	/* Amount to be added to variable. */
    int flags;			/* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));

1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021

2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037

2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrIncrWideVar --
 *
 *	Given the pointers to a variable and possible containing array, 
 *      increment the Tcl object value of the variable by a specified 
 *      amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in
 *	the interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    CONST char *part2;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    CONST Tcl_WideInt incrAmount;
				/* Amount to be added to variable. */
    CONST int flags;            /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    register Tcl_Obj *varValuePtr;
    int createdNewObj;		/* Set 1 if var's value object is shared
				 * so we must increment a copy (i.e. copy
				 * on write). */
    Tcl_WideInt wide;

    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);

    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
     * Increment the variable's value. If the object is unshared we can
     * modify it directly, otherwise we must create a new copy to modify:
     * this is "copy on write". Then free the variable's old string
     * representation, if any, since it will no longer be valid.
     */

    createdNewObj = 0;
    if (Tcl_IsShared(varValuePtr)) {
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
	createdNewObj = 1;
    }
    if (varValuePtr->typePtr == &tclWideIntType) {
	TclGetWide(wide, varValuePtr);
	Tcl_SetWideIntObj(varValuePtr, wide + incrAmount);
    } else if (varValuePtr->typePtr == &tclIntType) {
	long i = varValuePtr->internalRep.longValue;
	Tcl_SetWideIntObj(varValuePtr, Tcl_LongAsWide(i) + incrAmount);
    } else {
	/*
	 * Not an integer or wide internal-rep...
	 */

	if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
	    if (createdNewObj) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
	    }
	    return NULL;
	}
	Tcl_SetWideIntObj(varValuePtr, wide + incrAmount);
    }

    /*
     * Store the variable's new value and run any write traces.
     */
    
    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
	    varValuePtr, flags);
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar --
 *
 *	Delete a variable, so that it may not be accessed anymore.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
 *	if the variable can't be unset.  In the event of an error,
 *	if the TCL_LEAVE_ERR_MSG flag is set then an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	If varName is defined as a local or global variable in interp,
 *	it is deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp.  May be
				 * either a scalar name or an array name
				 * or an element in an array. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
				 * TCL_LEAVE_ERR_MSG. */
{
    return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar2 --
 *
 *	Delete a variable, given a 2-part name.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
 *	if the variable can't be unset.  In the event of an error,
 *	if the TCL_LEAVE_ERR_MSG flag is set then an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	If part1 and part2 indicate a local or global variable in interp,
 *	it is deleted.  If part1 is an array name and part2 is NULL, then
 *	the whole array is deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    int result;
    Tcl_Obj *part1Ptr;

    part1Ptr = Tcl_NewStringObj(part1, -1);
    Tcl_IncrRefCount(part1Ptr);
    result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
    TclDecrRefCount(part1Ptr);

    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * TclObjUnsetVar2 --
 *
 *	Delete a variable, given a 2-object name.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
 *	if the variable can't be unset.  In the event of an error,
 *	if the TCL_LEAVE_ERR_MSG flag is set then an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	If part1ptr and part2Ptr indicate a local or global variable in interp,
 *	it is deleted.  If part1Ptr is an array name and part2Ptr is NULL, then
 *	the whole array is deleted.
 *
 *----------------------------------------------------------------------
 */

int
TclObjUnsetVar2(interp, part1Ptr, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    Tcl_Obj *part1Ptr;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    Var dummyVar;







|
|
<



|
|
|
|













|
|


|
|
|





|
|
|
|


|
|
|











|
|
|
|









|


|




>


|



|





|



>









|
|
|
|


|
|






|
|
|
|
|















|
|
|
|


|
|
|






|
|
















<









|
|
|
|


|
|
|






|
|







2070
2071
2072
2073
2074
2075
2076
2077
2078

2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245

2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrIncrWideVar --
 *
 *	Given the pointers to a variable and possible containing array,
 *	increment the Tcl object value of the variable by a specified amount.

 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the specified variable doesn't exist, or there is a clash
 *	in array usage, or an error occurs while executing variable traces,
 *	then NULL is returned and a message will be left in the interpreter's
 *	result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is to
				 * be found. */
    Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Points to an object holding the name of an
				 * array (if part2 is non-NULL) or the name of
				 * a variable. */
    CONST char *part2;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    CONST Tcl_WideInt incrAmount;
				/* Amount to be added to variable. */
    CONST int flags;		/* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
{
    register Tcl_Obj *varValuePtr;
    int createdNewObj;		/* Set 1 if var's value object is shared so we
				 * must increment a copy (i.e. copy on
				 * write). */
    Tcl_WideInt wide;

    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);

    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
     * Increment the variable's value. If the object is unshared we can modify
     * it directly, otherwise we must create a new copy to modify: this is
     * "copy on write". Then free the variable's old string representation, if
     * any, since it will no longer be valid.
     */

    createdNewObj = 0;
    if (Tcl_IsShared(varValuePtr)) {
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
	createdNewObj = 1;
    }
    if (varValuePtr->typePtr == &tclWideIntType) {
	TclGetWide(wide, varValuePtr);
	TclSetWideIntObj(varValuePtr, wide + incrAmount);
    } else if (varValuePtr->typePtr == &tclIntType) {
	long i = varValuePtr->internalRep.longValue;
	TclSetWideIntObj(varValuePtr, Tcl_LongAsWide(i) + incrAmount);
    } else {
	/*
	 * Not an integer or wide internal-rep...
	 */

	if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
	    if (createdNewObj) {
		TclDecrRefCount(varValuePtr); /* free unneeded copy */
	    }
	    return NULL;
	}
	TclSetWideIntObj(varValuePtr, wide + incrAmount);
    }

    /*
     * Store the variable's new value and run any write traces.
     */

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
	    varValuePtr, flags);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar --
 *
 *	Delete a variable, so that it may not be accessed anymore.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
 *	the variable can't be unset.  In the event of an error, if the
 *	TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	If varName is defined as a local or global variable in interp, it is
 *	deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is to
				 * be looked up. */
    CONST char *varName;	/* Name of a variable in interp. May be either
				 * a scalar name or an array name or an
				 * element in an array. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
				 * TCL_LEAVE_ERR_MSG. */
{
    return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar2 --
 *
 *	Delete a variable, given a 2-part name.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
 *	the variable can't be unset.  In the event of an error, if the
 *	TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	If part1 and part2 indicate a local or global variable in interp, it
 *	is deleted.  If part1 is an array name and part2 is NULL, then the
 *	whole array is deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is to
				 * be looked up. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    int result;
    Tcl_Obj *part1Ptr;

    part1Ptr = Tcl_NewStringObj(part1, -1);
    Tcl_IncrRefCount(part1Ptr);
    result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
    TclDecrRefCount(part1Ptr);

    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * TclObjUnsetVar2 --
 *
 *	Delete a variable, given a 2-object name.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
 *	the variable can't be unset.  In the event of an error, if the
 *	TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	If part1ptr and part2Ptr indicate a local or global variable in
 *	interp, it is deleted.  If part1Ptr is an array name and part2Ptr is
 *	NULL, then the whole array is deleted.
 *
 *----------------------------------------------------------------------
 */

int
TclObjUnsetVar2(interp, part1Ptr, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is to
				 * be looked up. */
    Tcl_Obj *part1Ptr;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    Var dummyVar;
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247

2248

2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262

2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300

    part1 = TclGetString(part1Ptr);
    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
	    /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }
    
    result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);

    if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
	DeleteSearches(arrayPtr);
    }

    /*
     * The code below is tricky, because of the possibility that
     * a trace procedure might try to access a variable being
     * deleted. To handle this situation gracefully, do things
     * in three steps:
     * 1. Copy the contents of the variable to a dummy variable
     *    structure, and mark the original Var structure as undefined.
     * 2. Invoke traces and clean up the variable, using the dummy copy.
     * 3. If at the end of this the original variable is still
     *    undefined and has no outstanding references, then delete
     *	  it (but it could have gotten recreated by a trace).
     */

    dummyVar = *varPtr;
    TclSetVarUndefined(varPtr);
    TclSetVarScalar(varPtr);
    varPtr->value.objPtr = NULL; /* dummyVar points to any value object */
    varPtr->tracePtr = NULL;
    varPtr->searchPtr = NULL;

    /*
     * Keep the variable alive until we're done with it. We used to
     * increase/decrease the refCount for each operation, making it
     * hard to find [Bug 735335] - caused by unsetting the variable
     * whose value was the variable's name.
     */
    
    varPtr->refCount++;


    /*
     * Call trace procedures for the variable being deleted. Then delete
     * its traces. Be sure to abort any other traces for the variable
     * that are still pending. Special tricks:
     * 1. We need to increment varPtr's refCount around this: TclCallVarTraces
     *    will use dummyVar so it won't increment varPtr's refCount itself.
     * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
     *    call unset traces even if other traces are pending.
     */

    if ((dummyVar.tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
	while (dummyVar.tracePtr != NULL) {
	    VarTrace *tracePtr = dummyVar.tracePtr;
	    dummyVar.tracePtr = tracePtr->nextPtr;
	    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	}
	for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
	     activePtr = activePtr->nextPtr) {
	    if (activePtr->varPtr == varPtr) {
		activePtr->nextTracePtr = NULL;
	    }
	}
    }

    /*
     * If the variable is an array, delete all of its elements. This must be
     * done after calling the traces on the array, above (that's the way
     * traces are defined). If it is a scalar, "discard" its object
     * (decrement the ref count of its object, if any).
     */

    dummyVarPtr = &dummyVar;
    if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
	/*
	 * Deleting the elements of the array may cause traces to be fired
	 * on those elements.  Before deleting them, bump the reference count
	 * of the array, so that if those trace procs make a global or upvar
	 * link to the array, the array is not deleted when the call stack
	 * gets popped (we will delete the array ourselves later in this
	 * function).
	 *
	 * Bumping the count can lead to the odd situation that elements of the
	 * array are being deleted when the array still exists, but since the
	 * array is about to be removed anyway, that shouldn't really matter.

	 */

	DeleteArray(iPtr, part1, dummyVarPtr,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) 
		| TCL_TRACE_UNSETS);
	/* Decr ref count */
    }
    if (TclIsVarScalar(dummyVarPtr)
	    && (dummyVarPtr->value.objPtr != NULL)) {
	objPtr = dummyVarPtr->value.objPtr;
	TclDecrRefCount(objPtr);
	dummyVarPtr->value.objPtr = NULL;
    }

    /*
     * If the variable was a namespace variable, decrement its reference count.

     */
    
    if (TclIsVarNamespaceVar(varPtr)) {
	TclClearVarNamespaceVar(varPtr);
	varPtr->refCount--;
    }

    /*
     * It's an error to unset an undefined variable.
     */
	
    if (result != TCL_OK) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclVarErrMsg(interp, part1, part2, "unset", 
		    ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
	}
    }

#if ENABLE_NS_VARNAME_CACHING
    /*
     * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType 
     * keeping a reference. This removes some additional exteriorisations of
     * [Bug 736729], but may be a good thing independently of the bug.
     */

    if (part1Ptr->typePtr == &tclNsVarNameType) {
	TclFreeIntRep(part1Ptr);
	part1Ptr->typePtr = NULL;
    }
#endif
    
    /*
     * Finally, if the variable is truly not in use then free up its Var
     * structure and remove it from its hash table, if any. The ref count of
     * its value object, if any, was decremented above.
     */

    varPtr->refCount--;







|







|
|
|
<
|
|

|
|
|











|
|
|

|


<

|
|
|


|
|














|









|
|





|
|
|
|
|
<

|
|
|
>

>

|











|
>

|








|


|






|









|







2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303

2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327

2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371

2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431

    part1 = TclGetString(part1Ptr);
    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
	    /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }

    result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);

    if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
	DeleteSearches(arrayPtr);
    }

    /*
     * The code below is tricky, because of the possibility that a trace
     * procedure might try to access a variable being deleted. To handle this
     * situation gracefully, do things in three steps:

     * 1. Copy the contents of the variable to a dummy variable structure, and
     *    mark the original Var structure as undefined.
     * 2. Invoke traces and clean up the variable, using the dummy copy.
     * 3. If at the end of this the original variable is still undefined and
     *    has no outstanding references, then delete * it (but it could have
     *    gotten recreated by a trace).
     */

    dummyVar = *varPtr;
    TclSetVarUndefined(varPtr);
    TclSetVarScalar(varPtr);
    varPtr->value.objPtr = NULL; /* dummyVar points to any value object */
    varPtr->tracePtr = NULL;
    varPtr->searchPtr = NULL;

    /*
     * Keep the variable alive until we're done with it. We used to
     * increase/decrease the refCount for each operation, making it hard to
     * find [Bug 735335] - caused by unsetting the variable whose value was
     * the variable's name.
     */

    varPtr->refCount++;


    /*
     * Call trace procedures for the variable being deleted. Then delete its
     * traces. Be sure to abort any other traces for the variable that are
     * still pending. Special tricks:
     * 1. We need to increment varPtr's refCount around this: TclCallVarTraces
     *    will use dummyVar so it won't increment varPtr's refCount itself.
     * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to call
     *    unset traces even if other traces are pending.
     */

    if ((dummyVar.tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
	while (dummyVar.tracePtr != NULL) {
	    VarTrace *tracePtr = dummyVar.tracePtr;
	    dummyVar.tracePtr = tracePtr->nextPtr;
	    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	}
	for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
		activePtr = activePtr->nextPtr) {
	    if (activePtr->varPtr == varPtr) {
		activePtr->nextTracePtr = NULL;
	    }
	}
    }

    /*
     * If the variable is an array, delete all of its elements. This must be
     * done after calling the traces on the array, above (that's the way
     * traces are defined). If it is a scalar, "discard" its object (decrement
     * the ref count of its object, if any).
     */

    dummyVarPtr = &dummyVar;
    if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
	/*
	 * Deleting the elements of the array may cause traces to be fired on
	 * those elements.  Before deleting them, bump the reference count of
	 * the array, so that if those trace procs make a global or upvar link
	 * to the array, the array is not deleted when the call stack gets
	 * popped (we will delete the array ourselves later in this function).

	 *
	 * Bumping the count can lead to the odd situation that elements of
	 * the array are being deleted when the array still exists, but since
	 * the array is about to be removed anyway, that shouldn't really
	 * matter.
	 */

	DeleteArray(iPtr, part1, dummyVarPtr,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_UNSETS);
	/* Decr ref count */
    }
    if (TclIsVarScalar(dummyVarPtr)
	    && (dummyVarPtr->value.objPtr != NULL)) {
	objPtr = dummyVarPtr->value.objPtr;
	TclDecrRefCount(objPtr);
	dummyVarPtr->value.objPtr = NULL;
    }

    /*
     * If the variable was a namespace variable, decrement its reference
     * count.
     */

    if (TclIsVarNamespaceVar(varPtr)) {
	TclClearVarNamespaceVar(varPtr);
	varPtr->refCount--;
    }

    /*
     * It's an error to unset an undefined variable.
     */

    if (result != TCL_OK) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    TclVarErrMsg(interp, part1, part2, "unset",
		    ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
	}
    }

#if ENABLE_NS_VARNAME_CACHING
    /*
     * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
     * keeping a reference. This removes some additional exteriorisations of
     * [Bug 736729], but may be a good thing independently of the bug.
     */

    if (part1Ptr->typePtr == &tclNsVarNameType) {
	TclFreeIntRep(part1Ptr);
	part1Ptr->typePtr = NULL;
    }
#endif

    /*
     * Finally, if the variable is truly not in use then free up its Var
     * structure and remove it from its hash table, if any. The ref count of
     * its value object, if any, was decremented above.
     */

    varPtr->refCount--;
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341

2342
2343
2344
2345
2346
2347
2348
2349

2350
2351
2352
2353
2354
2355
2356

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nocomplain? ?--? ?varName varName ...?");
	return TCL_ERROR;
    } else if (objc == 1) {
	/*
	 * Do nothing if no arguments supplied, so as to match
	 * command documentation.
	 */

	return TCL_OK;
    }

    /*
     * Simple, restrictive argument parsing.  The only options are --
     * and -nocomplain (which must come first and be given exactly to
     * be an option).
     */

    i = 1;
    name = TclGetString(objv[i]);
    if (name[0] == '-') {
 	if (strcmp("-nocomplain", name) == 0) {
	    i++;
 	    if (i == objc) {
		return TCL_OK;







|
|

>




|
|
|

>







2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nocomplain? ?--? ?varName varName ...?");
	return TCL_ERROR;
    } else if (objc == 1) {
	/*
	 * Do nothing if no arguments supplied, so as to match command
	 * documentation.
	 */

	return TCL_OK;
    }

    /*
     * Simple, restrictive argument parsing.  The only options are -- and
     * -nocomplain (which must come first and be given exactly to be an
     * option).
     */

    i = 1;
    name = TclGetString(objv[i]);
    if (name[0] == '-') {
 	if (strcmp("-nocomplain", name) == 0) {
	    i++;
 	    if (i == objc) {
		return TCL_OK;
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendObjCmd --
 *
 *	This object-based procedure is invoked to process the "append" 
 *	Tcl command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *







|
|







2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendObjCmd --
 *
 *	This object-based procedure is invoked to process the "append" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474

2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551

2552
2553


2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Var *varPtr, *arrayPtr;
    char *part1;

    register Tcl_Obj *varValuePtr = NULL;
    					/* Initialized to avoid compiler
				         * warning. */
    int i;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
	if (varValuePtr == NULL) {
	    return TCL_ERROR;
	}
    } else {
	varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	part1 = TclGetString(objv[1]);
	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	for (i = 2;  i < objc;  i++) {	  
	    /*
	     * Note that we do not need to increase the refCount of
	     * the Var pointers: should a trace delete the variable,
	     * the return value of TclPtrSetVar will be NULL, and we 
	     * will not access the variable again.
	     */

	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, 
	            objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}
    }
    Tcl_SetObjResult(interp, varValuePtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LappendObjCmd --
 *
 *	This object-based procedure is invoked to process the "lappend" 
 *	Tcl command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LappendObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *varValuePtr, *newValuePtr;
    register List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    int numElems, numRequired, createdNewObj, createVar, i, j;
    Var *varPtr, *arrayPtr;
    char *part1;


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }
    if (objc == 2) {
	newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
	if (newValuePtr == NULL) {
	    /*
	     * The variable doesn't exist yet. Just create it with an empty
	     * initial value.
	     */
	    
	    varValuePtr = Tcl_NewObj();
	    newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
		    TCL_LEAVE_ERR_MSG);
	    if (newValuePtr == NULL) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded object */
		return TCL_ERROR;
	    }
	}
    } else {
	/*
	 * We have arguments to append. We used to call Tcl_SetVar2 to
	 * append each argument one at a time to ensure that traces were run
	 * for each append step. We now append the arguments all at once
	 * because it's faster. Note that a read trace and a write trace for
	 * the variable will now each only be called once. Also, if the
	 * variable's old value is unshared we modify it directly, otherwise
	 * we create a new copy to modify: this is "copy on write".
	 */

	createdNewObj = 0;
	createVar = 1;

	/*
	 * Use the TCL_TRACE_READS flag to ensure that if we have an
	 * array with no elements set yet, but with a read trace on it,
	 * we will create the variable and get read traces triggered.
	 * Note that you have to protect the variable pointers around
	 * the TclPtrGetVar call to insure that they remain valid 
	 * even if the variable was undefined and unused.
	 */

	varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	varPtr->refCount++;
	if (arrayPtr != NULL) {
	    arrayPtr->refCount++;
	}
	part1 = TclGetString(objv[1]);
	varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, 
	        (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG));
	varPtr->refCount--;
	if (arrayPtr != NULL) {
	    arrayPtr->refCount--;
	}

	if (varValuePtr == NULL) {
	    /*
	     * We couldn't read the old value: either the var doesn't yet
	     * exist or it's an array element.  If it's new, we will try to
	     * create it with Tcl_ObjSetVar2 below.
	     */
	    
	    createVar = (TclIsVarUndefined(varPtr));
	    varValuePtr = Tcl_NewObj();
	    createdNewObj = 1;
	} else if (Tcl_IsShared(varValuePtr)) {	
	    varValuePtr = Tcl_DuplicateObj(varValuePtr);
	    createdNewObj = 1;
	}

	/*

	 * Convert the variable's old value to a list object if necessary.
	 */



	if (varValuePtr->typePtr != &tclListType) {
	    int result = tclListType.setFromAnyProc(interp, varValuePtr);
	    if (result != TCL_OK) {
		if (createdNewObj) {
		    Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */
		}
		return result;
	    }
	}
	listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1;
	elemPtrs = listRepPtr->elements;
	numElems = listRepPtr->elemCount;

	/*
	 * If there is no room in the current array of element pointers,
	 * allocate a new, larger array and copy the pointers to it.
	 */
	
	numRequired = numElems + (objc-2);
	if (numRequired > listRepPtr->maxElemCount) {
	    int newMax = (2 * numRequired);
	    Tcl_Obj **newElemPtrs = (Tcl_Obj **)
		ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
	    
	    memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs,
		    (size_t) (numElems * sizeof(Tcl_Obj *)));
	    listRepPtr->maxElemCount = newMax;
	    listRepPtr->elements = newElemPtrs;
	    ckfree((char *) elemPtrs);
	    elemPtrs = newElemPtrs;
	}

	/*
	 * Insert the new elements at the end of the list.
	 */

	for (i = 2, j = numElems;  i < objc;  i++, j++) {
            elemPtrs[j] = objv[i];
            Tcl_IncrRefCount(objv[i]);
        }
	listRepPtr->elemCount = numRequired;

	/*
	 * Invalidate and free any old string representation since it no
	 * longer reflects the list's internal representation.
	 */

	Tcl_InvalidateStringRep(varValuePtr);

	/*
	 * Now store the list object back into the variable. If there is an
	 * error setting the new value, decrement its ref count if it
	 * was new and we didn't create the variable.
	 */
	
	newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, 
	            varValuePtr, TCL_LEAVE_ERR_MSG);	
	if (newValuePtr == NULL) {
	    if (createdNewObj && !createVar) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * Set the interpreter's object result to refer to the variable's value







|



















|

|
|
|
|


|
|














|
|



















<
<
|


>












|
|



|





|
|
|
|
|
|
|






|
|
|
|
|
|












|
|











|

|

|




<
>
|
<
>
>
|
<
<
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



|
|

|
|
|


|







2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602


2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682

2683
2684

2685
2686
2687


2688
2689
2690
2691
2692
2693








































2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Var *varPtr, *arrayPtr;
    char *part1;

    register Tcl_Obj *varValuePtr = NULL;
    					/* Initialized to avoid compiler
					 * warning. */
    int i;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
	if (varValuePtr == NULL) {
	    return TCL_ERROR;
	}
    } else {
	varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	part1 = TclGetString(objv[1]);
	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	for (i = 2;  i < objc;  i++) {
	    /*
	     * Note that we do not need to increase the refCount of the Var
	     * pointers: should a trace delete the variable, the return value
	     * of TclPtrSetVar will be NULL, and we will not access the
	     * variable again.
	     */

	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
		    objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}
    }
    Tcl_SetObjResult(interp, varValuePtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LappendObjCmd --
 *
 *	This object-based procedure is invoked to process the "lappend" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LappendObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *varValuePtr, *newValuePtr;


    int numElems, createdNewObj, createVar;
    Var *varPtr, *arrayPtr;
    char *part1;
    int result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }
    if (objc == 2) {
	newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
	if (newValuePtr == NULL) {
	    /*
	     * The variable doesn't exist yet. Just create it with an empty
	     * initial value.
	     */

	    TclNewObj(varValuePtr);
	    newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
		    TCL_LEAVE_ERR_MSG);
	    if (newValuePtr == NULL) {
		TclDecrRefCount(varValuePtr); /* free unneeded object */
		return TCL_ERROR;
	    }
	}
    } else {
	/*
	 * We have arguments to append. We used to call Tcl_SetVar2 to append
	 * each argument one at a time to ensure that traces were run for each
	 * append step. We now append the arguments all at once because it's
	 * faster. Note that a read trace and a write trace for the variable
	 * will now each only be called once. Also, if the variable's old
	 * value is unshared we modify it directly, otherwise we create a new
	 * copy to modify: this is "copy on write".
	 */

	createdNewObj = 0;
	createVar = 1;

	/*
	 * Use the TCL_TRACE_READS flag to ensure that if we have an array
	 * with no elements set yet, but with a read trace on it, we will
	 * create the variable and get read traces triggered.  Note that you
	 * have to protect the variable pointers around the TclPtrGetVar call
	 * to insure that they remain valid even if the variable was undefined
	 * and unused.
	 */

	varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	varPtr->refCount++;
	if (arrayPtr != NULL) {
	    arrayPtr->refCount++;
	}
	part1 = TclGetString(objv[1]);
	varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
		(TCL_TRACE_READS | TCL_LEAVE_ERR_MSG));
	varPtr->refCount--;
	if (arrayPtr != NULL) {
	    arrayPtr->refCount--;
	}

	if (varValuePtr == NULL) {
	    /*
	     * We couldn't read the old value: either the var doesn't yet
	     * exist or it's an array element.  If it's new, we will try to
	     * create it with Tcl_ObjSetVar2 below.
	     */

	    createVar = (TclIsVarUndefined(varPtr));
	    TclNewObj(varValuePtr);
	    createdNewObj = 1;
	} else if (Tcl_IsShared(varValuePtr)) {
	    varValuePtr = Tcl_DuplicateObj(varValuePtr);
	    createdNewObj = 1;
	}


	result = Tcl_ListObjLength(interp, varValuePtr, &numElems);
	if (result == TCL_OK) {

	    result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
		    (objc-2), (objv+2));
	}


	if (result != TCL_OK) {
	    if (createdNewObj) {
		TclDecrRefCount(varValuePtr); /* free unneeded obj. */
	    }
	    return result;
	}









































	/*
	 * Now store the list object back into the variable. If there is an
	 * error setting the new value, decrement its ref count if it was new
	 * and we didn't create the variable.
	 */

	newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
		varValuePtr, TCL_LEAVE_ERR_MSG);
	if (newValuePtr == NULL) {
	    if (createdNewObj && !createVar) {
		TclDecrRefCount(varValuePtr); /* free unneeded obj */
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * Set the interpreter's object result to refer to the variable's value
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059







3060



3061


3062




3063

































































3064
3065

















































































3066
3067
3068

3069













3070
3071



3072
3073


3074
3075
3076
3077


3078



















3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095

3096
3097
3098
3099
3100
3101

3102






3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
















































3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
    /*
     * The list of constants below should match the arrayOptions string array
     * below.
     */

    enum {ARRAY_ANYMORE, ARRAY_DONESEARCH,  ARRAY_EXISTS, ARRAY_GET,
	  ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
	  ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; 
    static CONST char *arrayOptions[] = {
	"anymore", "donesearch", "exists", "get", "names", "nextelement",
	"set", "size", "startsearch", "statistics", "unset", (char *) NULL
    };

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *varNamePtr;
    int notArray;
    char *varName;
    int index, result;


    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
	    0, &index) != TCL_OK) {
    	return TCL_ERROR;
    }

    /*
     * Locate the array variable
     */
    
    varNamePtr = objv[2];
    varName = TclGetString(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
            /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    /*
     * Special array trace used to keep the env array in sync for
     * array names, array get, etc.
     */

    if (varPtr != NULL && varPtr->tracePtr != NULL
	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, varName,
		NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
	    return TCL_ERROR;
	}
    }

    /*
     * Verify that it is indeed an array variable. This test comes after
     * the traces - the variable may actually become an array as an effect 
     * of said traces.
     */

    notArray = 0;
    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
	    || TclIsVarUndefined(varPtr)) {
	notArray = 1;
    }

    switch (index) {
        case ARRAY_ANYMORE: {
	    ArraySearch *searchPtr;
	    
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
		return TCL_ERROR;
	    }
	    if (notArray) {
	        goto error;
	    }
	    searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
	    if (searchPtr == NULL) {
	        return TCL_ERROR;
	    }
	    while (1) {
	        Var *varPtr2;

		if (searchPtr->nextEntry != NULL) {
		    varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
		    if (!TclIsVarUndefined(varPtr2)) {
		        break;
		    }
		}
		searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
		if (searchPtr->nextEntry == NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
		    return TCL_OK;
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
	    break;
	}
        case ARRAY_DONESEARCH: {
	    ArraySearch *searchPtr, *prevPtr;

	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
		return TCL_ERROR;
	    }
	    if (notArray) {
	        goto error;
	    }
	    searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
	    if (searchPtr == NULL) {
	        return TCL_ERROR;
	    }
	    if (varPtr->searchPtr == searchPtr) {
	        varPtr->searchPtr = searchPtr->nextPtr;
	    } else {
	        for (prevPtr = varPtr->searchPtr;  ;
		     prevPtr = prevPtr->nextPtr) {
		    if (prevPtr->nextPtr == searchPtr) {
		        prevPtr->nextPtr = searchPtr->nextPtr;
			break;
		    }
		}
	    }
	    ckfree((char *) searchPtr);
	    break;
	}
        case ARRAY_EXISTS: {
	    if (objc != 3) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
	        return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!notArray));
	    break;
	}
        case ARRAY_GET: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    char *pattern = NULL;
	    char *name;
	    Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr;
	    int i, count;
	    
	    if ((objc != 3) && (objc != 4)) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
		return TCL_ERROR;
	    }
	    if (notArray) {
	        return TCL_OK;
	    }
	    if (objc == 4) {
	        pattern = TclGetString(objv[3]);
	    }

	    /*
	     * Store the array names in a new object.
	     */

	    nameLstPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(nameLstPtr);

	    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		 hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
	        varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		if (TclIsVarUndefined(varPtr2)) {
		    continue;
		}
		name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
		if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
		    continue;	/* element name doesn't match pattern */
		}
		
		namePtr = Tcl_NewStringObj(name, -1);
		result = Tcl_ListObjAppendElement(interp, nameLstPtr,
		        namePtr);
		if (result != TCL_OK) {
		    Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
		    Tcl_DecrRefCount(nameLstPtr);
		    return result;
		}
	    }

	    /*
	     * Make sure the Var structure of the array is not removed by
	     * a trace while we're working.
	     */

	    varPtr->refCount++;

	    /*
	     * Get the array values corresponding to each element name 
	     */

	    tmpResPtr = Tcl_NewObj();
	    result = Tcl_ListObjGetElements(interp, nameLstPtr,
		    &count, &namePtrPtr);
	    if (result != TCL_OK) {
		goto errorInArrayGet;
	    }
	    
	    for (i = 0; i < count; i++) { 
		namePtr = *namePtrPtr++;
		valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
	                TCL_LEAVE_ERR_MSG);
		if (valuePtr == NULL) {
		    /*
		     * Some trace played a trick on us; we need to diagnose to
		     * adapt our behaviour: was the array element unset, or did
		     * the modification modify the complete array?
		     */

		    if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
			/*
			 * The array itself looks OK, the variable was
			 * undefined: forget it.
			 */
			
			continue;
		    } else {
			result = TCL_ERROR;
			goto errorInArrayGet;
		    }
		}
		result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr);
		if (result != TCL_OK) {
		    goto errorInArrayGet;
		}
	    }
	    varPtr->refCount--;
	    Tcl_SetObjResult(interp, tmpResPtr);
	    Tcl_DecrRefCount(nameLstPtr);
	    break;

	    errorInArrayGet:
	    varPtr->refCount--;
	    Tcl_DecrRefCount(nameLstPtr);
	    Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */
	    return result;
	}
        case ARRAY_NAMES: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    char *pattern = NULL;
	    char *name;
	    Tcl_Obj *namePtr, *resultPtr;
	    int mode, matched = 0;
	    static CONST char *options[] = {
		"-exact", "-glob", "-regexp", (char *) NULL
	    };
	    enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };

	    mode = OPT_GLOB;
	    
	    if ((objc < 3) || (objc > 5)) {
  	        Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?");
		return TCL_ERROR;
	    }
	    if (notArray) {
	        return TCL_OK;
	    }
	    if (objc == 4) {
	        pattern = TclGetString(objv[3]);
	    } else if (objc == 5) {
		pattern = TclGetString(objv[4]);
		if (Tcl_GetIndexFromObj(interp, objv[3], options, "option",
			0, &mode) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }       		
	    resultPtr = Tcl_NewObj();
	    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	        varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		if (TclIsVarUndefined(varPtr2)) {
		    continue;
		}
		name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
		if (objc > 3) {
		    switch ((enum options) mode) {
			case OPT_EXACT:
			    matched = (strcmp(name, pattern) == 0);
			    break;
			case OPT_GLOB:
			    matched = Tcl_StringMatch(name, pattern);
			    break;
			case OPT_REGEXP:
			    matched = Tcl_RegExpMatch(interp, name,
				    pattern);
			    if (matched < 0) {
				Tcl_DecrRefCount(resultPtr);
				return TCL_ERROR;
			    }
			    break;
		    }
		    if (matched == 0) {
			continue;
		    }
		}
		
		namePtr = Tcl_NewStringObj(name, -1);
		result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
		if (result != TCL_OK) {
		    Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
		    return result;
		}
		Tcl_SetObjResult(interp, resultPtr);
	    }
	    break;
	}
        case ARRAY_NEXTELEMENT: {
	    ArraySearch *searchPtr;
	    Tcl_HashEntry *hPtr;
	    
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
		return TCL_ERROR;
	    }
	    if (notArray) {
  	        goto error;
	    }
	    searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
	    if (searchPtr == NULL) {
	        return TCL_ERROR;
	    }
	    while (1) {
	        Var *varPtr2;

		hPtr = searchPtr->nextEntry;
		if (hPtr == NULL) {
		    hPtr = Tcl_NextHashEntry(&searchPtr->search);
		    if (hPtr == NULL) {
		        return TCL_OK;
		    }
		} else {
		    searchPtr->nextEntry = NULL;
		}
		varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		if (!TclIsVarUndefined(varPtr2)) {
		    break;
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	            Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1));
	    break;
	}
        case ARRAY_SET: {
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
		return TCL_ERROR;
	    }
	    return TclArraySet(interp, objv[2], objv[3]);
	}
        case ARRAY_SIZE: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    int size;

	    if (objc != 3) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
		return TCL_ERROR;
	    }
	    size = 0;
	    if (!notArray) {
	        for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, 
                        &search);
		     hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
		    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		    if (TclIsVarUndefined(varPtr2)) {
		        continue;
		    }
		    size++;
		}
	    }
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
	    break;
	}
        case ARRAY_STARTSEARCH: {
	    ArraySearch *searchPtr;

	    if (objc != 3) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
		return TCL_ERROR;
	    }
	    if (notArray) {
	        goto error;
	    }
	    searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
	    if (varPtr->searchPtr == NULL) {
	        searchPtr->id = 1;
		Tcl_AppendResult(interp, "s-1-", varName, NULL);
	    } else {
	        char string[TCL_INTEGER_SPACE];

		searchPtr->id = varPtr->searchPtr->id + 1;
		TclFormatInt(string, searchPtr->id);
		Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
	    }
	    searchPtr->varPtr = varPtr;
	    searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
		    &searchPtr->search);
	    searchPtr->nextPtr = varPtr->searchPtr;
	    varPtr->searchPtr = searchPtr;
	    break;
	}








	case ARRAY_STATISTICS: {



	    CONST char *stats;







	    if (notArray) {

































































		goto error;
	    }


















































































	    stats = Tcl_HashStats(varPtr->value.tablePtr);
	    if (stats != NULL) {

		Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));













		ckfree((void *)stats);
	    } else {



		Tcl_SetResult(interp, "error reading array statistics",
			TCL_STATIC);


		return TCL_ERROR;
	    }
	    break;
        }


	



















	case ARRAY_UNSET: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    char *pattern = NULL;
	    char *name;
          
	    if ((objc != 3) && (objc != 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
		return TCL_ERROR;
	    }
	    if (notArray) {
		return TCL_OK;
	    }
	    if (objc == 3) {
		/*
		 * When no pattern is given, just unset the whole array
		 */

		if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0)
			!= TCL_OK) {
		    return TCL_ERROR;
		}
	    } else {
		pattern = TclGetString(objv[3]);

		for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,






			&search);
		     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
		    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		    if (TclIsVarUndefined(varPtr2)) {
			continue;
		    }
		    name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
		    if (Tcl_StringMatch(name, pattern) &&
			    (TclObjUnsetVar2(interp, varNamePtr, name, 0)
				    != TCL_OK)) {
			return TCL_ERROR;
		    }
		}
















































	    }
	    break;
	}
    }
    return TCL_OK;

    error:
    Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArraySet --
 *
 *	Set the elements of an array.  If there are no elements to
 *	set, create an empty array.  This routine is used by the
 *	Tcl_ArrayObjCmd and by the TclSetupEnv routine.
 *
 * Results:
 *	A standard Tcl result object.
 *
 * Side effects:
 *	A variable will be created if one does not already exist.
 *
 *----------------------------------------------------------------------
 */

int
TclArraySet(interp, arrayNameObj, arrayElemObj)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Obj *arrayNameObj;	/* The array name. */
    Tcl_Obj *arrayElemObj;	/* The array elements list or dict.  If
				 * this is NULL, create an empty array. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj **elemPtrs;
    int result, elemLen, i, nameLen;
    char *varName, *p;
    
    varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
    p = varName + nameLen - 1;
    if (*p == ')') {
	while (--p >= varName) {
	    if (*p == '(') {
		TclVarErrMsg(interp, varName, NULL, "set", needArray);
		return TCL_ERROR;







|












<














|



|


|
|












|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

>
>
>
>
>
>
>
|
>
>
>
|
>
>

>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
|
<
>
>
|
|
|
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
<
|
|
|
|
>
|
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|



|









|
|
|














|
|





|







2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764

2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860

2861
2862
2863
2864
2865
2866
2867
2868






















































































































































































2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906































2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104


3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125

3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172

3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
    /*
     * The list of constants below should match the arrayOptions string array
     * below.
     */

    enum {ARRAY_ANYMORE, ARRAY_DONESEARCH,  ARRAY_EXISTS, ARRAY_GET,
	  ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
	  ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET};
    static CONST char *arrayOptions[] = {
	"anymore", "donesearch", "exists", "get", "names", "nextelement",
	"set", "size", "startsearch", "statistics", "unset", (char *) NULL
    };

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *varNamePtr;
    int notArray;
    char *varName;
    int index, result;


    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
	    0, &index) != TCL_OK) {
    	return TCL_ERROR;
    }

    /*
     * Locate the array variable
     */

    varNamePtr = objv[2];
    varName = TclGetString(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    /*
     * Special array trace used to keep the env array in sync for array names,
     * array get, etc.
     */

    if (varPtr != NULL && varPtr->tracePtr != NULL
	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
	if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, varName,
		NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
	    return TCL_ERROR;
	}
    }

    /*
     * Verify that it is indeed an array variable. This test comes after the
     * traces - the variable may actually become an array as an effect of said
     * traces.
     */

    notArray = 0;
    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
	    || TclIsVarUndefined(varPtr)) {
	notArray = 1;
    }

    switch (index) {
    case ARRAY_ANYMORE: {
	ArraySearch *searchPtr;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
	    return TCL_ERROR;
	}
	if (notArray) {
	    goto error;
	}
	searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
	if (searchPtr == NULL) {
	    return TCL_ERROR;
	}
	while (1) {
	    Var *varPtr2;

	    if (searchPtr->nextEntry != NULL) {
		varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
		if (!TclIsVarUndefined(varPtr2)) {
		    break;
		}
	    }
	    searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
	    if (searchPtr->nextEntry == NULL) {
		Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[0]);
		return TCL_OK;
	    }
	}
	Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[1]);
	break;
    }
    case ARRAY_DONESEARCH: {
	ArraySearch *searchPtr, *prevPtr;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
	    return TCL_ERROR;
	}
	if (notArray) {
	    goto error;
	}
	searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
	if (searchPtr == NULL) {
	    return TCL_ERROR;
	}
	if (varPtr->searchPtr == searchPtr) {
	    varPtr->searchPtr = searchPtr->nextPtr;
	} else {

	    for (prevPtr=varPtr->searchPtr ;; prevPtr=prevPtr->nextPtr) {
		if (prevPtr->nextPtr == searchPtr) {
		    prevPtr->nextPtr = searchPtr->nextPtr;
		    break;
		}
	    }
	}
	ckfree((char *) searchPtr);






















































































































































































	break;
    }
    case ARRAY_NEXTELEMENT: {
	ArraySearch *searchPtr;
	Tcl_HashEntry *hPtr;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
	    return TCL_ERROR;
	}
	if (notArray) {
	    goto error;
	}
	searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
	if (searchPtr == NULL) {
	    return TCL_ERROR;
	}
	while (1) {
	    Var *varPtr2;

	    hPtr = searchPtr->nextEntry;
	    if (hPtr == NULL) {
		hPtr = Tcl_NextHashEntry(&searchPtr->search);
		if (hPtr == NULL) {
		    return TCL_OK;
		}
	    } else {
		searchPtr->nextEntry = NULL;
	    }
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (!TclIsVarUndefined(varPtr2)) {
		break;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1));
	break;
    }































    case ARRAY_STARTSEARCH: {
	ArraySearch *searchPtr;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
	    return TCL_ERROR;
	}
	if (notArray) {
	    goto error;
	}
	searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
	if (varPtr->searchPtr == NULL) {
	    searchPtr->id = 1;
	    Tcl_AppendResult(interp, "s-1-", varName, NULL);
	} else {
	    char string[TCL_INTEGER_SPACE];

	    searchPtr->id = varPtr->searchPtr->id + 1;
	    TclFormatInt(string, searchPtr->id);
	    Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
	}
	searchPtr->varPtr = varPtr;
	searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
		&searchPtr->search);
	searchPtr->nextPtr = varPtr->searchPtr;
	varPtr->searchPtr = searchPtr;
	break;
    }

    case ARRAY_EXISTS:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]);
	break;
    case ARRAY_GET: {
	Tcl_HashSearch search;
	Var *varPtr2;
	char *pattern = NULL;
	char *name;
	Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr;
	int i, count;

	if ((objc != 3) && (objc != 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
	    return TCL_ERROR;
	}
	if (notArray) {
	    return TCL_OK;
	}
	if (objc == 4) {
	    pattern = TclGetString(objv[3]);
	}

	/*
	 * Store the array names in a new object.
	 */

	TclNewObj(nameLstPtr);
	Tcl_IncrRefCount(nameLstPtr);
	if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
	    hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
	    if (hPtr == NULL) {
		goto searchDone;
	    }
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (TclIsVarUndefined(varPtr2)) {
		goto searchDone;
	    }
	    result = Tcl_ListObjAppendElement(interp, nameLstPtr,
		    Tcl_NewStringObj(pattern, -1));
	    if (result != TCL_OK) {
		TclDecrRefCount(nameLstPtr);
		return result;
	    }
	    goto searchDone;
	}
	for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (TclIsVarUndefined(varPtr2)) {
		continue;
	    }
	    name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
	    if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
		continue;	/* element name doesn't match pattern */
	    }

	    namePtr = Tcl_NewStringObj(name, -1);
	    result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr);
	    if (result != TCL_OK) {
		TclDecrRefCount(namePtr);	/* free unneeded name obj */
		TclDecrRefCount(nameLstPtr);
		return result;
	    }
	}

    searchDone:
	/*
	 * Make sure the Var structure of the array is not removed by a trace
	 * while we're working.
	 */

	varPtr->refCount++;

	/*
	 * Get the array values corresponding to each element name
	 */

	TclNewObj(tmpResPtr);
	result = Tcl_ListObjGetElements(interp, nameLstPtr,
		&count, &namePtrPtr);
	if (result != TCL_OK) {
	    goto errorInArrayGet;
	}

	for (i=0 ; i<count ; i++) {
	    namePtr = *namePtrPtr++;
	    valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
		    TCL_LEAVE_ERR_MSG);
	    if (valuePtr == NULL) {
		/*
		 * Some trace played a trick on us; we need to diagnose to
		 * adapt our behaviour: was the array element unset, or did
		 * the modification modify the complete array?
		 */

		if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
		    /*
		     * The array itself looks OK, the variable was undefined:
		     * forget it.
		     */

		    continue;
		} else {
		    result = TCL_ERROR;
		    goto errorInArrayGet;
		}
	    }
	    result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr);
	    if (result != TCL_OK) {
		goto errorInArrayGet;
	    }
	}
	varPtr->refCount--;
	Tcl_SetObjResult(interp, tmpResPtr);
	TclDecrRefCount(nameLstPtr);
	break;

    errorInArrayGet:
	varPtr->refCount--;
	TclDecrRefCount(nameLstPtr);
	TclDecrRefCount(tmpResPtr);	/* free unneeded temp result */
	return result;
    }
    case ARRAY_NAMES: {
	Tcl_HashSearch search;
	Var *varPtr2;
	char *pattern = NULL;
	char *name;
	Tcl_Obj *namePtr, *resultPtr;
	int mode, matched = 0;
	static CONST char *options[] = {
	    "-exact", "-glob", "-regexp", (char *) NULL
	};
	enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };

	mode = OPT_GLOB;

	if ((objc < 3) || (objc > 5)) {
	    Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?");
	    return TCL_ERROR;
	}
	if (notArray) {
	    return TCL_OK;
	}
	if (objc == 4) {
	    pattern = TclGetString(objv[3]);
	} else if (objc == 5) {
	    pattern = TclGetString(objv[4]);
	    if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", 0,
		    &mode) != TCL_OK) {
		return TCL_ERROR;
	    }
	}
	TclNewObj(resultPtr);
	if (((enum options) mode)==OPT_GLOB && pattern!=NULL &&
		TclMatchIsTrivial(pattern)) {
	    hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
	    if ((hPtr != NULL) &&
		    !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr))) {
		result = Tcl_ListObjAppendElement(interp, resultPtr,
			Tcl_NewStringObj(pattern, -1));
		if (result != TCL_OK) {
		    TclDecrRefCount(resultPtr);
		    return result;
		}


	    }
	    Tcl_SetObjResult(interp, resultPtr);
	    return TCL_OK;
	}
	for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (TclIsVarUndefined(varPtr2)) {
		continue;
	    }
	    name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
	    if (objc > 3) {
		switch ((enum options) mode) {
		case OPT_EXACT:
		    matched = (strcmp(name, pattern) == 0);
		    break;
		case OPT_GLOB:
		    matched = Tcl_StringMatch(name, pattern);
		    break;
		case OPT_REGEXP:
		    matched = Tcl_RegExpMatch(interp, name, pattern);

		    if (matched < 0) {
			TclDecrRefCount(resultPtr);
			return TCL_ERROR;
		    }
		    break;
		}
		if (matched == 0) {
		    continue;
		}
	    }

	    namePtr = Tcl_NewStringObj(name, -1);
	    result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
	    if (result != TCL_OK) {
		TclDecrRefCount(resultPtr);
		TclDecrRefCount(namePtr);	/* free unneeded name obj */
		return result;
	    }
	}
	Tcl_SetObjResult(interp, resultPtr);
	break;
    }
    case ARRAY_SET:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
	    return TCL_ERROR;
	}
	return TclArraySet(interp, objv[2], objv[3]);
    case ARRAY_UNSET: {
	Tcl_HashSearch search;
	Var *varPtr2;
	char *pattern = NULL;
	char *name;

	if ((objc != 3) && (objc != 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
	    return TCL_ERROR;
	}
	if (notArray) {
	    return TCL_OK;
	}
	if (objc == 3) {
	    /*
	     * When no pattern is given, just unset the whole array.
	     */

	    if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) != TCL_OK) {

		return TCL_ERROR;
	    }
	} else {
	    pattern = TclGetString(objv[3]);
	    if (TclMatchIsTrivial(pattern)) {
		hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
		if (hPtr != NULL &&
			!TclIsVarUndefined((Var *)Tcl_GetHashValue(hPtr))){
		    return TclObjUnsetVar2(interp, varNamePtr, pattern, 0);
		}
		return TCL_OK;
	    }
	    for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		    hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
		varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		if (TclIsVarUndefined(varPtr2)) {
		    continue;
		}
		name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
		if (Tcl_StringMatch(name, pattern) &&
			TclObjUnsetVar2(interp, varNamePtr, name,
				0) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	}
	break;
    }

    case ARRAY_SIZE: {
	Tcl_HashSearch search;
	Var *varPtr2;
	int size;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
	    return TCL_ERROR;
	}
	size = 0;

	/*
	 * Must iterate in order to get chance to check for present but
	 * "undefined" entries.
	 */

	if (!notArray) {
	    for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		    hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
		varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		if (TclIsVarUndefined(varPtr2)) {
		    continue;
		}
		size++;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
	break;
    }

    case ARRAY_STATISTICS: {
	CONST char *stats;

	if (notArray) {
	    goto error;
	}

	stats = Tcl_HashStats(varPtr->value.tablePtr);
	if (stats != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
	    ckfree((void *)stats);
	} else {
	    Tcl_SetResult(interp, "error reading array statistics",TCL_STATIC);
	    return TCL_ERROR;
	}
	break;
    }
    }
    return TCL_OK;

  error:
    Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArraySet --
 *
 *	Set the elements of an array.  If there are no elements to set, create
 *	an empty array.  This routine is used by the Tcl_ArrayObjCmd and by
 *	the TclSetupEnv routine.
 *
 * Results:
 *	A standard Tcl result object.
 *
 * Side effects:
 *	A variable will be created if one does not already exist.
 *
 *----------------------------------------------------------------------
 */

int
TclArraySet(interp, arrayNameObj, arrayElemObj)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Obj *arrayNameObj;	/* The array name. */
    Tcl_Obj *arrayElemObj;	/* The array elements list or dict.  If this
				 * is NULL, create an empty array. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj **elemPtrs;
    int result, elemLen, i, nameLen;
    char *varName, *p;

    varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
    p = varName + nameLen - 1;
    if (*p == ')') {
	while (--p >= varName) {
	    if (*p == '(') {
		TclVarErrMsg(interp, varName, NULL, "set", needArray);
		return TCL_ERROR;
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195

3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211

3212
3213
3214
3215
3216
3217
3218
3219
3220
	int done;

	if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (done == 0) {
	    /*
	     * Empty, so we'll just force the array to be properly
	     * existing instead.
	     */

	    goto ensureArray;
	}

	/*
	 * Don't need to look at result of Tcl_DictObjFirst as we've
	 * just successfully used a dictionary operation on the same
	 * object.
	 */

	for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
		&keyPtr, &valuePtr, &done) ; !done ;
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
	    /*
	     * At this point, it would be nice if the key was directly
	     * usable by the array.  This isn't the case though.
	     */

	    char *part2 = TclGetString(keyPtr);
	    Var *elemVarPtr = TclLookupArrayElement(interp, varName, 
		    part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);

	    if ((elemVarPtr == NULL) ||
		    (TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
		    part2, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) {
		Tcl_DictObjDone(&search);
		return TCL_ERROR;







|
|

>




|
|
<






|
|

>

|







3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332

3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
	int done;

	if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (done == 0) {
	    /*
	     * Empty, so we'll just force the array to be properly existing
	     * instead.
	     */

	    goto ensureArray;
	}

	/*
	 * Don't need to look at result of Tcl_DictObjFirst as we've just
	 * successfully used a dictionary operation on the same object.

	 */

	for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
		&keyPtr, &valuePtr, &done) ; !done ;
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
	    /*
	     * At this point, it would be nice if the key was directly usable
	     * by the array.  This isn't the case though.
	     */

	    char *part2 = TclGetString(keyPtr);
	    Var *elemVarPtr = TclLookupArrayElement(interp, varName,
		    part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);

	    if ((elemVarPtr == NULL) ||
		    (TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
		    part2, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) {
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253

3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317

3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
	    return TCL_ERROR;
	}
	if (elemLen == 0) {
	    goto ensureArray;
	}

	/*
	 * We needn't worry about traces invalidating arrayPtr: should
	 * that be the case, TclPtrSetVar will return NULL so that we
	 * break out of the loop and return an error.
	 */

	for (i = 0;  i < elemLen;  i += 2) {
	    char *part2 = TclGetString(elemPtrs[i]);
	    Var *elemVarPtr = TclLookupArrayElement(interp, varName, 
		    part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);

	    if ((elemVarPtr == NULL) ||
		    (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, part2,
		    elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
		result = TCL_ERROR;
		break;
	    }
	}
	return result;
    }

    /*
     * The list is empty make sure we have an array, or create
     * one if necessary.
     */

  ensureArray:    
    if (varPtr != NULL) {
	if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
	    /*
	     * Already an array, done.
	     */
	    
	    return TCL_OK;
	}
	if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
	    /*
	     * Either an array element, or a scalar: lose!
	     */

	    TclVarErrMsg(interp, varName, (char *)NULL, "array set",
		    needArray);
	    return TCL_ERROR;
	}
    }
    TclSetVarArray(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ObjMakeUpvar --
 *
 *	This procedure does all of the work of the "global" and "upvar"
 *	commands.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs then an
 *	error message is left in iPtr->result.
 *
 * Side effects:
 *	The variable given by myName is linked to the variable in framePtr
 *	given by otherP1 and otherP2, so that references to myName are
 *	redirected to the other variable like a symbolic link.
 *
 *----------------------------------------------------------------------
 */

static int
ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index)

    Tcl_Interp *interp;		/* Interpreter containing variables. Used
			         * for error messages, too. */
    CallFrame *framePtr;	/* Call frame containing "other" variable.
				 * NULL means use global :: context. */
    Tcl_Obj *otherP1Ptr;
    CONST char *otherP2;	/* Two-part name of variable in framePtr. */
    CONST int otherFlags;	/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of "other" variable. */
    CONST char *myName;		/* Name of variable which will refer to
				 * otherP1/otherP2. Must be a scalar. */
    int myFlags;		/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of myName. */
    int index;                  /* If the variable to be linked is an indexed
				 * scalar, this is its index. Otherwise, -1. */
{
    Interp *iPtr = (Interp *) interp;
    Var *otherPtr, *varPtr, *arrayPtr;
    CallFrame *varFramePtr;
    CONST char *errMsg;
    CONST char *p;

    /*
     * Find "other" in "framePtr". If not looking up other in just the
     * current namespace, temporarily replace the current var frame
     * pointer in the interpreter in order to use TclObjLookupVar.
     */

    varFramePtr = iPtr->varFramePtr;
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	iPtr->varFramePtr = framePtr;
    }
    otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
	    (otherFlags | TCL_LEAVE_ERR_MSG), "access",
            /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	iPtr->varFramePtr = varFramePtr;
    }
    if (otherPtr == NULL) {
	return TCL_ERROR;
    }

    if (index >= 0) {
	if (!varFramePtr->isProcCallFrame) {
	    Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n");
	}
	varPtr = &(varFramePtr->compiledLocals[index]);
    } else {
	/*
	 * Check that we are not trying to create a namespace var linked to
	 * a local variable in a procedure. If we allowed this, the local
	 * variable in the shorter-lived procedure frame could go away
	 * leaving the namespace var's reference invalid.
	 */
	
	if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) 
	    && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		|| (varFramePtr == NULL)
		|| !varFramePtr->isProcCallFrame
		|| (strstr(myName, "::") != NULL))) {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
		    myName, "\": upvar won't create namespace variable that ",
		    "refers to procedure variable", (char *) NULL);
	    return TCL_ERROR;
	}
	
	/*
	 * Do not permit the new variable to look like an array reference,
	 * as it will not be reachable in that case [Bug 600812, TIP 184].
	 * The "definition" of what "looks like an array reference" is 
	 * consistent (and must remain consistent) with the code in 
	 * TclObjLookupVar().
	 */

	p = strstr(myName, "(");
	if (p != NULL) {
	    p += strlen(p)-1;
	    if (*p == ')') {
	        /*
		 * myName looks like an array reference.
		 */
		    
		Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
		        myName, "\": upvar won't create a scalar variable that ",
		    "looks like an array element", (char *) NULL);
		return TCL_ERROR;
	    }
	}

	/*
	 * Lookup and eventually create the new variable. Set the flag bit
	 * LOOKUP_FOR_UPVAR to indicate the special resolution rules for 
	 * upvar purposes: 
	 *   - Bug #696893 - variable is either proc-local or in the current
	 *     namespace; never follow the second (global) resolution path 
	 *   - Bug #631741 - do not use special namespace or interp resolvers
	 */
	
	varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR), 
	        /* create */ 1, &errMsg, &index);
	if (varPtr == NULL) {
	    TclVarErrMsg(interp, myName, NULL, "create", errMsg);
	    return TCL_ERROR;
	}
    }

    if (varPtr == otherPtr) {
	Tcl_SetResult((Tcl_Interp *) iPtr,
		      "can't upvar from variable to itself", TCL_STATIC);
	return TCL_ERROR;
    }

    if (varPtr->tracePtr != NULL) {
	Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
	        "\" has traces: can't use for upvar", (char *) NULL);
	return TCL_ERROR;
    } else if (!TclIsVarUndefined(varPtr)) {
	/*
	 * The variable already existed. Make sure this variable "varPtr"
	 * isn't the same as "otherPtr" (avoid circular links). Also, if
	 * it's not an upvar then it's an error. If it is an upvar, then
	 * just disconnect it from the thing it currently refers to.
	 */

	if (TclIsVarLink(varPtr)) {
	    Var *linkPtr = varPtr->value.linkPtr;
	    if (linkPtr == otherPtr) {
		return TCL_OK;
	    }







|
|
|


|

|

>











|
|


|





|







|
<




















|
|










|
>
|
|










|
|








|
|
|








|








|





|
|
|
|

|
|


|






|

|
|
|
|
<






|


|

|
|






|
|

|
|

|
|
|








|





|




|
|
|







3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415

3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519

3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
	    return TCL_ERROR;
	}
	if (elemLen == 0) {
	    goto ensureArray;
	}

	/*
	 * We needn't worry about traces invalidating arrayPtr: should that be
	 * the case, TclPtrSetVar will return NULL so that we break out of the
	 * loop and return an error.
	 */

	for (i=0 ; i<elemLen ; i+=2) {
	    char *part2 = TclGetString(elemPtrs[i]);
	    Var *elemVarPtr = TclLookupArrayElement(interp, varName,
		    part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);

	    if ((elemVarPtr == NULL) ||
		    (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, part2,
		    elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
		result = TCL_ERROR;
		break;
	    }
	}
	return result;
    }

    /*
     * The list is empty make sure we have an array, or create one if
     * necessary.
     */

  ensureArray:
    if (varPtr != NULL) {
	if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
	    /*
	     * Already an array, done.
	     */

	    return TCL_OK;
	}
	if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
	    /*
	     * Either an array element, or a scalar: lose!
	     */

	    TclVarErrMsg(interp, varName, (char*)NULL, "array set", needArray);

	    return TCL_ERROR;
	}
    }
    TclSetVarArray(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ObjMakeUpvar --
 *
 *	This procedure does all of the work of the "global" and "upvar"
 *	commands.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs then an error
 *	message is left in iPtr->result.
 *
 * Side effects:
 *	The variable given by myName is linked to the variable in framePtr
 *	given by otherP1 and otherP2, so that references to myName are
 *	redirected to the other variable like a symbolic link.
 *
 *----------------------------------------------------------------------
 */

static int
ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName,
	myFlags, index)
    Tcl_Interp *interp;		/* Interpreter containing variables. Used for
				 * error messages, too. */
    CallFrame *framePtr;	/* Call frame containing "other" variable.
				 * NULL means use global :: context. */
    Tcl_Obj *otherP1Ptr;
    CONST char *otherP2;	/* Two-part name of variable in framePtr. */
    CONST int otherFlags;	/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of "other" variable. */
    CONST char *myName;		/* Name of variable which will refer to
				 * otherP1/otherP2. Must be a scalar. */
    int myFlags;		/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of myName. */
    int index;			/* If the variable to be linked is an indexed
				 * scalar, this is its index. Otherwise, -1 */
{
    Interp *iPtr = (Interp *) interp;
    Var *otherPtr, *varPtr, *arrayPtr;
    CallFrame *varFramePtr;
    CONST char *errMsg;
    CONST char *p;

    /*
     * Find "other" in "framePtr". If not looking up other in just the current
     * namespace, temporarily replace the current var frame pointer in the
     * interpreter in order to use TclObjLookupVar.
     */

    varFramePtr = iPtr->varFramePtr;
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	iPtr->varFramePtr = framePtr;
    }
    otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
	    (otherFlags | TCL_LEAVE_ERR_MSG), "access",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	iPtr->varFramePtr = varFramePtr;
    }
    if (otherPtr == NULL) {
	return TCL_ERROR;
    }

    if (index >= 0) {
	if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
	    Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n");
	}
	varPtr = &(varFramePtr->compiledLocals[index]);
    } else {
	/*
	 * Check that we are not trying to create a namespace var linked to a
	 * local variable in a procedure. If we allowed this, the local
	 * variable in the shorter-lived procedure frame could go away leaving
	 * the namespace var's reference invalid.
	 */

	if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
	    && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		|| (varFramePtr == NULL)
		|| !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
		|| (strstr(myName, "::") != NULL))) {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
		    myName, "\": upvar won't create namespace variable that ",
		    "refers to procedure variable", (char *) NULL);
	    return TCL_ERROR;
	}

	/*
	 * Do not permit the new variable to look like an array reference, as
	 * it will not be reachable in that case [Bug 600812, TIP 184].  The
	 * "definition" of what "looks like an array reference" is consistent
	 * (and must remain consistent) with the code in TclObjLookupVar().

	 */

	p = strstr(myName, "(");
	if (p != NULL) {
	    p += strlen(p)-1;
	    if (*p == ')') {
		/*
		 * myName looks like an array reference.
		 */

		Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
			myName, "\": upvar won't create a scalar variable ",
			"that looks like an array element", (char *) NULL);
		return TCL_ERROR;
	    }
	}

	/*
	 * Lookup and eventually create the new variable. Set the flag bit
	 * LOOKUP_FOR_UPVAR to indicate the special resolution rules for upvar
	 * purposes:
	 *   - Bug #696893 - variable is either proc-local or in the current
	 *     namespace; never follow the second (global) resolution path.
	 *   - Bug #631741 - do not use special namespace or interp resolvers.
	 */

	varPtr = TclLookupSimpleVar(interp, myName, (myFlags|LOOKUP_FOR_UPVAR),
		/* create */ 1, &errMsg, &index);
	if (varPtr == NULL) {
	    TclVarErrMsg(interp, myName, NULL, "create", errMsg);
	    return TCL_ERROR;
	}
    }

    if (varPtr == otherPtr) {
	Tcl_SetResult((Tcl_Interp *) iPtr,
		"can't upvar from variable to itself", TCL_STATIC);
	return TCL_ERROR;
    }

    if (varPtr->tracePtr != NULL) {
	Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
		"\" has traces: can't use for upvar", (char *) NULL);
	return TCL_ERROR;
    } else if (!TclIsVarUndefined(varPtr)) {
	/*
	 * The variable already existed. Make sure this variable "varPtr"
	 * isn't the same as "otherPtr" (avoid circular links). Also, if it's
	 * not an upvar then it's an error. If it is an upvar, then just
	 * disconnect it from the thing it currently refers to.
	 */

	if (TclIsVarLink(varPtr)) {
	    Var *linkPtr = varPtr->value.linkPtr;
	    if (linkPtr == otherPtr) {
		return TCL_OK;
	    }
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpVar --
 *
 *	This procedure links one variable to another, just like
 *	the "upvar" command.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs then
 *	an error message is left in the interp's result.
 *
 * Side effects:
 *	The variable in frameName whose name is given by varName becomes
 *	accessible under the name localName, so that references to
 *	localName are redirected to the other variable like a symbolic
 *	link.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UpVar(interp, frameName, varName, localName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *frameName;	/* Name of the frame containing the source
				 * variable, such as "1" or "#0". */
    CONST char *varName;	/* Name of a variable in interp to link to.
				 * May be either a scalar name or an
				 * element in an array. */
    CONST char *localName;	/* Name of link variable. */
    int flags;			/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of localName. */
{
    return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpVar2 --
 *
 *	This procedure links one variable to another, just like
 *	the "upvar" command.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs then
 *	an error message is left in the interp's result.
 *
 * Side effects:
 *	The variable in frameName whose name is given by part1 and
 *	part2 becomes accessible under the name localName, so that
 *	references to localName are redirected to the other variable
 *	like a symbolic link.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
    Tcl_Interp *interp;		/* Interpreter containing variables.  Used
				 * for error messages too. */
    CONST char *frameName;	/* Name of the frame containing the source
				 * variable, such as "1" or "#0". */
    CONST char *part1;
    CONST char *part2;		/* Two parts of source variable name to
				 * link to. */
    CONST char *localName;	/* Name of link variable. */
    int flags;			/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of localName. */
{
    int result;
    CallFrame *framePtr;
    Tcl_Obj *part1Ptr;







|
|


|
|



|
|
<






|
|



|
|












|
|


|
|


|
|
|
<






|
|



|
|







3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609

3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645

3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpVar --
 *
 *	This procedure links one variable to another, just like the "upvar"
 *	command.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs then an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	The variable in frameName whose name is given by varName becomes
 *	accessible under the name localName, so that references to localName
 *	are redirected to the other variable like a symbolic link.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_UpVar(interp, frameName, varName, localName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is to
				 * be looked up. */
    CONST char *frameName;	/* Name of the frame containing the source
				 * variable, such as "1" or "#0". */
    CONST char *varName;	/* Name of a variable in interp to link to.
				 * May be either a scalar name or an element
				 * in an array. */
    CONST char *localName;	/* Name of link variable. */
    int flags;			/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of localName. */
{
    return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpVar2 --
 *
 *	This procedure links one variable to another, just like the "upvar"
 *	command.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs then an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	The variable in frameName whose name is given by part1 and part2
 *	becomes accessible under the name localName, so that references to
 *	localName are redirected to the other variable like a symbolic link.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
    Tcl_Interp *interp;		/* Interpreter containing variables.  Used for
				 * error messages too. */
    CONST char *frameName;	/* Name of the frame containing the source
				 * variable, such as "1" or "#0". */
    CONST char *part1;
    CONST char *part2;		/* Two parts of source variable name to link
				 * to. */
    CONST char *localName;	/* Name of link variable. */
    int flags;			/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of localName. */
{
    int result;
    CallFrame *framePtr;
    Tcl_Obj *part1Ptr;
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVariableFullName --
 *
 *	Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this
 *	procedure appends to an object the namespace variable's full
 *	name, qualified by a sequence of parent namespace names.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The variable's fully-qualified name is appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetVariableFullName(interp, variable, objPtr)
    Tcl_Interp *interp;	        /* Interpreter containing the variable. */
    Tcl_Var variable;		/* Token for the variable returned by a
				 * previous call to Tcl_FindNamespaceVar. */
    Tcl_Obj *objPtr;		/* Points to the object onto which the
				 * variable's full name is appended. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr = (Var *) variable;
    char *name;

    /*
     * Add the full name of the containing namespace (if any), followed by
     * the "::" separator, then the variable name.
     */

    if (varPtr != NULL) {
	if (!TclIsVarArrayElement(varPtr)) {
	    if (varPtr->nsPtr != NULL) {
		Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1);
		if (varPtr->nsPtr != iPtr->globalNsPtr) {







|
|
|


|


|







|










|
|







3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVariableFullName --
 *
 *	Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this procedure
 *	appends to an object the namespace variable's full name, qualified by
 *	a sequence of parent namespace names.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The variable's fully-qualified name is appended to the string
 *	representation of objPtr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetVariableFullName(interp, variable, objPtr)
    Tcl_Interp *interp;		/* Interpreter containing the variable. */
    Tcl_Var variable;		/* Token for the variable returned by a
				 * previous call to Tcl_FindNamespaceVar. */
    Tcl_Obj *objPtr;		/* Points to the object onto which the
				 * variable's full name is appended. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr = (Var *) variable;
    char *name;

    /*
     * Add the full name of the containing namespace (if any), followed by the
     * "::" separator, then the variable name.
     */

    if (varPtr != NULL) {
	if (!TclIsVarArrayElement(varPtr)) {
	    if (varPtr->nsPtr != NULL) {
		Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1);
		if (varPtr->nsPtr != iPtr->globalNsPtr) {
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
	return TCL_ERROR;
    }

    /*
     * If we are not executing inside a Tcl procedure, just return.
     */
    
    if ((iPtr->varFramePtr == NULL)
	    || !iPtr->varFramePtr->isProcCallFrame) {
	return TCL_OK;
    }

    for (i = 1;  i < objc;  i++) {
	/*
	 * Make a local variable linked to its counterpart in the global ::
	 * namespace.
	 */
	
	objPtr = objv[i];
	varName = TclGetString(objPtr);

	/*
	 * The variable name might have a scope qualifier, but the name for
         * the local "link" variable must be the simple name at the tail.
	 */

	for (tail = varName;  *tail != '\0';  tail++) {
	    /* empty body */
	}
        while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
            tail--;
	}
        if ((*tail == ':') && (tail > varName)) {
            tail++;
	}

	/*
	 * Link to the variable "varName" in the global :: namespace.
	 */
	
	result = ObjMakeUpvar(interp, (CallFrame *) NULL,
		objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
	        /*myName*/ tail, /*myFlags*/ 0, -1);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}








|

|








|





|





|
|

|
|





|


|







3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
	return TCL_ERROR;
    }

    /*
     * If we are not executing inside a Tcl procedure, just return.
     */

    if ((iPtr->varFramePtr == NULL)
	    || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
	return TCL_OK;
    }

    for (i = 1;  i < objc;  i++) {
	/*
	 * Make a local variable linked to its counterpart in the global ::
	 * namespace.
	 */

	objPtr = objv[i];
	varName = TclGetString(objPtr);

	/*
	 * The variable name might have a scope qualifier, but the name for
	 * the local "link" variable must be the simple name at the tail.
	 */

	for (tail = varName;  *tail != '\0';  tail++) {
	    /* empty body */
	}
	while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
	    tail--;
	}
	if ((*tail == ':') && (tail > varName)) {
	    tail++;
	}

	/*
	 * Link to the variable "varName" in the global :: namespace.
	 */

	result = ObjMakeUpvar(interp, (CallFrame *) NULL,
		objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
		/*myName*/ tail, /*myFlags*/ 0, -1);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
 *	    variable ?name value...? name ?value?
 *
 *	One or more variables can be created. The variables are initialized
 *	with the specified values. The value for the last variable is
 *	optional.
 *
 *	If the variable does not exist, it is created and given the optional
 *	value. If it already exists, it is simply set to the optional
 *	value. Normally, "name" is an unqualified name, so it is created in
 *	the current namespace. If it includes namespace qualifiers, it can
 *	be created in another namespace.
 *
 *	If the variable command is executed inside a Tcl procedure, it
 *	creates a local variable linked to the newly-created namespace
 *	variable.
 *
 * Results:
 *	Returns TCL_OK if the variable is found or created. Returns
 *	TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error message
 *	as the result in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_VariableObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */







|
|
|
|

|
|
<


|
|


|
|







3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837

3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
 *	    variable ?name value...? name ?value?
 *
 *	One or more variables can be created. The variables are initialized
 *	with the specified values. The value for the last variable is
 *	optional.
 *
 *	If the variable does not exist, it is created and given the optional
 *	value. If it already exists, it is simply set to the optional value.
 *	Normally, "name" is an unqualified name, so it is created in the
 *	current namespace. If it includes namespace qualifiers, it can be
 *	created in another namespace.
 *
 *	If the variable command is executed inside a Tcl procedure, it creates
 *	a local variable linked to the newly-created namespace variable.

 *
 * Results:
 *	Returns TCL_OK if the variable is found or created. Returns TCL_ERROR
 *	if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error message as the
 *	result in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_VariableObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757

3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
	return TCL_ERROR;
    }

    for (i = 1;  i < objc;  i = i+2) {
	/*
	 * Look up each variable in the current namespace context, creating
	 * it if necessary.
	 */
	
	varNamePtr = objv[i];
	varName = TclGetString(varNamePtr);
	varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
                (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
                /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
	
        if (arrayPtr != NULL) {
            /*
             * Variable cannot be an element in an array.  If arrayPtr is
             * non-null, it is, so throw up an error and return.
             */

            TclVarErrMsg(interp, varName, NULL, "define", isArrayElement);
            return TCL_ERROR;
        }

	if (varPtr == NULL) {
	    return TCL_ERROR;
	}

	/*
	 * Mark the variable as a namespace variable and increment its 
	 * reference count so that it will persist until its namespace is
	 * destroyed or until the variable is unset.
	 */

	if (!TclIsVarNamespaceVar(varPtr)) {
	    TclSetVarNamespaceVar(varPtr);
	    varPtr->refCount++;
	}

	/*
	 * If a value was specified, set the variable to that value.
	 * Otherwise, if the variable is new, leave it undefined.
	 * (If the variable already exists and no value was specified,
	 * leave its value unchanged; just create the local link if
	 * we're in a Tcl procedure).
	 */

	if (i+1 < objc) {	/* a value was specified */
	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
		    objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}

	/*
	 * If we are executing inside a Tcl procedure, create a local
	 * variable linked to the new namespace variable "varName".
	 */

	if ((iPtr->varFramePtr != NULL)
	        && iPtr->varFramePtr->isProcCallFrame) {
	    /*
	     * varName might have a scope qualifier, but the name for the
	     * local "link" variable must be the simple name at the tail.
	     *
	     * Locate tail in one pass: drop any prefix after two *or more*
	     * consecutive ":" characters).
	     */

	    for (tail = cp = varName;  *cp != '\0'; ) {
		if (*cp++ == ':') {
		    while (*cp == ':') {
			tail = ++cp;
		    }
		}
	    }
	    
	    /*
	     * Create a local link "tail" to the variable "varName" in the
	     * current namespace.
	     */
	    
	    result = ObjMakeUpvar(interp, (CallFrame *) NULL,
		    /*otherP1*/ varNamePtr, /*otherP2*/ NULL,
                    /*otherFlags*/ TCL_NAMESPACE_ONLY,
		    /*myName*/ tail, /*myFlags*/ 0, -1);
	    if (result != TCL_OK) {
		return result;
	    }
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpvarObjCmd --
 *
 *	This object-based procedure is invoked to process the "upvar"
 *	Tcl command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|

|



|
|
|
|
|
|
|
|
>
|
|
|






|











|
|
|
<











|
|



|








|






|




|


|














|
|







3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910

3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
	return TCL_ERROR;
    }

    for (i = 1;  i < objc;  i = i+2) {
	/*
	 * Look up each variable in the current namespace context, creating it
	 * if necessary.
	 */

	varNamePtr = objv[i];
	varName = TclGetString(varNamePtr);
	varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
		(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
		/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);

	if (arrayPtr != NULL) {
	    /*
	     * Variable cannot be an element in an array.  If arrayPtr is
	     * non-null, it is, so throw up an error and return.
	     */

	    TclVarErrMsg(interp, varName, NULL, "define", isArrayElement);
	    return TCL_ERROR;
	}

	if (varPtr == NULL) {
	    return TCL_ERROR;
	}

	/*
	 * Mark the variable as a namespace variable and increment its
	 * reference count so that it will persist until its namespace is
	 * destroyed or until the variable is unset.
	 */

	if (!TclIsVarNamespaceVar(varPtr)) {
	    TclSetVarNamespaceVar(varPtr);
	    varPtr->refCount++;
	}

	/*
	 * If a value was specified, set the variable to that value.
	 * Otherwise, if the variable is new, leave it undefined. (If the
	 * variable already exists and no value was specified, leave its value
	 * unchanged; just create the local link if we're in a Tcl procedure).

	 */

	if (i+1 < objc) {	/* a value was specified */
	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
		    objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}

	/*
	 * If we are executing inside a Tcl procedure, create a local variable
	 * linked to the new namespace variable "varName".
	 */

	if ((iPtr->varFramePtr != NULL)
		&& (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
	    /*
	     * varName might have a scope qualifier, but the name for the
	     * local "link" variable must be the simple name at the tail.
	     *
	     * Locate tail in one pass: drop any prefix after two *or more*
	     * consecutive ":" characters).
	     */

	    for (tail=cp=varName ; *cp!='\0' ;) {
		if (*cp++ == ':') {
		    while (*cp == ':') {
			tail = ++cp;
		    }
		}
	    }

	    /*
	     * Create a local link "tail" to the variable "varName" in the
	     * current namespace.
	     */

	    result = ObjMakeUpvar(interp, (CallFrame *) NULL,
		    /*otherP1*/ varNamePtr, /*otherP2*/ NULL,
		    /*otherFlags*/ TCL_NAMESPACE_ONLY,
		    /*myName*/ tail, /*myFlags*/ 0, -1);
	    if (result != TCL_OK) {
		return result;
	    }
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpvarObjCmd --
 *
 *	This object-based procedure is invoked to process the "upvar" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	See the user documentation.
 *
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    CallFrame *framePtr;
    char *localName;
    int result;

    if (objc < 3) {
	upvarSyntax:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?level? otherVar localVar ?otherVar localVar ...?");
	return TCL_ERROR;
    }

    /*
     * Find the call frame containing each of the "other variables" to be
     * linked to. 
     */

    result = TclObjGetFrame(interp, objv[1], &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    objc -= result+1;
    if ((objc & 1) != 0) {
	goto upvarSyntax;
    }
    objv += result+1;

    /*
     * Iterate over each (other variable, local variable) pair.
     * Divide the other variable name into two parts, then call
     * MakeUpvar to do all the work of linking it to the local variable.
     */

    for ( ;  objc > 0;  objc -= 2, objv += 2) {
	localName = TclGetString(objv[1]);
	result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
		NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NewVar --
 *
 *	Create a new heap-allocated variable that will eventually be
 *	entered into a hashtable.
 *
 * Results:
 *	The return value is a pointer to the new variable structure. It is
 *	marked as a scalar variable (and not a link or array variable). Its
 *	value initially is NULL. The variable is not part of any hash table
 *	yet. Since it will be in a hashtable and not in a call frame, its
 *	name field is set NULL. It is initially marked as undefined.
 *
 * Side effects:
 *	Storage gets allocated.
 *
 *----------------------------------------------------------------------
 */








|







|













|
|
|


|















|
|





|
|







3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    CallFrame *framePtr;
    char *localName;
    int result;

    if (objc < 3) {
    upvarSyntax:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?level? otherVar localVar ?otherVar localVar ...?");
	return TCL_ERROR;
    }

    /*
     * Find the call frame containing each of the "other variables" to be
     * linked to.
     */

    result = TclObjGetFrame(interp, objv[1], &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    objc -= result+1;
    if ((objc & 1) != 0) {
	goto upvarSyntax;
    }
    objv += result+1;

    /*
     * Iterate over each (other variable, local variable) pair.  Divide the
     * other variable name into two parts, then call MakeUpvar to do all the
     * work of linking it to the local variable.
     */

    for (; objc>0 ; objc-=2, objv+=2) {
	localName = TclGetString(objv[1]);
	result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
		NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NewVar --
 *
 *	Create a new heap-allocated variable that will eventually be entered
 *	into a hashtable.
 *
 * Results:
 *	The return value is a pointer to the new variable structure. It is
 *	marked as a scalar variable (and not a link or array variable). Its
 *	value initially is NULL. The variable is not part of any hash table
 *	yet. Since it will be in a hashtable and not in a call frame, its name
 *	field is set NULL. It is initially marked as undefined.
 *
 * Side effects:
 *	Storage gets allocated.
 *
 *----------------------------------------------------------------------
 */

3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
}

/*
 *----------------------------------------------------------------------
 *
 * SetArraySearchObj --
 *
 *	This function converts the given tcl object into one that
 *	has the "array search" internal type.
 *
 * Results:
 *	TCL_OK if the conversion succeeded, and TCL_ERROR if it failed
 *	(when an error message will be placed in the interpreter's
 *	result.)
 *
 * Side effects:
 *	Updates the internal type and representation of the object to
 *	make this an array-search object.  See the tclArraySearchType
 *	declaration above for details of the internal representation.
 *
 *----------------------------------------------------------------------
 */

static int
SetArraySearchObj(interp, objPtr)
    Tcl_Interp *interp;







|
|


|
|
<


|
|
|







4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077

4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
}

/*
 *----------------------------------------------------------------------
 *
 * SetArraySearchObj --
 *
 *	This function converts the given tcl object into one that has the
 *	"array search" internal type.
 *
 * Results:
 *	TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when
 *	an error message will be placed in the interpreter's result.)

 *
 * Side effects:
 *	Updates the internal type and representation of the object to make
 *	this an array-search object.  See the tclArraySearchType declaration
 *	above for details of the internal representation.
 *
 *----------------------------------------------------------------------
 */

static int
SetArraySearchObj(interp, objPtr)
    Tcl_Interp *interp;
3972
3973
3974
3975
3976
3977
3978

3979
3980
3981
3982
3983
3984
3985
3986
3987
3988

3989
3990
3991
3992

3993
3994
3995
3996
3997
3998
3999
4000





4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
     */

    string = TclGetString(objPtr);

    /*
     * Parse the id into the three parts separated by dashes.
     */

    if ((string[0] != 's') || (string[1] != '-')) {
	syntax:
	Tcl_AppendResult(interp, "illegal search identifier \"", string,
		"\"", (char *) NULL);
	return TCL_ERROR;
    }
    id = strtoul(string+2, &end, 10);
    if ((end == (string+2)) || (*end != '-')) {
	goto syntax;
    }

    /*
     * Can't perform value check in this context, so place reference
     * to place in string to use for the check in the object instead.
     */

    end++;
    offset = end - string;

    TclFreeIntRep(objPtr);
    objPtr->typePtr = &tclArraySearchType;
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id);
    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset);
    return TCL_OK;





}

/*
 *----------------------------------------------------------------------
 *
 * ParseSearchId --
 *
 *	This procedure translates from a tcl object to a pointer to an
 *	active array search (if there is one that matches the string).
 *
 * Results:
 *	The return value is a pointer to the array search indicated
 *	by string, or NULL if there isn't one.  If NULL is returned,
 *	the interp's result contains an error message.
 *
 * Side effects:
 *	The tcl object might have its internal type and representation
 *	modified.
 *
 *----------------------------------------------------------------------
 */







>

|
<
<
<





>

|
|

>





|
|

>
>
>
>
>







|
|


|
|
|







4099
4100
4101
4102
4103
4104
4105
4106
4107
4108



4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
     */

    string = TclGetString(objPtr);

    /*
     * Parse the id into the three parts separated by dashes.
     */

    if ((string[0] != 's') || (string[1] != '-')) {
	goto syntax;



    }
    id = strtoul(string+2, &end, 10);
    if ((end == (string+2)) || (*end != '-')) {
	goto syntax;
    }

    /*
     * Can't perform value check in this context, so place reference to place
     * in string to use for the check in the object instead.
     */

    end++;
    offset = end - string;

    TclFreeIntRep(objPtr);
    objPtr->typePtr = &tclArraySearchType;
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL) + id);
    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL) + offset);
    return TCL_OK;

  syntax:
    Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"",
	    (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseSearchId --
 *
 *	This procedure translates from a tcl object to a pointer to an active
 *	array search (if there is one that matches the string).
 *
 * Results:
 *	The return value is a pointer to the array search indicated by string,
 *	or NULL if there isn't one.  If NULL is returned, the interp's result
 *	contains an error message.
 *
 * Side effects:
 *	The tcl object might have its internal type and representation
 *	modified.
 *
 *----------------------------------------------------------------------
 */
4035
4036
4037
4038
4039
4040
4041

4042
4043
4044

4045
4046
4047

4048
4049
4050
4051
4052

4053
4054
4055
4056

4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
    register size_t offset;
    int id;
    ArraySearch *searchPtr;

    /*
     * Parse the id.
     */

    if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
	return NULL;
    }

    /*
     * Cast is safe, since always came from an int in the first place.
     */

    id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
	       ((char*)NULL));
    string = TclGetString(handleObj);
    offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
	      ((char*)NULL));

    /*
     * This test cannot be placed inside the Tcl_Obj machinery, since
     * it is dependent on the variable context.
     */

    if (strcmp(string+offset, varName) != 0) {
	Tcl_AppendResult(interp, "search identifier \"", string,
		"\" isn't for variable \"", varName, "\"", (char *) NULL);
	return NULL;
    }

    /*
     * Search through the list of active searches on the interpreter
     * to see if the desired one exists.
     *
     * Note that we cannot store the searchPtr directly in the Tcl_Obj
     * as that would run into trouble when DeleteSearches() was called
     * so we must scan this list every time.
     */

    for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
	 searchPtr = searchPtr->nextPtr) {
	if (searchPtr->id == id) {
	    return searchPtr;
	}
    }
    Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
	    (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteSearches --
 *
 *	This procedure is called to free up all of the searches
 *	associated with an array variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is released to the storage allocator.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteSearches(arrayVarPtr)
    register Var *arrayVarPtr;		/* Variable whose searches are
					 * to be deleted. */
{
    ArraySearch *searchPtr;

    while (arrayVarPtr->searchPtr != NULL) {
	searchPtr = arrayVarPtr->searchPtr;
	arrayVarPtr->searchPtr = searchPtr->nextPtr;
	ckfree((char *) searchPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclDeleteVars --
 *
 *	This procedure is called to recycle all the storage space
 *	associated with a table of variables. For this procedure
 *	to work correctly, it must not be possible for any of the
 *	variables in the table to be accessed from Tcl commands
 *	(e.g. from trace procedures).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Variables are deleted and trace procedures are invoked, if
 *	any are declared.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteVars(iPtr, tablePtr)
    Interp *iPtr;		/* Interpreter to which variables belong. */







>



>



>

|


|
>

|
|

>







|
|

|
|
|



|














|
|












|
|















|
|
|
<
|





|
|







4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258

4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
    register size_t offset;
    int id;
    ArraySearch *searchPtr;

    /*
     * Parse the id.
     */

    if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
	return NULL;
    }

    /*
     * Cast is safe, since always came from an int in the first place.
     */

    id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
	    ((char*)NULL));
    string = TclGetString(handleObj);
    offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
	    ((char*)NULL));

    /*
     * This test cannot be placed inside the Tcl_Obj machinery, since it is
     * dependent on the variable context.
     */

    if (strcmp(string+offset, varName) != 0) {
	Tcl_AppendResult(interp, "search identifier \"", string,
		"\" isn't for variable \"", varName, "\"", (char *) NULL);
	return NULL;
    }

    /*
     * Search through the list of active searches on the interpreter to see if
     * the desired one exists.
     *
     * Note that we cannot store the searchPtr directly in the Tcl_Obj as that
     * would run into trouble when DeleteSearches() was called so we must scan
     * this list every time.
     */

    for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
	    searchPtr = searchPtr->nextPtr) {
	if (searchPtr->id == id) {
	    return searchPtr;
	}
    }
    Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
	    (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteSearches --
 *
 *	This procedure is called to free up all of the searches associated
 *	with an array variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is released to the storage allocator.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteSearches(arrayVarPtr)
    register Var *arrayVarPtr;	/* Variable whose searches are to be
				 * deleted. */
{
    ArraySearch *searchPtr;

    while (arrayVarPtr->searchPtr != NULL) {
	searchPtr = arrayVarPtr->searchPtr;
	arrayVarPtr->searchPtr = searchPtr->nextPtr;
	ckfree((char *) searchPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclDeleteVars --
 *
 *	This procedure is called to recycle all the storage space associated
 *	with a table of variables. For this procedure to work correctly, it
 *	must not be possible for any of the variables in the table to be

 *	accessed from Tcl commands (e.g. from trace procedures).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Variables are deleted and trace procedures are invoked, if any are
 *	declared.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteVars(iPtr, tablePtr)
    Interp *iPtr;		/* Interpreter to which variables belong. */
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
	flags |= TCL_NAMESPACE_ONLY;
    }
    if (Tcl_InterpDeleted(interp)) {
	flags |= TCL_INTERP_DESTROYED;
    }

    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);  hPtr != NULL;
	 hPtr = Tcl_NextHashEntry(&search)) {
	varPtr = (Var *) Tcl_GetHashValue(hPtr);

	/*
	 * For global/upvar variables referenced in procedures, decrement
	 * the reference count on the variable referred to, and free
	 * the referenced variable if it's no longer needed. Don't delete
	 * the hash entry for the other variable if it's in the same table
	 * as us: this will happen automatically later on.
	 */

	if (TclIsVarLink(varPtr)) {
	    linkPtr = varPtr->value.linkPtr;
	    linkPtr->refCount--;
	    if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
		    && (linkPtr->tracePtr == NULL)
		    && (linkPtr->flags & VAR_IN_HASHTABLE)) {
		if (linkPtr->hPtr == NULL) {
		    ckfree((char *) linkPtr);
		} else if (linkPtr->hPtr->tablePtr != tablePtr) {
		    Tcl_DeleteHashEntry(linkPtr->hPtr);
		    ckfree((char *) linkPtr);
		}
	    }
	}

	/*
	 * Invoke traces on the variable that is being deleted, then
	 * free up the variable's space (no need to free the hash
	 * entry here, unless we're dealing with a global variable:
	 * the hash entries will be deleted automatically when the
	 * whole table is deleted). Note that we give TclCallVarTraces
	 * the variable's fully-qualified name so that any called
	 * trace procedures can refer to these variables being
	 * deleted.
	 */

	if (varPtr->tracePtr != NULL) {
	    objPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(objPtr); /* until done with traces */
	    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
	    TclCallVarTraces(iPtr, (Var *) NULL, varPtr, TclGetString(objPtr),
		    NULL, flags, /* leaveErrMsg */ 0);
	    Tcl_DecrRefCount(objPtr); /* free no longer needed obj */

	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	    
	if (TclIsVarArray(varPtr)) {
	    DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
	            flags);
	    varPtr->value.tablePtr = NULL;
	}
	if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
	    objPtr = varPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    varPtr->value.objPtr = NULL;
	}
	varPtr->hPtr = NULL;
	varPtr->tracePtr = NULL;
	TclSetVarUndefined(varPtr);
	TclSetVarScalar(varPtr);

	/*
	 * If the variable was a namespace variable, decrement its 
	 * reference count. We are in the process of destroying its
	 * namespace so that namespace will no longer "refer" to the
	 * variable.
	 */

	if (TclIsVarNamespaceVar(varPtr)) {
	    TclClearVarNamespaceVar(varPtr);
	    varPtr->refCount--;
	}








|



|
|
|
|
|


















|
|
|
<
|
|
|




|
|



|







|





|

|
<













|
|
|
<







4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331

4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360

4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376

4377
4378
4379
4380
4381
4382
4383
	flags |= TCL_NAMESPACE_ONLY;
    }
    if (Tcl_InterpDeleted(interp)) {
	flags |= TCL_INTERP_DESTROYED;
    }

    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);  hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&search)) {
	varPtr = (Var *) Tcl_GetHashValue(hPtr);

	/*
	 * For global/upvar variables referenced in procedures, decrement the
	 * reference count on the variable referred to, and free the
	 * referenced variable if it's no longer needed. Don't delete the hash
	 * entry for the other variable if it's in the same table as us: this
	 * will happen automatically later on.
	 */

	if (TclIsVarLink(varPtr)) {
	    linkPtr = varPtr->value.linkPtr;
	    linkPtr->refCount--;
	    if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
		    && (linkPtr->tracePtr == NULL)
		    && (linkPtr->flags & VAR_IN_HASHTABLE)) {
		if (linkPtr->hPtr == NULL) {
		    ckfree((char *) linkPtr);
		} else if (linkPtr->hPtr->tablePtr != tablePtr) {
		    Tcl_DeleteHashEntry(linkPtr->hPtr);
		    ckfree((char *) linkPtr);
		}
	    }
	}

	/*
	 * Invoke traces on the variable that is being deleted, then free up
	 * the variable's space (no need to free the hash entry here, unless
	 * we're dealing with a global variable: the hash entries will be

	 * deleted automatically when the whole table is deleted). Note that
	 * we give TclCallVarTraces the variable's fully-qualified name so
	 * that any called trace procedures can refer to these variables being
	 * deleted.
	 */

	if (varPtr->tracePtr != NULL) {
	    TclNewObj(objPtr);
	    Tcl_IncrRefCount(objPtr);	/* until done with traces */
	    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
	    TclCallVarTraces(iPtr, (Var *) NULL, varPtr, TclGetString(objPtr),
		    NULL, flags, /* leaveErrMsg */ 0);
	    TclDecrRefCount(objPtr);	/* free no longer needed obj */

	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		    activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}

	if (TclIsVarArray(varPtr)) {
	    DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags);

	    varPtr->value.tablePtr = NULL;
	}
	if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
	    objPtr = varPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    varPtr->value.objPtr = NULL;
	}
	varPtr->hPtr = NULL;
	varPtr->tracePtr = NULL;
	TclSetVarUndefined(varPtr);
	TclSetVarScalar(varPtr);

	/*
	 * If the variable was a namespace variable, decrement its reference
	 * count. We are in the process of destroying its namespace so that
	 * namespace will no longer "refer" to the variable.

	 */

	if (TclIsVarNamespaceVar(varPtr)) {
	    TclClearVarNamespaceVar(varPtr);
	    varPtr->refCount--;
	}

4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
}

/*
 *----------------------------------------------------------------------
 *
 * TclDeleteCompiledLocalVars --
 *
 *	This procedure is called to recycle storage space associated with
 *	the compiler-allocated array of local variables in a procedure call
 *	frame. This procedure resembles TclDeleteVars above except that each
 *	variable is stored in a call frame and not a hash table. For this
 *	procedure to work correctly, it must not be possible for any of the
 *	variable in the table to be accessed from Tcl commands (e.g. from
 *	trace procedures).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Variables are deleted and trace procedures are invoked, if
 *	any are declared.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteCompiledLocalVars(iPtr, framePtr)
    Interp *iPtr;		/* Interpreter to which variables belong. */
    CallFrame *framePtr;	/* Procedure call frame containing
				 * compiler-assigned local variables to
				 * delete. */
{
    register Var *varPtr;
    int flags;			/* Flags passed to trace procedures. */
    Var *linkPtr;
    ActiveVarTrace *activePtr;
    int numLocals, i;

    flags = TCL_TRACE_UNSETS;
    numLocals = framePtr->numCompiledLocals;
    varPtr = framePtr->compiledLocals;
    for (i = 0;  i < numLocals;  i++) {
	/*
	 * For global/upvar variables referenced in procedures, decrement
	 * the reference count on the variable referred to, and free
	 * the referenced variable if it's no longer needed. Don't delete
	 * the hash entry for the other variable if it's in the same table
	 * as us: this will happen automatically later on.
	 */

	if (TclIsVarLink(varPtr)) {
	    linkPtr = varPtr->value.linkPtr;
	    linkPtr->refCount--;
	    if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
		    && (linkPtr->tracePtr == NULL)







|
|
|
|
|
|
<





|
|







|
|
<












|
|
|
|
|







4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407

4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423

4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
}

/*
 *----------------------------------------------------------------------
 *
 * TclDeleteCompiledLocalVars --
 *
 *	This procedure is called to recycle storage space associated with the
 *	compiler-allocated array of local variables in a procedure call frame.
 *	This procedure resembles TclDeleteVars above except that each variable
 *	is stored in a call frame and not a hash table. For this procedure to
 *	work correctly, it must not be possible for any of the variable in the
 *	table to be accessed from Tcl commands (e.g. from trace procedures).

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Variables are deleted and trace procedures are invoked, if any are
 *	declared.
 *
 *----------------------------------------------------------------------
 */

void
TclDeleteCompiledLocalVars(iPtr, framePtr)
    Interp *iPtr;		/* Interpreter to which variables belong. */
    CallFrame *framePtr;	/* Procedure call frame containing compiler-
				 * assigned local variables to delete. */

{
    register Var *varPtr;
    int flags;			/* Flags passed to trace procedures. */
    Var *linkPtr;
    ActiveVarTrace *activePtr;
    int numLocals, i;

    flags = TCL_TRACE_UNSETS;
    numLocals = framePtr->numCompiledLocals;
    varPtr = framePtr->compiledLocals;
    for (i = 0;  i < numLocals;  i++) {
	/*
	 * For global/upvar variables referenced in procedures, decrement the
	 * reference count on the variable referred to, and free the
	 * referenced variable if it's no longer needed. Don't delete the hash
	 * entry for the other variable if it's in the same table as us: this
	 * will happen automatically later on.
	 */

	if (TclIsVarLink(varPtr)) {
	    linkPtr = varPtr->value.linkPtr;
	    linkPtr->refCount--;
	    if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
		    && (linkPtr->tracePtr == NULL)
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425

4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
		    flags, /* leaveErrMsg */ 0);
	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}

        /*
	 * Now if the variable is an array, delete its element hash table.
	 * Otherwise, if it's a scalar variable, decrement the ref count
	 * of its value.
	 */
	    
	if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) {
	    DeleteArray(iPtr, varPtr->name, varPtr, flags);
	}
	if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
	    TclDecrRefCount(varPtr->value.objPtr);
	    varPtr->value.objPtr = NULL;
	}
	varPtr->hPtr = NULL;
	varPtr->tracePtr = NULL;
	TclSetVarUndefined(varPtr);
	TclSetVarScalar(varPtr);
	varPtr++;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteArray --
 *
 *	This procedure is called to free up everything in an array
 *	variable.  It's the caller's responsibility to make sure
 *	that the array is no longer accessible before this procedure
 *	is called.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	All storage associated with varPtr's array elements is deleted
 *	(including the array's hash table). Deletion trace procedures for
 *	array elements are invoked, then deleted. Any pending traces for
 *	array elements are also deleted.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteArray(iPtr, arrayName, varPtr, flags)
    Interp *iPtr;			/* Interpreter containing array. */
    CONST char *arrayName;	        /* Name of array (used for trace
					 * callbacks). */
    Var *varPtr;			/* Pointer to variable structure. */
    int flags;				/* Flags to pass to TclCallVarTraces:
					 * TCL_TRACE_UNSETS and sometimes
					 * TCL_INTERP_DESTROYED,
					 * TCL_NAMESPACE_ONLY, or
					 * TCL_GLOBAL_ONLY. */
{
    Tcl_HashSearch search;
    register Tcl_HashEntry *hPtr;
    register Var *elPtr;
    ActiveVarTrace *activePtr;
    Tcl_Obj *objPtr;

    DeleteSearches(varPtr);
    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
	 hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
	elPtr = (Var *) Tcl_GetHashValue(hPtr);
	if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
	    objPtr = elPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    elPtr->value.objPtr = NULL;
	}
	elPtr->hPtr = NULL;
	if (elPtr->tracePtr != NULL) {
	    elPtr->flags &= ~VAR_TRACE_ACTIVE;
	    TclCallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
		    Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
		    /* leaveErrMsg */ 0);
	    while (elPtr->tracePtr != NULL) {
		VarTrace *tracePtr = elPtr->tracePtr;

		elPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == elPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	TclSetVarUndefined(elPtr);
	TclSetVarScalar(elPtr);

	/*
	 * Even though array elements are not supposed to be namespace
	 * variables, some combinations of [upvar] and [variable] may
	 * create such beasts - see [Bug 604239]. This is necessary to
	 * avoid leaking the corresponding Var struct, and is otherwise
	 * harmless. 
	 */

	if (TclIsVarNamespaceVar(elPtr)) {
	    TclClearVarNamespaceVar(elPtr);
	    elPtr->refCount--;
	}
	if (elPtr->refCount == 0) {
	    ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
	}
    }
    Tcl_DeleteHashTable(varPtr->value.tablePtr);
    ckfree((char *) varPtr->value.tablePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupVar --
 *
 *	This procedure is called when it looks like it may be OK to free up
 *	a variable's storage. If the variable is in a hashtable, its Var
 *	structure and hash table entry will be freed along with those of its
 *	containing array, if any. This procedure is called, for example,
 *	when a trace on a variable deletes a variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the variable (or its containing array) really is dead and in a
 *	hashtable, then its Var structure, and possibly its hash table
 *	entry, is freed up.
 *
 *----------------------------------------------------------------------
 */

void
TclCleanupVar(varPtr, arrayPtr)
    Var *varPtr;		/* Pointer to variable that may be a
				 * candidate for being expunged. */
    Var *arrayPtr;		/* Array that contains the variable, or
				 * NULL if this variable isn't an array
				 * element. */
{
    if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)
	    && (varPtr->tracePtr == NULL)
	    && (varPtr->flags & VAR_IN_HASHTABLE)) {
	if (varPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(varPtr->hPtr);
	}
	ckfree((char *) varPtr);
    }
    if (arrayPtr != NULL) {
	if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0)
		&& (arrayPtr->tracePtr == NULL)
	        && (arrayPtr->flags & VAR_IN_HASHTABLE)) {
	    if (arrayPtr->hPtr != NULL) {
		Tcl_DeleteHashEntry(arrayPtr->hPtr);
	    }
	    ckfree((char *) arrayPtr);
	}
    }
}
/*
 *----------------------------------------------------------------------
 *
 * TclVarErrMsg --
 *
 *      Generate a reasonable error message describing why a variable
 *      operation failed.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The interp's result is set to hold a message identifying the
 *      variable given by part1 and part2 and describing why the
 *      variable operation failed.
 *
 *----------------------------------------------------------------------
 */

void
TclVarErrMsg(interp, part1, part2, operation, reason)
    Tcl_Interp *interp;         /* Interpreter in which to record message. */
    CONST char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    CONST char *operation;      /* String describing operation that failed,
                                 * e.g. "read", "set", or "unset". */
    CONST char *reason;         /* String describing why operation failed. */
{
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
	    (char *) NULL);
    if (part2 != NULL) {
        Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
    }
    Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Internal functions for variable name object types --
 *
 *----------------------------------------------------------------------
 */

/*
 * Panic functions that should never be called in normal
 * operation.
 */

static void
PanicOnUpdateVarName(objPtr)
    Tcl_Obj *objPtr;
{
    Tcl_Panic("ERROR: updateStringProc of type %s should not be called.",
	    objPtr->typePtr->name);
}

static int
PanicOnSetVarName(interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
{
    Tcl_Panic("ERROR: setFromAnyProc of type %s should not be called.",
	    objPtr->typePtr->name);
    return TCL_ERROR;
}

/* 
 * localVarName -
 *
 * INTERNALREP DEFINITION:
 *   longValue = index into locals table
 */

static void
DupLocalVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    dupPtr->internalRep.longValue = srcPtr->internalRep.longValue;
    dupPtr->typePtr = &tclLocalVarNameType;
}

#if ENABLE_NS_VARNAME_CACHING
/* 
 * nsVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1: pointer to the namespace containing the 
 *                     reference.
 *   twoPtrValue.ptr2: pointer to the corresponding Var 
 */

static void 
FreeNsVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;
    
    varPtr->refCount--;
    if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) {
	TclCleanupVar(varPtr, NULL);
    }
}

static void







|






|

|
|

|




















|
|
|
<







|
|






|
|
|
|
|
|
|
<
|









|














>

|


|










|
|
|
<



















|
|

|
|






|
|






|
|
|
|
<












|












|
|


|


|
|
|






|


|
|
|





|













|
<




















|












|



|



|
<
|


|




|







4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507

4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529

4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573

4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615

4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682

4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724

4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
		    flags, /* leaveErrMsg */ 0);
	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		    activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}

	/*
	 * Now if the variable is an array, delete its element hash table.
	 * Otherwise, if it's a scalar variable, decrement the ref count of
	 * its value.
	 */

	if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) {
	    DeleteArray(iPtr, varPtr->name, varPtr, flags);
	}
	if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
	    TclDecrRefCount(varPtr->value.objPtr);
	    varPtr->value.objPtr = NULL;
	}
	varPtr->hPtr = NULL;
	varPtr->tracePtr = NULL;
	TclSetVarUndefined(varPtr);
	TclSetVarScalar(varPtr);
	varPtr++;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteArray --
 *
 *	This procedure is called to free up everything in an array variable.
 *	It's the caller's responsibility to make sure that the array is no
 *	longer accessible before this procedure is called.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	All storage associated with varPtr's array elements is deleted
 *	(including the array's hash table). Deletion trace procedures for
 *	array elements are invoked, then deleted. Any pending traces for array
 *	elements are also deleted.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteArray(iPtr, arrayName, varPtr, flags)
    Interp *iPtr;		/* Interpreter containing array. */
    CONST char *arrayName;	/* Name of array (used for trace
				 * callbacks). */
    Var *varPtr;		/* Pointer to variable structure. */
    int flags;			/* Flags to pass to TclCallVarTraces:
				 * TCL_TRACE_UNSETS and sometimes
				 * TCL_INTERP_DESTROYED, TCL_NAMESPACE_ONLY,

				 * or TCL_GLOBAL_ONLY. */
{
    Tcl_HashSearch search;
    register Tcl_HashEntry *hPtr;
    register Var *elPtr;
    ActiveVarTrace *activePtr;
    Tcl_Obj *objPtr;

    DeleteSearches(varPtr);
    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	elPtr = (Var *) Tcl_GetHashValue(hPtr);
	if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
	    objPtr = elPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    elPtr->value.objPtr = NULL;
	}
	elPtr->hPtr = NULL;
	if (elPtr->tracePtr != NULL) {
	    elPtr->flags &= ~VAR_TRACE_ACTIVE;
	    TclCallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
		    Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
		    /* leaveErrMsg */ 0);
	    while (elPtr->tracePtr != NULL) {
		VarTrace *tracePtr = elPtr->tracePtr;

		elPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		    activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == elPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	TclSetVarUndefined(elPtr);
	TclSetVarScalar(elPtr);

	/*
	 * Even though array elements are not supposed to be namespace
	 * variables, some combinations of [upvar] and [variable] may create
	 * such beasts - see [Bug 604239]. This is necessary to avoid leaking
	 * the corresponding Var struct, and is otherwise harmless.

	 */

	if (TclIsVarNamespaceVar(elPtr)) {
	    TclClearVarNamespaceVar(elPtr);
	    elPtr->refCount--;
	}
	if (elPtr->refCount == 0) {
	    ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
	}
    }
    Tcl_DeleteHashTable(varPtr->value.tablePtr);
    ckfree((char *) varPtr->value.tablePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupVar --
 *
 *	This procedure is called when it looks like it may be OK to free up a
 *	variable's storage. If the variable is in a hashtable, its Var
 *	structure and hash table entry will be freed along with those of its
 *	containing array, if any. This procedure is called, for example, when
 *	a trace on a variable deletes a variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the variable (or its containing array) really is dead and in a
 *	hashtable, then its Var structure, and possibly its hash table entry,
 *	is freed up.
 *
 *----------------------------------------------------------------------
 */

void
TclCleanupVar(varPtr, arrayPtr)
    Var *varPtr;		/* Pointer to variable that may be a candidate
				 * for being expunged. */
    Var *arrayPtr;		/* Array that contains the variable, or NULL
				 * if this variable isn't an array element. */

{
    if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)
	    && (varPtr->tracePtr == NULL)
	    && (varPtr->flags & VAR_IN_HASHTABLE)) {
	if (varPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(varPtr->hPtr);
	}
	ckfree((char *) varPtr);
    }
    if (arrayPtr != NULL) {
	if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0)
		&& (arrayPtr->tracePtr == NULL)
		&& (arrayPtr->flags & VAR_IN_HASHTABLE)) {
	    if (arrayPtr->hPtr != NULL) {
		Tcl_DeleteHashEntry(arrayPtr->hPtr);
	    }
	    ckfree((char *) arrayPtr);
	}
    }
}
/*
 *----------------------------------------------------------------------
 *
 * TclVarErrMsg --
 *
 *	Generate a reasonable error message describing why a variable
 *	operation failed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interp's result is set to hold a message identifying the variable
 *	given by part1 and part2 and describing why the variable operation
 *	failed.
 *
 *----------------------------------------------------------------------
 */

void
TclVarErrMsg(interp, part1, part2, operation, reason)
    Tcl_Interp *interp;		/* Interpreter in which to record message. */
    CONST char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    CONST char *operation;	/* String describing operation that failed,
				 * e.g. "read", "set", or "unset". */
    CONST char *reason;		/* String describing why operation failed. */
{
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
	    (char *) NULL);
    if (part2 != NULL) {
	Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
    }
    Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Internal functions for variable name object types --
 *
 *----------------------------------------------------------------------
 */

/*
 * Panic functions that should never be called in normal operation.

 */

static void
PanicOnUpdateVarName(objPtr)
    Tcl_Obj *objPtr;
{
    Tcl_Panic("ERROR: updateStringProc of type %s should not be called.",
	    objPtr->typePtr->name);
}

static int
PanicOnSetVarName(interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
{
    Tcl_Panic("ERROR: setFromAnyProc of type %s should not be called.",
	    objPtr->typePtr->name);
    return TCL_ERROR;
}

/*
 * localVarName -
 *
 * INTERNALREP DEFINITION:
 *   longValue = index into locals table
 */

static void
DupLocalVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    dupPtr->internalRep.longValue = srcPtr->internalRep.longValue;
    dupPtr->typePtr = &localVarNameType;
}

#if ENABLE_NS_VARNAME_CACHING
/*
 * nsVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1: pointer to the namespace containing the reference.

 *   twoPtrValue.ptr2: pointer to the corresponding Var
 */

static void
FreeNsVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;

    varPtr->refCount--;
    if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) {
	TclCleanupVar(varPtr, NULL);
    }
}

static void
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
    dupPtr->internalRep.twoPtrValue.ptr1 =  (VOID *) nsPtr;
    dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
    varPtr->refCount++;
    dupPtr->typePtr = &tclNsVarNameType;
}
#endif

/* 
 * parsedVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj
 *                      (NULL if scalar)
 *   twoPtrValue.ptr2 = pointer to the element name string
 *                      (owned by this Tcl_Obj), or NULL if 
 *                      it is a scalar variable
 */

static void 
FreeParsedVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_Obj *arrayPtr =
	    (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
    register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;
    
    if (arrayPtr != NULL) {
	TclDecrRefCount(arrayPtr);
	ckfree(elem);
    }
}

static void
DupParsedVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    register Tcl_Obj *arrayPtr =
	    (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1;
    register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
    char *elemCopy;
    unsigned int elemLen;

    if (arrayPtr != NULL) {
	Tcl_IncrRefCount(arrayPtr);
	elemLen = strlen(elem);







|



|
<
|
<
|


|



|
|

|











|
|







4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759

4760

4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
    dupPtr->internalRep.twoPtrValue.ptr1 =  (VOID *) nsPtr;
    dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
    varPtr->refCount++;
    dupPtr->typePtr = &tclNsVarNameType;
}
#endif

/*
 * parsedVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj (NULL if scalar)

 *   twoPtrValue.ptr2 = pointer to the element name string (owned by this

 *			Tcl_Obj), or NULL if it is a scalar variable
 */

static void
FreeParsedVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_Obj *arrayPtr = (Tcl_Obj *)
	    objPtr->internalRep.twoPtrValue.ptr1;
    register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;

    if (arrayPtr != NULL) {
	TclDecrRefCount(arrayPtr);
	ckfree(elem);
    }
}

static void
DupParsedVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    register Tcl_Obj *arrayPtr = (Tcl_Obj *)
	    srcPtr->internalRep.twoPtrValue.ptr1;
    register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
    char *elemCopy;
    unsigned int elemLen;

    if (arrayPtr != NULL) {
	Tcl_IncrRefCount(arrayPtr);
	elemLen = strlen(elem);
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692

4693
4694

4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710








    Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
    char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
    char *part1, *p;
    int len1, len2, totalLen;

    if (arrayPtr == NULL) {
	/*
	 * This is a parsed scalar name: what is it
	 * doing here?
	 */

	Tcl_Panic("ERROR: scalar parsedVarName without a string rep.\n");
    }

    part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
    len2 = strlen(part2);

    totalLen = len1 + len2 + 2;
    p = ckalloc((unsigned int) totalLen + 1);
    objPtr->bytes = p;
    objPtr->length = totalLen;

    memcpy(p, part1, (unsigned int) len1);
    p += len1;
    *p++ = '(';
    memcpy(p, part2, (unsigned int) len2);
    p += len2;
    *p++ = ')';
    *p   = '\0';
}















|
<

>


>
















>
>
>
>
>
>
>
>
4807
4808
4809
4810
4811
4812
4813
4814

4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
    Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
    char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
    char *part1, *p;
    int len1, len2, totalLen;

    if (arrayPtr == NULL) {
	/*
	 * This is a parsed scalar name: what is it doing here?

	 */

	Tcl_Panic("ERROR: scalar parsedVarName without a string rep.\n");
    }

    part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
    len2 = strlen(part2);

    totalLen = len1 + len2 + 2;
    p = ckalloc((unsigned int) totalLen + 1);
    objPtr->bytes = p;
    objPtr->length = totalLen;

    memcpy(p, part1, (unsigned int) len1);
    p += len1;
    *p++ = '(';
    memcpy(p, part2, (unsigned int) len2);
    p += len2;
    *p++ = ')';
    *p   = '\0';
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Added generic/tommath.h.

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#ifndef BN_H_
#define BN_H_

#ifdef TCL_TOMMATH
#include <tclTomMath.h>
#endif
#ifndef TOMMATH_STORAGE_CLASS
#define TOMMATH_STORAGE_CLASS extern
#endif

#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
#include <limits.h>

#include <tommath_class.h>

#ifndef MIN
   #define MIN(x,y) ((x)<(y)?(x):(y))
#endif

#ifndef MAX
   #define MAX(x,y) ((x)>(y)?(x):(y))
#endif

#ifdef __cplusplus
extern "C" {

/* C++ compilers don't like assigning void * to mp_digit * */
#define  OPT_CAST(x)  (x *)

#else

/* C on the other hand doesn't care */
#define  OPT_CAST(x)

#endif


/* detect 64-bit mode if possible */
#if defined(__x86_64__) 
   #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT))
      #define MP_64BIT
   #endif
#endif

/* some default configurations.
 *
 * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits
 * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits
 *
 * At the very least a mp_digit must be able to hold 7 bits
 * [any size beyond that is ok provided it doesn't overflow the data type]
 */
#ifdef MP_8BIT
#ifndef MP_DIGIT_DECLARED
   typedef unsigned char      mp_digit;
#define MP_DIGIT_DECLARED
#endif
   typedef unsigned short     mp_word;
#elif defined(MP_16BIT)
#ifndef MP_DIGIT_DECLARED
   typedef unsigned short     mp_digit;
#define MP_DIGIT_DECLARED
#endif
   typedef unsigned long      mp_word;
#elif defined(MP_64BIT)
   /* for GCC only on supported platforms */
#ifndef CRYPT
   typedef unsigned long long ulong64;
   typedef signed long long   long64;
#endif

#ifndef MP_DIGIT_DECLARED
   typedef unsigned long      mp_digit;
#define MP_DIGIT_DECLARED
#endif
   typedef unsigned long      mp_word __attribute__ ((mode(TI)));

   #define DIGIT_BIT          60
#else
   /* this is the default case, 28-bit digits */
   
   /* this is to make porting into LibTomCrypt easier :-) */
#ifndef CRYPT
   #if defined(_MSC_VER) || defined(__BORLANDC__) 
      typedef unsigned __int64   ulong64;
      typedef signed __int64     long64;
   #else
      typedef unsigned long long ulong64;
      typedef signed long long   long64;
   #endif
#endif

#ifndef MP_DIGIT_DECLARED
   typedef unsigned long      mp_digit;
#define MP_DIGIT_DECLARED
#endif
   typedef ulong64            mp_word;

#ifdef MP_31BIT   
   /* this is an extension that uses 31-bit digits */
   #define DIGIT_BIT          31
#else
   /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
   #define DIGIT_BIT          28
   #define MP_28BIT
#endif   
#endif

/* define heap macros */
#ifndef CRYPT
   /* default to libc stuff */
   #ifndef XMALLOC 
       #define XMALLOC  malloc
       #define XFREE    free
       #define XREALLOC realloc
       #define XCALLOC  calloc
   #else
      /* prototypes for our heap functions */
      extern void *XMALLOC(size_t n);
      extern void *XREALLOC(void *p, size_t n);
      extern void *XCALLOC(size_t n, size_t s);
      extern void XFREE(void *p);
   #endif
#endif


/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
#ifndef DIGIT_BIT
   #define DIGIT_BIT     ((int)((CHAR_BIT * sizeof(mp_digit) - 1)))  /* bits per digit */
#endif

#define MP_DIGIT_BIT     DIGIT_BIT
#define MP_MASK          ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
#define MP_DIGIT_MAX     MP_MASK

/* equalities */
#define MP_LT        -1   /* less than */
#define MP_EQ         0   /* equal to */
#define MP_GT         1   /* greater than */

#define MP_ZPOS       0   /* positive integer */
#define MP_NEG        1   /* negative */

#define MP_OKAY       0   /* ok result */
#define MP_MEM        -2  /* out of mem */
#define MP_VAL        -3  /* invalid input */
#define MP_RANGE      MP_VAL

#define MP_YES        1   /* yes response */
#define MP_NO         0   /* no response */

/* Primality generation flags */
#define LTM_PRIME_BBS      0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */
#define LTM_PRIME_2MSB_ON  0x0008 /* force 2nd MSB to 1 */

typedef int           mp_err;

/* you'll have to tune these... */
extern int KARATSUBA_MUL_CUTOFF,
           KARATSUBA_SQR_CUTOFF,
           TOOM_MUL_CUTOFF,
           TOOM_SQR_CUTOFF;

/* define this to use lower memory usage routines (exptmods mostly) */
/* #define MP_LOW_MEM */

/* default precision */
#ifndef MP_PREC
   #ifndef MP_LOW_MEM
      #define MP_PREC                 32     /* default digits of precision */
   #else
      #define MP_PREC                 8      /* default digits of precision */
   #endif   
#endif

/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY               (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1))

/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
typedef struct mp_int mp_int;
#endif
struct mp_int {
    int used, alloc, sign;
    mp_digit *dp;
};

/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);


#define USED(m)    ((m)->used)
#define DIGIT(m,k) ((m)->dp[(k)])
#define SIGN(m)    ((m)->sign)

/* error code to char* string */
TOMMATH_STORAGE_CLASS char *mp_error_to_string(int code);

/* ---> init and deinit bignum functions <--- */
/* init a bignum */
TOMMATH_STORAGE_CLASS int mp_init(mp_int *a);

/* free a bignum */
TOMMATH_STORAGE_CLASS void mp_clear(mp_int *a);

/* init a null terminated series of arguments */
TOMMATH_STORAGE_CLASS int mp_init_multi(mp_int *mp, ...);

/* clear a null terminated series of arguments */
TOMMATH_STORAGE_CLASS void mp_clear_multi(mp_int *mp, ...);

/* exchange two ints */
TOMMATH_STORAGE_CLASS void mp_exch(mp_int *a, mp_int *b);

/* shrink ram required for a bignum */
TOMMATH_STORAGE_CLASS int mp_shrink(mp_int *a);

/* grow an int to a given size */
TOMMATH_STORAGE_CLASS int mp_grow(mp_int *a, int size);

/* init to a given number of digits */
TOMMATH_STORAGE_CLASS int mp_init_size(mp_int *a, int size);

/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
#define mp_isodd(a)  (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)

/* set to zero */
TOMMATH_STORAGE_CLASS void mp_zero(mp_int *a);

/* set to a digit */
TOMMATH_STORAGE_CLASS void mp_set(mp_int *a, mp_digit b);

/* set a 32-bit const */
TOMMATH_STORAGE_CLASS int mp_set_int(mp_int *a, unsigned long b);

/* get a 32-bit value */
unsigned long mp_get_int(mp_int * a);

/* initialize and set a digit */
TOMMATH_STORAGE_CLASS int mp_init_set (mp_int * a, mp_digit b);

/* initialize and set 32-bit value */
TOMMATH_STORAGE_CLASS int mp_init_set_int (mp_int * a, unsigned long b);

/* copy, b = a */
TOMMATH_STORAGE_CLASS int mp_copy(mp_int *a, mp_int *b);

/* inits and copies, a = b */
TOMMATH_STORAGE_CLASS int mp_init_copy(mp_int *a, mp_int *b);

/* trim unused digits */
TOMMATH_STORAGE_CLASS void mp_clamp(mp_int *a);

/* ---> digit manipulation <--- */

/* right shift by "b" digits */
TOMMATH_STORAGE_CLASS void mp_rshd(mp_int *a, int b);

/* left shift by "b" digits */
TOMMATH_STORAGE_CLASS int mp_lshd(mp_int *a, int b);

/* c = a / 2**b */
TOMMATH_STORAGE_CLASS int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d);

/* b = a/2 */
TOMMATH_STORAGE_CLASS int mp_div_2(mp_int *a, mp_int *b);

/* c = a * 2**b */
TOMMATH_STORAGE_CLASS int mp_mul_2d(mp_int *a, int b, mp_int *c);

/* b = a*2 */
TOMMATH_STORAGE_CLASS int mp_mul_2(mp_int *a, mp_int *b);

/* c = a mod 2**d */
TOMMATH_STORAGE_CLASS int mp_mod_2d(mp_int *a, int b, mp_int *c);

/* computes a = 2**b */
TOMMATH_STORAGE_CLASS int mp_2expt(mp_int *a, int b);

/* Counts the number of lsbs which are zero before the first zero bit */
TOMMATH_STORAGE_CLASS int mp_cnt_lsb(mp_int *a);

/* I Love Earth! */

/* makes a pseudo-random int of a given size */
TOMMATH_STORAGE_CLASS int mp_rand(mp_int *a, int digits);

/* ---> binary operations <--- */
/* c = a XOR b  */
TOMMATH_STORAGE_CLASS int mp_xor(mp_int *a, mp_int *b, mp_int *c);

/* c = a OR b */
TOMMATH_STORAGE_CLASS int mp_or(mp_int *a, mp_int *b, mp_int *c);

/* c = a AND b */
TOMMATH_STORAGE_CLASS int mp_and(mp_int *a, mp_int *b, mp_int *c);

/* ---> Basic arithmetic <--- */

/* b = -a */
TOMMATH_STORAGE_CLASS int mp_neg(mp_int *a, mp_int *b);

/* b = |a| */
TOMMATH_STORAGE_CLASS int mp_abs(mp_int *a, mp_int *b);

/* compare a to b */
TOMMATH_STORAGE_CLASS int mp_cmp(mp_int *a, mp_int *b);

/* compare |a| to |b| */
TOMMATH_STORAGE_CLASS int mp_cmp_mag(mp_int *a, mp_int *b);

/* c = a + b */
TOMMATH_STORAGE_CLASS int mp_add(mp_int *a, mp_int *b, mp_int *c);

/* c = a - b */
TOMMATH_STORAGE_CLASS int mp_sub(mp_int *a, mp_int *b, mp_int *c);

/* c = a * b */
TOMMATH_STORAGE_CLASS int mp_mul(mp_int *a, mp_int *b, mp_int *c);

/* b = a*a  */
TOMMATH_STORAGE_CLASS int mp_sqr(mp_int *a, mp_int *b);

/* a/b => cb + d == a */
TOMMATH_STORAGE_CLASS int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* c = a mod b, 0 <= c < b  */
TOMMATH_STORAGE_CLASS int mp_mod(mp_int *a, mp_int *b, mp_int *c);

/* ---> single digit functions <--- */

/* compare against a single digit */
TOMMATH_STORAGE_CLASS int mp_cmp_d(mp_int *a, mp_digit b);

/* c = a + b */
TOMMATH_STORAGE_CLASS int mp_add_d(mp_int *a, mp_digit b, mp_int *c);

/* c = a - b */
TOMMATH_STORAGE_CLASS int mp_sub_d(mp_int *a, mp_digit b, mp_int *c);

/* c = a * b */
TOMMATH_STORAGE_CLASS int mp_mul_d(mp_int *a, mp_digit b, mp_int *c);

/* a/b => cb + d == a */
TOMMATH_STORAGE_CLASS int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d);

/* a/3 => 3c + d == a */
TOMMATH_STORAGE_CLASS int mp_div_3(mp_int *a, mp_int *c, mp_digit *d);

/* c = a**b */
TOMMATH_STORAGE_CLASS int mp_expt_d(mp_int *a, mp_digit b, mp_int *c);

/* c = a mod b, 0 <= c < b  */
TOMMATH_STORAGE_CLASS int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c);

/* ---> number theory <--- */

/* d = a + b (mod c) */
TOMMATH_STORAGE_CLASS int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* d = a - b (mod c) */
TOMMATH_STORAGE_CLASS int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* d = a * b (mod c) */
TOMMATH_STORAGE_CLASS int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* c = a * a (mod b) */
TOMMATH_STORAGE_CLASS int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c);

/* c = 1/a (mod b) */
TOMMATH_STORAGE_CLASS int mp_invmod(mp_int *a, mp_int *b, mp_int *c);

/* c = (a, b) */
TOMMATH_STORAGE_CLASS int mp_gcd(mp_int *a, mp_int *b, mp_int *c);

/* produces value such that U1*a + U2*b = U3 */
TOMMATH_STORAGE_CLASS int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3);

/* c = [a, b] or (a*b)/(a, b) */
TOMMATH_STORAGE_CLASS int mp_lcm(mp_int *a, mp_int *b, mp_int *c);

/* finds one of the b'th root of a, such that |c|**b <= |a|
 *
 * returns error if a < 0 and b is even
 */
TOMMATH_STORAGE_CLASS int mp_n_root(mp_int *a, mp_digit b, mp_int *c);

/* special sqrt algo */
TOMMATH_STORAGE_CLASS int mp_sqrt(mp_int *arg, mp_int *ret);

/* is number a square? */
TOMMATH_STORAGE_CLASS int mp_is_square(mp_int *arg, int *ret);

/* computes the jacobi c = (a | n) (or Legendre if b is prime)  */
TOMMATH_STORAGE_CLASS int mp_jacobi(mp_int *a, mp_int *n, int *c);

/* used to setup the Barrett reduction for a given modulus b */
TOMMATH_STORAGE_CLASS int mp_reduce_setup(mp_int *a, mp_int *b);

/* Barrett Reduction, computes a (mod b) with a precomputed value c
 *
 * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely
 * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code].
 */
TOMMATH_STORAGE_CLASS int mp_reduce(mp_int *a, mp_int *b, mp_int *c);

/* setups the montgomery reduction */
TOMMATH_STORAGE_CLASS int mp_montgomery_setup(mp_int *a, mp_digit *mp);

/* computes a = B**n mod b without division or multiplication useful for
 * normalizing numbers in a Montgomery system.
 */
TOMMATH_STORAGE_CLASS int mp_montgomery_calc_normalization(mp_int *a, mp_int *b);

/* computes x/R == x (mod N) via Montgomery Reduction */
TOMMATH_STORAGE_CLASS int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);

/* returns 1 if a is a valid DR modulus */
TOMMATH_STORAGE_CLASS int mp_dr_is_modulus(mp_int *a);

/* sets the value of "d" required for mp_dr_reduce */
TOMMATH_STORAGE_CLASS void mp_dr_setup(mp_int *a, mp_digit *d);

/* reduces a modulo b using the Diminished Radix method */
TOMMATH_STORAGE_CLASS int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp);

/* returns true if a can be reduced with mp_reduce_2k */
TOMMATH_STORAGE_CLASS int mp_reduce_is_2k(mp_int *a);

/* determines k value for 2k reduction */
TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup(mp_int *a, mp_digit *d);

/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
TOMMATH_STORAGE_CLASS int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d);

/* returns true if a can be reduced with mp_reduce_2k_l */
TOMMATH_STORAGE_CLASS int mp_reduce_is_2k_l(mp_int *a);

/* determines k value for 2k reduction */
TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup_l(mp_int *a, mp_int *d);

/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
TOMMATH_STORAGE_CLASS int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d);

/* d = a**b (mod c) */
TOMMATH_STORAGE_CLASS int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* ---> Primes <--- */

/* number of primes */
#ifdef MP_8BIT
   #define PRIME_SIZE      31
#else
   #define PRIME_SIZE      256
#endif

/* table of first PRIME_SIZE primes */
extern const mp_digit ltm_prime_tab[];

/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
TOMMATH_STORAGE_CLASS int mp_prime_is_divisible(mp_int *a, int *result);

/* performs one Fermat test of "a" using base "b".
 * Sets result to 0 if composite or 1 if probable prime
 */
TOMMATH_STORAGE_CLASS int mp_prime_fermat(mp_int *a, mp_int *b, int *result);

/* performs one Miller-Rabin test of "a" using base "b".
 * Sets result to 0 if composite or 1 if probable prime
 */
TOMMATH_STORAGE_CLASS int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result);

/* This gives [for a given bit size] the number of trials required
 * such that Miller-Rabin gives a prob of failure lower than 2^-96 
 */
TOMMATH_STORAGE_CLASS int mp_prime_rabin_miller_trials(int size);

/* performs t rounds of Miller-Rabin on "a" using the first
 * t prime bases.  Also performs an initial sieve of trial
 * division.  Determines if "a" is prime with probability
 * of error no more than (1/4)**t.
 *
 * Sets result to 1 if probably prime, 0 otherwise
 */
TOMMATH_STORAGE_CLASS int mp_prime_is_prime(mp_int *a, int t, int *result);

/* finds the next prime after the number "a" using "t" trials
 * of Miller-Rabin.
 *
 * bbs_style = 1 means the prime must be congruent to 3 mod 4
 */
TOMMATH_STORAGE_CLASS int mp_prime_next_prime(mp_int *a, int t, int bbs_style);

/* makes a truly random prime of a given size (bytes),
 * call with bbs = 1 if you want it to be congruent to 3 mod 4 
 *
 * You have to supply a callback which fills in a buffer with random bytes.  "dat" is a parameter you can
 * have passed to the callback (e.g. a state or something).  This function doesn't use "dat" itself
 * so it can be NULL
 *
 * The prime generated will be larger than 2^(8*size).
 */
#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat)

/* makes a truly random prime of a given size (bits),
 *
 * Flags are as follows:
 * 
 *   LTM_PRIME_BBS      - make prime congruent to 3 mod 4
 *   LTM_PRIME_SAFE     - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS)
 *   LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero
 *   LTM_PRIME_2MSB_ON  - make the 2nd highest bit one
 *
 * You have to supply a callback which fills in a buffer with random bytes.  "dat" is a parameter you can
 * have passed to the callback (e.g. a state or something).  This function doesn't use "dat" itself
 * so it can be NULL
 *
 */
TOMMATH_STORAGE_CLASS int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat);

/* ---> radix conversion <--- */
TOMMATH_STORAGE_CLASS int mp_count_bits(mp_int *a);

TOMMATH_STORAGE_CLASS int mp_unsigned_bin_size(mp_int *a);
TOMMATH_STORAGE_CLASS int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c);
TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin(mp_int *a, unsigned char *b);
TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen);

TOMMATH_STORAGE_CLASS int mp_signed_bin_size(mp_int *a);
TOMMATH_STORAGE_CLASS int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c);
TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b);
TOMMATH_STORAGE_CLASS int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen);

TOMMATH_STORAGE_CLASS int mp_read_radix(mp_int *a, const char *str, int radix);
TOMMATH_STORAGE_CLASS int mp_toradix(mp_int *a, char *str, int radix);
TOMMATH_STORAGE_CLASS int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen);
TOMMATH_STORAGE_CLASS int mp_radix_size(mp_int *a, int radix, int *size);

TOMMATH_STORAGE_CLASS int mp_fread(mp_int *a, int radix, FILE *stream);
TOMMATH_STORAGE_CLASS int mp_fwrite(mp_int *a, int radix, FILE *stream);

#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len))
#define mp_raw_size(mp)           mp_signed_bin_size(mp)
#define mp_toraw(mp, str)         mp_to_signed_bin((mp), (str))
#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len))
#define mp_mag_size(mp)           mp_unsigned_bin_size(mp)
#define mp_tomag(mp, str)         mp_to_unsigned_bin((mp), (str))

#define mp_tobinary(M, S)  mp_toradix((M), (S), 2)
#define mp_tooctal(M, S)   mp_toradix((M), (S), 8)
#define mp_todecimal(M, S) mp_toradix((M), (S), 10)
#define mp_tohex(M, S)     mp_toradix((M), (S), 16)

/* lowlevel functions, do not call! */
TOMMATH_STORAGE_CLASS int s_mp_add(mp_int *a, mp_int *b, mp_int *c);
TOMMATH_STORAGE_CLASS int s_mp_sub(mp_int *a, mp_int *b, mp_int *c);
#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
TOMMATH_STORAGE_CLASS int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
TOMMATH_STORAGE_CLASS int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
TOMMATH_STORAGE_CLASS int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
TOMMATH_STORAGE_CLASS int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
TOMMATH_STORAGE_CLASS int fast_s_mp_sqr(mp_int *a, mp_int *b);
TOMMATH_STORAGE_CLASS int s_mp_sqr(mp_int *a, mp_int *b);
TOMMATH_STORAGE_CLASS int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c);
TOMMATH_STORAGE_CLASS int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c);
TOMMATH_STORAGE_CLASS int mp_karatsuba_sqr(mp_int *a, mp_int *b);
TOMMATH_STORAGE_CLASS int mp_toom_sqr(mp_int *a, mp_int *b);
TOMMATH_STORAGE_CLASS int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c);
TOMMATH_STORAGE_CLASS int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c);
TOMMATH_STORAGE_CLASS int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);
TOMMATH_STORAGE_CLASS int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode);
TOMMATH_STORAGE_CLASS int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode);
TOMMATH_STORAGE_CLASS void bn_reverse(unsigned char *s, int len);

extern const char *mp_s_rmap;

#ifdef __cplusplus
   }
#endif

#endif


/* $Source: /root/tcl/repos-to-convert/tcl/generic/tommath.h,v $ */
/* $Revision: 1.1.2.4 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Changes to library/auto.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

33
34

35



36
37
38
39
40
41
42
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.21 2004/12/01 22:14:20 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

# auto_reset --
#
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments: 
# None.

proc auto_reset {} {
    variable ::tcl::auto_oldpath
    global auto_execs auto_index 
    foreach p [info procs] {
	if {[info exists auto_index($p)]} {
	    rename $p {}
	}
    }

    catch {unset auto_execs}
    catch {unset auto_index}

    catch {unset auto_oldpath}



}

# tcl_findLibrary --
#
#	This is a utility for extensions that searches for a library directory
#	using a canonical searching algorithm. A side effect is to source
#	the initialization script and set a global library variable.





|












|
<





|
|
|
|
|


>
|
|
>
|
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.21.2.3 2005/08/02 18:16:14 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

# auto_reset --
#
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any commands that are listed in the auto-load index.

#
# Arguments: 
# None.

proc auto_reset {} {
    if {[array exists ::auto_index]} {
	foreach cmdName [array names ::auto_index] {
	    set fqcn [namespace which $cmdName]
	    if {$fqcn eq ""} {continue}
	    rename $fqcn {}
	}
    }
    unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
    if {[catch {llength $::auto_path}]} {
	set ::auto_path [list [info library]]
    } else {
	if {[info library] ni $::auto_path} {
	    lappend ::auto_path [info library]
	}
    }
}

# tcl_findLibrary --
#
#	This is a utility for extensions that searches for a library directory
#	using a canonical searching algorithm. A side effect is to source
#	the initialization script and set a global library variable.
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
    global env

    set dirs {}
    set errors {}

    # The C application may have hardwired a path, which we honor

    set variableSet [info exists the_library]
    if {$variableSet && $the_library ne ""} {
	lappend dirs $the_library
    } else {

	# Do the canonical search

	# 1. From an environment variable, if it exists.
	#    Placing this first gives the end-user ultimate control







|
<







58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
    global env

    set dirs {}
    set errors {}

    # The C application may have hardwired a path, which we honor

    if {[info exists the_library] && $the_library ne ""} {

	lappend dirs $the_library
    } else {

	# Do the canonical search

	# 1. From an environment variable, if it exists.
	#    Placing this first gives the end-user ultimate control
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
                return
            } else {
                append errors "$file: $msg\n"
		append errors [dict get $opts -errorinfo]\n
            }
        }
    }
    if {!$variableSet} {
	unset the_library
    }
    set msg "Can't find a usable $initScript in the following directories: \n"
    append msg "    $dirs\n\n"
    append msg "$errors\n\n"
    append msg "This probably means that $basename wasn't installed properly.\n"
    error $msg
}








<
|
<







152
153
154
155
156
157
158

159

160
161
162
163
164
165
166
                return
            } else {
                append errors "$file: $msg\n"
		append errors [dict get $opts -errorinfo]\n
            }
        }
    }

    unset -nocomplain the_library

    set msg "Can't find a usable $initScript in the following directories: \n"
    append msg "    $dirs\n\n"
    append msg "$errors\n\n"
    append msg "This probably means that $basename wasn't installed properly.\n"
    error $msg
}

207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }

    auto_mkindex_parser::init
    foreach file [glob {expand}$args] {
        if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
            append index $msg
        } else {
            cd $oldDir
	    return -options $opts $msg
        }
    }







|







208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }

    auto_mkindex_parser::init
    foreach file [glob -- {expand}$args] {
        if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
            append index $msg
        } else {
            cd $oldDir
	    return -options $opts $msg
        }
    }
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
    append index "# more commands.  Typically each line is a command that\n"
    append index "# sets an element in the auto_index array, where the\n"
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }
    foreach file [glob {expand}$args] {
	set f ""
	set error [catch {
	    set f [open $file]
	    while {[gets $f line] >= 0} {
		if {[regexp {^proc[ 	]+([^ 	]*)} $line match procName]} {
		    set procName [lindex [auto_qualify $procName "::"] 0]
		    append index "set [list auto_index($procName)]"







|







241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
    append index "# more commands.  Typically each line is a command that\n"
    append index "# sets an element in the auto_index array, where the\n"
    append index "# element name is the name of a command and the value is\n"
    append index "# a script that loads the command.\n\n"
    if {[llength $args] == 0} {
	set args *.tcl
    }
    foreach file [glob -- {expand}$args] {
	set f ""
	set error [catch {
	    set f [open $file]
	    while {[gets $f line] >= 0} {
		if {[regexp {^proc[ 	]+([^ 	]*)} $line match procName]} {
		    set procName [lindex [auto_qualify $procName "::"] 0]
		    append index "set [list auto_index($procName)]"
285
286
287
288
289
290
291
292



293
294
295
296
297
298
299

namespace eval auto_mkindex_parser {
    variable parser ""          ;# parser used to build index
    variable index ""           ;# maintains index as it is built
    variable scriptFile ""      ;# name of file being processed
    variable contextStack ""    ;# stack of namespace scopes
    variable imports ""         ;# keeps track of all imported cmds
    variable initCommands ""    ;# list of commands that create aliases




    proc init {} {
	variable parser
	variable initCommands

	if {![interp issafe]} {
	    set parser [interp create -safe]







|
>
>
>







286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

namespace eval auto_mkindex_parser {
    variable parser ""          ;# parser used to build index
    variable index ""           ;# maintains index as it is built
    variable scriptFile ""      ;# name of file being processed
    variable contextStack ""    ;# stack of namespace scopes
    variable imports ""         ;# keeps track of all imported cmds
    variable initCommands       ;# list of commands that create aliases
    if {![info exists initCommands]} {
	set initCommands [list]
    }

    proc init {} {
	variable parser
	variable initCommands

	if {![interp issafe]} {
	    set parser [interp create -safe]
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
#	body 	Implementation of command to handle indexing.

proc auto_mkindex_parser::commandInit {name arglist body} {
    variable parser

    set ns [namespace qualifiers $name]
    set tail [namespace tail $name]
    if {[string equal $ns ""]} {
        set fakeName "[namespace current]::_%@fake_$tail"
    } else {
	set fakeName [string map {:: _} "_%@fake_$name"]
        set fakeName "[namespace current]::$fakeName"
    }
    proc $fakeName $arglist $body

    # YUK!  Tcl won't let us alias fully qualified command names,
    # so we can't handle names like "::itcl::class".  Instead,
    # we have to build procs with the fully qualified names, and
    # have the procs point to the aliases.

    if {[string match "*::*" $name]} {
        set exportCmd [list _%@namespace export [namespace tail $name]]
        $parser eval [list _%@namespace eval $ns $exportCmd]
 
	# The following proc definition does not work if you
	# want to tolerate space or something else diabolical
	# in the procedure name, (i.e., space in $alias)
	# The following does not work:







|
|

<
|








|







437
438
439
440
441
442
443
444
445
446

447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
#	body 	Implementation of command to handle indexing.

proc auto_mkindex_parser::commandInit {name arglist body} {
    variable parser

    set ns [namespace qualifiers $name]
    set tail [namespace tail $name]
    if {$ns eq ""} {
        set fakeName [namespace current]::_%@fake_$tail
    } else {

        set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
    }
    proc $fakeName $arglist $body

    # YUK!  Tcl won't let us alias fully qualified command names,
    # so we can't handle names like "::itcl::class".  Instead,
    # we have to build procs with the fully qualified names, and
    # have the procs point to the aliases.

    if {[string match *::* $name]} {
        set exportCmd [list _%@namespace export [namespace tail $name]]
        $parser eval [list _%@namespace eval $ns $exportCmd]
 
	# The following proc definition does not work if you
	# want to tolerate space or something else diabolical
	# in the procedure name, (i.e., space in $alias)
	# The following does not work:
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512




513
514
515
516
517
518
519
            set name "${ns}::$name"
            if {[string match ::* $name]} {
                break
            }
        }
    }

    if {[string equal [namespace qualifiers $name] ""]} {
        set name [namespace tail $name]
    } elseif {![string match ::* $name]} {
        set name "::$name"
    }

    # Earlier, mkindex replaced all $'s with \0.  Now, we have to reverse
    # that replacement.
    return [string map [list \0 \$] $name]
}





# Register all of the procedures for the auto_mkindex parser that
# will build the "tclIndex" file.

# AUTO MKINDEX:  proc name arglist body
# Adds an entry to the auto index list for the given procedure name.








|









>
>
>
>







499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
            set name "${ns}::$name"
            if {[string match ::* $name]} {
                break
            }
        }
    }

    if {[namespace qualifiers $name] eq ""} {
        set name [namespace tail $name]
    } elseif {![string match ::* $name]} {
        set name "::$name"
    }

    # Earlier, mkindex replaced all $'s with \0.  Now, we have to reverse
    # that replacement.
    return [string map [list \0 \$] $name]
}

if {[llength $::auto_mkindex_parser::initCommands]} {
    return
}

# Register all of the procedures for the auto_mkindex parser that
# will build the "tclIndex" file.

# AUTO MKINDEX:  proc name arglist body
# Adds an entry to the auto index list for the given procedure name.

536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
# variable.  Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded.  This should be a noop if the package has
# already been loaded

auto_mkindex_parser::hook {
    if {![catch {package require tbcload}]} {
	if {[llength [info commands tbcload::bcproc]] == 0} {
	    auto_load tbcload::bcproc
	}
	load {} tbcload $auto_mkindex_parser::parser

	# AUTO MKINDEX:  tbcload::bcproc name arglist body
	# Adds an entry to the auto index list for the given pre-compiled
	# procedure name.  







|







543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
# variable.  Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded.  This should be a noop if the package has
# already been loaded

auto_mkindex_parser::hook {
    if {![catch {package require tbcload}]} {
	if {[namespace which -command tbcload::bcproc] eq ""} {
	    auto_load tbcload::bcproc
	}
	load {} tbcload $auto_mkindex_parser::parser

	# AUTO MKINDEX:  tbcload::bcproc name arglist body
	# Adds an entry to the auto index list for the given pre-compiled
	# procedure name.  
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
	    $parser eval [list _%@namespace eval $name] $args
            set contextStack [lrange $contextStack 1 end]
        }
        import {
            variable parser
            variable imports
            foreach pattern $args {
                if {[string compare $pattern "-force"]} {
                    lappend imports $pattern
                }
            }
            catch {$parser eval "_%@namespace import $args"}
        }
    }
}

return







|









594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
	    $parser eval [list _%@namespace eval $name] $args
            set contextStack [lrange $contextStack 1 end]
        }
        import {
            variable parser
            variable imports
            foreach pattern $args {
                if {$pattern ne "-force"} {
                    lappend imports $pattern
                }
            }
            catch {$parser eval "_%@namespace import $args"}
        }
    }
}

return

Changes to library/clock.tcl.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#
#----------------------------------------------------------------------
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.tcl,v 1.12 2004/11/30 15:45:04 kennykb Exp $
#
#----------------------------------------------------------------------

# We must have message catalogs that support the root locale, and
# we need access to the Registry on Windows systems.  We also need
# Tcl 8.5 dictionaries.








|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#
#----------------------------------------------------------------------
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.tcl,v 1.12.2.4 2005/08/15 18:14:00 dgp Exp $
#
#----------------------------------------------------------------------

# We must have message catalogs that support the root locale, and
# we need access to the Registry on Windows systems.  We also need
# Tcl 8.5 dictionaries.

78
79
80
81
82
83
84




























85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
    namespace export add

    # Import the message catalog commands that we use.

    namespace import ::msgcat::mcload
    namespace import ::msgcat::mclocale





























    # Define the Greenwich time zone

    proc initTZData {} {
	variable TZData
	array unset TZData
	set TZData(:Etc/GMT) {
	    {-9223372036854775808 0 0 GMT}
	}
	set TZData(:GMT) $TZData(:Etc/GMT)
	set TZData(:Etc/UTC) {
	    {-9223372036854775808 0 0 UTC}
	}
	set TZData(:UTC) $TZData(:Etc/UTC)
    }
    initTZData

    # Define the message catalog for the root locale.

    ::msgcat::mcmset {} {
	AM {am}
	BCE {B.C.E.}
	CE {C.E.}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|











|







78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
    namespace export add

    # Import the message catalog commands that we use.

    namespace import ::msgcat::mcload
    namespace import ::msgcat::mclocale

}

#----------------------------------------------------------------------
#
# ::tcl::clock::Initialize --
#
#	Finish initializing the 'clock' subsystem
#
# Results:
#	None.
#
# Side effects:
#	Namespace variable in the 'clock' subsystem are initialized.
#
# The '::tcl::clock::Initialize' procedure initializes the namespace
# variables and root locale message catalog for the 'clock' subsystem.
# It is broken into a procedure rather than simply evaluated as a script
# so that it will be able to use local variables, avoiding the dangers
# of 'creative writing' as in Bug 1185933.
#
#----------------------------------------------------------------------

proc ::tcl::clock::Initialize {} {

    rename ::tcl::clock::Initialize {}

    variable LibDir

    # Define the Greenwich time zone

    proc InitTZData {} {
	variable TZData
	array unset TZData
	set TZData(:Etc/GMT) {
	    {-9223372036854775808 0 0 GMT}
	}
	set TZData(:GMT) $TZData(:Etc/GMT)
	set TZData(:Etc/UTC) {
	    {-9223372036854775808 0 0 UTC}
	}
	set TZData(:UTC) $TZData(:Etc/UTC)
    }
    InitTZData

    # Define the message catalog for the root locale.

    ::msgcat::mcmset {} {
	AM {am}
	BCE {B.C.E.}
	CE {C.E.}
223
224
225
226
227
228
229
230
231
232
233
234
235

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
    #
    #------------------------------------------------------------------

    # Paths at which binary time zone data for the Olson libraries
    # are known to reside on various operating systems

    variable ZoneinfoPaths {}
    proc ZoneinfoInit {} {
	variable ZoneinfoPaths
	rename ZoneinfoInit {}
	foreach path {
	    /usr/share/zoneinfo
	    /usr/share/lib/zoneinfo

	    /usr/local/etc/zoneinfo
	    C:/Progra~1/cygwin/usr/local/etc/zoneinfo
	} {
	    if { [file isdirectory $path] } {
		lappend ZoneinfoPaths $path
	    }
	}
    }
    ZoneinfoInit

    # Define the directories for time zone data and message catalogs.

    variable DataDir [file join $LibDir tzdata]
    variable MsgDir [file join $LibDir msgs]

    # Number of days in the months, in common years and leap years.







<
<
<
|
|
|
>
|
|
|
|
|
|
|
<
<







251
252
253
254
255
256
257



258
259
260
261
262
263
264
265
266
267
268


269
270
271
272
273
274
275
    #
    #------------------------------------------------------------------

    # Paths at which binary time zone data for the Olson libraries
    # are known to reside on various operating systems

    variable ZoneinfoPaths {}



    foreach path {
	/usr/share/zoneinfo
	/usr/share/lib/zoneinfo
	/usr/lib/zoneinfo
	/usr/local/etc/zoneinfo
	C:/Progra~1/cygwin/usr/local/etc/zoneinfo
    } {
	if { [file isdirectory $path] } {
	    lappend ZoneinfoPaths $path
	}
    }



    # Define the directories for time zone data and message catalogs.

    variable DataDir [file join $LibDir tzdata]
    variable MsgDir [file join $LibDir msgs]

    # Number of days in the months, in common years and leap years.
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    foreach j $DaysInRomanMonthInCommonYear {
	lappend DaysInPriorMonthsInCommonYear [incr i $j]
    }
    set i 0
    foreach j $DaysInRomanMonthInLeapYear {
	lappend DaysInPriorMonthsInLeapYear [incr i $j]
    }
    unset i j

    # Another epoch (Hi, Jeff!)

    variable Roddenberry 1946

    # Integer ranges








<







284
285
286
287
288
289
290

291
292
293
294
295
296
297
    foreach j $DaysInRomanMonthInCommonYear {
	lappend DaysInPriorMonthsInCommonYear [incr i $j]
    }
    set i 0
    foreach j $DaysInRomanMonthInLeapYear {
	lappend DaysInPriorMonthsInLeapYear [incr i $j]
    }


    # Another epoch (Hi, Jeff!)

    variable Roddenberry 1946

    # Integer ranges

594
595
596
597
598
599
600

601
602
603
604
605
606
607
    					# if it is known.
    variable TZData;			# Array whose keys are time zone names
					# and whose values are lists of quads
					# comprising start time, UTC offset,
					# Daylight Saving Time indicator, and
					# time zone abbreviation.
}


#----------------------------------------------------------------------
#
# clock format --
#
#	Formats a count of seconds since the Posix Epoch as a time
#	of day.







>







617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
    					# if it is known.
    variable TZData;			# Array whose keys are time zone names
					# and whose values are lists of quads
					# comprising start time, UTC offset,
					# Daylight Saving Time indicator, and
					# time zone abbreviation.
}
::tcl::clock::Initialize

#----------------------------------------------------------------------
#
# clock format --
#
#	Formats a count of seconds since the Posix Epoch as a time
#	of day.
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
	set date [GetYearWeekDay $date[set date {}]]
	
	# Format the result
	
	set state {}
	set retval {}
	foreach char [split $format {}] {
	    switch -exact $state {
		{} {
		    if { [string equal % $char] } {
			set state percent
		    } else {
			append retval $char
		    }
		}







|







727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
	set date [GetYearWeekDay $date[set date {}]]
	
	# Format the result
	
	set state {}
	set retval {}
	foreach char [split $format {}] {
	    switch -exact -- $state {
		{} {
		    if { [string equal % $char] } {
			set state percent
		    } else {
			append retval $char
		    }
		}
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
			 -timezone $timezone -locale $locale]
    }	

    # Do relative weekday
    
    if { [llength $parseWeekday] > 0 } {

	# TODO - There's no reason for this to involve the
	#        ISO calendar; day of week is determined by
	#        Julian Day and there's no need to extract
	#        week of year
	foreach {dayOrdinal dayOfWeek} $parseWeekday break
	set date2 [GetJulianDay \
		       [ConvertUTCToLocal \
			    [dict create seconds $seconds] \
			    $timezone]]
	dict set date2 era CE
	set jdwkday [WeekdayOnOrBefore $dayOfWeek \







<
<
<
<







1324
1325
1326
1327
1328
1329
1330




1331
1332
1333
1334
1335
1336
1337
			 -timezone $timezone -locale $locale]
    }	

    # Do relative weekday
    
    if { [llength $parseWeekday] > 0 } {





	foreach {dayOrdinal dayOfWeek} $parseWeekday break
	set date2 [GetJulianDay \
		       [ConvertUTCToLocal \
			    [dict create seconds $seconds] \
			    $timezone]]
	dict set date2 era CE
	set jdwkday [WeekdayOnOrBefore $dayOfWeek \
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915




2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
    variable CachedSystemTimeZone
    variable TimeZoneBad

    if { ![catch {getenv TCL_TZ} result] } {
	set timezone $result
    } elseif { ![catch {getenv TZ} result] } {
	set timezone $result
    } else {
	if { [info exists CachedSystemTimeZone] } {
	    set timezone $CachedSystemTimeZone
	} else {
	    if { $::tcl_platform(platform) eq {windows} } {
		set timezone [GuessWindowsTimeZone]




	    } else {
		set timezone :localtime
	    }
	    set CachedSystemTimeZone $timezone
	}
    }
    if { ![dict exists $TimeZoneBad $timezone] } {
	dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
    }
    if { [dict get $TimeZoneBad $timezone] } {
	return :localtime
    } else {
	return $timezone







<
|
|
<
|
|
>
>
>
>
|
|
|
|
<
<







2923
2924
2925
2926
2927
2928
2929

2930
2931

2932
2933
2934
2935
2936
2937
2938
2939
2940
2941


2942
2943
2944
2945
2946
2947
2948
    variable CachedSystemTimeZone
    variable TimeZoneBad

    if { ![catch {getenv TCL_TZ} result] } {
	set timezone $result
    } elseif { ![catch {getenv TZ} result] } {
	set timezone $result

    } elseif { [info exists CachedSystemTimeZone] } {
	set timezone $CachedSystemTimeZone

    } elseif { $::tcl_platform(platform) eq {windows} } {
	set timezone [GuessWindowsTimeZone]
    } elseif { [file exists /etc/localtime]
	       && ![catch {ReadZoneinfoFile \
			       Tcl/Localtime /etc/localtime}] } {
	set timezone :Tcl/Localtime
    } else {
	set timezone :localtime
    }
    set CachedSystemTimeZone $timezone


    if { ![dict exists $TimeZoneBad $timezone] } {
	dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
    }
    if { [dict get $TimeZoneBad $timezone] } {
	return :localtime
    } else {
	return $timezone
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305

	} else {

	    # We couldn't parse this as a POSIX time zone.  Try
	    # again with a time zone file - this time without a colon

	    if { [catch { LoadTimeZoneFile $timezone }]
		 && [catch { LoadZoneinfoFile $timezone } - opts] } {
		dict unset opts -errorinfo
		return -options $opts "time zone $timezone not found"
	    }
	    set TZData($timezone) $TZData(:$timezone)
	}
    }








|







3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325

	} else {

	    # We couldn't parse this as a POSIX time zone.  Try
	    # again with a time zone file - this time without a colon

	    if { [catch { LoadTimeZoneFile $timezone }]
		 && [catch { ZoneinfoFile $timezone } - opts] } {
		dict unset opts -errorinfo
		return -options $opts "time zone $timezone not found"
	    }
	    set TZData($timezone) $TZData(:$timezone)
	}
    }

3333
3334
3335
3336
3337
3338
3339

3340
3341
3342
3343
3344
3345
3346
#
#----------------------------------------------------------------------

proc ::tcl::clock::GuessWindowsTimeZone {} {

    variable WinZoneInfo
    variable NoRegistry


    if { [info exists NoRegistry] } {
	return :localtime
    }

    # Dredge time zone information out of the registry








>







3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
#
#----------------------------------------------------------------------

proc ::tcl::clock::GuessWindowsTimeZone {} {

    variable WinZoneInfo
    variable NoRegistry
    variable TimeZoneBad

    if { [info exists NoRegistry] } {
	return :localtime
    }

    # Dredge time zone information out of the registry

3366
3367
3368
3369
3370
3371
3372
3373



3374
3375








3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387

3388
3389

3390
3391
3392
3393

3394
3395
3396
3397
3398

3399
3400

3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
    }] } {

	# Missing values in the Registry - bail out

	return :localtime
    }

    # Make up a Posix time zone specifier if we can't find one




    if { ! [dict exists $WinZoneInfo $data] } {








	foreach {
	    bias stdBias dstBias
	    stdYear stdMonth stdDayOfWeek stdDayOfMonth
	    stdHour stdMinute stdSecond stdMillisec
	    dstYear dstMonth dstDayOfWeek dstDayOfMonth
	    dstHour dstMinute dstSecond dstMillisec
	} $data break
	set stdDelta [expr { $bias + $stdBias }]
	set dstDelta [expr { $bias + $dstBias }]
	if { $stdDelta <= 0 } {
	    set stdSignum +
	    set stdDelta [expr { - $stdDelta }]

	} else {
	    set stdSignum -

	}
	set hh [::format %02d [expr { $stdDelta / 3600 }]]
	set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
	set ss [::format %02d [expr { $stdDelta % 60 }]]

	append tzname < $stdSignum $hh $mm > $stdSignum $hh : $mm : $ss
	if { $stdMonth >= 0 } {
	    if { $dstDelta <= 0 } {
		set dstSignum +
		set dstDelta [expr { - $dstDelta }]

	    } else {
		set dstSignum -

	    }
	    set hh [::format %02d [expr { $dstDelta / 3600 }]]
	    set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
	    set ss [::format %02d [expr { $dstDelta % 60 }]]
	    append tzname < $dstSignum $hh $mm > $dstSignum $hh : $mm : $ss
	    if { $dstYear == 0 } {
		append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
	    } else {
		# I have not been able to find any locale on which
		# Windows converts time zone on a fixed day of the year,
		# hence don't know how to interpret the fields.
		# If someone can inform me, I'd be glad to code it up.







|
>
>
>

|
>
>
>
>
>
>
>
>












>


>




>
|




>


>




|







3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
    }] } {

	# Missing values in the Registry - bail out

	return :localtime
    }

    # Make up a Posix time zone specifier if we can't find one.
    # Check here that the tzdata file exists, in case we're running
    # in an environment (e.g. starpack) where tzdata is incomplete.
    # (Bug 1237907)

    if { [dict exists $WinZoneInfo $data] } {
	set tzname [dict get $WinZoneInfo $data]
	if { ! [dict exists $TimeZoneBad $tzname] } {
	    dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
	}
    } else {
	set tzname {}
    }
    if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } {
	foreach {
	    bias stdBias dstBias
	    stdYear stdMonth stdDayOfWeek stdDayOfMonth
	    stdHour stdMinute stdSecond stdMillisec
	    dstYear dstMonth dstDayOfWeek dstDayOfMonth
	    dstHour dstMinute dstSecond dstMillisec
	} $data break
	set stdDelta [expr { $bias + $stdBias }]
	set dstDelta [expr { $bias + $dstBias }]
	if { $stdDelta <= 0 } {
	    set stdSignum +
	    set stdDelta [expr { - $stdDelta }]
	    set dispStdSignum -
	} else {
	    set stdSignum -
	    set dispStdSignum +
	}
	set hh [::format %02d [expr { $stdDelta / 3600 }]]
	set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
	set ss [::format %02d [expr { $stdDelta % 60 }]]
	set tzname {}
	append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
	if { $stdMonth >= 0 } {
	    if { $dstDelta <= 0 } {
		set dstSignum +
		set dstDelta [expr { - $dstDelta }]
		set dispDstSignum -
	    } else {
		set dstSignum -
		set dispDstSignum +
	    }
	    set hh [::format %02d [expr { $dstDelta / 3600 }]]
	    set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
	    set ss [::format %02d [expr { $dstDelta % 60 }]]
	    append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
	    if { $dstYear == 0 } {
		append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
	    } else {
		# I have not been able to find any locale on which
		# Windows converts time zone on a fixed day of the year,
		# hence don't know how to interpret the fields.
		# If someone can inform me, I'd be glad to code it up.
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524



























3525
3526
3527
3528
3529
3530
3531
#----------------------------------------------------------------------
#
# LoadZoneinfoFile --
#
#	Loads a binary time zone information file in Olson format.
#
# Parameters:
#	fileName - Path name of the file to load.
#
# Results:
#	Returns an empty result normally; returns an error if no
#	Olson file was found or the file was malformed in some way.
#
# Side effects:
#	TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------

proc ::tcl::clock::LoadZoneinfoFile { fileName } {

    variable MINWIDE
    variable TZData
    variable ZoneinfoPaths

    # Since an unsafe interp uses the [clock] command in the master,
    # this code is security sensitive.  Make sure that the path name
    # cannot escape the given directory.

    if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
	return -code error \
	    -errorcode [list CLOCK badTimeZone $:fileName] \
	    "time zone \":$fileName\" not valid"
    }
    foreach d $ZoneinfoPaths {
	set fname [file join $d $fileName]
	if { [file readable $fname] && [file isfile $fname] } {
	    break
	}
	unset fname
    }



























    if { ![info exists fname] } {
	return -code error "$fileName not found"
    }

    if { [file size $fname] > 262144 } {
	return -code error "$fileName too big"
    }







|












<
<


















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541


3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
#----------------------------------------------------------------------
#
# LoadZoneinfoFile --
#
#	Loads a binary time zone information file in Olson format.
#
# Parameters:
#	fileName - Relative path name of the file to load.
#
# Results:
#	Returns an empty result normally; returns an error if no
#	Olson file was found or the file was malformed in some way.
#
# Side effects:
#	TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------

proc ::tcl::clock::LoadZoneinfoFile { fileName } {



    variable ZoneinfoPaths

    # Since an unsafe interp uses the [clock] command in the master,
    # this code is security sensitive.  Make sure that the path name
    # cannot escape the given directory.

    if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
	return -code error \
	    -errorcode [list CLOCK badTimeZone $:fileName] \
	    "time zone \":$fileName\" not valid"
    }
    foreach d $ZoneinfoPaths {
	set fname [file join $d $fileName]
	if { [file readable $fname] && [file isfile $fname] } {
	    break
	}
	unset fname
    }
    ReadZoneinfoFile $fileName $fname
}

#----------------------------------------------------------------------
#
# LoadZoneinfoFile --
#
#	Loads a binary time zone information file in Olson format.
#
# Parameters:
#	fileName - Name of the time zone (relative path name of the
#		   file).
#	fname - Absolute path name of the file.
#
# Results:
#	Returns an empty result normally; returns an error if no
#	Olson file was found or the file was malformed in some way.
#
# Side effects:
#	TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------


proc ReadZoneinfoFile {fileName fname} {
    variable MINWIDE
    variable TZData
    if { ![info exists fname] } {
	return -code error "$fileName not found"
    }

    if { [file size $fname] > 262144 } {
	return -code error "$fileName too big"
    }
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
	set lastTime $t
	foreach { gmtoff isDst abbrInd } [lindex $types $c] break
	set abbrev [dict get $abbrevs $abbrInd]
	lappend r [list $t $gmtoff $isDst $abbrev]
    }

    set TZData(:$fileName) $r

}

#----------------------------------------------------------------------
#
# ParsePosixTimeZone --
#
#	Parses the TZ environment variable in Posix form







|







3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
	set lastTime $t
	foreach { gmtoff isDst abbrInd } [lindex $types $c] break
	set abbrev [dict get $abbrevs $abbrInd]
	lappend r [list $t $gmtoff $isDst $abbrev]
    }

    set TZData(:$fileName) $r
    return
}

#----------------------------------------------------------------------
#
# ParsePosixTimeZone --
#
#	Parses the TZ environment variable in Posix form
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421








4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } {

    variable DaysInPriorMonthsInCommonYear
    variable DaysInPriorMonthsInLeapYear

    # Get absolute year number from the civil year

    switch -exact [dict get $date era] {
	BCE {
	    set year [expr { 1 - [dict get $date year] }]
	}
	CE {
	    set year [dict get $date year]
	}
    }








    set ym1 [expr { $year - 1 }]

    # Try the Gregorian calendar first.

    dict set date gregorian 1
    set jd [expr { 1721425
		   + [dict get $date dayOfMonth]
		   + ( [IsGregorianLeapYear $date] ?
		       [lindex $DaysInPriorMonthsInLeapYear \
			    [expr { [dict get $date month] - 1}]]
		       : [lindex $DaysInPriorMonthsInCommonYear \
			      [expr { [dict get $date month] - 1}]] )
		   + ( 365 * $ym1 )
		   + ( $ym1 / 4 )
		   - ( $ym1 / 100 )
		   + ( $ym1 / 400 ) }]
    
    # If the date is before the Gregorian change, use the Julian calendar.

    if { $jd < [mc GREGORIAN_CHANGE_DATE] } {

	dict set date gregorian 0
	set jd [expr { 1721423
		       + [dict get $date dayOfMonth]
		       + ( ( $year % 4 == 0 ) ?
		       [lindex $DaysInPriorMonthsInLeapYear \
			    [expr { [dict get $date month] - 1}]]
		       : [lindex $DaysInPriorMonthsInCommonYear \
			      [expr { [dict get $date month] - 1}]] )
		       + ( 365 * $ym1 )
		       + ( $ym1 / 4 ) }]
    }

    dict set date julianDay $jd
    return $date








|







>
>
>
>
>
>
>
>









|

|














|

|







4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } {

    variable DaysInPriorMonthsInCommonYear
    variable DaysInPriorMonthsInLeapYear

    # Get absolute year number from the civil year

    switch -exact -- [dict get $date era] {
	BCE {
	    set year [expr { 1 - [dict get $date year] }]
	}
	CE {
	    set year [dict get $date year]
	}
    }

    # If month is out of range, reduce modulo 12 and adjust year accordingly.

    set month [expr { [dict get $date month] - 1 }]
    incr year [expr { $month / 12 }]
    set month [expr { ( $month % 12 ) + 1 }]
    dict set date era CE; dict set date year $year; dict set date month $month

    set ym1 [expr { $year - 1 }]

    # Try the Gregorian calendar first.

    dict set date gregorian 1
    set jd [expr { 1721425
		   + [dict get $date dayOfMonth]
		   + ( [IsGregorianLeapYear $date] ?
		       [lindex $DaysInPriorMonthsInLeapYear \
			    [expr { $month - 1}]]
		       : [lindex $DaysInPriorMonthsInCommonYear \
			      [expr { $month - 1}]] )
		   + ( 365 * $ym1 )
		   + ( $ym1 / 4 )
		   - ( $ym1 / 100 )
		   + ( $ym1 / 400 ) }]
    
    # If the date is before the Gregorian change, use the Julian calendar.

    if { $jd < [mc GREGORIAN_CHANGE_DATE] } {

	dict set date gregorian 0
	set jd [expr { 1721423
		       + [dict get $date dayOfMonth]
		       + ( ( $year % 4 == 0 ) ?
		       [lindex $DaysInPriorMonthsInLeapYear \
			    [expr { $month - 1}]]
		       : [lindex $DaysInPriorMonthsInCommonYear \
			      [expr { $month - 1}]] )
		       + ( 365 * $ym1 )
		       + ( $ym1 / 4 ) }]
    }

    dict set date julianDay $jd
    return $date

4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc ::tcl::clock::GetJulianDayFromEraYearDay { date } {

    variable DaysInPriorMonthsInCommonYear
    variable DaysInPriorMonthsInLeapYear

    # Get absolute year number from the civil year

    switch -exact [dict get $date era] {
	BCE {
	    set year [expr { 1 - [dict get $date year] }]
	}
	CE {
	    set year [dict get $date year]
	}
    }







<
<
<


|







4549
4550
4551
4552
4553
4554
4555



4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc ::tcl::clock::GetJulianDayFromEraYearDay { date } {




    # Get absolute year number from the civil year

    switch -exact -- [dict get $date era] {
	BCE {
	    set year [expr { 1 - [dict get $date year] }]
	}
	CE {
	    set year [dict get $date year]
	}
    }
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039

5040
5041
5042
#----------------------------------------------------------------------

proc ::tcl::clock::ClearCaches {} {

    variable LocaleNumeralCache
    variable McLoaded
    variable CachedSystemTimeZone
    variable TZData

    foreach p [info procs [namespace current]::scanproc'*] {
	rename $p {}
    }

    set LocaleNumeralCache {}
    set McLoaded {}
    catch {unset CachedSystemTimeZone}

    initTZData

}







|








>
|


5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
#----------------------------------------------------------------------

proc ::tcl::clock::ClearCaches {} {

    variable LocaleNumeralCache
    variable McLoaded
    variable CachedSystemTimeZone
    variable TimeZoneBad

    foreach p [info procs [namespace current]::scanproc'*] {
	rename $p {}
    }

    set LocaleNumeralCache {}
    set McLoaded {}
    catch {unset CachedSystemTimeZone}
    set TimeZoneBad {}
    InitTZData

}

Changes to library/history.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.6 2003/03/19 21:57:42 dgp Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#





|







1
2
3
4
5
6
7
8
9
10
11
12
# history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.6.4.1 2005/08/02 18:16:14 dgp Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
# Side Effects:
#	Adds to the history list

 proc tcl::HistAdd {command {exec {}}} {
    variable history

    # Do not add empty commands to the history
    if {[string trim $command] == ""} {
	return ""
    }

    set i [incr history(nextid)]
    set history($i) $command
    set j [incr history(oldest)]
    if {[info exists history($j)]} {unset history($j)}
    if {[string match e* $exec]} {
	return [uplevel #0 $command]
    } else {
	return {}
    }
}








|






|







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
# Side Effects:
#	Adds to the history list

 proc tcl::HistAdd {command {exec {}}} {
    variable history

    # Do not add empty commands to the history
    if {[string trim $command] eq ""} {
	return ""
    }

    set i [incr history(nextid)]
    set history($i) $command
    set j [incr history(oldest)]
    unset -nocomplain history($j)
    if {[string match e* $exec]} {
	return [uplevel #0 $command]
    } else {
	return {}
    }
}

194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
#	If no limit is specified, the current limit is returned
#
# Side Effects:
#	Updates history(keep) if a limit is specified

 proc tcl::HistKeep {{limit {}}} {
    variable history
    if {[string length $limit] == 0} {
	return $history(keep)
    } else {
	set oldold $history(oldest)
	set history(oldest) [expr {$history(nextid) - $limit}]
	for {} {$oldold <= $history(oldest)} {incr oldold} {
	    if {[info exists history($oldold)]} {unset history($oldold)}
	}
	set history(keep) $limit
    }
}

# tcl::HistClear --
#







|





|







194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
#	If no limit is specified, the current limit is returned
#
# Side Effects:
#	Updates history(keep) if a limit is specified

 proc tcl::HistKeep {{limit {}}} {
    variable history
    if {$limit eq ""} {
	return $history(keep)
    } else {
	set oldold $history(oldest)
	set history(oldest) [expr {$history(nextid) - $limit}]
	for {} {$oldold <= $history(oldest)} {incr oldold} {
	    unset -nocomplain history($oldold)
	}
	set history(keep) $limit
    }
}

# tcl::HistClear --
#
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
#	num	(optional) the length of the history list to return
#
# Results:
#	A formatted history list

 proc tcl::HistInfo {{num {}}} {
    variable history
    if {$num == {}} {
	set num [expr {$history(keep) + 1}]
    }
    set result {}
    set newline ""
    for {set i [expr {$history(nextid) - $num + 1}]} \
	    {$i <= $history(nextid)} {incr i} {
	if {![info exists history($i)]} {







|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
#	num	(optional) the length of the history list to return
#
# Results:
#	A formatted history list

 proc tcl::HistInfo {{num {}}} {
    variable history
    if {$num eq ""} {
	set num [expr {$history(keep) + 1}]
    }
    set result {}
    set newline ""
    for {set i [expr {$history(nextid) - $num + 1}]} \
	    {$i <= $history(nextid)} {incr i} {
	if {![info exists history($i)]} {
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
#	Those of the command being redone.
#
# Side Effects:
#	Replaces the current history list item with the one being redone.

 proc tcl::HistRedo {{event -1}} {
    variable history
    if {[string length $event] == 0} {
	set event -1
    }
    set i [HistIndex $event]
    if {$i == $history(nextid)} {
	return -code error "cannot redo the current event"
    }
    set cmd $history($i)







|







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
#	Those of the command being redone.
#
# Side Effects:
#	Replaces the current history list item with the one being redone.

 proc tcl::HistRedo {{event -1}} {
    variable history
    if {$event eq ""} {
	set event -1
    }
    set i [HistIndex $event]
    if {$i == $history(nextid)} {
	return -code error "cannot redo the current event"
    }
    set cmd $history($i)

Changes to library/http/http.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43




44
45
46
47
48
49
50
51

52
53
54
55
56
57
58
# http.tcl --
#
#	Client-side HTTP for GET, POST, and HEAD commands.
#	These routines can be used in untrusted code that uses 
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.48 2004/05/25 22:56:33 hobbs Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel
#	This version also cleans up error cases and eliminates the
#	"ioerror" status in favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element
#	to the state array.

package require Tcl 8.2
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
package provide http 2.5.0

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-proxyfilter http::ProxyRequired
	-urlencoding utf-8
    }
    set http(-useragent) "Tcl http client package [package provide http]"

    proc init {} {
	variable formMap
	variable alphanumeric a-zA-Z0-9




	for {set i 0} {$i <= 256} {incr i} {
	    set c [format %c $i]
	    if {![string match \[$alphanumeric\] $c]} {
		set formMap($c) %[format %.2x $i]
	    }
	}
	# These are handled specially
	array set formMap { " " + \n %0d%0a }

    }
    init

    variable urlTypes
    array set urlTypes {
	http	{80 ::socket}
    }











|












|


|













|
|
>
>
>
>


|
|



|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
# http.tcl --
#
#	Client-side HTTP for GET, POST, and HEAD commands.
#	These routines can be used in untrusted code that uses 
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.48.2.2 2005/10/08 13:44:37 dgp Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel
#	This version also cleans up error cases and eliminates the
#	"ioerror" status in favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element
#	to the state array.

package require Tcl 8.4
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
package provide http 2.5.1

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-proxyfilter http::ProxyRequired
	-urlencoding utf-8
    }
    set http(-useragent) "Tcl http client package [package provide http]"

    proc init {} {
	# Set up the map for quoting chars
	# RFC3986 Section 2.3 say percent encode all except:
	# "... percent-encoded octets in the ranges of ALPHA
	# (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D),
	# period (%2E), underscore (%5F), or tilde (%7E) should
	# not be created by URI producers ..."
	for {set i 0} {$i <= 256} {incr i} {
	    set c [format %c $i]
	    if {![string match {[-._~a-zA-Z0-9]} $c]} {
		set map($c) %[format %.2x $i]
	    }
	}
	# These are handled specially
	array set map { " " + \n %0d%0a }
	variable formMap [array get map]
    }
    init

    variable urlTypes
    array set urlTypes {
	http	{80 ::socket}
    }
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token

	if {[string equal $state(status) "error"]} {
	    # something went wrong while trying to establish the connection
	    # Clean up after events and such, but DON'T call the command
	    # callback (if available) because we're going to throw an 
	    # exception from here instead.
	    set err [lindex $state(error) 0]
	    cleanup $token
	    return -code error $err
	} elseif {![string equal $state(status) "connect"]} {
	    # Likely to be connection timeout
	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators







|







|







369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token

	if {$state(status) eq "error"} {
	    # something went wrong while trying to establish the connection
	    # Clean up after events and such, but DON'T call the command
	    # callback (if available) because we're going to throw an 
	    # exception from here instead.
	    set err [lindex $state(error) 0]
	    cleanup $token
	    return -code error $err
	} elseif {$state(status) ne "connect"} {
	    # Likely to be connection timeout
	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
	} else {
	    puts $s "Host: $host:$port"
	}
	puts $s "User-Agent: $http(-useragent)"
	foreach {key value} $state(-headers) {
	    set value [string map [list \n "" \r ""] $value]
	    set key [string trim $key]
	    if {[string equal $key "Content-Length"]} {
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}







|







427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
	} else {
	    puts $s "Host: $host:$port"
	}
	puts $s "User-Agent: $http(-useragent)"
	foreach {key value} $state(-headers) {
	    set value [string map [list \n "" \r ""] $value]
	    set key [string trim $key]
	    if {$key eq "Content-Length"} {
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508

	if {! [info exists state(-command)]} {

	    # geturl does EVERYTHING asynchronously, so if the user
	    # calls it synchronously, we just do a wait here.

	    wait $token
	    if {[string equal $state(status) "error"]} {
		# Something went wrong, so throw the exception, and the
		# enclosing catch will do cleanup.
		return -code error [lindex $state(error) 0]
	    }
	}
    } err]} {
	# The socket probably was never connected,
	# or the connection dropped later.

	# Clean up after events and such, but DON'T call the command callback
	# (if available) because we're going to throw an exception from here
	# instead.

	# if state(status) is error, it means someone's already called Finish
	# to do the above-described clean up.
	if {[string equal $state(status) "error"]} {
	    Finish $token $err 1
	}
	cleanup $token
	return -code error $err
    }

    return $token







|















|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513

	if {! [info exists state(-command)]} {

	    # geturl does EVERYTHING asynchronously, so if the user
	    # calls it synchronously, we just do a wait here.

	    wait $token
	    if {$state(status) eq "error"} {
		# Something went wrong, so throw the exception, and the
		# enclosing catch will do cleanup.
		return -code error [lindex $state(error) 0]
	    }
	}
    } err]} {
	# The socket probably was never connected,
	# or the connection dropped later.

	# Clean up after events and such, but DON'T call the command callback
	# (if available) because we're going to throw an exception from here
	# instead.

	# if state(status) is error, it means someone's already called Finish
	# to do the above-described clean up.
	if {$state(status) eq "error"} {
	    Finish $token $err 1
	}
	cleanup $token
	return -code error $err
    }

    return $token
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
    upvar 0 $token state
    set s $state(sock)

     if {[eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
	    variable encodings
	    set state(state) body
	    if {$state(-binary) || ![string match -nocase text* $state(type)]
		    || [string match *gzip* $state(coding)]







|







679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
    upvar 0 $token state
    set s $state(sock)

     if {[eof $s]} {
	Eof $token
	return
    }
    if {$state(state) eq "header"} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
	    variable encodings
	    set state(state) body
	    if {$state(-binary) || ![string match -nocase text* $state(type)]
		    || [string match *gzip* $state(coding)]
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
#
# Side Effects
#	Clean up the socket

proc http::Eof {token} {
    variable $token
    upvar 0 $token state
    if {[string equal $state(state) "header"]} {
	# Premature eof
	set state(status) eof
    } else {
	set state(status) ok
    }
    set state(state) eof
    Finish $token







|







817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
#
# Side Effects
#	Clean up the socket

proc http::Eof {token} {
    variable $token
    upvar 0 $token state
    if {$state(state) eq "header"} {
	# Premature eof
	set state(status) eof
    } else {
	set state(status) ok
    }
    set state(state) eof
    Finish $token
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
#        TODO

proc http::formatQuery {args} {
    set result ""
    set sep ""
    foreach i $args {
	append result $sep [mapReply $i]
	if {[string equal $sep "="]} {
	    set sep &
	} else {
	    set sep =
	}
    }
    return $result
}







|







867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
#        TODO

proc http::formatQuery {args} {
    set result ""
    set sep ""
    foreach i $args {
	append result $sep [mapReply $i]
	if {$sep eq "="} {
	    set sep &
	} else {
	    set sep =
	}
    }
    return $result
}
884
885
886
887
888
889
890
891
892
893
894

895
896
897
898
899
900

901
902
903





904
905
906
907
908
909
910
911
#
# Results:
#       The encoded string

proc http::mapReply {string} {
    variable http
    variable formMap
    variable alphanumeric

    # The spec says: "non-alphanumeric characters are replaced by '%HH'"
    # 1 leave alphanumerics characters alone

    # 2 Convert every other character to an array lookup
    # 3 Escape constructs that are "special" to the tcl parser
    # 4 "subst" the result, doing all the array substitutions

    if {$http(-urlencoding) ne ""} {
	set string [encoding convertto $http(-urlencoding) $string]

    }
    regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
    regsub -all {[][{})\\]\)} $string {\\&} string





    return [subst -nocommand $string]
}

# http::ProxyRequired --
#	Default proxy filter. 
#
# Arguments:
#	host	The destination host







<


<
>
|
<
<



>

|
|
>
>
>
>
>
|







889
890
891
892
893
894
895

896
897

898
899


900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
#
# Results:
#       The encoded string

proc http::mapReply {string} {
    variable http
    variable formMap


    # The spec says: "non-alphanumeric characters are replaced by '%HH'"

    # Use a pre-computed map and [string map] to do the conversion
    # (much faster than [regsub]/[subst]). [Bug 1020491]



    if {$http(-urlencoding) ne ""} {
	set string [encoding convertto $http(-urlencoding) $string]
	return [string map $formMap $string]
    }
    set converted [string map $formMap $string]
    if {[string match "*\[\u0100-\uffff\]*" $converted]} {
	regexp {[\u0100-\uffff]} $converted badChar
	# Return this error message for maximum compatability... :^/
	return -code error \
	    "can't read \"formMap($badChar)\": no such element in array"
    }
    return $converted
}

# http::ProxyRequired --
#	Default proxy filter. 
#
# Arguments:
#	host	The destination host

Changes to library/http/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded http 2.5.0 [list tclPkgSetup $dir http 2.5.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]










|
|
1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded http 2.5.1 [list tclPkgSetup $dir http 2.5.1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]

Changes to library/init.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69 2004/11/30 22:19:21 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution





|







1
2
3
4
5
6
7
8
9
10
11
12
13
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69.2.7 2005/10/08 13:44:37 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70





71





























































72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116



117

118





119

120




















121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
	set auto_path $env(TCLLIBPATH)
    } else {
	set auto_path ""
    }
}
namespace eval tcl {
    variable Dir
    if {[info library] != ""} {
	foreach Dir [list [info library] [file dirname [info library]]] {
	    if {[lsearch -exact $::auto_path $Dir] < 0} {
		lappend ::auto_path $Dir
	    }
	}
    }
    set Dir [file join [file dirname [file dirname \
	    [info nameofexecutable]]] lib]
    if {[lsearch -exact $::auto_path $Dir] < 0} {
	lappend ::auto_path $Dir
    }
    if {[info exists ::tcl_pkgPath]} {
	foreach Dir $::tcl_pkgPath {
	    if {[lsearch -exact $::auto_path $Dir] < 0} {
		lappend ::auto_path $Dir
	    }
	}
    }
}





  





























































# Windows specific end of initialization

if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
    namespace eval tcl {
	proc EnvTraceProc {lo n1 n2 op} {
	    set x $::env($n2)
	    set ::env($lo) $x
	    set ::env([string toupper $lo]) $x
	}
	proc InitWinEnv {} {
	    global env tcl_platform
	    foreach p [array names env] {
		set u [string toupper $p]
		if {![string equal $u $p]} {
		    switch -- $u {
			COMSPEC -
			PATH {
			    if {![info exists env($u)]} {
				set env($u) $env($p)
			    }
			    trace variable env($p) w \
				    [namespace code [list EnvTraceProc $p]]
			    trace variable env($u) w \
				    [namespace code [list EnvTraceProc $p]]
			}
		    }
		}
	    }
	    if {![info exists env(COMSPEC)]} {
		if {[string equal $tcl_platform(os) "Windows NT"]} {
		    set env(COMSPEC) cmd.exe
		} else {
		    set env(COMSPEC) command.com
		}
	    }
	}
	InitWinEnv
    }
}

# Setup the unknown package handler

package unknown tclPkgUnknown

if {![interp issafe]} {



    # setup platform specific unknown package handlers

    if {[string equal $::tcl_platform(platform) "unix"] && \





	    [string equal $::tcl_platform(os) "Darwin"]} {

	package unknown [list tcl::MacOSXPkgUnknown [package unknown]]




















    }
}

# Conditionalize for presence of exec.

if {[llength [info commands exec]] == 0} {

    # Some machines do not have exec. Also, on all
    # platforms, safe interpreters do not have exec.

    set auto_noexec 1
}

# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)

if {[llength [info commands tclLog]] == 0} {
    proc tclLog {string} {
	catch {puts stderr $string}
    }
}

# unknown --
# This procedure is called when a Tcl command is invoked that doesn't







<
|
|
|
<




|


|

|




|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|










|






|

|






|












<

|
>
>
>
|
>
|
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|










|







44
45
46
47
48
49
50

51
52
53

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177

178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
	set auto_path $env(TCLLIBPATH)
    } else {
	set auto_path ""
    }
}
namespace eval tcl {
    variable Dir

    foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
	if {$Dir ni $::auto_path} {
	    lappend ::auto_path $Dir

	}
    }
    set Dir [file join [file dirname [file dirname \
	    [info nameofexecutable]]] lib]
    if {$Dir ni $::auto_path} {
	lappend ::auto_path $Dir
    }
    catch {
	foreach Dir $::tcl_pkgPath {
	    if {$Dir ni $::auto_path} {
		lappend ::auto_path $Dir
	    }
	}
    }

    variable Path [unsupported::EncodingDirs]
    set Dir [file join $::tcl_library encoding]
    if {$Dir ni $Path} {
	lappend Path $Dir
	unsupported::EncodingDirs $Path
    }

    # Set up the 'chan' ensemble (TIP #208).
    namespace eval chan {
        # TIP #219. Added methods: create, postevent.
        namespace ensemble create -command ::chan -map {
            blocked     ::fblocked
            close       ::close
            configure   ::fconfigure
            copy        ::fcopy
            create      ::tcl::chan::rCreate
            eof         ::eof
            event       ::fileevent
            flush       ::flush
            gets        ::gets
            names       {::file channels}
            postevent   ::tcl::chan::rPostevent
            puts        ::puts
            read        ::read
            seek        ::seek
            tell        ::tell
            truncate    ::tcl::chan::Truncate
        }
    }

    # TIP #255 min and max functions
    namespace eval mathfunc {
	proc min {args} {
	    if {[llength $args] == 0} {
		return -code error \
		    "too few arguments to math function \"min\""
	    }
	    set val Inf
	    foreach arg $args {
		# This will handle forcing the numeric value without
		# ruining the internal type of a numeric object
		if {[catch {expr {double($arg)}} err]} {
		    return -code error $err
		}
		if {$arg < $val} { set val $arg }
	    }
	    return $val
	}
	proc max {args} {
	    if {[llength $args] == 0} {
		return -code error \
		    "too few arguments to math function \"max\""
	    }
	    set val -Inf
	    foreach arg $args {
		# This will handle forcing the numeric value without
		# ruining the internal type of a numeric object
		if {[catch {expr {double($arg)}} err]} {
		    return -code error $err
		}
		if {$arg > $val} { set val $arg }
	    }
	    return $val
	}
    }
}

# Windows specific end of initialization

if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
    namespace eval tcl {
	proc EnvTraceProc {lo n1 n2 op} {
	    set x $::env($n2)
	    set ::env($lo) $x
	    set ::env([string toupper $lo]) $x
	}
	proc InitWinEnv {} {
	    global env tcl_platform
	    foreach p [array names env] {
		set u [string toupper $p]
		if {$u ne $p} {
		    switch -- $u {
			COMSPEC -
			PATH {
			    if {![info exists env($u)]} {
				set env($u) $env($p)
			    }
			    trace add variable env($p) write \
				    [namespace code [list EnvTraceProc $p]]
			    trace add variable env($u) write \
				    [namespace code [list EnvTraceProc $p]]
			}
		    }
		}
	    }
	    if {![info exists env(COMSPEC)]} {
		if {$tcl_platform(os) eq "Windows NT"} {
		    set env(COMSPEC) cmd.exe
		} else {
		    set env(COMSPEC) command.com
		}
	    }
	}
	InitWinEnv
    }
}

# Setup the unknown package handler



if {[interp issafe]} {
    package unknown ::tclPkgUnknown
} else {
    # Set up search for Tcl Modules (TIP #189).
    # and setup platform specific unknown package handlers
    if {$::tcl_platform(os) eq "Darwin"
	    && $::tcl_platform(platform) eq "unix"} {
	package unknown {::tcl::tm::UnknownHandler \
		{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
    } else {
	package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
    }

    # Set up the 'clock' ensemble

    namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]

    proc clock args {
	namespace eval ::tcl::clock [list namespace ensemble create -command \
		[uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \
		-subcommands {
		    add clicks format microseconds milliseconds scan seconds
		}]
	
	# Auto-loading stubs for 'clock.tcl'
	
	foreach cmd {add format scan} {
	    proc ::tcl::clock::$cmd args {
		variable TclLibDir
		source -encoding utf-8 [file join $TclLibDir clock.tcl]
		return [uplevel 1 [info level 0]]
	    }
	}

	return [uplevel 1 [info level 0]]
    }
}

# Conditionalize for presence of exec.

if {[namespace which -command exec] eq ""} {

    # Some machines do not have exec. Also, on all
    # platforms, safe interpreters do not have exec.

    set auto_noexec 1
}

# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)

if {[namespace which -command tclLog] eq ""} {
    proc tclLog {string} {
	catch {puts stderr $string}
    }
}

# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
	dict unset opts -errorinfo
	dict incr opts -level
	return -options $opts $result
    }

    catch {set savedErrorInfo $::errorInfo}
    catch {set savedErrorCode $::errorCode}
    set name [lindex $args 0]
    if {![info exists auto_noload]} {
	#
	# Make sure we're not trying to load the same proc twice.
	#
	if {[info exists UnknownPending($name)]} {
	    return -code error "self-referential recursion\
		    in \"unknown\" for command \"$name\"";







|







270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
	dict unset opts -errorinfo
	dict incr opts -level
	return -options $opts $result
    }

    catch {set savedErrorInfo $::errorInfo}
    catch {set savedErrorCode $::errorCode}
    set name $cmd
    if {![info exists auto_noload]} {
	#
	# Make sure we're not trying to load the same proc twice.
	#
	if {[info exists UnknownPending($name)]} {
	    return -code error "self-referential recursion\
		    in \"unknown\" for command \"$name\"";
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 153} {
		    set cinfo [string range $cinfo 0 152]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"







|
|







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 150} {
		    set cinfo [string range $cinfo 0 150]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"
255
256
257
258
259
260
261

262
263
264
265
266
267
268
269
270
271
272
273
274
275

276



277
278
279
280
281
282
283
284
285
286
287
288
289
290



291
292
293
294
295
296
297
298
299
300
301








302
303
304
305
306
307
308
309
310
311



312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
		if {$errorInfo ne "$einfo$expect"} {
		    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
			[list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
		}
		return -code error -errorcode $errorCode \
			-errorinfo $einfo $msg
	    } else {

		return -code $code $msg
	    }
	}
    }

    if {([info level] == 1) && [string equal [info script] ""] \
	    && [info exists tcl_interactive] && $tcl_interactive} {
	if {![info exists auto_noexec]} {
	    set new [auto_execok $name]
	    if {$new != ""} {
		set redir ""
		if {[string equal [info commands console] ""]} {
		    set redir ">&@stdout <@stdin"
		}

		return [uplevel 1 exec $redir $new [lrange $args 1 end]]



	    }
	}
	if {[string equal $name "!!"]} {
	    set newcmd [history event]
	} elseif {[regexp {^!(.+)$} $name dummy event]} {
	    set newcmd [history event $event]
	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
	    set newcmd [history event -1]
	    catch {regsub -all -- $old $newcmd $new newcmd}
	}
	if {[info exists newcmd]} {
	    tclLog $newcmd
	    history change $newcmd 0
	    return [uplevel 1 $newcmd]



	}

	set ret [catch {set candidates [info commands $name*]} msg]
	if {[string equal $name "::"]} {
	    set name ""
	}
	if {$ret != 0} {
	    dict append opts -errorinfo \
		    "\n    (expanding command prefix \"$name\" in unknown)"
	    return -options $opts $msg
	}








	# Filter out bogus matches when $name contained
	# a glob-special char [Bug 946952]
	set cmds [list]
	foreach x $candidates {
	    if {[string range $x 0 [expr [string length $name]-1]] eq $name} {
		lappend cmds $x
	    }
	}
	if {[llength $cmds] == 1} {
	    return [uplevel 1 [lreplace $args 0 0 $cmds]]



	}
	if {[llength $cmds]} {
	    if {[string equal $name ""]} {
		return -code error "empty command name \"\""
	    } else {
		return -code error \
			"ambiguous command name \"$name\": [lsort $cmds]"
	    }
	}
    }
    return -code error "invalid command name \"$name\""
}

# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them.  If so, it sources the appropriate
# library file to create the procedure.  Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments: 
# cmd -			Name of the command to find and load.
# namespace (optional)  The namespace where the command is being used - must be
#                       a canonical namespace as returned [namespace current]
#                       for instance. If not given, namespace current is used.

proc auto_load {cmd {namespace {}}} {
    global auto_index auto_path

    if {[string length $namespace] == 0} {
	set namespace [uplevel 1 [list ::namespace current]]
    }
    set nameList [auto_qualify $cmd $namespace]
    # workaround non canonical auto_index entries that might be around
    # from older auto_mkindex versions
    lappend nameList $cmd
    foreach name $nameList {







>
|




|



|

|


>
|
>
>
>


|

|

|






|
>
>
>



|







>
>
>
>
>
>
>
>




|




|
>
>
>


<
<
<
<
|
<




















|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425




426

427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
		if {$errorInfo ne "$einfo$expect"} {
		    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
			[list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
		}
		return -code error -errorcode $errorCode \
			-errorinfo $einfo $msg
	    } else {
		dict incr opts -level
		return -options $opts $msg
	    }
	}
    }

    if {([info level] == 1) && ([info script] eq "") \
	    && [info exists tcl_interactive] && $tcl_interactive} {
	if {![info exists auto_noexec]} {
	    set new [auto_execok $name]
	    if {$new ne ""} {
		set redir ""
		if {[namespace which -command console] eq ""} {
		    set redir ">&@stdout <@stdin"
		}
		uplevel 1 [list ::catch \
			[concat exec $redir $new [lrange $args 1 end]] \
			::tcl::UnknownResult ::tcl::UnknownOptions]
		dict incr ::tcl::UnknownOptions -level
		return -options $::tcl::UnknownOptions $::tcl::UnknownResult
	    }
	}
	if {$name eq "!!"} {
	    set newcmd [history event]
	} elseif {[regexp {^!(.+)$} $name -> event]} {
	    set newcmd [history event $event]
	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
	    set newcmd [history event -1]
	    catch {regsub -all -- $old $newcmd $new newcmd}
	}
	if {[info exists newcmd]} {
	    tclLog $newcmd
	    history change $newcmd 0
	    uplevel 1 [list ::catch $newcmd \
		    ::tcl::UnknownResult ::tcl::UnknownOptions]
	    dict incr ::tcl::UnknownOptions -level
	    return -options $::tcl::UnknownOptions $::tcl::UnknownResult
	}

	set ret [catch {set candidates [info commands $name*]} msg]
	if {$name eq "::"} {
	    set name ""
	}
	if {$ret != 0} {
	    dict append opts -errorinfo \
		    "\n    (expanding command prefix \"$name\" in unknown)"
	    return -options $opts $msg
	}
	# Handle empty $name separately due to strangeness in [string first]
	if {$name eq ""} {
	    if {[llength $candidates] != 1} {
		return -code error "empty command name \"\""
	    }
	    # It's not really possible to reach here.
	    return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
	}
	# Filter out bogus matches when $name contained
	# a glob-special char [Bug 946952]
	set cmds [list]
	foreach x $candidates {
	    if {[string first $name $x] == 0} {
		lappend cmds $x
	    }
	}
	if {[llength $cmds] == 1} {
	    uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \
		    ::tcl::UnknownResult ::tcl::UnknownOptions]
	    dict incr ::tcl::UnknownOptions -level
	    return -options $::tcl::UnknownOptions $::tcl::UnknownResult
	}
	if {[llength $cmds]} {




	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"

	}
    }
    return -code error "invalid command name \"$name\""
}

# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them.  If so, it sources the appropriate
# library file to create the procedure.  Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments: 
# cmd -			Name of the command to find and load.
# namespace (optional)  The namespace where the command is being used - must be
#                       a canonical namespace as returned [namespace current]
#                       for instance. If not given, namespace current is used.

proc auto_load {cmd {namespace {}}} {
    global auto_index auto_path

    if {$namespace eq ""} {
	set namespace [uplevel 1 [list ::namespace current]]
    }
    set nameList [auto_qualify $cmd $namespace]
    # workaround non canonical auto_index entries that might be around
    # from older auto_mkindex versions
    lappend nameList $cmd
    foreach name $nameList {
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
# Arguments: 
# None.

proc auto_load_index {} {
    variable ::tcl::auto_oldpath
    global auto_index auto_path

    if {[info exists auto_oldpath] && \
	    [string equal $auto_oldpath $auto_path]} {
	return 0
    }
    set auto_oldpath $auto_path

    # Check if we are a safe interpreter. In that case, we support only
    # newer format tclIndex files.

    set issafe [interp issafe]
    for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
	set dir [lindex $auto_path $i]
	set f ""
	if {$issafe} {
	    catch {source [file join $dir tclIndex]}
	} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
	    continue
	} else {
	    set error [catch {
		set id [gets $f]
		if {[string equal $id \
			"# Tcl autoload index file, version 2.0"]} {
		    eval [read $f]
		} elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
		    while {[gets $f line] >= 0} {
			if {[string equal [string index $line 0] "#"] \
				|| ([llength $line] != 2)} {
			    continue
			}
			set name [lindex $line 0]
			set auto_index($name) \
				"source [file join $dir [lindex $line 1]]"
		    }
		} else {
		    error "[file join $dir tclIndex] isn't a proper Tcl index file"
		}
	    } msg opts]
	    if {$f != ""} {
		close $f
	    }
	    if {$error} {
		return -options $opts $msg
	    }
	}
    }







|
<


















<
|

|

|











|







493
494
495
496
497
498
499
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
# Arguments: 
# None.

proc auto_load_index {} {
    variable ::tcl::auto_oldpath
    global auto_index auto_path

    if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {

	return 0
    }
    set auto_oldpath $auto_path

    # Check if we are a safe interpreter. In that case, we support only
    # newer format tclIndex files.

    set issafe [interp issafe]
    for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
	set dir [lindex $auto_path $i]
	set f ""
	if {$issafe} {
	    catch {source [file join $dir tclIndex]}
	} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
	    continue
	} else {
	    set error [catch {
		set id [gets $f]

		if {$id eq "# Tcl autoload index file, version 2.0"} {
		    eval [read $f]
		} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"]} {
		    while {[gets $f line] >= 0} {
			if {([string index $line 0] eq "#") \
				|| ([llength $line] != 2)} {
			    continue
			}
			set name [lindex $line 0]
			set auto_index($name) \
				"source [file join $dir [lindex $line 1]]"
		    }
		} else {
		    error "[file join $dir tclIndex] isn't a proper Tcl index file"
		}
	    } msg opts]
	    if {$f ne ""} {
		close $f
	    }
	    if {$error} {
		return -options $opts $msg
	    }
	}
    }
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
    # Ignore namespace if the name starts with ::
    # Handle special case of only leading ::

    # Before each return case we give an example of which category it is
    # with the following form :
    # ( inputCmd, inputNameSpace) -> output

    if {[regexp {^::(.*)$} $cmd x tail]} {
	if {$n > 1} {
	    # ( ::foo::bar , * ) -> ::foo::bar
	    return [list $cmd]
	} else {
	    # ( ::global , * ) -> global
	    return [list $tail]
	}
    }
    
    # Potentially returning 2 elements to try  :
    # (if the current namespace is not the global one)

    if {$n == 0} {
	if {[string equal $namespace ::]} {
	    # ( nocolons , :: ) -> nocolons
	    return [list $cmd]
	} else {
	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
	    return [list ${namespace}::$cmd $cmd]
	}
    } elseif {[string equal $namespace ::]} {
	#  ( foo::bar , :: ) -> ::foo::bar
	return [list ::$cmd]
    } else {
	# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
	return [list ${namespace}::$cmd ::$cmd]
    }
}







|





|







|






|







567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
    # Ignore namespace if the name starts with ::
    # Handle special case of only leading ::

    # Before each return case we give an example of which category it is
    # with the following form :
    # ( inputCmd, inputNameSpace) -> output

    if {[string match ::* $cmd]} {
	if {$n > 1} {
	    # ( ::foo::bar , * ) -> ::foo::bar
	    return [list $cmd]
	} else {
	    # ( ::global , * ) -> global
	    return [list [string range $cmd 2 end]]
	}
    }
    
    # Potentially returning 2 elements to try  :
    # (if the current namespace is not the global one)

    if {$n == 0} {
	if {$namespace eq "::"} {
	    # ( nocolons , :: ) -> nocolons
	    return [list $cmd]
	} else {
	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
	    return [list ${namespace}::$cmd $cmd]
	}
    } elseif {$namespace eq "::"} {
	#  ( foo::bar , :: ) -> ::foo::bar
	return [list ::$cmd]
    } else {
	# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
	return [list ${namespace}::$cmd ::$cmd]
    }
}
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
# Windows search path, or "" otherwise.  Builds an associative 
# array auto_execs that caches information about previous checks, 
# for speed.
#
# Arguments: 
# name -			Name of a command.

if {[string equal windows $tcl_platform(platform)]} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions.  Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
    global auto_execs env tcl_platform

    if {[info exists auto_execs($name)]} {
	return $auto_execs($name)
    }
    set auto_execs($name) ""

    set shellBuiltins [list cls copy date del erase dir echo mkdir \
	    md rename ren rmdir rd time type ver vol]
    if {[string equal $tcl_platform(os) "Windows NT"]} {
	# NT includes the 'start' built-in
	lappend shellBuiltins "start"
    }
    if {[info exists env(PATHEXT)]} {
	# Add an initial ; to have the {} extension check first.
	set execExtensions [split ";$env(PATHEXT)" ";"]
    } else {
	set execExtensions [list {} .com .exe .bat]
    }

    if {[lsearch -exact $shellBuiltins $name] != -1} {
	# When this is command.com for some reason on Win2K, Tcl won't
	# exec it unless the case is right, which this corrects.  COMSPEC
	# may not point to a real file, so do the check.
	set cmd $env(COMSPEC)
	if {[file exists $cmd]} {
	    set cmd [file attributes $cmd -shortname]
	}







|

















|










|







643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
# Windows search path, or "" otherwise.  Builds an associative 
# array auto_execs that caches information about previous checks, 
# for speed.
#
# Arguments: 
# name -			Name of a command.

if {$tcl_platform(platform) eq "windows"} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions.  Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
    global auto_execs env tcl_platform

    if {[info exists auto_execs($name)]} {
	return $auto_execs($name)
    }
    set auto_execs($name) ""

    set shellBuiltins [list cls copy date del erase dir echo mkdir \
	    md rename ren rmdir rd time type ver vol]
    if {$tcl_platform(os) eq "Windows NT"} {
	# NT includes the 'start' built-in
	lappend shellBuiltins "start"
    }
    if {[info exists env(PATHEXT)]} {
	# Add an initial ; to have the {} extension check first.
	set execExtensions [split ";$env(PATHEXT)" ";"]
    } else {
	set execExtensions [list {} .com .exe .bat]
    }

    if {$name in $shellBuiltins} {
	# When this is command.com for some reason on Win2K, Tcl won't
	# exec it unless the case is right, which this corrects.  COMSPEC
	# may not point to a real file, so do the check.
	set cmd $env(COMSPEC)
	if {[file exists $cmd]} {
	    set cmd [file attributes $cmd -shortname]
	}
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
    }

    set path "[file dirname [info nameof]];.;"
    if {[info exists env(WINDIR)]} {
	set windir $env(WINDIR) 
    }
    if {[info exists windir]} {
	if {[string equal $tcl_platform(os) "Windows NT"]} {
	    append path "$windir/system32;"
	}
	append path "$windir/system;$windir;"
    }

    foreach var {PATH Path path} {
	if {[info exists env($var)]} {
	    append path ";$env($var)"
	}
    }

    foreach dir [split $path {;}] {
	# Skip already checked directories
	if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
	set checked($dir) {}
	foreach ext $execExtensions {
	    set file [file join $dir ${name}${ext}]
	    if {[file exists $file] && ![file isdirectory $file]} {
		return [set auto_execs($name) [list $file]]
	    }
	}







|













|







698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
    }

    set path "[file dirname [info nameof]];.;"
    if {[info exists env(WINDIR)]} {
	set windir $env(WINDIR) 
    }
    if {[info exists windir]} {
	if {$tcl_platform(os) eq "Windows NT"} {
	    append path "$windir/system32;"
	}
	append path "$windir/system;$windir;"
    }

    foreach var {PATH Path path} {
	if {[info exists env($var)]} {
	    append path ";$env($var)"
	}
    }

    foreach dir [split $path {;}] {
	# Skip already checked directories
	if {[info exists checked($dir)] || ($dir eq {})} { continue }
	set checked($dir) {}
	foreach ext $execExtensions {
	    set file [file join $dir ${name}${ext}]
	    if {[file exists $file] && ![file isdirectory $file]} {
		return [set auto_execs($name) [list $file]]
	    }
	}
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
    if {[llength [file split $name]] != 1} {
	if {[file executable $name] && ![file isdirectory $name]} {
	    set auto_execs($name) [list $name]
	}
	return $auto_execs($name)
    }
    foreach dir [split $env(PATH) :] {
	if {[string equal $dir ""]} {
	    set dir .
	}
	set file [file join $dir $name]
	if {[file executable $file] && ![file isdirectory $file]} {
	    set auto_execs($name) [list $file]
	    return $auto_execs($name)
	}







|







741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
    if {[llength [file split $name]] != 1} {
	if {[file executable $name] && ![file isdirectory $name]} {
	    set auto_execs($name) [list $name]
	}
	return $auto_execs($name)
    }
    foreach dir [split $env(PATH) :] {
	if {$dir eq ""} {
	    set dir .
	}
	set file [file join $dir $name]
	if {[file executable $file] && ![file isdirectory $file]} {
	    set auto_execs($name) [list $file]
	    return $auto_execs($name)
	}
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
# action -              "renaming" or "copying" 
# src -			source directory
# dest -		destination directory
proc tcl::CopyDirectory {action src dest} {
    set nsrc [file normalize $src]
    set ndest [file normalize $dest]

    if {[string equal $action "renaming"]} {
	# Can't rename volumes.  We could give a more precise
	# error message here, but that would break the test suite.
	if {[lsearch -exact [file volumes] $nsrc] != -1} {
	    return -code error "error $action \"$src\" to\
	      \"$dest\": trying to rename a volume or move a directory\
	      into itself"
	}
    }
    if {[file exists $dest]} {
	if {$nsrc == $ndest} {
	    return -code error "error $action \"$src\" to\
	      \"$dest\": trying to rename a volume or move a directory\
	      into itself"
	}
	if {[string equal $action "copying"]} {
	    # We used to throw an error here, but, looking more closely
	    # at the core copy code in tclFCmd.c, if the destination
	    # exists, then we should only call this function if -force
	    # is true, which means we just want to over-write.  So,
	    # the following code is now commented out.
	    # 
	    # return -code error "error $action \"$src\" to\
	    # \"$dest\": file already exists"
	} else {
	    # Depending on the platform, and on the current
	    # working directory, the directories '.', '..'
	    # can be returned in various combinations.  Anyway,
	    # if any other file is returned, we must signal an error.
	    set existing [glob -nocomplain -directory $dest * .*]
	    eval [list lappend existing] \
	      [glob -nocomplain -directory $dest -type hidden * .*]
	    foreach s $existing {
		if {([file tail $s] != ".") && ([file tail $s] != "..")} {
		    return -code error "error $action \"$src\" to\
		      \"$dest\": file already exists"
		}
	    }
	}
    } else {
	if {[string first $nsrc $ndest] != -1} {
	    set srclen [expr {[llength [file split $nsrc]] -1}]
	    set ndest [lindex [file split $ndest] $srclen]
	    if {$ndest == [file tail $nsrc]} {
		return -code error "error $action \"$src\" to\
		  \"$dest\": trying to rename a volume or move a directory\
		  into itself"
	    }
	}
	file mkdir $dest
    }
    # Have to be careful to capture both visible and hidden files.
    # We will also be more generous to the file system and not
    # assume the hidden and non-hidden lists are non-overlapping.
    # 
    # On Unix 'hidden' files begin with '.'.  On other platforms
    # or filesystems hidden files may have other interpretations.
    set filelist [concat [glob -nocomplain -directory $src *] \
      [glob -nocomplain -directory $src -types hidden *]]

    foreach s [lsort -unique $filelist] {
	if {([file tail $s] != ".") && ([file tail $s] != "..")} {
	    file copy -force $s [file join $dest [file tail $s]]
	}
    }
    return
}

# Set up the 'clock' ensemble

if { ![interp issafe] } {

    namespace eval ::tcl::clock \
	[list variable TclLibDir [file dirname [info script]]]

    namespace eval ::tcl::clock {
	namespace ensemble create -command ::clock \
	    -subcommands {
		add clicks format 
		microseconds milliseconds 
		scan seconds
	    }
	
	# Auto-loading stub for 'clock.tcl'
	
	proc add args {
	    variable TclLibDir
	    source -encoding utf-8 [file join $TclLibDir clock.tcl]
	    return [uplevel 1 [info level 0]]
	}
	proc format args {
	    variable TclLibDir
	    source -encoding utf-8 [file join $TclLibDir clock.tcl]
	    return [uplevel 1 [info level 0]]
	}
	proc scan args {
	    variable TclLibDir
	    source -encoding utf-8 [file join $TclLibDir clock.tcl]
	    return [uplevel 1 [info level 0]]
	}
    }
}

# Set up search for Tcl Modules (TIP #189).

if { ![interp issafe] } {
    source [file join [file dirname [info script]] tm.tcl]
}







|


|






|




|














|
|

|









|

















|





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846









































# action -              "renaming" or "copying" 
# src -			source directory
# dest -		destination directory
proc tcl::CopyDirectory {action src dest} {
    set nsrc [file normalize $src]
    set ndest [file normalize $dest]

    if {$action eq "renaming"} {
	# Can't rename volumes.  We could give a more precise
	# error message here, but that would break the test suite.
	if {$nsrc in [file volumes]} {
	    return -code error "error $action \"$src\" to\
	      \"$dest\": trying to rename a volume or move a directory\
	      into itself"
	}
    }
    if {[file exists $dest]} {
	if {$nsrc eq $ndest} {
	    return -code error "error $action \"$src\" to\
	      \"$dest\": trying to rename a volume or move a directory\
	      into itself"
	}
	if {$action eq "copying"} {
	    # We used to throw an error here, but, looking more closely
	    # at the core copy code in tclFCmd.c, if the destination
	    # exists, then we should only call this function if -force
	    # is true, which means we just want to over-write.  So,
	    # the following code is now commented out.
	    # 
	    # return -code error "error $action \"$src\" to\
	    # \"$dest\": file already exists"
	} else {
	    # Depending on the platform, and on the current
	    # working directory, the directories '.', '..'
	    # can be returned in various combinations.  Anyway,
	    # if any other file is returned, we must signal an error.
	    set existing [glob -nocomplain -directory $dest * .*]
	    lappend existing {expand}[glob -nocomplain -directory $dest \
		    -type hidden * .*]
	    foreach s $existing {
		if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
		    return -code error "error $action \"$src\" to\
		      \"$dest\": file already exists"
		}
	    }
	}
    } else {
	if {[string first $nsrc $ndest] != -1} {
	    set srclen [expr {[llength [file split $nsrc]] -1}]
	    set ndest [lindex [file split $ndest] $srclen]
	    if {$ndest eq [file tail $nsrc]} {
		return -code error "error $action \"$src\" to\
		  \"$dest\": trying to rename a volume or move a directory\
		  into itself"
	    }
	}
	file mkdir $dest
    }
    # Have to be careful to capture both visible and hidden files.
    # We will also be more generous to the file system and not
    # assume the hidden and non-hidden lists are non-overlapping.
    # 
    # On Unix 'hidden' files begin with '.'.  On other platforms
    # or filesystems hidden files may have other interpretations.
    set filelist [concat [glob -nocomplain -directory $src *] \
      [glob -nocomplain -directory $src -types hidden *]]

    foreach s [lsort -unique $filelist] {
	if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
	    file copy -force $s [file join $dest [file tail $s]]
	}
    }
    return
}









































Deleted library/ldAout.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
# ldAout.tcl --
#
#	This "tclldAout" procedure in this script acts as a replacement
#	for the "ld" command when linking an object file that will be
#	loaded dynamically into Tcl or Tk using pseudo-static linking.
#
# Parameters:
#	The arguments to the script are the command line options for
#	an "ld" command.
#
# Results:
#	The "ld" command is parsed, and the "-o" option determines the
#	module name.  ".a" and ".o" options are accumulated.
#	The input archives and object files are examined with the "nm"
#	command to determine whether the modules initialization
#	entry and safe initialization entry are present.  A trivial
#	C function that locates the entries is composed, compiled, and
#	its .o file placed before all others in the command; then
#	"ld" is executed to bind the objects together.
#
# RCS: @(#) $Id: ldAout.tcl,v 1.6 2003/03/19 21:57:42 dgp Exp $
#
# Copyright (c) 1995, by General Electric Company. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This work was supported in part by the ARPA Manufacturing Automation
# and Design Engineering (MADE) Initiative through ARPA contract
# F33615-94-C-4400.

proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
    global env
    global argv

    if {[string equal $cc ""]} {
	set cc $env(CC)
    }

    # if only two parameters are supplied there is assumed that the
    # only shlib_suffix is missing. This parameter is anyway available
    # as "info sharedlibextension" too, so there is no need to transfer
    # 3 parameters to the function tclLdAout. For compatibility, this
    # function now accepts both 2 and 3 parameters.

    if {[string equal $shlib_suffix ""]} {
	set shlib_cflags $env(SHLIB_CFLAGS)
    } elseif {[string equal $shlib_cflags "none"]} {
	set shlib_cflags $shlib_suffix
    }

    # seenDotO is nonzero if a .o or .a file has been seen
    set seenDotO 0

    # minusO is nonzero if the last command line argument was "-o".
    set minusO 0

    # head has command line arguments up to but not including the first
    # .o or .a file. tail has the rest of the arguments.
    set head {}
    set tail {}

    # nmCommand is the "nm" command that lists global symbols from the
    # object files.
    set nmCommand {|nm -g}

    # entryProtos is the table of _Init and _SafeInit prototypes found in the
    # module.
    set entryProtos {}

    # entryPoints is the table of _Init and _SafeInit entries found in the
    # module.
    set entryPoints {}

    # libraries is the list of -L and -l flags to the linker.
    set libraries {}
    set libdirs {}

    # Process command line arguments
    foreach a $argv {
	if {!$minusO && [regexp {\.[ao]$} $a]} {
	    set seenDotO 1
	    lappend nmCommand $a
	}
	if {$minusO} {
	    set outputFile $a
	    set minusO 0
	} elseif {![string compare $a -o]} {
	    set minusO 1
	}
	if {[string match -nocase "-l*" $a]} {
	    lappend libraries $a
	    if {[string match "-L*" $a]} {
		lappend libdirs [string range $a 2 end]
	    }
	} elseif {$seenDotO} {
	    lappend tail $a
	} else {
	    lappend head $a
	}
    }
    lappend libdirs /lib /usr/lib

    # MIPS -- If there are corresponding G0 libraries, replace the
    # ordinary ones with the G0 ones.

    set libs {}
    foreach lib $libraries {
	if {[string match "-l*" $lib]} {
	    set lname [string range $lib 2 end]
	    foreach dir $libdirs {
		if {[file exists [file join $dir lib${lname}_G0.a]]} {
		    set lname ${lname}_G0
		    break
		}
	    }
	    lappend libs -l$lname
	} else {
	    lappend libs $lib
	}
    }
    set libraries $libs

    # Extract the module name from the "-o" option

    if {![info exists outputFile]} {
	error "-o option must be supplied to link a Tcl load module"
    }
    set m [file tail $outputFile]
    if {[regexp {\.a$} $outputFile]} {
	set shlib_suffix .a
    } else {
	set shlib_suffix ""
    }
    if {[regexp {\..*$} $outputFile match]} {
	set l [expr {[string length $m] - [string length $match]}]
    } else {
	error "Output file does not appear to have a suffix"
    }
    set modName [string tolower $m 0 [expr {$l-1}]]
    if {[string match "lib*" $modName]} {
	set modName [string range $modName 3 end]
    }
    if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
	set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
    }
    set modName [string totitle $modName]

    # Catalog initialization entry points found in the module

    set f [open $nmCommand r]
    while {[gets $f l] >= 0} {
	if {[regexp {T[ 	]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
	    if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
		set s $symbol
	    }
	    append entryProtos {extern int } $symbol { (); } \n
	    append entryPoints {  } \{ { "} $s {", } $symbol { } \} , \n
	}
    }
    close $f

    if {[string equal $entryPoints ""]} {
	error "No entry point found in objects"
    }

    # Compose a C function that resolves the initialization entry points and
    # embeds the required libraries in the object code.

    set C {#include <string.h>}
    append C \n
    append C {char TclLoadLibraries_} $modName { [] =} \n
    append C {  "@LIBS: } $libraries {";} \n
    append C $entryProtos
    append C {static struct } \{ \n
    append C {  char * name;} \n
    append C {  int (*value)();} \n
    append C \} {dictionary [] = } \{ \n
    append C $entryPoints
    append C {  0, 0 } \n \} \; \n
    append C {typedef struct Tcl_Interp Tcl_Interp;} \n
    append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
    append C {Tcl_PackageInitProc *} \n
    append C TclLoadDictionary_ $modName { (symbol)} \n
    append C {    CONST char * symbol;} \n
    append C {
	{
	    int i;
	    for (i = 0; dictionary [i] . name != 0; ++i) {
		if (!strcmp (symbol, dictionary [i] . name)) {
		    return dictionary [i].value;
		}
	    }
	    return 0;
	}
    }
    append C \n


    # Write the C module and compile it

    set cFile tcl$modName.c
    set f [open $cFile w]
    puts -nonewline $f $C
    close $f
    set ccCommand "$cc -c $shlib_cflags $cFile"
    puts stderr $ccCommand
    eval exec $ccCommand

    # Now compose and execute the ld command that packages the module

    if {[string equal $shlib_suffix ".a"]} {
	set ldCommand "ar cr $outputFile"
	regsub { -o} $tail {} tail
    } else {
	set ldCommand ld
	foreach item $head {
	    lappend ldCommand $item
	}
    }
    lappend ldCommand tcl$modName.o
    foreach item $tail {
	lappend ldCommand $item
    }
    puts stderr $ldCommand
    eval exec $ldCommand
    if {[string equal $shlib_suffix ".a"]} {
	exec ranlib $outputFile
    }

    # Clean up working files
    exec /bin/rm $cFile [file rootname $cFile].o
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































Deleted library/msgs/af_ZA.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/af_za.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Deleted library/msgs/ar_IN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y"
    ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S  %z %z"
}
<
<
<
<
<
<












Deleted library/msgs/ar_JO.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_JO MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_JO MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































Deleted library/msgs/ar_LB.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_LB MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_LB MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































Deleted library/msgs/ar_SY.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_SY MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_SY MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631\u0627\u0646"\
        "\u062d\u0632\u064a\u0631"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































Added library/msgs/ar_in.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y"
    ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S  %z %z"
}

Added library/msgs/ar_jo.msg.















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_JO MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_JO MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}

Added library/msgs/ar_lb.msg.















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_LB MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_LB MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}

Added library/msgs/ar_sy.msg.















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_SY MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_SY MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631\u0627\u0646"\
        "\u062d\u0632\u064a\u0631"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}

Deleted library/msgs/bn_IN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y"
    ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S  %z %z"
}
<
<
<
<
<
<












Added library/msgs/bn_in.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y"
    ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S  %z %z"
}

Deleted library/msgs/de_AT.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset de_AT MONTHS_ABBREV [list \
        "J\u00e4n"\
        "Feb"\
        "M\u00e4r"\
        "Apr"\
        "Mai"\
        "Jun"\
        "Jul"\
        "Aug"\
        "Sep"\
        "Okt"\
        "Nov"\
        "Dez"\
        ""]
    ::msgcat::mcset de_AT MONTHS_FULL [list \
        "J\u00e4nner"\
        "Februar"\
        "M\u00e4rz"\
        "April"\
        "Mai"\
        "Juni"\
        "Juli"\
        "August"\
        "September"\
        "Oktober"\
        "November"\
        "Dezember"\
        ""]
    ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset de_AT TIME_FORMAT "%T"
    ::msgcat::mcset de_AT TIME_FORMAT_12 "%T"
    ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































Deleted library/msgs/de_BE.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \
        "Son"\
        "Mon"\
        "Die"\
        "Mit"\
        "Don"\
        "Fre"\
        "Sam"]
    ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \
        "Sonntag"\
        "Montag"\
        "Dienstag"\
        "Mittwoch"\
        "Donnerstag"\
        "Freitag"\
        "Samstag"]
    ::msgcat::mcset de_BE MONTHS_ABBREV [list \
        "Jan"\
        "Feb"\
        "M\u00e4r"\
        "Apr"\
        "Mai"\
        "Jun"\
        "Jul"\
        "Aug"\
        "Sep"\
        "Okt"\
        "Nov"\
        "Dez"\
        ""]
    ::msgcat::mcset de_BE MONTHS_FULL [list \
        "Januar"\
        "Februar"\
        "M\u00e4rz"\
        "April"\
        "Mai"\
        "Juni"\
        "Juli"\
        "August"\
        "September"\
        "Oktober"\
        "November"\
        "Dezember"\
        ""]
    ::msgcat::mcset de_BE AM "vorm"
    ::msgcat::mcset de_BE PM "nachm"
    ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset de_BE TIME_FORMAT "%T"
    ::msgcat::mcset de_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































Added library/msgs/de_at.msg.







































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset de_AT MONTHS_ABBREV [list \
        "J\u00e4n"\
        "Feb"\
        "M\u00e4r"\
        "Apr"\
        "Mai"\
        "Jun"\
        "Jul"\
        "Aug"\
        "Sep"\
        "Okt"\
        "Nov"\
        "Dez"\
        ""]
    ::msgcat::mcset de_AT MONTHS_FULL [list \
        "J\u00e4nner"\
        "Februar"\
        "M\u00e4rz"\
        "April"\
        "Mai"\
        "Juni"\
        "Juli"\
        "August"\
        "September"\
        "Oktober"\
        "November"\
        "Dezember"\
        ""]
    ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset de_AT TIME_FORMAT "%T"
    ::msgcat::mcset de_AT TIME_FORMAT_12 "%T"
    ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Added library/msgs/de_be.msg.











































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \
        "Son"\
        "Mon"\
        "Die"\
        "Mit"\
        "Don"\
        "Fre"\
        "Sam"]
    ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \
        "Sonntag"\
        "Montag"\
        "Dienstag"\
        "Mittwoch"\
        "Donnerstag"\
        "Freitag"\
        "Samstag"]
    ::msgcat::mcset de_BE MONTHS_ABBREV [list \
        "Jan"\
        "Feb"\
        "M\u00e4r"\
        "Apr"\
        "Mai"\
        "Jun"\
        "Jul"\
        "Aug"\
        "Sep"\
        "Okt"\
        "Nov"\
        "Dez"\
        ""]
    ::msgcat::mcset de_BE MONTHS_FULL [list \
        "Januar"\
        "Februar"\
        "M\u00e4rz"\
        "April"\
        "Mai"\
        "Juni"\
        "Juli"\
        "August"\
        "September"\
        "Oktober"\
        "November"\
        "Dezember"\
        ""]
    ::msgcat::mcset de_BE AM "vorm"
    ::msgcat::mcset de_BE PM "nachm"
    ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset de_BE TIME_FORMAT "%T"
    ::msgcat::mcset de_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/en_AU.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z"
    ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/en_BE.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z"
    ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/en_BW.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/en_CA.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_CA TIME_FORMAT "%r"
    ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p"
    ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/en_GB.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_GB TIME_FORMAT "%T"
    ::msgcat::mcset en_GB TIME_FORMAT_12 "%T"
    ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/en_HK.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_HK AM "AM"
    ::msgcat::mcset en_HK PM "PM"
    ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y"
    ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<
<
<
















Deleted library/msgs/en_IE.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_IE TIME_FORMAT "%T"
    ::msgcat::mcset en_IE TIME_FORMAT_12 "%T"
    ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/en_IN.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_IN AM "AM"
    ::msgcat::mcset en_IN PM "PM"
    ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z"
}
<
<
<
<
<
<
<
<
















Deleted library/msgs/en_NZ.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z"
    ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/en_PH.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_PH AM "AM"
    ::msgcat::mcset en_PH PM "PM"
    ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y"
    ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<
<
<
















Deleted library/msgs/en_SG.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z"
}
<
<
<
<
<
<












Deleted library/msgs/en_ZA.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S"
    ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z"
}
<
<
<
<
<
<












Deleted library/msgs/en_ZW.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/en_au.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z"
    ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z"
}

Added library/msgs/en_be.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z"
    ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z"
}

Added library/msgs/en_bw.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Added library/msgs/en_ca.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_CA TIME_FORMAT "%r"
    ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p"
    ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z"
}

Added library/msgs/en_gb.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_GB TIME_FORMAT "%T"
    ::msgcat::mcset en_GB TIME_FORMAT_12 "%T"
    ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Added library/msgs/en_hk.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_HK AM "AM"
    ::msgcat::mcset en_HK PM "PM"
    ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y"
    ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z"
}

Added library/msgs/en_ie.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_IE TIME_FORMAT "%T"
    ::msgcat::mcset en_IE TIME_FORMAT_12 "%T"
    ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Added library/msgs/en_in.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_IN AM "AM"
    ::msgcat::mcset en_IN PM "PM"
    ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z"
}

Added library/msgs/en_nz.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z"
    ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z"
}

Added library/msgs/en_ph.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_PH AM "AM"
    ::msgcat::mcset en_PH PM "PM"
    ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y"
    ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z"
}

Added library/msgs/en_sg.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z"
}

Added library/msgs/en_za.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S"
    ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z"
}

Added library/msgs/en_zw.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Deleted library/msgs/es_AR.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_BO.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_CL.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_CO.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_CR.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_DO.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y"
    ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_EC.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_GT.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_HN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_MX.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_NI.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_PA.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y"
    ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_PE.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_PR.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_PY.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_SV.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_UY.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Deleted library/msgs/es_VE.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/es_ar.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z"
}

Added library/msgs/es_bo.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z"
}

Added library/msgs/es_cl.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z"
}

Added library/msgs/es_co.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_cr.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_do.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y"
    ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_ec.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_gt.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_hn.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

Added library/msgs/es_mx.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_ni.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

Added library/msgs/es_pa.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y"
    ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_pe.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_pr.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

Added library/msgs/es_py.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_sv.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

Added library/msgs/es_uy.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Added library/msgs/es_ve.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Deleted library/msgs/eu_ES.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da"
    ::msgcat::mcset eu_ES TIME_FORMAT "%T"
    ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T"
    ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/eu_es.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da"
    ::msgcat::mcset eu_ES TIME_FORMAT "%T"
    ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T"
    ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z"
}

Deleted library/msgs/fa_IN.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \
        "\u06cc\u2214"\
        "\u062f\u2214"\
        "\u0633\u2214"\
        "\u0686\u2214"\
        "\u067e\u2214"\
        "\u062c\u2214"\
        "\u0634\u2214"]
    ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \
        "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\
        "\u062f\u0648\u0634\u0646\u0628\u0647"\
        "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\
        "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\
        "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\
        "\u062c\u0645\u0639\u0647"\
        "\u0634\u0646\u0628\u0647"]
    ::msgcat::mcset fa_IN MONTHS_ABBREV [list \
        "\u0698\u0627\u0646"\
        "\u0641\u0648\u0631"\
        "\u0645\u0627\u0631"\
        "\u0622\u0648\u0631"\
        "\u0645\u0640\u0647"\
        "\u0698\u0648\u0646"\
        "\u0698\u0648\u06cc"\
        "\u0627\u0648\u062a"\
        "\u0633\u067e\u062a"\
        "\u0627\u0643\u062a"\
        "\u0646\u0648\u0627"\
        "\u062f\u0633\u0627"\
        ""]
    ::msgcat::mcset fa_IN MONTHS_FULL [list \
        "\u0698\u0627\u0646\u0648\u06cc\u0647"\
        "\u0641\u0648\u0631\u0648\u06cc\u0647"\
        "\u0645\u0627\u0631\u0633"\
        "\u0622\u0648\u0631\u06cc\u0644"\
        "\u0645\u0647"\
        "\u0698\u0648\u0626\u0646"\
        "\u0698\u0648\u0626\u06cc\u0647"\
        "\u0627\u0648\u062a"\
        "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\
        "\u0627\u0643\u062a\u0628\u0631"\
        "\u0646\u0648\u0627\u0645\u0628\u0631"\
        "\u062f\u0633\u0627\u0645\u0628\u0631"\
        ""]
    ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d"
    ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631"
    ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y"
    ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S  %z %z"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Deleted library/msgs/fa_IR.msg.

1
2
3
4
5
6
7
8
9
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d"
    ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631"
    ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y"
    ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H"
    ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P"
    ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z"
}
<
<
<
<
<
<
<
<
<


















Added library/msgs/fa_in.msg.









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \
        "\u06cc\u2214"\
        "\u062f\u2214"\
        "\u0633\u2214"\
        "\u0686\u2214"\
        "\u067e\u2214"\
        "\u062c\u2214"\
        "\u0634\u2214"]
    ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \
        "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\
        "\u062f\u0648\u0634\u0646\u0628\u0647"\
        "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\
        "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\
        "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\
        "\u062c\u0645\u0639\u0647"\
        "\u0634\u0646\u0628\u0647"]
    ::msgcat::mcset fa_IN MONTHS_ABBREV [list \
        "\u0698\u0627\u0646"\
        "\u0641\u0648\u0631"\
        "\u0645\u0627\u0631"\
        "\u0622\u0648\u0631"\
        "\u0645\u0640\u0647"\
        "\u0698\u0648\u0646"\
        "\u0698\u0648\u06cc"\
        "\u0627\u0648\u062a"\
        "\u0633\u067e\u062a"\
        "\u0627\u0643\u062a"\
        "\u0646\u0648\u0627"\
        "\u062f\u0633\u0627"\
        ""]
    ::msgcat::mcset fa_IN MONTHS_FULL [list \
        "\u0698\u0627\u0646\u0648\u06cc\u0647"\
        "\u0641\u0648\u0631\u0648\u06cc\u0647"\
        "\u0645\u0627\u0631\u0633"\
        "\u0622\u0648\u0631\u06cc\u0644"\
        "\u0645\u0647"\
        "\u0698\u0648\u0626\u0646"\
        "\u0698\u0648\u0626\u06cc\u0647"\
        "\u0627\u0648\u062a"\
        "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\
        "\u0627\u0643\u062a\u0628\u0631"\
        "\u0646\u0648\u0627\u0645\u0628\u0631"\
        "\u062f\u0633\u0627\u0645\u0628\u0631"\
        ""]
    ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d"
    ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631"
    ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y"
    ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S  %z %z"
}

Added library/msgs/fa_ir.msg.



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d"
    ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631"
    ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y"
    ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H"
    ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P"
    ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z"
}

Deleted library/msgs/fo_FO.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fo_FO DATE_FORMAT "%d/%m-%Y"
    ::msgcat::mcset fo_FO TIME_FORMAT "%T"
    ::msgcat::mcset fo_FO TIME_FORMAT_12 "%T"
    ::msgcat::mcset fo_FO DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/fo_fo.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fo_FO DATE_FORMAT "%d/%m-%Y"
    ::msgcat::mcset fo_FO TIME_FORMAT "%T"
    ::msgcat::mcset fo_FO TIME_FORMAT_12 "%T"
    ::msgcat::mcset fo_FO DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/fr_BE.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fr_BE DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset fr_BE TIME_FORMAT "%T"
    ::msgcat::mcset fr_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset fr_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/fr_CA.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fr_CA DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset fr_CA TIME_FORMAT "%T"
    ::msgcat::mcset fr_CA TIME_FORMAT_12 "%T"
    ::msgcat::mcset fr_CA DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/fr_CH.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fr_CH DATE_FORMAT "%d. %m. %y"
    ::msgcat::mcset fr_CH TIME_FORMAT "%T"
    ::msgcat::mcset fr_CH TIME_FORMAT_12 "%T"
    ::msgcat::mcset fr_CH DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/fr_be.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fr_BE DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset fr_BE TIME_FORMAT "%T"
    ::msgcat::mcset fr_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset fr_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Added library/msgs/fr_ca.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fr_CA DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset fr_CA TIME_FORMAT "%T"
    ::msgcat::mcset fr_CA TIME_FORMAT_12 "%T"
    ::msgcat::mcset fr_CA DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Added library/msgs/fr_ch.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fr_CH DATE_FORMAT "%d. %m. %y"
    ::msgcat::mcset fr_CH TIME_FORMAT "%T"
    ::msgcat::mcset fr_CH TIME_FORMAT_12 "%T"
    ::msgcat::mcset fr_CH DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/ga_IE.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ga_IE DATE_FORMAT "%d.%m.%y"
    ::msgcat::mcset ga_IE TIME_FORMAT "%T"
    ::msgcat::mcset ga_IE TIME_FORMAT_12 "%T"
    ::msgcat::mcset ga_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/ga_ie.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ga_IE DATE_FORMAT "%d.%m.%y"
    ::msgcat::mcset ga_IE TIME_FORMAT "%T"
    ::msgcat::mcset ga_IE TIME_FORMAT_12 "%T"
    ::msgcat::mcset ga_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/gl_ES.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset gl_ES DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset gl_ES TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset gl_ES DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/gl_es.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset gl_ES DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset gl_ES TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset gl_ES DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Deleted library/msgs/gv_GB.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset gv_GB DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset gv_GB TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset gv_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/gv_gb.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset gv_GB DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset gv_GB TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset gv_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Deleted library/msgs/hi_IN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset hi_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset hi_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset hi_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/hi_in.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset hi_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset hi_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset hi_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}

Deleted library/msgs/id_ID.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset id_ID DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset id_ID TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset id_ID DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/id_id.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset id_ID DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset id_ID TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset id_ID DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Deleted library/msgs/it_CH.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset it_CH DATE_FORMAT "%e. %B %Y"
    ::msgcat::mcset it_CH TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset it_CH DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z"
}
<
<
<
<
<
<












Added library/msgs/it_ch.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset it_CH DATE_FORMAT "%e. %B %Y"
    ::msgcat::mcset it_CH TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset it_CH DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z"
}

Deleted library/msgs/kl_GL.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset kl_GL DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset kl_GL TIME_FORMAT "%T"
    ::msgcat::mcset kl_GL TIME_FORMAT_12 "%T"
    ::msgcat::mcset kl_GL DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/kl_gl.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset kl_GL DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset kl_GL TIME_FORMAT "%T"
    ::msgcat::mcset kl_GL TIME_FORMAT_12 "%T"
    ::msgcat::mcset kl_GL DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/ko_KR.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804"
    ::msgcat::mcset ko_KR CE "\uc11c\uae30"
    ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d"
    ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S"
    ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z"
}
<
<
<
<
<
<
<
<
















Added library/msgs/ko_kr.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804"
    ::msgcat::mcset ko_KR CE "\uc11c\uae30"
    ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d"
    ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S"
    ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z"
}

Deleted library/msgs/kok_IN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset kok_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset kok_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset kok_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/kok_in.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset kok_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset kok_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset kok_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}

Deleted library/msgs/kw_GB.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset kw_GB DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset kw_GB TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset kw_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/kw_gb.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset kw_GB DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset kw_GB TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset kw_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

Deleted library/msgs/mr_IN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset mr_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset mr_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset mr_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/mr_in.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset mr_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset mr_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset mr_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}

Deleted library/msgs/ms_MY.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ms_MY DATE_FORMAT "%A %d %b %Y"
    ::msgcat::mcset ms_MY TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset ms_MY DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S  %z %z"
}
<
<
<
<
<
<












Added library/msgs/ms_my.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ms_MY DATE_FORMAT "%A %d %b %Y"
    ::msgcat::mcset ms_MY TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset ms_MY DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S  %z %z"
}

Deleted library/msgs/nl_BE.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset nl_BE DATE_FORMAT "%d-%m-%y"
    ::msgcat::mcset nl_BE TIME_FORMAT "%T"
    ::msgcat::mcset nl_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset nl_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/nl_be.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset nl_BE DATE_FORMAT "%d-%m-%y"
    ::msgcat::mcset nl_BE TIME_FORMAT "%T"
    ::msgcat::mcset nl_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset nl_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/pt_BR.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset pt_BR DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset pt_BR TIME_FORMAT "%T"
    ::msgcat::mcset pt_BR TIME_FORMAT_12 "%T"
    ::msgcat::mcset pt_BR DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}
<
<
<
<
<
<
<














Added library/msgs/pt_br.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset pt_BR DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset pt_BR TIME_FORMAT "%T"
    ::msgcat::mcset pt_BR TIME_FORMAT_12 "%T"
    ::msgcat::mcset pt_BR DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

Deleted library/msgs/ru_UA.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ru_UA DATE_FORMAT "%d.%m.%Y"
    ::msgcat::mcset ru_UA TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset ru_UA DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z"
}
<
<
<
<
<
<












Added library/msgs/ru_ua.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ru_UA DATE_FORMAT "%d.%m.%Y"
    ::msgcat::mcset ru_UA TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset ru_UA DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z"
}

Deleted library/msgs/ta_IN.msg.

1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ta_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset ta_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset ta_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}
<
<
<
<
<
<












Added library/msgs/ta_in.msg.













>
>
>
>
>
>
1
2
3
4
5
6
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ta_IN DATE_FORMAT "%d %M %Y"
    ::msgcat::mcset ta_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset ta_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z"
}

Deleted library/msgs/te_IN.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28"
    ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28"
    ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}
<
<
<
<
<
<
<
<
















Added library/msgs/te_in.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28"
    ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28"
    ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

Deleted library/msgs/zh_CN.msg.

1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e"
    ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2"
    ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z"
}
<
<
<
<
<
<
<














Deleted library/msgs/zh_HK.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \
        "\u65e5"\
        "\u4e00"\
        "\u4e8c"\
        "\u4e09"\
        "\u56db"\
        "\u4e94"\
        "\u516d"]
    ::msgcat::mcset zh_HK MONTHS_ABBREV [list \
        "1\u6708"\
        "2\u6708"\
        "3\u6708"\
        "4\u6708"\
        "5\u6708"\
        "6\u6708"\
        "7\u6708"\
        "8\u6708"\
        "9\u6708"\
        "10\u6708"\
        "11\u6708"\
        "12\u6708"\
        ""]
    ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5"
    ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S"
    ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































Deleted library/msgs/zh_SG.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_SG AM "\u4e0a\u5348"
    ::msgcat::mcset zh_SG PM "\u4e2d\u5348"
    ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z"
}
<
<
<
<
<
<
<
<
















Deleted library/msgs/zh_TW.msg.

1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d"
    ::msgcat::mcset zh_TW CE "\u6c11\u570b"
    ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e"
    ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z"
}
<
<
<
<
<
<
<
<
















Added library/msgs/zh_cn.msg.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e"
    ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2"
    ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z"
}

Added library/msgs/zh_hk.msg.

























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \
        "\u65e5"\
        "\u4e00"\
        "\u4e8c"\
        "\u4e09"\
        "\u56db"\
        "\u4e94"\
        "\u516d"]
    ::msgcat::mcset zh_HK MONTHS_ABBREV [list \
        "1\u6708"\
        "2\u6708"\
        "3\u6708"\
        "4\u6708"\
        "5\u6708"\
        "6\u6708"\
        "7\u6708"\
        "8\u6708"\
        "9\u6708"\
        "10\u6708"\
        "11\u6708"\
        "12\u6708"\
        ""]
    ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5"
    ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S"
    ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z"
}

Added library/msgs/zh_sg.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_SG AM "\u4e0a\u5348"
    ::msgcat::mcset zh_SG PM "\u4e2d\u5348"
    ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z"
}

Added library/msgs/zh_tw.msg.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d"
    ::msgcat::mcset zh_TW CE "\u6c11\u570b"
    ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e"
    ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z"
}

Changes to library/package.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.32 2004/08/02 22:01:38 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#





|







1
2
3
4
5
6
7
8
9
10
11
12
13
# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.32.2.1 2005/08/02 18:16:15 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
#		Defaults to [info sharedlibextension]
#
# Results:
#  Returns 1 if the extension matches, 0 otherwise

proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
    global tcl_platform
    if {![string length $ext]} {set ext [info sharedlibextension]}
    if {[string equal $tcl_platform(platform) "windows"]} {
        return [string equal -nocase [file extension $fileName] $ext]
    } else {
        # Some unices add trailing numbers after the .so, so
        # we could have something like '.so.1.2'.
        set root $fileName
        while {1} {
            set currExt [file extension $root]
            if {[string equal $currExt $ext]} {
                return 1
            } 

	    # The current extension does not match; if it is not a numeric
	    # value, quit, as we are only looking to ignore version number
	    # extensions.  Otherwise we might return 1 in this case:
	    #		tcl::Pkg::CompareExtension foo.so.bar .so







|
|







|







27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
#		Defaults to [info sharedlibextension]
#
# Results:
#  Returns 1 if the extension matches, 0 otherwise

proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
    global tcl_platform
    if {$ext eq ""} {set ext [info sharedlibextension]}
    if {$tcl_platform(platform) eq "windows"} {
        return [string equal -nocase [file extension $fileName] $ext]
    } else {
        # Some unices add trailing numbers after the .so, so
        # we could have something like '.so.1.2'.
        set root $fileName
        while {1} {
            set currExt [file extension $root]
            if {$currExt eq $ext} {
                return 1
            } 

	    # The current extension does not match; if it is not a numeric
	    # value, quit, as we are only looking to ignore version number
	    # extensions.  Otherwise we might return 1 in this case:
	    #		tcl::Pkg::CompareExtension foo.so.bar .so
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    set dir [lindex $args $idx]
    set patternList [lrange $args [expr {$idx + 1}] end]
    if {[llength $patternList] == 0} {
	set patternList [list "*.tcl" "*[info sharedlibextension]"]
    }

    if {[catch {
	    glob -directory $dir -tails -types {r f} {expand}$patternList
    } fileList o]} {
	return -options $o $fileList
    }
    foreach file $fileList {
	# For each file, figure out what commands and packages it provides.
	# To do this, create a child interpreter, load the file into the
	# interpreter, and get a list of the new commands and packages
	# that are defined.

	if {[string equal $file pkgIndex.tcl]} {
	    continue
	}

	set c [interp create]

	# Load into the child any packages currently loaded in the parent
	# interpreter that match the -load pattern.

	if {[string length $loadPat]} {
	    if {$doVerbose} {
		tclLog "currently loaded packages: '[info loaded]'"
		tclLog "trying to load all packages matching $loadPat"
	    }
	    if {![llength [info loaded]]} {
		tclLog "warning: no packages are currently loaded, nothing"
		tclLog "can possibly match '$loadPat'"







|









|








|







131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    set dir [lindex $args $idx]
    set patternList [lrange $args [expr {$idx + 1}] end]
    if {[llength $patternList] == 0} {
	set patternList [list "*.tcl" "*[info sharedlibextension]"]
    }

    if {[catch {
	    glob -directory $dir -tails -types {r f} -- {expand}$patternList
    } fileList o]} {
	return -options $o $fileList
    }
    foreach file $fileList {
	# For each file, figure out what commands and packages it provides.
	# To do this, create a child interpreter, load the file into the
	# interpreter, and get a list of the new commands and packages
	# that are defined.

	if {$file eq "pkgIndex.tcl"} {
	    continue
	}

	set c [interp create]

	# Load into the child any packages currently loaded in the parent
	# interpreter that match the -load pattern.

	if {$loadPat ne ""} {
	    if {$doVerbose} {
		tclLog "currently loaded packages: '[info loaded]'"
		tclLog "trying to load all packages matching $loadPat"
	    }
	    if {![llength [info loaded]]} {
		tclLog "warning: no packages are currently loaded, nothing"
		tclLog "can possibly match '$loadPat'"
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
	    } err]} {
		if {$doVerbose} {
		    tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
		}
	    } elseif {$doVerbose} {
		tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
	    }
	    if {[string equal [lindex $pkg 1] "Tk"]} {
		# Withdraw . if Tk was loaded, to avoid showing a window.
		$c eval [list wm withdraw .]
	    }
	}

	$c eval {
	    # Stub out the package command so packages can







|







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
	    } err]} {
		if {$doVerbose} {
		    tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
		}
	    } elseif {$doVerbose} {
		tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
	    }
	    if {[lindex $pkg 1] eq "Tk"} {
		# Withdraw . if Tk was loaded, to avoid showing a window.
		$c eval [list wm withdraw .]
	    }
	}

	$c eval {
	    # Stub out the package command so packages can
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273

		# init the list of existing namespaces, packages, commands

		foreach ::tcl::x [::tcl::GetAllNamespaces] {
		    set ::tcl::namespaces($::tcl::x) 1
		}
		foreach ::tcl::x [package names] {
		    if {[string compare [package provide $::tcl::x] ""]} {
			set ::tcl::packages($::tcl::x) 1
		    }
		}
		set ::tcl::origCmds [info commands]

		# Try to load the file if it has the shared library
		# extension, otherwise source it.  It's important not to







|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273

		# init the list of existing namespaces, packages, commands

		foreach ::tcl::x [::tcl::GetAllNamespaces] {
		    set ::tcl::namespaces($::tcl::x) 1
		}
		foreach ::tcl::x [package names] {
		    if {[package provide $::tcl::x] ne ""} {
			set ::tcl::packages($::tcl::x) 1
		    }
		}
		set ::tcl::origCmds [info commands]

		# Try to load the file if it has the shared library
		# extension, otherwise source it.  It's important not to
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348

			# Figure out what commands appeared
			
			foreach ::tcl::x [info commands] {
			    set ::tcl::newCmds($::tcl::x) 1
			}
			foreach ::tcl::x $::tcl::origCmds {
			    catch {unset ::tcl::newCmds($::tcl::x)}
			}
			foreach ::tcl::x [array names ::tcl::newCmds] {
			    # determine which namespace a command comes from
			    
			    set ::tcl::abs [namespace origin $::tcl::x]
			    
			    # special case so that global names have no leading
			    # ::, this is required by the unknown command
			    
			    set ::tcl::abs \
				    [lindex [auto_qualify $::tcl::abs ::] 0]
			    
			    if {[string compare $::tcl::x $::tcl::abs]} {
				# Name changed during qualification
				
				set ::tcl::newCmds($::tcl::abs) 1
				unset ::tcl::newCmds($::tcl::x)
			    }
			}
		    }
		}

		# Look through the packages that appeared, and if there is
		# a version provided, then record it

		foreach ::tcl::x [package names] {
		    if {[string compare [package provide $::tcl::x] ""] \
			    && ![info exists ::tcl::packages($::tcl::x)]} {
			lappend ::tcl::newPkgs \
			    [list $::tcl::x [package provide $::tcl::x]]
		    }
		}
	    }
	} msg] == 1} {







|












|













|







307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348

			# Figure out what commands appeared
			
			foreach ::tcl::x [info commands] {
			    set ::tcl::newCmds($::tcl::x) 1
			}
			foreach ::tcl::x $::tcl::origCmds {
			    unset -nocomplain ::tcl::newCmds($::tcl::x)
			}
			foreach ::tcl::x [array names ::tcl::newCmds] {
			    # determine which namespace a command comes from
			    
			    set ::tcl::abs [namespace origin $::tcl::x]
			    
			    # special case so that global names have no leading
			    # ::, this is required by the unknown command
			    
			    set ::tcl::abs \
				    [lindex [auto_qualify $::tcl::abs ::] 0]
			    
			    if {$::tcl::x ne $::tcl::abs} {
				# Name changed during qualification
				
				set ::tcl::newCmds($::tcl::abs) 1
				unset ::tcl::newCmds($::tcl::x)
			    }
			}
		    }
		}

		# Look through the packages that appeared, and if there is
		# a version provided, then record it

		foreach ::tcl::x [package names] {
		    if {[package provide $::tcl::x] ne ""
			    && ![info exists ::tcl::packages($::tcl::x)]} {
			lappend ::tcl::newPkgs \
			    [list $::tcl::x [package provide $::tcl::x]]
		    }
		}
	    }
	} msg] == 1} {
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
    global auto_index

    package provide $pkg $version
    foreach fileInfo $files {
	set f [lindex $fileInfo 0]
	set type [lindex $fileInfo 1]
	foreach cmd [lindex $fileInfo 2] {
	    if {[string equal $type "load"]} {
		set auto_index($cmd) [list load [file join $dir $f] $pkg]
	    } else {
		set auto_index($cmd) [list source [file join $dir $f]]
	    } 
	}
    }
}







|







433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
    global auto_index

    package provide $pkg $version
    foreach fileInfo $files {
	set f [lindex $fileInfo 0]
	set type [lindex $fileInfo 1]
	foreach cmd [lindex $fileInfo 2] {
	    if {$type eq "load"} {
		set auto_index($cmd) [list load [file join $dir $f] $pkg]
	    } else {
		set auto_index($cmd) [list source [file join $dir $f]]
	    } 
	}
    }
}

Changes to library/parray.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
# parray:
# Print the contents of a global array on stdout.
#
# RCS: @(#) $Id: parray.tcl,v 1.3 1998/09/14 18:40:03 stanton Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

proc parray {a {pattern *}} {
    upvar 1 $a array
    if {![array exists array]} {
	error "\"$a\" isn't an array"
    }
    set maxl 0
    foreach name [lsort [array names array $pattern]] {

	if {[string length $name] > $maxl} {
	    set maxl [string length $name]
	}
    }
    set maxl [expr {$maxl + [string length $a] + 2}]
    foreach name [lsort [array names array $pattern]] {
	set nameString [format %s(%s) $a $name]
	puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
    }
}



|














|
>





|




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
# parray:
# Print the contents of a global array on stdout.
#
# RCS: @(#) $Id: parray.tcl,v 1.3.44.1 2005/07/12 20:37:06 kennykb Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

proc parray {a {pattern *}} {
    upvar 1 $a array
    if {![array exists array]} {
	error "\"$a\" isn't an array"
    }
    set maxl 0
    set names [lsort [array names array $pattern]]
    foreach name $names {
	if {[string length $name] > $maxl} {
	    set maxl [string length $name]
	}
    }
    set maxl [expr {$maxl + [string length $a] + 2}]
    foreach name $names {
	set nameString [format %s(%s) $a $name]
	puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
    }
}

Changes to library/safe.tcl.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# See the safe.n man page for details.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.tcl,v 1.14 2004/06/29 09:34:44 dkf Exp $

#
# The implementation is based on namespaces. These naming conventions
# are followed:
# Private procs starts with uppercase.
# Public  procs are exported and starts with lowercase
#







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# See the safe.n man page for details.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.tcl,v 1.14.2.1 2005/08/02 18:16:15 dgp Exp $

#
# The implementation is based on namespaces. These naming conventions
# are followed:
# Private procs starts with uppercase.
# Public  procs are exported and starts with lowercase
#
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
    # Helper function to resolve the dual way of specifying staticsok
    # (either by -noStatics or -statics 0)
    proc InterpStatics {} {
	foreach v {Args statics noStatics} {
	    upvar $v $v
	}
	set flag [::tcl::OptProcArgGiven -noStatics];
	if {$flag && ($noStatics == $statics) 
	          && ([::tcl::OptProcArgGiven -statics])} {
	    return -code error\
		    "conflicting values given for -statics and -noStatics"
	}
	if {$flag} {
	    return [expr {!$noStatics}]
	} else {
	    return $statics
	}
    }

    # Helper function to resolve the dual way of specifying nested loading
    # (either by -nestedLoadOk or -nested 1)
    proc InterpNested {} {
	foreach v {Args nested nestedLoadOk} {
	    upvar $v $v
	}
	set flag [::tcl::OptProcArgGiven -nestedLoadOk];
	# note that the test here is the opposite of the "InterpStatics"
	# one (it is not -noNested... because of the wanted default value)
	if {$flag && ($nestedLoadOk != $nested) 
	          && ([::tcl::OptProcArgGiven -nested])} {
	    return -code error\
		    "conflicting values given for -nested and -nestedLoadOk"
	}
	if {$flag} {
	    # another difference with "InterpStatics"
	    return $nestedLoadOk







|




















|







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
    # Helper function to resolve the dual way of specifying staticsok
    # (either by -noStatics or -statics 0)
    proc InterpStatics {} {
	foreach v {Args statics noStatics} {
	    upvar $v $v
	}
	set flag [::tcl::OptProcArgGiven -noStatics];
	if {$flag && (!$noStatics == !$statics) 
	          && ([::tcl::OptProcArgGiven -statics])} {
	    return -code error\
		    "conflicting values given for -statics and -noStatics"
	}
	if {$flag} {
	    return [expr {!$noStatics}]
	} else {
	    return $statics
	}
    }

    # Helper function to resolve the dual way of specifying nested loading
    # (either by -nestedLoadOk or -nested 1)
    proc InterpNested {} {
	foreach v {Args nested nestedLoadOk} {
	    upvar $v $v
	}
	set flag [::tcl::OptProcArgGiven -nestedLoadOk];
	# note that the test here is the opposite of the "InterpStatics"
	# one (it is not -noNested... because of the wanted default value)
	if {$flag && (!$nestedLoadOk != !$nested) 
	          && ([::tcl::OptProcArgGiven -nested])} {
	    return -code error\
		    "conflicting values given for -nested and -nestedLoadOk"
	}
	if {$flag} {
	    # another difference with "InterpStatics"
	    return $nestedLoadOk
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
    #    you probably need to call "auto_reset" in the slave in order that it
    #    gets the right auto_index() array values.

    proc ::safe::InterpSetConfig {slave access_path staticsok\
	    nestedok deletehook} {

	# determine and store the access path if empty
	if {[string equal "" $access_path]} {
	    set access_path [uplevel \#0 set auto_path]
	    # Make sure that tcl_library is in auto_path
	    # and at the first position (needed by setAccessPath)
	    set where [lsearch -exact $access_path [info library]]
	    if {$where == -1} {
		# not found, add it.
		set access_path [concat [list [info library]] $access_path]







|







320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
    #    you probably need to call "auto_reset" in the slave in order that it
    #    gets the right auto_index() array values.

    proc ::safe::InterpSetConfig {slave access_path staticsok\
	    nestedok deletehook} {

	# determine and store the access path if empty
	if {$access_path eq ""} {
	    set access_path [uplevel \#0 set auto_path]
	    # Make sure that tcl_library is in auto_path
	    # and at the first position (needed by setAccessPath)
	    set where [lsearch -exact $access_path [info library]]
	    if {$where == -1} {
		# not found, add it.
		set access_path [concat [list [info library]] $access_path]
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788

	# package name (can be empty if file is not).
	set package [lindex $args 0]

	# Determine where to load. load use a relative interp path
	# and {} means self, so we can directly and safely use passed arg.
	set target [lindex $args 1]
	if {[string length $target]} {
	    # we will try to load into a sub sub interp
	    # check that we want to authorize that.
	    if {![NestedOk $slave]} {
		Log $slave "loading to a sub interp (nestedok)\
			disabled (trying to load $package to $target)"
		return -code error "permission denied (nested load)"
	    }
	    
	}

	# Determine what kind of load is requested
	if {[string length $file] == 0} {
	    # static package loading
	    if {[string length $package] == 0} {
		set msg "load error: empty filename and no package name"
		Log $slave $msg
		return -code error $msg
	    }
	    if {![StaticsOk $slave]} {
		Log $slave "static packages loading disabled\
			(trying to load $package to $target)"







|











|

|







760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788

	# package name (can be empty if file is not).
	set package [lindex $args 0]

	# Determine where to load. load use a relative interp path
	# and {} means self, so we can directly and safely use passed arg.
	set target [lindex $args 1]
	if {$target ne ""} {
	    # we will try to load into a sub sub interp
	    # check that we want to authorize that.
	    if {![NestedOk $slave]} {
		Log $slave "loading to a sub interp (nestedok)\
			disabled (trying to load $package to $target)"
		return -code error "permission denied (nested load)"
	    }
	    
	}

	# Determine what kind of load is requested
	if {$file eq ""} {
	    # static package loading
	    if {$package eq ""} {
		set msg "load error: empty filename and no package name"
		Log $slave $msg
		return -code error $msg
	    }
	    if {![StaticsOk $slave]} {
		Log $slave "static packages loading disabled\
			(trying to load $package to $target)"
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856

    # This procedure enables access from a safe interpreter to only a subset of
    # the subcommands of a command:

    proc Subset {slave command okpat args} {
	set subcommand [lindex $args 0]
	if {[regexp $okpat $subcommand]} {
	    return [$command $subcommand {expand}[lrange $args 1 end]]
	}
	set msg "not allowed to invoke subcommand $subcommand of $command"
	Log $slave $msg
	error $msg
    }

    # This procedure installs an alias in a slave that invokes "safesubset"







|







842
843
844
845
846
847
848
849
850
851
852
853
854
855
856

    # This procedure enables access from a safe interpreter to only a subset of
    # the subcommands of a command:

    proc Subset {slave command okpat args} {
	set subcommand [lindex $args 0]
	if {[regexp $okpat $subcommand]} {
	    return [$command {expand}$args]
	}
	set msg "not allowed to invoke subcommand $subcommand of $command"
	Log $slave $msg
	error $msg
    }

    # This procedure installs an alias in a slave that invokes "safesubset"
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895

	set argc [llength $args]

	set okpat "^(name.*|convert.*)\$"
	set subcommand [lindex $args 0]

	if {[regexp $okpat $subcommand]} {
	    return [::interp invokehidden $slave encoding $subcommand \
		    {expand}[lrange $args 1 end]]
	}

	if {[string match $subcommand system]} {
	    if {$argc == 1} {
		# passed all the tests , lets source it:
		if {[catch {::interp invokehidden \
			$slave encoding system} msg]} {
		    Log $slave $msg
		    return -code error "script error"
		}







|
<


|







877
878
879
880
881
882
883
884

885
886
887
888
889
890
891
892
893
894

	set argc [llength $args]

	set okpat "^(name.*|convert.*)\$"
	set subcommand [lindex $args 0]

	if {[regexp $okpat $subcommand]} {
	    return [::interp invokehidden $slave encoding {expand}$args]

	}

	if {[string first $subcommand system] == 0} {
	    if {$argc == 1} {
		# passed all the tests , lets source it:
		if {[catch {::interp invokehidden \
			$slave encoding system} msg]} {
		    Log $slave $msg
		    return -code error "script error"
		}

Changes to library/tclIndex.

70
71
72
73
74
75
76

77
78
79
80
81





set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]

set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]












>





>
>
>
>
>
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]

Changes to library/tcltest/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded tcltest 2.2.7 [list source [file join $dir tcltest.tcl]]











|
1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded tcltest 2.2.8 [list source [file join $dir tcltest.tcl]]

Changes to library/tcltest/tcltest.tcl.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.93 2004/11/02 19:03:29 dgp Exp $

package require Tcl 8.3		;# uses [glob -directory]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.2.7

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]








|







|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.93.2.1 2005/03/09 15:57:18 kennykb Exp $

package require Tcl 8.3		;# uses [glob -directory]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.2.8

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

2565
2566
2567
2568
2569
2570
2571
2572

2573
2574
2575
2576
2577
2578
2579

2580
2581
2582
2583
2584
2585
2586
    set matchingFiles [list]
    foreach directory $dirList {

	# List files in $directory that match patterns to run.
	set matchFileList [list]
	foreach match [matchFiles] {
	    set matchFileList [concat $matchFileList \
		    [glob -directory $directory -nocomplain -- $match]]

	}

	# List files in $directory that match patterns to skip.
	set skipFileList [list]
	foreach skip [skipFiles] {
	    set skipFileList [concat $skipFileList \
		    [glob -directory $directory -nocomplain -- $skip]]

	}

	# Add to result list all files in match list and not in skip list
	foreach file $matchFileList {
	    if {[lsearch -exact $skipFileList $file] == -1} {
		lappend matchingFiles $file
	    }







|
>






|
>







2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
    set matchingFiles [list]
    foreach directory $dirList {

	# List files in $directory that match patterns to run.
	set matchFileList [list]
	foreach match [matchFiles] {
	    set matchFileList [concat $matchFileList \
		    [glob -directory $directory -types {b c f p s} \
		    -nocomplain -- $match]]
	}

	# List files in $directory that match patterns to skip.
	set skipFileList [list]
	foreach skip [skipFiles] {
	    set skipFileList [concat $skipFileList \
		    [glob -directory $directory -types {b c f p s} \
		    -nocomplain -- $skip]]
	}

	# Add to result list all files in match list and not in skip list
	foreach file $matchFileList {
	    if {[lsearch -exact $skipFileList $file] == -1} {
		lappend matchingFiles $file
	    }
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
proc tcltest::GetMatchingDirectories {rootdir} {

    # Determine the skip list first, to avoid [glob]-ing over subdirectories
    # we're going to throw away anyway.  Be sure we skip the $rootdir if it
    # comes up to avoid infinite loops.
    set skipDirs [list $rootdir]
    foreach pattern [skipDirectories] {
	foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
	    if {[file isdirectory $path]} {
		lappend skipDirs $path
	    }
	}
    }

    # Now step through the matching directories, prune out the skipped ones
    # as you go.
    set matchDirs [list]
    foreach pattern [matchDirectories] {
	foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
	    if {[file isdirectory $path]} {
		if {[lsearch -exact $skipDirs $path] == -1} {
		    set matchDirs [concat $matchDirs \
			    [GetMatchingDirectories $path]]
		    if {[file exists [file join $path all.tcl]]} {
			lappend matchDirs $path
		    }
		}
	    }
	}
    }

    if {[llength $matchDirs] == 0} {
	DebugPuts 1 "No test directories remain after applying match\







|
|
<
<
<






|
|
|
|
<
|
|
<







2616
2617
2618
2619
2620
2621
2622
2623
2624



2625
2626
2627
2628
2629
2630
2631
2632
2633
2634

2635
2636

2637
2638
2639
2640
2641
2642
2643
proc tcltest::GetMatchingDirectories {rootdir} {

    # Determine the skip list first, to avoid [glob]-ing over subdirectories
    # we're going to throw away anyway.  Be sure we skip the $rootdir if it
    # comes up to avoid infinite loops.
    set skipDirs [list $rootdir]
    foreach pattern [skipDirectories] {
	set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
		-nocomplain -- $pattern]]



    }

    # Now step through the matching directories, prune out the skipped ones
    # as you go.
    set matchDirs [list]
    foreach pattern [matchDirectories] {
	foreach path [glob -directory $rootdir -types d -nocomplain -- \
		$pattern] {
	    if {[lsearch -exact $skipDirs $path] == -1} {
		set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]

		if {[file exists [file join $path all.tcl]]} {
		    lappend matchDirs $path

		}
	    }
	}
    }

    if {[llength $matchDirs] == 0} {
	DebugPuts 1 "No test directories remain after applying match\

Changes to library/tm.tcl.

349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
proc ::tcl::tm::roots {paths} {
    foreach {major minor} [split [info tclversion] .] break
    foreach pa $paths {
	set p [file join $pa tcl$major]
	for {set n $minor} {$n >= 0} {incr n -1} {
	    path add [file normalize [file join $p ${major}.${n}]]
	}
	path add [file normalize [file join $pa site-tcl]]
    }
    return
}

# Initialization. Set up the default paths, then insert the new
# handler into the chain.

::tcl::tm::Defaults
package unknown [list ::tcl::tm::UnknownHandler [package unknown]]







|








<
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364

proc ::tcl::tm::roots {paths} {
    foreach {major minor} [split [info tclversion] .] break
    foreach pa $paths {
	set p [file join $pa tcl$major]
	for {set n $minor} {$n >= 0} {incr n -1} {
	    path add [file normalize [file join $p ${major}.${n}]]
	}
	path add [file normalize [file join $p site-tcl]]
    }
    return
}

# Initialization. Set up the default paths, then insert the new
# handler into the chain.

::tcl::tm::Defaults

Changes to library/tzdata/Africa/Timbuktu.

1


2
3
4
5
6
# created by ../tools/tclZIC.tcl - do not edit



set TZData(:Africa/Timbuktu) {
    {-9223372036854775808 -724 0 LMT}
    {-1830383276 0 0 GMT}
}

>
>
|
|
<
<
<
1
2
3
4
5



# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Africa/Bamako)]} {
    LoadTimeZoneFile Africa/Bamako
}
set TZData(:Africa/Timbuktu) $TZData(:Africa/Bamako)



Changes to library/tzdata/Africa/Tunis.

24
25
26
27
28
29
30


31
    {276048000 3600 0 CET}
    {581126400 7200 1 CEST}
    {591148800 3600 0 CET}
    {606873600 7200 1 CEST}
    {622598400 3600 0 CET}
    {641520000 7200 1 CEST}
    {654652800 3600 0 CET}


}







>
>

24
25
26
27
28
29
30
31
32
33
    {276048000 3600 0 CET}
    {581126400 7200 1 CEST}
    {591148800 3600 0 CET}
    {606873600 7200 1 CEST}
    {622598400 3600 0 CET}
    {641520000 7200 1 CEST}
    {654652800 3600 0 CET}
    {1114905600 7200 1 CEST}
    {1128042000 3600 0 CET}
}

Changes to library/tzdata/America/Adak.

83
84
85
86
87
88
89
90
91
92
93
94


95


96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175


176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198


199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
    {1067166000 -36000 0 HAST}
    {1081080000 -32400 1 HADT}
    {1099220400 -36000 0 HAST}
    {1112529600 -32400 1 HADT}
    {1130670000 -36000 0 HAST}
    {1143979200 -32400 1 HADT}
    {1162119600 -36000 0 HAST}
    {1175428800 -32400 1 HADT}
    {1193569200 -36000 0 HAST}
    {1207483200 -32400 1 HADT}
    {1225018800 -36000 0 HAST}
    {1238932800 -32400 1 HADT}


    {1256468400 -36000 0 HAST}


    {1270382400 -32400 1 HADT}
    {1288522800 -36000 0 HAST}
    {1301832000 -32400 1 HADT}
    {1319972400 -36000 0 HAST}
    {1333281600 -32400 1 HADT}
    {1351422000 -36000 0 HAST}
    {1365336000 -32400 1 HADT}
    {1382871600 -36000 0 HAST}
    {1396785600 -32400 1 HADT}
    {1414321200 -36000 0 HAST}
    {1428235200 -32400 1 HADT}
    {1445770800 -36000 0 HAST}
    {1459684800 -32400 1 HADT}
    {1477825200 -36000 0 HAST}
    {1491134400 -32400 1 HADT}
    {1509274800 -36000 0 HAST}
    {1522584000 -32400 1 HADT}
    {1540724400 -36000 0 HAST}
    {1554638400 -32400 1 HADT}
    {1572174000 -36000 0 HAST}
    {1586088000 -32400 1 HADT}
    {1603623600 -36000 0 HAST}
    {1617537600 -32400 1 HADT}
    {1635678000 -36000 0 HAST}
    {1648987200 -32400 1 HADT}
    {1667127600 -36000 0 HAST}
    {1680436800 -32400 1 HADT}
    {1698577200 -36000 0 HAST}
    {1712491200 -32400 1 HADT}
    {1730026800 -36000 0 HAST}
    {1743940800 -32400 1 HADT}
    {1761476400 -36000 0 HAST}
    {1775390400 -32400 1 HADT}
    {1792926000 -36000 0 HAST}
    {1806840000 -32400 1 HADT}
    {1824980400 -36000 0 HAST}
    {1838289600 -32400 1 HADT}
    {1856430000 -36000 0 HAST}
    {1869739200 -32400 1 HADT}
    {1887879600 -36000 0 HAST}
    {1901793600 -32400 1 HADT}
    {1919329200 -36000 0 HAST}
    {1933243200 -32400 1 HADT}
    {1950778800 -36000 0 HAST}
    {1964692800 -32400 1 HADT}
    {1982833200 -36000 0 HAST}
    {1996142400 -32400 1 HADT}
    {2014282800 -36000 0 HAST}
    {2027592000 -32400 1 HADT}
    {2045732400 -36000 0 HAST}
    {2059041600 -32400 1 HADT}
    {2077182000 -36000 0 HAST}
    {2091096000 -32400 1 HADT}
    {2108631600 -36000 0 HAST}
    {2122545600 -32400 1 HADT}
    {2140081200 -36000 0 HAST}
    {2153995200 -32400 1 HADT}
    {2172135600 -36000 0 HAST}
    {2185444800 -32400 1 HADT}
    {2203585200 -36000 0 HAST}
    {2216894400 -32400 1 HADT}
    {2235034800 -36000 0 HAST}
    {2248948800 -32400 1 HADT}
    {2266484400 -36000 0 HAST}
    {2280398400 -32400 1 HADT}
    {2297934000 -36000 0 HAST}
    {2311848000 -32400 1 HADT}
    {2329383600 -36000 0 HAST}
    {2343297600 -32400 1 HADT}
    {2361438000 -36000 0 HAST}
    {2374747200 -32400 1 HADT}
    {2392887600 -36000 0 HAST}
    {2406196800 -32400 1 HADT}
    {2424337200 -36000 0 HAST}
    {2438251200 -32400 1 HADT}
    {2455786800 -36000 0 HAST}
    {2469700800 -32400 1 HADT}
    {2487236400 -36000 0 HAST}
    {2501150400 -32400 1 HADT}
    {2519290800 -36000 0 HAST}


    {2532600000 -32400 1 HADT}
    {2550740400 -36000 0 HAST}
    {2564049600 -32400 1 HADT}
    {2582190000 -36000 0 HAST}
    {2596104000 -32400 1 HADT}
    {2613639600 -36000 0 HAST}
    {2627553600 -32400 1 HADT}
    {2645089200 -36000 0 HAST}
    {2659003200 -32400 1 HADT}
    {2676538800 -36000 0 HAST}
    {2690452800 -32400 1 HADT}
    {2708593200 -36000 0 HAST}
    {2721902400 -32400 1 HADT}
    {2740042800 -36000 0 HAST}
    {2753352000 -32400 1 HADT}
    {2771492400 -36000 0 HAST}
    {2785406400 -32400 1 HADT}
    {2802942000 -36000 0 HAST}
    {2816856000 -32400 1 HADT}
    {2834391600 -36000 0 HAST}
    {2848305600 -32400 1 HADT}
    {2866446000 -36000 0 HAST}
    {2879755200 -32400 1 HADT}


    {2897895600 -36000 0 HAST}
    {2911204800 -32400 1 HADT}
    {2929345200 -36000 0 HAST}
    {2942654400 -32400 1 HADT}
    {2960794800 -36000 0 HAST}
    {2974708800 -32400 1 HADT}
    {2992244400 -36000 0 HAST}
    {3006158400 -32400 1 HADT}
    {3023694000 -36000 0 HAST}
    {3037608000 -32400 1 HADT}
    {3055748400 -36000 0 HAST}
    {3069057600 -32400 1 HADT}
    {3087198000 -36000 0 HAST}
    {3100507200 -32400 1 HADT}
    {3118647600 -36000 0 HAST}
    {3132561600 -32400 1 HADT}
    {3150097200 -36000 0 HAST}
    {3164011200 -32400 1 HADT}
    {3181546800 -36000 0 HAST}
    {3195460800 -32400 1 HADT}
    {3212996400 -36000 0 HAST}
    {3226910400 -32400 1 HADT}
    {3245050800 -36000 0 HAST}
    {3258360000 -32400 1 HADT}
    {3276500400 -36000 0 HAST}
    {3289809600 -32400 1 HADT}
    {3307950000 -36000 0 HAST}
    {3321864000 -32400 1 HADT}
    {3339399600 -36000 0 HAST}
    {3353313600 -32400 1 HADT}
    {3370849200 -36000 0 HAST}
    {3384763200 -32400 1 HADT}
    {3402903600 -36000 0 HAST}
    {3416212800 -32400 1 HADT}
    {3434353200 -36000 0 HAST}
    {3447662400 -32400 1 HADT}
    {3465802800 -36000 0 HAST}
    {3479716800 -32400 1 HADT}
    {3497252400 -36000 0 HAST}
    {3511166400 -32400 1 HADT}
    {3528702000 -36000 0 HAST}
    {3542616000 -32400 1 HADT}
    {3560151600 -36000 0 HAST}
    {3574065600 -32400 1 HADT}
    {3592206000 -36000 0 HAST}
    {3605515200 -32400 1 HADT}
    {3623655600 -36000 0 HAST}
    {3636964800 -32400 1 HADT}
    {3655105200 -36000 0 HAST}
    {3669019200 -32400 1 HADT}
    {3686554800 -36000 0 HAST}
    {3700468800 -32400 1 HADT}
    {3718004400 -36000 0 HAST}
    {3731918400 -32400 1 HADT}
    {3750058800 -36000 0 HAST}
    {3763368000 -32400 1 HADT}
    {3781508400 -36000 0 HAST}
    {3794817600 -32400 1 HADT}
    {3812958000 -36000 0 HAST}
    {3826267200 -32400 1 HADT}
    {3844407600 -36000 0 HAST}
    {3858321600 -32400 1 HADT}
    {3875857200 -36000 0 HAST}
    {3889771200 -32400 1 HADT}
    {3907306800 -36000 0 HAST}
    {3921220800 -32400 1 HADT}
    {3939361200 -36000 0 HAST}
    {3952670400 -32400 1 HADT}
    {3970810800 -36000 0 HAST}
    {3984120000 -32400 1 HADT}
    {4002260400 -36000 0 HAST}
    {4016174400 -32400 1 HADT}
    {4033710000 -36000 0 HAST}
    {4047624000 -32400 1 HADT}
    {4065159600 -36000 0 HAST}
    {4079073600 -32400 1 HADT}
    {4096609200 -36000 0 HAST}
}







|
|
|
|
|
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135


136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158


159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229


230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275


276
    {1067166000 -36000 0 HAST}
    {1081080000 -32400 1 HADT}
    {1099220400 -36000 0 HAST}
    {1112529600 -32400 1 HADT}
    {1130670000 -36000 0 HAST}
    {1143979200 -32400 1 HADT}
    {1162119600 -36000 0 HAST}
    {1173614400 -32400 1 HADT}
    {1194174000 -36000 0 HAST}
    {1205064000 -32400 1 HADT}
    {1225623600 -36000 0 HAST}
    {1236513600 -32400 1 HADT}
    {1257073200 -36000 0 HAST}
    {1268568000 -32400 1 HADT}
    {1289127600 -36000 0 HAST}
    {1300017600 -32400 1 HADT}
    {1320577200 -36000 0 HAST}
    {1331467200 -32400 1 HADT}
    {1352026800 -36000 0 HAST}
    {1362916800 -32400 1 HADT}
    {1383476400 -36000 0 HAST}
    {1394366400 -32400 1 HADT}
    {1414926000 -36000 0 HAST}
    {1425816000 -32400 1 HADT}
    {1446375600 -36000 0 HAST}
    {1457870400 -32400 1 HADT}
    {1478430000 -36000 0 HAST}
    {1489320000 -32400 1 HADT}
    {1509879600 -36000 0 HAST}
    {1520769600 -32400 1 HADT}
    {1541329200 -36000 0 HAST}
    {1552219200 -32400 1 HADT}
    {1572778800 -36000 0 HAST}
    {1583668800 -32400 1 HADT}
    {1604228400 -36000 0 HAST}
    {1615723200 -32400 1 HADT}
    {1636282800 -36000 0 HAST}
    {1647172800 -32400 1 HADT}
    {1667732400 -36000 0 HAST}
    {1678622400 -32400 1 HADT}
    {1699182000 -36000 0 HAST}
    {1710072000 -32400 1 HADT}
    {1730631600 -36000 0 HAST}
    {1741521600 -32400 1 HADT}
    {1762081200 -36000 0 HAST}
    {1772971200 -32400 1 HADT}
    {1793530800 -36000 0 HAST}
    {1805025600 -32400 1 HADT}
    {1825585200 -36000 0 HAST}
    {1836475200 -32400 1 HADT}
    {1857034800 -36000 0 HAST}
    {1867924800 -32400 1 HADT}
    {1888484400 -36000 0 HAST}


    {1899374400 -32400 1 HADT}
    {1919934000 -36000 0 HAST}
    {1930824000 -32400 1 HADT}
    {1951383600 -36000 0 HAST}
    {1962878400 -32400 1 HADT}
    {1983438000 -36000 0 HAST}
    {1994328000 -32400 1 HADT}
    {2014887600 -36000 0 HAST}
    {2025777600 -32400 1 HADT}
    {2046337200 -36000 0 HAST}
    {2057227200 -32400 1 HADT}
    {2077786800 -36000 0 HAST}
    {2088676800 -32400 1 HADT}
    {2109236400 -36000 0 HAST}
    {2120126400 -32400 1 HADT}
    {2140686000 -36000 0 HAST}
    {2152180800 -32400 1 HADT}
    {2172740400 -36000 0 HAST}
    {2183630400 -32400 1 HADT}
    {2204190000 -36000 0 HAST}
    {2215080000 -32400 1 HADT}
    {2235639600 -36000 0 HAST}
    {2246529600 -32400 1 HADT}


    {2267089200 -36000 0 HAST}
    {2277979200 -32400 1 HADT}
    {2298538800 -36000 0 HAST}
    {2309428800 -32400 1 HADT}
    {2329988400 -36000 0 HAST}
    {2341483200 -32400 1 HADT}
    {2362042800 -36000 0 HAST}
    {2372932800 -32400 1 HADT}
    {2393492400 -36000 0 HAST}
    {2404382400 -32400 1 HADT}
    {2424942000 -36000 0 HAST}
    {2435832000 -32400 1 HADT}
    {2456391600 -36000 0 HAST}
    {2467281600 -32400 1 HADT}
    {2487841200 -36000 0 HAST}
    {2499336000 -32400 1 HADT}
    {2519895600 -36000 0 HAST}
    {2530785600 -32400 1 HADT}
    {2551345200 -36000 0 HAST}
    {2562235200 -32400 1 HADT}
    {2582794800 -36000 0 HAST}
    {2593684800 -32400 1 HADT}
    {2614244400 -36000 0 HAST}
    {2625134400 -32400 1 HADT}
    {2645694000 -36000 0 HAST}
    {2656584000 -32400 1 HADT}
    {2677143600 -36000 0 HAST}
    {2688638400 -32400 1 HADT}
    {2709198000 -36000 0 HAST}
    {2720088000 -32400 1 HADT}
    {2740647600 -36000 0 HAST}
    {2751537600 -32400 1 HADT}
    {2772097200 -36000 0 HAST}
    {2782987200 -32400 1 HADT}
    {2803546800 -36000 0 HAST}
    {2814436800 -32400 1 HADT}
    {2834996400 -36000 0 HAST}
    {2846491200 -32400 1 HADT}
    {2867050800 -36000 0 HAST}
    {2877940800 -32400 1 HADT}
    {2898500400 -36000 0 HAST}
    {2909390400 -32400 1 HADT}
    {2929950000 -36000 0 HAST}
    {2940840000 -32400 1 HADT}
    {2961399600 -36000 0 HAST}
    {2972289600 -32400 1 HADT}
    {2992849200 -36000 0 HAST}
    {3003739200 -32400 1 HADT}
    {3024298800 -36000 0 HAST}
    {3035793600 -32400 1 HADT}
    {3056353200 -36000 0 HAST}
    {3067243200 -32400 1 HADT}
    {3087802800 -36000 0 HAST}
    {3098692800 -32400 1 HADT}
    {3119252400 -36000 0 HAST}
    {3130142400 -32400 1 HADT}
    {3150702000 -36000 0 HAST}
    {3161592000 -32400 1 HADT}
    {3182151600 -36000 0 HAST}
    {3193041600 -32400 1 HADT}
    {3213601200 -36000 0 HAST}
    {3225096000 -32400 1 HADT}
    {3245655600 -36000 0 HAST}
    {3256545600 -32400 1 HADT}
    {3277105200 -36000 0 HAST}
    {3287995200 -32400 1 HADT}
    {3308554800 -36000 0 HAST}
    {3319444800 -32400 1 HADT}
    {3340004400 -36000 0 HAST}
    {3350894400 -32400 1 HADT}
    {3371454000 -36000 0 HAST}


    {3382948800 -32400 1 HADT}
    {3403508400 -36000 0 HAST}
    {3414398400 -32400 1 HADT}
    {3434958000 -36000 0 HAST}
    {3445848000 -32400 1 HADT}
    {3466407600 -36000 0 HAST}
    {3477297600 -32400 1 HADT}
    {3497857200 -36000 0 HAST}
    {3508747200 -32400 1 HADT}
    {3529306800 -36000 0 HAST}
    {3540196800 -32400 1 HADT}
    {3560756400 -36000 0 HAST}
    {3572251200 -32400 1 HADT}
    {3592810800 -36000 0 HAST}
    {3603700800 -32400 1 HADT}
    {3624260400 -36000 0 HAST}
    {3635150400 -32400 1 HADT}
    {3655710000 -36000 0 HAST}
    {3666600000 -32400 1 HADT}
    {3687159600 -36000 0 HAST}
    {3698049600 -32400 1 HADT}
    {3718609200 -36000 0 HAST}
    {3730104000 -32400 1 HADT}
    {3750663600 -36000 0 HAST}
    {3761553600 -32400 1 HADT}
    {3782113200 -36000 0 HAST}
    {3793003200 -32400 1 HADT}
    {3813562800 -36000 0 HAST}
    {3824452800 -32400 1 HADT}
    {3845012400 -36000 0 HAST}
    {3855902400 -32400 1 HADT}
    {3876462000 -36000 0 HAST}
    {3887352000 -32400 1 HADT}
    {3907911600 -36000 0 HAST}
    {3919406400 -32400 1 HADT}
    {3939966000 -36000 0 HAST}
    {3950856000 -32400 1 HADT}
    {3971415600 -36000 0 HAST}
    {3982305600 -32400 1 HADT}
    {4002865200 -36000 0 HAST}
    {4013755200 -32400 1 HADT}
    {4034314800 -36000 0 HAST}
    {4045204800 -32400 1 HADT}
    {4065764400 -36000 0 HAST}
    {4076654400 -32400 1 HADT}
    {4097214000 -36000 0 HAST}


}

Changes to library/tzdata/America/Anchorage.

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181


182
183
184


185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243


244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275


276
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1175425200 -28800 1 AKDT}
    {1193565600 -32400 0 AKST}
    {1207479600 -28800 1 AKDT}
    {1225015200 -32400 0 AKST}
    {1238929200 -28800 1 AKDT}
    {1256464800 -32400 0 AKST}
    {1270378800 -28800 1 AKDT}
    {1288519200 -32400 0 AKST}
    {1301828400 -28800 1 AKDT}
    {1319968800 -32400 0 AKST}
    {1333278000 -28800 1 AKDT}
    {1351418400 -32400 0 AKST}
    {1365332400 -28800 1 AKDT}
    {1382868000 -32400 0 AKST}
    {1396782000 -28800 1 AKDT}
    {1414317600 -32400 0 AKST}
    {1428231600 -28800 1 AKDT}
    {1445767200 -32400 0 AKST}
    {1459681200 -28800 1 AKDT}
    {1477821600 -32400 0 AKST}
    {1491130800 -28800 1 AKDT}
    {1509271200 -32400 0 AKST}
    {1522580400 -28800 1 AKDT}
    {1540720800 -32400 0 AKST}
    {1554634800 -28800 1 AKDT}
    {1572170400 -32400 0 AKST}
    {1586084400 -28800 1 AKDT}
    {1603620000 -32400 0 AKST}
    {1617534000 -28800 1 AKDT}
    {1635674400 -32400 0 AKST}
    {1648983600 -28800 1 AKDT}
    {1667124000 -32400 0 AKST}
    {1680433200 -28800 1 AKDT}
    {1698573600 -32400 0 AKST}
    {1712487600 -28800 1 AKDT}
    {1730023200 -32400 0 AKST}
    {1743937200 -28800 1 AKDT}
    {1761472800 -32400 0 AKST}
    {1775386800 -28800 1 AKDT}
    {1792922400 -32400 0 AKST}
    {1806836400 -28800 1 AKDT}
    {1824976800 -32400 0 AKST}
    {1838286000 -28800 1 AKDT}
    {1856426400 -32400 0 AKST}
    {1869735600 -28800 1 AKDT}
    {1887876000 -32400 0 AKST}
    {1901790000 -28800 1 AKDT}
    {1919325600 -32400 0 AKST}
    {1933239600 -28800 1 AKDT}
    {1950775200 -32400 0 AKST}
    {1964689200 -28800 1 AKDT}
    {1982829600 -32400 0 AKST}
    {1996138800 -28800 1 AKDT}
    {2014279200 -32400 0 AKST}
    {2027588400 -28800 1 AKDT}
    {2045728800 -32400 0 AKST}
    {2059038000 -28800 1 AKDT}
    {2077178400 -32400 0 AKST}
    {2091092400 -28800 1 AKDT}
    {2108628000 -32400 0 AKST}
    {2122542000 -28800 1 AKDT}
    {2140077600 -32400 0 AKST}
    {2153991600 -28800 1 AKDT}
    {2172132000 -32400 0 AKST}
    {2185441200 -28800 1 AKDT}
    {2203581600 -32400 0 AKST}
    {2216890800 -28800 1 AKDT}
    {2235031200 -32400 0 AKST}
    {2248945200 -28800 1 AKDT}
    {2266480800 -32400 0 AKST}
    {2280394800 -28800 1 AKDT}
    {2297930400 -32400 0 AKST}
    {2311844400 -28800 1 AKDT}
    {2329380000 -32400 0 AKST}
    {2343294000 -28800 1 AKDT}
    {2361434400 -32400 0 AKST}
    {2374743600 -28800 1 AKDT}
    {2392884000 -32400 0 AKST}
    {2406193200 -28800 1 AKDT}
    {2424333600 -32400 0 AKST}
    {2438247600 -28800 1 AKDT}
    {2455783200 -32400 0 AKST}
    {2469697200 -28800 1 AKDT}
    {2487232800 -32400 0 AKST}
    {2501146800 -28800 1 AKDT}
    {2519287200 -32400 0 AKST}
    {2532596400 -28800 1 AKDT}
    {2550736800 -32400 0 AKST}
    {2564046000 -28800 1 AKDT}
    {2582186400 -32400 0 AKST}
    {2596100400 -28800 1 AKDT}
    {2613636000 -32400 0 AKST}


    {2627550000 -28800 1 AKDT}
    {2645085600 -32400 0 AKST}
    {2658999600 -28800 1 AKDT}


    {2676535200 -32400 0 AKST}
    {2690449200 -28800 1 AKDT}
    {2708589600 -32400 0 AKST}
    {2721898800 -28800 1 AKDT}
    {2740039200 -32400 0 AKST}
    {2753348400 -28800 1 AKDT}
    {2771488800 -32400 0 AKST}
    {2785402800 -28800 1 AKDT}
    {2802938400 -32400 0 AKST}
    {2816852400 -28800 1 AKDT}
    {2834388000 -32400 0 AKST}
    {2848302000 -28800 1 AKDT}
    {2866442400 -32400 0 AKST}
    {2879751600 -28800 1 AKDT}
    {2897892000 -32400 0 AKST}
    {2911201200 -28800 1 AKDT}
    {2929341600 -32400 0 AKST}
    {2942650800 -28800 1 AKDT}
    {2960791200 -32400 0 AKST}
    {2974705200 -28800 1 AKDT}
    {2992240800 -32400 0 AKST}
    {3006154800 -28800 1 AKDT}
    {3023690400 -32400 0 AKST}
    {3037604400 -28800 1 AKDT}
    {3055744800 -32400 0 AKST}
    {3069054000 -28800 1 AKDT}
    {3087194400 -32400 0 AKST}
    {3100503600 -28800 1 AKDT}
    {3118644000 -32400 0 AKST}
    {3132558000 -28800 1 AKDT}
    {3150093600 -32400 0 AKST}
    {3164007600 -28800 1 AKDT}
    {3181543200 -32400 0 AKST}
    {3195457200 -28800 1 AKDT}
    {3212992800 -32400 0 AKST}
    {3226906800 -28800 1 AKDT}
    {3245047200 -32400 0 AKST}
    {3258356400 -28800 1 AKDT}
    {3276496800 -32400 0 AKST}
    {3289806000 -28800 1 AKDT}
    {3307946400 -32400 0 AKST}
    {3321860400 -28800 1 AKDT}
    {3339396000 -32400 0 AKST}
    {3353310000 -28800 1 AKDT}
    {3370845600 -32400 0 AKST}
    {3384759600 -28800 1 AKDT}
    {3402900000 -32400 0 AKST}
    {3416209200 -28800 1 AKDT}
    {3434349600 -32400 0 AKST}
    {3447658800 -28800 1 AKDT}
    {3465799200 -32400 0 AKST}
    {3479713200 -28800 1 AKDT}
    {3497248800 -32400 0 AKST}
    {3511162800 -28800 1 AKDT}
    {3528698400 -32400 0 AKST}
    {3542612400 -28800 1 AKDT}
    {3560148000 -32400 0 AKST}
    {3574062000 -28800 1 AKDT}
    {3592202400 -32400 0 AKST}


    {3605511600 -28800 1 AKDT}
    {3623652000 -32400 0 AKST}
    {3636961200 -28800 1 AKDT}
    {3655101600 -32400 0 AKST}
    {3669015600 -28800 1 AKDT}
    {3686551200 -32400 0 AKST}
    {3700465200 -28800 1 AKDT}
    {3718000800 -32400 0 AKST}
    {3731914800 -28800 1 AKDT}
    {3750055200 -32400 0 AKST}
    {3763364400 -28800 1 AKDT}
    {3781504800 -32400 0 AKST}
    {3794814000 -28800 1 AKDT}
    {3812954400 -32400 0 AKST}
    {3826263600 -28800 1 AKDT}
    {3844404000 -32400 0 AKST}
    {3858318000 -28800 1 AKDT}
    {3875853600 -32400 0 AKST}
    {3889767600 -28800 1 AKDT}
    {3907303200 -32400 0 AKST}
    {3921217200 -28800 1 AKDT}
    {3939357600 -32400 0 AKST}
    {3952666800 -28800 1 AKDT}
    {3970807200 -32400 0 AKST}
    {3984116400 -28800 1 AKDT}
    {4002256800 -32400 0 AKST}
    {4016170800 -28800 1 AKDT}
    {4033706400 -32400 0 AKST}
    {4047620400 -28800 1 AKDT}
    {4065156000 -32400 0 AKST}
    {4079070000 -28800 1 AKDT}
    {4096605600 -32400 0 AKST}


}







|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>

83
84
85
86
87
88
89
90
91
92
93
94
95
96


97
98
99
100
101
102
103
104
105
106
107
108


109
110
111
112
113


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204


205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1173610800 -28800 1 AKDT}
    {1194170400 -32400 0 AKST}
    {1205060400 -28800 1 AKDT}
    {1225620000 -32400 0 AKST}
    {1236510000 -28800 1 AKDT}
    {1257069600 -32400 0 AKST}
    {1268564400 -28800 1 AKDT}


    {1289124000 -32400 0 AKST}
    {1300014000 -28800 1 AKDT}
    {1320573600 -32400 0 AKST}
    {1331463600 -28800 1 AKDT}
    {1352023200 -32400 0 AKST}
    {1362913200 -28800 1 AKDT}
    {1383472800 -32400 0 AKST}
    {1394362800 -28800 1 AKDT}
    {1414922400 -32400 0 AKST}
    {1425812400 -28800 1 AKDT}
    {1446372000 -32400 0 AKST}
    {1457866800 -28800 1 AKDT}


    {1478426400 -32400 0 AKST}
    {1489316400 -28800 1 AKDT}
    {1509876000 -32400 0 AKST}
    {1520766000 -28800 1 AKDT}
    {1541325600 -32400 0 AKST}


    {1552215600 -28800 1 AKDT}
    {1572775200 -32400 0 AKST}
    {1583665200 -28800 1 AKDT}
    {1604224800 -32400 0 AKST}
    {1615719600 -28800 1 AKDT}
    {1636279200 -32400 0 AKST}
    {1647169200 -28800 1 AKDT}
    {1667728800 -32400 0 AKST}
    {1678618800 -28800 1 AKDT}
    {1699178400 -32400 0 AKST}
    {1710068400 -28800 1 AKDT}
    {1730628000 -32400 0 AKST}
    {1741518000 -28800 1 AKDT}
    {1762077600 -32400 0 AKST}
    {1772967600 -28800 1 AKDT}
    {1793527200 -32400 0 AKST}
    {1805022000 -28800 1 AKDT}
    {1825581600 -32400 0 AKST}
    {1836471600 -28800 1 AKDT}
    {1857031200 -32400 0 AKST}
    {1867921200 -28800 1 AKDT}
    {1888480800 -32400 0 AKST}
    {1899370800 -28800 1 AKDT}
    {1919930400 -32400 0 AKST}
    {1930820400 -28800 1 AKDT}
    {1951380000 -32400 0 AKST}
    {1962874800 -28800 1 AKDT}
    {1983434400 -32400 0 AKST}
    {1994324400 -28800 1 AKDT}
    {2014884000 -32400 0 AKST}
    {2025774000 -28800 1 AKDT}
    {2046333600 -32400 0 AKST}
    {2057223600 -28800 1 AKDT}
    {2077783200 -32400 0 AKST}
    {2088673200 -28800 1 AKDT}
    {2109232800 -32400 0 AKST}
    {2120122800 -28800 1 AKDT}
    {2140682400 -32400 0 AKST}
    {2152177200 -28800 1 AKDT}
    {2172736800 -32400 0 AKST}
    {2183626800 -28800 1 AKDT}
    {2204186400 -32400 0 AKST}
    {2215076400 -28800 1 AKDT}
    {2235636000 -32400 0 AKST}
    {2246526000 -28800 1 AKDT}
    {2267085600 -32400 0 AKST}
    {2277975600 -28800 1 AKDT}
    {2298535200 -32400 0 AKST}
    {2309425200 -28800 1 AKDT}
    {2329984800 -32400 0 AKST}
    {2341479600 -28800 1 AKDT}
    {2362039200 -32400 0 AKST}
    {2372929200 -28800 1 AKDT}
    {2393488800 -32400 0 AKST}
    {2404378800 -28800 1 AKDT}
    {2424938400 -32400 0 AKST}
    {2435828400 -28800 1 AKDT}
    {2456388000 -32400 0 AKST}
    {2467278000 -28800 1 AKDT}
    {2487837600 -32400 0 AKST}
    {2499332400 -28800 1 AKDT}
    {2519892000 -32400 0 AKST}
    {2530782000 -28800 1 AKDT}
    {2551341600 -32400 0 AKST}
    {2562231600 -28800 1 AKDT}
    {2582791200 -32400 0 AKST}
    {2593681200 -28800 1 AKDT}
    {2614240800 -32400 0 AKST}
    {2625130800 -28800 1 AKDT}
    {2645690400 -32400 0 AKST}
    {2656580400 -28800 1 AKDT}
    {2677140000 -32400 0 AKST}
    {2688634800 -28800 1 AKDT}
    {2709194400 -32400 0 AKST}
    {2720084400 -28800 1 AKDT}
    {2740644000 -32400 0 AKST}
    {2751534000 -28800 1 AKDT}
    {2772093600 -32400 0 AKST}
    {2782983600 -28800 1 AKDT}
    {2803543200 -32400 0 AKST}
    {2814433200 -28800 1 AKDT}
    {2834992800 -32400 0 AKST}
    {2846487600 -28800 1 AKDT}
    {2867047200 -32400 0 AKST}
    {2877937200 -28800 1 AKDT}
    {2898496800 -32400 0 AKST}
    {2909386800 -28800 1 AKDT}
    {2929946400 -32400 0 AKST}
    {2940836400 -28800 1 AKDT}
    {2961396000 -32400 0 AKST}
    {2972286000 -28800 1 AKDT}


    {2992845600 -32400 0 AKST}
    {3003735600 -28800 1 AKDT}
    {3024295200 -32400 0 AKST}
    {3035790000 -28800 1 AKDT}
    {3056349600 -32400 0 AKST}
    {3067239600 -28800 1 AKDT}
    {3087799200 -32400 0 AKST}
    {3098689200 -28800 1 AKDT}
    {3119248800 -32400 0 AKST}
    {3130138800 -28800 1 AKDT}
    {3150698400 -32400 0 AKST}
    {3161588400 -28800 1 AKDT}
    {3182148000 -32400 0 AKST}
    {3193038000 -28800 1 AKDT}
    {3213597600 -32400 0 AKST}
    {3225092400 -28800 1 AKDT}
    {3245652000 -32400 0 AKST}
    {3256542000 -28800 1 AKDT}
    {3277101600 -32400 0 AKST}
    {3287991600 -28800 1 AKDT}
    {3308551200 -32400 0 AKST}
    {3319441200 -28800 1 AKDT}
    {3340000800 -32400 0 AKST}
    {3350890800 -28800 1 AKDT}
    {3371450400 -32400 0 AKST}
    {3382945200 -28800 1 AKDT}
    {3403504800 -32400 0 AKST}
    {3414394800 -28800 1 AKDT}
    {3434954400 -32400 0 AKST}
    {3445844400 -28800 1 AKDT}
    {3466404000 -32400 0 AKST}
    {3477294000 -28800 1 AKDT}
    {3497853600 -32400 0 AKST}
    {3508743600 -28800 1 AKDT}
    {3529303200 -32400 0 AKST}
    {3540193200 -28800 1 AKDT}
    {3560752800 -32400 0 AKST}
    {3572247600 -28800 1 AKDT}
    {3592807200 -32400 0 AKST}
    {3603697200 -28800 1 AKDT}
    {3624256800 -32400 0 AKST}
    {3635146800 -28800 1 AKDT}
    {3655706400 -32400 0 AKST}
    {3666596400 -28800 1 AKDT}
    {3687156000 -32400 0 AKST}
    {3698046000 -28800 1 AKDT}
    {3718605600 -32400 0 AKST}
    {3730100400 -28800 1 AKDT}
    {3750660000 -32400 0 AKST}
    {3761550000 -28800 1 AKDT}
    {3782109600 -32400 0 AKST}
    {3792999600 -28800 1 AKDT}
    {3813559200 -32400 0 AKST}
    {3824449200 -28800 1 AKDT}
    {3845008800 -32400 0 AKST}
    {3855898800 -28800 1 AKDT}
    {3876458400 -32400 0 AKST}
    {3887348400 -28800 1 AKDT}
    {3907908000 -32400 0 AKST}
    {3919402800 -28800 1 AKDT}
    {3939962400 -32400 0 AKST}
    {3950852400 -28800 1 AKDT}
    {3971412000 -32400 0 AKST}
    {3982302000 -28800 1 AKDT}
    {4002861600 -32400 0 AKST}
    {4013751600 -28800 1 AKDT}
    {4034311200 -32400 0 AKST}
    {4045201200 -28800 1 AKDT}
    {4065760800 -32400 0 AKST}
    {4076650800 -28800 1 AKDT}
    {4097210400 -32400 0 AKST}
}

Changes to library/tzdata/America/Argentina/ComodRivadavia.

1


2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
# created by ../tools/tclZIC.tcl - do not edit



set TZData(:America/Argentina/ComodRivadavia) {
    {-9223372036854775808 -16200 0 LMT}
    {-2372095800 -15408 0 CMT}
    {-1567453392 -14400 0 ART}
    {-1233432000 -10800 0 ARST}
    {-1222981200 -14400 0 ART}
    {-1205956800 -10800 1 ARST}
    {-1194037200 -14400 0 ART}
    {-1172865600 -10800 1 ARST}
    {-1162501200 -14400 0 ART}
    {-1141329600 -10800 1 ARST}
    {-1130965200 -14400 0 ART}
    {-1109793600 -10800 1 ARST}
    {-1099429200 -14400 0 ART}
    {-1078257600 -10800 1 ARST}
    {-1067806800 -14400 0 ART}
    {-1046635200 -10800 1 ARST}
    {-1036270800 -14400 0 ART}
    {-1015099200 -10800 1 ARST}
    {-1004734800 -14400 0 ART}
    {-983563200 -10800 1 ARST}
    {-973198800 -14400 0 ART}
    {-952027200 -10800 1 ARST}
    {-941576400 -14400 0 ART}
    {-931032000 -10800 1 ARST}
    {-900882000 -14400 0 ART}
    {-890337600 -10800 1 ARST}
    {-833749200 -14400 0 ART}
    {-827265600 -10800 1 ARST}
    {-752274000 -14400 0 ART}
    {-733780800 -10800 1 ARST}
    {-197326800 -14400 0 ART}
    {-190843200 -10800 1 ARST}
    {-184194000 -14400 0 ART}
    {-164491200 -10800 1 ARST}
    {-152658000 -14400 0 ART}
    {-132955200 -10800 1 ARST}
    {-121122000 -14400 0 ART}
    {-101419200 -10800 1 ARST}
    {-86821200 -14400 0 ART}
    {-71092800 -10800 1 ARST}
    {-54766800 -14400 0 ART}
    {-39038400 -10800 1 ARST}
    {-23317200 -14400 0 ART}
    {-7588800 -10800 0 ART}
    {128142000 -7200 1 ARST}
    {136605600 -10800 0 ART}
    {596948400 -7200 1 ARST}
    {605066400 -10800 0 ART}
    {624423600 -7200 1 ARST}
    {636516000 -10800 0 ART}
    {656478000 -7200 1 ARST}
    {667965600 -14400 0 WART}
    {687931200 -7200 0 ARST}
    {699415200 -10800 0 ART}
    {719377200 -7200 1 ARST}
    {731469600 -10800 0 ART}
    {938916000 -10800 0 ART}
    {938919600 -10800 1 ARST}
    {952056000 -10800 0 ART}
    {1086058800 -14400 0 WART}
    {1087704000 -10800 0 ART}
}

>
>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
1
2
3
4
5






























































# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Argentina/Catamarca)]} {
    LoadTimeZoneFile America/Argentina/Catamarca
}
set TZData(:America/Argentina/ComodRivadavia) $TZData(:America/Argentina/Catamarca)






























































Changes to library/tzdata/America/Asuncion.

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92


93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137


138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186


187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258


259
    {983674800 -14400 0 PYT}
    {1002427200 -10800 1 PYST}
    {1018148400 -14400 0 PYT}
    {1030852800 -10800 1 PYST}
    {1049598000 -14400 0 PYT}
    {1062907200 -10800 1 PYST}
    {1081047600 -14400 0 PYT}
    {1094356800 -10800 1 PYST}
    {1112497200 -14400 0 PYT}
    {1125806400 -10800 1 PYST}
    {1143946800 -14400 0 PYT}
    {1157256000 -10800 1 PYST}
    {1175396400 -14400 0 PYT}
    {1188705600 -10800 1 PYST}
    {1207450800 -14400 0 PYT}
    {1220760000 -10800 1 PYST}
    {1238900400 -14400 0 PYT}
    {1252209600 -10800 1 PYST}
    {1270350000 -14400 0 PYT}
    {1283659200 -10800 1 PYST}
    {1301799600 -14400 0 PYT}
    {1315108800 -10800 1 PYST}
    {1333249200 -14400 0 PYT}
    {1346558400 -10800 1 PYST}
    {1365303600 -14400 0 PYT}
    {1378008000 -10800 1 PYST}
    {1396753200 -14400 0 PYT}
    {1410062400 -10800 1 PYST}
    {1428202800 -14400 0 PYT}
    {1441512000 -10800 1 PYST}
    {1459652400 -14400 0 PYT}
    {1472961600 -10800 1 PYST}


    {1491102000 -14400 0 PYT}
    {1504411200 -10800 1 PYST}
    {1522551600 -14400 0 PYT}
    {1535860800 -10800 1 PYST}
    {1554606000 -14400 0 PYT}
    {1567310400 -10800 1 PYST}
    {1586055600 -14400 0 PYT}
    {1599364800 -10800 1 PYST}
    {1617505200 -14400 0 PYT}
    {1630814400 -10800 1 PYST}
    {1648954800 -14400 0 PYT}
    {1662264000 -10800 1 PYST}
    {1680404400 -14400 0 PYT}
    {1693713600 -10800 1 PYST}
    {1712458800 -14400 0 PYT}
    {1725163200 -10800 1 PYST}
    {1743908400 -14400 0 PYT}
    {1757217600 -10800 1 PYST}
    {1775358000 -14400 0 PYT}
    {1788667200 -10800 1 PYST}
    {1806807600 -14400 0 PYT}
    {1820116800 -10800 1 PYST}
    {1838257200 -14400 0 PYT}
    {1851566400 -10800 1 PYST}
    {1869706800 -14400 0 PYT}
    {1883016000 -10800 1 PYST}
    {1901761200 -14400 0 PYT}
    {1914465600 -10800 1 PYST}
    {1933210800 -14400 0 PYT}
    {1946520000 -10800 1 PYST}
    {1964660400 -14400 0 PYT}
    {1977969600 -10800 1 PYST}
    {1996110000 -14400 0 PYT}
    {2009419200 -10800 1 PYST}
    {2027559600 -14400 0 PYT}
    {2040868800 -10800 1 PYST}
    {2059009200 -14400 0 PYT}
    {2072318400 -10800 1 PYST}
    {2091063600 -14400 0 PYT}
    {2104372800 -10800 1 PYST}
    {2122513200 -14400 0 PYT}
    {2135822400 -10800 1 PYST}
    {2153962800 -14400 0 PYT}
    {2167272000 -10800 1 PYST}
    {2185412400 -14400 0 PYT}


    {2198721600 -10800 1 PYST}
    {2216862000 -14400 0 PYT}
    {2230171200 -10800 1 PYST}
    {2248916400 -14400 0 PYT}
    {2261620800 -10800 1 PYST}
    {2280366000 -14400 0 PYT}
    {2293675200 -10800 1 PYST}
    {2311815600 -14400 0 PYT}
    {2325124800 -10800 1 PYST}
    {2343265200 -14400 0 PYT}
    {2356574400 -10800 1 PYST}
    {2374714800 -14400 0 PYT}
    {2388024000 -10800 1 PYST}
    {2406164400 -14400 0 PYT}
    {2419473600 -10800 1 PYST}
    {2438218800 -14400 0 PYT}
    {2450923200 -10800 1 PYST}
    {2469668400 -14400 0 PYT}
    {2482977600 -10800 1 PYST}
    {2501118000 -14400 0 PYT}
    {2514427200 -10800 1 PYST}
    {2532567600 -14400 0 PYT}
    {2545876800 -10800 1 PYST}
    {2564017200 -14400 0 PYT}
    {2577326400 -10800 1 PYST}
    {2596071600 -14400 0 PYT}
    {2608776000 -10800 1 PYST}
    {2627521200 -14400 0 PYT}
    {2640830400 -10800 1 PYST}
    {2658970800 -14400 0 PYT}
    {2672280000 -10800 1 PYST}
    {2690420400 -14400 0 PYT}
    {2703729600 -10800 1 PYST}
    {2721870000 -14400 0 PYT}
    {2735179200 -10800 1 PYST}
    {2753319600 -14400 0 PYT}
    {2766628800 -10800 1 PYST}
    {2785374000 -14400 0 PYT}
    {2798078400 -10800 1 PYST}
    {2816823600 -14400 0 PYT}
    {2830132800 -10800 1 PYST}
    {2848273200 -14400 0 PYT}
    {2861582400 -10800 1 PYST}
    {2879722800 -14400 0 PYT}
    {2893032000 -10800 1 PYST}
    {2911172400 -14400 0 PYT}
    {2924481600 -10800 1 PYST}
    {2942622000 -14400 0 PYT}
    {2955931200 -10800 1 PYST}


    {2974676400 -14400 0 PYT}
    {2987985600 -10800 1 PYST}
    {3006126000 -14400 0 PYT}
    {3019435200 -10800 1 PYST}
    {3037575600 -14400 0 PYT}
    {3050884800 -10800 1 PYST}
    {3069025200 -14400 0 PYT}
    {3082334400 -10800 1 PYST}
    {3100474800 -14400 0 PYT}
    {3113784000 -10800 1 PYST}
    {3132529200 -14400 0 PYT}
    {3145233600 -10800 1 PYST}
    {3163978800 -14400 0 PYT}
    {3177288000 -10800 1 PYST}
    {3195428400 -14400 0 PYT}
    {3208737600 -10800 1 PYST}
    {3226878000 -14400 0 PYT}
    {3240187200 -10800 1 PYST}
    {3258327600 -14400 0 PYT}
    {3271636800 -10800 1 PYST}
    {3289777200 -14400 0 PYT}
    {3303086400 -10800 1 PYST}
    {3321831600 -14400 0 PYT}
    {3334536000 -10800 1 PYST}
    {3353281200 -14400 0 PYT}
    {3366590400 -10800 1 PYST}
    {3384730800 -14400 0 PYT}
    {3398040000 -10800 1 PYST}
    {3416180400 -14400 0 PYT}
    {3429489600 -10800 1 PYST}
    {3447630000 -14400 0 PYT}
    {3460939200 -10800 1 PYST}
    {3479684400 -14400 0 PYT}
    {3492388800 -10800 1 PYST}
    {3511134000 -14400 0 PYT}
    {3524443200 -10800 1 PYST}
    {3542583600 -14400 0 PYT}
    {3555892800 -10800 1 PYST}
    {3574033200 -14400 0 PYT}
    {3587342400 -10800 1 PYST}
    {3605482800 -14400 0 PYT}
    {3618792000 -10800 1 PYST}
    {3636932400 -14400 0 PYT}
    {3650241600 -10800 1 PYST}
    {3668986800 -14400 0 PYT}
    {3681691200 -10800 1 PYST}
    {3700436400 -14400 0 PYT}
    {3713745600 -10800 1 PYST}
    {3731886000 -14400 0 PYT}
    {3745195200 -10800 1 PYST}
    {3763335600 -14400 0 PYT}
    {3776644800 -10800 1 PYST}
    {3794785200 -14400 0 PYT}
    {3808094400 -10800 1 PYST}
    {3826234800 -14400 0 PYT}
    {3839544000 -10800 1 PYST}
    {3858289200 -14400 0 PYT}
    {3871598400 -10800 1 PYST}
    {3889738800 -14400 0 PYT}
    {3903048000 -10800 1 PYST}
    {3921188400 -14400 0 PYT}
    {3934497600 -10800 1 PYST}
    {3952638000 -14400 0 PYT}
    {3965947200 -10800 1 PYST}
    {3984087600 -14400 0 PYT}
    {3997396800 -10800 1 PYST}
    {4016142000 -14400 0 PYT}
    {4028846400 -10800 1 PYST}
    {4047591600 -14400 0 PYT}
    {4060900800 -10800 1 PYST}
    {4079041200 -14400 0 PYT}
    {4092350400 -10800 1 PYST}


}







|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>

61
62
63
64
65
66
67
68
69
70
71
72


73
74
75
76
77
78
79
80
81
82
83
84
85
86
87


88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139


140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212


213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
    {983674800 -14400 0 PYT}
    {1002427200 -10800 1 PYST}
    {1018148400 -14400 0 PYT}
    {1030852800 -10800 1 PYST}
    {1049598000 -14400 0 PYT}
    {1062907200 -10800 1 PYST}
    {1081047600 -14400 0 PYT}
    {1097985600 -10800 1 PYST}
    {1110682800 -14400 0 PYT}
    {1129435200 -10800 1 PYST}
    {1142132400 -14400 0 PYT}
    {1160884800 -10800 1 PYST}


    {1173582000 -14400 0 PYT}
    {1192939200 -10800 1 PYST}
    {1205031600 -14400 0 PYT}
    {1224388800 -10800 1 PYST}
    {1236481200 -14400 0 PYT}
    {1255838400 -10800 1 PYST}
    {1268535600 -14400 0 PYT}
    {1287288000 -10800 1 PYST}
    {1299985200 -14400 0 PYT}
    {1318737600 -10800 1 PYST}
    {1331434800 -14400 0 PYT}
    {1350792000 -10800 1 PYST}
    {1362884400 -14400 0 PYT}
    {1382241600 -10800 1 PYST}
    {1394334000 -14400 0 PYT}


    {1413691200 -10800 1 PYST}
    {1425783600 -14400 0 PYT}
    {1445140800 -10800 1 PYST}
    {1457838000 -14400 0 PYT}
    {1476590400 -10800 1 PYST}
    {1489287600 -14400 0 PYT}
    {1508040000 -10800 1 PYST}
    {1520737200 -14400 0 PYT}
    {1540094400 -10800 1 PYST}
    {1552186800 -14400 0 PYT}
    {1571544000 -10800 1 PYST}
    {1583636400 -14400 0 PYT}
    {1602993600 -10800 1 PYST}
    {1615690800 -14400 0 PYT}
    {1634443200 -10800 1 PYST}
    {1647140400 -14400 0 PYT}
    {1665892800 -10800 1 PYST}
    {1678590000 -14400 0 PYT}
    {1697342400 -10800 1 PYST}
    {1710039600 -14400 0 PYT}
    {1729396800 -10800 1 PYST}
    {1741489200 -14400 0 PYT}
    {1760846400 -10800 1 PYST}
    {1772938800 -14400 0 PYT}
    {1792296000 -10800 1 PYST}
    {1804993200 -14400 0 PYT}
    {1823745600 -10800 1 PYST}
    {1836442800 -14400 0 PYT}
    {1855195200 -10800 1 PYST}
    {1867892400 -14400 0 PYT}
    {1887249600 -10800 1 PYST}
    {1899342000 -14400 0 PYT}
    {1918699200 -10800 1 PYST}
    {1930791600 -14400 0 PYT}
    {1950148800 -10800 1 PYST}
    {1962846000 -14400 0 PYT}
    {1981598400 -10800 1 PYST}
    {1994295600 -14400 0 PYT}
    {2013048000 -10800 1 PYST}
    {2025745200 -14400 0 PYT}
    {2044497600 -10800 1 PYST}
    {2057194800 -14400 0 PYT}
    {2076552000 -10800 1 PYST}
    {2088644400 -14400 0 PYT}
    {2108001600 -10800 1 PYST}
    {2120094000 -14400 0 PYT}
    {2139451200 -10800 1 PYST}
    {2152148400 -14400 0 PYT}
    {2170900800 -10800 1 PYST}
    {2183598000 -14400 0 PYT}
    {2202350400 -10800 1 PYST}
    {2215047600 -14400 0 PYT}


    {2234404800 -10800 1 PYST}
    {2246497200 -14400 0 PYT}
    {2265854400 -10800 1 PYST}
    {2277946800 -14400 0 PYT}
    {2297304000 -10800 1 PYST}
    {2309396400 -14400 0 PYT}
    {2328753600 -10800 1 PYST}
    {2341450800 -14400 0 PYT}
    {2360203200 -10800 1 PYST}
    {2372900400 -14400 0 PYT}
    {2391652800 -10800 1 PYST}
    {2404350000 -14400 0 PYT}
    {2423707200 -10800 1 PYST}
    {2435799600 -14400 0 PYT}
    {2455156800 -10800 1 PYST}
    {2467249200 -14400 0 PYT}
    {2486606400 -10800 1 PYST}
    {2499303600 -14400 0 PYT}
    {2518056000 -10800 1 PYST}
    {2530753200 -14400 0 PYT}
    {2549505600 -10800 1 PYST}
    {2562202800 -14400 0 PYT}
    {2580955200 -10800 1 PYST}
    {2593652400 -14400 0 PYT}
    {2613009600 -10800 1 PYST}
    {2625102000 -14400 0 PYT}
    {2644459200 -10800 1 PYST}
    {2656551600 -14400 0 PYT}
    {2675908800 -10800 1 PYST}
    {2688606000 -14400 0 PYT}
    {2707358400 -10800 1 PYST}
    {2720055600 -14400 0 PYT}
    {2738808000 -10800 1 PYST}
    {2751505200 -14400 0 PYT}
    {2770862400 -10800 1 PYST}
    {2782954800 -14400 0 PYT}
    {2802312000 -10800 1 PYST}
    {2814404400 -14400 0 PYT}
    {2833761600 -10800 1 PYST}
    {2846458800 -14400 0 PYT}
    {2865211200 -10800 1 PYST}
    {2877908400 -14400 0 PYT}
    {2896660800 -10800 1 PYST}
    {2909358000 -14400 0 PYT}
    {2928110400 -10800 1 PYST}
    {2940807600 -14400 0 PYT}
    {2960164800 -10800 1 PYST}
    {2972257200 -14400 0 PYT}
    {2991614400 -10800 1 PYST}
    {3003706800 -14400 0 PYT}
    {3023064000 -10800 1 PYST}
    {3035761200 -14400 0 PYT}
    {3054513600 -10800 1 PYST}
    {3067210800 -14400 0 PYT}
    {3085963200 -10800 1 PYST}
    {3098660400 -14400 0 PYT}
    {3118017600 -10800 1 PYST}
    {3130110000 -14400 0 PYT}
    {3149467200 -10800 1 PYST}
    {3161559600 -14400 0 PYT}
    {3180916800 -10800 1 PYST}
    {3193009200 -14400 0 PYT}
    {3212366400 -10800 1 PYST}
    {3225063600 -14400 0 PYT}
    {3243816000 -10800 1 PYST}
    {3256513200 -14400 0 PYT}
    {3275265600 -10800 1 PYST}
    {3287962800 -14400 0 PYT}
    {3307320000 -10800 1 PYST}
    {3319412400 -14400 0 PYT}
    {3338769600 -10800 1 PYST}
    {3350862000 -14400 0 PYT}
    {3370219200 -10800 1 PYST}


    {3382916400 -14400 0 PYT}
    {3401668800 -10800 1 PYST}
    {3414366000 -14400 0 PYT}
    {3433118400 -10800 1 PYST}
    {3445815600 -14400 0 PYT}
    {3464568000 -10800 1 PYST}
    {3477265200 -14400 0 PYT}
    {3496622400 -10800 1 PYST}
    {3508714800 -14400 0 PYT}
    {3528072000 -10800 1 PYST}
    {3540164400 -14400 0 PYT}
    {3559521600 -10800 1 PYST}
    {3572218800 -14400 0 PYT}
    {3590971200 -10800 1 PYST}
    {3603668400 -14400 0 PYT}
    {3622420800 -10800 1 PYST}
    {3635118000 -14400 0 PYT}
    {3654475200 -10800 1 PYST}
    {3666567600 -14400 0 PYT}
    {3685924800 -10800 1 PYST}
    {3698017200 -14400 0 PYT}
    {3717374400 -10800 1 PYST}
    {3730071600 -14400 0 PYT}
    {3748824000 -10800 1 PYST}
    {3761521200 -14400 0 PYT}
    {3780273600 -10800 1 PYST}
    {3792970800 -14400 0 PYT}
    {3811723200 -10800 1 PYST}
    {3824420400 -14400 0 PYT}
    {3843777600 -10800 1 PYST}
    {3855870000 -14400 0 PYT}
    {3875227200 -10800 1 PYST}
    {3887319600 -14400 0 PYT}
    {3906676800 -10800 1 PYST}
    {3919374000 -14400 0 PYT}
    {3938126400 -10800 1 PYST}
    {3950823600 -14400 0 PYT}
    {3969576000 -10800 1 PYST}
    {3982273200 -14400 0 PYT}
    {4001630400 -10800 1 PYST}
    {4013722800 -14400 0 PYT}
    {4033080000 -10800 1 PYST}
    {4045172400 -14400 0 PYT}
    {4064529600 -10800 1 PYST}
    {4076622000 -14400 0 PYT}
    {4095979200 -10800 1 PYST}
}

Changes to library/tzdata/America/Boise.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Boise) {
    {-9223372036854775808 -27889 0 LMT}
    {-2717640911 -28800 0 PST}
    {-1633269600 -25200 1 PDT}
    {-1615129200 -28800 0 PST}
    {-1601820000 -25200 1 PDT}
    {-1583679600 -28800 0 PST}
    {-1471788000 -25200 0 MST}
    {-880210800 -21600 1 MWT}
    {-769395600 -21600 1 MPT}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Boise) {
    {-9223372036854775808 -27889 0 LMT}
    {-2717640000 -28800 0 PST}
    {-1633269600 -25200 1 PDT}
    {-1615129200 -28800 0 PST}
    {-1601820000 -25200 1 PDT}
    {-1583679600 -28800 0 PST}
    {-1471788000 -25200 0 MST}
    {-880210800 -21600 1 MWT}
    {-769395600 -21600 1 MPT}
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102


103


104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183


184
185
186
187
188
189
190


191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
    {1067155200 -25200 0 MST}
    {1081069200 -21600 1 MDT}
    {1099209600 -25200 0 MST}
    {1112518800 -21600 1 MDT}
    {1130659200 -25200 0 MST}
    {1143968400 -21600 1 MDT}
    {1162108800 -25200 0 MST}
    {1175418000 -21600 1 MDT}
    {1193558400 -25200 0 MST}
    {1207472400 -21600 1 MDT}
    {1225008000 -25200 0 MST}
    {1238922000 -21600 1 MDT}
    {1256457600 -25200 0 MST}
    {1270371600 -21600 1 MDT}
    {1288512000 -25200 0 MST}


    {1301821200 -21600 1 MDT}


    {1319961600 -25200 0 MST}
    {1333270800 -21600 1 MDT}
    {1351411200 -25200 0 MST}
    {1365325200 -21600 1 MDT}
    {1382860800 -25200 0 MST}
    {1396774800 -21600 1 MDT}
    {1414310400 -25200 0 MST}
    {1428224400 -21600 1 MDT}
    {1445760000 -25200 0 MST}
    {1459674000 -21600 1 MDT}
    {1477814400 -25200 0 MST}
    {1491123600 -21600 1 MDT}
    {1509264000 -25200 0 MST}
    {1522573200 -21600 1 MDT}
    {1540713600 -25200 0 MST}
    {1554627600 -21600 1 MDT}
    {1572163200 -25200 0 MST}
    {1586077200 -21600 1 MDT}
    {1603612800 -25200 0 MST}
    {1617526800 -21600 1 MDT}
    {1635667200 -25200 0 MST}
    {1648976400 -21600 1 MDT}
    {1667116800 -25200 0 MST}
    {1680426000 -21600 1 MDT}
    {1698566400 -25200 0 MST}
    {1712480400 -21600 1 MDT}
    {1730016000 -25200 0 MST}
    {1743930000 -21600 1 MDT}
    {1761465600 -25200 0 MST}
    {1775379600 -21600 1 MDT}
    {1792915200 -25200 0 MST}
    {1806829200 -21600 1 MDT}
    {1824969600 -25200 0 MST}
    {1838278800 -21600 1 MDT}
    {1856419200 -25200 0 MST}
    {1869728400 -21600 1 MDT}
    {1887868800 -25200 0 MST}
    {1901782800 -21600 1 MDT}
    {1919318400 -25200 0 MST}
    {1933232400 -21600 1 MDT}
    {1950768000 -25200 0 MST}
    {1964682000 -21600 1 MDT}
    {1982822400 -25200 0 MST}
    {1996131600 -21600 1 MDT}
    {2014272000 -25200 0 MST}
    {2027581200 -21600 1 MDT}
    {2045721600 -25200 0 MST}
    {2059030800 -21600 1 MDT}
    {2077171200 -25200 0 MST}
    {2091085200 -21600 1 MDT}
    {2108620800 -25200 0 MST}
    {2122534800 -21600 1 MDT}
    {2140070400 -25200 0 MST}
    {2153984400 -21600 1 MDT}
    {2172124800 -25200 0 MST}
    {2185434000 -21600 1 MDT}
    {2203574400 -25200 0 MST}
    {2216883600 -21600 1 MDT}
    {2235024000 -25200 0 MST}
    {2248938000 -21600 1 MDT}
    {2266473600 -25200 0 MST}
    {2280387600 -21600 1 MDT}
    {2297923200 -25200 0 MST}
    {2311837200 -21600 1 MDT}
    {2329372800 -25200 0 MST}
    {2343286800 -21600 1 MDT}
    {2361427200 -25200 0 MST}
    {2374736400 -21600 1 MDT}
    {2392876800 -25200 0 MST}
    {2406186000 -21600 1 MDT}
    {2424326400 -25200 0 MST}
    {2438240400 -21600 1 MDT}
    {2455776000 -25200 0 MST}
    {2469690000 -21600 1 MDT}
    {2487225600 -25200 0 MST}
    {2501139600 -21600 1 MDT}
    {2519280000 -25200 0 MST}
    {2532589200 -21600 1 MDT}
    {2550729600 -25200 0 MST}
    {2564038800 -21600 1 MDT}


    {2582179200 -25200 0 MST}
    {2596093200 -21600 1 MDT}
    {2613628800 -25200 0 MST}
    {2627542800 -21600 1 MDT}
    {2645078400 -25200 0 MST}
    {2658992400 -21600 1 MDT}
    {2676528000 -25200 0 MST}


    {2690442000 -21600 1 MDT}
    {2708582400 -25200 0 MST}
    {2721891600 -21600 1 MDT}
    {2740032000 -25200 0 MST}
    {2753341200 -21600 1 MDT}
    {2771481600 -25200 0 MST}
    {2785395600 -21600 1 MDT}
    {2802931200 -25200 0 MST}
    {2816845200 -21600 1 MDT}
    {2834380800 -25200 0 MST}
    {2848294800 -21600 1 MDT}
    {2866435200 -25200 0 MST}
    {2879744400 -21600 1 MDT}
    {2897884800 -25200 0 MST}
    {2911194000 -21600 1 MDT}
    {2929334400 -25200 0 MST}
    {2942643600 -21600 1 MDT}
    {2960784000 -25200 0 MST}
    {2974698000 -21600 1 MDT}
    {2992233600 -25200 0 MST}
    {3006147600 -21600 1 MDT}
    {3023683200 -25200 0 MST}
    {3037597200 -21600 1 MDT}
    {3055737600 -25200 0 MST}
    {3069046800 -21600 1 MDT}
    {3087187200 -25200 0 MST}
    {3100496400 -21600 1 MDT}
    {3118636800 -25200 0 MST}
    {3132550800 -21600 1 MDT}
    {3150086400 -25200 0 MST}
    {3164000400 -21600 1 MDT}
    {3181536000 -25200 0 MST}
    {3195450000 -21600 1 MDT}
    {3212985600 -25200 0 MST}
    {3226899600 -21600 1 MDT}
    {3245040000 -25200 0 MST}
    {3258349200 -21600 1 MDT}
    {3276489600 -25200 0 MST}
    {3289798800 -21600 1 MDT}
    {3307939200 -25200 0 MST}
    {3321853200 -21600 1 MDT}
    {3339388800 -25200 0 MST}
    {3353302800 -21600 1 MDT}
    {3370838400 -25200 0 MST}
    {3384752400 -21600 1 MDT}
    {3402892800 -25200 0 MST}
    {3416202000 -21600 1 MDT}
    {3434342400 -25200 0 MST}
    {3447651600 -21600 1 MDT}
    {3465792000 -25200 0 MST}
    {3479706000 -21600 1 MDT}
    {3497241600 -25200 0 MST}
    {3511155600 -21600 1 MDT}
    {3528691200 -25200 0 MST}
    {3542605200 -21600 1 MDT}
    {3560140800 -25200 0 MST}
    {3574054800 -21600 1 MDT}
    {3592195200 -25200 0 MST}
    {3605504400 -21600 1 MDT}
    {3623644800 -25200 0 MST}
    {3636954000 -21600 1 MDT}
    {3655094400 -25200 0 MST}
    {3669008400 -21600 1 MDT}
    {3686544000 -25200 0 MST}
    {3700458000 -21600 1 MDT}
    {3717993600 -25200 0 MST}
    {3731907600 -21600 1 MDT}
    {3750048000 -25200 0 MST}
    {3763357200 -21600 1 MDT}
    {3781497600 -25200 0 MST}
    {3794806800 -21600 1 MDT}
    {3812947200 -25200 0 MST}
    {3826256400 -21600 1 MDT}
    {3844396800 -25200 0 MST}
    {3858310800 -21600 1 MDT}
    {3875846400 -25200 0 MST}
    {3889760400 -21600 1 MDT}
    {3907296000 -25200 0 MST}
    {3921210000 -21600 1 MDT}
    {3939350400 -25200 0 MST}
    {3952659600 -21600 1 MDT}
    {3970800000 -25200 0 MST}
    {3984109200 -21600 1 MDT}
    {4002249600 -25200 0 MST}
    {4016163600 -21600 1 MDT}
    {4033699200 -25200 0 MST}
    {4047613200 -21600 1 MDT}
    {4065148800 -25200 0 MST}
    {4079062800 -21600 1 MDT}
    {4096598400 -25200 0 MST}
}







|
|
|
|
|
|
|
|
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140


141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163


164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258


259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280


281
    {1067155200 -25200 0 MST}
    {1081069200 -21600 1 MDT}
    {1099209600 -25200 0 MST}
    {1112518800 -21600 1 MDT}
    {1130659200 -25200 0 MST}
    {1143968400 -21600 1 MDT}
    {1162108800 -25200 0 MST}
    {1173603600 -21600 1 MDT}
    {1194163200 -25200 0 MST}
    {1205053200 -21600 1 MDT}
    {1225612800 -25200 0 MST}
    {1236502800 -21600 1 MDT}
    {1257062400 -25200 0 MST}
    {1268557200 -21600 1 MDT}
    {1289116800 -25200 0 MST}
    {1300006800 -21600 1 MDT}
    {1320566400 -25200 0 MST}
    {1331456400 -21600 1 MDT}
    {1352016000 -25200 0 MST}
    {1362906000 -21600 1 MDT}
    {1383465600 -25200 0 MST}
    {1394355600 -21600 1 MDT}
    {1414915200 -25200 0 MST}
    {1425805200 -21600 1 MDT}
    {1446364800 -25200 0 MST}
    {1457859600 -21600 1 MDT}
    {1478419200 -25200 0 MST}
    {1489309200 -21600 1 MDT}
    {1509868800 -25200 0 MST}
    {1520758800 -21600 1 MDT}
    {1541318400 -25200 0 MST}
    {1552208400 -21600 1 MDT}
    {1572768000 -25200 0 MST}
    {1583658000 -21600 1 MDT}
    {1604217600 -25200 0 MST}
    {1615712400 -21600 1 MDT}
    {1636272000 -25200 0 MST}
    {1647162000 -21600 1 MDT}
    {1667721600 -25200 0 MST}
    {1678611600 -21600 1 MDT}
    {1699171200 -25200 0 MST}
    {1710061200 -21600 1 MDT}
    {1730620800 -25200 0 MST}
    {1741510800 -21600 1 MDT}
    {1762070400 -25200 0 MST}
    {1772960400 -21600 1 MDT}
    {1793520000 -25200 0 MST}
    {1805014800 -21600 1 MDT}
    {1825574400 -25200 0 MST}
    {1836464400 -21600 1 MDT}
    {1857024000 -25200 0 MST}
    {1867914000 -21600 1 MDT}
    {1888473600 -25200 0 MST}


    {1899363600 -21600 1 MDT}
    {1919923200 -25200 0 MST}
    {1930813200 -21600 1 MDT}
    {1951372800 -25200 0 MST}
    {1962867600 -21600 1 MDT}
    {1983427200 -25200 0 MST}
    {1994317200 -21600 1 MDT}
    {2014876800 -25200 0 MST}
    {2025766800 -21600 1 MDT}
    {2046326400 -25200 0 MST}
    {2057216400 -21600 1 MDT}
    {2077776000 -25200 0 MST}
    {2088666000 -21600 1 MDT}
    {2109225600 -25200 0 MST}
    {2120115600 -21600 1 MDT}
    {2140675200 -25200 0 MST}
    {2152170000 -21600 1 MDT}
    {2172729600 -25200 0 MST}
    {2183619600 -21600 1 MDT}
    {2204179200 -25200 0 MST}
    {2215069200 -21600 1 MDT}
    {2235628800 -25200 0 MST}
    {2246518800 -21600 1 MDT}


    {2267078400 -25200 0 MST}
    {2277968400 -21600 1 MDT}
    {2298528000 -25200 0 MST}
    {2309418000 -21600 1 MDT}
    {2329977600 -25200 0 MST}
    {2341472400 -21600 1 MDT}
    {2362032000 -25200 0 MST}
    {2372922000 -21600 1 MDT}
    {2393481600 -25200 0 MST}
    {2404371600 -21600 1 MDT}
    {2424931200 -25200 0 MST}
    {2435821200 -21600 1 MDT}
    {2456380800 -25200 0 MST}
    {2467270800 -21600 1 MDT}
    {2487830400 -25200 0 MST}
    {2499325200 -21600 1 MDT}
    {2519884800 -25200 0 MST}
    {2530774800 -21600 1 MDT}
    {2551334400 -25200 0 MST}
    {2562224400 -21600 1 MDT}
    {2582784000 -25200 0 MST}
    {2593674000 -21600 1 MDT}
    {2614233600 -25200 0 MST}
    {2625123600 -21600 1 MDT}
    {2645683200 -25200 0 MST}
    {2656573200 -21600 1 MDT}
    {2677132800 -25200 0 MST}
    {2688627600 -21600 1 MDT}
    {2709187200 -25200 0 MST}
    {2720077200 -21600 1 MDT}
    {2740636800 -25200 0 MST}
    {2751526800 -21600 1 MDT}
    {2772086400 -25200 0 MST}
    {2782976400 -21600 1 MDT}
    {2803536000 -25200 0 MST}
    {2814426000 -21600 1 MDT}
    {2834985600 -25200 0 MST}
    {2846480400 -21600 1 MDT}
    {2867040000 -25200 0 MST}
    {2877930000 -21600 1 MDT}
    {2898489600 -25200 0 MST}
    {2909379600 -21600 1 MDT}
    {2929939200 -25200 0 MST}
    {2940829200 -21600 1 MDT}
    {2961388800 -25200 0 MST}
    {2972278800 -21600 1 MDT}
    {2992838400 -25200 0 MST}
    {3003728400 -21600 1 MDT}
    {3024288000 -25200 0 MST}
    {3035782800 -21600 1 MDT}
    {3056342400 -25200 0 MST}
    {3067232400 -21600 1 MDT}
    {3087792000 -25200 0 MST}
    {3098682000 -21600 1 MDT}
    {3119241600 -25200 0 MST}
    {3130131600 -21600 1 MDT}
    {3150691200 -25200 0 MST}
    {3161581200 -21600 1 MDT}
    {3182140800 -25200 0 MST}
    {3193030800 -21600 1 MDT}
    {3213590400 -25200 0 MST}
    {3225085200 -21600 1 MDT}
    {3245644800 -25200 0 MST}
    {3256534800 -21600 1 MDT}
    {3277094400 -25200 0 MST}
    {3287984400 -21600 1 MDT}
    {3308544000 -25200 0 MST}
    {3319434000 -21600 1 MDT}
    {3339993600 -25200 0 MST}
    {3350883600 -21600 1 MDT}
    {3371443200 -25200 0 MST}
    {3382938000 -21600 1 MDT}
    {3403497600 -25200 0 MST}
    {3414387600 -21600 1 MDT}
    {3434947200 -25200 0 MST}
    {3445837200 -21600 1 MDT}
    {3466396800 -25200 0 MST}
    {3477286800 -21600 1 MDT}
    {3497846400 -25200 0 MST}
    {3508736400 -21600 1 MDT}
    {3529296000 -25200 0 MST}
    {3540186000 -21600 1 MDT}
    {3560745600 -25200 0 MST}
    {3572240400 -21600 1 MDT}
    {3592800000 -25200 0 MST}
    {3603690000 -21600 1 MDT}
    {3624249600 -25200 0 MST}
    {3635139600 -21600 1 MDT}
    {3655699200 -25200 0 MST}
    {3666589200 -21600 1 MDT}
    {3687148800 -25200 0 MST}
    {3698038800 -21600 1 MDT}
    {3718598400 -25200 0 MST}
    {3730093200 -21600 1 MDT}
    {3750652800 -25200 0 MST}


    {3761542800 -21600 1 MDT}
    {3782102400 -25200 0 MST}
    {3792992400 -21600 1 MDT}
    {3813552000 -25200 0 MST}
    {3824442000 -21600 1 MDT}
    {3845001600 -25200 0 MST}
    {3855891600 -21600 1 MDT}
    {3876451200 -25200 0 MST}
    {3887341200 -21600 1 MDT}
    {3907900800 -25200 0 MST}
    {3919395600 -21600 1 MDT}
    {3939955200 -25200 0 MST}
    {3950845200 -21600 1 MDT}
    {3971404800 -25200 0 MST}
    {3982294800 -21600 1 MDT}
    {4002854400 -25200 0 MST}
    {4013744400 -21600 1 MDT}
    {4034304000 -25200 0 MST}
    {4045194000 -21600 1 MDT}
    {4065753600 -25200 0 MST}
    {4076643600 -21600 1 MDT}
    {4097203200 -25200 0 MST}


}

Changes to library/tzdata/America/Chicago.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Chicago) {
    {-9223372036854775808 -21036 0 LMT}
    {-2717647764 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-1577901600 -21600 0 CST}
    {-1563724800 -18000 1 CDT}
    {-1551632400 -21600 0 CST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Chicago) {
    {-9223372036854775808 -21036 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-1577901600 -21600 0 CST}
    {-1563724800 -18000 1 CDT}
    {-1551632400 -21600 0 CST}
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226




227


228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    {1067151600 -21600 0 CST}
    {1081065600 -18000 1 CDT}
    {1099206000 -21600 0 CST}
    {1112515200 -18000 1 CDT}
    {1130655600 -21600 0 CST}
    {1143964800 -18000 1 CDT}
    {1162105200 -21600 0 CST}
    {1175414400 -18000 1 CDT}
    {1193554800 -21600 0 CST}
    {1207468800 -18000 1 CDT}
    {1225004400 -21600 0 CST}
    {1238918400 -18000 1 CDT}
    {1256454000 -21600 0 CST}
    {1270368000 -18000 1 CDT}
    {1288508400 -21600 0 CST}
    {1301817600 -18000 1 CDT}
    {1319958000 -21600 0 CST}
    {1333267200 -18000 1 CDT}
    {1351407600 -21600 0 CST}
    {1365321600 -18000 1 CDT}
    {1382857200 -21600 0 CST}
    {1396771200 -18000 1 CDT}
    {1414306800 -21600 0 CST}
    {1428220800 -18000 1 CDT}
    {1445756400 -21600 0 CST}
    {1459670400 -18000 1 CDT}
    {1477810800 -21600 0 CST}
    {1491120000 -18000 1 CDT}
    {1509260400 -21600 0 CST}
    {1522569600 -18000 1 CDT}
    {1540710000 -21600 0 CST}
    {1554624000 -18000 1 CDT}
    {1572159600 -21600 0 CST}
    {1586073600 -18000 1 CDT}
    {1603609200 -21600 0 CST}
    {1617523200 -18000 1 CDT}
    {1635663600 -21600 0 CST}
    {1648972800 -18000 1 CDT}
    {1667113200 -21600 0 CST}
    {1680422400 -18000 1 CDT}
    {1698562800 -21600 0 CST}
    {1712476800 -18000 1 CDT}
    {1730012400 -21600 0 CST}
    {1743926400 -18000 1 CDT}
    {1761462000 -21600 0 CST}
    {1775376000 -18000 1 CDT}
    {1792911600 -21600 0 CST}
    {1806825600 -18000 1 CDT}
    {1824966000 -21600 0 CST}
    {1838275200 -18000 1 CDT}
    {1856415600 -21600 0 CST}




    {1869724800 -18000 1 CDT}


    {1887865200 -21600 0 CST}
    {1901779200 -18000 1 CDT}
    {1919314800 -21600 0 CST}
    {1933228800 -18000 1 CDT}
    {1950764400 -21600 0 CST}
    {1964678400 -18000 1 CDT}
    {1982818800 -21600 0 CST}
    {1996128000 -18000 1 CDT}
    {2014268400 -21600 0 CST}
    {2027577600 -18000 1 CDT}
    {2045718000 -21600 0 CST}
    {2059027200 -18000 1 CDT}
    {2077167600 -21600 0 CST}
    {2091081600 -18000 1 CDT}
    {2108617200 -21600 0 CST}
    {2122531200 -18000 1 CDT}
    {2140066800 -21600 0 CST}
    {2153980800 -18000 1 CDT}
    {2172121200 -21600 0 CST}
    {2185430400 -18000 1 CDT}
    {2203570800 -21600 0 CST}
    {2216880000 -18000 1 CDT}
    {2235020400 -21600 0 CST}
    {2248934400 -18000 1 CDT}
    {2266470000 -21600 0 CST}
    {2280384000 -18000 1 CDT}
    {2297919600 -21600 0 CST}
    {2311833600 -18000 1 CDT}
    {2329369200 -21600 0 CST}
    {2343283200 -18000 1 CDT}
    {2361423600 -21600 0 CST}
    {2374732800 -18000 1 CDT}
    {2392873200 -21600 0 CST}
    {2406182400 -18000 1 CDT}
    {2424322800 -21600 0 CST}
    {2438236800 -18000 1 CDT}
    {2455772400 -21600 0 CST}
    {2469686400 -18000 1 CDT}
    {2487222000 -21600 0 CST}
    {2501136000 -18000 1 CDT}
    {2519276400 -21600 0 CST}
    {2532585600 -18000 1 CDT}
    {2550726000 -21600 0 CST}
    {2564035200 -18000 1 CDT}
    {2582175600 -21600 0 CST}
    {2596089600 -18000 1 CDT}
    {2613625200 -21600 0 CST}
    {2627539200 -18000 1 CDT}
    {2645074800 -21600 0 CST}
    {2658988800 -18000 1 CDT}
    {2676524400 -21600 0 CST}
    {2690438400 -18000 1 CDT}
    {2708578800 -21600 0 CST}
    {2721888000 -18000 1 CDT}
    {2740028400 -21600 0 CST}
    {2753337600 -18000 1 CDT}
    {2771478000 -21600 0 CST}
    {2785392000 -18000 1 CDT}
    {2802927600 -21600 0 CST}
    {2816841600 -18000 1 CDT}
    {2834377200 -21600 0 CST}
    {2848291200 -18000 1 CDT}
    {2866431600 -21600 0 CST}
    {2879740800 -18000 1 CDT}
    {2897881200 -21600 0 CST}
    {2911190400 -18000 1 CDT}
    {2929330800 -21600 0 CST}
    {2942640000 -18000 1 CDT}
    {2960780400 -21600 0 CST}
    {2974694400 -18000 1 CDT}
    {2992230000 -21600 0 CST}
    {3006144000 -18000 1 CDT}
    {3023679600 -21600 0 CST}
    {3037593600 -18000 1 CDT}
    {3055734000 -21600 0 CST}
    {3069043200 -18000 1 CDT}
    {3087183600 -21600 0 CST}
    {3100492800 -18000 1 CDT}
    {3118633200 -21600 0 CST}
    {3132547200 -18000 1 CDT}
    {3150082800 -21600 0 CST}
    {3163996800 -18000 1 CDT}
    {3181532400 -21600 0 CST}
    {3195446400 -18000 1 CDT}
    {3212982000 -21600 0 CST}
    {3226896000 -18000 1 CDT}
    {3245036400 -21600 0 CST}
    {3258345600 -18000 1 CDT}
    {3276486000 -21600 0 CST}
    {3289795200 -18000 1 CDT}
    {3307935600 -21600 0 CST}
    {3321849600 -18000 1 CDT}
    {3339385200 -21600 0 CST}
    {3353299200 -18000 1 CDT}
    {3370834800 -21600 0 CST}
    {3384748800 -18000 1 CDT}
    {3402889200 -21600 0 CST}
    {3416198400 -18000 1 CDT}
    {3434338800 -21600 0 CST}
    {3447648000 -18000 1 CDT}
    {3465788400 -21600 0 CST}
    {3479702400 -18000 1 CDT}
    {3497238000 -21600 0 CST}
    {3511152000 -18000 1 CDT}
    {3528687600 -21600 0 CST}
    {3542601600 -18000 1 CDT}
    {3560137200 -21600 0 CST}
    {3574051200 -18000 1 CDT}
    {3592191600 -21600 0 CST}
    {3605500800 -18000 1 CDT}
    {3623641200 -21600 0 CST}
    {3636950400 -18000 1 CDT}
    {3655090800 -21600 0 CST}
    {3669004800 -18000 1 CDT}
    {3686540400 -21600 0 CST}
    {3700454400 -18000 1 CDT}
    {3717990000 -21600 0 CST}
    {3731904000 -18000 1 CDT}
    {3750044400 -21600 0 CST}
    {3763353600 -18000 1 CDT}
    {3781494000 -21600 0 CST}
    {3794803200 -18000 1 CDT}
    {3812943600 -21600 0 CST}
    {3826252800 -18000 1 CDT}
    {3844393200 -21600 0 CST}
    {3858307200 -18000 1 CDT}
    {3875842800 -21600 0 CST}
    {3889756800 -18000 1 CDT}
    {3907292400 -21600 0 CST}
    {3921206400 -18000 1 CDT}
    {3939346800 -21600 0 CST}
    {3952656000 -18000 1 CDT}
    {3970796400 -21600 0 CST}
    {3984105600 -18000 1 CDT}
    {4002246000 -21600 0 CST}
    {4016160000 -18000 1 CDT}
    {4033695600 -21600 0 CST}
    {4047609600 -18000 1 CDT}
    {4065145200 -21600 0 CST}
    {4079059200 -18000 1 CDT}
    {4096594800 -21600 0 CST}
}







|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190


191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297


298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343


344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    {1067151600 -21600 0 CST}
    {1081065600 -18000 1 CDT}
    {1099206000 -21600 0 CST}
    {1112515200 -18000 1 CDT}
    {1130655600 -21600 0 CST}
    {1143964800 -18000 1 CDT}
    {1162105200 -21600 0 CST}
    {1173600000 -18000 1 CDT}
    {1194159600 -21600 0 CST}
    {1205049600 -18000 1 CDT}
    {1225609200 -21600 0 CST}
    {1236499200 -18000 1 CDT}
    {1257058800 -21600 0 CST}
    {1268553600 -18000 1 CDT}
    {1289113200 -21600 0 CST}


    {1300003200 -18000 1 CDT}
    {1320562800 -21600 0 CST}
    {1331452800 -18000 1 CDT}
    {1352012400 -21600 0 CST}
    {1362902400 -18000 1 CDT}
    {1383462000 -21600 0 CST}
    {1394352000 -18000 1 CDT}
    {1414911600 -21600 0 CST}
    {1425801600 -18000 1 CDT}
    {1446361200 -21600 0 CST}
    {1457856000 -18000 1 CDT}
    {1478415600 -21600 0 CST}
    {1489305600 -18000 1 CDT}
    {1509865200 -21600 0 CST}
    {1520755200 -18000 1 CDT}
    {1541314800 -21600 0 CST}
    {1552204800 -18000 1 CDT}
    {1572764400 -21600 0 CST}
    {1583654400 -18000 1 CDT}
    {1604214000 -21600 0 CST}
    {1615708800 -18000 1 CDT}
    {1636268400 -21600 0 CST}
    {1647158400 -18000 1 CDT}
    {1667718000 -21600 0 CST}
    {1678608000 -18000 1 CDT}
    {1699167600 -21600 0 CST}
    {1710057600 -18000 1 CDT}
    {1730617200 -21600 0 CST}
    {1741507200 -18000 1 CDT}
    {1762066800 -21600 0 CST}
    {1772956800 -18000 1 CDT}
    {1793516400 -21600 0 CST}
    {1805011200 -18000 1 CDT}
    {1825570800 -21600 0 CST}
    {1836460800 -18000 1 CDT}
    {1857020400 -21600 0 CST}
    {1867910400 -18000 1 CDT}
    {1888470000 -21600 0 CST}
    {1899360000 -18000 1 CDT}
    {1919919600 -21600 0 CST}
    {1930809600 -18000 1 CDT}
    {1951369200 -21600 0 CST}
    {1962864000 -18000 1 CDT}
    {1983423600 -21600 0 CST}
    {1994313600 -18000 1 CDT}
    {2014873200 -21600 0 CST}
    {2025763200 -18000 1 CDT}
    {2046322800 -21600 0 CST}
    {2057212800 -18000 1 CDT}
    {2077772400 -21600 0 CST}
    {2088662400 -18000 1 CDT}
    {2109222000 -21600 0 CST}
    {2120112000 -18000 1 CDT}
    {2140671600 -21600 0 CST}
    {2152166400 -18000 1 CDT}
    {2172726000 -21600 0 CST}
    {2183616000 -18000 1 CDT}
    {2204175600 -21600 0 CST}
    {2215065600 -18000 1 CDT}
    {2235625200 -21600 0 CST}
    {2246515200 -18000 1 CDT}
    {2267074800 -21600 0 CST}
    {2277964800 -18000 1 CDT}
    {2298524400 -21600 0 CST}
    {2309414400 -18000 1 CDT}
    {2329974000 -21600 0 CST}
    {2341468800 -18000 1 CDT}
    {2362028400 -21600 0 CST}
    {2372918400 -18000 1 CDT}
    {2393478000 -21600 0 CST}
    {2404368000 -18000 1 CDT}
    {2424927600 -21600 0 CST}
    {2435817600 -18000 1 CDT}
    {2456377200 -21600 0 CST}
    {2467267200 -18000 1 CDT}
    {2487826800 -21600 0 CST}
    {2499321600 -18000 1 CDT}
    {2519881200 -21600 0 CST}
    {2530771200 -18000 1 CDT}
    {2551330800 -21600 0 CST}
    {2562220800 -18000 1 CDT}
    {2582780400 -21600 0 CST}
    {2593670400 -18000 1 CDT}
    {2614230000 -21600 0 CST}
    {2625120000 -18000 1 CDT}
    {2645679600 -21600 0 CST}
    {2656569600 -18000 1 CDT}
    {2677129200 -21600 0 CST}
    {2688624000 -18000 1 CDT}
    {2709183600 -21600 0 CST}
    {2720073600 -18000 1 CDT}
    {2740633200 -21600 0 CST}
    {2751523200 -18000 1 CDT}
    {2772082800 -21600 0 CST}
    {2782972800 -18000 1 CDT}
    {2803532400 -21600 0 CST}
    {2814422400 -18000 1 CDT}
    {2834982000 -21600 0 CST}
    {2846476800 -18000 1 CDT}
    {2867036400 -21600 0 CST}
    {2877926400 -18000 1 CDT}
    {2898486000 -21600 0 CST}
    {2909376000 -18000 1 CDT}
    {2929935600 -21600 0 CST}
    {2940825600 -18000 1 CDT}
    {2961385200 -21600 0 CST}
    {2972275200 -18000 1 CDT}


    {2992834800 -21600 0 CST}
    {3003724800 -18000 1 CDT}
    {3024284400 -21600 0 CST}
    {3035779200 -18000 1 CDT}
    {3056338800 -21600 0 CST}
    {3067228800 -18000 1 CDT}
    {3087788400 -21600 0 CST}
    {3098678400 -18000 1 CDT}
    {3119238000 -21600 0 CST}
    {3130128000 -18000 1 CDT}
    {3150687600 -21600 0 CST}
    {3161577600 -18000 1 CDT}
    {3182137200 -21600 0 CST}
    {3193027200 -18000 1 CDT}
    {3213586800 -21600 0 CST}
    {3225081600 -18000 1 CDT}
    {3245641200 -21600 0 CST}
    {3256531200 -18000 1 CDT}
    {3277090800 -21600 0 CST}
    {3287980800 -18000 1 CDT}
    {3308540400 -21600 0 CST}
    {3319430400 -18000 1 CDT}
    {3339990000 -21600 0 CST}
    {3350880000 -18000 1 CDT}
    {3371439600 -21600 0 CST}
    {3382934400 -18000 1 CDT}
    {3403494000 -21600 0 CST}
    {3414384000 -18000 1 CDT}
    {3434943600 -21600 0 CST}
    {3445833600 -18000 1 CDT}
    {3466393200 -21600 0 CST}
    {3477283200 -18000 1 CDT}
    {3497842800 -21600 0 CST}
    {3508732800 -18000 1 CDT}
    {3529292400 -21600 0 CST}
    {3540182400 -18000 1 CDT}
    {3560742000 -21600 0 CST}
    {3572236800 -18000 1 CDT}
    {3592796400 -21600 0 CST}
    {3603686400 -18000 1 CDT}
    {3624246000 -21600 0 CST}
    {3635136000 -18000 1 CDT}
    {3655695600 -21600 0 CST}
    {3666585600 -18000 1 CDT}
    {3687145200 -21600 0 CST}
    {3698035200 -18000 1 CDT}


    {3718594800 -21600 0 CST}
    {3730089600 -18000 1 CDT}
    {3750649200 -21600 0 CST}
    {3761539200 -18000 1 CDT}
    {3782098800 -21600 0 CST}
    {3792988800 -18000 1 CDT}
    {3813548400 -21600 0 CST}
    {3824438400 -18000 1 CDT}
    {3844998000 -21600 0 CST}
    {3855888000 -18000 1 CDT}
    {3876447600 -21600 0 CST}
    {3887337600 -18000 1 CDT}
    {3907897200 -21600 0 CST}
    {3919392000 -18000 1 CDT}
    {3939951600 -21600 0 CST}
    {3950841600 -18000 1 CDT}
    {3971401200 -21600 0 CST}
    {3982291200 -18000 1 CDT}
    {4002850800 -21600 0 CST}
    {4013740800 -18000 1 CDT}
    {4034300400 -21600 0 CST}
    {4045190400 -18000 1 CDT}
    {4065750000 -21600 0 CST}
    {4076640000 -18000 1 CDT}
    {4097199600 -21600 0 CST}
}

Added library/tzdata/America/Coral_Harbour.





























>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Coral_Harbour) {
    {-9223372036854775808 -19960 0 LMT}
    {-2713890440 -18000 0 EST}
    {-1632070800 -14400 1 EDT}
    {-1615140000 -18000 0 EST}
    {-1596992400 -14400 1 EDT}
    {-1583179200 -18000 0 EST}
    {-880218000 -14400 1 EWT}
    {-769395600 -14400 1 EPT}
    {-765396000 -18000 0 EST}
    {-757364400 -18000 0 EST}
}

Changes to library/tzdata/America/Denver.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Denver) {
    {-9223372036854775808 -25196 0 LMT}
    {-2717643604 -25200 0 MST}
    {-1633273200 -21600 1 MDT}
    {-1615132800 -25200 0 MST}
    {-1601823600 -21600 1 MDT}
    {-1583683200 -25200 0 MST}
    {-1577898000 -25200 0 MST}
    {-1570374000 -21600 1 MDT}
    {-1551628800 -25200 0 MST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Denver) {
    {-9223372036854775808 -25196 0 LMT}
    {-2717643600 -25200 0 MST}
    {-1633273200 -21600 1 MDT}
    {-1615132800 -25200 0 MST}
    {-1601823600 -21600 1 MDT}
    {-1583683200 -25200 0 MST}
    {-1577898000 -25200 0 MST}
    {-1570374000 -21600 1 MDT}
    {-1551628800 -25200 0 MST}
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112


113


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193


194
195
196
197
198
199
200


201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
    {1067155200 -25200 0 MST}
    {1081069200 -21600 1 MDT}
    {1099209600 -25200 0 MST}
    {1112518800 -21600 1 MDT}
    {1130659200 -25200 0 MST}
    {1143968400 -21600 1 MDT}
    {1162108800 -25200 0 MST}
    {1175418000 -21600 1 MDT}
    {1193558400 -25200 0 MST}
    {1207472400 -21600 1 MDT}
    {1225008000 -25200 0 MST}
    {1238922000 -21600 1 MDT}
    {1256457600 -25200 0 MST}
    {1270371600 -21600 1 MDT}
    {1288512000 -25200 0 MST}


    {1301821200 -21600 1 MDT}


    {1319961600 -25200 0 MST}
    {1333270800 -21600 1 MDT}
    {1351411200 -25200 0 MST}
    {1365325200 -21600 1 MDT}
    {1382860800 -25200 0 MST}
    {1396774800 -21600 1 MDT}
    {1414310400 -25200 0 MST}
    {1428224400 -21600 1 MDT}
    {1445760000 -25200 0 MST}
    {1459674000 -21600 1 MDT}
    {1477814400 -25200 0 MST}
    {1491123600 -21600 1 MDT}
    {1509264000 -25200 0 MST}
    {1522573200 -21600 1 MDT}
    {1540713600 -25200 0 MST}
    {1554627600 -21600 1 MDT}
    {1572163200 -25200 0 MST}
    {1586077200 -21600 1 MDT}
    {1603612800 -25200 0 MST}
    {1617526800 -21600 1 MDT}
    {1635667200 -25200 0 MST}
    {1648976400 -21600 1 MDT}
    {1667116800 -25200 0 MST}
    {1680426000 -21600 1 MDT}
    {1698566400 -25200 0 MST}
    {1712480400 -21600 1 MDT}
    {1730016000 -25200 0 MST}
    {1743930000 -21600 1 MDT}
    {1761465600 -25200 0 MST}
    {1775379600 -21600 1 MDT}
    {1792915200 -25200 0 MST}
    {1806829200 -21600 1 MDT}
    {1824969600 -25200 0 MST}
    {1838278800 -21600 1 MDT}
    {1856419200 -25200 0 MST}
    {1869728400 -21600 1 MDT}
    {1887868800 -25200 0 MST}
    {1901782800 -21600 1 MDT}
    {1919318400 -25200 0 MST}
    {1933232400 -21600 1 MDT}
    {1950768000 -25200 0 MST}
    {1964682000 -21600 1 MDT}
    {1982822400 -25200 0 MST}
    {1996131600 -21600 1 MDT}
    {2014272000 -25200 0 MST}
    {2027581200 -21600 1 MDT}
    {2045721600 -25200 0 MST}
    {2059030800 -21600 1 MDT}
    {2077171200 -25200 0 MST}
    {2091085200 -21600 1 MDT}
    {2108620800 -25200 0 MST}
    {2122534800 -21600 1 MDT}
    {2140070400 -25200 0 MST}
    {2153984400 -21600 1 MDT}
    {2172124800 -25200 0 MST}
    {2185434000 -21600 1 MDT}
    {2203574400 -25200 0 MST}
    {2216883600 -21600 1 MDT}
    {2235024000 -25200 0 MST}
    {2248938000 -21600 1 MDT}
    {2266473600 -25200 0 MST}
    {2280387600 -21600 1 MDT}
    {2297923200 -25200 0 MST}
    {2311837200 -21600 1 MDT}
    {2329372800 -25200 0 MST}
    {2343286800 -21600 1 MDT}
    {2361427200 -25200 0 MST}
    {2374736400 -21600 1 MDT}
    {2392876800 -25200 0 MST}
    {2406186000 -21600 1 MDT}
    {2424326400 -25200 0 MST}
    {2438240400 -21600 1 MDT}
    {2455776000 -25200 0 MST}
    {2469690000 -21600 1 MDT}
    {2487225600 -25200 0 MST}
    {2501139600 -21600 1 MDT}
    {2519280000 -25200 0 MST}
    {2532589200 -21600 1 MDT}
    {2550729600 -25200 0 MST}
    {2564038800 -21600 1 MDT}


    {2582179200 -25200 0 MST}
    {2596093200 -21600 1 MDT}
    {2613628800 -25200 0 MST}
    {2627542800 -21600 1 MDT}
    {2645078400 -25200 0 MST}
    {2658992400 -21600 1 MDT}
    {2676528000 -25200 0 MST}


    {2690442000 -21600 1 MDT}
    {2708582400 -25200 0 MST}
    {2721891600 -21600 1 MDT}
    {2740032000 -25200 0 MST}
    {2753341200 -21600 1 MDT}
    {2771481600 -25200 0 MST}
    {2785395600 -21600 1 MDT}
    {2802931200 -25200 0 MST}
    {2816845200 -21600 1 MDT}
    {2834380800 -25200 0 MST}
    {2848294800 -21600 1 MDT}
    {2866435200 -25200 0 MST}
    {2879744400 -21600 1 MDT}
    {2897884800 -25200 0 MST}
    {2911194000 -21600 1 MDT}
    {2929334400 -25200 0 MST}
    {2942643600 -21600 1 MDT}
    {2960784000 -25200 0 MST}
    {2974698000 -21600 1 MDT}
    {2992233600 -25200 0 MST}
    {3006147600 -21600 1 MDT}
    {3023683200 -25200 0 MST}
    {3037597200 -21600 1 MDT}
    {3055737600 -25200 0 MST}
    {3069046800 -21600 1 MDT}
    {3087187200 -25200 0 MST}
    {3100496400 -21600 1 MDT}
    {3118636800 -25200 0 MST}
    {3132550800 -21600 1 MDT}
    {3150086400 -25200 0 MST}
    {3164000400 -21600 1 MDT}
    {3181536000 -25200 0 MST}
    {3195450000 -21600 1 MDT}
    {3212985600 -25200 0 MST}
    {3226899600 -21600 1 MDT}
    {3245040000 -25200 0 MST}
    {3258349200 -21600 1 MDT}
    {3276489600 -25200 0 MST}
    {3289798800 -21600 1 MDT}
    {3307939200 -25200 0 MST}
    {3321853200 -21600 1 MDT}
    {3339388800 -25200 0 MST}
    {3353302800 -21600 1 MDT}
    {3370838400 -25200 0 MST}
    {3384752400 -21600 1 MDT}
    {3402892800 -25200 0 MST}
    {3416202000 -21600 1 MDT}
    {3434342400 -25200 0 MST}
    {3447651600 -21600 1 MDT}
    {3465792000 -25200 0 MST}
    {3479706000 -21600 1 MDT}
    {3497241600 -25200 0 MST}
    {3511155600 -21600 1 MDT}
    {3528691200 -25200 0 MST}
    {3542605200 -21600 1 MDT}
    {3560140800 -25200 0 MST}
    {3574054800 -21600 1 MDT}
    {3592195200 -25200 0 MST}
    {3605504400 -21600 1 MDT}
    {3623644800 -25200 0 MST}
    {3636954000 -21600 1 MDT}
    {3655094400 -25200 0 MST}
    {3669008400 -21600 1 MDT}
    {3686544000 -25200 0 MST}
    {3700458000 -21600 1 MDT}
    {3717993600 -25200 0 MST}
    {3731907600 -21600 1 MDT}
    {3750048000 -25200 0 MST}
    {3763357200 -21600 1 MDT}
    {3781497600 -25200 0 MST}
    {3794806800 -21600 1 MDT}
    {3812947200 -25200 0 MST}
    {3826256400 -21600 1 MDT}
    {3844396800 -25200 0 MST}
    {3858310800 -21600 1 MDT}
    {3875846400 -25200 0 MST}
    {3889760400 -21600 1 MDT}
    {3907296000 -25200 0 MST}
    {3921210000 -21600 1 MDT}
    {3939350400 -25200 0 MST}
    {3952659600 -21600 1 MDT}
    {3970800000 -25200 0 MST}
    {3984109200 -21600 1 MDT}
    {4002249600 -25200 0 MST}
    {4016163600 -21600 1 MDT}
    {4033699200 -25200 0 MST}
    {4047613200 -21600 1 MDT}
    {4065148800 -25200 0 MST}
    {4079062800 -21600 1 MDT}
    {4096598400 -25200 0 MST}
}







|
|
|
|
|
|
|
|
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<

98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150


151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173


174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268


269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290


291
    {1067155200 -25200 0 MST}
    {1081069200 -21600 1 MDT}
    {1099209600 -25200 0 MST}
    {1112518800 -21600 1 MDT}
    {1130659200 -25200 0 MST}
    {1143968400 -21600 1 MDT}
    {1162108800 -25200 0 MST}
    {1173603600 -21600 1 MDT}
    {1194163200 -25200 0 MST}
    {1205053200 -21600 1 MDT}
    {1225612800 -25200 0 MST}
    {1236502800 -21600 1 MDT}
    {1257062400 -25200 0 MST}
    {1268557200 -21600 1 MDT}
    {1289116800 -25200 0 MST}
    {1300006800 -21600 1 MDT}
    {1320566400 -25200 0 MST}
    {1331456400 -21600 1 MDT}
    {1352016000 -25200 0 MST}
    {1362906000 -21600 1 MDT}
    {1383465600 -25200 0 MST}
    {1394355600 -21600 1 MDT}
    {1414915200 -25200 0 MST}
    {1425805200 -21600 1 MDT}
    {1446364800 -25200 0 MST}
    {1457859600 -21600 1 MDT}
    {1478419200 -25200 0 MST}
    {1489309200 -21600 1 MDT}
    {1509868800 -25200 0 MST}
    {1520758800 -21600 1 MDT}
    {1541318400 -25200 0 MST}
    {1552208400 -21600 1 MDT}
    {1572768000 -25200 0 MST}
    {1583658000 -21600 1 MDT}
    {1604217600 -25200 0 MST}
    {1615712400 -21600 1 MDT}
    {1636272000 -25200 0 MST}
    {1647162000 -21600 1 MDT}
    {1667721600 -25200 0 MST}
    {1678611600 -21600 1 MDT}
    {1699171200 -25200 0 MST}
    {1710061200 -21600 1 MDT}
    {1730620800 -25200 0 MST}
    {1741510800 -21600 1 MDT}
    {1762070400 -25200 0 MST}
    {1772960400 -21600 1 MDT}
    {1793520000 -25200 0 MST}
    {1805014800 -21600 1 MDT}
    {1825574400 -25200 0 MST}
    {1836464400 -21600 1 MDT}
    {1857024000 -25200 0 MST}
    {1867914000 -21600 1 MDT}
    {1888473600 -25200 0 MST}


    {1899363600 -21600 1 MDT}
    {1919923200 -25200 0 MST}
    {1930813200 -21600 1 MDT}
    {1951372800 -25200 0 MST}
    {1962867600 -21600 1 MDT}
    {1983427200 -25200 0 MST}
    {1994317200 -21600 1 MDT}
    {2014876800 -25200 0 MST}
    {2025766800 -21600 1 MDT}
    {2046326400 -25200 0 MST}
    {2057216400 -21600 1 MDT}
    {2077776000 -25200 0 MST}
    {2088666000 -21600 1 MDT}
    {2109225600 -25200 0 MST}
    {2120115600 -21600 1 MDT}
    {2140675200 -25200 0 MST}
    {2152170000 -21600 1 MDT}
    {2172729600 -25200 0 MST}
    {2183619600 -21600 1 MDT}
    {2204179200 -25200 0 MST}
    {2215069200 -21600 1 MDT}
    {2235628800 -25200 0 MST}
    {2246518800 -21600 1 MDT}


    {2267078400 -25200 0 MST}
    {2277968400 -21600 1 MDT}
    {2298528000 -25200 0 MST}
    {2309418000 -21600 1 MDT}
    {2329977600 -25200 0 MST}
    {2341472400 -21600 1 MDT}
    {2362032000 -25200 0 MST}
    {2372922000 -21600 1 MDT}
    {2393481600 -25200 0 MST}
    {2404371600 -21600 1 MDT}
    {2424931200 -25200 0 MST}
    {2435821200 -21600 1 MDT}
    {2456380800 -25200 0 MST}
    {2467270800 -21600 1 MDT}
    {2487830400 -25200 0 MST}
    {2499325200 -21600 1 MDT}
    {2519884800 -25200 0 MST}
    {2530774800 -21600 1 MDT}
    {2551334400 -25200 0 MST}
    {2562224400 -21600 1 MDT}
    {2582784000 -25200 0 MST}
    {2593674000 -21600 1 MDT}
    {2614233600 -25200 0 MST}
    {2625123600 -21600 1 MDT}
    {2645683200 -25200 0 MST}
    {2656573200 -21600 1 MDT}
    {2677132800 -25200 0 MST}
    {2688627600 -21600 1 MDT}
    {2709187200 -25200 0 MST}
    {2720077200 -21600 1 MDT}
    {2740636800 -25200 0 MST}
    {2751526800 -21600 1 MDT}
    {2772086400 -25200 0 MST}
    {2782976400 -21600 1 MDT}
    {2803536000 -25200 0 MST}
    {2814426000 -21600 1 MDT}
    {2834985600 -25200 0 MST}
    {2846480400 -21600 1 MDT}
    {2867040000 -25200 0 MST}
    {2877930000 -21600 1 MDT}
    {2898489600 -25200 0 MST}
    {2909379600 -21600 1 MDT}
    {2929939200 -25200 0 MST}
    {2940829200 -21600 1 MDT}
    {2961388800 -25200 0 MST}
    {2972278800 -21600 1 MDT}
    {2992838400 -25200 0 MST}
    {3003728400 -21600 1 MDT}
    {3024288000 -25200 0 MST}
    {3035782800 -21600 1 MDT}
    {3056342400 -25200 0 MST}
    {3067232400 -21600 1 MDT}
    {3087792000 -25200 0 MST}
    {3098682000 -21600 1 MDT}
    {3119241600 -25200 0 MST}
    {3130131600 -21600 1 MDT}
    {3150691200 -25200 0 MST}
    {3161581200 -21600 1 MDT}
    {3182140800 -25200 0 MST}
    {3193030800 -21600 1 MDT}
    {3213590400 -25200 0 MST}
    {3225085200 -21600 1 MDT}
    {3245644800 -25200 0 MST}
    {3256534800 -21600 1 MDT}
    {3277094400 -25200 0 MST}
    {3287984400 -21600 1 MDT}
    {3308544000 -25200 0 MST}
    {3319434000 -21600 1 MDT}
    {3339993600 -25200 0 MST}
    {3350883600 -21600 1 MDT}
    {3371443200 -25200 0 MST}
    {3382938000 -21600 1 MDT}
    {3403497600 -25200 0 MST}
    {3414387600 -21600 1 MDT}
    {3434947200 -25200 0 MST}
    {3445837200 -21600 1 MDT}
    {3466396800 -25200 0 MST}
    {3477286800 -21600 1 MDT}
    {3497846400 -25200 0 MST}
    {3508736400 -21600 1 MDT}
    {3529296000 -25200 0 MST}
    {3540186000 -21600 1 MDT}
    {3560745600 -25200 0 MST}
    {3572240400 -21600 1 MDT}
    {3592800000 -25200 0 MST}
    {3603690000 -21600 1 MDT}
    {3624249600 -25200 0 MST}
    {3635139600 -21600 1 MDT}
    {3655699200 -25200 0 MST}
    {3666589200 -21600 1 MDT}
    {3687148800 -25200 0 MST}
    {3698038800 -21600 1 MDT}
    {3718598400 -25200 0 MST}
    {3730093200 -21600 1 MDT}
    {3750652800 -25200 0 MST}


    {3761542800 -21600 1 MDT}
    {3782102400 -25200 0 MST}
    {3792992400 -21600 1 MDT}
    {3813552000 -25200 0 MST}
    {3824442000 -21600 1 MDT}
    {3845001600 -25200 0 MST}
    {3855891600 -21600 1 MDT}
    {3876451200 -25200 0 MST}
    {3887341200 -21600 1 MDT}
    {3907900800 -25200 0 MST}
    {3919395600 -21600 1 MDT}
    {3939955200 -25200 0 MST}
    {3950845200 -21600 1 MDT}
    {3971404800 -25200 0 MST}
    {3982294800 -21600 1 MDT}
    {4002854400 -25200 0 MST}
    {4013744400 -21600 1 MDT}
    {4034304000 -25200 0 MST}
    {4045194000 -21600 1 MDT}
    {4065753600 -25200 0 MST}
    {4076643600 -21600 1 MDT}
    {4097203200 -25200 0 MST}


}

Changes to library/tzdata/America/Detroit.

79
80
81
82
83
84
85
86
87


88
89


90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136


137
138
139
140
141
142
143
144
145
146


147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1175410800 -14400 1 EDT}
    {1193551200 -18000 0 EST}


    {1207465200 -14400 1 EDT}
    {1225000800 -18000 0 EST}


    {1238914800 -14400 1 EDT}
    {1256450400 -18000 0 EST}
    {1270364400 -14400 1 EDT}
    {1288504800 -18000 0 EST}
    {1301814000 -14400 1 EDT}
    {1319954400 -18000 0 EST}
    {1333263600 -14400 1 EDT}
    {1351404000 -18000 0 EST}
    {1365318000 -14400 1 EDT}
    {1382853600 -18000 0 EST}
    {1396767600 -14400 1 EDT}
    {1414303200 -18000 0 EST}
    {1428217200 -14400 1 EDT}
    {1445752800 -18000 0 EST}
    {1459666800 -14400 1 EDT}
    {1477807200 -18000 0 EST}
    {1491116400 -14400 1 EDT}
    {1509256800 -18000 0 EST}
    {1522566000 -14400 1 EDT}
    {1540706400 -18000 0 EST}
    {1554620400 -14400 1 EDT}
    {1572156000 -18000 0 EST}
    {1586070000 -14400 1 EDT}
    {1603605600 -18000 0 EST}
    {1617519600 -14400 1 EDT}
    {1635660000 -18000 0 EST}
    {1648969200 -14400 1 EDT}
    {1667109600 -18000 0 EST}
    {1680418800 -14400 1 EDT}
    {1698559200 -18000 0 EST}
    {1712473200 -14400 1 EDT}
    {1730008800 -18000 0 EST}
    {1743922800 -14400 1 EDT}
    {1761458400 -18000 0 EST}
    {1775372400 -14400 1 EDT}
    {1792908000 -18000 0 EST}
    {1806822000 -14400 1 EDT}
    {1824962400 -18000 0 EST}
    {1838271600 -14400 1 EDT}
    {1856412000 -18000 0 EST}
    {1869721200 -14400 1 EDT}
    {1887861600 -18000 0 EST}
    {1901775600 -14400 1 EDT}
    {1919311200 -18000 0 EST}
    {1933225200 -14400 1 EDT}
    {1950760800 -18000 0 EST}
    {1964674800 -14400 1 EDT}


    {1982815200 -18000 0 EST}
    {1996124400 -14400 1 EDT}
    {2014264800 -18000 0 EST}
    {2027574000 -14400 1 EDT}
    {2045714400 -18000 0 EST}
    {2059023600 -14400 1 EDT}
    {2077164000 -18000 0 EST}
    {2091078000 -14400 1 EDT}
    {2108613600 -18000 0 EST}
    {2122527600 -14400 1 EDT}


    {2140063200 -18000 0 EST}
    {2153977200 -14400 1 EDT}
    {2172117600 -18000 0 EST}
    {2185426800 -14400 1 EDT}
    {2203567200 -18000 0 EST}
    {2216876400 -14400 1 EDT}
    {2235016800 -18000 0 EST}
    {2248930800 -14400 1 EDT}
    {2266466400 -18000 0 EST}
    {2280380400 -14400 1 EDT}
    {2297916000 -18000 0 EST}
    {2311830000 -14400 1 EDT}
    {2329365600 -18000 0 EST}
    {2343279600 -14400 1 EDT}
    {2361420000 -18000 0 EST}
    {2374729200 -14400 1 EDT}
    {2392869600 -18000 0 EST}
    {2406178800 -14400 1 EDT}
    {2424319200 -18000 0 EST}
    {2438233200 -14400 1 EDT}
    {2455768800 -18000 0 EST}
    {2469682800 -14400 1 EDT}
    {2487218400 -18000 0 EST}
    {2501132400 -14400 1 EDT}
    {2519272800 -18000 0 EST}
    {2532582000 -14400 1 EDT}
    {2550722400 -18000 0 EST}
    {2564031600 -14400 1 EDT}
    {2582172000 -18000 0 EST}
    {2596086000 -14400 1 EDT}
    {2613621600 -18000 0 EST}
    {2627535600 -14400 1 EDT}
    {2645071200 -18000 0 EST}
    {2658985200 -14400 1 EDT}
    {2676520800 -18000 0 EST}
    {2690434800 -14400 1 EDT}
    {2708575200 -18000 0 EST}
    {2721884400 -14400 1 EDT}
    {2740024800 -18000 0 EST}
    {2753334000 -14400 1 EDT}
    {2771474400 -18000 0 EST}
    {2785388400 -14400 1 EDT}
    {2802924000 -18000 0 EST}
    {2816838000 -14400 1 EDT}
    {2834373600 -18000 0 EST}
    {2848287600 -14400 1 EDT}
    {2866428000 -18000 0 EST}
    {2879737200 -14400 1 EDT}
    {2897877600 -18000 0 EST}
    {2911186800 -14400 1 EDT}
    {2929327200 -18000 0 EST}
    {2942636400 -14400 1 EDT}
    {2960776800 -18000 0 EST}
    {2974690800 -14400 1 EDT}
    {2992226400 -18000 0 EST}
    {3006140400 -14400 1 EDT}
    {3023676000 -18000 0 EST}
    {3037590000 -14400 1 EDT}
    {3055730400 -18000 0 EST}
    {3069039600 -14400 1 EDT}
    {3087180000 -18000 0 EST}
    {3100489200 -14400 1 EDT}
    {3118629600 -18000 0 EST}
    {3132543600 -14400 1 EDT}
    {3150079200 -18000 0 EST}
    {3163993200 -14400 1 EDT}
    {3181528800 -18000 0 EST}
    {3195442800 -14400 1 EDT}
    {3212978400 -18000 0 EST}
    {3226892400 -14400 1 EDT}
    {3245032800 -18000 0 EST}
    {3258342000 -14400 1 EDT}
    {3276482400 -18000 0 EST}
    {3289791600 -14400 1 EDT}
    {3307932000 -18000 0 EST}
    {3321846000 -14400 1 EDT}
    {3339381600 -18000 0 EST}
    {3353295600 -14400 1 EDT}
    {3370831200 -18000 0 EST}
    {3384745200 -14400 1 EDT}
    {3402885600 -18000 0 EST}
    {3416194800 -14400 1 EDT}
    {3434335200 -18000 0 EST}
    {3447644400 -14400 1 EDT}
    {3465784800 -18000 0 EST}
    {3479698800 -14400 1 EDT}
    {3497234400 -18000 0 EST}
    {3511148400 -14400 1 EDT}
    {3528684000 -18000 0 EST}
    {3542598000 -14400 1 EDT}
    {3560133600 -18000 0 EST}
    {3574047600 -14400 1 EDT}
    {3592188000 -18000 0 EST}
    {3605497200 -14400 1 EDT}
    {3623637600 -18000 0 EST}
    {3636946800 -14400 1 EDT}
    {3655087200 -18000 0 EST}
    {3669001200 -14400 1 EDT}
    {3686536800 -18000 0 EST}
    {3700450800 -14400 1 EDT}
    {3717986400 -18000 0 EST}
    {3731900400 -14400 1 EDT}
    {3750040800 -18000 0 EST}
    {3763350000 -14400 1 EDT}
    {3781490400 -18000 0 EST}
    {3794799600 -14400 1 EDT}
    {3812940000 -18000 0 EST}
    {3826249200 -14400 1 EDT}
    {3844389600 -18000 0 EST}
    {3858303600 -14400 1 EDT}
    {3875839200 -18000 0 EST}
    {3889753200 -14400 1 EDT}
    {3907288800 -18000 0 EST}
    {3921202800 -14400 1 EDT}
    {3939343200 -18000 0 EST}
    {3952652400 -14400 1 EDT}
    {3970792800 -18000 0 EST}
    {3984102000 -14400 1 EDT}
    {4002242400 -18000 0 EST}
    {4016156400 -14400 1 EDT}
    {4033692000 -18000 0 EST}
    {4047606000 -14400 1 EDT}
    {4065141600 -18000 0 EST}
    {4079055600 -14400 1 EDT}
    {4096591200 -18000 0 EST}
}







|
|
>
>
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131


132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157


158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200


201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222


223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}


    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}


    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}


    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}


    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Fort_Wayne.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indianapolis)]} {
    LoadTimeZoneFile America/Indianapolis
}
set TZData(:America/Fort_Wayne) $TZData(:America/Indianapolis)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indiana/Indianapolis)]} {
    LoadTimeZoneFile America/Indiana/Indianapolis
}
set TZData(:America/Fort_Wayne) $TZData(:America/Indiana/Indianapolis)

Changes to library/tzdata/America/Indiana/Indianapolis.

1
2
3
4
5







































































































































































































































# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indianapolis)]} {
    LoadTimeZoneFile America/Indianapolis
}
set TZData(:America/Indiana/Indianapolis) $TZData(:America/Indianapolis)








































































































































































































































<
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1


2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
# created by ../tools/tclZIC.tcl - do not edit



set TZData(:America/Indiana/Indianapolis) {
    {-9223372036854775808 -20678 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-1577901600 -21600 0 CST}
    {-900259200 -18000 1 CDT}
    {-891795600 -21600 0 CST}
    {-883591200 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
    {-757360800 -21600 0 CST}
    {-747244800 -18000 1 CDT}
    {-733942800 -21600 0 CST}
    {-715795200 -18000 1 CDT}
    {-702493200 -21600 0 CST}
    {-684345600 -18000 1 CDT}
    {-671043600 -21600 0 CST}
    {-652896000 -18000 1 CDT}
    {-639594000 -21600 0 CST}
    {-620841600 -18000 1 CDT}
    {-608144400 -21600 0 CST}
    {-589392000 -18000 1 CDT}
    {-576090000 -21600 0 CST}
    {-557942400 -18000 1 CDT}
    {-544640400 -21600 0 CST}
    {-526492800 -18000 1 CDT}
    {-513190800 -21600 0 CST}
    {-495043200 -18000 1 CDT}
    {-481741200 -21600 0 CST}
    {-463593600 -18000 0 EST}
    {-386787600 -21600 0 CST}
    {-368640000 -18000 0 EST}
    {-31518000 -18000 0 EST}
    {-21488400 -14400 1 EDT}
    {-5767200 -18000 0 EST}
    {9961200 -14400 1 EDT}
    {25682400 -18000 0 EST}
    {31554000 -18000 0 EST}
    {1136091600 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}
    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}
    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}
    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}
    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Indiana/Knox.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Indiana/Knox) {
    {-9223372036854775808 -20790 0 LMT}
    {-2717648010 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Indiana/Knox) {
    {-9223372036854775808 -20790 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
89
90
91
92
93
94
95





























































































































































































96
    {594198000 -21600 0 CST}
    {607507200 -18000 1 CDT}
    {625647600 -21600 0 CST}
    {638956800 -18000 1 CDT}
    {657097200 -21600 0 CST}
    {671011200 -18000 1 CDT}
    {688550400 -18000 0 EST}





























































































































































































}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
    {594198000 -21600 0 CST}
    {607507200 -18000 1 CDT}
    {625647600 -21600 0 CST}
    {638956800 -18000 1 CDT}
    {657097200 -21600 0 CST}
    {671011200 -18000 1 CDT}
    {688550400 -18000 0 EST}
    {1136091600 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}
    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}
    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}
    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}
    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Indiana/Marengo.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Indiana/Marengo) {
    {-9223372036854775808 -20723 0 LMT}
    {-2717648077 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Indiana/Marengo) {
    {-9223372036854775808 -20723 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
40
41
42
43
44
45
46





























































































































































































47
    {104914800 -14400 1 EDT}
    {120636000 -18000 0 EST}
    {126687600 -18000 1 CDT}
    {152089200 -18000 0 EST}
    {162370800 -14400 1 EDT}
    {183535200 -18000 0 EST}
    {189320400 -18000 0 EST}





























































































































































































}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
    {104914800 -14400 1 EDT}
    {120636000 -18000 0 EST}
    {126687600 -18000 1 CDT}
    {152089200 -18000 0 EST}
    {162370800 -14400 1 EDT}
    {183535200 -18000 0 EST}
    {189320400 -18000 0 EST}
    {1136091600 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}
    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}
    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}
    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}
    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Indiana/Vevay.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23





























































































































































































24
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Indiana/Vevay) {
    {-9223372036854775808 -20416 0 LMT}
    {-2717648384 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
    {-495043200 -18000 0 EST}
    {-31518000 -18000 0 EST}
    {-21488400 -14400 1 EDT}
    {-5767200 -18000 0 EST}
    {9961200 -14400 1 EDT}
    {25682400 -18000 0 EST}
    {41410800 -14400 1 EDT}
    {57736800 -18000 0 EST}
    {73465200 -14400 1 EDT}
    {89186400 -18000 0 EST}
    {94712400 -18000 0 EST}





























































































































































































}




|


















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Indiana/Vevay) {
    {-9223372036854775808 -20416 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
    {-495043200 -18000 0 EST}
    {-31518000 -18000 0 EST}
    {-21488400 -14400 1 EDT}
    {-5767200 -18000 0 EST}
    {9961200 -14400 1 EDT}
    {25682400 -18000 0 EST}
    {41410800 -14400 1 EDT}
    {57736800 -18000 0 EST}
    {73465200 -14400 1 EDT}
    {89186400 -18000 0 EST}
    {94712400 -18000 0 EST}
    {1136091600 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}
    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}
    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}
    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}
    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Indianapolis.

1


2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
# created by ../tools/tclZIC.tcl - do not edit



set TZData(:America/Indianapolis) {
    {-9223372036854775808 -20678 0 LMT}
    {-2717648122 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-1577901600 -21600 0 CST}
    {-900259200 -18000 1 CDT}
    {-891795600 -21600 0 CST}
    {-883591200 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
    {-757360800 -21600 0 CST}
    {-747244800 -18000 1 CDT}
    {-733942800 -21600 0 CST}
    {-715795200 -18000 1 CDT}
    {-702493200 -21600 0 CST}
    {-684345600 -18000 1 CDT}
    {-671043600 -21600 0 CST}
    {-652896000 -18000 1 CDT}
    {-639594000 -21600 0 CST}
    {-620841600 -18000 1 CDT}
    {-608144400 -21600 0 CST}
    {-589392000 -18000 1 CDT}
    {-576090000 -21600 0 CST}
    {-557942400 -18000 1 CDT}
    {-544640400 -21600 0 CST}
    {-526492800 -18000 1 CDT}
    {-513190800 -21600 0 CST}
    {-495043200 -18000 1 CDT}
    {-481741200 -21600 0 CST}
    {-463593600 -18000 0 EST}
    {-386787600 -21600 0 CST}
    {-368640000 -18000 0 EST}
    {-31518000 -18000 0 EST}
    {-21488400 -14400 1 EDT}
    {-5767200 -18000 0 EST}
    {9961200 -14400 1 EDT}
    {25682400 -18000 0 EST}
    {31554000 -18000 0 EST}
}

>
>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
1
2
3
4
5










































# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indiana/Indianapolis)]} {
    LoadTimeZoneFile America/Indiana/Indianapolis
}
set TZData(:America/Indianapolis) $TZData(:America/Indiana/Indianapolis)










































Changes to library/tzdata/America/Juneau.

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180


181
182
183


184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242


243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274


275
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1175425200 -28800 1 AKDT}
    {1193565600 -32400 0 AKST}
    {1207479600 -28800 1 AKDT}
    {1225015200 -32400 0 AKST}
    {1238929200 -28800 1 AKDT}
    {1256464800 -32400 0 AKST}
    {1270378800 -28800 1 AKDT}
    {1288519200 -32400 0 AKST}
    {1301828400 -28800 1 AKDT}
    {1319968800 -32400 0 AKST}
    {1333278000 -28800 1 AKDT}
    {1351418400 -32400 0 AKST}
    {1365332400 -28800 1 AKDT}
    {1382868000 -32400 0 AKST}
    {1396782000 -28800 1 AKDT}
    {1414317600 -32400 0 AKST}
    {1428231600 -28800 1 AKDT}
    {1445767200 -32400 0 AKST}
    {1459681200 -28800 1 AKDT}
    {1477821600 -32400 0 AKST}
    {1491130800 -28800 1 AKDT}
    {1509271200 -32400 0 AKST}
    {1522580400 -28800 1 AKDT}
    {1540720800 -32400 0 AKST}
    {1554634800 -28800 1 AKDT}
    {1572170400 -32400 0 AKST}
    {1586084400 -28800 1 AKDT}
    {1603620000 -32400 0 AKST}
    {1617534000 -28800 1 AKDT}
    {1635674400 -32400 0 AKST}
    {1648983600 -28800 1 AKDT}
    {1667124000 -32400 0 AKST}
    {1680433200 -28800 1 AKDT}
    {1698573600 -32400 0 AKST}
    {1712487600 -28800 1 AKDT}
    {1730023200 -32400 0 AKST}
    {1743937200 -28800 1 AKDT}
    {1761472800 -32400 0 AKST}
    {1775386800 -28800 1 AKDT}
    {1792922400 -32400 0 AKST}
    {1806836400 -28800 1 AKDT}
    {1824976800 -32400 0 AKST}
    {1838286000 -28800 1 AKDT}
    {1856426400 -32400 0 AKST}
    {1869735600 -28800 1 AKDT}
    {1887876000 -32400 0 AKST}
    {1901790000 -28800 1 AKDT}
    {1919325600 -32400 0 AKST}
    {1933239600 -28800 1 AKDT}
    {1950775200 -32400 0 AKST}
    {1964689200 -28800 1 AKDT}
    {1982829600 -32400 0 AKST}
    {1996138800 -28800 1 AKDT}
    {2014279200 -32400 0 AKST}
    {2027588400 -28800 1 AKDT}
    {2045728800 -32400 0 AKST}
    {2059038000 -28800 1 AKDT}
    {2077178400 -32400 0 AKST}
    {2091092400 -28800 1 AKDT}
    {2108628000 -32400 0 AKST}
    {2122542000 -28800 1 AKDT}
    {2140077600 -32400 0 AKST}
    {2153991600 -28800 1 AKDT}
    {2172132000 -32400 0 AKST}
    {2185441200 -28800 1 AKDT}
    {2203581600 -32400 0 AKST}
    {2216890800 -28800 1 AKDT}
    {2235031200 -32400 0 AKST}
    {2248945200 -28800 1 AKDT}
    {2266480800 -32400 0 AKST}
    {2280394800 -28800 1 AKDT}
    {2297930400 -32400 0 AKST}
    {2311844400 -28800 1 AKDT}
    {2329380000 -32400 0 AKST}
    {2343294000 -28800 1 AKDT}
    {2361434400 -32400 0 AKST}
    {2374743600 -28800 1 AKDT}
    {2392884000 -32400 0 AKST}
    {2406193200 -28800 1 AKDT}
    {2424333600 -32400 0 AKST}
    {2438247600 -28800 1 AKDT}
    {2455783200 -32400 0 AKST}
    {2469697200 -28800 1 AKDT}
    {2487232800 -32400 0 AKST}
    {2501146800 -28800 1 AKDT}
    {2519287200 -32400 0 AKST}
    {2532596400 -28800 1 AKDT}
    {2550736800 -32400 0 AKST}
    {2564046000 -28800 1 AKDT}
    {2582186400 -32400 0 AKST}
    {2596100400 -28800 1 AKDT}
    {2613636000 -32400 0 AKST}


    {2627550000 -28800 1 AKDT}
    {2645085600 -32400 0 AKST}
    {2658999600 -28800 1 AKDT}


    {2676535200 -32400 0 AKST}
    {2690449200 -28800 1 AKDT}
    {2708589600 -32400 0 AKST}
    {2721898800 -28800 1 AKDT}
    {2740039200 -32400 0 AKST}
    {2753348400 -28800 1 AKDT}
    {2771488800 -32400 0 AKST}
    {2785402800 -28800 1 AKDT}
    {2802938400 -32400 0 AKST}
    {2816852400 -28800 1 AKDT}
    {2834388000 -32400 0 AKST}
    {2848302000 -28800 1 AKDT}
    {2866442400 -32400 0 AKST}
    {2879751600 -28800 1 AKDT}
    {2897892000 -32400 0 AKST}
    {2911201200 -28800 1 AKDT}
    {2929341600 -32400 0 AKST}
    {2942650800 -28800 1 AKDT}
    {2960791200 -32400 0 AKST}
    {2974705200 -28800 1 AKDT}
    {2992240800 -32400 0 AKST}
    {3006154800 -28800 1 AKDT}
    {3023690400 -32400 0 AKST}
    {3037604400 -28800 1 AKDT}
    {3055744800 -32400 0 AKST}
    {3069054000 -28800 1 AKDT}
    {3087194400 -32400 0 AKST}
    {3100503600 -28800 1 AKDT}
    {3118644000 -32400 0 AKST}
    {3132558000 -28800 1 AKDT}
    {3150093600 -32400 0 AKST}
    {3164007600 -28800 1 AKDT}
    {3181543200 -32400 0 AKST}
    {3195457200 -28800 1 AKDT}
    {3212992800 -32400 0 AKST}
    {3226906800 -28800 1 AKDT}
    {3245047200 -32400 0 AKST}
    {3258356400 -28800 1 AKDT}
    {3276496800 -32400 0 AKST}
    {3289806000 -28800 1 AKDT}
    {3307946400 -32400 0 AKST}
    {3321860400 -28800 1 AKDT}
    {3339396000 -32400 0 AKST}
    {3353310000 -28800 1 AKDT}
    {3370845600 -32400 0 AKST}
    {3384759600 -28800 1 AKDT}
    {3402900000 -32400 0 AKST}
    {3416209200 -28800 1 AKDT}
    {3434349600 -32400 0 AKST}
    {3447658800 -28800 1 AKDT}
    {3465799200 -32400 0 AKST}
    {3479713200 -28800 1 AKDT}
    {3497248800 -32400 0 AKST}
    {3511162800 -28800 1 AKDT}
    {3528698400 -32400 0 AKST}
    {3542612400 -28800 1 AKDT}
    {3560148000 -32400 0 AKST}
    {3574062000 -28800 1 AKDT}
    {3592202400 -32400 0 AKST}


    {3605511600 -28800 1 AKDT}
    {3623652000 -32400 0 AKST}
    {3636961200 -28800 1 AKDT}
    {3655101600 -32400 0 AKST}
    {3669015600 -28800 1 AKDT}
    {3686551200 -32400 0 AKST}
    {3700465200 -28800 1 AKDT}
    {3718000800 -32400 0 AKST}
    {3731914800 -28800 1 AKDT}
    {3750055200 -32400 0 AKST}
    {3763364400 -28800 1 AKDT}
    {3781504800 -32400 0 AKST}
    {3794814000 -28800 1 AKDT}
    {3812954400 -32400 0 AKST}
    {3826263600 -28800 1 AKDT}
    {3844404000 -32400 0 AKST}
    {3858318000 -28800 1 AKDT}
    {3875853600 -32400 0 AKST}
    {3889767600 -28800 1 AKDT}
    {3907303200 -32400 0 AKST}
    {3921217200 -28800 1 AKDT}
    {3939357600 -32400 0 AKST}
    {3952666800 -28800 1 AKDT}
    {3970807200 -32400 0 AKST}
    {3984116400 -28800 1 AKDT}
    {4002256800 -32400 0 AKST}
    {4016170800 -28800 1 AKDT}
    {4033706400 -32400 0 AKST}
    {4047620400 -28800 1 AKDT}
    {4065156000 -32400 0 AKST}
    {4079070000 -28800 1 AKDT}
    {4096605600 -32400 0 AKST}


}







|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>

82
83
84
85
86
87
88
89
90
91
92
93
94
95


96
97
98
99
100
101
102
103
104
105
106
107


108
109
110
111
112


113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203


204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1173610800 -28800 1 AKDT}
    {1194170400 -32400 0 AKST}
    {1205060400 -28800 1 AKDT}
    {1225620000 -32400 0 AKST}
    {1236510000 -28800 1 AKDT}
    {1257069600 -32400 0 AKST}
    {1268564400 -28800 1 AKDT}


    {1289124000 -32400 0 AKST}
    {1300014000 -28800 1 AKDT}
    {1320573600 -32400 0 AKST}
    {1331463600 -28800 1 AKDT}
    {1352023200 -32400 0 AKST}
    {1362913200 -28800 1 AKDT}
    {1383472800 -32400 0 AKST}
    {1394362800 -28800 1 AKDT}
    {1414922400 -32400 0 AKST}
    {1425812400 -28800 1 AKDT}
    {1446372000 -32400 0 AKST}
    {1457866800 -28800 1 AKDT}


    {1478426400 -32400 0 AKST}
    {1489316400 -28800 1 AKDT}
    {1509876000 -32400 0 AKST}
    {1520766000 -28800 1 AKDT}
    {1541325600 -32400 0 AKST}


    {1552215600 -28800 1 AKDT}
    {1572775200 -32400 0 AKST}
    {1583665200 -28800 1 AKDT}
    {1604224800 -32400 0 AKST}
    {1615719600 -28800 1 AKDT}
    {1636279200 -32400 0 AKST}
    {1647169200 -28800 1 AKDT}
    {1667728800 -32400 0 AKST}
    {1678618800 -28800 1 AKDT}
    {1699178400 -32400 0 AKST}
    {1710068400 -28800 1 AKDT}
    {1730628000 -32400 0 AKST}
    {1741518000 -28800 1 AKDT}
    {1762077600 -32400 0 AKST}
    {1772967600 -28800 1 AKDT}
    {1793527200 -32400 0 AKST}
    {1805022000 -28800 1 AKDT}
    {1825581600 -32400 0 AKST}
    {1836471600 -28800 1 AKDT}
    {1857031200 -32400 0 AKST}
    {1867921200 -28800 1 AKDT}
    {1888480800 -32400 0 AKST}
    {1899370800 -28800 1 AKDT}
    {1919930400 -32400 0 AKST}
    {1930820400 -28800 1 AKDT}
    {1951380000 -32400 0 AKST}
    {1962874800 -28800 1 AKDT}
    {1983434400 -32400 0 AKST}
    {1994324400 -28800 1 AKDT}
    {2014884000 -32400 0 AKST}
    {2025774000 -28800 1 AKDT}
    {2046333600 -32400 0 AKST}
    {2057223600 -28800 1 AKDT}
    {2077783200 -32400 0 AKST}
    {2088673200 -28800 1 AKDT}
    {2109232800 -32400 0 AKST}
    {2120122800 -28800 1 AKDT}
    {2140682400 -32400 0 AKST}
    {2152177200 -28800 1 AKDT}
    {2172736800 -32400 0 AKST}
    {2183626800 -28800 1 AKDT}
    {2204186400 -32400 0 AKST}
    {2215076400 -28800 1 AKDT}
    {2235636000 -32400 0 AKST}
    {2246526000 -28800 1 AKDT}
    {2267085600 -32400 0 AKST}
    {2277975600 -28800 1 AKDT}
    {2298535200 -32400 0 AKST}
    {2309425200 -28800 1 AKDT}
    {2329984800 -32400 0 AKST}
    {2341479600 -28800 1 AKDT}
    {2362039200 -32400 0 AKST}
    {2372929200 -28800 1 AKDT}
    {2393488800 -32400 0 AKST}
    {2404378800 -28800 1 AKDT}
    {2424938400 -32400 0 AKST}
    {2435828400 -28800 1 AKDT}
    {2456388000 -32400 0 AKST}
    {2467278000 -28800 1 AKDT}
    {2487837600 -32400 0 AKST}
    {2499332400 -28800 1 AKDT}
    {2519892000 -32400 0 AKST}
    {2530782000 -28800 1 AKDT}
    {2551341600 -32400 0 AKST}
    {2562231600 -28800 1 AKDT}
    {2582791200 -32400 0 AKST}
    {2593681200 -28800 1 AKDT}
    {2614240800 -32400 0 AKST}
    {2625130800 -28800 1 AKDT}
    {2645690400 -32400 0 AKST}
    {2656580400 -28800 1 AKDT}
    {2677140000 -32400 0 AKST}
    {2688634800 -28800 1 AKDT}
    {2709194400 -32400 0 AKST}
    {2720084400 -28800 1 AKDT}
    {2740644000 -32400 0 AKST}
    {2751534000 -28800 1 AKDT}
    {2772093600 -32400 0 AKST}
    {2782983600 -28800 1 AKDT}
    {2803543200 -32400 0 AKST}
    {2814433200 -28800 1 AKDT}
    {2834992800 -32400 0 AKST}
    {2846487600 -28800 1 AKDT}
    {2867047200 -32400 0 AKST}
    {2877937200 -28800 1 AKDT}
    {2898496800 -32400 0 AKST}
    {2909386800 -28800 1 AKDT}
    {2929946400 -32400 0 AKST}
    {2940836400 -28800 1 AKDT}
    {2961396000 -32400 0 AKST}
    {2972286000 -28800 1 AKDT}


    {2992845600 -32400 0 AKST}
    {3003735600 -28800 1 AKDT}
    {3024295200 -32400 0 AKST}
    {3035790000 -28800 1 AKDT}
    {3056349600 -32400 0 AKST}
    {3067239600 -28800 1 AKDT}
    {3087799200 -32400 0 AKST}
    {3098689200 -28800 1 AKDT}
    {3119248800 -32400 0 AKST}
    {3130138800 -28800 1 AKDT}
    {3150698400 -32400 0 AKST}
    {3161588400 -28800 1 AKDT}
    {3182148000 -32400 0 AKST}
    {3193038000 -28800 1 AKDT}
    {3213597600 -32400 0 AKST}
    {3225092400 -28800 1 AKDT}
    {3245652000 -32400 0 AKST}
    {3256542000 -28800 1 AKDT}
    {3277101600 -32400 0 AKST}
    {3287991600 -28800 1 AKDT}
    {3308551200 -32400 0 AKST}
    {3319441200 -28800 1 AKDT}
    {3340000800 -32400 0 AKST}
    {3350890800 -28800 1 AKDT}
    {3371450400 -32400 0 AKST}
    {3382945200 -28800 1 AKDT}
    {3403504800 -32400 0 AKST}
    {3414394800 -28800 1 AKDT}
    {3434954400 -32400 0 AKST}
    {3445844400 -28800 1 AKDT}
    {3466404000 -32400 0 AKST}
    {3477294000 -28800 1 AKDT}
    {3497853600 -32400 0 AKST}
    {3508743600 -28800 1 AKDT}
    {3529303200 -32400 0 AKST}
    {3540193200 -28800 1 AKDT}
    {3560752800 -32400 0 AKST}
    {3572247600 -28800 1 AKDT}
    {3592807200 -32400 0 AKST}
    {3603697200 -28800 1 AKDT}
    {3624256800 -32400 0 AKST}
    {3635146800 -28800 1 AKDT}
    {3655706400 -32400 0 AKST}
    {3666596400 -28800 1 AKDT}
    {3687156000 -32400 0 AKST}
    {3698046000 -28800 1 AKDT}
    {3718605600 -32400 0 AKST}
    {3730100400 -28800 1 AKDT}
    {3750660000 -32400 0 AKST}
    {3761550000 -28800 1 AKDT}
    {3782109600 -32400 0 AKST}
    {3792999600 -28800 1 AKDT}
    {3813559200 -32400 0 AKST}
    {3824449200 -28800 1 AKDT}
    {3845008800 -32400 0 AKST}
    {3855898800 -28800 1 AKDT}
    {3876458400 -32400 0 AKST}
    {3887348400 -28800 1 AKDT}
    {3907908000 -32400 0 AKST}
    {3919402800 -28800 1 AKDT}
    {3939962400 -32400 0 AKST}
    {3950852400 -28800 1 AKDT}
    {3971412000 -32400 0 AKST}
    {3982302000 -28800 1 AKDT}
    {4002861600 -32400 0 AKST}
    {4013751600 -28800 1 AKDT}
    {4034311200 -32400 0 AKST}
    {4045201200 -28800 1 AKDT}
    {4065760800 -32400 0 AKST}
    {4076650800 -28800 1 AKDT}
    {4097210400 -32400 0 AKST}
}

Changes to library/tzdata/America/Kentucky/Louisville.

1
2
3






















































































































































































































































































































4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Louisville)]} {
    LoadTimeZoneFile America/Louisville






















































































































































































































































































































}
set TZData(:America/Kentucky/Louisville) $TZData(:America/Louisville)

|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

<
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314

# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Kentucky/Louisville) {
    {-9223372036854775808 -20582 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-1546279200 -21600 0 CST}
    {-1535904000 -18000 1 CDT}
    {-1525280400 -21600 0 CST}
    {-905097600 -18000 1 CDT}
    {-891795600 -21600 0 CST}
    {-883591200 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
    {-757360800 -21600 0 CST}
    {-747244800 -18000 1 CDT}
    {-744224400 -21600 0 CST}
    {-715795200 -18000 1 CDT}
    {-684349200 -18000 1 CDT}
    {-652899600 -18000 1 CDT}
    {-620845200 -18000 1 CDT}
    {-608144400 -21600 0 CST}
    {-589392000 -18000 1 CDT}
    {-576090000 -21600 0 CST}
    {-557942400 -18000 1 CDT}
    {-544640400 -21600 0 CST}
    {-526492800 -18000 1 CDT}
    {-513190800 -21600 0 CST}
    {-495043200 -18000 1 CDT}
    {-481741200 -21600 0 CST}
    {-463593600 -18000 1 CDT}
    {-450291600 -21600 0 CST}
    {-431539200 -18000 1 CDT}
    {-415818000 -21600 0 CST}
    {-400089600 -18000 1 CDT}
    {-384368400 -21600 0 CST}
    {-368640000 -18000 1 CDT}
    {-352918800 -21600 0 CST}
    {-337190400 -18000 1 CDT}
    {-321469200 -21600 0 CST}
    {-305740800 -18000 1 CDT}
    {-289414800 -21600 0 CST}
    {-273686400 -18000 1 CDT}
    {-266432400 -18000 0 EST}
    {-63140400 -18000 0 EST}
    {-52938000 -14400 1 EDT}
    {-37216800 -18000 0 EST}
    {-21488400 -14400 1 EDT}
    {-5767200 -18000 0 EST}
    {9961200 -14400 1 EDT}
    {25682400 -18000 0 EST}
    {41410800 -14400 1 EDT}
    {57736800 -18000 0 EST}
    {73465200 -14400 1 EDT}
    {89186400 -18000 0 EST}
    {104914800 -14400 1 EDT}
    {120636000 -18000 0 EST}
    {126687600 -18000 1 CDT}
    {152089200 -18000 0 EST}
    {162370800 -14400 1 EDT}
    {183535200 -18000 0 EST}
    {199263600 -14400 1 EDT}
    {215589600 -18000 0 EST}
    {230713200 -14400 1 EDT}
    {247039200 -18000 0 EST}
    {262767600 -14400 1 EDT}
    {278488800 -18000 0 EST}
    {294217200 -14400 1 EDT}
    {309938400 -18000 0 EST}
    {325666800 -14400 1 EDT}
    {341388000 -18000 0 EST}
    {357116400 -14400 1 EDT}
    {372837600 -18000 0 EST}
    {388566000 -14400 1 EDT}
    {404892000 -18000 0 EST}
    {420015600 -14400 1 EDT}
    {436341600 -18000 0 EST}
    {452070000 -14400 1 EDT}
    {467791200 -18000 0 EST}
    {483519600 -14400 1 EDT}
    {499240800 -18000 0 EST}
    {514969200 -14400 1 EDT}
    {530690400 -18000 0 EST}
    {544604400 -14400 1 EDT}
    {562140000 -18000 0 EST}
    {576054000 -14400 1 EDT}
    {594194400 -18000 0 EST}
    {607503600 -14400 1 EDT}
    {625644000 -18000 0 EST}
    {638953200 -14400 1 EDT}
    {657093600 -18000 0 EST}
    {671007600 -14400 1 EDT}
    {688543200 -18000 0 EST}
    {702457200 -14400 1 EDT}
    {719992800 -18000 0 EST}
    {733906800 -14400 1 EDT}
    {752047200 -18000 0 EST}
    {765356400 -14400 1 EDT}
    {783496800 -18000 0 EST}
    {796806000 -14400 1 EDT}
    {814946400 -18000 0 EST}
    {828860400 -14400 1 EDT}
    {846396000 -18000 0 EST}
    {860310000 -14400 1 EDT}
    {877845600 -18000 0 EST}
    {891759600 -14400 1 EDT}
    {909295200 -18000 0 EST}
    {923209200 -14400 1 EDT}
    {941349600 -18000 0 EST}
    {954658800 -14400 1 EDT}
    {972799200 -18000 0 EST}
    {986108400 -14400 1 EDT}
    {1004248800 -18000 0 EST}
    {1018162800 -14400 1 EDT}
    {1035698400 -18000 0 EST}
    {1049612400 -14400 1 EDT}
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}
    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}
    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}
    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}
    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Kentucky/Monticello.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Kentucky/Monticello) {
    {-9223372036854775808 -20364 0 LMT}
    {-2717648436 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Kentucky/Monticello) {
    {-9223372036854775808 -20364 0 LMT}
    {-2717647200 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
86
87
88
89
90
91
92
93
94


95
96


97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143


144
145
146
147
148
149
150
151
152
153


154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1175410800 -14400 1 EDT}
    {1193551200 -18000 0 EST}


    {1207465200 -14400 1 EDT}
    {1225000800 -18000 0 EST}


    {1238914800 -14400 1 EDT}
    {1256450400 -18000 0 EST}
    {1270364400 -14400 1 EDT}
    {1288504800 -18000 0 EST}
    {1301814000 -14400 1 EDT}
    {1319954400 -18000 0 EST}
    {1333263600 -14400 1 EDT}
    {1351404000 -18000 0 EST}
    {1365318000 -14400 1 EDT}
    {1382853600 -18000 0 EST}
    {1396767600 -14400 1 EDT}
    {1414303200 -18000 0 EST}
    {1428217200 -14400 1 EDT}
    {1445752800 -18000 0 EST}
    {1459666800 -14400 1 EDT}
    {1477807200 -18000 0 EST}
    {1491116400 -14400 1 EDT}
    {1509256800 -18000 0 EST}
    {1522566000 -14400 1 EDT}
    {1540706400 -18000 0 EST}
    {1554620400 -14400 1 EDT}
    {1572156000 -18000 0 EST}
    {1586070000 -14400 1 EDT}
    {1603605600 -18000 0 EST}
    {1617519600 -14400 1 EDT}
    {1635660000 -18000 0 EST}
    {1648969200 -14400 1 EDT}
    {1667109600 -18000 0 EST}
    {1680418800 -14400 1 EDT}
    {1698559200 -18000 0 EST}
    {1712473200 -14400 1 EDT}
    {1730008800 -18000 0 EST}
    {1743922800 -14400 1 EDT}
    {1761458400 -18000 0 EST}
    {1775372400 -14400 1 EDT}
    {1792908000 -18000 0 EST}
    {1806822000 -14400 1 EDT}
    {1824962400 -18000 0 EST}
    {1838271600 -14400 1 EDT}
    {1856412000 -18000 0 EST}
    {1869721200 -14400 1 EDT}
    {1887861600 -18000 0 EST}
    {1901775600 -14400 1 EDT}
    {1919311200 -18000 0 EST}
    {1933225200 -14400 1 EDT}
    {1950760800 -18000 0 EST}
    {1964674800 -14400 1 EDT}


    {1982815200 -18000 0 EST}
    {1996124400 -14400 1 EDT}
    {2014264800 -18000 0 EST}
    {2027574000 -14400 1 EDT}
    {2045714400 -18000 0 EST}
    {2059023600 -14400 1 EDT}
    {2077164000 -18000 0 EST}
    {2091078000 -14400 1 EDT}
    {2108613600 -18000 0 EST}
    {2122527600 -14400 1 EDT}


    {2140063200 -18000 0 EST}
    {2153977200 -14400 1 EDT}
    {2172117600 -18000 0 EST}
    {2185426800 -14400 1 EDT}
    {2203567200 -18000 0 EST}
    {2216876400 -14400 1 EDT}
    {2235016800 -18000 0 EST}
    {2248930800 -14400 1 EDT}
    {2266466400 -18000 0 EST}
    {2280380400 -14400 1 EDT}
    {2297916000 -18000 0 EST}
    {2311830000 -14400 1 EDT}
    {2329365600 -18000 0 EST}
    {2343279600 -14400 1 EDT}
    {2361420000 -18000 0 EST}
    {2374729200 -14400 1 EDT}
    {2392869600 -18000 0 EST}
    {2406178800 -14400 1 EDT}
    {2424319200 -18000 0 EST}
    {2438233200 -14400 1 EDT}
    {2455768800 -18000 0 EST}
    {2469682800 -14400 1 EDT}
    {2487218400 -18000 0 EST}
    {2501132400 -14400 1 EDT}
    {2519272800 -18000 0 EST}
    {2532582000 -14400 1 EDT}
    {2550722400 -18000 0 EST}
    {2564031600 -14400 1 EDT}
    {2582172000 -18000 0 EST}
    {2596086000 -14400 1 EDT}
    {2613621600 -18000 0 EST}
    {2627535600 -14400 1 EDT}
    {2645071200 -18000 0 EST}
    {2658985200 -14400 1 EDT}
    {2676520800 -18000 0 EST}
    {2690434800 -14400 1 EDT}
    {2708575200 -18000 0 EST}
    {2721884400 -14400 1 EDT}
    {2740024800 -18000 0 EST}
    {2753334000 -14400 1 EDT}
    {2771474400 -18000 0 EST}
    {2785388400 -14400 1 EDT}
    {2802924000 -18000 0 EST}
    {2816838000 -14400 1 EDT}
    {2834373600 -18000 0 EST}
    {2848287600 -14400 1 EDT}
    {2866428000 -18000 0 EST}
    {2879737200 -14400 1 EDT}
    {2897877600 -18000 0 EST}
    {2911186800 -14400 1 EDT}
    {2929327200 -18000 0 EST}
    {2942636400 -14400 1 EDT}
    {2960776800 -18000 0 EST}
    {2974690800 -14400 1 EDT}
    {2992226400 -18000 0 EST}
    {3006140400 -14400 1 EDT}
    {3023676000 -18000 0 EST}
    {3037590000 -14400 1 EDT}
    {3055730400 -18000 0 EST}
    {3069039600 -14400 1 EDT}
    {3087180000 -18000 0 EST}
    {3100489200 -14400 1 EDT}
    {3118629600 -18000 0 EST}
    {3132543600 -14400 1 EDT}
    {3150079200 -18000 0 EST}
    {3163993200 -14400 1 EDT}
    {3181528800 -18000 0 EST}
    {3195442800 -14400 1 EDT}
    {3212978400 -18000 0 EST}
    {3226892400 -14400 1 EDT}
    {3245032800 -18000 0 EST}
    {3258342000 -14400 1 EDT}
    {3276482400 -18000 0 EST}
    {3289791600 -14400 1 EDT}
    {3307932000 -18000 0 EST}
    {3321846000 -14400 1 EDT}
    {3339381600 -18000 0 EST}
    {3353295600 -14400 1 EDT}
    {3370831200 -18000 0 EST}
    {3384745200 -14400 1 EDT}
    {3402885600 -18000 0 EST}
    {3416194800 -14400 1 EDT}
    {3434335200 -18000 0 EST}
    {3447644400 -14400 1 EDT}
    {3465784800 -18000 0 EST}
    {3479698800 -14400 1 EDT}
    {3497234400 -18000 0 EST}
    {3511148400 -14400 1 EDT}
    {3528684000 -18000 0 EST}
    {3542598000 -14400 1 EDT}
    {3560133600 -18000 0 EST}
    {3574047600 -14400 1 EDT}
    {3592188000 -18000 0 EST}
    {3605497200 -14400 1 EDT}
    {3623637600 -18000 0 EST}
    {3636946800 -14400 1 EDT}
    {3655087200 -18000 0 EST}
    {3669001200 -14400 1 EDT}
    {3686536800 -18000 0 EST}
    {3700450800 -14400 1 EDT}
    {3717986400 -18000 0 EST}
    {3731900400 -14400 1 EDT}
    {3750040800 -18000 0 EST}
    {3763350000 -14400 1 EDT}
    {3781490400 -18000 0 EST}
    {3794799600 -14400 1 EDT}
    {3812940000 -18000 0 EST}
    {3826249200 -14400 1 EDT}
    {3844389600 -18000 0 EST}
    {3858303600 -14400 1 EDT}
    {3875839200 -18000 0 EST}
    {3889753200 -14400 1 EDT}
    {3907288800 -18000 0 EST}
    {3921202800 -14400 1 EDT}
    {3939343200 -18000 0 EST}
    {3952652400 -14400 1 EDT}
    {3970792800 -18000 0 EST}
    {3984102000 -14400 1 EDT}
    {4002242400 -18000 0 EST}
    {4016156400 -14400 1 EDT}
    {4033692000 -18000 0 EST}
    {4047606000 -14400 1 EDT}
    {4065141600 -18000 0 EST}
    {4079055600 -14400 1 EDT}
    {4096591200 -18000 0 EST}
}







|
|
>
>
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138


139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164


165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207


208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229


230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}


    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}


    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}


    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}


    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Los_Angeles.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Los_Angeles) {
    {-9223372036854775808 -28378 0 LMT}
    {-2717640422 -28800 0 PST}
    {-1633269600 -25200 1 PDT}
    {-1615129200 -28800 0 PST}
    {-1601820000 -25200 1 PDT}
    {-1583679600 -28800 0 PST}
    {-880207200 -25200 1 PWT}
    {-769395600 -25200 1 PPT}
    {-765385200 -28800 0 PST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Los_Angeles) {
    {-9223372036854775808 -28378 0 LMT}
    {-2717640000 -28800 0 PST}
    {-1633269600 -25200 1 PDT}
    {-1615129200 -28800 0 PST}
    {-1601820000 -25200 1 PDT}
    {-1583679600 -28800 0 PST}
    {-880207200 -25200 1 PWT}
    {-769395600 -25200 1 PPT}
    {-765385200 -28800 0 PST}
124
125
126
127
128
129
130
131
132
133
134
135
136
137




138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229


230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
    {1067158800 -28800 0 PST}
    {1081072800 -25200 1 PDT}
    {1099213200 -28800 0 PST}
    {1112522400 -25200 1 PDT}
    {1130662800 -28800 0 PST}
    {1143972000 -25200 1 PDT}
    {1162112400 -28800 0 PST}
    {1175421600 -25200 1 PDT}
    {1193562000 -28800 0 PST}
    {1207476000 -25200 1 PDT}
    {1225011600 -28800 0 PST}
    {1238925600 -25200 1 PDT}
    {1256461200 -28800 0 PST}
    {1270375200 -25200 1 PDT}




    {1288515600 -28800 0 PST}
    {1301824800 -25200 1 PDT}
    {1319965200 -28800 0 PST}
    {1333274400 -25200 1 PDT}
    {1351414800 -28800 0 PST}
    {1365328800 -25200 1 PDT}
    {1382864400 -28800 0 PST}
    {1396778400 -25200 1 PDT}
    {1414314000 -28800 0 PST}
    {1428228000 -25200 1 PDT}
    {1445763600 -28800 0 PST}
    {1459677600 -25200 1 PDT}
    {1477818000 -28800 0 PST}
    {1491127200 -25200 1 PDT}
    {1509267600 -28800 0 PST}
    {1522576800 -25200 1 PDT}
    {1540717200 -28800 0 PST}
    {1554631200 -25200 1 PDT}
    {1572166800 -28800 0 PST}
    {1586080800 -25200 1 PDT}
    {1603616400 -28800 0 PST}
    {1617530400 -25200 1 PDT}
    {1635670800 -28800 0 PST}
    {1648980000 -25200 1 PDT}
    {1667120400 -28800 0 PST}
    {1680429600 -25200 1 PDT}
    {1698570000 -28800 0 PST}
    {1712484000 -25200 1 PDT}
    {1730019600 -28800 0 PST}
    {1743933600 -25200 1 PDT}
    {1761469200 -28800 0 PST}
    {1775383200 -25200 1 PDT}
    {1792918800 -28800 0 PST}
    {1806832800 -25200 1 PDT}
    {1824973200 -28800 0 PST}
    {1838282400 -25200 1 PDT}
    {1856422800 -28800 0 PST}
    {1869732000 -25200 1 PDT}
    {1887872400 -28800 0 PST}
    {1901786400 -25200 1 PDT}
    {1919322000 -28800 0 PST}
    {1933236000 -25200 1 PDT}
    {1950771600 -28800 0 PST}
    {1964685600 -25200 1 PDT}
    {1982826000 -28800 0 PST}
    {1996135200 -25200 1 PDT}
    {2014275600 -28800 0 PST}
    {2027584800 -25200 1 PDT}
    {2045725200 -28800 0 PST}
    {2059034400 -25200 1 PDT}
    {2077174800 -28800 0 PST}
    {2091088800 -25200 1 PDT}
    {2108624400 -28800 0 PST}
    {2122538400 -25200 1 PDT}
    {2140074000 -28800 0 PST}
    {2153988000 -25200 1 PDT}
    {2172128400 -28800 0 PST}
    {2185437600 -25200 1 PDT}
    {2203578000 -28800 0 PST}
    {2216887200 -25200 1 PDT}
    {2235027600 -28800 0 PST}
    {2248941600 -25200 1 PDT}
    {2266477200 -28800 0 PST}
    {2280391200 -25200 1 PDT}
    {2297926800 -28800 0 PST}
    {2311840800 -25200 1 PDT}
    {2329376400 -28800 0 PST}
    {2343290400 -25200 1 PDT}
    {2361430800 -28800 0 PST}
    {2374740000 -25200 1 PDT}
    {2392880400 -28800 0 PST}
    {2406189600 -25200 1 PDT}
    {2424330000 -28800 0 PST}
    {2438244000 -25200 1 PDT}
    {2455779600 -28800 0 PST}
    {2469693600 -25200 1 PDT}
    {2487229200 -28800 0 PST}
    {2501143200 -25200 1 PDT}
    {2519283600 -28800 0 PST}
    {2532592800 -25200 1 PDT}
    {2550733200 -28800 0 PST}
    {2564042400 -25200 1 PDT}
    {2582182800 -28800 0 PST}
    {2596096800 -25200 1 PDT}
    {2613632400 -28800 0 PST}
    {2627546400 -25200 1 PDT}
    {2645082000 -28800 0 PST}
    {2658996000 -25200 1 PDT}
    {2676531600 -28800 0 PST}
    {2690445600 -25200 1 PDT}
    {2708586000 -28800 0 PST}
    {2721895200 -25200 1 PDT}


    {2740035600 -28800 0 PST}
    {2753344800 -25200 1 PDT}
    {2771485200 -28800 0 PST}
    {2785399200 -25200 1 PDT}
    {2802934800 -28800 0 PST}
    {2816848800 -25200 1 PDT}
    {2834384400 -28800 0 PST}
    {2848298400 -25200 1 PDT}
    {2866438800 -28800 0 PST}
    {2879748000 -25200 1 PDT}
    {2897888400 -28800 0 PST}
    {2911197600 -25200 1 PDT}
    {2929338000 -28800 0 PST}
    {2942647200 -25200 1 PDT}
    {2960787600 -28800 0 PST}
    {2974701600 -25200 1 PDT}
    {2992237200 -28800 0 PST}
    {3006151200 -25200 1 PDT}
    {3023686800 -28800 0 PST}
    {3037600800 -25200 1 PDT}
    {3055741200 -28800 0 PST}
    {3069050400 -25200 1 PDT}
    {3087190800 -28800 0 PST}
    {3100500000 -25200 1 PDT}
    {3118640400 -28800 0 PST}
    {3132554400 -25200 1 PDT}
    {3150090000 -28800 0 PST}
    {3164004000 -25200 1 PDT}
    {3181539600 -28800 0 PST}
    {3195453600 -25200 1 PDT}
    {3212989200 -28800 0 PST}
    {3226903200 -25200 1 PDT}
    {3245043600 -28800 0 PST}
    {3258352800 -25200 1 PDT}
    {3276493200 -28800 0 PST}
    {3289802400 -25200 1 PDT}
    {3307942800 -28800 0 PST}
    {3321856800 -25200 1 PDT}
    {3339392400 -28800 0 PST}
    {3353306400 -25200 1 PDT}
    {3370842000 -28800 0 PST}
    {3384756000 -25200 1 PDT}
    {3402896400 -28800 0 PST}
    {3416205600 -25200 1 PDT}
    {3434346000 -28800 0 PST}
    {3447655200 -25200 1 PDT}
    {3465795600 -28800 0 PST}
    {3479709600 -25200 1 PDT}
    {3497245200 -28800 0 PST}
    {3511159200 -25200 1 PDT}
    {3528694800 -28800 0 PST}
    {3542608800 -25200 1 PDT}
    {3560144400 -28800 0 PST}
    {3574058400 -25200 1 PDT}
    {3592198800 -28800 0 PST}
    {3605508000 -25200 1 PDT}
    {3623648400 -28800 0 PST}
    {3636957600 -25200 1 PDT}
    {3655098000 -28800 0 PST}
    {3669012000 -25200 1 PDT}
    {3686547600 -28800 0 PST}
    {3700461600 -25200 1 PDT}
    {3717997200 -28800 0 PST}
    {3731911200 -25200 1 PDT}
    {3750051600 -28800 0 PST}
    {3763360800 -25200 1 PDT}
    {3781501200 -28800 0 PST}
    {3794810400 -25200 1 PDT}
    {3812950800 -28800 0 PST}
    {3826260000 -25200 1 PDT}
    {3844400400 -28800 0 PST}
    {3858314400 -25200 1 PDT}
    {3875850000 -28800 0 PST}
    {3889764000 -25200 1 PDT}
    {3907299600 -28800 0 PST}
    {3921213600 -25200 1 PDT}
    {3939354000 -28800 0 PST}
    {3952663200 -25200 1 PDT}
    {3970803600 -28800 0 PST}
    {3984112800 -25200 1 PDT}
    {4002253200 -28800 0 PST}
    {4016167200 -25200 1 PDT}
    {4033702800 -28800 0 PST}
    {4047616800 -25200 1 PDT}
    {4065152400 -28800 0 PST}
    {4079066400 -25200 1 PDT}
    {4096602000 -28800 0 PST}
}







|
|
|
|
|
|
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198


199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270


271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316


317
    {1067158800 -28800 0 PST}
    {1081072800 -25200 1 PDT}
    {1099213200 -28800 0 PST}
    {1112522400 -25200 1 PDT}
    {1130662800 -28800 0 PST}
    {1143972000 -25200 1 PDT}
    {1162112400 -28800 0 PST}
    {1173607200 -25200 1 PDT}
    {1194166800 -28800 0 PST}
    {1205056800 -25200 1 PDT}
    {1225616400 -28800 0 PST}
    {1236506400 -25200 1 PDT}
    {1257066000 -28800 0 PST}
    {1268560800 -25200 1 PDT}
    {1289120400 -28800 0 PST}
    {1300010400 -25200 1 PDT}
    {1320570000 -28800 0 PST}
    {1331460000 -25200 1 PDT}
    {1352019600 -28800 0 PST}
    {1362909600 -25200 1 PDT}
    {1383469200 -28800 0 PST}
    {1394359200 -25200 1 PDT}
    {1414918800 -28800 0 PST}
    {1425808800 -25200 1 PDT}
    {1446368400 -28800 0 PST}
    {1457863200 -25200 1 PDT}
    {1478422800 -28800 0 PST}
    {1489312800 -25200 1 PDT}
    {1509872400 -28800 0 PST}
    {1520762400 -25200 1 PDT}
    {1541322000 -28800 0 PST}
    {1552212000 -25200 1 PDT}
    {1572771600 -28800 0 PST}
    {1583661600 -25200 1 PDT}
    {1604221200 -28800 0 PST}
    {1615716000 -25200 1 PDT}
    {1636275600 -28800 0 PST}
    {1647165600 -25200 1 PDT}
    {1667725200 -28800 0 PST}
    {1678615200 -25200 1 PDT}
    {1699174800 -28800 0 PST}
    {1710064800 -25200 1 PDT}
    {1730624400 -28800 0 PST}
    {1741514400 -25200 1 PDT}
    {1762074000 -28800 0 PST}
    {1772964000 -25200 1 PDT}
    {1793523600 -28800 0 PST}
    {1805018400 -25200 1 PDT}
    {1825578000 -28800 0 PST}
    {1836468000 -25200 1 PDT}
    {1857027600 -28800 0 PST}
    {1867917600 -25200 1 PDT}
    {1888477200 -28800 0 PST}
    {1899367200 -25200 1 PDT}
    {1919926800 -28800 0 PST}
    {1930816800 -25200 1 PDT}
    {1951376400 -28800 0 PST}
    {1962871200 -25200 1 PDT}
    {1983430800 -28800 0 PST}
    {1994320800 -25200 1 PDT}
    {2014880400 -28800 0 PST}
    {2025770400 -25200 1 PDT}
    {2046330000 -28800 0 PST}
    {2057220000 -25200 1 PDT}
    {2077779600 -28800 0 PST}
    {2088669600 -25200 1 PDT}
    {2109229200 -28800 0 PST}
    {2120119200 -25200 1 PDT}
    {2140678800 -28800 0 PST}
    {2152173600 -25200 1 PDT}
    {2172733200 -28800 0 PST}
    {2183623200 -25200 1 PDT}
    {2204182800 -28800 0 PST}
    {2215072800 -25200 1 PDT}
    {2235632400 -28800 0 PST}


    {2246522400 -25200 1 PDT}
    {2267082000 -28800 0 PST}
    {2277972000 -25200 1 PDT}
    {2298531600 -28800 0 PST}
    {2309421600 -25200 1 PDT}
    {2329981200 -28800 0 PST}
    {2341476000 -25200 1 PDT}
    {2362035600 -28800 0 PST}
    {2372925600 -25200 1 PDT}
    {2393485200 -28800 0 PST}
    {2404375200 -25200 1 PDT}
    {2424934800 -28800 0 PST}
    {2435824800 -25200 1 PDT}
    {2456384400 -28800 0 PST}
    {2467274400 -25200 1 PDT}
    {2487834000 -28800 0 PST}
    {2499328800 -25200 1 PDT}
    {2519888400 -28800 0 PST}
    {2530778400 -25200 1 PDT}
    {2551338000 -28800 0 PST}
    {2562228000 -25200 1 PDT}
    {2582787600 -28800 0 PST}
    {2593677600 -25200 1 PDT}
    {2614237200 -28800 0 PST}
    {2625127200 -25200 1 PDT}
    {2645686800 -28800 0 PST}
    {2656576800 -25200 1 PDT}
    {2677136400 -28800 0 PST}
    {2688631200 -25200 1 PDT}
    {2709190800 -28800 0 PST}
    {2720080800 -25200 1 PDT}
    {2740640400 -28800 0 PST}
    {2751530400 -25200 1 PDT}
    {2772090000 -28800 0 PST}
    {2782980000 -25200 1 PDT}
    {2803539600 -28800 0 PST}
    {2814429600 -25200 1 PDT}
    {2834989200 -28800 0 PST}
    {2846484000 -25200 1 PDT}
    {2867043600 -28800 0 PST}
    {2877933600 -25200 1 PDT}
    {2898493200 -28800 0 PST}
    {2909383200 -25200 1 PDT}
    {2929942800 -28800 0 PST}
    {2940832800 -25200 1 PDT}
    {2961392400 -28800 0 PST}
    {2972282400 -25200 1 PDT}
    {2992842000 -28800 0 PST}
    {3003732000 -25200 1 PDT}
    {3024291600 -28800 0 PST}
    {3035786400 -25200 1 PDT}
    {3056346000 -28800 0 PST}
    {3067236000 -25200 1 PDT}
    {3087795600 -28800 0 PST}
    {3098685600 -25200 1 PDT}
    {3119245200 -28800 0 PST}
    {3130135200 -25200 1 PDT}
    {3150694800 -28800 0 PST}
    {3161584800 -25200 1 PDT}
    {3182144400 -28800 0 PST}
    {3193034400 -25200 1 PDT}
    {3213594000 -28800 0 PST}
    {3225088800 -25200 1 PDT}
    {3245648400 -28800 0 PST}
    {3256538400 -25200 1 PDT}
    {3277098000 -28800 0 PST}
    {3287988000 -25200 1 PDT}
    {3308547600 -28800 0 PST}
    {3319437600 -25200 1 PDT}
    {3339997200 -28800 0 PST}
    {3350887200 -25200 1 PDT}
    {3371446800 -28800 0 PST}


    {3382941600 -25200 1 PDT}
    {3403501200 -28800 0 PST}
    {3414391200 -25200 1 PDT}
    {3434950800 -28800 0 PST}
    {3445840800 -25200 1 PDT}
    {3466400400 -28800 0 PST}
    {3477290400 -25200 1 PDT}
    {3497850000 -28800 0 PST}
    {3508740000 -25200 1 PDT}
    {3529299600 -28800 0 PST}
    {3540189600 -25200 1 PDT}
    {3560749200 -28800 0 PST}
    {3572244000 -25200 1 PDT}
    {3592803600 -28800 0 PST}
    {3603693600 -25200 1 PDT}
    {3624253200 -28800 0 PST}
    {3635143200 -25200 1 PDT}
    {3655702800 -28800 0 PST}
    {3666592800 -25200 1 PDT}
    {3687152400 -28800 0 PST}
    {3698042400 -25200 1 PDT}
    {3718602000 -28800 0 PST}
    {3730096800 -25200 1 PDT}
    {3750656400 -28800 0 PST}
    {3761546400 -25200 1 PDT}
    {3782106000 -28800 0 PST}
    {3792996000 -25200 1 PDT}
    {3813555600 -28800 0 PST}
    {3824445600 -25200 1 PDT}
    {3845005200 -28800 0 PST}
    {3855895200 -25200 1 PDT}
    {3876454800 -28800 0 PST}
    {3887344800 -25200 1 PDT}
    {3907904400 -28800 0 PST}
    {3919399200 -25200 1 PDT}
    {3939958800 -28800 0 PST}
    {3950848800 -25200 1 PDT}
    {3971408400 -28800 0 PST}
    {3982298400 -25200 1 PDT}
    {4002858000 -28800 0 PST}
    {4013748000 -25200 1 PDT}
    {4034307600 -28800 0 PST}
    {4045197600 -25200 1 PDT}
    {4065757200 -28800 0 PST}
    {4076647200 -25200 1 PDT}
    {4097206800 -28800 0 PST}


}

Changes to library/tzdata/America/Louisville.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314

# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Louisville) {
    {-9223372036854775808 -20582 0 LMT}
    {-2717648218 -21600 0 CST}
    {-1633276800 -18000 1 CDT}
    {-1615136400 -21600 0 CST}
    {-1601827200 -18000 1 CDT}
    {-1583686800 -21600 0 CST}
    {-1546279200 -21600 0 CST}
    {-1535904000 -18000 1 CDT}
    {-1525280400 -21600 0 CST}
    {-905097600 -18000 1 CDT}
    {-891795600 -21600 0 CST}
    {-883591200 -21600 0 CST}
    {-880214400 -18000 1 CWT}
    {-769395600 -18000 1 CPT}
    {-765392400 -21600 0 CST}
    {-757360800 -21600 0 CST}
    {-747244800 -18000 1 CDT}
    {-744224400 -21600 0 CST}
    {-715795200 -18000 1 CDT}
    {-684349200 -18000 1 CDT}
    {-652899600 -18000 1 CDT}
    {-620845200 -18000 1 CDT}
    {-608144400 -21600 0 CST}
    {-589392000 -18000 1 CDT}
    {-576090000 -21600 0 CST}
    {-557942400 -18000 1 CDT}
    {-544640400 -21600 0 CST}
    {-526492800 -18000 1 CDT}
    {-513190800 -21600 0 CST}
    {-495043200 -18000 1 CDT}
    {-481741200 -21600 0 CST}
    {-463593600 -18000 1 CDT}
    {-450291600 -21600 0 CST}
    {-431539200 -18000 1 CDT}
    {-415818000 -21600 0 CST}
    {-400089600 -18000 1 CDT}
    {-384368400 -21600 0 CST}
    {-368640000 -18000 1 CDT}
    {-352918800 -21600 0 CST}
    {-337190400 -18000 1 CDT}
    {-321469200 -21600 0 CST}
    {-305740800 -18000 1 CDT}
    {-289414800 -21600 0 CST}
    {-273686400 -18000 1 CDT}
    {-266432400 -18000 0 EST}
    {-63140400 -18000 0 EST}
    {-52938000 -14400 1 EDT}
    {-37216800 -18000 0 EST}
    {-21488400 -14400 1 EDT}
    {-5767200 -18000 0 EST}
    {9961200 -14400 1 EDT}
    {25682400 -18000 0 EST}
    {41410800 -14400 1 EDT}
    {57736800 -18000 0 EST}
    {73465200 -14400 1 EDT}
    {89186400 -18000 0 EST}
    {104914800 -14400 1 EDT}
    {120636000 -18000 0 EST}
    {126687600 -18000 1 CDT}
    {152089200 -18000 0 EST}
    {162370800 -14400 1 EDT}
    {183535200 -18000 0 EST}
    {199263600 -14400 1 EDT}
    {215589600 -18000 0 EST}
    {230713200 -14400 1 EDT}
    {247039200 -18000 0 EST}
    {262767600 -14400 1 EDT}
    {278488800 -18000 0 EST}
    {294217200 -14400 1 EDT}
    {309938400 -18000 0 EST}
    {325666800 -14400 1 EDT}
    {341388000 -18000 0 EST}
    {357116400 -14400 1 EDT}
    {372837600 -18000 0 EST}
    {388566000 -14400 1 EDT}
    {404892000 -18000 0 EST}
    {420015600 -14400 1 EDT}
    {436341600 -18000 0 EST}
    {452070000 -14400 1 EDT}
    {467791200 -18000 0 EST}
    {483519600 -14400 1 EDT}
    {499240800 -18000 0 EST}
    {514969200 -14400 1 EDT}
    {530690400 -18000 0 EST}
    {544604400 -14400 1 EDT}
    {562140000 -18000 0 EST}
    {576054000 -14400 1 EDT}
    {594194400 -18000 0 EST}
    {607503600 -14400 1 EDT}
    {625644000 -18000 0 EST}
    {638953200 -14400 1 EDT}
    {657093600 -18000 0 EST}
    {671007600 -14400 1 EDT}
    {688543200 -18000 0 EST}
    {702457200 -14400 1 EDT}
    {719992800 -18000 0 EST}
    {733906800 -14400 1 EDT}
    {752047200 -18000 0 EST}
    {765356400 -14400 1 EDT}
    {783496800 -18000 0 EST}
    {796806000 -14400 1 EDT}
    {814946400 -18000 0 EST}
    {828860400 -14400 1 EDT}
    {846396000 -18000 0 EST}
    {860310000 -14400 1 EDT}
    {877845600 -18000 0 EST}
    {891759600 -14400 1 EDT}
    {909295200 -18000 0 EST}
    {923209200 -14400 1 EDT}
    {941349600 -18000 0 EST}
    {954658800 -14400 1 EDT}
    {972799200 -18000 0 EST}
    {986108400 -14400 1 EDT}
    {1004248800 -18000 0 EST}
    {1018162800 -14400 1 EDT}
    {1035698400 -18000 0 EST}
    {1049612400 -14400 1 EDT}
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1175410800 -14400 1 EDT}
    {1193551200 -18000 0 EST}
    {1207465200 -14400 1 EDT}
    {1225000800 -18000 0 EST}
    {1238914800 -14400 1 EDT}
    {1256450400 -18000 0 EST}
    {1270364400 -14400 1 EDT}
    {1288504800 -18000 0 EST}
    {1301814000 -14400 1 EDT}
    {1319954400 -18000 0 EST}
    {1333263600 -14400 1 EDT}
    {1351404000 -18000 0 EST}
    {1365318000 -14400 1 EDT}
    {1382853600 -18000 0 EST}
    {1396767600 -14400 1 EDT}
    {1414303200 -18000 0 EST}
    {1428217200 -14400 1 EDT}
    {1445752800 -18000 0 EST}
    {1459666800 -14400 1 EDT}
    {1477807200 -18000 0 EST}
    {1491116400 -14400 1 EDT}
    {1509256800 -18000 0 EST}
    {1522566000 -14400 1 EDT}
    {1540706400 -18000 0 EST}
    {1554620400 -14400 1 EDT}
    {1572156000 -18000 0 EST}
    {1586070000 -14400 1 EDT}
    {1603605600 -18000 0 EST}
    {1617519600 -14400 1 EDT}
    {1635660000 -18000 0 EST}
    {1648969200 -14400 1 EDT}
    {1667109600 -18000 0 EST}
    {1680418800 -14400 1 EDT}
    {1698559200 -18000 0 EST}
    {1712473200 -14400 1 EDT}
    {1730008800 -18000 0 EST}
    {1743922800 -14400 1 EDT}
    {1761458400 -18000 0 EST}
    {1775372400 -14400 1 EDT}
    {1792908000 -18000 0 EST}
    {1806822000 -14400 1 EDT}
    {1824962400 -18000 0 EST}
    {1838271600 -14400 1 EDT}
    {1856412000 -18000 0 EST}
    {1869721200 -14400 1 EDT}
    {1887861600 -18000 0 EST}
    {1901775600 -14400 1 EDT}
    {1919311200 -18000 0 EST}
    {1933225200 -14400 1 EDT}
    {1950760800 -18000 0 EST}
    {1964674800 -14400 1 EDT}
    {1982815200 -18000 0 EST}
    {1996124400 -14400 1 EDT}
    {2014264800 -18000 0 EST}
    {2027574000 -14400 1 EDT}
    {2045714400 -18000 0 EST}
    {2059023600 -14400 1 EDT}
    {2077164000 -18000 0 EST}
    {2091078000 -14400 1 EDT}
    {2108613600 -18000 0 EST}
    {2122527600 -14400 1 EDT}
    {2140063200 -18000 0 EST}
    {2153977200 -14400 1 EDT}
    {2172117600 -18000 0 EST}
    {2185426800 -14400 1 EDT}
    {2203567200 -18000 0 EST}
    {2216876400 -14400 1 EDT}
    {2235016800 -18000 0 EST}
    {2248930800 -14400 1 EDT}
    {2266466400 -18000 0 EST}
    {2280380400 -14400 1 EDT}
    {2297916000 -18000 0 EST}
    {2311830000 -14400 1 EDT}
    {2329365600 -18000 0 EST}
    {2343279600 -14400 1 EDT}
    {2361420000 -18000 0 EST}
    {2374729200 -14400 1 EDT}
    {2392869600 -18000 0 EST}
    {2406178800 -14400 1 EDT}
    {2424319200 -18000 0 EST}
    {2438233200 -14400 1 EDT}
    {2455768800 -18000 0 EST}
    {2469682800 -14400 1 EDT}
    {2487218400 -18000 0 EST}
    {2501132400 -14400 1 EDT}
    {2519272800 -18000 0 EST}
    {2532582000 -14400 1 EDT}
    {2550722400 -18000 0 EST}
    {2564031600 -14400 1 EDT}
    {2582172000 -18000 0 EST}
    {2596086000 -14400 1 EDT}
    {2613621600 -18000 0 EST}
    {2627535600 -14400 1 EDT}
    {2645071200 -18000 0 EST}
    {2658985200 -14400 1 EDT}
    {2676520800 -18000 0 EST}
    {2690434800 -14400 1 EDT}
    {2708575200 -18000 0 EST}
    {2721884400 -14400 1 EDT}
    {2740024800 -18000 0 EST}
    {2753334000 -14400 1 EDT}
    {2771474400 -18000 0 EST}
    {2785388400 -14400 1 EDT}
    {2802924000 -18000 0 EST}
    {2816838000 -14400 1 EDT}
    {2834373600 -18000 0 EST}
    {2848287600 -14400 1 EDT}
    {2866428000 -18000 0 EST}
    {2879737200 -14400 1 EDT}
    {2897877600 -18000 0 EST}
    {2911186800 -14400 1 EDT}
    {2929327200 -18000 0 EST}
    {2942636400 -14400 1 EDT}
    {2960776800 -18000 0 EST}
    {2974690800 -14400 1 EDT}
    {2992226400 -18000 0 EST}
    {3006140400 -14400 1 EDT}
    {3023676000 -18000 0 EST}
    {3037590000 -14400 1 EDT}
    {3055730400 -18000 0 EST}
    {3069039600 -14400 1 EDT}
    {3087180000 -18000 0 EST}
    {3100489200 -14400 1 EDT}
    {3118629600 -18000 0 EST}
    {3132543600 -14400 1 EDT}
    {3150079200 -18000 0 EST}
    {3163993200 -14400 1 EDT}
    {3181528800 -18000 0 EST}
    {3195442800 -14400 1 EDT}
    {3212978400 -18000 0 EST}
    {3226892400 -14400 1 EDT}
    {3245032800 -18000 0 EST}
    {3258342000 -14400 1 EDT}
    {3276482400 -18000 0 EST}
    {3289791600 -14400 1 EDT}
    {3307932000 -18000 0 EST}
    {3321846000 -14400 1 EDT}
    {3339381600 -18000 0 EST}
    {3353295600 -14400 1 EDT}
    {3370831200 -18000 0 EST}
    {3384745200 -14400 1 EDT}
    {3402885600 -18000 0 EST}
    {3416194800 -14400 1 EDT}
    {3434335200 -18000 0 EST}
    {3447644400 -14400 1 EDT}
    {3465784800 -18000 0 EST}
    {3479698800 -14400 1 EDT}
    {3497234400 -18000 0 EST}
    {3511148400 -14400 1 EDT}
    {3528684000 -18000 0 EST}
    {3542598000 -14400 1 EDT}
    {3560133600 -18000 0 EST}
    {3574047600 -14400 1 EDT}
    {3592188000 -18000 0 EST}
    {3605497200 -14400 1 EDT}
    {3623637600 -18000 0 EST}
    {3636946800 -14400 1 EDT}
    {3655087200 -18000 0 EST}
    {3669001200 -14400 1 EDT}
    {3686536800 -18000 0 EST}
    {3700450800 -14400 1 EDT}
    {3717986400 -18000 0 EST}
    {3731900400 -14400 1 EDT}
    {3750040800 -18000 0 EST}
    {3763350000 -14400 1 EDT}
    {3781490400 -18000 0 EST}
    {3794799600 -14400 1 EDT}
    {3812940000 -18000 0 EST}
    {3826249200 -14400 1 EDT}
    {3844389600 -18000 0 EST}
    {3858303600 -14400 1 EDT}
    {3875839200 -18000 0 EST}
    {3889753200 -14400 1 EDT}
    {3907288800 -18000 0 EST}
    {3921202800 -14400 1 EDT}
    {3939343200 -18000 0 EST}
    {3952652400 -14400 1 EDT}
    {3970792800 -18000 0 EST}
    {3984102000 -14400 1 EDT}
    {4002242400 -18000 0 EST}
    {4016156400 -14400 1 EDT}
    {4033692000 -18000 0 EST}
    {4047606000 -14400 1 EDT}
    {4065141600 -18000 0 EST}
    {4079055600 -14400 1 EDT}
    {4096591200 -18000 0 EST}
}


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

>
1
2



























































































































































3



























































































































































4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Kentucky/Louisville)]} {



























































































































































    LoadTimeZoneFile America/Kentucky/Louisville



























































































































































}
set TZData(:America/Louisville) $TZData(:America/Kentucky/Louisville)

Changes to library/tzdata/America/Managua.

10
11
12
13
14
15
16


17
    {299134800 -21600 0 CST}
    {322034400 -18000 1 CDT}
    {330584400 -21600 0 CST}
    {694260000 -18000 1 CDT}
    {717310800 -21600 0 CST}
    {725882400 -18000 0 EST}
    {912488400 -21600 0 CST}


}







>
>

10
11
12
13
14
15
16
17
18
19
    {299134800 -21600 0 CST}
    {322034400 -18000 1 CDT}
    {330584400 -21600 0 CST}
    {694260000 -18000 1 CDT}
    {717310800 -21600 0 CST}
    {725882400 -18000 0 EST}
    {912488400 -21600 0 CST}
    {1113112800 -18000 1 CDT}
    {1127019600 -21600 0 CST}
}

Changes to library/tzdata/America/Menominee.

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131




132


133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    {1067151600 -21600 0 CST}
    {1081065600 -18000 1 CDT}
    {1099206000 -21600 0 CST}
    {1112515200 -18000 1 CDT}
    {1130655600 -21600 0 CST}
    {1143964800 -18000 1 CDT}
    {1162105200 -21600 0 CST}
    {1175414400 -18000 1 CDT}
    {1193554800 -21600 0 CST}
    {1207468800 -18000 1 CDT}
    {1225004400 -21600 0 CST}
    {1238918400 -18000 1 CDT}
    {1256454000 -21600 0 CST}
    {1270368000 -18000 1 CDT}
    {1288508400 -21600 0 CST}
    {1301817600 -18000 1 CDT}
    {1319958000 -21600 0 CST}
    {1333267200 -18000 1 CDT}
    {1351407600 -21600 0 CST}
    {1365321600 -18000 1 CDT}
    {1382857200 -21600 0 CST}
    {1396771200 -18000 1 CDT}
    {1414306800 -21600 0 CST}
    {1428220800 -18000 1 CDT}
    {1445756400 -21600 0 CST}
    {1459670400 -18000 1 CDT}
    {1477810800 -21600 0 CST}
    {1491120000 -18000 1 CDT}
    {1509260400 -21600 0 CST}
    {1522569600 -18000 1 CDT}
    {1540710000 -21600 0 CST}
    {1554624000 -18000 1 CDT}
    {1572159600 -21600 0 CST}
    {1586073600 -18000 1 CDT}
    {1603609200 -21600 0 CST}
    {1617523200 -18000 1 CDT}
    {1635663600 -21600 0 CST}
    {1648972800 -18000 1 CDT}
    {1667113200 -21600 0 CST}
    {1680422400 -18000 1 CDT}
    {1698562800 -21600 0 CST}
    {1712476800 -18000 1 CDT}
    {1730012400 -21600 0 CST}
    {1743926400 -18000 1 CDT}
    {1761462000 -21600 0 CST}
    {1775376000 -18000 1 CDT}
    {1792911600 -21600 0 CST}
    {1806825600 -18000 1 CDT}
    {1824966000 -21600 0 CST}
    {1838275200 -18000 1 CDT}
    {1856415600 -21600 0 CST}




    {1869724800 -18000 1 CDT}


    {1887865200 -21600 0 CST}
    {1901779200 -18000 1 CDT}
    {1919314800 -21600 0 CST}
    {1933228800 -18000 1 CDT}
    {1950764400 -21600 0 CST}
    {1964678400 -18000 1 CDT}
    {1982818800 -21600 0 CST}
    {1996128000 -18000 1 CDT}
    {2014268400 -21600 0 CST}
    {2027577600 -18000 1 CDT}
    {2045718000 -21600 0 CST}
    {2059027200 -18000 1 CDT}
    {2077167600 -21600 0 CST}
    {2091081600 -18000 1 CDT}
    {2108617200 -21600 0 CST}
    {2122531200 -18000 1 CDT}
    {2140066800 -21600 0 CST}
    {2153980800 -18000 1 CDT}
    {2172121200 -21600 0 CST}
    {2185430400 -18000 1 CDT}
    {2203570800 -21600 0 CST}
    {2216880000 -18000 1 CDT}
    {2235020400 -21600 0 CST}
    {2248934400 -18000 1 CDT}
    {2266470000 -21600 0 CST}
    {2280384000 -18000 1 CDT}
    {2297919600 -21600 0 CST}
    {2311833600 -18000 1 CDT}
    {2329369200 -21600 0 CST}
    {2343283200 -18000 1 CDT}
    {2361423600 -21600 0 CST}
    {2374732800 -18000 1 CDT}
    {2392873200 -21600 0 CST}
    {2406182400 -18000 1 CDT}
    {2424322800 -21600 0 CST}
    {2438236800 -18000 1 CDT}
    {2455772400 -21600 0 CST}
    {2469686400 -18000 1 CDT}
    {2487222000 -21600 0 CST}
    {2501136000 -18000 1 CDT}
    {2519276400 -21600 0 CST}
    {2532585600 -18000 1 CDT}
    {2550726000 -21600 0 CST}
    {2564035200 -18000 1 CDT}
    {2582175600 -21600 0 CST}
    {2596089600 -18000 1 CDT}
    {2613625200 -21600 0 CST}
    {2627539200 -18000 1 CDT}
    {2645074800 -21600 0 CST}
    {2658988800 -18000 1 CDT}
    {2676524400 -21600 0 CST}
    {2690438400 -18000 1 CDT}
    {2708578800 -21600 0 CST}
    {2721888000 -18000 1 CDT}
    {2740028400 -21600 0 CST}
    {2753337600 -18000 1 CDT}
    {2771478000 -21600 0 CST}
    {2785392000 -18000 1 CDT}
    {2802927600 -21600 0 CST}
    {2816841600 -18000 1 CDT}
    {2834377200 -21600 0 CST}
    {2848291200 -18000 1 CDT}
    {2866431600 -21600 0 CST}
    {2879740800 -18000 1 CDT}
    {2897881200 -21600 0 CST}
    {2911190400 -18000 1 CDT}
    {2929330800 -21600 0 CST}
    {2942640000 -18000 1 CDT}
    {2960780400 -21600 0 CST}
    {2974694400 -18000 1 CDT}
    {2992230000 -21600 0 CST}
    {3006144000 -18000 1 CDT}
    {3023679600 -21600 0 CST}
    {3037593600 -18000 1 CDT}
    {3055734000 -21600 0 CST}
    {3069043200 -18000 1 CDT}
    {3087183600 -21600 0 CST}
    {3100492800 -18000 1 CDT}
    {3118633200 -21600 0 CST}
    {3132547200 -18000 1 CDT}
    {3150082800 -21600 0 CST}
    {3163996800 -18000 1 CDT}
    {3181532400 -21600 0 CST}
    {3195446400 -18000 1 CDT}
    {3212982000 -21600 0 CST}
    {3226896000 -18000 1 CDT}
    {3245036400 -21600 0 CST}
    {3258345600 -18000 1 CDT}
    {3276486000 -21600 0 CST}
    {3289795200 -18000 1 CDT}
    {3307935600 -21600 0 CST}
    {3321849600 -18000 1 CDT}
    {3339385200 -21600 0 CST}
    {3353299200 -18000 1 CDT}
    {3370834800 -21600 0 CST}
    {3384748800 -18000 1 CDT}
    {3402889200 -21600 0 CST}
    {3416198400 -18000 1 CDT}
    {3434338800 -21600 0 CST}
    {3447648000 -18000 1 CDT}
    {3465788400 -21600 0 CST}
    {3479702400 -18000 1 CDT}
    {3497238000 -21600 0 CST}
    {3511152000 -18000 1 CDT}
    {3528687600 -21600 0 CST}
    {3542601600 -18000 1 CDT}
    {3560137200 -21600 0 CST}
    {3574051200 -18000 1 CDT}
    {3592191600 -21600 0 CST}
    {3605500800 -18000 1 CDT}
    {3623641200 -21600 0 CST}
    {3636950400 -18000 1 CDT}
    {3655090800 -21600 0 CST}
    {3669004800 -18000 1 CDT}
    {3686540400 -21600 0 CST}
    {3700454400 -18000 1 CDT}
    {3717990000 -21600 0 CST}
    {3731904000 -18000 1 CDT}
    {3750044400 -21600 0 CST}
    {3763353600 -18000 1 CDT}
    {3781494000 -21600 0 CST}
    {3794803200 -18000 1 CDT}
    {3812943600 -21600 0 CST}
    {3826252800 -18000 1 CDT}
    {3844393200 -21600 0 CST}
    {3858307200 -18000 1 CDT}
    {3875842800 -21600 0 CST}
    {3889756800 -18000 1 CDT}
    {3907292400 -21600 0 CST}
    {3921206400 -18000 1 CDT}
    {3939346800 -21600 0 CST}
    {3952656000 -18000 1 CDT}
    {3970796400 -21600 0 CST}
    {3984105600 -18000 1 CDT}
    {4002246000 -21600 0 CST}
    {4016160000 -18000 1 CDT}
    {4033695600 -21600 0 CST}
    {4047609600 -18000 1 CDT}
    {4065145200 -21600 0 CST}
    {4079059200 -18000 1 CDT}
    {4096594800 -21600 0 CST}
}







|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95


96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202


203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248


249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    {1067151600 -21600 0 CST}
    {1081065600 -18000 1 CDT}
    {1099206000 -21600 0 CST}
    {1112515200 -18000 1 CDT}
    {1130655600 -21600 0 CST}
    {1143964800 -18000 1 CDT}
    {1162105200 -21600 0 CST}
    {1173600000 -18000 1 CDT}
    {1194159600 -21600 0 CST}
    {1205049600 -18000 1 CDT}
    {1225609200 -21600 0 CST}
    {1236499200 -18000 1 CDT}
    {1257058800 -21600 0 CST}
    {1268553600 -18000 1 CDT}
    {1289113200 -21600 0 CST}


    {1300003200 -18000 1 CDT}
    {1320562800 -21600 0 CST}
    {1331452800 -18000 1 CDT}
    {1352012400 -21600 0 CST}
    {1362902400 -18000 1 CDT}
    {1383462000 -21600 0 CST}
    {1394352000 -18000 1 CDT}
    {1414911600 -21600 0 CST}
    {1425801600 -18000 1 CDT}
    {1446361200 -21600 0 CST}
    {1457856000 -18000 1 CDT}
    {1478415600 -21600 0 CST}
    {1489305600 -18000 1 CDT}
    {1509865200 -21600 0 CST}
    {1520755200 -18000 1 CDT}
    {1541314800 -21600 0 CST}
    {1552204800 -18000 1 CDT}
    {1572764400 -21600 0 CST}
    {1583654400 -18000 1 CDT}
    {1604214000 -21600 0 CST}
    {1615708800 -18000 1 CDT}
    {1636268400 -21600 0 CST}
    {1647158400 -18000 1 CDT}
    {1667718000 -21600 0 CST}
    {1678608000 -18000 1 CDT}
    {1699167600 -21600 0 CST}
    {1710057600 -18000 1 CDT}
    {1730617200 -21600 0 CST}
    {1741507200 -18000 1 CDT}
    {1762066800 -21600 0 CST}
    {1772956800 -18000 1 CDT}
    {1793516400 -21600 0 CST}
    {1805011200 -18000 1 CDT}
    {1825570800 -21600 0 CST}
    {1836460800 -18000 1 CDT}
    {1857020400 -21600 0 CST}
    {1867910400 -18000 1 CDT}
    {1888470000 -21600 0 CST}
    {1899360000 -18000 1 CDT}
    {1919919600 -21600 0 CST}
    {1930809600 -18000 1 CDT}
    {1951369200 -21600 0 CST}
    {1962864000 -18000 1 CDT}
    {1983423600 -21600 0 CST}
    {1994313600 -18000 1 CDT}
    {2014873200 -21600 0 CST}
    {2025763200 -18000 1 CDT}
    {2046322800 -21600 0 CST}
    {2057212800 -18000 1 CDT}
    {2077772400 -21600 0 CST}
    {2088662400 -18000 1 CDT}
    {2109222000 -21600 0 CST}
    {2120112000 -18000 1 CDT}
    {2140671600 -21600 0 CST}
    {2152166400 -18000 1 CDT}
    {2172726000 -21600 0 CST}
    {2183616000 -18000 1 CDT}
    {2204175600 -21600 0 CST}
    {2215065600 -18000 1 CDT}
    {2235625200 -21600 0 CST}
    {2246515200 -18000 1 CDT}
    {2267074800 -21600 0 CST}
    {2277964800 -18000 1 CDT}
    {2298524400 -21600 0 CST}
    {2309414400 -18000 1 CDT}
    {2329974000 -21600 0 CST}
    {2341468800 -18000 1 CDT}
    {2362028400 -21600 0 CST}
    {2372918400 -18000 1 CDT}
    {2393478000 -21600 0 CST}
    {2404368000 -18000 1 CDT}
    {2424927600 -21600 0 CST}
    {2435817600 -18000 1 CDT}
    {2456377200 -21600 0 CST}
    {2467267200 -18000 1 CDT}
    {2487826800 -21600 0 CST}
    {2499321600 -18000 1 CDT}
    {2519881200 -21600 0 CST}
    {2530771200 -18000 1 CDT}
    {2551330800 -21600 0 CST}
    {2562220800 -18000 1 CDT}
    {2582780400 -21600 0 CST}
    {2593670400 -18000 1 CDT}
    {2614230000 -21600 0 CST}
    {2625120000 -18000 1 CDT}
    {2645679600 -21600 0 CST}
    {2656569600 -18000 1 CDT}
    {2677129200 -21600 0 CST}
    {2688624000 -18000 1 CDT}
    {2709183600 -21600 0 CST}
    {2720073600 -18000 1 CDT}
    {2740633200 -21600 0 CST}
    {2751523200 -18000 1 CDT}
    {2772082800 -21600 0 CST}
    {2782972800 -18000 1 CDT}
    {2803532400 -21600 0 CST}
    {2814422400 -18000 1 CDT}
    {2834982000 -21600 0 CST}
    {2846476800 -18000 1 CDT}
    {2867036400 -21600 0 CST}
    {2877926400 -18000 1 CDT}
    {2898486000 -21600 0 CST}
    {2909376000 -18000 1 CDT}
    {2929935600 -21600 0 CST}
    {2940825600 -18000 1 CDT}
    {2961385200 -21600 0 CST}
    {2972275200 -18000 1 CDT}


    {2992834800 -21600 0 CST}
    {3003724800 -18000 1 CDT}
    {3024284400 -21600 0 CST}
    {3035779200 -18000 1 CDT}
    {3056338800 -21600 0 CST}
    {3067228800 -18000 1 CDT}
    {3087788400 -21600 0 CST}
    {3098678400 -18000 1 CDT}
    {3119238000 -21600 0 CST}
    {3130128000 -18000 1 CDT}
    {3150687600 -21600 0 CST}
    {3161577600 -18000 1 CDT}
    {3182137200 -21600 0 CST}
    {3193027200 -18000 1 CDT}
    {3213586800 -21600 0 CST}
    {3225081600 -18000 1 CDT}
    {3245641200 -21600 0 CST}
    {3256531200 -18000 1 CDT}
    {3277090800 -21600 0 CST}
    {3287980800 -18000 1 CDT}
    {3308540400 -21600 0 CST}
    {3319430400 -18000 1 CDT}
    {3339990000 -21600 0 CST}
    {3350880000 -18000 1 CDT}
    {3371439600 -21600 0 CST}
    {3382934400 -18000 1 CDT}
    {3403494000 -21600 0 CST}
    {3414384000 -18000 1 CDT}
    {3434943600 -21600 0 CST}
    {3445833600 -18000 1 CDT}
    {3466393200 -21600 0 CST}
    {3477283200 -18000 1 CDT}
    {3497842800 -21600 0 CST}
    {3508732800 -18000 1 CDT}
    {3529292400 -21600 0 CST}
    {3540182400 -18000 1 CDT}
    {3560742000 -21600 0 CST}
    {3572236800 -18000 1 CDT}
    {3592796400 -21600 0 CST}
    {3603686400 -18000 1 CDT}
    {3624246000 -21600 0 CST}
    {3635136000 -18000 1 CDT}
    {3655695600 -21600 0 CST}
    {3666585600 -18000 1 CDT}
    {3687145200 -21600 0 CST}
    {3698035200 -18000 1 CDT}


    {3718594800 -21600 0 CST}
    {3730089600 -18000 1 CDT}
    {3750649200 -21600 0 CST}
    {3761539200 -18000 1 CDT}
    {3782098800 -21600 0 CST}
    {3792988800 -18000 1 CDT}
    {3813548400 -21600 0 CST}
    {3824438400 -18000 1 CDT}
    {3844998000 -21600 0 CST}
    {3855888000 -18000 1 CDT}
    {3876447600 -21600 0 CST}
    {3887337600 -18000 1 CDT}
    {3907897200 -21600 0 CST}
    {3919392000 -18000 1 CDT}
    {3939951600 -21600 0 CST}
    {3950841600 -18000 1 CDT}
    {3971401200 -21600 0 CST}
    {3982291200 -18000 1 CDT}
    {4002850800 -21600 0 CST}
    {4013740800 -18000 1 CDT}
    {4034300400 -21600 0 CST}
    {4045190400 -18000 1 CDT}
    {4065750000 -21600 0 CST}
    {4076640000 -18000 1 CDT}
    {4097199600 -21600 0 CST}
}

Changes to library/tzdata/America/Montevideo.

63
64
65
66
67
68
69
70


71
    {656478000 -7200 1 UYST}
    {667965600 -10800 0 UYT}
    {688532400 -7200 1 UYST}
    {699415200 -10800 0 UYT}
    {719377200 -7200 1 UYST}
    {730864800 -10800 0 UYT}
    {1095562800 -7200 1 UYST}
    {1110679200 -10800 0 UYT}


}







|
>
>

63
64
65
66
67
68
69
70
71
72
73
    {656478000 -7200 1 UYST}
    {667965600 -10800 0 UYT}
    {688532400 -7200 1 UYST}
    {699415200 -10800 0 UYT}
    {719377200 -7200 1 UYST}
    {730864800 -10800 0 UYT}
    {1095562800 -7200 1 UYST}
    {1111896000 -10800 0 UYT}
    {1128834000 -7200 1 UYST}
    {1142136000 -10800 0 UYT}
}

Changes to library/tzdata/America/New_York.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/New_York) {
    {-9223372036854775808 -17762 0 LMT}
    {-2717651038 -18000 0 EST}
    {-1633280400 -14400 1 EDT}
    {-1615140000 -18000 0 EST}
    {-1601830800 -14400 1 EDT}
    {-1583690400 -18000 0 EST}
    {-1577905200 -18000 0 EST}
    {-1570381200 -14400 1 EDT}
    {-1551636000 -18000 0 EST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/New_York) {
    {-9223372036854775808 -17762 0 LMT}
    {-2717650800 -18000 0 EST}
    {-1633280400 -14400 1 EDT}
    {-1615140000 -18000 0 EST}
    {-1601830800 -14400 1 EDT}
    {-1583690400 -18000 0 EST}
    {-1577905200 -18000 0 EST}
    {-1570381200 -14400 1 EDT}
    {-1551636000 -18000 0 EST}
176
177
178
179
180
181
182
183
184


185
186


187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233


234
235
236
237
238
239
240
241
242
243


244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1175410800 -14400 1 EDT}
    {1193551200 -18000 0 EST}


    {1207465200 -14400 1 EDT}
    {1225000800 -18000 0 EST}


    {1238914800 -14400 1 EDT}
    {1256450400 -18000 0 EST}
    {1270364400 -14400 1 EDT}
    {1288504800 -18000 0 EST}
    {1301814000 -14400 1 EDT}
    {1319954400 -18000 0 EST}
    {1333263600 -14400 1 EDT}
    {1351404000 -18000 0 EST}
    {1365318000 -14400 1 EDT}
    {1382853600 -18000 0 EST}
    {1396767600 -14400 1 EDT}
    {1414303200 -18000 0 EST}
    {1428217200 -14400 1 EDT}
    {1445752800 -18000 0 EST}
    {1459666800 -14400 1 EDT}
    {1477807200 -18000 0 EST}
    {1491116400 -14400 1 EDT}
    {1509256800 -18000 0 EST}
    {1522566000 -14400 1 EDT}
    {1540706400 -18000 0 EST}
    {1554620400 -14400 1 EDT}
    {1572156000 -18000 0 EST}
    {1586070000 -14400 1 EDT}
    {1603605600 -18000 0 EST}
    {1617519600 -14400 1 EDT}
    {1635660000 -18000 0 EST}
    {1648969200 -14400 1 EDT}
    {1667109600 -18000 0 EST}
    {1680418800 -14400 1 EDT}
    {1698559200 -18000 0 EST}
    {1712473200 -14400 1 EDT}
    {1730008800 -18000 0 EST}
    {1743922800 -14400 1 EDT}
    {1761458400 -18000 0 EST}
    {1775372400 -14400 1 EDT}
    {1792908000 -18000 0 EST}
    {1806822000 -14400 1 EDT}
    {1824962400 -18000 0 EST}
    {1838271600 -14400 1 EDT}
    {1856412000 -18000 0 EST}
    {1869721200 -14400 1 EDT}
    {1887861600 -18000 0 EST}
    {1901775600 -14400 1 EDT}
    {1919311200 -18000 0 EST}
    {1933225200 -14400 1 EDT}
    {1950760800 -18000 0 EST}
    {1964674800 -14400 1 EDT}


    {1982815200 -18000 0 EST}
    {1996124400 -14400 1 EDT}
    {2014264800 -18000 0 EST}
    {2027574000 -14400 1 EDT}
    {2045714400 -18000 0 EST}
    {2059023600 -14400 1 EDT}
    {2077164000 -18000 0 EST}
    {2091078000 -14400 1 EDT}
    {2108613600 -18000 0 EST}
    {2122527600 -14400 1 EDT}


    {2140063200 -18000 0 EST}
    {2153977200 -14400 1 EDT}
    {2172117600 -18000 0 EST}
    {2185426800 -14400 1 EDT}
    {2203567200 -18000 0 EST}
    {2216876400 -14400 1 EDT}
    {2235016800 -18000 0 EST}
    {2248930800 -14400 1 EDT}
    {2266466400 -18000 0 EST}
    {2280380400 -14400 1 EDT}
    {2297916000 -18000 0 EST}
    {2311830000 -14400 1 EDT}
    {2329365600 -18000 0 EST}
    {2343279600 -14400 1 EDT}
    {2361420000 -18000 0 EST}
    {2374729200 -14400 1 EDT}
    {2392869600 -18000 0 EST}
    {2406178800 -14400 1 EDT}
    {2424319200 -18000 0 EST}
    {2438233200 -14400 1 EDT}
    {2455768800 -18000 0 EST}
    {2469682800 -14400 1 EDT}
    {2487218400 -18000 0 EST}
    {2501132400 -14400 1 EDT}
    {2519272800 -18000 0 EST}
    {2532582000 -14400 1 EDT}
    {2550722400 -18000 0 EST}
    {2564031600 -14400 1 EDT}
    {2582172000 -18000 0 EST}
    {2596086000 -14400 1 EDT}
    {2613621600 -18000 0 EST}
    {2627535600 -14400 1 EDT}
    {2645071200 -18000 0 EST}
    {2658985200 -14400 1 EDT}
    {2676520800 -18000 0 EST}
    {2690434800 -14400 1 EDT}
    {2708575200 -18000 0 EST}
    {2721884400 -14400 1 EDT}
    {2740024800 -18000 0 EST}
    {2753334000 -14400 1 EDT}
    {2771474400 -18000 0 EST}
    {2785388400 -14400 1 EDT}
    {2802924000 -18000 0 EST}
    {2816838000 -14400 1 EDT}
    {2834373600 -18000 0 EST}
    {2848287600 -14400 1 EDT}
    {2866428000 -18000 0 EST}
    {2879737200 -14400 1 EDT}
    {2897877600 -18000 0 EST}
    {2911186800 -14400 1 EDT}
    {2929327200 -18000 0 EST}
    {2942636400 -14400 1 EDT}
    {2960776800 -18000 0 EST}
    {2974690800 -14400 1 EDT}
    {2992226400 -18000 0 EST}
    {3006140400 -14400 1 EDT}
    {3023676000 -18000 0 EST}
    {3037590000 -14400 1 EDT}
    {3055730400 -18000 0 EST}
    {3069039600 -14400 1 EDT}
    {3087180000 -18000 0 EST}
    {3100489200 -14400 1 EDT}
    {3118629600 -18000 0 EST}
    {3132543600 -14400 1 EDT}
    {3150079200 -18000 0 EST}
    {3163993200 -14400 1 EDT}
    {3181528800 -18000 0 EST}
    {3195442800 -14400 1 EDT}
    {3212978400 -18000 0 EST}
    {3226892400 -14400 1 EDT}
    {3245032800 -18000 0 EST}
    {3258342000 -14400 1 EDT}
    {3276482400 -18000 0 EST}
    {3289791600 -14400 1 EDT}
    {3307932000 -18000 0 EST}
    {3321846000 -14400 1 EDT}
    {3339381600 -18000 0 EST}
    {3353295600 -14400 1 EDT}
    {3370831200 -18000 0 EST}
    {3384745200 -14400 1 EDT}
    {3402885600 -18000 0 EST}
    {3416194800 -14400 1 EDT}
    {3434335200 -18000 0 EST}
    {3447644400 -14400 1 EDT}
    {3465784800 -18000 0 EST}
    {3479698800 -14400 1 EDT}
    {3497234400 -18000 0 EST}
    {3511148400 -14400 1 EDT}
    {3528684000 -18000 0 EST}
    {3542598000 -14400 1 EDT}
    {3560133600 -18000 0 EST}
    {3574047600 -14400 1 EDT}
    {3592188000 -18000 0 EST}
    {3605497200 -14400 1 EDT}
    {3623637600 -18000 0 EST}
    {3636946800 -14400 1 EDT}
    {3655087200 -18000 0 EST}
    {3669001200 -14400 1 EDT}
    {3686536800 -18000 0 EST}
    {3700450800 -14400 1 EDT}
    {3717986400 -18000 0 EST}
    {3731900400 -14400 1 EDT}
    {3750040800 -18000 0 EST}
    {3763350000 -14400 1 EDT}
    {3781490400 -18000 0 EST}
    {3794799600 -14400 1 EDT}
    {3812940000 -18000 0 EST}
    {3826249200 -14400 1 EDT}
    {3844389600 -18000 0 EST}
    {3858303600 -14400 1 EDT}
    {3875839200 -18000 0 EST}
    {3889753200 -14400 1 EDT}
    {3907288800 -18000 0 EST}
    {3921202800 -14400 1 EDT}
    {3939343200 -18000 0 EST}
    {3952652400 -14400 1 EDT}
    {3970792800 -18000 0 EST}
    {3984102000 -14400 1 EDT}
    {4002242400 -18000 0 EST}
    {4016156400 -14400 1 EDT}
    {4033692000 -18000 0 EST}
    {4047606000 -14400 1 EDT}
    {4065141600 -18000 0 EST}
    {4079055600 -14400 1 EDT}
    {4096591200 -18000 0 EST}
}







|
|
>
>
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228


229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254


255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297


298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319


320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    {1067148000 -18000 0 EST}
    {1081062000 -14400 1 EDT}
    {1099202400 -18000 0 EST}
    {1112511600 -14400 1 EDT}
    {1130652000 -18000 0 EST}
    {1143961200 -14400 1 EDT}
    {1162101600 -18000 0 EST}
    {1173596400 -14400 1 EDT}
    {1194156000 -18000 0 EST}
    {1205046000 -14400 1 EDT}
    {1225605600 -18000 0 EST}
    {1236495600 -14400 1 EDT}
    {1257055200 -18000 0 EST}
    {1268550000 -14400 1 EDT}
    {1289109600 -18000 0 EST}
    {1299999600 -14400 1 EDT}
    {1320559200 -18000 0 EST}
    {1331449200 -14400 1 EDT}
    {1352008800 -18000 0 EST}
    {1362898800 -14400 1 EDT}
    {1383458400 -18000 0 EST}
    {1394348400 -14400 1 EDT}
    {1414908000 -18000 0 EST}
    {1425798000 -14400 1 EDT}
    {1446357600 -18000 0 EST}
    {1457852400 -14400 1 EDT}
    {1478412000 -18000 0 EST}
    {1489302000 -14400 1 EDT}
    {1509861600 -18000 0 EST}
    {1520751600 -14400 1 EDT}
    {1541311200 -18000 0 EST}
    {1552201200 -14400 1 EDT}
    {1572760800 -18000 0 EST}
    {1583650800 -14400 1 EDT}
    {1604210400 -18000 0 EST}
    {1615705200 -14400 1 EDT}
    {1636264800 -18000 0 EST}
    {1647154800 -14400 1 EDT}
    {1667714400 -18000 0 EST}
    {1678604400 -14400 1 EDT}
    {1699164000 -18000 0 EST}
    {1710054000 -14400 1 EDT}
    {1730613600 -18000 0 EST}
    {1741503600 -14400 1 EDT}
    {1762063200 -18000 0 EST}
    {1772953200 -14400 1 EDT}
    {1793512800 -18000 0 EST}
    {1805007600 -14400 1 EDT}
    {1825567200 -18000 0 EST}
    {1836457200 -14400 1 EDT}
    {1857016800 -18000 0 EST}
    {1867906800 -14400 1 EDT}
    {1888466400 -18000 0 EST}


    {1899356400 -14400 1 EDT}
    {1919916000 -18000 0 EST}
    {1930806000 -14400 1 EDT}
    {1951365600 -18000 0 EST}
    {1962860400 -14400 1 EDT}
    {1983420000 -18000 0 EST}
    {1994310000 -14400 1 EDT}
    {2014869600 -18000 0 EST}
    {2025759600 -14400 1 EDT}
    {2046319200 -18000 0 EST}
    {2057209200 -14400 1 EDT}
    {2077768800 -18000 0 EST}
    {2088658800 -14400 1 EDT}
    {2109218400 -18000 0 EST}
    {2120108400 -14400 1 EDT}
    {2140668000 -18000 0 EST}
    {2152162800 -14400 1 EDT}
    {2172722400 -18000 0 EST}
    {2183612400 -14400 1 EDT}
    {2204172000 -18000 0 EST}
    {2215062000 -14400 1 EDT}
    {2235621600 -18000 0 EST}
    {2246511600 -14400 1 EDT}
    {2267071200 -18000 0 EST}
    {2277961200 -14400 1 EDT}
    {2298520800 -18000 0 EST}


    {2309410800 -14400 1 EDT}
    {2329970400 -18000 0 EST}
    {2341465200 -14400 1 EDT}
    {2362024800 -18000 0 EST}
    {2372914800 -14400 1 EDT}
    {2393474400 -18000 0 EST}
    {2404364400 -14400 1 EDT}
    {2424924000 -18000 0 EST}
    {2435814000 -14400 1 EDT}
    {2456373600 -18000 0 EST}
    {2467263600 -14400 1 EDT}
    {2487823200 -18000 0 EST}
    {2499318000 -14400 1 EDT}
    {2519877600 -18000 0 EST}
    {2530767600 -14400 1 EDT}
    {2551327200 -18000 0 EST}
    {2562217200 -14400 1 EDT}
    {2582776800 -18000 0 EST}
    {2593666800 -14400 1 EDT}
    {2614226400 -18000 0 EST}
    {2625116400 -14400 1 EDT}
    {2645676000 -18000 0 EST}
    {2656566000 -14400 1 EDT}
    {2677125600 -18000 0 EST}
    {2688620400 -14400 1 EDT}
    {2709180000 -18000 0 EST}
    {2720070000 -14400 1 EDT}
    {2740629600 -18000 0 EST}
    {2751519600 -14400 1 EDT}
    {2772079200 -18000 0 EST}
    {2782969200 -14400 1 EDT}
    {2803528800 -18000 0 EST}
    {2814418800 -14400 1 EDT}
    {2834978400 -18000 0 EST}
    {2846473200 -14400 1 EDT}
    {2867032800 -18000 0 EST}
    {2877922800 -14400 1 EDT}
    {2898482400 -18000 0 EST}
    {2909372400 -14400 1 EDT}
    {2929932000 -18000 0 EST}
    {2940822000 -14400 1 EDT}
    {2961381600 -18000 0 EST}
    {2972271600 -14400 1 EDT}


    {2992831200 -18000 0 EST}
    {3003721200 -14400 1 EDT}
    {3024280800 -18000 0 EST}
    {3035775600 -14400 1 EDT}
    {3056335200 -18000 0 EST}
    {3067225200 -14400 1 EDT}
    {3087784800 -18000 0 EST}
    {3098674800 -14400 1 EDT}
    {3119234400 -18000 0 EST}
    {3130124400 -14400 1 EDT}
    {3150684000 -18000 0 EST}
    {3161574000 -14400 1 EDT}
    {3182133600 -18000 0 EST}
    {3193023600 -14400 1 EDT}
    {3213583200 -18000 0 EST}
    {3225078000 -14400 1 EDT}
    {3245637600 -18000 0 EST}
    {3256527600 -14400 1 EDT}
    {3277087200 -18000 0 EST}
    {3287977200 -14400 1 EDT}
    {3308536800 -18000 0 EST}
    {3319426800 -14400 1 EDT}


    {3339986400 -18000 0 EST}
    {3350876400 -14400 1 EDT}
    {3371436000 -18000 0 EST}
    {3382930800 -14400 1 EDT}
    {3403490400 -18000 0 EST}
    {3414380400 -14400 1 EDT}
    {3434940000 -18000 0 EST}
    {3445830000 -14400 1 EDT}
    {3466389600 -18000 0 EST}
    {3477279600 -14400 1 EDT}
    {3497839200 -18000 0 EST}
    {3508729200 -14400 1 EDT}
    {3529288800 -18000 0 EST}
    {3540178800 -14400 1 EDT}
    {3560738400 -18000 0 EST}
    {3572233200 -14400 1 EDT}
    {3592792800 -18000 0 EST}
    {3603682800 -14400 1 EDT}
    {3624242400 -18000 0 EST}
    {3635132400 -14400 1 EDT}
    {3655692000 -18000 0 EST}
    {3666582000 -14400 1 EDT}
    {3687141600 -18000 0 EST}
    {3698031600 -14400 1 EDT}
    {3718591200 -18000 0 EST}
    {3730086000 -14400 1 EDT}
    {3750645600 -18000 0 EST}
    {3761535600 -14400 1 EDT}
    {3782095200 -18000 0 EST}
    {3792985200 -14400 1 EDT}
    {3813544800 -18000 0 EST}
    {3824434800 -14400 1 EDT}
    {3844994400 -18000 0 EST}
    {3855884400 -14400 1 EDT}
    {3876444000 -18000 0 EST}
    {3887334000 -14400 1 EDT}
    {3907893600 -18000 0 EST}
    {3919388400 -14400 1 EDT}
    {3939948000 -18000 0 EST}
    {3950838000 -14400 1 EDT}
    {3971397600 -18000 0 EST}
    {3982287600 -14400 1 EDT}
    {4002847200 -18000 0 EST}
    {4013737200 -14400 1 EDT}
    {4034296800 -18000 0 EST}
    {4045186800 -14400 1 EDT}
    {4065746400 -18000 0 EST}
    {4076636400 -14400 1 EDT}
    {4097196000 -18000 0 EST}
}

Changes to library/tzdata/America/Nome.

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181


182
183
184


185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243


244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275


276
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1175425200 -28800 1 AKDT}
    {1193565600 -32400 0 AKST}
    {1207479600 -28800 1 AKDT}
    {1225015200 -32400 0 AKST}
    {1238929200 -28800 1 AKDT}
    {1256464800 -32400 0 AKST}
    {1270378800 -28800 1 AKDT}
    {1288519200 -32400 0 AKST}
    {1301828400 -28800 1 AKDT}
    {1319968800 -32400 0 AKST}
    {1333278000 -28800 1 AKDT}
    {1351418400 -32400 0 AKST}
    {1365332400 -28800 1 AKDT}
    {1382868000 -32400 0 AKST}
    {1396782000 -28800 1 AKDT}
    {1414317600 -32400 0 AKST}
    {1428231600 -28800 1 AKDT}
    {1445767200 -32400 0 AKST}
    {1459681200 -28800 1 AKDT}
    {1477821600 -32400 0 AKST}
    {1491130800 -28800 1 AKDT}
    {1509271200 -32400 0 AKST}
    {1522580400 -28800 1 AKDT}
    {1540720800 -32400 0 AKST}
    {1554634800 -28800 1 AKDT}
    {1572170400 -32400 0 AKST}
    {1586084400 -28800 1 AKDT}
    {1603620000 -32400 0 AKST}
    {1617534000 -28800 1 AKDT}
    {1635674400 -32400 0 AKST}
    {1648983600 -28800 1 AKDT}
    {1667124000 -32400 0 AKST}
    {1680433200 -28800 1 AKDT}
    {1698573600 -32400 0 AKST}
    {1712487600 -28800 1 AKDT}
    {1730023200 -32400 0 AKST}
    {1743937200 -28800 1 AKDT}
    {1761472800 -32400 0 AKST}
    {1775386800 -28800 1 AKDT}
    {1792922400 -32400 0 AKST}
    {1806836400 -28800 1 AKDT}
    {1824976800 -32400 0 AKST}
    {1838286000 -28800 1 AKDT}
    {1856426400 -32400 0 AKST}
    {1869735600 -28800 1 AKDT}
    {1887876000 -32400 0 AKST}
    {1901790000 -28800 1 AKDT}
    {1919325600 -32400 0 AKST}
    {1933239600 -28800 1 AKDT}
    {1950775200 -32400 0 AKST}
    {1964689200 -28800 1 AKDT}
    {1982829600 -32400 0 AKST}
    {1996138800 -28800 1 AKDT}
    {2014279200 -32400 0 AKST}
    {2027588400 -28800 1 AKDT}
    {2045728800 -32400 0 AKST}
    {2059038000 -28800 1 AKDT}
    {2077178400 -32400 0 AKST}
    {2091092400 -28800 1 AKDT}
    {2108628000 -32400 0 AKST}
    {2122542000 -28800 1 AKDT}
    {2140077600 -32400 0 AKST}
    {2153991600 -28800 1 AKDT}
    {2172132000 -32400 0 AKST}
    {2185441200 -28800 1 AKDT}
    {2203581600 -32400 0 AKST}
    {2216890800 -28800 1 AKDT}
    {2235031200 -32400 0 AKST}
    {2248945200 -28800 1 AKDT}
    {2266480800 -32400 0 AKST}
    {2280394800 -28800 1 AKDT}
    {2297930400 -32400 0 AKST}
    {2311844400 -28800 1 AKDT}
    {2329380000 -32400 0 AKST}
    {2343294000 -28800 1 AKDT}
    {2361434400 -32400 0 AKST}
    {2374743600 -28800 1 AKDT}
    {2392884000 -32400 0 AKST}
    {2406193200 -28800 1 AKDT}
    {2424333600 -32400 0 AKST}
    {2438247600 -28800 1 AKDT}
    {2455783200 -32400 0 AKST}
    {2469697200 -28800 1 AKDT}
    {2487232800 -32400 0 AKST}
    {2501146800 -28800 1 AKDT}
    {2519287200 -32400 0 AKST}
    {2532596400 -28800 1 AKDT}
    {2550736800 -32400 0 AKST}
    {2564046000 -28800 1 AKDT}
    {2582186400 -32400 0 AKST}
    {2596100400 -28800 1 AKDT}
    {2613636000 -32400 0 AKST}


    {2627550000 -28800 1 AKDT}
    {2645085600 -32400 0 AKST}
    {2658999600 -28800 1 AKDT}


    {2676535200 -32400 0 AKST}
    {2690449200 -28800 1 AKDT}
    {2708589600 -32400 0 AKST}
    {2721898800 -28800 1 AKDT}
    {2740039200 -32400 0 AKST}
    {2753348400 -28800 1 AKDT}
    {2771488800 -32400 0 AKST}
    {2785402800 -28800 1 AKDT}
    {2802938400 -32400 0 AKST}
    {2816852400 -28800 1 AKDT}
    {2834388000 -32400 0 AKST}
    {2848302000 -28800 1 AKDT}
    {2866442400 -32400 0 AKST}
    {2879751600 -28800 1 AKDT}
    {2897892000 -32400 0 AKST}
    {2911201200 -28800 1 AKDT}
    {2929341600 -32400 0 AKST}
    {2942650800 -28800 1 AKDT}
    {2960791200 -32400 0 AKST}
    {2974705200 -28800 1 AKDT}
    {2992240800 -32400 0 AKST}
    {3006154800 -28800 1 AKDT}
    {3023690400 -32400 0 AKST}
    {3037604400 -28800 1 AKDT}
    {3055744800 -32400 0 AKST}
    {3069054000 -28800 1 AKDT}
    {3087194400 -32400 0 AKST}
    {3100503600 -28800 1 AKDT}
    {3118644000 -32400 0 AKST}
    {3132558000 -28800 1 AKDT}
    {3150093600 -32400 0 AKST}
    {3164007600 -28800 1 AKDT}
    {3181543200 -32400 0 AKST}
    {3195457200 -28800 1 AKDT}
    {3212992800 -32400 0 AKST}
    {3226906800 -28800 1 AKDT}
    {3245047200 -32400 0 AKST}
    {3258356400 -28800 1 AKDT}
    {3276496800 -32400 0 AKST}
    {3289806000 -28800 1 AKDT}
    {3307946400 -32400 0 AKST}
    {3321860400 -28800 1 AKDT}
    {3339396000 -32400 0 AKST}
    {3353310000 -28800 1 AKDT}
    {3370845600 -32400 0 AKST}
    {3384759600 -28800 1 AKDT}
    {3402900000 -32400 0 AKST}
    {3416209200 -28800 1 AKDT}
    {3434349600 -32400 0 AKST}
    {3447658800 -28800 1 AKDT}
    {3465799200 -32400 0 AKST}
    {3479713200 -28800 1 AKDT}
    {3497248800 -32400 0 AKST}
    {3511162800 -28800 1 AKDT}
    {3528698400 -32400 0 AKST}
    {3542612400 -28800 1 AKDT}
    {3560148000 -32400 0 AKST}
    {3574062000 -28800 1 AKDT}
    {3592202400 -32400 0 AKST}


    {3605511600 -28800 1 AKDT}
    {3623652000 -32400 0 AKST}
    {3636961200 -28800 1 AKDT}
    {3655101600 -32400 0 AKST}
    {3669015600 -28800 1 AKDT}
    {3686551200 -32400 0 AKST}
    {3700465200 -28800 1 AKDT}
    {3718000800 -32400 0 AKST}
    {3731914800 -28800 1 AKDT}
    {3750055200 -32400 0 AKST}
    {3763364400 -28800 1 AKDT}
    {3781504800 -32400 0 AKST}
    {3794814000 -28800 1 AKDT}
    {3812954400 -32400 0 AKST}
    {3826263600 -28800 1 AKDT}
    {3844404000 -32400 0 AKST}
    {3858318000 -28800 1 AKDT}
    {3875853600 -32400 0 AKST}
    {3889767600 -28800 1 AKDT}
    {3907303200 -32400 0 AKST}
    {3921217200 -28800 1 AKDT}
    {3939357600 -32400 0 AKST}
    {3952666800 -28800 1 AKDT}
    {3970807200 -32400 0 AKST}
    {3984116400 -28800 1 AKDT}
    {4002256800 -32400 0 AKST}
    {4016170800 -28800 1 AKDT}
    {4033706400 -32400 0 AKST}
    {4047620400 -28800 1 AKDT}
    {4065156000 -32400 0 AKST}
    {4079070000 -28800 1 AKDT}
    {4096605600 -32400 0 AKST}


}







|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>

83
84
85
86
87
88
89
90
91
92
93
94
95
96


97
98
99
100
101
102
103
104
105
106
107
108


109
110
111
112
113


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204


205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1173610800 -28800 1 AKDT}
    {1194170400 -32400 0 AKST}
    {1205060400 -28800 1 AKDT}
    {1225620000 -32400 0 AKST}
    {1236510000 -28800 1 AKDT}
    {1257069600 -32400 0 AKST}
    {1268564400 -28800 1 AKDT}


    {1289124000 -32400 0 AKST}
    {1300014000 -28800 1 AKDT}
    {1320573600 -32400 0 AKST}
    {1331463600 -28800 1 AKDT}
    {1352023200 -32400 0 AKST}
    {1362913200 -28800 1 AKDT}
    {1383472800 -32400 0 AKST}
    {1394362800 -28800 1 AKDT}
    {1414922400 -32400 0 AKST}
    {1425812400 -28800 1 AKDT}
    {1446372000 -32400 0 AKST}
    {1457866800 -28800 1 AKDT}


    {1478426400 -32400 0 AKST}
    {1489316400 -28800 1 AKDT}
    {1509876000 -32400 0 AKST}
    {1520766000 -28800 1 AKDT}
    {1541325600 -32400 0 AKST}


    {1552215600 -28800 1 AKDT}
    {1572775200 -32400 0 AKST}
    {1583665200 -28800 1 AKDT}
    {1604224800 -32400 0 AKST}
    {1615719600 -28800 1 AKDT}
    {1636279200 -32400 0 AKST}
    {1647169200 -28800 1 AKDT}
    {1667728800 -32400 0 AKST}
    {1678618800 -28800 1 AKDT}
    {1699178400 -32400 0 AKST}
    {1710068400 -28800 1 AKDT}
    {1730628000 -32400 0 AKST}
    {1741518000 -28800 1 AKDT}
    {1762077600 -32400 0 AKST}
    {1772967600 -28800 1 AKDT}
    {1793527200 -32400 0 AKST}
    {1805022000 -28800 1 AKDT}
    {1825581600 -32400 0 AKST}
    {1836471600 -28800 1 AKDT}
    {1857031200 -32400 0 AKST}
    {1867921200 -28800 1 AKDT}
    {1888480800 -32400 0 AKST}
    {1899370800 -28800 1 AKDT}
    {1919930400 -32400 0 AKST}
    {1930820400 -28800 1 AKDT}
    {1951380000 -32400 0 AKST}
    {1962874800 -28800 1 AKDT}
    {1983434400 -32400 0 AKST}
    {1994324400 -28800 1 AKDT}
    {2014884000 -32400 0 AKST}
    {2025774000 -28800 1 AKDT}
    {2046333600 -32400 0 AKST}
    {2057223600 -28800 1 AKDT}
    {2077783200 -32400 0 AKST}
    {2088673200 -28800 1 AKDT}
    {2109232800 -32400 0 AKST}
    {2120122800 -28800 1 AKDT}
    {2140682400 -32400 0 AKST}
    {2152177200 -28800 1 AKDT}
    {2172736800 -32400 0 AKST}
    {2183626800 -28800 1 AKDT}
    {2204186400 -32400 0 AKST}
    {2215076400 -28800 1 AKDT}
    {2235636000 -32400 0 AKST}
    {2246526000 -28800 1 AKDT}
    {2267085600 -32400 0 AKST}
    {2277975600 -28800 1 AKDT}
    {2298535200 -32400 0 AKST}
    {2309425200 -28800 1 AKDT}
    {2329984800 -32400 0 AKST}
    {2341479600 -28800 1 AKDT}
    {2362039200 -32400 0 AKST}
    {2372929200 -28800 1 AKDT}
    {2393488800 -32400 0 AKST}
    {2404378800 -28800 1 AKDT}
    {2424938400 -32400 0 AKST}
    {2435828400 -28800 1 AKDT}
    {2456388000 -32400 0 AKST}
    {2467278000 -28800 1 AKDT}
    {2487837600 -32400 0 AKST}
    {2499332400 -28800 1 AKDT}
    {2519892000 -32400 0 AKST}
    {2530782000 -28800 1 AKDT}
    {2551341600 -32400 0 AKST}
    {2562231600 -28800 1 AKDT}
    {2582791200 -32400 0 AKST}
    {2593681200 -28800 1 AKDT}
    {2614240800 -32400 0 AKST}
    {2625130800 -28800 1 AKDT}
    {2645690400 -32400 0 AKST}
    {2656580400 -28800 1 AKDT}
    {2677140000 -32400 0 AKST}
    {2688634800 -28800 1 AKDT}
    {2709194400 -32400 0 AKST}
    {2720084400 -28800 1 AKDT}
    {2740644000 -32400 0 AKST}
    {2751534000 -28800 1 AKDT}
    {2772093600 -32400 0 AKST}
    {2782983600 -28800 1 AKDT}
    {2803543200 -32400 0 AKST}
    {2814433200 -28800 1 AKDT}
    {2834992800 -32400 0 AKST}
    {2846487600 -28800 1 AKDT}
    {2867047200 -32400 0 AKST}
    {2877937200 -28800 1 AKDT}
    {2898496800 -32400 0 AKST}
    {2909386800 -28800 1 AKDT}
    {2929946400 -32400 0 AKST}
    {2940836400 -28800 1 AKDT}
    {2961396000 -32400 0 AKST}
    {2972286000 -28800 1 AKDT}


    {2992845600 -32400 0 AKST}
    {3003735600 -28800 1 AKDT}
    {3024295200 -32400 0 AKST}
    {3035790000 -28800 1 AKDT}
    {3056349600 -32400 0 AKST}
    {3067239600 -28800 1 AKDT}
    {3087799200 -32400 0 AKST}
    {3098689200 -28800 1 AKDT}
    {3119248800 -32400 0 AKST}
    {3130138800 -28800 1 AKDT}
    {3150698400 -32400 0 AKST}
    {3161588400 -28800 1 AKDT}
    {3182148000 -32400 0 AKST}
    {3193038000 -28800 1 AKDT}
    {3213597600 -32400 0 AKST}
    {3225092400 -28800 1 AKDT}
    {3245652000 -32400 0 AKST}
    {3256542000 -28800 1 AKDT}
    {3277101600 -32400 0 AKST}
    {3287991600 -28800 1 AKDT}
    {3308551200 -32400 0 AKST}
    {3319441200 -28800 1 AKDT}
    {3340000800 -32400 0 AKST}
    {3350890800 -28800 1 AKDT}
    {3371450400 -32400 0 AKST}
    {3382945200 -28800 1 AKDT}
    {3403504800 -32400 0 AKST}
    {3414394800 -28800 1 AKDT}
    {3434954400 -32400 0 AKST}
    {3445844400 -28800 1 AKDT}
    {3466404000 -32400 0 AKST}
    {3477294000 -28800 1 AKDT}
    {3497853600 -32400 0 AKST}
    {3508743600 -28800 1 AKDT}
    {3529303200 -32400 0 AKST}
    {3540193200 -28800 1 AKDT}
    {3560752800 -32400 0 AKST}
    {3572247600 -28800 1 AKDT}
    {3592807200 -32400 0 AKST}
    {3603697200 -28800 1 AKDT}
    {3624256800 -32400 0 AKST}
    {3635146800 -28800 1 AKDT}
    {3655706400 -32400 0 AKST}
    {3666596400 -28800 1 AKDT}
    {3687156000 -32400 0 AKST}
    {3698046000 -28800 1 AKDT}
    {3718605600 -32400 0 AKST}
    {3730100400 -28800 1 AKDT}
    {3750660000 -32400 0 AKST}
    {3761550000 -28800 1 AKDT}
    {3782109600 -32400 0 AKST}
    {3792999600 -28800 1 AKDT}
    {3813559200 -32400 0 AKST}
    {3824449200 -28800 1 AKDT}
    {3845008800 -32400 0 AKST}
    {3855898800 -28800 1 AKDT}
    {3876458400 -32400 0 AKST}
    {3887348400 -28800 1 AKDT}
    {3907908000 -32400 0 AKST}
    {3919402800 -28800 1 AKDT}
    {3939962400 -32400 0 AKST}
    {3950852400 -28800 1 AKDT}
    {3971412000 -32400 0 AKST}
    {3982302000 -28800 1 AKDT}
    {4002861600 -32400 0 AKST}
    {4013751600 -28800 1 AKDT}
    {4034311200 -32400 0 AKST}
    {4045201200 -28800 1 AKDT}
    {4065760800 -32400 0 AKST}
    {4076650800 -28800 1 AKDT}
    {4097210400 -32400 0 AKST}
}

Changes to library/tzdata/America/North_Dakota/Center.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/North_Dakota/Center) {
    {-9223372036854775808 -24312 0 LMT}
    {-2717644488 -25200 0 MST}
    {-1633273200 -21600 1 MDT}
    {-1615132800 -25200 0 MST}
    {-1601823600 -21600 1 MDT}
    {-1583683200 -25200 0 MST}
    {-880210800 -21600 1 MWT}
    {-769395600 -21600 1 MPT}
    {-765388800 -25200 0 MST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/North_Dakota/Center) {
    {-9223372036854775808 -24312 0 LMT}
    {-2717643600 -25200 0 MST}
    {-1633273200 -21600 1 MDT}
    {-1615132800 -25200 0 MST}
    {-1601823600 -21600 1 MDT}
    {-1583683200 -25200 0 MST}
    {-880210800 -21600 1 MWT}
    {-769395600 -21600 1 MPT}
    {-765388800 -25200 0 MST}
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136




137


138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
    {1067151600 -21600 0 CST}
    {1081065600 -18000 1 CDT}
    {1099206000 -21600 0 CST}
    {1112515200 -18000 1 CDT}
    {1130655600 -21600 0 CST}
    {1143964800 -18000 1 CDT}
    {1162105200 -21600 0 CST}
    {1175414400 -18000 1 CDT}
    {1193554800 -21600 0 CST}
    {1207468800 -18000 1 CDT}
    {1225004400 -21600 0 CST}
    {1238918400 -18000 1 CDT}
    {1256454000 -21600 0 CST}
    {1270368000 -18000 1 CDT}
    {1288508400 -21600 0 CST}
    {1301817600 -18000 1 CDT}
    {1319958000 -21600 0 CST}
    {1333267200 -18000 1 CDT}
    {1351407600 -21600 0 CST}
    {1365321600 -18000 1 CDT}
    {1382857200 -21600 0 CST}
    {1396771200 -18000 1 CDT}
    {1414306800 -21600 0 CST}
    {1428220800 -18000 1 CDT}
    {1445756400 -21600 0 CST}
    {1459670400 -18000 1 CDT}
    {1477810800 -21600 0 CST}
    {1491120000 -18000 1 CDT}
    {1509260400 -21600 0 CST}
    {1522569600 -18000 1 CDT}
    {1540710000 -21600 0 CST}
    {1554624000 -18000 1 CDT}
    {1572159600 -21600 0 CST}
    {1586073600 -18000 1 CDT}
    {1603609200 -21600 0 CST}
    {1617523200 -18000 1 CDT}
    {1635663600 -21600 0 CST}
    {1648972800 -18000 1 CDT}
    {1667113200 -21600 0 CST}
    {1680422400 -18000 1 CDT}
    {1698562800 -21600 0 CST}
    {1712476800 -18000 1 CDT}
    {1730012400 -21600 0 CST}
    {1743926400 -18000 1 CDT}
    {1761462000 -21600 0 CST}
    {1775376000 -18000 1 CDT}
    {1792911600 -21600 0 CST}
    {1806825600 -18000 1 CDT}
    {1824966000 -21600 0 CST}
    {1838275200 -18000 1 CDT}
    {1856415600 -21600 0 CST}




    {1869724800 -18000 1 CDT}


    {1887865200 -21600 0 CST}
    {1901779200 -18000 1 CDT}
    {1919314800 -21600 0 CST}
    {1933228800 -18000 1 CDT}
    {1950764400 -21600 0 CST}
    {1964678400 -18000 1 CDT}
    {1982818800 -21600 0 CST}
    {1996128000 -18000 1 CDT}
    {2014268400 -21600 0 CST}
    {2027577600 -18000 1 CDT}
    {2045718000 -21600 0 CST}
    {2059027200 -18000 1 CDT}
    {2077167600 -21600 0 CST}
    {2091081600 -18000 1 CDT}
    {2108617200 -21600 0 CST}
    {2122531200 -18000 1 CDT}
    {2140066800 -21600 0 CST}
    {2153980800 -18000 1 CDT}
    {2172121200 -21600 0 CST}
    {2185430400 -18000 1 CDT}
    {2203570800 -21600 0 CST}
    {2216880000 -18000 1 CDT}
    {2235020400 -21600 0 CST}
    {2248934400 -18000 1 CDT}
    {2266470000 -21600 0 CST}
    {2280384000 -18000 1 CDT}
    {2297919600 -21600 0 CST}
    {2311833600 -18000 1 CDT}
    {2329369200 -21600 0 CST}
    {2343283200 -18000 1 CDT}
    {2361423600 -21600 0 CST}
    {2374732800 -18000 1 CDT}
    {2392873200 -21600 0 CST}
    {2406182400 -18000 1 CDT}
    {2424322800 -21600 0 CST}
    {2438236800 -18000 1 CDT}
    {2455772400 -21600 0 CST}
    {2469686400 -18000 1 CDT}
    {2487222000 -21600 0 CST}
    {2501136000 -18000 1 CDT}
    {2519276400 -21600 0 CST}
    {2532585600 -18000 1 CDT}
    {2550726000 -21600 0 CST}
    {2564035200 -18000 1 CDT}
    {2582175600 -21600 0 CST}
    {2596089600 -18000 1 CDT}
    {2613625200 -21600 0 CST}
    {2627539200 -18000 1 CDT}
    {2645074800 -21600 0 CST}
    {2658988800 -18000 1 CDT}
    {2676524400 -21600 0 CST}
    {2690438400 -18000 1 CDT}
    {2708578800 -21600 0 CST}
    {2721888000 -18000 1 CDT}
    {2740028400 -21600 0 CST}
    {2753337600 -18000 1 CDT}
    {2771478000 -21600 0 CST}
    {2785392000 -18000 1 CDT}
    {2802927600 -21600 0 CST}
    {2816841600 -18000 1 CDT}
    {2834377200 -21600 0 CST}
    {2848291200 -18000 1 CDT}
    {2866431600 -21600 0 CST}
    {2879740800 -18000 1 CDT}
    {2897881200 -21600 0 CST}
    {2911190400 -18000 1 CDT}
    {2929330800 -21600 0 CST}
    {2942640000 -18000 1 CDT}
    {2960780400 -21600 0 CST}
    {2974694400 -18000 1 CDT}
    {2992230000 -21600 0 CST}
    {3006144000 -18000 1 CDT}
    {3023679600 -21600 0 CST}
    {3037593600 -18000 1 CDT}
    {3055734000 -21600 0 CST}
    {3069043200 -18000 1 CDT}
    {3087183600 -21600 0 CST}
    {3100492800 -18000 1 CDT}
    {3118633200 -21600 0 CST}
    {3132547200 -18000 1 CDT}
    {3150082800 -21600 0 CST}
    {3163996800 -18000 1 CDT}
    {3181532400 -21600 0 CST}
    {3195446400 -18000 1 CDT}
    {3212982000 -21600 0 CST}
    {3226896000 -18000 1 CDT}
    {3245036400 -21600 0 CST}
    {3258345600 -18000 1 CDT}
    {3276486000 -21600 0 CST}
    {3289795200 -18000 1 CDT}
    {3307935600 -21600 0 CST}
    {3321849600 -18000 1 CDT}
    {3339385200 -21600 0 CST}
    {3353299200 -18000 1 CDT}
    {3370834800 -21600 0 CST}
    {3384748800 -18000 1 CDT}
    {3402889200 -21600 0 CST}
    {3416198400 -18000 1 CDT}
    {3434338800 -21600 0 CST}
    {3447648000 -18000 1 CDT}
    {3465788400 -21600 0 CST}
    {3479702400 -18000 1 CDT}
    {3497238000 -21600 0 CST}
    {3511152000 -18000 1 CDT}
    {3528687600 -21600 0 CST}
    {3542601600 -18000 1 CDT}
    {3560137200 -21600 0 CST}
    {3574051200 -18000 1 CDT}
    {3592191600 -21600 0 CST}
    {3605500800 -18000 1 CDT}
    {3623641200 -21600 0 CST}
    {3636950400 -18000 1 CDT}
    {3655090800 -21600 0 CST}
    {3669004800 -18000 1 CDT}
    {3686540400 -21600 0 CST}
    {3700454400 -18000 1 CDT}
    {3717990000 -21600 0 CST}
    {3731904000 -18000 1 CDT}
    {3750044400 -21600 0 CST}
    {3763353600 -18000 1 CDT}
    {3781494000 -21600 0 CST}
    {3794803200 -18000 1 CDT}
    {3812943600 -21600 0 CST}
    {3826252800 -18000 1 CDT}
    {3844393200 -21600 0 CST}
    {3858307200 -18000 1 CDT}
    {3875842800 -21600 0 CST}
    {3889756800 -18000 1 CDT}
    {3907292400 -21600 0 CST}
    {3921206400 -18000 1 CDT}
    {3939346800 -21600 0 CST}
    {3952656000 -18000 1 CDT}
    {3970796400 -21600 0 CST}
    {3984105600 -18000 1 CDT}
    {4002246000 -21600 0 CST}
    {4016160000 -18000 1 CDT}
    {4033695600 -21600 0 CST}
    {4047609600 -18000 1 CDT}
    {4065145200 -21600 0 CST}
    {4079059200 -18000 1 CDT}
    {4096594800 -21600 0 CST}
}







|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100


101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207


208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253


254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
    {1067151600 -21600 0 CST}
    {1081065600 -18000 1 CDT}
    {1099206000 -21600 0 CST}
    {1112515200 -18000 1 CDT}
    {1130655600 -21600 0 CST}
    {1143964800 -18000 1 CDT}
    {1162105200 -21600 0 CST}
    {1173600000 -18000 1 CDT}
    {1194159600 -21600 0 CST}
    {1205049600 -18000 1 CDT}
    {1225609200 -21600 0 CST}
    {1236499200 -18000 1 CDT}
    {1257058800 -21600 0 CST}
    {1268553600 -18000 1 CDT}
    {1289113200 -21600 0 CST}


    {1300003200 -18000 1 CDT}
    {1320562800 -21600 0 CST}
    {1331452800 -18000 1 CDT}
    {1352012400 -21600 0 CST}
    {1362902400 -18000 1 CDT}
    {1383462000 -21600 0 CST}
    {1394352000 -18000 1 CDT}
    {1414911600 -21600 0 CST}
    {1425801600 -18000 1 CDT}
    {1446361200 -21600 0 CST}
    {1457856000 -18000 1 CDT}
    {1478415600 -21600 0 CST}
    {1489305600 -18000 1 CDT}
    {1509865200 -21600 0 CST}
    {1520755200 -18000 1 CDT}
    {1541314800 -21600 0 CST}
    {1552204800 -18000 1 CDT}
    {1572764400 -21600 0 CST}
    {1583654400 -18000 1 CDT}
    {1604214000 -21600 0 CST}
    {1615708800 -18000 1 CDT}
    {1636268400 -21600 0 CST}
    {1647158400 -18000 1 CDT}
    {1667718000 -21600 0 CST}
    {1678608000 -18000 1 CDT}
    {1699167600 -21600 0 CST}
    {1710057600 -18000 1 CDT}
    {1730617200 -21600 0 CST}
    {1741507200 -18000 1 CDT}
    {1762066800 -21600 0 CST}
    {1772956800 -18000 1 CDT}
    {1793516400 -21600 0 CST}
    {1805011200 -18000 1 CDT}
    {1825570800 -21600 0 CST}
    {1836460800 -18000 1 CDT}
    {1857020400 -21600 0 CST}
    {1867910400 -18000 1 CDT}
    {1888470000 -21600 0 CST}
    {1899360000 -18000 1 CDT}
    {1919919600 -21600 0 CST}
    {1930809600 -18000 1 CDT}
    {1951369200 -21600 0 CST}
    {1962864000 -18000 1 CDT}
    {1983423600 -21600 0 CST}
    {1994313600 -18000 1 CDT}
    {2014873200 -21600 0 CST}
    {2025763200 -18000 1 CDT}
    {2046322800 -21600 0 CST}
    {2057212800 -18000 1 CDT}
    {2077772400 -21600 0 CST}
    {2088662400 -18000 1 CDT}
    {2109222000 -21600 0 CST}
    {2120112000 -18000 1 CDT}
    {2140671600 -21600 0 CST}
    {2152166400 -18000 1 CDT}
    {2172726000 -21600 0 CST}
    {2183616000 -18000 1 CDT}
    {2204175600 -21600 0 CST}
    {2215065600 -18000 1 CDT}
    {2235625200 -21600 0 CST}
    {2246515200 -18000 1 CDT}
    {2267074800 -21600 0 CST}
    {2277964800 -18000 1 CDT}
    {2298524400 -21600 0 CST}
    {2309414400 -18000 1 CDT}
    {2329974000 -21600 0 CST}
    {2341468800 -18000 1 CDT}
    {2362028400 -21600 0 CST}
    {2372918400 -18000 1 CDT}
    {2393478000 -21600 0 CST}
    {2404368000 -18000 1 CDT}
    {2424927600 -21600 0 CST}
    {2435817600 -18000 1 CDT}
    {2456377200 -21600 0 CST}
    {2467267200 -18000 1 CDT}
    {2487826800 -21600 0 CST}
    {2499321600 -18000 1 CDT}
    {2519881200 -21600 0 CST}
    {2530771200 -18000 1 CDT}
    {2551330800 -21600 0 CST}
    {2562220800 -18000 1 CDT}
    {2582780400 -21600 0 CST}
    {2593670400 -18000 1 CDT}
    {2614230000 -21600 0 CST}
    {2625120000 -18000 1 CDT}
    {2645679600 -21600 0 CST}
    {2656569600 -18000 1 CDT}
    {2677129200 -21600 0 CST}
    {2688624000 -18000 1 CDT}
    {2709183600 -21600 0 CST}
    {2720073600 -18000 1 CDT}
    {2740633200 -21600 0 CST}
    {2751523200 -18000 1 CDT}
    {2772082800 -21600 0 CST}
    {2782972800 -18000 1 CDT}
    {2803532400 -21600 0 CST}
    {2814422400 -18000 1 CDT}
    {2834982000 -21600 0 CST}
    {2846476800 -18000 1 CDT}
    {2867036400 -21600 0 CST}
    {2877926400 -18000 1 CDT}
    {2898486000 -21600 0 CST}
    {2909376000 -18000 1 CDT}
    {2929935600 -21600 0 CST}
    {2940825600 -18000 1 CDT}
    {2961385200 -21600 0 CST}
    {2972275200 -18000 1 CDT}


    {2992834800 -21600 0 CST}
    {3003724800 -18000 1 CDT}
    {3024284400 -21600 0 CST}
    {3035779200 -18000 1 CDT}
    {3056338800 -21600 0 CST}
    {3067228800 -18000 1 CDT}
    {3087788400 -21600 0 CST}
    {3098678400 -18000 1 CDT}
    {3119238000 -21600 0 CST}
    {3130128000 -18000 1 CDT}
    {3150687600 -21600 0 CST}
    {3161577600 -18000 1 CDT}
    {3182137200 -21600 0 CST}
    {3193027200 -18000 1 CDT}
    {3213586800 -21600 0 CST}
    {3225081600 -18000 1 CDT}
    {3245641200 -21600 0 CST}
    {3256531200 -18000 1 CDT}
    {3277090800 -21600 0 CST}
    {3287980800 -18000 1 CDT}
    {3308540400 -21600 0 CST}
    {3319430400 -18000 1 CDT}
    {3339990000 -21600 0 CST}
    {3350880000 -18000 1 CDT}
    {3371439600 -21600 0 CST}
    {3382934400 -18000 1 CDT}
    {3403494000 -21600 0 CST}
    {3414384000 -18000 1 CDT}
    {3434943600 -21600 0 CST}
    {3445833600 -18000 1 CDT}
    {3466393200 -21600 0 CST}
    {3477283200 -18000 1 CDT}
    {3497842800 -21600 0 CST}
    {3508732800 -18000 1 CDT}
    {3529292400 -21600 0 CST}
    {3540182400 -18000 1 CDT}
    {3560742000 -21600 0 CST}
    {3572236800 -18000 1 CDT}
    {3592796400 -21600 0 CST}
    {3603686400 -18000 1 CDT}
    {3624246000 -21600 0 CST}
    {3635136000 -18000 1 CDT}
    {3655695600 -21600 0 CST}
    {3666585600 -18000 1 CDT}
    {3687145200 -21600 0 CST}
    {3698035200 -18000 1 CDT}


    {3718594800 -21600 0 CST}
    {3730089600 -18000 1 CDT}
    {3750649200 -21600 0 CST}
    {3761539200 -18000 1 CDT}
    {3782098800 -21600 0 CST}
    {3792988800 -18000 1 CDT}
    {3813548400 -21600 0 CST}
    {3824438400 -18000 1 CDT}
    {3844998000 -21600 0 CST}
    {3855888000 -18000 1 CDT}
    {3876447600 -21600 0 CST}
    {3887337600 -18000 1 CDT}
    {3907897200 -21600 0 CST}
    {3919392000 -18000 1 CDT}
    {3939951600 -21600 0 CST}
    {3950841600 -18000 1 CDT}
    {3971401200 -21600 0 CST}
    {3982291200 -18000 1 CDT}
    {4002850800 -21600 0 CST}
    {4013740800 -18000 1 CDT}
    {4034300400 -21600 0 CST}
    {4045190400 -18000 1 CDT}
    {4065750000 -21600 0 CST}
    {4076640000 -18000 1 CDT}
    {4097199600 -21600 0 CST}
}

Changes to library/tzdata/America/Phoenix.

1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Phoenix) {
    {-9223372036854775808 -26898 0 LMT}
    {-2717641902 -25200 0 MST}
    {-1633273200 -21600 1 MDT}
    {-1615132800 -25200 0 MST}
    {-1601823600 -21600 1 MDT}
    {-1583683200 -25200 0 MST}
    {-880210800 -21600 1 MWT}
    {-820519140 -25200 0 MST}
    {-796841940 -25200 0 MST}




|







1
2
3
4
5
6
7
8
9
10
11
12
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:America/Phoenix) {
    {-9223372036854775808 -26898 0 LMT}
    {-2717643600 -25200 0 MST}
    {-1633273200 -21600 1 MDT}
    {-1615132800 -25200 0 MST}
    {-1601823600 -21600 1 MDT}
    {-1583683200 -25200 0 MST}
    {-880210800 -21600 1 MWT}
    {-820519140 -25200 0 MST}
    {-796841940 -25200 0 MST}

Changes to library/tzdata/America/Port-au-Prince.

30
31
32
33
34
35
36


37
    {783478800 -18000 0 EST}
    {796784400 -14400 1 EDT}
    {814928400 -18000 0 EST}
    {828838800 -14400 1 EDT}
    {846378000 -18000 0 EST}
    {860288400 -14400 1 EDT}
    {877827600 -18000 0 EST}


}







>
>

30
31
32
33
34
35
36
37
38
39
    {783478800 -18000 0 EST}
    {796784400 -14400 1 EDT}
    {814928400 -18000 0 EST}
    {828838800 -14400 1 EDT}
    {846378000 -18000 0 EST}
    {860288400 -14400 1 EDT}
    {877827600 -18000 0 EST}
    {1112504400 -14400 1 EDT}
    {1130644800 -18000 0 EST}
}

Changes to library/tzdata/America/Rosario.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Cordoba)]} {
    LoadTimeZoneFile America/Cordoba
}
set TZData(:America/Rosario) $TZData(:America/Cordoba)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Argentina/Cordoba)]} {
    LoadTimeZoneFile America/Argentina/Cordoba
}
set TZData(:America/Rosario) $TZData(:America/Argentina/Cordoba)

Changes to library/tzdata/America/Yakutat.

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181


182
183
184


185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243


244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275


276
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1175425200 -28800 1 AKDT}
    {1193565600 -32400 0 AKST}
    {1207479600 -28800 1 AKDT}
    {1225015200 -32400 0 AKST}
    {1238929200 -28800 1 AKDT}
    {1256464800 -32400 0 AKST}
    {1270378800 -28800 1 AKDT}
    {1288519200 -32400 0 AKST}
    {1301828400 -28800 1 AKDT}
    {1319968800 -32400 0 AKST}
    {1333278000 -28800 1 AKDT}
    {1351418400 -32400 0 AKST}
    {1365332400 -28800 1 AKDT}
    {1382868000 -32400 0 AKST}
    {1396782000 -28800 1 AKDT}
    {1414317600 -32400 0 AKST}
    {1428231600 -28800 1 AKDT}
    {1445767200 -32400 0 AKST}
    {1459681200 -28800 1 AKDT}
    {1477821600 -32400 0 AKST}
    {1491130800 -28800 1 AKDT}
    {1509271200 -32400 0 AKST}
    {1522580400 -28800 1 AKDT}
    {1540720800 -32400 0 AKST}
    {1554634800 -28800 1 AKDT}
    {1572170400 -32400 0 AKST}
    {1586084400 -28800 1 AKDT}
    {1603620000 -32400 0 AKST}
    {1617534000 -28800 1 AKDT}
    {1635674400 -32400 0 AKST}
    {1648983600 -28800 1 AKDT}
    {1667124000 -32400 0 AKST}
    {1680433200 -28800 1 AKDT}
    {1698573600 -32400 0 AKST}
    {1712487600 -28800 1 AKDT}
    {1730023200 -32400 0 AKST}
    {1743937200 -28800 1 AKDT}
    {1761472800 -32400 0 AKST}
    {1775386800 -28800 1 AKDT}
    {1792922400 -32400 0 AKST}
    {1806836400 -28800 1 AKDT}
    {1824976800 -32400 0 AKST}
    {1838286000 -28800 1 AKDT}
    {1856426400 -32400 0 AKST}
    {1869735600 -28800 1 AKDT}
    {1887876000 -32400 0 AKST}
    {1901790000 -28800 1 AKDT}
    {1919325600 -32400 0 AKST}
    {1933239600 -28800 1 AKDT}
    {1950775200 -32400 0 AKST}
    {1964689200 -28800 1 AKDT}
    {1982829600 -32400 0 AKST}
    {1996138800 -28800 1 AKDT}
    {2014279200 -32400 0 AKST}
    {2027588400 -28800 1 AKDT}
    {2045728800 -32400 0 AKST}
    {2059038000 -28800 1 AKDT}
    {2077178400 -32400 0 AKST}
    {2091092400 -28800 1 AKDT}
    {2108628000 -32400 0 AKST}
    {2122542000 -28800 1 AKDT}
    {2140077600 -32400 0 AKST}
    {2153991600 -28800 1 AKDT}
    {2172132000 -32400 0 AKST}
    {2185441200 -28800 1 AKDT}
    {2203581600 -32400 0 AKST}
    {2216890800 -28800 1 AKDT}
    {2235031200 -32400 0 AKST}
    {2248945200 -28800 1 AKDT}
    {2266480800 -32400 0 AKST}
    {2280394800 -28800 1 AKDT}
    {2297930400 -32400 0 AKST}
    {2311844400 -28800 1 AKDT}
    {2329380000 -32400 0 AKST}
    {2343294000 -28800 1 AKDT}
    {2361434400 -32400 0 AKST}
    {2374743600 -28800 1 AKDT}
    {2392884000 -32400 0 AKST}
    {2406193200 -28800 1 AKDT}
    {2424333600 -32400 0 AKST}
    {2438247600 -28800 1 AKDT}
    {2455783200 -32400 0 AKST}
    {2469697200 -28800 1 AKDT}
    {2487232800 -32400 0 AKST}
    {2501146800 -28800 1 AKDT}
    {2519287200 -32400 0 AKST}
    {2532596400 -28800 1 AKDT}
    {2550736800 -32400 0 AKST}
    {2564046000 -28800 1 AKDT}
    {2582186400 -32400 0 AKST}
    {2596100400 -28800 1 AKDT}
    {2613636000 -32400 0 AKST}


    {2627550000 -28800 1 AKDT}
    {2645085600 -32400 0 AKST}
    {2658999600 -28800 1 AKDT}


    {2676535200 -32400 0 AKST}
    {2690449200 -28800 1 AKDT}
    {2708589600 -32400 0 AKST}
    {2721898800 -28800 1 AKDT}
    {2740039200 -32400 0 AKST}
    {2753348400 -28800 1 AKDT}
    {2771488800 -32400 0 AKST}
    {2785402800 -28800 1 AKDT}
    {2802938400 -32400 0 AKST}
    {2816852400 -28800 1 AKDT}
    {2834388000 -32400 0 AKST}
    {2848302000 -28800 1 AKDT}
    {2866442400 -32400 0 AKST}
    {2879751600 -28800 1 AKDT}
    {2897892000 -32400 0 AKST}
    {2911201200 -28800 1 AKDT}
    {2929341600 -32400 0 AKST}
    {2942650800 -28800 1 AKDT}
    {2960791200 -32400 0 AKST}
    {2974705200 -28800 1 AKDT}
    {2992240800 -32400 0 AKST}
    {3006154800 -28800 1 AKDT}
    {3023690400 -32400 0 AKST}
    {3037604400 -28800 1 AKDT}
    {3055744800 -32400 0 AKST}
    {3069054000 -28800 1 AKDT}
    {3087194400 -32400 0 AKST}
    {3100503600 -28800 1 AKDT}
    {3118644000 -32400 0 AKST}
    {3132558000 -28800 1 AKDT}
    {3150093600 -32400 0 AKST}
    {3164007600 -28800 1 AKDT}
    {3181543200 -32400 0 AKST}
    {3195457200 -28800 1 AKDT}
    {3212992800 -32400 0 AKST}
    {3226906800 -28800 1 AKDT}
    {3245047200 -32400 0 AKST}
    {3258356400 -28800 1 AKDT}
    {3276496800 -32400 0 AKST}
    {3289806000 -28800 1 AKDT}
    {3307946400 -32400 0 AKST}
    {3321860400 -28800 1 AKDT}
    {3339396000 -32400 0 AKST}
    {3353310000 -28800 1 AKDT}
    {3370845600 -32400 0 AKST}
    {3384759600 -28800 1 AKDT}
    {3402900000 -32400 0 AKST}
    {3416209200 -28800 1 AKDT}
    {3434349600 -32400 0 AKST}
    {3447658800 -28800 1 AKDT}
    {3465799200 -32400 0 AKST}
    {3479713200 -28800 1 AKDT}
    {3497248800 -32400 0 AKST}
    {3511162800 -28800 1 AKDT}
    {3528698400 -32400 0 AKST}
    {3542612400 -28800 1 AKDT}
    {3560148000 -32400 0 AKST}
    {3574062000 -28800 1 AKDT}
    {3592202400 -32400 0 AKST}


    {3605511600 -28800 1 AKDT}
    {3623652000 -32400 0 AKST}
    {3636961200 -28800 1 AKDT}
    {3655101600 -32400 0 AKST}
    {3669015600 -28800 1 AKDT}
    {3686551200 -32400 0 AKST}
    {3700465200 -28800 1 AKDT}
    {3718000800 -32400 0 AKST}
    {3731914800 -28800 1 AKDT}
    {3750055200 -32400 0 AKST}
    {3763364400 -28800 1 AKDT}
    {3781504800 -32400 0 AKST}
    {3794814000 -28800 1 AKDT}
    {3812954400 -32400 0 AKST}
    {3826263600 -28800 1 AKDT}
    {3844404000 -32400 0 AKST}
    {3858318000 -28800 1 AKDT}
    {3875853600 -32400 0 AKST}
    {3889767600 -28800 1 AKDT}
    {3907303200 -32400 0 AKST}
    {3921217200 -28800 1 AKDT}
    {3939357600 -32400 0 AKST}
    {3952666800 -28800 1 AKDT}
    {3970807200 -32400 0 AKST}
    {3984116400 -28800 1 AKDT}
    {4002256800 -32400 0 AKST}
    {4016170800 -28800 1 AKDT}
    {4033706400 -32400 0 AKST}
    {4047620400 -28800 1 AKDT}
    {4065156000 -32400 0 AKST}
    {4079070000 -28800 1 AKDT}
    {4096605600 -32400 0 AKST}


}







|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>

83
84
85
86
87
88
89
90
91
92
93
94
95
96


97
98
99
100
101
102
103
104
105
106
107
108


109
110
111
112
113


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204


205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
    {1067162400 -32400 0 AKST}
    {1081076400 -28800 1 AKDT}
    {1099216800 -32400 0 AKST}
    {1112526000 -28800 1 AKDT}
    {1130666400 -32400 0 AKST}
    {1143975600 -28800 1 AKDT}
    {1162116000 -32400 0 AKST}
    {1173610800 -28800 1 AKDT}
    {1194170400 -32400 0 AKST}
    {1205060400 -28800 1 AKDT}
    {1225620000 -32400 0 AKST}
    {1236510000 -28800 1 AKDT}
    {1257069600 -32400 0 AKST}
    {1268564400 -28800 1 AKDT}


    {1289124000 -32400 0 AKST}
    {1300014000 -28800 1 AKDT}
    {1320573600 -32400 0 AKST}
    {1331463600 -28800 1 AKDT}
    {1352023200 -32400 0 AKST}
    {1362913200 -28800 1 AKDT}
    {1383472800 -32400 0 AKST}
    {1394362800 -28800 1 AKDT}
    {1414922400 -32400 0 AKST}
    {1425812400 -28800 1 AKDT}
    {1446372000 -32400 0 AKST}
    {1457866800 -28800 1 AKDT}


    {1478426400 -32400 0 AKST}
    {1489316400 -28800 1 AKDT}
    {1509876000 -32400 0 AKST}
    {1520766000 -28800 1 AKDT}
    {1541325600 -32400 0 AKST}


    {1552215600 -28800 1 AKDT}
    {1572775200 -32400 0 AKST}
    {1583665200 -28800 1 AKDT}
    {1604224800 -32400 0 AKST}
    {1615719600 -28800 1 AKDT}
    {1636279200 -32400 0 AKST}
    {1647169200 -28800 1 AKDT}
    {1667728800 -32400 0 AKST}
    {1678618800 -28800 1 AKDT}
    {1699178400 -32400 0 AKST}
    {1710068400 -28800 1 AKDT}
    {1730628000 -32400 0 AKST}
    {1741518000 -28800 1 AKDT}
    {1762077600 -32400 0 AKST}
    {1772967600 -28800 1 AKDT}
    {1793527200 -32400 0 AKST}
    {1805022000 -28800 1 AKDT}
    {1825581600 -32400 0 AKST}
    {1836471600 -28800 1 AKDT}
    {1857031200 -32400 0 AKST}
    {1867921200 -28800 1 AKDT}
    {1888480800 -32400 0 AKST}
    {1899370800 -28800 1 AKDT}
    {1919930400 -32400 0 AKST}
    {1930820400 -28800 1 AKDT}
    {1951380000 -32400 0 AKST}
    {1962874800 -28800 1 AKDT}
    {1983434400 -32400 0 AKST}
    {1994324400 -28800 1 AKDT}
    {2014884000 -32400 0 AKST}
    {2025774000 -28800 1 AKDT}
    {2046333600 -32400 0 AKST}
    {2057223600 -28800 1 AKDT}
    {2077783200 -32400 0 AKST}
    {2088673200 -28800 1 AKDT}
    {2109232800 -32400 0 AKST}
    {2120122800 -28800 1 AKDT}
    {2140682400 -32400 0 AKST}
    {2152177200 -28800 1 AKDT}
    {2172736800 -32400 0 AKST}
    {2183626800 -28800 1 AKDT}
    {2204186400 -32400 0 AKST}
    {2215076400 -28800 1 AKDT}
    {2235636000 -32400 0 AKST}
    {2246526000 -28800 1 AKDT}
    {2267085600 -32400 0 AKST}
    {2277975600 -28800 1 AKDT}
    {2298535200 -32400 0 AKST}
    {2309425200 -28800 1 AKDT}
    {2329984800 -32400 0 AKST}
    {2341479600 -28800 1 AKDT}
    {2362039200 -32400 0 AKST}
    {2372929200 -28800 1 AKDT}
    {2393488800 -32400 0 AKST}
    {2404378800 -28800 1 AKDT}
    {2424938400 -32400 0 AKST}
    {2435828400 -28800 1 AKDT}
    {2456388000 -32400 0 AKST}
    {2467278000 -28800 1 AKDT}
    {2487837600 -32400 0 AKST}
    {2499332400 -28800 1 AKDT}
    {2519892000 -32400 0 AKST}
    {2530782000 -28800 1 AKDT}
    {2551341600 -32400 0 AKST}
    {2562231600 -28800 1 AKDT}
    {2582791200 -32400 0 AKST}
    {2593681200 -28800 1 AKDT}
    {2614240800 -32400 0 AKST}
    {2625130800 -28800 1 AKDT}
    {2645690400 -32400 0 AKST}
    {2656580400 -28800 1 AKDT}
    {2677140000 -32400 0 AKST}
    {2688634800 -28800 1 AKDT}
    {2709194400 -32400 0 AKST}
    {2720084400 -28800 1 AKDT}
    {2740644000 -32400 0 AKST}
    {2751534000 -28800 1 AKDT}
    {2772093600 -32400 0 AKST}
    {2782983600 -28800 1 AKDT}
    {2803543200 -32400 0 AKST}
    {2814433200 -28800 1 AKDT}
    {2834992800 -32400 0 AKST}
    {2846487600 -28800 1 AKDT}
    {2867047200 -32400 0 AKST}
    {2877937200 -28800 1 AKDT}
    {2898496800 -32400 0 AKST}
    {2909386800 -28800 1 AKDT}
    {2929946400 -32400 0 AKST}
    {2940836400 -28800 1 AKDT}
    {2961396000 -32400 0 AKST}
    {2972286000 -28800 1 AKDT}


    {2992845600 -32400 0 AKST}
    {3003735600 -28800 1 AKDT}
    {3024295200 -32400 0 AKST}
    {3035790000 -28800 1 AKDT}
    {3056349600 -32400 0 AKST}
    {3067239600 -28800 1 AKDT}
    {3087799200 -32400 0 AKST}
    {3098689200 -28800 1 AKDT}
    {3119248800 -32400 0 AKST}
    {3130138800 -28800 1 AKDT}
    {3150698400 -32400 0 AKST}
    {3161588400 -28800 1 AKDT}
    {3182148000 -32400 0 AKST}
    {3193038000 -28800 1 AKDT}
    {3213597600 -32400 0 AKST}
    {3225092400 -28800 1 AKDT}
    {3245652000 -32400 0 AKST}
    {3256542000 -28800 1 AKDT}
    {3277101600 -32400 0 AKST}
    {3287991600 -28800 1 AKDT}
    {3308551200 -32400 0 AKST}
    {3319441200 -28800 1 AKDT}
    {3340000800 -32400 0 AKST}
    {3350890800 -28800 1 AKDT}
    {3371450400 -32400 0 AKST}
    {3382945200 -28800 1 AKDT}
    {3403504800 -32400 0 AKST}
    {3414394800 -28800 1 AKDT}
    {3434954400 -32400 0 AKST}
    {3445844400 -28800 1 AKDT}
    {3466404000 -32400 0 AKST}
    {3477294000 -28800 1 AKDT}
    {3497853600 -32400 0 AKST}
    {3508743600 -28800 1 AKDT}
    {3529303200 -32400 0 AKST}
    {3540193200 -28800 1 AKDT}
    {3560752800 -32400 0 AKST}
    {3572247600 -28800 1 AKDT}
    {3592807200 -32400 0 AKST}
    {3603697200 -28800 1 AKDT}
    {3624256800 -32400 0 AKST}
    {3635146800 -28800 1 AKDT}
    {3655706400 -32400 0 AKST}
    {3666596400 -28800 1 AKDT}
    {3687156000 -32400 0 AKST}
    {3698046000 -28800 1 AKDT}
    {3718605600 -32400 0 AKST}
    {3730100400 -28800 1 AKDT}
    {3750660000 -32400 0 AKST}
    {3761550000 -28800 1 AKDT}
    {3782109600 -32400 0 AKST}
    {3792999600 -28800 1 AKDT}
    {3813559200 -32400 0 AKST}
    {3824449200 -28800 1 AKDT}
    {3845008800 -32400 0 AKST}
    {3855898800 -28800 1 AKDT}
    {3876458400 -32400 0 AKST}
    {3887348400 -28800 1 AKDT}
    {3907908000 -32400 0 AKST}
    {3919402800 -28800 1 AKDT}
    {3939962400 -32400 0 AKST}
    {3950852400 -28800 1 AKDT}
    {3971412000 -32400 0 AKST}
    {3982302000 -28800 1 AKDT}
    {4002861600 -32400 0 AKST}
    {4013751600 -28800 1 AKDT}
    {4034311200 -32400 0 AKST}
    {4045201200 -28800 1 AKDT}
    {4065760800 -32400 0 AKST}
    {4076650800 -28800 1 AKDT}
    {4097210400 -32400 0 AKST}
}

Changes to library/tzdata/Asia/Almaty.

48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
    {1004234400 21600 0 ALMT}
    {1017540000 25200 1 ALMST}
    {1035684000 21600 0 ALMT}
    {1048989600 25200 1 ALMST}
    {1067133600 21600 0 ALMT}
    {1080439200 25200 1 ALMST}
    {1099188000 21600 0 ALMT}
    {1111888800 25200 1 ALMST}
    {1130637600 21600 0 ALMT}
    {1143338400 25200 1 ALMST}
    {1162087200 21600 0 ALMT}
    {1174788000 25200 1 ALMST}
    {1193536800 21600 0 ALMT}
    {1206842400 25200 1 ALMST}
    {1224986400 21600 0 ALMT}
    {1238292000 25200 1 ALMST}
    {1256436000 21600 0 ALMT}
    {1269741600 25200 1 ALMST}
    {1288490400 21600 0 ALMT}
    {1301191200 25200 1 ALMST}
    {1319940000 21600 0 ALMT}
    {1332640800 25200 1 ALMST}
    {1351389600 21600 0 ALMT}
    {1364695200 25200 1 ALMST}
    {1382839200 21600 0 ALMT}
    {1396144800 25200 1 ALMST}
    {1414288800 21600 0 ALMT}
    {1427594400 25200 1 ALMST}
    {1445738400 21600 0 ALMT}
    {1459044000 25200 1 ALMST}
    {1477792800 21600 0 ALMT}
    {1490493600 25200 1 ALMST}
    {1509242400 21600 0 ALMT}
    {1521943200 25200 1 ALMST}
    {1540692000 21600 0 ALMT}
    {1553997600 25200 1 ALMST}
    {1572141600 21600 0 ALMT}
    {1585447200 25200 1 ALMST}
    {1603591200 21600 0 ALMT}
    {1616896800 25200 1 ALMST}
    {1635645600 21600 0 ALMT}
    {1648346400 25200 1 ALMST}
    {1667095200 21600 0 ALMT}
    {1679796000 25200 1 ALMST}
    {1698544800 21600 0 ALMT}
    {1711850400 25200 1 ALMST}
    {1729994400 21600 0 ALMT}
    {1743300000 25200 1 ALMST}
    {1761444000 21600 0 ALMT}
    {1774749600 25200 1 ALMST}
    {1792893600 21600 0 ALMT}
    {1806199200 25200 1 ALMST}
    {1824948000 21600 0 ALMT}
    {1837648800 25200 1 ALMST}
    {1856397600 21600 0 ALMT}
    {1869098400 25200 1 ALMST}
    {1887847200 21600 0 ALMT}
    {1901152800 25200 1 ALMST}
    {1919296800 21600 0 ALMT}
    {1932602400 25200 1 ALMST}
    {1950746400 21600 0 ALMT}
    {1964052000 25200 1 ALMST}
    {1982800800 21600 0 ALMT}
    {1995501600 25200 1 ALMST}
    {2014250400 21600 0 ALMT}
    {2026951200 25200 1 ALMST}
    {2045700000 21600 0 ALMT}
    {2058400800 25200 1 ALMST}
    {2077149600 21600 0 ALMT}
    {2090455200 25200 1 ALMST}
    {2108599200 21600 0 ALMT}
    {2121904800 25200 1 ALMST}
    {2140048800 21600 0 ALMT}
    {2153354400 25200 1 ALMST}
    {2172103200 21600 0 ALMT}
    {2184804000 25200 1 ALMST}
    {2203552800 21600 0 ALMT}
    {2216253600 25200 1 ALMST}
    {2235002400 21600 0 ALMT}
    {2248308000 25200 1 ALMST}
    {2266452000 21600 0 ALMT}
    {2279757600 25200 1 ALMST}
    {2297901600 21600 0 ALMT}
    {2311207200 25200 1 ALMST}
    {2329351200 21600 0 ALMT}
    {2342656800 25200 1 ALMST}
    {2361405600 21600 0 ALMT}
    {2374106400 25200 1 ALMST}
    {2392855200 21600 0 ALMT}
    {2405556000 25200 1 ALMST}
    {2424304800 21600 0 ALMT}
    {2437610400 25200 1 ALMST}
    {2455754400 21600 0 ALMT}
    {2469060000 25200 1 ALMST}
    {2487204000 21600 0 ALMT}
    {2500509600 25200 1 ALMST}
    {2519258400 21600 0 ALMT}
    {2531959200 25200 1 ALMST}
    {2550708000 21600 0 ALMT}
    {2563408800 25200 1 ALMST}
    {2582157600 21600 0 ALMT}
    {2595463200 25200 1 ALMST}
    {2613607200 21600 0 ALMT}
    {2626912800 25200 1 ALMST}
    {2645056800 21600 0 ALMT}
    {2658362400 25200 1 ALMST}
    {2676506400 21600 0 ALMT}
    {2689812000 25200 1 ALMST}
    {2708560800 21600 0 ALMT}
    {2721261600 25200 1 ALMST}
    {2740010400 21600 0 ALMT}
    {2752711200 25200 1 ALMST}
    {2771460000 21600 0 ALMT}
    {2784765600 25200 1 ALMST}
    {2802909600 21600 0 ALMT}
    {2816215200 25200 1 ALMST}
    {2834359200 21600 0 ALMT}
    {2847664800 25200 1 ALMST}
    {2866413600 21600 0 ALMT}
    {2879114400 25200 1 ALMST}
    {2897863200 21600 0 ALMT}
    {2910564000 25200 1 ALMST}
    {2929312800 21600 0 ALMT}
    {2942013600 25200 1 ALMST}
    {2960762400 21600 0 ALMT}
    {2974068000 25200 1 ALMST}
    {2992212000 21600 0 ALMT}
    {3005517600 25200 1 ALMST}
    {3023661600 21600 0 ALMT}
    {3036967200 25200 1 ALMST}
    {3055716000 21600 0 ALMT}
    {3068416800 25200 1 ALMST}
    {3087165600 21600 0 ALMT}
    {3099866400 25200 1 ALMST}
    {3118615200 21600 0 ALMT}
    {3131920800 25200 1 ALMST}
    {3150064800 21600 0 ALMT}
    {3163370400 25200 1 ALMST}
    {3181514400 21600 0 ALMT}
    {3194820000 25200 1 ALMST}
    {3212964000 21600 0 ALMT}
    {3226269600 25200 1 ALMST}
    {3245018400 21600 0 ALMT}
    {3257719200 25200 1 ALMST}
    {3276468000 21600 0 ALMT}
    {3289168800 25200 1 ALMST}
    {3307917600 21600 0 ALMT}
    {3321223200 25200 1 ALMST}
    {3339367200 21600 0 ALMT}
    {3352672800 25200 1 ALMST}
    {3370816800 21600 0 ALMT}
    {3384122400 25200 1 ALMST}
    {3402871200 21600 0 ALMT}
    {3415572000 25200 1 ALMST}
    {3434320800 21600 0 ALMT}
    {3447021600 25200 1 ALMST}
    {3465770400 21600 0 ALMT}
    {3479076000 25200 1 ALMST}
    {3497220000 21600 0 ALMT}
    {3510525600 25200 1 ALMST}
    {3528669600 21600 0 ALMT}
    {3541975200 25200 1 ALMST}
    {3560119200 21600 0 ALMT}
    {3573424800 25200 1 ALMST}
    {3592173600 21600 0 ALMT}
    {3604874400 25200 1 ALMST}
    {3623623200 21600 0 ALMT}
    {3636324000 25200 1 ALMST}
    {3655072800 21600 0 ALMT}
    {3668378400 25200 1 ALMST}
    {3686522400 21600 0 ALMT}
    {3699828000 25200 1 ALMST}
    {3717972000 21600 0 ALMT}
    {3731277600 25200 1 ALMST}
    {3750026400 21600 0 ALMT}
    {3762727200 25200 1 ALMST}
    {3781476000 21600 0 ALMT}
    {3794176800 25200 1 ALMST}
    {3812925600 21600 0 ALMT}
    {3825626400 25200 1 ALMST}
    {3844375200 21600 0 ALMT}
    {3857680800 25200 1 ALMST}
    {3875824800 21600 0 ALMT}
    {3889130400 25200 1 ALMST}
    {3907274400 21600 0 ALMT}
    {3920580000 25200 1 ALMST}
    {3939328800 21600 0 ALMT}
    {3952029600 25200 1 ALMST}
    {3970778400 21600 0 ALMT}
    {3983479200 25200 1 ALMST}
    {4002228000 21600 0 ALMT}
    {4015533600 25200 1 ALMST}
    {4033677600 21600 0 ALMT}
    {4046983200 25200 1 ALMST}
    {4065127200 21600 0 ALMT}
    {4078432800 25200 1 ALMST}
    {4096576800 21600 0 ALMT}
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

48
49
50
51
52
53
54































































































































































55






























56
    {1004234400 21600 0 ALMT}
    {1017540000 25200 1 ALMST}
    {1035684000 21600 0 ALMT}
    {1048989600 25200 1 ALMST}
    {1067133600 21600 0 ALMT}
    {1080439200 25200 1 ALMST}
    {1099188000 21600 0 ALMT}































































































































































    {1110823200 21600 0 ALMT}






























}

Changes to library/tzdata/Asia/Aqtau.

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
    {1004234400 14400 0 AQTT}
    {1017540000 18000 1 AQTST}
    {1035684000 14400 0 AQTT}
    {1048989600 18000 1 AQTST}
    {1067133600 14400 0 AQTT}
    {1080439200 18000 1 AQTST}
    {1099188000 14400 0 AQTT}
    {1111888800 18000 1 AQTST}
    {1130637600 14400 0 AQTT}
    {1143338400 18000 1 AQTST}
    {1162087200 14400 0 AQTT}
    {1174788000 18000 1 AQTST}
    {1193536800 14400 0 AQTT}
    {1206842400 18000 1 AQTST}
    {1224986400 14400 0 AQTT}
    {1238292000 18000 1 AQTST}
    {1256436000 14400 0 AQTT}
    {1269741600 18000 1 AQTST}
    {1288490400 14400 0 AQTT}
    {1301191200 18000 1 AQTST}
    {1319940000 14400 0 AQTT}
    {1332640800 18000 1 AQTST}
    {1351389600 14400 0 AQTT}
    {1364695200 18000 1 AQTST}
    {1382839200 14400 0 AQTT}
    {1396144800 18000 1 AQTST}
    {1414288800 14400 0 AQTT}
    {1427594400 18000 1 AQTST}
    {1445738400 14400 0 AQTT}
    {1459044000 18000 1 AQTST}
    {1477792800 14400 0 AQTT}
    {1490493600 18000 1 AQTST}
    {1509242400 14400 0 AQTT}
    {1521943200 18000 1 AQTST}
    {1540692000 14400 0 AQTT}
    {1553997600 18000 1 AQTST}
    {1572141600 14400 0 AQTT}
    {1585447200 18000 1 AQTST}
    {1603591200 14400 0 AQTT}
    {1616896800 18000 1 AQTST}
    {1635645600 14400 0 AQTT}
    {1648346400 18000 1 AQTST}
    {1667095200 14400 0 AQTT}
    {1679796000 18000 1 AQTST}
    {1698544800 14400 0 AQTT}
    {1711850400 18000 1 AQTST}
    {1729994400 14400 0 AQTT}
    {1743300000 18000 1 AQTST}
    {1761444000 14400 0 AQTT}
    {1774749600 18000 1 AQTST}
    {1792893600 14400 0 AQTT}
    {1806199200 18000 1 AQTST}
    {1824948000 14400 0 AQTT}
    {1837648800 18000 1 AQTST}
    {1856397600 14400 0 AQTT}
    {1869098400 18000 1 AQTST}
    {1887847200 14400 0 AQTT}
    {1901152800 18000 1 AQTST}
    {1919296800 14400 0 AQTT}
    {1932602400 18000 1 AQTST}
    {1950746400 14400 0 AQTT}
    {1964052000 18000 1 AQTST}
    {1982800800 14400 0 AQTT}
    {1995501600 18000 1 AQTST}
    {2014250400 14400 0 AQTT}
    {2026951200 18000 1 AQTST}
    {2045700000 14400 0 AQTT}
    {2058400800 18000 1 AQTST}
    {2077149600 14400 0 AQTT}
    {2090455200 18000 1 AQTST}
    {2108599200 14400 0 AQTT}
    {2121904800 18000 1 AQTST}
    {2140048800 14400 0 AQTT}
    {2153354400 18000 1 AQTST}
    {2172103200 14400 0 AQTT}
    {2184804000 18000 1 AQTST}
    {2203552800 14400 0 AQTT}
    {2216253600 18000 1 AQTST}
    {2235002400 14400 0 AQTT}
    {2248308000 18000 1 AQTST}
    {2266452000 14400 0 AQTT}
    {2279757600 18000 1 AQTST}
    {2297901600 14400 0 AQTT}
    {2311207200 18000 1 AQTST}
    {2329351200 14400 0 AQTT}
    {2342656800 18000 1 AQTST}
    {2361405600 14400 0 AQTT}
    {2374106400 18000 1 AQTST}
    {2392855200 14400 0 AQTT}
    {2405556000 18000 1 AQTST}
    {2424304800 14400 0 AQTT}
    {2437610400 18000 1 AQTST}
    {2455754400 14400 0 AQTT}
    {2469060000 18000 1 AQTST}
    {2487204000 14400 0 AQTT}
    {2500509600 18000 1 AQTST}
    {2519258400 14400 0 AQTT}
    {2531959200 18000 1 AQTST}
    {2550708000 14400 0 AQTT}
    {2563408800 18000 1 AQTST}
    {2582157600 14400 0 AQTT}
    {2595463200 18000 1 AQTST}
    {2613607200 14400 0 AQTT}
    {2626912800 18000 1 AQTST}
    {2645056800 14400 0 AQTT}
    {2658362400 18000 1 AQTST}
    {2676506400 14400 0 AQTT}
    {2689812000 18000 1 AQTST}
    {2708560800 14400 0 AQTT}
    {2721261600 18000 1 AQTST}
    {2740010400 14400 0 AQTT}
    {2752711200 18000 1 AQTST}
    {2771460000 14400 0 AQTT}
    {2784765600 18000 1 AQTST}
    {2802909600 14400 0 AQTT}
    {2816215200 18000 1 AQTST}
    {2834359200 14400 0 AQTT}
    {2847664800 18000 1 AQTST}
    {2866413600 14400 0 AQTT}
    {2879114400 18000 1 AQTST}
    {2897863200 14400 0 AQTT}
    {2910564000 18000 1 AQTST}
    {2929312800 14400 0 AQTT}
    {2942013600 18000 1 AQTST}
    {2960762400 14400 0 AQTT}
    {2974068000 18000 1 AQTST}
    {2992212000 14400 0 AQTT}
    {3005517600 18000 1 AQTST}
    {3023661600 14400 0 AQTT}
    {3036967200 18000 1 AQTST}
    {3055716000 14400 0 AQTT}
    {3068416800 18000 1 AQTST}
    {3087165600 14400 0 AQTT}
    {3099866400 18000 1 AQTST}
    {3118615200 14400 0 AQTT}
    {3131920800 18000 1 AQTST}
    {3150064800 14400 0 AQTT}
    {3163370400 18000 1 AQTST}
    {3181514400 14400 0 AQTT}
    {3194820000 18000 1 AQTST}
    {3212964000 14400 0 AQTT}
    {3226269600 18000 1 AQTST}
    {3245018400 14400 0 AQTT}
    {3257719200 18000 1 AQTST}
    {3276468000 14400 0 AQTT}
    {3289168800 18000 1 AQTST}
    {3307917600 14400 0 AQTT}
    {3321223200 18000 1 AQTST}
    {3339367200 14400 0 AQTT}
    {3352672800 18000 1 AQTST}
    {3370816800 14400 0 AQTT}
    {3384122400 18000 1 AQTST}
    {3402871200 14400 0 AQTT}
    {3415572000 18000 1 AQTST}
    {3434320800 14400 0 AQTT}
    {3447021600 18000 1 AQTST}
    {3465770400 14400 0 AQTT}
    {3479076000 18000 1 AQTST}
    {3497220000 14400 0 AQTT}
    {3510525600 18000 1 AQTST}
    {3528669600 14400 0 AQTT}
    {3541975200 18000 1 AQTST}
    {3560119200 14400 0 AQTT}
    {3573424800 18000 1 AQTST}
    {3592173600 14400 0 AQTT}
    {3604874400 18000 1 AQTST}
    {3623623200 14400 0 AQTT}
    {3636324000 18000 1 AQTST}
    {3655072800 14400 0 AQTT}
    {3668378400 18000 1 AQTST}
    {3686522400 14400 0 AQTT}
    {3699828000 18000 1 AQTST}
    {3717972000 14400 0 AQTT}
    {3731277600 18000 1 AQTST}
    {3750026400 14400 0 AQTT}
    {3762727200 18000 1 AQTST}
    {3781476000 14400 0 AQTT}
    {3794176800 18000 1 AQTST}
    {3812925600 14400 0 AQTT}
    {3825626400 18000 1 AQTST}
    {3844375200 14400 0 AQTT}
    {3857680800 18000 1 AQTST}
    {3875824800 14400 0 AQTT}
    {3889130400 18000 1 AQTST}
    {3907274400 14400 0 AQTT}
    {3920580000 18000 1 AQTST}
    {3939328800 14400 0 AQTT}
    {3952029600 18000 1 AQTST}
    {3970778400 14400 0 AQTT}
    {3983479200 18000 1 AQTST}
    {4002228000 14400 0 AQTT}
    {4015533600 18000 1 AQTST}
    {4033677600 14400 0 AQTT}
    {4046983200 18000 1 AQTST}
    {4065127200 14400 0 AQTT}
    {4078432800 18000 1 AQTST}
    {4096576800 14400 0 AQTT}
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<

50
51
52
53
54
55
56
















































































































































































57













58
    {1004234400 14400 0 AQTT}
    {1017540000 18000 1 AQTST}
    {1035684000 14400 0 AQTT}
    {1048989600 18000 1 AQTST}
    {1067133600 14400 0 AQTT}
    {1080439200 18000 1 AQTST}
    {1099188000 14400 0 AQTT}
















































































































































































    {1110830400 18000 0 AQTT}













}

Changes to library/tzdata/Asia/Aqtobe.

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
    {1004234400 18000 0 AQTT}
    {1017540000 21600 1 AQTST}
    {1035684000 18000 0 AQTT}
    {1048989600 21600 1 AQTST}
    {1067133600 18000 0 AQTT}
    {1080439200 21600 1 AQTST}
    {1099188000 18000 0 AQTT}
    {1111888800 21600 1 AQTST}
    {1130637600 18000 0 AQTT}
    {1143338400 21600 1 AQTST}
    {1162087200 18000 0 AQTT}
    {1174788000 21600 1 AQTST}
    {1193536800 18000 0 AQTT}
    {1206842400 21600 1 AQTST}
    {1224986400 18000 0 AQTT}
    {1238292000 21600 1 AQTST}
    {1256436000 18000 0 AQTT}
    {1269741600 21600 1 AQTST}
    {1288490400 18000 0 AQTT}
    {1301191200 21600 1 AQTST}
    {1319940000 18000 0 AQTT}
    {1332640800 21600 1 AQTST}
    {1351389600 18000 0 AQTT}
    {1364695200 21600 1 AQTST}
    {1382839200 18000 0 AQTT}
    {1396144800 21600 1 AQTST}
    {1414288800 18000 0 AQTT}
    {1427594400 21600 1 AQTST}
    {1445738400 18000 0 AQTT}
    {1459044000 21600 1 AQTST}
    {1477792800 18000 0 AQTT}
    {1490493600 21600 1 AQTST}
    {1509242400 18000 0 AQTT}
    {1521943200 21600 1 AQTST}
    {1540692000 18000 0 AQTT}
    {1553997600 21600 1 AQTST}
    {1572141600 18000 0 AQTT}
    {1585447200 21600 1 AQTST}
    {1603591200 18000 0 AQTT}
    {1616896800 21600 1 AQTST}
    {1635645600 18000 0 AQTT}
    {1648346400 21600 1 AQTST}
    {1667095200 18000 0 AQTT}
    {1679796000 21600 1 AQTST}
    {1698544800 18000 0 AQTT}
    {1711850400 21600 1 AQTST}
    {1729994400 18000 0 AQTT}
    {1743300000 21600 1 AQTST}
    {1761444000 18000 0 AQTT}
    {1774749600 21600 1 AQTST}
    {1792893600 18000 0 AQTT}
    {1806199200 21600 1 AQTST}
    {1824948000 18000 0 AQTT}
    {1837648800 21600 1 AQTST}
    {1856397600 18000 0 AQTT}
    {1869098400 21600 1 AQTST}
    {1887847200 18000 0 AQTT}
    {1901152800 21600 1 AQTST}
    {1919296800 18000 0 AQTT}
    {1932602400 21600 1 AQTST}
    {1950746400 18000 0 AQTT}
    {1964052000 21600 1 AQTST}
    {1982800800 18000 0 AQTT}
    {1995501600 21600 1 AQTST}
    {2014250400 18000 0 AQTT}
    {2026951200 21600 1 AQTST}
    {2045700000 18000 0 AQTT}
    {2058400800 21600 1 AQTST}
    {2077149600 18000 0 AQTT}
    {2090455200 21600 1 AQTST}
    {2108599200 18000 0 AQTT}
    {2121904800 21600 1 AQTST}
    {2140048800 18000 0 AQTT}
    {2153354400 21600 1 AQTST}
    {2172103200 18000 0 AQTT}
    {2184804000 21600 1 AQTST}
    {2203552800 18000 0 AQTT}
    {2216253600 21600 1 AQTST}
    {2235002400 18000 0 AQTT}
    {2248308000 21600 1 AQTST}
    {2266452000 18000 0 AQTT}
    {2279757600 21600 1 AQTST}
    {2297901600 18000 0 AQTT}
    {2311207200 21600 1 AQTST}
    {2329351200 18000 0 AQTT}
    {2342656800 21600 1 AQTST}
    {2361405600 18000 0 AQTT}
    {2374106400 21600 1 AQTST}
    {2392855200 18000 0 AQTT}
    {2405556000 21600 1 AQTST}
    {2424304800 18000 0 AQTT}
    {2437610400 21600 1 AQTST}
    {2455754400 18000 0 AQTT}
    {2469060000 21600 1 AQTST}
    {2487204000 18000 0 AQTT}
    {2500509600 21600 1 AQTST}
    {2519258400 18000 0 AQTT}
    {2531959200 21600 1 AQTST}
    {2550708000 18000 0 AQTT}
    {2563408800 21600 1 AQTST}
    {2582157600 18000 0 AQTT}
    {2595463200 21600 1 AQTST}
    {2613607200 18000 0 AQTT}
    {2626912800 21600 1 AQTST}
    {2645056800 18000 0 AQTT}
    {2658362400 21600 1 AQTST}
    {2676506400 18000 0 AQTT}
    {2689812000 21600 1 AQTST}
    {2708560800 18000 0 AQTT}
    {2721261600 21600 1 AQTST}
    {2740010400 18000 0 AQTT}
    {2752711200 21600 1 AQTST}
    {2771460000 18000 0 AQTT}
    {2784765600 21600 1 AQTST}
    {2802909600 18000 0 AQTT}
    {2816215200 21600 1 AQTST}
    {2834359200 18000 0 AQTT}
    {2847664800 21600 1 AQTST}
    {2866413600 18000 0 AQTT}
    {2879114400 21600 1 AQTST}
    {2897863200 18000 0 AQTT}
    {2910564000 21600 1 AQTST}
    {2929312800 18000 0 AQTT}
    {2942013600 21600 1 AQTST}
    {2960762400 18000 0 AQTT}
    {2974068000 21600 1 AQTST}
    {2992212000 18000 0 AQTT}
    {3005517600 21600 1 AQTST}
    {3023661600 18000 0 AQTT}
    {3036967200 21600 1 AQTST}
    {3055716000 18000 0 AQTT}
    {3068416800 21600 1 AQTST}
    {3087165600 18000 0 AQTT}
    {3099866400 21600 1 AQTST}
    {3118615200 18000 0 AQTT}
    {3131920800 21600 1 AQTST}
    {3150064800 18000 0 AQTT}
    {3163370400 21600 1 AQTST}
    {3181514400 18000 0 AQTT}
    {3194820000 21600 1 AQTST}
    {3212964000 18000 0 AQTT}
    {3226269600 21600 1 AQTST}
    {3245018400 18000 0 AQTT}
    {3257719200 21600 1 AQTST}
    {3276468000 18000 0 AQTT}
    {3289168800 21600 1 AQTST}
    {3307917600 18000 0 AQTT}
    {3321223200 21600 1 AQTST}
    {3339367200 18000 0 AQTT}
    {3352672800 21600 1 AQTST}
    {3370816800 18000 0 AQTT}
    {3384122400 21600 1 AQTST}
    {3402871200 18000 0 AQTT}
    {3415572000 21600 1 AQTST}
    {3434320800 18000 0 AQTT}
    {3447021600 21600 1 AQTST}
    {3465770400 18000 0 AQTT}
    {3479076000 21600 1 AQTST}
    {3497220000 18000 0 AQTT}
    {3510525600 21600 1 AQTST}
    {3528669600 18000 0 AQTT}
    {3541975200 21600 1 AQTST}
    {3560119200 18000 0 AQTT}
    {3573424800 21600 1 AQTST}
    {3592173600 18000 0 AQTT}
    {3604874400 21600 1 AQTST}
    {3623623200 18000 0 AQTT}
    {3636324000 21600 1 AQTST}
    {3655072800 18000 0 AQTT}
    {3668378400 21600 1 AQTST}
    {3686522400 18000 0 AQTT}
    {3699828000 21600 1 AQTST}
    {3717972000 18000 0 AQTT}
    {3731277600 21600 1 AQTST}
    {3750026400 18000 0 AQTT}
    {3762727200 21600 1 AQTST}
    {3781476000 18000 0 AQTT}
    {3794176800 21600 1 AQTST}
    {3812925600 18000 0 AQTT}
    {3825626400 21600 1 AQTST}
    {3844375200 18000 0 AQTT}
    {3857680800 21600 1 AQTST}
    {3875824800 18000 0 AQTT}
    {3889130400 21600 1 AQTST}
    {3907274400 18000 0 AQTT}
    {3920580000 21600 1 AQTST}
    {3939328800 18000 0 AQTT}
    {3952029600 21600 1 AQTST}
    {3970778400 18000 0 AQTT}
    {3983479200 21600 1 AQTST}
    {4002228000 18000 0 AQTT}
    {4015533600 21600 1 AQTST}
    {4033677600 18000 0 AQTT}
    {4046983200 21600 1 AQTST}
    {4065127200 18000 0 AQTT}
    {4078432800 21600 1 AQTST}
    {4096576800 18000 0 AQTT}
}







<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

49
50
51
52
53
54
55





56
























































































































































































57
    {1004234400 18000 0 AQTT}
    {1017540000 21600 1 AQTST}
    {1035684000 18000 0 AQTT}
    {1048989600 21600 1 AQTST}
    {1067133600 18000 0 AQTT}
    {1080439200 21600 1 AQTST}
    {1099188000 18000 0 AQTT}





    {1110826800 18000 0 AQTT}
























































































































































































}

Changes to library/tzdata/Asia/Baku.

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
    {622605600 14400 0 BAKT}
    {638330400 18000 1 BAKST}
    {654660000 14400 0 BAKT}
    {670384800 14400 1 BAKST}
    {683496000 14400 0 AZST}
    {686109600 10800 0 AZT}
    {701812800 14400 1 AZST}
    {717534000 10800 0 AZT}
    {717559200 14400 0 AZT}
    {820440000 14400 0 AZT}
    {828234000 18000 1 AZST}
    {846378000 14400 0 AZT}
    {852062400 14400 0 AZT}
    {859669200 18000 1 AZST}
    {877809600 14400 0 AZT}
    {891118800 18000 1 AZST}







<
|







24
25
26
27
28
29
30

31
32
33
34
35
36
37
38
    {622605600 14400 0 BAKT}
    {638330400 18000 1 BAKST}
    {654660000 14400 0 BAKT}
    {670384800 14400 1 BAKST}
    {683496000 14400 0 AZST}
    {686109600 10800 0 AZT}
    {701812800 14400 1 AZST}

    {717537600 14400 0 AZT}
    {820440000 14400 0 AZT}
    {828234000 18000 1 AZST}
    {846378000 14400 0 AZT}
    {852062400 14400 0 AZT}
    {859669200 18000 1 AZST}
    {877809600 14400 0 AZT}
    {891118800 18000 1 AZST}

Changes to library/tzdata/Asia/Bishkek.

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
    {1017523800 21600 1 KGST}
    {1035664200 18000 0 KGT}
    {1048973400 21600 1 KGST}
    {1067113800 18000 0 KGT}
    {1080423000 21600 1 KGST}
    {1099168200 18000 0 KGT}
    {1111872600 21600 1 KGST}
    {1130617800 18000 0 KGT}
    {1143322200 21600 1 KGST}
    {1162067400 18000 0 KGT}
    {1174771800 21600 1 KGST}
    {1193517000 18000 0 KGT}
    {1206826200 21600 1 KGST}
    {1224966600 18000 0 KGT}
    {1238275800 21600 1 KGST}
    {1256416200 18000 0 KGT}
    {1269725400 21600 1 KGST}
    {1288470600 18000 0 KGT}
    {1301175000 21600 1 KGST}
    {1319920200 18000 0 KGT}
    {1332624600 21600 1 KGST}
    {1351369800 18000 0 KGT}
    {1364679000 21600 1 KGST}
    {1382819400 18000 0 KGT}
    {1396128600 21600 1 KGST}
    {1414269000 18000 0 KGT}
    {1427578200 21600 1 KGST}
    {1445718600 18000 0 KGT}
    {1459027800 21600 1 KGST}
    {1477773000 18000 0 KGT}
    {1490477400 21600 1 KGST}
    {1509222600 18000 0 KGT}
    {1521927000 21600 1 KGST}
    {1540672200 18000 0 KGT}
    {1553981400 21600 1 KGST}
    {1572121800 18000 0 KGT}
    {1585431000 21600 1 KGST}
    {1603571400 18000 0 KGT}
    {1616880600 21600 1 KGST}
    {1635625800 18000 0 KGT}
    {1648330200 21600 1 KGST}
    {1667075400 18000 0 KGT}
    {1679779800 21600 1 KGST}
    {1698525000 18000 0 KGT}
    {1711834200 21600 1 KGST}
    {1729974600 18000 0 KGT}
    {1743283800 21600 1 KGST}
    {1761424200 18000 0 KGT}
    {1774733400 21600 1 KGST}
    {1792873800 18000 0 KGT}
    {1806183000 21600 1 KGST}
    {1824928200 18000 0 KGT}
    {1837632600 21600 1 KGST}
    {1856377800 18000 0 KGT}
    {1869082200 21600 1 KGST}
    {1887827400 18000 0 KGT}
    {1901136600 21600 1 KGST}
    {1919277000 18000 0 KGT}
    {1932586200 21600 1 KGST}
    {1950726600 18000 0 KGT}
    {1964035800 21600 1 KGST}
    {1982781000 18000 0 KGT}
    {1995485400 21600 1 KGST}
    {2014230600 18000 0 KGT}
    {2026935000 21600 1 KGST}
    {2045680200 18000 0 KGT}
    {2058384600 21600 1 KGST}
    {2077129800 18000 0 KGT}
    {2090439000 21600 1 KGST}
    {2108579400 18000 0 KGT}
    {2121888600 21600 1 KGST}
    {2140029000 18000 0 KGT}
    {2153338200 21600 1 KGST}
    {2172083400 18000 0 KGT}
    {2184787800 21600 1 KGST}
    {2203533000 18000 0 KGT}
    {2216237400 21600 1 KGST}
    {2234982600 18000 0 KGT}
    {2248291800 21600 1 KGST}
    {2266432200 18000 0 KGT}
    {2279741400 21600 1 KGST}
    {2297881800 18000 0 KGT}
    {2311191000 21600 1 KGST}
    {2329331400 18000 0 KGT}
    {2342640600 21600 1 KGST}
    {2361385800 18000 0 KGT}
    {2374090200 21600 1 KGST}
    {2392835400 18000 0 KGT}
    {2405539800 21600 1 KGST}
    {2424285000 18000 0 KGT}
    {2437594200 21600 1 KGST}
    {2455734600 18000 0 KGT}
    {2469043800 21600 1 KGST}
    {2487184200 18000 0 KGT}
    {2500493400 21600 1 KGST}
    {2519238600 18000 0 KGT}
    {2531943000 21600 1 KGST}
    {2550688200 18000 0 KGT}
    {2563392600 21600 1 KGST}
    {2582137800 18000 0 KGT}
    {2595447000 21600 1 KGST}
    {2613587400 18000 0 KGT}
    {2626896600 21600 1 KGST}
    {2645037000 18000 0 KGT}
    {2658346200 21600 1 KGST}
    {2676486600 18000 0 KGT}
    {2689795800 21600 1 KGST}
    {2708541000 18000 0 KGT}
    {2721245400 21600 1 KGST}
    {2739990600 18000 0 KGT}
    {2752695000 21600 1 KGST}
    {2771440200 18000 0 KGT}
    {2784749400 21600 1 KGST}
    {2802889800 18000 0 KGT}
    {2816199000 21600 1 KGST}
    {2834339400 18000 0 KGT}
    {2847648600 21600 1 KGST}
    {2866393800 18000 0 KGT}
    {2879098200 21600 1 KGST}
    {2897843400 18000 0 KGT}
    {2910547800 21600 1 KGST}
    {2929293000 18000 0 KGT}
    {2941997400 21600 1 KGST}
    {2960742600 18000 0 KGT}
    {2974051800 21600 1 KGST}
    {2992192200 18000 0 KGT}
    {3005501400 21600 1 KGST}
    {3023641800 18000 0 KGT}
    {3036951000 21600 1 KGST}
    {3055696200 18000 0 KGT}
    {3068400600 21600 1 KGST}
    {3087145800 18000 0 KGT}
    {3099850200 21600 1 KGST}
    {3118595400 18000 0 KGT}
    {3131904600 21600 1 KGST}
    {3150045000 18000 0 KGT}
    {3163354200 21600 1 KGST}
    {3181494600 18000 0 KGT}
    {3194803800 21600 1 KGST}
    {3212944200 18000 0 KGT}
    {3226253400 21600 1 KGST}
    {3244998600 18000 0 KGT}
    {3257703000 21600 1 KGST}
    {3276448200 18000 0 KGT}
    {3289152600 21600 1 KGST}
    {3307897800 18000 0 KGT}
    {3321207000 21600 1 KGST}
    {3339347400 18000 0 KGT}
    {3352656600 21600 1 KGST}
    {3370797000 18000 0 KGT}
    {3384106200 21600 1 KGST}
    {3402851400 18000 0 KGT}
    {3415555800 21600 1 KGST}
    {3434301000 18000 0 KGT}
    {3447005400 21600 1 KGST}
    {3465750600 18000 0 KGT}
    {3479059800 21600 1 KGST}
    {3497200200 18000 0 KGT}
    {3510509400 21600 1 KGST}
    {3528649800 18000 0 KGT}
    {3541959000 21600 1 KGST}
    {3560099400 18000 0 KGT}
    {3573408600 21600 1 KGST}
    {3592153800 18000 0 KGT}
    {3604858200 21600 1 KGST}
    {3623603400 18000 0 KGT}
    {3636307800 21600 1 KGST}
    {3655053000 18000 0 KGT}
    {3668362200 21600 1 KGST}
    {3686502600 18000 0 KGT}
    {3699811800 21600 1 KGST}
    {3717952200 18000 0 KGT}
    {3731261400 21600 1 KGST}
    {3750006600 18000 0 KGT}
    {3762711000 21600 1 KGST}
    {3781456200 18000 0 KGT}
    {3794160600 21600 1 KGST}
    {3812905800 18000 0 KGT}
    {3825610200 21600 1 KGST}
    {3844355400 18000 0 KGT}
    {3857664600 21600 1 KGST}
    {3875805000 18000 0 KGT}
    {3889114200 21600 1 KGST}
    {3907254600 18000 0 KGT}
    {3920563800 21600 1 KGST}
    {3939309000 18000 0 KGT}
    {3952013400 21600 1 KGST}
    {3970758600 18000 0 KGT}
    {3983463000 21600 1 KGST}
    {4002208200 18000 0 KGT}
    {4015517400 21600 1 KGST}
    {4033657800 18000 0 KGT}
    {4046967000 21600 1 KGST}
    {4065107400 18000 0 KGT}
    {4078416600 21600 1 KGST}
    {4096557000 18000 0 KGT}
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

49
50
51
52
53
54
55















































































































56













































































57
    {1017523800 21600 1 KGST}
    {1035664200 18000 0 KGT}
    {1048973400 21600 1 KGST}
    {1067113800 18000 0 KGT}
    {1080423000 21600 1 KGST}
    {1099168200 18000 0 KGT}
    {1111872600 21600 1 KGST}















































































































    {1123783200 21600 0 KGT}













































































}

Changes to library/tzdata/Asia/Dili.

1
2
3
4
5
6
7
8
9
10
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Asia/Dili) {
    {-9223372036854775808 30140 0 LMT}
    {-1830414140 28800 0 TPT}
    {-879152400 32400 0 JST}
    {-770634000 32400 0 TPT}
    {199897200 28800 0 CIT}
    {969120000 32400 0 TPT}
}




|

|

|

1
2
3
4
5
6
7
8
9
10
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Asia/Dili) {
    {-9223372036854775808 30140 0 LMT}
    {-1830414140 28800 0 TLT}
    {-879152400 32400 0 JST}
    {-770634000 32400 0 TLT}
    {199897200 28800 0 CIT}
    {969120000 32400 0 TLT}
}

Changes to library/tzdata/Asia/Jerusalem.

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
    {1001282400 7200 0 IST}
    {1017356400 10800 1 IDT}
    {1033941600 7200 0 IST}
    {1048806000 10800 1 IDT}
    {1065132000 7200 0 IST}
    {1081292400 10800 1 IDT}
    {1095804000 7200 0 IST}
    {1112310000 10800 1 IDT}
    {1128117600 7200 0 IST}
    {1143846000 10800 1 IDT}
    {1159653600 7200 0 IST}
    {1175382000 10800 1 IDT}
    {1191189600 7200 0 IST}
    {1207004400 10800 1 IDT}
    {1222812000 7200 0 IST}
    {1238540400 10800 1 IDT}
    {1254348000 7200 0 IST}
    {1270076400 10800 1 IDT}
    {1285884000 7200 0 IST}
    {1301612400 10800 1 IDT}
    {1317420000 7200 0 IST}
    {1333234800 10800 1 IDT}
    {1349042400 7200 0 IST}
    {1364770800 10800 1 IDT}
    {1380578400 7200 0 IST}
    {1396306800 10800 1 IDT}
    {1412114400 7200 0 IST}
    {1427842800 10800 1 IDT}
    {1443650400 7200 0 IST}
    {1459465200 10800 1 IDT}
    {1475272800 7200 0 IST}
    {1491001200 10800 1 IDT}
    {1506808800 7200 0 IST}
    {1522537200 10800 1 IDT}
    {1538344800 7200 0 IST}
    {1554073200 10800 1 IDT}
    {1569880800 7200 0 IST}
    {1585695600 10800 1 IDT}
    {1601503200 7200 0 IST}
    {1617231600 10800 1 IDT}
    {1633039200 7200 0 IST}
    {1648767600 10800 1 IDT}
    {1664575200 7200 0 IST}
    {1680303600 10800 1 IDT}
    {1696111200 7200 0 IST}
    {1711926000 10800 1 IDT}
    {1727733600 7200 0 IST}
    {1743462000 10800 1 IDT}
    {1759269600 7200 0 IST}
    {1774998000 10800 1 IDT}
    {1790805600 7200 0 IST}
    {1806534000 10800 1 IDT}
    {1822341600 7200 0 IST}
    {1838156400 10800 1 IDT}
    {1853964000 7200 0 IST}
    {1869692400 10800 1 IDT}
    {1885500000 7200 0 IST}
    {1901228400 10800 1 IDT}
    {1917036000 7200 0 IST}
    {1932764400 10800 1 IDT}
    {1948572000 7200 0 IST}
    {1964386800 10800 1 IDT}
    {1980194400 7200 0 IST}
    {1995922800 10800 1 IDT}
    {2011730400 7200 0 IST}
    {2027458800 10800 1 IDT}
    {2043266400 7200 0 IST}
    {2058994800 10800 1 IDT}
    {2074802400 7200 0 IST}
    {2090617200 10800 1 IDT}
    {2106424800 7200 0 IST}
    {2122153200 10800 1 IDT}
    {2137960800 7200 0 IST}
    {2153689200 10800 1 IDT}
    {2169496800 7200 0 IST}
    {2185225200 10800 1 IDT}
    {2201032800 7200 0 IST}
    {2216847600 10800 1 IDT}
    {2232655200 7200 0 IST}
    {2248383600 10800 1 IDT}
    {2264191200 7200 0 IST}
    {2279919600 10800 1 IDT}
    {2295727200 7200 0 IST}
    {2311455600 10800 1 IDT}
    {2327263200 7200 0 IST}
    {2343078000 10800 1 IDT}
    {2358885600 7200 0 IST}
    {2374614000 10800 1 IDT}
    {2390421600 7200 0 IST}
    {2406150000 10800 1 IDT}
    {2421957600 7200 0 IST}
    {2437686000 10800 1 IDT}
    {2453493600 7200 0 IST}
    {2469308400 10800 1 IDT}
    {2485116000 7200 0 IST}
    {2500844400 10800 1 IDT}
    {2516652000 7200 0 IST}
    {2532380400 10800 1 IDT}
    {2548188000 7200 0 IST}
    {2563916400 10800 1 IDT}
    {2579724000 7200 0 IST}
    {2595538800 10800 1 IDT}
    {2611346400 7200 0 IST}
    {2627074800 10800 1 IDT}
    {2642882400 7200 0 IST}
    {2658610800 10800 1 IDT}
    {2674418400 7200 0 IST}
    {2690146800 10800 1 IDT}
    {2705954400 7200 0 IST}
    {2721769200 10800 1 IDT}
    {2737576800 7200 0 IST}
    {2753305200 10800 1 IDT}
    {2769112800 7200 0 IST}
    {2784841200 10800 1 IDT}
    {2800648800 7200 0 IST}
    {2816377200 10800 1 IDT}
    {2832184800 7200 0 IST}
    {2847999600 10800 1 IDT}
    {2863807200 7200 0 IST}
    {2879535600 10800 1 IDT}
    {2895343200 7200 0 IST}
    {2911071600 10800 1 IDT}
    {2926879200 7200 0 IST}
    {2942607600 10800 1 IDT}
    {2958415200 7200 0 IST}
    {2974230000 10800 1 IDT}
    {2990037600 7200 0 IST}
    {3005766000 10800 1 IDT}
    {3021573600 7200 0 IST}
    {3037302000 10800 1 IDT}
    {3053109600 7200 0 IST}
    {3068838000 10800 1 IDT}
    {3084645600 7200 0 IST}
    {3100460400 10800 1 IDT}
    {3116268000 7200 0 IST}
    {3131996400 10800 1 IDT}
    {3147804000 7200 0 IST}
    {3163532400 10800 1 IDT}
    {3179340000 7200 0 IST}
    {3195068400 10800 1 IDT}
    {3210876000 7200 0 IST}
    {3226690800 10800 1 IDT}
    {3242498400 7200 0 IST}
    {3258226800 10800 1 IDT}
    {3274034400 7200 0 IST}
    {3289762800 10800 1 IDT}
    {3305570400 7200 0 IST}
    {3321298800 10800 1 IDT}
    {3337106400 7200 0 IST}
    {3352921200 10800 1 IDT}
    {3368728800 7200 0 IST}
    {3384457200 10800 1 IDT}
    {3400264800 7200 0 IST}
    {3415993200 10800 1 IDT}
    {3431800800 7200 0 IST}
    {3447529200 10800 1 IDT}
    {3463336800 7200 0 IST}
    {3479151600 10800 1 IDT}
    {3494959200 7200 0 IST}
    {3510687600 10800 1 IDT}
    {3526495200 7200 0 IST}
    {3542223600 10800 1 IDT}
    {3558031200 7200 0 IST}
    {3573759600 10800 1 IDT}
    {3589567200 7200 0 IST}
    {3605382000 10800 1 IDT}
    {3621189600 7200 0 IST}
    {3636918000 10800 1 IDT}
    {3652725600 7200 0 IST}
    {3668454000 10800 1 IDT}
    {3684261600 7200 0 IST}
    {3699990000 10800 1 IDT}
    {3715797600 7200 0 IST}
    {3731612400 10800 1 IDT}
    {3747420000 7200 0 IST}
    {3763148400 10800 1 IDT}
    {3778956000 7200 0 IST}
    {3794684400 10800 1 IDT}
    {3810492000 7200 0 IST}
    {3826220400 10800 1 IDT}
    {3842028000 7200 0 IST}
    {3857842800 10800 1 IDT}
    {3873650400 7200 0 IST}
    {3889378800 10800 1 IDT}
    {3905186400 7200 0 IST}
    {3920914800 10800 1 IDT}
    {3936722400 7200 0 IST}
    {3952450800 10800 1 IDT}
    {3968258400 7200 0 IST}
    {3984073200 10800 1 IDT}
    {3999880800 7200 0 IST}
    {4015609200 10800 1 IDT}
    {4031416800 7200 0 IST}
    {4047145200 10800 1 IDT}
    {4062952800 7200 0 IST}
    {4078681200 10800 1 IDT}
    {4094488800 7200 0 IST}
}







|
|
|
|
|
|
|
|
<
<
<
<
|
|
|
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
|
|
|
<
<
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
|
|
|
|
<
<
|
<
<
<
<
|
|
|
|

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89




90
91
92


93
94






























95
96
97










98
99
100
101
102
103
104
105


106






107
108
109
110












111












112


113
114
115
116
117
118


119






120
121
122
123
124
125
















126
127




128
129
130


131
132
133
134
135
136
137
138








139
140
141
142


143




144
145
146
147
148
    {1001282400 7200 0 IST}
    {1017356400 10800 1 IDT}
    {1033941600 7200 0 IST}
    {1048806000 10800 1 IDT}
    {1065132000 7200 0 IST}
    {1081292400 10800 1 IDT}
    {1095804000 7200 0 IST}
    {1112313600 10800 1 IDT}
    {1128812400 7200 0 IST}
    {1143763200 10800 1 IDT}
    {1159657200 7200 0 IST}
    {1175212800 10800 1 IDT}
    {1189897200 7200 0 IST}
    {1206662400 10800 1 IDT}
    {1223161200 7200 0 IST}




    {1238112000 10800 1 IDT}
    {1254006000 7200 0 IST}
    {1269561600 10800 1 IDT}


    {1284246000 7200 0 IST}
    {1301616000 10800 1 IDT}






























    {1317510000 7200 0 IST}
    {1333065600 10800 1 IDT}
    {1348354800 7200 0 IST}










    {1364515200 10800 1 IDT}
    {1378594800 7200 0 IST}
    {1395964800 10800 1 IDT}
    {1411858800 7200 0 IST}
    {1427414400 10800 1 IDT}
    {1442703600 7200 0 IST}
    {1459468800 10800 1 IDT}
    {1475967600 7200 0 IST}


    {1490918400 10800 1 IDT}






    {1506207600 7200 0 IST}
    {1522368000 10800 1 IDT}
    {1537052400 7200 0 IST}
    {1553817600 10800 1 IDT}












    {1570316400 7200 0 IST}












    {1585267200 10800 1 IDT}


    {1601161200 7200 0 IST}
    {1616716800 10800 1 IDT}
    {1631401200 7200 0 IST}
    {1648771200 10800 1 IDT}
    {1664665200 7200 0 IST}
    {1680220800 10800 1 IDT}


    {1695510000 7200 0 IST}






    {1711670400 10800 1 IDT}
    {1728169200 7200 0 IST}
    {1743120000 10800 1 IDT}
    {1759014000 7200 0 IST}
    {1774569600 10800 1 IDT}
    {1789858800 7200 0 IST}
















    {1806019200 10800 1 IDT}
    {1823122800 7200 0 IST}




    {1838073600 10800 1 IDT}
    {1853362800 7200 0 IST}
    {1869523200 10800 1 IDT}


    {1884207600 7200 0 IST}
    {1900972800 10800 1 IDT}
    {1917471600 7200 0 IST}
    {1932422400 10800 1 IDT}
    {1947711600 7200 0 IST}
    {1963872000 10800 1 IDT}
    {1978556400 7200 0 IST}
    {1995926400 10800 1 IDT}








    {2011820400 7200 0 IST}
    {2027376000 10800 1 IDT}
    {2042060400 7200 0 IST}
    {2058825600 10800 1 IDT}


    {2075324400 7200 0 IST}




    {2090275200 10800 1 IDT}
    {2106169200 7200 0 IST}
    {2121724800 10800 1 IDT}
    {2136409200 7200 0 IST}
}

Changes to library/tzdata/Asia/Oral.

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
    {1004234400 14400 0 ORAT}
    {1017540000 18000 1 ORAST}
    {1035684000 14400 0 ORAT}
    {1048989600 18000 1 ORAST}
    {1067133600 14400 0 ORAT}
    {1080439200 18000 1 ORAST}
    {1099188000 14400 0 ORAT}
    {1111888800 18000 1 ORAST}
    {1130637600 14400 0 ORAT}
    {1143338400 18000 1 ORAST}
    {1162087200 14400 0 ORAT}
    {1174788000 18000 1 ORAST}
    {1193536800 14400 0 ORAT}
    {1206842400 18000 1 ORAST}
    {1224986400 14400 0 ORAT}
    {1238292000 18000 1 ORAST}
    {1256436000 14400 0 ORAT}
    {1269741600 18000 1 ORAST}
    {1288490400 14400 0 ORAT}
    {1301191200 18000 1 ORAST}
    {1319940000 14400 0 ORAT}
    {1332640800 18000 1 ORAST}
    {1351389600 14400 0 ORAT}
    {1364695200 18000 1 ORAST}
    {1382839200 14400 0 ORAT}
    {1396144800 18000 1 ORAST}
    {1414288800 14400 0 ORAT}
    {1427594400 18000 1 ORAST}
    {1445738400 14400 0 ORAT}
    {1459044000 18000 1 ORAST}
    {1477792800 14400 0 ORAT}
    {1490493600 18000 1 ORAST}
    {1509242400 14400 0 ORAT}
    {1521943200 18000 1 ORAST}
    {1540692000 14400 0 ORAT}
    {1553997600 18000 1 ORAST}
    {1572141600 14400 0 ORAT}
    {1585447200 18000 1 ORAST}
    {1603591200 14400 0 ORAT}
    {1616896800 18000 1 ORAST}
    {1635645600 14400 0 ORAT}
    {1648346400 18000 1 ORAST}
    {1667095200 14400 0 ORAT}
    {1679796000 18000 1 ORAST}
    {1698544800 14400 0 ORAT}
    {1711850400 18000 1 ORAST}
    {1729994400 14400 0 ORAT}
    {1743300000 18000 1 ORAST}
    {1761444000 14400 0 ORAT}
    {1774749600 18000 1 ORAST}
    {1792893600 14400 0 ORAT}
    {1806199200 18000 1 ORAST}
    {1824948000 14400 0 ORAT}
    {1837648800 18000 1 ORAST}
    {1856397600 14400 0 ORAT}
    {1869098400 18000 1 ORAST}
    {1887847200 14400 0 ORAT}
    {1901152800 18000 1 ORAST}
    {1919296800 14400 0 ORAT}
    {1932602400 18000 1 ORAST}
    {1950746400 14400 0 ORAT}
    {1964052000 18000 1 ORAST}
    {1982800800 14400 0 ORAT}
    {1995501600 18000 1 ORAST}
    {2014250400 14400 0 ORAT}
    {2026951200 18000 1 ORAST}
    {2045700000 14400 0 ORAT}
    {2058400800 18000 1 ORAST}
    {2077149600 14400 0 ORAT}
    {2090455200 18000 1 ORAST}
    {2108599200 14400 0 ORAT}
    {2121904800 18000 1 ORAST}
    {2140048800 14400 0 ORAT}
    {2153354400 18000 1 ORAST}
    {2172103200 14400 0 ORAT}
    {2184804000 18000 1 ORAST}
    {2203552800 14400 0 ORAT}
    {2216253600 18000 1 ORAST}
    {2235002400 14400 0 ORAT}
    {2248308000 18000 1 ORAST}
    {2266452000 14400 0 ORAT}
    {2279757600 18000 1 ORAST}
    {2297901600 14400 0 ORAT}
    {2311207200 18000 1 ORAST}
    {2329351200 14400 0 ORAT}
    {2342656800 18000 1 ORAST}
    {2361405600 14400 0 ORAT}
    {2374106400 18000 1 ORAST}
    {2392855200 14400 0 ORAT}
    {2405556000 18000 1 ORAST}
    {2424304800 14400 0 ORAT}
    {2437610400 18000 1 ORAST}
    {2455754400 14400 0 ORAT}
    {2469060000 18000 1 ORAST}
    {2487204000 14400 0 ORAT}
    {2500509600 18000 1 ORAST}
    {2519258400 14400 0 ORAT}
    {2531959200 18000 1 ORAST}
    {2550708000 14400 0 ORAT}
    {2563408800 18000 1 ORAST}
    {2582157600 14400 0 ORAT}
    {2595463200 18000 1 ORAST}
    {2613607200 14400 0 ORAT}
    {2626912800 18000 1 ORAST}
    {2645056800 14400 0 ORAT}
    {2658362400 18000 1 ORAST}
    {2676506400 14400 0 ORAT}
    {2689812000 18000 1 ORAST}
    {2708560800 14400 0 ORAT}
    {2721261600 18000 1 ORAST}
    {2740010400 14400 0 ORAT}
    {2752711200 18000 1 ORAST}
    {2771460000 14400 0 ORAT}
    {2784765600 18000 1 ORAST}
    {2802909600 14400 0 ORAT}
    {2816215200 18000 1 ORAST}
    {2834359200 14400 0 ORAT}
    {2847664800 18000 1 ORAST}
    {2866413600 14400 0 ORAT}
    {2879114400 18000 1 ORAST}
    {2897863200 14400 0 ORAT}
    {2910564000 18000 1 ORAST}
    {2929312800 14400 0 ORAT}
    {2942013600 18000 1 ORAST}
    {2960762400 14400 0 ORAT}
    {2974068000 18000 1 ORAST}
    {2992212000 14400 0 ORAT}
    {3005517600 18000 1 ORAST}
    {3023661600 14400 0 ORAT}
    {3036967200 18000 1 ORAST}
    {3055716000 14400 0 ORAT}
    {3068416800 18000 1 ORAST}
    {3087165600 14400 0 ORAT}
    {3099866400 18000 1 ORAST}
    {3118615200 14400 0 ORAT}
    {3131920800 18000 1 ORAST}
    {3150064800 14400 0 ORAT}
    {3163370400 18000 1 ORAST}
    {3181514400 14400 0 ORAT}
    {3194820000 18000 1 ORAST}
    {3212964000 14400 0 ORAT}
    {3226269600 18000 1 ORAST}
    {3245018400 14400 0 ORAT}
    {3257719200 18000 1 ORAST}
    {3276468000 14400 0 ORAT}
    {3289168800 18000 1 ORAST}
    {3307917600 14400 0 ORAT}
    {3321223200 18000 1 ORAST}
    {3339367200 14400 0 ORAT}
    {3352672800 18000 1 ORAST}
    {3370816800 14400 0 ORAT}
    {3384122400 18000 1 ORAST}
    {3402871200 14400 0 ORAT}
    {3415572000 18000 1 ORAST}
    {3434320800 14400 0 ORAT}
    {3447021600 18000 1 ORAST}
    {3465770400 14400 0 ORAT}
    {3479076000 18000 1 ORAST}
    {3497220000 14400 0 ORAT}
    {3510525600 18000 1 ORAST}
    {3528669600 14400 0 ORAT}
    {3541975200 18000 1 ORAST}
    {3560119200 14400 0 ORAT}
    {3573424800 18000 1 ORAST}
    {3592173600 14400 0 ORAT}
    {3604874400 18000 1 ORAST}
    {3623623200 14400 0 ORAT}
    {3636324000 18000 1 ORAST}
    {3655072800 14400 0 ORAT}
    {3668378400 18000 1 ORAST}
    {3686522400 14400 0 ORAT}
    {3699828000 18000 1 ORAST}
    {3717972000 14400 0 ORAT}
    {3731277600 18000 1 ORAST}
    {3750026400 14400 0 ORAT}
    {3762727200 18000 1 ORAST}
    {3781476000 14400 0 ORAT}
    {3794176800 18000 1 ORAST}
    {3812925600 14400 0 ORAT}
    {3825626400 18000 1 ORAST}
    {3844375200 14400 0 ORAT}
    {3857680800 18000 1 ORAST}
    {3875824800 14400 0 ORAT}
    {3889130400 18000 1 ORAST}
    {3907274400 14400 0 ORAT}
    {3920580000 18000 1 ORAST}
    {3939328800 14400 0 ORAT}
    {3952029600 18000 1 ORAST}
    {3970778400 14400 0 ORAT}
    {3983479200 18000 1 ORAST}
    {4002228000 14400 0 ORAT}
    {4015533600 18000 1 ORAST}
    {4033677600 14400 0 ORAT}
    {4046983200 18000 1 ORAST}
    {4065127200 14400 0 ORAT}
    {4078432800 18000 1 ORAST}
    {4096576800 14400 0 ORAT}
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<

50
51
52
53
54
55
56
















































































































































































57













58
    {1004234400 14400 0 ORAT}
    {1017540000 18000 1 ORAST}
    {1035684000 14400 0 ORAT}
    {1048989600 18000 1 ORAST}
    {1067133600 14400 0 ORAT}
    {1080439200 18000 1 ORAST}
    {1099188000 14400 0 ORAT}
















































































































































































    {1110830400 18000 0 ORAT}













}

Changes to library/tzdata/Asia/Qyzylorda.

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
    {1004234400 21600 0 QYZT}
    {1017540000 25200 1 QYZST}
    {1035684000 21600 0 QYZT}
    {1048989600 25200 1 QYZST}
    {1067133600 21600 0 QYZT}
    {1080439200 25200 1 QYZST}
    {1099188000 21600 0 QYZT}
    {1111888800 25200 1 QYZST}
    {1130637600 21600 0 QYZT}
    {1143338400 25200 1 QYZST}
    {1162087200 21600 0 QYZT}
    {1174788000 25200 1 QYZST}
    {1193536800 21600 0 QYZT}
    {1206842400 25200 1 QYZST}
    {1224986400 21600 0 QYZT}
    {1238292000 25200 1 QYZST}
    {1256436000 21600 0 QYZT}
    {1269741600 25200 1 QYZST}
    {1288490400 21600 0 QYZT}
    {1301191200 25200 1 QYZST}
    {1319940000 21600 0 QYZT}
    {1332640800 25200 1 QYZST}
    {1351389600 21600 0 QYZT}
    {1364695200 25200 1 QYZST}
    {1382839200 21600 0 QYZT}
    {1396144800 25200 1 QYZST}
    {1414288800 21600 0 QYZT}
    {1427594400 25200 1 QYZST}
    {1445738400 21600 0 QYZT}
    {1459044000 25200 1 QYZST}
    {1477792800 21600 0 QYZT}
    {1490493600 25200 1 QYZST}
    {1509242400 21600 0 QYZT}
    {1521943200 25200 1 QYZST}
    {1540692000 21600 0 QYZT}
    {1553997600 25200 1 QYZST}
    {1572141600 21600 0 QYZT}
    {1585447200 25200 1 QYZST}
    {1603591200 21600 0 QYZT}
    {1616896800 25200 1 QYZST}
    {1635645600 21600 0 QYZT}
    {1648346400 25200 1 QYZST}
    {1667095200 21600 0 QYZT}
    {1679796000 25200 1 QYZST}
    {1698544800 21600 0 QYZT}
    {1711850400 25200 1 QYZST}
    {1729994400 21600 0 QYZT}
    {1743300000 25200 1 QYZST}
    {1761444000 21600 0 QYZT}
    {1774749600 25200 1 QYZST}
    {1792893600 21600 0 QYZT}
    {1806199200 25200 1 QYZST}
    {1824948000 21600 0 QYZT}
    {1837648800 25200 1 QYZST}
    {1856397600 21600 0 QYZT}
    {1869098400 25200 1 QYZST}
    {1887847200 21600 0 QYZT}
    {1901152800 25200 1 QYZST}
    {1919296800 21600 0 QYZT}
    {1932602400 25200 1 QYZST}
    {1950746400 21600 0 QYZT}
    {1964052000 25200 1 QYZST}
    {1982800800 21600 0 QYZT}
    {1995501600 25200 1 QYZST}
    {2014250400 21600 0 QYZT}
    {2026951200 25200 1 QYZST}
    {2045700000 21600 0 QYZT}
    {2058400800 25200 1 QYZST}
    {2077149600 21600 0 QYZT}
    {2090455200 25200 1 QYZST}
    {2108599200 21600 0 QYZT}
    {2121904800 25200 1 QYZST}
    {2140048800 21600 0 QYZT}
    {2153354400 25200 1 QYZST}
    {2172103200 21600 0 QYZT}
    {2184804000 25200 1 QYZST}
    {2203552800 21600 0 QYZT}
    {2216253600 25200 1 QYZST}
    {2235002400 21600 0 QYZT}
    {2248308000 25200 1 QYZST}
    {2266452000 21600 0 QYZT}
    {2279757600 25200 1 QYZST}
    {2297901600 21600 0 QYZT}
    {2311207200 25200 1 QYZST}
    {2329351200 21600 0 QYZT}
    {2342656800 25200 1 QYZST}
    {2361405600 21600 0 QYZT}
    {2374106400 25200 1 QYZST}
    {2392855200 21600 0 QYZT}
    {2405556000 25200 1 QYZST}
    {2424304800 21600 0 QYZT}
    {2437610400 25200 1 QYZST}
    {2455754400 21600 0 QYZT}
    {2469060000 25200 1 QYZST}
    {2487204000 21600 0 QYZT}
    {2500509600 25200 1 QYZST}
    {2519258400 21600 0 QYZT}
    {2531959200 25200 1 QYZST}
    {2550708000 21600 0 QYZT}
    {2563408800 25200 1 QYZST}
    {2582157600 21600 0 QYZT}
    {2595463200 25200 1 QYZST}
    {2613607200 21600 0 QYZT}
    {2626912800 25200 1 QYZST}
    {2645056800 21600 0 QYZT}
    {2658362400 25200 1 QYZST}
    {2676506400 21600 0 QYZT}
    {2689812000 25200 1 QYZST}
    {2708560800 21600 0 QYZT}
    {2721261600 25200 1 QYZST}
    {2740010400 21600 0 QYZT}
    {2752711200 25200 1 QYZST}
    {2771460000 21600 0 QYZT}
    {2784765600 25200 1 QYZST}
    {2802909600 21600 0 QYZT}
    {2816215200 25200 1 QYZST}
    {2834359200 21600 0 QYZT}
    {2847664800 25200 1 QYZST}
    {2866413600 21600 0 QYZT}
    {2879114400 25200 1 QYZST}
    {2897863200 21600 0 QYZT}
    {2910564000 25200 1 QYZST}
    {2929312800 21600 0 QYZT}
    {2942013600 25200 1 QYZST}
    {2960762400 21600 0 QYZT}
    {2974068000 25200 1 QYZST}
    {2992212000 21600 0 QYZT}
    {3005517600 25200 1 QYZST}
    {3023661600 21600 0 QYZT}
    {3036967200 25200 1 QYZST}
    {3055716000 21600 0 QYZT}
    {3068416800 25200 1 QYZST}
    {3087165600 21600 0 QYZT}
    {3099866400 25200 1 QYZST}
    {3118615200 21600 0 QYZT}
    {3131920800 25200 1 QYZST}
    {3150064800 21600 0 QYZT}
    {3163370400 25200 1 QYZST}
    {3181514400 21600 0 QYZT}
    {3194820000 25200 1 QYZST}
    {3212964000 21600 0 QYZT}
    {3226269600 25200 1 QYZST}
    {3245018400 21600 0 QYZT}
    {3257719200 25200 1 QYZST}
    {3276468000 21600 0 QYZT}
    {3289168800 25200 1 QYZST}
    {3307917600 21600 0 QYZT}
    {3321223200 25200 1 QYZST}
    {3339367200 21600 0 QYZT}
    {3352672800 25200 1 QYZST}
    {3370816800 21600 0 QYZT}
    {3384122400 25200 1 QYZST}
    {3402871200 21600 0 QYZT}
    {3415572000 25200 1 QYZST}
    {3434320800 21600 0 QYZT}
    {3447021600 25200 1 QYZST}
    {3465770400 21600 0 QYZT}
    {3479076000 25200 1 QYZST}
    {3497220000 21600 0 QYZT}
    {3510525600 25200 1 QYZST}
    {3528669600 21600 0 QYZT}
    {3541975200 25200 1 QYZST}
    {3560119200 21600 0 QYZT}
    {3573424800 25200 1 QYZST}
    {3592173600 21600 0 QYZT}
    {3604874400 25200 1 QYZST}
    {3623623200 21600 0 QYZT}
    {3636324000 25200 1 QYZST}
    {3655072800 21600 0 QYZT}
    {3668378400 25200 1 QYZST}
    {3686522400 21600 0 QYZT}
    {3699828000 25200 1 QYZST}
    {3717972000 21600 0 QYZT}
    {3731277600 25200 1 QYZST}
    {3750026400 21600 0 QYZT}
    {3762727200 25200 1 QYZST}
    {3781476000 21600 0 QYZT}
    {3794176800 25200 1 QYZST}
    {3812925600 21600 0 QYZT}
    {3825626400 25200 1 QYZST}
    {3844375200 21600 0 QYZT}
    {3857680800 25200 1 QYZST}
    {3875824800 21600 0 QYZT}
    {3889130400 25200 1 QYZST}
    {3907274400 21600 0 QYZT}
    {3920580000 25200 1 QYZST}
    {3939328800 21600 0 QYZT}
    {3952029600 25200 1 QYZST}
    {3970778400 21600 0 QYZT}
    {3983479200 25200 1 QYZST}
    {4002228000 21600 0 QYZT}
    {4015533600 25200 1 QYZST}
    {4033677600 21600 0 QYZT}
    {4046983200 25200 1 QYZST}
    {4065127200 21600 0 QYZT}
    {4078432800 25200 1 QYZST}
    {4096576800 21600 0 QYZT}
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

50
51
52
53
54
55
56































































































































































57






























58
    {1004234400 21600 0 QYZT}
    {1017540000 25200 1 QYZST}
    {1035684000 21600 0 QYZT}
    {1048989600 25200 1 QYZST}
    {1067133600 21600 0 QYZT}
    {1080439200 25200 1 QYZST}
    {1099188000 21600 0 QYZT}































































































































































    {1110823200 21600 0 QYZT}






























}

Changes to library/tzdata/Asia/Tehran.

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    {1632252600 12600 0 IRST}
    {1647894600 16200 1 IRDT}
    {1663788600 12600 0 IRST}
    {1679430600 16200 1 IRDT}
    {1695324600 12600 0 IRST}
    {1710966600 16200 1 IRDT}
    {1726860600 12600 0 IRST}
    {1742502600 16200 1 IRDT}
    {1758396600 12600 0 IRST}
    {1774125000 16200 1 IRDT}
    {1790019000 12600 0 IRST}
    {1805661000 16200 1 IRDT}
    {1821555000 12600 0 IRST}
    {1837197000 16200 1 IRDT}
    {1853091000 12600 0 IRST}
    {1868733000 16200 1 IRDT}







|
|







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    {1632252600 12600 0 IRST}
    {1647894600 16200 1 IRDT}
    {1663788600 12600 0 IRST}
    {1679430600 16200 1 IRDT}
    {1695324600 12600 0 IRST}
    {1710966600 16200 1 IRDT}
    {1726860600 12600 0 IRST}
    {1742589000 16200 1 IRDT}
    {1758483000 12600 0 IRST}
    {1774125000 16200 1 IRDT}
    {1790019000 12600 0 IRST}
    {1805661000 16200 1 IRDT}
    {1821555000 12600 0 IRST}
    {1837197000 16200 1 IRDT}
    {1853091000 12600 0 IRST}
    {1868733000 16200 1 IRDT}

Changes to library/tzdata/Asia/Tokyo.

1
2
3
4
5
6
7








8
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Asia/Tokyo) {
    {-9223372036854775808 33539 0 LMT}
    {-2587712400 32400 0 JST}
    {-2335251600 32400 0 CJT}
    {-1009875600 32400 0 JST}








}







>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Asia/Tokyo) {
    {-9223372036854775808 33539 0 LMT}
    {-2587712400 32400 0 JST}
    {-2335251600 32400 0 CJT}
    {-1009875600 32400 0 JST}
    {-683794800 36000 1 JDT}
    {-672393600 32400 0 JST}
    {-654764400 36000 1 JDT}
    {-640944000 32400 0 JST}
    {-620290800 36000 1 JDT}
    {-609494400 32400 0 JST}
    {-588841200 36000 1 JDT}
    {-578044800 32400 0 JST}
}

Changes to library/tzdata/Australia/Adelaide.

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
    {1035684000 37800 1 CST}
    {1048989600 34200 0 CST}
    {1067133600 37800 1 CST}
    {1080439200 34200 0 CST}
    {1099188000 37800 1 CST}
    {1111888800 34200 0 CST}
    {1130637600 37800 1 CST}
    {1143338400 34200 0 CST}
    {1162087200 37800 1 CST}
    {1174788000 34200 0 CST}
    {1193536800 37800 1 CST}
    {1206842400 34200 0 CST}
    {1224986400 37800 1 CST}
    {1238292000 34200 0 CST}
    {1256436000 37800 1 CST}







|







78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
    {1035684000 37800 1 CST}
    {1048989600 34200 0 CST}
    {1067133600 37800 1 CST}
    {1080439200 34200 0 CST}
    {1099188000 37800 1 CST}
    {1111888800 34200 0 CST}
    {1130637600 37800 1 CST}
    {1143943200 34200 0 CST}
    {1162087200 37800 1 CST}
    {1174788000 34200 0 CST}
    {1193536800 37800 1 CST}
    {1206842400 34200 0 CST}
    {1224986400 37800 1 CST}
    {1238292000 34200 0 CST}
    {1256436000 37800 1 CST}

Changes to library/tzdata/Australia/Broken_Hill.

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
    {1035684000 37800 1 CST}
    {1048989600 34200 0 CST}
    {1067133600 37800 1 CST}
    {1080439200 34200 0 CST}
    {1099188000 37800 1 CST}
    {1111888800 34200 0 CST}
    {1130637600 37800 1 CST}
    {1143338400 34200 0 CST}
    {1162087200 37800 1 CST}
    {1174788000 34200 0 CST}
    {1193536800 37800 1 CST}
    {1206842400 34200 0 CST}
    {1224986400 37800 1 CST}
    {1238292000 34200 0 CST}
    {1256436000 37800 1 CST}







|







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
    {1035684000 37800 1 CST}
    {1048989600 34200 0 CST}
    {1067133600 37800 1 CST}
    {1080439200 34200 0 CST}
    {1099188000 37800 1 CST}
    {1111888800 34200 0 CST}
    {1130637600 37800 1 CST}
    {1143943200 34200 0 CST}
    {1162087200 37800 1 CST}
    {1174788000 34200 0 CST}
    {1193536800 37800 1 CST}
    {1206842400 34200 0 CST}
    {1224986400 37800 1 CST}
    {1238292000 34200 0 CST}
    {1256436000 37800 1 CST}

Added library/tzdata/Australia/Currie.



































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Australia/Currie) {
    {-9223372036854775808 34528 0 LMT}
    {-2345794528 36000 0 EST}
    {-1680508800 39600 1 EST}
    {-1669892400 39600 0 EST}
    {-1665392400 36000 0 EST}
    {-883641600 39600 1 EST}
    {-876128400 36000 0 EST}
    {-860400000 39600 1 EST}
    {-844678800 36000 0 EST}
    {-828345600 39600 1 EST}
    {-813229200 36000 0 EST}
    {47138400 36000 0 EST}
    {57722400 39600 1 EST}
    {68004000 36000 0 EST}
    {89172000 39600 1 EST}
    {100058400 36000 0 EST}
    {120621600 39600 1 EST}
    {131508000 36000 0 EST}
    {152071200 39600 1 EST}
    {162957600 36000 0 EST}
    {183520800 39600 1 EST}
    {195012000 36000 0 EST}
    {215575200 39600 1 EST}
    {226461600 36000 0 EST}
    {247024800 39600 1 EST}
    {257911200 36000 0 EST}
    {278474400 39600 1 EST}
    {289360800 36000 0 EST}
    {309924000 39600 1 EST}
    {320810400 36000 0 EST}
    {341373600 39600 1 EST}
    {352260000 36000 0 EST}
    {372823200 39600 1 EST}
    {386128800 36000 0 EST}
    {404877600 39600 1 EST}
    {417578400 36000 0 EST}
    {436327200 39600 1 EST}
    {447213600 36000 0 EST}
    {467776800 39600 1 EST}
    {478663200 36000 0 EST}
    {499226400 39600 1 EST}
    {510112800 36000 0 EST}
    {530071200 39600 1 EST}
    {542772000 36000 0 EST}
    {562125600 39600 1 EST}
    {574826400 36000 0 EST}
    {594180000 39600 1 EST}
    {606276000 36000 0 EST}
    {625629600 39600 1 EST}
    {637725600 36000 0 EST}
    {657079200 39600 1 EST}
    {670384800 36000 0 EST}
    {686714400 39600 1 EST}
    {701834400 36000 0 EST}
    {718164000 39600 1 EST}
    {733284000 36000 0 EST}
    {749613600 39600 1 EST}
    {764733600 36000 0 EST}
    {781063200 39600 1 EST}
    {796183200 36000 0 EST}
    {812512800 39600 1 EST}
    {828237600 36000 0 EST}
    {844567200 39600 1 EST}
    {859687200 36000 0 EST}
    {876016800 39600 1 EST}
    {891136800 36000 0 EST}
    {907466400 39600 1 EST}
    {922586400 36000 0 EST}
    {938916000 39600 1 EST}
    {954036000 36000 0 EST}
    {967341600 39600 1 EST}
    {985485600 36000 0 EST}
    {1002420000 39600 1 EST}
    {1017540000 36000 0 EST}
    {1033869600 39600 1 EST}
    {1048989600 36000 0 EST}
    {1065319200 39600 1 EST}
    {1080439200 36000 0 EST}
    {1096768800 39600 1 EST}
    {1111888800 36000 0 EST}
    {1128218400 39600 1 EST}
    {1143943200 36000 0 EST}
    {1159668000 39600 1 EST}
    {1174788000 36000 0 EST}
    {1191722400 39600 1 EST}
    {1206842400 36000 0 EST}
    {1223172000 39600 1 EST}
    {1238292000 36000 0 EST}
    {1254621600 39600 1 EST}
    {1269741600 36000 0 EST}
    {1286071200 39600 1 EST}
    {1301191200 36000 0 EST}
    {1317520800 39600 1 EST}
    {1332640800 36000 0 EST}
    {1349575200 39600 1 EST}
    {1364695200 36000 0 EST}
    {1381024800 39600 1 EST}
    {1396144800 36000 0 EST}
    {1412474400 39600 1 EST}
    {1427594400 36000 0 EST}
    {1443924000 39600 1 EST}
    {1459044000 36000 0 EST}
    {1475373600 39600 1 EST}
    {1490493600 36000 0 EST}
    {1506823200 39600 1 EST}
    {1521943200 36000 0 EST}
    {1538877600 39600 1 EST}
    {1553997600 36000 0 EST}
    {1570327200 39600 1 EST}
    {1585447200 36000 0 EST}
    {1601776800 39600 1 EST}
    {1616896800 36000 0 EST}
    {1633226400 39600 1 EST}
    {1648346400 36000 0 EST}
    {1664676000 39600 1 EST}
    {1679796000 36000 0 EST}
    {1696125600 39600 1 EST}
    {1711850400 36000 0 EST}
    {1728180000 39600 1 EST}
    {1743300000 36000 0 EST}
    {1759629600 39600 1 EST}
    {1774749600 36000 0 EST}
    {1791079200 39600 1 EST}
    {1806199200 36000 0 EST}
    {1822528800 39600 1 EST}
    {1837648800 36000 0 EST}
    {1853978400 39600 1 EST}
    {1869098400 36000 0 EST}
    {1886032800 39600 1 EST}
    {1901152800 36000 0 EST}
    {1917482400 39600 1 EST}
    {1932602400 36000 0 EST}
    {1948932000 39600 1 EST}
    {1964052000 36000 0 EST}
    {1980381600 39600 1 EST}
    {1995501600 36000 0 EST}
    {2011831200 39600 1 EST}
    {2026951200 36000 0 EST}
    {2043280800 39600 1 EST}
    {2058400800 36000 0 EST}
    {2075335200 39600 1 EST}
    {2090455200 36000 0 EST}
    {2106784800 39600 1 EST}
    {2121904800 36000 0 EST}
    {2138234400 39600 1 EST}
    {2153354400 36000 0 EST}
    {2169684000 39600 1 EST}
    {2184804000 36000 0 EST}
    {2201133600 39600 1 EST}
    {2216253600 36000 0 EST}
    {2233188000 39600 1 EST}
    {2248308000 36000 0 EST}
    {2264637600 39600 1 EST}
    {2279757600 36000 0 EST}
    {2296087200 39600 1 EST}
    {2311207200 36000 0 EST}
    {2327536800 39600 1 EST}
    {2342656800 36000 0 EST}
    {2358986400 39600 1 EST}
    {2374106400 36000 0 EST}
    {2390436000 39600 1 EST}
    {2405556000 36000 0 EST}
    {2422490400 39600 1 EST}
    {2437610400 36000 0 EST}
    {2453940000 39600 1 EST}
    {2469060000 36000 0 EST}
    {2485389600 39600 1 EST}
    {2500509600 36000 0 EST}
    {2516839200 39600 1 EST}
    {2531959200 36000 0 EST}
    {2548288800 39600 1 EST}
    {2563408800 36000 0 EST}
    {2579738400 39600 1 EST}
    {2595463200 36000 0 EST}
    {2611792800 39600 1 EST}
    {2626912800 36000 0 EST}
    {2643242400 39600 1 EST}
    {2658362400 36000 0 EST}
    {2674692000 39600 1 EST}
    {2689812000 36000 0 EST}
    {2706141600 39600 1 EST}
    {2721261600 36000 0 EST}
    {2737591200 39600 1 EST}
    {2752711200 36000 0 EST}
    {2769645600 39600 1 EST}
    {2784765600 36000 0 EST}
    {2801095200 39600 1 EST}
    {2816215200 36000 0 EST}
    {2832544800 39600 1 EST}
    {2847664800 36000 0 EST}
    {2863994400 39600 1 EST}
    {2879114400 36000 0 EST}
    {2895444000 39600 1 EST}
    {2910564000 36000 0 EST}
    {2926893600 39600 1 EST}
    {2942013600 36000 0 EST}
    {2958948000 39600 1 EST}
    {2974068000 36000 0 EST}
    {2990397600 39600 1 EST}
    {3005517600 36000 0 EST}
    {3021847200 39600 1 EST}
    {3036967200 36000 0 EST}
    {3053296800 39600 1 EST}
    {3068416800 36000 0 EST}
    {3084746400 39600 1 EST}
    {3099866400 36000 0 EST}
    {3116800800 39600 1 EST}
    {3131920800 36000 0 EST}
    {3148250400 39600 1 EST}
    {3163370400 36000 0 EST}
    {3179700000 39600 1 EST}
    {3194820000 36000 0 EST}
    {3211149600 39600 1 EST}
    {3226269600 36000 0 EST}
    {3242599200 39600 1 EST}
    {3257719200 36000 0 EST}
    {3274048800 39600 1 EST}
    {3289168800 36000 0 EST}
    {3306103200 39600 1 EST}
    {3321223200 36000 0 EST}
    {3337552800 39600 1 EST}
    {3352672800 36000 0 EST}
    {3369002400 39600 1 EST}
    {3384122400 36000 0 EST}
    {3400452000 39600 1 EST}
    {3415572000 36000 0 EST}
    {3431901600 39600 1 EST}
    {3447021600 36000 0 EST}
    {3463351200 39600 1 EST}
    {3479076000 36000 0 EST}
    {3495405600 39600 1 EST}
    {3510525600 36000 0 EST}
    {3526855200 39600 1 EST}
    {3541975200 36000 0 EST}
    {3558304800 39600 1 EST}
    {3573424800 36000 0 EST}
    {3589754400 39600 1 EST}
    {3604874400 36000 0 EST}
    {3621204000 39600 1 EST}
    {3636324000 36000 0 EST}
    {3653258400 39600 1 EST}
    {3668378400 36000 0 EST}
    {3684708000 39600 1 EST}
    {3699828000 36000 0 EST}
    {3716157600 39600 1 EST}
    {3731277600 36000 0 EST}
    {3747607200 39600 1 EST}
    {3762727200 36000 0 EST}
    {3779056800 39600 1 EST}
    {3794176800 36000 0 EST}
    {3810506400 39600 1 EST}
    {3825626400 36000 0 EST}
    {3842560800 39600 1 EST}
    {3857680800 36000 0 EST}
    {3874010400 39600 1 EST}
    {3889130400 36000 0 EST}
    {3905460000 39600 1 EST}
    {3920580000 36000 0 EST}
    {3936909600 39600 1 EST}
    {3952029600 36000 0 EST}
    {3968359200 39600 1 EST}
    {3983479200 36000 0 EST}
    {4000413600 39600 1 EST}
    {4015533600 36000 0 EST}
    {4031863200 39600 1 EST}
    {4046983200 36000 0 EST}
    {4063312800 39600 1 EST}
    {4078432800 36000 0 EST}
    {4094762400 39600 1 EST}
}

Changes to library/tzdata/Australia/Hobart.

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    {1033869600 39600 1 EST}
    {1048989600 36000 0 EST}
    {1065319200 39600 1 EST}
    {1080439200 36000 0 EST}
    {1096768800 39600 1 EST}
    {1111888800 36000 0 EST}
    {1128218400 39600 1 EST}
    {1143338400 36000 0 EST}
    {1159668000 39600 1 EST}
    {1174788000 36000 0 EST}
    {1191722400 39600 1 EST}
    {1206842400 36000 0 EST}
    {1223172000 39600 1 EST}
    {1238292000 36000 0 EST}
    {1254621600 39600 1 EST}







|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    {1033869600 39600 1 EST}
    {1048989600 36000 0 EST}
    {1065319200 39600 1 EST}
    {1080439200 36000 0 EST}
    {1096768800 39600 1 EST}
    {1111888800 36000 0 EST}
    {1128218400 39600 1 EST}
    {1143943200 36000 0 EST}
    {1159668000 39600 1 EST}
    {1174788000 36000 0 EST}
    {1191722400 39600 1 EST}
    {1206842400 36000 0 EST}
    {1223172000 39600 1 EST}
    {1238292000 36000 0 EST}
    {1254621600 39600 1 EST}

Changes to library/tzdata/Australia/Lord_Howe.

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    {1035646200 39600 1 LHST}
    {1048950000 37800 0 LHST}
    {1067095800 39600 1 LHST}
    {1080399600 37800 0 LHST}
    {1099150200 39600 1 LHST}
    {1111849200 37800 0 LHST}
    {1130599800 39600 1 LHST}
    {1143298800 37800 0 LHST}
    {1162049400 39600 1 LHST}
    {1174748400 37800 0 LHST}
    {1193499000 39600 1 LHST}
    {1206802800 37800 0 LHST}
    {1224948600 39600 1 LHST}
    {1238252400 37800 0 LHST}
    {1256398200 39600 1 LHST}







|







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    {1035646200 39600 1 LHST}
    {1048950000 37800 0 LHST}
    {1067095800 39600 1 LHST}
    {1080399600 37800 0 LHST}
    {1099150200 39600 1 LHST}
    {1111849200 37800 0 LHST}
    {1130599800 39600 1 LHST}
    {1143903600 37800 0 LHST}
    {1162049400 39600 1 LHST}
    {1174748400 37800 0 LHST}
    {1193499000 39600 1 LHST}
    {1206802800 37800 0 LHST}
    {1224948600 39600 1 LHST}
    {1238252400 37800 0 LHST}
    {1256398200 39600 1 LHST}

Changes to library/tzdata/Australia/Melbourne.

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    {1035684000 39600 1 EST}
    {1048989600 36000 0 EST}
    {1067133600 39600 1 EST}
    {1080439200 36000 0 EST}
    {1099188000 39600 1 EST}
    {1111888800 36000 0 EST}
    {1130637600 39600 1 EST}
    {1143338400 36000 0 EST}
    {1162087200 39600 1 EST}
    {1174788000 36000 0 EST}
    {1193536800 39600 1 EST}
    {1206842400 36000 0 EST}
    {1224986400 39600 1 EST}
    {1238292000 36000 0 EST}
    {1256436000 39600 1 EST}







|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    {1035684000 39600 1 EST}
    {1048989600 36000 0 EST}
    {1067133600 39600 1 EST}
    {1080439200 36000 0 EST}
    {1099188000 39600 1 EST}
    {1111888800 36000 0 EST}
    {1130637600 39600 1 EST}
    {1143943200 36000 0 EST}
    {1162087200 39600 1 EST}
    {1174788000 36000 0 EST}
    {1193536800 39600 1 EST}
    {1206842400 36000 0 EST}
    {1224986400 39600 1 EST}
    {1238292000 36000 0 EST}
    {1256436000 39600 1 EST}

Changes to library/tzdata/Australia/Sydney.

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    {1035684000 39600 1 EST}
    {1048989600 36000 0 EST}
    {1067133600 39600 1 EST}
    {1080439200 36000 0 EST}
    {1099188000 39600 1 EST}
    {1111888800 36000 0 EST}
    {1130637600 39600 1 EST}
    {1143338400 36000 0 EST}
    {1162087200 39600 1 EST}
    {1174788000 36000 0 EST}
    {1193536800 39600 1 EST}
    {1206842400 36000 0 EST}
    {1224986400 39600 1 EST}
    {1238292000 36000 0 EST}
    {1256436000 39600 1 EST}







|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    {1035684000 39600 1 EST}
    {1048989600 36000 0 EST}
    {1067133600 39600 1 EST}
    {1080439200 36000 0 EST}
    {1099188000 39600 1 EST}
    {1111888800 36000 0 EST}
    {1130637600 39600 1 EST}
    {1143943200 36000 0 EST}
    {1162087200 39600 1 EST}
    {1174788000 36000 0 EST}
    {1193536800 39600 1 EST}
    {1206842400 36000 0 EST}
    {1224986400 39600 1 EST}
    {1238292000 36000 0 EST}
    {1256436000 39600 1 EST}

Changes to library/tzdata/Brazil/Acre.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Porto_Acre)]} {
    LoadTimeZoneFile America/Porto_Acre
}
set TZData(:Brazil/Acre) $TZData(:America/Porto_Acre)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Rio_Branco)]} {
    LoadTimeZoneFile America/Rio_Branco
}
set TZData(:Brazil/Acre) $TZData(:America/Rio_Branco)

Changes to library/tzdata/EST.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indianapolis)]} {
    LoadTimeZoneFile America/Indianapolis
}
set TZData(:EST) $TZData(:America/Indianapolis)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Panama)]} {
    LoadTimeZoneFile America/Panama
}
set TZData(:EST) $TZData(:America/Panama)

Changes to library/tzdata/Europe/Belfast.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372

# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Europe/Belfast) {
    {-9223372036854775808 -1420 0 LMT}
    {-2821649780 -1521 0 DMT}
    {-1691962479 2079 1 IST}
    {-1680472800 0 0 GMT}
    {-1664143200 3600 1 BST}
    {-1650146400 0 0 GMT}
    {-1633903200 3600 1 BST}
    {-1617487200 0 0 GMT}
    {-1601848800 3600 1 BST}
    {-1586037600 0 0 GMT}
    {-1570399200 3600 1 BST}
    {-1552168800 0 0 GMT}
    {-1538344800 3600 1 BST}
    {-1522533600 0 0 GMT}
    {-1507500000 3600 1 BST}
    {-1490565600 0 0 GMT}
    {-1473631200 3600 1 BST}
    {-1460930400 0 0 GMT}
    {-1442786400 3600 1 BST}
    {-1428876000 0 0 GMT}
    {-1410732000 3600 1 BST}
    {-1396216800 0 0 GMT}
    {-1379282400 3600 1 BST}
    {-1364767200 0 0 GMT}
    {-1348437600 3600 1 BST}
    {-1333317600 0 0 GMT}
    {-1315778400 3600 1 BST}
    {-1301263200 0 0 GMT}
    {-1284328800 3600 1 BST}
    {-1269813600 0 0 GMT}
    {-1253484000 3600 1 BST}
    {-1238364000 0 0 GMT}
    {-1221429600 3600 1 BST}
    {-1206914400 0 0 GMT}
    {-1189980000 3600 1 BST}
    {-1175464800 0 0 GMT}
    {-1159135200 3600 1 BST}
    {-1143410400 0 0 GMT}
    {-1126476000 3600 1 BST}
    {-1111960800 0 0 GMT}
    {-1095631200 3600 1 BST}
    {-1080511200 0 0 GMT}
    {-1063576800 3600 1 BST}
    {-1049061600 0 0 GMT}
    {-1032127200 3600 1 BST}
    {-1017612000 0 0 GMT}
    {-1001282400 3600 1 BST}
    {-986162400 0 0 GMT}
    {-969228000 3600 1 BST}
    {-950479200 0 0 GMT}
    {-942012000 3600 1 BST}
    {-904518000 7200 1 BDST}
    {-896050800 3600 1 BST}
    {-875487600 7200 1 BDST}
    {-864601200 3600 1 BST}
    {-844038000 7200 1 BDST}
    {-832546800 3600 1 BST}
    {-812588400 7200 1 BDST}
    {-798073200 3600 1 BST}
    {-781052400 7200 1 BDST}
    {-772066800 3600 1 BST}
    {-764805600 0 0 GMT}
    {-748476000 3600 1 BST}
    {-733356000 0 0 GMT}
    {-719445600 3600 1 BST}
    {-717030000 7200 1 BDST}
    {-706748400 3600 1 BST}
    {-699487200 0 0 GMT}
    {-687996000 3600 1 BST}
    {-668037600 0 0 GMT}
    {-654732000 3600 1 BST}
    {-636588000 0 0 GMT}
    {-622072800 3600 1 BST}
    {-605743200 0 0 GMT}
    {-590623200 3600 1 BST}
    {-574293600 0 0 GMT}
    {-558568800 3600 1 BST}
    {-542239200 0 0 GMT}
    {-527119200 3600 1 BST}
    {-512604000 0 0 GMT}
    {-496274400 3600 1 BST}
    {-481154400 0 0 GMT}
    {-464220000 3600 1 BST}
    {-449704800 0 0 GMT}
    {-432165600 3600 1 BST}
    {-417650400 0 0 GMT}
    {-401320800 3600 1 BST}
    {-386200800 0 0 GMT}
    {-369266400 3600 1 BST}
    {-354751200 0 0 GMT}
    {-337816800 3600 1 BST}
    {-323301600 0 0 GMT}
    {-306972000 3600 1 BST}
    {-291852000 0 0 GMT}
    {-276732000 3600 1 BST}
    {-257983200 0 0 GMT}
    {-245282400 3600 1 BST}
    {-226533600 0 0 GMT}
    {-213228000 3600 1 BST}
    {-195084000 0 0 GMT}
    {-182383200 3600 1 BST}
    {-163634400 0 0 GMT}
    {-150933600 3600 1 BST}
    {-132184800 0 0 GMT}
    {-119484000 3600 1 BST}
    {-100735200 0 0 GMT}
    {-88034400 3600 1 BST}
    {-68680800 0 0 GMT}
    {-59004000 3600 1 BST}
    {-37238400 3600 0 BST}
    {57722400 0 0 GMT}
    {69818400 3600 1 BST}
    {89172000 0 0 GMT}
    {101268000 3600 1 BST}
    {120621600 0 0 GMT}
    {132717600 3600 1 BST}
    {152071200 0 0 GMT}
    {164167200 3600 1 BST}
    {183520800 0 0 GMT}
    {196221600 3600 1 BST}
    {214970400 0 0 GMT}
    {227671200 3600 1 BST}
    {246420000 0 0 GMT}
    {259120800 3600 1 BST}
    {278474400 0 0 GMT}
    {290570400 3600 1 BST}
    {309924000 0 0 GMT}
    {322020000 3600 1 BST}
    {341373600 0 0 GMT}
    {354675600 3600 1 BST}
    {372819600 0 0 GMT}
    {386125200 3600 1 BST}
    {404269200 0 0 GMT}
    {417574800 3600 1 BST}
    {435718800 0 0 GMT}
    {449024400 3600 1 BST}
    {467773200 0 0 GMT}
    {481078800 3600 1 BST}
    {499222800 0 0 GMT}
    {512528400 3600 1 BST}
    {530672400 0 0 GMT}
    {543978000 3600 1 BST}
    {562122000 0 0 GMT}
    {575427600 3600 1 BST}
    {593571600 0 0 GMT}
    {606877200 3600 1 BST}
    {625626000 0 0 GMT}
    {638326800 3600 1 BST}
    {657075600 0 0 GMT}
    {670381200 3600 1 BST}
    {688525200 0 0 GMT}
    {701830800 3600 1 BST}
    {719974800 0 0 GMT}
    {733280400 3600 1 BST}
    {751424400 0 0 GMT}
    {764730000 3600 1 BST}
    {782874000 0 0 GMT}
    {796179600 3600 1 BST}
    {814323600 0 0 GMT}
    {820454400 0 0 GMT}
    {828234000 3600 1 BST}
    {846378000 0 0 GMT}
    {859683600 3600 1 BST}
    {877827600 0 0 GMT}
    {891133200 3600 1 BST}
    {909277200 0 0 GMT}
    {922582800 3600 1 BST}
    {941331600 0 0 GMT}
    {954032400 3600 1 BST}
    {972781200 0 0 GMT}
    {985482000 3600 1 BST}
    {1004230800 0 0 GMT}
    {1017536400 3600 1 BST}
    {1035680400 0 0 GMT}
    {1048986000 3600 1 BST}
    {1067130000 0 0 GMT}
    {1080435600 3600 1 BST}
    {1099184400 0 0 GMT}
    {1111885200 3600 1 BST}
    {1130634000 0 0 GMT}
    {1143334800 3600 1 BST}
    {1162083600 0 0 GMT}
    {1174784400 3600 1 BST}
    {1193533200 0 0 GMT}
    {1206838800 3600 1 BST}
    {1224982800 0 0 GMT}
    {1238288400 3600 1 BST}
    {1256432400 0 0 GMT}
    {1269738000 3600 1 BST}
    {1288486800 0 0 GMT}
    {1301187600 3600 1 BST}
    {1319936400 0 0 GMT}
    {1332637200 3600 1 BST}
    {1351386000 0 0 GMT}
    {1364691600 3600 1 BST}
    {1382835600 0 0 GMT}
    {1396141200 3600 1 BST}
    {1414285200 0 0 GMT}
    {1427590800 3600 1 BST}
    {1445734800 0 0 GMT}
    {1459040400 3600 1 BST}
    {1477789200 0 0 GMT}
    {1490490000 3600 1 BST}
    {1509238800 0 0 GMT}
    {1521939600 3600 1 BST}
    {1540688400 0 0 GMT}
    {1553994000 3600 1 BST}
    {1572138000 0 0 GMT}
    {1585443600 3600 1 BST}
    {1603587600 0 0 GMT}
    {1616893200 3600 1 BST}
    {1635642000 0 0 GMT}
    {1648342800 3600 1 BST}
    {1667091600 0 0 GMT}
    {1679792400 3600 1 BST}
    {1698541200 0 0 GMT}
    {1711846800 3600 1 BST}
    {1729990800 0 0 GMT}
    {1743296400 3600 1 BST}
    {1761440400 0 0 GMT}
    {1774746000 3600 1 BST}
    {1792890000 0 0 GMT}
    {1806195600 3600 1 BST}
    {1824944400 0 0 GMT}
    {1837645200 3600 1 BST}
    {1856394000 0 0 GMT}
    {1869094800 3600 1 BST}
    {1887843600 0 0 GMT}
    {1901149200 3600 1 BST}
    {1919293200 0 0 GMT}
    {1932598800 3600 1 BST}
    {1950742800 0 0 GMT}
    {1964048400 3600 1 BST}
    {1982797200 0 0 GMT}
    {1995498000 3600 1 BST}
    {2014246800 0 0 GMT}
    {2026947600 3600 1 BST}
    {2045696400 0 0 GMT}
    {2058397200 3600 1 BST}
    {2077146000 0 0 GMT}
    {2090451600 3600 1 BST}
    {2108595600 0 0 GMT}
    {2121901200 3600 1 BST}
    {2140045200 0 0 GMT}
    {2153350800 3600 1 BST}
    {2172099600 0 0 GMT}
    {2184800400 3600 1 BST}
    {2203549200 0 0 GMT}
    {2216250000 3600 1 BST}
    {2234998800 0 0 GMT}
    {2248304400 3600 1 BST}
    {2266448400 0 0 GMT}
    {2279754000 3600 1 BST}
    {2297898000 0 0 GMT}
    {2311203600 3600 1 BST}
    {2329347600 0 0 GMT}
    {2342653200 3600 1 BST}
    {2361402000 0 0 GMT}
    {2374102800 3600 1 BST}
    {2392851600 0 0 GMT}
    {2405552400 3600 1 BST}
    {2424301200 0 0 GMT}
    {2437606800 3600 1 BST}
    {2455750800 0 0 GMT}
    {2469056400 3600 1 BST}
    {2487200400 0 0 GMT}
    {2500506000 3600 1 BST}
    {2519254800 0 0 GMT}
    {2531955600 3600 1 BST}
    {2550704400 0 0 GMT}
    {2563405200 3600 1 BST}
    {2582154000 0 0 GMT}
    {2595459600 3600 1 BST}
    {2613603600 0 0 GMT}
    {2626909200 3600 1 BST}
    {2645053200 0 0 GMT}
    {2658358800 3600 1 BST}
    {2676502800 0 0 GMT}
    {2689808400 3600 1 BST}
    {2708557200 0 0 GMT}
    {2721258000 3600 1 BST}
    {2740006800 0 0 GMT}
    {2752707600 3600 1 BST}
    {2771456400 0 0 GMT}
    {2784762000 3600 1 BST}
    {2802906000 0 0 GMT}
    {2816211600 3600 1 BST}
    {2834355600 0 0 GMT}
    {2847661200 3600 1 BST}
    {2866410000 0 0 GMT}
    {2879110800 3600 1 BST}
    {2897859600 0 0 GMT}
    {2910560400 3600 1 BST}
    {2929309200 0 0 GMT}
    {2942010000 3600 1 BST}
    {2960758800 0 0 GMT}
    {2974064400 3600 1 BST}
    {2992208400 0 0 GMT}
    {3005514000 3600 1 BST}
    {3023658000 0 0 GMT}
    {3036963600 3600 1 BST}
    {3055712400 0 0 GMT}
    {3068413200 3600 1 BST}
    {3087162000 0 0 GMT}
    {3099862800 3600 1 BST}
    {3118611600 0 0 GMT}
    {3131917200 3600 1 BST}
    {3150061200 0 0 GMT}
    {3163366800 3600 1 BST}
    {3181510800 0 0 GMT}
    {3194816400 3600 1 BST}
    {3212960400 0 0 GMT}
    {3226266000 3600 1 BST}
    {3245014800 0 0 GMT}
    {3257715600 3600 1 BST}
    {3276464400 0 0 GMT}
    {3289165200 3600 1 BST}
    {3307914000 0 0 GMT}
    {3321219600 3600 1 BST}
    {3339363600 0 0 GMT}
    {3352669200 3600 1 BST}
    {3370813200 0 0 GMT}
    {3384118800 3600 1 BST}
    {3402867600 0 0 GMT}
    {3415568400 3600 1 BST}
    {3434317200 0 0 GMT}
    {3447018000 3600 1 BST}
    {3465766800 0 0 GMT}
    {3479072400 3600 1 BST}
    {3497216400 0 0 GMT}
    {3510522000 3600 1 BST}
    {3528666000 0 0 GMT}
    {3541971600 3600 1 BST}
    {3560115600 0 0 GMT}
    {3573421200 3600 1 BST}
    {3592170000 0 0 GMT}
    {3604870800 3600 1 BST}
    {3623619600 0 0 GMT}
    {3636320400 3600 1 BST}
    {3655069200 0 0 GMT}
    {3668374800 3600 1 BST}
    {3686518800 0 0 GMT}
    {3699824400 3600 1 BST}
    {3717968400 0 0 GMT}
    {3731274000 3600 1 BST}
    {3750022800 0 0 GMT}
    {3762723600 3600 1 BST}
    {3781472400 0 0 GMT}
    {3794173200 3600 1 BST}
    {3812922000 0 0 GMT}
    {3825622800 3600 1 BST}
    {3844371600 0 0 GMT}
    {3857677200 3600 1 BST}
    {3875821200 0 0 GMT}
    {3889126800 3600 1 BST}
    {3907270800 0 0 GMT}
    {3920576400 3600 1 BST}
    {3939325200 0 0 GMT}
    {3952026000 3600 1 BST}
    {3970774800 0 0 GMT}
    {3983475600 3600 1 BST}
    {4002224400 0 0 GMT}
    {4015530000 3600 1 BST}
    {4033674000 0 0 GMT}
    {4046979600 3600 1 BST}
    {4065123600 0 0 GMT}
    {4078429200 3600 1 BST}
    {4096573200 0 0 GMT}
}


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

>
1
2
























































































































































































3
























































































































































































4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/London)]} {
























































































































































































    LoadTimeZoneFile Europe/London
























































































































































































}
set TZData(:Europe/Belfast) $TZData(:Europe/London)

Changes to library/tzdata/Europe/Copenhagen.

1
2
3
4
5
6
7
8
9
10
11
12
13
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Europe/Copenhagen) {
    {-9223372036854775808 3020 0 LMT}
    {-2524524620 3020 0 CMT}
    {-2390518220 3600 0 CET}
    {-1692496800 7200 1 CEST}
    {-1680490800 3600 0 CET}
    {-935110800 7200 1 CEST}
    {-857253600 3600 0 CET}
    {-844552800 7200 1 CEST}
    {-828223200 3600 0 CET}
    {-812498400 7200 1 CEST}





|







1
2
3
4
5
6
7
8
9
10
11
12
13
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Europe/Copenhagen) {
    {-9223372036854775808 3020 0 LMT}
    {-2524524620 3020 0 CMT}
    {-2398294220 3600 0 CET}
    {-1692496800 7200 1 CEST}
    {-1680490800 3600 0 CET}
    {-935110800 7200 1 CEST}
    {-857253600 3600 0 CET}
    {-844552800 7200 1 CEST}
    {-828223200 3600 0 CET}
    {-812498400 7200 1 CEST}

Changes to library/tzdata/Europe/Warsaw.

17
18
19
20
21
22
23
24
25


26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
    {-844552800 7200 1 CEST}
    {-828223200 3600 0 CET}
    {-812498400 7200 1 CEST}
    {-796870800 3600 0 CET}
    {-796604400 3600 0 CET}
    {-778726800 7200 1 CEST}
    {-762660000 3600 0 CET}
    {-748486800 7200 1 CEST}
    {-735876000 3600 0 CET}


    {-715222800 7200 1 CEST}
    {-701920800 3600 0 CET}
    {-684982800 7200 1 CEST}
    {-670471200 3600 0 CET}
    {-397090800 7200 1 CEST}
    {-386809200 3600 0 CET}
    {-371084400 7200 1 CEST}
    {-355359600 3600 0 CET}
    {-334191600 7200 1 CEST}
    {-323305200 3600 0 CET}
    {-307580400 7200 1 CEST}
    {-291855600 3600 0 CET}
    {-271292400 7200 1 CEST}
    {-260406000 3600 0 CET}
    {-239842800 7200 1 CEST}
    {-228956400 3600 0 CET}
    {-208393200 7200 1 CEST}
    {-197506800 3600 0 CET}
    {-176338800 7200 1 CEST}
    {-166057200 3600 0 CET}
    {228873600 3600 0 CET}
    {228877200 7200 1 CEST}
    {243997200 3600 0 CET}
    {260326800 7200 1 CEST}
    {276051600 3600 0 CET}
    {291776400 7200 1 CEST}
    {307501200 3600 0 CET}
    {323830800 7200 1 CEST}







|
|
>
>
|
|
|
|
















|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
    {-844552800 7200 1 CEST}
    {-828223200 3600 0 CET}
    {-812498400 7200 1 CEST}
    {-796870800 3600 0 CET}
    {-796604400 3600 0 CET}
    {-778726800 7200 1 CEST}
    {-762660000 3600 0 CET}
    {-748483200 7200 1 CEST}
    {-733269600 3600 0 CET}
    {-715212000 7200 1 CEST}
    {-701906400 3600 0 CET}
    {-684972000 7200 1 CEST}
    {-670456800 3600 0 CET}
    {-654127200 7200 1 CEST}
    {-639007200 3600 0 CET}
    {-397090800 7200 1 CEST}
    {-386809200 3600 0 CET}
    {-371084400 7200 1 CEST}
    {-355359600 3600 0 CET}
    {-334191600 7200 1 CEST}
    {-323305200 3600 0 CET}
    {-307580400 7200 1 CEST}
    {-291855600 3600 0 CET}
    {-271292400 7200 1 CEST}
    {-260406000 3600 0 CET}
    {-239842800 7200 1 CEST}
    {-228956400 3600 0 CET}
    {-208393200 7200 1 CEST}
    {-197506800 3600 0 CET}
    {-176338800 7200 1 CEST}
    {-166057200 3600 0 CET}
    {220921200 3600 0 CET}
    {228877200 7200 1 CEST}
    {243997200 3600 0 CET}
    {260326800 7200 1 CEST}
    {276051600 3600 0 CET}
    {291776400 7200 1 CEST}
    {307501200 3600 0 CET}
    {323830800 7200 1 CEST}
62
63
64
65
66
67
68

69
70
71
72
73
74
75
    {465354000 3600 0 CET}
    {481078800 7200 1 CEST}
    {496803600 3600 0 CET}
    {512528400 7200 1 CEST}
    {528253200 3600 0 CET}
    {543978000 7200 1 CEST}
    {559702800 3600 0 CET}

    {575427600 7200 1 CEST}
    {591152400 3600 0 CET}
    {606877200 7200 1 CEST}
    {622602000 3600 0 CET}
    {638326800 7200 1 CEST}
    {654656400 3600 0 CET}
    {670381200 7200 1 CEST}







>







64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
    {465354000 3600 0 CET}
    {481078800 7200 1 CEST}
    {496803600 3600 0 CET}
    {512528400 7200 1 CEST}
    {528253200 3600 0 CET}
    {543978000 7200 1 CEST}
    {559702800 3600 0 CET}
    {567990000 3600 0 CET}
    {575427600 7200 1 CEST}
    {591152400 3600 0 CET}
    {606877200 7200 1 CEST}
    {622602000 3600 0 CET}
    {638326800 7200 1 CEST}
    {654656400 3600 0 CET}
    {670381200 7200 1 CEST}
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
    {811904400 3600 0 CET}
    {828234000 7200 1 CEST}
    {846378000 3600 0 CET}
    {859683600 7200 1 CEST}
    {877827600 3600 0 CET}
    {891133200 7200 1 CEST}
    {909277200 3600 0 CET}
    {915145200 3600 0 CET}
    {922582800 7200 1 CEST}
    {941331600 3600 0 CET}
    {954032400 7200 1 CEST}
    {972781200 3600 0 CET}
    {985482000 7200 1 CEST}
    {1004230800 3600 0 CET}
    {1017536400 7200 1 CEST}







<







87
88
89
90
91
92
93

94
95
96
97
98
99
100
    {811904400 3600 0 CET}
    {828234000 7200 1 CEST}
    {846378000 3600 0 CET}
    {859683600 7200 1 CEST}
    {877827600 3600 0 CET}
    {891133200 7200 1 CEST}
    {909277200 3600 0 CET}

    {922582800 7200 1 CEST}
    {941331600 3600 0 CET}
    {954032400 7200 1 CEST}
    {972781200 3600 0 CET}
    {985482000 7200 1 CEST}
    {1004230800 3600 0 CET}
    {1017536400 7200 1 CEST}

Changes to library/tzdata/GMT+0.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT+0)]} {
    LoadTimeZoneFile Etc/GMT+0
}
set TZData(:GMT+0) $TZData(:Etc/GMT+0)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT)]} {
    LoadTimeZoneFile Etc/GMT
}
set TZData(:GMT+0) $TZData(:Etc/GMT)

Changes to library/tzdata/GMT-0.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT-0)]} {
    LoadTimeZoneFile Etc/GMT-0
}
set TZData(:GMT-0) $TZData(:Etc/GMT-0)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT)]} {
    LoadTimeZoneFile Etc/GMT
}
set TZData(:GMT-0) $TZData(:Etc/GMT)

Changes to library/tzdata/GMT0.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT0)]} {
    LoadTimeZoneFile Etc/GMT0
}
set TZData(:GMT0) $TZData(:Etc/GMT0)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT)]} {
    LoadTimeZoneFile Etc/GMT
}
set TZData(:GMT0) $TZData(:Etc/GMT)

Changes to library/tzdata/Greenwich.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/Greenwich)]} {
    LoadTimeZoneFile Etc/Greenwich
}
set TZData(:Greenwich) $TZData(:Etc/Greenwich)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/GMT)]} {
    LoadTimeZoneFile Etc/GMT
}
set TZData(:Greenwich) $TZData(:Etc/GMT)

Changes to library/tzdata/Indian/Chagos.

1
2
3
4

5
6
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Indian/Chagos) {
    {-9223372036854775808 18000 0 IOT}

    {820436400 21600 0 IOT}
}



|
>


1
2
3
4
5
6
7
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Indian/Chagos) {
    {-9223372036854775808 17380 0 LMT}
    {-1988167780 18000 0 IOT}
    {820436400 21600 0 IOT}
}

Changes to library/tzdata/Indian/Cocos.

1
2
3
4

5
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Indian/Cocos) {
    {-9223372036854775808 23400 0 CCT}

}



|
>

1
2
3
4
5
6
# created by ../tools/tclZIC.tcl - do not edit

set TZData(:Indian/Cocos) {
    {-9223372036854775808 23260 0 LMT}
    {-2209012060 23400 0 CCT}
}

Changes to library/tzdata/Navajo.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Shiprock)]} {
    LoadTimeZoneFile America/Shiprock
}
set TZData(:Navajo) $TZData(:America/Shiprock)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Denver)]} {
    LoadTimeZoneFile America/Denver
}
set TZData(:Navajo) $TZData(:America/Denver)

Changes to library/tzdata/Pacific/Yap.

1


2
3
4
5
6
7
# created by ../tools/tclZIC.tcl - do not edit



set TZData(:Pacific/Yap) {
    {-9223372036854775808 33152 0 LMT}
    {-2177485952 32400 0 YAPT}
    {-7981200 36000 0 YAPT}
}

>
>
|
|
<
<
<
<
1
2
3
4
5




# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Truk)]} {
    LoadTimeZoneFile Pacific/Truk
}
set TZData(:Pacific/Yap) $TZData(:Pacific/Truk)




Changes to library/tzdata/US/East-Indiana.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indianapolis)]} {
    LoadTimeZoneFile America/Indianapolis
}
set TZData(:US/East-Indiana) $TZData(:America/Indianapolis)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indiana/Indianapolis)]} {
    LoadTimeZoneFile America/Indiana/Indianapolis
}
set TZData(:US/East-Indiana) $TZData(:America/Indiana/Indianapolis)

Changes to library/tzdata/Universal.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/Universal)]} {
    LoadTimeZoneFile Etc/Universal
}
set TZData(:Universal) $TZData(:Etc/Universal)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/UTC)]} {
    LoadTimeZoneFile Etc/UTC
}
set TZData(:Universal) $TZData(:Etc/UTC)

Changes to library/tzdata/Zulu.

1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/Zulu)]} {
    LoadTimeZoneFile Etc/Zulu
}
set TZData(:Zulu) $TZData(:Etc/Zulu)

|
|

|
1
2
3
4
5
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Etc/UTC)]} {
    LoadTimeZoneFile Etc/UTC
}
set TZData(:Zulu) $TZData(:Etc/UTC)

Changes to library/word.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
# word.tcl --
#
# This file defines various procedures for computing word boundaries
# in strings.  This file is primarily needed so Tk text and entry
# widgets behave properly for different platforms.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
# Copyright (c) 1998 by Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: word.tcl,v 1.7 2002/11/01 00:28:51 andreas_kupries Exp $

# The following variables are used to determine which characters are
# interpreted as white space.  

if {[string equal $::tcl_platform(platform) "windows"]} {
    # Windows style - any but a unicode space char
    set tcl_wordchars "\\S"
    set tcl_nonwordchars "\\s"
} else {
    # Motif style - any unicode word char (number, letter, or underscore)
    set tcl_wordchars "\\w"
    set tcl_nonwordchars "\\W"












|




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
# word.tcl --
#
# This file defines various procedures for computing word boundaries
# in strings.  This file is primarily needed so Tk text and entry
# widgets behave properly for different platforms.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
# Copyright (c) 1998 by Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: word.tcl,v 1.7.6.1 2005/08/02 18:16:15 dgp Exp $

# The following variables are used to determine which characters are
# interpreted as white space.  

if {$::tcl_platform(platform) eq "windows"} {
    # Windows style - any but a unicode space char
    set tcl_wordchars "\\S"
    set tcl_nonwordchars "\\s"
} else {
    # Motif style - any unicode word char (number, letter, or underscore)
    set tcl_wordchars "\\w"
    set tcl_nonwordchars "\\W"
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_wordBreakBefore {str start} {
    global tcl_nonwordchars tcl_wordchars
    if {[string equal $start end]} {
	set start [string length $str]
    }
    if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
	return [lindex $result 1]
    }
    return -1
}







|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_wordBreakBefore {str start} {
    global tcl_nonwordchars tcl_wordchars
    if {$start eq "end"} {
	set start [string length $str]
    }
    if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
	return [lindex $result 1]
    }
    return -1
}
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_startOfPreviousWord {str start} {
    global tcl_nonwordchars tcl_wordchars
    if {[string equal $start end]} {
	set start [string length $str]
    }
    if {[regexp -indices \
	    "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
	    [string range $str 0 [expr {$start - 1}]] result word]} {
	return [lindex $word 0]
    }
    return -1
}







|









116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_startOfPreviousWord {str start} {
    global tcl_nonwordchars tcl_wordchars
    if {$start eq "end"} {
	set start [string length $str]
    }
    if {[regexp -indices \
	    "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
	    [string range $str 0 [expr {$start - 1}]] result word]} {
	return [lindex $word 0]
    }
    return -1
}

Added libtommath/bn.pdf.

cannot compute difference between binary files

Added libtommath/bn.tex.























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
\documentclass[b5paper]{book}
\usepackage{hyperref}
\usepackage{makeidx}
\usepackage{amssymb}
\usepackage{color}
\usepackage{alltt}
\usepackage{graphicx}
\usepackage{layout}
\def\union{\cup}
\def\intersect{\cap}
\def\getsrandom{\stackrel{\rm R}{\gets}}
\def\cross{\times}
\def\cat{\hspace{0.5em} \| \hspace{0.5em}}
\def\catn{$\|$}
\def\divides{\hspace{0.3em} | \hspace{0.3em}}
\def\nequiv{\not\equiv}
\def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}}
\def\lcm{{\rm lcm}}
\def\gcd{{\rm gcd}}
\def\log{{\rm log}}
\def\ord{{\rm ord}}
\def\abs{{\mathit abs}}
\def\rep{{\mathit rep}}
\def\mod{{\mathit\ mod\ }}
\renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})}
\newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor}
\newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil}
\def\Or{{\rm\ or\ }}
\def\And{{\rm\ and\ }}
\def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}}
\def\implies{\Rightarrow}
\def\undefined{{\rm ``undefined"}}
\def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}}
\let\oldphi\phi
\def\phi{\varphi}
\def\Pr{{\rm Pr}}
\newcommand{\str}[1]{{\mathbf{#1}}}
\def\F{{\mathbb F}}
\def\N{{\mathbb N}}
\def\Z{{\mathbb Z}}
\def\R{{\mathbb R}}
\def\C{{\mathbb C}}
\def\Q{{\mathbb Q}}
\definecolor{DGray}{gray}{0.5}
\newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}}
\def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}}
\def\gap{\vspace{0.5ex}}
\makeindex
\begin{document}
\frontmatter
\pagestyle{empty}
\title{LibTomMath User Manual \\ v0.36}
\author{Tom St Denis \\ [email protected]}
\maketitle
This text, the library and the accompanying textbook are all hereby placed in the public domain.  This book has been 
formatted for B5 [176x250] paper using the \LaTeX{} {\em book} macro package.

\vspace{10cm}

\begin{flushright}Open Source.  Open Academia.  Open Minds.

\mbox{ }

Tom St Denis,

Ontario, Canada
\end{flushright}

\tableofcontents
\listoffigures
\mainmatter
\pagestyle{headings}
\chapter{Introduction}
\section{What is LibTomMath?}
LibTomMath is a library of source code which provides a series of efficient and carefully written functions for manipulating
large integer numbers.  It was written in portable ISO C source code so that it will build on any platform with a conforming
C compiler.  

In a nutshell the library was written from scratch with verbose comments to help instruct computer science students how
to implement ``bignum'' math.  However, the resulting code has proven to be very useful.  It has been used by numerous 
universities, commercial and open source software developers.  It has been used on a variety of platforms ranging from
Linux and Windows based x86 to ARM based Gameboys and PPC based MacOS machines.  

\section{License}
As of the v0.25 the library source code has been placed in the public domain with every new release.  As of the v0.28
release the textbook ``Implementing Multiple Precision Arithmetic'' has been placed in the public domain with every new
release as well.  This textbook is meant to compliment the project by providing a more solid walkthrough of the development
algorithms used in the library.

Since both\footnote{Note that the MPI files under mtest/ are copyrighted by Michael Fromberger.  They are not required to use LibTomMath.} are in the 
public domain everyone is entitled to do with them as they see fit.

\section{Building LibTomMath}

LibTomMath is meant to be very ``GCC friendly'' as it comes with a makefile well suited for GCC.  However, the library will
also build in MSVC, Borland C out of the box.  For any other ISO C compiler a makefile will have to be made by the end
developer.  

\subsection{Static Libraries}
To build as a static library for GCC issue the following
\begin{alltt}
make
\end{alltt}

command.  This will build the library and archive the object files in ``libtommath.a''.  Now you link against 
that and include ``tommath.h'' within your programs.  Alternatively to build with MSVC issue the following
\begin{alltt}
nmake -f makefile.msvc
\end{alltt}

This will build the library and archive the object files in ``tommath.lib''.  This has been tested with MSVC 
version 6.00 with service pack 5.  

\subsection{Shared Libraries}
To build as a shared library for GCC issue the following
\begin{alltt}
make -f makefile.shared
\end{alltt}
This requires the ``libtool'' package (common on most Linux/BSD systems).  It will build LibTomMath as both shared
and static then install (by default) into /usr/lib as well as install the header files in /usr/include.  The shared 
library (resource) will be called ``libtommath.la'' while the static library called ``libtommath.a''.  Generally 
you use libtool to link your application against the shared object.  

There is limited support for making a ``DLL'' in windows via the ``makefile.cygwin\_dll'' makefile.  It requires 
Cygwin to work with since it requires the auto-export/import functionality.  The resulting DLL and import library 
``libtommath.dll.a'' can be used to link LibTomMath dynamically to any Windows program using Cygwin.

\subsection{Testing}
To build the library and the test harness type

\begin{alltt}
make test
\end{alltt}

This will build the library, ``test'' and ``mtest/mtest''.  The ``test'' program will accept test vectors and verify the
results.  ``mtest/mtest'' will generate test vectors using the MPI library by Michael Fromberger\footnote{A copy of MPI
is included in the package}.  Simply pipe mtest into test using

\begin{alltt}
mtest/mtest | test
\end{alltt}

If you do not have a ``/dev/urandom'' style RNG source you will have to write your own PRNG and simply pipe that into 
mtest.  For example, if your PRNG program is called ``myprng'' simply invoke

\begin{alltt}
myprng | mtest/mtest | test
\end{alltt}

This will output a row of numbers that are increasing.  Each column is a different test (such as addition, multiplication, etc)
that is being performed.  The numbers represent how many times the test was invoked.  If an error is detected the program
will exit with a dump of the relevent numbers it was working with.

\section{Build Configuration}
LibTomMath can configured at build time in three phases we shall call ``depends'', ``tweaks'' and ``trims''.  
Each phase changes how the library is built and they are applied one after another respectively.  

To make the system more powerful you can tweak the build process.  Classes are defined in the file
``tommath\_superclass.h''.  By default, the symbol ``LTM\_ALL'' shall be defined which simply 
instructs the system to build all of the functions.  This is how LibTomMath used to be packaged.  This will give you 
access to every function LibTomMath offers.

However, there are cases where such a build is not optional.  For instance, you want to perform RSA operations.  You 
don't need the vast majority of the library to perform these operations.  Aside from LTM\_ALL there is 
another pre--defined class ``SC\_RSA\_1'' which works in conjunction with the RSA from LibTomCrypt.  Additional 
classes can be defined base on the need of the user.

\subsection{Build Depends}
In the file tommath\_class.h you will see a large list of C ``defines'' followed by a series of ``ifdefs''
which further define symbols.  All of the symbols (technically they're macros $\ldots$) represent a given C source
file.  For instance, BN\_MP\_ADD\_C represents the file ``bn\_mp\_add.c''.  When a define has been enabled the
function in the respective file will be compiled and linked into the library.  Accordingly when the define
is absent the file will not be compiled and not contribute any size to the library.

You will also note that the header tommath\_class.h is actually recursively included (it includes itself twice).  
This is to help resolve as many dependencies as possible.  In the last pass the symbol LTM\_LAST will be defined.  
This is useful for ``trims''.

\subsection{Build Tweaks}
A tweak is an algorithm ``alternative''.  For example, to provide tradeoffs (usually between size and space).
They can be enabled at any pass of the configuration phase.

\begin{small}
\begin{center}
\begin{tabular}{|l|l|}
\hline \textbf{Define} & \textbf{Purpose} \\
\hline BN\_MP\_DIV\_SMALL & Enables a slower, smaller and equally \\
                          & functional mp\_div() function \\
\hline
\end{tabular}
\end{center}
\end{small}

\subsection{Build Trims}
A trim is a manner of removing functionality from a function that is not required.  For instance, to perform
RSA cryptography you only require exponentiation with odd moduli so even moduli support can be safely removed.  
Build trims are meant to be defined on the last pass of the configuration which means they are to be defined
only if LTM\_LAST has been defined.

\subsubsection{Moduli Related}
\begin{small}
\begin{center}
\begin{tabular}{|l|l|}
\hline \textbf{Restriction} & \textbf{Undefine} \\
\hline Exponentiation with odd moduli only & BN\_S\_MP\_EXPTMOD\_C \\
                                           & BN\_MP\_REDUCE\_C \\
                                           & BN\_MP\_REDUCE\_SETUP\_C \\
                                           & BN\_S\_MP\_MUL\_HIGH\_DIGS\_C \\
                                           & BN\_FAST\_S\_MP\_MUL\_HIGH\_DIGS\_C \\
\hline Exponentiation with random odd moduli & (The above plus the following) \\
                                           & BN\_MP\_REDUCE\_2K\_C \\
                                           & BN\_MP\_REDUCE\_2K\_SETUP\_C \\
                                           & BN\_MP\_REDUCE\_IS\_2K\_C \\
                                           & BN\_MP\_DR\_IS\_MODULUS\_C \\
                                           & BN\_MP\_DR\_REDUCE\_C \\
                                           & BN\_MP\_DR\_SETUP\_C \\
\hline Modular inverse odd moduli only     & BN\_MP\_INVMOD\_SLOW\_C \\
\hline Modular inverse (both, smaller/slower) & BN\_FAST\_MP\_INVMOD\_C \\
\hline
\end{tabular}
\end{center}
\end{small}

\subsubsection{Operand Size Related}
\begin{small}
\begin{center}
\begin{tabular}{|l|l|}
\hline \textbf{Restriction} & \textbf{Undefine} \\
\hline Moduli $\le 2560$ bits              & BN\_MP\_MONTGOMERY\_REDUCE\_C \\
                                           & BN\_S\_MP\_MUL\_DIGS\_C \\
                                           & BN\_S\_MP\_MUL\_HIGH\_DIGS\_C \\
                                           & BN\_S\_MP\_SQR\_C \\
\hline Polynomial Schmolynomial            & BN\_MP\_KARATSUBA\_MUL\_C \\
                                           & BN\_MP\_KARATSUBA\_SQR\_C \\
                                           & BN\_MP\_TOOM\_MUL\_C \\ 
                                           & BN\_MP\_TOOM\_SQR\_C \\

\hline
\end{tabular}
\end{center}
\end{small}


\section{Purpose of LibTomMath}
Unlike  GNU MP (GMP) Library, LIP, OpenSSL or various other commercial kits (Miracl), LibTomMath was not written with 
bleeding edge performance in mind.  First and foremost LibTomMath was written to be entirely open.  Not only is the 
source code public domain (unlike various other GPL/etc licensed code), not only is the code freely downloadable but the
source code is also accessible for computer science students attempting to learn ``BigNum'' or multiple precision
arithmetic techniques. 

LibTomMath was written to be an instructive collection of source code.  This is why there are many comments, only one
function per source file and often I use a ``middle-road'' approach where I don't cut corners for an extra 2\% speed
increase.

Source code alone cannot really teach how the algorithms work which is why I also wrote a textbook that accompanies
the library (beat that!).

So you may be thinking ``should I use LibTomMath?'' and the answer is a definite maybe.  Let me tabulate what I think
are the pros and cons of LibTomMath by comparing it to the math routines from GnuPG\footnote{GnuPG v1.2.3 versus LibTomMath v0.28}.

\newpage\begin{figure}[here]
\begin{small}
\begin{center}
\begin{tabular}{|l|c|c|l|}
\hline \textbf{Criteria} & \textbf{Pro} & \textbf{Con} & \textbf{Notes} \\
\hline Few lines of code per file & X & & GnuPG $ = 300.9$, LibTomMath  $ = 71.97$ \\
\hline Commented function prototypes & X && GnuPG function names are cryptic. \\
\hline Speed && X & LibTomMath is slower.  \\
\hline Totally free & X & & GPL has unfavourable restrictions.\\
\hline Large function base & X & & GnuPG is barebones. \\
\hline Five modular reduction algorithms & X & & Faster modular exponentiation for a variety of moduli. \\
\hline Portable & X & & GnuPG requires configuration to build. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{LibTomMath Valuation}
\end{figure}

It may seem odd to compare LibTomMath to GnuPG since the math in GnuPG is only a small portion of the entire application. 
However, LibTomMath was written with cryptography in mind.  It provides essentially all of the functions a cryptosystem
would require when working with large integers.  

So it may feel tempting to just rip the math code out of GnuPG (or GnuMP where it was taken from originally) in your
own application but I think there are reasons not to.  While LibTomMath is slower than libraries such as GnuMP it is
not normally significantly slower.  On x86 machines the difference is normally a factor of two when performing modular
exponentiations.  It depends largely on the processor, compiler and the moduli being used.

Essentially the only time you wouldn't use LibTomMath is when blazing speed is the primary concern.  However,
on the other side of the coin LibTomMath offers you a totally free (public domain) well structured math library
that is very flexible, complete and performs well in resource contrained environments.  Fast RSA for example can
be performed with as little as 8KB of ram for data (again depending on build options).  

\chapter{Getting Started with LibTomMath}
\section{Building Programs}
In order to use LibTomMath you must include ``tommath.h'' and link against the appropriate library file (typically 
libtommath.a).  There is no library initialization required and the entire library is thread safe.

\section{Return Codes}
There are three possible return codes a function may return.

\index{MP\_OKAY}\index{MP\_YES}\index{MP\_NO}\index{MP\_VAL}\index{MP\_MEM}
\begin{figure}[here!]
\begin{center}
\begin{small}
\begin{tabular}{|l|l|}
\hline \textbf{Code} & \textbf{Meaning} \\
\hline MP\_OKAY & The function succeeded. \\
\hline MP\_VAL  & The function input was invalid. \\
\hline MP\_MEM  & Heap memory exhausted. \\
\hline &\\
\hline MP\_YES  & Response is yes. \\
\hline MP\_NO   & Response is no. \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Return Codes}
\end{figure}

The last two codes listed are not actually ``return'ed'' by a function.  They are placed in an integer (the caller must
provide the address of an integer it can store to) which the caller can access.  To convert one of the three return codes
to a string use the following function.

\index{mp\_error\_to\_string}
\begin{alltt}
char *mp_error_to_string(int code);
\end{alltt}

This will return a pointer to a string which describes the given error code.  It will not work for the return codes 
MP\_YES and MP\_NO.  

\section{Data Types}
The basic ``multiple precision integer'' type is known as the ``mp\_int'' within LibTomMath.  This data type is used to
organize all of the data required to manipulate the integer it represents.  Within LibTomMath it has been prototyped
as the following.

\index{mp\_int}
\begin{alltt}
typedef struct  \{
    int used, alloc, sign;
    mp_digit *dp;
\} mp_int;
\end{alltt}

Where ``mp\_digit'' is a data type that represents individual digits of the integer.  By default, an mp\_digit is the
ISO C ``unsigned long'' data type and each digit is $28-$bits long.  The mp\_digit type can be configured to suit other
platforms by defining the appropriate macros.  

All LTM functions that use the mp\_int type will expect a pointer to mp\_int structure.  You must allocate memory to
hold the structure itself by yourself (whether off stack or heap it doesn't matter).  The very first thing that must be
done to use an mp\_int is that it must be initialized.

\section{Function Organization}

The arithmetic functions of the library are all organized to have the same style prototype.  That is source operands
are passed on the left and the destination is on the right.  For instance,

\begin{alltt}
mp_add(&a, &b, &c);       /* c = a + b */
mp_mul(&a, &a, &c);       /* c = a * a */
mp_div(&a, &b, &c, &d);   /* c = [a/b], d = a mod b */
\end{alltt}

Another feature of the way the functions have been implemented is that source operands can be destination operands as well.
For instance,

\begin{alltt}
mp_add(&a, &b, &b);       /* b = a + b */
mp_div(&a, &b, &a, &c);   /* a = [a/b], c = a mod b */
\end{alltt}

This allows operands to be re-used which can make programming simpler.

\section{Initialization}
\subsection{Single Initialization}
A single mp\_int can be initialized with the ``mp\_init'' function. 

\index{mp\_init}
\begin{alltt}
int mp_init (mp_int * a);
\end{alltt}

This function expects a pointer to an mp\_int structure and will initialize the members of the structure so the mp\_int
represents the default integer which is zero.  If the functions returns MP\_OKAY then the mp\_int is ready to be used
by the other LibTomMath functions.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* use the number */

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\subsection{Single Free}
When you are finished with an mp\_int it is ideal to return the heap it used back to the system.  The following function 
provides this functionality.

\index{mp\_clear}
\begin{alltt}
void mp_clear (mp_int * a);
\end{alltt}

The function expects a pointer to a previously initialized mp\_int structure and frees the heap it uses.  It sets the 
pointer\footnote{The ``dp'' member.} within the mp\_int to \textbf{NULL} which is used to prevent double free situations. 
Is is legal to call mp\_clear() twice on the same mp\_int in a row.  

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* use the number */

   /* We're done with it. */
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\subsection{Multiple Initializations}
Certain algorithms require more than one large integer.  In these instances it is ideal to initialize all of the mp\_int
variables in an ``all or nothing'' fashion.  That is, they are either all initialized successfully or they are all
not initialized.

The  mp\_init\_multi() function provides this functionality.

\index{mp\_init\_multi} \index{mp\_clear\_multi}
\begin{alltt}
int mp_init_multi(mp_int *mp, ...);
\end{alltt}

It accepts a \textbf{NULL} terminated list of pointers to mp\_int structures.  It will attempt to initialize them all
at once.  If the function returns MP\_OKAY then all of the mp\_int variables are ready to use, otherwise none of them
are available for use.  A complementary mp\_clear\_multi() function allows multiple mp\_int variables to be free'd 
from the heap at the same time.  

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int num1, num2, num3;
   int result;

   if ((result = mp_init_multi(&num1, 
                               &num2,
                               &num3, NULL)) != MP\_OKAY) \{      
      printf("Error initializing the numbers.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* use the numbers */

   /* We're done with them. */
   mp_clear_multi(&num1, &num2, &num3, NULL);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\subsection{Other Initializers}
To initialized and make a copy of an mp\_int the mp\_init\_copy() function has been provided.  

\index{mp\_init\_copy}
\begin{alltt}
int mp_init_copy (mp_int * a, mp_int * b);
\end{alltt}

This function will initialize $a$ and make it a copy of $b$ if all goes well.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int num1, num2;
   int result;

   /* initialize and do work on num1 ... */

   /* We want a copy of num1 in num2 now */
   if ((result = mp_init_copy(&num2, &num1)) != MP_OKAY) \{
     printf("Error initializing the copy.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* now num2 is ready and contains a copy of num1 */

   /* We're done with them. */
   mp_clear_multi(&num1, &num2, NULL);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

Another less common initializer is mp\_init\_size() which allows the user to initialize an mp\_int with a given
default number of digits.  By default, all initializers allocate \textbf{MP\_PREC} digits.  This function lets
you override this behaviour.

\index{mp\_init\_size}
\begin{alltt}
int mp_init_size (mp_int * a, int size);
\end{alltt}

The $size$ parameter must be greater than zero.  If the function succeeds the mp\_int $a$ will be initialized
to have $size$ digits (which are all initially zero).  

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   /* we need a 60-digit number */
   if ((result = mp_init_size(&number, 60)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* use the number */

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\section{Maintenance Functions}

\subsection{Reducing Memory Usage}
When an mp\_int is in a state where it won't be changed again\footnote{A Diffie-Hellman modulus for instance.} excess
digits can be removed to return memory to the heap with the mp\_shrink() function.

\index{mp\_shrink}
\begin{alltt}
int mp_shrink (mp_int * a);
\end{alltt}

This will remove excess digits of the mp\_int $a$.  If the operation fails the mp\_int should be intact without the
excess digits being removed.  Note that you can use a shrunk mp\_int in further computations, however, such operations
will require heap operations which can be slow.  It is not ideal to shrink mp\_int variables that you will further
modify in the system (unless you are seriously low on memory).  

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* use the number [e.g. pre-computation]  */

   /* We're done with it for now. */
   if ((result = mp_shrink(&number)) != MP_OKAY) \{
      printf("Error shrinking the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* use it .... */


   /* we're done with it. */ 
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\subsection{Adding additional digits}

Within the mp\_int structure are two parameters which control the limitations of the array of digits that represent
the integer the mp\_int is meant to equal.   The \textit{used} parameter dictates how many digits are significant, that is,
contribute to the value of the mp\_int.  The \textit{alloc} parameter dictates how many digits are currently available in
the array.  If you need to perform an operation that requires more digits you will have to mp\_grow() the mp\_int to
your desired size.  

\index{mp\_grow}
\begin{alltt}
int mp_grow (mp_int * a, int size);
\end{alltt}

This will grow the array of digits of $a$ to $size$.  If the \textit{alloc} parameter is already bigger than
$size$ the function will not do anything.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* use the number */

   /* We need to add 20 digits to the number  */
   if ((result = mp_grow(&number, number.alloc + 20)) != MP_OKAY) \{
      printf("Error growing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}


   /* use the number */

   /* we're done with it. */ 
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\chapter{Basic Operations}
\section{Small Constants}
Setting mp\_ints to small constants is a relatively common operation.  To accomodate these instances there are two
small constant assignment functions.  The first function is used to set a single digit constant while the second sets
an ISO C style ``unsigned long'' constant.  The reason for both functions is efficiency.  Setting a single digit is quick but the
domain of a digit can change (it's always at least $0 \ldots 127$).  

\subsection{Single Digit}

Setting a single digit can be accomplished with the following function.

\index{mp\_set}
\begin{alltt}
void mp_set (mp_int * a, mp_digit b);
\end{alltt}

This will zero the contents of $a$ and make it represent an integer equal to the value of $b$.  Note that this
function has a return type of \textbf{void}.  It cannot cause an error so it is safe to assume the function
succeeded.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* set the number to 5 */
   mp_set(&number, 5);

   /* we're done with it. */ 
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

\subsection{Long Constants}

To set a constant that is the size of an ISO C ``unsigned long'' and larger than a single digit the following function 
can be used.

\index{mp\_set\_int}
\begin{alltt}
int mp_set_int (mp_int * a, unsigned long b);
\end{alltt}

This will assign the value of the 32-bit variable $b$ to the mp\_int $a$.  Unlike mp\_set() this function will always
accept a 32-bit input regardless of the size of a single digit.  However, since the value may span several digits 
this function can fail if it runs out of heap memory.

To get the ``unsigned long'' copy of an mp\_int the following function can be used.

\index{mp\_get\_int}
\begin{alltt}
unsigned long mp_get_int (mp_int * a);
\end{alltt}

This will return the 32 least significant bits of the mp\_int $a$.  

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* set the number to 654321 (note this is bigger than 127) */
   if ((result = mp_set_int(&number, 654321)) != MP_OKAY) \{
      printf("Error setting the value of the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   printf("number == \%lu", mp_get_int(&number));

   /* we're done with it. */ 
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

This should output the following if the program succeeds.

\begin{alltt}
number == 654321
\end{alltt}

\subsection{Initialize and Setting Constants}
To both initialize and set small constants the following two functions are available.
\index{mp\_init\_set} \index{mp\_init\_set\_int}
\begin{alltt}
int mp_init_set (mp_int * a, mp_digit b);
int mp_init_set_int (mp_int * a, unsigned long b);
\end{alltt}

Both functions work like the previous counterparts except they first mp\_init $a$ before setting the values.  

\begin{alltt}
int main(void)
\{
   mp_int number1, number2;
   int    result;

   /* initialize and set a single digit */
   if ((result = mp_init_set(&number1, 100)) != MP_OKAY) \{
      printf("Error setting number1: \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}             

   /* initialize and set a long */
   if ((result = mp_init_set_int(&number2, 1023)) != MP_OKAY) \{
      printf("Error setting number2: \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* display */
   printf("Number1, Number2 == \%lu, \%lu",
          mp_get_int(&number1), mp_get_int(&number2));

   /* clear */
   mp_clear_multi(&number1, &number2, NULL);

   return EXIT_SUCCESS;
\}
\end{alltt}

If this program succeeds it shall output.
\begin{alltt}
Number1, Number2 == 100, 1023
\end{alltt}

\section{Comparisons}

Comparisons in LibTomMath are always performed in a ``left to right'' fashion.  There are three possible return codes
for any comparison.

\index{MP\_GT} \index{MP\_EQ} \index{MP\_LT}
\begin{figure}[here]
\begin{center}
\begin{tabular}{|c|c|}
\hline \textbf{Result Code} & \textbf{Meaning} \\
\hline MP\_GT & $a > b$ \\
\hline MP\_EQ & $a = b$ \\
\hline MP\_LT & $a < b$ \\
\hline
\end{tabular}
\end{center}
\caption{Comparison Codes for $a, b$}
\label{fig:CMP}
\end{figure}

In figure \ref{fig:CMP} two integers $a$ and $b$ are being compared.  In this case $a$ is said to be ``to the left'' of 
$b$.  

\subsection{Unsigned comparison}

An unsigned comparison considers only the digits themselves and not the associated \textit{sign} flag of the 
mp\_int structures.  This is analogous to an absolute comparison.  The function mp\_cmp\_mag() will compare two
mp\_int variables based on their digits only. 

\index{mp\_cmp\_mag}
\begin{alltt}
int mp_cmp_mag(mp_int * a, mp_int * b);
\end{alltt}
This will compare $a$ to $b$ placing $a$ to the left of $b$.  This function cannot fail and will return one of the
three compare codes listed in figure \ref{fig:CMP}.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number1, number2;
   int result;

   if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{
      printf("Error initializing the numbers.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* set the number1 to 5 */
   mp_set(&number1, 5);
  
   /* set the number2 to -6 */
   mp_set(&number2, 6);
   if ((result = mp_neg(&number2, &number2)) != MP_OKAY) \{
      printf("Error negating number2.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   switch(mp_cmp_mag(&number1, &number2)) \{
       case MP_GT:  printf("|number1| > |number2|"); break;
       case MP_EQ:  printf("|number1| = |number2|"); break;
       case MP_LT:  printf("|number1| < |number2|"); break;
   \}

   /* we're done with it. */ 
   mp_clear_multi(&number1, &number2, NULL);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

If this program\footnote{This function uses the mp\_neg() function which is discussed in section \ref{sec:NEG}.} completes 
successfully it should print the following.

\begin{alltt}
|number1| < |number2|
\end{alltt}

This is because $\vert -6 \vert = 6$ and obviously $5 < 6$.

\subsection{Signed comparison}

To compare two mp\_int variables based on their signed value the mp\_cmp() function is provided.

\index{mp\_cmp}
\begin{alltt}
int mp_cmp(mp_int * a, mp_int * b);
\end{alltt}

This will compare $a$ to the left of $b$.  It will first compare the signs of the two mp\_int variables.  If they
differ it will return immediately based on their signs.  If the signs are equal then it will compare the digits
individually.  This function will return one of the compare conditions codes listed in figure \ref{fig:CMP}.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number1, number2;
   int result;

   if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{
      printf("Error initializing the numbers.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* set the number1 to 5 */
   mp_set(&number1, 5);
  
   /* set the number2 to -6 */
   mp_set(&number2, 6);
   if ((result = mp_neg(&number2, &number2)) != MP_OKAY) \{
      printf("Error negating number2.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   switch(mp_cmp(&number1, &number2)) \{
       case MP_GT:  printf("number1 > number2"); break;
       case MP_EQ:  printf("number1 = number2"); break;
       case MP_LT:  printf("number1 < number2"); break;
   \}

   /* we're done with it. */ 
   mp_clear_multi(&number1, &number2, NULL);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

If this program\footnote{This function uses the mp\_neg() function which is discussed in section \ref{sec:NEG}.} completes 
successfully it should print the following.

\begin{alltt}
number1 > number2
\end{alltt}

\subsection{Single Digit}

To compare a single digit against an mp\_int the following function has been provided.

\index{mp\_cmp\_d}
\begin{alltt}
int mp_cmp_d(mp_int * a, mp_digit b);
\end{alltt}

This will compare $a$ to the left of $b$ using a signed comparison.  Note that it will always treat $b$ as 
positive.  This function is rather handy when you have to compare against small values such as $1$ (which often
comes up in cryptography).  The function cannot fail and will return one of the tree compare condition codes
listed in figure \ref{fig:CMP}.


\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* set the number to 5 */
   mp_set(&number, 5);

   switch(mp_cmp_d(&number, 7)) \{
       case MP_GT:  printf("number > 7"); break;
       case MP_EQ:  printf("number = 7"); break;
       case MP_LT:  printf("number < 7"); break;
   \}

   /* we're done with it. */ 
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

If this program functions properly it will print out the following.

\begin{alltt}
number < 7
\end{alltt}

\section{Logical Operations}

Logical operations are operations that can be performed either with simple shifts or boolean operators such as
AND, XOR and OR directly.  These operations are very quick.

\subsection{Multiplication by two}

Multiplications and divisions by any power of two can be performed with quick logical shifts either left or
right depending on the operation.  

When multiplying or dividing by two a special case routine can be used which are as follows.
\index{mp\_mul\_2} \index{mp\_div\_2}
\begin{alltt}
int mp_mul_2(mp_int * a, mp_int * b);
int mp_div_2(mp_int * a, mp_int * b);
\end{alltt}

The former will assign twice $a$ to $b$ while the latter will assign half $a$ to $b$.  These functions are fast
since the shift counts and maskes are hardcoded into the routines.

\begin{small} \begin{alltt}
int main(void)
\{
   mp_int number;
   int result;

   if ((result = mp_init(&number)) != MP_OKAY) \{
      printf("Error initializing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   /* set the number to 5 */
   mp_set(&number, 5);

   /* multiply by two */
   if ((result = mp\_mul\_2(&number, &number)) != MP_OKAY) \{
      printf("Error multiplying the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
   switch(mp_cmp_d(&number, 7)) \{
       case MP_GT:  printf("2*number > 7"); break;
       case MP_EQ:  printf("2*number = 7"); break;
       case MP_LT:  printf("2*number < 7"); break;
   \}

   /* now divide by two */
   if ((result = mp\_div\_2(&number, &number)) != MP_OKAY) \{
      printf("Error dividing the number.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
   switch(mp_cmp_d(&number, 7)) \{
       case MP_GT:  printf("2*number/2 > 7"); break;
       case MP_EQ:  printf("2*number/2 = 7"); break;
       case MP_LT:  printf("2*number/2 < 7"); break;
   \}

   /* we're done with it. */ 
   mp_clear(&number);

   return EXIT_SUCCESS;
\}
\end{alltt} \end{small}

If this program is successful it will print out the following text.

\begin{alltt}
2*number > 7
2*number/2 < 7
\end{alltt}

Since $10 > 7$ and $5 < 7$.  To multiply by a power of two the following function can be used.

\index{mp\_mul\_2d}
\begin{alltt}
int mp_mul_2d(mp_int * a, int b, mp_int * c);
\end{alltt}

This will multiply $a$ by $2^b$ and store the result in ``c''.  If the value of $b$ is less than or equal to 
zero the function will copy $a$ to ``c'' without performing any further actions.  

To divide by a power of two use the following.

\index{mp\_div\_2d}
\begin{alltt}
int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d);
\end{alltt}
Which will divide $a$ by $2^b$, store the quotient in ``c'' and the remainder in ``d'.  If $b \le 0$ then the
function simply copies $a$ over to ``c'' and zeroes $d$.  The variable $d$ may be passed as a \textbf{NULL}
value to signal that the remainder is not desired.

\subsection{Polynomial Basis Operations}

Strictly speaking the organization of the integers within the mp\_int structures is what is known as a 
``polynomial basis''.  This simply means a field element is stored by divisions of a radix.  For example, if
$f(x) = \sum_{i=0}^{k} y_ix^k$ for any vector $\vec y$ then the array of digits in $\vec y$ are said to be 
the polynomial basis representation of $z$ if $f(\beta) = z$ for a given radix $\beta$.  

To multiply by the polynomial $g(x) = x$ all you have todo is shift the digits of the basis left one place.  The
following function provides this operation.

\index{mp\_lshd}
\begin{alltt}
int mp_lshd (mp_int * a, int b);
\end{alltt}

This will multiply $a$ in place by $x^b$ which is equivalent to shifting the digits left $b$ places and inserting zeroes
in the least significant digits.  Similarly to divide by a power of $x$ the following function is provided.

\index{mp\_rshd}
\begin{alltt}
void mp_rshd (mp_int * a, int b)
\end{alltt}
This will divide $a$ in place by $x^b$ and discard the remainder.  This function cannot fail as it performs the operations
in place and no new digits are required to complete it.

\subsection{AND, OR and XOR Operations}

While AND, OR and XOR operations are not typical ``bignum functions'' they can be useful in several instances.  The
three functions are prototyped as follows.

\index{mp\_or} \index{mp\_and} \index{mp\_xor}
\begin{alltt}
int mp_or  (mp_int * a, mp_int * b, mp_int * c);
int mp_and (mp_int * a, mp_int * b, mp_int * c);
int mp_xor (mp_int * a, mp_int * b, mp_int * c);
\end{alltt}

Which compute $c = a \odot b$ where $\odot$ is one of OR, AND or XOR.  

\section{Addition and Subtraction}

To compute an addition or subtraction the following two functions can be used.

\index{mp\_add} \index{mp\_sub}
\begin{alltt}
int mp_add (mp_int * a, mp_int * b, mp_int * c);
int mp_sub (mp_int * a, mp_int * b, mp_int * c)
\end{alltt}

Which perform $c = a \odot b$ where $\odot$ is one of signed addition or subtraction.  The operations are fully sign
aware.

\section{Sign Manipulation}
\subsection{Negation}
\label{sec:NEG}
Simple integer negation can be performed with the following.

\index{mp\_neg}
\begin{alltt}
int mp_neg (mp_int * a, mp_int * b);
\end{alltt}

Which assigns $-a$ to $b$.  

\subsection{Absolute}
Simple integer absolutes can be performed with the following.

\index{mp\_neg}
\begin{alltt}
int mp_abs (mp_int * a, mp_int * b);
\end{alltt}

Which assigns $\vert a \vert$ to $b$.  

\section{Integer Division and Remainder}
To perform a complete and general integer division with remainder use the following function.

\index{mp\_div}
\begin{alltt}
int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d);
\end{alltt}
                                                        
This divides $a$ by $b$ and stores the quotient in $c$ and $d$.  The signed quotient is computed such that 
$bc + d = a$.  Note that either of $c$ or $d$ can be set to \textbf{NULL} if their value is not required.  If 
$b$ is zero the function returns \textbf{MP\_VAL}.  


\chapter{Multiplication and Squaring}
\section{Multiplication}
A full signed integer multiplication can be performed with the following.
\index{mp\_mul}
\begin{alltt}
int mp_mul (mp_int * a, mp_int * b, mp_int * c);
\end{alltt}
Which assigns the full signed product $ab$ to $c$.  This function actually breaks into one of four cases which are 
specific multiplication routines optimized for given parameters.  First there are the Toom-Cook multiplications which
should only be used with very large inputs.  This is followed by the Karatsuba multiplications which are for moderate
sized inputs.  Then followed by the Comba and baseline multipliers.

Fortunately for the developer you don't really need to know this unless you really want to fine tune the system.  mp\_mul()
will determine on its own\footnote{Some tweaking may be required.} what routine to use automatically when it is called.

\begin{alltt}
int main(void)
\{
   mp_int number1, number2;
   int result;

   /* Initialize the numbers */
   if ((result = mp_init_multi(&number1, 
                               &number2, NULL)) != MP_OKAY) \{
      printf("Error initializing the numbers.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* set the terms */
   if ((result = mp_set_int(&number, 257)) != MP_OKAY) \{
      printf("Error setting number1.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
 
   if ((result = mp_set_int(&number2, 1023)) != MP_OKAY) \{
      printf("Error setting number2.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* multiply them */
   if ((result = mp_mul(&number1, &number2,
                        &number1)) != MP_OKAY) \{
      printf("Error multiplying terms.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* display */
   printf("number1 * number2 == \%lu", mp_get_int(&number1));

   /* free terms and return */
   mp_clear_multi(&number1, &number2, NULL);

   return EXIT_SUCCESS;
\}
\end{alltt}   

If this program succeeds it shall output the following.

\begin{alltt}
number1 * number2 == 262911
\end{alltt}

\section{Squaring}
Since squaring can be performed faster than multiplication it is performed it's own function instead of just using
mp\_mul().

\index{mp\_sqr}
\begin{alltt}
int mp_sqr (mp_int * a, mp_int * b);
\end{alltt}

Will square $a$ and store it in $b$.  Like the case of multiplication there are four different squaring
algorithms all which can be called from mp\_sqr().  It is ideal to use mp\_sqr over mp\_mul when squaring terms because
of the speed difference.  

\section{Tuning Polynomial Basis Routines}

Both of the Toom-Cook and Karatsuba multiplication algorithms are faster than the traditional $O(n^2)$ approach that
the Comba and baseline algorithms use.  At $O(n^{1.464973})$ and $O(n^{1.584962})$ running times respectively they require 
considerably less work.  For example, a 10000-digit multiplication would take roughly 724,000 single precision
multiplications with Toom-Cook or 100,000,000 single precision multiplications with the standard Comba (a factor
of 138).

So why not always use Karatsuba or Toom-Cook?   The simple answer is that they have so much overhead that they're not
actually faster than Comba until you hit distinct  ``cutoff'' points.  For Karatsuba with the default configuration, 
GCC 3.3.1 and an Athlon XP processor the cutoff point is roughly 110 digits (about 70 for the Intel P4).  That is, at 
110 digits Karatsuba and Comba multiplications just about break even and for 110+ digits Karatsuba is faster.

Toom-Cook has incredible overhead and is probably only useful for very large inputs.  So far no known cutoff points 
exist and for the most part I just set the cutoff points very high to make sure they're not called.

A demo program in the ``etc/'' directory of the project called ``tune.c'' can be used to find the cutoff points.  This
can be built with GCC as follows

\begin{alltt}
make XXX
\end{alltt}
Where ``XXX'' is one of the following entries from the table \ref{fig:tuning}.

\begin{figure}[here]
\begin{center}
\begin{small}
\begin{tabular}{|l|l|}
\hline \textbf{Value of XXX} & \textbf{Meaning} \\
\hline tune & Builds portable tuning application \\
\hline tune86 & Builds x86 (pentium and up) program for COFF \\
\hline tune86c & Builds x86 program for Cygwin \\
\hline tune86l & Builds x86 program for Linux (ELF format) \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Build Names for Tuning Programs}
\label{fig:tuning}
\end{figure}

When the program is running it will output a series of measurements for different cutoff points.  It will first find
good Karatsuba squaring and multiplication points.  Then it proceeds to find Toom-Cook points.  Note that the Toom-Cook
tuning takes a very long time as the cutoff points are likely to be very high.

\chapter{Modular Reduction}

Modular reduction is process of taking the remainder of one quantity divided by another.  Expressed 
as (\ref{eqn:mod}) the modular reduction is equivalent to the remainder of $b$ divided by $c$.  

\begin{equation}
a \equiv b \mbox{ (mod }c\mbox{)}
\label{eqn:mod}
\end{equation}

Of particular interest to cryptography are reductions where $b$ is limited to the range $0 \le b < c^2$ since particularly 
fast reduction algorithms can be written for the limited range.  

Note that one of the four optimized reduction algorithms are automatically chosen in the modular exponentiation
algorithm mp\_exptmod when an appropriate modulus is detected.  

\section{Straight Division}
In order to effect an arbitrary modular reduction the following algorithm is provided.

\index{mp\_mod}
\begin{alltt}
int mp_mod(mp_int *a, mp_int *b, mp_int *c);
\end{alltt}

This reduces $a$ modulo $b$ and stores the result in $c$.  The sign of $c$ shall agree with the sign 
of $b$.  This algorithm accepts an input $a$ of any range and is not limited by $0 \le a < b^2$.

\section{Barrett Reduction}

Barrett reduction is a generic optimized reduction algorithm that requires pre--computation to achieve
a decent speedup over straight division.  First a $\mu$ value must be precomputed with the following function.

\index{mp\_reduce\_setup}
\begin{alltt}
int mp_reduce_setup(mp_int *a, mp_int *b);
\end{alltt}

Given a modulus in $b$ this produces the required $\mu$ value in $a$.  For any given modulus this only has to
be computed once.  Modular reduction can now be performed with the following.

\index{mp\_reduce}
\begin{alltt}
int mp_reduce(mp_int *a, mp_int *b, mp_int *c);
\end{alltt}

This will reduce $a$ in place modulo $b$ with the precomputed $\mu$ value in $c$.  $a$ must be in the range
$0 \le a < b^2$.

\begin{alltt}
int main(void)
\{
   mp_int   a, b, c, mu;
   int      result;

   /* initialize a,b to desired values, mp_init mu, 
    * c and set c to 1...we want to compute a^3 mod b 
    */

   /* get mu value */
   if ((result = mp_reduce_setup(&mu, b)) != MP_OKAY) \{
      printf("Error getting mu.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* square a to get c = a^2 */
   if ((result = mp_sqr(&a, &c)) != MP_OKAY) \{
      printf("Error squaring.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* now reduce `c' modulo b */
   if ((result = mp_reduce(&c, &b, &mu)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
   
   /* multiply a to get c = a^3 */
   if ((result = mp_mul(&a, &c, &c)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* now reduce `c' modulo b  */
   if ((result = mp_reduce(&c, &b, &mu)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
  
   /* c now equals a^3 mod b */

   return EXIT_SUCCESS;
\}
\end{alltt} 

This program will calculate $a^3 \mbox{ mod }b$ if all the functions succeed.  

\section{Montgomery Reduction}

Montgomery is a specialized reduction algorithm for any odd moduli.  Like Barrett reduction a pre--computation
step is required.  This is accomplished with the following.

\index{mp\_montgomery\_setup}
\begin{alltt}
int mp_montgomery_setup(mp_int *a, mp_digit *mp);
\end{alltt}

For the given odd moduli $a$ the precomputation value is placed in $mp$.  The reduction is computed with the 
following.

\index{mp\_montgomery\_reduce}
\begin{alltt}
int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);
\end{alltt}
This reduces $a$ in place modulo $m$ with the pre--computed value $mp$.   $a$ must be in the range
$0 \le a < b^2$.

Montgomery reduction is faster than Barrett reduction for moduli smaller than the ``comba'' limit.  With the default
setup for instance, the limit is $127$ digits ($3556$--bits).   Note that this function is not limited to
$127$ digits just that it falls back to a baseline algorithm after that point.  

An important observation is that this reduction does not return $a \mbox{ mod }m$ but $aR^{-1} \mbox{ mod }m$ 
where $R = \beta^n$, $n$ is the n number of digits in $m$ and $\beta$ is radix used (default is $2^{28}$).  

To quickly calculate $R$ the following function was provided.

\index{mp\_montgomery\_calc\_normalization}
\begin{alltt}
int mp_montgomery_calc_normalization(mp_int *a, mp_int *b);
\end{alltt}
Which calculates $a = R$ for the odd moduli $b$ without using multiplication or division.  

The normal modus operandi for Montgomery reductions is to normalize the integers before entering the system.  For
example, to calculate $a^3 \mbox { mod }b$ using Montgomery reduction the value of $a$ can be normalized by
multiplying it by $R$.  Consider the following code snippet.

\begin{alltt}
int main(void)
\{
   mp_int   a, b, c, R;
   mp_digit mp;
   int      result;

   /* initialize a,b to desired values, 
    * mp_init R, c and set c to 1.... 
    */

   /* get normalization */
   if ((result = mp_montgomery_calc_normalization(&R, b)) != MP_OKAY) \{
      printf("Error getting norm.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* get mp value */
   if ((result = mp_montgomery_setup(&c, &mp)) != MP_OKAY) \{
      printf("Error setting up montgomery.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* normalize `a' so now a is equal to aR */
   if ((result = mp_mulmod(&a, &R, &b, &a)) != MP_OKAY) \{
      printf("Error computing aR.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* square a to get c = a^2R^2 */
   if ((result = mp_sqr(&a, &c)) != MP_OKAY) \{
      printf("Error squaring.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* now reduce `c' back down to c = a^2R^2 * R^-1 == a^2R */
   if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
   
   /* multiply a to get c = a^3R^2 */
   if ((result = mp_mul(&a, &c, &c)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* now reduce `c' back down to c = a^3R^2 * R^-1 == a^3R */
   if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}
   
   /* now reduce (again) `c' back down to c = a^3R * R^-1 == a^3 */
   if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{
      printf("Error reducing.  \%s", 
             mp_error_to_string(result));
      return EXIT_FAILURE;
   \}

   /* c now equals a^3 mod b */

   return EXIT_SUCCESS;
\}
\end{alltt} 

This particular example does not look too efficient but it demonstrates the point of the algorithm.  By 
normalizing the inputs the reduced results are always of the form $aR$ for some variable $a$.  This allows
a single final reduction to correct for the normalization and the fast reduction used within the algorithm.

For more details consider examining the file \textit{bn\_mp\_exptmod\_fast.c}.

\section{Restricted Dimminished Radix}

``Dimminished Radix'' reduction refers to reduction with respect to moduli that are ameniable to simple
digit shifting and small multiplications.  In this case the ``restricted'' variant refers to moduli of the
form $\beta^k - p$ for some $k \ge 0$ and $0 < p < \beta$ where $\beta$ is the radix (default to $2^{28}$).  

As in the case of Montgomery reduction there is a pre--computation phase required for a given modulus.

\index{mp\_dr\_setup}
\begin{alltt}
void mp_dr_setup(mp_int *a, mp_digit *d);
\end{alltt}

This computes the value required for the modulus $a$ and stores it in $d$.  This function cannot fail
and does not return any error codes.  After the pre--computation a reduction can be performed with the
following.

\index{mp\_dr\_reduce}
\begin{alltt}
int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp);
\end{alltt}

This reduces $a$ in place modulo $b$ with the pre--computed value $mp$.  $b$ must be of a restricted
dimminished radix form and $a$ must be in the range $0 \le a < b^2$.  Dimminished radix reductions are 
much faster than both Barrett and Montgomery reductions as they have a much lower asymtotic running time.  

Since the moduli are restricted this algorithm is not particularly useful for something like Rabin, RSA or
BBS cryptographic purposes.  This reduction algorithm is useful for Diffie-Hellman and ECC where fixed
primes are acceptable.  

Note that unlike Montgomery reduction there is no normalization process.  The result of this function is
equal to the correct residue.

\section{Unrestricted Dimminshed Radix}

Unrestricted reductions work much like the restricted counterparts except in this case the moduli is of the 
form $2^k - p$ for $0 < p < \beta$.  In this sense the unrestricted reductions are more flexible as they 
can be applied to a wider range of numbers.  

\index{mp\_reduce\_2k\_setup}
\begin{alltt}
int mp_reduce_2k_setup(mp_int *a, mp_digit *d);
\end{alltt}

This will compute the required $d$ value for the given moduli $a$.  

\index{mp\_reduce\_2k}
\begin{alltt}
int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d);
\end{alltt}

This will reduce $a$ in place modulo $n$ with the pre--computed value $d$.  From my experience this routine is 
slower than mp\_dr\_reduce but faster for most moduli sizes than the Montgomery reduction.  

\chapter{Exponentiation}
\section{Single Digit Exponentiation}
\index{mp\_expt\_d}
\begin{alltt}
int mp_expt_d (mp_int * a, mp_digit b, mp_int * c)
\end{alltt}
This computes $c = a^b$ using a simple binary left-to-right algorithm.  It is faster than repeated multiplications by 
$a$ for all values of $b$ greater than three.  

\section{Modular Exponentiation}
\index{mp\_exptmod}
\begin{alltt}
int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y)
\end{alltt}
This computes $Y \equiv G^X \mbox{ (mod }P\mbox{)}$ using a variable width sliding window algorithm.  This function
will automatically detect the fastest modular reduction technique to use during the operation.  For negative values of 
$X$ the operation is performed as $Y \equiv (G^{-1} \mbox{ mod }P)^{\vert X \vert} \mbox{ (mod }P\mbox{)}$ provided that 
$gcd(G, P) = 1$.

This function is actually a shell around the two internal exponentiation functions.  This routine will automatically
detect when Barrett, Montgomery, Restricted and Unrestricted Dimminished Radix based exponentiation can be used.  Generally
moduli of the a ``restricted dimminished radix'' form lead to the fastest modular exponentiations.  Followed by Montgomery
and the other two algorithms.

\section{Root Finding}
\index{mp\_n\_root}
\begin{alltt}
int mp_n_root (mp_int * a, mp_digit b, mp_int * c)
\end{alltt}
This computes $c = a^{1/b}$ such that $c^b \le a$ and $(c+1)^b > a$.  The implementation of this function is not 
ideal for values of $b$ greater than three.  It will work but become very slow.  So unless you are working with very small
numbers (less than 1000 bits) I'd avoid $b > 3$ situations.  Will return a positive root only for even roots and return
a root with the sign of the input for odd roots.  For example, performing $4^{1/2}$ will return $2$ whereas $(-8)^{1/3}$ 
will return $-2$.  

This algorithm uses the ``Newton Approximation'' method and will converge on the correct root fairly quickly.  Since
the algorithm requires raising $a$ to the power of $b$ it is not ideal to attempt to find roots for large
values of $b$.  If particularly large roots are required then a factor method could be used instead.  For example,
$a^{1/16}$ is equivalent to $\left (a^{1/4} \right)^{1/4}$ or simply 
$\left ( \left ( \left ( a^{1/2} \right )^{1/2} \right )^{1/2} \right )^{1/2}$

\chapter{Prime Numbers}
\section{Trial Division}
\index{mp\_prime\_is\_divisible}
\begin{alltt}
int mp_prime_is_divisible (mp_int * a, int *result)
\end{alltt}
This will attempt to evenly divide $a$ by a list of primes\footnote{Default is the first 256 primes.} and store the 
outcome in ``result''.  That is if $result = 0$ then $a$ is not divisible by the primes, otherwise it is.  Note that 
if the function does not return \textbf{MP\_OKAY} the value in ``result'' should be considered undefined\footnote{Currently
the default is to set it to zero first.}.

\section{Fermat Test}
\index{mp\_prime\_fermat}
\begin{alltt}
int mp_prime_fermat (mp_int * a, mp_int * b, int *result)
\end{alltt}
Performs a Fermat primality test to the base $b$.  That is it computes $b^a \mbox{ mod }a$ and tests whether the value is
equal to $b$ or not.  If the values are equal then $a$ is probably prime and $result$ is set to one.  Otherwise $result$
is set to zero.

\section{Miller-Rabin Test}
\index{mp\_prime\_miller\_rabin}
\begin{alltt}
int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result)
\end{alltt}
Performs a Miller-Rabin test to the base $b$ of $a$.  This test is much stronger than the Fermat test and is very hard to
fool (besides with Carmichael numbers).  If $a$ passes the test (therefore is probably prime) $result$ is set to one.  
Otherwise $result$ is set to zero.  

Note that is suggested that you use the Miller-Rabin test instead of the Fermat test since all of the failures of 
Miller-Rabin are a subset of the failures of the Fermat test.

\subsection{Required Number of Tests}
Generally to ensure a number is very likely to be prime you have to perform the Miller-Rabin with at least a half-dozen
or so unique bases.  However, it has been proven that the probability of failure goes down as the size of the input goes up.
This is why a simple function has been provided to help out.

\index{mp\_prime\_rabin\_miller\_trials}
\begin{alltt}
int mp_prime_rabin_miller_trials(int size)
\end{alltt}
This returns the number of trials required for a $2^{-96}$ (or lower) probability of failure for a given ``size'' expressed
in bits.  This comes in handy specially since larger numbers are slower to test.  For example, a 512-bit number would
require ten tests whereas a 1024-bit number would only require four tests. 

You should always still perform a trial division before a Miller-Rabin test though.

\section{Primality Testing}
\index{mp\_prime\_is\_prime}
\begin{alltt}
int mp_prime_is_prime (mp_int * a, int t, int *result)
\end{alltt}
This will perform a trial division followed by $t$ rounds of Miller-Rabin tests on $a$ and store the result in $result$.  
If $a$ passes all of the tests $result$ is set to one, otherwise it is set to zero.  Note that $t$ is bounded by 
$1 \le t < PRIME\_SIZE$ where $PRIME\_SIZE$ is the number of primes in the prime number table (by default this is $256$).

\section{Next Prime}
\index{mp\_prime\_next\_prime}
\begin{alltt}
int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
\end{alltt}
This finds the next prime after $a$ that passes mp\_prime\_is\_prime() with $t$ tests.  Set $bbs\_style$ to one if you 
want only the next prime congruent to $3 \mbox{ mod } 4$, otherwise set it to zero to find any next prime.  

\section{Random Primes}
\index{mp\_prime\_random}
\begin{alltt}
int mp_prime_random(mp_int *a, int t, int size, int bbs, 
                    ltm_prime_callback cb, void *dat)
\end{alltt}
This will find a prime greater than $256^{size}$ which can be ``bbs\_style'' or not depending on $bbs$ and must pass
$t$ rounds of tests.  The ``ltm\_prime\_callback'' is a typedef for 

\begin{alltt}
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);
\end{alltt}

Which is a function that must read $len$ bytes (and return the amount stored) into $dst$.  The $dat$ variable is simply
copied from the original input.  It can be used to pass RNG context data to the callback.  The function 
mp\_prime\_random() is more suitable for generating primes which must be secret (as in the case of RSA) since there 
is no skew on the least significant bits.

\textit{Note:}  As of v0.30 of the LibTomMath library this function has been deprecated.  It is still available
but users are encouraged to use the new mp\_prime\_random\_ex() function instead.

\subsection{Extended Generation}
\index{mp\_prime\_random\_ex}
\begin{alltt}
int mp_prime_random_ex(mp_int *a,    int t, 
                       int     size, int flags, 
                       ltm_prime_callback cb, void *dat);
\end{alltt}
This will generate a prime in $a$ using $t$ tests of the primality testing algorithms.  The variable $size$
specifies the bit length of the prime desired.  The variable $flags$ specifies one of several options available
(see fig. \ref{fig:primeopts}) which can be OR'ed together.  The callback parameters are used as in 
mp\_prime\_random().

\begin{figure}[here]
\begin{center}
\begin{small}
\begin{tabular}{|r|l|}
\hline \textbf{Flag}         & \textbf{Meaning} \\
\hline LTM\_PRIME\_BBS       & Make the prime congruent to $3$ modulo $4$ \\
\hline LTM\_PRIME\_SAFE      & Make a prime $p$ such that $(p - 1)/2$ is also prime. \\
                             & This option implies LTM\_PRIME\_BBS as well. \\
\hline LTM\_PRIME\_2MSB\_OFF & Makes sure that the bit adjacent to the most significant bit \\
                             & Is forced to zero.  \\
\hline LTM\_PRIME\_2MSB\_ON  & Makes sure that the bit adjacent to the most significant bit \\
                             & Is forced to one. \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Primality Generation Options}
\label{fig:primeopts}
\end{figure}

\chapter{Input and Output}
\section{ASCII Conversions}
\subsection{To ASCII}
\index{mp\_toradix}
\begin{alltt}
int mp_toradix (mp_int * a, char *str, int radix);
\end{alltt}
This still store $a$ in ``str'' as a base-``radix'' string of ASCII chars.  This function appends a NUL character
to terminate the string.  Valid values of ``radix'' line in the range $[2, 64]$.  To determine the size (exact) required
by the conversion before storing any data use the following function.

\index{mp\_radix\_size}
\begin{alltt}
int mp_radix_size (mp_int * a, int radix, int *size)
\end{alltt}
This stores in ``size'' the number of characters (including space for the NUL terminator) required.  Upon error this 
function returns an error code and ``size'' will be zero.  

\subsection{From ASCII}
\index{mp\_read\_radix}
\begin{alltt}
int mp_read_radix (mp_int * a, char *str, int radix);
\end{alltt}
This will read the base-``radix'' NUL terminated string from ``str'' into $a$.  It will stop reading when it reads a
character it does not recognize (which happens to include th NUL char... imagine that...).  A single leading $-$ sign
can be used to denote a negative number.

\section{Binary Conversions}

Converting an mp\_int to and from binary is another keen idea.

\index{mp\_unsigned\_bin\_size}
\begin{alltt}
int mp_unsigned_bin_size(mp_int *a);
\end{alltt}

This will return the number of bytes (octets) required to store the unsigned copy of the integer $a$.

\index{mp\_to\_unsigned\_bin}
\begin{alltt}
int mp_to_unsigned_bin(mp_int *a, unsigned char *b);
\end{alltt}
This will store $a$ into the buffer $b$ in big--endian format.  Fortunately this is exactly what DER (or is it ASN?)
requires.  It does not store the sign of the integer.

\index{mp\_read\_unsigned\_bin}
\begin{alltt}
int mp_read_unsigned_bin(mp_int *a, unsigned char *b, int c);
\end{alltt}
This will read in an unsigned big--endian array of bytes (octets) from $b$ of length $c$ into $a$.  The resulting
integer $a$ will always be positive.

For those who acknowledge the existence of negative numbers (heretic!) there are ``signed'' versions of the
previous functions.

\begin{alltt}
int mp_signed_bin_size(mp_int *a);
int mp_read_signed_bin(mp_int *a, unsigned char *b, int c);
int mp_to_signed_bin(mp_int *a, unsigned char *b);
\end{alltt}
They operate essentially the same as the unsigned copies except they prefix the data with zero or non--zero
byte depending on the sign.  If the sign is zpos (e.g. not negative) the prefix is zero, otherwise the prefix
is non--zero.  

\chapter{Algebraic Functions}
\section{Extended Euclidean Algorithm}
\index{mp\_exteuclid}
\begin{alltt}
int mp_exteuclid(mp_int *a, mp_int *b, 
                 mp_int *U1, mp_int *U2, mp_int *U3);
\end{alltt}

This finds the triple U1/U2/U3 using the Extended Euclidean algorithm such that the following equation holds.

\begin{equation}
a \cdot U1 + b \cdot U2 = U3
\end{equation}

Any of the U1/U2/U3 paramters can be set to \textbf{NULL} if they are not desired.  

\section{Greatest Common Divisor}
\index{mp\_gcd}
\begin{alltt}
int mp_gcd (mp_int * a, mp_int * b, mp_int * c)
\end{alltt}
This will compute the greatest common divisor of $a$ and $b$ and store it in $c$.

\section{Least Common Multiple}
\index{mp\_lcm}
\begin{alltt}
int mp_lcm (mp_int * a, mp_int * b, mp_int * c)
\end{alltt}
This will compute the least common multiple of $a$ and $b$ and store it in $c$.

\section{Jacobi Symbol}
\index{mp\_jacobi}
\begin{alltt}
int mp_jacobi (mp_int * a, mp_int * p, int *c)
\end{alltt}
This will compute the Jacobi symbol for $a$ with respect to $p$.  If $p$ is prime this essentially computes the Legendre
symbol.  The result is stored in $c$ and can take on one of three values $\lbrace -1, 0, 1 \rbrace$.  If $p$ is prime
then the result will be $-1$ when $a$ is not a quadratic residue modulo $p$.  The result will be $0$ if $a$ divides $p$
and the result will be $1$ if $a$ is a quadratic residue modulo $p$.  

\section{Modular Inverse}
\index{mp\_invmod}
\begin{alltt}
int mp_invmod (mp_int * a, mp_int * b, mp_int * c)
\end{alltt}
Computes the multiplicative inverse of $a$ modulo $b$ and stores the result in $c$ such that $ac \equiv 1 \mbox{ (mod }b\mbox{)}$.

\section{Single Digit Functions}

For those using small numbers (\textit{snicker snicker}) there are several ``helper'' functions

\index{mp\_add\_d} \index{mp\_sub\_d} \index{mp\_mul\_d} \index{mp\_div\_d} \index{mp\_mod\_d}
\begin{alltt}
int mp_add_d(mp_int *a, mp_digit b, mp_int *c);
int mp_sub_d(mp_int *a, mp_digit b, mp_int *c);
int mp_mul_d(mp_int *a, mp_digit b, mp_int *c);
int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d);
int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c);
\end{alltt}

These work like the full mp\_int capable variants except the second parameter $b$ is a mp\_digit.  These
functions fairly handy if you have to work with relatively small numbers since you will not have to allocate
an entire mp\_int to store a number like $1$ or $2$.

\input{bn.ind}

\end{document}

Added libtommath/bn_error.c.































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
#include <tommath.h>
#ifdef BN_ERROR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

static const struct {
     int code;
     char *msg;
} msgs[] = {
     { MP_OKAY, "Successful" },
     { MP_MEM,  "Out of heap" },
     { MP_VAL,  "Value out of range" }
};

/* return a char * string for a given code */
char *mp_error_to_string(int code)
{
   int x;

   /* scan the lookup table for the given message */
   for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) {
       if (msgs[x].code == code) {
          return msgs[x].msg;
       }
   }

   /* generic reply for invalid code */
   return "Invalid error code";
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_error.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_fast_mp_invmod.c.









































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
#include <tommath.h>
#ifdef BN_FAST_MP_INVMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes the modular inverse via binary extended euclidean algorithm, 
 * that is c = 1/a mod b 
 *
 * Based on slow invmod except this is optimized for the case where b is 
 * odd as per HAC Note 14.64 on pp. 610
 */
int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  x, y, u, v, B, D;
  int     res, neg;

  /* 2. [modified] b must be odd   */
  if (mp_iseven (b) == 1) {
    return MP_VAL;
  }

  /* init all our temps */
  if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) {
     return res;
  }

  /* x == modulus, y == value to invert */
  if ((res = mp_copy (b, &x)) != MP_OKAY) {
    goto LBL_ERR;
  }

  /* we need y = |a| */
  if ((res = mp_mod (a, b, &y)) != MP_OKAY) {
    goto LBL_ERR;
  }

  /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
  if ((res = mp_copy (&x, &u)) != MP_OKAY) {
    goto LBL_ERR;
  }
  if ((res = mp_copy (&y, &v)) != MP_OKAY) {
    goto LBL_ERR;
  }
  mp_set (&D, 1);

top:
  /* 4.  while u is even do */
  while (mp_iseven (&u) == 1) {
    /* 4.1 u = u/2 */
    if ((res = mp_div_2 (&u, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 4.2 if B is odd then */
    if (mp_isodd (&B) == 1) {
      if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) {
        goto LBL_ERR;
      }
    }
    /* B = B/2 */
    if ((res = mp_div_2 (&B, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 5.  while v is even do */
  while (mp_iseven (&v) == 1) {
    /* 5.1 v = v/2 */
    if ((res = mp_div_2 (&v, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 5.2 if D is odd then */
    if (mp_isodd (&D) == 1) {
      /* D = (D-x)/2 */
      if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) {
        goto LBL_ERR;
      }
    }
    /* D = D/2 */
    if ((res = mp_div_2 (&D, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 6.  if u >= v then */
  if (mp_cmp (&u, &v) != MP_LT) {
    /* u = u - v, B = B - D */
    if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  } else {
    /* v - v - u, D = D - B */
    if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* if not zero goto step 4 */
  if (mp_iszero (&u) == 0) {
    goto top;
  }

  /* now a = C, b = D, gcd == g*v */

  /* if v != 1 then there is no inverse */
  if (mp_cmp_d (&v, 1) != MP_EQ) {
    res = MP_VAL;
    goto LBL_ERR;
  }

  /* b is now the inverse */
  neg = a->sign;
  while (D.sign == MP_NEG) {
    if ((res = mp_add (&D, b, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }
  mp_exch (&D, c);
  c->sign = neg;
  res = MP_OKAY;

LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_mp_invmod.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_fast_mp_montgomery_reduce.c.

























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
#include <tommath.h>
#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes xR**-1 == x (mod N) via Montgomery Reduction
 *
 * This is an optimized implementation of montgomery_reduce
 * which uses the comba method to quickly calculate the columns of the
 * reduction.
 *
 * Based on Algorithm 14.32 on pp.601 of HAC.
*/
int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho)
{
  int     ix, res, olduse;
  mp_word W[MP_WARRAY];

  /* get old used count */
  olduse = x->used;

  /* grow a as required */
  if (x->alloc < n->used + 1) {
    if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) {
      return res;
    }
  }

  /* first we have to get the digits of the input into
   * an array of double precision words W[...]
   */
  {
    register mp_word *_W;
    register mp_digit *tmpx;

    /* alias for the W[] array */
    _W   = W;

    /* alias for the digits of  x*/
    tmpx = x->dp;

    /* copy the digits of a into W[0..a->used-1] */
    for (ix = 0; ix < x->used; ix++) {
      *_W++ = *tmpx++;
    }

    /* zero the high words of W[a->used..m->used*2] */
    for (; ix < n->used * 2 + 1; ix++) {
      *_W++ = 0;
    }
  }

  /* now we proceed to zero successive digits
   * from the least significant upwards
   */
  for (ix = 0; ix < n->used; ix++) {
    /* mu = ai * m' mod b
     *
     * We avoid a double precision multiplication (which isn't required)
     * by casting the value down to a mp_digit.  Note this requires
     * that W[ix-1] have  the carry cleared (see after the inner loop)
     */
    register mp_digit mu;
    mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK);

    /* a = a + mu * m * b**i
     *
     * This is computed in place and on the fly.  The multiplication
     * by b**i is handled by offseting which columns the results
     * are added to.
     *
     * Note the comba method normally doesn't handle carries in the
     * inner loop In this case we fix the carry from the previous
     * column since the Montgomery reduction requires digits of the
     * result (so far) [see above] to work.  This is
     * handled by fixing up one carry after the inner loop.  The
     * carry fixups are done in order so after these loops the
     * first m->used words of W[] have the carries fixed
     */
    {
      register int iy;
      register mp_digit *tmpn;
      register mp_word *_W;

      /* alias for the digits of the modulus */
      tmpn = n->dp;

      /* Alias for the columns set by an offset of ix */
      _W = W + ix;

      /* inner loop */
      for (iy = 0; iy < n->used; iy++) {
          *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++);
      }
    }

    /* now fix carry for next digit, W[ix+1] */
    W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT);
  }

  /* now we have to propagate the carries and
   * shift the words downward [all those least
   * significant digits we zeroed].
   */
  {
    register mp_digit *tmpx;
    register mp_word *_W, *_W1;

    /* nox fix rest of carries */

    /* alias for current word */
    _W1 = W + ix;

    /* alias for next word, where the carry goes */
    _W = W + ++ix;

    for (; ix <= n->used * 2 + 1; ix++) {
      *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT);
    }

    /* copy out, A = A/b**n
     *
     * The result is A/b**n but instead of converting from an
     * array of mp_word to mp_digit than calling mp_rshd
     * we just copy them in the right order
     */

    /* alias for destination word */
    tmpx = x->dp;

    /* alias for shifted double precision result */
    _W = W + n->used;

    for (ix = 0; ix < n->used + 1; ix++) {
      *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK));
    }

    /* zero oldused digits, if the input a was larger than
     * m->used+1 we'll have to clear the digits
     */
    for (; ix < olduse; ix++) {
      *tmpx++ = 0;
    }
  }

  /* set the max used and clamp */
  x->used = n->used + 1;
  mp_clamp (x);

  /* if A >= m then A = A - m */
  if (mp_cmp_mag (x, n) != MP_LT) {
    return s_mp_sub (x, n, x);
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_fast_s_mp_mul_digs.c.





























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#include <tommath.h>
#ifdef BN_FAST_S_MP_MUL_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Fast (comba) multiplier
 *
 * This is the fast column-array [comba] multiplier.  It is 
 * designed to compute the columns of the product first 
 * then handle the carries afterwards.  This has the effect 
 * of making the nested loops that compute the columns very
 * simple and schedulable on super-scalar processors.
 *
 * This has been modified to produce a variable number of 
 * digits of output so if say only a half-product is required 
 * you don't have to compute the upper half (a feature 
 * required for fast Barrett reduction).
 *
 * Based on Algorithm 14.12 on pp.595 of HAC.
 *
 */
int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  int     olduse, res, pa, ix, iz;
  mp_digit W[MP_WARRAY];
  register mp_word  _W;

  /* grow the destination as required */
  if (c->alloc < digs) {
    if ((res = mp_grow (c, digs)) != MP_OKAY) {
      return res;
    }
  }

  /* number of output digits to produce */
  pa = MIN(digs, a->used + b->used);

  /* clear the carry */
  _W = 0;
  for (ix = 0; ix < pa; ix++) { 
      int      tx, ty;
      int      iy;
      mp_digit *tmpx, *tmpy;

      /* get offsets into the two bignums */
      ty = MIN(b->used-1, ix);
      tx = ix - ty;

      /* setup temp aliases */
      tmpx = a->dp + tx;
      tmpy = b->dp + ty;

      /* this is the number of times the loop will iterrate, essentially 
         while (tx++ < a->used && ty-- >= 0) { ... }
       */
      iy = MIN(a->used-tx, ty+1);

      /* execute loop */
      for (iz = 0; iz < iy; ++iz) {
         _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);

      }

      /* store term */
      W[ix] = ((mp_digit)_W) & MP_MASK;

      /* make next carry */
      _W = _W >> ((mp_word)DIGIT_BIT);
  }

  /* store final carry */
  W[ix] = (mp_digit)(_W & MP_MASK);

  /* setup dest */
  olduse  = c->used;
  c->used = pa;

  {
    register mp_digit *tmpc;
    tmpc = c->dp;
    for (ix = 0; ix < pa+1; ix++) {
      /* now extract the previous digit [below the carry] */
      *tmpc++ = W[ix];
    }

    /* clear unused digits [that existed in the old copy of c] */
    for (; ix < olduse; ix++) {
      *tmpc++ = 0;
    }
  }
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_mul_digs.c,v $ */
/* $Revision: 1.1.1.1.2.3 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_fast_s_mp_mul_high_digs.c.











































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
#include <tommath.h>
#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* this is a modified version of fast_s_mul_digs that only produces
 * output digits *above* digs.  See the comments for fast_s_mul_digs
 * to see how it works.
 *
 * This is used in the Barrett reduction since for one of the multiplications
 * only the higher digits were needed.  This essentially halves the work.
 *
 * Based on Algorithm 14.12 on pp.595 of HAC.
 */
int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  int     olduse, res, pa, ix, iz;
  mp_digit W[MP_WARRAY];
  mp_word  _W;

  /* grow the destination as required */
  pa = a->used + b->used;
  if (c->alloc < pa) {
    if ((res = mp_grow (c, pa)) != MP_OKAY) {
      return res;
    }
  }

  /* number of output digits to produce */
  pa = a->used + b->used;
  _W = 0;
  for (ix = digs; ix < pa; ix++) { 
      int      tx, ty, iy;
      mp_digit *tmpx, *tmpy;

      /* get offsets into the two bignums */
      ty = MIN(b->used-1, ix);
      tx = ix - ty;

      /* setup temp aliases */
      tmpx = a->dp + tx;
      tmpy = b->dp + ty;

      /* this is the number of times the loop will iterrate, essentially its 
         while (tx++ < a->used && ty-- >= 0) { ... }
       */
      iy = MIN(a->used-tx, ty+1);

      /* execute loop */
      for (iz = 0; iz < iy; iz++) {
         _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
      }

      /* store term */
      W[ix] = ((mp_digit)_W) & MP_MASK;

      /* make next carry */
      _W = _W >> ((mp_word)DIGIT_BIT);
  }
  
  /* store final carry */
  W[ix] = (mp_digit)(_W & MP_MASK);

  /* setup dest */
  olduse  = c->used;
  c->used = pa;

  {
    register mp_digit *tmpc;

    tmpc = c->dp + digs;
    for (ix = digs; ix <= pa; ix++) {
      /* now extract the previous digit [below the carry] */
      *tmpc++ = W[ix];
    }

    /* clear unused digits [that existed in the old copy of c] */
    for (; ix < olduse; ix++) {
      *tmpc++ = 0;
    }
  }
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_fast_s_mp_sqr.c.





































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
#include <tommath.h>
#ifdef BN_FAST_S_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* the jist of squaring...
 * you do like mult except the offset of the tmpx [one that 
 * starts closer to zero] can't equal the offset of tmpy.  
 * So basically you set up iy like before then you min it with
 * (ty-tx) so that it never happens.  You double all those 
 * you add in the inner loop

After that loop you do the squares and add them in.
*/

int fast_s_mp_sqr (mp_int * a, mp_int * b)
{
  int       olduse, res, pa, ix, iz;
  mp_digit   W[MP_WARRAY], *tmpx;
  mp_word   W1;

  /* grow the destination as required */
  pa = a->used + a->used;
  if (b->alloc < pa) {
    if ((res = mp_grow (b, pa)) != MP_OKAY) {
      return res;
    }
  }

  /* number of output digits to produce */
  W1 = 0;
  for (ix = 0; ix < pa; ix++) { 
      int      tx, ty, iy;
      mp_word  _W;
      mp_digit *tmpy;

      /* clear counter */
      _W = 0;

      /* get offsets into the two bignums */
      ty = MIN(a->used-1, ix);
      tx = ix - ty;

      /* setup temp aliases */
      tmpx = a->dp + tx;
      tmpy = a->dp + ty;

      /* this is the number of times the loop will iterrate, essentially
         while (tx++ < a->used && ty-- >= 0) { ... }
       */
      iy = MIN(a->used-tx, ty+1);

      /* now for squaring tx can never equal ty 
       * we halve the distance since they approach at a rate of 2x
       * and we have to round because odd cases need to be executed
       */
      iy = MIN(iy, (ty-tx+1)>>1);

      /* execute loop */
      for (iz = 0; iz < iy; iz++) {
         _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
      }

      /* double the inner product and add carry */
      _W = _W + _W + W1;

      /* even columns have the square term in them */
      if ((ix&1) == 0) {
         _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]);
      }

      /* store it */
      W[ix] = (mp_digit)(_W & MP_MASK);

      /* make next carry */
      W1 = _W >> ((mp_word)DIGIT_BIT);
  }

  /* setup dest */
  olduse  = b->used;
  b->used = a->used+a->used;

  {
    mp_digit *tmpb;
    tmpb = b->dp;
    for (ix = 0; ix < pa; ix++) {
      *tmpb++ = W[ix] & MP_MASK;
    }

    /* clear unused digits [that existed in the old copy of c] */
    for (; ix < olduse; ix++) {
      *tmpb++ = 0;
    }
  }
  mp_clamp (b);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_sqr.c,v $ */
/* $Revision: 1.1.1.1.2.3 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_2expt.c.

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#include <tommath.h>
#ifdef BN_MP_2EXPT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes a = 2**b 
 *
 * Simple algorithm which zeroes the int, grows it then just sets one bit
 * as required.
 */
int
mp_2expt (mp_int * a, int b)
{
  int     res;

  /* zero a as per default */
  mp_zero (a);

  /* grow a to accomodate the single bit */
  if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) {
    return res;
  }

  /* set the used count of where the bit will go */
  a->used = b / DIGIT_BIT + 1;

  /* put the single bit in its place */
  a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT);

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_2expt.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_abs.c.























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#include <tommath.h>
#ifdef BN_MP_ABS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = |a| 
 *
 * Simple function copies the input and fixes the sign to positive
 */
int
mp_abs (mp_int * a, mp_int * b)
{
  int     res;

  /* copy a to b */
  if (a != b) {
     if ((res = mp_copy (a, b)) != MP_OKAY) {
       return res;
     }
  }

  /* force the sign of b to positive */
  b->sign = MP_ZPOS;

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_abs.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_add.c.











































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
#include <tommath.h>
#ifdef BN_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* high level addition (handles signs) */
int mp_add (mp_int * a, mp_int * b, mp_int * c)
{
  int     sa, sb, res;

  /* get sign of both inputs */
  sa = a->sign;
  sb = b->sign;

  /* handle two cases, not four */
  if (sa == sb) {
    /* both positive or both negative */
    /* add their magnitudes, copy the sign */
    c->sign = sa;
    res = s_mp_add (a, b, c);
  } else {
    /* one positive, the other negative */
    /* subtract the one with the greater magnitude from */
    /* the one of the lesser magnitude.  The result gets */
    /* the sign of the one with the greater magnitude. */
    if (mp_cmp_mag (a, b) == MP_LT) {
      c->sign = sb;
      res = s_mp_sub (b, a, c);
    } else {
      c->sign = sa;
      res = s_mp_sub (a, b, c);
    }
  }
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_add_d.c.





























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#include <tommath.h>
#ifdef BN_MP_ADD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* single digit addition */
int
mp_add_d (mp_int * a, mp_digit b, mp_int * c)
{
  int     res, ix, oldused;
  mp_digit *tmpa, *tmpc, mu;

  /* grow c as required */
  if (c->alloc < a->used + 1) {
     if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) {
        return res;
     }
  }

  /* if a is negative and |a| >= b, call c = |a| - b */
  if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) {
     /* temporarily fix sign of a */
     a->sign = MP_ZPOS;

     /* c = |a| - b */
     res = mp_sub_d(a, b, c);

     /* fix signs  */
     a->sign = MP_NEG;
     c->sign = (c->used) ? MP_NEG : MP_ZPOS;

     return res;
  }

  /* old number of used digits in c */
  oldused = c->used;

  /* sign always positive */
  c->sign = MP_ZPOS;

  /* source alias */
  tmpa    = a->dp;

  /* destination alias */
  tmpc    = c->dp;

  /* if a is positive */
  if (a->sign == MP_ZPOS) {
     /* add digit, after this we're propagating
      * the carry.
      */
     *tmpc   = *tmpa++ + b;
     mu      = *tmpc >> DIGIT_BIT;
     *tmpc++ &= MP_MASK;

     /* now handle rest of the digits */
     for (ix = 1; ix < a->used; ix++) {
        *tmpc   = *tmpa++ + mu;
        mu      = *tmpc >> DIGIT_BIT;
        *tmpc++ &= MP_MASK;
     }
     /* set final carry */
     ix++;
     *tmpc++  = mu;

     /* setup size */
     c->used = a->used + 1;
  } else {
     /* a was negative and |a| < b */
     c->used  = 1;

     /* the result is a single digit */
     if (a->used == 1) {
        *tmpc++  =  b - a->dp[0];
     } else {
        *tmpc++  =  b;
     }

     /* setup count so the clearing of oldused
      * can fall through correctly
      */
     ix       = 1;
  }

  /* now zero to oldused */
  while (ix++ < oldused) {
     *tmpc++ = 0;
  }
  mp_clamp(c);

  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add_d.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_addmod.c.



















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
#include <tommath.h>
#ifdef BN_MP_ADDMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* d = a + b (mod c) */
int
mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  int     res;
  mp_int  t;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_add (a, b, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, c, d);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_addmod.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_and.c.



















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#include <tommath.h>
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* AND two ints together */
int
mp_and (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, ix, px;
  mp_int  t, *x;

  if (a->used > b->used) {
    if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
      return res;
    }
    px = b->used;
    x = b;
  } else {
    if ((res = mp_init_copy (&t, b)) != MP_OKAY) {
      return res;
    }
    px = a->used;
    x = a;
  }

  for (ix = 0; ix < px; ix++) {
    t.dp[ix] &= x->dp[ix];
  }

  /* zero digits above the last from the smallest mp_int */
  for (; ix < t.used; ix++) {
    t.dp[ix] = 0;
  }

  mp_clamp (&t);
  mp_exch (c, &t);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_and.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_clamp.c.

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#include <tommath.h>
#ifdef BN_MP_CLAMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* trim unused digits 
 *
 * This is used to ensure that leading zero digits are
 * trimed and the leading "used" digit will be non-zero
 * Typically very fast.  Also fixes the sign if there
 * are no more leading digits
 */
void
mp_clamp (mp_int * a)
{
  /* decrease used while the most significant digit is
   * zero.
   */
  while (a->used > 0 && a->dp[a->used - 1] == 0) {
    --(a->used);
  }

  /* reset the sign flag if used == 0 */
  if (a->used == 0) {
    a->sign = MP_ZPOS;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clamp.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_clear.c.

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#include <tommath.h>
#ifdef BN_MP_CLEAR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* clear one (frees)  */
void
mp_clear (mp_int * a)
{
  int i;

  /* only do anything if a hasn't been freed previously */
  if (a->dp != NULL) {
    /* first zero the digits */
    for (i = 0; i < a->used; i++) {
        a->dp[i] = 0;
    }

    /* free ram */
    XFREE(a->dp);

    /* reset members to make debugging easier */
    a->dp    = NULL;
    a->alloc = a->used = 0;
    a->sign  = MP_ZPOS;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clear.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_clear_multi.c.





































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#include <tommath.h>
#ifdef BN_MP_CLEAR_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#include <stdarg.h>

void mp_clear_multi(mp_int *mp, ...) 
{
    mp_int* next_mp = mp;
    va_list args;
    va_start(args, mp);
    while (next_mp != NULL) {
        mp_clear(next_mp);
        next_mp = va_arg(args, mp_int*);
    }
    va_end(args);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clear_multi.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_cmp.c.























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#include <tommath.h>
#ifdef BN_MP_CMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* compare two ints (signed)*/
int
mp_cmp (mp_int * a, mp_int * b)
{
  /* compare based on sign */
  if (a->sign != b->sign) {
     if (a->sign == MP_NEG) {
        return MP_LT;
     } else {
        return MP_GT;
     }
  }
  
  /* compare digits */
  if (a->sign == MP_NEG) {
     /* if negative compare opposite direction */
     return mp_cmp_mag(b, a);
  } else {
     return mp_cmp_mag(a, b);
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_cmp_d.c.

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#include <tommath.h>
#ifdef BN_MP_CMP_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* compare a digit */
int mp_cmp_d(mp_int * a, mp_digit b)
{
  /* compare based on sign */
  if (a->sign == MP_NEG) {
    return MP_LT;
  }

  /* compare based on magnitude */
  if (a->used > 1) {
    return MP_GT;
  }

  /* compare the only digit of a to b */
  if (a->dp[0] > b) {
    return MP_GT;
  } else if (a->dp[0] < b) {
    return MP_LT;
  } else {
    return MP_EQ;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp_d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_cmp_mag.c.















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
#include <tommath.h>
#ifdef BN_MP_CMP_MAG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* compare maginitude of two ints (unsigned) */
int mp_cmp_mag (mp_int * a, mp_int * b)
{
  int     n;
  mp_digit *tmpa, *tmpb;

  /* compare based on # of non-zero digits */
  if (a->used > b->used) {
    return MP_GT;
  }
  
  if (a->used < b->used) {
    return MP_LT;
  }

  /* alias for a */
  tmpa = a->dp + (a->used - 1);

  /* alias for b */
  tmpb = b->dp + (a->used - 1);

  /* compare based on digits  */
  for (n = 0; n < a->used; ++n, --tmpa, --tmpb) {
    if (*tmpa > *tmpb) {
      return MP_GT;
    }

    if (*tmpa < *tmpb) {
      return MP_LT;
    }
  }
  return MP_EQ;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp_mag.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_cnt_lsb.c.











































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
#include <tommath.h>
#ifdef BN_MP_CNT_LSB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

static const int lnz[16] = { 
   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
};

/* Counts the number of lsbs which are zero before the first zero bit */
int mp_cnt_lsb(mp_int *a)
{
   int x;
   mp_digit q, qq;

   /* easy out */
   if (mp_iszero(a) == 1) {
      return 0;
   }

   /* scan lower digits until non-zero */
   for (x = 0; x < a->used && a->dp[x] == 0; x++);
   q = a->dp[x];
   x *= DIGIT_BIT;

   /* now scan this digit until a 1 is found */
   if ((q & 1) == 0) {
      do {
         qq  = q & 15;
         x  += lnz[qq];
         q >>= 4;
      } while (qq == 0);
   }
   return x;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cnt_lsb.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_copy.c.









































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
#include <tommath.h>
#ifdef BN_MP_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* copy, b = a */
int
mp_copy (mp_int * a, mp_int * b)
{
  int     res, n;

  /* if dst == src do nothing */
  if (a == b) {
    return MP_OKAY;
  }

  /* grow dest */
  if (b->alloc < a->used) {
     if ((res = mp_grow (b, a->used)) != MP_OKAY) {
        return res;
     }
  }

  /* zero b and copy the parameters over */
  {
    register mp_digit *tmpa, *tmpb;

    /* pointer aliases */

    /* source */
    tmpa = a->dp;

    /* destination */
    tmpb = b->dp;

    /* copy all the digits */
    for (n = 0; n < a->used; n++) {
      *tmpb++ = *tmpa++;
    }

    /* clear high digits */
    for (; n < b->used; n++) {
      *tmpb++ = 0;
    }
  }

  /* copy used count and sign */
  b->used = a->used;
  b->sign = a->sign;
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_copy.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_count_bits.c.



























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
#include <tommath.h>
#ifdef BN_MP_COUNT_BITS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* returns the number of bits in an int */
int
mp_count_bits (mp_int * a)
{
  int     r;
  mp_digit q;

  /* shortcut */
  if (a->used == 0) {
    return 0;
  }

  /* get number of digits and add that */
  r = (a->used - 1) * DIGIT_BIT;
  
  /* take the last digit and count the bits in it */
  q = a->dp[a->used - 1];
  while (q > ((mp_digit) 0)) {
    ++r;
    q >>= ((mp_digit) 1);
  }
  return r;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_count_bits.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_div.c.









































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
#include <tommath.h>
#ifdef BN_MP_DIV_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

#ifdef BN_MP_DIV_SMALL

/* slower bit-bang division... also smaller */
int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
   mp_int ta, tb, tq, q;
   int    res, n, n2;

  /* is divisor zero ? */
  if (mp_iszero (b) == 1) {
    return MP_VAL;
  }

  /* if a < b then q=0, r = a */
  if (mp_cmp_mag (a, b) == MP_LT) {
    if (d != NULL) {
      res = mp_copy (a, d);
    } else {
      res = MP_OKAY;
    }
    if (c != NULL) {
      mp_zero (c);
    }
    return res;
  }
	
  /* init our temps */
  if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) {
     return res;
  }


  mp_set(&tq, 1);
  n = mp_count_bits(a) - mp_count_bits(b);
  if (((res = mp_abs(a, &ta)) != MP_OKAY) ||
      ((res = mp_abs(b, &tb)) != MP_OKAY) || 
      ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) ||
      ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) {
      goto LBL_ERR;
  }

  while (n-- >= 0) {
     if (mp_cmp(&tb, &ta) != MP_GT) {
        if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) ||
            ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) {
           goto LBL_ERR;
        }
     }
     if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) ||
         ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) {
           goto LBL_ERR;
     }
  }

  /* now q == quotient and ta == remainder */
  n  = a->sign;
  n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG);
  if (c != NULL) {
     mp_exch(c, &q);
     c->sign  = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2;
  }
  if (d != NULL) {
     mp_exch(d, &ta);
     d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n;
  }
LBL_ERR:
   mp_clear_multi(&ta, &tb, &tq, &q, NULL);
   return res;
}

#else

/* integer signed division. 
 * c*b + d == a [e.g. a/b, c=quotient, d=remainder]
 * HAC pp.598 Algorithm 14.20
 *
 * Note that the description in HAC is horribly 
 * incomplete.  For example, it doesn't consider 
 * the case where digits are removed from 'x' in 
 * the inner loop.  It also doesn't consider the 
 * case that y has fewer than three digits, etc..
 *
 * The overall algorithm is as described as 
 * 14.20 from HAC but fixed to treat these cases.
*/
int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  mp_int  q, x, y, t1, t2;
  int     res, n, t, i, norm, neg;

  /* is divisor zero ? */
  if (mp_iszero (b) == 1) {
    return MP_VAL;
  }

  /* if a < b then q=0, r = a */
  if (mp_cmp_mag (a, b) == MP_LT) {
    if (d != NULL) {
      res = mp_copy (a, d);
    } else {
      res = MP_OKAY;
    }
    if (c != NULL) {
      mp_zero (c);
    }
    return res;
  }

  if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) {
    return res;
  }
  q.used = a->used + 2;

  if ((res = mp_init (&t1)) != MP_OKAY) {
    goto LBL_Q;
  }

  if ((res = mp_init (&t2)) != MP_OKAY) {
    goto LBL_T1;
  }

  if ((res = mp_init_copy (&x, a)) != MP_OKAY) {
    goto LBL_T2;
  }

  if ((res = mp_init_copy (&y, b)) != MP_OKAY) {
    goto LBL_X;
  }

  /* fix the sign */
  neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;
  x.sign = y.sign = MP_ZPOS;

  /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */
  norm = mp_count_bits(&y) % DIGIT_BIT;
  if (norm < (int)(DIGIT_BIT-1)) {
     norm = (DIGIT_BIT-1) - norm;
     if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) {
       goto LBL_Y;
     }
     if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) {
       goto LBL_Y;
     }
  } else {
     norm = 0;
  }

  /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */
  n = x.used - 1;
  t = y.used - 1;

  /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */
  if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */
    goto LBL_Y;
  }

  while (mp_cmp (&x, &y) != MP_LT) {
    ++(q.dp[n - t]);
    if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) {
      goto LBL_Y;
    }
  }

  /* reset y by shifting it back down */
  mp_rshd (&y, n - t);

  /* step 3. for i from n down to (t + 1) */
  for (i = n; i >= (t + 1); i--) {
    if (i > x.used) {
      continue;
    }

    /* step 3.1 if xi == yt then set q{i-t-1} to b-1, 
     * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */
    if (x.dp[i] == y.dp[t]) {
      q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1);
    } else {
      mp_word tmp;
      tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT);
      tmp |= ((mp_word) x.dp[i - 1]);
      tmp /= ((mp_word) y.dp[t]);
      if (tmp > (mp_word) MP_MASK)
        tmp = MP_MASK;
      q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK));
    }

    /* while (q{i-t-1} * (yt * b + y{t-1})) > 
             xi * b**2 + xi-1 * b + xi-2 
     
       do q{i-t-1} -= 1; 
    */
    q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK;
    do {
      q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK;

      /* find left hand */
      mp_zero (&t1);
      t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1];
      t1.dp[1] = y.dp[t];
      t1.used = 2;
      if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) {
        goto LBL_Y;
      }

      /* find right hand */
      t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2];
      t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1];
      t2.dp[2] = x.dp[i];
      t2.used = 3;
    } while (mp_cmp_mag(&t1, &t2) == MP_GT);

    /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */
    if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) {
      goto LBL_Y;
    }

    if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) {
      goto LBL_Y;
    }

    if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) {
      goto LBL_Y;
    }

    /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */
    if (x.sign == MP_NEG) {
      if ((res = mp_copy (&y, &t1)) != MP_OKAY) {
        goto LBL_Y;
      }
      if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) {
        goto LBL_Y;
      }
      if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) {
        goto LBL_Y;
      }

      q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK;
    }
  }

  /* now q is the quotient and x is the remainder 
   * [which we have to normalize] 
   */
  
  /* get sign before writing to c */
  x.sign = x.used == 0 ? MP_ZPOS : a->sign;

  if (c != NULL) {
    mp_clamp (&q);
    mp_exch (&q, c);
    c->sign = neg;
  }

  if (d != NULL) {
    mp_div_2d (&x, norm, &x, NULL);
    mp_exch (&x, d);
  }

  res = MP_OKAY;

LBL_Y:mp_clear (&y);
LBL_X:mp_clear (&x);
LBL_T2:mp_clear (&t2);
LBL_T1:mp_clear (&t1);
LBL_Q:mp_clear (&q);
  return res;
}

#endif

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_div_2.c.









































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
#include <tommath.h>
#ifdef BN_MP_DIV_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = a/2 */
int mp_div_2(mp_int * a, mp_int * b)
{
  int     x, res, oldused;

  /* copy */
  if (b->alloc < a->used) {
    if ((res = mp_grow (b, a->used)) != MP_OKAY) {
      return res;
    }
  }

  oldused = b->used;
  b->used = a->used;
  {
    register mp_digit r, rr, *tmpa, *tmpb;

    /* source alias */
    tmpa = a->dp + b->used - 1;

    /* dest alias */
    tmpb = b->dp + b->used - 1;

    /* carry */
    r = 0;
    for (x = b->used - 1; x >= 0; x--) {
      /* get the carry for the next iteration */
      rr = *tmpa & 1;

      /* shift the current digit, add in carry and store */
      *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1));

      /* forward carry to next iteration */
      r = rr;
    }

    /* zero excess digits */
    tmpb = b->dp + b->used;
    for (x = b->used; x < oldused; x++) {
      *tmpb++ = 0;
    }
  }
  b->sign = a->sign;
  mp_clamp (b);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_2.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_div_2d.c.



































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
#include <tommath.h>
#ifdef BN_MP_DIV_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift right by a certain bit count (store quotient in c, optional remainder in d) */
int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d)
{
  mp_digit D, r, rr;
  int     x, res;
  mp_int  t;


  /* if the shift count is <= 0 then we do no work */
  if (b <= 0) {
    res = mp_copy (a, c);
    if (d != NULL) {
      mp_zero (d);
    }
    return res;
  }

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  /* get the remainder */
  if (d != NULL) {
    if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
  }

  /* copy */
  if ((res = mp_copy (a, c)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }

  /* shift by as many digits in the bit count */
  if (b >= (int)DIGIT_BIT) {
    mp_rshd (c, b / DIGIT_BIT);
  }

  /* shift any bit count < DIGIT_BIT */
  D = (mp_digit) (b % DIGIT_BIT);
  if (D != 0) {
    register mp_digit *tmpc, mask, shift;

    /* mask */
    mask = (((mp_digit)1) << D) - 1;

    /* shift for lsb */
    shift = DIGIT_BIT - D;

    /* alias */
    tmpc = c->dp + (c->used - 1);

    /* carry */
    r = 0;
    for (x = c->used - 1; x >= 0; x--) {
      /* get the lower  bits of this word in a temp */
      rr = *tmpc & mask;

      /* shift the current word and mix in the carry bits from the previous word */
      *tmpc = (*tmpc >> D) | (r << shift);
      --tmpc;

      /* set the carry to the carry bits of the current word found above */
      r = rr;
    }
  }
  mp_clamp (c);
  if (d != NULL) {
    mp_exch (&t, d);
  }
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_2d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_div_3.c.































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
#include <tommath.h>
#ifdef BN_MP_DIV_3_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* divide by three (based on routine from MPI and the GMP manual) */
int
mp_div_3 (mp_int * a, mp_int *c, mp_digit * d)
{
  mp_int   q;
  mp_word  w, t;
  mp_digit b;
  int      res, ix;
  
  /* b = 2**DIGIT_BIT / 3 */
  b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3);

  if ((res = mp_init_size(&q, a->used)) != MP_OKAY) {
     return res;
  }
  
  q.used = a->used;
  q.sign = a->sign;
  w = 0;
  for (ix = a->used - 1; ix >= 0; ix--) {
     w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]);

     if (w >= 3) {
        /* multiply w by [1/3] */
        t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT);

        /* now subtract 3 * [w/3] from w, to get the remainder */
        w -= t+t+t;

        /* fixup the remainder as required since
         * the optimization is not exact.
         */
        while (w >= 3) {
           t += 1;
           w -= 3;
        }
      } else {
        t = 0;
      }
      q.dp[ix] = (mp_digit)t;
  }

  /* [optional] store the remainder */
  if (d != NULL) {
     *d = (mp_digit)w;
  }

  /* [optional] store the quotient */
  if (c != NULL) {
     mp_clamp(&q);
     mp_exch(&q, c);
  }
  mp_clear(&q);
  
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_3.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_div_d.c.





























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#include <tommath.h>
#ifdef BN_MP_DIV_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

static int s_is_power_of_two(mp_digit b, int *p)
{
   int x;

   for (x = 1; x < DIGIT_BIT; x++) {
      if (b == (((mp_digit)1)<<x)) {
         *p = x;
         return 1;
      }
   }
   return 0;
}

/* single digit division (based on routine from MPI) */
int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d)
{
  mp_int  q;
  mp_word w;
  mp_digit t;
  int     res, ix;

  /* cannot divide by zero */
  if (b == 0) {
     return MP_VAL;
  }

  /* quick outs */
  if (b == 1 || mp_iszero(a) == 1) {
     if (d != NULL) {
        *d = 0;
     }
     if (c != NULL) {
        return mp_copy(a, c);
     }
     return MP_OKAY;
  }

  /* power of two ? */
  if (s_is_power_of_two(b, &ix) == 1) {
     if (d != NULL) {
        *d = a->dp[0] & ((((mp_digit)1)<<ix) - 1);
     }
     if (c != NULL) {
        return mp_div_2d(a, ix, c, NULL);
     }
     return MP_OKAY;
  }

#ifdef BN_MP_DIV_3_C
  /* three? */
  if (b == 3) {
     return mp_div_3(a, c, d);
  }
#endif

  /* no easy answer [c'est la vie].  Just division */
  if ((res = mp_init_size(&q, a->used)) != MP_OKAY) {
     return res;
  }
  
  q.used = a->used;
  q.sign = a->sign;
  w = 0;
  for (ix = a->used - 1; ix >= 0; ix--) {
     w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]);
     
     if (w >= b) {
        t = (mp_digit)(w / b);
        w -= ((mp_word)t) * ((mp_word)b);
      } else {
        t = 0;
      }
      q.dp[ix] = (mp_digit)t;
  }
  
  if (d != NULL) {
     *d = (mp_digit)w;
  }
  
  if (c != NULL) {
     mp_clamp(&q);
     mp_exch(&q, c);
  }
  mp_clear(&q);
  
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_dr_is_modulus.c.























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#include <tommath.h>
#ifdef BN_MP_DR_IS_MODULUS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if a number is a valid DR modulus */
int mp_dr_is_modulus(mp_int *a)
{
   int ix;

   /* must be at least two digits */
   if (a->used < 2) {
      return 0;
   }

   /* must be of the form b**k - a [a <= b] so all
    * but the first digit must be equal to -1 (mod b).
    */
   for (ix = 1; ix < a->used; ix++) {
       if (a->dp[ix] != MP_MASK) {
          return 0;
       }
   }
   return 1;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_is_modulus.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_dr_reduce.c.





























































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
#include <tommath.h>
#ifdef BN_MP_DR_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduce "x" in place modulo "n" using the Diminished Radix algorithm.
 *
 * Based on algorithm from the paper
 *
 * "Generating Efficient Primes for Discrete Log Cryptosystems"
 *                 Chae Hoon Lim, Pil Joong Lee,
 *          POSTECH Information Research Laboratories
 *
 * The modulus must be of a special format [see manual]
 *
 * Has been modified to use algorithm 7.10 from the LTM book instead
 *
 * Input x must be in the range 0 <= x <= (n-1)**2
 */
int
mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k)
{
  int      err, i, m;
  mp_word  r;
  mp_digit mu, *tmpx1, *tmpx2;

  /* m = digits in modulus */
  m = n->used;

  /* ensure that "x" has at least 2m digits */
  if (x->alloc < m + m) {
    if ((err = mp_grow (x, m + m)) != MP_OKAY) {
      return err;
    }
  }

/* top of loop, this is where the code resumes if
 * another reduction pass is required.
 */
top:
  /* aliases for digits */
  /* alias for lower half of x */
  tmpx1 = x->dp;

  /* alias for upper half of x, or x/B**m */
  tmpx2 = x->dp + m;

  /* set carry to zero */
  mu = 0;

  /* compute (x mod B**m) + k * [x/B**m] inline and inplace */
  for (i = 0; i < m; i++) {
      r         = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu;
      *tmpx1++  = (mp_digit)(r & MP_MASK);
      mu        = (mp_digit)(r >> ((mp_word)DIGIT_BIT));
  }

  /* set final carry */
  *tmpx1++ = mu;

  /* zero words above m */
  for (i = m + 1; i < x->used; i++) {
      *tmpx1++ = 0;
  }

  /* clamp, sub and return */
  mp_clamp (x);

  /* if x >= n then subtract and reduce again
   * Each successive "recursion" makes the input smaller and smaller.
   */
  if (mp_cmp_mag (x, n) != MP_LT) {
    s_mp_sub(x, n, x);
    goto top;
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_reduce.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_dr_setup.c.

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#include <tommath.h>
#ifdef BN_MP_DR_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines the setup value */
void mp_dr_setup(mp_int *a, mp_digit *d)
{
   /* the casts are required if DIGIT_BIT is one less than
    * the number of bits in a mp_digit [e.g. DIGIT_BIT==31]
    */
   *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - 
        ((mp_word)a->dp[0]));
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_setup.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_exch.c.





































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#include <tommath.h>
#ifdef BN_MP_EXCH_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* swap the elements of two integers, for cases where you can't simply swap the 
 * mp_int pointers around
 */
void
mp_exch (mp_int * a, mp_int * b)
{
  mp_int  t;

  t  = *a;
  *a = *b;
  *b = t;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exch.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_expt_d.c.



















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#include <tommath.h>
#ifdef BN_MP_EXPT_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* calculate c = a**b  using a square-multiply algorithm */
int mp_expt_d (mp_int * a, mp_digit b, mp_int * c)
{
  int     res, x;
  mp_int  g;

  if ((res = mp_init_copy (&g, a)) != MP_OKAY) {
    return res;
  }

  /* set initial result */
  mp_set (c, 1);

  for (x = 0; x < (int) DIGIT_BIT; x++) {
    /* square */
    if ((res = mp_sqr (c, c)) != MP_OKAY) {
      mp_clear (&g);
      return res;
    }

    /* if the bit is set multiply */
    if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) {
      if ((res = mp_mul (c, &g, c)) != MP_OKAY) {
         mp_clear (&g);
         return res;
      }
    }

    /* shift to next bit */
    b <<= 1;
  }

  mp_clear (&g);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_expt_d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_exptmod.c.

































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
#include <tommath.h>
#ifdef BN_MP_EXPTMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */


/* this is a shell function that calls either the normal or Montgomery
 * exptmod functions.  Originally the call to the montgomery code was
 * embedded in the normal function but that wasted alot of stack space
 * for nothing (since 99% of the time the Montgomery code would be called)
 */
int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y)
{
  int dr;

  /* modulus P must be positive */
  if (P->sign == MP_NEG) {
     return MP_VAL;
  }

  /* if exponent X is negative we have to recurse */
  if (X->sign == MP_NEG) {
#ifdef BN_MP_INVMOD_C
     mp_int tmpG, tmpX;
     int err;

     /* first compute 1/G mod P */
     if ((err = mp_init(&tmpG)) != MP_OKAY) {
        return err;
     }
     if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) {
        mp_clear(&tmpG);
        return err;
     }

     /* now get |X| */
     if ((err = mp_init(&tmpX)) != MP_OKAY) {
        mp_clear(&tmpG);
        return err;
     }
     if ((err = mp_abs(X, &tmpX)) != MP_OKAY) {
        mp_clear_multi(&tmpG, &tmpX, NULL);
        return err;
     }

     /* and now compute (1/G)**|X| instead of G**X [X < 0] */
     err = mp_exptmod(&tmpG, &tmpX, P, Y);
     mp_clear_multi(&tmpG, &tmpX, NULL);
     return err;
#else 
     /* no invmod */
     return MP_VAL;
#endif
  }

/* modified diminished radix reduction */
#if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C)
  if (mp_reduce_is_2k_l(P) == MP_YES) {
     return s_mp_exptmod(G, X, P, Y, 1);
  }
#endif

#ifdef BN_MP_DR_IS_MODULUS_C
  /* is it a DR modulus? */
  dr = mp_dr_is_modulus(P);
#else
  /* default to no */
  dr = 0;
#endif

#ifdef BN_MP_REDUCE_IS_2K_C
  /* if not, is it a unrestricted DR modulus? */
  if (dr == 0) {
     dr = mp_reduce_is_2k(P) << 1;
  }
#endif
    
  /* if the modulus is odd or dr != 0 use the montgomery method */
#ifdef BN_MP_EXPTMOD_FAST_C
  if (mp_isodd (P) == 1 || dr !=  0) {
    return mp_exptmod_fast (G, X, P, Y, dr);
  } else {
#endif
#ifdef BN_S_MP_EXPTMOD_C
    /* otherwise use the generic Barrett reduction technique */
    return s_mp_exptmod (G, X, P, Y, 0);
#else
    /* no exptmod for evens */
    return MP_VAL;
#endif
#ifdef BN_MP_EXPTMOD_FAST_C
  }
#endif
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exptmod.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_exptmod_fast.c.



































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
#include <tommath.h>
#ifdef BN_MP_EXPTMOD_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85
 *
 * Uses a left-to-right k-ary sliding window to compute the modular exponentiation.
 * The value of k changes based on the size of the exponent.
 *
 * Uses Montgomery or Diminished Radix reduction [whichever appropriate]
 */

#ifdef MP_LOW_MEM
   #define TAB_SIZE 32
#else
   #define TAB_SIZE 256
#endif

int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode)
{
  mp_int  M[TAB_SIZE], res;
  mp_digit buf, mp;
  int     err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;

  /* use a pointer to the reduction algorithm.  This allows us to use
   * one of many reduction algorithms without modding the guts of
   * the code with if statements everywhere.
   */
  int     (*redux)(mp_int*,mp_int*,mp_digit);

  /* find window size */
  x = mp_count_bits (X);
  if (x <= 7) {
    winsize = 2;
  } else if (x <= 36) {
    winsize = 3;
  } else if (x <= 140) {
    winsize = 4;
  } else if (x <= 450) {
    winsize = 5;
  } else if (x <= 1303) {
    winsize = 6;
  } else if (x <= 3529) {
    winsize = 7;
  } else {
    winsize = 8;
  }

#ifdef MP_LOW_MEM
  if (winsize > 5) {
     winsize = 5;
  }
#endif

  /* init M array */
  /* init first cell */
  if ((err = mp_init(&M[1])) != MP_OKAY) {
     return err;
  }

  /* now init the second half of the array */
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    if ((err = mp_init(&M[x])) != MP_OKAY) {
      for (y = 1<<(winsize-1); y < x; y++) {
        mp_clear (&M[y]);
      }
      mp_clear(&M[1]);
      return err;
    }
  }

  /* determine and setup reduction code */
  if (redmode == 0) {
#ifdef BN_MP_MONTGOMERY_SETUP_C     
     /* now setup montgomery  */
     if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) {
        goto LBL_M;
     }
#else
     err = MP_VAL;
     goto LBL_M;
#endif

     /* automatically pick the comba one if available (saves quite a few calls/ifs) */
#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C
     if (((P->used * 2 + 1) < MP_WARRAY) &&
          P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
        redux = fast_mp_montgomery_reduce;
     } else 
#endif
     {
#ifdef BN_MP_MONTGOMERY_REDUCE_C
        /* use slower baseline Montgomery method */
        redux = mp_montgomery_reduce;
#else
        err = MP_VAL;
        goto LBL_M;
#endif
     }
  } else if (redmode == 1) {
#if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C)
     /* setup DR reduction for moduli of the form B**k - b */
     mp_dr_setup(P, &mp);
     redux = mp_dr_reduce;
#else
     err = MP_VAL;
     goto LBL_M;
#endif
  } else {
#if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C)
     /* setup DR reduction for moduli of the form 2**k - b */
     if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) {
        goto LBL_M;
     }
     redux = mp_reduce_2k;
#else
     err = MP_VAL;
     goto LBL_M;
#endif
  }

  /* setup result */
  if ((err = mp_init (&res)) != MP_OKAY) {
    goto LBL_M;
  }

  /* create M table
   *

   *
   * The first half of the table is not computed though accept for M[0] and M[1]
   */

  if (redmode == 0) {
#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
     /* now we need R mod m */
     if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) {
       goto LBL_RES;
     }
#else 
     err = MP_VAL;
     goto LBL_RES;
#endif

     /* now set M[1] to G * R mod m */
     if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) {
       goto LBL_RES;
     }
  } else {
     mp_set(&res, 1);
     if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
        goto LBL_RES;
     }
  }

  /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */
  if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) {
    goto LBL_RES;
  }

  for (x = 0; x < (winsize - 1); x++) {
    if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) {
      goto LBL_RES;
    }
    if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) {
      goto LBL_RES;
    }
  }

  /* create upper table */
  for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
    if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) {
      goto LBL_RES;
    }
    if ((err = redux (&M[x], P, mp)) != MP_OKAY) {
      goto LBL_RES;
    }
  }

  /* set initial mode and bit cnt */
  mode   = 0;
  bitcnt = 1;
  buf    = 0;
  digidx = X->used - 1;
  bitcpy = 0;
  bitbuf = 0;

  for (;;) {
    /* grab next digit as required */
    if (--bitcnt == 0) {
      /* if digidx == -1 we are out of digits so break */
      if (digidx == -1) {
        break;
      }
      /* read next digit and reset bitcnt */
      buf    = X->dp[digidx--];
      bitcnt = (int)DIGIT_BIT;
    }

    /* grab the next msb from the exponent */
    y     = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1;
    buf <<= (mp_digit)1;

    /* if the bit is zero and mode == 0 then we ignore it
     * These represent the leading zero bits before the first 1 bit
     * in the exponent.  Technically this opt is not required but it
     * does lower the # of trivial squaring/reductions used
     */
    if (mode == 0 && y == 0) {
      continue;
    }

    /* if the bit is zero and mode == 1 then we square */
    if (mode == 1 && y == 0) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, mp)) != MP_OKAY) {
        goto LBL_RES;
      }
      continue;
    }

    /* else we add it to the window */
    bitbuf |= (y << (winsize - ++bitcpy));
    mode    = 2;

    if (bitcpy == winsize) {
      /* ok window is filled so square as required and multiply  */
      /* square first */
      for (x = 0; x < winsize; x++) {
        if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, mp)) != MP_OKAY) {
          goto LBL_RES;
        }
      }

      /* then multiply */
      if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, mp)) != MP_OKAY) {
        goto LBL_RES;
      }

      /* empty window and reset */
      bitcpy = 0;
      bitbuf = 0;
      mode   = 1;
    }
  }

  /* if bits remain then square/multiply */
  if (mode == 2 && bitcpy > 0) {
    /* square then multiply if the bit is set */
    for (x = 0; x < bitcpy; x++) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, mp)) != MP_OKAY) {
        goto LBL_RES;
      }

      /* get next bit of the window */
      bitbuf <<= 1;
      if ((bitbuf & (1 << winsize)) != 0) {
        /* then multiply */
        if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, mp)) != MP_OKAY) {
          goto LBL_RES;
        }
      }
    }
  }

  if (redmode == 0) {
     /* fixup result if Montgomery reduction is used
      * recall that any value in a Montgomery system is
      * actually multiplied by R mod n.  So we have
      * to reduce one more time to cancel out the factor
      * of R.
      */
     if ((err = redux(&res, P, mp)) != MP_OKAY) {
       goto LBL_RES;
     }
  }

  /* swap res with Y */
  mp_exch (&res, Y);
  err = MP_OKAY;
LBL_RES:mp_clear (&res);
LBL_M:
  mp_clear(&M[1]);
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    mp_clear (&M[x]);
  }
  return err;
}
#endif


/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exptmod_fast.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_exteuclid.c.





































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
#include <tommath.h>
#ifdef BN_MP_EXTEUCLID_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Extended euclidean algorithm of (a, b) produces 
   a*u1 + b*u2 = u3
 */
int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3)
{
   mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp;
   int err;

   if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) {
      return err;
   }

   /* initialize, (u1,u2,u3) = (1,0,a) */
   mp_set(&u1, 1);
   if ((err = mp_copy(a, &u3)) != MP_OKAY)                                        { goto _ERR; }

   /* initialize, (v1,v2,v3) = (0,1,b) */
   mp_set(&v2, 1);
   if ((err = mp_copy(b, &v3)) != MP_OKAY)                                        { goto _ERR; }

   /* loop while v3 != 0 */
   while (mp_iszero(&v3) == MP_NO) {
       /* q = u3/v3 */
       if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY)                         { goto _ERR; }

       /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */
       if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY)                              { goto _ERR; }
       if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY)                             { goto _ERR; }
       if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY)                              { goto _ERR; }
       if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY)                             { goto _ERR; }
       if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY)                              { goto _ERR; }
       if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY)                             { goto _ERR; }

       /* (u1,u2,u3) = (v1,v2,v3) */
       if ((err = mp_copy(&v1, &u1)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&v2, &u2)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&v3, &u3)) != MP_OKAY)                                  { goto _ERR; }

       /* (v1,v2,v3) = (t1,t2,t3) */
       if ((err = mp_copy(&t1, &v1)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&t2, &v2)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&t3, &v3)) != MP_OKAY)                                  { goto _ERR; }
   }

   /* make sure U3 >= 0 */
   if (u3.sign == MP_NEG) {
      mp_neg(&u1, &u1);
      mp_neg(&u2, &u2);
      mp_neg(&u3, &u3);
   }

   /* copy result out */
   if (U1 != NULL) { mp_exch(U1, &u1); }
   if (U2 != NULL) { mp_exch(U2, &u2); }
   if (U3 != NULL) { mp_exch(U3, &u3); }

   err = MP_OKAY;
_ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL);
   return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exteuclid.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_fread.c.







































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
#include <tommath.h>
#ifdef BN_MP_FREAD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* read a bigint from a file stream in ASCII */
int mp_fread(mp_int *a, int radix, FILE *stream)
{
   int err, ch, neg, y;
   
   /* clear a */
   mp_zero(a);
   
   /* if first digit is - then set negative */
   ch = fgetc(stream);
   if (ch == '-') {
      neg = MP_NEG;
      ch = fgetc(stream);
   } else {
      neg = MP_ZPOS;
   }
   
   for (;;) {
      /* find y in the radix map */
      for (y = 0; y < radix; y++) {
          if (mp_s_rmap[y] == ch) {
             break;
          }
      }
      if (y == radix) {
         break;
      }
      
      /* shift up and add */
      if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) {
         return err;
      }
      if ((err = mp_add_d(a, y, a)) != MP_OKAY) {
         return err;
      }
      
      ch = fgetc(stream);
   }
   if (mp_cmp_d(a, 0) != MP_EQ) {
      a->sign = neg;
   }
   
   return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_fread.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_fwrite.c.









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
#include <tommath.h>
#ifdef BN_MP_FWRITE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

int mp_fwrite(mp_int *a, int radix, FILE *stream)
{
   char *buf;
   int err, len, x;
   
   if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
      return err;
   }

   buf = OPT_CAST(char) XMALLOC (len);
   if (buf == NULL) {
      return MP_MEM;
   }
   
   if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) {
      XFREE (buf);
      return err;
   }
   
   for (x = 0; x < len; x++) {
       if (fputc(buf[x], stream) == EOF) {
          XFREE (buf);
          return MP_VAL;
       }
   }
   
   XFREE (buf);
   return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_fwrite.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_gcd.c.



































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
#include <tommath.h>
#ifdef BN_MP_GCD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Greatest Common Divisor using the binary method */
int mp_gcd (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  u, v;
  int     k, u_lsb, v_lsb, res;

  /* either zero than gcd is the largest */
  if (mp_iszero (a) == 1 && mp_iszero (b) == 0) {
    return mp_abs (b, c);
  }
  if (mp_iszero (a) == 0 && mp_iszero (b) == 1) {
    return mp_abs (a, c);
  }

  /* optimized.  At this point if a == 0 then
   * b must equal zero too
   */
  if (mp_iszero (a) == 1) {
    mp_zero(c);
    return MP_OKAY;
  }

  /* get copies of a and b we can modify */
  if ((res = mp_init_copy (&u, a)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init_copy (&v, b)) != MP_OKAY) {
    goto LBL_U;
  }

  /* must be positive for the remainder of the algorithm */
  u.sign = v.sign = MP_ZPOS;

  /* B1.  Find the common power of two for u and v */
  u_lsb = mp_cnt_lsb(&u);
  v_lsb = mp_cnt_lsb(&v);
  k     = MIN(u_lsb, v_lsb);

  if (k > 0) {
     /* divide the power of two out */
     if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) {
        goto LBL_V;
     }

     if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) {
        goto LBL_V;
     }
  }

  /* divide any remaining factors of two out */
  if (u_lsb != k) {
     if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) {
        goto LBL_V;
     }
  }

  if (v_lsb != k) {
     if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) {
        goto LBL_V;
     }
  }

  while (mp_iszero(&v) == 0) {
     /* make sure v is the largest */
     if (mp_cmp_mag(&u, &v) == MP_GT) {
        /* swap u and v to make sure v is >= u */
        mp_exch(&u, &v);
     }
     
     /* subtract smallest from largest */
     if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) {
        goto LBL_V;
     }
     
     /* Divide out all factors of two */
     if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) {
        goto LBL_V;
     } 
  } 

  /* multiply by 2**k which we divided out at the beginning */
  if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) {
     goto LBL_V;
  }
  c->sign = MP_ZPOS;
  res = MP_OKAY;
LBL_V:mp_clear (&u);
LBL_U:mp_clear (&v);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_gcd.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_get_int.c.



























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
#include <tommath.h>
#ifdef BN_MP_GET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* get the lower 32-bits of an mp_int */
unsigned long mp_get_int(mp_int * a) 
{
  int i;
  unsigned long res;

  if (a->used == 0) {
     return 0;
  }

  /* get number of digits of the lsb we have to read */
  i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1;

  /* get most significant digit of result */
  res = DIGIT(a,i);
   
  while (--i >= 0) {
    res = (res << DIGIT_BIT) | DIGIT(a,i);
  }

  /* force result to 32-bits always so it is consistent on non 32-bit platforms */
  return res & 0xFFFFFFFFUL;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_get_int.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_grow.c.



















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#include <tommath.h>
#ifdef BN_MP_GROW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* grow as required */
int mp_grow (mp_int * a, int size)
{
  int     i;
  mp_digit *tmp;

  /* if the alloc size is smaller alloc more ram */
  if (a->alloc < size) {
    /* ensure there are always at least MP_PREC digits extra on top */
    size += (MP_PREC * 2) - (size % MP_PREC);

    /* reallocate the array a->dp
     *
     * We store the return in a temporary variable
     * in case the operation failed we don't want
     * to overwrite the dp member of a.
     */
    tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size);
    if (tmp == NULL) {
      /* reallocation failed but "a" is still valid [can be freed] */
      return MP_MEM;
    }

    /* reallocation succeeded so set a->dp */
    a->dp = tmp;

    /* zero excess digits */
    i        = a->alloc;
    a->alloc = size;
    for (; i < a->alloc; i++) {
      a->dp[i] = 0;
    }
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_grow.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_init.c.





























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
#include <tommath.h>
#ifdef BN_MP_INIT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* init a new mp_int */
int mp_init (mp_int * a)
{
  int i;

  /* allocate memory required and clear it */
  a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC);
  if (a->dp == NULL) {
    return MP_MEM;
  }

  /* set the digits to zero */
  for (i = 0; i < MP_PREC; i++) {
      a->dp[i] = 0;
  }

  /* set the used to zero, allocated digits to the default precision
   * and sign to positive */
  a->used  = 0;
  a->alloc = MP_PREC;
  a->sign  = MP_ZPOS;

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_init_copy.c.

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#include <tommath.h>
#ifdef BN_MP_INIT_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* creates "a" then copies b into it */
int mp_init_copy (mp_int * a, mp_int * b)
{
  int     res;

  if ((res = mp_init (a)) != MP_OKAY) {
    return res;
  }
  return mp_copy (b, a);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_copy.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_init_multi.c.























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
#include <tommath.h>
#ifdef BN_MP_INIT_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#include <stdarg.h>

int mp_init_multi(mp_int *mp, ...) 
{
    mp_err res = MP_OKAY;      /* Assume ok until proven otherwise */
    int n = 0;                 /* Number of ok inits */
    mp_int* cur_arg = mp;
    va_list args;

    va_start(args, mp);        /* init args to next argument from caller */
    while (cur_arg != NULL) {
        if (mp_init(cur_arg) != MP_OKAY) {
            /* Oops - error! Back-track and mp_clear what we already
               succeeded in init-ing, then return error.
            */
            va_list clean_args;
            
            /* end the current list */
            va_end(args);
            
            /* now start cleaning up */            
            cur_arg = mp;
            va_start(clean_args, mp);
            while (n--) {
                mp_clear(cur_arg);
                cur_arg = va_arg(clean_args, mp_int*);
            }
            va_end(clean_args);
            res = MP_MEM;
            break;
        }
        n++;
        cur_arg = va_arg(args, mp_int*);
    }
    va_end(args);
    return res;                /* Assumed ok, if error flagged above. */
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_multi.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_init_set.c.

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#include <tommath.h>
#ifdef BN_MP_INIT_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* initialize and set a digit */
int mp_init_set (mp_int * a, mp_digit b)
{
  int err;
  if ((err = mp_init(a)) != MP_OKAY) {
     return err;
  }
  mp_set(a, b);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_init_set_int.c.































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
#include <tommath.h>
#ifdef BN_MP_INIT_SET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* initialize and set a digit */
int mp_init_set_int (mp_int * a, unsigned long b)
{
  int err;
  if ((err = mp_init(a)) != MP_OKAY) {
     return err;
  }
  return mp_set_int(a, b);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set_int.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_init_size.c.

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#include <tommath.h>
#ifdef BN_MP_INIT_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* init an mp_init for a given size */
int mp_init_size (mp_int * a, int size)
{
  int x;

  /* pad size so there are always extra digits */
  size += (MP_PREC * 2) - (size % MP_PREC);	
  
  /* alloc mem */
  a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size);
  if (a->dp == NULL) {
    return MP_MEM;
  }

  /* set the members */
  a->used  = 0;
  a->alloc = size;
  a->sign  = MP_ZPOS;

  /* zero the digits */
  for (x = 0; x < size; x++) {
      a->dp[x] = 0;
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_size.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_invmod.c.























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#include <tommath.h>
#ifdef BN_MP_INVMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* hac 14.61, pp608 */
int mp_invmod (mp_int * a, mp_int * b, mp_int * c)
{
  /* b cannot be negative */
  if (b->sign == MP_NEG || mp_iszero(b) == 1) {
    return MP_VAL;
  }

#ifdef BN_FAST_MP_INVMOD_C
  /* if the modulus is odd we can use a faster routine instead */
  if (mp_isodd (b) == 1) {
    return fast_mp_invmod (a, b, c);
  }
#endif

#ifdef BN_MP_INVMOD_SLOW_C
  return mp_invmod_slow(a, b, c);
#endif

  return MP_VAL;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_invmod_slow.c.































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
#include <tommath.h>
#ifdef BN_MP_INVMOD_SLOW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* hac 14.61, pp608 */
int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  x, y, u, v, A, B, C, D;
  int     res;

  /* b cannot be negative */
  if (b->sign == MP_NEG || mp_iszero(b) == 1) {
    return MP_VAL;
  }

  /* init temps */
  if ((res = mp_init_multi(&x, &y, &u, &v, 
                           &A, &B, &C, &D, NULL)) != MP_OKAY) {
     return res;
  }

  /* x = a, y = b */
  if ((res = mp_mod(a, b, &x)) != MP_OKAY) {
      goto LBL_ERR;
  }
  if ((res = mp_copy (b, &y)) != MP_OKAY) {
    goto LBL_ERR;
  }

  /* 2. [modified] if x,y are both even then return an error! */
  if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) {
    res = MP_VAL;
    goto LBL_ERR;
  }

  /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
  if ((res = mp_copy (&x, &u)) != MP_OKAY) {
    goto LBL_ERR;
  }
  if ((res = mp_copy (&y, &v)) != MP_OKAY) {
    goto LBL_ERR;
  }
  mp_set (&A, 1);
  mp_set (&D, 1);

top:
  /* 4.  while u is even do */
  while (mp_iseven (&u) == 1) {
    /* 4.1 u = u/2 */
    if ((res = mp_div_2 (&u, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 4.2 if A or B is odd then */
    if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) {
      /* A = (A+y)/2, B = (B-x)/2 */
      if ((res = mp_add (&A, &y, &A)) != MP_OKAY) {
         goto LBL_ERR;
      }
      if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) {
         goto LBL_ERR;
      }
    }
    /* A = A/2, B = B/2 */
    if ((res = mp_div_2 (&A, &A)) != MP_OKAY) {
      goto LBL_ERR;
    }
    if ((res = mp_div_2 (&B, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 5.  while v is even do */
  while (mp_iseven (&v) == 1) {
    /* 5.1 v = v/2 */
    if ((res = mp_div_2 (&v, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 5.2 if C or D is odd then */
    if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) {
      /* C = (C+y)/2, D = (D-x)/2 */
      if ((res = mp_add (&C, &y, &C)) != MP_OKAY) {
         goto LBL_ERR;
      }
      if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) {
         goto LBL_ERR;
      }
    }
    /* C = C/2, D = D/2 */
    if ((res = mp_div_2 (&C, &C)) != MP_OKAY) {
      goto LBL_ERR;
    }
    if ((res = mp_div_2 (&D, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 6.  if u >= v then */
  if (mp_cmp (&u, &v) != MP_LT) {
    /* u = u - v, A = A - C, B = B - D */
    if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  } else {
    /* v - v - u, C = C - A, D = D - B */
    if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* if not zero goto step 4 */
  if (mp_iszero (&u) == 0)
    goto top;

  /* now a = C, b = D, gcd == g*v */

  /* if v != 1 then there is no inverse */
  if (mp_cmp_d (&v, 1) != MP_EQ) {
    res = MP_VAL;
    goto LBL_ERR;
  }

  /* if its too low */
  while (mp_cmp_d(&C, 0) == MP_LT) {
      if ((res = mp_add(&C, b, &C)) != MP_OKAY) {
         goto LBL_ERR;
      }
  }
  
  /* too big */
  while (mp_cmp_mag(&C, b) != MP_LT) {
      if ((res = mp_sub(&C, b, &C)) != MP_OKAY) {
         goto LBL_ERR;
      }
  }
  
  /* C is now the inverse */
  mp_exch (&C, c);
  res = MP_OKAY;
LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod_slow.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_is_square.c.



























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
#include <tommath.h>
#ifdef BN_MP_IS_SQUARE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Check if remainders are possible squares - fast exclude non-squares */
static const char rem_128[128] = {
 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1
};

static const char rem_105[105] = {
 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1,
 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1,
 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1,
 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,
 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1
};

/* Store non-zero to ret if arg is square, and zero if not */
int mp_is_square(mp_int *arg,int *ret) 
{
  int           res;
  mp_digit      c;
  mp_int        t;
  unsigned long r;

  /* Default to Non-square :) */
  *ret = MP_NO; 

  if (arg->sign == MP_NEG) {
    return MP_VAL;
  }

  /* digits used?  (TSD) */
  if (arg->used == 0) {
     return MP_OKAY;
  }

  /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
  if (rem_128[127 & DIGIT(arg,0)] == 1) {
     return MP_OKAY;
  }

  /* Next check mod 105 (3*5*7) */
  if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) {
     return res;
  }
  if (rem_105[c] == 1) {
     return MP_OKAY;
  }


  if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) {
     return res;
  }
  if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) {
     goto ERR;
  }
  r = mp_get_int(&t);
  /* Check for other prime modules, note it's not an ERROR but we must
   * free "t" so the easiest way is to goto ERR.  We know that res
   * is already equal to MP_OKAY from the mp_mod call 
   */ 
  if ( (1L<<(r%11)) & 0x5C4L )             goto ERR;
  if ( (1L<<(r%13)) & 0x9E4L )             goto ERR;
  if ( (1L<<(r%17)) & 0x5CE8L )            goto ERR;
  if ( (1L<<(r%19)) & 0x4F50CL )           goto ERR;
  if ( (1L<<(r%23)) & 0x7ACCA0L )          goto ERR;
  if ( (1L<<(r%29)) & 0xC2EDD0CL )         goto ERR;
  if ( (1L<<(r%31)) & 0x6DE2B848L )        goto ERR;

  /* Final check - is sqr(sqrt(arg)) == arg ? */
  if ((res = mp_sqrt(arg,&t)) != MP_OKAY) {
     goto ERR;
  }
  if ((res = mp_sqr(&t,&t)) != MP_OKAY) {
     goto ERR;
  }

  *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO;
ERR:mp_clear(&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_is_square.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_jacobi.c.



















































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
#include <tommath.h>
#ifdef BN_MP_JACOBI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes the jacobi c = (a | n) (or Legendre if n is prime)
 * HAC pp. 73 Algorithm 2.149
 */
int mp_jacobi (mp_int * a, mp_int * p, int *c)
{
  mp_int  a1, p1;
  int     k, s, r, res;
  mp_digit residue;

  /* if p <= 0 return MP_VAL */
  if (mp_cmp_d(p, 0) != MP_GT) {
     return MP_VAL;
  }

  /* step 1.  if a == 0, return 0 */
  if (mp_iszero (a) == 1) {
    *c = 0;
    return MP_OKAY;
  }

  /* step 2.  if a == 1, return 1 */
  if (mp_cmp_d (a, 1) == MP_EQ) {
    *c = 1;
    return MP_OKAY;
  }

  /* default */
  s = 0;

  /* step 3.  write a = a1 * 2**k  */
  if ((res = mp_init_copy (&a1, a)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init (&p1)) != MP_OKAY) {
    goto LBL_A1;
  }

  /* divide out larger power of two */
  k = mp_cnt_lsb(&a1);
  if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) {
     goto LBL_P1;
  }

  /* step 4.  if e is even set s=1 */
  if ((k & 1) == 0) {
    s = 1;
  } else {
    /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */
    residue = p->dp[0] & 7;

    if (residue == 1 || residue == 7) {
      s = 1;
    } else if (residue == 3 || residue == 5) {
      s = -1;
    }
  }

  /* step 5.  if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */
  if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) {
    s = -s;
  }

  /* if a1 == 1 we're done */
  if (mp_cmp_d (&a1, 1) == MP_EQ) {
    *c = s;
  } else {
    /* n1 = n mod a1 */
    if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) {
      goto LBL_P1;
    }
    if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) {
      goto LBL_P1;
    }
    *c = s * r;
  }

  /* done */
  res = MP_OKAY;
LBL_P1:mp_clear (&p1);
LBL_A1:mp_clear (&a1);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_jacobi.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_karatsuba_mul.c.















































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
#include <tommath.h>
#ifdef BN_MP_KARATSUBA_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* c = |a| * |b| using Karatsuba Multiplication using 
 * three half size multiplications
 *
 * Let B represent the radix [e.g. 2**DIGIT_BIT] and 
 * let n represent half of the number of digits in 
 * the min(a,b)
 *
 * a = a1 * B**n + a0
 * b = b1 * B**n + b0
 *
 * Then, a * b => 
   a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0
 *
 * Note that a1b1 and a0b0 are used twice and only need to be 
 * computed once.  So in total three half size (half # of 
 * digit) multiplications are performed, a0b0, a1b1 and 
 * (a1+b1)(a0+b0)
 *
 * Note that a multiplication of half the digits requires
 * 1/4th the number of single precision multiplications so in 
 * total after one call 25% of the single precision multiplications 
 * are saved.  Note also that the call to mp_mul can end up back 
 * in this function if the a0, a1, b0, or b1 are above the threshold.  
 * This is known as divide-and-conquer and leads to the famous 
 * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than 
 * the standard O(N**2) that the baseline/comba methods use.  
 * Generally though the overhead of this method doesn't pay off 
 * until a certain size (N ~ 80) is reached.
 */
int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  x0, x1, y0, y1, t1, x0y0, x1y1;
  int     B, err;

  /* default the return code to an error */
  err = MP_MEM;

  /* min # of digits */
  B = MIN (a->used, b->used);

  /* now divide in two */
  B = B >> 1;

  /* init copy all the temps */
  if (mp_init_size (&x0, B) != MP_OKAY)
    goto ERR;
  if (mp_init_size (&x1, a->used - B) != MP_OKAY)
    goto X0;
  if (mp_init_size (&y0, B) != MP_OKAY)
    goto X1;
  if (mp_init_size (&y1, b->used - B) != MP_OKAY)
    goto Y0;

  /* init temps */
  if (mp_init_size (&t1, B * 2) != MP_OKAY)
    goto Y1;
  if (mp_init_size (&x0y0, B * 2) != MP_OKAY)
    goto T1;
  if (mp_init_size (&x1y1, B * 2) != MP_OKAY)
    goto X0Y0;

  /* now shift the digits */
  x0.used = y0.used = B;
  x1.used = a->used - B;
  y1.used = b->used - B;

  {
    register int x;
    register mp_digit *tmpa, *tmpb, *tmpx, *tmpy;

    /* we copy the digits directly instead of using higher level functions
     * since we also need to shift the digits
     */
    tmpa = a->dp;
    tmpb = b->dp;

    tmpx = x0.dp;
    tmpy = y0.dp;
    for (x = 0; x < B; x++) {
      *tmpx++ = *tmpa++;
      *tmpy++ = *tmpb++;
    }

    tmpx = x1.dp;
    for (x = B; x < a->used; x++) {
      *tmpx++ = *tmpa++;
    }

    tmpy = y1.dp;
    for (x = B; x < b->used; x++) {
      *tmpy++ = *tmpb++;
    }
  }

  /* only need to clamp the lower words since by definition the 
   * upper words x1/y1 must have a known number of digits
   */
  mp_clamp (&x0);
  mp_clamp (&y0);

  /* now calc the products x0y0 and x1y1 */
  /* after this x0 is no longer required, free temp [x0==t2]! */
  if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY)  
    goto X1Y1;          /* x0y0 = x0*y0 */
  if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY)
    goto X1Y1;          /* x1y1 = x1*y1 */

  /* now calc x1+x0 and y1+y0 */
  if (s_mp_add (&x1, &x0, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = x1 - x0 */
  if (s_mp_add (&y1, &y0, &x0) != MP_OKAY)
    goto X1Y1;          /* t2 = y1 - y0 */
  if (mp_mul (&t1, &x0, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = (x1 + x0) * (y1 + y0) */

  /* add x0y0 */
  if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY)
    goto X1Y1;          /* t2 = x0y0 + x1y1 */
  if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */

  /* shift by B */
  if (mp_lshd (&t1, B) != MP_OKAY)
    goto X1Y1;          /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<<B */
  if (mp_lshd (&x1y1, B * 2) != MP_OKAY)
    goto X1Y1;          /* x1y1 = x1y1 << 2*B */

  if (mp_add (&x0y0, &t1, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = x0y0 + t1 */
  if (mp_add (&t1, &x1y1, c) != MP_OKAY)
    goto X1Y1;          /* t1 = x0y0 + t1 + x1y1 */

  /* Algorithm succeeded set the return code to MP_OKAY */
  err = MP_OKAY;

X1Y1:mp_clear (&x1y1);
X0Y0:mp_clear (&x0y0);
T1:mp_clear (&t1);
Y1:mp_clear (&y1);
Y0:mp_clear (&y0);
X1:mp_clear (&x1);
X0:mp_clear (&x0);
ERR:
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_karatsuba_mul.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_karatsuba_sqr.c.



















































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#include <tommath.h>
#ifdef BN_MP_KARATSUBA_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Karatsuba squaring, computes b = a*a using three 
 * half size squarings
 *
 * See comments of karatsuba_mul for details.  It 
 * is essentially the same algorithm but merely 
 * tuned to perform recursive squarings.
 */
int mp_karatsuba_sqr (mp_int * a, mp_int * b)
{
  mp_int  x0, x1, t1, t2, x0x0, x1x1;
  int     B, err;

  err = MP_MEM;

  /* min # of digits */
  B = a->used;

  /* now divide in two */
  B = B >> 1;

  /* init copy all the temps */
  if (mp_init_size (&x0, B) != MP_OKAY)
    goto ERR;
  if (mp_init_size (&x1, a->used - B) != MP_OKAY)
    goto X0;

  /* init temps */
  if (mp_init_size (&t1, a->used * 2) != MP_OKAY)
    goto X1;
  if (mp_init_size (&t2, a->used * 2) != MP_OKAY)
    goto T1;
  if (mp_init_size (&x0x0, B * 2) != MP_OKAY)
    goto T2;
  if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY)
    goto X0X0;

  {
    register int x;
    register mp_digit *dst, *src;

    src = a->dp;

    /* now shift the digits */
    dst = x0.dp;
    for (x = 0; x < B; x++) {
      *dst++ = *src++;
    }

    dst = x1.dp;
    for (x = B; x < a->used; x++) {
      *dst++ = *src++;
    }
  }

  x0.used = B;
  x1.used = a->used - B;

  mp_clamp (&x0);

  /* now calc the products x0*x0 and x1*x1 */
  if (mp_sqr (&x0, &x0x0) != MP_OKAY)
    goto X1X1;           /* x0x0 = x0*x0 */
  if (mp_sqr (&x1, &x1x1) != MP_OKAY)
    goto X1X1;           /* x1x1 = x1*x1 */

  /* now calc (x1+x0)**2 */
  if (s_mp_add (&x1, &x0, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = x1 - x0 */
  if (mp_sqr (&t1, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = (x1 - x0) * (x1 - x0) */

  /* add x0y0 */
  if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY)
    goto X1X1;           /* t2 = x0x0 + x1x1 */
  if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */

  /* shift by B */
  if (mp_lshd (&t1, B) != MP_OKAY)
    goto X1X1;           /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<<B */
  if (mp_lshd (&x1x1, B * 2) != MP_OKAY)
    goto X1X1;           /* x1x1 = x1x1 << 2*B */

  if (mp_add (&x0x0, &t1, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = x0x0 + t1 */
  if (mp_add (&t1, &x1x1, b) != MP_OKAY)
    goto X1X1;           /* t1 = x0x0 + t1 + x1x1 */

  err = MP_OKAY;

X1X1:mp_clear (&x1x1);
X0X0:mp_clear (&x0x0);
T2:mp_clear (&t2);
T1:mp_clear (&t1);
X1:mp_clear (&x1);
X0:mp_clear (&x0);
ERR:
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_karatsuba_sqr.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_lcm.c.

























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
#include <tommath.h>
#ifdef BN_MP_LCM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes least common multiple as |a*b|/(a, b) */
int mp_lcm (mp_int * a, mp_int * b, mp_int * c)
{
  int     res;
  mp_int  t1, t2;


  if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) {
    return res;
  }

  /* t1 = get the GCD of the two inputs */
  if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) {
    goto LBL_T;
  }

  /* divide the smallest by the GCD */
  if (mp_cmp_mag(a, b) == MP_LT) {
     /* store quotient in t2 such that t2 * b is the LCM */
     if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) {
        goto LBL_T;
     }
     res = mp_mul(b, &t2, c);
  } else {
     /* store quotient in t2 such that t2 * a is the LCM */
     if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) {
        goto LBL_T;
     }
     res = mp_mul(a, &t2, c);
  }

  /* fix the sign to positive */
  c->sign = MP_ZPOS;

LBL_T:
  mp_clear_multi (&t1, &t2, NULL);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lcm.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_lshd.c.







































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
#include <tommath.h>
#ifdef BN_MP_LSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift left a certain amount of digits */
int mp_lshd (mp_int * a, int b)
{
  int     x, res;

  /* if its less than zero return */
  if (b <= 0) {
    return MP_OKAY;
  }

  /* grow to fit the new digits */
  if (a->alloc < a->used + b) {
     if ((res = mp_grow (a, a->used + b)) != MP_OKAY) {
       return res;
     }
  }

  {
    register mp_digit *top, *bottom;

    /* increment the used by the shift amount then copy upwards */
    a->used += b;

    /* top */
    top = a->dp + a->used - 1;

    /* base */
    bottom = a->dp + a->used - 1 - b;

    /* much like mp_rshd this is implemented using a sliding window
     * except the window goes the otherway around.  Copying from
     * the bottom to the top.  see bn_mp_rshd.c for more info.
     */
    for (x = a->used - 1; x >= b; x--) {
      *top-- = *bottom--;
    }

    /* zero the lower digits */
    top = a->dp;
    for (x = 0; x < b; x++) {
      *top++ = 0;
    }
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lshd.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mod.c.

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#include <tommath.h>
#ifdef BN_MP_MOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* c = a mod b, 0 <= c < b */
int
mp_mod (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  t;
  int     res;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }

  if (t.sign != b->sign) {
    res = mp_add (b, &t, c);
  } else {
    res = MP_OKAY;
    mp_exch (&t, c);
  }

  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mod_2d.c.















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
#include <tommath.h>
#ifdef BN_MP_MOD_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* calc a value mod 2**b */
int
mp_mod_2d (mp_int * a, int b, mp_int * c)
{
  int     x, res;

  /* if b is <= 0 then zero the int */
  if (b <= 0) {
    mp_zero (c);
    return MP_OKAY;
  }

  /* if the modulus is larger than the value than return */
  if (b >= (int) (a->used * DIGIT_BIT)) {
    res = mp_copy (a, c);
    return res;
  }

  /* copy */
  if ((res = mp_copy (a, c)) != MP_OKAY) {
    return res;
  }

  /* zero digits above the last digit of the modulus */
  for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) {
    c->dp[x] = 0;
  }
  /* clear the digit that is not completely outside/inside the modulus */
  c->dp[b / DIGIT_BIT] &=
    (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1));
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_2d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mod_d.c.























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#include <tommath.h>
#ifdef BN_MP_MOD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

int
mp_mod_d (mp_int * a, mp_digit b, mp_digit * c)
{
  return mp_div_d(a, b, NULL, c);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_montgomery_calc_normalization.c.























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
#include <tommath.h>
#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/*
 * shifts with subtractions when the result is greater than b.
 *
 * The method is slightly modified to shift B unconditionally upto just under
 * the leading bit of b.  This saves alot of multiple precision shifting.
 */
int mp_montgomery_calc_normalization (mp_int * a, mp_int * b)
{
  int     x, bits, res;

  /* how many bits of last digit does b use */
  bits = mp_count_bits (b) % DIGIT_BIT;

  if (b->used > 1) {
     if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) {
        return res;
     }
  } else {
     mp_set(a, 1);
     bits = 1;
  }


  /* now compute C = A * B mod b */
  for (x = bits - 1; x < (int)DIGIT_BIT; x++) {
    if ((res = mp_mul_2 (a, a)) != MP_OKAY) {
      return res;
    }
    if (mp_cmp_mag (a, b) != MP_LT) {
      if ((res = s_mp_sub (a, b, a)) != MP_OKAY) {
        return res;
      }
    }
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_montgomery_reduce.c.













































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#include <tommath.h>
#ifdef BN_MP_MONTGOMERY_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes xR**-1 == x (mod N) via Montgomery Reduction */
int
mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho)
{
  int     ix, res, digs;
  mp_digit mu;

  /* can the fast reduction [comba] method be used?
   *
   * Note that unlike in mul you're safely allowed *less*
   * than the available columns [255 per default] since carries
   * are fixed up in the inner loop.
   */
  digs = n->used * 2 + 1;
  if ((digs < MP_WARRAY) &&
      n->used <
      (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
    return fast_mp_montgomery_reduce (x, n, rho);
  }

  /* grow the input as required */
  if (x->alloc < digs) {
    if ((res = mp_grow (x, digs)) != MP_OKAY) {
      return res;
    }
  }
  x->used = digs;

  for (ix = 0; ix < n->used; ix++) {
    /* mu = ai * rho mod b
     *
     * The value of rho must be precalculated via
     * montgomery_setup() such that
     * it equals -1/n0 mod b this allows the
     * following inner loop to reduce the
     * input one digit at a time
     */
    mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK);

    /* a = a + mu * m * b**i */
    {
      register int iy;
      register mp_digit *tmpn, *tmpx, u;
      register mp_word r;

      /* alias for digits of the modulus */
      tmpn = n->dp;

      /* alias for the digits of x [the input] */
      tmpx = x->dp + ix;

      /* set the carry to zero */
      u = 0;

      /* Multiply and add in place */
      for (iy = 0; iy < n->used; iy++) {
        /* compute product and sum */
        r       = ((mp_word)mu) * ((mp_word)*tmpn++) +
                  ((mp_word) u) + ((mp_word) * tmpx);

        /* get carry */
        u       = (mp_digit)(r >> ((mp_word) DIGIT_BIT));

        /* fix digit */
        *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK));
      }
      /* At this point the ix'th digit of x should be zero */


      /* propagate carries upwards as required*/
      while (u) {
        *tmpx   += u;
        u        = *tmpx >> DIGIT_BIT;
        *tmpx++ &= MP_MASK;
      }
    }
  }

  /* at this point the n.used'th least
   * significant digits of x are all zero
   * which means we can shift x to the
   * right by n.used digits and the
   * residue is unchanged.
   */

  /* x = x/b**n.used */
  mp_clamp(x);
  mp_rshd (x, n->used);

  /* if x >= n then x = x - n */
  if (mp_cmp_mag (x, n) != MP_LT) {
    return s_mp_sub (x, n, x);
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_reduce.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_montgomery_setup.c.























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
#include <tommath.h>
#ifdef BN_MP_MONTGOMERY_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* setups the montgomery reduction stuff */
int
mp_montgomery_setup (mp_int * n, mp_digit * rho)
{
  mp_digit x, b;

/* fast inversion mod 2**k
 *
 * Based on the fact that
 *
 * XA = 1 (mod 2**n)  =>  (X(2-XA)) A = 1 (mod 2**2n)
 *                    =>  2*X*A - X*X*A*A = 1
 *                    =>  2*(1) - (1)     = 1
 */
  b = n->dp[0];

  if ((b & 1) == 0) {
    return MP_VAL;
  }

  x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */
  x *= 2 - b * x;               /* here x*a==1 mod 2**8 */
#if !defined(MP_8BIT)
  x *= 2 - b * x;               /* here x*a==1 mod 2**16 */
#endif
#if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT))
  x *= 2 - b * x;               /* here x*a==1 mod 2**32 */
#endif
#ifdef MP_64BIT
  x *= 2 - b * x;               /* here x*a==1 mod 2**64 */
#endif

  /* rho = -1/m mod b */
  *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK;

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_setup.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mul.c.





































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
#include <tommath.h>
#ifdef BN_MP_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* high level multiplication (handles sign) */
int mp_mul (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, neg;
  neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;

  /* use Toom-Cook? */
#ifdef BN_MP_TOOM_MUL_C
  if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) {
    res = mp_toom_mul(a, b, c);
  } else 
#endif
#ifdef BN_MP_KARATSUBA_MUL_C
  /* use Karatsuba? */
  if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) {
    res = mp_karatsuba_mul (a, b, c);
  } else 
#endif
  {
    /* can we use the fast multiplier?
     *
     * The fast multiplier can be used if the output will 
     * have less than MP_WARRAY digits and the number of 
     * digits won't affect carry propagation
     */
    int     digs = a->used + b->used + 1;

#ifdef BN_FAST_S_MP_MUL_DIGS_C
    if ((digs < MP_WARRAY) &&
        MIN(a->used, b->used) <= 
        (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
      res = fast_s_mp_mul_digs (a, b, c, digs);
    } else 
#endif
#ifdef BN_S_MP_MUL_DIGS_C
      res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */
#else
      res = MP_VAL;
#endif

  }
  c->sign = (c->used > 0) ? neg : MP_ZPOS;
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mul_2.c.





































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
#include <tommath.h>
#ifdef BN_MP_MUL_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = a*2 */
int mp_mul_2(mp_int * a, mp_int * b)
{
  int     x, res, oldused;

  /* grow to accomodate result */
  if (b->alloc < a->used + 1) {
    if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) {
      return res;
    }
  }

  oldused = b->used;
  b->used = a->used;

  {
    register mp_digit r, rr, *tmpa, *tmpb;

    /* alias for source */
    tmpa = a->dp;
    
    /* alias for dest */
    tmpb = b->dp;

    /* carry */
    r = 0;
    for (x = 0; x < a->used; x++) {
    
      /* get what will be the *next* carry bit from the 
       * MSB of the current digit 
       */
      rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1));
      
      /* now shift up this digit, add in the carry [from the previous] */
      *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK;
      
      /* copy the carry that would be from the source 
       * digit into the next iteration 
       */
      r = rr;
    }

    /* new leading digit? */
    if (r != 0) {
      /* add a MSB which is always 1 at this point */
      *tmpb = 1;
      ++(b->used);
    }

    /* now zero any excess digits on the destination 
     * that we didn't write to 
     */
    tmpb = b->dp + b->used;
    for (x = b->used; x < oldused; x++) {
      *tmpb++ = 0;
    }
  }
  b->sign = a->sign;
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mul_2d.c.











































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
#include <tommath.h>
#ifdef BN_MP_MUL_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift left by a certain bit count */
int mp_mul_2d (mp_int * a, int b, mp_int * c)
{
  mp_digit d;
  int      res;

  /* copy */
  if (a != c) {
     if ((res = mp_copy (a, c)) != MP_OKAY) {
       return res;
     }
  }

  if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) {
     if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) {
       return res;
     }
  }

  /* shift by as many digits in the bit count */
  if (b >= (int)DIGIT_BIT) {
    if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) {
      return res;
    }
  }

  /* shift any bit count < DIGIT_BIT */
  d = (mp_digit) (b % DIGIT_BIT);
  if (d != 0) {
    register mp_digit *tmpc, shift, mask, r, rr;
    register int x;

    /* bitmask for carries */
    mask = (((mp_digit)1) << d) - 1;

    /* shift for msbs */
    shift = DIGIT_BIT - d;

    /* alias */
    tmpc = c->dp;

    /* carry */
    r    = 0;
    for (x = 0; x < c->used; x++) {
      /* get the higher bits of the current word */
      rr = (*tmpc >> shift) & mask;

      /* shift the current word and OR in the carry */
      *tmpc = ((*tmpc << d) | r) & MP_MASK;
      ++tmpc;

      /* set the carry to the carry bits of the current word */
      r = rr;
    }
    
    /* set final carry */
    if (r != 0) {
       c->dp[(c->used)++] = r;
    }
  }
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mul_d.c.































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
#include <tommath.h>
#ifdef BN_MP_MUL_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiply by a digit */
int
mp_mul_d (mp_int * a, mp_digit b, mp_int * c)
{
  mp_digit u, *tmpa, *tmpc;
  mp_word  r;
  int      ix, res, olduse;

  /* make sure c is big enough to hold a*b */
  if (c->alloc < a->used + 1) {
    if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) {
      return res;
    }
  }

  /* get the original destinations used count */
  olduse = c->used;

  /* set the sign */
  c->sign = a->sign;

  /* alias for a->dp [source] */
  tmpa = a->dp;

  /* alias for c->dp [dest] */
  tmpc = c->dp;

  /* zero carry */
  u = 0;

  /* compute columns */
  for (ix = 0; ix < a->used; ix++) {
    /* compute product and carry sum for this term */
    r       = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b);

    /* mask off higher bits to get a single digit */
    *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK));

    /* send carry into next iteration */
    u       = (mp_digit) (r >> ((mp_word) DIGIT_BIT));
  }

  /* store final carry [if any] and increment ix offset  */
  *tmpc++ = u;
  ++ix;

  /* now zero digits above the top */
  while (ix++ < olduse) {
     *tmpc++ = 0;
  }

  /* set used count */
  c->used = a->used + 1;
  mp_clamp(c);

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_d.c,v $ */
/* $Revision: 1.1.1.1.2.3 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_mulmod.c.

















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#include <tommath.h>
#ifdef BN_MP_MULMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* d = a * b (mod c) */
int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  int     res;
  mp_int  t;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_mul (a, b, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, c, d);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mulmod.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_n_root.c.









































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#include <tommath.h>
#ifdef BN_MP_N_ROOT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* find the n'th root of an integer 
 *
 * Result found such that (c)**b <= a and (c+1)**b > a 
 *
 * This algorithm uses Newton's approximation 
 * x[i+1] = x[i] - f(x[i])/f'(x[i]) 
 * which will find the root in log(N) time where 
 * each step involves a fair bit.  This is not meant to 
 * find huge roots [square and cube, etc].
 */
int mp_n_root (mp_int * a, mp_digit b, mp_int * c)
{
  mp_int  t1, t2, t3;
  int     res, neg;

  /* input must be positive if b is even */
  if ((b & 1) == 0 && a->sign == MP_NEG) {
    return MP_VAL;
  }

  if ((res = mp_init (&t1)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init (&t2)) != MP_OKAY) {
    goto LBL_T1;
  }

  if ((res = mp_init (&t3)) != MP_OKAY) {
    goto LBL_T2;
  }

  /* if a is negative fudge the sign but keep track */
  neg     = a->sign;
  a->sign = MP_ZPOS;

  /* t2 = 2 */
  mp_set (&t2, 2);

  do {
    /* t1 = t2 */
    if ((res = mp_copy (&t2, &t1)) != MP_OKAY) {
      goto LBL_T3;
    }

    /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */
    
    /* t3 = t1**(b-1) */
    if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) {   
      goto LBL_T3;
    }

    /* numerator */
    /* t2 = t1**b */
    if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) {    
      goto LBL_T3;
    }

    /* t2 = t1**b - a */
    if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) {  
      goto LBL_T3;
    }

    /* denominator */
    /* t3 = t1**(b-1) * b  */
    if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) {    
      goto LBL_T3;
    }

    /* t3 = (t1**b - a)/(b * t1**(b-1)) */
    if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) {  
      goto LBL_T3;
    }

    if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) {
      goto LBL_T3;
    }
  }  while (mp_cmp (&t1, &t2) != MP_EQ);

  /* result can be off by a few so check */
  for (;;) {
    if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) {
      goto LBL_T3;
    }

    if (mp_cmp (&t2, a) == MP_GT) {
      if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) {
         goto LBL_T3;
      }
    } else {
      break;
    }
  }

  /* reset the sign of a first */
  a->sign = neg;

  /* set the result */
  mp_exch (&t1, c);

  /* set the sign of the result */
  c->sign = neg;

  res = MP_OKAY;

LBL_T3:mp_clear (&t3);
LBL_T2:mp_clear (&t2);
LBL_T1:mp_clear (&t1);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_n_root.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_neg.c.

















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#include <tommath.h>
#ifdef BN_MP_NEG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = -a */
int mp_neg (mp_int * a, mp_int * b)
{
  int     res;
  if (a != b) {
     if ((res = mp_copy (a, b)) != MP_OKAY) {
        return res;
     }
  }

  if (mp_iszero(b) != MP_YES) {
     b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS;
  } else {
     b->sign = MP_ZPOS;
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_neg.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_or.c.





































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
#include <tommath.h>
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* OR two ints together */
int mp_or (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, ix, px;
  mp_int  t, *x;

  if (a->used > b->used) {
    if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
      return res;
    }
    px = b->used;
    x = b;
  } else {
    if ((res = mp_init_copy (&t, b)) != MP_OKAY) {
      return res;
    }
    px = a->used;
    x = a;
  }

  for (ix = 0; ix < px; ix++) {
    t.dp[ix] |= x->dp[ix];
  }
  mp_clamp (&t);
  mp_exch (c, &t);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_or.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_fermat.c.





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
#include <tommath.h>
#ifdef BN_MP_PRIME_FERMAT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* performs one Fermat test.
 * 
 * If "a" were prime then b**a == b (mod a) since the order of
 * the multiplicative sub-group would be phi(a) = a-1.  That means
 * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a).
 *
 * Sets result to 1 if the congruence holds, or zero otherwise.
 */
int mp_prime_fermat (mp_int * a, mp_int * b, int *result)
{
  mp_int  t;
  int     err;

  /* default to composite  */
  *result = MP_NO;

  /* ensure b > 1 */
  if (mp_cmp_d(b, 1) != MP_GT) {
     return MP_VAL;
  }

  /* init t */
  if ((err = mp_init (&t)) != MP_OKAY) {
    return err;
  }

  /* compute t = b**a mod a */
  if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) {
    goto LBL_T;
  }

  /* is it equal to b? */
  if (mp_cmp (&t, b) == MP_EQ) {
    *result = MP_YES;
  }

  err = MP_OKAY;
LBL_T:mp_clear (&t);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_fermat.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_is_divisible.c.





































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
#include <tommath.h>
#ifdef BN_MP_PRIME_IS_DIVISIBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if an integers is divisible by one 
 * of the first PRIME_SIZE primes or not
 *
 * sets result to 0 if not, 1 if yes
 */
int mp_prime_is_divisible (mp_int * a, int *result)
{
  int     err, ix;
  mp_digit res;

  /* default to not */
  *result = MP_NO;

  for (ix = 0; ix < PRIME_SIZE; ix++) {
    /* what is a mod LBL_prime_tab[ix] */
    if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) {
      return err;
    }

    /* is the residue zero? */
    if (res == 0) {
      *result = MP_YES;
      return MP_OKAY;
    }
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_divisible.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_is_prime.c.







































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
#include <tommath.h>
#ifdef BN_MP_PRIME_IS_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* performs a variable number of rounds of Miller-Rabin
 *
 * Probability of error after t rounds is no more than

 *
 * Sets result to 1 if probably prime, 0 otherwise
 */
int mp_prime_is_prime (mp_int * a, int t, int *result)
{
  mp_int  b;
  int     ix, err, res;

  /* default to no */
  *result = MP_NO;

  /* valid value of t? */
  if (t <= 0 || t > PRIME_SIZE) {
    return MP_VAL;
  }

  /* is the input equal to one of the primes in the table? */
  for (ix = 0; ix < PRIME_SIZE; ix++) {
      if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) {
         *result = 1;
         return MP_OKAY;
      }
  }

  /* first perform trial division */
  if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) {
    return err;
  }

  /* return if it was trivially divisible */
  if (res == MP_YES) {
    return MP_OKAY;
  }

  /* now perform the miller-rabin rounds */
  if ((err = mp_init (&b)) != MP_OKAY) {
    return err;
  }

  for (ix = 0; ix < t; ix++) {
    /* set the prime */
    mp_set (&b, ltm_prime_tab[ix]);

    if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) {
      goto LBL_B;
    }

    if (res == MP_NO) {
      goto LBL_B;
    }
  }

  /* passed the test */
  *result = MP_YES;
LBL_B:mp_clear (&b);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_prime.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_miller_rabin.c.















































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
#include <tommath.h>
#ifdef BN_MP_PRIME_MILLER_RABIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Miller-Rabin test of "a" to the base of "b" as described in 
 * HAC pp. 139 Algorithm 4.24
 *
 * Sets result to 0 if definitely composite or 1 if probably prime.
 * Randomly the chance of error is no more than 1/4 and often 
 * very much lower.
 */
int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result)
{
  mp_int  n1, y, r;
  int     s, j, err;

  /* default */
  *result = MP_NO;

  /* ensure b > 1 */
  if (mp_cmp_d(b, 1) != MP_GT) {
     return MP_VAL;
  }     

  /* get n1 = a - 1 */
  if ((err = mp_init_copy (&n1, a)) != MP_OKAY) {
    return err;
  }
  if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) {
    goto LBL_N1;
  }

  /* set 2**s * r = n1 */
  if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) {
    goto LBL_N1;
  }

  /* count the number of least significant bits
   * which are zero
   */
  s = mp_cnt_lsb(&r);

  /* now divide n - 1 by 2**s */
  if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) {
    goto LBL_R;
  }

  /* compute y = b**r mod a */
  if ((err = mp_init (&y)) != MP_OKAY) {
    goto LBL_R;
  }
  if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) {
    goto LBL_Y;
  }

  /* if y != 1 and y != n1 do */
  if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) {
    j = 1;
    /* while j <= s-1 and y != n1 */
    while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) {
      if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) {
         goto LBL_Y;
      }

      /* if y == 1 then composite */
      if (mp_cmp_d (&y, 1) == MP_EQ) {
         goto LBL_Y;
      }

      ++j;
    }

    /* if y != n1 then composite */
    if (mp_cmp (&y, &n1) != MP_EQ) {
      goto LBL_Y;
    }
  }

  /* probably prime now */
  *result = MP_YES;
LBL_Y:mp_clear (&y);
LBL_R:mp_clear (&r);
LBL_N1:mp_clear (&n1);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_miller_rabin.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_next_prime.c.





















































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
#include <tommath.h>
#ifdef BN_MP_PRIME_NEXT_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* finds the next prime after the number "a" using "t" trials
 * of Miller-Rabin.
 *
 * bbs_style = 1 means the prime must be congruent to 3 mod 4
 */
int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
{
   int      err, res, x, y;
   mp_digit res_tab[PRIME_SIZE], step, kstep;
   mp_int   b;

   /* ensure t is valid */
   if (t <= 0 || t > PRIME_SIZE) {
      return MP_VAL;
   }

   /* force positive */
   a->sign = MP_ZPOS;

   /* simple algo if a is less than the largest prime in the table */
   if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) {
      /* find which prime it is bigger than */
      for (x = PRIME_SIZE - 2; x >= 0; x--) {
          if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) {
             if (bbs_style == 1) {
                /* ok we found a prime smaller or
                 * equal [so the next is larger]
                 *
                 * however, the prime must be
                 * congruent to 3 mod 4
                 */
                if ((ltm_prime_tab[x + 1] & 3) != 3) {
                   /* scan upwards for a prime congruent to 3 mod 4 */
                   for (y = x + 1; y < PRIME_SIZE; y++) {
                       if ((ltm_prime_tab[y] & 3) == 3) {
                          mp_set(a, ltm_prime_tab[y]);
                          return MP_OKAY;
                       }
                   }
                }
             } else {
                mp_set(a, ltm_prime_tab[x + 1]);
                return MP_OKAY;
             }
          }
      }
      /* at this point a maybe 1 */
      if (mp_cmp_d(a, 1) == MP_EQ) {
         mp_set(a, 2);
         return MP_OKAY;
      }
      /* fall through to the sieve */
   }

   /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */
   if (bbs_style == 1) {
      kstep   = 4;
   } else {
      kstep   = 2;
   }

   /* at this point we will use a combination of a sieve and Miller-Rabin */

   if (bbs_style == 1) {
      /* if a mod 4 != 3 subtract the correct value to make it so */
      if ((a->dp[0] & 3) != 3) {
         if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; };
      }
   } else {
      if (mp_iseven(a) == 1) {
         /* force odd */
         if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) {
            return err;
         }
      }
   }

   /* generate the restable */
   for (x = 1; x < PRIME_SIZE; x++) {
      if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) {
         return err;
      }
   }

   /* init temp used for Miller-Rabin Testing */
   if ((err = mp_init(&b)) != MP_OKAY) {
      return err;
   }

   for (;;) {
      /* skip to the next non-trivially divisible candidate */
      step = 0;
      do {
         /* y == 1 if any residue was zero [e.g. cannot be prime] */
         y     =  0;

         /* increase step to next candidate */
         step += kstep;

         /* compute the new residue without using division */
         for (x = 1; x < PRIME_SIZE; x++) {
             /* add the step to each residue */
             res_tab[x] += kstep;

             /* subtract the modulus [instead of using division] */
             if (res_tab[x] >= ltm_prime_tab[x]) {
                res_tab[x]  -= ltm_prime_tab[x];
             }

             /* set flag if zero */
             if (res_tab[x] == 0) {
                y = 1;
             }
         }
      } while (y == 1 && step < ((((mp_digit)1)<<DIGIT_BIT) - kstep));

      /* add the step */
      if ((err = mp_add_d(a, step, a)) != MP_OKAY) {
         goto LBL_ERR;
      }

      /* if didn't pass sieve and step == MAX then skip test */
      if (y == 1 && step >= ((((mp_digit)1)<<DIGIT_BIT) - kstep)) {
         continue;
      }

      /* is this prime? */
      for (x = 0; x < t; x++) {
          mp_set(&b, ltm_prime_tab[t]);
          if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
             goto LBL_ERR;
          }
          if (res == MP_NO) {
             break;
          }
      }

      if (res == MP_YES) {
         break;
      }
   }

   err = MP_OKAY;
LBL_ERR:
   mp_clear(&b);
   return err;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_next_prime.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_rabin_miller_trials.c.









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
#include <tommath.h>
#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */


static const struct {
   int k, t;
} sizes[] = {
{   128,    28 },
{   256,    16 },
{   384,    10 },
{   512,     7 },
{   640,     6 },
{   768,     5 },
{   896,     4 },
{  1024,     4 }
};

/* returns # of RM trials required for a given bit size */
int mp_prime_rabin_miller_trials(int size)
{
   int x;

   for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) {
       if (sizes[x].k == size) {
          return sizes[x].t;
       } else if (sizes[x].k > size) {
          return (x == 0) ? sizes[0].t : sizes[x - 1].t;
       }
   }
   return sizes[x-1].t + 1;
}


#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_prime_random_ex.c.



























































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
#include <tommath.h>
#ifdef BN_MP_PRIME_RANDOM_EX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* makes a truly random prime of a given size (bits),
 *
 * Flags are as follows:
 * 
 *   LTM_PRIME_BBS      - make prime congruent to 3 mod 4
 *   LTM_PRIME_SAFE     - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS)
 *   LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero
 *   LTM_PRIME_2MSB_ON  - make the 2nd highest bit one
 *
 * You have to supply a callback which fills in a buffer with random bytes.  "dat" is a parameter you can
 * have passed to the callback (e.g. a state or something).  This function doesn't use "dat" itself
 * so it can be NULL
 *
 */

/* This is possibly the mother of all prime generation functions, muahahahahaha! */
int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat)
{
   unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb;
   int res, err, bsize, maskOR_msb_offset;

   /* sanity check the input */
   if (size <= 1 || t <= 0) {
      return MP_VAL;
   }

   /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */
   if (flags & LTM_PRIME_SAFE) {
      flags |= LTM_PRIME_BBS;
   }

   /* calc the byte size */
   bsize = (size>>3) + ((size&7)?1:0);

   /* we need a buffer of bsize bytes */
   tmp = OPT_CAST(unsigned char) XMALLOC(bsize);
   if (tmp == NULL) {
      return MP_MEM;
   }

   /* calc the maskAND value for the MSbyte*/
   maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7)));

   /* calc the maskOR_msb */
   maskOR_msb        = 0;
   maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
   if (flags & LTM_PRIME_2MSB_ON) {
      maskOR_msb       |= 0x80 >> ((9 - size) & 7);
   }  

   /* get the maskOR_lsb */
   maskOR_lsb         = 1;
   if (flags & LTM_PRIME_BBS) {
      maskOR_lsb     |= 3;
   }

   do {
      /* read the bytes */
      if (cb(tmp, bsize, dat) != bsize) {
         err = MP_VAL;
         goto error;
      }
 
      /* work over the MSbyte */
      tmp[0]    &= maskAND;
      tmp[0]    |= 1 << ((size - 1) & 7);

      /* mix in the maskORs */
      tmp[maskOR_msb_offset]   |= maskOR_msb;
      tmp[bsize-1]             |= maskOR_lsb;

      /* read it in */
      if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY)     { goto error; }

      /* is it prime? */
      if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY)           { goto error; }
      if (res == MP_NO) {  
         continue;
      }

      if (flags & LTM_PRIME_SAFE) {
         /* see if (a-1)/2 is prime */
         if ((err = mp_sub_d(a, 1, a)) != MP_OKAY)                    { goto error; }
         if ((err = mp_div_2(a, a)) != MP_OKAY)                       { goto error; }
 
         /* is it prime? */
         if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY)        { goto error; }
      }
   } while (res == MP_NO);

   if (flags & LTM_PRIME_SAFE) {
      /* restore a to the original value */
      if ((err = mp_mul_2(a, a)) != MP_OKAY)                          { goto error; }
      if ((err = mp_add_d(a, 1, a)) != MP_OKAY)                       { goto error; }
   }

   err = MP_OKAY;
error:
   XFREE(tmp);
   return err;
}


#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_random_ex.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_radix_size.c.















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
#include <tommath.h>
#ifdef BN_MP_RADIX_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* returns size of ASCII reprensentation */
int mp_radix_size (mp_int * a, int radix, int *size)
{
  int     res, digs;
  mp_int  t;
  mp_digit d;

  *size = 0;

  /* special case for binary */
  if (radix == 2) {
    *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1;
    return MP_OKAY;
  }

  /* make sure the radix is in range */
  if (radix < 2 || radix > 64) {
    return MP_VAL;
  }

  if (mp_iszero(a) == MP_YES) {
     *size = 2;
    return MP_OKAY;
  }

  /* digs is the digit count */
  digs = 0;

  /* if it's negative add one for the sign */
  if (a->sign == MP_NEG) {
    ++digs;
  }

  /* init a copy of the input */
  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  /* force temp to positive */
  t.sign = MP_ZPOS; 

  /* fetch out all of the digits */
  while (mp_iszero (&t) == MP_NO) {
    if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
    ++digs;
  }
  mp_clear (&t);

  /* 
   * return digs + 1, the 1 is for the NULL byte that would be required.
   * mp_toradix_n requires a minimum of 3 bytes, so never report less than
   * that.
   */

  if ( digs >= 2 ) {
      *size = digs + 1;
  } else {
      *size = 3;
  }
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_size.c,v $ */
/* $Revision: 1.1.1.1.2.3 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_radix_smap.c.

















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
#include <tommath.h>
#ifdef BN_MP_RADIX_SMAP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* chars used in radix conversions */
const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_smap.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_rand.c.















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
#include <tommath.h>
#ifdef BN_MP_RAND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* makes a pseudo-random int of a given size */
int
mp_rand (mp_int * a, int digits)
{
  int     res;
  mp_digit d;

  mp_zero (a);
  if (digits <= 0) {
    return MP_OKAY;
  }

  /* first place a random non-zero digit */
  do {
    d = ((mp_digit) abs (rand ())) & MP_MASK;
  } while (d == 0);

  if ((res = mp_add_d (a, d, a)) != MP_OKAY) {
    return res;
  }

  while (--digits > 0) {
    if ((res = mp_lshd (a, 1)) != MP_OKAY) {
      return res;
    }

    if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) {
      return res;
    }
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rand.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_read_radix.c.



















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#include <tommath.h>
#ifdef BN_MP_READ_RADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* read a string [ASCII] in a given radix */
int mp_read_radix (mp_int * a, const char *str, int radix)
{
  int     y, res, neg;
  char    ch;

  /* make sure the radix is ok */
  if (radix < 2 || radix > 64) {
    return MP_VAL;
  }

  /* if the leading digit is a 
   * minus set the sign to negative. 
   */
  if (*str == '-') {
    ++str;
    neg = MP_NEG;
  } else {
    neg = MP_ZPOS;
  }

  /* set the integer to the default of zero */
  mp_zero (a);
  
  /* process each digit of the string */
  while (*str) {
    /* if the radix < 36 the conversion is case insensitive
     * this allows numbers like 1AB and 1ab to represent the same  value
     * [e.g. in hex]
     */
    ch = (char) ((radix < 36) ? toupper (*str) : *str);
    for (y = 0; y < 64; y++) {
      if (ch == mp_s_rmap[y]) {
         break;
      }
    }

    /* if the char was found in the map 
     * and is less than the given radix add it
     * to the number, otherwise exit the loop. 
     */
    if (y < radix) {
      if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) {
         return res;
      }
      if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) {
         return res;
      }
    } else {
      break;
    }
    ++str;
  }
  
  /* if an illegal character was found, fail. */

  if ( *str != '\0' ) {
      mp_zero( a );
      return MP_VAL;
  }

  /* set the sign only if a != 0 */
  if (mp_iszero(a) != 1) {
     a->sign = neg;
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_radix.c,v $ */
/* $Revision: 1.1.1.1.2.3 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_read_signed_bin.c.



















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
#include <tommath.h>
#ifdef BN_MP_READ_SIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* read signed bin, big endian, first byte is 0==positive or 1==negative */
int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c)
{
  int     res;

  /* read magnitude */
  if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) {
    return res;
  }

  /* first byte is 0 for positive, non-zero for negative */
  if (b[0] == 0) {
     a->sign = MP_ZPOS;
  } else {
     a->sign = MP_NEG;
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_signed_bin.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_read_unsigned_bin.c.















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
#include <tommath.h>
#ifdef BN_MP_READ_UNSIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reads a unsigned char array, assumes the msb is stored first [big endian] */
int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c)
{
  int     res;

  /* make sure there are at least two digits */
  if (a->alloc < 2) {
     if ((res = mp_grow(a, 2)) != MP_OKAY) {
        return res;
     }
  }

  /* zero the int */
  mp_zero (a);

  /* read the bytes in */
  while (c-- > 0) {
    if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) {
      return res;
    }

#ifndef MP_8BIT
      a->dp[0] |= *b++;
      a->used += 1;
#else
      a->dp[0] = (*b & MP_MASK);
      a->dp[1] |= ((*b++ >> 7U) & 1);
      a->used += 2;
#endif
  }
  mp_clamp (a);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_unsigned_bin.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce.c.









































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
#include <tommath.h>
#ifdef BN_MP_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduces x mod m, assumes 0 < x < m**2, mu is 
 * precomputed via mp_reduce_setup.
 * From HAC pp.604 Algorithm 14.42
 */
int mp_reduce (mp_int * x, mp_int * m, mp_int * mu)
{
  mp_int  q;
  int     res, um = m->used;

  /* q = x */
  if ((res = mp_init_copy (&q, x)) != MP_OKAY) {
    return res;
  }

  /* q1 = x / b**(k-1)  */
  mp_rshd (&q, um - 1);         

  /* according to HAC this optimization is ok */
  if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) {
    if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) {
      goto CLEANUP;
    }
  } else {
#ifdef BN_S_MP_MUL_HIGH_DIGS_C
    if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) {
      goto CLEANUP;
    }
#elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C)
    if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) {
      goto CLEANUP;
    }
#else 
    { 
      res = MP_VAL;
      goto CLEANUP;
    }
#endif
  }

  /* q3 = q2 / b**(k+1) */
  mp_rshd (&q, um + 1);         

  /* x = x mod b**(k+1), quick (no division) */
  if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) {
    goto CLEANUP;
  }

  /* q = q * m mod b**(k+1), quick (no division) */
  if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) {
    goto CLEANUP;
  }

  /* x = x - q */
  if ((res = mp_sub (x, &q, x)) != MP_OKAY) {
    goto CLEANUP;
  }

  /* If x < 0, add b**(k+1) to it */
  if (mp_cmp_d (x, 0) == MP_LT) {
    mp_set (&q, 1);
    if ((res = mp_lshd (&q, um + 1)) != MP_OKAY)
      goto CLEANUP;
    if ((res = mp_add (x, &q, x)) != MP_OKAY)
      goto CLEANUP;
  }

  /* Back off if it's too big */
  while (mp_cmp (x, m) != MP_LT) {
    if ((res = s_mp_sub (x, m, x)) != MP_OKAY) {
      goto CLEANUP;
    }
  }
  
CLEANUP:
  mp_clear (&q);

  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_2k.c.



























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduces a modulo n where n is of the form 2**p - d */
int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d)
{
   mp_int q;
   int    p, res;
   
   if ((res = mp_init(&q)) != MP_OKAY) {
      return res;
   }
   
   p = mp_count_bits(n);    
top:
   /* q = a/2**p, a = a mod 2**p */
   if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   if (d != 1) {
      /* q = q * d */
      if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { 
         goto ERR;
      }
   }
   
   /* a = a + q */
   if ((res = s_mp_add(a, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   if (mp_cmp_mag(a, n) != MP_LT) {
      s_mp_sub(a, n, a);
      goto top;
   }
   
ERR:
   mp_clear(&q);
   return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_2k_l.c.





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduces a modulo n where n is of the form 2**p - d 
   This differs from reduce_2k since "d" can be larger
   than a single digit.
*/
int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d)
{
   mp_int q;
   int    p, res;
   
   if ((res = mp_init(&q)) != MP_OKAY) {
      return res;
   }
   
   p = mp_count_bits(n);    
top:
   /* q = a/2**p, a = a mod 2**p */
   if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   /* q = q * d */
   if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { 
      goto ERR;
   }
   
   /* a = a + q */
   if ((res = s_mp_add(a, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   if (mp_cmp_mag(a, n) != MP_LT) {
      s_mp_sub(a, n, a);
      goto top;
   }
   
ERR:
   mp_clear(&q);
   return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_l.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_2k_setup.c.































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines the setup value */
int mp_reduce_2k_setup(mp_int *a, mp_digit *d)
{
   int res, p;
   mp_int tmp;
   
   if ((res = mp_init(&tmp)) != MP_OKAY) {
      return res;
   }
   
   p = mp_count_bits(a);
   if ((res = mp_2expt(&tmp, p)) != MP_OKAY) {
      mp_clear(&tmp);
      return res;
   }
   
   if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) {
      mp_clear(&tmp);
      return res;
   }
   
   *d = tmp.dp[0];
   mp_clear(&tmp);
   return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_2k_setup_l.c.

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_SETUP_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines the setup value */
int mp_reduce_2k_setup_l(mp_int *a, mp_int *d)
{
   int    res;
   mp_int tmp;
   
   if ((res = mp_init(&tmp)) != MP_OKAY) {
      return res;
   }
   
   if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) {
      goto ERR;
   }
   
   if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) {
      goto ERR;
   }
   
ERR:
   mp_clear(&tmp);
   return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_is_2k.c.









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
#include <tommath.h>
#ifdef BN_MP_REDUCE_IS_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if mp_reduce_2k can be used */
int mp_reduce_is_2k(mp_int *a)
{
   int ix, iy, iw;
   mp_digit iz;
   
   if (a->used == 0) {
      return MP_NO;
   } else if (a->used == 1) {
      return MP_YES;
   } else if (a->used > 1) {
      iy = mp_count_bits(a);
      iz = 1;
      iw = 1;
    
      /* Test every bit from the second digit up, must be 1 */
      for (ix = DIGIT_BIT; ix < iy; ix++) {
          if ((a->dp[iw] & iz) == 0) {
             return MP_NO;
          }
          iz <<= 1;
          if (iz > (mp_digit)MP_MASK) {
             ++iw;
             iz = 1;
          }
      }
   }
   return MP_YES;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_is_2k_l.c.

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#include <tommath.h>
#ifdef BN_MP_REDUCE_IS_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if reduce_2k_l can be used */
int mp_reduce_is_2k_l(mp_int *a)
{
   int ix, iy;
   
   if (a->used == 0) {
      return MP_NO;
   } else if (a->used == 1) {
      return MP_YES;
   } else if (a->used > 1) {
      /* if more than half of the digits are -1 we're sold */
      for (iy = ix = 0; ix < a->used; ix++) {
          if (a->dp[ix] == MP_MASK) {
              ++iy;
          }
      }
      return (iy >= (a->used/2)) ? MP_YES : MP_NO;
      
   }
   return MP_NO;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k_l.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_reduce_setup.c.





































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#include <tommath.h>
#ifdef BN_MP_REDUCE_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* pre-calculate the value required for Barrett reduction
 * For a given modulus "b" it calulates the value required in "a"
 */
int mp_reduce_setup (mp_int * a, mp_int * b)
{
  int     res;
  
  if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) {
    return res;
  }
  return mp_div (a, b, a, NULL);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_setup.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_rshd.c.

















































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
#include <tommath.h>
#ifdef BN_MP_RSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift right a certain amount of digits */
void mp_rshd (mp_int * a, int b)
{
  int     x;

  /* if b <= 0 then ignore it */
  if (b <= 0) {
    return;
  }

  /* if b > used then simply zero it and return */
  if (a->used <= b) {
    mp_zero (a);
    return;
  }

  {
    register mp_digit *bottom, *top;

    /* shift the digits down */

    /* bottom */
    bottom = a->dp;

    /* top [offset into digits] */
    top = a->dp + b;

    /* this is implemented as a sliding window where 
     * the window is b-digits long and digits from 
     * the top of the window are copied to the bottom
     *
     * e.g.

     b-2 | b-1 | b0 | b1 | b2 | ... | bb |   ---->
                 /\                   |      ---->
                  \-------------------/      ---->
     */
    for (x = 0; x < (a->used - b); x++) {
      *bottom++ = *top++;
    }

    /* zero the top digits */
    for (; x < a->used; x++) {
      *bottom++ = 0;
    }
  }
  
  /* remove excess digits */
  a->used -= b;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rshd.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_set.c.



























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
#include <tommath.h>
#ifdef BN_MP_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* set to a digit */
void mp_set (mp_int * a, mp_digit b)
{
  mp_zero (a);
  a->dp[0] = b & MP_MASK;
  a->used  = (a->dp[0] != 0) ? 1 : 0;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_set_int.c.

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#include <tommath.h>
#ifdef BN_MP_SET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* set a 32-bit const */
int mp_set_int (mp_int * a, unsigned long b)
{
  int     x, res;

  mp_zero (a);
  
  /* set four bits at a time */
  for (x = 0; x < 8; x++) {
    /* shift the number up four bits */
    if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) {
      return res;
    }

    /* OR in the top four bits of the source */
    a->dp[0] |= (b >> 28) & 15;

    /* shift the source up to the next four bits */
    b <<= 4;

    /* ensure that digits are not clamped off */
    a->used += 1;
  }
  mp_clamp (a);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set_int.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_shrink.c.







































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
#include <tommath.h>
#ifdef BN_MP_SHRINK_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shrink a bignum */
int mp_shrink (mp_int * a)
{
  mp_digit *tmp;
  if (a->alloc != a->used && a->used > 0) {
    if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) {
      return MP_MEM;
    }
    a->dp    = tmp;
    a->alloc = a->used;
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_shrink.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_signed_bin_size.c.























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#include <tommath.h>
#ifdef BN_MP_SIGNED_BIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* get the size for an signed equivalent */
int mp_signed_bin_size (mp_int * a)
{
  return 1 + mp_unsigned_bin_size (a);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_signed_bin_size.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_sqr.c.





















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
#include <tommath.h>
#ifdef BN_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes b = a*a */
int
mp_sqr (mp_int * a, mp_int * b)
{
  int     res;

#ifdef BN_MP_TOOM_SQR_C
  /* use Toom-Cook? */
  if (a->used >= TOOM_SQR_CUTOFF) {
    res = mp_toom_sqr(a, b);
  /* Karatsuba? */
  } else 
#endif
#ifdef BN_MP_KARATSUBA_SQR_C
if (a->used >= KARATSUBA_SQR_CUTOFF) {
    res = mp_karatsuba_sqr (a, b);
  } else 
#endif
  {
#ifdef BN_FAST_S_MP_SQR_C
    /* can we use the fast comba multiplier? */
    if ((a->used * 2 + 1) < MP_WARRAY && 
         a->used < 
         (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) {
      res = fast_s_mp_sqr (a, b);
    } else
#endif
#ifdef BN_S_MP_SQR_C
      res = s_mp_sqr (a, b);
#else
      res = MP_VAL;
#endif
  }
  b->sign = MP_ZPOS;
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqr.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_sqrmod.c.



















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
#include <tommath.h>
#ifdef BN_MP_SQRMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* c = a * a (mod b) */
int
mp_sqrmod (mp_int * a, mp_int * b, mp_int * c)
{
  int     res;
  mp_int  t;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_sqr (a, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, b, c);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrmod.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_sqrt.c.



































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
#include <tommath.h>
#ifdef BN_MP_SQRT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(mp_int *arg, mp_int *ret) 
{
  int res;
  mp_int t1,t2;

  /* must be positive */
  if (arg->sign == MP_NEG) {
    return MP_VAL;
  }

  /* easy out */
  if (mp_iszero(arg) == MP_YES) {
    mp_zero(ret);
    return MP_OKAY;
  }

  if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init(&t2)) != MP_OKAY) {
    goto E2;
  }

  /* First approx. (not very bad for large arg) */
  mp_rshd (&t1,t1.used/2);

  /* t1 > 0  */ 
  if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) {
    goto E1;
  }
  if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) {
    goto E1;
  }
  if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) {
    goto E1;
  }
  /* And now t1 > sqrt(arg) */
  do { 
    if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) {
      goto E1;
    }
    if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) {
      goto E1;
    }
    if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) {
      goto E1;
    }
    /* t1 >= sqrt(arg) >= t2 at this point */
  } while (mp_cmp_mag(&t1,&t2) == MP_GT);

  mp_exch(&t1,ret);

E1: mp_clear(&t2);
E2: mp_clear(&t1);
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrt.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_sub.c.























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
#include <tommath.h>
#ifdef BN_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* high level subtraction (handles signs) */
int
mp_sub (mp_int * a, mp_int * b, mp_int * c)
{
  int     sa, sb, res;

  sa = a->sign;
  sb = b->sign;

  if (sa != sb) {
    /* subtract a negative from a positive, OR */
    /* subtract a positive from a negative. */
    /* In either case, ADD their magnitudes, */
    /* and use the sign of the first number. */
    c->sign = sa;
    res = s_mp_add (a, b, c);
  } else {
    /* subtract a positive from a positive, OR */
    /* subtract a negative from a negative. */
    /* First, take the difference between their */
    /* magnitudes, then... */
    if (mp_cmp_mag (a, b) != MP_LT) {
      /* Copy the sign from the first */
      c->sign = sa;
      /* The first has a larger or equal magnitude */
      res = s_mp_sub (a, b, c);
    } else {
      /* The result has the *opposite* sign from */
      /* the first number. */
      c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS;
      /* The second has a larger magnitude */
      res = s_mp_sub (b, a, c);
    }
  }
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_sub_d.c.



















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#include <tommath.h>
#ifdef BN_MP_SUB_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* single digit subtraction */
int
mp_sub_d (mp_int * a, mp_digit b, mp_int * c)
{
  mp_digit *tmpa, *tmpc, mu;
  int       res, ix, oldused;

  /* grow c as required */
  if (c->alloc < a->used + 1) {
     if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) {
        return res;
     }
  }

  /* if a is negative just do an unsigned
   * addition [with fudged signs]
   */
  if (a->sign == MP_NEG) {
     a->sign = MP_ZPOS;
     res     = mp_add_d(a, b, c);
     a->sign = c->sign = MP_NEG;
     return res;
  }

  /* setup regs */
  oldused = c->used;
  tmpa    = a->dp;
  tmpc    = c->dp;

  /* if a <= b simply fix the single digit */
  if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) {
     if (a->used == 1) {
        *tmpc++ = b - *tmpa;
     } else {
        *tmpc++ = b;
     }
     ix      = 1;

     /* negative/1digit */
     c->sign = MP_NEG;
     c->used = 1;
  } else {
     /* positive/size */
     c->sign = MP_ZPOS;
     c->used = a->used;

     /* subtract first digit */
     *tmpc    = *tmpa++ - b;
     mu       = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1);
     *tmpc++ &= MP_MASK;

     /* handle rest of the digits */
     for (ix = 1; ix < a->used; ix++) {
        *tmpc    = *tmpa++ - mu;
        mu       = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1);
        *tmpc++ &= MP_MASK;
     }
  }

  /* zero excess digits */
  while (ix++ < oldused) {
     *tmpc++ = 0;
  }
  mp_clamp(c);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub_d.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:53 $ */

Added libtommath/bn_mp_submod.c.





















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
#include <tommath.h>
#ifdef BN_MP_SUBMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* d = a - b (mod c) */
int
mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  int     res;
  mp_int  t;


  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_sub (a, b, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, c, d);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_submod.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_to_signed_bin.c.



































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
#include <tommath.h>
#ifdef BN_MP_TO_SIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in signed [big endian] format */
int mp_to_signed_bin (mp_int * a, unsigned char *b)
{
  int     res;

  if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) {
    return res;
  }
  b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_to_signed_bin_n.c.































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
#include <tommath.h>
#ifdef BN_MP_TO_SIGNED_BIN_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in signed [big endian] format */
int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen)
{
   if (*outlen < (unsigned long)mp_signed_bin_size(a)) {
      return MP_VAL;
   }
   *outlen = mp_signed_bin_size(a);
   return mp_to_signed_bin(a, b);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin_n.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_to_unsigned_bin.c.

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#include <tommath.h>
#ifdef BN_MP_TO_UNSIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in unsigned [big endian] format */
int mp_to_unsigned_bin (mp_int * a, unsigned char *b)
{
  int     x, res;
  mp_int  t;

  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  x = 0;
  while (mp_iszero (&t) == 0) {
#ifndef MP_8BIT
      b[x++] = (unsigned char) (t.dp[0] & 255);
#else
      b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7));
#endif
    if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
  }
  bn_reverse (b, x);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_to_unsigned_bin_n.c.































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
#include <tommath.h>
#ifdef BN_MP_TO_UNSIGNED_BIN_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in unsigned [big endian] format */
int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen)
{
   if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) {
      return MP_VAL;
   }
   *outlen = mp_unsigned_bin_size(a);
   return mp_to_unsigned_bin(a, b);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_toom_mul.c.

























































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
#include <tommath.h>
#ifdef BN_MP_TOOM_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiplication using the Toom-Cook 3-way algorithm 
 *
 * Much more complicated than Karatsuba but has a lower 
 * asymptotic running time of O(N**1.464).  This algorithm is 
 * only particularly useful on VERY large inputs 
 * (we're talking 1000s of digits here...).
*/
int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c)
{
    mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2;
    int res, B;
        
    /* init temps */
    if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, 
                             &a0, &a1, &a2, &b0, &b1, 
                             &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) {
       return res;
    }
    
    /* B */
    B = MIN(a->used, b->used) / 3;
    
    /* a = a2 * B**2 + a1 * B + a0 */
    if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_copy(a, &a1)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a1, B);
    mp_mod_2d(&a1, DIGIT_BIT * B, &a1);

    if ((res = mp_copy(a, &a2)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a2, B*2);
    
    /* b = b2 * B**2 + b1 * B + b0 */
    if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_copy(b, &b1)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&b1, B);
    mp_mod_2d(&b1, DIGIT_BIT * B, &b1);

    if ((res = mp_copy(b, &b2)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&b2, B*2);
    
    /* w0 = a0*b0 */
    if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) {
       goto ERR;
    }
    
    /* w4 = a2 * b2 */
    if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) {
       goto ERR;
    }
    
    /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */
    if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) {
       goto ERR;
    }
    
    /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */
    if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) {
       goto ERR;
    }
    

    /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */
    if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) {
       goto ERR;
    }
    
    /* now solve the matrix 
    
       0  0  0  0  1
       1  2  4  8  16
       1  1  1  1  1
       16 8  4  2  1
       1  0  0  0  0
       
       using 12 subtractions, 4 shifts, 
              2 small divisions and 1 small multiplication 
     */
     
     /* r1 - r4 */
     if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r0 */
     if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/2 */
     if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/2 */
     if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r2 - r0 - r4 */
     if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - 8r0 */
     if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - 8r4 */
     if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* 3r2 - r1 - r3 */
     if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/3 */
     if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/3 */
     if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) {
        goto ERR;
     }
     
     /* at this point shift W[n] by B*n */
     if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) {
        goto ERR;
     }     
     
     if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) {
        goto ERR;
     }     
     
ERR:
     mp_clear_multi(&w0, &w1, &w2, &w3, &w4, 
                    &a0, &a1, &a2, &b0, &b1, 
                    &b2, &tmp1, &tmp2, NULL);
     return res;
}     
     
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_mul.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_toom_sqr.c.





































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
#include <tommath.h>
#ifdef BN_MP_TOOM_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* squaring using Toom-Cook 3-way algorithm */
int
mp_toom_sqr(mp_int *a, mp_int *b)
{
    mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2;
    int res, B;

    /* init temps */
    if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) {
       return res;
    }

    /* B */
    B = a->used / 3;

    /* a = a2 * B**2 + a1 * B + a0 */
    if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_copy(a, &a1)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a1, B);
    mp_mod_2d(&a1, DIGIT_BIT * B, &a1);

    if ((res = mp_copy(a, &a2)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a2, B*2);

    /* w0 = a0*a0 */
    if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) {
       goto ERR;
    }

    /* w4 = a2 * a2 */
    if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) {
       goto ERR;
    }

    /* w1 = (a2 + 2(a1 + 2a0))**2 */
    if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) {
       goto ERR;
    }

    /* w3 = (a0 + 2(a1 + 2a2))**2 */
    if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) {
       goto ERR;
    }


    /* w2 = (a2 + a1 + a0)**2 */
    if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) {
       goto ERR;
    }

    /* now solve the matrix

       0  0  0  0  1
       1  2  4  8  16
       1  1  1  1  1
       16 8  4  2  1
       1  0  0  0  0

       using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication.
     */

     /* r1 - r4 */
     if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r0 */
     if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/2 */
     if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/2 */
     if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r2 - r0 - r4 */
     if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - 8r0 */
     if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - 8r4 */
     if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* 3r2 - r1 - r3 */
     if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/3 */
     if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/3 */
     if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) {
        goto ERR;
     }

     /* at this point shift W[n] by B*n */
     if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) {
        goto ERR;
     }

     if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) {
        goto ERR;
     }

ERR:
     mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL);
     return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_sqr.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_toradix.c.























































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
#include <tommath.h>
#ifdef BN_MP_TORADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* stores a bignum as a ASCII string in a given radix (2..64) */
int mp_toradix (mp_int * a, char *str, int radix)
{
  int     res, digs;
  mp_int  t;
  mp_digit d;
  char   *_s = str;

  /* check range of the radix */
  if (radix < 2 || radix > 64) {
    return MP_VAL;
  }

  /* quick out if its zero */
  if (mp_iszero(a) == 1) {
     *str++ = '0';
     *str = '\0';
     return MP_OKAY;
  }

  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  /* if it is negative output a - */
  if (t.sign == MP_NEG) {
    ++_s;
    *str++ = '-';
    t.sign = MP_ZPOS;
  }

  digs = 0;
  while (mp_iszero (&t) == 0) {
    if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
    *str++ = mp_s_rmap[d];
    ++digs;
  }

  /* reverse the digits of the string.  In this case _s points
   * to the first digit [exluding the sign] of the number]
   */
  bn_reverse ((unsigned char *)_s, digs);

  /* append a NULL so the string is properly terminated */
  *str = '\0';

  mp_clear (&t);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_toradix_n.c.



















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#include <tommath.h>
#ifdef BN_MP_TORADIX_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* stores a bignum as a ASCII string in a given radix (2..64) 
 *
 * Stores upto maxlen-1 chars and always a NULL byte 
 */
int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen)
{
  int     res, digs;
  mp_int  t;
  mp_digit d;
  char   *_s = str;

  /* check range of the maxlen, radix */
  if (maxlen < 3 || radix < 2 || radix > 64) {
    return MP_VAL;
  }

  /* quick out if its zero */
  if (mp_iszero(a) == 1) {
     *str++ = '0';
     *str = '\0';
     return MP_OKAY;
  }

  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  /* if it is negative output a - */
  if (t.sign == MP_NEG) {
    /* we have to reverse our digits later... but not the - sign!! */
    ++_s;

    /* store the flag and mark the number as positive */
    *str++ = '-';
    t.sign = MP_ZPOS;
 
    /* subtract a char */
    --maxlen;
  }

  digs = 0;
  while (mp_iszero (&t) == 0) {
    if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
    *str++ = mp_s_rmap[d];
    ++digs;

    if (--maxlen == 1) {
       /* no more room */
       break;
    }
  }

  /* reverse the digits of the string.  In this case _s points
   * to the first digit [exluding the sign] of the number]
   */
  bn_reverse ((unsigned char *)_s, digs);

  /* append a NULL so the string is properly terminated */
  *str = '\0';

  mp_clear (&t);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix_n.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_unsigned_bin_size.c.

























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#include <tommath.h>
#ifdef BN_MP_UNSIGNED_BIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* get the size for an unsigned equivalent */
int mp_unsigned_bin_size (mp_int * a)
{
  int     size = mp_count_bits (a);
  return (size / 8 + ((size & 7) != 0 ? 1 : 0));
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_unsigned_bin_size.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_xor.c.







































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#include <tommath.h>
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* XOR two ints together */
int
mp_xor (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, ix, px;
  mp_int  t, *x;

  if (a->used > b->used) {
    if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
      return res;
    }
    px = b->used;
    x = b;
  } else {
    if ((res = mp_init_copy (&t, b)) != MP_OKAY) {
      return res;
    }
    px = a->used;
    x = a;
  }

  for (ix = 0; ix < px; ix++) {
     t.dp[ix] ^= x->dp[ix];
  }
  mp_clamp (&t);
  mp_exch (c, &t);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_xor.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_mp_zero.c.









































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
#include <tommath.h>
#ifdef BN_MP_ZERO_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* set to zero */
void mp_zero (mp_int * a)
{
  int       n;
  mp_digit *tmp;

  a->sign = MP_ZPOS;
  a->used = 0;

  tmp = a->dp;
  for (n = 0; n < a->alloc; n++) {
     *tmp++ = 0;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_zero.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_prime_tab.c.



























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
#include <tommath.h>
#ifdef BN_PRIME_TAB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
const mp_digit ltm_prime_tab[] = {
  0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013,
  0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035,
  0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059,
  0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F,
#ifndef MP_8BIT
  0x0083,
  0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD,
  0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF,
  0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107,
  0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137,

  0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167,
  0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199,
  0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9,
  0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7,
  0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239,
  0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265,
  0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293,
  0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF,

  0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301,
  0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B,
  0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371,
  0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD,
  0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5,
  0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419,
  0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449,
  0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B,

  0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7,
  0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503,
  0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529,
  0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F,
  0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3,
  0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7,
  0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623,
  0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653
#endif
};
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_prime_tab.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_reverse.c.















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
#include <tommath.h>
#ifdef BN_REVERSE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reverse an array, used for radix code */
void
bn_reverse (unsigned char *s, int len)
{
  int     ix, iy;
  unsigned char t;

  ix = 0;
  iy = len - 1;
  while (ix < iy) {
    t     = s[ix];
    s[ix] = s[iy];
    s[iy] = t;
    ++ix;
    --iy;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_reverse.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_s_mp_add.c.



























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
#include <tommath.h>
#ifdef BN_S_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* low level addition, based on HAC pp.594, Algorithm 14.7 */
int
s_mp_add (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int *x;
  int     olduse, res, min, max;

  /* find sizes, we let |a| <= |b| which means we have to sort
   * them.  "x" will point to the input with the most digits
   */
  if (a->used > b->used) {
    min = b->used;
    max = a->used;
    x = a;
  } else {
    min = a->used;
    max = b->used;
    x = b;
  }

  /* init result */
  if (c->alloc < max + 1) {
    if ((res = mp_grow (c, max + 1)) != MP_OKAY) {
      return res;
    }
  }

  /* get old used digit count and set new one */
  olduse = c->used;
  c->used = max + 1;

  {
    register mp_digit u, *tmpa, *tmpb, *tmpc;
    register int i;

    /* alias for digit pointers */

    /* first input */
    tmpa = a->dp;

    /* second input */
    tmpb = b->dp;

    /* destination */
    tmpc = c->dp;

    /* zero the carry */
    u = 0;
    for (i = 0; i < min; i++) {
      /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */
      *tmpc = *tmpa++ + *tmpb++ + u;

      /* U = carry bit of T[i] */
      u = *tmpc >> ((mp_digit)DIGIT_BIT);

      /* take away carry bit from T[i] */
      *tmpc++ &= MP_MASK;
    }

    /* now copy higher words if any, that is in A+B 
     * if A or B has more digits add those in 
     */
    if (min != max) {
      for (; i < max; i++) {
        /* T[i] = X[i] + U */
        *tmpc = x->dp[i] + u;

        /* U = carry bit of T[i] */
        u = *tmpc >> ((mp_digit)DIGIT_BIT);

        /* take away carry bit from T[i] */
        *tmpc++ &= MP_MASK;
      }
    }

    /* add carry */
    *tmpc++ = u;

    /* clear digits above oldused */
    for (i = c->used; i < olduse; i++) {
      *tmpc++ = 0;
    }
  }

  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_add.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_s_mp_exptmod.c.

























































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
#include <tommath.h>
#ifdef BN_S_MP_EXPTMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#ifdef MP_LOW_MEM
   #define TAB_SIZE 32
#else
   #define TAB_SIZE 256
#endif

int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode)
{
  mp_int  M[TAB_SIZE], res, mu;
  mp_digit buf;
  int     err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;
  int (*redux)(mp_int*,mp_int*,mp_int*);

  /* find window size */
  x = mp_count_bits (X);
  if (x <= 7) {
    winsize = 2;
  } else if (x <= 36) {
    winsize = 3;
  } else if (x <= 140) {
    winsize = 4;
  } else if (x <= 450) {
    winsize = 5;
  } else if (x <= 1303) {
    winsize = 6;
  } else if (x <= 3529) {
    winsize = 7;
  } else {
    winsize = 8;
  }

#ifdef MP_LOW_MEM
    if (winsize > 5) {
       winsize = 5;
    }
#endif

  /* init M array */
  /* init first cell */
  if ((err = mp_init(&M[1])) != MP_OKAY) {
     return err; 
  }

  /* now init the second half of the array */
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    if ((err = mp_init(&M[x])) != MP_OKAY) {
      for (y = 1<<(winsize-1); y < x; y++) {
        mp_clear (&M[y]);
      }
      mp_clear(&M[1]);
      return err;
    }
  }

  /* create mu, used for Barrett reduction */
  if ((err = mp_init (&mu)) != MP_OKAY) {
    goto LBL_M;
  }
  
  if (redmode == 0) {
     if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) {
        goto LBL_MU;
     }
     redux = mp_reduce;
  } else {
     if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) {
        goto LBL_MU;
     }
     redux = mp_reduce_2k_l;
  }    

  /* create M table
   *
   * The M table contains powers of the base, 
   * e.g. M[x] = G**x mod P
   *
   * The first half of the table is not 
   * computed though accept for M[0] and M[1]
   */
  if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) {
    goto LBL_MU;
  }

  /* compute the value at M[1<<(winsize-1)] by squaring 
   * M[1] (winsize-1) times 
   */
  if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) {
    goto LBL_MU;
  }

  for (x = 0; x < (winsize - 1); x++) {
    /* square it */
    if ((err = mp_sqr (&M[1 << (winsize - 1)], 
                       &M[1 << (winsize - 1)])) != MP_OKAY) {
      goto LBL_MU;
    }

    /* reduce modulo P */
    if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) {
      goto LBL_MU;
    }
  }

  /* create upper table, that is M[x] = M[x-1] * M[1] (mod P)
   * for x = (2**(winsize - 1) + 1) to (2**winsize - 1)
   */
  for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
    if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) {
      goto LBL_MU;
    }
    if ((err = redux (&M[x], P, &mu)) != MP_OKAY) {
      goto LBL_MU;
    }
  }

  /* setup result */
  if ((err = mp_init (&res)) != MP_OKAY) {
    goto LBL_MU;
  }
  mp_set (&res, 1);

  /* set initial mode and bit cnt */
  mode   = 0;
  bitcnt = 1;
  buf    = 0;
  digidx = X->used - 1;
  bitcpy = 0;
  bitbuf = 0;

  for (;;) {
    /* grab next digit as required */
    if (--bitcnt == 0) {
      /* if digidx == -1 we are out of digits */
      if (digidx == -1) {
        break;
      }
      /* read next digit and reset the bitcnt */
      buf    = X->dp[digidx--];
      bitcnt = (int) DIGIT_BIT;
    }

    /* grab the next msb from the exponent */
    y     = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1;
    buf <<= (mp_digit)1;

    /* if the bit is zero and mode == 0 then we ignore it
     * These represent the leading zero bits before the first 1 bit
     * in the exponent.  Technically this opt is not required but it
     * does lower the # of trivial squaring/reductions used
     */
    if (mode == 0 && y == 0) {
      continue;
    }

    /* if the bit is zero and mode == 1 then we square */
    if (mode == 1 && y == 0) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, &mu)) != MP_OKAY) {
        goto LBL_RES;
      }
      continue;
    }

    /* else we add it to the window */
    bitbuf |= (y << (winsize - ++bitcpy));
    mode    = 2;

    if (bitcpy == winsize) {
      /* ok window is filled so square as required and multiply  */
      /* square first */
      for (x = 0; x < winsize; x++) {
        if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, &mu)) != MP_OKAY) {
          goto LBL_RES;
        }
      }

      /* then multiply */
      if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, &mu)) != MP_OKAY) {
        goto LBL_RES;
      }

      /* empty window and reset */
      bitcpy = 0;
      bitbuf = 0;
      mode   = 1;
    }
  }

  /* if bits remain then square/multiply */
  if (mode == 2 && bitcpy > 0) {
    /* square then multiply if the bit is set */
    for (x = 0; x < bitcpy; x++) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, &mu)) != MP_OKAY) {
        goto LBL_RES;
      }

      bitbuf <<= 1;
      if ((bitbuf & (1 << winsize)) != 0) {
        /* then multiply */
        if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, &mu)) != MP_OKAY) {
          goto LBL_RES;
        }
      }
    }
  }

  mp_exch (&res, Y);
  err = MP_OKAY;
LBL_RES:mp_clear (&res);
LBL_MU:mp_clear (&mu);
LBL_M:
  mp_clear(&M[1]);
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    mp_clear (&M[x]);
  }
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_exptmod.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_s_mp_mul_digs.c.





















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
#include <tommath.h>
#ifdef BN_S_MP_MUL_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiplies |a| * |b| and only computes upto digs digits of result
 * HAC pp. 595, Algorithm 14.12  Modified so you can control how 
 * many digits of output are created.
 */
int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  mp_int  t;
  int     res, pa, pb, ix, iy;
  mp_digit u;
  mp_word r;
  mp_digit tmpx, *tmpt, *tmpy;

  /* can we use the fast multiplier? */
  if (((digs) < MP_WARRAY) &&
      MIN (a->used, b->used) < 
          (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
    return fast_s_mp_mul_digs (a, b, c, digs);
  }

  if ((res = mp_init_size (&t, digs)) != MP_OKAY) {
    return res;
  }
  t.used = digs;

  /* compute the digits of the product directly */
  pa = a->used;
  for (ix = 0; ix < pa; ix++) {
    /* set the carry to zero */
    u = 0;

    /* limit ourselves to making digs digits of output */
    pb = MIN (b->used, digs - ix);

    /* setup some aliases */
    /* copy of the digit from a used within the nested loop */
    tmpx = a->dp[ix];
    
    /* an alias for the destination shifted ix places */
    tmpt = t.dp + ix;
    
    /* an alias for the digits of b */
    tmpy = b->dp;

    /* compute the columns of the output and propagate the carry */
    for (iy = 0; iy < pb; iy++) {
      /* compute the column as a mp_word */
      r       = ((mp_word)*tmpt) +
                ((mp_word)tmpx) * ((mp_word)*tmpy++) +
                ((mp_word) u);

      /* the new column is the lower part of the result */
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));

      /* get the carry word from the result */
      u       = (mp_digit) (r >> ((mp_word) DIGIT_BIT));
    }
    /* set carry if it is placed below digs */
    if (ix + iy < digs) {
      *tmpt = u;
    }
  }

  mp_clamp (&t);
  mp_exch (&t, c);

  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_digs.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_s_mp_mul_high_digs.c.



































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
#include <tommath.h>
#ifdef BN_S_MP_MUL_HIGH_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiplies |a| * |b| and does not compute the lower digs digits
 * [meant to get the higher part of the product]
 */
int
s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  mp_int  t;
  int     res, pa, pb, ix, iy;
  mp_digit u;
  mp_word r;
  mp_digit tmpx, *tmpt, *tmpy;

  /* can we use the fast multiplier? */
#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C
  if (((a->used + b->used + 1) < MP_WARRAY)
      && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
    return fast_s_mp_mul_high_digs (a, b, c, digs);
  }
#endif

  if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) {
    return res;
  }
  t.used = a->used + b->used + 1;

  pa = a->used;
  pb = b->used;
  for (ix = 0; ix < pa; ix++) {
    /* clear the carry */
    u = 0;

    /* left hand side of A[ix] * B[iy] */
    tmpx = a->dp[ix];

    /* alias to the address of where the digits will be stored */
    tmpt = &(t.dp[digs]);

    /* alias for where to read the right hand side from */
    tmpy = b->dp + (digs - ix);

    for (iy = digs - ix; iy < pb; iy++) {
      /* calculate the double precision result */
      r       = ((mp_word)*tmpt) +
                ((mp_word)tmpx) * ((mp_word)*tmpy++) +
                ((mp_word) u);

      /* get the lower part */
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));

      /* carry the carry */
      u       = (mp_digit) (r >> ((mp_word) DIGIT_BIT));
    }
    *tmpt = u;
  }
  mp_clamp (&t);
  mp_exch (&t, c);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_high_digs.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_s_mp_sqr.c.









































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
#include <tommath.h>
#ifdef BN_S_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */
int s_mp_sqr (mp_int * a, mp_int * b)
{
  mp_int  t;
  int     res, ix, iy, pa;
  mp_word r;
  mp_digit u, tmpx, *tmpt;

  pa = a->used;
  if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) {
    return res;
  }

  /* default used is maximum possible size */
  t.used = 2*pa + 1;

  for (ix = 0; ix < pa; ix++) {
    /* first calculate the digit at 2*ix */
    /* calculate double precision result */
    r = ((mp_word) t.dp[2*ix]) +
        ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]);

    /* store lower part in result */
    t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK));

    /* get the carry */
    u           = (mp_digit)(r >> ((mp_word) DIGIT_BIT));

    /* left hand side of A[ix] * A[iy] */
    tmpx        = a->dp[ix];

    /* alias for where to store the results */
    tmpt        = t.dp + (2*ix + 1);
    
    for (iy = ix + 1; iy < pa; iy++) {
      /* first calculate the product */
      r       = ((mp_word)tmpx) * ((mp_word)a->dp[iy]);

      /* now calculate the double precision result, note we use
       * addition instead of *2 since it's easier to optimize
       */
      r       = ((mp_word) *tmpt) + r + r + ((mp_word) u);

      /* store lower part */
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));

      /* get carry */
      u       = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
    }
    /* propagate upwards */
    while (u != ((mp_digit) 0)) {
      r       = ((mp_word) *tmpt) + ((mp_word) u);
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));
      u       = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
    }
  }

  mp_clamp (&t);
  mp_exch (&t, b);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sqr.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bn_s_mp_sub.c.



















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#include <tommath.h>
#ifdef BN_S_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */
int
s_mp_sub (mp_int * a, mp_int * b, mp_int * c)
{
  int     olduse, res, min, max;

  /* find sizes */
  min = b->used;
  max = a->used;

  /* init result */
  if (c->alloc < max) {
    if ((res = mp_grow (c, max)) != MP_OKAY) {
      return res;
    }
  }
  olduse = c->used;
  c->used = max;

  {
    register mp_digit u, *tmpa, *tmpb, *tmpc;
    register int i;

    /* alias for digit pointers */
    tmpa = a->dp;
    tmpb = b->dp;
    tmpc = c->dp;

    /* set carry to zero */
    u = 0;
    for (i = 0; i < min; i++) {
      /* T[i] = A[i] - B[i] - U */
      *tmpc = *tmpa++ - *tmpb++ - u;

      /* U = carry bit of T[i]
       * Note this saves performing an AND operation since
       * if a carry does occur it will propagate all the way to the
       * MSB.  As a result a single shift is enough to get the carry
       */
      u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1));

      /* Clear carry from T[i] */
      *tmpc++ &= MP_MASK;
    }

    /* now copy higher words if any, e.g. if A has more digits than B  */
    for (; i < max; i++) {
      /* T[i] = A[i] - U */
      *tmpc = *tmpa++ - u;

      /* U = carry bit of T[i] */
      u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1));

      /* Clear carry from T[i] */
      *tmpc++ &= MP_MASK;
    }

    /* clear digits above used (since we may not have grown result above) */
    for (i = c->used; i < olduse; i++) {
      *tmpc++ = 0;
    }
  }

  mp_clamp (c);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sub.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/bncore.c.









































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
#include <tommath.h>
#ifdef BNCORE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Known optimal configurations

 CPU                    /Compiler     /MUL CUTOFF/SQR CUTOFF
-------------------------------------------------------------
 Intel P4 Northwood     /GCC v3.4.1   /        88/       128/LTM 0.32 ;-)
 AMD Athlon64           /GCC v3.4.4   /        80/       120/LTM 0.35
 
*/

int     KARATSUBA_MUL_CUTOFF = 80,      /* Min. number of digits before Karatsuba multiplication is used. */
        KARATSUBA_SQR_CUTOFF = 120,     /* Min. number of digits before Karatsuba squaring is used. */
        
        TOOM_MUL_CUTOFF      = 350,      /* no optimal values of these are known yet so set em high */
        TOOM_SQR_CUTOFF      = 400; 
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bncore.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/booker.pl.



















































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
#!/bin/perl
#
#Used to prepare the book "tommath.src" for LaTeX by pre-processing it into a .tex file
#
#Essentially you write the "tommath.src" as normal LaTex except where you want code snippets you put
#
#EXAM,file
#
#This preprocessor will then open "file" and insert it as a verbatim copy.
#
#Tom St Denis

#get graphics type
if (shift =~ /PDF/) {
   $graph = "";
} else {
   $graph = ".ps";
}   

open(IN,"<tommath.src") or die "Can't open source file";
open(OUT,">tommath.tex") or die "Can't open destination file";

print "Scanning for sections\n";
$chapter = $section = $subsection = 0;
$x = 0;
while (<IN>) {
   print ".";
   if (!(++$x % 80)) { print "\n"; }
   #update the headings 
   if (~($_ =~ /\*/)) {
      if ($_ =~ /\\chapter{.+}/) {
          ++$chapter;
          $section = $subsection = 0;
      } elsif ($_ =~ /\\section{.+}/) {
          ++$section;
          $subsection = 0;
      } elsif ($_ =~ /\\subsection{.+}/) {
          ++$subsection;
      }
   }      

   if ($_ =~ m/MARK/) {
      @m = split(",",$_);
      chomp(@m[1]);
      $index1{@m[1]} = $chapter;
      $index2{@m[1]} = $section;
      $index3{@m[1]} = $subsection;
   }
}
close(IN);

open(IN,"<tommath.src") or die "Can't open source file";
$readline = $wroteline = 0;
$srcline = 0;

while (<IN>) {
   ++$readline;
   ++$srcline;
   
   if ($_ =~ m/MARK/) {
   } elsif ($_ =~ m/EXAM/ || $_ =~ m/LIST/) {
      if ($_ =~ m/EXAM/) {
         $skipheader = 1;
      } else {
         $skipheader = 0;
      }
      
      # EXAM,file
      chomp($_);
      @m = split(",",$_);
      open(SRC,"<$m[1]") or die "Error:$srcline:Can't open source file $m[1]";
      
      print "$srcline:Inserting $m[1]:";
      
      $line = 0;
      $tmp = $m[1];
      $tmp =~ s/_/"\\_"/ge;
      print OUT "\\vspace{+3mm}\\begin{small}\n\\hspace{-5.1mm}{\\bf File}: $tmp\n\\vspace{-3mm}\n\\begin{alltt}\n";
      $wroteline += 5;
      
      if ($skipheader == 1) {
         # scan till next end of comment, e.g. skip license 
         while (<SRC>) {
            $text[$line++] = $_;
            last if ($_ =~ /math\.libtomcrypt\.org/);
         }
         <SRC>;   
      }
      
      $inline = 0;
      while (<SRC>) {
      next if ($_ =~ /\$Source/);
      next if ($_ =~ /\$Revision/);
      next if ($_ =~ /\$Date/);
         $text[$line++] = $_;
         ++$inline;
         chomp($_);
         $_ =~ s/\t/"    "/ge;
         $_ =~ s/{/"^{"/ge;
         $_ =~ s/}/"^}"/ge;
         $_ =~ s/\\/'\symbol{92}'/ge;
         $_ =~ s/\^/"\\"/ge;
           
         printf OUT ("%03d   ", $line);
         for ($x = 0; $x < length($_); $x++) {
             print OUT chr(vec($_, $x, 8));
             if ($x == 75) { 
                 print OUT "\n      ";
                 ++$wroteline;
             }
         }
         print OUT "\n";
         ++$wroteline;
      }
      $totlines = $line;
      print OUT "\\end{alltt}\n\\end{small}\n";
      close(SRC);
      print "$inline lines\n";
      $wroteline += 2;
   } elsif ($_ =~ m/@\d+,.+@/) {
     # line contains [number,text]
     # e.g. @14,for (ix = 0)@
     $txt = $_;
     while ($txt =~ m/@\d+,.+@/) {
        @m = split("@",$txt);      # splits into text, one, two
        @parms = split(",",$m[1]);  # splits one,two into two elements 
                
        # now search from $parms[0] down for $parms[1] 
        $found1 = 0;
        $found2 = 0;
        for ($i = $parms[0]; $i < $totlines && $found1 == 0; $i++) {
           if ($text[$i] =~ m/\Q$parms[1]\E/) {
              $foundline1 = $i + 1;
              $found1 = 1;
           }
        }
        
        # now search backwards
        for ($i = $parms[0] - 1; $i >= 0 && $found2 == 0; $i--) {
           if ($text[$i] =~ m/\Q$parms[1]\E/) {
              $foundline2 = $i + 1;
              $found2 = 1;
           }
        }
        
        # now use the closest match or the first if tied
        if ($found1 == 1 && $found2 == 0) {
           $found = 1;
           $foundline = $foundline1;
        } elsif ($found1 == 0 && $found2 == 1) {
           $found = 1;
           $foundline = $foundline2;
        } elsif ($found1 == 1 && $found2 == 1) {
           $found = 1;
           if (($foundline1 - $parms[0]) <= ($parms[0] - $foundline2)) {
              $foundline = $foundline1;
           } else {
              $foundline = $foundline2;
           }
        } else {
           $found = 0;
        }
                      
        # if found replace 
        if ($found == 1) {
           $delta = $parms[0] - $foundline;
           print "Found replacement tag for \"$parms[1]\" on line $srcline which refers to line $foundline (delta $delta)\n";
           $_ =~ s/@\Q$m[1]\E@/$foundline/;
        } else {
           print "ERROR:  The tag \"$parms[1]\" on line $srcline was not found in the most recently parsed source!\n";
        }
        
        # remake the rest of the line 
        $cnt = @m;
        $txt = "";
        for ($i = 2; $i < $cnt; $i++) {
            $txt = $txt . $m[$i] . "@";
        }
     }
     print OUT $_;
     ++$wroteline;
   } elsif ($_ =~ /~.+~/) {
      # line contains a ~text~ pair used to refer to indexing :-)
      $txt = $_;
      while ($txt =~ /~.+~/) {
         @m = split("~", $txt);
         
         # word is the second position
         $word = @m[1];
         $a = $index1{$word};
         $b = $index2{$word};
         $c = $index3{$word};
         
         # if chapter (a) is zero it wasn't found
         if ($a == 0) {
            print "ERROR: the tag \"$word\" on line $srcline was not found previously marked.\n";
         } else {
            # format the tag as x, x.y or x.y.z depending on the values
            $str = $a;
            $str = $str . ".$b" if ($b != 0);
            $str = $str . ".$c" if ($c != 0);
            
            if ($b == 0 && $c == 0) {
               # its a chapter
               if ($a <= 10) {
                  if ($a == 1) {
                     $str = "chapter one";
                  } elsif ($a == 2) {
                     $str = "chapter two";
                  } elsif ($a == 3) {
                     $str = "chapter three";
                  } elsif ($a == 4) {
                     $str = "chapter four";
                  } elsif ($a == 5) {
                     $str = "chapter five";
                  } elsif ($a == 6) {
                     $str = "chapter six";
                  } elsif ($a == 7) {
                     $str = "chapter seven";
                  } elsif ($a == 8) {
                     $str = "chapter eight";
                  } elsif ($a == 9) {
                     $str = "chapter nine";
                  } elsif ($a == 2) {
                     $str = "chapter ten";
                  }
               } else {
                  $str = "chapter " . $str;
               }
            } else {
               $str = "section " . $str     if ($b != 0 && $c == 0);            
               $str = "sub-section " . $str if ($b != 0 && $c != 0);
            }
            
            #substitute
            $_ =~ s/~\Q$word\E~/$str/;
            
            print "Found replacement tag for marker \"$word\" on line $srcline which refers to $str\n";
         }
         
         # remake rest of the line
         $cnt = @m;
         $txt = "";
         for ($i = 2; $i < $cnt; $i++) {
             $txt = $txt . $m[$i] . "~";
         }
      }
      print OUT $_;
      ++$wroteline;
   } elsif ($_ =~ m/FIGU/) {
      # FIGU,file,caption
      chomp($_);
      @m = split(",", $_);
      print OUT "\\begin{center}\n\\begin{figure}[here]\n\\includegraphics{pics/$m[1]$graph}\n";
      print OUT "\\caption{$m[2]}\n\\label{pic:$m[1]}\n\\end{figure}\n\\end{center}\n";
      $wroteline += 4;
   } else {
      print OUT $_;
      ++$wroteline;
   }
}
print "Read $readline lines, wrote $wroteline lines\n";

close (OUT);
close (IN);

Added libtommath/callgraph.txt.

more than 10,000 changes

Added libtommath/changes.txt.









































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
August 1st, 2005
v0.36  -- LTM_PRIME_2MSB_ON was fixed and the "OFF" flag was removed.
       -- [Peter LaDow] found a typo in the XREALLOC macro
       -- [Peter LaDow] pointed out that mp_read_(un)signed_bin should have "const" on the input
       -- Ported LTC patch to fix the prime_random_ex() function to get the bitsize correct [and the maskOR flags]
       -- Kevin Kenny pointed out a stray //
       -- David Hulton pointed out a typo in the textbook [mp_montgomery_setup() pseudo-code]
       -- Neal Hamilton (Elliptic Semiconductor) pointed out that my Karatsuba notation was backwards and that I could use 
          unsigned operations in the routine.  
       -- Paul Schmidt pointed out a linking error in mp_exptmod() when BN_S_MP_EXPTMOD_C is undefined (and another for read_radix)
       -- Updated makefiles to be way more flexible

March 12th, 2005
v0.35  -- Stupid XOR function missing line again... oops.
       -- Fixed bug in invmod not handling negative inputs correctly [Wolfgang Ehrhardt]
       -- Made exteuclid always give positive u3 output...[ Wolfgang Ehrhardt ]
       -- [Wolfgang Ehrhardt] Suggested a fix for mp_reduce() which avoided underruns.  ;-)
       -- mp_rand() would emit one too many digits and it was possible to get a 0 out of it ... oops
       -- Added montgomery to the testing to make sure it handles 1..10 digit moduli correctly
       -- Fixed bug in comba that would lead to possible erroneous outputs when "pa < digs" 
       -- Fixed bug in mp_toradix_size for "0" [Kevin Kenny]
       -- Updated chapters 1-5 of the textbook ;-) It now talks about the new comba code!

February 12th, 2005
v0.34  -- Fixed two more small errors in mp_prime_random_ex()
       -- Fixed overflow in mp_mul_d() [Kevin Kenny]
       -- Added mp_to_(un)signed_bin_n() functions which do bounds checking for ya [and report the size]
       -- Added "large" diminished radix support.  Speeds up things like DSA where the moduli is of the form 2^k - P for some P < 2^(k/2) or so
          Actually is faster than Montgomery on my AMD64 (and probably much faster on a P4)
       -- Updated the manual a bit
       -- Ok so I haven't done the textbook work yet... My current freelance gig has landed me in France till the 
          end of Feb/05.  Once I get back I'll have tons of free time and I plan to go to town on the book.
          As of this release the API will freeze.  At least until the book catches up with all the changes.  I welcome
          bug reports but new algorithms will have to wait.

December 23rd, 2004
v0.33  -- Fixed "small" variant for mp_div() which would munge with negative dividends...
       -- Fixed bug in mp_prime_random_ex() which would set the most significant byte to zero when
          no special flags were set
       -- Fixed overflow [minor] bug in fast_s_mp_sqr()
       -- Made the makefiles easier to configure the group/user that ltm will install as
       -- Fixed "final carry" bug in comba multipliers. (Volkan Ceylan)
       -- Matt Johnston pointed out a missing semi-colon in mp_exptmod

October 29th, 2004
v0.32  -- Added "makefile.shared" for shared object support
       -- Added more to the build options/configs in the manual
       -- Started the Depends framework, wrote dep.pl to scan deps and 
          produce "callgraph.txt" ;-)
       -- Wrote SC_RSA_1 which will enable close to the minimum required to perform
          RSA on 32-bit [or 64-bit] platforms with LibTomCrypt
       -- Merged in the small/slower mp_div replacement.  You can now toggle which
          you want to use as your mp_div() at build time.  Saves roughly 8KB or so.
       -- Renamed a few files and changed some comments to make depends system work better.
          (No changes to function names)
       -- Merged in new Combas that perform 2 reads per inner loop instead of the older 
          3reads/2writes per inner loop of the old code.  Really though if you want speed
          learn to use TomsFastMath ;-)

August 9th, 2004
v0.31  -- "profiled" builds now :-) new timings for Intel Northwoods
       -- Added "pretty" build target
       -- Update mp_init() to actually assign 0's instead of relying on calloc()
       -- "Wolfgang Ehrhardt" <[email protected]> found a bug in mp_mul() where if
          you multiply a negative by zero you get negative zero as the result.  Oops.
       -- J Harper from PeerSec let me toy with his AMD64 and I got 60-bit digits working properly
          [this also means that I fixed a bug where if sizeof(int) < sizeof(mp_digit) it would bug]

April 11th, 2004
v0.30  -- Added "mp_toradix_n" which stores upto "n-1" least significant digits of an mp_int
       -- Johan Lindh sent a patch so MSVC wouldn't whine about redefining malloc [in weird dll modes]
       -- Henrik Goldman spotted a missing OPT_CAST in mp_fwrite()
       -- Tuned tommath.h so that when MP_LOW_MEM is defined MP_PREC shall be reduced.
          [I also allow MP_PREC to be externally defined now]
       -- Sped up mp_cnt_lsb() by using a 4x4 table [e.g. 4x speedup]
       -- Added mp_prime_random_ex() which is a more versatile prime generator accurate to
          exact bit lengths (unlike the deprecated but still available mp_prime_random() which
          is only accurate to byte lengths).  See the new LTM_PRIME_* flags ;-)
       -- Alex Polushin contributed an optimized mp_sqrt() as well as mp_get_int() and mp_is_square().
          I've cleaned them all up to be a little more consistent [along with one bug fix] for this release.
       -- Added mp_init_set and mp_init_set_int to initialize and set small constants with one function
          call.
       -- Removed /etclib directory [um LibTomPoly deprecates this].
       -- Fixed mp_mod() so the sign of the result agrees with the sign of the modulus.
       ++ N.B.  My semester is almost up so expect updates to the textbook to be posted to the libtomcrypt.org 
          website.  

Jan 25th, 2004
v0.29  ++ Note: "Henrik" from the v0.28 changelog refers to Henrik Goldman ;-)
       -- Added fix to mp_shrink to prevent a realloc when used == 0 [e.g. realloc zero bytes???]
       -- Made the mp_prime_rabin_miller_trials() function internal table smaller and also
          set the minimum number of tests to two (sounds a bit safer).
       -- Added a mp_exteuclid() which computes the extended euclidean algorithm.
       -- Fixed a memory leak in s_mp_exptmod() [called when Barrett reduction is to be used] which would arise
          if a multiplication or subsequent reduction failed [would not free the temp result].
       -- Made an API change to mp_radix_size().  It now returns an error code and stores the required size
          through an "int star" passed to it.

Dec 24th, 2003
v0.28  -- Henrik Goldman suggested I add casts to the montomgery code [stores into mu...] so compilers wouldn't
          spew [erroneous] diagnostics... fixed.
       -- Henrik Goldman also spotted two typos.  One in mp_radix_size() and another in mp_toradix().
       -- Added fix to mp_shrink() to avoid a memory leak.
       -- Added mp_prime_random() which requires a callback to make truly random primes of a given nature
          (idea from chat with Niels Ferguson at Crypto'03)
       -- Picked up a second wind.  I'm filled with Gooo.  Mission Gooo!
       -- Removed divisions from mp_reduce_is_2k()
       -- Sped up mp_div_d() [general case] to use only one division per digit instead of two.
       -- Added the heap macros from LTC to LTM.  Now you can easily [by editing four lines of tommath.h]
          change the name of the heap functions used in LTM [also compatible with LTC via MPI mode]
       -- Added bn_prime_rabin_miller_trials() which gives the number of Rabin-Miller trials to achieve
          a failure rate of less than 2^-96
       -- fixed bug in fast_mp_invmod().  The initial testing logic was wrong.  An invalid input is not when
          "a" and "b" are even it's when "b" is even [the algo is for odd moduli only].
       -- Started a new manual [finally].  It is incomplete and will be finished as time goes on.  I had to stop
          adding full demos around half way in chapter three so I could at least get a good portion of the
          manual done.   If you really need help using the library you can always email me!
       -- My Textbook is now included as part of the package [all Public Domain]

Sept 19th, 2003
v0.27  -- Removed changes.txt~ which was made by accident since "kate" decided it was
          a good time to re-enable backups... [kde is fun!]
       -- In mp_grow() "a->dp" is not overwritten by realloc call [re: memory leak]
          Now if mp_grow() fails the mp_int is still valid and can be cleared via
          mp_clear() to reclaim the memory.
       -- Henrik Goldman found a buffer overflow bug in mp_add_d().  Fixed.
       -- Cleaned up mp_mul_d() to be much easier to read and follow.

Aug 29th, 2003
v0.26  -- Fixed typo that caused warning with GCC 3.2
       -- Martin Marcel noticed a bug in mp_neg() that allowed negative zeroes.
          Also, Martin is the fellow who noted the bugs in mp_gcd() of 0.24/0.25.
       -- Martin Marcel noticed an optimization [and slight bug] in mp_lcm().
       -- Added fix to mp_read_unsigned_bin to prevent a buffer overflow.
       -- Beefed up the comments in the baseline multipliers [and montgomery]
       -- Added "mont" demo to the makefile.msvc in etc/
       -- Optimized sign compares in mp_cmp from 4 to 2 cases.

Aug 4th, 2003
v0.25  -- Fix to mp_gcd again... oops (0,-a) == (-a, 0) == a
       -- Fix to mp_clear which didn't reset the sign  [Greg Rose]
       -- Added mp_error_to_string() to convert return codes to strings.  [Greg Rose]
       -- Optimized fast_mp_invmod() to do the test for invalid inputs [both even]
          first so temps don't have to be initialized if it's going to fail.
       -- Optimized mp_gcd() by removing mp_div_2d calls for when one of the inputs
          is odd.
       -- Tons of new comments, some indentation fixups, etc.
       -- mp_jacobi() returns MP_VAL if the modulus is less than or equal to zero.
       -- fixed two typos in the header of each file :-)
       -- LibTomMath is officially Public Domain [see LICENSE]

July 15th, 2003
v0.24  -- Optimized mp_add_d and mp_sub_d to not allocate temporary variables
       -- Fixed mp_gcd() so the gcd of 0,0 is 0.  Allows the gcd operation to be chained
          e.g. (0,0,a) == a [instead of 1]
       -- Should be one of the last release for a while.  Working on LibTomMath book now.
       -- optimized the pprime demo [/etc/pprime.c] to first make a huge table of single
          digit primes then it reads them randomly instead of randomly choosing/testing single
          digit primes.

July 12th, 2003
v0.23  -- Optimized mp_prime_next_prime() to not use mp_mod [via is_divisible()] in each
          iteration.  Instead now a smaller table is kept of the residues which can be updated
          without division.
       -- Fixed a bug in next_prime() where an input of zero would be treated as odd and
          have two added to it [to move to the next odd].
       -- fixed a bug in prime_fermat() and prime_miller_rabin() which allowed the base
          to be negative, zero or one.  Normally the test is only valid if the base is
          greater than one.
       -- changed the next_prime() prototype to accept a new parameter "bbs_style" which
          will find the next prime congruent to 3 mod 4.  The default [bbs_style==0] will
          make primes which are either congruent to 1 or 3 mod 4.
       -- fixed mp_read_unsigned_bin() so that it doesn't include both code for
          the case DIGIT_BIT < 8 and >= 8
       -- optimized div_d() to easy out on division by 1 [or if a == 0] and use
          logical shifts if the divisor is a power of two.
       -- the default DIGIT_BIT type was not int for non-default builds.  Fixed.

July 2nd, 2003
v0.22  -- Fixed up mp_invmod so the result is properly in range now [was always congruent to the inverse...]
       -- Fixed up s_mp_exptmod and mp_exptmod_fast so the lower half of the pre-computed table isn't allocated
          which makes the algorithm use half as much ram.
       -- Fixed the install script not to make the book :-) [which isn't included anyways]
       -- added mp_cnt_lsb() which counts how many of the lsbs are zero
       -- optimized mp_gcd() to use the new mp_cnt_lsb() to replace multiple divisions by two by a single division.
       -- applied similar optimization to mp_prime_miller_rabin().
       -- Fixed a bug in both mp_invmod() and fast_mp_invmod() which tested for odd
          via "mp_iseven() == 0" which is not valid [since zero is not even either].

June 19th, 2003
v0.21  -- Fixed bug in mp_mul_d which would not handle sign correctly [would not always forward it]
       -- Removed the #line lines from gen.pl [was in violation of ISO C]

June 8th, 2003
v0.20  -- Removed the book from the package.  Added the TDCAL license document.
       -- This release is officially pure-bred TDCAL again [last officially TDCAL based release was v0.16]

June 6th, 2003
v0.19  -- Fixed a bug in mp_montgomery_reduce() which was introduced when I tweaked mp_rshd() in the previous release.
          Essentially the digits were not trimmed before the compare which cause a subtraction to occur all the time.
       -- Fixed up etc/tune.c a bit to stop testing new cutoffs after 16 failures [to find more optimal points].
          Brute force ho!


May 29th, 2003
v0.18  -- Fixed a bug in s_mp_sqr which would handle carries properly just not very elegantly.
          (e.g. correct result, just bad looking code)
       -- Fixed bug in mp_sqr which still had a 512 constant instead of MP_WARRAY
       -- Added Toom-Cook multipliers [needs tuning!]
       -- Added efficient divide by 3 algorithm mp_div_3
       -- Re-wrote mp_div_d to be faster than calling mp_div
       -- Added in a donated BCC makefile and a single page LTM poster ([email protected])
       -- Added mp_reduce_2k which reduces an input modulo n = 2**p - k for any single digit k
       -- Made the exptmod system be aware of the 2k reduction algorithms.
       -- Rewrote mp_dr_reduce to be smaller, simpler and easier to understand.

May 17th, 2003
v0.17  -- Benjamin Goldberg submitted optimized mp_add and mp_sub routines.  A new gen.pl as well
          as several smaller suggestions.  Thanks!
       -- removed call to mp_cmp in inner loop of mp_div and put mp_cmp_mag in its place :-)
       -- Fixed bug in mp_exptmod that would cause it to fail for odd moduli when DIGIT_BIT != 28
       -- mp_exptmod now also returns errors if the modulus is negative and will handle negative exponents
       -- mp_prime_is_prime will now return true if the input is one of the primes in the prime table
       -- Damian M Gryski ([email protected]) found a index out of bounds error in the
          mp_fast_s_mp_mul_high_digs function which didn't come up before.  (fixed)
       -- Refactored the DR reduction code so there is only one function per file.
       -- Fixed bug in the mp_mul() which would erroneously avoid the faster multiplier [comba] when it was
          allowed.  The bug would not cause the incorrect value to be produced just less efficient (fixed)
       -- Fixed similar bug in the Montgomery reduction code.
       -- Added tons of (mp_digit) casts so the 7/15/28/31 bit digit code will work flawlessly out of the box.
          Also added limited support for 64-bit machines with a 60-bit digit.  Both thanks to Tom Wu ([email protected])
       -- Added new comments here and there, cleaned up some code [style stuff]
       -- Fixed a lingering typo in mp_exptmod* that would set bitcnt to zero then one.  Very silly stuff :-)
       -- Fixed up mp_exptmod_fast so it would set "redux" to the comba Montgomery reduction if allowed.  This
          saves quite a few calls and if statements.
       -- Added etc/mont.c a test of the Montgomery reduction [assuming all else works :-| ]
       -- Fixed up etc/tune.c to use a wider test range [more appropriate] also added a x86 based addition which
          uses RDTSC for high precision timing.
       -- Updated demo/demo.c to remove MPI stuff [won't work anyways], made the tests run for 2 seconds each so its
          not so insanely slow.  Also made the output space delimited [and fixed up various errors]
       -- Added logs directory, logs/graph.dem which will use gnuplot to make a series of PNG files
          that go with the pre-made index.html.  You have to build [via make timing] and run ltmtest first in the
          root of the package.
       -- Fixed a bug in mp_sub and mp_add where "-a - -a" or "-a + a" would produce -0 as the result [obviously invalid].
       -- Fixed a bug in mp_rshd.  If the count == a.used it should zero/return [instead of shifting]
       -- Fixed a "off-by-one" bug in mp_mul2d.  The initial size check on alloc would be off by one if the residue
          shifting caused a carry.
       -- Fixed a bug where s_mp_mul_digs() would not call the Comba based routine if allowed.  This made Barrett reduction
          slower than it had to be.

Mar 29th, 2003
v0.16  -- Sped up mp_div by making normalization one shift call
       -- Sped up mp_mul_2d/mp_div_2d by aliasing pointers :-)
       -- Cleaned up mp_gcd to use the macros for odd/even detection
       -- Added comments here and there, mostly there but occasionally here too.

Mar 22nd, 2003
v0.15  -- Added series of prime testing routines to lib
       -- Fixed up etc/tune.c
       -- Added DR reduction algorithm
       -- Beefed up the manual more.
       -- Fixed up demo/demo.c so it doesn't have so many warnings and it does the full series of
          tests
       -- Added "pre-gen" directory which will hold a "gen.pl"'ed copy of the entire lib [done at
          zipup time so its always the latest]
       -- Added conditional casts for C++ users [boo!]

Mar 15th, 2003
v0.14  -- Tons of manual updates
       -- cleaned up the directory
       -- added MSVC makefiles
       -- source changes [that I don't recall]
       -- Fixed up the lshd/rshd code to use pointer aliasing
       -- Fixed up the mul_2d and div_2d to not call rshd/lshd unless needed
       -- Fixed up etc/tune.c a tad
       -- fixed up demo/demo.c to output comma-delimited results of timing
          also fixed up timing demo to use a finer granularity for various functions
       -- fixed up demo/demo.c testing to pause during testing so my Duron won't catch on fire
          [stays around 31-35C during testing :-)]

Feb 13th, 2003
v0.13  -- tons of minor speed-ups in low level add, sub, mul_2 and div_2 which propagate
          to other functions like mp_invmod, mp_div, etc...
       -- Sped up mp_exptmod_fast by using new code to find R mod m [e.g. B^n mod m]
       -- minor fixes

Jan 17th, 2003
v0.12  -- re-wrote the majority of the makefile so its more portable and will
          install via "make install" on most *nix platforms
       -- Re-packaged all the source as seperate files.  Means the library a single
          file packagage any more.  Instead of just adding "bn.c" you have to add
          libtommath.a
       -- Renamed "bn.h" to "tommath.h"
       -- Changes to the manual to reflect all of this
       -- Used GNU Indent to clean up the source

Jan 15th, 2003
v0.11  -- More subtle fixes
       -- Moved to gentoo linux [hurrah!] so made *nix specific fixes to the make process
       -- Sped up the montgomery reduction code quite a bit
       -- fixed up demo so when building timing for the x86 it assumes ELF format now

Jan 9th, 2003
v0.10  -- Pekka Riikonen suggested fixes to the radix conversion code.
       -- Added baseline montgomery and comba montgomery reductions, sped up exptmods
          [to a point, see bn.h for MONTGOMERY_EXPT_CUTOFF]

Jan 6th, 2003
v0.09  -- Updated the manual to reflect recent changes.  :-)
       -- Added Jacobi function (mp_jacobi) to supplement the number theory side of the lib
       -- Added a Mersenne prime finder demo in ./etc/mersenne.c

Jan 2nd, 2003
v0.08  -- Sped up the multipliers by moving the inner loop variables into a smaller scope
       -- Corrected a bunch of small "warnings"
       -- Added more comments
       -- Made "mtest" be able to use /dev/random, /dev/urandom or stdin for RNG data
       -- Corrected some bugs where error messages were potentially ignored
       -- add etc/pprime.c program which makes numbers which are provably prime.

Jan 1st, 2003
v0.07  -- Removed alot of heap operations from core functions to speed them up
       -- Added a root finding function [and mp_sqrt macro like from MPI]
       -- Added more to manual

Dec 31st, 2002
v0.06  -- Sped up the s_mp_add, s_mp_sub which inturn sped up mp_invmod, mp_exptmod, etc...
       -- Cleaned up the header a bit more

Dec 30th, 2002
v0.05  -- Builds with MSVC out of the box
       -- Fixed a bug in mp_invmod w.r.t. even moduli
       -- Made mp_toradix and mp_read_radix use char instead of unsigned char arrays
       -- Fixed up exptmod to use fewer multiplications
       -- Fixed up mp_init_size to use only one heap operation
          -- Note there is a slight "off-by-one" bug in the library somewhere
             without the padding (see the source for comment) the library
             crashes in libtomcrypt.  Anyways a reasonable workaround is to pad the
             numbers which will always correct it since as the numbers grow the padding
             will still be beyond the end of the number
       -- Added more to the manual

Dec 29th, 2002
v0.04  -- Fixed a memory leak in mp_to_unsigned_bin
       -- optimized invmod code
       -- Fixed bug in mp_div
       -- use exchange instead of copy for results
       -- added a bit more to the manual

Dec 27th, 2002
v0.03  -- Sped up s_mp_mul_high_digs by not computing the carries of the lower digits
       -- Fixed a bug where mp_set_int wouldn't zero the value first and set the used member.
       -- fixed a bug in s_mp_mul_high_digs where the limit placed on the result digits was not calculated properly
       -- fixed bugs in add/sub/mul/sqr_mod functions where if the modulus and dest were the same it wouldn't work
       -- fixed a bug in mp_mod and mp_mod_d concerning negative inputs
       -- mp_mul_d didn't preserve sign
       -- Many many many many fixes
       -- Works in LibTomCrypt now :-)
       -- Added iterations to the timing demos... more accurate.
       -- Tom needs a job.

Dec 26th, 2002
v0.02  -- Fixed a few "slips" in the manual.  This is "LibTomMath" afterall :-)
       -- Added mp_cmp_mag, mp_neg, mp_abs and mp_radix_size that were missing.
       -- Sped up the fast [comba] multipliers more [yahoo!]

Dec 25th,2002
v0.01  -- Initial release.  Gimme a break.
       -- Todo list,
           add details to manual [e.g. algorithms]
           more comments in code
           example programs

Added libtommath/demo/demo.c.









































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
#include <time.h>

#ifdef IOWNANATHLON
#include <unistd.h>
#define SLEEP sleep(4)
#else
#define SLEEP
#endif

#include "tommath.h"

void ndraw(mp_int * a, char *name)
{
   char buf[16000];

   printf("%s: ", name);
   mp_toradix(a, buf, 10);
   printf("%s\n", buf);
}

static void draw(mp_int * a)
{
   ndraw(a, "");
}


unsigned long lfsr = 0xAAAAAAAAUL;

int lbit(void)
{
   if (lfsr & 0x80000000UL) {
      lfsr = ((lfsr << 1) ^ 0x8000001BUL) & 0xFFFFFFFFUL;
      return 1;
   } else {
      lfsr <<= 1;
      return 0;
   }
}

int myrng(unsigned char *dst, int len, void *dat)
{
   int x;

   for (x = 0; x < len; x++)
      dst[x] = rand() & 0xFF;
   return len;
}



char cmd[4096], buf[4096];
int main(void)
{
   mp_int a, b, c, d, e, f;
   unsigned long expt_n, add_n, sub_n, mul_n, div_n, sqr_n, mul2d_n, div2d_n,
      gcd_n, lcm_n, inv_n, div2_n, mul2_n, add_d_n, sub_d_n, t;
   unsigned rr;
   int i, n, err, cnt, ix, old_kara_m, old_kara_s;
   mp_digit mp;


   mp_init(&a);
   mp_init(&b);
   mp_init(&c);
   mp_init(&d);
   mp_init(&e);
   mp_init(&f);

   srand(time(NULL));

#if 0
   // test montgomery 
   printf("Testing montgomery...\n");
   for (i = 1; i < 10; i++) {
      printf("Testing digit size: %d\n", i);
      for (n = 0; n < 1000; n++) {
         mp_rand(&a, i);
         a.dp[0] |= 1;

         // let's see if R is right
         mp_montgomery_calc_normalization(&b, &a);
         mp_montgomery_setup(&a, &mp);

         // now test a random reduction 
         for (ix = 0; ix < 100; ix++) {
             mp_rand(&c, 1 + abs(rand()) % (2*i));
             mp_copy(&c, &d);
             mp_copy(&c, &e);

             mp_mod(&d, &a, &d);
             mp_montgomery_reduce(&c, &a, mp);
             mp_mulmod(&c, &b, &a, &c);

             if (mp_cmp(&c, &d) != MP_EQ) { 
printf("d = e mod a, c = e MOD a\n");
mp_todecimal(&a, buf); printf("a = %s\n", buf);
mp_todecimal(&e, buf); printf("e = %s\n", buf);
mp_todecimal(&d, buf); printf("d = %s\n", buf);
mp_todecimal(&c, buf); printf("c = %s\n", buf);
printf("compare no compare!\n"); exit(EXIT_FAILURE); }
         }
      }
   }
   printf("done\n");

   // test mp_get_int
   printf("Testing: mp_get_int\n");
   for (i = 0; i < 1000; ++i) {
      t = ((unsigned long) rand() * rand() + 1) & 0xFFFFFFFF;
      mp_set_int(&a, t);
      if (t != mp_get_int(&a)) {
	 printf("mp_get_int() bad result!\n");
	 return 1;
      }
   }
   mp_set_int(&a, 0);
   if (mp_get_int(&a) != 0) {
      printf("mp_get_int() bad result!\n");
      return 1;
   }
   mp_set_int(&a, 0xffffffff);
   if (mp_get_int(&a) != 0xffffffff) {
      printf("mp_get_int() bad result!\n");
      return 1;
   }
   // test mp_sqrt
   printf("Testing: mp_sqrt\n");
   for (i = 0; i < 1000; ++i) {
      printf("%6d\r", i);
      fflush(stdout);
      n = (rand() & 15) + 1;
      mp_rand(&a, n);
      if (mp_sqrt(&a, &b) != MP_OKAY) {
	 printf("mp_sqrt() error!\n");
	 return 1;
      }
      mp_n_root(&a, 2, &a);
      if (mp_cmp_mag(&b, &a) != MP_EQ) {
	 printf("mp_sqrt() bad result!\n");
	 return 1;
      }
   }

   printf("\nTesting: mp_is_square\n");
   for (i = 0; i < 1000; ++i) {
      printf("%6d\r", i);
      fflush(stdout);

      /* test mp_is_square false negatives */
      n = (rand() & 7) + 1;
      mp_rand(&a, n);
      mp_sqr(&a, &a);
      if (mp_is_square(&a, &n) != MP_OKAY) {
	 printf("fn:mp_is_square() error!\n");
	 return 1;
      }
      if (n == 0) {
	 printf("fn:mp_is_square() bad result!\n");
	 return 1;
      }

      /* test for false positives */
      mp_add_d(&a, 1, &a);
      if (mp_is_square(&a, &n) != MP_OKAY) {
	 printf("fp:mp_is_square() error!\n");
	 return 1;
      }
      if (n == 1) {
	 printf("fp:mp_is_square() bad result!\n");
	 return 1;
      }

   }
   printf("\n\n");

   /* test for size */
   for (ix = 10; ix < 128; ix++) {
      printf("Testing (not safe-prime): %9d bits    \r", ix);
      fflush(stdout);
      err =
	 mp_prime_random_ex(&a, 8, ix,
			    (rand() & 1) ? LTM_PRIME_2MSB_OFF :
			    LTM_PRIME_2MSB_ON, myrng, NULL);
      if (err != MP_OKAY) {
	 printf("failed with err code %d\n", err);
	 return EXIT_FAILURE;
      }
      if (mp_count_bits(&a) != ix) {
	 printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix);
	 return EXIT_FAILURE;
      }
   }

   for (ix = 16; ix < 128; ix++) {
      printf("Testing (   safe-prime): %9d bits    \r", ix);
      fflush(stdout);
      err =
	 mp_prime_random_ex(&a, 8, ix,
			    ((rand() & 1) ? LTM_PRIME_2MSB_OFF :
			     LTM_PRIME_2MSB_ON) | LTM_PRIME_SAFE, myrng,
			    NULL);
      if (err != MP_OKAY) {
	 printf("failed with err code %d\n", err);
	 return EXIT_FAILURE;
      }
      if (mp_count_bits(&a) != ix) {
	 printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix);
	 return EXIT_FAILURE;
      }
      /* let's see if it's really a safe prime */
      mp_sub_d(&a, 1, &a);
      mp_div_2(&a, &a);
      mp_prime_is_prime(&a, 8, &cnt);
      if (cnt != MP_YES) {
	 printf("sub is not prime!\n");
	 return EXIT_FAILURE;
      }
   }

   printf("\n\n");

   mp_read_radix(&a, "123456", 10);
   mp_toradix_n(&a, buf, 10, 3);
   printf("a == %s\n", buf);
   mp_toradix_n(&a, buf, 10, 4);
   printf("a == %s\n", buf);
   mp_toradix_n(&a, buf, 10, 30);
   printf("a == %s\n", buf);


#if 0
   for (;;) {
      fgets(buf, sizeof(buf), stdin);
      mp_read_radix(&a, buf, 10);
      mp_prime_next_prime(&a, 5, 1);
      mp_toradix(&a, buf, 10);
      printf("%s, %lu\n", buf, a.dp[0] & 3);
   }
#endif

   /* test mp_cnt_lsb */
   printf("testing mp_cnt_lsb...\n");
   mp_set(&a, 1);
   for (ix = 0; ix < 1024; ix++) {
      if (mp_cnt_lsb(&a) != ix) {
	 printf("Failed at %d, %d\n", ix, mp_cnt_lsb(&a));
	 return 0;
      }
      mp_mul_2(&a, &a);
   }

/* test mp_reduce_2k */
   printf("Testing mp_reduce_2k...\n");
   for (cnt = 3; cnt <= 128; ++cnt) {
      mp_digit tmp;

      mp_2expt(&a, cnt);
      mp_sub_d(&a, 2, &a);	/* a = 2**cnt - 2 */


      printf("\nTesting %4d bits", cnt);
      printf("(%d)", mp_reduce_is_2k(&a));
      mp_reduce_2k_setup(&a, &tmp);
      printf("(%d)", tmp);
      for (ix = 0; ix < 1000; ix++) {
	 if (!(ix & 127)) {
	    printf(".");
	    fflush(stdout);
	 }
	 mp_rand(&b, (cnt / DIGIT_BIT + 1) * 2);
	 mp_copy(&c, &b);
	 mp_mod(&c, &a, &c);
	 mp_reduce_2k(&b, &a, 2);
	 if (mp_cmp(&c, &b)) {
	    printf("FAILED\n");
	    exit(0);
	 }
      }
   }

/* test mp_div_3  */
   printf("Testing mp_div_3...\n");
   mp_set(&d, 3);
   for (cnt = 0; cnt < 10000;) {
      mp_digit r1, r2;

      if (!(++cnt & 127))
	 printf("%9d\r", cnt);
      mp_rand(&a, abs(rand()) % 128 + 1);
      mp_div(&a, &d, &b, &e);
      mp_div_3(&a, &c, &r2);

      if (mp_cmp(&b, &c) || mp_cmp_d(&e, r2)) {
	 printf("\n\nmp_div_3 => Failure\n");
      }
   }
   printf("\n\nPassed div_3 testing\n");

/* test the DR reduction */
   printf("testing mp_dr_reduce...\n");
   for (cnt = 2; cnt < 32; cnt++) {
      printf("%d digit modulus\n", cnt);
      mp_grow(&a, cnt);
      mp_zero(&a);
      for (ix = 1; ix < cnt; ix++) {
	 a.dp[ix] = MP_MASK;
      }
      a.used = cnt;
      a.dp[0] = 3;

      mp_rand(&b, cnt - 1);
      mp_copy(&b, &c);

      rr = 0;
      do {
	 if (!(rr & 127)) {
	    printf("%9lu\r", rr);
	    fflush(stdout);
	 }
	 mp_sqr(&b, &b);
	 mp_add_d(&b, 1, &b);
	 mp_copy(&b, &c);

	 mp_mod(&b, &a, &b);
	 mp_dr_reduce(&c, &a, (((mp_digit) 1) << DIGIT_BIT) - a.dp[0]);

	 if (mp_cmp(&b, &c) != MP_EQ) {
	    printf("Failed on trial %lu\n", rr);
	    exit(-1);

	 }
      } while (++rr < 500);
      printf("Passed DR test for %d digits\n", cnt);
   }

#endif

/* test the mp_reduce_2k_l code */
#if 0
#if 0
/* first load P with 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF */
   mp_2expt(&a, 1024);
   mp_read_radix(&b, "2A434B9FDEC95D8F9D550FFFFFFFFFFFFFFFF", 16);
   mp_sub(&a, &b, &a);
#elif 1
/*  p = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F  */
   mp_2expt(&a, 2048);
   mp_read_radix(&b,
		 "1000000000000000000000000000000004945DDBF8EA2A91D5776399BB83E188F",
		 16);
   mp_sub(&a, &b, &a);
#endif

   mp_todecimal(&a, buf);
   printf("p==%s\n", buf);
/* now mp_reduce_is_2k_l() should return */
   if (mp_reduce_is_2k_l(&a) != 1) {
      printf("mp_reduce_is_2k_l() return 0, should be 1\n");
      return EXIT_FAILURE;
   }
   mp_reduce_2k_setup_l(&a, &d);
   /* now do a million square+1 to see if it varies */
   mp_rand(&b, 64);
   mp_mod(&b, &a, &b);
   mp_copy(&b, &c);
   printf("testing mp_reduce_2k_l...");
   fflush(stdout);
   for (cnt = 0; cnt < (1UL << 20); cnt++) {
      mp_sqr(&b, &b);
      mp_add_d(&b, 1, &b);
      mp_reduce_2k_l(&b, &a, &d);
      mp_sqr(&c, &c);
      mp_add_d(&c, 1, &c);
      mp_mod(&c, &a, &c);
      if (mp_cmp(&b, &c) != MP_EQ) {
	 printf("mp_reduce_2k_l() failed at step %lu\n", cnt);
	 mp_tohex(&b, buf);
	 printf("b == %s\n", buf);
	 mp_tohex(&c, buf);
	 printf("c == %s\n", buf);
	 return EXIT_FAILURE;
      }
   }
   printf("...Passed\n");
#endif

   div2_n = mul2_n = inv_n = expt_n = lcm_n = gcd_n = add_n =
      sub_n = mul_n = div_n = sqr_n = mul2d_n = div2d_n = cnt = add_d_n =
      sub_d_n = 0;

   /* force KARA and TOOM to enable despite cutoffs */
   KARATSUBA_SQR_CUTOFF = KARATSUBA_MUL_CUTOFF = 8;
   TOOM_SQR_CUTOFF = TOOM_MUL_CUTOFF = 16;

   for (;;) {
      /* randomly clear and re-init one variable, this has the affect of triming the alloc space */
      switch (abs(rand()) % 7) {
      case 0:
	 mp_clear(&a);
	 mp_init(&a);
	 break;
      case 1:
	 mp_clear(&b);
	 mp_init(&b);
	 break;
      case 2:
	 mp_clear(&c);
	 mp_init(&c);
	 break;
      case 3:
	 mp_clear(&d);
	 mp_init(&d);
	 break;
      case 4:
	 mp_clear(&e);
	 mp_init(&e);
	 break;
      case 5:
	 mp_clear(&f);
	 mp_init(&f);
	 break;
      case 6:
	 break;			/* don't clear any */
      }


      printf
	 ("%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu ",
	  add_n, sub_n, mul_n, div_n, sqr_n, mul2d_n, div2d_n, gcd_n, lcm_n,
	  expt_n, inv_n, div2_n, mul2_n, add_d_n, sub_d_n);
      fgets(cmd, 4095, stdin);
      cmd[strlen(cmd) - 1] = 0;
      printf("%s  ]\r", cmd);
      fflush(stdout);
      if (!strcmp(cmd, "mul2d")) {
	 ++mul2d_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 sscanf(buf, "%d", &rr);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);

	 mp_mul_2d(&a, rr, &a);
	 a.sign = b.sign;
	 if (mp_cmp(&a, &b) != MP_EQ) {
	    printf("mul2d failed, rr == %d\n", rr);
	    draw(&a);
	    draw(&b);
	    return 0;
	 }
      } else if (!strcmp(cmd, "div2d")) {
	 ++div2d_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 sscanf(buf, "%d", &rr);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);

	 mp_div_2d(&a, rr, &a, &e);
	 a.sign = b.sign;
	 if (a.used == b.used && a.used == 0) {
	    a.sign = b.sign = MP_ZPOS;
	 }
	 if (mp_cmp(&a, &b) != MP_EQ) {
	    printf("div2d failed, rr == %d\n", rr);
	    draw(&a);
	    draw(&b);
	    return 0;
	 }
      } else if (!strcmp(cmd, "add")) {
	 ++add_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 mp_copy(&a, &d);
	 mp_add(&d, &b, &d);
	 if (mp_cmp(&c, &d) != MP_EQ) {
	    printf("add %lu failure!\n", add_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    return 0;
	 }

	 /* test the sign/unsigned storage functions */

	 rr = mp_signed_bin_size(&c);
	 mp_to_signed_bin(&c, (unsigned char *) cmd);
	 memset(cmd + rr, rand() & 255, sizeof(cmd) - rr);
	 mp_read_signed_bin(&d, (unsigned char *) cmd, rr);
	 if (mp_cmp(&c, &d) != MP_EQ) {
	    printf("mp_signed_bin failure!\n");
	    draw(&c);
	    draw(&d);
	    return 0;
	 }


	 rr = mp_unsigned_bin_size(&c);
	 mp_to_unsigned_bin(&c, (unsigned char *) cmd);
	 memset(cmd + rr, rand() & 255, sizeof(cmd) - rr);
	 mp_read_unsigned_bin(&d, (unsigned char *) cmd, rr);
	 if (mp_cmp_mag(&c, &d) != MP_EQ) {
	    printf("mp_unsigned_bin failure!\n");
	    draw(&c);
	    draw(&d);
	    return 0;
	 }

      } else if (!strcmp(cmd, "sub")) {
	 ++sub_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 mp_copy(&a, &d);
	 mp_sub(&d, &b, &d);
	 if (mp_cmp(&c, &d) != MP_EQ) {
	    printf("sub %lu failure!\n", sub_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    return 0;
	 }
      } else if (!strcmp(cmd, "mul")) {
	 ++mul_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 mp_copy(&a, &d);
	 mp_mul(&d, &b, &d);
	 if (mp_cmp(&c, &d) != MP_EQ) {
	    printf("mul %lu failure!\n", mul_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    return 0;
	 }
      } else if (!strcmp(cmd, "div")) {
	 ++div_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&d, buf, 64);

	 mp_div(&a, &b, &e, &f);
	 if (mp_cmp(&c, &e) != MP_EQ || mp_cmp(&d, &f) != MP_EQ) {
	    printf("div %lu %d, %d, failure!\n", div_n, mp_cmp(&c, &e),
		   mp_cmp(&d, &f));
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    draw(&e);
	    draw(&f);
	    return 0;
	 }

      } else if (!strcmp(cmd, "sqr")) {
	 ++sqr_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 mp_copy(&a, &c);
	 mp_sqr(&c, &c);
	 if (mp_cmp(&b, &c) != MP_EQ) {
	    printf("sqr %lu failure!\n", sqr_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    return 0;
	 }
      } else if (!strcmp(cmd, "gcd")) {
	 ++gcd_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 mp_copy(&a, &d);
	 mp_gcd(&d, &b, &d);
	 d.sign = c.sign;
	 if (mp_cmp(&c, &d) != MP_EQ) {
	    printf("gcd %lu failure!\n", gcd_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    return 0;
	 }
      } else if (!strcmp(cmd, "lcm")) {
	 ++lcm_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 mp_copy(&a, &d);
	 mp_lcm(&d, &b, &d);
	 d.sign = c.sign;
	 if (mp_cmp(&c, &d) != MP_EQ) {
	    printf("lcm %lu failure!\n", lcm_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    return 0;
	 }
      } else if (!strcmp(cmd, "expt")) {
	 ++expt_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&d, buf, 64);
	 mp_copy(&a, &e);
	 mp_exptmod(&e, &b, &c, &e);
	 if (mp_cmp(&d, &e) != MP_EQ) {
	    printf("expt %lu failure!\n", expt_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    draw(&e);
	    return 0;
	 }
      } else if (!strcmp(cmd, "invmod")) {
	 ++inv_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&c, buf, 64);
	 mp_invmod(&a, &b, &d);
	 mp_mulmod(&d, &a, &b, &e);
	 if (mp_cmp_d(&e, 1) != MP_EQ) {
	    printf("inv [wrong value from MPI?!] failure\n");
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    draw(&d);
	    mp_gcd(&a, &b, &e);
	    draw(&e);
	    return 0;
	 }

      } else if (!strcmp(cmd, "div2")) {
	 ++div2_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 mp_div_2(&a, &c);
	 if (mp_cmp(&c, &b) != MP_EQ) {
	    printf("div_2 %lu failure\n", div2_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    return 0;
	 }
      } else if (!strcmp(cmd, "mul2")) {
	 ++mul2_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 mp_mul_2(&a, &c);
	 if (mp_cmp(&c, &b) != MP_EQ) {
	    printf("mul_2 %lu failure\n", mul2_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    return 0;
	 }
      } else if (!strcmp(cmd, "add_d")) {
	 ++add_d_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 sscanf(buf, "%d", &ix);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 mp_add_d(&a, ix, &c);
	 if (mp_cmp(&b, &c) != MP_EQ) {
	    printf("add_d %lu failure\n", add_d_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    printf("d == %d\n", ix);
	    return 0;
	 }
      } else if (!strcmp(cmd, "sub_d")) {
	 ++sub_d_n;
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&a, buf, 64);
	 fgets(buf, 4095, stdin);
	 sscanf(buf, "%d", &ix);
	 fgets(buf, 4095, stdin);
	 mp_read_radix(&b, buf, 64);
	 mp_sub_d(&a, ix, &c);
	 if (mp_cmp(&b, &c) != MP_EQ) {
	    printf("sub_d %lu failure\n", sub_d_n);
	    draw(&a);
	    draw(&b);
	    draw(&c);
	    printf("d == %d\n", ix);
	    return 0;
	 }
      }
   }
   return 0;
}

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/demo.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/demo/timing.c.































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
#include <tommath.h>
#include <time.h>

ulong64 _tt;

#ifdef IOWNANATHLON
#include <unistd.h>
#define SLEEP sleep(4)
#else
#define SLEEP
#endif


void ndraw(mp_int * a, char *name)
{
   char buf[4096];

   printf("%s: ", name);
   mp_toradix(a, buf, 64);
   printf("%s\n", buf);
}

static void draw(mp_int * a)
{
   ndraw(a, "");
}


unsigned long lfsr = 0xAAAAAAAAUL;

int lbit(void)
{
   if (lfsr & 0x80000000UL) {
      lfsr = ((lfsr << 1) ^ 0x8000001BUL) & 0xFFFFFFFFUL;
      return 1;
   } else {
      lfsr <<= 1;
      return 0;
   }
}

/* RDTSC from Scott Duplichan */
static ulong64 TIMFUNC(void)
{
#if defined __GNUC__
#if defined(__i386__) || defined(__x86_64__)
   unsigned long long a;
   __asm__ __volatile__("rdtsc\nmovl %%eax,%0\nmovl %%edx,4+%0\n"::
			"m"(a):"%eax", "%edx");
   return a;
#else /* gcc-IA64 version */
   unsigned long result;
   __asm__ __volatile__("mov %0=ar.itc":"=r"(result)::"memory");

   while (__builtin_expect((int) result == -1, 0))
      __asm__ __volatile__("mov %0=ar.itc":"=r"(result)::"memory");

   return result;
#endif

   // Microsoft and Intel Windows compilers
#elif defined _M_IX86
   __asm rdtsc
#elif defined _M_AMD64
   return __rdtsc();
#elif defined _M_IA64
#if defined __INTEL_COMPILER
#include <ia64intrin.h>
#endif
   return __getReg(3116);
#else
#error need rdtsc function for this build
#endif
}

#define DO(x) x; x;
//#define DO4(x) DO2(x); DO2(x);
//#define DO8(x) DO4(x); DO4(x);
//#define DO(x)  DO8(x); DO8(x);

int main(void)
{
   ulong64 tt, gg, CLK_PER_SEC;
   FILE *log, *logb, *logc, *logd;
   mp_int a, b, c, d, e, f;
   int n, cnt, ix, old_kara_m, old_kara_s;
   unsigned rr;

   mp_init(&a);
   mp_init(&b);
   mp_init(&c);
   mp_init(&d);
   mp_init(&e);
   mp_init(&f);

   srand(time(NULL));


   /* temp. turn off TOOM */
   TOOM_MUL_CUTOFF = TOOM_SQR_CUTOFF = 100000;

   CLK_PER_SEC = TIMFUNC();
   sleep(1);
   CLK_PER_SEC = TIMFUNC() - CLK_PER_SEC;

   printf("CLK_PER_SEC == %llu\n", CLK_PER_SEC);
   goto exptmod;
   log = fopen("logs/add.log", "w");
   for (cnt = 8; cnt <= 128; cnt += 8) {
      SLEEP;
      mp_rand(&a, cnt);
      mp_rand(&b, cnt);
      rr = 0;
      tt = -1;
      do {
	 gg = TIMFUNC();
	 DO(mp_add(&a, &b, &c));
	 gg = (TIMFUNC() - gg) >> 1;
	 if (tt > gg)
	    tt = gg;
      } while (++rr < 100000);
      printf("Adding\t\t%4d-bit => %9llu/sec, %9llu cycles\n",
	     mp_count_bits(&a), CLK_PER_SEC / tt, tt);
      fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt);
      fflush(log);
   }
   fclose(log);

   log = fopen("logs/sub.log", "w");
   for (cnt = 8; cnt <= 128; cnt += 8) {
      SLEEP;
      mp_rand(&a, cnt);
      mp_rand(&b, cnt);
      rr = 0;
      tt = -1;
      do {
	 gg = TIMFUNC();
	 DO(mp_sub(&a, &b, &c));
	 gg = (TIMFUNC() - gg) >> 1;
	 if (tt > gg)
	    tt = gg;
      } while (++rr < 100000);

      printf("Subtracting\t\t%4d-bit => %9llu/sec, %9llu cycles\n",
	     mp_count_bits(&a), CLK_PER_SEC / tt, tt);
      fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt);
      fflush(log);
   }
   fclose(log);

   /* do mult/square twice, first without karatsuba and second with */
 multtest:
   old_kara_m = KARATSUBA_MUL_CUTOFF;
   old_kara_s = KARATSUBA_SQR_CUTOFF;
   for (ix = 0; ix < 2; ix++) {
      printf("With%s Karatsuba\n", (ix == 0) ? "out" : "");

      KARATSUBA_MUL_CUTOFF = (ix == 0) ? 9999 : old_kara_m;
      KARATSUBA_SQR_CUTOFF = (ix == 0) ? 9999 : old_kara_s;

      log = fopen((ix == 0) ? "logs/mult.log" : "logs/mult_kara.log", "w");
      for (cnt = 4; cnt <= 10240 / DIGIT_BIT; cnt += 2) {
	 SLEEP;
	 mp_rand(&a, cnt);
	 mp_rand(&b, cnt);
	 rr = 0;
	 tt = -1;
	 do {
	    gg = TIMFUNC();
	    DO(mp_mul(&a, &b, &c));
	    gg = (TIMFUNC() - gg) >> 1;
	    if (tt > gg)
	       tt = gg;
	 } while (++rr < 100);
	 printf("Multiplying\t%4d-bit => %9llu/sec, %9llu cycles\n",
		mp_count_bits(&a), CLK_PER_SEC / tt, tt);
	 fprintf(log, "%d %9llu\n", mp_count_bits(&a), tt);
	 fflush(log);
      }
      fclose(log);

      log = fopen((ix == 0) ? "logs/sqr.log" : "logs/sqr_kara.log", "w");
      for (cnt = 4; cnt <= 10240 / DIGIT_BIT; cnt += 2) {
	 SLEEP;
	 mp_rand(&a, cnt);
	 rr = 0;
	 tt = -1;
	 do {
	    gg = TIMFUNC();
	    DO(mp_sqr(&a, &b));
	    gg = (TIMFUNC() - gg) >> 1;
	    if (tt > gg)
	       tt = gg;
	 } while (++rr < 100);
	 printf("Squaring\t%4d-bit => %9llu/sec, %9llu cycles\n",
		mp_count_bits(&a), CLK_PER_SEC / tt, tt);
	 fprintf(log, "%d %9llu\n", mp_count_bits(&a), tt);
	 fflush(log);
      }
      fclose(log);

   }
 exptmod:

   {
      char *primes[] = {
	 /* 2K large moduli */
	 "179769313486231590772930519078902473361797697894230657273430081157732675805500963132708477322407536021120113879871393357658789768814416622492847430639474124377767893424865485276302219601246094119453082952085005768838150682342462881473913110540827237163350510684586239334100047359817950870678242457666208137217",
	 "32317006071311007300714876688669951960444102669715484032130345427524655138867890893197201411522913463688717960921898019494119559150490921095088152386448283120630877367300996091750197750389652106796057638384067568276792218642619756161838094338476170470581645852036305042887575891541065808607552399123930385521914333389668342420684974786564569494856176035326322058077805659331026192708460314150258592864177116725943603718461857357598351152301645904403697613233287231227125684710820209725157101726931323469678542580656697935045997268352998638099733077152121140120031150424541696791951097529546801429027668869927491725169",
	 "1044388881413152506691752710716624382579964249047383780384233483283953907971557456848826811934997558340890106714439262837987573438185793607263236087851365277945956976543709998340361590134383718314428070011855946226376318839397712745672334684344586617496807908705803704071284048740118609114467977783598029006686938976881787785946905630190260940599579453432823469303026696443059025015972399867714215541693835559885291486318237914434496734087811872639496475100189041349008417061675093668333850551032972088269550769983616369411933015213796825837188091833656751221318492846368125550225998300412344784862595674492194617023806505913245610825731835380087608622102834270197698202313169017678006675195485079921636419370285375124784014907159135459982790513399611551794271106831134090584272884279791554849782954323534517065223269061394905987693002122963395687782878948440616007412945674919823050571642377154816321380631045902916136926708342856440730447899971901781465763473223850267253059899795996090799469201774624817718449867455659250178329070473119433165550807568221846571746373296884912819520317457002440926616910874148385078411929804522981857338977648103126085902995208257421855249796721729039744118165938433694823325696642096892124547425283",
	 /* 2K moduli mersenne primes */
	 "6864797660130609714981900799081393217269435300143305409394463459185543183397656052122559640661454554977296311391480858037121987999716643812574028291115057151",
	 "531137992816767098689588206552468627329593117727031923199444138200403559860852242739162502265229285668889329486246501015346579337652707239409519978766587351943831270835393219031728127",
	 "10407932194664399081925240327364085538615262247266704805319112350403608059673360298012239441732324184842421613954281007791383566248323464908139906605677320762924129509389220345773183349661583550472959420547689811211693677147548478866962501384438260291732348885311160828538416585028255604666224831890918801847068222203140521026698435488732958028878050869736186900714720710555703168729087",
	 "1475979915214180235084898622737381736312066145333169775147771216478570297878078949377407337049389289382748507531496480477281264838760259191814463365330269540496961201113430156902396093989090226259326935025281409614983499388222831448598601834318536230923772641390209490231836446899608210795482963763094236630945410832793769905399982457186322944729636418890623372171723742105636440368218459649632948538696905872650486914434637457507280441823676813517852099348660847172579408422316678097670224011990280170474894487426924742108823536808485072502240519452587542875349976558572670229633962575212637477897785501552646522609988869914013540483809865681250419497686697771007",
	 "259117086013202627776246767922441530941818887553125427303974923161874019266586362086201209516800483406550695241733194177441689509238807017410377709597512042313066624082916353517952311186154862265604547691127595848775610568757931191017711408826252153849035830401185072116424747461823031471398340229288074545677907941037288235820705892351068433882986888616658650280927692080339605869308790500409503709875902119018371991620994002568935113136548829739112656797303241986517250116412703509705427773477972349821676443446668383119322540099648994051790241624056519054483690809616061625743042361721863339415852426431208737266591962061753535748892894599629195183082621860853400937932839420261866586142503251450773096274235376822938649407127700846077124211823080804139298087057504713825264571448379371125032081826126566649084251699453951887789613650248405739378594599444335231188280123660406262468609212150349937584782292237144339628858485938215738821232393687046160677362909315071",
	 "190797007524439073807468042969529173669356994749940177394741882673528979787005053706368049835514900244303495954950709725762186311224148828811920216904542206960744666169364221195289538436845390250168663932838805192055137154390912666527533007309292687539092257043362517857366624699975402375462954490293259233303137330643531556539739921926201438606439020075174723029056838272505051571967594608350063404495977660656269020823960825567012344189908927956646011998057988548630107637380993519826582389781888135705408653045219655801758081251164080554609057468028203308718724654081055323215860189611391296030471108443146745671967766308925858547271507311563765171008318248647110097614890313562856541784154881743146033909602737947385055355960331855614540900081456378659068370317267696980001187750995491090350108417050917991562167972281070161305972518044872048331306383715094854938415738549894606070722584737978176686422134354526989443028353644037187375385397838259511833166416134323695660367676897722287918773420968982326089026150031515424165462111337527431154890666327374921446276833564519776797633875503548665093914556482031482248883127023777039667707976559857333357013727342079099064400455741830654320379350833236245819348824064783585692924881021978332974949906122664421376034687815350484991",

	 /* DR moduli */
	 "14059105607947488696282932836518693308967803494693489478439861164411992439598399594747002144074658928593502845729752797260025831423419686528151609940203368612079",
	 "101745825697019260773923519755878567461315282017759829107608914364075275235254395622580447400994175578963163918967182013639660669771108475957692810857098847138903161308502419410142185759152435680068435915159402496058513611411688900243039",
	 "736335108039604595805923406147184530889923370574768772191969612422073040099331944991573923112581267542507986451953227192970402893063850485730703075899286013451337291468249027691733891486704001513279827771740183629161065194874727962517148100775228363421083691764065477590823919364012917984605619526140821797602431",
	 "38564998830736521417281865696453025806593491967131023221754800625044118265468851210705360385717536794615180260494208076605798671660719333199513807806252394423283413430106003596332513246682903994829528690198205120921557533726473585751382193953592127439965050261476810842071573684505878854588706623484573925925903505747545471088867712185004135201289273405614415899438276535626346098904241020877974002916168099951885406379295536200413493190419727789712076165162175783",
	 "542189391331696172661670440619180536749994166415993334151601745392193484590296600979602378676624808129613777993466242203025054573692562689251250471628358318743978285860720148446448885701001277560572526947619392551574490839286458454994488665744991822837769918095117129546414124448777033941223565831420390846864429504774477949153794689948747680362212954278693335653935890352619041936727463717926744868338358149568368643403037768649616778526013610493696186055899318268339432671541328195724261329606699831016666359440874843103020666106568222401047720269951530296879490444224546654729111504346660859907296364097126834834235287147",
	 "1487259134814709264092032648525971038895865645148901180585340454985524155135260217788758027400478312256339496385275012465661575576202252063145698732079880294664220579764848767704076761853197216563262660046602703973050798218246170835962005598561669706844469447435461092542265792444947706769615695252256130901271870341005768912974433684521436211263358097522726462083917939091760026658925757076733484173202927141441492573799914240222628795405623953109131594523623353044898339481494120112723445689647986475279242446083151413667587008191682564376412347964146113898565886683139407005941383669325997475076910488086663256335689181157957571445067490187939553165903773554290260531009121879044170766615232300936675369451260747671432073394867530820527479172464106442450727640226503746586340279816318821395210726268291535648506190714616083163403189943334431056876038286530365757187367147446004855912033137386225053275419626102417236133948503",
	 "1095121115716677802856811290392395128588168592409109494900178008967955253005183831872715423151551999734857184538199864469605657805519106717529655044054833197687459782636297255219742994736751541815269727940751860670268774903340296040006114013971309257028332849679096824800250742691718610670812374272414086863715763724622797509437062518082383056050144624962776302147890521249477060215148275163688301275847155316042279405557632639366066847442861422164832655874655824221577849928863023018366835675399949740429332468186340518172487073360822220449055340582568461568645259954873303616953776393853174845132081121976327462740354930744487429617202585015510744298530101547706821590188733515880733527449780963163909830077616357506845523215289297624086914545378511082534229620116563260168494523906566709418166011112754529766183554579321224940951177394088465596712620076240067370589036924024728375076210477267488679008016579588696191194060127319035195370137160936882402244399699172017835144537488486396906144217720028992863941288217185353914991583400421682751000603596655790990815525126154394344641336397793791497068253936771017031980867706707490224041075826337383538651825493679503771934836094655802776331664261631740148281763487765852746577808019633679",

	 /* generic unrestricted moduli */
	 "17933601194860113372237070562165128350027320072176844226673287945873370751245439587792371960615073855669274087805055507977323024886880985062002853331424203",
	 "2893527720709661239493896562339544088620375736490408468011883030469939904368086092336458298221245707898933583190713188177399401852627749210994595974791782790253946539043962213027074922559572312141181787434278708783207966459019479487",
	 "347743159439876626079252796797422223177535447388206607607181663903045907591201940478223621722118173270898487582987137708656414344685816179420855160986340457973820182883508387588163122354089264395604796675278966117567294812714812796820596564876450716066283126720010859041484786529056457896367683122960411136319",
	 "47266428956356393164697365098120418976400602706072312735924071745438532218237979333351774907308168340693326687317443721193266215155735814510792148768576498491199122744351399489453533553203833318691678263241941706256996197460424029012419012634671862283532342656309677173602509498417976091509154360039893165037637034737020327399910409885798185771003505320583967737293415979917317338985837385734747478364242020380416892056650841470869294527543597349250299539682430605173321029026555546832473048600327036845781970289288898317888427517364945316709081173840186150794397479045034008257793436817683392375274635794835245695887",
	 "436463808505957768574894870394349739623346440601945961161254440072143298152040105676491048248110146278752857839930515766167441407021501229924721335644557342265864606569000117714935185566842453630868849121480179691838399545644365571106757731317371758557990781880691336695584799313313687287468894148823761785582982549586183756806449017542622267874275103877481475534991201849912222670102069951687572917937634467778042874315463238062009202992087620963771759666448266532858079402669920025224220613419441069718482837399612644978839925207109870840278194042158748845445131729137117098529028886770063736487420613144045836803985635654192482395882603511950547826439092832800532152534003936926017612446606135655146445620623395788978726744728503058670046885876251527122350275750995227",
	 "11424167473351836398078306042624362277956429440521137061889702611766348760692206243140413411077394583180726863277012016602279290144126785129569474909173584789822341986742719230331946072730319555984484911716797058875905400999504305877245849119687509023232790273637466821052576859232452982061831009770786031785669030271542286603956118755585683996118896215213488875253101894663403069677745948305893849505434201763745232895780711972432011344857521691017896316861403206449421332243658855453435784006517202894181640562433575390821384210960117518650374602256601091379644034244332285065935413233557998331562749140202965844219336298970011513882564935538704289446968322281451907487362046511461221329799897350993370560697505809686438782036235372137015731304779072430260986460269894522159103008260495503005267165927542949439526272736586626709581721032189532726389643625590680105784844246152702670169304203783072275089194754889511973916207",
	 "1214855636816562637502584060163403830270705000634713483015101384881871978446801224798536155406895823305035467591632531067547890948695117172076954220727075688048751022421198712032848890056357845974246560748347918630050853933697792254955890439720297560693579400297062396904306270145886830719309296352765295712183040773146419022875165382778007040109957609739589875590885701126197906063620133954893216612678838507540777138437797705602453719559017633986486649523611975865005712371194067612263330335590526176087004421363598470302731349138773205901447704682181517904064735636518462452242791676541725292378925568296858010151852326316777511935037531017413910506921922450666933202278489024521263798482237150056835746454842662048692127173834433089016107854491097456725016327709663199738238442164843147132789153725513257167915555162094970853584447993125488607696008169807374736711297007473812256272245489405898470297178738029484459690836250560495461579533254473316340608217876781986188705928270735695752830825527963838355419762516246028680280988020401914551825487349990306976304093109384451438813251211051597392127491464898797406789175453067960072008590614886532333015881171367104445044718144312416815712216611576221546455968770801413440778423979",
	 NULL
      };
      log = fopen("logs/expt.log", "w");
      logb = fopen("logs/expt_dr.log", "w");
      logc = fopen("logs/expt_2k.log", "w");
      logd = fopen("logs/expt_2kl.log", "w");
      for (n = 0; primes[n]; n++) {
	 SLEEP;
	 mp_read_radix(&a, primes[n], 10);
	 mp_zero(&b);
	 for (rr = 0; rr < (unsigned) mp_count_bits(&a); rr++) {
	    mp_mul_2(&b, &b);
	    b.dp[0] |= lbit();
	    b.used += 1;
	 }
	 mp_sub_d(&a, 1, &c);
	 mp_mod(&b, &c, &b);
	 mp_set(&c, 3);
	 rr = 0;
	 tt = -1;
	 do {
	    gg = TIMFUNC();
	    DO(mp_exptmod(&c, &b, &a, &d));
	    gg = (TIMFUNC() - gg) >> 1;
	    if (tt > gg)
	       tt = gg;
	 } while (++rr < 10);
	 mp_sub_d(&a, 1, &e);
	 mp_sub(&e, &b, &b);
	 mp_exptmod(&c, &b, &a, &e);	/* c^(p-1-b) mod a */
	 mp_mulmod(&e, &d, &a, &d);	/* c^b * c^(p-1-b) == c^p-1 == 1 */
	 if (mp_cmp_d(&d, 1)) {
	    printf("Different (%d)!!!\n", mp_count_bits(&a));
	    draw(&d);
	    exit(0);
	 }
	 printf("Exponentiating\t%4d-bit => %9llu/sec, %9llu cycles\n",
		mp_count_bits(&a), CLK_PER_SEC / tt, tt);
	 fprintf(n < 4 ? logd : (n < 9) ? logc : (n < 16) ? logb : log,
		 "%d %9llu\n", mp_count_bits(&a), tt);
      }
   }
   fclose(log);
   fclose(logb);
   fclose(logc);
   fclose(logd);

   log = fopen("logs/invmod.log", "w");
   for (cnt = 4; cnt <= 128; cnt += 4) {
      SLEEP;
      mp_rand(&a, cnt);
      mp_rand(&b, cnt);

      do {
	 mp_add_d(&b, 1, &b);
	 mp_gcd(&a, &b, &c);
      } while (mp_cmp_d(&c, 1) != MP_EQ);

      rr = 0;
      tt = -1;
      do {
	 gg = TIMFUNC();
	 DO(mp_invmod(&b, &a, &c));
	 gg = (TIMFUNC() - gg) >> 1;
	 if (tt > gg)
	    tt = gg;
      } while (++rr < 1000);
      mp_mulmod(&b, &c, &a, &d);
      if (mp_cmp_d(&d, 1) != MP_EQ) {
	 printf("Failed to invert\n");
	 return 0;
      }
      printf("Inverting mod\t%4d-bit => %9llu/sec, %9llu cycles\n",
	     mp_count_bits(&a), CLK_PER_SEC / tt, tt);
      fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt);
   }
   fclose(log);

   return 0;
}

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/timing.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/dep.pl.























































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
#!/usr/bin/perl 
#
# Walk through source, add labels and make classes
#
#use strict;

my %deplist;

#open class file and write preamble 
open(CLASS, ">tommath_class.h") or die "Couldn't open tommath_class.h for writing\n";
print CLASS "#if !(defined(LTM1) && defined(LTM2) && defined(LTM3))\n#if defined(LTM2)\n#define LTM3\n#endif\n#if defined(LTM1)\n#define LTM2\n#endif\n#define LTM1\n\n#if defined(LTM_ALL)\n";

foreach my $filename (glob "bn*.c") {
   my $define = $filename;

print "Processing $filename\n";

   # convert filename to upper case so we can use it as a define 
   $define =~ tr/[a-z]/[A-Z]/;
   $define =~ tr/\./_/;
   print CLASS "#define $define\n";

   # now copy text and apply #ifdef as required 
   my $apply = 0;
   open(SRC, "<$filename");
   open(OUT, ">tmp");

   # first line will be the #ifdef
   my $line = <SRC>;
   if ($line =~ /include/) {
      print OUT $line;
   } else {
      print OUT "#include <tommath.h>\n#ifdef $define\n$line";
      $apply = 1;
   }
   while (<SRC>) {
      if (!($_ =~ /tommath\.h/)) {
         print OUT $_;
      }
   }
   if ($apply == 1) {
      print OUT "#endif\n";
   }
   close SRC;
   close OUT;

   unlink($filename);
   rename("tmp", $filename);
}
print CLASS "#endif\n\n";

# now do classes 

foreach my $filename (glob "bn*.c") {
   open(SRC, "<$filename") or die "Can't open source file!\n"; 

   # convert filename to upper case so we can use it as a define 
   $filename =~ tr/[a-z]/[A-Z]/;
   $filename =~ tr/\./_/;

   print CLASS "#if defined($filename)\n";
   my $list = $filename;

   # scan for mp_* and make classes
   while (<SRC>) {
      my $line = $_;
      while ($line =~ m/(fast_)*(s_)*mp\_[a-z_0-9]*/) {
          $line = $';
          # now $& is the match, we want to skip over LTM keywords like
          # mp_int, mp_word, mp_digit
          if (!($& eq "mp_digit") && !($& eq "mp_word") && !($& eq "mp_int")) {
             my $a = $&;
             $a =~ tr/[a-z]/[A-Z]/;
             $a = "BN_" . $a . "_C";
             if (!($list =~ /$a/)) {
                print CLASS "   #define $a\n";
             }
             $list = $list . "," . $a;
          }
      }
   }
   @deplist{$filename} = $list;

   print CLASS "#endif\n\n";
   close SRC;
}

print CLASS "#ifdef LTM3\n#define LTM_LAST\n#endif\n#include <tommath_superclass.h>\n#include <tommath_class.h>\n#else\n#define LTM_LAST\n#endif\n";
close CLASS;

#now let's make a cool call graph... 

open(OUT,">callgraph.txt");
$indent = 0;
foreach (keys %deplist) {
   $list = "";
   draw_func(@deplist{$_});
   print OUT "\n\n";
}
close(OUT);

sub draw_func()
{
   my @funcs = split(",", $_[0]);
   if ($list =~ /@funcs[0]/) {
      return;
   } else {
      $list = $list . @funcs[0];
   }
   if ($indent == 0) { }
   elsif ($indent >= 1) { print OUT "|   " x ($indent - 1) . "+--->"; }
   print OUT @funcs[0] . "\n";   
   shift @funcs;
      my $temp = $list;
   foreach my $i (@funcs) {
      ++$indent;
      draw_func(@deplist{$i});
      --$indent;
   }
      $list = $temp;
}


Added libtommath/etc/2kprime.c.









































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
/* Makes safe primes of a 2k nature */
#include <tommath.h>
#include <time.h>

int sizes[] = {256, 512, 768, 1024, 1536, 2048, 3072, 4096};

int main(void)
{
   char buf[2000];
   int x, y;
   mp_int q, p;
   FILE *out;
   clock_t t1;
   mp_digit z;
   
   mp_init_multi(&q, &p, NULL);
   
   out = fopen("2kprime.1", "w");
   for (x = 0; x < (int)(sizeof(sizes) / sizeof(sizes[0])); x++) {
   top:
       mp_2expt(&q, sizes[x]);
       mp_add_d(&q, 3, &q);
       z = -3;
       
       t1 = clock();
       for(;;) {
         mp_sub_d(&q, 4, &q);
         z += 4;

         if (z > MP_MASK) {
            printf("No primes of size %d found\n", sizes[x]);
            break;
         }
         
         if (clock() - t1 > CLOCKS_PER_SEC) { 
            printf("."); fflush(stdout);
//            sleep((clock() - t1 + CLOCKS_PER_SEC/2)/CLOCKS_PER_SEC);
            t1 = clock();
         }
         
         /* quick test on q */
         mp_prime_is_prime(&q, 1, &y);
         if (y == 0) {
            continue;
         }

         /* find (q-1)/2 */
         mp_sub_d(&q, 1, &p);
         mp_div_2(&p, &p);
         mp_prime_is_prime(&p, 3, &y);
         if (y == 0) {
            continue;
         }

         /* test on q */
         mp_prime_is_prime(&q, 3, &y);
         if (y == 0) {
            continue;
         }

         break;
       }
       
       if (y == 0) {
          ++sizes[x];
          goto top;
       }
       
       mp_toradix(&q, buf, 10);
       printf("\n\n%d-bits (k = %lu) = %s\n", sizes[x], z, buf);
       fprintf(out, "%d-bits (k = %lu) = %s\n", sizes[x], z, buf); fflush(out);
   }
   
   return 0;
}   
       
         
            
            
          

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/2kprime.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/etc/drprime.c.

































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
/* Makes safe primes of a DR nature */
#include <tommath.h>

int sizes[] = { 1+256/DIGIT_BIT, 1+512/DIGIT_BIT, 1+768/DIGIT_BIT, 1+1024/DIGIT_BIT, 1+2048/DIGIT_BIT, 1+4096/DIGIT_BIT };
int main(void)
{
   int res, x, y;
   char buf[4096];
   FILE *out;
   mp_int a, b;
   
   mp_init(&a);
   mp_init(&b);
   
   out = fopen("drprimes.txt", "w");
   for (x = 0; x < (int)(sizeof(sizes)/sizeof(sizes[0])); x++) {
   top:
       printf("Seeking a %d-bit safe prime\n", sizes[x] * DIGIT_BIT);
       mp_grow(&a, sizes[x]);
       mp_zero(&a);
       for (y = 1; y < sizes[x]; y++) {
           a.dp[y] = MP_MASK;
       }
       
       /* make a DR modulus */
       a.dp[0] = -1;
       a.used = sizes[x];
       
       /* now loop */
       res = 0;
       for (;;) { 
          a.dp[0] += 4;
          if (a.dp[0] >= MP_MASK) break;
          mp_prime_is_prime(&a, 1, &res);
          if (res == 0) continue;
          printf("."); fflush(stdout);
          mp_sub_d(&a, 1, &b);
          mp_div_2(&b, &b);
          mp_prime_is_prime(&b, 3, &res);  
          if (res == 0) continue;
          mp_prime_is_prime(&a, 3, &res);
          if (res == 1) break;
	}
        
        if (res != 1) {
           printf("Error not DR modulus\n"); sizes[x] += 1; goto top;
        } else {
           mp_toradix(&a, buf, 10);
           printf("\n\np == %s\n\n", buf);
           fprintf(out, "%d-bit prime:\np == %s\n\n", mp_count_bits(&a), buf); fflush(out);
        }           
   }
   fclose(out);
   
   mp_clear(&a);
   mp_clear(&b);
   
   return 0;
}


/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/drprime.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/etc/makefile.icc.







































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
CC = icc

CFLAGS += -I../

# optimize for SPEED
#
# -mcpu= can be pentium, pentiumpro (covers PII through PIII) or pentium4
# -ax?   specifies make code specifically for ? but compatible with IA-32
# -x?    specifies compile solely for ? [not specifically IA-32 compatible]
#
# where ? is 
#   K - PIII
#   W - first P4 [Williamette]
#   N - P4 Northwood
#   P - P4 Prescott
#   B - Blend of P4 and PM [mobile]
#
# Default to just generic max opts
CFLAGS += -O3 -xP -ip

# default lib name (requires install with root)
# LIBNAME=-ltommath

# libname when you can't install the lib with install
LIBNAME=../libtommath.a

#provable primes
pprime: pprime.o
	$(CC) pprime.o $(LIBNAME) -o pprime

# portable [well requires clock()] tuning app
tune: tune.o
	$(CC) tune.o $(LIBNAME) -o tune
	
# same app but using RDTSC for higher precision [requires 80586+], coff based gcc installs [e.g. ming, cygwin, djgpp]
tune86: tune.c
	nasm -f coff timer.asm
	$(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o  $(LIBNAME) -o tune86
	
# for cygwin
tune86c: tune.c
	nasm -f gnuwin32 timer.asm
	$(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o  $(LIBNAME) -o tune86

#make tune86 for linux or any ELF format
tune86l: tune.c
	nasm -f elf -DUSE_ELF timer.asm
	$(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86l
        
# spits out mersenne primes
mersenne: mersenne.o
	$(CC) mersenne.o $(LIBNAME) -o mersenne

# fines DR safe primes for the given config
drprime: drprime.o
	$(CC) drprime.o $(LIBNAME) -o drprime
	
# fines 2k safe primes for the given config
2kprime: 2kprime.o
	$(CC) 2kprime.o $(LIBNAME) -o 2kprime

mont: mont.o
	$(CC) mont.o $(LIBNAME) -o mont

        
clean:
	rm -f *.log *.o *.obj *.exe pprime tune mersenne drprime tune86 tune86l mont 2kprime pprime.dat *.il

Added libtommath/etc/mersenne.c.

































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
/* Finds Mersenne primes using the Lucas-Lehmer test 
 *
 * Tom St Denis, [email protected]
 */
#include <time.h>
#include <tommath.h>

int
is_mersenne (long s, int *pp)
{
  mp_int  n, u;
  int     res, k;
  
  *pp = 0;

  if ((res = mp_init (&n)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init (&u)) != MP_OKAY) {
    goto LBL_N;
  }

  /* n = 2^s - 1 */
  if ((res = mp_2expt(&n, s)) != MP_OKAY) {
     goto LBL_MU;
  }
  if ((res = mp_sub_d (&n, 1, &n)) != MP_OKAY) {
    goto LBL_MU;
  }

  /* set u=4 */
  mp_set (&u, 4);

  /* for k=1 to s-2 do */
  for (k = 1; k <= s - 2; k++) {
    /* u = u^2 - 2 mod n */
    if ((res = mp_sqr (&u, &u)) != MP_OKAY) {
      goto LBL_MU;
    }
    if ((res = mp_sub_d (&u, 2, &u)) != MP_OKAY) {
      goto LBL_MU;
    }

    /* make sure u is positive */
    while (u.sign == MP_NEG) {
      if ((res = mp_add (&u, &n, &u)) != MP_OKAY) {
         goto LBL_MU;
      }
    }

    /* reduce */
    if ((res = mp_reduce_2k (&u, &n, 1)) != MP_OKAY) {
      goto LBL_MU;
    }
  }

  /* if u == 0 then its prime */
  if (mp_iszero (&u) == 1) {
    mp_prime_is_prime(&n, 8, pp);
  if (*pp != 1) printf("FAILURE\n");
  }

  res = MP_OKAY;
LBL_MU:mp_clear (&u);
LBL_N:mp_clear (&n);
  return res;
}

/* square root of a long < 65536 */
long
i_sqrt (long x)
{
  long    x1, x2;

  x2 = 16;
  do {
    x1 = x2;
    x2 = x1 - ((x1 * x1) - x) / (2 * x1);
  } while (x1 != x2);

  if (x1 * x1 > x) {
    --x1;
  }

  return x1;
}

/* is the long prime by brute force */
int
isprime (long k)
{
  long    y, z;

  y = i_sqrt (k);
  for (z = 2; z <= y; z++) {
    if ((k % z) == 0)
      return 0;
  }
  return 1;
}


int
main (void)
{
  int     pp;
  long    k;
  clock_t tt;

  k = 3;

  for (;;) {
    /* start time */
    tt = clock ();

    /* test if 2^k - 1 is prime */
    if (is_mersenne (k, &pp) != MP_OKAY) {
      printf ("Whoa error\n");
      return -1;
    }

    if (pp == 1) {
      /* count time */
      tt = clock () - tt;

      /* display if prime */
      printf ("2^%-5ld - 1 is prime, test took %ld ticks\n", k, tt);
    }

    /* goto next odd exponent */
    k += 2;

    /* but make sure its prime */
    while (isprime (k) == 0) {
      k += 2;
    }
  }
  return 0;
}

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mersenne.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/etc/mont.c.





































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
/* tests the montgomery routines */
#include <tommath.h>

int main(void)
{
   mp_int modulus, R, p, pp;
   mp_digit mp;
   long x, y;

   srand(time(NULL));
   mp_init_multi(&modulus, &R, &p, &pp, NULL);

   /* loop through various sizes */
   for (x = 4; x < 256; x++) {
       printf("DIGITS == %3ld...", x); fflush(stdout);
       
       /* make up the odd modulus */
       mp_rand(&modulus, x);
       modulus.dp[0] |= 1;
       
       /* now find the R value */
       mp_montgomery_calc_normalization(&R, &modulus);
       mp_montgomery_setup(&modulus, &mp);
       
       /* now run through a bunch tests */
       for (y = 0; y < 1000; y++) {
           mp_rand(&p, x/2);        /* p = random */
           mp_mul(&p, &R, &pp);     /* pp = R * p */
           mp_montgomery_reduce(&pp, &modulus, mp);
           
           /* should be equal to p */
           if (mp_cmp(&pp, &p) != MP_EQ) {
              printf("FAILURE!\n");
              exit(-1);
           }
       }
       printf("PASSED\n");
    }
    
    return 0;
}






/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mont.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/etc/pprime.c.

































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
/* Generates provable primes
 *
 * See http://iahu.ca:8080/papers/pp.pdf for more info.
 *
 * Tom St Denis, [email protected], http://tom.iahu.ca
 */
#include <time.h>
#include "tommath.h"

int   n_prime;
FILE *primes;

/* fast square root */
static  mp_digit
i_sqrt (mp_word x)
{
  mp_word x1, x2;

  x2 = x;
  do {
    x1 = x2;
    x2 = x1 - ((x1 * x1) - x) / (2 * x1);
  } while (x1 != x2);

  if (x1 * x1 > x) {
    --x1;
  }

  return x1;
}


/* generates a prime digit */
static void gen_prime (void)
{
  mp_digit r, x, y, next;
  FILE *out;

  out = fopen("pprime.dat", "wb");

  /* write first set of primes */
  r = 3; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 5; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 7; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 11; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 13; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 17; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 19; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 23; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 29; fwrite(&r, 1, sizeof(mp_digit), out);
  r = 31; fwrite(&r, 1, sizeof(mp_digit), out);

  /* get square root, since if 'r' is composite its factors must be < than this */
  y = i_sqrt (r);
  next = (y + 1) * (y + 1);

  for (;;) {
  do {
    r += 2;			/* next candidate */
    r &= MP_MASK;
    if (r < 31) break;

    /* update sqrt ? */
    if (next <= r) {
      ++y;
      next = (y + 1) * (y + 1);
    }

    /* loop if divisible by 3,5,7,11,13,17,19,23,29  */
    if ((r % 3) == 0) {
      x = 0;
      continue;
    }
    if ((r % 5) == 0) {
      x = 0;
      continue;
    }
    if ((r % 7) == 0) {
      x = 0;
      continue;
    }
    if ((r % 11) == 0) {
      x = 0;
      continue;
    }
    if ((r % 13) == 0) {
      x = 0;
      continue;
    }
    if ((r % 17) == 0) {
      x = 0;
      continue;
    }
    if ((r % 19) == 0) {
      x = 0;
      continue;
    }
    if ((r % 23) == 0) {
      x = 0;
      continue;
    }
    if ((r % 29) == 0) {
      x = 0;
      continue;
    }

    /* now check if r is divisible by x + k={1,7,11,13,17,19,23,29} */
    for (x = 30; x <= y; x += 30) {
      if ((r % (x + 1)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 7)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 11)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 13)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 17)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 19)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 23)) == 0) {
	x = 0;
	break;
      }
      if ((r % (x + 29)) == 0) {
	x = 0;
	break;
      }
    }
  } while (x == 0);
  if (r > 31) { fwrite(&r, 1, sizeof(mp_digit), out); printf("%9d\r", r); fflush(stdout); }
  if (r < 31) break;
  }

  fclose(out);
}

void load_tab(void)
{
   primes = fopen("pprime.dat", "rb");
   if (primes == NULL) {
      gen_prime();
      primes = fopen("pprime.dat", "rb");
   }
   fseek(primes, 0, SEEK_END);
   n_prime = ftell(primes) / sizeof(mp_digit);
}

mp_digit prime_digit(void)
{
   int n;
   mp_digit d;

   n = abs(rand()) % n_prime;
   fseek(primes, n * sizeof(mp_digit), SEEK_SET);
   fread(&d, 1, sizeof(mp_digit), primes);
   return d;
}


/* makes a prime of at least k bits */
int
pprime (int k, int li, mp_int * p, mp_int * q)
{
  mp_int  a, b, c, n, x, y, z, v;
  int     res, ii;
  static const mp_digit bases[] = { 2, 3, 5, 7, 11, 13, 17, 19 };

  /* single digit ? */
  if (k <= (int) DIGIT_BIT) {
    mp_set (p, prime_digit ());
    return MP_OKAY;
  }

  if ((res = mp_init (&c)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init (&v)) != MP_OKAY) {
    goto LBL_C;
  }

  /* product of first 50 primes */
  if ((res =
       mp_read_radix (&v,
		      "19078266889580195013601891820992757757219839668357012055907516904309700014933909014729740190",
		      10)) != MP_OKAY) {
    goto LBL_V;
  }

  if ((res = mp_init (&a)) != MP_OKAY) {
    goto LBL_V;
  }

  /* set the prime */
  mp_set (&a, prime_digit ());

  if ((res = mp_init (&b)) != MP_OKAY) {
    goto LBL_A;
  }

  if ((res = mp_init (&n)) != MP_OKAY) {
    goto LBL_B;
  }

  if ((res = mp_init (&x)) != MP_OKAY) {
    goto LBL_N;
  }

  if ((res = mp_init (&y)) != MP_OKAY) {
    goto LBL_X;
  }

  if ((res = mp_init (&z)) != MP_OKAY) {
    goto LBL_Y;
  }

  /* now loop making the single digit */
  while (mp_count_bits (&a) < k) {
    fprintf (stderr, "prime has %4d bits left\r", k - mp_count_bits (&a));
    fflush (stderr);
  top:
    mp_set (&b, prime_digit ());

    /* now compute z = a * b * 2 */
    if ((res = mp_mul (&a, &b, &z)) != MP_OKAY) {	/* z = a * b */
      goto LBL_Z;
    }

    if ((res = mp_copy (&z, &c)) != MP_OKAY) {	/* c = a * b */
      goto LBL_Z;
    }

    if ((res = mp_mul_2 (&z, &z)) != MP_OKAY) {	/* z = 2 * a * b */
      goto LBL_Z;
    }

    /* n = z + 1 */
    if ((res = mp_add_d (&z, 1, &n)) != MP_OKAY) {	/* n = z + 1 */
      goto LBL_Z;
    }

    /* check (n, v) == 1 */
    if ((res = mp_gcd (&n, &v, &y)) != MP_OKAY) {	/* y = (n, v) */
      goto LBL_Z;
    }

    if (mp_cmp_d (&y, 1) != MP_EQ)
      goto top;

    /* now try base x=bases[ii]  */
    for (ii = 0; ii < li; ii++) {
      mp_set (&x, bases[ii]);

      /* compute x^a mod n */
      if ((res = mp_exptmod (&x, &a, &n, &y)) != MP_OKAY) {	/* y = x^a mod n */
	goto LBL_Z;
      }

      /* if y == 1 loop */
      if (mp_cmp_d (&y, 1) == MP_EQ)
	continue;

      /* now x^2a mod n */
      if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) {	/* y = x^2a mod n */
	goto LBL_Z;
      }

      if (mp_cmp_d (&y, 1) == MP_EQ)
	continue;

      /* compute x^b mod n */
      if ((res = mp_exptmod (&x, &b, &n, &y)) != MP_OKAY) {	/* y = x^b mod n */
	goto LBL_Z;
      }

      /* if y == 1 loop */
      if (mp_cmp_d (&y, 1) == MP_EQ)
	continue;

      /* now x^2b mod n */
      if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) {	/* y = x^2b mod n */
	goto LBL_Z;
      }

      if (mp_cmp_d (&y, 1) == MP_EQ)
	continue;

      /* compute x^c mod n == x^ab mod n */
      if ((res = mp_exptmod (&x, &c, &n, &y)) != MP_OKAY) {	/* y = x^ab mod n */
	goto LBL_Z;
      }

      /* if y == 1 loop */
      if (mp_cmp_d (&y, 1) == MP_EQ)
	continue;

      /* now compute (x^c mod n)^2 */
      if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) {	/* y = x^2ab mod n */
	goto LBL_Z;
      }

      /* y should be 1 */
      if (mp_cmp_d (&y, 1) != MP_EQ)
	continue;
      break;
    }

    /* no bases worked? */
    if (ii == li)
      goto top;

{
   char buf[4096];

   mp_toradix(&n, buf, 10);
   printf("Certificate of primality for:\n%s\n\n", buf);
   mp_toradix(&a, buf, 10);
   printf("A == \n%s\n\n", buf);
   mp_toradix(&b, buf, 10);
   printf("B == \n%s\n\nG == %d\n", buf, bases[ii]);
   printf("----------------------------------------------------------------\n");
}

    /* a = n */
    mp_copy (&n, &a);
  }

  /* get q to be the order of the large prime subgroup */
  mp_sub_d (&n, 1, q);
  mp_div_2 (q, q);
  mp_div (q, &b, q, NULL);

  mp_exch (&n, p);

  res = MP_OKAY;
LBL_Z:mp_clear (&z);
LBL_Y:mp_clear (&y);
LBL_X:mp_clear (&x);
LBL_N:mp_clear (&n);
LBL_B:mp_clear (&b);
LBL_A:mp_clear (&a);
LBL_V:mp_clear (&v);
LBL_C:mp_clear (&c);
  return res;
}


int
main (void)
{
  mp_int  p, q;
  char    buf[4096];
  int     k, li;
  clock_t t1;

  srand (time (NULL));
  load_tab();

  printf ("Enter # of bits: \n");
  fgets (buf, sizeof (buf), stdin);
  sscanf (buf, "%d", &k);

  printf ("Enter number of bases to try (1 to 8):\n");
  fgets (buf, sizeof (buf), stdin);
  sscanf (buf, "%d", &li);


  mp_init (&p);
  mp_init (&q);

  t1 = clock ();
  pprime (k, li, &p, &q);
  t1 = clock () - t1;

  printf ("\n\nTook %ld ticks, %d bits\n", t1, mp_count_bits (&p));

  mp_toradix (&p, buf, 10);
  printf ("P == %s\n", buf);
  mp_toradix (&q, buf, 10);
  printf ("Q == %s\n", buf);

  return 0;
}

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/pprime.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/etc/timer.asm.











































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
; x86 timer in NASM
;
; Tom St Denis, [email protected]
[bits 32]
[section .data]
time dd 0, 0

[section .text]

%ifdef USE_ELF
[global t_start]
t_start:
%else
[global _t_start]
_t_start:
%endif
   push edx
   push eax
   rdtsc
   mov [time+0],edx
   mov [time+4],eax
   pop eax
   pop edx
   ret
   
%ifdef USE_ELF
[global t_read]
t_read:
%else
[global _t_read]
_t_read:
%endif
   rdtsc
   sub eax,[time+4]
   sbb edx,[time+0]
   ret
   

Added libtommath/etc/tune.c.





























































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
/* Tune the Karatsuba parameters
 *
 * Tom St Denis, [email protected]
 */
#include <tommath.h>
#include <time.h>

/* how many times todo each size mult.  Depends on your computer.  For slow computers
 * this can be low like 5 or 10.  For fast [re: Athlon] should be 25 - 50 or so 
 */
#define TIMES (1UL<<14UL)

/* RDTSC from Scott Duplichan */
static ulong64 TIMFUNC (void)
   {
   #if defined __GNUC__
      #if defined(__i386__) || defined(__x86_64__)
         unsigned long long a;
         __asm__ __volatile__ ("rdtsc\nmovl %%eax,%0\nmovl %%edx,4+%0\n"::"m"(a):"%eax","%edx");
         return a;
      #else /* gcc-IA64 version */
         unsigned long result;
         __asm__ __volatile__("mov %0=ar.itc" : "=r"(result) :: "memory");
         while (__builtin_expect ((int) result == -1, 0))
         __asm__ __volatile__("mov %0=ar.itc" : "=r"(result) :: "memory");
         return result;
      #endif

   // Microsoft and Intel Windows compilers
   #elif defined _M_IX86
     __asm rdtsc
   #elif defined _M_AMD64
     return __rdtsc ();
   #elif defined _M_IA64
     #if defined __INTEL_COMPILER
       #include <ia64intrin.h>
     #endif
      return __getReg (3116);
   #else
     #error need rdtsc function for this build
   #endif
   }


#ifndef X86_TIMER

/* generic ISO C timer */
ulong64 LBL_T;
void t_start(void) { LBL_T = TIMFUNC(); }
ulong64 t_read(void) { return TIMFUNC() - LBL_T; }

#else
extern void t_start(void);
extern ulong64 t_read(void);
#endif

ulong64 time_mult(int size, int s)
{
  unsigned long     x;
  mp_int  a, b, c;
  ulong64 t1;

  mp_init (&a);
  mp_init (&b);
  mp_init (&c);

  mp_rand (&a, size);
  mp_rand (&b, size);

  if (s == 1) { 
      KARATSUBA_MUL_CUTOFF = size;
  } else {
      KARATSUBA_MUL_CUTOFF = 100000;
  }

  t_start();
  for (x = 0; x < TIMES; x++) {
      mp_mul(&a,&b,&c);
  }
  t1 = t_read();
  mp_clear (&a);
  mp_clear (&b);
  mp_clear (&c);
  return t1;
}

ulong64 time_sqr(int size, int s)
{
  unsigned long     x;
  mp_int  a, b;
  ulong64 t1;

  mp_init (&a);
  mp_init (&b);

  mp_rand (&a, size);

  if (s == 1) { 
      KARATSUBA_SQR_CUTOFF = size;
  } else {
      KARATSUBA_SQR_CUTOFF = 100000;
  }

  t_start();
  for (x = 0; x < TIMES; x++) {
      mp_sqr(&a,&b);
  }
  t1 = t_read();
  mp_clear (&a);
  mp_clear (&b);
  return t1;
}

int
main (void)
{
  ulong64 t1, t2;
  int x, y;

  for (x = 8; ; x += 2) { 
     t1 = time_mult(x, 0);
     t2 = time_mult(x, 1);
     printf("%d: %9llu %9llu, %9llu\n", x, t1, t2, t2 - t1);
     if (t2 < t1) break;
  }
  y = x;

  for (x = 8; ; x += 2) { 
     t1 = time_sqr(x, 0);
     t2 = time_sqr(x, 1);
     printf("%d: %9llu %9llu, %9llu\n", x, t1, t2, t2 - t1);
     if (t2 < t1) break;
  }
  printf("KARATSUBA_MUL_CUTOFF = %d\n", y);
  printf("KARATSUBA_SQR_CUTOFF = %d\n", x);

  return 0;
}

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/tune.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/logs/README.



























>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
To use the pretty graphs you have to first build/run the ltmtest from the root directory of the package.  
Todo this type 

make timing ; ltmtest

in the root.  It will run for a while [about ten minutes on most PCs] and produce a series of .log files in logs/.

After doing that run "gnuplot graphs.dem" to make the PNGs.  If you managed todo that all so far just open index.html to view
them all :-)

Have fun

Tom

Added libtommath/logs/add.log.

































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
480        87
960       111
1440       135
1920       159
2400       200
2880       224
3360       248
3840       272
4320       296
4800       320
5280       344
5760       368
6240       392
6720       416
7200       440
7680       464

Added libtommath/logs/addsub.png.

cannot compute difference between binary files

Added libtommath/logs/expt.log.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
513   1435869
769   3544970
1025   7791638
2049  46902238
2561  85334899
3073 141451412
4097 308770310

Added libtommath/logs/expt.png.

cannot compute difference between binary files

Added libtommath/logs/expt_2k.log.











>
>
>
>
>
1
2
3
4
5
607   2109225
1279  10148314
2203  34126877
3217  82716424
4253 161569606

Added libtommath/logs/expt_2kl.log.









>
>
>
>
1
2
3
4
1024   7705271
2048  34286851
4096 165207491
521   1618631

Added libtommath/logs/expt_dr.log.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
532   1928550
784   3763908
1036   7564221
1540  16566059
2072  32283784
3080  79851565
4116 157843530

Added libtommath/logs/index.html.























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
<html>
<head>
<title>LibTomMath Log Plots</title>
</head>
<body>

<h1>Addition and Subtraction</h1>
<center><img src=addsub.png></center>
<hr>

<h1>Multipliers</h1>
<center><img src=mult.png></center>
<hr>

<h1>Exptmod</h1>
<center><img src=expt.png></center>
<hr>

<h1>Modular Inverse</h1>
<center><img src=invmod.png></center>
<hr>

</body>
</html>
/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/logs/index.html,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/logs/invmod.png.

cannot compute difference between binary files

Added libtommath/logs/mult.log.









































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
271       555
390       855
508      1161
631      1605
749      2117
871      2687
991      3329
1108      4084
1231      4786
1351      5624
1470      6392
1586      7364
1710      8218
1830      9255
1951     10217
2067     11461
2191     12463
2308     13677
2430     14800
2551     16232
2671     17460
2791     18899
2902     20247
3028     21902
3151     23240
3267     24927
3391     26441
3511     28277
3631     29838
3749     31751
3869     33673
3989     35431
4111     37518
4231     39426
4349     41504
4471     43567
4591     45786
4711     47876
4831     50299
4951     52427
5071     54785
5189     57241
5307     59730
5431     62194
5551     64761
5670     67322
5789     70073
5907     72663
6030     75437
6151     78242
6268     81202
6389     83948
6509     86985
6631     89903
6747     93184
6869     96044
6991     99286
7109    102395
7229    105917
7351    108940
7470    112490
7589    115702
7711    119508
7831    122632
7951    126410
8071    129808
8190    133895
8311    137146
8431    141218
8549    144732
8667    149131
8790    152462
8911    156754
9030    160479
9149    165138
9271    168601
9391    173185
9511    176988
9627    181976
9751    185539
9870    190388
9991    194335
10110    199605
10228    203298

Added libtommath/logs/mult.png.

cannot compute difference between binary files

Added libtommath/logs/mult_kara.log.









































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
271       560
391       870
511      1159
631      1605
750      2111
871      2737
991      3361
1111      4054
1231      4778
1351      5600
1471      6404
1591      7323
1710      8255
1831      9239
1948     10257
2070     11397
2190     12531
2308     13665
2429     14870
2550     16175
2671     17539
2787     18879
2911     20350
3031     21807
3150     23415
3270     24897
3388     26567
3511     28205
3627     30076
3751     31744
3869     33657
3991     35425
4111     37522
4229     39363
4351     41503
4470     43491
4590     45827
4711     47795
4828     50166
4951     52318
5070     54911
5191     57036
5308     58237
5431     60248
5551     62678
5671     64786
5791     67294
5908     69343
6031     71607
6151     74166
6271     76590
6391     78734
6511     81175
6631     83742
6750     86403
6868     88873
6990     91150
7110     94211
7228     96922
7351     99445
7469    102216
7589    104968
7711    108113
7827    110758
7950    113714
8071    116511
8186    119643
8310    122679
8425    125581
8551    128715
8669    131778
8788    135116
8910    138138
9031    141628
9148    144754
9268    148367
9391    151551
9511    155033
9631    158652
9751    162125
9871    165248
9988    168627
10111    172427
10231    176412

Added libtommath/logs/sqr.log.









































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
265       562
389       882
509      1207
631      1572
750      1990
859      2433
991      2894
1109      3555
1230      4228
1350      5018
1471      5805
1591      6579
1709      7415
1829      8329
1949      9225
2071     10139
2188     11239
2309     12178
2431     13212
2551     14294
2671     15551
2791     16512
2911     17718
3030     18876
3150     20259
3270     21374
3391     22650
3511     23948
3631     25493
3750     26756
3870     28225
3989     29705
4110     31409
4230     32834
4351     34327
4471     35818
4591     37636
4711     39228
4830     40868
4949     42393
5070     44541
5191     46269
5310     48162
5429     49728
5548     51985
5671     53948
5791     55885
5910     57584
6031     60082
6150     62239
6270     64309
6390     66014
6511     68766
6631     71012
6750     73172
6871     74952
6991     77909
7111     80371
7231     82666
7351     84531
7469     87698
7589     90318
7711    225384
7830    232428
7950    240009
8070    246522
8190    253662
8310    260961
8431    269253
8549    275743
8671    283769
8789    290811
8911    300034
9030    306873
9149    315085
9270    323944
9390    332390
9508    337519
9631    348986
9749    356904
9871    367013
9989    373831
10108    381033
10230    393475

Added libtommath/logs/sqr_kara.log.









































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
271       560
388       878
511      1179
629      1625
751      1988
871      2423
989      2896
1111      3561
1231      4209
1350      5015
1470      5804
1591      6556
1709      7420
1831      8263
1951      9173
2070     10153
2191     11229
2310     12167
2431     13211
2550     14309
2671     15524
2788     16525
2910     17712
3028     18822
3148     20220
3271     21343
3391     22652
3511     23944
3630     25485
3750     26778
3868     28201
3990     29653
4111     31393
4225     32841
4350     34328
4471     35786
4590     37652
4711     39245
4830     40876
4951     42433
5068     44547
5191     46321
5311     48140
5430     49727
5550     52034
5671     53954
5791     55921
5908     57597
6031     60084
6148     62226
6270     64295
6390     66045
6511     68779
6629     71003
6751     73169
6871     74992
6991     77895
7110     80376
7231     82628
7351     84468
7470     87664
7591     90284
7711     91352
7828     93995
7950     96276
8071     98691
8190    101256
8308    103631
8431    105222
8550    108343
8671    110281
8787    112764
8911    115397
9031    117690
9151    120266
9271    122715
9391    124624
9510    127937
9630    130313
9750    132914
9871    136129
9991    138517
10108    141525
10231    144225

Added libtommath/logs/sub.log.

































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
480        94
960       116
1440       140
1920       164
2400       205
2880       229
3360       253
3840       277
4320       299
4800       321
5280       345
5760       371
6240       395
6720       419
7200       441
7680       465

Added libtommath/makefile.









































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
#Makefile for GCC
#
#Tom St Denis

#version of library 
VERSION=0.36

CFLAGS  +=  -I./ -Wall -W -Wshadow -Wsign-compare

ifndef IGNORE_SPEED

#for speed 
CFLAGS += -O3 -funroll-loops

#for size 
#CFLAGS += -Os

#x86 optimizations [should be valid for any GCC install though]
CFLAGS  += -fomit-frame-pointer

#debug
#CFLAGS += -g3

endif

#install as this user
ifndef INSTALL_GROUP
   GROUP=wheel
else
   GROUP=$(INSTALL_GROUP)
endif

ifndef INSTALL_USER
   USER=root
else
   USER=$(INSTALL_USER)
endif

default: libtommath.a

#default files to install
ifndef LIBNAME
   LIBNAME=libtommath.a
endif
HEADERS=tommath.h tommath_class.h tommath_superclass.h

#LIBPATH-The directory for libtommath to be installed to.
#INCPATH-The directory to install the header files for libtommath.
#DATAPATH-The directory to install the pdf docs.
DESTDIR=
LIBPATH=/usr/lib
INCPATH=/usr/include
DATAPATH=/usr/share/doc/libtommath/pdf

OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \
bn_mp_clamp.o bn_mp_zero.o  bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \
bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \
bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \
bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \
bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \
bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \
bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \
bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \
bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \
bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \
bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \
bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \
bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o  \
bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \
bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \
bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \
bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \
bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \
bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \
bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \
bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \
bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \
bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \
bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \
bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o

$(LIBNAME):  $(OBJECTS)
	$(AR) $(ARFLAGS) $@ $(OBJECTS)
	ranlib $@

#make a profiled library (takes a while!!!)
#
# This will build the library with profile generation
# then run the test demo and rebuild the library.
# 
# So far I've seen improvements in the MP math
profiled:
	make CFLAGS="$(CFLAGS) -fprofile-arcs -DTESTING" timing
	./ltmtest
	rm -f *.a *.o ltmtest
	make CFLAGS="$(CFLAGS) -fbranch-probabilities"

#make a single object profiled library 
profiled_single:
	perl gen.pl
	$(CC) $(CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o
	$(CC) $(CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -o ltmtest
	./ltmtest
	rm -f *.o ltmtest
	$(CC) $(CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o
	$(AR) $(ARFLAGS) $(LIBNAME) mpi.o
	ranlib $(LIBNAME)	

install: $(LIBNAME)
	install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(LIBPATH)
	install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH)
	install -g $(GROUP) -o $(USER) $(LIBNAME) $(DESTDIR)$(LIBPATH)
	install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH)

test: $(LIBNAME) demo/demo.o
	$(CC) $(CFLAGS) demo/demo.o $(LIBNAME) -o test
	
mtest: test	
	cd mtest ; $(CC) $(CFLAGS) mtest.c -o mtest
        
timing: $(LIBNAME)
	$(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o ltmtest

# makes the LTM book DVI file, requires tetex, perl and makeindex [part of tetex I think]
docdvi: tommath.src
	cd pics ; make 
	echo "hello" > tommath.ind
	perl booker.pl
	latex tommath > /dev/null
	latex tommath > /dev/null
	makeindex tommath
	latex tommath > /dev/null

# poster, makes the single page PDF poster
poster: poster.tex
	pdflatex poster
	rm -f poster.aux poster.log 

# makes the LTM book PDF file, requires tetex, cleans up the LaTeX temp files
docs:   docdvi
	dvipdf tommath
	rm -f tommath.log tommath.aux tommath.dvi tommath.idx tommath.toc tommath.lof tommath.ind tommath.ilg
	cd pics ; make clean
	
#LTM user manual
mandvi: bn.tex
	echo "hello" > bn.ind
	latex bn > /dev/null
	latex bn > /dev/null
	makeindex bn
	latex bn > /dev/null

#LTM user manual [pdf]
manual:	mandvi
	pdflatex bn >/dev/null
	rm -f bn.aux bn.dvi bn.log bn.idx bn.lof bn.out bn.toc

pretty: 
	perl pretty.build

clean:
	rm -f *.bat *.pdf *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test ltmtest mpitest mtest/mtest mtest/mtest.exe \
        *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.da *.dyn *.dpi tommath.tex `find -type f | grep [~] | xargs` *.lo *.la
	rm -rf .libs
	cd etc ; make clean
	cd pics ; make clean

#zipup the project (take that!)
no_oops: clean
	cd .. ; cvs commit 
	echo Scanning for scratch/dirty files
	find . -type f | grep -v CVS | xargs -n 1 bash mess.sh

zipup: clean manual poster docs
	perl gen.pl ; mv mpi.c pre_gen/ ; \
	cd .. ; rm -rf ltm* libtommath-$(VERSION) ; mkdir libtommath-$(VERSION) ; \
	cp -R ./libtommath/* ./libtommath-$(VERSION)/ ; \
	tar -c libtommath-$(VERSION)/* | bzip2 -9vvc > ltm-$(VERSION).tar.bz2 ; \
	zip -9 -r ltm-$(VERSION).zip libtommath-$(VERSION)/*

Added libtommath/makefile.bcc.

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#
# Borland C++Builder Makefile (makefile.bcc)
#


LIB = tlib
CC = bcc32
CFLAGS = -c -O2 -I.

OBJECTS=bncore.obj bn_mp_init.obj bn_mp_clear.obj bn_mp_exch.obj bn_mp_grow.obj bn_mp_shrink.obj \
bn_mp_clamp.obj bn_mp_zero.obj  bn_mp_set.obj bn_mp_set_int.obj bn_mp_init_size.obj bn_mp_copy.obj \
bn_mp_init_copy.obj bn_mp_abs.obj bn_mp_neg.obj bn_mp_cmp_mag.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \
bn_mp_rshd.obj bn_mp_lshd.obj bn_mp_mod_2d.obj bn_mp_div_2d.obj bn_mp_mul_2d.obj bn_mp_div_2.obj \
bn_mp_mul_2.obj bn_s_mp_add.obj bn_s_mp_sub.obj bn_fast_s_mp_mul_digs.obj bn_s_mp_mul_digs.obj \
bn_fast_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_s_mp_sqr.obj \
bn_mp_add.obj bn_mp_sub.obj bn_mp_karatsuba_mul.obj bn_mp_mul.obj bn_mp_karatsuba_sqr.obj \
bn_mp_sqr.obj bn_mp_div.obj bn_mp_mod.obj bn_mp_add_d.obj bn_mp_sub_d.obj bn_mp_mul_d.obj \
bn_mp_div_d.obj bn_mp_mod_d.obj bn_mp_expt_d.obj bn_mp_addmod.obj bn_mp_submod.obj \
bn_mp_mulmod.obj bn_mp_sqrmod.obj bn_mp_gcd.obj bn_mp_lcm.obj bn_fast_mp_invmod.obj bn_mp_invmod.obj \
bn_mp_reduce.obj bn_mp_montgomery_setup.obj bn_fast_mp_montgomery_reduce.obj bn_mp_montgomery_reduce.obj \
bn_mp_exptmod_fast.obj bn_mp_exptmod.obj bn_mp_2expt.obj bn_mp_n_root.obj bn_mp_jacobi.obj bn_reverse.obj \
bn_mp_count_bits.obj bn_mp_read_unsigned_bin.obj bn_mp_read_signed_bin.obj bn_mp_to_unsigned_bin.obj \
bn_mp_to_signed_bin.obj bn_mp_unsigned_bin_size.obj bn_mp_signed_bin_size.obj  \
bn_mp_xor.obj bn_mp_and.obj bn_mp_or.obj bn_mp_rand.obj bn_mp_montgomery_calc_normalization.obj \
bn_mp_prime_is_divisible.obj bn_prime_tab.obj bn_mp_prime_fermat.obj bn_mp_prime_miller_rabin.obj \
bn_mp_prime_is_prime.obj bn_mp_prime_next_prime.obj bn_mp_dr_reduce.obj \
bn_mp_dr_is_modulus.obj bn_mp_dr_setup.obj bn_mp_reduce_setup.obj \
bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_div_3.obj bn_s_mp_exptmod.obj \
bn_mp_reduce_2k.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_2k_setup.obj \
bn_mp_reduce_2k_l.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_2k_setup_l.obj \
bn_mp_radix_smap.obj bn_mp_read_radix.obj bn_mp_toradix.obj bn_mp_radix_size.obj \
bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_cnt_lsb.obj bn_error.obj \
bn_mp_init_multi.obj bn_mp_clear_multi.obj bn_mp_exteuclid.obj bn_mp_toradix_n.obj \
bn_mp_prime_random_ex.obj bn_mp_get_int.obj bn_mp_sqrt.obj bn_mp_is_square.obj \
bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_invmod_slow.obj bn_mp_prime_rabin_miller_trials.obj \
bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin_n.obj

TARGET = libtommath.lib

$(TARGET): $(OBJECTS)

.c.objbjbjbj:
	$(CC) $(CFLAGS) $<
	$(LIB) $(TARGET) -+$@

Added libtommath/makefile.cygwin_dll.















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
#Makefile for Cygwin-GCC
#
#This makefile will build a Windows DLL [doesn't require cygwin to run] in the file
#libtommath.dll.  The import library is in libtommath.dll.a.  Remember to add
#"-Wl,--enable-auto-import" to your client build to avoid the auto-import warnings
#
#Tom St Denis
CFLAGS  +=  -I./ -Wall -W -Wshadow -O3 -funroll-loops -mno-cygwin

#x86 optimizations [should be valid for any GCC install though]
CFLAGS  += -fomit-frame-pointer 

default: windll

OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \
bn_mp_clamp.o bn_mp_zero.o  bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \
bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \
bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \
bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \
bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \
bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \
bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \
bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \
bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \
bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \
bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \
bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \
bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o  \
bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \
bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \
bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \
bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \
bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \
bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \
bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \
bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \
bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \
bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \
bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \
bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o

# make a Windows DLL via Cygwin
windll:  $(OBJECTS)
	gcc -mno-cygwin -mdll -o libtommath.dll -Wl,--out-implib=libtommath.dll.a -Wl,--export-all-symbols *.o
	ranlib libtommath.dll.a

# build the test program using the windows DLL
test: $(OBJECTS) windll
	gcc $(CFLAGS) demo/demo.c libtommath.dll.a -Wl,--enable-auto-import -o test -s
	cd mtest ; $(CC) -O3 -fomit-frame-pointer -funroll-loops mtest.c -o mtest -s

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/makefile.cygwin_dll,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/makefile.icc.









































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
#Makefile for ICC
#
#Tom St Denis
CC=icc

CFLAGS  +=  -I./

# optimize for SPEED
#
# -mcpu= can be pentium, pentiumpro (covers PII through PIII) or pentium4
# -ax?   specifies make code specifically for ? but compatible with IA-32
# -x?    specifies compile solely for ? [not specifically IA-32 compatible]
#
# where ? is 
#   K - PIII
#   W - first P4 [Williamette]
#   N - P4 Northwood
#   P - P4 Prescott
#   B - Blend of P4 and PM [mobile]
#
# Default to just generic max opts
CFLAGS += -O3 -xP -ip

#install as this user
USER=root
GROUP=root

default: libtommath.a

#default files to install
LIBNAME=libtommath.a
HEADERS=tommath.h

#LIBPATH-The directory for libtomcrypt to be installed to.
#INCPATH-The directory to install the header files for libtommath.
#DATAPATH-The directory to install the pdf docs.
DESTDIR=
LIBPATH=/usr/lib
INCPATH=/usr/include
DATAPATH=/usr/share/doc/libtommath/pdf

OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \
bn_mp_clamp.o bn_mp_zero.o  bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \
bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \
bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \
bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \
bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \
bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \
bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \
bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \
bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \
bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \
bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \
bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \
bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o  \
bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \
bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \
bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \
bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \
bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \
bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \
bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \
bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \
bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \
bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \
bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \
bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o

libtommath.a:  $(OBJECTS)
	$(AR) $(ARFLAGS) libtommath.a $(OBJECTS)
	ranlib libtommath.a

#make a profiled library (takes a while!!!)
#
# This will build the library with profile generation
# then run the test demo and rebuild the library.
# 
# So far I've seen improvements in the MP math
profiled:
	make -f makefile.icc CFLAGS="$(CFLAGS) -prof_gen -DTESTING" timing
	./ltmtest
	rm -f *.a *.o ltmtest
	make -f makefile.icc CFLAGS="$(CFLAGS) -prof_use"

#make a single object profiled library 
profiled_single:
	perl gen.pl
	$(CC) $(CFLAGS) -prof_gen -DTESTING -c mpi.c -o mpi.o
	$(CC) $(CFLAGS) -DTESTING -DTIMER demo/demo.c mpi.o -o ltmtest
	./ltmtest
	rm -f *.o ltmtest
	$(CC) $(CFLAGS) -prof_use -ip -DTESTING -c mpi.c -o mpi.o
	$(AR) $(ARFLAGS) libtommath.a mpi.o
	ranlib libtommath.a	

install: libtommath.a
	install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(LIBPATH)
	install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH)
	install -g $(GROUP) -o $(USER) $(LIBNAME) $(DESTDIR)$(LIBPATH)
	install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH)

test: libtommath.a demo/demo.o
	$(CC) demo/demo.o libtommath.a -o test
	
mtest: test	
	cd mtest ; $(CC) $(CFLAGS) mtest.c -o mtest
        
timing: libtommath.a
	$(CC) $(CFLAGS) -DTIMER demo/timing.c libtommath.a -o ltmtest

clean:
	rm -f *.bat *.pdf *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test ltmtest mpitest mtest/mtest mtest/mtest.exe \
        *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.il etc/*.il *.dyn
	cd etc ; make clean
	cd pics ; make clean

Added libtommath/makefile.msvc.

















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#MSVC Makefile
#
#Tom St Denis

CFLAGS = /I. /Ox /DWIN32 /W3 /Fo$@

default: library

OBJECTS=bncore.obj bn_mp_init.obj bn_mp_clear.obj bn_mp_exch.obj bn_mp_grow.obj bn_mp_shrink.obj \
bn_mp_clamp.obj bn_mp_zero.obj  bn_mp_set.obj bn_mp_set_int.obj bn_mp_init_size.obj bn_mp_copy.obj \
bn_mp_init_copy.obj bn_mp_abs.obj bn_mp_neg.obj bn_mp_cmp_mag.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \
bn_mp_rshd.obj bn_mp_lshd.obj bn_mp_mod_2d.obj bn_mp_div_2d.obj bn_mp_mul_2d.obj bn_mp_div_2.obj \
bn_mp_mul_2.obj bn_s_mp_add.obj bn_s_mp_sub.obj bn_fast_s_mp_mul_digs.obj bn_s_mp_mul_digs.obj \
bn_fast_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_s_mp_sqr.obj \
bn_mp_add.obj bn_mp_sub.obj bn_mp_karatsuba_mul.obj bn_mp_mul.obj bn_mp_karatsuba_sqr.obj \
bn_mp_sqr.obj bn_mp_div.obj bn_mp_mod.obj bn_mp_add_d.obj bn_mp_sub_d.obj bn_mp_mul_d.obj \
bn_mp_div_d.obj bn_mp_mod_d.obj bn_mp_expt_d.obj bn_mp_addmod.obj bn_mp_submod.obj \
bn_mp_mulmod.obj bn_mp_sqrmod.obj bn_mp_gcd.obj bn_mp_lcm.obj bn_fast_mp_invmod.obj bn_mp_invmod.obj \
bn_mp_reduce.obj bn_mp_montgomery_setup.obj bn_fast_mp_montgomery_reduce.obj bn_mp_montgomery_reduce.obj \
bn_mp_exptmod_fast.obj bn_mp_exptmod.obj bn_mp_2expt.obj bn_mp_n_root.obj bn_mp_jacobi.obj bn_reverse.obj \
bn_mp_count_bits.obj bn_mp_read_unsigned_bin.obj bn_mp_read_signed_bin.obj bn_mp_to_unsigned_bin.obj \
bn_mp_to_signed_bin.obj bn_mp_unsigned_bin_size.obj bn_mp_signed_bin_size.obj  \
bn_mp_xor.obj bn_mp_and.obj bn_mp_or.obj bn_mp_rand.obj bn_mp_montgomery_calc_normalization.obj \
bn_mp_prime_is_divisible.obj bn_prime_tab.obj bn_mp_prime_fermat.obj bn_mp_prime_miller_rabin.obj \
bn_mp_prime_is_prime.obj bn_mp_prime_next_prime.obj bn_mp_dr_reduce.obj \
bn_mp_dr_is_modulus.obj bn_mp_dr_setup.obj bn_mp_reduce_setup.obj \
bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_div_3.obj bn_s_mp_exptmod.obj \
bn_mp_reduce_2k.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_2k_setup.obj \
bn_mp_reduce_2k_l.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_2k_setup_l.obj \
bn_mp_radix_smap.obj bn_mp_read_radix.obj bn_mp_toradix.obj bn_mp_radix_size.obj \
bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_cnt_lsb.obj bn_error.obj \
bn_mp_init_multi.obj bn_mp_clear_multi.obj bn_mp_exteuclid.obj bn_mp_toradix_n.obj \
bn_mp_prime_random_ex.obj bn_mp_get_int.obj bn_mp_sqrt.obj bn_mp_is_square.obj \
bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_invmod_slow.obj bn_mp_prime_rabin_miller_trials.obj \
bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin_n.obj

HEADERS=tommath.h tommath_class.h tommath_superclass.h

library: $(OBJECTS)
	lib /out:tommath.lib $(OBJECTS)

Added libtommath/makefile.shared.







































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
#Makefile for GCC
#
#Tom St Denis
VERSION=0:36

CC = libtool --mode=compile gcc

CFLAGS  +=  -I./ -Wall -W -Wshadow -Wsign-compare

ifndef IGNORE_SPEED

#for speed 
CFLAGS += -O3 -funroll-loops

#for size 
#CFLAGS += -Os

#x86 optimizations [should be valid for any GCC install though]
CFLAGS  += -fomit-frame-pointer

endif

#install as this user
ifndef INSTALL_GROUP
   GROUP=wheel
else
   GROUP=$(INSTALL_GROUP)
endif

ifndef INSTALL_USER
   USER=root
else
   USER=$(INSTALL_USER)
endif

default: libtommath.la

#default files to install
ifndef LIBNAME
   LIBNAME=libtommath.la
endif
ifndef LIBNAME_S
   LIBNAME_S=libtommath.a
endif
HEADERS=tommath.h tommath_class.h tommath_superclass.h

#LIBPATH-The directory for libtommath to be installed to.
#INCPATH-The directory to install the header files for libtommath.
#DATAPATH-The directory to install the pdf docs.
DESTDIR=
LIBPATH=/usr/lib
INCPATH=/usr/include
DATAPATH=/usr/share/doc/libtommath/pdf

OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \
bn_mp_clamp.o bn_mp_zero.o  bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \
bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \
bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \
bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \
bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \
bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \
bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \
bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \
bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \
bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \
bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \
bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \
bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o  \
bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \
bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \
bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \
bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \
bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \
bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \
bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \
bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \
bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \
bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \
bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \
bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \
bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o

$(LIBNAME):  $(OBJECTS)
	libtool --mode=link gcc *.lo -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION)
	libtool --mode=link gcc *.o -o $(LIBNAME_S)
	ranlib $(LIBNAME_S)
	libtool --mode=install install -c $(LIBNAME) $(LIBPATH)/$@
	install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH)
	install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH)

test: $(LIBNAME) demo/demo.o
	gcc $(CFLAGS) -c demo/demo.c -o demo/demo.o
	libtool --mode=link gcc -o test demo/demo.o $(LIBNAME_S)
	
mtest: test	
	cd mtest ; gcc $(CFLAGS) mtest.c -o mtest
        
timing: $(LIBNAME)
	gcc $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME_S) -o ltmtest

Added libtommath/mess.sh.









>
>
>
>
1
2
3
4
#!/bin/bash
if cvs log $1 >/dev/null 2>/dev/null; then exit 0; else echo "$1 shouldn't be here" ; exit 1; fi


Added libtommath/mtest/logtab.h.

















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
const float s_logv_2[] = {
   0.000000000, 0.000000000, 1.000000000, 0.630929754, 	/*  0  1  2  3 */
   0.500000000, 0.430676558, 0.386852807, 0.356207187, 	/*  4  5  6  7 */
   0.333333333, 0.315464877, 0.301029996, 0.289064826, 	/*  8  9 10 11 */
   0.278942946, 0.270238154, 0.262649535, 0.255958025, 	/* 12 13 14 15 */
   0.250000000, 0.244650542, 0.239812467, 0.235408913, 	/* 16 17 18 19 */
   0.231378213, 0.227670249, 0.224243824, 0.221064729, 	/* 20 21 22 23 */
   0.218104292, 0.215338279, 0.212746054, 0.210309918, 	/* 24 25 26 27 */
   0.208014598, 0.205846832, 0.203795047, 0.201849087, 	/* 28 29 30 31 */
   0.200000000, 0.198239863, 0.196561632, 0.194959022, 	/* 32 33 34 35 */
   0.193426404, 0.191958720, 0.190551412, 0.189200360, 	/* 36 37 38 39 */
   0.187901825, 0.186652411, 0.185449023, 0.184288833, 	/* 40 41 42 43 */
   0.183169251, 0.182087900, 0.181042597, 0.180031327, 	/* 44 45 46 47 */
   0.179052232, 0.178103594, 0.177183820, 0.176291434, 	/* 48 49 50 51 */
   0.175425064, 0.174583430, 0.173765343, 0.172969690, 	/* 52 53 54 55 */
   0.172195434, 0.171441601, 0.170707280, 0.169991616, 	/* 56 57 58 59 */
   0.169293808, 0.168613099, 0.167948779, 0.167300179, 	/* 60 61 62 63 */
   0.166666667
};


/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/logtab.h,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/mtest/mpi-config.h.





















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
/* Default configuration for MPI library */
/* $Id: mpi-config.h,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ */

#ifndef MPI_CONFIG_H_
#define MPI_CONFIG_H_

/*
  For boolean options, 
  0 = no
  1 = yes

  Other options are documented individually.

 */

#ifndef MP_IOFUNC
#define MP_IOFUNC     0  /* include mp_print() ?                */
#endif

#ifndef MP_MODARITH
#define MP_MODARITH   1  /* include modular arithmetic ?        */
#endif

#ifndef MP_NUMTH
#define MP_NUMTH      1  /* include number theoretic functions? */
#endif

#ifndef MP_LOGTAB
#define MP_LOGTAB     1  /* use table of logs instead of log()? */
#endif

#ifndef MP_MEMSET
#define MP_MEMSET     1  /* use memset() to zero buffers?       */
#endif

#ifndef MP_MEMCPY
#define MP_MEMCPY     1  /* use memcpy() to copy buffers?       */
#endif

#ifndef MP_CRYPTO
#define MP_CRYPTO     1  /* erase memory on free?               */
#endif

#ifndef MP_ARGCHK
/*
  0 = no parameter checks
  1 = runtime checks, continue execution and return an error to caller
  2 = assertions; dump core on parameter errors
 */
#define MP_ARGCHK     2  /* how to check input arguments        */
#endif

#ifndef MP_DEBUG
#define MP_DEBUG      0  /* print diagnostic output?            */
#endif

#ifndef MP_DEFPREC
#define MP_DEFPREC    64 /* default precision, in digits        */
#endif

#ifndef MP_MACRO
#define MP_MACRO      1  /* use macros for frequent calls?      */
#endif

#ifndef MP_SQUARE
#define MP_SQUARE     1  /* use separate squaring code?         */
#endif

#ifndef MP_PTAB_SIZE
/*
  When building mpprime.c, we build in a table of small prime
  values to use for primality testing.  The more you include,
  the more space they take up.  See primes.c for the possible
  values (currently 16, 32, 64, 128, 256, and 6542)
 */
#define MP_PTAB_SIZE  128  /* how many built-in primes?         */
#endif

#ifndef MP_COMPAT_MACROS
#define MP_COMPAT_MACROS 1   /* define compatibility macros?    */
#endif

#endif /* ifndef MPI_CONFIG_H_ */


/* crc==3287762869, version==2, Sat Feb 02 06:43:53 2002 */

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-config.h,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/mtest/mpi-types.h.









































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* Type definitions generated by 'types.pl' */
typedef char               mp_sign;
typedef unsigned short     mp_digit;  /* 2 byte type */
typedef unsigned int       mp_word;   /* 4 byte type */
typedef unsigned int       mp_size;
typedef int                mp_err;

#define MP_DIGIT_BIT       (CHAR_BIT*sizeof(mp_digit))
#define MP_DIGIT_MAX       USHRT_MAX
#define MP_WORD_BIT        (CHAR_BIT*sizeof(mp_word))
#define MP_WORD_MAX        UINT_MAX

#define MP_DIGIT_SIZE      2
#define DIGIT_FMT          "%04X"
#define RADIX              (MP_DIGIT_MAX+1)


/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-types.h,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/mtest/mpi.c.



































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
/*
    mpi.c

    by Michael J. Fromberger <[email protected]>
    Copyright (C) 1998 Michael J. Fromberger, All Rights Reserved

    Arbitrary precision integer arithmetic library

    $Id: mpi.c,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $
 */

#include "mpi.h"
#include <stdlib.h>
#include <string.h>
#include <ctype.h>

#if MP_DEBUG
#include <stdio.h>

#define DIAG(T,V) {fprintf(stderr,T);mp_print(V,stderr);fputc('\n',stderr);}
#else
#define DIAG(T,V)
#endif

/* 
   If MP_LOGTAB is not defined, use the math library to compute the
   logarithms on the fly.  Otherwise, use the static table below.
   Pick which works best for your system.
 */
#if MP_LOGTAB

/* {{{ s_logv_2[] - log table for 2 in various bases */

/*
  A table of the logs of 2 for various bases (the 0 and 1 entries of
  this table are meaningless and should not be referenced).  

  This table is used to compute output lengths for the mp_toradix()
  function.  Since a number n in radix r takes up about log_r(n)
  digits, we estimate the output size by taking the least integer
  greater than log_r(n), where:

  log_r(n) = log_2(n) * log_r(2)

  This table, therefore, is a table of log_r(2) for 2 <= r <= 36,
  which are the output bases supported.  
 */

#include "logtab.h"

/* }}} */
#define LOG_V_2(R)  s_logv_2[(R)]

#else

#include <math.h>
#define LOG_V_2(R)  (log(2.0)/log(R))

#endif

/* Default precision for newly created mp_int's      */
static unsigned int s_mp_defprec = MP_DEFPREC;

/* {{{ Digit arithmetic macros */

/*
  When adding and multiplying digits, the results can be larger than
  can be contained in an mp_digit.  Thus, an mp_word is used.  These
  macros mask off the upper and lower digits of the mp_word (the
  mp_word may be more than 2 mp_digits wide, but we only concern
  ourselves with the low-order 2 mp_digits)

  If your mp_word DOES have more than 2 mp_digits, you need to
  uncomment the first line, and comment out the second.
 */

/* #define  CARRYOUT(W)  (((W)>>DIGIT_BIT)&MP_DIGIT_MAX) */
#define  CARRYOUT(W)  ((W)>>DIGIT_BIT)
#define  ACCUM(W)     ((W)&MP_DIGIT_MAX)

/* }}} */

/* {{{ Comparison constants */

#define  MP_LT       -1
#define  MP_EQ        0
#define  MP_GT        1

/* }}} */

/* {{{ Constant strings */

/* Constant strings returned by mp_strerror() */
static const char *mp_err_string[] = {
  "unknown result code",     /* say what?            */
  "boolean true",            /* MP_OKAY, MP_YES      */
  "boolean false",           /* MP_NO                */
  "out of memory",           /* MP_MEM               */
  "argument out of range",   /* MP_RANGE             */
  "invalid input parameter", /* MP_BADARG            */
  "result is undefined"      /* MP_UNDEF             */
};

/* Value to digit maps for radix conversion   */

/* s_dmap_1 - standard digits and letters */
static const char *s_dmap_1 = 
  "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";

#if 0
/* s_dmap_2 - base64 ordering for digits  */
static const char *s_dmap_2 =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
#endif

/* }}} */

/* {{{ Static function declarations */

/* 
   If MP_MACRO is false, these will be defined as actual functions;
   otherwise, suitable macro definitions will be used.  This works
   around the fact that ANSI C89 doesn't support an 'inline' keyword
   (although I hear C9x will ... about bloody time).  At present, the
   macro definitions are identical to the function bodies, but they'll
   expand in place, instead of generating a function call.

   I chose these particular functions to be made into macros because
   some profiling showed they are called a lot on a typical workload,
   and yet they are primarily housekeeping.
 */
#if MP_MACRO == 0
 void     s_mp_setz(mp_digit *dp, mp_size count); /* zero digits           */
 void     s_mp_copy(mp_digit *sp, mp_digit *dp, mp_size count); /* copy    */
 void    *s_mp_alloc(size_t nb, size_t ni);       /* general allocator     */
 void     s_mp_free(void *ptr);                   /* general free function */
#else

 /* Even if these are defined as macros, we need to respect the settings
    of the MP_MEMSET and MP_MEMCPY configuration options...
  */
 #if MP_MEMSET == 0
  #define  s_mp_setz(dp, count) \
       {int ix;for(ix=0;ix<(count);ix++)(dp)[ix]=0;}
 #else
  #define  s_mp_setz(dp, count) memset(dp, 0, (count) * sizeof(mp_digit))
 #endif /* MP_MEMSET */

 #if MP_MEMCPY == 0
  #define  s_mp_copy(sp, dp, count) \
       {int ix;for(ix=0;ix<(count);ix++)(dp)[ix]=(sp)[ix];}
 #else
  #define  s_mp_copy(sp, dp, count) memcpy(dp, sp, (count) * sizeof(mp_digit))
 #endif /* MP_MEMCPY */

 #define  s_mp_alloc(nb, ni)  calloc(nb, ni)
 #define  s_mp_free(ptr) {if(ptr) free(ptr);}
#endif /* MP_MACRO */

mp_err   s_mp_grow(mp_int *mp, mp_size min);   /* increase allocated size */
mp_err   s_mp_pad(mp_int *mp, mp_size min);    /* left pad with zeroes    */

void     s_mp_clamp(mp_int *mp);               /* clip leading zeroes     */

void     s_mp_exch(mp_int *a, mp_int *b);      /* swap a and b in place   */

mp_err   s_mp_lshd(mp_int *mp, mp_size p);     /* left-shift by p digits  */
void     s_mp_rshd(mp_int *mp, mp_size p);     /* right-shift by p digits */
void     s_mp_div_2d(mp_int *mp, mp_digit d);  /* divide by 2^d in place  */
void     s_mp_mod_2d(mp_int *mp, mp_digit d);  /* modulo 2^d in place     */
mp_err   s_mp_mul_2d(mp_int *mp, mp_digit d);  /* multiply by 2^d in place*/
void     s_mp_div_2(mp_int *mp);               /* divide by 2 in place    */
mp_err   s_mp_mul_2(mp_int *mp);               /* multiply by 2 in place  */
mp_digit s_mp_norm(mp_int *a, mp_int *b);      /* normalize for division  */
mp_err   s_mp_add_d(mp_int *mp, mp_digit d);   /* unsigned digit addition */
mp_err   s_mp_sub_d(mp_int *mp, mp_digit d);   /* unsigned digit subtract */
mp_err   s_mp_mul_d(mp_int *mp, mp_digit d);   /* unsigned digit multiply */
mp_err   s_mp_div_d(mp_int *mp, mp_digit d, mp_digit *r);
		                               /* unsigned digit divide   */
mp_err   s_mp_reduce(mp_int *x, mp_int *m, mp_int *mu);
                                               /* Barrett reduction       */
mp_err   s_mp_add(mp_int *a, mp_int *b);       /* magnitude addition      */
mp_err   s_mp_sub(mp_int *a, mp_int *b);       /* magnitude subtract      */
mp_err   s_mp_mul(mp_int *a, mp_int *b);       /* magnitude multiply      */
#if 0
void     s_mp_kmul(mp_digit *a, mp_digit *b, mp_digit *out, mp_size len);
                                               /* multiply buffers in place */
#endif
#if MP_SQUARE
mp_err   s_mp_sqr(mp_int *a);                  /* magnitude square        */
#else
#define  s_mp_sqr(a) s_mp_mul(a, a)
#endif
mp_err   s_mp_div(mp_int *a, mp_int *b);       /* magnitude divide        */
mp_err   s_mp_2expt(mp_int *a, mp_digit k);    /* a = 2^k                 */
int      s_mp_cmp(mp_int *a, mp_int *b);       /* magnitude comparison    */
int      s_mp_cmp_d(mp_int *a, mp_digit d);    /* magnitude digit compare */
int      s_mp_ispow2(mp_int *v);               /* is v a power of 2?      */
int      s_mp_ispow2d(mp_digit d);             /* is d a power of 2?      */

int      s_mp_tovalue(char ch, int r);          /* convert ch to value    */
char     s_mp_todigit(int val, int r, int low); /* convert val to digit   */
int      s_mp_outlen(int bits, int r);          /* output length in bytes */

/* }}} */

/* {{{ Default precision manipulation */

unsigned int mp_get_prec(void)
{
  return s_mp_defprec;

} /* end mp_get_prec() */

void         mp_set_prec(unsigned int prec)
{
  if(prec == 0)
    s_mp_defprec = MP_DEFPREC;
  else
    s_mp_defprec = prec;

} /* end mp_set_prec() */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ mp_init(mp) */

/*
  mp_init(mp)

  Initialize a new zero-valued mp_int.  Returns MP_OKAY if successful,
  MP_MEM if memory could not be allocated for the structure.
 */

mp_err mp_init(mp_int *mp)
{
  return mp_init_size(mp, s_mp_defprec);

} /* end mp_init() */

/* }}} */

/* {{{ mp_init_array(mp[], count) */

mp_err mp_init_array(mp_int mp[], int count)
{
  mp_err  res;
  int     pos;

  ARGCHK(mp !=NULL && count > 0, MP_BADARG);

  for(pos = 0; pos < count; ++pos) {
    if((res = mp_init(&mp[pos])) != MP_OKAY)
      goto CLEANUP;
  }

  return MP_OKAY;

 CLEANUP:
  while(--pos >= 0) 
    mp_clear(&mp[pos]);

  return res;

} /* end mp_init_array() */

/* }}} */

/* {{{ mp_init_size(mp, prec) */

/*
  mp_init_size(mp, prec)

  Initialize a new zero-valued mp_int with at least the given
  precision; returns MP_OKAY if successful, or MP_MEM if memory could
  not be allocated for the structure.
 */

mp_err mp_init_size(mp_int *mp, mp_size prec)
{
  ARGCHK(mp != NULL && prec > 0, MP_BADARG);

  if((DIGITS(mp) = s_mp_alloc(prec, sizeof(mp_digit))) == NULL)
    return MP_MEM;

  SIGN(mp) = MP_ZPOS;
  USED(mp) = 1;
  ALLOC(mp) = prec;

  return MP_OKAY;

} /* end mp_init_size() */

/* }}} */

/* {{{ mp_init_copy(mp, from) */

/*
  mp_init_copy(mp, from)

  Initialize mp as an exact copy of from.  Returns MP_OKAY if
  successful, MP_MEM if memory could not be allocated for the new
  structure.
 */

mp_err mp_init_copy(mp_int *mp, mp_int *from)
{
  ARGCHK(mp != NULL && from != NULL, MP_BADARG);

  if(mp == from)
    return MP_OKAY;

  if((DIGITS(mp) = s_mp_alloc(USED(from), sizeof(mp_digit))) == NULL)
    return MP_MEM;

  s_mp_copy(DIGITS(from), DIGITS(mp), USED(from));
  USED(mp) = USED(from);
  ALLOC(mp) = USED(from);
  SIGN(mp) = SIGN(from);

  return MP_OKAY;

} /* end mp_init_copy() */

/* }}} */

/* {{{ mp_copy(from, to) */

/*
  mp_copy(from, to)

  Copies the mp_int 'from' to the mp_int 'to'.  It is presumed that
  'to' has already been initialized (if not, use mp_init_copy()
  instead). If 'from' and 'to' are identical, nothing happens.
 */

mp_err mp_copy(mp_int *from, mp_int *to)
{
  ARGCHK(from != NULL && to != NULL, MP_BADARG);

  if(from == to)
    return MP_OKAY;

  { /* copy */
    mp_digit   *tmp;

    /*
      If the allocated buffer in 'to' already has enough space to hold
      all the used digits of 'from', we'll re-use it to avoid hitting
      the memory allocater more than necessary; otherwise, we'd have
      to grow anyway, so we just allocate a hunk and make the copy as
      usual
     */
    if(ALLOC(to) >= USED(from)) {
      s_mp_setz(DIGITS(to) + USED(from), ALLOC(to) - USED(from));
      s_mp_copy(DIGITS(from), DIGITS(to), USED(from));
      
    } else {
      if((tmp = s_mp_alloc(USED(from), sizeof(mp_digit))) == NULL)
	return MP_MEM;

      s_mp_copy(DIGITS(from), tmp, USED(from));

      if(DIGITS(to) != NULL) {
#if MP_CRYPTO
	s_mp_setz(DIGITS(to), ALLOC(to));
#endif
	s_mp_free(DIGITS(to));
      }

      DIGITS(to) = tmp;
      ALLOC(to) = USED(from);
    }

    /* Copy the precision and sign from the original */
    USED(to) = USED(from);
    SIGN(to) = SIGN(from);
  } /* end copy */

  return MP_OKAY;

} /* end mp_copy() */

/* }}} */

/* {{{ mp_exch(mp1, mp2) */

/*
  mp_exch(mp1, mp2)

  Exchange mp1 and mp2 without allocating any intermediate memory
  (well, unless you count the stack space needed for this call and the
  locals it creates...).  This cannot fail.
 */

void mp_exch(mp_int *mp1, mp_int *mp2)
{
#if MP_ARGCHK == 2
  assert(mp1 != NULL && mp2 != NULL);
#else
  if(mp1 == NULL || mp2 == NULL)
    return;
#endif

  s_mp_exch(mp1, mp2);

} /* end mp_exch() */

/* }}} */

/* {{{ mp_clear(mp) */

/*
  mp_clear(mp)

  Release the storage used by an mp_int, and void its fields so that
  if someone calls mp_clear() again for the same int later, we won't
  get tollchocked.
 */

void   mp_clear(mp_int *mp)
{
  if(mp == NULL)
    return;

  if(DIGITS(mp) != NULL) {
#if MP_CRYPTO
    s_mp_setz(DIGITS(mp), ALLOC(mp));
#endif
    s_mp_free(DIGITS(mp));
    DIGITS(mp) = NULL;
  }

  USED(mp) = 0;
  ALLOC(mp) = 0;

} /* end mp_clear() */

/* }}} */

/* {{{ mp_clear_array(mp[], count) */

void   mp_clear_array(mp_int mp[], int count)
{
  ARGCHK(mp != NULL && count > 0, MP_BADARG);

  while(--count >= 0) 
    mp_clear(&mp[count]);

} /* end mp_clear_array() */

/* }}} */

/* {{{ mp_zero(mp) */

/*
  mp_zero(mp) 

  Set mp to zero.  Does not change the allocated size of the structure,
  and therefore cannot fail (except on a bad argument, which we ignore)
 */
void   mp_zero(mp_int *mp)
{
  if(mp == NULL)
    return;

  s_mp_setz(DIGITS(mp), ALLOC(mp));
  USED(mp) = 1;
  SIGN(mp) = MP_ZPOS;

} /* end mp_zero() */

/* }}} */

/* {{{ mp_set(mp, d) */

void   mp_set(mp_int *mp, mp_digit d)
{
  if(mp == NULL)
    return;

  mp_zero(mp);
  DIGIT(mp, 0) = d;

} /* end mp_set() */

/* }}} */

/* {{{ mp_set_int(mp, z) */

mp_err mp_set_int(mp_int *mp, long z)
{
  int            ix;
  unsigned long  v = abs(z);
  mp_err         res;

  ARGCHK(mp != NULL, MP_BADARG);

  mp_zero(mp);
  if(z == 0)
    return MP_OKAY;  /* shortcut for zero */

  for(ix = sizeof(long) - 1; ix >= 0; ix--) {

    if((res = s_mp_mul_2d(mp, CHAR_BIT)) != MP_OKAY)
      return res;

    res = s_mp_add_d(mp, 
		     (mp_digit)((v >> (ix * CHAR_BIT)) & UCHAR_MAX));
    if(res != MP_OKAY)
      return res;

  }

  if(z < 0)
    SIGN(mp) = MP_NEG;

  return MP_OKAY;

} /* end mp_set_int() */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ Digit arithmetic */

/* {{{ mp_add_d(a, d, b) */

/*
  mp_add_d(a, d, b)

  Compute the sum b = a + d, for a single digit d.  Respects the sign of
  its primary addend (single digits are unsigned anyway).
 */

mp_err mp_add_d(mp_int *a, mp_digit d, mp_int *b)
{
  mp_err   res = MP_OKAY;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if((res = mp_copy(a, b)) != MP_OKAY)
    return res;

  if(SIGN(b) == MP_ZPOS) {
    res = s_mp_add_d(b, d);
  } else if(s_mp_cmp_d(b, d) >= 0) {
    res = s_mp_sub_d(b, d);
  } else {
    SIGN(b) = MP_ZPOS;

    DIGIT(b, 0) = d - DIGIT(b, 0);
  }

  return res;

} /* end mp_add_d() */

/* }}} */

/* {{{ mp_sub_d(a, d, b) */

/*
  mp_sub_d(a, d, b)

  Compute the difference b = a - d, for a single digit d.  Respects the
  sign of its subtrahend (single digits are unsigned anyway).
 */

mp_err mp_sub_d(mp_int *a, mp_digit d, mp_int *b)
{
  mp_err   res;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if((res = mp_copy(a, b)) != MP_OKAY)
    return res;

  if(SIGN(b) == MP_NEG) {
    if((res = s_mp_add_d(b, d)) != MP_OKAY)
      return res;

  } else if(s_mp_cmp_d(b, d) >= 0) {
    if((res = s_mp_sub_d(b, d)) != MP_OKAY)
      return res;

  } else {
    mp_neg(b, b);

    DIGIT(b, 0) = d - DIGIT(b, 0);
    SIGN(b) = MP_NEG;
  }

  if(s_mp_cmp_d(b, 0) == 0)
    SIGN(b) = MP_ZPOS;

  return MP_OKAY;

} /* end mp_sub_d() */

/* }}} */

/* {{{ mp_mul_d(a, d, b) */

/*
  mp_mul_d(a, d, b)

  Compute the product b = a * d, for a single digit d.  Respects the sign
  of its multiplicand (single digits are unsigned anyway)
 */

mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b)
{
  mp_err  res;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if(d == 0) {
    mp_zero(b);
    return MP_OKAY;
  }

  if((res = mp_copy(a, b)) != MP_OKAY)
    return res;

  res = s_mp_mul_d(b, d);

  return res;

} /* end mp_mul_d() */

/* }}} */

/* {{{ mp_mul_2(a, c) */

mp_err mp_mul_2(mp_int *a, mp_int *c)
{
  mp_err  res;

  ARGCHK(a != NULL && c != NULL, MP_BADARG);

  if((res = mp_copy(a, c)) != MP_OKAY)
    return res;

  return s_mp_mul_2(c);

} /* end mp_mul_2() */

/* }}} */

/* {{{ mp_div_d(a, d, q, r) */

/*
  mp_div_d(a, d, q, r)

  Compute the quotient q = a / d and remainder r = a mod d, for a
  single digit d.  Respects the sign of its divisor (single digits are
  unsigned anyway).
 */

mp_err mp_div_d(mp_int *a, mp_digit d, mp_int *q, mp_digit *r)
{
  mp_err   res;
  mp_digit rem;
  int      pow;

  ARGCHK(a != NULL, MP_BADARG);

  if(d == 0)
    return MP_RANGE;

  /* Shortcut for powers of two ... */
  if((pow = s_mp_ispow2d(d)) >= 0) {
    mp_digit  mask;

    mask = (1 << pow) - 1;
    rem = DIGIT(a, 0) & mask;

    if(q) {
      mp_copy(a, q);
      s_mp_div_2d(q, pow);
    }

    if(r)
      *r = rem;

    return MP_OKAY;
  }

  /*
    If the quotient is actually going to be returned, we'll try to
    avoid hitting the memory allocator by copying the dividend into it
    and doing the division there.  This can't be any _worse_ than
    always copying, and will sometimes be better (since it won't make
    another copy)

    If it's not going to be returned, we need to allocate a temporary
    to hold the quotient, which will just be discarded.
   */
  if(q) {
    if((res = mp_copy(a, q)) != MP_OKAY)
      return res;

    res = s_mp_div_d(q, d, &rem);
    if(s_mp_cmp_d(q, 0) == MP_EQ)
      SIGN(q) = MP_ZPOS;

  } else {
    mp_int  qp;

    if((res = mp_init_copy(&qp, a)) != MP_OKAY)
      return res;

    res = s_mp_div_d(&qp, d, &rem);
    if(s_mp_cmp_d(&qp, 0) == 0)
      SIGN(&qp) = MP_ZPOS;

    mp_clear(&qp);
  }

  if(r)
    *r = rem;

  return res;

} /* end mp_div_d() */

/* }}} */

/* {{{ mp_div_2(a, c) */

/*
  mp_div_2(a, c)

  Compute c = a / 2, disregarding the remainder.
 */

mp_err mp_div_2(mp_int *a, mp_int *c)
{
  mp_err  res;

  ARGCHK(a != NULL && c != NULL, MP_BADARG);

  if((res = mp_copy(a, c)) != MP_OKAY)
    return res;

  s_mp_div_2(c);

  return MP_OKAY;

} /* end mp_div_2() */

/* }}} */

/* {{{ mp_expt_d(a, d, b) */

mp_err mp_expt_d(mp_int *a, mp_digit d, mp_int *c)
{
  mp_int   s, x;
  mp_err   res;

  ARGCHK(a != NULL && c != NULL, MP_BADARG);

  if((res = mp_init(&s)) != MP_OKAY)
    return res;
  if((res = mp_init_copy(&x, a)) != MP_OKAY)
    goto X;

  DIGIT(&s, 0) = 1;

  while(d != 0) {
    if(d & 1) {
      if((res = s_mp_mul(&s, &x)) != MP_OKAY)
	goto CLEANUP;
    }

    d >>= 1;

    if((res = s_mp_sqr(&x)) != MP_OKAY)
      goto CLEANUP;
  }

  s_mp_exch(&s, c);

CLEANUP:
  mp_clear(&x);
X:
  mp_clear(&s);

  return res;

} /* end mp_expt_d() */

/* }}} */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ Full arithmetic */

/* {{{ mp_abs(a, b) */

/*
  mp_abs(a, b)

  Compute b = |a|.  'a' and 'b' may be identical.
 */

mp_err mp_abs(mp_int *a, mp_int *b)
{
  mp_err   res;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if((res = mp_copy(a, b)) != MP_OKAY)
    return res;

  SIGN(b) = MP_ZPOS;

  return MP_OKAY;

} /* end mp_abs() */

/* }}} */

/* {{{ mp_neg(a, b) */

/*
  mp_neg(a, b)

  Compute b = -a.  'a' and 'b' may be identical.
 */

mp_err mp_neg(mp_int *a, mp_int *b)
{
  mp_err   res;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if((res = mp_copy(a, b)) != MP_OKAY)
    return res;

  if(s_mp_cmp_d(b, 0) == MP_EQ) 
    SIGN(b) = MP_ZPOS;
  else 
    SIGN(b) = (SIGN(b) == MP_NEG) ? MP_ZPOS : MP_NEG;

  return MP_OKAY;

} /* end mp_neg() */

/* }}} */

/* {{{ mp_add(a, b, c) */

/*
  mp_add(a, b, c)

  Compute c = a + b.  All parameters may be identical.
 */

mp_err mp_add(mp_int *a, mp_int *b, mp_int *c)
{
  mp_err  res;
  int     cmp;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  if(SIGN(a) == SIGN(b)) { /* same sign:  add values, keep sign */

    /* Commutativity of addition lets us do this in either order,
       so we avoid having to use a temporary even if the result 
       is supposed to replace the output
     */
    if(c == b) {
      if((res = s_mp_add(c, a)) != MP_OKAY)
	return res;
    } else {
      if(c != a && (res = mp_copy(a, c)) != MP_OKAY)
	return res;

      if((res = s_mp_add(c, b)) != MP_OKAY) 
	return res;
    }

  } else if((cmp = s_mp_cmp(a, b)) > 0) {  /* different sign: a > b   */

    /* If the output is going to be clobbered, we will use a temporary
       variable; otherwise, we'll do it without touching the memory 
       allocator at all, if possible
     */
    if(c == b) {
      mp_int  tmp;

      if((res = mp_init_copy(&tmp, a)) != MP_OKAY)
	return res;
      if((res = s_mp_sub(&tmp, b)) != MP_OKAY) {
	mp_clear(&tmp);
	return res;
      }

      s_mp_exch(&tmp, c);
      mp_clear(&tmp);

    } else {

      if(c != a && (res = mp_copy(a, c)) != MP_OKAY)
	return res;
      if((res = s_mp_sub(c, b)) != MP_OKAY)
	return res;

    }

  } else if(cmp == 0) {             /* different sign, a == b   */

    mp_zero(c);
    return MP_OKAY;

  } else {                          /* different sign: a < b    */

    /* See above... */
    if(c == a) {
      mp_int  tmp;

      if((res = mp_init_copy(&tmp, b)) != MP_OKAY)
	return res;
      if((res = s_mp_sub(&tmp, a)) != MP_OKAY) {
	mp_clear(&tmp);
	return res;
      }

      s_mp_exch(&tmp, c);
      mp_clear(&tmp);

    } else {

      if(c != b && (res = mp_copy(b, c)) != MP_OKAY)
	return res;
      if((res = s_mp_sub(c, a)) != MP_OKAY)
	return res;

    }
  }

  if(USED(c) == 1 && DIGIT(c, 0) == 0)
    SIGN(c) = MP_ZPOS;

  return MP_OKAY;

} /* end mp_add() */

/* }}} */

/* {{{ mp_sub(a, b, c) */

/*
  mp_sub(a, b, c)

  Compute c = a - b.  All parameters may be identical.
 */

mp_err mp_sub(mp_int *a, mp_int *b, mp_int *c)
{
  mp_err  res;
  int     cmp;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  if(SIGN(a) != SIGN(b)) {
    if(c == a) {
      if((res = s_mp_add(c, b)) != MP_OKAY)
	return res;
    } else {
      if(c != b && ((res = mp_copy(b, c)) != MP_OKAY))
	return res;
      if((res = s_mp_add(c, a)) != MP_OKAY)
	return res;
      SIGN(c) = SIGN(a);
    }

  } else if((cmp = s_mp_cmp(a, b)) > 0) { /* Same sign, a > b */
    if(c == b) {
      mp_int  tmp;

      if((res = mp_init_copy(&tmp, a)) != MP_OKAY)
	return res;
      if((res = s_mp_sub(&tmp, b)) != MP_OKAY) {
	mp_clear(&tmp);
	return res;
      }
      s_mp_exch(&tmp, c);
      mp_clear(&tmp);

    } else {
      if(c != a && ((res = mp_copy(a, c)) != MP_OKAY))
	return res;

      if((res = s_mp_sub(c, b)) != MP_OKAY)
	return res;
    }

  } else if(cmp == 0) {  /* Same sign, equal magnitude */
    mp_zero(c);
    return MP_OKAY;

  } else {               /* Same sign, b > a */
    if(c == a) {
      mp_int  tmp;

      if((res = mp_init_copy(&tmp, b)) != MP_OKAY)
	return res;

      if((res = s_mp_sub(&tmp, a)) != MP_OKAY) {
	mp_clear(&tmp);
	return res;
      }
      s_mp_exch(&tmp, c);
      mp_clear(&tmp);

    } else {
      if(c != b && ((res = mp_copy(b, c)) != MP_OKAY)) 
	return res;

      if((res = s_mp_sub(c, a)) != MP_OKAY)
	return res;
    }

    SIGN(c) = !SIGN(b);
  }

  if(USED(c) == 1 && DIGIT(c, 0) == 0)
    SIGN(c) = MP_ZPOS;

  return MP_OKAY;

} /* end mp_sub() */

/* }}} */

/* {{{ mp_mul(a, b, c) */

/*
  mp_mul(a, b, c)

  Compute c = a * b.  All parameters may be identical.
 */

mp_err mp_mul(mp_int *a, mp_int *b, mp_int *c)
{
  mp_err   res;
  mp_sign  sgn;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  sgn = (SIGN(a) == SIGN(b)) ? MP_ZPOS : MP_NEG;

  if(c == b) {
    if((res = s_mp_mul(c, a)) != MP_OKAY)
      return res;

  } else {
    if((res = mp_copy(a, c)) != MP_OKAY)
      return res;

    if((res = s_mp_mul(c, b)) != MP_OKAY)
      return res;
  }
  
  if(sgn == MP_ZPOS || s_mp_cmp_d(c, 0) == MP_EQ)
    SIGN(c) = MP_ZPOS;
  else
    SIGN(c) = sgn;
  
  return MP_OKAY;

} /* end mp_mul() */

/* }}} */

/* {{{ mp_mul_2d(a, d, c) */

/*
  mp_mul_2d(a, d, c)

  Compute c = a * 2^d.  a may be the same as c.
 */

mp_err mp_mul_2d(mp_int *a, mp_digit d, mp_int *c)
{
  mp_err   res;

  ARGCHK(a != NULL && c != NULL, MP_BADARG);

  if((res = mp_copy(a, c)) != MP_OKAY)
    return res;

  if(d == 0)
    return MP_OKAY;

  return s_mp_mul_2d(c, d);

} /* end mp_mul() */

/* }}} */

/* {{{ mp_sqr(a, b) */

#if MP_SQUARE
mp_err mp_sqr(mp_int *a, mp_int *b)
{
  mp_err   res;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if((res = mp_copy(a, b)) != MP_OKAY)
    return res;

  if((res = s_mp_sqr(b)) != MP_OKAY)
    return res;

  SIGN(b) = MP_ZPOS;

  return MP_OKAY;

} /* end mp_sqr() */
#endif

/* }}} */

/* {{{ mp_div(a, b, q, r) */

/*
  mp_div(a, b, q, r)

  Compute q = a / b and r = a mod b.  Input parameters may be re-used
  as output parameters.  If q or r is NULL, that portion of the
  computation will be discarded (although it will still be computed)

  Pay no attention to the hacker behind the curtain.
 */

mp_err mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r)
{
  mp_err   res;
  mp_int   qtmp, rtmp;
  int      cmp;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  if(mp_cmp_z(b) == MP_EQ)
    return MP_RANGE;

  /* If a <= b, we can compute the solution without division, and
     avoid any memory allocation
   */
  if((cmp = s_mp_cmp(a, b)) < 0) {
    if(r) {
      if((res = mp_copy(a, r)) != MP_OKAY)
	return res;
    }

    if(q) 
      mp_zero(q);

    return MP_OKAY;

  } else if(cmp == 0) {

    /* Set quotient to 1, with appropriate sign */
    if(q) {
      int qneg = (SIGN(a) != SIGN(b));

      mp_set(q, 1);
      if(qneg)
	SIGN(q) = MP_NEG;
    }

    if(r)
      mp_zero(r);

    return MP_OKAY;
  }

  /* If we get here, it means we actually have to do some division */

  /* Set up some temporaries... */
  if((res = mp_init_copy(&qtmp, a)) != MP_OKAY)
    return res;
  if((res = mp_init_copy(&rtmp, b)) != MP_OKAY)
    goto CLEANUP;

  if((res = s_mp_div(&qtmp, &rtmp)) != MP_OKAY)
    goto CLEANUP;

  /* Compute the signs for the output  */
  SIGN(&rtmp) = SIGN(a); /* Sr = Sa              */
  if(SIGN(a) == SIGN(b))
    SIGN(&qtmp) = MP_ZPOS;  /* Sq = MP_ZPOS if Sa = Sb */
  else
    SIGN(&qtmp) = MP_NEG;   /* Sq = MP_NEG if Sa != Sb */

  if(s_mp_cmp_d(&qtmp, 0) == MP_EQ)
    SIGN(&qtmp) = MP_ZPOS;
  if(s_mp_cmp_d(&rtmp, 0) == MP_EQ)
    SIGN(&rtmp) = MP_ZPOS;

  /* Copy output, if it is needed      */
  if(q) 
    s_mp_exch(&qtmp, q);

  if(r) 
    s_mp_exch(&rtmp, r);

CLEANUP:
  mp_clear(&rtmp);
  mp_clear(&qtmp);

  return res;

} /* end mp_div() */

/* }}} */

/* {{{ mp_div_2d(a, d, q, r) */

mp_err mp_div_2d(mp_int *a, mp_digit d, mp_int *q, mp_int *r)
{
  mp_err  res;

  ARGCHK(a != NULL, MP_BADARG);

  if(q) {
    if((res = mp_copy(a, q)) != MP_OKAY)
      return res;

    s_mp_div_2d(q, d);
  }

  if(r) {
    if((res = mp_copy(a, r)) != MP_OKAY)
      return res;

    s_mp_mod_2d(r, d);
  }

  return MP_OKAY;

} /* end mp_div_2d() */

/* }}} */

/* {{{ mp_expt(a, b, c) */

/*
  mp_expt(a, b, c)

  Compute c = a ** b, that is, raise a to the b power.  Uses a
  standard iterative square-and-multiply technique.
 */

mp_err mp_expt(mp_int *a, mp_int *b, mp_int *c)
{
  mp_int   s, x;
  mp_err   res;
  mp_digit d;
  int      dig, bit;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  if(mp_cmp_z(b) < 0)
    return MP_RANGE;

  if((res = mp_init(&s)) != MP_OKAY)
    return res;

  mp_set(&s, 1);

  if((res = mp_init_copy(&x, a)) != MP_OKAY)
    goto X;

  /* Loop over low-order digits in ascending order */
  for(dig = 0; dig < (USED(b) - 1); dig++) {
    d = DIGIT(b, dig);

    /* Loop over bits of each non-maximal digit */
    for(bit = 0; bit < DIGIT_BIT; bit++) {
      if(d & 1) {
	if((res = s_mp_mul(&s, &x)) != MP_OKAY) 
	  goto CLEANUP;
      }

      d >>= 1;
      
      if((res = s_mp_sqr(&x)) != MP_OKAY)
	goto CLEANUP;
    }
  }

  /* Consider now the last digit... */
  d = DIGIT(b, dig);

  while(d) {
    if(d & 1) {
      if((res = s_mp_mul(&s, &x)) != MP_OKAY)
	goto CLEANUP;
    }

    d >>= 1;

    if((res = s_mp_sqr(&x)) != MP_OKAY)
      goto CLEANUP;
  }
  
  if(mp_iseven(b))
    SIGN(&s) = SIGN(a);

  res = mp_copy(&s, c);

CLEANUP:
  mp_clear(&x);
X:
  mp_clear(&s);

  return res;

} /* end mp_expt() */

/* }}} */

/* {{{ mp_2expt(a, k) */

/* Compute a = 2^k */

mp_err mp_2expt(mp_int *a, mp_digit k)
{
  ARGCHK(a != NULL, MP_BADARG);

  return s_mp_2expt(a, k);

} /* end mp_2expt() */

/* }}} */

/* {{{ mp_mod(a, m, c) */

/*
  mp_mod(a, m, c)

  Compute c = a (mod m).  Result will always be 0 <= c < m.
 */

mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c)
{
  mp_err  res;
  int     mag;

  ARGCHK(a != NULL && m != NULL && c != NULL, MP_BADARG);

  if(SIGN(m) == MP_NEG)
    return MP_RANGE;

  /*
     If |a| > m, we need to divide to get the remainder and take the
     absolute value.  

     If |a| < m, we don't need to do any division, just copy and adjust
     the sign (if a is negative).

     If |a| == m, we can simply set the result to zero.

     This order is intended to minimize the average path length of the
     comparison chain on common workloads -- the most frequent cases are
     that |a| != m, so we do those first.
   */
  if((mag = s_mp_cmp(a, m)) > 0) {
    if((res = mp_div(a, m, NULL, c)) != MP_OKAY)
      return res;
    
    if(SIGN(c) == MP_NEG) {
      if((res = mp_add(c, m, c)) != MP_OKAY)
	return res;
    }

  } else if(mag < 0) {
    if((res = mp_copy(a, c)) != MP_OKAY)
      return res;

    if(mp_cmp_z(a) < 0) {
      if((res = mp_add(c, m, c)) != MP_OKAY)
	return res;

    }
    
  } else {
    mp_zero(c);

  }

  return MP_OKAY;

} /* end mp_mod() */

/* }}} */

/* {{{ mp_mod_d(a, d, c) */

/*
  mp_mod_d(a, d, c)

  Compute c = a (mod d).  Result will always be 0 <= c < d
 */
mp_err mp_mod_d(mp_int *a, mp_digit d, mp_digit *c)
{
  mp_err   res;
  mp_digit rem;

  ARGCHK(a != NULL && c != NULL, MP_BADARG);

  if(s_mp_cmp_d(a, d) > 0) {
    if((res = mp_div_d(a, d, NULL, &rem)) != MP_OKAY)
      return res;

  } else {
    if(SIGN(a) == MP_NEG)
      rem = d - DIGIT(a, 0);
    else
      rem = DIGIT(a, 0);
  }

  if(c)
    *c = rem;

  return MP_OKAY;

} /* end mp_mod_d() */

/* }}} */

/* {{{ mp_sqrt(a, b) */

/*
  mp_sqrt(a, b)

  Compute the integer square root of a, and store the result in b.
  Uses an integer-arithmetic version of Newton's iterative linear
  approximation technique to determine this value; the result has the
  following two properties:

     b^2 <= a
     (b+1)^2 >= a

  It is a range error to pass a negative value.
 */
mp_err mp_sqrt(mp_int *a, mp_int *b)
{
  mp_int   x, t;
  mp_err   res;

  ARGCHK(a != NULL && b != NULL, MP_BADARG);

  /* Cannot take square root of a negative value */
  if(SIGN(a) == MP_NEG)
    return MP_RANGE;

  /* Special cases for zero and one, trivial     */
  if(mp_cmp_d(a, 0) == MP_EQ || mp_cmp_d(a, 1) == MP_EQ) 
    return mp_copy(a, b);
    
  /* Initialize the temporaries we'll use below  */
  if((res = mp_init_size(&t, USED(a))) != MP_OKAY)
    return res;

  /* Compute an initial guess for the iteration as a itself */
  if((res = mp_init_copy(&x, a)) != MP_OKAY)
    goto X;

s_mp_rshd(&x, (USED(&x)/2)+1);
mp_add_d(&x, 1, &x);

  for(;;) {
    /* t = (x * x) - a */
    mp_copy(&x, &t);      /* can't fail, t is big enough for original x */
    if((res = mp_sqr(&t, &t)) != MP_OKAY ||
       (res = mp_sub(&t, a, &t)) != MP_OKAY)
      goto CLEANUP;

    /* t = t / 2x       */
    s_mp_mul_2(&x);
    if((res = mp_div(&t, &x, &t, NULL)) != MP_OKAY)
      goto CLEANUP;
    s_mp_div_2(&x);

    /* Terminate the loop, if the quotient is zero */
    if(mp_cmp_z(&t) == MP_EQ)
      break;

    /* x = x - t       */
    if((res = mp_sub(&x, &t, &x)) != MP_OKAY)
      goto CLEANUP;

  }

  /* Copy result to output parameter */
  mp_sub_d(&x, 1, &x);
  s_mp_exch(&x, b);

 CLEANUP:
  mp_clear(&x);
 X:
  mp_clear(&t); 

  return res;

} /* end mp_sqrt() */

/* }}} */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ Modular arithmetic */

#if MP_MODARITH
/* {{{ mp_addmod(a, b, m, c) */

/*
  mp_addmod(a, b, m, c)

  Compute c = (a + b) mod m
 */

mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c)
{
  mp_err  res;

  ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG);

  if((res = mp_add(a, b, c)) != MP_OKAY)
    return res;
  if((res = mp_mod(c, m, c)) != MP_OKAY)
    return res;

  return MP_OKAY;

}

/* }}} */

/* {{{ mp_submod(a, b, m, c) */

/*
  mp_submod(a, b, m, c)

  Compute c = (a - b) mod m
 */

mp_err mp_submod(mp_int *a, mp_int *b, mp_int *m, mp_int *c)
{
  mp_err  res;

  ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG);

  if((res = mp_sub(a, b, c)) != MP_OKAY)
    return res;
  if((res = mp_mod(c, m, c)) != MP_OKAY)
    return res;

  return MP_OKAY;

}

/* }}} */

/* {{{ mp_mulmod(a, b, m, c) */

/*
  mp_mulmod(a, b, m, c)

  Compute c = (a * b) mod m
 */

mp_err mp_mulmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c)
{
  mp_err  res;

  ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG);

  if((res = mp_mul(a, b, c)) != MP_OKAY)
    return res;
  if((res = mp_mod(c, m, c)) != MP_OKAY)
    return res;

  return MP_OKAY;

}

/* }}} */

/* {{{ mp_sqrmod(a, m, c) */

#if MP_SQUARE
mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c)
{
  mp_err  res;

  ARGCHK(a != NULL && m != NULL && c != NULL, MP_BADARG);

  if((res = mp_sqr(a, c)) != MP_OKAY)
    return res;
  if((res = mp_mod(c, m, c)) != MP_OKAY)
    return res;

  return MP_OKAY;

} /* end mp_sqrmod() */
#endif

/* }}} */

/* {{{ mp_exptmod(a, b, m, c) */

/*
  mp_exptmod(a, b, m, c)

  Compute c = (a ** b) mod m.  Uses a standard square-and-multiply
  method with modular reductions at each step. (This is basically the
  same code as mp_expt(), except for the addition of the reductions)
  
  The modular reductions are done using Barrett's algorithm (see
  s_mp_reduce() below for details)
 */

mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c)
{
  mp_int   s, x, mu;
  mp_err   res;
  mp_digit d, *db = DIGITS(b);
  mp_size  ub = USED(b);
  int      dig, bit;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  if(mp_cmp_z(b) < 0 || mp_cmp_z(m) <= 0)
    return MP_RANGE;

  if((res = mp_init(&s)) != MP_OKAY)
    return res;
  if((res = mp_init_copy(&x, a)) != MP_OKAY)
    goto X;
  if((res = mp_mod(&x, m, &x)) != MP_OKAY ||
     (res = mp_init(&mu)) != MP_OKAY)
    goto MU;

  mp_set(&s, 1);

  /* mu = b^2k / m */
  s_mp_add_d(&mu, 1); 
  s_mp_lshd(&mu, 2 * USED(m));
  if((res = mp_div(&mu, m, &mu, NULL)) != MP_OKAY)
    goto CLEANUP;

  /* Loop over digits of b in ascending order, except highest order */
  for(dig = 0; dig < (ub - 1); dig++) {
    d = *db++;

    /* Loop over the bits of the lower-order digits */
    for(bit = 0; bit < DIGIT_BIT; bit++) {
      if(d & 1) {
	if((res = s_mp_mul(&s, &x)) != MP_OKAY)
	  goto CLEANUP;
	if((res = s_mp_reduce(&s, m, &mu)) != MP_OKAY)
	  goto CLEANUP;
      }

      d >>= 1;

      if((res = s_mp_sqr(&x)) != MP_OKAY)
	goto CLEANUP;
      if((res = s_mp_reduce(&x, m, &mu)) != MP_OKAY)
	goto CLEANUP;
    }
  }

  /* Now do the last digit... */
  d = *db;

  while(d) {
    if(d & 1) {
      if((res = s_mp_mul(&s, &x)) != MP_OKAY)
	goto CLEANUP;
      if((res = s_mp_reduce(&s, m, &mu)) != MP_OKAY)
	goto CLEANUP;
    }

    d >>= 1;

    if((res = s_mp_sqr(&x)) != MP_OKAY)
      goto CLEANUP;
    if((res = s_mp_reduce(&x, m, &mu)) != MP_OKAY)
      goto CLEANUP;
  }

  s_mp_exch(&s, c);

 CLEANUP:
  mp_clear(&mu);
 MU:
  mp_clear(&x);
 X:
  mp_clear(&s);

  return res;

} /* end mp_exptmod() */

/* }}} */

/* {{{ mp_exptmod_d(a, d, m, c) */

mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c)
{
  mp_int   s, x;
  mp_err   res;

  ARGCHK(a != NULL && c != NULL, MP_BADARG);

  if((res = mp_init(&s)) != MP_OKAY)
    return res;
  if((res = mp_init_copy(&x, a)) != MP_OKAY)
    goto X;

  mp_set(&s, 1);

  while(d != 0) {
    if(d & 1) {
      if((res = s_mp_mul(&s, &x)) != MP_OKAY ||
	 (res = mp_mod(&s, m, &s)) != MP_OKAY)
	goto CLEANUP;
    }

    d /= 2;

    if((res = s_mp_sqr(&x)) != MP_OKAY ||
       (res = mp_mod(&x, m, &x)) != MP_OKAY)
      goto CLEANUP;
  }

  s_mp_exch(&s, c);

CLEANUP:
  mp_clear(&x);
X:
  mp_clear(&s);

  return res;

} /* end mp_exptmod_d() */

/* }}} */
#endif /* if MP_MODARITH */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ Comparison functions */

/* {{{ mp_cmp_z(a) */

/*
  mp_cmp_z(a)

  Compare a <=> 0.  Returns <0 if a<0, 0 if a=0, >0 if a>0.
 */

int    mp_cmp_z(mp_int *a)
{
  if(SIGN(a) == MP_NEG)
    return MP_LT;
  else if(USED(a) == 1 && DIGIT(a, 0) == 0)
    return MP_EQ;
  else
    return MP_GT;

} /* end mp_cmp_z() */

/* }}} */

/* {{{ mp_cmp_d(a, d) */

/*
  mp_cmp_d(a, d)

  Compare a <=> d.  Returns <0 if a<d, 0 if a=d, >0 if a>d
 */

int    mp_cmp_d(mp_int *a, mp_digit d)
{
  ARGCHK(a != NULL, MP_EQ);

  if(SIGN(a) == MP_NEG)
    return MP_LT;

  return s_mp_cmp_d(a, d);

} /* end mp_cmp_d() */

/* }}} */

/* {{{ mp_cmp(a, b) */

int    mp_cmp(mp_int *a, mp_int *b)
{
  ARGCHK(a != NULL && b != NULL, MP_EQ);

  if(SIGN(a) == SIGN(b)) {
    int  mag;

    if((mag = s_mp_cmp(a, b)) == MP_EQ)
      return MP_EQ;

    if(SIGN(a) == MP_ZPOS)
      return mag;
    else
      return -mag;

  } else if(SIGN(a) == MP_ZPOS) {
    return MP_GT;
  } else {
    return MP_LT;
  }

} /* end mp_cmp() */

/* }}} */

/* {{{ mp_cmp_mag(a, b) */

/*
  mp_cmp_mag(a, b)

  Compares |a| <=> |b|, and returns an appropriate comparison result
 */

int    mp_cmp_mag(mp_int *a, mp_int *b)
{
  ARGCHK(a != NULL && b != NULL, MP_EQ);

  return s_mp_cmp(a, b);

} /* end mp_cmp_mag() */

/* }}} */

/* {{{ mp_cmp_int(a, z) */

/*
  This just converts z to an mp_int, and uses the existing comparison
  routines.  This is sort of inefficient, but it's not clear to me how
  frequently this wil get used anyway.  For small positive constants,
  you can always use mp_cmp_d(), and for zero, there is mp_cmp_z().
 */
int    mp_cmp_int(mp_int *a, long z)
{
  mp_int  tmp;
  int     out;

  ARGCHK(a != NULL, MP_EQ);
  
  mp_init(&tmp); mp_set_int(&tmp, z);
  out = mp_cmp(a, &tmp);
  mp_clear(&tmp);

  return out;

} /* end mp_cmp_int() */

/* }}} */

/* {{{ mp_isodd(a) */

/*
  mp_isodd(a)

  Returns a true (non-zero) value if a is odd, false (zero) otherwise.
 */
int    mp_isodd(mp_int *a)
{
  ARGCHK(a != NULL, 0);

  return (DIGIT(a, 0) & 1);

} /* end mp_isodd() */

/* }}} */

/* {{{ mp_iseven(a) */

int    mp_iseven(mp_int *a)
{
  return !mp_isodd(a);

} /* end mp_iseven() */

/* }}} */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ Number theoretic functions */

#if MP_NUMTH
/* {{{ mp_gcd(a, b, c) */

/*
  Like the old mp_gcd() function, except computes the GCD using the
  binary algorithm due to Josef Stein in 1961 (via Knuth).
 */
mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c)
{
  mp_err   res;
  mp_int   u, v, t;
  mp_size  k = 0;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  if(mp_cmp_z(a) == MP_EQ && mp_cmp_z(b) == MP_EQ)
      return MP_RANGE;
  if(mp_cmp_z(a) == MP_EQ) {
    return mp_copy(b, c);
  } else if(mp_cmp_z(b) == MP_EQ) {
    return mp_copy(a, c);
  }

  if((res = mp_init(&t)) != MP_OKAY)
    return res;
  if((res = mp_init_copy(&u, a)) != MP_OKAY)
    goto U;
  if((res = mp_init_copy(&v, b)) != MP_OKAY)
    goto V;

  SIGN(&u) = MP_ZPOS;
  SIGN(&v) = MP_ZPOS;

  /* Divide out common factors of 2 until at least 1 of a, b is even */
  while(mp_iseven(&u) && mp_iseven(&v)) {
    s_mp_div_2(&u);
    s_mp_div_2(&v);
    ++k;
  }

  /* Initialize t */
  if(mp_isodd(&u)) {
    if((res = mp_copy(&v, &t)) != MP_OKAY)
      goto CLEANUP;
    
    /* t = -v */
    if(SIGN(&v) == MP_ZPOS)
      SIGN(&t) = MP_NEG;
    else
      SIGN(&t) = MP_ZPOS;
    
  } else {
    if((res = mp_copy(&u, &t)) != MP_OKAY)
      goto CLEANUP;

  }

  for(;;) {
    while(mp_iseven(&t)) {
      s_mp_div_2(&t);
    }

    if(mp_cmp_z(&t) == MP_GT) {
      if((res = mp_copy(&t, &u)) != MP_OKAY)
	goto CLEANUP;

    } else {
      if((res = mp_copy(&t, &v)) != MP_OKAY)
	goto CLEANUP;

      /* v = -t */
      if(SIGN(&t) == MP_ZPOS)
	SIGN(&v) = MP_NEG;
      else
	SIGN(&v) = MP_ZPOS;
    }

    if((res = mp_sub(&u, &v, &t)) != MP_OKAY)
      goto CLEANUP;

    if(s_mp_cmp_d(&t, 0) == MP_EQ)
      break;
  }

  s_mp_2expt(&v, k);       /* v = 2^k   */
  res = mp_mul(&u, &v, c); /* c = u * v */

 CLEANUP:
  mp_clear(&v);
 V:
  mp_clear(&u);
 U:
  mp_clear(&t);

  return res;

} /* end mp_bgcd() */

/* }}} */

/* {{{ mp_lcm(a, b, c) */

/* We compute the least common multiple using the rule:

   ab = [a, b](a, b)

   ... by computing the product, and dividing out the gcd.
 */

mp_err mp_lcm(mp_int *a, mp_int *b, mp_int *c)
{
  mp_int  gcd, prod;
  mp_err  res;

  ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);

  /* Set up temporaries */
  if((res = mp_init(&gcd)) != MP_OKAY)
    return res;
  if((res = mp_init(&prod)) != MP_OKAY)
    goto GCD;

  if((res = mp_mul(a, b, &prod)) != MP_OKAY)
    goto CLEANUP;
  if((res = mp_gcd(a, b, &gcd)) != MP_OKAY)
    goto CLEANUP;

  res = mp_div(&prod, &gcd, c, NULL);

 CLEANUP:
  mp_clear(&prod);
 GCD:
  mp_clear(&gcd);

  return res;

} /* end mp_lcm() */

/* }}} */

/* {{{ mp_xgcd(a, b, g, x, y) */

/*
  mp_xgcd(a, b, g, x, y)

  Compute g = (a, b) and values x and y satisfying Bezout's identity
  (that is, ax + by = g).  This uses the extended binary GCD algorithm
  based on the Stein algorithm used for mp_gcd()
 */

mp_err mp_xgcd(mp_int *a, mp_int *b, mp_int *g, mp_int *x, mp_int *y)
{
  mp_int   gx, xc, yc, u, v, A, B, C, D;
  mp_int  *clean[9];
  mp_err   res;
  int      last = -1;

  if(mp_cmp_z(b) == 0)
    return MP_RANGE;

  /* Initialize all these variables we need */
  if((res = mp_init(&u)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &u;
  if((res = mp_init(&v)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &v;
  if((res = mp_init(&gx)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &gx;
  if((res = mp_init(&A)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &A;
  if((res = mp_init(&B)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &B;
  if((res = mp_init(&C)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &C;
  if((res = mp_init(&D)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &D;
  if((res = mp_init_copy(&xc, a)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &xc;
  mp_abs(&xc, &xc);
  if((res = mp_init_copy(&yc, b)) != MP_OKAY) goto CLEANUP;
  clean[++last] = &yc;
  mp_abs(&yc, &yc);

  mp_set(&gx, 1);

  /* Divide by two until at least one of them is even */
  while(mp_iseven(&xc) && mp_iseven(&yc)) {
    s_mp_div_2(&xc);
    s_mp_div_2(&yc);
    if((res = s_mp_mul_2(&gx)) != MP_OKAY)
      goto CLEANUP;
  }

  mp_copy(&xc, &u);
  mp_copy(&yc, &v);
  mp_set(&A, 1); mp_set(&D, 1);

  /* Loop through binary GCD algorithm */
  for(;;) {
    while(mp_iseven(&u)) {
      s_mp_div_2(&u);

      if(mp_iseven(&A) && mp_iseven(&B)) {
	s_mp_div_2(&A); s_mp_div_2(&B);
      } else {
	if((res = mp_add(&A, &yc, &A)) != MP_OKAY) goto CLEANUP;
	s_mp_div_2(&A);
	if((res = mp_sub(&B, &xc, &B)) != MP_OKAY) goto CLEANUP;
	s_mp_div_2(&B);
      }
    }

    while(mp_iseven(&v)) {
      s_mp_div_2(&v);

      if(mp_iseven(&C) && mp_iseven(&D)) {
	s_mp_div_2(&C); s_mp_div_2(&D);
      } else {
	if((res = mp_add(&C, &yc, &C)) != MP_OKAY) goto CLEANUP;
	s_mp_div_2(&C);
	if((res = mp_sub(&D, &xc, &D)) != MP_OKAY) goto CLEANUP;
	s_mp_div_2(&D);
      }
    }

    if(mp_cmp(&u, &v) >= 0) {
      if((res = mp_sub(&u, &v, &u)) != MP_OKAY) goto CLEANUP;
      if((res = mp_sub(&A, &C, &A)) != MP_OKAY) goto CLEANUP;
      if((res = mp_sub(&B, &D, &B)) != MP_OKAY) goto CLEANUP;

    } else {
      if((res = mp_sub(&v, &u, &v)) != MP_OKAY) goto CLEANUP;
      if((res = mp_sub(&C, &A, &C)) != MP_OKAY) goto CLEANUP;
      if((res = mp_sub(&D, &B, &D)) != MP_OKAY) goto CLEANUP;

    }

    /* If we're done, copy results to output */
    if(mp_cmp_z(&u) == 0) {
      if(x)
	if((res = mp_copy(&C, x)) != MP_OKAY) goto CLEANUP;

      if(y)
	if((res = mp_copy(&D, y)) != MP_OKAY) goto CLEANUP;
      
      if(g)
	if((res = mp_mul(&gx, &v, g)) != MP_OKAY) goto CLEANUP;

      break;
    }
  }

 CLEANUP:
  while(last >= 0)
    mp_clear(clean[last--]);

  return res;

} /* end mp_xgcd() */

/* }}} */

/* {{{ mp_invmod(a, m, c) */

/*
  mp_invmod(a, m, c)

  Compute c = a^-1 (mod m), if there is an inverse for a (mod m).
  This is equivalent to the question of whether (a, m) = 1.  If not,
  MP_UNDEF is returned, and there is no inverse.
 */

mp_err mp_invmod(mp_int *a, mp_int *m, mp_int *c)
{
  mp_int  g, x;
  mp_err  res;

  ARGCHK(a && m && c, MP_BADARG);

  if(mp_cmp_z(a) == 0 || mp_cmp_z(m) == 0)
    return MP_RANGE;

  if((res = mp_init(&g)) != MP_OKAY)
    return res;
  if((res = mp_init(&x)) != MP_OKAY)
    goto X;

  if((res = mp_xgcd(a, m, &g, &x, NULL)) != MP_OKAY)
    goto CLEANUP;

  if(mp_cmp_d(&g, 1) != MP_EQ) {
    res = MP_UNDEF;
    goto CLEANUP;
  }

  res = mp_mod(&x, m, c);
  SIGN(c) = SIGN(a);

CLEANUP:
  mp_clear(&x);
X:
  mp_clear(&g);

  return res;

} /* end mp_invmod() */

/* }}} */
#endif /* if MP_NUMTH */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ mp_print(mp, ofp) */

#if MP_IOFUNC
/*
  mp_print(mp, ofp)

  Print a textual representation of the given mp_int on the output
  stream 'ofp'.  Output is generated using the internal radix.
 */

void   mp_print(mp_int *mp, FILE *ofp)
{
  int   ix;

  if(mp == NULL || ofp == NULL)
    return;

  fputc((SIGN(mp) == MP_NEG) ? '-' : '+', ofp);

  for(ix = USED(mp) - 1; ix >= 0; ix--) {
    fprintf(ofp, DIGIT_FMT, DIGIT(mp, ix));
  }

} /* end mp_print() */

#endif /* if MP_IOFUNC */

/* }}} */

/*------------------------------------------------------------------------*/
/* {{{ More I/O Functions */

/* {{{ mp_read_signed_bin(mp, str, len) */

/* 
   mp_read_signed_bin(mp, str, len)

   Read in a raw value (base 256) into the given mp_int
 */

mp_err  mp_read_signed_bin(mp_int *mp, unsigned char *str, int len)
{
  mp_err         res;

  ARGCHK(mp != NULL && str != NULL && len > 0, MP_BADARG);

  if((res = mp_read_unsigned_bin(mp, str + 1, len - 1)) == MP_OKAY) {
    /* Get sign from first byte */
    if(str[0])
      SIGN(mp) = MP_NEG;
    else
      SIGN(mp) = MP_ZPOS;
  }

  return res;

} /* end mp_read_signed_bin() */

/* }}} */

/* {{{ mp_signed_bin_size(mp) */

int    mp_signed_bin_size(mp_int *mp)
{
  ARGCHK(mp != NULL, 0);

  return mp_unsigned_bin_size(mp) + 1;

} /* end mp_signed_bin_size() */

/* }}} */

/* {{{ mp_to_signed_bin(mp, str) */

mp_err mp_to_signed_bin(mp_int *mp, unsigned char *str)
{
  ARGCHK(mp != NULL && str != NULL, MP_BADARG);

  /* Caller responsible for allocating enough memory (use mp_raw_size(mp)) */
  str[0] = (char)SIGN(mp);

  return mp_to_unsigned_bin(mp, str + 1);

} /* end mp_to_signed_bin() */

/* }}} */

/* {{{ mp_read_unsigned_bin(mp, str, len) */

/*
  mp_read_unsigned_bin(mp, str, len)

  Read in an unsigned value (base 256) into the given mp_int
 */

mp_err  mp_read_unsigned_bin(mp_int *mp, unsigned char *str, int len)
{
  int     ix;
  mp_err  res;

  ARGCHK(mp != NULL && str != NULL && len > 0, MP_BADARG);

  mp_zero(mp);

  for(ix = 0; ix < len; ix++) {
    if((res = s_mp_mul_2d(mp, CHAR_BIT)) != MP_OKAY)
      return res;

    if((res = mp_add_d(mp, str[ix], mp)) != MP_OKAY)
      return res;
  }
  
  return MP_OKAY;
  
} /* end mp_read_unsigned_bin() */

/* }}} */

/* {{{ mp_unsigned_bin_size(mp) */

int     mp_unsigned_bin_size(mp_int *mp) 
{
  mp_digit   topdig;
  int        count;

  ARGCHK(mp != NULL, 0);

  /* Special case for the value zero */
  if(USED(mp) == 1 && DIGIT(mp, 0) == 0)
    return 1;

  count = (USED(mp) - 1) * sizeof(mp_digit);
  topdig = DIGIT(mp, USED(mp) - 1);

  while(topdig != 0) {
    ++count;
    topdig >>= CHAR_BIT;
  }

  return count;

} /* end mp_unsigned_bin_size() */

/* }}} */

/* {{{ mp_to_unsigned_bin(mp, str) */

mp_err mp_to_unsigned_bin(mp_int *mp, unsigned char *str)
{
  mp_digit      *dp, *end, d;
  unsigned char *spos;

  ARGCHK(mp != NULL && str != NULL, MP_BADARG);

  dp = DIGITS(mp);
  end = dp + USED(mp) - 1;
  spos = str;

  /* Special case for zero, quick test */
  if(dp == end && *dp == 0) {
    *str = '\0';
    return MP_OKAY;
  }

  /* Generate digits in reverse order */
  while(dp < end) {
    int      ix;

    d = *dp;
    for(ix = 0; ix < sizeof(mp_digit); ++ix) {
      *spos = d & UCHAR_MAX;
      d >>= CHAR_BIT;
      ++spos;
    }

    ++dp;
  }

  /* Now handle last digit specially, high order zeroes are not written */
  d = *end;
  while(d != 0) {
    *spos = d & UCHAR_MAX;
    d >>= CHAR_BIT;
    ++spos;
  }

  /* Reverse everything to get digits in the correct order */
  while(--spos > str) {
    unsigned char t = *str;
    *str = *spos;
    *spos = t;

    ++str;
  }

  return MP_OKAY;

} /* end mp_to_unsigned_bin() */

/* }}} */

/* {{{ mp_count_bits(mp) */

int    mp_count_bits(mp_int *mp)
{
  int      len;
  mp_digit d;

  ARGCHK(mp != NULL, MP_BADARG);

  len = DIGIT_BIT * (USED(mp) - 1);
  d = DIGIT(mp, USED(mp) - 1);

  while(d != 0) {
    ++len;
    d >>= 1;
  }

  return len;
  
} /* end mp_count_bits() */

/* }}} */

/* {{{ mp_read_radix(mp, str, radix) */

/*
  mp_read_radix(mp, str, radix)

  Read an integer from the given string, and set mp to the resulting
  value.  The input is presumed to be in base 10.  Leading non-digit
  characters are ignored, and the function reads until a non-digit
  character or the end of the string.
 */

mp_err  mp_read_radix(mp_int *mp, unsigned char *str, int radix)
{
  int     ix = 0, val = 0;
  mp_err  res;
  mp_sign sig = MP_ZPOS;

  ARGCHK(mp != NULL && str != NULL && radix >= 2 && radix <= MAX_RADIX, 
	 MP_BADARG);

  mp_zero(mp);

  /* Skip leading non-digit characters until a digit or '-' or '+' */
  while(str[ix] && 
	(s_mp_tovalue(str[ix], radix) < 0) && 
	str[ix] != '-' &&
	str[ix] != '+') {
    ++ix;
  }

  if(str[ix] == '-') {
    sig = MP_NEG;
    ++ix;
  } else if(str[ix] == '+') {
    sig = MP_ZPOS; /* this is the default anyway... */
    ++ix;
  }

  while((val = s_mp_tovalue(str[ix], radix)) >= 0) {
    if((res = s_mp_mul_d(mp, radix)) != MP_OKAY)
      return res;
    if((res = s_mp_add_d(mp, val)) != MP_OKAY)
      return res;
    ++ix;
  }

  if(s_mp_cmp_d(mp, 0) == MP_EQ)
    SIGN(mp) = MP_ZPOS;
  else
    SIGN(mp) = sig;

  return MP_OKAY;

} /* end mp_read_radix() */

/* }}} */

/* {{{ mp_radix_size(mp, radix) */

int    mp_radix_size(mp_int *mp, int radix)
{
  int  len;
  ARGCHK(mp != NULL, 0);

  len = s_mp_outlen(mp_count_bits(mp), radix) + 1; /* for NUL terminator */

  if(mp_cmp_z(mp) < 0)
    ++len; /* for sign */

  return len;

} /* end mp_radix_size() */

/* }}} */

/* {{{ mp_value_radix_size(num, qty, radix) */

/* num = number of digits
   qty = number of bits per digit
   radix = target base
   
   Return the number of digits in the specified radix that would be
   needed to express 'num' digits of 'qty' bits each.
 */
int    mp_value_radix_size(int num, int qty, int radix)
{
  ARGCHK(num >= 0 && qty > 0 && radix >= 2 && radix <= MAX_RADIX, 0);

  return s_mp_outlen(num * qty, radix);

} /* end mp_value_radix_size() */

/* }}} */

/* {{{ mp_toradix(mp, str, radix) */

mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix)
{
  int  ix, pos = 0;

  ARGCHK(mp != NULL && str != NULL, MP_BADARG);
  ARGCHK(radix > 1 && radix <= MAX_RADIX, MP_RANGE);

  if(mp_cmp_z(mp) == MP_EQ) {
    str[0] = '0';
    str[1] = '\0';
  } else {
    mp_err   res;
    mp_int   tmp;
    mp_sign  sgn;
    mp_digit rem, rdx = (mp_digit)radix;
    char     ch;

    if((res = mp_init_copy(&tmp, mp)) != MP_OKAY)
      return res;

    /* Save sign for later, and take absolute value */
    sgn = SIGN(&tmp); SIGN(&tmp) = MP_ZPOS;

    /* Generate output digits in reverse order      */
    while(mp_cmp_z(&tmp) != 0) {
      if((res = s_mp_div_d(&tmp, rdx, &rem)) != MP_OKAY) {
	mp_clear(&tmp);
	return res;
      }

      /* Generate digits, use capital letters */
      ch = s_mp_todigit(rem, radix, 0);

      str[pos++] = ch;
    }

    /* Add - sign if original value was negative */
    if(sgn == MP_NEG)
      str[pos++] = '-';

    /* Add trailing NUL to end the string        */
    str[pos--] = '\0';

    /* Reverse the digits and sign indicator     */
    ix = 0;
    while(ix < pos) {
      char tmp = str[ix];

      str[ix] = str[pos];
      str[pos] = tmp;
      ++ix;
      --pos;
    }
    
    mp_clear(&tmp);
  }

  return MP_OKAY;

} /* end mp_toradix() */

/* }}} */

/* {{{ mp_char2value(ch, r) */

int    mp_char2value(char ch, int r)
{
  return s_mp_tovalue(ch, r);

} /* end mp_tovalue() */

/* }}} */

/* }}} */

/* {{{ mp_strerror(ec) */

/*
  mp_strerror(ec)

  Return a string describing the meaning of error code 'ec'.  The
  string returned is allocated in static memory, so the caller should
  not attempt to modify or free the memory associated with this
  string.
 */
const char  *mp_strerror(mp_err ec)
{
  int   aec = (ec < 0) ? -ec : ec;

  /* Code values are negative, so the senses of these comparisons
     are accurate */
  if(ec < MP_LAST_CODE || ec > MP_OKAY) {
    return mp_err_string[0];  /* unknown error code */
  } else {
    return mp_err_string[aec + 1];
  }

} /* end mp_strerror() */

/* }}} */

/*========================================================================*/
/*------------------------------------------------------------------------*/
/* Static function definitions (internal use only)                        */

/* {{{ Memory management */

/* {{{ s_mp_grow(mp, min) */

/* Make sure there are at least 'min' digits allocated to mp              */
mp_err   s_mp_grow(mp_int *mp, mp_size min)
{
  if(min > ALLOC(mp)) {
    mp_digit   *tmp;

    /* Set min to next nearest default precision block size */
    min = ((min + (s_mp_defprec - 1)) / s_mp_defprec) * s_mp_defprec;

    if((tmp = s_mp_alloc(min, sizeof(mp_digit))) == NULL)
      return MP_MEM;

    s_mp_copy(DIGITS(mp), tmp, USED(mp));

#if MP_CRYPTO
    s_mp_setz(DIGITS(mp), ALLOC(mp));
#endif
    s_mp_free(DIGITS(mp));
    DIGITS(mp) = tmp;
    ALLOC(mp) = min;
  }

  return MP_OKAY;

} /* end s_mp_grow() */

/* }}} */

/* {{{ s_mp_pad(mp, min) */

/* Make sure the used size of mp is at least 'min', growing if needed     */
mp_err   s_mp_pad(mp_int *mp, mp_size min)
{
  if(min > USED(mp)) {
    mp_err  res;

    /* Make sure there is room to increase precision  */
    if(min > ALLOC(mp) && (res = s_mp_grow(mp, min)) != MP_OKAY)
      return res;

    /* Increase precision; should already be 0-filled */
    USED(mp) = min;
  }

  return MP_OKAY;

} /* end s_mp_pad() */

/* }}} */

/* {{{ s_mp_setz(dp, count) */

#if MP_MACRO == 0
/* Set 'count' digits pointed to by dp to be zeroes                       */
void s_mp_setz(mp_digit *dp, mp_size count)
{
#if MP_MEMSET == 0
  int  ix;

  for(ix = 0; ix < count; ix++)
    dp[ix] = 0;
#else
  memset(dp, 0, count * sizeof(mp_digit));
#endif

} /* end s_mp_setz() */
#endif

/* }}} */

/* {{{ s_mp_copy(sp, dp, count) */

#if MP_MACRO == 0
/* Copy 'count' digits from sp to dp                                      */
void s_mp_copy(mp_digit *sp, mp_digit *dp, mp_size count)
{
#if MP_MEMCPY == 0
  int  ix;

  for(ix = 0; ix < count; ix++)
    dp[ix] = sp[ix];
#else
  memcpy(dp, sp, count * sizeof(mp_digit));
#endif

} /* end s_mp_copy() */
#endif

/* }}} */

/* {{{ s_mp_alloc(nb, ni) */

#if MP_MACRO == 0
/* Allocate ni records of nb bytes each, and return a pointer to that     */
void    *s_mp_alloc(size_t nb, size_t ni)
{
  return calloc(nb, ni);

} /* end s_mp_alloc() */
#endif

/* }}} */

/* {{{ s_mp_free(ptr) */

#if MP_MACRO == 0
/* Free the memory pointed to by ptr                                      */
void     s_mp_free(void *ptr)
{
  if(ptr)
    free(ptr);

} /* end s_mp_free() */
#endif

/* }}} */

/* {{{ s_mp_clamp(mp) */

/* Remove leading zeroes from the given value                             */
void     s_mp_clamp(mp_int *mp)
{
  mp_size   du = USED(mp);
  mp_digit *zp = DIGITS(mp) + du - 1;

  while(du > 1 && !*zp--)
    --du;

  USED(mp) = du;

} /* end s_mp_clamp() */


/* }}} */

/* {{{ s_mp_exch(a, b) */

/* Exchange the data for a and b; (b, a) = (a, b)                         */
void     s_mp_exch(mp_int *a, mp_int *b)
{
  mp_int   tmp;

  tmp = *a;
  *a = *b;
  *b = tmp;

} /* end s_mp_exch() */

/* }}} */

/* }}} */

/* {{{ Arithmetic helpers */

/* {{{ s_mp_lshd(mp, p) */

/* 
   Shift mp leftward by p digits, growing if needed, and zero-filling
   the in-shifted digits at the right end.  This is a convenient
   alternative to multiplication by powers of the radix
 */   

mp_err   s_mp_lshd(mp_int *mp, mp_size p)
{
  mp_err   res;
  mp_size  pos;
  mp_digit *dp;
  int     ix;

  if(p == 0)
    return MP_OKAY;

  if((res = s_mp_pad(mp, USED(mp) + p)) != MP_OKAY)
    return res;

  pos = USED(mp) - 1;
  dp = DIGITS(mp);

  /* Shift all the significant figures over as needed */
  for(ix = pos - p; ix >= 0; ix--) 
    dp[ix + p] = dp[ix];

  /* Fill the bottom digits with zeroes */
  for(ix = 0; ix < p; ix++)
    dp[ix] = 0;

  return MP_OKAY;

} /* end s_mp_lshd() */

/* }}} */

/* {{{ s_mp_rshd(mp, p) */

/* 
   Shift mp rightward by p digits.  Maintains the invariant that
   digits above the precision are all zero.  Digits shifted off the
   end are lost.  Cannot fail.
 */

void     s_mp_rshd(mp_int *mp, mp_size p)
{
  mp_size  ix;
  mp_digit *dp;

  if(p == 0)
    return;

  /* Shortcut when all digits are to be shifted off */
  if(p >= USED(mp)) {
    s_mp_setz(DIGITS(mp), ALLOC(mp));
    USED(mp) = 1;
    SIGN(mp) = MP_ZPOS;
    return;
  }

  /* Shift all the significant figures over as needed */
  dp = DIGITS(mp);
  for(ix = p; ix < USED(mp); ix++)
    dp[ix - p] = dp[ix];

  /* Fill the top digits with zeroes */
  ix -= p;
  while(ix < USED(mp))
    dp[ix++] = 0;

  /* Strip off any leading zeroes    */
  s_mp_clamp(mp);

} /* end s_mp_rshd() */

/* }}} */

/* {{{ s_mp_div_2(mp) */

/* Divide by two -- take advantage of radix properties to do it fast      */
void     s_mp_div_2(mp_int *mp)
{
  s_mp_div_2d(mp, 1);

} /* end s_mp_div_2() */

/* }}} */

/* {{{ s_mp_mul_2(mp) */

mp_err s_mp_mul_2(mp_int *mp)
{
  int      ix;
  mp_digit kin = 0, kout, *dp = DIGITS(mp);
  mp_err   res;

  /* Shift digits leftward by 1 bit */
  for(ix = 0; ix < USED(mp); ix++) {
    kout = (dp[ix] >> (DIGIT_BIT - 1)) & 1;
    dp[ix] = (dp[ix] << 1) | kin;

    kin = kout;
  }

  /* Deal with rollover from last digit */
  if(kin) {
    if(ix >= ALLOC(mp)) {
      if((res = s_mp_grow(mp, ALLOC(mp) + 1)) != MP_OKAY)
	return res;
      dp = DIGITS(mp);
    }

    dp[ix] = kin;
    USED(mp) += 1;
  }

  return MP_OKAY;

} /* end s_mp_mul_2() */

/* }}} */

/* {{{ s_mp_mod_2d(mp, d) */

/*
  Remainder the integer by 2^d, where d is a number of bits.  This
  amounts to a bitwise AND of the value, and does not require the full
  division code
 */
void     s_mp_mod_2d(mp_int *mp, mp_digit d)
{
  unsigned int  ndig = (d / DIGIT_BIT), nbit = (d % DIGIT_BIT);
  unsigned int  ix;
  mp_digit      dmask, *dp = DIGITS(mp);

  if(ndig >= USED(mp))
    return;

  /* Flush all the bits above 2^d in its digit */
  dmask = (1 << nbit) - 1;
  dp[ndig] &= dmask;

  /* Flush all digits above the one with 2^d in it */
  for(ix = ndig + 1; ix < USED(mp); ix++)
    dp[ix] = 0;

  s_mp_clamp(mp);

} /* end s_mp_mod_2d() */

/* }}} */

/* {{{ s_mp_mul_2d(mp, d) */

/*
  Multiply by the integer 2^d, where d is a number of bits.  This
  amounts to a bitwise shift of the value, and does not require the
  full multiplication code.
 */
mp_err    s_mp_mul_2d(mp_int *mp, mp_digit d)
{
  mp_err   res;
  mp_digit save, next, mask, *dp;
  mp_size  used;
  int      ix;

  if((res = s_mp_lshd(mp, d / DIGIT_BIT)) != MP_OKAY)
    return res;

  dp = DIGITS(mp); used = USED(mp);
  d %= DIGIT_BIT;

  mask = (1 << d) - 1;

  /* If the shift requires another digit, make sure we've got one to
     work with */
  if((dp[used - 1] >> (DIGIT_BIT - d)) & mask) {
    if((res = s_mp_grow(mp, used + 1)) != MP_OKAY)
      return res;
    dp = DIGITS(mp);
  }

  /* Do the shifting... */
  save = 0;
  for(ix = 0; ix < used; ix++) {
    next = (dp[ix] >> (DIGIT_BIT - d)) & mask;
    dp[ix] = (dp[ix] << d) | save;
    save = next;
  }

  /* If, at this point, we have a nonzero carryout into the next
     digit, we'll increase the size by one digit, and store it...
   */
  if(save) {
    dp[used] = save;
    USED(mp) += 1;
  }

  s_mp_clamp(mp);
  return MP_OKAY;

} /* end s_mp_mul_2d() */

/* }}} */

/* {{{ s_mp_div_2d(mp, d) */

/*
  Divide the integer by 2^d, where d is a number of bits.  This
  amounts to a bitwise shift of the value, and does not require the
  full division code (used in Barrett reduction, see below)
 */
void     s_mp_div_2d(mp_int *mp, mp_digit d)
{
  int       ix;
  mp_digit  save, next, mask, *dp = DIGITS(mp);

  s_mp_rshd(mp, d / DIGIT_BIT);
  d %= DIGIT_BIT;

  mask = (1 << d) - 1;

  save = 0;
  for(ix = USED(mp) - 1; ix >= 0; ix--) {
    next = dp[ix] & mask;
    dp[ix] = (dp[ix] >> d) | (save << (DIGIT_BIT - d));
    save = next;
  }

  s_mp_clamp(mp);

} /* end s_mp_div_2d() */

/* }}} */

/* {{{ s_mp_norm(a, b) */

/*
  s_mp_norm(a, b)

  Normalize a and b for division, where b is the divisor.  In order
  that we might make good guesses for quotient digits, we want the
  leading digit of b to be at least half the radix, which we
  accomplish by multiplying a and b by a constant.  This constant is
  returned (so that it can be divided back out of the remainder at the
  end of the division process).

  We multiply by the smallest power of 2 that gives us a leading digit
  at least half the radix.  By choosing a power of 2, we simplify the 
  multiplication and division steps to simple shifts.
 */
mp_digit s_mp_norm(mp_int *a, mp_int *b)
{
  mp_digit  t, d = 0;

  t = DIGIT(b, USED(b) - 1);
  while(t < (RADIX / 2)) {
    t <<= 1;
    ++d;
  }
    
  if(d != 0) {
    s_mp_mul_2d(a, d);
    s_mp_mul_2d(b, d);
  }

  return d;

} /* end s_mp_norm() */

/* }}} */

/* }}} */

/* {{{ Primitive digit arithmetic */

/* {{{ s_mp_add_d(mp, d) */

/* Add d to |mp| in place                                                 */
mp_err   s_mp_add_d(mp_int *mp, mp_digit d)    /* unsigned digit addition */
{
  mp_word   w, k = 0;
  mp_size   ix = 1, used = USED(mp);
  mp_digit *dp = DIGITS(mp);

  w = dp[0] + d;
  dp[0] = ACCUM(w);
  k = CARRYOUT(w);

  while(ix < used && k) {
    w = dp[ix] + k;
    dp[ix] = ACCUM(w);
    k = CARRYOUT(w);
    ++ix;
  }

  if(k != 0) {
    mp_err  res;

    if((res = s_mp_pad(mp, USED(mp) + 1)) != MP_OKAY)
      return res;

    DIGIT(mp, ix) = k;
  }

  return MP_OKAY;

} /* end s_mp_add_d() */

/* }}} */

/* {{{ s_mp_sub_d(mp, d) */

/* Subtract d from |mp| in place, assumes |mp| > d                        */
mp_err   s_mp_sub_d(mp_int *mp, mp_digit d)    /* unsigned digit subtract */
{
  mp_word   w, b = 0;
  mp_size   ix = 1, used = USED(mp);
  mp_digit *dp = DIGITS(mp);

  /* Compute initial subtraction    */
  w = (RADIX + dp[0]) - d;
  b = CARRYOUT(w) ? 0 : 1;
  dp[0] = ACCUM(w);

  /* Propagate borrows leftward     */
  while(b && ix < used) {
    w = (RADIX + dp[ix]) - b;
    b = CARRYOUT(w) ? 0 : 1;
    dp[ix] = ACCUM(w);
    ++ix;
  }

  /* Remove leading zeroes          */
  s_mp_clamp(mp);

  /* If we have a borrow out, it's a violation of the input invariant */
  if(b)
    return MP_RANGE;
  else
    return MP_OKAY;

} /* end s_mp_sub_d() */

/* }}} */

/* {{{ s_mp_mul_d(a, d) */

/* Compute a = a * d, single digit multiplication                         */
mp_err   s_mp_mul_d(mp_int *a, mp_digit d)
{
  mp_word w, k = 0;
  mp_size ix, max;
  mp_err  res;
  mp_digit *dp = DIGITS(a);

  /*
    Single-digit multiplication will increase the precision of the
    output by at most one digit.  However, we can detect when this
    will happen -- if the high-order digit of a, times d, gives a
    two-digit result, then the precision of the result will increase;
    otherwise it won't.  We use this fact to avoid calling s_mp_pad()
    unless absolutely necessary.
   */
  max = USED(a);
  w = dp[max - 1] * d;
  if(CARRYOUT(w) != 0) {
    if((res = s_mp_pad(a, max + 1)) != MP_OKAY)
      return res;
    dp = DIGITS(a);
  }

  for(ix = 0; ix < max; ix++) {
    w = (dp[ix] * d) + k;
    dp[ix] = ACCUM(w);
    k = CARRYOUT(w);
  }

  /* If there is a precision increase, take care of it here; the above
     test guarantees we have enough storage to do this safely.
   */
  if(k) {
    dp[max] = k; 
    USED(a) = max + 1;
  }

  s_mp_clamp(a);

  return MP_OKAY;
  
} /* end s_mp_mul_d() */

/* }}} */

/* {{{ s_mp_div_d(mp, d, r) */

/*
  s_mp_div_d(mp, d, r)

  Compute the quotient mp = mp / d and remainder r = mp mod d, for a
  single digit d.  If r is null, the remainder will be discarded.
 */

mp_err   s_mp_div_d(mp_int *mp, mp_digit d, mp_digit *r)
{
  mp_word   w = 0, t;
  mp_int    quot;
  mp_err    res;
  mp_digit *dp = DIGITS(mp), *qp;
  int       ix;

  if(d == 0)
    return MP_RANGE;

  /* Make room for the quotient */
  if((res = mp_init_size(&quot, USED(mp))) != MP_OKAY)
    return res;

  USED(&quot) = USED(mp); /* so clamping will work below */
  qp = DIGITS(&quot);

  /* Divide without subtraction */
  for(ix = USED(mp) - 1; ix >= 0; ix--) {
    w = (w << DIGIT_BIT) | dp[ix];

    if(w >= d) {
      t = w / d;
      w = w % d;
    } else {
      t = 0;
    }

    qp[ix] = t;
  }

  /* Deliver the remainder, if desired */
  if(r)
    *r = w;

  s_mp_clamp(&quot);
  mp_exch(&quot, mp);
  mp_clear(&quot);

  return MP_OKAY;

} /* end s_mp_div_d() */

/* }}} */

/* }}} */

/* {{{ Primitive full arithmetic */

/* {{{ s_mp_add(a, b) */

/* Compute a = |a| + |b|                                                  */
mp_err   s_mp_add(mp_int *a, mp_int *b)        /* magnitude addition      */
{
  mp_word   w = 0;
  mp_digit *pa, *pb;
  mp_size   ix, used = USED(b);
  mp_err    res;

  /* Make sure a has enough precision for the output value */
  if((used > USED(a)) && (res = s_mp_pad(a, used)) != MP_OKAY)
    return res;

  /*
    Add up all digits up to the precision of b.  If b had initially
    the same precision as a, or greater, we took care of it by the
    padding step above, so there is no problem.  If b had initially
    less precision, we'll have to make sure the carry out is duly
    propagated upward among the higher-order digits of the sum.
   */
  pa = DIGITS(a);
  pb = DIGITS(b);
  for(ix = 0; ix < used; ++ix) {
    w += *pa + *pb++;
    *pa++ = ACCUM(w);
    w = CARRYOUT(w);
  }

  /* If we run out of 'b' digits before we're actually done, make
     sure the carries get propagated upward...  
   */
  used = USED(a);
  while(w && ix < used) {
    w += *pa;
    *pa++ = ACCUM(w);
    w = CARRYOUT(w);
    ++ix;
  }

  /* If there's an overall carry out, increase precision and include
     it.  We could have done this initially, but why touch the memory
     allocator unless we're sure we have to?
   */
  if(w) {
    if((res = s_mp_pad(a, used + 1)) != MP_OKAY)
      return res;

    DIGIT(a, ix) = w;  /* pa may not be valid after s_mp_pad() call */
  }

  return MP_OKAY;

} /* end s_mp_add() */

/* }}} */

/* {{{ s_mp_sub(a, b) */

/* Compute a = |a| - |b|, assumes |a| >= |b|                              */
mp_err   s_mp_sub(mp_int *a, mp_int *b)        /* magnitude subtract      */
{
  mp_word   w = 0;
  mp_digit *pa, *pb;
  mp_size   ix, used = USED(b);

  /*
    Subtract and propagate borrow.  Up to the precision of b, this
    accounts for the digits of b; after that, we just make sure the
    carries get to the right place.  This saves having to pad b out to
    the precision of a just to make the loops work right...
   */
  pa = DIGITS(a);
  pb = DIGITS(b);

  for(ix = 0; ix < used; ++ix) {
    w = (RADIX + *pa) - w - *pb++;
    *pa++ = ACCUM(w);
    w = CARRYOUT(w) ? 0 : 1;
  }

  used = USED(a);
  while(ix < used) {
    w = RADIX + *pa - w;
    *pa++ = ACCUM(w);
    w = CARRYOUT(w) ? 0 : 1;
    ++ix;
  }

  /* Clobber any leading zeroes we created    */
  s_mp_clamp(a);

  /* 
     If there was a borrow out, then |b| > |a| in violation
     of our input invariant.  We've already done the work,
     but we'll at least complain about it...
   */
  if(w)
    return MP_RANGE;
  else
    return MP_OKAY;

} /* end s_mp_sub() */

/* }}} */

mp_err   s_mp_reduce(mp_int *x, mp_int *m, mp_int *mu)
{
  mp_int   q;
  mp_err   res;
  mp_size  um = USED(m);

  if((res = mp_init_copy(&q, x)) != MP_OKAY)
    return res;

  s_mp_rshd(&q, um - 1);       /* q1 = x / b^(k-1)  */
  s_mp_mul(&q, mu);            /* q2 = q1 * mu      */
  s_mp_rshd(&q, um + 1);       /* q3 = q2 / b^(k+1) */

  /* x = x mod b^(k+1), quick (no division) */
  s_mp_mod_2d(x, (mp_digit)(DIGIT_BIT * (um + 1)));

  /* q = q * m mod b^(k+1), quick (no division), uses the short multiplier */
#ifndef SHRT_MUL
  s_mp_mul(&q, m);
  s_mp_mod_2d(&q, (mp_digit)(DIGIT_BIT * (um + 1)));
#else
  s_mp_mul_dig(&q, m, um + 1);
#endif  

  /* x = x - q */
  if((res = mp_sub(x, &q, x)) != MP_OKAY)
    goto CLEANUP;

  /* If x < 0, add b^(k+1) to it */
  if(mp_cmp_z(x) < 0) {
    mp_set(&q, 1);
    if((res = s_mp_lshd(&q, um + 1)) != MP_OKAY)
      goto CLEANUP;
    if((res = mp_add(x, &q, x)) != MP_OKAY)
      goto CLEANUP;
  }

  /* Back off if it's too big */
  while(mp_cmp(x, m) >= 0) {
    if((res = s_mp_sub(x, m)) != MP_OKAY)
      break;
  }

 CLEANUP:
  mp_clear(&q);

  return res;

} /* end s_mp_reduce() */



/* {{{ s_mp_mul(a, b) */

/* Compute a = |a| * |b|                                                  */
mp_err   s_mp_mul(mp_int *a, mp_int *b)
{
  mp_word   w, k = 0;
  mp_int    tmp;
  mp_err    res;
  mp_size   ix, jx, ua = USED(a), ub = USED(b);
  mp_digit *pa, *pb, *pt, *pbt;

  if((res = mp_init_size(&tmp, ua + ub)) != MP_OKAY)
    return res;

  /* This has the effect of left-padding with zeroes... */
  USED(&tmp) = ua + ub;

  /* We're going to need the base value each iteration */
  pbt = DIGITS(&tmp);

  /* Outer loop:  Digits of b */

  pb = DIGITS(b);
  for(ix = 0; ix < ub; ++ix, ++pb) {
    if(*pb == 0) 
      continue;

    /* Inner product:  Digits of a */
    pa = DIGITS(a);
    for(jx = 0; jx < ua; ++jx, ++pa) {
      pt = pbt + ix + jx;
      w = *pb * *pa + k + *pt;
      *pt = ACCUM(w);
      k = CARRYOUT(w);
    }

    pbt[ix + jx] = k;
    k = 0;
  }

  s_mp_clamp(&tmp);
  s_mp_exch(&tmp, a);

  mp_clear(&tmp);

  return MP_OKAY;

} /* end s_mp_mul() */

/* }}} */

/* {{{ s_mp_kmul(a, b, out, len) */

#if 0
void   s_mp_kmul(mp_digit *a, mp_digit *b, mp_digit *out, mp_size len)
{
  mp_word   w, k = 0;
  mp_size   ix, jx;
  mp_digit *pa, *pt;

  for(ix = 0; ix < len; ++ix, ++b) {
    if(*b == 0)
      continue;
    
    pa = a;
    for(jx = 0; jx < len; ++jx, ++pa) {
      pt = out + ix + jx;
      w = *b * *pa + k + *pt;
      *pt = ACCUM(w);
      k = CARRYOUT(w);
    }

    out[ix + jx] = k;
    k = 0;
  }

} /* end s_mp_kmul() */
#endif

/* }}} */

/* {{{ s_mp_sqr(a) */

/*
  Computes the square of a, in place.  This can be done more
  efficiently than a general multiplication, because many of the
  computation steps are redundant when squaring.  The inner product
  step is a bit more complicated, but we save a fair number of
  iterations of the multiplication loop.
 */
#if MP_SQUARE
mp_err   s_mp_sqr(mp_int *a)
{
  mp_word  w, k = 0;
  mp_int   tmp;
  mp_err   res;
  mp_size  ix, jx, kx, used = USED(a);
  mp_digit *pa1, *pa2, *pt, *pbt;

  if((res = mp_init_size(&tmp, 2 * used)) != MP_OKAY)
    return res;

  /* Left-pad with zeroes */
  USED(&tmp) = 2 * used;

  /* We need the base value each time through the loop */
  pbt = DIGITS(&tmp);

  pa1 = DIGITS(a);
  for(ix = 0; ix < used; ++ix, ++pa1) {
    if(*pa1 == 0)
      continue;

    w = DIGIT(&tmp, ix + ix) + (*pa1 * *pa1);

    pbt[ix + ix] = ACCUM(w);
    k = CARRYOUT(w);

    /*
      The inner product is computed as:

         (C, S) = t[i,j] + 2 a[i] a[j] + C

      This can overflow what can be represented in an mp_word, and
      since C arithmetic does not provide any way to check for
      overflow, we have to check explicitly for overflow conditions
      before they happen.
     */
    for(jx = ix + 1, pa2 = DIGITS(a) + jx; jx < used; ++jx, ++pa2) {
      mp_word  u = 0, v;
      
      /* Store this in a temporary to avoid indirections later */
      pt = pbt + ix + jx;

      /* Compute the multiplicative step */
      w = *pa1 * *pa2;

      /* If w is more than half MP_WORD_MAX, the doubling will
	 overflow, and we need to record a carry out into the next
	 word */
      u = (w >> (MP_WORD_BIT - 1)) & 1;

      /* Double what we've got, overflow will be ignored as defined
	 for C arithmetic (we've already noted if it is to occur)
       */
      w *= 2;

      /* Compute the additive step */
      v = *pt + k;

      /* If we do not already have an overflow carry, check to see
	 if the addition will cause one, and set the carry out if so 
       */
      u |= ((MP_WORD_MAX - v) < w);

      /* Add in the rest, again ignoring overflow */
      w += v;

      /* Set the i,j digit of the output */
      *pt = ACCUM(w);

      /* Save carry information for the next iteration of the loop.
	 This is why k must be an mp_word, instead of an mp_digit */
      k = CARRYOUT(w) | (u << DIGIT_BIT);

    } /* for(jx ...) */

    /* Set the last digit in the cycle and reset the carry */
    k = DIGIT(&tmp, ix + jx) + k;
    pbt[ix + jx] = ACCUM(k);
    k = CARRYOUT(k);

    /* If we are carrying out, propagate the carry to the next digit
       in the output.  This may cascade, so we have to be somewhat
       circumspect -- but we will have enough precision in the output
       that we won't overflow 
     */
    kx = 1;
    while(k) {
      k = pbt[ix + jx + kx] + 1;
      pbt[ix + jx + kx] = ACCUM(k);
      k = CARRYOUT(k);
      ++kx;
    }
  } /* for(ix ...) */

  s_mp_clamp(&tmp);
  s_mp_exch(&tmp, a);

  mp_clear(&tmp);

  return MP_OKAY;

} /* end s_mp_sqr() */
#endif

/* }}} */

/* {{{ s_mp_div(a, b) */

/*
  s_mp_div(a, b)

  Compute a = a / b and b = a mod b.  Assumes b > a.
 */

mp_err   s_mp_div(mp_int *a, mp_int *b)
{
  mp_int   quot, rem, t;
  mp_word  q;
  mp_err   res;
  mp_digit d;
  int      ix;

  if(mp_cmp_z(b) == 0)
    return MP_RANGE;

  /* Shortcut if b is power of two */
  if((ix = s_mp_ispow2(b)) >= 0) {
    mp_copy(a, b);  /* need this for remainder */
    s_mp_div_2d(a, (mp_digit)ix);
    s_mp_mod_2d(b, (mp_digit)ix);

    return MP_OKAY;
  }

  /* Allocate space to store the quotient */
  if((res = mp_init_size(&quot, USED(a))) != MP_OKAY)
    return res;

  /* A working temporary for division     */
  if((res = mp_init_size(&t, USED(a))) != MP_OKAY)
    goto T;

  /* Allocate space for the remainder     */
  if((res = mp_init_size(&rem, USED(a))) != MP_OKAY)
    goto REM;

  /* Normalize to optimize guessing       */
  d = s_mp_norm(a, b);

  /* Perform the division itself...woo!   */
  ix = USED(a) - 1;

  while(ix >= 0) {
    /* Find a partial substring of a which is at least b */
    while(s_mp_cmp(&rem, b) < 0 && ix >= 0) {
      if((res = s_mp_lshd(&rem, 1)) != MP_OKAY) 
	goto CLEANUP;

      if((res = s_mp_lshd(&quot, 1)) != MP_OKAY)
	goto CLEANUP;

      DIGIT(&rem, 0) = DIGIT(a, ix);
      s_mp_clamp(&rem);
      --ix;
    }

    /* If we didn't find one, we're finished dividing    */
    if(s_mp_cmp(&rem, b) < 0) 
      break;    

    /* Compute a guess for the next quotient digit       */
    q = DIGIT(&rem, USED(&rem) - 1);
    if(q <= DIGIT(b, USED(b) - 1) && USED(&rem) > 1)
      q = (q << DIGIT_BIT) | DIGIT(&rem, USED(&rem) - 2);

    q /= DIGIT(b, USED(b) - 1);

    /* The guess can be as much as RADIX + 1 */
    if(q >= RADIX)
      q = RADIX - 1;

    /* See what that multiplies out to                   */
    mp_copy(b, &t);
    if((res = s_mp_mul_d(&t, q)) != MP_OKAY)
      goto CLEANUP;

    /* 
       If it's too big, back it off.  We should not have to do this
       more than once, or, in rare cases, twice.  Knuth describes a
       method by which this could be reduced to a maximum of once, but
       I didn't implement that here.
     */
    while(s_mp_cmp(&t, &rem) > 0) {
      --q;
      s_mp_sub(&t, b);
    }

    /* At this point, q should be the right next digit   */
    if((res = s_mp_sub(&rem, &t)) != MP_OKAY)
      goto CLEANUP;

    /*
      Include the digit in the quotient.  We allocated enough memory
      for any quotient we could ever possibly get, so we should not
      have to check for failures here
     */
    DIGIT(&quot, 0) = q;
  }

  /* Denormalize remainder                */
  if(d != 0) 
    s_mp_div_2d(&rem, d);

  s_mp_clamp(&quot);
  s_mp_clamp(&rem);

  /* Copy quotient back to output         */
  s_mp_exch(&quot, a);
  
  /* Copy remainder back to output        */
  s_mp_exch(&rem, b);

CLEANUP:
  mp_clear(&rem);
REM:
  mp_clear(&t);
T:
  mp_clear(&quot);

  return res;

} /* end s_mp_div() */

/* }}} */

/* {{{ s_mp_2expt(a, k) */

mp_err   s_mp_2expt(mp_int *a, mp_digit k)
{
  mp_err    res;
  mp_size   dig, bit;

  dig = k / DIGIT_BIT;
  bit = k % DIGIT_BIT;

  mp_zero(a);
  if((res = s_mp_pad(a, dig + 1)) != MP_OKAY)
    return res;
  
  DIGIT(a, dig) |= (1 << bit);

  return MP_OKAY;

} /* end s_mp_2expt() */

/* }}} */


/* }}} */

/* }}} */

/* {{{ Primitive comparisons */

/* {{{ s_mp_cmp(a, b) */

/* Compare |a| <=> |b|, return 0 if equal, <0 if a<b, >0 if a>b           */
int      s_mp_cmp(mp_int *a, mp_int *b)
{
  mp_size   ua = USED(a), ub = USED(b);

  if(ua > ub)
    return MP_GT;
  else if(ua < ub)
    return MP_LT;
  else {
    int      ix = ua - 1;
    mp_digit *ap = DIGITS(a) + ix, *bp = DIGITS(b) + ix;

    while(ix >= 0) {
      if(*ap > *bp)
	return MP_GT;
      else if(*ap < *bp)
	return MP_LT;

      --ap; --bp; --ix;
    }

    return MP_EQ;
  }

} /* end s_mp_cmp() */

/* }}} */

/* {{{ s_mp_cmp_d(a, d) */

/* Compare |a| <=> d, return 0 if equal, <0 if a<d, >0 if a>d             */
int      s_mp_cmp_d(mp_int *a, mp_digit d)
{
  mp_size  ua = USED(a);
  mp_digit *ap = DIGITS(a);

  if(ua > 1)
    return MP_GT;

  if(*ap < d) 
    return MP_LT;
  else if(*ap > d)
    return MP_GT;
  else
    return MP_EQ;

} /* end s_mp_cmp_d() */

/* }}} */

/* {{{ s_mp_ispow2(v) */

/*
  Returns -1 if the value is not a power of two; otherwise, it returns
  k such that v = 2^k, i.e. lg(v).
 */
int      s_mp_ispow2(mp_int *v)
{
  mp_digit d, *dp;
  mp_size  uv = USED(v);
  int      extra = 0, ix;

  d = DIGIT(v, uv - 1); /* most significant digit of v */

  while(d && ((d & 1) == 0)) {
    d >>= 1;
    ++extra;
  }

  if(d == 1) {
    ix = uv - 2;
    dp = DIGITS(v) + ix;

    while(ix >= 0) {
      if(*dp)
	return -1; /* not a power of two */

      --dp; --ix;
    }

    return ((uv - 1) * DIGIT_BIT) + extra;
  } 

  return -1;

} /* end s_mp_ispow2() */

/* }}} */

/* {{{ s_mp_ispow2d(d) */

int      s_mp_ispow2d(mp_digit d)
{
  int   pow = 0;

  while((d & 1) == 0) {
    ++pow; d >>= 1;
  }

  if(d == 1)
    return pow;

  return -1;

} /* end s_mp_ispow2d() */

/* }}} */

/* }}} */

/* {{{ Primitive I/O helpers */

/* {{{ s_mp_tovalue(ch, r) */

/*
  Convert the given character to its digit value, in the given radix.
  If the given character is not understood in the given radix, -1 is
  returned.  Otherwise the digit's numeric value is returned.

  The results will be odd if you use a radix < 2 or > 62, you are
  expected to know what you're up to.
 */
int      s_mp_tovalue(char ch, int r)
{
  int    val, xch;
  
  if(r > 36)
    xch = ch;
  else
    xch = toupper(ch);

  if(isdigit(xch))
    val = xch - '0';
  else if(isupper(xch))
    val = xch - 'A' + 10;
  else if(islower(xch))
    val = xch - 'a' + 36;
  else if(xch == '+')
    val = 62;
  else if(xch == '/')
    val = 63;
  else 
    return -1;

  if(val < 0 || val >= r)
    return -1;

  return val;

} /* end s_mp_tovalue() */

/* }}} */

/* {{{ s_mp_todigit(val, r, low) */

/*
  Convert val to a radix-r digit, if possible.  If val is out of range
  for r, returns zero.  Otherwise, returns an ASCII character denoting
  the value in the given radix.

  The results may be odd if you use a radix < 2 or > 64, you are
  expected to know what you're doing.
 */
  
char     s_mp_todigit(int val, int r, int low)
{
  char   ch;

  if(val < 0 || val >= r)
    return 0;

  ch = s_dmap_1[val];

  if(r <= 36 && low)
    ch = tolower(ch);

  return ch;

} /* end s_mp_todigit() */

/* }}} */

/* {{{ s_mp_outlen(bits, radix) */

/* 
   Return an estimate for how long a string is needed to hold a radix
   r representation of a number with 'bits' significant bits.

   Does not include space for a sign or a NUL terminator.
 */
int      s_mp_outlen(int bits, int r)
{
  return (int)((double)bits * LOG_V_2(r));

} /* end s_mp_outlen() */

/* }}} */

/* }}} */

/*------------------------------------------------------------------------*/
/* HERE THERE BE DRAGONS                                                  */
/* crc==4242132123, version==2, Sat Feb 02 06:43:52 2002 */

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/mtest/mpi.h.















































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
/*
    mpi.h

    by Michael J. Fromberger <[email protected]>
    Copyright (C) 1998 Michael J. Fromberger, All Rights Reserved

    Arbitrary precision integer arithmetic library

    $Id: mpi.h,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $
 */

#ifndef _H_MPI_
#define _H_MPI_

#include "mpi-config.h"

#define  MP_LT       -1
#define  MP_EQ        0
#define  MP_GT        1

#if MP_DEBUG
#undef MP_IOFUNC
#define MP_IOFUNC 1
#endif

#if MP_IOFUNC
#include <stdio.h>
#include <ctype.h>
#endif

#include <limits.h>

#define  MP_NEG  1
#define  MP_ZPOS 0

/* Included for compatibility... */
#define  NEG     MP_NEG
#define  ZPOS    MP_ZPOS

#define  MP_OKAY          0 /* no error, all is well */
#define  MP_YES           0 /* yes (boolean result)  */
#define  MP_NO           -1 /* no (boolean result)   */
#define  MP_MEM          -2 /* out of memory         */
#define  MP_RANGE        -3 /* argument out of range */
#define  MP_BADARG       -4 /* invalid parameter     */
#define  MP_UNDEF        -5 /* answer is undefined   */
#define  MP_LAST_CODE    MP_UNDEF

#include "mpi-types.h"

/* Included for compatibility... */
#define DIGIT_BIT         MP_DIGIT_BIT
#define DIGIT_MAX         MP_DIGIT_MAX

/* Macros for accessing the mp_int internals           */
#define  SIGN(MP)     ((MP)->sign)
#define  USED(MP)     ((MP)->used)
#define  ALLOC(MP)    ((MP)->alloc)
#define  DIGITS(MP)   ((MP)->dp)
#define  DIGIT(MP,N)  (MP)->dp[(N)]

#if MP_ARGCHK == 1
#define  ARGCHK(X,Y)  {if(!(X)){return (Y);}}
#elif MP_ARGCHK == 2
#include <assert.h>
#define  ARGCHK(X,Y)  assert(X)
#else
#define  ARGCHK(X,Y)  /*  */
#endif

/* This defines the maximum I/O base (minimum is 2)   */
#define MAX_RADIX         64

typedef struct {
  mp_sign       sign;    /* sign of this quantity      */
  mp_size       alloc;   /* how many digits allocated  */
  mp_size       used;    /* how many digits used       */
  mp_digit     *dp;      /* the digits themselves      */
} mp_int;

/*------------------------------------------------------------------------*/
/* Default precision                                                      */

unsigned int mp_get_prec(void);
void         mp_set_prec(unsigned int prec);

/*------------------------------------------------------------------------*/
/* Memory management                                                      */

mp_err mp_init(mp_int *mp);
mp_err mp_init_array(mp_int mp[], int count);
mp_err mp_init_size(mp_int *mp, mp_size prec);
mp_err mp_init_copy(mp_int *mp, mp_int *from);
mp_err mp_copy(mp_int *from, mp_int *to);
void   mp_exch(mp_int *mp1, mp_int *mp2);
void   mp_clear(mp_int *mp);
void   mp_clear_array(mp_int mp[], int count);
void   mp_zero(mp_int *mp);
void   mp_set(mp_int *mp, mp_digit d);
mp_err mp_set_int(mp_int *mp, long z);
mp_err mp_shrink(mp_int *a);


/*------------------------------------------------------------------------*/
/* Single digit arithmetic                                                */

mp_err mp_add_d(mp_int *a, mp_digit d, mp_int *b);
mp_err mp_sub_d(mp_int *a, mp_digit d, mp_int *b);
mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b);
mp_err mp_mul_2(mp_int *a, mp_int *c);
mp_err mp_div_d(mp_int *a, mp_digit d, mp_int *q, mp_digit *r);
mp_err mp_div_2(mp_int *a, mp_int *c);
mp_err mp_expt_d(mp_int *a, mp_digit d, mp_int *c);

/*------------------------------------------------------------------------*/
/* Sign manipulations                                                     */

mp_err mp_abs(mp_int *a, mp_int *b);
mp_err mp_neg(mp_int *a, mp_int *b);

/*------------------------------------------------------------------------*/
/* Full arithmetic                                                        */

mp_err mp_add(mp_int *a, mp_int *b, mp_int *c);
mp_err mp_sub(mp_int *a, mp_int *b, mp_int *c);
mp_err mp_mul(mp_int *a, mp_int *b, mp_int *c);
mp_err mp_mul_2d(mp_int *a, mp_digit d, mp_int *c);
#if MP_SQUARE
mp_err mp_sqr(mp_int *a, mp_int *b);
#else
#define mp_sqr(a, b) mp_mul(a, a, b)
#endif
mp_err mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r);
mp_err mp_div_2d(mp_int *a, mp_digit d, mp_int *q, mp_int *r);
mp_err mp_expt(mp_int *a, mp_int *b, mp_int *c);
mp_err mp_2expt(mp_int *a, mp_digit k);
mp_err mp_sqrt(mp_int *a, mp_int *b);

/*------------------------------------------------------------------------*/
/* Modular arithmetic                                                     */

#if MP_MODARITH
mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c);
mp_err mp_mod_d(mp_int *a, mp_digit d, mp_digit *c);
mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c);
mp_err mp_submod(mp_int *a, mp_int *b, mp_int *m, mp_int *c);
mp_err mp_mulmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c);
#if MP_SQUARE
mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c);
#else
#define mp_sqrmod(a, m, c) mp_mulmod(a, a, m, c)
#endif
mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c);
mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c);
#endif /* MP_MODARITH */

/*------------------------------------------------------------------------*/
/* Comparisons                                                            */

int    mp_cmp_z(mp_int *a);
int    mp_cmp_d(mp_int *a, mp_digit d);
int    mp_cmp(mp_int *a, mp_int *b);
int    mp_cmp_mag(mp_int *a, mp_int *b);
int    mp_cmp_int(mp_int *a, long z);
int    mp_isodd(mp_int *a);
int    mp_iseven(mp_int *a);

/*------------------------------------------------------------------------*/
/* Number theoretic                                                       */

#if MP_NUMTH
mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c);
mp_err mp_lcm(mp_int *a, mp_int *b, mp_int *c);
mp_err mp_xgcd(mp_int *a, mp_int *b, mp_int *g, mp_int *x, mp_int *y);
mp_err mp_invmod(mp_int *a, mp_int *m, mp_int *c);
#endif /* end MP_NUMTH */

/*------------------------------------------------------------------------*/
/* Input and output                                                       */

#if MP_IOFUNC
void   mp_print(mp_int *mp, FILE *ofp);
#endif /* end MP_IOFUNC */

/*------------------------------------------------------------------------*/
/* Base conversion                                                        */

#define BITS     1
#define BYTES    CHAR_BIT

mp_err mp_read_signed_bin(mp_int *mp, unsigned char *str, int len);
int    mp_signed_bin_size(mp_int *mp);
mp_err mp_to_signed_bin(mp_int *mp, unsigned char *str);

mp_err mp_read_unsigned_bin(mp_int *mp, unsigned char *str, int len);
int    mp_unsigned_bin_size(mp_int *mp);
mp_err mp_to_unsigned_bin(mp_int *mp, unsigned char *str);

int    mp_count_bits(mp_int *mp);

#if MP_COMPAT_MACROS
#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len))
#define mp_raw_size(mp)           mp_signed_bin_size(mp)
#define mp_toraw(mp, str)         mp_to_signed_bin((mp), (str))
#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len))
#define mp_mag_size(mp)           mp_unsigned_bin_size(mp)
#define mp_tomag(mp, str)         mp_to_unsigned_bin((mp), (str))
#endif

mp_err mp_read_radix(mp_int *mp, unsigned char *str, int radix);
int    mp_radix_size(mp_int *mp, int radix);
int    mp_value_radix_size(int num, int qty, int radix);
mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix);

int    mp_char2value(char ch, int r);

#define mp_tobinary(M, S)  mp_toradix((M), (S), 2)
#define mp_tooctal(M, S)   mp_toradix((M), (S), 8)
#define mp_todecimal(M, S) mp_toradix((M), (S), 10)
#define mp_tohex(M, S)     mp_toradix((M), (S), 16)

/*------------------------------------------------------------------------*/
/* Error strings                                                          */

const  char  *mp_strerror(mp_err ec);

#endif /* end _H_MPI_ */

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.h,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/mtest/mtest.c.









































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
/* makes a bignum test harness with NUM tests per operation
 *
 * the output is made in the following format [one parameter per line]

operation
operand1
operand2
[... operandN]
result1
result2
[... resultN]

So for example "a * b mod n" would be

mulmod
a
b
n
a*b mod n

e.g. if a=3, b=4 n=11 then

mulmod
3
4
11
1

 */

#ifdef MP_8BIT
#define THE_MASK 127
#else
#define THE_MASK 32767
#endif

#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include "mpi.c"

FILE *rng;

void rand_num(mp_int *a)
{
   int n, size;
   unsigned char buf[2048];

   size = 1 + ((fgetc(rng)<<8) + fgetc(rng)) % 101;
   buf[0] = (fgetc(rng)&1)?1:0;
   fread(buf+1, 1, size, rng);
   while (buf[1] == 0) buf[1] = fgetc(rng);
   mp_read_raw(a, buf, 1+size);
}

void rand_num2(mp_int *a)
{
   int n, size;
   unsigned char buf[2048];

   size = 10 + ((fgetc(rng)<<8) + fgetc(rng)) % 101;
   buf[0] = (fgetc(rng)&1)?1:0;
   fread(buf+1, 1, size, rng);
   while (buf[1] == 0) buf[1] = fgetc(rng);
   mp_read_raw(a, buf, 1+size);
}

#define mp_to64(a, b) mp_toradix(a, b, 64)

int main(void)
{
   int n, tmp;
   mp_int a, b, c, d, e;
   clock_t t1;
   char buf[4096];

   mp_init(&a);
   mp_init(&b);
   mp_init(&c);
   mp_init(&d);
   mp_init(&e);


   /* initial (2^n - 1)^2 testing, makes sure the comba multiplier works [it has the new carry code] */
/*
   mp_set(&a, 1);
   for (n = 1; n < 8192; n++) {
       mp_mul(&a, &a, &c);
       printf("mul\n");
       mp_to64(&a, buf);
       printf("%s\n%s\n", buf, buf);
       mp_to64(&c, buf);
       printf("%s\n", buf);

       mp_add_d(&a, 1, &a);
       mp_mul_2(&a, &a);
       mp_sub_d(&a, 1, &a);
   }
*/

   rng = fopen("/dev/urandom", "rb");
   if (rng == NULL) {
      rng = fopen("/dev/random", "rb");
      if (rng == NULL) {
         fprintf(stderr, "\nWarning:  stdin used as random source\n\n");
         rng = stdin;
      }
   }

   t1 = clock();
   for (;;) {
#if 0
      if (clock() - t1 > CLOCKS_PER_SEC) {
         sleep(2);
         t1 = clock();
      }
#endif
       n = fgetc(rng) % 15;

   if (n == 0) {
       /* add tests */
       rand_num(&a);
       rand_num(&b);
       mp_add(&a, &b, &c);
       printf("add\n");
       mp_to64(&a, buf);
       printf("%s\n", buf);
       mp_to64(&b, buf);
       printf("%s\n", buf);
       mp_to64(&c, buf);
       printf("%s\n", buf);
   } else if (n == 1) {
      /* sub tests */
       rand_num(&a);
       rand_num(&b);
       mp_sub(&a, &b, &c);
       printf("sub\n");
       mp_to64(&a, buf);
       printf("%s\n", buf);
       mp_to64(&b, buf);
       printf("%s\n", buf);
       mp_to64(&c, buf);
       printf("%s\n", buf);
   } else if (n == 2) {
       /* mul tests */
       rand_num(&a);
       rand_num(&b);
       mp_mul(&a, &b, &c);
       printf("mul\n");
       mp_to64(&a, buf);
       printf("%s\n", buf);
       mp_to64(&b, buf);
       printf("%s\n", buf);
       mp_to64(&c, buf);
       printf("%s\n", buf);
   } else if (n == 3) {
      /* div tests */
       rand_num(&a);
       rand_num(&b);
       mp_div(&a, &b, &c, &d);
       printf("div\n");
       mp_to64(&a, buf);
       printf("%s\n", buf);
       mp_to64(&b, buf);
       printf("%s\n", buf);
       mp_to64(&c, buf);
       printf("%s\n", buf);
       mp_to64(&d, buf);
       printf("%s\n", buf);
   } else if (n == 4) {
      /* sqr tests */
       rand_num(&a);
       mp_sqr(&a, &b);
       printf("sqr\n");
       mp_to64(&a, buf);
       printf("%s\n", buf);
       mp_to64(&b, buf);
       printf("%s\n", buf);
   } else if (n == 5) {
      /* mul_2d test */
      rand_num(&a);
      mp_copy(&a, &b);
      n = fgetc(rng) & 63;
      mp_mul_2d(&b, n, &b);
      mp_to64(&a, buf);
      printf("mul2d\n");
      printf("%s\n", buf);
      printf("%d\n", n);
      mp_to64(&b, buf);
      printf("%s\n", buf);
   } else if (n == 6) {
      /* div_2d test */
      rand_num(&a);
      mp_copy(&a, &b);
      n = fgetc(rng) & 63;
      mp_div_2d(&b, n, &b, NULL);
      mp_to64(&a, buf);
      printf("div2d\n");
      printf("%s\n", buf);
      printf("%d\n", n);
      mp_to64(&b, buf);
      printf("%s\n", buf);
   } else if (n == 7) {
      /* gcd test */
      rand_num(&a);
      rand_num(&b);
      a.sign = MP_ZPOS;
      b.sign = MP_ZPOS;
      mp_gcd(&a, &b, &c);
      printf("gcd\n");
      mp_to64(&a, buf);
      printf("%s\n", buf);
      mp_to64(&b, buf);
      printf("%s\n", buf);
      mp_to64(&c, buf);
      printf("%s\n", buf);
   } else if (n == 8) {
      /* lcm test */
      rand_num(&a);
      rand_num(&b);
      a.sign = MP_ZPOS;
      b.sign = MP_ZPOS;
      mp_lcm(&a, &b, &c);
      printf("lcm\n");
      mp_to64(&a, buf);
      printf("%s\n", buf);
      mp_to64(&b, buf);
      printf("%s\n", buf);
      mp_to64(&c, buf);
      printf("%s\n", buf);
   } else if (n == 9) {
      /* exptmod test */
      rand_num2(&a);
      rand_num2(&b);
      rand_num2(&c);
//      if (c.dp[0]&1) mp_add_d(&c, 1, &c);
      a.sign = b.sign = c.sign = 0;
      mp_exptmod(&a, &b, &c, &d);
      printf("expt\n");
      mp_to64(&a, buf);
      printf("%s\n", buf);
      mp_to64(&b, buf);
      printf("%s\n", buf);
      mp_to64(&c, buf);
      printf("%s\n", buf);
      mp_to64(&d, buf);
      printf("%s\n", buf);
   } else if (n == 10) {
      /* invmod test */
      rand_num2(&a);
      rand_num2(&b);
      b.sign = MP_ZPOS;
      a.sign = MP_ZPOS;
      mp_gcd(&a, &b, &c);
      if (mp_cmp_d(&c, 1) != 0) continue;
      if (mp_cmp_d(&b, 1) == 0) continue;
      mp_invmod(&a, &b, &c);
      printf("invmod\n");
      mp_to64(&a, buf);
      printf("%s\n", buf);
      mp_to64(&b, buf);
      printf("%s\n", buf);
      mp_to64(&c, buf);
      printf("%s\n", buf);
   } else if (n == 11) {
      rand_num(&a);
      mp_mul_2(&a, &a);
      mp_div_2(&a, &b);
      printf("div2\n");
      mp_to64(&a, buf);
      printf("%s\n", buf);
      mp_to64(&b, buf);
      printf("%s\n", buf);
   } else if (n == 12) {
      rand_num2(&a);
      mp_mul_2(&a, &b);
      printf("mul2\n");
      mp_to64(&a, buf);
      printf("%s\n", buf);
      mp_to64(&b, buf);
      printf("%s\n", buf);
   } else if (n == 13) {
      rand_num2(&a);
      tmp = abs(rand()) & THE_MASK;
      mp_add_d(&a, tmp, &b);
      printf("add_d\n");
      mp_to64(&a, buf);
      printf("%s\n%d\n", buf, tmp);
      mp_to64(&b, buf);
      printf("%s\n", buf);
   } else if (n == 14) {
      rand_num2(&a);
      tmp = abs(rand()) & THE_MASK;
      mp_sub_d(&a, tmp, &b);
      printf("sub_d\n");
      mp_to64(&a, buf);
      printf("%s\n%d\n", buf, tmp);
      mp_to64(&b, buf);
      printf("%s\n", buf);
   }
   }
   fclose(rng);
   return 0;
}

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mtest.c,v $ */
/* $Revision: 1.1.1.1.2.1 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/pics/expt_state.tif.

cannot compute difference between binary files

Added libtommath/pics/primality.tif.

cannot compute difference between binary files

Added libtommath/poster.pdf.

cannot compute difference between binary files

Added libtommath/pre_gen/mpi.c.































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
6906
6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028
7029
7030
7031
7032
7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
7048
7049
7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
7461
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476
7477
7478
7479
7480
7481
7482
7483
7484
7485
7486
7487
7488
7489
7490
7491
7492
7493
7494
7495
7496
7497
7498
7499
7500
7501
7502
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
7525
7526
7527
7528
7529
7530
7531
7532
7533
7534
7535
7536
7537
7538
7539
7540
7541
7542
7543
7544
7545
7546
7547
7548
7549
7550
7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
7562
7563
7564
7565
7566
7567
7568
7569
7570
7571
7572
7573
7574
7575
7576
7577
7578
7579
7580
7581
7582
7583
7584
7585
7586
7587
7588
7589
7590
7591
7592
7593
7594
7595
7596
7597
7598
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627
7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
7649
7650
7651
7652
7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
7802
7803
7804
7805
7806
7807
7808
7809
7810
7811
7812
7813
7814
7815
7816
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880
7881
7882
7883
7884
7885
7886
7887
7888
7889
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
7984
7985
7986
7987
7988
7989
7990
7991
7992
7993
7994
7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
8117
8118
8119
8120
8121
8122
8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164
8165
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
8240
8241
8242
8243
8244
8245
8246
8247
8248
8249
8250
8251
8252
8253
8254
8255
8256
8257
8258
8259
8260
8261
8262
8263
8264
8265
8266
8267
8268
8269
8270
8271
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298
8299
8300
8301
8302
8303
8304
8305
8306
8307
8308
8309
8310
8311
8312
8313
8314
8315
8316
8317
8318
8319
8320
8321
8322
8323
8324
8325
8326
8327
8328
8329
8330
8331
8332
8333
8334
8335
8336
8337
8338
8339
8340
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
8603
8604
8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
8617
8618
8619
8620
8621
8622
8623
8624
8625
8626
8627
8628
8629
8630
8631
8632
8633
8634
8635
8636
8637
8638
8639
8640
8641
8642
8643
8644
8645
8646
8647
8648
8649
8650
8651
8652
8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
8678
8679
8680
8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699
8700
8701
8702
8703
8704
8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721
8722
8723
8724
8725
8726
8727
8728
8729
8730
8731
8732
8733
8734
8735
8736
8737
8738
8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750
8751
8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
8778
8779
8780
8781
8782
8783
8784
8785
8786
8787
8788
8789
8790
8791
8792
8793
8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
8823
8824
8825
8826
8827
8828
8829
8830
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
8847
8848
8849
8850
8851
8852
8853
8854
8855
8856
8857
8858
8859
8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880
8881
8882
8883
8884
8885
8886
8887
8888
8889
8890
8891
8892
8893
8894
8895
8896
8897
8898
8899
8900
8901
8902
8903
8904
8905
8906
8907
8908
8909
8910
8911
8912
8913
8914
8915
8916
8917
8918
8919
8920
8921
8922
8923
8924
8925
8926
8927
8928
8929
8930
8931
8932
8933
8934
8935
8936
8937
8938
8939
8940
8941
8942
8943
8944
8945
8946
8947
8948
8949
8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
9075
9076
9077
9078
9079
9080
9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
9093
9094
9095
9096
9097
9098
9099
9100
9101
9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
9143
9144
9145
9146
9147
9148
9149
9150
9151
9152
9153
9154
9155
9156
9157
9158
9159
9160
9161
9162
9163
9164
9165
9166
9167
9168
9169
9170
9171
9172
9173
9174
9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
9314
9315
9316
9317
9318
9319
9320
9321
9322
9323
9324
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
9399
9400
9401
9402
9403
9404
9405
9406
9407
9408
9409
9410
9411
9412
9413
9414
9415
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
9431
9432
9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450
9451
9452
9453
9454
9455
9456
9457
9458
9459
9460
9461
9462
9463
9464
9465
9466
9467
9468
9469
9470
9471
9472
9473
9474
9475
9476
9477
9478
9479
9480
9481
9482
9483
9484
9485
9486
9487
9488
9489
9490
9491
9492
9493
9494
9495
9496
9497
9498
9499
9500
9501
9502
9503
9504
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514
9515
9516
9517
9518
9519
/* Start: bn_error.c */
#include <tommath.h>
#ifdef BN_ERROR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

static const struct {
     int code;
     char *msg;
} msgs[] = {
     { MP_OKAY, "Successful" },
     { MP_MEM,  "Out of heap" },
     { MP_VAL,  "Value out of range" }
};

/* return a char * string for a given code */
char *mp_error_to_string(int code)
{
   int x;

   /* scan the lookup table for the given message */
   for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) {
       if (msgs[x].code == code) {
          return msgs[x].msg;
       }
   }

   /* generic reply for invalid code */
   return "Invalid error code";
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_error.c */

/* Start: bn_fast_mp_invmod.c */
#include <tommath.h>
#ifdef BN_FAST_MP_INVMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes the modular inverse via binary extended euclidean algorithm, 
 * that is c = 1/a mod b 
 *
 * Based on slow invmod except this is optimized for the case where b is 
 * odd as per HAC Note 14.64 on pp. 610
 */
int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  x, y, u, v, B, D;
  int     res, neg;

  /* 2. [modified] b must be odd   */
  if (mp_iseven (b) == 1) {
    return MP_VAL;
  }

  /* init all our temps */
  if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) {
     return res;
  }

  /* x == modulus, y == value to invert */
  if ((res = mp_copy (b, &x)) != MP_OKAY) {
    goto LBL_ERR;
  }

  /* we need y = |a| */
  if ((res = mp_mod (a, b, &y)) != MP_OKAY) {
    goto LBL_ERR;
  }

  /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
  if ((res = mp_copy (&x, &u)) != MP_OKAY) {
    goto LBL_ERR;
  }
  if ((res = mp_copy (&y, &v)) != MP_OKAY) {
    goto LBL_ERR;
  }
  mp_set (&D, 1);

top:
  /* 4.  while u is even do */
  while (mp_iseven (&u) == 1) {
    /* 4.1 u = u/2 */
    if ((res = mp_div_2 (&u, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 4.2 if B is odd then */
    if (mp_isodd (&B) == 1) {
      if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) {
        goto LBL_ERR;
      }
    }
    /* B = B/2 */
    if ((res = mp_div_2 (&B, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 5.  while v is even do */
  while (mp_iseven (&v) == 1) {
    /* 5.1 v = v/2 */
    if ((res = mp_div_2 (&v, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 5.2 if D is odd then */
    if (mp_isodd (&D) == 1) {
      /* D = (D-x)/2 */
      if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) {
        goto LBL_ERR;
      }
    }
    /* D = D/2 */
    if ((res = mp_div_2 (&D, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 6.  if u >= v then */
  if (mp_cmp (&u, &v) != MP_LT) {
    /* u = u - v, B = B - D */
    if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  } else {
    /* v - v - u, D = D - B */
    if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* if not zero goto step 4 */
  if (mp_iszero (&u) == 0) {
    goto top;
  }

  /* now a = C, b = D, gcd == g*v */

  /* if v != 1 then there is no inverse */
  if (mp_cmp_d (&v, 1) != MP_EQ) {
    res = MP_VAL;
    goto LBL_ERR;
  }

  /* b is now the inverse */
  neg = a->sign;
  while (D.sign == MP_NEG) {
    if ((res = mp_add (&D, b, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }
  mp_exch (&D, c);
  c->sign = neg;
  res = MP_OKAY;

LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_fast_mp_invmod.c */

/* Start: bn_fast_mp_montgomery_reduce.c */
#include <tommath.h>
#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes xR**-1 == x (mod N) via Montgomery Reduction
 *
 * This is an optimized implementation of montgomery_reduce
 * which uses the comba method to quickly calculate the columns of the
 * reduction.
 *
 * Based on Algorithm 14.32 on pp.601 of HAC.
*/
int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho)
{
  int     ix, res, olduse;
  mp_word W[MP_WARRAY];

  /* get old used count */
  olduse = x->used;

  /* grow a as required */
  if (x->alloc < n->used + 1) {
    if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) {
      return res;
    }
  }

  /* first we have to get the digits of the input into
   * an array of double precision words W[...]
   */
  {
    register mp_word *_W;
    register mp_digit *tmpx;

    /* alias for the W[] array */
    _W   = W;

    /* alias for the digits of  x*/
    tmpx = x->dp;

    /* copy the digits of a into W[0..a->used-1] */
    for (ix = 0; ix < x->used; ix++) {
      *_W++ = *tmpx++;
    }

    /* zero the high words of W[a->used..m->used*2] */
    for (; ix < n->used * 2 + 1; ix++) {
      *_W++ = 0;
    }
  }

  /* now we proceed to zero successive digits
   * from the least significant upwards
   */
  for (ix = 0; ix < n->used; ix++) {
    /* mu = ai * m' mod b
     *
     * We avoid a double precision multiplication (which isn't required)
     * by casting the value down to a mp_digit.  Note this requires
     * that W[ix-1] have  the carry cleared (see after the inner loop)
     */
    register mp_digit mu;
    mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK);

    /* a = a + mu * m * b**i
     *
     * This is computed in place and on the fly.  The multiplication
     * by b**i is handled by offseting which columns the results
     * are added to.
     *
     * Note the comba method normally doesn't handle carries in the
     * inner loop In this case we fix the carry from the previous
     * column since the Montgomery reduction requires digits of the
     * result (so far) [see above] to work.  This is
     * handled by fixing up one carry after the inner loop.  The
     * carry fixups are done in order so after these loops the
     * first m->used words of W[] have the carries fixed
     */
    {
      register int iy;
      register mp_digit *tmpn;
      register mp_word *_W;

      /* alias for the digits of the modulus */
      tmpn = n->dp;

      /* Alias for the columns set by an offset of ix */
      _W = W + ix;

      /* inner loop */
      for (iy = 0; iy < n->used; iy++) {
          *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++);
      }
    }

    /* now fix carry for next digit, W[ix+1] */
    W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT);
  }

  /* now we have to propagate the carries and
   * shift the words downward [all those least
   * significant digits we zeroed].
   */
  {
    register mp_digit *tmpx;
    register mp_word *_W, *_W1;

    /* nox fix rest of carries */

    /* alias for current word */
    _W1 = W + ix;

    /* alias for next word, where the carry goes */
    _W = W + ++ix;

    for (; ix <= n->used * 2 + 1; ix++) {
      *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT);
    }

    /* copy out, A = A/b**n
     *
     * The result is A/b**n but instead of converting from an
     * array of mp_word to mp_digit than calling mp_rshd
     * we just copy them in the right order
     */

    /* alias for destination word */
    tmpx = x->dp;

    /* alias for shifted double precision result */
    _W = W + n->used;

    for (ix = 0; ix < n->used + 1; ix++) {
      *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK));
    }

    /* zero oldused digits, if the input a was larger than
     * m->used+1 we'll have to clear the digits
     */
    for (; ix < olduse; ix++) {
      *tmpx++ = 0;
    }
  }

  /* set the max used and clamp */
  x->used = n->used + 1;
  mp_clamp (x);

  /* if A >= m then A = A - m */
  if (mp_cmp_mag (x, n) != MP_LT) {
    return s_mp_sub (x, n, x);
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_fast_mp_montgomery_reduce.c */

/* Start: bn_fast_s_mp_mul_digs.c */
#include <tommath.h>
#ifdef BN_FAST_S_MP_MUL_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Fast (comba) multiplier
 *
 * This is the fast column-array [comba] multiplier.  It is 
 * designed to compute the columns of the product first 
 * then handle the carries afterwards.  This has the effect 
 * of making the nested loops that compute the columns very
 * simple and schedulable on super-scalar processors.
 *
 * This has been modified to produce a variable number of 
 * digits of output so if say only a half-product is required 
 * you don't have to compute the upper half (a feature 
 * required for fast Barrett reduction).
 *
 * Based on Algorithm 14.12 on pp.595 of HAC.
 *
 */
int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  int     olduse, res, pa, ix, iz;
  mp_digit W[MP_WARRAY];
  register mp_word  _W;

  /* grow the destination as required */
  if (c->alloc < digs) {
    if ((res = mp_grow (c, digs)) != MP_OKAY) {
      return res;
    }
  }

  /* number of output digits to produce */
  pa = MIN(digs, a->used + b->used);

  /* clear the carry */
  _W = 0;
  for (ix = 0; ix < pa; ix++) { 
      int      tx, ty;
      int      iy;
      mp_digit *tmpx, *tmpy;

      /* get offsets into the two bignums */
      ty = MIN(b->used-1, ix);
      tx = ix - ty;

      /* setup temp aliases */
      tmpx = a->dp + tx;
      tmpy = b->dp + ty;

      /* this is the number of times the loop will iterrate, essentially 
         while (tx++ < a->used && ty-- >= 0) { ... }
       */
      iy = MIN(a->used-tx, ty+1);

      /* execute loop */
      for (iz = 0; iz < iy; ++iz) {
         _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);

      }

      /* store term */
      W[ix] = ((mp_digit)_W) & MP_MASK;

      /* make next carry */
      _W = _W >> ((mp_word)DIGIT_BIT);
  }

  /* store final carry */
  W[ix] = (mp_digit)(_W & MP_MASK);

  /* setup dest */
  olduse  = c->used;
  c->used = pa;

  {
    register mp_digit *tmpc;
    tmpc = c->dp;
    for (ix = 0; ix < pa+1; ix++) {
      /* now extract the previous digit [below the carry] */
      *tmpc++ = W[ix];
    }

    /* clear unused digits [that existed in the old copy of c] */
    for (; ix < olduse; ix++) {
      *tmpc++ = 0;
    }
  }
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_fast_s_mp_mul_digs.c */

/* Start: bn_fast_s_mp_mul_high_digs.c */
#include <tommath.h>
#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* this is a modified version of fast_s_mul_digs that only produces
 * output digits *above* digs.  See the comments for fast_s_mul_digs
 * to see how it works.
 *
 * This is used in the Barrett reduction since for one of the multiplications
 * only the higher digits were needed.  This essentially halves the work.
 *
 * Based on Algorithm 14.12 on pp.595 of HAC.
 */
int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  int     olduse, res, pa, ix, iz;
  mp_digit W[MP_WARRAY];
  mp_word  _W;

  /* grow the destination as required */
  pa = a->used + b->used;
  if (c->alloc < pa) {
    if ((res = mp_grow (c, pa)) != MP_OKAY) {
      return res;
    }
  }

  /* number of output digits to produce */
  pa = a->used + b->used;
  _W = 0;
  for (ix = digs; ix < pa; ix++) { 
      int      tx, ty, iy;
      mp_digit *tmpx, *tmpy;

      /* get offsets into the two bignums */
      ty = MIN(b->used-1, ix);
      tx = ix - ty;

      /* setup temp aliases */
      tmpx = a->dp + tx;
      tmpy = b->dp + ty;

      /* this is the number of times the loop will iterrate, essentially its 
         while (tx++ < a->used && ty-- >= 0) { ... }
       */
      iy = MIN(a->used-tx, ty+1);

      /* execute loop */
      for (iz = 0; iz < iy; iz++) {
         _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
      }

      /* store term */
      W[ix] = ((mp_digit)_W) & MP_MASK;

      /* make next carry */
      _W = _W >> ((mp_word)DIGIT_BIT);
  }
  
  /* store final carry */
  W[ix] = (mp_digit)(_W & MP_MASK);

  /* setup dest */
  olduse  = c->used;
  c->used = pa;

  {
    register mp_digit *tmpc;

    tmpc = c->dp + digs;
    for (ix = digs; ix <= pa; ix++) {
      /* now extract the previous digit [below the carry] */
      *tmpc++ = W[ix];
    }

    /* clear unused digits [that existed in the old copy of c] */
    for (; ix < olduse; ix++) {
      *tmpc++ = 0;
    }
  }
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_fast_s_mp_mul_high_digs.c */

/* Start: bn_fast_s_mp_sqr.c */
#include <tommath.h>
#ifdef BN_FAST_S_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* the jist of squaring...
 * you do like mult except the offset of the tmpx [one that 
 * starts closer to zero] can't equal the offset of tmpy.  
 * So basically you set up iy like before then you min it with
 * (ty-tx) so that it never happens.  You double all those 
 * you add in the inner loop

After that loop you do the squares and add them in.
*/

int fast_s_mp_sqr (mp_int * a, mp_int * b)
{
  int       olduse, res, pa, ix, iz;
  mp_digit   W[MP_WARRAY], *tmpx;
  mp_word   W1;

  /* grow the destination as required */
  pa = a->used + a->used;
  if (b->alloc < pa) {
    if ((res = mp_grow (b, pa)) != MP_OKAY) {
      return res;
    }
  }

  /* number of output digits to produce */
  W1 = 0;
  for (ix = 0; ix < pa; ix++) { 
      int      tx, ty, iy;
      mp_word  _W;
      mp_digit *tmpy;

      /* clear counter */
      _W = 0;

      /* get offsets into the two bignums */
      ty = MIN(a->used-1, ix);
      tx = ix - ty;

      /* setup temp aliases */
      tmpx = a->dp + tx;
      tmpy = a->dp + ty;

      /* this is the number of times the loop will iterrate, essentially
         while (tx++ < a->used && ty-- >= 0) { ... }
       */
      iy = MIN(a->used-tx, ty+1);

      /* now for squaring tx can never equal ty 
       * we halve the distance since they approach at a rate of 2x
       * and we have to round because odd cases need to be executed
       */
      iy = MIN(iy, (ty-tx+1)>>1);

      /* execute loop */
      for (iz = 0; iz < iy; iz++) {
         _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
      }

      /* double the inner product and add carry */
      _W = _W + _W + W1;

      /* even columns have the square term in them */
      if ((ix&1) == 0) {
         _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]);
      }

      /* store it */
      W[ix] = (mp_digit)(_W & MP_MASK);

      /* make next carry */
      W1 = _W >> ((mp_word)DIGIT_BIT);
  }

  /* setup dest */
  olduse  = b->used;
  b->used = a->used+a->used;

  {
    mp_digit *tmpb;
    tmpb = b->dp;
    for (ix = 0; ix < pa; ix++) {
      *tmpb++ = W[ix] & MP_MASK;
    }

    /* clear unused digits [that existed in the old copy of c] */
    for (; ix < olduse; ix++) {
      *tmpb++ = 0;
    }
  }
  mp_clamp (b);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_fast_s_mp_sqr.c */

/* Start: bn_mp_2expt.c */
#include <tommath.h>
#ifdef BN_MP_2EXPT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes a = 2**b 
 *
 * Simple algorithm which zeroes the int, grows it then just sets one bit
 * as required.
 */
int
mp_2expt (mp_int * a, int b)
{
  int     res;

  /* zero a as per default */
  mp_zero (a);

  /* grow a to accomodate the single bit */
  if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) {
    return res;
  }

  /* set the used count of where the bit will go */
  a->used = b / DIGIT_BIT + 1;

  /* put the single bit in its place */
  a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT);

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_2expt.c */

/* Start: bn_mp_abs.c */
#include <tommath.h>
#ifdef BN_MP_ABS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = |a| 
 *
 * Simple function copies the input and fixes the sign to positive
 */
int
mp_abs (mp_int * a, mp_int * b)
{
  int     res;

  /* copy a to b */
  if (a != b) {
     if ((res = mp_copy (a, b)) != MP_OKAY) {
       return res;
     }
  }

  /* force the sign of b to positive */
  b->sign = MP_ZPOS;

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_abs.c */

/* Start: bn_mp_add.c */
#include <tommath.h>
#ifdef BN_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* high level addition (handles signs) */
int mp_add (mp_int * a, mp_int * b, mp_int * c)
{
  int     sa, sb, res;

  /* get sign of both inputs */
  sa = a->sign;
  sb = b->sign;

  /* handle two cases, not four */
  if (sa == sb) {
    /* both positive or both negative */
    /* add their magnitudes, copy the sign */
    c->sign = sa;
    res = s_mp_add (a, b, c);
  } else {
    /* one positive, the other negative */
    /* subtract the one with the greater magnitude from */
    /* the one of the lesser magnitude.  The result gets */
    /* the sign of the one with the greater magnitude. */
    if (mp_cmp_mag (a, b) == MP_LT) {
      c->sign = sb;
      res = s_mp_sub (b, a, c);
    } else {
      c->sign = sa;
      res = s_mp_sub (a, b, c);
    }
  }
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_add.c */

/* Start: bn_mp_add_d.c */
#include <tommath.h>
#ifdef BN_MP_ADD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* single digit addition */
int
mp_add_d (mp_int * a, mp_digit b, mp_int * c)
{
  int     res, ix, oldused;
  mp_digit *tmpa, *tmpc, mu;

  /* grow c as required */
  if (c->alloc < a->used + 1) {
     if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) {
        return res;
     }
  }

  /* if a is negative and |a| >= b, call c = |a| - b */
  if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) {
     /* temporarily fix sign of a */
     a->sign = MP_ZPOS;

     /* c = |a| - b */
     res = mp_sub_d(a, b, c);

     /* fix sign  */
     a->sign = c->sign = MP_NEG;

     return res;
  }

  /* old number of used digits in c */
  oldused = c->used;

  /* sign always positive */
  c->sign = MP_ZPOS;

  /* source alias */
  tmpa    = a->dp;

  /* destination alias */
  tmpc    = c->dp;

  /* if a is positive */
  if (a->sign == MP_ZPOS) {
     /* add digit, after this we're propagating
      * the carry.
      */
     *tmpc   = *tmpa++ + b;
     mu      = *tmpc >> DIGIT_BIT;
     *tmpc++ &= MP_MASK;

     /* now handle rest of the digits */
     for (ix = 1; ix < a->used; ix++) {
        *tmpc   = *tmpa++ + mu;
        mu      = *tmpc >> DIGIT_BIT;
        *tmpc++ &= MP_MASK;
     }
     /* set final carry */
     ix++;
     *tmpc++  = mu;

     /* setup size */
     c->used = a->used + 1;
  } else {
     /* a was negative and |a| < b */
     c->used  = 1;

     /* the result is a single digit */
     if (a->used == 1) {
        *tmpc++  =  b - a->dp[0];
     } else {
        *tmpc++  =  b;
     }

     /* setup count so the clearing of oldused
      * can fall through correctly
      */
     ix       = 1;
  }

  /* now zero to oldused */
  while (ix++ < oldused) {
     *tmpc++ = 0;
  }
  mp_clamp(c);

  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_add_d.c */

/* Start: bn_mp_addmod.c */
#include <tommath.h>
#ifdef BN_MP_ADDMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* d = a + b (mod c) */
int
mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  int     res;
  mp_int  t;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_add (a, b, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, c, d);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_addmod.c */

/* Start: bn_mp_and.c */
#include <tommath.h>
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* AND two ints together */
int
mp_and (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, ix, px;
  mp_int  t, *x;

  if (a->used > b->used) {
    if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
      return res;
    }
    px = b->used;
    x = b;
  } else {
    if ((res = mp_init_copy (&t, b)) != MP_OKAY) {
      return res;
    }
    px = a->used;
    x = a;
  }

  for (ix = 0; ix < px; ix++) {
    t.dp[ix] &= x->dp[ix];
  }

  /* zero digits above the last from the smallest mp_int */
  for (; ix < t.used; ix++) {
    t.dp[ix] = 0;
  }

  mp_clamp (&t);
  mp_exch (c, &t);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_and.c */

/* Start: bn_mp_clamp.c */
#include <tommath.h>
#ifdef BN_MP_CLAMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* trim unused digits 
 *
 * This is used to ensure that leading zero digits are
 * trimed and the leading "used" digit will be non-zero
 * Typically very fast.  Also fixes the sign if there
 * are no more leading digits
 */
void
mp_clamp (mp_int * a)
{
  /* decrease used while the most significant digit is
   * zero.
   */
  while (a->used > 0 && a->dp[a->used - 1] == 0) {
    --(a->used);
  }

  /* reset the sign flag if used == 0 */
  if (a->used == 0) {
    a->sign = MP_ZPOS;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_clamp.c */

/* Start: bn_mp_clear.c */
#include <tommath.h>
#ifdef BN_MP_CLEAR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* clear one (frees)  */
void
mp_clear (mp_int * a)
{
  int i;

  /* only do anything if a hasn't been freed previously */
  if (a->dp != NULL) {
    /* first zero the digits */
    for (i = 0; i < a->used; i++) {
        a->dp[i] = 0;
    }

    /* free ram */
    XFREE(a->dp);

    /* reset members to make debugging easier */
    a->dp    = NULL;
    a->alloc = a->used = 0;
    a->sign  = MP_ZPOS;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_clear.c */

/* Start: bn_mp_clear_multi.c */
#include <tommath.h>
#ifdef BN_MP_CLEAR_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#include <stdarg.h>

void mp_clear_multi(mp_int *mp, ...) 
{
    mp_int* next_mp = mp;
    va_list args;
    va_start(args, mp);
    while (next_mp != NULL) {
        mp_clear(next_mp);
        next_mp = va_arg(args, mp_int*);
    }
    va_end(args);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_clear_multi.c */

/* Start: bn_mp_cmp.c */
#include <tommath.h>
#ifdef BN_MP_CMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* compare two ints (signed)*/
int
mp_cmp (mp_int * a, mp_int * b)
{
  /* compare based on sign */
  if (a->sign != b->sign) {
     if (a->sign == MP_NEG) {
        return MP_LT;
     } else {
        return MP_GT;
     }
  }
  
  /* compare digits */
  if (a->sign == MP_NEG) {
     /* if negative compare opposite direction */
     return mp_cmp_mag(b, a);
  } else {
     return mp_cmp_mag(a, b);
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_cmp.c */

/* Start: bn_mp_cmp_d.c */
#include <tommath.h>
#ifdef BN_MP_CMP_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* compare a digit */
int mp_cmp_d(mp_int * a, mp_digit b)
{
  /* compare based on sign */
  if (a->sign == MP_NEG) {
    return MP_LT;
  }

  /* compare based on magnitude */
  if (a->used > 1) {
    return MP_GT;
  }

  /* compare the only digit of a to b */
  if (a->dp[0] > b) {
    return MP_GT;
  } else if (a->dp[0] < b) {
    return MP_LT;
  } else {
    return MP_EQ;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_cmp_d.c */

/* Start: bn_mp_cmp_mag.c */
#include <tommath.h>
#ifdef BN_MP_CMP_MAG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* compare maginitude of two ints (unsigned) */
int mp_cmp_mag (mp_int * a, mp_int * b)
{
  int     n;
  mp_digit *tmpa, *tmpb;

  /* compare based on # of non-zero digits */
  if (a->used > b->used) {
    return MP_GT;
  }
  
  if (a->used < b->used) {
    return MP_LT;
  }

  /* alias for a */
  tmpa = a->dp + (a->used - 1);

  /* alias for b */
  tmpb = b->dp + (a->used - 1);

  /* compare based on digits  */
  for (n = 0; n < a->used; ++n, --tmpa, --tmpb) {
    if (*tmpa > *tmpb) {
      return MP_GT;
    }

    if (*tmpa < *tmpb) {
      return MP_LT;
    }
  }
  return MP_EQ;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_cmp_mag.c */

/* Start: bn_mp_cnt_lsb.c */
#include <tommath.h>
#ifdef BN_MP_CNT_LSB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

static const int lnz[16] = { 
   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
};

/* Counts the number of lsbs which are zero before the first zero bit */
int mp_cnt_lsb(mp_int *a)
{
   int x;
   mp_digit q, qq;

   /* easy out */
   if (mp_iszero(a) == 1) {
      return 0;
   }

   /* scan lower digits until non-zero */
   for (x = 0; x < a->used && a->dp[x] == 0; x++);
   q = a->dp[x];
   x *= DIGIT_BIT;

   /* now scan this digit until a 1 is found */
   if ((q & 1) == 0) {
      do {
         qq  = q & 15;
         x  += lnz[qq];
         q >>= 4;
      } while (qq == 0);
   }
   return x;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_cnt_lsb.c */

/* Start: bn_mp_copy.c */
#include <tommath.h>
#ifdef BN_MP_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* copy, b = a */
int
mp_copy (mp_int * a, mp_int * b)
{
  int     res, n;

  /* if dst == src do nothing */
  if (a == b) {
    return MP_OKAY;
  }

  /* grow dest */
  if (b->alloc < a->used) {
     if ((res = mp_grow (b, a->used)) != MP_OKAY) {
        return res;
     }
  }

  /* zero b and copy the parameters over */
  {
    register mp_digit *tmpa, *tmpb;

    /* pointer aliases */

    /* source */
    tmpa = a->dp;

    /* destination */
    tmpb = b->dp;

    /* copy all the digits */
    for (n = 0; n < a->used; n++) {
      *tmpb++ = *tmpa++;
    }

    /* clear high digits */
    for (; n < b->used; n++) {
      *tmpb++ = 0;
    }
  }

  /* copy used count and sign */
  b->used = a->used;
  b->sign = a->sign;
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_copy.c */

/* Start: bn_mp_count_bits.c */
#include <tommath.h>
#ifdef BN_MP_COUNT_BITS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* returns the number of bits in an int */
int
mp_count_bits (mp_int * a)
{
  int     r;
  mp_digit q;

  /* shortcut */
  if (a->used == 0) {
    return 0;
  }

  /* get number of digits and add that */
  r = (a->used - 1) * DIGIT_BIT;
  
  /* take the last digit and count the bits in it */
  q = a->dp[a->used - 1];
  while (q > ((mp_digit) 0)) {
    ++r;
    q >>= ((mp_digit) 1);
  }
  return r;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_count_bits.c */

/* Start: bn_mp_div.c */
#include <tommath.h>
#ifdef BN_MP_DIV_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

#ifdef BN_MP_DIV_SMALL

/* slower bit-bang division... also smaller */
int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
   mp_int ta, tb, tq, q;
   int    res, n, n2;

  /* is divisor zero ? */
  if (mp_iszero (b) == 1) {
    return MP_VAL;
  }

  /* if a < b then q=0, r = a */
  if (mp_cmp_mag (a, b) == MP_LT) {
    if (d != NULL) {
      res = mp_copy (a, d);
    } else {
      res = MP_OKAY;
    }
    if (c != NULL) {
      mp_zero (c);
    }
    return res;
  }
	
  /* init our temps */
  if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) {
     return res;
  }


  mp_set(&tq, 1);
  n = mp_count_bits(a) - mp_count_bits(b);
  if (((res = mp_abs(a, &ta)) != MP_OKAY) ||
      ((res = mp_abs(b, &tb)) != MP_OKAY) || 
      ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) ||
      ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) {
      goto LBL_ERR;
  }

  while (n-- >= 0) {
     if (mp_cmp(&tb, &ta) != MP_GT) {
        if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) ||
            ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) {
           goto LBL_ERR;
        }
     }
     if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) ||
         ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) {
           goto LBL_ERR;
     }
  }

  /* now q == quotient and ta == remainder */
  n  = a->sign;
  n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG);
  if (c != NULL) {
     mp_exch(c, &q);
     c->sign  = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2;
  }
  if (d != NULL) {
     mp_exch(d, &ta);
     d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n;
  }
LBL_ERR:
   mp_clear_multi(&ta, &tb, &tq, &q, NULL);
   return res;
}

#else

/* integer signed division. 
 * c*b + d == a [e.g. a/b, c=quotient, d=remainder]
 * HAC pp.598 Algorithm 14.20
 *
 * Note that the description in HAC is horribly 
 * incomplete.  For example, it doesn't consider 
 * the case where digits are removed from 'x' in 
 * the inner loop.  It also doesn't consider the 
 * case that y has fewer than three digits, etc..
 *
 * The overall algorithm is as described as 
 * 14.20 from HAC but fixed to treat these cases.
*/
int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  mp_int  q, x, y, t1, t2;
  int     res, n, t, i, norm, neg;

  /* is divisor zero ? */
  if (mp_iszero (b) == 1) {
    return MP_VAL;
  }

  /* if a < b then q=0, r = a */
  if (mp_cmp_mag (a, b) == MP_LT) {
    if (d != NULL) {
      res = mp_copy (a, d);
    } else {
      res = MP_OKAY;
    }
    if (c != NULL) {
      mp_zero (c);
    }
    return res;
  }

  if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) {
    return res;
  }
  q.used = a->used + 2;

  if ((res = mp_init (&t1)) != MP_OKAY) {
    goto LBL_Q;
  }

  if ((res = mp_init (&t2)) != MP_OKAY) {
    goto LBL_T1;
  }

  if ((res = mp_init_copy (&x, a)) != MP_OKAY) {
    goto LBL_T2;
  }

  if ((res = mp_init_copy (&y, b)) != MP_OKAY) {
    goto LBL_X;
  }

  /* fix the sign */
  neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;
  x.sign = y.sign = MP_ZPOS;

  /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */
  norm = mp_count_bits(&y) % DIGIT_BIT;
  if (norm < (int)(DIGIT_BIT-1)) {
     norm = (DIGIT_BIT-1) - norm;
     if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) {
       goto LBL_Y;
     }
     if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) {
       goto LBL_Y;
     }
  } else {
     norm = 0;
  }

  /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */
  n = x.used - 1;
  t = y.used - 1;

  /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */
  if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */
    goto LBL_Y;
  }

  while (mp_cmp (&x, &y) != MP_LT) {
    ++(q.dp[n - t]);
    if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) {
      goto LBL_Y;
    }
  }

  /* reset y by shifting it back down */
  mp_rshd (&y, n - t);

  /* step 3. for i from n down to (t + 1) */
  for (i = n; i >= (t + 1); i--) {
    if (i > x.used) {
      continue;
    }

    /* step 3.1 if xi == yt then set q{i-t-1} to b-1, 
     * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */
    if (x.dp[i] == y.dp[t]) {
      q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1);
    } else {
      mp_word tmp;
      tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT);
      tmp |= ((mp_word) x.dp[i - 1]);
      tmp /= ((mp_word) y.dp[t]);
      if (tmp > (mp_word) MP_MASK)
        tmp = MP_MASK;
      q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK));
    }

    /* while (q{i-t-1} * (yt * b + y{t-1})) > 
             xi * b**2 + xi-1 * b + xi-2 
     
       do q{i-t-1} -= 1; 
    */
    q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK;
    do {
      q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK;

      /* find left hand */
      mp_zero (&t1);
      t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1];
      t1.dp[1] = y.dp[t];
      t1.used = 2;
      if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) {
        goto LBL_Y;
      }

      /* find right hand */
      t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2];
      t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1];
      t2.dp[2] = x.dp[i];
      t2.used = 3;
    } while (mp_cmp_mag(&t1, &t2) == MP_GT);

    /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */
    if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) {
      goto LBL_Y;
    }

    if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) {
      goto LBL_Y;
    }

    if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) {
      goto LBL_Y;
    }

    /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */
    if (x.sign == MP_NEG) {
      if ((res = mp_copy (&y, &t1)) != MP_OKAY) {
        goto LBL_Y;
      }
      if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) {
        goto LBL_Y;
      }
      if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) {
        goto LBL_Y;
      }

      q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK;
    }
  }

  /* now q is the quotient and x is the remainder 
   * [which we have to normalize] 
   */
  
  /* get sign before writing to c */
  x.sign = x.used == 0 ? MP_ZPOS : a->sign;

  if (c != NULL) {
    mp_clamp (&q);
    mp_exch (&q, c);
    c->sign = neg;
  }

  if (d != NULL) {
    mp_div_2d (&x, norm, &x, NULL);
    mp_exch (&x, d);
  }

  res = MP_OKAY;

LBL_Y:mp_clear (&y);
LBL_X:mp_clear (&x);
LBL_T2:mp_clear (&t2);
LBL_T1:mp_clear (&t1);
LBL_Q:mp_clear (&q);
  return res;
}

#endif

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_div.c */

/* Start: bn_mp_div_2.c */
#include <tommath.h>
#ifdef BN_MP_DIV_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = a/2 */
int mp_div_2(mp_int * a, mp_int * b)
{
  int     x, res, oldused;

  /* copy */
  if (b->alloc < a->used) {
    if ((res = mp_grow (b, a->used)) != MP_OKAY) {
      return res;
    }
  }

  oldused = b->used;
  b->used = a->used;
  {
    register mp_digit r, rr, *tmpa, *tmpb;

    /* source alias */
    tmpa = a->dp + b->used - 1;

    /* dest alias */
    tmpb = b->dp + b->used - 1;

    /* carry */
    r = 0;
    for (x = b->used - 1; x >= 0; x--) {
      /* get the carry for the next iteration */
      rr = *tmpa & 1;

      /* shift the current digit, add in carry and store */
      *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1));

      /* forward carry to next iteration */
      r = rr;
    }

    /* zero excess digits */
    tmpb = b->dp + b->used;
    for (x = b->used; x < oldused; x++) {
      *tmpb++ = 0;
    }
  }
  b->sign = a->sign;
  mp_clamp (b);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_div_2.c */

/* Start: bn_mp_div_2d.c */
#include <tommath.h>
#ifdef BN_MP_DIV_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift right by a certain bit count (store quotient in c, optional remainder in d) */
int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d)
{
  mp_digit D, r, rr;
  int     x, res;
  mp_int  t;


  /* if the shift count is <= 0 then we do no work */
  if (b <= 0) {
    res = mp_copy (a, c);
    if (d != NULL) {
      mp_zero (d);
    }
    return res;
  }

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  /* get the remainder */
  if (d != NULL) {
    if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
  }

  /* copy */
  if ((res = mp_copy (a, c)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }

  /* shift by as many digits in the bit count */
  if (b >= (int)DIGIT_BIT) {
    mp_rshd (c, b / DIGIT_BIT);
  }

  /* shift any bit count < DIGIT_BIT */
  D = (mp_digit) (b % DIGIT_BIT);
  if (D != 0) {
    register mp_digit *tmpc, mask, shift;

    /* mask */
    mask = (((mp_digit)1) << D) - 1;

    /* shift for lsb */
    shift = DIGIT_BIT - D;

    /* alias */
    tmpc = c->dp + (c->used - 1);

    /* carry */
    r = 0;
    for (x = c->used - 1; x >= 0; x--) {
      /* get the lower  bits of this word in a temp */
      rr = *tmpc & mask;

      /* shift the current word and mix in the carry bits from the previous word */
      *tmpc = (*tmpc >> D) | (r << shift);
      --tmpc;

      /* set the carry to the carry bits of the current word found above */
      r = rr;
    }
  }
  mp_clamp (c);
  if (d != NULL) {
    mp_exch (&t, d);
  }
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_div_2d.c */

/* Start: bn_mp_div_3.c */
#include <tommath.h>
#ifdef BN_MP_DIV_3_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* divide by three (based on routine from MPI and the GMP manual) */
int
mp_div_3 (mp_int * a, mp_int *c, mp_digit * d)
{
  mp_int   q;
  mp_word  w, t;
  mp_digit b;
  int      res, ix;
  
  /* b = 2**DIGIT_BIT / 3 */
  b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3);

  if ((res = mp_init_size(&q, a->used)) != MP_OKAY) {
     return res;
  }
  
  q.used = a->used;
  q.sign = a->sign;
  w = 0;
  for (ix = a->used - 1; ix >= 0; ix--) {
     w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]);

     if (w >= 3) {
        /* multiply w by [1/3] */
        t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT);

        /* now subtract 3 * [w/3] from w, to get the remainder */
        w -= t+t+t;

        /* fixup the remainder as required since
         * the optimization is not exact.
         */
        while (w >= 3) {
           t += 1;
           w -= 3;
        }
      } else {
        t = 0;
      }
      q.dp[ix] = (mp_digit)t;
  }

  /* [optional] store the remainder */
  if (d != NULL) {
     *d = (mp_digit)w;
  }

  /* [optional] store the quotient */
  if (c != NULL) {
     mp_clamp(&q);
     mp_exch(&q, c);
  }
  mp_clear(&q);
  
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_div_3.c */

/* Start: bn_mp_div_d.c */
#include <tommath.h>
#ifdef BN_MP_DIV_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

static int s_is_power_of_two(mp_digit b, int *p)
{
   int x;

   for (x = 1; x < DIGIT_BIT; x++) {
      if (b == (((mp_digit)1)<<x)) {
         *p = x;
         return 1;
      }
   }
   return 0;
}

/* single digit division (based on routine from MPI) */
int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d)
{
  mp_int  q;
  mp_word w;
  mp_digit t;
  int     res, ix;

  /* cannot divide by zero */
  if (b == 0) {
     return MP_VAL;
  }

  /* quick outs */
  if (b == 1 || mp_iszero(a) == 1) {
     if (d != NULL) {
        *d = 0;
     }
     if (c != NULL) {
        return mp_copy(a, c);
     }
     return MP_OKAY;
  }

  /* power of two ? */
  if (s_is_power_of_two(b, &ix) == 1) {
     if (d != NULL) {
        *d = a->dp[0] & ((((mp_digit)1)<<ix) - 1);
     }
     if (c != NULL) {
        return mp_div_2d(a, ix, c, NULL);
     }
     return MP_OKAY;
  }

#ifdef BN_MP_DIV_3_C
  /* three? */
  if (b == 3) {
     return mp_div_3(a, c, d);
  }
#endif

  /* no easy answer [c'est la vie].  Just division */
  if ((res = mp_init_size(&q, a->used)) != MP_OKAY) {
     return res;
  }
  
  q.used = a->used;
  q.sign = a->sign;
  w = 0;
  for (ix = a->used - 1; ix >= 0; ix--) {
     w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]);
     
     if (w >= b) {
        t = (mp_digit)(w / b);
        w -= ((mp_word)t) * ((mp_word)b);
      } else {
        t = 0;
      }
      q.dp[ix] = (mp_digit)t;
  }
  
  if (d != NULL) {
     *d = (mp_digit)w;
  }
  
  if (c != NULL) {
     mp_clamp(&q);
     mp_exch(&q, c);
  }
  mp_clear(&q);
  
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_div_d.c */

/* Start: bn_mp_dr_is_modulus.c */
#include <tommath.h>
#ifdef BN_MP_DR_IS_MODULUS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if a number is a valid DR modulus */
int mp_dr_is_modulus(mp_int *a)
{
   int ix;

   /* must be at least two digits */
   if (a->used < 2) {
      return 0;
   }

   /* must be of the form b**k - a [a <= b] so all
    * but the first digit must be equal to -1 (mod b).
    */
   for (ix = 1; ix < a->used; ix++) {
       if (a->dp[ix] != MP_MASK) {
          return 0;
       }
   }
   return 1;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_dr_is_modulus.c */

/* Start: bn_mp_dr_reduce.c */
#include <tommath.h>
#ifdef BN_MP_DR_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduce "x" in place modulo "n" using the Diminished Radix algorithm.
 *
 * Based on algorithm from the paper
 *
 * "Generating Efficient Primes for Discrete Log Cryptosystems"
 *                 Chae Hoon Lim, Pil Joong Lee,
 *          POSTECH Information Research Laboratories
 *
 * The modulus must be of a special format [see manual]
 *
 * Has been modified to use algorithm 7.10 from the LTM book instead
 *
 * Input x must be in the range 0 <= x <= (n-1)**2
 */
int
mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k)
{
  int      err, i, m;
  mp_word  r;
  mp_digit mu, *tmpx1, *tmpx2;

  /* m = digits in modulus */
  m = n->used;

  /* ensure that "x" has at least 2m digits */
  if (x->alloc < m + m) {
    if ((err = mp_grow (x, m + m)) != MP_OKAY) {
      return err;
    }
  }

/* top of loop, this is where the code resumes if
 * another reduction pass is required.
 */
top:
  /* aliases for digits */
  /* alias for lower half of x */
  tmpx1 = x->dp;

  /* alias for upper half of x, or x/B**m */
  tmpx2 = x->dp + m;

  /* set carry to zero */
  mu = 0;

  /* compute (x mod B**m) + k * [x/B**m] inline and inplace */
  for (i = 0; i < m; i++) {
      r         = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu;
      *tmpx1++  = (mp_digit)(r & MP_MASK);
      mu        = (mp_digit)(r >> ((mp_word)DIGIT_BIT));
  }

  /* set final carry */
  *tmpx1++ = mu;

  /* zero words above m */
  for (i = m + 1; i < x->used; i++) {
      *tmpx1++ = 0;
  }

  /* clamp, sub and return */
  mp_clamp (x);

  /* if x >= n then subtract and reduce again
   * Each successive "recursion" makes the input smaller and smaller.
   */
  if (mp_cmp_mag (x, n) != MP_LT) {
    s_mp_sub(x, n, x);
    goto top;
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_dr_reduce.c */

/* Start: bn_mp_dr_setup.c */
#include <tommath.h>
#ifdef BN_MP_DR_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines the setup value */
void mp_dr_setup(mp_int *a, mp_digit *d)
{
   /* the casts are required if DIGIT_BIT is one less than
    * the number of bits in a mp_digit [e.g. DIGIT_BIT==31]
    */
   *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - 
        ((mp_word)a->dp[0]));
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_dr_setup.c */

/* Start: bn_mp_exch.c */
#include <tommath.h>
#ifdef BN_MP_EXCH_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* swap the elements of two integers, for cases where you can't simply swap the 
 * mp_int pointers around
 */
void
mp_exch (mp_int * a, mp_int * b)
{
  mp_int  t;

  t  = *a;
  *a = *b;
  *b = t;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_exch.c */

/* Start: bn_mp_expt_d.c */
#include <tommath.h>
#ifdef BN_MP_EXPT_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* calculate c = a**b  using a square-multiply algorithm */
int mp_expt_d (mp_int * a, mp_digit b, mp_int * c)
{
  int     res, x;
  mp_int  g;

  if ((res = mp_init_copy (&g, a)) != MP_OKAY) {
    return res;
  }

  /* set initial result */
  mp_set (c, 1);

  for (x = 0; x < (int) DIGIT_BIT; x++) {
    /* square */
    if ((res = mp_sqr (c, c)) != MP_OKAY) {
      mp_clear (&g);
      return res;
    }

    /* if the bit is set multiply */
    if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) {
      if ((res = mp_mul (c, &g, c)) != MP_OKAY) {
         mp_clear (&g);
         return res;
      }
    }

    /* shift to next bit */
    b <<= 1;
  }

  mp_clear (&g);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_expt_d.c */

/* Start: bn_mp_exptmod.c */
#include <tommath.h>
#ifdef BN_MP_EXPTMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */


/* this is a shell function that calls either the normal or Montgomery
 * exptmod functions.  Originally the call to the montgomery code was
 * embedded in the normal function but that wasted alot of stack space
 * for nothing (since 99% of the time the Montgomery code would be called)
 */
int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y)
{
  int dr;

  /* modulus P must be positive */
  if (P->sign == MP_NEG) {
     return MP_VAL;
  }

  /* if exponent X is negative we have to recurse */
  if (X->sign == MP_NEG) {
#ifdef BN_MP_INVMOD_C
     mp_int tmpG, tmpX;
     int err;

     /* first compute 1/G mod P */
     if ((err = mp_init(&tmpG)) != MP_OKAY) {
        return err;
     }
     if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) {
        mp_clear(&tmpG);
        return err;
     }

     /* now get |X| */
     if ((err = mp_init(&tmpX)) != MP_OKAY) {
        mp_clear(&tmpG);
        return err;
     }
     if ((err = mp_abs(X, &tmpX)) != MP_OKAY) {
        mp_clear_multi(&tmpG, &tmpX, NULL);
        return err;
     }

     /* and now compute (1/G)**|X| instead of G**X [X < 0] */
     err = mp_exptmod(&tmpG, &tmpX, P, Y);
     mp_clear_multi(&tmpG, &tmpX, NULL);
     return err;
#else 
     /* no invmod */
     return MP_VAL;
#endif
  }

/* modified diminished radix reduction */
#if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C)
  if (mp_reduce_is_2k_l(P) == MP_YES) {
     return s_mp_exptmod(G, X, P, Y, 1);
  }
#endif

#ifdef BN_MP_DR_IS_MODULUS_C
  /* is it a DR modulus? */
  dr = mp_dr_is_modulus(P);
#else
  /* default to no */
  dr = 0;
#endif

#ifdef BN_MP_REDUCE_IS_2K_C
  /* if not, is it a unrestricted DR modulus? */
  if (dr == 0) {
     dr = mp_reduce_is_2k(P) << 1;
  }
#endif
    
  /* if the modulus is odd or dr != 0 use the montgomery method */
#ifdef BN_MP_EXPTMOD_FAST_C
  if (mp_isodd (P) == 1 || dr !=  0) {
    return mp_exptmod_fast (G, X, P, Y, dr);
  } else {
#endif
#ifdef BN_S_MP_EXPTMOD_C
    /* otherwise use the generic Barrett reduction technique */
    return s_mp_exptmod (G, X, P, Y, 0);
#else
    /* no exptmod for evens */
    return MP_VAL;
#endif
#ifdef BN_MP_EXPTMOD_FAST_C
  }
#endif
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_exptmod.c */

/* Start: bn_mp_exptmod_fast.c */
#include <tommath.h>
#ifdef BN_MP_EXPTMOD_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85
 *
 * Uses a left-to-right k-ary sliding window to compute the modular exponentiation.
 * The value of k changes based on the size of the exponent.
 *
 * Uses Montgomery or Diminished Radix reduction [whichever appropriate]
 */

#ifdef MP_LOW_MEM
   #define TAB_SIZE 32
#else
   #define TAB_SIZE 256
#endif

int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode)
{
  mp_int  M[TAB_SIZE], res;
  mp_digit buf, mp;
  int     err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;

  /* use a pointer to the reduction algorithm.  This allows us to use
   * one of many reduction algorithms without modding the guts of
   * the code with if statements everywhere.
   */
  int     (*redux)(mp_int*,mp_int*,mp_digit);

  /* find window size */
  x = mp_count_bits (X);
  if (x <= 7) {
    winsize = 2;
  } else if (x <= 36) {
    winsize = 3;
  } else if (x <= 140) {
    winsize = 4;
  } else if (x <= 450) {
    winsize = 5;
  } else if (x <= 1303) {
    winsize = 6;
  } else if (x <= 3529) {
    winsize = 7;
  } else {
    winsize = 8;
  }

#ifdef MP_LOW_MEM
  if (winsize > 5) {
     winsize = 5;
  }
#endif

  /* init M array */
  /* init first cell */
  if ((err = mp_init(&M[1])) != MP_OKAY) {
     return err;
  }

  /* now init the second half of the array */
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    if ((err = mp_init(&M[x])) != MP_OKAY) {
      for (y = 1<<(winsize-1); y < x; y++) {
        mp_clear (&M[y]);
      }
      mp_clear(&M[1]);
      return err;
    }
  }

  /* determine and setup reduction code */
  if (redmode == 0) {
#ifdef BN_MP_MONTGOMERY_SETUP_C     
     /* now setup montgomery  */
     if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) {
        goto LBL_M;
     }
#else
     err = MP_VAL;
     goto LBL_M;
#endif

     /* automatically pick the comba one if available (saves quite a few calls/ifs) */
#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C
     if (((P->used * 2 + 1) < MP_WARRAY) &&
          P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
        redux = fast_mp_montgomery_reduce;
     } else 
#endif
     {
#ifdef BN_MP_MONTGOMERY_REDUCE_C
        /* use slower baseline Montgomery method */
        redux = mp_montgomery_reduce;
#else
        err = MP_VAL;
        goto LBL_M;
#endif
     }
  } else if (redmode == 1) {
#if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C)
     /* setup DR reduction for moduli of the form B**k - b */
     mp_dr_setup(P, &mp);
     redux = mp_dr_reduce;
#else
     err = MP_VAL;
     goto LBL_M;
#endif
  } else {
#if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C)
     /* setup DR reduction for moduli of the form 2**k - b */
     if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) {
        goto LBL_M;
     }
     redux = mp_reduce_2k;
#else
     err = MP_VAL;
     goto LBL_M;
#endif
  }

  /* setup result */
  if ((err = mp_init (&res)) != MP_OKAY) {
    goto LBL_M;
  }

  /* create M table
   *

   *
   * The first half of the table is not computed though accept for M[0] and M[1]
   */

  if (redmode == 0) {
#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
     /* now we need R mod m */
     if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) {
       goto LBL_RES;
     }
#else 
     err = MP_VAL;
     goto LBL_RES;
#endif

     /* now set M[1] to G * R mod m */
     if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) {
       goto LBL_RES;
     }
  } else {
     mp_set(&res, 1);
     if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
        goto LBL_RES;
     }
  }

  /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */
  if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) {
    goto LBL_RES;
  }

  for (x = 0; x < (winsize - 1); x++) {
    if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) {
      goto LBL_RES;
    }
    if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) {
      goto LBL_RES;
    }
  }

  /* create upper table */
  for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
    if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) {
      goto LBL_RES;
    }
    if ((err = redux (&M[x], P, mp)) != MP_OKAY) {
      goto LBL_RES;
    }
  }

  /* set initial mode and bit cnt */
  mode   = 0;
  bitcnt = 1;
  buf    = 0;
  digidx = X->used - 1;
  bitcpy = 0;
  bitbuf = 0;

  for (;;) {
    /* grab next digit as required */
    if (--bitcnt == 0) {
      /* if digidx == -1 we are out of digits so break */
      if (digidx == -1) {
        break;
      }
      /* read next digit and reset bitcnt */
      buf    = X->dp[digidx--];
      bitcnt = (int)DIGIT_BIT;
    }

    /* grab the next msb from the exponent */
    y     = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1;
    buf <<= (mp_digit)1;

    /* if the bit is zero and mode == 0 then we ignore it
     * These represent the leading zero bits before the first 1 bit
     * in the exponent.  Technically this opt is not required but it
     * does lower the # of trivial squaring/reductions used
     */
    if (mode == 0 && y == 0) {
      continue;
    }

    /* if the bit is zero and mode == 1 then we square */
    if (mode == 1 && y == 0) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, mp)) != MP_OKAY) {
        goto LBL_RES;
      }
      continue;
    }

    /* else we add it to the window */
    bitbuf |= (y << (winsize - ++bitcpy));
    mode    = 2;

    if (bitcpy == winsize) {
      /* ok window is filled so square as required and multiply  */
      /* square first */
      for (x = 0; x < winsize; x++) {
        if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, mp)) != MP_OKAY) {
          goto LBL_RES;
        }
      }

      /* then multiply */
      if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, mp)) != MP_OKAY) {
        goto LBL_RES;
      }

      /* empty window and reset */
      bitcpy = 0;
      bitbuf = 0;
      mode   = 1;
    }
  }

  /* if bits remain then square/multiply */
  if (mode == 2 && bitcpy > 0) {
    /* square then multiply if the bit is set */
    for (x = 0; x < bitcpy; x++) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, mp)) != MP_OKAY) {
        goto LBL_RES;
      }

      /* get next bit of the window */
      bitbuf <<= 1;
      if ((bitbuf & (1 << winsize)) != 0) {
        /* then multiply */
        if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, mp)) != MP_OKAY) {
          goto LBL_RES;
        }
      }
    }
  }

  if (redmode == 0) {
     /* fixup result if Montgomery reduction is used
      * recall that any value in a Montgomery system is
      * actually multiplied by R mod n.  So we have
      * to reduce one more time to cancel out the factor
      * of R.
      */
     if ((err = redux(&res, P, mp)) != MP_OKAY) {
       goto LBL_RES;
     }
  }

  /* swap res with Y */
  mp_exch (&res, Y);
  err = MP_OKAY;
LBL_RES:mp_clear (&res);
LBL_M:
  mp_clear(&M[1]);
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    mp_clear (&M[x]);
  }
  return err;
}
#endif


/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_exptmod_fast.c */

/* Start: bn_mp_exteuclid.c */
#include <tommath.h>
#ifdef BN_MP_EXTEUCLID_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Extended euclidean algorithm of (a, b) produces 
   a*u1 + b*u2 = u3
 */
int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3)
{
   mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp;
   int err;

   if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) {
      return err;
   }

   /* initialize, (u1,u2,u3) = (1,0,a) */
   mp_set(&u1, 1);
   if ((err = mp_copy(a, &u3)) != MP_OKAY)                                        { goto _ERR; }

   /* initialize, (v1,v2,v3) = (0,1,b) */
   mp_set(&v2, 1);
   if ((err = mp_copy(b, &v3)) != MP_OKAY)                                        { goto _ERR; }

   /* loop while v3 != 0 */
   while (mp_iszero(&v3) == MP_NO) {
       /* q = u3/v3 */
       if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY)                         { goto _ERR; }

       /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */
       if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY)                              { goto _ERR; }
       if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY)                             { goto _ERR; }
       if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY)                              { goto _ERR; }
       if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY)                             { goto _ERR; }
       if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY)                              { goto _ERR; }
       if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY)                             { goto _ERR; }

       /* (u1,u2,u3) = (v1,v2,v3) */
       if ((err = mp_copy(&v1, &u1)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&v2, &u2)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&v3, &u3)) != MP_OKAY)                                  { goto _ERR; }

       /* (v1,v2,v3) = (t1,t2,t3) */
       if ((err = mp_copy(&t1, &v1)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&t2, &v2)) != MP_OKAY)                                  { goto _ERR; }
       if ((err = mp_copy(&t3, &v3)) != MP_OKAY)                                  { goto _ERR; }
   }

   /* make sure U3 >= 0 */
   if (u3.sign == MP_NEG) {
      mp_neg(&u1, &u1);
      mp_neg(&u2, &u2);
      mp_neg(&u3, &u3);
   }

   /* copy result out */
   if (U1 != NULL) { mp_exch(U1, &u1); }
   if (U2 != NULL) { mp_exch(U2, &u2); }
   if (U3 != NULL) { mp_exch(U3, &u3); }

   err = MP_OKAY;
_ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL);
   return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_exteuclid.c */

/* Start: bn_mp_fread.c */
#include <tommath.h>
#ifdef BN_MP_FREAD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* read a bigint from a file stream in ASCII */
int mp_fread(mp_int *a, int radix, FILE *stream)
{
   int err, ch, neg, y;
   
   /* clear a */
   mp_zero(a);
   
   /* if first digit is - then set negative */
   ch = fgetc(stream);
   if (ch == '-') {
      neg = MP_NEG;
      ch = fgetc(stream);
   } else {
      neg = MP_ZPOS;
   }
   
   for (;;) {
      /* find y in the radix map */
      for (y = 0; y < radix; y++) {
          if (mp_s_rmap[y] == ch) {
             break;
          }
      }
      if (y == radix) {
         break;
      }
      
      /* shift up and add */
      if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) {
         return err;
      }
      if ((err = mp_add_d(a, y, a)) != MP_OKAY) {
         return err;
      }
      
      ch = fgetc(stream);
   }
   if (mp_cmp_d(a, 0) != MP_EQ) {
      a->sign = neg;
   }
   
   return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_fread.c */

/* Start: bn_mp_fwrite.c */
#include <tommath.h>
#ifdef BN_MP_FWRITE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

int mp_fwrite(mp_int *a, int radix, FILE *stream)
{
   char *buf;
   int err, len, x;
   
   if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
      return err;
   }

   buf = OPT_CAST(char) XMALLOC (len);
   if (buf == NULL) {
      return MP_MEM;
   }
   
   if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) {
      XFREE (buf);
      return err;
   }
   
   for (x = 0; x < len; x++) {
       if (fputc(buf[x], stream) == EOF) {
          XFREE (buf);
          return MP_VAL;
       }
   }
   
   XFREE (buf);
   return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_fwrite.c */

/* Start: bn_mp_gcd.c */
#include <tommath.h>
#ifdef BN_MP_GCD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Greatest Common Divisor using the binary method */
int mp_gcd (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  u, v;
  int     k, u_lsb, v_lsb, res;

  /* either zero than gcd is the largest */
  if (mp_iszero (a) == 1 && mp_iszero (b) == 0) {
    return mp_abs (b, c);
  }
  if (mp_iszero (a) == 0 && mp_iszero (b) == 1) {
    return mp_abs (a, c);
  }

  /* optimized.  At this point if a == 0 then
   * b must equal zero too
   */
  if (mp_iszero (a) == 1) {
    mp_zero(c);
    return MP_OKAY;
  }

  /* get copies of a and b we can modify */
  if ((res = mp_init_copy (&u, a)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init_copy (&v, b)) != MP_OKAY) {
    goto LBL_U;
  }

  /* must be positive for the remainder of the algorithm */
  u.sign = v.sign = MP_ZPOS;

  /* B1.  Find the common power of two for u and v */
  u_lsb = mp_cnt_lsb(&u);
  v_lsb = mp_cnt_lsb(&v);
  k     = MIN(u_lsb, v_lsb);

  if (k > 0) {
     /* divide the power of two out */
     if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) {
        goto LBL_V;
     }

     if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) {
        goto LBL_V;
     }
  }

  /* divide any remaining factors of two out */
  if (u_lsb != k) {
     if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) {
        goto LBL_V;
     }
  }

  if (v_lsb != k) {
     if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) {
        goto LBL_V;
     }
  }

  while (mp_iszero(&v) == 0) {
     /* make sure v is the largest */
     if (mp_cmp_mag(&u, &v) == MP_GT) {
        /* swap u and v to make sure v is >= u */
        mp_exch(&u, &v);
     }
     
     /* subtract smallest from largest */
     if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) {
        goto LBL_V;
     }
     
     /* Divide out all factors of two */
     if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) {
        goto LBL_V;
     } 
  } 

  /* multiply by 2**k which we divided out at the beginning */
  if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) {
     goto LBL_V;
  }
  c->sign = MP_ZPOS;
  res = MP_OKAY;
LBL_V:mp_clear (&u);
LBL_U:mp_clear (&v);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_gcd.c */

/* Start: bn_mp_get_int.c */
#include <tommath.h>
#ifdef BN_MP_GET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* get the lower 32-bits of an mp_int */
unsigned long mp_get_int(mp_int * a) 
{
  int i;
  unsigned long res;

  if (a->used == 0) {
     return 0;
  }

  /* get number of digits of the lsb we have to read */
  i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1;

  /* get most significant digit of result */
  res = DIGIT(a,i);
   
  while (--i >= 0) {
    res = (res << DIGIT_BIT) | DIGIT(a,i);
  }

  /* force result to 32-bits always so it is consistent on non 32-bit platforms */
  return res & 0xFFFFFFFFUL;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_get_int.c */

/* Start: bn_mp_grow.c */
#include <tommath.h>
#ifdef BN_MP_GROW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* grow as required */
int mp_grow (mp_int * a, int size)
{
  int     i;
  mp_digit *tmp;

  /* if the alloc size is smaller alloc more ram */
  if (a->alloc < size) {
    /* ensure there are always at least MP_PREC digits extra on top */
    size += (MP_PREC * 2) - (size % MP_PREC);

    /* reallocate the array a->dp
     *
     * We store the return in a temporary variable
     * in case the operation failed we don't want
     * to overwrite the dp member of a.
     */
    tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size);
    if (tmp == NULL) {
      /* reallocation failed but "a" is still valid [can be freed] */
      return MP_MEM;
    }

    /* reallocation succeeded so set a->dp */
    a->dp = tmp;

    /* zero excess digits */
    i        = a->alloc;
    a->alloc = size;
    for (; i < a->alloc; i++) {
      a->dp[i] = 0;
    }
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_grow.c */

/* Start: bn_mp_init.c */
#include <tommath.h>
#ifdef BN_MP_INIT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* init a new mp_int */
int mp_init (mp_int * a)
{
  int i;

  /* allocate memory required and clear it */
  a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC);
  if (a->dp == NULL) {
    return MP_MEM;
  }

  /* set the digits to zero */
  for (i = 0; i < MP_PREC; i++) {
      a->dp[i] = 0;
  }

  /* set the used to zero, allocated digits to the default precision
   * and sign to positive */
  a->used  = 0;
  a->alloc = MP_PREC;
  a->sign  = MP_ZPOS;

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_init.c */

/* Start: bn_mp_init_copy.c */
#include <tommath.h>
#ifdef BN_MP_INIT_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* creates "a" then copies b into it */
int mp_init_copy (mp_int * a, mp_int * b)
{
  int     res;

  if ((res = mp_init (a)) != MP_OKAY) {
    return res;
  }
  return mp_copy (b, a);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_init_copy.c */

/* Start: bn_mp_init_multi.c */
#include <tommath.h>
#ifdef BN_MP_INIT_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#include <stdarg.h>

int mp_init_multi(mp_int *mp, ...) 
{
    mp_err res = MP_OKAY;      /* Assume ok until proven otherwise */
    int n = 0;                 /* Number of ok inits */
    mp_int* cur_arg = mp;
    va_list args;

    va_start(args, mp);        /* init args to next argument from caller */
    while (cur_arg != NULL) {
        if (mp_init(cur_arg) != MP_OKAY) {
            /* Oops - error! Back-track and mp_clear what we already
               succeeded in init-ing, then return error.
            */
            va_list clean_args;
            
            /* end the current list */
            va_end(args);
            
            /* now start cleaning up */            
            cur_arg = mp;
            va_start(clean_args, mp);
            while (n--) {
                mp_clear(cur_arg);
                cur_arg = va_arg(clean_args, mp_int*);
            }
            va_end(clean_args);
            res = MP_MEM;
            break;
        }
        n++;
        cur_arg = va_arg(args, mp_int*);
    }
    va_end(args);
    return res;                /* Assumed ok, if error flagged above. */
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_init_multi.c */

/* Start: bn_mp_init_set.c */
#include <tommath.h>
#ifdef BN_MP_INIT_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* initialize and set a digit */
int mp_init_set (mp_int * a, mp_digit b)
{
  int err;
  if ((err = mp_init(a)) != MP_OKAY) {
     return err;
  }
  mp_set(a, b);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_init_set.c */

/* Start: bn_mp_init_set_int.c */
#include <tommath.h>
#ifdef BN_MP_INIT_SET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* initialize and set a digit */
int mp_init_set_int (mp_int * a, unsigned long b)
{
  int err;
  if ((err = mp_init(a)) != MP_OKAY) {
     return err;
  }
  return mp_set_int(a, b);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_init_set_int.c */

/* Start: bn_mp_init_size.c */
#include <tommath.h>
#ifdef BN_MP_INIT_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* init an mp_init for a given size */
int mp_init_size (mp_int * a, int size)
{
  int x;

  /* pad size so there are always extra digits */
  size += (MP_PREC * 2) - (size % MP_PREC);	
  
  /* alloc mem */
  a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size);
  if (a->dp == NULL) {
    return MP_MEM;
  }

  /* set the members */
  a->used  = 0;
  a->alloc = size;
  a->sign  = MP_ZPOS;

  /* zero the digits */
  for (x = 0; x < size; x++) {
      a->dp[x] = 0;
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_init_size.c */

/* Start: bn_mp_invmod.c */
#include <tommath.h>
#ifdef BN_MP_INVMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* hac 14.61, pp608 */
int mp_invmod (mp_int * a, mp_int * b, mp_int * c)
{
  /* b cannot be negative */
  if (b->sign == MP_NEG || mp_iszero(b) == 1) {
    return MP_VAL;
  }

#ifdef BN_FAST_MP_INVMOD_C
  /* if the modulus is odd we can use a faster routine instead */
  if (mp_isodd (b) == 1) {
    return fast_mp_invmod (a, b, c);
  }
#endif

#ifdef BN_MP_INVMOD_SLOW_C
  return mp_invmod_slow(a, b, c);
#endif

  return MP_VAL;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_invmod.c */

/* Start: bn_mp_invmod_slow.c */
#include <tommath.h>
#ifdef BN_MP_INVMOD_SLOW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* hac 14.61, pp608 */
int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  x, y, u, v, A, B, C, D;
  int     res;

  /* b cannot be negative */
  if (b->sign == MP_NEG || mp_iszero(b) == 1) {
    return MP_VAL;
  }

  /* init temps */
  if ((res = mp_init_multi(&x, &y, &u, &v, 
                           &A, &B, &C, &D, NULL)) != MP_OKAY) {
     return res;
  }

  /* x = a, y = b */
  if ((res = mp_mod(a, b, &x)) != MP_OKAY) {
      goto LBL_ERR;
  }
  if ((res = mp_copy (b, &y)) != MP_OKAY) {
    goto LBL_ERR;
  }

  /* 2. [modified] if x,y are both even then return an error! */
  if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) {
    res = MP_VAL;
    goto LBL_ERR;
  }

  /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
  if ((res = mp_copy (&x, &u)) != MP_OKAY) {
    goto LBL_ERR;
  }
  if ((res = mp_copy (&y, &v)) != MP_OKAY) {
    goto LBL_ERR;
  }
  mp_set (&A, 1);
  mp_set (&D, 1);

top:
  /* 4.  while u is even do */
  while (mp_iseven (&u) == 1) {
    /* 4.1 u = u/2 */
    if ((res = mp_div_2 (&u, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 4.2 if A or B is odd then */
    if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) {
      /* A = (A+y)/2, B = (B-x)/2 */
      if ((res = mp_add (&A, &y, &A)) != MP_OKAY) {
         goto LBL_ERR;
      }
      if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) {
         goto LBL_ERR;
      }
    }
    /* A = A/2, B = B/2 */
    if ((res = mp_div_2 (&A, &A)) != MP_OKAY) {
      goto LBL_ERR;
    }
    if ((res = mp_div_2 (&B, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 5.  while v is even do */
  while (mp_iseven (&v) == 1) {
    /* 5.1 v = v/2 */
    if ((res = mp_div_2 (&v, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }
    /* 5.2 if C or D is odd then */
    if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) {
      /* C = (C+y)/2, D = (D-x)/2 */
      if ((res = mp_add (&C, &y, &C)) != MP_OKAY) {
         goto LBL_ERR;
      }
      if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) {
         goto LBL_ERR;
      }
    }
    /* C = C/2, D = D/2 */
    if ((res = mp_div_2 (&C, &C)) != MP_OKAY) {
      goto LBL_ERR;
    }
    if ((res = mp_div_2 (&D, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* 6.  if u >= v then */
  if (mp_cmp (&u, &v) != MP_LT) {
    /* u = u - v, A = A - C, B = B - D */
    if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) {
      goto LBL_ERR;
    }
  } else {
    /* v - v - u, C = C - A, D = D - B */
    if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) {
      goto LBL_ERR;
    }

    if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) {
      goto LBL_ERR;
    }
  }

  /* if not zero goto step 4 */
  if (mp_iszero (&u) == 0)
    goto top;

  /* now a = C, b = D, gcd == g*v */

  /* if v != 1 then there is no inverse */
  if (mp_cmp_d (&v, 1) != MP_EQ) {
    res = MP_VAL;
    goto LBL_ERR;
  }

  /* if its too low */
  while (mp_cmp_d(&C, 0) == MP_LT) {
      if ((res = mp_add(&C, b, &C)) != MP_OKAY) {
         goto LBL_ERR;
      }
  }
  
  /* too big */
  while (mp_cmp_mag(&C, b) != MP_LT) {
      if ((res = mp_sub(&C, b, &C)) != MP_OKAY) {
         goto LBL_ERR;
      }
  }
  
  /* C is now the inverse */
  mp_exch (&C, c);
  res = MP_OKAY;
LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_invmod_slow.c */

/* Start: bn_mp_is_square.c */
#include <tommath.h>
#ifdef BN_MP_IS_SQUARE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Check if remainders are possible squares - fast exclude non-squares */
static const char rem_128[128] = {
 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1
};

static const char rem_105[105] = {
 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1,
 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1,
 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1,
 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1,
 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,
 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1,
 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1
};

/* Store non-zero to ret if arg is square, and zero if not */
int mp_is_square(mp_int *arg,int *ret) 
{
  int           res;
  mp_digit      c;
  mp_int        t;
  unsigned long r;

  /* Default to Non-square :) */
  *ret = MP_NO; 

  if (arg->sign == MP_NEG) {
    return MP_VAL;
  }

  /* digits used?  (TSD) */
  if (arg->used == 0) {
     return MP_OKAY;
  }

  /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
  if (rem_128[127 & DIGIT(arg,0)] == 1) {
     return MP_OKAY;
  }

  /* Next check mod 105 (3*5*7) */
  if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) {
     return res;
  }
  if (rem_105[c] == 1) {
     return MP_OKAY;
  }


  if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) {
     return res;
  }
  if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) {
     goto ERR;
  }
  r = mp_get_int(&t);
  /* Check for other prime modules, note it's not an ERROR but we must
   * free "t" so the easiest way is to goto ERR.  We know that res
   * is already equal to MP_OKAY from the mp_mod call 
   */ 
  if ( (1L<<(r%11)) & 0x5C4L )             goto ERR;
  if ( (1L<<(r%13)) & 0x9E4L )             goto ERR;
  if ( (1L<<(r%17)) & 0x5CE8L )            goto ERR;
  if ( (1L<<(r%19)) & 0x4F50CL )           goto ERR;
  if ( (1L<<(r%23)) & 0x7ACCA0L )          goto ERR;
  if ( (1L<<(r%29)) & 0xC2EDD0CL )         goto ERR;
  if ( (1L<<(r%31)) & 0x6DE2B848L )        goto ERR;

  /* Final check - is sqr(sqrt(arg)) == arg ? */
  if ((res = mp_sqrt(arg,&t)) != MP_OKAY) {
     goto ERR;
  }
  if ((res = mp_sqr(&t,&t)) != MP_OKAY) {
     goto ERR;
  }

  *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO;
ERR:mp_clear(&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_is_square.c */

/* Start: bn_mp_jacobi.c */
#include <tommath.h>
#ifdef BN_MP_JACOBI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes the jacobi c = (a | n) (or Legendre if n is prime)
 * HAC pp. 73 Algorithm 2.149
 */
int mp_jacobi (mp_int * a, mp_int * p, int *c)
{
  mp_int  a1, p1;
  int     k, s, r, res;
  mp_digit residue;

  /* if p <= 0 return MP_VAL */
  if (mp_cmp_d(p, 0) != MP_GT) {
     return MP_VAL;
  }

  /* step 1.  if a == 0, return 0 */
  if (mp_iszero (a) == 1) {
    *c = 0;
    return MP_OKAY;
  }

  /* step 2.  if a == 1, return 1 */
  if (mp_cmp_d (a, 1) == MP_EQ) {
    *c = 1;
    return MP_OKAY;
  }

  /* default */
  s = 0;

  /* step 3.  write a = a1 * 2**k  */
  if ((res = mp_init_copy (&a1, a)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init (&p1)) != MP_OKAY) {
    goto LBL_A1;
  }

  /* divide out larger power of two */
  k = mp_cnt_lsb(&a1);
  if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) {
     goto LBL_P1;
  }

  /* step 4.  if e is even set s=1 */
  if ((k & 1) == 0) {
    s = 1;
  } else {
    /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */
    residue = p->dp[0] & 7;

    if (residue == 1 || residue == 7) {
      s = 1;
    } else if (residue == 3 || residue == 5) {
      s = -1;
    }
  }

  /* step 5.  if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */
  if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) {
    s = -s;
  }

  /* if a1 == 1 we're done */
  if (mp_cmp_d (&a1, 1) == MP_EQ) {
    *c = s;
  } else {
    /* n1 = n mod a1 */
    if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) {
      goto LBL_P1;
    }
    if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) {
      goto LBL_P1;
    }
    *c = s * r;
  }

  /* done */
  res = MP_OKAY;
LBL_P1:mp_clear (&p1);
LBL_A1:mp_clear (&a1);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_jacobi.c */

/* Start: bn_mp_karatsuba_mul.c */
#include <tommath.h>
#ifdef BN_MP_KARATSUBA_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* c = |a| * |b| using Karatsuba Multiplication using 
 * three half size multiplications
 *
 * Let B represent the radix [e.g. 2**DIGIT_BIT] and 
 * let n represent half of the number of digits in 
 * the min(a,b)
 *
 * a = a1 * B**n + a0
 * b = b1 * B**n + b0
 *
 * Then, a * b => 
   a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0
 *
 * Note that a1b1 and a0b0 are used twice and only need to be 
 * computed once.  So in total three half size (half # of 
 * digit) multiplications are performed, a0b0, a1b1 and 
 * (a1+b1)(a0+b0)
 *
 * Note that a multiplication of half the digits requires
 * 1/4th the number of single precision multiplications so in 
 * total after one call 25% of the single precision multiplications 
 * are saved.  Note also that the call to mp_mul can end up back 
 * in this function if the a0, a1, b0, or b1 are above the threshold.  
 * This is known as divide-and-conquer and leads to the famous 
 * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than 
 * the standard O(N**2) that the baseline/comba methods use.  
 * Generally though the overhead of this method doesn't pay off 
 * until a certain size (N ~ 80) is reached.
 */
int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  x0, x1, y0, y1, t1, x0y0, x1y1;
  int     B, err;

  /* default the return code to an error */
  err = MP_MEM;

  /* min # of digits */
  B = MIN (a->used, b->used);

  /* now divide in two */
  B = B >> 1;

  /* init copy all the temps */
  if (mp_init_size (&x0, B) != MP_OKAY)
    goto ERR;
  if (mp_init_size (&x1, a->used - B) != MP_OKAY)
    goto X0;
  if (mp_init_size (&y0, B) != MP_OKAY)
    goto X1;
  if (mp_init_size (&y1, b->used - B) != MP_OKAY)
    goto Y0;

  /* init temps */
  if (mp_init_size (&t1, B * 2) != MP_OKAY)
    goto Y1;
  if (mp_init_size (&x0y0, B * 2) != MP_OKAY)
    goto T1;
  if (mp_init_size (&x1y1, B * 2) != MP_OKAY)
    goto X0Y0;

  /* now shift the digits */
  x0.used = y0.used = B;
  x1.used = a->used - B;
  y1.used = b->used - B;

  {
    register int x;
    register mp_digit *tmpa, *tmpb, *tmpx, *tmpy;

    /* we copy the digits directly instead of using higher level functions
     * since we also need to shift the digits
     */
    tmpa = a->dp;
    tmpb = b->dp;

    tmpx = x0.dp;
    tmpy = y0.dp;
    for (x = 0; x < B; x++) {
      *tmpx++ = *tmpa++;
      *tmpy++ = *tmpb++;
    }

    tmpx = x1.dp;
    for (x = B; x < a->used; x++) {
      *tmpx++ = *tmpa++;
    }

    tmpy = y1.dp;
    for (x = B; x < b->used; x++) {
      *tmpy++ = *tmpb++;
    }
  }

  /* only need to clamp the lower words since by definition the 
   * upper words x1/y1 must have a known number of digits
   */
  mp_clamp (&x0);
  mp_clamp (&y0);

  /* now calc the products x0y0 and x1y1 */
  /* after this x0 is no longer required, free temp [x0==t2]! */
  if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY)  
    goto X1Y1;          /* x0y0 = x0*y0 */
  if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY)
    goto X1Y1;          /* x1y1 = x1*y1 */

  /* now calc x1+x0 and y1+y0 */
  if (s_mp_add (&x1, &x0, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = x1 - x0 */
  if (s_mp_add (&y1, &y0, &x0) != MP_OKAY)
    goto X1Y1;          /* t2 = y1 - y0 */
  if (mp_mul (&t1, &x0, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = (x1 + x0) * (y1 + y0) */

  /* add x0y0 */
  if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY)
    goto X1Y1;          /* t2 = x0y0 + x1y1 */
  if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */

  /* shift by B */
  if (mp_lshd (&t1, B) != MP_OKAY)
    goto X1Y1;          /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<<B */
  if (mp_lshd (&x1y1, B * 2) != MP_OKAY)
    goto X1Y1;          /* x1y1 = x1y1 << 2*B */

  if (mp_add (&x0y0, &t1, &t1) != MP_OKAY)
    goto X1Y1;          /* t1 = x0y0 + t1 */
  if (mp_add (&t1, &x1y1, c) != MP_OKAY)
    goto X1Y1;          /* t1 = x0y0 + t1 + x1y1 */

  /* Algorithm succeeded set the return code to MP_OKAY */
  err = MP_OKAY;

X1Y1:mp_clear (&x1y1);
X0Y0:mp_clear (&x0y0);
T1:mp_clear (&t1);
Y1:mp_clear (&y1);
Y0:mp_clear (&y0);
X1:mp_clear (&x1);
X0:mp_clear (&x0);
ERR:
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_karatsuba_mul.c */

/* Start: bn_mp_karatsuba_sqr.c */
#include <tommath.h>
#ifdef BN_MP_KARATSUBA_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Karatsuba squaring, computes b = a*a using three 
 * half size squarings
 *
 * See comments of karatsuba_mul for details.  It 
 * is essentially the same algorithm but merely 
 * tuned to perform recursive squarings.
 */
int mp_karatsuba_sqr (mp_int * a, mp_int * b)
{
  mp_int  x0, x1, t1, t2, x0x0, x1x1;
  int     B, err;

  err = MP_MEM;

  /* min # of digits */
  B = a->used;

  /* now divide in two */
  B = B >> 1;

  /* init copy all the temps */
  if (mp_init_size (&x0, B) != MP_OKAY)
    goto ERR;
  if (mp_init_size (&x1, a->used - B) != MP_OKAY)
    goto X0;

  /* init temps */
  if (mp_init_size (&t1, a->used * 2) != MP_OKAY)
    goto X1;
  if (mp_init_size (&t2, a->used * 2) != MP_OKAY)
    goto T1;
  if (mp_init_size (&x0x0, B * 2) != MP_OKAY)
    goto T2;
  if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY)
    goto X0X0;

  {
    register int x;
    register mp_digit *dst, *src;

    src = a->dp;

    /* now shift the digits */
    dst = x0.dp;
    for (x = 0; x < B; x++) {
      *dst++ = *src++;
    }

    dst = x1.dp;
    for (x = B; x < a->used; x++) {
      *dst++ = *src++;
    }
  }

  x0.used = B;
  x1.used = a->used - B;

  mp_clamp (&x0);

  /* now calc the products x0*x0 and x1*x1 */
  if (mp_sqr (&x0, &x0x0) != MP_OKAY)
    goto X1X1;           /* x0x0 = x0*x0 */
  if (mp_sqr (&x1, &x1x1) != MP_OKAY)
    goto X1X1;           /* x1x1 = x1*x1 */

  /* now calc (x1+x0)**2 */
  if (s_mp_add (&x1, &x0, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = x1 - x0 */
  if (mp_sqr (&t1, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = (x1 - x0) * (x1 - x0) */

  /* add x0y0 */
  if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY)
    goto X1X1;           /* t2 = x0x0 + x1x1 */
  if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */

  /* shift by B */
  if (mp_lshd (&t1, B) != MP_OKAY)
    goto X1X1;           /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<<B */
  if (mp_lshd (&x1x1, B * 2) != MP_OKAY)
    goto X1X1;           /* x1x1 = x1x1 << 2*B */

  if (mp_add (&x0x0, &t1, &t1) != MP_OKAY)
    goto X1X1;           /* t1 = x0x0 + t1 */
  if (mp_add (&t1, &x1x1, b) != MP_OKAY)
    goto X1X1;           /* t1 = x0x0 + t1 + x1x1 */

  err = MP_OKAY;

X1X1:mp_clear (&x1x1);
X0X0:mp_clear (&x0x0);
T2:mp_clear (&t2);
T1:mp_clear (&t1);
X1:mp_clear (&x1);
X0:mp_clear (&x0);
ERR:
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_karatsuba_sqr.c */

/* Start: bn_mp_lcm.c */
#include <tommath.h>
#ifdef BN_MP_LCM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes least common multiple as |a*b|/(a, b) */
int mp_lcm (mp_int * a, mp_int * b, mp_int * c)
{
  int     res;
  mp_int  t1, t2;


  if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) {
    return res;
  }

  /* t1 = get the GCD of the two inputs */
  if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) {
    goto LBL_T;
  }

  /* divide the smallest by the GCD */
  if (mp_cmp_mag(a, b) == MP_LT) {
     /* store quotient in t2 such that t2 * b is the LCM */
     if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) {
        goto LBL_T;
     }
     res = mp_mul(b, &t2, c);
  } else {
     /* store quotient in t2 such that t2 * a is the LCM */
     if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) {
        goto LBL_T;
     }
     res = mp_mul(a, &t2, c);
  }

  /* fix the sign to positive */
  c->sign = MP_ZPOS;

LBL_T:
  mp_clear_multi (&t1, &t2, NULL);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_lcm.c */

/* Start: bn_mp_lshd.c */
#include <tommath.h>
#ifdef BN_MP_LSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift left a certain amount of digits */
int mp_lshd (mp_int * a, int b)
{
  int     x, res;

  /* if its less than zero return */
  if (b <= 0) {
    return MP_OKAY;
  }

  /* grow to fit the new digits */
  if (a->alloc < a->used + b) {
     if ((res = mp_grow (a, a->used + b)) != MP_OKAY) {
       return res;
     }
  }

  {
    register mp_digit *top, *bottom;

    /* increment the used by the shift amount then copy upwards */
    a->used += b;

    /* top */
    top = a->dp + a->used - 1;

    /* base */
    bottom = a->dp + a->used - 1 - b;

    /* much like mp_rshd this is implemented using a sliding window
     * except the window goes the otherway around.  Copying from
     * the bottom to the top.  see bn_mp_rshd.c for more info.
     */
    for (x = a->used - 1; x >= b; x--) {
      *top-- = *bottom--;
    }

    /* zero the lower digits */
    top = a->dp;
    for (x = 0; x < b; x++) {
      *top++ = 0;
    }
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_lshd.c */

/* Start: bn_mp_mod.c */
#include <tommath.h>
#ifdef BN_MP_MOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* c = a mod b, 0 <= c < b */
int
mp_mod (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int  t;
  int     res;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }

  if (t.sign != b->sign) {
    res = mp_add (b, &t, c);
  } else {
    res = MP_OKAY;
    mp_exch (&t, c);
  }

  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mod.c */

/* Start: bn_mp_mod_2d.c */
#include <tommath.h>
#ifdef BN_MP_MOD_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* calc a value mod 2**b */
int
mp_mod_2d (mp_int * a, int b, mp_int * c)
{
  int     x, res;

  /* if b is <= 0 then zero the int */
  if (b <= 0) {
    mp_zero (c);
    return MP_OKAY;
  }

  /* if the modulus is larger than the value than return */
  if (b >= (int) (a->used * DIGIT_BIT)) {
    res = mp_copy (a, c);
    return res;
  }

  /* copy */
  if ((res = mp_copy (a, c)) != MP_OKAY) {
    return res;
  }

  /* zero digits above the last digit of the modulus */
  for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) {
    c->dp[x] = 0;
  }
  /* clear the digit that is not completely outside/inside the modulus */
  c->dp[b / DIGIT_BIT] &=
    (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1));
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mod_2d.c */

/* Start: bn_mp_mod_d.c */
#include <tommath.h>
#ifdef BN_MP_MOD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

int
mp_mod_d (mp_int * a, mp_digit b, mp_digit * c)
{
  return mp_div_d(a, b, NULL, c);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mod_d.c */

/* Start: bn_mp_montgomery_calc_normalization.c */
#include <tommath.h>
#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/*
 * shifts with subtractions when the result is greater than b.
 *
 * The method is slightly modified to shift B unconditionally upto just under
 * the leading bit of b.  This saves alot of multiple precision shifting.
 */
int mp_montgomery_calc_normalization (mp_int * a, mp_int * b)
{
  int     x, bits, res;

  /* how many bits of last digit does b use */
  bits = mp_count_bits (b) % DIGIT_BIT;

  if (b->used > 1) {
     if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) {
        return res;
     }
  } else {
     mp_set(a, 1);
     bits = 1;
  }


  /* now compute C = A * B mod b */
  for (x = bits - 1; x < (int)DIGIT_BIT; x++) {
    if ((res = mp_mul_2 (a, a)) != MP_OKAY) {
      return res;
    }
    if (mp_cmp_mag (a, b) != MP_LT) {
      if ((res = s_mp_sub (a, b, a)) != MP_OKAY) {
        return res;
      }
    }
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_montgomery_calc_normalization.c */

/* Start: bn_mp_montgomery_reduce.c */
#include <tommath.h>
#ifdef BN_MP_MONTGOMERY_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes xR**-1 == x (mod N) via Montgomery Reduction */
int
mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho)
{
  int     ix, res, digs;
  mp_digit mu;

  /* can the fast reduction [comba] method be used?
   *
   * Note that unlike in mul you're safely allowed *less*
   * than the available columns [255 per default] since carries
   * are fixed up in the inner loop.
   */
  digs = n->used * 2 + 1;
  if ((digs < MP_WARRAY) &&
      n->used <
      (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
    return fast_mp_montgomery_reduce (x, n, rho);
  }

  /* grow the input as required */
  if (x->alloc < digs) {
    if ((res = mp_grow (x, digs)) != MP_OKAY) {
      return res;
    }
  }
  x->used = digs;

  for (ix = 0; ix < n->used; ix++) {
    /* mu = ai * rho mod b
     *
     * The value of rho must be precalculated via
     * montgomery_setup() such that
     * it equals -1/n0 mod b this allows the
     * following inner loop to reduce the
     * input one digit at a time
     */
    mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK);

    /* a = a + mu * m * b**i */
    {
      register int iy;
      register mp_digit *tmpn, *tmpx, u;
      register mp_word r;

      /* alias for digits of the modulus */
      tmpn = n->dp;

      /* alias for the digits of x [the input] */
      tmpx = x->dp + ix;

      /* set the carry to zero */
      u = 0;

      /* Multiply and add in place */
      for (iy = 0; iy < n->used; iy++) {
        /* compute product and sum */
        r       = ((mp_word)mu) * ((mp_word)*tmpn++) +
                  ((mp_word) u) + ((mp_word) * tmpx);

        /* get carry */
        u       = (mp_digit)(r >> ((mp_word) DIGIT_BIT));

        /* fix digit */
        *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK));
      }
      /* At this point the ix'th digit of x should be zero */


      /* propagate carries upwards as required*/
      while (u) {
        *tmpx   += u;
        u        = *tmpx >> DIGIT_BIT;
        *tmpx++ &= MP_MASK;
      }
    }
  }

  /* at this point the n.used'th least
   * significant digits of x are all zero
   * which means we can shift x to the
   * right by n.used digits and the
   * residue is unchanged.
   */

  /* x = x/b**n.used */
  mp_clamp(x);
  mp_rshd (x, n->used);

  /* if x >= n then x = x - n */
  if (mp_cmp_mag (x, n) != MP_LT) {
    return s_mp_sub (x, n, x);
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_montgomery_reduce.c */

/* Start: bn_mp_montgomery_setup.c */
#include <tommath.h>
#ifdef BN_MP_MONTGOMERY_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* setups the montgomery reduction stuff */
int
mp_montgomery_setup (mp_int * n, mp_digit * rho)
{
  mp_digit x, b;

/* fast inversion mod 2**k
 *
 * Based on the fact that
 *
 * XA = 1 (mod 2**n)  =>  (X(2-XA)) A = 1 (mod 2**2n)
 *                    =>  2*X*A - X*X*A*A = 1
 *                    =>  2*(1) - (1)     = 1
 */
  b = n->dp[0];

  if ((b & 1) == 0) {
    return MP_VAL;
  }

  x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */
  x *= 2 - b * x;               /* here x*a==1 mod 2**8 */
#if !defined(MP_8BIT)
  x *= 2 - b * x;               /* here x*a==1 mod 2**16 */
#endif
#if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT))
  x *= 2 - b * x;               /* here x*a==1 mod 2**32 */
#endif
#ifdef MP_64BIT
  x *= 2 - b * x;               /* here x*a==1 mod 2**64 */
#endif

  /* rho = -1/m mod b */
  *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK;

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_montgomery_setup.c */

/* Start: bn_mp_mul.c */
#include <tommath.h>
#ifdef BN_MP_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* high level multiplication (handles sign) */
int mp_mul (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, neg;
  neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;

  /* use Toom-Cook? */
#ifdef BN_MP_TOOM_MUL_C
  if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) {
    res = mp_toom_mul(a, b, c);
  } else 
#endif
#ifdef BN_MP_KARATSUBA_MUL_C
  /* use Karatsuba? */
  if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) {
    res = mp_karatsuba_mul (a, b, c);
  } else 
#endif
  {
    /* can we use the fast multiplier?
     *
     * The fast multiplier can be used if the output will 
     * have less than MP_WARRAY digits and the number of 
     * digits won't affect carry propagation
     */
    int     digs = a->used + b->used + 1;

#ifdef BN_FAST_S_MP_MUL_DIGS_C
    if ((digs < MP_WARRAY) &&
        MIN(a->used, b->used) <= 
        (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
      res = fast_s_mp_mul_digs (a, b, c, digs);
    } else 
#endif
#ifdef BN_S_MP_MUL_DIGS_C
      res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */
#else
      res = MP_VAL;
#endif

  }
  c->sign = (c->used > 0) ? neg : MP_ZPOS;
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mul.c */

/* Start: bn_mp_mul_2.c */
#include <tommath.h>
#ifdef BN_MP_MUL_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = a*2 */
int mp_mul_2(mp_int * a, mp_int * b)
{
  int     x, res, oldused;

  /* grow to accomodate result */
  if (b->alloc < a->used + 1) {
    if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) {
      return res;
    }
  }

  oldused = b->used;
  b->used = a->used;

  {
    register mp_digit r, rr, *tmpa, *tmpb;

    /* alias for source */
    tmpa = a->dp;
    
    /* alias for dest */
    tmpb = b->dp;

    /* carry */
    r = 0;
    for (x = 0; x < a->used; x++) {
    
      /* get what will be the *next* carry bit from the 
       * MSB of the current digit 
       */
      rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1));
      
      /* now shift up this digit, add in the carry [from the previous] */
      *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK;
      
      /* copy the carry that would be from the source 
       * digit into the next iteration 
       */
      r = rr;
    }

    /* new leading digit? */
    if (r != 0) {
      /* add a MSB which is always 1 at this point */
      *tmpb = 1;
      ++(b->used);
    }

    /* now zero any excess digits on the destination 
     * that we didn't write to 
     */
    tmpb = b->dp + b->used;
    for (x = b->used; x < oldused; x++) {
      *tmpb++ = 0;
    }
  }
  b->sign = a->sign;
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mul_2.c */

/* Start: bn_mp_mul_2d.c */
#include <tommath.h>
#ifdef BN_MP_MUL_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift left by a certain bit count */
int mp_mul_2d (mp_int * a, int b, mp_int * c)
{
  mp_digit d;
  int      res;

  /* copy */
  if (a != c) {
     if ((res = mp_copy (a, c)) != MP_OKAY) {
       return res;
     }
  }

  if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) {
     if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) {
       return res;
     }
  }

  /* shift by as many digits in the bit count */
  if (b >= (int)DIGIT_BIT) {
    if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) {
      return res;
    }
  }

  /* shift any bit count < DIGIT_BIT */
  d = (mp_digit) (b % DIGIT_BIT);
  if (d != 0) {
    register mp_digit *tmpc, shift, mask, r, rr;
    register int x;

    /* bitmask for carries */
    mask = (((mp_digit)1) << d) - 1;

    /* shift for msbs */
    shift = DIGIT_BIT - d;

    /* alias */
    tmpc = c->dp;

    /* carry */
    r    = 0;
    for (x = 0; x < c->used; x++) {
      /* get the higher bits of the current word */
      rr = (*tmpc >> shift) & mask;

      /* shift the current word and OR in the carry */
      *tmpc = ((*tmpc << d) | r) & MP_MASK;
      ++tmpc;

      /* set the carry to the carry bits of the current word */
      r = rr;
    }
    
    /* set final carry */
    if (r != 0) {
       c->dp[(c->used)++] = r;
    }
  }
  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mul_2d.c */

/* Start: bn_mp_mul_d.c */
#include <tommath.h>
#ifdef BN_MP_MUL_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiply by a digit */
int
mp_mul_d (mp_int * a, mp_digit b, mp_int * c)
{
  mp_digit u, *tmpa, *tmpc;
  mp_word  r;
  int      ix, res, olduse;

  /* make sure c is big enough to hold a*b */
  if (c->alloc < a->used + 1) {
    if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) {
      return res;
    }
  }

  /* get the original destinations used count */
  olduse = c->used;

  /* set the sign */
  c->sign = a->sign;

  /* alias for a->dp [source] */
  tmpa = a->dp;

  /* alias for c->dp [dest] */
  tmpc = c->dp;

  /* zero carry */
  u = 0;

  /* compute columns */
  for (ix = 0; ix < a->used; ix++) {
    /* compute product and carry sum for this term */
    r       = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b);

    /* mask off higher bits to get a single digit */
    *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK));

    /* send carry into next iteration */
    u       = (mp_digit) (r >> ((mp_word) DIGIT_BIT));
  }

  /* store final carry [if any] and increment ix offset  */
  *tmpc++ = u;
  ++ix;

  /* now zero digits above the top */
  while (ix++ < olduse) {
     *tmpc++ = 0;
  }

  /* set used count */
  c->used = a->used + 1;
  mp_clamp(c);

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mul_d.c */

/* Start: bn_mp_mulmod.c */
#include <tommath.h>
#ifdef BN_MP_MULMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* d = a * b (mod c) */
int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  int     res;
  mp_int  t;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_mul (a, b, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, c, d);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_mulmod.c */

/* Start: bn_mp_n_root.c */
#include <tommath.h>
#ifdef BN_MP_N_ROOT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* find the n'th root of an integer 
 *
 * Result found such that (c)**b <= a and (c+1)**b > a 
 *
 * This algorithm uses Newton's approximation 
 * x[i+1] = x[i] - f(x[i])/f'(x[i]) 
 * which will find the root in log(N) time where 
 * each step involves a fair bit.  This is not meant to 
 * find huge roots [square and cube, etc].
 */
int mp_n_root (mp_int * a, mp_digit b, mp_int * c)
{
  mp_int  t1, t2, t3;
  int     res, neg;

  /* input must be positive if b is even */
  if ((b & 1) == 0 && a->sign == MP_NEG) {
    return MP_VAL;
  }

  if ((res = mp_init (&t1)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init (&t2)) != MP_OKAY) {
    goto LBL_T1;
  }

  if ((res = mp_init (&t3)) != MP_OKAY) {
    goto LBL_T2;
  }

  /* if a is negative fudge the sign but keep track */
  neg     = a->sign;
  a->sign = MP_ZPOS;

  /* t2 = 2 */
  mp_set (&t2, 2);

  do {
    /* t1 = t2 */
    if ((res = mp_copy (&t2, &t1)) != MP_OKAY) {
      goto LBL_T3;
    }

    /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */
    
    /* t3 = t1**(b-1) */
    if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) {   
      goto LBL_T3;
    }

    /* numerator */
    /* t2 = t1**b */
    if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) {    
      goto LBL_T3;
    }

    /* t2 = t1**b - a */
    if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) {  
      goto LBL_T3;
    }

    /* denominator */
    /* t3 = t1**(b-1) * b  */
    if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) {    
      goto LBL_T3;
    }

    /* t3 = (t1**b - a)/(b * t1**(b-1)) */
    if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) {  
      goto LBL_T3;
    }

    if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) {
      goto LBL_T3;
    }
  }  while (mp_cmp (&t1, &t2) != MP_EQ);

  /* result can be off by a few so check */
  for (;;) {
    if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) {
      goto LBL_T3;
    }

    if (mp_cmp (&t2, a) == MP_GT) {
      if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) {
         goto LBL_T3;
      }
    } else {
      break;
    }
  }

  /* reset the sign of a first */
  a->sign = neg;

  /* set the result */
  mp_exch (&t1, c);

  /* set the sign of the result */
  c->sign = neg;

  res = MP_OKAY;

LBL_T3:mp_clear (&t3);
LBL_T2:mp_clear (&t2);
LBL_T1:mp_clear (&t1);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_n_root.c */

/* Start: bn_mp_neg.c */
#include <tommath.h>
#ifdef BN_MP_NEG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* b = -a */
int mp_neg (mp_int * a, mp_int * b)
{
  int     res;
  if (a != b) {
     if ((res = mp_copy (a, b)) != MP_OKAY) {
        return res;
     }
  }

  if (mp_iszero(b) != MP_YES) {
     b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS;
  } else {
     b->sign = MP_ZPOS;
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_neg.c */

/* Start: bn_mp_or.c */
#include <tommath.h>
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* OR two ints together */
int mp_or (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, ix, px;
  mp_int  t, *x;

  if (a->used > b->used) {
    if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
      return res;
    }
    px = b->used;
    x = b;
  } else {
    if ((res = mp_init_copy (&t, b)) != MP_OKAY) {
      return res;
    }
    px = a->used;
    x = a;
  }

  for (ix = 0; ix < px; ix++) {
    t.dp[ix] |= x->dp[ix];
  }
  mp_clamp (&t);
  mp_exch (c, &t);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_or.c */

/* Start: bn_mp_prime_fermat.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_FERMAT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* performs one Fermat test.
 * 
 * If "a" were prime then b**a == b (mod a) since the order of
 * the multiplicative sub-group would be phi(a) = a-1.  That means
 * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a).
 *
 * Sets result to 1 if the congruence holds, or zero otherwise.
 */
int mp_prime_fermat (mp_int * a, mp_int * b, int *result)
{
  mp_int  t;
  int     err;

  /* default to composite  */
  *result = MP_NO;

  /* ensure b > 1 */
  if (mp_cmp_d(b, 1) != MP_GT) {
     return MP_VAL;
  }

  /* init t */
  if ((err = mp_init (&t)) != MP_OKAY) {
    return err;
  }

  /* compute t = b**a mod a */
  if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) {
    goto LBL_T;
  }

  /* is it equal to b? */
  if (mp_cmp (&t, b) == MP_EQ) {
    *result = MP_YES;
  }

  err = MP_OKAY;
LBL_T:mp_clear (&t);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_fermat.c */

/* Start: bn_mp_prime_is_divisible.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_IS_DIVISIBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if an integers is divisible by one 
 * of the first PRIME_SIZE primes or not
 *
 * sets result to 0 if not, 1 if yes
 */
int mp_prime_is_divisible (mp_int * a, int *result)
{
  int     err, ix;
  mp_digit res;

  /* default to not */
  *result = MP_NO;

  for (ix = 0; ix < PRIME_SIZE; ix++) {
    /* what is a mod LBL_prime_tab[ix] */
    if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) {
      return err;
    }

    /* is the residue zero? */
    if (res == 0) {
      *result = MP_YES;
      return MP_OKAY;
    }
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_is_divisible.c */

/* Start: bn_mp_prime_is_prime.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_IS_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* performs a variable number of rounds of Miller-Rabin
 *
 * Probability of error after t rounds is no more than

 *
 * Sets result to 1 if probably prime, 0 otherwise
 */
int mp_prime_is_prime (mp_int * a, int t, int *result)
{
  mp_int  b;
  int     ix, err, res;

  /* default to no */
  *result = MP_NO;

  /* valid value of t? */
  if (t <= 0 || t > PRIME_SIZE) {
    return MP_VAL;
  }

  /* is the input equal to one of the primes in the table? */
  for (ix = 0; ix < PRIME_SIZE; ix++) {
      if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) {
         *result = 1;
         return MP_OKAY;
      }
  }

  /* first perform trial division */
  if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) {
    return err;
  }

  /* return if it was trivially divisible */
  if (res == MP_YES) {
    return MP_OKAY;
  }

  /* now perform the miller-rabin rounds */
  if ((err = mp_init (&b)) != MP_OKAY) {
    return err;
  }

  for (ix = 0; ix < t; ix++) {
    /* set the prime */
    mp_set (&b, ltm_prime_tab[ix]);

    if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) {
      goto LBL_B;
    }

    if (res == MP_NO) {
      goto LBL_B;
    }
  }

  /* passed the test */
  *result = MP_YES;
LBL_B:mp_clear (&b);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_is_prime.c */

/* Start: bn_mp_prime_miller_rabin.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_MILLER_RABIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Miller-Rabin test of "a" to the base of "b" as described in 
 * HAC pp. 139 Algorithm 4.24
 *
 * Sets result to 0 if definitely composite or 1 if probably prime.
 * Randomly the chance of error is no more than 1/4 and often 
 * very much lower.
 */
int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result)
{
  mp_int  n1, y, r;
  int     s, j, err;

  /* default */
  *result = MP_NO;

  /* ensure b > 1 */
  if (mp_cmp_d(b, 1) != MP_GT) {
     return MP_VAL;
  }     

  /* get n1 = a - 1 */
  if ((err = mp_init_copy (&n1, a)) != MP_OKAY) {
    return err;
  }
  if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) {
    goto LBL_N1;
  }

  /* set 2**s * r = n1 */
  if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) {
    goto LBL_N1;
  }

  /* count the number of least significant bits
   * which are zero
   */
  s = mp_cnt_lsb(&r);

  /* now divide n - 1 by 2**s */
  if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) {
    goto LBL_R;
  }

  /* compute y = b**r mod a */
  if ((err = mp_init (&y)) != MP_OKAY) {
    goto LBL_R;
  }
  if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) {
    goto LBL_Y;
  }

  /* if y != 1 and y != n1 do */
  if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) {
    j = 1;
    /* while j <= s-1 and y != n1 */
    while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) {
      if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) {
         goto LBL_Y;
      }

      /* if y == 1 then composite */
      if (mp_cmp_d (&y, 1) == MP_EQ) {
         goto LBL_Y;
      }

      ++j;
    }

    /* if y != n1 then composite */
    if (mp_cmp (&y, &n1) != MP_EQ) {
      goto LBL_Y;
    }
  }

  /* probably prime now */
  *result = MP_YES;
LBL_Y:mp_clear (&y);
LBL_R:mp_clear (&r);
LBL_N1:mp_clear (&n1);
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_miller_rabin.c */

/* Start: bn_mp_prime_next_prime.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_NEXT_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* finds the next prime after the number "a" using "t" trials
 * of Miller-Rabin.
 *
 * bbs_style = 1 means the prime must be congruent to 3 mod 4
 */
int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
{
   int      err, res, x, y;
   mp_digit res_tab[PRIME_SIZE], step, kstep;
   mp_int   b;

   /* ensure t is valid */
   if (t <= 0 || t > PRIME_SIZE) {
      return MP_VAL;
   }

   /* force positive */
   a->sign = MP_ZPOS;

   /* simple algo if a is less than the largest prime in the table */
   if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) {
      /* find which prime it is bigger than */
      for (x = PRIME_SIZE - 2; x >= 0; x--) {
          if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) {
             if (bbs_style == 1) {
                /* ok we found a prime smaller or
                 * equal [so the next is larger]
                 *
                 * however, the prime must be
                 * congruent to 3 mod 4
                 */
                if ((ltm_prime_tab[x + 1] & 3) != 3) {
                   /* scan upwards for a prime congruent to 3 mod 4 */
                   for (y = x + 1; y < PRIME_SIZE; y++) {
                       if ((ltm_prime_tab[y] & 3) == 3) {
                          mp_set(a, ltm_prime_tab[y]);
                          return MP_OKAY;
                       }
                   }
                }
             } else {
                mp_set(a, ltm_prime_tab[x + 1]);
                return MP_OKAY;
             }
          }
      }
      /* at this point a maybe 1 */
      if (mp_cmp_d(a, 1) == MP_EQ) {
         mp_set(a, 2);
         return MP_OKAY;
      }
      /* fall through to the sieve */
   }

   /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */
   if (bbs_style == 1) {
      kstep   = 4;
   } else {
      kstep   = 2;
   }

   /* at this point we will use a combination of a sieve and Miller-Rabin */

   if (bbs_style == 1) {
      /* if a mod 4 != 3 subtract the correct value to make it so */
      if ((a->dp[0] & 3) != 3) {
         if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; };
      }
   } else {
      if (mp_iseven(a) == 1) {
         /* force odd */
         if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) {
            return err;
         }
      }
   }

   /* generate the restable */
   for (x = 1; x < PRIME_SIZE; x++) {
      if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) {
         return err;
      }
   }

   /* init temp used for Miller-Rabin Testing */
   if ((err = mp_init(&b)) != MP_OKAY) {
      return err;
   }

   for (;;) {
      /* skip to the next non-trivially divisible candidate */
      step = 0;
      do {
         /* y == 1 if any residue was zero [e.g. cannot be prime] */
         y     =  0;

         /* increase step to next candidate */
         step += kstep;

         /* compute the new residue without using division */
         for (x = 1; x < PRIME_SIZE; x++) {
             /* add the step to each residue */
             res_tab[x] += kstep;

             /* subtract the modulus [instead of using division] */
             if (res_tab[x] >= ltm_prime_tab[x]) {
                res_tab[x]  -= ltm_prime_tab[x];
             }

             /* set flag if zero */
             if (res_tab[x] == 0) {
                y = 1;
             }
         }
      } while (y == 1 && step < ((((mp_digit)1)<<DIGIT_BIT) - kstep));

      /* add the step */
      if ((err = mp_add_d(a, step, a)) != MP_OKAY) {
         goto LBL_ERR;
      }

      /* if didn't pass sieve and step == MAX then skip test */
      if (y == 1 && step >= ((((mp_digit)1)<<DIGIT_BIT) - kstep)) {
         continue;
      }

      /* is this prime? */
      for (x = 0; x < t; x++) {
          mp_set(&b, ltm_prime_tab[t]);
          if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
             goto LBL_ERR;
          }
          if (res == MP_NO) {
             break;
          }
      }

      if (res == MP_YES) {
         break;
      }
   }

   err = MP_OKAY;
LBL_ERR:
   mp_clear(&b);
   return err;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_next_prime.c */

/* Start: bn_mp_prime_rabin_miller_trials.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */


static const struct {
   int k, t;
} sizes[] = {
{   128,    28 },
{   256,    16 },
{   384,    10 },
{   512,     7 },
{   640,     6 },
{   768,     5 },
{   896,     4 },
{  1024,     4 }
};

/* returns # of RM trials required for a given bit size */
int mp_prime_rabin_miller_trials(int size)
{
   int x;

   for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) {
       if (sizes[x].k == size) {
          return sizes[x].t;
       } else if (sizes[x].k > size) {
          return (x == 0) ? sizes[0].t : sizes[x - 1].t;
       }
   }
   return sizes[x-1].t + 1;
}


#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_rabin_miller_trials.c */

/* Start: bn_mp_prime_random_ex.c */
#include <tommath.h>
#ifdef BN_MP_PRIME_RANDOM_EX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* makes a truly random prime of a given size (bits),
 *
 * Flags are as follows:
 * 
 *   LTM_PRIME_BBS      - make prime congruent to 3 mod 4
 *   LTM_PRIME_SAFE     - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS)
 *   LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero
 *   LTM_PRIME_2MSB_ON  - make the 2nd highest bit one
 *
 * You have to supply a callback which fills in a buffer with random bytes.  "dat" is a parameter you can
 * have passed to the callback (e.g. a state or something).  This function doesn't use "dat" itself
 * so it can be NULL
 *
 */

/* This is possibly the mother of all prime generation functions, muahahahahaha! */
int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat)
{
   unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb;
   int res, err, bsize, maskOR_msb_offset;

   /* sanity check the input */
   if (size <= 1 || t <= 0) {
      return MP_VAL;
   }

   /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */
   if (flags & LTM_PRIME_SAFE) {
      flags |= LTM_PRIME_BBS;
   }

   /* calc the byte size */
   bsize = (size>>3) + ((size&7)?1:0);

   /* we need a buffer of bsize bytes */
   tmp = OPT_CAST(unsigned char) XMALLOC(bsize);
   if (tmp == NULL) {
      return MP_MEM;
   }

   /* calc the maskAND value for the MSbyte*/
   maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7)));

   /* calc the maskOR_msb */
   maskOR_msb        = 0;
   maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
   if (flags & LTM_PRIME_2MSB_ON) {
      maskOR_msb       |= 0x80 >> ((9 - size) & 7);
   }  

   /* get the maskOR_lsb */
   maskOR_lsb         = 1;
   if (flags & LTM_PRIME_BBS) {
      maskOR_lsb     |= 3;
   }

   do {
      /* read the bytes */
      if (cb(tmp, bsize, dat) != bsize) {
         err = MP_VAL;
         goto error;
      }
 
      /* work over the MSbyte */
      tmp[0]    &= maskAND;
      tmp[0]    |= 1 << ((size - 1) & 7);

      /* mix in the maskORs */
      tmp[maskOR_msb_offset]   |= maskOR_msb;
      tmp[bsize-1]             |= maskOR_lsb;

      /* read it in */
      if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY)     { goto error; }

      /* is it prime? */
      if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY)           { goto error; }
      if (res == MP_NO) {  
         continue;
      }

      if (flags & LTM_PRIME_SAFE) {
         /* see if (a-1)/2 is prime */
         if ((err = mp_sub_d(a, 1, a)) != MP_OKAY)                    { goto error; }
         if ((err = mp_div_2(a, a)) != MP_OKAY)                       { goto error; }
 
         /* is it prime? */
         if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY)        { goto error; }
      }
   } while (res == MP_NO);

   if (flags & LTM_PRIME_SAFE) {
      /* restore a to the original value */
      if ((err = mp_mul_2(a, a)) != MP_OKAY)                          { goto error; }
      if ((err = mp_add_d(a, 1, a)) != MP_OKAY)                       { goto error; }
   }

   err = MP_OKAY;
error:
   XFREE(tmp);
   return err;
}


#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_prime_random_ex.c */

/* Start: bn_mp_radix_size.c */
#include <tommath.h>
#ifdef BN_MP_RADIX_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* returns size of ASCII reprensentation */
int mp_radix_size (mp_int * a, int radix, int *size)
{
  int     res, digs;
  mp_int  t;
  mp_digit d;

  *size = 0;

  /* special case for binary */
  if (radix == 2) {
    *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1;
    return MP_OKAY;
  }

  /* make sure the radix is in range */
  if (radix < 2 || radix > 64) {
    return MP_VAL;
  }

  if (mp_iszero(a) == MP_YES) {
     *size = 2;
    return MP_OKAY;
  }

  /* digs is the digit count */
  digs = 0;

  /* if it's negative add one for the sign */
  if (a->sign == MP_NEG) {
    ++digs;
  }

  /* init a copy of the input */
  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  /* force temp to positive */
  t.sign = MP_ZPOS; 

  /* fetch out all of the digits */
  while (mp_iszero (&t) == MP_NO) {
    if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
    ++digs;
  }
  mp_clear (&t);

  /* return digs + 1, the 1 is for the NULL byte that would be required. */
  *size = digs + 1;
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_radix_size.c */

/* Start: bn_mp_radix_smap.c */
#include <tommath.h>
#ifdef BN_MP_RADIX_SMAP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* chars used in radix conversions */
const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_radix_smap.c */

/* Start: bn_mp_rand.c */
#include <tommath.h>
#ifdef BN_MP_RAND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* makes a pseudo-random int of a given size */
int
mp_rand (mp_int * a, int digits)
{
  int     res;
  mp_digit d;

  mp_zero (a);
  if (digits <= 0) {
    return MP_OKAY;
  }

  /* first place a random non-zero digit */
  do {
    d = ((mp_digit) abs (rand ())) & MP_MASK;
  } while (d == 0);

  if ((res = mp_add_d (a, d, a)) != MP_OKAY) {
    return res;
  }

  while (--digits > 0) {
    if ((res = mp_lshd (a, 1)) != MP_OKAY) {
      return res;
    }

    if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) {
      return res;
    }
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_rand.c */

/* Start: bn_mp_read_radix.c */
#include <tommath.h>
#ifdef BN_MP_READ_RADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* read a string [ASCII] in a given radix */
int mp_read_radix (mp_int * a, const char *str, int radix)
{
  int     y, res, neg;
  char    ch;

  /* make sure the radix is ok */
  if (radix < 2 || radix > 64) {
    return MP_VAL;
  }

  /* if the leading digit is a 
   * minus set the sign to negative. 
   */
  if (*str == '-') {
    ++str;
    neg = MP_NEG;
  } else {
    neg = MP_ZPOS;
  }

  /* set the integer to the default of zero */
  mp_zero (a);
  
  /* process each digit of the string */
  while (*str) {
    /* if the radix < 36 the conversion is case insensitive
     * this allows numbers like 1AB and 1ab to represent the same  value
     * [e.g. in hex]
     */
    ch = (char) ((radix < 36) ? toupper (*str) : *str);
    for (y = 0; y < 64; y++) {
      if (ch == mp_s_rmap[y]) {
         break;
      }
    }

    /* if the char was found in the map 
     * and is less than the given radix add it
     * to the number, otherwise exit the loop. 
     */
    if (y < radix) {
      if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) {
         return res;
      }
      if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) {
         return res;
      }
    } else {
      break;
    }
    ++str;
  }
  
  /* set the sign only if a != 0 */
  if (mp_iszero(a) != 1) {
     a->sign = neg;
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_read_radix.c */

/* Start: bn_mp_read_signed_bin.c */
#include <tommath.h>
#ifdef BN_MP_READ_SIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* read signed bin, big endian, first byte is 0==positive or 1==negative */
int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c)
{
  int     res;

  /* read magnitude */
  if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) {
    return res;
  }

  /* first byte is 0 for positive, non-zero for negative */
  if (b[0] == 0) {
     a->sign = MP_ZPOS;
  } else {
     a->sign = MP_NEG;
  }

  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_read_signed_bin.c */

/* Start: bn_mp_read_unsigned_bin.c */
#include <tommath.h>
#ifdef BN_MP_READ_UNSIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reads a unsigned char array, assumes the msb is stored first [big endian] */
int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c)
{
  int     res;

  /* make sure there are at least two digits */
  if (a->alloc < 2) {
     if ((res = mp_grow(a, 2)) != MP_OKAY) {
        return res;
     }
  }

  /* zero the int */
  mp_zero (a);

  /* read the bytes in */
  while (c-- > 0) {
    if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) {
      return res;
    }

#ifndef MP_8BIT
      a->dp[0] |= *b++;
      a->used += 1;
#else
      a->dp[0] = (*b & MP_MASK);
      a->dp[1] |= ((*b++ >> 7U) & 1);
      a->used += 2;
#endif
  }
  mp_clamp (a);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_read_unsigned_bin.c */

/* Start: bn_mp_reduce.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduces x mod m, assumes 0 < x < m**2, mu is 
 * precomputed via mp_reduce_setup.
 * From HAC pp.604 Algorithm 14.42
 */
int mp_reduce (mp_int * x, mp_int * m, mp_int * mu)
{
  mp_int  q;
  int     res, um = m->used;

  /* q = x */
  if ((res = mp_init_copy (&q, x)) != MP_OKAY) {
    return res;
  }

  /* q1 = x / b**(k-1)  */
  mp_rshd (&q, um - 1);         

  /* according to HAC this optimization is ok */
  if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) {
    if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) {
      goto CLEANUP;
    }
  } else {
#ifdef BN_S_MP_MUL_HIGH_DIGS_C
    if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) {
      goto CLEANUP;
    }
#elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C)
    if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) {
      goto CLEANUP;
    }
#else 
    { 
      res = MP_VAL;
      goto CLEANUP;
    }
#endif
  }

  /* q3 = q2 / b**(k+1) */
  mp_rshd (&q, um + 1);         

  /* x = x mod b**(k+1), quick (no division) */
  if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) {
    goto CLEANUP;
  }

  /* q = q * m mod b**(k+1), quick (no division) */
  if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) {
    goto CLEANUP;
  }

  /* x = x - q */
  if ((res = mp_sub (x, &q, x)) != MP_OKAY) {
    goto CLEANUP;
  }

  /* If x < 0, add b**(k+1) to it */
  if (mp_cmp_d (x, 0) == MP_LT) {
    mp_set (&q, 1);
    if ((res = mp_lshd (&q, um + 1)) != MP_OKAY)
      goto CLEANUP;
    if ((res = mp_add (x, &q, x)) != MP_OKAY)
      goto CLEANUP;
  }

  /* Back off if it's too big */
  while (mp_cmp (x, m) != MP_LT) {
    if ((res = s_mp_sub (x, m, x)) != MP_OKAY) {
      goto CLEANUP;
    }
  }
  
CLEANUP:
  mp_clear (&q);

  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce.c */

/* Start: bn_mp_reduce_2k.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduces a modulo n where n is of the form 2**p - d */
int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d)
{
   mp_int q;
   int    p, res;
   
   if ((res = mp_init(&q)) != MP_OKAY) {
      return res;
   }
   
   p = mp_count_bits(n);    
top:
   /* q = a/2**p, a = a mod 2**p */
   if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   if (d != 1) {
      /* q = q * d */
      if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { 
         goto ERR;
      }
   }
   
   /* a = a + q */
   if ((res = s_mp_add(a, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   if (mp_cmp_mag(a, n) != MP_LT) {
      s_mp_sub(a, n, a);
      goto top;
   }
   
ERR:
   mp_clear(&q);
   return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_2k.c */

/* Start: bn_mp_reduce_2k_l.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reduces a modulo n where n is of the form 2**p - d 
   This differs from reduce_2k since "d" can be larger
   than a single digit.
*/
int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d)
{
   mp_int q;
   int    p, res;
   
   if ((res = mp_init(&q)) != MP_OKAY) {
      return res;
   }
   
   p = mp_count_bits(n);    
top:
   /* q = a/2**p, a = a mod 2**p */
   if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   /* q = q * d */
   if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { 
      goto ERR;
   }
   
   /* a = a + q */
   if ((res = s_mp_add(a, &q, a)) != MP_OKAY) {
      goto ERR;
   }
   
   if (mp_cmp_mag(a, n) != MP_LT) {
      s_mp_sub(a, n, a);
      goto top;
   }
   
ERR:
   mp_clear(&q);
   return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_2k_l.c */

/* Start: bn_mp_reduce_2k_setup.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines the setup value */
int mp_reduce_2k_setup(mp_int *a, mp_digit *d)
{
   int res, p;
   mp_int tmp;
   
   if ((res = mp_init(&tmp)) != MP_OKAY) {
      return res;
   }
   
   p = mp_count_bits(a);
   if ((res = mp_2expt(&tmp, p)) != MP_OKAY) {
      mp_clear(&tmp);
      return res;
   }
   
   if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) {
      mp_clear(&tmp);
      return res;
   }
   
   *d = tmp.dp[0];
   mp_clear(&tmp);
   return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_2k_setup.c */

/* Start: bn_mp_reduce_2k_setup_l.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_2K_SETUP_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines the setup value */
int mp_reduce_2k_setup_l(mp_int *a, mp_int *d)
{
   int    res;
   mp_int tmp;
   
   if ((res = mp_init(&tmp)) != MP_OKAY) {
      return res;
   }
   
   if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) {
      goto ERR;
   }
   
   if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) {
      goto ERR;
   }
   
ERR:
   mp_clear(&tmp);
   return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_2k_setup_l.c */

/* Start: bn_mp_reduce_is_2k.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_IS_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if mp_reduce_2k can be used */
int mp_reduce_is_2k(mp_int *a)
{
   int ix, iy, iw;
   mp_digit iz;
   
   if (a->used == 0) {
      return MP_NO;
   } else if (a->used == 1) {
      return MP_YES;
   } else if (a->used > 1) {
      iy = mp_count_bits(a);
      iz = 1;
      iw = 1;
    
      /* Test every bit from the second digit up, must be 1 */
      for (ix = DIGIT_BIT; ix < iy; ix++) {
          if ((a->dp[iw] & iz) == 0) {
             return MP_NO;
          }
          iz <<= 1;
          if (iz > (mp_digit)MP_MASK) {
             ++iw;
             iz = 1;
          }
      }
   }
   return MP_YES;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_is_2k.c */

/* Start: bn_mp_reduce_is_2k_l.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_IS_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* determines if reduce_2k_l can be used */
int mp_reduce_is_2k_l(mp_int *a)
{
   int ix, iy;
   
   if (a->used == 0) {
      return MP_NO;
   } else if (a->used == 1) {
      return MP_YES;
   } else if (a->used > 1) {
      /* if more than half of the digits are -1 we're sold */
      for (iy = ix = 0; ix < a->used; ix++) {
          if (a->dp[ix] == MP_MASK) {
              ++iy;
          }
      }
      return (iy >= (a->used/2)) ? MP_YES : MP_NO;
      
   }
   return MP_NO;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_is_2k_l.c */

/* Start: bn_mp_reduce_setup.c */
#include <tommath.h>
#ifdef BN_MP_REDUCE_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* pre-calculate the value required for Barrett reduction
 * For a given modulus "b" it calulates the value required in "a"
 */
int mp_reduce_setup (mp_int * a, mp_int * b)
{
  int     res;
  
  if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) {
    return res;
  }
  return mp_div (a, b, a, NULL);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_reduce_setup.c */

/* Start: bn_mp_rshd.c */
#include <tommath.h>
#ifdef BN_MP_RSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shift right a certain amount of digits */
void mp_rshd (mp_int * a, int b)
{
  int     x;

  /* if b <= 0 then ignore it */
  if (b <= 0) {
    return;
  }

  /* if b > used then simply zero it and return */
  if (a->used <= b) {
    mp_zero (a);
    return;
  }

  {
    register mp_digit *bottom, *top;

    /* shift the digits down */

    /* bottom */
    bottom = a->dp;

    /* top [offset into digits] */
    top = a->dp + b;

    /* this is implemented as a sliding window where 
     * the window is b-digits long and digits from 
     * the top of the window are copied to the bottom
     *
     * e.g.

     b-2 | b-1 | b0 | b1 | b2 | ... | bb |   ---->
                 /\                   |      ---->
                  \-------------------/      ---->
     */
    for (x = 0; x < (a->used - b); x++) {
      *bottom++ = *top++;
    }

    /* zero the top digits */
    for (; x < a->used; x++) {
      *bottom++ = 0;
    }
  }
  
  /* remove excess digits */
  a->used -= b;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_rshd.c */

/* Start: bn_mp_set.c */
#include <tommath.h>
#ifdef BN_MP_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* set to a digit */
void mp_set (mp_int * a, mp_digit b)
{
  mp_zero (a);
  a->dp[0] = b & MP_MASK;
  a->used  = (a->dp[0] != 0) ? 1 : 0;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_set.c */

/* Start: bn_mp_set_int.c */
#include <tommath.h>
#ifdef BN_MP_SET_INT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* set a 32-bit const */
int mp_set_int (mp_int * a, unsigned long b)
{
  int     x, res;

  mp_zero (a);
  
  /* set four bits at a time */
  for (x = 0; x < 8; x++) {
    /* shift the number up four bits */
    if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) {
      return res;
    }

    /* OR in the top four bits of the source */
    a->dp[0] |= (b >> 28) & 15;

    /* shift the source up to the next four bits */
    b <<= 4;

    /* ensure that digits are not clamped off */
    a->used += 1;
  }
  mp_clamp (a);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_set_int.c */

/* Start: bn_mp_shrink.c */
#include <tommath.h>
#ifdef BN_MP_SHRINK_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* shrink a bignum */
int mp_shrink (mp_int * a)
{
  mp_digit *tmp;
  if (a->alloc != a->used && a->used > 0) {
    if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) {
      return MP_MEM;
    }
    a->dp    = tmp;
    a->alloc = a->used;
  }
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_shrink.c */

/* Start: bn_mp_signed_bin_size.c */
#include <tommath.h>
#ifdef BN_MP_SIGNED_BIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* get the size for an signed equivalent */
int mp_signed_bin_size (mp_int * a)
{
  return 1 + mp_unsigned_bin_size (a);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_signed_bin_size.c */

/* Start: bn_mp_sqr.c */
#include <tommath.h>
#ifdef BN_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* computes b = a*a */
int
mp_sqr (mp_int * a, mp_int * b)
{
  int     res;

#ifdef BN_MP_TOOM_SQR_C
  /* use Toom-Cook? */
  if (a->used >= TOOM_SQR_CUTOFF) {
    res = mp_toom_sqr(a, b);
  /* Karatsuba? */
  } else 
#endif
#ifdef BN_MP_KARATSUBA_SQR_C
if (a->used >= KARATSUBA_SQR_CUTOFF) {
    res = mp_karatsuba_sqr (a, b);
  } else 
#endif
  {
#ifdef BN_FAST_S_MP_SQR_C
    /* can we use the fast comba multiplier? */
    if ((a->used * 2 + 1) < MP_WARRAY && 
         a->used < 
         (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) {
      res = fast_s_mp_sqr (a, b);
    } else
#endif
#ifdef BN_S_MP_SQR_C
      res = s_mp_sqr (a, b);
#else
      res = MP_VAL;
#endif
  }
  b->sign = MP_ZPOS;
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_sqr.c */

/* Start: bn_mp_sqrmod.c */
#include <tommath.h>
#ifdef BN_MP_SQRMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* c = a * a (mod b) */
int
mp_sqrmod (mp_int * a, mp_int * b, mp_int * c)
{
  int     res;
  mp_int  t;

  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_sqr (a, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, b, c);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_sqrmod.c */

/* Start: bn_mp_sqrt.c */
#include <tommath.h>
#ifdef BN_MP_SQRT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(mp_int *arg, mp_int *ret) 
{
  int res;
  mp_int t1,t2;

  /* must be positive */
  if (arg->sign == MP_NEG) {
    return MP_VAL;
  }

  /* easy out */
  if (mp_iszero(arg) == MP_YES) {
    mp_zero(ret);
    return MP_OKAY;
  }

  if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_init(&t2)) != MP_OKAY) {
    goto E2;
  }

  /* First approx. (not very bad for large arg) */
  mp_rshd (&t1,t1.used/2);

  /* t1 > 0  */ 
  if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) {
    goto E1;
  }
  if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) {
    goto E1;
  }
  if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) {
    goto E1;
  }
  /* And now t1 > sqrt(arg) */
  do { 
    if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) {
      goto E1;
    }
    if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) {
      goto E1;
    }
    if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) {
      goto E1;
    }
    /* t1 >= sqrt(arg) >= t2 at this point */
  } while (mp_cmp_mag(&t1,&t2) == MP_GT);

  mp_exch(&t1,ret);

E1: mp_clear(&t2);
E2: mp_clear(&t1);
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_sqrt.c */

/* Start: bn_mp_sub.c */
#include <tommath.h>
#ifdef BN_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* high level subtraction (handles signs) */
int
mp_sub (mp_int * a, mp_int * b, mp_int * c)
{
  int     sa, sb, res;

  sa = a->sign;
  sb = b->sign;

  if (sa != sb) {
    /* subtract a negative from a positive, OR */
    /* subtract a positive from a negative. */
    /* In either case, ADD their magnitudes, */
    /* and use the sign of the first number. */
    c->sign = sa;
    res = s_mp_add (a, b, c);
  } else {
    /* subtract a positive from a positive, OR */
    /* subtract a negative from a negative. */
    /* First, take the difference between their */
    /* magnitudes, then... */
    if (mp_cmp_mag (a, b) != MP_LT) {
      /* Copy the sign from the first */
      c->sign = sa;
      /* The first has a larger or equal magnitude */
      res = s_mp_sub (a, b, c);
    } else {
      /* The result has the *opposite* sign from */
      /* the first number. */
      c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS;
      /* The second has a larger magnitude */
      res = s_mp_sub (b, a, c);
    }
  }
  return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_sub.c */

/* Start: bn_mp_sub_d.c */
#include <tommath.h>
#ifdef BN_MP_SUB_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* single digit subtraction */
int
mp_sub_d (mp_int * a, mp_digit b, mp_int * c)
{
  mp_digit *tmpa, *tmpc, mu;
  int       res, ix, oldused;

  /* grow c as required */
  if (c->alloc < a->used + 1) {
     if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) {
        return res;
     }
  }

  /* if a is negative just do an unsigned
   * addition [with fudged signs]
   */
  if (a->sign == MP_NEG) {
     a->sign = MP_ZPOS;
     res     = mp_add_d(a, b, c);
     a->sign = c->sign = MP_NEG;
     return res;
  }

  /* setup regs */
  oldused = c->used;
  tmpa    = a->dp;
  tmpc    = c->dp;

  /* if a <= b simply fix the single digit */
  if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) {
     if (a->used == 1) {
        *tmpc++ = b - *tmpa;
     } else {
        *tmpc++ = b;
     }
     ix      = 1;

     /* negative/1digit */
     c->sign = MP_NEG;
     c->used = 1;
  } else {
     /* positive/size */
     c->sign = MP_ZPOS;
     c->used = a->used;

     /* subtract first digit */
     *tmpc    = *tmpa++ - b;
     mu       = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1);
     *tmpc++ &= MP_MASK;

     /* handle rest of the digits */
     for (ix = 1; ix < a->used; ix++) {
        *tmpc    = *tmpa++ - mu;
        mu       = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1);
        *tmpc++ &= MP_MASK;
     }
  }

  /* zero excess digits */
  while (ix++ < oldused) {
     *tmpc++ = 0;
  }
  mp_clamp(c);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_sub_d.c */

/* Start: bn_mp_submod.c */
#include <tommath.h>
#ifdef BN_MP_SUBMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* d = a - b (mod c) */
int
mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d)
{
  int     res;
  mp_int  t;


  if ((res = mp_init (&t)) != MP_OKAY) {
    return res;
  }

  if ((res = mp_sub (a, b, &t)) != MP_OKAY) {
    mp_clear (&t);
    return res;
  }
  res = mp_mod (&t, c, d);
  mp_clear (&t);
  return res;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_submod.c */

/* Start: bn_mp_to_signed_bin.c */
#include <tommath.h>
#ifdef BN_MP_TO_SIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in signed [big endian] format */
int mp_to_signed_bin (mp_int * a, unsigned char *b)
{
  int     res;

  if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) {
    return res;
  }
  b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_to_signed_bin.c */

/* Start: bn_mp_to_signed_bin_n.c */
#include <tommath.h>
#ifdef BN_MP_TO_SIGNED_BIN_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in signed [big endian] format */
int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen)
{
   if (*outlen < (unsigned long)mp_signed_bin_size(a)) {
      return MP_VAL;
   }
   *outlen = mp_signed_bin_size(a);
   return mp_to_signed_bin(a, b);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_to_signed_bin_n.c */

/* Start: bn_mp_to_unsigned_bin.c */
#include <tommath.h>
#ifdef BN_MP_TO_UNSIGNED_BIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in unsigned [big endian] format */
int mp_to_unsigned_bin (mp_int * a, unsigned char *b)
{
  int     x, res;
  mp_int  t;

  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  x = 0;
  while (mp_iszero (&t) == 0) {
#ifndef MP_8BIT
      b[x++] = (unsigned char) (t.dp[0] & 255);
#else
      b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7));
#endif
    if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
  }
  bn_reverse (b, x);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_to_unsigned_bin.c */

/* Start: bn_mp_to_unsigned_bin_n.c */
#include <tommath.h>
#ifdef BN_MP_TO_UNSIGNED_BIN_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* store in unsigned [big endian] format */
int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen)
{
   if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) {
      return MP_VAL;
   }
   *outlen = mp_unsigned_bin_size(a);
   return mp_to_unsigned_bin(a, b);
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_to_unsigned_bin_n.c */

/* Start: bn_mp_toom_mul.c */
#include <tommath.h>
#ifdef BN_MP_TOOM_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiplication using the Toom-Cook 3-way algorithm 
 *
 * Much more complicated than Karatsuba but has a lower 
 * asymptotic running time of O(N**1.464).  This algorithm is 
 * only particularly useful on VERY large inputs 
 * (we're talking 1000s of digits here...).
*/
int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c)
{
    mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2;
    int res, B;
        
    /* init temps */
    if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, 
                             &a0, &a1, &a2, &b0, &b1, 
                             &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) {
       return res;
    }
    
    /* B */
    B = MIN(a->used, b->used) / 3;
    
    /* a = a2 * B**2 + a1 * B + a0 */
    if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_copy(a, &a1)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a1, B);
    mp_mod_2d(&a1, DIGIT_BIT * B, &a1);

    if ((res = mp_copy(a, &a2)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a2, B*2);
    
    /* b = b2 * B**2 + b1 * B + b0 */
    if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_copy(b, &b1)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&b1, B);
    mp_mod_2d(&b1, DIGIT_BIT * B, &b1);

    if ((res = mp_copy(b, &b2)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&b2, B*2);
    
    /* w0 = a0*b0 */
    if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) {
       goto ERR;
    }
    
    /* w4 = a2 * b2 */
    if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) {
       goto ERR;
    }
    
    /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */
    if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) {
       goto ERR;
    }
    
    /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */
    if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    
    if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) {
       goto ERR;
    }
    

    /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */
    if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) {
       goto ERR;
    }
    
    /* now solve the matrix 
    
       0  0  0  0  1
       1  2  4  8  16
       1  1  1  1  1
       16 8  4  2  1
       1  0  0  0  0
       
       using 12 subtractions, 4 shifts, 
              2 small divisions and 1 small multiplication 
     */
     
     /* r1 - r4 */
     if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r0 */
     if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/2 */
     if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/2 */
     if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r2 - r0 - r4 */
     if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - 8r0 */
     if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - 8r4 */
     if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* 3r2 - r1 - r3 */
     if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/3 */
     if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/3 */
     if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) {
        goto ERR;
     }
     
     /* at this point shift W[n] by B*n */
     if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) {
        goto ERR;
     }     
     
     if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) {
        goto ERR;
     }     
     
ERR:
     mp_clear_multi(&w0, &w1, &w2, &w3, &w4, 
                    &a0, &a1, &a2, &b0, &b1, 
                    &b2, &tmp1, &tmp2, NULL);
     return res;
}     
     
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_toom_mul.c */

/* Start: bn_mp_toom_sqr.c */
#include <tommath.h>
#ifdef BN_MP_TOOM_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* squaring using Toom-Cook 3-way algorithm */
int
mp_toom_sqr(mp_int *a, mp_int *b)
{
    mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2;
    int res, B;

    /* init temps */
    if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) {
       return res;
    }

    /* B */
    B = a->used / 3;

    /* a = a2 * B**2 + a1 * B + a0 */
    if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_copy(a, &a1)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a1, B);
    mp_mod_2d(&a1, DIGIT_BIT * B, &a1);

    if ((res = mp_copy(a, &a2)) != MP_OKAY) {
       goto ERR;
    }
    mp_rshd(&a2, B*2);

    /* w0 = a0*a0 */
    if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) {
       goto ERR;
    }

    /* w4 = a2 * a2 */
    if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) {
       goto ERR;
    }

    /* w1 = (a2 + 2(a1 + 2a0))**2 */
    if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) {
       goto ERR;
    }

    /* w3 = (a0 + 2(a1 + 2a2))**2 */
    if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }

    if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) {
       goto ERR;
    }


    /* w2 = (a2 + a1 + a0)**2 */
    if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) {
       goto ERR;
    }
    if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) {
       goto ERR;
    }

    /* now solve the matrix

       0  0  0  0  1
       1  2  4  8  16
       1  1  1  1  1
       16 8  4  2  1
       1  0  0  0  0

       using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication.
     */

     /* r1 - r4 */
     if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r0 */
     if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/2 */
     if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/2 */
     if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r2 - r0 - r4 */
     if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - 8r0 */
     if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - 8r4 */
     if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* 3r2 - r1 - r3 */
     if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) {
        goto ERR;
     }
     /* r1 - r2 */
     if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) {
        goto ERR;
     }
     /* r3 - r2 */
     if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) {
        goto ERR;
     }
     /* r1/3 */
     if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) {
        goto ERR;
     }
     /* r3/3 */
     if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) {
        goto ERR;
     }

     /* at this point shift W[n] by B*n */
     if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) {
        goto ERR;
     }

     if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) {
        goto ERR;
     }
     if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) {
        goto ERR;
     }

ERR:
     mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL);
     return res;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_toom_sqr.c */

/* Start: bn_mp_toradix.c */
#include <tommath.h>
#ifdef BN_MP_TORADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* stores a bignum as a ASCII string in a given radix (2..64) */
int mp_toradix (mp_int * a, char *str, int radix)
{
  int     res, digs;
  mp_int  t;
  mp_digit d;
  char   *_s = str;

  /* check range of the radix */
  if (radix < 2 || radix > 64) {
    return MP_VAL;
  }

  /* quick out if its zero */
  if (mp_iszero(a) == 1) {
     *str++ = '0';
     *str = '\0';
     return MP_OKAY;
  }

  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  /* if it is negative output a - */
  if (t.sign == MP_NEG) {
    ++_s;
    *str++ = '-';
    t.sign = MP_ZPOS;
  }

  digs = 0;
  while (mp_iszero (&t) == 0) {
    if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
    *str++ = mp_s_rmap[d];
    ++digs;
  }

  /* reverse the digits of the string.  In this case _s points
   * to the first digit [exluding the sign] of the number]
   */
  bn_reverse ((unsigned char *)_s, digs);

  /* append a NULL so the string is properly terminated */
  *str = '\0';

  mp_clear (&t);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_toradix.c */

/* Start: bn_mp_toradix_n.c */
#include <tommath.h>
#ifdef BN_MP_TORADIX_N_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* stores a bignum as a ASCII string in a given radix (2..64) 
 *
 * Stores upto maxlen-1 chars and always a NULL byte 
 */
int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen)
{
  int     res, digs;
  mp_int  t;
  mp_digit d;
  char   *_s = str;

  /* check range of the maxlen, radix */
  if (maxlen < 3 || radix < 2 || radix > 64) {
    return MP_VAL;
  }

  /* quick out if its zero */
  if (mp_iszero(a) == 1) {
     *str++ = '0';
     *str = '\0';
     return MP_OKAY;
  }

  if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
    return res;
  }

  /* if it is negative output a - */
  if (t.sign == MP_NEG) {
    /* we have to reverse our digits later... but not the - sign!! */
    ++_s;

    /* store the flag and mark the number as positive */
    *str++ = '-';
    t.sign = MP_ZPOS;
 
    /* subtract a char */
    --maxlen;
  }

  digs = 0;
  while (mp_iszero (&t) == 0) {
    if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) {
      mp_clear (&t);
      return res;
    }
    *str++ = mp_s_rmap[d];
    ++digs;

    if (--maxlen == 1) {
       /* no more room */
       break;
    }
  }

  /* reverse the digits of the string.  In this case _s points
   * to the first digit [exluding the sign] of the number]
   */
  bn_reverse ((unsigned char *)_s, digs);

  /* append a NULL so the string is properly terminated */
  *str = '\0';

  mp_clear (&t);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_toradix_n.c */

/* Start: bn_mp_unsigned_bin_size.c */
#include <tommath.h>
#ifdef BN_MP_UNSIGNED_BIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* get the size for an unsigned equivalent */
int mp_unsigned_bin_size (mp_int * a)
{
  int     size = mp_count_bits (a);
  return (size / 8 + ((size & 7) != 0 ? 1 : 0));
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_unsigned_bin_size.c */

/* Start: bn_mp_xor.c */
#include <tommath.h>
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* XOR two ints together */
int
mp_xor (mp_int * a, mp_int * b, mp_int * c)
{
  int     res, ix, px;
  mp_int  t, *x;

  if (a->used > b->used) {
    if ((res = mp_init_copy (&t, a)) != MP_OKAY) {
      return res;
    }
    px = b->used;
    x = b;
  } else {
    if ((res = mp_init_copy (&t, b)) != MP_OKAY) {
      return res;
    }
    px = a->used;
    x = a;
  }

  for (ix = 0; ix < px; ix++) {
     t.dp[ix] ^= x->dp[ix];
  }
  mp_clamp (&t);
  mp_exch (c, &t);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_xor.c */

/* Start: bn_mp_zero.c */
#include <tommath.h>
#ifdef BN_MP_ZERO_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* set to zero */
void mp_zero (mp_int * a)
{
  int       n;
  mp_digit *tmp;

  a->sign = MP_ZPOS;
  a->used = 0;

  tmp = a->dp;
  for (n = 0; n < a->alloc; n++) {
     *tmp++ = 0;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_mp_zero.c */

/* Start: bn_prime_tab.c */
#include <tommath.h>
#ifdef BN_PRIME_TAB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
const mp_digit ltm_prime_tab[] = {
  0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013,
  0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035,
  0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059,
  0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F,
#ifndef MP_8BIT
  0x0083,
  0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD,
  0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF,
  0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107,
  0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137,

  0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167,
  0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199,
  0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9,
  0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7,
  0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239,
  0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265,
  0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293,
  0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF,

  0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301,
  0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B,
  0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371,
  0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD,
  0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5,
  0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419,
  0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449,
  0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B,

  0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7,
  0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503,
  0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529,
  0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F,
  0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3,
  0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7,
  0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623,
  0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653
#endif
};
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_prime_tab.c */

/* Start: bn_reverse.c */
#include <tommath.h>
#ifdef BN_REVERSE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* reverse an array, used for radix code */
void
bn_reverse (unsigned char *s, int len)
{
  int     ix, iy;
  unsigned char t;

  ix = 0;
  iy = len - 1;
  while (ix < iy) {
    t     = s[ix];
    s[ix] = s[iy];
    s[iy] = t;
    ++ix;
    --iy;
  }
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_reverse.c */

/* Start: bn_s_mp_add.c */
#include <tommath.h>
#ifdef BN_S_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* low level addition, based on HAC pp.594, Algorithm 14.7 */
int
s_mp_add (mp_int * a, mp_int * b, mp_int * c)
{
  mp_int *x;
  int     olduse, res, min, max;

  /* find sizes, we let |a| <= |b| which means we have to sort
   * them.  "x" will point to the input with the most digits
   */
  if (a->used > b->used) {
    min = b->used;
    max = a->used;
    x = a;
  } else {
    min = a->used;
    max = b->used;
    x = b;
  }

  /* init result */
  if (c->alloc < max + 1) {
    if ((res = mp_grow (c, max + 1)) != MP_OKAY) {
      return res;
    }
  }

  /* get old used digit count and set new one */
  olduse = c->used;
  c->used = max + 1;

  {
    register mp_digit u, *tmpa, *tmpb, *tmpc;
    register int i;

    /* alias for digit pointers */

    /* first input */
    tmpa = a->dp;

    /* second input */
    tmpb = b->dp;

    /* destination */
    tmpc = c->dp;

    /* zero the carry */
    u = 0;
    for (i = 0; i < min; i++) {
      /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */
      *tmpc = *tmpa++ + *tmpb++ + u;

      /* U = carry bit of T[i] */
      u = *tmpc >> ((mp_digit)DIGIT_BIT);

      /* take away carry bit from T[i] */
      *tmpc++ &= MP_MASK;
    }

    /* now copy higher words if any, that is in A+B 
     * if A or B has more digits add those in 
     */
    if (min != max) {
      for (; i < max; i++) {
        /* T[i] = X[i] + U */
        *tmpc = x->dp[i] + u;

        /* U = carry bit of T[i] */
        u = *tmpc >> ((mp_digit)DIGIT_BIT);

        /* take away carry bit from T[i] */
        *tmpc++ &= MP_MASK;
      }
    }

    /* add carry */
    *tmpc++ = u;

    /* clear digits above oldused */
    for (i = c->used; i < olduse; i++) {
      *tmpc++ = 0;
    }
  }

  mp_clamp (c);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_s_mp_add.c */

/* Start: bn_s_mp_exptmod.c */
#include <tommath.h>
#ifdef BN_S_MP_EXPTMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#ifdef MP_LOW_MEM
   #define TAB_SIZE 32
#else
   #define TAB_SIZE 256
#endif

int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode)
{
  mp_int  M[TAB_SIZE], res, mu;
  mp_digit buf;
  int     err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;
  int (*redux)(mp_int*,mp_int*,mp_int*);

  /* find window size */
  x = mp_count_bits (X);
  if (x <= 7) {
    winsize = 2;
  } else if (x <= 36) {
    winsize = 3;
  } else if (x <= 140) {
    winsize = 4;
  } else if (x <= 450) {
    winsize = 5;
  } else if (x <= 1303) {
    winsize = 6;
  } else if (x <= 3529) {
    winsize = 7;
  } else {
    winsize = 8;
  }

#ifdef MP_LOW_MEM
    if (winsize > 5) {
       winsize = 5;
    }
#endif

  /* init M array */
  /* init first cell */
  if ((err = mp_init(&M[1])) != MP_OKAY) {
     return err; 
  }

  /* now init the second half of the array */
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    if ((err = mp_init(&M[x])) != MP_OKAY) {
      for (y = 1<<(winsize-1); y < x; y++) {
        mp_clear (&M[y]);
      }
      mp_clear(&M[1]);
      return err;
    }
  }

  /* create mu, used for Barrett reduction */
  if ((err = mp_init (&mu)) != MP_OKAY) {
    goto LBL_M;
  }
  
  if (redmode == 0) {
     if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) {
        goto LBL_MU;
     }
     redux = mp_reduce;
  } else {
     if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) {
        goto LBL_MU;
     }
     redux = mp_reduce_2k_l;
  }    

  /* create M table
   *
   * The M table contains powers of the base, 
   * e.g. M[x] = G**x mod P
   *
   * The first half of the table is not 
   * computed though accept for M[0] and M[1]
   */
  if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) {
    goto LBL_MU;
  }

  /* compute the value at M[1<<(winsize-1)] by squaring 
   * M[1] (winsize-1) times 
   */
  if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) {
    goto LBL_MU;
  }

  for (x = 0; x < (winsize - 1); x++) {
    /* square it */
    if ((err = mp_sqr (&M[1 << (winsize - 1)], 
                       &M[1 << (winsize - 1)])) != MP_OKAY) {
      goto LBL_MU;
    }

    /* reduce modulo P */
    if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) {
      goto LBL_MU;
    }
  }

  /* create upper table, that is M[x] = M[x-1] * M[1] (mod P)
   * for x = (2**(winsize - 1) + 1) to (2**winsize - 1)
   */
  for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
    if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) {
      goto LBL_MU;
    }
    if ((err = redux (&M[x], P, &mu)) != MP_OKAY) {
      goto LBL_MU;
    }
  }

  /* setup result */
  if ((err = mp_init (&res)) != MP_OKAY) {
    goto LBL_MU;
  }
  mp_set (&res, 1);

  /* set initial mode and bit cnt */
  mode   = 0;
  bitcnt = 1;
  buf    = 0;
  digidx = X->used - 1;
  bitcpy = 0;
  bitbuf = 0;

  for (;;) {
    /* grab next digit as required */
    if (--bitcnt == 0) {
      /* if digidx == -1 we are out of digits */
      if (digidx == -1) {
        break;
      }
      /* read next digit and reset the bitcnt */
      buf    = X->dp[digidx--];
      bitcnt = (int) DIGIT_BIT;
    }

    /* grab the next msb from the exponent */
    y     = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1;
    buf <<= (mp_digit)1;

    /* if the bit is zero and mode == 0 then we ignore it
     * These represent the leading zero bits before the first 1 bit
     * in the exponent.  Technically this opt is not required but it
     * does lower the # of trivial squaring/reductions used
     */
    if (mode == 0 && y == 0) {
      continue;
    }

    /* if the bit is zero and mode == 1 then we square */
    if (mode == 1 && y == 0) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, &mu)) != MP_OKAY) {
        goto LBL_RES;
      }
      continue;
    }

    /* else we add it to the window */
    bitbuf |= (y << (winsize - ++bitcpy));
    mode    = 2;

    if (bitcpy == winsize) {
      /* ok window is filled so square as required and multiply  */
      /* square first */
      for (x = 0; x < winsize; x++) {
        if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, &mu)) != MP_OKAY) {
          goto LBL_RES;
        }
      }

      /* then multiply */
      if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, &mu)) != MP_OKAY) {
        goto LBL_RES;
      }

      /* empty window and reset */
      bitcpy = 0;
      bitbuf = 0;
      mode   = 1;
    }
  }

  /* if bits remain then square/multiply */
  if (mode == 2 && bitcpy > 0) {
    /* square then multiply if the bit is set */
    for (x = 0; x < bitcpy; x++) {
      if ((err = mp_sqr (&res, &res)) != MP_OKAY) {
        goto LBL_RES;
      }
      if ((err = redux (&res, P, &mu)) != MP_OKAY) {
        goto LBL_RES;
      }

      bitbuf <<= 1;
      if ((bitbuf & (1 << winsize)) != 0) {
        /* then multiply */
        if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) {
          goto LBL_RES;
        }
        if ((err = redux (&res, P, &mu)) != MP_OKAY) {
          goto LBL_RES;
        }
      }
    }
  }

  mp_exch (&res, Y);
  err = MP_OKAY;
LBL_RES:mp_clear (&res);
LBL_MU:mp_clear (&mu);
LBL_M:
  mp_clear(&M[1]);
  for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
    mp_clear (&M[x]);
  }
  return err;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_s_mp_exptmod.c */

/* Start: bn_s_mp_mul_digs.c */
#include <tommath.h>
#ifdef BN_S_MP_MUL_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiplies |a| * |b| and only computes upto digs digits of result
 * HAC pp. 595, Algorithm 14.12  Modified so you can control how 
 * many digits of output are created.
 */
int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  mp_int  t;
  int     res, pa, pb, ix, iy;
  mp_digit u;
  mp_word r;
  mp_digit tmpx, *tmpt, *tmpy;

  /* can we use the fast multiplier? */
  if (((digs) < MP_WARRAY) &&
      MIN (a->used, b->used) < 
          (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
    return fast_s_mp_mul_digs (a, b, c, digs);
  }

  if ((res = mp_init_size (&t, digs)) != MP_OKAY) {
    return res;
  }
  t.used = digs;

  /* compute the digits of the product directly */
  pa = a->used;
  for (ix = 0; ix < pa; ix++) {
    /* set the carry to zero */
    u = 0;

    /* limit ourselves to making digs digits of output */
    pb = MIN (b->used, digs - ix);

    /* setup some aliases */
    /* copy of the digit from a used within the nested loop */
    tmpx = a->dp[ix];
    
    /* an alias for the destination shifted ix places */
    tmpt = t.dp + ix;
    
    /* an alias for the digits of b */
    tmpy = b->dp;

    /* compute the columns of the output and propagate the carry */
    for (iy = 0; iy < pb; iy++) {
      /* compute the column as a mp_word */
      r       = ((mp_word)*tmpt) +
                ((mp_word)tmpx) * ((mp_word)*tmpy++) +
                ((mp_word) u);

      /* the new column is the lower part of the result */
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));

      /* get the carry word from the result */
      u       = (mp_digit) (r >> ((mp_word) DIGIT_BIT));
    }
    /* set carry if it is placed below digs */
    if (ix + iy < digs) {
      *tmpt = u;
    }
  }

  mp_clamp (&t);
  mp_exch (&t, c);

  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_s_mp_mul_digs.c */

/* Start: bn_s_mp_mul_high_digs.c */
#include <tommath.h>
#ifdef BN_S_MP_MUL_HIGH_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* multiplies |a| * |b| and does not compute the lower digs digits
 * [meant to get the higher part of the product]
 */
int
s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs)
{
  mp_int  t;
  int     res, pa, pb, ix, iy;
  mp_digit u;
  mp_word r;
  mp_digit tmpx, *tmpt, *tmpy;

  /* can we use the fast multiplier? */
#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C
  if (((a->used + b->used + 1) < MP_WARRAY)
      && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) {
    return fast_s_mp_mul_high_digs (a, b, c, digs);
  }
#endif

  if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) {
    return res;
  }
  t.used = a->used + b->used + 1;

  pa = a->used;
  pb = b->used;
  for (ix = 0; ix < pa; ix++) {
    /* clear the carry */
    u = 0;

    /* left hand side of A[ix] * B[iy] */
    tmpx = a->dp[ix];

    /* alias to the address of where the digits will be stored */
    tmpt = &(t.dp[digs]);

    /* alias for where to read the right hand side from */
    tmpy = b->dp + (digs - ix);

    for (iy = digs - ix; iy < pb; iy++) {
      /* calculate the double precision result */
      r       = ((mp_word)*tmpt) +
                ((mp_word)tmpx) * ((mp_word)*tmpy++) +
                ((mp_word) u);

      /* get the lower part */
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));

      /* carry the carry */
      u       = (mp_digit) (r >> ((mp_word) DIGIT_BIT));
    }
    *tmpt = u;
  }
  mp_clamp (&t);
  mp_exch (&t, c);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_s_mp_mul_high_digs.c */

/* Start: bn_s_mp_sqr.c */
#include <tommath.h>
#ifdef BN_S_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */
int s_mp_sqr (mp_int * a, mp_int * b)
{
  mp_int  t;
  int     res, ix, iy, pa;
  mp_word r;
  mp_digit u, tmpx, *tmpt;

  pa = a->used;
  if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) {
    return res;
  }

  /* default used is maximum possible size */
  t.used = 2*pa + 1;

  for (ix = 0; ix < pa; ix++) {
    /* first calculate the digit at 2*ix */
    /* calculate double precision result */
    r = ((mp_word) t.dp[2*ix]) +
        ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]);

    /* store lower part in result */
    t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK));

    /* get the carry */
    u           = (mp_digit)(r >> ((mp_word) DIGIT_BIT));

    /* left hand side of A[ix] * A[iy] */
    tmpx        = a->dp[ix];

    /* alias for where to store the results */
    tmpt        = t.dp + (2*ix + 1);
    
    for (iy = ix + 1; iy < pa; iy++) {
      /* first calculate the product */
      r       = ((mp_word)tmpx) * ((mp_word)a->dp[iy]);

      /* now calculate the double precision result, note we use
       * addition instead of *2 since it's easier to optimize
       */
      r       = ((mp_word) *tmpt) + r + r + ((mp_word) u);

      /* store lower part */
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));

      /* get carry */
      u       = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
    }
    /* propagate upwards */
    while (u != ((mp_digit) 0)) {
      r       = ((mp_word) *tmpt) + ((mp_word) u);
      *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK));
      u       = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
    }
  }

  mp_clamp (&t);
  mp_exch (&t, b);
  mp_clear (&t);
  return MP_OKAY;
}
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_s_mp_sqr.c */

/* Start: bn_s_mp_sub.c */
#include <tommath.h>
#ifdef BN_S_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */
int
s_mp_sub (mp_int * a, mp_int * b, mp_int * c)
{
  int     olduse, res, min, max;

  /* find sizes */
  min = b->used;
  max = a->used;

  /* init result */
  if (c->alloc < max) {
    if ((res = mp_grow (c, max)) != MP_OKAY) {
      return res;
    }
  }
  olduse = c->used;
  c->used = max;

  {
    register mp_digit u, *tmpa, *tmpb, *tmpc;
    register int i;

    /* alias for digit pointers */
    tmpa = a->dp;
    tmpb = b->dp;
    tmpc = c->dp;

    /* set carry to zero */
    u = 0;
    for (i = 0; i < min; i++) {
      /* T[i] = A[i] - B[i] - U */
      *tmpc = *tmpa++ - *tmpb++ - u;

      /* U = carry bit of T[i]
       * Note this saves performing an AND operation since
       * if a carry does occur it will propagate all the way to the
       * MSB.  As a result a single shift is enough to get the carry
       */
      u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1));

      /* Clear carry from T[i] */
      *tmpc++ &= MP_MASK;
    }

    /* now copy higher words if any, e.g. if A has more digits than B  */
    for (; i < max; i++) {
      /* T[i] = A[i] - U */
      *tmpc = *tmpa++ - u;

      /* U = carry bit of T[i] */
      u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1));

      /* Clear carry from T[i] */
      *tmpc++ &= MP_MASK;
    }

    /* clear digits above used (since we may not have grown result above) */
    for (i = c->used; i < olduse; i++) {
      *tmpc++ = 0;
    }
  }

  mp_clamp (c);
  return MP_OKAY;
}

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bn_s_mp_sub.c */

/* Start: bncore.c */
#include <tommath.h>
#ifdef BNCORE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */

/* Known optimal configurations

 CPU                    /Compiler     /MUL CUTOFF/SQR CUTOFF
-------------------------------------------------------------
 Intel P4 Northwood     /GCC v3.4.1   /        88/       128/LTM 0.32 ;-)
 AMD Athlon64           /GCC v3.4.4   /        80/       120/LTM 0.35
 
*/

int     KARATSUBA_MUL_CUTOFF = 80,      /* Min. number of digits before Karatsuba multiplication is used. */
        KARATSUBA_SQR_CUTOFF = 120,     /* Min. number of digits before Karatsuba squaring is used. */
        
        TOOM_MUL_CUTOFF      = 350,      /* no optimal values of these are known yet so set em high */
        TOOM_SQR_CUTOFF      = 400; 
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

/* End: bncore.c */


/* EOF */

Added libtommath/tombc/grammar.txt.







































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
program       := program statement | statement | empty
statement     := { statement }                                                                              | 
                 identifier = numexpression;                                                                | 
                 identifier[numexpression] = numexpression;                                                 |
                 function(expressionlist);                                                                  | 
                 for (identifer = numexpression; numexpression; identifier = numexpression) { statement }   |
                 while (numexpression) { statement }                                                        | 
                 if (numexpresion) { statement } elif                                                       | 
                 break;                                                                                     | 
                 continue;                                                                                  
                 
elif          := else statement | empty
function      := abs | countbits | exptmod | jacobi | print | isprime | nextprime | issquare | readinteger | exit
expressionlist := expressionlist, expression | expression

// LR(1) !!!?
expression    := string | numexpression
numexpression := cmpexpr && cmpexpr | cmpexpr \|\| cmpexpr | cmpexpr
cmpexpr       := boolexpr  < boolexpr | boolexpr  > boolexpr | boolexpr == boolexpr | 
                 boolexpr <= boolexpr | boolexpr >= boolexpr | boolexpr
boolexpr      := shiftexpr & shiftexpr | shiftexpr ^ shiftexpr | shiftexpr \| shiftexpr | shiftexpr
shiftexpr     := addsubexpr << addsubexpr | addsubexpr >> addsubexpr | addsubexpr
addsubexpr    := mulexpr + mulexpr | mulexpr - mulexpr | mulexpr
mulexpr       := expr * expr       | expr / expr | expr % expr | expr
expr          := -nexpr | nexpr 
nexpr         := integer | identifier | ( numexpression ) | identifier[numexpression] 

identifier    := identifer digits | identifier alpha | alpha
alpha         := a ... z | A ... Z
integer       := hexnumber | digits 
hexnumber     := 0xhexdigits
hexdigits     := hexdigits hexdigit | hexdigit
hexdigit      := 0 ... 9 | a ... f | A ... F
digits        := digits digit | digit 
digit         := 0 ... 9

Added libtommath/tommath.h.

















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 *
 * Tom St Denis, [email protected], http://math.libtomcrypt.org
 */
#ifndef BN_H_
#define BN_H_

#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
#include <limits.h>

#include <tommath_class.h>

#ifndef MIN
   #define MIN(x,y) ((x)<(y)?(x):(y))
#endif

#ifndef MAX
   #define MAX(x,y) ((x)>(y)?(x):(y))
#endif

#ifdef __cplusplus
extern "C" {

/* C++ compilers don't like assigning void * to mp_digit * */
#define  OPT_CAST(x)  (x *)

#else

/* C on the other hand doesn't care */
#define  OPT_CAST(x)

#endif


/* detect 64-bit mode if possible */
#if defined(__x86_64__) 
   #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT))
      #define MP_64BIT
   #endif
#endif

/* some default configurations.
 *
 * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits
 * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits
 *
 * At the very least a mp_digit must be able to hold 7 bits
 * [any size beyond that is ok provided it doesn't overflow the data type]
 */
#ifdef MP_8BIT
   typedef unsigned char      mp_digit;
   typedef unsigned short     mp_word;
#elif defined(MP_16BIT)
   typedef unsigned short     mp_digit;
   typedef unsigned long      mp_word;
#elif defined(MP_64BIT)
   /* for GCC only on supported platforms */
#ifndef CRYPT
   typedef unsigned long long ulong64;
   typedef signed long long   long64;
#endif

   typedef unsigned long      mp_digit;
   typedef unsigned long      mp_word __attribute__ ((mode(TI)));

   #define DIGIT_BIT          60
#else
   /* this is the default case, 28-bit digits */
   
   /* this is to make porting into LibTomCrypt easier :-) */
#ifndef CRYPT
   #if defined(_MSC_VER) || defined(__BORLANDC__) 
      typedef unsigned __int64   ulong64;
      typedef signed __int64     long64;
   #else
      typedef unsigned long long ulong64;
      typedef signed long long   long64;
   #endif
#endif

   typedef unsigned long      mp_digit;
   typedef ulong64            mp_word;

#ifdef MP_31BIT   
   /* this is an extension that uses 31-bit digits */
   #define DIGIT_BIT          31
#else
   /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
   #define DIGIT_BIT          28
   #define MP_28BIT
#endif   
#endif

/* define heap macros */
#ifndef CRYPT
   /* default to libc stuff */
   #ifndef XMALLOC 
       #define XMALLOC  malloc
       #define XFREE    free
       #define XREALLOC realloc
       #define XCALLOC  calloc
   #else
      /* prototypes for our heap functions */
      extern void *XMALLOC(size_t n);
      extern void *XREALLOC(void *p, size_t n);
      extern void *XCALLOC(size_t n, size_t s);
      extern void XFREE(void *p);
   #endif
#endif


/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
#ifndef DIGIT_BIT
   #define DIGIT_BIT     ((int)((CHAR_BIT * sizeof(mp_digit) - 1)))  /* bits per digit */
#endif

#define MP_DIGIT_BIT     DIGIT_BIT
#define MP_MASK          ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
#define MP_DIGIT_MAX     MP_MASK

/* equalities */
#define MP_LT        -1   /* less than */
#define MP_EQ         0   /* equal to */
#define MP_GT         1   /* greater than */

#define MP_ZPOS       0   /* positive integer */
#define MP_NEG        1   /* negative */

#define MP_OKAY       0   /* ok result */
#define MP_MEM        -2  /* out of mem */
#define MP_VAL        -3  /* invalid input */
#define MP_RANGE      MP_VAL

#define MP_YES        1   /* yes response */
#define MP_NO         0   /* no response */

/* Primality generation flags */
#define LTM_PRIME_BBS      0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */
#define LTM_PRIME_2MSB_ON  0x0008 /* force 2nd MSB to 1 */

typedef int           mp_err;

/* you'll have to tune these... */
extern int KARATSUBA_MUL_CUTOFF,
           KARATSUBA_SQR_CUTOFF,
           TOOM_MUL_CUTOFF,
           TOOM_SQR_CUTOFF;

/* define this to use lower memory usage routines (exptmods mostly) */
/* #define MP_LOW_MEM */

/* default precision */
#ifndef MP_PREC
   #ifndef MP_LOW_MEM
      #define MP_PREC                 32     /* default digits of precision */
   #else
      #define MP_PREC                 8      /* default digits of precision */
   #endif   
#endif

/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY               (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1))

/* the infamous mp_int structure */
typedef struct  {
    int used, alloc, sign;
    mp_digit *dp;
} mp_int;

/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);


#define USED(m)    ((m)->used)
#define DIGIT(m,k) ((m)->dp[(k)])
#define SIGN(m)    ((m)->sign)

/* error code to char* string */
char *mp_error_to_string(int code);

/* ---> init and deinit bignum functions <--- */
/* init a bignum */
int mp_init(mp_int *a);

/* free a bignum */
void mp_clear(mp_int *a);

/* init a null terminated series of arguments */
int mp_init_multi(mp_int *mp, ...);

/* clear a null terminated series of arguments */
void mp_clear_multi(mp_int *mp, ...);

/* exchange two ints */
void mp_exch(mp_int *a, mp_int *b);

/* shrink ram required for a bignum */
int mp_shrink(mp_int *a);

/* grow an int to a given size */
int mp_grow(mp_int *a, int size);

/* init to a given number of digits */
int mp_init_size(mp_int *a, int size);

/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
#define mp_isodd(a)  (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)

/* set to zero */
void mp_zero(mp_int *a);

/* set to a digit */
void mp_set(mp_int *a, mp_digit b);

/* set a 32-bit const */
int mp_set_int(mp_int *a, unsigned long b);

/* get a 32-bit value */
unsigned long mp_get_int(mp_int * a);

/* initialize and set a digit */
int mp_init_set (mp_int * a, mp_digit b);

/* initialize and set 32-bit value */
int mp_init_set_int (mp_int * a, unsigned long b);

/* copy, b = a */
int mp_copy(mp_int *a, mp_int *b);

/* inits and copies, a = b */
int mp_init_copy(mp_int *a, mp_int *b);

/* trim unused digits */
void mp_clamp(mp_int *a);

/* ---> digit manipulation <--- */

/* right shift by "b" digits */
void mp_rshd(mp_int *a, int b);

/* left shift by "b" digits */
int mp_lshd(mp_int *a, int b);

/* c = a / 2**b */
int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d);

/* b = a/2 */
int mp_div_2(mp_int *a, mp_int *b);

/* c = a * 2**b */
int mp_mul_2d(mp_int *a, int b, mp_int *c);

/* b = a*2 */
int mp_mul_2(mp_int *a, mp_int *b);

/* c = a mod 2**d */
int mp_mod_2d(mp_int *a, int b, mp_int *c);

/* computes a = 2**b */
int mp_2expt(mp_int *a, int b);

/* Counts the number of lsbs which are zero before the first zero bit */
int mp_cnt_lsb(mp_int *a);

/* I Love Earth! */

/* makes a pseudo-random int of a given size */
int mp_rand(mp_int *a, int digits);

/* ---> binary operations <--- */
/* c = a XOR b  */
int mp_xor(mp_int *a, mp_int *b, mp_int *c);

/* c = a OR b */
int mp_or(mp_int *a, mp_int *b, mp_int *c);

/* c = a AND b */
int mp_and(mp_int *a, mp_int *b, mp_int *c);

/* ---> Basic arithmetic <--- */

/* b = -a */
int mp_neg(mp_int *a, mp_int *b);

/* b = |a| */
int mp_abs(mp_int *a, mp_int *b);

/* compare a to b */
int mp_cmp(mp_int *a, mp_int *b);

/* compare |a| to |b| */
int mp_cmp_mag(mp_int *a, mp_int *b);

/* c = a + b */
int mp_add(mp_int *a, mp_int *b, mp_int *c);

/* c = a - b */
int mp_sub(mp_int *a, mp_int *b, mp_int *c);

/* c = a * b */
int mp_mul(mp_int *a, mp_int *b, mp_int *c);

/* b = a*a  */
int mp_sqr(mp_int *a, mp_int *b);

/* a/b => cb + d == a */
int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* c = a mod b, 0 <= c < b  */
int mp_mod(mp_int *a, mp_int *b, mp_int *c);

/* ---> single digit functions <--- */

/* compare against a single digit */
int mp_cmp_d(mp_int *a, mp_digit b);

/* c = a + b */
int mp_add_d(mp_int *a, mp_digit b, mp_int *c);

/* c = a - b */
int mp_sub_d(mp_int *a, mp_digit b, mp_int *c);

/* c = a * b */
int mp_mul_d(mp_int *a, mp_digit b, mp_int *c);

/* a/b => cb + d == a */
int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d);

/* a/3 => 3c + d == a */
int mp_div_3(mp_int *a, mp_int *c, mp_digit *d);

/* c = a**b */
int mp_expt_d(mp_int *a, mp_digit b, mp_int *c);

/* c = a mod b, 0 <= c < b  */
int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c);

/* ---> number theory <--- */

/* d = a + b (mod c) */
int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* d = a - b (mod c) */
int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* d = a * b (mod c) */
int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* c = a * a (mod b) */
int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c);

/* c = 1/a (mod b) */
int mp_invmod(mp_int *a, mp_int *b, mp_int *c);

/* c = (a, b) */
int mp_gcd(mp_int *a, mp_int *b, mp_int *c);

/* produces value such that U1*a + U2*b = U3 */
int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3);

/* c = [a, b] or (a*b)/(a, b) */
int mp_lcm(mp_int *a, mp_int *b, mp_int *c);

/* finds one of the b'th root of a, such that |c|**b <= |a|
 *
 * returns error if a < 0 and b is even
 */
int mp_n_root(mp_int *a, mp_digit b, mp_int *c);

/* special sqrt algo */
int mp_sqrt(mp_int *arg, mp_int *ret);

/* is number a square? */
int mp_is_square(mp_int *arg, int *ret);

/* computes the jacobi c = (a | n) (or Legendre if b is prime)  */
int mp_jacobi(mp_int *a, mp_int *n, int *c);

/* used to setup the Barrett reduction for a given modulus b */
int mp_reduce_setup(mp_int *a, mp_int *b);

/* Barrett Reduction, computes a (mod b) with a precomputed value c
 *
 * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely
 * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code].
 */
int mp_reduce(mp_int *a, mp_int *b, mp_int *c);

/* setups the montgomery reduction */
int mp_montgomery_setup(mp_int *a, mp_digit *mp);

/* computes a = B**n mod b without division or multiplication useful for
 * normalizing numbers in a Montgomery system.
 */
int mp_montgomery_calc_normalization(mp_int *a, mp_int *b);

/* computes x/R == x (mod N) via Montgomery Reduction */
int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);

/* returns 1 if a is a valid DR modulus */
int mp_dr_is_modulus(mp_int *a);

/* sets the value of "d" required for mp_dr_reduce */
void mp_dr_setup(mp_int *a, mp_digit *d);

/* reduces a modulo b using the Diminished Radix method */
int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp);

/* returns true if a can be reduced with mp_reduce_2k */
int mp_reduce_is_2k(mp_int *a);

/* determines k value for 2k reduction */
int mp_reduce_2k_setup(mp_int *a, mp_digit *d);

/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d);

/* returns true if a can be reduced with mp_reduce_2k_l */
int mp_reduce_is_2k_l(mp_int *a);

/* determines k value for 2k reduction */
int mp_reduce_2k_setup_l(mp_int *a, mp_int *d);

/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d);

/* d = a**b (mod c) */
int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);

/* ---> Primes <--- */

/* number of primes */
#ifdef MP_8BIT
   #define PRIME_SIZE      31
#else
   #define PRIME_SIZE      256
#endif

/* table of first PRIME_SIZE primes */
extern const mp_digit ltm_prime_tab[];

/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
int mp_prime_is_divisible(mp_int *a, int *result);

/* performs one Fermat test of "a" using base "b".
 * Sets result to 0 if composite or 1 if probable prime
 */
int mp_prime_fermat(mp_int *a, mp_int *b, int *result);

/* performs one Miller-Rabin test of "a" using base "b".
 * Sets result to 0 if composite or 1 if probable prime
 */
int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result);

/* This gives [for a given bit size] the number of trials required
 * such that Miller-Rabin gives a prob of failure lower than 2^-96 
 */
int mp_prime_rabin_miller_trials(int size);

/* performs t rounds of Miller-Rabin on "a" using the first
 * t prime bases.  Also performs an initial sieve of trial
 * division.  Determines if "a" is prime with probability
 * of error no more than (1/4)**t.
 *
 * Sets result to 1 if probably prime, 0 otherwise
 */
int mp_prime_is_prime(mp_int *a, int t, int *result);

/* finds the next prime after the number "a" using "t" trials
 * of Miller-Rabin.
 *
 * bbs_style = 1 means the prime must be congruent to 3 mod 4
 */
int mp_prime_next_prime(mp_int *a, int t, int bbs_style);

/* makes a truly random prime of a given size (bytes),
 * call with bbs = 1 if you want it to be congruent to 3 mod 4 
 *
 * You have to supply a callback which fills in a buffer with random bytes.  "dat" is a parameter you can
 * have passed to the callback (e.g. a state or something).  This function doesn't use "dat" itself
 * so it can be NULL
 *
 * The prime generated will be larger than 2^(8*size).
 */
#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat)

/* makes a truly random prime of a given size (bits),
 *
 * Flags are as follows:
 * 
 *   LTM_PRIME_BBS      - make prime congruent to 3 mod 4
 *   LTM_PRIME_SAFE     - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS)
 *   LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero
 *   LTM_PRIME_2MSB_ON  - make the 2nd highest bit one
 *
 * You have to supply a callback which fills in a buffer with random bytes.  "dat" is a parameter you can
 * have passed to the callback (e.g. a state or something).  This function doesn't use "dat" itself
 * so it can be NULL
 *
 */
int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat);

/* ---> radix conversion <--- */
int mp_count_bits(mp_int *a);

int mp_unsigned_bin_size(mp_int *a);
int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c);
int mp_to_unsigned_bin(mp_int *a, unsigned char *b);
int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen);

int mp_signed_bin_size(mp_int *a);
int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c);
int mp_to_signed_bin(mp_int *a,  unsigned char *b);
int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen);

int mp_read_radix(mp_int *a, const char *str, int radix);
int mp_toradix(mp_int *a, char *str, int radix);
int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen);
int mp_radix_size(mp_int *a, int radix, int *size);

int mp_fread(mp_int *a, int radix, FILE *stream);
int mp_fwrite(mp_int *a, int radix, FILE *stream);

#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len))
#define mp_raw_size(mp)           mp_signed_bin_size(mp)
#define mp_toraw(mp, str)         mp_to_signed_bin((mp), (str))
#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len))
#define mp_mag_size(mp)           mp_unsigned_bin_size(mp)
#define mp_tomag(mp, str)         mp_to_unsigned_bin((mp), (str))

#define mp_tobinary(M, S)  mp_toradix((M), (S), 2)
#define mp_tooctal(M, S)   mp_toradix((M), (S), 8)
#define mp_todecimal(M, S) mp_toradix((M), (S), 10)
#define mp_tohex(M, S)     mp_toradix((M), (S), 16)

/* lowlevel functions, do not call! */
int s_mp_add(mp_int *a, mp_int *b, mp_int *c);
int s_mp_sub(mp_int *a, mp_int *b, mp_int *c);
#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
int fast_s_mp_sqr(mp_int *a, mp_int *b);
int s_mp_sqr(mp_int *a, mp_int *b);
int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c);
int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c);
int mp_karatsuba_sqr(mp_int *a, mp_int *b);
int mp_toom_sqr(mp_int *a, mp_int *b);
int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c);
int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c);
int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);
int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode);
int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode);
void bn_reverse(unsigned char *s, int len);

extern const char *mp_s_rmap;

#ifdef __cplusplus
   }
#endif

#endif


/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath.h,v $ */
/* $Revision: 1.1.1.1.2.4 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/tommath.pdf.

cannot compute difference between binary files

Added libtommath/tommath.src.

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
\documentclass[b5paper]{book}
\usepackage{hyperref}
\usepackage{makeidx}
\usepackage{amssymb}
\usepackage{color}
\usepackage{alltt}
\usepackage{graphicx}
\usepackage{layout}
\def\union{\cup}
\def\intersect{\cap}
\def\getsrandom{\stackrel{\rm R}{\gets}}
\def\cross{\times}
\def\cat{\hspace{0.5em} \| \hspace{0.5em}}
\def\catn{$\|$}
\def\divides{\hspace{0.3em} | \hspace{0.3em}}
\def\nequiv{\not\equiv}
\def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}}
\def\lcm{{\rm lcm}}
\def\gcd{{\rm gcd}}
\def\log{{\rm log}}
\def\ord{{\rm ord}}
\def\abs{{\mathit abs}}
\def\rep{{\mathit rep}}
\def\mod{{\mathit\ mod\ }}
\renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})}
\newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor}
\newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil}
\def\Or{{\rm\ or\ }}
\def\And{{\rm\ and\ }}
\def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}}
\def\implies{\Rightarrow}
\def\undefined{{\rm ``undefined"}}
\def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}}
\let\oldphi\phi
\def\phi{\varphi}
\def\Pr{{\rm Pr}}
\newcommand{\str}[1]{{\mathbf{#1}}}
\def\F{{\mathbb F}}
\def\N{{\mathbb N}}
\def\Z{{\mathbb Z}}
\def\R{{\mathbb R}}
\def\C{{\mathbb C}}
\def\Q{{\mathbb Q}}
\definecolor{DGray}{gray}{0.5}
\newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}}
\def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}}
\def\gap{\vspace{0.5ex}}
\makeindex
\begin{document}
\frontmatter
\pagestyle{empty}
\title{Multi--Precision Math}
\author{\mbox{
%\begin{small}
\begin{tabular}{c}
Tom St Denis \\
Algonquin College \\
\\
Mads Rasmussen \\
Open Communications Security \\
\\
Greg Rose \\
QUALCOMM Australia \\
\end{tabular}
%\end{small}
}
}
\maketitle
This text has been placed in the public domain.  This text corresponds to the v0.36 release of the 
LibTomMath project.

\begin{alltt}
Tom St Denis
111 Banning Rd
Ottawa, Ontario
K2L 1C3
Canada

Phone: 1-613-836-3160
Email: [email protected]
\end{alltt}

This text is formatted to the international B5 paper size of 176mm wide by 250mm tall using the \LaTeX{} 
{\em book} macro package and the Perl {\em booker} package.

\tableofcontents
\listoffigures
\chapter*{Prefaces}
When I tell people about my LibTom projects and that I release them as public domain they are often puzzled.  
They ask why I did it and especially why I continue to work on them for free.  The best I can explain it is ``Because I can.''  
Which seems odd and perhaps too terse for adult conversation. I often qualify it with ``I am able, I am willing.'' which 
perhaps explains it better.  I am the first to admit there is not anything that special with what I have done.  Perhaps
others can see that too and then we would have a society to be proud of.  My LibTom projects are what I am doing to give 
back to society in the form of tools and knowledge that can help others in their endeavours.

I started writing this book because it was the most logical task to further my goal of open academia.  The LibTomMath source
code itself was written to be easy to follow and learn from.  There are times, however, where pure C source code does not
explain the algorithms properly.  Hence this book.  The book literally starts with the foundation of the library and works
itself outwards to the more complicated algorithms.  The use of both pseudo--code and verbatim source code provides a duality
of ``theory'' and ``practice'' that the computer science students of the world shall appreciate.  I never deviate too far
from relatively straightforward algebra and I hope that this book can be a valuable learning asset.

This book and indeed much of the LibTom projects would not exist in their current form if it was not for a plethora
of kind people donating their time, resources and kind words to help support my work.  Writing a text of significant
length (along with the source code) is a tiresome and lengthy process.  Currently the LibTom project is four years old,
comprises of literally thousands of users and over 100,000 lines of source code, TeX and other material.  People like Mads and Greg 
were there at the beginning to encourage me to work well.  It is amazing how timely validation from others can boost morale to 
continue the project. Definitely my parents were there for me by providing room and board during the many months of work in 2003.  

To my many friends whom I have met through the years I thank you for the good times and the words of encouragement.  I hope I
honour your kind gestures with this project.

Open Source.  Open Academia.  Open Minds.

\begin{flushright} Tom St Denis \end{flushright}

\newpage
I found the opportunity to work with Tom appealing for several reasons, not only could I broaden my own horizons, but also 
contribute to educate others facing the problem of having to handle big number mathematical calculations.

This book is Tom's child and he has been caring and fostering the project ever since the beginning with a clear mind of 
how he wanted the project to turn out. I have helped by proofreading the text and we have had several discussions about 
the layout and language used.

I hold a masters degree in cryptography from the University of Southern Denmark and have always been interested in the 
practical aspects of cryptography. 

Having worked in the security consultancy business for several years in S\~{a}o Paulo, Brazil, I have been in touch with a 
great deal of work in which multiple precision mathematics was needed. Understanding the possibilities for speeding up 
multiple precision calculations is often very important since we deal with outdated machine architecture where modular 
reductions, for example, become painfully slow.

This text is for people who stop and wonder when first examining algorithms such as RSA for the first time and asks 
themselves, ``You tell me this is only secure for large numbers, fine; but how do you implement these numbers?''

\begin{flushright}
Mads Rasmussen

S\~{a}o Paulo - SP

Brazil
\end{flushright}

\newpage
It's all because I broke my leg. That just happened to be at about the same time that Tom asked for someone to review the section of the book about 
Karatsuba multiplication. I was laid up, alone and immobile, and thought ``Why not?'' I vaguely knew what Karatsuba multiplication was, but not 
really, so I thought I could help, learn, and stop myself from watching daytime cable TV, all at once.

At the time of writing this, I've still not met Tom or Mads in meatspace. I've been following Tom's progress since his first splash on the 
sci.crypt Usenet news group. I watched him go from a clueless newbie, to the cryptographic equivalent of a reformed smoker, to a real
contributor to the field, over a period of about two years. I've been impressed with his obvious intelligence, and astounded by his productivity. 
Of course, he's young enough to be my own child, so he doesn't have my problems with staying awake.

When I reviewed that single section of the book, in its very earliest form, I was very pleasantly surprised. So I decided to collaborate more fully, 
and at least review all of it, and perhaps write some bits too. There's still a long way to go with it, and I have watched a number of close 
friends go through the mill of publication, so I think that the way to go is longer than Tom thinks it is. Nevertheless, it's a good effort, 
and I'm pleased to be involved with it.

\begin{flushright}
Greg Rose, Sydney, Australia, June 2003. 
\end{flushright}

\mainmatter
\pagestyle{headings}
\chapter{Introduction}
\section{Multiple Precision Arithmetic}

\subsection{What is Multiple Precision Arithmetic?}
When we think of long-hand arithmetic such as addition or multiplication we rarely consider the fact that we instinctively
raise or lower the precision of the numbers we are dealing with.  For example, in decimal we almost immediate can 
reason that $7$ times $6$ is $42$.  However, $42$ has two digits of precision as opposed to one digit we started with.  
Further multiplications of say $3$ result in a larger precision result $126$.  In these few examples we have multiple 
precisions for the numbers we are working with.  Despite the various levels of precision a single subset\footnote{With the occasional optimization.}
 of algorithms can be designed to accomodate them.  

By way of comparison a fixed or single precision operation would lose precision on various operations.  For example, in
the decimal system with fixed precision $6 \cdot 7 = 2$.

Essentially at the heart of computer based multiple precision arithmetic are the same long-hand algorithms taught in
schools to manually add, subtract, multiply and divide.  

\subsection{The Need for Multiple Precision Arithmetic}
The most prevalent need for multiple precision arithmetic, often referred to as ``bignum'' math, is within the implementation
of public-key cryptography algorithms.   Algorithms such as RSA \cite{RSAREF} and Diffie-Hellman \cite{DHREF} require 
integers of significant magnitude to resist known cryptanalytic attacks.  For example, at the time of this writing a 
typical RSA modulus would be at least greater than $10^{309}$.  However, modern programming languages such as ISO C \cite{ISOC} and 
Java \cite{JAVA} only provide instrinsic support for integers which are relatively small and single precision.

\begin{figure}[!here]
\begin{center}
\begin{tabular}{|r|c|}
\hline \textbf{Data Type} & \textbf{Range} \\
\hline char  & $-128 \ldots 127$ \\
\hline short & $-32768 \ldots 32767$ \\
\hline long  & $-2147483648 \ldots 2147483647$ \\
\hline long long & $-9223372036854775808 \ldots 9223372036854775807$ \\
\hline
\end{tabular}
\end{center}
\caption{Typical Data Types for the C Programming Language}
\label{fig:ISOC}
\end{figure}

The largest data type guaranteed to be provided by the ISO C programming 
language\footnote{As per the ISO C standard.  However, each compiler vendor is allowed to augment the precision as they 
see fit.}  can only represent values up to $10^{19}$ as shown in figure \ref{fig:ISOC}. On its own the C language is 
insufficient to accomodate the magnitude required for the problem at hand.  An RSA modulus of magnitude $10^{19}$ could be 
trivially factored\footnote{A Pollard-Rho factoring would take only $2^{16}$ time.} on the average desktop computer, 
rendering any protocol based on the algorithm insecure.  Multiple precision algorithms solve this very problem by 
extending the range of representable integers while using single precision data types.

Most advancements in fast multiple precision arithmetic stem from the need for faster and more efficient cryptographic 
primitives.  Faster modular reduction and exponentiation algorithms such as Barrett's algorithm, which have appeared in 
various cryptographic journals, can render algorithms such as RSA and Diffie-Hellman more efficient.  In fact, several 
major companies such as RSA Security, Certicom and Entrust have built entire product lines on the implementation and 
deployment of efficient algorithms.

However, cryptography is not the only field of study that can benefit from fast multiple precision integer routines.  
Another auxiliary use of multiple precision integers is high precision floating point data types.  
The basic IEEE \cite{IEEE} standard floating point type is made up of an integer mantissa $q$, an exponent $e$ and a sign bit $s$.  
Numbers are given in the form $n = q \cdot b^e \cdot -1^s$ where $b = 2$ is the most common base for IEEE.  Since IEEE 
floating point is meant to be implemented in hardware the precision of the mantissa is often fairly small 
(\textit{23, 48 and 64 bits}).  The mantissa is merely an integer and a multiple precision integer could be used to create
a mantissa of much larger precision than hardware alone can efficiently support.  This approach could be useful where 
scientific applications must minimize the total output error over long calculations.

Yet another use for large integers is within arithmetic on polynomials of large characteristic (i.e. $GF(p)[x]$ for large $p$).
In fact the library discussed within this text has already been used to form a polynomial basis library\footnote{See \url{http://poly.libtomcrypt.org} for more details.}.

\subsection{Benefits of Multiple Precision Arithmetic}
\index{precision}
The benefit of multiple precision representations over single or fixed precision representations is that 
no precision is lost while representing the result of an operation which requires excess precision.  For example, 
the product of two $n$-bit integers requires at least $2n$ bits of precision to be represented faithfully.  A multiple 
precision algorithm would augment the precision of the destination to accomodate the result while a single precision system 
would truncate excess bits to maintain a fixed level of precision.

It is possible to implement algorithms which require large integers with fixed precision algorithms.  For example, elliptic
curve cryptography (\textit{ECC}) is often implemented on smartcards by fixing the precision of the integers to the maximum 
size the system will ever need.  Such an approach can lead to vastly simpler algorithms which can accomodate the 
integers required even if the host platform cannot natively accomodate them\footnote{For example, the average smartcard 
processor has an 8 bit accumulator.}.  However, as efficient as such an approach may be, the resulting source code is not
normally very flexible.  It cannot, at runtime, accomodate inputs of higher magnitude than the designer anticipated.

Multiple precision algorithms have the most overhead of any style of arithmetic.  For the the most part the 
overhead can be kept to a minimum with careful planning, but overall, it is not well suited for most memory starved
platforms.  However, multiple precision algorithms do offer the most flexibility in terms of the magnitude of the 
inputs.  That is, the same algorithms based on multiple precision integers can accomodate any reasonable size input 
without the designer's explicit forethought.  This leads to lower cost of ownership for the code as it only has to 
be written and tested once.

\section{Purpose of This Text}
The purpose of this text is to instruct the reader regarding how to implement efficient multiple precision algorithms.  
That is to not only explain a limited subset of the core theory behind the algorithms but also the various ``house keeping'' 
elements that are neglected by authors of other texts on the subject.  Several well reknowned texts \cite{TAOCPV2,HAC} 
give considerably detailed explanations of the theoretical aspects of algorithms and often very little information 
regarding the practical implementation aspects.  

In most cases how an algorithm is explained and how it is actually implemented are two very different concepts.  For 
example, the Handbook of Applied Cryptography (\textit{HAC}), algorithm 14.7 on page 594, gives a relatively simple 
algorithm for performing multiple precision integer addition.  However, the description lacks any discussion concerning 
the fact that the two integer inputs may be of differing magnitudes.  As a result the implementation is not as simple
as the text would lead people to believe.  Similarly the division routine (\textit{algorithm 14.20, pp. 598}) does not 
discuss how to handle sign or handle the dividend's decreasing magnitude in the main loop (\textit{step \#3}).

Both texts also do not discuss several key optimal algorithms required such as ``Comba'' and Karatsuba multipliers 
and fast modular inversion, which we consider practical oversights.  These optimal algorithms are vital to achieve 
any form of useful performance in non-trivial applications.  

To solve this problem the focus of this text is on the practical aspects of implementing a multiple precision integer
package.  As a case study the ``LibTomMath''\footnote{Available at \url{http://math.libtomcrypt.org}} package is used 
to demonstrate algorithms with real implementations\footnote{In the ISO C programming language.} that have been field 
tested and work very well.  The LibTomMath library is freely available on the Internet for all uses and this text 
discusses a very large portion of the inner workings of the library.

The algorithms that are presented will always include at least one ``pseudo-code'' description followed 
by the actual C source code that implements the algorithm.  The pseudo-code can be used to implement the same 
algorithm in other programming languages as the reader sees fit.  

This text shall also serve as a walkthrough of the creation of multiple precision algorithms from scratch.  Showing
the reader how the algorithms fit together as well as where to start on various taskings.  

\section{Discussion and Notation}
\subsection{Notation}
A multiple precision integer of $n$-digits shall be denoted as $x = (x_{n-1}, \ldots, x_1, x_0)_{ \beta }$ and represent
the integer $x \equiv \sum_{i=0}^{n-1} x_i\beta^i$.  The elements of the array $x$ are said to be the radix $\beta$ digits 
of the integer.  For example, $x = (1,2,3)_{10}$ would represent the integer 
$1\cdot 10^2 + 2\cdot10^1 + 3\cdot10^0 = 123$.  

\index{mp\_int}
The term ``mp\_int'' shall refer to a composite structure which contains the digits of the integer it represents, as well 
as auxilary data required to manipulate the data.  These additional members are discussed further in section 
\ref{sec:MPINT}.  For the purposes of this text a ``multiple precision integer'' and an ``mp\_int'' are assumed to be 
synonymous.  When an algorithm is specified to accept an mp\_int variable it is assumed the various auxliary data members 
are present as well.  An expression of the type \textit{variablename.item} implies that it should evaluate to the 
member named ``item'' of the variable.  For example, a string of characters may have a member ``length'' which would 
evaluate to the number of characters in the string.  If the string $a$ equals ``hello'' then it follows that 
$a.length = 5$.  

For certain discussions more generic algorithms are presented to help the reader understand the final algorithm used
to solve a given problem.  When an algorithm is described as accepting an integer input it is assumed the input is 
a plain integer with no additional multiple-precision members.  That is, algorithms that use integers as opposed to 
mp\_ints as inputs do not concern themselves with the housekeeping operations required such as memory management.  These 
algorithms will be used to establish the relevant theory which will subsequently be used to describe a multiple
precision algorithm to solve the same problem.  

\subsection{Precision Notation}
The variable $\beta$ represents the radix of a single digit of a multiple precision integer and 
must be of the form $q^p$ for $q, p \in \Z^+$.  A single precision variable must be able to represent integers in 
the range $0 \le x < q \beta$ while a double precision variable must be able to represent integers in the range 
$0 \le x < q \beta^2$.  The extra radix-$q$ factor allows additions and subtractions to proceed without truncation of the 
carry.  Since all modern computers are binary, it is assumed that $q$ is two.

\index{mp\_digit} \index{mp\_word}
Within the source code that will be presented for each algorithm, the data type \textbf{mp\_digit} will represent 
a single precision integer type, while, the data type \textbf{mp\_word} will represent a double precision integer type.  In 
several algorithms (notably the Comba routines) temporary results will be stored in arrays of double precision mp\_words.  
For the purposes of this text $x_j$ will refer to the $j$'th digit of a single precision array and $\hat x_j$ will refer to 
the $j$'th digit of a double precision array.  Whenever an expression is to be assigned to a double precision
variable it is assumed that all single precision variables are promoted to double precision during the evaluation.  
Expressions that are assigned to a single precision variable are truncated to fit within the precision of a single
precision data type.

For example, if $\beta = 10^2$ a single precision data type may represent a value in the 
range $0 \le x < 10^3$, while a double precision data type may represent a value in the range $0 \le x < 10^5$.  Let
$a = 23$ and $b = 49$ represent two single precision variables.  The single precision product shall be written
as $c \leftarrow a \cdot b$ while the double precision product shall be written as $\hat c \leftarrow a \cdot b$.
In this particular case, $\hat c = 1127$ and $c = 127$.  The most significant digit of the product would not fit 
in a single precision data type and as a result $c \ne \hat c$.  

\subsection{Algorithm Inputs and Outputs}
Within the algorithm descriptions all variables are assumed to be scalars of either single or double precision
as indicated.  The only exception to this rule is when variables have been indicated to be of type mp\_int.  This 
distinction is important as scalars are often used as array indicies and various other counters.  

\subsection{Mathematical Expressions}
The $\lfloor \mbox{ } \rfloor$ brackets imply an expression truncated to an integer not greater than the expression 
itself.  For example, $\lfloor 5.7 \rfloor = 5$.  Similarly the $\lceil \mbox{ } \rceil$ brackets imply an expression
rounded to an integer not less than the expression itself.  For example, $\lceil 5.1 \rceil = 6$.  Typically when 
the $/$ division symbol is used the intention is to perform an integer division with truncation.  For example, 
$5/2 = 2$ which will often be written as $\lfloor 5/2 \rfloor = 2$ for clarity.  When an expression is written as a 
fraction a real value division is implied, for example ${5 \over 2} = 2.5$.  

The norm of a multiple precision integer, for example $\vert \vert x \vert \vert$, will be used to represent the number of digits in the representation
of the integer.  For example, $\vert \vert 123 \vert \vert = 3$ and $\vert \vert 79452 \vert \vert = 5$.  

\subsection{Work Effort}
\index{big-Oh}
To measure the efficiency of the specified algorithms, a modified big-Oh notation is used.  In this system all 
single precision operations are considered to have the same cost\footnote{Except where explicitly noted.}.  
That is a single precision addition, multiplication and division are assumed to take the same time to 
complete.  While this is generally not true in practice, it will simplify the discussions considerably.

Some algorithms have slight advantages over others which is why some constants will not be removed in 
the notation.  For example, a normal baseline multiplication (section \ref{sec:basemult}) requires $O(n^2)$ work while a 
baseline squaring (section \ref{sec:basesquare}) requires $O({{n^2 + n}\over 2})$ work.  In standard big-Oh notation these 
would both be said to be equivalent to $O(n^2)$.  However, 
in the context of the this text this is not the case as the magnitude of the inputs will typically be rather small.  As a 
result small constant factors in the work effort will make an observable difference in algorithm efficiency.

All of the algorithms presented in this text have a polynomial time work level.  That is, of the form 
$O(n^k)$ for $n, k \in \Z^{+}$.  This will help make useful comparisons in terms of the speed of the algorithms and how 
various optimizations will help pay off in the long run.

\section{Exercises}
Within the more advanced chapters a section will be set aside to give the reader some challenging exercises related to
the discussion at hand.  These exercises are not designed to be prize winning problems, but instead to be thought 
provoking.  Wherever possible the problems are forward minded, stating problems that will be answered in subsequent 
chapters.  The reader is encouraged to finish the exercises as they appear to get a better understanding of the 
subject material.  

That being said, the problems are designed to affirm knowledge of a particular subject matter.  Students in particular
are encouraged to verify they can answer the problems correctly before moving on.

Similar to the exercises of \cite[pp. ix]{TAOCPV2} these exercises are given a scoring system based on the difficulty of
the problem.  However, unlike \cite{TAOCPV2} the problems do not get nearly as hard.  The scoring of these 
exercises ranges from one (the easiest) to five (the hardest).  The following table sumarizes the 
scoring system used.

\begin{figure}[here]
\begin{center}
\begin{small}
\begin{tabular}{|c|l|}
\hline $\left [ 1 \right ]$ & An easy problem that should only take the reader a manner of \\
                            & minutes to solve.  Usually does not involve much computer time \\
                            & to solve. \\
\hline $\left [ 2 \right ]$ & An easy problem that involves a marginal amount of computer \\
                     & time usage.  Usually requires a program to be written to \\
                     & solve the problem. \\
\hline $\left [ 3 \right ]$ & A moderately hard problem that requires a non-trivial amount \\
                     & of work.  Usually involves trivial research and development of \\
                     & new theory from the perspective of a student. \\
\hline $\left [ 4 \right ]$ & A moderately hard problem that involves a non-trivial amount \\
                     & of work and research, the solution to which will demonstrate \\
                     & a higher mastery of the subject matter. \\
\hline $\left [ 5 \right ]$ & A hard problem that involves concepts that are difficult for a \\
                     & novice to solve.  Solutions to these problems will demonstrate a \\
                     & complete mastery of the given subject. \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Exercise Scoring System}
\end{figure}

Problems at the first level are meant to be simple questions that the reader can answer quickly without programming a solution or
devising new theory.  These problems are quick tests to see if the material is understood.  Problems at the second level 
are also designed to be easy but will require a program or algorithm to be implemented to arrive at the answer.  These
two levels are essentially entry level questions.  

Problems at the third level are meant to be a bit more difficult than the first two levels.  The answer is often 
fairly obvious but arriving at an exacting solution requires some thought and skill.  These problems will almost always 
involve devising a new algorithm or implementing a variation of another algorithm previously presented.  Readers who can
answer these questions will feel comfortable with the concepts behind the topic at hand.

Problems at the fourth level are meant to be similar to those of the level three questions except they will require 
additional research to be completed.  The reader will most likely not know the answer right away, nor will the text provide 
the exact details of the answer until a subsequent chapter.  

Problems at the fifth level are meant to be the hardest 
problems relative to all the other problems in the chapter.  People who can correctly answer fifth level problems have a 
mastery of the subject matter at hand.

Often problems will be tied together.  The purpose of this is to start a chain of thought that will be discussed in future chapters.  The reader
is encouraged to answer the follow-up problems and try to draw the relevance of problems.

\section{Introduction to LibTomMath}

\subsection{What is LibTomMath?}
LibTomMath is a free and open source multiple precision integer library written entirely in portable ISO C.  By portable it 
is meant that the library does not contain any code that is computer platform dependent or otherwise problematic to use on 
any given platform.  

The library has been successfully tested under numerous operating systems including Unix\footnote{All of these
trademarks belong to their respective rightful owners.}, MacOS, Windows, Linux, PalmOS and on standalone hardware such 
as the Gameboy Advance.  The library is designed to contain enough functionality to be able to develop applications such 
as public key cryptosystems and still maintain a relatively small footprint.

\subsection{Goals of LibTomMath}

Libraries which obtain the most efficiency are rarely written in a high level programming language such as C.  However, 
even though this library is written entirely in ISO C, considerable care has been taken to optimize the algorithm implementations within the 
library.  Specifically the code has been written to work well with the GNU C Compiler (\textit{GCC}) on both x86 and ARM 
processors.  Wherever possible, highly efficient algorithms, such as Karatsuba multiplication, sliding window 
exponentiation and Montgomery reduction have been provided to make the library more efficient.  

Even with the nearly optimal and specialized algorithms that have been included the Application Programing Interface 
(\textit{API}) has been kept as simple as possible.  Often generic place holder routines will make use of specialized 
algorithms automatically without the developer's specific attention.  One such example is the generic multiplication 
algorithm \textbf{mp\_mul()} which will automatically use Toom--Cook, Karatsuba, Comba or baseline multiplication 
based on the magnitude of the inputs and the configuration of the library.  

Making LibTomMath as efficient as possible is not the only goal of the LibTomMath project.  Ideally the library should 
be source compatible with another popular library which makes it more attractive for developers to use.  In this case the
MPI library was used as a API template for all the basic functions.  MPI was chosen because it is another library that fits 
in the same niche as LibTomMath.  Even though LibTomMath uses MPI as the template for the function names and argument 
passing conventions, it has been written from scratch by Tom St Denis.

The project is also meant to act as a learning tool for students, the logic being that no easy-to-follow ``bignum'' 
library exists which can be used to teach computer science students how to perform fast and reliable multiple precision 
integer arithmetic.  To this end the source code has been given quite a few comments and algorithm discussion points.  

\section{Choice of LibTomMath}
LibTomMath was chosen as the case study of this text not only because the author of both projects is one and the same but
for more worthy reasons.  Other libraries such as GMP \cite{GMP}, MPI \cite{MPI}, LIP \cite{LIP} and OpenSSL 
\cite{OPENSSL} have multiple precision integer arithmetic routines but would not be ideal for this text for 
reasons that will be explained in the following sub-sections.

\subsection{Code Base}
The LibTomMath code base is all portable ISO C source code.  This means that there are no platform dependent conditional
segments of code littered throughout the source.  This clean and uncluttered approach to the library means that a
developer can more readily discern the true intent of a given section of source code without trying to keep track of
what conditional code will be used.

The code base of LibTomMath is well organized.  Each function is in its own separate source code file 
which allows the reader to find a given function very quickly.  On average there are $76$ lines of code per source
file which makes the source very easily to follow.  By comparison MPI and LIP are single file projects making code tracing
very hard.  GMP has many conditional code segments which also hinder tracing.  

When compiled with GCC for the x86 processor and optimized for speed the entire library is approximately $100$KiB\footnote{The notation ``KiB'' means $2^{10}$ octets, similarly ``MiB'' means $2^{20}$ octets.}
 which is fairly small compared to GMP (over $250$KiB).  LibTomMath is slightly larger than MPI (which compiles to about 
$50$KiB) but LibTomMath is also much faster and more complete than MPI.

\subsection{API Simplicity}
LibTomMath is designed after the MPI library and shares the API design.  Quite often programs that use MPI will build 
with LibTomMath without change. The function names correlate directly to the action they perform.  Almost all of the 
functions share the same parameter passing convention.  The learning curve is fairly shallow with the API provided 
which is an extremely valuable benefit for the student and developer alike.  

The LIP library is an example of a library with an API that is awkward to work with.  LIP uses function names that are often ``compressed'' to 
illegible short hand.  LibTomMath does not share this characteristic.  

The GMP library also does not return error codes.  Instead it uses a POSIX.1 \cite{POSIX1} signal system where errors
are signaled to the host application.  This happens to be the fastest approach but definitely not the most versatile.  In
effect a math error (i.e. invalid input, heap error, etc) can cause a program to stop functioning which is definitely 
undersireable in many situations.

\subsection{Optimizations}
While LibTomMath is certainly not the fastest library (GMP often beats LibTomMath by a factor of two) it does
feature a set of optimal algorithms for tasks such as modular reduction, exponentiation, multiplication and squaring.  GMP 
and LIP also feature such optimizations while MPI only uses baseline algorithms with no optimizations.  GMP lacks a few
of the additional modular reduction optimizations that LibTomMath features\footnote{At the time of this writing GMP
only had Barrett and Montgomery modular reduction algorithms.}.  

LibTomMath is almost always an order of magnitude faster than the MPI library at computationally expensive tasks such as modular
exponentiation.  In the grand scheme of ``bignum'' libraries LibTomMath is faster than the average library and usually  
slower than the best libraries such as GMP and OpenSSL by only a small factor.

\subsection{Portability and Stability}
LibTomMath will build ``out of the box'' on any platform equipped with a modern version of the GNU C Compiler 
(\textit{GCC}).  This means that without changes the library will build without configuration or setting up any 
variables.  LIP and MPI will build ``out of the box'' as well but have numerous known bugs.  Most notably the author of 
MPI has recently stopped working on his library and LIP has long since been discontinued.  

GMP requires a configuration script to run and will not build out of the box.   GMP and LibTomMath are still in active
development and are very stable across a variety of platforms.

\subsection{Choice}
LibTomMath is a relatively compact, well documented, highly optimized and portable library which seems only natural for
the case study of this text.  Various source files from the LibTomMath project will be included within the text.  However, 
the reader is encouraged to download their own copy of the library to actually be able to work with the library.  

\chapter{Getting Started}
\section{Library Basics}
The trick to writing any useful library of source code is to build a solid foundation and work outwards from it.  First, 
a problem along with allowable solution parameters should be identified and analyzed.  In this particular case the 
inability to accomodate multiple precision integers is the problem.  Futhermore, the solution must be written
as portable source code that is reasonably efficient across several different computer platforms.

After a foundation is formed the remainder of the library can be designed and implemented in a hierarchical fashion.  
That is, to implement the lowest level dependencies first and work towards the most abstract functions last.  For example, 
before implementing a modular exponentiation algorithm one would implement a modular reduction algorithm.
By building outwards from a base foundation instead of using a parallel design methodology the resulting project is 
highly modular.  Being highly modular is a desirable property of any project as it often means the resulting product
has a small footprint and updates are easy to perform.  

Usually when I start a project I will begin with the header files.  I define the data types I think I will need and 
prototype the initial functions that are not dependent on other functions (within the library).  After I 
implement these base functions I prototype more dependent functions and implement them.   The process repeats until
I implement all of the functions I require.  For example, in the case of LibTomMath I implemented functions such as 
mp\_init() well before I implemented mp\_mul() and even further before I implemented mp\_exptmod().  As an example as to 
why this design works note that the Karatsuba and Toom-Cook multipliers were written \textit{after} the 
dependent function mp\_exptmod() was written.  Adding the new multiplication algorithms did not require changes to the 
mp\_exptmod() function itself and lowered the total cost of ownership (\textit{so to speak}) and of development 
for new algorithms.  This methodology allows new algorithms to be tested in a complete framework with relative ease.

FIGU,design_process,Design Flow of the First Few Original LibTomMath Functions.

Only after the majority of the functions were in place did I pursue a less hierarchical approach to auditing and optimizing
the source code.  For example, one day I may audit the multipliers and the next day the polynomial basis functions.  

It only makes sense to begin the text with the preliminary data types and support algorithms required as well.  
This chapter discusses the core algorithms of the library which are the dependents for every other algorithm.

\section{What is a Multiple Precision Integer?}
Recall that most programming languages, in particular ISO C \cite{ISOC}, only have fixed precision data types that on their own cannot 
be used to represent values larger than their precision will allow. The purpose of multiple precision algorithms is 
to use fixed precision data types to create and manipulate multiple precision integers which may represent values 
that are very large.  

As a well known analogy, school children are taught how to form numbers larger than nine by prepending more radix ten digits.  In the decimal system
the largest single digit value is $9$.  However, by concatenating digits together larger numbers may be represented.  Newly prepended digits 
(\textit{to the left}) are said to be in a different power of ten column.  That is, the number $123$ can be described as having a $1$ in the hundreds 
column, $2$ in the tens column and $3$ in the ones column.  Or more formally $123 = 1 \cdot 10^2 + 2 \cdot 10^1 + 3 \cdot 10^0$.  Computer based 
multiple precision arithmetic is essentially the same concept.  Larger integers are represented by adjoining fixed 
precision computer words with the exception that a different radix is used.

What most people probably do not think about explicitly are the various other attributes that describe a multiple precision 
integer.  For example, the integer $154_{10}$ has two immediately obvious properties.  First, the integer is positive, 
that is the sign of this particular integer is positive as opposed to negative.  Second, the integer has three digits in 
its representation.  There is an additional property that the integer posesses that does not concern pencil-and-paper 
arithmetic.  The third property is how many digits placeholders are available to hold the integer.  

The human analogy of this third property is ensuring there is enough space on the paper to write the integer.  For example,
if one starts writing a large number too far to the right on a piece of paper they will have to erase it and move left.  
Similarly, computer algorithms must maintain strict control over memory usage to ensure that the digits of an integer
will not exceed the allowed boundaries.  These three properties make up what is known as a multiple precision 
integer or mp\_int for short.  

\subsection{The mp\_int Structure}
\label{sec:MPINT}
The mp\_int structure is the ISO C based manifestation of what represents a multiple precision integer.  The ISO C standard does not provide for 
any such data type but it does provide for making composite data types known as structures.  The following is the structure definition 
used within LibTomMath.

\index{mp\_int}
\begin{figure}[here]
\begin{center}
\begin{small}
%\begin{verbatim}
\begin{tabular}{|l|}
\hline
typedef struct \{ \\
\hspace{3mm}int used, alloc, sign;\\
\hspace{3mm}mp\_digit *dp;\\
\} \textbf{mp\_int}; \\
\hline
\end{tabular}
%\end{verbatim}
\end{small}
\caption{The mp\_int Structure}
\label{fig:mpint}
\end{center}
\end{figure}

The mp\_int structure (fig. \ref{fig:mpint}) can be broken down as follows.

\begin{enumerate}
\item The \textbf{used} parameter denotes how many digits of the array \textbf{dp} contain the digits used to represent
a given integer.  The \textbf{used} count must be positive (or zero) and may not exceed the \textbf{alloc} count.  

\item The \textbf{alloc} parameter denotes how 
many digits are available in the array to use by functions before it has to increase in size.  When the \textbf{used} count 
of a result would exceed the \textbf{alloc} count all of the algorithms will automatically increase the size of the 
array to accommodate the precision of the result.  

\item The pointer \textbf{dp} points to a dynamically allocated array of digits that represent the given multiple 
precision integer.  It is padded with $(\textbf{alloc} - \textbf{used})$ zero digits.  The array is maintained in a least 
significant digit order.  As a pencil and paper analogy the array is organized such that the right most digits are stored
first starting at the location indexed by zero\footnote{In C all arrays begin at zero.} in the array.  For example, 
if \textbf{dp} contains $\lbrace a, b, c, \ldots \rbrace$ where \textbf{dp}$_0 = a$, \textbf{dp}$_1 = b$, \textbf{dp}$_2 = c$, $\ldots$ then 
it would represent the integer $a + b\beta + c\beta^2 + \ldots$  

\index{MP\_ZPOS} \index{MP\_NEG}
\item The \textbf{sign} parameter denotes the sign as either zero/positive (\textbf{MP\_ZPOS}) or negative (\textbf{MP\_NEG}).  
\end{enumerate}

\subsubsection{Valid mp\_int Structures}
Several rules are placed on the state of an mp\_int structure and are assumed to be followed for reasons of efficiency.  
The only exceptions are when the structure is passed to initialization functions such as mp\_init() and mp\_init\_copy().

\begin{enumerate}
\item The value of \textbf{alloc} may not be less than one.  That is \textbf{dp} always points to a previously allocated
array of digits.
\item The value of \textbf{used} may not exceed \textbf{alloc} and must be greater than or equal to zero.
\item The value of \textbf{used} implies the digit at index $(used - 1)$ of the \textbf{dp} array is non-zero.  That is, 
leading zero digits in the most significant positions must be trimmed.
   \begin{enumerate}
   \item Digits in the \textbf{dp} array at and above the \textbf{used} location must be zero.
   \end{enumerate}
\item The value of \textbf{sign} must be \textbf{MP\_ZPOS} if \textbf{used} is zero; 
this represents the mp\_int value of zero.
\end{enumerate}

\section{Argument Passing}
A convention of argument passing must be adopted early on in the development of any library.  Making the function 
prototypes consistent will help eliminate many headaches in the future as the library grows to significant complexity.  
In LibTomMath the multiple precision integer functions accept parameters from left to right as pointers to mp\_int 
structures.  That means that the source (input) operands are placed on the left and the destination (output) on the right.   
Consider the following examples.

\begin{verbatim}
   mp_mul(&a, &b, &c);   /* c = a * b */
   mp_add(&a, &b, &a);   /* a = a + b */
   mp_sqr(&a, &b);       /* b = a * a */
\end{verbatim}

The left to right order is a fairly natural way to implement the functions since it lets the developer read aloud the
functions and make sense of them.  For example, the first function would read ``multiply a and b and store in c''.

Certain libraries (\textit{LIP by Lenstra for instance}) accept parameters the other way around, to mimic the order
of assignment expressions.  That is, the destination (output) is on the left and arguments (inputs) are on the right.  In 
truth, it is entirely a matter of preference.  In the case of LibTomMath the convention from the MPI library has been 
adopted.  

Another very useful design consideration, provided for in LibTomMath, is whether to allow argument sources to also be a 
destination.  For example, the second example (\textit{mp\_add}) adds $a$ to $b$ and stores in $a$.  This is an important 
feature to implement since it allows the calling functions to cut down on the number of variables it must maintain.  
However, to implement this feature specific care has to be given to ensure the destination is not modified before the 
source is fully read.

\section{Return Values}
A well implemented application, no matter what its purpose, should trap as many runtime errors as possible and return them 
to the caller.  By catching runtime errors a library can be guaranteed to prevent undefined behaviour.  However, the end 
developer can still manage to cause a library to crash.  For example, by passing an invalid pointer an application may
fault by dereferencing memory not owned by the application.

In the case of LibTomMath the only errors that are checked for are related to inappropriate inputs (division by zero for 
instance) and memory allocation errors.  It will not check that the mp\_int passed to any function is valid nor 
will it check pointers for validity.  Any function that can cause a runtime error will return an error code as an 
\textbf{int} data type with one of the following values (fig \ref{fig:errcodes}).

\index{MP\_OKAY} \index{MP\_VAL} \index{MP\_MEM}
\begin{figure}[here]
\begin{center}
\begin{tabular}{|l|l|}
\hline \textbf{Value} & \textbf{Meaning} \\
\hline \textbf{MP\_OKAY} & The function was successful \\
\hline \textbf{MP\_VAL}  & One of the input value(s) was invalid \\
\hline \textbf{MP\_MEM}  & The function ran out of heap memory \\
\hline
\end{tabular}
\end{center}
\caption{LibTomMath Error Codes}
\label{fig:errcodes}
\end{figure}

When an error is detected within a function it should free any memory it allocated, often during the initialization of
temporary mp\_ints, and return as soon as possible.  The goal is to leave the system in the same state it was when the 
function was called.  Error checking with this style of API is fairly simple.

\begin{verbatim}
   int err;
   if ((err = mp_add(&a, &b, &c)) != MP_OKAY) {
      printf("Error: %s\n", mp_error_to_string(err));
      exit(EXIT_FAILURE);
   }
\end{verbatim}

The GMP \cite{GMP} library uses C style \textit{signals} to flag errors which is of questionable use.  Not all errors are fatal 
and it was not deemed ideal by the author of LibTomMath to force developers to have signal handlers for such cases.

\section{Initialization and Clearing}
The logical starting point when actually writing multiple precision integer functions is the initialization and 
clearing of the mp\_int structures.  These two algorithms will be used by the majority of the higher level algorithms.

Given the basic mp\_int structure an initialization routine must first allocate memory to hold the digits of
the integer.  Often it is optimal to allocate a sufficiently large pre-set number of digits even though
the initial integer will represent zero.  If only a single digit were allocated quite a few subsequent re-allocations
would occur when operations are performed on the integers.  There is a tradeoff between how many default digits to allocate
and how many re-allocations are tolerable.  Obviously allocating an excessive amount of digits initially will waste 
memory and become unmanageable.  

If the memory for the digits has been successfully allocated then the rest of the members of the structure must
be initialized.  Since the initial state of an mp\_int is to represent the zero integer, the allocated digits must be set
to zero.  The \textbf{used} count set to zero and \textbf{sign} set to \textbf{MP\_ZPOS}.

\subsection{Initializing an mp\_int}
An mp\_int is said to be initialized if it is set to a valid, preferably default, state such that all of the members of the
structure are set to valid values.  The mp\_init algorithm will perform such an action.

\index{mp\_init}
\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_init}. \\
\textbf{Input}.   An mp\_int $a$ \\
\textbf{Output}.  Allocate memory and initialize $a$ to a known valid mp\_int state.  \\
\hline \\
1.  Allocate memory for \textbf{MP\_PREC} digits. \\
2.  If the allocation failed return(\textit{MP\_MEM}) \\
3.  for $n$ from $0$ to $MP\_PREC - 1$ do  \\
\hspace{3mm}3.1  $a_n \leftarrow 0$\\
4.  $a.sign \leftarrow MP\_ZPOS$\\
5.  $a.used \leftarrow 0$\\
6.  $a.alloc \leftarrow MP\_PREC$\\
7.  Return(\textit{MP\_OKAY})\\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_init}
\end{figure}

\textbf{Algorithm mp\_init.}
The purpose of this function is to initialize an mp\_int structure so that the rest of the library can properly
manipulte it.  It is assumed that the input may not have had any of its members previously initialized which is certainly
a valid assumption if the input resides on the stack.  

Before any of the members such as \textbf{sign}, \textbf{used} or \textbf{alloc} are initialized the memory for
the digits is allocated.  If this fails the function returns before setting any of the other members.  The \textbf{MP\_PREC} 
name represents a constant\footnote{Defined in the ``tommath.h'' header file within LibTomMath.} 
used to dictate the minimum precision of newly initialized mp\_int integers.  Ideally, it is at least equal to the smallest
precision number you'll be working with.

Allocating a block of digits at first instead of a single digit has the benefit of lowering the number of usually slow
heap operations later functions will have to perform in the future.  If \textbf{MP\_PREC} is set correctly the slack 
memory and the number of heap operations will be trivial.

Once the allocation has been made the digits have to be set to zero as well as the \textbf{used}, \textbf{sign} and
\textbf{alloc} members initialized.  This ensures that the mp\_int will always represent the default state of zero regardless
of the original condition of the input.

\textbf{Remark.}
This function introduces the idiosyncrasy that all iterative loops, commonly initiated with the ``for'' keyword, iterate incrementally
when the ``to'' keyword is placed between two expressions.  For example, ``for $a$ from $b$ to $c$ do'' means that
a subsequent expression (or body of expressions) are to be evaluated upto $c - b$ times so long as $b \le c$.  In each
iteration the variable $a$ is substituted for a new integer that lies inclusively between $b$ and $c$.  If $b > c$ occured
the loop would not iterate.  By contrast if the ``downto'' keyword were used in place of ``to'' the loop would iterate 
decrementally.

EXAM,bn_mp_init.c

One immediate observation of this initializtion function is that it does not return a pointer to a mp\_int structure.  It 
is assumed that the caller has already allocated memory for the mp\_int structure, typically on the application stack.  The 
call to mp\_init() is used only to initialize the members of the structure to a known default state.  

Here we see (line @23,XMALLOC@) the memory allocation is performed first.  This allows us to exit cleanly and quickly
if there is an error.  If the allocation fails the routine will return \textbf{MP\_MEM} to the caller to indicate there
was a memory error.  The function XMALLOC is what actually allocates the memory.  Technically XMALLOC is not a function
but a macro defined in ``tommath.h``.  By default, XMALLOC will evaluate to malloc() which is the C library's built--in
memory allocation routine.

In order to assure the mp\_int is in a known state the digits must be set to zero.  On most platforms this could have been
accomplished by using calloc() instead of malloc().  However,  to correctly initialize a integer type to a given value in a 
portable fashion you have to actually assign the value.  The for loop (line @28,for@) performs this required
operation.

After the memory has been successfully initialized the remainder of the members are initialized 
(lines @29,used@ through @31,sign@) to their respective default states.  At this point the algorithm has succeeded and
a success code is returned to the calling function.  If this function returns \textbf{MP\_OKAY} it is safe to assume the 
mp\_int structure has been properly initialized and is safe to use with other functions within the library.  

\subsection{Clearing an mp\_int}
When an mp\_int is no longer required by the application, the memory that has been allocated for its digits must be 
returned to the application's memory pool with the mp\_clear algorithm.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_clear}. \\
\textbf{Input}.   An mp\_int $a$ \\
\textbf{Output}.  The memory for $a$ shall be deallocated.  \\
\hline \\
1.  If $a$ has been previously freed then return(\textit{MP\_OKAY}). \\
2.  for $n$ from 0 to $a.used - 1$ do \\
\hspace{3mm}2.1  $a_n \leftarrow 0$ \\
3.  Free the memory allocated for the digits of $a$. \\
4.  $a.used \leftarrow 0$ \\
5.  $a.alloc \leftarrow 0$ \\
6.  $a.sign \leftarrow MP\_ZPOS$ \\
7.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_clear}
\end{figure}

\textbf{Algorithm mp\_clear.}
This algorithm accomplishes two goals.  First, it clears the digits and the other mp\_int members.  This ensures that 
if a developer accidentally re-uses a cleared structure it is less likely to cause problems.  The second goal
is to free the allocated memory.

The logic behind the algorithm is extended by marking cleared mp\_int structures so that subsequent calls to this
algorithm will not try to free the memory multiple times.  Cleared mp\_ints are detectable by having a pre-defined invalid 
digit pointer \textbf{dp} setting.

Once an mp\_int has been cleared the mp\_int structure is no longer in a valid state for any other algorithm
with the exception of algorithms mp\_init, mp\_init\_copy, mp\_init\_size and mp\_clear.

EXAM,bn_mp_clear.c

The algorithm only operates on the mp\_int if it hasn't been previously cleared.  The if statement (line @23,a->dp != NULL@)
checks to see if the \textbf{dp} member is not \textbf{NULL}.  If the mp\_int is a valid mp\_int then \textbf{dp} cannot be
\textbf{NULL} in which case the if statement will evaluate to true.

The digits of the mp\_int are cleared by the for loop (line @25,for@) which assigns a zero to every digit.  Similar to mp\_init()
the digits are assigned zero instead of using block memory operations (such as memset()) since this is more portable.  

The digits are deallocated off the heap via the XFREE macro.  Similar to XMALLOC the XFREE macro actually evaluates to
a standard C library function.  In this case the free() function.  Since free() only deallocates the memory the pointer
still has to be reset to \textbf{NULL} manually (line @33,NULL@).  

Now that the digits have been cleared and deallocated the other members are set to their final values (lines @34,= 0@ and @35,ZPOS@).

\section{Maintenance Algorithms}

The previous sections describes how to initialize and clear an mp\_int structure.  To further support operations
that are to be performed on mp\_int structures (such as addition and multiplication) the dependent algorithms must be
able to augment the precision of an mp\_int and 
initialize mp\_ints with differing initial conditions.  

These algorithms complete the set of low level algorithms required to work with mp\_int structures in the higher level
algorithms such as addition, multiplication and modular exponentiation.

\subsection{Augmenting an mp\_int's Precision}
When storing a value in an mp\_int structure, a sufficient number of digits must be available to accomodate the entire 
result of an operation without loss of precision.  Quite often the size of the array given by the \textbf{alloc} member 
is large enough to simply increase the \textbf{used} digit count.  However, when the size of the array is too small it 
must be re-sized appropriately to accomodate the result.  The mp\_grow algorithm will provide this functionality.

\newpage\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_grow}. \\
\textbf{Input}.   An mp\_int $a$ and an integer $b$. \\
\textbf{Output}.  $a$ is expanded to accomodate $b$ digits. \\
\hline \\
1.  if $a.alloc \ge b$ then return(\textit{MP\_OKAY}) \\
2.  $u \leftarrow b\mbox{ (mod }MP\_PREC\mbox{)}$ \\
3.  $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\
4.  Re-allocate the array of digits $a$ to size $v$ \\
5.  If the allocation failed then return(\textit{MP\_MEM}). \\
6.  for n from a.alloc to $v - 1$ do  \\
\hspace{+3mm}6.1  $a_n \leftarrow 0$ \\
7.  $a.alloc \leftarrow v$ \\
8.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_grow}
\end{figure}

\textbf{Algorithm mp\_grow.}
It is ideal to prevent re-allocations from being performed if they are not required (step one).  This is useful to 
prevent mp\_ints from growing excessively in code that erroneously calls mp\_grow.  

The requested digit count is padded up to next multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} (steps two and three).  
This helps prevent many trivial reallocations that would grow an mp\_int by trivially small values.  

It is assumed that the reallocation (step four) leaves the lower $a.alloc$ digits of the mp\_int intact.  This is much 
akin to how the \textit{realloc} function from the standard C library works.  Since the newly allocated digits are 
assumed to contain undefined values they are initially set to zero.

EXAM,bn_mp_grow.c

A quick optimization is to first determine if a memory re-allocation is required at all.  The if statement (line @24,alloc@) checks
if the \textbf{alloc} member of the mp\_int is smaller than the requested digit count.  If the count is not larger than \textbf{alloc}
the function skips the re-allocation part thus saving time.

When a re-allocation is performed it is turned into an optimal request to save time in the future.  The requested digit count is
padded upwards to 2nd multiple of \textbf{MP\_PREC} larger than \textbf{alloc} (line @25, size@).  The XREALLOC function is used
to re-allocate the memory.  As per the other functions XREALLOC is actually a macro which evaluates to realloc by default.  The realloc
function leaves the base of the allocation intact which means the first \textbf{alloc} digits of the mp\_int are the same as before
the re-allocation.  All	that is left is to clear the newly allocated digits and return.

Note that the re-allocation result is actually stored in a temporary pointer $tmp$.  This is to allow this function to return
an error with a valid pointer.  Earlier releases of the library stored the result of XREALLOC into the mp\_int $a$.  That would
result in a memory leak if XREALLOC ever failed.  

\subsection{Initializing Variable Precision mp\_ints}
Occasionally the number of digits required will be known in advance of an initialization, based on, for example, the size 
of input mp\_ints to a given algorithm.  The purpose of algorithm mp\_init\_size is similar to mp\_init except that it 
will allocate \textit{at least} a specified number of digits.  

\begin{figure}[here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_init\_size}. \\
\textbf{Input}.   An mp\_int $a$ and the requested number of digits $b$. \\
\textbf{Output}.  $a$ is initialized to hold at least $b$ digits. \\
\hline \\
1.  $u \leftarrow b \mbox{ (mod }MP\_PREC\mbox{)}$ \\
2.  $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\
3.  Allocate $v$ digits. \\
4.  for $n$ from $0$ to $v - 1$ do \\
\hspace{3mm}4.1  $a_n \leftarrow 0$ \\
5.  $a.sign \leftarrow MP\_ZPOS$\\
6.  $a.used \leftarrow 0$\\
7.  $a.alloc \leftarrow v$\\
8.  Return(\textit{MP\_OKAY})\\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_init\_size}
\end{figure}

\textbf{Algorithm mp\_init\_size.}
This algorithm will initialize an mp\_int structure $a$ like algorithm mp\_init with the exception that the number of 
digits allocated can be controlled by the second input argument $b$.  The input size is padded upwards so it is a 
multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} digits.  This padding is used to prevent trivial 
allocations from becoming a bottleneck in the rest of the algorithms.

Like algorithm mp\_init, the mp\_int structure is initialized to a default state representing the integer zero.  This 
particular algorithm is useful if it is known ahead of time the approximate size of the input.  If the approximation is
correct no further memory re-allocations are required to work with the mp\_int.

EXAM,bn_mp_init_size.c

The number of digits $b$ requested is padded (line @22,MP_PREC@) by first augmenting it to the next multiple of 
\textbf{MP\_PREC} and then adding \textbf{MP\_PREC} to the result.  If the memory can be successfully allocated the 
mp\_int is placed in a default state representing the integer zero.  Otherwise, the error code \textbf{MP\_MEM} will be 
returned (line @27,return@).  

The digits are allocated and set to zero at the same time with the calloc() function (line @25,XCALLOC@).  The 
\textbf{used} count is set to zero, the \textbf{alloc} count set to the padded digit count and the \textbf{sign} flag set 
to \textbf{MP\_ZPOS} to achieve a default valid mp\_int state (lines @29,used@, @30,alloc@ and @31,sign@).  If the function 
returns succesfully then it is correct to assume that the mp\_int structure is in a valid state for the remainder of the 
functions to work with.

\subsection{Multiple Integer Initializations and Clearings}
Occasionally a function will require a series of mp\_int data types to be made available simultaneously.  
The purpose of algorithm mp\_init\_multi is to initialize a variable length array of mp\_int structures in a single
statement.  It is essentially a shortcut to multiple initializations.

\newpage\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_init\_multi}. \\
\textbf{Input}.   Variable length array $V_k$ of mp\_int variables of length $k$. \\
\textbf{Output}.  The array is initialized such that each mp\_int of $V_k$ is ready to use. \\
\hline \\
1.  for $n$ from 0 to $k - 1$ do \\
\hspace{+3mm}1.1.  Initialize the mp\_int $V_n$ (\textit{mp\_init}) \\
\hspace{+3mm}1.2.  If initialization failed then do \\
\hspace{+6mm}1.2.1.  for $j$ from $0$ to $n$ do \\
\hspace{+9mm}1.2.1.1.  Free the mp\_int $V_j$ (\textit{mp\_clear}) \\
\hspace{+6mm}1.2.2.   Return(\textit{MP\_MEM}) \\
2.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_init\_multi}
\end{figure}

\textbf{Algorithm mp\_init\_multi.}
The algorithm will initialize the array of mp\_int variables one at a time.  If a runtime error has been detected 
(\textit{step 1.2}) all of the previously initialized variables are cleared.  The goal is an ``all or nothing'' 
initialization which allows for quick recovery from runtime errors.

EXAM,bn_mp_init_multi.c

This function intializes a variable length list of mp\_int structure pointers.  However, instead of having the mp\_int
structures in an actual C array they are simply passed as arguments to the function.  This function makes use of the 
``...'' argument syntax of the C programming language.  The list is terminated with a final \textbf{NULL} argument 
appended on the right.  

The function uses the ``stdarg.h'' \textit{va} functions to step portably through the arguments to the function.  A count
$n$ of succesfully initialized mp\_int structures is maintained (line @47,n++@) such that if a failure does occur,
the algorithm can backtrack and free the previously initialized structures (lines @27,if@ to @46,}@).  


\subsection{Clamping Excess Digits}
When a function anticipates a result will be $n$ digits it is simpler to assume this is true within the body of 
the function instead of checking during the computation.  For example, a multiplication of a $i$ digit number by a 
$j$ digit produces a result of at most $i + j$ digits.  It is entirely possible that the result is $i + j - 1$ 
though, with no final carry into the last position.  However, suppose the destination had to be first expanded 
(\textit{via mp\_grow}) to accomodate $i + j - 1$ digits than further expanded to accomodate the final carry.  
That would be a considerable waste of time since heap operations are relatively slow.

The ideal solution is to always assume the result is $i + j$ and fix up the \textbf{used} count after the function
terminates.  This way a single heap operation (\textit{at most}) is required.  However, if the result was not checked
there would be an excess high order zero digit.  

For example, suppose the product of two integers was $x_n = (0x_{n-1}x_{n-2}...x_0)_{\beta}$.  The leading zero digit 
will not contribute to the precision of the result.  In fact, through subsequent operations more leading zero digits would
accumulate to the point the size of the integer would be prohibitive.  As a result even though the precision is very 
low the representation is excessively large.  

The mp\_clamp algorithm is designed to solve this very problem.  It will trim high-order zeros by decrementing the 
\textbf{used} count until a non-zero most significant digit is found.  Also in this system, zero is considered to be a 
positive number which means that if the \textbf{used} count is decremented to zero, the sign must be set to 
\textbf{MP\_ZPOS}.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_clamp}. \\
\textbf{Input}.   An mp\_int $a$ \\
\textbf{Output}.  Any excess leading zero digits of $a$ are removed \\
\hline \\
1.  while $a.used > 0$ and $a_{a.used - 1} = 0$ do \\
\hspace{+3mm}1.1  $a.used \leftarrow a.used - 1$ \\
2.  if $a.used = 0$ then do \\
\hspace{+3mm}2.1  $a.sign \leftarrow MP\_ZPOS$ \\
\hline \\
\end{tabular}
\end{center}
\caption{Algorithm mp\_clamp}
\end{figure}

\textbf{Algorithm mp\_clamp.}
As can be expected this algorithm is very simple.  The loop on step one is expected to iterate only once or twice at
the most.  For example, this will happen in cases where there is not a carry to fill the last position.  Step two fixes the sign for 
when all of the digits are zero to ensure that the mp\_int is valid at all times.

EXAM,bn_mp_clamp.c

Note on line @27,while@ how to test for the \textbf{used} count is made on the left of the \&\& operator.  In the C programming
language the terms to \&\& are evaluated left to right with a boolean short-circuit if any condition fails.  This is 
important since if the \textbf{used} is zero the test on the right would fetch below the array.  That is obviously 
undesirable.  The parenthesis on line @28,a->used@ is used to make sure the \textbf{used} count is decremented and not
the pointer ``a''.  

\section*{Exercises}
\begin{tabular}{cl}
$\left [ 1 \right ]$ & Discuss the relevance of the \textbf{used} member of the mp\_int structure. \\
                     & \\
$\left [ 1 \right ]$ & Discuss the consequences of not using padding when performing allocations.  \\
                     & \\
$\left [ 2 \right ]$ & Estimate an ideal value for \textbf{MP\_PREC} when performing 1024-bit RSA \\
                     & encryption when $\beta = 2^{28}$.  \\
                     & \\
$\left [ 1 \right ]$ & Discuss the relevance of the algorithm mp\_clamp.  What does it prevent? \\
                     & \\
$\left [ 1 \right ]$ & Give an example of when the algorithm  mp\_init\_copy might be useful. \\
                     & \\
\end{tabular}


%%%
% CHAPTER FOUR
%%%

\chapter{Basic Operations}

\section{Introduction}
In the previous chapter a series of low level algorithms were established that dealt with initializing and maintaining
mp\_int structures.  This chapter will discuss another set of seemingly non-algebraic algorithms which will form the low 
level basis of the entire library.  While these algorithm are relatively trivial it is important to understand how they
work before proceeding since these algorithms will be used almost intrinsically in the following chapters.

The algorithms in this chapter deal primarily with more ``programmer'' related tasks such as creating copies of
mp\_int structures, assigning small values to mp\_int structures and comparisons of the values mp\_int structures
represent.   

\section{Assigning Values to mp\_int Structures}
\subsection{Copying an mp\_int}
Assigning the value that a given mp\_int structure represents to another mp\_int structure shall be known as making
a copy for the purposes of this text.  The copy of the mp\_int will be a separate entity that represents the same
value as the mp\_int it was copied from.  The mp\_copy algorithm provides this functionality. 

\newpage\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_copy}. \\
\textbf{Input}.  An mp\_int $a$ and $b$. \\
\textbf{Output}.  Store a copy of $a$ in $b$. \\
\hline \\
1.  If $b.alloc < a.used$ then grow $b$ to $a.used$ digits.  (\textit{mp\_grow}) \\
2.  for $n$ from 0 to $a.used - 1$ do \\
\hspace{3mm}2.1  $b_{n} \leftarrow a_{n}$ \\
3.  for $n$ from $a.used$ to $b.used - 1$ do \\
\hspace{3mm}3.1  $b_{n} \leftarrow 0$ \\
4.  $b.used \leftarrow a.used$ \\
5.  $b.sign \leftarrow a.sign$ \\
6.  return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_copy}
\end{figure}

\textbf{Algorithm mp\_copy.}
This algorithm copies the mp\_int $a$ such that upon succesful termination of the algorithm the mp\_int $b$ will
represent the same integer as the mp\_int $a$.  The mp\_int $b$ shall be a complete and distinct copy of the 
mp\_int $a$ meaing that the mp\_int $a$ can be modified and it shall not affect the value of the mp\_int $b$.

If $b$ does not have enough room for the digits of $a$ it must first have its precision augmented via the mp\_grow 
algorithm.  The digits of $a$ are copied over the digits of $b$ and any excess digits of $b$ are set to zero (step two
and three).  The \textbf{used} and \textbf{sign} members of $a$ are finally copied over the respective members of
$b$.

\textbf{Remark.}  This algorithm also introduces a new idiosyncrasy that will be used throughout the rest of the
text.  The error return codes of other algorithms are not explicitly checked in the pseudo-code presented.  For example, in 
step one of the mp\_copy algorithm the return of mp\_grow is not explicitly checked to ensure it succeeded.  Text space is 
limited so it is assumed that if a algorithm fails it will clear all temporarily allocated mp\_ints and return
the error code itself.  However, the C code presented will demonstrate all of the error handling logic required to 
implement the pseudo-code.

EXAM,bn_mp_copy.c

Occasionally a dependent algorithm may copy an mp\_int effectively into itself such as when the input and output
mp\_int structures passed to a function are one and the same.  For this case it is optimal to return immediately without 
copying digits (line @24,a == b@).  

The mp\_int $b$ must have enough digits to accomodate the used digits of the mp\_int $a$.  If $b.alloc$ is less than
$a.used$ the algorithm mp\_grow is used to augment the precision of $b$ (lines @29,alloc@ to @33,}@).  In order to
simplify the inner loop that copies the digits from $a$ to $b$, two aliases $tmpa$ and $tmpb$ point directly at the digits
of the mp\_ints $a$ and $b$ respectively.  These aliases (lines @42,tmpa@ and @45,tmpb@) allow the compiler to access the digits without first dereferencing the
mp\_int pointers and then subsequently the pointer to the digits.  

After the aliases are established the digits from $a$ are copied into $b$ (lines @48,for@ to @50,}@) and then the excess 
digits of $b$ are set to zero (lines @53,for@ to @55,}@).  Both ``for'' loops make use of the pointer aliases and in 
fact the alias for $b$ is carried through into the second ``for'' loop to clear the excess digits.  This optimization 
allows the alias to stay in a machine register fairly easy between the two loops.

\textbf{Remarks.}  The use of pointer aliases is an implementation methodology first introduced in this function that will
be used considerably in other functions.  Technically, a pointer alias is simply a short hand alias used to lower the 
number of pointer dereferencing operations required to access data.  For example, a for loop may resemble

\begin{alltt}
for (x = 0; x < 100; x++) \{
    a->num[4]->dp[x] = 0;
\}
\end{alltt}

This could be re-written using aliases as 

\begin{alltt}
mp_digit *tmpa;
a = a->num[4]->dp;
for (x = 0; x < 100; x++) \{
    *a++ = 0;
\}
\end{alltt}

In this case an alias is used to access the 
array of digits within an mp\_int structure directly.  It may seem that a pointer alias is strictly not required 
as a compiler may optimize out the redundant pointer operations.  However, there are two dominant reasons to use aliases.

The first reason is that most compilers will not effectively optimize pointer arithmetic.  For example, some optimizations 
may work for the Microsoft Visual C++ compiler (MSVC) and not for the GNU C Compiler (GCC).  Also some optimizations may 
work for GCC and not MSVC.  As such it is ideal to find a common ground for as many compilers as possible.  Pointer 
aliases optimize the code considerably before the compiler even reads the source code which means the end compiled code 
stands a better chance of being faster.

The second reason is that pointer aliases often can make an algorithm simpler to read.  Consider the first ``for'' 
loop of the function mp\_copy() re-written to not use pointer aliases.

\begin{alltt}
    /* copy all the digits */
    for (n = 0; n < a->used; n++) \{
      b->dp[n] = a->dp[n];
    \}
\end{alltt}

Whether this code is harder to read depends strongly on the individual.  However, it is quantifiably slightly more 
complicated as there are four variables within the statement instead of just two.

\subsubsection{Nested Statements}
Another commonly used technique in the source routines is that certain sections of code are nested.  This is used in
particular with the pointer aliases to highlight code phases.  For example, a Comba multiplier (discussed in chapter six)
will typically have three different phases.  First the temporaries are initialized, then the columns calculated and 
finally the carries are propagated.  In this example the middle column production phase will typically be nested as it
uses temporary variables and aliases the most.

The nesting also simplies the source code as variables that are nested are only valid for their scope.  As a result
the various temporary variables required do not propagate into other sections of code.


\subsection{Creating a Clone}
Another common operation is to make a local temporary copy of an mp\_int argument.  To initialize an mp\_int 
and then copy another existing mp\_int into the newly intialized mp\_int will be known as creating a clone.  This is 
useful within functions that need to modify an argument but do not wish to actually modify the original copy.  The 
mp\_init\_copy algorithm has been designed to help perform this task.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_init\_copy}. \\
\textbf{Input}.   An mp\_int $a$ and $b$\\
\textbf{Output}.  $a$ is initialized to be a copy of $b$. \\
\hline \\
1.  Init $a$.  (\textit{mp\_init}) \\
2.  Copy $b$ to $a$.  (\textit{mp\_copy}) \\
3.  Return the status of the copy operation. \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_init\_copy}
\end{figure}

\textbf{Algorithm mp\_init\_copy.}
This algorithm will initialize an mp\_int variable and copy another previously initialized mp\_int variable into it.  As 
such this algorithm will perform two operations in one step.  

EXAM,bn_mp_init_copy.c

This will initialize \textbf{a} and make it a verbatim copy of the contents of \textbf{b}.  Note that 
\textbf{a} will have its own memory allocated which means that \textbf{b} may be cleared after the call
and \textbf{a} will be left intact.  

\section{Zeroing an Integer}
Reseting an mp\_int to the default state is a common step in many algorithms.  The mp\_zero algorithm will be the algorithm used to
perform this task.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_zero}. \\
\textbf{Input}.   An mp\_int $a$ \\
\textbf{Output}.  Zero the contents of $a$ \\
\hline \\
1.  $a.used \leftarrow 0$ \\
2.  $a.sign \leftarrow$ MP\_ZPOS \\
3.  for $n$ from 0 to $a.alloc - 1$ do \\
\hspace{3mm}3.1  $a_n \leftarrow 0$ \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_zero}
\end{figure}

\textbf{Algorithm mp\_zero.}
This algorithm simply resets a mp\_int to the default state.  

EXAM,bn_mp_zero.c

After the function is completed, all of the digits are zeroed, the \textbf{used} count is zeroed and the 
\textbf{sign} variable is set to \textbf{MP\_ZPOS}.

\section{Sign Manipulation}
\subsection{Absolute Value}
With the mp\_int representation of an integer, calculating the absolute value is trivial.  The mp\_abs algorithm will compute
the absolute value of an mp\_int.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_abs}. \\
\textbf{Input}.   An mp\_int $a$ \\
\textbf{Output}.  Computes $b = \vert a \vert$ \\
\hline \\
1.  Copy $a$ to $b$.  (\textit{mp\_copy}) \\
2.  If the copy failed return(\textit{MP\_MEM}). \\
3.  $b.sign \leftarrow MP\_ZPOS$ \\
4.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_abs}
\end{figure}

\textbf{Algorithm mp\_abs.}
This algorithm computes the absolute of an mp\_int input.  First it copies $a$ over $b$.  This is an example of an
algorithm where the check in mp\_copy that determines if the source and destination are equal proves useful.  This allows,
for instance, the developer to pass the same mp\_int as the source and destination to this function without addition 
logic to handle it.

EXAM,bn_mp_abs.c

This fairly trivial algorithm first eliminates non--required duplications (line @27,a != b@) and then sets the
\textbf{sign} flag to \textbf{MP\_ZPOS}.

\subsection{Integer Negation}
With the mp\_int representation of an integer, calculating the negation is also trivial.  The mp\_neg algorithm will compute
the negative of an mp\_int input.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_neg}. \\
\textbf{Input}.   An mp\_int $a$ \\
\textbf{Output}.  Computes $b = -a$ \\
\hline \\
1.  Copy $a$ to $b$.  (\textit{mp\_copy}) \\
2.  If the copy failed return(\textit{MP\_MEM}). \\
3.  If $a.used = 0$ then return(\textit{MP\_OKAY}). \\
4.  If $a.sign = MP\_ZPOS$ then do \\
\hspace{3mm}4.1  $b.sign = MP\_NEG$. \\
5.  else do \\
\hspace{3mm}5.1  $b.sign = MP\_ZPOS$. \\
6.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_neg}
\end{figure}

\textbf{Algorithm mp\_neg.}
This algorithm computes the negation of an input.  First it copies $a$ over $b$.  If $a$ has no used digits then
the algorithm returns immediately.  Otherwise it flips the sign flag and stores the result in $b$.  Note that if 
$a$ had no digits then it must be positive by definition.  Had step three been omitted then the algorithm would return
zero as negative.

EXAM,bn_mp_neg.c

Like mp\_abs() this function avoids non--required duplications (line @21,a != b@) and then sets the sign.  We
have to make sure that only non--zero values get a \textbf{sign} of \textbf{MP\_NEG}.  If the mp\_int is zero
than the \textbf{sign} is hard--coded to \textbf{MP\_ZPOS}.

\section{Small Constants}
\subsection{Setting Small Constants}
Often a mp\_int must be set to a relatively small value such as $1$ or $2$.  For these cases the mp\_set algorithm is useful.

\newpage\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_set}. \\
\textbf{Input}.   An mp\_int $a$ and a digit $b$ \\
\textbf{Output}.  Make $a$ equivalent to $b$ \\
\hline \\
1.  Zero $a$ (\textit{mp\_zero}). \\
2.  $a_0 \leftarrow b \mbox{ (mod }\beta\mbox{)}$ \\
3.  $a.used \leftarrow  \left \lbrace \begin{array}{ll}
                              1 &  \mbox{if }a_0 > 0 \\
                              0 &  \mbox{if }a_0 = 0 
                              \end{array} \right .$ \\
\hline                              
\end{tabular}
\end{center}
\caption{Algorithm mp\_set}
\end{figure}

\textbf{Algorithm mp\_set.}
This algorithm sets a mp\_int to a small single digit value.  Step number 1 ensures that the integer is reset to the default state.  The
single digit is set (\textit{modulo $\beta$}) and the \textbf{used} count is adjusted accordingly.

EXAM,bn_mp_set.c

First we zero (line @21,mp_zero@) the mp\_int to make sure that the other members are initialized for a 
small positive constant.  mp\_zero() ensures that the \textbf{sign} is positive and the \textbf{used} count
is zero.  Next we set the digit and reduce it modulo $\beta$ (line @22,MP_MASK@).  After this step we have to 
check if the resulting digit is zero or not.  If it is not then we set the \textbf{used} count to one, otherwise
to zero.

We can quickly reduce modulo $\beta$ since it is of the form $2^k$ and a quick binary AND operation with 
$2^k - 1$ will perform the same operation.

One important limitation of this function is that it will only set one digit.  The size of a digit is not fixed, meaning source that uses 
this function should take that into account.  Only trivially small constants can be set using this function.

\subsection{Setting Large Constants}
To overcome the limitations of the mp\_set algorithm the mp\_set\_int algorithm is ideal.  It accepts a ``long''
data type as input and will always treat it as a 32-bit integer.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_set\_int}. \\
\textbf{Input}.   An mp\_int $a$ and a ``long'' integer $b$ \\
\textbf{Output}.  Make $a$ equivalent to $b$ \\
\hline \\
1.  Zero $a$ (\textit{mp\_zero}) \\
2.  for $n$ from 0 to 7 do \\
\hspace{3mm}2.1  $a \leftarrow a \cdot 16$ (\textit{mp\_mul2d}) \\
\hspace{3mm}2.2  $u \leftarrow \lfloor b / 2^{4(7 - n)} \rfloor \mbox{ (mod }16\mbox{)}$\\
\hspace{3mm}2.3  $a_0 \leftarrow a_0 + u$ \\
\hspace{3mm}2.4  $a.used \leftarrow a.used + 1$ \\
3.  Clamp excess used digits (\textit{mp\_clamp}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_set\_int}
\end{figure}

\textbf{Algorithm mp\_set\_int.}
The algorithm performs eight iterations of a simple loop where in each iteration four bits from the source are added to the 
mp\_int.  Step 2.1 will multiply the current result by sixteen making room for four more bits in the less significant positions.  In step 2.2 the
next four bits from the source are extracted and are added to the mp\_int. The \textbf{used} digit count is 
incremented to reflect the addition.  The \textbf{used} digit counter is incremented since if any of the leading digits were zero the mp\_int would have
zero digits used and the newly added four bits would be ignored.

Excess zero digits are trimmed in steps 2.1 and 3 by using higher level algorithms mp\_mul2d and mp\_clamp.

EXAM,bn_mp_set_int.c

This function sets four bits of the number at a time to handle all practical \textbf{DIGIT\_BIT} sizes.  The weird
addition on line @38,a->used@ ensures that the newly added in bits are added to the number of digits.  While it may not 
seem obvious as to why the digit counter does not grow exceedingly large it is because of the shift on line @27,mp_mul_2d@ 
as well as the  call to mp\_clamp() on line @40,mp_clamp@.  Both functions will clamp excess leading digits which keeps 
the number of used digits low.

\section{Comparisons}
\subsection{Unsigned Comparisions}
Comparing a multiple precision integer is performed with the exact same algorithm used to compare two decimal numbers.  For example,
to compare $1,234$ to $1,264$ the digits are extracted by their positions.  That is we compare $1 \cdot 10^3 + 2 \cdot 10^2 + 3 \cdot 10^1 + 4 \cdot 10^0$
to $1 \cdot 10^3 + 2 \cdot 10^2 + 6 \cdot 10^1 + 4 \cdot 10^0$ by comparing single digits at a time starting with the highest magnitude 
positions.  If any leading digit of one integer is greater than a digit in the same position of another integer then obviously it must be greater.  

The first comparision routine that will be developed is the unsigned magnitude compare which will perform a comparison based on the digits of two
mp\_int variables alone.  It will ignore the sign of the two inputs.  Such a function is useful when an absolute comparison is required or if the 
signs are known to agree in advance.

To facilitate working with the results of the comparison functions three constants are required.  

\begin{figure}[here]
\begin{center}
\begin{tabular}{|r|l|}
\hline \textbf{Constant} & \textbf{Meaning} \\
\hline \textbf{MP\_GT} & Greater Than \\
\hline \textbf{MP\_EQ} & Equal To \\
\hline \textbf{MP\_LT} & Less Than \\
\hline
\end{tabular}
\end{center}
\caption{Comparison Return Codes}
\end{figure}

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_cmp\_mag}. \\
\textbf{Input}.   Two mp\_ints $a$ and $b$.  \\
\textbf{Output}.  Unsigned comparison results ($a$ to the left of $b$). \\
\hline \\
1.  If $a.used > b.used$ then return(\textit{MP\_GT}) \\
2.  If $a.used < b.used$ then return(\textit{MP\_LT}) \\
3.  for n from $a.used - 1$ to 0 do \\
\hspace{+3mm}3.1  if $a_n > b_n$ then return(\textit{MP\_GT}) \\
\hspace{+3mm}3.2  if $a_n < b_n$ then return(\textit{MP\_LT}) \\
4.  Return(\textit{MP\_EQ}) \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_cmp\_mag}
\end{figure}

\textbf{Algorithm mp\_cmp\_mag.}
By saying ``$a$ to the left of $b$'' it is meant that the comparison is with respect to $a$, that is if $a$ is greater than $b$ it will return
\textbf{MP\_GT} and similar with respect to when $a = b$ and $a < b$.  The first two steps compare the number of digits used in both $a$ and $b$.  
Obviously if the digit counts differ there would be an imaginary zero digit in the smaller number where the leading digit of the larger number is.  
If both have the same number of digits than the actual digits themselves must be compared starting at the leading digit.  

By step three both inputs must have the same number of digits so its safe to start from either $a.used - 1$ or $b.used - 1$ and count down to
the zero'th digit.  If after all of the digits have been compared, no difference is found, the algorithm returns \textbf{MP\_EQ}.

EXAM,bn_mp_cmp_mag.c

The two if statements (lines @24,if@ and @28,if@) compare the number of digits in the two inputs.  These two are 
performed before all of the digits are compared since it is a very cheap test to perform and can potentially save 
considerable time.  The implementation given is also not valid without those two statements.  $b.alloc$ may be 
smaller than $a.used$, meaning that undefined values will be read from $b$ past the end of the array of digits.



\subsection{Signed Comparisons}
Comparing with sign considerations is also fairly critical in several routines (\textit{division for example}).  Based on an unsigned magnitude 
comparison a trivial signed comparison algorithm can be written.

\begin{figure}[here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_cmp}. \\
\textbf{Input}.   Two mp\_ints $a$ and $b$ \\
\textbf{Output}.  Signed Comparison Results ($a$ to the left of $b$) \\
\hline \\
1.  if $a.sign = MP\_NEG$ and $b.sign = MP\_ZPOS$ then return(\textit{MP\_LT}) \\
2.  if $a.sign = MP\_ZPOS$ and $b.sign = MP\_NEG$ then return(\textit{MP\_GT}) \\
3.  if $a.sign = MP\_NEG$ then \\
\hspace{+3mm}3.1  Return the unsigned comparison of $b$ and $a$ (\textit{mp\_cmp\_mag}) \\
4   Otherwise \\
\hspace{+3mm}4.1  Return the unsigned comparison of $a$ and $b$ \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_cmp}
\end{figure}

\textbf{Algorithm mp\_cmp.}
The first two steps compare the signs of the two inputs.  If the signs do not agree then it can return right away with the appropriate 
comparison code.  When the signs are equal the digits of the inputs must be compared to determine the correct result.  In step 
three the unsigned comparision flips the order of the arguments since they are both negative.  For instance, if $-a > -b$ then 
$\vert a \vert < \vert b \vert$.  Step number four will compare the two when they are both positive.

EXAM,bn_mp_cmp.c

The two if statements (lines @22,if@ and @26,if@) perform the initial sign comparison.  If the signs are not the equal then which ever
has the positive sign is larger.   The inputs are compared (line @30,if@) based on magnitudes.  If the signs were both 
negative then the unsigned comparison is performed in the opposite direction (line @31,mp_cmp_mag@).  Otherwise, the signs are assumed to 
be both positive and a forward direction unsigned comparison is performed.

\section*{Exercises}
\begin{tabular}{cl}
$\left [ 2 \right ]$ & Modify algorithm mp\_set\_int to accept as input a variable length array of bits. \\
                     & \\
$\left [ 3 \right ]$ & Give the probability that algorithm mp\_cmp\_mag will have to compare $k$ digits  \\
                     & of two random digits (of equal magnitude) before a difference is found. \\
                     & \\
$\left [ 1 \right ]$ & Suggest a simple method to speed up the implementation of mp\_cmp\_mag based  \\
                     & on the observations made in the previous problem. \\
                     &
\end{tabular}

\chapter{Basic Arithmetic}
\section{Introduction}
At this point algorithms for initialization, clearing, zeroing, copying, comparing and setting small constants have been 
established.  The next logical set of algorithms to develop are addition, subtraction and digit shifting algorithms.  These 
algorithms make use of the lower level algorithms and are the cruicial building block for the multiplication algorithms.  It is very important 
that these algorithms are highly optimized.  On their own they are simple $O(n)$ algorithms but they can be called from higher level algorithms 
which easily places them at $O(n^2)$ or even $O(n^3)$ work levels.  

MARK,SHIFTS
All of the algorithms within this chapter make use of the logical bit shift operations denoted by $<<$ and $>>$ for left and right 
logical shifts respectively.  A logical shift is analogous to sliding the decimal point of radix-10 representations.  For example, the real 
number $0.9345$ is equivalent to $93.45\%$ which is found by sliding the the decimal two places to the right (\textit{multiplying by $\beta^2 = 10^2$}).  
Algebraically a binary logical shift is equivalent to a division or multiplication by a power of two.  
For example, $a << k = a \cdot 2^k$ while $a >> k = \lfloor a/2^k \rfloor$.

One significant difference between a logical shift and the way decimals are shifted is that digits below the zero'th position are removed
from the number.  For example, consider $1101_2 >> 1$ using decimal notation this would produce $110.1_2$.  However, with a logical shift the 
result is $110_2$.  

\section{Addition and Subtraction}
In common twos complement fixed precision arithmetic negative numbers are easily represented by subtraction from the modulus.  For example, with 32-bit integers
$a - b\mbox{ (mod }2^{32}\mbox{)}$ is the same as $a + (2^{32} - b) \mbox{ (mod }2^{32}\mbox{)}$  since $2^{32} \equiv 0 \mbox{ (mod }2^{32}\mbox{)}$.  
As a result subtraction can be performed with a trivial series of logical operations and an addition.

However, in multiple precision arithmetic negative numbers are not represented in the same way.  Instead a sign flag is used to keep track of the
sign of the integer.  As a result signed addition and subtraction are actually implemented as conditional usage of lower level addition or 
subtraction algorithms with the sign fixed up appropriately.

The lower level algorithms will add or subtract integers without regard to the sign flag.  That is they will add or subtract the magnitude of
the integers respectively.

\subsection{Low Level Addition}
An unsigned addition of multiple precision integers is performed with the same long-hand algorithm used to add decimal numbers.  That is to add the 
trailing digits first and propagate the resulting carry upwards.  Since this is a lower level algorithm the name will have a ``s\_'' prefix.  
Historically that convention stems from the MPI library where ``s\_'' stood for static functions that were hidden from the developer entirely.

\newpage
\begin{figure}[!here]
\begin{center}
\begin{small}
\begin{tabular}{l}
\hline Algorithm \textbf{s\_mp\_add}. \\
\textbf{Input}.   Two mp\_ints $a$ and $b$ \\
\textbf{Output}.  The unsigned addition $c = \vert a \vert + \vert b \vert$. \\
\hline \\
1.  if $a.used > b.used$ then \\
\hspace{+3mm}1.1  $min \leftarrow b.used$ \\
\hspace{+3mm}1.2  $max \leftarrow a.used$ \\
\hspace{+3mm}1.3  $x   \leftarrow a$ \\
2.  else  \\
\hspace{+3mm}2.1  $min \leftarrow a.used$ \\
\hspace{+3mm}2.2  $max \leftarrow b.used$ \\
\hspace{+3mm}2.3  $x   \leftarrow b$ \\
3.  If $c.alloc < max + 1$ then grow $c$ to hold at least $max + 1$ digits (\textit{mp\_grow}) \\
4.  $oldused \leftarrow c.used$ \\
5.  $c.used \leftarrow max + 1$ \\
6.  $u \leftarrow 0$ \\
7.  for $n$ from $0$ to $min - 1$ do \\
\hspace{+3mm}7.1  $c_n \leftarrow a_n + b_n + u$ \\
\hspace{+3mm}7.2  $u \leftarrow c_n >> lg(\beta)$ \\
\hspace{+3mm}7.3  $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\
8.  if $min \ne max$ then do \\
\hspace{+3mm}8.1  for $n$ from $min$ to $max - 1$ do \\
\hspace{+6mm}8.1.1  $c_n \leftarrow x_n + u$ \\
\hspace{+6mm}8.1.2  $u \leftarrow c_n >> lg(\beta)$ \\
\hspace{+6mm}8.1.3  $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\
9.  $c_{max} \leftarrow u$ \\
10.  if $olduse > max$ then \\
\hspace{+3mm}10.1  for $n$ from $max + 1$ to $oldused - 1$ do \\
\hspace{+6mm}10.1.1  $c_n \leftarrow 0$ \\
11.  Clamp excess digits in $c$.  (\textit{mp\_clamp}) \\
12.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Algorithm s\_mp\_add}
\end{figure}

\textbf{Algorithm s\_mp\_add.}
This algorithm is loosely based on algorithm 14.7 of HAC \cite[pp. 594]{HAC} but has been extended to allow the inputs to have different magnitudes.  
Coincidentally the description of algorithm A in Knuth \cite[pp. 266]{TAOCPV2} shares the same deficiency as the algorithm from \cite{HAC}.  Even the 
MIX pseudo  machine code presented by Knuth \cite[pp. 266-267]{TAOCPV2} is incapable of handling inputs which are of different magnitudes.

The first thing that has to be accomplished is to sort out which of the two inputs is the largest.  The addition logic
will simply add all of the smallest input to the largest input and store that first part of the result in the
destination.  Then it will apply a simpler addition loop to excess digits of the larger input.

The first two steps will handle sorting the inputs such that $min$ and $max$ hold the digit counts of the two 
inputs.  The variable $x$ will be an mp\_int alias for the largest input or the second input $b$ if they have the
same number of digits.  After the inputs are sorted the destination $c$ is grown as required to accomodate the sum 
of the two inputs.  The original \textbf{used} count of $c$ is copied and set to the new used count.  

At this point the first addition loop will go through as many digit positions that both inputs have.  The carry
variable $\mu$ is set to zero outside the loop.  Inside the loop an ``addition'' step requires three statements to produce
one digit of the summand.  First
two digits from $a$ and $b$ are added together along with the carry $\mu$.  The carry of this step is extracted and stored
in $\mu$ and finally the digit of the result $c_n$ is truncated within the range $0 \le c_n < \beta$.

Now all of the digit positions that both inputs have in common have been exhausted.  If $min \ne max$ then $x$ is an alias
for one of the inputs that has more digits.  A simplified addition loop is then used to essentially copy the remaining digits
and the carry to the destination.

The final carry is stored in $c_{max}$ and digits above $max$ upto $oldused$ are zeroed which completes the addition.


EXAM,bn_s_mp_add.c

We first sort (lines @27,if@ to @35,}@) the inputs based on magnitude and determine the $min$ and $max$ variables.
Note that $x$ is a pointer to an mp\_int assigned to the largest input, in effect it is a local alias.  Next we
grow the destination (@37,init@ to @42,}@) ensure that it can accomodate the result of the addition. 

Similar to the implementation of mp\_copy this function uses the braced code and local aliases coding style.  The three aliases that are on 
lines @56,tmpa@, @59,tmpb@ and @62,tmpc@ represent the two inputs and destination variables respectively.  These aliases are used to ensure the
compiler does not have to dereference $a$, $b$ or $c$ (respectively) to access the digits of the respective mp\_int.

The initial carry $u$ will be cleared (line @65,u = 0@), note that $u$ is of type mp\_digit which ensures type 
compatibility within the implementation.  The initial addition (line @66,for@ to @75,}@) adds digits from
both inputs until the smallest input runs out of digits.  Similarly the conditional addition loop
(line @81,for@ to @90,}@) adds the remaining digits from the larger of the two inputs.  The addition is finished 
with the final carry being stored in $tmpc$ (line @94,tmpc++@).  Note the ``++'' operator within the same expression.
After line @94,tmpc++@, $tmpc$ will point to the $c.used$'th digit of the mp\_int $c$.  This is useful
for the next loop (line @97,for@ to @99,}@) which set any old upper digits to zero.

\subsection{Low Level Subtraction}
The low level unsigned subtraction algorithm is very similar to the low level unsigned addition algorithm.  The principle difference is that the
unsigned subtraction algorithm requires the result to be positive.  That is when computing $a - b$ the condition $\vert a \vert \ge \vert b\vert$ must 
be met for this algorithm to function properly.  Keep in mind this low level algorithm is not meant to be used in higher level algorithms directly.  
This algorithm as will be shown can be used to create functional signed addition and subtraction algorithms.

MARK,GAMMA

For this algorithm a new variable is required to make the description simpler.  Recall from section 1.3.1 that a mp\_digit must be able to represent
the range $0 \le x < 2\beta$ for the algorithms to work correctly.  However, it is allowable that a mp\_digit represent a larger range of values.  For 
this algorithm we will assume that the variable $\gamma$ represents the number of bits available in a 
mp\_digit (\textit{this implies $2^{\gamma} > \beta$}).  

For example, the default for LibTomMath is to use a ``unsigned long'' for the mp\_digit ``type'' while $\beta = 2^{28}$.  In ISO C an ``unsigned long''
data type must be able to represent $0 \le x < 2^{32}$ meaning that in this case $\gamma \ge 32$.

\newpage\begin{figure}[!here]
\begin{center}
\begin{small}
\begin{tabular}{l}
\hline Algorithm \textbf{s\_mp\_sub}. \\
\textbf{Input}.   Two mp\_ints $a$ and $b$ ($\vert a \vert \ge \vert b \vert$) \\
\textbf{Output}.  The unsigned subtraction $c = \vert a \vert - \vert b \vert$. \\
\hline \\
1.  $min \leftarrow b.used$ \\
2.  $max \leftarrow a.used$ \\
3.  If $c.alloc < max$ then grow $c$ to hold at least $max$ digits.  (\textit{mp\_grow}) \\
4.  $oldused \leftarrow c.used$ \\ 
5.  $c.used \leftarrow max$ \\
6.  $u \leftarrow 0$ \\
7.  for $n$ from $0$ to $min - 1$ do \\
\hspace{3mm}7.1  $c_n \leftarrow a_n - b_n - u$ \\
\hspace{3mm}7.2  $u   \leftarrow c_n >> (\gamma - 1)$ \\
\hspace{3mm}7.3  $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\
8.  if $min < max$ then do \\
\hspace{3mm}8.1  for $n$ from $min$ to $max - 1$ do \\
\hspace{6mm}8.1.1  $c_n \leftarrow a_n - u$ \\
\hspace{6mm}8.1.2  $u   \leftarrow c_n >> (\gamma - 1)$ \\
\hspace{6mm}8.1.3  $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\
9. if $oldused > max$ then do \\
\hspace{3mm}9.1  for $n$ from $max$ to $oldused - 1$ do \\
\hspace{6mm}9.1.1  $c_n \leftarrow 0$ \\
10. Clamp excess digits of $c$.  (\textit{mp\_clamp}). \\
11. Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Algorithm s\_mp\_sub}
\end{figure}

\textbf{Algorithm s\_mp\_sub.}
This algorithm performs the unsigned subtraction of two mp\_int variables under the restriction that the result must be positive.  That is when
passing variables $a$ and $b$ the condition that $\vert a \vert \ge \vert b \vert$ must be met for the algorithm to function correctly.  This
algorithm is loosely based on algorithm 14.9 \cite[pp. 595]{HAC} and is similar to algorithm S in \cite[pp. 267]{TAOCPV2} as well.  As was the case
of the algorithm s\_mp\_add both other references lack discussion concerning various practical details such as when the inputs differ in magnitude.

The initial sorting of the inputs is trivial in this algorithm since $a$ is guaranteed to have at least the same magnitude of $b$.  Steps 1 and 2 
set the $min$ and $max$ variables.  Unlike the addition routine there is guaranteed to be no carry which means that the final result can be at 
most $max$ digits in length as opposed to $max + 1$.  Similar to the addition algorithm the \textbf{used} count of $c$ is copied locally and 
set to the maximal count for the operation.

The subtraction loop that begins on step seven is essentially the same as the addition loop of algorithm s\_mp\_add except single precision 
subtraction is used instead.  Note the use of the $\gamma$ variable to extract the carry (\textit{also known as the borrow}) within the subtraction 
loops.  Under the assumption that two's complement single precision arithmetic is used this will successfully extract the desired carry.  

For example, consider subtracting $0101_2$ from $0100_2$ where $\gamma = 4$ and $\beta = 2$.  The least significant bit will force a carry upwards to 
the third bit which will be set to zero after the borrow.  After the very first bit has been subtracted $4 - 1 \equiv 0011_2$ will remain,  When the 
third bit of $0101_2$ is subtracted from the result it will cause another carry.  In this case though the carry will be forced to propagate all the 
way to the most significant bit.  

Recall that $\beta < 2^{\gamma}$.  This means that if a carry does occur just before the $lg(\beta)$'th bit it will propagate all the way to the most 
significant bit.  Thus, the high order bits of the mp\_digit that are not part of the actual digit will either be all zero, or all one. All that
is needed is a single zero or one bit for the carry.  Therefore a single logical shift right by $\gamma - 1$ positions is sufficient to extract the 
carry.  This method of carry extraction may seem awkward but the reason for it becomes apparent when the implementation is discussed.  

If $b$ has a smaller magnitude than $a$ then step 9 will force the carry and copy operation to propagate through the larger input $a$ into $c$.  Step
10 will ensure that any leading digits of $c$ above the $max$'th position are zeroed.

EXAM,bn_s_mp_sub.c

Like low level addition we ``sort'' the inputs.  Except in this case the sorting is hardcoded 
(lines @24,min@ and @25,max@).  In reality the $min$ and $max$ variables are only aliases and are only 
used to make the source code easier to read.  Again the pointer alias optimization is used 
within this algorithm.  The aliases $tmpa$, $tmpb$ and $tmpc$ are initialized
(lines @42,tmpa@, @43,tmpb@ and @44,tmpc@) for $a$, $b$ and $c$ respectively.

The first subtraction loop (lines @47,u = 0@ through @61,}@) subtract digits from both inputs until the smaller of
the two inputs has been exhausted.  As remarked earlier there is an implementation reason for using the ``awkward'' 
method of extracting the carry (line @57, >>@).  The traditional method for extracting the carry would be to shift 
by $lg(\beta)$ positions and logically AND the least significant bit.  The AND operation is required because all of 
the bits above the $\lg(\beta)$'th bit will be set to one after a carry occurs from subtraction.  This carry 
extraction requires two relatively cheap operations to extract the carry.  The other method is to simply shift the 
most significant bit to the least significant bit thus extracting the carry with a single cheap operation.  This 
optimization only works on twos compliment machines which is a safe assumption to make.

If $a$ has a larger magnitude than $b$ an additional loop (lines @64,for@ through @73,}@) is required to propagate 
the carry through $a$ and copy the result to $c$.  

\subsection{High Level Addition}
Now that both lower level addition and subtraction algorithms have been established an effective high level signed addition algorithm can be
established.  This high level addition algorithm will be what other algorithms and developers will use to perform addition of mp\_int data 
types.  

Recall from section 5.2 that an mp\_int represents an integer with an unsigned mantissa (\textit{the array of digits}) and a \textbf{sign} 
flag.  A high level addition is actually performed as a series of eight separate cases which can be optimized down to three unique cases.

\begin{figure}[!here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_add}. \\
\textbf{Input}.   Two mp\_ints $a$ and $b$  \\
\textbf{Output}.  The signed addition $c = a + b$. \\
\hline \\
1.  if $a.sign = b.sign$ then do \\
\hspace{3mm}1.1  $c.sign \leftarrow a.sign$  \\
\hspace{3mm}1.2  $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add})\\
2.  else do \\
\hspace{3mm}2.1  if $\vert a \vert < \vert b \vert$ then do (\textit{mp\_cmp\_mag})  \\
\hspace{6mm}2.1.1  $c.sign \leftarrow b.sign$ \\
\hspace{6mm}2.1.2  $c \leftarrow \vert b \vert - \vert a \vert$ (\textit{s\_mp\_sub}) \\
\hspace{3mm}2.2  else do \\
\hspace{6mm}2.2.1  $c.sign \leftarrow a.sign$ \\
\hspace{6mm}2.2.2  $c \leftarrow \vert a \vert - \vert b \vert$ \\
3.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_add}
\end{figure}

\textbf{Algorithm mp\_add.}
This algorithm performs the signed addition of two mp\_int variables.  There is no reference algorithm to draw upon from 
either \cite{TAOCPV2} or \cite{HAC} since they both only provide unsigned operations.  The algorithm is fairly 
straightforward but restricted since subtraction can only produce positive results.

\begin{figure}[here]
\begin{small}
\begin{center}
\begin{tabular}{|c|c|c|c|c|}
\hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert > \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\
\hline $+$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\
\hline $+$ & $+$ & No  & $c = a + b$ & $a.sign$ \\
\hline $-$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\
\hline $-$ & $-$ & No  & $c = a + b$ & $a.sign$ \\
\hline &&&&\\

\hline $+$ & $-$ & No  & $c = b - a$ & $b.sign$ \\
\hline $-$ & $+$ & No  & $c = b - a$ & $b.sign$ \\

\hline &&&&\\

\hline $+$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\
\hline $-$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\

\hline
\end{tabular}
\end{center}
\end{small}
\caption{Addition Guide Chart}
\label{fig:AddChart}
\end{figure}

Figure~\ref{fig:AddChart} lists all of the eight possible input combinations and is sorted to show that only three 
specific cases need to be handled.  The return code of the unsigned operations at step 1.2, 2.1.2 and 2.2.2 are 
forwarded to step three to check for errors.  This simplifies the description of the algorithm considerably and best 
follows how the implementation actually was achieved.

Also note how the \textbf{sign} is set before the unsigned addition or subtraction is performed.  Recall from the descriptions of algorithms
s\_mp\_add and s\_mp\_sub that the mp\_clamp function is used at the end to trim excess digits.  The mp\_clamp algorithm will set the \textbf{sign}
to \textbf{MP\_ZPOS} when the \textbf{used} digit count reaches zero.

For example, consider performing $-a + a$ with algorithm mp\_add.  By the description of the algorithm the sign is set to \textbf{MP\_NEG} which would
produce a result of $-0$.  However, since the sign is set first then the unsigned addition is performed the subsequent usage of algorithm mp\_clamp 
within algorithm s\_mp\_add will force $-0$ to become $0$.  

EXAM,bn_mp_add.c

The source code follows the algorithm fairly closely.  The most notable new source code addition is the usage of the $res$ integer variable which
is used to pass result of the unsigned operations forward.  Unlike in the algorithm, the variable $res$ is merely returned as is without
explicitly checking it and returning the constant \textbf{MP\_OKAY}.  The observation is this algorithm will succeed or fail only if the lower
level functions do so.  Returning their return code is sufficient.

\subsection{High Level Subtraction}
The high level signed subtraction algorithm is essentially the same as the high level signed addition algorithm.  

\newpage\begin{figure}[!here]
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_sub}. \\
\textbf{Input}.   Two mp\_ints $a$ and $b$  \\
\textbf{Output}.  The signed subtraction $c = a - b$. \\
\hline \\
1.  if $a.sign \ne b.sign$ then do \\
\hspace{3mm}1.1  $c.sign \leftarrow a.sign$ \\
\hspace{3mm}1.2  $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add}) \\
2.  else do \\
\hspace{3mm}2.1  if $\vert a \vert \ge \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\
\hspace{6mm}2.1.1  $c.sign \leftarrow a.sign$ \\
\hspace{6mm}2.1.2  $c \leftarrow \vert a \vert  - \vert b \vert$ (\textit{s\_mp\_sub}) \\
\hspace{3mm}2.2  else do \\
\hspace{6mm}2.2.1  $c.sign \leftarrow  \left \lbrace \begin{array}{ll}
                              MP\_ZPOS &  \mbox{if }a.sign = MP\_NEG \\
                              MP\_NEG  &  \mbox{otherwise} \\
                              \end{array} \right .$ \\
\hspace{6mm}2.2.2  $c \leftarrow \vert b \vert  - \vert a \vert$ \\
3.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\caption{Algorithm mp\_sub}
\end{figure}

\textbf{Algorithm mp\_sub.}
This algorithm performs the signed subtraction of two inputs.  Similar to algorithm mp\_add there is no reference in either \cite{TAOCPV2} or 
\cite{HAC}.  Also this algorithm is restricted by algorithm s\_mp\_sub.  Chart \ref{fig:SubChart} lists the eight possible inputs and
the operations required.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{|c|c|c|c|c|}
\hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert \ge \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\
\hline $+$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\
\hline $+$ & $-$ & No  & $c = a + b$ & $a.sign$ \\
\hline $-$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\
\hline $-$ & $+$ & No  & $c = a + b$ & $a.sign$ \\
\hline &&&& \\
\hline $+$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\
\hline $-$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\
\hline &&&& \\
\hline $+$ & $+$ & No  & $c = b - a$ & $\mbox{opposite of }a.sign$ \\
\hline $-$ & $-$ & No  & $c = b - a$ & $\mbox{opposite of }a.sign$ \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Subtraction Guide Chart}
\label{fig:SubChart}
\end{figure}

Similar to the case of algorithm mp\_add the \textbf{sign} is set first before the unsigned addition or subtraction.  That is to prevent the 
algorithm from producing $-a - -a = -0$ as a result.  

EXAM,bn_mp_sub.c

Much like the implementation of algorithm mp\_add the variable $res$ is used to catch the return code of the unsigned addition or subtraction operations
and forward it to the end of the function.  On line @38, != MP_LT@ the ``not equal to'' \textbf{MP\_LT} expression is used to emulate a 
``greater than or equal to'' comparison.  

\section{Bit and Digit Shifting}
MARK,POLY
It is quite common to think of a multiple precision integer as a polynomial in $x$, that is $y = f(\beta)$ where $f(x) = \sum_{i=0}^{n-1} a_i x^i$.  
This notation arises within discussion of Montgomery and Diminished Radix Reduction as well as Karatsuba multiplication and squaring.  

In order to facilitate operations on polynomials in $x$ as above a series of simple ``digit'' algorithms have to be established.  That is to shift
the digits left or right as well to shift individual bits of the digits left and right.  It is important to note that not all ``shift'' operations
are on radix-$\beta$ digits.  

\subsection{Multiplication by Two}

In a binary system where the radix is a power of two multiplication by two not only arises often in other algorithms it is a fairly efficient 
operation to perform.  A single precision logical shift left is sufficient to multiply a single digit by two.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_mul\_2}. \\
\textbf{Input}.   One mp\_int $a$ \\
\textbf{Output}.  $b = 2a$. \\
\hline \\
1.  If $b.alloc < a.used + 1$ then grow $b$ to hold $a.used + 1$ digits.  (\textit{mp\_grow}) \\
2.  $oldused \leftarrow b.used$ \\
3.  $b.used \leftarrow a.used$ \\
4.  $r \leftarrow 0$ \\
5.  for $n$ from 0 to $a.used - 1$ do \\
\hspace{3mm}5.1  $rr \leftarrow a_n >> (lg(\beta) - 1)$ \\
\hspace{3mm}5.2  $b_n \leftarrow (a_n << 1) + r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}5.3  $r \leftarrow rr$ \\
6.  If $r \ne 0$ then do \\
\hspace{3mm}6.1  $b_{n + 1} \leftarrow r$ \\
\hspace{3mm}6.2  $b.used \leftarrow b.used + 1$ \\
7.  If $b.used < oldused - 1$ then do \\
\hspace{3mm}7.1  for $n$ from $b.used$ to $oldused - 1$ do \\
\hspace{6mm}7.1.1  $b_n \leftarrow 0$ \\
8.  $b.sign \leftarrow a.sign$ \\
9.  Return(\textit{MP\_OKAY}).\\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_mul\_2}
\end{figure}

\textbf{Algorithm mp\_mul\_2.}
This algorithm will quickly multiply a mp\_int by two provided $\beta$ is a power of two.  Neither \cite{TAOCPV2} nor \cite{HAC} describe such 
an algorithm despite the fact it arises often in other algorithms.  The algorithm is setup much like the lower level algorithm s\_mp\_add since 
it is for all intents and purposes equivalent to the operation $b = \vert a \vert + \vert a \vert$.  

Step 1 and 2 grow the input as required to accomodate the maximum number of \textbf{used} digits in the result.  The initial \textbf{used} count
is set to $a.used$ at step 4.  Only if there is a final carry will the \textbf{used} count require adjustment.

Step 6 is an optimization implementation of the addition loop for this specific case.  That is since the two values being added together 
are the same there is no need to perform two reads from the digits of $a$.  Step 6.1 performs a single precision shift on the current digit $a_n$ to
obtain what will be the carry for the next iteration.  Step 6.2 calculates the $n$'th digit of the result as single precision shift of $a_n$ plus
the previous carry.  Recall from ~SHIFTS~ that $a_n << 1$ is equivalent to $a_n \cdot 2$.  An iteration of the addition loop is finished with 
forwarding the carry to the next iteration.

Step 7 takes care of any final carry by setting the $a.used$'th digit of the result to the carry and augmenting the \textbf{used} count of $b$.  
Step 8 clears any leading digits of $b$ in case it originally had a larger magnitude than $a$.

EXAM,bn_mp_mul_2.c

This implementation is essentially an optimized implementation of s\_mp\_add for the case of doubling an input.  The only noteworthy difference
is the use of the logical shift operator on line @52,<<@ to perform a single precision doubling.  

\subsection{Division by Two}
A division by two can just as easily be accomplished with a logical shift right as multiplication by two can be with a logical shift left.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_div\_2}. \\
\textbf{Input}.   One mp\_int $a$ \\
\textbf{Output}.  $b = a/2$. \\
\hline \\
1.  If $b.alloc < a.used$ then grow $b$ to hold $a.used$ digits.  (\textit{mp\_grow}) \\
2.  If the reallocation failed return(\textit{MP\_MEM}). \\
3.  $oldused \leftarrow b.used$ \\
4.  $b.used \leftarrow a.used$ \\
5.  $r \leftarrow 0$ \\
6.  for $n$ from $b.used - 1$ to $0$ do \\
\hspace{3mm}6.1  $rr \leftarrow a_n \mbox{ (mod }2\mbox{)}$\\
\hspace{3mm}6.2  $b_n \leftarrow (a_n >> 1) + (r << (lg(\beta) - 1)) \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}6.3  $r \leftarrow rr$ \\
7.  If $b.used < oldused - 1$ then do \\
\hspace{3mm}7.1  for $n$ from $b.used$ to $oldused - 1$ do \\
\hspace{6mm}7.1.1  $b_n \leftarrow 0$ \\
8.  $b.sign \leftarrow a.sign$ \\
9.  Clamp excess digits of $b$.  (\textit{mp\_clamp}) \\
10.  Return(\textit{MP\_OKAY}).\\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_div\_2}
\end{figure}

\textbf{Algorithm mp\_div\_2.}
This algorithm will divide an mp\_int by two using logical shifts to the right.  Like mp\_mul\_2 it uses a modified low level addition
core as the basis of the algorithm.  Unlike mp\_mul\_2 the shift operations work from the leading digit to the trailing digit.  The algorithm
could be written to work from the trailing digit to the leading digit however, it would have to stop one short of $a.used - 1$ digits to prevent
reading past the end of the array of digits.

Essentially the loop at step 6 is similar to that of mp\_mul\_2 except the logical shifts go in the opposite direction and the carry is at the 
least significant bit not the most significant bit.  

EXAM,bn_mp_div_2.c

\section{Polynomial Basis Operations}
Recall from ~POLY~ that any integer can be represented as a polynomial in $x$ as $y = f(\beta)$.  Such a representation is also known as
the polynomial basis \cite[pp. 48]{ROSE}. Given such a notation a multiplication or division by $x$ amounts to shifting whole digits a single 
place.  The need for such operations arises in several other higher level algorithms such as Barrett and Montgomery reduction, integer
division and Karatsuba multiplication.  

Converting from an array of digits to polynomial basis is very simple.  Consider the integer $y \equiv (a_2, a_1, a_0)_{\beta}$ and recall that
$y = \sum_{i=0}^{2} a_i \beta^i$.  Simply replace $\beta$ with $x$ and the expression is in polynomial basis.  For example, $f(x) = 8x + 9$ is the
polynomial basis representation for $89$ using radix ten.  That is, $f(10) = 8(10) + 9 = 89$.  

\subsection{Multiplication by $x$}

Given a polynomial in $x$ such as $f(x) = a_n x^n + a_{n-1} x^{n-1} + ... + a_0$ multiplying by $x$ amounts to shifting the coefficients up one 
degree.  In this case $f(x) \cdot x = a_n x^{n+1} + a_{n-1} x^n + ... + a_0 x$.  From a scalar basis point of view multiplying by $x$ is equivalent to
multiplying by the integer $\beta$.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_lshd}. \\
\textbf{Input}.   One mp\_int $a$ and an integer $b$ \\
\textbf{Output}.  $a \leftarrow a \cdot \beta^b$ (equivalent to multiplication by $x^b$). \\
\hline \\
1.  If $b \le 0$ then return(\textit{MP\_OKAY}). \\
2.  If $a.alloc < a.used + b$ then grow $a$ to at least $a.used + b$ digits.  (\textit{mp\_grow}). \\
3.  If the reallocation failed return(\textit{MP\_MEM}). \\
4.  $a.used \leftarrow a.used + b$ \\
5.  $i \leftarrow a.used - 1$ \\
6.  $j \leftarrow a.used - 1 - b$ \\
7.  for $n$ from $a.used - 1$ to $b$ do \\
\hspace{3mm}7.1  $a_{i} \leftarrow a_{j}$ \\
\hspace{3mm}7.2  $i \leftarrow i - 1$ \\
\hspace{3mm}7.3  $j \leftarrow j - 1$ \\
8.  for $n$ from 0 to $b - 1$ do \\
\hspace{3mm}8.1  $a_n \leftarrow 0$ \\
9.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_lshd}
\end{figure}

\textbf{Algorithm mp\_lshd.}
This algorithm multiplies an mp\_int by the $b$'th power of $x$.  This is equivalent to multiplying by $\beta^b$.  The algorithm differs 
from the other algorithms presented so far as it performs the operation in place instead storing the result in a separate location.  The
motivation behind this change is due to the way this function is typically used.  Algorithms such as mp\_add store the result in an optionally
different third mp\_int because the original inputs are often still required.  Algorithm mp\_lshd (\textit{and similarly algorithm mp\_rshd}) is
typically used on values where the original value is no longer required.  The algorithm will return success immediately if 
$b \le 0$ since the rest of algorithm is only valid when $b > 0$.  

First the destination $a$ is grown as required to accomodate the result.  The counters $i$ and $j$ are used to form a \textit{sliding window} over
the digits of $a$ of length $b$.  The head of the sliding window is at $i$ (\textit{the leading digit}) and the tail at $j$ (\textit{the trailing digit}).  
The loop on step 7 copies the digit from the tail to the head.  In each iteration the window is moved down one digit.   The last loop on 
step 8 sets the lower $b$ digits to zero.

\newpage
FIGU,sliding_window,Sliding Window Movement

EXAM,bn_mp_lshd.c

The if statement (line @24,if@) ensures that the $b$ variable is greater than zero since we do not interpret negative
shift counts properly.  The \textbf{used} count is incremented by $b$ before the copy loop begins.  This elminates 
the need for an additional variable in the for loop.  The variable $top$ (line @42,top@) is an alias
for the leading digit while $bottom$ (line @45,bottom@) is an alias for the trailing edge.  The aliases form a 
window of exactly $b$ digits over the input.  

\subsection{Division by $x$}

Division by powers of $x$ is easily achieved by shifting the digits right and removing any that will end up to the right of the zero'th digit.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_rshd}. \\
\textbf{Input}.   One mp\_int $a$ and an integer $b$ \\
\textbf{Output}.  $a \leftarrow a / \beta^b$ (Divide by $x^b$). \\
\hline \\
1.  If $b \le 0$ then return. \\
2.  If $a.used \le b$ then do \\
\hspace{3mm}2.1  Zero $a$.  (\textit{mp\_zero}). \\
\hspace{3mm}2.2  Return. \\
3.  $i \leftarrow 0$ \\
4.  $j \leftarrow b$ \\
5.  for $n$ from 0 to $a.used - b - 1$ do \\
\hspace{3mm}5.1  $a_i \leftarrow a_j$ \\
\hspace{3mm}5.2  $i \leftarrow i + 1$ \\
\hspace{3mm}5.3  $j \leftarrow j + 1$ \\
6.  for $n$ from $a.used - b$ to $a.used - 1$ do \\
\hspace{3mm}6.1  $a_n \leftarrow 0$ \\
7.  $a.used \leftarrow a.used - b$ \\
8.  Return. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_rshd}
\end{figure}

\textbf{Algorithm mp\_rshd.}
This algorithm divides the input in place by the $b$'th power of $x$.  It is analogous to dividing by a $\beta^b$ but much quicker since
it does not require single precision division.  This algorithm does not actually return an error code as it cannot fail.  

If the input $b$ is less than one the algorithm quickly returns without performing any work.  If the \textbf{used} count is less than or equal
to the shift count $b$ then it will simply zero the input and return.

After the trivial cases of inputs have been handled the sliding window is setup.  Much like the case of algorithm mp\_lshd a sliding window that
is $b$ digits wide is used to copy the digits.  Unlike mp\_lshd the window slides in the opposite direction from the trailing to the leading digit.  
Also the digits are copied from the leading to the trailing edge.

Once the window copy is complete the upper digits must be zeroed and the \textbf{used} count decremented.

EXAM,bn_mp_rshd.c

The only noteworthy element of this routine is the lack of a return type since it cannot fail.  Like mp\_lshd() we
form a sliding window except we copy in the other direction.  After the window (line @59,for (;@) we then zero
the upper digits of the input to make sure the result is correct.

\section{Powers of Two}

Now that algorithms for moving single bits as well as whole digits exist algorithms for moving the ``in between'' distances are required.  For 
example, to quickly multiply by $2^k$ for any $k$ without using a full multiplier algorithm would prove useful.  Instead of performing single
shifts $k$ times to achieve a multiplication by $2^{\pm k}$ a mixture of whole digit shifting and partial digit shifting is employed.  

\subsection{Multiplication by Power of Two}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_mul\_2d}. \\
\textbf{Input}.   One mp\_int $a$ and an integer $b$ \\
\textbf{Output}.  $c \leftarrow a \cdot 2^b$. \\
\hline \\
1.  $c \leftarrow a$.  (\textit{mp\_copy}) \\
2.  If $c.alloc < c.used + \lfloor b / lg(\beta) \rfloor + 2$ then grow $c$ accordingly. \\
3.  If the reallocation failed return(\textit{MP\_MEM}). \\
4.  If $b \ge lg(\beta)$ then \\
\hspace{3mm}4.1  $c \leftarrow c \cdot \beta^{\lfloor b / lg(\beta) \rfloor}$ (\textit{mp\_lshd}). \\
\hspace{3mm}4.2  If step 4.1 failed return(\textit{MP\_MEM}). \\
5.  $d \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\
6.  If $d \ne 0$ then do \\
\hspace{3mm}6.1  $mask \leftarrow 2^d$ \\
\hspace{3mm}6.2  $r \leftarrow 0$ \\
\hspace{3mm}6.3  for $n$ from $0$ to $c.used - 1$ do \\
\hspace{6mm}6.3.1  $rr \leftarrow c_n >> (lg(\beta) - d) \mbox{ (mod }mask\mbox{)}$ \\
\hspace{6mm}6.3.2  $c_n \leftarrow (c_n << d) + r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{6mm}6.3.3  $r \leftarrow rr$ \\
\hspace{3mm}6.4  If $r > 0$ then do \\
\hspace{6mm}6.4.1  $c_{c.used} \leftarrow r$ \\
\hspace{6mm}6.4.2  $c.used \leftarrow c.used + 1$ \\
7.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_mul\_2d}
\end{figure}

\textbf{Algorithm mp\_mul\_2d.}
This algorithm multiplies $a$ by $2^b$ and stores the result in $c$.  The algorithm uses algorithm mp\_lshd and a derivative of algorithm mp\_mul\_2 to
quickly compute the product.

First the algorithm will multiply $a$ by $x^{\lfloor b / lg(\beta) \rfloor}$ which will ensure that the remainder multiplicand is less than 
$\beta$.  For example, if $b = 37$ and $\beta = 2^{28}$ then this step will multiply by $x$ leaving a multiplication by $2^{37 - 28} = 2^{9}$ 
left.

After the digits have been shifted appropriately at most $lg(\beta) - 1$ shifts are left to perform.  Step 5 calculates the number of remaining shifts 
required.  If it is non-zero a modified shift loop is used to calculate the remaining product.  
Essentially the loop is a generic version of algorith mp\_mul2 designed to handle any shift count in the range $1 \le x < lg(\beta)$.  The $mask$
variable is used to extract the upper $d$ bits to form the carry for the next iteration.  

This algorithm is loosely measured as a $O(2n)$ algorithm which means that if the input is $n$-digits that it takes $2n$ ``time'' to 
complete.  It is possible to optimize this algorithm down to a $O(n)$ algorithm at a cost of making the algorithm slightly harder to follow.

EXAM,bn_mp_mul_2d.c

The shifting is performed in--place which means the first step (line @24,a != c@) is to copy the input to the 
destination.  We avoid calling mp\_copy() by making sure the mp\_ints are different.  The destination then
has to be grown (line @31,grow@) to accomodate the result.

If the shift count $b$ is larger than $lg(\beta)$ then a call to mp\_lshd() is used to handle all of the multiples 
of $lg(\beta)$.  Leaving only a remaining shift of $lg(\beta) - 1$ or fewer bits left.  Inside the actual shift 
loop (lines @45,if@ to @76,}@) we make use of pre--computed values $shift$ and $mask$.   These are used to
extract the carry bit(s) to pass into the next iteration of the loop.  The $r$ and $rr$ variables form a 
chain between consecutive iterations to propagate the carry.  

\subsection{Division by Power of Two}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_div\_2d}. \\
\textbf{Input}.   One mp\_int $a$ and an integer $b$ \\
\textbf{Output}.  $c \leftarrow \lfloor a / 2^b \rfloor, d \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\
\hline \\
1.  If $b \le 0$ then do \\
\hspace{3mm}1.1  $c \leftarrow a$ (\textit{mp\_copy}) \\
\hspace{3mm}1.2  $d \leftarrow 0$ (\textit{mp\_zero}) \\
\hspace{3mm}1.3  Return(\textit{MP\_OKAY}). \\
2.  $c \leftarrow a$ \\
3.  $d \leftarrow a \mbox{ (mod }2^b\mbox{)}$ (\textit{mp\_mod\_2d}) \\
4.  If $b \ge lg(\beta)$ then do \\
\hspace{3mm}4.1  $c \leftarrow \lfloor c/\beta^{\lfloor b/lg(\beta) \rfloor} \rfloor$ (\textit{mp\_rshd}). \\
5.  $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\
6.  If $k \ne 0$ then do \\
\hspace{3mm}6.1  $mask \leftarrow 2^k$ \\
\hspace{3mm}6.2  $r \leftarrow 0$ \\
\hspace{3mm}6.3  for $n$ from $c.used - 1$ to $0$ do \\
\hspace{6mm}6.3.1  $rr \leftarrow c_n \mbox{ (mod }mask\mbox{)}$ \\
\hspace{6mm}6.3.2  $c_n \leftarrow (c_n >> k) + (r << (lg(\beta) - k))$ \\
\hspace{6mm}6.3.3  $r \leftarrow rr$ \\
7.  Clamp excess digits of $c$.  (\textit{mp\_clamp}) \\
8.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_div\_2d}
\end{figure}

\textbf{Algorithm mp\_div\_2d.}
This algorithm will divide an input $a$ by $2^b$ and produce the quotient and remainder.  The algorithm is designed much like algorithm 
mp\_mul\_2d by first using whole digit shifts then single precision shifts.  This algorithm will also produce the remainder of the division
by using algorithm mp\_mod\_2d.

EXAM,bn_mp_div_2d.c

The implementation of algorithm mp\_div\_2d is slightly different than the algorithm specifies.  The remainder $d$ may be optionally 
ignored by passing \textbf{NULL} as the pointer to the mp\_int variable.    The temporary mp\_int variable $t$ is used to hold the 
result of the remainder operation until the end.  This allows $d$ and $a$ to represent the same mp\_int without modifying $a$ before
the quotient is obtained.

The remainder of the source code is essentially the same as the source code for mp\_mul\_2d.  The only significant difference is
the direction of the shifts.

\subsection{Remainder of Division by Power of Two}

The last algorithm in the series of polynomial basis power of two algorithms is calculating the remainder of division by $2^b$.  This
algorithm benefits from the fact that in twos complement arithmetic $a \mbox{ (mod }2^b\mbox{)}$ is the same as $a$ AND $2^b - 1$.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_mod\_2d}. \\
\textbf{Input}.   One mp\_int $a$ and an integer $b$ \\
\textbf{Output}.  $c \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\
\hline \\
1.  If $b \le 0$ then do \\
\hspace{3mm}1.1  $c \leftarrow 0$ (\textit{mp\_zero}) \\
\hspace{3mm}1.2  Return(\textit{MP\_OKAY}). \\
2.  If $b > a.used \cdot lg(\beta)$ then do \\
\hspace{3mm}2.1  $c \leftarrow a$ (\textit{mp\_copy}) \\
\hspace{3mm}2.2  Return the result of step 2.1. \\
3.  $c \leftarrow a$ \\
4.  If step 3 failed return(\textit{MP\_MEM}). \\
5.  for $n$ from $\lceil b / lg(\beta) \rceil$ to $c.used$ do \\
\hspace{3mm}5.1  $c_n \leftarrow 0$ \\
6.  $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\
7.  $c_{\lfloor b / lg(\beta) \rfloor} \leftarrow c_{\lfloor b / lg(\beta) \rfloor} \mbox{ (mod }2^{k}\mbox{)}$. \\
8.  Clamp excess digits of $c$.  (\textit{mp\_clamp}) \\
9.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_mod\_2d}
\end{figure}

\textbf{Algorithm mp\_mod\_2d.}
This algorithm will quickly calculate the value of $a \mbox{ (mod }2^b\mbox{)}$.  First if $b$ is less than or equal to zero the 
result is set to zero.  If $b$ is greater than the number of bits in $a$ then it simply copies $a$ to $c$ and returns.  Otherwise, $a$ 
is copied to $b$, leading digits are removed and the remaining leading digit is trimed to the exact bit count.

EXAM,bn_mp_mod_2d.c

We first avoid cases of $b \le 0$ by simply mp\_zero()'ing the destination in such cases.  Next if $2^b$ is larger
than the input we just mp\_copy() the input and return right away.  After this point we know we must actually
perform some work to produce the remainder.

Recalling that reducing modulo $2^k$ and a binary ``and'' with $2^k - 1$ are numerically equivalent we can quickly reduce 
the number.  First we zero any digits above the last digit in $2^b$ (line @41,for@).  Next we reduce the 
leading digit of both (line @45,&=@) and then mp\_clamp().

\section*{Exercises}
\begin{tabular}{cl}
$\left [ 3 \right ] $ & Devise an algorithm that performs $a \cdot 2^b$ for generic values of $b$ \\
                      & in $O(n)$ time. \\
                      &\\
$\left [ 3 \right ] $ & Devise an efficient algorithm to multiply by small low hamming  \\
                      & weight values such as $3$, $5$ and $9$.  Extend it to handle all values \\
                      & upto $64$ with a hamming weight less than three. \\
                      &\\
$\left [ 2 \right ] $ & Modify the preceding algorithm to handle values of the form \\
                      & $2^k - 1$ as well. \\
                      &\\
$\left [ 3 \right ] $ & Using only algorithms mp\_mul\_2, mp\_div\_2 and mp\_add create an \\
                      & algorithm to multiply two integers in roughly $O(2n^2)$ time for \\
                      & any $n$-bit input.  Note that the time of addition is ignored in the \\
                      & calculation.  \\
                      & \\
$\left [ 5 \right ] $ & Improve the previous algorithm to have a working time of at most \\
                      & $O \left (2^{(k-1)}n + \left ({2n^2 \over k} \right ) \right )$ for an appropriate choice of $k$.  Again ignore \\
                      & the cost of addition. \\
                      & \\
$\left [ 2 \right ] $ & Devise a chart to find optimal values of $k$ for the previous problem \\
                      & for $n = 64 \ldots 1024$ in steps of $64$. \\
                      & \\
$\left [ 2 \right ] $ & Using only algorithms mp\_abs and mp\_sub devise another method for \\
                      & calculating the result of a signed comparison. \\
                      &
\end{tabular}

\chapter{Multiplication and Squaring}
\section{The Multipliers}
For most number theoretic problems including certain public key cryptographic algorithms, the ``multipliers'' form the most important subset of 
algorithms of any multiple precision integer package.  The set of multiplier algorithms include integer multiplication, squaring and modular reduction 
where in each of the algorithms single precision multiplication is the dominant operation performed.  This chapter will discuss integer multiplication 
and squaring, leaving modular reductions for the subsequent chapter.  

The importance of the multiplier algorithms is for the most part driven by the fact that certain popular public key algorithms are based on modular 
exponentiation, that is computing $d \equiv a^b \mbox{ (mod }c\mbox{)}$ for some arbitrary choice of $a$, $b$, $c$ and $d$.  During a modular
exponentiation the majority\footnote{Roughly speaking a modular exponentiation will spend about 40\% of the time performing modular reductions, 
35\% of the time performing squaring and 25\% of the time performing multiplications.} of the processor time is spent performing single precision 
multiplications.

For centuries general purpose multiplication has required a lengthly $O(n^2)$ process, whereby each digit of one multiplicand has to be multiplied 
against every digit of the other multiplicand.  Traditional long-hand multiplication is based on this process;  while the techniques can differ the 
overall algorithm used is essentially the same.  Only ``recently'' have faster algorithms been studied.  First Karatsuba multiplication was discovered in 
1962.  This algorithm can multiply two numbers with considerably fewer single precision multiplications when compared to the long-hand approach.  
This technique led to the discovery of polynomial basis algorithms (\textit{good reference?}) and subquently Fourier Transform based solutions.  

\section{Multiplication}
\subsection{The Baseline Multiplication}
\label{sec:basemult}
\index{baseline multiplication}
Computing the product of two integers in software can be achieved using a trivial adaptation of the standard $O(n^2)$ long-hand multiplication
algorithm that school children are taught.  The algorithm is considered an $O(n^2)$ algorithm since for two $n$-digit inputs $n^2$ single precision 
multiplications are required.  More specifically for a $m$ and $n$ digit input $m \cdot n$ single precision multiplications are required.  To 
simplify most discussions, it will be assumed that the inputs have comparable number of digits.  

The ``baseline multiplication'' algorithm is designed to act as the ``catch-all'' algorithm, only to be used when the faster algorithms cannot be 
used.  This algorithm does not use any particularly interesting optimizations and should ideally be avoided if possible.    One important 
facet of this algorithm, is that it has been modified to only produce a certain amount of output digits as resolution.  The importance of this 
modification will become evident during the discussion of Barrett modular reduction.  Recall that for a $n$ and $m$ digit input the product 
will be at most $n + m$ digits.  Therefore, this algorithm can be reduced to a full multiplier by having it produce $n + m$ digits of the product.  

Recall from ~GAMMA~ the definition of $\gamma$ as the number of bits in the type \textbf{mp\_digit}.  We shall now extend the variable set to 
include $\alpha$ which shall represent the number of bits in the type \textbf{mp\_word}.  This implies that $2^{\alpha} > 2 \cdot \beta^2$.  The 
constant $\delta = 2^{\alpha - 2lg(\beta)}$ will represent the maximal weight of any column in a product (\textit{see ~COMBA~ for more information}).

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{s\_mp\_mul\_digs}. \\
\textbf{Input}.   mp\_int $a$, mp\_int $b$ and an integer $digs$ \\
\textbf{Output}.  $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\
\hline \\
1.  If min$(a.used, b.used) < \delta$ then do \\
\hspace{3mm}1.1  Calculate $c = \vert a \vert \cdot \vert b \vert$ by the Comba method (\textit{see algorithm~\ref{fig:COMBAMULT}}).  \\
\hspace{3mm}1.2  Return the result of step 1.1 \\
\\
Allocate and initialize a temporary mp\_int. \\
2.  Init $t$ to be of size $digs$ \\
3.  If step 2 failed return(\textit{MP\_MEM}). \\
4.  $t.used \leftarrow digs$ \\
\\
Compute the product. \\
5.  for $ix$ from $0$ to $a.used - 1$ do \\
\hspace{3mm}5.1  $u \leftarrow 0$ \\
\hspace{3mm}5.2  $pb \leftarrow \mbox{min}(b.used, digs - ix)$ \\
\hspace{3mm}5.3  If $pb < 1$ then goto step 6. \\
\hspace{3mm}5.4  for $iy$ from $0$ to $pb - 1$ do \\
\hspace{6mm}5.4.1  $\hat r \leftarrow t_{iy + ix} + a_{ix} \cdot b_{iy} + u$ \\
\hspace{6mm}5.4.2  $t_{iy + ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{6mm}5.4.3  $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\
\hspace{3mm}5.5  if $ix + pb < digs$ then do \\
\hspace{6mm}5.5.1  $t_{ix + pb} \leftarrow u$ \\
6.  Clamp excess digits of $t$. \\
7.  Swap $c$ with $t$ \\
8.  Clear $t$ \\
9.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm s\_mp\_mul\_digs}
\end{figure}

\textbf{Algorithm s\_mp\_mul\_digs.}
This algorithm computes the unsigned product of two inputs $a$ and $b$, limited to an output precision of $digs$ digits.  While it may seem
a bit awkward to modify the function from its simple $O(n^2)$ description, the usefulness of partial multipliers will arise in a subsequent 
algorithm.  The algorithm is loosely based on algorithm 14.12 from \cite[pp. 595]{HAC} and is similar to Algorithm M of Knuth \cite[pp. 268]{TAOCPV2}.  
Algorithm s\_mp\_mul\_digs differs from these cited references since it can produce a variable output precision regardless of the precision of the 
inputs.

The first thing this algorithm checks for is whether a Comba multiplier can be used instead.   If the minimum digit count of either
input is less than $\delta$, then the Comba method may be used instead.    After the Comba method is ruled out, the baseline algorithm begins.  A 
temporary mp\_int variable $t$ is used to hold the intermediate result of the product.  This allows the algorithm to be used to 
compute products when either $a = c$ or $b = c$ without overwriting the inputs.  

All of step 5 is the infamous $O(n^2)$ multiplication loop slightly modified to only produce upto $digs$ digits of output.  The $pb$ variable
is given the count of digits to read from $b$ inside the nested loop.  If $pb \le 1$ then no more output digits can be produced and the algorithm
will exit the loop.  The best way to think of the loops are as a series of $pb \times 1$ multiplications.    That is, in each pass of the 
innermost loop $a_{ix}$ is multiplied against $b$ and the result is added (\textit{with an appropriate shift}) to $t$.  

For example, consider multiplying $576$ by $241$.  That is equivalent to computing $10^0(1)(576) + 10^1(4)(576) + 10^2(2)(576)$ which is best
visualized in the following table.

\begin{figure}[here]
\begin{center}
\begin{tabular}{|c|c|c|c|c|c|l|}
\hline   &&          & 5 & 7 & 6 & \\
\hline   $\times$&&  & 2 & 4 & 1 & \\
\hline &&&&&&\\
  &&          & 5 & 7 & 6 & $10^0(1)(576)$ \\
  &2 &   3    & 6 & 1 & 6 & $10^1(4)(576) + 10^0(1)(576)$ \\
  1 & 3 & 8 & 8 & 1 & 6 &   $10^2(2)(576) + 10^1(4)(576) + 10^0(1)(576)$ \\
\hline  
\end{tabular}
\end{center}
\caption{Long-Hand Multiplication Diagram}
\end{figure}

Each row of the product is added to the result after being shifted to the left (\textit{multiplied by a power of the radix}) by the appropriate 
count.  That is in pass $ix$ of the inner loop the product is added starting at the $ix$'th digit of the reult.

Step 5.4.1 introduces the hat symbol (\textit{e.g. $\hat r$}) which represents a double precision variable.  The multiplication on that step
is assumed to be a double wide output single precision multiplication.  That is, two single precision variables are multiplied to produce a
double precision result.  The step is somewhat optimized from a long-hand multiplication algorithm because the carry from the addition in step
5.4.1 is propagated through the nested loop.  If the carry was not propagated immediately it would overflow the single precision digit 
$t_{ix+iy}$ and the result would be lost.  

At step 5.5 the nested loop is finished and any carry that was left over should be forwarded.  The carry does not have to be added to the $ix+pb$'th
digit since that digit is assumed to be zero at this point.  However, if $ix + pb \ge digs$ the carry is not set as it would make the result
exceed the precision requested.

EXAM,bn_s_mp_mul_digs.c

First we determine (line @30,if@) if the Comba method can be used first since it's faster.  The conditions for 
sing the Comba routine are that min$(a.used, b.used) < \delta$ and the number of digits of output is less than 
\textbf{MP\_WARRAY}.  This new constant is used to control the stack usage in the Comba routines.  By default it is 
set to $\delta$ but can be reduced when memory is at a premium.

If we cannot use the Comba method we proceed to setup the baseline routine.  We allocate the the destination mp\_int
$t$ (line @36,init@) to the exact size of the output to avoid further re--allocations.  At this point we now 
begin the $O(n^2)$ loop.

This implementation of multiplication has the caveat that it can be trimmed to only produce a variable number of
digits as output.  In each iteration of the outer loop the $pb$ variable is set (line @48,MIN@) to the maximum 
number of inner loop iterations.  

Inside the inner loop we calculate $\hat r$ as the mp\_word product of the two mp\_digits and the addition of the
carry from the previous iteration.  A particularly important observation is that most modern optimizing 
C compilers (GCC for instance) can recognize that a $N \times N \rightarrow 2N$ multiplication is all that 
is required for the product.  In x86 terms for example, this means using the MUL instruction.

Each digit of the product is stored in turn (line @68,tmpt@) and the carry propagated (line @71,>>@) to the 
next iteration.

\subsection{Faster Multiplication by the ``Comba'' Method}
MARK,COMBA

One of the huge drawbacks of the ``baseline'' algorithms is that at the $O(n^2)$ level the carry must be 
computed and propagated upwards.  This makes the nested loop very sequential and hard to unroll and implement 
in parallel.  The ``Comba'' \cite{COMBA} method is named after little known (\textit{in cryptographic venues}) Paul G. 
Comba who described a method of implementing fast multipliers that do not require nested carry fixup operations.  As an 
interesting aside it seems that Paul Barrett describes a similar technique in his 1986 paper \cite{BARRETT} written 
five years before.

At the heart of the Comba technique is once again the long-hand algorithm.  Except in this case a slight 
twist is placed on how the columns of the result are produced.  In the standard long-hand algorithm rows of products 
are produced then added together to form the final result.  In the baseline algorithm the columns are added together 
after each iteration to get the result instantaneously.  

In the Comba algorithm the columns of the result are produced entirely independently of each other.  That is at 
the $O(n^2)$ level a simple multiplication and addition step is performed.  The carries of the columns are propagated 
after the nested loop to reduce the amount of work requiored. Succintly the first step of the algorithm is to compute 
the product vector $\vec x$ as follows. 

\begin{equation}
\vec x_n = \sum_{i+j = n} a_ib_j, \forall n \in \lbrace 0, 1, 2, \ldots, i + j \rbrace
\end{equation}

Where $\vec x_n$ is the $n'th$ column of the output vector.  Consider the following example which computes the vector $\vec x$ for the multiplication
of $576$ and $241$.  

\newpage\begin{figure}[here]
\begin{small}
\begin{center}
\begin{tabular}{|c|c|c|c|c|c|}
  \hline &          & 5 & 7 & 6 & First Input\\
  \hline $\times$ & & 2 & 4 & 1 & Second Input\\
\hline            &                        & $1 \cdot 5 = 5$   & $1 \cdot 7 = 7$   & $1 \cdot 6 = 6$ & First pass \\
                  &  $4 \cdot 5 = 20$      & $4 \cdot 7+5=33$  & $4 \cdot 6+7=31$  & 6               & Second pass \\
   $2 \cdot 5 = 10$ &  $2 \cdot 7 + 20 = 34$ & $2 \cdot 6+33=45$ & 31                & 6             & Third pass \\
\hline 10 & 34 & 45 & 31 & 6 & Final Result \\   
\hline   
\end{tabular}
\end{center}
\end{small}
\caption{Comba Multiplication Diagram}
\end{figure}

At this point the vector $x = \left < 10, 34, 45, 31, 6 \right >$ is the result of the first step of the Comba multipler.  
Now the columns must be fixed by propagating the carry upwards.  The resultant vector will have one extra dimension over the input vector which is
congruent to adding a leading zero digit.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Comba Fixup}. \\
\textbf{Input}.   Vector $\vec x$ of dimension $k$ \\
\textbf{Output}.  Vector $\vec x$ such that the carries have been propagated. \\
\hline \\
1.  for $n$ from $0$ to $k - 1$ do \\
\hspace{3mm}1.1 $\vec x_{n+1} \leftarrow \vec x_{n+1} + \lfloor \vec x_{n}/\beta \rfloor$ \\
\hspace{3mm}1.2 $\vec x_{n} \leftarrow \vec x_{n} \mbox{ (mod }\beta\mbox{)}$ \\
2.  Return($\vec x$). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Comba Fixup}
\end{figure}

With that algorithm and $k = 5$ and $\beta = 10$ the following vector is produced $\vec x= \left < 1, 3, 8, 8, 1, 6 \right >$.  In this case 
$241 \cdot 576$ is in fact $138816$ and the procedure succeeded.  If the algorithm is correct and as will be demonstrated shortly more
efficient than the baseline algorithm why not simply always use this algorithm?

\subsubsection{Column Weight.}
At the nested $O(n^2)$ level the Comba method adds the product of two single precision variables to each column of the output 
independently.  A serious obstacle is if the carry is lost, due to lack of precision before the algorithm has a chance to fix
the carries.  For example, in the multiplication of two three-digit numbers the third column of output will be the sum of
three single precision multiplications.  If the precision of the accumulator for the output digits is less then $3 \cdot (\beta - 1)^2$ then
an overflow can occur and the carry information will be lost.  For any $m$ and $n$ digit inputs the maximum weight of any column is 
min$(m, n)$ which is fairly obvious.

The maximum number of terms in any column of a product is known as the ``column weight'' and strictly governs when the algorithm can be used.  Recall
from earlier that a double precision type has $\alpha$ bits of resolution and a single precision digit has $lg(\beta)$ bits of precision.  Given these
two quantities we must not violate the following

\begin{equation}
k \cdot \left (\beta - 1 \right )^2 < 2^{\alpha}
\end{equation}

Which reduces to 

\begin{equation}
k \cdot \left ( \beta^2 - 2\beta + 1 \right ) < 2^{\alpha}
\end{equation}

Let $\rho = lg(\beta)$ represent the number of bits in a single precision digit.  By further re-arrangement of the equation the final solution is
found.

\begin{equation}
k  < {{2^{\alpha}} \over {\left (2^{2\rho} - 2^{\rho + 1} + 1 \right )}}
\end{equation}

The defaults for LibTomMath are $\beta = 2^{28}$ and $\alpha = 2^{64}$ which means that $k$ is bounded by $k < 257$.  In this configuration 
the smaller input may not have more than $256$ digits if the Comba method is to be used.  This is quite satisfactory for most applications since 
$256$ digits would allow for numbers in the range of $0 \le x < 2^{7168}$ which, is much larger than most public key cryptographic algorithms require.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{fast\_s\_mp\_mul\_digs}. \\
\textbf{Input}.   mp\_int $a$, mp\_int $b$ and an integer $digs$ \\
\textbf{Output}.  $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\
\hline \\
Place an array of \textbf{MP\_WARRAY} single precision digits named $W$ on the stack. \\
1.  If $c.alloc < digs$ then grow $c$ to $digs$ digits. (\textit{mp\_grow}) \\
2.  If step 1 failed return(\textit{MP\_MEM}).\\
\\
3.  $pa \leftarrow \mbox{MIN}(digs, a.used + b.used)$ \\
\\
4.  $\_ \hat W \leftarrow 0$ \\
5.  for $ix$ from 0 to $pa - 1$ do \\
\hspace{3mm}5.1  $ty \leftarrow \mbox{MIN}(b.used - 1, ix)$ \\
\hspace{3mm}5.2  $tx \leftarrow ix - ty$ \\
\hspace{3mm}5.3  $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\
\hspace{3mm}5.4  for $iz$ from 0 to $iy - 1$ do \\
\hspace{6mm}5.4.1  $\_ \hat W \leftarrow \_ \hat W + a_{tx+iy}b_{ty-iy}$ \\
\hspace{3mm}5.5  $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$\\
\hspace{3mm}5.6  $\_ \hat W \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\
6.  $W_{pa} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\
\\
7.  $oldused \leftarrow c.used$ \\
8.  $c.used \leftarrow digs$ \\
9.  for $ix$ from $0$ to $pa$ do \\
\hspace{3mm}9.1  $c_{ix} \leftarrow W_{ix}$ \\
10.  for $ix$ from $pa + 1$ to $oldused - 1$ do \\
\hspace{3mm}10.1 $c_{ix} \leftarrow 0$ \\
\\
11.  Clamp $c$. \\
12.  Return MP\_OKAY. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm fast\_s\_mp\_mul\_digs}
\label{fig:COMBAMULT}
\end{figure}

\textbf{Algorithm fast\_s\_mp\_mul\_digs.}
This algorithm performs the unsigned multiplication of $a$ and $b$ using the Comba method limited to $digs$ digits of precision.

The outer loop of this algorithm is more complicated than that of the baseline multiplier.  This is because on the inside of the 
loop we want to produce one column per pass.  This allows the accumulator $\_ \hat W$ to be placed in CPU registers and
reduce the memory bandwidth to two \textbf{mp\_digit} reads per iteration.

The $ty$ variable is set to the minimum count of $ix$ or the number of digits in $b$.  That way if $a$ has more digits than
$b$ this will be limited to $b.used - 1$.  The $tx$ variable is set to the to the distance past $b.used$ the variable
$ix$ is.  This is used for the immediately subsequent statement where we find $iy$.  

The variable $iy$ is the minimum digits we can read from either $a$ or $b$ before running out.  Computing one column at a time
means we have to scan one integer upwards and the other downwards.  $a$ starts at $tx$ and $b$ starts at $ty$.  In each
pass we are producing the $ix$'th output column and we note that $tx + ty = ix$.  As we move $tx$ upwards we have to 
move $ty$ downards so the equality remains valid.  The $iy$ variable is the number of iterations until 
$tx \ge a.used$ or $ty < 0$ occurs.

After every inner pass we store the lower half of the accumulator into $W_{ix}$ and then propagate the carry of the accumulator
into the next round by dividing $\_ \hat W$ by $\beta$.

To measure the benefits of the Comba method over the baseline method consider the number of operations that are required.  If the 
cost in terms of time of a multiply and addition is $p$ and the cost of a carry propagation is $q$ then a baseline multiplication would require 
$O \left ((p + q)n^2 \right )$ time to multiply two $n$-digit numbers.  The Comba method requires only $O(pn^2 + qn)$ time, however in practice, 
the speed increase is actually much more.  With $O(n)$ space the algorithm can be reduced to $O(pn + qn)$ time by implementing the $n$ multiply
and addition operations in the nested loop in parallel.  

EXAM,bn_fast_s_mp_mul_digs.c

As per the pseudo--code we first calculate $pa$ (line @47,MIN@) as the number of digits to output.  Next we begin the outer loop
to produce the individual columns of the product.  We use the two aliases $tmpx$ and $tmpy$ (lines @61,tmpx@, @62,tmpy@) to point
inside the two multiplicands quickly.  

The inner loop (lines @70,for@ to @72,}@) of this implementation is where the tradeoff come into play.  Originally this comba 
implementation was ``row--major'' which means it adds to each of the columns in each pass.  After the outer loop it would then fix 
the carries.  This was very fast except it had an annoying drawback.  You had to read a mp\_word and two mp\_digits and write 
one mp\_word per iteration.  On processors such as the Athlon XP and P4 this did not matter much since the cache bandwidth 
is very high and it can keep the ALU fed with data.  It did, however, matter on older and embedded cpus where cache is often 
slower and also often doesn't exist.  This new algorithm only performs two reads per iteration under the assumption that the 
compiler has aliased $\_ \hat W$ to a CPU register.

After the inner loop we store the current accumulator in $W$ and shift $\_ \hat W$ (lines @75,W[ix]@, @78,>>@) to forward it as 
a carry for the next pass.  After the outer loop we use the final carry (line @82,W[ix]@) as the last digit of the product.  

\subsection{Polynomial Basis Multiplication}
To break the $O(n^2)$ barrier in multiplication requires a completely different look at integer multiplication.  In the following algorithms
the use of polynomial basis representation for two integers $a$ and $b$ as $f(x) = \sum_{i=0}^{n} a_i x^i$ and  
$g(x) = \sum_{i=0}^{n} b_i x^i$ respectively, is required.  In this system both $f(x)$ and $g(x)$ have $n + 1$ terms and are of the $n$'th degree.
 
The product $a \cdot b \equiv f(x)g(x)$ is the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$.  The coefficients $w_i$ will
directly yield the desired product when $\beta$ is substituted for $x$.  The direct solution to solve for the $2n + 1$ coefficients
requires $O(n^2)$ time and would in practice be slower than the Comba technique.

However, numerical analysis theory indicates that only $2n + 1$ distinct points in $W(x)$ are required to determine the values of the $2n + 1$ unknown 
coefficients.   This means by finding $\zeta_y = W(y)$ for $2n + 1$ small values of $y$ the coefficients of $W(x)$ can be found with 
Gaussian elimination.  This technique is also occasionally refered to as the \textit{interpolation technique} (\textit{references please...}) since in 
effect an interpolation based on $2n + 1$ points will yield a polynomial equivalent to $W(x)$.  

The coefficients of the polynomial $W(x)$ are unknown which makes finding $W(y)$ for any value of $y$ impossible.  However, since 
$W(x) = f(x)g(x)$ the equivalent $\zeta_y = f(y) g(y)$ can be used in its place.  The benefit of this technique stems from the 
fact that $f(y)$ and $g(y)$ are much smaller than either $a$ or $b$ respectively.  As a result finding the $2n + 1$ relations required 
by multiplying $f(y)g(y)$ involves multiplying integers that are much smaller than either of the inputs.

When picking points to gather relations there are always three obvious points to choose, $y = 0, 1$ and $ \infty$.  The $\zeta_0$ term
is simply the product $W(0) = w_0 = a_0 \cdot b_0$.  The $\zeta_1$ term is the product 
$W(1) = \left (\sum_{i = 0}^{n} a_i \right ) \left (\sum_{i = 0}^{n} b_i \right )$.  The third point $\zeta_{\infty}$ is less obvious but rather
simple to explain.  The $2n + 1$'th coefficient of $W(x)$ is numerically equivalent to the most significant column in an integer multiplication.  
The point at $\infty$ is used symbolically to represent the most significant column, that is $W(\infty) = w_{2n} = a_nb_n$.  Note that the 
points at $y = 0$ and $\infty$ yield the coefficients $w_0$ and $w_{2n}$ directly.

If more points are required they should be of small values and powers of two such as $2^q$ and the related \textit{mirror points} 
$\left (2^q \right )^{2n}  \cdot \zeta_{2^{-q}}$ for small values of $q$.  The term ``mirror point'' stems from the fact that 
$\left (2^q \right )^{2n}  \cdot \zeta_{2^{-q}}$ can be calculated in the exact opposite fashion as $\zeta_{2^q}$.  For
example, when $n = 2$ and $q = 1$ then following two equations are equivalent to the point $\zeta_{2}$ and its mirror.

\begin{eqnarray}
\zeta_{2}                  = f(2)g(2) = (4a_2 + 2a_1 + a_0)(4b_2 + 2b_1 + b_0) \nonumber \\
16 \cdot \zeta_{1 \over 2} = 4f({1\over 2}) \cdot 4g({1 \over 2}) = (a_2 + 2a_1 + 4a_0)(b_2 + 2b_1 + 4b_0)
\end{eqnarray}

Using such points will allow the values of $f(y)$ and $g(y)$ to be independently calculated using only left shifts.  For example, when $n = 2$ the
polynomial $f(2^q)$ is equal to $2^q((2^qa_2) + a_1) + a_0$.  This technique of polynomial representation is known as Horner's method.  

As a general rule of the algorithm when the inputs are split into $n$ parts each there are $2n - 1$ multiplications.  Each multiplication is of 
multiplicands that have $n$ times fewer digits than the inputs.  The asymptotic running time of this algorithm is 
$O \left ( k^{lg_n(2n - 1)} \right )$ for $k$ digit inputs (\textit{assuming they have the same number of digits}).  Figure~\ref{fig:exponent}
summarizes the exponents for various values of $n$.

\begin{figure}
\begin{center}
\begin{tabular}{|c|c|c|}
\hline \textbf{Split into $n$ Parts} & \textbf{Exponent}  & \textbf{Notes}\\
\hline $2$ & $1.584962501$ & This is Karatsuba Multiplication. \\
\hline $3$ & $1.464973520$ & This is Toom-Cook Multiplication. \\
\hline $4$ & $1.403677461$ &\\
\hline $5$ & $1.365212389$ &\\
\hline $10$ & $1.278753601$ &\\
\hline $100$ & $1.149426538$ &\\
\hline $1000$ & $1.100270931$ &\\
\hline $10000$ & $1.075252070$ &\\
\hline
\end{tabular}
\end{center}
\caption{Asymptotic Running Time of Polynomial Basis Multiplication}
\label{fig:exponent}
\end{figure}

At first it may seem like a good idea to choose $n = 1000$ since the exponent is approximately $1.1$.  However, the overhead
of solving for the 2001 terms of $W(x)$ will certainly consume any savings the algorithm could offer for all but exceedingly large
numbers.  

\subsubsection{Cutoff Point}
The polynomial basis multiplication algorithms all require fewer single precision multiplications than a straight Comba approach.  However, 
the algorithms incur an overhead (\textit{at the $O(n)$ work level}) since they require a system of equations to be solved.  This makes the
polynomial basis approach more costly to use with small inputs.

Let $m$ represent the number of digits in the multiplicands (\textit{assume both multiplicands have the same number of digits}).  There exists a 
point $y$ such that when $m < y$ the polynomial basis algorithms are more costly than Comba, when $m = y$ they are roughly the same cost and 
when $m > y$ the Comba methods are slower than the polynomial basis algorithms.  

The exact location of $y$ depends on several key architectural elements of the computer platform in question.

\begin{enumerate}
\item  The ratio of clock cycles for single precision multiplication versus other simpler operations such as addition, shifting, etc.  For example
on the AMD Athlon the ratio is roughly $17 : 1$ while on the Intel P4 it is $29 : 1$.  The higher the ratio in favour of multiplication the lower
the cutoff point $y$ will be.  

\item  The complexity of the linear system of equations (\textit{for the coefficients of $W(x)$}) is.  Generally speaking as the number of splits
grows the complexity grows substantially.  Ideally solving the system will only involve addition, subtraction and shifting of integers.  This
directly reflects on the ratio previous mentioned.

\item  To a lesser extent memory bandwidth and function call overheads.  Provided the values are in the processor cache this is less of an
influence over the cutoff point.

\end{enumerate}

A clean cutoff point separation occurs when a point $y$ is found such that all of the cutoff point conditions are met.  For example, if the point
is too low then there will be values of $m$ such that $m > y$ and the Comba method is still faster.  Finding the cutoff points is fairly simple when
a high resolution timer is available.  

\subsection{Karatsuba Multiplication}
Karatsuba \cite{KARA} multiplication when originally proposed in 1962 was among the first set of algorithms to break the $O(n^2)$ barrier for
general purpose multiplication.  Given two polynomial basis representations $f(x) = ax + b$ and $g(x) = cx + d$, Karatsuba proved with 
light algebra \cite{KARAP} that the following polynomial is equivalent to multiplication of the two integers the polynomials represent.

\begin{equation}
f(x) \cdot g(x) = acx^2 + ((a + b)(c + d) - (ac + bd))x + bd
\end{equation}

Using the observation that $ac$ and $bd$ could be re-used only three half sized multiplications would be required to produce the product.  Applying
this algorithm recursively, the work factor becomes $O(n^{lg(3)})$ which is substantially better than the work factor $O(n^2)$ of the Comba technique.  It turns 
out what Karatsuba did not know or at least did not publish was that this is simply polynomial basis multiplication with the points 
$\zeta_0$, $\zeta_{\infty}$ and $\zeta_{1}$.  Consider the resultant system of equations.

\begin{center}
\begin{tabular}{rcrcrcrc}
$\zeta_{0}$ &      $=$ &  &  &  & & $w_0$ \\
$\zeta_{1}$ &      $=$ & $w_2$ & $+$ & $w_1$ & $+$ & $w_0$ \\
$\zeta_{\infty}$ & $=$ & $w_2$ &  & &  & \\
\end{tabular}
\end{center}

By adding the first and last equation to the equation in the middle the term $w_1$ can be isolated and all three coefficients solved for.  The simplicity
of this system of equations has made Karatsuba fairly popular.  In fact the cutoff point is often fairly low\footnote{With LibTomMath 0.18 it is 70 and 109 digits for the Intel P4 and AMD Athlon respectively.}
making it an ideal algorithm to speed up certain public key cryptosystems such as RSA and Diffie-Hellman.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_karatsuba\_mul}. \\
\textbf{Input}.   mp\_int $a$ and mp\_int $b$ \\
\textbf{Output}.  $c \leftarrow \vert a \vert \cdot \vert b \vert$ \\
\hline \\
1.  Init the following mp\_int variables: $x0$, $x1$, $y0$, $y1$, $t1$, $x0y0$, $x1y1$.\\
2.  If step 2 failed then return(\textit{MP\_MEM}). \\
\\
Split the input.  e.g. $a = x1 \cdot \beta^B + x0$ \\
3.  $B \leftarrow \mbox{min}(a.used, b.used)/2$ \\
4.  $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\
5.  $y0 \leftarrow b \mbox{ (mod }\beta^B\mbox{)}$ \\
6.  $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_rshd}) \\
7.  $y1 \leftarrow \lfloor b / \beta^B \rfloor$ \\
\\
Calculate the three products. \\
8.  $x0y0 \leftarrow x0 \cdot y0$ (\textit{mp\_mul}) \\
9.  $x1y1 \leftarrow x1 \cdot y1$ \\
10.  $t1 \leftarrow x1 + x0$ (\textit{mp\_add}) \\
11.  $x0 \leftarrow y1 + y0$ \\
12.  $t1 \leftarrow t1 \cdot x0$ \\
\\
Calculate the middle term. \\
13.  $x0 \leftarrow x0y0 + x1y1$ \\
14.  $t1 \leftarrow t1 - x0$ (\textit{s\_mp\_sub}) \\
\\
Calculate the final product. \\
15.  $t1 \leftarrow t1 \cdot \beta^B$ (\textit{mp\_lshd}) \\
16.  $x1y1 \leftarrow x1y1 \cdot \beta^{2B}$ \\
17.  $t1 \leftarrow x0y0 + t1$ \\
18.  $c \leftarrow t1 + x1y1$ \\
19.  Clear all of the temporary variables. \\
20.  Return(\textit{MP\_OKAY}).\\
\hline 
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_karatsuba\_mul}
\end{figure}

\textbf{Algorithm mp\_karatsuba\_mul.}
This algorithm computes the unsigned product of two inputs using the Karatsuba multiplication algorithm.  It is loosely based on the description
from Knuth \cite[pp. 294-295]{TAOCPV2}.  

\index{radix point}
In order to split the two inputs into their respective halves, a suitable \textit{radix point} must be chosen.  The radix point chosen must
be used for both of the inputs meaning that it must be smaller than the smallest input.  Step 3 chooses the radix point $B$ as half of the 
smallest input \textbf{used} count.  After the radix point is chosen the inputs are split into lower and upper halves.  Step 4 and 5 
compute the lower halves.  Step 6 and 7 computer the upper halves.  

After the halves have been computed the three intermediate half-size products must be computed.  Step 8 and 9 compute the trivial products
$x0 \cdot y0$ and $x1 \cdot y1$.  The mp\_int $x0$ is used as a temporary variable after $x1 + x0$ has been computed.  By using $x0$ instead
of an additional temporary variable, the algorithm can avoid an addition memory allocation operation.

The remaining steps 13 through 18 compute the Karatsuba polynomial through a variety of digit shifting and addition operations.

EXAM,bn_mp_karatsuba_mul.c

The new coding element in this routine, not  seen in previous routines, is the usage of goto statements.  The conventional
wisdom is that goto statements should be avoided.  This is generally true, however when every single function call can fail, it makes sense
to handle error recovery with a single piece of code.  Lines @61,if@ to @75,if@ handle initializing all of the temporary variables 
required.  Note how each of the if statements goes to a different label in case of failure.  This allows the routine to correctly free only
the temporaries that have been successfully allocated so far.

The temporary variables are all initialized using the mp\_init\_size routine since they are expected to be large.  This saves the 
additional reallocation that would have been necessary.  Also $x0$, $x1$, $y0$ and $y1$ have to be able to hold at least their respective
number of digits for the next section of code.

The first algebraic portion of the algorithm is to split the two inputs into their halves.  However, instead of using mp\_mod\_2d and mp\_rshd
to extract the halves, the respective code has been placed inline within the body of the function.  To initialize the halves, the \textbf{used} and 
\textbf{sign} members are copied first.  The first for loop on line @98,for@ copies the lower halves.  Since they are both the same magnitude it 
is simpler to calculate both lower halves in a single loop.  The for loop on lines @104,for@ and @109,for@ calculate the upper halves $x1$ and 
$y1$ respectively.

By inlining the calculation of the halves, the Karatsuba multiplier has a slightly lower overhead and can be used for smaller magnitude inputs.

When line @152,err@ is reached, the algorithm has completed succesfully.  The ``error status'' variable $err$ is set to \textbf{MP\_OKAY} so that
the same code that handles errors can be used to clear the temporary variables and return.  

\subsection{Toom-Cook $3$-Way Multiplication}
Toom-Cook $3$-Way \cite{TOOM} multiplication is essentially the polynomial basis algorithm for $n = 2$ except that the points  are 
chosen such that $\zeta$ is easy to compute and the resulting system of equations easy to reduce.  Here, the points $\zeta_{0}$, 
$16 \cdot \zeta_{1 \over 2}$, $\zeta_1$, $\zeta_2$ and $\zeta_{\infty}$ make up the five required points to solve for the coefficients 
of the $W(x)$.

With the five relations that Toom-Cook specifies, the following system of equations is formed.

\begin{center}
\begin{tabular}{rcrcrcrcrcr}
$\zeta_0$                    & $=$ & $0w_4$ & $+$ & $0w_3$ & $+$ & $0w_2$ & $+$ & $0w_1$ & $+$ & $1w_0$  \\
$16 \cdot \zeta_{1 \over 2}$ & $=$ & $1w_4$ & $+$ & $2w_3$ & $+$ & $4w_2$ & $+$ & $8w_1$ & $+$ & $16w_0$  \\
$\zeta_1$                    & $=$ & $1w_4$ & $+$ & $1w_3$ & $+$ & $1w_2$ & $+$ & $1w_1$ & $+$ & $1w_0$  \\
$\zeta_2$                    & $=$ & $16w_4$ & $+$ & $8w_3$ & $+$ & $4w_2$ & $+$ & $2w_1$ & $+$ & $1w_0$  \\
$\zeta_{\infty}$             & $=$ & $1w_4$ & $+$ & $0w_3$ & $+$ & $0w_2$ & $+$ & $0w_1$ & $+$ & $0w_0$  \\
\end{tabular}
\end{center}

A trivial solution to this matrix requires $12$ subtractions, two multiplications by a small power of two, two divisions by a small power
of two, two divisions by three and one multiplication by three.  All of these $19$ sub-operations require less than quadratic time, meaning that
the algorithm can be faster than a baseline multiplication.  However, the greater complexity of this algorithm places the cutoff point
(\textbf{TOOM\_MUL\_CUTOFF}) where Toom-Cook becomes more efficient much higher than the Karatsuba cutoff point.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_toom\_mul}. \\
\textbf{Input}.   mp\_int $a$ and mp\_int $b$ \\
\textbf{Output}.  $c \leftarrow  a  \cdot  b $ \\
\hline \\
Split $a$ and $b$ into three pieces.  E.g. $a = a_2 \beta^{2k} + a_1 \beta^{k} + a_0$ \\
1.  $k \leftarrow \lfloor \mbox{min}(a.used, b.used) / 3 \rfloor$ \\
2.  $a_0 \leftarrow a \mbox{ (mod }\beta^{k}\mbox{)}$ \\
3.  $a_1 \leftarrow \lfloor a / \beta^k \rfloor$, $a_1 \leftarrow a_1 \mbox{ (mod }\beta^{k}\mbox{)}$ \\
4.  $a_2 \leftarrow \lfloor a / \beta^{2k} \rfloor$, $a_2 \leftarrow a_2 \mbox{ (mod }\beta^{k}\mbox{)}$ \\
5.  $b_0 \leftarrow a \mbox{ (mod }\beta^{k}\mbox{)}$ \\
6.  $b_1 \leftarrow \lfloor a / \beta^k \rfloor$, $b_1 \leftarrow b_1 \mbox{ (mod }\beta^{k}\mbox{)}$ \\
7.  $b_2 \leftarrow \lfloor a / \beta^{2k} \rfloor$, $b_2 \leftarrow b_2 \mbox{ (mod }\beta^{k}\mbox{)}$ \\
\\
Find the five equations for $w_0, w_1, ..., w_4$. \\
8.  $w_0 \leftarrow a_0 \cdot b_0$ \\
9.  $w_4 \leftarrow a_2 \cdot b_2$ \\
10. $tmp_1 \leftarrow 2 \cdot a_0$, $tmp_1 \leftarrow a_1 + tmp_1$, $tmp_1 \leftarrow 2 \cdot tmp_1$, $tmp_1 \leftarrow tmp_1 + a_2$ \\
11. $tmp_2 \leftarrow 2 \cdot b_0$, $tmp_2 \leftarrow b_1 + tmp_2$, $tmp_2 \leftarrow 2 \cdot tmp_2$, $tmp_2 \leftarrow tmp_2 + b_2$ \\
12. $w_1 \leftarrow tmp_1 \cdot tmp_2$ \\
13. $tmp_1 \leftarrow 2 \cdot a_2$, $tmp_1 \leftarrow a_1 + tmp_1$, $tmp_1 \leftarrow 2 \cdot tmp_1$, $tmp_1 \leftarrow tmp_1 + a_0$ \\
14. $tmp_2 \leftarrow 2 \cdot b_2$, $tmp_2 \leftarrow b_1 + tmp_2$, $tmp_2 \leftarrow 2 \cdot tmp_2$, $tmp_2 \leftarrow tmp_2 + b_0$ \\
15. $w_3 \leftarrow tmp_1 \cdot tmp_2$ \\
16. $tmp_1 \leftarrow a_0 + a_1$, $tmp_1 \leftarrow tmp_1 + a_2$, $tmp_2 \leftarrow b_0 + b_1$, $tmp_2 \leftarrow tmp_2 + b_2$ \\
17. $w_2 \leftarrow tmp_1 \cdot tmp_2$ \\
\\
Continued on the next page.\\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_toom\_mul}
\end{figure}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_toom\_mul} (continued). \\
\textbf{Input}.   mp\_int $a$ and mp\_int $b$ \\
\textbf{Output}.  $c \leftarrow a \cdot  b $ \\
\hline \\
Now solve the system of equations. \\
18. $w_1 \leftarrow w_4 - w_1$, $w_3 \leftarrow w_3 - w_0$ \\
19. $w_1 \leftarrow \lfloor w_1 / 2 \rfloor$, $w_3 \leftarrow \lfloor w_3 / 2 \rfloor$ \\
20. $w_2 \leftarrow w_2 - w_0$, $w_2 \leftarrow w_2 - w_4$ \\
21. $w_1 \leftarrow w_1 - w_2$, $w_3 \leftarrow w_3 - w_2$ \\
22. $tmp_1 \leftarrow 8 \cdot w_0$, $w_1 \leftarrow w_1 - tmp_1$, $tmp_1 \leftarrow 8 \cdot w_4$, $w_3 \leftarrow w_3 - tmp_1$ \\
23. $w_2 \leftarrow 3 \cdot w_2$, $w_2 \leftarrow w_2 - w_1$, $w_2 \leftarrow w_2 - w_3$ \\
24. $w_1 \leftarrow w_1 - w_2$, $w_3 \leftarrow w_3 - w_2$ \\
25. $w_1 \leftarrow \lfloor w_1 / 3 \rfloor, w_3 \leftarrow \lfloor w_3 / 3 \rfloor$ \\
\\
Now substitute $\beta^k$ for $x$ by shifting $w_0, w_1, ..., w_4$. \\
26. for $n$ from $1$ to $4$ do \\
\hspace{3mm}26.1  $w_n \leftarrow w_n \cdot \beta^{nk}$ \\
27. $c \leftarrow w_0 + w_1$, $c \leftarrow c + w_2$, $c \leftarrow c + w_3$, $c \leftarrow c + w_4$ \\
28. Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_toom\_mul (continued)}
\end{figure}

\textbf{Algorithm mp\_toom\_mul.}
This algorithm computes the product of two mp\_int variables $a$ and $b$ using the Toom-Cook approach.  Compared to the Karatsuba multiplication, this 
algorithm has a lower asymptotic running time of approximately $O(n^{1.464})$ but at an obvious cost in overhead.  In this
description, several statements have been compounded to save space.  The intention is that the statements are executed from left to right across
any given step.

The two inputs $a$ and $b$ are first split into three $k$-digit integers $a_0, a_1, a_2$ and $b_0, b_1, b_2$ respectively.  From these smaller
integers the coefficients of the polynomial basis representations $f(x)$ and $g(x)$ are known and can be used to find the relations required.

The first two relations $w_0$ and $w_4$ are the points $\zeta_{0}$ and $\zeta_{\infty}$ respectively.  The relation $w_1, w_2$ and $w_3$ correspond
to the points $16 \cdot \zeta_{1 \over 2}, \zeta_{2}$ and $\zeta_{1}$ respectively.  These are found using logical shifts to independently find
$f(y)$ and $g(y)$ which significantly speeds up the algorithm.

After the five relations $w_0, w_1, \ldots, w_4$ have been computed, the system they represent must be solved in order for the unknown coefficients 
$w_1, w_2$ and $w_3$ to be isolated.  The steps 18 through 25 perform the system reduction required as previously described.  Each step of
the reduction represents the comparable matrix operation that would be performed had this been performed by pencil.  For example, step 18 indicates
that row $1$ must be subtracted from row $4$ and simultaneously row $0$ subtracted from row $3$.  

Once the coeffients have been isolated, the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$ is known.  By substituting $\beta^{k}$ for $x$, the integer 
result $a \cdot b$ is produced.

EXAM,bn_mp_toom_mul.c

The first obvious thing to note is that this algorithm is complicated.  The complexity is worth it if you are multiplying very 
large numbers.  For example, a 10,000 digit multiplication takes approximaly 99,282,205 fewer single precision multiplications with
Toom--Cook than a Comba or baseline approach (this is a savings of more than 99$\%$).  For most ``crypto'' sized numbers this
algorithm is not practical as Karatsuba has a much lower cutoff point.

First we split $a$ and $b$ into three roughly equal portions.  This has been accomplished (lines @40,mod@ to @69,rshd@) with 
combinations of mp\_rshd() and mp\_mod\_2d() function calls.  At this point $a = a2 \cdot \beta^2 + a1 \cdot \beta + a0$ and similiarly
for $b$.  

Next we compute the five points $w0, w1, w2, w3$ and $w4$.  Recall that $w0$ and $w4$ can be computed directly from the portions so
we get those out of the way first (lines @72,mul@ and @77,mul@).  Next we compute $w1, w2$ and $w3$ using Horners method.

After this point we solve for the actual values of $w1, w2$ and $w3$ by reducing the $5 \times 5$ system which is relatively
straight forward.  

\subsection{Signed Multiplication}
Now that algorithms to handle multiplications of every useful dimensions have been developed, a rather simple finishing touch is required.  So far all
of the multiplication algorithms have been unsigned multiplications which leaves only a signed multiplication algorithm to be established.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_mul}. \\
\textbf{Input}.   mp\_int $a$ and mp\_int $b$ \\
\textbf{Output}.  $c \leftarrow a \cdot b$ \\
\hline \\
1.  If $a.sign = b.sign$ then \\
\hspace{3mm}1.1  $sign = MP\_ZPOS$ \\
2.  else \\
\hspace{3mm}2.1  $sign = MP\_ZNEG$ \\
3.  If min$(a.used, b.used) \ge TOOM\_MUL\_CUTOFF$ then  \\
\hspace{3mm}3.1  $c \leftarrow a \cdot b$ using algorithm mp\_toom\_mul \\
4.  else if min$(a.used, b.used) \ge KARATSUBA\_MUL\_CUTOFF$ then \\
\hspace{3mm}4.1  $c \leftarrow a \cdot b$ using algorithm mp\_karatsuba\_mul \\
5.  else \\
\hspace{3mm}5.1  $digs \leftarrow a.used + b.used + 1$ \\
\hspace{3mm}5.2  If $digs < MP\_ARRAY$ and min$(a.used, b.used) \le \delta$ then \\
\hspace{6mm}5.2.1  $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm fast\_s\_mp\_mul\_digs.  \\
\hspace{3mm}5.3  else \\
\hspace{6mm}5.3.1  $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm s\_mp\_mul\_digs.  \\
6.  $c.sign \leftarrow sign$ \\
7.  Return the result of the unsigned multiplication performed. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_mul}
\end{figure}

\textbf{Algorithm mp\_mul.}
This algorithm performs the signed multiplication of two inputs.  It will make use of any of the three unsigned multiplication algorithms 
available when the input is of appropriate size.  The \textbf{sign} of the result is not set until the end of the algorithm since algorithm
s\_mp\_mul\_digs will clear it.  

EXAM,bn_mp_mul.c

The implementation is rather simplistic and is not particularly noteworthy.  Line @22,?@ computes the sign of the result using the ``?'' 
operator from the C programming language.  Line @37,<<@ computes $\delta$ using the fact that $1 << k$ is equal to $2^k$.  

\section{Squaring}
\label{sec:basesquare}

Squaring is a special case of multiplication where both multiplicands are equal.  At first it may seem like there is no significant optimization
available but in fact there is.  Consider the multiplication of $576$ against $241$.  In total there will be nine single precision multiplications
performed which are $1\cdot 6$, $1 \cdot 7$, $1 \cdot 5$, $4 \cdot 6$, $4 \cdot 7$, $4 \cdot 5$, $2 \cdot  6$, $2 \cdot 7$ and $2 \cdot 5$.  Now consider 
the multiplication of $123$ against $123$.  The nine products are $3 \cdot 3$, $3 \cdot 2$, $3 \cdot 1$, $2 \cdot 3$, $2 \cdot 2$, $2 \cdot 1$, 
$1 \cdot 3$, $1 \cdot 2$ and $1 \cdot 1$.  On closer inspection some of the products are equivalent.  For example, $3 \cdot 2 = 2 \cdot 3$ 
and $3 \cdot 1 = 1 \cdot 3$. 

For any $n$-digit input, there are ${{\left (n^2 + n \right)}\over 2}$ possible unique single precision multiplications required compared to the $n^2$
required for multiplication.  The following diagram gives an example of the operations required.

\begin{figure}[here]
\begin{center}
\begin{tabular}{ccccc|c}
&&1&2&3&\\
$\times$ &&1&2&3&\\
\hline && $3 \cdot 1$ & $3 \cdot 2$ & $3 \cdot 3$ & Row 0\\
       & $2 \cdot 1$  & $2 \cdot 2$ & $2 \cdot 3$ && Row 1 \\
         $1 \cdot 1$  & $1 \cdot 2$ & $1 \cdot 3$ &&& Row 2 \\
\end{tabular}
\end{center}
\caption{Squaring Optimization Diagram}
\end{figure}

MARK,SQUARE
Starting from zero and numbering the columns from right to left a very simple pattern becomes obvious.  For the purposes of this discussion let $x$
represent the number being squared.  The first observation is that in row $k$ the $2k$'th column of the product has a $\left (x_k \right)^2$ term in it.  

The second observation is that every column $j$ in row $k$ where $j \ne 2k$ is part of a double product.  Every non-square term of a column will
appear twice hence the name ``double product''.  Every odd column is made up entirely of double products.  In fact every column is made up of double 
products and at most one square (\textit{see the exercise section}).  

The third and final observation is that for row $k$ the first unique non-square term, that is, one that hasn't already appeared in an earlier row, 
occurs at column $2k + 1$.  For example, on row $1$ of the previous squaring, column one is part of the double product with column one from row zero. 
Column two of row one is a square and column three is the first unique column.

\subsection{The Baseline Squaring Algorithm}
The baseline squaring algorithm is meant to be a catch-all squaring algorithm.  It will handle any of the input sizes that the faster routines
will not handle.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{s\_mp\_sqr}. \\
\textbf{Input}.   mp\_int $a$ \\
\textbf{Output}.  $b \leftarrow a^2$ \\
\hline \\
1.  Init a temporary mp\_int of at least $2 \cdot a.used +1$ digits.  (\textit{mp\_init\_size}) \\
2.  If step 1 failed return(\textit{MP\_MEM}) \\
3.  $t.used \leftarrow 2 \cdot a.used + 1$ \\
4.  For $ix$ from 0 to $a.used - 1$ do \\
\hspace{3mm}Calculate the square. \\
\hspace{3mm}4.1  $\hat r \leftarrow t_{2ix} + \left (a_{ix} \right )^2$ \\
\hspace{3mm}4.2  $t_{2ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}Calculate the double products after the square. \\
\hspace{3mm}4.3  $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\
\hspace{3mm}4.4  For $iy$ from $ix + 1$ to $a.used - 1$ do \\
\hspace{6mm}4.4.1  $\hat r \leftarrow 2 \cdot a_{ix}a_{iy} + t_{ix + iy} + u$ \\
\hspace{6mm}4.4.2  $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{6mm}4.4.3  $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\
\hspace{3mm}Set the last carry. \\
\hspace{3mm}4.5  While $u > 0$ do \\
\hspace{6mm}4.5.1  $iy \leftarrow iy + 1$ \\
\hspace{6mm}4.5.2  $\hat r \leftarrow t_{ix + iy} + u$ \\
\hspace{6mm}4.5.3  $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{6mm}4.5.4  $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\
5.  Clamp excess digits of $t$.  (\textit{mp\_clamp}) \\
6.  Exchange $b$ and $t$. \\
7.  Clear $t$ (\textit{mp\_clear}) \\
8.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm s\_mp\_sqr}
\end{figure}

\textbf{Algorithm s\_mp\_sqr.}
This algorithm computes the square of an input using the three observations on squaring.  It is based fairly faithfully on  algorithm 14.16 of HAC
\cite[pp.596-597]{HAC}.  Similar to algorithm s\_mp\_mul\_digs, a temporary mp\_int is allocated to hold the result of the squaring.  This allows the 
destination mp\_int to be the same as the source mp\_int.

The outer loop of this algorithm begins on step 4. It is best to think of the outer loop as walking down the rows of the partial results, while
the inner loop computes the columns of the partial result.  Step 4.1 and 4.2 compute the square term for each row, and step 4.3 and 4.4 propagate
the carry and compute the double products.  

The requirement that a mp\_word be able to represent the range $0 \le x < 2 \beta^2$ arises from this
very algorithm.  The product $a_{ix}a_{iy}$ will lie in the range $0 \le x \le \beta^2 - 2\beta + 1$ which is obviously less than $\beta^2$ meaning that
when it is multiplied by two, it can be properly represented by a mp\_word.

Similar to algorithm s\_mp\_mul\_digs, after every pass of the inner loop, the destination is correctly set to the sum of all of the partial 
results calculated so far.  This involves expensive carry propagation which will be eliminated in the next algorithm.  

EXAM,bn_s_mp_sqr.c

Inside the outer loop (line @32,for@) the square term is calculated on line @35,r =@.  The carry (line @42,>>@) has been
extracted from the mp\_word accumulator using a right shift.  Aliases for $a_{ix}$ and $t_{ix+iy}$ are initialized 
(lines @45,tmpx@ and @48,tmpt@) to simplify the inner loop.  The doubling is performed using two
additions (line @57,r + r@) since it is usually faster than shifting, if not at least as fast.  

The important observation is that the inner loop does not begin at $iy = 0$ like for multiplication.  As such the inner loops
get progressively shorter as the algorithm proceeds.  This is what leads to the savings compared to using a multiplication to
square a number. 

\subsection{Faster Squaring by the ``Comba'' Method}
A major drawback to the baseline method is the requirement for single precision shifting inside the $O(n^2)$ nested loop.  Squaring has an additional
drawback that it must double the product inside the inner loop as well.  As for multiplication, the Comba technique can be used to eliminate these
performance hazards.

The first obvious solution is to make an array of mp\_words which will hold all of the columns.  This will indeed eliminate all of the carry
propagation operations from the inner loop.  However, the inner product must still be doubled $O(n^2)$ times.  The solution stems from the simple fact
that $2a + 2b + 2c = 2(a + b + c)$.  That is the sum of all of the double products is equal to double the sum of all the products.  For example,
$ab + ba + ac + ca = 2ab + 2ac = 2(ab + ac)$.  

However, we cannot simply double all of the columns, since the squares appear only once per row.  The most practical solution is to have two 
mp\_word arrays.  One array will hold the squares and the other array will hold the double products.  With both arrays the doubling and 
carry propagation can be moved to a $O(n)$ work level outside the $O(n^2)$ level.  In this case, we have an even simpler solution in mind.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{fast\_s\_mp\_sqr}. \\
\textbf{Input}.   mp\_int $a$ \\
\textbf{Output}.  $b \leftarrow a^2$ \\
\hline \\
Place an array of \textbf{MP\_WARRAY} mp\_digits named $W$ on the stack. \\
1.  If $b.alloc < 2a.used + 1$ then grow $b$ to $2a.used + 1$ digits.  (\textit{mp\_grow}). \\
2.  If step 1 failed return(\textit{MP\_MEM}). \\
\\
3.  $pa \leftarrow 2 \cdot a.used$ \\
4.  $\hat W1 \leftarrow 0$ \\
5.  for $ix$ from $0$ to $pa - 1$ do \\
\hspace{3mm}5.1  $\_ \hat W \leftarrow 0$ \\
\hspace{3mm}5.2  $ty \leftarrow \mbox{MIN}(a.used - 1, ix)$ \\
\hspace{3mm}5.3  $tx \leftarrow ix - ty$ \\
\hspace{3mm}5.4  $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\
\hspace{3mm}5.5  $iy \leftarrow \mbox{MIN}(iy, \lfloor \left (ty - tx + 1 \right )/2 \rfloor)$ \\
\hspace{3mm}5.6  for $iz$ from $0$ to $iz - 1$ do \\
\hspace{6mm}5.6.1  $\_ \hat W \leftarrow \_ \hat W + a_{tx + iz}a_{ty - iz}$ \\
\hspace{3mm}5.7  $\_ \hat W \leftarrow 2 \cdot \_ \hat W  + \hat W1$ \\
\hspace{3mm}5.8  if $ix$ is even then \\
\hspace{6mm}5.8.1  $\_ \hat W \leftarrow \_ \hat W + \left ( a_{\lfloor ix/2 \rfloor}\right )^2$ \\
\hspace{3mm}5.9  $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\
\hspace{3mm}5.10  $\hat W1 \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\
\\
6.  $oldused \leftarrow b.used$ \\
7.  $b.used \leftarrow 2 \cdot a.used$ \\
8.  for $ix$ from $0$ to $pa - 1$ do \\
\hspace{3mm}8.1  $b_{ix} \leftarrow W_{ix}$ \\
9.  for $ix$ from $pa$ to $oldused - 1$ do \\
\hspace{3mm}9.1  $b_{ix} \leftarrow 0$ \\
10.  Clamp excess digits from $b$.  (\textit{mp\_clamp}) \\
11.  Return(\textit{MP\_OKAY}). \\ 
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm fast\_s\_mp\_sqr}
\end{figure}

\textbf{Algorithm fast\_s\_mp\_sqr.}
This algorithm computes the square of an input using the Comba technique.  It is designed to be a replacement for algorithm 
s\_mp\_sqr when the number of input digits is less than \textbf{MP\_WARRAY} and less than $\delta \over 2$.  
This algorithm is very similar to the Comba multiplier except with a few key differences we shall make note of.

First, we have an accumulator and carry variables $\_ \hat W$ and $\hat W1$ respectively.  This is because the inner loop
products are to be doubled.  If we had added the previous carry in we would be doubling too much.  Next we perform an
addition MIN condition on $iy$ (step 5.5) to prevent overlapping digits.  For example, $a_3 \cdot a_5$ is equal
$a_5 \cdot a_3$.  Whereas in the multiplication case we would have $5 < a.used$ and $3 \ge 0$ is maintained since we double the sum
of the products just outside the inner loop we have to avoid doing this.  This is also a good thing since we perform
fewer multiplications and the routine ends up being faster.

Finally the last difference is the addition of the ``square'' term outside the inner loop (step 5.8).  We add in the square
only to even outputs and it is the square of the term at the $\lfloor ix / 2 \rfloor$ position.

EXAM,bn_fast_s_mp_sqr.c

This implementation is essentially a copy of Comba multiplication with the appropriate changes added to make it faster for 
the special case of squaring.  

\subsection{Polynomial Basis Squaring}
The same algorithm that performs optimal polynomial basis multiplication can be used to perform polynomial basis squaring.  The minor exception
is that $\zeta_y = f(y)g(y)$ is actually equivalent to $\zeta_y = f(y)^2$ since $f(y) = g(y)$.  Instead of performing $2n + 1$
multiplications to find the $\zeta$ relations, squaring operations are performed instead.  

\subsection{Karatsuba Squaring}
Let $f(x) = ax + b$ represent the polynomial basis representation of a number to square.  
Let $h(x) = \left ( f(x) \right )^2$ represent the square of the polynomial.  The Karatsuba equation can be modified to square a 
number with the following equation.

\begin{equation}
h(x) = a^2x^2 + \left ((a + b)^2 - (a^2 + b^2) \right )x + b^2
\end{equation}

Upon closer inspection this equation only requires the calculation of three half-sized squares: $a^2$, $b^2$ and $(a + b)^2$.  As in 
Karatsuba multiplication, this algorithm can be applied recursively on the input and will achieve an asymptotic running time of 
$O \left ( n^{lg(3)} \right )$.

If the asymptotic times of Karatsuba squaring and multiplication are the same, why not simply use the multiplication algorithm 
instead?  The answer to this arises from the cutoff point for squaring.  As in multiplication there exists a cutoff point, at which the 
time required for a Comba based squaring and a Karatsuba based squaring meet.  Due to the overhead inherent in the Karatsuba method, the cutoff 
point is fairly high.  For example, on an AMD Athlon XP processor with $\beta = 2^{28}$, the cutoff point is around 127 digits.  

Consider squaring a 200 digit number with this technique.  It will be split into two 100 digit halves which are subsequently squared.  
The 100 digit halves will not be squared using Karatsuba, but instead using the faster Comba based squaring algorithm.  If Karatsuba multiplication
were used instead, the 100 digit numbers would be squared with a slower Comba based multiplication.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_karatsuba\_sqr}. \\
\textbf{Input}.   mp\_int $a$ \\
\textbf{Output}.  $b \leftarrow a^2$ \\
\hline \\
1.  Initialize the following temporary mp\_ints:  $x0$, $x1$, $t1$, $t2$, $x0x0$ and $x1x1$. \\
2.  If any of the initializations on step 1 failed return(\textit{MP\_MEM}). \\
\\
Split the input.  e.g. $a = x1\beta^B + x0$ \\
3.  $B \leftarrow \lfloor a.used / 2 \rfloor$ \\
4.  $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\
5.  $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_lshd}) \\
\\
Calculate the three squares. \\
6.  $x0x0 \leftarrow x0^2$ (\textit{mp\_sqr}) \\
7.  $x1x1 \leftarrow x1^2$ \\
8.  $t1 \leftarrow x1 + x0$ (\textit{s\_mp\_add}) \\
9.  $t1 \leftarrow t1^2$ \\
\\
Compute the middle term. \\
10.  $t2 \leftarrow x0x0 + x1x1$ (\textit{s\_mp\_add}) \\
11.  $t1 \leftarrow t1 - t2$ \\
\\
Compute final product. \\
12.  $t1 \leftarrow t1\beta^B$ (\textit{mp\_lshd}) \\
13.  $x1x1 \leftarrow x1x1\beta^{2B}$ \\
14.  $t1 \leftarrow t1 + x0x0$ \\
15.  $b \leftarrow t1 + x1x1$ \\
16.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_karatsuba\_sqr}
\end{figure}

\textbf{Algorithm mp\_karatsuba\_sqr.}
This algorithm computes the square of an input $a$ using the Karatsuba technique.  This algorithm is very similar to the Karatsuba based
multiplication algorithm with the exception that the three half-size multiplications have been replaced with three half-size squarings.

The radix point for squaring is simply placed exactly in the middle of the digits when the input has an odd number of digits, otherwise it is
placed just below the middle.  Step 3, 4 and 5 compute the two halves required using $B$
as the radix point.  The first two squares in steps 6 and 7 are rather straightforward while the last square is of a more compact form.

By expanding $\left (x1 + x0 \right )^2$, the $x1^2$ and $x0^2$ terms in the middle disappear, that is $(x0 - x1)^2 - (x1^2 + x0^2)  = 2 \cdot x0 \cdot x1$.
Now if $5n$ single precision additions and a squaring of $n$-digits is faster than multiplying two $n$-digit numbers and doubling then
this method is faster.  Assuming no further recursions occur, the difference can be estimated with the following inequality.

Let $p$ represent the cost of a single precision addition and $q$ the cost of a single precision multiplication both in terms of time\footnote{Or
machine clock cycles.}. 

\begin{equation}
5pn +{{q(n^2 + n)} \over 2} \le pn + qn^2
\end{equation}

For example, on an AMD Athlon XP processor $p = {1 \over 3}$ and $q = 6$.  This implies that the following inequality should hold.
\begin{center}
\begin{tabular}{rcl}
${5n \over 3} + 3n^2 + 3n$     & $<$ & ${n \over 3} + 6n^2$ \\
${5 \over 3} + 3n + 3$     & $<$ & ${1 \over 3} + 6n$ \\
${13 \over 9}$     & $<$ & $n$ \\
\end{tabular}
\end{center}

This results in a cutoff point around $n = 2$.  As a consequence it is actually faster to compute the middle term the ``long way'' on processors
where multiplication is substantially slower\footnote{On the Athlon there is a 1:17 ratio between clock cycles for addition and multiplication.  On
the Intel P4 processor this ratio is 1:29 making this method even more beneficial.  The only common exception is the ARMv4 processor which has a
ratio of 1:7.  } than simpler operations such as addition.  

EXAM,bn_mp_karatsuba_sqr.c

This implementation is largely based on the implementation of algorithm mp\_karatsuba\_mul.  It uses the same inline style to copy and 
shift the input into the two halves.  The loop from line @54,{@ to line @70,}@ has been modified since only one input exists.  The \textbf{used}
count of both $x0$ and $x1$ is fixed up and $x0$ is clamped before the calculations begin.  At this point $x1$ and $x0$ are valid equivalents
to the respective halves as if mp\_rshd and mp\_mod\_2d had been used.  

By inlining the copy and shift operations the cutoff point for Karatsuba multiplication can be lowered.  On the Athlon the cutoff point
is exactly at the point where Comba squaring can no longer be used (\textit{128 digits}).  On slower processors such as the Intel P4
it is actually below the Comba limit (\textit{at 110 digits}).

This routine uses the same error trap coding style as mp\_karatsuba\_sqr.  As the temporary variables are initialized errors are 
redirected to the error trap higher up.  If the algorithm completes without error the error code is set to \textbf{MP\_OKAY} and 
mp\_clears are executed normally.

\subsection{Toom-Cook Squaring}
The Toom-Cook squaring algorithm mp\_toom\_sqr is heavily based on the algorithm mp\_toom\_mul with the exception that squarings are used
instead of multiplication to find the five relations.  The reader is encouraged to read the description of the latter algorithm and try to 
derive their own Toom-Cook squaring algorithm.  

\subsection{High Level Squaring}
\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_sqr}. \\
\textbf{Input}.   mp\_int $a$ \\
\textbf{Output}.  $b \leftarrow a^2$ \\
\hline \\
1.  If $a.used \ge TOOM\_SQR\_CUTOFF$ then  \\
\hspace{3mm}1.1  $b \leftarrow a^2$ using algorithm mp\_toom\_sqr \\
2.  else if $a.used \ge KARATSUBA\_SQR\_CUTOFF$ then \\
\hspace{3mm}2.1  $b \leftarrow a^2$ using algorithm mp\_karatsuba\_sqr \\
3.  else \\
\hspace{3mm}3.1  $digs \leftarrow a.used + b.used + 1$ \\
\hspace{3mm}3.2  If $digs < MP\_ARRAY$ and $a.used \le \delta$ then \\
\hspace{6mm}3.2.1  $b \leftarrow a^2$ using algorithm fast\_s\_mp\_sqr.  \\
\hspace{3mm}3.3  else \\
\hspace{6mm}3.3.1  $b \leftarrow a^2$ using algorithm s\_mp\_sqr.  \\
4.  $b.sign \leftarrow MP\_ZPOS$ \\
5.  Return the result of the unsigned squaring performed. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_sqr}
\end{figure}

\textbf{Algorithm mp\_sqr.}
This algorithm computes the square of the input using one of four different algorithms.  If the input is very large and has at least
\textbf{TOOM\_SQR\_CUTOFF} or \textbf{KARATSUBA\_SQR\_CUTOFF} digits then either the Toom-Cook or the Karatsuba Squaring algorithm is used.  If
neither of the polynomial basis algorithms should be used then either the Comba or baseline algorithm is used.  

EXAM,bn_mp_sqr.c

\section*{Exercises}
\begin{tabular}{cl}
$\left [ 3 \right ] $ & Devise an efficient algorithm for selection of the radix point to handle inputs \\
                      & that have different number of digits in Karatsuba multiplication. \\
                      & \\
$\left [ 2 \right ] $ & In ~SQUARE~ the fact that every column of a squaring is made up \\
                      & of double products and at most one square is stated.  Prove this statement. \\
                      & \\                      
$\left [ 3 \right ] $ & Prove the equation for Karatsuba squaring. \\
                      & \\
$\left [ 1 \right ] $ & Prove that Karatsuba squaring requires $O \left (n^{lg(3)} \right )$ time. \\
                      & \\ 
$\left [ 2 \right ] $ & Determine the minimal ratio between addition and multiplication clock cycles \\
                      & required for equation $6.7$ to be true.  \\
                      & \\
$\left [ 3 \right ] $ & Implement a threaded version of Comba multiplication (and squaring) where you \\
                      & compute subsets of the columns in each thread.  Determine a cutoff point where \\
                      & it is effective and add the logic to mp\_mul() and mp\_sqr(). \\
                      &\\
$\left [ 4 \right ] $ & Same as the previous but also modify the Karatsuba and Toom-Cook.  You must \\
                      & increase the throughput of mp\_exptmod() for random odd moduli in the range \\
                      & $512 \ldots 4096$ bits significantly ($> 2x$) to complete this challenge. \\
                      & \\
\end{tabular}

\chapter{Modular Reduction}
MARK,REDUCTION
\section{Basics of Modular Reduction}
\index{modular residue}
Modular reduction is an operation that arises quite often within public key cryptography algorithms and various number theoretic algorithms, 
such as factoring.  Modular reduction algorithms are the third class of algorithms of the ``multipliers'' set.  A number $a$ is said to be \textit{reduced}
modulo another number $b$ by finding the remainder of the division $a/b$.  Full integer division with remainder is a topic to be covered 
in~\ref{sec:division}.

Modular reduction is equivalent to solving for $r$ in the following equation.  $a = bq + r$ where $q = \lfloor a/b \rfloor$.  The result 
$r$ is said to be ``congruent to $a$ modulo $b$'' which is also written as $r \equiv a \mbox{ (mod }b\mbox{)}$.  In other vernacular $r$ is known as the 
``modular residue'' which leads to ``quadratic residue''\footnote{That's fancy talk for $b \equiv a^2 \mbox{ (mod }p\mbox{)}$.} and
other forms of residues.  

Modular reductions are normally used to create either finite groups, rings or fields.  The most common usage for performance driven modular reductions 
is in modular exponentiation algorithms.  That is to compute $d = a^b \mbox{ (mod }c\mbox{)}$ as fast as possible.  This operation is used in the 
RSA and Diffie-Hellman public key algorithms, for example.  Modular multiplication and squaring also appears as a fundamental operation in 
elliptic curve cryptographic algorithms.  As will be discussed in the subsequent chapter there exist fast algorithms for computing modular 
exponentiations without having to perform (\textit{in this example}) $b - 1$ multiplications.  These algorithms will produce partial results in the 
range $0 \le x < c^2$ which can be taken advantage of to create several efficient algorithms.   They have also been used to create redundancy check 
algorithms known as CRCs, error correction codes such as Reed-Solomon and solve a variety of number theoeretic problems.  

\section{The Barrett Reduction}
The Barrett reduction algorithm \cite{BARRETT} was inspired by fast division algorithms which multiply by the reciprocal to emulate
division.  Barretts observation was that the residue $c$ of $a$ modulo $b$ is equal to 

\begin{equation}
c = a - b \cdot \lfloor a/b \rfloor
\end{equation}

Since algorithms such as modular exponentiation would be using the same modulus extensively, typical DSP\footnote{It is worth noting that Barrett's paper 
targeted the DSP56K processor.}  intuition would indicate the next step would be to replace $a/b$ by a multiplication by the reciprocal.  However, 
DSP intuition on its own will not work as these numbers are considerably larger than the precision of common DSP floating point data types.  
It would take another common optimization to optimize the algorithm.

\subsection{Fixed Point Arithmetic}
The trick used to optimize the above equation is based on a technique of emulating floating point data types with fixed precision integers.  Fixed
point arithmetic would become very popular as it greatly optimize the ``3d-shooter'' genre of games in the mid 1990s when floating point units were 
fairly slow if not unavailable.   The idea behind fixed point arithmetic is to take a normal $k$-bit integer data type and break it into $p$-bit 
integer and a $q$-bit fraction part (\textit{where $p+q = k$}).  

In this system a $k$-bit integer $n$ would actually represent $n/2^q$.  For example, with $q = 4$ the integer $n = 37$ would actually represent the
value $2.3125$.  To multiply two fixed point numbers the integers are multiplied using traditional arithmetic and subsequently normalized by 
moving the implied decimal point back to where it should be.  For example, with $q = 4$ to multiply the integers $9$ and $5$ they must be converted 
to fixed point first by multiplying by $2^q$.  Let $a = 9(2^q)$ represent the fixed point representation of $9$ and $b = 5(2^q)$ represent the 
fixed point representation of $5$.  The product $ab$ is equal to $45(2^{2q})$ which when normalized by dividing by $2^q$ produces $45(2^q)$.  

This technique became popular since a normal integer multiplication and logical shift right are the only required operations to perform a multiplication
of two fixed point numbers.  Using fixed point arithmetic, division can be easily approximated by multiplying by the reciprocal.  If $2^q$ is 
equivalent to one than $2^q/b$ is equivalent to the fixed point approximation of $1/b$ using real arithmetic.  Using this fact dividing an integer 
$a$ by another integer $b$ can be achieved with the following expression.

\begin{equation}
\lfloor a / b \rfloor \mbox{ }\approx\mbox{ } \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor
\end{equation}

The precision of the division is proportional to the value of $q$.  If the divisor $b$ is used frequently as is the case with 
modular exponentiation pre-computing $2^q/b$ will allow a division to be performed with a multiplication and a right shift.  Both operations
are considerably faster than division on most processors.  

Consider dividing $19$ by $5$.  The correct result is $\lfloor 19/5 \rfloor = 3$.  With $q = 3$ the reciprocal is $\lfloor 2^q/5 \rfloor = 1$ which
leads to a product of $19$ which when divided by $2^q$ produces $2$.  However, with $q = 4$ the reciprocal is $\lfloor 2^q/5 \rfloor = 3$ and
the result of the emulated division is $\lfloor 3 \cdot 19 / 2^q \rfloor = 3$ which is correct.  The value of $2^q$ must be close to or ideally
larger than the dividend.  In effect if $a$ is the dividend then $q$ should allow $0 \le \lfloor a/2^q \rfloor \le 1$ in order for this approach
to work correctly.  Plugging this form of divison into the original equation the following modular residue equation arises.

\begin{equation}
c = a - b \cdot \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor
\end{equation}

Using the notation from \cite{BARRETT} the value of $\lfloor 2^q / b \rfloor$ will be represented by the $\mu$ symbol.  Using the $\mu$
variable also helps re-inforce the idea that it is meant to be computed once and re-used.

\begin{equation}
c = a - b \cdot \lfloor (a \cdot \mu)/2^q \rfloor
\end{equation}

Provided that $2^q \ge a$ this algorithm will produce a quotient that is either exactly correct or off by a value of one.  In the context of Barrett
reduction the value of $a$ is bound by $0 \le a \le (b - 1)^2$ meaning that $2^q \ge b^2$ is sufficient to ensure the reciprocal will have enough
precision.  

Let $n$ represent the number of digits in $b$.  This algorithm requires approximately $2n^2$ single precision multiplications to produce the quotient and 
another $n^2$ single precision multiplications to find the residue.  In total $3n^2$ single precision multiplications are required to 
reduce the number.  

For example, if $b = 1179677$ and $q = 41$ ($2^q > b^2$), then the reciprocal $\mu$ is equal to $\lfloor 2^q / b \rfloor = 1864089$.  Consider reducing
$a = 180388626447$ modulo $b$ using the above reduction equation.  The quotient using the new formula is $\lfloor (a \cdot \mu) / 2^q \rfloor = 152913$.
By subtracting $152913b$ from $a$ the correct residue $a \equiv 677346 \mbox{ (mod }b\mbox{)}$ is found.

\subsection{Choosing a Radix Point}
Using the fixed point representation a modular reduction can be performed with $3n^2$ single precision multiplications.  If that were the best
that could be achieved a full division\footnote{A division requires approximately $O(2cn^2)$ single precision multiplications for a small value of $c$.  
See~\ref{sec:division} for further details.} might as well be used in its place.  The key to optimizing the reduction is to reduce the precision of
the initial multiplication that finds the quotient.  

Let $a$ represent the number of which the residue is sought.  Let $b$ represent the modulus used to find the residue.  Let $m$ represent
the number of digits in $b$.  For the purposes of this discussion we will assume that the number of digits in $a$ is $2m$, which is generally true if 
two $m$-digit numbers have been multiplied.  Dividing $a$ by $b$ is the same as dividing a $2m$ digit integer by a $m$ digit integer.  Digits below the 
$m - 1$'th digit of $a$ will contribute at most a value of $1$ to the quotient because $\beta^k < b$ for any $0 \le k \le m - 1$.  Another way to
express this is by re-writing $a$ as two parts.  If $a' \equiv a \mbox{ (mod }b^m\mbox{)}$ and $a'' = a - a'$ then 
${a \over b} \equiv {{a' + a''} \over b}$ which is equivalent to ${a' \over b} + {a'' \over b}$.  Since $a'$ is bound to be less than $b$ the quotient
is bound by $0 \le {a' \over b} < 1$.

Since the digits of $a'$ do not contribute much to the quotient the observation is that they might as well be zero.  However, if the digits 
``might as well be zero'' they might as well not be there in the first place.  Let $q_0 = \lfloor a/\beta^{m-1} \rfloor$ represent the input
with the irrelevant digits trimmed.  Now the modular reduction is trimmed to the almost equivalent equation

\begin{equation}
c = a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor
\end{equation}

Note that the original divisor $2^q$ has been replaced with $\beta^{m+1}$ where in this case $q$ is a multiple of $lg(\beta)$. Also note that the 
exponent on the divisor when added to the amount $q_0$ was shifted by equals $2m$.  If the optimization had not been performed the divisor 
would have the exponent $2m$ so in the end the exponents do ``add up''. Using the above equation the quotient 
$\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ can be off from the true quotient by at most two.  The original fixed point quotient can be off
by as much as one (\textit{provided the radix point is chosen suitably}) and now that the lower irrelevent digits have been trimmed the quotient
can be off by an additional value of one for a total of at most two.  This implies that 
$0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$.  By first subtracting $b$ times the quotient and then conditionally subtracting 
$b$ once or twice the residue is found.

The quotient is now found using $(m + 1)(m) = m^2 + m$ single precision multiplications and the residue with an additional $m^2$ single
precision multiplications, ignoring the subtractions required.  In total $2m^2 + m$ single precision multiplications are required to find the residue.  
This is considerably faster than the original attempt.

For example, let $\beta = 10$ represent the radix of the digits.  Let $b = 9999$ represent the modulus which implies $m = 4$. Let $a = 99929878$ 
represent the value of which the residue is desired.  In this case $q = 8$ since $10^7 < 9999^2$ meaning that $\mu = \lfloor \beta^{q}/b \rfloor = 10001$.  
With the new observation the multiplicand for the quotient is equal to $q_0 = \lfloor a / \beta^{m - 1} \rfloor = 99929$.  The quotient is then 
$\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor = 9993$.  Subtracting $9993b$ from $a$ and the correct residue $a \equiv 9871 \mbox{ (mod }b\mbox{)}$ 
is found.  

\subsection{Trimming the Quotient}
So far the reduction algorithm has been optimized from $3m^2$ single precision multiplications down to $2m^2 + m$ single precision multiplications.  As 
it stands now the algorithm is already fairly fast compared to a full integer division algorithm.  However, there is still room for
optimization.  

After the first multiplication inside the quotient ($q_0 \cdot \mu$) the value is shifted right by $m + 1$ places effectively nullifying the lower
half of the product.  It would be nice to be able to remove those digits from the product to effectively cut down the number of single precision 
multiplications.  If the number of digits in the modulus $m$ is far less than $\beta$ a full product is not required for the algorithm to work properly.  
In fact the lower $m - 2$ digits will not affect the upper half of the product at all and do not need to be computed.  

The value of $\mu$ is a $m$-digit number and $q_0$ is a $m + 1$ digit number.  Using a full multiplier $(m + 1)(m) = m^2 + m$ single precision
multiplications would be required.  Using a multiplier that will only produce digits at and above the $m - 1$'th digit reduces the number
of single precision multiplications to ${m^2 + m} \over 2$ single precision multiplications.  

\subsection{Trimming the Residue}
After the quotient has been calculated it is used to reduce the input.  As previously noted the algorithm is not exact and it can be off by a small
multiple of the modulus, that is $0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$.  If $b$ is $m$ digits than the 
result of reduction equation is a value of at most $m + 1$ digits (\textit{provided $3 < \beta$}) implying that the upper $m - 1$ digits are
implicitly zero.  

The next optimization arises from this very fact.  Instead of computing $b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ using a full
$O(m^2)$ multiplication algorithm only the lower $m+1$ digits of the product have to be computed.  Similarly the value of $a$ can
be reduced modulo $\beta^{m+1}$ before the multiple of $b$ is subtracted which simplifes the subtraction as well.  A multiplication that produces 
only the lower $m+1$ digits requires ${m^2 + 3m - 2} \over 2$ single precision multiplications.  

With both optimizations in place the algorithm is the algorithm Barrett proposed.  It requires $m^2 + 2m - 1$ single precision multiplications which
is considerably faster than the straightforward $3m^2$ method.  

\subsection{The Barrett Algorithm}
\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_reduce}. \\
\textbf{Input}.   mp\_int $a$, mp\_int $b$ and $\mu = \lfloor \beta^{2m}/b \rfloor, m = \lceil lg_{\beta}(b) \rceil, (0 \le a < b^2, b > 1)$ \\
\textbf{Output}.  $a \mbox{ (mod }b\mbox{)}$ \\
\hline \\
Let $m$ represent the number of digits in $b$.  \\
1.  Make a copy of $a$ and store it in $q$.  (\textit{mp\_init\_copy}) \\
2.  $q \leftarrow \lfloor q / \beta^{m - 1} \rfloor$ (\textit{mp\_rshd}) \\
\\
Produce the quotient. \\
3.  $q \leftarrow q \cdot \mu$  (\textit{note: only produce digits at or above $m-1$}) \\
4.  $q \leftarrow \lfloor q / \beta^{m + 1} \rfloor$ \\
\\
Subtract the multiple of modulus from the input. \\
5.  $a \leftarrow a \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{mp\_mod\_2d}) \\
6.  $q \leftarrow q \cdot b \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{s\_mp\_mul\_digs}) \\
7.  $a \leftarrow a - q$ (\textit{mp\_sub}) \\
\\
Add $\beta^{m+1}$ if a carry occured. \\
8.  If $a < 0$ then (\textit{mp\_cmp\_d}) \\
\hspace{3mm}8.1  $q \leftarrow 1$ (\textit{mp\_set}) \\
\hspace{3mm}8.2  $q \leftarrow q \cdot \beta^{m+1}$ (\textit{mp\_lshd}) \\
\hspace{3mm}8.3  $a \leftarrow a + q$ \\
\\
Now subtract the modulus if the residue is too large (e.g. quotient too small). \\
9.  While $a \ge b$ do (\textit{mp\_cmp}) \\
\hspace{3mm}9.1  $c \leftarrow a - b$ \\
10.  Clear $q$. \\
11.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_reduce}
\end{figure}

\textbf{Algorithm mp\_reduce.}
This algorithm will reduce the input $a$ modulo $b$ in place using the Barrett algorithm.  It is loosely based on algorithm 14.42 of HAC
\cite[pp.  602]{HAC} which is based on the paper from Paul Barrett \cite{BARRETT}.  The algorithm has several restrictions and assumptions which must 
be adhered to for the algorithm to work.

First the modulus $b$ is assumed to be positive and greater than one.  If the modulus were less than or equal to one than subtracting
a multiple of it would either accomplish nothing or actually enlarge the input.  The input $a$ must be in the range $0 \le a < b^2$ in order
for the quotient to have enough precision.  If $a$ is the product of two numbers that were already reduced modulo $b$, this will not be a problem.
Technically the algorithm will still work if $a \ge b^2$ but it will take much longer to finish.  The value of $\mu$ is passed as an argument to this 
algorithm and is assumed to be calculated and stored before the algorithm is used.  

Recall that the multiplication for the quotient on step 3 must only produce digits at or above the $m-1$'th position.  An algorithm called 
$s\_mp\_mul\_high\_digs$ which has not been presented is used to accomplish this task.  The algorithm is based on $s\_mp\_mul\_digs$ except that
instead of stopping at a given level of precision it starts at a given level of precision.  This optimal algorithm can only be used if the number
of digits in $b$ is very much smaller than $\beta$.  

While it is known that 
$a \ge b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ only the lower $m+1$ digits are being used to compute the residue, so an implied 
``borrow'' from the higher digits might leave a negative result.  After the multiple of the modulus has been subtracted from $a$ the residue must be 
fixed up in case it is negative.  The invariant $\beta^{m+1}$ must be added to the residue to make it positive again.  

The while loop at step 9 will subtract $b$ until the residue is less than $b$.  If the algorithm is performed correctly this step is 
performed at most twice, and on average once. However, if $a \ge b^2$ than it will iterate substantially more times than it should.

EXAM,bn_mp_reduce.c

The first multiplication that determines the quotient can be performed by only producing the digits from $m - 1$ and up.  This essentially halves
the number of single precision multiplications required.  However, the optimization is only safe if $\beta$ is much larger than the number of digits
in the modulus.  In the source code this is evaluated on lines @36,if@ to @44,}@ where algorithm s\_mp\_mul\_high\_digs is used when it is
safe to do so.  

\subsection{The Barrett Setup Algorithm}
In order to use algorithm mp\_reduce the value of $\mu$ must be calculated in advance.  Ideally this value should be computed once and stored for
future use so that the Barrett algorithm can be used without delay.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_reduce\_setup}. \\
\textbf{Input}.   mp\_int $a$ ($a > 1$)  \\
\textbf{Output}.  $\mu \leftarrow \lfloor \beta^{2m}/a \rfloor$ \\
\hline \\
1.  $\mu \leftarrow 2^{2 \cdot lg(\beta) \cdot  m}$ (\textit{mp\_2expt}) \\
2.  $\mu \leftarrow \lfloor \mu / b \rfloor$ (\textit{mp\_div}) \\
3.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_reduce\_setup}
\end{figure}

\textbf{Algorithm mp\_reduce\_setup.}
This algorithm computes the reciprocal $\mu$ required for Barrett reduction.  First $\beta^{2m}$ is calculated as $2^{2 \cdot lg(\beta) \cdot  m}$ which
is equivalent and much faster.  The final value is computed by taking the integer quotient of $\lfloor \mu / b \rfloor$.

EXAM,bn_mp_reduce_setup.c

This simple routine calculates the reciprocal $\mu$ required by Barrett reduction.  Note the extended usage of algorithm mp\_div where the variable
which would received the remainder is passed as NULL.  As will be discussed in~\ref{sec:division} the division routine allows both the quotient and the 
remainder to be passed as NULL meaning to ignore the value.  

\section{The Montgomery Reduction}
Montgomery reduction\footnote{Thanks to Niels Ferguson for his insightful explanation of the algorithm.} \cite{MONT} is by far the most interesting 
form of reduction in common use.  It computes a modular residue which is not actually equal to the residue of the input yet instead equal to a 
residue times a constant.  However, as perplexing as this may sound the algorithm is relatively simple and very efficient.  

Throughout this entire section the variable $n$ will represent the modulus used to form the residue.  As will be discussed shortly the value of
$n$ must be odd.  The variable $x$ will represent the quantity of which the residue is sought.  Similar to the Barrett algorithm the input
is restricted to $0 \le x < n^2$.  To begin the description some simple number theory facts must be established.

\textbf{Fact 1.}  Adding $n$ to $x$ does not change the residue since in effect it adds one to the quotient $\lfloor x / n \rfloor$.  Another way
to explain this is that $n$ is (\textit{or multiples of $n$ are}) congruent to zero modulo $n$.  Adding zero will not change the value of the residue.  

\textbf{Fact 2.}  If $x$ is even then performing a division by two in $\Z$ is congruent to $x \cdot 2^{-1} \mbox{ (mod }n\mbox{)}$.  Actually
this is an application of the fact that if $x$ is evenly divisible by any $k \in \Z$ then division in $\Z$ will be congruent to 
multiplication by $k^{-1}$ modulo $n$.  

From these two simple facts the following simple algorithm can be derived.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Montgomery Reduction}. \\
\textbf{Input}.   Integer $x$, $n$ and $k$ \\
\textbf{Output}.  $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\
\hline \\
1.  for $t$ from $1$ to $k$ do \\
\hspace{3mm}1.1  If $x$ is odd then \\
\hspace{6mm}1.1.1  $x \leftarrow x + n$ \\
\hspace{3mm}1.2  $x \leftarrow x/2$ \\
2.  Return $x$. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Montgomery Reduction}
\end{figure}

The algorithm reduces the input one bit at a time using the two congruencies stated previously.  Inside the loop $n$, which is odd, is
added to $x$ if $x$ is odd.  This forces $x$ to be even which allows the division by two in $\Z$ to be congruent to a modular division by two.  Since
$x$ is assumed to be initially much larger than $n$ the addition of $n$ will contribute an insignificant magnitude to $x$.  Let $r$ represent the 
final result of the Montgomery algorithm.  If $k > lg(n)$ and $0 \le x < n^2$ then the final result is limited to 
$0 \le r < \lfloor x/2^k \rfloor + n$.  As a result at most a single subtraction is required to get the residue desired.

\begin{figure}[here]
\begin{small}
\begin{center}
\begin{tabular}{|c|l|}
\hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} \\
\hline $1$ & $x + n = 5812$, $x/2 = 2906$ \\
\hline $2$ & $x/2 = 1453$ \\
\hline $3$ & $x + n = 1710$, $x/2 = 855$ \\
\hline $4$ & $x + n = 1112$, $x/2 = 556$ \\
\hline $5$ & $x/2 = 278$ \\
\hline $6$ & $x/2 = 139$ \\
\hline $7$ & $x + n = 396$, $x/2 = 198$ \\
\hline $8$ & $x/2 = 99$ \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Example of Montgomery Reduction (I)}
\label{fig:MONT1}
\end{figure}

Consider the example in figure~\ref{fig:MONT1} which reduces $x = 5555$ modulo $n = 257$ when $k = 8$.  The result of the algorithm $r = 99$ is
congruent to the value of $2^{-8} \cdot 5555 \mbox{ (mod }257\mbox{)}$.  When $r$ is multiplied by $2^8$ modulo $257$ the correct residue 
$r \equiv 158$ is produced.  

Let $k = \lfloor lg(n) \rfloor + 1$ represent the number of bits in $n$.  The current algorithm requires $2k^2$ single precision shifts
and $k^2$ single precision additions.  At this rate the algorithm is most certainly slower than Barrett reduction and not terribly useful.  
Fortunately there exists an alternative representation of the algorithm.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Montgomery Reduction} (modified I). \\
\textbf{Input}.   Integer $x$, $n$ and $k$ \\
\textbf{Output}.  $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\
\hline \\
1.  for $t$ from $0$ to $k - 1$ do \\
\hspace{3mm}1.1  If the $t$'th bit of $x$ is one then \\
\hspace{6mm}1.1.1  $x \leftarrow x + 2^tn$ \\
2.  Return $x/2^k$. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Montgomery Reduction (modified I)}
\end{figure}

This algorithm is equivalent since $2^tn$ is a multiple of $n$ and the lower $k$ bits of $x$ are zero by step 2.  The number of single
precision shifts has now been reduced from $2k^2$ to $k^2 + k$ which is only a small improvement.

\begin{figure}[here]
\begin{small}
\begin{center}
\begin{tabular}{|c|l|r|}
\hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} & \textbf{Result ($x$) in Binary} \\
\hline -- & $5555$ & $1010110110011$ \\
\hline $1$ & $x + 2^{0}n = 5812$ &  $1011010110100$ \\
\hline $2$ & $5812$ & $1011010110100$ \\
\hline $3$ & $x + 2^{2}n = 6840$ & $1101010111000$ \\
\hline $4$ & $x + 2^{3}n = 8896$ & $10001011000000$ \\
\hline $5$ & $8896$ & $10001011000000$ \\
\hline $6$ & $8896$ & $10001011000000$ \\
\hline $7$ & $x + 2^{6}n = 25344$ & $110001100000000$ \\
\hline $8$ & $25344$ & $110001100000000$ \\
\hline -- & $x/2^k = 99$ & \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Example of Montgomery Reduction (II)}
\label{fig:MONT2}
\end{figure}

Figure~\ref{fig:MONT2} demonstrates the modified algorithm reducing $x = 5555$ modulo $n = 257$ with $k = 8$. 
With this algorithm a single shift right at the end is the only right shift required to reduce the input instead of $k$ right shifts inside the 
loop.  Note that for the iterations $t = 2, 5, 6$ and $8$ where the result $x$ is not changed.  In those iterations the $t$'th bit of $x$ is 
zero and the appropriate multiple of $n$ does not need to be added to force the $t$'th bit of the result to zero.  

\subsection{Digit Based Montgomery Reduction}
Instead of computing the reduction on a bit-by-bit basis it is actually much faster to compute it on digit-by-digit basis.  Consider the
previous algorithm re-written to compute the Montgomery reduction in this new fashion.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Montgomery Reduction} (modified II). \\
\textbf{Input}.   Integer $x$, $n$ and $k$ \\
\textbf{Output}.  $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\
\hline \\
1.  for $t$ from $0$ to $k - 1$ do \\
\hspace{3mm}1.1  $x \leftarrow x + \mu n \beta^t$ \\
2.  Return $x/\beta^k$. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Montgomery Reduction (modified II)}
\end{figure}

The value $\mu n \beta^t$ is a multiple of the modulus $n$ meaning that it will not change the residue.  If the first digit of 
the value $\mu n \beta^t$ equals the negative (modulo $\beta$) of the $t$'th digit of $x$ then the addition will result in a zero digit.  This
problem breaks down to solving the following congruency.  

\begin{center}
\begin{tabular}{rcl}
$x_t + \mu n_0$ & $\equiv$ & $0 \mbox{ (mod }\beta\mbox{)}$ \\
$\mu n_0$ & $\equiv$ & $-x_t \mbox{ (mod }\beta\mbox{)}$ \\
$\mu$ & $\equiv$ & $-x_t/n_0 \mbox{ (mod }\beta\mbox{)}$ \\
\end{tabular}
\end{center}

In each iteration of the loop on step 1 a new value of $\mu$ must be calculated.  The value of $-1/n_0 \mbox{ (mod }\beta\mbox{)}$ is used 
extensively in this algorithm and should be precomputed.  Let $\rho$ represent the negative of the modular inverse of $n_0$ modulo $\beta$.  

For example, let $\beta = 10$ represent the radix.  Let $n = 17$ represent the modulus which implies $k = 2$ and $\rho \equiv 7$.  Let $x = 33$ 
represent the value to reduce.

\newpage\begin{figure}
\begin{center}
\begin{tabular}{|c|c|c|}
\hline \textbf{Step ($t$)} & \textbf{Value of $x$} & \textbf{Value of $\mu$} \\
\hline --                 & $33$ & --\\
\hline $0$                 & $33 + \mu n = 50$ & $1$ \\
\hline $1$                 & $50 + \mu n \beta = 900$ & $5$ \\
\hline
\end{tabular}
\end{center}
\caption{Example of Montgomery Reduction}
\end{figure}

The final result $900$ is then divided by $\beta^k$ to produce the final result $9$.  The first observation is that $9 \nequiv x \mbox{ (mod }n\mbox{)}$ 
which implies the result is not the modular residue of $x$ modulo $n$.  However, recall that the residue is actually multiplied by $\beta^{-k}$ in
the algorithm.  To get the true residue the value must be multiplied by $\beta^k$.  In this case $\beta^k \equiv 15 \mbox{ (mod }n\mbox{)}$ and
the correct residue is $9 \cdot 15 \equiv 16 \mbox{ (mod }n\mbox{)}$.  

\subsection{Baseline Montgomery Reduction}
The baseline Montgomery reduction algorithm will produce the residue for any size input.  It is designed to be a catch-all algororithm for 
Montgomery reductions.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_montgomery\_reduce}. \\
\textbf{Input}.   mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\
\hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\
\textbf{Output}.  $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\
\hline \\
1.  $digs \leftarrow 2n.used + 1$ \\
2.  If $digs < MP\_ARRAY$ and $m.used < \delta$ then \\
\hspace{3mm}2.1  Use algorithm fast\_mp\_montgomery\_reduce instead. \\
\\
Setup $x$ for the reduction. \\
3.  If $x.alloc < digs$ then grow $x$ to $digs$ digits. \\
4.  $x.used \leftarrow digs$ \\
\\
Eliminate the lower $k$ digits. \\
5.  For $ix$ from $0$ to $k - 1$ do \\
\hspace{3mm}5.1  $\mu \leftarrow x_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}5.2  $u \leftarrow 0$ \\
\hspace{3mm}5.3  For $iy$ from $0$ to $k - 1$ do \\
\hspace{6mm}5.3.1  $\hat r \leftarrow \mu n_{iy} + x_{ix + iy} + u$ \\
\hspace{6mm}5.3.2  $x_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{6mm}5.3.3  $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\
\hspace{3mm}5.4  While $u > 0$ do \\
\hspace{6mm}5.4.1  $iy \leftarrow iy + 1$ \\
\hspace{6mm}5.4.2  $x_{ix + iy} \leftarrow x_{ix + iy} + u$ \\
\hspace{6mm}5.4.3  $u \leftarrow \lfloor x_{ix+iy} / \beta \rfloor$ \\
\hspace{6mm}5.4.4  $x_{ix + iy} \leftarrow x_{ix+iy} \mbox{ (mod }\beta\mbox{)}$ \\
\\
Divide by $\beta^k$ and fix up as required. \\
6.  $x \leftarrow \lfloor x / \beta^k \rfloor$ \\
7.  If $x \ge n$ then \\
\hspace{3mm}7.1  $x \leftarrow x - n$ \\
8.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_montgomery\_reduce}
\end{figure}

\textbf{Algorithm mp\_montgomery\_reduce.}
This algorithm reduces the input $x$ modulo $n$ in place using the Montgomery reduction algorithm.  The algorithm is loosely based
on algorithm 14.32 of \cite[pp.601]{HAC} except it merges the multiplication of $\mu n \beta^t$ with the addition in the inner loop.  The
restrictions on this algorithm are fairly easy to adapt to.  First $0 \le x < n^2$ bounds the input to numbers in the same range as 
for the Barrett algorithm.  Additionally if $n > 1$ and $n$ is odd there will exist a modular inverse $\rho$.  $\rho$ must be calculated in
advance of this algorithm.  Finally the variable $k$ is fixed and a pseudonym for $n.used$.  

Step 2 decides whether a faster Montgomery algorithm can be used.  It is based on the Comba technique meaning that there are limits on
the size of the input.  This algorithm is discussed in ~COMBARED~.

Step 5 is the main reduction loop of the algorithm.  The value of $\mu$ is calculated once per iteration in the outer loop.  The inner loop
calculates $x + \mu n \beta^{ix}$ by multiplying $\mu n$ and adding the result to $x$ shifted by $ix$ digits.  Both the addition and
multiplication are performed in the same loop to save time and memory.  Step 5.4 will handle any additional carries that escape the inner loop.

Using a quick inspection this algorithm requires $n$ single precision multiplications for the outer loop and $n^2$ single precision multiplications 
in the inner loop.  In total $n^2 + n$ single precision multiplications which compares favourably to Barrett at $n^2 + 2n - 1$ single precision
multiplications.  

EXAM,bn_mp_montgomery_reduce.c

This is the baseline implementation of the Montgomery reduction algorithm.  Lines @30,digs@ to @35,}@ determine if the Comba based
routine can be used instead.  Line @47,mu@ computes the value of $\mu$ for that particular iteration of the outer loop.  

The multiplication $\mu n \beta^{ix}$ is performed in one step in the inner loop.  The alias $tmpx$ refers to the $ix$'th digit of $x$ and
the alias $tmpn$ refers to the modulus $n$.  

\subsection{Faster ``Comba'' Montgomery Reduction}
MARK,COMBARED

The Montgomery reduction requires fewer single precision multiplications than a Barrett reduction, however it is much slower due to the serial
nature of the inner loop.  The Barrett reduction algorithm requires two slightly modified multipliers which can be implemented with the Comba
technique.  The Montgomery reduction algorithm cannot directly use the Comba technique to any significant advantage since the inner loop calculates
a $k \times 1$ product $k$ times. 

The biggest obstacle is that at the $ix$'th iteration of the outer loop the value of $x_{ix}$ is required to calculate $\mu$.  This means the 
carries from $0$ to $ix - 1$ must have been propagated upwards to form a valid $ix$'th digit.  The solution as it turns out is very simple.  
Perform a Comba like multiplier and inside the outer loop just after the inner loop fix up the $ix + 1$'th digit by forwarding the carry.  

With this change in place the Montgomery reduction algorithm can be performed with a Comba style multiplication loop which substantially increases
the speed of the algorithm.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{fast\_mp\_montgomery\_reduce}. \\
\textbf{Input}.   mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\
\hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\
\textbf{Output}.  $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\
\hline \\
Place an array of \textbf{MP\_WARRAY} mp\_word variables called $\hat W$ on the stack. \\
1.  if $x.alloc < n.used + 1$ then grow $x$ to $n.used + 1$ digits. \\
Copy the digits of $x$ into the array $\hat W$ \\
2.  For $ix$ from $0$ to $x.used - 1$ do \\
\hspace{3mm}2.1  $\hat W_{ix} \leftarrow x_{ix}$ \\
3.  For $ix$ from $x.used$ to $2n.used - 1$ do \\
\hspace{3mm}3.1  $\hat W_{ix} \leftarrow 0$ \\
Elimiate the lower $k$ digits. \\
4.  for $ix$ from $0$ to $n.used - 1$ do \\
\hspace{3mm}4.1  $\mu \leftarrow \hat W_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}4.2  For $iy$ from $0$ to $n.used - 1$ do \\
\hspace{6mm}4.2.1  $\hat W_{iy + ix} \leftarrow \hat W_{iy + ix} + \mu \cdot n_{iy}$ \\
\hspace{3mm}4.3  $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\
Propagate carries upwards. \\
5.  for $ix$ from $n.used$ to $2n.used + 1$ do \\
\hspace{3mm}5.1  $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\
Shift right and reduce modulo $\beta$ simultaneously. \\
6.  for $ix$ from $0$ to $n.used + 1$ do \\
\hspace{3mm}6.1  $x_{ix} \leftarrow \hat W_{ix + n.used} \mbox{ (mod }\beta\mbox{)}$ \\
Zero excess digits and fixup $x$. \\
7.  if $x.used > n.used + 1$ then do \\
\hspace{3mm}7.1  for $ix$ from $n.used + 1$ to $x.used - 1$ do \\
\hspace{6mm}7.1.1  $x_{ix} \leftarrow 0$ \\
8.  $x.used \leftarrow n.used + 1$ \\
9.  Clamp excessive digits of $x$. \\
10.  If $x \ge n$ then \\
\hspace{3mm}10.1  $x \leftarrow x - n$ \\
11.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm fast\_mp\_montgomery\_reduce}
\end{figure}

\textbf{Algorithm fast\_mp\_montgomery\_reduce.}
This algorithm will compute the Montgomery reduction of $x$ modulo $n$ using the Comba technique.  It is on most computer platforms significantly
faster than algorithm mp\_montgomery\_reduce and algorithm mp\_reduce (\textit{Barrett reduction}).  The algorithm has the same restrictions
on the input as the baseline reduction algorithm.  An additional two restrictions are imposed on this algorithm.  The number of digits $k$ in the 
the modulus $n$ must not violate $MP\_WARRAY > 2k +1$ and $n < \delta$.   When $\beta = 2^{28}$ this algorithm can be used to reduce modulo
a modulus of at most $3,556$ bits in length.  

As in the other Comba reduction algorithms there is a $\hat W$ array which stores the columns of the product.  It is initially filled with the
contents of $x$ with the excess digits zeroed.  The reduction loop is very similar the to the baseline loop at heart.  The multiplication on step
4.1 can be single precision only since $ab \mbox{ (mod }\beta\mbox{)} \equiv (a \mbox{ mod }\beta)(b \mbox{ mod }\beta)$.  Some multipliers such
as those on the ARM processors take a variable length time to complete depending on the number of bytes of result it must produce.  By performing
a single precision multiplication instead half the amount of time is spent.

Also note that digit $\hat W_{ix}$ must have the carry from the $ix - 1$'th digit propagated upwards in order for this to work.  That is what step
4.3 will do.  In effect over the $n.used$ iterations of the outer loop the $n.used$'th lower columns all have the their carries propagated forwards.  Note
how the upper bits of those same words are not reduced modulo $\beta$.  This is because those values will be discarded shortly and there is no
point.

Step 5 will propagate the remainder of the carries upwards.  On step 6 the columns are reduced modulo $\beta$ and shifted simultaneously as they are
stored in the destination $x$.  

EXAM,bn_fast_mp_montgomery_reduce.c

The $\hat W$ array is first filled with digits of $x$ on line @49,for@ then the rest of the digits are zeroed on line @54,for@.  Both loops share
the same alias variables to make the code easier to read.  

The value of $\mu$ is calculated in an interesting fashion.  First the value $\hat W_{ix}$ is reduced modulo $\beta$ and cast to a mp\_digit.  This
forces the compiler to use a single precision multiplication and prevents any concerns about loss of precision.   Line @101,>>@ fixes the carry 
for the next iteration of the loop by propagating the carry from $\hat W_{ix}$ to $\hat W_{ix+1}$.

The for loop on line @113,for@ propagates the rest of the carries upwards through the columns.  The for loop on line @126,for@ reduces the columns
modulo $\beta$ and shifts them $k$ places at the same time.  The alias $\_ \hat W$ actually refers to the array $\hat W$ starting at the $n.used$'th
digit, that is $\_ \hat W_{t} = \hat W_{n.used + t}$.  

\subsection{Montgomery Setup}
To calculate the variable $\rho$ a relatively simple algorithm will be required.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_montgomery\_setup}. \\
\textbf{Input}.   mp\_int $n$ ($n > 1$ and $(n, 2) = 1$) \\
\textbf{Output}.  $\rho \equiv -1/n_0 \mbox{ (mod }\beta\mbox{)}$ \\
\hline \\
1.  $b \leftarrow n_0$ \\
2.  If $b$ is even return(\textit{MP\_VAL}) \\
3.  $x \leftarrow (((b + 2) \mbox{ AND } 4) << 1) + b$ \\
4.  for $k$ from 0 to $\lceil lg(lg(\beta)) \rceil - 2$ do \\
\hspace{3mm}4.1  $x \leftarrow x \cdot (2 - bx)$ \\
5.  $\rho \leftarrow \beta - x \mbox{ (mod }\beta\mbox{)}$ \\
6.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_montgomery\_setup} 
\end{figure}

\textbf{Algorithm mp\_montgomery\_setup.}
This algorithm will calculate the value of $\rho$ required within the Montgomery reduction algorithms.  It uses a very interesting trick 
to calculate $1/n_0$ when $\beta$ is a power of two.  

EXAM,bn_mp_montgomery_setup.c

This source code computes the value of $\rho$ required to perform Montgomery reduction.  It has been modified to avoid performing excess
multiplications when $\beta$ is not the default 28-bits.  

\section{The Diminished Radix Algorithm}
The Diminished Radix method of modular reduction \cite{DRMET} is a fairly clever technique which can be more efficient than either the Barrett
or Montgomery methods for certain forms of moduli.  The technique is based on the following simple congruence.

\begin{equation}
(x \mbox{ mod } n) + k \lfloor x / n \rfloor \equiv x \mbox{ (mod }(n - k)\mbox{)}
\end{equation}

This observation was used in the MMB \cite{MMB} block cipher to create a diffusion primitive.  It used the fact that if $n = 2^{31}$ and $k=1$ that 
then a x86 multiplier could produce the 62-bit product and use  the ``shrd'' instruction to perform a double-precision right shift.  The proof
of the above equation is very simple.  First write $x$ in the product form.

\begin{equation}
x = qn + r
\end{equation}

Now reduce both sides modulo $(n - k)$.

\begin{equation}
x \equiv qk + r  \mbox{ (mod }(n-k)\mbox{)}
\end{equation}

The variable $n$ reduces modulo $n - k$ to $k$.  By putting $q = \lfloor x/n \rfloor$ and $r = x \mbox{ mod } n$ 
into the equation the original congruence is reproduced, thus concluding the proof.  The following algorithm is based on this observation.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Diminished Radix Reduction}. \\
\textbf{Input}.   Integer $x$, $n$, $k$ \\
\textbf{Output}.  $x \mbox{ mod } (n - k)$ \\
\hline \\
1.  $q \leftarrow \lfloor x / n \rfloor$ \\
2.  $q \leftarrow k \cdot q$ \\
3.  $x \leftarrow x \mbox{ (mod }n\mbox{)}$ \\
4.  $x \leftarrow x + q$ \\
5.  If $x \ge (n - k)$ then \\
\hspace{3mm}5.1  $x \leftarrow x - (n - k)$ \\
\hspace{3mm}5.2  Goto step 1. \\
6.  Return $x$ \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Diminished Radix Reduction}
\label{fig:DR}
\end{figure}

This algorithm will reduce $x$ modulo $n - k$ and return the residue.  If $0 \le x < (n - k)^2$ then the algorithm will loop almost always
once or twice and occasionally three times.  For simplicity sake the value of $x$ is bounded by the following simple polynomial.

\begin{equation} 
0 \le x < n^2 + k^2 - 2nk
\end{equation}

The true bound is  $0 \le x < (n - k - 1)^2$ but this has quite a few more terms.  The value of $q$ after step 1 is bounded by the following.

\begin{equation}
q < n - 2k - k^2/n
\end{equation}

Since $k^2$ is going to be considerably smaller than $n$ that term will always be zero.  The value of $x$ after step 3 is bounded trivially as
$0 \le x < n$.  By step four the sum $x + q$ is bounded by 

\begin{equation}
0 \le q + x < (k + 1)n - 2k^2 - 1
\end{equation}

With a second pass $q$ will be loosely bounded by $0 \le q < k^2$ after step 2 while $x$ will still be loosely bounded by $0 \le x < n$ after step 3.  After the second pass it is highly unlike that the
sum in step 4 will exceed $n - k$.  In practice fewer than three passes of the algorithm are required to reduce virtually every input in the 
range $0 \le x < (n - k - 1)^2$.  

\begin{figure}
\begin{small}
\begin{center}
\begin{tabular}{|l|}
\hline
$x = 123456789, n = 256, k = 3$ \\
\hline $q \leftarrow \lfloor x/n \rfloor = 482253$ \\
$q \leftarrow q*k = 1446759$ \\
$x \leftarrow x \mbox{ mod } n = 21$ \\
$x \leftarrow x + q = 1446780$ \\
$x \leftarrow x - (n - k) = 1446527$ \\
\hline 
$q \leftarrow \lfloor x/n \rfloor = 5650$ \\
$q \leftarrow q*k = 16950$ \\
$x \leftarrow x \mbox{ mod } n = 127$ \\
$x \leftarrow x + q = 17077$ \\
$x \leftarrow x - (n - k) = 16824$ \\
\hline 
$q \leftarrow \lfloor x/n \rfloor = 65$ \\
$q \leftarrow q*k = 195$ \\
$x \leftarrow x \mbox{ mod } n = 184$ \\
$x \leftarrow x + q = 379$ \\
$x \leftarrow x - (n - k) = 126$ \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Example Diminished Radix Reduction}
\label{fig:EXDR}
\end{figure}

Figure~\ref{fig:EXDR} demonstrates the reduction of $x = 123456789$ modulo $n - k = 253$ when $n = 256$ and $k = 3$.  Note that even while $x$
is considerably larger than $(n - k - 1)^2 = 63504$ the algorithm still converges on the modular residue exceedingly fast.  In this case only
three passes were required to find the residue $x \equiv 126$.


\subsection{Choice of Moduli}
On the surface this algorithm looks like a very expensive algorithm.  It requires a couple of subtractions followed by multiplication and other
modular reductions.  The usefulness of this algorithm becomes exceedingly clear when an appropriate modulus is chosen.

Division in general is a very expensive operation to perform.  The one exception is when the division is by a power of the radix of representation used.  
Division by ten for example is simple for pencil and paper mathematics since it amounts to shifting the decimal place to the right.  Similarly division 
by two (\textit{or powers of two}) is very simple for binary computers to perform.  It would therefore seem logical to choose $n$ of the form $2^p$ 
which would imply that $\lfloor x / n \rfloor$ is a simple shift of $x$ right $p$ bits.  

However, there is one operation related to division of power of twos that is even faster than this.  If $n = \beta^p$ then the division may be 
performed by moving whole digits to the right $p$ places.  In practice division by $\beta^p$ is much faster than division by $2^p$ for any $p$.  
Also with the choice of $n = \beta^p$ reducing $x$ modulo $n$ merely requires zeroing the digits above the $p-1$'th digit of $x$.  

Throughout the next section the term ``restricted modulus'' will refer to a modulus of the form $\beta^p - k$ whereas the term ``unrestricted
modulus'' will refer to a modulus of the form $2^p - k$.  The word ``restricted'' in this case refers to the fact that it is based on the 
$2^p$ logic except $p$ must be a multiple of $lg(\beta)$.  

\subsection{Choice of $k$}
Now that division and reduction (\textit{step 1 and 3 of figure~\ref{fig:DR}}) have been optimized to simple digit operations the multiplication by $k$
in step 2 is the most expensive operation.  Fortunately the choice of $k$ is not terribly limited.  For all intents and purposes it might
as well be a single digit.  The smaller the value of $k$ is the faster the algorithm will be.  

\subsection{Restricted Diminished Radix Reduction}
The restricted Diminished Radix algorithm can quickly reduce an input modulo a modulus of the form $n = \beta^p - k$.  This algorithm can reduce 
an input $x$ within the range $0 \le x < n^2$ using only a couple passes of the algorithm demonstrated in figure~\ref{fig:DR}.  The implementation
of this algorithm has been optimized to avoid additional overhead associated with a division by $\beta^p$, the multiplication by $k$ or the addition 
of $x$ and $q$.  The resulting algorithm is very efficient and can lead to substantial improvements over Barrett and Montgomery reduction when modular 
exponentiations are performed.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_dr\_reduce}. \\
\textbf{Input}.   mp\_int $x$, $n$ and a mp\_digit $k = \beta - n_0$ \\
\hspace{11.5mm}($0 \le x < n^2$, $n > 1$, $0 < k < \beta$) \\
\textbf{Output}.  $x \mbox{ mod } n$ \\
\hline \\
1.  $m \leftarrow n.used$ \\
2.  If $x.alloc < 2m$ then grow $x$ to $2m$ digits. \\
3.  $\mu \leftarrow 0$ \\
4.  for $i$ from $0$ to $m - 1$ do \\
\hspace{3mm}4.1  $\hat r \leftarrow k \cdot x_{m+i} + x_{i} + \mu$ \\
\hspace{3mm}4.2  $x_{i} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}4.3  $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\
5.  $x_{m} \leftarrow \mu$ \\
6.  for $i$ from $m + 1$ to $x.used - 1$ do \\
\hspace{3mm}6.1  $x_{i} \leftarrow 0$ \\
7.  Clamp excess digits of $x$. \\
8.  If $x \ge n$ then \\
\hspace{3mm}8.1  $x \leftarrow x - n$ \\
\hspace{3mm}8.2  Goto step 3. \\
9.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_dr\_reduce}
\end{figure}

\textbf{Algorithm mp\_dr\_reduce.}
This algorithm will perform the Dimished Radix reduction of $x$ modulo $n$.  It has similar restrictions to that of the Barrett reduction
with the addition that $n$ must be of the form $n = \beta^m - k$ where $0 < k <\beta$.  

This algorithm essentially implements the pseudo-code in figure~\ref{fig:DR} except with a slight optimization.  The division by $\beta^m$, multiplication by $k$
and addition of $x \mbox{ mod }\beta^m$ are all performed simultaneously inside the loop on step 4.  The division by $\beta^m$ is emulated by accessing
the term at the $m+i$'th position which is subsequently multiplied by $k$ and added to the term at the $i$'th position.  After the loop the $m$'th
digit is set to the carry and the upper digits are zeroed.  Steps 5 and 6 emulate the reduction modulo $\beta^m$ that should have happend to 
$x$ before the addition of the multiple of the upper half.  

At step 8 if $x$ is still larger than $n$ another pass of the algorithm is required.  First $n$ is subtracted from $x$ and then the algorithm resumes
at step 3.  

EXAM,bn_mp_dr_reduce.c

The first step is to grow $x$ as required to $2m$ digits since the reduction is performed in place on $x$.  The label on line @49,top:@ is where
the algorithm will resume if further reduction passes are required.  In theory it could be placed at the top of the function however, the size of
the modulus and question of whether $x$ is large enough are invariant after the first pass meaning that it would be a waste of time.  

The aliases $tmpx1$ and $tmpx2$ refer to the digits of $x$ where the latter is offset by $m$ digits.  By reading digits from $x$ offset by $m$ digits
a division by $\beta^m$ can be simulated virtually for free.  The loop on line @61,for@ performs the bulk of the work (\textit{corresponds to step 4 of algorithm 7.11})
in this algorithm.

By line @68,mu@ the pointer $tmpx1$ points to the $m$'th digit of $x$ which is where the final carry will be placed.  Similarly by line @71,for@ the 
same pointer will point to the $m+1$'th digit where the zeroes will be placed.  

Since the algorithm is only valid if both $x$ and $n$ are greater than zero an unsigned comparison suffices to determine if another pass is required.  
With the same logic at line @82,sub@ the value of $x$ is known to be greater than or equal to $n$ meaning that an unsigned subtraction can be used
as well.  Since the destination of the subtraction is the larger of the inputs the call to algorithm s\_mp\_sub cannot fail and the return code
does not need to be checked.

\subsubsection{Setup}
To setup the restricted Diminished Radix algorithm the value $k = \beta - n_0$ is required.  This algorithm is not really complicated but provided for
completeness.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_dr\_setup}. \\
\textbf{Input}.   mp\_int $n$ \\
\textbf{Output}.  $k = \beta - n_0$ \\
\hline \\
1.  $k \leftarrow \beta - n_0$ \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_dr\_setup}
\end{figure}

EXAM,bn_mp_dr_setup.c

\subsubsection{Modulus Detection}
Another algorithm which will be useful is the ability to detect a restricted Diminished Radix modulus.  An integer is said to be
of restricted Diminished Radix form if all of the digits are equal to $\beta - 1$ except the trailing digit which may be any value.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_dr\_is\_modulus}. \\
\textbf{Input}.   mp\_int $n$ \\
\textbf{Output}.  $1$ if $n$ is in D.R form, $0$ otherwise \\
\hline
1.  If $n.used < 2$ then return($0$). \\
2.  for $ix$ from $1$ to $n.used - 1$ do \\
\hspace{3mm}2.1  If $n_{ix} \ne \beta - 1$ return($0$). \\
3.  Return($1$). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_dr\_is\_modulus}
\end{figure}

\textbf{Algorithm mp\_dr\_is\_modulus.}
This algorithm determines if a value is in Diminished Radix form.  Step 1 rejects obvious cases where fewer than two digits are
in the mp\_int.  Step 2 tests all but the first digit to see if they are equal to $\beta - 1$.  If the algorithm manages to get to
step 3 then $n$ must be of Diminished Radix form.

EXAM,bn_mp_dr_is_modulus.c

\subsection{Unrestricted Diminished Radix Reduction}
The unrestricted Diminished Radix algorithm allows modular reductions to be performed when the modulus is of the form $2^p - k$.  This algorithm
is a straightforward adaptation of algorithm~\ref{fig:DR}.

In general the restricted Diminished Radix reduction algorithm is much faster since it has considerably lower overhead.  However, this new
algorithm is much faster than either Montgomery or Barrett reduction when the moduli are of the appropriate form.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_reduce\_2k}. \\
\textbf{Input}.   mp\_int $a$ and $n$.  mp\_digit $k$  \\
\hspace{11.5mm}($a \ge 0$, $n > 1$, $0 < k < \beta$, $n + k$ is a power of two) \\
\textbf{Output}.  $a \mbox{ (mod }n\mbox{)}$ \\
\hline
1.  $p \leftarrow \lceil lg(n) \rceil$  (\textit{mp\_count\_bits}) \\
2.  While $a \ge n$ do \\
\hspace{3mm}2.1  $q \leftarrow \lfloor a / 2^p \rfloor$ (\textit{mp\_div\_2d}) \\
\hspace{3mm}2.2  $a \leftarrow a \mbox{ (mod }2^p\mbox{)}$ (\textit{mp\_mod\_2d}) \\
\hspace{3mm}2.3  $q \leftarrow q \cdot k$ (\textit{mp\_mul\_d}) \\
\hspace{3mm}2.4  $a \leftarrow a - q$ (\textit{s\_mp\_sub}) \\
\hspace{3mm}2.5  If $a \ge n$ then do \\
\hspace{6mm}2.5.1  $a \leftarrow a - n$ \\
3.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_reduce\_2k}
\end{figure}

\textbf{Algorithm mp\_reduce\_2k.}
This algorithm quickly reduces an input $a$ modulo an unrestricted Diminished Radix modulus $n$.  Division by $2^p$ is emulated with a right
shift which makes the algorithm fairly inexpensive to use.  

EXAM,bn_mp_reduce_2k.c

The algorithm mp\_count\_bits calculates the number of bits in an mp\_int which is used to find the initial value of $p$.  The call to mp\_div\_2d
on line @31,mp_div_2d@ calculates both the quotient $q$ and the remainder $a$ required.  By doing both in a single function call the code size
is kept fairly small.  The multiplication by $k$ is only performed if $k > 1$. This allows reductions modulo $2^p - 1$ to be performed without
any multiplications.  

The unsigned s\_mp\_add, mp\_cmp\_mag and s\_mp\_sub are used in place of their full sign counterparts since the inputs are only valid if they are 
positive.  By using the unsigned versions the overhead is kept to a minimum.  

\subsubsection{Unrestricted Setup}
To setup this reduction algorithm the value of $k = 2^p - n$ is required.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_reduce\_2k\_setup}. \\
\textbf{Input}.   mp\_int $n$   \\
\textbf{Output}.  $k = 2^p - n$ \\
\hline
1.  $p \leftarrow \lceil lg(n) \rceil$  (\textit{mp\_count\_bits}) \\
2.  $x \leftarrow 2^p$ (\textit{mp\_2expt}) \\
3.  $x \leftarrow x - n$ (\textit{mp\_sub}) \\
4.  $k \leftarrow x_0$ \\
5.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_reduce\_2k\_setup}
\end{figure}

\textbf{Algorithm mp\_reduce\_2k\_setup.}
This algorithm computes the value of $k$ required for the algorithm mp\_reduce\_2k.  By making a temporary variable $x$ equal to $2^p$ a subtraction
is sufficient to solve for $k$.  Alternatively if $n$ has more than one digit the value of $k$ is simply $\beta - n_0$.  

EXAM,bn_mp_reduce_2k_setup.c

\subsubsection{Unrestricted Detection}
An integer $n$ is a valid unrestricted Diminished Radix modulus if either of the following are true.

\begin{enumerate}
\item  The number has only one digit.
\item  The number has more than one digit and every bit from the $\beta$'th to the most significant is one.
\end{enumerate}

If either condition is true than there is a power of two $2^p$ such that $0 < 2^p - n < \beta$.   If the input is only
one digit than it will always be of the correct form.  Otherwise all of the bits above the first digit must be one.  This arises from the fact
that there will be value of $k$ that when added to the modulus causes a carry in the first digit which propagates all the way to the most
significant bit.  The resulting sum will be a power of two.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_reduce\_is\_2k}. \\
\textbf{Input}.   mp\_int $n$   \\
\textbf{Output}.  $1$ if of proper form, $0$ otherwise \\
\hline
1.  If $n.used = 0$ then return($0$). \\
2.  If $n.used = 1$ then return($1$). \\
3.  $p \leftarrow \lceil lg(n) \rceil$  (\textit{mp\_count\_bits}) \\
4.  for $x$ from $lg(\beta)$ to $p$ do \\
\hspace{3mm}4.1  If the ($x \mbox{ mod }lg(\beta)$)'th bit of the $\lfloor x / lg(\beta) \rfloor$ of $n$ is zero then return($0$). \\
5.  Return($1$). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_reduce\_is\_2k}
\end{figure}

\textbf{Algorithm mp\_reduce\_is\_2k.}
This algorithm quickly determines if a modulus is of the form required for algorithm mp\_reduce\_2k to function properly.  

EXAM,bn_mp_reduce_is_2k.c



\section{Algorithm Comparison}
So far three very different algorithms for modular reduction have been discussed.  Each of the algorithms have their own strengths and weaknesses
that makes having such a selection very useful.  The following table sumarizes the three algorithms along with comparisons of work factors.  Since
all three algorithms have the restriction that $0 \le x < n^2$ and $n > 1$ those limitations are not included in the table.  

\begin{center}
\begin{small}
\begin{tabular}{|c|c|c|c|c|c|}
\hline \textbf{Method} & \textbf{Work Required} & \textbf{Limitations} & \textbf{$m = 8$} & \textbf{$m = 32$} & \textbf{$m = 64$} \\
\hline Barrett    & $m^2 + 2m - 1$ & None              & $79$ & $1087$ & $4223$ \\
\hline Montgomery & $m^2 + m$      & $n$ must be odd   & $72$ & $1056$ & $4160$ \\
\hline D.R.       & $2m$           & $n = \beta^m - k$ & $16$ & $64$   & $128$  \\
\hline
\end{tabular}
\end{small}
\end{center}

In theory Montgomery and Barrett reductions would require roughly the same amount of time to complete.  However, in practice since Montgomery
reduction can be written as a single function with the Comba technique it is much faster.  Barrett reduction suffers from the overhead of
calling the half precision multipliers, addition and division by $\beta$ algorithms.

For almost every cryptographic algorithm Montgomery reduction is the algorithm of choice.  The one set of algorithms where Diminished Radix reduction truly
shines are based on the discrete logarithm problem such as Diffie-Hellman \cite{DH} and ElGamal \cite{ELGAMAL}.  In these algorithms
primes of the form $\beta^m - k$ can be found and shared amongst users.  These primes will allow the Diminished Radix algorithm to be used in
modular exponentiation to greatly speed up the operation.



\section*{Exercises}
\begin{tabular}{cl}
$\left [ 3 \right ]$ & Prove that the ``trick'' in algorithm mp\_montgomery\_setup actually \\
                     & calculates the correct value of $\rho$. \\
                     & \\
$\left [ 2 \right ]$ & Devise an algorithm to reduce modulo $n + k$ for small $k$ quickly.  \\
                     & \\
$\left [ 4 \right ]$ & Prove that the pseudo-code algorithm ``Diminished Radix Reduction'' \\
                     & (\textit{figure~\ref{fig:DR}}) terminates.  Also prove the probability that it will \\
                     & terminate within $1 \le k \le 10$ iterations. \\
                     & \\
\end{tabular}                     


\chapter{Exponentiation}
Exponentiation is the operation of raising one variable to the power of another, for example, $a^b$.  A variant of exponentiation, computed
in a finite field or ring, is called modular exponentiation.  This latter style of operation is typically used in public key 
cryptosystems such as RSA and Diffie-Hellman.  The ability to quickly compute modular exponentiations is of great benefit to any
such cryptosystem and many methods have been sought to speed it up.

\section{Exponentiation Basics}
A trivial algorithm would simply multiply $a$ against itself $b - 1$ times to compute the exponentiation desired.  However, as $b$ grows in size
the number of multiplications becomes prohibitive.  Imagine what would happen if $b$ $\approx$ $2^{1024}$ as is the case when computing an RSA signature
with a $1024$-bit key.  Such a calculation could never be completed as it would take simply far too long.

Fortunately there is a very simple algorithm based on the laws of exponents.  Recall that $lg_a(a^b) = b$ and that $lg_a(a^ba^c) = b + c$ which
are two trivial relationships between the base and the exponent.  Let $b_i$ represent the $i$'th bit of $b$ starting from the least 
significant bit.  If $b$ is a $k$-bit integer than the following equation is true.

\begin{equation}
a^b = \prod_{i=0}^{k-1} a^{2^i \cdot b_i}
\end{equation}

By taking the base $a$ logarithm of both sides of the equation the following equation is the result.

\begin{equation}
b = \sum_{i=0}^{k-1}2^i \cdot b_i
\end{equation}

The term $a^{2^i}$ can be found from the $i - 1$'th term by squaring the term since $\left ( a^{2^i} \right )^2$ is equal to
$a^{2^{i+1}}$.  This observation forms the basis of essentially all fast exponentiation algorithms.  It requires $k$ squarings and on average
$k \over 2$ multiplications to compute the result.  This is indeed quite an improvement over simply multiplying by $a$ a total of $b-1$ times.

While this current method is a considerable speed up there are further improvements to be made.  For example, the $a^{2^i}$ term does not need to 
be computed in an auxilary variable.  Consider the following equivalent algorithm.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Left to Right Exponentiation}. \\
\textbf{Input}.   Integer $a$, $b$ and $k$ \\
\textbf{Output}.  $c = a^b$ \\
\hline \\
1.  $c \leftarrow 1$ \\
2.  for $i$ from $k - 1$ to $0$ do \\
\hspace{3mm}2.1  $c \leftarrow c^2$ \\
\hspace{3mm}2.2  $c \leftarrow c \cdot a^{b_i}$ \\
3.  Return $c$. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Left to Right Exponentiation}
\label{fig:LTOR}
\end{figure}

This algorithm starts from the most significant bit and works towards the least significant bit.  When the $i$'th bit of $b$ is set $a$ is
multiplied against the current product.  In each iteration the product is squared which doubles the exponent of the individual terms of the
product.  

For example, let $b = 101100_2 \equiv 44_{10}$.  The following chart demonstrates the actions of the algorithm.

\newpage\begin{figure}
\begin{center}
\begin{tabular}{|c|c|}
\hline \textbf{Value of $i$} & \textbf{Value of $c$} \\
\hline - & $1$ \\
\hline $5$ & $a$ \\
\hline $4$ & $a^2$ \\
\hline $3$ & $a^4 \cdot a$ \\
\hline $2$ & $a^8 \cdot a^2 \cdot a$ \\
\hline $1$ & $a^{16} \cdot a^4 \cdot a^2$ \\
\hline $0$ & $a^{32} \cdot a^8 \cdot a^4$ \\
\hline
\end{tabular}
\end{center}
\caption{Example of Left to Right Exponentiation}
\end{figure}

When the product $a^{32} \cdot a^8 \cdot a^4$ is simplified it is equal $a^{44}$ which is the desired exponentiation.  This particular algorithm is 
called ``Left to Right'' because it reads the exponent in that order.  All of the exponentiation algorithms that will be presented are of this nature.  

\subsection{Single Digit Exponentiation}
The first algorithm in the series of exponentiation algorithms will be an unbounded algorithm where the exponent is a single digit.  It is intended 
to be used when a small power of an input is required (\textit{e.g. $a^5$}).  It is faster than simply multiplying $b - 1$ times for all values of 
$b$ that are greater than three.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_expt\_d}. \\
\textbf{Input}.   mp\_int $a$ and mp\_digit $b$ \\
\textbf{Output}.  $c = a^b$ \\
\hline \\
1.  $g \leftarrow a$ (\textit{mp\_init\_copy}) \\
2.  $c \leftarrow 1$ (\textit{mp\_set}) \\
3.  for $x$ from 1 to $lg(\beta)$ do \\
\hspace{3mm}3.1  $c \leftarrow c^2$ (\textit{mp\_sqr}) \\
\hspace{3mm}3.2  If $b$ AND $2^{lg(\beta) - 1} \ne 0$ then \\
\hspace{6mm}3.2.1  $c \leftarrow c \cdot g$ (\textit{mp\_mul}) \\
\hspace{3mm}3.3  $b \leftarrow b << 1$ \\
4.  Clear $g$. \\
5.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_expt\_d}
\end{figure}

\textbf{Algorithm mp\_expt\_d.}
This algorithm computes the value of $a$ raised to the power of a single digit $b$.  It uses the left to right exponentiation algorithm to
quickly compute the exponentiation.  It is loosely based on algorithm 14.79 of HAC \cite[pp. 615]{HAC} with the difference that the 
exponent is a fixed width.  

A copy of $a$ is made first to allow destination variable $c$ be the same as the source variable $a$.  The result is set to the initial value of 
$1$ in the subsequent step.

Inside the loop the exponent is read from the most significant bit first down to the least significant bit.  First $c$ is invariably squared
on step 3.1.  In the following step if the most significant bit of $b$ is one the copy of $a$ is multiplied against $c$.  The value
of $b$ is shifted left one bit to make the next bit down from the most signficant bit the new most significant bit.  In effect each
iteration of the loop moves the bits of the exponent $b$ upwards to the most significant location.

EXAM,bn_mp_expt_d.c

Line @29,mp_set@ sets the initial value of the result to $1$.  Next the loop on line @31,for@ steps through each bit of the exponent starting from
the most significant down towards the least significant. The invariant squaring operation placed on line @333,mp_sqr@ is performed first.  After 
the squaring the result $c$ is multiplied by the base $g$ if and only if the most significant bit of the exponent is set.  The shift on line
@47,<<@ moves all of the bits of the exponent upwards towards the most significant location.  

\section{$k$-ary Exponentiation}
When calculating an exponentiation the most time consuming bottleneck is the multiplications which are in general a small factor
slower than squaring.  Recall from the previous algorithm that $b_{i}$ refers to the $i$'th bit of the exponent $b$.  Suppose instead it referred to
the $i$'th $k$-bit digit of the exponent of $b$.  For $k = 1$ the definitions are synonymous and for $k > 1$ algorithm~\ref{fig:KARY}
computes the same exponentiation.  A group of $k$ bits from the exponent is called a \textit{window}.  That is it is a small window on only a
portion of the entire exponent.  Consider the following modification to the basic left to right exponentiation algorithm.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{$k$-ary Exponentiation}. \\
\textbf{Input}.   Integer $a$, $b$, $k$ and $t$ \\
\textbf{Output}.  $c = a^b$ \\
\hline \\
1.  $c \leftarrow 1$ \\
2.  for $i$ from $t - 1$ to $0$ do \\
\hspace{3mm}2.1  $c \leftarrow c^{2^k} $ \\
\hspace{3mm}2.2  Extract the $i$'th $k$-bit word from $b$ and store it in $g$. \\
\hspace{3mm}2.3  $c \leftarrow c \cdot a^g$ \\
3.  Return $c$. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{$k$-ary Exponentiation}
\label{fig:KARY}
\end{figure}

The squaring on step 2.1 can be calculated by squaring the value $c$ successively $k$ times.  If the values of $a^g$ for $0 < g < 2^k$ have been
precomputed this algorithm requires only $t$ multiplications and $tk$ squarings.  The table can be generated with $2^{k - 1} - 1$ squarings and
$2^{k - 1} + 1$ multiplications.  This algorithm assumes that the number of bits in the exponent is evenly divisible by $k$.  
However, when it is not the remaining $0 < x \le k - 1$ bits can be handled with algorithm~\ref{fig:LTOR}.

Suppose $k = 4$ and $t = 100$.  This modified algorithm will require $109$ multiplications and $408$ squarings to compute the exponentiation.  The
original algorithm would on average have required $200$ multiplications and $400$ squrings to compute the same value.  The total number of squarings
has increased slightly but the number of multiplications has nearly halved.

\subsection{Optimal Values of $k$}
An optimal value of $k$ will minimize $2^{k} + \lceil n / k \rceil + n - 1$ for a fixed number of bits in the exponent $n$.  The simplest
approach is to brute force search amongst the values $k = 2, 3, \ldots, 8$ for the lowest result.  Table~\ref{fig:OPTK} lists optimal values of $k$
for various exponent sizes and compares the number of multiplication and squarings required against algorithm~\ref{fig:LTOR}.  

\begin{figure}[here]
\begin{center}
\begin{small}
\begin{tabular}{|c|c|c|c|c|c|}
\hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:LTOR}} \\
\hline $16$ & $2$ & $27$ & $24$ \\
\hline $32$ & $3$ & $49$ & $48$ \\
\hline $64$ & $3$ & $92$ & $96$ \\
\hline $128$ & $4$ & $175$ & $192$ \\
\hline $256$ & $4$ & $335$ & $384$ \\
\hline $512$ & $5$ & $645$ & $768$ \\
\hline $1024$ & $6$ & $1257$ & $1536$ \\
\hline $2048$ & $6$ & $2452$ & $3072$ \\
\hline $4096$ & $7$ & $4808$ & $6144$ \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Optimal Values of $k$ for $k$-ary Exponentiation}
\label{fig:OPTK}
\end{figure}

\subsection{Sliding-Window Exponentiation}
A simple modification to the previous algorithm is only generate the upper half of the table in the range $2^{k-1} \le g < 2^k$.  Essentially
this is a table for all values of $g$ where the most significant bit of $g$ is a one.  However, in order for this to be allowed in the 
algorithm values of $g$ in the range $0 \le g < 2^{k-1}$ must be avoided.  

Table~\ref{fig:OPTK2} lists optimal values of $k$ for various exponent sizes and compares the work required against algorithm~\ref{fig:KARY}.  

\begin{figure}[here]
\begin{center}
\begin{small}
\begin{tabular}{|c|c|c|c|c|c|}
\hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:KARY}} \\
\hline $16$ & $3$ & $24$ & $27$ \\
\hline $32$ & $3$ & $45$ & $49$ \\
\hline $64$ & $4$ & $87$ & $92$ \\
\hline $128$ & $4$ & $167$ & $175$ \\
\hline $256$ & $5$ & $322$ & $335$ \\
\hline $512$ & $6$ & $628$ & $645$ \\
\hline $1024$ & $6$ & $1225$ & $1257$ \\
\hline $2048$ & $7$ & $2403$ & $2452$ \\
\hline $4096$ & $8$ & $4735$ & $4808$ \\
\hline
\end{tabular}
\end{small}
\end{center}
\caption{Optimal Values of $k$ for Sliding Window Exponentiation}
\label{fig:OPTK2}
\end{figure}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Sliding Window $k$-ary Exponentiation}. \\
\textbf{Input}.   Integer $a$, $b$, $k$ and $t$ \\
\textbf{Output}.  $c = a^b$ \\
\hline \\
1.  $c \leftarrow 1$ \\
2.  for $i$ from $t - 1$ to $0$ do \\
\hspace{3mm}2.1  If the $i$'th bit of $b$ is a zero then \\
\hspace{6mm}2.1.1   $c \leftarrow c^2$ \\
\hspace{3mm}2.2  else do \\
\hspace{6mm}2.2.1  $c \leftarrow c^{2^k}$ \\
\hspace{6mm}2.2.2  Extract the $k$ bits from $(b_{i}b_{i-1}\ldots b_{i-(k-1)})$ and store it in $g$. \\
\hspace{6mm}2.2.3  $c \leftarrow c \cdot a^g$ \\
\hspace{6mm}2.2.4  $i \leftarrow i - k$ \\
3.  Return $c$. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Sliding Window $k$-ary Exponentiation}
\end{figure}

Similar to the previous algorithm this algorithm must have a special handler when fewer than $k$ bits are left in the exponent.  While this
algorithm requires the same number of squarings it can potentially have fewer multiplications.  The pre-computed table $a^g$ is also half
the size as the previous table.  

Consider the exponent $b = 111101011001000_2 \equiv 31432_{10}$ with $k = 3$ using both algorithms.  The first algorithm will divide the exponent up as 
the following five $3$-bit words $b \equiv \left ( 111, 101, 011, 001, 000 \right )_{2}$.  The second algorithm will break the 
exponent as $b \equiv \left ( 111, 101, 0, 110, 0, 100, 0 \right )_{2}$.  The single digit $0$ in the second representation are where
a single squaring took place instead of a squaring and multiplication.  In total the first method requires $10$ multiplications and $18$ 
squarings.  The second method requires $8$ multiplications and $18$ squarings.  

In general the sliding window method is never slower than the generic $k$-ary method and often it is slightly faster.  

\section{Modular Exponentiation}

Modular exponentiation is essentially computing the power of a base within a finite field or ring.  For example, computing 
$d \equiv a^b \mbox{ (mod }c\mbox{)}$ is a modular exponentiation.  Instead of first computing $a^b$ and then reducing it 
modulo $c$ the intermediate result is reduced modulo $c$ after every squaring or multiplication operation.  

This guarantees that any intermediate result is bounded by $0 \le d \le c^2 - 2c + 1$ and can be reduced modulo $c$ quickly using
one of the algorithms presented in ~REDUCTION~.  

Before the actual modular exponentiation algorithm can be written a wrapper algorithm must be written first.  This algorithm
will allow the exponent $b$ to be negative which is computed as $c \equiv \left (1 / a \right )^{\vert b \vert} \mbox{(mod }d\mbox{)}$. The
value of $(1/a) \mbox{ mod }c$ is computed using the modular inverse (\textit{see \ref{sec;modinv}}).  If no inverse exists the algorithm
terminates with an error.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_exptmod}. \\
\textbf{Input}.   mp\_int $a$, $b$ and $c$ \\
\textbf{Output}.  $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\
\hline \\
1.  If $c.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\
2.  If $b.sign = MP\_NEG$ then \\
\hspace{3mm}2.1  $g' \leftarrow g^{-1} \mbox{ (mod }c\mbox{)}$ \\
\hspace{3mm}2.2  $x' \leftarrow \vert x \vert$ \\
\hspace{3mm}2.3  Compute $d \equiv g'^{x'} \mbox{ (mod }c\mbox{)}$ via recursion. \\
3.  if $p$ is odd \textbf{OR} $p$ is a D.R. modulus then \\
\hspace{3mm}3.1  Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm mp\_exptmod\_fast. \\
4.  else \\
\hspace{3mm}4.1  Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm s\_mp\_exptmod. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_exptmod}
\end{figure}

\textbf{Algorithm mp\_exptmod.}
The first algorithm which actually performs modular exponentiation is algorithm s\_mp\_exptmod.  It is a sliding window $k$-ary algorithm 
which uses Barrett reduction to reduce the product modulo $p$.  The second algorithm mp\_exptmod\_fast performs the same operation 
except it uses either Montgomery or Diminished Radix reduction.  The two latter reduction algorithms are clumped in the same exponentiation
algorithm since their arguments are essentially the same (\textit{two mp\_ints and one mp\_digit}).  

EXAM,bn_mp_exptmod.c

In order to keep the algorithms in a known state the first step on line @29,if@ is to reject any negative modulus as input.  If the exponent is
negative the algorithm tries to perform a modular exponentiation with the modular inverse of the base $G$.  The temporary variable $tmpG$ is assigned
the modular inverse of $G$ and $tmpX$ is assigned the absolute value of $X$.  The algorithm will recuse with these new values with a positive
exponent.

If the exponent is positive the algorithm resumes the exponentiation.  Line @63,dr_@ determines if the modulus is of the restricted Diminished Radix 
form.  If it is not line @65,reduce@ attempts to determine if it is of a unrestricted Diminished Radix form.  The integer $dr$ will take on one
of three values.

\begin{enumerate}
\item $dr = 0$ means that the modulus is not of either restricted or unrestricted Diminished Radix form.
\item $dr = 1$ means that the modulus is of restricted Diminished Radix form.
\item $dr = 2$ means that the modulus is of unrestricted Diminished Radix form.
\end{enumerate}

Line @69,if@ determines if the fast modular exponentiation algorithm can be used.  It is allowed if $dr \ne 0$ or if the modulus is odd.  Otherwise,
the slower s\_mp\_exptmod algorithm is used which uses Barrett reduction.  

\subsection{Barrett Modular Exponentiation}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{s\_mp\_exptmod}. \\
\textbf{Input}.   mp\_int $a$, $b$ and $c$ \\
\textbf{Output}.  $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\
\hline \\
1.  $k \leftarrow lg(x)$ \\
2.  $winsize \leftarrow  \left \lbrace \begin{array}{ll}
                              2 &  \mbox{if }k \le 7 \\
                              3 &  \mbox{if }7 < k \le 36 \\
                              4 &  \mbox{if }36 < k \le 140 \\
                              5 &  \mbox{if }140 < k \le 450 \\
                              6 &  \mbox{if }450 < k \le 1303 \\
                              7 &  \mbox{if }1303 < k \le 3529 \\
                              8 &  \mbox{if }3529 < k \\
                              \end{array} \right .$ \\
3.  Initialize $2^{winsize}$ mp\_ints in an array named $M$ and one mp\_int named $\mu$ \\
4.  Calculate the $\mu$ required for Barrett Reduction (\textit{mp\_reduce\_setup}). \\
5.  $M_1 \leftarrow g \mbox{ (mod }p\mbox{)}$ \\
\\
Setup the table of small powers of $g$.  First find $g^{2^{winsize}}$ and then all multiples of it. \\
6.  $k \leftarrow 2^{winsize - 1}$ \\
7.  $M_{k} \leftarrow M_1$ \\
8.  for $ix$ from 0 to $winsize - 2$ do \\
\hspace{3mm}8.1  $M_k \leftarrow \left ( M_k \right )^2$ (\textit{mp\_sqr})  \\
\hspace{3mm}8.2  $M_k \leftarrow M_k \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\
9.  for $ix$ from $2^{winsize - 1} + 1$ to $2^{winsize} - 1$ do \\
\hspace{3mm}9.1  $M_{ix} \leftarrow M_{ix - 1} \cdot M_{1}$ (\textit{mp\_mul}) \\
\hspace{3mm}9.2  $M_{ix} \leftarrow M_{ix} \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\
10.  $res \leftarrow 1$ \\
\\
Start Sliding Window. \\
11.  $mode \leftarrow 0, bitcnt \leftarrow 1, buf \leftarrow 0, digidx \leftarrow x.used - 1, bitcpy \leftarrow 0, bitbuf \leftarrow 0$ \\
12.  Loop \\
\hspace{3mm}12.1  $bitcnt \leftarrow bitcnt - 1$ \\
\hspace{3mm}12.2  If $bitcnt = 0$ then do \\
\hspace{6mm}12.2.1  If $digidx = -1$ goto step 13. \\
\hspace{6mm}12.2.2  $buf \leftarrow x_{digidx}$ \\
\hspace{6mm}12.2.3  $digidx \leftarrow digidx - 1$ \\
\hspace{6mm}12.2.4  $bitcnt \leftarrow lg(\beta)$ \\
Continued on next page. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm s\_mp\_exptmod}
\end{figure}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{s\_mp\_exptmod} (\textit{continued}). \\
\textbf{Input}.   mp\_int $a$, $b$ and $c$ \\
\textbf{Output}.  $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\
\hline \\
\hspace{3mm}12.3  $y \leftarrow (buf >> (lg(\beta) - 1))$ AND $1$ \\
\hspace{3mm}12.4  $buf \leftarrow buf << 1$ \\
\hspace{3mm}12.5  if $mode = 0$ and $y = 0$ then goto step 12. \\
\hspace{3mm}12.6  if $mode = 1$ and $y = 0$ then do \\
\hspace{6mm}12.6.1  $res \leftarrow res^2$ \\
\hspace{6mm}12.6.2  $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\
\hspace{6mm}12.6.3  Goto step 12. \\
\hspace{3mm}12.7  $bitcpy \leftarrow bitcpy + 1$ \\
\hspace{3mm}12.8  $bitbuf \leftarrow bitbuf + (y << (winsize - bitcpy))$ \\
\hspace{3mm}12.9  $mode \leftarrow 2$ \\
\hspace{3mm}12.10  If $bitcpy = winsize$ then do \\
\hspace{6mm}Window is full so perform the squarings and single multiplication. \\
\hspace{6mm}12.10.1  for $ix$ from $0$ to $winsize -1$ do \\
\hspace{9mm}12.10.1.1  $res \leftarrow res^2$ \\
\hspace{9mm}12.10.1.2  $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\
\hspace{6mm}12.10.2  $res \leftarrow res \cdot M_{bitbuf}$ \\
\hspace{6mm}12.10.3  $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\
\hspace{6mm}Reset the window. \\
\hspace{6mm}12.10.4  $bitcpy \leftarrow 0, bitbuf \leftarrow 0, mode \leftarrow 1$ \\
\\
No more windows left.  Check for residual bits of exponent. \\
13.  If $mode = 2$ and $bitcpy > 0$ then do \\
\hspace{3mm}13.1  for $ix$ form $0$ to $bitcpy - 1$ do \\
\hspace{6mm}13.1.1  $res \leftarrow res^2$ \\
\hspace{6mm}13.1.2  $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\
\hspace{6mm}13.1.3  $bitbuf \leftarrow bitbuf << 1$ \\
\hspace{6mm}13.1.4  If $bitbuf$ AND $2^{winsize} \ne 0$ then do \\
\hspace{9mm}13.1.4.1  $res \leftarrow res \cdot M_{1}$ \\
\hspace{9mm}13.1.4.2  $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\
14.  $y \leftarrow res$ \\
15.  Clear $res$, $mu$ and the $M$ array. \\
16.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm s\_mp\_exptmod (continued)}
\end{figure}

\textbf{Algorithm s\_mp\_exptmod.}
This algorithm computes the $x$'th power of $g$ modulo $p$ and stores the result in $y$.  It takes advantage of the Barrett reduction
algorithm to keep the product small throughout the algorithm.

The first two steps determine the optimal window size based on the number of bits in the exponent.  The larger the exponent the 
larger the window size becomes.  After a window size $winsize$ has been chosen an array of $2^{winsize}$ mp\_int variables is allocated.  This
table will hold the values of $g^x \mbox{ (mod }p\mbox{)}$ for $2^{winsize - 1} \le x < 2^{winsize}$.  

After the table is allocated the first power of $g$ is found.  Since $g \ge p$ is allowed it must be first reduced modulo $p$ to make
the rest of the algorithm more efficient.  The first element of the table at $2^{winsize - 1}$ is found by squaring $M_1$ successively $winsize - 2$
times.  The rest of the table elements are found by multiplying the previous element by $M_1$ modulo $p$.

Now that the table is available the sliding window may begin.  The following list describes the functions of all the variables in the window.
\begin{enumerate}
\item The variable $mode$ dictates how the bits of the exponent are interpreted.  
\begin{enumerate}
   \item When $mode = 0$ the bits are ignored since no non-zero bit of the exponent has been seen yet.  For example, if the exponent were simply 
         $1$ then there would be $lg(\beta) - 1$ zero bits before the first non-zero bit.  In this case bits are ignored until a non-zero bit is found.  
   \item When $mode = 1$ a non-zero bit has been seen before and a new $winsize$-bit window has not been formed yet.  In this mode leading $0$ bits 
         are read and a single squaring is performed.  If a non-zero bit is read a new window is created.  
   \item When $mode = 2$ the algorithm is in the middle of forming a window and new bits are appended to the window from the most significant bit
         downwards.
\end{enumerate}
\item The variable $bitcnt$ indicates how many bits are left in the current digit of the exponent left to be read.  When it reaches zero a new digit
      is fetched from the exponent.
\item The variable $buf$ holds the currently read digit of the exponent. 
\item The variable $digidx$ is an index into the exponents digits.  It starts at the leading digit $x.used - 1$ and moves towards the trailing digit.
\item The variable $bitcpy$ indicates how many bits are in the currently formed window.  When it reaches $winsize$ the window is flushed and
      the appropriate operations performed.
\item The variable $bitbuf$ holds the current bits of the window being formed.  
\end{enumerate}

All of step 12 is the window processing loop.  It will iterate while there are digits available form the exponent to read.  The first step
inside this loop is to extract a new digit if no more bits are available in the current digit.  If there are no bits left a new digit is
read and if there are no digits left than the loop terminates.  

After a digit is made available step 12.3 will extract the most significant bit of the current digit and move all other bits in the digit
upwards.  In effect the digit is read from most significant bit to least significant bit and since the digits are read from leading to 
trailing edges the entire exponent is read from most significant bit to least significant bit.

At step 12.5 if the $mode$ and currently extracted bit $y$ are both zero the bit is ignored and the next bit is read.  This prevents the 
algorithm from having to perform trivial squaring and reduction operations before the first non-zero bit is read.  Step 12.6 and 12.7-10 handle
the two cases of $mode = 1$ and $mode = 2$ respectively.  

FIGU,expt_state,Sliding Window State Diagram

By step 13 there are no more digits left in the exponent.  However, there may be partial bits in the window left.  If $mode = 2$ then 
a Left-to-Right algorithm is used to process the remaining few bits.  

EXAM,bn_s_mp_exptmod.c

Lines @26,if@ through @40,}@ determine the optimal window size based on the length of the exponent in bits.  The window divisions are sorted
from smallest to greatest so that in each \textbf{if} statement only one condition must be tested.  For example, by the \textbf{if} statement 
on line @32,if@ the value of $x$ is already known to be greater than $140$.  

The conditional piece of code beginning on line @42,ifdef@ allows the window size to be restricted to five bits.  This logic is used to ensure
the table of precomputed powers of $G$ remains relatively small.  

The for loop on line @49,for@ initializes the $M$ array while lines @59,mp_init@ and @62,mp_reduce@ compute the value of $\mu$ required for
Barrett reduction.  

-- More later.

\section{Quick Power of Two}
Calculating $b = 2^a$ can be performed much quicker than with any of the previous algorithms.  Recall that a logical shift left $m << k$ is
equivalent to $m \cdot 2^k$.  By this logic when $m = 1$ a quick power of two can be achieved.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_2expt}. \\
\textbf{Input}.   integer $b$ \\
\textbf{Output}.  $a \leftarrow 2^b$ \\
\hline \\
1.  $a \leftarrow 0$ \\
2.  If $a.alloc < \lfloor b / lg(\beta) \rfloor + 1$ then grow $a$ appropriately. \\
3.  $a.used \leftarrow \lfloor b / lg(\beta) \rfloor + 1$ \\
4.  $a_{\lfloor b / lg(\beta) \rfloor} \leftarrow 1 << (b \mbox{ mod } lg(\beta))$ \\
5.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_2expt}
\end{figure}

\textbf{Algorithm mp\_2expt.}

EXAM,bn_mp_2expt.c

\chapter{Higher Level Algorithms}

This chapter discusses the various higher level algorithms that are required to complete a well rounded multiple precision integer package.  These
routines are less performance oriented than the algorithms of chapters five, six and seven but are no less important.  

The first section describes a method of integer division with remainder that is universally well known.  It provides the signed division logic
for the package.  The subsequent section discusses a set of algorithms which allow a single digit to be the 2nd operand for a variety of operations.  
These algorithms serve mostly to simplify other algorithms where small constants are required.  The last two sections discuss how to manipulate 
various representations of integers.  For example, converting from an mp\_int to a string of character.

\section{Integer Division with Remainder}
\label{sec:division}

Integer division aside from modular exponentiation is the most intensive algorithm to compute.  Like addition, subtraction and multiplication
the basis of this algorithm is the long-hand division algorithm taught to school children.  Throughout this discussion several common variables
will be used.  Let $x$ represent the divisor and $y$ represent the dividend.  Let $q$ represent the integer quotient $\lfloor y / x \rfloor$ and 
let $r$ represent the remainder $r = y - x \lfloor y / x \rfloor$.  The following simple algorithm will be used to start the discussion.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Radix-$\beta$ Integer Division}. \\
\textbf{Input}.   integer $x$ and $y$ \\
\textbf{Output}.  $q = \lfloor y/x\rfloor, r = y - xq$ \\
\hline \\
1.  $q \leftarrow 0$ \\
2.  $n \leftarrow \vert \vert y \vert \vert - \vert \vert x \vert \vert$ \\
3.  for $t$ from $n$ down to $0$ do \\
\hspace{3mm}3.1  Maximize $k$ such that $kx\beta^t$ is less than or equal to $y$ and $(k + 1)x\beta^t$ is greater. \\
\hspace{3mm}3.2  $q \leftarrow q + k\beta^t$ \\
\hspace{3mm}3.3  $y \leftarrow y - kx\beta^t$ \\
4.  $r \leftarrow y$ \\
5.  Return($q, r$) \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Radix-$\beta$ Integer Division}
\label{fig:raddiv}
\end{figure}

As children we are taught this very simple algorithm for the case of $\beta = 10$.  Almost instinctively several optimizations are taught for which
their reason of existing are never explained.  For this example let $y = 5471$ represent the dividend and $x = 23$ represent the divisor.

To find the first digit of the quotient the value of $k$ must be maximized such that $kx\beta^t$ is less than or equal to $y$ and 
simultaneously $(k + 1)x\beta^t$ is greater than $y$.  Implicitly $k$ is the maximum value the $t$'th digit of the quotient may have.  The habitual method
used to find the maximum is to ``eyeball'' the two numbers, typically only the leading digits and quickly estimate a quotient.  By only using leading
digits a much simpler division may be used to form an educated guess at what the value must be.  In this case $k = \lfloor 54/23\rfloor = 2$ quickly 
arises as a possible  solution.  Indeed $2x\beta^2 = 4600$ is less than $y = 5471$ and simultaneously $(k + 1)x\beta^2 = 6900$ is larger than $y$.  
As a  result $k\beta^2$ is added to the quotient which now equals $q = 200$ and $4600$ is subtracted from $y$ to give a remainder of $y = 841$.

Again this process is repeated to produce the quotient digit $k = 3$ which makes the quotient $q = 200 + 3\beta = 230$ and the remainder 
$y = 841 - 3x\beta = 181$.  Finally the last iteration of the loop produces $k = 7$ which leads to the quotient $q = 230 + 7 = 237$ and the
remainder $y = 181 - 7x = 20$.  The final quotient and remainder found are $q = 237$ and $r = y = 20$ which are indeed correct since 
$237 \cdot 23 + 20 = 5471$ is true.  

\subsection{Quotient Estimation}
\label{sec:divest}
As alluded to earlier the quotient digit $k$ can be estimated from only the leading digits of both the divisor and dividend.  When $p$ leading
digits are used from both the divisor and dividend to form an estimation the accuracy of the estimation rises as $p$ grows.  Technically
speaking the estimation is based on assuming the lower $\vert \vert y \vert \vert - p$ and $\vert \vert x \vert \vert - p$ lower digits of the
dividend and divisor are zero.  

The value of the estimation may off by a few values in either direction and in general is fairly correct.  A simplification \cite[pp. 271]{TAOCPV2}
of the estimation technique is to use $t + 1$ digits of the dividend and $t$ digits of the divisor, in particularly when $t = 1$.  The estimate 
using this technique is never too small.  For the following proof let $t = \vert \vert y \vert \vert - 1$ and $s = \vert \vert x \vert \vert - 1$ 
represent the most significant digits of the dividend and divisor respectively.

\textbf{Proof.}\textit{  The quotient $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ is greater than or equal to 
$k = \lfloor y / (x \cdot \beta^{\vert \vert y \vert \vert - \vert \vert x \vert \vert - 1}) \rfloor$. }
The first obvious case is when $\hat k = \beta - 1$ in which case the proof is concluded since the real quotient cannot be larger.  For all other 
cases $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ and $\hat k x_s \ge y_t\beta + y_{t-1} - x_s + 1$.  The latter portion of the inequalility
$-x_s + 1$ arises from the fact that a truncated integer division will give the same quotient for at most $x_s - 1$ values.  Next a series of 
inequalities will prove the hypothesis.

\begin{equation}
y - \hat k x \le y - \hat k x_s\beta^s
\end{equation}

This is trivially true since $x \ge x_s\beta^s$.  Next we replace $\hat kx_s\beta^s$ by the previous inequality for $\hat kx_s$.  

\begin{equation}
y - \hat k x \le y_t\beta^t + \ldots + y_0 - (y_t\beta^t + y_{t-1}\beta^{t-1} - x_s\beta^t + \beta^s)
\end{equation}

By simplifying the previous inequality the following inequality is formed.

\begin{equation}
y - \hat k x \le y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s
\end{equation}

Subsequently,

\begin{equation}
y_{t-2}\beta^{t-2} + \ldots +  y_0  + x_s\beta^s - \beta^s < x_s\beta^s \le x
\end{equation}

Which proves that $y - \hat kx \le x$ and by consequence $\hat k \ge k$ which concludes the proof.  \textbf{QED}


\subsection{Normalized Integers}
For the purposes of division a normalized input is when the divisors leading digit $x_n$ is greater than or equal to $\beta / 2$.  By multiplying both
$x$ and $y$ by $j = \lfloor (\beta / 2) / x_n \rfloor$ the quotient remains unchanged and the remainder is simply $j$ times the original
remainder.  The purpose of normalization is to ensure the leading digit of the divisor is sufficiently large such that the estimated quotient will
lie in the domain of a single digit.  Consider the maximum dividend $(\beta - 1) \cdot \beta + (\beta - 1)$ and the minimum divisor $\beta / 2$.  

\begin{equation} 
{{\beta^2 - 1} \over { \beta / 2}} \le 2\beta - {2 \over \beta} 
\end{equation}

At most the quotient approaches $2\beta$, however, in practice this will not occur since that would imply the previous quotient digit was too small.  

\subsection{Radix-$\beta$ Division with Remainder}
\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_div}. \\
\textbf{Input}.   mp\_int $a, b$ \\
\textbf{Output}.  $c = \lfloor a/b \rfloor$, $d = a - bc$ \\
\hline \\
1.  If $b = 0$ return(\textit{MP\_VAL}). \\
2.  If $\vert a \vert < \vert b \vert$ then do \\
\hspace{3mm}2.1  $d \leftarrow a$ \\
\hspace{3mm}2.2  $c \leftarrow 0$ \\
\hspace{3mm}2.3  Return(\textit{MP\_OKAY}). \\
\\
Setup the quotient to receive the digits. \\
3.  Grow $q$ to $a.used + 2$ digits. \\
4.  $q \leftarrow 0$ \\
5.  $x \leftarrow \vert a \vert , y \leftarrow \vert b \vert$ \\
6.  $sign \leftarrow  \left \lbrace \begin{array}{ll}
                              MP\_ZPOS &  \mbox{if }a.sign = b.sign \\
                              MP\_NEG  &  \mbox{otherwise} \\
                              \end{array} \right .$ \\
\\
Normalize the inputs such that the leading digit of $y$ is greater than or equal to $\beta / 2$. \\
7.  $norm \leftarrow (lg(\beta) - 1) - (\lceil lg(y) \rceil \mbox{ (mod }lg(\beta)\mbox{)})$ \\
8.  $x \leftarrow x \cdot 2^{norm}, y \leftarrow y \cdot 2^{norm}$ \\
\\
Find the leading digit of the quotient. \\
9.  $n \leftarrow x.used - 1, t \leftarrow y.used - 1$ \\
10.  $y \leftarrow y \cdot \beta^{n - t}$ \\
11.  While ($x \ge y$) do \\
\hspace{3mm}11.1  $q_{n - t} \leftarrow q_{n - t} + 1$ \\
\hspace{3mm}11.2  $x \leftarrow x - y$ \\
12.  $y \leftarrow \lfloor y / \beta^{n-t} \rfloor$ \\
\\
Continued on the next page. \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_div}
\end{figure}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_div} (continued). \\
\textbf{Input}.   mp\_int $a, b$ \\
\textbf{Output}.  $c = \lfloor a/b \rfloor$, $d = a - bc$ \\
\hline \\
Now find the remainder fo the digits. \\
13.  for $i$ from $n$ down to $(t + 1)$ do \\
\hspace{3mm}13.1  If $i > x.used$ then jump to the next iteration of this loop. \\
\hspace{3mm}13.2  If $x_{i} = y_{t}$ then \\
\hspace{6mm}13.2.1  $q_{i - t - 1} \leftarrow \beta - 1$ \\
\hspace{3mm}13.3  else \\
\hspace{6mm}13.3.1  $\hat r \leftarrow x_{i} \cdot \beta + x_{i - 1}$ \\
\hspace{6mm}13.3.2  $\hat r \leftarrow \lfloor \hat r / y_{t} \rfloor$ \\
\hspace{6mm}13.3.3  $q_{i - t - 1} \leftarrow \hat r$ \\
\hspace{3mm}13.4  $q_{i - t - 1} \leftarrow q_{i - t - 1} + 1$ \\
\\
Fixup quotient estimation. \\
\hspace{3mm}13.5  Loop \\
\hspace{6mm}13.5.1  $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\
\hspace{6mm}13.5.2  t$1 \leftarrow 0$ \\
\hspace{6mm}13.5.3  t$1_0 \leftarrow y_{t - 1}, $ t$1_1 \leftarrow y_t,$ t$1.used \leftarrow 2$ \\
\hspace{6mm}13.5.4  $t1 \leftarrow t1 \cdot q_{i - t - 1}$ \\
\hspace{6mm}13.5.5  t$2_0 \leftarrow x_{i - 2}, $ t$2_1 \leftarrow x_{i - 1}, $ t$2_2 \leftarrow x_i, $ t$2.used \leftarrow 3$ \\
\hspace{6mm}13.5.6  If $\vert t1 \vert > \vert t2 \vert$ then goto step 13.5. \\
\hspace{3mm}13.6  t$1 \leftarrow y \cdot q_{i - t - 1}$ \\
\hspace{3mm}13.7  t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\
\hspace{3mm}13.8  $x \leftarrow x - $ t$1$ \\
\hspace{3mm}13.9  If $x.sign = MP\_NEG$ then \\
\hspace{6mm}13.10  t$1 \leftarrow y$ \\
\hspace{6mm}13.11  t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\
\hspace{6mm}13.12  $x \leftarrow x + $ t$1$ \\
\hspace{6mm}13.13  $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\
\\
Finalize the result. \\
14.  Clamp excess digits of $q$ \\
15.  $c \leftarrow q, c.sign \leftarrow sign$ \\
16.  $x.sign \leftarrow a.sign$ \\
17.  $d \leftarrow \lfloor x / 2^{norm} \rfloor$ \\
18.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_div (continued)}
\end{figure}
\textbf{Algorithm mp\_div.}
This algorithm will calculate quotient and remainder from an integer division given a dividend and divisor.  The algorithm is a signed
division and will produce a fully qualified quotient and remainder.

First the divisor $b$ must be non-zero which is enforced in step one.  If the divisor is larger than the dividend than the quotient is implicitly 
zero and the remainder is the dividend.  

After the first two trivial cases of inputs are handled the variable $q$ is setup to receive the digits of the quotient.  Two unsigned copies of the
divisor $y$ and dividend $x$ are made as well.  The core of the division algorithm is an unsigned division and will only work if the values are
positive.  Now the two values $x$ and $y$ must be normalized such that the leading digit of $y$ is greater than or equal to $\beta / 2$.  
This is performed by shifting both to the left by enough bits to get the desired normalization.  

At this point the division algorithm can begin producing digits of the quotient.  Recall that maximum value of the estimation used is 
$2\beta - {2 \over \beta}$ which means that a digit of the quotient must be first produced by another means.  In this case $y$ is shifted
to the left (\textit{step ten}) so that it has the same number of digits as $x$.  The loop on step eleven will subtract multiples of the 
shifted copy of $y$ until $x$ is smaller.  Since the leading digit of $y$ is greater than or equal to $\beta/2$ this loop will iterate at most two
times to produce the desired leading digit of the quotient.  

Now the remainder of the digits can be produced.  The equation $\hat q = \lfloor {{x_i \beta + x_{i-1}}\over y_t} \rfloor$ is used to fairly
accurately approximate the true quotient digit.  The estimation can in theory produce an estimation as high as $2\beta - {2 \over \beta}$ but by
induction the upper quotient digit is correct (\textit{as established on step eleven}) and the estimate must be less than $\beta$.  

Recall from section~\ref{sec:divest} that the estimation is never too low but may be too high.  The next step of the estimation process is
to refine the estimation.  The loop on step 13.5 uses $x_i\beta^2 + x_{i-1}\beta + x_{i-2}$ and $q_{i - t - 1}(y_t\beta + y_{t-1})$ as a higher
order approximation to adjust the quotient digit.

After both phases of estimation the quotient digit may still be off by a value of one\footnote{This is similar to the error introduced
by optimizing Barrett reduction.}.  Steps 13.6 and 13.7 subtract the multiple of the divisor from the dividend (\textit{Similar to step 3.3 of
algorithm~\ref{fig:raddiv}} and then subsequently add a multiple of the divisor if the quotient was too large.  

Now that the quotient has been determine finializing the result is a matter of clamping the quotient, fixing the sizes and de-normalizing the 
remainder.  An important aspect of this algorithm seemingly overlooked in other descriptions such as that of Algorithm 14.20 HAC \cite[pp. 598]{HAC}
is that when the estimations are being made (\textit{inside the loop on step 13.5}) that the digits $y_{t-1}$, $x_{i-2}$ and $x_{i-1}$ may lie 
outside their respective boundaries.  For example, if $t = 0$ or $i \le 1$ then the digits would be undefined.  In those cases the digits should
respectively be replaced with a zero.  

EXAM,bn_mp_div.c

The implementation of this algorithm differs slightly from the pseudo code presented previously.  In this algorithm either of the quotient $c$ or
remainder $d$ may be passed as a \textbf{NULL} pointer which indicates their value is not desired.  For example, the C code to call the division
algorithm with only the quotient is 

\begin{verbatim}
mp_div(&a, &b, &c, NULL);  /* c = [a/b] */
\end{verbatim}

Lines @37,if@ and @42,if@ handle the two trivial cases of inputs which are division by zero and dividend smaller than the divisor 
respectively.  After the two trivial cases all of the temporary variables are initialized.  Line @76,neg@ determines the sign of 
the quotient and line @77,sign@ ensures that both $x$ and $y$ are positive.  

The number of bits in the leading digit is calculated on line @80,norm@.  Implictly an mp\_int with $r$ digits will require $lg(\beta)(r-1) + k$ bits
of precision which when reduced modulo $lg(\beta)$ produces the value of $k$.  In this case $k$ is the number of bits in the leading digit which is
exactly what is required.  For the algorithm to operate $k$ must equal $lg(\beta) - 1$ and when it does not the inputs must be normalized by shifting
them to the left by $lg(\beta) - 1 - k$ bits.

Throughout the variables $n$ and $t$ will represent the highest digit of $x$ and $y$ respectively.  These are first used to produce the 
leading digit of the quotient.  The loop beginning on line @113,for@ will produce the remainder of the quotient digits.

The conditional ``continue'' on line @114,if@ is used to prevent the algorithm from reading past the leading edge of $x$ which can occur when the
algorithm eliminates multiple non-zero digits in a single iteration.  This ensures that $x_i$ is always non-zero since by definition the digits
above the $i$'th position $x$ must be zero in order for the quotient to be precise\footnote{Precise as far as integer division is concerned.}.  

Lines @142,t1@, @143,t1@ and @150,t2@ through @152,t2@ manually construct the high accuracy estimations by setting the digits of the two mp\_int 
variables directly.  

\section{Single Digit Helpers}

This section briefly describes a series of single digit helper algorithms which come in handy when working with small constants.  All of 
the helper functions assume the single digit input is positive and will treat them as such.

\subsection{Single Digit Addition and Subtraction}

Both addition and subtraction are performed by ``cheating'' and using mp\_set followed by the higher level addition or subtraction 
algorithms.   As a result these algorithms are subtantially simpler with a slight cost in performance.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_add\_d}. \\
\textbf{Input}.   mp\_int $a$ and a mp\_digit $b$ \\
\textbf{Output}.  $c = a + b$ \\
\hline \\
1.  $t \leftarrow b$ (\textit{mp\_set}) \\
2.  $c \leftarrow a + t$ \\
3.  Return(\textit{MP\_OKAY}) \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_add\_d}
\end{figure}

\textbf{Algorithm mp\_add\_d.}
This algorithm initiates a temporary mp\_int with the value of the single digit and uses algorithm mp\_add to add the two values together.

EXAM,bn_mp_add_d.c

Clever use of the letter 't'.

\subsubsection{Subtraction}
The single digit subtraction algorithm mp\_sub\_d is essentially the same except it uses mp\_sub to subtract the digit from the mp\_int.

\subsection{Single Digit Multiplication}
Single digit multiplication arises enough in division and radix conversion that it ought to be implement as a special case of the baseline
multiplication algorithm.  Essentially this algorithm is a modified version of algorithm s\_mp\_mul\_digs where one of the multiplicands
only has one digit.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_mul\_d}. \\
\textbf{Input}.   mp\_int $a$ and a mp\_digit $b$ \\
\textbf{Output}.  $c = ab$ \\
\hline \\
1.  $pa \leftarrow a.used$ \\
2.  Grow $c$ to at least $pa + 1$ digits. \\
3.  $oldused \leftarrow c.used$ \\
4.  $c.used \leftarrow pa + 1$ \\
5.  $c.sign \leftarrow a.sign$ \\
6.  $\mu \leftarrow 0$ \\
7.  for $ix$ from $0$ to $pa - 1$ do \\
\hspace{3mm}7.1  $\hat r \leftarrow \mu + a_{ix}b$ \\
\hspace{3mm}7.2  $c_{ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\
\hspace{3mm}7.3  $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\
8.  $c_{pa} \leftarrow \mu$ \\
9.  for $ix$ from $pa + 1$ to $oldused$ do \\
\hspace{3mm}9.1  $c_{ix} \leftarrow 0$ \\
10.  Clamp excess digits of $c$. \\
11.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_mul\_d}
\end{figure}
\textbf{Algorithm mp\_mul\_d.}
This algorithm quickly multiplies an mp\_int by a small single digit value.  It is specially tailored to the job and has a minimal of overhead.  
Unlike the full multiplication algorithms this algorithm does not require any significnat temporary storage or memory allocations.  

EXAM,bn_mp_mul_d.c

In this implementation the destination $c$ may point to the same mp\_int as the source $a$ since the result is written after the digit is 
read from the source.  This function uses pointer aliases $tmpa$ and $tmpc$ for the digits of $a$ and $c$ respectively.  

\subsection{Single Digit Division}
Like the single digit multiplication algorithm, single digit division is also a fairly common algorithm used in radix conversion.  Since the
divisor is only a single digit a specialized variant of the division algorithm can be used to compute the quotient.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_div\_d}. \\
\textbf{Input}.   mp\_int $a$ and a mp\_digit $b$ \\
\textbf{Output}.  $c = \lfloor a / b \rfloor, d = a - cb$ \\
\hline \\
1.  If $b = 0$ then return(\textit{MP\_VAL}).\\
2.  If $b = 3$ then use algorithm mp\_div\_3 instead. \\
3.  Init $q$ to $a.used$ digits.  \\
4.  $q.used \leftarrow a.used$ \\
5.  $q.sign \leftarrow a.sign$ \\
6.  $\hat w \leftarrow 0$ \\
7.  for $ix$ from $a.used - 1$ down to $0$ do \\
\hspace{3mm}7.1  $\hat w \leftarrow \hat w \beta + a_{ix}$ \\
\hspace{3mm}7.2  If $\hat w \ge b$ then \\
\hspace{6mm}7.2.1  $t \leftarrow \lfloor \hat w / b \rfloor$ \\
\hspace{6mm}7.2.2  $\hat w \leftarrow \hat w \mbox{ (mod }b\mbox{)}$ \\
\hspace{3mm}7.3  else\\
\hspace{6mm}7.3.1  $t \leftarrow 0$ \\
\hspace{3mm}7.4  $q_{ix} \leftarrow t$ \\
8.  $d \leftarrow \hat w$ \\
9.  Clamp excess digits of $q$. \\
10.  $c \leftarrow q$ \\
11.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_div\_d}
\end{figure}
\textbf{Algorithm mp\_div\_d.}
This algorithm divides the mp\_int $a$ by the single mp\_digit $b$ using an optimized approach.  Essentially in every iteration of the
algorithm another digit of the dividend is reduced and another digit of quotient produced.  Provided $b < \beta$ the value of $\hat w$
after step 7.1 will be limited such that $0 \le \lfloor \hat w / b \rfloor < \beta$.  

If the divisor $b$ is equal to three a variant of this algorithm is used which is called mp\_div\_3.  It replaces the division by three with
a multiplication by $\lfloor \beta / 3 \rfloor$ and the appropriate shift and residual fixup.  In essence it is much like the Barrett reduction
from chapter seven.  

EXAM,bn_mp_div_d.c

Like the implementation of algorithm mp\_div this algorithm allows either of the quotient or remainder to be passed as a \textbf{NULL} pointer to
indicate the respective value is not required.  This allows a trivial single digit modular reduction algorithm, mp\_mod\_d to be created.

The division and remainder on lines @44,/@ and @45,%@ can be replaced often by a single division on most processors.  For example, the 32-bit x86 based 
processors can divide a 64-bit quantity by a 32-bit quantity and produce the quotient and remainder simultaneously.  Unfortunately the GCC 
compiler does not recognize that optimization and will actually produce two function calls to find the quotient and remainder respectively.  

\subsection{Single Digit Root Extraction}

Finding the $n$'th root of an integer is fairly easy as far as numerical analysis is concerned.  Algorithms such as the Newton-Raphson approximation 
(\ref{eqn:newton}) series will converge very quickly to a root for any continuous function $f(x)$.  

\begin{equation}
x_{i+1} = x_i - {f(x_i) \over f'(x_i)}
\label{eqn:newton}
\end{equation}

In this case the $n$'th root is desired and $f(x) = x^n - a$ where $a$ is the integer of which the root is desired.  The derivative of $f(x)$ is 
simply $f'(x) = nx^{n - 1}$.  Of particular importance is that this algorithm will be used over the integers not over the a more continuous domain
such as the real numbers.  As a result the root found can be above the true root by few and must be manually adjusted.  Ideally at the end of the 
algorithm the $n$'th root $b$ of an integer $a$ is desired such that $b^n \le a$.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_n\_root}. \\
\textbf{Input}.   mp\_int $a$ and a mp\_digit $b$ \\
\textbf{Output}.  $c^b \le a$ \\
\hline \\
1.  If $b$ is even and $a.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\
2.  $sign \leftarrow a.sign$ \\
3.  $a.sign \leftarrow MP\_ZPOS$ \\
4.  t$2 \leftarrow 2$ \\
5.  Loop \\
\hspace{3mm}5.1  t$1 \leftarrow $ t$2$ \\
\hspace{3mm}5.2  t$3 \leftarrow $ t$1^{b - 1}$ \\
\hspace{3mm}5.3  t$2 \leftarrow $ t$3 $ $\cdot$ t$1$ \\
\hspace{3mm}5.4  t$2 \leftarrow $ t$2 - a$ \\
\hspace{3mm}5.5  t$3 \leftarrow $ t$3 \cdot b$ \\
\hspace{3mm}5.6  t$3 \leftarrow \lfloor $t$2 / $t$3 \rfloor$ \\
\hspace{3mm}5.7  t$2 \leftarrow $ t$1 - $ t$3$ \\
\hspace{3mm}5.8  If t$1 \ne $ t$2$ then goto step 5.  \\
6.  Loop \\
\hspace{3mm}6.1  t$2 \leftarrow $ t$1^b$ \\
\hspace{3mm}6.2  If t$2 > a$ then \\
\hspace{6mm}6.2.1  t$1 \leftarrow $ t$1 - 1$ \\
\hspace{6mm}6.2.2  Goto step 6. \\
7.  $a.sign \leftarrow sign$ \\
8.  $c \leftarrow $ t$1$ \\
9.  $c.sign \leftarrow sign$  \\
10.  Return(\textit{MP\_OKAY}).  \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_n\_root}
\end{figure}
\textbf{Algorithm mp\_n\_root.}
This algorithm finds the integer $n$'th root of an input using the Newton-Raphson approach.  It is partially optimized based on the observation
that the numerator of ${f(x) \over f'(x)}$ can be derived from a partial denominator.  That is at first the denominator is calculated by finding
$x^{b - 1}$.  This value can then be multiplied by $x$ and have $a$ subtracted from it to find the numerator.  This saves a total of $b - 1$ 
multiplications by t$1$ inside the loop.  

The initial value of the approximation is t$2 = 2$ which allows the algorithm to start with very small values and quickly converge on the
root.  Ideally this algorithm is meant to find the $n$'th root of an input where $n$ is bounded by $2 \le n \le 5$.  

EXAM,bn_mp_n_root.c

\section{Random Number Generation}

Random numbers come up in a variety of activities from public key cryptography to simple simulations and various randomized algorithms.  Pollard-Rho 
factoring for example, can make use of random values as starting points to find factors of a composite integer.  In this case the algorithm presented
is solely for simulations and not intended for cryptographic use.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_rand}. \\
\textbf{Input}.   An integer $b$ \\
\textbf{Output}.  A pseudo-random number of $b$ digits \\
\hline \\
1.  $a \leftarrow 0$ \\
2.  If $b \le 0$ return(\textit{MP\_OKAY}) \\
3.  Pick a non-zero random digit $d$. \\
4.  $a \leftarrow a + d$ \\
5.  for $ix$ from 1 to $d - 1$ do \\
\hspace{3mm}5.1  $a \leftarrow a \cdot \beta$ \\
\hspace{3mm}5.2  Pick a random digit $d$. \\
\hspace{3mm}5.3  $a \leftarrow a + d$ \\
6.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_rand}
\end{figure}
\textbf{Algorithm mp\_rand.}
This algorithm produces a pseudo-random integer of $b$ digits.  By ensuring that the first digit is non-zero the algorithm also guarantees that the
final result has at least $b$ digits.  It relies heavily on a third-part random number generator which should ideally generate uniformly all of
the integers from $0$ to $\beta - 1$.  

EXAM,bn_mp_rand.c

\section{Formatted Representations}
The ability to emit a radix-$n$ textual representation of an integer is useful for interacting with human parties.  For example, the ability to
be given a string of characters such as ``114585'' and turn it into the radix-$\beta$ equivalent would make it easier to enter numbers
into a program.

\subsection{Reading Radix-n Input}
For the purposes of this text we will assume that a simple lower ASCII map (\ref{fig:ASC}) is used for the values of from $0$ to $63$ to 
printable characters.  For example, when the character ``N'' is read it represents the integer $23$.  The first $16$ characters of the
map are for the common representations up to hexadecimal.  After that they match the ``base64'' encoding scheme which are suitable chosen
such that they are printable.  While outputting as base64 may not be too helpful for human operators it does allow communication via non binary
mediums.

\newpage\begin{figure}[here]
\begin{center}
\begin{tabular}{cc|cc|cc|cc}
\hline \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} &  \textbf{Value} & \textbf{Char} \\
\hline 
0 & 0 & 1 & 1 & 2 & 2 & 3 & 3 \\
4 & 4 & 5 & 5 & 6 & 6 & 7 & 7 \\
8 & 8 & 9 & 9 & 10 & A & 11 & B \\
12 & C & 13 & D & 14 & E & 15 & F \\
16 & G & 17 & H & 18 & I & 19 & J \\
20 & K & 21 & L & 22 & M & 23 & N \\
24 & O & 25 & P & 26 & Q & 27 & R \\
28 & S & 29 & T & 30 & U & 31 & V \\
32 & W & 33 & X & 34 & Y & 35 & Z \\
36 & a & 37 & b & 38 & c & 39 & d \\
40 & e & 41 & f & 42 & g & 43 & h \\
44 & i & 45 & j & 46 & k & 47 & l \\
48 & m & 49 & n & 50 & o & 51 & p \\
52 & q & 53 & r & 54 & s & 55 & t \\
56 & u & 57 & v & 58 & w & 59 & x \\
60 & y & 61 & z & 62 & $+$ & 63 & $/$ \\
\hline
\end{tabular}
\end{center}
\caption{Lower ASCII Map}
\label{fig:ASC}
\end{figure}

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_read\_radix}. \\
\textbf{Input}.   A string $str$ of length $sn$ and radix $r$. \\
\textbf{Output}.  The radix-$\beta$ equivalent mp\_int. \\
\hline \\
1.  If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\
2.  $ix \leftarrow 0$ \\
3.  If $str_0 =$ ``-'' then do \\
\hspace{3mm}3.1  $ix \leftarrow ix + 1$ \\
\hspace{3mm}3.2  $sign \leftarrow MP\_NEG$ \\
4.  else \\
\hspace{3mm}4.1  $sign \leftarrow MP\_ZPOS$ \\
5.  $a \leftarrow 0$ \\
6.  for $iy$ from $ix$ to $sn - 1$ do \\
\hspace{3mm}6.1  Let $y$ denote the position in the map of $str_{iy}$. \\
\hspace{3mm}6.2  If $str_{iy}$ is not in the map or $y \ge r$ then goto step 7. \\
\hspace{3mm}6.3  $a \leftarrow a \cdot r$ \\
\hspace{3mm}6.4  $a \leftarrow a + y$ \\
7.  If $a \ne 0$ then $a.sign \leftarrow sign$ \\
8.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_read\_radix}
\end{figure}
\textbf{Algorithm mp\_read\_radix.}
This algorithm will read an ASCII string and produce the radix-$\beta$ mp\_int representation of the same integer.  A minus symbol ``-'' may precede the 
string  to indicate the value is negative, otherwise it is assumed to be positive.  The algorithm will read up to $sn$ characters from the input
and will stop when it reads a character it cannot map the algorithm stops reading characters from the string.  This allows numbers to be embedded
as part of larger input without any significant problem.

EXAM,bn_mp_read_radix.c

\subsection{Generating Radix-$n$ Output}
Generating radix-$n$ output is fairly trivial with a division and remainder algorithm.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_toradix}. \\
\textbf{Input}.   A mp\_int $a$ and an integer $r$\\
\textbf{Output}.  The radix-$r$ representation of $a$ \\
\hline \\
1.  If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\
2.  If $a = 0$ then $str = $ ``$0$'' and return(\textit{MP\_OKAY}).  \\
3.  $t \leftarrow a$ \\
4.  $str \leftarrow$ ``'' \\
5.  if $t.sign = MP\_NEG$ then \\
\hspace{3mm}5.1  $str \leftarrow str + $ ``-'' \\
\hspace{3mm}5.2  $t.sign = MP\_ZPOS$ \\
6.  While ($t \ne 0$) do \\
\hspace{3mm}6.1  $d \leftarrow t \mbox{ (mod }r\mbox{)}$ \\
\hspace{3mm}6.2  $t \leftarrow \lfloor t / r \rfloor$ \\
\hspace{3mm}6.3  Look up $d$ in the map and store the equivalent character in $y$. \\
\hspace{3mm}6.4  $str \leftarrow str + y$ \\
7.  If $str_0 = $``$-$'' then \\
\hspace{3mm}7.1  Reverse the digits $str_1, str_2, \ldots str_n$. \\
8.  Otherwise \\
\hspace{3mm}8.1  Reverse the digits $str_0, str_1, \ldots str_n$. \\
9.  Return(\textit{MP\_OKAY}).\\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_toradix}
\end{figure}
\textbf{Algorithm mp\_toradix.}
This algorithm computes the radix-$r$ representation of an mp\_int $a$.  The ``digits'' of the representation are extracted by reducing 
successive powers of $\lfloor a / r^k \rfloor$ the input modulo $r$ until $r^k > a$.  Note that instead of actually dividing by $r^k$ in
each iteration the quotient $\lfloor a / r \rfloor$ is saved for the next iteration.  As a result a series of trivial $n \times 1$ divisions
are required instead of a series of $n \times k$ divisions.  One design flaw of this approach is that the digits are produced in the reverse order 
(see~\ref{fig:mpradix}).  To remedy this flaw the digits must be swapped or simply ``reversed''.

\begin{figure}
\begin{center}
\begin{tabular}{|c|c|c|}
\hline \textbf{Value of $a$} & \textbf{Value of $d$} & \textbf{Value of $str$} \\
\hline $1234$ & -- & -- \\
\hline $123$  & $4$ & ``4'' \\
\hline $12$   & $3$ & ``43'' \\
\hline $1$    & $2$ & ``432'' \\
\hline $0$    & $1$ & ``4321'' \\
\hline
\end{tabular}
\end{center}
\caption{Example of Algorithm mp\_toradix.}
\label{fig:mpradix}
\end{figure}

EXAM,bn_mp_toradix.c

\chapter{Number Theoretic Algorithms}
This chapter discusses several fundamental number theoretic algorithms such as the greatest common divisor, least common multiple and Jacobi 
symbol computation.  These algorithms arise as essential components in several key cryptographic algorithms such as the RSA public key algorithm and
various Sieve based factoring algorithms.

\section{Greatest Common Divisor}
The greatest common divisor of two integers $a$ and $b$, often denoted as $(a, b)$ is the largest integer $k$ that is a proper divisor of
both $a$ and $b$.  That is, $k$ is the largest integer such that $0 \equiv a \mbox{ (mod }k\mbox{)}$ and $0 \equiv b \mbox{ (mod }k\mbox{)}$ occur
simultaneously.

The most common approach (cite) is to reduce one input modulo another.  That is if $a$ and $b$ are divisible by some integer $k$ and if $qa + r = b$ then
$r$ is also divisible by $k$.  The reduction pattern follows $\left < a , b \right > \rightarrow \left < b, a \mbox{ mod } b \right >$.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Greatest Common Divisor (I)}. \\
\textbf{Input}.   Two positive integers $a$ and $b$ greater than zero. \\
\textbf{Output}.  The greatest common divisor $(a, b)$.  \\
\hline \\
1.  While ($b > 0$) do \\
\hspace{3mm}1.1  $r \leftarrow a \mbox{ (mod }b\mbox{)}$ \\
\hspace{3mm}1.2  $a \leftarrow b$ \\
\hspace{3mm}1.3  $b \leftarrow r$ \\
2.  Return($a$). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Greatest Common Divisor (I)}
\label{fig:gcd1}
\end{figure}

This algorithm will quickly converge on the greatest common divisor since the residue $r$ tends diminish rapidly.  However, divisions are
relatively expensive operations to perform and should ideally be avoided.  There is another approach based on a similar relationship of 
greatest common divisors.  The faster approach is based on the observation that if $k$ divides both $a$ and $b$ it will also divide $a - b$.  
In particular, we would like $a - b$ to decrease in magnitude which implies that $b \ge a$.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Greatest Common Divisor (II)}. \\
\textbf{Input}.   Two positive integers $a$ and $b$ greater than zero. \\
\textbf{Output}.  The greatest common divisor $(a, b)$.  \\
\hline \\
1.  While ($b > 0$) do \\
\hspace{3mm}1.1  Swap $a$ and $b$ such that $a$ is the smallest of the two. \\
\hspace{3mm}1.2  $b \leftarrow b - a$ \\
2.  Return($a$). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Greatest Common Divisor (II)}
\label{fig:gcd2}
\end{figure}

\textbf{Proof} \textit{Algorithm~\ref{fig:gcd2} will return the greatest common divisor of $a$ and $b$.}
The algorithm in figure~\ref{fig:gcd2} will eventually terminate since $b \ge a$ the subtraction in step 1.2 will be a value less than $b$.  In other
words in every iteration that tuple $\left < a, b \right >$ decrease in magnitude until eventually $a = b$.  Since both $a$ and $b$ are always 
divisible by the greatest common divisor (\textit{until the last iteration}) and in the last iteration of the algorithm $b = 0$, therefore, in the 
second to last iteration of the algorithm $b = a$ and clearly $(a, a) = a$ which concludes the proof.  \textbf{QED}.

As a matter of practicality algorithm \ref{fig:gcd1} decreases far too slowly to be useful.  Specially if $b$ is much larger than $a$ such that 
$b - a$ is still very much larger than $a$.  A simple addition to the algorithm is to divide $b - a$ by a power of some integer $p$ which does
not divide the greatest common divisor but will divide $b - a$.  In this case ${b - a} \over p$ is also an integer and still divisible by
the greatest common divisor.

However, instead of factoring $b - a$ to find a suitable value of $p$ the powers of $p$ can be removed from $a$ and $b$ that are in common first.  
Then inside the loop whenever $b - a$ is divisible by some power of $p$ it can be safely removed.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{Greatest Common Divisor (III)}. \\
\textbf{Input}.   Two positive integers $a$ and $b$ greater than zero. \\
\textbf{Output}.  The greatest common divisor $(a, b)$.  \\
\hline \\
1.  $k \leftarrow 0$ \\
2.  While $a$ and $b$ are both divisible by $p$ do \\
\hspace{3mm}2.1  $a \leftarrow \lfloor a / p \rfloor$ \\
\hspace{3mm}2.2  $b \leftarrow \lfloor b / p \rfloor$ \\
\hspace{3mm}2.3  $k \leftarrow k + 1$ \\
3.  While $a$ is divisible by $p$ do \\
\hspace{3mm}3.1  $a \leftarrow \lfloor a / p \rfloor$ \\
4.  While $b$ is divisible by $p$ do \\
\hspace{3mm}4.1  $b \leftarrow \lfloor b / p \rfloor$ \\
5.  While ($b > 0$) do \\
\hspace{3mm}5.1  Swap $a$ and $b$ such that $a$ is the smallest of the two. \\
\hspace{3mm}5.2  $b \leftarrow b - a$ \\
\hspace{3mm}5.3  While $b$ is divisible by $p$ do \\
\hspace{6mm}5.3.1  $b \leftarrow \lfloor b / p \rfloor$ \\
6.  Return($a \cdot p^k$). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm Greatest Common Divisor (III)}
\label{fig:gcd3}
\end{figure}

This algorithm is based on the first except it removes powers of $p$ first and inside the main loop to ensure the tuple $\left < a, b \right >$ 
decreases more rapidly.  The first loop on step two removes powers of $p$ that are in common.  A count, $k$, is kept which will present a common
divisor of $p^k$.  After step two the remaining common divisor of $a$ and $b$ cannot be divisible by $p$.  This means that $p$ can be safely 
divided out of the difference $b - a$ so long as the division leaves no remainder.  

In particular the value of $p$ should be chosen such that the division on step 5.3.1 occur often.  It also helps that division by $p$ be easy
to compute.  The ideal choice of $p$ is two since division by two amounts to a right logical shift.  Another important observation is that by
step five both $a$ and $b$ are odd.  Therefore, the diffrence $b - a$ must be even which means that each iteration removes one bit from the 
largest of the pair.

\subsection{Complete Greatest Common Divisor}
The algorithms presented so far cannot handle inputs which are zero or negative.  The following algorithm can handle all input cases properly
and will produce the greatest common divisor.

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_gcd}. \\
\textbf{Input}.   mp\_int $a$ and $b$ \\
\textbf{Output}.  The greatest common divisor $c = (a, b)$.  \\
\hline \\
1.  If $a = 0$ and $b \ne 0$ then \\
\hspace{3mm}1.1  $c \leftarrow b$ \\
\hspace{3mm}1.2  Return(\textit{MP\_OKAY}). \\
2.  If $a \ne 0$ and $b = 0$ then \\
\hspace{3mm}2.1  $c \leftarrow a$ \\
\hspace{3mm}2.2  Return(\textit{MP\_OKAY}). \\
3.  If $a = b = 0$ then \\
\hspace{3mm}3.1  $c \leftarrow 1$ \\
\hspace{3mm}3.2  Return(\textit{MP\_OKAY}). \\
4.  $u \leftarrow \vert a \vert, v \leftarrow \vert b \vert$ \\
5.  $k \leftarrow 0$ \\
6.  While $u.used > 0$ and $v.used > 0$ and $u_0 \equiv v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}6.1  $k \leftarrow k + 1$ \\
\hspace{3mm}6.2  $u \leftarrow \lfloor u / 2 \rfloor$ \\
\hspace{3mm}6.3  $v \leftarrow \lfloor v / 2 \rfloor$ \\
7.  While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}7.1  $u \leftarrow \lfloor u / 2 \rfloor$ \\
8.  While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}8.1  $v \leftarrow \lfloor v / 2 \rfloor$ \\
9.  While $v.used > 0$ \\
\hspace{3mm}9.1  If $\vert u \vert > \vert v \vert$ then \\
\hspace{6mm}9.1.1  Swap $u$ and $v$. \\
\hspace{3mm}9.2  $v \leftarrow \vert v \vert - \vert u \vert$ \\
\hspace{3mm}9.3  While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{6mm}9.3.1  $v \leftarrow \lfloor v / 2 \rfloor$ \\
10.  $c \leftarrow u \cdot 2^k$ \\
11.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_gcd}
\end{figure}
\textbf{Algorithm mp\_gcd.}
This algorithm will produce the greatest common divisor of two mp\_ints $a$ and $b$.  The algorithm was originally based on Algorithm B of
Knuth \cite[pp. 338]{TAOCPV2} but has been modified to be simpler to explain.  In theory it achieves the same asymptotic working time as
Algorithm B and in practice this appears to be true.  

The first three steps handle the cases where either one of or both inputs are zero.  If either input is zero the greatest common divisor is the 
largest input or zero if they are both zero.  If the inputs are not trivial than $u$ and $v$ are assigned the absolute values of 
$a$ and $b$ respectively and the algorithm will proceed to reduce the pair.

Step six will divide out any common factors of two and keep track of the count in the variable $k$.  After this step two is no longer a
factor of the remaining greatest common divisor between $u$ and $v$ and can be safely evenly divided out of either whenever they are even.  Step 
seven and eight ensure that the $u$ and $v$ respectively have no more factors of two.  At most only one of the while loops will iterate since 
they cannot both be even.

By step nine both of $u$ and $v$ are odd which is required for the inner logic.  First the pair are swapped such that $v$ is equal to
or greater than $u$.  This ensures that the subtraction on step 9.2 will always produce a positive and even result.  Step 9.3 removes any
factors of two from the difference $u$ to ensure that in the next iteration of the loop both are once again odd.

After $v = 0$ occurs the variable $u$ has the greatest common divisor of the pair $\left < u, v \right >$ just after step six.  The result
must be adjusted by multiplying by the common factors of two ($2^k$) removed earlier.  

EXAM,bn_mp_gcd.c

This function makes use of the macros mp\_iszero and mp\_iseven.  The former evaluates to $1$ if the input mp\_int is equivalent to the 
integer zero otherwise it evaluates to $0$.  The latter evaluates to $1$ if the input mp\_int represents a non-zero even integer otherwise
it evaluates to $0$.  Note that just because mp\_iseven may evaluate to $0$ does not mean the input is odd, it could also be zero.  The three 
trivial cases of inputs are handled on lines @25,zero@ through @34,}@.  After those lines the inputs are assumed to be non-zero.

Lines @36,if@ and @40,if@ make local copies $u$ and $v$ of the inputs $a$ and $b$ respectively.  At this point the common factors of two 
must be divided out of the two inputs.  The while loop on line @49,while@ iterates so long as both are even.  The local integer $k$ is used to
keep track of how many factors of $2$ are pulled out of both values.  It is assumed that the number of factors will not exceed the maximum 
value of a C ``int'' data type\footnote{Strictly speaking no array in C may have more than entries than are accessible by an ``int'' so this is not 
a limitation.}.  

At this point there are no more common factors of two in the two values.  The while loops on lines @60,while@ and @65,while@ remove any independent
factors of two such that both $u$ and $v$ are guaranteed to be an odd integer before hitting the main body of the algorithm.  The while loop
on line @71, while@ performs the reduction of the pair until $v$ is equal to zero.  The unsigned comparison and subtraction algorithms are used in
place of the full signed routines since both values are guaranteed to be positive and the result of the subtraction is guaranteed to be non-negative.

\section{Least Common Multiple}
The least common multiple of a pair of integers is their product divided by their greatest common divisor.  For two integers $a$ and $b$ the
least common multiple is normally denoted as $[ a, b ]$ and numerically equivalent to ${ab} \over {(a, b)}$.  For example, if $a = 2 \cdot 2 \cdot 3 = 12$
and $b = 2 \cdot 3 \cdot 3 \cdot 7 = 126$ the least common multiple is ${126 \over {(12, 126)}} = {126 \over 6} = 21$.

The least common multiple arises often in coding theory as well as number theory.  If two functions have periods of $a$ and $b$ respectively they will
collide, that is be in synchronous states, after only $[ a, b ]$ iterations.  This is why, for example, random number generators based on 
Linear Feedback Shift Registers (LFSR) tend to use registers with periods which are co-prime (\textit{e.g. the greatest common divisor is one.}).  
Similarly in number theory if a composite $n$ has two prime factors $p$ and $q$ then maximal order of any unit of $\Z/n\Z$ will be $[ p - 1, q - 1] $.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_lcm}. \\
\textbf{Input}.   mp\_int $a$ and $b$ \\
\textbf{Output}.  The least common multiple $c = [a, b]$.  \\
\hline \\
1.  $c \leftarrow (a, b)$ \\
2.  $t \leftarrow a \cdot b$ \\
3.  $c \leftarrow \lfloor t / c \rfloor$ \\
4.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_lcm}
\end{figure}
\textbf{Algorithm mp\_lcm.}
This algorithm computes the least common multiple of two mp\_int inputs $a$ and $b$.  It computes the least common multiple directly by
dividing the product of the two inputs by their greatest common divisor.

EXAM,bn_mp_lcm.c

\section{Jacobi Symbol Computation}
To explain the Jacobi Symbol we shall first discuss the Legendre function\footnote{Arrg.  What is the name of this?} off which the Jacobi symbol is 
defined.  The Legendre function computes whether or not an integer $a$ is a quadratic residue modulo an odd prime $p$.  Numerically it is
equivalent to equation \ref{eqn:legendre}.

\textit{-- Tom, don't be an ass, cite your source here...!}

\begin{equation}
a^{(p-1)/2} \equiv \begin{array}{rl}
                              -1 &  \mbox{if }a\mbox{ is a quadratic non-residue.} \\
                              0  &  \mbox{if }a\mbox{ divides }p\mbox{.} \\
                              1  &  \mbox{if }a\mbox{ is a quadratic residue}. 
                              \end{array} \mbox{ (mod }p\mbox{)}
\label{eqn:legendre}                              
\end{equation}

\textbf{Proof.} \textit{Equation \ref{eqn:legendre} correctly identifies the residue status of an integer $a$ modulo a prime $p$.}
An integer $a$ is a quadratic residue if the following equation has a solution.

\begin{equation}
x^2 \equiv a \mbox{ (mod }p\mbox{)}
\label{eqn:root}
\end{equation}

Consider the following equation.

\begin{equation}
0 \equiv x^{p-1} - 1 \equiv \left \lbrace \left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \right \rbrace + \left ( a^{(p-1)/2} - 1 \right ) \mbox{ (mod }p\mbox{)}
\label{eqn:rooti}
\end{equation}

Whether equation \ref{eqn:root} has a solution or not equation \ref{eqn:rooti} is always true.  If $a^{(p-1)/2} - 1 \equiv 0 \mbox{ (mod }p\mbox{)}$
then the quantity in the braces must be zero.  By reduction,

\begin{eqnarray}
\left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \equiv 0  \nonumber \\
\left (x^2 \right )^{(p-1)/2} \equiv a^{(p-1)/2} \nonumber \\
x^2 \equiv a \mbox{ (mod }p\mbox{)} 
\end{eqnarray}

As a result there must be a solution to the quadratic equation and in turn $a$ must be a quadratic residue.  If $a$ does not divide $p$ and $a$
is not a quadratic residue then the only other value $a^{(p-1)/2}$ may be congruent to is $-1$ since
\begin{equation}
0 \equiv a^{p - 1} - 1 \equiv (a^{(p-1)/2} + 1)(a^{(p-1)/2} - 1) \mbox{ (mod }p\mbox{)}
\end{equation}
One of the terms on the right hand side must be zero.  \textbf{QED}

\subsection{Jacobi Symbol}
The Jacobi symbol is a generalization of the Legendre function for any odd non prime moduli $p$ greater than 2.  If $p = \prod_{i=0}^n p_i$ then
the Jacobi symbol $\left ( { a \over p } \right )$ is equal to the following equation.

\begin{equation}
\left ( { a \over p } \right ) = \left ( { a \over p_0} \right ) \left ( { a \over p_1} \right ) \ldots \left ( { a \over p_n} \right )
\end{equation}

By inspection if $p$ is prime the Jacobi symbol is equivalent to the Legendre function.  The following facts\footnote{See HAC \cite[pp. 72-74]{HAC} for
further details.} will be used to derive an efficient Jacobi symbol algorithm.  Where $p$ is an odd integer greater than two and $a, b \in \Z$ the
following are true.  

\begin{enumerate}
\item $\left ( { a \over p} \right )$ equals $-1$, $0$ or $1$. 
\item $\left ( { ab \over p} \right ) = \left ( { a \over p} \right )\left ( { b \over p} \right )$.
\item If $a \equiv b$ then $\left ( { a \over p} \right ) = \left ( { b \over p} \right )$.
\item $\left ( { 2 \over p} \right )$ equals $1$ if $p \equiv 1$ or $7 \mbox{ (mod }8\mbox{)}$.  Otherwise, it equals $-1$.
\item $\left ( { a \over p} \right ) \equiv \left ( { p \over a} \right ) \cdot (-1)^{(p-1)(a-1)/4}$.  More specifically 
$\left ( { a \over p} \right ) = \left ( { p \over a} \right )$ if $p \equiv a \equiv 1 \mbox{ (mod }4\mbox{)}$.  
\end{enumerate}

Using these facts if $a = 2^k \cdot a'$ then

\begin{eqnarray}
\left ( { a \over p } \right ) = \left ( {{2^k} \over p } \right ) \left ( {a' \over p} \right ) \nonumber \\
                               = \left ( {2 \over p } \right )^k \left ( {a' \over p} \right ) 
\label{eqn:jacobi}
\end{eqnarray}

By fact five, 

\begin{equation}
\left ( { a \over p } \right ) = \left ( { p \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} 
\end{equation}

Subsequently by fact three since $p \equiv (p \mbox{ mod }a) \mbox{ (mod }a\mbox{)}$ then 

\begin{equation}
\left ( { a \over p } \right ) = \left ( { {p \mbox{ mod } a} \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} 
\end{equation}

By putting both observations into equation \ref{eqn:jacobi} the following simplified equation is formed.

\begin{equation}
\left ( { a \over p } \right ) = \left ( {2 \over p } \right )^k \left ( {{p\mbox{ mod }a'} \over a'} \right )  \cdot (-1)^{(p-1)(a'-1)/4} 
\end{equation}

The value of $\left ( {{p \mbox{ mod }a'} \over a'} \right )$ can be found by using the same equation recursively.  The value of 
$\left ( {2 \over p } \right )^k$ equals $1$ if $k$ is even otherwise it equals $\left ( {2 \over p } \right )$.  Using this approach the 
factors of $p$ do not have to be known.  Furthermore, if $(a, p) = 1$ then the algorithm will terminate when the recursion requests the 
Jacobi symbol computation of $\left ( {1 \over a'} \right )$ which is simply $1$.  

\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_jacobi}. \\
\textbf{Input}.   mp\_int $a$ and $p$, $a \ge 0$, $p \ge 3$, $p \equiv 1 \mbox{ (mod }2\mbox{)}$ \\
\textbf{Output}.  The Jacobi symbol $c = \left ( {a \over p } \right )$. \\
\hline \\
1.  If $a = 0$ then \\
\hspace{3mm}1.1  $c \leftarrow 0$ \\
\hspace{3mm}1.2  Return(\textit{MP\_OKAY}). \\
2.  If $a = 1$ then \\
\hspace{3mm}2.1  $c \leftarrow 1$ \\
\hspace{3mm}2.2  Return(\textit{MP\_OKAY}). \\
3.  $a' \leftarrow a$ \\
4.  $k \leftarrow 0$ \\
5.  While $a'.used > 0$ and $a'_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}5.1  $k \leftarrow k + 1$ \\
\hspace{3mm}5.2  $a' \leftarrow \lfloor a' / 2 \rfloor$ \\
6.  If $k \equiv 0 \mbox{ (mod }2\mbox{)}$ then \\
\hspace{3mm}6.1  $s \leftarrow 1$ \\
7.  else \\
\hspace{3mm}7.1  $r \leftarrow p_0 \mbox{ (mod }8\mbox{)}$ \\
\hspace{3mm}7.2  If $r = 1$ or $r = 7$ then \\
\hspace{6mm}7.2.1  $s \leftarrow 1$ \\
\hspace{3mm}7.3  else \\
\hspace{6mm}7.3.1  $s \leftarrow -1$ \\
8.  If $p_0 \equiv a'_0 \equiv 3 \mbox{ (mod }4\mbox{)}$ then \\
\hspace{3mm}8.1  $s \leftarrow -s$ \\
9.  If $a' \ne 1$ then \\
\hspace{3mm}9.1  $p' \leftarrow p \mbox{ (mod }a'\mbox{)}$ \\
\hspace{3mm}9.2  $s \leftarrow s \cdot \mbox{mp\_jacobi}(p', a')$ \\
10.  $c \leftarrow s$ \\
11.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_jacobi}
\end{figure}
\textbf{Algorithm mp\_jacobi.}
This algorithm computes the Jacobi symbol for an arbitrary positive integer $a$ with respect to an odd integer $p$ greater than three.  The algorithm
is based on algorithm 2.149 of HAC \cite[pp. 73]{HAC}.  

Step numbers one and two handle the trivial cases of $a = 0$ and $a = 1$ respectively.  Step five determines the number of two factors in the
input $a$.  If $k$ is even than the term $\left ( { 2 \over p } \right )^k$ must always evaluate to one.  If $k$ is odd than the term evaluates to one 
if $p_0$ is congruent to one or seven modulo eight, otherwise it evaluates to $-1$. After the the $\left ( { 2 \over p } \right )^k$ term is handled 
the $(-1)^{(p-1)(a'-1)/4}$ is computed and multiplied against the current product $s$.  The latter term evaluates to one if both $p$ and $a'$ 
are congruent to one modulo four, otherwise it evaluates to negative one.

By step nine if $a'$ does not equal one a recursion is required.  Step 9.1 computes $p' \equiv p \mbox{ (mod }a'\mbox{)}$ and will recurse to compute
$\left ( {p' \over a'} \right )$ which is multiplied against the current Jacobi product.

EXAM,bn_mp_jacobi.c

As a matter of practicality the variable $a'$ as per the pseudo-code is reprensented by the variable $a1$ since the $'$ symbol is not valid for a C 
variable name character. 

The two simple cases of $a = 0$ and $a = 1$ are handled at the very beginning to simplify the algorithm.  If the input is non-trivial the algorithm
has to proceed compute the Jacobi.  The variable $s$ is used to hold the current Jacobi product.  Note that $s$ is merely a C ``int'' data type since
the values it may obtain are merely $-1$, $0$ and $1$.  

After a local copy of $a$ is made all of the factors of two are divided out and the total stored in $k$.  Technically only the least significant
bit of $k$ is required, however, it makes the algorithm simpler to follow to perform an addition. In practice an exclusive-or and addition have the same 
processor requirements and neither is faster than the other.

Line @59, if@ through @70, }@ determines the value of $\left ( { 2 \over p } \right )^k$.  If the least significant bit of $k$ is zero than
$k$ is even and the value is one.  Otherwise, the value of $s$ depends on which residue class $p$ belongs to modulo eight.  The value of
$(-1)^{(p-1)(a'-1)/4}$ is compute and multiplied against $s$ on lines @73, if@ through @75, }@.  

Finally, if $a1$ does not equal one the algorithm must recurse and compute $\left ( {p' \over a'} \right )$.  

\textit{-- Comment about default $s$ and such...}

\section{Modular Inverse}
\label{sec:modinv}
The modular inverse of a number actually refers to the modular multiplicative inverse.  Essentially for any integer $a$ such that $(a, p) = 1$ there
exist another integer $b$ such that $ab \equiv 1 \mbox{ (mod }p\mbox{)}$.  The integer $b$ is called the multiplicative inverse of $a$ which is
denoted as $b = a^{-1}$.  Technically speaking modular inversion is a well defined operation for any finite ring or field not just for rings and 
fields of integers.  However, the former will be the matter of discussion.

The simplest approach is to compute the algebraic inverse of the input.  That is to compute $b \equiv a^{\Phi(p) - 1}$.  If $\Phi(p)$ is the 
order of the multiplicative subgroup modulo $p$ then $b$ must be the multiplicative inverse of $a$.  The proof of which is trivial.

\begin{equation}
ab \equiv a \left (a^{\Phi(p) - 1} \right ) \equiv a^{\Phi(p)} \equiv a^0 \equiv 1 \mbox{ (mod }p\mbox{)}
\end{equation}

However, as simple as this approach may be it has two serious flaws.  It requires that the value of $\Phi(p)$ be known which if $p$ is composite 
requires all of the prime factors.  This approach also is very slow as the size of $p$ grows.  

A simpler approach is based on the observation that solving for the multiplicative inverse is equivalent to solving the linear 
Diophantine\footnote{See LeVeque \cite[pp. 40-43]{LeVeque} for more information.} equation.

\begin{equation}
ab + pq = 1
\end{equation}

Where $a$, $b$, $p$ and $q$ are all integers.  If such a pair of integers $ \left < b, q \right >$ exist than $b$ is the multiplicative inverse of 
$a$ modulo $p$.  The extended Euclidean algorithm (Knuth \cite[pp. 342]{TAOCPV2}) can be used to solve such equations provided $(a, p) = 1$.  
However, instead of using that algorithm directly a variant known as the binary Extended Euclidean algorithm will be used in its place.  The
binary approach is very similar to the binary greatest common divisor algorithm except it will produce a full solution to the Diophantine 
equation.  

\subsection{General Case}
\newpage\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_invmod}. \\
\textbf{Input}.   mp\_int $a$ and $b$, $(a, b) = 1$, $p \ge 2$, $0 < a < p$.  \\
\textbf{Output}.  The modular inverse $c \equiv a^{-1} \mbox{ (mod }b\mbox{)}$. \\
\hline \\
1.  If $b \le 0$ then return(\textit{MP\_VAL}). \\
2.  If $b_0 \equiv 1 \mbox{ (mod }2\mbox{)}$ then use algorithm fast\_mp\_invmod. \\
3.  $x \leftarrow \vert a \vert, y \leftarrow b$ \\
4.  If $x_0 \equiv y_0  \equiv 0 \mbox{ (mod }2\mbox{)}$ then return(\textit{MP\_VAL}). \\
5.  $B \leftarrow 0, C \leftarrow 0, A \leftarrow 1, D \leftarrow 1$ \\
6.  While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}6.1  $u \leftarrow \lfloor u / 2 \rfloor$ \\
\hspace{3mm}6.2  If ($A.used > 0$ and $A_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($B.used > 0$ and $B_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\
\hspace{6mm}6.2.1  $A \leftarrow A + y$ \\
\hspace{6mm}6.2.2  $B \leftarrow B - x$ \\
\hspace{3mm}6.3  $A \leftarrow \lfloor A / 2 \rfloor$ \\
\hspace{3mm}6.4  $B \leftarrow \lfloor B / 2 \rfloor$ \\
7.  While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}7.1  $v \leftarrow \lfloor v / 2 \rfloor$ \\
\hspace{3mm}7.2  If ($C.used > 0$ and $C_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($D.used > 0$ and $D_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\
\hspace{6mm}7.2.1  $C \leftarrow C + y$ \\
\hspace{6mm}7.2.2  $D \leftarrow D - x$ \\
\hspace{3mm}7.3  $C \leftarrow \lfloor C / 2 \rfloor$ \\
\hspace{3mm}7.4  $D \leftarrow \lfloor D / 2 \rfloor$ \\
8.  If $u \ge v$ then \\
\hspace{3mm}8.1  $u \leftarrow u - v$ \\
\hspace{3mm}8.2  $A \leftarrow A - C$ \\
\hspace{3mm}8.3  $B \leftarrow B - D$ \\
9.  else \\
\hspace{3mm}9.1  $v \leftarrow v - u$ \\
\hspace{3mm}9.2  $C \leftarrow C - A$ \\
\hspace{3mm}9.3  $D \leftarrow D - B$ \\
10.  If $u \ne 0$ goto step 6. \\
11.  If $v \ne 1$ return(\textit{MP\_VAL}). \\
12.  While $C \le 0$ do \\
\hspace{3mm}12.1  $C \leftarrow C + b$ \\
13.  While $C \ge b$ do \\
\hspace{3mm}13.1  $C \leftarrow C - b$ \\
14.  $c \leftarrow C$ \\
15.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\end{figure}
\textbf{Algorithm mp\_invmod.}
This algorithm computes the modular multiplicative inverse of an integer $a$ modulo an integer $b$.  This algorithm is a variation of the 
extended binary Euclidean algorithm from HAC \cite[pp. 608]{HAC}.  It has been modified to only compute the modular inverse and not a complete
Diophantine solution.  

If $b \le 0$ than the modulus is invalid and MP\_VAL is returned.  Similarly if both $a$ and $b$ are even then there cannot be a multiplicative
inverse for $a$ and the error is reported.  

The astute reader will observe that steps seven through nine are very similar to the binary greatest common divisor algorithm mp\_gcd.  In this case
the other variables to the Diophantine equation are solved.  The algorithm terminates when $u = 0$ in which case the solution is

\begin{equation}
Ca + Db = v
\end{equation}

If $v$, the greatest common divisor of $a$ and $b$ is not equal to one then the algorithm will report an error as no inverse exists.  Otherwise, $C$
is the modular inverse of $a$.  The actual value of $C$ is congruent to, but not necessarily equal to, the ideal modular inverse which should lie 
within $1 \le a^{-1} < b$.  Step numbers twelve and thirteen adjust the inverse until it is in range.  If the original input $a$ is within $0 < a < p$ 
then only a couple of additions or subtractions will be required to adjust the inverse.

EXAM,bn_mp_invmod.c

\subsubsection{Odd Moduli}

When the modulus $b$ is odd the variables $A$ and $C$ are fixed and are not required to compute the inverse.  In particular by attempting to solve
the Diophantine $Cb + Da = 1$ only $B$ and $D$ are required to find the inverse of $a$.  

The algorithm fast\_mp\_invmod is a direct adaptation of algorithm mp\_invmod with all all steps involving either $A$ or $C$ removed.  This 
optimization will halve the time required to compute the modular inverse.

\section{Primality Tests}

A non-zero integer $a$ is said to be prime if it is not divisible by any other integer excluding one and itself.  For example, $a = 7$ is prime 
since the integers $2 \ldots 6$ do not evenly divide $a$.  By contrast, $a = 6$ is not prime since $a = 6 = 2 \cdot 3$. 

Prime numbers arise in cryptography considerably as they allow finite fields to be formed.  The ability to determine whether an integer is prime or
not quickly has been a viable subject in cryptography and number theory for considerable time.  The algorithms that will be presented are all
probablistic algorithms in that when they report an integer is composite it must be composite.  However, when the algorithms report an integer is
prime the algorithm may be incorrect.  

As will be discussed it is possible to limit the probability of error so well that for practical purposes the probablity of error might as 
well be zero.  For the purposes of these discussions let $n$ represent the candidate integer of which the primality is in question.

\subsection{Trial Division}

Trial division means to attempt to evenly divide a candidate integer by small prime integers.  If the candidate can be evenly divided it obviously
cannot be prime.  By dividing by all primes $1 < p \le \sqrt{n}$ this test can actually prove whether an integer is prime.  However, such a test
would require a prohibitive amount of time as $n$ grows.

Instead of dividing by every prime, a smaller, more mangeable set of primes may be used instead.  By performing trial division with only a subset
of the primes less than $\sqrt{n} + 1$ the algorithm cannot prove if a candidate is prime.  However, often it can prove a candidate is not prime.

The benefit of this test is that trial division by small values is fairly efficient.  Specially compared to the other algorithms that will be
discussed shortly.  The probability that this approach correctly identifies a composite candidate when tested with all primes upto $q$ is given by
$1 - {1.12 \over ln(q)}$.  The graph (\ref{pic:primality}, will be added later) demonstrates the probability of success for the range 
$3 \le q \le 100$.  

At approximately $q = 30$ the gain of performing further tests diminishes fairly quickly.  At $q = 90$ further testing is generally not going to 
be of any practical use.  In the case of LibTomMath the default limit $q = 256$ was chosen since it is not too high and will eliminate 
approximately $80\%$ of all candidate integers.  The constant \textbf{PRIME\_SIZE} is equal to the number of primes in the test base.  The 
array \_\_prime\_tab is an array of the first \textbf{PRIME\_SIZE} prime numbers.  

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_prime\_is\_divisible}. \\
\textbf{Input}.   mp\_int $a$ \\
\textbf{Output}.  $c = 1$ if $n$ is divisible by a small prime, otherwise $c = 0$.  \\
\hline \\
1.  for $ix$ from $0$ to $PRIME\_SIZE$ do \\
\hspace{3mm}1.1  $d \leftarrow n \mbox{ (mod }\_\_prime\_tab_{ix}\mbox{)}$ \\
\hspace{3mm}1.2  If $d = 0$ then \\
\hspace{6mm}1.2.1  $c \leftarrow 1$ \\
\hspace{6mm}1.2.2  Return(\textit{MP\_OKAY}). \\
2.  $c \leftarrow 0$ \\
3.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_prime\_is\_divisible}
\end{figure}
\textbf{Algorithm mp\_prime\_is\_divisible.}
This algorithm attempts to determine if a candidate integer $n$ is composite by performing trial divisions.  

EXAM,bn_mp_prime_is_divisible.c

The algorithm defaults to a return of $0$ in case an error occurs.  The values in the prime table are all specified to be in the range of a 
mp\_digit.  The table \_\_prime\_tab is defined in the following file.

EXAM,bn_prime_tab.c

Note that there are two possible tables.  When an mp\_digit is 7-bits long only the primes upto $127$ may be included, otherwise the primes
upto $1619$ are used.  Note that the value of \textbf{PRIME\_SIZE} is a constant dependent on the size of a mp\_digit. 

\subsection{The Fermat Test}
The Fermat test is probably one the oldest tests to have a non-trivial probability of success.  It is based on the fact that if $n$ is in 
fact prime then $a^{n} \equiv a \mbox{ (mod }n\mbox{)}$ for all $0 < a < n$.  The reason being that if $n$ is prime than the order of
the multiplicative sub group is $n - 1$.  Any base $a$ must have an order which divides $n - 1$ and as such $a^n$ is equivalent to 
$a^1 = a$.  

If $n$ is composite then any given base $a$ does not have to have a period which divides $n - 1$.  In which case 
it is possible that $a^n \nequiv a \mbox{ (mod }n\mbox{)}$.  However, this test is not absolute as it is possible that the order
of a base will divide $n - 1$ which would then be reported as prime.  Such a base yields what is known as a Fermat pseudo-prime.  Several 
integers known as Carmichael numbers will be a pseudo-prime to all valid bases.  Fortunately such numbers are extremely rare as $n$ grows
in size.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_prime\_fermat}. \\
\textbf{Input}.   mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$.  \\
\textbf{Output}.  $c = 1$ if $b^a \equiv b \mbox{ (mod }a\mbox{)}$, otherwise $c = 0$.  \\
\hline \\
1.  $t \leftarrow b^a \mbox{ (mod }a\mbox{)}$ \\
2.  If $t = b$ then \\
\hspace{3mm}2.1  $c = 1$ \\
3.  else \\
\hspace{3mm}3.1  $c = 0$ \\
4.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_prime\_fermat}
\end{figure}
\textbf{Algorithm mp\_prime\_fermat.}
This algorithm determines whether an mp\_int $a$ is a Fermat prime to the base $b$ or not.  It uses a single modular exponentiation to
determine the result.  

EXAM,bn_mp_prime_fermat.c

\subsection{The Miller-Rabin Test}
The Miller-Rabin (citation) test is another primality test which has tighter error bounds than the Fermat test specifically with sequentially chosen 
candidate  integers.  The algorithm is based on the observation that if $n - 1 = 2^kr$ and if $b^r \nequiv \pm 1$ then after upto $k - 1$ squarings the 
value must be equal to $-1$.  The squarings are stopped as soon as $-1$ is observed.  If the value of $1$ is observed first it means that
some value not congruent to $\pm 1$ when squared equals one which cannot occur if $n$ is prime.

\begin{figure}[!here]
\begin{small}
\begin{center}
\begin{tabular}{l}
\hline Algorithm \textbf{mp\_prime\_miller\_rabin}. \\
\textbf{Input}.   mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$.  \\
\textbf{Output}.  $c = 1$ if $a$ is a Miller-Rabin prime to the base $a$, otherwise $c = 0$.  \\
\hline
1.  $a' \leftarrow a - 1$ \\
2.  $r  \leftarrow n1$    \\
3.  $c \leftarrow 0, s  \leftarrow 0$ \\
4.  While $r.used > 0$ and $r_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\
\hspace{3mm}4.1  $s \leftarrow s + 1$ \\
\hspace{3mm}4.2  $r \leftarrow \lfloor r / 2 \rfloor$ \\
5.  $y \leftarrow b^r \mbox{ (mod }a\mbox{)}$ \\
6.  If $y \nequiv \pm 1$ then \\
\hspace{3mm}6.1  $j \leftarrow 1$ \\
\hspace{3mm}6.2  While $j \le (s - 1)$ and $y \nequiv a'$ \\
\hspace{6mm}6.2.1  $y \leftarrow y^2 \mbox{ (mod }a\mbox{)}$ \\
\hspace{6mm}6.2.2  If $y = 1$ then goto step 8. \\
\hspace{6mm}6.2.3  $j \leftarrow j + 1$ \\
\hspace{3mm}6.3  If $y \nequiv a'$ goto step 8. \\
7.  $c \leftarrow 1$\\
8.  Return(\textit{MP\_OKAY}). \\
\hline
\end{tabular}
\end{center}
\end{small}
\caption{Algorithm mp\_prime\_miller\_rabin}
\end{figure}
\textbf{Algorithm mp\_prime\_miller\_rabin.}
This algorithm performs one trial round of the Miller-Rabin algorithm to the base $b$.  It will set $c = 1$ if the algorithm cannot determine
if $b$ is composite or $c = 0$ if $b$ is provably composite.  The values of $s$ and $r$ are computed such that $a' = a - 1 = 2^sr$.  

If the value $y \equiv b^r$ is congruent to $\pm 1$ then the algorithm cannot prove if $a$ is composite or not.  Otherwise, the algorithm will
square $y$ upto $s - 1$ times stopping only when $y \equiv -1$.  If $y^2 \equiv 1$ and $y \nequiv \pm 1$ then the algorithm can report that $a$
is provably composite.  If the algorithm performs $s - 1$ squarings and $y \nequiv -1$ then $a$ is provably composite.  If $a$ is not provably 
composite then it is \textit{probably} prime.

EXAM,bn_mp_prime_miller_rabin.c




\backmatter
\appendix
\begin{thebibliography}{ABCDEF}
\bibitem[1]{TAOCPV2}
Donald Knuth, \textit{The Art of Computer Programming}, Third Edition, Volume Two, Seminumerical Algorithms, Addison-Wesley, 1998

\bibitem[2]{HAC}
A. Menezes, P. van Oorschot, S. Vanstone, \textit{Handbook of Applied Cryptography}, CRC Press, 1996

\bibitem[3]{ROSE}
Michael Rosing, \textit{Implementing Elliptic Curve Cryptography}, Manning Publications, 1999

\bibitem[4]{COMBA}
Paul G. Comba, \textit{Exponentiation Cryptosystems on the IBM PC}. IBM Systems Journal 29(4): 526-538 (1990)

\bibitem[5]{KARA}
A. Karatsuba, Doklay Akad. Nauk SSSR 145 (1962), pp.293-294

\bibitem[6]{KARAP}
Andre Weimerskirch and Christof Paar, \textit{Generalizations of the Karatsuba Algorithm for Polynomial Multiplication}, Submitted to Design, Codes and Cryptography, March 2002

\bibitem[7]{BARRETT}
Paul Barrett, \textit{Implementing the Rivest Shamir and Adleman Public Key Encryption Algorithm on a Standard Digital Signal Processor}, Advances in Cryptology, Crypto '86, Springer-Verlag.

\bibitem[8]{MONT}
P.L.Montgomery. \textit{Modular multiplication without trial division}. Mathematics of Computation, 44(170):519-521, April 1985.

\bibitem[9]{DRMET}
Chae Hoon Lim and Pil Joong Lee, \textit{Generating Efficient Primes for Discrete Log Cryptosystems}, POSTECH Information Research Laboratories

\bibitem[10]{MMB}
J. Daemen and R. Govaerts and J. Vandewalle, \textit{Block ciphers based on Modular Arithmetic}, State and {P}rogress in the {R}esearch of {C}ryptography, 1993, pp. 80-89

\bibitem[11]{RSAREF}
R.L. Rivest, A. Shamir, L. Adleman, \textit{A Method for Obtaining Digital Signatures and Public-Key Cryptosystems}

\bibitem[12]{DHREF}
Whitfield Diffie, Martin E. Hellman, \textit{New Directions in Cryptography}, IEEE Transactions on Information Theory, 1976

\bibitem[13]{IEEE}
IEEE Standard for Binary Floating-Point Arithmetic (ANSI/IEEE Std 754-1985)

\bibitem[14]{GMP}
GNU Multiple Precision (GMP), \url{http://www.swox.com/gmp/}

\bibitem[15]{MPI}
Multiple Precision Integer Library (MPI), Michael Fromberger, \url{http://thayer.dartmouth.edu/~sting/mpi/}

\bibitem[16]{OPENSSL}
OpenSSL Cryptographic Toolkit, \url{http://openssl.org}

\bibitem[17]{LIP}
Large Integer Package, \url{http://home.hetnet.nl/~ecstr/LIP.zip}

\bibitem[18]{ISOC}
JTC1/SC22/WG14, ISO/IEC 9899:1999, ``A draft rationale for the C99 standard.''

\bibitem[19]{JAVA}
The Sun Java Website, \url{http://java.sun.com/}

\end{thebibliography}

\input{tommath.ind}

\end{document}

Added libtommath/tommath.tex.

more than 10,000 changes

Added libtommath/tommath_class.h.















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
#if !(defined(LTM1) && defined(LTM2) && defined(LTM3))
#if defined(LTM2)
#define LTM3
#endif
#if defined(LTM1)
#define LTM2
#endif
#define LTM1

#if defined(LTM_ALL)
#define BN_ERROR_C
#define BN_FAST_MP_INVMOD_C
#define BN_FAST_MP_MONTGOMERY_REDUCE_C
#define BN_FAST_S_MP_MUL_DIGS_C
#define BN_FAST_S_MP_MUL_HIGH_DIGS_C
#define BN_FAST_S_MP_SQR_C
#define BN_MP_2EXPT_C
#define BN_MP_ABS_C
#define BN_MP_ADD_C
#define BN_MP_ADD_D_C
#define BN_MP_ADDMOD_C
#define BN_MP_AND_C
#define BN_MP_CLAMP_C
#define BN_MP_CLEAR_C
#define BN_MP_CLEAR_MULTI_C
#define BN_MP_CMP_C
#define BN_MP_CMP_D_C
#define BN_MP_CMP_MAG_C
#define BN_MP_CNT_LSB_C
#define BN_MP_COPY_C
#define BN_MP_COUNT_BITS_C
#define BN_MP_DIV_C
#define BN_MP_DIV_2_C
#define BN_MP_DIV_2D_C
#define BN_MP_DIV_3_C
#define BN_MP_DIV_D_C
#define BN_MP_DR_IS_MODULUS_C
#define BN_MP_DR_REDUCE_C
#define BN_MP_DR_SETUP_C
#define BN_MP_EXCH_C
#define BN_MP_EXPT_D_C
#define BN_MP_EXPTMOD_C
#define BN_MP_EXPTMOD_FAST_C
#define BN_MP_EXTEUCLID_C
#define BN_MP_FREAD_C
#define BN_MP_FWRITE_C
#define BN_MP_GCD_C
#define BN_MP_GET_INT_C
#define BN_MP_GROW_C
#define BN_MP_INIT_C
#define BN_MP_INIT_COPY_C
#define BN_MP_INIT_MULTI_C
#define BN_MP_INIT_SET_C
#define BN_MP_INIT_SET_INT_C
#define BN_MP_INIT_SIZE_C
#define BN_MP_INVMOD_C
#define BN_MP_INVMOD_SLOW_C
#define BN_MP_IS_SQUARE_C
#define BN_MP_JACOBI_C
#define BN_MP_KARATSUBA_MUL_C
#define BN_MP_KARATSUBA_SQR_C
#define BN_MP_LCM_C
#define BN_MP_LSHD_C
#define BN_MP_MOD_C
#define BN_MP_MOD_2D_C
#define BN_MP_MOD_D_C
#define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
#define BN_MP_MONTGOMERY_REDUCE_C
#define BN_MP_MONTGOMERY_SETUP_C
#define BN_MP_MUL_C
#define BN_MP_MUL_2_C
#define BN_MP_MUL_2D_C
#define BN_MP_MUL_D_C
#define BN_MP_MULMOD_C
#define BN_MP_N_ROOT_C
#define BN_MP_NEG_C
#define BN_MP_OR_C
#define BN_MP_PRIME_FERMAT_C
#define BN_MP_PRIME_IS_DIVISIBLE_C
#define BN_MP_PRIME_IS_PRIME_C
#define BN_MP_PRIME_MILLER_RABIN_C
#define BN_MP_PRIME_NEXT_PRIME_C
#define BN_MP_PRIME_RABIN_MILLER_TRIALS_C
#define BN_MP_PRIME_RANDOM_EX_C
#define BN_MP_RADIX_SIZE_C
#define BN_MP_RADIX_SMAP_C
#define BN_MP_RAND_C
#define BN_MP_READ_RADIX_C
#define BN_MP_READ_SIGNED_BIN_C
#define BN_MP_READ_UNSIGNED_BIN_C
#define BN_MP_REDUCE_C
#define BN_MP_REDUCE_2K_C
#define BN_MP_REDUCE_2K_L_C
#define BN_MP_REDUCE_2K_SETUP_C
#define BN_MP_REDUCE_2K_SETUP_L_C
#define BN_MP_REDUCE_IS_2K_C
#define BN_MP_REDUCE_IS_2K_L_C
#define BN_MP_REDUCE_SETUP_C
#define BN_MP_RSHD_C
#define BN_MP_SET_C
#define BN_MP_SET_INT_C
#define BN_MP_SHRINK_C
#define BN_MP_SIGNED_BIN_SIZE_C
#define BN_MP_SQR_C
#define BN_MP_SQRMOD_C
#define BN_MP_SQRT_C
#define BN_MP_SUB_C
#define BN_MP_SUB_D_C
#define BN_MP_SUBMOD_C
#define BN_MP_TO_SIGNED_BIN_C
#define BN_MP_TO_SIGNED_BIN_N_C
#define BN_MP_TO_UNSIGNED_BIN_C
#define BN_MP_TO_UNSIGNED_BIN_N_C
#define BN_MP_TOOM_MUL_C
#define BN_MP_TOOM_SQR_C
#define BN_MP_TORADIX_C
#define BN_MP_TORADIX_N_C
#define BN_MP_UNSIGNED_BIN_SIZE_C
#define BN_MP_XOR_C
#define BN_MP_ZERO_C
#define BN_PRIME_TAB_C
#define BN_REVERSE_C
#define BN_S_MP_ADD_C
#define BN_S_MP_EXPTMOD_C
#define BN_S_MP_MUL_DIGS_C
#define BN_S_MP_MUL_HIGH_DIGS_C
#define BN_S_MP_SQR_C
#define BN_S_MP_SUB_C
#define BNCORE_C
#endif

#if defined(BN_ERROR_C)
   #define BN_MP_ERROR_TO_STRING_C
#endif

#if defined(BN_FAST_MP_INVMOD_C)
   #define BN_MP_ISEVEN_C
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_COPY_C
   #define BN_MP_MOD_C
   #define BN_MP_SET_C
   #define BN_MP_DIV_2_C
   #define BN_MP_ISODD_C
   #define BN_MP_SUB_C
   #define BN_MP_CMP_C
   #define BN_MP_ISZERO_C
   #define BN_MP_CMP_D_C
   #define BN_MP_ADD_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_FAST_MP_MONTGOMERY_REDUCE_C)
   #define BN_MP_GROW_C
   #define BN_MP_RSHD_C
   #define BN_MP_CLAMP_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_FAST_S_MP_MUL_DIGS_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_FAST_S_MP_SQR_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_2EXPT_C)
   #define BN_MP_ZERO_C
   #define BN_MP_GROW_C
#endif

#if defined(BN_MP_ABS_C)
   #define BN_MP_COPY_C
#endif

#if defined(BN_MP_ADD_C)
   #define BN_S_MP_ADD_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_MP_ADD_D_C)
   #define BN_MP_GROW_C
   #define BN_MP_SUB_D_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_ADDMOD_C)
   #define BN_MP_INIT_C
   #define BN_MP_ADD_C
   #define BN_MP_CLEAR_C
   #define BN_MP_MOD_C
#endif

#if defined(BN_MP_AND_C)
   #define BN_MP_INIT_COPY_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_CLAMP_C)
#endif

#if defined(BN_MP_CLEAR_C)
#endif

#if defined(BN_MP_CLEAR_MULTI_C)
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_CMP_C)
   #define BN_MP_CMP_MAG_C
#endif

#if defined(BN_MP_CMP_D_C)
#endif

#if defined(BN_MP_CMP_MAG_C)
#endif

#if defined(BN_MP_CNT_LSB_C)
   #define BN_MP_ISZERO_C
#endif

#if defined(BN_MP_COPY_C)
   #define BN_MP_GROW_C
#endif

#if defined(BN_MP_COUNT_BITS_C)
#endif

#if defined(BN_MP_DIV_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_CMP_MAG_C
   #define BN_MP_COPY_C
   #define BN_MP_ZERO_C
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_SET_C
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_ABS_C
   #define BN_MP_MUL_2D_C
   #define BN_MP_CMP_C
   #define BN_MP_SUB_C
   #define BN_MP_ADD_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_MULTI_C
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_INIT_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_LSHD_C
   #define BN_MP_RSHD_C
   #define BN_MP_MUL_D_C
   #define BN_MP_CLAMP_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_DIV_2_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_DIV_2D_C)
   #define BN_MP_COPY_C
   #define BN_MP_ZERO_C
   #define BN_MP_INIT_C
   #define BN_MP_MOD_2D_C
   #define BN_MP_CLEAR_C
   #define BN_MP_RSHD_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
#endif

#if defined(BN_MP_DIV_3_C)
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_DIV_D_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_COPY_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_DIV_3_C
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_DR_IS_MODULUS_C)
#endif

#if defined(BN_MP_DR_REDUCE_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_MP_DR_SETUP_C)
#endif

#if defined(BN_MP_EXCH_C)
#endif

#if defined(BN_MP_EXPT_D_C)
   #define BN_MP_INIT_COPY_C
   #define BN_MP_SET_C
   #define BN_MP_SQR_C
   #define BN_MP_CLEAR_C
   #define BN_MP_MUL_C
#endif

#if defined(BN_MP_EXPTMOD_C)
   #define BN_MP_INIT_C
   #define BN_MP_INVMOD_C
   #define BN_MP_CLEAR_C
   #define BN_MP_ABS_C
   #define BN_MP_CLEAR_MULTI_C
   #define BN_MP_REDUCE_IS_2K_L_C
   #define BN_S_MP_EXPTMOD_C
   #define BN_MP_DR_IS_MODULUS_C
   #define BN_MP_REDUCE_IS_2K_C
   #define BN_MP_ISODD_C
   #define BN_MP_EXPTMOD_FAST_C
#endif

#if defined(BN_MP_EXPTMOD_FAST_C)
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_INIT_C
   #define BN_MP_CLEAR_C
   #define BN_MP_MONTGOMERY_SETUP_C
   #define BN_FAST_MP_MONTGOMERY_REDUCE_C
   #define BN_MP_MONTGOMERY_REDUCE_C
   #define BN_MP_DR_SETUP_C
   #define BN_MP_DR_REDUCE_C
   #define BN_MP_REDUCE_2K_SETUP_C
   #define BN_MP_REDUCE_2K_C
   #define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
   #define BN_MP_MULMOD_C
   #define BN_MP_SET_C
   #define BN_MP_MOD_C
   #define BN_MP_COPY_C
   #define BN_MP_SQR_C
   #define BN_MP_MUL_C
   #define BN_MP_EXCH_C
#endif

#if defined(BN_MP_EXTEUCLID_C)
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_SET_C
   #define BN_MP_COPY_C
   #define BN_MP_ISZERO_C
   #define BN_MP_DIV_C
   #define BN_MP_MUL_C
   #define BN_MP_SUB_C
   #define BN_MP_NEG_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_FREAD_C)
   #define BN_MP_ZERO_C
   #define BN_MP_S_RMAP_C
   #define BN_MP_MUL_D_C
   #define BN_MP_ADD_D_C
   #define BN_MP_CMP_D_C
#endif

#if defined(BN_MP_FWRITE_C)
   #define BN_MP_RADIX_SIZE_C
   #define BN_MP_TORADIX_C
#endif

#if defined(BN_MP_GCD_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_ABS_C
   #define BN_MP_ZERO_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_CNT_LSB_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_CMP_MAG_C
   #define BN_MP_EXCH_C
   #define BN_S_MP_SUB_C
   #define BN_MP_MUL_2D_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_GET_INT_C)
#endif

#if defined(BN_MP_GROW_C)
#endif

#if defined(BN_MP_INIT_C)
#endif

#if defined(BN_MP_INIT_COPY_C)
   #define BN_MP_COPY_C
#endif

#if defined(BN_MP_INIT_MULTI_C)
   #define BN_MP_ERR_C
   #define BN_MP_INIT_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_INIT_SET_C)
   #define BN_MP_INIT_C
   #define BN_MP_SET_C
#endif

#if defined(BN_MP_INIT_SET_INT_C)
   #define BN_MP_INIT_C
   #define BN_MP_SET_INT_C
#endif

#if defined(BN_MP_INIT_SIZE_C)
   #define BN_MP_INIT_C
#endif

#if defined(BN_MP_INVMOD_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_ISODD_C
   #define BN_FAST_MP_INVMOD_C
   #define BN_MP_INVMOD_SLOW_C
#endif

#if defined(BN_MP_INVMOD_SLOW_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_MOD_C
   #define BN_MP_COPY_C
   #define BN_MP_ISEVEN_C
   #define BN_MP_SET_C
   #define BN_MP_DIV_2_C
   #define BN_MP_ISODD_C
   #define BN_MP_ADD_C
   #define BN_MP_SUB_C
   #define BN_MP_CMP_C
   #define BN_MP_CMP_D_C
   #define BN_MP_CMP_MAG_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_IS_SQUARE_C)
   #define BN_MP_MOD_D_C
   #define BN_MP_INIT_SET_INT_C
   #define BN_MP_MOD_C
   #define BN_MP_GET_INT_C
   #define BN_MP_SQRT_C
   #define BN_MP_SQR_C
   #define BN_MP_CMP_MAG_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_JACOBI_C)
   #define BN_MP_CMP_D_C
   #define BN_MP_ISZERO_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_CNT_LSB_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_MOD_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_KARATSUBA_MUL_C)
   #define BN_MP_MUL_C
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_SUB_C
   #define BN_MP_ADD_C
   #define BN_MP_LSHD_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_KARATSUBA_SQR_C)
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_SQR_C
   #define BN_MP_SUB_C
   #define BN_S_MP_ADD_C
   #define BN_MP_LSHD_C
   #define BN_MP_ADD_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_LCM_C)
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_GCD_C
   #define BN_MP_CMP_MAG_C
   #define BN_MP_DIV_C
   #define BN_MP_MUL_C
   #define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_LSHD_C)
   #define BN_MP_GROW_C
   #define BN_MP_RSHD_C
#endif

#if defined(BN_MP_MOD_C)
   #define BN_MP_INIT_C
   #define BN_MP_DIV_C
   #define BN_MP_CLEAR_C
   #define BN_MP_ADD_C
   #define BN_MP_EXCH_C
#endif

#if defined(BN_MP_MOD_2D_C)
   #define BN_MP_ZERO_C
   #define BN_MP_COPY_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_MOD_D_C)
   #define BN_MP_DIV_D_C
#endif

#if defined(BN_MP_MONTGOMERY_CALC_NORMALIZATION_C)
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_2EXPT_C
   #define BN_MP_SET_C
   #define BN_MP_MUL_2_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_MP_MONTGOMERY_REDUCE_C)
   #define BN_FAST_MP_MONTGOMERY_REDUCE_C
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
   #define BN_MP_RSHD_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_MP_MONTGOMERY_SETUP_C)
#endif

#if defined(BN_MP_MUL_C)
   #define BN_MP_TOOM_MUL_C
   #define BN_MP_KARATSUBA_MUL_C
   #define BN_FAST_S_MP_MUL_DIGS_C
   #define BN_S_MP_MUL_C
   #define BN_S_MP_MUL_DIGS_C
#endif

#if defined(BN_MP_MUL_2_C)
   #define BN_MP_GROW_C
#endif

#if defined(BN_MP_MUL_2D_C)
   #define BN_MP_COPY_C
   #define BN_MP_GROW_C
   #define BN_MP_LSHD_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_MUL_D_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_MULMOD_C)
   #define BN_MP_INIT_C
   #define BN_MP_MUL_C
   #define BN_MP_CLEAR_C
   #define BN_MP_MOD_C
#endif

#if defined(BN_MP_N_ROOT_C)
   #define BN_MP_INIT_C
   #define BN_MP_SET_C
   #define BN_MP_COPY_C
   #define BN_MP_EXPT_D_C
   #define BN_MP_MUL_C
   #define BN_MP_SUB_C
   #define BN_MP_MUL_D_C
   #define BN_MP_DIV_C
   #define BN_MP_CMP_C
   #define BN_MP_SUB_D_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_NEG_C)
   #define BN_MP_COPY_C
   #define BN_MP_ISZERO_C
#endif

#if defined(BN_MP_OR_C)
   #define BN_MP_INIT_COPY_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_PRIME_FERMAT_C)
   #define BN_MP_CMP_D_C
   #define BN_MP_INIT_C
   #define BN_MP_EXPTMOD_C
   #define BN_MP_CMP_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_PRIME_IS_DIVISIBLE_C)
   #define BN_MP_MOD_D_C
#endif

#if defined(BN_MP_PRIME_IS_PRIME_C)
   #define BN_MP_CMP_D_C
   #define BN_MP_PRIME_IS_DIVISIBLE_C
   #define BN_MP_INIT_C
   #define BN_MP_SET_C
   #define BN_MP_PRIME_MILLER_RABIN_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_PRIME_MILLER_RABIN_C)
   #define BN_MP_CMP_D_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_SUB_D_C
   #define BN_MP_CNT_LSB_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_EXPTMOD_C
   #define BN_MP_CMP_C
   #define BN_MP_SQRMOD_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_PRIME_NEXT_PRIME_C)
   #define BN_MP_CMP_D_C
   #define BN_MP_SET_C
   #define BN_MP_SUB_D_C
   #define BN_MP_ISEVEN_C
   #define BN_MP_MOD_D_C
   #define BN_MP_INIT_C
   #define BN_MP_ADD_D_C
   #define BN_MP_PRIME_MILLER_RABIN_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C)
#endif

#if defined(BN_MP_PRIME_RANDOM_EX_C)
   #define BN_MP_READ_UNSIGNED_BIN_C
   #define BN_MP_PRIME_IS_PRIME_C
   #define BN_MP_SUB_D_C
   #define BN_MP_DIV_2_C
   #define BN_MP_MUL_2_C
   #define BN_MP_ADD_D_C
#endif

#if defined(BN_MP_RADIX_SIZE_C)
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_ISZERO_C
   #define BN_MP_DIV_D_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_RADIX_SMAP_C)
   #define BN_MP_S_RMAP_C
#endif

#if defined(BN_MP_RAND_C)
   #define BN_MP_ZERO_C
   #define BN_MP_ADD_D_C
   #define BN_MP_LSHD_C
#endif

#if defined(BN_MP_READ_RADIX_C)
   #define BN_MP_ZERO_C
   #define BN_MP_S_RMAP_C
   #define BN_MP_RADIX_SMAP_C
   #define BN_MP_MUL_D_C
   #define BN_MP_ADD_D_C
   #define BN_MP_ISZERO_C
#endif

#if defined(BN_MP_READ_SIGNED_BIN_C)
   #define BN_MP_READ_UNSIGNED_BIN_C
#endif

#if defined(BN_MP_READ_UNSIGNED_BIN_C)
   #define BN_MP_GROW_C
   #define BN_MP_ZERO_C
   #define BN_MP_MUL_2D_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_REDUCE_C)
   #define BN_MP_REDUCE_SETUP_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_RSHD_C
   #define BN_MP_MUL_C
   #define BN_S_MP_MUL_HIGH_DIGS_C
   #define BN_FAST_S_MP_MUL_HIGH_DIGS_C
   #define BN_MP_MOD_2D_C
   #define BN_S_MP_MUL_DIGS_C
   #define BN_MP_SUB_C
   #define BN_MP_CMP_D_C
   #define BN_MP_SET_C
   #define BN_MP_LSHD_C
   #define BN_MP_ADD_C
   #define BN_MP_CMP_C
   #define BN_S_MP_SUB_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_REDUCE_2K_C)
   #define BN_MP_INIT_C
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_MUL_D_C
   #define BN_S_MP_ADD_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_REDUCE_2K_L_C)
   #define BN_MP_INIT_C
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_MUL_C
   #define BN_S_MP_ADD_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_REDUCE_2K_SETUP_C)
   #define BN_MP_INIT_C
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_2EXPT_C
   #define BN_MP_CLEAR_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_MP_REDUCE_2K_SETUP_L_C)
   #define BN_MP_INIT_C
   #define BN_MP_2EXPT_C
   #define BN_MP_COUNT_BITS_C
   #define BN_S_MP_SUB_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_REDUCE_IS_2K_C)
   #define BN_MP_REDUCE_2K_C
   #define BN_MP_COUNT_BITS_C
#endif

#if defined(BN_MP_REDUCE_IS_2K_L_C)
#endif

#if defined(BN_MP_REDUCE_SETUP_C)
   #define BN_MP_2EXPT_C
   #define BN_MP_DIV_C
#endif

#if defined(BN_MP_RSHD_C)
   #define BN_MP_ZERO_C
#endif

#if defined(BN_MP_SET_C)
   #define BN_MP_ZERO_C
#endif

#if defined(BN_MP_SET_INT_C)
   #define BN_MP_ZERO_C
   #define BN_MP_MUL_2D_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_SHRINK_C)
#endif

#if defined(BN_MP_SIGNED_BIN_SIZE_C)
   #define BN_MP_UNSIGNED_BIN_SIZE_C
#endif

#if defined(BN_MP_SQR_C)
   #define BN_MP_TOOM_SQR_C
   #define BN_MP_KARATSUBA_SQR_C
   #define BN_FAST_S_MP_SQR_C
   #define BN_S_MP_SQR_C
#endif

#if defined(BN_MP_SQRMOD_C)
   #define BN_MP_INIT_C
   #define BN_MP_SQR_C
   #define BN_MP_CLEAR_C
   #define BN_MP_MOD_C
#endif

#if defined(BN_MP_SQRT_C)
   #define BN_MP_N_ROOT_C
   #define BN_MP_ISZERO_C
   #define BN_MP_ZERO_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_RSHD_C
   #define BN_MP_DIV_C
   #define BN_MP_ADD_C
   #define BN_MP_DIV_2_C
   #define BN_MP_CMP_MAG_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_SUB_C)
   #define BN_S_MP_ADD_C
   #define BN_MP_CMP_MAG_C
   #define BN_S_MP_SUB_C
#endif

#if defined(BN_MP_SUB_D_C)
   #define BN_MP_GROW_C
   #define BN_MP_ADD_D_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_MP_SUBMOD_C)
   #define BN_MP_INIT_C
   #define BN_MP_SUB_C
   #define BN_MP_CLEAR_C
   #define BN_MP_MOD_C
#endif

#if defined(BN_MP_TO_SIGNED_BIN_C)
   #define BN_MP_TO_UNSIGNED_BIN_C
#endif

#if defined(BN_MP_TO_SIGNED_BIN_N_C)
   #define BN_MP_SIGNED_BIN_SIZE_C
   #define BN_MP_TO_SIGNED_BIN_C
#endif

#if defined(BN_MP_TO_UNSIGNED_BIN_C)
   #define BN_MP_INIT_COPY_C
   #define BN_MP_ISZERO_C
   #define BN_MP_DIV_2D_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_TO_UNSIGNED_BIN_N_C)
   #define BN_MP_UNSIGNED_BIN_SIZE_C
   #define BN_MP_TO_UNSIGNED_BIN_C
#endif

#if defined(BN_MP_TOOM_MUL_C)
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_MOD_2D_C
   #define BN_MP_COPY_C
   #define BN_MP_RSHD_C
   #define BN_MP_MUL_C
   #define BN_MP_MUL_2_C
   #define BN_MP_ADD_C
   #define BN_MP_SUB_C
   #define BN_MP_DIV_2_C
   #define BN_MP_MUL_2D_C
   #define BN_MP_MUL_D_C
   #define BN_MP_DIV_3_C
   #define BN_MP_LSHD_C
   #define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_TOOM_SQR_C)
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_MOD_2D_C
   #define BN_MP_COPY_C
   #define BN_MP_RSHD_C
   #define BN_MP_SQR_C
   #define BN_MP_MUL_2_C
   #define BN_MP_ADD_C
   #define BN_MP_SUB_C
   #define BN_MP_DIV_2_C
   #define BN_MP_MUL_2D_C
   #define BN_MP_MUL_D_C
   #define BN_MP_DIV_3_C
   #define BN_MP_LSHD_C
   #define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_TORADIX_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_DIV_D_C
   #define BN_MP_CLEAR_C
   #define BN_MP_S_RMAP_C
#endif

#if defined(BN_MP_TORADIX_N_C)
   #define BN_MP_ISZERO_C
   #define BN_MP_INIT_COPY_C
   #define BN_MP_DIV_D_C
   #define BN_MP_CLEAR_C
   #define BN_MP_S_RMAP_C
#endif

#if defined(BN_MP_UNSIGNED_BIN_SIZE_C)
   #define BN_MP_COUNT_BITS_C
#endif

#if defined(BN_MP_XOR_C)
   #define BN_MP_INIT_COPY_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_ZERO_C)
#endif

#if defined(BN_PRIME_TAB_C)
#endif

#if defined(BN_REVERSE_C)
#endif

#if defined(BN_S_MP_ADD_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BN_S_MP_EXPTMOD_C)
   #define BN_MP_COUNT_BITS_C
   #define BN_MP_INIT_C
   #define BN_MP_CLEAR_C
   #define BN_MP_REDUCE_SETUP_C
   #define BN_MP_REDUCE_C
   #define BN_MP_REDUCE_2K_SETUP_L_C
   #define BN_MP_REDUCE_2K_L_C
   #define BN_MP_MOD_C
   #define BN_MP_COPY_C
   #define BN_MP_SQR_C
   #define BN_MP_MUL_C
   #define BN_MP_SET_C
   #define BN_MP_EXCH_C
#endif

#if defined(BN_S_MP_MUL_DIGS_C)
   #define BN_FAST_S_MP_MUL_DIGS_C
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_S_MP_MUL_HIGH_DIGS_C)
   #define BN_FAST_S_MP_MUL_HIGH_DIGS_C
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_S_MP_SQR_C)
   #define BN_MP_INIT_SIZE_C
   #define BN_MP_CLAMP_C
   #define BN_MP_EXCH_C
   #define BN_MP_CLEAR_C
#endif

#if defined(BN_S_MP_SUB_C)
   #define BN_MP_GROW_C
   #define BN_MP_CLAMP_C
#endif

#if defined(BNCORE_C)
#endif

#ifdef LTM3
#define LTM_LAST
#endif
#include <tommath_superclass.h>
#include <tommath_class.h>
#else
#define LTM_LAST
#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_class.h,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Added libtommath/tommath_superclass.h.

























































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
/* super class file for PK algos */

/* default ... include all MPI */
#define LTM_ALL

/* RSA only (does not support DH/DSA/ECC) */
/* #define SC_RSA_1 */

/* For reference.... On an Athlon64 optimizing for speed...

   LTM's mpi.o with all functions [striped] is 142KiB in size.

*/

/* Works for RSA only, mpi.o is 68KiB */
#ifdef SC_RSA_1
   #define BN_MP_SHRINK_C
   #define BN_MP_LCM_C
   #define BN_MP_PRIME_RANDOM_EX_C
   #define BN_MP_INVMOD_C
   #define BN_MP_GCD_C
   #define BN_MP_MOD_C
   #define BN_MP_MULMOD_C
   #define BN_MP_ADDMOD_C
   #define BN_MP_EXPTMOD_C
   #define BN_MP_SET_INT_C
   #define BN_MP_INIT_MULTI_C
   #define BN_MP_CLEAR_MULTI_C
   #define BN_MP_UNSIGNED_BIN_SIZE_C
   #define BN_MP_TO_UNSIGNED_BIN_C
   #define BN_MP_MOD_D_C
   #define BN_MP_PRIME_RABIN_MILLER_TRIALS_C
   #define BN_REVERSE_C
   #define BN_PRIME_TAB_C

   /* other modifiers */
   #define BN_MP_DIV_SMALL                    /* Slower division, not critical */

   /* here we are on the last pass so we turn things off.  The functions classes are still there
    * but we remove them specifically from the build.  This also invokes tweaks in functions
    * like removing support for even moduli, etc...
    */
#ifdef LTM_LAST
   #undef  BN_MP_TOOM_MUL_C
   #undef  BN_MP_TOOM_SQR_C
   #undef  BN_MP_KARATSUBA_MUL_C
   #undef  BN_MP_KARATSUBA_SQR_C
   #undef  BN_MP_REDUCE_C
   #undef  BN_MP_REDUCE_SETUP_C
   #undef  BN_MP_DR_IS_MODULUS_C
   #undef  BN_MP_DR_SETUP_C
   #undef  BN_MP_DR_REDUCE_C
   #undef  BN_MP_REDUCE_IS_2K_C
   #undef  BN_MP_REDUCE_2K_SETUP_C
   #undef  BN_MP_REDUCE_2K_C
   #undef  BN_S_MP_EXPTMOD_C
   #undef  BN_MP_DIV_3_C
   #undef  BN_S_MP_MUL_HIGH_DIGS_C
   #undef  BN_FAST_S_MP_MUL_HIGH_DIGS_C
   #undef  BN_FAST_MP_INVMOD_C

   /* To safely undefine these you have to make sure your RSA key won't exceed the Comba threshold
    * which is roughly 255 digits [7140 bits for 32-bit machines, 15300 bits for 64-bit machines] 
    * which means roughly speaking you can handle upto 2536-bit RSA keys with these defined without
    * trouble.  
    */
   #undef  BN_S_MP_MUL_DIGS_C
   #undef  BN_S_MP_SQR_C
   #undef  BN_MP_MONTGOMERY_REDUCE_C
#endif

#endif

/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_superclass.h,v $ */
/* $Revision: 1.1.1.1.2.2 $ */
/* $Date: 2005/09/26 20:16:54 $ */

Changes to macosx/Makefile.

1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70




71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111

112


113
114
115



116
117
118
119




120


121
122
123
124

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

147
148

149
150
151
152
153

154
155

156

157







158
159


160
161
162
163
164

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
########################################################################################################
#
# Makefile to build Tcl on Mac OS X packaged as a Framework
#	uses standard unix build system in tcl/unix

#
# RCS: @(#) $Id: Makefile,v 1.18 2004/11/19 06:28:29 das Exp $
#
########################################################################################################

#-------------------------------------------------------------------------------------------------------
# customizable settings

DESTDIR			?=
INSTALL_ROOT		?= ${DESTDIR}

BUILD_DIR		?= ${CURDIR}/../../build
SYMROOT			?= ${BUILD_DIR}/${PROJECT}
OBJROOT			?= ${SYMROOT}

EXTRA_CONFIGURE_ARGS 	?= 
EXTRA_MAKE_ARGS		?= 

INSTALL_PATH		?= /Library/Frameworks
PREFIX			?= /usr
BINDIR			?= ${PREFIX}/bin

MANDIR			?= ${PREFIX}/man

# set to non-empty value to install manpages in addition to html help:
INSTALL_MANPAGES 	?= 

TCL_PACKAGE_PATH	?= "~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl \
			    ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks \
			    /System/Library/Frameworks"
TCL_MODULE_PATH		?= "~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl"

#-------------------------------------------------------------------------------------------------------
# meta targets

meta 			:= all install embedded install-embedded clean distclean test

styles			:= develop deploy

all			:= ${styles}
all			: ${all}

install			:= ${styles:%=install-%}
install			: ${install}
install-%:		action := install-

embedded		:= ${styles:%=embedded-%}
embedded		: embedded-deploy
install-embedded	:= $(embedded:%=install-%)
install-embedded	: install-embedded-deploy

clean			:= ${styles:%=clean-%}
clean			: ${clean}
clean-%:		action := clean-
distclean		:= ${styles:%=distclean-%}
distclean		: ${distclean}
distclean-%:		action := distclean-

test			:= ${styles:%=test-%}
test			: ${test}
test-%:			action := test-

targets			:= $(foreach v,${meta},${$v})

#-------------------------------------------------------------------------------------------------------
# build styles





develop_make_args	:= BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols
deploy_make_args	:= BUILD_STYLE=Deployment \
			   MAKE_ARGS=INSTALL_PROGRAM="'$$\$${INSTALL} $$\$${INSTALL_STRIP_PROGRAM}'" \
			   MAKE_ARGS+=INSTALL_LIBRARY="'$$\$${INSTALL} $$\$${INSTALL_STRIP_LIBRARY}'" \
			   MAKE_ARGS+=MEM_DEBUG_FLAGS="-DNDEBUG"
embedded_make_args	:= EMBEDDED_BUILD=1
install_make_args	:= INSTALL_BUILD=1

$(targets): 
	${MAKE} ${action}${PROJECT} \
	$(foreach s,${styles} embedded install,$(if $(findstring $s,$@),${${s}_make_args}))

#-------------------------------------------------------------------------------------------------------
# project specific settings

PROJECT			:= tcl
PRODUCT_NAME		:= Tcl

UNIX_DIR		:= ${CURDIR}/../unix
GENERIC_DIR		:= ${CURDIR}/../generic

PRODUCT_VERSION		:= $(shell eval $$(grep '^TCL_VERSION=' ${UNIX_DIR}/configure.in); \
				echo "$${TCL_VERSION}")
PRODUCT_LONGVERSION	:= $(shell eval $$(grep '^TCL_PATCH_LEVEL=' ${UNIX_DIR}/configure.in); \
				echo "${PRODUCT_VERSION}$${TCL_PATCH_LEVEL}")
YEAR                    := $(shell date +%Y)

TARGETS			:= tclsh tcltest
TCLSH			:= tclsh${PRODUCT_VERSION}
TCL_EXE			?= ${SYMROOT}/${TCLSH}

DYLIB_INSTALL_PATH	?= ${INSTALL_PATH}

LIBDIR			:= ${INSTALL_PATH}/${PRODUCT_NAME}.framework/Versions/${PRODUCT_VERSION}
DYLIB_INSTALL_DIR	:= ${DYLIB_INSTALL_PATH}/${PRODUCT_NAME}.framework/Versions/${PRODUCT_VERSION}
INCLUDEDIR		:= ${LIBDIR}/Headers
PRIVATEINCLUDEDIR	:= ${LIBDIR}/PrivateHeaders
SCRIPTDIR		:= ${LIBDIR}/Resources/Scripts
DOCDIR			:= ${LIBDIR}/Resources/Documentation/Reference
INFOPLIST		:= ${LIBDIR}/Resources/Info.plist


BUILD_STYLE		=


OBJ_DIR			= ${OBJROOT}/${BUILD_STYLE}

${PROJECT}:		override INSTALL_ROOT = ${OBJ_DIR}/




MAKE_VARS		:= INSTALL_ROOT TCL_PACKAGE_PATH TCL_MODULE_PATH DYLIB_INSTALL_DIR
MAKE_ARGS_V		= $(foreach v,${MAKE_VARS},$v=${$v})
export CPPROG		:= cp -p







#-------------------------------------------------------------------------------------------------------
# build rules

${PROJECT}: install-${PROJECT}


${OBJ_DIR}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure
	mkdir -p ${OBJ_DIR} && cd ${OBJ_DIR} && ${UNIX_DIR}/configure \
	--prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} \
	--includedir=${INCLUDEDIR} --mandir=${MANDIR} --enable-threads \
	--enable-framework ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}
	cd ${OBJ_DIR} && mkdir -p ${PRODUCT_NAME}.framework && \
	ln -fs ../${PRODUCT_NAME} ${PRODUCT_NAME}.framework/${PRODUCT_NAME}

build-${PROJECT}: ${OBJ_DIR}/Makefile
	${MAKE} -C ${OBJ_DIR} ${TARGETS} ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS}
# symolic link hackery to trick
# 'make install INSTALL_ROOT=${OBJ_DIR}'
# into building Tcl.framework and tclsh in ${SYMROOT}
	cd ${OBJ_DIR}; mkdir -p $(dir ./${INSTALL_PATH}) $(dir ./${BINDIR}) ${SYMROOT}; \
	rm -f ./${INSTALL_PATH}; ln -fs ${SYMROOT} ./${INSTALL_PATH}; \
	rm -f ./${BINDIR}; ln -fs ${SYMROOT} ./${BINDIR}; \
	ln -fs ${OBJ_DIR}/tcltest ${SYMROOT}

clean-${PROJECT}:
	${MAKE} -C ${OBJ_DIR} clean ${EXTRA_MAKE_ARGS}


distclean-${PROJECT}:
	${MAKE} -C ${OBJ_DIR} distclean ${EXTRA_MAKE_ARGS}

	rm -rf ${OBJ_DIR} ${PRODUCT_NAME}.framework tclsh${PRODUCT_VERSION} tcltest
	
test-${PROJECT}: build-${PROJECT}
	${MAKE} -C ${OBJ_DIR} test ${EXTRA_MAKE_ARGS}


install-${PROJECT}: build-${PROJECT}
# install to ${INSTALL_ROOT} with optional stripping

	${MAKE} -C ${OBJ_DIR} install-binaries install-libraries install-private-headers \

	SCRIPT_INSTALL_DIR=${INSTALL_ROOT}${SCRIPTDIR} \







	PRIVATE_INCLUDE_INSTALL_DIR=${INSTALL_ROOT}${PRIVATEINCLUDEDIR} \
	${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS}


ifeq (${BUILD_STYLE},Development)
# keep copy of debug library around, so that
# Deployment build can be installed on top
# of Development build without overwriting
# the debug library

	cd ${INSTALL_ROOT}${LIBDIR} && ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"
endif
# fixup Framework structure
	cd ${INSTALL_ROOT}${LIBDIR}/.. && \
	rm -f Current && ln -fs ${PRODUCT_VERSION} Current && \
	cd .. && ln -fs Versions/Current/* . && \
	ln -fs Versions/${PRODUCT_VERSION}/lib*stub* .
ifeq (${INSTALL_BUILD},1)
ifeq (${EMBEDDED_BUILD},1)
# if we are embedding frameworks, don't install tclsh
	rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}"
	-rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&-
else
# redo prebinding
	cd ${INSTALL_ROOT}/; \
	if [ ! -d usr/lib ]; then mkdir -p usr; ln -fs /usr/lib usr/; RM_USRLIB=1; fi; \
	if [ ! -d System ]; then ln -fs /System .; RM_SYSTEM=1; fi; \
	redo_prebinding -r . "./${BINDIR}/${TCLSH}"; \
	if [ -n "$${RM_USRLIB:-}" ]; then rm -f usr/lib; rmdir -p usr 2>&-; fi; \
	if [ -n "$${RM_SYSTEM:-}" ]; then rm -f System; fi
# install tclsh symbolic link
	ln -fs ${TCLSH} ${INSTALL_ROOT}${BINDIR}/tclsh
ifeq (${BUILD_STYLE},Deployment)

ifneq (${INSTALL_MANPAGES},)
# install manpages
	${MAKE} -C ${OBJ_DIR} install-doc ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS}
endif
# build html documentation
	export DYLD_FRAMEWORK_PATH=${SYMROOT} && \
	${MAKE} -C ${OBJ_DIR} html-tcl ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} \
	DISTDIR=${INSTALL_ROOT}${DOCDIR} TCL_EXE=${TCL_EXE} && \
	cd ${INSTALL_ROOT}${DOCDIR} && ln -fs contents.htm html/${PRODUCT_NAME}TOC.html && \
	rm -fr "${PRODUCT_NAME}" && mv -f html "${PRODUCT_NAME}"
endif
endif
endif
# write Info.plist file
	@printf > ${INSTALL_ROOT}${INFOPLIST} '\
	<?xml version="1.0" encoding="UTF-8"?>\n\
	<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN"\
	"http://www.apple.com/DTDs/PropertyList-1.0.dtd">\n\
	<plist version="1.0">\n\
	<dict>\n\
		<key>CFBundleDevelopmentRegion</key>\n\
		<string>English</string>\n\
		<key>CFBundleExecutable</key>\n\
		<string>Tcl</string>\n\
		<key>CFBundleGetInfoString</key>\n\
		<string>Tcl Library ${PRODUCT_VERSION}, Copyright © ${YEAR} Tcl Core Team.\n\
	MacOS X Port by Jim Ingham &lt;[email protected]&gt; &amp; Ian Reid, Copyright\
	© 2001-2002, Apple Computer, Inc.</string>\n\
		<key>CFBundleIdentifier</key>\n\
		<string>com.tcltk.tcllibrary</string>\n\
		<key>CFBundleInfoDictionaryVersion</key>\n\
		<string>6.0</string>\n\
		<key>CFBundleName</key>\n\
		<string>Tcl Library ${PRODUCT_VERSION}</string>\n\
		<key>CFBundlePackageType</key>\n\
		<string>FMWK</string>\n\
		<key>CFBundleShortVersionString</key>\n\
		<string>${PRODUCT_LONGVERSION}</string>\n\
		<key>CFBundleSignature</key>\n\
		<string>Tcl </string>\n\
		<key>CFBundleVersion</key>\n\
		<string>${PRODUCT_LONGVERSION}</string>\n\
	</dict>\n\
	</plist>\n'

#-------------------------------------------------------------------------------------------------------

.PHONY: ${meta} ${targets} ${PROJECT} build-${PROJECT} install-${PROJECT} \
	clean-${PROJECT} distclean-${PROJECT}

.NOTPARALLEL:

#-------------------------------------------------------------------------------------------------------


|
|
>

|

















|

>





<
<
<
<
<
















|


















>
>
>
>

|
<
<
|



|










<
|
<
|
<
<
<

|
|
<

<
|
<
<
|
<
<
<
<

>
|
>
>
|
|
|
>
>
>

|
|
|
>
>
>
>

>
>



|
>


|

|
|
<
<


|



|
<
|
|

|
<
|
>
|
<
>
|
|
<
|
|
>
|
|
>
|
>
|
>
>
>
>
>
>
>
|
<
>
>
|




>
|

|
<
<
<
|
|
<
|
|
|
<
<
<
<
<
<
|
|
<
<
<
>
|
<
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<









1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32





33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73


74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

89

90



91
92
93

94

95


96




97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129


130
131
132
133
134
135
136

137
138
139
140

141
142
143

144
145
146

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174



175
176

177
178
179






180
181



182
183

184
185
186


187




































188
189
190
191
192
193
194
195
196
########################################################################################################
#
# Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem
#	uses the standard unix build system in tcl/unix (which can be used directly instead of this
#	if you are not using the tk/macosx projects).
#
# RCS: @(#) $Id: Makefile,v 1.18.2.2 2005/07/12 20:37:06 kennykb Exp $
#
########################################################################################################

#-------------------------------------------------------------------------------------------------------
# customizable settings

DESTDIR			?=
INSTALL_ROOT		?= ${DESTDIR}

BUILD_DIR		?= ${CURDIR}/../../build
SYMROOT			?= ${BUILD_DIR}/${PROJECT}
OBJROOT			?= ${SYMROOT}

EXTRA_CONFIGURE_ARGS 	?= 
EXTRA_MAKE_ARGS		?= 

INSTALL_PATH		?= /Library/Frameworks
PREFIX			?= /usr/local
BINDIR			?= ${PREFIX}/bin
LIBDIR			?= ${INSTALL_PATH}
MANDIR			?= ${PREFIX}/man

# set to non-empty value to install manpages in addition to html help:
INSTALL_MANPAGES 	?= 






#-------------------------------------------------------------------------------------------------------
# meta targets

meta 			:= all install embedded install-embedded clean distclean test

styles			:= develop deploy

all			:= ${styles}
all			: ${all}

install			:= ${styles:%=install-%}
install			: ${install}
install-%:		action := install-

embedded		:= ${styles:%=embedded-%}
embedded		: embedded-deploy
install-embedded	:= ${embedded:%=install-%}
install-embedded	: install-embedded-deploy

clean			:= ${styles:%=clean-%}
clean			: ${clean}
clean-%:		action := clean-
distclean		:= ${styles:%=distclean-%}
distclean		: ${distclean}
distclean-%:		action := distclean-

test			:= ${styles:%=test-%}
test			: ${test}
test-%:			action := test-

targets			:= $(foreach v,${meta},${$v})

#-------------------------------------------------------------------------------------------------------
# build styles

BUILD_STYLE		=
CONFIGURE_ARGS		=
OBJ_DIR			= ${OBJROOT}/${BUILD_STYLE}

develop_make_args	:= BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols
deploy_make_args	:= BUILD_STYLE=Deployment INSTALL_TARGET=install-strip \


			   GENERIC_FLAGS=-DNDEBUG
embedded_make_args	:= EMBEDDED_BUILD=1
install_make_args	:= INSTALL_BUILD=1

${targets}: 
	${MAKE} ${action}${PROJECT} \
	$(foreach s,${styles} embedded install,$(if $(findstring $s,$@),${${s}_make_args}))

#-------------------------------------------------------------------------------------------------------
# project specific settings

PROJECT			:= tcl
PRODUCT_NAME		:= Tcl

UNIX_DIR		:= ${CURDIR}/../unix

VERSION			:= $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.in)

TCLSH			:= tclsh${VERSION}




BUILD_TARGET		:= tclsh tcltest
INSTALL_TARGET		:= install



override GENERIC_FLAGS	:= ${GENERIC_FLAGS} -DTCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING


export CPPROG		:= cp -p





INSTALL_TARGETS		= install-binaries install-libraries
ifeq (${EMBEDDED_BUILD},)
INSTALL_TARGETS		+= install-private-headers
endif
ifeq (${INSTALL_BUILD}_${EMBEDDED_BUILD}_${BUILD_STYLE},1__Deployment)
INSTALL_TARGETS		+= html-tcl
ifneq (${INSTALL_MANPAGES},)
INSTALL_TARGETS		+= install-doc
endif
endif

MAKE_VARS		:= INSTALL_ROOT INSTALL_TARGETS VERSION GENERIC_FLAGS
MAKE_ARGS_V		= $(foreach v,${MAKE_VARS},$v='${$v}')

build-${PROJECT}:	target = ${TARGET}
install-${PROJECT}:	target = ${INSTALL_TARGET}
clean-${PROJECT} distclean-${PROJECT} test-${PROJECT}: \
			target = $*

DO_MAKE			= +${MAKE} -C ${OBJ_DIR} ${target} ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS}

#-------------------------------------------------------------------------------------------------------
# build rules

${PROJECT}:
	${MAKE} install-${PROJECT} INSTALL_ROOT=${OBJ_DIR}/

${OBJ_DIR}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure
	mkdir -p ${OBJ_DIR} && cd ${OBJ_DIR} && ${UNIX_DIR}/configure -C \
	--prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} \
	--mandir=${MANDIR} --enable-threads --enable-framework \
	${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}



build-${PROJECT}: ${OBJ_DIR}/Makefile
	${DO_MAKE}
# symolic link hackery to trick
# 'make install INSTALL_ROOT=${OBJ_DIR}'
# into building Tcl.framework and tclsh in ${SYMROOT}
	@cd ${OBJ_DIR} && mkdir -p $(dir ./${LIBDIR}) $(dir ./${BINDIR}) ${SYMROOT} && \

	rm -f ./${LIBDIR} ./${BINDIR} && ln -fs ${SYMROOT} ./${LIBDIR} && \
	ln -fs ${SYMROOT} ./${BINDIR} && ln -fs ${OBJ_DIR}/tcltest ${SYMROOT}

install-${PROJECT}: build-${PROJECT}

ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_)
	@echo "Cannot install-embedded with empty INSTALL_ROOT !" && false
endif

ifeq (${EMBEDDED_BUILD},1)
	@rm -rf "${INSTALL_ROOT}/${LIBDIR}/Tcl.framework"
endif

	${DO_MAKE}
ifeq (${INSTALL_BUILD},1)
ifeq (${EMBEDDED_BUILD},1)
# if we are embedding frameworks, don't install tclsh
	@rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}" && \
	rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&- || true
else
# redo prebinding
	@cd ${INSTALL_ROOT}/ && \
	if [ ! -d usr/lib ]; then mkdir -p usr && ln -fs /usr/lib usr/ && RM_USRLIB=1; fi; \
	if [ ! -d System ]; then ln -fs /System . && RM_SYSTEM=1; fi; \
	redo_prebinding -r . "./${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}/${PRODUCT_NAME}"; \
	redo_prebinding -r . "./${BINDIR}/${TCLSH}"; \
	if [ -n "$${RM_USRLIB:-}" ]; then rm -f usr/lib; rmdir -p usr 2>&-; fi; \
	if [ -n "$${RM_SYSTEM:-}" ]; then rm -f System; fi
# install tclsh symbolic link
	@ln -fs ${TCLSH} ${INSTALL_ROOT}${BINDIR}/tclsh

endif
endif
ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_)
# keep copy of debug library around, so that
# Deployment build can be installed on top
# of Development build without overwriting
# the debug library
	@cd ${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION} && \
	ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"
endif




clean-${PROJECT}: %-${PROJECT}:
	${DO_MAKE}

	rm -rf ${SYMROOT}/{${PRODUCT_NAME}.framework,${TCLSH},tcltest}
	rm -f ${OBJ_DIR}{${LIBDIR},${BINDIR}} && \
	rmdir -p ${OBJ_DIR}$(dir ${LIBDIR}) 2>&- || true && \






	rmdir -p ${OBJ_DIR}$(dir ${BINDIR}) 2>&- || true




distclean-${PROJECT}: %-${PROJECT}: clean-${PROJECT}
	${DO_MAKE}

	rm -rf ${OBJ_DIR}
	
test-${PROJECT}: %-${PROJECT}: build-${PROJECT}


	${DO_MAKE}





































#-------------------------------------------------------------------------------------------------------

.PHONY: ${meta} ${targets} ${PROJECT} build-${PROJECT} install-${PROJECT} \
	clean-${PROJECT} distclean-${PROJECT}

.NOTPARALLEL:

#-------------------------------------------------------------------------------------------------------

Changes to macosx/README.

1
2
3
4
5
6
7
8
9
10
11
Tcl MacOSX README 
-----------------

RCS: @(#) $Id: README,v 1.2 2003/07/18 02:02:02 das Exp $

This is the README file for the Mac OS X native version of Tcl (framework build).


1. General
----------




|







1
2
3
4
5
6
7
8
9
10
11
Tcl MacOSX README 
-----------------

RCS: @(#) $Id: README,v 1.2.4.2 2005/07/12 20:37:06 kennykb Exp $

This is the README file for the Mac OS X native version of Tcl (framework build).


1. General
----------

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79


80

81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
please make sure that your report Tk specific bugs to the tktoolkit bug
tracker and not the tcl one.


2. Using Tcl on MacOSX
----------------------

- Mac OS X 10.1 (or higher) is required to run Tcl on MacOSX.

- Tcl built on Mac OS X 10.2 or higher will not run on 10.1 due to missing
symbols in libSystem, however Tcl built on 10.1 will run on 10.2 (but without
prebinding and other optimizations).

- Tcl extensions will be found in any of:
	$HOME/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl
	$HOME/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks
	/System/Library/Frameworks (searched in that order).
Given a potential package directory $pkg, Tcl on OSX checks for the file
$pkg/Resources/Scripts/pkgIndex.tcl as well as the usual $pkg/pkgIndex.tcl.
This allows building extensions as frameworks with all script files contained
in the Resources/Scripts directory of the framework.

- The Tcl framework contains documentation in html format in the
standard location for frameworks:
	Tcl.framework/Resources/English.lproj/Documentation/Reference/Tcl
No manpages are installed by default.

- the framework Tcl.framework can be placed in any of the system's standard
framework directories:
	$HOME/Library/Frameworks /Library/Frameworks
	/Network/Library/Frameworks /System/Library/Frameworks
and /usr/bin/tclsh will work.

- the format of binary extensions expected by [load] is that of ordinary shared
libraries (.dylib) and not MachO bundles, at present loading of MachO bundles is
not supported.


3. Building Tcl.framework
-------------------------

- Mac OS X 10.1.5 (or higher) is required to build TclMacOSX.

- Apple's Developer Tools CD needs to be installed (the version matching your OS
release, but no earlier than April 2002). This CD should have come with Mac OS X
retail or should be present as a disk image on new macs that came with OSX
preinstalled. It can also be downloaded from http://connect.apple.com (after you
register for free ADC membership).

- Tcl is built as a Mac OS X framework via the Makefile in tcl/macosx, but can


also be built from Apple's ProjectBuilder IDE using the Tcl.pbproj project (which

calls through to the Makefile).


- Unpack the tcl archive

- The following instructions assume the tcl source tree is named "tcl${ver}", 
where ${ver} is a shell variable containing the tcl version number (for 
example '8.4.2').
Setup the shell variable as follows:
	set ver="8.4.2" ;: if your shell is csh
	ver="8.4.2"     ;: if your shell is sh
The source tree will be named this way only if you are building from a release
archive, if you are building from CVS, the version numbers will be missing; so
set ${ver} to the empty string instead:
	set ver=""     ;: if your shell is csh
	ver=""         ;: if your shell is sh

- If you're only interested in _building_ Tcl.framework and don't plan on doing
development with the ProjectBuilder projects, using the Makefile is easiest.
The following steps will build Tcl from the Terminal, assuming you are
located in the directory containing the tcl source tree:
	make -C tcl${ver}/macosx
and the following will then install Tcl onto the root volume (admin password 
required):
	sudo make -C tcl${ver}/macosx install
if you don't have the admin password, you can install into your home directory,
instead by passing an INSTALL_ROOT argument to make:







|

|
|













|
















|

|
|
|
|
|


>
>
|
>
|
>

|













<
<
|







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100


101
102
103
104
105
106
107
108
please make sure that your report Tk specific bugs to the tktoolkit bug
tracker and not the tcl one.


2. Using Tcl on MacOSX
----------------------

- Mac OS X 10.2 (or higher) is required to run Tcl on MacOSX.

- Tcl built on Mac OS X 10.3 or higher will not run on 10.2 due to missing
symbols in libSystem, however Tcl built on 10.2 will run on 10.3 (but without
prebinding and other optimizations).

- Tcl extensions will be found in any of:
	$HOME/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl
	$HOME/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks
	/System/Library/Frameworks (searched in that order).
Given a potential package directory $pkg, Tcl on OSX checks for the file
$pkg/Resources/Scripts/pkgIndex.tcl as well as the usual $pkg/pkgIndex.tcl.
This allows building extensions as frameworks with all script files contained
in the Resources/Scripts directory of the framework.

- The Tcl framework contains documentation in html format in the
standard location for frameworks:
	Tcl.framework/Resources/Documentation/Reference/Tcl
No manpages are installed by default.

- the framework Tcl.framework can be placed in any of the system's standard
framework directories:
	$HOME/Library/Frameworks /Library/Frameworks
	/Network/Library/Frameworks /System/Library/Frameworks
and /usr/bin/tclsh will work.

- the format of binary extensions expected by [load] is that of ordinary shared
libraries (.dylib) and not MachO bundles, at present loading of MachO bundles is
not supported.


3. Building Tcl.framework
-------------------------

- Mac OS X 10.2 (or higher) is required to build Tcl on MacOSX.

- Apple's Developer Tools CD needs to be installed (the most recent version
matching your OS release, but no earlier than December 2002). This CD should
have come with Mac OS X retail or should be present as a disk image on new macs
that came with OSX preinstalled. It can also be downloaded from
http://connect.apple.com (after you register for free ADC membership).

- Tcl is built as a Mac OS X framework via the Makefile in tcl/macosx, but can
but can also be built directly with the standard unix configure and make
buildsystem in tcl/unix.

- It is still possible to build with Apple's Xcode IDE using the Tcl.pbproj
project but this is not recommended anymore (currently Tcl.pbproj calls through
to the tcl/macosx/Makefile so there should be no build differences).

- Unpack the tcl source release archive.

- The following instructions assume the tcl source tree is named "tcl${ver}", 
where ${ver} is a shell variable containing the tcl version number (for 
example '8.4.2').
Setup the shell variable as follows:
	set ver="8.4.2" ;: if your shell is csh
	ver="8.4.2"     ;: if your shell is sh
The source tree will be named this way only if you are building from a release
archive, if you are building from CVS, the version numbers will be missing; so
set ${ver} to the empty string instead:
	set ver=""     ;: if your shell is csh
	ver=""         ;: if your shell is sh



- The following steps will build Tcl from the Terminal, assuming you are
located in the directory containing the tcl source tree:
	make -C tcl${ver}/macosx
and the following will then install Tcl onto the root volume (admin password 
required):
	sudo make -C tcl${ver}/macosx install
if you don't have the admin password, you can install into your home directory,
instead by passing an INSTALL_ROOT argument to make:

Added macosx/Tcl-Info.plist.in.























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>@TCL_LIB_FILE@</string>
	<key>CFBundleGetInfoString</key>
	<string>Tcl Library @TCL_VERSION@, Copyright © @TCL_YEAR@ Tcl Core Team.
Initial MacOS X Port by Jim Ingham &lt;[email protected]&gt; &amp; Ian Reid, Copyright © 2001-2002, Apple Computer, Inc.</string>
	<key>CFBundleIdentifier</key>
	<string>com.tcltk.tcllibrary</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleName</key>
	<string>Tcl Library @TCL_VERSION@</string>
	<key>CFBundlePackageType</key>
	<string>FMWK</string>
	<key>CFBundleShortVersionString</key>
	<string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string>
	<key>CFBundleSignature</key>
	<string>Tcl </string>
	<key>CFBundleVersion</key>
	<string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string>
</dict>
</plist>

Changes to macosx/tclMacOSXBundle.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55


56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129
130
131
132
133
134

135


136
137
138
139
140

141
142

143
144
145
146
147
148
149
150

151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

171
172
173


174
175

176
177

178
179

180
181
182
183
184
185

186
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211



212








/*
 * tclMacOSXBundle.c --
 *
 *	This file implements functions that inspect CFBundle structures
 *      on MacOS X.
 *
 *      Copyright 2001, Apple Computer, Inc.
 *
 *      The following terms apply to all files originating from Apple
 *      Computer, Inc. ("Apple") and associated with the software
 *      unless explicitly disclaimed in individual files.
 *
 *
 *      Apple hereby grants permission to use, copy, modify,
 *      distribute, and license this software and its documentation
 *      for any purpose, provided that existing copyright notices are
 *      retained in all copies and that this notice is included
 *      verbatim in any distributions. No written agreement, license,
 *      or royalty fee is required for any of the authorized
 *      uses. Modifications to this software may be copyrighted by
 *      their authors and need not follow the licensing terms
 *      described here, provided that the new terms are clearly
 *      indicated on the first page of each file where they apply.
 *
 *
 *      IN NO EVENT SHALL APPLE, THE AUTHORS OR DISTRIBUTORS OF THE
 *      SOFTWARE BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL,
 *      INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF
 *      THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF,
 *      EVEN IF APPLE OR THE AUTHORS HAVE BEEN ADVISED OF THE
 *      POSSIBILITY OF SUCH DAMAGE.  APPLE, THE AUTHORS AND
 *      DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING,
 *      BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
 *      FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS
 *      SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND APPLE,THE
 *      AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
 *      MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 *
 *      GOVERNMENT USE: If you are acquiring this software on behalf
 *      of the U.S. government, the Government shall have only
 *      "Restricted Rights" in the software and related documentation
 *      as defined in the Federal Acquisition Regulations (FARs) in
 *      Clause 52.227.19 (c) (2).  If you are acquiring the software
 *      on behalf of the Department of Defense, the software shall be
 *      classified as "Commercial Computer Software" and the
 *      Government shall have only "Restricted Rights" as defined in
 *      Clause 252.227-7013 (c) (1) of DFARs.  Notwithstanding the
 *      foregoing, the authors grant the U.S. Government and others
 *      acting in its behalf permission to use and distribute the
 *      software in accordance with the terms specified in this
 *      license.
 */


#include <CoreFoundation/CoreFoundation.h>
#include <mach-o/dyld.h>


#include "tcl.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MacOSXOpenBundleResources --
 *
 *	Given the bundle name for a shared library, this routine sets
 *	libraryPath to the Resources/Scripts directory in the framework
 *	package.  If hasResourceFile is true, it will also open the main
 *	resource file for the bundle.
 *
 *
 * Results:
 *	TCL_OK if the bundle could be opened, and the Scripts folder found.
 *      TCL_ERROR otherwise.
 *
 * Side effects:
 *	libraryVariableName may be set, and the resource file opened.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MacOSXOpenBundleResources(
    Tcl_Interp *interp,
    CONST char *bundleName,
    int         hasResourceFile,
    int         maxPathLen,
    char       *libraryPath)
{
    return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName,
    	    NULL, hasResourceFile, maxPathLen, libraryPath);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MacOSXOpenVersionedBundleResources --
 *
 *	Given the bundle and version name for a shared library (version
 *	name can be NULL to indicate latest version), this routine sets 
 *	libraryPath to the Resources/Scripts directory in the framework
 *	package.  If hasResourceFile is true, it will also open the main
 *	resource file for the bundle.
 *
 *
 * Results:
 *	TCL_OK if the bundle could be opened, and the Scripts folder found.
 *      TCL_ERROR otherwise.
 *
 * Side effects:
 *	libraryVariableName may be set, and the resource file opened.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MacOSXOpenVersionedBundleResources(
    Tcl_Interp *interp,
    CONST char *bundleName,
    CONST char *bundleVersion,
    int         hasResourceFile,
    int         maxPathLen,
    char       *libraryPath)
{

    CFBundleRef bundleRef;
    CFStringRef bundleNameRef;
    CFURLRef libURL;

    libraryPath[0] = '\0';

    bundleNameRef = CFStringCreateWithCString(NULL,
	    bundleName, kCFStringEncodingUTF8);

    bundleRef = CFBundleGetBundleWithIdentifier(bundleNameRef);
    CFRelease(bundleNameRef);

    if (bundleVersion && bundleRef) {

        /* create bundle from bundleVersion subdirectory of 'Versions' */


    	CFBundleRef versionedBundleRef = NULL;
	CFURLRef versionedBundleURL = NULL;
	CFStringRef bundleVersionRef = CFStringCreateWithCString(NULL,
		bundleVersion, kCFStringEncodingUTF8);
	CFURLRef bundleURL = CFBundleCopyBundleURL(bundleRef);

	if (bundleURL) {
	    CFStringRef bundleTailRef = CFURLCopyLastPathComponent(bundleURL);

	    if (bundleTailRef) {
		if (CFStringCompare(bundleTailRef,bundleVersionRef,0)
			== kCFCompareEqualTo) {
		    versionedBundleRef = bundleRef;
		}
		CFRelease(bundleTailRef);
	    }
	}

	if (bundleURL && !versionedBundleRef) {
	    CFURLRef versURL = CFURLCreateCopyAppendingPathComponent(NULL,
	    	    bundleURL, CFSTR("Versions"), TRUE);

	    if (versURL) {
		versionedBundleURL = CFURLCreateCopyAppendingPathComponent(
			NULL, versURL, bundleVersionRef, TRUE);
		CFRelease(versURL);
	    }
	    CFRelease(bundleURL);
	}
	CFRelease(bundleVersionRef);
	if (versionedBundleURL) {
	    versionedBundleRef = CFBundleCreate(NULL, versionedBundleURL);
	    CFRelease(versionedBundleURL);
	}
	bundleRef = versionedBundleRef;
    }

    if (bundleRef) {	
	if (hasResourceFile) {

	    /* Dynamically acquire address for CFBundleOpenBundleResourceMap
	     * symbol, since it is only present in full CoreFoundation
	     * on Mac OS X and not in CFLite on pure Darwin. */


	    static int initialized = FALSE;
	    static short (*openresourcemap)(CFBundleRef) = NULL;

	    if(!initialized) {
		NSSymbol nsSymbol = NULL;

		if(NSIsSymbolNameDefinedWithHint("_CFBundleOpenBundleResourceMap", "CoreFoundation")) {
		    nsSymbol = NSLookupAndBindSymbolWithHint("_CFBundleOpenBundleResourceMap", "CoreFoundation");

		    if(nsSymbol) {
			openresourcemap = NSAddressOfSymbol(nsSymbol);
		    }
		}
		initialized = TRUE;
	    }

	    if (openresourcemap) {
		short refNum;

		refNum = openresourcemap(bundleRef);
	    }
	}

	libURL = CFBundleCopyResourceURL(bundleRef,
		CFSTR("Scripts"), NULL, NULL);

	if (libURL) {
	    /*
	     * FIXME: This is a quick fix, it is probably not right
	     * for internationalization.
	     */

	    CFURLGetFileSystemRepresentation(libURL, TRUE,
		    libraryPath, maxPathLen);
	    CFRelease(libURL);
	}
    }
    
    if (libraryPath[0]) {
        return TCL_OK;
    } else {
	return TCL_ERROR;
    }



}











|
|

|

|
|
|

<
|
|
|
<
|
|
|
|
|
|

<
|
|
|
|
|
<
|
|
|
|
|
|

|
|
|
|
<
|
|
|
|
|
|
|
<


>


>
>









|

<



|











|
|
|


|







|
|
|
|
|
<



|












|
|
|

>






|
|





>
|
>
>
|




>


>

|
|





>


|
>

















>
|
|
|
>
>


>
|

>
|
|
>
|





>


>




|
|



|
|



|





|



>
>
>

>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12

13
14
15

16
17
18
19
20
21
22

23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
/*
 * tclMacOSXBundle.c --
 *
 *	This file implements functions that inspect CFBundle structures on
 *	MacOS X.
 *
 *	Copyright 2001, Apple Computer, Inc.
 *
 *	The following terms apply to all files originating from Apple
 *	Computer, Inc. ("Apple") and associated with the software unless
 *	explicitly disclaimed in individual files.
 *

 *	Apple hereby grants permission to use, copy, modify, distribute, and
 *	license this software and its documentation for any purpose, provided
 *	that existing copyright notices are retained in all copies and that

 *	this notice is included verbatim in any distributions. No written
 *	agreement, license, or royalty fee is required for any of the
 *	authorized uses. Modifications to this software may be copyrighted by
 *	their authors and need not follow the licensing terms described here,
 *	provided that the new terms are clearly indicated on the first page of
 *	each file where they apply.
 *

 *	IN NO EVENT SHALL APPLE, THE AUTHORS OR DISTRIBUTORS OF THE SOFTWARE
 *	BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR
 *	CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS
 *	DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF APPLE OR THE
 *	AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. APPLE,

 *	THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
 *	INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
 *	MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
 *	NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND
 *	APPLE,THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
 *	MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 *
 *	GOVERNMENT USE: If you are acquiring this software on behalf of the
 *	U.S. government, the Government shall have only "Restricted Rights" in
 *	the software and related documentation as defined in the Federal
 *	Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are

 *	acquiring the software on behalf of the Department of Defense, the
 *	software shall be classified as "Commercial Computer Software" and the
 *	Government shall have only "Restricted Rights" as defined in Clause
 *	252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
 *	authors grant the U.S. Government and others acting in its behalf
 *	permission to use and distribute the software in accordance with the
 *	terms specified in this license.

 */

#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#include <mach-o/dyld.h>
#endif /* HAVE_COREFOUNDATION */

#include "tcl.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MacOSXOpenBundleResources --
 *
 *	Given the bundle name for a shared library, this routine sets
 *	libraryPath to the Resources/Scripts directory in the framework
 *	package. If hasResourceFile is true, it will also open the main
 *	resource file for the bundle.

 *
 * Results:
 *	TCL_OK if the bundle could be opened, and the Scripts folder found.
 *	TCL_ERROR otherwise.
 *
 * Side effects:
 *	libraryVariableName may be set, and the resource file opened.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MacOSXOpenBundleResources(
    Tcl_Interp *interp,
    CONST char *bundleName,
    int hasResourceFile,
    int maxPathLen,
    char *libraryPath)
{
    return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName,
	    NULL, hasResourceFile, maxPathLen, libraryPath);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MacOSXOpenVersionedBundleResources --
 *
 *	Given the bundle and version name for a shared library (version name
 *	can be NULL to indicate latest version), this routine sets libraryPath
 *	to the Resources/Scripts directory in the framework package. If
 *	hasResourceFile is true, it will also open the main resource file for
 *	the bundle.

 *
 * Results:
 *	TCL_OK if the bundle could be opened, and the Scripts folder found.
 *	TCL_ERROR otherwise.
 *
 * Side effects:
 *	libraryVariableName may be set, and the resource file opened.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MacOSXOpenVersionedBundleResources(
    Tcl_Interp *interp,
    CONST char *bundleName,
    CONST char *bundleVersion,
    int hasResourceFile,
    int maxPathLen,
    char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
    CFBundleRef bundleRef;
    CFStringRef bundleNameRef;
    CFURLRef libURL;

    libraryPath[0] = '\0';

    bundleNameRef = CFStringCreateWithCString(NULL, bundleName,
	    kCFStringEncodingUTF8);

    bundleRef = CFBundleGetBundleWithIdentifier(bundleNameRef);
    CFRelease(bundleNameRef);

    if (bundleVersion && bundleRef) {
	/*
	 * Create bundle from bundleVersion subdirectory of 'Versions'.
	 */

	CFBundleRef versionedBundleRef = NULL;
	CFURLRef versionedBundleURL = NULL;
	CFStringRef bundleVersionRef = CFStringCreateWithCString(NULL,
		bundleVersion, kCFStringEncodingUTF8);
	CFURLRef bundleURL = CFBundleCopyBundleURL(bundleRef);

	if (bundleURL) {
	    CFStringRef bundleTailRef = CFURLCopyLastPathComponent(bundleURL);

	    if (bundleTailRef) {
		if (CFStringCompare(bundleTailRef, bundleVersionRef,
			0) == kCFCompareEqualTo) {
		    versionedBundleRef = bundleRef;
		}
		CFRelease(bundleTailRef);
	    }
	}

	if (bundleURL && !versionedBundleRef) {
	    CFURLRef versURL = CFURLCreateCopyAppendingPathComponent(NULL,
		    bundleURL, CFSTR("Versions"), TRUE);

	    if (versURL) {
		versionedBundleURL = CFURLCreateCopyAppendingPathComponent(
			NULL, versURL, bundleVersionRef, TRUE);
		CFRelease(versURL);
	    }
	    CFRelease(bundleURL);
	}
	CFRelease(bundleVersionRef);
	if (versionedBundleURL) {
	    versionedBundleRef = CFBundleCreate(NULL, versionedBundleURL);
	    CFRelease(versionedBundleURL);
	}
	bundleRef = versionedBundleRef;
    }

    if (bundleRef) {	
	if (hasResourceFile) {
	    /*
	     * Dynamically acquire address for CFBundleOpenBundleResourceMap
	     * symbol, since it is only present in full CoreFoundation on Mac
	     * OS X and not in CFLite on pure Darwin.
	     */

	    static int initialized = FALSE;
	    static short (*openresourcemap)(CFBundleRef) = NULL;

	    if (!initialized) {
		NSSymbol nsSymbol = NULL;
		if (NSIsSymbolNameDefinedWithHint(
			"_CFBundleOpenBundleResourceMap", "CoreFoundation")) {
		    nsSymbol = NSLookupAndBindSymbolWithHint(
			    "_CFBundleOpenBundleResourceMap","CoreFoundation");
		    if (nsSymbol) {
			openresourcemap = NSAddressOfSymbol(nsSymbol);
		    }
		}
		initialized = TRUE;
	    }

	    if (openresourcemap) {
		short refNum;

		refNum = openresourcemap(bundleRef);
	    }
	}

	libURL = CFBundleCopyResourceURL(bundleRef, CFSTR("Scripts"),
		NULL, NULL);

	if (libURL) {
	    /*
	     * FIXME: This is a quick fix, it is probably not right for
	     * internationalization.
	     */

	    CFURLGetFileSystemRepresentation(libURL, TRUE,
		    (unsigned char*) libraryPath, maxPathLen);
	    CFRelease(libURL);
	}
    }
    
    if (libraryPath[0]) {
	return TCL_OK;
    } else {
	return TCL_ERROR;
    }
#else  /* HAVE_COREFOUNDATION */
    return TCL_ERROR;
#endif /* HAVE_COREFOUNDATION */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to macosx/tclMacOSXFCmd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

108


109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

196


197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

237
238
239
240
241
242
243
244
245
246
247
248


249

250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266

267
268
269
270

271
272
273
274
275
276
277

278


279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345

346


347
348
349
350
351
352
353
354
355
356
357

358


359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
/*
 * tclMacOSXFCmd.c
 *
 *      This file implements the MacOSX specific portion of file manipulation 
 *      subcommands of the "file" command.
 *
 * Copyright (c) 2003 Tcl Core Team.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.3 2004/11/11 01:16:41 das Exp $
 */

#include "tclInt.h"

#ifdef HAVE_GETATTRLIST
#include <sys/attr.h>
#include <sys/paths.h>
#endif

/*
 * Constants for file attributes subcommand.
 * Need to be kept in sync with tclUnixFCmd.c !
 */

enum {
    UNIX_GROUP_ATTRIBUTE,
    UNIX_OWNER_ATTRIBUTE,
    UNIX_PERMISSIONS_ATTRIBUTE,
#ifdef HAVE_CHFLAGS
    UNIX_READONLY_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE,
    MACOSX_TYPE_ATTRIBUTE,
    MACOSX_HIDDEN_ATTRIBUTE,
    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
};

typedef u_int32_t OSType;

static int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, 
		OSType *osTypePtr);
static Tcl_Obj *Tcl_NewOSTypeStringObj(CONST OSType newOSType);

enum {
   kFinfoIsInvisible = 0x4000,
};

typedef struct fileinfobuf {
   u_int32_t info_length;
   union {
     struct {
       u_int32_t type;
       u_int32_t creator;
       u_int16_t fdFlags;
       u_int16_t location;
       u_int32_t padding[4];
     } finder;
     off_t rsrcForkSize;
   } data __attribute__ ((packed));
} fileinfobuf;

/*
 *----------------------------------------------------------------------
 *
 * TclMacOSXGetFileAttribute
 *
 *      Gets a MacOSX attribute of a file.  Which attribute is
 *      controlled by objIndex. The object will have ref count 0.
 *
 * Results:
 *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *        if there is no error.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

int
TclMacOSXGetFileAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;          /* The interp we are using for errors. */
    int objIndex;                /* The index of the attribute. */
    Tcl_Obj *fileName;           /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;   /* A pointer to return the object with. */
{
#ifdef HAVE_GETATTRLIST
    int result;
    Tcl_StatBuf statBuf;
    struct attrlist alist;
    fileinfobuf finfo;
    CONST char *native;
    
    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	Tcl_AppendResult(interp, "could not read \"", 
		Tcl_GetString(fileName), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) {

        /* Directories only support attribute "-hidden" */


        errno = EISDIR;
        Tcl_AppendResult(interp, "invalid attribute: ", 
                Tcl_PosixError(interp), (char *) NULL);
        return TCL_ERROR;
    }

    memset(&alist, 0, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    if(objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
        alist.fileattr = ATTR_FILE_RSRCLENGTH;
    } else {
        alist.commonattr = ATTR_CMN_FNDRINFO;    
    }
    native = Tcl_FSGetNativePath(fileName);
    result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);

    if (result != 0) {
        Tcl_AppendResult(interp, "could not read attributes of \"", 
                Tcl_GetString(fileName), "\": ",
                Tcl_PosixError(interp), (char *) NULL);
        return TCL_ERROR;
    }

    switch (objIndex) {
        case MACOSX_CREATOR_ATTRIBUTE:
            *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.creator);
            break;
        case MACOSX_TYPE_ATTRIBUTE:
            *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.type);
            break;
        case MACOSX_HIDDEN_ATTRIBUTE:
            *attributePtrPtr = Tcl_NewBooleanObj( (finfo.data.finder.fdFlags
                & kFinfoIsInvisible) != 0);
            break;
        case MACOSX_RSRCLENGTH_ATTRIBUTE:
            *attributePtrPtr = Tcl_NewWideIntObj(finfo.data.rsrcForkSize);
            break;
    }
    return TCL_OK;
#else
    Tcl_AppendResult(interp, "Mac OS X file attributes not supported",
		(char *) NULL);
    return TCL_ERROR;
#endif
}

/*
 *---------------------------------------------------------------------------
 *
 * TclMacOSXSetFileAttribute --
 *
 *      Sets a MacOSX attribute of a file.  Which attribute is
 *      controlled by objIndex.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      As above.
 *      
 *---------------------------------------------------------------------------
 */

int
TclMacOSXSetFileAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;              /* The interp for error reporting. */
    int objIndex;                    /* The index of the attribute. */
    Tcl_Obj *fileName;               /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;           /* New owner for file. */
{
#ifdef HAVE_GETATTRLIST
    int result;
    Tcl_StatBuf statBuf;
    struct attrlist alist;
    fileinfobuf finfo;
    CONST char *native;
    
    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	Tcl_AppendResult(interp, "could not read \"", 
		Tcl_GetString(fileName), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) {

        /* Directories only support attribute "-hidden" */


        errno = EISDIR;
        Tcl_AppendResult(interp, "invalid attribute: ", 
                Tcl_PosixError(interp), (char *) NULL);
        return TCL_ERROR;
    }

    memset(&alist, 0, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    if(objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
        alist.fileattr = ATTR_FILE_RSRCLENGTH;
    } else {
        alist.commonattr = ATTR_CMN_FNDRINFO;    
    }
    native = Tcl_FSGetNativePath(fileName);
    result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);

    if (result != 0) {
        Tcl_AppendResult(interp, "could not read attributes of \"", 
                Tcl_GetString(fileName), "\": ",
                Tcl_PosixError(interp), (char *) NULL);
        return TCL_ERROR;
    }

    if (objIndex != MACOSX_RSRCLENGTH_ATTRIBUTE) {
        switch (objIndex) {
            case MACOSX_CREATOR_ATTRIBUTE:
                if (Tcl_GetOSTypeFromObj(interp, attributePtr,
                        &finfo.data.finder.creator) != TCL_OK) {
                    return TCL_ERROR;
                }
                break;
            case MACOSX_TYPE_ATTRIBUTE:
                if (Tcl_GetOSTypeFromObj(interp, attributePtr,
                        &finfo.data.finder.type) != TCL_OK) {
                    return TCL_ERROR;
                }
                break;
            case MACOSX_HIDDEN_ATTRIBUTE:
                {
                    int hidden;

                    if (Tcl_GetBooleanFromObj(interp, attributePtr, &hidden)
                            != TCL_OK) {
                        return TCL_ERROR;
                    }
                    if (hidden) {
                        finfo.data.finder.fdFlags |= kFinfoIsInvisible;
                    } else {
                        finfo.data.finder.fdFlags &= ~kFinfoIsInvisible;
                    }
                }
                break;
        }


        result = setattrlist(native, &alist, &finfo.data, sizeof(finfo.data), 0);

    
        if (result != 0) {
            Tcl_AppendResult(interp, "could not set attributes of \"", 
                    Tcl_GetString(fileName), "\": ",
                    Tcl_PosixError(interp), (char *) NULL);
            return TCL_ERROR;
        }
    } else {
        off_t newRsrcForkSize;
        
        if (Tcl_GetWideIntFromObj(interp, attributePtr,
                &newRsrcForkSize) != TCL_OK) {
            return TCL_ERROR;
        }
        
        if(newRsrcForkSize != finfo.data.rsrcForkSize) {
            Tcl_DString ds;

            /*
             * Only setting rsrclength to 0 to strip
             * a file's resource fork is supported.
             */

            if(newRsrcForkSize != 0) {
                Tcl_AppendResult(interp,
                        "setting nonzero rsrclength not supported", 
                        (char *) NULL);
                return TCL_ERROR;
            }
            

            /* construct path to resource fork */


            Tcl_DStringInit(&ds);
            Tcl_DStringAppend(&ds, native, -1);
            Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1);

            result = truncate(Tcl_DStringValue(&ds), (off_t)0);

            Tcl_DStringFree(&ds);
    
            if (result != 0) {
                Tcl_AppendResult(interp, 
                        "could not truncate resource fork of \"",
                        Tcl_GetString(fileName), "\": ",
                        Tcl_PosixError(interp), (char *) NULL);
                return TCL_ERROR;
            }
        }
    }
    return TCL_OK;
#else
    Tcl_AppendResult(interp, "Mac OS X file attributes not supported",
		(char *) NULL);
    return TCL_ERROR;
#endif
}

/*
 *---------------------------------------------------------------------------
 *
 * TclMacOSXCopyFileAttributes --
 *
 *	Copy the MacOSX attributes and resource fork (if present) from one
 *	file to another.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	MacOSX attributes and resource fork are updated in the new file
 *	to reflect the old file.
 *
 *---------------------------------------------------------------------------
 */

int
TclMacOSXCopyFileAttributes(src, dst, statBufPtr) 
    CONST char *src;		/* Path name of source file (native). */
    CONST char *dst;		/* Path name of target file (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for source file */
{
#ifdef HAVE_GETATTRLIST
    struct attrlist alist;
    fileinfobuf finfo;
    
    memset(&alist, 0, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    alist.commonattr = ATTR_CMN_FNDRINFO;    

    if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) {
        return TCL_ERROR;
    }

    if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) {
        return TCL_ERROR;
    }

    if (!S_ISDIR(statBufPtr->st_mode)) {

        /* only copy non-empty resource fork */


        alist.commonattr = 0;    
        alist.fileattr = ATTR_FILE_RSRCLENGTH;
        
	if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) {
	    return TCL_ERROR;
	}
        
        if(finfo.data.rsrcForkSize > 0) {
	    int result;
            Tcl_DString ds_src, ds_dst;
                        

            /* construct paths to resource forks */


            Tcl_DStringInit(&ds_src);
            Tcl_DStringAppend(&ds_src, src, -1);
            Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1);
            Tcl_DStringInit(&ds_dst);
            Tcl_DStringAppend(&ds_dst, dst, -1);
            Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1);
 
            result = TclUnixCopyFile(Tcl_DStringValue(&ds_src),
                    Tcl_DStringValue(&ds_dst), statBufPtr, 1);

            Tcl_DStringFree(&ds_src);
            Tcl_DStringFree(&ds_dst);
    
	    if (result != 0) {
		return TCL_ERROR;
	    }
        }
    }
    return TCL_OK;
#else
    return TCL_ERROR;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetOSTypeFromObj --
 *
 *	Attempt to return an OSType from the Tcl object "objPtr".
 *
 * Results:
 *	Standard TCL result. If an error occurs during conversion,
 *	an error message is left in interp->objResult.
 *
 * Side effects:
 *	The string representation of objPtr will be updated if necessary.
 *
 *----------------------------------------------------------------------
 */

static int
Tcl_GetOSTypeFromObj(
    Tcl_Interp *interp,         /* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,            /* The object from which to get an OSType. */
    OSType *osTypePtr)          /* Place to store resulting OSType. */
{
    char *string;
    int length, result = TCL_OK;
    Tcl_DString ds;
    Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");

    string = Tcl_GetStringFromObj(objPtr, &length);
    Tcl_UtfToExternalDString(encoding, string, length, &ds);

    if (Tcl_DStringLength(&ds) > sizeof(OSType)) {
	Tcl_AppendResult(interp, 
		"expected Macintosh OS type but got \"",
		string, "\": ", (char *) NULL);
        result = TCL_ERROR;
    } else {
	memset(osTypePtr, 0, sizeof(OSType));
	memcpy(osTypePtr, Tcl_DStringValue(&ds),
	        (size_t) Tcl_DStringLength(&ds));
    }
    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return result;
}

/*



|
|



|
|

|










|
|



















|
|
|






|
|
|
|
|
|
|
|
|
|
|







|
|


|
|


|
|





|
|
|
|







|

|

|






>
|
>
>
|
|
|
|




|
|

|





|
|
|
|



|
|
|
|
|
|
|
|
|
|
|
|
|




|









|
|


|


|
|





|
|
|
|







|

|

|






>
|
>
>
|
|
|
|




|
|

|





|
|
|
|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
<
|
|
|
|
|
|
|
<
|
|
>
>
|
>
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
>
|
|
|
|
>
|
|
|
|
|
|
|
>
|
>
>
|
|
|

|

|
|
|
|
|
|
|
|
|
|




|
















|
|





|








|


|


|



|



>
|
>
>
|
|
|



|
|

|
|
>
|
>
>
|
|
|
|
|
|
|
|
|

|
|
|



|















|
|









|
|
|










|


|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

241
242
243

244
245
246
247
248
249
250

251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
/*
 * tclMacOSXFCmd.c
 *
 *	This file implements the MacOSX specific portion of file manipulation
 *	subcommands of the "file" command.
 *
 * Copyright (c) 2003 Tcl Core Team.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.3.2.1 2005/08/02 18:16:16 dgp Exp $
 */

#include "tclInt.h"

#ifdef HAVE_GETATTRLIST
#include <sys/attr.h>
#include <sys/paths.h>
#endif

/*
 * Constants for file attributes subcommand. Need to be kept in sync with
 * tclUnixFCmd.c !
 */

enum {
    UNIX_GROUP_ATTRIBUTE,
    UNIX_OWNER_ATTRIBUTE,
    UNIX_PERMISSIONS_ATTRIBUTE,
#ifdef HAVE_CHFLAGS
    UNIX_READONLY_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE,
    MACOSX_TYPE_ATTRIBUTE,
    MACOSX_HIDDEN_ATTRIBUTE,
    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
};

typedef u_int32_t OSType;

static int		Tcl_GetOSTypeFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, OSType *osTypePtr);
static Tcl_Obj *	Tcl_NewOSTypeStringObj(CONST OSType newOSType);

enum {
   kFinfoIsInvisible = 0x4000,
};

typedef struct fileinfobuf {
    u_int32_t info_length;
    union {
	struct {
	    u_int32_t type;
	    u_int32_t creator;
	    u_int16_t fdFlags;
	    u_int16_t location;
	    u_int32_t padding[4];
	} finder;
	off_t rsrcForkSize;
    } data __attribute__ ((packed));
} fileinfobuf;

/*
 *----------------------------------------------------------------------
 *
 * TclMacOSXGetFileAttribute
 *
 *	Gets a MacOSX attribute of a file. Which attribute is controlled by
 *	objIndex. The object will have ref count 0.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

int
TclMacOSXGetFileAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		 /* The interp we are using for errors. */
    int objIndex;		 /* The index of the attribute. */
    Tcl_Obj *fileName;		 /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	 /* A pointer to return the object with. */
{
#ifdef HAVE_GETATTRLIST
    int result;
    Tcl_StatBuf statBuf;
    struct attrlist alist;
    fileinfobuf finfo;
    CONST char *native;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	Tcl_AppendResult(interp, "could not read \"",
		Tcl_GetString(fileName), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) {
	/*
	 * Directories only support attribute "-hidden".
	 */

	errno = EISDIR;
	Tcl_AppendResult(interp, "invalid attribute: ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    memset(&alist, 0, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
	alist.fileattr = ATTR_FILE_RSRCLENGTH;
    } else {
	alist.commonattr = ATTR_CMN_FNDRINFO;
    }
    native = Tcl_FSGetNativePath(fileName);
    result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);

    if (result != 0) {
	Tcl_AppendResult(interp, "could not read attributes of \"",
		Tcl_GetString(fileName), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    switch (objIndex) {
    case MACOSX_CREATOR_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.creator);
	break;
    case MACOSX_TYPE_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.type);
	break;
    case MACOSX_HIDDEN_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewBooleanObj(
		(finfo.data.finder.fdFlags & kFinfoIsInvisible) != 0);
	break;
    case MACOSX_RSRCLENGTH_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewWideIntObj(finfo.data.rsrcForkSize);
	break;
    }
    return TCL_OK;
#else
    Tcl_AppendResult(interp, "Mac OS X file attributes not supported",
	    (char *) NULL);
    return TCL_ERROR;
#endif
}

/*
 *---------------------------------------------------------------------------
 *
 * TclMacOSXSetFileAttribute --
 *
 *	Sets a MacOSX attribute of a file. Which attribute is controlled by
 *	objIndex.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	As above.
 *
 *---------------------------------------------------------------------------
 */

int
TclMacOSXSetFileAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		/* The interp for error reporting. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	/* New owner for file. */
{
#ifdef HAVE_GETATTRLIST
    int result;
    Tcl_StatBuf statBuf;
    struct attrlist alist;
    fileinfobuf finfo;
    CONST char *native;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	Tcl_AppendResult(interp, "could not read \"",
		Tcl_GetString(fileName), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) {
	/*
	 * Directories only support attribute "-hidden".
	 */

	errno = EISDIR;
	Tcl_AppendResult(interp, "invalid attribute: ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    memset(&alist, 0, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
	alist.fileattr = ATTR_FILE_RSRCLENGTH;
    } else {
	alist.commonattr = ATTR_CMN_FNDRINFO;
    }
    native = Tcl_FSGetNativePath(fileName);
    result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);

    if (result != 0) {
	Tcl_AppendResult(interp, "could not read attributes of \"",
		Tcl_GetString(fileName), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    if (objIndex != MACOSX_RSRCLENGTH_ATTRIBUTE) {
	switch (objIndex) {
	case MACOSX_CREATOR_ATTRIBUTE:
	    if (Tcl_GetOSTypeFromObj(interp, attributePtr,
		    &finfo.data.finder.creator) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case MACOSX_TYPE_ATTRIBUTE:
	    if (Tcl_GetOSTypeFromObj(interp, attributePtr,
		    &finfo.data.finder.type) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case MACOSX_HIDDEN_ATTRIBUTE: {

	    int hidden;

	    if (Tcl_GetBooleanFromObj(interp,attributePtr,&hidden) != TCL_OK) {

		return TCL_ERROR;
	    }
	    if (hidden) {
		finfo.data.finder.fdFlags |= kFinfoIsInvisible;
	    } else {
		finfo.data.finder.fdFlags &= ~kFinfoIsInvisible;
	    }

	    break;
	}
	}

	result = setattrlist(native, &alist,
		&finfo.data, sizeof(finfo.data), 0);

	if (result != 0) {
	    Tcl_AppendResult(interp, "could not set attributes of \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
    } else {
	off_t newRsrcForkSize;

	if (Tcl_GetWideIntFromObj(interp, attributePtr,
		&newRsrcForkSize) != TCL_OK) {
	    return TCL_ERROR;
	}

	if (newRsrcForkSize != finfo.data.rsrcForkSize) {
	    Tcl_DString ds;

	    /*
	     * Only setting rsrclength to 0 to strip a file's resource fork is
	     * supported.
	     */

	    if(newRsrcForkSize != 0) {
		Tcl_AppendResult(interp,
			"setting nonzero rsrclength not supported",
			(char *) NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Construct path to resource fork.
	     */

	    Tcl_DStringInit(&ds);
	    Tcl_DStringAppend(&ds, native, -1);
	    Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1);

	    result = truncate(Tcl_DStringValue(&ds), (off_t)0);

	    Tcl_DStringFree(&ds);

	    if (result != 0) {
		Tcl_AppendResult(interp,
			"could not truncate resource fork of \"",
			Tcl_GetString(fileName), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
		return TCL_ERROR;
	    }
	}
    }
    return TCL_OK;
#else
    Tcl_AppendResult(interp, "Mac OS X file attributes not supported",
	    (char *) NULL);
    return TCL_ERROR;
#endif
}

/*
 *---------------------------------------------------------------------------
 *
 * TclMacOSXCopyFileAttributes --
 *
 *	Copy the MacOSX attributes and resource fork (if present) from one
 *	file to another.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	MacOSX attributes and resource fork are updated in the new file to
 *	reflect the old file.
 *
 *---------------------------------------------------------------------------
 */

int
TclMacOSXCopyFileAttributes(src, dst, statBufPtr)
    CONST char *src;		/* Path name of source file (native). */
    CONST char *dst;		/* Path name of target file (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for source file */
{
#ifdef HAVE_GETATTRLIST
    struct attrlist alist;
    fileinfobuf finfo;

    memset(&alist, 0, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    alist.commonattr = ATTR_CMN_FNDRINFO;

    if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) {
	return TCL_ERROR;
    }

    if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) {
	return TCL_ERROR;
    }

    if (!S_ISDIR(statBufPtr->st_mode)) {
	/*
	 * Only copy non-empty resource fork.
	 */

	alist.commonattr = 0;
	alist.fileattr = ATTR_FILE_RSRCLENGTH;

	if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) {
	    return TCL_ERROR;
	}

	if(finfo.data.rsrcForkSize > 0) {
	    int result;
	    Tcl_DString ds_src, ds_dst;

	    /*
	     * Construct paths to resource forks.
	     */

	    Tcl_DStringInit(&ds_src);
	    Tcl_DStringAppend(&ds_src, src, -1);
	    Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1);
	    Tcl_DStringInit(&ds_dst);
	    Tcl_DStringAppend(&ds_dst, dst, -1);
	    Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1);

	    result = TclUnixCopyFile(Tcl_DStringValue(&ds_src),
		    Tcl_DStringValue(&ds_dst), statBufPtr, 1);

	    Tcl_DStringFree(&ds_src);
	    Tcl_DStringFree(&ds_dst);

	    if (result != 0) {
		return TCL_ERROR;
	    }
	}
    }
    return TCL_OK;
#else
    return TCL_ERROR;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetOSTypeFromObj --
 *
 *	Attempt to return an OSType from the Tcl object "objPtr".
 *
 * Results:
 *	Standard TCL result. If an error occurs during conversion, an error
 *	message is left in interp->objResult.
 *
 * Side effects:
 *	The string representation of objPtr will be updated if necessary.
 *
 *----------------------------------------------------------------------
 */

static int
Tcl_GetOSTypeFromObj(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* The object from which to get an OSType. */
    OSType *osTypePtr)		/* Place to store resulting OSType. */
{
    char *string;
    int length, result = TCL_OK;
    Tcl_DString ds;
    Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");

    string = Tcl_GetStringFromObj(objPtr, &length);
    Tcl_UtfToExternalDString(encoding, string, length, &ds);

    if (Tcl_DStringLength(&ds) > sizeof(OSType)) {
	Tcl_AppendResult(interp,
		"expected Macintosh OS type but got \"",
		string, "\": ", (char *) NULL);
	result = TCL_ERROR;
    } else {
	memset(osTypePtr, 0, sizeof(OSType));
	memcpy(osTypePtr, Tcl_DStringValue(&ds),
		(size_t) Tcl_DStringLength(&ds));
    }
    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return result;
}

/*
450
451
452
453
454
455
456
457

458
459
460
461








    Tcl_Obj *resultPtr;
    Tcl_DString ds;
    Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");

    memcpy(string, &newOSType, sizeof(OSType));
    string[sizeof(OSType)] = '\0';
    Tcl_ExternalToUtfDString(encoding, string, -1, &ds);
    resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));

    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return resultPtr;
}















|
>




>
>
>
>
>
>
>
>
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
    Tcl_Obj *resultPtr;
    Tcl_DString ds;
    Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");

    memcpy(string, &newOSType, sizeof(OSType));
    string[sizeof(OSType)] = '\0';
    Tcl_ExternalToUtfDString(encoding, string, -1, &ds);
    resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
	    Tcl_DStringLength(&ds));
    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return resultPtr;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Added macosx/tclMacOSXNotify.c.

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
/*
 * tclMacOSXNotify.c --
 *
 *	This file contains the implementation of a merged CFRunLoop/select()
 *	based notifier, which is the lowest-level part of the Tcl event loop.
 *	This file works together with generic/tclNotify.c.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright 2001, Apple Computer, Inc.
 * Copyright 2005, Tcl Core Team.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.3.2.3 2005/08/02 18:16:16 dgp Exp $
 */

#ifdef HAVE_COREFOUNDATION	/* Traditional unix select-based notifier is
				 * in tclUnixNotfy.c */
#include "tclInt.h"
#include <CoreFoundation/CoreFoundation.h>
#include <pthread.h>

extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;

/*
 * This structure is used to keep track of the notifier info for a registered
 * file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE,
				 * etc. */
    int readyMask;		/* Mask of events that have been seen since
				 * the last time file handlers were invoked
				 * for this file. */
    Tcl_FileProc *proc;		/* Function to call, in the style of
				 * Tcl_CreateFileHandler. */
    ClientData clientData;	/* Argument to pass to proc. */
    struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;

/*
 * The following structure is what is added to the Tcl event queue when file
 * handlers are ready to fire.
 */

typedef struct FileHandlerEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    int fd;			/* File descriptor that is ready. Used to find
				 * the FileHandler structure for the file
				 * (can't point directly to the FileHandler
				 * structure because it could go away while
				 * the event is queued). */
} FileHandlerEvent;

/*
 * The following structure contains a set of select() masks to track readable,
 * writable, and exceptional conditions.
 */

typedef struct SelectMasks {
    fd_set readable;
    fd_set writable;
    fd_set exceptional;
} SelectMasks;

/*
 * The following static structure contains the state information for the
 * select based implementation of the Tcl notifier. One of these structures is
 * created for each thread that is using the notifier.
 */

typedef struct ThreadSpecificData {
    FileHandler *firstFileHandlerPtr;
				/* Pointer to head of file handler list. */
    SelectMasks checkMasks;	/* This structure is used to build up the
				 * masks to be used in the next call to
				 * select. Bits are set in response to calls
				 * to Tcl_CreateFileHandler. */
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks (one
				 * more than highest fd for which
				 * Tcl_WatchFile has been called). */
    int onList;			/* True if it is in this list */
    unsigned int pollState;	/* pollState is used to implement a polling
				 * handshake between each thread and the
				 * notifier thread. Bits defined below. */
    struct ThreadSpecificData *nextPtr, *prevPtr;
				/* All threads that are currently waiting on
				 * an event have their ThreadSpecificData
				 * structure on a doubly-linked listed formed
				 * from these pointers. You must hold the
				 * notifierLock before accessing these
				 * fields. */
    CFRunLoopSourceRef runLoopSource;
				/* Any other thread alerts a notifier that an
				 * event is ready to be processed by signaling
				 * this CFRunLoopSource. */
    CFRunLoopRef runLoop;	/* This thread's CFRunLoop, needs to be woken
				 * up whenever the runLoopSource is
				 * signaled. */
    int eventReady;		/* True if an event is ready to be
				 * processed. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following static indicates the number of threads that have initialized
 * notifiers.
 *
 * You must hold the notifierInitLock before accessing this variable.
 */

static int notifierCount = 0;

/*
 * The following variable points to the head of a doubly-linked list of
 * ThreadSpecificData structures for all threads that are currently waiting on
 * an event.
 *
 * You must hold the notifierLock before accessing this list.
 */

static ThreadSpecificData *waitingListPtr = NULL;

/*
 * The notifier thread spends all its time in select() waiting for a file
 * descriptor associated with one of the threads on the waitingListPtr list to
 * do something interesting. But if the contents of the waitingListPtr list
 * ever changes, we need to wake up and restart the select() system call. You
 * can wake up the notifier thread by writing a single byte to the file
 * descriptor defined below. This file descriptor is the input-end of a pipe
 * and the notifier thread is listening for data on the output-end of the same
 * pipe. Hence writing to this file descriptor will cause the select() system
 * call to return and wake up the notifier thread.
 *
 * You must hold the notifierLock lock before writing to the pipe.
 */

static int triggerPipe = -1;
static int receivePipe = -1; /* Output end of triggerPipe */

/*
 * We use Darwin-native spinlocks instead of pthread mutexes for notifier
 * locking: this radically simplifies the implementation and lowers overhead.
 * Note that these are not pure spinlocks, they employ various strategies to
 * back off, making them immune to most priority-inversion livelocks (c.f. man
 * 3 OSSpinLockLock).
 */

#if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK)
/*
 * Use OSSpinLock API where available (Tiger or later).
 */

#include <libkern/OSAtomic.h>

#else
/*
 * Otherwise, use commpage spinlock SPI directly.
 */

typedef uint32_t OSSpinLock;
extern void	_spin_lock(OSSpinLock *lock);
extern void	_spin_unlock(OSSpinLock *lock);
#define OSSpinLockLock(p)	_spin_lock(p)
#define OSSpinLockUnlock(p)	_spin_unlock(p)

#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */

/*
 * These spinlocks lock access to the global notifier state.
 */

static OSSpinLock notifierInitLock = 0;
static OSSpinLock notifierLock = 0;

/*
 * Macros abstracting notifier locking/unlocking
 */

#define LOCK_NOTIFIER_INIT	OSSpinLockLock(&notifierInitLock)
#define UNLOCK_NOTIFIER_INIT	OSSpinLockUnlock(&notifierInitLock)
#define LOCK_NOTIFIER		OSSpinLockLock(&notifierLock)
#define UNLOCK_NOTIFIER		OSSpinLockUnlock(&notifierLock)

/*
 * The pollState bits
 *	POLL_WANT is set by each thread before it waits on its condition
 *		variable. It is checked by the notifier before it does select.
 *	POLL_DONE is set by the notifier if it goes into select after seeing
 *		POLL_WANT. The idea is to ensure it tries a select with the
 *		same bits the initial thread had set.
 */

#define POLL_WANT	0x1
#define POLL_DONE	0x2

/*
 * This is the thread ID of the notifier thread that does select.
 */

static pthread_t notifierThread;

/*
 * Static routines defined in this file.
 */

static void	NotifierThreadProc(ClientData clientData);
static int	FileHandlerEventProc(Tcl_Event *evPtr, int flags);

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitNotifier --
 *
 *	Initializes the platform specific notifier state.
 *
 * Results:
 *	Returns a handle to the notifier state for this thread..
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_InitNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    tsdPtr->eventReady = 0;

    /*
     * Initialize CFRunLoopSource and add it to CFRunLoop of this thread
     */

    if (!tsdPtr->runLoop) {
	CFRunLoopRef runLoop = CFRunLoopGetCurrent();
	CFRunLoopSourceRef runLoopSource;
	CFRunLoopSourceContext runLoopSourceContext;

	bzero(&runLoopSourceContext, sizeof(CFRunLoopSourceContext));
	runLoopSourceContext.info = tsdPtr;
	runLoopSource = CFRunLoopSourceCreate(NULL, 0, &runLoopSourceContext);
	if (!runLoopSource) {
	    Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource.");
	}
	CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes);
	tsdPtr->runLoopSource = runLoopSource;
	tsdPtr->runLoop = runLoop;
    }

    /*
     * Initialize trigger pipe and start the Notifier thread if necessary.
     */

    LOCK_NOTIFIER_INIT;
    if (notifierCount == 0) {
	int fds[2], status, result;
	pthread_attr_t attr;

	if (pipe(fds) != 0) {
	    Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe.");
	}

	status = fcntl(fds[0], F_GETFL);
	status |= O_NONBLOCK;
	if (fcntl(fds[0], F_SETFL, status) < 0) {
	    Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non blocking.");
	}
	status = fcntl(fds[1], F_GETFL);
	status |= O_NONBLOCK;
	if (fcntl(fds[1], F_SETFL, status) < 0) {
	    Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non blocking.");
	}

	receivePipe = fds[0];
	triggerPipe = fds[1];

	pthread_attr_init(&attr);
	pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
	pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
	pthread_attr_setstacksize(&attr, 60 * 1024);
	result = pthread_create(&notifierThread, &attr,
		(void * (*)(void *))NotifierThreadProc, NULL);
	pthread_attr_destroy(&attr);
	if (result) {
	    Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread.");
	}
    }
    notifierCount++;
    UNLOCK_NOTIFIER_INIT;

    return (ClientData) tsdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeNotifier --
 *
 *	This function is called to cleanup the notifier state before a thread
 *	is terminated.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May terminate the background notifier thread if this is the last
 *	notifier instance.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeNotifier(clientData)
    ClientData clientData;		/* Not used. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    LOCK_NOTIFIER_INIT;
    notifierCount--;

    /*
     * If this is the last thread to use the notifier, close the notifier pipe
     * and wait for the background thread to terminate.
     */

    if (notifierCount == 0) {
	int result;

	if (triggerPipe < 0) {
	    Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized.");
	}

	/*
	 * Send "q" message to the notifier thread so that it will terminate.
	 * The notifier will return from its call to select() and notice that
	 * a "q" message has arrived, it will then close its side of the pipe
	 * and terminate its thread. Note the we can not just close the pipe
	 * and check for EOF in the notifier thread because if a background
	 * child process was created with exec, select() would not register
	 * the EOF on the pipe until the child processes had terminated. [Bug:
	 * 4139]
	 */

	write(triggerPipe, "q", 1);
	close(triggerPipe);

	result = pthread_join(notifierThread, NULL);
	if (result) {
	    Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread.");
	}

	close(receivePipe);
	triggerPipe = -1;
    }
    UNLOCK_NOTIFIER_INIT;

    LOCK_NOTIFIER;		/* for concurrency with Tcl_AlertNotifier */
    if (tsdPtr->runLoop) {
	tsdPtr->runLoop = NULL;

	/*
	 * Remove runLoopSource from all CFRunLoops and release it.
	 */

	CFRunLoopSourceInvalidate(tsdPtr->runLoopSource);
	CFRelease(tsdPtr->runLoopSource);
	tsdPtr->runLoopSource = NULL;
    }
    UNLOCK_NOTIFIER;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AlertNotifier --
 *
 *	Wake up the specified notifier from any thread. This routine is called
 *	by the platform independent notifier code whenever the Tcl_ThreadAlert
 *	routine is called. This routine is guaranteed not to be called on a
 *	given notifier after Tcl_FinalizeNotifier is called for that notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the notifier condition variable for the specified notifier.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AlertNotifier(clientData)
    ClientData clientData;
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

    LOCK_NOTIFIER;
    if (tsdPtr->runLoop) {
	tsdPtr->eventReady = 1;
	CFRunLoopSourceSignal(tsdPtr->runLoopSource);
	CFRunLoopWakeUp(tsdPtr->runLoop);
    }
    UNLOCK_NOTIFIER;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimer --
 *
 *	This function sets the current notifier timer value. This interface is
 *	not implemented in this notifier because we are always running inside
 *	of Tcl_DoOneEvent.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimer(timePtr)
    Tcl_Time *timePtr;		/* Timeout value, may be NULL. */
{
    /*
     * The interval timer doesn't do anything in this implementation, because
     * the only event loop is via Tcl_DoOneEvent, which passes timeout values
     * to Tcl_WaitForEvent.
     */

    if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
	tclStubs.tcl_SetTimer(timePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceModeHook --
 *
 *	This function is invoked whenever the service mode changes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ServiceModeHook(mode)
    int mode;			/* Either TCL_SERVICE_ALL, or
				 * TCL_SERVICE_NONE. */
{
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateFileHandler --
 *
 *	This function registers a file handler with the select notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new file handler structure.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateFileHandler(fd, mask, proc, clientData)
    int fd;			/* Handle of stream to watch. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION: indicates
				 * conditions under which proc should be
				 * called. */
    Tcl_FileProc *proc;		/* Function to call for each
				 * selected event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    FileHandler *filePtr;

    if (tclStubs.tcl_CreateFileHandler !=
	    tclOriginalNotifier.createFileHandlerProc) {
	tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData);
	return;
    }

    for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
	    filePtr = filePtr->nextPtr) {
	if (filePtr->fd == fd) {
	    break;
	}
    }
    if (filePtr == NULL) {
	filePtr = (FileHandler*) ckalloc(sizeof(FileHandler));
	filePtr->fd = fd;
	filePtr->readyMask = 0;
	filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
	tsdPtr->firstFileHandlerPtr = filePtr;
    }
    filePtr->proc = proc;
    filePtr->clientData = clientData;
    filePtr->mask = mask;

    /*
     * Update the check masks for this file.
     */

    if (mask & TCL_READABLE) {
	FD_SET(fd, &(tsdPtr->checkMasks.readable));
    } else {
	FD_CLR(fd, &(tsdPtr->checkMasks.readable));
    }
    if (mask & TCL_WRITABLE) {
	FD_SET(fd, &(tsdPtr->checkMasks.writable));
    } else {
	FD_CLR(fd, &(tsdPtr->checkMasks.writable));
    }
    if (mask & TCL_EXCEPTION) {
	FD_SET(fd, &(tsdPtr->checkMasks.exceptional));
    } else {
	FD_CLR(fd, &(tsdPtr->checkMasks.exceptional));
    }
    if (tsdPtr->numFdBits <= fd) {
	tsdPtr->numFdBits = fd+1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteFileHandler --
 *
 *	Cancel a previously-arranged callback arrangement for a file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered on file, remove it.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteFileHandler(fd)
    int fd;			/* Stream id for which to remove callback
				 * function. */
{
    FileHandler *filePtr, *prevPtr;
    int i;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tclStubs.tcl_DeleteFileHandler !=
	    tclOriginalNotifier.deleteFileHandlerProc) {
	tclStubs.tcl_DeleteFileHandler(fd);
	return;
    }

    /*
     * Find the entry for the given file (and return if there isn't one).
     */

    for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
	 prevPtr = filePtr, filePtr = filePtr->nextPtr) {
	if (filePtr == NULL) {
	    return;
	}
	if (filePtr->fd == fd) {
	    break;
	}
    }

    /*
     * Update the check masks for this file.
     */

    if (filePtr->mask & TCL_READABLE) {
	FD_CLR(fd, &(tsdPtr->checkMasks.readable));
    }
    if (filePtr->mask & TCL_WRITABLE) {
	FD_CLR(fd, &(tsdPtr->checkMasks.writable));
    }
    if (filePtr->mask & TCL_EXCEPTION) {
	FD_CLR(fd, &(tsdPtr->checkMasks.exceptional));
    }

    /*
     * Find current max fd.
     */

    if (fd+1 == tsdPtr->numFdBits) {
	tsdPtr->numFdBits = 0;
	for (i = fd-1; i >= 0; i--) {
	    if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))
		    || FD_ISSET(i, &(tsdPtr->checkMasks.writable))
		    || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) {
		tsdPtr->numFdBits = i+1;
		break;
	    }
	}
    }

    /*
     * Clean up information in the callback record.
     */

    if (prevPtr == NULL) {
	tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
    } else {
	prevPtr->nextPtr = filePtr->nextPtr;
    }
    ckfree((char *) filePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * FileHandlerEventProc --
 *
 *	This function is called by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This function is responsible for
 *	actually handling the event by invoking the callback for the file
 *	handler.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the file handler's callback function does.
 *
 *----------------------------------------------------------------------
 */

static int
FileHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.
     */

    tsdPtr = TCL_TSD_INIT(&dataKey);
    for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
	    filePtr = filePtr->nextPtr) {
	if (filePtr->fd != fileEvPtr->fd) {
	    continue;
	}

	/*
	 * The code is tricky for two reasons:
	 * 1. The file handler's desired events could have changed since the
	 *    time when the event was queued, so AND the ready mask with the
	 *    desired mask.
	 * 2. The file could have been closed and re-opened since the time
	 *    when the event was queued. This is why the ready mask is stored
	 *    in the file handler rather than the queued event: it will be
	 *    zeroed when a new file handler is created for the newly opened
	 *    file.
	 */

	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    (*filePtr->proc)(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just
 *	polls without blocking.
 *
 * Results:
 *	Returns -1 if the select would block forever, otherwise returns 0.
 *
 * Side effects:
 *	Queues file events that are detected by the select.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WaitForEvent(timePtr)
    Tcl_Time *timePtr;		/* Maximum block time, or NULL. */
{
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr;
    int mask;
    Tcl_Time myTime;
    int waitForFiles;
    Tcl_Time *myTimePtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
	return tclStubs.tcl_WaitForEvent(timePtr);
    }

    if (timePtr != NULL) {
	/*
	 * TIP #233 (Virtualized Time). Is virtual time in effect? And do we
	 * actually have something to scale? If yes to both then we call the
	 * handler to do this scaling.
	 */

	myTime.sec  = timePtr->sec;
	myTime.usec = timePtr->usec;

	if (myTime.sec != 0 || myTime.usec != 0) {
	    (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData);
	}

	myTimePtr = &myTime;
    } else {
	myTimePtr = NULL;
    }

    /*
     * Place this thread on the list of interested threads, signal the
     * notifier thread, and wait for a response or a timeout.
     */

    LOCK_NOTIFIER;

    waitForFiles = (tsdPtr->numFdBits > 0);
    if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) {
	/*
	 * Cannot emulate a polling select with a polling condition variable.
	 * Instead, pretend to wait for files and tell the notifier thread
	 * what we are doing. The notifier thread makes sure it goes through
	 * select with its select mask in the same state as ours currently is.
	 * We block until that happens.
	 */

	waitForFiles = 1;
	tsdPtr->pollState = POLL_WANT;
	myTimePtr = NULL;
    } else {
	tsdPtr->pollState = 0;
    }

    if (waitForFiles) {
	/*
	 * Add the ThreadSpecificData structure of this thread to the list of
	 * ThreadSpecificData structures of all threads that are waiting on
	 * file events.
	 */

	tsdPtr->nextPtr = waitingListPtr;
	if (waitingListPtr) {
	    waitingListPtr->prevPtr = tsdPtr;
	}
	tsdPtr->prevPtr = 0;
	waitingListPtr = tsdPtr;
	tsdPtr->onList = 1;

	write(triggerPipe, "", 1);
    }

    FD_ZERO(&(tsdPtr->readyMasks.readable));
    FD_ZERO(&(tsdPtr->readyMasks.writable));
    FD_ZERO(&(tsdPtr->readyMasks.exceptional));

    if (!tsdPtr->eventReady) {
	CFTimeInterval waitTime;

	if (myTimePtr == NULL) {
	    waitTime = 1.0e10; /* Wait forever, as per CFRunLoop.c */
	} else {
	    waitTime = myTimePtr->sec + 1.0e-6 * myTimePtr->usec;
	}
	UNLOCK_NOTIFIER;
	CFRunLoopRunInMode(kCFRunLoopDefaultMode, waitTime, TRUE);
	LOCK_NOTIFIER;
    }
    tsdPtr->eventReady = 0;

    if (waitForFiles && tsdPtr->onList) {
	/*
	 * Remove the ThreadSpecificData structure of this thread from the
	 * waiting list. Alert the notifier thread to recompute its select
	 * masks - skipping this caused a hang when trying to close a pipe
	 * which the notifier thread was still doing a select on.
	 */

	if (tsdPtr->prevPtr) {
	    tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	write(triggerPipe, "", 1);
    }

    /*
     * Queue all detected file events before returning.
     */

    for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
	    filePtr = filePtr->nextPtr) {

	mask = 0;
	if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) {
	    mask |= TCL_READABLE;
	}
	if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) {
	    mask |= TCL_WRITABLE;
	}
	if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) {
	    mask |= TCL_EXCEPTION;
	}

	if (!mask) {
	    continue;
	}

	/*
	 * Don't bother to queue an event if the mask was previously non-zero
	 * since an event must still be on the queue.
	 */

	if (filePtr->readyMask == 0) {
	    fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
	    fileEvPtr->header.proc = FileHandlerEventProc;
	    fileEvPtr->fd = filePtr->fd;
	    Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
	}
	filePtr->readyMask = mask;
    }
    UNLOCK_NOTIFIER;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *
 *	This routine is the initial (and only) function executed by the
 *	special notifier thread. Its job is to wait for file descriptors to
 *	become readable or writable or to have an exception condition and then
 *	to notify other threads who are interested in this information by
 *	signalling a condition variable. Other threads can signal this
 *	notifier thread of a change in their interests by writing a single
 *	byte to a special pipe that the notifier thread is monitoring.
 *
 * Result:
 *	None. Once started, this routine never exits. It dies with the overall
 *	process.
 *
 * Side effects:
 *	The trigger pipe used to signal the notifier thread is created when
 *	the notifier thread first starts.
 *
 *----------------------------------------------------------------------
 */

static void
NotifierThreadProc(clientData)
    ClientData clientData;	/* Not used. */
{
    ThreadSpecificData *tsdPtr;
    fd_set readableMask;
    fd_set writableMask;
    fd_set exceptionalMask;
    int i, numFdBits = 0;
    long found;
    struct timeval poll = {0., 0.}, *timePtr;
    char buf[2];

    /*
     * Look for file events and report them to interested threads.
     */

    while (1) {
	FD_ZERO(&readableMask);
	FD_ZERO(&writableMask);
	FD_ZERO(&exceptionalMask);

	/*
	 * Compute the logical OR of the select masks from all the waiting
	 * notifiers.
	 */

	LOCK_NOTIFIER;
	timePtr = NULL;
	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
		if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) {
		    FD_SET(i, &readableMask);
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) {
		    FD_SET(i, &writableMask);
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) {
		    FD_SET(i, &exceptionalMask);
		}
	    }
	    if (tsdPtr->numFdBits > numFdBits) {
		numFdBits = tsdPtr->numFdBits;
	    }
	    if (tsdPtr->pollState & POLL_WANT) {
		/*
		 * Here we make sure we go through select() with the same mask
		 * bits that were present when the thread tried to poll.
		 */

		tsdPtr->pollState |= POLL_DONE;
		timePtr = &poll;
	    }
	}
	UNLOCK_NOTIFIER;

	/*
	 * Set up the select mask to include the receive pipe.
	 */

	if (receivePipe >= numFdBits) {
	    numFdBits = receivePipe + 1;
	}
	FD_SET(receivePipe, &readableMask);

	if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask,
		timePtr) == -1) {
	    /*
	     * Try again immediately on an error.
	     */

	    continue;
	}

	/*
	 * Alert any threads that are waiting on a ready file descriptor.
	 */

	LOCK_NOTIFIER;
	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    found = 0;

	    for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
		if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))
			&& FD_ISSET(i, &readableMask)) {
		    FD_SET(i, &(tsdPtr->readyMasks.readable));
		    found = 1;
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))
			&& FD_ISSET(i, &writableMask)) {
		    FD_SET(i, &(tsdPtr->readyMasks.writable));
		    found = 1;
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))
			&& FD_ISSET(i, &exceptionalMask)) {
		    FD_SET(i, &(tsdPtr->readyMasks.exceptional));
		    found = 1;
		}
	    }

	    if (found || (tsdPtr->pollState & POLL_DONE)) {
		tsdPtr->eventReady = 1;
		if (tsdPtr->onList) {
		    /*
		     * Remove the ThreadSpecificData structure of this thread
		     * from the waiting list. This prevents us from
		     * continuously spining on select until the other threads
		     * runs and services the file event.
		     */

		    if (tsdPtr->prevPtr) {
			tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
		    } else {
			waitingListPtr = tsdPtr->nextPtr;
		    }
		    if (tsdPtr->nextPtr) {
			tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
		    }
		    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
		    tsdPtr->onList = 0;
		    tsdPtr->pollState = 0;
		}
		if (tsdPtr->runLoop) {
		    CFRunLoopSourceSignal(tsdPtr->runLoopSource);
		    CFRunLoopWakeUp(tsdPtr->runLoop);
		}
	    }
	}
	UNLOCK_NOTIFIER;

	/*
	 * Consume the next byte from the notifier pipe if the pipe was
	 * readable. Note that there may be multiple bytes pending, but to
	 * avoid a race condition we only read one at a time.
	 */

	if (FD_ISSET(receivePipe, &readableMask)) {
	    i = read(receivePipe, buf, 1);

	    if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
		/*
		 * Someone closed the write end of the pipe or sent us a Quit
		 * message [Bug: 4139] and then closed the write end of the
		 * pipe so we need to shut down the notifier thread.
		 */

		break;
	    }
	}
    }
    pthread_exit (0);
}
#endif /* HAVE_COREFOUNDATION */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to tests/appendComp.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: appendComp.test,v 1.7 2004/09/22 03:19:52 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}
catch {unset x}














|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: appendComp.test,v 1.7.2.1 2005/05/05 17:56:14 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}
catch {unset x}

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
	proc foo {args} {append ::result $args}
	append myvar a
	info exists ::result
    }
    bar
} {0}

test appendComp-8.1 {TCL_OUT_LINE_COMPILE, not TCL_ERROR} -setup {
    interp create slave
} -body {
    slave eval {
	proc foo {} {
	    proc append args {}
	    append
	}







|







347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
	proc foo {args} {append ::result $args}
	append myvar a
	info exists ::result
    }
    bar
} {0}

test appendComp-8.1 {defer error to runtime} -setup {
    interp create slave
} -body {
    slave eval {
	proc foo {} {
	    proc append args {}
	    append
	}

Changes to tests/basic.test.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.36 2004/11/18 19:22:12 dgp Exp $
#

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.36.2.2 2005/04/10 23:14:58 kennykb Exp $
#

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
433
434
435
436
437
438
439





































440
441
442
443
444
445
446
    close $f
    set x
} -cleanup {
    removeFile test1
    interp bgerror {} $handler
    rename myHandler {}
} -result "foo\n    while executing\n\"error foo\""






































test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}

test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
    close $f
    set x
} -cleanup {
    removeFile test1
    interp bgerror {} $handler
    rename myHandler {}
} -result "foo\n    while executing\n\"error foo\""

test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} {
    #
    # Follow the pure-list branch in a manner that
    #   a - the pure-list internal rep is destroyed by shimmering
    #   b - the command returns an error
    # As the error code in Tcl_EvalObjv accesses the list elements, this will
    # cause a segfault if [Bug 1119369] has not been fixed. 
    # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
    #

    set SRC [list foo 1] ;# pure-list command 
    proc foo str {
	# Shimmer pure-list to cmdName, cleanup and error
	proc $::SRC {} {}; $::SRC
	error "BAD CALL"
    }
    catch {eval $SRC}
} 1

test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} {
    #
    # Follow the pure-list branch in a manner that
    #   a - the pure-list internal rep is destroyed by shimmering
    #   b - the command accesses its command line
    # This will cause a segfault if [Bug 1119369] has not been fixed. 
    # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
    #

    set SRC [list foo 1] ;# pure-list command 
    proc foo str {
	# Shimmer pure-list to cmdName, cleanup and error
	proc $::SRC {} {}; $::SRC
	info level 0
    }
    catch {eval $SRC}
} 0

test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}

test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}

563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
} -constraints {
    exec
} -body {
    exec [interpreter] $fName
} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
    while executing
"break"
    invoked from within
"foo \[set a 1] \[break]"
    (file "*BREAKtest" line 2)}

test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
    set fName [makeFile {
	return -code return
    } BREAKtest]







|
<
<







600
601
602
603
604
605
606
607


608
609
610
611
612
613
614
} -constraints {
    exec
} -body {
    exec [interpreter] $fName
} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
    while executing*


"foo \[set a 1] \[break]"
    (file "*BREAKtest" line 2)}

test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
    set fName [makeFile {
	return -code return
    } BREAKtest]

Changes to tests/binary.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclBinary.c file and the "binary" Tcl command. 
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: binary.test,v 1.18 2004/06/23 15:36:55 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
::tcltest::testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
::tcltest::testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclBinary.c file and the "binary" Tcl command. 
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: binary.test,v 1.18.2.10 2005/10/08 13:44:38 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
::tcltest::testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
::tcltest::testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533




534
535
536
537
538
539
540
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format d2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format d2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable bigEndian} {
    binary format d NaN
} \x7f\xff\xff\xff\xff\xff\xff\xff
test binary-14.14 {Tcl_BinaryObjCmd: format} {
    list [catch {binary format d2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-14.15 {Tcl_BinaryObjCmd: format} {
    set a {1.6 3.4}
    list [catch {binary format d $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian {
    set a {1.6 3.4}
    binary format d1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian {
    set a {1.6 3.4}
    binary format d1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f





test binary-15.1 {Tcl_BinaryObjCmd: format} {
    list [catch {binary format ax*a "y" "z"} msg] $msg
} {1 {cannot use "*" in format string with "x"}}
test binary-15.2 {Tcl_BinaryObjCmd: format} {
    binary format axa "y" "z"
} y\x00z







<
<
<















>
>
>
>







509
510
511
512
513
514
515



516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format d2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format d2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40



test binary-14.14 {Tcl_BinaryObjCmd: format} {
    list [catch {binary format d2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-14.15 {Tcl_BinaryObjCmd: format} {
    set a {1.6 3.4}
    list [catch {binary format d $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian {
    set a {1.6 3.4}
    binary format d1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian {
    set a {1.6 3.4}
    binary format d1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-14.18 {FormatNumber: Bug 1116542} {
    binary scan [binary format d 1.25] d w
    set w
} 1.25

test binary-15.1 {Tcl_BinaryObjCmd: format} {
    list [catch {binary format ax*a "y" "z"} msg] $msg
} {1 {cannot use "*" in format string with "x"}}
test binary-15.2 {Tcl_BinaryObjCmd: format} {
    binary format axa "y" "z"
} y\x00z
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139

test binary-31.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc f} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1
} {1 1.60000002384}
test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1
} {1 1.60000002384}
test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1
} {1 1.60000002384}
test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1
} {1 1.60000002384}
test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
} {1 {}}
test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1
} {1 {}}
test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 foo
    list [binary scan \x52 f1 arg1] $arg1
} {0 foo}
test binary-31.13 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 1
    list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.60000002384 3.40000009537} 5}
test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.60000002384 3.40000009537} 5}

test binary-32.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc d} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1







|



|



|



|



|



|











|



|















|





|







1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140

test binary-31.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc f} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1
} {1 1.600000023841858}
test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1
} {1 1.600000023841858}
test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1
} {1 1.600000023841858}
test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1
} {1 1.600000023841858}
test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
} {1 {}}
test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1
} {1 {}}
test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 foo
    list [binary scan \x52 f1 arg1] $arg1
} {0 foo}
test binary-31.13 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 1
    list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}

test binary-32.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc d} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391

1392
1393
1394
1395
1396

1397
1398
1399
1400

1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 -2130640639}}
test binary-39.5 {ScanNumber: sign extension} {
    catch {unset arg1}
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}

test binary-40.1 {ScanNumber: floating point overflow} {nonPortable bigEndian} {
    catch {unset arg1}
    list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} {1 -NaN}
test binary-40.3 {ScanNumber: floating point overflow} {littleEndian win} {

    catch {unset arg1}
    set result [binary scan \xff\xff\xff\xff f1 arg1]
    if {[string equal $arg1 -1.\#QNAN] || [string equal $arg1 -NAN]} {
	lappend result success
    } else {

	lappend result failure $arg1
    }
} {1 success}
test binary-40.4 {ScanNumber: floating point overflow} {nonPortable bigEndian} {

    catch {unset arg1}
    list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1
} {1 -NaN}
test binary-40.6 {ScanNumber: floating point overflow} {littleEndian win} {
    catch {unset arg1}
    set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1]
    if {[string equal $arg1 -1.\#QNAN] || [string equal $arg1 -NAN]} {
	lappend result success
    } else {
	lappend result failure $arg1
    }
} {1 success}

test binary-41.1 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.2 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.3 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.4 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.5 {ScanNumber: word alignment} bigEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.60000002384}
test binary-41.6 {ScanNumber: word alignment} littleEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.60000002384}
test binary-41.7 {ScanNumber: word alignment} bigEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} littleEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2







<
<
<
<
|
>
|
|
<
<
|
>
|
|
<
|
>
|
|
|
<
|
<
<
|
<
<
<
<




















|



|







1381
1382
1383
1384
1385
1386
1387




1388
1389
1390
1391


1392
1393
1394
1395

1396
1397
1398
1399
1400

1401


1402




1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 -2130640639}}
test binary-39.5 {ScanNumber: sign extension} {
    catch {unset arg1}
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}





test binary-40.3 {ScanNumber: NaN} \
    -body {
	catch {unset arg1}
	list [binary scan \xff\xff\xff\xff f1 arg1] $arg1


    } \
    -match glob \
    -result {1 -NaN*}


test binary-40.4 {ScanNumber: NaN} \
    -body {
	catch {unset arg1}
	list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1
    } \

    -match glob \


    -result {1 -NaN*}





test binary-41.1 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.2 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.3 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.4 {ScanNumber: word alignment} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.5 {ScanNumber: word alignment} bigEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.600000023841858}
test binary-41.6 {ScanNumber: word alignment} littleEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.600000023841858}
test binary-41.7 {ScanNumber: word alignment} bigEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} littleEndian {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-51.10 {Tcl_BinaryObjCmd: format} {} {
    binary format Q2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-51.11 {Tcl_BinaryObjCmd: format} {} {
    binary format q2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-51.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable bigEndian} {
    binary format Q NaN
} \x7f\xff\xff\xff\xff\xff\xff\xff
test binary-51.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable mac} {
    binary format Q NaN
} \x7f\xf8\x02\xa0\x00\x00\x00\x00
test binary-51.14 {Tcl_BinaryObjCmd: format} {
    list [catch {binary format q2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-51.15 {Tcl_BinaryObjCmd: format} {
    set a {1.6 3.4}
    list [catch {binary format q $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]







<
<
<
<
<
<







1678
1679
1680
1681
1682
1683
1684






1685
1686
1687
1688
1689
1690
1691
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-51.10 {Tcl_BinaryObjCmd: format} {} {
    binary format Q2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-51.11 {Tcl_BinaryObjCmd: format} {} {
    binary format q2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40






test binary-51.14 {Tcl_BinaryObjCmd: format} {
    list [catch {binary format q2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-51.15 {Tcl_BinaryObjCmd: format} {
    set a {1.6 3.4}
    list [catch {binary format q $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}

# scan m
test binary-60.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian {
    binary scan HelloTcl m x
    set x
} 5216694956358656876
test binary-60.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian {
    binary scan lcTolleH m x
    set x
} 5216694956358656876
test binary-60.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set}  littleEndian {
    binary scan [binary format w [expr {wide(3) << 31}]] m x
    set x
} 6442450944
test binary-60.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian {
    binary scan [binary format W [expr {wide(3) << 31}]] m x
    set x
} 6442450944


# scan Q/q
test binary-58.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc q} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1919
1920
1921
1922
1923
1924
1925



















1926
1927
1928
1929
1930
1931
1932
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}




















# scan Q/q
test binary-58.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc q} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095




















































































































































































2096
2097
2098




# scan R/r
test binary-59.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc r} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1
} {1 1.60000002384}
test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1
} {1 1.60000002384}
test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1
} {1 1.60000002384}
test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1
} {1 1.60000002384}
test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1
} {1 {}}
test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1
} {1 {}}
test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-59.12 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 foo
    list [binary scan \x52 r1 arg1] $arg1
} {0 foo}
test binary-59.13 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 1
    list [catch {binary scan \x3f\xcc\xcc\xcd r1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2
} {2 {1.60000002384 3.40000009537} 5}
test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2
} {2 {1.60000002384 3.40000009537} 5}





















































































































































































# cleanup
::tcltest::cleanupTests
return











|



|



|



|



|



|











|



|















|





|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>
>
>
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
# scan R/r
test binary-59.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc r} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1
} {1 1.600000023841858}
test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1
} {1 1.600000023841858}
test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1
} {1 1.600000023841858}
test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1
} {1 1.600000023841858}
test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1
} {1 {}}
test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1
} {1 {}}
test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1}
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.12 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 foo
    list [binary scan \x52 r1 arg1] $arg1
} {0 foo}
test binary-59.13 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    set arg1 1
    list [catch {binary scan \x3f\xcc\xcc\xcd r1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}

test binary-60.1 {[binary format] with NaN} -body {
    binary scan [binary format dqQfrR NaN NaN NaN NaN NaN NaN] dqQfrR \
	v1 v2 v3 v4 v5 v6
    list $v1 $v2 $v3 $v4 $v5 $v6
} -match regexp -result {NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))?}

# scan m
test binary-61.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian {
    binary scan HelloTcl m x
    set x
} 5216694956358656876
test binary-61.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian {
    binary scan lcTolleH m x
    set x
} 5216694956358656876
test binary-61.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set}  littleEndian {
    binary scan [binary format w [expr {wide(3) << 31}]] m x
    set x
} 6442450944
test binary-61.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian {
    binary scan [binary format W [expr {wide(3) << 31}]] m x
    set x
} 6442450944

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]

# scan/format infinities

test binary-62.1 {infinity} ieeeFloatingPoint {
    binary scan [binary format q Infinity] w w
    format 0x%016lx $w
} 0x7ff0000000000000
test binary-62.2 {infinity} ieeeFloatingPoint {
    binary scan [binary format q -Infinity] w w
    format 0x%016lx $w
} 0xfff0000000000000
test binary-62.3 {infinity} ieeeFloatingPoint {
    binary scan [binary format q Inf] w w
    format 0x%016lx $w
} 0x7ff0000000000000
test binary-62.4 {infinity} ieeeFloatingPoint {
    binary scan [binary format q -Infinity] w w
    format 0x%016lx $w
} 0xfff0000000000000
test binary-62.5 {infinity} ieeeFloatingPoint {
    binary scan [binary format w 0x7ff0000000000000] q d
    set d
} Inf
test binary-62.6 {infinity} ieeeFloatingPoint {
    binary scan [binary format w 0xfff0000000000000] q d
    set d
} -Inf

# scan/format Not-a-Number

test binary-63.1 {NaN} ieeeFloatingPoint {
    binary scan [binary format q NaN] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff0000000000000
test binary-63.2 {NaN} ieeeFloatingPoint {
    binary scan [binary format q -NaN] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0xfff0000000000000
test binary-63.3 {NaN} ieeeFloatingPoint {
    binary scan [binary format q NaN(3123456789aBc)] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff3123456789abc
test binary-63.4 {NaN} ieeeFloatingPoint {
    binary scan [binary format q {NaN( 3123456789aBc)}] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff3123456789abc
test binary-64.1 {NaN} \
    -constraints ieeeFloatingPoint \
    -body {
	binary scan [binary format w 0x7ff8000000000000] q d
	set d
    } \
    -match glob -result NaN*
test binary-64.2 {NaN} \
    -constraints ieeeFloatingPoint \
    -body {
	binary scan [binary format w 0x7ff0123456789aBc] q d
	set d
    } \
    -match glob -result NaN(*123456789abc)

test binary-65.1 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fcfffffffffffff] q d
    set d
} 0.24999999999999997
test binary-65.2 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fd0000000000000] q d
    set d
} 0.25
test binary-65.3 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fdfffffffffffff] q d
    set d
} 0.49999999999999994
test binary-65.4 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fe0000000000000] q d
    set d
} 0.5
test binary-65.5 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fffffffffffffff] q d
    set d
} 1.9999999999999998
test binary-65.6 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x4000000000000000] q d
    set d
} 2.0
test binary-65.7 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x434fffffffffffff] q d
    set d
} 18014398509481982.0
test binary-65.8 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x4350000000000000] q d
    set d
} 18014398509481984.0
test binary-65.8 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x4350000000000001] q d
    set d
} 18014398509481988.0

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Added tests/chan.test.

















































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
# This file contains a collection of tests for the Tcl built-in 'chan'
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 2005 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: chan.test,v 1.4.6.3 2005/08/25 15:46:53 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

#
# Note: The tests for the chan methods "create" and "postevent"
# currently reside in the file "ioCmd.test".
#

test chan-1.1 {chan command general syntax} -body {
    chan
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\""
test chan-1.2 {chan command general syntax} -body {
    chan FOOBAR
} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate"

test chan-2.1 {chan command: blocked subcommand} -body {
    chan blocked foo bar
} -returnCodes error -result "wrong # args: should be \"chan blocked channelId\""

test chan-3.1 {chan command: close subcommand} -body {
    chan close foo bar
} -returnCodes error -result "wrong # args: should be \"chan close channelId\""

test chan-4.1 {chan command: configure subcommand} -body {
    chan configure
} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?optionName? ?value? ?optionName value?...\""

test chan-5.1 {chan command: copy subcommand} -body {
    chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""

test chan-6.1 {chan command: eof subcommand} -body {
    chan eof foo bar
} -returnCodes error -result "wrong # args: should be \"chan eof channelId\""

test chan-7.1 {chan command: event subcommand} -body {
    chan event foo
} -returnCodes error -result "wrong # args: should be \"chan event channelId event ?script?\""

test chan-8.1 {chan command: flush subcommand} -body {
    chan flush foo bar
} -returnCodes error -result "wrong # args: should be \"chan flush channelId\""

test chan-9.1 {chan command: gets subcommand} -body {
    chan gets
} -returnCodes error -result "wrong # args: should be \"chan gets channelId ?varName?\""

test chan-10.1 {chan command: names subcommand} -body {
    chan names foo bar
} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\""

test chan-11.1 {chan command: puts subcommand} -body {
    chan puts foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channelId? string\""

test chan-12.1 {chan command: read subcommand} -body {
    chan read
} -returnCodes error -result "wrong # args: should be \"chan read channelId ?numChars?\" or \"chan read ?-nonewline? channelId\""

test chan-13.1 {chan command: seek subcommand} -body {
    chan seek foo bar foo bar
} -returnCodes error -result "wrong # args: should be \"chan seek channelId offset ?origin?\""

test chan-14.1 {chan command: tell subcommand} -body {
    chan tell foo bar
} -returnCodes error -result "wrong # args: should be \"chan tell channelId\""

test chan-15.1 {chan command: truncate subcommand} -body {
    chan truncate foo bar foo bar
} -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\""
test chan-15.2 {chan command: truncate subcommand} -setup {
    set file [makeFile {} testTruncate]
    set f [open $file w+]
    fconfigure $f -translation binary
} -body {
    seek $f 0
    puts -nonewline $f 12345
    seek $f 0
    chan truncate $f 2
    read $f
} -result 12 -cleanup {
    catch {close $f}
    catch {removeFile $file}
}

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/clock.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# clock.test --
#
#	This test file covers the 'clock' command that manipulates time.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.test,v 1.52 2004/11/30 15:45:04 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if { $::tcl_platform(platform) eq {windows} } {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# clock.test --
#
#	This test file covers the 'clock' command that manipulates time.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.test,v 1.52.2.6 2005/10/08 13:44:38 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if { $::tcl_platform(platform) eq {windows} } {
38
39
40
41
42
43
44





45
46
47
48
49
50
51
	    # Still no registry!
	    namespace eval ::tcl::clock [set NoRegistry {}]
	}
    }
}
package require msgcat 1.4






# TEST PLAN

# clock-1:
#	[clock format] - tests of bad and empty arguments 
#
# clock-2 
#	formatting of year, month and day of month







>
>
>
>
>







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
	    # Still no registry!
	    namespace eval ::tcl::clock [set NoRegistry {}]
	}
    }
}
package require msgcat 1.4

::tcltest::testConstraint detroit \
    [expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}]
::tcltest::testConstraint y2038 \
    [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]

# TEST PLAN

# clock-1:
#	[clock format] - tests of bad and empty arguments 
#
# clock-2 
#	formatting of year, month and day of month
14770
14771
14772
14773
14774
14775
14776
14777
14778
14779
14780
14781
14782
14783
14784
14785
14786
14787
14788
14789
14790
14791
14792
14793
14794
} {23 xxiii 11 xi 23 xxiii 11 xi 59 lix PM pm 11:59:59 pm 23:59 59 lix 23:59:59 23:59:59 xxiii h lix m lix s Thu Jan  1 23:59:59 GMT 1970}
# END testcases4

# BEGIN testcases5

# Test formatting of Daylight Saving Time

::tcltest::testConstraint detroit 0
test clock-5.1 {does Detroit exist} {
    clock format 0 -format {} -timezone :America/Detroit
    ::tcltest::testConstraint detroit 1
    concat
} {}
test clock-5.2 {does Detroit have a Y2038 problem} detroit {
    if { [clock format 2158894800 -format %z -timezone :America/Detroit] ne {-0400} } {
        concat {y2038 problem}
    } else {
        ::tcltest::testConstraint y2038 1
        concat {ok}
    }
} ok
test clock-5.3 {time zone boundary case 1904-12-31 23:59:59} detroit {
    clock format -2051202470 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {23:59:59 -053211 LMT}







<


<






<







14775
14776
14777
14778
14779
14780
14781

14782
14783

14784
14785
14786
14787
14788
14789

14790
14791
14792
14793
14794
14795
14796
} {23 xxiii 11 xi 23 xxiii 11 xi 59 lix PM pm 11:59:59 pm 23:59 59 lix 23:59:59 23:59:59 xxiii h lix m lix s Thu Jan  1 23:59:59 GMT 1970}
# END testcases4

# BEGIN testcases5

# Test formatting of Daylight Saving Time


test clock-5.1 {does Detroit exist} {
    clock format 0 -format {} -timezone :America/Detroit

    concat
} {}
test clock-5.2 {does Detroit have a Y2038 problem} detroit {
    if { [clock format 2158894800 -format %z -timezone :America/Detroit] ne {-0400} } {
        concat {y2038 problem}
    } else {

        concat {ok}
    }
} ok
test clock-5.3 {time zone boundary case 1904-12-31 23:59:59} detroit {
    clock format -2051202470 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {23:59:59 -053211 LMT}
15756
15757
15758
15759
15760
15761
15762
15763
15764
15765
15766
15767
15768
15769
15770
15771
15772
15773
15774
15775
15776
15777
15778
15779
15780
15781
15782
15783
15784
15785
15786
15787
15788
15789
15790
15791
15792
15793
15794
15795
15796
15797
15798
15799
15800
15801
15802
15803
15804
15805
15806
15807
15808
15809
15810
15811
15812
15813
15814
15815
15816
15817
15818
15819
15820
15821
15822
15823
15824
15825
15826
15827
15828
15829
15830
15831
15832
15833
15834
15835
15836
15837
15838
15839
15840
15841
15842
15843
15844
15845
15846
15847
15848
15849
15850
15851
15852
15853
15854
15855
15856
15857
15858
15859
15860
15861
15862
15863
15864
15865
15866
15867
15868
15869
15870
15871
15872
15873
15874
15875
15876
15877
15878
15879
15880
15881
15882
15883
15884
15885
15886
15887
15888
15889
15890
15891
15892
15893
15894
15895
15896
15897
15898
15899
15900
15901
15902
15903
15904
15905
15906
15907
15908
15909
15910
15911
15912
15913
15914
15915
15916
15917
15918
15919
15920
15921
15922
15923
15924
15925
15926
15927
15928
15929
15930
15931
15932
15933
15934
15935
15936
15937
15938
15939
15940
15941
15942
15943
15944
15945
15946
15947
15948
15949
15950
15951
15952
15953
15954
15955
15956
15957
15958
15959
15960
15961
15962
15963
15964
15965
15966
15967
15968
15969
15970
15971
15972
15973
15974
15975
15976
15977
15978
15979
15980
15981
15982
15983
15984
15985
15986
15987
15988
15989
15990
15991
15992
15993
15994
15995
15996
15997
15998
15999
16000
16001
16002
16003
16004
16005
16006
16007
16008
16009
16010
16011
16012
16013
16014
16015
16016
16017
16018
16019
16020
16021
16022
16023
16024
16025
16026
16027
16028
16029
16030
16031
16032
16033
16034
16035
16036
16037
16038
16039
16040
16041
16042
16043
16044
16045
16046
16047
16048
16049
16050
16051
16052
16053
16054
16055
16056
16057
16058
16059
16060
16061
16062
16063
16064
16065
16066
16067
16068
16069
16070
16071
16072
16073
16074
16075
16076
16077
16078
16079
16080
16081
16082
16083
16084
16085
16086
16087
16088
16089
16090
16091
16092
16093
16094
16095
16096
16097
16098
16099
16100
16101
16102
16103
16104
16105
16106
16107
16108
16109
16110
16111
16112
16113
16114
16115
16116
16117
16118
16119
16120
16121
16122
16123
16124
16125
16126
16127
16128
16129
16130
16131
16132
16133
16134
16135
16136
16137
16138
16139
16140
16141
16142
16143
16144
16145
16146
16147
16148
16149
16150
16151
16152
16153
16154
16155
16156
16157
16158
16159
16160
16161
16162
16163
16164
16165
16166
16167
16168
16169
16170
16171
16172
16173
16174
16175
16176
16177
16178
16179
16180
16181
16182
16183
16184
16185
16186
16187
16188
16189
16190
16191
16192
16193
16194
16195
16196
16197
16198
16199
16200
16201
16202
16203
16204
16205
16206
16207
16208
16209
16210
16211
16212
16213
16214
16215
16216
16217
16218
16219
16220
16221
16222
16223
16224
16225
16226
16227
16228
16229
16230
16231
16232
16233
16234
16235
16236
16237
16238
16239
16240
16241
16242
16243
16244
16245
16246
16247
16248
16249
16250
16251
16252
16253
16254
16255
16256
16257
16258
16259
16260
16261
16262
16263
16264
16265
16266
16267
16268
16269
16270
16271
16272
16273
16274
16275
16276
16277
16278
16279
16280
16281
16282
16283
16284
16285
16286
16287
16288
16289
16290
16291
16292
16293
16294
16295
16296
16297
16298
16299
16300
16301
16302
16303
16304
16305
16306
16307
16308
16309
16310
16311
16312
16313
16314
16315
16316
16317
16318
16319
16320
16321
16322
16323
16324
16325
16326
16327
16328
16329
16330
16331
16332
16333
16334
16335
16336
16337
16338
16339
16340
16341
16342
16343
16344
16345
16346
16347
16348
16349
16350
16351
16352
16353
16354
16355
16356
16357
16358
16359
16360
16361
16362
16363
16364
16365
16366
16367
16368
16369
16370
16371
16372
16373
16374
16375
16376
16377
16378
16379
16380
16381
16382
16383
16384
16385
16386
16387
16388
16389
16390
16391
16392
16393
16394
16395
16396
16397
16398
16399
16400
16401
16402
16403
16404
16405
16406
16407
16408
16409
16410
16411
16412
16413
16414
16415
16416
16417
16418
16419
16420
16421
16422
16423
16424
16425
16426
16427
16428
16429
16430
16431
16432
16433
16434
16435
16436
16437
16438
16439
16440
16441
16442
16443
16444
16445
16446
16447
16448
16449
16450
16451
16452
16453
16454
16455
16456
16457
16458
16459
16460
16461
16462
16463
16464
16465
16466
16467
16468
16469
16470
16471
16472
16473
16474
16475
16476
16477
16478
16479
16480
16481
16482
16483
16484
16485
16486
16487
16488
16489
16490
16491
16492
16493
16494
16495
16496
16497
16498
16499
16500
16501
16502
16503
16504
16505
16506
16507
16508
16509
16510
16511
16512
16513
16514
16515
16516
16517
16518
16519
16520
16521
16522
16523
16524
16525
16526
16527
16528
16529
16530
16531
16532
16533
16534
16535
16536
16537
16538
16539
16540
16541
16542
16543
16544
16545
16546
16547
16548
16549
16550
16551
16552
16553
16554
16555
16556
16557
16558
16559
16560
16561
16562
16563
16564
16565
16566
16567
16568
16569
16570
16571
16572
16573
16574
16575
16576
16577
16578
16579
16580
16581
16582
16583
16584
16585
16586
16587
16588
16589
16590
16591
16592
16593
16594
16595
16596
16597
16598
16599
16600
16601
16602
16603
16604
16605
16606
16607
16608
16609
16610
16611
16612
16613
16614
16615
16616
16617
16618
16619
16620
16621
16622
16623
16624
16625
16626
16627
16628
16629
16630
16631
16632
16633
16634
16635
16636
16637
16638
16639
16640
16641
16642
16643
16644
16645
16646
16647
16648
16649
16650
16651
16652
16653
16654
16655
16656
16657
16658
16659
16660
16661
16662
16663
16664
16665
16666
16667
16668
16669
16670
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688
16689
16690
16691
16692
16693
16694
16695
16696
16697
16698
16699
16700
16701
16702
16703
16704
16705
16706
16707
16708
16709
16710
16711
16712
16713
16714
16715
16716
16717
16718
16719
16720
16721
16722
16723
16724
16725
16726
16727
16728
16729
16730
16731
16732
16733
16734
16735
16736
16737
16738
16739
16740
16741
16742
16743
16744
16745
16746
16747
16748
16749
16750
16751
16752
16753
16754
16755
16756
16757
16758
16759
16760
16761
16762
16763
16764
16765
16766
16767
16768
16769
16770
16771
16772
16773
16774
16775
16776
16777
16778
16779
16780
16781
16782
16783
16784
16785
16786
16787
16788
16789
16790
16791
16792
16793
16794
16795
16796
16797
16798
16799
16800
16801
16802
16803
16804
16805
16806
16807
16808
16809
16810
16811
16812
16813
16814
16815
16816
16817
16818
16819
16820
16821
16822
16823
16824
16825
16826
16827
16828
16829
16830
16831
16832
16833
16834
16835
16836
16837
16838
16839
16840
16841
16842
16843
16844
16845
16846
16847
16848
16849
16850
16851
16852
16853
16854
16855
16856
16857
16858
16859
16860
16861
16862
16863
16864
16865
16866
16867
16868
16869
16870
16871
16872
16873
16874
16875
16876
16877
16878
16879
16880
16881
16882
16883
16884
16885
16886
16887
16888
16889
16890
16891
16892
16893
16894
16895
16896
16897
16898
16899
16900
16901
16902
16903
16904
16905
16906
16907
16908
16909
16910
16911
16912
16913
16914
16915
16916
16917
16918
16919
16920
16921
16922
16923
16924
16925
16926
16927
16928
16929
16930
16931
16932
16933
16934
16935
16936
16937
16938
16939
16940
16941
16942
16943
16944
16945
16946
16947
16948
16949
16950
16951
16952
16953
16954
16955
16956
16957
16958
16959
16960
16961
16962
16963
16964
16965
16966
16967
16968
16969
16970
16971
16972
16973
16974
16975
16976
16977
16978
16979
16980
16981
16982
16983
16984
16985
16986
16987
16988
16989
16990
16991
16992
16993
16994
16995
16996
16997
16998
16999
17000
17001
17002
17003
17004
17005
17006
17007
17008
17009
17010
17011
17012
17013
17014
17015
17016
17017
17018
17019
17020
17021
17022
17023
17024
17025
17026
17027
17028
17029
17030
17031
17032
17033
17034
17035
17036
17037
17038
17039
17040
17041
17042
17043
17044
17045
17046
17047
17048
17049
17050
17051
17052
17053
17054
17055
17056
17057
17058
17059
17060
17061
17062
17063
17064
17065
17066
17067
17068
17069
17070
17071
17072
17073
17074
17075
17076
17077
17078
17079
17080
17081
17082
17083
17084
17085
17086
17087
17088
17089
17090
17091
17092
17093
17094
17095
17096
17097
17098
17099
17100
17101
17102
17103
17104
17105
17106
17107
17108
17109
17110
17111
17112
17113
17114
17115
17116
17117
17118
17119
17120
17121
17122
17123
17124
17125
17126
17127
17128
17129
17130
17131
17132
17133
17134
17135
17136
17137
17138
17139
17140
17141
17142
17143
17144
17145
17146
17147
17148
17149
17150
17151
17152
17153
17154
17155
17156
17157
17158
17159
17160
17161
17162
17163
17164
17165
17166
17167
17168
17169
17170
17171
17172
17173
17174
17175
17176
17177
17178
17179
17180
17181
17182
17183
17184
17185
17186
17187
17188
17189
17190
17191
17192
17193
17194
17195
17196
17197
17198
17199
17200
17201
17202
17203
17204
17205
17206
17207
17208
17209
17210
17211
17212
17213
17214
17215
17216
17217
17218
17219
17220
17221
17222
17223
17224
17225
17226
17227
17228
17229
17230
17231
17232
17233
17234
17235
17236
17237
17238
17239
17240
17241
17242
17243
17244
17245
17246
17247
17248
17249
17250
17251
17252
17253
17254
17255
17256
17257
17258
17259
17260
17261
17262
17263
17264
17265
17266
17267
17268
17269
17270
17271
17272
17273
17274
17275
17276
17277
17278
17279
17280
17281
17282
17283
17284
17285
17286
17287
17288
17289
17290
17291
17292
17293
17294
17295
17296
17297
17298
17299
17300
17301
17302
17303
17304
17305
17306
17307
17308
17309
17310
17311
17312
17313
17314
17315
17316
17317
17318
17319
17320
17321
17322
17323
17324
17325
17326
17327
17328
17329
17330
17331
17332
17333
17334
17335
17336
17337
17338
17339
17340
17341
17342
17343
17344
17345
17346
17347
17348
17349
17350
17351
17352
17353
17354
17355
17356
17357
17358
17359
17360
17361
17362
17363
17364
17365
17366
17367
17368
17369
17370
17371
17372
17373
17374
17375
17376
17377
17378
17379
17380
17381
17382
17383
17384
17385
17386
17387
17388
17389
17390
17391
17392
17393
17394
17395
17396
17397
17398
17399
17400
17401
17402
17403
17404
17405
17406
17407
17408
17409
17410
17411
17412
17413
17414
17415
17416
17417
17418
17419
17420
17421
17422
17423
17424
17425
17426
17427
17428
17429
17430
17431
17432
17433
17434
17435
17436
17437
17438
17439
17440
17441
17442
17443
17444
17445
17446
17447
17448
17449
17450
17451
17452
17453
17454
17455
17456
17457
17458
17459
17460
17461
17462
17463
17464
17465
17466
17467
17468
17469
17470
17471
17472
17473
17474
17475
17476
17477
17478
17479
17480
17481
17482
17483
17484
17485
17486
17487
17488
17489
17490
17491
17492
17493
17494
17495
17496
17497
17498
17499
17500
17501
17502
17503
17504
17505
17506
17507
17508
17509
17510
17511
17512
17513
17514
17515
17516
17517
17518
17519
17520
17521
17522
17523
17524
17525
17526
17527
17528
17529
17530
17531
17532
17533
17534
17535
17536
17537
17538
17539
17540
17541
17542
17543
17544
17545
17546
17547
17548
17549
17550
17551
17552
17553
17554
17555
17556
17557
17558
17559
17560
17561
17562
17563
17564
17565
17566
17567
17568
17569
17570
17571
17572
17573
17574
17575
17576
17577
17578
17579
17580
17581
17582
17583
17584
17585
17586
17587
17588
17589
17590
17591
17592
17593
17594
17595
17596
17597
17598
17599
17600
17601
17602
17603
17604
17605
17606
17607
17608
17609
17610
17611
17612
17613
17614
17615
17616
17617
17618
17619
17620
17621
17622
17623
17624
17625
17626
17627
17628
17629
17630
17631
17632
17633
17634
17635
17636
17637
17638
17639
17640
17641
17642
17643
17644
17645
17646
17647
17648
17649
17650
17651
17652
17653
17654
17655
17656
17657
17658
17659
17660
17661
17662
17663
17664
17665
17666
17667
17668
17669
17670
17671
17672
17673
17674
17675
17676
17677
17678
17679
17680
17681
17682
17683
17684
17685
17686
17687
17688
17689
17690
17691
17692
17693
17694
17695
17696
17697
17698
17699
17700
17701
17702
17703
17704
17705
17706
17707
17708
17709
17710
17711
17712
17713
17714
17715
17716
17717
17718
17719
17720
17721
17722
17723
17724
17725
17726
17727
17728
17729
17730
17731
17732
17733
17734
17735
17736
17737
17738
17739
17740
17741
17742
17743
17744
17745
17746
17747
17748
17749
17750
17751
17752
17753
17754
17755
17756
17757
17758
17759
17760
17761
17762
17763
17764
17765
17766
17767
17768
17769
17770
17771
17772
17773
17774
17775
17776
17777
17778
17779
17780
17781
17782
17783
17784
17785
17786
17787
17788
17789
17790
17791
17792
17793
17794
17795
17796
17797
17798
17799
17800
17801
17802
17803
17804
17805
17806
17807
17808
17809
17810
17811
17812
17813
17814
17815
17816
17817
17818
17819
17820
17821
17822
17823
17824
17825
17826
17827
17828
17829
17830
17831
17832
17833
17834
17835
17836
17837
17838
17839
17840
17841
17842
17843
17844
17845
17846
17847
17848
17849
17850
17851
17852
17853
17854
17855
17856
17857
17858
17859
17860
17861
17862
17863
17864
17865
17866
17867
17868
17869
17870
17871
17872
17873
17874
17875
17876
17877
17878
17879
17880
17881
17882
17883
17884
17885
17886
17887
17888
17889
17890
17891
17892
17893
17894
17895
17896
17897
17898
17899
17900
17901
17902
17903
17904
17905
17906
17907
17908
17909
17910
17911
17912
17913
17914
17915
17916
17917
17918
17919
17920
17921
17922
17923
17924
17925
17926
17927
17928
17929
17930
17931
17932
17933
17934
17935
17936
17937
17938
17939
17940
17941
17942
17943
17944
17945
17946
17947
17948
17949
17950
17951
17952
17953
17954
17955
17956
17957
17958
17959
17960
17961
17962
17963
17964
17965
17966
17967
17968
17969
17970
17971
17972
17973
17974
17975
17976
17977
17978
17979
17980
17981
17982
17983
17984
17985
17986
17987
17988
17989
17990
17991
17992
17993
17994
17995
17996
17997
17998
17999
    clock format 1162101600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.245 {time zone boundary case 2006-10-29 01:00:01} detroit {
    clock format 1162101601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.246 {time zone boundary case 2007-04-01 01:59:59} detroit {
    clock format 1175410799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.247 {time zone boundary case 2007-04-01 03:00:00} detroit {
    clock format 1175410800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.248 {time zone boundary case 2007-04-01 03:00:01} detroit {
    clock format 1175410801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.249 {time zone boundary case 2007-10-28 01:59:59} detroit {
    clock format 1193551199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.250 {time zone boundary case 2007-10-28 01:00:00} detroit {
    clock format 1193551200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.251 {time zone boundary case 2007-10-28 01:00:01} detroit {
    clock format 1193551201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.252 {time zone boundary case 2008-04-06 01:59:59} detroit {
    clock format 1207465199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.253 {time zone boundary case 2008-04-06 03:00:00} detroit {
    clock format 1207465200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.254 {time zone boundary case 2008-04-06 03:00:01} detroit {
    clock format 1207465201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.255 {time zone boundary case 2008-10-26 01:59:59} detroit {
    clock format 1225000799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.256 {time zone boundary case 2008-10-26 01:00:00} detroit {
    clock format 1225000800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.257 {time zone boundary case 2008-10-26 01:00:01} detroit {
    clock format 1225000801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.258 {time zone boundary case 2009-04-05 01:59:59} detroit {
    clock format 1238914799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.259 {time zone boundary case 2009-04-05 03:00:00} detroit {
    clock format 1238914800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.260 {time zone boundary case 2009-04-05 03:00:01} detroit {
    clock format 1238914801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.261 {time zone boundary case 2009-10-25 01:59:59} detroit {
    clock format 1256450399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.262 {time zone boundary case 2009-10-25 01:00:00} detroit {
    clock format 1256450400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.263 {time zone boundary case 2009-10-25 01:00:01} detroit {
    clock format 1256450401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.264 {time zone boundary case 2010-04-04 01:59:59} detroit {
    clock format 1270364399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.265 {time zone boundary case 2010-04-04 03:00:00} detroit {
    clock format 1270364400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.266 {time zone boundary case 2010-04-04 03:00:01} detroit {
    clock format 1270364401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.267 {time zone boundary case 2010-10-31 01:59:59} detroit {
    clock format 1288504799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.268 {time zone boundary case 2010-10-31 01:00:00} detroit {
    clock format 1288504800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.269 {time zone boundary case 2010-10-31 01:00:01} detroit {
    clock format 1288504801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.270 {time zone boundary case 2011-04-03 01:59:59} detroit {
    clock format 1301813999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.271 {time zone boundary case 2011-04-03 03:00:00} detroit {
    clock format 1301814000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.272 {time zone boundary case 2011-04-03 03:00:01} detroit {
    clock format 1301814001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.273 {time zone boundary case 2011-10-30 01:59:59} detroit {
    clock format 1319954399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.274 {time zone boundary case 2011-10-30 01:00:00} detroit {
    clock format 1319954400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.275 {time zone boundary case 2011-10-30 01:00:01} detroit {
    clock format 1319954401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.276 {time zone boundary case 2012-04-01 01:59:59} detroit {
    clock format 1333263599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.277 {time zone boundary case 2012-04-01 03:00:00} detroit {
    clock format 1333263600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.278 {time zone boundary case 2012-04-01 03:00:01} detroit {
    clock format 1333263601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.279 {time zone boundary case 2012-10-28 01:59:59} detroit {
    clock format 1351403999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.280 {time zone boundary case 2012-10-28 01:00:00} detroit {
    clock format 1351404000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.281 {time zone boundary case 2012-10-28 01:00:01} detroit {
    clock format 1351404001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.282 {time zone boundary case 2013-04-07 01:59:59} detroit {
    clock format 1365317999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.283 {time zone boundary case 2013-04-07 03:00:00} detroit {
    clock format 1365318000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.284 {time zone boundary case 2013-04-07 03:00:01} detroit {
    clock format 1365318001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.285 {time zone boundary case 2013-10-27 01:59:59} detroit {
    clock format 1382853599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.286 {time zone boundary case 2013-10-27 01:00:00} detroit {
    clock format 1382853600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.287 {time zone boundary case 2013-10-27 01:00:01} detroit {
    clock format 1382853601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.288 {time zone boundary case 2014-04-06 01:59:59} detroit {
    clock format 1396767599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.289 {time zone boundary case 2014-04-06 03:00:00} detroit {
    clock format 1396767600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.290 {time zone boundary case 2014-04-06 03:00:01} detroit {
    clock format 1396767601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.291 {time zone boundary case 2014-10-26 01:59:59} detroit {
    clock format 1414303199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.292 {time zone boundary case 2014-10-26 01:00:00} detroit {
    clock format 1414303200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.293 {time zone boundary case 2014-10-26 01:00:01} detroit {
    clock format 1414303201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.294 {time zone boundary case 2015-04-05 01:59:59} detroit {
    clock format 1428217199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.295 {time zone boundary case 2015-04-05 03:00:00} detroit {
    clock format 1428217200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.296 {time zone boundary case 2015-04-05 03:00:01} detroit {
    clock format 1428217201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.297 {time zone boundary case 2015-10-25 01:59:59} detroit {
    clock format 1445752799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.298 {time zone boundary case 2015-10-25 01:00:00} detroit {
    clock format 1445752800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.299 {time zone boundary case 2015-10-25 01:00:01} detroit {
    clock format 1445752801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.300 {time zone boundary case 2016-04-03 01:59:59} detroit {
    clock format 1459666799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.301 {time zone boundary case 2016-04-03 03:00:00} detroit {
    clock format 1459666800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.302 {time zone boundary case 2016-04-03 03:00:01} detroit {
    clock format 1459666801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.303 {time zone boundary case 2016-10-30 01:59:59} detroit {
    clock format 1477807199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.304 {time zone boundary case 2016-10-30 01:00:00} detroit {
    clock format 1477807200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.305 {time zone boundary case 2016-10-30 01:00:01} detroit {
    clock format 1477807201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.306 {time zone boundary case 2017-04-02 01:59:59} detroit {
    clock format 1491116399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.307 {time zone boundary case 2017-04-02 03:00:00} detroit {
    clock format 1491116400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.308 {time zone boundary case 2017-04-02 03:00:01} detroit {
    clock format 1491116401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.309 {time zone boundary case 2017-10-29 01:59:59} detroit {
    clock format 1509256799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.310 {time zone boundary case 2017-10-29 01:00:00} detroit {
    clock format 1509256800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.311 {time zone boundary case 2017-10-29 01:00:01} detroit {
    clock format 1509256801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.312 {time zone boundary case 2018-04-01 01:59:59} detroit {
    clock format 1522565999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.313 {time zone boundary case 2018-04-01 03:00:00} detroit {
    clock format 1522566000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.314 {time zone boundary case 2018-04-01 03:00:01} detroit {
    clock format 1522566001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.315 {time zone boundary case 2018-10-28 01:59:59} detroit {
    clock format 1540706399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.316 {time zone boundary case 2018-10-28 01:00:00} detroit {
    clock format 1540706400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.317 {time zone boundary case 2018-10-28 01:00:01} detroit {
    clock format 1540706401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.318 {time zone boundary case 2019-04-07 01:59:59} detroit {
    clock format 1554620399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.319 {time zone boundary case 2019-04-07 03:00:00} detroit {
    clock format 1554620400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.320 {time zone boundary case 2019-04-07 03:00:01} detroit {
    clock format 1554620401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.321 {time zone boundary case 2019-10-27 01:59:59} detroit {
    clock format 1572155999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.322 {time zone boundary case 2019-10-27 01:00:00} detroit {
    clock format 1572156000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.323 {time zone boundary case 2019-10-27 01:00:01} detroit {
    clock format 1572156001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.324 {time zone boundary case 2020-04-05 01:59:59} detroit {
    clock format 1586069999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.325 {time zone boundary case 2020-04-05 03:00:00} detroit {
    clock format 1586070000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.326 {time zone boundary case 2020-04-05 03:00:01} detroit {
    clock format 1586070001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.327 {time zone boundary case 2020-10-25 01:59:59} detroit {
    clock format 1603605599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.328 {time zone boundary case 2020-10-25 01:00:00} detroit {
    clock format 1603605600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.329 {time zone boundary case 2020-10-25 01:00:01} detroit {
    clock format 1603605601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.330 {time zone boundary case 2021-04-04 01:59:59} detroit {
    clock format 1617519599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.331 {time zone boundary case 2021-04-04 03:00:00} detroit {
    clock format 1617519600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.332 {time zone boundary case 2021-04-04 03:00:01} detroit {
    clock format 1617519601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.333 {time zone boundary case 2021-10-31 01:59:59} detroit {
    clock format 1635659999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.334 {time zone boundary case 2021-10-31 01:00:00} detroit {
    clock format 1635660000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.335 {time zone boundary case 2021-10-31 01:00:01} detroit {
    clock format 1635660001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.336 {time zone boundary case 2022-04-03 01:59:59} detroit {
    clock format 1648969199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.337 {time zone boundary case 2022-04-03 03:00:00} detroit {
    clock format 1648969200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.338 {time zone boundary case 2022-04-03 03:00:01} detroit {
    clock format 1648969201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.339 {time zone boundary case 2022-10-30 01:59:59} detroit {
    clock format 1667109599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.340 {time zone boundary case 2022-10-30 01:00:00} detroit {
    clock format 1667109600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.341 {time zone boundary case 2022-10-30 01:00:01} detroit {
    clock format 1667109601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.342 {time zone boundary case 2023-04-02 01:59:59} detroit {
    clock format 1680418799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.343 {time zone boundary case 2023-04-02 03:00:00} detroit {
    clock format 1680418800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.344 {time zone boundary case 2023-04-02 03:00:01} detroit {
    clock format 1680418801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.345 {time zone boundary case 2023-10-29 01:59:59} detroit {
    clock format 1698559199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.346 {time zone boundary case 2023-10-29 01:00:00} detroit {
    clock format 1698559200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.347 {time zone boundary case 2023-10-29 01:00:01} detroit {
    clock format 1698559201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.348 {time zone boundary case 2024-04-07 01:59:59} detroit {
    clock format 1712473199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.349 {time zone boundary case 2024-04-07 03:00:00} detroit {
    clock format 1712473200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.350 {time zone boundary case 2024-04-07 03:00:01} detroit {
    clock format 1712473201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.351 {time zone boundary case 2024-10-27 01:59:59} detroit {
    clock format 1730008799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.352 {time zone boundary case 2024-10-27 01:00:00} detroit {
    clock format 1730008800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.353 {time zone boundary case 2024-10-27 01:00:01} detroit {
    clock format 1730008801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.354 {time zone boundary case 2025-04-06 01:59:59} detroit {
    clock format 1743922799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.355 {time zone boundary case 2025-04-06 03:00:00} detroit {
    clock format 1743922800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.356 {time zone boundary case 2025-04-06 03:00:01} detroit {
    clock format 1743922801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.357 {time zone boundary case 2025-10-26 01:59:59} detroit {
    clock format 1761458399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.358 {time zone boundary case 2025-10-26 01:00:00} detroit {
    clock format 1761458400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.359 {time zone boundary case 2025-10-26 01:00:01} detroit {
    clock format 1761458401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.360 {time zone boundary case 2026-04-05 01:59:59} detroit {
    clock format 1775372399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.361 {time zone boundary case 2026-04-05 03:00:00} detroit {
    clock format 1775372400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.362 {time zone boundary case 2026-04-05 03:00:01} detroit {
    clock format 1775372401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.363 {time zone boundary case 2026-10-25 01:59:59} detroit {
    clock format 1792907999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.364 {time zone boundary case 2026-10-25 01:00:00} detroit {
    clock format 1792908000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.365 {time zone boundary case 2026-10-25 01:00:01} detroit {
    clock format 1792908001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.366 {time zone boundary case 2027-04-04 01:59:59} detroit {
    clock format 1806821999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.367 {time zone boundary case 2027-04-04 03:00:00} detroit {
    clock format 1806822000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.368 {time zone boundary case 2027-04-04 03:00:01} detroit {
    clock format 1806822001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.369 {time zone boundary case 2027-10-31 01:59:59} detroit {
    clock format 1824962399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.370 {time zone boundary case 2027-10-31 01:00:00} detroit {
    clock format 1824962400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.371 {time zone boundary case 2027-10-31 01:00:01} detroit {
    clock format 1824962401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.372 {time zone boundary case 2028-04-02 01:59:59} detroit {
    clock format 1838271599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.373 {time zone boundary case 2028-04-02 03:00:00} detroit {
    clock format 1838271600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.374 {time zone boundary case 2028-04-02 03:00:01} detroit {
    clock format 1838271601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.375 {time zone boundary case 2028-10-29 01:59:59} detroit {
    clock format 1856411999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.376 {time zone boundary case 2028-10-29 01:00:00} detroit {
    clock format 1856412000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.377 {time zone boundary case 2028-10-29 01:00:01} detroit {
    clock format 1856412001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.378 {time zone boundary case 2029-04-01 01:59:59} detroit {
    clock format 1869721199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.379 {time zone boundary case 2029-04-01 03:00:00} detroit {
    clock format 1869721200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.380 {time zone boundary case 2029-04-01 03:00:01} detroit {
    clock format 1869721201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.381 {time zone boundary case 2029-10-28 01:59:59} detroit {
    clock format 1887861599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.382 {time zone boundary case 2029-10-28 01:00:00} detroit {
    clock format 1887861600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.383 {time zone boundary case 2029-10-28 01:00:01} detroit {
    clock format 1887861601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.384 {time zone boundary case 2030-04-07 01:59:59} detroit {
    clock format 1901775599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.385 {time zone boundary case 2030-04-07 03:00:00} detroit {
    clock format 1901775600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.386 {time zone boundary case 2030-04-07 03:00:01} detroit {
    clock format 1901775601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.387 {time zone boundary case 2030-10-27 01:59:59} detroit {
    clock format 1919311199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.388 {time zone boundary case 2030-10-27 01:00:00} detroit {
    clock format 1919311200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.389 {time zone boundary case 2030-10-27 01:00:01} detroit {
    clock format 1919311201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.390 {time zone boundary case 2031-04-06 01:59:59} detroit {
    clock format 1933225199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.391 {time zone boundary case 2031-04-06 03:00:00} detroit {
    clock format 1933225200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.392 {time zone boundary case 2031-04-06 03:00:01} detroit {
    clock format 1933225201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.393 {time zone boundary case 2031-10-26 01:59:59} detroit {
    clock format 1950760799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.394 {time zone boundary case 2031-10-26 01:00:00} detroit {
    clock format 1950760800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.395 {time zone boundary case 2031-10-26 01:00:01} detroit {
    clock format 1950760801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.396 {time zone boundary case 2032-04-04 01:59:59} detroit {
    clock format 1964674799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.397 {time zone boundary case 2032-04-04 03:00:00} detroit {
    clock format 1964674800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.398 {time zone boundary case 2032-04-04 03:00:01} detroit {
    clock format 1964674801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.399 {time zone boundary case 2032-10-31 01:59:59} detroit {
    clock format 1982815199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.400 {time zone boundary case 2032-10-31 01:00:00} detroit {
    clock format 1982815200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.401 {time zone boundary case 2032-10-31 01:00:01} detroit {
    clock format 1982815201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.402 {time zone boundary case 2033-04-03 01:59:59} detroit {
    clock format 1996124399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.403 {time zone boundary case 2033-04-03 03:00:00} detroit {
    clock format 1996124400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.404 {time zone boundary case 2033-04-03 03:00:01} detroit {
    clock format 1996124401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.405 {time zone boundary case 2033-10-30 01:59:59} detroit {
    clock format 2014264799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.406 {time zone boundary case 2033-10-30 01:00:00} detroit {
    clock format 2014264800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.407 {time zone boundary case 2033-10-30 01:00:01} detroit {
    clock format 2014264801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.408 {time zone boundary case 2034-04-02 01:59:59} detroit {
    clock format 2027573999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.409 {time zone boundary case 2034-04-02 03:00:00} detroit {
    clock format 2027574000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.410 {time zone boundary case 2034-04-02 03:00:01} detroit {
    clock format 2027574001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.411 {time zone boundary case 2034-10-29 01:59:59} detroit {
    clock format 2045714399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.412 {time zone boundary case 2034-10-29 01:00:00} detroit {
    clock format 2045714400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.413 {time zone boundary case 2034-10-29 01:00:01} detroit {
    clock format 2045714401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.414 {time zone boundary case 2035-04-01 01:59:59} detroit {
    clock format 2059023599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.415 {time zone boundary case 2035-04-01 03:00:00} detroit {
    clock format 2059023600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.416 {time zone boundary case 2035-04-01 03:00:01} detroit {
    clock format 2059023601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.417 {time zone boundary case 2035-10-28 01:59:59} detroit {
    clock format 2077163999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.418 {time zone boundary case 2035-10-28 01:00:00} detroit {
    clock format 2077164000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.419 {time zone boundary case 2035-10-28 01:00:01} detroit {
    clock format 2077164001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.420 {time zone boundary case 2036-04-06 01:59:59} detroit {
    clock format 2091077999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.421 {time zone boundary case 2036-04-06 03:00:00} detroit {
    clock format 2091078000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.422 {time zone boundary case 2036-04-06 03:00:01} detroit {
    clock format 2091078001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.423 {time zone boundary case 2036-10-26 01:59:59} detroit {
    clock format 2108613599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.424 {time zone boundary case 2036-10-26 01:00:00} detroit {
    clock format 2108613600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.425 {time zone boundary case 2036-10-26 01:00:01} detroit {
    clock format 2108613601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.426 {time zone boundary case 2037-04-05 01:59:59} detroit {
    clock format 2122527599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.427 {time zone boundary case 2037-04-05 03:00:00} detroit {
    clock format 2122527600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.428 {time zone boundary case 2037-04-05 03:00:01} detroit {
    clock format 2122527601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.429 {time zone boundary case 2037-10-25 01:59:59} detroit {
    clock format 2140063199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.430 {time zone boundary case 2037-10-25 01:00:00} detroit {
    clock format 2140063200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.431 {time zone boundary case 2037-10-25 01:00:01} detroit {
    clock format 2140063201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.432 {time zone boundary case 2038-04-04 01:59:59} {detroit y2038} {
    clock format 2153977199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.433 {time zone boundary case 2038-04-04 03:00:00} {detroit y2038} {
    clock format 2153977200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.434 {time zone boundary case 2038-04-04 03:00:01} {detroit y2038} {
    clock format 2153977201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.435 {time zone boundary case 2038-10-31 01:59:59} {detroit y2038} {
    clock format 2172117599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.436 {time zone boundary case 2038-10-31 01:00:00} {detroit y2038} {
    clock format 2172117600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.437 {time zone boundary case 2038-10-31 01:00:01} {detroit y2038} {
    clock format 2172117601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.438 {time zone boundary case 2039-04-03 01:59:59} {detroit y2038} {
    clock format 2185426799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.439 {time zone boundary case 2039-04-03 03:00:00} {detroit y2038} {
    clock format 2185426800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.440 {time zone boundary case 2039-04-03 03:00:01} {detroit y2038} {
    clock format 2185426801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.441 {time zone boundary case 2039-10-30 01:59:59} {detroit y2038} {
    clock format 2203567199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.442 {time zone boundary case 2039-10-30 01:00:00} {detroit y2038} {
    clock format 2203567200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.443 {time zone boundary case 2039-10-30 01:00:01} {detroit y2038} {
    clock format 2203567201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.444 {time zone boundary case 2040-04-01 01:59:59} {detroit y2038} {
    clock format 2216876399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.445 {time zone boundary case 2040-04-01 03:00:00} {detroit y2038} {
    clock format 2216876400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.446 {time zone boundary case 2040-04-01 03:00:01} {detroit y2038} {
    clock format 2216876401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.447 {time zone boundary case 2040-10-28 01:59:59} {detroit y2038} {
    clock format 2235016799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.448 {time zone boundary case 2040-10-28 01:00:00} {detroit y2038} {
    clock format 2235016800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.449 {time zone boundary case 2040-10-28 01:00:01} {detroit y2038} {
    clock format 2235016801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.450 {time zone boundary case 2041-04-07 01:59:59} {detroit y2038} {
    clock format 2248930799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.451 {time zone boundary case 2041-04-07 03:00:00} {detroit y2038} {
    clock format 2248930800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.452 {time zone boundary case 2041-04-07 03:00:01} {detroit y2038} {
    clock format 2248930801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.453 {time zone boundary case 2041-10-27 01:59:59} {detroit y2038} {
    clock format 2266466399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.454 {time zone boundary case 2041-10-27 01:00:00} {detroit y2038} {
    clock format 2266466400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.455 {time zone boundary case 2041-10-27 01:00:01} {detroit y2038} {
    clock format 2266466401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.456 {time zone boundary case 2042-04-06 01:59:59} {detroit y2038} {
    clock format 2280380399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.457 {time zone boundary case 2042-04-06 03:00:00} {detroit y2038} {
    clock format 2280380400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.458 {time zone boundary case 2042-04-06 03:00:01} {detroit y2038} {
    clock format 2280380401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.459 {time zone boundary case 2042-10-26 01:59:59} {detroit y2038} {
    clock format 2297915999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.460 {time zone boundary case 2042-10-26 01:00:00} {detroit y2038} {
    clock format 2297916000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.461 {time zone boundary case 2042-10-26 01:00:01} {detroit y2038} {
    clock format 2297916001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.462 {time zone boundary case 2043-04-05 01:59:59} {detroit y2038} {
    clock format 2311829999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.463 {time zone boundary case 2043-04-05 03:00:00} {detroit y2038} {
    clock format 2311830000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.464 {time zone boundary case 2043-04-05 03:00:01} {detroit y2038} {
    clock format 2311830001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.465 {time zone boundary case 2043-10-25 01:59:59} {detroit y2038} {
    clock format 2329365599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.466 {time zone boundary case 2043-10-25 01:00:00} {detroit y2038} {
    clock format 2329365600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.467 {time zone boundary case 2043-10-25 01:00:01} {detroit y2038} {
    clock format 2329365601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.468 {time zone boundary case 2044-04-03 01:59:59} {detroit y2038} {
    clock format 2343279599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.469 {time zone boundary case 2044-04-03 03:00:00} {detroit y2038} {
    clock format 2343279600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.470 {time zone boundary case 2044-04-03 03:00:01} {detroit y2038} {
    clock format 2343279601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.471 {time zone boundary case 2044-10-30 01:59:59} {detroit y2038} {
    clock format 2361419999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.472 {time zone boundary case 2044-10-30 01:00:00} {detroit y2038} {
    clock format 2361420000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.473 {time zone boundary case 2044-10-30 01:00:01} {detroit y2038} {
    clock format 2361420001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.474 {time zone boundary case 2045-04-02 01:59:59} {detroit y2038} {
    clock format 2374729199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.475 {time zone boundary case 2045-04-02 03:00:00} {detroit y2038} {
    clock format 2374729200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.476 {time zone boundary case 2045-04-02 03:00:01} {detroit y2038} {
    clock format 2374729201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.477 {time zone boundary case 2045-10-29 01:59:59} {detroit y2038} {
    clock format 2392869599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.478 {time zone boundary case 2045-10-29 01:00:00} {detroit y2038} {
    clock format 2392869600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.479 {time zone boundary case 2045-10-29 01:00:01} {detroit y2038} {
    clock format 2392869601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.480 {time zone boundary case 2046-04-01 01:59:59} {detroit y2038} {
    clock format 2406178799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.481 {time zone boundary case 2046-04-01 03:00:00} {detroit y2038} {
    clock format 2406178800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.482 {time zone boundary case 2046-04-01 03:00:01} {detroit y2038} {
    clock format 2406178801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.483 {time zone boundary case 2046-10-28 01:59:59} {detroit y2038} {
    clock format 2424319199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.484 {time zone boundary case 2046-10-28 01:00:00} {detroit y2038} {
    clock format 2424319200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.485 {time zone boundary case 2046-10-28 01:00:01} {detroit y2038} {
    clock format 2424319201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.486 {time zone boundary case 2047-04-07 01:59:59} {detroit y2038} {
    clock format 2438233199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.487 {time zone boundary case 2047-04-07 03:00:00} {detroit y2038} {
    clock format 2438233200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.488 {time zone boundary case 2047-04-07 03:00:01} {detroit y2038} {
    clock format 2438233201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.489 {time zone boundary case 2047-10-27 01:59:59} {detroit y2038} {
    clock format 2455768799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.490 {time zone boundary case 2047-10-27 01:00:00} {detroit y2038} {
    clock format 2455768800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.491 {time zone boundary case 2047-10-27 01:00:01} {detroit y2038} {
    clock format 2455768801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.492 {time zone boundary case 2048-04-05 01:59:59} {detroit y2038} {
    clock format 2469682799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.493 {time zone boundary case 2048-04-05 03:00:00} {detroit y2038} {
    clock format 2469682800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.494 {time zone boundary case 2048-04-05 03:00:01} {detroit y2038} {
    clock format 2469682801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.495 {time zone boundary case 2048-10-25 01:59:59} {detroit y2038} {
    clock format 2487218399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.496 {time zone boundary case 2048-10-25 01:00:00} {detroit y2038} {
    clock format 2487218400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.497 {time zone boundary case 2048-10-25 01:00:01} {detroit y2038} {
    clock format 2487218401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.498 {time zone boundary case 2049-04-04 01:59:59} {detroit y2038} {
    clock format 2501132399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.499 {time zone boundary case 2049-04-04 03:00:00} {detroit y2038} {
    clock format 2501132400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.500 {time zone boundary case 2049-04-04 03:00:01} {detroit y2038} {
    clock format 2501132401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.501 {time zone boundary case 2049-10-31 01:59:59} {detroit y2038} {
    clock format 2519272799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.502 {time zone boundary case 2049-10-31 01:00:00} {detroit y2038} {
    clock format 2519272800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.503 {time zone boundary case 2049-10-31 01:00:01} {detroit y2038} {
    clock format 2519272801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.504 {time zone boundary case 2050-04-03 01:59:59} {detroit y2038} {
    clock format 2532581999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.505 {time zone boundary case 2050-04-03 03:00:00} {detroit y2038} {
    clock format 2532582000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.506 {time zone boundary case 2050-04-03 03:00:01} {detroit y2038} {
    clock format 2532582001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.507 {time zone boundary case 2050-10-30 01:59:59} {detroit y2038} {
    clock format 2550722399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.508 {time zone boundary case 2050-10-30 01:00:00} {detroit y2038} {
    clock format 2550722400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.509 {time zone boundary case 2050-10-30 01:00:01} {detroit y2038} {
    clock format 2550722401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.510 {time zone boundary case 2051-04-02 01:59:59} {detroit y2038} {
    clock format 2564031599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.511 {time zone boundary case 2051-04-02 03:00:00} {detroit y2038} {
    clock format 2564031600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.512 {time zone boundary case 2051-04-02 03:00:01} {detroit y2038} {
    clock format 2564031601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.513 {time zone boundary case 2051-10-29 01:59:59} {detroit y2038} {
    clock format 2582171999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.514 {time zone boundary case 2051-10-29 01:00:00} {detroit y2038} {
    clock format 2582172000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.515 {time zone boundary case 2051-10-29 01:00:01} {detroit y2038} {
    clock format 2582172001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.516 {time zone boundary case 2052-04-07 01:59:59} {detroit y2038} {
    clock format 2596085999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.517 {time zone boundary case 2052-04-07 03:00:00} {detroit y2038} {
    clock format 2596086000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.518 {time zone boundary case 2052-04-07 03:00:01} {detroit y2038} {
    clock format 2596086001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.519 {time zone boundary case 2052-10-27 01:59:59} {detroit y2038} {
    clock format 2613621599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.520 {time zone boundary case 2052-10-27 01:00:00} {detroit y2038} {
    clock format 2613621600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.521 {time zone boundary case 2052-10-27 01:00:01} {detroit y2038} {
    clock format 2613621601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.522 {time zone boundary case 2053-04-06 01:59:59} {detroit y2038} {
    clock format 2627535599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.523 {time zone boundary case 2053-04-06 03:00:00} {detroit y2038} {
    clock format 2627535600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.524 {time zone boundary case 2053-04-06 03:00:01} {detroit y2038} {
    clock format 2627535601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.525 {time zone boundary case 2053-10-26 01:59:59} {detroit y2038} {
    clock format 2645071199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.526 {time zone boundary case 2053-10-26 01:00:00} {detroit y2038} {
    clock format 2645071200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.527 {time zone boundary case 2053-10-26 01:00:01} {detroit y2038} {
    clock format 2645071201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.528 {time zone boundary case 2054-04-05 01:59:59} {detroit y2038} {
    clock format 2658985199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.529 {time zone boundary case 2054-04-05 03:00:00} {detroit y2038} {
    clock format 2658985200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.530 {time zone boundary case 2054-04-05 03:00:01} {detroit y2038} {
    clock format 2658985201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.531 {time zone boundary case 2054-10-25 01:59:59} {detroit y2038} {
    clock format 2676520799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.532 {time zone boundary case 2054-10-25 01:00:00} {detroit y2038} {
    clock format 2676520800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.533 {time zone boundary case 2054-10-25 01:00:01} {detroit y2038} {
    clock format 2676520801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.534 {time zone boundary case 2055-04-04 01:59:59} {detroit y2038} {
    clock format 2690434799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.535 {time zone boundary case 2055-04-04 03:00:00} {detroit y2038} {
    clock format 2690434800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.536 {time zone boundary case 2055-04-04 03:00:01} {detroit y2038} {
    clock format 2690434801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.537 {time zone boundary case 2055-10-31 01:59:59} {detroit y2038} {
    clock format 2708575199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.538 {time zone boundary case 2055-10-31 01:00:00} {detroit y2038} {
    clock format 2708575200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.539 {time zone boundary case 2055-10-31 01:00:01} {detroit y2038} {
    clock format 2708575201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.540 {time zone boundary case 2056-04-02 01:59:59} {detroit y2038} {
    clock format 2721884399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.541 {time zone boundary case 2056-04-02 03:00:00} {detroit y2038} {
    clock format 2721884400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.542 {time zone boundary case 2056-04-02 03:00:01} {detroit y2038} {
    clock format 2721884401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.543 {time zone boundary case 2056-10-29 01:59:59} {detroit y2038} {
    clock format 2740024799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.544 {time zone boundary case 2056-10-29 01:00:00} {detroit y2038} {
    clock format 2740024800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.545 {time zone boundary case 2056-10-29 01:00:01} {detroit y2038} {
    clock format 2740024801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.546 {time zone boundary case 2057-04-01 01:59:59} {detroit y2038} {
    clock format 2753333999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.547 {time zone boundary case 2057-04-01 03:00:00} {detroit y2038} {
    clock format 2753334000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.548 {time zone boundary case 2057-04-01 03:00:01} {detroit y2038} {
    clock format 2753334001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.549 {time zone boundary case 2057-10-28 01:59:59} {detroit y2038} {
    clock format 2771474399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.550 {time zone boundary case 2057-10-28 01:00:00} {detroit y2038} {
    clock format 2771474400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.551 {time zone boundary case 2057-10-28 01:00:01} {detroit y2038} {
    clock format 2771474401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.552 {time zone boundary case 2058-04-07 01:59:59} {detroit y2038} {
    clock format 2785388399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.553 {time zone boundary case 2058-04-07 03:00:00} {detroit y2038} {
    clock format 2785388400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.554 {time zone boundary case 2058-04-07 03:00:01} {detroit y2038} {
    clock format 2785388401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.555 {time zone boundary case 2058-10-27 01:59:59} {detroit y2038} {
    clock format 2802923999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.556 {time zone boundary case 2058-10-27 01:00:00} {detroit y2038} {
    clock format 2802924000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.557 {time zone boundary case 2058-10-27 01:00:01} {detroit y2038} {
    clock format 2802924001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.558 {time zone boundary case 2059-04-06 01:59:59} {detroit y2038} {
    clock format 2816837999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.559 {time zone boundary case 2059-04-06 03:00:00} {detroit y2038} {
    clock format 2816838000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.560 {time zone boundary case 2059-04-06 03:00:01} {detroit y2038} {
    clock format 2816838001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.561 {time zone boundary case 2059-10-26 01:59:59} {detroit y2038} {
    clock format 2834373599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.562 {time zone boundary case 2059-10-26 01:00:00} {detroit y2038} {
    clock format 2834373600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.563 {time zone boundary case 2059-10-26 01:00:01} {detroit y2038} {
    clock format 2834373601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.564 {time zone boundary case 2060-04-04 01:59:59} {detroit y2038} {
    clock format 2848287599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.565 {time zone boundary case 2060-04-04 03:00:00} {detroit y2038} {
    clock format 2848287600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.566 {time zone boundary case 2060-04-04 03:00:01} {detroit y2038} {
    clock format 2848287601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.567 {time zone boundary case 2060-10-31 01:59:59} {detroit y2038} {
    clock format 2866427999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.568 {time zone boundary case 2060-10-31 01:00:00} {detroit y2038} {
    clock format 2866428000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.569 {time zone boundary case 2060-10-31 01:00:01} {detroit y2038} {
    clock format 2866428001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.570 {time zone boundary case 2061-04-03 01:59:59} {detroit y2038} {
    clock format 2879737199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.571 {time zone boundary case 2061-04-03 03:00:00} {detroit y2038} {
    clock format 2879737200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.572 {time zone boundary case 2061-04-03 03:00:01} {detroit y2038} {
    clock format 2879737201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.573 {time zone boundary case 2061-10-30 01:59:59} {detroit y2038} {
    clock format 2897877599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.574 {time zone boundary case 2061-10-30 01:00:00} {detroit y2038} {
    clock format 2897877600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.575 {time zone boundary case 2061-10-30 01:00:01} {detroit y2038} {
    clock format 2897877601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.576 {time zone boundary case 2062-04-02 01:59:59} {detroit y2038} {
    clock format 2911186799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.577 {time zone boundary case 2062-04-02 03:00:00} {detroit y2038} {
    clock format 2911186800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.578 {time zone boundary case 2062-04-02 03:00:01} {detroit y2038} {
    clock format 2911186801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.579 {time zone boundary case 2062-10-29 01:59:59} {detroit y2038} {
    clock format 2929327199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.580 {time zone boundary case 2062-10-29 01:00:00} {detroit y2038} {
    clock format 2929327200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.581 {time zone boundary case 2062-10-29 01:00:01} {detroit y2038} {
    clock format 2929327201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.582 {time zone boundary case 2063-04-01 01:59:59} {detroit y2038} {
    clock format 2942636399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.583 {time zone boundary case 2063-04-01 03:00:00} {detroit y2038} {
    clock format 2942636400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.584 {time zone boundary case 2063-04-01 03:00:01} {detroit y2038} {
    clock format 2942636401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.585 {time zone boundary case 2063-10-28 01:59:59} {detroit y2038} {
    clock format 2960776799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.586 {time zone boundary case 2063-10-28 01:00:00} {detroit y2038} {
    clock format 2960776800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.587 {time zone boundary case 2063-10-28 01:00:01} {detroit y2038} {
    clock format 2960776801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.588 {time zone boundary case 2064-04-06 01:59:59} {detroit y2038} {
    clock format 2974690799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.589 {time zone boundary case 2064-04-06 03:00:00} {detroit y2038} {
    clock format 2974690800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.590 {time zone boundary case 2064-04-06 03:00:01} {detroit y2038} {
    clock format 2974690801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.591 {time zone boundary case 2064-10-26 01:59:59} {detroit y2038} {
    clock format 2992226399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.592 {time zone boundary case 2064-10-26 01:00:00} {detroit y2038} {
    clock format 2992226400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.593 {time zone boundary case 2064-10-26 01:00:01} {detroit y2038} {
    clock format 2992226401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.594 {time zone boundary case 2065-04-05 01:59:59} {detroit y2038} {
    clock format 3006140399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.595 {time zone boundary case 2065-04-05 03:00:00} {detroit y2038} {
    clock format 3006140400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.596 {time zone boundary case 2065-04-05 03:00:01} {detroit y2038} {
    clock format 3006140401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.597 {time zone boundary case 2065-10-25 01:59:59} {detroit y2038} {
    clock format 3023675999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.598 {time zone boundary case 2065-10-25 01:00:00} {detroit y2038} {
    clock format 3023676000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.599 {time zone boundary case 2065-10-25 01:00:01} {detroit y2038} {
    clock format 3023676001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.600 {time zone boundary case 2066-04-04 01:59:59} {detroit y2038} {
    clock format 3037589999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.601 {time zone boundary case 2066-04-04 03:00:00} {detroit y2038} {
    clock format 3037590000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.602 {time zone boundary case 2066-04-04 03:00:01} {detroit y2038} {
    clock format 3037590001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.603 {time zone boundary case 2066-10-31 01:59:59} {detroit y2038} {
    clock format 3055730399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.604 {time zone boundary case 2066-10-31 01:00:00} {detroit y2038} {
    clock format 3055730400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.605 {time zone boundary case 2066-10-31 01:00:01} {detroit y2038} {
    clock format 3055730401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.606 {time zone boundary case 2067-04-03 01:59:59} {detroit y2038} {
    clock format 3069039599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.607 {time zone boundary case 2067-04-03 03:00:00} {detroit y2038} {
    clock format 3069039600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.608 {time zone boundary case 2067-04-03 03:00:01} {detroit y2038} {
    clock format 3069039601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.609 {time zone boundary case 2067-10-30 01:59:59} {detroit y2038} {
    clock format 3087179999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.610 {time zone boundary case 2067-10-30 01:00:00} {detroit y2038} {
    clock format 3087180000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.611 {time zone boundary case 2067-10-30 01:00:01} {detroit y2038} {
    clock format 3087180001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.612 {time zone boundary case 2068-04-01 01:59:59} {detroit y2038} {
    clock format 3100489199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.613 {time zone boundary case 2068-04-01 03:00:00} {detroit y2038} {
    clock format 3100489200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.614 {time zone boundary case 2068-04-01 03:00:01} {detroit y2038} {
    clock format 3100489201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.615 {time zone boundary case 2068-10-28 01:59:59} {detroit y2038} {
    clock format 3118629599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.616 {time zone boundary case 2068-10-28 01:00:00} {detroit y2038} {
    clock format 3118629600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.617 {time zone boundary case 2068-10-28 01:00:01} {detroit y2038} {
    clock format 3118629601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.618 {time zone boundary case 2069-04-07 01:59:59} {detroit y2038} {
    clock format 3132543599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.619 {time zone boundary case 2069-04-07 03:00:00} {detroit y2038} {
    clock format 3132543600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.620 {time zone boundary case 2069-04-07 03:00:01} {detroit y2038} {
    clock format 3132543601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.621 {time zone boundary case 2069-10-27 01:59:59} {detroit y2038} {
    clock format 3150079199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.622 {time zone boundary case 2069-10-27 01:00:00} {detroit y2038} {
    clock format 3150079200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.623 {time zone boundary case 2069-10-27 01:00:01} {detroit y2038} {
    clock format 3150079201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.624 {time zone boundary case 2070-04-06 01:59:59} {detroit y2038} {
    clock format 3163993199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.625 {time zone boundary case 2070-04-06 03:00:00} {detroit y2038} {
    clock format 3163993200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.626 {time zone boundary case 2070-04-06 03:00:01} {detroit y2038} {
    clock format 3163993201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.627 {time zone boundary case 2070-10-26 01:59:59} {detroit y2038} {
    clock format 3181528799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.628 {time zone boundary case 2070-10-26 01:00:00} {detroit y2038} {
    clock format 3181528800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.629 {time zone boundary case 2070-10-26 01:00:01} {detroit y2038} {
    clock format 3181528801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.630 {time zone boundary case 2071-04-05 01:59:59} {detroit y2038} {
    clock format 3195442799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.631 {time zone boundary case 2071-04-05 03:00:00} {detroit y2038} {
    clock format 3195442800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.632 {time zone boundary case 2071-04-05 03:00:01} {detroit y2038} {
    clock format 3195442801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.633 {time zone boundary case 2071-10-25 01:59:59} {detroit y2038} {
    clock format 3212978399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.634 {time zone boundary case 2071-10-25 01:00:00} {detroit y2038} {
    clock format 3212978400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.635 {time zone boundary case 2071-10-25 01:00:01} {detroit y2038} {
    clock format 3212978401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.636 {time zone boundary case 2072-04-03 01:59:59} {detroit y2038} {
    clock format 3226892399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.637 {time zone boundary case 2072-04-03 03:00:00} {detroit y2038} {
    clock format 3226892400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.638 {time zone boundary case 2072-04-03 03:00:01} {detroit y2038} {
    clock format 3226892401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.639 {time zone boundary case 2072-10-30 01:59:59} {detroit y2038} {
    clock format 3245032799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.640 {time zone boundary case 2072-10-30 01:00:00} {detroit y2038} {
    clock format 3245032800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.641 {time zone boundary case 2072-10-30 01:00:01} {detroit y2038} {
    clock format 3245032801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.642 {time zone boundary case 2073-04-02 01:59:59} {detroit y2038} {
    clock format 3258341999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.643 {time zone boundary case 2073-04-02 03:00:00} {detroit y2038} {
    clock format 3258342000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.644 {time zone boundary case 2073-04-02 03:00:01} {detroit y2038} {
    clock format 3258342001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.645 {time zone boundary case 2073-10-29 01:59:59} {detroit y2038} {
    clock format 3276482399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.646 {time zone boundary case 2073-10-29 01:00:00} {detroit y2038} {
    clock format 3276482400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.647 {time zone boundary case 2073-10-29 01:00:01} {detroit y2038} {
    clock format 3276482401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.648 {time zone boundary case 2074-04-01 01:59:59} {detroit y2038} {
    clock format 3289791599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.649 {time zone boundary case 2074-04-01 03:00:00} {detroit y2038} {
    clock format 3289791600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.650 {time zone boundary case 2074-04-01 03:00:01} {detroit y2038} {
    clock format 3289791601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.651 {time zone boundary case 2074-10-28 01:59:59} {detroit y2038} {
    clock format 3307931999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.652 {time zone boundary case 2074-10-28 01:00:00} {detroit y2038} {
    clock format 3307932000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.653 {time zone boundary case 2074-10-28 01:00:01} {detroit y2038} {
    clock format 3307932001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.654 {time zone boundary case 2075-04-07 01:59:59} {detroit y2038} {
    clock format 3321845999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.655 {time zone boundary case 2075-04-07 03:00:00} {detroit y2038} {
    clock format 3321846000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.656 {time zone boundary case 2075-04-07 03:00:01} {detroit y2038} {
    clock format 3321846001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.657 {time zone boundary case 2075-10-27 01:59:59} {detroit y2038} {
    clock format 3339381599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.658 {time zone boundary case 2075-10-27 01:00:00} {detroit y2038} {
    clock format 3339381600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.659 {time zone boundary case 2075-10-27 01:00:01} {detroit y2038} {
    clock format 3339381601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.660 {time zone boundary case 2076-04-05 01:59:59} {detroit y2038} {
    clock format 3353295599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.661 {time zone boundary case 2076-04-05 03:00:00} {detroit y2038} {
    clock format 3353295600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.662 {time zone boundary case 2076-04-05 03:00:01} {detroit y2038} {
    clock format 3353295601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.663 {time zone boundary case 2076-10-25 01:59:59} {detroit y2038} {
    clock format 3370831199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.664 {time zone boundary case 2076-10-25 01:00:00} {detroit y2038} {
    clock format 3370831200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.665 {time zone boundary case 2076-10-25 01:00:01} {detroit y2038} {
    clock format 3370831201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.666 {time zone boundary case 2077-04-04 01:59:59} {detroit y2038} {
    clock format 3384745199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.667 {time zone boundary case 2077-04-04 03:00:00} {detroit y2038} {
    clock format 3384745200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.668 {time zone boundary case 2077-04-04 03:00:01} {detroit y2038} {
    clock format 3384745201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.669 {time zone boundary case 2077-10-31 01:59:59} {detroit y2038} {
    clock format 3402885599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.670 {time zone boundary case 2077-10-31 01:00:00} {detroit y2038} {
    clock format 3402885600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.671 {time zone boundary case 2077-10-31 01:00:01} {detroit y2038} {
    clock format 3402885601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.672 {time zone boundary case 2078-04-03 01:59:59} {detroit y2038} {
    clock format 3416194799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.673 {time zone boundary case 2078-04-03 03:00:00} {detroit y2038} {
    clock format 3416194800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.674 {time zone boundary case 2078-04-03 03:00:01} {detroit y2038} {
    clock format 3416194801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.675 {time zone boundary case 2078-10-30 01:59:59} {detroit y2038} {
    clock format 3434335199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.676 {time zone boundary case 2078-10-30 01:00:00} {detroit y2038} {
    clock format 3434335200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.677 {time zone boundary case 2078-10-30 01:00:01} {detroit y2038} {
    clock format 3434335201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.678 {time zone boundary case 2079-04-02 01:59:59} {detroit y2038} {
    clock format 3447644399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.679 {time zone boundary case 2079-04-02 03:00:00} {detroit y2038} {
    clock format 3447644400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.680 {time zone boundary case 2079-04-02 03:00:01} {detroit y2038} {
    clock format 3447644401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.681 {time zone boundary case 2079-10-29 01:59:59} {detroit y2038} {
    clock format 3465784799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.682 {time zone boundary case 2079-10-29 01:00:00} {detroit y2038} {
    clock format 3465784800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.683 {time zone boundary case 2079-10-29 01:00:01} {detroit y2038} {
    clock format 3465784801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.684 {time zone boundary case 2080-04-07 01:59:59} {detroit y2038} {
    clock format 3479698799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.685 {time zone boundary case 2080-04-07 03:00:00} {detroit y2038} {
    clock format 3479698800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.686 {time zone boundary case 2080-04-07 03:00:01} {detroit y2038} {
    clock format 3479698801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.687 {time zone boundary case 2080-10-27 01:59:59} {detroit y2038} {
    clock format 3497234399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.688 {time zone boundary case 2080-10-27 01:00:00} {detroit y2038} {
    clock format 3497234400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.689 {time zone boundary case 2080-10-27 01:00:01} {detroit y2038} {
    clock format 3497234401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.690 {time zone boundary case 2081-04-06 01:59:59} {detroit y2038} {
    clock format 3511148399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.691 {time zone boundary case 2081-04-06 03:00:00} {detroit y2038} {
    clock format 3511148400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.692 {time zone boundary case 2081-04-06 03:00:01} {detroit y2038} {
    clock format 3511148401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.693 {time zone boundary case 2081-10-26 01:59:59} {detroit y2038} {
    clock format 3528683999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.694 {time zone boundary case 2081-10-26 01:00:00} {detroit y2038} {
    clock format 3528684000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.695 {time zone boundary case 2081-10-26 01:00:01} {detroit y2038} {
    clock format 3528684001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.696 {time zone boundary case 2082-04-05 01:59:59} {detroit y2038} {
    clock format 3542597999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.697 {time zone boundary case 2082-04-05 03:00:00} {detroit y2038} {
    clock format 3542598000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.698 {time zone boundary case 2082-04-05 03:00:01} {detroit y2038} {
    clock format 3542598001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.699 {time zone boundary case 2082-10-25 01:59:59} {detroit y2038} {
    clock format 3560133599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.700 {time zone boundary case 2082-10-25 01:00:00} {detroit y2038} {
    clock format 3560133600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.701 {time zone boundary case 2082-10-25 01:00:01} {detroit y2038} {
    clock format 3560133601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.702 {time zone boundary case 2083-04-04 01:59:59} {detroit y2038} {
    clock format 3574047599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.703 {time zone boundary case 2083-04-04 03:00:00} {detroit y2038} {
    clock format 3574047600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.704 {time zone boundary case 2083-04-04 03:00:01} {detroit y2038} {
    clock format 3574047601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.705 {time zone boundary case 2083-10-31 01:59:59} {detroit y2038} {
    clock format 3592187999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.706 {time zone boundary case 2083-10-31 01:00:00} {detroit y2038} {
    clock format 3592188000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.707 {time zone boundary case 2083-10-31 01:00:01} {detroit y2038} {
    clock format 3592188001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.708 {time zone boundary case 2084-04-02 01:59:59} {detroit y2038} {
    clock format 3605497199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.709 {time zone boundary case 2084-04-02 03:00:00} {detroit y2038} {
    clock format 3605497200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.710 {time zone boundary case 2084-04-02 03:00:01} {detroit y2038} {
    clock format 3605497201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.711 {time zone boundary case 2084-10-29 01:59:59} {detroit y2038} {
    clock format 3623637599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.712 {time zone boundary case 2084-10-29 01:00:00} {detroit y2038} {
    clock format 3623637600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.713 {time zone boundary case 2084-10-29 01:00:01} {detroit y2038} {
    clock format 3623637601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.714 {time zone boundary case 2085-04-01 01:59:59} {detroit y2038} {
    clock format 3636946799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.715 {time zone boundary case 2085-04-01 03:00:00} {detroit y2038} {
    clock format 3636946800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.716 {time zone boundary case 2085-04-01 03:00:01} {detroit y2038} {
    clock format 3636946801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.717 {time zone boundary case 2085-10-28 01:59:59} {detroit y2038} {
    clock format 3655087199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.718 {time zone boundary case 2085-10-28 01:00:00} {detroit y2038} {
    clock format 3655087200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.719 {time zone boundary case 2085-10-28 01:00:01} {detroit y2038} {
    clock format 3655087201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.720 {time zone boundary case 2086-04-07 01:59:59} {detroit y2038} {
    clock format 3669001199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.721 {time zone boundary case 2086-04-07 03:00:00} {detroit y2038} {
    clock format 3669001200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.722 {time zone boundary case 2086-04-07 03:00:01} {detroit y2038} {
    clock format 3669001201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.723 {time zone boundary case 2086-10-27 01:59:59} {detroit y2038} {
    clock format 3686536799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.724 {time zone boundary case 2086-10-27 01:00:00} {detroit y2038} {
    clock format 3686536800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.725 {time zone boundary case 2086-10-27 01:00:01} {detroit y2038} {
    clock format 3686536801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.726 {time zone boundary case 2087-04-06 01:59:59} {detroit y2038} {
    clock format 3700450799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.727 {time zone boundary case 2087-04-06 03:00:00} {detroit y2038} {
    clock format 3700450800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.728 {time zone boundary case 2087-04-06 03:00:01} {detroit y2038} {
    clock format 3700450801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.729 {time zone boundary case 2087-10-26 01:59:59} {detroit y2038} {
    clock format 3717986399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.730 {time zone boundary case 2087-10-26 01:00:00} {detroit y2038} {
    clock format 3717986400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.731 {time zone boundary case 2087-10-26 01:00:01} {detroit y2038} {
    clock format 3717986401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.732 {time zone boundary case 2088-04-04 01:59:59} {detroit y2038} {
    clock format 3731900399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.733 {time zone boundary case 2088-04-04 03:00:00} {detroit y2038} {
    clock format 3731900400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.734 {time zone boundary case 2088-04-04 03:00:01} {detroit y2038} {
    clock format 3731900401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.735 {time zone boundary case 2088-10-31 01:59:59} {detroit y2038} {
    clock format 3750040799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.736 {time zone boundary case 2088-10-31 01:00:00} {detroit y2038} {
    clock format 3750040800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.737 {time zone boundary case 2088-10-31 01:00:01} {detroit y2038} {
    clock format 3750040801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.738 {time zone boundary case 2089-04-03 01:59:59} {detroit y2038} {
    clock format 3763349999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.739 {time zone boundary case 2089-04-03 03:00:00} {detroit y2038} {
    clock format 3763350000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.740 {time zone boundary case 2089-04-03 03:00:01} {detroit y2038} {
    clock format 3763350001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.741 {time zone boundary case 2089-10-30 01:59:59} {detroit y2038} {
    clock format 3781490399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.742 {time zone boundary case 2089-10-30 01:00:00} {detroit y2038} {
    clock format 3781490400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.743 {time zone boundary case 2089-10-30 01:00:01} {detroit y2038} {
    clock format 3781490401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.744 {time zone boundary case 2090-04-02 01:59:59} {detroit y2038} {
    clock format 3794799599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.745 {time zone boundary case 2090-04-02 03:00:00} {detroit y2038} {
    clock format 3794799600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.746 {time zone boundary case 2090-04-02 03:00:01} {detroit y2038} {
    clock format 3794799601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.747 {time zone boundary case 2090-10-29 01:59:59} {detroit y2038} {
    clock format 3812939999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.748 {time zone boundary case 2090-10-29 01:00:00} {detroit y2038} {
    clock format 3812940000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.749 {time zone boundary case 2090-10-29 01:00:01} {detroit y2038} {
    clock format 3812940001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.750 {time zone boundary case 2091-04-01 01:59:59} {detroit y2038} {
    clock format 3826249199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.751 {time zone boundary case 2091-04-01 03:00:00} {detroit y2038} {
    clock format 3826249200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.752 {time zone boundary case 2091-04-01 03:00:01} {detroit y2038} {
    clock format 3826249201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.753 {time zone boundary case 2091-10-28 01:59:59} {detroit y2038} {
    clock format 3844389599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.754 {time zone boundary case 2091-10-28 01:00:00} {detroit y2038} {
    clock format 3844389600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.755 {time zone boundary case 2091-10-28 01:00:01} {detroit y2038} {
    clock format 3844389601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.756 {time zone boundary case 2092-04-06 01:59:59} {detroit y2038} {
    clock format 3858303599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.757 {time zone boundary case 2092-04-06 03:00:00} {detroit y2038} {
    clock format 3858303600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.758 {time zone boundary case 2092-04-06 03:00:01} {detroit y2038} {
    clock format 3858303601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.759 {time zone boundary case 2092-10-26 01:59:59} {detroit y2038} {
    clock format 3875839199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.760 {time zone boundary case 2092-10-26 01:00:00} {detroit y2038} {
    clock format 3875839200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.761 {time zone boundary case 2092-10-26 01:00:01} {detroit y2038} {
    clock format 3875839201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.762 {time zone boundary case 2093-04-05 01:59:59} {detroit y2038} {
    clock format 3889753199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.763 {time zone boundary case 2093-04-05 03:00:00} {detroit y2038} {
    clock format 3889753200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.764 {time zone boundary case 2093-04-05 03:00:01} {detroit y2038} {
    clock format 3889753201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.765 {time zone boundary case 2093-10-25 01:59:59} {detroit y2038} {
    clock format 3907288799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.766 {time zone boundary case 2093-10-25 01:00:00} {detroit y2038} {
    clock format 3907288800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.767 {time zone boundary case 2093-10-25 01:00:01} {detroit y2038} {
    clock format 3907288801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.768 {time zone boundary case 2094-04-04 01:59:59} {detroit y2038} {
    clock format 3921202799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.769 {time zone boundary case 2094-04-04 03:00:00} {detroit y2038} {
    clock format 3921202800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.770 {time zone boundary case 2094-04-04 03:00:01} {detroit y2038} {
    clock format 3921202801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.771 {time zone boundary case 2094-10-31 01:59:59} {detroit y2038} {
    clock format 3939343199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.772 {time zone boundary case 2094-10-31 01:00:00} {detroit y2038} {
    clock format 3939343200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.773 {time zone boundary case 2094-10-31 01:00:01} {detroit y2038} {
    clock format 3939343201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.774 {time zone boundary case 2095-04-03 01:59:59} {detroit y2038} {
    clock format 3952652399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.775 {time zone boundary case 2095-04-03 03:00:00} {detroit y2038} {
    clock format 3952652400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.776 {time zone boundary case 2095-04-03 03:00:01} {detroit y2038} {
    clock format 3952652401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.777 {time zone boundary case 2095-10-30 01:59:59} {detroit y2038} {
    clock format 3970792799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.778 {time zone boundary case 2095-10-30 01:00:00} {detroit y2038} {
    clock format 3970792800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.779 {time zone boundary case 2095-10-30 01:00:01} {detroit y2038} {
    clock format 3970792801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.780 {time zone boundary case 2096-04-01 01:59:59} {detroit y2038} {
    clock format 3984101999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.781 {time zone boundary case 2096-04-01 03:00:00} {detroit y2038} {
    clock format 3984102000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.782 {time zone boundary case 2096-04-01 03:00:01} {detroit y2038} {
    clock format 3984102001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.783 {time zone boundary case 2096-10-28 01:59:59} {detroit y2038} {
    clock format 4002242399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.784 {time zone boundary case 2096-10-28 01:00:00} {detroit y2038} {
    clock format 4002242400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.785 {time zone boundary case 2096-10-28 01:00:01} {detroit y2038} {
    clock format 4002242401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.786 {time zone boundary case 2097-04-07 01:59:59} {detroit y2038} {
    clock format 4016156399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.787 {time zone boundary case 2097-04-07 03:00:00} {detroit y2038} {
    clock format 4016156400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.788 {time zone boundary case 2097-04-07 03:00:01} {detroit y2038} {
    clock format 4016156401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.789 {time zone boundary case 2097-10-27 01:59:59} {detroit y2038} {
    clock format 4033691999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.790 {time zone boundary case 2097-10-27 01:00:00} {detroit y2038} {
    clock format 4033692000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.791 {time zone boundary case 2097-10-27 01:00:01} {detroit y2038} {
    clock format 4033692001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.792 {time zone boundary case 2098-04-06 01:59:59} {detroit y2038} {
    clock format 4047605999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.793 {time zone boundary case 2098-04-06 03:00:00} {detroit y2038} {
    clock format 4047606000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.794 {time zone boundary case 2098-04-06 03:00:01} {detroit y2038} {
    clock format 4047606001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.795 {time zone boundary case 2098-10-26 01:59:59} {detroit y2038} {
    clock format 4065141599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.796 {time zone boundary case 2098-10-26 01:00:00} {detroit y2038} {
    clock format 4065141600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.797 {time zone boundary case 2098-10-26 01:00:01} {detroit y2038} {
    clock format 4065141601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.798 {time zone boundary case 2099-04-05 01:59:59} {detroit y2038} {
    clock format 4079055599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.799 {time zone boundary case 2099-04-05 03:00:00} {detroit y2038} {
    clock format 4079055600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.800 {time zone boundary case 2099-04-05 03:00:01} {detroit y2038} {
    clock format 4079055601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.801 {time zone boundary case 2099-10-25 01:59:59} {detroit y2038} {
    clock format 4096591199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.802 {time zone boundary case 2099-10-25 01:00:00} {detroit y2038} {
    clock format 4096591200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.803 {time zone boundary case 2099-10-25 01:00:01} {detroit y2038} {
    clock format 4096591201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
# END testcases5

# Test input conversions.

test clock-6.0 {input of seconds} {







|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|


|
|







15758
15759
15760
15761
15762
15763
15764
15765
15766
15767
15768
15769
15770
15771
15772
15773
15774
15775
15776
15777
15778
15779
15780
15781
15782
15783
15784
15785
15786
15787
15788
15789
15790
15791
15792
15793
15794
15795
15796
15797
15798
15799
15800
15801
15802
15803
15804
15805
15806
15807
15808
15809
15810
15811
15812
15813
15814
15815
15816
15817
15818
15819
15820
15821
15822
15823
15824
15825
15826
15827
15828
15829
15830
15831
15832
15833
15834
15835
15836
15837
15838
15839
15840
15841
15842
15843
15844
15845
15846
15847
15848
15849
15850
15851
15852
15853
15854
15855
15856
15857
15858
15859
15860
15861
15862
15863
15864
15865
15866
15867
15868
15869
15870
15871
15872
15873
15874
15875
15876
15877
15878
15879
15880
15881
15882
15883
15884
15885
15886
15887
15888
15889
15890
15891
15892
15893
15894
15895
15896
15897
15898
15899
15900
15901
15902
15903
15904
15905
15906
15907
15908
15909
15910
15911
15912
15913
15914
15915
15916
15917
15918
15919
15920
15921
15922
15923
15924
15925
15926
15927
15928
15929
15930
15931
15932
15933
15934
15935
15936
15937
15938
15939
15940
15941
15942
15943
15944
15945
15946
15947
15948
15949
15950
15951
15952
15953
15954
15955
15956
15957
15958
15959
15960
15961
15962
15963
15964
15965
15966
15967
15968
15969
15970
15971
15972
15973
15974
15975
15976
15977
15978
15979
15980
15981
15982
15983
15984
15985
15986
15987
15988
15989
15990
15991
15992
15993
15994
15995
15996
15997
15998
15999
16000
16001
16002
16003
16004
16005
16006
16007
16008
16009
16010
16011
16012
16013
16014
16015
16016
16017
16018
16019
16020
16021
16022
16023
16024
16025
16026
16027
16028
16029
16030
16031
16032
16033
16034
16035
16036
16037
16038
16039
16040
16041
16042
16043
16044
16045
16046
16047
16048
16049
16050
16051
16052
16053
16054
16055
16056
16057
16058
16059
16060
16061
16062
16063
16064
16065
16066
16067
16068
16069
16070
16071
16072
16073
16074
16075
16076
16077
16078
16079
16080
16081
16082
16083
16084
16085
16086
16087
16088
16089
16090
16091
16092
16093
16094
16095
16096
16097
16098
16099
16100
16101
16102
16103
16104
16105
16106
16107
16108
16109
16110
16111
16112
16113
16114
16115
16116
16117
16118
16119
16120
16121
16122
16123
16124
16125
16126
16127
16128
16129
16130
16131
16132
16133
16134
16135
16136
16137
16138
16139
16140
16141
16142
16143
16144
16145
16146
16147
16148
16149
16150
16151
16152
16153
16154
16155
16156
16157
16158
16159
16160
16161
16162
16163
16164
16165
16166
16167
16168
16169
16170
16171
16172
16173
16174
16175
16176
16177
16178
16179
16180
16181
16182
16183
16184
16185
16186
16187
16188
16189
16190
16191
16192
16193
16194
16195
16196
16197
16198
16199
16200
16201
16202
16203
16204
16205
16206
16207
16208
16209
16210
16211
16212
16213
16214
16215
16216
16217
16218
16219
16220
16221
16222
16223
16224
16225
16226
16227
16228
16229
16230
16231
16232
16233
16234
16235
16236
16237
16238
16239
16240
16241
16242
16243
16244
16245
16246
16247
16248
16249
16250
16251
16252
16253
16254
16255
16256
16257
16258
16259
16260
16261
16262
16263
16264
16265
16266
16267
16268
16269
16270
16271
16272
16273
16274
16275
16276
16277
16278
16279
16280
16281
16282
16283
16284
16285
16286
16287
16288
16289
16290
16291
16292
16293
16294
16295
16296
16297
16298
16299
16300
16301
16302
16303
16304
16305
16306
16307
16308
16309
16310
16311
16312
16313
16314
16315
16316
16317
16318
16319
16320
16321
16322
16323
16324
16325
16326
16327
16328
16329
16330
16331
16332
16333
16334
16335
16336
16337
16338
16339
16340
16341
16342
16343
16344
16345
16346
16347
16348
16349
16350
16351
16352
16353
16354
16355
16356
16357
16358
16359
16360
16361
16362
16363
16364
16365
16366
16367
16368
16369
16370
16371
16372
16373
16374
16375
16376
16377
16378
16379
16380
16381
16382
16383
16384
16385
16386
16387
16388
16389
16390
16391
16392
16393
16394
16395
16396
16397
16398
16399
16400
16401
16402
16403
16404
16405
16406
16407
16408
16409
16410
16411
16412
16413
16414
16415
16416
16417
16418
16419
16420
16421
16422
16423
16424
16425
16426
16427
16428
16429
16430
16431
16432
16433
16434
16435
16436
16437
16438
16439
16440
16441
16442
16443
16444
16445
16446
16447
16448
16449
16450
16451
16452
16453
16454
16455
16456
16457
16458
16459
16460
16461
16462
16463
16464
16465
16466
16467
16468
16469
16470
16471
16472
16473
16474
16475
16476
16477
16478
16479
16480
16481
16482
16483
16484
16485
16486
16487
16488
16489
16490
16491
16492
16493
16494
16495
16496
16497
16498
16499
16500
16501
16502
16503
16504
16505
16506
16507
16508
16509
16510
16511
16512
16513
16514
16515
16516
16517
16518
16519
16520
16521
16522
16523
16524
16525
16526
16527
16528
16529
16530
16531
16532
16533
16534
16535
16536
16537
16538
16539
16540
16541
16542
16543
16544
16545
16546
16547
16548
16549
16550
16551
16552
16553
16554
16555
16556
16557
16558
16559
16560
16561
16562
16563
16564
16565
16566
16567
16568
16569
16570
16571
16572
16573
16574
16575
16576
16577
16578
16579
16580
16581
16582
16583
16584
16585
16586
16587
16588
16589
16590
16591
16592
16593
16594
16595
16596
16597
16598
16599
16600
16601
16602
16603
16604
16605
16606
16607
16608
16609
16610
16611
16612
16613
16614
16615
16616
16617
16618
16619
16620
16621
16622
16623
16624
16625
16626
16627
16628
16629
16630
16631
16632
16633
16634
16635
16636
16637
16638
16639
16640
16641
16642
16643
16644
16645
16646
16647
16648
16649
16650
16651
16652
16653
16654
16655
16656
16657
16658
16659
16660
16661
16662
16663
16664
16665
16666
16667
16668
16669
16670
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688
16689
16690
16691
16692
16693
16694
16695
16696
16697
16698
16699
16700
16701
16702
16703
16704
16705
16706
16707
16708
16709
16710
16711
16712
16713
16714
16715
16716
16717
16718
16719
16720
16721
16722
16723
16724
16725
16726
16727
16728
16729
16730
16731
16732
16733
16734
16735
16736
16737
16738
16739
16740
16741
16742
16743
16744
16745
16746
16747
16748
16749
16750
16751
16752
16753
16754
16755
16756
16757
16758
16759
16760
16761
16762
16763
16764
16765
16766
16767
16768
16769
16770
16771
16772
16773
16774
16775
16776
16777
16778
16779
16780
16781
16782
16783
16784
16785
16786
16787
16788
16789
16790
16791
16792
16793
16794
16795
16796
16797
16798
16799
16800
16801
16802
16803
16804
16805
16806
16807
16808
16809
16810
16811
16812
16813
16814
16815
16816
16817
16818
16819
16820
16821
16822
16823
16824
16825
16826
16827
16828
16829
16830
16831
16832
16833
16834
16835
16836
16837
16838
16839
16840
16841
16842
16843
16844
16845
16846
16847
16848
16849
16850
16851
16852
16853
16854
16855
16856
16857
16858
16859
16860
16861
16862
16863
16864
16865
16866
16867
16868
16869
16870
16871
16872
16873
16874
16875
16876
16877
16878
16879
16880
16881
16882
16883
16884
16885
16886
16887
16888
16889
16890
16891
16892
16893
16894
16895
16896
16897
16898
16899
16900
16901
16902
16903
16904
16905
16906
16907
16908
16909
16910
16911
16912
16913
16914
16915
16916
16917
16918
16919
16920
16921
16922
16923
16924
16925
16926
16927
16928
16929
16930
16931
16932
16933
16934
16935
16936
16937
16938
16939
16940
16941
16942
16943
16944
16945
16946
16947
16948
16949
16950
16951
16952
16953
16954
16955
16956
16957
16958
16959
16960
16961
16962
16963
16964
16965
16966
16967
16968
16969
16970
16971
16972
16973
16974
16975
16976
16977
16978
16979
16980
16981
16982
16983
16984
16985
16986
16987
16988
16989
16990
16991
16992
16993
16994
16995
16996
16997
16998
16999
17000
17001
17002
17003
17004
17005
17006
17007
17008
17009
17010
17011
17012
17013
17014
17015
17016
17017
17018
17019
17020
17021
17022
17023
17024
17025
17026
17027
17028
17029
17030
17031
17032
17033
17034
17035
17036
17037
17038
17039
17040
17041
17042
17043
17044
17045
17046
17047
17048
17049
17050
17051
17052
17053
17054
17055
17056
17057
17058
17059
17060
17061
17062
17063
17064
17065
17066
17067
17068
17069
17070
17071
17072
17073
17074
17075
17076
17077
17078
17079
17080
17081
17082
17083
17084
17085
17086
17087
17088
17089
17090
17091
17092
17093
17094
17095
17096
17097
17098
17099
17100
17101
17102
17103
17104
17105
17106
17107
17108
17109
17110
17111
17112
17113
17114
17115
17116
17117
17118
17119
17120
17121
17122
17123
17124
17125
17126
17127
17128
17129
17130
17131
17132
17133
17134
17135
17136
17137
17138
17139
17140
17141
17142
17143
17144
17145
17146
17147
17148
17149
17150
17151
17152
17153
17154
17155
17156
17157
17158
17159
17160
17161
17162
17163
17164
17165
17166
17167
17168
17169
17170
17171
17172
17173
17174
17175
17176
17177
17178
17179
17180
17181
17182
17183
17184
17185
17186
17187
17188
17189
17190
17191
17192
17193
17194
17195
17196
17197
17198
17199
17200
17201
17202
17203
17204
17205
17206
17207
17208
17209
17210
17211
17212
17213
17214
17215
17216
17217
17218
17219
17220
17221
17222
17223
17224
17225
17226
17227
17228
17229
17230
17231
17232
17233
17234
17235
17236
17237
17238
17239
17240
17241
17242
17243
17244
17245
17246
17247
17248
17249
17250
17251
17252
17253
17254
17255
17256
17257
17258
17259
17260
17261
17262
17263
17264
17265
17266
17267
17268
17269
17270
17271
17272
17273
17274
17275
17276
17277
17278
17279
17280
17281
17282
17283
17284
17285
17286
17287
17288
17289
17290
17291
17292
17293
17294
17295
17296
17297
17298
17299
17300
17301
17302
17303
17304
17305
17306
17307
17308
17309
17310
17311
17312
17313
17314
17315
17316
17317
17318
17319
17320
17321
17322
17323
17324
17325
17326
17327
17328
17329
17330
17331
17332
17333
17334
17335
17336
17337
17338
17339
17340
17341
17342
17343
17344
17345
17346
17347
17348
17349
17350
17351
17352
17353
17354
17355
17356
17357
17358
17359
17360
17361
17362
17363
17364
17365
17366
17367
17368
17369
17370
17371
17372
17373
17374
17375
17376
17377
17378
17379
17380
17381
17382
17383
17384
17385
17386
17387
17388
17389
17390
17391
17392
17393
17394
17395
17396
17397
17398
17399
17400
17401
17402
17403
17404
17405
17406
17407
17408
17409
17410
17411
17412
17413
17414
17415
17416
17417
17418
17419
17420
17421
17422
17423
17424
17425
17426
17427
17428
17429
17430
17431
17432
17433
17434
17435
17436
17437
17438
17439
17440
17441
17442
17443
17444
17445
17446
17447
17448
17449
17450
17451
17452
17453
17454
17455
17456
17457
17458
17459
17460
17461
17462
17463
17464
17465
17466
17467
17468
17469
17470
17471
17472
17473
17474
17475
17476
17477
17478
17479
17480
17481
17482
17483
17484
17485
17486
17487
17488
17489
17490
17491
17492
17493
17494
17495
17496
17497
17498
17499
17500
17501
17502
17503
17504
17505
17506
17507
17508
17509
17510
17511
17512
17513
17514
17515
17516
17517
17518
17519
17520
17521
17522
17523
17524
17525
17526
17527
17528
17529
17530
17531
17532
17533
17534
17535
17536
17537
17538
17539
17540
17541
17542
17543
17544
17545
17546
17547
17548
17549
17550
17551
17552
17553
17554
17555
17556
17557
17558
17559
17560
17561
17562
17563
17564
17565
17566
17567
17568
17569
17570
17571
17572
17573
17574
17575
17576
17577
17578
17579
17580
17581
17582
17583
17584
17585
17586
17587
17588
17589
17590
17591
17592
17593
17594
17595
17596
17597
17598
17599
17600
17601
17602
17603
17604
17605
17606
17607
17608
17609
17610
17611
17612
17613
17614
17615
17616
17617
17618
17619
17620
17621
17622
17623
17624
17625
17626
17627
17628
17629
17630
17631
17632
17633
17634
17635
17636
17637
17638
17639
17640
17641
17642
17643
17644
17645
17646
17647
17648
17649
17650
17651
17652
17653
17654
17655
17656
17657
17658
17659
17660
17661
17662
17663
17664
17665
17666
17667
17668
17669
17670
17671
17672
17673
17674
17675
17676
17677
17678
17679
17680
17681
17682
17683
17684
17685
17686
17687
17688
17689
17690
17691
17692
17693
17694
17695
17696
17697
17698
17699
17700
17701
17702
17703
17704
17705
17706
17707
17708
17709
17710
17711
17712
17713
17714
17715
17716
17717
17718
17719
17720
17721
17722
17723
17724
17725
17726
17727
17728
17729
17730
17731
17732
17733
17734
17735
17736
17737
17738
17739
17740
17741
17742
17743
17744
17745
17746
17747
17748
17749
17750
17751
17752
17753
17754
17755
17756
17757
17758
17759
17760
17761
17762
17763
17764
17765
17766
17767
17768
17769
17770
17771
17772
17773
17774
17775
17776
17777
17778
17779
17780
17781
17782
17783
17784
17785
17786
17787
17788
17789
17790
17791
17792
17793
17794
17795
17796
17797
17798
17799
17800
17801
17802
17803
17804
17805
17806
17807
17808
17809
17810
17811
17812
17813
17814
17815
17816
17817
17818
17819
17820
17821
17822
17823
17824
17825
17826
17827
17828
17829
17830
17831
17832
17833
17834
17835
17836
17837
17838
17839
17840
17841
17842
17843
17844
17845
17846
17847
17848
17849
17850
17851
17852
17853
17854
17855
17856
17857
17858
17859
17860
17861
17862
17863
17864
17865
17866
17867
17868
17869
17870
17871
17872
17873
17874
17875
17876
17877
17878
17879
17880
17881
17882
17883
17884
17885
17886
17887
17888
17889
17890
17891
17892
17893
17894
17895
17896
17897
17898
17899
17900
17901
17902
17903
17904
17905
17906
17907
17908
17909
17910
17911
17912
17913
17914
17915
17916
17917
17918
17919
17920
17921
17922
17923
17924
17925
17926
17927
17928
17929
17930
17931
17932
17933
17934
17935
17936
17937
17938
17939
17940
17941
17942
17943
17944
17945
17946
17947
17948
17949
17950
17951
17952
17953
17954
17955
17956
17957
17958
17959
17960
17961
17962
17963
17964
17965
17966
17967
17968
17969
17970
17971
17972
17973
17974
17975
17976
17977
17978
17979
17980
17981
17982
17983
17984
17985
17986
17987
17988
17989
17990
17991
17992
17993
17994
17995
17996
17997
17998
17999
18000
18001
    clock format 1162101600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.245 {time zone boundary case 2006-10-29 01:00:01} detroit {
    clock format 1162101601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.246 {time zone boundary case 2007-03-11 01:59:59} detroit {
    clock format 1173596399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.247 {time zone boundary case 2007-03-11 03:00:00} detroit {
    clock format 1173596400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.248 {time zone boundary case 2007-03-11 03:00:01} detroit {
    clock format 1173596401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.249 {time zone boundary case 2007-11-04 01:59:59} detroit {
    clock format 1194155999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.250 {time zone boundary case 2007-11-04 01:00:00} detroit {
    clock format 1194156000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.251 {time zone boundary case 2007-11-04 01:00:01} detroit {
    clock format 1194156001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.252 {time zone boundary case 2008-03-09 01:59:59} detroit {
    clock format 1205045999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.253 {time zone boundary case 2008-03-09 03:00:00} detroit {
    clock format 1205046000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.254 {time zone boundary case 2008-03-09 03:00:01} detroit {
    clock format 1205046001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.255 {time zone boundary case 2008-11-02 01:59:59} detroit {
    clock format 1225605599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.256 {time zone boundary case 2008-11-02 01:00:00} detroit {
    clock format 1225605600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.257 {time zone boundary case 2008-11-02 01:00:01} detroit {
    clock format 1225605601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.258 {time zone boundary case 2009-03-08 01:59:59} detroit {
    clock format 1236495599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.259 {time zone boundary case 2009-03-08 03:00:00} detroit {
    clock format 1236495600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.260 {time zone boundary case 2009-03-08 03:00:01} detroit {
    clock format 1236495601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.261 {time zone boundary case 2009-11-01 01:59:59} detroit {
    clock format 1257055199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.262 {time zone boundary case 2009-11-01 01:00:00} detroit {
    clock format 1257055200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.263 {time zone boundary case 2009-11-01 01:00:01} detroit {
    clock format 1257055201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.264 {time zone boundary case 2010-03-14 01:59:59} detroit {
    clock format 1268549999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.265 {time zone boundary case 2010-03-14 03:00:00} detroit {
    clock format 1268550000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.266 {time zone boundary case 2010-03-14 03:00:01} detroit {
    clock format 1268550001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.267 {time zone boundary case 2010-11-07 01:59:59} detroit {
    clock format 1289109599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.268 {time zone boundary case 2010-11-07 01:00:00} detroit {
    clock format 1289109600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.269 {time zone boundary case 2010-11-07 01:00:01} detroit {
    clock format 1289109601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.270 {time zone boundary case 2011-03-13 01:59:59} detroit {
    clock format 1299999599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.271 {time zone boundary case 2011-03-13 03:00:00} detroit {
    clock format 1299999600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.272 {time zone boundary case 2011-03-13 03:00:01} detroit {
    clock format 1299999601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.273 {time zone boundary case 2011-11-06 01:59:59} detroit {
    clock format 1320559199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.274 {time zone boundary case 2011-11-06 01:00:00} detroit {
    clock format 1320559200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.275 {time zone boundary case 2011-11-06 01:00:01} detroit {
    clock format 1320559201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.276 {time zone boundary case 2012-03-11 01:59:59} detroit {
    clock format 1331449199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.277 {time zone boundary case 2012-03-11 03:00:00} detroit {
    clock format 1331449200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.278 {time zone boundary case 2012-03-11 03:00:01} detroit {
    clock format 1331449201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.279 {time zone boundary case 2012-11-04 01:59:59} detroit {
    clock format 1352008799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.280 {time zone boundary case 2012-11-04 01:00:00} detroit {
    clock format 1352008800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.281 {time zone boundary case 2012-11-04 01:00:01} detroit {
    clock format 1352008801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.282 {time zone boundary case 2013-03-10 01:59:59} detroit {
    clock format 1362898799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.283 {time zone boundary case 2013-03-10 03:00:00} detroit {
    clock format 1362898800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.284 {time zone boundary case 2013-03-10 03:00:01} detroit {
    clock format 1362898801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.285 {time zone boundary case 2013-11-03 01:59:59} detroit {
    clock format 1383458399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.286 {time zone boundary case 2013-11-03 01:00:00} detroit {
    clock format 1383458400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.287 {time zone boundary case 2013-11-03 01:00:01} detroit {
    clock format 1383458401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.288 {time zone boundary case 2014-03-09 01:59:59} detroit {
    clock format 1394348399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.289 {time zone boundary case 2014-03-09 03:00:00} detroit {
    clock format 1394348400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.290 {time zone boundary case 2014-03-09 03:00:01} detroit {
    clock format 1394348401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.291 {time zone boundary case 2014-11-02 01:59:59} detroit {
    clock format 1414907999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.292 {time zone boundary case 2014-11-02 01:00:00} detroit {
    clock format 1414908000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.293 {time zone boundary case 2014-11-02 01:00:01} detroit {
    clock format 1414908001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.294 {time zone boundary case 2015-03-08 01:59:59} detroit {
    clock format 1425797999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.295 {time zone boundary case 2015-03-08 03:00:00} detroit {
    clock format 1425798000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.296 {time zone boundary case 2015-03-08 03:00:01} detroit {
    clock format 1425798001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.297 {time zone boundary case 2015-11-01 01:59:59} detroit {
    clock format 1446357599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.298 {time zone boundary case 2015-11-01 01:00:00} detroit {
    clock format 1446357600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.299 {time zone boundary case 2015-11-01 01:00:01} detroit {
    clock format 1446357601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.300 {time zone boundary case 2016-03-13 01:59:59} detroit {
    clock format 1457852399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.301 {time zone boundary case 2016-03-13 03:00:00} detroit {
    clock format 1457852400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.302 {time zone boundary case 2016-03-13 03:00:01} detroit {
    clock format 1457852401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.303 {time zone boundary case 2016-11-06 01:59:59} detroit {
    clock format 1478411999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.304 {time zone boundary case 2016-11-06 01:00:00} detroit {
    clock format 1478412000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.305 {time zone boundary case 2016-11-06 01:00:01} detroit {
    clock format 1478412001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.306 {time zone boundary case 2017-03-12 01:59:59} detroit {
    clock format 1489301999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.307 {time zone boundary case 2017-03-12 03:00:00} detroit {
    clock format 1489302000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.308 {time zone boundary case 2017-03-12 03:00:01} detroit {
    clock format 1489302001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.309 {time zone boundary case 2017-11-05 01:59:59} detroit {
    clock format 1509861599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.310 {time zone boundary case 2017-11-05 01:00:00} detroit {
    clock format 1509861600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.311 {time zone boundary case 2017-11-05 01:00:01} detroit {
    clock format 1509861601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.312 {time zone boundary case 2018-03-11 01:59:59} detroit {
    clock format 1520751599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.313 {time zone boundary case 2018-03-11 03:00:00} detroit {
    clock format 1520751600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.314 {time zone boundary case 2018-03-11 03:00:01} detroit {
    clock format 1520751601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.315 {time zone boundary case 2018-11-04 01:59:59} detroit {
    clock format 1541311199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.316 {time zone boundary case 2018-11-04 01:00:00} detroit {
    clock format 1541311200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.317 {time zone boundary case 2018-11-04 01:00:01} detroit {
    clock format 1541311201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.318 {time zone boundary case 2019-03-10 01:59:59} detroit {
    clock format 1552201199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.319 {time zone boundary case 2019-03-10 03:00:00} detroit {
    clock format 1552201200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.320 {time zone boundary case 2019-03-10 03:00:01} detroit {
    clock format 1552201201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.321 {time zone boundary case 2019-11-03 01:59:59} detroit {
    clock format 1572760799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.322 {time zone boundary case 2019-11-03 01:00:00} detroit {
    clock format 1572760800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.323 {time zone boundary case 2019-11-03 01:00:01} detroit {
    clock format 1572760801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.324 {time zone boundary case 2020-03-08 01:59:59} detroit {
    clock format 1583650799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.325 {time zone boundary case 2020-03-08 03:00:00} detroit {
    clock format 1583650800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.326 {time zone boundary case 2020-03-08 03:00:01} detroit {
    clock format 1583650801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.327 {time zone boundary case 2020-11-01 01:59:59} detroit {
    clock format 1604210399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.328 {time zone boundary case 2020-11-01 01:00:00} detroit {
    clock format 1604210400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.329 {time zone boundary case 2020-11-01 01:00:01} detroit {
    clock format 1604210401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.330 {time zone boundary case 2021-03-14 01:59:59} detroit {
    clock format 1615705199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.331 {time zone boundary case 2021-03-14 03:00:00} detroit {
    clock format 1615705200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.332 {time zone boundary case 2021-03-14 03:00:01} detroit {
    clock format 1615705201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.333 {time zone boundary case 2021-11-07 01:59:59} detroit {
    clock format 1636264799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.334 {time zone boundary case 2021-11-07 01:00:00} detroit {
    clock format 1636264800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.335 {time zone boundary case 2021-11-07 01:00:01} detroit {
    clock format 1636264801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.336 {time zone boundary case 2022-03-13 01:59:59} detroit {
    clock format 1647154799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.337 {time zone boundary case 2022-03-13 03:00:00} detroit {
    clock format 1647154800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.338 {time zone boundary case 2022-03-13 03:00:01} detroit {
    clock format 1647154801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.339 {time zone boundary case 2022-11-06 01:59:59} detroit {
    clock format 1667714399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.340 {time zone boundary case 2022-11-06 01:00:00} detroit {
    clock format 1667714400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.341 {time zone boundary case 2022-11-06 01:00:01} detroit {
    clock format 1667714401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.342 {time zone boundary case 2023-03-12 01:59:59} detroit {
    clock format 1678604399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.343 {time zone boundary case 2023-03-12 03:00:00} detroit {
    clock format 1678604400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.344 {time zone boundary case 2023-03-12 03:00:01} detroit {
    clock format 1678604401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.345 {time zone boundary case 2023-11-05 01:59:59} detroit {
    clock format 1699163999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.346 {time zone boundary case 2023-11-05 01:00:00} detroit {
    clock format 1699164000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.347 {time zone boundary case 2023-11-05 01:00:01} detroit {
    clock format 1699164001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.348 {time zone boundary case 2024-03-10 01:59:59} detroit {
    clock format 1710053999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.349 {time zone boundary case 2024-03-10 03:00:00} detroit {
    clock format 1710054000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.350 {time zone boundary case 2024-03-10 03:00:01} detroit {
    clock format 1710054001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.351 {time zone boundary case 2024-11-03 01:59:59} detroit {
    clock format 1730613599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.352 {time zone boundary case 2024-11-03 01:00:00} detroit {
    clock format 1730613600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.353 {time zone boundary case 2024-11-03 01:00:01} detroit {
    clock format 1730613601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.354 {time zone boundary case 2025-03-09 01:59:59} detroit {
    clock format 1741503599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.355 {time zone boundary case 2025-03-09 03:00:00} detroit {
    clock format 1741503600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.356 {time zone boundary case 2025-03-09 03:00:01} detroit {
    clock format 1741503601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.357 {time zone boundary case 2025-11-02 01:59:59} detroit {
    clock format 1762063199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.358 {time zone boundary case 2025-11-02 01:00:00} detroit {
    clock format 1762063200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.359 {time zone boundary case 2025-11-02 01:00:01} detroit {
    clock format 1762063201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.360 {time zone boundary case 2026-03-08 01:59:59} detroit {
    clock format 1772953199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.361 {time zone boundary case 2026-03-08 03:00:00} detroit {
    clock format 1772953200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.362 {time zone boundary case 2026-03-08 03:00:01} detroit {
    clock format 1772953201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.363 {time zone boundary case 2026-11-01 01:59:59} detroit {
    clock format 1793512799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.364 {time zone boundary case 2026-11-01 01:00:00} detroit {
    clock format 1793512800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.365 {time zone boundary case 2026-11-01 01:00:01} detroit {
    clock format 1793512801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.366 {time zone boundary case 2027-03-14 01:59:59} detroit {
    clock format 1805007599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.367 {time zone boundary case 2027-03-14 03:00:00} detroit {
    clock format 1805007600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.368 {time zone boundary case 2027-03-14 03:00:01} detroit {
    clock format 1805007601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.369 {time zone boundary case 2027-11-07 01:59:59} detroit {
    clock format 1825567199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.370 {time zone boundary case 2027-11-07 01:00:00} detroit {
    clock format 1825567200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.371 {time zone boundary case 2027-11-07 01:00:01} detroit {
    clock format 1825567201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.372 {time zone boundary case 2028-03-12 01:59:59} detroit {
    clock format 1836457199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.373 {time zone boundary case 2028-03-12 03:00:00} detroit {
    clock format 1836457200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.374 {time zone boundary case 2028-03-12 03:00:01} detroit {
    clock format 1836457201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.375 {time zone boundary case 2028-11-05 01:59:59} detroit {
    clock format 1857016799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.376 {time zone boundary case 2028-11-05 01:00:00} detroit {
    clock format 1857016800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.377 {time zone boundary case 2028-11-05 01:00:01} detroit {
    clock format 1857016801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.378 {time zone boundary case 2029-03-11 01:59:59} detroit {
    clock format 1867906799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.379 {time zone boundary case 2029-03-11 03:00:00} detroit {
    clock format 1867906800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.380 {time zone boundary case 2029-03-11 03:00:01} detroit {
    clock format 1867906801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.381 {time zone boundary case 2029-11-04 01:59:59} detroit {
    clock format 1888466399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.382 {time zone boundary case 2029-11-04 01:00:00} detroit {
    clock format 1888466400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.383 {time zone boundary case 2029-11-04 01:00:01} detroit {
    clock format 1888466401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.384 {time zone boundary case 2030-03-10 01:59:59} detroit {
    clock format 1899356399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.385 {time zone boundary case 2030-03-10 03:00:00} detroit {
    clock format 1899356400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.386 {time zone boundary case 2030-03-10 03:00:01} detroit {
    clock format 1899356401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.387 {time zone boundary case 2030-11-03 01:59:59} detroit {
    clock format 1919915999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.388 {time zone boundary case 2030-11-03 01:00:00} detroit {
    clock format 1919916000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.389 {time zone boundary case 2030-11-03 01:00:01} detroit {
    clock format 1919916001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.390 {time zone boundary case 2031-03-09 01:59:59} detroit {
    clock format 1930805999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.391 {time zone boundary case 2031-03-09 03:00:00} detroit {
    clock format 1930806000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.392 {time zone boundary case 2031-03-09 03:00:01} detroit {
    clock format 1930806001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.393 {time zone boundary case 2031-11-02 01:59:59} detroit {
    clock format 1951365599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.394 {time zone boundary case 2031-11-02 01:00:00} detroit {
    clock format 1951365600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.395 {time zone boundary case 2031-11-02 01:00:01} detroit {
    clock format 1951365601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.396 {time zone boundary case 2032-03-14 01:59:59} detroit {
    clock format 1962860399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.397 {time zone boundary case 2032-03-14 03:00:00} detroit {
    clock format 1962860400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.398 {time zone boundary case 2032-03-14 03:00:01} detroit {
    clock format 1962860401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.399 {time zone boundary case 2032-11-07 01:59:59} detroit {
    clock format 1983419999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.400 {time zone boundary case 2032-11-07 01:00:00} detroit {
    clock format 1983420000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.401 {time zone boundary case 2032-11-07 01:00:01} detroit {
    clock format 1983420001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.402 {time zone boundary case 2033-03-13 01:59:59} detroit {
    clock format 1994309999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.403 {time zone boundary case 2033-03-13 03:00:00} detroit {
    clock format 1994310000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.404 {time zone boundary case 2033-03-13 03:00:01} detroit {
    clock format 1994310001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.405 {time zone boundary case 2033-11-06 01:59:59} detroit {
    clock format 2014869599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.406 {time zone boundary case 2033-11-06 01:00:00} detroit {
    clock format 2014869600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.407 {time zone boundary case 2033-11-06 01:00:01} detroit {
    clock format 2014869601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.408 {time zone boundary case 2034-03-12 01:59:59} detroit {
    clock format 2025759599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.409 {time zone boundary case 2034-03-12 03:00:00} detroit {
    clock format 2025759600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.410 {time zone boundary case 2034-03-12 03:00:01} detroit {
    clock format 2025759601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.411 {time zone boundary case 2034-11-05 01:59:59} detroit {
    clock format 2046319199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.412 {time zone boundary case 2034-11-05 01:00:00} detroit {
    clock format 2046319200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.413 {time zone boundary case 2034-11-05 01:00:01} detroit {
    clock format 2046319201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.414 {time zone boundary case 2035-03-11 01:59:59} detroit {
    clock format 2057209199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.415 {time zone boundary case 2035-03-11 03:00:00} detroit {
    clock format 2057209200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.416 {time zone boundary case 2035-03-11 03:00:01} detroit {
    clock format 2057209201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.417 {time zone boundary case 2035-11-04 01:59:59} detroit {
    clock format 2077768799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.418 {time zone boundary case 2035-11-04 01:00:00} detroit {
    clock format 2077768800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.419 {time zone boundary case 2035-11-04 01:00:01} detroit {
    clock format 2077768801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.420 {time zone boundary case 2036-03-09 01:59:59} detroit {
    clock format 2088658799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.421 {time zone boundary case 2036-03-09 03:00:00} detroit {
    clock format 2088658800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.422 {time zone boundary case 2036-03-09 03:00:01} detroit {
    clock format 2088658801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.423 {time zone boundary case 2036-11-02 01:59:59} detroit {
    clock format 2109218399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.424 {time zone boundary case 2036-11-02 01:00:00} detroit {
    clock format 2109218400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.425 {time zone boundary case 2036-11-02 01:00:01} detroit {
    clock format 2109218401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.426 {time zone boundary case 2037-03-08 01:59:59} detroit {
    clock format 2120108399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.427 {time zone boundary case 2037-03-08 03:00:00} detroit {
    clock format 2120108400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.428 {time zone boundary case 2037-03-08 03:00:01} detroit {
    clock format 2120108401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.429 {time zone boundary case 2037-11-01 01:59:59} detroit {
    clock format 2140667999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.430 {time zone boundary case 2037-11-01 01:00:00} detroit {
    clock format 2140668000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.431 {time zone boundary case 2037-11-01 01:00:01} detroit {
    clock format 2140668001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.432 {time zone boundary case 2038-03-14 01:59:59} {detroit y2038} {
    clock format 2152162799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.433 {time zone boundary case 2038-03-14 03:00:00} {detroit y2038} {
    clock format 2152162800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.434 {time zone boundary case 2038-03-14 03:00:01} {detroit y2038} {
    clock format 2152162801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.435 {time zone boundary case 2038-11-07 01:59:59} {detroit y2038} {
    clock format 2172722399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.436 {time zone boundary case 2038-11-07 01:00:00} {detroit y2038} {
    clock format 2172722400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.437 {time zone boundary case 2038-11-07 01:00:01} {detroit y2038} {
    clock format 2172722401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.438 {time zone boundary case 2039-03-13 01:59:59} {detroit y2038} {
    clock format 2183612399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.439 {time zone boundary case 2039-03-13 03:00:00} {detroit y2038} {
    clock format 2183612400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.440 {time zone boundary case 2039-03-13 03:00:01} {detroit y2038} {
    clock format 2183612401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.441 {time zone boundary case 2039-11-06 01:59:59} {detroit y2038} {
    clock format 2204171999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.442 {time zone boundary case 2039-11-06 01:00:00} {detroit y2038} {
    clock format 2204172000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.443 {time zone boundary case 2039-11-06 01:00:01} {detroit y2038} {
    clock format 2204172001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.444 {time zone boundary case 2040-03-11 01:59:59} {detroit y2038} {
    clock format 2215061999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.445 {time zone boundary case 2040-03-11 03:00:00} {detroit y2038} {
    clock format 2215062000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.446 {time zone boundary case 2040-03-11 03:00:01} {detroit y2038} {
    clock format 2215062001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.447 {time zone boundary case 2040-11-04 01:59:59} {detroit y2038} {
    clock format 2235621599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.448 {time zone boundary case 2040-11-04 01:00:00} {detroit y2038} {
    clock format 2235621600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.449 {time zone boundary case 2040-11-04 01:00:01} {detroit y2038} {
    clock format 2235621601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.450 {time zone boundary case 2041-03-10 01:59:59} {detroit y2038} {
    clock format 2246511599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.451 {time zone boundary case 2041-03-10 03:00:00} {detroit y2038} {
    clock format 2246511600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.452 {time zone boundary case 2041-03-10 03:00:01} {detroit y2038} {
    clock format 2246511601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.453 {time zone boundary case 2041-11-03 01:59:59} {detroit y2038} {
    clock format 2267071199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.454 {time zone boundary case 2041-11-03 01:00:00} {detroit y2038} {
    clock format 2267071200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.455 {time zone boundary case 2041-11-03 01:00:01} {detroit y2038} {
    clock format 2267071201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.456 {time zone boundary case 2042-03-09 01:59:59} {detroit y2038} {
    clock format 2277961199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.457 {time zone boundary case 2042-03-09 03:00:00} {detroit y2038} {
    clock format 2277961200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.458 {time zone boundary case 2042-03-09 03:00:01} {detroit y2038} {
    clock format 2277961201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.459 {time zone boundary case 2042-11-02 01:59:59} {detroit y2038} {
    clock format 2298520799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.460 {time zone boundary case 2042-11-02 01:00:00} {detroit y2038} {
    clock format 2298520800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.461 {time zone boundary case 2042-11-02 01:00:01} {detroit y2038} {
    clock format 2298520801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.462 {time zone boundary case 2043-03-08 01:59:59} {detroit y2038} {
    clock format 2309410799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.463 {time zone boundary case 2043-03-08 03:00:00} {detroit y2038} {
    clock format 2309410800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.464 {time zone boundary case 2043-03-08 03:00:01} {detroit y2038} {
    clock format 2309410801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.465 {time zone boundary case 2043-11-01 01:59:59} {detroit y2038} {
    clock format 2329970399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.466 {time zone boundary case 2043-11-01 01:00:00} {detroit y2038} {
    clock format 2329970400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.467 {time zone boundary case 2043-11-01 01:00:01} {detroit y2038} {
    clock format 2329970401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.468 {time zone boundary case 2044-03-13 01:59:59} {detroit y2038} {
    clock format 2341465199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.469 {time zone boundary case 2044-03-13 03:00:00} {detroit y2038} {
    clock format 2341465200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.470 {time zone boundary case 2044-03-13 03:00:01} {detroit y2038} {
    clock format 2341465201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.471 {time zone boundary case 2044-11-06 01:59:59} {detroit y2038} {
    clock format 2362024799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.472 {time zone boundary case 2044-11-06 01:00:00} {detroit y2038} {
    clock format 2362024800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.473 {time zone boundary case 2044-11-06 01:00:01} {detroit y2038} {
    clock format 2362024801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.474 {time zone boundary case 2045-03-12 01:59:59} {detroit y2038} {
    clock format 2372914799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.475 {time zone boundary case 2045-03-12 03:00:00} {detroit y2038} {
    clock format 2372914800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.476 {time zone boundary case 2045-03-12 03:00:01} {detroit y2038} {
    clock format 2372914801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.477 {time zone boundary case 2045-11-05 01:59:59} {detroit y2038} {
    clock format 2393474399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.478 {time zone boundary case 2045-11-05 01:00:00} {detroit y2038} {
    clock format 2393474400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.479 {time zone boundary case 2045-11-05 01:00:01} {detroit y2038} {
    clock format 2393474401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.480 {time zone boundary case 2046-03-11 01:59:59} {detroit y2038} {
    clock format 2404364399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.481 {time zone boundary case 2046-03-11 03:00:00} {detroit y2038} {
    clock format 2404364400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.482 {time zone boundary case 2046-03-11 03:00:01} {detroit y2038} {
    clock format 2404364401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.483 {time zone boundary case 2046-11-04 01:59:59} {detroit y2038} {
    clock format 2424923999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.484 {time zone boundary case 2046-11-04 01:00:00} {detroit y2038} {
    clock format 2424924000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.485 {time zone boundary case 2046-11-04 01:00:01} {detroit y2038} {
    clock format 2424924001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.486 {time zone boundary case 2047-03-10 01:59:59} {detroit y2038} {
    clock format 2435813999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.487 {time zone boundary case 2047-03-10 03:00:00} {detroit y2038} {
    clock format 2435814000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.488 {time zone boundary case 2047-03-10 03:00:01} {detroit y2038} {
    clock format 2435814001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.489 {time zone boundary case 2047-11-03 01:59:59} {detroit y2038} {
    clock format 2456373599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.490 {time zone boundary case 2047-11-03 01:00:00} {detroit y2038} {
    clock format 2456373600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.491 {time zone boundary case 2047-11-03 01:00:01} {detroit y2038} {
    clock format 2456373601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.492 {time zone boundary case 2048-03-08 01:59:59} {detroit y2038} {
    clock format 2467263599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.493 {time zone boundary case 2048-03-08 03:00:00} {detroit y2038} {
    clock format 2467263600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.494 {time zone boundary case 2048-03-08 03:00:01} {detroit y2038} {
    clock format 2467263601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.495 {time zone boundary case 2048-11-01 01:59:59} {detroit y2038} {
    clock format 2487823199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.496 {time zone boundary case 2048-11-01 01:00:00} {detroit y2038} {
    clock format 2487823200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.497 {time zone boundary case 2048-11-01 01:00:01} {detroit y2038} {
    clock format 2487823201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.498 {time zone boundary case 2049-03-14 01:59:59} {detroit y2038} {
    clock format 2499317999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.499 {time zone boundary case 2049-03-14 03:00:00} {detroit y2038} {
    clock format 2499318000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.500 {time zone boundary case 2049-03-14 03:00:01} {detroit y2038} {
    clock format 2499318001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.501 {time zone boundary case 2049-11-07 01:59:59} {detroit y2038} {
    clock format 2519877599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.502 {time zone boundary case 2049-11-07 01:00:00} {detroit y2038} {
    clock format 2519877600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.503 {time zone boundary case 2049-11-07 01:00:01} {detroit y2038} {
    clock format 2519877601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.504 {time zone boundary case 2050-03-13 01:59:59} {detroit y2038} {
    clock format 2530767599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.505 {time zone boundary case 2050-03-13 03:00:00} {detroit y2038} {
    clock format 2530767600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.506 {time zone boundary case 2050-03-13 03:00:01} {detroit y2038} {
    clock format 2530767601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.507 {time zone boundary case 2050-11-06 01:59:59} {detroit y2038} {
    clock format 2551327199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.508 {time zone boundary case 2050-11-06 01:00:00} {detroit y2038} {
    clock format 2551327200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.509 {time zone boundary case 2050-11-06 01:00:01} {detroit y2038} {
    clock format 2551327201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.510 {time zone boundary case 2051-03-12 01:59:59} {detroit y2038} {
    clock format 2562217199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.511 {time zone boundary case 2051-03-12 03:00:00} {detroit y2038} {
    clock format 2562217200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.512 {time zone boundary case 2051-03-12 03:00:01} {detroit y2038} {
    clock format 2562217201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.513 {time zone boundary case 2051-11-05 01:59:59} {detroit y2038} {
    clock format 2582776799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.514 {time zone boundary case 2051-11-05 01:00:00} {detroit y2038} {
    clock format 2582776800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.515 {time zone boundary case 2051-11-05 01:00:01} {detroit y2038} {
    clock format 2582776801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.516 {time zone boundary case 2052-03-10 01:59:59} {detroit y2038} {
    clock format 2593666799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.517 {time zone boundary case 2052-03-10 03:00:00} {detroit y2038} {
    clock format 2593666800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.518 {time zone boundary case 2052-03-10 03:00:01} {detroit y2038} {
    clock format 2593666801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.519 {time zone boundary case 2052-11-03 01:59:59} {detroit y2038} {
    clock format 2614226399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.520 {time zone boundary case 2052-11-03 01:00:00} {detroit y2038} {
    clock format 2614226400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.521 {time zone boundary case 2052-11-03 01:00:01} {detroit y2038} {
    clock format 2614226401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.522 {time zone boundary case 2053-03-09 01:59:59} {detroit y2038} {
    clock format 2625116399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.523 {time zone boundary case 2053-03-09 03:00:00} {detroit y2038} {
    clock format 2625116400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.524 {time zone boundary case 2053-03-09 03:00:01} {detroit y2038} {
    clock format 2625116401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.525 {time zone boundary case 2053-11-02 01:59:59} {detroit y2038} {
    clock format 2645675999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.526 {time zone boundary case 2053-11-02 01:00:00} {detroit y2038} {
    clock format 2645676000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.527 {time zone boundary case 2053-11-02 01:00:01} {detroit y2038} {
    clock format 2645676001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.528 {time zone boundary case 2054-03-08 01:59:59} {detroit y2038} {
    clock format 2656565999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.529 {time zone boundary case 2054-03-08 03:00:00} {detroit y2038} {
    clock format 2656566000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.530 {time zone boundary case 2054-03-08 03:00:01} {detroit y2038} {
    clock format 2656566001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.531 {time zone boundary case 2054-11-01 01:59:59} {detroit y2038} {
    clock format 2677125599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.532 {time zone boundary case 2054-11-01 01:00:00} {detroit y2038} {
    clock format 2677125600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.533 {time zone boundary case 2054-11-01 01:00:01} {detroit y2038} {
    clock format 2677125601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.534 {time zone boundary case 2055-03-14 01:59:59} {detroit y2038} {
    clock format 2688620399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.535 {time zone boundary case 2055-03-14 03:00:00} {detroit y2038} {
    clock format 2688620400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.536 {time zone boundary case 2055-03-14 03:00:01} {detroit y2038} {
    clock format 2688620401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.537 {time zone boundary case 2055-11-07 01:59:59} {detroit y2038} {
    clock format 2709179999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.538 {time zone boundary case 2055-11-07 01:00:00} {detroit y2038} {
    clock format 2709180000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.539 {time zone boundary case 2055-11-07 01:00:01} {detroit y2038} {
    clock format 2709180001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.540 {time zone boundary case 2056-03-12 01:59:59} {detroit y2038} {
    clock format 2720069999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.541 {time zone boundary case 2056-03-12 03:00:00} {detroit y2038} {
    clock format 2720070000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.542 {time zone boundary case 2056-03-12 03:00:01} {detroit y2038} {
    clock format 2720070001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.543 {time zone boundary case 2056-11-05 01:59:59} {detroit y2038} {
    clock format 2740629599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.544 {time zone boundary case 2056-11-05 01:00:00} {detroit y2038} {
    clock format 2740629600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.545 {time zone boundary case 2056-11-05 01:00:01} {detroit y2038} {
    clock format 2740629601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.546 {time zone boundary case 2057-03-11 01:59:59} {detroit y2038} {
    clock format 2751519599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.547 {time zone boundary case 2057-03-11 03:00:00} {detroit y2038} {
    clock format 2751519600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.548 {time zone boundary case 2057-03-11 03:00:01} {detroit y2038} {
    clock format 2751519601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.549 {time zone boundary case 2057-11-04 01:59:59} {detroit y2038} {
    clock format 2772079199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.550 {time zone boundary case 2057-11-04 01:00:00} {detroit y2038} {
    clock format 2772079200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.551 {time zone boundary case 2057-11-04 01:00:01} {detroit y2038} {
    clock format 2772079201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.552 {time zone boundary case 2058-03-10 01:59:59} {detroit y2038} {
    clock format 2782969199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.553 {time zone boundary case 2058-03-10 03:00:00} {detroit y2038} {
    clock format 2782969200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.554 {time zone boundary case 2058-03-10 03:00:01} {detroit y2038} {
    clock format 2782969201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.555 {time zone boundary case 2058-11-03 01:59:59} {detroit y2038} {
    clock format 2803528799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.556 {time zone boundary case 2058-11-03 01:00:00} {detroit y2038} {
    clock format 2803528800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.557 {time zone boundary case 2058-11-03 01:00:01} {detroit y2038} {
    clock format 2803528801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.558 {time zone boundary case 2059-03-09 01:59:59} {detroit y2038} {
    clock format 2814418799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.559 {time zone boundary case 2059-03-09 03:00:00} {detroit y2038} {
    clock format 2814418800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.560 {time zone boundary case 2059-03-09 03:00:01} {detroit y2038} {
    clock format 2814418801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.561 {time zone boundary case 2059-11-02 01:59:59} {detroit y2038} {
    clock format 2834978399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.562 {time zone boundary case 2059-11-02 01:00:00} {detroit y2038} {
    clock format 2834978400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.563 {time zone boundary case 2059-11-02 01:00:01} {detroit y2038} {
    clock format 2834978401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.564 {time zone boundary case 2060-03-14 01:59:59} {detroit y2038} {
    clock format 2846473199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.565 {time zone boundary case 2060-03-14 03:00:00} {detroit y2038} {
    clock format 2846473200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.566 {time zone boundary case 2060-03-14 03:00:01} {detroit y2038} {
    clock format 2846473201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.567 {time zone boundary case 2060-11-07 01:59:59} {detroit y2038} {
    clock format 2867032799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.568 {time zone boundary case 2060-11-07 01:00:00} {detroit y2038} {
    clock format 2867032800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.569 {time zone boundary case 2060-11-07 01:00:01} {detroit y2038} {
    clock format 2867032801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.570 {time zone boundary case 2061-03-13 01:59:59} {detroit y2038} {
    clock format 2877922799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.571 {time zone boundary case 2061-03-13 03:00:00} {detroit y2038} {
    clock format 2877922800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.572 {time zone boundary case 2061-03-13 03:00:01} {detroit y2038} {
    clock format 2877922801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.573 {time zone boundary case 2061-11-06 01:59:59} {detroit y2038} {
    clock format 2898482399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.574 {time zone boundary case 2061-11-06 01:00:00} {detroit y2038} {
    clock format 2898482400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.575 {time zone boundary case 2061-11-06 01:00:01} {detroit y2038} {
    clock format 2898482401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.576 {time zone boundary case 2062-03-12 01:59:59} {detroit y2038} {
    clock format 2909372399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.577 {time zone boundary case 2062-03-12 03:00:00} {detroit y2038} {
    clock format 2909372400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.578 {time zone boundary case 2062-03-12 03:00:01} {detroit y2038} {
    clock format 2909372401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.579 {time zone boundary case 2062-11-05 01:59:59} {detroit y2038} {
    clock format 2929931999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.580 {time zone boundary case 2062-11-05 01:00:00} {detroit y2038} {
    clock format 2929932000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.581 {time zone boundary case 2062-11-05 01:00:01} {detroit y2038} {
    clock format 2929932001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.582 {time zone boundary case 2063-03-11 01:59:59} {detroit y2038} {
    clock format 2940821999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.583 {time zone boundary case 2063-03-11 03:00:00} {detroit y2038} {
    clock format 2940822000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.584 {time zone boundary case 2063-03-11 03:00:01} {detroit y2038} {
    clock format 2940822001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.585 {time zone boundary case 2063-11-04 01:59:59} {detroit y2038} {
    clock format 2961381599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.586 {time zone boundary case 2063-11-04 01:00:00} {detroit y2038} {
    clock format 2961381600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.587 {time zone boundary case 2063-11-04 01:00:01} {detroit y2038} {
    clock format 2961381601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.588 {time zone boundary case 2064-03-09 01:59:59} {detroit y2038} {
    clock format 2972271599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.589 {time zone boundary case 2064-03-09 03:00:00} {detroit y2038} {
    clock format 2972271600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.590 {time zone boundary case 2064-03-09 03:00:01} {detroit y2038} {
    clock format 2972271601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.591 {time zone boundary case 2064-11-02 01:59:59} {detroit y2038} {
    clock format 2992831199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.592 {time zone boundary case 2064-11-02 01:00:00} {detroit y2038} {
    clock format 2992831200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.593 {time zone boundary case 2064-11-02 01:00:01} {detroit y2038} {
    clock format 2992831201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.594 {time zone boundary case 2065-03-08 01:59:59} {detroit y2038} {
    clock format 3003721199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.595 {time zone boundary case 2065-03-08 03:00:00} {detroit y2038} {
    clock format 3003721200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.596 {time zone boundary case 2065-03-08 03:00:01} {detroit y2038} {
    clock format 3003721201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.597 {time zone boundary case 2065-11-01 01:59:59} {detroit y2038} {
    clock format 3024280799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.598 {time zone boundary case 2065-11-01 01:00:00} {detroit y2038} {
    clock format 3024280800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.599 {time zone boundary case 2065-11-01 01:00:01} {detroit y2038} {
    clock format 3024280801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.600 {time zone boundary case 2066-03-14 01:59:59} {detroit y2038} {
    clock format 3035775599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.601 {time zone boundary case 2066-03-14 03:00:00} {detroit y2038} {
    clock format 3035775600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.602 {time zone boundary case 2066-03-14 03:00:01} {detroit y2038} {
    clock format 3035775601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.603 {time zone boundary case 2066-11-07 01:59:59} {detroit y2038} {
    clock format 3056335199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.604 {time zone boundary case 2066-11-07 01:00:00} {detroit y2038} {
    clock format 3056335200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.605 {time zone boundary case 2066-11-07 01:00:01} {detroit y2038} {
    clock format 3056335201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.606 {time zone boundary case 2067-03-13 01:59:59} {detroit y2038} {
    clock format 3067225199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.607 {time zone boundary case 2067-03-13 03:00:00} {detroit y2038} {
    clock format 3067225200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.608 {time zone boundary case 2067-03-13 03:00:01} {detroit y2038} {
    clock format 3067225201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.609 {time zone boundary case 2067-11-06 01:59:59} {detroit y2038} {
    clock format 3087784799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.610 {time zone boundary case 2067-11-06 01:00:00} {detroit y2038} {
    clock format 3087784800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.611 {time zone boundary case 2067-11-06 01:00:01} {detroit y2038} {
    clock format 3087784801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.612 {time zone boundary case 2068-03-11 01:59:59} {detroit y2038} {
    clock format 3098674799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.613 {time zone boundary case 2068-03-11 03:00:00} {detroit y2038} {
    clock format 3098674800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.614 {time zone boundary case 2068-03-11 03:00:01} {detroit y2038} {
    clock format 3098674801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.615 {time zone boundary case 2068-11-04 01:59:59} {detroit y2038} {
    clock format 3119234399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.616 {time zone boundary case 2068-11-04 01:00:00} {detroit y2038} {
    clock format 3119234400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.617 {time zone boundary case 2068-11-04 01:00:01} {detroit y2038} {
    clock format 3119234401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.618 {time zone boundary case 2069-03-10 01:59:59} {detroit y2038} {
    clock format 3130124399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.619 {time zone boundary case 2069-03-10 03:00:00} {detroit y2038} {
    clock format 3130124400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.620 {time zone boundary case 2069-03-10 03:00:01} {detroit y2038} {
    clock format 3130124401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.621 {time zone boundary case 2069-11-03 01:59:59} {detroit y2038} {
    clock format 3150683999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.622 {time zone boundary case 2069-11-03 01:00:00} {detroit y2038} {
    clock format 3150684000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.623 {time zone boundary case 2069-11-03 01:00:01} {detroit y2038} {
    clock format 3150684001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.624 {time zone boundary case 2070-03-09 01:59:59} {detroit y2038} {
    clock format 3161573999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.625 {time zone boundary case 2070-03-09 03:00:00} {detroit y2038} {
    clock format 3161574000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.626 {time zone boundary case 2070-03-09 03:00:01} {detroit y2038} {
    clock format 3161574001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.627 {time zone boundary case 2070-11-02 01:59:59} {detroit y2038} {
    clock format 3182133599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.628 {time zone boundary case 2070-11-02 01:00:00} {detroit y2038} {
    clock format 3182133600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.629 {time zone boundary case 2070-11-02 01:00:01} {detroit y2038} {
    clock format 3182133601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.630 {time zone boundary case 2071-03-08 01:59:59} {detroit y2038} {
    clock format 3193023599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.631 {time zone boundary case 2071-03-08 03:00:00} {detroit y2038} {
    clock format 3193023600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.632 {time zone boundary case 2071-03-08 03:00:01} {detroit y2038} {
    clock format 3193023601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.633 {time zone boundary case 2071-11-01 01:59:59} {detroit y2038} {
    clock format 3213583199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.634 {time zone boundary case 2071-11-01 01:00:00} {detroit y2038} {
    clock format 3213583200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.635 {time zone boundary case 2071-11-01 01:00:01} {detroit y2038} {
    clock format 3213583201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.636 {time zone boundary case 2072-03-13 01:59:59} {detroit y2038} {
    clock format 3225077999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.637 {time zone boundary case 2072-03-13 03:00:00} {detroit y2038} {
    clock format 3225078000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.638 {time zone boundary case 2072-03-13 03:00:01} {detroit y2038} {
    clock format 3225078001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.639 {time zone boundary case 2072-11-06 01:59:59} {detroit y2038} {
    clock format 3245637599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.640 {time zone boundary case 2072-11-06 01:00:00} {detroit y2038} {
    clock format 3245637600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.641 {time zone boundary case 2072-11-06 01:00:01} {detroit y2038} {
    clock format 3245637601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.642 {time zone boundary case 2073-03-12 01:59:59} {detroit y2038} {
    clock format 3256527599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.643 {time zone boundary case 2073-03-12 03:00:00} {detroit y2038} {
    clock format 3256527600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.644 {time zone boundary case 2073-03-12 03:00:01} {detroit y2038} {
    clock format 3256527601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.645 {time zone boundary case 2073-11-05 01:59:59} {detroit y2038} {
    clock format 3277087199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.646 {time zone boundary case 2073-11-05 01:00:00} {detroit y2038} {
    clock format 3277087200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.647 {time zone boundary case 2073-11-05 01:00:01} {detroit y2038} {
    clock format 3277087201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.648 {time zone boundary case 2074-03-11 01:59:59} {detroit y2038} {
    clock format 3287977199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.649 {time zone boundary case 2074-03-11 03:00:00} {detroit y2038} {
    clock format 3287977200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.650 {time zone boundary case 2074-03-11 03:00:01} {detroit y2038} {
    clock format 3287977201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.651 {time zone boundary case 2074-11-04 01:59:59} {detroit y2038} {
    clock format 3308536799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.652 {time zone boundary case 2074-11-04 01:00:00} {detroit y2038} {
    clock format 3308536800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.653 {time zone boundary case 2074-11-04 01:00:01} {detroit y2038} {
    clock format 3308536801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.654 {time zone boundary case 2075-03-10 01:59:59} {detroit y2038} {
    clock format 3319426799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.655 {time zone boundary case 2075-03-10 03:00:00} {detroit y2038} {
    clock format 3319426800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.656 {time zone boundary case 2075-03-10 03:00:01} {detroit y2038} {
    clock format 3319426801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.657 {time zone boundary case 2075-11-03 01:59:59} {detroit y2038} {
    clock format 3339986399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.658 {time zone boundary case 2075-11-03 01:00:00} {detroit y2038} {
    clock format 3339986400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.659 {time zone boundary case 2075-11-03 01:00:01} {detroit y2038} {
    clock format 3339986401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.660 {time zone boundary case 2076-03-08 01:59:59} {detroit y2038} {
    clock format 3350876399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.661 {time zone boundary case 2076-03-08 03:00:00} {detroit y2038} {
    clock format 3350876400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.662 {time zone boundary case 2076-03-08 03:00:01} {detroit y2038} {
    clock format 3350876401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.663 {time zone boundary case 2076-11-01 01:59:59} {detroit y2038} {
    clock format 3371435999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.664 {time zone boundary case 2076-11-01 01:00:00} {detroit y2038} {
    clock format 3371436000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.665 {time zone boundary case 2076-11-01 01:00:01} {detroit y2038} {
    clock format 3371436001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.666 {time zone boundary case 2077-03-14 01:59:59} {detroit y2038} {
    clock format 3382930799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.667 {time zone boundary case 2077-03-14 03:00:00} {detroit y2038} {
    clock format 3382930800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.668 {time zone boundary case 2077-03-14 03:00:01} {detroit y2038} {
    clock format 3382930801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.669 {time zone boundary case 2077-11-07 01:59:59} {detroit y2038} {
    clock format 3403490399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.670 {time zone boundary case 2077-11-07 01:00:00} {detroit y2038} {
    clock format 3403490400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.671 {time zone boundary case 2077-11-07 01:00:01} {detroit y2038} {
    clock format 3403490401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.672 {time zone boundary case 2078-03-13 01:59:59} {detroit y2038} {
    clock format 3414380399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.673 {time zone boundary case 2078-03-13 03:00:00} {detroit y2038} {
    clock format 3414380400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.674 {time zone boundary case 2078-03-13 03:00:01} {detroit y2038} {
    clock format 3414380401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.675 {time zone boundary case 2078-11-06 01:59:59} {detroit y2038} {
    clock format 3434939999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.676 {time zone boundary case 2078-11-06 01:00:00} {detroit y2038} {
    clock format 3434940000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.677 {time zone boundary case 2078-11-06 01:00:01} {detroit y2038} {
    clock format 3434940001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.678 {time zone boundary case 2079-03-12 01:59:59} {detroit y2038} {
    clock format 3445829999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.679 {time zone boundary case 2079-03-12 03:00:00} {detroit y2038} {
    clock format 3445830000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.680 {time zone boundary case 2079-03-12 03:00:01} {detroit y2038} {
    clock format 3445830001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.681 {time zone boundary case 2079-11-05 01:59:59} {detroit y2038} {
    clock format 3466389599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.682 {time zone boundary case 2079-11-05 01:00:00} {detroit y2038} {
    clock format 3466389600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.683 {time zone boundary case 2079-11-05 01:00:01} {detroit y2038} {
    clock format 3466389601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.684 {time zone boundary case 2080-03-10 01:59:59} {detroit y2038} {
    clock format 3477279599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.685 {time zone boundary case 2080-03-10 03:00:00} {detroit y2038} {
    clock format 3477279600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.686 {time zone boundary case 2080-03-10 03:00:01} {detroit y2038} {
    clock format 3477279601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.687 {time zone boundary case 2080-11-03 01:59:59} {detroit y2038} {
    clock format 3497839199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.688 {time zone boundary case 2080-11-03 01:00:00} {detroit y2038} {
    clock format 3497839200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.689 {time zone boundary case 2080-11-03 01:00:01} {detroit y2038} {
    clock format 3497839201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.690 {time zone boundary case 2081-03-09 01:59:59} {detroit y2038} {
    clock format 3508729199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.691 {time zone boundary case 2081-03-09 03:00:00} {detroit y2038} {
    clock format 3508729200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.692 {time zone boundary case 2081-03-09 03:00:01} {detroit y2038} {
    clock format 3508729201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.693 {time zone boundary case 2081-11-02 01:59:59} {detroit y2038} {
    clock format 3529288799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.694 {time zone boundary case 2081-11-02 01:00:00} {detroit y2038} {
    clock format 3529288800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.695 {time zone boundary case 2081-11-02 01:00:01} {detroit y2038} {
    clock format 3529288801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.696 {time zone boundary case 2082-03-08 01:59:59} {detroit y2038} {
    clock format 3540178799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.697 {time zone boundary case 2082-03-08 03:00:00} {detroit y2038} {
    clock format 3540178800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.698 {time zone boundary case 2082-03-08 03:00:01} {detroit y2038} {
    clock format 3540178801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.699 {time zone boundary case 2082-11-01 01:59:59} {detroit y2038} {
    clock format 3560738399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.700 {time zone boundary case 2082-11-01 01:00:00} {detroit y2038} {
    clock format 3560738400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.701 {time zone boundary case 2082-11-01 01:00:01} {detroit y2038} {
    clock format 3560738401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.702 {time zone boundary case 2083-03-14 01:59:59} {detroit y2038} {
    clock format 3572233199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.703 {time zone boundary case 2083-03-14 03:00:00} {detroit y2038} {
    clock format 3572233200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.704 {time zone boundary case 2083-03-14 03:00:01} {detroit y2038} {
    clock format 3572233201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.705 {time zone boundary case 2083-11-07 01:59:59} {detroit y2038} {
    clock format 3592792799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.706 {time zone boundary case 2083-11-07 01:00:00} {detroit y2038} {
    clock format 3592792800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.707 {time zone boundary case 2083-11-07 01:00:01} {detroit y2038} {
    clock format 3592792801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.708 {time zone boundary case 2084-03-12 01:59:59} {detroit y2038} {
    clock format 3603682799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.709 {time zone boundary case 2084-03-12 03:00:00} {detroit y2038} {
    clock format 3603682800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.710 {time zone boundary case 2084-03-12 03:00:01} {detroit y2038} {
    clock format 3603682801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.711 {time zone boundary case 2084-11-05 01:59:59} {detroit y2038} {
    clock format 3624242399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.712 {time zone boundary case 2084-11-05 01:00:00} {detroit y2038} {
    clock format 3624242400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.713 {time zone boundary case 2084-11-05 01:00:01} {detroit y2038} {
    clock format 3624242401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.714 {time zone boundary case 2085-03-11 01:59:59} {detroit y2038} {
    clock format 3635132399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.715 {time zone boundary case 2085-03-11 03:00:00} {detroit y2038} {
    clock format 3635132400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.716 {time zone boundary case 2085-03-11 03:00:01} {detroit y2038} {
    clock format 3635132401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.717 {time zone boundary case 2085-11-04 01:59:59} {detroit y2038} {
    clock format 3655691999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.718 {time zone boundary case 2085-11-04 01:00:00} {detroit y2038} {
    clock format 3655692000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.719 {time zone boundary case 2085-11-04 01:00:01} {detroit y2038} {
    clock format 3655692001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.720 {time zone boundary case 2086-03-10 01:59:59} {detroit y2038} {
    clock format 3666581999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.721 {time zone boundary case 2086-03-10 03:00:00} {detroit y2038} {
    clock format 3666582000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.722 {time zone boundary case 2086-03-10 03:00:01} {detroit y2038} {
    clock format 3666582001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.723 {time zone boundary case 2086-11-03 01:59:59} {detroit y2038} {
    clock format 3687141599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.724 {time zone boundary case 2086-11-03 01:00:00} {detroit y2038} {
    clock format 3687141600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.725 {time zone boundary case 2086-11-03 01:00:01} {detroit y2038} {
    clock format 3687141601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.726 {time zone boundary case 2087-03-09 01:59:59} {detroit y2038} {
    clock format 3698031599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.727 {time zone boundary case 2087-03-09 03:00:00} {detroit y2038} {
    clock format 3698031600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.728 {time zone boundary case 2087-03-09 03:00:01} {detroit y2038} {
    clock format 3698031601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.729 {time zone boundary case 2087-11-02 01:59:59} {detroit y2038} {
    clock format 3718591199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.730 {time zone boundary case 2087-11-02 01:00:00} {detroit y2038} {
    clock format 3718591200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.731 {time zone boundary case 2087-11-02 01:00:01} {detroit y2038} {
    clock format 3718591201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.732 {time zone boundary case 2088-03-14 01:59:59} {detroit y2038} {
    clock format 3730085999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.733 {time zone boundary case 2088-03-14 03:00:00} {detroit y2038} {
    clock format 3730086000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.734 {time zone boundary case 2088-03-14 03:00:01} {detroit y2038} {
    clock format 3730086001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.735 {time zone boundary case 2088-11-07 01:59:59} {detroit y2038} {
    clock format 3750645599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.736 {time zone boundary case 2088-11-07 01:00:00} {detroit y2038} {
    clock format 3750645600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.737 {time zone boundary case 2088-11-07 01:00:01} {detroit y2038} {
    clock format 3750645601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.738 {time zone boundary case 2089-03-13 01:59:59} {detroit y2038} {
    clock format 3761535599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.739 {time zone boundary case 2089-03-13 03:00:00} {detroit y2038} {
    clock format 3761535600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.740 {time zone boundary case 2089-03-13 03:00:01} {detroit y2038} {
    clock format 3761535601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.741 {time zone boundary case 2089-11-06 01:59:59} {detroit y2038} {
    clock format 3782095199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.742 {time zone boundary case 2089-11-06 01:00:00} {detroit y2038} {
    clock format 3782095200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.743 {time zone boundary case 2089-11-06 01:00:01} {detroit y2038} {
    clock format 3782095201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.744 {time zone boundary case 2090-03-12 01:59:59} {detroit y2038} {
    clock format 3792985199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.745 {time zone boundary case 2090-03-12 03:00:00} {detroit y2038} {
    clock format 3792985200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.746 {time zone boundary case 2090-03-12 03:00:01} {detroit y2038} {
    clock format 3792985201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.747 {time zone boundary case 2090-11-05 01:59:59} {detroit y2038} {
    clock format 3813544799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.748 {time zone boundary case 2090-11-05 01:00:00} {detroit y2038} {
    clock format 3813544800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.749 {time zone boundary case 2090-11-05 01:00:01} {detroit y2038} {
    clock format 3813544801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.750 {time zone boundary case 2091-03-11 01:59:59} {detroit y2038} {
    clock format 3824434799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.751 {time zone boundary case 2091-03-11 03:00:00} {detroit y2038} {
    clock format 3824434800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.752 {time zone boundary case 2091-03-11 03:00:01} {detroit y2038} {
    clock format 3824434801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.753 {time zone boundary case 2091-11-04 01:59:59} {detroit y2038} {
    clock format 3844994399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.754 {time zone boundary case 2091-11-04 01:00:00} {detroit y2038} {
    clock format 3844994400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.755 {time zone boundary case 2091-11-04 01:00:01} {detroit y2038} {
    clock format 3844994401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.756 {time zone boundary case 2092-03-09 01:59:59} {detroit y2038} {
    clock format 3855884399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.757 {time zone boundary case 2092-03-09 03:00:00} {detroit y2038} {
    clock format 3855884400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.758 {time zone boundary case 2092-03-09 03:00:01} {detroit y2038} {
    clock format 3855884401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.759 {time zone boundary case 2092-11-02 01:59:59} {detroit y2038} {
    clock format 3876443999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.760 {time zone boundary case 2092-11-02 01:00:00} {detroit y2038} {
    clock format 3876444000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.761 {time zone boundary case 2092-11-02 01:00:01} {detroit y2038} {
    clock format 3876444001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.762 {time zone boundary case 2093-03-08 01:59:59} {detroit y2038} {
    clock format 3887333999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.763 {time zone boundary case 2093-03-08 03:00:00} {detroit y2038} {
    clock format 3887334000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.764 {time zone boundary case 2093-03-08 03:00:01} {detroit y2038} {
    clock format 3887334001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.765 {time zone boundary case 2093-11-01 01:59:59} {detroit y2038} {
    clock format 3907893599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.766 {time zone boundary case 2093-11-01 01:00:00} {detroit y2038} {
    clock format 3907893600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.767 {time zone boundary case 2093-11-01 01:00:01} {detroit y2038} {
    clock format 3907893601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.768 {time zone boundary case 2094-03-14 01:59:59} {detroit y2038} {
    clock format 3919388399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.769 {time zone boundary case 2094-03-14 03:00:00} {detroit y2038} {
    clock format 3919388400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.770 {time zone boundary case 2094-03-14 03:00:01} {detroit y2038} {
    clock format 3919388401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.771 {time zone boundary case 2094-11-07 01:59:59} {detroit y2038} {
    clock format 3939947999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.772 {time zone boundary case 2094-11-07 01:00:00} {detroit y2038} {
    clock format 3939948000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.773 {time zone boundary case 2094-11-07 01:00:01} {detroit y2038} {
    clock format 3939948001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.774 {time zone boundary case 2095-03-13 01:59:59} {detroit y2038} {
    clock format 3950837999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.775 {time zone boundary case 2095-03-13 03:00:00} {detroit y2038} {
    clock format 3950838000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.776 {time zone boundary case 2095-03-13 03:00:01} {detroit y2038} {
    clock format 3950838001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.777 {time zone boundary case 2095-11-06 01:59:59} {detroit y2038} {
    clock format 3971397599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.778 {time zone boundary case 2095-11-06 01:00:00} {detroit y2038} {
    clock format 3971397600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.779 {time zone boundary case 2095-11-06 01:00:01} {detroit y2038} {
    clock format 3971397601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.780 {time zone boundary case 2096-03-11 01:59:59} {detroit y2038} {
    clock format 3982287599 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.781 {time zone boundary case 2096-03-11 03:00:00} {detroit y2038} {
    clock format 3982287600 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.782 {time zone boundary case 2096-03-11 03:00:01} {detroit y2038} {
    clock format 3982287601 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.783 {time zone boundary case 2096-11-04 01:59:59} {detroit y2038} {
    clock format 4002847199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.784 {time zone boundary case 2096-11-04 01:00:00} {detroit y2038} {
    clock format 4002847200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.785 {time zone boundary case 2096-11-04 01:00:01} {detroit y2038} {
    clock format 4002847201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.786 {time zone boundary case 2097-03-10 01:59:59} {detroit y2038} {
    clock format 4013737199 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.787 {time zone boundary case 2097-03-10 03:00:00} {detroit y2038} {
    clock format 4013737200 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.788 {time zone boundary case 2097-03-10 03:00:01} {detroit y2038} {
    clock format 4013737201 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.789 {time zone boundary case 2097-11-03 01:59:59} {detroit y2038} {
    clock format 4034296799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.790 {time zone boundary case 2097-11-03 01:00:00} {detroit y2038} {
    clock format 4034296800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.791 {time zone boundary case 2097-11-03 01:00:01} {detroit y2038} {
    clock format 4034296801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.792 {time zone boundary case 2098-03-09 01:59:59} {detroit y2038} {
    clock format 4045186799 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.793 {time zone boundary case 2098-03-09 03:00:00} {detroit y2038} {
    clock format 4045186800 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.794 {time zone boundary case 2098-03-09 03:00:01} {detroit y2038} {
    clock format 4045186801 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.795 {time zone boundary case 2098-11-02 01:59:59} {detroit y2038} {
    clock format 4065746399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.796 {time zone boundary case 2098-11-02 01:00:00} {detroit y2038} {
    clock format 4065746400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.797 {time zone boundary case 2098-11-02 01:00:01} {detroit y2038} {
    clock format 4065746401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
test clock-5.798 {time zone boundary case 2099-03-08 01:59:59} {detroit y2038} {
    clock format 4076636399 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0500 EST}
test clock-5.799 {time zone boundary case 2099-03-08 03:00:00} {detroit y2038} {
    clock format 4076636400 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:00 -0400 EDT}
test clock-5.800 {time zone boundary case 2099-03-08 03:00:01} {detroit y2038} {
    clock format 4076636401 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {03:00:01 -0400 EDT}
test clock-5.801 {time zone boundary case 2099-11-01 01:59:59} {detroit y2038} {
    clock format 4097195999 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:59:59 -0400 EDT}
test clock-5.802 {time zone boundary case 2099-11-01 01:00:00} {detroit y2038} {
    clock format 4097196000 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:00 -0500 EST}
test clock-5.803 {time zone boundary case 2099-11-01 01:00:01} {detroit y2038} {
    clock format 4097196001 -format {%H:%M:%S %z %Z} \
        -timezone :America/Detroit
} {01:00:01 -0500 EST}
# END testcases5

# Test input conversions.

test clock-6.0 {input of seconds} {
35325
35326
35327
35328
35329
35330
35331
35332
35333
35334
35335
35336
35337
35338
35339
35340
35341
35342
35343
35344
35345
35346
35347
35348
35349
35350
35351
35352
35353
35354
35355
35356
35357
35358
	    unset oldTZ
	} else {
	    unset env(TZ)
	}
    } \
    -result {-0500}

test clock-43.1 {regression test - mktime returning -1} \
    -setup {
	if { [info exists env(TZ)] } {
	    set oldTZ $env(TZ)
	}
	set env(TZ) UTC0
    } \
    -body {
	clock scan 1969-12-31T23:59:59 -format %Y-%m-%dT%T -timezone :localtime
    } \
    -cleanup {
	if { [info exists oldTZ] } {
	    set env(TZ) $oldTZ
	    unset oldTZ
	} else {
	    unset env(TZ)
	}
    } \
    -result {-1}
    
test clock-44.1 {regression test - time zone name containing hyphen } \
    -setup {
	if { [info exists env(TZ)] } {
	    set oldTZ $env(TZ)
	}
	set env(TZ) US/East-Indiana
    } \







|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







35327
35328
35329
35330
35331
35332
35333
35334



35335















35336
35337
35338
35339
35340
35341
35342
	    unset oldTZ
	} else {
	    unset env(TZ)
	}
    } \
    -result {-0500}

# 43.1 was a bad test - mktime returning -1 is an error according to posix.



















test clock-44.1 {regression test - time zone name containing hyphen } \
    -setup {
	if { [info exists env(TZ)] } {
	    set oldTZ $env(TZ)
	}
	set env(TZ) US/East-Indiana
    } \
35370
35371
35372
35373
35374
35375
35376



















































































































35377
35378
35379
35380
35381
35382
35383
35384
35385
35386
35387
    -result {12:34:56-0500}
    
test clock-45.1 {regression test - time zone containing only two digits} \
    -body {
	clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z
    } \
    -result 482134530




















































































































# cleanup

namespace delete ::testClock
::tcl::clock::ClearCaches
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











35354
35355
35356
35357
35358
35359
35360
35361
35362
35363
35364
35365
35366
35367
35368
35369
35370
35371
35372
35373
35374
35375
35376
35377
35378
35379
35380
35381
35382
35383
35384
35385
35386
35387
35388
35389
35390
35391
35392
35393
35394
35395
35396
35397
35398
35399
35400
35401
35402
35403
35404
35405
35406
35407
35408
35409
35410
35411
35412
35413
35414
35415
35416
35417
35418
35419
35420
35421
35422
35423
35424
35425
35426
35427
35428
35429
35430
35431
35432
35433
35434
35435
35436
35437
35438
35439
35440
35441
35442
35443
35444
35445
35446
35447
35448
35449
35450
35451
35452
35453
35454
35455
35456
35457
35458
35459
35460
35461
35462
35463
35464
35465
35466
35467
35468
35469
35470
35471
35472
35473
35474
35475
35476
35477
35478
35479
35480
35481
35482
35483
35484
35485
35486
    -result {12:34:56-0500}
    
test clock-45.1 {regression test - time zone containing only two digits} \
    -body {
	clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z
    } \
    -result 482134530

test clock-46.1 {regression test - month zero} \
    -body {
	clock scan 2004-00-00 -format %Y-%m-%d
    } -result [clock scan 2003-11-30 -format %Y-%m-%d]
test clock-46.2 {regression test - month zero} \
    -body {
	clock scan 20040000
    } -result [clock scan 2003-11-30 -format %Y-%m-%d]
test clock-46.3 {regression test - month thirteen} \
    -body {
	clock scan 2004-13-01 -format %Y-%m-%d
    } -result [clock scan 2005-01-01 -format %Y-%m-%d]
test clock-46.4 {regression test - month thirteen} \
    -body {
	clock scan 20041301
    } -result [clock scan 2005-01-01 -format %Y-%m-%d]

test clock-47.1 {regression test - four-digit time} {
    clock scan 0012
} [clock scan 0012 -format %H%M]
test clock-47.2 {regression test - four digit time} {
    clock scan 0039
} [clock scan 0039 -format %H%M]

test clock-48.1 {Bug 1185933: 'i' destroyed by clock init} -setup {
    interp create child
} -body {
    interp eval child {
	set i 12345
	clock format 0
	list [catch { set i } result] $result
    }
} -cleanup {
    interp delete child
} -result {0 12345}

test clock-49.1 {regression test - localtime with negative arg (Bug 1237907)} \
    -body {
	list [catch { 
	    clock format -86400 -timezone :localtime -format %Y
	} result] $result
    } \
    -match regexp \
    -result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}}

test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \
    -constraints win \
    -setup {
	# override the registry so that the test takes place in New York time
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	if { [info exists env(TZ)] } {
	    set oldTZ $env(TZ)
	    unset env(TZ)
	}
	if { [info exists env(TCL_TZ)] } {
	    set oldTclTZ $env(TCL_TZ)
	    unset env(TCL_TZ)
	}
	# make it so New York time is a missing file
	dict set ::tcl::clock::WinZoneInfo \
	    {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} \
	    :No/Such/File
	::tcl::clock::ClearCaches
    } \
    -body {
	list [::tcl::clock::GuessWindowsTimeZone] \
	    [clock format 0 -locale system -format "%X %Z"] \
	    [clock format -86400 -format "%Y"]
    } \
    -cleanup {
	# restore the registry and environment
	namespace eval ::tcl::clock {
	    rename registry {}
	}
	if { [info exists oldTclTZ] } {
	    set env(TCL_TZ) $oldTclTZ
	}
	if { [info exists oldTZ] } {
	    set env(TZ) $oldTZ
	}
	# put New York back on the map
	dict set ::tcl::clock::WinZoneInfo \
	    {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} \
	    :America/New_York
	::tcl::clock::ClearCaches
    } \
    -result {<-0500>+05:00:00<-0400>+04:00:00,M4.1.0/02:00:00,M10.5.0/02:00:00 { 7:00:00 PM -0500} 1969}

test clock-50.1 {format / scan -1 as a local time} {
    if {[catch {
	clock scan \
	    [clock format -1 -format %Y%m%d%H%M%S -timezone :localtime] \
	    -format %Y%m%d%H%M%S -timezone :localtime
    } result]} {
	if { [regexp " too large" $result] } {
	    set result -1
	}
    }
    set result
} -1
test clock-50.2 {format / scan -2 as a local time} {
    if {[catch {
	clock scan \
	    [clock format -2 -format %Y%m%d%H%M%S -timezone :localtime] \
	    -format %Y%m%d%H%M%S -timezone :localtime
    } result]} {
	if { [regexp " too large" $result] } {
	    set result -2
	}
    }
    set result
} -2

# cleanup

namespace delete ::testClock
::tcl::clock::ClearCaches
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/cmdIL.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
# This file contains a collection of tests for the procedures in the
# file tclCmdIL.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdIL.test,v 1.23 2004/10/14 17:20:11 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]

test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort -foo {1 3 2 5}} msg] $msg
} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -real, or -unique}}
test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} {
    lsort {d e c b a \{ d35 d300}
} {a b c d d300 d35 e \{}
test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} {
    lsort -integer -ascii {d e c b a d35 d300}
} {a b c d d300 d35 e}
test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} {










|














|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
# This file contains a collection of tests for the procedures in the
# file tclCmdIL.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdIL.test,v 1.23.2.2 2005/07/12 20:37:06 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]

test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort -foo {1 3 2 5}} msg] $msg
} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique}}
test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} {
    lsort {d e c b a \{ d35 d300}
} {a b c d d300 d35 e \{}
test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} {
    lsort -integer -ascii {d e c b a d35 d300}
} {a b c d d300 d35 e}
test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} {
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
    lsort -decreasing -increasing {d e c b a d35 d300}
} {a b c d d300 d35 e}
test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} {
    list [catch {lsort -index {1 3 2 5}} msg] $msg
} {1 {"-index" option must be followed by list index}}
test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} {
    list [catch {lsort -index foo {1 3 2 5}} msg] $msg
} {1 {bad index "foo": must be integer or end?-integer?}}
test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} {
    lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1}
} {1 {2 25} {3 16 42} {10 20 50 100}}
test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} {
    lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}}
} {{3 16 42} {10 20 50} {1 25 100}}
test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} {







|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
    lsort -decreasing -increasing {d e c b a d35 d300}
} {a b c d d300 d35 e}
test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} {
    list [catch {lsort -index {1 3 2 5}} msg] $msg
} {1 {"-index" option must be followed by list index}}
test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} {
    list [catch {lsort -index foo {1 3 2 5}} msg] $msg
} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}}
test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} {
    lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1}
} {1 {2 25} {3 16 42} {10 20 50 100}}
test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} {
    lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}}
} {{3 16 42} {10 20 50} {1 25 100}}
test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} {
379
380
381
382
383
384
385






386
387
388
389
390
391
392
} [list ` AA c CC]
test cmdIL-4.32 {DictionaryCompare procedure, chars between Z and a in ASCII} {
    lsort -dictionary [list AA c CC `]
} [list ` AA c CC]
test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} {
    lsort -dictionary [list AA ! c CC `]
} [list ! ` AA c CC]







test cmdIL-5.1 {lsort with list style index} {
    lsort -ascii -decreasing -index {0 1} {
	{{Jim Alpha} 20000410}
	{{Joe Bravo} 19990320}
	{{Jacky Charlie} 19390911}
    }







>
>
>
>
>
>







379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
} [list ` AA c CC]
test cmdIL-4.32 {DictionaryCompare procedure, chars between Z and a in ASCII} {
    lsort -dictionary [list AA c CC `]
} [list ` AA c CC]
test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} {
    lsort -dictionary [list AA ! c CC `]
} [list ! ` AA c CC]
test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} {
    lsort -ascii -nocase {d e c b a d35 d300 100 20}
} {100 20 a b c d d300 d35 e}
test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} {
    lsort -ascii -nocase {d E c B a D35 d300 100 20}
} {100 20 a B c d d300 D35 E}

test cmdIL-5.1 {lsort with list style index} {
    lsort -ascii -decreasing -index {0 1} {
	{{Jim Alpha} 20000410}
	{{Joe Bravo} 19990320}
	{{Jacky Charlie} 19390911}
    }

Changes to tests/compExpr-old.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27


























































28
29
30
31
32
33
34
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compExpr-old.test,v 1.11 2004/10/31 18:46:55 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    testConstraint testmathfunctions 0
} else {
    testConstraint testmathfunctions 1
}



























































# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
}







|












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compExpr-old.test,v 1.11.2.4 2005/08/15 18:14:01 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    testConstraint testmathfunctions 0
} else {
    testConstraint testmathfunctions 1
}

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}
::tcltest::testConstraint ieeeFloatingPoint [testIEEE]

# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
}
63
64
65
66
67
68
69
70


71
72
73
74
75
76
77
	"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
	[string range $c 1 end]]}
}
proc do_twelve_days {} {
    global xxx
    set xxx ""
    12days 1 1 1
    string length $xxx


}

# start of tests

catch {unset a b i x}

test compExpr-old-1.1 {TclCompileExprCmd: no expression} {







|
>
>







121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
	"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
	[string range $c 1 end]]}
}
proc do_twelve_days {} {
    global xxx
    set xxx ""
    12days 1 1 1
    set result [string length $xxx]
    unset xxx
    return $result
}

# start of tests

catch {unset a b i x}

test compExpr-old-1.1 {TclCompileExprCmd: no expression} {
139
140
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
    set msg
} {syntax error in expression "7*2foo": extra tokens at end of expression}
test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
    expr {0001}
} 1

test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
test compExpr-old-3.2 {CompileCondExpr: error in lor expr} {
    catch {expr x||3} msg
    set msg

} {syntax error in expression "x||3": variable references require preceding $} 
test compExpr-old-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test compExpr-old-3.4 {CompileCondExpr: error compiling true arm} {
    catch {expr 3>2?2***3:66} msg
    set msg
} {syntax error in expression "3>2?2***3:66": unexpected operator *}
test compExpr-old-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test compExpr-old-3.6 {CompileCondExpr: error compiling false arm} {
    catch {expr 2>3?44:2***3} msg
    set msg
} {syntax error in expression "2>3?44:2***3": unexpected operator *}
test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} {
    puts "Note: doing test compExpr-old-3.7 which can take several minutes to run"
    hello_world
} {Hello world}
catch {unset xxx}
test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} {
    puts "Note: doing test compExpr-old-3.8 which can take several minutes to run"

    do_twelve_days
} 2358
catch {unset xxx}

test compExpr-old-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
test compExpr-old-4.2 {CompileLorExpr: error in land expr} {
    catch {expr x&&3} msg
    set msg
} {syntax error in expression "x&&3": variable references require preceding $} 
test compExpr-old-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test compExpr-old-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test compExpr-old-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test compExpr-old-4.6 {CompileLorExpr: error compiling lor arm} {
    catch {expr 2***3||4.0} msg
    set msg
} {syntax error in expression "2***3||4.0": unexpected operator *}







|


>
|










|
<


<
|
<
>


<


|


|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221

222
223

224

225
226
227

228
229
230
231
232
233
234
235
236
237
238
239
240
    set msg
} {syntax error in expression "7*2foo": extra tokens at end of expression}
test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
    expr {0001}
} 1

test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
test compExpr-old-3.2 {CompileCondExpr: error in lor expr} -body {
    catch {expr x||3} msg
    set msg
} -match glob \
	-result {syntax error in expression "x||3": * preceding $*}
test compExpr-old-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test compExpr-old-3.4 {CompileCondExpr: error compiling true arm} {
    catch {expr 3>2?2***3:66} msg
    set msg
} {syntax error in expression "3>2?2***3:66": unexpected operator *}
test compExpr-old-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test compExpr-old-3.6 {CompileCondExpr: error compiling false arm} {
    catch {expr 2>3?44:2***3} msg
    set msg
} {syntax error in expression "2>3?44:2***3": unexpected operator *}
test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} {

    hello_world
} {Hello world}

test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} unix {

    # Fails with a stack overflow on threaded Windows builds
    do_twelve_days
} 2358


test compExpr-old-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
test compExpr-old-4.2 {CompileLorExpr: error in land expr} -body {
    catch {expr x&&3} msg
    set msg
} -match glob -result {syntax error in expression "x&&3": * preceding $*} 
test compExpr-old-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test compExpr-old-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test compExpr-old-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test compExpr-old-4.6 {CompileLorExpr: error compiling lor arm} {
    catch {expr 2***3||4.0} msg
    set msg
} {syntax error in expression "2***3||4.0": unexpected operator *}
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
test compExpr-old-4.9 {CompileLorExpr: long lor arm} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1

test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} {
    catch {expr x|3} msg
    set msg
} {syntax error in expression "x|3": variable references require preceding $} 
test compExpr-old-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test compExpr-old-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test compExpr-old-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test compExpr-old-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
test compExpr-old-5.7 {CompileLandExpr: error compiling land arm} {
    catch {expr 2***3&&4.0} msg
    set msg







|


|







248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
test compExpr-old-4.9 {CompileLorExpr: long lor arm} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1

test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} -body {
    catch {expr x|3} msg
    set msg
} -match glob -result {syntax error in expression "x|3": * preceding $*} 
test compExpr-old-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test compExpr-old-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test compExpr-old-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test compExpr-old-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
test compExpr-old-5.7 {CompileLandExpr: error compiling land arm} {
    catch {expr 2***3&&4.0} msg
    set msg
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303


304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379



380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
test compExpr-old-5.10 {CompileLandExpr: long land arms} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1

test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} {
    catch {expr x|3} msg
    set msg
} {syntax error in expression "x|3": variable references require preceding $} 
test compExpr-old-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test compExpr-old-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test compExpr-old-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test compExpr-old-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
test compExpr-old-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
    catch {expr 2***3|6} msg
    set msg
} {syntax error in expression "2***3|6": unexpected operator *}
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
    catch {expr 2^x} msg
    set msg
} {syntax error in expression "2^x": variable references require preceding $}
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}

test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} {
    catch {expr x==3} msg
    set msg
} {syntax error in expression "x==3": variable references require preceding $} 
test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} {
    catch {expr 2***3&6} msg
    set msg
} {syntax error in expression "2***3&6": unexpected operator *}
test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} {
    catch {expr 2&x} msg
    set msg
} {syntax error in expression "2&x": variable references require preceding $}
test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}

test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} {
    catch {expr x>3} msg
    set msg
} {syntax error in expression "x>3": variable references require preceding $} 
test compExpr-old-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test compExpr-old-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test compExpr-old-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test compExpr-old-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
test compExpr-old-8.10 {CompileEqualityExpr: error compiling equality arm} {
    catch {expr 2***3==6} msg
    set msg
} {syntax error in expression "2***3==6": unexpected operator *}
test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} {
    catch {expr 2!=x} msg
    set msg
} {syntax error in expression "2!=x": variable references require preceding $}


test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8

# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different

if {int(0x80000000) > 0} {


    test compExpr-old-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
	expr {1<<63}
    } -9223372036854775808
} else {
    test compExpr-old-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
	expr {1<<31}
    } -2147483648
}
test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} {
    catch {expr x>>3} msg
    set msg
} {syntax error in expression "x>>3": variable references require preceding $} 
test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} {
    catch {expr 2***3>6} msg
    set msg
} {syntax error in expression "2***3>6": unexpected operator *}
test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} {
    catch {expr 2<x} msg
    set msg
} {syntax error in expression "2<x": variable references require preceding $}

test compExpr-old-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
test compExpr-old-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
test compExpr-old-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
test compExpr-old-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82
test compExpr-old-10.5 {CompileShiftExpr: error in add expr} {
    catch {expr x+3} msg
    set msg
} {syntax error in expression "x+3": variable references require preceding $}
test compExpr-old-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
test compExpr-old-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test compExpr-old-10.8 {CompileShiftExpr: error compiling shift arm} {
    catch {expr 2***3>>6} msg
    set msg
} {syntax error in expression "2***3>>6": unexpected operator *}
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} {
    catch {expr 2<<x} msg
    set msg
} {syntax error in expression "2<<x": variable references require preceding $}
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
    list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
    list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}

test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} {
    catch {expr x*3} msg
    set msg
} {syntax error in expression "x*3": variable references require preceding $}
test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} {
    catch {expr 2***3+6} msg
    set msg
} {syntax error in expression "2***3+6": unexpected operator *}
test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} {
    catch {expr 2-x} msg
    set msg
} {syntax error in expression "2-x": variable references require preceding $}
test compExpr-old-11.10 {CompileAddExpr: runtime error} {
    list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test compExpr-old-11.11 {CompileAddExpr: runtime error} {
    list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test compExpr-old-11.12 {CompileAddExpr: runtime error} {
    list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test compExpr-old-11.13 {CompileAddExpr: runtime error} {



    list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}

test compExpr-old-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test compExpr-old-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test compExpr-old-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test compExpr-old-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} {
    catch {expr ~x} msg
    set msg
} {syntax error in expression "~x": variable references require preceding $}
test compExpr-old-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test compExpr-old-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test compExpr-old-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
    catch {expr 2*3%%6} msg
    set msg
} {syntax error in expression "2*3%%6": unexpected operator %}
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
    catch {expr 2*x} msg
    set msg
} {syntax error in expression "2*x": variable references require preceding $}
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}

test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} {
    catch {expr ~x} msg
    set msg
} {syntax error in expression "~x": variable references require preceding $}
test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} {
    catch {expr !1.x} msg
    set msg
} {syntax error in expression "!1.x": extra tokens at end of expression}
test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
    list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}







|


|








|


|











|


|








|


|











|


|








|


|










|
>
>
|
|
|
|
|
|
|
|
|


|






|


|





|


|






|


|











|


|






|


|









|
>
>
>







|


|






|


|














|


|







274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
test compExpr-old-5.10 {CompileLandExpr: long land arms} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1

test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} -body {
    catch {expr x|3} msg
    set msg
} -match glob -result {syntax error in expression "x|3": * preceding $*} 
test compExpr-old-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test compExpr-old-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test compExpr-old-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test compExpr-old-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
test compExpr-old-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
    catch {expr 2***3|6} msg
    set msg
} {syntax error in expression "2***3|6": unexpected operator *}
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
    catch {expr 2^x} msg
    set msg
} -match glob -result {syntax error in expression "2^x": * preceding $*}
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}

test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body {
    catch {expr x==3} msg
    set msg
} -match glob -result {syntax error in expression "x==3": * preceding $*} 
test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} {
    catch {expr 2***3&6} msg
    set msg
} {syntax error in expression "2***3&6": unexpected operator *}
test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
    catch {expr 2&x} msg
    set msg
} -match glob -result {syntax error in expression "2&x": * preceding $*}
test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}

test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body {
    catch {expr x>3} msg
    set msg
} -match glob -result {syntax error in expression "x>3": * preceding $*} 
test compExpr-old-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test compExpr-old-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test compExpr-old-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test compExpr-old-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
test compExpr-old-8.10 {CompileEqualityExpr: error compiling equality arm} {
    catch {expr 2***3==6} msg
    set msg
} {syntax error in expression "2***3==6": unexpected operator *}
test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} -body {
    catch {expr 2!=x} msg
    set msg
} -match glob -result {syntax error in expression "2!=x": * preceding $*}


test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8

# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different

testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]

test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
    expr {1<<63}
} -9223372036854775808

test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
    expr {1<<31}
} -2147483648

test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body {
    catch {expr x>>3} msg
    set msg
} -match glob -result {syntax error in expression "x>>3": * preceding $*} 
test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} {
    catch {expr 2***3>6} msg
    set msg
} {syntax error in expression "2***3>6": unexpected operator *}
test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} -body {
    catch {expr 2<x} msg
    set msg
} -match glob -result {syntax error in expression "2<x": * preceding $*}

test compExpr-old-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
test compExpr-old-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
test compExpr-old-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
test compExpr-old-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82
test compExpr-old-10.5 {CompileShiftExpr: error in add expr} -body {
    catch {expr x+3} msg
    set msg
} -match glob -result {syntax error in expression "x+3": * preceding $*}
test compExpr-old-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
test compExpr-old-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test compExpr-old-10.8 {CompileShiftExpr: error compiling shift arm} {
    catch {expr 2***3>>6} msg
    set msg
} {syntax error in expression "2***3>>6": unexpected operator *}
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
    catch {expr 2<<x} msg
    set msg
} -match glob -result {syntax error in expression "2<<x": * preceding $*}
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
    list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
    list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}

test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body {
    catch {expr x*3} msg
    set msg
} -match glob -result {syntax error in expression "x*3": * preceding $*}
test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} {
    catch {expr 2***3+6} msg
    set msg
} {syntax error in expression "2***3+6": unexpected operator *}
test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body {
    catch {expr 2-x} msg
    set msg
} -match glob -result {syntax error in expression "2-x": * preceding $*}
test compExpr-old-11.10 {CompileAddExpr: runtime error} {
    list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test compExpr-old-11.11 {CompileAddExpr: runtime error} {
    list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test compExpr-old-11.12 {CompileAddExpr: runtime error} {
    list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint {
    list [catch {expr {2.3/0.0}} msg] $msg
} {0 Inf}
test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint {
    list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}

test compExpr-old-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test compExpr-old-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test compExpr-old-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test compExpr-old-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} -body {
    catch {expr ~x} msg
    set msg
} -match glob -result {syntax error in expression "~x": * preceding $*}
test compExpr-old-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test compExpr-old-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test compExpr-old-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
    catch {expr 2*3%%6} msg
    set msg
} {syntax error in expression "2*3%%6": unexpected operator %}
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
    catch {expr 2*x} msg
    set msg
} -match glob -result {syntax error in expression "2*x": * preceding $*}
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}

test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
    catch {expr ~x} msg
    set msg
} -match glob -result {syntax error in expression "~x": * preceding $*}
test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} {
    catch {expr !1.x} msg
    set msg
} {syntax error in expression "!1.x": extra tokens at end of expression}
test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
    list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
} 2.71828
test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} {
    format %.6g [expr pow(2.0+0.1,3.0+0.1)]
} 9.97424
test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body {
    catch {expr sinh::(2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments
    while *ing
"expr sinh::(2.0)"}
test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg







|







588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
} 2.71828
test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} {
    format %.6g [expr pow(2.0+0.1,3.0+0.1)]
} 9.97424
test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body {
    catch {expr sinh::(2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh::(2.0)": * function arguments*
    while *ing
"expr sinh::(2.0)"}
test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
} -match glob -result {syntax error in expression "@": character not legal in expressions
    while *ing
"expr @"}

test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    catch {expr sinh2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh2.0)": variable references require preceding $
    while *ing
"expr sinh2.0)"}
test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set errorInfo
} -match glob -result {unknown math function "whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set errorInfo
} -match glob -result {too many arguments for math function
    while *ing
"expr sin(1,2,3)"}
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set errorInfo
} -match glob -result {too few arguments for math function
    while *ing
"expr sin()"}
test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set errorInfo
} -match glob -result {too few arguments for math function
    while *ing
"expr pow(1)"}
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
    catch {expr sin(1} msg
    set errorInfo
} -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call
    while *ing







|





|





|





|





|







620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
} -match glob -result {syntax error in expression "@": character not legal in expressions
    while *ing
"expr @"}

test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    catch {expr sinh2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh2.0)": * preceding $*
    while *ing
"expr sinh2.0)"}
test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set errorInfo
} -match glob -result {* "*whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set errorInfo
} -match glob -result {too many arguments for math function*
    while *ing
"expr sin(1,2,3)"}
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr sin()"}
test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr pow(1)"}
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
    catch {expr sin(1} msg
    set errorInfo
} -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call
    while *ing

Changes to tests/compExpr.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36
37
38
39
40
41
# This file contains a collection of tests for the procedures in the
# file tclCompExpr.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compExpr.test,v 1.8 2004/09/26 16:36:05 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    testConstraint testmathfunctions 0
} else {
    testConstraint testmathfunctions 1
}

catch {unset a}

test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
    expr 1+2
} 3
test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} {
    list [catch {expr 1+2+} msg] $msg
} {1 {syntax error in expression "1+2+": premature end of expression}}
test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} {
    list [catch {expr "foo(123)"} msg] $msg

} {1 {unknown math function "foo"}}
test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} {
    set a {000123}
    expr {$a}
} 83

test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} {
    catch {unset a}










|




















|

>
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
# This file contains a collection of tests for the procedures in the
# file tclCompExpr.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compExpr.test,v 1.8.2.1 2005/03/15 19:41:45 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    testConstraint testmathfunctions 0
} else {
    testConstraint testmathfunctions 1
}

catch {unset a}

test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
    expr 1+2
} 3
test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} {
    list [catch {expr 1+2+} msg] $msg
} {1 {syntax error in expression "1+2+": premature end of expression}}
test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body {
    list [catch {expr "foo(123)"} msg] $msg
} -match glob -result {1 {* "*foo"}}

test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} {
    set a {000123}
    expr {$a}
} 83

test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} {
    catch {unset a}
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
} {0 1}
test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} {
    expr {5*6}
} 30
test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} {
    format %.6g [expr {sin(2.0)}]
} 0.909297
test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} {
    list [catch {expr {fred(2.0)}} msg] $msg
} {1 {unknown math function "fred"}}
test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
    expr {4*2}
} 8
test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
    expr {4/2}
} 2
test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {







|

|







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
} {0 1}
test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} {
    expr {5*6}
} 30
test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} {
    format %.6g [expr {sin(2.0)}]
} 0.909297
test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} -body {
    list [catch {expr {fred(2.0)}} msg] $msg
} -match glob -result {1 {* "*fred"}}
test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
    expr {4*2}
} 8
test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
    expr {4/2}
} 2
test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
    list [catch {expr {1? 15 : [expr *2]}} msg] $msg
} {0 15}

test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
    format %.6g [expr atan2(1.0, 2.0)]
} 0.463648
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} {
    list [catch {expr {do_it()}} msg] $msg
} {1 {unknown math function "do_it"}}
test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions {
    expr 3*T1()-1
} 368
test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions {
    expr T2()*3
} 1035
test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} {
    list [catch {expr {atan2(1.0)}} msg] $msg
} {1 {too few arguments for math function}}
test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} {
    format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))]
} 9.97424
test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} {
    list [catch {expr {sinh(2.*)}} msg] $msg
} {1 {syntax error in expression "sinh(2.*)": unexpected close parenthesis}}
test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} {
    list [catch {expr {sinh(2.0, 3.0)}} msg] $msg
} {1 {too many arguments for math function}}
test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} {
    list [catch {expr {0 <= rand(5.2)}} msg] $msg
} {1 {too many arguments for math function}}

test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
    list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": extra tokens at end of expression}}

# cleanup
catch {unset a}
catch {unset b}
::tcltest::cleanupTests
return







|

|






|

|






|

|
|

|










286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
    list [catch {expr {1? 15 : [expr *2]}} msg] $msg
} {0 15}

test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
    format %.6g [expr atan2(1.0, 2.0)]
} 0.463648
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
    list [catch {expr {do_it()}} msg] $msg
} -match glob -result {1 {* "*do_it"}}
test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions {
    expr 3*T1()-1
} 368
test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions {
    expr T2()*3
} 1035
test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body {
    list [catch {expr {atan2(1.0)}} msg] $msg
} -match glob -result {1 {too few arguments for math function*}}
test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} {
    format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))]
} 9.97424
test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} {
    list [catch {expr {sinh(2.*)}} msg] $msg
} {1 {syntax error in expression "sinh(2.*)": unexpected close parenthesis}}
test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body {
    list [catch {expr {sinh(2.0, 3.0)}} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}
test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body {
    list [catch {expr {0 <= rand(5.2)}} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}

test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
    list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": extra tokens at end of expression}}

# cleanup
catch {unset a}
catch {unset b}
::tcltest::cleanupTests
return

Changes to tests/compile.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# This file contains tests for the files tclCompile.c, tclCompCmds.c
# and tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compile.test,v 1.34 2004/12/02 11:10:49 dkf Exp $

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint exec       [llength [info commands exec]]
testConstraint memory     [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# This file contains tests for the files tclCompile.c, tclCompCmds.c
# and tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compile.test,v 1.34.2.3 2005/05/05 17:56:15 kennykb Exp $

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint exec       [llength [info commands exec]]
testConstraint memory     [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    proc p {} {
	# shared object - Interp result && Var 'r'
	set r [list foobar]
	# command that will add error to result
	lindex a bogus
    }
    list [catch {p} msg] $msg
} {1 {bad index "bogus": must be integer or end?-integer?}}
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; string index a bogus }
    list [catch {p} msg] $msg
} {1 {bad index "bogus": must be integer or end?-integer?}}
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; string index a 09 }
    list [catch {p} msg] $msg
} {1 {bad index "09": must be integer or end?-integer? (looks like invalid octal number)}}
test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; array set var {one two many} }
    list [catch {p} msg] $msg
} {1 {list must have an even number of elements}}
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; incr foo }
    list [catch {p} msg] $msg
} {1 {can't read "foo": no such variable}}
test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; incr foo bogus }
    list [catch {p} msg] $msg
} {1 {expected integer but got "bogus"}}
test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; expr !a }
    list [catch {p} msg] $msg
} {1 {syntax error in expression "!a": variable references require preceding $}}
test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; expr {!a} }
    list [catch {p} msg] $msg
} {1 {syntax error in expression "!a": variable references require preceding $}}
test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; llength "\{" }
    list [catch {p} msg] $msg
} {1 {unmatched open brace in list}}

# 
# Special section for tests of tclLiteral.c







|



|



|












|


|
|


|







232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    proc p {} {
	# shared object - Interp result && Var 'r'
	set r [list foobar]
	# command that will add error to result
	lindex a bogus
    }
    list [catch {p} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; string index a bogus }
    list [catch {p} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; string index a 09 }
    list [catch {p} msg] $msg
} {1 {bad index "09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}
test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; array set var {one two many} }
    list [catch {p} msg] $msg
} {1 {list must have an even number of elements}}
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; incr foo }
    list [catch {p} msg] $msg
} {1 {can't read "foo": no such variable}}
test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; incr foo bogus }
    list [catch {p} msg] $msg
} {1 {expected integer but got "bogus"}}
test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
    proc p {} { set r [list foobar] ; expr !a }
    list [catch {p} msg] $msg
} -match glob -result {1 {syntax error in expression "!a": * preceding $*}}
test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
    proc p {} { set r [list foobar] ; expr {!a} }
    list [catch {p} msg] $msg
} -match glob -result {1 {syntax error in expression "!a": * preceding $*}}
test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
    proc p {} { set r [list foobar] ; llength "\{" }
    list [catch {p} msg] $msg
} {1 {unmatched open brace in list}}

# 
# Special section for tests of tclLiteral.c
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
test compile-12.3 {check for a buffer overrun} -body {
    proc crash {} {
	puts $array([expr {a+2}])
    }
    crash
} -returnCodes error -cleanup {
    rename crash {}
} -result {syntax error in expression "a+2": variable references require preceding $}
test compile-12.4 {TclCleanupLiteralTable segfault} -body {
    # Tcl Bug 1001997
    # Here, we're trying to test a case that causes a crash in
    # TclCleanupLiteralTable.  The conditions that we're trying to
    # establish are:
    # - TclCleanupLiteralTable is attempting to clean up a bytecode
    #   object in the literal table.







|







316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
test compile-12.3 {check for a buffer overrun} -body {
    proc crash {} {
	puts $array([expr {a+2}])
    }
    crash
} -returnCodes error -cleanup {
    rename crash {}
} -match glob -result {syntax error in expression "a+2": * preceding $*}
test compile-12.4 {TclCleanupLiteralTable segfault} -body {
    # Tcl Bug 1001997
    # Here, we're trying to test a case that causes a crash in
    # TclCleanupLiteralTable.  The conditions that we're trying to
    # establish are:
    # - TclCleanupLiteralTable is attempting to clean up a bytecode
    #   object in the literal table.
582
583
584
585
586
587
588































589
590
591
592
593
594
595
596
597
	}
    }
} -cleanup {
    namespace delete x
} -returnCodes ok -result {syntax {}{}}

}	;# End of noComp loop
































# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
	}
    }
} -cleanup {
    namespace delete x
} -returnCodes ok -result {syntax {}{}}

}	;# End of noComp loop

# These tests are messy because it wrecks the interpreter it runs in!
# They demonstrate issues arising from [FRQ 1101710]
test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup {
    set i [interp create]
} -body {
    $i eval {
	if 1 {
	    expr [
		proc expr args {return substituted}
		format {[subst compiled]}
	    ]
	}
    }
} -cleanup {
    interp delete $i
} -result substituted
test compile-17.2 {Command interpretation binding for non-compiled code} -setup {
    set i [interp create]
} -body {
    $i eval {
	if 1 {
	    [subst expr] [
		proc expr args {return substituted}
		format {[subst compiled]}
	    ]
	}
    }
} -cleanup {
    interp delete $i
} -result substituted

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return

Changes to tests/dict.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This test file covers the dictionary object type and the dict
# command used to work with values of that type.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2003 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: dict.test,v 1.12 2004/10/19 22:20:05 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This test file covers the dictionary object type and the dict
# command used to work with values of that type.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2003 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: dict.test,v 1.12.2.2 2005/08/18 21:19:17 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
302
303
304
305
306
307
308


















309
310
311
312
313
314
315
test dict-11.15 {dict incr command: write failure} {
    catch {unset dictVar}
    set dictVar(block) {}
    set result [list [catch {dict incr dictVar a} msg] $msg]
    catch {unset dictVar}
    set result
} {1 {can't set "dictVar": variable is array}}



















test dict-12.1 {dict lappend command} {
    set dictv {a a}
    dict lappend dictv a
} {a a}
test dict-12.2 {dict lappend command} {
    set dictv {a a}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
test dict-11.15 {dict incr command: write failure} {
    catch {unset dictVar}
    set dictVar(block) {}
    set result [list [catch {dict incr dictVar a} msg] $msg]
    catch {unset dictVar}
    set result
} {1 {can't set "dictVar": variable is array}}
test dict-11.16 {dict incr command: compilation} {
    proc dicttest {} {
	set v {a 0 b 0 c 0}
	dict incr v a
	dict incr v b 1
	dict incr v c 2
	dict incr v d 3
	list [dict get $v a] [dict get $v b] [dict get $v c] [dict get $v d]
    }
    dicttest
} {1 1 2 3}
test dict-11.17 {dict incr command: compilation} {
    proc dicttest {} {
	set dictv {a 1}
	dict incr dictv a 2
    }
    dicttest
} {a 3}

test dict-12.1 {dict lappend command} {
    set dictv {a a}
    dict lappend dictv a
} {a a}
test dict-12.2 {dict lappend command} {
    set dictv {a a}
507
508
509
510
511
512
513











514
515
516
517
518
519
520
    lappend result :
    foreach k $result {
	catch {lappend result $accum($k)}
    }
    catch {unset accum}
    set result
} {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}











# There's probably a lot more tests to add here.  Really ought to use
# a coverage tool for this job...

test dict-15.1 {dict set command} {
    set dictVar {}
    dict set dictVar a x
} {a x}







>
>
>
>
>
>
>
>
>
>
>







525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
    lappend result :
    foreach k $result {
	catch {lappend result $accum($k)}
    }
    catch {unset accum}
    set result
} {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
test dict-14.16 {dict for command in compilation context} {
    proc dicttest {} {
	set res {x x x x x x}
	dict for {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
	    lset res $v $k
	    continue
	}
	return $res
    }
    dicttest
} {a b c d e f}
# There's probably a lot more tests to add here.  Really ought to use
# a coverage tool for this job...

test dict-15.1 {dict set command} {
    set dictVar {}
    dict set dictVar a x
} {a x}
964
965
966
967
968
969
970













971
972
973
974
975
976
977
test dict-21.12 {dict update command} {
    set a {b c d e}
    dict update a b v1 d v2 f v3 {
	set v3 g
    }
    getOrder $a b d f
} {b c d e f g 3}














test dict-22.1 {dict with command} -body {
    dict with
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
test dict-22.2 {dict with command} -body {
    dict with v
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}







>
>
>
>
>
>
>
>
>
>
>
>
>







993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
test dict-21.12 {dict update command} {
    set a {b c d e}
    dict update a b v1 d v2 f v3 {
	set v3 g
    }
    getOrder $a b d f
} {b c d e f g 3}
test dict-21.13 {dict update command: compilation} {
    proc dicttest {d} {
	while 1 {
	    dict update d a alpha b beta {
		set beta $alpha
		unset alpha
		break
	    }
	}
	return $d
    }
    getOrder [dicttest {a 1 c 2}] b c
} {b 1 c 2 2}

test dict-22.1 {dict with command} -body {
    dict with
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
test dict-22.2 {dict with command} -body {
    dict with v
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}

Changes to tests/encoding.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: encoding.test,v 1.21 2004/11/30 19:34:51 dgp Exp $

package require tcltest 2
namespace import -force ::tcltest::*

proc toutf {args} {
    global x
    lappend x "toutf $args"










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: encoding.test,v 1.21.2.1 2005/04/25 21:37:28 kennykb Exp $

package require tcltest 2
namespace import -force ::tcltest::*

proc toutf {args} {
    global x
    lappend x "toutf $args"
551
552
553
554
555
556
557













558
559
560
561
562
563
564
565
566
567
	    close $fb
	    
	    # Difference should be empty.
	    set diff
	} {}
    }
}














file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>










551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
	    close $fb
	    
	    # Difference should be empty.
	    set diff
	} {}
    }
}

testConstraint testgetdefenc [llength [info commands testgetdefenc]]

test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints {
    testgetdefenc 
} -setup {
     set origDir [testgetdefenc]
     testsetdefenc slappy
} -body {
     testgetdefenc
} -cleanup {
     testsetdefenc $origDir
} -result slappy

file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::tcltest::cleanupTests
return

Changes to tests/env.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  none (tests environment variable implementation)
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.20 2004/08/26 17:37:12 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Some tests require the "exec" command.













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  none (tests environment variable implementation)
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.20.2.2 2005/10/08 13:44:38 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Some tests require the "exec" command.
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
    set names [lsort [array names env]]
    if {$tcl_platform(platform) == "windows"} {
	lrem names HOME
        lrem names COMSPEC
	lrem names ComSpec
	lrem names ""
    }	
    foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH __CF_USER_TEXT_ENCODING } {
	lrem names $name
    }
    foreach p $names {
	puts "$p=$env($p)"
    }
    exit
} printenv]







|







72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
    set names [lsort [array names env]]
    if {$tcl_platform(platform) == "windows"} {
	lrem names HOME
        lrem names COMSPEC
	lrem names ComSpec
	lrem names ""
    }	
    foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH __CF_USER_TEXT_ENCODING } {
	lrem names $name
    }
    foreach p $names {
	puts "$p=$env($p)"
    }
    exit
} printenv]
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
    set env2($name) $env($name)
    unset env($name)
}

# Added the following lines so that child tcltest can actually find its
# library if the initial tcltest is run from a non-standard place.
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH} {
    if {[info exists env2($name)]} {
	set env($name) $env2($name);
    }
}

test env-2.1 {adding environment variables} {exec} {
    getenv







|







102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
    set env2($name) $env($name)
    unset env($name)
}

# Added the following lines so that child tcltest can actually find its
# library if the initial tcltest is run from a non-standard place.
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH} {
    if {[info exists env2($name)]} {
	set env($name) $env2($name);
    }
}

test env-2.1 {adding environment variables} {exec} {
    getenv
228
229
230
231
232
233
234







235
236
237
238
239
240
241
    set result
} {1 a 1}
test env-5.5 {corner cases - cannot have null entries on Windows} {win} {
    set env() a
    catch {set env()}
} {1}









# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {







>
>
>
>
>
>
>







228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
    set result
} {1 a 1}
test env-5.5 {corner cases - cannot have null entries on Windows} {win} {
    set env() a
    catch {set env()}
} {1}

test env-6.1 {corner cases - add lots of env variables} {} {
    set size [array size env]
    for {set i 0} {$i < 100} {incr i} {
	set env(BOGUS$i) $i
    }
    expr {[array size env] - $size}
} 100

# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {

Changes to tests/error.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  error, catch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.12 2004/09/30 23:06:49 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc foo {} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  error, catch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.12.2.1 2005/08/02 18:16:23 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc foo {} {
64
65
66
67
68
69
70
71
72
73
74




75
76
77
78
79
80
81
} 1

test error-1.7 {simple errors from commands} {
    catch {catch a b c d} b
    set b
} {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}

test error-1.8 {simple errors from commands} {nonPortable} {
    # This test is non-portable: it generates a memory fault on
    # machines like DEC Alphas (infinite recursion overflows
    # stack?)





    proc p {} {
        uplevel 1 catch p error
    }
    p
} 0








|



>
>
>
>







64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
} 1

test error-1.7 {simple errors from commands} {
    catch {catch a b c d} b
    set b
} {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}

test error-1.8 {simple errors from commands} {
    # This test is non-portable: it generates a memory fault on
    # machines like DEC Alphas (infinite recursion overflows
    # stack?)
    #
    # That claims sounds like a bug to be fixed rather than a portability
    # problem.  Anyhow, I believe it's out of date (bug's been fixed) so
    # this test is re-enabled.

    proc p {} {
        uplevel 1 catch p error
    }
    p
} 0

Changes to tests/eval.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  eval
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: eval.test,v 1.6 2004/05/19 12:23:13 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test eval-1.1 {single argument} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  eval
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: eval.test,v 1.6.2.1 2005/09/09 18:48:40 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test eval-1.1 {single argument} {
53
54
55
56
57
58
59























60
61
62
63
\"error \"test error\"\"
    (\"eval\" body line 3)
    invoked from within
\"eval {
	set a 1
	error \"test error\"
    }\""
























# cleanup
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
\"error \"test error\"\"
    (\"eval\" body line 3)
    invoked from within
\"eval {
	set a 1
	error \"test error\"
    }\""

test eval-3.1 {eval and pure lists} {
    eval [list list 1 2 3 4 5]
} {1 2 3 4 5}
test eval-3.2 {concatenating eval and pure lists} {
    eval [list list 1] [list 2 3 4 5]
} {1 2 3 4 5}
test eval-3.3 {eval and canonical lists} {
    set cmd [list list 1 2 3 4 5]
    # Force existance of utf-8 rep
    set dummy($cmd) $cmd
    unset dummy($cmd)
    eval $cmd
} {1 2 3 4 5}
test eval-3.4 {concatenating eval and canonical lists} {
    set cmd  [list list 1]
    set cmd2 [list 2 3 4 5]
    # Force existance of utf-8 rep
    set dummy($cmd) $cmd
    set dummy($cmd2) $cmd2
    unset dummy($cmd) dummy($cmd2)
    eval $cmd $cmd2
} {1 2 3 4 5}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/exec.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  exec
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: exec.test,v 1.22 2004/07/02 23:31:30 hobbs Exp $

package require tcltest 2
namespace import -force ::tcltest::*

# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  exec
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: exec.test,v 1.22.2.1 2005/08/02 18:16:23 dgp Exp $

package require tcltest 2
namespace import -force ::tcltest::*

# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
595
596
597
598
599
600
601




























602
603
604
605
606
607
608
609
610
611
    set fout [open $path(fooblah) w]
    puts $fout "contents"
    close $fout
    set res [list [catch {exec cat $path(fooblah)} msg] $msg]
    removeFile $f
    set res
} {0 contents}





























# cleanup

foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} {
    removeFile $file
}
unset -nocomplain path

::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
    set fout [open $path(fooblah) w]
    puts $fout "contents"
    close $fout
    set res [list [catch {exec cat $path(fooblah)} msg] $msg]
    removeFile $f
    set res
} {0 contents}

# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND.
test exec-19.1 {exec >> uses O_APPEND} {
    -constraints {exec unix}
    -setup {
	set tmpfile [makeFile {0} tmpfile.exec-19.1]
    }
    -body {
	# Note that we have to allow for the current contents of the
	# temporary file, which is why the result is 14 and not 12
	exec /bin/sh -c \
	    {for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
	exec /bin/sh -c \
	    {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
	# The above two shell invokations take about 3 seconds to
	# finish, so allow 5s (in case the machine is busy)
	after 5000
	# Check that no bytes have got lost through mixups with
	# overlapping appends, which is only guaranteed to work when
	# we set O_APPEND on the file descriptor in the [exec >>...]
	file size $tmpfile
    }
    -cleanup {
	removeFile $tmpfile
    }
    -result 14
}

# cleanup

foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} {
    removeFile $file
}
unset -nocomplain path

::tcltest::cleanupTests
return

Changes to tests/expr-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28


























































29
30
31
32
33
34
35
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.22 2004/11/03 22:12:51 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    testConstraint testmathfunctions 0
} else {
    testConstraint testmathfunctions 1
}



























































# First, test all of the integer operators individually.

test expr-old-1.1 {integer operators} {expr -4} -4
test expr-old-1.2 {integer operators} {expr -(1+4)} -5
test expr-old-1.3 {integer operators} {expr ~3} -4
test expr-old-1.4 {integer operators} {expr !2} 0
test expr-old-1.5 {integer operators} {expr !0} 1







|












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.22.2.11 2005/10/08 13:44:38 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    testConstraint testmathfunctions 0
} else {
    testConstraint testmathfunctions 1
}

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}
::tcltest::testConstraint ieeeFloatingPoint [testIEEE]

# First, test all of the integer operators individually.

test expr-old-1.1 {integer operators} {expr -4} -4
test expr-old-1.2 {integer operators} {expr -(1+4)} -5
test expr-old-1.3 {integer operators} {expr ~3} -4
test expr-old-1.4 {integer operators} {expr !2} 0
test expr-old-1.5 {integer operators} {expr !0} 1
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
         [expr {0 || $x}] [expr {$x || 0}]
} {1 1 1 1}

# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.

test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2
test expr-old-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3
test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7
test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0
test expr-old-2.5 {floating-point operators} {expr !2.1} 0
test expr-old-2.6 {floating-point operators} {expr !0.0} 1
test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46
test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0
test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75







|







145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
         [expr {0 || $x}] [expr {$x || 0}]
} {1 1 1 1}

# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.

test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2
test expr-old-2.2 {floating-point operators} {expr -(1.125+4.25)} -5.375
test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7
test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0
test expr-old-2.5 {floating-point operators} {expr !2.1} 0
test expr-old-2.6 {floating-point operators} {expr !0.0} 1
test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46
test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0
test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0
test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0
test expr-old-4.24 {string operators} {expr {"" eq ""}} 1
test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1
test expr-old-4.26 {string operators} {expr {"" ne ""}} 0
test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0
test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1

# The following tests are non-portable because on some systems "+"
# and "-" can be parsed as numbers.

test expr-old-4.29 {string operators} {nonPortable} {expr {"0" == "+"}} 0
test expr-old-4.30 {string operators} {nonPortable} {expr {"0" == "-"}} 0
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar

# Operators that aren't legal on string operands.

test expr-old-5.1 {illegal string operations} {
    list [catch {expr {-"a"}} msg] $msg







<
<
<
<
|
|







248
249
250
251
252
253
254




255
256
257
258
259
260
261
262
263
test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0
test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0
test expr-old-4.24 {string operators} {expr {"" eq ""}} 1
test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1
test expr-old-4.26 {string operators} {expr {"" ne ""}} 0
test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0
test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1




test expr-old-4.29 {string operators} {expr {"0" == "+"}} 0
test expr-old-4.30 {string operators} {expr {"0" == "-"}} 0
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar

# Operators that aren't legal on string operands.

test expr-old-5.1 {illegal string operations} {
    list [catch {expr {-"a"}} msg] $msg
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
test expr-old-25.12 {type conversions} {expr 2>"ab"} 0
test expr-old-25.13 {type conversions} {expr {2>" "}} 1
test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1
test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0
test expr-old-25.19 {type conversions} {eformat} {expr 2.0e15} 2e+15
test expr-old-25.20 {type conversions} {expr 10.0} 10.0

# Various error conditions.

test expr-old-26.1 {error conditions} {
    list [catch {expr 2+"a"} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}







|







478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
test expr-old-25.12 {type conversions} {expr 2>"ab"} 0
test expr-old-25.13 {type conversions} {expr {2>" "}} 1
test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1
test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0
test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0
test expr-old-25.20 {type conversions} {expr 10.0} 10.0

# Various error conditions.

test expr-old-26.1 {error conditions} {
    list [catch {expr 2+"a"} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
458
459
460
461
462
463
464
465
466
467



468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
} {1 {syntax error in expression "2+(4": looking for close parenthesis}}
test expr-old-26.8 {error conditions} {
    list [catch {expr 2/0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.9 {error conditions} {
    list [catch {expr 2%0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.10 {error conditions} {
    list [catch {expr 2.0/0.0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}



test expr-old-26.11 {error conditions} {
    list [catch {expr 2#} msg] $msg
} {1 {syntax error in expression "2#": extra tokens at end of expression}}
test expr-old-26.12 {error conditions} {
    list [catch {expr a.b} msg] $msg
} {1 {syntax error in expression "a.b": variable references require preceding $}}
test expr-old-26.13 {error conditions} {
    list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-old-26.14 {error conditions} {
    list [catch {expr 2:3} msg] $msg
} {1 {syntax error in expression "2:3": extra tokens at end of expression}}
test expr-old-26.15 {error conditions} {
    list [catch {expr a@b} msg] $msg
} {1 {syntax error in expression "a@b": variable references require preceding $}}
test expr-old-26.16 {error conditions} {
    list [catch {expr a[b} msg] $msg
} {1 {missing close-bracket}}
test expr-old-26.17 {error conditions} {
    list [catch {expr a`b} msg] $msg
} {1 {syntax error in expression "a`b": variable references require preceding $}}
test expr-old-26.18 {error conditions} {
    list [catch {expr \"a\"\{b} msg] $msg
} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\":\ extra\ tokens\ at\ end\ of\ expression}
test expr-old-26.19 {error conditions} {
    list [catch {expr a} msg] $msg
} {1 {syntax error in expression "a": variable references require preceding $}}
test expr-old-26.20 {error conditions} {
    list [catch expr msg] $msg
} {1 {wrong # args: should be "expr arg ?arg ...?"}}

# Cancelled evaluation.

test expr-old-27.1 {cancelled evaluation} {







|


>
>
>



|

|






|

|



|

|



|

|







512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
} {1 {syntax error in expression "2+(4": looking for close parenthesis}}
test expr-old-26.8 {error conditions} {
    list [catch {expr 2/0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.9 {error conditions} {
    list [catch {expr 2%0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.10a {error conditions} !ieeeFloatingPoint {
    list [catch {expr 2.0/0.0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.10b {error conditions} ieeeFloatingPoint {
    list [catch {expr 2.0/0.0} msg] $msg
} {0 Inf}
test expr-old-26.11 {error conditions} {
    list [catch {expr 2#} msg] $msg
} {1 {syntax error in expression "2#": extra tokens at end of expression}}
test expr-old-26.12 {error conditions} -body {
    list [catch {expr a.b} msg] $msg
} -match glob -result {1 {syntax error in expression "a.b": * preceding $*}}
test expr-old-26.13 {error conditions} {
    list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-old-26.14 {error conditions} {
    list [catch {expr 2:3} msg] $msg
} {1 {syntax error in expression "2:3": extra tokens at end of expression}}
test expr-old-26.15 {error conditions} -body {
    list [catch {expr a@b} msg] $msg
} -match glob -result {1 {syntax error in expression "a@b": * preceding $*}}
test expr-old-26.16 {error conditions} {
    list [catch {expr a[b} msg] $msg
} {1 {missing close-bracket}}
test expr-old-26.17 {error conditions} -body {
    list [catch {expr a`b} msg] $msg
} -match glob -result {1 {syntax error in expression "a`b": * preceding $*}}
test expr-old-26.18 {error conditions} {
    list [catch {expr \"a\"\{b} msg] $msg
} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\":\ extra\ tokens\ at\ end\ of\ expression}
test expr-old-26.19 {error conditions} -body {
    list [catch {expr a} msg] $msg
} -match glob -result {1 {syntax error in expression "a": * preceding $*}}
test expr-old-26.20 {error conditions} {
    list [catch expr msg] $msg
} {1 {wrong # args: should be "expr arg ?arg ...?"}}

# Cancelled evaluation.

test expr-old-27.1 {cancelled evaluation} {
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
test expr-old-27.9 {cancelled evaluation} {
    list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg
} {0 1}
test expr-old-27.10 {cancelled evaluation} {
    set x -1.0
    list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg
} {0 0}
test expr-old-27.11 {cancelled evaluation} {
    list [catch {expr {0 && foo}} msg] $msg
} {1 {syntax error in expression "0 && foo": variable references require preceding $}}
test expr-old-27.12 {cancelled evaluation} {
    list [catch {expr {0 ? 1 : foo}} msg] $msg
} {1 {syntax error in expression "0 ? 1 : foo": variable references require preceding $}}

# Tcl_ExprBool as used in "if" statements

test expr-old-28.1 {Tcl_ExprBoolean usage} {
    set a 1
    if {2} {set a 2}
    set a







|

|
|

|







592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
test expr-old-27.9 {cancelled evaluation} {
    list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg
} {0 1}
test expr-old-27.10 {cancelled evaluation} {
    set x -1.0
    list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg
} {0 0}
test expr-old-27.11 {cancelled evaluation} -body {
    list [catch {expr {0 && foo}} msg] $msg
} -match glob -result {1 {syntax error in expression "0 && foo": * preceding $*}}
test expr-old-27.12 {cancelled evaluation} -body {
    list [catch {expr {0 ? 1 : foo}} msg] $msg
} -match glob -result {1 {syntax error in expression "0 ? 1 : foo": * preceding $*}}

# Tcl_ExprBool as used in "if" statements

test expr-old-28.1 {Tcl_ExprBoolean usage} {
    set a 1
    if {2} {set a 2}
    set a
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
test expr-old-32.23 {math functions in expressions} {
    format %.6g [expr abs(-4)]
} {4}
test expr-old-32.24 {math functions in expressions} {
    format %.6g [expr abs(66)]
} {66}

# The following test is different for 32-bit versus 64-bit architectures.

if {int(0x80000000) > 0} {
    test expr-old-32.25a {math functions in expressions} {nonPortable} {
	list [catch {expr abs(0x8000000000000000)} msg] $msg
    } {1 {integer value too large to represent}}
} else {
    test expr-old-32.25b {math functions in expressions} {nonPortable} {
	list [catch {expr abs(0x80000000)} msg] $msg
    } {1 {integer value too large to represent}}
}

test expr-old-32.26 {math functions in expressions} {
    expr double(1)
} {1.0}
test expr-old-32.27 {math functions in expressions} {
    expr double(1.1)
} {1.1}







<
<
<
|
|
|
|
|
|
<
|







780
781
782
783
784
785
786



787
788
789
790
791
792

793
794
795
796
797
798
799
800
test expr-old-32.23 {math functions in expressions} {
    format %.6g [expr abs(-4)]
} {4}
test expr-old-32.24 {math functions in expressions} {
    format %.6g [expr abs(66)]
} {66}




test expr-old-32.25a {math functions in expressions} {
    list [catch {expr abs(0x8000000000000000)} msg] $msg
} {1 {integer value too large to represent}}

test expr-old-32.25b {math functions in expressions} {
    expr abs(0x80000000)

} 2147483648

test expr-old-32.26 {math functions in expressions} {
    expr double(1)
} {1.0}
test expr-old-32.27 {math functions in expressions} {
    expr double(1.1)
} {1.1}
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
} 246
test expr-old-32.44 {math functions in expressions} testmathfunctions {
    expr T2()*3
} 1035
test expr-old-32.45 {math functions in expressions} {
    expr (0 <= rand()) && (rand() < 1)
} {1}
test expr-old-32.46 {math functions in expressions} {
    list [catch {expr rand(24)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-32.47 {math functions in expressions} {
    list [catch {expr srand()} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-32.48 {math functions in expressions} {
    list [catch {expr srand(3.79)} msg] $msg
} {1 {can't use floating-point value as argument to srand}}
test expr-old-32.49 {math functions in expressions} {
    list [catch {expr srand("")} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.50 {math functions in expressions} {







|

|
|

|







848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
} 246
test expr-old-32.44 {math functions in expressions} testmathfunctions {
    expr T2()*3
} 1035
test expr-old-32.45 {math functions in expressions} {
    expr (0 <= rand()) && (rand() < 1)
} {1}
test expr-old-32.46 {math functions in expressions} -body {
    list [catch {expr rand(24)} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}
test expr-old-32.47 {math functions in expressions} -body {
    list [catch {expr srand()} msg] $msg
} -match glob -result {1 {too few arguments for math function*}}
test expr-old-32.48 {math functions in expressions} {
    list [catch {expr srand(3.79)} msg] $msg
} {1 {can't use floating-point value as argument to srand}}
test expr-old-32.49 {math functions in expressions} {
    list [catch {expr srand("")} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.50 {math functions in expressions} {
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877



878
879



880
881
882
883
884
885
886
887
888
889
890
891
892

893
894
895
896
897
898
899
900
901
test expr-old-33.3 {conversions and fancy args to math functions} {
    expr hypot ( 3 , (3.0 + 1.0) )
} 5.0
test expr-old-33.4 {conversions and fancy args to math functions} {
    format %.6g [expr cos(acos(0.1))]
} 0.1

test expr-old-34.1 {errors in math functions} {
    list [catch {expr func_2(1.0)} msg] $msg
} {1 {unknown math function "func_2"}}
test expr-old-34.2 {errors in math functions} {
    list [catch {expr func|(1.0)} msg] $msg
} {1 {syntax error in expression "func|(1.0)": variable references require preceding $}}
test expr-old-34.3 {errors in math functions} {
    list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-34.4 {errors in math functions} {
    list [catch {expr hypot(1.0 2.0)} msg] $msg
} {1 {syntax error in expression "hypot(1.0 2.0)": missing close parenthesis at end of function call}}
test expr-old-34.5 {errors in math functions} {
    list [catch {expr hypot(1.0, 2.0} msg] $msg
} {1 {syntax error in expression "hypot(1.0, 2.0": missing close parenthesis at end of function call}}
test expr-old-34.6 {errors in math functions} {
    list [catch {expr hypot(1.0 ,} msg] $msg
} {1 {syntax error in expression "hypot(1.0 ,": premature end of expression}}
test expr-old-34.7 {errors in math functions} {
    list [catch {expr hypot(1.0)} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-34.8 {errors in math functions} {
    list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-34.9 {errors in math functions} {
    list [catch {expr acos(-2.0)} msg] $msg $errorCode
} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}
test expr-old-34.10 {errors in math functions} {nonPortable} {
    list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.11 {errors in math functions} {
    list [catch {expr pow(3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.12 {errors in math functions} {



    list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}



test expr-old-34.13 {errors in math functions} {
    list [catch {expr int(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.14 {errors in math functions} {
    list [catch {expr int(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.15 {errors in math functions} {
    list [catch {expr round(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.16 {errors in math functions} {
    list [catch {expr round(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.17 {errors in math functions} testmathfunctions {

    list [catch {expr T1(4)} msg] $msg
} {1 {too many arguments for math function}}

test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
    expr 0289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
    set x 0289
    list [catch {expr {$x+1}} msg] $msg







|

|
|

|


|









|

|
|

|



|
|
|
|


|
>
>
>


>
>
>












|
>
|
|







890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
test expr-old-33.3 {conversions and fancy args to math functions} {
    expr hypot ( 3 , (3.0 + 1.0) )
} 5.0
test expr-old-33.4 {conversions and fancy args to math functions} {
    format %.6g [expr cos(acos(0.1))]
} 0.1

test expr-old-34.1 {errors in math functions} -body {
    list [catch {expr func_2(1.0)} msg] $msg
} -match glob -result {1 {* "*func_2"}}
test expr-old-34.2 {errors in math functions} -body {
    list [catch {expr func|(1.0)} msg] $msg
} -match glob -result {1 {syntax error in expression "func|(1.0)": * preceding $*}}
test expr-old-34.3 {errors in math functions} {
    list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {expected floating-point number but got "a b"}}
test expr-old-34.4 {errors in math functions} {
    list [catch {expr hypot(1.0 2.0)} msg] $msg
} {1 {syntax error in expression "hypot(1.0 2.0)": missing close parenthesis at end of function call}}
test expr-old-34.5 {errors in math functions} {
    list [catch {expr hypot(1.0, 2.0} msg] $msg
} {1 {syntax error in expression "hypot(1.0, 2.0": missing close parenthesis at end of function call}}
test expr-old-34.6 {errors in math functions} {
    list [catch {expr hypot(1.0 ,} msg] $msg
} {1 {syntax error in expression "hypot(1.0 ,": premature end of expression}}
test expr-old-34.7 {errors in math functions} -body {
    list [catch {expr hypot(1.0)} msg] $msg
} -match glob -result {1 {too few arguments for math function*}}
test expr-old-34.8 {errors in math functions} -body {
    list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}
test expr-old-34.9 {errors in math functions} {
    list [catch {expr acos(-2.0)} msg] $msg $errorCode
} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}
test expr-old-34.10 {errors in math functions} {
    list [catch {expr pow(-3, 1000001)} msg] $msg
} {0 -Inf}
test expr-old-34.11a {errors in math functions} !ieeeFloatingPoint {
    list [catch {expr pow(3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.11b {errors in math functions} ieeeFloatingPoint {
    list [catch {expr pow(3, 1000001)} msg] $msg
} {0 Inf}
test expr-old-34.12a {errors in math functions} !ieeeFloatingPoint {
    list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.12b {errors in math functions} ieeeFloatingPoint {
    list [catch {expr -14.0*exp(100000)} msg] $msg
} {0 -Inf}
test expr-old-34.13 {errors in math functions} {
    list [catch {expr int(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.14 {errors in math functions} {
    list [catch {expr int(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.15 {errors in math functions} {
    list [catch {expr round(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.16 {errors in math functions} {
    list [catch {expr round(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \
    -body {
        list [catch {expr T1(4)} msg] $msg
    } -match glob -result {1 {too many arguments for math function*}}

test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
    expr 0289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
    set x 0289
    list [catch {expr {$x+1}} msg] $msg
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
    set x {  +22}
    list [catch {expr {$x+1}} msg] $msg
} {0 23}
test expr-old-36.6 {ExprLooksLikeInt procedure} {
    set x {	-22}
    list [catch {expr {$x+1}} msg] $msg
} {0 -21}
test expr-old-36.7 {ExprLooksLikeInt procedure} {nonPortable unix} {
    list [catch {expr nan} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-old-36.8 {ExprLooksLikeInt procedure} {
    list [catch {expr 78e1} msg] $msg
} {0 780.0}
test expr-old-36.9 {ExprLooksLikeInt procedure} {
    list [catch {expr 24E1} msg] $msg
} {0 240.0}
test expr-old-36.10 {ExprLooksLikeInt procedure} {nonPortable unix} {
    list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}

# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
    # define a "too large integer"; this one works also for 64bit arith
    set x 665802003400000000000000
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}







|








|
|
|







971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
    set x {  +22}
    list [catch {expr {$x+1}} msg] $msg
} {0 23}
test expr-old-36.6 {ExprLooksLikeInt procedure} {
    set x {	-22}
    list [catch {expr {$x+1}} msg] $msg
} {0 -21}
test expr-old-36.7 {ExprLooksLikeInt procedure} {
    list [catch {expr nan} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-old-36.8 {ExprLooksLikeInt procedure} {
    list [catch {expr 78e1} msg] $msg
} {0 780.0}
test expr-old-36.9 {ExprLooksLikeInt procedure} {
    list [catch {expr 24E1} msg] $msg
} {0 240.0}
test expr-old-36.10 {ExprLooksLikeInt procedure} -body {
    expr 78e
} -returnCodes error -match glob -result {syntax error in expression "78e"*}

# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
    # define a "too large integer"; this one works also for 64bit arith
    set x 665802003400000000000000
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
954
955
956
957
958
959
960

961

962
963
964
965




966




























































































967
968
969
970







971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986










































987
988
989
990
991
992
993
994
995
996
997
998




} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
    set x " 0xffffffffffffffffffffffffffffffffffffff  "
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}

testConstraint testexprlong   [llength [info commands testexprlong]]

testConstraint testexprstring [llength [info commands testexprstring]]


test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong {
    testexprlong
} {This is a result: 5}

































































































test expr-old-38.1 {Verify Tcl_ExprString's basic operation} testexprstring {
    list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
	    [catch {testexprstring "1+"} msg] $msg
} {5 10.2 1 {syntax error in expression "1+": premature end of expression}}








#
# Test for bug #908375: rounding numbers that do not fit in a
# long but do fit in a wide
#

test expr-old-39.1 {Rounding with wide result} {
    set x 1.0e10
    set y [expr $x + 0.1]
    catch {
	set x [list [expr {$x == round($y)}] [expr $x == -round(-$y)]]
    }
    set x
} {1 1}
unset -nocomplain x y











































# Special test for Pentium arithmetic bug of 1994:

if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
    puts "Warning: this machine contains a defective Pentium processor"
    puts "that performs arithmetic incorrectly.  I recommend that you"
    puts "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::tcltest::cleanupTests
return











>

>


|

>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>
>
>
>
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
    set x " 0xffffffffffffffffffffffffffffffffffffff  "
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}

testConstraint testexprlong   [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
testConstraint longIs32bit    [expr {int(0x80000000) < 0}]

test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong {
    testexprlong 4+1
} {This is a result: 5}
#Check for [Bug 1109484]
test expr-old-37.2 {Tcl_ExprLong handles wide ints gracefully} testexprlong {
    testexprlong wide(1)+2
} {This is a result: 3}

test expr-old-37.3 {Tcl_ExprLong on the empty string} testexprlong {
    testexprlong ""
} {This is a result: 0}
test expr-old-37.4 {Tcl_ExprLong coerces doubles} testexprlong {
    testexprlong 3+.14159
} {This is a result: 3}
test expr-old-37.5 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
    testexprlong 0x80000000
} {This is a result: -2147483648}
test expr-old-37.6 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
    testexprlong 0xffffffff
} {This is a result: -1}
test expr-old-37.7 {Tcl_ExprLong handles overflows} \
    -constraints {testexprlong longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlong 0x100000000} result] $result
    } \
    -result {1 {integer value too large to represent*}}
test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong {
    testexprlong -0x80000000
} {This is a result: -2147483648}
test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
    testexprlong -0xffffffff
} {This is a result: 1}
test expr-old-37.10 {Tcl_ExprLong handles overflows} \
    -constraints {testexprlong longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlong -0x100000000} result] $result
    } \
    -result {1 {integer value too large to represent*}}
test expr-old-37.11 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit}  {
    testexprlong 2147483648.
} {This is a result: -2147483648}
test expr-old-37.12 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
    testexprlong 4294967295.
} {This is a result: -1}
test expr-old-37.13 {Tcl_ExprLong handles overflows} \
    -constraints {testexprlong longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlong 4294967296.} result] $result
    } \
    -result {1 {integer value too large to represent*}}
test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong {
    testexprlong -2147483648.
} {This is a result: -2147483648}
test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
    testexprlong -4294967295.
} {This is a result: 1}
test expr-old-37.16 {Tcl_ExprLong handles overflows} \
    -constraints {testexprlong longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlong 4294967296.} result] $result
    } \
    -result {1 {integer value too large to represent*}}

test expr-old-37.17 {Check that Tcl_ExprDouble doesn't modify interpreter result if no error} testexprdouble {
    testexprdouble 4.+1.
} {This is a result: 5.0}
#Check for [Bug 1109484]
test expr-old-37.18 {Tcl_ExprDouble on the empty string} testexprdouble {
    testexprdouble ""
} {This is a result: 0.0}
test expr-old-37.19 {Tcl_ExprDouble coerces wides} testexprdouble {
    testexprdouble 1[string repeat 0 17]
} {This is a result: 1e+17}
test expr-old-37.20 {Tcl_ExprDouble coerces bignums} testexprdouble {
    testexprdouble 1[string repeat 0 38]
} {This is a result: 1e+38}
test expr-old-37.21 {Tcl_ExprDouble handles overflows} testexprdouble {
    testexprdouble 17976931348623157[string repeat 0 292].
} {This is a result: 1.7976931348623157e+308}
test expr-old-37.22 {Tcl_ExprDouble handles overflows that look like int} \
    testexprdouble {
	testexprdouble 17976931348623157[string repeat 0 292]
    } {This is a result: 1.7976931348623157e+308}
test expr-old-37.23 {Tcl_ExprDouble handles overflows} \
    ieeeFloatingPoint&&testexprdouble {
	testexprdouble 17976931348623165[string repeat 0 292].
    } {This is a result: Inf}
test expr-old-37.24 {Tcl_ExprDouble handles overflows that look like int} \
    ieeeFloatingPoint&&testexprdouble {
	testexprdouble 17976931348623165[string repeat 0 292]
    } {This is a result: Inf}
test expr-old-37.25 {Tcl_ExprDouble and NaN} \
    ieeeFloatingPoint&&testexprdouble {
	list [catch {testexprdouble 0.0/0.0} result] $result
    } {1 {floating point value is Not a Number}}
    
test expr-old-38.1 {Verify Tcl_ExprString's basic operation} testexprstring {
    list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
	    [catch {testexprstring "1+"} msg] $msg
} {5 10.2 1 {syntax error in expression "1+": premature end of expression}}
test expr-old-38.2 {Tcl_ExprString} testexprstring {
    # This one is "magical"
    testexprstring {}
} 0
test expr-old-38.3 {Tcl_ExprString} -constraints testexprstring -body {
    testexprstring { }
} -returnCodes error -match glob -result *

#
# Test for bug #908375: rounding numbers that do not fit in a
# long but do fit in a wide
#

test expr-old-39.1 {Rounding with wide result} {
    set x 1.0e10
    set y [expr $x + 0.1]
    catch {
	set x [list [expr {$x == round($y)}] [expr $x == -round(-$y)]]
    }
    set x
} {1 1}
unset -nocomplain x y

#
# TIP #255 min and max math functions
#

test expr-old-40.1 {min math function} -body {
    expr {min(0)}
} -result 0
test expr-old-40.2 {min math function} -body {
    expr {min(0.0)}
} -result 0.0
test expr-old-40.3 {min math function} -body {
    list [catch {expr {min()}} msg] $msg
} -result {1 {too few arguments to math function "min"}}
test expr-old-40.4 {min math function} -body {
    expr {min(wide(-1) << 30, 4.5, -10)}
} -result [expr {wide(-1) << 30}]
test expr-old-40.5 {min math function} -body {
    list [catch {expr {min("a", 0)}} msg] $msg
} -result {1 {argument to math function didn't have numeric value}}
test expr-old-40.6 {min math function} -body {
    expr {min(300, "0xFF")}
} -result 255

test expr-old-41.1 {max math function} -body {
    expr {max(0)}
} -result 0
test expr-old-41.2 {max math function} -body {
    expr {max(0.0)}
} -result 0.0
test expr-old-41.3 {max math function} -body {
    list [catch {expr {max()}} msg] $msg
} -result {1 {too few arguments to math function "max"}}
test expr-old-41.4 {max math function} -body {
    expr {max(wide(1) << 30, 4.5, -10)}
} -result [expr {wide(1) << 30}]
test expr-old-41.5 {max math function} -body {
    list [catch {expr {max("a", 0)}} msg] $msg
} -result {1 {argument to math function didn't have numeric value}}
test expr-old-41.6 {max math function} -body {
    expr {max(200, "0xFF")}
} -result 255

# Special test for Pentium arithmetic bug of 1994:

if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
    puts "Warning: this machine contains a defective Pentium processor"
    puts "that performs arithmetic incorrectly.  I recommend that you"
    puts "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/expr.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23






































































24
25
26
27
28
29
30
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.30 2004/11/01 14:38:26 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testmathfunctions [expr {
    ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"})
}]







































































# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
}












|


|







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.30.2.24 2005/08/29 18:38:45 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testmathfunctions [expr {
    ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"})
}]

# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.

testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \
		ieeeValues(-NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]
# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
}
59
60
61
62
63
64
65
66


67
68
69
70
71
72
73
	"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
	[string range $c 1 end]]}
}
proc do_twelve_days {} {
    global xxx
    set xxx ""
    12days 1 1 1
    string length $xxx


}

# start of tests

catch {unset a b i x}

test expr-1.1 {TclCompileExprCmd: no expression} {







|
>
>







129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
	"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
	[string range $c 1 end]]}
}
proc do_twelve_days {} {
    global xxx
    set xxx ""
    12days 1 1 1
    set result [string length $xxx]
    unset xxx
    return $result
}

# start of tests

catch {unset a b i x}

test expr-1.1 {TclCompileExprCmd: no expression} {
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195









196
197
198
199
200
201
202
203
204
205
206
207
208
    set msg
} {syntax error in expression "7*2foo": extra tokens at end of expression}
test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
    expr {0001}
} 1

test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
test expr-3.2 {CompileCondExpr: error in lor expr} {
    catch {expr x||3} msg
    set msg
} {syntax error in expression "x||3": variable references require preceding $}
test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test expr-3.4 {CompileCondExpr: error compiling true arm} {
    catch {expr 3>2?2***3:66} msg
    set msg
} {syntax error in expression "3>2?2***3:66": unexpected operator *}
test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test expr-3.6 {CompileCondExpr: error compiling false arm} {
    catch {expr 2>3?44:2***3} msg
    set msg
} {syntax error in expression "2>3?44:2***3": unexpected operator *}
test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {unix nonPortable} {
    puts "Note: doing test expr-3.7 which can take several minutes to run"
    hello_world
} {Hello world}
catch {unset xxx}
test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {unix nonPortable} {
    puts "Note: doing test expr-3.8 which can take several minutes to run"

    do_twelve_days
} 2358
catch {unset xxx}

test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
test expr-4.2 {CompileLorExpr: error in land expr} {
    catch {expr x&&3} msg
    set msg
} {syntax error in expression "x&&3": variable references require preceding $} 
test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test expr-4.6 {CompileLorExpr: error compiling lor arm} {
    catch {expr 2***3||4.0} msg
    set msg
} {syntax error in expression "2***3||4.0": unexpected operator *}
test expr-4.7 {CompileLorExpr: error compiling lor arm} {
    catch {expr 1.3||2***3} msg
    set msg
} {syntax error in expression "1.3||2***3": unexpected operator *}
test expr-4.8 {CompileLorExpr: error compiling lor arms} {
    list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-4.9 {CompileLorExpr: long lor arm} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1










test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
test expr-5.2 {CompileLandExpr: error in bitor expr} {
    catch {expr x|3} msg
    set msg
} {syntax error in expression "x|3": variable references require preceding $} 
test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
test expr-5.7 {CompileLandExpr: error compiling land arm} {
    catch {expr 2***3&&4.0} msg
    set msg







|


|










|
<


<
|
<
>


<


|


|



















>
>
>
>
>
>
>
>
>


|


|







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233

234
235

236

237
238
239

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
    set msg
} {syntax error in expression "7*2foo": extra tokens at end of expression}
test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
    expr {0001}
} 1

test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
test expr-3.2 {CompileCondExpr: error in lor expr} -body {
    catch {expr x||3} msg
    set msg
} -match glob -result {syntax error in expression "x||3": * preceding $*}
test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test expr-3.4 {CompileCondExpr: error compiling true arm} {
    catch {expr 3>2?2***3:66} msg
    set msg
} {syntax error in expression "3>2?2***3:66": unexpected operator *}
test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test expr-3.6 {CompileCondExpr: error compiling false arm} {
    catch {expr 2>3?44:2***3} msg
    set msg
} {syntax error in expression "2>3?44:2***3": unexpected operator *}
test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {

    hello_world
} {Hello world}

test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} unix {

    # Fails with a stack overflow on threaded Windows builds
    do_twelve_days
} 2358


test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
test expr-4.2 {CompileLorExpr: error in land expr} -body {
    catch {expr x&&3} msg
    set msg
} -match glob -result {syntax error in expression "x&&3": *preceding $*} 
test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test expr-4.6 {CompileLorExpr: error compiling lor arm} {
    catch {expr 2***3||4.0} msg
    set msg
} {syntax error in expression "2***3||4.0": unexpected operator *}
test expr-4.7 {CompileLorExpr: error compiling lor arm} {
    catch {expr 1.3||2***3} msg
    set msg
} {syntax error in expression "1.3||2***3": unexpected operator *}
test expr-4.8 {CompileLorExpr: error compiling lor arms} {
    list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-4.9 {CompileLorExpr: long lor arm} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-4.10 {CompileLorExpr: error compiling ! operand} {
    list [catch {expr {!"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "!"}}
test expr-4.11 {CompileLorExpr: error compiling land arms} {
    list [catch {expr {"a"||0}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-4.12 {CompileLorExpr: error compiling land arms} {
    list [catch {expr {0||"a"}} msg] $msg
} {1 {expected boolean value but got "a"}}

test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
test expr-5.2 {CompileLandExpr: error in bitor expr} -body {
    catch {expr x|3} msg
    set msg
} -match glob -result {syntax error in expression "x|3": * preceding $*} 
test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
test expr-5.7 {CompileLandExpr: error compiling land arm} {
    catch {expr 2***3&&4.0} msg
    set msg
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324








































325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412



413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
test expr-5.10 {CompileLandExpr: long land arms} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1

test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
test expr-6.2 {CompileBitXorExpr: error in bitand expr} {
    catch {expr x|3} msg
    set msg
} {syntax error in expression "x|3": variable references require preceding $} 
test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
    catch {expr 2***3|6} msg
    set msg
} {syntax error in expression "2***3|6": unexpected operator *}
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
    catch {expr 2^x} msg
    set msg
} {syntax error in expression "2^x": variable references require preceding $}
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}

test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test expr-7.5 {CompileBitAndExpr: error in equality expr} {
    catch {expr x==3} msg
    set msg
} {syntax error in expression "x==3": variable references require preceding $}
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} {
    catch {expr 2***3&6} msg
    set msg
} {syntax error in expression "2***3&6": unexpected operator *}
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} {
    catch {expr 2&x} msg
    set msg
} {syntax error in expression "2&x": variable references require preceding $}
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-7.20 {CompileBitAndExpr: error in equality expr} {
    catch {expr xne3} msg
    set msg
} {syntax error in expression "xne3": variable references require preceding $} 

test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test expr-8.5 {CompileEqualityExpr: error in relational expr} {
    catch {expr x>3} msg
    set msg
} {syntax error in expression "x>3": variable references require preceding $}
test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
test expr-8.10 {CompileEqualityExpr: error compiling equality arm} {
    catch {expr 2***3==6} msg
    set msg
} {syntax error in expression "2***3==6": unexpected operator *}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
    catch {expr 2!=x} msg
    set msg
} {syntax error in expression "2!=x": variable references require preceding $}
test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1
test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq "�"}} 1
test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0
test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1
test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0
test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1
test expr-8.20 {CompileBitAndExpr: error in equality expr} {
    catch {expr x ne3} msg
    set msg
} {syntax error in expression "x ne3": variable references require preceding $} 
test expr-8.21 {CompileBitAndExpr: error in equality expr} {
    # These should be ""ed to avoid the error
    catch {expr a eq b} msg
    set msg
} {syntax error in expression "a eq b": variable references require preceding $}
test expr-8.22 {CompileBitAndExpr: error in equality expr} {
    catch {expr {false eqfalse}} msg
    set msg
} {syntax error in expression "false eqfalse": extra tokens at end of expression}
test expr-8.23 {CompileBitAndExpr: error in equality expr} {
    catch {expr {false nefalse}} msg
    set msg
} {syntax error in expression "false nefalse": extra tokens at end of expression}









































test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8

# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different

if {0x80000000 > 0} {
    test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
	expr {1<<63}
    } -9223372036854775808
} else {
    test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
	expr {1<<31}
    } -2147483648
}
test expr-9.6 {CompileRelationalExpr: error in shift expr} {
    catch {expr x>>3} msg
    set msg
} {syntax error in expression "x>>3": variable references require preceding $}
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test expr-9.9 {CompileRelationalExpr: error compiling relational arm} {
    catch {expr 2***3>6} msg
    set msg
} {syntax error in expression "2***3>6": unexpected operator *}
test expr-9.10 {CompileRelationalExpr: error compiling relational arm} {
    catch {expr 2<x} msg
    set msg
} {syntax error in expression "2<x": variable references require preceding $}

test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82
test expr-10.5 {CompileShiftExpr: error in add expr} {
    catch {expr x+3} msg
    set msg
} {syntax error in expression "x+3": variable references require preceding $}
test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test expr-10.8 {CompileShiftExpr: error compiling shift arm} {
    catch {expr 2***3>>6} msg
    set msg
} {syntax error in expression "2***3>>6": unexpected operator *}
test expr-10.9 {CompileShiftExpr: error compiling shift arm} {
    catch {expr 2<<x} msg
    set msg
} {syntax error in expression "2<<x": variable references require preceding $}
test expr-10.10 {CompileShiftExpr: runtime error} {
    list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-10.11 {CompileShiftExpr: runtime error} {
    list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}

test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
test expr-11.5 {CompileAddExpr: error in multiply expr} {
    catch {expr x*3} msg
    set msg
} {syntax error in expression "x*3": variable references require preceding $}
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} {
    catch {expr 2***3+6} msg
    set msg
} {syntax error in expression "2***3+6": unexpected operator *}
test expr-11.9 {CompileAddExpr: error compiling add arm} {
    catch {expr 2-x} msg
    set msg
} {syntax error in expression "2-x": variable references require preceding $}
test expr-11.10 {CompileAddExpr: runtime error} {
    list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-11.11 {CompileAddExpr: runtime error} {
    list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-11.12 {CompileAddExpr: runtime error} {
    list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13 {CompileAddExpr: runtime error} {
    list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}




test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test expr-12.5 {CompileMultiplyExpr: error in unary expr} {
    catch {expr ~x} msg
    set msg
} {syntax error in expression "~x": variable references require preceding $}
test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
    catch {expr 2*3%%6} msg
    set msg
} {syntax error in expression "2*3%%6": unexpected operator %}
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
    catch {expr 2*x} msg
    set msg
} {syntax error in expression "2*x": variable references require preceding $}
test expr-12.10 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}

test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} {
    catch {expr ~x} msg
    set msg
} {syntax error in expression "~x": variable references require preceding $}
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} {
    catch {expr !1.x} msg
    set msg
} {syntax error in expression "!1.x": extra tokens at end of expression}
test expr-13.10 {CompileUnaryExpr: runtime error} {
    list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}







|


|








|


|











|


|








|


|








|


|





|


|








|


|








|


|
|



|








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





<
<
<
<
<
|
|
|
<
|
|
|
<
|


|






|


|





|


|






|


|











|


|






|


|









|


>
>
>





|


|






|


|














|


|







295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447





448
449
450

451
452
453

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
test expr-5.10 {CompileLandExpr: long land arms} {
    set a "abcdefghijkl"
    set i 7
    expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1

test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
test expr-6.2 {CompileBitXorExpr: error in bitand expr} -body {
    catch {expr x|3} msg
    set msg
} -match glob -result {syntax error in expression "x|3": * preceding $*} 
test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
    catch {expr 2***3|6} msg
    set msg
} {syntax error in expression "2***3|6": unexpected operator *}
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
    catch {expr 2^x} msg
    set msg
} -match glob -result {syntax error in expression "2^x": * preceding $**}
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
    list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}

test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test expr-7.5 {CompileBitAndExpr: error in equality expr} -body {
    catch {expr x==3} msg
    set msg
} -match glob -result {syntax error in expression "x==3": * preceding $*}
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} {
    catch {expr 2***3&6} msg
    set msg
} {syntax error in expression "2***3&6": unexpected operator *}
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
    catch {expr 2&x} msg
    set msg
} -match glob -result {syntax error in expression "2&x": * preceding $*}
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
    list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-7.20 {CompileBitAndExpr: error in equality expr} -body {
    catch {expr xne3} msg
    set msg
} -match glob -result {syntax error in expression "xne3": * preceding $*} 

test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test expr-8.5 {CompileEqualityExpr: error in relational expr} -body {
    catch {expr x>3} msg
    set msg
} -match glob -result {syntax error in expression "x>3": * preceding $*}
test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
test expr-8.10 {CompileEqualityExpr: error compiling equality arm} {
    catch {expr 2***3==6} msg
    set msg
} {syntax error in expression "2***3==6": unexpected operator *}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} -body {
    catch {expr 2!=x} msg
    set msg
} -match glob -result {syntax error in expression "2!=x": * preceding $*}
test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1
test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq "�"}} 1
test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0
test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1
test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0
test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1
test expr-8.20 {CompileBitAndExpr: error in equality expr} -body {
    catch {expr x ne3} msg
    set msg
} -match glob -result {syntax error in expression "x ne3": * preceding $*} 
test expr-8.21 {CompileBitAndExpr: error in equality expr} -body {
    # These should be ""ed to avoid the error
    catch {expr a eq b} msg
    set msg
} -match glob -result {syntax error in expression "a eq b": * preceding $*}
test expr-8.22 {CompileBitAndExpr: error in equality expr} {
    catch {expr {false eqfalse}} msg
    set msg
} {syntax error in expression "false eqfalse": extra tokens at end of expression}
test expr-8.23 {CompileBitAndExpr: error in equality expr} {
    catch {expr {false nefalse}} msg
    set msg
} {syntax error in expression "false nefalse": extra tokens at end of expression}
test expr-8.24 {CompileEqualityExpr: simple equality exprs} {
    set x 12398712938788234
    expr {$x == 100}
} 0
test expr-8.25 {CompileEqualityExpr: simple equality exprs} {
    expr {"0x12 " == "0x12"}
} 1
test expr-8.26 {CompileEqualityExpr: simple equality exprs} {
    expr {"0x12 " eq "0x12"}
} 0
test expr-8.27 {CompileEqualityExpr: simple equality exprs} {
    expr {"1.0e100000000" == "0.0"}
} 0
test expr-8.28 {CompileEqualityExpr: just relational expr} {
    expr {"0y" == "0x0"}
} 0
test expr-8.29 {CompileEqualityExpr: just relational expr} {
    # Compare original strings from variables.
    set v1 "0y"
    set v2 "0x12"
    expr {$v1 < $v2}
} 0
test expr-8.30 {CompileEqualityExpr: simple equality exprs} {
    expr {"fake" != "bob"}
} 1
test expr-8.31 {expr edge cases} {
    list [catch {expr {1e}} err] $err
} {1 {syntax error in expression "1e": extra tokens at end of expression}}
test expr-8.32 {expr edge cases} {
    list [catch {expr {1E}} err] $err
} {1 {syntax error in expression "1E": extra tokens at end of expression}}
test expr-8.33 {expr edge cases} {
    list [catch {expr {1e+}} err] $err
} {1 {syntax error in expression "1e+": extra tokens at end of expression}}
test expr-8.34 {expr edge cases} {
    list [catch {expr {1E+}} err] $err
} {1 {syntax error in expression "1E+": extra tokens at end of expression}}
test expr-8.35 {expr edge cases} {
    list [catch {expr {1ea}} err] $err
} {1 {syntax error in expression "1ea": extra tokens at end of expression}}

test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8





test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
    expr {1<<63}
} -9223372036854775808

test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
    expr {1<<31}
} -2147483648

test expr-9.6 {CompileRelationalExpr: error in shift expr} -body {
    catch {expr x>>3} msg
    set msg
} -match glob -result {syntax error in expression "x>>3": * preceding $*}
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test expr-9.9 {CompileRelationalExpr: error compiling relational arm} {
    catch {expr 2***3>6} msg
    set msg
} {syntax error in expression "2***3>6": unexpected operator *}
test expr-9.10 {CompileRelationalExpr: error compiling relational arm} -body {
    catch {expr 2<x} msg
    set msg
} -match glob -result {syntax error in expression "2<x": * preceding $*}

test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82
test expr-10.5 {CompileShiftExpr: error in add expr} -body {
    catch {expr x+3} msg
    set msg
} -match glob -result {syntax error in expression "x+3": * preceding $*}
test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test expr-10.8 {CompileShiftExpr: error compiling shift arm} {
    catch {expr 2***3>>6} msg
    set msg
} {syntax error in expression "2***3>>6": unexpected operator *}
test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body {
    catch {expr 2<<x} msg
    set msg
} -match glob -result {syntax error in expression "2<<x": * preceding $*}
test expr-10.10 {CompileShiftExpr: runtime error} {
    list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-10.11 {CompileShiftExpr: runtime error} {
    list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}

test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
test expr-11.5 {CompileAddExpr: error in multiply expr} -body {
    catch {expr x*3} msg
    set msg
} -match glob -result {syntax error in expression "x*3": * preceding $*}
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} {
    catch {expr 2***3+6} msg
    set msg
} {syntax error in expression "2***3+6": unexpected operator *}
test expr-11.9 {CompileAddExpr: error compiling add arm} -body {
    catch {expr 2-x} msg
    set msg
} -match glob -result {syntax error in expression "2-x": * preceding $*}
test expr-11.10 {CompileAddExpr: runtime error} {
    list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-11.11 {CompileAddExpr: runtime error} {
    list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-11.12 {CompileAddExpr: runtime error} {
    list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint {
    list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13b {CompileAddExpr: runtime error} ieeeFloatingPoint {
    list [catch {expr {2.3/0.0}} msg] $msg
} {0 Inf}

test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test expr-12.5 {CompileMultiplyExpr: error in unary expr} -body {
    catch {expr ~x} msg
    set msg
} -match glob -result {syntax error in expression "~x": * preceding $*}
test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
    catch {expr 2*3%%6} msg
    set msg
} {syntax error in expression "2*3%%6": unexpected operator %}
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
    catch {expr 2*x} msg
    set msg
} -match glob -result {syntax error in expression "2*x": * preceding $*}
test expr-12.10 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
    list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}

test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
    catch {expr ~x} msg
    set msg
} -match glob -result {syntax error in expression "~x": * preceding $*}
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} {
    catch {expr !1.x} msg
    set msg
} {syntax error in expression "!1.x": extra tokens at end of expression}
test expr-13.10 {CompileUnaryExpr: runtime error} {
    list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
} 2.71828
test expr-14.26 {CompilePrimaryExpr: math function primary} {
    format %.6g [expr pow(2.0+0.1,3.0+0.1)]
} 9.97424
test expr-14.27 {CompilePrimaryExpr: error in math function primary} -body {
    catch {expr sinh::(2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments
    while *ing
"expr sinh::(2.0)"}
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg







|







675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
} 2.71828
test expr-14.26 {CompilePrimaryExpr: math function primary} {
    format %.6g [expr pow(2.0+0.1,3.0+0.1)]
} 9.97424
test expr-14.27 {CompilePrimaryExpr: error in math function primary} -body {
    catch {expr sinh::(2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh::(2.0)": * function arguments*
    while *ing
"expr sinh::(2.0)"}
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
} -match glob -result {syntax error in expression "@": character not legal in expressions
    while *ing
"expr @"}

test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    catch {expr sinh2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh2.0)": variable references require preceding $
    while *ing
"expr sinh2.0)"}
test expr-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set errorInfo
} -match glob -result {unknown math function "whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test expr-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set errorInfo
} -match glob -result {too many arguments for math function
    while *ing
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set errorInfo
} -match glob -result {too few arguments for math function
    while *ing
"expr sin()"}
test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set errorInfo
} -match glob -result {too few arguments for math function
    while *ing
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
    catch {expr sin(1} msg
    set errorInfo
} -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call
    while *ing







|





|





|





|





|







707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
} -match glob -result {syntax error in expression "@": character not legal in expressions
    while *ing
"expr @"}

test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    catch {expr sinh2.0)} msg
    set errorInfo
} -match glob -result {syntax error in expression "sinh2.0)": * preceding $*
    while *ing
"expr sinh2.0)"}
test expr-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set errorInfo
} -match glob -result {* "*whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test expr-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set errorInfo
} -match glob -result {too many arguments for math function*
    while *ing
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr sin()"}
test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
    catch {expr sin(1} msg
    set errorInfo
} -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call
    while *ing
774
775
776
777
778
779
780






































781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
test expr-21.6 	{non-numeric boolean literals} {expr yes   } yes
test expr-21.7 	{non-numeric boolean literals} {expr !false} 1
test expr-21.8 	{non-numeric boolean literals} {expr !true } 0
test expr-21.9 	{non-numeric boolean literals} {expr !off  } 1
test expr-21.10 {non-numeric boolean literals} {expr !on   } 0
test expr-21.11 {non-numeric boolean literals} {expr !no   } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes  } 0







































# Test for non-numeric float handling.
#
# These are non-portable because strtod()-support for "Inf" and "NaN"
# is so wildly variable.  This sucks...
test expr-22.1 {non-numeric floats} nonPortable {
    list [catch {expr {NaN + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.2 {non-numeric floats} nonPortable {
    list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} nonPortable {
    set nan NaN
    list [catch {expr {$nan + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.4 {non-numeric floats} nonPortable {
    set inf Inf
    list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} nonPortable {
    list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} nonPortable {
    list [catch {expr Inf} msg] $msg
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} nonPortable {
    list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} nonPortable {
    list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# Make sure [Bug 761471] stays fixed.
test expr-22.9 {non-numeric floats: shared object equality and NaN} {
    set x NaN
    expr {$x == $x}
} 0

# Tests for exponentiation handling
test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16
test expr-23.2 {CompileExponentialExpr: just exponential expr} {expr 0xff**2} 65025
test expr-23.3 {CompileExponentialExpr: just exponential expr} {expr -1**2} 1
test expr-23.4 {CompileExponentialExpr: just exponential expr} {expr 18**07} 612220032
test expr-23.5 {CompileExponentialExpr: error in exponential expr} {
    catch {expr x**3} msg
    set msg
} {syntax error in expression "x**3": variable references require preceding $}
test expr-23.6 {CompileExponentialExpr: simple expo exprs} {expr 0xff**0x3} 16581375
test expr-23.7 {CompileExponentialExpr: error compiling expo arm} {
    catch {expr (-3-)**6} msg
    set msg
} {syntax error in expression "(-3-)**6": unexpected close parenthesis}
test expr-23.8 {CompileExponentialExpr: error compiling expo arm} {
    catch {expr 2**x} msg
    set msg
} {syntax error in expression "2**x": variable references require preceding $}
test expr-23.9 {CompileExponentialExpr: runtime error} {
    list [catch {expr {24.0**"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "**"}}
test expr-23.10 {CompileExponentialExpr: runtime error} {
    list [catch {expr {"a"**2}} msg] $msg
} {1 {can't use non-numeric string as operand of "**"}}
test expr-23.11 {CompileExponentialExpr: runtime error} {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


<
<
<
|


|


|



|



|


|


|


|













|


|





|


|







888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934



935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
test expr-21.6 	{non-numeric boolean literals} {expr yes   } yes
test expr-21.7 	{non-numeric boolean literals} {expr !false} 1
test expr-21.8 	{non-numeric boolean literals} {expr !true } 0
test expr-21.9 	{non-numeric boolean literals} {expr !off  } 1
test expr-21.10 {non-numeric boolean literals} {expr !on   } 0
test expr-21.11 {non-numeric boolean literals} {expr !no   } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes  } 0
test expr-21.13 {non-numeric boolean literals} {
    list [catch {expr !truef} err] $err
} {1 {syntax error in expression "!truef": the word "truef" requires a preceding $ if it's a variable or function arguments if it's a function}}
test expr-21.14 {non-numeric boolean literals} {
    list [catch {expr !"truef"} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.15 {non-numeric boolean variables} {
    set v truef
    list [catch {expr {!$v}} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.16 {non-numeric boolean variables} {
    set v "true "
    list [catch {expr {!$v}} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.17 {non-numeric boolean variables} {
    set v "tru"
    list [catch {expr {!$v}} err] $err
} {0 0}
test expr-21.18 {non-numeric boolean variables} {
    set v "fal"
    list [catch {expr {!$v}} err] $err
} {0 1}
test expr-21.19 {non-numeric boolean variables} {
    set v "y"
    list [catch {expr {!$v}} err] $err
} {0 0}
test expr-21.20 {non-numeric boolean variables} {
    set v "of"
    list [catch {expr {!$v}} err] $err
} {0 1}
test expr-21.21 {non-numeric boolean variables} {
    set v "o"
    list [catch {expr {!$v}} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.22 {non-numeric boolean variables} {
    set v ""
    list [catch {expr {!$v}} err] $err
} {1 {can't use empty string as operand of "!"}}

# Test for non-numeric float handling.



test expr-22.1 {non-numeric floats} {
    list [catch {expr {NaN + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.2 {non-numeric floats} !ieeeFloatingPoint {
    list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} {
    set nan NaN
    list [catch {expr {$nan + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.4 {non-numeric floats} !ieeeFloatingPoint {
    set inf Inf
    list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} {
    list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} !ieeeFloatingPoint {
    list [catch {expr Inf} msg] $msg
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} {
    list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} !ieeeFloatingPoint {
    list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# Make sure [Bug 761471] stays fixed.
test expr-22.9 {non-numeric floats: shared object equality and NaN} {
    set x NaN
    expr {$x == $x}
} 0

# Tests for exponentiation handling
test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16
test expr-23.2 {CompileExponentialExpr: just exponential expr} {expr 0xff**2} 65025
test expr-23.3 {CompileExponentialExpr: just exponential expr} {expr -1**2} 1
test expr-23.4 {CompileExponentialExpr: just exponential expr} {expr 18**07} 612220032
test expr-23.5 {CompileExponentialExpr: error in exponential expr} -body {
    catch {expr x**3} msg
    set msg
} -match glob -result {syntax error in expression "x**3": * preceding $*}
test expr-23.6 {CompileExponentialExpr: simple expo exprs} {expr 0xff**0x3} 16581375
test expr-23.7 {CompileExponentialExpr: error compiling expo arm} {
    catch {expr (-3-)**6} msg
    set msg
} {syntax error in expression "(-3-)**6": unexpected close parenthesis}
test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body {
    catch {expr 2**x} msg
    set msg
} -match glob -result {syntax error in expression "2**x": * preceding $*}
test expr-23.9 {CompileExponentialExpr: runtime error} {
    list [catch {expr {24.0**"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "**"}}
test expr-23.10 {CompileExponentialExpr: runtime error} {
    list [catch {expr {"a"**2}} msg] $msg
} {1 {can't use non-numeric string as operand of "**"}}
test expr-23.11 {CompileExponentialExpr: runtime error} {
864
865
866
867
868
869
870


871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898



































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































899
900
901
902
903


904
905




test expr-23.27 {INST_EXPON: special cases} {expr {wide(-2)**wide(0)}} 1
test expr-23.28 {INST_EXPON: special cases} {expr {wide(-1)**wide(1)}} -1
test expr-23.29 {INST_EXPON: special cases} {expr {wide(-1)**wide(0)}} 1
test expr-23.30 {INST_EXPON: special cases} {expr {wide(-1)**wide(2)}} 1
test expr-23.31 {INST_EXPON: special cases} {expr {wide(-1)**wide(-1)}} -1
test expr-23.32 {INST_EXPON: special cases} {expr {wide(1)**wide(1234567)}} 1
test expr-23.33 {INST_EXPON: special cases} {expr {wide(2)**wide(-2)}} 0



# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0
test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0
test expr-24.5 {expr edge cases; shifting} nonPortable {expr int(5)<<32} 0
test expr-24.6 {expr edge cases; shifting} nonPortable {expr int(5)<<63} 0
test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480
test expr-24.8 {expr edge cases; shifting} {expr wide(10)<<63} 0
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0

# List membership tests
test expr-25.1 {'in' operator} {expr {"a" in "a b c"}} 1
test expr-25.2 {'in' operator} {expr {"a" in "b a c"}} 1
test expr-25.3 {'in' operator} {expr {"a" in "b c a"}} 1
test expr-25.4 {'in' operator} {expr {"a" in ""}} 0
test expr-25.5 {'in' operator} {expr {"" in {a b c ""}}} 1
test expr-25.6 {'in' operator} {expr {"" in "a b c"}} 0
test expr-25.7 {'in' operator} {expr {"" in ""}} 0

test expr-26.1 {'ni' operator} {expr {"a" ni "a b c"}} 0
test expr-26.2 {'ni' operator} {expr {"a" ni "b a c"}} 0
test expr-26.3 {'ni' operator} {expr {"a" ni "b c a"}} 0
test expr-26.4 {'ni' operator} {expr {"a" ni ""}} 1
test expr-26.5 {'ni' operator} {expr {"" ni {a b c ""}}} 0
test expr-26.6 {'ni' operator} {expr {"" ni "a b c"}} 1
test expr-26.7 {'ni' operator} {expr {"" ni ""}} 1




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































# cleanup
if {[info exists a]} {
    unset a
}


::tcltest::cleanupTests
return











>
>






|
|




















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





>
>


>
>
>
>
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
test expr-23.27 {INST_EXPON: special cases} {expr {wide(-2)**wide(0)}} 1
test expr-23.28 {INST_EXPON: special cases} {expr {wide(-1)**wide(1)}} -1
test expr-23.29 {INST_EXPON: special cases} {expr {wide(-1)**wide(0)}} 1
test expr-23.30 {INST_EXPON: special cases} {expr {wide(-1)**wide(2)}} 1
test expr-23.31 {INST_EXPON: special cases} {expr {wide(-1)**wide(-1)}} -1
test expr-23.32 {INST_EXPON: special cases} {expr {wide(1)**wide(1234567)}} 1
test expr-23.33 {INST_EXPON: special cases} {expr {wide(2)**wide(-2)}} 0
test expr-23.34 {INST_EXPON: special cases} {expr {2**0}} 1
test expr-23.35 {INST_EXPON: special cases} {expr {wide(2)**0}} 1

# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0
test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0
test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5)<<32} 0
test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5)<<63} 0
test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480
test expr-24.8 {expr edge cases; shifting} {expr wide(10)<<63} 0
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0

# List membership tests
test expr-25.1 {'in' operator} {expr {"a" in "a b c"}} 1
test expr-25.2 {'in' operator} {expr {"a" in "b a c"}} 1
test expr-25.3 {'in' operator} {expr {"a" in "b c a"}} 1
test expr-25.4 {'in' operator} {expr {"a" in ""}} 0
test expr-25.5 {'in' operator} {expr {"" in {a b c ""}}} 1
test expr-25.6 {'in' operator} {expr {"" in "a b c"}} 0
test expr-25.7 {'in' operator} {expr {"" in ""}} 0

test expr-26.1 {'ni' operator} {expr {"a" ni "a b c"}} 0
test expr-26.2 {'ni' operator} {expr {"a" ni "b a c"}} 0
test expr-26.3 {'ni' operator} {expr {"a" ni "b c a"}} 0
test expr-26.4 {'ni' operator} {expr {"a" ni ""}} 1
test expr-26.5 {'ni' operator} {expr {"" ni {a b c ""}}} 0
test expr-26.6 {'ni' operator} {expr {"" ni "a b c"}} 1
test expr-26.7 {'ni' operator} {expr {"" ni ""}} 1

foreach op {< <= == != > >=} {
    proc test$op {a b} [list expr "\$a $op \$b"]
}

test expr-27.1 {expr - correct ordering - not compiled} ieeeFloatingPoint {
    set problems {}
    # Ordering should be: -Infinity < -Normal < Subnormal < -0
    #                     < +0 < +Subnormal < +Normal < +Infinity
    # with equality within each class.
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity
    }
    set weights {
	-3 -2 -1 0 0 1 2 3
    }
    foreach name1 $names weight1 $weights {
	foreach name2 $names weight2 $weights {
	    foreach op {< <= == != >= >} {
		set shouldBe [expr "$weight1 $op $weight2"]
		set is [expr "\$ieeeValues($name1) $op \$ieeeValues($name2)"]
		if { $is != $shouldBe } {
		    append problems $name1 { } $op { } $name2 \
			":result is " $is ", should be $shouldBe" \n
		}
	    }
	}
    }
    set problems
} {}
test expr-27.2 {expr - correct ordering - compiled} ieeeFloatingPoint {
    set problems {}
    # Ordering should be: -Infinity < -Normal < Subnormal < -0
    #                     < +0 < +Subnormal < +Normal < +Infinity
    # with equality within each class.
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity
    }
    set weights {
	-3 -2 -1 0 0 1 2 3
    }
    foreach name1 $names weight1 $weights {
	foreach name2 $names weight2 $weights {
	    foreach op {< <= == != >= >} {
		set shouldBe [expr "$weight1 $op $weight2"]
		set is [test$op $ieeeValues($name1) $ieeeValues($name2)]
		if { $is != $shouldBe } {
		    append problems $name1 { } $op { } $name2 \
			":result is " $is ", should be $shouldBe" \n
		}
	    }
	}
    }
    set problems
} {}
test expr-27.3 {expr - NaN is unordered - not compiled} {
    set problems {}
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN
    }
    foreach name1 $names {
	foreach op {< <= == != >= >} sb {0 0 0 1 0 0} {
	    if "(\$ieeeValues($name1) $op \$ieeeValues(NaN)) != $sb " {
		append problems $name1 { } $op { } NaN \
		    ": result is 1, should be $sb" \n
	    }
	    if "(\$ieeeValues(NaN) $op \$ieeeValues($name1)) != $sb" {
		append problems NaN { } $op { } $name1 \
		    ": result is 1, should be $sb" \n
	    }
	}
    }
    set problems
} {}
test expr-27.4 {expr - NaN is unordered - compiled} {
    set problems {}
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN
    }
    foreach name1 $names {
	foreach op {< <= == != >= >} sb {0 0 0 1 0 0} {
	    if { [test$op $ieeeValues($name1) $ieeeValues(NaN)] != $sb } {
		append problems $ieeeValues($name1) { } $op { } $ieeeValues(NaN) \
		    ": result is 1, should be $sb" \n
	    }
	    if { [test$op $ieeeValues(NaN) $ieeeValues($name1)] != $sb } {
		append problems NaN { } $op { } $ieeeValues($name1) \
		    ": result is 1, should be $sb" \n
	    }
	}
    }
    set problems
} {}

proc convertToDouble { x } {
    variable ieeeValues
    binary scan [binary format d $x] c* bytes
    set result 0x
    if { $ieeeValues(littleEndian) } {
	for { set i 7 } { $i >= 0 } { incr i -1 } {
	    append result [format %02x [expr { [lindex $bytes $i] & 0xff }]]
	}
    } else {
	foreach byte $bytes {
	    append result [format %02x [expr { $byte & 0xff }]]
	}
    }
    return $result
}

test expr-28.1 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 0 E0 OK 00000000000000 E-1023
    convertToDouble 0E0
} 0x0000000000000000
test expr-28.2 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL -0 E0 OK -0000000000000 E-1023
    convertToDouble -0E0
} 0x8000000000000000
test expr-28.3 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 1 E0 OK 10000000000000 E0
    convertToDouble 1E0
} 0x3ff0000000000000
test expr-28.4 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 15 E-1 OK 18000000000000 E0
    convertToDouble 15E-1
} 0x3ff8000000000000
test expr-28.5 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 125 E-2 OK 14000000000000 E0
    convertToDouble 125E-2
} 0x3ff4000000000000
test expr-28.6 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 1125 E-3 OK 12000000000000 E0
    convertToDouble 1125E-3
} 0x3ff2000000000000
test expr-28.7 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 10625 E-4 OK 11000000000000 E0
    convertToDouble 10625E-4
} 0x3ff1000000000000
test expr-28.8 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 103125 E-5 OK 10800000000000 E0
    convertToDouble 103125E-5
} 0x3ff0800000000000
test expr-28.9 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 1015625 E-6 OK 10400000000000 E0
    convertToDouble 1015625E-6
} 0x3ff0400000000000
test expr-28.10 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 10078125 E-7 OK 10200000000000 E0
    convertToDouble 10078125E-7
} 0x3ff0200000000000
test expr-28.11 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d ALL 100390625 E-8 OK 10100000000000 E0
    convertToDouble 100390625E-8
} 0x3ff0100000000000
test expr-28.12 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 1001953125 E-9 OK 10080000000000 E0
    convertToDouble 1001953125E-9
} 0x3ff0080000000000
test expr-28.13 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 10009765625 E-10 OK 10040000000000 E0
    convertToDouble 10009765625E-10
} 0x3ff0040000000000
test expr-28.14 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 100048828125 E-11 OK 10020000000000 E0
    convertToDouble 100048828125E-11
} 0x3ff0020000000000
test expr-28.15 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 1000244140625 E-12 OK 10010000000000 E0
    convertToDouble 1000244140625E-12
} 0x3ff0010000000000
test expr-28.16 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 10001220703125 E-13 OK 10008000000000 E0
    convertToDouble 10001220703125E-13
} 0x3ff0008000000000
test expr-28.17 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 100006103515625 E-14 OK 10004000000000 E0
    convertToDouble 100006103515625E-14
} 0x3ff0004000000000
test expr-28.18 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 1000030517578125 E-15 OK 10002000000000 E0
    convertToDouble 1000030517578125E-15
} 0x3ff0002000000000
test expr-28.19 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee ALL 10000152587890625 E-16 OK 10001000000000 E0
    convertToDouble 10000152587890625E-16
} 0x3ff0001000000000
test expr-28.20 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8 E153 x 1317e5ef3ab327_0000000001& E511
    convertToDouble +8E153
} 0x5fe317e5ef3ab327
test expr-28.21 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1 E153 x -1317e5ef3ab327_0000000001& E508
    convertToDouble -1E153
} 0xdfb317e5ef3ab327
test expr-28.22 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9 E306 x 19a2028368022e_00000000001& E1019
    convertToDouble +9E306
} 0x7fa9a2028368022e
test expr-28.23 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -2 E153 x -1317e5ef3ab327_0000000001& E509
    convertToDouble -2E153
} 0xdfc317e5ef3ab327
test expr-28.24 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7 E-304 x 1eb8e84fa0b278_00000000001& E-1008
    convertToDouble +7E-304
} 0x00feb8e84fa0b278
test expr-28.25 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3 E-49 x -1c0f92a6276c9d_000000001& E-162
    convertToDouble -3E-49
} 0xb5dc0f92a6276c9d
test expr-28.26 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7 E-303 x 13339131c46f8b_00000000001& E-1004
    convertToDouble +7E-303
} 0x0133339131c46f8b
test expr-28.27 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6 E-49 x -1c0f92a6276c9d_000000001& E-161
    convertToDouble -6E-49
} 0xb5ec0f92a6276c9d
test expr-28.28 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9 E43 x 102498ea6df0c3_11111111110& E146
    convertToDouble +9E43
} 0x49102498ea6df0c4
test expr-28.29 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9 E44 x -142dbf25096cf4_1111111110& E149
    convertToDouble -9E44
} 0xc9442dbf25096cf5
test expr-28.30 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8 E303 x 1754e31cd072d9_1111111110& E1009
    convertToDouble +8E303
} 0x7f0754e31cd072da
test expr-28.31 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1 E303 x -1754e31cd072d9_1111111110& E1006
    convertToDouble -1E303
} 0xfed754e31cd072da
test expr-28.32 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7 E-287 x 1551603777f798_111111110& E-951
    convertToDouble +7E-287
} 0x048551603777f799
test expr-28.33 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -2 E-204 x -1410d9f9b2f7f2_11111110& E-677
    convertToDouble -2E-204
} 0x95a410d9f9b2f7f3
test expr-28.34 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2 E-205 x 100d7b2e28c65b_11111110& E-680
    convertToDouble +2E-205
} 0x15700d7b2e28c65c
test expr-28.35 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9 E-47 x -10711fed5b19a3_11111110& E-153
    convertToDouble -9E-47
} 0xb660711fed5b19a4
test expr-28.36 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +34 E195 x 1d1c26db7d0dae_000000000001& E652
    convertToDouble +34E195
} 0x68bd1c26db7d0dae
test expr-28.37 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -68 E195 x -1d1c26db7d0dae_000000000001& E653
    convertToDouble -68E195
} 0xe8cd1c26db7d0dae
test expr-28.38 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +85 E194 x 1d1c26db7d0dae_000000000001& E650
    convertToDouble +85E194
} 0x689d1c26db7d0dae
test expr-28.39 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -67 E97 x -139ac1ce2cc95f_000000000001& E328
    convertToDouble -67E97
} 0xd4739ac1ce2cc95f
test expr-28.40 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +93 E-234 x 127b2e4f210075_0000000000000001& E-771
    convertToDouble +93E-234
} 0x0fc27b2e4f210075
test expr-28.41 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -19 E-87 x -12e5f5dfa4fe9d_00000000000001& E-285
    convertToDouble -19E-87
} 0xae22e5f5dfa4fe9d
test expr-28.42 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +38 E-87 x 12e5f5dfa4fe9d_00000000000001& E-284
    convertToDouble +38E-87
} 0x2e32e5f5dfa4fe9d
test expr-28.43 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -38 E-88 x -1e3cbc9907fdc8_00000000000001& E-288
    convertToDouble -38E-88
} 0xadfe3cbc9907fdc8
test expr-28.44 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -69 E220 x -1e8aa8823a5db3_11111111110& E736
    convertToDouble -69E220
} 0xedfe8aa8823a5db4
test expr-28.45 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +18 E43 x 102498ea6df0c3_11111111110& E147
    convertToDouble +18E43
} 0x49202498ea6df0c4
test expr-28.46 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -36 E43 x -102498ea6df0c3_11111111110& E148
    convertToDouble -36E43
} 0xc9302498ea6df0c4
test expr-28.47 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +61 E-99 x 10ad836f269a16_11111111111110& E-323
    convertToDouble +61E-99
} 0x2bc0ad836f269a17
test expr-28.48 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -43 E-92 x -1c0794d9d40e95_111111111111110& E-301
    convertToDouble -43E-92
} 0xad2c0794d9d40e96
test expr-28.49 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +86 E-92 x 1c0794d9d40e95_111111111111110& E-300
    convertToDouble +86E-92
} 0x2d3c0794d9d40e96
test expr-28.50 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -51 E-74 x -1cd5bee57763e5_1111111111111110& E-241
    convertToDouble -51E-74
} 0xb0ecd5bee57763e6
test expr-28.51 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +283 E85 x 16c309024bab4b_00000000000000001& E290
    convertToDouble +283E85
} 0x5216c309024bab4b
test expr-28.52 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -566 E85 x -16c309024bab4b_00000000000000001& E291
    convertToDouble -566E85
} 0xd226c309024bab4b
test expr-28.53 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +589 E187 x 1526be9c22eb17_00000000000000001& E630
    convertToDouble +589E187
} 0x675526be9c22eb17
test expr-28.54 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -839 E143 x -1ae03f245703e2_000000000000001& E484
    convertToDouble -839E143
} 0xde3ae03f245703e2
test expr-28.55 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -744 E-234 x -127b2e4f210075_0000000000000001& E-768
    convertToDouble -744E-234
} 0x8ff27b2e4f210075
test expr-28.56 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +930 E-235 x 127b2e4f210075_0000000000000001& E-771
    convertToDouble +930E-235
} 0x0fc27b2e4f210075
test expr-28.57 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -186 E-234 x -127b2e4f210075_0000000000000001& E-770
    convertToDouble -186E-234
} 0x8fd27b2e4f210075
test expr-28.58 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +604 E175 x 17d93193f78fc5_1111111111111111110& E590
    convertToDouble +604E175
} 0x64d7d93193f78fc6
test expr-28.59 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -302 E175 x -17d93193f78fc5_1111111111111111110& E589
    convertToDouble -302E175
} 0xe4c7d93193f78fc6
test expr-28.60 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +755 E174 x 17d93193f78fc5_1111111111111111110& E587
    convertToDouble +755E174
} 0x64a7d93193f78fc6
test expr-28.61 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -151 E175 x -17d93193f78fc5_1111111111111111110& E588
    convertToDouble -151E175
} 0xe4b7d93193f78fc6
test expr-28.62 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +662 E-213 x 1bdb90e62a8cbc_1111111111111110& E-699
    convertToDouble +662E-213
} 0x144bdb90e62a8cbd
test expr-28.63 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -408 E-74 x -1cd5bee57763e5_1111111111111110& E-238
    convertToDouble -408E-74
} 0xb11cd5bee57763e6
test expr-28.64 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +510 E-75 x 1cd5bee57763e5_1111111111111110& E-241
    convertToDouble +510E-75
} 0x30ecd5bee57763e6
test expr-28.65 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6782 E55 x 159bd3ad46e346_0000000000000000001& E195
    convertToDouble +6782E55
} 0x4c259bd3ad46e346
test expr-28.66 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -2309 E92 x -1bac6f7d64d119_000000000000000001& E316
    convertToDouble -2309E92
} 0xd3bbac6f7d64d119
test expr-28.67 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7963 E34 x 1df4170f0fdecc_00000000000000000001& E125
    convertToDouble +7963E34
} 0x47cdf4170f0fdecc
test expr-28.68 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3391 E55 x -159bd3ad46e346_0000000000000000001& E194
    convertToDouble -3391E55
} 0xcc159bd3ad46e346
test expr-28.69 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7903 E-96 x 107c2d27a5b989_0000000000000000001& E-306
    convertToDouble +7903E-96
} 0x2cd07c2d27a5b989
test expr-28.70 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7611 E-226 x -119b8744033457_0000000000000000001& E-738
    convertToDouble -7611E-226
} 0x91d19b8744033457
test expr-28.71 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4907 E-196 x 11e90a8711440f_000000000000000001& E-639
    convertToDouble +4907E-196
} 0x1801e90a8711440f
test expr-28.72 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5547 E-311 x -13f190452a29f4_000000000000000001& E-1021
    convertToDouble -5547E-311
} 0x8023f190452a29f4
test expr-28.73 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +5311 E241 x 1f1ce3c887c25f_11111111111111111110& E812
    convertToDouble +5311E241
} 0x72bf1ce3c887c260
test expr-28.74 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5311 E243 x -184e91f4aa0fda_11111111111111111110& E819
    convertToDouble -5311E243
} 0xf3284e91f4aa0fdb
test expr-28.75 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +5311 E242 x 13720e5d54d97b_11111111111111111110& E816
    convertToDouble +5311E242
} 0x72f3720e5d54d97c
test expr-28.76 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9269 E-45 x 19d69455a53bd8_111111111111111111110& E-137
    convertToDouble +9269E-45
} 0x3769d69455a53bd9
test expr-28.77 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8559 E-289 x -104a81d35952fe_11111111111111111110& E-947
    convertToDouble -8559E-289
} 0x84c04a81d35952ff
test expr-28.78 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8699 E-276 x 12d2df246ecd2c_1111111111111111111110& E-904
    convertToDouble +8699E-276
} 0x0772d2df246ecd2d
test expr-28.79 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8085 E-64 x -14c98fce16152d_1111111111111111110& E-200
    convertToDouble -8085E-64
} 0xb374c98fce16152e
test expr-28.80 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +74819 E201 x 1dd455061eb3f1_0000000000000000000001& E683
    convertToDouble +74819E201
} 0x6aadd455061eb3f1
test expr-28.81 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -82081 E41 x -170105df3d47cb_000000000000000000000000001& E152
    convertToDouble -82081E41
} 0xc9770105df3d47cb
test expr-28.82 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +51881 E37 x 17d2950dc76da4_000000000000000000001& E138
    convertToDouble +51881E37
} 0x4897d2950dc76da4
test expr-28.83 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -55061 E157 x -1394fc0f33536c_000000000000000000001& E537
    convertToDouble -55061E157
} 0xe18394fc0f33536c
test expr-28.84 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +77402 E-215 x 10492a4a8a37fd_0000000000000000000000001& E-698
    convertToDouble +77402E-215
} 0x1450492a4a8a37fd
test expr-28.85 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -33891 E-92 x -1592f9932c06bd_00000000000000000000001& E-291
    convertToDouble -33891E-92
} 0xadc592f9932c06bd
test expr-28.86 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +38701 E-215 x 10492a4a8a37fd_0000000000000000000000001& E-699
    convertToDouble +38701E-215
} 0x1440492a4a8a37fd
test expr-28.87 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -82139 E-76 x -1d0681489839d5_00000000000000000000001& E-237
    convertToDouble -82139E-76
} 0xb12d0681489839d5
test expr-28.88 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +75859 E25 x 132645e1ba93ef_11111111111111111111110& E99
    convertToDouble +75859E25
} 0x46232645e1ba93f0
test expr-28.89 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +89509 E140 x 16f02bee68670c_1111111111111111111110& E481
    convertToDouble +89509E140
} 0x5e06f02bee68670d
test expr-28.90 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -57533 E287 x -1272ed2307f569_1111111111111111111110& E969
    convertToDouble -57533E287
} 0xfc8272ed2307f56a
test expr-28.91 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +46073 E-32 x 12405b773fbdf2_11111111111111111111110& E-91
    convertToDouble +46073E-32
} 0x3a42405b773fbdf3
test expr-28.92 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -92146 E-32 x -12405b773fbdf2_11111111111111111111110& E-90
    convertToDouble -92146E-32
} 0xba52405b773fbdf3
test expr-28.93 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +83771 E-74 x 17206bfc4ccabd_11111111111111111111110& E-230
    convertToDouble +83771E-74
} 0x3197206bfc4ccabe
test expr-28.94 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -34796 E-276 x -12d2df246ecd2c_1111111111111111111110& E-902
    convertToDouble -34796E-276
} 0x8792d2df246ecd2d
test expr-28.95 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +584169 E229 x 1d657059dc79aa_00000000000000000000000000001& E779
    convertToDouble +584169E229
} 0x70ad657059dc79aa
test expr-28.96 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +164162 E41 x 170105df3d47cb_000000000000000000000000001& E153
    convertToDouble +164162E41
} 0x49870105df3d47cb
test expr-28.97 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -328324 E41 x -170105df3d47cb_000000000000000000000000001& E154
    convertToDouble -328324E41
} 0xc9970105df3d47cb
test expr-28.98 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +209901 E-11 x 119b96f36ec68b_00000000000000000000000001& E-19
    convertToDouble +209901E-11
} 0x3ec19b96f36ec68b
test expr-28.99 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -419802 E-11 x -119b96f36ec68b_00000000000000000000000001& E-18
    convertToDouble -419802E-11
} 0xbed19b96f36ec68b
test expr-28.100 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +940189 E-112 x 1b99d6240c1a28_00000000000000000000000001& E-353
    convertToDouble +940189E-112
} 0x29eb99d6240c1a28
test expr-28.101 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -892771 E-213 x -125818c7294f27_0000000000000000000000000001& E-688
    convertToDouble -892771E-213
} 0x94f25818c7294f27
test expr-28.102 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +757803 E120 x 11e968b555bb80_11111111111111111111111111110& E418
    convertToDouble +757803E120
} 0x5a11e968b555bb81
test expr-28.103 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -252601 E120 x -17e1e0f1c7a4ab_11111111111111111111111111110& E416
    convertToDouble -252601E120
} 0xd9f7e1e0f1c7a4ac
test expr-28.104 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +252601 E121 x 1dda592e398dd6_1111111111111111111111111110& E419
    convertToDouble +252601E121
} 0x5a2dda592e398dd7
test expr-28.105 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -505202 E120 x -17e1e0f1c7a4ab_11111111111111111111111111110& E417
    convertToDouble -505202E120
} 0xda07e1e0f1c7a4ac
test expr-28.106 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +970811 E-264 x 1dda6b965c9629_11111111111111111111111110& E-858
    convertToDouble +970811E-264
} 0x0a5dda6b965c962a
test expr-28.107 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -654839 E-60 x -100e7db3b3f241_111111111111111111111111110& E-180
    convertToDouble -654839E-60
} 0xb4b00e7db3b3f242
test expr-28.108 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +289767 E-178 x 1caad28f23a100_11111111111111111111111110& E-574
    convertToDouble +289767E-178
} 0x1c1caad28f23a101
test expr-28.109 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -579534 E-178 x -1caad28f23a100_11111111111111111111111110& E-573
    convertToDouble -579534E-178
} 0x9c2caad28f23a101
test expr-28.110 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8823691 E130 x -1e597c0b94b7ae_00000000000000000000000000000001& E454
    convertToDouble -8823691E130
} 0xdc5e597c0b94b7ae
test expr-28.111 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9346704 E229 x 1d657059dc79aa_00000000000000000000000000001& E783
    convertToDouble +9346704E229
} 0x70ed657059dc79aa
test expr-28.112 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1168338 E229 x -1d657059dc79aa_00000000000000000000000000001& E780
    convertToDouble -1168338E229
} 0xf0bd657059dc79aa
test expr-28.113 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6063369 E-136 x -1ae6148e3902b3_000000000000000000000000000001& E-430
    convertToDouble -6063369E-136
} 0xa51ae6148e3902b3
test expr-28.114 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3865421 E-225 x 15d4fe53afec65_00000000000000000000000000001& E-726
    convertToDouble +3865421E-225
} 0x1295d4fe53afec65
test expr-28.115 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5783893 E-127 x -17e5902ce0e151_000000000000000000000000000000001& E-400
    convertToDouble -5783893E-127
} 0xa6f7e5902ce0e151
test expr-28.116 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2572231 E223 x 10f73be1dff9ac_111111111111111111111111111110& E762
    convertToDouble +2572231E223
} 0x6f90f73be1dff9ad
test expr-28.117 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5144462 E223 x -10f73be1dff9ac_111111111111111111111111111110& E763
    convertToDouble -5144462E223
} 0xefa0f73be1dff9ad
test expr-28.118 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +1817623 E109 x 1d85f96f3fe659_11111111111111111111111111110& E382
    convertToDouble +1817623E109
} 0x57dd85f96f3fe65a
test expr-28.119 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6431543 E-97 x 14f6493f34a0bc_11111111111111111111111111110& E-300
    convertToDouble +6431543E-97
} 0x2d34f6493f34a0bd
test expr-28.120 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -5444097 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-48
    convertToDouble -5444097E-21
} 0xbcf8849dd33c95af
test expr-28.121 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8076999 E-121 x 1fd332f7e2e3b2_11111111111111111111111111110& E-380
    convertToDouble +8076999E-121
} 0x283fd332f7e2e3b3
test expr-28.122 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9997649 E-270 x -1425e9d29e558d_1111111111111111111111111110& E-874
    convertToDouble -9997649E-270
} 0x895425e9d29e558e
test expr-28.123 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +50609263 E157 x 1193aff1f1c8e3_000000000000000000000000000000001& E547
    convertToDouble +50609263E157
} 0x622193aff1f1c8e3
test expr-28.124 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +70589528 E130 x 1e597c0b94b7ae_00000000000000000000000000000001& E457
    convertToDouble +70589528E130
} 0x5c8e597c0b94b7ae
test expr-28.125 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -88236910 E129 x -1e597c0b94b7ae_00000000000000000000000000000001& E454
    convertToDouble -88236910E129
} 0xdc5e597c0b94b7ae
test expr-28.126 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +87575437 E-310 x 1805c19e680456_0000000000000000000000000000000000001& E-1004
    convertToDouble +87575437E-310
} 0x013805c19e680456
test expr-28.127 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -23135572 E-127 x -17e5902ce0e151_000000000000000000000000000000001& E-398
    convertToDouble -23135572E-127
} 0xa717e5902ce0e151
test expr-28.128 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +85900881 E177 x 14375b2214e1b4_111111111111111111111111111111110& E614
    convertToDouble +85900881E177
} 0x6654375b2214e1b5
test expr-28.129 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -84863171 E113 x -1a4a8e56474b8b_111111111111111111111111111111110& E401
    convertToDouble -84863171E113
} 0xd90a4a8e56474b8c
test expr-28.130 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +68761586 E232 x 1a662c350f37f2_1111111111111111111111111111110& E796
    convertToDouble +68761586E232
} 0x71ba662c350f37f3
test expr-28.131 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -50464069 E286 x -1948dd06de561e_1111111111111111111111111111110& E975
    convertToDouble -50464069E286
} 0xfce948dd06de561f
test expr-28.132 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +27869147 E-248 x 1dbbac6f83a820_111111111111111111111111111111111110& E-800
    convertToDouble +27869147E-248
} 0x0dfdbbac6f83a821
test expr-28.133 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -55738294 E-248 x -1dbbac6f83a820_111111111111111111111111111111111110& E-799
    convertToDouble -55738294E-248
} 0x8e0dbbac6f83a821
test expr-28.134 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +70176353 E-53 x 100683a21de854_1111111111111111111111111111111110& E-150
    convertToDouble +70176353E-53
} 0x36900683a21de855
test expr-28.135 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -80555086 E-32 x -1f29ca0ff893b0_111111111111111111111111111111110& E-81
    convertToDouble -80555086E-32
} 0xbaef29ca0ff893b1
test expr-28.136 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -491080654 E121 x -1c569e968e0944_00000000000000000000000000000000000000001& E430
    convertToDouble -491080654E121
} 0xdadc569e968e0944
test expr-28.137 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +526250918 E287 x 14997a298b2f2e_0000000000000000000000000000000000001& E982
    convertToDouble +526250918E287
} 0x7d54997a298b2f2e
test expr-28.138 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -245540327 E121 x -1c569e968e0944_00000000000000000000000000000000000000001& E429
    convertToDouble -245540327E121
} 0xdacc569e968e0944
test expr-28.139 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -175150874 E-310 x -1805c19e680456_0000000000000000000000000000000000001& E-1003
    convertToDouble -175150874E-310
} 0x814805c19e680456
test expr-28.140 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +350301748 E-310 x 1805c19e680456_0000000000000000000000000000000000001& E-1002
    convertToDouble +350301748E-310
} 0x015805c19e680456
test expr-28.141 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -437877185 E-311 x -1805c19e680456_0000000000000000000000000000000000001& E-1005
    convertToDouble -437877185E-311
} 0x812805c19e680456
test expr-28.142 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +458117166 E52 x 16ce94febdc7a4_1111111111111111111111111111111111110& E201
    convertToDouble +458117166E52
} 0x4c86ce94febdc7a5
test expr-28.143 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -916234332 E52 x -16ce94febdc7a4_1111111111111111111111111111111111110& E202
    convertToDouble -916234332E52
} 0xcc96ce94febdc7a5
test expr-28.144 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +229058583 E52 x 16ce94febdc7a4_1111111111111111111111111111111111110& E200
    convertToDouble +229058583E52
} 0x4c76ce94febdc7a5
test expr-28.145 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -525789935 E98 x -16ecdc2a58fc64_11111111111111111111111111111111110& E354
    convertToDouble -525789935E98
} 0xd616ecdc2a58fc65
test expr-28.146 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +282926897 E-227 x 1ff5a70d3d2fee_1111111111111111111111111111111111110& E-727
    convertToDouble +282926897E-227
} 0x128ff5a70d3d2fef
test expr-28.147 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -565853794 E-227 x -1ff5a70d3d2fee_1111111111111111111111111111111111110& E-726
    convertToDouble -565853794E-227
} 0x929ff5a70d3d2fef
test expr-28.148 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +667284113 E-240 x 109355f8050c01_111111111111111111111111111111111110& E-768
    convertToDouble +667284113E-240
} 0x0ff09355f8050c02
test expr-28.149 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -971212611 E-126 x -1397d3c9745d2e_111111111111111111111111111111111111110& E-389
    convertToDouble -971212611E-126
} 0xa7a397d3c9745d2f
test expr-28.150 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9981396317 E-182 x 18afe10a2a66aa_0000000000000000000000000000000000000001& E-572
    convertToDouble +9981396317E-182
} 0x1c38afe10a2a66aa
test expr-28.151 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5035231965 E-156 x -101891fc4717fd_00000000000000000000000000000000000001& E-486
    convertToDouble -5035231965E-156
} 0xa1901891fc4717fd
test expr-28.152 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8336960483 E-153 x 1a06a1024b95e1_000000000000000000000000000000000000001& E-476
    convertToDouble +8336960483E-153
} 0x223a06a1024b95e1
test expr-28.153 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8056371144 E-155 x -101891fc4717fd_00000000000000000000000000000000000001& E-482
    convertToDouble -8056371144E-155
} 0xa1d01891fc4717fd
test expr-28.154 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6418488827 E79 x 1021f14ed7b3f9_11111111111111111111111111111111111111110& E295
    convertToDouble +6418488827E79
} 0x526021f14ed7b3fa
test expr-28.155 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3981006983 E252 x -102ebaf189d5f1_1111111111111111111111111111111111111110& E869
    convertToDouble -3981006983E252
} 0xf6402ebaf189d5f2
test expr-28.156 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7962013966 E252 x 102ebaf189d5f1_1111111111111111111111111111111111111110& E870
    convertToDouble +7962013966E252
} 0x76502ebaf189d5f2
test expr-28.157 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -4713898551 E261 x -11d8813536e0df_11111111111111111111111111111111111110& E899
    convertToDouble -4713898551E261
} 0xf821d8813536e0e0
test expr-28.158 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8715380633 E-58 x 14614c3219891e_11111111111111111111111111111111111111110& E-160
    convertToDouble +8715380633E-58
} 0x35f4614c3219891f
test expr-28.159 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9078555839 E-109 x -1fc575867314ed_111111111111111111111111111111111111111111110& E-330
    convertToDouble -9078555839E-109
} 0xab5fc575867314ee
test expr-28.160 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9712126110 E-127 x 1397d3c9745d2e_111111111111111111111111111111111111110& E-389
    convertToDouble +9712126110E-127
} 0x27a397d3c9745d2f
test expr-28.161 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +42333842451 E201 x 10189a26df575f_000000000000000000000000000000000000000000001& E703
    convertToDouble +42333842451E201
} 0x6be0189a26df575f
test expr-28.162 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -84667684902 E201 x -10189a26df575f_000000000000000000000000000000000000000000001& E704
    convertToDouble -84667684902E201
} 0xebf0189a26df575f
test expr-28.163 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +23792120709 E-315 x 10b517dc5d3212_00000000000000000000000000000000000000001& E-1012
    convertToDouble +23792120709E-315
} 0x00b0b517dc5d3212
test expr-28.164 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -78564021519 E-227 x -1155515fd37265_00000000000000000000000000000000000000000001& E-718
    convertToDouble -78564021519E-227
} 0x931155515fd37265
test expr-28.165 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +71812054883 E-188 x 1747b46d78c6fe_00000000000000000000000000000000000000001& E-589
    convertToDouble +71812054883E-188
} 0x1b2747b46d78c6fe
test expr-28.166 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -30311163631 E-116 x -163ef6f560afe7_00000000000000000000000000000000000000001& E-351
    convertToDouble -30311163631E-116
} 0xaa063ef6f560afe7
test expr-28.167 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +71803914657 E292 x 10c0c44cdc2c05_11111111111111111111111111111111111111111110& E1006
    convertToDouble +71803914657E292
} 0x7ed0c0c44cdc2c06
test expr-28.168 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +36314223356 E-109 x 1fc575867314ed_111111111111111111111111111111111111111111110& E-328
    convertToDouble +36314223356E-109
} 0x2b7fc575867314ee
test expr-28.169 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +18157111678 E-109 x 1fc575867314ed_111111111111111111111111111111111111111111110& E-329
    convertToDouble +18157111678E-109
} 0x2b6fc575867314ee
test expr-28.170 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -45392779195 E-110 x -1fc575867314ed_111111111111111111111111111111111111111111110& E-331
    convertToDouble -45392779195E-110
} 0xab4fc575867314ee
test expr-28.171 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +778380362293 E218 x 19ab8261990292_0000000000000000000000000000000000000000000000000001& E763
    convertToDouble +778380362293E218
} 0x6fa9ab8261990292
test expr-28.172 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -685763015669 E280 x -15fd7aa44d9477_000000000000000000000000000000000000000000000001& E969
    convertToDouble -685763015669E280
} 0xfc85fd7aa44d9477
test expr-28.173 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +952918668151 E70 x 14177a9915fbf8_00000000000000000000000000000000000000000000001& E272
    convertToDouble +952918668151E70
} 0x50f4177a9915fbf8
test expr-28.174 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -548357443505 E32 x -13abde2775e9b5_0000000000000000000000000000000000000000000001& E145
    convertToDouble -548357443505E32
} 0xc903abde2775e9b5
test expr-28.175 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +384865004907 E-285 x 1aa65b58639e69_00000000000000000000000000000000000000000000001& E-909
    convertToDouble +384865004907E-285
} 0x072aa65b58639e69
test expr-28.176 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -769730009814 E-285 x -1aa65b58639e69_00000000000000000000000000000000000000000000001& E-908
    convertToDouble -769730009814E-285
} 0x873aa65b58639e69
test expr-28.177 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +697015418417 E-93 x 152847dad80453_0000000000000000000000000000000000000000000001& E-270
    convertToDouble +697015418417E-93
} 0x2f152847dad80453
test expr-28.178 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -915654049301 E-28 x -1a645598d05989_0000000000000000000000000000000000000000000001& E-54
    convertToDouble -915654049301E-28
} 0xbc9a645598d05989
test expr-28.179 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +178548656339 E169 x 1b89d67c5b6d24_111111111111111111111111111111111111111111110& E598
    convertToDouble +178548656339E169
} 0x655b89d67c5b6d25
test expr-28.180 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -742522891517 E259 x -1c1c352fc3c308_11111111111111111111111111111111111111111111110& E899
    convertToDouble -742522891517E259
} 0xf82c1c352fc3c309
test expr-28.181 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +742522891517 E258 x 167cf7596968d3_11111111111111111111111111111111111111111111110& E896
    convertToDouble +742522891517E258
} 0x77f67cf7596968d4
test expr-28.182 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -357097312678 E169 x -1b89d67c5b6d24_111111111111111111111111111111111111111111110& E599
    convertToDouble -357097312678E169
} 0xe56b89d67c5b6d25
test expr-28.183 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3113521449172 E218 x -19ab8261990292_0000000000000000000000000000000000000000000000000001& E765
    convertToDouble -3113521449172E218
} 0xefc9ab8261990292
test expr-28.184 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3891901811465 E217 x 19ab8261990292_0000000000000000000000000000000000000000000000000001& E762
    convertToDouble +3891901811465E217
} 0x6f99ab8261990292
test expr-28.185 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1556760724586 E218 x -19ab8261990292_0000000000000000000000000000000000000000000000000001& E764
    convertToDouble -1556760724586E218
} 0xefb9ab8261990292
test expr-28.186 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9997878507563 E-195 x 153db2fea1ea31_0000000000000000000000000000000000000000000000001& E-605
    convertToDouble +9997878507563E-195
} 0x1a253db2fea1ea31
test expr-28.187 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7247563029154 E-319 x -10493f056e9ef3_0000000000000000000000000000000000000000000000001& E-1017
    convertToDouble -7247563029154E-319
} 0x8060493f056e9ef3
test expr-28.188 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3623781514577 E-319 x 10493f056e9ef3_0000000000000000000000000000000000000000000000001& E-1018
    convertToDouble +3623781514577E-319
} 0x0050493f056e9ef3
test expr-28.189 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3092446298323 E-200 x -113918353bbc47_0000000000000000000000000000000000000000000000001& E-623
    convertToDouble -3092446298323E-200
} 0x99013918353bbc47
test expr-28.190 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6363857920591 E145 x 128a61cf9483b6_1111111111111111111111111111111111111111111111111110& E524
    convertToDouble +6363857920591E145
} 0x60b28a61cf9483b7
test expr-28.191 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8233559360849 E94 x -11f324d11d4861_1111111111111111111111111111111111111111111111110& E355
    convertToDouble -8233559360849E94
} 0xd621f324d11d4862
test expr-28.192 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2689845954547 E49 x 10bd2bfd34f98a_1111111111111111111111111111111111111111111111110& E204
    convertToDouble +2689845954547E49
} 0x4cb0bd2bfd34f98b
test expr-28.193 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5379691909094 E49 x -10bd2bfd34f98a_1111111111111111111111111111111111111111111111110& E205
    convertToDouble -5379691909094E49
} 0xccc0bd2bfd34f98b
test expr-28.194 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +5560322501926 E-301 x 15acc2053064c1_11111111111111111111111111111111111111111111111110& E-958
    convertToDouble +5560322501926E-301
} 0x0415acc2053064c2
test expr-28.195 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7812878489261 E-179 x -126dae7bbeda74_11111111111111111111111111111111111111111111111111110& E-552
    convertToDouble -7812878489261E-179
} 0x9d726dae7bbeda75
test expr-28.196 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8439398533053 E-256 x 170cc285f2d209_1111111111111111111111111111111111111111111111110& E-808
    convertToDouble +8439398533053E-256
} 0x0d770cc285f2d20a
test expr-28.197 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -2780161250963 E-301 x -15acc2053064c1_11111111111111111111111111111111111111111111111110& E-959
    convertToDouble -2780161250963E-301
} 0x8405acc2053064c2
test expr-28.198 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -87605699161665 E155 x -12920f96e7f9ef_00000000000000000000000000000000000000000000000000001& E561
    convertToDouble -87605699161665E155
} 0xe302920f96e7f9ef
test expr-28.199 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -17521139832333 E156 x -12920f96e7f9ef_00000000000000000000000000000000000000000000000000001& E562
    convertToDouble -17521139832333E156
} 0xe312920f96e7f9ef
test expr-28.200 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -88218101363513 E-170 x -18395688592faf_0000000000000000000000000000000000000000000000000001& E-519
    convertToDouble -88218101363513E-170
} 0x9f88395688592faf
test expr-28.201 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +38639244311627 E-115 x 114ef3e205c817_0000000000000000000000000000000000000000000000000001& E-337
    convertToDouble +38639244311627E-115
} 0x2ae14ef3e205c817
test expr-28.202 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +35593959807306 E261 x 1072f3819c1320_11111111111111111111111111111111111111111111111111110& E912
    convertToDouble +35593959807306E261
} 0x78f072f3819c1321
test expr-28.203 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -53390939710959 E260 x -13bd243521b08d_11111111111111111111111111111111111111111111111111110& E909
    convertToDouble -53390939710959E260
} 0xf8c3bd243521b08e
test expr-28.204 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +71187919614612 E261 x 1072f3819c1320_11111111111111111111111111111111111111111111111111110& E913
    convertToDouble +71187919614612E261
} 0x790072f3819c1321
test expr-28.205 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -88984899518265 E260 x -1072f3819c1320_11111111111111111111111111111111111111111111111111110& E910
    convertToDouble -88984899518265E260
} 0xf8d072f3819c1321
test expr-28.206 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +77003665618895 E-73 x 18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-197
    convertToDouble +77003665618895E-73
} 0x33a8bf7e7fa6f02a
test expr-28.207 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -15400733123779 E-72 x -18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-196
    convertToDouble -15400733123779E-72
} 0xb3b8bf7e7fa6f02a
test expr-28.208 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +61602932495116 E-72 x 18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-194
    convertToDouble +61602932495116E-72
} 0x33d8bf7e7fa6f02a
test expr-28.209 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -30801466247558 E-72 x -18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-195
    convertToDouble -30801466247558E-72
} 0xb3c8bf7e7fa6f02a
test expr-28.210 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +834735494917063 E-300 x 1fc6c26f899dd1_0000000000000000000000000000000000000000000000000000000001& E-948
    convertToDouble +834735494917063E-300
} 0x04bfc6c26f899dd1
test expr-28.211 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -589795149206434 E-151 x -15f2df5e675a0f_0000000000000000000000000000000000000000000000000000000001& E-453
    convertToDouble -589795149206434E-151
} 0xa3a5f2df5e675a0f
test expr-28.212 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +475603213226859 E-42 x 12d73088f4050a_000000000000000000000000000000000000000000000000000000001& E-91
    convertToDouble +475603213226859E-42
} 0x3a42d73088f4050a
test expr-28.213 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -294897574603217 E-151 x -15f2df5e675a0f_0000000000000000000000000000000000000000000000000000000001& E-454
    convertToDouble -294897574603217E-151
} 0xa395f2df5e675a0f
test expr-28.214 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +850813008001913 E93 x 172f7a1831ad70_11111111111111111111111111111111111111111111111111111110& E358
    convertToDouble +850813008001913E93
} 0x56572f7a1831ad71
test expr-28.215 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -203449172043339 E185 x -1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E662
    convertToDouble -203449172043339E185
} 0xe95102b47e4af988
test expr-28.216 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +406898344086678 E185 x 1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E663
    convertToDouble +406898344086678E185
} 0x696102b47e4af988
test expr-28.217 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -813796688173356 E185 x -1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E664
    convertToDouble -813796688173356E185
} 0xe97102b47e4af988
test expr-28.218 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6045338514609393 E244 x 1f746182e6cd5d_00000000000000000000000000000000000000000000000000000000001& E862
    convertToDouble +6045338514609393E244
} 0x75df746182e6cd5d
test expr-28.219 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5145963778954906 E142 x -1dfc11fbf46087_00000000000000000000000000000000000000000000000000000000001& E523
    convertToDouble -5145963778954906E142
} 0xe0adfc11fbf46087
test expr-28.220 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2572981889477453 E142 x 1dfc11fbf46087_00000000000000000000000000000000000000000000000000000000001& E522
    convertToDouble +2572981889477453E142
} 0x609dfc11fbf46087
test expr-28.221 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6965949469487146 E74 x -15e2c10ad970b0_0000000000000000000000000000000000000000000000000000000001& E298
    convertToDouble -6965949469487146E74
} 0xd295e2c10ad970b0
test expr-28.222 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6182410494241627 E-119 x 11b96458445d07_0000000000000000000000000000000000000000000000000000000000001& E-343
    convertToDouble +6182410494241627E-119
} 0x2a81b96458445d07
test expr-28.223 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8510309498186985 E-277 x -1acc46749dccfe_000000000000000000000000000000000000000000000000000000000001& E-868
    convertToDouble -8510309498186985E-277
} 0x89bacc46749dccfe
test expr-28.224 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6647704637273331 E-212 x 13e07d2c0cb1e9_0000000000000000000000000000000000000000000000000000000000001& E-652
    convertToDouble +6647704637273331E-212
} 0x1733e07d2c0cb1e9
test expr-28.225 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -2215901545757777 E-212 x -1a80a6e566428c_000000000000000000000000000000000000000000000000000000000001& E-654
    convertToDouble -2215901545757777E-212
} 0x971a80a6e566428c
test expr-28.226 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3771476185376383 E276 x 183010aba78a53_111111111111111111111111111111111111111111111111111111111110& E968
    convertToDouble +3771476185376383E276
} 0x7c783010aba78a54
test expr-28.227 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3729901848043846 E212 x -1f7d6721f7f143_111111111111111111111111111111111111111111111111111111111110& E755
    convertToDouble -3729901848043846E212
} 0xef2f7d6721f7f144
test expr-28.228 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3771476185376383 E277 x 1e3c14d6916ce8_111111111111111111111111111111111111111111111111111111111110& E971
    convertToDouble +3771476185376383E277
} 0x7cae3c14d6916ce9
test expr-28.229 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9977830465649166 E119 x -15f6de9d5d6b5a_111111111111111111111111111111111111111111111111111111111110& E448
    convertToDouble -9977830465649166E119
} 0xdbf5f6de9d5d6b5b
test expr-28.230 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8439928496349319 E-142 x 12483a0f125699_111111111111111111111111111111111111111111111111111111111110& E-419
    convertToDouble +8439928496349319E-142
} 0x25c2483a0f12569a
test expr-28.231 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8204230082070882 E-59 x -1d460f4fca1d36_1111111111111111111111111111111111111111111111111111111110& E-144
    convertToDouble -8204230082070882E-59
} 0xb6fd460f4fca1d37
test expr-28.232 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8853686434843997 E-244 x 157a340eb5d4f0_11111111111111111111111111111111111111111111111111111111110& E-758
    convertToDouble +8853686434843997E-244
} 0x10957a340eb5d4f1
test expr-28.233 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5553274272288559 E-104 x -1c47d20a19d1ed_1111111111111111111111111111111111111111111111111111111110& E-294
    convertToDouble -5553274272288559E-104
} 0xad9c47d20a19d1ee
test expr-28.234 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +36149023611096162 E144 x 1491daad0ba280_0000000000000000000000000000000000000000000000000000000000000001& E533
    convertToDouble +36149023611096162E144
} 0x614491daad0ba280
test expr-28.235 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -36149023611096162 E147 x -14166f8cfd5cb1_0000000000000000000000000000000000000000000000000000000000000001& E543
    convertToDouble -36149023611096162E147
} 0xe1e4166f8cfd5cb1
test expr-28.236 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +18074511805548081 E146 x 1011f2d73116f4_0000000000000000000000000000000000000000000000000000000000000001& E539
    convertToDouble +18074511805548081E146
} 0x61a011f2d73116f4
test expr-28.237 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -18074511805548081 E147 x -14166f8cfd5cb1_0000000000000000000000000000000000000000000000000000000000000001& E542
    convertToDouble -18074511805548081E147
} 0xe1d4166f8cfd5cb1
test expr-28.238 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +97338774138954421 E-290 x 10d9b828199006_0000000000000000000000000000000000000000000000000000000000000001& E-907
    convertToDouble +97338774138954421E-290
} 0x0740d9b828199006
test expr-28.239 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -88133809804950961 E-308 x -119710dc581911_000000000000000000000000000000000000000000000000000000000000001& E-967
    convertToDouble -88133809804950961E-308
} 0x83819710dc581911
test expr-28.240 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +94080055902682397 E-243 x 11d467e94b856e_0000000000000000000000000000000000000000000000000000000000000001& E-751
    convertToDouble +94080055902682397E-243
} 0x1101d467e94b856e
test expr-28.241 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -24691002732654881 E-115 x -159a2783ce70ab_000000000000000000000000000000000000000000000000000000000000001& E-328
    convertToDouble -24691002732654881E-115
} 0xab759a2783ce70ab
test expr-28.242 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +52306490527514614 E49 x 13de005bd620de_111111111111111111111111111111111111111111111111111111111111111110& E218
    convertToDouble +52306490527514614E49
} 0x4d93de005bd620df
test expr-28.243 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -26153245263757307 E49 x -13de005bd620de_111111111111111111111111111111111111111111111111111111111111111110& E217
    convertToDouble -26153245263757307E49
} 0xcd83de005bd620df
test expr-28.244 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +55188692254193604 E165 x 1a999ddec72ac9_11111111111111111111111111111111111111111111111111111111111110& E603
    convertToDouble +55188692254193604E165
} 0x65aa999ddec72aca
test expr-28.245 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -68985865317742005 E164 x -1a999ddec72ac9_11111111111111111111111111111111111111111111111111111111111110& E600
    convertToDouble -68985865317742005E164
} 0xe57a999ddec72aca
test expr-28.246 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +27176258005319167 E-261 x 17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-813
    convertToDouble +27176258005319167E-261
} 0x0d27c0747bd76fa1
test expr-28.247 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -73169230107256116 E-248 x -122cea327fa99c_1111111111111111111111111111111111111111111111111111111111110& E-768
    convertToDouble -73169230107256116E-248
} 0x8ff22cea327fa99d
test expr-28.248 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +91461537634070145 E-249 x 122cea327fa99c_1111111111111111111111111111111111111111111111111111111111110& E-771
    convertToDouble +91461537634070145E-249
} 0x0fc22cea327fa99d
test expr-28.249 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -54352516010638334 E-261 x -17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-812
    convertToDouble -54352516010638334E-261
} 0x8d37c0747bd76fa1
test expr-28.250 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +586144289638535878 E280 x 11eccbd6f62709_0000000000000000000000000000000000000000000000000000000000000000001& E989
    convertToDouble +586144289638535878E280
} 0x7dc1eccbd6f62709
test expr-28.251 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -601117006785295431 E245 x -1e8b3525b3737e_000000000000000000000000000000000000000000000000000000000000000001& E872
    convertToDouble -601117006785295431E245
} 0xf67e8b3525b3737e
test expr-28.252 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +293072144819267939 E280 x 11eccbd6f62709_0000000000000000000000000000000000000000000000000000000000000000001& E988
    convertToDouble +293072144819267939E280
} 0x7db1eccbd6f62709
test expr-28.253 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -953184713238516652 E272 x -138fd93f1f5342_00000000000000000000000000000000000000000000000000000000000000001& E963
    convertToDouble -953184713238516652E272
} 0xfc238fd93f1f5342
test expr-28.254 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +902042358290366539 E-281 x 122dc01ca1cb8c_0000000000000000000000000000000000000000000000000000000000000000001& E-874
    convertToDouble +902042358290366539E-281
} 0x09522dc01ca1cb8c
test expr-28.255 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -557035730189854663 E-294 x -13bfac6bc4767b_00000000000000000000000000000000000000000000000000000000000000000001& E-918
    convertToDouble -557035730189854663E-294
} 0x8693bfac6bc4767b
test expr-28.256 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +902042358290366539 E-280 x 16b93023ca3e6f_0000000000000000000000000000000000000000000000000000000000000000001& E-871
    convertToDouble +902042358290366539E-280
} 0x0986b93023ca3e6f
test expr-28.257 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -354944100507554393 E-238 x -19a91cece6ad07_000000000000000000000000000000000000000000000000000000000000000001& E-733
    convertToDouble -354944100507554393E-238
} 0x9229a91cece6ad07
test expr-28.258 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +272104041512242479 E199 x 1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E718
    convertToDouble +272104041512242479E199
} 0x6cdf92bacb3cb40c
test expr-28.259 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -816312124536727437 E199 x -17ae0c186d8708_11111111111111111111111111111111111111111111111111111111111111111111110& E720
    convertToDouble -816312124536727437E199
} 0xecf7ae0c186d8709
test expr-28.260 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +544208083024484958 E199 x 1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E719
    convertToDouble +544208083024484958E199
} 0x6cef92bacb3cb40c
test expr-28.261 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -792644927852378159 E78 x -17bff336d8ff05_111111111111111111111111111111111111111111111111111111111111111111110& E318
    convertToDouble -792644927852378159E78
} 0xd3d7bff336d8ff06
test expr-28.262 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -679406450132979175 E-263 x -17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-815
    convertToDouble -679406450132979175E-263
} 0x8d07c0747bd76fa1
test expr-28.263 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +543525160106383340 E-262 x 17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-812
    convertToDouble +543525160106383340E-262
} 0x0d37c0747bd76fa1
test expr-28.264 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7400253695682920196 E215 x 1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E776
    convertToDouble +7400253695682920196E215
} 0x707dca94e3990085
test expr-28.265 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1850063423920730049 E215 x -1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E774
    convertToDouble -1850063423920730049E215
} 0xf05dca94e3990085
test expr-28.266 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3700126847841460098 E215 x 1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E775
    convertToDouble +3700126847841460098E215
} 0x706dca94e3990085
test expr-28.267 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9250317119603650245 E214 x -1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E773
    convertToDouble -9250317119603650245E214
} 0xf04dca94e3990085
test expr-28.268 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8396094300569779681 E-252 x 1ab223efcee35a_0000000000000000000000000000000000000000000000000000000000000000000000001& E-775
    convertToDouble +8396094300569779681E-252
} 0x0f8ab223efcee35a
test expr-28.269 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3507665085003296281 E-75 x -160499b881ea50_00000000000000000000000000000000000000000000000000000000000000000000001& E-188
    convertToDouble -3507665085003296281E-75
} 0xb4360499b881ea50
test expr-28.270 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7015330170006592562 E-75 x 160499b881ea50_00000000000000000000000000000000000000000000000000000000000000000000001& E-187
    convertToDouble +7015330170006592562E-75
} 0x34460499b881ea50
test expr-28.271 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7015330170006592562 E-74 x -1b85c026a264e4_00000000000000000000000000000000000000000000000000000000000000000000001& E-184
    convertToDouble -7015330170006592562E-74
} 0xb47b85c026a264e4
test expr-28.272 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7185620434951919351 E205 x 18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E743
    convertToDouble +7185620434951919351E205
} 0x6e68d92d2bcc7a81
test expr-28.273 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1360520207561212395 E198 x -1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E717
    convertToDouble -1360520207561212395E198
} 0xeccf92bacb3cb40c
test expr-28.274 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2178999185345151731 E-184 x 19b2c4d2a82335_1111111111111111111111111111111111111111111111111111111111111111111110& E-551
    convertToDouble +2178999185345151731E-184
} 0x1d89b2c4d2a82336
test expr-28.275 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8691089486201567102 E-218 x -1a9c42e5b6d89e_1111111111111111111111111111111111111111111111111111111111111111111110& E-662
    convertToDouble -8691089486201567102E-218
} 0x969a9c42e5b6d89f
test expr-28.276 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4345544743100783551 E-218 x 1a9c42e5b6d89e_1111111111111111111111111111111111111111111111111111111111111111111110& E-663
    convertToDouble +4345544743100783551E-218
} 0x168a9c42e5b6d89f
test expr-28.277 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -4357998370690303462 E-184 x -19b2c4d2a82335_1111111111111111111111111111111111111111111111111111111111111111111110& E-550
    convertToDouble -4357998370690303462E-184
} 0x9d99b2c4d2a82336
test expr-28.278 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +59825267349106892461 E177 x 199c476d7868df_000000000000000000000000000000000000000000000000000000000000000000000001& E653
    convertToDouble +59825267349106892461E177
} 0x68c99c476d7868df
test expr-28.279 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -62259110684423957791 E47 x -1d8f2cfc20d6e8_0000000000000000000000000000000000000000000000000000000000000000000000001& E221
    convertToDouble -62259110684423957791E47
} 0xcdcd8f2cfc20d6e8
test expr-28.280 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +58380168477038565599 E265 x 1f686e9efbe48d_00000000000000000000000000000000000000000000000000000000000000000000000001& E945
    convertToDouble +58380168477038565599E265
} 0x7b0f686e9efbe48d
test expr-28.281 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -62259110684423957791 E48 x -12797c1d948651_0000000000000000000000000000000000000000000000000000000000000000000000001& E225
    convertToDouble -62259110684423957791E48
} 0xce02797c1d948651
test expr-28.282 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -33584377202279118724 E-252 x -1ab223efcee35a_0000000000000000000000000000000000000000000000000000000000000000000000001& E-773
    convertToDouble -33584377202279118724E-252
} 0x8faab223efcee35a
test expr-28.283 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -57484963479615354808 E205 x -18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E746
    convertToDouble -57484963479615354808E205
} 0xee98d92d2bcc7a81
test expr-28.284 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +71856204349519193510 E204 x 18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E743
    convertToDouble +71856204349519193510E204
} 0x6e68d92d2bcc7a81
test expr-28.285 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -14371240869903838702 E205 x -18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E744
    convertToDouble -14371240869903838702E205
} 0xee78d92d2bcc7a81
test expr-28.286 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +36992084760177624177 E-318 x 18c5f9551c2f99_111111111111111111111111111111111111111111111111111111111111111111111110& E-992
    convertToDouble +36992084760177624177E-318
} 0x01f8c5f9551c2f9a
test expr-28.287 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -73984169520355248354 E-318 x -18c5f9551c2f99_111111111111111111111111111111111111111111111111111111111111111111111110& E-991
    convertToDouble -73984169520355248354E-318
} 0x8208c5f9551c2f9a
test expr-28.288 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +99257763227713890244 E-115 x 15338a554b9ce0_11111111111111111111111111111111111111111111111111111111111111111111110& E-316
    convertToDouble +99257763227713890244E-115
} 0x2c35338a554b9ce1
test expr-28.289 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -87336362425182547697 E-280 x -1130304e7d9c32_11111111111111111111111111111111111111111111111111111111111111111111110& E-864
    convertToDouble -87336362425182547697E-280
} 0x89f130304e7d9c33
test expr-28.290 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7 E289 x 1cbb547777a284_10000000001& E962
    convertToDouble +7E289
} 0x7c1cbb547777a285
test expr-28.291 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3 E153 x -1ca3d8e6d80cba_100000001& E509
    convertToDouble -3E153
} 0xdfcca3d8e6d80cbb
test expr-28.292 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6 E153 x 1ca3d8e6d80cba_100000001& E510
    convertToDouble +6E153
} 0x5fdca3d8e6d80cbb
test expr-28.293 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5 E243 x -176ec98994f488_10000001& E809
    convertToDouble -5E243
} 0xf2876ec98994f489
test expr-28.294 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7 E-161 x 1f7e0db3799aa2_10000000001& E-533
    convertToDouble +7E-161
} 0x1eaf7e0db3799aa3
test expr-28.295 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7 E-172 x -15a4337446ef2a_1000000001& E-569
    convertToDouble -7E-172
} 0x9c65a4337446ef2b
test expr-28.296 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8 E-63 x 1a53fc9631d10c_10000001& E-207
    convertToDouble +8E-63
} 0x330a53fc9631d10d
test expr-28.297 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7 E-113 x -158c47e6eea282_10000001& E-373
    convertToDouble -7E-113
} 0xa8a58c47e6eea283
test expr-28.298 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8 E126 x 17a2ecc414a03f_0111111111110& E421
    convertToDouble +8E126
} 0x5a47a2ecc414a03f
test expr-28.299 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -4 E126 x -17a2ecc414a03f_0111111111110& E420
    convertToDouble -4E126
} 0xda37a2ecc414a03f
test expr-28.300 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +5 E125 x 17a2ecc414a03f_0111111111110& E417
    convertToDouble +5E125
} 0x5a07a2ecc414a03f
test expr-28.301 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1 E126 x -17a2ecc414a03f_0111111111110& E418
    convertToDouble -1E126
} 0xda17a2ecc414a03f
test expr-28.302 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8 E-163 x 1708d0f84d3de7_011111110& E-539
    convertToDouble +8E-163
} 0x1e4708d0f84d3de7
test expr-28.303 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1 E-163 x -1708d0f84d3de7_011111110& E-542
    convertToDouble -1E-163
} 0x9e1708d0f84d3de7
test expr-28.304 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2 E-163 x 1708d0f84d3de7_011111110& E-541
    convertToDouble +2E-163
} 0x1e2708d0f84d3de7
test expr-28.305 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -4 E-163 x -1708d0f84d3de7_011111110& E-540
    convertToDouble -4E-163
} 0x9e3708d0f84d3de7
test expr-28.306 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +51 E195 x 15d51d249dca42_1000000000001& E653
    convertToDouble +51E195
} 0x68c5d51d249dca43
test expr-28.307 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -37 E46 x -1033d7eca0adee_100000000000001& E158
    convertToDouble -37E46
} 0xc9d033d7eca0adef
test expr-28.308 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +74 E46 x 1033d7eca0adee_100000000000001& E159
    convertToDouble +74E46
} 0x49e033d7eca0adef
test expr-28.309 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -56 E289 x -1cbb547777a284_10000000001& E965
    convertToDouble -56E289
} 0xfc4cbb547777a285
test expr-28.310 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +69 E-145 x 158a41b31c9a9a_100000000001& E-476
    convertToDouble +69E-145
} 0x22358a41b31c9a9b
test expr-28.311 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -70 E-162 x -1f7e0db3799aa2_10000000001& E-533
    convertToDouble -70E-162
} 0x9eaf7e0db3799aa3
test expr-28.312 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +56 E-161 x 1f7e0db3799aa2_10000000001& E-530
    convertToDouble +56E-161
} 0x1edf7e0db3799aa3
test expr-28.313 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -21 E-303 x -1ccd59caa6a750_10000000001& E-1003
    convertToDouble -21E-303
} 0x814ccd59caa6a751
test expr-28.314 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +34 E-276 x 12d5a4350d30ff_011111111110& E-912
    convertToDouble +34E-276
} 0x06f2d5a4350d30ff
test expr-28.315 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -68 E-276 x -12d5a4350d30ff_011111111110& E-911
    convertToDouble -68E-276
} 0x8702d5a4350d30ff
test expr-28.316 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +85 E-277 x 12d5a4350d30ff_011111111110& E-914
    convertToDouble +85E-277
} 0x06d2d5a4350d30ff
test expr-28.317 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -87 E-274 x -12d36cf48e7abd_011111111111110& E-904
    convertToDouble -87E-274
} 0x8772d36cf48e7abd
test expr-28.318 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +829 E102 x 17221a79cdd1d8_1000000000000001& E348
    convertToDouble +829E102
} 0x55b7221a79cdd1d9
test expr-28.319 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -623 E100 x -1640a62f3a83de_10000000000000000001& E341
    convertToDouble -623E100
} 0xd54640a62f3a83df
test expr-28.320 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +723 E-162 x 145457ee24abd2_1000000000000001& E-529
    convertToDouble +723E-162
} 0x1ee45457ee24abd3
test expr-28.321 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -457 E-102 x -1ffc81bc29f02a_100000000000000001& E-331
    convertToDouble -457E-102
} 0xab4ffc81bc29f02b
test expr-28.322 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +914 E-102 x 1ffc81bc29f02a_100000000000000001& E-330
    convertToDouble +914E-102
} 0x2b5ffc81bc29f02b
test expr-28.323 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -323 E-135 x -1d589ae4d70218_10000000000001& E-441
    convertToDouble -323E-135
} 0xa46d589ae4d70219
test expr-28.324 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +151 E176 x 1dcf7df8f573b7_0111111111111111110& E591
    convertToDouble +151E176
} 0x64edcf7df8f573b7
test expr-28.325 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -302 E176 x -1dcf7df8f573b7_0111111111111111110& E592
    convertToDouble -302E176
} 0xe4fdcf7df8f573b7
test expr-28.326 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +921 E90 x 1c420a45fd70ff_0111111111111110& E308
    convertToDouble +921E90
} 0x533c420a45fd70ff
test expr-28.327 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -604 E176 x -1dcf7df8f573b7_0111111111111111110& E593
    convertToDouble -604E176
} 0xe50dcf7df8f573b7
test expr-28.328 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +823 E-206 x 14a48933c208ad_0111111111111110& E-675
    convertToDouble +823E-206
} 0x15c4a48933c208ad
test expr-28.329 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -463 E-114 x -11d0c83f6378a5_011111111111110& E-370
    convertToDouble -463E-114
} 0xa8d1d0c83f6378a5
test expr-28.330 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +348 E-274 x 12d36cf48e7abd_011111111111110& E-902
    convertToDouble +348E-274
} 0x0792d36cf48e7abd
test expr-28.331 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9968 E100 x 1640a62f3a83de_10000000000000000001& E345
    convertToDouble +9968E100
} 0x558640a62f3a83df
test expr-28.332 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6230 E99 x -1640a62f3a83de_10000000000000000001& E341
    convertToDouble -6230E99
} 0xd54640a62f3a83df
test expr-28.333 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +1246 E100 x 1640a62f3a83de_10000000000000000001& E342
    convertToDouble +1246E100
} 0x555640a62f3a83df
test expr-28.334 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6676 E-296 x 15519ac5142aaa_1000000000000000000001& E-971
    convertToDouble +6676E-296
} 0x0345519ac5142aab
test expr-28.335 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8345 E-297 x -15519ac5142aaa_1000000000000000000001& E-974
    convertToDouble -8345E-297
} 0x8315519ac5142aab
test expr-28.336 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +1669 E-296 x 15519ac5142aaa_1000000000000000000001& E-973
    convertToDouble +1669E-296
} 0x0325519ac5142aab
test expr-28.337 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3338 E-296 x -15519ac5142aaa_1000000000000000000001& E-972
    convertToDouble -3338E-296
} 0x8335519ac5142aab
test expr-28.338 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3257 E58 x 1444b34a6fb3eb_01111111111111111110& E204
    convertToDouble +3257E58
} 0x4cb444b34a6fb3eb
test expr-28.339 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6514 E58 x -1444b34a6fb3eb_01111111111111111110& E205
    convertToDouble -6514E58
} 0xccc444b34a6fb3eb
test expr-28.340 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2416 E176 x 1dcf7df8f573b7_0111111111111111110& E595
    convertToDouble +2416E176
} 0x652dcf7df8f573b7
test expr-28.341 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8085 E-63 x 19fbf3c19b9a79_0111111111111111110& E-197
    convertToDouble +8085E-63
} 0x33a9fbf3c19b9a79
test expr-28.342 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3234 E-62 x -19fbf3c19b9a79_0111111111111111110& E-195
    convertToDouble -3234E-62
} 0xb3c9fbf3c19b9a79
test expr-28.343 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +1617 E-62 x 19fbf3c19b9a79_0111111111111111110& E-196
    convertToDouble +1617E-62
} 0x33b9fbf3c19b9a79
test expr-28.344 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6468 E-62 x -19fbf3c19b9a79_0111111111111111110& E-194
    convertToDouble -6468E-62
} 0xb3d9fbf3c19b9a79
test expr-28.345 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +53418 E111 x 15b1051df943a8_1000000000000000000001& E384
    convertToDouble +53418E111
} 0x57f5b1051df943a9
test expr-28.346 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -60513 E160 x -15043b64e56c72_1000000000000000000001& E547
    convertToDouble -60513E160
} 0xe225043b64e56c73
test expr-28.347 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +26709 E111 x 15b1051df943a8_1000000000000000000001& E383
    convertToDouble +26709E111
} 0x57e5b1051df943a9
test expr-28.348 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -99447 E166 x -10782189b336ae_1000000000000000000001& E568
    convertToDouble -99447E166
} 0xe370782189b336af
test expr-28.349 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +12549 E48 x 10c52fe6dc6a1b_011111111111111111111110& E173
    convertToDouble +12549E48
} 0x4ac0c52fe6dc6a1b
test expr-28.350 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -25098 E48 x -10c52fe6dc6a1b_011111111111111111111110& E174
    convertToDouble -25098E48
} 0xcad0c52fe6dc6a1b
test expr-28.351 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +50196 E48 x 10c52fe6dc6a1b_011111111111111111111110& E175
    convertToDouble +50196E48
} 0x4ae0c52fe6dc6a1b
test expr-28.352 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -62745 E47 x -10c52fe6dc6a1b_011111111111111111111110& E172
    convertToDouble -62745E47
} 0xcab0c52fe6dc6a1b
test expr-28.353 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +83771 E-73 x 1ce886fb5ffd6d_0111111111111111111110& E-227
    convertToDouble +83771E-73
} 0x31cce886fb5ffd6d
test expr-28.354 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -97451 E-167 x -1c0f220fb1c70d_01111111111111111111110& E-539
    convertToDouble -97451E-167
} 0x9e4c0f220fb1c70d
test expr-28.355 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +86637 E-203 x 10943edb4e81db_0111111111111111111110& E-658
    convertToDouble +86637E-203
} 0x16d0943edb4e81db
test expr-28.356 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -75569 E-254 x -15a462d91c6ab3_0111111111111111111111111110& E-828
    convertToDouble -75569E-254
} 0x8c35a462d91c6ab3
test expr-28.357 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +473806 E83 x 17d15bf3186080_1000000000000000000000001& E294
    convertToDouble +473806E83
} 0x5257d15bf3186081
test expr-28.358 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -947612 E83 x -17d15bf3186080_1000000000000000000000001& E295
    convertToDouble -947612E83
} 0xd267d15bf3186081
test expr-28.359 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +292369 E76 x 18a85eb277e644_100000000000000000000000001& E270
    convertToDouble +292369E76
} 0x50d8a85eb277e645
test expr-28.360 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -584738 E76 x -18a85eb277e644_100000000000000000000000001& E271
    convertToDouble -584738E76
} 0xd0e8a85eb277e645
test expr-28.361 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +933587 E-140 x 1b248728b9c116_100000000000000000000000001& E-446
    convertToDouble +933587E-140
} 0x241b248728b9c117
test expr-28.362 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -720919 E-14 x -1ef696965cbf04_10000000000000000000000001& E-28
    convertToDouble -720919E-14
} 0xbe3ef696965cbf05
test expr-28.363 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +535001 E-149 x 10b38e07c745ae_1000000000000000000000001& E-476
    convertToDouble +535001E-149
} 0x2230b38e07c745af
test expr-28.364 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -890521 E-235 x -114828ee39c852_1000000000000000000000001& E-761
    convertToDouble -890521E-235
} 0x90614828ee39c853
test expr-28.365 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +548057 E81 x 11a1d9135cca53_0111111111111111111111110& E288
    convertToDouble +548057E81
} 0x51f1a1d9135cca53
test expr-28.366 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -706181 E88 x -1b156ac4c2d1e5_0111111111111111111111110& E311
    convertToDouble -706181E88
} 0xd36b156ac4c2d1e5
test expr-28.367 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +820997 E106 x 1b4f8b64fa125d_0111111111111111111111110& E371
    convertToDouble +820997E106
} 0x572b4f8b64fa125d
test expr-28.368 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -320681 E63 x -17ca18a876c5ef_0111111111111111111111110& E227
    convertToDouble -320681E63
} 0xce27ca18a876c5ef
test expr-28.369 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +928609 E-261 x 1be2dd66200bef_011111111111111111111111111110& E-848
    convertToDouble +928609E-261
} 0x0afbe2dd66200bef
test expr-28.370 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -302276 E-254 x -15a462d91c6ab3_0111111111111111111111111110& E-826
    convertToDouble -302276E-254
} 0x8c55a462d91c6ab3
test expr-28.371 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +151138 E-254 x 15a462d91c6ab3_0111111111111111111111111110& E-827
    convertToDouble +151138E-254
} 0x0c45a462d91c6ab3
test expr-28.372 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4691773 E45 x 19147b9330eaae_1000000000000000000000000001& E171
    convertToDouble +4691773E45
} 0x4aa9147b9330eaaf
test expr-28.373 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9383546 E45 x -19147b9330eaae_1000000000000000000000000001& E172
    convertToDouble -9383546E45
} 0xcab9147b9330eaaf
test expr-28.374 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3059949 E-243 x 13ecf22ea07862_10000000000000000000000000001& E-786
    convertToDouble +3059949E-243
} 0x0ed3ecf22ea07863
test expr-28.375 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6119898 E-243 x -13ecf22ea07862_10000000000000000000000000001& E-785
    convertToDouble -6119898E-243
} 0x8ee3ecf22ea07863
test expr-28.376 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +5356626 E-213 x 1b84252abdf6ba_100000000000000000000000001& E-686
    convertToDouble +5356626E-213
} 0x151b84252abdf6bb
test expr-28.377 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -4877378 E-199 x -11cd5cd90cb200_100000000000000000000000001& E-639
    convertToDouble -4877378E-199
} 0x9801cd5cd90cb201
test expr-28.378 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7716693 E223 x 1972d9d2cff683_01111111111111111111111111110& E763
    convertToDouble +7716693E223
} 0x6fa972d9d2cff683
test expr-28.379 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5452869 E109 x -16247b136fecc3_01111111111111111111111111110& E384
    convertToDouble -5452869E109
} 0xd7f6247b136fecc3
test expr-28.380 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4590831 E156 x 14689b4a5fa201_011111111111111111111111111110& E540
    convertToDouble +4590831E156
} 0x61b4689b4a5fa201
test expr-28.381 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9181662 E156 x -14689b4a5fa201_011111111111111111111111111110& E541
    convertToDouble -9181662E156
} 0xe1c4689b4a5fa201
test expr-28.382 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3714436 E-261 x -1be2dd66200bef_011111111111111111111111111110& E-846
    convertToDouble -3714436E-261
} 0x8b1be2dd66200bef
test expr-28.383 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4643045 E-262 x 1be2dd66200bef_011111111111111111111111111110& E-849
    convertToDouble +4643045E-262
} 0x0aebe2dd66200bef
test expr-28.384 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7428872 E-261 x -1be2dd66200bef_011111111111111111111111111110& E-845
    convertToDouble -7428872E-261
} 0x8b2be2dd66200bef
test expr-28.385 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +52942146 E130 x 16c31d08af89c2_10000000000000000000000000000001& E457
    convertToDouble +52942146E130
} 0x5c86c31d08af89c3
test expr-28.386 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -27966061 E145 x -155bcf72fd10f8_1000000000000000000000000000000001& E506
    convertToDouble -27966061E145
} 0xdf955bcf72fd10f9
test expr-28.387 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +26471073 E130 x 16c31d08af89c2_10000000000000000000000000000001& E456
    convertToDouble +26471073E130
} 0x5c76c31d08af89c3
test expr-28.388 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -55932122 E145 x -155bcf72fd10f8_1000000000000000000000000000000001& E507
    convertToDouble -55932122E145
} 0xdfa55bcf72fd10f9
test expr-28.389 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +95412548 E-99 x 18e0bfb98864c8_100000000000000000000000000000001& E-303
    convertToDouble +95412548E-99
} 0x2d08e0bfb98864c9
test expr-28.390 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -47706274 E-99 x -18e0bfb98864c8_100000000000000000000000000000001& E-304
    convertToDouble -47706274E-99
} 0xacf8e0bfb98864c9
test expr-28.391 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +23853137 E-99 x 18e0bfb98864c8_100000000000000000000000000000001& E-305
    convertToDouble +23853137E-99
} 0x2ce8e0bfb98864c9
test expr-28.392 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -78493654 E-301 x -140d76077b648e_10000000000000000000000000000001& E-974
    convertToDouble -78493654E-301
} 0x83140d76077b648f
test expr-28.393 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +65346417 E29 x 13aa1ad778f23b_0111111111111111111111111111110& E122
    convertToDouble +65346417E29
} 0x4793aa1ad778f23b
test expr-28.394 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -51083099 E167 x -14a75eb58df47b_0111111111111111111111111111110& E580
    convertToDouble -51083099E167
} 0xe434a75eb58df47b
test expr-28.395 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +89396333 E264 x 1526f061ca9053_0111111111111111111111111111111110& E903
    convertToDouble +89396333E264
} 0x786526f061ca9053
test expr-28.396 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -84863171 E114 x -106e98f5ec8f37_0111111111111111111111111111111110& E405
    convertToDouble -84863171E114
} 0xd9406e98f5ec8f37
test expr-28.397 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +59540836 E-251 x 10430c2d075c07_011111111111111111111111111111110& E-808
    convertToDouble +59540836E-251
} 0x0d70430c2d075c07
test expr-28.398 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -74426045 E-252 x -10430c2d075c07_011111111111111111111111111111110& E-811
    convertToDouble -74426045E-252
} 0x8d40430c2d075c07
test expr-28.399 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +14885209 E-251 x 10430c2d075c07_011111111111111111111111111111110& E-810
    convertToDouble +14885209E-251
} 0x0d50430c2d075c07
test expr-28.400 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -29770418 E-251 x -10430c2d075c07_011111111111111111111111111111110& E-809
    convertToDouble -29770418E-251
} 0x8d60430c2d075c07
test expr-28.401 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +982161308 E122 x 11b6231e18c5ca_100000000000000000000000000000000000000001& E435
    convertToDouble +982161308E122
} 0x5b21b6231e18c5cb
test expr-28.402 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -245540327 E122 x -11b6231e18c5ca_100000000000000000000000000000000000000001& E433
    convertToDouble -245540327E122
} 0xdb01b6231e18c5cb
test expr-28.403 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +491080654 E122 x 11b6231e18c5ca_100000000000000000000000000000000000000001& E434
    convertToDouble +491080654E122
} 0x5b11b6231e18c5cb
test expr-28.404 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +525452622 E-310 x 12045136ce0340_1000000000000000000000000000000000001& E-1001
    convertToDouble +525452622E-310
} 0x0162045136ce0341
test expr-28.405 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -771837113 E-134 x -14e61f991c4ed0_100000000000000000000000000000000001& E-416
    convertToDouble -771837113E-134
} 0xa5f4e61f991c4ed1
test expr-28.406 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +820858081 E-150 x 14050669985a86_10000000000000000000000000000000001& E-469
    convertToDouble +820858081E-150
} 0x22a4050669985a87
test expr-28.407 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -262726311 E-310 x -12045136ce0340_1000000000000000000000000000000000001& E-1002
    convertToDouble -262726311E-310
} 0x8152045136ce0341
test expr-28.408 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +923091487 E209 x 10bc60e6896717_011111111111111111111111111111111110& E724
    convertToDouble +923091487E209
} 0x6d30bc60e6896717
test expr-28.409 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -653777767 E273 x -120223f2b3a881_0111111111111111111111111111111111111110& E936
    convertToDouble -653777767E273
} 0xfa720223f2b3a881
test expr-28.410 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +842116236 E-53 x 1809c5732cdc7f_0111111111111111111111111111111110& E-147
    convertToDouble +842116236E-53
} 0x36c809c5732cdc7f
test expr-28.411 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -741111169 E-202 x -15a3e1d1b73099_01111111111111111111111111111111110& E-642
    convertToDouble -741111169E-202
} 0x97d5a3e1d1b73099
test expr-28.412 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +839507247 E-284 x 129a1effc50859_0111111111111111111111111111111110& E-914
    convertToDouble +839507247E-284
} 0x06d29a1effc50859
test expr-28.413 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -951487269 E-264 x -1c92befccb5f59_0111111111111111111111111111111110& E-848
    convertToDouble -951487269E-264
} 0x8afc92befccb5f59
test expr-28.414 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9821613080 E121 x -11b6231e18c5ca_100000000000000000000000000000000000000001& E435
    convertToDouble -9821613080E121
} 0xdb21b6231e18c5cb
test expr-28.415 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6677856011 E-31 x 193a6d11077292_100000000000000000000000000000000000001& E-71
    convertToDouble +6677856011E-31
} 0x3b893a6d11077293
test expr-28.416 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3573796826 E-266 x -112be2041a79fc_100000000000000000000000000000000000001& E-852
    convertToDouble -3573796826E-266
} 0x8ab12be2041a79fd
test expr-28.417 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7147593652 E-266 x 112be2041a79fc_100000000000000000000000000000000000001& E-851
    convertToDouble +7147593652E-266
} 0x0ac12be2041a79fd
test expr-28.418 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9981396317 E-181 x -1edbd94cb50054_100000000000000000000000000000000000001& E-569
    convertToDouble -9981396317E-181
} 0x9c6edbd94cb50055
test expr-28.419 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3268888835 E272 x 120223f2b3a881_0111111111111111111111111111111111111110& E935
    convertToDouble +3268888835E272
} 0x7a620223f2b3a881
test expr-28.420 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -2615111068 E273 x -120223f2b3a881_0111111111111111111111111111111111111110& E938
    convertToDouble -2615111068E273
} 0xfa920223f2b3a881
test expr-28.421 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +1307555534 E273 x 120223f2b3a881_0111111111111111111111111111111111111110& E937
    convertToDouble +1307555534E273
} 0x7a820223f2b3a881
test expr-28.422 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2990671154 E-190 x 13db11ac608107_01111111111111111111111111111111111111110& E-600
    convertToDouble +2990671154E-190
} 0x1a73db11ac608107
test expr-28.423 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1495335577 E-190 x -13db11ac608107_01111111111111111111111111111111111111110& E-601
    convertToDouble -1495335577E-190
} 0x9a63db11ac608107
test expr-28.424 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +5981342308 E-190 x 13db11ac608107_01111111111111111111111111111111111111110& E-599
    convertToDouble +5981342308E-190
} 0x1a83db11ac608107
test expr-28.425 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7476677885 E-191 x -13db11ac608107_01111111111111111111111111111111111111110& E-602
    convertToDouble -7476677885E-191
} 0x9a53db11ac608107
test expr-28.426 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +82259684194 E-202 x 12c3e72d179606_1000000000000000000000000000000000000000001& E-635
    convertToDouble +82259684194E-202
} 0x1842c3e72d179607
test expr-28.427 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -93227267727 E-49 x -1960fe08d5847e_100000000000000000000000000000000000000001& E-127
    convertToDouble -93227267727E-49
} 0xb80960fe08d5847f
test expr-28.428 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +41129842097 E-202 x 12c3e72d179606_1000000000000000000000000000000000000000001& E-636
    convertToDouble +41129842097E-202
} 0x1832c3e72d179607
test expr-28.429 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -47584241418 E-314 x -14e25dd3747e96_10000000000000000000000000000000000000001& E-1008
    convertToDouble -47584241418E-314
} 0x80f4e25dd3747e97
test expr-28.430 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -79360293406 E92 x -1c58a00bb31863_01111111111111111111111111111111111111110& E341
    convertToDouble -79360293406E92
} 0xd54c58a00bb31863
test expr-28.431 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +57332259349 E225 x 120811f528378b_01111111111111111111111111111111111111110& E783
    convertToDouble +57332259349E225
} 0x70e20811f528378b
test expr-28.432 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -57202326162 E111 x -1626f1c480545b_01111111111111111111111111111111111111110& E404
    convertToDouble -57202326162E111
} 0xd93626f1c480545b
test expr-28.433 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +86860597053 E-206 x 103b77d2b969d9_0111111111111111111111111111111111111111110& E-648
    convertToDouble +86860597053E-206
} 0x17703b77d2b969d9
test expr-28.434 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -53827010643 E-200 x -132fa69a69bd6d_0111111111111111111111111111111111111111110& E-629
    convertToDouble -53827010643E-200
} 0x98a32fa69a69bd6d
test expr-28.435 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +53587107423 E-61 x 100a19a3ffd981_011111111111111111111111111111111111111111110& E-167
    convertToDouble +53587107423E-61
} 0x35800a19a3ffd981
test expr-28.436 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +635007636765 E200 x 1824e73a4f030e_100000000000000000000000000000000000000000001& E703
    convertToDouble +635007636765E200
} 0x6be824e73a4f030f
test expr-28.437 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +508006109412 E201 x 1824e73a4f030e_100000000000000000000000000000000000000000001& E706
    convertToDouble +508006109412E201
} 0x6c1824e73a4f030f
test expr-28.438 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -254003054706 E201 x -1824e73a4f030e_100000000000000000000000000000000000000000001& E705
    convertToDouble -254003054706E201
} 0xec0824e73a4f030f
test expr-28.439 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +561029718715 E-72 x 1cd96a6972a14a_100000000000000000000000000000000000000000001& E-201
    convertToDouble +561029718715E-72
} 0x336cd96a6972a14b
test expr-28.440 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -897647549944 E-71 x -1cd96a6972a14a_100000000000000000000000000000000000000000001& E-197
    convertToDouble -897647549944E-71
} 0xb3acd96a6972a14b
test expr-28.441 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +112205943743 E-71 x 1cd96a6972a14a_100000000000000000000000000000000000000000001& E-200
    convertToDouble +112205943743E-71
} 0x337cd96a6972a14b
test expr-28.442 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -873947086081 E-236 x -19e117541d04e6_1000000000000000000000000000000000000000000001& E-745
    convertToDouble -873947086081E-236
} 0x9169e117541d04e7
test expr-28.443 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +809184709177 E116 x 1de27e59fb0679_011111111111111111111111111111111111111111110& E424
    convertToDouble +809184709177E116
} 0x5a7de27e59fb0679
test expr-28.444 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -573112917422 E81 x -11958b36c5102b_01111111111111111111111111111111111111111111110& E308
    convertToDouble -573112917422E81
} 0xd331958b36c5102b
test expr-28.445 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +286556458711 E81 x 11958b36c5102b_01111111111111111111111111111111111111111111110& E307
    convertToDouble +286556458711E81
} 0x5321958b36c5102b
test expr-28.446 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +952805821491 E-259 x 1551767ef8a9a3_011111111111111111111111111111111111111111110& E-821
    convertToDouble +952805821491E-259
} 0x0ca551767ef8a9a3
test expr-28.447 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -132189992873 E-44 x -1b746cf242410b_011111111111111111111111111111111111111111110& E-110
    convertToDouble -132189992873E-44
} 0xb91b746cf242410b
test expr-28.448 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -173696038493 E-144 x -1f8fefbb3249d3_011111111111111111111111111111111111111111110& E-442
    convertToDouble -173696038493E-144
} 0xa45f8fefbb3249d3
test expr-28.449 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +1831132757599 E-107 x 138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-315
    convertToDouble +1831132757599E-107
} 0x2c438e6edd48f2a3
test expr-28.450 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9155663787995 E-108 x -138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-316
    convertToDouble -9155663787995E-108
} 0xac338e6edd48f2a3
test expr-28.451 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7324531030396 E-107 x 138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-313
    convertToDouble +7324531030396E-107
} 0x2c638e6edd48f2a3
test expr-28.452 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9277338894969 E-200 x -19d5a44fd99a6a_1000000000000000000000000000000000000000000000001& E-622
    convertToDouble -9277338894969E-200
} 0x9919d5a44fd99a6b
test expr-28.453 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8188292423973 E287 x 1390273bf8f983_0111111111111111111111111111111111111111111111110& E996
    convertToDouble +8188292423973E287
} 0x7e3390273bf8f983
test expr-28.454 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5672557437938 E59 x -148c2bd60a1523_011111111111111111111111111111111111111111111110& E238
    convertToDouble -5672557437938E59
} 0xced48c2bd60a1523
test expr-28.455 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2836278718969 E59 x 148c2bd60a1523_011111111111111111111111111111111111111111111110& E237
    convertToDouble +2836278718969E59
} 0x4ec48c2bd60a1523
test expr-28.456 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -9995153153494 E54 x -17ba37c4fbe993_01111111111111111111111111111111111111111111110& E222
    convertToDouble -9995153153494E54
} 0xcdd7ba37c4fbe993
test expr-28.457 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9224786422069 E-291 x 14ee5d56b32957_011111111111111111111111111111111111111111111111110& E-924
    convertToDouble +9224786422069E-291
} 0x0634ee5d56b32957
test expr-28.458 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3142213164987 E-294 x -1d3409dfbca26f_011111111111111111111111111111111111111111111111110& E-936
    convertToDouble -3142213164987E-294
} 0x857d3409dfbca26f
test expr-28.459 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +6284426329974 E-294 x 1d3409dfbca26f_011111111111111111111111111111111111111111111111110& E-935
    convertToDouble +6284426329974E-294
} 0x058d3409dfbca26f
test expr-28.460 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8340483752889 E-301 x -10419183e44b91_01111111111111111111111111111111111111111111111110& E-957
    convertToDouble -8340483752889E-301
} 0x8420419183e44b91
test expr-28.461 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +67039371486466 E89 x 17f203339c9628_10000000000000000000000000000000000000000000000000001& E341
    convertToDouble +67039371486466E89
} 0x5547f203339c9629
test expr-28.462 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -62150786615239 E197 x -12e79a035b9714_1000000000000000000000000000000000000000000000000001& E700
    convertToDouble -62150786615239E197
} 0xebb2e79a035b9715
test expr-28.463 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +33519685743233 E89 x 17f203339c9628_10000000000000000000000000000000000000000000000000001& E340
    convertToDouble +33519685743233E89
} 0x5537f203339c9629
test expr-28.464 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -52563419496999 E156 x -1bdb17625bf6e6_1000000000000000000000000000000000000000000000000001& E563
    convertToDouble -52563419496999E156
} 0xe32bdb17625bf6e7
test expr-28.465 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +32599460466991 E-65 x 1f395d4c779d8e_1000000000000000000000000000000000000000000000000001& E-172
    convertToDouble +32599460466991E-65
} 0x353f395d4c779d8f
test expr-28.466 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -41010988798007 E-133 x -152e1c9e04ee06_100000000000000000000000000000000000000000000000001& E-397
    convertToDouble -41010988798007E-133
} 0xa7252e1c9e04ee07
test expr-28.467 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +65198920933982 E-65 x 1f395d4c779d8e_1000000000000000000000000000000000000000000000000001& E-171
    convertToDouble +65198920933982E-65
} 0x354f395d4c779d8f
test expr-28.468 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -82021977596014 E-133 x -152e1c9e04ee06_100000000000000000000000000000000000000000000000001& E-396
    convertToDouble -82021977596014E-133
} 0xa7352e1c9e04ee07
test expr-28.469 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +80527976643809 E61 x 1c7c5aea080a49_0111111111111111111111111111111111111111111111111110& E248
    convertToDouble +80527976643809E61
} 0x4f7c7c5aea080a49
test expr-28.470 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -74712611505209 E158 x -1eeebe9ea010f3_011111111111111111111111111111111111111111111111110& E570
    convertToDouble -74712611505209E158
} 0xe39eeebe9ea010f3
test expr-28.471 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +53390939710959 E261 x 18ac6d426a1cb1_0111111111111111111111111111111111111111111111111110& E912
    convertToDouble +53390939710959E261
} 0x78f8ac6d426a1cb1
test expr-28.472 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -69277302659155 E225 x -1547166a3a2b0f_011111111111111111111111111111111111111111111111110& E793
    convertToDouble -69277302659155E225
} 0xf18547166a3a2b0f
test expr-28.473 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +46202199371337 E-72 x 128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-194
    convertToDouble +46202199371337E-72
} 0x33d28f9edfbd341f
test expr-28.474 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -23438635467783 E-179 x -1ba485b99e47af_0111111111111111111111111111111111111111111111111110& E-551
    convertToDouble -23438635467783E-179
} 0x9d8ba485b99e47af
test expr-28.475 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +41921560615349 E-67 x 19b2a5c4041e4b_0111111111111111111111111111111111111111111111111110& E-178
    convertToDouble +41921560615349E-67
} 0x34d9b2a5c4041e4b
test expr-28.476 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -92404398742674 E-72 x -128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-193
    convertToDouble -92404398742674E-72
} 0xb3e28f9edfbd341f
test expr-28.477 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +738545606647197 E124 x 13d8886a766a20_100000000000000000000000000000000000000000000000000001& E461
    convertToDouble +738545606647197E124
} 0x5cc3d8886a766a21
test expr-28.478 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -972708181182949 E117 x -15ed1f039cebfe_1000000000000000000000000000000000000000000000000000001& E438
    convertToDouble -972708181182949E117
} 0xdb55ed1f039cebff
test expr-28.479 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -837992143580825 E87 x -17f203339c9628_10000000000000000000000000000000000000000000000000001& E338
    convertToDouble -837992143580825E87
} 0xd517f203339c9629
test expr-28.480 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +609610927149051 E-255 x 104273b18918b0_100000000000000000000000000000000000000000000000000000001& E-798
    convertToDouble +609610927149051E-255
} 0x0e104273b18918b1
test expr-28.481 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -475603213226859 E-41 x -178cfcab31064c_10000000000000000000000000000000000000000000000000000001& E-88
    convertToDouble -475603213226859E-41
} 0xba778cfcab31064d
test expr-28.482 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +563002800671023 E-177 x 1035e7b5183922_10000000000000000000000000000000000000000000000000000001& E-539
    convertToDouble +563002800671023E-177
} 0x1e4035e7b5183923
test expr-28.483 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -951206426453718 E-41 x -178cfcab31064c_10000000000000000000000000000000000000000000000000000001& E-87
    convertToDouble -951206426453718E-41
} 0xba878cfcab31064d
test expr-28.484 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +805416432656519 E202 x 175d226331d039_01111111111111111111111111111111111111111111111111111110& E720
    convertToDouble +805416432656519E202
} 0x6cf75d226331d039
test expr-28.485 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -530658674694337 E159 x -112a13daa46fe3_0111111111111111111111111111111111111111111111111111110& E577
    convertToDouble -530658674694337E159
} 0xe4012a13daa46fe3
test expr-28.486 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +946574173863918 E208 x 1a2fbffdb7580b_011111111111111111111111111111111111111111111111111110& E740
    convertToDouble +946574173863918E208
} 0x6e3a2fbffdb7580b
test expr-28.487 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -318329953318553 E113 x -178358811cbc95_011111111111111111111111111111111111111111111111111110& E423
    convertToDouble -318329953318553E113
} 0xda678358811cbc95
test expr-28.488 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -462021993713370 E-73 x -128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-194
    convertToDouble -462021993713370E-73
} 0xb3d28f9edfbd341f
test expr-28.489 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +369617594970696 E-72 x 128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-191
    convertToDouble +369617594970696E-72
} 0x34028f9edfbd341f
test expr-28.490 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3666156212014994 E233 x 1a37935f3b71c8_100000000000000000000000000000000000000000000000000000001& E825
    convertToDouble +3666156212014994E233
} 0x738a37935f3b71c9
test expr-28.491 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1833078106007497 E233 x -1a37935f3b71c8_100000000000000000000000000000000000000000000000000000001& E824
    convertToDouble -1833078106007497E233
} 0xf37a37935f3b71c9
test expr-28.492 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +8301790508624232 E174 x 1dcfee6690ffc6_100000000000000000000000000000000000000000000000000000001& E630
    convertToDouble +8301790508624232E174
} 0x675dcfee6690ffc7
test expr-28.493 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1037723813578029 E174 x -1dcfee6690ffc6_100000000000000000000000000000000000000000000000000000001& E627
    convertToDouble -1037723813578029E174
} 0xe72dcfee6690ffc7
test expr-28.494 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7297662880581139 E-286 x 18ac8c79e1ff18_1000000000000000000000000000000000000000000000000000000000001& E-898
    convertToDouble +7297662880581139E-286
} 0x07d8ac8c79e1ff19
test expr-28.495 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -5106185698912191 E-276 x -141934d77659be_1000000000000000000000000000000000000000000000000000000000001& E-865
    convertToDouble -5106185698912191E-276
} 0x89e41934d77659bf
test expr-28.496 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7487252720986826 E-165 x 18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-496
    convertToDouble +7487252720986826E-165
} 0x20f8823a57adbef9
test expr-28.497 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3743626360493413 E-165 x -18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-497
    convertToDouble -3743626360493413E-165
} 0xa0e8823a57adbef9
test expr-28.498 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3773057430100257 E230 x 1ba10d818fdafd_0111111111111111111111111111111111111111111111111111111110& E815
    convertToDouble +3773057430100257E230
} 0x72eba10d818fdafd
test expr-28.499 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7546114860200514 E230 x -1ba10d818fdafd_0111111111111111111111111111111111111111111111111111111110& E816
    convertToDouble -7546114860200514E230
} 0xf2fba10d818fdafd
test expr-28.500 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4321222892463822 E58 x 18750ea732fdad_011111111111111111111111111111111111111111111111111111110& E244
    convertToDouble +4321222892463822E58
} 0x4f38750ea732fdad
test expr-28.501 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7793560217139653 E51 x -1280461b856ec5_0111111111111111111111111111111111111111111111111111111110& E222
    convertToDouble -7793560217139653E51
} 0xcdd280461b856ec5
test expr-28.502 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +26525993941010681 E112 x 187dcbf6ad5cf8_10000000000000000000000000000000000000000000000000000000000001& E426
    convertToDouble +26525993941010681E112
} 0x5a987dcbf6ad5cf9
test expr-28.503 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -53051987882021362 E112 x -187dcbf6ad5cf8_10000000000000000000000000000000000000000000000000000000000001& E427
    convertToDouble -53051987882021362E112
} 0xdaa87dcbf6ad5cf9
test expr-28.504 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +72844871414247907 E77 x 1bf00baf60b70c_100000000000000000000000000000000000000000000000000000000001& E311
    convertToDouble +72844871414247907E77
} 0x536bf00baf60b70d
test expr-28.505 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -88839359596763261 E105 x -1133b1a33a1108_100000000000000000000000000000000000000000000000000000000001& E405
    convertToDouble -88839359596763261E105
} 0xd94133b1a33a1109
test expr-28.506 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +18718131802467065 E-166 x 18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-498
    convertToDouble +18718131802467065E-166
} 0x20d8823a57adbef9
test expr-28.507 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -14974505441973652 E-165 x -18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-495
    convertToDouble -14974505441973652E-165
} 0xa108823a57adbef9
test expr-28.508 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +73429396004640239 E106 x 11c5cb19ef3451_01111111111111111111111111111111111111111111111111111111111110& E408
    convertToDouble +73429396004640239E106
} 0x5971c5cb19ef3451
test expr-28.509 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -58483921078398283 E57 x -108ce499519ce3_0111111111111111111111111111111111111111111111111111111111111110& E245
    convertToDouble -58483921078398283E57
} 0xcf408ce499519ce3
test expr-28.510 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +41391519190645203 E165 x 13f33667156017_011111111111111111111111111111111111111111111111111111111111110& E603
    convertToDouble +41391519190645203E165
} 0x65a3f33667156017
test expr-28.511 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -82783038381290406 E165 x -13f33667156017_011111111111111111111111111111111111111111111111111111111111110& E604
    convertToDouble -82783038381290406E165
} 0xe5b3f33667156017
test expr-28.512 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +58767043776702677 E-163 x 12c92fee3a3867_0111111111111111111111111111111111111111111111111111111111110& E-486
    convertToDouble +58767043776702677E-163
} 0x2192c92fee3a3867
test expr-28.513 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -90506231831231999 E-129 x -1bdc4114397ff3_01111111111111111111111111111111111111111111111111111111111110& E-373
    convertToDouble -90506231831231999E-129
} 0xa8abdc4114397ff3
test expr-28.514 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +64409240769861689 E-159 x 192238f7987779_011111111111111111111111111111111111111111111111111111111111110& E-473
    convertToDouble +64409240769861689E-159
} 0x22692238f7987779
test expr-28.515 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -77305427432277771 E-190 x -1e978b7780b613_0111111111111111111111111111111111111111111111111111111111110& E-576
    convertToDouble -77305427432277771E-190
} 0x9bfe978b7780b613
test expr-28.516 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +476592356619258326 E273 x 1873cf8ee72812_10000000000000000000000000000000000000000000000000000000000000001& E965
    convertToDouble +476592356619258326E273
} 0x7c4873cf8ee72813
test expr-28.517 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -953184713238516652 E273 x -1873cf8ee72812_10000000000000000000000000000000000000000000000000000000000000001& E966
    convertToDouble -953184713238516652E273
} 0xfc5873cf8ee72813
test expr-28.518 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +899810892172646163 E283 x 1adf51fa055e02_100000000000000000000000000000000000000000000000000000000000000000001& E999
    convertToDouble +899810892172646163E283
} 0x7e6adf51fa055e03
test expr-28.519 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -929167076892018333 E187 x -1da2c42fce2bc4_10000000000000000000000000000000000000000000000000000000000000000001& E680
    convertToDouble -929167076892018333E187
} 0xea7da2c42fce2bc5
test expr-28.520 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +647761278967534239 E-312 x 1a7a2476ec0b3e_10000000000000000000000000000000000000000000000000000000000000001& E-978
    convertToDouble +647761278967534239E-312
} 0x02da7a2476ec0b3f
test expr-28.521 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -644290479820542942 E-180 x -128d1407dfa832_10000000000000000000000000000000000000000000000000000000000000001& E-539
    convertToDouble -644290479820542942E-180
} 0x9e428d1407dfa833
test expr-28.522 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +926145344610700019 E-225 x 1307a67f1f69fe_10000000000000000000000000000000000000000000000000000000000000000001& E-688
    convertToDouble +926145344610700019E-225
} 0x14f307a67f1f69ff
test expr-28.523 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -958507931896511964 E-246 x -17406753df2f0c_10000000000000000000000000000000000000000000000000000000000000001& E-758
    convertToDouble -958507931896511964E-246
} 0x9097406753df2f0d
test expr-28.524 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +272104041512242479 E200 x 13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E722
    convertToDouble +272104041512242479E200
} 0x6d13bbb4bf05f087
test expr-28.525 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -792644927852378159 E79 x -1daff0048f3ec7_011111111111111111111111111111111111111111111111111111111111111111110& E321
    convertToDouble -792644927852378159E79
} 0xd40daff0048f3ec7
test expr-28.526 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +544208083024484958 E200 x 13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E723
    convertToDouble +544208083024484958E200
} 0x6d23bbb4bf05f087
test expr-28.527 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -929963218616126365 E290 x -108dcc0c505461_01111111111111111111111111111111111111111111111111111111111111110& E1023
    convertToDouble -929963218616126365E290
} 0xffe08dcc0c505461
test expr-28.528 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +305574339166810102 E-219 x 17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-670
    convertToDouble +305574339166810102E-219
} 0x1617f399fe02c4b9
test expr-28.529 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -152787169583405051 E-219 x -17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-671
    convertToDouble -152787169583405051E-219
} 0x9607f399fe02c4b9
test expr-28.530 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +611148678333620204 E-219 x 17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-669
    convertToDouble +611148678333620204E-219
} 0x1627f399fe02c4b9
test expr-28.531 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -763935847917025255 E-220 x -17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-672
    convertToDouble -763935847917025255E-220
} 0x95f7f399fe02c4b9
test expr-28.532 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +7439550220920798612 E158 x 177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E587
    convertToDouble +7439550220920798612E158
} 0x64a77fe14f40159b
test expr-28.533 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -3719775110460399306 E158 x -177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E586
    convertToDouble -3719775110460399306E158
} 0xe4977fe14f40159b
test expr-28.534 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +9299437776150998265 E157 x 177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E584
    convertToDouble +9299437776150998265E157
} 0x64777fe14f40159b
test expr-28.535 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7120190517612959703 E120 x -13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E461
    convertToDouble -7120190517612959703E120
} 0xdcc3220dcd5899fd
test expr-28.536 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +3507665085003296281 E-73 x 11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-181
    convertToDouble +3507665085003296281E-73
} 0x34a1339818257f0f
test expr-28.537 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -7015330170006592562 E-73 x -11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-180
    convertToDouble -7015330170006592562E-73
} 0xb4b1339818257f0f
test expr-28.538 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -6684428762278255956 E-294 x -1d9f82a1a6b1b8_10000000000000000000000000000000000000000000000000000000000000000001& E-915
    convertToDouble -6684428762278255956E-294
} 0x86cd9f82a1a6b1b9
test expr-28.539 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -1088416166048969916 E200 x -13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E724
    convertToDouble -1088416166048969916E200
} 0xed33bbb4bf05f087
test expr-28.540 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8707329328391759328 E200 x -13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E727
    convertToDouble -8707329328391759328E200
} 0xed63bbb4bf05f087
test expr-28.541 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +4439021781608558002 E-65 x 1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-154
    convertToDouble +4439021781608558002E-65
} 0x365038168b71e2c9
test expr-28.542 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -8878043563217116004 E-65 x -1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-153
    convertToDouble -8878043563217116004E-65
} 0xb66038168b71e2c9
test expr-28.543 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +2219510890804279001 E-65 x 1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-155
    convertToDouble +2219510890804279001E-65
} 0x364038168b71e2c9
test expr-28.544 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +33051223951904955802 E55 x 1762068a24fd54_1000000000000000000000000000000000000000000000000000000000000000000000001& E247
    convertToDouble +33051223951904955802E55
} 0x4f6762068a24fd55
test expr-28.545 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -56961524140903677624 E120 x -13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E464
    convertToDouble -56961524140903677624E120
} 0xdcf3220dcd5899fd
test expr-28.546 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +71201905176129597030 E119 x 13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E461
    convertToDouble +71201905176129597030E119
} 0x5cc3220dcd5899fd
test expr-28.547 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +14030660340013185124 E-73 x 11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-179
    convertToDouble +14030660340013185124E-73
} 0x34c1339818257f0f
test expr-28.548 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -17538325425016481405 E-74 x -11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-182
    convertToDouble -17538325425016481405E-74
} 0xb491339818257f0f
test expr-28.549 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +67536228609141569109 E-133 x 10a1b35cf2a635_01111111111111111111111111111111111111111111111111111111111111111111110& E-376
    convertToDouble +67536228609141569109E-133
} 0x2870a1b35cf2a635
test expr-28.550 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -35620497849450218807 E-306 x -15b22082529425_0111111111111111111111111111111111111111111111111111111111111111111111110& E-952
    convertToDouble -35620497849450218807E-306
} 0x8475b22082529425
test expr-28.551 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN +66550376797582521751 E-126 x 13897c0ede6c69_01111111111111111111111111111111111111111111111111111111111111111111110& E-353
    convertToDouble +66550376797582521751E-126
} 0x29e3897c0ede6c69
test expr-28.552 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b d UN -71240995698900437614 E-306 x -15b22082529425_0111111111111111111111111111111111111111111111111111111111111111111111110& E-951
    convertToDouble -71240995698900437614E-306
} 0x8485b22082529425
test expr-28.553 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +3 E24 x 13da329b633647_0001& E81
    convertToDouble +3E24
} 0x4503da329b633647
test expr-28.554 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -6 E24 x -13da329b633647_0001& E82
    convertToDouble -6E24
} 0xc513da329b633647
test expr-28.555 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6 E26 x 1f04ef12cb04cf_0001& E88
    convertToDouble +6E26
} 0x457f04ef12cb04cf
test expr-28.556 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7 E25 x -1cf389cd46047d_0000001& E85
    convertToDouble -7E25
} 0xc54cf389cd46047d
test expr-28.557 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +1 E-14 x 16849b86a12b9b_00000001& E-47
    convertToDouble +1E-14
} 0x3d06849b86a12b9b
test expr-28.558 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2 E-14 x -16849b86a12b9b_00000001& E-46
    convertToDouble -2E-14
} 0xbd16849b86a12b9b
test expr-28.559 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4 E-14 x 16849b86a12b9b_00000001& E-45
    convertToDouble +4E-14
} 0x3d26849b86a12b9b
test expr-28.560 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8 E-14 x -16849b86a12b9b_00000001& E-44
    convertToDouble -8E-14
} 0xbd36849b86a12b9b
test expr-28.561 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5 E26 x 19d971e4fe8401_1110& E88
    convertToDouble +5E26
} 0x4579d971e4fe8402
test expr-28.562 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8 E27 x -19d971e4fe8401_1110& E92
    convertToDouble -8E27
} 0xc5b9d971e4fe8402
test expr-28.563 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +1 E27 x 19d971e4fe8401_1110& E89
    convertToDouble +1E27
} 0x4589d971e4fe8402
test expr-28.564 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4 E27 x -19d971e4fe8401_1110& E91
    convertToDouble -4E27
} 0xc5a9d971e4fe8402
test expr-28.565 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9 E-13 x 1faa7ab552a551_111110& E-41
    convertToDouble +9E-13
} 0x3d6faa7ab552a552
test expr-28.566 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7 E-20 x -14a90ceafff9de_11110& E-64
    convertToDouble -7E-20
} 0xbbf4a90ceafff9df
test expr-28.567 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +56 E25 x 1cf389cd46047d_0000001& E88
    convertToDouble +56E25
} 0x457cf389cd46047d
test expr-28.568 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -70 E24 x -1cf389cd46047d_0000001& E85
    convertToDouble -70E24
} 0xc54cf389cd46047d
test expr-28.569 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +51 E26 x 107a9f01fbda8e_0000001& E92
    convertToDouble +51E26
} 0x45b07a9f01fbda8e
test expr-28.570 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +71 E-17 x 19949819f693d7_00000000001& E-51
    convertToDouble +71E-17
} 0x3cc9949819f693d7
test expr-28.571 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -31 E-5 x -1450efdc9c4da9_00000000001& E-12
    convertToDouble -31E-5
} 0xbf3450efdc9c4da9
test expr-28.572 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +62 E-5 x 1450efdc9c4da9_00000000001& E-11
    convertToDouble +62E-5
} 0x3f4450efdc9c4da9
test expr-28.573 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -94 E-8 x -1f8a89dc374df5_0000000001& E-21
    convertToDouble -94E-8
} 0xbeaf8a89dc374df5
test expr-28.574 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +67 E27 x 1b0fa33bba7231_11111110& E95
    convertToDouble +67E27
} 0x45eb0fa33bba7232
test expr-28.575 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -81 E24 x -10c01ab31bb5cb_1111110& E86
    convertToDouble -81E24
} 0xc550c01ab31bb5cc
test expr-28.576 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +54 E23 x 11ddfa58a6173f_111110& E82
    convertToDouble +54E23
} 0x4511ddfa58a61740
test expr-28.577 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -54 E25 x -1bead72a838453_111110& E88
    convertToDouble -54E25
} 0xc57bead72a838454
test expr-28.578 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +63 E-22 x 1dc03b8fd70169_11111111110& E-68
    convertToDouble +63E-22
} 0x3bbdc03b8fd7016a
test expr-28.579 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -63 E-23 x -17ccfc73126787_11111111110& E-71
    convertToDouble -63E-23
} 0xbb87ccfc73126788
test expr-28.580 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +43 E-4 x 119ce075f6fd21_111111110& E-8
    convertToDouble +43E-4
} 0x3f719ce075f6fd22
test expr-28.581 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -86 E-4 x -119ce075f6fd21_111111110& E-7
    convertToDouble -86E-4
} 0xbf819ce075f6fd22
test expr-28.582 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +942 E26 x 1306069e8681f3_00000000001& E96
    convertToDouble +942E26
} 0x45f306069e8681f3
test expr-28.583 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -471 E25 x -1e700a973d9cb8_0000000001& E91
    convertToDouble -471E25
} 0xc5ae700a973d9cb8
test expr-28.584 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +803 E24 x 14c1cee9cd666b_000000000001& E89
    convertToDouble +803E24
} 0x4584c1cee9cd666b
test expr-28.585 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -471 E26 x -1306069e8681f3_00000000001& E95
    convertToDouble -471E26
} 0xc5e306069e8681f3
test expr-28.586 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -409 E-21 x -1e2dcaa4115622_000000000001& E-62
    convertToDouble -409E-21
} 0xbc1e2dcaa4115622
test expr-28.587 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +818 E-21 x 1e2dcaa4115622_000000000001& E-61
    convertToDouble +818E-21
} 0x3c2e2dcaa4115622
test expr-28.588 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -867 E-8 x -122eabba029aba_000000000001& E-17
    convertToDouble -867E-8
} 0xbee22eabba029aba
test expr-28.589 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +538 E27 x 1b297cad9f70b5_1111111111111110& E98
    convertToDouble +538E27
} 0x461b297cad9f70b6
test expr-28.590 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -857 E24 x -16272678ba603b_11111111110& E89
    convertToDouble -857E24
} 0xc586272678ba603c
test expr-28.591 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +269 E27 x 1b297cad9f70b5_1111111111111110& E97
    convertToDouble +269E27
} 0x460b297cad9f70b6
test expr-28.592 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -403 E26 x -1046ec1e31dd85_1111111110& E95
    convertToDouble -403E26
} 0xc5e046ec1e31dd86
test expr-28.593 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +959 E-7 x 1923bd746a3527_11111111111110& E-14
    convertToDouble +959E-7
} 0x3f1923bd746a3528
test expr-28.594 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -959 E-6 x -1f6cacd184c271_1111111111110& E-11
    convertToDouble -959E-6
} 0xbf4f6cacd184c272
test expr-28.595 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +373 E-27 x 1cdc06b20ef182_1111111111110& E-82
    convertToDouble +373E-27
} 0x3adcdc06b20ef183
test expr-28.596 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -746 E-27 x -1cdc06b20ef182_1111111111110& E-81
    convertToDouble -746E-27
} 0xbaecdc06b20ef183
test expr-28.597 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4069 E24 x 1a4b9887fbfe7a_0000000000001& E91
    convertToDouble +4069E24
} 0x45aa4b9887fbfe7a
test expr-28.598 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4069 E23 x -150946d32ffec8_0000000000001& E88
    convertToDouble -4069E23
} 0xc5750946d32ffec8
test expr-28.599 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8138 E24 x -1a4b9887fbfe7a_0000000000001& E92
    convertToDouble -8138E24
} 0xc5ba4b9887fbfe7a
test expr-28.600 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8294 E-15 x 123d1b5eb1d778_000000000000000001& E-37
    convertToDouble +8294E-15
} 0x3da23d1b5eb1d778
test expr-28.601 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4147 E-14 x -16cc62365e4d56_00000000000000001& E-35
    convertToDouble -4147E-14
} 0xbdc6cc62365e4d56
test expr-28.602 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4147 E-15 x 123d1b5eb1d778_000000000000000001& E-38
    convertToDouble +4147E-15
} 0x3d923d1b5eb1d778
test expr-28.603 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8294 E-14 x -16cc62365e4d56_00000000000000001& E-34
    convertToDouble -8294E-14
} 0xbdd6cc62365e4d56
test expr-28.604 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +538 E27 x 1b297cad9f70b5_1111111111111110& E98
    convertToDouble +538E27
} 0x461b297cad9f70b6
test expr-28.605 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2690 E26 x -1b297cad9f70b5_1111111111111110& E97
    convertToDouble -2690E26
} 0xc60b297cad9f70b6
test expr-28.606 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +269 E27 x 1b297cad9f70b5_1111111111111110& E97
    convertToDouble +269E27
} 0x460b297cad9f70b6
test expr-28.607 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2152 E27 x -1b297cad9f70b5_1111111111111110& E100
    convertToDouble -2152E27
} 0xc63b297cad9f70b6
test expr-28.608 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +1721 E-17 x 136071dcae4564_111111111111110& E-46
    convertToDouble +1721E-17
} 0x3d136071dcae4565
test expr-28.609 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7979 E-27 x -134ac304747faf_111111111111110& E-77
    convertToDouble -7979E-27
} 0xbb234ac304747fb0
test expr-28.610 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6884 E-17 x 136071dcae4564_111111111111110& E-44
    convertToDouble +6884E-17
} 0x3d336071dcae4565
test expr-28.611 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8605 E-18 x -136071dcae4564_111111111111110& E-47
    convertToDouble -8605E-18
} 0xbd036071dcae4565
test expr-28.612 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +82854 E27 x 10570ed9e3cecc_00000000000000001& E106
    convertToDouble +82854E27
} 0x4690570ed9e3cecc
test expr-28.613 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -55684 E24 x -167d9735144ae3_00000000000000001& E95
    convertToDouble -55684E24
} 0xc5e67d9735144ae3
test expr-28.614 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +27842 E24 x 167d9735144ae3_00000000000000001& E94
    convertToDouble +27842E24
} 0x45d67d9735144ae3
test expr-28.615 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -48959 E25 x -18b7cd6ca56f85_00000000000000001& E98
    convertToDouble -48959E25
} 0xc618b7cd6ca56f85
test expr-28.616 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +81921 E-17 x 1cd2c9a6cdd003_000000000000000000001& E-41
    convertToDouble +81921E-17
} 0x3d6cd2c9a6cdd003
test expr-28.617 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -76207 E-8 x -18f8b4dd16f1df_0000000000000000001& E-11
    convertToDouble -76207E-8
} 0xbf48f8b4dd16f1df
test expr-28.618 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4147 E-15 x 123d1b5eb1d778_000000000000000001& E-38
    convertToDouble +4147E-15
} 0x3d923d1b5eb1d778
test expr-28.619 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -41470 E-16 x -123d1b5eb1d778_000000000000000001& E-38
    convertToDouble -41470E-16
} 0xbd923d1b5eb1d778
test expr-28.620 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +89309 E24 x 12092ac5f2019e_1111111111111111110& E96
    convertToDouble +89309E24
} 0x45f2092ac5f2019f
test expr-28.621 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +75859 E26 x 17efd75a2938eb_1111111111111111111110& E102
    convertToDouble +75859E26
} 0x4657efd75a2938ec
test expr-28.622 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -75859 E25 x -132645e1ba93ef_1111111111111111111110& E99
    convertToDouble -75859E25
} 0xc6232645e1ba93f0
test expr-28.623 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +14257 E-23 x 150a246ecd44f2_1111111111111111110& E-63
    convertToDouble +14257E-23
} 0x3c050a246ecd44f3
test expr-28.624 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -28514 E-23 x -150a246ecd44f2_1111111111111111110& E-62
    convertToDouble -28514E-23
} 0xbc150a246ecd44f3
test expr-28.625 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +57028 E-23 x 150a246ecd44f2_1111111111111111110& E-61
    convertToDouble +57028E-23
} 0x3c250a246ecd44f3
test expr-28.626 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -71285 E-24 x -150a246ecd44f2_1111111111111111110& E-64
    convertToDouble -71285E-24
} 0xbbf50a246ecd44f3
test expr-28.627 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +344863 E27 x 1100c873963d6d_00000000000000000001& E108
    convertToDouble +344863E27
} 0x46b100c873963d6d
test expr-28.628 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -951735 E27 x -17764ad224e24a_000000000000000000001& E109
    convertToDouble -951735E27
} 0xc6c7764ad224e24a
test expr-28.629 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +200677 E23 x 1035e73135b834_0000000000000000001& E94
    convertToDouble +200677E23
} 0x45d035e73135b834
test expr-28.630 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -401354 E24 x -144360fd832641_0000000000000000001& E98
    convertToDouble -401354E24
} 0xc6144360fd832641
test expr-28.631 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +839604 E-11 x 119b96f36ec68b_00000000000000000000000001& E-17
    convertToDouble +839604E-11
} 0x3ee19b96f36ec68b
test expr-28.632 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -209901 E-11 x -119b96f36ec68b_00000000000000000000000001& E-19
    convertToDouble -209901E-11
} 0xbec19b96f36ec68b
test expr-28.633 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +419802 E-11 x 119b96f36ec68b_00000000000000000000000001& E-18
    convertToDouble +419802E-11
} 0x3ed19b96f36ec68b
test expr-28.634 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -537734 E-24 x -13d6c1088ae40e_0000000000000000000001& E-61
    convertToDouble -537734E-24
} 0xbc23d6c1088ae40e
test expr-28.635 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +910308 E26 x 11f3e1839eeab0_11111111111111111111110& E106
    convertToDouble +910308E26
} 0x4691f3e1839eeab1
test expr-28.636 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -227577 E26 x -11f3e1839eeab0_11111111111111111111110& E104
    convertToDouble -227577E26
} 0xc671f3e1839eeab1
test expr-28.637 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +455154 E26 x 11f3e1839eeab0_11111111111111111111110& E105
    convertToDouble +455154E26
} 0x4681f3e1839eeab1
test expr-28.638 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -531013 E25 x -10c17d25834171_11111111111111111111110& E102
    convertToDouble -531013E25
} 0xc650c17d25834172
test expr-28.639 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +963019 E-21 x 11592429784914_11111111111111111111110& E-50
    convertToDouble +963019E-21
} 0x3cd1592429784915
test expr-28.640 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -519827 E-13 x -1be872a8b30d7c_11111111111111111111110& E-25
    convertToDouble -519827E-13
} 0xbe6be872a8b30d7d
test expr-28.641 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +623402 E-27 x 178d2c97bde2a0_11111111111111111111110& E-71
    convertToDouble +623402E-27
} 0x3b878d2c97bde2a1
test expr-28.642 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -311701 E-27 x -178d2c97bde2a0_11111111111111111111110& E-72
    convertToDouble -311701E-27
} 0xbb778d2c97bde2a1
test expr-28.643 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9613651 E26 x 17b31116270d9b_000000000000000000000001& E109
    convertToDouble +9613651E26
} 0x46c7b31116270d9b
test expr-28.644 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9191316 E23 x -1733bfae0801fd_0000000000000000000001& E99
    convertToDouble -9191316E23
} 0xc62733bfae0801fd
test expr-28.645 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4595658 E23 x 1733bfae0801fd_0000000000000000000001& E98
    convertToDouble +4595658E23
} 0x461733bfae0801fd
test expr-28.646 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2297829 E23 x -1733bfae0801fd_0000000000000000000001& E97
    convertToDouble -2297829E23
} 0xc60733bfae0801fd
test expr-28.647 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1679208 E-11 x -119b96f36ec68b_00000000000000000000000001& E-16
    convertToDouble -1679208E-11
} 0xbef19b96f36ec68b
test expr-28.648 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +3379223 E27 x 14d3794ce2fc25_1111111111111111111111110& E111
    convertToDouble +3379223E27
} 0x46e4d3794ce2fc26
test expr-28.649 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -6758446 E27 x -14d3794ce2fc25_1111111111111111111111110& E112
    convertToDouble -6758446E27
} 0xc6f4d3794ce2fc26
test expr-28.650 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5444097 E-21 x 18849dd33c95ae_11111111111111111111111111110& E-48
    convertToDouble +5444097E-21
} 0x3cf8849dd33c95af
test expr-28.651 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8399969 E-27 x -13d5783e85fcf7_1111111111111111111111110& E-67
    convertToDouble -8399969E-27
} 0xbbc3d5783e85fcf8
test expr-28.652 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8366487 E-16 x 1cbf3d630403af_1111111111111111111111110& E-31
    convertToDouble +8366487E-16
} 0x3e0cbf3d630403b0
test expr-28.653 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8366487 E-15 x -11f7865de2824d_11111111111111111111111110& E-27
    convertToDouble -8366487E-15
} 0xbe41f7865de2824e
test expr-28.654 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +65060671 E25 x 1009e7d474572a_0000000000000000000000000001& E109
    convertToDouble +65060671E25
} 0x46c009e7d474572a
test expr-28.655 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +65212389 E23 x 1493d098d37657_000000000000000000000000001& E102
    convertToDouble +65212389E23
} 0x465493d098d37657
test expr-28.656 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +55544957 E-13 x 174c1826f3010c_00000000000000000000000000001& E-18
    convertToDouble +55544957E-13
} 0x3ed74c1826f3010c
test expr-28.657 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -51040905 E-20 x -11f55b23c8bf2d_0000000000000000000000000001& E-41
    convertToDouble -51040905E-20
} 0xbd61f55b23c8bf2d
test expr-28.658 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +99585767 E-22 x 166cba8699f0f2_0000000000000000000000000001& E-47
    convertToDouble +99585767E-22
} 0x3d066cba8699f0f2
test expr-28.659 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -99585767 E-23 x -11f095387b2728_0000000000000000000000000001& E-50
    convertToDouble -99585767E-23
} 0xbcd1f095387b2728
test expr-28.660 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +40978393 E26 x 1941401cca2bfd_1111111111111111111111111110& E111
    convertToDouble +40978393E26
} 0x46e941401cca2bfe
test expr-28.661 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -67488159 E24 x -1a9e90059d12db_11111111111111111111111111110& E105
    convertToDouble -67488159E24
} 0xc68a9e90059d12dc
test expr-28.662 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +69005339 E23 x 15c634f6ef1f95_111111111111111111111111110& E102
    convertToDouble +69005339E23
} 0x4655c634f6ef1f96
test expr-28.663 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -81956786 E26 x -1941401cca2bfd_1111111111111111111111111110& E112
    convertToDouble -81956786E26
} 0xc6f941401cca2bfe
test expr-28.664 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -87105552 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-44
    convertToDouble -87105552E-21
} 0xbd38849dd33c95af
test expr-28.665 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +10888194 E-21 x 18849dd33c95ae_11111111111111111111111111110& E-47
    convertToDouble +10888194E-21
} 0x3d08849dd33c95af
test expr-28.666 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -21776388 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-46
    convertToDouble -21776388E-21
} 0xbd18849dd33c95af
test expr-28.667 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +635806667 E27 x 1e9cec176c96f8_000000000000000000000000000000001& E118
    convertToDouble +635806667E27
} 0x475e9cec176c96f8
test expr-28.668 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -670026614 E25 x -14a593f89f4194_00000000000000000000000000000001& E112
    convertToDouble -670026614E25
} 0xc6f4a593f89f4194
test expr-28.669 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +335013307 E26 x 19cef8f6c711f9_0000000000000000000000000000001& E114
    convertToDouble +335013307E26
} 0x4719cef8f6c711f9
test expr-28.670 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -335013307 E25 x -14a593f89f4194_00000000000000000000000000000001& E111
    convertToDouble -335013307E25
} 0xc6e4a593f89f4194
test expr-28.671 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +371790617 E-24 x 1aca538c61ba9c_000000000000000000000000000000001& E-52
    convertToDouble +371790617E-24
} 0x3cbaca538c61ba9c
test expr-28.672 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -371790617 E-25 x -156ea93d1afbb0_0000000000000000000000000000000001& E-55
    convertToDouble -371790617E-25
} 0xbc856ea93d1afbb0
test expr-28.673 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +743581234 E-24 x 1aca538c61ba9c_000000000000000000000000000000001& E-51
    convertToDouble +743581234E-24
} 0x3ccaca538c61ba9c
test expr-28.674 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -743581234 E-25 x -156ea93d1afbb0_0000000000000000000000000000000001& E-54
    convertToDouble -743581234E-25
} 0xbc956ea93d1afbb0
test expr-28.675 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +202464477 E24 x 13f6ec0435ce24_111111111111111111111111111110& E107
    convertToDouble +202464477E24
} 0x46a3f6ec0435ce25
test expr-28.676 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -404928954 E24 x -13f6ec0435ce24_111111111111111111111111111110& E108
    convertToDouble -404928954E24
} 0xc6b3f6ec0435ce25
test expr-28.677 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +997853758 E27 x 1805bfa33b98fa_111111111111111111111111111110& E119
    convertToDouble +997853758E27
} 0x476805bfa33b98fb
test expr-28.678 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -997853758 E26 x -1337cc829613fb_111111111111111111111111111110& E116
    convertToDouble -997853758E26
} 0xc73337cc829613fc
test expr-28.679 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +405498418 E-17 x 116a8093df66a6_111111111111111111111111111111110& E-28
    convertToDouble +405498418E-17
} 0x3e316a8093df66a7
test expr-28.680 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -582579084 E-14 x -186f653140a658_111111111111111111111111111111110& E-18
    convertToDouble -582579084E-14
} 0xbed86f653140a659
test expr-28.681 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +608247627 E-18 x 14e633e4a5ae61_111111111111111111111111111111110& E-31
    convertToDouble +608247627E-18
} 0x3e04e633e4a5ae62
test expr-28.682 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -291289542 E-14 x -186f653140a658_111111111111111111111111111111110& E-19
    convertToDouble -291289542E-14
} 0xbec86f653140a659
test expr-28.683 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9537100005 E26 x -16f5b11191713a_000000000000000000000000000000001& E119
    convertToDouble -9537100005E26
} 0xc766f5b11191713a
test expr-28.684 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6358066670 E27 x 1322138ea3de5b_000000000000000000000000000000001& E122
    convertToDouble +6358066670E27
} 0x479322138ea3de5b
test expr-28.685 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1271613334 E27 x -1e9cec176c96f8_000000000000000000000000000000001& E119
    convertToDouble -1271613334E27
} 0xc76e9cec176c96f8
test expr-28.686 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5229646999 E-16 x 118c3b89731f3d_000000000000000000000000000000000001& E-21
    convertToDouble +5229646999E-16
} 0x3ea18c3b89731f3d
test expr-28.687 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5229646999 E-17 x 1c13927584fec8_00000000000000000000000000000000001& E-25
    convertToDouble +5229646999E-17
} 0x3e6c13927584fec8
test expr-28.688 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4429943614 E24 x 1b4d37fa06864a_1111111111111111111111111111111110& E111
    convertToDouble +4429943614E24
} 0x46eb4d37fa06864b
test expr-28.689 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8859887228 E24 x -1b4d37fa06864a_1111111111111111111111111111111110& E112
    convertToDouble -8859887228E24
} 0xc6fb4d37fa06864b
test expr-28.690 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +2214971807 E24 x 1b4d37fa06864a_1111111111111111111111111111111110& E110
    convertToDouble +2214971807E24
} 0x46db4d37fa06864b
test expr-28.691 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4176887093 E26 x -141c692c5bd07a_111111111111111111111111111111110& E118
    convertToDouble -4176887093E26
} 0xc7541c692c5bd07b
test expr-28.692 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4003495257 E-20 x 16026b2e07ec06_111111111111111111111111111111111110& E-35
    convertToDouble +4003495257E-20
} 0x3dc6026b2e07ec07
test expr-28.693 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4361901637 E-23 x -188e29a9d7c5b8_11111111111111111111111111111111110& E-45
    convertToDouble -4361901637E-23
} 0xbd288e29a9d7c5b9
test expr-28.694 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8723803274 E-23 x 188e29a9d7c5b8_11111111111111111111111111111111110& E-44
    convertToDouble +8723803274E-23
} 0x3d388e29a9d7c5b9
test expr-28.695 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8006990514 E-20 x -16026b2e07ec06_111111111111111111111111111111111110& E-34
    convertToDouble -8006990514E-20
} 0xbdd6026b2e07ec07
test expr-28.696 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +72835110098 E27 x 1b65c41711fb6d_0000000000000000000000000000000000001& E125
    convertToDouble +72835110098E27
} 0x47cb65c41711fb6d
test expr-28.697 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -36417555049 E27 x -1b65c41711fb6d_0000000000000000000000000000000000001& E124
    convertToDouble -36417555049E27
} 0xc7bb65c41711fb6d
test expr-28.698 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +84279630104 E25 x 144a221b1cf62e_000000000000000000000000000000000001& E119
    convertToDouble +84279630104E25
} 0x47644a221b1cf62e
test expr-28.699 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -84279630104 E24 x -103b4e7c172b58_000000000000000000000000000000000001& E116
    convertToDouble -84279630104E24
} 0xc7303b4e7c172b58
test expr-28.700 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +21206176437 E-27 x 1872f563ae0cc9_0000000000000000000000000000000000001& E-56
    convertToDouble +21206176437E-27
} 0x3c7872f563ae0cc9
test expr-28.701 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -66461566917 E-22 x -1d3ae83e4322b3_00000000000000000000000000000000000001& E-38
    convertToDouble -66461566917E-22
} 0xbd9d3ae83e4322b3
test expr-28.702 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +64808355539 E-16 x 1b2ebe83265fbf_00000000000000000000000000000000000001& E-18
    convertToDouble +64808355539E-16
} 0x3edb2ebe83265fbf
test expr-28.703 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -84932679673 E-19 x -123d39339f1bf6_00000000000000000000000000000000000001& E-27
    convertToDouble -84932679673E-19
} 0xbe423d39339f1bf6
test expr-28.704 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +65205430094 E26 x 139f3e5d7fd76a_1111111111111111111111111111111111110& E122
    convertToDouble +65205430094E26
} 0x47939f3e5d7fd76b
test expr-28.705 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -68384463429 E25 x -107684982f634e_1111111111111111111111111111111111111110& E119
    convertToDouble -68384463429E25
} 0xc7607684982f634f
test expr-28.706 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +32602715047 E26 x 139f3e5d7fd76a_1111111111111111111111111111111111110& E121
    convertToDouble +32602715047E26
} 0x47839f3e5d7fd76b
test expr-28.707 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -62662203426 E27 x -1792269424688d_111111111111111111111111111111111110& E125
    convertToDouble -62662203426E27
} 0xc7c792269424688e
test expr-28.708 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +58784444678 E-18 x 1f8f45c64b4682_111111111111111111111111111111111111110& E-25
    convertToDouble +58784444678E-18
} 0x3e6f8f45c64b4683
test expr-28.709 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -50980203373 E-21 x -1c06d366394440_11111111111111111111111111111111111111111110& E-35
    convertToDouble -50980203373E-21
} 0xbdcc06d366394441
test expr-28.710 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +29392222339 E-18 x 1f8f45c64b4682_111111111111111111111111111111111111110& E-26
    convertToDouble +29392222339E-18
} 0x3e5f8f45c64b4683
test expr-28.711 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -75529940323 E-27 x -15c5203c0aad52_1111111111111111111111111111111111111110& E-54
    convertToDouble -75529940323E-27
} 0xbc95c5203c0aad53
test expr-28.712 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -937495906299 E26 x -11a1e0ebb6af11_000000000000000000000000000000000000000001& E126
    convertToDouble -937495906299E26
} 0xc7d1a1e0ebb6af11
test expr-28.713 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +842642485799 E-20 x 121879decdd7cb_000000000000000000000000000000000000000001& E-27
    convertToDouble +842642485799E-20
} 0x3e421879decdd7cb
test expr-28.714 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -387824150699 E-23 x -110e8302245571_00000000000000000000000000000000000000001& E-38
    convertToDouble -387824150699E-23
} 0xbd910e8302245571
test expr-28.715 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +924948814726 E-27 x 10a992d1fc6ded_00000000000000000000000000000000000000001& E-50
    convertToDouble +924948814726E-27
} 0x3cd0a992d1fc6ded
test expr-28.716 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -775648301398 E-23 x -110e8302245571_00000000000000000000000000000000000000001& E-37
    convertToDouble -775648301398E-23
} 0xbda10e8302245571
test expr-28.717 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +547075707432 E25 x 107684982f634e_1111111111111111111111111111111111111110& E122
    convertToDouble +547075707432E25
} 0x47907684982f634f
test expr-28.718 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +683844634290 E24 x 107684982f634e_1111111111111111111111111111111111111110& E119
    convertToDouble +683844634290E24
} 0x47607684982f634f
test expr-28.719 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -136768926858 E25 x -107684982f634e_1111111111111111111111111111111111111110& E120
    convertToDouble -136768926858E25
} 0xc7707684982f634f
test expr-28.720 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +509802033730 E-22 x 1c06d366394440_11111111111111111111111111111111111111111110& E-35
    convertToDouble +509802033730E-22
} 0x3dcc06d366394441
test expr-28.721 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +101960406746 E-21 x 1c06d366394440_11111111111111111111111111111111111111111110& E-34
    convertToDouble +101960406746E-21
} 0x3ddc06d366394441
test expr-28.722 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -815683253968 E-21 x -1c06d366394440_11111111111111111111111111111111111111111110& E-31
    convertToDouble -815683253968E-21
} 0xbe0c06d366394441
test expr-28.723 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +7344124123524 E24 x 1619b519dd6833_00000000000000000000000000000000000000000001& E122
    convertToDouble +7344124123524E24
} 0x479619b519dd6833
test expr-28.724 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9180155154405 E23 x -1619b519dd6833_00000000000000000000000000000000000000000001& E119
    convertToDouble -9180155154405E23
} 0xc76619b519dd6833
test expr-28.725 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6479463327323 E27 x 130a9b3e9bd05e_00000000000000000000000000000000000000000001& E132
    convertToDouble +6479463327323E27
} 0x48330a9b3e9bd05e
test expr-28.726 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1836031030881 E24 x -1619b519dd6833_00000000000000000000000000000000000000000001& E120
    convertToDouble -1836031030881E24
} 0xc77619b519dd6833
test expr-28.727 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4337269293039 E-19 x 1d1b5f354c63d6_00000000000000000000000000000000000000000001& E-22
    convertToDouble +4337269293039E-19
} 0x3e9d1b5f354c63d6
test expr-28.728 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4599163554373 E-23 x -1948bf4d34088d_00000000000000000000000000000000000000000001& E-35
    convertToDouble -4599163554373E-23
} 0xbdc948bf4d34088d
test expr-28.729 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9198327108746 E-23 x 1948bf4d34088d_00000000000000000000000000000000000000000001& E-34
    convertToDouble +9198327108746E-23
} 0x3dd948bf4d34088d
test expr-28.730 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4812803938347 E27 x 1c4980a4ee94ce_111111111111111111111111111111111111111111110& E131
    convertToDouble +4812803938347E27
} 0x482c4980a4ee94cf
test expr-28.731 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8412030890011 E23 x -14405075e52db9_11111111111111111111111111111111111111111110& E119
    convertToDouble -8412030890011E23
} 0xc764405075e52dba
test expr-28.732 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9625607876694 E27 x 1c4980a4ee94ce_111111111111111111111111111111111111111111110& E132
    convertToDouble +9625607876694E27
} 0x483c4980a4ee94cf
test expr-28.733 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4739968828249 E24 x -1c87140cdf8a1d_1111111111111111111111111111111111111111110& E121
    convertToDouble -4739968828249E24
} 0xc78c87140cdf8a1e
test expr-28.734 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9697183891673 E-23 x 1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-34
    convertToDouble +9697183891673E-23
} 0x3ddaa7c959b6a667
test expr-28.735 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7368108517543 E-20 x -13c7535bbd85a1_1111111111111111111111111111111111111111111110& E-24
    convertToDouble -7368108517543E-20
} 0xbe73c7535bbd85a2
test expr-28.736 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +51461358161422 E25 x 18326f87d4cae0_0000000000000000000000000000000000000000000000001& E128
    convertToDouble +51461358161422E25
} 0x47f8326f87d4cae0
test expr-28.737 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -77192037242133 E26 x -16af488f577e32_0000000000000000000000000000000000000000000000001& E132
    convertToDouble -77192037242133E26
} 0xc836af488f577e32
test expr-28.738 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +77192037242133 E25 x 1225d3a5df9828_0000000000000000000000000000000000000000000000001& E129
    convertToDouble +77192037242133E25
} 0x480225d3a5df9828
test expr-28.739 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -51461358161422 E27 x -12e767221e3e7f_0000000000000000000000000000000000000000000000001& E135
    convertToDouble -51461358161422E27
} 0xc862e767221e3e7f
test expr-28.740 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +43999661561541 E-21 x 179f4476d372a3_0000000000000000000000000000000000000000000000001& E-25
    convertToDouble +43999661561541E-21
} 0x3e679f4476d372a3
test expr-28.741 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -87999323123082 E-21 x -179f4476d372a3_0000000000000000000000000000000000000000000000001& E-24
    convertToDouble -87999323123082E-21
} 0xbe779f4476d372a3
test expr-28.742 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +48374886826137 E-26 x 110538f23350d5_00000000000000000000000000000000000000000000001& E-41
    convertToDouble +48374886826137E-26
} 0x3d610538f23350d5
test expr-28.743 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -57684246567111 E-23 x -13d1f5c1b8a912_00000000000000000000000000000000000000000000001& E-31
    convertToDouble -57684246567111E-23
} 0xbe03d1f5c1b8a912
test expr-28.744 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +87192805957686 E23 x 1a3d16e55a9664_1111111111111111111111111111111111111111111110& E122
    convertToDouble +87192805957686E23
} 0x479a3d16e55a9665
test expr-28.745 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -75108713005913 E24 x -1c40b4baa79655_11111111111111111111111111111111111111111111110& E125
    convertToDouble -75108713005913E24
} 0xc7cc40b4baa79656
test expr-28.746 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +64233110587487 E27 x 179873e38669a6_1111111111111111111111111111111111111111111110& E135
    convertToDouble +64233110587487E27
} 0x48679873e38669a7
test expr-28.747 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -77577471133384 E-23 x -1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-31
    convertToDouble -77577471133384E-23
} 0xbe0aa7c959b6a667
test expr-28.748 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +48485919458365 E-24 x 1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-35
    convertToDouble +48485919458365E-24
} 0x3dcaa7c959b6a667
test expr-28.749 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -56908598265713 E-26 x -1405deef4bdef5_111111111111111111111111111111111111111111111110& E-41
    convertToDouble -56908598265713E-26
} 0xbd6405deef4bdef6
test expr-28.750 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +589722294620133 E23 x 162ed1b287caef_00000000000000000000000000000000000000000000000001& E125
    convertToDouble +589722294620133E23
} 0x47c62ed1b287caef
test expr-28.751 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +652835804449289 E-22 x 118640e490b087_0000000000000000000000000000000000000000000000000001& E-24
    convertToDouble +652835804449289E-22
} 0x3e718640e490b087
test expr-28.752 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -656415363936202 E-23 x -1c315cfe25d201_00000000000000000000000000000000000000000000000001& E-28
    convertToDouble -656415363936202E-23
} 0xbe3c315cfe25d201
test expr-28.753 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +579336749585745 E-25 x 1fd9709d9aeb19_00000000000000000000000000000000000000000000000001& E-35
    convertToDouble +579336749585745E-25
} 0x3dcfd9709d9aeb19
test expr-28.754 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -381292764980839 E-26 x -10c4f9921c3f8f_00000000000000000000000000000000000000000000000001& E-38
    convertToDouble -381292764980839E-26
} 0xbd90c4f9921c3f8f
test expr-28.755 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +965265859649698 E23 x 12279607edcb0c_1111111111111111111111111111111111111111111111110& E126
    convertToDouble +965265859649698E23
} 0x47d2279607edcb0d
test expr-28.756 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -848925235434882 E27 x -137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E139
    convertToDouble -848925235434882E27
} 0xc8a37d88ba4b43e4
test expr-28.757 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +536177612222491 E23 x 142b33dd3acafd_11111111111111111111111111111111111111111111111110& E125
    convertToDouble +536177612222491E23
} 0x47c42b33dd3acafe
test expr-28.758 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -424462617717441 E27 x -137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E138
    convertToDouble -424462617717441E27
} 0xc8937d88ba4b43e4
test expr-28.759 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +276009279888989 E-27 x 136c242313c288_111111111111111111111111111111111111111111111111110& E-42
    convertToDouble +276009279888989E-27
} 0x3d536c242313c289
test expr-28.760 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -608927158043691 E-26 x -1ac7e909c22f09_11111111111111111111111111111111111111111111111110& E-38
    convertToDouble -608927158043691E-26
} 0xbd9ac7e909c22f0a
test expr-28.761 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +552018559777978 E-27 x 136c242313c288_111111111111111111111111111111111111111111111111110& E-41
    convertToDouble +552018559777978E-27
} 0x3d636c242313c289
test expr-28.762 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -425678377667758 E-22 x -16da7aa49bdcd5_1111111111111111111111111111111111111111111111110& E-25
    convertToDouble -425678377667758E-22
} 0xbe66da7aa49bdcd6
test expr-28.763 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8013702726927119 E26 x 126607f8f1b29e_00000000000000000000000000000000000000000000000000001& E139
    convertToDouble +8013702726927119E26
} 0x48a26607f8f1b29e
test expr-28.764 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8862627962362001 E27 x 196f3b0e7787c2_00000000000000000000000000000000000000000000000000001& E142
    convertToDouble +8862627962362001E27
} 0x48d96f3b0e7787c2
test expr-28.765 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -5068007907757162 E26 x -17456a27848397_00000000000000000000000000000000000000000000000000001& E138
    convertToDouble -5068007907757162E26
} 0xc897456a27848397
test expr-28.766 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7379714799828406 E-23 x -13cf4d2839e036_00000000000000000000000000000000000000000000000000001& E-24
    convertToDouble -7379714799828406E-23
} 0xbe73cf4d2839e036
test expr-28.767 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4114538064016107 E-27 x 12188eda98010c_0000000000000000000000000000000000000000000000000001& E-38
    convertToDouble +4114538064016107E-27
} 0x3d92188eda98010c
test expr-28.768 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -3689857399914203 E-23 x -13cf4d2839e036_00000000000000000000000000000000000000000000000000001& E-25
    convertToDouble -3689857399914203E-23
} 0xbe63cf4d2839e036
test expr-28.769 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5575954851815478 E23 x 1a37cfbf2ffdb5_1111111111111111111111111111111111111111111111111110& E128
    convertToDouble +5575954851815478E23
} 0x47fa37cfbf2ffdb6
test expr-28.770 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +3395700941739528 E27 x 137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E141
    convertToDouble +3395700941739528E27
} 0x48c37d88ba4b43e4
test expr-28.771 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4115535777581961 E-23 x 1618596be30fe4_111111111111111111111111111111111111111111111111111110& E-25
    convertToDouble +4115535777581961E-23
} 0x3e6618596be30fe5
test expr-28.772 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8231071555163922 E-23 x -1618596be30fe4_111111111111111111111111111111111111111111111111111110& E-24
    convertToDouble -8231071555163922E-23
} 0xbe7618596be30fe5
test expr-28.773 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6550246696190871 E-26 x 1201538b0f8c69_111111111111111111111111111111111111111111111111111110& E-34
    convertToDouble +6550246696190871E-26
} 0x3dd201538b0f8c6a
test expr-28.774 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -68083046403986701 E27 x -186c70ba8ba28d_000000000000000000000000000000000000000000000000000000001& E145
    convertToDouble -68083046403986701E27
} 0xc9086c70ba8ba28d
test expr-28.775 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +43566388595783643 E27 x 1f41e1bf48b03f_111111111111111111111111111111111111111111111111111111110& E144
    convertToDouble +43566388595783643E27
} 0x48ff41e1bf48b040
test expr-28.776 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -87132777191567286 E27 x -1f41e1bf48b03f_111111111111111111111111111111111111111111111111111111110& E145
    convertToDouble -87132777191567286E27
} 0xc90f41e1bf48b040
test expr-28.777 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +59644881059342141 E25 x 1b6338d9d8ae38_11111111111111111111111111111111111111111111111111111110& E138
    convertToDouble +59644881059342141E25
} 0x489b6338d9d8ae39
test expr-28.778 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -83852770718576667 E23 x -18a4619ed6f442_111111111111111111111111111111111111111111111111111111110& E132
    convertToDouble -83852770718576667E23
} 0xc838a4619ed6f443
test expr-28.779 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +99482967418206961 E-25 x 155d224bfed7ac_11111111111111111111111111111111111111111111111111111111110& E-27
    convertToDouble +99482967418206961E-25
} 0x3e455d224bfed7ad
test expr-28.780 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -99482967418206961 E-26 x -11174ea3324623_11111111111111111111111111111111111111111111111111111111110& E-30
    convertToDouble -99482967418206961E-26
} 0xbe11174ea3324624
test expr-28.781 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +87446669969994614 E-27 x 1809832942376d_11111111111111111111111111111111111111111111111111111110& E-34
    convertToDouble +87446669969994614E-27
} 0x3dd809832942376e
test expr-28.782 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -43723334984997307 E-27 x -1809832942376d_11111111111111111111111111111111111111111111111111111110& E-35
    convertToDouble -43723334984997307E-27
} 0xbdc809832942376e
test expr-28.783 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5 E24 x 108b2a2c280290_1001& E82
    convertToDouble +5E24
} 0x45108b2a2c280291
test expr-28.784 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8 E25 x -108b2a2c280290_1001& E86
    convertToDouble -8E25
} 0xc5508b2a2c280291
test expr-28.785 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +1 E25 x 108b2a2c280290_1001& E83
    convertToDouble +1E25
} 0x45208b2a2c280291
test expr-28.786 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4 E25 x -108b2a2c280290_1001& E85
    convertToDouble -4E25
} 0xc5408b2a2c280291
test expr-28.787 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +2 E-5 x 14f8b588e368f0_100001& E-16
    convertToDouble +2E-5
} 0x3ef4f8b588e368f1
test expr-28.788 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -5 E-6 x -14f8b588e368f0_100001& E-18
    convertToDouble -5E-6
} 0xbed4f8b588e368f1
test expr-28.789 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4 E-5 x 14f8b588e368f0_100001& E-15
    convertToDouble +4E-5
} 0x3f04f8b588e368f1
test expr-28.790 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -3 E-20 x -11b578c96db19a_100001& E-65
    convertToDouble -3E-20
} 0xbbe1b578c96db19b
test expr-28.791 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +3 E27 x 1363156bbee301_0110& E91
    convertToDouble +3E27
} 0x45a363156bbee301
test expr-28.792 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9 E26 x -1743b34e18439b_010& E89
    convertToDouble -9E26
} 0xc58743b34e18439b
test expr-28.793 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +7 E25 x 1cf389cd46047d_00& E85
    convertToDouble +7E25
} 0x454cf389cd46047d
test expr-28.794 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -6 E27 x -1363156bbee301_0110& E92
    convertToDouble -6E27
} 0xc5b363156bbee301
test expr-28.795 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +2 E-21 x 12e3b40a0e9b4f_0111110& E-69
    convertToDouble +2E-21
} 0x3ba2e3b40a0e9b4f
test expr-28.796 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -5 E-22 x -12e3b40a0e9b4f_0111110& E-71
    convertToDouble -5E-22
} 0xbb82e3b40a0e9b4f
test expr-28.797 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4 E-21 x -12e3b40a0e9b4f_0111110& E-68
    convertToDouble -4E-21
} 0xbbb2e3b40a0e9b4f
test expr-28.798 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +87 E25 x 167d2d5406637c_10001& E89
    convertToDouble +87E25
} 0x45867d2d5406637d
test expr-28.799 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -97 E24 x -140f232256e982_1000000001& E86
    convertToDouble -97E24
} 0xc5540f232256e983
test expr-28.800 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +82 E-24 x 18c87154dff6c6_1000000001& E-74
    convertToDouble +82E-24
} 0x3b58c87154dff6c7
test expr-28.801 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -41 E-24 x -18c87154dff6c6_1000000001& E-75
    convertToDouble -41E-24
} 0xbb48c87154dff6c7
test expr-28.802 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +76 E-23 x 1cb644dc1633c0_10000001& E-71
    convertToDouble +76E-23
} 0x3b8cb644dc1633c1
test expr-28.803 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +83 E25 x 15747ab143e353_011111111110& E89
    convertToDouble +83E25
} 0x4585747ab143e353
test expr-28.804 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -50 E27 x -1431e0fae6d721_0111110& E95
    convertToDouble -50E27
} 0xc5e431e0fae6d721
test expr-28.805 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +25 E27 x 1431e0fae6d721_0111110& E94
    convertToDouble +25E27
} 0x45d431e0fae6d721
test expr-28.806 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -99 E27 x -13fe2e171cda19_011110& E96
    convertToDouble -99E27
} 0xc5f3fe2e171cda19
test expr-28.807 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +97 E-10 x 14d4a1a3157dc7_011111110& E-27
    convertToDouble +97E-10
} 0x3e44d4a1a3157dc7
test expr-28.808 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -57 E-20 x -15077f6f3242e7_011111110& E-61
    convertToDouble -57E-20
} 0xbc25077f6f3242e7
test expr-28.809 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +997 E23 x 149e12f51c1a3c_10000000001& E86
    convertToDouble +997E23
} 0x45549e12f51c1a3d
test expr-28.810 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +776 E24 x 140f232256e982_1000000001& E89
    convertToDouble +776E24
} 0x45840f232256e983
test expr-28.811 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -388 E24 x -140f232256e982_1000000001& E88
    convertToDouble -388E24
} 0xc5740f232256e983
test expr-28.812 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +521 E-10 x 1bf891c92c0890_100000000001& E-25
    convertToDouble +521E-10
} 0x3e6bf891c92c0891
test expr-28.813 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -506 E-26 x -1877fa0260beb2_10000000001& E-78
    convertToDouble -506E-26
} 0xbb1877fa0260beb3
test expr-28.814 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +739 E-10 x 13d65e8c76722c_10000000001& E-24
    convertToDouble +739E-10
} 0x3e73d65e8c76722d
test expr-28.815 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -867 E-7 x -16ba56a8834168_100000000001& E-14
    convertToDouble -867E-7
} 0xbf16ba56a8834169
test expr-28.816 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -415 E24 x -15747ab143e353_011111111110& E88
    convertToDouble -415E24
} 0xc575747ab143e353
test expr-28.817 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +332 E25 x 15747ab143e353_011111111110& E91
    convertToDouble +332E25
} 0x45a5747ab143e353
test expr-28.818 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -664 E25 x -15747ab143e353_011111111110& E92
    convertToDouble -664E25
} 0xc5b5747ab143e353
test expr-28.819 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +291 E-13 x 1ffeebfc8b81b5_01111111111110& E-36
    convertToDouble +291E-13
} 0x3dbffeebfc8b81b5
test expr-28.820 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -982 E-8 x -14981285e98e79_0111111111110& E-17
    convertToDouble -982E-8
} 0xbee4981285e98e79
test expr-28.821 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +582 E-13 x 1ffeebfc8b81b5_01111111111110& E-35
    convertToDouble +582E-13
} 0x3dcffeebfc8b81b5
test expr-28.822 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -491 E-8 x -14981285e98e79_0111111111110& E-18
    convertToDouble -491E-8
} 0xbed4981285e98e79
test expr-28.823 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4574 E26 x 1717c1a612f954_100000000001& E98
    convertToDouble +4574E26
} 0x461717c1a612f955
test expr-28.824 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8609 E26 x -15bb6f942546ee_1000000000001& E99
    convertToDouble -8609E26
} 0xc625bb6f942546ef
test expr-28.825 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +2287 E26 x 1717c1a612f954_100000000001& E97
    convertToDouble +2287E26
} 0x460717c1a612f955
test expr-28.826 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4818 E24 x -1f22b65eb419a0_10000000001& E91
    convertToDouble -4818E24
} 0xc5af22b65eb419a1
test expr-28.827 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6529 E-8 x 111d89a8b5c142_100000000000001& E-14
    convertToDouble +6529E-8
} 0x3f111d89a8b5c143
test expr-28.828 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8151 E-21 x -12cb804b61b898_1000000000000001& E-57
    convertToDouble -8151E-21
} 0xbc62cb804b61b899
test expr-28.829 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +1557 E-12 x 1abfc227ab1026_10000000000001& E-30
    convertToDouble +1557E-12
} 0x3e1abfc227ab1027
test expr-28.830 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2573 E-18 x -172cef1ebbca44_10000000000001& E-49
    convertToDouble -2573E-18
} 0xbce72cef1ebbca45
test expr-28.831 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4929 E-16 x 1157a604ed019f_0111111111111110& E-41
    convertToDouble +4929E-16
} 0x3d6157a604ed019f
test expr-28.832 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -3053 E-22 x -1686f435fe6b6b_011111111111110& E-62
    convertToDouble -3053E-22
} 0xbc1686f435fe6b6b
test expr-28.833 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9858 E-16 x 1157a604ed019f_0111111111111110& E-40
    convertToDouble +9858E-16
} 0x3d7157a604ed019f
test expr-28.834 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7767 E-11 x -14d971170ed055_011111111111110& E-24
    convertToDouble -7767E-11
} 0xbe74d971170ed055
test expr-28.835 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +54339 E26 x 1125782ec15cbe_100000000000000001& E102
    convertToDouble +54339E26
} 0x465125782ec15cbf
test expr-28.836 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -62409 E25 x -1f822c980d4bb2_100000000000000001& E98
    convertToDouble -62409E25
} 0xc61f822c980d4bb3
test expr-28.837 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +32819 E27 x 19e3be885fc16a_100000000000001& E104
    convertToDouble +32819E27
} 0x4679e3be885fc16b
test expr-28.838 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -89849 E27 x -11b8371b6dda04_1000000000000001& E106
    convertToDouble -89849E27
} 0xc691b8371b6dda05
test expr-28.839 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +63876 E-20 x 1703856844bdbe_1000000000000000000001& E-51
    convertToDouble +63876E-20
} 0x3cc703856844bdbf
test expr-28.840 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -15969 E-20 x -1703856844bdbe_1000000000000000000001& E-53
    convertToDouble -15969E-20
} 0xbca703856844bdbf
test expr-28.841 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +31938 E-20 x 1703856844bdbe_1000000000000000000001& E-52
    convertToDouble +31938E-20
} 0x3cb703856844bdbf
test expr-28.842 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -79845 E-21 x -1703856844bdbe_1000000000000000000001& E-54
    convertToDouble -79845E-21
} 0xbc9703856844bdbf
test expr-28.843 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +89306 E27 x 119cccff237e17_011111111111110& E106
    convertToDouble +89306E27
} 0x46919cccff237e17
test expr-28.844 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -25487 E24 x -1496968ba07117_01111111111110& E94
    convertToDouble -25487E24
} 0xc5d496968ba07117
test expr-28.845 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +79889 E24 x 10222a1c7e27d3_01111111111110& E96
    convertToDouble +79889E24
} 0x45f0222a1c7e27d3
test expr-28.846 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -97379 E26 x -1eba3685911519_011111111111111110& E102
    convertToDouble -97379E26
} 0xc65eba3685911519
test expr-28.847 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +81002 E-8 x 1a8af0b45d9531_0111111111111111110& E-11
    convertToDouble +81002E-8
} 0x3f4a8af0b45d9531
test expr-28.848 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -43149 E-25 x -146064de6ecbed_011111111111111110& E-68
    convertToDouble -43149E-25
} 0xbbb46064de6ecbed
test expr-28.849 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +40501 E-8 x 1a8af0b45d9531_0111111111111111110& E-12
    convertToDouble +40501E-8
} 0x3f3a8af0b45d9531
test expr-28.850 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -60318 E-10 x -194c988f217e51_011111111111111110& E-18
    convertToDouble -60318E-10
} 0xbed94c988f217e51
test expr-28.851 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -648299 E27 x -1ff6af0bf00100_10000000000000000001& E108
    convertToDouble -648299E27
} 0xc6bff6af0bf00101
test expr-28.852 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +780649 E24 x 13b4d36f9edd18_10000000000000000001& E99
    convertToDouble +780649E24
} 0x4623b4d36f9edd19
test expr-28.853 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +720919 E-14 x 1ef696965cbf04_10000000000000000000000001& E-28
    convertToDouble +720919E-14
} 0x3e3ef696965cbf05
test expr-28.854 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -629703 E-11 x -1a69626d2629d0_1000000000000000000000001& E-18
    convertToDouble -629703E-11
} 0xbeda69626d2629d1
test expr-28.855 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +557913 E24 x 1c2adb44b394bf_01111111111111111110& E98
    convertToDouble +557913E24
} 0x461c2adb44b394bf
test expr-28.856 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -847899 E23 x -111f88fb93dce9_011111111111111111110& E96
    convertToDouble -847899E23
} 0xc5f11f88fb93dce9
test expr-28.857 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +565445 E27 x 1be0eb55770d4d_0111111111111111110& E108
    convertToDouble +565445E27
} 0x46bbe0eb55770d4d
test expr-28.858 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -736531 E24 x -1297b853d64ac7_01111111111111111110& E99
    convertToDouble -736531E24
} 0xc62297b853d64ac7
test expr-28.859 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +680013 E-19 x 13240293e95c3b_01111111111111111111110& E-44
    convertToDouble +680013E-19
} 0x3d33240293e95c3b
test expr-28.860 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -529981 E-10 x -1bc948d999ac11_011111111111111111110& E-15
    convertToDouble -529981E-10
} 0xbf0bc948d999ac11
test expr-28.861 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +382923 E-23 x 11a8c1c10a1fc5_011111111111111111110& E-58
    convertToDouble +382923E-23
} 0x3c51a8c1c10a1fc5
test expr-28.862 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -633614 E-18 x -164b166995a9b7_011111111111111111110& E-41
    convertToDouble -633614E-18
} 0xbd664b166995a9b7
test expr-28.863 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +2165479 E27 x 1ab10c016c34b8_100000000000000000000001& E110
    convertToDouble +2165479E27
} 0x46dab10c016c34b9
test expr-28.864 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8661916 E27 x -1ab10c016c34b8_100000000000000000000001& E112
    convertToDouble -8661916E27
} 0xc6fab10c016c34b9
test expr-28.865 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4330958 E27 x 1ab10c016c34b8_100000000000000000000001& E111
    convertToDouble +4330958E27
} 0x46eab10c016c34b9
test expr-28.866 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9391993 E22 x -12f78bec748c98_1000000000000000000001& E96
    convertToDouble -9391993E22
} 0xc5f2f78bec748c99
test expr-28.867 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -5767352 E-14 x -1ef696965cbf04_10000000000000000000000001& E-25
    convertToDouble -5767352E-14
} 0xbe6ef696965cbf05
test expr-28.868 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +7209190 E-15 x 1ef696965cbf04_10000000000000000000000001& E-28
    convertToDouble +7209190E-15
} 0x3e3ef696965cbf05
test expr-28.869 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1441838 E-14 x -1ef696965cbf04_10000000000000000000000001& E-27
    convertToDouble -1441838E-14
} 0xbe4ef696965cbf05
test expr-28.870 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8478990 E22 x 111f88fb93dce9_011111111111111111110& E96
    convertToDouble +8478990E22
} 0x45f11f88fb93dce9
test expr-28.871 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +1473062 E24 x 1297b853d64ac7_01111111111111111110& E100
    convertToDouble +1473062E24
} 0x463297b853d64ac7
test expr-28.872 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8366487 E-14 x 167567f55b22e1_0111111111111111111111110& E-24
    convertToDouble +8366487E-14
} 0x3e767567f55b22e1
test expr-28.873 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8399969 E-25 x -1efd8be1b15b43_011111111111111111111110& E-61
    convertToDouble -8399969E-25
} 0xbc2efd8be1b15b43
test expr-28.874 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9366737 E-12 x 13a4ba87ddc13f_011111111111111111111110& E-17
    convertToDouble +9366737E-12
} 0x3ee3a4ba87ddc13f
test expr-28.875 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9406141 E-13 x -1f8fd047c84d49_0111111111111111111111110& E-21
    convertToDouble -9406141E-13
} 0xbeaf8fd047c84d49
test expr-28.876 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +65970979 E24 x 1a055dd68f3e3c_1000000000000000000000000001& E105
    convertToDouble +65970979E24
} 0x468a055dd68f3e3d
test expr-28.877 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -65060671 E26 x -140c61c9916cf4_100000000000000000000000001& E112
    convertToDouble -65060671E26
} 0xc6f40c61c9916cf5
test expr-28.878 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +54923002 E27 x 1527d37d8b38ea_10000000000000000000000001& E115
    convertToDouble +54923002E27
} 0x472527d37d8b38eb
test expr-28.879 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -63846927 E25 x -1f7a9d79dad9b4_10000000000000000000000001& E108
    convertToDouble -63846927E25
} 0xc6bf7a9d79dad9b5
test expr-28.880 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +99585767 E-21 x 1c07e928406d2e_100000000000000000000000001& E-44
    convertToDouble +99585767E-21
} 0x3d3c07e928406d2f
test expr-28.881 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +67488159 E25 x 10a31a03822bc9_011111111111111111111111111110& E109
    convertToDouble +67488159E25
} 0x46c0a31a03822bc9
test expr-28.882 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -69005339 E24 x -1b37c234aae77b_011111111111111111111111110& E105
    convertToDouble -69005339E24
} 0xc68b37c234aae77b
test expr-28.883 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +81956786 E27 x 1f919023fcb6fd_0111111111111111111111111110& E115
    convertToDouble +81956786E27
} 0x472f919023fcb6fd
test expr-28.884 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -40978393 E27 x -1f919023fcb6fd_0111111111111111111111111110& E114
    convertToDouble -40978393E27
} 0xc71f919023fcb6fd
test expr-28.885 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +77505754 E-12 x 145152b6f85e09_0111111111111111111111111110& E-14
    convertToDouble +77505754E-12
} 0x3f145152b6f85e09
test expr-28.886 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -38752877 E-12 x -145152b6f85e09_0111111111111111111111111110& E-15
    convertToDouble -38752877E-12
} 0xbf045152b6f85e09
test expr-28.887 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +82772981 E-15 x 16381dae63505f_0111111111111111111111111111110& E-24
    convertToDouble +82772981E-15
} 0x3e76381dae63505f
test expr-28.888 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -95593517 E-25 x -160ad862d8537d_0111111111111111111111111110& E-57
    convertToDouble -95593517E-25
} 0xbc660ad862d8537d
test expr-28.889 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +200036989 E25 x 18a80dedbc575e_10000000000000000000000000001& E110
    convertToDouble +200036989E25
} 0x46d8a80dedbc575f
test expr-28.890 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -772686455 E27 x -129a0c45ceca7a_1000000000000000000000000000001& E119
    convertToDouble -772686455E27
} 0xc7629a0c45ceca7b
test expr-28.891 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +859139907 E23 x 10f18c4dd0ffe2_10000000000000000000000000001& E106
    convertToDouble +859139907E23
} 0x4690f18c4dd0ffe3
test expr-28.892 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -400073978 E25 x -18a80dedbc575e_10000000000000000000000000001& E111
    convertToDouble -400073978E25
} 0xc6e8a80dedbc575f
test expr-28.893 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +569014327 E-14 x 17ddbeac19d3b2_100000000000000000000000000001& E-18
    convertToDouble +569014327E-14
} 0x3ed7ddbeac19d3b3
test expr-28.894 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -794263862 E-15 x -1aa6acb41dfc52_1000000000000000000000000000001& E-21
    convertToDouble -794263862E-15
} 0xbeaaa6acb41dfc53
test expr-28.895 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +397131931 E-15 x 1aa6acb41dfc52_1000000000000000000000000000001& E-22
    convertToDouble +397131931E-15
} 0x3e9aa6acb41dfc53
test expr-28.896 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -380398957 E-16 x -146c29d8331024_100000000000000000000000000001& E-25
    convertToDouble -380398957E-16
} 0xbe646c29d8331025
test expr-28.897 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +567366773 E27 x 1b5155dd5417f9_0111111111111111111111111111110& E118
    convertToDouble +567366773E27
} 0x475b5155dd5417f9
test expr-28.898 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -337440795 E24 x -10a31a03822bc9_011111111111111111111111111110& E108
    convertToDouble -337440795E24
} 0xc6b0a31a03822bc9
test expr-28.899 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +134976318 E25 x 10a31a03822bc9_011111111111111111111111111110& E110
    convertToDouble +134976318E25
} 0x46d0a31a03822bc9
test expr-28.900 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -269952636 E25 x -10a31a03822bc9_011111111111111111111111111110& E111
    convertToDouble -269952636E25
} 0xc6e0a31a03822bc9
test expr-28.901 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +932080597 E-20 x 147f25b4941e5b_0111111111111111111111111111110& E-37
    convertToDouble +932080597E-20
} 0x3da47f25b4941e5b
test expr-28.902 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -331091924 E-15 x -16381dae63505f_0111111111111111111111111111110& E-22
    convertToDouble -331091924E-15
} 0xbe96381dae63505f
test expr-28.903 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -413864905 E-16 x -16381dae63505f_0111111111111111111111111111110& E-25
    convertToDouble -413864905E-16
} 0xbe66381dae63505f
test expr-28.904 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8539246247 E26 x 148eb7813eaeba_10000000000000000000000000000001& E119
    convertToDouble +8539246247E26
} 0x47648eb7813eaebb
test expr-28.905 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -5859139791 E26 x -1c35f28719d478_10000000000000000000000000000001& E118
    convertToDouble -5859139791E26
} 0xc75c35f28719d479
test expr-28.906 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6105010149 E24 x 12d000fb2b138a_1000000000000000000000000000000001& E112
    convertToDouble +6105010149E24
} 0x46f2d000fb2b138b
test expr-28.907 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -3090745820 E27 x -129a0c45ceca7a_1000000000000000000000000000001& E121
    convertToDouble -3090745820E27
} 0xc7829a0c45ceca7b
test expr-28.908 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +3470877773 E-20 x 1314d381f2c31e_1000000000000000000000000000000001& E-35
    convertToDouble +3470877773E-20
} 0x3dc314d381f2c31f
test expr-28.909 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -6136309089 E-27 x -1c4c799fab4328_1000000000000000000000000000000001& E-58
    convertToDouble -6136309089E-27
} 0xbc5c4c799fab4329
test expr-28.910 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8917758713 E-19 x 1ea424bda7d7f4_100000000000000000000000000000001& E-31
    convertToDouble +8917758713E-19
} 0x3e0ea424bda7d7f5
test expr-28.911 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -6941755546 E-20 x -1314d381f2c31e_1000000000000000000000000000000001& E-34
    convertToDouble -6941755546E-20
} 0xbdd314d381f2c31f
test expr-28.912 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9194900535 E25 x 11b56f9c090dfb_011111111111111111111111111111111110& E116
    convertToDouble +9194900535E25
} 0x4731b56f9c090dfb
test expr-28.913 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1838980107 E26 x -11b56f9c090dfb_011111111111111111111111111111111110& E117
    convertToDouble -1838980107E26
} 0xc741b56f9c090dfb
test expr-28.914 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +7355920428 E26 x 11b56f9c090dfb_011111111111111111111111111111111110& E119
    convertToDouble +7355920428E26
} 0x4761b56f9c090dfb
test expr-28.915 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -3677960214 E26 x -11b56f9c090dfb_011111111111111111111111111111111110& E118
    convertToDouble -3677960214E26
} 0xc751b56f9c090dfb
test expr-28.916 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8473634343 E-17 x 16bf0984b232b7_0111111111111111111111111111111110& E-24
    convertToDouble +8473634343E-17
} 0x3e76bf0984b232b7
test expr-28.917 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8870766274 E-16 x -1dc3ee22137269_0111111111111111111111111111111110& E-21
    convertToDouble -8870766274E-16
} 0xbeadc3ee22137269
test expr-28.918 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +4435383137 E-16 x 1dc3ee22137269_0111111111111111111111111111111110& E-22
    convertToDouble +4435383137E-16
} 0x3e9dc3ee22137269
test expr-28.919 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9598990129 E-15 x -14216b286031e7_01111111111111111111111111111111110& E-17
    convertToDouble -9598990129E-15
} 0xbee4216b286031e7
test expr-28.920 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +71563496764 E26 x 15890d1ef6a0da_10000000000000000000000000000000000001& E122
    convertToDouble +71563496764E26
} 0x4795890d1ef6a0db
test expr-28.921 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -89454370955 E25 x -15890d1ef6a0da_10000000000000000000000000000000000001& E119
    convertToDouble -89454370955E25
} 0xc765890d1ef6a0db
test expr-28.922 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +17890874191 E26 x 15890d1ef6a0da_10000000000000000000000000000000000001& E120
    convertToDouble +17890874191E26
} 0x4775890d1ef6a0db
test expr-28.923 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -35781748382 E26 x -15890d1ef6a0da_10000000000000000000000000000000000001& E121
    convertToDouble -35781748382E26
} 0xc785890d1ef6a0db
test expr-28.924 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +57973447842 E-19 x 18e63f7cf5313c_1000000000000000000000000000000000000001& E-28
    convertToDouble +57973447842E-19
} 0x3e38e63f7cf5313d
test expr-28.925 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -28986723921 E-19 x -18e63f7cf5313c_1000000000000000000000000000000000000001& E-29
    convertToDouble -28986723921E-19
} 0xbe28e63f7cf5313d
test expr-28.926 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +76822711313 E-19 x 107f5f8b3bf818_100000000000000000000000000000000001& E-27
    convertToDouble +76822711313E-19
} 0x3e407f5f8b3bf819
test expr-28.927 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -97699466874 E-20 x -10c8de34de806e_10000000000000000000000000000000001& E-30
    convertToDouble -97699466874E-20
} 0xbe10c8de34de806f
test expr-28.928 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +67748656762 E27 x 197bf5559b31fd_01111111111111111111111111111111111110& E125
    convertToDouble +67748656762E27
} 0x47c97bf5559b31fd
test expr-28.929 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -19394840991 E24 x -1de1ea791a6e7d_0111111111111111111111111111111111110& E113
    convertToDouble -19394840991E24
} 0xc70de1ea791a6e7d
test expr-28.930 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +38789681982 E24 x 1de1ea791a6e7d_0111111111111111111111111111111111110& E114
    convertToDouble +38789681982E24
} 0x471de1ea791a6e7d
test expr-28.931 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -33874328381 E27 x -197bf5559b31fd_01111111111111111111111111111111111110& E124
    convertToDouble -33874328381E27
} 0xc7b97bf5559b31fd
test expr-28.932 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +54323763886 E-27 x 1f50c5c63e5441_0111111111111111111111111111111111110& E-55
    convertToDouble +54323763886E-27
} 0x3c8f50c5c63e5441
test expr-28.933 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -58987193887 E-20 x -14449185a4c829_011111111111111111111111111111111111110& E-31
    convertToDouble -58987193887E-20
} 0xbe04449185a4c829
test expr-28.934 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +27161881943 E-27 x 1f50c5c63e5441_0111111111111111111111111111111111110& E-56
    convertToDouble +27161881943E-27
} 0x3c7f50c5c63e5441
test expr-28.935 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -93042648033 E-19 x -13fb12dc023fd3_0111111111111111111111111111111111110& E-27
    convertToDouble -93042648033E-19
} 0xbe43fb12dc023fd3
test expr-28.936 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +520831059055 E27 x 187d469cb69dd0_10000000000000000000000000000000000000001& E128
    convertToDouble +520831059055E27
} 0x47f87d469cb69dd1
test expr-28.937 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -768124264394 E25 x -171d6a019edae8_1000000000000000000000000000000000000001& E122
    convertToDouble -768124264394E25
} 0xc7971d6a019edae9
test expr-28.938 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +384062132197 E25 x 171d6a019edae8_1000000000000000000000000000000000000001& E121
    convertToDouble +384062132197E25
} 0x47871d6a019edae9
test expr-28.939 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +765337749889 E-25 x 158ad6f5d0a854_100000000000000000000000000000000000000001& E-44
    convertToDouble +765337749889E-25
} 0x3d358ad6f5d0a855
test expr-28.940 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +794368912771 E25 x 17e79872f2f7ef_01111111111111111111111111111111111111110& E122
    convertToDouble +794368912771E25
} 0x4797e79872f2f7ef
test expr-28.941 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -994162090146 E23 x -132598f85e658b_011111111111111111111111111111111111110& E116
    convertToDouble -994162090146E23
} 0xc7332598f85e658b
test expr-28.942 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +781652779431 E26 x 1d670adf52038f_01111111111111111111111111111111111110& E125
    convertToDouble +781652779431E26
} 0x47cd670adf52038f
test expr-28.943 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +910077190046 E-26 x 147e3ce1871d79_01111111111111111111111111111111111111110& E-47
    convertToDouble +910077190046E-26
} 0x3d047e3ce1871d79
test expr-28.944 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -455038595023 E-26 x -147e3ce1871d79_01111111111111111111111111111111111111110& E-48
    convertToDouble -455038595023E-26
} 0xbcf47e3ce1871d79
test expr-28.945 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +471897551096 E-20 x 14449185a4c829_011111111111111111111111111111111111110& E-28
    convertToDouble +471897551096E-20
} 0x3e34449185a4c829
test expr-28.946 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -906698409911 E-21 x -1f27674f7d5745_0111111111111111111111111111111111111110& E-31
    convertToDouble -906698409911E-21
} 0xbe0f27674f7d5745
test expr-28.947 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8854128003935 E25 x 10a71b8948faac_100000000000000000000000000000000000000001& E126
    convertToDouble +8854128003935E25
} 0x47d0a71b8948faad
test expr-28.948 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8146122716299 E27 x -17f0762ac05654_1000000000000000000000000000000000000000001& E132
    convertToDouble -8146122716299E27
} 0xc837f0762ac05655
test expr-28.949 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +7083302403148 E26 x 10a71b8948faac_100000000000000000000000000000000000000001& E129
    convertToDouble +7083302403148E26
} 0x4800a71b8948faad
test expr-28.950 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -3541651201574 E26 x -10a71b8948faac_100000000000000000000000000000000000000001& E128
    convertToDouble -3541651201574E26
} 0xc7f0a71b8948faad
test expr-28.951 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8394920649291 E-25 x 1d8978e8c1cc78_100000000000000000000000000000000000000000001& E-41
    convertToDouble +8394920649291E-25
} 0x3d6d8978e8c1cc79
test expr-28.952 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -7657975756753 E-22 x -1a5006d695fef0_1000000000000000000000000000000000000000000001& E-31
    convertToDouble -7657975756753E-22
} 0xbe0a5006d695fef1
test expr-28.953 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5473834002228 E-20 x 1d632e1f745624_100000000000000000000000000000000000000000001& E-25
    convertToDouble +5473834002228E-20
} 0x3e6d632e1f745625
test expr-28.954 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -6842292502785 E-21 x -1d632e1f745624_100000000000000000000000000000000000000000001& E-28
    convertToDouble -6842292502785E-21
} 0xbe3d632e1f745625
test expr-28.955 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2109568884597 E25 x -1fbdc386609b13_011111111111111111111111111111111111111110& E123
    convertToDouble -2109568884597E25
} 0xc7afbdc386609b13
test expr-28.956 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +8438275538388 E25 x 1fbdc386609b13_011111111111111111111111111111111111111110& E125
    convertToDouble +8438275538388E25
} 0x47cfbdc386609b13
test expr-28.957 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -4219137769194 E25 x -1fbdc386609b13_011111111111111111111111111111111111111110& E124
    convertToDouble -4219137769194E25
} 0xc7bfbdc386609b13
test expr-28.958 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +3200141789841 E-25 x 1684dcea3829f7_0111111111111111111111111111111111111111110& E-42
    convertToDouble +3200141789841E-25
} 0x3d5684dcea3829f7
test expr-28.959 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8655689322607 E-22 x -1dbd9ff5dc8991_011111111111111111111111111111111111111110& E-31
    convertToDouble -8655689322607E-22
} 0xbe0dbd9ff5dc8991
test expr-28.960 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6400283579682 E-25 x 1684dcea3829f7_0111111111111111111111111111111111111111110& E-41
    convertToDouble +6400283579682E-25
} 0x3d6684dcea3829f7
test expr-28.961 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -8837719634493 E-21 x -12fa9676d2585b_011111111111111111111111111111111111111110& E-27
    convertToDouble -8837719634493E-21
} 0xbe42fa9676d2585b
test expr-28.962 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +19428217075297 E24 x 1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E123
    convertToDouble +19428217075297E24
} 0x47ad3b7a1d154abb
test expr-28.963 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -38856434150594 E24 x -1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E124
    convertToDouble -38856434150594E24
} 0xc7bd3b7a1d154abb
test expr-28.964 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +77712868301188 E24 x 1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E125
    convertToDouble +77712868301188E24
} 0x47cd3b7a1d154abb
test expr-28.965 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -77192037242133 E27 x -1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E135
    convertToDouble -77192037242133E27
} 0xc86c5b1ab32d5dbf
test expr-28.966 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +76579757567530 E-23 x 1a5006d695fef0_1000000000000000000000000000000000000000000001& E-31
    convertToDouble +76579757567530E-23
} 0x3e0a5006d695fef1
test expr-28.967 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +15315951513506 E-22 x 1a5006d695fef0_1000000000000000000000000000000000000000000001& E-30
    convertToDouble +15315951513506E-22
} 0x3e1a5006d695fef1
test expr-28.968 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -38289878783765 E-23 x -1a5006d695fef0_1000000000000000000000000000000000000000000001& E-32
    convertToDouble -38289878783765E-23
} 0xbdfa5006d695fef1
test expr-28.969 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +49378033925202 E25 x 1737aa2567167b_0111111111111111111111111111111111111111111110& E128
    convertToDouble +49378033925202E25
} 0x47f737aa2567167b
test expr-28.970 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -50940527102367 E24 x -132964f2944b05_0111111111111111111111111111111111111111111111110& E125
    convertToDouble -50940527102367E24
} 0xc7c32964f2944b05
test expr-28.971 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +98756067850404 E25 x 1737aa2567167b_0111111111111111111111111111111111111111111110& E129
    convertToDouble +98756067850404E25
} 0x480737aa2567167b
test expr-28.972 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -99589397544892 E26 x -1d4446075c4933_0111111111111111111111111111111111111111111110& E132
    convertToDouble -99589397544892E26
} 0xc83d4446075c4933
test expr-28.973 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -56908598265713 E-25 x -190756ab1ed6b3_011111111111111111111111111111111111111111111110& E-38
    convertToDouble -56908598265713E-25
} 0xbd990756ab1ed6b3
test expr-28.974 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +97470695699657 E-22 x 14ee821710e655_01111111111111111111111111111111111111111111110& E-27
    convertToDouble +97470695699657E-22
} 0x3e44ee821710e655
test expr-28.975 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -35851901247343 E-25 x -1f8921657e1581_0111111111111111111111111111111111111111111110& E-39
    convertToDouble -35851901247343E-25
} 0xbd8f8921657e1581
test expr-28.976 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +154384074484266 E27 x 1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E136
    convertToDouble +154384074484266E27
} 0x487c5b1ab32d5dbf
test expr-28.977 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -308768148968532 E27 x -1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E137
    convertToDouble -308768148968532E27
} 0xc88c5b1ab32d5dbf
test expr-28.978 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +910990389005985 E23 x 112242592ae54a_100000000000000000000000000000000000000000000001& E126
    convertToDouble +910990389005985E23
} 0x47d12242592ae54b
test expr-28.979 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +271742424169201 E-27 x 131f46bcf7b452_10000000000000000000000000000000000000000000000001& E-42
    convertToDouble +271742424169201E-27
} 0x3d531f46bcf7b453
test expr-28.980 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -543484848338402 E-27 x -131f46bcf7b452_10000000000000000000000000000000000000000000000001& E-41
    convertToDouble -543484848338402E-27
} 0xbd631f46bcf7b453
test expr-28.981 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +162192083357563 E-26 x 1c887b68658760_1000000000000000000000000000000000000000000000001& E-40
    convertToDouble +162192083357563E-26
} 0x3d7c887b68658761
test expr-28.982 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -869254552770081 E-23 x -12aac70665485e_1000000000000000000000000000000000000000000000000001& E-27
    convertToDouble -869254552770081E-23
} 0xbe42aac70665485f
test expr-28.983 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +664831007626046 E24 x 1f429cb67eb075_011111111111111111111111111111111111111111111111110& E128
    convertToDouble +664831007626046E24
} 0x47ff429cb67eb075
test expr-28.984 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -332415503813023 E24 x -1f429cb67eb075_011111111111111111111111111111111111111111111111110& E127
    convertToDouble -332415503813023E24
} 0xc7ef429cb67eb075
test expr-28.985 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +943701829041427 E24 x 162fb2e38ee461_01111111111111111111111111111111111111111111111110& E129
    convertToDouble +943701829041427E24
} 0x48062fb2e38ee461
test expr-28.986 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -101881054204734 E24 x -132964f2944b05_0111111111111111111111111111111111111111111111110& E126
    convertToDouble -101881054204734E24
} 0xc7d32964f2944b05
test expr-28.987 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +828027839666967 E-27 x 1d2236349da3cd_011111111111111111111111111111111111111111111111110& E-41
    convertToDouble +828027839666967E-27
} 0x3d6d2236349da3cd
test expr-28.988 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -280276135608777 E-27 x -13b901892fd0bf_0111111111111111111111111111111111111111111111110& E-42
    convertToDouble -280276135608777E-27
} 0xbd53b901892fd0bf
test expr-28.989 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +212839188833879 E-21 x 1c91194dc2d40b_0111111111111111111111111111111111111111111111110& E-23
    convertToDouble +212839188833879E-21
} 0x3e8c91194dc2d40b
test expr-28.990 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -113817196531426 E-25 x -190756ab1ed6b3_011111111111111111111111111111111111111111111110& E-37
    convertToDouble -113817196531426E-25
} 0xbda90756ab1ed6b3
test expr-28.991 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +9711553197796883 E27 x 1bdeec25c0f03e_10000000000000000000000000000000000000000000000000001& E142
    convertToDouble +9711553197796883E27
} 0x48dbdeec25c0f03f
test expr-28.992 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2739849386524269 E26 x -19295ade212370_1000000000000000000000000000000000000000000000000001& E137
    convertToDouble -2739849386524269E26
} 0xc889295ade212371
test expr-28.993 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +5479698773048538 E26 x 19295ade212370_1000000000000000000000000000000000000000000000000001& E138
    convertToDouble +5479698773048538E26
} 0x4899295ade212371
test expr-28.994 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6124568318523113 E-25 x 150b3a2e0aff14_1000000000000000000000000000000000000000000000000000001& E-31
    convertToDouble +6124568318523113E-25
} 0x3e050b3a2e0aff15
test expr-28.995 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1139777988171071 E-24 x -1394cbee428ea4_10000000000000000000000000000000000000000000000000001& E-30
    convertToDouble -1139777988171071E-24
} 0xbe1394cbee428ea5
test expr-28.996 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +6322612303128019 E-27 x 1bcea0ec21e250_1000000000000000000000000000000000000000000000000000001& E-38
    convertToDouble +6322612303128019E-27
} 0x3d9bcea0ec21e251
test expr-28.997 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2955864564844617 E-25 x -1450030e26c6dc_10000000000000000000000000000000000000000000000000001& E-32
    convertToDouble -2955864564844617E-25
} 0xbdf450030e26c6dd
test expr-28.998 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -9994029144998961 E25 x -125b2b7fed4a61_0111111111111111111111111111111111111111111111111110& E136
    convertToDouble -9994029144998961E25
} 0xc8725b2b7fed4a61
test expr-28.999 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -2971238324022087 E27 x -110dd7a301db67_0111111111111111111111111111111111111111111111111110& E141
    convertToDouble -2971238324022087E27
} 0xc8c10dd7a301db67
test expr-28.1000 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1656055679333934 E-27 x -1d2236349da3cd_011111111111111111111111111111111111111111111111110& E-40
    convertToDouble -1656055679333934E-27
} 0xbd7d2236349da3cd
test expr-28.1001 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -1445488709150234 E-26 x -1fc960c59526c7_0111111111111111111111111111111111111111111111110& E-37
    convertToDouble -1445488709150234E-26
} 0xbdafc960c59526c7
test expr-28.1002 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +55824717499885172 E27 x 1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E145
    convertToDouble +55824717499885172E27
} 0x490406b0cd17fd57
test expr-28.1003 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -69780896874856465 E26 x -1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E142
    convertToDouble -69780896874856465E26
} 0xc8d406b0cd17fd57
test expr-28.1004 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +84161538867545199 E25 x 13529217bdce6c_10000000000000000000000000000000000000000000000000000000001& E139
    convertToDouble +84161538867545199E25
} 0x48a3529217bdce6d
test expr-28.1005 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -27912358749942586 E27 x -1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E144
    convertToDouble -27912358749942586E27
} 0xc8f406b0cd17fd57
test expr-28.1006 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +24711112462926331 E-25 x 153a07f6040d22_100000000000000000000000000000000000000000000000000000001& E-29
    convertToDouble +24711112462926331E-25
} 0x3e253a07f6040d23
test expr-28.1007 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -12645224606256038 E-27 x -1bcea0ec21e250_1000000000000000000000000000000000000000000000000000001& E-37
    convertToDouble -12645224606256038E-27
} 0xbdabcea0ec21e251
test expr-28.1008 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -12249136637046226 E-25 x -150b3a2e0aff14_1000000000000000000000000000000000000000000000000000001& E-30
    convertToDouble -12249136637046226E-25
} 0xbe150b3a2e0aff15
test expr-28.1009 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +74874448287465757 E27 x 1adc21d1d50b09_01111111111111111111111111111111111111111111111111111110& E145
    convertToDouble +74874448287465757E27
} 0x490adc21d1d50b09
test expr-28.1010 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -35642836832753303 E24 x -1a2fac2b421f53_0111111111111111111111111111111111111111111111111111110& E134
    convertToDouble -35642836832753303E24
} 0xc85a2fac2b421f53
test expr-28.1011 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -71285673665506606 E24 x -1a2fac2b421f53_0111111111111111111111111111111111111111111111111111110& E135
    convertToDouble -71285673665506606E24
} 0xc86a2fac2b421f53
test expr-28.1012 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +43723334984997307 E-26 x 1e0be3f392c549_01111111111111111111111111111111111111111111111111111110& E-32
    convertToDouble +43723334984997307E-26
} 0x3dfe0be3f392c549
test expr-28.1013 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN +10182419849537963 E-24 x 15ddd831ebbe53_011111111111111111111111111111111111111111111111111110& E-27
    convertToDouble +10182419849537963E-24
} 0x3e45ddd831ebbe53
test expr-28.1014 {input floating-point conversion} {ieeeFloatingPoint} {
    # Ad2b dieee UN -93501703572661982 E-26 x -10103f97ea6e13_0111111111111111111111111111111111111111111111111110& E-30
    convertToDouble -93501703572661982E-26
} 0xbe10103f97ea6e13

test expr-29.1 {smallest representible number} {ieeeFloatingPoint} {
    list [catch {convertToDouble 4.9406564584124654e-324} result] \
	$result \
	[catch {convertToDouble 2.4703282292062327e-324} result] \
	$result \
	[catch {convertToDouble 2.47032822920623e-324} result] \
	$result
} {0 0x0000000000000001 0 0x0000000000000001 0 0x0000000000000000}
test expr-29.2 {smallest representible number} {ieeeFloatingPoint} {
    list [catch {convertToDouble -4.9406564584124654e-324} result] \
	$result \
	[catch {convertToDouble -2.4703282292062327e-324} result] \
	$result \
	[catch {convertToDouble -2.47032822920623e-324} result] \
	$result
} {0 0x8000000000000001 0 0x8000000000000001 0 0x8000000000000000}
test expr-29.3 {silent underflow on input conversion} {ieeeFloatingPoint} {
    set v ?
    list [scan 2.47032822920623e-324 %g v] $v
} {1 0.0}
test expr-29.4 {silent underflow on input conversion} {ieeeFloatingPoint} {
    set v ?
    list [scan -2.47032822920623e-324 %g v] $v
} {1 -0.0}

test expr-30.1 {largest representible number} {ieeeFloatingPoint} {
    list [catch {convertToDouble 1.7976931348623155e+308} result] \
	$result \
	[catch {convertToDouble 1.7976931348623157e+308} result] \
	$result \
	[catch {convertToDouble 1.7976931348623159e+308} result] \
	$result
} {0 0x7feffffffffffffe 0 0x7fefffffffffffff 0 0x7ff0000000000000}
test expr-30.2 {largest representible number} {ieeeFloatingPoint} {
    list [catch {convertToDouble -1.7976931348623155e+308} result] \
	$result \
	[catch {convertToDouble -1.7976931348623157e+308} result] \
	$result \
	[catch {convertToDouble -1.7976931348623159e+308} result] \
	$result
} {0 0xffeffffffffffffe 0 0xffefffffffffffff 0 0xfff0000000000000}
test expr-30.3 {silent overflow on input conversion} {ieeeFloatingPoint} {
    set v ?
    list [scan 1.7976931348623159e+308 %f v] $v
} {1 Inf}
test expr-30.4 {silent overflow on input conversion} {ieeeFloatingPoint} {
    set v ?
    list [scan -1.7976931348623159e+308 %f v] $v
} {1 -Inf}

# bool() tests (TIP #182)
set i 0
foreach s {yes true on} {
    test expr-31.$i.0 {boolean conversion} {expr bool($s)} 1
    test expr-31.$i.1 {boolean conversion} {expr bool(!$s)} 0
    test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 1
    test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 0
    set j 1
    while {$j < [string length $s]-1} {
	test expr-31.$i.4.$j {boolean conversion} {
	    expr bool([string range $s 0 $j])
	} 1
	test expr-31.$i.5.$j {boolean conversion} {
	    expr bool("[string range $s 0 $j]")
	} 1
	incr j
    }
    incr i
}
test expr-31.0.4.0 {boolean conversion} {expr bool(y)} 1
test expr-31.0.5.0 {boolean conversion} {expr bool("y")} 1
test expr-31.1.4.0 {boolean conversion} {expr bool(t)} 1
test expr-31.1.5.0 {boolean conversion} {expr bool("t")} 1
test expr-31.2.4.0 {boolean conversion} -body {
    expr bool(o)
} -returnCodes error -match glob -result *
test expr-31.2.5.0 {boolean conversion} -body {
    expr bool("o")
} -returnCodes error -match glob -result *
foreach s {no false off} {
    test expr-31.$i.0 {boolean conversion} {expr bool($s)} 0
    test expr-31.$i.1 {boolean conversion} {expr bool(!$s)} 1
    test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 0
    test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 1
    set j 1
    while {$j < [string length $s]-1} {
	test expr-31.$i.4.$j {boolean conversion} {
	    expr bool([string range $s 0 $j])
	} 0
	test expr-31.$i.5.$j {boolean conversion} {
	    expr bool("[string range $s 0 $j]")
	} 0
	incr j
    }
    incr i
}
test expr-31.3.4.0 {boolean conversion} {expr bool(n)} 0
test expr-31.3.5.0 {boolean conversion} {expr bool("n")} 0
test expr-31.4.4.0 {boolean conversion} {expr bool(f)} 0
test expr-31.4.5.0 {boolean conversion} {expr bool("f")} 0
test expr-31.6  {boolean conversion} {expr bool(-1 + 1)} 0
test expr-31.7  {boolean conversion} {expr bool(0 + 1)} 1
test expr-31.8  {boolean conversion} {expr bool(0.0)} 0
test expr-31.9  {boolean conversion} {expr bool(0x0)} 0
test expr-31.10 {boolean conversion} {expr bool(wide(0))} 0
test expr-31.11 {boolean conversion} {expr bool(5.0)} 1
test expr-31.12 {boolean conversion} {expr bool(5)} 1
test expr-31.13 {boolean conversion} {expr bool(0x5)} 1
test expr-31.14 {boolean conversion} {expr bool(wide(5))} 1
test expr-31.15 {boolean conversion} -body {
    expr bool("fred")
} -returnCodes error -match glob -result *

test expr-32.1 {expr mod basics} {
    set mod_nums [list \
        {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \
        {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \
        {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \
        {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \
        {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \
        {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \
        {0 -100} {0 -1} {0 1} {0 100} \
        {1 1} {1 2} {1 3} {1 4} {1 5} \
        {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \
        {2 1} {2 2} {2 3} {2 4} {2 5} \
        {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \
        {3 1} {3 2} {3 3} {3 4} {3 5} \
        {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \
        ]
    set results [list]
    foreach pair $mod_nums {
        set dividend [lindex $pair 0]
        set divisor [lindex $pair 1]
        lappend results [expr {$dividend % $divisor}]
    }
    set results
} [list \
    0 1 0 1 2 \
    0 -1 0 -3 -3 \
    0 0 1 2 3 \
    0 0 -2 -2 -2 \
    0 1 2 3 4 \
    0 -1 -1 -1 -1 \
    0 0 0 0 \
    0 1 1 1 1 \
    0 -1 -2 -3 -4 \
    0 0 2 2 2 \
    0 0 -1 -2 -3 \
    0 1 0 3 3 \
    0 -1 0 -1 -2 \
    ]
        
test expr-32.2 {expr div basics} {
    set mod_nums [list \
        {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \
        {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \
        {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \
        {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \
        {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \
        {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \
        {0 -100} {0 -1} {0 1} {0 100} \
        {1 1} {1 2} {1 3} {1 4} {1 5} \
        {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \
        {2 1} {2 2} {2 3} {2 4} {2 5} \
        {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \
        {3 1} {3 2} {3 3} {3 4} {3 5} \
        {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \
        ]
    set results [list]
    foreach pair $mod_nums {
        set dividend [lindex $pair 0]
        set divisor [lindex $pair 1]
        lappend results [expr {$dividend / $divisor}]
    }
    set results
} [list \
    -3 -2 -1 -1 -1 \
    3 1 1 0 0 \
    -2 -1 -1 -1 -1 \
    2 1 0 0 0 \
    -1 -1 -1 -1 -1 \
    1 0 0 0 0 \
    0 0 0 0 \
    1 0 0 0 0 \
    -1 -1 -1 -1 -1 \
    2 1 0 0 0 \
    -2 -1 -1 -1 -1 \
    3 1 1 0 0 \
    -3 -2 -1 -1 -1 \
    ]

test expr-33.1 {parse largest long value} {longIs32bit} {
    set max_long_str 2147483647
    set max_long_hex "0x7FFFFFFF "

    # Convert to integer (long, not wide) internal rep
    set max_long 2147483647
    string is integer $max_long

    list \
        [expr {" $max_long_str "}] \
        [expr {$max_long_str + 0}] \
        [expr {$max_long + 0}] \
        [expr {2147483647 + 0}] \
        [expr {$max_long == $max_long_hex}] \
        [expr {(2147483647 + 1) < 0}] \

} {2147483647 2147483647 2147483647 2147483647 1 1}
test expr-33.2 {parse smallest long value} {longIs32bit} {
    set min_long_str -2147483648
    set min_long_hex "-0x80000000 "

    set min_long -2147483648
    # This will convert to integer (not wide) internal rep
    string is integer $min_long

    # Note: If the final expression returns 0 then the
    # expression literal is being promoted to a wide type
    # when it should be parsed as a long type.
    list \
        [expr {" $min_long_str "}] \
        [expr {$min_long_str + 0}] \
        [expr {$min_long + 0}] \
        [expr {-2147483648 + 0}] \
        [expr {$min_long == $min_long_hex}] \
        [expr {(-2147483648 - 1) == 0x7FFFFFFF}] \

} {-2147483648 -2147483648 -2147483648 -2147483648 1 1}
test expr-33.3 {parse largest wide value} {wideIs64bit} {
    set max_wide_str 9223372036854775807
    set max_wide_hex "0x7FFFFFFFFFFFFFFF "

    # Convert to wide integer
    set max_wide 9223372036854775807
    string is integer $max_wide

    list \
        [expr {" $max_wide_str "}] \
        [expr {$max_wide_str + 0}] \
        [expr {$max_wide + 0}] \
        [expr {9223372036854775807 + 0}] \
        [expr {$max_wide == $max_wide_hex}] \
        [expr {(9223372036854775807 + 1) < 0}] \

} {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1}
test expr-33.4 {parse smallest wide value} {wideIs64bit} {
    set min_wide_str -9223372036854775808
    set min_wide_hex "-0x8000000000000000 "

    set min_wide -9223372036854775808
    # Convert to wide integer
    string is integer $min_wide

    # Note: If the final expression returns 0 then the
    # wide integer is not being parsed correctly with
    # the leading - sign.
    list \
        [expr {" $min_wide_str "}] \
        [expr {$min_wide_str + 0}] \
        [expr {$min_wide + 0}] \
        [expr {-9223372036854775808 + 0}] \
        [expr {$min_wide == $min_wide_hex}] \
        [expr {(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \

} {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1}

set min -2147483648
set max 2147483647

test expr-34.1 {expr edge cases} {longIs32bit} {
    expr {$min / $min}
} {1}
test expr-34.2 {expr edge cases} {longIs32bit} {
    expr {$min % $min}
} {0}
test expr-34.3 {expr edge cases} {longIs32bit} {
    expr {$min / ($min + 1)}
} {1}
test expr-34.4 {expr edge cases} {longIs32bit} {
    expr {$min % ($min + 1)}
} {-1}
test expr-34.5 {expr edge cases} {longIs32bit} {
    expr {$min / ($min + 2)}
} {1}
test expr-34.6 {expr edge cases} {longIs32bit} {
    expr {$min % ($min + 2)}
} {-2}
test expr-34.7 {expr edge cases} {longIs32bit} {
    expr {$min / ($min + 3)}
} {1}
test expr-34.8 {expr edge cases} {longIs32bit} {
    expr {$min % ($min + 3)}
} {-3}
test expr-34.9 {expr edge cases} {longIs32bit} {
    expr {$min / -3}
} {715827882}
test expr-34.10 {expr edge cases} {longIs32bit} {
    expr {$min % -3}
} {-2}
test expr-34.11 {expr edge cases} {longIs32bit} {
    expr {$min / -2}
} {1073741824}
test expr-34.12 {expr edge cases} {longIs32bit} {
    expr {$min % -2}
} {0}
test expr-34.13 {expr edge cases} {longIs32bit} {
    expr {$min / -1}
} {-2147483648}
test expr-34.14 {expr edge cases} {longIs32bit} {
    expr {$min % -1}
} {0}
test expr-34.15 {expr edge cases} {longIs32bit} {
    expr {$min * -1}
} $min
test expr-34.16 {expr edge cases} {longIs32bit} {
    expr {-$min}
} $min
test expr-34.17 {expr edge cases} {longIs32bit} {
    expr {$min / 1}
} $min
test expr-34.18 {expr edge cases} {longIs32bit} {
    expr {$min % 1}
} {0}
test expr-34.19 {expr edge cases} {longIs32bit} {
    expr {$min / 2}
} {-1073741824}
test expr-34.20 {expr edge cases} {longIs32bit} {
    expr {$min % 2}
} {0}
test expr-34.21 {expr edge cases} {longIs32bit} {
    expr {$min / 3}
} {-715827883}
test expr-34.22 {expr edge cases} {longIs32bit} {
    expr {$min % 3}
} {1}
test expr-34.23 {expr edge cases} {longIs32bit} {
    expr {$min / ($max - 3)}
} {-2}
test expr-34.24 {expr edge cases} {longIs32bit} {
    expr {$min % ($max - 3)}
} {2147483640}
test expr-34.25 {expr edge cases} {longIs32bit} {
    expr {$min / ($max - 2)}
} {-2}
test expr-34.26 {expr edge cases} {longIs32bit} {
    expr {$min % ($max - 2)}
} {2147483642}
test expr-34.27 {expr edge cases} {longIs32bit} {
    expr {$min / ($max - 1)}
} {-2}
test expr-34.28 {expr edge cases} {longIs32bit} {
    expr {$min % ($max - 1)}
} {2147483644}
test expr-34.29 {expr edge cases} {longIs32bit} {
    expr {$min / $max}
} {-2}
test expr-34.30 {expr edge cases} {longIs32bit} {
    expr {$min % $max}
} {2147483646}
test expr-34.31 {expr edge cases} {longIs32bit} {
    expr {$max / $max}
} {1}
test expr-34.32 {expr edge cases} {longIs32bit} {
    expr {$max % $max}
} {0}
test expr-34.33 {expr edge cases} {longIs32bit} {
    expr {$max / ($max - 1)}
} {1}
test expr-34.34 {expr edge cases} {longIs32bit} {
    expr {$max % ($max - 1)}
} {1}
test expr-34.35 {expr edge cases} {longIs32bit} {
    expr {$max / ($max - 2)}
} {1}
test expr-34.36 {expr edge cases} {longIs32bit} {
    expr {$max % ($max - 2)}
} {2}
test expr-34.37 {expr edge cases} {longIs32bit} {
    expr {$max / ($max - 3)}
} {1}
test expr-34.38 {expr edge cases} {longIs32bit} {
    expr {$max % ($max - 3)}
} {3}
test expr-34.39 {expr edge cases} {longIs32bit} {
    expr {$max / 3}
} {715827882}
test expr-34.40 {expr edge cases} {longIs32bit} {
    expr {$max % 3}
} {1}
test expr-34.41 {expr edge cases} {longIs32bit} {
    expr {$max / 2}
} {1073741823}
test expr-34.42 {expr edge cases} {longIs32bit} {
    expr {$max % 2}
} {1}
test expr-34.43 {expr edge cases} {longIs32bit} {
    expr {$max / 1}
} $max
test expr-34.44 {expr edge cases} {longIs32bit} {
    expr {$max % 1}
} {0}
test expr-34.45 {expr edge cases} {longIs32bit} {
    expr {$max / -1}
} "-$max"
test expr-34.46 {expr edge cases} {longIs32bit} {
    expr {$max % -1}
} {0}
test expr-34.47 {expr edge cases} {longIs32bit} {
    expr {$max / -2}
} {-1073741824}
test expr-34.48 {expr edge cases} {longIs32bit} {
    expr {$max % -2}
} {-1}
test expr-34.49 {expr edge cases} {longIs32bit} {
    expr {$max / -3}
} {-715827883}
test expr-34.50 {expr edge cases} {longIs32bit} {
    expr {$max % -3}
} {-2}
test expr-34.51 {expr edge cases} {longIs32bit} {
    expr {$max / ($min + 3)}
} {-2}
test expr-34.52 {expr edge cases} {longIs32bit} {
    expr {$max % ($min + 3)}
} {-2147483643}
test expr-34.53 {expr edge cases} {longIs32bit} {
    expr {$max / ($min + 2)}
} {-2}
test expr-34.54 {expr edge cases} {longIs32bit} {
    expr {$max % ($min + 2)}
} {-2147483645}
test expr-34.55 {expr edge cases} {longIs32bit} {
    expr {$max / ($min + 1)}
} {-1}
test expr-34.56 {expr edge cases} {longIs32bit} {
    expr {$max % ($min + 1)}
} {0}
test expr-34.57 {expr edge cases} {longIs32bit} {
    expr {$max / $min}
} {-1}
test expr-34.58 {expr edge cases} {longIs32bit} {
    expr {$max % $min}
} {-1}
test expr-34.59 {expr edge cases} {longIs32bit} {
    expr {($min + 1) / ($max - 1)}
} {-2}
test expr-34.60 {expr edge cases} {longIs32bit} {
    expr {($min + 1) % ($max - 1)}
} {2147483645}
test expr-34.61 {expr edge cases} {longIs32bit} {
    expr {($max - 1) / ($min + 1)}
} {-1}
test expr-34.62 {expr edge cases} {longIs32bit} {
    expr {($max - 1) % ($min + 1)}
} {-1}
test expr-34.63 {expr edge cases} {longIs32bit} {
    expr {($max - 1) / $min}
} {-1}
test expr-34.64 {expr edge cases} {longIs32bit} {
    expr {($max - 1) % $min}
} {-2}
test expr-34.65 {expr edge cases} {longIs32bit} {
    expr {($max - 2) / $min}
} {-1}
test expr-34.66 {expr edge cases} {longIs32bit} {
    expr {($max - 2) % $min}
} {-3}
test expr-34.67 {expr edge cases} {longIs32bit} {
    expr {($max - 3) / $min}
} {-1}
test expr-34.68 {expr edge cases} {longIs32bit} {
    expr {($max - 3) % $min}
} {-4}
test expr-34.69 {expr edge cases} {longIs32bit} {
    expr {-3 / $min}
} {0}
test expr-34.70 {expr edge cases} {longIs32bit} {
    expr {-3 % $min}
} {-3}
test expr-34.71 {expr edge cases} {longIs32bit} {
    expr {-2 / $min}
} {0}
test expr-34.72 {expr edge cases} {longIs32bit} {
    expr {-2 % $min}
} {-2}
test expr-34.73 {expr edge cases} {longIs32bit} {
    expr {-1 / $min}
} {0}
test expr-34.74 {expr edge cases} {longIs32bit} {
    expr {-1 % $min}
} {-1}
test expr-34.75 {expr edge cases} {longIs32bit} {
    expr {0 / $min}
} {0}
test expr-34.76 {expr edge cases} {longIs32bit} {
    expr {0 % $min}
} {0}
test expr-34.77 {expr edge cases} {longIs32bit} {
    expr {0 / ($min + 1)}
} {0}
test expr-34.78 {expr edge cases} {longIs32bit} {
    expr {0 % ($min + 1)}
} {0}
test expr-34.79 {expr edge cases} {longIs32bit} {
    expr {1 / $min}
} {-1}
test expr-34.80 {expr edge cases} {longIs32bit} {
    expr {1 % $min}
} {-2147483647}
test expr-34.81 {expr edge cases} {longIs32bit} {
    expr {1 / ($min + 1)}
} {-1}
test expr-34.82 {expr edge cases} {longIs32bit} {
    expr {1 % ($min + 1)}
} {-2147483646}
test expr-34.83 {expr edge cases} {longIs32bit} {
    expr {2 / $min}
} {-1}
test expr-34.84 {expr edge cases} {longIs32bit} {
    expr {2 % $min}
} {-2147483646}
test expr-34.85 {expr edge cases} {longIs32bit} {
    expr {2 / ($min + 1)}
} {-1}
test expr-34.86 {expr edge cases} {longIs32bit} {
    expr {2 % ($min + 1)}
} {-2147483645}
test expr-34.87 {expr edge cases} {longIs32bit} {
    expr {3 / $min}
} {-1}
test expr-34.88 {expr edge cases} {longIs32bit} {
    expr {3 % $min}
} {-2147483645}
test expr-34.89 {expr edge cases} {longIs32bit} {
    expr {3 / ($min + 1)}
} {-1}
test expr-34.90 {expr edge cases} {longIs32bit} {
    expr {3 % ($min + 1)}
} {-2147483644}

# Euclidean property:
# quotient * divisor + remainder = dividend

test expr-35.1 {expr edge cases} {longIs32bit} {
    set dividend $max
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($divisor * $q) + $r}]
} {1073741823 * 2 + 1 = 2147483647}
test expr-35.2 {expr edge cases} {longIs32bit} {
    set dividend [expr {$max - 1}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1073741823 * 2 + 0 = 2147483646}
test expr-35.3 {expr edge cases} {longIs32bit} {
    set dividend [expr {$max - 2}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1073741822 * 2 + 1 = 2147483645}
test expr-35.4 {expr edge cases} {longIs32bit} {
    set dividend $max
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827882 * 3 + 1 = 2147483647}
test expr-35.5 {expr edge cases} {longIs32bit} {
    set dividend [expr {$max - 1}]
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827882 * 3 + 0 = 2147483646}
test expr-35.6 {expr edge cases} {longIs32bit} {
    set dividend [expr {$max - 2}]
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827881 * 3 + 2 = 2147483645}
test expr-35.7 {expr edge cases} {longIs32bit} {
    set dividend $min
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-1073741824 * 2 + 0 = -2147483648}
test expr-35.8 {expr edge cases} {longIs32bit} {
    set dividend [expr {$min + 1}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-1073741824 * 2 + 1 = -2147483647}
test expr-35.9 {expr edge cases} {longIs32bit} {
    set dividend [expr {$min + 2}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-1073741823 * 2 + 0 = -2147483646}
test expr-35.10 {expr edge cases} {longIs32bit} {
    # Two things could happen here. The multiplication
    # could overflow a 32 bit type, so that when
    # 1 is added it overflows again back to min.
    # The multiplication could also use a wide type
    # to hold ($min - 1) until 1 is added and
    # the number becomes $min again.
    set dividend $min
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-715827883 * 3 + 1 = -2147483648}
test expr-35.11 {expr edge cases} {longIs32bit} {
    set dividend $min
    set divisor -3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827882 * -3 + -2 = -2147483648}
test expr-35.12 {expr edge cases} {longIs32bit} {
    set dividend $min
    set divisor $min
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -2147483648 + 0 = -2147483648}
test expr-35.13 {expr edge cases} {longIs32bit} {
    set dividend $min
    set divisor [expr {$min + 1}]
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -2147483647 + -1 = -2147483648}
test expr-35.14 {expr edge cases} {longIs32bit} {
    set dividend $min
    set divisor [expr {$min + 2}]
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -2147483646 + -2 = -2147483648}

# 64bit wide integer checks

set min -9223372036854775808
set max 9223372036854775807

test expr-36.1 {expr edge cases} {wideIs64bit} {
    expr {$min / $min}
} {1}
test expr-36.2 {expr edge cases} {wideIs64bit} {
    expr {$min % $min}
} {0}
test expr-36.3 {expr edge cases} {wideIs64bit} {
    expr {$min / ($min + 1)}
} {1}
test expr-36.4 {expr edge cases} {wideIs64bit} {
    expr {$min % ($min + 1)}
} {-1}
test expr-36.5 {expr edge cases} {wideIs64bit} {
    expr {$min / ($min + 2)}
} {1}
test expr-36.6 {expr edge cases} {wideIs64bit} {
    expr {$min % ($min + 2)}
} {-2}
test expr-36.7 {expr edge cases} {wideIs64bit} {
    expr {$min / ($min + 3)}
} {1}
test expr-36.8 {expr edge cases} {wideIs64bit} {
    expr {$min % ($min + 3)}
} {-3}
test expr-36.9 {expr edge cases} {wideIs64bit} {
    expr {$min / -3}
} {3074457345618258602}
test expr-36.10 {expr edge cases} {wideIs64bit} {
    expr {$min % -3}
} {-2}
test expr-36.11 {expr edge cases} {wideIs64bit} {
    expr {$min / -2}
} {4611686018427387904}
test expr-36.12 {expr edge cases} {wideIs64bit} {
    expr {$min % -2}
} {0}
test expr-36.13 {expr edge cases} {wideIs64bit} {
    expr {$min / -1}
} $min
test expr-36.14 {expr edge cases} {wideIs64bit} {
    expr {$min % -1}
} {0}
test expr-36.15 {expr edge cases} {wideIs64bit} {
    expr {$min * -1}
} $min
test expr-36.16 {expr edge cases} {wideIs64bit} {
    expr {-$min}
} $min
test expr-36.17 {expr edge cases} {wideIs64bit} {
    expr {$min / 1}
} $min
test expr-36.18 {expr edge cases} {wideIs64bit} {
    expr {$min % 1}
} {0}
test expr-36.19 {expr edge cases} {wideIs64bit} {
    expr {$min / 2}
} {-4611686018427387904}
test expr-36.20 {expr edge cases} {wideIs64bit} {
    expr {$min % 2}
} {0}
test expr-36.21 {expr edge cases} {wideIs64bit} {
    expr {$min / 3}
} {-3074457345618258603}
test expr-36.22 {expr edge cases} {wideIs64bit} {
    expr {$min % 3}
} {1}
test expr-36.23 {expr edge cases} {wideIs64bit} {
    expr {$min / ($max - 3)}
} {-2}
test expr-36.24 {expr edge cases} {wideIs64bit} {
    expr {$min % ($max - 3)}
} {9223372036854775800}
test expr-36.25 {expr edge cases} {wideIs64bit} {
    expr {$min / ($max - 2)}
} {-2}
test expr-36.26 {expr edge cases} {wideIs64bit} {
    expr {$min % ($max - 2)}
} {9223372036854775802}
test expr-36.27 {expr edge cases} {wideIs64bit} {
    expr {$min / ($max - 1)}
} {-2}
test expr-36.28 {expr edge cases} {wideIs64bit} {
    expr {$min % ($max - 1)}
} {9223372036854775804}
test expr-36.29 {expr edge cases} {wideIs64bit} {
    expr {$min / $max}
} {-2}
test expr-36.30 {expr edge cases} {wideIs64bit} {
    expr {$min % $max}
} {9223372036854775806}
test expr-36.31 {expr edge cases} {wideIs64bit} {
    expr {$max / $max}
} {1}
test expr-36.32 {expr edge cases} {wideIs64bit} {
    expr {$max % $max}
} {0}
test expr-36.33 {expr edge cases} {wideIs64bit} {
    expr {$max / ($max - 1)}
} {1}
test expr-36.34 {expr edge cases} {wideIs64bit} {
    expr {$max % ($max - 1)}
} {1}
test expr-36.35 {expr edge cases} {wideIs64bit} {
    expr {$max / ($max - 2)}
} {1}
test expr-36.36 {expr edge cases} {wideIs64bit} {
    expr {$max % ($max - 2)}
} {2}
test expr-36.37 {expr edge cases} {wideIs64bit} {
    expr {$max / ($max - 3)}
} {1}
test expr-36.38 {expr edge cases} {wideIs64bit} {
    expr {$max % ($max - 3)}
} {3}
test expr-36.39 {expr edge cases} {wideIs64bit} {
    expr {$max / 3}
} {3074457345618258602}
test expr-36.40 {expr edge cases} {wideIs64bit} {
    expr {$max % 3}
} {1}
test expr-36.41 {expr edge cases} {wideIs64bit} {
    expr {$max / 2}
} {4611686018427387903}
test expr-36.42 {expr edge cases} {wideIs64bit} {
    expr {$max % 2}
} {1}
test expr-36.43 {expr edge cases} {wideIs64bit} {
    expr {$max / 1}
} $max
test expr-36.44 {expr edge cases} {wideIs64bit} {
    expr {$max % 1}
} {0}
test expr-36.45 {expr edge cases} {wideIs64bit} {
    expr {$max / -1}
} "-$max"
test expr-36.46 {expr edge cases} {wideIs64bit} {
    expr {$max % -1}
} {0}
test expr-36.47 {expr edge cases} {wideIs64bit} {
    expr {$max / -2}
} {-4611686018427387904}
test expr-36.48 {expr edge cases} {wideIs64bit} {
    expr {$max % -2}
} {-1}
test expr-36.49 {expr edge cases} {wideIs64bit} {
    expr {$max / -3}
} {-3074457345618258603}
test expr-36.50 {expr edge cases} {wideIs64bit} {
    expr {$max % -3}
} {-2}
test expr-36.51 {expr edge cases} {wideIs64bit} {
    expr {$max / ($min + 3)}
} {-2}
test expr-36.52 {expr edge cases} {wideIs64bit} {
    expr {$max % ($min + 3)}
} {-9223372036854775803}
test expr-36.53 {expr edge cases} {wideIs64bit} {
    expr {$max / ($min + 2)}
} {-2}
test expr-36.54 {expr edge cases} {wideIs64bit} {
    expr {$max % ($min + 2)}
} {-9223372036854775805}
test expr-36.55 {expr edge cases} {wideIs64bit} {
    expr {$max / ($min + 1)}
} {-1}
test expr-36.56 {expr edge cases} {wideIs64bit} {
    expr {$max % ($min + 1)}
} {0}
test expr-36.57 {expr edge cases} {wideIs64bit} {
    expr {$max / $min}
} {-1}
test expr-36.58 {expr edge cases} {wideIs64bit} {
    expr {$max % $min}
} {-1}
test expr-36.59 {expr edge cases} {wideIs64bit} {
    expr {($min + 1) / ($max - 1)}
} {-2}
test expr-36.60 {expr edge cases} {wideIs64bit} {
    expr {($min + 1) % ($max - 1)}
} {9223372036854775805}
test expr-36.61 {expr edge cases} {wideIs64bit} {
    expr {($max - 1) / ($min + 1)}
} {-1}
test expr-36.62 {expr edge cases} {wideIs64bit} {
    expr {($max - 1) % ($min + 1)}
} {-1}
test expr-36.63 {expr edge cases} {wideIs64bit} {
    expr {($max - 1) / $min}
} {-1}
test expr-36.64 {expr edge cases} {wideIs64bit} {
    expr {($max - 1) % $min}
} {-2}
test expr-36.65 {expr edge cases} {wideIs64bit} {
    expr {($max - 2) / $min}
} {-1}
test expr-36.66 {expr edge cases} {wideIs64bit} {
    expr {($max - 2) % $min}
} {-3}
test expr-36.67 {expr edge cases} {wideIs64bit} {
    expr {($max - 3) / $min}
} {-1}
test expr-36.68 {expr edge cases} {wideIs64bit} {
    expr {($max - 3) % $min}
} {-4}
test expr-36.69 {expr edge cases} {wideIs64bit} {
    expr {-3 / $min}
} {0}
test expr-36.70 {expr edge cases} {wideIs64bit} {
    expr {-3 % $min}
} {-3}
test expr-36.71 {expr edge cases} {wideIs64bit} {
    expr {-2 / $min}
} {0}
test expr-36.72 {expr edge cases} {wideIs64bit} {
    expr {-2 % $min}
} {-2}
test expr-36.73 {expr edge cases} {wideIs64bit} {
    expr {-1 / $min}
} {0}
test expr-36.74 {expr edge cases} {wideIs64bit} {
    expr {-1 % $min}
} {-1}
test expr-36.75 {expr edge cases} {wideIs64bit} {
    expr {0 / $min}
} {0}
test expr-36.76 {expr edge cases} {wideIs64bit} {
    expr {0 % $min}
} {0}
test expr-36.77 {expr edge cases} {wideIs64bit} {
    expr {0 / ($min + 1)}
} {0}
test expr-36.78 {expr edge cases} {wideIs64bit} {
    expr {0 % ($min + 1)}
} {0}
test expr-36.79 {expr edge cases} {wideIs64bit} {
    expr {1 / $min}
} {-1}
test expr-36.80 {expr edge cases} {wideIs64bit} {
    expr {1 % $min}
} {-9223372036854775807}
test expr-36.81 {expr edge cases} {wideIs64bit} {
    expr {1 / ($min + 1)}
} {-1}
test expr-36.82 {expr edge cases} {wideIs64bit} {
    expr {1 % ($min + 1)}
} {-9223372036854775806}
test expr-36.83 {expr edge cases} {wideIs64bit} {
    expr {2 / $min}
} {-1}
test expr-36.84 {expr edge cases} {wideIs64bit} {
    expr {2 % $min}
} {-9223372036854775806}
test expr-36.85 {expr edge cases} {wideIs64bit} {
    expr {2 / ($min + 1)}
} {-1}
test expr-36.86 {expr edge cases} {wideIs64bit} {
    expr {2 % ($min + 1)}
} {-9223372036854775805}
test expr-36.87 {expr edge cases} {wideIs64bit} {
    expr {3 / $min}
} {-1}
test expr-36.88 {expr edge cases} {wideIs64bit} {
    expr {3 % $min}
} {-9223372036854775805}
test expr-36.89 {expr edge cases} {wideIs64bit} {
    expr {3 / ($min + 1)}
} {-1}
test expr-36.90 {expr edge cases} {wideIs64bit} {
    expr {3 % ($min + 1)}
} {-9223372036854775804}

test expr-37.1 {expr edge cases} {wideIs64bit} {
    set dividend $max
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($divisor * $q) + $r}]
} {4611686018427387903 * 2 + 1 = 9223372036854775807}
test expr-37.2 {expr edge cases} {wideIs64bit} {
    set dividend [expr {$max - 1}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {4611686018427387903 * 2 + 0 = 9223372036854775806}
test expr-37.3 {expr edge cases} {wideIs64bit} {
    set dividend [expr {$max - 2}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {4611686018427387902 * 2 + 1 = 9223372036854775805}
test expr-37.4 {expr edge cases} {wideIs64bit} {
    set dividend $max
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258602 * 3 + 1 = 9223372036854775807}
test expr-37.5 {expr edge cases} {wideIs64bit} {
    set dividend [expr {$max - 1}]
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258602 * 3 + 0 = 9223372036854775806}
test expr-37.6 {expr edge cases} {wideIs64bit} {
    set dividend [expr {$max - 2}]
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258601 * 3 + 2 = 9223372036854775805}
test expr-37.7 {expr edge cases} {wideIs64bit} {
    set dividend $min
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-4611686018427387904 * 2 + 0 = -9223372036854775808}
test expr-37.8 {expr edge cases} {wideIs64bit} {
    set dividend [expr {$min + 1}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-4611686018427387904 * 2 + 1 = -9223372036854775807}
test expr-37.9 {expr edge cases} {wideIs64bit} {
    set dividend [expr {$min + 2}]
    set divisor 2
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-4611686018427387903 * 2 + 0 = -9223372036854775806}
test expr-37.10 {expr edge cases} {wideIs64bit} {
    # Multiplication overflows 64 bit type here,
    # so when the 1 is added it overflows
    # again and we end up back at min.
    set dividend $min
    set divisor 3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-3074457345618258603 * 3 + 1 = -9223372036854775808}
test expr-37.11 {expr edge cases} {wideIs64bit} {
    set dividend $min
    set divisor -3
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258602 * -3 + -2 = -9223372036854775808}
test expr-37.12 {expr edge cases} {wideIs64bit} {
    set dividend $min
    set divisor $min
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -9223372036854775808 + 0 = -9223372036854775808}
test expr-37.13 {expr edge cases} {wideIs64bit} {
    set dividend $min
    set divisor [expr {$min + 1}]
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -9223372036854775807 + -1 = -9223372036854775808}
test expr-37.14 {expr edge cases} {wideIs64bit} {
    set dividend $min
    set divisor [expr {$min + 2}]
    set q [expr {$dividend / $divisor}]
    set r [expr {$dividend % $divisor}]
    list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -9223372036854775806 + -2 = -9223372036854775808}

test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} {
    expr {abs(-2147483648)}
} 2147483648

testConstraint testexprlongobj   [llength [info commands testexprlongobj]]
testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]]

test expr-39.1 {Check that Tcl_ExprLongObj doesn't modify interpreter result if no error} testexprlongobj {
    testexprlongobj 4+1
} {This is a result: 5}
#Check for [Bug 1109484]
test expr-39.2 {Tcl_ExprLongObj handles wide ints gracefully} testexprlongobj {
    testexprlongobj wide(1)+2
} {This is a result: 3}

test expr-39.3 {Tcl_ExprLongObj on the empty string} \
    -constraints testexprlongobj \
    -body {
	list [catch {testexprlongobj ""} result] $result
    } \
    -match glob \
    -result {1 {syntax error*}}
test expr-39.4 {Tcl_ExprLongObj coerces doubles} testexprlongobj {
    testexprlongobj 3+.14159
} {This is a result: 3}
test expr-39.5 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
    testexprlongobj 0x80000000
} {This is a result: -2147483648}
test expr-39.6 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
    testexprlongobj 0xffffffff
} {This is a result: -1}
test expr-39.7 {Tcl_ExprLongObj handles overflows} \
    -constraints {testexprlongobj longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlongobj 0x100000000} result] $result
    } \
    -result {1 {integer value too large to represent*}}
test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj {
    testexprlongobj -0x80000000
} {This is a result: -2147483648}
test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
    testexprlongobj -0xffffffff
} {This is a result: 1}
test expr-39.10 {Tcl_ExprLongObj handles overflows} \
    -constraints {testexprlongobj longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlongobj -0x100000000} result] $result
    } \
    -result {1 {integer value too large to represent*}}
test expr-39.11 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
    testexprlongobj 2147483648.
} {This is a result: -2147483648}
test expr-39.12 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
    testexprlongobj 4294967295.
} {This is a result: -1}
test expr-39.13 {Tcl_ExprLongObj handles overflows} \
    -constraints {testexprlongobj longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlongobj 4294967296.} result] $result
    } \
    -result {1 {integer value too large to represent*}}
test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj {
    testexprlongobj -2147483648.
} {This is a result: -2147483648}
test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
    testexprlongobj -4294967295.
} {This is a result: 1}
test expr-39.16 {Tcl_ExprLongObj handles overflows} \
    -constraints {testexprlongobj longIs32bit} \
    -match glob \
    -body {
	list [catch {testexprlongobj 4294967296.} result] $result
    } \
    -result {1 {integer value too large to represent*}}
    
test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj {
    testexprdoubleobj 4.+1.
} {This is a result: 5.0}
#Check for [Bug 1109484]
test expr-39.18 {Tcl_ExprDoubleObj on the empty string} \
    -constraints testexprdoubleobj \
    -match glob \
    -body {
	list [catch {testexprdoubleobj ""} result] $result
    } \
    -result {1 {syntax error*}}
test expr-39.19 {Tcl_ExprDoubleObj coerces wides} testexprdoubleobj {
    testexprdoubleobj 1[string repeat 0 17]
} {This is a result: 1e+17}
test expr-39.20 {Tcl_ExprDoubleObj coerces bignums} testexprdoubleobj {
    testexprdoubleobj 1[string repeat 0 38]
} {This is a result: 1e+38}
test expr-39.21 {Tcl_ExprDoubleObj handles overflows} \
    testexprdoubleobj&&ieeeFloatingPoint {
	testexprdoubleobj 17976931348623157[string repeat 0 292].
    } {This is a result: 1.7976931348623157e+308}
test expr-39.22 {Tcl_ExprDoubleObj handles overflows that look like int} \
    testexprdoubleobj&&ieeeFloatingPoint {
	testexprdoubleobj 17976931348623157[string repeat 0 292]
    } {This is a result: 1.7976931348623157e+308}
test expr-39.23 {Tcl_ExprDoubleObj handles overflows} \
    testexprdoubleobj&&ieeeFloatingPoint {
	testexprdoubleobj 17976931348623165[string repeat 0 292].
    } {This is a result: Inf}
test expr-39.24 {Tcl_ExprDoubleObj handles overflows that look like int} \
    testexprdoubleobj&&ieeeFloatingPoint {
	testexprdoubleobj 17976931348623165[string repeat 0 292]
    } {This is a result: Inf}
test expr-39.25 {Tcl_ExprDoubleObj and NaN} \
    testexprdoubleobj&&ieeeFloatingPoint {
	list [catch {testexprdoubleobj 0.0/0.0} result] $result
    } {1 {floating point value is Not a Number}}

test expr-40.1 {large octal shift} {
    expr 0100000000000000000000000000000000
} [expr 0x1000000000000000000000000]
test expr-40.2 {large octal shift} {
    expr 0100000000000000000000000000000001
} [expr 0x1000000000000000000000001]

test expr-41.1 {exponent overflow} {
    expr 1.0e2147483630
} Inf
test expr-41.2 {exponent underflow} {
    expr 1.0e-2147483630
} 0.0

test expr-42.1 {denormals} ieeeFloatingPoint {
    expr 7e-324
} 5e-324

# TIP 114

test expr-43.1 {0b notation} {
    expr 0b0
} 0
test expr-43.2 {0b notation} {
    expr 0b1
} 1
test expr-43.3 {0b notation} {
    expr 0b10
} 2
test expr-43.4 {0b notation} {
    expr 0b11
} 3
test expr-43.5 {0b notation} {
    expr 0b100
} 4
test expr-43.6 {0b notation} {
    expr 0b101
} 5
test expr-43.7 {0b notation} {
    expr 0b1000
} 8
test expr-43.8 {0b notation} {
    expr 0b1001
} 9
test expr-43.9 {0b notation} {
    expr 0b1[string repeat 0 31]
} 2147483648
test expr-43.10 {0b notation} {
    expr 0b1[string repeat 0 30]1
} 2147483649
test expr-43.11 {0b notation} {
    expr 0b[string repeat 1 64]
} 18446744073709551615
test expr-43.12 {0b notation} {
    expr 0b1[string repeat 0 64]
} 18446744073709551616
test expr-43.13 {0b notation} {
    expr 0b1[string repeat 0 63]1
} 18446744073709551617

test expr-44.1 {0o notation} {
    expr 0o0
} 0
test expr-44.2 {0o notation} {
    expr 0o1
} 1
test expr-44.3 {0o notation} {
    expr 0o7
} 7
test expr-44.4 {0o notation} {
    expr 0o10
} 8
test expr-44.5 {0o notation} {
    expr 0o11
} 9
test expr-44.6 {0o notation} {
    expr 0o100
} 64
test expr-44.7 {0o notation} {
    expr 0o101
} 65
test expr-44.8 {0o notation} {
    expr 0o1000
} 512
test expr-44.9 {0o notation} {
    expr 0o1001
} 513
test expr-44.10 {0o notation} {
    expr 0o1[string repeat 7 21]
} 18446744073709551615
test expr-44.11 {0o notation} {
    expr 0o2[string repeat 0 21]
} 18446744073709551616
test expr-44.12 {0o notation} {
    expr 0o2[string repeat 0 20]1
} 18446744073709551617

# TIP 237 again

test expr-45.1 {entier} {
    expr entier(0)
} 0
test expr-45.2 {entier} {
    expr entier(0.5)
} 0
test expr-45.3 {entier} {
    expr entier(1.0)
} 1
test expr-45.4 {entier} {
    expr entier(1.5)
} 1
test expr-45.5 {entier} {
    expr entier(2.0)
} 2
test expr-45.6 {entier} {
    expr entier(1e+22)
} 10000000000000000000000
test expr-45.7 {entier} {
    list [catch {expr entier(Inf)} result] $result
} {1 {integer value too large to represent}}
test expr-45.8 {entier} ieeeFloatingPoint {
    list [catch {expr {entier($ieeeValues(NaN))}} result] $result
} {1 {floating point value is Not a Number}}
test expr-45.9 {entier} ieeeFloatingPoint {
    list [catch {expr {entier($ieeeValues(-NaN))}} result] $result
} {1 {floating point value is Not a Number}}

test expr-46.1 {round() rounds to +-infinity} {
    expr round(0.5)
} 1
test expr-46.2 {round() rounds to +-infinity} {
    expr round(1.5)
} 2
test expr-46.3 {round() rounds to +-infinity} {
    expr round(-0.5)
} -1
test expr-46.4 {round() rounds to +-infinity} {
    expr round(-1.5)
} -2
test expr-46.5 {round() overflow} {
    list [catch {expr round(9.2233720368547758e+018)} result] $result
} {1 {integer value too large to represent}}
test expr-46.6 {round() overflow} {
    list [catch {expr round(-9.2233720368547758e+018)} result] $result
} {1 {integer value too large to represent}}
test expr-46.7 {round() bad value} {
    set x trash
    list [catch {expr {round($x)}} result] $result
} {1 {argument to math function didn't have numeric value}}
test expr-46.8 {round() already an integer} {
    set x 123456789012
    incr x
    expr round($x)
} 123456789013
test expr-46.9 {round() boundary case - 1/2 - 1 ulp} {
    set x 0.25
    set bit 0.125
    while 1 {
	set newx [expr {$x + $bit}]
	if { $newx == $x || $newx == 0.5 } break
	set x $newx
	set bit [expr { $bit / 2.0 }]
    }
    expr {round($x)}
} 0
test expr-46.10 {round() boundary case - 1/2 + 1 ulp} {
    set x 0.75
    set bit 0.125
    while 1 {
	set newx [expr {$x - $bit}]
	if { $newx == $x || $newx == 0.5 } break
	set x $newx
	set bit [expr { $bit / 2.0 }]
    }
    expr {round($x)}
} 1
test expr-46.11 {round() boundary case - -1/2 - 1 ulp} {
    set x -0.75
    set bit 0.125
    while 1 {
	set newx [expr {$x + $bit}]
	if { $newx == $x || $newx == -0.5 } break
	set x $newx
	set bit [expr { $bit / 2.0 }]
    }
    expr {round($x)}
} -1
test expr-46.12 {round() boundary case - -1/2 + 1 ulp} {
    set x -0.25
    set bit 0.125
    while 1 {
	set newx [expr {$x - $bit}]
	if { $newx == $x || $newx == -0.5 } break
	set x $newx
	set bit [expr { $bit / 2.0 }]
    }
    expr {round($x)}
} 0

# cleanup
if {[info exists a]} {
    unset a
}
catch {unset min}
catch {unset max}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/fCmd.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.44 2004/11/11 01:14:29 das Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.44.2.2 2005/10/08 13:44:38 dgp Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}
test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}







|







1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}
test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \
	{notRoot notNetworkFilesystem} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
    set result
} {1}

test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} \
	{unix notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    for {set i 1} {$i <= 200} {incr i} {createfile tfa/testfile_$i}
    set result [catch {file delete -force tfa} msg]
    while {[catch {file delete -force tfa}]} {}
    list $result $msg
} {0 {}}

#
# Feature testing for TclCopyFilesCmd







|







1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
    set result
} {1}

test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} \
	{unix notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    for {set i 1} {$i <= 300} {incr i} {createfile tfa/testfile_$i}
    set result [catch {file delete -force tfa} msg]
    while {[catch {file delete -force tfa}]} {}
    list $result $msg
} {0 {}}

#
# Feature testing for TclCopyFilesCmd

Changes to tests/fileName.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.45 2004/11/11 01:16:05 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.45.2.2 2005/08/02 18:16:40 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
    list [catch {testtranslatefilename foo//bar} msg] $msg
} {0 {foo\bar}}

if {[testConstraint testsetplatform]} {
    testsetplatform $platform
}

test filename-10.23 {Tcl_TranslateFileName} {unix nonPortable} {
    # this test fails if ~ouster is not /home/ouster
    list [catch {testtranslatefilename ~ouster} msg] $msg
} {0 /home/ouster}
test filename-10.24 {Tcl_TranslateFileName} {unix nonPortable} {
    # this test fails if ~ouster is not /home/ouster
    list [catch {testtranslatefilename ~ouster/foo} msg] $msg
} {0 /home/ouster/foo}


test filename-11.1 {Tcl_GlobCmd} {
    list [catch {glob} msg] $msg







|



|







662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
    list [catch {testtranslatefilename foo//bar} msg] $msg
} {0 {foo\bar}}

if {[testConstraint testsetplatform]} {
    testsetplatform $platform
}

test filename-10.23 {Tcl_TranslateFileName} {nonPortable} {
    # this test fails if ~ouster is not /home/ouster
    list [catch {testtranslatefilename ~ouster} msg] $msg
} {0 /home/ouster}
test filename-10.24 {Tcl_TranslateFileName} {nonPortable} {
    # this test fails if ~ouster is not /home/ouster
    list [catch {testtranslatefilename ~ouster/foo} msg] $msg
} {0 /home/ouster/foo}


test filename-11.1 {Tcl_GlobCmd} {
    list [catch {glob} msg] $msg
1514
1515
1516
1517
1518
1519
1520







1521
1522
1523
1524
1525
1526
1527
    set res [glob -nocomplain -dir [temporaryDirectory]/execglob \
      -tails -types x *]
    removeFile execglob/abc.exe
    removeFile execglob/abc.notexecutable
    removeDirectory execglob
    set res
} {abc.exe}








# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome







>
>
>
>
>
>
>







1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
    set res [glob -nocomplain -dir [temporaryDirectory]/execglob \
      -tails -types x *]
    removeFile execglob/abc.exe
    removeFile execglob/abc.notexecutable
    removeDirectory execglob
    set res
} {abc.exe}

test fileName-18.1 {windows - split ADS name correctly} {win} {
    # bug 1194458
    set x [file split c:/c:d]
    set y [eval [linsert $x 0 file join]]
    list $x $y
} {{c:/ ./c:d} c:/c:d}

# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome

Changes to tests/fileSystem.test.

909
910
911
912
913
914
915
916
917
918
919
920
921
922



















































923
924
925
926
927
928
	set absolute [file join [pwd] $relative]
	set res [list [file tail $absolute] "test"]
    }
    file delete -force dgp 
    cd $origdir
    set res
} {test test}
test filesystem-9.6 {path objects and file tail and object rep} {winOnly} {
    set res {}
    set p "C:\\toto"
    lappend res [file join $p toto]
    file isdirectory $p
    lappend res [file join $p toto]
} {C:/toto/toto C:/toto/toto}




















































cleanupTests
unset -nocomplain drive
}
namespace delete ::tcl::test::fileSystem
return







|






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
	set absolute [file join [pwd] $relative]
	set res [list [file tail $absolute] "test"]
    }
    file delete -force dgp 
    cd $origdir
    set res
} {test test}
test filesystem-9.6 {path objects and file tail and object rep} win {
    set res {}
    set p "C:\\toto"
    lappend res [file join $p toto]
    file isdirectory $p
    lappend res [file join $p toto]
} {C:/toto/toto C:/toto/toto}
test filesystem-9.7 {path objects and glob and file tail and tilde} {
    set res {}
    set origdir [pwd]
    cd [tcltest::temporaryDirectory]
    file mkdir tilde
    close [open tilde/~testNotExist w]
    cd tilde
    set file [lindex [glob *test*] 0]
    lappend res [file exists $file] [catch {file tail $file} r] $r
    lappend res $file
    lappend res [file exists $file] [catch {file tail $file} r] $r
    lappend res [catch {file tail $file} r] $r
    cd ..
    file delete -force tilde
    cd $origdir
    set res
} {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
test filesystem-9.8 {path objects and glob and file tail and tilde} {
    set res {}
    set origdir [pwd]
    cd [tcltest::temporaryDirectory]
    file mkdir tilde
    close [open tilde/~testNotExist w]
    cd tilde
    set file1 [lindex [glob *test*] 0]
    set file2 "~testNotExist"
    lappend res $file1 $file2
    lappend res [catch {file tail $file1} r] $r
    lappend res [catch {file tail $file2} r] $r
    cd ..
    file delete -force tilde
    cd $origdir
    set res
} {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
test filesystem-9.9 {path objects and glob and file tail and tilde} {
    set res {}
    set origdir [pwd]
    cd [tcltest::temporaryDirectory]
    file mkdir tilde
    close [open tilde/~testNotExist w]
    cd tilde
    set file1 [lindex [glob *test*] 0]
    set file2 "~testNotExist"
    lappend res [catch {file exists $file1} r] $r
    lappend res [catch {file exists $file2} r] $r
    lappend res [string equal $file1 $file2]
    cd ..
    file delete -force tilde
    cd $origdir
    set res
} {0 0 0 0 1}

cleanupTests
unset -nocomplain drive
}
namespace delete ::tcl::test::fileSystem
return

Changes to tests/for.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Commands covered:  for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.10 2004/09/26 16:36:06 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "for" operation.











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Commands covered:  for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.10.2.2 2005/07/12 20:37:09 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "for" operation.
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
    list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" initial command)
    invoked from within
"$z {set} {$i < 5} {incr i} {body}"}}
test for-6.7 {Tcl_ForObjCmd: error in test expression} {
    set z for
    list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo
} {1 {syntax error in expression "i < 5": variable references require preceding $} {syntax error in expression "i < 5": variable references require preceding $
    while executing
"$z {set i 0} {i < 5} {incr i} {body}"}}
test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
    set z for
    set i 0
    $z {set i 6} "$i > 5" {incr i} {set y $i}
    set i







|


|







655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
    list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" initial command)
    invoked from within
"$z {set} {$i < 5} {incr i} {body}"}}
test for-6.7 {Tcl_ForObjCmd: error in test expression} -match glob -body {
    set z for
    list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo
} -result {1 {syntax error in expression "i < 5": * preceding $*} {syntax error in expression "i < 5": * preceding $*
    while executing
"$z {set i 0} {i < 5} {incr i} {body}"}}
test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
    set z for
    set i 0
    $z {set i 6} "$i > 5" {incr i} {set y $i}
    set i
759
760
761
762
763
764
765















766



767


768





























769
770
771
    set a
} {}
test for-6.16 {Tcl_ForObjCmd: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}




















































# cleanup
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
    set a
} {}
test for-6.16 {Tcl_ForObjCmd: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}
test for-6.17 {Tcl_ForObjCmd: for command result} {
    list \
        [catch {for {break} {1} {} {}} err] $err \
        [catch {for {continue} {1} {} {}} err] $err \
        [catch {for {} {[break]} {} {}} err] $err \
        [catch {for {} {[continue]} {} {}} err] $err \
        [catch {for {} {1} {break} {}} err] $err \
        [catch {for {} {1} {continue} {}} err] $err \
} [list \
    3 {} \
    4 {} \
    3 {} \
    4 {} \
    0 {} \
    4 {} \
    ]
test for-6.18 {Tcl_ForObjCmd: for command result} {
    proc p6181 {} {
        for {break} {1} {} {}
    }
    proc p6182 {} {
        for {continue} {1} {} {}
    }
    proc p6183 {} {
        for {} {[break]} {} {}
    }
    proc p6184 {} {
        for {} {[continue]} {} {}
    }
    proc p6185 {} {
        for {} {1} {break} {}
    }
    proc p6186 {} {
        for {} {1} {continue} {}
    }
    list \
        [catch {p6181} err] $err \
        [catch {p6182} err] $err \
        [catch {p6183} err] $err \
        [catch {p6184} err] $err \
        [catch {p6185} err] $err \
        [catch {p6186} err] $err
} [list \
    1 {invoked "break" outside of a loop} \
    1 {invoked "continue" outside of a loop} \
    1 {invoked "break" outside of a loop} \
    1 {invoked "continue" outside of a loop} \
    0 {} \
    1 {invoked "continue" outside of a loop} \
    ]


# cleanup
::tcltest::cleanupTests
return

Changes to tests/format.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34


35
36
37
38



39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54



55
56
57



58
59
60



61
62
63



64
65
66



67
68
69
70
71
72
73
# Commands covered:  format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.19 2004/10/27 17:56:22 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).

testConstraint roundOffBug [expr {"[format %7.1e  68.514]" != "6.8e+01"}]

test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {nonPortable} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} {   6   34 16923  -12 -1 0xe 0XC}

# %u output depends on word length, so this test is not portable.



test format-1.3 {integer formatting} {nonPortable} {
    format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} {   6   34 16923 4294967284 -1 0}



test format-1.4 {integer formatting} {
    format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6    34   16923 -12 }
test format-1.5 {integer formatting} {
    format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
    format "%00*d" 6 34
} {000034}

# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.

test format-1.7 {integer formatting} {nonPortable} {
    format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} {   6   22 421b fffffff4}



test format-1.8 {integer formatting} {nonPortable} {
    format "%#x %#X %#X %#x" 6 34 16923 -12 -1
} {0x6 0X22 0X421B 0xfffffff4}



test format-1.9 {integer formatting} {nonPortable} {
    format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
} {                 0x6                 0x22               0x421b           0xfffffff4}



test format-1.10 {integer formatting} {nonPortable} {
    format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
} {0x6                  0x22                 0x421b               0xfffffff4          }



test format-1.11 {integer formatting} {nonPortable} {
    format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
} {06                   042                  041033               037777777764        }




test format-2.1 {string formatting} {
    format "%s %s %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. x x}
test format-2.2 {string formatting} {
    format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
} {                abcd This is a very long test string.                    x                    x}












|






<
<
<
<
<
<
<



|




>
>

|


>
>
>













|


>
>
>
|


>
>
>
|


>
>
>
|


>
>
>
|


>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
# Commands covered:  format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.19.2.3 2005/08/22 12:55:10 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}








test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} {   6   34 16923  -12 -1 0xe 0XC}

# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]

test format-1.3 {integer formatting} longIs32bit {
    format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} {   6   34 16923 4294967284 -1 0}
test format-1.3.1 {integer formatting} longIs64bit {
    format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} {   6   34 16923 18446744073709551604 -1 0}
test format-1.4 {integer formatting} {
    format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6    34   16923 -12 }
test format-1.5 {integer formatting} {
    format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
    format "%00*d" 6 34
} {000034}

# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.

test format-1.7 {integer formatting} longIs32bit {
    format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} {   6   22 421b fffffff4}
test format-1.7.1 {integer formatting} longIs64bit {
    format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} {   6   22 421b fffffffffffffff4}
test format-1.8 {integer formatting} longIs32bit {
    format "%#x %#X %#X %#x" 6 34 16923 -12 -1
} {0x6 0X22 0X421B 0xfffffff4}
test format-1.8.1 {integer formatting} longIs64bit {
    format "%#x %#X %#X %#x" 6 34 16923 -12 -1
} {0x6 0X22 0X421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} longIs32bit {
    format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
} {                 0x6                 0x22               0x421b           0xfffffff4}
test format-1.9.1 {integer formatting} longIs64bit {
    format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
} {                 0x6                 0x22               0x421b   0xfffffffffffffff4}
test format-1.10 {integer formatting} longIs32bit {
    format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
} {0x6                  0x22                 0x421b               0xfffffff4          }
test format-1.10.1 {integer formatting} longIs64bit {
    format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
} {0x6                  0x22                 0x421b               0xfffffffffffffff4  }
test format-1.11 {integer formatting} longIs32bit {
    format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
} {06                   042                  041033               037777777764        }
test format-1.11.1 {integer formatting} longIs64bit {
    format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
} {06                   042                  041033               01777777777777777777764}

test format-2.1 {string formatting} {
    format "%s %s %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. x x}
test format-2.2 {string formatting} {
    format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
} {                abcd This is a very long test string.                    x                    x}
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152

test format-4.1 {e and f formats} {eformat} {
    format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
test format-4.2 {e and f formats} {eformat} {
    format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
} {        3.420000e+13         6.851400e+01        -1.250000e-01        -1.600000e+04}
test format-4.3 {e and f formats} {eformat roundOffBug} {
    format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
test format-4.4 {e and f formats} {eformat roundOffBug} {
    format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
} {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
test format-4.5 {e and f formats} {eformat roundOffBug} {
    format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
test format-4.6 {e and f formats roundOffBug} {
    format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.000000 68.514000 -0.125000 -16000.000000}
test format-4.7 {e and f formats} {nonPortable} {
    format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
test format-4.8 {e and f formats} {eformat} {
    format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
} {-1.0000e+01 -9.99996e+00 9.999960e+00}
test format-4.9 {e and f formats} {
    format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996







|


|


|


|


|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

test format-4.1 {e and f formats} {eformat} {
    format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
test format-4.2 {e and f formats} {eformat} {
    format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
} {        3.420000e+13         6.851400e+01        -1.250000e-01        -1.600000e+04}
test format-4.3 {e and f formats} {eformat} {
    format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
test format-4.4 {e and f formats} {eformat} {
    format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
} {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
test format-4.5 {e and f formats} {eformat} {
    format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
test format-4.6 {e and f formats} {
    format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.000000 68.514000 -0.125000 -16000.000000}
test format-4.7 {e and f formats} {
    format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
test format-4.8 {e and f formats} {eformat} {
    format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
} {-1.0000e+01 -9.99996e+00 9.999960e+00}
test format-4.9 {e and f formats} {
    format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366




367
368
369
370
371
372
373
} {expected integer but got "xyz"}

test format-9.1 {long result} {
    set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
    format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a
} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}

test format-10.1 {"h" format specifier} {nonPortable} {
    format %hd 0xffff
} -1
test format-10.2 {"h" format specifier} {nonPortable} {
    format %hx 0x10fff
} fff
test format-10.3 {"h" format specifier} {nonPortable} {
    format %hd 0x10000
} 0





test format-11.1 {XPG3 %$n specifiers} {
    format {%2$d %1$d} 4 5
} {5 4}
test format-11.2 {XPG3 %$n specifiers} {
    format {%2$d %1$d %1$d %3$d} 4 5 6
} {5 4 4 6}







|


|


|


>
>
>
>







364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
} {expected integer but got "xyz"}

test format-9.1 {long result} {
    set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
    format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a
} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}

test format-10.1 {"h" format specifier} {
    format %hd 0xffff
} -1
test format-10.2 {"h" format specifier} {
    format %hx 0x10fff
} fff
test format-10.3 {"h" format specifier} {
    format %hd 0x10000
} 0
test format-10.4 {"h" format specifier} {
    # Bug 1154163: This is minimal behaviour for %hx specifier!
    format %hx 1
} 1

test format-11.1 {XPG3 %$n specifiers} {
    format {%2$d %1$d} 4 5
} {5 4}
test format-11.2 {XPG3 %$n specifiers} {
    format {%2$d %1$d %1$d %3$d} 4 5 6
} {5 4 4 6}
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
        format {%s} $b    
    } $b
    append b "x"
}

::tcltest::testConstraint 64bitInts \
	[expr {0x80000000 > 0}]
::tcltest::testConstraint wideIntExpressions \
	[expr {wide(0x80000000) != int(0x80000000)}]

test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
    list [catch {format %d 7810179016327718216} msg] $msg
} {1 {integer value too large to represent}}
test format-17.2 {testing %ld with wide} {64bitInts} {
    format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {64bitInts} {
    format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
    format %lf 1
} 1.000000

test format-18.1 {do not demote existing numeric values} {







|
|
|


|


|


|







499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
        format {%s} $b    
    } $b
    append b "x"
}

::tcltest::testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
::tcltest::testConstraint wideBiggerThanInt \
	[expr {wide(0x80000000) != int(0x80000000)}]

test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} {
    list [catch {format %d 7810179016327718216} msg] $msg
} {1 {integer value too large to represent}}
test format-17.2 {testing %ld with wide} {wideIs64bit} {
    format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
    format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
    format %lf 1
} 1.000000

test format-18.1 {do not demote existing numeric values} {
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
    set b 0xaaaa
    append b aaaa

    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideIntExpressions} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [catch {format %08x $a} msg] $msg [expr {$a == $b}]
} {1 {integer value too large to represent} 1}

test format-19.1 {
    regression test - tcl-core message by Brian Griffin on







|







534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
    set b 0xaaaa
    append b aaaa

    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [catch {format %08x $a} msg] $msg [expr {$a == $b}]
} {1 {integer value too large to represent} 1}

test format-19.1 {
    regression test - tcl-core message by Brian Griffin on

Changes to tests/get.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
# Commands covered:  none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: get.test,v 1.9 2004/05/19 10:38:24 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testgetint [llength [info commands testgetint]]
testConstraint intsAre64bit [expr {int(0x80000000) > 0}]


test get-1.1 {Tcl_GetInt procedure} testgetint {
    testgetint 44 { 	  22}
} {66}
test get-1.2 {Tcl_GetInt procedure} testgetint {
    testgetint 44 -3
} {41}
test get-1.3 {Tcl_GetInt procedure} testgetint {
    testgetint 44 +8
} {52}
test get-1.4 {Tcl_GetInt procedure} testgetint {
    list [catch {testgetint 44 foo} msg] $msg
} {1 {expected integer but got "foo"}}
test get-1.5 {Tcl_GetInt procedure} testgetint {
    list [catch {testgetint 44 {16	 }} msg] $msg
} {0 60}
test get-1.6 {Tcl_GetInt procedure} testgetint {
    list [catch {testgetint 44 {16	 x}} msg] $msg
} {1 {expected integer but got "16	 x"}}
test get-1.7 {Tcl_GetInt procedure} {testgetint intsAre64bit} {
    list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint intsAre64bit} {
    list [catch {testgetint 18446744073709551614} msg] $msg
} {0 -2}
test get-1.9 {Tcl_GetInt procedure} {testgetint intsAre64bit} {
    list [catch {testgetint +18446744073709551614} msg] $msg
} {0 -2}
test get-1.10 {Tcl_GetInt procedure} {testgetint intsAre64bit} {
    list [catch {testgetint -18446744073709551614} msg] $msg
} {0 2}
test get-1.11 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} {
    list [catch {testgetint 44 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.12 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} {
    list [catch {testgetint 4294967294} msg] $msg
} {0 -2}
test get-1.13 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} {
    list [catch {testgetint +4294967294} msg] $msg
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} {
    list [catch {testgetint -4294967294} msg] $msg
} {0 2}

test get-2.1 {Tcl_GetInt procedure} {
    format %g 1.23
} {1.23}
test get-2.2 {Tcl_GetInt procedure} {
    format %g { 	 1.23 	}
} {1.23}
test get-2.3 {Tcl_GetInt procedure} {
    list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
    list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}

test get-3.1 {Tcl_GetInt(FromObj), bad numbers} {
    # SF bug #634856
    set result ""
    set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"]
    foreach num $numbers {
	lappend result [catch {format %ld $num} msg] $msg












|







|
>



















|


|


|


|


|


|


|


|












|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
# Commands covered:  none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: get.test,v 1.9.2.2 2005/08/15 18:14:01 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]

test get-1.1 {Tcl_GetInt procedure} testgetint {
    testgetint 44 { 	  22}
} {66}
test get-1.2 {Tcl_GetInt procedure} testgetint {
    testgetint 44 -3
} {41}
test get-1.3 {Tcl_GetInt procedure} testgetint {
    testgetint 44 +8
} {52}
test get-1.4 {Tcl_GetInt procedure} testgetint {
    list [catch {testgetint 44 foo} msg] $msg
} {1 {expected integer but got "foo"}}
test get-1.5 {Tcl_GetInt procedure} testgetint {
    list [catch {testgetint 44 {16	 }} msg] $msg
} {0 60}
test get-1.6 {Tcl_GetInt procedure} testgetint {
    list [catch {testgetint 44 {16	 x}} msg] $msg
} {1 {expected integer but got "16	 x"}}
test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} {
    list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
    list [catch {testgetint 18446744073709551614} msg] $msg
} {0 -2}
test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} {
    list [catch {testgetint +18446744073709551614} msg] $msg
} {0 -2}
test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} {
    list [catch {testgetint -18446744073709551614} msg] $msg
} {0 2}
test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} {
    list [catch {testgetint 44 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} {
    list [catch {testgetint 4294967294} msg] $msg
} {0 -2}
test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} {
    list [catch {testgetint +4294967294} msg] $msg
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} {
    list [catch {testgetint -4294967294} msg] $msg
} {0 2}

test get-2.1 {Tcl_GetInt procedure} {
    format %g 1.23
} {1.23}
test get-2.2 {Tcl_GetInt procedure} {
    format %g { 	 1.23 	}
} {1.23}
test get-2.3 {Tcl_GetInt procedure} {
    list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {
    format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
} 0

test get-3.1 {Tcl_GetInt(FromObj), bad numbers} {
    # SF bug #634856
    set result ""
    set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"]
    foreach num $numbers {
	lappend result [catch {format %ld $num} msg] $msg

Changes to tests/http.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.38 2004/05/25 22:56:33 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {package require http 2} version]} {







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.38.2.1 2005/10/08 13:44:39 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {package require http 2} version]} {
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501

test http-5.3 {http::formatQuery} {
    http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test http-5.4 {http::formatQuery} {
    http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%c2%a1%c2%a2%c2%a2}

test http-5.5 {http::formatQuery} {
    set enc [http::config -urlencoding]
    http::config -urlencoding iso8859-1
    set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
    http::config -urlencoding $enc
    set res
} {name1=%7ebwelch&name2=%a1%a2%a2}

test http-6.1 {http::ProxyRequired} {
    http::config -proxyhost [info hostname] -proxyport $port
    set token [http::geturl $url]
    http::wait $token
    http::config -proxyhost {} -proxyport {}
    upvar #0 $token data







|







|







479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501

test http-5.3 {http::formatQuery} {
    http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test http-5.4 {http::formatQuery} {
    http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2}

test http-5.5 {http::formatQuery} {
    set enc [http::config -urlencoding]
    http::config -urlencoding iso8859-1
    set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
    http::config -urlencoding $enc
    set res
} {name1=~bwelch&name2=%a1%a2%a2}

test http-6.1 {http::ProxyRequired} {
    http::config -proxyhost [info hostname] -proxyport $port
    set token [http::geturl $url]
    http::wait $token
    http::config -proxyhost {} -proxyport {}
    upvar #0 $token data

Changes to tests/info.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# Commands covered:  info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.29 2004/11/24 19:28:42 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.

catch {namespace delete test_ns_info1 test_ns_info2}













|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# Commands covered:  info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.29.2.3 2005/10/08 13:44:39 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.

catch {namespace delete test_ns_info1 test_ns_info2}
147
148
149
150
151
152
153

154
155
156
157
158
159
160
    lsort [info commands _t*]
} {_t1_ _t2_}
catch {rename _t1_ {}}
catch {rename _t2_ {}}
test info-4.5 {info commands option} {
    list [catch {info commands a b} msg] $msg
} {1 {wrong # args: should be "info commands ?pattern?"}}


test info-5.1 {info complete option} {
    list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
    info complete abc
} 1







>







147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
    lsort [info commands _t*]
} {_t1_ _t2_}
catch {rename _t1_ {}}
catch {rename _t2_ {}}
test info-4.5 {info commands option} {
    list [catch {info commands a b} msg] $msg
} {1 {wrong # args: should be "info commands ?pattern?"}}
# Also some tests in namespace.test

test info-5.1 {info complete option} {
    list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
    info complete abc
} 1
287
288
289
290
291
292
293













294
295
296
297
298
299
300
test info-8.3 {info globals option} {
    list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}
test info-8.4 {info globals option: may have leading namespace qualifiers} {
    set x 0
    list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
} {x {} x x x}














test info-9.1 {info level option} {
    info level
} 0
test info-9.2 {info level option} {
    proc t1 {a b} {
        set x [info le]







>
>
>
>
>
>
>
>
>
>
>
>
>







288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
test info-8.3 {info globals option} {
    list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}
test info-8.4 {info globals option: may have leading namespace qualifiers} {
    set x 0
    list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
} {x {} x x x}
test info-8.5 {info globals option: only return existing global variables} {
    -setup {
	catch {unset ::NO_SUCH_VAR}
	proc evalInProc script {eval $script}
    }
    -body {
	evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
    }
    -cleanup {
	rename evalInProc {}
    }
    -result {}
}

test info-9.1 {info level option} {
    info level
} 0
test info-9.2 {info level option} {
    proc t1 {a b} {
        set x [info le]
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
    namespace eval x info vars foo
} -cleanup {
    namespace delete x
} -result {}

# Check whether the extra testing functions are defined...
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
} else {
    set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
}
test info-20.1 {info functions option} {info functions sin} sin
test info-20.2 {info functions option} {lsort [info functions]} $functions
test info-20.3 {info functions option} {
    lsort [info functions a*]
} {abs acos asin atan atan2}
test info-20.4 {info functions option} {







|

|







623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
    namespace eval x info vars foo
} -cleanup {
    namespace delete x
} -result {}

# Check whether the extra testing functions are defined...
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set functions {abs acos asin atan atan2 bool ceil cos cosh double exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
} else {
    set functions {T1 T2 T3 abs acos asin atan atan2 bool ceil cos cosh double exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
}
test info-20.1 {info functions option} {info functions sin} sin
test info-20.2 {info functions option} {lsort [info functions]} $functions
test info-20.3 {info functions option} {
    lsort [info functions a*]
} {abs acos asin atan atan2}
test info-20.4 {info functions option} {

Changes to tests/init.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Functionality covered: this file contains a collection of tests for the
# auto loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: init.test,v 1.13 2004/10/26 16:46:16 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Functionality covered: this file contains a collection of tests for the
# auto loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: init.test,v 1.13.2.1 2005/07/12 20:37:11 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
191
192
193
194
195
196
197













198
199
200
201
202
203
204
205
206
	catch {parray ::junk::$arg}
	set second $::errorInfo
	string equal $first $second
    } 1

    incr count
}














cleanupTests
}	;#  End of [interp eval $testInterp]

# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return








>
>
>
>
>
>
>
>
>
>
>
>
>









191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
	catch {parray ::junk::$arg}
	set second $::errorInfo
	string equal $first $second
    } 1

    incr count
}

test init-5.0 {return options passed through ::unknown} -setup {
    catch {rename xxx {}}
    set ::auto_index(::xxx) {proc ::xxx {} {
	return -code error -level 2 xxx
    }}
} -body {
    set code [catch {::xxx} foo bar]
    set code2 [catch {::xxx} foo2 bar2]
    list $code $foo $bar $code2 $foo2 $bar2
} -cleanup {
    unset ::auto_index(::xxx)
} -result {2 xxx {-code 1 -level 1} 2 xxx {-code 1 -level 1}}

cleanupTests
}	;#  End of [interp eval $testInterp]

# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return

Changes to tests/interp.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.43 2004/11/18 21:00:51 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testinterpdelete [llength [info commands testinterpdelete]]












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.43.2.2 2005/07/12 20:37:11 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testinterpdelete [llength [info commands testinterpdelete]]
3071
3072
3073
3074
3075
3076
3077






































3078
3079
3080
3081
3082
3083
3084
	}
    }
    list $n [interp exists $i]
} -result {4 0} -cleanup {
    rename cb3 {}
    rename cb4 {}
}







































test interp-35.1 {interp limit syntax} -body {
    interp limit
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"}
test interp-35.2 {interp limit syntax} -body {
    interp limit {}
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
	}
    }
    list $n [interp exists $i]
} -result {4 0} -cleanup {
    rename cb3 {}
    rename cb4 {}
}
# Bug 1085023
test interp-34.8 {time limits trigger in vwaits} -body {
    set i [interp create]
    interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1
    $i eval {
	set x {}
	vwait x
    }
} -cleanup {
    interp delete $i
} -returnCodes error -result {limit exceeded}
test interp-34.9 {time limits trigger in blocking after} {
    set i [interp create]
    set t0 [clock seconds]
    interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1
    set code [catch {
	$i eval {after 10000}
    } msg]
    set t1 [clock seconds]
    interp delete $i
    list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] 
} {1 {time limit exceeded} OK}
test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body {
    set i [interp create]
    # Assume someone hasn't set the clock to early 1970!
    $i limit time -seconds 1 -granularity 4
    interp alias $i log {} lappend result
    set result {}
    catch {
	$i eval {
	    log 1
	    after 100
	    log 2
	}
    } msg
    interp delete $i
    lappend result $msg
} -result {1 {time limit exceeded}}

test interp-35.1 {interp limit syntax} -body {
    interp limit
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"}
test interp-35.2 {interp limit syntax} -body {
    interp limit {}
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"}

Changes to tests/io.test.


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.65 2004/11/18 19:22:12 dgp Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::io {

    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::interpreter
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::viewFile

testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
>














|















|
|
|
|
|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.65.2.3 2005/08/25 15:46:53 dgp Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::io {

    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::interpreter
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::viewFile

testConstraint testchannel      [llength [info commands testchannel]]
testConstraint exec             [llength [info commands exec]]
testConstraint openpipe         1
testConstraint fileevent        [llength [info commands fileevent]]
testConstraint fcopy            [llength [info commands fcopy]]
testConstraint testfevent       [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread   [llength [info commands testmainthread]]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
1700
1701
1702
1703
1704
1705
1706






1707
1708
1709
1710
1711
1712
1713
	set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
	puts [gets $f]
    }
    close $f
    set f [open "|[list [interpreter] $path(script) [array get path]]" r]
    set c [gets $f]
    close $f






    set c
} hello

test io-15.1 {Tcl_CreateCloseHandler} emptyTest {
} {}

test io-16.1 {Tcl_DeleteCloseHandler} emptyTest {







>
>
>
>
>
>







1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
	set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
	puts [gets $f]
    }
    close $f
    set f [open "|[list [interpreter] $path(script) [array get path]]" r]
    set c [gets $f]
    close $f
    # Added delay to give Windows time to stop the spawned process and clean
    # up its grip on the file test1. Added delete as proper test cleanup.
    # The failing tests were 18.1 and 18.2 as first re-users of file "test1".
    after 10000
    file delete $path(script)
    file delete $path(test1)
    set c
} hello

test io-15.1 {Tcl_CreateCloseHandler} emptyTest {
} {}

test io-16.1 {Tcl_DeleteCloseHandler} emptyTest {
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 100000
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 10000000
    lappend l [fconfigure $f -buffersize]
    close $f
    set l
} {4096 10000 10000 10000 10000 100000 100000}
test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
    # This test crashes the interp if Bug #427196 is not fixed

    set chan [open [info script] r]
    fconfigure $chan -buffersize 10
    set var [read $chan 2]
    fconfigure $chan -buffersize 32







|







4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 100000
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 10000000
    lappend l [fconfigure $f -buffersize]
    close $f
    set l
} {4096 10000 1 1 1 100000 100000}
test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
    # This test crashes the interp if Bug #427196 is not fixed

    set chan [open [info script] r]
    fconfigure $chan -buffersize 10
    set var [read $chan 2]
    fconfigure $chan -buffersize 32
7101
7102
7103
7104
7105
7106
7107




































































































































































































































































7108
7109
7110
7111
7112
7113
7114
7115
7116
    #lappend res [read $f; tell $f]
    close $f
    set res
} -cleanup {
    removeFile eofchar
} -result {77 = 23431}





































































































































































































































































# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
    #lappend res [read $f; tell $f]
    close $f
    set res
} -cleanup {
    removeFile eofchar
} -result {77 = 23431}


# Test the cutting and splicing of channels, this is incidentially the
# attach/detach facility of package Thread, but __without any
# safeguards__. It can also be used to emulate transfer of channels
# between threads, and is used for that here.

test io-70.0 {Cutting & Splicing channels} {testchannel} {
    set f [makeFile {... dummy ...} cutsplice]
    set c [open $f r]

    set     res {}
    lappend res [catch {seek $c 0 start}]
    testchannel cut $c

    lappend res [catch {seek $c 0 start}]
    testchannel splice $c

    lappend res [catch {seek $c 0 start}]
    close $c

    removeFile cutsplice

    set res
} {0 1 0}


# Duplicate of code in "thread.test". Find a better way of doing this
# without duplication. Maybe placement into a proc which transforms to
# nop after the first call, and placement of its defintion in a
# central location.

testConstraint testthread [expr {[info commands testthread] != {}}]

if {[testConstraint testthread]} {
    testthread errorproc ThreadError

    proc ThreadError {id info} {
	global threadError
	set threadError $info
    }

    proc ThreadNullError {id info} {
	# ignore
    }
}

test io-70.1 {Transfer channel} {testchannel testthread} {
    set f [makeFile {... dummy ...} cutsplice]
    set c [open $f r]

    set     res {}
    lappend res [catch {seek $c 0 start}]
    testchannel cut $c
    lappend res [catch {seek $c 0 start}]

    set tid [testthread create]
    testthread send $tid [list set c $c]
    lappend res [testthread send $tid {
	testchannel splice $c
	set res [catch {seek $c 0 start}]
	close $c
	set res
    }]

    tcltest::threadReap
    removeFile cutsplice

    set res
} {0 1 0}

# ### ### ### ######### ######### #########

foreach {n msg expected} {
     0 {}                                 {}
     1 {{message only}}                   {{message only}}
     2 {-options x}                       {-options x}
     3 {-options {x y} {the message}}     {-options {x y} {the message}}

     4 {-code 1     -level 0 -f ba snarf} {-code 1     -level 0 -f ba snarf}
     5 {-code 0     -level 0 -f ba snarf} {-code 1     -level 0 -f ba snarf}
     6 {-code 1     -level 5 -f ba snarf} {-code 1     -level 0 -f ba snarf}
     7 {-code 0     -level 5 -f ba snarf} {-code 1     -level 0 -f ba snarf}
     8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf}
     9 {-code ok    -level 0 -f ba snarf} {-code 1     -level 0 -f ba snarf}
    10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf}
    11 {-code ok    -level 5 -f ba snarf} {-code 1     -level 0 -f ba snarf}
    12 {-code boss  -level 0 -f ba snarf} {-code 1     -level 0 -f ba snarf}
    13 {-code boss  -level 5 -f ba snarf} {-code 1     -level 0 -f ba snarf}
    14 {-code 1     -level 0 -f ba}       {-code 1     -level 0 -f ba}
    15 {-code 0     -level 0 -f ba}       {-code 1     -level 0 -f ba}
    16 {-code 1     -level 5 -f ba}       {-code 1     -level 0 -f ba}
    17 {-code 0     -level 5 -f ba}       {-code 1     -level 0 -f ba}
    18 {-code error -level 0 -f ba}       {-code error -level 0 -f ba}
    19 {-code ok    -level 0 -f ba}       {-code 1     -level 0 -f ba}
    20 {-code error -level 5 -f ba}       {-code error -level 0 -f ba}
    21 {-code ok    -level 5 -f ba}       {-code 1     -level 0 -f ba}
    22 {-code boss  -level 0 -f ba}       {-code 1     -level 0 -f ba}
    23 {-code boss  -level 5 -f ba}       {-code 1     -level 0 -f ba}
    24 {-code 1     -level X -f ba snarf} {-code 1     -level 0 -f ba snarf}
    25 {-code 0     -level X -f ba snarf} {-code 1     -level 0 -f ba snarf}
    26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf}
    27 {-code ok    -level X -f ba snarf} {-code 1     -level 0 -f ba snarf}
    28 {-code boss  -level X -f ba snarf} {-code 1     -level 0 -f ba snarf}
    29 {-code 1     -level X -f ba}       {-code 1     -level 0 -f ba}
    30 {-code 0     -level X -f ba}       {-code 1     -level 0 -f ba}
    31 {-code error -level X -f ba}       {-code error -level 0 -f ba}
    32 {-code ok    -level X -f ba}       {-code 1     -level 0 -f ba}
    33 {-code boss  -level X -f ba}       {-code 1     -level 0 -f ba}

    34 {-code 1 -code 1     -level 0 -f ba snarf} {-code 1 -code 1     -level 0 -f ba snarf}
    35 {-code 1 -code 0     -level 0 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    36 {-code 1 -code 1     -level 5 -f ba snarf} {-code 1 -code 1     -level 0 -f ba snarf}
    37 {-code 1 -code 0     -level 5 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
    39 {-code 1 -code ok    -level 0 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
    41 {-code 1 -code ok    -level 5 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    42 {-code 1 -code boss  -level 0 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    43 {-code 1 -code boss  -level 5 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    44 {-code 1 -code 1     -level 0 -f ba}       {-code 1 -code 1     -level 0 -f ba}
    45 {-code 1 -code 0     -level 0 -f ba}       {-code 1             -level 0 -f ba}
    46 {-code 1 -code 1     -level 5 -f ba}       {-code 1 -code 1     -level 0 -f ba}
    47 {-code 1 -code 0     -level 5 -f ba}       {-code 1             -level 0 -f ba}
    48 {-code 1 -code error -level 0 -f ba}       {-code 1 -code error -level 0 -f ba}
    49 {-code 1 -code ok    -level 0 -f ba}       {-code 1             -level 0 -f ba}
    50 {-code 1 -code error -level 5 -f ba}       {-code 1 -code error -level 0 -f ba}
    51 {-code 1 -code ok    -level 5 -f ba}       {-code 1             -level 0 -f ba}
    52 {-code 1 -code boss  -level 0 -f ba}       {-code 1             -level 0 -f ba}
    53 {-code 1 -code boss  -level 5 -f ba}       {-code 1             -level 0 -f ba}
    54 {-code 1 -code 1     -level X -f ba snarf} {-code 1 -code 1     -level 0 -f ba snarf}
    55 {-code 1 -code 0     -level X -f ba snarf} {-code 1             -level 0 -f ba snarf}
    56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
    57 {-code 1 -code ok    -level X -f ba snarf} {-code 1             -level 0 -f ba snarf}
    58 {-code 1 -code boss  -level X -f ba snarf} {-code 1             -level 0 -f ba snarf}
    59 {-code 1 -code 1     -level X -f ba}       {-code 1 -code 1     -level 0 -f ba}
    60 {-code 1 -code 0     -level X -f ba}       {-code 1             -level 0 -f ba}
    61 {-code 1 -code error -level X -f ba}       {-code 1 -code error -level 0 -f ba}
    62 {-code 1 -code ok    -level X -f ba}       {-code 1             -level 0 -f ba}
    63 {-code 1 -code boss  -level X -f ba}       {-code 1             -level 0 -f ba}

    64 {-code 0 -code 1     -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    65 {-code 0 -code 0     -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    66 {-code 0 -code 1     -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    67 {-code 0 -code 0     -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    69 {-code 0 -code ok    -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    71 {-code 0 -code ok    -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    72 {-code 0 -code boss  -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    73 {-code 0 -code boss  -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    74 {-code 0 -code 1     -level 0 -f ba}       {-code 1 -level 0 -f ba}
    75 {-code 0 -code 0     -level 0 -f ba}       {-code 1 -level 0 -f ba}
    76 {-code 0 -code 1     -level 5 -f ba}       {-code 1 -level 0 -f ba}
    77 {-code 0 -code 0     -level 5 -f ba}       {-code 1 -level 0 -f ba}
    78 {-code 0 -code error -level 0 -f ba}       {-code 1 -level 0 -f ba}
    79 {-code 0 -code ok    -level 0 -f ba}       {-code 1 -level 0 -f ba}
    80 {-code 0 -code error -level 5 -f ba}       {-code 1 -level 0 -f ba}
    81 {-code 0 -code ok    -level 5 -f ba}       {-code 1 -level 0 -f ba}
    82 {-code 0 -code boss  -level 0 -f ba}       {-code 1 -level 0 -f ba}
    83 {-code 0 -code boss  -level 5 -f ba}       {-code 1 -level 0 -f ba}
    84 {-code 0 -code 1     -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    85 {-code 0 -code 0     -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    87 {-code 0 -code ok    -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    88 {-code 0 -code boss  -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    89 {-code 0 -code 1     -level X -f ba}       {-code 1 -level 0 -f ba}
    90 {-code 0 -code 0     -level X -f ba}       {-code 1 -level 0 -f ba}
    91 {-code 0 -code error -level X -f ba}       {-code 1 -level 0 -f ba}
    92 {-code 0 -code ok    -level X -f ba}       {-code 1 -level 0 -f ba}
    93 {-code 0 -code boss  -level X -f ba}       {-code 1 -level 0 -f ba}

    94 {-code 1     -code 1 -level 0 -f ba snarf} {-code 1 -code 1     -level 0 -f ba snarf}
    95 {-code 0     -code 1 -level 0 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    96 {-code 1     -code 1 -level 5 -f ba snarf} {-code 1 -code 1     -level 0 -f ba snarf}
    97 {-code 0     -code 1 -level 5 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
    99 {-code ok    -code 1 -level 0 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
    a1 {-code ok    -code 1 -level 5 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    a2 {-code boss  -code 1 -level 0 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    a3 {-code boss  -code 1 -level 5 -f ba snarf} {-code 1             -level 0 -f ba snarf}
    a4 {-code 1     -code 1 -level 0 -f ba}       {-code 1 -code 1     -level 0 -f ba}
    a5 {-code 0     -code 1 -level 0 -f ba}       {-code 1             -level 0 -f ba}
    a6 {-code 1     -code 1 -level 5 -f ba}       {-code 1 -code 1     -level 0 -f ba}
    a7 {-code 0     -code 1 -level 5 -f ba}       {-code 1             -level 0 -f ba}
    a8 {-code error -code 1 -level 0 -f ba}       {-code error -code 1 -level 0 -f ba}
    a9 {-code ok    -code 1 -level 0 -f ba}       {-code 1             -level 0 -f ba}
    b0 {-code error -code 1 -level 5 -f ba}       {-code error -code 1 -level 0 -f ba}
    b1 {-code ok    -code 1 -level 5 -f ba}       {-code 1             -level 0 -f ba}
    b2 {-code boss  -code 1 -level 0 -f ba}       {-code 1             -level 0 -f ba}
    b3 {-code boss  -code 1 -level 5 -f ba}       {-code 1             -level 0 -f ba}
    b4 {-code 1     -code 1 -level X -f ba snarf} {-code 1 -code 1     -level 0 -f ba snarf}
    b5 {-code 0     -code 1 -level X -f ba snarf} {-code 1             -level 0 -f ba snarf}
    b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
    b7 {-code ok    -code 1 -level X -f ba snarf} {-code 1             -level 0 -f ba snarf}
    b8 {-code boss  -code 1 -level X -f ba snarf} {-code 1             -level 0 -f ba snarf}
    b9 {-code 1     -code 1 -level X -f ba}       {-code 1 -code 1     -level 0 -f ba}
    c0 {-code 0     -code 1 -level X -f ba}       {-code 1             -level 0 -f ba}
    c1 {-code error -code 1 -level X -f ba}       {-code error -code 1 -level 0 -f ba}
    c2 {-code ok    -code 1 -level X -f ba}       {-code 1             -level 0 -f ba}
    c3 {-code boss  -code 1 -level X -f ba}       {-code 1             -level 0 -f ba}

    c4 {-code 1     -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    c5 {-code 0     -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    c6 {-code 1     -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    c7 {-code 0     -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    c9 {-code ok    -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    d1 {-code ok    -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    d2 {-code boss  -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    d3 {-code boss  -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
    d4 {-code 1     -code 0 -level 0 -f ba}       {-code 1 -level 0 -f ba}
    d5 {-code 0     -code 0 -level 0 -f ba}       {-code 1 -level 0 -f ba}
    d6 {-code 1     -code 0 -level 5 -f ba}       {-code 1 -level 0 -f ba}
    d7 {-code 0     -code 0 -level 5 -f ba}       {-code 1 -level 0 -f ba}
    d8 {-code error -code 0 -level 0 -f ba}       {-code 1 -level 0 -f ba}
    d9 {-code ok    -code 0 -level 0 -f ba}       {-code 1 -level 0 -f ba}
    e0 {-code error -code 0 -level 5 -f ba}       {-code 1 -level 0 -f ba}
    e1 {-code ok    -code 0 -level 5 -f ba}       {-code 1 -level 0 -f ba}
    e2 {-code boss  -code 0 -level 0 -f ba}       {-code 1 -level 0 -f ba}
    e3 {-code boss  -code 0 -level 5 -f ba}       {-code 1 -level 0 -f ba}
    e4 {-code 1     -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    e5 {-code 0     -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    e7 {-code ok    -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    e8 {-code boss  -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
    e9 {-code 1     -code 0 -level X -f ba}       {-code 1 -level 0 -f ba}
    f0 {-code 0     -code 0 -level X -f ba}       {-code 1 -level 0 -f ba}
    f1 {-code error -code 0 -level X -f ba}       {-code 1 -level 0 -f ba}
    f2 {-code ok    -code 0 -level X -f ba}       {-code 1 -level 0 -f ba}
    f3 {-code boss  -code 0 -level X -f ba}       {-code 1 -level 0 -f ba}
} {
    test io-71.$n {Tcl_SetChannelError} {testchannel} {

	set f [makeFile {... dummy ...} cutsplice]
	set c [open $f r]

	set res [testchannel setchannelerror $c [lrange $msg 0 end]]
	close $c
	removeFile cutsplice

	set res
    } [lrange $expected 0 end]

    test io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} {

	set f [makeFile {... dummy ...} cutsplice]
	set c [open $f r]

	set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]]
	close $c
	removeFile cutsplice

	set res
    } [lrange $expected 0 end]
}

# ### ### ### ######### ######### #########

# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return

Changes to tests/ioCmd.test.


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
#		    fblocked, fconfigure, open, channel, fcopy
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.21 2004/06/23 15:36:57 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint fcopy [llength [info commands fcopy]]
>














|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
#		    fblocked, fconfigure, open, channel, fcopy
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.21.2.2 2005/08/25 15:46:53 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint fcopy [llength [info commands fcopy]]
422
423
424
425
426
427
428
429
430
431
432
433

























434
435
436
437
438
439
440
} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
    list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
close [open $path(test3) w]


























test iocmd-13.1 {errors in open command} {
    list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
    list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}







|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
    list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
close [open $path(test3) w]
test iocmd-12.9 {POSIX open access modes: BINARY} {
    list [catch {open $path(test1) BINARY} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
test iocmd-12.10 {POSIX open access modes: BINARY} {
    set f [open $path(test1) {WRONLY BINARY TRUNC}]
    puts $f a
    puts $f b
    puts -nonewline $f c	;# contents are now 5 bytes: a\nb\nc
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation binary
    set result [string length [read $f]]
    close $f
    set result
} 5
test iocmd-12.11 {POSIX open access modes: BINARY} {
    set f [open $path(test1) {WRONLY BINARY TRUNC}]
    puts $f \u0248	;# gets truncated to \u0048
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation binary
    set result [read -nonewline $f]
    close $f
    set result
} \u0048

test iocmd-13.1 {errors in open command} {
    list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
    list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
448
449
450
451
452
453
454









455
456
457
458
459
460
461
    list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
    set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
    regsub [file join {} _non_existent_] $msg "_non_existent_" msg
	string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}










test iocmd-14.1 {file id parsing errors} {
    list [catch {eof gorp} msg] $msg $errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
    list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}







>
>
>
>
>
>
>
>
>







474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
    list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
    set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
    regsub [file join {} _non_existent_] $msg "_non_existent_" msg
	string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-13.7 {errors in open command} {
    list [catch {open $path(test1) b} msg] $msg
} {1 {illegal access mode "b"}}
test iocmd-13.8 {errors in open command} {
    list [catch {open $path(test1) rbb} msg] $msg
} {1 {illegal access mode "rbb"}}
test iocmd-13.9 {errors in open command} {
    list [catch {open $path(test1) r++} msg] $msg
} {1 {illegal access mode "r++"}}

test iocmd-14.1 {file id parsing errors} {
    list [catch {eof gorp} msg] $msg $errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
    list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
534
535
536
537
538
539
540



































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































541
542
543
544
545
546
547
548
549
550
551
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































# cleanup
foreach file [list test1 test2 test3 test4] {
    removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5] {
    removeFile $file
}
cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile

# ### ### ### ######### ######### #########
## Testing the reflected channel.

test iocmd-20.0 {chan, wrong#args} {
    catch {chan} msg
    set msg
} {wrong # args: should be "chan subcommand ?argument ...?"}

test iocmd-20.1 {chan, unknown method} {
    catch {chan foo} msg
    set msg
} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate}

# --- --- --- --------- --------- ---------
# chan create, and method "initalize"

test iocmd-21.0 {chan create, wrong#args, not enough} {
    catch {chan create} msg
    set msg
} {wrong # args: should be "chan create mode cmdprefix"}

test iocmd-21.1 {chan create, wrong#args, too many} {
    catch {chan create a b c} msg
    set msg
} {wrong # args: should be "chan create mode cmdprefix"}

test iocmd-21.2 {chan create, invalid r/w mode, empty} {
    proc foo {} {}
    catch {chan create {} foo} msg
    rename foo {}
    set msg
} {bad mode list: is empty}

test iocmd-21.3 {chan create, invalid r/w mode, bad string} {
    proc foo {} {}
    catch {chan create {c} foo} msg
    rename foo {}
    set msg
} {bad mode "c": must be read or write}

test iocmd-21.4 {chan create, bad handler, not a list} {
    catch {chan create {r w} "foo \{"} msg
    set msg
} {unmatched open brace in list}

test iocmd-21.5 {chan create, bad handler, not a command} {
    catch {chan create {r w} foo} msg
    set msg
} {Initialize failure: invalid command name "foo"}

test iocmd-21.6 {chan create, initialize failed, bad signature} {
    proc foo {} {}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: wrong # args: should be "foo"}

test iocmd-21.7 {chan create, initialize failed, bad signature} {
    proc foo {} {}
    catch {chan create {r w} ::foo} msg
    rename foo {}
    set msg
} {Initialize failure: wrong # args: should be "::foo"}

test iocmd-21.8 {chan create, initialize failed, bad result, not a list} {
    proc foo {args} {return "\{"}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: unmatched open brace in list}

test iocmd-21.9 {chan create, initialize failed, bad result, not a list} {
    proc foo {args} {return \{\{\}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: unmatched open brace in list}

test iocmd-21.10 {chan create, initialize failed, bad result, empty list} {
    proc foo {args} {}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: Not all required methods supported}

test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} {
    proc foo {args} {return 1}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: bad method "1": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write}

test iocmd-21.12 {chan create, initialize failed, bad result, ambiguous method name} {
    proc foo {args} {return {a b c}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: ambiguous method "c": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write}

test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} {
    proc foo {args} {return {initialize finalize}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: Not all required methods supported}

test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} {
    proc foo {args} {return {initialize finalize watch read}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: Writing not supported, but requested}

test iocmd-21.15 {chan create, initialize failed, bad result, mode/handler mismatch} {
    proc foo {args} {return {initialize finalize watch write}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: Reading not supported, but requested}

test iocmd-21.16 {chan create, initialize failed, bad result, cget(all) mismatch} {
    proc foo {args} {return {initialize finalize watch cget write read}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: 'cgetall' not supported, but should be, as 'cget' is}

test iocmd-21.17 {chan create, initialize failed, bad result, cget(all) mismatch} {
    proc foo {args} {return {initialize finalize watch cgetall read write}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} {Initialize failure: 'cget' not supported, but should be, as 'cgetall' is}

test iocmd-21.18 {chan create, initialize ok, creates channel} -match glob -body {
    proc foo {args} {
	global  res
	lappend res $args
	if {[lindex $args 0] ne "initialize"} {return}
	return {initialize finalize watch read write}
    }
    set res {}
    lappend res [file channel rc*]
    lappend res [chan create {r w} foo]
    lappend res [close [lindex $res end]]
    lappend res [file channel rc*]
    rename foo {}
    set res
} -result {{} {initialize rc* {read write}} rc* {finalize rc*} {} {}}

test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match glob -body {
    proc foo {args} {
	global  res
	lappend res $args
	return {}
    }
    set res {}
    lappend res [file channel rc*]
    lappend res [catch {chan create {r w} foo} msg]
    lappend res $msg
    lappend res [file channel rc*]
    rename foo {}
    set res
} -result {{} {initialize rc* {read write}} 1 {Initialize failure: Not all required methods supported} {}}

# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.

proc note  {item}  {global res ; lappend res $item ; return}
proc track {}      {upvar args item ; note $item; return}
proc notes {items} {foreach i $items {note $i}}

# Helper command, canned result for 'initialize' method.
# Gets the optional methods as arguments. Use return features
# to post the result higher up.

proc init {args} {
    lappend args initialize finalize watch read write
    return -code return $args
}

proc oninit {args} {
    upvar args hargs
    if {[lindex $hargs 0] ne "initialize"} {return}
    lappend args initialize finalize watch read write
    return -code return $args
}

proc onfinal {} {
    upvar args hargs
    if {[lindex $hargs 0] ne "finalize"} {return}
    return -code return ""
}

# --- --- --- --------- --------- ---------
# method finalize

test iocmd-22.1 {chan finalize, handler destruction has no effect on channel} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit; return}
    note [set c [chan create {r w} foo]]

    rename foo {}

    note [file channels rc*]
    note [catch {close $c} msg] ; note $msg
    note [file channels rc*]

    set res
} -result {{initialize rc* {read write}} rc* rc* 1 {invalid command name "foo"} {}}

test iocmd-22.2 {chan finalize, for close} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return {}}
    note [set c [chan create {r w} foo]]

    close $c

    # Close deleted the channel.
    note [file channels rc*]

    # Channel destruction does not kill handler command!
    note [info command foo]

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}

test iocmd-22.3 {chan finalize, for close, error, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code error 5}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg] ; note $msg
    # Channel is gone despite error.
    note [file channels rc*]

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}

test iocmd-22.4 {chan finalize, for close, error, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; error FOO}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg] ; note $msg

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}

test iocmd-22.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return SOMETHING}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg]; note $msg

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}

test iocmd-22.6 {chan finalize, for close, break, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code 3}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg] ; note $msg

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}}

test iocmd-22.7 {chan finalize, for close, continue, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code 4}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg] ; note $msg

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}}

test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code 777 BANG}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg] ; note $msg

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG}

test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG}
    note [set c [chan create {r w} foo]]

    note [catch {close $c} msg opt] ; note $msg ; note $opt

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

# --- === *** ###########################
# method read

test iocmd-23.1 {chan read, regular data return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return snarf
    }
    set c [chan create {r w} foo]

    note [read $c 10]
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}

test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return [string repeat snarf 1000]
    }
    set c [chan create {r w} foo]

    note [catch {read $c 2} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} 1 {read delivered more than requested}}

test iocmd-23.3 {chan read, for non-readable channel} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	note MUST_NOT_HAPPEN
    }
    set c [chan create {w} foo]

    note [catch {read $c 2} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {1 {channel "rc*" wasn't opened for reading}}

test iocmd-23.4 {chan read, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!}

test iocmd-23.5 {chan read, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!}

test iocmd-23.6 {chan read, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!}

test iocmd-23.7 {chan read, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code 777 BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!}

test iocmd-23.8 {chan read, level is squashed} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -level 55 -code 777 BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg opt] ; note $msg ; note $opt
    close $c

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}}

# --- === *** ###########################
# method write

test iocmd-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal ; track
	set     written [string length [lindex $args 2]]
	note   $written
	return $written
    }
    set c [chan create {r w} foo]

    puts -nonewline $c snarf ; flush $c
    close $c

    rename foo {}
    set res
} -result {{write rc* snarf} 5}

test iocmd-24.2 {chan write, partial write is ok} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	set     written [string length [lindex $args 2]]
	if {$written > 10} {set written [expr {$written / 2}]}
	note   $written
	return $written
    }
    set c [chan create {r w} foo]

    puts -nonewline $c snarfsnarfsnarf ; flush $c
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}

test iocmd-24.3 {chan write, failed write} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1}

    set c [chan create {r w} foo]
    puts -nonewline $c snarfsnarfsnarf ; flush $c
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} -1}

test iocmd-24.4 {chan write, non-writable channel} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {1 {channel "rc*" wasn't opened for writing}}

test iocmd-24.5 {chan write, bad result, more written than data} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return 10000}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarf} 1 {write wrote more than requested}}

test iocmd-24.6 {chan write, bad result, zero-length write} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return 0}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarf} 1 {write wrote more than requested}}

test iocmd-24.7 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
    note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}

test iocmd-24.8 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; error BOOM!}
    set c [chan create {r w} foo]

    notes [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
    note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}

test iocmd-24.9 {chan write, failed write, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
    note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}

test iocmd-24.10 {chan write, failed write, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
    note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}

test iocmd-24.11 {chan write, failed write, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
    note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}

test iocmd-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return BANG}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
    note $msg
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}}

test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!}
    set c [chan create {r w} foo]

    note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt]
    note $msg
    note $opt
    close $c

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}}

# --- === *** ###########################
# method cgetall

test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c]
    close $c

    rename foo {}
    set res
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}

test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
    set res {}
    proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""}
    set c [chan create {r w} foo]

    note [fconfigure $c]
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}

test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return "-bar foo -snarf x"
    }
    set c [chan create {r w} foo]

    note [fconfigure $c]
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}

test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return "-bar"
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}

test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return "\{"
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 {unmatched open brace in list}}

test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!}

test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!}

test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!}

test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code 777 BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!}

test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -level 55 -code 777 BANG
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt
    close $c

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

# --- === *** ###########################
# method configure

test iocmd-26.1 {chan configure, set standard option} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN
	return
    }
    set c [chan create {r w} foo]

    note [fconfigure $c -translation lf]
    close $c

    rename foo {}
    set res
} -result {{}}

test iocmd-26.2 {chan configure, set option, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!}

test iocmd-26.3 {chan configure, set option, ok return} -match glob -body {
    set res {}
    proc foo {args} {oninit configure ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c -rc-foo bar]
    close $c

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} {}}

test iocmd-26.4 {chan configure, set option, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!}

test iocmd-26.5 {chan configure, set option, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!}

test iocmd-26.6 {chan configure, set option, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code 444 BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!}

test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -level 55 -code 444 BANG
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt
    close $c

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

# --- === *** ###########################
# method cget

test iocmd-27.1 {chan configure, get option, ok return} -match glob -body {
    set res {}
    proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo}
    set c [chan create {r w} foo]

    note [fconfigure $c -rc-foo]
    close $c

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} foo}

test iocmd-27.2 {chan configure, get option, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!}

test iocmd-27.3 {chan configure, get option, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!}

test iocmd-27.4 {chan configure, get option, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!}

test iocmd-27.5 {chan configure, get option, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code 333 BOOM!
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!}

test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -level 77 -code 333 BANG
    }
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt
    close $c

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

# --- === *** ###########################
# method seek

test iocmd-28.1 {chan tell, not supported by handler} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    note [tell $c]
    close $c

    rename foo {}
    set res
} -result {-1}

test iocmd-28.2 {chan tell, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!}

test iocmd-28.3 {chan tell, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!}

test iocmd-28.4 {chan tell, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!}

test iocmd-28.5 {chan tell, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!}

test iocmd-28.6 {chan tell, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg opt] ; note $msg ; note $opt
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

test iocmd-28.7 {chan tell, regular return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return 88}
    set c [chan create {r w} foo]

    note [tell $c]
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 88}

test iocmd-28.8 {chan tell, negative return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -1}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 {Tried to seek before origin}}

test iocmd-28.9 {chan tell, string return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
    set c [chan create {r w} foo]

    note [catch {tell $c} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}}

test iocmd-28.10 {chan seek, not supported by handler} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {1 {error during seek on "rc*": invalid argument}}

test iocmd-28.11 {chan seek, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!}

test iocmd-28.12 {chan seek, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!}

test iocmd-28.13 {chan seek, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!}

test iocmd-28.14 {chan seek, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!}

test iocmd-28.15 {chan seek, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

test iocmd-28.16 {chan seek, bogus return, negative location} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -45}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 {Tried to seek before origin}}

test iocmd-28.17 {chan seek, bogus return, string return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
    set c [chan create {r w} foo]

    note [catch {seek $c 0 start} msg] ; note $msg
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}}

test iocmd-28.18 {chan seek, ok result} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return 23}
    set c [chan create {r w} foo]

    note [seek $c 0 current]
    close $c

    rename foo {}
    set res
} -result {{seek rc* 0 current} {}}

foreach {n code} {
    0 start
    1 current
    2 end
} {
    test iocmd-28.19.$n "chan seek, base conversion, $code" -match glob -body {
	set res {}
	proc foo {args} {oninit seek ; onfinal ; track ; return 0}

	set c [chan create {r w} foo]
	note [seek $c 0 $code]
	close $c

	rename foo {}
	set res
    } -result [list [list seek rc* 0 $code] {}]
}

# --- === *** ###########################
# method blocking

test iocmd-29.1 {chan blocking, no handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c -blocking]
    close $c

    rename foo {}
    set res
} -result {1}

test iocmd-29.2 {chan blocking, no handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c -blocking 0]
    note [fconfigure $c -blocking]
    close $c

    rename foo {}
    set res
} -result {{} 0}

test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c -blocking]
    close $c

    rename foo {}
    set res
} -result {1}

test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c -blocking 0]
    note [fconfigure $c -blocking]
    close $c

    rename foo {}
    set res
} -result {{blocking rc* 0} {} 0}

test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fconfigure $c -blocking 1]
    note [fconfigure $c -blocking]
    close $c

    rename foo {}
    set res
} -result {{blocking rc* 1} {} 1}

test iocmd-29.6 {chan blocking, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!}

    set c [chan create {r w} foo]

    note [catch {fconfigure $c -blocking 0} msg] ; note $msg

    # Catch the close. It changes blocking mode internally, and runs into the error result.
    catch {close $c}
    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!}

test iocmd-29.7 {chan blocking, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -blocking 0} msg] ; note $msg

    catch {close $c}
    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!}

test iocmd-29.8 {chan blocking, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -blocking 0} msg] ; note $msg

    catch {close $c}
    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!}

test iocmd-29.9 {chan blocking, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!}
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -blocking 0} msg] ; note $msg

    catch {close $c}
    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!}

test iocmd-29.10 {chan blocking, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG}
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt

    catch {close $c}
    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}

test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS}
    set c [chan create {r w} foo]

    note [catch {fconfigure $c -blocking 0} msg] ; note $msg

    catch {close $c}
    rename foo {}
    set res
} -result {{blocking rc* 0} 0 {}}

# --- === *** ###########################
# method watch

test iocmd-30.1 {chan watch, read interest, some return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return IGNORED}
    set c [chan create {r w} foo]

    note [fileevent $c readable {set tick $tick}]
    close $c     ;# 2nd watch, interest zero.

    rename foo {}
    set res
} -result {{watch rc* read} {} {watch rc* {}}}

test iocmd-30.2 {chan watch, write interest, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED}
    set c [chan create {r w} foo]

    note [fileevent $c writable {set tick $tick}]
    note [fileevent $c writable {}]
    close $c

    rename foo {}
    set res
} -result {{watch rc* write} {} {watch rc* {}} {}}

test iocmd-30.3 {chan watch, accumulated interests} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fileevent $c writable {set tick $tick}]
    note [fileevent $c readable {set tick $tick}]
    note [fileevent $c writable {}]
    note [fileevent $c readable {}]
    close $c

    rename foo {}
    set res
} -result {{watch rc* write} {} {watch rc* {read write}} {} {watch rc* read} {} {watch rc* {}} {}}

test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fileevent $c writable {set tick $tick}]
    note [fileevent $c readable {set tick $tick}] ;# Script is changing,
    note [fileevent $c readable {set tock $tock}] ;# interest does not.

    close $c ;# 3rd and 4th watch, removing the event handlers.
    rename foo {}
    set res
} -result {{watch rc* write} {} {watch rc* {read write}} {} {} {watch rc* write} {watch rc* {}}}

# --- === *** ###########################
# chan postevent

test iocmd-31.1 {chan postevent, restricted to reflected channels} -match glob -body {
    set c [open [makeFile {} goo] r]

    catch {chan postevent $c {r w}} msg

    close $c
    removeFile goo
    set msg
} -result {channel "file*" is not a reflected channel}

test iocmd-31.2 {chan postevent, unwanted events} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    catch {chan postevent $c {r w}} msg ; note $msg
    close $c

    rename foo {}
    set res
} -result {{tried to post events channel "rc*" is not interested in}}

test iocmd-31.3 {chan postevent, bad input, empty list} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    catch {chan postevent $c {}} msg ; note $msg
    close $c

    rename foo {}
    set res
} -result {{bad event list: is empty}}

test iocmd-31.4 {chan postevent, bad input, illlegal keyword} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    catch {chan postevent $c goo} msg ; note $msg
    close $c

    rename foo {}
    set res
} -result {{bad event "goo": must be read or write}}

test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    catch {chan postevent $c "\{"} msg ; note $msg
    close $c

    rename foo {}
    set res
} -result {{unmatched open brace in list}}

test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fileevent $c readable {note TOCK}]

    set stop [after 10000 {note TIMEOUT}]
    after  1000 {note [chan postevent $c r]}
    vwait ::res
    catch {after cancel $stop}
    close $c

    rename foo {}
    set res
} -result {{watch rc* read} {} TOCK {} {watch rc* {}}}

test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    note [fileevent $c writable {note TOCK}]

    set stop [after 10000 {note TIMEOUT}]
    after  1000 {note [chan postevent $c w]}
    vwait ::res
    catch {after cancel $stop}
    close $c

    rename foo {}
    set res
} -result {{watch rc* write} {} TOCK {} {watch rc* {}}}

# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Testing the reflected channel (Thread forwarding).
#
## The id numbers refer to the original test without thread
## forwarding, and gaps due to tests not applicable to forwarding are
## left to keep this asociation.

testConstraint testchannel [llength [info commands testchannel]]

# Duplicate of code in "thread.test". Find a better way of doing this
# without duplication. Maybe placement into a proc which transforms to
# nop after the first call, and placement of its defintion in a
# central location.

testConstraint testthread [expr {[info commands testthread] != {}}]

if {[testConstraint testthread]} {
    testthread errorproc ThreadError

    proc ThreadError {id info} {
	global threadError
	set threadError $info
    }

    proc ThreadNullError {id info} {
	# ignore
    }
}

# ### ### ### ######### ######### #########
## Helper command. Runs a script in a separate thread and returns the
## result. A channel is transfered into the thread as well, and list of
## configuation variables

proc inthread {chan script args} {

    # Test thread.

    set tid [testthread create]

    # Init thread configuration.
    # - Listed variables
    # - Id of main thread
    # - A number of helper commands

    foreach v $args {
	upvar 1 $v x
	testthread send $tid [list set $v $x]
    }
    testthread send $tid [list set mid $tcltest::mainThread]
    testthread send $tid {
	proc note {item} {global notes ; lappend notes $item}
	proc notes {} {global notes ; return $notes}
    }
    testthread send $tid [list proc s {} [list uplevel 1 $script]] ; # (*)

    # Transfer channel (cut/splice aka detach/attach)

    testchannel cut $chan
    testthread send $tid [list testchannel splice $chan]

    # Run test script, also run local event loop!
    # The local event loop waits for the result to come back.
    # It is also necessary for the execution of forwarded channel
    # operations.

    set ::tres ""
    testthread send -async $tid {
	after 500
	catch {s} res ; # This runs the script, 's' was defined at (*)
	testthread send -async $mid [list set ::tres $res]
    }
    vwait ::tres
    # Remove test thread, and return the captured result.

    tcltest::threadReap
    return $::tres
}

# ### ### ### ######### ######### #########

# ### ### ### ######### ######### #########

test iocmd.tf-22.2 {chan finalize, for close} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return {}}
    note [set c [chan create {r w} foo]]

    note [inthread $c {
	close $c
	# Close the deleted the channel.
	file channels rc*
    } c]

    # Channel destruction does not kill handler command!
    note [info command foo]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}

test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code error 5}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg] ; note $msg
	# Channel is gone despite error.
	note [file channels rc*]
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}

test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; error FOO}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg] ; note $msg
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}

test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return SOMETHING}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}

test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code 3}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg] ; note $msg
	notes
    } c]

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \
    -constraints {testchannel testthread}

test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code 4}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg] ; note $msg
	notes
    } c]

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \
    -constraints {testchannel testthread}

test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -code 777 BANG}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg] ; note $msg
	notes
    } c]

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} \
    -constraints {testchannel testthread}

test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body {
    set res {}
    proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG}
    note [set c [chan create {r w} foo]]

    notes [inthread $c {
	note [catch {close $c} msg opt] ; note $msg ; note $opt
	notes
    } c]

    rename foo {}
    set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method read

test iocmd.tf-23.1 {chan read, regular data return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return snarf
    }
    set c [chan create {r w} foo]
    notes [inthread $c {
	note [read $c 10]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}

test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return [string repeat snarf 1000]
    }
    set c [chan create {r w} foo]
    notes [inthread $c {
	note [catch {[read $c 2]} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}}

test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	note MUST_NOT_HAPPEN
    }
    set c [chan create {w} foo]
    notes [inthread $c {
	note [catch {[read $c 2]} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}}

test iocmd.tf-23.4 {chan read, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {read $c 2} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-23.5 {chan read, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {read $c 2} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {read $c 2} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -code 777 BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {read $c 2} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	return -level 55 -code 777 BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {read $c 2} msg opt] ; note $msg ; note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method write

test iocmd.tf-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal ; track
	set     written [string length [lindex $args 2]]
	note   $written
	return $written
    }
    set c [chan create {r w} foo]

    inthread $c {
	puts -nonewline $c snarf ; flush $c
	close $c
    } c

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{write rc* snarf} 5}

test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body {
    set res {}
    proc foo {args} {
	oninit ; onfinal ; track
	set     written [string length [lindex $args 2]]
	if {$written > 10} {set written [expr {$written / 2}]}
	note   $written
	return $written
    }
    set c [chan create {r w} foo]

    inthread $c {
	puts -nonewline $c snarfsnarfsnarf ; flush $c
	close $c
    } c

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}

test iocmd.tf-24.3 {chan write, failed write} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1}
    set c [chan create {r w} foo]

    inthread $c {
	puts -nonewline $c snarfsnarfsnarf ; flush $c
	close $c
    } c

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1}

test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}}

test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ;  return 10000}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}

test iocmd.tf-24.6 {chan write, zero writes} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return 0}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}

test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
	note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; error BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
	note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
	note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
	note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
	note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return BANG}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
	note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \
    -constraints {testchannel testthread}

test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt]
	note $msg
	note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method cgetall

test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}

test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
    set res {}
    proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}

test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return "-bar foo -snarf x"
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}

test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return "-bar"
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}

test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return "\{"
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}}

test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!}

test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code 777 BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -level 55 -code 777 BANG
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method configure

test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN
	return
    }

    set c [chan create {r w} foo]
    notes [inthread $c {
	note [fconfigure $c -translation lf]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{}}

test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!}

test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body {
    set res {}
    proc foo {args} {oninit configure ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -rc-foo bar]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}}

test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -code 444 BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit configure ; onfinal ; track
	return -level 55 -code 444 BANG
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method cget

test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body {
    set res {}
    proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -rc-foo]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo}

test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!}

test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -code 333 BOOM!
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit cget cgetall ; onfinal ; track
	return -level 77 -code 333 BANG
    }
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method seek

test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [tell $c]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {-1} \
    -constraints {testchannel testthread}

test iocmd.tf-28.2 {chan tell, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg opt] ; note $msg ; note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.7 {chan tell, regular return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return 88}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [tell $c]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 88} \
    -constraints {testchannel testthread}

test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -1}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {tell $c} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {1 {error during seek on "rc*": invalid argument}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.11 {chan seek, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return -45}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {seek $c 0 start} msg] ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \
    -constraints {testchannel testthread}

test iocmd.tf-28.18 {chan seek, ok result} -match glob -body {
    set res {}
    proc foo {args} {oninit seek ; onfinal ; track ; return 23}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [seek $c 0 current]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{seek rc* 0 current} {}} \
    -constraints {testchannel testthread}

foreach {n code} {
    0 start
    1 current
    2 end
} {
    test iocmd.tf-28.19.$n "chan seek, base conversion, $code" -match glob -body {
	set res {}
	proc foo {args} {oninit seek ; onfinal ; track ; return 0}
	set c [chan create {r w} foo]

	notes [inthread $c {
	    note [seek $c 0 $code]
	    close $c
	    notes
	} c code]

	rename foo {}
	set res
    } -result [list [list seek rc* 0 $code] {}] \
	-constraints {testchannel testthread}
}

# --- === *** ###########################
# method blocking

test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -blocking]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {1} \
    -constraints {testchannel testthread}

test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -blocking 0]
	note [fconfigure $c -blocking]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{} 0} \
    -constraints {testchannel testthread}

test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -blocking]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {1} \
    -constraints {testchannel testthread}

test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -blocking 0]
	note [fconfigure $c -blocking]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} {} 0} \
    -constraints {testchannel testthread}

test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fconfigure $c -blocking 1]
	note [fconfigure $c -blocking]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 1} {} 1} \
    -constraints {testchannel testthread}

test iocmd.tf-29.6 {chan blocking, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!}

    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -blocking 0} msg] ; note $msg
	# Catch the close. It changes blocking mode internally, and runs into the error result.
	catch {close $c}
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -blocking 0} msg] ; note $msg
	catch {close $c}
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -blocking 0} msg] ; note $msg
	catch {close $c}
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -blocking 0} msg] ; note $msg
	catch {close $c}
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BOOM!} \
    -constraints {testchannel testthread}

test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt
	catch {close $c}
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
    -constraints {testchannel testthread}

test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [catch {fconfigure $c -blocking 0} msg] ; note $msg
	catch {close $c}
	notes
    } c]

    rename foo {}
    set res
} -result {{blocking rc* 0} 0 {}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method watch

test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return IGNORED}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fileevent $c readable {set tick $tick}]
	close $c     ;# 2nd watch, interest zero.
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}}

test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fileevent $c writable {set tick $tick}]
	note [fileevent $c writable {}]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}}

test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fileevent $c writable {set tick $tick}]
	note [fileevent $c readable {set tick $tick}]
	note [fileevent $c writable {}]
	note [fileevent $c readable {}]
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}}

test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	note [fileevent $c writable {set tick $tick}]
	note [fileevent $c readable {set tick $tick}] ;# Script is changing,
	note [fileevent $c readable {set tock $tock}] ;# interest does not.
	close $c ;# 3rd and 4th watch, removing the event handlers.
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}}

# --- === *** ###########################
# postevent
# Not possible from a thread not containing the command handler.
# Check that this is rejected.

test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
    set res {}
    proc foo {args} {oninit ; onfinal ; track ; return}
    set c [chan create {r w} foo]

    notes [inthread $c {
	catch {chan postevent $c r} msg ; note $msg
	close $c
	notes
    } c]

    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{postevent for channel "rc*" called from outside interpreter}}


# ### ### ### ######### ######### #########

# ### ### ### ######### ######### #########

rename track {}
# cleanup
foreach file [list test1 test2 test3 test4] {
    removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5] {
    removeFile $file
}
cleanupTests
return

Changes to tests/iogt.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# -*- tcl -*-
# Commands covered:  transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
# 
# RCS: @(#) $Id: iogt.test,v 1.11 2004/06/23 15:36:57 dkf Exp $

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}
namespace eval ::tcl::test::iogt {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# -*- tcl -*-
# Commands covered:  transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
# 
# RCS: @(#) $Id: iogt.test,v 1.11.2.1 2005/04/25 21:37:29 kennykb Exp $

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}
namespace eval ::tcl::test::iogt {

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
    set fout [open $path(dummyout) w]

    set ain [list] ; set aout [list]
    audit_ops ain  -attach $fin
    audit_ops aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 5

    fcopy $fin $fout

    close $fin
    close $fout

    set res "[join $ain \n]\n--------\n[join $aout \n]"







|







494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
    set fout [open $path(dummyout) w]

    set ain [list] ; set aout [list]
    audit_ops ain  -attach $fin
    audit_ops aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 10

    fcopy $fin $fout

    close $fin
    close $fout

    set res "[join $ain \n]\n--------\n[join $aout \n]"
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
    set fout [open $path(dummyout) w]

    set ain [list] ; set aout [list]
    audit_flow ain  -attach $fin
    audit_flow aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 5

    fcopy $fin $fout

    close $fin
    close $fout

    set res "[join $ain \n]\n--------\n[join $aout \n]"







|







544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
    set fout [open $path(dummyout) w]

    set ain [list] ; set aout [list]
    audit_flow ain  -attach $fin
    audit_flow aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 10

    fcopy $fin $fout

    close $fin
    close $fout

    set res "[join $ain \n]\n--------\n[join $aout \n]"

Changes to tests/lindex.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lindex.test,v 1.11 2003/11/14 20:44:46 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set minus -







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lindex.test,v 1.11.2.1 2005/05/05 17:56:17 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set minus -
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
    list [testevalex {lindex {{a b c} {d e f}} $x}] \
	[testevalex {lindex {{a b c} {d e f}} $x}]
} {f f}

test lindex-2.4 {malformed index list} testevalex {
    set x \{
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?}

# Indices that are integers or convertible to integers

test lindex-3.1 {integer -1} testevalex {
    set x ${minus}1
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}







|







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
    list [testevalex {lindex {{a b c} {d e f}} $x}] \
	[testevalex {lindex {{a b c} {d e f}} $x}]
} {f f}

test lindex-2.4 {malformed index list} testevalex {
    set x \{
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}

# Indices that are integers or convertible to integers

test lindex-3.1 {integer -1} testevalex {
    set x ${minus}1
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    set x [string range 33 0 0]
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}

test lindex-3.5 {bad octal} testevalex {
    set x 08
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}"

test lindex-3.6 {bad octal} testevalex {
    set x -09
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}"

test lindex-3.7 {indexes don't shimmer wide ints} {
    set x [expr {(wide(1)<<31) - 2}]
    list $x [lindex {1 2 3} $x] [incr x] [incr x]
} {2147483646 {} 2147483647 2147483648}

# Indices relative to end







|




|







72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    set x [string range 33 0 0]
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}

test lindex-3.5 {bad octal} testevalex {
    set x 08
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}

test lindex-3.6 {bad octal} testevalex {
    set x -09
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "-09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}

test lindex-3.7 {indexes don't shimmer wide ints} {
    set x [expr {(wide(1)<<31) - 2}]
    list $x [lindex {1 2 3} $x] [incr x] [incr x]
} {2147483646 {} 2147483647 2147483648}

# Indices relative to end
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
    set x end-3
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}

test lindex-4.6 {bad octal} testevalex {
    set x end-08
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}"

test lindex-4.7 {bad octal} testevalex {
    set x end--09
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} "1 {bad index \"end--09\": must be integer or end?-integer?}"

test lindex-4.8 {bad integer, not octal} testevalex {
    set x end-0a2
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"

test lindex-4.9 {incomplete end} testevalex {
    set x en
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}

test lindex-4.10 {incomplete end-} testevalex {
    set x end-
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} "1 {bad index \"end-\": must be integer or end?-integer?}"

test lindex-5.1 {bad second index} testevalex {
    list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result
} "1 {bad index \"0a2\": must be integer or end?-integer?}"

test lindex-5.2 {good second index} testevalex {
    testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
} f

test lindex-5.3 {three indices} testevalex {
    testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1}







|




|




|

|
|






|



|







114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
    set x end-3
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}

test lindex-4.6 {bad octal} testevalex {
    set x end-08
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end-08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}

test lindex-4.7 {bad octal} testevalex {
    set x end--09
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end--09": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-4.8 {bad integer, not octal} testevalex {
    set x end-0a2
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-4.9 {obsolete test} testevalex {
    set x end
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}

test lindex-4.10 {incomplete end-} testevalex {
    set x end-
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-5.1 {bad second index} testevalex {
    list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-5.2 {good second index} testevalex {
    testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
} f

test lindex-5.3 {three indices} testevalex {
    testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1}
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
    } result
    set result
} {f f}

test lindex-10.4 {malformed index list} {
    set x \{
    list [catch { lindex {a b c} $x } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?}

# Indices that are integers or convertible to integers

test lindex-11.1 {integer -1} {
    set x ${minus}1
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]







|







241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
    } result
    set result
} {f f}

test lindex-10.4 {malformed index list} {
    set x \{
    list [catch { lindex {a b c} $x } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}

# Indices that are integers or convertible to integers

test lindex-11.1 {integer -1} {
    set x ${minus}1
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
    } result
    set result
} {{} {}}

test lindex-11.5 {bad octal} {
    set x 08
    list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}"

test lindex-11.6 {bad octal} {
    set x -09
    list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}"

# Indices relative to end

test lindex-12.1 {index = end} {
    set x end
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]







|




|







280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
    } result
    set result
} {{} {}}

test lindex-11.5 {bad octal} {
    set x 08
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}

test lindex-11.6 {bad octal} {
    set x -09
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "-09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}

# Indices relative to end

test lindex-12.1 {index = end} {
    set x end
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
    } result
    set result
} {{} {}}

test lindex-12.6 {bad octal} {
    set x end-08
    list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}"

test lindex-12.7 {bad octal} {
    set x end--09
    list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end--09\": must be integer or end?-integer?}"

test lindex-12.8 {bad integer, not octal} {
    set x end-0a2
    list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"

test lindex-12.9 {incomplete end} {
    set x en
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]
    } result
    set result
} {c c}

test lindex-12.10 {incomplete end-} {
    set x end-
    list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end-\": must be integer or end?-integer?}"

test lindex-13.1 {bad second index} {
    list [catch { lindex {a b c} 0 0a2 } result] $result
} "1 {bad index \"0a2\": must be integer or end?-integer?}"

test lindex-13.2 {good second index} {
    catch {
	lindex {{a b c} {d e f} {g h i}} 1 2
    } result
    set result
} f







|




|




|

|
|









|



|







332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
    } result
    set result
} {{} {}}

test lindex-12.6 {bad octal} {
    set x end-08
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end-08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}

test lindex-12.7 {bad octal} {
    set x end--09
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end--09": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-12.8 {bad integer, not octal} {
    set x end-0a2
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-12.9 {obsolete test} {
    set x end
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]
    } result
    set result
} {c c}

test lindex-12.10 {incomplete end-} {
    set x end-
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-13.1 {bad second index} {
    list [catch { lindex {a b c} 0 0a2 } result] $result
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lindex-13.2 {good second index} {
    catch {
	lindex {{a b c} {d e f} {g h i}} 1 2
    } result
    set result
} f

Changes to tests/link.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48









49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127









128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251


252
253
254
255
256
257
258
259
260
261
262
# Commands covered:  none
#
# This file contains a collection of tests for Tcl_LinkVar and related
# library procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: link.test,v 1.7 2002/06/22 04:19:47 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint testlink \
        [expr {[info commands testlink] != {}}]

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 12341234
    testlink create 1 1 1 1 1
    list $int $real $bool $string $wide
} {43 1.23 1 NULL 12341234}
test link-1.2 {reading C variables from Tcl} {testlink} {
    testlink delete
    testlink create 1 1 1 1 1
    testlink set -3 2 0 "A long string with spaces"  43214321
    list $int $real $bool $string $wide $int $real $bool $string $wide
} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321}

test link-2.1 {writing C variables from Tcl} {testlink} {
    testlink delete
    testlink set 43 1.21 4 - 56785678
    testlink create 1 1 1 1 1
    set int "00721"
    set real -10.5
    set bool true
    set string abcdef
    set wide 135135









    concat [testlink get] $int $real $bool $string $wide
} {465 -10.5 1 abcdef 135135 00721 -10.5 true abcdef 135135}
test link-2.2 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678
    testlink create 1 1 1 1 1
    list [catch {set int 09a} msg] $msg $int
} {1 {can't set "int": variable must have integer value} 43}
test link-2.3 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678
    testlink create 1 1 1 1 1
    list [catch {set real 1.x3} msg] $msg $real
} {1 {can't set "real": variable must have real value} 1.23}
test link-2.4 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678
    testlink create 1 1 1 1 1
    list [catch {set bool gorp} msg] $msg $bool
} {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678
    testlink create 1 1 1 1 1
    list [catch {set wide gorp} msg] $msg $bool
} {1 {can't set "wide": variable must have integer value} 1}

test link-3.1 {read-only variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678
    testlink create 0 1 1 0 0
    list [catch {set int 4} msg] $msg $int \
	[catch {set real 10.6} msg] $msg $real \
	[catch {set bool no} msg] $msg $bool \
	[catch {set string "new value"} msg] $msg $string \
	[catch {set wide 12341234} msg] $msg $wide
} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678}
test link-3.2 {read-only variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678
    testlink create 1 0 0 1 1
    list [catch {set int 4} msg] $msg $int \
	[catch {set real 10.6} msg] $msg $real \
	[catch {set bool no} msg] $msg $bool \
	[catch {set string "new value"} msg] $msg $string\
	[catch {set wide 12341234} msg] $msg $wide
} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234}

test link-4.1 {unsetting linked variables} {testlink} {
    testlink delete
    testlink set -6 -2.5 0 stringValue 13579
    testlink create 1 1 1 1 1
    unset int real bool string wide
    list [catch {set int} msg] $msg [catch {set real} msg] $msg \
	    [catch {set bool} msg] $msg [catch {set string} msg] $msg \
	    [catch {set wide} msg] $msg
} {0 -6 0 -2.5 0 0 0 stringValue 0 13579}
test link-4.2 {unsetting linked variables} {testlink} {
    testlink delete
    testlink set -6 -2.1 0 stringValue 97531
    testlink create 1 1 1 1 1
    unset int real bool string wide
    set int 102
    set real 16
    set bool true
    set string newValue
    set wide 333555
    testlink get
} {102 16.0 1 newValue 333555}

test link-5.1 {unlinking variables} {testlink} {
    testlink delete
    testlink set -6 -2.25 0 stringValue 13579
    testlink delete
    set int xx1
    set real qrst
    set bool bogus
    set string 12345
    set wide 875421









    testlink get
} {-6 -2.25 0 stringValue 13579}
test link-5.2 {unlinking variables} {testlink} {
    testlink delete
    testlink set -6 -2.25 0 stringValue 97531
    testlink create 1 1 1 1 1
    testlink delete
    testlink set 25 14.7 7 - 999999
    list $int $real $bool $string $wide
} {-6 -2.25 0 stringValue 97531}

test link-6.1 {errors in setting up link} {testlink} {
    testlink delete
    catch {unset int}
    set int(44) 1
    list [catch {testlink create 1 1 1 1 1} msg] $msg
} {1 {can't set "int": variable is array}}
catch {unset int}

test link-7.1 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	unset y
    }
    testlink delete
    testlink create 1 0 0 0 0
    testlink set 14 {} {} {} {}
    x
    list [catch {set int} msg] $msg
} {0 14}
test link-7.2 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	return [set y]
    }
    testlink delete
    testlink create 1 0 0 0 0
    testlink set 0 {} {} {} {}
    set int
    testlink set 23 {} {} {} {}
    x
    list [x] $int
} {23 23}
test link-7.3 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	set y 44
    }
    testlink delete
    testlink create 0 0 0 0 0
    testlink set 11 {} {} {} {}
    list [catch x msg] $msg $int
} {1 {can't set "y": linked variable is read-only} 11}
test link-7.4 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1
    testlink set -4 {} {} {} {}
    list [catch x msg] $msg $int
} {1 {can't set "y": variable must have integer value} -4}
test link-7.5 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar real y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1
    testlink set -4 16.75 {} {} {}
    list [catch x msg] $msg $real
} {1 {can't set "y": variable must have real value} 16.75}
test link-7.6 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar bool y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1
    testlink set -4 16.3 1 {} {}
    list [catch x msg] $msg $bool
} {1 {can't set "y": variable must have boolean value} 1}
test link-7.7 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar wide y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1
    testlink set -4 16.3 1 {} 778899
    list [catch x msg] $msg $wide
} {1 {can't set "y": variable must have integer value} 778899}

test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
    proc x args {
	global x int real bool string wide
	lappend x $args $int $real $bool $string $wide
    }
    set x {}
    testlink create 1 1 1 1 1
    testlink set 14 -2.0 0 xyzzy 995511
    trace var int w x
    testlink update 32 4.0 3 abcd 113355
    trace vdelete int w x
    set x
} {{int {} w} 32 -2.0 0 xyzzy 995511}
test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
    proc x args {
	global x int real bool string wide
	lappend x $args $int $real $bool $string $wide
    }
    set x {}
    testlink create 1 1 1 1 1
    testlink set 14 -2.0 0 xyzzy 995511
    testlink delete
    trace var int w x
    testlink update 32 4.0 6 abcd 113355
    trace vdelete int w x
    set x
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
    testlink create 0 0 0 0 0
    list [catch {testlink update 47 {} {} {} {}} msg] $msg $int


} {0 {} 47}

catch {testlink set 0 0 0 - 0}
catch {testlink delete}
foreach i {int real bool string wide} {
    catch {unset $i}
}

# cleanup
::tcltest::cleanupTests
return













|














|
|




|
|





|
|





>
>
>
>
>
>
>
>
>
|
|


|
|




|
|




|
|




|
|





|
|








|
|









|
|







|
|






|




|






>
>
>
>
>
>
>
>
>

|


|
|

|
|
|





|









|
|









|
|

|









|
|








|
|








|
|








|
|








|
|









|
|

|









|
|


|




|
|
>
>


|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
# Commands covered:  none
#
# This file contains a collection of tests for Tcl_LinkVar and related
# library procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: link.test,v 1.7.6.1 2005/09/09 18:48:40 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint testlink \
        [expr {[info commands testlink] != {}}]

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list $int $real $bool $string $wide
} {43 1.23 1 NULL 12341234}
test link-1.2 {reading C variables from Tcl} {testlink} {
    testlink delete
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -3 2 0 "A long string with spaces"  43214321 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    list $int $real $bool $string $wide $int $real $bool $string $wide
} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321}

test link-2.1 {writing C variables from Tcl} {testlink} {
    testlink delete
    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    set int "00721"
    set real -10.5
    set bool true
    set string abcdef
    set wide 135135
    set char 79
    set uchar 161
    set short 8000
    set ushort 40000
    set uint 0xc001babe
    set long 34543
    set ulong 567890
    set float 1.0987654321
    set uwide 357357357357
    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 00721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357}
test link-2.2 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list [catch {set int 09a} msg] $msg $int
} {1 {can't set "int": variable must have integer value} 43}
test link-2.3 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list [catch {set real 1.x3} msg] $msg $real
} {1 {can't set "real": variable must have real value} 1.23}
test link-2.4 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list [catch {set bool gorp} msg] $msg $bool
} {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list [catch {set wide gorp} msg] $msg $bool
} {1 {can't set "wide": variable must have integer value} 1}

test link-3.1 {read-only variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0
    list [catch {set int 4} msg] $msg $int \
	[catch {set real 10.6} msg] $msg $real \
	[catch {set bool no} msg] $msg $bool \
	[catch {set string "new value"} msg] $msg $string \
	[catch {set wide 12341234} msg] $msg $wide
} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678}
test link-3.2 {read-only variables} {testlink} {
    testlink delete
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 0 0 1 1 0 0 0 0 0 0 0 0 0
    list [catch {set int 4} msg] $msg $int \
	[catch {set real 10.6} msg] $msg $real \
	[catch {set bool no} msg] $msg $bool \
	[catch {set string "new value"} msg] $msg $string\
	[catch {set wide 12341234} msg] $msg $wide
} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234}

test link-4.1 {unsetting linked variables} {testlink} {
    testlink delete
    testlink set -6 -2.5 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    unset int real bool string wide
    list [catch {set int} msg] $msg [catch {set real} msg] $msg \
	    [catch {set bool} msg] $msg [catch {set string} msg] $msg \
	    [catch {set wide} msg] $msg
} {0 -6 0 -2.5 0 0 0 stringValue 0 13579}
test link-4.2 {unsetting linked variables} {testlink} {
    testlink delete
    testlink set -6 -2.1 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    unset int real bool string wide
    set int 102
    set real 16
    set bool true
    set string newValue
    set wide 333555
    lrange [testlink get] 0 4
} {102 16.0 1 newValue 333555}

test link-5.1 {unlinking variables} {testlink} {
    testlink delete
    testlink set -6 -2.25 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink delete
    set int xx1
    set real qrst
    set bool bogus
    set string 12345
    set wide 875421
    set char skjdf
    set uchar dslfjk
    set short slkf
    set ushort skrh
    set uint sfdkfkh
    set long srkjh
    set ulong sjkg
    set float dskjfbjfd
    set uwide isdfsngs
    testlink get
} {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234}
test link-5.2 {unlinking variables} {testlink} {
    testlink delete
    testlink set -6 -2.25 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink delete
    testlink set 25 14.7 7 - 999999 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
    list $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} {-6 -2.25 0 stringValue 97531 64 250 30000 60000 3203381950 12321 32123 3.25 1231231234}

test link-6.1 {errors in setting up link} {testlink} {
    testlink delete
    catch {unset int}
    set int(44) 1
    list [catch {testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1} msg] $msg
} {1 {can't set "int": variable is array}}
catch {unset int}

test link-7.1 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	unset y
    }
    testlink delete
    testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
    testlink set 14 {} {} {} {} {} {} {} {} {} {} {} {} {}
    x
    list [catch {set int} msg] $msg
} {0 14}
test link-7.2 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	return [set y]
    }
    testlink delete
    testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
    testlink set 0 {} {} {} {} {} {} {} {} {} {} {} {} {}
    set int
    testlink set 23 {} {} {} {} {} {} {} {} {} {} {} {} {}
    x
    list [x] $int
} {23 23}
test link-7.3 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	set y 44
    }
    testlink delete
    testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    testlink set 11 {} {} {} {} {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $int
} {1 {can't set "y": linked variable is read-only} 11}
test link-7.4 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar int y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -4 {} {} {} {} {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $int
} {1 {can't set "y": variable must have integer value} -4}
test link-7.5 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar real y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -4 16.75 {} {} {} {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $real
} {1 {can't set "y": variable must have real value} 16.75}
test link-7.6 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar bool y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -4 16.3 1 {} {} {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $bool
} {1 {can't set "y": variable must have boolean value} 1}
test link-7.7 {access to linked variables via upvar} {testlink} {
    proc x {} {
	upvar wide y
	set y abc
    }
    testlink delete
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $wide
} {1 {can't set "y": variable must have integer value} 778899}

test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
    proc x args {
	global x int real bool string wide
	lappend x $args $int $real $bool $string $wide
    }
    set x {}
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    trace var int w x
    testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
    trace vdelete int w x
    set x
} {{int {} w} 32 -2.0 0 xyzzy 995511}
test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
    proc x args {
	global x int real bool string wide
	lappend x $args $int $real $bool $string $wide
    }
    set x {}
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink delete
    trace var int w x
    testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
    trace vdelete int w x
    set x
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
    testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    list [catch {
	testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
    } msg] $msg $int
} {0 {} 47}

catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
    catch {unset $i}
}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/linsert.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  linsert
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: linsert.test,v 1.8 2000/04/10 17:19:01 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {unset lis}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  linsert
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: linsert.test,v 1.8.28.1 2005/05/05 17:56:18 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {unset lis}
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    list [catch linsert msg] $msg
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
test linsert-2.2 {linsert errors} {
    list [catch {linsert a b} msg] $msg
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
test linsert-2.3 {linsert errors} {
    list [catch {linsert a 12x 2} msg] $msg
} {1 {bad index "12x": must be integer or end?-integer?}}
test linsert-2.4 {linsert errors} {
    list [catch {linsert \{ 12 2} msg] $msg
} {1 {unmatched open brace in list}}

test linsert-3.1 {linsert won't modify shared argument objects} {
    proc p {} {
        linsert "a b c" 1 "x y"







|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    list [catch linsert msg] $msg
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
test linsert-2.2 {linsert errors} {
    list [catch {linsert a b} msg] $msg
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
test linsert-2.3 {linsert errors} {
    list [catch {linsert a 12x 2} msg] $msg
} {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.4 {linsert errors} {
    list [catch {linsert \{ 12 2} msg] $msg
} {1 {unmatched open brace in list}}

test linsert-3.1 {linsert won't modify shared argument objects} {
    proc p {} {
        linsert "a b c" 1 "x y"

Changes to tests/listObj.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
# Functionality covered: operation of the procedures in tclListObj.c that
# implement the Tcl type manager for the list object type.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: listObj.test,v 1.6 2004/05/19 12:15:04 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testobj [llength [info commands testobj]]

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} testobj {
    set t [testobj types]
    set first [string first "list" $t]
    set result [expr {$first != -1}]

} {1}

test listobj-2.1 {Tcl_SetListObj, use in lappend} {
    catch {unset x}
    list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x
} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}}
test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} {
    proc return_args {args} {













|






<
<

|
<
<
|
>
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20


21
22


23
24
25
26
27
28
29
30
31
32
# Functionality covered: operation of the procedures in tclListObj.c that
# implement the Tcl type manager for the list object type.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: listObj.test,v 1.6.2.2 2005/08/02 18:16:41 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}



catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {


    # Test removed; tested an internal detail
    # that's no longer correct, and duplicated test obj-1.1
} {}

test listobj-2.1 {Tcl_SetListObj, use in lappend} {
    catch {unset x}
    list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x
} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}}
test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} {
    proc return_args {args} {

Changes to tests/load.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands covered:  load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: load.test,v 1.13 2004/06/19 00:42:35 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands covered:  load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: load.test,v 1.13.2.1 2005/08/02 18:16:41 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this
125
126
127
128
129
130
131
132


133
134
135
136
137
138
139
140
    set result [info loaded x]
    interp delete x
    set result
} [list [list [file join $testDir pkga$ext] Pkga]]

# On some platforms, like SunOS 4.1.3, these tests can't be run because
# they cause the process to exit.



test load-6.1 {errors loading file} [list $dll $loaded nonPortable] {
    catch {load foo foo}
} {1}

test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
    set x "not loaded"
    teststaticpkg Test 1 0
    load {} Test







|
>
>
|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
    set result [info loaded x]
    interp delete x
    set result
} [list [list [file join $testDir pkga$ext] Pkga]]

# On some platforms, like SunOS 4.1.3, these tests can't be run because
# they cause the process to exit.
#
# As of 2005, such ancient broken systems no longer matter.

test load-6.1 {errors loading file} [list $dll $loaded] {
    catch {load foo foo}
} {1}

test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
    set x "not loaded"
    teststaticpkg Test 1 0
    load {} Test

Changes to tests/lrange.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  lrange
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lrange.test,v 1.7 2000/04/10 17:19:01 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test lrange-1.1 {range of list elements} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  lrange
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lrange.test,v 1.7.28.1 2005/05/05 17:56:18 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test lrange-1.1 {range of list elements} {
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
test lrange-1.7 {range of list elements} {
    lrange {a b c d e} -1 2
} {a b c}
test lrange-1.8 {range of list elements} {
    lrange {a b c d e} -2 -1
} {}
test lrange-1.9 {range of list elements} {
    lrange {a b c d e} -2 e
} {a b c d e}
test lrange-1.10 {range of list elements} {
    lrange "a b\{c d" 1 2
} "b\\{c d"
test lrange-1.11 {range of list elements} {
    lrange "a b c d" end end
} d
test lrange-1.12 {range of list elements} {
    lrange "a b c d" end 100000
} d
test lrange-1.13 {range of list elements} {
    lrange "a b c d" e 3
} d
test lrange-1.14 {range of list elements} {
    lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
    concat \"[lrange {a b \{\   	} 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
    lrange {[append a .b]} 0 end    
} {{[append} a .b\]}

test lrange-2.1 {error conditions} {
    list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
    list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
    list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test lrange-2.4 {error conditions} {
    list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer or end?-integer?}}
test lrange-2.5 {error conditions} {
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return







|











|



















|


|










39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
test lrange-1.7 {range of list elements} {
    lrange {a b c d e} -1 2
} {a b c}
test lrange-1.8 {range of list elements} {
    lrange {a b c d e} -2 -1
} {}
test lrange-1.9 {range of list elements} {
    lrange {a b c d e} -2 end
} {a b c d e}
test lrange-1.10 {range of list elements} {
    lrange "a b\{c d" 1 2
} "b\\{c d"
test lrange-1.11 {range of list elements} {
    lrange "a b c d" end end
} d
test lrange-1.12 {range of list elements} {
    lrange "a b c d" end 100000
} d
test lrange-1.13 {range of list elements} {
    lrange "a b c d" end 3
} d
test lrange-1.14 {range of list elements} {
    lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
    concat \"[lrange {a b \{\   	} 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
    lrange {[append a .b]} 0 end    
} {{[append} a .b\]}

test lrange-2.1 {error conditions} {
    list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
    list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
    list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
    list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/lreplace.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  lreplace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lreplace.test,v 1.7 2000/04/10 17:19:01 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test lreplace-1.1 {lreplace command} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  lreplace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lreplace.test,v 1.7.28.1 2005/05/05 17:56:18 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test lreplace-1.1 {lreplace command} {
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
    list [catch lreplace msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
test lreplace-2.2 {lreplace errors} {
    list [catch {lreplace a b} msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
test lreplace-2.3 {lreplace errors} {
    list [catch {lreplace x a 10} msg] $msg
} {1 {bad index "a": must be integer or end?-integer?}}
test lreplace-2.4 {lreplace errors} {
    list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer or end?-integer?}}
test lreplace-2.5 {lreplace errors} {
    list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer or end?-integer?}}
test lreplace-2.6 {lreplace errors} {
    list [catch {lreplace x 3 2} msg] $msg
} {1 {list doesn't contain element 3}}
test lreplace-2.7 {lreplace errors} {
    list [catch {lreplace x 1 1} msg] $msg
} {1 {list doesn't contain element 1}}








|


|


|







106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
    list [catch lreplace msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
test lreplace-2.2 {lreplace errors} {
    list [catch {lreplace a b} msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
test lreplace-2.3 {lreplace errors} {
    list [catch {lreplace x a 10} msg] $msg
} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.4 {lreplace errors} {
    list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
    list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} {
    list [catch {lreplace x 3 2} msg] $msg
} {1 {list doesn't contain element 3}}
test lreplace-2.7 {lreplace errors} {
    list [catch {lreplace x 1 1} msg] $msg
} {1 {list doesn't contain element 1}}

Changes to tests/lsearch.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  lsearch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lsearch.test,v 1.13 2003/10/15 13:15:45 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set x {abcd bbcd 123 234 345}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  lsearch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lsearch.test,v 1.13.2.2 2005/07/12 20:37:11 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set x {abcd bbcd 123 234 345}
57
58
59
60
61
62
63
64


















65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
    lsearch -glob {xyz bbcc *bc*} *bc*
} 1
test lsearch-2.9 {search modes} {
    lsearch -glob {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.10 {search modes} {
    list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg
} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}}



















test lsearch-3.1 {lsearch errors} {
    list [catch lsearch msg] $msg
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.2 {lsearch errors} {
    list [catch {lsearch a} msg] $msg
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.3 {lsearch errors} {
    list [catch {lsearch a b c} msg] $msg
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}}
test lsearch-3.4 {lsearch errors} {
    list [catch {lsearch a b c d} msg] $msg
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}}
test lsearch-3.5 {lsearch errors} {
    list [catch {lsearch "\{" b} msg] $msg
} {1 {unmatched open brace in list}}
test lsearch-3.6 {lsearch errors} {
    list [catch {lsearch -index a b} msg] $msg
} {1 {"-index" option must be followed by list index}}
test lsearch-3.7 {lsearch errors} {







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|


|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
    lsearch -glob {xyz bbcc *bc*} *bc*
} 1
test lsearch-2.9 {search modes} {
    lsearch -glob {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.10 {search modes} {
    list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg
} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}}
test lsearch-2.11 {search modes with -nocase} {
    lsearch -exact -nocase {a b c A B C} A
} 0
test lsearch-2.12 {search modes with -nocase} {
    lsearch -glob -nocase {a b c A B C} A*
} 0
test lsearch-2.13 {search modes with -nocase} {
    lsearch -regexp -nocase {a b c A B C} ^A\$
} 0
test lsearch-2.14 {search modes without -nocase} {
    lsearch -exact {a b c A B C} A
} 3
test lsearch-2.15 {search modes without -nocase} {
    lsearch -glob {a b c A B C} A*
} 3
test lsearch-2.16 {search modes without -nocase} {
    lsearch -regexp {a b c A B C} ^A\$
} 3

test lsearch-3.1 {lsearch errors} {
    list [catch lsearch msg] $msg
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.2 {lsearch errors} {
    list [catch {lsearch a} msg] $msg
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.3 {lsearch errors} {
    list [catch {lsearch a b c} msg] $msg
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}}
test lsearch-3.4 {lsearch errors} {
    list [catch {lsearch a b c d} msg] $msg
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}}
test lsearch-3.5 {lsearch errors} {
    list [catch {lsearch "\{" b} msg] $msg
} {1 {unmatched open brace in list}}
test lsearch-3.6 {lsearch errors} {
    list [catch {lsearch -index a b} msg] $msg
} {1 {"-index" option must be followed by list index}}
test lsearch-3.7 {lsearch errors} {
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
    lsearch -start 2 {a b c d e f} a
} -1
test lsearch-10.3 {offset searching} {
    lsearch -start end-4 {a b c a b c} a
} 3
test lsearch-10.4 {offset searching} {
    list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg
} {1 {bad index "foobar": must be integer or end?-integer?}}
test lsearch-10.5 {offset searching} {
    list [catch {lsearch -start 1 2} msg] $msg
} {1 {missing starting index}}
test lsearch-10.6 {binary search with offset} {
    set res {}
    for {set i 0} {$i < 100} {incr i} {
	lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i]







|







298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
    lsearch -start 2 {a b c d e f} a
} -1
test lsearch-10.3 {offset searching} {
    lsearch -start end-4 {a b c a b c} a
} 3
test lsearch-10.4 {offset searching} {
    list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg
} {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}}
test lsearch-10.5 {offset searching} {
    list [catch {lsearch -start 1 2} msg] $msg
} {1 {missing starting index}}
test lsearch-10.6 {binary search with offset} {
    set res {}
    for {set i 0} {$i < 100} {incr i} {
	lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i]
316
317
318
319
320
321
322









323
324
325
326
327
328
329

test lsearch-13.1 {search for all matches} {
    lsearch -all {a b a c a d} 1
} {}
test lsearch-13.2 {search for all matches} {
    lsearch -all {a b a c a d} a
} {0 2 4}










test lsearch-14.1 {combinations: -all and -inline} {
    lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
} {a1 a3 a5}
test lsearch-14.2 {combinations: -all, -inline and -not} {
    lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {b2 c4 d6}







>
>
>
>
>
>
>
>
>







334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356

test lsearch-13.1 {search for all matches} {
    lsearch -all {a b a c a d} 1
} {}
test lsearch-13.2 {search for all matches} {
    lsearch -all {a b a c a d} a
} {0 2 4}
test lsearch-13.3 {search for all matches with -nocase} {
    lsearch -all -exact -nocase {a b c A B C} A
} {0 3}
test lsearch-13.4 {search for all matches with -nocase} {
    lsearch -all -glob -nocase {a b c A B C} A*
} {0 3}
test lsearch-13.5 {search for all matches with -nocase} {
    lsearch -all -regexp -nocase {a b c A B C} ^A\$
} {0 3}

test lsearch-14.1 {combinations: -all and -inline} {
    lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
} {a1 a3 a5}
test lsearch-14.2 {combinations: -all, -inline and -not} {
    lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {b2 c4 d6}
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
} {{0 0 0} {1 0 0}}

test lsearch-20.1 {lsearch -index option, index larger than sublists} {
    list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg
} {1 {element 2 missing from sublist "a c"}}
test lsearch-20.2 {lsearch -index option, malformed index} {
    list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg
} {1 {bad index "foo": must be integer or end?-integer?}}
test lsearch-20.3 {lsearch -index option, malformed index} {
    list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
catch {unset res}
catch {unset increasingIntegers}







|







438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
} {{0 0 0} {1 0 0}}

test lsearch-20.1 {lsearch -index option, index larger than sublists} {
    list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg
} {1 {element 2 missing from sublist "a c"}}
test lsearch-20.2 {lsearch -index option, malformed index} {
    list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg
} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}}
test lsearch-20.3 {lsearch -index option, malformed index} {
    list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
catch {unset res}
catch {unset increasingIntegers}

Changes to tests/lset.test.

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
} {{3 1 2} {3 1 2}}

test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex {
    set x {0 1 2}
    list [catch {
	testevalex {lset x {{bad}1} 3}
    } msg] $msg
} "1 {bad index \"{bad}1\": must be integer or end?-integer?}"

test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex {
    set x {0 1 2}
    list [testevalex {lset x 0 $x}] $x
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}

test lset-3.2 {lset, not compiled, 3 args, data duplicated} testevalex {







|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
} {{3 1 2} {3 1 2}}

test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex {
    set x {0 1 2}
    list [catch {
	testevalex {lset x {{bad}1} 3}
    } msg] $msg
} {1 {bad index "{bad}1": must be integer?[+-]integer? or end?[+-]integer?}}

test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex {
    set x {0 1 2}
    list [testevalex {lset x 0 $x}] $x
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}

test lset-3.2 {lset, not compiled, 3 args, data duplicated} testevalex {
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
} {1 {unmatched open brace in list}}

test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a [list 2a2] w}
    } msg] $msg
} {1 {bad index "2a2": must be integer or end?-integer?}}

test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a [list -1] w}
    } msg] $msg
} {1 {list index out of range}}







|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
} {1 {unmatched open brace in list}}

test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a [list 2a2] w}
    } msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a [list -1] w}
    } msg] $msg
} {1 {list index out of range}}
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
} {1 {unmatched open brace in list}}

test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a 2a2 w}
    } msg] $msg
} {1 {bad index "2a2": must be integer or end?-integer?}}

test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a -1 w}
    } msg] $msg
} {1 {list index out of range}}







|







137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
} {1 {unmatched open brace in list}}

test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a 2a2 w}
    } msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a -1 w}
    } msg] $msg
} {1 {list index out of range}}
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
    set a [list "a \{" b]
    list [catch {testevalex {lset a {0 1} c}} msg] $msg
} {1 {unmatched open brace in list}}

test lset-8.3 {lset, not compiled, bad second index} testevalex {
    set a {{b c} {d e}}
    list [catch {testevalex {lset a 0 2a2 f}} msg] $msg
} {1 {bad index "2a2": must be integer or end?-integer?}}

test lset-8.4 {lset, not compiled, bad second index} testevalex {
    set a {{b c} {d e}}
    list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer or end?-integer?}}

test lset-8.5 {lset, not compiled, second index out of range} testevalex {
    set a {{b c} {d e} {f g}}
    list [catch {testevalex {lset a 2 -1 h}} msg] $msg
} {1 {list index out of range}}

test lset-8.6 {lset, not compiled, second index out of range} testevalex {







|




|







296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
    set a [list "a \{" b]
    list [catch {testevalex {lset a {0 1} c}} msg] $msg
} {1 {unmatched open brace in list}}

test lset-8.3 {lset, not compiled, bad second index} testevalex {
    set a {{b c} {d e}}
    list [catch {testevalex {lset a 0 2a2 f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lset-8.4 {lset, not compiled, bad second index} testevalex {
    set a {{b c} {d e}}
    list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}

test lset-8.5 {lset, not compiled, second index out of range} testevalex {
    set a {{b c} {d e} {f g}}
    list [catch {testevalex {lset a 2 -1 h}} msg] $msg
} {1 {list index out of range}}

test lset-8.6 {lset, not compiled, second index out of range} testevalex {

Changes to tests/main.test.

1
2
3
4
5
6
7
8
9
10
# This file contains a collection of tests for generic/tclMain.c.
#
# RCS: @(#) $Id: main.test,v 1.15 2003/10/07 21:45:39 dgp Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::main {


|







1
2
3
4
5
6
7
8
9
10
# This file contains a collection of tests for generic/tclMain.c.
#
# RCS: @(#) $Id: main.test,v 1.15.2.1 2005/05/05 17:56:19 kennykb Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::main {
901
902
903
904
905
906
907
















908
909
910
911
912
913
914
		close stdin} >& result
	set f [open result]
	read $f
    } -cleanup {
	close $f
	file delete result
    } -result "1\n% "

















    # Tests Tcl_Main-7.*: exiting

    test Tcl_Main-7.1 {
	Tcl_Main: [exit] defined as no-op -> still have exithandlers
    } -constraints {
	exec Tcltest







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
		close stdin} >& result
	set f [open result]
	read $f
    } -cleanup {
	close $f
	file delete result
    } -result "1\n% "

    test Tcl_Main-6.7 {
	[unknown]: interactive auto-completion.
    } -constraints {
	exec
    } -body {
	exec [interpreter] << {
		proc foo\{ x {}
		set tcl_interactive 1
		foo y} >& result
	set f [open result]
	read $f
    } -cleanup {
	close $f
	file delete result
    } -result "1\n% % "

    # Tests Tcl_Main-7.*: exiting

    test Tcl_Main-7.1 {
	Tcl_Main: [exit] defined as no-op -> still have exithandlers
    } -constraints {
	exec Tcltest

Changes to tests/msgcat.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
#
# RCS: @(#) $Id: msgcat.test,v 1.16 2004/11/11 01:16:07 das Exp $

package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
if {[catch {package require msgcat 1.4.1}]} {







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
#
# RCS: @(#) $Id: msgcat.test,v 1.16.2.1 2004/12/08 18:24:36 kennykb Exp $

package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
if {[catch {package require msgcat 1.4.1}]} {
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
    set msgdir [makeDirectory msgdir]
    foreach loc $locales {
	if { $loc eq {} } {
	    set msg ROOT
        } else {
	    set msg [string tolower $loc]
	}
	makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg \
		[file join [temporaryDirectory] msgdir]
    }
    variable count 1
    foreach loc {foo foo_BAR foo_BAR_baz} {
	test msgcat-5.$count {mcload} -setup {
	    variable locale [mclocale]
	    mclocale $loc
	} -cleanup {







|
<







392
393
394
395
396
397
398
399

400
401
402
403
404
405
406
    set msgdir [makeDirectory msgdir]
    foreach loc $locales {
	if { $loc eq {} } {
	    set msg ROOT
        } else {
	    set msg [string tolower $loc]
	}
	makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg $msgdir

    }
    variable count 1
    foreach loc {foo foo_BAR foo_BAR_baz} {
	test msgcat-5.$count {mcload} -setup {
	    variable locale [mclocale]
	    mclocale $loc
	} -cleanup {
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504

    foreach loc $locales {
	if { $loc eq {} } {
	    set msg ROOT
        } else {
	    set msg [string tolower $loc]
	}
	removeFile $msg.msg msgdir
    }
    removeDirectory msgdir

    # Tests msgcat-6.*: [mcset], [mc] namespace inheritance
#
# Test mcset and mc, ensuring that resolution for messages
# proceeds from the current ns to its parent and so on to the 







|







489
490
491
492
493
494
495
496
497
498
499
500
501
502
503

    foreach loc $locales {
	if { $loc eq {} } {
	    set msg ROOT
        } else {
	    set msg [string tolower $loc]
	}
	removeFile $msg.msg $msgdir
    }
    removeDirectory msgdir

    # Tests msgcat-6.*: [mcset], [mc] namespace inheritance
#
# Test mcset and mc, ensuring that resolution for messages
# proceeds from the current ns to its parent and so on to the 

Changes to tests/namespace.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.43 2004/10/29 15:39:10 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.43.2.1 2005/07/12 20:37:12 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
        namespace import ::test_ns_export::*
        proc p {} {return [cmd1 123]}
    }
    test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
    list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {1 {can't import command "cmd1": already exists}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
    namespace eval test_ns_import {
        namespace import -force ::test_ns_export::*
        cmd1 555
    }
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {







|







240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
        namespace import ::test_ns_export::*
        proc p {} {return [cmd1 123]}
    }
    test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
    list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
    namespace eval test_ns_import {
        namespace import -force ::test_ns_export::*
        cmd1 555
    }
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848

test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
    catch {namespace delete {expand}[namespace children :: test_ns_*]}
    list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
    list [catch {namespace wombat {}} msg] $msg
} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
    namespace ch :: test_ns_*
} {}

test namespace-21.1 {NamespaceChildrenCmd, no args} {
    catch {namespace delete {expand}[namespace children :: test_ns_*]}
    namespace eval test_ns_1::test_ns_2 {}







|







834
835
836
837
838
839
840
841
842
843
844
845
846
847
848

test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
    catch {namespace delete {expand}[namespace children :: test_ns_*]}
    list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
    list [catch {namespace wombat {}} msg] $msg
} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
    namespace ch :: test_ns_*
} {}

test namespace-21.1 {NamespaceChildrenCmd, no args} {
    catch {namespace delete {expand}[namespace children :: test_ns_*]}
    namespace eval test_ns_1::test_ns_2 {}
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955

test namespace-25.1 {NamespaceEvalCmd, bad args} {
    catch {namespace delete {expand}[namespace children :: test_ns_*]}
    list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
    list [catch {namespace test_ns_1} msg] $msg
} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
    set v 123
    namespace eval test_ns_1 {
        variable v 314159
        proc p {} {
            variable v







|







941
942
943
944
945
946
947
948
949
950
951
952
953
954
955

test namespace-25.1 {NamespaceEvalCmd, bad args} {
    catch {namespace delete {expand}[namespace children :: test_ns_*]}
    list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
    list [catch {namespace test_ns_1} msg] $msg
} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
    set v 123
    namespace eval test_ns_1 {
        variable v 314159
        proc p {} {
            variable v
1920
1921
1922
1923
1924
1925
1926













1927
1928
1929
1930
1931
1932
1933
    proc x {} {a b; c b; a b; c b}
    x
} -result {1 2 1 2} -cleanup {
    rename a {}
    rename c {}
    rename x {}
}














test namespace-50.1 {ensembles affect proc arguments error messages} -body {
    namespace ens cre -command a -map {b {bb foo}}
    proc bb {c d {e f} args} {list $c $args}
    a b
} -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup {
    rename a {}







>
>
>
>
>
>
>
>
>
>
>
>
>







1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
    proc x {} {a b; c b; a b; c b}
    x
} -result {1 2 1 2} -cleanup {
    rename a {}
    rename c {}
    rename x {}
}
test namespace-49.2 {strange delete crash} -body {
    namespace eval foo {namespace ensemble create -command ::bar}
    trace add command ::bar delete DeleteTrace
    proc DeleteTrace {old new op} {
	trace remove command ::bar delete DeleteTrace
	rename $old ""
	# This next line caused a bus error in [Bug 1220058]
	namespace delete foo
    }
    rename ::bar ""
} -result "" -cleanup {
    rename DeleteTrace ""
}

test namespace-50.1 {ensembles affect proc arguments error messages} -body {
    namespace ens cre -command a -map {b {bb foo}}
    proc bb {c d {e f} args} {list $c $args}
    a b
} -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup {
    rename a {}
1951
1952
1953
1954
1955
1956
1957































































































































































































































































































































































































1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
    namespace ens cre -command a -map {b {c d}}
    namespace ens cre -command c -map {d {e f}}
    proc e f {}
    a b d
} -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup {
    rename a {}
}
































































































































































































































































































































































































# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {expand}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
    namespace ens cre -command a -map {b {c d}}
    namespace ens cre -command c -map {d {e f}}
    proc e f {}
    a b d
} -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup {
    rename a {}
}

test namespace-51.1 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc pathtestA {} {
		::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
	    }
	    proc pathtestC {} {
		::return 2
	    }
	}
	proc pathtestB {} {
	    return 1
	}
	proc pathtestC {} {
	    return 1
	}
	namespace path ::test_ns_1
    }
    proc ::pathtestB {} {
	return global
    }
    proc ::pathtestD {} {
	return global
    }
    test_ns_1::test_ns_2::pathtestA
} -result "global,2,global," -cleanup {
    namespace delete ::test_ns_1
    catch {rename ::pathtestB {}}
    catch {rename ::pathtestD {}}
}
test namespace-51.2 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    namespace path ::test_ns_1
	    proc pathtestA {} {
		::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
	    }
	    proc pathtestC {} {
		::return 2
	    }
	}
	proc pathtestB {} {
	    return 1
	}
	proc pathtestC {} {
	    return 1
	}
    }
    proc ::pathtestB {} {
	return global
    }
    proc ::pathtestD {} {
	return global
    }
    ::test_ns_1::test_ns_2::pathtestA
} -result "1,2,global,::test_ns_1" -cleanup {
    namespace delete ::test_ns_1
    catch {rename ::pathtestB {}}
    catch {rename ::pathtestD {}}
}
test namespace-51.3 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc pathtestA {} {
		::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
	    }
	    proc pathtestC {} {
		::return 2
	    }
	}
	proc pathtestB {} {
	    return 1
	}
	proc pathtestC {} {
	    return 1
	}
    }
    proc ::pathtestB {} {
	return global
    }
    proc ::pathtestD {} {
	return global
    }
    set result [::test_ns_1::test_ns_2::pathtestA]
    namespace eval ::test_ns_1::test_ns_2 {
	namespace path ::test_ns_1
    }
    lappend result [::test_ns_1::test_ns_2::pathtestA]
    rename ::test_ns_1::pathtestB {}
    lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global,::test_ns_1" -cleanup {
    namespace delete ::test_ns_1
    catch {rename ::pathtestB {}}
    catch {rename ::pathtestD {}}
}
test namespace-51.4 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc pathtestA {} {
		::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
	    }
	    proc pathtestC {} {
		::return 2
	    }
	}
	proc pathtestB {} {
	    return 1
	}
	proc pathtestC {} {
	    return 1
	}
    }
    proc ::pathtestB {} {
	return global
    }
    proc ::pathtestD {} {
	return global
    }
    set result [::test_ns_1::test_ns_2::pathtestA]
    namespace eval ::test_ns_1::test_ns_2 {
	namespace path ::test_ns_1
    }
    lappend result [::test_ns_1::test_ns_2::pathtestA]
    namespace eval ::test_ns_1::test_ns_2 {
	namespace path {}
    }
    lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global," -cleanup {
    namespace delete ::test_ns_1
    catch {rename ::pathtestB {}}
    catch {rename ::pathtestD {}}
}
test namespace-51.5 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc pathtestA {} {
		::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
	    }
	    proc pathtestC {} {
		::return 2
	    }
	    namespace path ::test_ns_1
	}
	proc pathtestB {} {
	    return 1
	}
	proc pathtestC {} {
	    return 1
	}
	proc pathtestD {} {
	    return 1
	}
    }
    proc ::pathtestB {} {
	return global
    }
    proc ::pathtestD {} {
	return global
    }
    set result [::test_ns_1::test_ns_2::pathtestA]
    namespace eval ::test_ns_1::test_ns_2 {
	namespace path {:: ::test_ns_1}
    }
    lappend result [::test_ns_1::test_ns_2::pathtestA]
    rename ::test_ns_1::test_ns_2::pathtestC {}
    lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1}" -cleanup {
    namespace delete ::test_ns_1
    catch {rename ::pathtestB {}}
    catch {rename ::pathtestD {}}
}
test namespace-51.6 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc pathtestA {} {
		::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
	    }
	    proc pathtestC {} {
		::return 2
	    }
	    namespace path ::test_ns_1
	}
	proc pathtestB {} {
	    return 1
	}
	proc pathtestC {} {
	    return 1
	}
	proc pathtestD {} {
	    return 1
	}
    }
    proc ::pathtestB {} {
	return global
    }
    proc ::pathtestD {} {
	return global
    }
    set result [::test_ns_1::test_ns_2::pathtestA]
    namespace eval ::test_ns_1::test_ns_2 {
	namespace path {:: ::test_ns_1}
    }
    lappend result [::test_ns_1::test_ns_2::pathtestA]
    rename ::test_ns_1::test_ns_2::pathtestC {}
    lappend result [::test_ns_1::test_ns_2::pathtestA]
    proc ::pathtestC {} {
	return global
    }
    lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
    namespace delete ::test_ns_1
    catch {rename ::pathtestB {}}
    catch {rename ::pathtestD {}}
}
test namespace-51.7 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
    }
    namespace eval ::test_ns_2 {
	namespace path ::test_ns_1
	proc getpath {} {namespace path}
    }
    list [::test_ns_2::getpath] [namespace delete ::test_ns_1] [::test_ns_2::getpath]
} -result {::test_ns_1 {} {}} -cleanup {
    catch {namespace delete ::test_ns_1}
    namespace delete ::test_ns_2
}
test namespace-51.8 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
    }
    namespace eval ::test_ns_2 {
    }
    namespace eval ::test_ns_3 {
    }
    namespace eval ::test_ns_4 {
	namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3}
	proc getpath {} {namespace path}
    }
    list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [::test_ns_4::getpath]
} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {::test_ns_1 ::test_ns_3}} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}
test namespace-51.9 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
    }
    namespace eval ::test_ns_2 {
    }
    namespace eval ::test_ns_3 {
    }
    namespace eval ::test_ns_4 {
	namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3}
	proc getpath {} {namespace path}
    }
    list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [namespace eval ::test_ns_2 {}] [::test_ns_4::getpath]
} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {} {::test_ns_1 ::test_ns_3}} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}
test namespace-51.10 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	namespace path does::not::exist
    }
} -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup {
    catch {namespace delete ::test_ns_1}
}
test namespace-51.11 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	proc foo {} {return 1}
    }
    namespace eval ::test_ns_2 {
	proc foo {} {return 2}
    }
    namespace eval ::test_ns_3 {
	namespace path ::test_ns_1
    }
    namespace eval ::test_ns_4 {
	namespace path {::test_ns_3 ::test_ns_2}
	foo
    }
} -result 2 -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}
test namespace-51.12 {name resolution path control} -body {
    namespace eval ::test_ns_1 {
	proc foo {} {return 1}
    }
    namespace eval ::test_ns_2 {
	proc foo {} {return 2}
    }
    namespace eval ::test_ns_3 {
	namespace path ::test_ns_1
    }
    namespace eval ::test_ns_4 {
	namespace path {::test_ns_3 ::test_ns_2}
	list [foo] [namespace delete ::test_ns_3] [foo]
    }
} -result {2 {} 2} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}
# Fails right now due to unrelated bug...
test namespace-51.13 {name resolution path control} -constraints knownBug -body {
    set ::result {}
    namespace eval ::test_ns_1 {
	proc foo {} {lappend ::result 1}
    }
    namespace eval ::test_ns_2 {
	proc foo {} {lappend ::result 2}
	trace add command foo delete {namespace eval ::test_ns_3 foo;#}
    }
    namespace eval ::test_ns_3 {
	proc foo {} {
	    lappend ::result 3
	    namespace delete [namespace current]
	    ::test_ns_4::bar
	}
    }
    namespace eval ::test_ns_4 {
	namespace path {::test_ns_2 ::test_ns_3 ::test_ns_1}
	proc bar {} {
	    list [foo] [namespace delete ::test_ns_2] [foo]
	}
	bar
    }
    # Should the result be "2 {} {2 3 1 1}" instead?
} -result {2 {} {2 3 2 1}} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}
test namespace-51.14 {name resolution path control} -body {
    proc foo0 {} {}
    namespace eval ::test_ns_1 {
	proc foo1 {} {}
    }
    namespace eval ::test_ns_2 {
	proc foo2 {} {}
    }
    namespace eval ::test_ns_3 {
	variable result {}
	lappend result [info commands foo*]
	namespace path {::test_ns_1 ::test_ns_2}
	lappend result [info commands foo*]
	proc foo2 {} {}
	lappend result [info commands foo*]
	rename foo2 {}
	lappend result [info commands foo*]
	namespace delete ::test_ns_1
	lappend result [info commands foo*]
    }
} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
}
test namespace-51.15 {namespace resolution path control} -body {
    namespace eval ::test_ns_2 {
	proc foo {} {return 2}
    }
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc foo {} {return 1_2}
	}
	namespace eval test_ns_3 {
	    namespace path ::test_ns_1
	    test_ns_2::foo
	}
    }
} -result 1_2 -cleanup {
    namespace delete ::test_ns_1
    namespace delete ::test_ns_2
}

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {expand}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/obj.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81


82
83
84
85
86
87
88
89
90
91
92
# Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: obj.test,v 1.11 2004/09/10 21:29:42 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Procedure to determine the integer range of the machine
proc int_range {} {
    for {set MIN_INT 1} {$MIN_INT > 0} {} {
	set MIN_INT [expr {$MIN_INT << 1}]
    }
    set MAX_INT [expr {~ $MIN_INT}]
    return [list $MIN_INT $MAX_INT]
}

# Procedure to determine the range of wide integers on the machine.
proc wide_range {} {
    for {set MIN_WIDE [expr {wide(1)}] } {$MIN_WIDE > wide(0)} {} {
	set MIN_WIDE [expr {$MIN_WIDE << 1}]
    }
    set MAX_WIDE [expr {~ $MIN_WIDE}]
    return [list $MIN_WIDE $MAX_WIDE]
}

foreach {MIN_INT  MAX_INT}  [int_range]  break
foreach {MIN_WIDE MAX_WIDE} [wide_range] break

testConstraint testobj [llength [info commands testobj]]
testConstraint 32bit   [expr {$MAX_INT == 0x7fffffff}]
testConstraint wideBiggerThanInt [expr {$MAX_WIDE > wide($MAX_INT)}]

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
    set r 1
    foreach {t} {
	{array search} 
	boolean
	bytearray
	bytecode

	double
	end-offset
	index
	int
	list
	nsName
	procbody
	string
    } {
        set first [string first $t [testobj types]]
        set r [expr {$r && ($first != -1)}]
    }
    set result $r
} {1}

test obj-2.1 {Tcl_GetObjType error} testobj {
    list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg
} {0 1 {no type foo found}}
test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testintobj set 1 12]
    lappend result [testobj convert 1 double]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 12 12 double 3}

test obj-3.1 {Tcl_ConvertToType error} testobj {
    list [testdoubleobj set 1 12.34] [catch {testobj convert 1 int} msg] $msg


} {12.34 1 {expected integer but got "12.34"}}
test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
    list [testobj newobj 1] [catch {testobj convert 1 int} msg] $msg
} {{} 1 {expected integer but got ""}}

test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]













|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|
|





<


>
|

<
<
<

|















|


|


|
>
>
|

|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20





















21
22
23
24
25
26
27
28

29
30
31
32
33



34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: obj.test,v 1.11.2.3 2005/08/02 18:16:41 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}






















testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit	[expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
    set r 1
    foreach {t} {
	{array search} 

	bytearray
	bytecode
	cmdName
	dict
	end-offset



	nsName
	regexp
	string
    } {
        set first [string first $t [testobj types]]
        set r [expr {$r && ($first != -1)}]
    }
    set result $r
} {1}

test obj-2.1 {Tcl_GetObjType error} testobj {
    list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg
} {0 1 {no type foo found}}
test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testintobj set 1 12]
    lappend result [testobj convert 1 bytearray]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 12 12 bytearray 3}

test obj-3.1 {Tcl_ConvertToType error} testobj {
    list [testdoubleobj set 1 12.34] \
	[catch {testobj convert 1 end-offset} msg] \
	 $msg
} {12.34 1 {bad index "12.34": must be end?[+-]integer?}}
test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
    list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg
} {{} 1 {bad index "": must be end?[+-]integer?}}

test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273

test obj-9.1 {Tcl_NewBooleanObj} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testbooleanobj set 1 0]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 0 boolean 2}

test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testbooleanobj set 1 0]  ;# makes existing obj boolean
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} {} 0 boolean 2}
test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testintobj set 1 98765]
    lappend result [testbooleanobj set 1 1]  ;# makes existing obj boolean
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 98765 1 boolean 2}

test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} testobj {
    set result ""
    lappend result [testbooleanobj set 1 1]
    lappend result [testbooleanobj not 1]    ;# gets existing boolean rep
} {1 0}
test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} testobj {
    set result ""
    lappend result [testintobj set 1 47]
    lappend result [testbooleanobj not 1]    ;# must convert to bool
    lappend result [testobj type 1]
} {47 0 boolean}
test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} testobj {
    set result ""
    lappend result [teststringobj set 1 abc]
    lappend result [catch {testbooleanobj not 1} msg]
    lappend result $msg
} {abc 1 {expected boolean value but got "abc"}}
test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} testobj {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [catch {testbooleanobj not 1} msg]
    lappend result $msg
} {{} 1 {expected boolean value but got ""}}
test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} testobj {
    set result ""
    lappend result [teststringobj set 1 0xac]
    lappend result [testbooleanobj not 1]
    lappend result [testobj type 1]
} {0xac 0 boolean}
test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} testobj {
    set result ""
    lappend result [teststringobj set 1 5.42]
    lappend result [testbooleanobj not 1]
    lappend result [testobj type 1]
} {5.42 0 boolean}

test obj-12.1 {DupBooleanInternalRep} testobj {
    set result ""
    lappend result [testbooleanobj set 1 1]
    lappend result [testobj duplicate 1 2]   ;# uses DupBooleanInternalRep
    lappend result [testbooleanobj get 2]
} {1 1 1}

test obj-13.1 {SetBooleanFromAny, int to boolean special case} testobj {
    set result ""
    lappend result [testintobj set 1 1234]
    lappend result [testbooleanobj not 1]    ;# converts with SetBooleanFromAny
    lappend result [testobj type 1]
} {1234 0 boolean}
test obj-13.2 {SetBooleanFromAny, double to boolean special case} testobj {
    set result ""
    lappend result [testdoubleobj set 1 3.14159]
    lappend result [testbooleanobj not 1]    ;# converts with SetBooleanFromAny
    lappend result [testobj type 1]
} {3.14159 0 boolean}
test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj {
    set result ""
    foreach s {yes no true false on off} {
        teststringobj set 1 $s
        lappend result [testbooleanobj not 1]
    }
    lappend result [testobj type 1]
} {0 1 0 1 0 1 boolean}
test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj {
    set result ""
    lappend result [testintobj set 1 456]
    lappend result [testintobj div10 1]
    lappend result [testbooleanobj not 1]    ;# converts with SetBooleanFromAny
    lappend result [testobj type 1]
} {456 45 0 boolean}
test obj-13.5 {SetBooleanFromAny, error parsing string} testobj {
    set result ""
    lappend result [teststringobj set 1 abc]
    lappend result [catch {testbooleanobj not 1} msg]
    lappend result $msg
} {abc 1 {expected boolean value but got "abc"}}
test obj-13.6 {SetBooleanFromAny, error parsing string} testobj {







|








|







|











|

















|





|













|





|







|






|







149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251

test obj-9.1 {Tcl_NewBooleanObj} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testbooleanobj set 1 0]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 0 int 2}

test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testbooleanobj set 1 0]  ;# makes existing obj boolean
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} {} 0 int 2}
test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testintobj set 1 98765]
    lappend result [testbooleanobj set 1 1]  ;# makes existing obj boolean
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 98765 1 int 2}

test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} testobj {
    set result ""
    lappend result [testbooleanobj set 1 1]
    lappend result [testbooleanobj not 1]    ;# gets existing boolean rep
} {1 0}
test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} testobj {
    set result ""
    lappend result [testintobj set 1 47]
    lappend result [testbooleanobj not 1]    ;# must convert to bool
    lappend result [testobj type 1]
} {47 0 int}
test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} testobj {
    set result ""
    lappend result [teststringobj set 1 abc]
    lappend result [catch {testbooleanobj not 1} msg]
    lappend result $msg
} {abc 1 {expected boolean value but got "abc"}}
test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} testobj {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [catch {testbooleanobj not 1} msg]
    lappend result $msg
} {{} 1 {expected boolean value but got ""}}
test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} testobj {
    set result ""
    lappend result [teststringobj set 1 0xac]
    lappend result [testbooleanobj not 1]
    lappend result [testobj type 1]
} {0xac 0 int}
test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} testobj {
    set result ""
    lappend result [teststringobj set 1 5.42]
    lappend result [testbooleanobj not 1]
    lappend result [testobj type 1]
} {5.42 0 int}

test obj-12.1 {DupBooleanInternalRep} testobj {
    set result ""
    lappend result [testbooleanobj set 1 1]
    lappend result [testobj duplicate 1 2]   ;# uses DupBooleanInternalRep
    lappend result [testbooleanobj get 2]
} {1 1 1}

test obj-13.1 {SetBooleanFromAny, int to boolean special case} testobj {
    set result ""
    lappend result [testintobj set 1 1234]
    lappend result [testbooleanobj not 1]    ;# converts with SetBooleanFromAny
    lappend result [testobj type 1]
} {1234 0 int}
test obj-13.2 {SetBooleanFromAny, double to boolean special case} testobj {
    set result ""
    lappend result [testdoubleobj set 1 3.14159]
    lappend result [testbooleanobj not 1]    ;# converts with SetBooleanFromAny
    lappend result [testobj type 1]
} {3.14159 0 int}
test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj {
    set result ""
    foreach s {yes no true false on off} {
        teststringobj set 1 $s
        lappend result [testbooleanobj not 1]
    }
    lappend result [testobj type 1]
} {0 1 0 1 0 1 int}
test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj {
    set result ""
    lappend result [testintobj set 1 456]
    lappend result [testintobj div10 1]
    lappend result [testbooleanobj not 1]    ;# converts with SetBooleanFromAny
    lappend result [testobj type 1]
} {456 45 0 int}
test obj-13.5 {SetBooleanFromAny, error parsing string} testobj {
    set result ""
    lappend result [teststringobj set 1 abc]
    lappend result [catch {testbooleanobj not 1} msg]
    lappend result $msg
} {abc 1 {expected boolean value but got "abc"}}
test obj-13.6 {SetBooleanFromAny, error parsing string} testobj {
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
} {abc 1 {expected integer but got "abc"}}
test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} testobj {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [catch {testintobj div10 1} msg]
    lappend result $msg
} {{} 1 {expected integer but got ""}}
test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj nonPortable} {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [testintobj inttoobigtest 1]
} {{} 1}

test obj-24.1 {DupIntInternalRep} testobj {
    set result ""







|







419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
} {abc 1 {expected integer but got "abc"}}
test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} testobj {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [catch {testintobj div10 1} msg]
    lappend result $msg
} {{} 1 {expected integer but got ""}}
test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj} {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [testintobj inttoobigtest 1]
} {{} 1}

test obj-24.1 {DupIntInternalRep} testobj {
    set result ""
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
} {abc 1 {expected integer but got "abc"}}
test obj-25.5 {SetIntFromAny, error parsing string} testobj {
    set result ""
    lappend result [teststringobj set 1 x17]
    lappend result [catch {testintobj mult10 1} msg]
    lappend result $msg
} {x17 1 {expected integer but got "x17"}}
test obj-25.6 {SetIntFromAny, integer too large} {testobj nonPortable} {
    set result ""
    lappend result [teststringobj set 1 123456789012345678901]
    lappend result [catch {testintobj mult10 1} msg]
    lappend result $msg
} {123456789012345678901 1 {integer value too large to represent}}
test obj-25.7 {SetIntFromAny, error converting from "empty string"} testobj {
    set result ""







|







463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
} {abc 1 {expected integer but got "abc"}}
test obj-25.5 {SetIntFromAny, error parsing string} testobj {
    set result ""
    lappend result [teststringobj set 1 x17]
    lappend result [catch {testintobj mult10 1} msg]
    lappend result $msg
} {x17 1 {expected integer but got "x17"}}
test obj-25.6 {SetIntFromAny, integer too large} {testobj} {
    set result ""
    lappend result [teststringobj set 1 123456789012345678901]
    lappend result [catch {testintobj mult10 1} msg]
    lappend result $msg
} {123456789012345678901 1 {integer value too large to represent}}
test obj-25.7 {SetIntFromAny, error converting from "empty string"} testobj {
    set result ""
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
    lappend result [testobj type 2]
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
    lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs
    lappend result [testobj type 2]
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}


test obj-31.1 {regenerate string rep of "end"} testobj {
    testobj freeallvars
    teststringobj set 1 end
    testobj convert 1 end-offset
    testobj invalidateStringRep 1







|







545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
    lappend result [testobj type 2]
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
    lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs
    lappend result [testobj type 2]
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 int 3 2}


test obj-31.1 {regenerate string rep of "end"} testobj {
    testobj freeallvars
    teststringobj set 1 end
    testobj convert 1 end-offset
    testobj invalidateStringRep 1
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
} end-2147483647
test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj {
    testobj freeallvars
    teststringobj set 1 end--0x7fffffff
    testobj convert 1 end-offset
    testobj invalidateStringRep 1
} end--2147483647
test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj nonPortable} {
    testobj freeallvars
    teststringobj set 1 end--0x80000000
    testobj convert 1 end-offset
    testobj invalidateStringRep 1
} end--2147483648

test obj-32.1 {freeing very large object trees} {
    set x {}
    for {set i 0} {$i<100000} {incr i} {
	set x [list $x {}]
    }
    unset x
} {}

test obj-33.1 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x 0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x 0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
test obj-33.4 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x -0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {32bit wideBiggerThanInt} {
    set x -0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}

if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return







|














|



|



|



|



|



|



|











578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
} end-2147483647
test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj {
    testobj freeallvars
    teststringobj set 1 end--0x7fffffff
    testobj convert 1 end-offset
    testobj invalidateStringRep 1
} end--2147483647
test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} {
    testobj freeallvars
    teststringobj set 1 end--0x80000000
    testobj convert 1 end-offset
    testobj invalidateStringRep 1
} end--2147483648

test obj-32.1 {freeing very large object trees} {
    set x {}
    for {set i 0} {$i<100000} {incr i} {
	set x [list $x {}]
    }
    unset x
} {}

test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x10000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}

if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/parse.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains a collection of tests for the procedures in the
# file tclParse.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parse.test,v 1.19 2004/10/01 03:10:36 dgp Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::parse {










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains a collection of tests for the procedures in the
# file tclParse.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parse.test,v 1.19.2.1 2005/04/10 23:14:59 kennykb Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::parse {
939
940
941
942
943
944
945














































946
947
948
949
950
951
    set a
} 2
test parse-18.30 {Tcl_SubstObj, side effects} {
    set a 0
    catch {subst {foo[incr a; incr a parse error {}{}]bar}}
    set a
} 1















































    cleanupTests
}

namespace delete ::tcl::test::parse
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
    set a
} 2
test parse-18.30 {Tcl_SubstObj, side effects} {
    set a 0
    catch {subst {foo[incr a; incr a parse error {}{}]bar}}
    set a
} 1

test parse-19.1 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
    testevalex
} -setup {
    interp create i
    load {} Tcltest i
    i eval {proc {} args {}}
    interp recursionlimit i 3
} -body {
    i eval {testevalex {[]}}
} -cleanup {
    interp delete i
}

test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
    testevalex
} -setup {
    interp create i
    load {} Tcltest i
    i eval {proc {} args {}}
    interp recursionlimit i 3
} -body {
    i eval {testevalex {[[]]}}
} -cleanup {
    interp delete i
} -returnCodes error -match glob -result {too many nested*}

test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
    interp create i
    i eval {proc {} args {}}
    interp recursionlimit i 3
} -body {
    i eval {subst {[]}}
} -cleanup {
    interp delete i
}

test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
    interp create i
    i eval {proc {} args {}}
    interp recursionlimit i 3
} -body {
    i eval {subst {[[]]}}
} -cleanup {
    interp delete i
} -returnCodes error -match glob -result {too many nested*}

    cleanupTests
}

namespace delete ::tcl::test::parse
return

Changes to tests/parseExpr.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28


























































29
30
31
32
33
34
35
36
37
38
39
40
41

42

43
44
45
46
47
48
49
50
51

52

53
54
55
56
57
58
59
60
61
62
63
64
65
66

67

68
69
70
71
72
73
74
75

76

77
78
79
80
81
82

83

84
85
86
87
88
89
90
91
92
93
94
95
96
97

98

99
100
101
102
103
104

105

106
107
108
109
110
111
112
113
114
115
116
117
118
119

120

121
122
123
124
125
126

127

128
129
130
131
132
133
134
135
136
137
138
139
140
141

142

143
144
145
146
147
148

149

150
151
152
153
154
155
156
157
158
159
160
161
162
163

164

165
166
167
168
169
170

171

172
173
174
175
176
177
178
179
180
181
182
183
184
185

186

187
188
189
190
191
192

193

194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

211

212
213
214
215
216
217

218

219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

242

243
244
245
246
247
248

249

250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266

267

268
269
270
271
272
273

274

275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

292

293
294
295
296
297
298

299

300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

317

318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344

345

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
# This file contains a collection of tests for the procedures in the
# file tclParseExpr.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseExpr.test,v 1.13 2004/06/23 15:36:57 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.

testConstraint testexprparser [llength [info commands testexprparser]]

# Some tests only work if wide integers (>32bit) are not found to be
# integers at all.

testConstraint wideIntegerUnparsed [expr {-1 == 0xffffffff}]



























































######################################################################

test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser {
    testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser {
    testexprparser "1  + 2" -1
} {- {} 0 subexpr {1  + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} testexprparser {

    list [catch {testexprparser {foo+} -1} msg] $msg

} {1 {syntax error in expression "foo+": variable references require preceding $}}
test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} testexprparser {
    list [catch {testexprparser {1+2 345} -1} msg] $msg
} {1 {syntax error in expression "1+2 345": extra tokens at end of expression}}

test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} testexprparser {
    testexprparser {2>3? 1 : 0} -1
} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} testexprparser {

    list [catch {testexprparser {0 || foo} -1} msg] $msg

} {1 {syntax error in expression "0 || foo": variable references require preceding $}}
test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} testexprparser {
    testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} testexprparser {
    testexprparser {1+2 ? 3 : 4} -1
} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} testexprparser {
    testexprparser {1? 3 : 4} -1
} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} testexprparser {

    list [catch {testexprparser {1? fred : martha} -1} msg] $msg

} {1 {syntax error in expression "1? fred : martha": variable references require preceding $}}
test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} testexprparser {
    list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg
} {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}}
test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} testexprparser {
    testexprparser {27||3? 3 : 4&&9} -1
} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}}
test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} testexprparser {

    list [catch {testexprparser {1? 2 : martha} -1} msg] $msg

} {1 {syntax error in expression "1? 2 : martha": variable references require preceding $}}

test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} testexprparser {
    testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} testexprparser {

    list [catch {testexprparser {1&&foo || 3} -1} msg] $msg

} {1 {syntax error in expression "1&&foo || 3": variable references require preceding $}}
test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} testexprparser {
    testexprparser {1&&2? 1 : 0} -1
} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} testexprparser {
    testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1&&2 || 3 || 4} -1
} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg

} {1 {syntax error in expression "1&&2 || 3 || martha": variable references require preceding $}}

test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} testexprparser {
    testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} testexprparser {

    list [catch {testexprparser {1&&foo && 3} -1} msg] $msg

} {1 {syntax error in expression "1&&foo && 3": variable references require preceding $}}
test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} testexprparser {
    testexprparser {1|2? 1 : 0} -1
} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} testexprparser {
    testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1|2 && 3 && 4} -1
} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg

} {1 {syntax error in expression "1|2 && 3 && martha": variable references require preceding $}}

test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} testexprparser {
    testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} testexprparser {

    list [catch {testexprparser {1|foo | 3} -1} msg] $msg

} {1 {syntax error in expression "1|foo | 3": variable references require preceding $}}
test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} testexprparser {
    testexprparser {1^2? 1 : 0} -1
} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} testexprparser {
    testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1^2 | 3 | 4} -1
} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg

} {1 {syntax error in expression "1^2 | 3 | martha": variable references require preceding $}}

test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} testexprparser {
    testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} testexprparser {

    list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg

} {1 {syntax error in expression "1^foo ^ 3": variable references require preceding $}}
test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} testexprparser {
    testexprparser {1&2? 1 : 0} -1
} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} testexprparser {
    testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1&2 ^ 3 ^ 4} -1
} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg

} {1 {syntax error in expression "1&2 ^ 3 ^ martha": variable references require preceding $}}

test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} testexprparser {
    testexprparser {1==2 & 3} -1
} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} testexprparser {

    list [catch {testexprparser {1!=foo & 3} -1} msg] $msg

} {1 {syntax error in expression "1!=foo & 3": variable references require preceding $}}
test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} testexprparser {
    testexprparser {1==2? 1 : 0} -1
} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} testexprparser {
    testexprparser {1>2 & 3} -1
} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1<2 & 3 & 4} -1
} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg

} {1 {syntax error in expression "1==2 & 3>2 & martha": variable references require preceding $}}

test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} testexprparser {
    testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} testexprparser {

    list [catch {testexprparser {1>=foo == 3} -1} msg] $msg

} {1 {syntax error in expression "1>=foo == 3": variable references require preceding $}}
test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} testexprparser {
    testexprparser {1<2? 1 : 0} -1
} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser {
    testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser {
    testexprparser {1<2 != 3} -1
} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1<2 == 3 == 4} -1
} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg

} {1 {syntax error in expression "1<2 == 3 != martha": variable references require preceding $}}

test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} testexprparser {
    testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} testexprparser {

    list [catch {testexprparser {1>=foo < 3} -1} msg] $msg

} {1 {syntax error in expression "1>=foo < 3": variable references require preceding $}}
test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} testexprparser {
    testexprparser {1<<2? 1 : 0} -1
} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1>>2 > 3} -1
} {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1<<2 <= 3} -1
} {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1<<2 >= 3} -1
} {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1<<2 < 3 < 4} -1
} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg

} {1 {syntax error in expression "1<<2 < 3 > martha": variable references require preceding $}}

test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} testexprparser {
    testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} testexprparser {

    list [catch {testexprparser {1-foo << 3} -1} msg] $msg

} {1 {syntax error in expression "1-foo << 3": variable references require preceding $}}
test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} testexprparser {
    testexprparser {1+2? 1 : 0} -1
} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser {
    testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser {
    testexprparser {1+2 >> 3} -1
} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1+2 << 3 << 4} -1
} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg

} {1 {syntax error in expression "1+2 << 3 >> martha": variable references require preceding $}}

test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} testexprparser {

    list [catch {testexprparser {1/foo + 3} -1} msg] $msg

} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}}
test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser {
    testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg

} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}}

test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} testexprparser {

    list [catch {testexprparser {1/foo + 3} -1} msg] $msg

} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}}
test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser {
    testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg

} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}}

test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} testexprparser {
    testexprparser {+2 * 3} -1
} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} testexprparser {
    testexprparser {+2? 1 : 0} -1
} {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser {
    testexprparser {-123 * 3} -1
} {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser {
    testexprparser {+-456 / 3} -1
} {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser {
    testexprparser {+-456 % 3} -1
} {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {-2 / 3 % 4} -1
} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} testexprparser {

    list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg

} {1 {syntax error in expression "++2 / 3 * martha": variable references require preceding $}}

test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {+2} -1
} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {-2} -1
} {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {~2} -1
} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {!2} -1
} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {-12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} testexprparser {
    testexprparser {+"1234"} -1
} {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}}
test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} testexprparser {
    testexprparser {~!{fred}} -1
} {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}}
test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser {
    list [catch {testexprparser {+-||27} -1} msg] $msg
} {1 {syntax error in expression "+-||27": unexpected operator ||}}
test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser {
    list [catch {testexprparser {+-||27} -1} msg] $msg
} {1 {syntax error in expression "+-||27": unexpected operator ||}}
test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} testexprparser {
    testexprparser {123} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} testexprparser {
    testexprparser {(1+2)} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}

test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} testexprparser {
    testexprparser {({abc}/{def})} -1
} {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}}
test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} testexprparser {
    testexprparser {({abc}? 2*4 : -6)} -1
} {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}}
test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} testexprparser {
    list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg










|
















|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|


|
>
|
>
|







|
>
|
>
|






|





|
>
|
>
|






|
>
|
>
|




|
>
|
>
|






|





|
>
|
>
|




|
>
|
>
|






|





|
>
|
>
|




|
>
|
>
|






|





|
>
|
>
|




|
>
|
>
|






|





|
>
|
>
|




|
>
|
>
|






|





|
>
|
>
|




|
>
|
>
|









|





|
>
|
>
|




|
>
|
>
|















|





|
>
|
>
|




|
>
|
>
|









|





|
>
|
>
|




|
>
|
>
|









|





|
>
|
>
|




|
>
|
>
|









|





|
>
|
>
|




|














|





|
>
|
>
|













|




















|






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
# This file contains a collection of tests for the procedures in the
# file tclParseExpr.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseExpr.test,v 1.13.2.3 2005/08/02 18:16:42 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.

testConstraint testexprparser [llength [info commands testexprparser]]

# Some tests only work if wide integers (>32bit) are not found to be
# integers at all.

testConstraint wideIs32bit [expr {0x80000000 < 0}]

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}
::tcltest::testConstraint ieeeFloatingPoint [testIEEE]

######################################################################

test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser {
    testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser {
    testexprparser "1  + 2" -1
} {- {} 0 subexpr {1  + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {testexprparser wideIs32bit} {
    list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {foo+} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "foo+": *preceding $*}}
test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} testexprparser {
    list [catch {testexprparser {1+2 345} -1} msg] $msg
} {1 {syntax error in expression "1+2 345": extra tokens at end of expression}}

test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} testexprparser {
    testexprparser {2>3? 1 : 0} -1
} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} \
	-constraints testexprparser -body {
            list [catch {testexprparser {0 || foo} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "0 || foo": * preceding $*}}
test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} testexprparser {
    testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} testexprparser {
    testexprparser {1+2 ? 3 : 4} -1
} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} testexprparser {
    testexprparser {1? 3 : 4} -1
} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1? fred : martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1? fred : martha": *preceding $*}}
test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} testexprparser {
    list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg
} {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}}
test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} testexprparser {
    testexprparser {27||3? 3 : 4&&9} -1
} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}}
test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} \
    -constraints  testexprparser -body {
        list [catch {testexprparser {1? 2 : martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1? 2 : martha": * preceding $*}}

test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} testexprparser {
    testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1&&foo || 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1&&foo || 3": * preceding $*}}
test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} testexprparser {
    testexprparser {1&&2? 1 : 0} -1
} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} testexprparser {
    testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1&&2 || 3 || 4} -1
} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1&&2 || 3 || martha": * preceding $*}}

test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} testexprparser {
    testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1&&foo && 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1&&foo && 3": * preceding $*}}
test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} testexprparser {
    testexprparser {1|2? 1 : 0} -1
} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} testexprparser {
    testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1|2 && 3 && 4} -1
} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1|2 && 3 && martha": * preceding $*}}

test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} testexprparser {
    testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1|foo | 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1|foo | 3": * preceding $*}}
test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} testexprparser {
    testexprparser {1^2? 1 : 0} -1
} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} testexprparser {
    testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1^2 | 3 | 4} -1
} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1^2 | 3 | martha": * preceding $*}}

test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} testexprparser {
    testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1^foo ^ 3": * preceding $*}}
test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} testexprparser {
    testexprparser {1&2? 1 : 0} -1
} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} testexprparser {
    testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1&2 ^ 3 ^ 4} -1
} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1&2 ^ 3 ^ martha": * preceding $*}}

test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} testexprparser {
    testexprparser {1==2 & 3} -1
} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1!=foo & 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1!=foo & 3": * preceding $*}}
test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} testexprparser {
    testexprparser {1==2? 1 : 0} -1
} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} testexprparser {
    testexprparser {1>2 & 3} -1
} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1<2 & 3 & 4} -1
} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1==2 & 3>2 & martha": * preceding $*}}

test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} testexprparser {
    testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1>=foo == 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1>=foo == 3": * preceding $*}}
test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} testexprparser {
    testexprparser {1<2? 1 : 0} -1
} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser {
    testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser {
    testexprparser {1<2 != 3} -1
} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1<2 == 3 == 4} -1
} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1<2 == 3 != martha": * preceding $*}}

test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} testexprparser {
    testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1>=foo < 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1>=foo < 3": * preceding $*}}
test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} testexprparser {
    testexprparser {1<<2? 1 : 0} -1
} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1>>2 > 3} -1
} {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1<<2 <= 3} -1
} {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser {
    testexprparser {1<<2 >= 3} -1
} {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1<<2 < 3 < 4} -1
} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1<<2 < 3 > martha": * preceding $*}}

test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} testexprparser {
    testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1-foo << 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1-foo << 3": * preceding $*}}
test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} testexprparser {
    testexprparser {1+2? 1 : 0} -1
} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser {
    testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser {
    testexprparser {1+2 >> 3} -1
} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1+2 << 3 << 4} -1
} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1+2 << 3 >> martha": * preceding $*}}

test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1/foo + 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1/foo + 3": * preceding $*}}
test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser {
    testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1*2 + 3 - martha": * preceding $*}}

test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1/foo + 3} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1/foo + 3": * preceding $*}}
test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser {
    testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser {
    testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "1*2 + 3 - martha": * preceding $*}}

test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} testexprparser {
    testexprparser {+2 * 3} -1
} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {testexprparser wideIs32bit} {
    list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} testexprparser {
    testexprparser {+2? 1 : 0} -1
} {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser {
    testexprparser {-123 * 3} -1
} {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser {
    testexprparser {+-456 / 3} -1
} {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser {
    testexprparser {+-456 % 3} -1
} {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {testexprparser wideIs32bit} {
    list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser {
    testexprparser {-2 / 3 % 4} -1
} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} \
    -constraints testexprparser -body {
        list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "++2 / 3 * martha": * preceding $*}}

test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {+2} -1
} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {-2} -1
} {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {~2} -1
} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} testexprparser {
    testexprparser {!2} -1
} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {testexprparser wideIs32bit} {
    list [catch {testexprparser {-12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} testexprparser {
    testexprparser {+"1234"} -1
} {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}}
test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} testexprparser {
    testexprparser {~!{fred}} -1
} {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}}
test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser {
    list [catch {testexprparser {+-||27} -1} msg] $msg
} {1 {syntax error in expression "+-||27": unexpected operator ||}}
test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser {
    list [catch {testexprparser {+-||27} -1} msg] $msg
} {1 {syntax error in expression "+-||27": unexpected operator ||}}
test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} testexprparser {
    testexprparser {123} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} testexprparser {
    testexprparser {(1+2)} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {testexprparser wideIs32bit} {
    list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}

test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} testexprparser {
    testexprparser {({abc}/{def})} -1
} {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}}
test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIs32bit} {
    list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} testexprparser {
    testexprparser {({abc}? 2*4 : -6)} -1
} {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}}
test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} testexprparser {
    list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg
445
446
447
448
449
450
451
452
453
454
455

456

457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} testexprparser {
    testexprparser "\{  \\
 +123 \}" -1
} {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text {  } 0 backslash \\\n\  0 text {+123 } 0 {}}
test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} testexprparser {
    testexprparser {foo(123)} -1
} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}}
test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} testexprparser {

    list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg

} {1 {syntax error in expression "foo 27.4 123)": variable references require preceding $}}
test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} testexprparser {
    testexprparser {foo(27*4)} -1
} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}}
test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} testexprparser {
    list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} testexprparser {
    list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} testexprparser {
    testexprparser {foo(27-2, (-2*[foo]))} -1
} {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} testexprparser {
    list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg
} {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}}
test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} testexprparser {
    list [catch {testexprparser {123+,456} -1} msg] $msg
} {1 {syntax error in expression "123+,456": commas can only separate function arguments}}
test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} testexprparser {
    list [catch {testexprparser {123+=456} -1} msg] $msg







|


|
>
|
>
|
|














|





|







553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} testexprparser {
    testexprparser "\{  \\
 +123 \}" -1
} {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text {  } 0 backslash \\\n\  0 text {+123 } 0 {}}
test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} testexprparser {
    testexprparser {foo(123)} -1
} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}}
test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {testexprparser wideIs32bit} {
    list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} \
    -constraints testexprparser -body {
        list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg
    } -match glob \
    -result {1 {syntax error in expression "foo 27.4 123)": * preceding $*}}
test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIs32bit} {
    list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} testexprparser {
    testexprparser {foo(27*4)} -1
} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}}
test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} testexprparser {
    list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} testexprparser {
    list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} testexprparser {
    testexprparser {foo(27-2, (-2*[foo]))} -1
} {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {testexprparser wideIs32bit} {
    list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} testexprparser {
    list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg
} {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}}
test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {testexprparser wideIs32bit} {
    list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} testexprparser {
    list [catch {testexprparser {123+,456} -1} msg] $msg
} {1 {syntax error in expression "123+,456": commas can only separate function arguments}}
test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} testexprparser {
    list [catch {testexprparser {123+=456} -1} msg] $msg
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530



531
532
533
534
535
536
537
test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} testexprparser {
    testexprparser { 123 \
   } -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} testexprparser {
    testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {testexprparser wideIntegerUnparsed} {
    list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -constraints testexprparser -body {
    testexprparser {0999} -1
} -returnCodes error -match glob -result {*invalid octal number*}
test parseExpr-16.7 {GetLexeme procedure, double lexeme} testexprparser {
    testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
test parseExpr-16.8 {GetLexeme procedure, double lexeme} testexprparser {
    testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
test parseExpr-16.9 {GetLexeme procedure, double lexeme} {testexprparser nonPortable unix} {
    testexprparser {nan} -1
} {- {} 0 subexpr nan 1 text nan 0 {}}
test parseExpr-16.10 {GetLexeme procedure, double lexeme} {testexprparser nonPortable unix} {
    testexprparser {NaN} -1
} {- {} 0 subexpr NaN 1 text NaN 0 {}}
test parseExpr-16.11 {GetLexeme procedure, bad double lexeme too big} testexprparser {
    list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg
} {1 {floating-point value too large to represent}}



test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} testexprparser {
    list [catch {testexprparser {123.4x56} -1} msg] $msg
} {1 {syntax error in expression "123.4x56": extra tokens at end of expression}}
test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} testexprparser {
    testexprparser {[foo]} -1
} {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} testexprparser {







|











|


|


|


>
>
>







613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} testexprparser {
    testexprparser { 123 \
   } -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} testexprparser {
    testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {testexprparser wideIs32bit} {
    list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -constraints testexprparser -body {
    testexprparser {0999} -1
} -returnCodes error -match glob -result {*invalid octal number*}
test parseExpr-16.7 {GetLexeme procedure, double lexeme} testexprparser {
    testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
test parseExpr-16.8 {GetLexeme procedure, double lexeme} testexprparser {
    testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
test parseExpr-16.9 {GetLexeme procedure, double lexeme} {testexprparser unix} {
    testexprparser {nan} -1
} {- {} 0 subexpr nan 1 text nan 0 {}}
test parseExpr-16.10 {GetLexeme procedure, double lexeme} {testexprparser unix} {
    testexprparser {NaN} -1
} {- {} 0 subexpr NaN 1 text NaN 0 {}}
test parseExpr-16.11a {GetLexeme procedure, bad double lexeme too big} {testexprparser && !ieeeFloatingPoint} {
    list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg
} {1 {floating-point value too large to represent}}
test parseExpr-16.11b {GetLexeme procedure, bad double lexeme too big} {testexprparser && ieeeFloatingPoint} {
    list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg
} {0 {- {} 0 subexpr 123.e+99999999999999 1 text 123.e+99999999999999 0 {}}}
test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} testexprparser {
    list [catch {testexprparser {123.4x56} -1} msg] $msg
} {1 {syntax error in expression "123.4x56": extra tokens at end of expression}}
test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} testexprparser {
    testexprparser {[foo]} -1
} {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} testexprparser {

Changes to tests/regexp.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: regexp.test,v 1.25 2003/10/14 18:23:31 vincentdarley Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset foo}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: regexp.test,v 1.25.2.1 2005/05/05 17:56:19 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset foo}
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
test regexp-6.8 {regexp errors} {
    catch {unset f1}
    set f1 44
    list [catch {regexp abc abc f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-6.9 {regexp errors, -start bad int check} {
    list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {expected integer but got "bogus"}}

test regexp-7.1 {basic regsub operation} {
    list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
test regexp-7.2 {basic regsub operation} {
    list [regsub aa+ aaaxaa &111 foo] $foo
} {1 aaa111xaa}







|







216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
test regexp-6.8 {regexp errors} {
    catch {unset f1}
    set f1 44
    list [catch {regexp abc abc f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-6.9 {regexp errors, -start bad int check} {
    list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}

test regexp-7.1 {basic regsub operation} {
    list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
test regexp-7.2 {basic regsub operation} {
    list [regsub aa+ aaaxaa &111 foo] $foo
} {1 aaa111xaa}
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
test regexp-11.7 {regsub errors} {
    catch {unset f1}
    set f1 44
    list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-11.8 {regsub errors, -start bad int check} {
    list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {expected integer but got "bogus"}}
test regexp-11.9 {regsub without final variable name returns value} {
    regsub b abaca X
} {aXaca}
test regexp-11.10 {regsub without final variable name returns value} {
    regsub -all a abaca X
} {XbXcX}
test regexp-11.11 {regsub without final variable name returns value} {







|







373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
test regexp-11.7 {regsub errors} {
    catch {unset f1}
    set f1 44
    list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-11.8 {regsub errors, -start bad int check} {
    list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-11.9 {regsub without final variable name returns value} {
    regsub b abaca X
} {aXaca}
test regexp-11.10 {regsub without final variable name returns value} {
    regsub -all a abaca X
} {XbXcX}
test regexp-11.11 {regsub without final variable name returns value} {
463
464
465
466
467
468
469














470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487












488
489
490
491
492
493
494
test regexp-15.5 {regexp -start, over end of string} {
    catch {unset x}
    list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} {
    list [regexp -start 2 {^$} {}]
} {0}















test regexp-16.1 {regsub -start} {
    catch {unset x}
    list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} {
    catch {unset x}
    list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.3 {regsub -start} {
    catch {unset x}
    list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.4 {regsub -start, \A behavior} {
    set out {}
    lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
    lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}













test regexp-17.1 {regexp -inline} {
    regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
    regexp -inline (b) ababa
} {b b}







>
>
>
>
>
>
>
>
>
>
>
>
>
>


















>
>
>
>
>
>
>
>
>
>
>
>







463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
test regexp-15.5 {regexp -start, over end of string} {
    catch {unset x}
    list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} {
    list [regexp -start 2 {^$} {}]
} {0}
test regexp-15.7 {regexp -start, double option} {
    regexp -start 2 -start 0 a abc
} 1
test regexp-15.8 {regexp -start, double option} {
    regexp -start 0 -start 2 a abc
} 0
test regexp-15.9 {regexp -start, end relative index} {
    catch {unset x}
    list [regexp -start end {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.10 {regexp -start, end relative index} {
    catch {unset x}
    list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
} {1 1 3}

test regexp-16.1 {regsub -start} {
    catch {unset x}
    list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} {
    catch {unset x}
    list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.3 {regsub -start} {
    catch {unset x}
    list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.4 {regsub -start, \A behavior} {
    set out {}
    lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
    lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexp-16.5 {regsub -start, double option} {
    list [regsub -start 2 -start 0 a abc c x] $x
} {1 cbc}
test regexp-16.6 {regsub -start, double option} {
    list [regsub -start 0 -start 2 a abc c x] $x
} {0 abc}
test regexp-16.7 {regexp -start, end relative index} {
    list [regsub -start end a aaa b x] $x
} {0 aaa}
test regexp-16.8 {regexp -start, end relative index} {
    list [regsub -start end-1 a aaa b x] $x
} {1 aab}

test regexp-17.1 {regexp -inline} {
    regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
    regexp -inline (b) ababa
} {b b}

Changes to tests/regexpComp.test.

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
	list [catch {regexp abc abc f1(f2)} msg] $msg
    }
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-6.9 {regexp errors, -start bad int check} {
    evalInProc {
	list [catch {regexp -start bogus {^$} {}} msg] $msg
    }
} {1 {expected integer but got "bogus"}}

test regexpComp-7.1 {basic regsub operation} {
    evalInProc {
	list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
    }
} {1 xax111aaa222xaa}
test regexpComp-7.2 {basic regsub operation} {







|







297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
	list [catch {regexp abc abc f1(f2)} msg] $msg
    }
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-6.9 {regexp errors, -start bad int check} {
    evalInProc {
	list [catch {regexp -start bogus {^$} {}} msg] $msg
    }
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}

test regexpComp-7.1 {basic regsub operation} {
    evalInProc {
	list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
    }
} {1 xax111aaa222xaa}
test regexpComp-7.2 {basic regsub operation} {
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
	list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
    }
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-11.8 {regsub errors, -start bad int check} {
    evalInProc {
	list [catch {regsub -start bogus pattern string rep var} msg] $msg
    }
} {1 {expected integer but got "bogus"}}

# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg.  This is probably bigger than most users want... 
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
    evalInProc {







|







538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
	list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
    }
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-11.8 {regsub errors, -start bad int check} {
    evalInProc {
	list [catch {regsub -start bogus pattern string rep var} msg] $msg
    }
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}

# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg.  This is probably bigger than most users want... 
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
    evalInProc {

Changes to tests/result.test.

104
105
106
107
108
109
110













111
112
113
114
    catch {testseterrorcode \{}
    llength $errorCode
} 1
test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode {
    catch {testseterrorcode {a b} c}
    set errorCode
} {{a b} c}














# cleanup
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>




104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
    catch {testseterrorcode \{}
    llength $errorCode
} 1
test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode {
    catch {testseterrorcode {a b} c}
    set errorCode
} {{a b} c}

::tcltest::testConstraint testreturn \
	[expr {[info commands testreturn] != {}}]
test result-6.0 {Bug 1209759} -constraints testreturn -body {
    # Might panic if bug is not fixed.
    proc foo {} {testreturn}
    foo
} -returnCodes ok  -result {}
test result-6.1 {Bug 1209759} -constraints testreturn -body {
    # Might panic if bug is not fixed.
    proc foo {} {catch {return -level 2}; testreturn}
    foo
} -returnCodes ok -result {}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/safe.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23



24
25
26
27
28
29
30
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.test,v 1.17 2004/08/18 19:59:08 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

foreach i [interp slaves] {
    interp delete $i
}




# Force actual loading of the safe package 
# because we use un exported (and thus un-autoindexed) APIs
# in this test result arguments:
catch {safe::interpConfigure}

proc equiv {x} {return $x}













|










>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.test,v 1.17.2.1 2004/12/08 18:24:36 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

foreach i [interp slaves] {
    interp delete $i
}

set saveAutoPath $::auto_path
set ::auto_path [info library]

# Force actual loading of the safe package 
# because we use un exported (and thus un-autoindexed) APIs
# in this test result arguments:
catch {safe::interpConfigure}

proc equiv {x} {return $x}

474
475
476
477
478
479
480

481
482
483
    list \
	    [catch {interp eval $i encoding convertto} msg] \
	    $msg \
	    [safe::interpDelete $i];
} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}}



# cleanup
::tcltest::cleanupTests
return







>



477
478
479
480
481
482
483
484
485
486
487
    list \
	    [catch {interp eval $i encoding convertto} msg] \
	    $msg \
	    [safe::interpDelete $i];
} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}}


set ::auto_path $saveAutoPath
# cleanup
::tcltest::cleanupTests
return

Changes to tests/scan.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
# Commands covered:  scan
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: scan.test,v 1.15 2004/08/19 20:59:00 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint 64bitInts [expr {0x80000000 > 0}]


test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
    list [scan \]foo {%[]f]} x] $x
} {1 \]f}













|






|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# Commands covered:  scan
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: scan.test,v 1.15.2.5 2005/08/23 18:28:52 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
    list [scan \]foo {%[]f]} x] $x
} {1 \]f}
336
337
338
339
340
341
342
343
344
345

346
347
348
349
350
351
352
    unset z
    set result
} {1 {couldn't set variable "z"couldn't set variable "y"} abc}

# procedure that returns the range of integers

proc int_range {} {
    for { set MIN_INT 1 } { $MIN_INT > 0 } {} {
	set MIN_INT [expr { $MIN_INT << 1 }]
    }

    set MAX_INT [expr { ~ $MIN_INT }]
    return [list $MIN_INT $MAX_INT]
}

test scan-4.62 {scanning of large and negative octal integers} {
    foreach { MIN_INT MAX_INT } [int_range] {}
    set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT]







|


>







337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
    unset z
    set result
} {1 {couldn't set variable "z"couldn't set variable "y"} abc}

# procedure that returns the range of integers

proc int_range {} {
    for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} {
	set MIN_INT [expr { $MIN_INT << 1 }]
    }
    set MIN_INT [expr {int($MIN_INT)}]
    set MAX_INT [expr { ~ $MIN_INT }]
    return [list $MIN_INT $MAX_INT]
}

test scan-4.62 {scanning of large and negative octal integers} {
    foreach { MIN_INT MAX_INT } [int_range] {}
    set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT]
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonPortable} {
    set a {}; set b {};
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}
test scan-5.12 {integer scanning} {64bitInts} {
    set a {}; set b {}; set c {}
    list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
	    %ld,%lx,%lo a b c] $a $b $c
} {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
    # This test used to fail on some 64-bit systems. [Bug 1011860]
    scan {300000000 3000000000 30000000000} {%ld %ld %ld}







|







415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonPortable} {
    set a {}; set b {};
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}
test scan-5.12 {integer scanning} {wideIs64bit} {
    set a {}; set b {}; set c {}
    list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
	    %ld,%lx,%lo a b c] $a $b $c
} {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
    # This test used to fail on some 64-bit systems. [Bug 1011860]
    scan {300000000 3000000000 30000000000} {%ld %ld %ld}
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
    set a {}; set b {}; set c {}
    list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c
} {3 1.0 200.0 3.0}
test scan-6.5 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d
} {4 4.6 99999.7 87.643 118.0}
test scan-6.6 {floating-point scanning} {eformat} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d
} {4 1.2345 0.697 124.0 5e-05}
test scan-6.7 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d







|


|







449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    set a {}; set b {}; set c {}
    list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c
} {3 1.0 200.0 3.0}
test scan-6.5 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d
} {4 4.6 99999.7 87.643 118.0}
test scan-6.6 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d
} {4 1.2345 0.697 124.0 5e-5}
test scan-6.7 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
    list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
674
675
676
677
678
679
680








































































681
682
683




    scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" {%20$d %18$d %17$d %16$d %15$d %14$d %13$d %12$d %11$d %10$d %9$d %8$d %7$d %6$d %5$d %4$d %3$d %2$d %1$d}
} {190 180 170 160 150 140 130 120 110 100 90 80 70 60 50 40 30 20 {} 10}
test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} {
    set msg [scan "10 20 30" {%100$d %5$d %200$d}]
    list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199]
} {200 10 20 30}









































































# cleanup
::tcltest::cleanupTests
return











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>
>
>
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
    scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" {%20$d %18$d %17$d %16$d %15$d %14$d %13$d %12$d %11$d %10$d %9$d %8$d %7$d %6$d %5$d %4$d %3$d %2$d %1$d}
} {190 180 170 160 150 140 130 120 110 100 90 80 70 60 50 40 30 20 {} 10}
test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} {
    set msg [scan "10 20 30" {%100$d %5$d %200$d}]
    list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199]
} {200 10 20 30}

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]

# scan infinities - not working

test scan-14.1 {infinity} ieeeFloatingPoint {
    scan Inf %g d
    set d
} Inf
test scan-14.2 {infinity} ieeeFloatingPoint {
    scan -Inf %g d
    set d
} -Inf

# TODO - also need to scan NaN's

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/socket.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: socket.test,v 1.36 2004/11/18 19:22:14 dgp Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: socket.test,v 1.36.2.1 2005/08/02 18:16:43 dgp Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
}

test socket-1.1 {arg parsing for socket command} {socket} {
    list [catch {socket -server} msg] $msg
} {1 {no argument given for -server option}}
test socket-1.2 {arg parsing for socket command} {socket} {
    list [catch {socket -server foo} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.3 {arg parsing for socket command} {socket} {
    list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
test socket-1.4 {arg parsing for socket command} {socket} {
    list [catch {socket -myaddr 127.0.0.1} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.5 {arg parsing for socket command} {socket} {
    list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
test socket-1.6 {arg parsing for socket command} {socket} {
    list [catch {socket -myport xxxx} msg] $msg
} {1 {expected integer but got "xxxx"}}
test socket-1.7 {arg parsing for socket command} {socket} {
    list [catch {socket -myport 2522} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.8 {arg parsing for socket command} {socket} {
    list [catch {socket -froboz} msg] $msg
} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
test socket-1.9 {arg parsing for socket command} {socket} {
    list [catch {socket -server foo -myport 2521 3333} msg] $msg
} {1 {Option -myport is not valid for servers}}
test socket-1.10 {arg parsing for socket command} {socket} {
    list [catch {socket host 2528 -junk} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.11 {arg parsing for socket command} {socket} {
    list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
test socket-1.13 {arg parsing for socket command} {socket} {
list [catch {socket -async -server} msg] $msg
} {1 {cannot set -async option for server sockets}}
test socket-1.14 {arg parsing for socket command} {socket} {







<
|
<





<
|
<








<
|
<








<
|
<


<
|
<







197
198
199
200
201
202
203

204

205
206
207
208
209

210

211
212
213
214
215
216
217
218

219

220
221
222
223
224
225
226
227

228

229
230

231

232
233
234
235
236
237
238
}

test socket-1.1 {arg parsing for socket command} {socket} {
    list [catch {socket -server} msg] $msg
} {1 {no argument given for -server option}}
test socket-1.2 {arg parsing for socket command} {socket} {
    list [catch {socket -server foo} msg] $msg

} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}}

test socket-1.3 {arg parsing for socket command} {socket} {
    list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
test socket-1.4 {arg parsing for socket command} {socket} {
    list [catch {socket -myaddr 127.0.0.1} msg] $msg

} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}}

test socket-1.5 {arg parsing for socket command} {socket} {
    list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
test socket-1.6 {arg parsing for socket command} {socket} {
    list [catch {socket -myport xxxx} msg] $msg
} {1 {expected integer but got "xxxx"}}
test socket-1.7 {arg parsing for socket command} {socket} {
    list [catch {socket -myport 2522} msg] $msg

} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}}

test socket-1.8 {arg parsing for socket command} {socket} {
    list [catch {socket -froboz} msg] $msg
} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
test socket-1.9 {arg parsing for socket command} {socket} {
    list [catch {socket -server foo -myport 2521 3333} msg] $msg
} {1 {Option -myport is not valid for servers}}
test socket-1.10 {arg parsing for socket command} {socket} {
    list [catch {socket host 2528 -junk} msg] $msg

} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}}

test socket-1.11 {arg parsing for socket command} {socket} {
    list [catch {socket -server callback 2520 --} msg] $msg

} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}}

test socket-1.12 {arg parsing for socket command} {socket} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
test socket-1.13 {arg parsing for socket command} {socket} {
list [catch {socket -async -server} msg] $msg
} {1 {cannot set -async option for server sockets}}
test socket-1.14 {arg parsing for socket command} {socket} {

Changes to tests/string.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: string.test,v 1.43 2004/10/28 00:04:39 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] != {}}]


test string-1.1 {error conditions} {
    list [catch {string gorp a b} msg] $msg
} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}







|









>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: string.test,v 1.43.2.7 2005/08/17 04:57:49 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]

test string-1.1 {error conditions} {
    list [catch {string gorp a b} msg] $msg
} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
} 1

test string-4.1 {string first, too few args} {
    list [catch {string first a} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.2 {string first, bad args} {
    list [catch {string first a b c} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-4.3 {string first, too many args} {
    list [catch {string first a b 5 d} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.4 {string first} {
    string first bq abcdefgbcefgbqrs
} 12
test string-4.5 {string first} {







|







172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
} 1

test string-4.1 {string first, too few args} {
    list [catch {string first a} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.2 {string first, bad args} {
    list [catch {string first a b c} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-4.3 {string first, too many args} {
    list [catch {string first a b 5 d} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.4 {string first} {
    string first bq abcdefgbcefgbqrs
} 12
test string-4.5 {string first} {
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
    string index abcde 5
} {}
test string-5.6 {string index} {
    list [catch {string index abcde -10} msg] $msg
} {0 {}}
test string-5.7 {string index} {
    list [catch {string index a xyz} msg] $msg
} {1 {bad index "xyz": must be integer or end?-integer?}}
test string-5.8 {string index} {
    string index abc end
} c
test string-5.9 {string index} {
    string index abc end-1
} b
test string-5.10 {string index, unicode} {







|







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
    string index abcde 5
} {}
test string-5.6 {string index} {
    list [catch {string index abcde -10} msg] $msg
} {0 {}}
test string-5.7 {string index} {
    list [catch {string index a xyz} msg] $msg
} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
test string-5.8 {string index} {
    string index abc end
} c
test string-5.9 {string index} {
    string index abc end-1
} b
test string-5.10 {string index, unicode} {
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
test string-5.16 {string index, bytearray object with string obj shimmering} {
    set str "0123456789\x00 abcdedfghi"
    binary scan $str H* dump
    string compare [string index $str 10] \x00
} 0
test string-5.17 {string index, bad integer} {
    list [catch {string index "abc" 08} msg] $msg
} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
test string-5.18 {string index, bad integer} {
    list [catch {string index "abc" end-00289} msg] $msg
} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}}
test string-5.19 {string index, bytearray object out of bounds} {
    string index [binary format I* {0x50515253 0x52}] -1
} {}
test string-5.20 {string index, bytearray object out of bounds} {
    string index [binary format I* {0x50515253 0x52}] 20
} {}


proc largest_int {} {
    # This will give us what the largest valid int on this machine is,
    # so we can test for overflow properly below on >32 bit systems
    set int 1
    set exp 7; # assume we get at least 8 bits
    while {$int > 0} { set int [expr {wide(1) << [incr exp]}] }
    return [expr {$int-1}]
}

test string-6.1 {string is, too few args} {
    list [catch {string is} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.2 {string is, too few args} {







|


|













|







272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
test string-5.16 {string index, bytearray object with string obj shimmering} {
    set str "0123456789\x00 abcdedfghi"
    binary scan $str H* dump
    string compare [string index $str 10] \x00
} 0
test string-5.17 {string index, bad integer} {
    list [catch {string index "abc" 08} msg] $msg
} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}
test string-5.18 {string index, bad integer} {
    list [catch {string index "abc" end-00289} msg] $msg
} {1 {bad index "end-00289": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}
test string-5.19 {string index, bytearray object out of bounds} {
    string index [binary format I* {0x50515253 0x52}] -1
} {}
test string-5.20 {string index, bytearray object out of bounds} {
    string index [binary format I* {0x50515253 0x52}] 20
} {}


proc largest_int {} {
    # This will give us what the largest valid int on this machine is,
    # so we can test for overflow properly below on >32 bit systems
    set int 1
    set exp 7; # assume we get at least 8 bits
    while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] }
    return [expr {$int-1}]
}

test string-6.1 {string is, too few args} {
    list [catch {string is} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.2 {string is, too few args} {
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419


420
421
422
423
424
425
426
test string-6.36 {string is double, false} {
    list [string is double -fail var "\n"] $var
} {0 0}
test string-6.37 {string is double, false on int overflow} {
    # Make it the largest int recognizable, with one more digit for overflow
    list [string is double -fail var [largest_int]0] $var
} {0 -1}
test string-6.38 {string is double, false on underflow} {
    catch {unset var}
    list [string is double -fail var 123e-9999] $var
} {0 -1}
test string-6.39 {string is double, false} {nonPortable} {
    # This test is non-portable because IRIX thinks 
    # that .e1 is a valid double - this is really a bug
    # on IRIX as .e1 should NOT be a valid double



    list [string is double -fail var .e1] $var
} {0 0}
test string-6.40 {string is false, true} {
    string is false false
} 1
test string-6.41 {string is false, true} {







|
<
<
<
|



>
>







406
407
408
409
410
411
412
413



414
415
416
417
418
419
420
421
422
423
424
425
426
test string-6.36 {string is double, false} {
    list [string is double -fail var "\n"] $var
} {0 0}
test string-6.37 {string is double, false on int overflow} {
    # Make it the largest int recognizable, with one more digit for overflow
    list [string is double -fail var [largest_int]0] $var
} {0 -1}
# string-6.38 removed, underflow on input is no longer an error.



test string-6.39 {string is double, false} {
    # This test is non-portable because IRIX thinks 
    # that .e1 is a valid double - this is really a bug
    # on IRIX as .e1 should NOT be a valid double
    #
    # Portable now. Tcl 8.5 does its own double parsing.

    list [string is double -fail var .e1] $var
} {0 0}
test string-6.40 {string is false, true} {
    string is false false
} 1
test string-6.41 {string is false, true} {
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
catch {rename largest_int {}}

test string-7.1 {string last, too few args} {
    list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.2 {string last, bad args} {
    list [catch {string last a b c} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-7.3 {string last, too many args} {
    list [catch {string last a b c d} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.4 {string last} {
    string la xxx xxxx123xx345x678
} 1
test string-7.5 {string last} {







|







662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
catch {rename largest_int {}}

test string-7.1 {string last, too few args} {
    list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.2 {string last, bad args} {
    list [catch {string last a b c} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-7.3 {string last, too many args} {
    list [catch {string last a b c d} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.4 {string last} {
    string la xxx xxxx123xx345x678
} 1
test string-7.5 {string last} {
804
805
806
807
808
809
810
811






























812
813
814
815
816
817
818
test string-10.19 {string map, empty arguments} {
    string map -nocase {{} abc f bar {} def} foo
} baroo
test string-10.20 {string map, dictionaries can alter map ordering} {
    set map {aa X a Y}
    list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
} {YYY XY 2 XY}
test string-10.21 {string map, nasty sharing crash from [Bug 1018562]} {






























    set a {a b}
    string map $a $a
} {b b}

test string-11.1 {string match, too few args} {
    list [catch {string match a} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
test string-10.19 {string map, empty arguments} {
    string map -nocase {{} abc f bar {} def} foo
} baroo
test string-10.20 {string map, dictionaries can alter map ordering} {
    set map {aa X a Y}
    list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
} {YYY XY 2 XY}
test string-10.21 {string map, ABR checks} {
    string map {longstring foob} long
} long
test string-10.22 {string map, ABR checks} {
    string map {long foob} long
} foob
test string-10.23 {string map, ABR checks} {
    string map {lon foob} long
} foobg
test string-10.24 {string map, ABR checks} {
    string map {lon foob} longlo
} foobglo
test string-10.25 {string map, ABR checks} {
    string map {lon foob} longlon
} foobgfoob
test string-10.26 {string map, ABR checks} {
    string map {longstring foob longstring bar} long
} long
test string-10.27 {string map, ABR checks} {
    string map {long foob longstring bar} long
} foob
test string-10.28 {string map, ABR checks} {
    string map {lon foob longstring bar} long
} foobg
test string-10.29 {string map, ABR checks} {
    string map {lon foob longstring bar} longlo
} foobglo
test string-10.30 {string map, ABR checks} {
    string map {lon foob longstring bar} longlon
} foobgfoob
test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} {
    set a {a b}
    string map $a $a
} {b b}

test string-11.1 {string match, too few args} {
    list [catch {string match a} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
test string-12.4 {string range} {
    string range abcdefghijklmnop 2 14
} {cdefghijklmno}
test string-12.5 {string range, last > length} {
    string range abcdefghijklmnop 7 1000
} {hijklmnop}
test string-12.6 {string range} {
    string range abcdefghijklmnop 10 e
} {klmnop}
test string-12.7 {string range, last < first} {
    string range abcdefghijklmnop 10 9
} {}
test string-12.8 {string range, first < 0} {
    string range abcdefghijklmnop -3 2
} {abc}
test string-12.9 {string range} {
    string range abcdefghijklmnop -3 -2
} {}
test string-12.10 {string range} {
    string range abcdefghijklmnop 1000 1010
} {}
test string-12.11 {string range} {
    string range abcdefghijklmnop -100 end
} {abcdefghijklmnop}
test string-12.12 {string range} {
    list [catch {string range abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer or end?-integer?}}
test string-12.13 {string range} {
    list [catch {string range abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer or end?-integer?}}
test string-12.14 {string range} {
    string range abcdefghijklmnop end-1 end
} {op}
test string-12.15 {string range} {
    string range abcdefghijklmnop e 1000
} {p}
test string-12.16 {string range} {
    string range abcdefghijklmnop end end-1
} {}
test string-12.17 {string range, unicode} {
    string range ab\u7266cdefghijklmnop 5 5
} e







|


















|


|




|







1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
test string-12.4 {string range} {
    string range abcdefghijklmnop 2 14
} {cdefghijklmno}
test string-12.5 {string range, last > length} {
    string range abcdefghijklmnop 7 1000
} {hijklmnop}
test string-12.6 {string range} {
    string range abcdefghijklmnop 10 end
} {klmnop}
test string-12.7 {string range, last < first} {
    string range abcdefghijklmnop 10 9
} {}
test string-12.8 {string range, first < 0} {
    string range abcdefghijklmnop -3 2
} {abc}
test string-12.9 {string range} {
    string range abcdefghijklmnop -3 -2
} {}
test string-12.10 {string range} {
    string range abcdefghijklmnop 1000 1010
} {}
test string-12.11 {string range} {
    string range abcdefghijklmnop -100 end
} {abcdefghijklmnop}
test string-12.12 {string range} {
    list [catch {string range abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-12.13 {string range} {
    list [catch {string range abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
test string-12.14 {string range} {
    string range abcdefghijklmnop end-1 end
} {op}
test string-12.15 {string range} {
    string range abcdefghijklmnop end 1000
} {p}
test string-12.16 {string range} {
    string range abcdefghijklmnop end end-1
} {}
test string-12.17 {string range, unicode} {
    string range ab\u7266cdefghijklmnop 5 5
} e
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
test string-14.5 {string replace} {
    string replace abcdefghijklmnop 2 14
} {abp}
test string-14.6 {string replace} {
    string replace abcdefghijklmnop 7 1000
} {abcdefg}
test string-14.7 {string replace} {
    string replace abcdefghijklmnop 10 e
} {abcdefghij}
test string-14.8 {string replace} {
    string replace abcdefghijklmnop 10 9
} {abcdefghijklmnop}
test string-14.9 {string replace} {
    string replace abcdefghijklmnop -3 2
} {defghijklmnop}
test string-14.10 {string replace} {
    string replace abcdefghijklmnop -3 -2
} {abcdefghijklmnop}
test string-14.11 {string replace} {
    string replace abcdefghijklmnop 1000 1010
} {abcdefghijklmnop}
test string-14.12 {string replace} {
    string replace abcdefghijklmnop -100 end
} {}
test string-14.13 {string replace} {
    list [catch {string replace abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer or end?-integer?}}
test string-14.14 {string replace} {
    list [catch {string replace abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer or end?-integer?}}
test string-14.15 {string replace} {
    string replace abcdefghijklmnop end-10 end-2 NEW
} {abcdeNEWop}
test string-14.16 {string replace} {
    string replace abcdefghijklmnop 0 e foo
} {foo}
test string-14.17 {string replace} {
    string replace abcdefghijklmnop end end-1
} {abcdefghijklmnop}

test string-15.1 {string tolower too few args} {
    list [catch {string tolower} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.2 {string tolower bad args} {
    list [catch {string tolower a b} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test string-15.3 {string tolower too many args} {
    list [catch {string tolower ABC 1 end oops} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.4 {string tolower} {
    string tolower ABCDeF
} {abcdef}
test string-15.5 {string tolower} {







|


















|


|




|










|







1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
test string-14.5 {string replace} {
    string replace abcdefghijklmnop 2 14
} {abp}
test string-14.6 {string replace} {
    string replace abcdefghijklmnop 7 1000
} {abcdefg}
test string-14.7 {string replace} {
    string replace abcdefghijklmnop 10 end
} {abcdefghij}
test string-14.8 {string replace} {
    string replace abcdefghijklmnop 10 9
} {abcdefghijklmnop}
test string-14.9 {string replace} {
    string replace abcdefghijklmnop -3 2
} {defghijklmnop}
test string-14.10 {string replace} {
    string replace abcdefghijklmnop -3 -2
} {abcdefghijklmnop}
test string-14.11 {string replace} {
    string replace abcdefghijklmnop 1000 1010
} {abcdefghijklmnop}
test string-14.12 {string replace} {
    string replace abcdefghijklmnop -100 end
} {}
test string-14.13 {string replace} {
    list [catch {string replace abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14 {string replace} {
    list [catch {string replace abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.15 {string replace} {
    string replace abcdefghijklmnop end-10 end-2 NEW
} {abcdeNEWop}
test string-14.16 {string replace} {
    string replace abcdefghijklmnop 0 end foo
} {foo}
test string-14.17 {string replace} {
    string replace abcdefghijklmnop end end-1
} {abcdefghijklmnop}

test string-15.1 {string tolower too few args} {
    list [catch {string tolower} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.2 {string tolower bad args} {
    list [catch {string tolower a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-15.3 {string tolower too many args} {
    list [catch {string tolower ABC 1 end oops} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.4 {string tolower} {
    string tolower ABCDeF
} {abcdef}
test string-15.5 {string tolower} {
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
} "abcabc\xe7\xe7"

test string-16.1 {string toupper} {
    list [catch {string toupper} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2 {string toupper} {
    list [catch {string toupper a b} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test string-16.3 {string toupper} {
    list [catch {string toupper a 1 end oops} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.4 {string toupper} {
    string toupper abCDEf
} {ABCDEF}
test string-16.5 {string toupper} {







|







1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
} "abcabc\xe7\xe7"

test string-16.1 {string toupper} {
    list [catch {string toupper} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2 {string toupper} {
    list [catch {string toupper a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-16.3 {string toupper} {
    list [catch {string toupper a 1 end oops} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.4 {string toupper} {
    string toupper abCDEf
} {ABCDEF}
test string-16.5 {string toupper} {
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
} "ABCABC\xc7\xc7"

test string-17.1 {string totitle} {
    list [catch {string totitle} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2 {string totitle} {
    list [catch {string totitle a b} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test string-17.3 {string totitle} {
    string totitle abCDEf
} {Abcdef}
test string-17.4 {string totitle} {
    string totitle "abc xYz"
} {Abc xyz}
test string-17.5 {string totitle} {







|







1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
} "ABCABC\xc7\xc7"

test string-17.1 {string totitle} {
    list [catch {string totitle} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2 {string totitle} {
    list [catch {string totitle a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-17.3 {string totitle} {
    string totitle abCDEf
} {Abcdef}
test string-17.4 {string totitle} {
    string totitle "abc xYz"
} {Abc xyz}
test string-17.5 {string totitle} {
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
    list [catch {string wordend a} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.2 {string wordend} {
    list [catch {string wordend a b c} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.3 {string wordend} {
    list [catch {string wordend a gorp} msg] $msg
} {1 {bad index "gorp": must be integer or end?-integer?}}
test string-21.4 {string wordend} {
    string wordend abc. -1
} 3
test string-21.5 {string wordend} {
    string wordend abc. 100
} 4
test string-21.6 {string wordend} {







|







1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
    list [catch {string wordend a} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.2 {string wordend} {
    list [catch {string wordend a b c} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.3 {string wordend} {
    list [catch {string wordend a gorp} msg] $msg
} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-21.4 {string wordend} {
    string wordend abc. -1
} 3
test string-21.5 {string wordend} {
    string wordend abc. 100
} 4
test string-21.6 {string wordend} {
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
    list [catch {string wordstart a} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3 {string wordstart} {
    list [catch {string wordstart a b c} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4 {string wordstart} {
    list [catch {string wordstart a gorp} msg] $msg
} {1 {bad index "gorp": must be integer or end?-integer?}}
test string-22.5 {string wordstart} {
    string wordstart "one two three_words" 400
} 8
test string-22.6 {string wordstart} {
    string wordstart "one two three_words" 2
} 0
test string-22.7 {string wordstart} {







|







1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
    list [catch {string wordstart a} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3 {string wordstart} {
    list [catch {string wordstart a b c} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4 {string wordstart} {
    list [catch {string wordstart a gorp} msg] $msg
} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-22.5 {string wordstart} {
    string wordstart "one two three_words" 400
} 8
test string-22.6 {string wordstart} {
    string wordstart "one two three_words" 2
} 0
test string-22.7 {string wordstart} {
1383
1384
1385
1386
1387
1388
1389






















































1390
1391
1392
1393
1394
1395
1396
1397
} 4
test string-22.12 {string wordstart, unicode} {
    string wordstart "ab\uc700\uc700 cdef ghi" 12
} 10
test string-22.13 {string wordstart, unicode} {
    string wordstart "\uc700\uc700 abc" 8
} 3























































# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
} 4
test string-22.12 {string wordstart, unicode} {
    string wordstart "ab\uc700\uc700 cdef ghi" 12
} 10
test string-22.13 {string wordstart, unicode} {
    string wordstart "\uc700\uc700 abc" 8
} 3

test string-23.0 {string is boolean, Bug 1187123} testindexobj {
    set x 5
    catch {testindexobj $x foo bar soom}
    string is boolean $x
} 0

test string-23.1 {string is command with empty string} {
    set s ""
    list \
        [string is alnum $s] \
        [string is alpha $s] \
        [string is ascii $s] \
        [string is control $s] \
        [string is boolean $s] \
        [string is digit $s] \
        [string is double $s] \
        [string is false $s] \
        [string is graph $s] \
        [string is integer $s] \
        [string is lower $s] \
        [string is print $s] \
        [string is punct $s] \
        [string is space $s] \
        [string is true $s] \
        [string is upper $s] \
        [string is wordchar $s] \
        [string is xdigit $s] \

} {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}

test string-23.2 {string is command with empty string} {
    set s ""
    list \
        [string is alnum -strict $s] \
        [string is alpha -strict $s] \
        [string is ascii -strict $s] \
        [string is control -strict $s] \
        [string is boolean -strict $s] \
        [string is digit -strict $s] \
        [string is double -strict $s] \
        [string is false -strict $s] \
        [string is graph -strict $s] \
        [string is integer -strict $s] \
        [string is lower -strict $s] \
        [string is print -strict $s] \
        [string is punct -strict $s] \
        [string is space -strict $s] \
        [string is true -strict $s] \
        [string is upper -strict $s] \
        [string is wordchar -strict $s] \
        [string is xdigit -strict $s] \

} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/stringComp.test.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#
# Copyright (c) 2001 by ActiveState Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stringComp.test,v 1.8 2004/05/25 18:58:05 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testobj command







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#
# Copyright (c) 2001 by ActiveState Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stringComp.test,v 1.8.2.1 2005/05/05 17:56:36 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testobj command
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
test stringComp-4.1 {string first, too few args} {
    proc foo {} {string first a}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test stringComp-4.2 {string first, bad args} {
    proc foo {} {string first a b c}
    list [catch {foo} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test stringComp-4.3 {string first, too many args} {
    proc foo {} {string first a b 5 d}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test stringComp-4.4 {string first} {
    proc foo {} {string first bq abcdefgbcefgbqrs}
    foo







|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
test stringComp-4.1 {string first, too few args} {
    proc foo {} {string first a}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test stringComp-4.2 {string first, bad args} {
    proc foo {} {string first a b c}
    list [catch {foo} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test stringComp-4.3 {string first, too many args} {
    proc foo {} {string first a b 5 d}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test stringComp-4.4 {string first} {
    proc foo {} {string first bq abcdefgbcefgbqrs}
    foo
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
test stringComp-5.6 {string index} {
    proc foo {} {string index abcde -10}
    list [catch {foo} msg] $msg
} {0 {}}
test stringComp-5.7 {string index} {
    proc foo {} {string index a xyz}
    list [catch {foo} msg] $msg
} {1 {bad index "xyz": must be integer or end?-integer?}}
test stringComp-5.8 {string index} {
    proc foo {} {string index abc end}
    foo
} c
test stringComp-5.9 {string index} {
    proc foo {} {string index abc end-1}
    foo







|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
test stringComp-5.6 {string index} {
    proc foo {} {string index abcde -10}
    list [catch {foo} msg] $msg
} {0 {}}
test stringComp-5.7 {string index} {
    proc foo {} {string index a xyz}
    list [catch {foo} msg] $msg
} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
test stringComp-5.8 {string index} {
    proc foo {} {string index abc end}
    foo
} c
test stringComp-5.9 {string index} {
    proc foo {} {string index abc end-1}
    foo
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
	string compare [string index $str 10] \x00
    }
    foo
} 0
test stringComp-5.17 {string index, bad integer} {
    proc foo {} {string index "abc" 08}
    list [catch {foo} msg] $msg
} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
test stringComp-5.18 {string index, bad integer} {
    proc foo {} {string index "abc" end-00289}
    list [catch {foo} msg] $msg
} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}}
test stringComp-5.19 {string index, bytearray object out of bounds} {
    proc foo {} {string index [binary format I* {0x50515253 0x52}] -1}
    foo
} {}
test stringComp-5.20 {string index, bytearray object out of bounds} {
    proc foo {} {string index [binary format I* {0x50515253 0x52}] 20}
    foo







|



|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
	string compare [string index $str 10] \x00
    }
    foo
} 0
test stringComp-5.17 {string index, bad integer} {
    proc foo {} {string index "abc" 08}
    list [catch {foo} msg] $msg
} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}
test stringComp-5.18 {string index, bad integer} {
    proc foo {} {string index "abc" end-00289}
    list [catch {foo} msg] $msg
} {1 {bad index "end-00289": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}}
test stringComp-5.19 {string index, bytearray object out of bounds} {
    proc foo {} {string index [binary format I* {0x50515253 0x52}] -1}
    foo
} {}
test stringComp-5.20 {string index, bytearray object out of bounds} {
    proc foo {} {string index [binary format I* {0x50515253 0x52}] 20}
    foo

Changes to tests/switch.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  switch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: switch.test,v 1.10 2003/12/14 18:32:36 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test switch-1.1 {simple patterns} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  switch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: switch.test,v 1.10.2.2 2005/07/12 20:37:12 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test switch-1.1 {simple patterns} {
35
36
37
38
39
40
41












42
43
44
45
46
47
48
} 2
test switch-1.6 {simple patterns} {
    switch default a {format 1} default {format 2} c {format 3} default {format 4}
} 2
test switch-1.7 {simple patterns} {
    switch x a {format 1} default {format 2} c {format 3} default {format 4}
} 4













test switch-2.1 {single-argument form for pattern/command pairs} {
    switch b {
	a {format 1}
	b {format 2}
	default {format 6}
    }







>
>
>
>
>
>
>
>
>
>
>
>







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
} 2
test switch-1.6 {simple patterns} {
    switch default a {format 1} default {format 2} c {format 3} default {format 4}
} 2
test switch-1.7 {simple patterns} {
    switch x a {format 1} default {format 2} c {format 3} default {format 4}
} 4
test switch-1.8 {simple patterns with -nocase} {
    switch -nocase b a {format 1} b {format 2} c {format 3} default {format 4}
} 2
test switch-1.9 {simple patterns with -nocase} {
    switch -nocase B a {format 1} b {format 2} c {format 3} default {format 4}
} 2
test switch-1.10 {simple patterns with -nocase} {
    switch -nocase b a {format 1} B {format 2} c {format 3} default {format 4}
} 2
test switch-1.11 {simple patterns with -nocase} {
    switch -nocase x a {format 1} default {format 2} c {format 3} default {format 4}
} 4

test switch-2.1 {single-argument form for pattern/command pairs} {
    switch b {
	a {format 1}
	b {format 2}
	default {format 6}
    }
85
86
87
88
89
90
91
92
































































93
94
95
96
97
98
99
	-*	{concat glob}
	-glob	{concat exact}
	default {concat none}
    }
} exact
test switch-3.6 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -foo a b c} msg] $msg
} {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -regexp, or --}}

































































test switch-4.1 {error in executed command} {
    list [catch {switch a a {error "Just a test"} default {format 1}} msg] \
	    $msg $errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
	-*	{concat glob}
	-glob	{concat exact}
	default {concat none}
    }
} exact
test switch-3.6 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -foo a b c} msg] $msg
} {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}}
test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -exact -nocase aaaab {
	^a*b$	{concat regexp}
	*b	{concat glob}
	aaaab	{concat exact}
	default	{concat none}
    }
} exact
test switch-3.8 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -regexp -nocase aaaab {
	^a*b$	{concat regexp}
	*b	{concat glob}
	aaaab	{concat exact}
	default	{concat none}
    }
} regexp
test switch-3.9 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -glob -nocase aaaab {
	^a*b$	{concat regexp}
	*b	{concat glob}
	aaaab	{concat exact}
	default	{concat none}
    }
} glob
test switch-3.10 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -nocase aaaab {^a*b$} {concat regexp} *b {concat glob} \
	    aaaab {concat exact} default {concat none}
} exact
test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -nocase -- -glob {
	^g.*b$	{concat regexp}
	-*	{concat glob}
	-glob	{concat exact}
	default {concat none}
    }
} exact

test switch-3.7 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -exa Foo Foo {set result OK}} msg] $msg
} {0 OK}

test switch-3.8 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -gl Foo Fo? {set result OK}} msg] $msg
} {0 OK}

test switch-3.9 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -re Foo Fo. {set result OK}} msg] $msg
} {0 OK}

test switch-3.10 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -exact -exact Foo Foo {set result OK}} msg] $msg
} {1 {bad option "-exact": -exact option already found}}

test switch-3.11 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -exact -glob Foo Foo {set result OK}} msg] $msg
} {1 {bad option "-glob": -exact option already found}}

test switch-3.12 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -glob -regexp Foo Foo {set result OK}} msg] $msg
} {1 {bad option "-regexp": -glob option already found}}

test switch-3.13 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -regexp -glob Foo Foo {set result OK}} msg] $msg
} {1 {bad option "-glob": -regexp option already found}}

test switch-4.1 {error in executed command} {
    list [catch {switch a a {error "Just a test"} default {format 1}} msg] \
	    $msg $errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""
168
169
170
171
172
173
174









175
176
177
178
179
180
181
182
183


















184
185
186
187
188
189
190
	switch a {
	    a -
	    b -foo
	    c -
	}
    } msg] $msg
} {1 {no body specified for pattern "c"}}










test switch-8.1 {empty body} {
    set msg {}
    switch {2} {
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}



















test switch-9.1 {empty pattern/body list} {
    list [catch {switch x} msg] $msg
} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
test switch-9.2 {empty pattern/body list} {
    list [catch {switch -- x} msg] $msg
} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}







>
>
>
>
>
>
>
>
>









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
	switch a {
	    a -
	    b -foo
	    c -
	}
    } msg] $msg
} {1 {no body specified for pattern "c"}}
test switch-7.4 {"-" bodies} {
    list [catch {
	switch a {
	    a -
	    b -foo
	    c {}
	}
    } msg] $msg
} {1 {invalid command name "-foo"}}

test switch-8.1 {empty body} {
    set msg {}
    switch {2} {
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}

proc test_switch_body {} {
    return "INVOKED"
}

test switch-8.2 {weird body text, variable} {
    set cmd {test_switch_body}
    switch Foo {
    	Foo $cmd
    }
} {INVOKED}

test switch-8.3 {weird body text, variable} {
    set cmd {test_switch_body}
    switch Foo {
    	Foo {$cmd}
    }
} {INVOKED}

test switch-9.1 {empty pattern/body list} {
    list [catch {switch x} msg] $msg
} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
test switch-9.2 {empty pattern/body list} {
    list [catch {switch -- x} msg] $msg
} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
252
253
254
255
256
257
258




259
260
261
262
263







264
265
266
267
268
269
270
271
272
273
274
275




276
277
278
279
280







281
282
283
284
285
286
287
288
289
290
291
292
293




294
295
296
297
298








299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320







321








322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
    set x 0; set y 0
    foreach c [split $s {}] {
	switch -glob -- $c {
	    a {incr x}
	    b {incr y}
	}
    }




    return $x,$y
}
proc iswtest-glob s {
    set x 0; set y 0
    foreach c [split $s {}] {







	switch -glob -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc cswtest-exact s {
    set x 0; set y 0
    foreach c [split $s {}] {
	switch -exact -- $c {
	    a {incr x}
	    b {incr y}
	}
    }




    return $x,$y
}
proc iswtest-exact s {
    set x 0; set y 0
    foreach c [split $s {}] {







	switch -exact -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc cswtest2-glob s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -glob -- $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }




    return $x,$y,$z
}
proc iswtest2-glob s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {








	switch -glob -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc cswtest2-exact s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -exact -- $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    return $x,$y,$z
}
proc iswtest2-exact s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -exact -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
















test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} {
    expr {[cswtest-exact abcb] eq [iswtest-exact abcb]}
} 1
test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} {
    expr {[cswtest-glob abcb] eq [iswtest-glob abcb]}
} 1
test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} {
    expr {[cswtest2-exact abcb] eq [iswtest2-exact abcb]}
} 1
test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} {
    expr {[cswtest2-glob abcb] eq [iswtest2-glob abcb]}
} 1
proc cswtest-default-exact {x} {
    switch -- $x {
	a* {return b}
	aa {return c}
	default {return d}
    }
}







>
>
>
>



|

>
>
>
>
>
>
>
|











>
>
>
>



|

>
>
>
>
>
>
>
|












>
>
>
>



|

>
>
>
>
>
>
>
>
|












<
<
<
|





>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>

|
|

|
|

|
|

|
|







355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448



449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
    set x 0; set y 0
    foreach c [split $s {}] {
	switch -glob -- $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	switch -glob -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc iswtest-glob s {
    set x 0; set y 0; set switch switch
    foreach c [split $s {}] {
	$switch -glob -- $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	$switch -glob -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc cswtest-exact s {
    set x 0; set y 0
    foreach c [split $s {}] {
	switch -exact -- $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	switch -exact -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc iswtest-exact s {
    set x 0; set y 0; set switch switch
    foreach c [split $s {}] {
	$switch -exact -- $c {
	    a {incr x}
	    b {incr y}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]
    foreach c [split $s {}] {
	$switch -exact -- $c a {incr x} b {incr y}
    }
    return $x,$y
}
proc cswtest2-glob s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -glob -- $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	switch -glob -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc iswtest2-glob s {
    set x 0; set y 0; set z 0; set switch switch
    foreach c [split $s {}] {
	$switch -glob -- $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	$switch -glob -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc cswtest2-exact s {
    set x 0; set y 0; set z 0
    foreach c [split $s {}] {
	switch -exact -- $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }



    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	switch -exact -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}
proc iswtest2-exact s {
    set x 0; set y 0; set z 0; set switch switch
    foreach c [split $s {}] {
	$switch -exact -- $c {
	    a {incr x}
	    b {incr y}
	    default {incr z}
	}
    }
    set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}]
    foreach c [split $s {}] {
	$switch -exact -- $c a {incr x} b {incr y} default {incr z}
    }
    return $x,$y,$z
}

test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} {
    cswtest-exact abcb
} [iswtest-exact abcb]
test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} {
    cswtest-glob abcb
} [iswtest-glob abcb]
test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} {
    cswtest2-exact abcb
} [iswtest2-exact abcb]
test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} {
    cswtest2-glob abcb
} [iswtest2-glob abcb]
proc cswtest-default-exact {x} {
    switch -- $x {
	a* {return b}
	aa {return c}
	default {return d}
    }
}

Changes to tests/tcltest.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation. 
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.48 2004/11/25 16:17:09 rmax Exp $

# Note that there are several places where the value of 
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself.  Ditto on things like [verbose].
#








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation. 
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.48.2.1 2005/03/09 15:57:19 kennykb Exp $

# Note that there are several places where the value of 
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself.  Ditto on things like [verbose].
#
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725

file delete -force $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} -constraints {unixOrPc} -setup {
    set old [testsDirectory]
    testsDirectory [file dirname [info script]]
} -body {
    slave msg [file join [testsDirectory] all.tcl] -file a*.test
    set msg
} -cleanup {
    testsDirectory $old
} -match regexp -result {assocd\.test}

test tcltest-9.2 {-file a*.tcl} -constraints {unixOrPc} -setup {
    set old [testsDirectory]
    testsDirectory [file dirname [info script]]
} -body {
    slave msg [file join [testsDirectory] all.tcl] \
	    -file a*.test -notfile assocd*
    regexp {assocd\.test} $msg
} -cleanup {
    testsDirectory $old
} -result 0

test tcltest-9.3 {matchFiles}  {
    -body {
	set old [matchFiles]







|



|



|

|




|
|







695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725

file delete -force $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
    set old [testsDirectory]
    testsDirectory [file dirname [info script]]
} -body {
    slave msg [file join [testsDirectory] all.tcl] -file d*.test
    set msg
} -cleanup {
    testsDirectory $old
} -match regexp -result {dstring\.test}

test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
    set old [testsDirectory]
    testsDirectory [file dirname [info script]]
} -body {
    slave msg [file join [testsDirectory] all.tcl] \
	    -file d*.test -notfile dstring*
    regexp {dstring\.test} $msg
} -cleanup {
    testsDirectory $old
} -result 0

test tcltest-9.3 {matchFiles}  {
    -body {
	set old [matchFiles]
741
742
743
744
745
746
747















748
749
750
751
752
753
754
	skipFiles bar
	set new [skipFiles]
	skipFiles $old
	list $current $new
    } 
    -result {foo bar}
}
















# -preservecore, [preserveCore]
set mc [makeFile {
    package require tcltest
    namespace import ::tcltest::test
    test makecore {make a core file} {
	set f [open core w]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
	skipFiles bar
	set new [skipFiles]
	skipFiles $old
	list $current $new
    } 
    -result {foo bar}
}

test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
    set d [makeDirectory tmp]
    makeDirectory foo $d
    makeFile {} fee $d
    file copy [file join [file dirname [info script]] all.tcl] $d
} -body {
    slave msg [file join [temporaryDirectory] all.tcl] -file f*
    regexp {exiting with errors:} $msg
} -cleanup {
    file delete [file join $d all.tcl]
    removeFile fee $d
    removeDirectory foo $d
    removeDirectory tmp
} -result 0

# -preservecore, [preserveCore]
set mc [makeFile {
    package require tcltest
    namespace import ::tcltest::test
    test makecore {make a core file} {
	set f [open core w]

Changes to tests/tm.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# This file contains tests for the ::tcl::tm::* commands.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 2004 by Donal K. Fellows.
# All rights reserved.
#
# RCS: @(#) $Id: tm.test,v 1.5 2004/11/05 09:21:46 dkf Exp $

package require Tcl 8.5
if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# This file contains tests for the ::tcl::tm::* commands.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 2004 by Donal K. Fellows.
# All rights reserved.
#
# RCS: @(#) $Id: tm.test,v 1.5.2.1 2005/09/09 18:48:40 dgp Exp $

package require Tcl 8.5
if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

200
201
202
203
204
205
206
207
208

209
210
211
212
213
214
215


proc genpaths {base} {
    # Normalizing picks up drive letters on windows [Bug 1053568]
    set base [file normalize $base]
    foreach {major minor} [split [info tclversion] .] break
    set results {}
    lappend results [file join $base site-tcl]
    set base [file join $base tcl$major]

    for {set i 0} {$i <= $minor} {incr i} {
	lappend results [file join $base ${major}.$i]
    }
    return $results
}

test tm-3.12 {tm: module path management, roots} -setup {







<

>







200
201
202
203
204
205
206

207
208
209
210
211
212
213
214
215


proc genpaths {base} {
    # Normalizing picks up drive letters on windows [Bug 1053568]
    set base [file normalize $base]
    foreach {major minor} [split [info tclversion] .] break
    set results {}

    set base [file join $base tcl$major]
    lappend results [file join $base site-tcl]
    for {set i 0} {$i <= $minor} {incr i} {
	lappend results [file join $base ${major}.$i]
    }
    return $results
}

test tm-3.12 {tm: module path management, roots} -setup {

Changes to tests/trace.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.37 2004/11/15 21:47:23 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testcmdtrace [llength [info commands testcmdtrace]]













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.37.2.2 2005/08/02 18:16:43 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testcmdtrace [llength [info commands testcmdtrace]]
2200
2201
2202
2203
2204
2205
2206












































2207
2208
2209
2210
2211
2212
2213
2214
test trace-33.1 {variable match with remove variable} {
    unset -nocomplain x
    trace variable x w foo
    trace remove variable x write foo
    llength [trace info variable x]
} 0













































test trace-34.1 {527164: Keep -errorinfo of traces} -setup {
    unset -nocomplain x y
} -body {
    trace add variable x write {error foo;#}
    trace add variable y write {set x 2;#}
    list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo]
} -cleanup {
    unset -nocomplain x y







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|







2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
test trace-33.1 {variable match with remove variable} {
    unset -nocomplain x
    trace variable x w foo
    trace remove variable x write foo
    llength [trace info variable x]
} 0

test trace-34.1 {Bug 1201035} {
    set ::x [list]
    proc foo {} {lappend ::x foo}
    proc bar args {
        lappend ::x $args
        trace remove execution foo leavestep bar
        trace remove execution foo enterstep bar
        trace add execution foo leavestep bar
        trace add execution foo enterstep bar
        lappend ::x done
    }
    trace add execution foo leavestep bar
    trace add execution foo enterstep bar
    foo
    set ::x
} {{{lappend ::x foo} enterstep} done foo}

test trace-34.2 {Bug 1224585} {
    proc foo {} {}
    proc bar args {trace remove execution foo leave soom}
    trace add execution foo leave bar
    trace add execution foo leave soom
    foo
} {}

test trace-34.3 {Bug 1224585} {
    proc foo {} {set x {}}
    proc bar args {trace remove execution foo enterstep soom}
    trace add execution foo enterstep soom
    trace add execution foo enterstep bar
    foo
} {}

test trace-34.4 {Bug 1047286} {
    variable x notrace
    proc callback {old - -} {
        variable x "$old exists: [namespace which -command $old]"
    }
    namespace eval ::foo {proc bar {} {}}
    trace add command ::foo::bar delete [namespace code callback]
    namespace delete ::foo
    set x
} {::foo::bar exists: ::foo::bar}

test trace-35.1 {527164: Keep -errorinfo of traces} -setup {
    unset -nocomplain x y
} -body {
    trace add variable x write {error foo;#}
    trace add variable y write {set x 2;#}
    list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo]
} -cleanup {
    unset -nocomplain x y

Changes to tests/unixInit.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.44 2004/11/30 19:34:51 dgp Exp $

package require tcltest 2
namespace import -force ::tcltest::*
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} {
    set x {}












|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.44.2.3 2005/05/05 17:56:37 kennykb Exp $

package require tcltest 2.2
namespace import -force ::tcltest::*
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} {
    set x {}
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124
125
    } then {
	subst "OK"
    } else {
	subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
    }
} {OK}

proc getlibpath [list [list program [interpreter]]] {
    set f [open "|[list $program]" w+]
    fconfigure $f -buffering none
    puts $f {puts $::tcl::LibPath; exit}
    set path [gets $f]
    close $f
    return $path
}

# Some tests require the testgetdefenc command

testConstraint testgetdefenc [llength [info commands testgetdefenc]]

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
	{unix testgetdefenc} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}

test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -constraints {
    unix stdio
} -setup {
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
	unset env(TCL_LIBRARY)
    }
} -body {
    set path [getlibpath]







|
|
<
<
<
|
<
|
|
<

<
<
|
<






>
|
<
<







88
89
90
91
92
93
94
95
96



97

98
99

100


101

102
103
104
105
106
107
108
109


110
111
112
113
114
115
116
    } then {
	subst "OK"
    } else {
	subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
    }
} {OK}

# The unixInit-2.* tests were written to test the internal routine,
# TclpInitLibraryPath.  That routine no longer does the things it used



# to do so those tests are obsolete.  Skip them.


skip [concat [skip] unixInit-2.*]




test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {

    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}

test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup {


    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
	unset env(TCL_LIBRARY)
    }
} -body {
    set path [getlibpath]
134
135
136
137
138
139
140

141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
    set x
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result {0 0}

test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -constraints {
    unix stdio 
} -setup {
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
} -body {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result "sparkly"

test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -constraints {
    unix stdio 
} -setup {
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
} -body {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]

test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -constraints {
    unix stdio knownBug
} -setup {
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
} -body {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unix} {
    # cannot test
} {}

test unixInit-2.6 {TclpInitLibraryPath: executable relative} -constraints {
    unix stdio
} -setup {
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    makeDirectory tmp
    makeDirectory [file join tmp sparkly]







>
|
<
<


















>
|
<
<


















>
|
<
<


















|
<


>
|
<
<







125
126
127
128
129
130
131
132
133


134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153


154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173


174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

193
194
195
196


197
198
199
200
201
202
203
    set x
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result {0 0}

test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup {


    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
} -body {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result "sparkly"

test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup {


    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
} -body {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]

test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup {


    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
} -body {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} -cleanup {
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} {

    # cannot test
} {}

test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup {


    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    makeDirectory tmp
    makeDirectory [file join tmp sparkly]
234
235
236
237
238
239
240
241
242
243
244
245

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
    unset env(TCL_LIBRARY)
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]

test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unix} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}

#
# The following two tests write to the directory /tmp/sparkly instead
# of to [temporaryDirectory].  This is because the failures tested by
# these tests need paths near the "root" of the file system to present
# themselves.
#
testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}]
testConstraint noTmpInstall [expr {![file exists \
				[file join /tmp lib tcl[info tclversion]]]}]
test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -constraints {
    unix noSparkly noTmpInstall
} -setup {
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    # Checking for Bug 219416
    # When a program that embeds the Tcl library, like tcltest, is







|
<



>






<
<
<
|
<
<







220
221
222
223
224
225
226
227

228
229
230
231
232
233
234
235
236
237



238


239
240
241
242
243
244
245
    unset env(TCL_LIBRARY)
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]

test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} {

    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}

#
# The following two tests write to the directory /tmp/sparkly instead
# of to [temporaryDirectory].  This is because the failures tested by
# these tests need paths near the "root" of the file system to present
# themselves.
#



test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup {


    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    # Checking for Bug 219416
    # When a program that embeds the Tcl library, like tcltest, is
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
    if {$deletelib} {file delete -force /tmp/lib}
    unset env(TCL_LIBRARY)
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result 1
testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}]
test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -constraints {
    unix noSparkly noTmpBuild
} -setup {
    # Checking for Bug 438014
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    file delete -force /tmp/sparkly







|
|
<
<







292
293
294
295
296
297
298
299
300


301
302
303
304
305
306
307
    if {$deletelib} {file delete -force /tmp/lib}
    unset env(TCL_LIBRARY)
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result 1

test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup {


    # Checking for Bug 438014
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    file delete -force /tmp/sparkly
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
        /tmp/library /library /tcl[info patchlevel]/library]

test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints {
	unix stdio 
} -setup {
    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    set tmpDir [makeDirectory tmp]
    set sparklyDir [makeDirectory sparkly $tmpDir]







|
<
<







320
321
322
323
324
325
326
327


328
329
330
331
332
333
334
    if {[info exists oldlibrary]} {
	set env(TCL_LIBRARY) $oldlibrary
	unset oldlibrary
    }
} -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
        /tmp/library /library /tcl[info patchlevel]/library]

test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup {


    unset -nocomplain oldlibrary
    if {[info exists env(TCL_LIBRARY)]} {
	set oldlibrary $env(TCL_LIBRARY)
    }
    set env(TCL_LIBRARY) [info library]
    set tmpDir [makeDirectory tmp]
    set sparklyDir [makeDirectory sparkly $tmpDir]
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} {
} {}

test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
	unix stdio
} -body {
    set tclsh [interpreter]
    makeFile {puts [open /dev/null]} crash.tcl
    makeFile "
	close stdin
	[list exec $tclsh [file join [temporaryDirectory] crash.tcl]]
    " crashtest.tcl
    exec $tclsh [file join [temporaryDirectory] crashtest.tcl]
} -cleanup {
    removeFile crash.tcl
    removeFile crashtest.tcl
} -returnCodes 0

# cleanup
catch {unset env(LANG)}
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
return








|
|

|
|
|












425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} {
} {}

test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
	unix stdio
} -body {
    set tclsh [interpreter]
    set crash [makeFile {puts [open /dev/null]} crash.tcl]
    set crashtest [makeFile "
	close stdin
	[list exec $tclsh $crash]
    " crashtest.tcl]
    exec $tclsh $crashtest
} -cleanup {
    removeFile crash.tcl
    removeFile crashtest.tcl
} -returnCodes 0

# cleanup
catch {unset env(LANG)}
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
return

Changes to tests/unixNotfy.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

27
28

29
30
31
32
33
34
35
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.17 2004/06/24 10:34:12 dkf Exp $

# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# When run in a Tk shell, these tests hang.
testConstraint noTk       [expr {![info exists tk_version]}]
testConstraint testthread [expr {[info commands testthread] != {}}]

testConstraint unthreaded [expr {
    ![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)

}]

# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.
test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body {
    catch {vwait x}












|













>

|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.17.2.1 2005/05/21 15:10:27 kennykb Exp $

# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# When run in a Tk shell, these tests hang.
testConstraint noTk       [expr {![info exists tk_version]}]
testConstraint testthread [expr {[info commands testthread] != {}}]
# Darwin always uses a threaded notifier
testConstraint unthreaded [expr {
    (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
    && $tcl_platform(os) ne "Darwin"
}]

# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.
test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body {
    catch {vwait x}

Changes to tests/utf.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31



32
33
34
35
36
37
38
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: utf.test,v 1.12 2003/10/08 15:24:21 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset x}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
    set x "\x00"
} [bytestring "\xc0\x80"]
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
    set x "\xe0"
} [bytestring "\xc3\xa0"]
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
    set x "\u4e4e"
} [bytestring "\xe4\xb9\x8e"]




test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
    string length "abc"
} {3}
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
    string length [bytestring "\x82\x83\x84"]
} {3}










|




















>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: utf.test,v 1.12.2.1 2005/09/09 18:48:40 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset x}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
    set x "\x00"
} [bytestring "\xc0\x80"]
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
    set x "\xe0"
} [bytestring "\xc3\xa0"]
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
    set x "\u4e4e"
} [bytestring "\xe4\xb9\x8e"]
test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
    string length [format %c -1]
} 1

test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
    string length "abc"
} {3}
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
    string length [bytestring "\x82\x83\x84"]
} {3}

Changes to tests/util.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15




































































16
17
18
19
20
21
22
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: util.test,v 1.14 2004/05/19 20:15:32 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}





































































test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
    lindex {0 foo\x00help} 1
} "foo\x00help"









|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: util.test,v 1.14.2.4 2005/05/21 15:10:27 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}
::tcltest::testConstraint ieeeFloatingPoint [testIEEE]

proc convertDouble { x } {
    variable ieeeValues
    if { $ieeeValues(littleEndian) } {
	binary scan [binary format w $x] d result
    } else {
	binary scan [binary format W $x] d result
    }
    return $result
}

test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
    lindex {0 foo\x00help} 1
} "foo\x00help"
269
270
271
272
273
274
275
276



277


278
279



280


281
282



283


284
285

286

287
288
289


290
291
292
293
294
295
296
297


298
299
300
301


302
303


304
305
306
307
308
309


310
311


312
313
314
315
316
317
318


319
320


321
322


323
324
325
326
327
328
329
330
331
332
test util-5.50 {Tcl_StringMatch} {
    Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
    Wrapper_Tcl_StringMatch "" ""
} 1

test util-6.1 {Tcl_PrintDouble - using tcl_precision} {



    concat x[expr 1.4]


} {x1.4}
test util-6.2 {Tcl_PrintDouble - using tcl_precision} {



    concat x[expr 1.39999999999]


} {x1.39999999999}
test util-6.3 {Tcl_PrintDouble - using tcl_precision} {



    concat x[expr 1.399999999999]


} {x1.4}
test util-6.4 {Tcl_PrintDouble - using tcl_precision} {

    set tcl_precision 5

    concat x[expr 1.123412341234]
} {x1.1234}
set tcl_precision 12


test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
    concat x[expr 2.0]
} {x2.0}
test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {eformat} {
    concat x[expr 3.0e98]
} {x3e+98}

test util-7.1 {TclPrecTraceProc - unset callbacks} {


    set tcl_precision 7
    set x $tcl_precision
    unset tcl_precision
    list $x $tcl_precision


} {7 7}
test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} {


    set tcl_precision 12
    interp create child
    set x [child eval set tcl_precision]
    child eval {set tcl_precision 6}
    interp delete child
    list $x $tcl_precision


} {12 6}
test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} {


    set tcl_precision 12
    interp create -safe child
    set x [child eval {
	list [catch {set tcl_precision 8} msg] $msg
    }]
    interp delete child
    list $x $tcl_precision


} {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12}
test util-7.4 {TclPrecTraceProc - write traces, bogus values} {


    set tcl_precision 12
    list [catch {set tcl_precision abc} msg] $msg $tcl_precision


} {1 {can't set "tcl_precision": improper value for precision} 12}

set tcl_precision 12

# This test always succeeded in the C locale anyway...
test util-8.1 {TclNeedSpace - correct UTF8 handling} {
    # Bug 411825
    # Note that this test relies on the fact that
    # [interp target] calls on Tcl_AppendElement()
    # which calls on TclNeedSpace().  If [interp target]







|
>
>
>

>
>
|
|
>
>
>

>
>
|
|
>
>
>

>
>
|
|
>
|
>

|
|
>
>



|



|
>
>




>
>
|
|
>
>






>
>
|
|
>
>







>
>
|
|
>
>


>
>
|
<
<







337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426


427
428
429
430
431
432
433
test util-5.50 {Tcl_StringMatch} {
    Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
    Wrapper_Tcl_StringMatch "" ""
} 1

test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup {
    set old_precision $::tcl_precision
    set ::tcl_precision 12
} -body {
    concat x[expr 1.4]
} -cleanup {
    set ::tcl_precision $old_precision
} -result {x1.4}
test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup {
    set old_precision $::tcl_precision
    set ::tcl_precision 12
} -body {
    concat x[expr 1.39999999999]
} -cleanup {
    set ::tcl_precision $old_precision
} -result {x1.39999999999}
test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup {
    set old_precision $::tcl_precision
    set ::tcl_precision 12
} -body {
    concat x[expr 1.399999999999]
} -cleanup {
    set ::tcl_precision $old_precision
} -result {x1.4}
test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup {
    set old_precision $::tcl_precision
    set ::tcl_precision 5
} -body {
    concat x[expr 1.123412341234]
} -cleanup {
    set tcl_precision $old_precision
} -result {x1.1234}

test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
    concat x[expr 2.0]
} {x2.0}
test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {
    concat x[expr 3.0e98]
} {x3e+98}

test util-7.1 {TclPrecTraceProc - unset callbacks} -setup {
    set old_precision $::tcl_precision
} -body {
    set tcl_precision 7
    set x $tcl_precision
    unset tcl_precision
    list $x $tcl_precision
} -cleanup {
    set ::tcl_precision $old_precision
} -result {7 7}
test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters}  -setup {
    set old_precision $::tcl_precision
} -body {
    set tcl_precision 12
    interp create child
    set x [child eval set tcl_precision]
    child eval {set tcl_precision 6}
    interp delete child
    list $x $tcl_precision
} -cleanup {
    set ::tcl_precision $old_precision
} -result {12 6}
test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup {
    set old_precision $::tcl_precision
} -body {
    set tcl_precision 12
    interp create -safe child
    set x [child eval {
	list [catch {set tcl_precision 8} msg] $msg
    }]
    interp delete child
    list $x $tcl_precision
} -cleanup {
    set ::tcl_precision $old_precision
} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12}
test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup {
    set old_precision $::tcl_precision
} -body {
    set tcl_precision 12
    list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} -cleanup {
    set ::tcl_precision $old_precision
} -result {1 {can't set "tcl_precision": improper value for precision} 12}



# This test always succeeded in the C locale anyway...
test util-8.1 {TclNeedSpace - correct UTF8 handling} {
    # Bug 411825
    # Note that this test relies on the fact that
    # [interp target] calls on Tcl_AppendElement()
    # which calls on TclNeedSpace().  If [interp target]
383
384
385
386
387
388
389












































































































































































































































































































































































































































































































































































































































390
391
392
393
    testdstring free
    testdstring append {\\ } -1
    testdstring append \{ -1
    testdstring element foo
    testdstring append \} -1
    list [llength [testdstring get]] [string length [testdstring get]]
} {2 9}













































































































































































































































































































































































































































































































































































































































# cleanup
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
    testdstring free
    testdstring append {\\ } -1
    testdstring append \{ -1
    testdstring element foo
    testdstring append \} -1
    list [llength [testdstring get]] [string length [testdstring get]]
} {2 9}

test util-9.0.0 {TclGetIntForIndex} {
    string index abcd 0
} a
test util-9.0.1 {TclGetIntForIndex} {
    string index abcd 0x0
} a
test util-9.0.2 {TclGetIntForIndex} {
    string index abcd -0x0
} a
test util-9.0.3 {TclGetIntForIndex} {
    string index abcd { 0 }
} a
test util-9.0.4 {TclGetIntForIndex} {
    string index abcd { 0x0 }
} a
test util-9.0.5 {TclGetIntForIndex} {
    string index abcd { -0x0 }
} a
test util-9.0.6 {TclGetIntForIndex} {
    string index abcd 01
} b
test util-9.0.7 {TclGetIntForIndex} {
    string index abcd { 01 }
} b
test util-9.1.0 {TclGetIntForIndex} {
    string index abcd 3
} d
test util-9.1.1 {TclGetIntForIndex} {
    string index abcd { 3 }
} d
test util-9.1.2 {TclGetIntForIndex} {
    string index abcdefghijk 0xa
} k
test util-9.1.3 {TclGetIntForIndex} {
    string index abcdefghijk { 0xa }
} k
test util-9.2.0 {TclGetIntForIndex} {
    string index abcd end
} d 
test util-9.2.1 {TclGetIntForIndex} -body {
    string index abcd { end}
} -returnCodes error -match glob -result *
test util-9.2.2 {TclGetIntForIndex} -body {
    string index abcd {end }
} -returnCodes error -match glob -result *
test util-9.3 {TclGetIntForIndex} {
    # Deprecated
    string index abcd en
} d
test util-9.4 {TclGetIntForIndex} {
    # Deprecated
    string index abcd e
} d
test util-9.5.0 {TclGetIntForIndex} {
    string index abcd end-1
} c
test util-9.5.1 {TclGetIntForIndex} {
    string index abcd {end-1 }
} c
test util-9.5.2 {TclGetIntForIndex} -body {
    string index abcd { end-1}
} -returnCodes error -match glob -result *
test util-9.6 {TclGetIntForIndex} {
    string index abcd end+-1
} c
test util-9.7 {TclGetIntForIndex} {
    string index abcd end+1
} {}
test util-9.8 {TclGetIntForIndex} {
    string index abcd end--1
} {}
test util-9.9.0 {TclGetIntForIndex} {
    string index abcd 0+0
} a
test util-9.9.1 {TclGetIntForIndex} {
    string index abcd { 0+0 }
} a
test util-9.10 {TclGetIntForIndex} {
    string index abcd 0-0
} a
test util-9.11 {TclGetIntForIndex} {
    string index abcd 1+0
} b
test util-9.12 {TclGetIntForIndex} {
    string index abcd 1-0
} b
test util-9.13 {TclGetIntForIndex} {
    string index abcd 1+1
} c
test util-9.14 {TclGetIntForIndex} {
    string index abcd 1-1
} a
test util-9.15 {TclGetIntForIndex} {
    string index abcd -1+2
} b
test util-9.16 {TclGetIntForIndex} {
    string index abcd -1--2
} b
test util-9.17 {TclGetIntForIndex} {
    string index abcd { -1+2 }
} b
test util-9.18 {TclGetIntForIndex} {
    string index abcd { -1--2 }
} b
test util-9.19 {TclGetIntForIndex} -body {
    string index a {}
} -returnCodes error -match glob -result *
test util-9.20 {TclGetIntForIndex} -body {
    string index a { }
} -returnCodes error -match glob -result *
test util-9.21 {TclGetIntForIndex} -body {
    string index a " \r\t\n"
} -returnCodes error -match glob -result *
test util-9.22 {TclGetIntForIndex} -body {
    string index a +
} -returnCodes error -match glob -result *
test util-9.23 {TclGetIntForIndex} -body {
    string index a -
} -returnCodes error -match glob -result *
test util-9.24 {TclGetIntForIndex} -body {
    string index a x
} -returnCodes error -match glob -result *
test util-9.25 {TclGetIntForIndex} -body {
    string index a +x
} -returnCodes error -match glob -result *
test util-9.26 {TclGetIntForIndex} -body {
    string index a -x
} -returnCodes error -match glob -result *
test util-9.27 {TclGetIntForIndex} -body {
    string index a 0y
} -returnCodes error -match glob -result *
test util-9.28 {TclGetIntForIndex} -body {
    string index a 1*
} -returnCodes error -match glob -result *
test util-9.29 {TclGetIntForIndex} -body {
    string index a 0+
} -returnCodes error -match glob -result *
test util-9.30 {TclGetIntForIndex} -body {
    string index a {0+ }
} -returnCodes error -match glob -result *
test util-9.31 {TclGetIntForIndex} -body {
    string index a 0x
} -returnCodes error -match glob -result *
test util-9.32 {TclGetIntForIndex} -body {
    string index a 0x1FFFFFFFF+0
} -returnCodes error -match glob -result *
test util-9.33 {TclGetIntForIndex} -body {
    string index a 100000000000+0
} -returnCodes error -match glob -result *
test util-9.34 {TclGetIntForIndex} -body {
    string index a 1.0
} -returnCodes error -match glob -result *
test util-9.35 {TclGetIntForIndex} -body {
    string index a 1e23
} -returnCodes error -match glob -result *
test util-9.36 {TclGetIntForIndex} -body {
    string index a 1.5e2
} -returnCodes error -match glob -result *
test util-9.37 {TclGetIntForIndex} -body {
    string index a 0+x
} -returnCodes error -match glob -result *
test util-9.38 {TclGetIntForIndex} -body {
    string index a 0+0x
} -returnCodes error -match glob -result *
test util-9.39 {TclGetIntForIndex} -body {
    string index a 0+0xg
} -returnCodes error -match glob -result *
test util-9.40 {TclGetIntForIndex} -body {
    string index a 0+0xg
} -returnCodes error -match glob -result *
test util-9.41 {TclGetIntForIndex} -body {
    string index a 0+1.0
} -returnCodes error -match glob -result *
test util-9.42 {TclGetIntForIndex} -body {
    string index a 0+1e2
} -returnCodes error -match glob -result *
test util-9.43 {TclGetIntForIndex} -body {
    string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {TclGetIntForIndex} -body {
    string index a 0+1000000000000
} -returnCodes error -match glob -result *

test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x8000000000000000
} {-0.0}
test util-10.3 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x7ef754e31cd072da
} {4e+303}
test util-10.4 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xd08afcef51f0fb5f
} {-1e+80}
test util-10.5 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x7ed754e31cd072da
} {1e+303}
test util-10.6 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xfee754e31cd072da
} {-2e+303}
test util-10.7 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x0afe07b27dd78b14
} {1e-255}
test util-10.8 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x93ae29e9c56687fe
} {-7e-214}
test util-10.9 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x376be03d0bf225c7
} {1e-41}
test util-10.10 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xa0ca2fe76a3f9475
} {-1e-150}
test util-10.11 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x7fa9a2028368022e
} {9e+306}
test util-10.12 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xdfc317e5ef3ab327
} {-2e+153}
test util-10.13 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x5fd317e5ef3ab327
} {4e+153}
test util-10.14 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xdfe317e5ef3ab327
} {-8e+153}
test util-10.15 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x00feb8e84fa0b278
} {7e-304}
test util-10.16 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x8133339131c46f8b
} {-7e-303}
test util-10.17 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x35dc0f92a6276c9d
} {3e-49}
test util-10.18 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xa445ce1f143d7ad2
} {-6e-134}
test util-10.19 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x2d2c0794d9d40e96
} {4.3e-91}
test util-10.20 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xad3c0794d9d40e96
} {-8.6e-91}
test util-10.21 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x30ecd5bee57763e6
} {5.1e-73}
test util-10.22 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x68ad1c26db7d0dae
} {1.7e+196}
test util-10.23 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbfa3f7ced916872b
} {-0.039}
test util-10.24 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x64b7d93193f78fc6
} {1.51e+177}
test util-10.25 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x98ea82a1631eeb30
} {-1.19e-188}
test util-10.26 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xd216c309024bab4b
} {-2.83e+87}
test util-10.27 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x0dfdbbac6f83a821
} {2.7869147e-241}
test util-10.28 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xdadc569e968e0944
} {-4.91080654e+129}
test util-10.29 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x5acc569e968e0944
} {2.45540327e+129}
test util-10.30 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xab5fc575867314ee
} {-9.078555839e-100}
test util-10.31 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xdabc569e968e0944
} {-1.227701635e+129}
test util-10.32 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x2b6fc575867314ee
} {1.8157111678e-99}
test util-10.33 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xb3b8bf7e7fa6f02a
} {-1.5400733123779e-59}
test util-10.34 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xcd83de005bd620df
} {-2.6153245263757307e+65}
test util-10.35 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x6cdf92bacb3cb40c
} {2.7210404151224248e+216}
test util-10.36 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xecef92bacb3cb40c
} {-5.4420808302448496e+216}
test util-10.37 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x49342dbf25096cf5
} {4.5e+44}
test util-10.38 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xd06afcef51f0fb5f
} {-2.5e+79}
test util-10.39 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x49002498ea6df0c4
} {4.5e+43}
test util-10.40 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xfeb754e31cd072da
} {-2.5e+302}
test util-10.41 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x1d22deac01e2b4f7
} {2.5e-168}
test util-10.42 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xaccb1df536c13eee
} {-6.5e-93}
test util-10.43 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3650711fed5b19a4
} {4.5e-47}
test util-10.44 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xb6848d67e8b1e00d
} {-4.5e-46}
test util-10.45 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4bac8c574c0c6be7
} {3.5e+56}
test util-10.46 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xccd756183c147514
} {-1.5e+62}
test util-10.47 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4ca2ab469676c410
} {1.5e+61}
test util-10.48 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xcf5539684e774b48
} {-1.5e+74}
test util-10.49 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x2e12e5f5dfa4fe9d
} {9.5e-87}
test util-10.50 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x8b9bdc2417bf7787
} {-9.5e-253}
test util-10.51 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x00eeb8e84fa0b278
} {3.5e-304}
test util-10.52 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xadde3cbc9907fdc8
} {-9.5e-88}
test util-10.53 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x2bb0ad836f269a17
} {3.05e-98}
test util-10.54 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x950b39ae1909c31b
} {-2.65e-207}
test util-10.55 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x1bfb2ab18615fcc6
} {6.865e-174}
test util-10.56 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x98f3e1f90a573064
} {-1.785e-188}
test util-10.57 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x5206c309024bab4b
} {1.415e+87}
test util-10.58 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xcc059bd3ad46e346
} {-1.6955e+58}
test util-10.59 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x47bdf4170f0fdecc
} {3.9815e+37}
test util-10.60 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x59e7e1e0f1c7a4ac
} {1.263005e+125}
test util-10.61 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xda1dda592e398dd7
} {-1.263005e+126}
test util-10.62 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xdc4e597c0b94b7ae
} {-4.4118455e+136}
test util-10.63 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x5aac569e968e0944
} {6.138508175e+128}
test util-10.64 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xdabc569e968e0944
} {-1.227701635e+129}
test util-10.65 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x6ce7ae0c186d8709
} {4.081560622683637e+216}
test util-10.66 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x44b52d02c7e14af7
} {1.0000000000000001e+23}
test util-10.67 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc589d971e4fe8402
} {-1e+27}
test util-10.68 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4599d971e4fe8402
} {2e+27}
test util-10.69 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc5a9d971e4fe8402
} {-4e+27}
test util-10.70 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3e45798ee2308c3a
} {1e-8}
test util-10.71 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbe55798ee2308c3a
} {-2e-8}
test util-10.72 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3e65798ee2308c3a
} {4e-8}
test util-10.73 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbabef2d0f5da7dd9
} {-1e-25}
test util-10.74 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x44da784379d99db4
} {5e+23}
test util-10.75 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc4fa784379d99db4
} {-2e+24}
test util-10.76 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4503da329b633647
} {3e+24}
test util-10.77 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc54cf389cd46047d
} {-7e+25}
test util-10.78 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3fc999999999999a
} {0.2}
test util-10.79 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbfd3333333333333
} {-0.3}
test util-10.80 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3cf6849b86a12b9b
} {5e-15}
test util-10.81 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbd16849b86a12b9b
} {-2e-14}
test util-10.82 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3b87ccfc73126788
} {6.3e-22}
test util-10.83 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbbbdc03b8fd7016a
} {-6.3e-21}
test util-10.84 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3fa3f7ced916872b
} {0.039}
test util-10.85 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x460b297cad9f70b6
} {2.69e+29}
test util-10.86 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc61b297cad9f70b6
} {-5.38e+29}
test util-10.87 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3adcdc06b20ef183
} {3.73e-25}
test util-10.88 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x45fb297cad9f70b6
} {1.345e+29}
test util-10.89 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc60b297cad9f70b6
} {-2.69e+29}
test util-10.90 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbc050a246ecd44f3
} {-1.4257e-19}
test util-10.91 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbec19b96f36ec68b
} {-2.09901e-6}
test util-10.92 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3dcc06d366394441
} {5.0980203373e-11}
test util-10.93 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc79f58ac4db68c90
} {-1.04166211811e+37}
test util-10.94 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4569d971e4fe8402
} {2.5e+26}
test util-10.95 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc50dc74be914d16b
} {-4.5e+24}
test util-10.96 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4534adf4b7320335
} {2.5e+25}
test util-10.97 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc54ae22487c1042b
} {-6.5e+25}
test util-10.98 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3c987fe49aab41e0
} {8.5e-17}
test util-10.99 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbc2f5c05e4b23fd7
} {-8.5e-19}
test util-10.100 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3d5faa7ab552a552
} {4.5e-13}
test util-10.101 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbdbb7cdfd9d7bdbb
} {-2.5e-11}
test util-10.102 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x44f3da329b633647
} {1.5e+24}
test util-10.103 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc53cf389cd46047d
} {-3.5e+25}
test util-10.104 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x454f04ef12cb04cf
} {7.5e+25}
test util-10.105 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc55f04ef12cb04cf
} {-1.5e+26}
test util-10.106 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3fc3333333333333
} {0.15}
test util-10.107 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbdb07e1fe91b0b70
} {-1.5e-11}
test util-10.108 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3de49da7e361ce4c
} {1.5e-10}
test util-10.109 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbe19c511dc3a41df
} {-1.5e-9}
test util-10.110 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc5caa83d74267822
} {-1.65e+28}
test util-10.111 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x4588f1d5969453de
} {9.65e+26}
test util-10.112 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3b91d9bd564dcda6
} {9.45e-22}
test util-10.113 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbcfa58973ecbede6
} {-5.85e-15}
test util-10.114 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x45eb297cad9f70b6
} {6.725e+28}
test util-10.115 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc5fb297cad9f70b6
} {-1.345e+29}
test util-10.116 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3accdc06b20ef183
} {1.865e-25}
test util-10.117 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xbd036071dcae4565
} {-8.605e-15}
test util-10.118 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x462cb968d297dde8
} {1.137885e+30}
test util-10.119 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0xc661f3e1839eeab1
} {-1.137885e+31}
test util-10.120 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x474e9cec176c96f8
} {3.179033335e+35}
test util-10.121 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x3dbc06d366394441
} {2.54901016865e-11}
test util-10.122 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
    convertDouble 0x478f58ac4db68c90
} {5.20831059055e+36}

test util-11.1 {Tcl_PrintDouble - scaling} {
    expr 1.1e-5
} {1.1e-5}
test util-11.2 {Tcl_PrintDouble - scaling} {
    expr 1.1e-4
} {0.00011}
test util-11.3 {Tcl_PrintDouble - scaling} {
    expr 1.1e-3
} {0.0011}
test util-11.4 {Tcl_PrintDouble - scaling} {
    expr 1.1e-2
} {0.011}
test util-11.5 {Tcl_PrintDouble - scaling} {
    expr 1.1e-1
} {0.11}
test util-11.6 {Tcl_PrintDouble - scaling} {
    expr 1.1e0
} {1.1}
test util-11.7 {Tcl_PrintDouble - scaling} {
    expr 1.1e1
} {11.0}
test util-11.8 {Tcl_PrintDouble - scaling} {
    expr 1.1e2
} {110.0}
test util-11.9 {Tcl_PrintDouble - scaling} {
    expr 1.1e3
} {1100.0}
test util-11.10 {Tcl_PrintDouble - scaling} {
    expr 1.1e4
} {11000.0}
test util-11.11 {Tcl_PrintDouble - scaling} {
    expr 1.1e5
} {110000.0}
test util-11.12 {Tcl_PrintDouble - scaling} {
    expr 1.1e6
} {1100000.0}
test util-11.13 {Tcl_PrintDouble - scaling} {
    expr 1.1e7
} {11000000.0}
test util-11.14 {Tcl_PrintDouble - scaling} {
    expr 1.1e8
} {110000000.0}
test util-11.15 {Tcl_PrintDouble - scaling} {
    expr 1.1e9
} {1100000000.0}
test util-11.16 {Tcl_PrintDouble - scaling} {
    expr 1.1e10
} {11000000000.0}
test util-11.17 {Tcl_PrintDouble - scaling} {
    expr 1.1e11
} {110000000000.0}
test util-11.18 {Tcl_PrintDouble - scaling} {
    expr 1.1e12
} {1100000000000.0}
test util-11.19 {Tcl_PrintDouble - scaling} {
    expr 1.1e13
} {11000000000000.0}
test util-11.20 {Tcl_PrintDouble - scaling} {
    expr 1.1e14
} {110000000000000.0}
test util-11.21 {Tcl_PrintDouble - scaling} {
    expr 1.1e15
} {1100000000000000.0}
test util-11.22 {Tcl_PrintDouble - scaling} {
    expr 1.1e16
} {11000000000000000.0}
test util-11.23 {Tcl_PrintDouble - scaling} {
    expr 1.1e17
} {1.1e+17}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/winDde.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winDde.test,v 1.26 2004/12/01 14:02:49 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    #tcltest::configure -verbose {pass start}
    namespace import -force ::tcltest::*
}












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winDde.test,v 1.26.2.1 2005/01/20 14:53:40 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    #tcltest::configure -verbose {pass start}
    namespace import -force ::tcltest::*
}

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
    dde eval "" "foo"
} -returnCodes error -result {invalid service name ""}

# -------------------------------------------------------------------------

test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body {
    dde servername -z -z -z
} -returnCodes error -result {unknown option "-z": should be -force, -handler or --}
test winDde-6.2 {DDE servername set name} -constraints {win dde} -body {
    dde servername -- winDde-6.2
} -result {winDde-6.2}
test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body {
    dde servername -force winDde-6.3
} -result {winDde-6.3}
test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body {







|







215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
    dde eval "" "foo"
} -returnCodes error -result {invalid service name ""}

# -------------------------------------------------------------------------

test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body {
    dde servername -z -z -z
} -returnCodes error -result {bad option "-z": must be -force, -handler, or --}
test winDde-6.2 {DDE servername set name} -constraints {win dde} -body {
    dde servername -- winDde-6.2
} -result {winDde-6.2}
test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body {
    dde servername -force winDde-6.3
} -result {winDde-6.3}
test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body {

Changes to tests/winFCmd.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFCmd.test,v 1.35 2004/10/07 14:50:23 vincentdarley Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFCmd.test,v 1.35.2.2 2005/04/10 23:15:16 kennykb Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

1095
1096
1097
1098
1099
1100
1101

























































1102
1103
1104
1105
1106
1107
1108
    }
} -cleanup {
    cd $pwd
} -result "permission denied"

cd $pwd
unset d dd pwd


























































# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
#    foreach chmodsrc {000 755} {
#        foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
#	    foreach chmoddst {000 755} {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
    }
} -cleanup {
    cd $pwd
} -result "permission denied"

cd $pwd
unset d dd pwd

test winFCmd-18.1 {Windows reserved path names} -constraints win -body {
    file pathtype com1
} -result "absolute"

test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body {
    file pathtype com4
} -result "absolute"

test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body {
    file pathtype com5
} -result "relative"

test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body {
    file pathtype lpt3
} -result "absolute"

test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body {
    file pathtype lpt4
} -result "relative"

test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body {
    file pathtype nul
} -result "absolute"

test winFCmd-18.1.7 {Windows reserved path names} -constraints win -body {
    file pathtype null
} -result "relative"

test winFCmd-18.2 {Windows reserved path names} -constraints win -body {
    file pathtype com1:
} -result "absolute"

test winFCmd-18.3 {Windows reserved path names} -constraints win -body {
    file pathtype COM1
} -result "absolute"

test winFCmd-18.4 {Windows reserved path names} -constraints win -body {
    file pathtype CoM1:
} -result "absolute"

test winFCmd-18.5 {Windows reserved path names} -constraints win -body {
    file normalize com1:
} -result COM1

test winFCmd-18.6 {Windows reserved path names} -constraints win -body {
    file normalize COM1:
} -result COM1

test winFCmd-18.7 {Windows reserved path names} -constraints win -body {
    file normalize cOm1
} -result COM1

test winFCmd-18.8 {Windows reserved path names} -constraints win -body {
    file normalize cOm1:
} -result COM1


# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
#    foreach chmodsrc {000 755} {
#        foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
#	    foreach chmoddst {000 755} {

Changes to tests/winFile.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFile.test,v 1.16 2004/11/08 19:19:27 davygrvy Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}
namespace import -force ::tcltest::*













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFile.test,v 1.16.2.1 2005/10/08 13:44:39 dgp Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}
namespace import -force ::tcltest::*

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
    set tail [file tail $tryname]
    set dirtext [exec cmd /c dir /q [file nativename $fname]]
    set owner ""
    foreach line [split $dirtext "\n"] {
	if {[string match -nocase "* $tail" $line]} {
	    set attrs [string range $line \
	      0 end-[string length $tail]]
	    regexp { [A-Z]+\\.*$} $attrs owner
	    set owner [string trim $owner]
	}
    }
    if {"" == "$owner"} {
	error "getuser: Owner not found in output of dir/q"
    }
    return $owner







|







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
    set tail [file tail $tryname]
    set dirtext [exec cmd /c dir /q [file nativename $fname]]
    set owner ""
    foreach line [split $dirtext "\n"] {
	if {[string match -nocase "* $tail" $line]} {
	    set attrs [string range $line \
	      0 end-[string length $tail]]
	    regexp { [^ \\]+\\.*$} $attrs owner
	    set owner [string trim $owner]
	}
    }
    if {"" == "$owner"} {
	error "getuser: Owner not found in output of dir/q"
    }
    return $owner

Added tools/fix_tommath_h.tcl.













































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
# fixtommath.tcl --
#
#	Changes to 'tommath.h' to make it conform with Tcl's linking
#	conventions.
#
# Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fix_tommath_h.tcl,v 1.1.2.1 2005/01/20 19:13:56 kennykb Exp $
#
#----------------------------------------------------------------------

set f [open [lindex $argv 0] r]
set data [read $f]
close $f

foreach line [split $data \n] {
    switch -regexp -- $line {
	{#define BN_H_} {
	    puts $line
	    puts {}
	    puts "\#ifdef TCL_TOMMATH"
	    puts "\#include <tclTomMath.h>"
	    puts "\#endif"
	    puts "\#ifndef TOMMATH_STORAGE_CLASS"
	    puts "\#define TOMMATH_STORAGE_CLASS extern"
	    puts "\#endif"
	}
	{typedef.*mp_digit;} {
	    puts "\#ifndef MP_DIGIT_DECLARED"
	    puts $line
	    puts "\#define MP_DIGIT_DECLARED"
	    puts "\#endif"
	}
	{typedef struct} {
	    puts "\#ifndef MP_INT_DECLARED"
	    puts "\#define MP_INT_DECLARED"
	    puts "typedef struct mp_int mp_int;"
	    puts "\#endif"
	    puts "struct mp_int \{"
	}
	\}\ mp_int\; {
	    puts "\};"
	}
	"^(char|int|void)" {
	    puts "TOMMATH_STORAGE_CLASS $line"
	}
	default {
	    puts $line
	}
    }
}

Changes to tools/genStubs.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.17 2004/03/17 18:14:18 das Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.17.2.1 2005/09/15 20:58:40 dgp Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] \







|







367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "([lindex $arg 0][lindex $arg 1], ...)"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] \
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

    append text "/* Slot $index */\n" $rtype "\n" $fname

    set arg1 [lindex $args 0]

    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " TCL_VARARGS_DEF($type,$argName)\n\{\n"
	append text "    " $type " var;\n    va_list argList;\n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;\n"
	}
	append text "\n    var = (" $type ") TCL_VARARGS_START(" \
		$type "," $argName ",argList);\n\n    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
	append text "    va_end(argList);\n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;\n"







|




|
|







460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

    append text "/* Slot $index */\n" $rtype "\n" $fname

    set arg1 [lindex $args 0]

    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " ($type$argName, ...)\n\{\n"
	append text "    " $type " var;\n    va_list argList;\n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;\n"
	}
	append text "\n    var = (" $type ") (va_start(argList, " \
		$argName "), " $argName ");\n\n    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
	append text "    va_end(argList);\n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;\n"
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] \
			[lindex $arg 2]
		set sep ", "







|







529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "([lindex $arg 0][lindex $arg 1], ...)"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] \
			[lindex $arg 2]
		set sep ", "

Changes to tools/loadICU.tcl.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
#
#----------------------------------------------------------------------
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: loadICU.tcl,v 1.1 2004/08/18 19:59:09 kennykb Exp $
#
#----------------------------------------------------------------------

# Calculate the Chinese numerals from zero to ninety-nine.

set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \
		  \u4e94 \u516d \u4e03 \u516b \u4e5d]







|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
#
#----------------------------------------------------------------------
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: loadICU.tcl,v 1.1.4.1 2005/10/08 13:45:04 dgp Exp $
#
#----------------------------------------------------------------------

# Calculate the Chinese numerals from zero to ninety-nine.

set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \
		  \u4e94 \u516d \u4e03 \u516b \u4e5d]
613
614
615
616
617
618
619
620
621
622
foreach { icudir msgdir } $argv break

# Walk the ICU files and create corresponding Tcl message catalogs

foreach fileName [glob -directory $icudir *.txt] {
    set n [file rootname [file tail $fileName]]
    if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } {
	handleLocaleFile $n $fileName [file join $msgdir ${n}.msg]
    }
}







|


613
614
615
616
617
618
619
620
621
622
foreach { icudir msgdir } $argv break

# Walk the ICU files and create corresponding Tcl message catalogs

foreach fileName [glob -directory $icudir *.txt] {
    set n [file rootname [file tail $fileName]]
    if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } {
	handleLocaleFile $n $fileName [file join $msgdir [string tolower $n].msg]
    }
}

Changes to tools/makeTestCases.tcl.

1
2
3
4
5

6
7
8
9
10
11
12
# TODO - When integrating this with the Core, path names will need to be
# swizzled here.

package require newclock
set d [file dirname [file dirname [info script]]]

source [file join $d library/tzdata/America/Detroit]

namespace eval ::tcl::clock {
    ::msgcat::mcmset en_US_roman {
	LOCALE_ERAS {
	    {-62164627200 {} 0}
	    {-59008867200 c 100}



|

>







1
2
3
4
5
6
7
8
9
10
11
12
13
# TODO - When integrating this with the Core, path names will need to be
# swizzled here.

package require msgcat
set d [file dirname [file dirname [info script]]]
puts "getting transition data from [file join $d library tzdata America Detroit]"
source [file join $d library/tzdata/America/Detroit]

namespace eval ::tcl::clock {
    ::msgcat::mcmset en_US_roman {
	LOCALE_ERAS {
	    {-62164627200 {} 0}
	    {-59008867200 c 100}
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
    puts $f2 {}
    puts $f2 "\# Test formatting of Daylight Saving Time"
    puts $f2 {}
    
    set fmt {%H:%M:%S %z %Z}
    
    set i 0
    puts $f2 "::tcltest::testConstraint detroit 0"
    puts $f2 "test clock-5.[incr i] {does Detroit exist} {"
    puts $f2 "    clock format 0 -format {} -timezone :America/Detroit"
    puts $f2 "    ::tcltest::testConstraint detroit 1"
    puts $f2 "    concat"
    puts $f2 "} {}"
    puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {"
    puts $f2 "    if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {"
    puts $f2 "        concat {y2038 problem}"
    puts $f2 "    } else {"
    puts $f2 "        ::tcltest::testConstraint y2038 1"
    puts $f2 "        concat {ok}"
    puts $f2 "    }"
    puts $f2 "} ok"
  
    foreach row $TZData(:America/Detroit) {
	foreach { t offset isdst tzname } $row break
	if { $t > -4000000000000 } {







<


<






<







544
545
546
547
548
549
550

551
552

553
554
555
556
557
558

559
560
561
562
563
564
565
    puts $f2 {}
    puts $f2 "\# Test formatting of Daylight Saving Time"
    puts $f2 {}
    
    set fmt {%H:%M:%S %z %Z}
    
    set i 0

    puts $f2 "test clock-5.[incr i] {does Detroit exist} {"
    puts $f2 "    clock format 0 -format {} -timezone :America/Detroit"

    puts $f2 "    concat"
    puts $f2 "} {}"
    puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {"
    puts $f2 "    if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {"
    puts $f2 "        concat {y2038 problem}"
    puts $f2 "    } else {"

    puts $f2 "        concat {ok}"
    puts $f2 "    }"
    puts $f2 "} ok"
  
    foreach row $TZData(:America/Detroit) {
	foreach { t offset isdst tzname } $row break
	if { $t > -4000000000000 } {

Changes to tools/man2html2.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# man2html2.tcl --
#
# This file defines procedures that are used during the second pass of the
# man page to html conversion process. It is sourced by man2html.tcl.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# $Id: man2html2.tcl,v 1.7 2004/11/24 11:24:34 dkf Exp $
#

package require Tcl 8.4

# Global variables used by these scripts:
#
# NAME_file -	array indexed by NAME and containing file names used







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# man2html2.tcl --
#
# This file defines procedures that are used during the second pass of the
# man page to html conversion process. It is sourced by man2html.tcl.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# $Id: man2html2.tcl,v 1.7.2.1 2005/04/10 23:15:16 kennykb Exp $
#

package require Tcl 8.4

# Global variables used by these scripts:
#
# NAME_file -	array indexed by NAME and containing file names used
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
	return
    }
    # Special case for alternative mechanism for declaring bullets
    if {[lindex $argList 0] eq "\\(bu"} {
	nest para UL LI
	return
    }
    if {$length == 1} {
    	nest para OL LI
	return
    }
    if {$length > 1} {
    	nest para DL DT
	formattedText [lindex $argList 0]
	puts $file "\n<DD>"
	return
    }
    puts stderr "Bad .IP macro: .IP [join $argList " "]"
}


# TPmacro --
#
# This procedure is invoked to handle ".TP" macros, which may take any
# of the following forms:







|



<
|
|
|
|
<
<







715
716
717
718
719
720
721
722
723
724
725

726
727
728
729


730
731
732
733
734
735
736
	return
    }
    # Special case for alternative mechanism for declaring bullets
    if {[lindex $argList 0] eq "\\(bu"} {
	nest para UL LI
	return
    }
    if {[regexp {^\[\d+\]$} [lindex $argList 0]]} {
    	nest para OL LI
	return
    }

    nest para DL DT
    formattedText [lindex $argList 0]
    puts $file "\n<DD>"
    return


}


# TPmacro --
#
# This procedure is invoked to handle ".TP" macros, which may take any
# of the following forms:

Changes to tools/tcl.wse.in.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
  Japanese Font Size=10
  Start Gradient=0 0 255
  End Gradient=0 0 0
  Windows Flags=00000000000000010010110000001000
  Log Pathname=%MAINDIR%\INSTALL.LOG
  Message Font=MS Sans Serif
  Font Size=8
  Disk Label=tcl8.5a2
  Disk Filename=setup
  Patch Flags=0000000000000001
  Patch Threshold=85
  Patch Memory=4000
  Variable Name1=_SYS_
  Variable Default1=C:\WINDOWS\SYSTEM
  Variable Flags1=00001000







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
  Japanese Font Size=10
  Start Gradient=0 0 255
  End Gradient=0 0 0
  Windows Flags=00000000000000010010110000001000
  Log Pathname=%MAINDIR%\INSTALL.LOG
  Message Font=MS Sans Serif
  Font Size=8
  Disk Label=tcl8.5a4
  Disk Filename=setup
  Patch Flags=0000000000000001
  Patch Threshold=85
  Patch Memory=4000
  Variable Name1=_SYS_
  Variable Default1=C:\WINDOWS\SYSTEM
  Variable Flags1=00001000

Changes to tools/tclZIC.tcl.

21
22
23
24
25
26
27
28
29
30
31
32
33
34


35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
#
# This program parses the timezone data in a means analogous to the
# 'zic' command, and produces Tcl time zone information files suitable
# for loading into the 'clock' namespace.
#
#----------------------------------------------------------------------
#
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tclZIC.tcl,v 1.3 2004/11/02 15:16:38 kennykb Exp $
#
#----------------------------------------------------------------------



# Define the names of the Olson files that we need to load.
# We avoid the solar time files and the leap seconds.

set olsonFiles {
    africa antarctica asia australasia
    backward etcetera europe northamerica
    pacificnew southamerica systemv
}

# Temporary scaffolding - load up the new 'clock' package.

source [file join [file dirname [info script]] .. library clock.tcl]

# Define the year at which the DST information will stop.

set maxyear 2100

# Determine how big a wide integer is.

set MAXWIDE [expr { wide(1) }]
while 1 {
    set next [expr { $MAXWIDE + $MAXWIDE + 1}]
    if { $next < 0 } {
	break
    }
    set MAXWIDE $next
}
set MINWIDE [expr { - $MAXWIDE - 1 }]

#----------------------------------------------------------------------
#
# K --
#
#	The K combinator returns its first argument.  It's used for
#	reference count management.
#
# Parameters:
#	x - Argument to be unreferenced.
#	y - Unused.
#
# Results:
#	Returns the first argument.
#
# Side effects:
#	None.
#
# The K combinator is used for its effect that [K $x [set x {}]]
# reads out the value of x destructively, giving an unshared Tcl
# object and avoiding 'copy on write'
#
#----------------------------------------------------------------------

proc K {x y} {return $x}

#----------------------------------------------------------------------
#
# loadFiles --
#
#	Loads the time zone files for each continent into memory
#
# Parameters:
#	dir - Directory where the time zone source files are found
#
# Results:
#	None.
#
# Side effects:
#	Calls 'loadZIC' for each continent's data file in turn.
#	Reports progress on stdout.
#
#----------------------------------------------------------------------

proc loadFiles { dir } {
    variable olsonFiles
    foreach file $olsonFiles {
	puts "loading: [file join $dir $file]"
	loadZIC [file join $dir $file]
    }
    return
}







|



|


>
>




















|

|
|




|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



















|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

























66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
#
# This program parses the timezone data in a means analogous to the
# 'zic' command, and produces Tcl time zone information files suitable
# for loading into the 'clock' namespace.
#
#----------------------------------------------------------------------
#
# Copyright (c) 2004 by Kevin B. Kenny.	 All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tclZIC.tcl,v 1.3.2.1 2005/04/25 21:37:30 kennykb Exp $
#
#----------------------------------------------------------------------

package require Tcl 8.5

# Define the names of the Olson files that we need to load.
# We avoid the solar time files and the leap seconds.

set olsonFiles {
    africa antarctica asia australasia
    backward etcetera europe northamerica
    pacificnew southamerica systemv
}

# Temporary scaffolding - load up the new 'clock' package.

source [file join [file dirname [info script]] .. library clock.tcl]

# Define the year at which the DST information will stop.

set maxyear 2100

# Determine how big a wide integer is.

set MAXWIDE [expr {wide(1)}]
while 1 {
    set next [expr {$MAXWIDE + $MAXWIDE + 1}]
    if {$next < 0} {
	break
    }
    set MAXWIDE $next
}
set MINWIDE [expr {-$MAXWIDE-1}]


























#----------------------------------------------------------------------
#
# loadFiles --
#
#	Loads the time zone files for each continent into memory
#
# Parameters:
#	dir - Directory where the time zone source files are found
#
# Results:
#	None.
#
# Side effects:
#	Calls 'loadZIC' for each continent's data file in turn.
#	Reports progress on stdout.
#
#----------------------------------------------------------------------

proc loadFiles {dir} {
    variable olsonFiles
    foreach file $olsonFiles {
	puts "loading: [file join $dir $file]"
	loadZIC [file join $dir $file]
    }
    return
}
132
133
134
135
136
137
138

139
140
141
142
143
144
145
146
147
148
#	any undefined rules are present.
#
#----------------------------------------------------------------------

proc checkForwardRuleRefs {} {
    variable forwardRuleRefs
    variable rules

    foreach { rule where } [array get forwardRuleRefs] {
	if { ![info exists rules($rule)] } {
	    foreach { fileName lno } $where {
		puts stderr "$fileName:$lno:can't locate rule \"$rule\""
		incr errorCount
	    }
	}
    }
}








>
|
|
|







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
#	any undefined rules are present.
#
#----------------------------------------------------------------------

proc checkForwardRuleRefs {} {
    variable forwardRuleRefs
    variable rules

    foreach {rule where} [array get forwardRuleRefs] {
	if {![info exists rules($rule)]} {
	    foreach {fileName lno} $where {
		puts stderr "$fileName:$lno:can't locate rule \"$rule\""
		incr errorCount
	    }
	}
    }
}

163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220


221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
#	The global array, 'links', contains a distillation of the
#	'Link' directives in the file. The keys are 'links to' and
#	the values are 'links from'.  The 'parseRule' and 'parseZone'
#	procedures are called to handle 'Rule' and 'Zone' directives.
#
#----------------------------------------------------------------------

proc loadZIC { fileName } {

    variable errorCount
    variable links

    # Suck the text into memory.

    set f [open $fileName r]
    set data [read $f]
    close $f

    # Break the input into lines, and count line numbers.

    set lno 0
    foreach line [split $data \n] {
	incr lno

	# Break a line of input into words.

	regsub {[[:space:]]*(\#.*)?$} $line {} line
	if { $line eq {} } {
	    continue
	}
	set words {}
	if { [regexp {^[[:space:]]+(.*)} $line -> l] } {

	    lappend words {}
	    set line $l
	}
	while {[regexp {^([^[:space:]]+)[[:space:]]*(.*)} $line -> \
		    word line]} {
	    lappend words $word
	}

	# Switch on the directive

	switch -exact -- [lindex $words 0] {
	    Rule {
		parseRule $fileName $lno $words
	    }
	    Link {
		set links([lindex $words 2]) [lindex $words 1]
	    }
	    Zone {
		set lastZone [lindex $words 1]
		set until [parseZone $fileName $lno \
			       $lastZone [lrange $words 2 end] minimum]
	    }
	    {} {			# Continuation of a Zone
		set i 0
		foreach word $words {
		    if { [lindex $words $i] ne {} } break


		    incr i
		}
		set words [lrange $words $i end]
		set until [parseZone $fileName $lno $lastZone $words $until]
	    }
	    default {
		incr errorCount
		puts stderr "$fileName:$lno:unknown line type \"[lindex $words 0]\""
	    }
	}
    }

    return

}

#----------------------------------------------------------------------
#
# parseRule --
#
#	Parses a Rule directive in an Olson file.







|
<

















|
|



|
>
|
<

<
<
|
<













|

|


|
>
>













<







141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174


175

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209

210
211
212
213
214
215
216
#	The global array, 'links', contains a distillation of the
#	'Link' directives in the file. The keys are 'links to' and
#	the values are 'links from'.  The 'parseRule' and 'parseZone'
#	procedures are called to handle 'Rule' and 'Zone' directives.
#
#----------------------------------------------------------------------

proc loadZIC {fileName} {

    variable errorCount
    variable links

    # Suck the text into memory.

    set f [open $fileName r]
    set data [read $f]
    close $f

    # Break the input into lines, and count line numbers.

    set lno 0
    foreach line [split $data \n] {
	incr lno

	# Break a line of input into words.

	regsub {\s*(\#.*)?$} $line {} line
	if {$line eq ""} {
	    continue
	}
	set words {}
	if {[regexp {^\s} $line]} {
	    # Detect continuations of a zone and flag the list appropriately
	    lappend words ""

	}


	lappend words {expand}[regexp -all -inline {\S+} $line]


	# Switch on the directive

	switch -exact -- [lindex $words 0] {
	    Rule {
		parseRule $fileName $lno $words
	    }
	    Link {
		set links([lindex $words 2]) [lindex $words 1]
	    }
	    Zone {
		set lastZone [lindex $words 1]
		set until [parseZone $fileName $lno \
			$lastZone [lrange $words 2 end] "minimum"]
	    }
	    {} {
		set i 0
		foreach word $words {
		    if {[lindex $words $i] ne ""} {
			break
		    }
		    incr i
		}
		set words [lrange $words $i end]
		set until [parseZone $fileName $lno $lastZone $words $until]
	    }
	    default {
		incr errorCount
		puts stderr "$fileName:$lno:unknown line type \"[lindex $words 0]\""
	    }
	}
    }

    return

}

#----------------------------------------------------------------------
#
# parseRule --
#
#	Parses a Rule directive in an Olson file.
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
#
# Side effects:
#	The rule is analyzed and added to the 'rules' array.
#	Errors are reported and counted.
#
#----------------------------------------------------------------------

proc parseRule { fileName lno words } {

    variable rules
    variable errorCount

    # Break out the columns

    foreach { Rule name from to type in on at save letter } $words {}

    # Handle the 'only' keyword

    if { $to eq {only} } {
	set to $from
    }

    # Process the start year

    set l [string length $from]
    if { ![string is integer $from] } {
	if { $from ne [string range {minumum} 0 [expr { $l - 1 }]] } {
	    puts stderr "$fileName:$lno:FROM field \"$from\" not an integer."
	    incr errorCount
	    return
	} else {
	    set from minimum
	}
    }

    # Process the end year

    set l [string length $to]
    if { ![string is integer $to] } {
	if { $to ne [string range {maximum} 0 [expr { $l - 1 }]] } {
	    puts stderr "$fileName:$lno:TO field \"$to\" not an integer."
	    incr errorCount
	    return
	} else {
	    set to maximum
	}
    }

    # Process the type of year in which the rule applies

    if { $type ne {-} } {
	puts stderr "$fileName:$lno:year types are not yet supported."
	incr errorCount
	return
    }

    # Process the month in which the rule starts

    if { [catch {lookupMonth $in} in] } {
	puts stderr "$fileName:$lno:$in"
	incr errorCount
	return
    }

    # Process the day of the month on which the rule starts

    if { [catch {parseON $on} on] } {
	puts stderr "$fileName:$lno:$on"
	incr errorCount
	return
    }

    # Process the time of day on which the rule starts

    if { [catch {parseTOD $at} at] } {
	puts stderr "$fileName:$lno:$at"
	incr errorCount
	return
    }

    # Process the DST adder

    if { [catch {parseOffsetTime $save} save] } {
	puts stderr "$fileName:$lno:$save"
	incr errorCount
	return
    }
	
    # Process the letter to use for summer time

    if { $letter eq {-} } {
	set letter {}
    }

    # Accumulate all the data.

    lappend rules($name) $from $to $type $in $on $at $save $letter
    return

}

#----------------------------------------------------------------------
#
# parseON --
#
#	Parse a specification for a day of the month
#
# Parameters:
#	on - the ON field from a line in an Olson file.
#
# Results:
#	Returns a partial Tcl command.  When the year and number of the
#	month are appended, the command will return the Julian Day Number
#	of the desired date.
#
# Side effects:
#	None.
#
# The specification can be:
#	- a simple number, which designates a constant date.
#	- The name of a weekday, followed by >= or <=, followed by a number.
#	    This designates the nearest occurrence of the given weekday on
#	    or before (on or after) the given day of the month.
#	- The word 'last' followed by a weekday name with no intervening
#	  space.  This designates the last occurrence of the given weekday
#	  in the month.
#
#----------------------------------------------------------------------	

proc parseON { on } {
    if { ! [regexp -expanded {
	^(?:
	  # first possibility - simple number - field 1
	  ([[:digit:]]+)
	  |
	  # second possibility - weekday >= (or <=) number
	  # field 2 - weekday
	  ([[:alpha:]]+)
	  # field 3 - direction
	  ([<>]=)
	  # field 4 - number
	  ([[:digit:]]+)
	  |
	  # third possibility - lastWeekday - field 5
	  last([[:alpha:]]+)
	  )$
    } $on -> dom1 wday2 dir2 num2 wday3] } {
	error "can't parse ON field \"$on\""
    }
    if { $dom1 ne {} } {
	return [list onDayOfMonth $dom1]
    } elseif { $wday2 ne {} } {
	set wday2 [lookupDayOfWeek $wday2]
	return [list onWeekdayInMonth $wday2 $dir2 $num2]
    } elseif { $wday3 ne {} } {
	set wday3 [lookupDayOfWeek $wday3]
	return [list onLastWeekdayInMonth $wday3]
    } else {
	error "in parseOn \"$on\": can't happen"
    }
}
      
#----------------------------------------------------------------------
#
# onDayOfMonth --
#
#	Find a given day of a given month
#
# Parameters:
#	day - Day of the month
#	year - Gregorian year
#	month - Number of the month (1-12)
#
# Results:
#	Returns the Julian Day Number of the desired day.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc onDayOfMonth { day year month } {
    set date [dict create era CE year $year month $month dayOfMonth $day]
    set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
		  [K $date [set date {}]]]
    return [dict get $date julianDay]
}

#----------------------------------------------------------------------
#
# onWeekdayInMonth --
#







|
<





|



|





<
|
|




|





<
|
|




|





|







|







|







|







|




|


|
|



















|















|

|
|



|







|


|
|


|

|


|






|



















|
<

|







225
226
227
228
229
230
231
232

233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

248
249
250
251
252
253
254
255
256
257
258
259

260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403

404
405
406
407
408
409
410
411
412
#
# Side effects:
#	The rule is analyzed and added to the 'rules' array.
#	Errors are reported and counted.
#
#----------------------------------------------------------------------

proc parseRule {fileName lno words} {

    variable rules
    variable errorCount

    # Break out the columns

    lassign $words  Rule name from to type in on at save letter

    # Handle the 'only' keyword

    if {$to eq "only"} {
	set to $from
    }

    # Process the start year


    if {![string is integer $from]} {
	if {![string equal -length [string length $from] $from "minimum"]} {
	    puts stderr "$fileName:$lno:FROM field \"$from\" not an integer."
	    incr errorCount
	    return
	} else {
	    set from "minimum"
	}
    }

    # Process the end year


    if {![string is integer $to]} {
	if {![string equal -length [string length $to] $to "maximum"]} {
	    puts stderr "$fileName:$lno:TO field \"$to\" not an integer."
	    incr errorCount
	    return
	} else {
	    set to "maximum"
	}
    }

    # Process the type of year in which the rule applies

    if {$type ne "-"} {
	puts stderr "$fileName:$lno:year types are not yet supported."
	incr errorCount
	return
    }

    # Process the month in which the rule starts

    if {[catch {lookupMonth $in} in]} {
	puts stderr "$fileName:$lno:$in"
	incr errorCount
	return
    }

    # Process the day of the month on which the rule starts

    if {[catch {parseON $on} on]} {
	puts stderr "$fileName:$lno:$on"
	incr errorCount
	return
    }

    # Process the time of day on which the rule starts

    if {[catch {parseTOD $at} at]} {
	puts stderr "$fileName:$lno:$at"
	incr errorCount
	return
    }

    # Process the DST adder

    if {[catch {parseOffsetTime $save} save]} {
	puts stderr "$fileName:$lno:$save"
	incr errorCount
	return
    }

    # Process the letter to use for summer time

    if {$letter eq "-"} {
	set letter ""
    }

    # Accumulate all the data.

    lappend rules($name) $from $to $type $in $on $at $save $letter
    return

}

#----------------------------------------------------------------------
#
# parseON --
#
#	Parse a specification for a day of the month
#
# Parameters:
#	on - the ON field from a line in an Olson file.
#
# Results:
#	Returns a partial Tcl command.	When the year and number of the
#	month are appended, the command will return the Julian Day Number
#	of the desired date.
#
# Side effects:
#	None.
#
# The specification can be:
#	- a simple number, which designates a constant date.
#	- The name of a weekday, followed by >= or <=, followed by a number.
#	    This designates the nearest occurrence of the given weekday on
#	    or before (on or after) the given day of the month.
#	- The word 'last' followed by a weekday name with no intervening
#	  space.  This designates the last occurrence of the given weekday
#	  in the month.
#
#----------------------------------------------------------------------

proc parseON {on} {
    if {![regexp -expanded {
	^(?:
	  # first possibility - simple number - field 1
	  ([[:digit:]]+)
	|
	  # second possibility - weekday >= (or <=) number
	  # field 2 - weekday
	  ([[:alpha:]]+)
	  # field 3 - direction
	  ([<>]=)
	  # field 4 - number
	  ([[:digit:]]+)
	|
	  # third possibility - lastWeekday - field 5
	  last([[:alpha:]]+)
	)$
    } $on -> dom1 wday2 dir2 num2 wday3]} then {
	error "can't parse ON field \"$on\""
    }
    if {$dom1 ne ""} {
	return [list onDayOfMonth $dom1]
    } elseif {$wday2 ne ""} {
	set wday2 [lookupDayOfWeek $wday2]
	return [list onWeekdayInMonth $wday2 $dir2 $num2]
    } elseif {$wday3 ne ""} {
	set wday3 [lookupDayOfWeek $wday3]
	return [list onLastWeekdayInMonth $wday3]
    } else {
	error "in parseOn \"$on\": can't happen"
    }
}

#----------------------------------------------------------------------
#
# onDayOfMonth --
#
#	Find a given day of a given month
#
# Parameters:
#	day - Day of the month
#	year - Gregorian year
#	month - Number of the month (1-12)
#
# Results:
#	Returns the Julian Day Number of the desired day.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc onDayOfMonth {day year month} {

    set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
	    [dict create era CE year $year month $month dayOfMonth $day]]
    return [dict get $date julianDay]
}

#----------------------------------------------------------------------
#
# onWeekdayInMonth --
#
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
#
# onWeekdayInMonth is used to compute Daylight Saving Time rules
# like 'Sun>=1' (for the nearest Sunday on or after the first of the month)
# or "Mon<=4' (for the Monday on or before the fourth of the month).
#
#----------------------------------------------------------------------

proc onWeekdayInMonth { dayOfWeek relation dayOfMonth year month } {
    set date [dict create \
		  era CE year $year month $month dayOfMonth $dayOfMonth]
    set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
		  [K $date [set date {}]]]
    switch -exact -- $relation {
	<= {
	    return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
			[dict get $date julianDay]]
	}
	>= {
	    return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
			[expr { [dict get $date julianDay] + 6 }]]
	}
    }
}

#----------------------------------------------------------------------
#
# onLastWeekdayInMonth --







|
|
|
<
<



|



|







429
430
431
432
433
434
435
436
437
438


439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
#
# onWeekdayInMonth is used to compute Daylight Saving Time rules
# like 'Sun>=1' (for the nearest Sunday on or after the first of the month)
# or "Mon<=4' (for the Monday on or before the fourth of the month).
#
#----------------------------------------------------------------------

proc onWeekdayInMonth {dayOfWeek relation dayOfMonth year month} {
    set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \
	    era CE year $year month $month dayOfMonth $dayOfMonth]]


    switch -exact -- $relation {
	<= {
	    return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
		    [dict get $date julianDay]]
	}
	>= {
	    return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
		    [expr {[dict get $date julianDay] + 6}]]
	}
    }
}

#----------------------------------------------------------------------
#
# onLastWeekdayInMonth --
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
#	the given weekday in the given month
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc onLastWeekdayInMonth { dayOfWeek year month } {
    incr month
    # Find day 0 of the following month, which is the last day of
    # the current month.  Yes, it works to ask for day 0 of month 13!
    set date [dict create \
		  era CE year $year month $month dayOfMonth 0]
    set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
		  [K $date [set date {}]]]
    return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
		[dict get $date julianDay]]
}
		  
#----------------------------------------------------------------------
#
# parseTOD --
#
#	Parses the specification of a time of day in an Olson file.
#
# Parameters:







|



|
|
<
<

|

|







464
465
466
467
468
469
470
471
472
473
474
475
476


477
478
479
480
481
482
483
484
485
486
487
#	the given weekday in the given month
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc onLastWeekdayInMonth {dayOfWeek year month} {
    incr month
    # Find day 0 of the following month, which is the last day of
    # the current month.  Yes, it works to ask for day 0 of month 13!
    set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \
	    era CE year $year month $month dayOfMonth 0]]


    return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
	    [dict get $date julianDay]]
}

#----------------------------------------------------------------------
#
# parseTOD --
#
#	Parses the specification of a time of day in an Olson file.
#
# Parameters:
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
#	midnight and the letter that followed the time.
#
# Side effects:
#	Reports and counts an error if the time cannot be parsed.
#
#----------------------------------------------------------------------

proc parseTOD { tod } {
    if { ![regexp -expanded {
	^
	# field 1 - hour
	([[:digit:]]{1,2})
	(?:
	 # field 2 - minute
	 :([[:digit:]]{2})
	 (?:
	  # field 3 - second
	  :([[:digit:]]{2})
	  )?
	)?
	(?:
	 # field 4 - type indicator
	 ([wsugz])
	 )?
    } $tod -> hour minute second ind] } {
	puts stderr "$fileName:$lno:can't parse time field \"$tod\""
	incr errorCount
    }
    scan $hour %d hour
    if { $minute ne {} } {
	scan $minute %d minute
    } else {
	set minute 0
    }
    if { $second ne {} } {
	scan $second %d second
    } else {
	set second 0
    }
    if { $ind eq {} } {
	set ind w
    }
    return [list [expr { ( $hour * 60 + $minute ) * 60 + $second }] $ind]
}

#----------------------------------------------------------------------
#
# parseOffsetTime --
#
#	Parses the specification of an offset time in an Olson file.
#
# Parameters:
#	offset - Offset time as [+-]hh:mm:ss
#
# Results:
#	Returns the offset time as a count of seconds.
#
# Side effects:
#	Reports and counts an error if the time cannot be parsed.
#
#----------------------------------------------------------------------

proc parseOffsetTime { offset } {
    if { ![regexp -expanded {
	^
	# field 1 - signum
	([-+])?
	# field 2 - hour
	([[:digit:]]{1,2})
	(?:
	 # field 3 - minute
	 :([[:digit:]]{2})
	 (?:
	  # field 4 - second
	  :([[:digit:]]{2})
	  )?
	)?
    } $offset -> signum hour minute second] } {
	puts stderr "$fileName:$lno:can't parse offset time \"$offset\""
	incr errorCount
    }
    append signum 1
    scan $hour %d hour
    if { $minute ne {} } {
	scan $minute %d minute
    } else {
	set minute 0
    }
    if { $second ne {} } {
	scan $second %d second
    } else {
	set second 0
    }
    return [expr { ( ( $hour * 60 + $minute ) * 60 + $second ) * $signum }]

}

#----------------------------------------------------------------------
#
# lookupMonth -
#	Looks up a month by name
#
# Parameters:
#	month - Name of a month.
#
# Results:
#	Returns the number of the month.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc lookupMonth { month } {

    set indx [lsearch -regexp {
	{} January February March April May June
	July August September October November December
    } ${month}.*]
    if { $indx < 1 } {
	error "unknown month name \"$month\""
    }
    return $indx
}

#----------------------------------------------------------------------
#







|
|

<
|

<
|
|
<
|
|


|
<
|
|




|




|




|


|



















|
|

|
<
<
|

<
|
|
<
|
|

|





|




|




|



















|
<




|







495
496
497
498
499
500
501
502
503
504

505
506

507
508

509
510
511
512
513

514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556


557
558

559
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600

601
602
603
604
605
606
607
608
609
610
611
612
#	midnight and the letter that followed the time.
#
# Side effects:
#	Reports and counts an error if the time cannot be parsed.
#
#----------------------------------------------------------------------

proc parseTOD {tod} {
    if {![regexp -expanded {
	^

	([[:digit:]]{1,2})		# field 1 - hour
	(?:

	    :([[:digit:]]{2})		# field 2 - minute
	    (?:

		:([[:digit:]]{2})	# field 3 - second
	    )?
	)?
	(?:
	    ([wsugz])			# field 4 - type indicator

	)?
    } $tod -> hour minute second ind]} then {
	puts stderr "$fileName:$lno:can't parse time field \"$tod\""
	incr errorCount
    }
    scan $hour %d hour
    if {$minute ne ""} {
	scan $minute %d minute
    } else {
	set minute 0
    }
    if {$second ne ""} {
	scan $second %d second
    } else {
	set second 0
    }
    if {$ind eq ""} {
	set ind w
    }
    return [list [expr {($hour * 60 + $minute) * 60 + $second}] $ind]
}

#----------------------------------------------------------------------
#
# parseOffsetTime --
#
#	Parses the specification of an offset time in an Olson file.
#
# Parameters:
#	offset - Offset time as [+-]hh:mm:ss
#
# Results:
#	Returns the offset time as a count of seconds.
#
# Side effects:
#	Reports and counts an error if the time cannot be parsed.
#
#----------------------------------------------------------------------

proc parseOffsetTime {offset} {
    if {![regexp -expanded {
	^
	([-+])?				# field 1 - signum


	([[:digit:]]{1,2})		# field 2 - hour
	(?:

	    :([[:digit:]]{2})		# field 3 - minute
	    (?:

		:([[:digit:]]{2})	# field 4 - second
	    )?
	)?
    } $offset -> signum hour minute second]} then {
	puts stderr "$fileName:$lno:can't parse offset time \"$offset\""
	incr errorCount
    }
    append signum 1
    scan $hour %d hour
    if {$minute ne ""} {
	scan $minute %d minute
    } else {
	set minute 0
    }
    if {$second ne ""} {
	scan $second %d second
    } else {
	set second 0
    }
    return [expr {(($hour * 60 + $minute) * 60 + $second) * $signum}]

}

#----------------------------------------------------------------------
#
# lookupMonth -
#	Looks up a month by name
#
# Parameters:
#	month - Name of a month.
#
# Results:
#	Returns the number of the month.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc lookupMonth {month} {

    set indx [lsearch -regexp {
	{} January February March April May June
	July August September October November December
    } ${month}.*]
    if {$indx < 1} {
	error "unknown month name \"$month\""
    }
    return $indx
}

#----------------------------------------------------------------------
#
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721

722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
#	Returns the weekday number (Monday=1, Sunday=7)
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc lookupDayOfWeek { wday } {
    set indx [lsearch -regexp {
	{} Monday Tuesday Wednesday Thursday Friday Saturday Sunday
    } ${wday}.*]
    if { $indx < 1 } {
	error "unknown weekday name \"$wday\""
    }
    return $indx
}

#----------------------------------------------------------------------
#
# parseZone --
#
#	Parses a Zone directive in an Olson file
#
# Parameters:
#	fileName -- Name of the file being parsed.
#	lno -- Line number within the file.
#	zone -- Name of the time zone
#	words -- Remaining words on the line.
#	start -- 'Until' time from the previous line if this is a
#	         continuation line, or 'minimum' if this is the first line.
#
# Results:
#	Returns the 'until' field of the current line
#
# Side effects:
#	Stores a row in the 'zones' array describing the current zone.
#	The row consists of a start time (year month day tod), a Standard
#	Time offset from Greenwich, a Daylight Saving Time offset from
#	Standard Time, and a format for printing the time zone.
#
#	The start time is the result of an earlier call to 'parseUntil'
#	or else the keyword 'minimum'.  The GMT offset is the
#	result of a call to 'parseOffsetTime'.  The Daylight Saving
#	Time offset is represented as a partial Tcl command. To the
#	command will be appended a start time (seconds from epoch)
#	the current offset of Standard Time from Greenwich, the current
#	offset of Daylight Saving Time from Greenwich, the default
#	offset from this line, the name pattern from this line,
#	the 'until' field from this line, and a variable name where points
#	are to be stored.  This command is implemented by the 'applyNoRule',
#	'applyDSTOffset' and 'applyRules' procedures.
#
#----------------------------------------------------------------------

proc parseZone { fileName lno zone words start } {
    variable zones
    variable rules
    variable errorCount
    variable forwardRuleRefs

    foreach { gmtoff save format } $words break
    if { [catch {parseOffsetTime $gmtoff} gmtoff] } {
	puts stderr "$fileName:$lno:$gmtoff"
	incr errorCount
	return
    } 
    if { [info exists rules($save)] } {
	set save [list applyRules $save]
    } elseif { $save eq {-} } {
	set save [list applyNoRule]
    } else {
	if { [catch { parseOffsetTime $save } save2] } {
	    lappend forwardRuleRefs($save) $fileName $lno
	    set save [list applyRules $save]
	} else {
	    set save [list applyDSTOffset $save2]
	}
    }
    lappend zones($zone) $start $gmtoff $save $format
    if { [llength $words] >= 4 } {
	return [parseUntil [lrange $words 3 end]]
    } else {
	return {}
    }
}

#----------------------------------------------------------------------
#
# parseUntil --
#	
#	Parses the 'UNTIL' part of a 'Zone' directive.
#
# Parameters:
#	words - The 'UNTIL' part of the directie.
#
# Results:
#	Returns a list comprising the year, the month, the day, and
#	the time of day. Time of day is represented as the result of
#	'parseTOD'.
#
#----------------------------------------------------------------------

proc parseUntil { words } {
    variable firstYear

    if { [llength $words] >= 1 } {
	set year [lindex $words 0]
	if { ![string is integer $year] } {
	    error "can't parse UNTIL field \"$words\""
	}
	if { ![info exists firstYear] || $year < $firstYear } {
	    set firstYear $year
	}
    } else {
	set year maximum
    }
    if { [llength $words] >= 2 } {
	set month [lookupMonth [lindex $words 1]]
    } else {
	set month 1
    }
    if { [llength $words] >= 3 } {
	set day [parseON [lindex $words 2]]
    } else {
	set day {onDayOfMonth 1}
    }
    if { [llength $words] >= 4 } {
	set tod [parseTOD [lindex $words 3]]
    } else {
	set tod {0 w}
    }
    return [list $year $month $day $tod]
}








|



|

















|











|
|











|




>
|
|



|
|

|

<
|
|
|
|
|
|
<

|









|












|

>
|

|


|



|

|




|




|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690

691
692
693
694
695
696

697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
#	Returns the weekday number (Monday=1, Sunday=7)
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc lookupDayOfWeek {wday} {
    set indx [lsearch -regexp {
	{} Monday Tuesday Wednesday Thursday Friday Saturday Sunday
    } ${wday}.*]
    if {$indx < 1} {
	error "unknown weekday name \"$wday\""
    }
    return $indx
}

#----------------------------------------------------------------------
#
# parseZone --
#
#	Parses a Zone directive in an Olson file
#
# Parameters:
#	fileName -- Name of the file being parsed.
#	lno -- Line number within the file.
#	zone -- Name of the time zone
#	words -- Remaining words on the line.
#	start -- 'Until' time from the previous line if this is a
#		 continuation line, or 'minimum' if this is the first line.
#
# Results:
#	Returns the 'until' field of the current line
#
# Side effects:
#	Stores a row in the 'zones' array describing the current zone.
#	The row consists of a start time (year month day tod), a Standard
#	Time offset from Greenwich, a Daylight Saving Time offset from
#	Standard Time, and a format for printing the time zone.
#
#	The start time is the result of an earlier call to 'parseUntil'
#	or else the keyword 'minimum'.	The GMT offset is the
#	result of a call to 'parseOffsetTime'.	The Daylight Saving
#	Time offset is represented as a partial Tcl command. To the
#	command will be appended a start time (seconds from epoch)
#	the current offset of Standard Time from Greenwich, the current
#	offset of Daylight Saving Time from Greenwich, the default
#	offset from this line, the name pattern from this line,
#	the 'until' field from this line, and a variable name where points
#	are to be stored.  This command is implemented by the 'applyNoRule',
#	'applyDSTOffset' and 'applyRules' procedures.
#
#----------------------------------------------------------------------

proc parseZone {fileName lno zone words start} {
    variable zones
    variable rules
    variable errorCount
    variable forwardRuleRefs

    lassign $words gmtoff save format
    if {[catch {parseOffsetTime $gmtoff} gmtoff]} {
	puts stderr "$fileName:$lno:$gmtoff"
	incr errorCount
	return
    }
    if {[info exists rules($save)]} {
	set save [list applyRules $save]
    } elseif {$save eq "-"} {
	set save [list applyNoRule]

    } elseif {[catch {parseOffsetTime $save} save2]} {
	lappend forwardRuleRefs($save) $fileName $lno
	set save [list applyRules $save]
    } else {
	set save [list applyDSTOffset $save2]
    }

    lappend zones($zone) $start $gmtoff $save $format
    if {[llength $words] >= 4} {
	return [parseUntil [lrange $words 3 end]]
    } else {
	return {}
    }
}

#----------------------------------------------------------------------
#
# parseUntil --
#
#	Parses the 'UNTIL' part of a 'Zone' directive.
#
# Parameters:
#	words - The 'UNTIL' part of the directie.
#
# Results:
#	Returns a list comprising the year, the month, the day, and
#	the time of day. Time of day is represented as the result of
#	'parseTOD'.
#
#----------------------------------------------------------------------

proc parseUntil {words} {
    variable firstYear

    if {[llength $words] >= 1} {
	set year [lindex $words 0]
	if {![string is integer $year]} {
	    error "can't parse UNTIL field \"$words\""
	}
	if {![info exists firstYear] || $year < $firstYear} {
	    set firstYear $year
	}
    } else {
	set year "maximum"
    }
    if {[llength $words] >= 2} {
	set month [lookupMonth [lindex $words 1]]
    } else {
	set month 1
    }
    if {[llength $words] >= 3} {
	set day [parseON [lindex $words 2]]
    } else {
	set day {onDayOfMonth 1}
    }
    if {[llength $words] >= 4} {
	set tod [parseTOD [lindex $words 3]]
    } else {
	set tod {0 w}
    }
    return [list $year $month $day $tod]
}

820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
# Side effects:
#	Appends a row to the 'points' variable comprising the start time,
#	the offset from GMT, a zero (indicating that DST is not in effect),
#	and the name of the time zone.
#
#----------------------------------------------------------------------

proc applyNoRule { year startSecs stdGMTOffset DSTOffset nextGMTOffset
		   namePattern until pointsVar } {
    upvar 1 $pointsVar points
    lappend points $startSecs $nextGMTOffset 0 \
	[convertNamePattern $namePattern -]
    return [list $nextGMTOffset 0]

}

#----------------------------------------------------------------------
#
# applyNoRule --
#
#	Generates time zone data for a zone with permanent Daylight
#	Saving Time.
#
# Parameters:
#	nextDSTOffset - Offset of Daylight from Standard while the
#	                rule is in effect.
#	year - Year in which the rule applies
#	startSecs - Time at which the rule starts.
#	stdGMTOffset - Offset from Greenwich prior to the start of the
#		       rule
#	DSTOffset - Offset of Daylight from Standard prior to the
#		    start of the rule.
#	nextGMTOffset - Offset from Greenwich when the rule is in effect.







|
|


|

<




|






|







778
779
780
781
782
783
784
785
786
787
788
789
790

791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
# Side effects:
#	Appends a row to the 'points' variable comprising the start time,
#	the offset from GMT, a zero (indicating that DST is not in effect),
#	and the name of the time zone.
#
#----------------------------------------------------------------------

proc applyNoRule {year startSecs stdGMTOffset DSTOffset nextGMTOffset
		  namePattern until pointsVar} {
    upvar 1 $pointsVar points
    lappend points $startSecs $nextGMTOffset 0 \
	    [convertNamePattern $namePattern -]
    return [list $nextGMTOffset 0]

}

#----------------------------------------------------------------------
#
# applyDSTOffset --
#
#	Generates time zone data for a zone with permanent Daylight
#	Saving Time.
#
# Parameters:
#	nextDSTOffset - Offset of Daylight from Standard while the
#			rule is in effect.
#	year - Year in which the rule applies
#	startSecs - Time at which the rule starts.
#	stdGMTOffset - Offset from Greenwich prior to the start of the
#		       rule
#	DSTOffset - Offset of Daylight from Standard prior to the
#		    start of the rule.
#	nextGMTOffset - Offset from Greenwich when the rule is in effect.
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
# Side effects:
#	Appends a row to the 'points' variable comprising the start time,
#	the offset from GMT, a one (indicating that DST is in effect),
#	and the name of the time zone.
#
#----------------------------------------------------------------------

proc applyDSTOffset { nextDSTOffset year startSecs
		      stdGMTOffset DSTOffset nextGMTOffset 
		      namePattern until pointsVar } {
    upvar 1 $pointsVar points
    lappend points \
	$startSecs \
	[expr { $nextGMTOffset + $nextDSTOffset }] \
	1 \
	[convertNamePattern $namePattern S]
    return [list $nextGMTOffset $nextDSTOffset]
}

#----------------------------------------------------------------------
#
# applyRules --
#







|
|
|


|
|
|
|







819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
# Side effects:
#	Appends a row to the 'points' variable comprising the start time,
#	the offset from GMT, a one (indicating that DST is in effect),
#	and the name of the time zone.
#
#----------------------------------------------------------------------

proc applyDSTOffset {nextDSTOffset year startSecs
		     stdGMTOffset DSTOffset nextGMTOffset
		     namePattern until pointsVar} {
    upvar 1 $pointsVar points
    lappend points \
	    $startSecs \
	    [expr {$nextGMTOffset + $nextDSTOffset}] \
	    1 \
	    [convertNamePattern $namePattern S]
    return [list $nextGMTOffset $nextDSTOffset]
}

#----------------------------------------------------------------------
#
# applyRules --
#
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968

969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
#	Appends one or more rows to the 'points' variable, each of which
#	comprises a transition time, the offset from GMT that is
#	in effect after the transition, a flag for whether DST is in
#	effect, and the name of the time zone.
#
#----------------------------------------------------------------------

proc applyRules { ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset \
		      namePattern until pointsVar } {
    variable done
    variable rules
    variable maxyear

    upvar 1 $pointsVar points

    # Extract the rules that apply to the current year, and the number
    # of rules (now or in future) that will end at a specific year.
    # Ignore rules entirely in the past.

    foreach { 
	currentRules nSunsetRules
    } [divideRules $ruleSet $year] break

    # If the first transition is later than $startSecs, and $stdGMTOffset is
    # different from $nextGMTOffset, we will need an initial record like:
    #    lappend points $startSecs $stdGMTOffset 0 \
    #                   [convertNamePattern $namePattern -]

    set didTransitionIn false

    # Determine the letter to use in Standard Time

    set prevLetter {}
    foreach { 
	fromYear toYear yearType monthIn daySpecOn timeAt save letter
    }  $rules($ruleSet) {
	if { $save == 0 } {
	    set prevLetter $letter
	    break
	} 
    }

    # Walk through each year in turn. This loop will break when
    #    (a) the 'until' time is passed
    # or (b) the 'until' time is empty and all remaining rules extend to
    #        the end of time

    set stdGMTOffset $nextGMTOffset

    # convert "until" to seconds from epoch in current time zone

    if { $until ne {} } {
	foreach { 
	    untilYear untilMonth untilDaySpec untilTimeOfDay 
	} $until break
	lappend untilDaySpec $untilYear $untilMonth
	set untilJCD [eval $untilDaySpec]
	set untilBaseSecs [expr {
				 wide(86400) * wide($untilJCD)
				 - 210866803200 }]
	set untilSecs [eval [linsert $untilTimeOfDay 0 convertTimeOfDay \
				 $untilBaseSecs $stdGMTOffset $DSTOffset]]

    }

    set origStartSecs $startSecs

    while { ( $until ne {} && 
	      $startSecs < $untilSecs )
	    || ( $until eq {} && 
		 ( $nSunsetRules > 0 || $year < $maxyear ) ) } {

	set remainingRules $currentRules
	while { [llength $remainingRules] > 0 } {


	    # Find the rule with the earliest start time from among the
	    # active rules that haven't yet been processed.

	    foreach { 
		earliestSecs earliestIndex 
	    } [findEarliestRule $remainingRules $year \
		   $stdGMTOffset $DSTOffset] break
	       
	    set endi [expr {$earliestIndex + 7}]
	    set rule [lrange $remainingRules $earliestIndex $endi]
	    foreach { 
		fromYear toYear yearType monthIn daySpecOn timeAt save letter
	    } $rule break

	    # Test if the rule is in effect.


	    if { $earliestSecs > $startSecs && 
		 ( $until eq {} || $earliestSecs < $untilSecs ) } {

		# Test if the initial transition has been done.
		# If not, do it now.

		if { !$didTransitionIn && $earliestSecs > $origStartSecs } {
		    set nm [convertNamePattern $namePattern $prevLetter]
		    lappend points \
			$origStartSecs \
			[expr { $stdGMTOffset + $DSTOffset }] \
			0 \
			$nm
		    set didTransitionIn true
		}

		# Add a row to 'points' for the rule

		set nm [convertNamePattern $namePattern $letter]
		lappend points \
		    $earliestSecs \
		    [expr { $stdGMTOffset + $save }] \
		    [expr { $save != 0 }] \
		    $nm
	    }

	    # Remove the rule just applied from the queue

	    set remainingRules [lreplace \
				    [K $remainingRules \
					 [set remainingRules {}]] \
				    $earliestIndex $endi]

	    # Update current DST offset and time zone letter

	    set DSTOffset $save
	    set prevLetter $letter

	    # Reconvert the 'until' time in the current zone.
	    
	    if { $until ne {} } {
		set untilSecs [eval [linsert $untilTimeOfDay 0 \
					 convertTimeOfDay $untilBaseSecs \
					 $stdGMTOffset $DSTOffset]]
	    }
	}

	# Advance to the next year

	incr year
	set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
		      [dict create era CE year $year month 1 dayOfMonth 1]]
	set startSecs [expr { [dict get $date julianDay] * wide(86400) \
			     -210866803200 }]
	set startSecs [expr { $startSecs - $stdGMTOffset - $DSTOffset }]


	# Get rules in effect in the new year.

	foreach { 
	    currentRules nSunsetRules 
	}  [divideRules $ruleSet $year] break
	
    }

    return [list $stdGMTOffset $DSTOffset]
}

#----------------------------------------------------------------------
#







|
|










<
<
|



|
|





|
|

|
|


|



|

|





|
<
|
<



|
<
<
|
>




<
|
<
|
<

|
<




<
<
|
|
|


|
|
<



>
|
|
|



|


|
|
|
|







|
|
|
|





<
|
|







|
|
<
|
|







|
|
|
|
|



<
<
|
<







864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882


883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913

914

915
916
917
918


919
920
921
922
923
924

925

926

927
928

929
930
931
932


933
934
935
936
937
938
939

940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972

973
974
975
976
977
978
979
980
981
982
983

984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000


1001

1002
1003
1004
1005
1006
1007
1008
#	Appends one or more rows to the 'points' variable, each of which
#	comprises a transition time, the offset from GMT that is
#	in effect after the transition, a flag for whether DST is in
#	effect, and the name of the time zone.
#
#----------------------------------------------------------------------

proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset
		 namePattern until pointsVar} {
    variable done
    variable rules
    variable maxyear

    upvar 1 $pointsVar points

    # Extract the rules that apply to the current year, and the number
    # of rules (now or in future) that will end at a specific year.
    # Ignore rules entirely in the past.



    lassign [divideRules $ruleSet $year] currentRules nSunsetRules

    # If the first transition is later than $startSecs, and $stdGMTOffset is
    # different from $nextGMTOffset, we will need an initial record like:
    #	 lappend points $startSecs $stdGMTOffset 0 \
    #			[convertNamePattern $namePattern -]

    set didTransitionIn false

    # Determine the letter to use in Standard Time

    set prevLetter ""
    foreach {
	fromYear toYear yearType monthIn daySpecOn timeAt save letter
    } $rules($ruleSet) {
	if {$save == 0} {
	    set prevLetter $letter
	    break
	}
    }

    # Walk through each year in turn. This loop will break when
    #	 (a) the 'until' time is passed
    # or (b) the 'until' time is empty and all remaining rules extend to
    #	     the end of time

    set stdGMTOffset $nextGMTOffset

    # convert "until" to seconds from epoch in current time zone

    if {$until ne ""} {

	lassign $until untilYear untilMonth untilDaySpec untilTimeOfDay

	lappend untilDaySpec $untilYear $untilMonth
	set untilJCD [eval $untilDaySpec]
	set untilBaseSecs [expr {
		wide(86400) * wide($untilJCD) - 210866803200 }]


	set untilSecs [convertTimeOfDay $untilBaseSecs $stdGMTOffset \
		$DSTOffset {expand}$untilTimeOfDay]
    }

    set origStartSecs $startSecs


    while {($until ne "" && $startSecs < $untilSecs)

	    || ($until eq "" && ($nSunsetRules > 0 || $year < $maxyear))} {

	set remainingRules $currentRules
	while {[llength $remainingRules] > 0} {


	    # Find the rule with the earliest start time from among the
	    # active rules that haven't yet been processed.



	    lassign [findEarliestRule $remainingRules $year \
		    $stdGMTOffset $DSTOffset] earliestSecs earliestIndex

	    set endi [expr {$earliestIndex + 7}]
	    set rule [lrange $remainingRules $earliestIndex $endi]
	    lassign $rule fromYear toYear \
		    yearType monthIn daySpecOn timeAt save letter


	    # Test if the rule is in effect.

	    if {
		$earliestSecs > $startSecs &&
		($until eq "" || $earliestSecs < $untilSecs)
	    } then {
		# Test if the initial transition has been done.
		# If not, do it now.

		if {!$didTransitionIn && $earliestSecs > $origStartSecs} {
		    set nm [convertNamePattern $namePattern $prevLetter]
		    lappend points \
			    $origStartSecs \
			    [expr {$stdGMTOffset + $DSTOffset}] \
			    0 \
			    $nm
		    set didTransitionIn true
		}

		# Add a row to 'points' for the rule

		set nm [convertNamePattern $namePattern $letter]
		lappend points \
			$earliestSecs \
			[expr {$stdGMTOffset + $save}] \
			[expr {$save != 0}] \
			$nm
	    }

	    # Remove the rule just applied from the queue

	    set remainingRules [lreplace \

		    $remainingRules[set remainingRules {}] \
		    $earliestIndex $endi]

	    # Update current DST offset and time zone letter

	    set DSTOffset $save
	    set prevLetter $letter

	    # Reconvert the 'until' time in the current zone.

	    if {$until ne ""} {

		set untilSecs [convertTimeOfDay $untilBaseSecs \
			$stdGMTOffset $DSTOffset {expand}$untilTimeOfDay]
	    }
	}

	# Advance to the next year

	incr year
	set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
		[dict create era CE year $year month 1 dayOfMonth 1]]
	set startSecs [expr {
	    [dict get $date julianDay] * wide(86400) - 210866803200 
		- $stdGMTOffset - $DSTOffset
	}]

	# Get rules in effect in the new year.



	lassign [divideRules $ruleSet $year] currentRules nSunsetRules

    }

    return [list $stdGMTOffset $DSTOffset]
}

#----------------------------------------------------------------------
#
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
#	not change in future years.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc divideRules { ruleSet year } {

    variable rules

    set currentRules {}
    set nSunsetRules 0

    foreach { 
	fromYear toYear yearType monthIn daySpecOn timeAt save letter
    }  $rules($ruleSet) {
	if { $toYear ne {maximum} && $year > $toYear } {
	    # ignore - rule is in the past
	} else {
	    if { $fromYear eq {minimum} || $fromYear <= $year } {
		lappend currentRules $fromYear $toYear $yearType $monthIn \
		    $daySpecOn $timeAt $save $letter
	    }
	    if { $toYear ne {maximum} } {
		incr nSunsetRules
	    }
	}
    }

    return [list $currentRules $nSunsetRules]

}

#----------------------------------------------------------------------
#
# findEarliestRule --
#
#	Find the rule in a rule set that has the earliest start time.
#
# Parameters:
#	remainingRules -- Rules to search
#	year - Year being processed.
#	stdGMTOffset - Current offset of standard time from GMT
#	DSTOffset - Current offset of daylight time from standard,
#	            if daylight time is in effect.
#
# Results:
#	Returns the index in remainingRules of the next rule to
#	go into effect.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc findEarliestRule { remainingRules year stdGMTOffset DSTOffset } {

    set earliest $::MAXWIDE
    set i 0
    foreach {
	fromYear toYear yearType monthIn daySpecOn timeAt save letter
    } $remainingRules {
	lappend daySpecOn $year $monthIn
	set dayIn [eval $daySpecOn]
	set secs [expr {
			wide(86400) * wide($dayIn)
			-210866803200 }]
	set secs [eval [linsert $timeAt 0 convertTimeOfDay \
			    $secs $stdGMTOffset $DSTOffset]]
	if { $secs < $earliest } {
	    set earliest $secs
	    set earliestIdx $i
	}
	incr i 8
    }

    return [list $earliest $earliestIdx]

}

#----------------------------------------------------------------------
#
# convertNamePattern --
#
#	Converts a name pattern to the name of the time zone.







|
<





|

|
|


|

|

|




















|










|
<







|
<
<
|
|
|







<







1022
1023
1024
1025
1026
1027
1028
1029

1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077

1078
1079
1080
1081
1082
1083
1084
1085


1086
1087
1088
1089
1090
1091
1092
1093
1094
1095

1096
1097
1098
1099
1100
1101
1102
#	not change in future years.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc divideRules {ruleSet year} {

    variable rules

    set currentRules {}
    set nSunsetRules 0

    foreach {
	fromYear toYear yearType monthIn daySpecOn timeAt save letter
    } $rules($ruleSet) {
	if {$toYear ne "maximum" && $year > $toYear} {
	    # ignore - rule is in the past
	} else {
	    if {$fromYear eq "minimum" || $fromYear <= $year} {
		lappend currentRules $fromYear $toYear $yearType $monthIn \
			$daySpecOn $timeAt $save $letter
	    }
	    if {$toYear ne "maximum"} {
		incr nSunsetRules
	    }
	}
    }

    return [list $currentRules $nSunsetRules]

}

#----------------------------------------------------------------------
#
# findEarliestRule --
#
#	Find the rule in a rule set that has the earliest start time.
#
# Parameters:
#	remainingRules -- Rules to search
#	year - Year being processed.
#	stdGMTOffset - Current offset of standard time from GMT
#	DSTOffset - Current offset of daylight time from standard,
#		    if daylight time is in effect.
#
# Results:
#	Returns the index in remainingRules of the next rule to
#	go into effect.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} {

    set earliest $::MAXWIDE
    set i 0
    foreach {
	fromYear toYear yearType monthIn daySpecOn timeAt save letter
    } $remainingRules {
	lappend daySpecOn $year $monthIn
	set dayIn [eval $daySpecOn]
	set secs [expr {wide(86400) * wide($dayIn) - 210866803200}]


	set secs [convertTimeOfDay $secs \
		$stdGMTOffset $DSTOffset {expand}$timeAt]
	if {$secs < $earliest} {
	    set earliest $secs
	    set earliestIdx $i
	}
	incr i 8
    }

    return [list $earliest $earliestIdx]

}

#----------------------------------------------------------------------
#
# convertNamePattern --
#
#	Converts a name pattern to the name of the time zone.
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
#	Returns the name of the time zone.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc convertNamePattern { pattern flag } {
    if { [regexp {(.*)/(.*)} $pattern -> standard daylight] } {
	if { $flag ne {} } {
	    set pattern $daylight
	} else {
	    set pattern $standard
	}
    }
    return [string map [list %s $flag] $pattern]
}







|
|
|







1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
#	Returns the name of the time zone.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc convertNamePattern {pattern flag} {
    if {[regexp {(.*)/(.*)} $pattern -> standard daylight]} {
	if {$flag ne ""} {
	    set pattern $daylight
	} else {
	    set pattern $standard
	}
    }
    return [string map [list %s $flag] $pattern]
}
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
#	seconds -- Time at which the GMT day starts, in seconds
#		   from the Posix epoch
#	stdGMTOffset - Offset of Standard Time from Greenwich
#	DSTOffset - Offset of Daylight Time from standard.
#	timeOfDay - Time of day to convert, in seconds from midnight
#	flag - Flag indicating whether the time is Greenwich, Standard
#	       or wall-clock. (g, s, or w)
#      
# Results:
#	Returns the time of day in seconds from the Posix epoch.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc convertTimeOfDay { seconds stdGMTOffset DSTOffset timeOfDay flag } {
    incr seconds $timeOfDay
    switch -exact $flag {
	g - u - z {
	}
	w {
	    incr seconds [expr { -$stdGMTOffset }]
	    incr seconds [expr { -$DSTOffset }]
	}
	z {
	    incr seconds [expr { -$stdGMTOffset }]
	}
    }
    return $seconds
}

#----------------------------------------------------------------------
#
# processTimeZone --
#
#	Generate the information about all time transitions in a
#	time zone.
#
# Parameters:
#	zoneName - Name of the time zone
#	zoneData - List containing the rows describing the time zone,
#		   obtained from 'parseZone.
#
# Results:
#	Returns a list of rows.  Each row consists of a time in
#	seconds from the Posix epoch, an offset from GMT to local
#	that begins at that time, a flag indicating whether DST
#	is in effect after that time, and the printable name of the
#	timezone that goes into effect at that time.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc processTimeZone { zoneName zoneData } {

    set points {}
    set i 0
    foreach { startTime nextGMTOffset dstRule namePattern } $zoneData {
	incr i 4
	set until [lindex $zoneData $i]
	if {! [info exists stdGMTOffset] } {
	    set stdGMTOffset $nextGMTOffset
	}
	if {! [info exists DSTOffset] } {
	    set DSTOffset 0
	}
	if { $startTime eq {minimum} } {
	    set secs $::MINWIDE
	    set year 0
	} else {
	    foreach { year month dayRule timeOfDay } $startTime break
	    lappend dayRule $year $month
	    set startDay [eval $dayRule]
	    set secs [expr {
			    wide(86400) * wide($startDay)
			    -210866803200}]
	    set secs [eval [linsert $timeOfDay 0 convertTimeOfDay \
				$secs $stdGMTOffset $DSTOffset]]
	}
	lappend dstRule \
	    $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \
	    $namePattern $until points
	foreach {stdGMTOffset DSTOffset} [eval $dstRule] break
    }
    return $points
}

#----------------------------------------------------------------------
#
# writeZones --







|








|





|
|


|


















|










|
<


|


|


|


|



|


<
|
<
|
|


|
|
|







1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192

1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210

1211

1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
#	seconds -- Time at which the GMT day starts, in seconds
#		   from the Posix epoch
#	stdGMTOffset - Offset of Standard Time from Greenwich
#	DSTOffset - Offset of Daylight Time from standard.
#	timeOfDay - Time of day to convert, in seconds from midnight
#	flag - Flag indicating whether the time is Greenwich, Standard
#	       or wall-clock. (g, s, or w)
#
# Results:
#	Returns the time of day in seconds from the Posix epoch.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} {
    incr seconds $timeOfDay
    switch -exact $flag {
	g - u - z {
	}
	w {
	    incr seconds [expr {-$stdGMTOffset}]
	    incr seconds [expr {-$DSTOffset}]
	}
	z {
	    incr seconds [expr {-$stdGMTOffset}]
	}
    }
    return $seconds
}

#----------------------------------------------------------------------
#
# processTimeZone --
#
#	Generate the information about all time transitions in a
#	time zone.
#
# Parameters:
#	zoneName - Name of the time zone
#	zoneData - List containing the rows describing the time zone,
#		   obtained from 'parseZone.
#
# Results:
#	Returns a list of rows.	 Each row consists of a time in
#	seconds from the Posix epoch, an offset from GMT to local
#	that begins at that time, a flag indicating whether DST
#	is in effect after that time, and the printable name of the
#	timezone that goes into effect at that time.
#
# Side effects:
#	None.
#
#----------------------------------------------------------------------

proc processTimeZone {zoneName zoneData} {

    set points {}
    set i 0
    foreach {startTime nextGMTOffset dstRule namePattern} $zoneData {
	incr i 4
	set until [lindex $zoneData $i]
	if {![info exists stdGMTOffset]} {
	    set stdGMTOffset $nextGMTOffset
	}
	if {![info exists DSTOffset]} {
	    set DSTOffset 0
	}
	if {$startTime eq "minimum"} {
	    set secs $::MINWIDE
	    set year 0
	} else {
	    lassign $startTime year month dayRule timeOfDay
	    lappend dayRule $year $month
	    set startDay [eval $dayRule]

	    set secs [expr {wide(86400) * wide($startDay) -210866803200}]

	    set secs [convertTimeOfDay $secs \
		    $stdGMTOffset $DSTOffset {expand}$timeOfDay]
	}
	lappend dstRule \
		$year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \
		$namePattern $until points
	lassign [eval $dstRule] stdGMTOffset DSTOffset
    }
    return $points
}

#----------------------------------------------------------------------
#
# writeZones --
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
#
# Side effects:
#	Writes the time zone information files; traces what's happening
#	on the standard output.
#
#----------------------------------------------------------------------

proc writeZones { outDir } {
 
    variable zones

    # Walk the zones

    foreach zoneName [lsort -dictionary [array names zones]] {
	puts "calculating: $zoneName"
	set fileName [eval [list file join $outDir] [file split $zoneName]]

	# Create directories as needed

	set dirName [file dirname $fileName]
	if { ![file exists $dirName] } {
	    puts "creating directory: $dirName"
	    file mkdir $dirName
	}

	# Generate data for a zone

	set data {}
	foreach { 
	    time offset dst name 
	} [processTimeZone $zoneName $zones($zoneName)] {
	    append data \n {    } [list [list $time $offset $dst $name]]
	}
	append data \n

	# Write the data to the information file

	set f [open $fileName w]
	puts $f "\# created by $::argv0 - do not edit"
	puts $f {}
	puts $f [list set TZData(:$zoneName) $data]
	close $f

    }

    return
}

#----------------------------------------------------------------------
#







|
<











|






|
|
|

|







|


<







1234
1235
1236
1237
1238
1239
1240
1241

1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274

1275
1276
1277
1278
1279
1280
1281
#
# Side effects:
#	Writes the time zone information files; traces what's happening
#	on the standard output.
#
#----------------------------------------------------------------------

proc writeZones {outDir} {

    variable zones

    # Walk the zones

    foreach zoneName [lsort -dictionary [array names zones]] {
	puts "calculating: $zoneName"
	set fileName [eval [list file join $outDir] [file split $zoneName]]

	# Create directories as needed

	set dirName [file dirname $fileName]
	if {![file exists $dirName]} {
	    puts "creating directory: $dirName"
	    file mkdir $dirName
	}

	# Generate data for a zone

	set data ""
	foreach {
	    time offset dst name
	} [processTimeZone $zoneName $zones($zoneName)] {
	    append data "\n    " [list [list $time $offset $dst $name]]
	}
	append data \n

	# Write the data to the information file

	set f [open $fileName w]
	puts $f "\# created by $::argv0 - do not edit"
	puts $f ""
	puts $f [list set TZData(:$zoneName) $data]
	close $f

    }

    return
}

#----------------------------------------------------------------------
#
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
#
# Results:
#	None.
#
# Side effects:
#	Creates a file for each link.

proc writeLinks { outDir } {

    variable links

    # Walk the links

    foreach zoneName [lsort -dictionary [array names links]] {
	puts "creating link: $zoneName"
	set fileName [eval [list file join $outDir] [file split $zoneName]]

	# Create directories as needed

	set dirName [file dirname $fileName]
	if { ![file exists $dirName] } {
	    puts "creating directory: $dirName"
	    file mkdir $dirName
	}

	# Create code for the synonym

	set linkTo $links($zoneName)







|
<











|







1289
1290
1291
1292
1293
1294
1295
1296

1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
#
# Results:
#	None.
#
# Side effects:
#	Creates a file for each link.

proc writeLinks {outDir} {

    variable links

    # Walk the links

    foreach zoneName [lsort -dictionary [array names links]] {
	puts "creating link: $zoneName"
	set fileName [eval [list file join $outDir] [file split $zoneName]]

	# Create directories as needed

	set dirName [file dirname $fileName]
	if {![file exists $dirName]} {
	    puts "creating directory: $dirName"
	    file mkdir $dirName
	}

	# Create code for the synonym

	set linkTo $links($zoneName)
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
#
# MAIN PROGRAM
#
#----------------------------------------------------------------------

# Determine directories

foreach { inDir outDir } $argv break

# Initialize count of errors

set errorCount 0

# Parse the Olson files

loadFiles $inDir
if { $errorCount > 0 } {
    exit 1
}

# Check that all riles appearing in Zone and Link lines actually exist

checkForwardRuleRefs
if { $errorCount > 0 } {
    exit 1
}

# Write the time zone information files

writeZones $outDir
writeLinks $outDir
if { $errorCount > 0 } {
    exit 1
}

# All done!

exit







|








|






|







|






1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
#
# MAIN PROGRAM
#
#----------------------------------------------------------------------

# Determine directories

lassign $argv inDir outDir

# Initialize count of errors

set errorCount 0

# Parse the Olson files

loadFiles $inDir
if {$errorCount > 0} {
    exit 1
}

# Check that all riles appearing in Zone and Link lines actually exist

checkForwardRuleRefs
if {$errorCount > 0} {
    exit 1
}

# Write the time zone information files

writeZones $outDir
writeLinks $outDir
if {$errorCount > 0} {
    exit 1
}

# All done!

exit

Changes to tools/tcltk-man2html.tcl.

77
78
79
80
81
82
83


84
85
86

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107
108
109
110
111
112
113
114
115
116
117





118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
    # Set defaults based on original code.
    set tcltkdir ../..
    set tkdir {}
    set tcldir {}
    set webdir ../html
    set build_tcl 0
    set build_tk 0



    # Handle arguments a la GNU:
    #   --version

    #   --help
    #   --srcdir=/path
    #   --htmldir=/path

    foreach option $argv {
	switch -glob -- $option {
	    --version {
		puts "tcltk-man-html $Version"
		exit 0
	    }

	    --help {
		puts "usage: tcltk-man-html \[OPTION\] ...\n"
		puts "  --help              print this help, then exit"
		puts "  --version           print version number, then exit"
		puts "  --srcdir=DIR        find tcl and tk source below DIR"
		puts "  --htmldir=DIR       put generated HTML in DIR"
		puts "  --tcl               build tcl help"
		puts "  --tk                build tk help"

		exit 0
	    }

	    --srcdir=* {
		# length of "--srcdir=" is 9.
		set tcltkdir [string range $option 9 end]
	    }

	    --htmldir=* {
		# length of "--htmldir=" is 10
		set webdir [string range $option 10 end]
	    }






	    --tcl {
		set build_tcl 1
	    }

	    --tk {
		set build_tk 1
	    }

	    default {
		puts stderr "tcltk-man-html: unrecognized option -- `$option'"
		exit 1
	    }
	}
    }

    if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1}

    if {$build_tcl} {
    # Find Tcl.
    set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
		-directory $tcltkdir {tcl{,[8-9].[0-9]{,.[0-9]}}}]] end]
    if {$tcldir == ""} then {
	puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
	exit 1
    }
    puts "using Tcl source directory $tcldir"
    }

    if {$build_tk} {
    # Find Tk.
    set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
		-directory $tcltkdir {tk{,[8-9].[0-9]{,.[0-9]}}}]] end]
    if {$tkdir == ""} then {
	puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
	exit 1
    }
    puts "using Tk source directory $tkdir"
    }

    # the title for the man pages overall
    global overall_title
    set overall_title ""
    if {$build_tcl} {append overall_title "[capitalize $tcldir]"}
    if {$build_tcl && $build_tk} {append overall_title "/"}







>
>



>



















>












>
>
>
>
>



















|
|
|
|
|
|
|
|



|
|
|
|
|
|
|
|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
    # Set defaults based on original code.
    set tcltkdir ../..
    set tkdir {}
    set tcldir {}
    set webdir ../html
    set build_tcl 0
    set build_tk 0
    # Default search version is a glob pattern
    set useversion {{,[8-9].[0-9]{,.[0-9]{,[0-9]}}}}

    # Handle arguments a la GNU:
    #   --version
    #   --useversion=<version>
    #   --help
    #   --srcdir=/path
    #   --htmldir=/path

    foreach option $argv {
	switch -glob -- $option {
	    --version {
		puts "tcltk-man-html $Version"
		exit 0
	    }

	    --help {
		puts "usage: tcltk-man-html \[OPTION\] ...\n"
		puts "  --help              print this help, then exit"
		puts "  --version           print version number, then exit"
		puts "  --srcdir=DIR        find tcl and tk source below DIR"
		puts "  --htmldir=DIR       put generated HTML in DIR"
		puts "  --tcl               build tcl help"
		puts "  --tk                build tk help"
		puts "  --useversion        version of tcl/tk to search for"
		exit 0
	    }

	    --srcdir=* {
		# length of "--srcdir=" is 9.
		set tcltkdir [string range $option 9 end]
	    }

	    --htmldir=* {
		# length of "--htmldir=" is 10
		set webdir [string range $option 10 end]
	    }

	    --useversion=* {
		# length of "--useversion=" is 13
		set useversion [string range $option 13 end]
	    }

	    --tcl {
		set build_tcl 1
	    }

	    --tk {
		set build_tk 1
	    }

	    default {
		puts stderr "tcltk-man-html: unrecognized option -- `$option'"
		exit 1
	    }
	}
    }

    if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1}

    if {$build_tcl} {
	# Find Tcl.
	set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
				       -directory $tcltkdir tcl$useversion]] end]
	if {$tcldir == ""} then {
	    puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
	    exit 1
	}
	puts "using Tcl source directory $tcldir"
    }

    if {$build_tk} {
	# Find Tk.
	set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
				      -directory $tcltkdir tk$useversion]] end]
	if {$tkdir == ""} then {
	    puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
	    exit 1
	}
	puts "using Tk source directory $tkdir"
    }

    # the title for the man pages overall
    global overall_title
    set overall_title ""
    if {$build_tcl} {append overall_title "[capitalize $tcldir]"}
    if {$build_tcl && $build_tk} {append overall_title "/"}

Changes to unix/Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.157 2004/11/24 00:10:30 dkf Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#----------------------------------------------------------------







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.157.2.19 2005/09/23 16:47:35 dgp Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#----------------------------------------------------------------
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60



61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77






78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
mandir			= @mandir@

# The following definition can be set to non-null for special systems
# like AFS with replication.  It allows the pathnames used for installation
# to be different than those used for actually reference files at
# run-time.  INSTALL_ROOT is prepended to $prefix and $exec_prefix
# when installing files.
INSTALL_ROOT		=

# Path for the platform independent Tcl scripting libraries:
TCL_LIBRARY		= $(prefix)/lib/tcl$(VERSION)

# Path to use at runtime to refer to LIB_INSTALL_DIR:
LIB_RUNTIME_DIR		= $(libdir)

# Directory in which to install the program tclsh:
BIN_INSTALL_DIR		= $(INSTALL_ROOT)$(bindir)

# Directory in which to install libtcl.so or libtcl.a:
LIB_INSTALL_DIR		= $(INSTALL_ROOT)$(libdir)

# Path name to use when installing library scripts.
SCRIPT_INSTALL_DIR	= $(INSTALL_ROOT)$(TCL_LIBRARY)

# Directory in which to install the include file tcl.h:
INCLUDE_INSTALL_DIR	= $(INSTALL_ROOT)$(includedir)




# Directory in which to (optionally) install the private tcl headers:
PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir)

# Top-level directory in which to install manual entries:
MAN_INSTALL_DIR		= $(INSTALL_ROOT)$(mandir)

# Directory in which to install manual entry for tclsh:
MAN1_INSTALL_DIR	= $(MAN_INSTALL_DIR)/man1

# Directory in which to install manual entries for Tcl's C library
# procedures:
MAN3_INSTALL_DIR	= $(MAN_INSTALL_DIR)/man3

# Directory in which to install manual entries for the built-in
# Tcl commands:
MANN_INSTALL_DIR	= $(MAN_INSTALL_DIR)/mann







# Package search path.
TCL_PACKAGE_PATH	= @TCL_PACKAGE_PATH@

# Tcl Module default path roots (TIP189).
TCL_MODULE_PATH		=

# Libraries built with optimization switches have this additional extension
TCL_DBGX		= @TCL_DBGX@

# warning flags
CFLAGS_WARNING		= @CFLAGS_WARNING@

# The default switches for optimization or debugging
CFLAGS_DEBUG		= @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE		= @CFLAGS_OPTIMIZE@







|


|
















>
>
>

|















>
>
>
>
>
>




|
<
<
<







34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91



92
93
94
95
96
97
98
mandir			= @mandir@

# The following definition can be set to non-null for special systems
# like AFS with replication.  It allows the pathnames used for installation
# to be different than those used for actually reference files at
# run-time.  INSTALL_ROOT is prepended to $prefix and $exec_prefix
# when installing files.
INSTALL_ROOT		= $(DESTDIR)

# Path for the platform independent Tcl scripting libraries:
TCL_LIBRARY		= @TCL_LIBRARY@

# Path to use at runtime to refer to LIB_INSTALL_DIR:
LIB_RUNTIME_DIR		= $(libdir)

# Directory in which to install the program tclsh:
BIN_INSTALL_DIR		= $(INSTALL_ROOT)$(bindir)

# Directory in which to install libtcl.so or libtcl.a:
LIB_INSTALL_DIR		= $(INSTALL_ROOT)$(libdir)

# Path name to use when installing library scripts.
SCRIPT_INSTALL_DIR	= $(INSTALL_ROOT)$(TCL_LIBRARY)

# Directory in which to install the include file tcl.h:
INCLUDE_INSTALL_DIR	= $(INSTALL_ROOT)$(includedir)

# Path to the private tcl header dir:
PRIVATE_INCLUDE_DIR	= @PRIVATE_INCLUDE_DIR@

# Directory in which to (optionally) install the private tcl headers:
PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(PRIVATE_INCLUDE_DIR)

# Top-level directory in which to install manual entries:
MAN_INSTALL_DIR		= $(INSTALL_ROOT)$(mandir)

# Directory in which to install manual entry for tclsh:
MAN1_INSTALL_DIR	= $(MAN_INSTALL_DIR)/man1

# Directory in which to install manual entries for Tcl's C library
# procedures:
MAN3_INSTALL_DIR	= $(MAN_INSTALL_DIR)/man3

# Directory in which to install manual entries for the built-in
# Tcl commands:
MANN_INSTALL_DIR	= $(MAN_INSTALL_DIR)/mann

# Path to the html documentation dir:
HTML_DIR		= @HTML_DIR@

# Directory in which to install html documentation:
HTML_INSTALL_DIR	= $(INSTALL_ROOT)$(HTML_DIR)

# Package search path.
TCL_PACKAGE_PATH	= @TCL_PACKAGE_PATH@

# Tcl Module default path roots (TIP189).
TCL_MODULE_PATH		= @TCL_MODULE_PATH@




# warning flags
CFLAGS_WARNING		= @CFLAGS_WARNING@

# The default switches for optimization or debugging
CFLAGS_DEBUG		= @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE		= @CFLAGS_OPTIMIZE@
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
LDFLAGS			= @LDFLAGS_DEFAULT@ @LDFLAGS@

# To disable ANSI-C procedure prototypes reverse the comment characters
# on the following lines:
PROTO_FLAGS		=
#PROTO_FLAGS		= -DNO_PROTOTYPE

# Mathematical functions like sin and atan2 are enabled for expressions
# by default.  To disable them, reverse the comment characters on the
# following pairs of lines:
MATH_FLAGS		=
#MATH_FLAGS		= -DTCL_NO_MATH

# If you use the setenv, putenv, or unsetenv procedures to modify
# environment variables in your application and you'd like those
# modifications to appear in the "env" Tcl variable, switch the
# comments on the two lines below so that Tcl provides these
# procedures instead of your standard C library.

ENV_FLAGS =







<
<
<
<
<
<







110
111
112
113
114
115
116






117
118
119
120
121
122
123
LDFLAGS			= @LDFLAGS_DEFAULT@ @LDFLAGS@

# To disable ANSI-C procedure prototypes reverse the comment characters
# on the following lines:
PROTO_FLAGS		=
#PROTO_FLAGS		= -DNO_PROTOTYPE







# If you use the setenv, putenv, or unsetenv procedures to modify
# environment variables in your application and you'd like those
# modifications to appear in the "env" Tcl variable, switch the
# comments on the two lines below so that Tcl provides these
# procedures instead of your standard C library.

ENV_FLAGS =
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

# Tcl used to let the configure script choose which program to use
# for installing, but there are just too many different versions of
# "install" around;  better to use the install-sh script that comes
# with the distribution, which is slower but guaranteed to work.

INSTALL_STRIP_PROGRAM   = -s
INSTALL_STRIP_LIBRARY  = -S -S

INSTALL			= @srcdir@/install-sh -c
INSTALL_PROGRAM		= ${INSTALL}
INSTALL_LIBRARY		= ${INSTALL}
INSTALL_DATA		= ${INSTALL} -m 644

# TCL_EXE is the name of a tclsh executable that is available *BEFORE*







|







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

# Tcl used to let the configure script choose which program to use
# for installing, but there are just too many different versions of
# "install" around;  better to use the install-sh script that comes
# with the distribution, which is slower but guaranteed to work.

INSTALL_STRIP_PROGRAM   = -s
INSTALL_STRIP_LIBRARY   = -S -S

INSTALL			= @srcdir@/install-sh -c
INSTALL_PROGRAM		= ${INSTALL}
INSTALL_LIBRARY		= ${INSTALL}
INSTALL_DATA		= ${INSTALL} -m 644

# TCL_EXE is the name of a tclsh executable that is available *BEFORE*
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
# symbols mean.  The values of the symbols are normally set by the
# configure script.  You shouldn't normally need to modify any of
# these definitions by hand.

STLIB_LD		= @STLIB_LD@
SHLIB_LD		= @SHLIB_LD@
SHLIB_CFLAGS		= @SHLIB_CFLAGS@
SHLIB_LD_FLAGS		= @SHLIB_LD_FLAGS@
SHLIB_LD_LIBS		= @SHLIB_LD_LIBS@
TCL_SHLIB_LD_EXTRAS	= @TCL_SHLIB_LD_EXTRAS@

SHLIB_SUFFIX		= @SHLIB_SUFFIX@
#SHLIB_SUFFIX		=

DLTEST_TARGETS		= dltest.marker







<







185
186
187
188
189
190
191

192
193
194
195
196
197
198
# symbols mean.  The values of the symbols are normally set by the
# configure script.  You shouldn't normally need to modify any of
# these definitions by hand.

STLIB_LD		= @STLIB_LD@
SHLIB_LD		= @SHLIB_LD@
SHLIB_CFLAGS		= @SHLIB_CFLAGS@

SHLIB_LD_LIBS		= @SHLIB_LD_LIBS@
TCL_SHLIB_LD_EXTRAS	= @TCL_SHLIB_LD_EXTRAS@

SHLIB_SUFFIX		= @SHLIB_SUFFIX@
#SHLIB_SUFFIX		=

DLTEST_TARGETS		= dltest.marker
238
239
240
241
242
243
244

245
246
247
248
249
250
251
AC_FLAGS		= @DEFS@
AR			= @AR@
RANLIB			= @RANLIB@
SRC_DIR			= @srcdir@
TOP_DIR			= $(SRC_DIR)/..
BUILD_DIR		= @builddir@
GENERIC_DIR		= $(TOP_DIR)/generic

COMPAT_DIR		= $(TOP_DIR)/compat
TOOL_DIR		= $(TOP_DIR)/tools
UNIX_DIR		= $(SRC_DIR)
MAC_OSX_DIR		= $(TOP_DIR)/macosx
# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR		= @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.







>







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
AC_FLAGS		= @DEFS@
AR			= @AR@
RANLIB			= @RANLIB@
SRC_DIR			= @srcdir@
TOP_DIR			= $(SRC_DIR)/..
BUILD_DIR		= @builddir@
GENERIC_DIR		= $(TOP_DIR)/generic
TOMMATH_DIR		= $(TOP_DIR)/libtommath
COMPAT_DIR		= $(TOP_DIR)/compat
TOOL_DIR		= $(TOP_DIR)/tools
UNIX_DIR		= $(SRC_DIR)
MAC_OSX_DIR		= $(TOP_DIR)/macosx
# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR		= @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
271
272
273
274
275
276
277
278
279
280
281
282
283
284

285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309

310

311
312

313




















314
315
316
317
318
319
320
321
322
323
324
325
326
# The information below should be usable as is.  The configure
# script won't modify it and you shouldn't need to modify it
# either.
#----------------------------------------------------------------


CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} \
${NO_DEPRECATED_FLAGS} ${ENV_FLAGS}

STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS}


LIBS		= @TCL_LIBS@

DEPEND_SWITCHES	= ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} \
${GENERIC_FLAGS} ${PROTO_FLAGS}

TCLSH_OBJS = tclAppInit.o

TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclThreadTest.o	tclUnixTest.o

XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclThreadTest.o	tclUnixTest.o tclXtNotify.o tclXtTest.o 

GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
	tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \
	tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \
	tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \
	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
	tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
	tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \
	tclPkg.o tclPkgConfig.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \

	tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \

	tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
	tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o






















STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS}

MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o

OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
        @DL_OBJS@ @PLAT_OBJS@

TCL_DECLS = \
	$(GENERIC_DIR)/tcl.decls \
	$(GENERIC_DIR)/tclInt.decls

GENERIC_HDRS = \
	$(GENERIC_DIR)/tcl.h \







|
|
|


|
|
>




<
|















|


|
>
|
>

|
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|

|
|







271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289

290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
# The information below should be usable as is.  The configure
# script won't modify it and you shouldn't need to modify it
# either.
#----------------------------------------------------------------


CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -DMP_PREC=4 \
-I${TOMMATH_DIR} ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} \
${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} @EXTRA_CC_SWITCHES@

STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -DMP_PREC=4 \
-I${TOMMATH_DIR} ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} \
@EXTRA_CC_SWITCHES@

LIBS		= @TCL_LIBS@

DEPEND_SWITCHES	= ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \

${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} @EXTRA_CC_SWITCHES@

TCLSH_OBJS = tclAppInit.o

TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclThreadTest.o	tclUnixTest.o

XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclThreadTest.o	tclUnixTest.o tclXtNotify.o tclXtTest.o 

GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
	tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \
	tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \
	tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \
	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
	tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
	tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \
	tclPkg.o tclPkgConfig.o tclPosixStr.o \
	tclPreserve.o tclProc.o tclRegexp.o \
	tclResolve.o tclResult.o tclScan.o tclStringObj.o \
	tclStrToD.o tclThread.o \
	tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
	tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o \
	tclTomMathInterface.o

TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \
	bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \
        bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \
        bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o bn_mp_copy.o \
	bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \
	bn_mp_div_2d.o bn_mp_div_3.o \
        bn_mp_exch.o bn_mp_expt_d.o bn_mp_grow.o bn_mp_init.o \
	bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \
	bn_mp_init_size.o bn_mp_karatsuba_mul.o \
	bn_mp_karatsuba_sqr.o \
        bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \
        bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \
	bn_mp_radix_size.o bn_mp_radix_smap.o \
        bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_shrink.o \
	bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \
        bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
	bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \
	bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
        bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o

STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS}

MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o

OBJS = ${GENERIC_OBJS} ${TOMMATH_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} \
	${COMPAT_OBJS} @DL_OBJS@ @PLAT_OBJS@

TCL_DECLS = \
	$(GENERIC_DIR)/tcl.decls \
	$(GENERIC_DIR)/tclInt.decls

GENERIC_HDRS = \
	$(GENERIC_DIR)/tcl.h \
365
366
367
368
369
370
371

372
373
374
375
376
377
378
	$(GENERIC_DIR)/tclIndexObj.c \
	$(GENERIC_DIR)/tclInterp.c \
	$(GENERIC_DIR)/tclIO.c \
	$(GENERIC_DIR)/tclIOCmd.c \
	$(GENERIC_DIR)/tclIOGT.c \
	$(GENERIC_DIR)/tclIOSock.c \
	$(GENERIC_DIR)/tclIOUtil.c \

	$(GENERIC_DIR)/tclLink.c \
	$(GENERIC_DIR)/tclListObj.c \
	$(GENERIC_DIR)/tclLiteral.c \
	$(GENERIC_DIR)/tclLoad.c \
	$(GENERIC_DIR)/tclMain.c \
	$(GENERIC_DIR)/tclNamesp.c \
	$(GENERIC_DIR)/tclNotify.c \







>







388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
	$(GENERIC_DIR)/tclIndexObj.c \
	$(GENERIC_DIR)/tclInterp.c \
	$(GENERIC_DIR)/tclIO.c \
	$(GENERIC_DIR)/tclIOCmd.c \
	$(GENERIC_DIR)/tclIOGT.c \
	$(GENERIC_DIR)/tclIOSock.c \
	$(GENERIC_DIR)/tclIOUtil.c \
	$(GENERIC_DIR)/tclIORChan.c \
	$(GENERIC_DIR)/tclLink.c \
	$(GENERIC_DIR)/tclListObj.c \
	$(GENERIC_DIR)/tclLiteral.c \
	$(GENERIC_DIR)/tclLoad.c \
	$(GENERIC_DIR)/tclMain.c \
	$(GENERIC_DIR)/tclNamesp.c \
	$(GENERIC_DIR)/tclNotify.c \
389
390
391
392
393
394
395

396
397
398
399
400
401
402
403
404
405
406
407
408
409
410































































411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430


431
432
433
434
435
436
437
438
439
440
441
442

443
444
445
446
447
448


449
450
451
452
453
454
455
	$(GENERIC_DIR)/tclRegexp.c \
	$(GENERIC_DIR)/tclResolve.c \
	$(GENERIC_DIR)/tclResult.c \
	$(GENERIC_DIR)/tclScan.c \
	$(GENERIC_DIR)/tclStubInit.c \
	$(GENERIC_DIR)/tclStubLib.c \
	$(GENERIC_DIR)/tclStringObj.c \

	$(GENERIC_DIR)/tclTest.c \
	$(GENERIC_DIR)/tclTestObj.c \
	$(GENERIC_DIR)/tclTestProcBodyObj.c \
	$(GENERIC_DIR)/tclThread.c \
	$(GENERIC_DIR)/tclThreadAlloc.c \
	$(GENERIC_DIR)/tclThreadJoin.c \
	$(GENERIC_DIR)/tclThreadStorage.c \
	$(GENERIC_DIR)/tclTimer.c \
	$(GENERIC_DIR)/tclTrace.c \
	$(GENERIC_DIR)/tclUtil.c \
	$(GENERIC_DIR)/tclVar.c

STUB_SRCS = \
	$(GENERIC_DIR)/tclStubLib.c
































































UNIX_HDRS = \
	$(UNIX_DIR)/tclUnixPort.h
#	$(UNIX_DIR)/tclConfig.h

UNIX_SRCS = \
	$(UNIX_DIR)/tclAppInit.c \
	$(UNIX_DIR)/tclUnixChan.c \
	$(UNIX_DIR)/tclUnixEvent.c \
	$(UNIX_DIR)/tclUnixFCmd.c \
	$(UNIX_DIR)/tclUnixFile.c \
	$(UNIX_DIR)/tclUnixNotfy.c \
	$(UNIX_DIR)/tclUnixPipe.c \
	$(UNIX_DIR)/tclUnixSock.c \
	$(UNIX_DIR)/tclUnixTest.c \
	$(UNIX_DIR)/tclUnixThrd.c \
	$(UNIX_DIR)/tclUnixTime.c \
	$(UNIX_DIR)/tclUnixInit.c

DL_SRCS = \
	$(UNIX_DIR)/tclLoadAix.c \


	$(UNIX_DIR)/tclLoadAout.c \
	$(UNIX_DIR)/tclLoadDl.c \
	$(UNIX_DIR)/tclLoadDl2.c \
	$(UNIX_DIR)/tclLoadDld.c \
	$(UNIX_DIR)/tclLoadDyld.c \
	$(GENERIC_DIR)/tclLoadNone.c \
	$(UNIX_DIR)/tclLoadOSF.c \
	$(UNIX_DIR)/tclLoadShl.c

MAC_OSX_SRCS = \
	$(MAC_OSX_DIR)/tclMacOSXBundle.c \
	$(MAC_OSX_DIR)/tclMacOSXFCmd.c


# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those
# files won't compile on the current machine, and they will cause
# problems for things like "make depend".

SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(STUB_SRCS)



all: binaries libraries doc

binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh

libraries:








>















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










<







|
|
>
>
|










|
>





|
>
>







413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508

509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
	$(GENERIC_DIR)/tclRegexp.c \
	$(GENERIC_DIR)/tclResolve.c \
	$(GENERIC_DIR)/tclResult.c \
	$(GENERIC_DIR)/tclScan.c \
	$(GENERIC_DIR)/tclStubInit.c \
	$(GENERIC_DIR)/tclStubLib.c \
	$(GENERIC_DIR)/tclStringObj.c \
	$(GENERIC_DIR)/tclStrToD.c \
	$(GENERIC_DIR)/tclTest.c \
	$(GENERIC_DIR)/tclTestObj.c \
	$(GENERIC_DIR)/tclTestProcBodyObj.c \
	$(GENERIC_DIR)/tclThread.c \
	$(GENERIC_DIR)/tclThreadAlloc.c \
	$(GENERIC_DIR)/tclThreadJoin.c \
	$(GENERIC_DIR)/tclThreadStorage.c \
	$(GENERIC_DIR)/tclTimer.c \
	$(GENERIC_DIR)/tclTrace.c \
	$(GENERIC_DIR)/tclUtil.c \
	$(GENERIC_DIR)/tclVar.c

STUB_SRCS = \
	$(GENERIC_DIR)/tclStubLib.c

TOMMATH_SRCS = \
	$(TOMMATH_DIR)/bncore.c \
	$(TOMMATH_DIR)/bn_reverse.c \
	$(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \
	$(TOMMATH_DIR)/bn_fast_s_mp_sqr.c \
	$(TOMMATH_DIR)/bn_mp_add.c \
	$(TOMMATH_DIR)/bn_mp_add_d.c \
	$(TOMMATH_DIR)/bn_mp_and.c \
	$(TOMMATH_DIR)/bn_mp_clamp.c \
	$(TOMMATH_DIR)/bn_mp_clear.c \
	$(TOMMATH_DIR)/bn_mp_clear_multi.c \
	$(TOMMATH_DIR)/bn_mp_cmp.c \
	$(TOMMATH_DIR)/bn_mp_cmp_d.c \
	$(TOMMATH_DIR)/bn_mp_cmp_mag.c \
	$(TOMMATH_DIR)/bn_mp_copy.c \
	$(TOMMATH_DIR)/bn_mp_count_bits.c \
	$(TOMMATH_DIR)/bn_mp_div.c \
	$(TOMMATH_DIR)/bn_mp_div_d.c \
	$(TOMMATH_DIR)/bn_mp_div_2.c \
	$(TOMMATH_DIR)/bn_mp_div_2d.c \
	$(TOMMATH_DIR)/bn_mp_div_3.c \
	$(TOMMATH_DIR)/bn_mp_exch.c \
	$(TOMMATH_DIR)/bn_mp_expt_d.c \
	$(TOMMATH_DIR)/bn_mp_grow.c \
	$(TOMMATH_DIR)/bn_mp_init.c \
	$(TOMMATH_DIR)/bn_mp_init_copy.c \
	$(TOMMATH_DIR)/bn_mp_init_multi.c \
	$(TOMMATH_DIR)/bn_mp_init_set.c \
	$(TOMMATH_DIR)/bn_mp_init_size.c \
	$(TOMMATH_DIR)/bn_mp_karatsuba_mul.c \
	$(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c \
	$(TOMMATH_DIR)/bn_mp_lshd.c \
	$(TOMMATH_DIR)/bn_mp_mod.c \
	$(TOMMATH_DIR)/bn_mp_mod_2d.c \
	$(TOMMATH_DIR)/bn_mp_mul.c \
	$(TOMMATH_DIR)/bn_mp_mul_2.c \
	$(TOMMATH_DIR)/bn_mp_mul_2d.c \
	$(TOMMATH_DIR)/bn_mp_mul_d.c \
	$(TOMMATH_DIR)/bn_mp_neg.c \
	$(TOMMATH_DIR)/bn_mp_or.c \
	$(TOMMATH_DIR)/bn_mp_radix_size.c \
	$(TOMMATH_DIR)/bn_mp_radix_smap.c \
	$(TOMMATH_DIR)/bn_mp_read_radix.c \
	$(TOMMATH_DIR)/bn_mp_rshd.c \
	$(TOMMATH_DIR)/bn_mp_set.c \
	$(TOMMATH_DIR)/bn_mp_shrink.c \
	$(TOMMATH_DIR)/bn_mp_sqr.c \
	$(TOMMATH_DIR)/bn_mp_sqrt.c \
	$(TOMMATH_DIR)/bn_mp_sub.c \
	$(TOMMATH_DIR)/bn_mp_sub_d.c \
	$(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \
	$(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \
	$(TOMMATH_DIR)/bn_mp_toom_mul.c \
	$(TOMMATH_DIR)/bn_mp_toom_sqr.c \
	$(TOMMATH_DIR)/bn_mp_toradix_n.c \
	$(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \
	$(TOMMATH_DIR)/bn_mp_xor.c \
	$(TOMMATH_DIR)/bn_mp_zero.c \
	$(TOMMATH_DIR)/bn_s_mp_add.c \
	$(TOMMATH_DIR)/bn_s_mp_mul_digs.c \
	$(TOMMATH_DIR)/bn_s_mp_sqr.c \
	$(TOMMATH_DIR)/bn_s_mp_sub.c

UNIX_HDRS = \
	$(UNIX_DIR)/tclUnixPort.h
#	$(UNIX_DIR)/tclConfig.h

UNIX_SRCS = \
	$(UNIX_DIR)/tclAppInit.c \
	$(UNIX_DIR)/tclUnixChan.c \
	$(UNIX_DIR)/tclUnixEvent.c \
	$(UNIX_DIR)/tclUnixFCmd.c \
	$(UNIX_DIR)/tclUnixFile.c \

	$(UNIX_DIR)/tclUnixPipe.c \
	$(UNIX_DIR)/tclUnixSock.c \
	$(UNIX_DIR)/tclUnixTest.c \
	$(UNIX_DIR)/tclUnixThrd.c \
	$(UNIX_DIR)/tclUnixTime.c \
	$(UNIX_DIR)/tclUnixInit.c

NOTIFY_SRCS = \
	$(UNIX_DIR)/tclUnixNotfy.c

DL_SRCS = \
	$(UNIX_DIR)/tclLoadAix.c \
	$(UNIX_DIR)/tclLoadDl.c \
	$(UNIX_DIR)/tclLoadDl2.c \
	$(UNIX_DIR)/tclLoadDld.c \
	$(UNIX_DIR)/tclLoadDyld.c \
	$(GENERIC_DIR)/tclLoadNone.c \
	$(UNIX_DIR)/tclLoadOSF.c \
	$(UNIX_DIR)/tclLoadShl.c

MAC_OSX_SRCS = \
	$(MAC_OSX_DIR)/tclMacOSXBundle.c \
	$(MAC_OSX_DIR)/tclMacOSXFCmd.c \
	$(MAC_OSX_DIR)/tclMacOSXNotify.c

# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those
# files won't compile on the current machine, and they will cause
# problems for things like "make depend".

SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) \
	$(UNIX_SRCS) $(NOTIFY_SRCS) $(STUB_SRCS) \
	@PLAT_SRCS@

all: binaries libraries doc

binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh

libraries:

497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564

565
566
567
568
569
570
571
572
573
574
575
576
577









578
579
580
581
582
583
584
585
586
587
588
589


590
591
592
593
594
595
596
597
598
# "make test" won't work in the case where the compilation directory
# isn't the same as the source directory.
# Specifying TESTFLAGS on the command line is the standard way to pass
# args to tcltest, ie:
#	% make test TESTFLAGS="-verbose bps -file fileName.test"

test: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) $(TCLTESTARGS)

# Useful target to launch a built tcltest with the proper path,...
runtest: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tcltest

# Useful target for running the test suite with an unwritable current
# directory...
ro-test: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest

# This target can be used to run tclsh from the build directory
# via `make shell SCRIPT=/tmp/foo.tcl`
shell: tclsh
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(SCRIPT)

# This target can be used to run tclsh inside either gdb or insight
gdb: tclsh
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	$(GDB) ./tclsh --command=gdb.run
	rm gdb.run

# This target can be used to run tclsh inside ddd
ddd: tclsh
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	$(DDD) -command=gdb.run ./tclsh
	rm gdb.run

valgrind: tclsh tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	valgrind --num-callers=8 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) $(TCLTESTARGS)

# The following target outputs the name of the top-level source directory
# for Tcl (it is used by Tk's configure script, for example).  The
# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake".
# Note: this target is now obsolete (use the autoconf variable
# TCL_SRC_DIR from tclConfig.sh instead).

.NO_PARALLEL: topDirName
topDirName:
	@cd $(TOP_DIR); pwd

# The following target generates the file generic/tclDate.c 
# from the yacc grammar found in generic/tclGetDate.y.  This is
# only run by hand as yacc is not available in all environments.
# The name of the .c file is different than the name of the .y file
# so that make doesn't try to automatically regenerate the .c file.

gendate:
	bison --output-file=$(GENERIC_DIR)/tclDate.c \

	--name-prefix=TclDate \
	$(GENERIC_DIR)/tclGetDate.y

#	yacc -l $(GENERIC_DIR)/tclGetDate.y
#	sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \
#	    -e 's?SCCSID?RCS: @(#) ?' \
#	    -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
#	    -e '/TclDatenewstate:/d' -e '/#pragma/d' \
#	    -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \
#           -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \
#	    -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \
#	    <y.tab.c >$(GENERIC_DIR)/tclDate.c
#	rm y.tab.c










# The following target generates the shared libraries in dltest/ that
# are used for testing;  they are included as part of the "tcltest"
# target (via the BUILD_DLTEST variable) if dynamic loading is supported
# on this platform. The Makefile in the dltest subdirectory creates
# the dltest.marker file in this directory after a successful build.

dltest.marker:
	cd dltest ; $(MAKE)

install: install-binaries install-libraries install-doc



install-strip:
	$(MAKE) install \
		INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
		INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}"

# Note: before running ranlib below, must cd to target directory because
# some ranlibs write to current directory, and this might not always be
# possible (e.g. if installing as root).








|

|



|






|






|





|






|





|

|



















>













>
>
>
>
>
>
>
>
>










|

>
>

|







589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
# "make test" won't work in the case where the compilation directory
# isn't the same as the source directory.
# Specifying TESTFLAGS on the command line is the standard way to pass
# args to tcltest, ie:
#	% make test TESTFLAGS="-verbose bps -file fileName.test"

test: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS)

# Useful target to launch a built tcltest with the proper path,...
runtest: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tcltest

# Useful target for running the test suite with an unwritable current
# directory...
ro-test: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest

# This target can be used to run tclsh from the build directory
# via `make shell SCRIPT=/tmp/foo.tcl`
shell: tclsh
	@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(SCRIPT)

# This target can be used to run tclsh inside either gdb or insight
gdb: tclsh
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	$(GDB) ./tclsh --command=gdb.run
	rm gdb.run

# This target can be used to run tclsh inside ddd
ddd: tclsh
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	$(DDD) -command=gdb.run ./tclsh
	rm gdb.run

valgrind: tclsh tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	valgrind --num-callers=8 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS)

# The following target outputs the name of the top-level source directory
# for Tcl (it is used by Tk's configure script, for example).  The
# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake".
# Note: this target is now obsolete (use the autoconf variable
# TCL_SRC_DIR from tclConfig.sh instead).

.NO_PARALLEL: topDirName
topDirName:
	@cd $(TOP_DIR); pwd

# The following target generates the file generic/tclDate.c 
# from the yacc grammar found in generic/tclGetDate.y.  This is
# only run by hand as yacc is not available in all environments.
# The name of the .c file is different than the name of the .y file
# so that make doesn't try to automatically regenerate the .c file.

gendate:
	bison --output-file=$(GENERIC_DIR)/tclDate.c \
	--no-lines \
	--name-prefix=TclDate \
	$(GENERIC_DIR)/tclGetDate.y

#	yacc -l $(GENERIC_DIR)/tclGetDate.y
#	sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \
#	    -e 's?SCCSID?RCS: @(#) ?' \
#	    -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
#	    -e '/TclDatenewstate:/d' -e '/#pragma/d' \
#	    -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \
#           -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \
#	    -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \
#	    <y.tab.c >$(GENERIC_DIR)/tclDate.c
#	rm y.tab.c

# The following target generates the file generic/tommath.h.
# It needs to be run (and the results checked) after updating
# to a new release of libtommath.

gentommath_h:
	$(TCL_EXE) "$(TOP_DIR)/tools/fix_tommath_h.tcl" \
		"$(TOMMATH_DIR)/tommath.h" \
		> "$(GENERIC_DIR)/tommath.h"

# The following target generates the shared libraries in dltest/ that
# are used for testing;  they are included as part of the "tcltest"
# target (via the BUILD_DLTEST variable) if dynamic loading is supported
# on this platform. The Makefile in the dltest subdirectory creates
# the dltest.marker file in this directory after a successful build.

dltest.marker:
	cd dltest ; $(MAKE)

INSTALL_TARGETS = install-binaries install-libraries install-doc @EXTRA_INSTALL@

install: $(INSTALL_TARGETS)

install-strip:
	$(MAKE) $(INSTALL_TARGETS) \
		INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
		INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}"

# Note: before running ranlib below, must cd to target directory because
# some ranlibs write to current directory, and this might not always be
# possible (e.g. if installing as root).

621
622
623
624
625
626
627

628
629
630
631
632
633
634
	@$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION)
	@echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/"
	@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
	@if test "$(STUB_LIB_FILE)" != "" ; then \
	    echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
	    @INSTALL_STUB_LIB@ ; \
	fi


install-libraries: libraries install-tzdata install-msgs
	@for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \
	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		mkdir -p $$i; \







>







725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
	@$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION)
	@echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/"
	@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
	@if test "$(STUB_LIB_FILE)" != "" ; then \
	    echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
	    @INSTALL_STUB_LIB@ ; \
	fi
	@EXTRA_INSTALL_BINARIES@

install-libraries: libraries install-tzdata install-msgs
	@for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \
	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		mkdir -p $$i; \
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
	    $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \
	    done;
	@echo "Installing library http1.0 directory";
	@for j in $(TOP_DIR)/library/http1.0/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \
	    done;
	@echo "Installing package http 2.5.0 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.0.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.4.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm;
	@echo "Installing package tcltest 2.2.7 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.7.tm;
	@echo "Installing library encoding directory";
	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
		$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \
	done;
	@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \
	    echo "Customizing tcl module path"; \
	    echo "::tcl::tm::roots {$(TCL_MODULE_PATH)}" >> \
	        $(SCRIPT_INSTALL_DIR)/tm.tcl; \
	fi

install-tzdata:
	@echo "Installing time zone data"
	@@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(TOOL_DIR)/installData.tcl \
	    $(TOP_DIR)/library/tzdata $(SCRIPT_INSTALL_DIR)/tzdata

install-msgs:
	@echo "Installing message catalogs"
	@@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(TOOL_DIR)/installData.tcl \
	    $(TOP_DIR)/library/msgs $(SCRIPT_INSTALL_DIR)/msgs

install-doc: doc
	@if test ! -x $(UNIX_DIR)/installManPage; then \
	    chmod +x $(UNIX_DIR)/installManPage; \







|
|







|
|












|






|







765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
	    $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \
	    done;
	@echo "Installing library http1.0 directory";
	@for j in $(TOP_DIR)/library/http1.0/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \
	    done;
	@echo "Installing package http 2.5.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.4.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm;
	@echo "Installing package tcltest 2.2.8 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm;
	@echo "Installing library encoding directory";
	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
		$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \
	done;
	@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \
	    echo "Customizing tcl module path"; \
	    echo "::tcl::tm::roots {$(TCL_MODULE_PATH)}" >> \
	        $(SCRIPT_INSTALL_DIR)/tm.tcl; \
	fi

install-tzdata:
	@echo "Installing time zone data"
	@@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(TOOL_DIR)/installData.tcl \
	    $(TOP_DIR)/library/tzdata $(SCRIPT_INSTALL_DIR)/tzdata

install-msgs:
	@echo "Installing message catalogs"
	@@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(TOOL_DIR)/installData.tcl \
	    $(TOP_DIR)/library/msgs $(SCRIPT_INSTALL_DIR)/msgs

install-doc: doc
	@if test ! -x $(UNIX_DIR)/installManPage; then \
	    chmod +x $(UNIX_DIR)/installManPage; \
744
745
746
747
748
749
750



751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
	@echo "Installing private header files";
	@for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
		$(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \
		$(UNIX_DIR)/tclUnixPort.h; \
	    do \
	    $(INSTALL_DATA) $$i $(PRIVATE_INCLUDE_INSTALL_DIR); \
	    done;




Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
	$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
#	$(SHELL) config.status

clean:
	rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
		errors tclsh tcltest lib.exp
	cd dltest ; $(MAKE) clean

distclean: clean
	rm -rf Makefile config.status config.cache config.log tclConfig.sh \
		$(PACKAGE).* prototype #tclConfig.h
	cd dltest ; $(MAKE) distclean

depend:
	makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)

# Test binaries.  The rules for tclTestInit.o and xtTestInit.o are
# complicated because they are compiled from tclAppInit.c.  Can't use







>
>
>








|




|







849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
	@echo "Installing private header files";
	@for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
		$(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \
		$(UNIX_DIR)/tclUnixPort.h; \
	    do \
	    $(INSTALL_DATA) $$i $(PRIVATE_INCLUDE_INSTALL_DIR); \
	    done;
	@if test -f tclConfig.h; then\
	    $(INSTALL_DATA) tclConfig.h $(PRIVATE_INCLUDE_INSTALL_DIR); \
	    fi;

Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
	$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
#	$(SHELL) config.status

clean:
	rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
		errors tclsh tcltest lib.exp Tcl
	cd dltest ; $(MAKE) clean

distclean: clean
	rm -rf Makefile config.status config.cache config.log tclConfig.sh \
		$(PACKAGE).* prototype tclConfig.h *.plist Tcl.framework
	cd dltest ; $(MAKE) distclean

depend:
	makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)

# Test binaries.  The rules for tclTestInit.o and xtTestInit.o are
# complicated because they are compiled from tclAppInit.c.  Can't use
913
914
915
916
917
918
919



920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947

tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c

tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c




tclLink.o: $(GENERIC_DIR)/tclLink.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c

tclListObj.o: $(GENERIC_DIR)/tclListObj.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c

tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c

tclObj.o: $(GENERIC_DIR)/tclObj.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c

tclLoad.o: $(GENERIC_DIR)/tclLoad.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c

tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c

tclLoadAout.o: $(UNIX_DIR)/tclLoadAout.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAout.c

tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c

tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c

tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c







>
>
>


















<
<
<







1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048



1049
1050
1051
1052
1053
1054
1055

tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c

tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c

tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c

tclLink.o: $(GENERIC_DIR)/tclLink.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c

tclListObj.o: $(GENERIC_DIR)/tclListObj.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c

tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c

tclObj.o: $(GENERIC_DIR)/tclObj.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c

tclLoad.o: $(GENERIC_DIR)/tclLoad.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c

tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c




tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c

tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c

tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c
1031
1032
1033
1034
1035
1036
1037



1038
1039
1040
1041
1042
1043
1044

tclScan.o: $(GENERIC_DIR)/tclScan.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c

tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c




tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c

tclTrace.o: $(GENERIC_DIR)/tclTrace.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c

tclUtil.o: $(GENERIC_DIR)/tclUtil.c







>
>
>







1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155

tclScan.o: $(GENERIC_DIR)/tclScan.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c

tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c

tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c

tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c

tclTrace.o: $(GENERIC_DIR)/tclTrace.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c

tclUtil.o: $(GENERIC_DIR)/tclUtil.c
1073
1074
1075
1076
1077
1078
1079


























































































































































































1080
1081
1082
1083
1084
1085
1086

tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c

tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c



























































































































































































tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c

tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c

tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383

tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c

tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c

tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c

bncore.o: $(TOMMATH_DIR)/bncore.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bncore.c

bn_reverse.o: $(TOMMATH_DIR)/bn_reverse.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_reverse.c

bn_fast_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c

bn_fast_s_mp_sqr.o: $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c

bn_mp_add.o: $(TOMMATH_DIR)/bn_mp_add.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add.c

bn_mp_add_d.o: $(TOMMATH_DIR)/bn_mp_add_d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add_d.c

bn_mp_and.o: $(TOMMATH_DIR)/bn_mp_and.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_and.c

bn_mp_clamp.o: $(TOMMATH_DIR)/bn_mp_clamp.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clamp.c

bn_mp_clear.o: $(TOMMATH_DIR)/bn_mp_clear.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clear.c

bn_mp_clear_multi.o: $(TOMMATH_DIR)/bn_mp_clear_multi.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clear_multi.c

bn_mp_cmp.o: $(TOMMATH_DIR)/bn_mp_cmp.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp.c

bn_mp_cmp_d.o: $(TOMMATH_DIR)/bn_mp_cmp_d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp_d.c

bn_mp_cmp_mag.o: $(TOMMATH_DIR)/bn_mp_cmp_mag.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp_mag.c

bn_mp_copy.o: $(TOMMATH_DIR)/bn_mp_copy.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_copy.c

bn_mp_count_bits.o: $(TOMMATH_DIR)/bn_mp_count_bits.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_count_bits.c

bn_mp_div.o: $(TOMMATH_DIR)/bn_mp_div.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div.c

bn_mp_div_d.o: $(TOMMATH_DIR)/bn_mp_div_d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_d.c

bn_mp_div_2.o: $(TOMMATH_DIR)/bn_mp_div_2.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2.c

bn_mp_div_2d.o: $(TOMMATH_DIR)/bn_mp_div_2d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2d.c

bn_mp_div_3.o: $(TOMMATH_DIR)/bn_mp_div_3.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_3.c

bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c

bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c

bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c

bn_mp_init.o: $(TOMMATH_DIR)/bn_mp_init.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init.c

bn_mp_init_copy.o: $(TOMMATH_DIR)/bn_mp_init_copy.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_copy.c

bn_mp_init_multi.o: $(TOMMATH_DIR)/bn_mp_init_multi.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_multi.c

bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set.c

bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c

bn_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c

bn_mp_karatsuba_sqr.o: $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c

bn_mp_lshd.o: $(TOMMATH_DIR)/bn_mp_lshd.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_lshd.c

bn_mp_mod.o: $(TOMMATH_DIR)/bn_mp_mod.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod.c

bn_mp_mod_2d.o: $(TOMMATH_DIR)/bn_mp_mod_2d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod_2d.c

bn_mp_mul.o: $(TOMMATH_DIR)/bn_mp_mul.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul.c

bn_mp_mul_2.o: $(TOMMATH_DIR)/bn_mp_mul_2.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_2.c

bn_mp_mul_2d.o: $(TOMMATH_DIR)/bn_mp_mul_2d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_2d.c

bn_mp_mul_d.o: $(TOMMATH_DIR)/bn_mp_mul_d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_d.c

bn_mp_neg.o: $(TOMMATH_DIR)/bn_mp_neg.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_neg.c

bn_mp_or.o: $(TOMMATH_DIR)/bn_mp_or.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_or.c

bn_mp_radix_size.o: $(TOMMATH_DIR)/bn_mp_radix_size.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_size.c

bn_mp_radix_smap.o: $(TOMMATH_DIR)/bn_mp_radix_smap.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_smap.c

bn_mp_read_radix.o: $(TOMMATH_DIR)/bn_mp_read_radix.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_read_radix.c

bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_rshd.c

bn_mp_set.o: $(TOMMATH_DIR)/bn_mp_set.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set.c

bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c

bn_mp_sqr.o: $(TOMMATH_DIR)/bn_mp_sqr.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqr.c

bn_mp_sqrt.o: $(TOMMATH_DIR)/bn_mp_sqrt.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqrt.c

bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c

bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c

bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c

bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c

bn_mp_toom_mul.o: $(TOMMATH_DIR)/bn_mp_toom_mul.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_mul.c

bn_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_mp_toom_sqr.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_sqr.c

bn_mp_toradix_n.o: $(TOMMATH_DIR)/bn_mp_toradix_n.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toradix_n.c

bn_mp_unsigned_bin_size.o: $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c

bn_mp_xor.o: $(TOMMATH_DIR)/bn_mp_xor.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_xor.c

bn_mp_zero.o: $(TOMMATH_DIR)/bn_mp_zero.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_zero.c

bn_s_mp_add.o: $(TOMMATH_DIR)/bn_s_mp_add.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_add.c

bn_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_s_mp_mul_digs.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_mul_digs.c

bn_s_mp_sqr.o: $(TOMMATH_DIR)/bn_s_mp_sqr.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sqr.c

bn_s_mp_sub.o: $(TOMMATH_DIR)/bn_s_mp_sub.c
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sub.c

tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c

tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c

tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121



1122
1123
1124
1125
1126
1127
1128
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c

tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh
	$(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
		-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \
		$(UNIX_DIR)/tclUnixInit.c

# This is the CFBundle interface.  It is only used on Mac OS X.
tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c

tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXFCmd.c




# The following targets are not completely general.  They are provide
# purely for documentation purposes so people who are interested in
# the Xt based notifier can modify them to suit their own installation.

xttest:  ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
	@DL_OBJS@ ${BUILD_DLTEST}
	${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \







|






>
>
>







1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c

tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh
	$(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
		-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \
		$(UNIX_DIR)/tclUnixInit.c

# The following are Mac OS X only sources:
tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c

tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXFCmd.c

tclMacOSXNotify.o: $(MAC_OSX_DIR)/tclMacOSXNotify.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXNotify.c

# The following targets are not completely general.  They are provide
# purely for documentation purposes so people who are interested in
# the Xt based notifier can modify them to suit their own installation.

xttest:  ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
	@DL_OBJS@ ${BUILD_DLTEST}
	${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c

waitpid.o: $(COMPAT_DIR)/waitpid.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c

# Stub library binaries, these must be compiled for use in a shared library
# even though they will be placed in a static archive


tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c
	$(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c

.c.o:
	$(CC) -c $(CC_SWITCHES) $<








<







1476
1477
1478
1479
1480
1481
1482

1483
1484
1485
1486
1487
1488
1489
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c

waitpid.o: $(COMPAT_DIR)/waitpid.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c

# Stub library binaries, these must be compiled for use in a shared library
# even though they will be placed in a static archive


tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c
	$(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c

.c.o:
	$(CC) -c $(CC_SWITCHES) $<

1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
	rpm -bb THIS.TCL.SPEC
	mv RPMS/i386/*.rpm .
	rm -rf RPMS THIS.TCL.SPEC

#
# Target to create a proper Tcl distribution from information in the
# master source directory.  DISTDIR must be defined to indicate where
# to put the distribution.
#

DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME	 = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR	 = $(DISTROOT)/$(DISTNAME)
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4







|







1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
	rpm -bb THIS.TCL.SPEC
	mv RPMS/i386/*.rpm .
	rm -rf RPMS THIS.TCL.SPEC

#
# Target to create a proper Tcl distribution from information in the
# master source directory.  DISTDIR must be defined to indicate where
# to put the distribution.  DISTDIR must be an absolute path name.
#

DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME	 = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR	 = $(DISTROOT)/$(DISTNAME)
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4
1311
1312
1313
1314
1315
1316
1317






1318
1319
1320
1321
1322
1323
1324
	for i in http1.0 http opt msgcat reg dde tcltest; \
	    do \
		mkdir $(DISTDIR)/library/$$i ;\
		cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
	    done;
	mkdir $(DISTDIR)/library/encoding
	cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding






	mkdir $(DISTDIR)/doc
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \
		$(TOP_DIR)/doc/man.macros $(DISTDIR)/doc
	mkdir $(DISTDIR)/compat
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \
		$(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \
		$(DISTDIR)/compat







>
>
>
>
>
>







1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
	for i in http1.0 http opt msgcat reg dde tcltest; \
	    do \
		mkdir $(DISTDIR)/library/$$i ;\
		cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
	    done;
	mkdir $(DISTDIR)/library/encoding
	cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
	mkdir $(DISTDIR)/library/msgs
	cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
	( cd $(TOP_DIR); \
	  find library/tzdata -name CVS -prune -o -type f -print ) \
	    | ( cd $(TOP_DIR) ; xargs tar cf - ) \
	    | ( cd $(DISTDIR) ; tar xfp - )
	mkdir $(DISTDIR)/doc
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \
		$(TOP_DIR)/doc/man.macros $(DISTDIR)/doc
	mkdir $(DISTDIR)/compat
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \
		$(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \
		$(DISTDIR)/compat
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372



1373
1374
1375
1376
1377
1378
1379
	$(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in
	cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win
	$(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds*
	cp -p $(TOP_DIR)/win/README $(DISTDIR)/win
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win
	mkdir $(DISTDIR)/macosx
	cp -p $(TOP_DIR)/macosx/Makefile \
		$(TOP_DIR)/macosx/*.c \
		$(DISTDIR)/macosx
	mkdir $(DISTDIR)/macosx/Tcl.pbproj
	cp -p $(TOP_DIR)/macosx/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj
	cp -p $(TOP_DIR)/macosx/README $(DISTDIR)/macosx
	mkdir $(DISTDIR)/unix/dltest
	cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \
		$(UNIX_DIR)/dltest/README \
		$(DISTDIR)/unix/dltest
	mkdir $(DISTDIR)/tools
	cp -p $(TOP_DIR)/tools/Makefile.in $(TOP_DIR)/tools/README \
		$(TOP_DIR)/tools/configure $(TOP_DIR)/tools/configure.in \
		$(TOP_DIR)/tools/*.tcl $(TOP_DIR)/tools/man2tcl.c \
		$(TOP_DIR)/tools/tcl.wse.in $(TOP_DIR)/tools/*.bmp \
		$(TOP_DIR)/tools/tcl.hpj.in \
		$(DISTDIR)/tools
	$(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \
		$(DISTDIR)/tools/tcl.wse.in




#
# The following target can only be used for non-patch releases.  Use
# the "allpatch" target below for patch releases.
#

alldist: dist







|

















>
>
>







1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
	$(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in
	cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win
	$(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds*
	cp -p $(TOP_DIR)/win/README $(DISTDIR)/win
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win
	mkdir $(DISTDIR)/macosx
	cp -p $(TOP_DIR)/macosx/Makefile \
		$(TOP_DIR)/macosx/*.c $(TOP_DIR)/macosx/*.in \
		$(DISTDIR)/macosx
	mkdir $(DISTDIR)/macosx/Tcl.pbproj
	cp -p $(TOP_DIR)/macosx/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj
	cp -p $(TOP_DIR)/macosx/README $(DISTDIR)/macosx
	mkdir $(DISTDIR)/unix/dltest
	cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \
		$(UNIX_DIR)/dltest/README \
		$(DISTDIR)/unix/dltest
	mkdir $(DISTDIR)/tools
	cp -p $(TOP_DIR)/tools/Makefile.in $(TOP_DIR)/tools/README \
		$(TOP_DIR)/tools/configure $(TOP_DIR)/tools/configure.in \
		$(TOP_DIR)/tools/*.tcl $(TOP_DIR)/tools/man2tcl.c \
		$(TOP_DIR)/tools/tcl.wse.in $(TOP_DIR)/tools/*.bmp \
		$(TOP_DIR)/tools/tcl.hpj.in \
		$(DISTDIR)/tools
	$(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \
		$(DISTDIR)/tools/tcl.wse.in
	mkdir $(DISTDIR)/libtommath
	cp -p $(TOP_DIR)/libtommath/*.* \
		$(DISTDIR)/libtommath

#
# The following target can only be used for non-patch releases.  Use
# the "allpatch" target below for patch releases.
#

alldist: dist
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410

1411
1412

1413
1414

1415
1416


1417
1418
1419
1420
1421
1422
1423
1424
1425
	mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
	mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}

#
# This target creates the HTML folder for Tcl & Tk and places it
# in DISTDIR/html.  It uses the tcltk-man2html.tcl tool from
# the Tcl group's tool workspace.  It depends on the Tcl & Tk being
# in directories called tcl8.3 & tk8.3 up two directories from the
# TOOL_DIR.
#

html:
	$(BUILD_HTML)

html-tcl:
	$(BUILD_HTML) --tcl

html-tk:
	$(BUILD_HTML) --tk


BUILD_HTML = \


	$(TCL_EXE) $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(DISTDIR)/html \
		--srcdir=$(TOP_DIR)/..

#
# Targets to build Solaris package of the distribution for the current
# architecture.  To build stream packages for both sun4 and i86pc
# architectures: 
#
#   On the sun4 machine, execute the following:







|





>


>


>


>
>
|
|







1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
	mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
	mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}

#
# This target creates the HTML folder for Tcl & Tk and places it
# in DISTDIR/html.  It uses the tcltk-man2html.tcl tool from
# the Tcl group's tool workspace.  It depends on the Tcl & Tk being
# in directories called tcl8.* & tk8.* up two directories from the
# TOOL_DIR.
#

html:
	$(BUILD_HTML)
	@EXTRA_BUILD_HTML@
html-tcl:
	$(BUILD_HTML) --tcl
	@EXTRA_BUILD_HTML@
html-tk:
	$(BUILD_HTML) --tk
	@EXTRA_BUILD_HTML@

BUILD_HTML = \
	@@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) \
		--srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS)

#
# Targets to build Solaris package of the distribution for the current
# architecture.  To build stream packages for both sun4 and i86pc
# architectures: 
#
#   On the sun4 machine, execute the following:

Changes to unix/configure.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.57 for tcl 8.5.
#
# Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002
# Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization.  ##
## --------------------- ##

# Be Bourne compatible
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
  emulate sh
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi


# Support unset when possible.
if (FOO=FOO; unset FOO) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.


|

<
|
















>


|


















|







1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.59 for tcl 8.5.
#

# Copyright (C) 2003 Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization.  ##
## --------------------- ##

# Be Bourne compatible
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
  emulate sh
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi
DUALCASE=1; export DUALCASE # for MKS sh

# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.
214
215
216
217
218
219
220

221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else

  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"







>






|


|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else
  test -d ./-p && rmdir ./-p
  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
#  include <stdint.h>
# endif
#endif
#if HAVE_UNISTD_H
# include <unistd.h>
#endif"

ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS RANLIB ac_ct_RANLIB AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_FLAGS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG BUILD_DLTEST TCL_PACKAGE_PATH LTLIBOBJS'
ac_subst_files=''

# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
# The variables have the same names as the options, with
# dashes changed to underlines.







|







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
#  include <stdint.h>
# endif
#endif
#if HAVE_UNISTD_H
# include <unistd.h>
#endif"

ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS RANLIB ac_ct_RANLIB AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR EXTRA_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML'
ac_subst_files=''

# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
# The variables have the same names as the options, with
# dashes changed to underlines.
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac
done

# Be sure to have absolute paths.
for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
              localstatedir libdir includedir oldincludedir infodir mandir
do
  eval ac_val=$`echo $ac_var`
  case $ac_val in
    [\\/$]* | ?:[\\/]* ) ;;
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac







|







663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac
done

# Be sure to have absolute paths.
for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
	      localstatedir libdir includedir oldincludedir infodir mandir
do
  eval ac_val=$`echo $ac_var`
  case $ac_val in
    [\\/$]* | ?:[\\/]* ) ;;
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719

# Find the source files, if location was not specified.
if test -z "$srcdir"; then
  ac_srcdir_defaulted=yes
  # Try the directory containing this script, then its parent.
  ac_confdir=`(dirname "$0") 2>/dev/null ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
         X"$0" : 'X\(//\)[^/]' \| \
         X"$0" : 'X\(//\)$' \| \
         X"$0" : 'X\(/\)' \| \
         .     : '\(.\)' 2>/dev/null ||
echo X"$0" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  srcdir=$ac_confdir







|
|
|
|







703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720

# Find the source files, if location was not specified.
if test -z "$srcdir"; then
  ac_srcdir_defaulted=yes
  # Try the directory containing this script, then its parent.
  ac_confdir=`(dirname "$0") 2>/dev/null ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$0" : 'X\(//\)[^/]' \| \
	 X"$0" : 'X\(//\)$' \| \
	 X"$0" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$0" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  srcdir=$ac_confdir
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
      --srcdir=DIR        find the sources in DIR [configure dir or \`..']

_ACEOF

  cat <<_ACEOF
Installation directories:
  --prefix=PREFIX         install architecture-independent files in PREFIX
                          [$ac_default_prefix]
  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
                          [PREFIX]

By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc.  You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.

For better control, use the options below.







|

|







798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
      --srcdir=DIR        find the sources in DIR [configure dir or \`..']

_ACEOF

  cat <<_ACEOF
Installation directories:
  --prefix=PREFIX         install architecture-independent files in PREFIX
			  [$ac_default_prefix]
  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
			  [PREFIX]

By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc.  You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.

For better control, use the options below.
836
837
838
839
840
841
842
843
844
845
846
847
848

849
850
851
852

853

854
855
856

857
858
859
860
861
862
863

864
865
866
867
868
869
870
     short | recursive ) echo "Configuration of tcl 8.5:";;
   esac
  cat <<\_ACEOF

Optional Features:
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
  --enable-man-symlinks   use symlinks for the manpages
  --enable-man-compression=PROG
                          compress the manpages with PROG
  --enable-man-suffix=STRING
                          use STRING as a suffix to manpage file names
                          (default: tcl)

  --enable-threads        build with threads
  --enable-shared         build and link with shared libraries --enable-shared
  --enable-64bit          enable 64bit support (where applicable)
  --enable-64bit-vis      enable 64bit Sparc VIS support

  --disable-load          disallow dynamic loading and "load" command

  --enable-symbols        build with debugging symbols --disable-symbols
  --enable-langinfo	  use nl_langinfo if possible to determine
			  encoding at startup, otherwise use old heuristic

  --enable-framework      package shared libraries in MacOSX frameworks --disable-framework
  --enable-dll-unloading  turn on the 'unload' command (default: on)

Optional Packages:
  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
  --with-encoding              encoding for configuration values


Some influential environment variables:
  CC          C compiler command
  CFLAGS      C compiler flags
  LDFLAGS     linker flags, e.g. -L<lib dir> if you have libraries in a
              nonstandard directory <lib dir>
  CPPFLAGS    C/C++ preprocessor flags, e.g. -I<include dir> if you have







|

|


|
>
|
|
|
|
>

>
|
|
|
>
|
|




|
>







837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
     short | recursive ) echo "Configuration of tcl 8.5:";;
   esac
  cat <<\_ACEOF

Optional Features:
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
  --enable-man-symlinks   use symlinks for the manpages (default: off)
  --enable-man-compression=PROG
                          compress the manpages with PROG (default: off)
  --enable-man-suffix=STRING
                          use STRING as a suffix to manpage file names
                          (default: no, tcl if enabled without
                          specifying STRING)
  --enable-threads        build with threads (default: off)
  --enable-shared         build and link with shared libraries (default: on)
  --enable-64bit          enable 64bit support (default: off)
  --enable-64bit-vis      enable 64bit Sparc VIS support (default: off)
  --enable-corefoundation use CoreFoundation API on MacOSX (default: yes)
  --disable-load          disallow dynamic loading and "load" command
                          (default: enabled)
  --enable-symbols        build with debugging symbols (default: off)
  --enable-langinfo       use nl_langinfo if possible to determine encoding at
                          startup, otherwise use old heuristic (default: on)
  --enable-dll-unloading  turn on the 'unload' command (default: on)
  --enable-framework      package shared libraries in MacOSX frameworks
                          (default: off)

Optional Packages:
  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
  --with-encoding         encoding for configuration values (default:
                          iso8859-1)

Some influential environment variables:
  CC          C compiler command
  CFLAGS      C compiler flags
  LDFLAGS     linker flags, e.g. -L<lib dir> if you have libraries in a
              nonstandard directory <lib dir>
  CPPFLAGS    C/C++ preprocessor flags, e.g. -I<include dir> if you have
903
904
905
906
907
908
909
910
911





912







913






914










915





916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac
# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be
# absolute.





ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd`







ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd`






ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd`










ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd`






    cd $ac_dir
    # Check for guested configure; otherwise get Cygnus style configure.
    if test -f $ac_srcdir/configure.gnu; then
      echo
      $SHELL $ac_srcdir/configure.gnu  --help=recursive
    elif test -f $ac_srcdir/configure; then
      echo
      $SHELL $ac_srcdir/configure  --help=recursive
    elif test -f $ac_srcdir/configure.ac ||
           test -f $ac_srcdir/configure.in; then
      echo
      $ac_configure --help
    else
      echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
    fi
    cd $ac_popdir
  done
fi

test -n "$ac_init_help" && exit 0
if $ac_init_version; then
  cat <<\_ACEOF
tcl configure 8.5
generated by GNU Autoconf 2.57

Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002
Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit 0
fi
exec 5>config.log
cat >&5 <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by tcl $as_me 8.5, which was
generated by GNU Autoconf 2.57.  Invocation command line was

  $ $0 $@

_ACEOF
{
cat <<_ASUNAME
## --------- ##







|
|
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>










|













|

<
|











|







909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980

981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac

# Do not use `cd foo && pwd` to compute absolute paths, because
# the directories may not exist.
case `pwd` in
.) ac_abs_builddir="$ac_dir";;
*)
  case "$ac_dir" in
  .) ac_abs_builddir=`pwd`;;
  [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
  *) ac_abs_builddir=`pwd`/"$ac_dir";;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_builddir=${ac_top_builddir}.;;
*)
  case ${ac_top_builddir}. in
  .) ac_abs_top_builddir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
  *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_srcdir=$ac_srcdir;;
*)
  case $ac_srcdir in
  .) ac_abs_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
  *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_srcdir=$ac_top_srcdir;;
*)
  case $ac_top_srcdir in
  .) ac_abs_top_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
  *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
  esac;;
esac

    cd $ac_dir
    # Check for guested configure; otherwise get Cygnus style configure.
    if test -f $ac_srcdir/configure.gnu; then
      echo
      $SHELL $ac_srcdir/configure.gnu  --help=recursive
    elif test -f $ac_srcdir/configure; then
      echo
      $SHELL $ac_srcdir/configure  --help=recursive
    elif test -f $ac_srcdir/configure.ac ||
	   test -f $ac_srcdir/configure.in; then
      echo
      $ac_configure --help
    else
      echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
    fi
    cd $ac_popdir
  done
fi

test -n "$ac_init_help" && exit 0
if $ac_init_version; then
  cat <<\_ACEOF
tcl configure 8.5
generated by GNU Autoconf 2.59


Copyright (C) 2003 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit 0
fi
exec 5>config.log
cat >&5 <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by tcl $as_me 8.5, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ $0 $@

_ACEOF
{
cat <<_ASUNAME
## --------- ##
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
      ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
    esac
    case $ac_pass in
    1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
    2)
      ac_configure_args1="$ac_configure_args1 '$ac_arg'"
      if test $ac_must_keep_next = true; then
        ac_must_keep_next=false # Got value, back to normal.
      else
        case $ac_arg in
          *=* | --config-cache | -C | -disable-* | --disable-* \
          | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
          | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
          | -with-* | --with-* | -without-* | --without-* | --x)
            case "$ac_configure_args0 " in
              "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
            esac
            ;;
          -* ) ac_must_keep_next=true ;;
        esac
      fi
      ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'"
      # Get rid of the leading space.
      ac_sep=" "
      ;;
    esac
  done







|

|
|
|
|
|
|
|
|
|
|
|







1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
      ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
    esac
    case $ac_pass in
    1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
    2)
      ac_configure_args1="$ac_configure_args1 '$ac_arg'"
      if test $ac_must_keep_next = true; then
	ac_must_keep_next=false # Got value, back to normal.
      else
	case $ac_arg in
	  *=* | --config-cache | -C | -disable-* | --disable-* \
	  | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
	  | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
	  | -with-* | --with-* | -without-* | --without-* | --x)
	    case "$ac_configure_args0 " in
	      "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
	    esac
	    ;;
	  -* ) ac_must_keep_next=true ;;
	esac
      fi
      ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'"
      # Get rid of the leading space.
      ac_sep=" "
      ;;
    esac
  done
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
    echo
    # The following way of writing the cache mishandles newlines in values,
{
  (set) 2>&1 |
    case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      sed -n \
        "s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
    	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
      ;;
    *)
      sed -n \
        "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
}
    echo

    cat <<\_ASBOX
## ----------------- ##







|
|



|







1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
    echo
    # The following way of writing the cache mishandles newlines in values,
{
  (set) 2>&1 |
    case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      sed -n \
	"s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
      ;;
    *)
      sed -n \
	"s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
}
    echo

    cat <<\_ASBOX
## ----------------- ##
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
## Output files. ##
## ------------- ##
_ASBOX
      echo
      for ac_var in $ac_subst_files
      do
	eval ac_val=$`echo $ac_var`
        echo "$ac_var='"'"'$ac_val'"'"'"
      done | sort
      echo
    fi

    if test -s confdefs.h; then
      cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
      echo
      sed "/^$/d" confdefs.h | sort
      echo
    fi
    test "$ac_signal" != 0 &&
      echo "$as_me: caught signal $ac_signal"
    echo "$as_me: exit $exit_status"
  } >&5
  rm -f core core.* *.core &&
  rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
    exit $exit_status
     ' 0
for ac_signal in 1 2 13 15; do
  trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0







|


















|







1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
## Output files. ##
## ------------- ##
_ASBOX
      echo
      for ac_var in $ac_subst_files
      do
	eval ac_val=$`echo $ac_var`
	echo "$ac_var='"'"'$ac_val'"'"'"
      done | sort
      echo
    fi

    if test -s confdefs.h; then
      cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
      echo
      sed "/^$/d" confdefs.h | sort
      echo
    fi
    test "$ac_signal" != 0 &&
      echo "$as_me: caught signal $ac_signal"
    echo "$as_me: exit $exit_status"
  } >&5
  rm -f core *.core &&
  rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
    exit $exit_status
     ' 0
for ac_signal in 1 2 13 15; do
  trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
  >$cache_file
fi

# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in `(set) 2>&1 |
               sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do
  eval ac_old_set=\$ac_cv_env_${ac_var}_set
  eval ac_new_set=\$ac_env_${ac_var}_set
  eval ac_old_val="\$ac_cv_env_${ac_var}_value"
  eval ac_new_val="\$ac_env_${ac_var}_value"
  case $ac_old_set,$ac_new_set in
    set,)
      { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,set)
      { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,);;
    *)
      if test "x$ac_old_val" != "x$ac_new_val"; then
        { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
        { echo "$as_me:$LINENO:   former value:  $ac_old_val" >&5
echo "$as_me:   former value:  $ac_old_val" >&2;}
        { echo "$as_me:$LINENO:   current value: $ac_new_val" >&5
echo "$as_me:   current value: $ac_new_val" >&2;}
        ac_cache_corrupted=:
      fi;;
  esac
  # Pass precious variables to config.status.
  if test "$ac_new_set" = set; then
    case $ac_new_val in
    *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
      ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;







|
















|

|

|

|







1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
  >$cache_file
fi

# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in `(set) 2>&1 |
	       sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do
  eval ac_old_set=\$ac_cv_env_${ac_var}_set
  eval ac_new_set=\$ac_env_${ac_var}_set
  eval ac_old_val="\$ac_cv_env_${ac_var}_value"
  eval ac_new_val="\$ac_env_${ac_var}_value"
  case $ac_old_set,$ac_new_set in
    set,)
      { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,set)
      { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,);;
    *)
      if test "x$ac_old_val" != "x$ac_new_val"; then
	{ echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
	{ echo "$as_me:$LINENO:   former value:  $ac_old_val" >&5
echo "$as_me:   former value:  $ac_old_val" >&2;}
	{ echo "$as_me:$LINENO:   current value: $ac_new_val" >&5
echo "$as_me:   current value: $ac_new_val" >&2;}
	ac_cache_corrupted=:
      fi;;
  esac
  # Pass precious variables to config.status.
  if test "$ac_new_set" = set; then
    case $ac_new_val in
    *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
      ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
1284
1285
1286
1287
1288
1289
1290

1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333

1334
1335
1336

1337

1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359

1360

1361

1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372









TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a2"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`

#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------


	echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5
echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6
	# Check whether --enable-man-symlinks or --disable-man-symlinks was given.
if test "${enable_man_symlinks+set}" = set; then
  enableval="$enable_man_symlinks"
  test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"
else
  enableval="no"
fi;
	echo "$as_me:$LINENO: result: $enableval" >&5
echo "${ECHO_T}$enableval" >&6

	echo "$as_me:$LINENO: checking whether to compress the manpages" >&5
echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6
	# Check whether --enable-man-compression or --disable-man-compression was given.
if test "${enable_man_compression+set}" = set; then
  enableval="$enable_man_compression"

  test "$enableval" = "yes" && { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5
echo "$as_me: error: missing argument to --enable-man-compression" >&2;}
   { (exit 1); exit 1; }; }

		test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --compress $enableval"

else
  enableval="no"
fi;
	echo "$as_me:$LINENO: result: $enableval" >&5
echo "${ECHO_T}$enableval" >&6
	if test "$enableval" != "no"; then
		echo "$as_me:$LINENO: checking for compressed file suffix" >&5
echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6
		touch TeST
		$enableval TeST
		Z=`ls TeST* | sed 's/^....//'`
		rm -f TeST*
		MAN_FLAGS="$MAN_FLAGS --extension $Z"
		echo "$as_me:$LINENO: result: $Z" >&5
echo "${ECHO_T}$Z" >&6
	fi

	echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5
echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6
	# Check whether --enable-man-suffix or --disable-man-suffix was given.
if test "${enable_man_suffix+set}" = set; then
  enableval="$enable_man_suffix"

  test "$enableval" = "yes" && enableval="tcl"

		test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --suffix $enableval"

else
  enableval="no"
fi;
	echo "$as_me:$LINENO: result: $enableval" >&5
echo "${ECHO_T}$enableval" >&6




#------------------------------------------------------------------------
# Standard compiler checks







>




|












<
<






<
|

|






|


|

|


>
|

|
>
|
>



|

|
|

|
|
|
|
|
|

|

|

|


>
|
>
|
>



|







1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346


1347
1348
1349
1350
1351
1352

1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414









TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a4"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi


TCL_SRC_DIR=`cd $srcdir/..; pwd`

#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------


    echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5
echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6
    # Check whether --enable-man-symlinks or --disable-man-symlinks was given.
if test "${enable_man_symlinks+set}" = set; then
  enableval="$enable_man_symlinks"
  test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"
else
  enableval="no"
fi;
    echo "$as_me:$LINENO: result: $enableval" >&5
echo "${ECHO_T}$enableval" >&6

    echo "$as_me:$LINENO: checking whether to compress the manpages" >&5
echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6
    # Check whether --enable-man-compression or --disable-man-compression was given.
if test "${enable_man_compression+set}" = set; then
  enableval="$enable_man_compression"
  case $enableval in
	    yes) { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5
echo "$as_me: error: missing argument to --enable-man-compression" >&2;}
   { (exit 1); exit 1; }; };;
	    no)  ;;
	    *)   MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
	esac
else
  enableval="no"
fi;
    echo "$as_me:$LINENO: result: $enableval" >&5
echo "${ECHO_T}$enableval" >&6
    if test "$enableval" != "no"; then
	echo "$as_me:$LINENO: checking for compressed file suffix" >&5
echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6
	touch TeST
	$enableval TeST
	Z=`ls TeST* | sed 's/^....//'`
	rm -f TeST*
	MAN_FLAGS="$MAN_FLAGS --extension $Z"
	echo "$as_me:$LINENO: result: $Z" >&5
echo "${ECHO_T}$Z" >&6
    fi

    echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5
echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6
    # Check whether --enable-man-suffix or --disable-man-suffix was given.
if test "${enable_man_suffix+set}" = set; then
  enableval="$enable_man_suffix"
  case $enableval in
	    yes) enableval="tcl";;
	    no)  ;;
	    *)   MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
	esac
else
  enableval="no"
fi;
    echo "$as_me:$LINENO: result: $enableval" >&5
echo "${ECHO_T}$enableval" >&6




#------------------------------------------------------------------------
# Standard compiler checks
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5
  (eval $ac_compiler -V </dev/null >&5) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files a.out a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
echo "$as_me:$LINENO: checking for C compiler default output" >&5
echo $ECHO_N "checking for C compiler default output... $ECHO_C" >&6
ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5
  (eval $ac_link_default) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; then
  # Find the output, starting from the most likely.  This scheme is
# not robust to junk in `.', hence go to wildcards (a.*) only as a last
# resort.

# Be careful to initialize this variable, since it used to be cached.
# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile.
ac_cv_exeext=
# b.out is created by i960 compilers.
for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out
do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj )
        ;;
    conftest.$ac_ext )
        # This is the source file.
        ;;
    [ab].out )
        # We found the default executable, but exeext='' is most
        # certainly right.
        break;;
    *.* )
        ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
        # FIXME: I believe we export ac_cv_exeext for Libtool,
        # but it would be cool to find out if it's true.  Does anybody
        # maintain Libtool? --akim.
        export ac_cv_exeext
        break;;
    * )
        break;;
  esac
done
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

{ { echo "$as_me:$LINENO: error: C compiler cannot create executables







<



















|
|



















|

|
|

|
|
|

|
|
|
|
|
|

|







1752
1753
1754
1755
1756
1757
1758

1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5
  (eval $ac_compiler -V </dev/null >&5) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files a.out a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
echo "$as_me:$LINENO: checking for C compiler default output file name" >&5
echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6
ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5
  (eval $ac_link_default) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; then
  # Find the output, starting from the most likely.  This scheme is
# not robust to junk in `.', hence go to wildcards (a.*) only as a last
# resort.

# Be careful to initialize this variable, since it used to be cached.
# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile.
ac_cv_exeext=
# b.out is created by i960 compilers.
for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out
do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj )
	;;
    conftest.$ac_ext )
	# This is the source file.
	;;
    [ab].out )
	# We found the default executable, but exeext='' is most
	# certainly right.
	break;;
    *.* )
	ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
	# FIXME: I believe we export ac_cv_exeext for Libtool,
	# but it would be cool to find out if it's true.  Does anybody
	# maintain Libtool? --akim.
	export ac_cv_exeext
	break;;
    * )
	break;;
  esac
done
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

{ { echo "$as_me:$LINENO: error: C compiler cannot create executables
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
# work properly (i.e., refer to `conftest.exe'), while it won't with
# `rm'.
for ac_file in conftest.exe conftest conftest.*; do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;;
    *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
          export ac_cv_exeext
          break;;
    * ) break;;
  esac
done
else
  { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
See \`config.log' for more details." >&5
echo "$as_me: error: cannot compute suffix of executables: cannot compile and link







|
|







1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
# work properly (i.e., refer to `conftest.exe'), while it won't with
# `rm'.
for ac_file in conftest.exe conftest conftest.*; do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;;
    *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
	  export ac_cv_exeext
	  break;;
    * ) break;;
  esac
done
else
  { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
See \`config.log' for more details." >&5
echo "$as_me: error: cannot compute suffix of executables: cannot compile and link
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
ac_exeext=$EXEEXT
echo "$as_me:$LINENO: checking for suffix of object files" >&5
echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6
if test "${ac_cv_objext+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int







<







1908
1909
1910
1911
1912
1913
1914

1915
1916
1917
1918
1919
1920
1921
ac_exeext=$EXEEXT
echo "$as_me:$LINENO: checking for suffix of object files" >&5
echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6
if test "${ac_cv_objext+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946



1947
1948







1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996



1997
1998







1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
ac_objext=$OBJEXT
echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6
if test "${ac_cv_c_compiler_gnu+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
#ifndef __GNUC__
       choke me
#endif

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_compiler_gnu=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_compiler_gnu=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu

fi
echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6
GCC=`test $ac_compiler_gnu = yes && echo yes`
ac_test_CFLAGS=${CFLAGS+set}
ac_save_CFLAGS=$CFLAGS
CFLAGS="-g"
echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6
if test "${ac_cv_prog_cc_g+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_g=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_prog_cc_g=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
if test "$ac_test_CFLAGS" = set; then
  CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
  if test "$GCC" = yes; then







<



















|

>
>
>


>
>
>
>
>
>
>
|












|















<
















|

>
>
>


>
>
>
>
>
>
>
|












|







1958
1959
1960
1961
1962
1963
1964

1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026

2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
ac_objext=$OBJEXT
echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6
if test "${ac_cv_c_compiler_gnu+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
#ifndef __GNUC__
       choke me
#endif

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_compiler_gnu=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_compiler_gnu=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu

fi
echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6
GCC=`test $ac_compiler_gnu = yes && echo yes`
ac_test_CFLAGS=${CFLAGS+set}
ac_save_CFLAGS=$CFLAGS
CFLAGS="-g"
echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6
if test "${ac_cv_prog_cc_g+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_g=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_prog_cc_g=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
if test "$ac_test_CFLAGS" = set; then
  CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
  if test "$GCC" = yes; then
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6
if test "${ac_cv_prog_cc_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_cv_prog_cc_stdc=no
ac_save_CC=$CC
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdarg.h>
#include <stdio.h>







<







2090
2091
2092
2093
2094
2095
2096

2097
2098
2099
2100
2101
2102
2103
echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6
if test "${ac_cv_prog_cc_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_cv_prog_cc_stdc=no
ac_save_CC=$CC
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdarg.h>
#include <stdio.h>
2060
2061
2062
2063
2064
2065
2066










2067
2068
2069
2070
2071
2072
2073
  char *s;
  va_list v;
  va_start (v,p);
  s = g (p, va_arg (v,int));
  va_end (v);
  return s;
}










int test (int i, double x);
struct s1 {int (*f) (int a);};
struct s2 {int (*f) (double a);};
int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
int argc;
char **argv;
int







>
>
>
>
>
>
>
>
>
>







2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
  char *s;
  va_list v;
  va_start (v,p);
  s = g (p, va_arg (v,int));
  va_end (v);
  return s;
}

/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default.  It has
   function prototypes and stuff, but not '\xHH' hex character constants.
   These don't provoke an error unfortunately, instead are silently treated
   as 'x'.  The following induces an error, until -std1 is added to get
   proper ANSI mode.  Curiously '\x00'!='x' always comes out true, for an
   array size at least.  It's necessary to write '\x00'==0 to get something
   that's true only with -std1.  */
int osf4_cc_array ['\x00' == 0 ? 1 : -1];

int test (int i, double x);
struct s1 {int (*f) (int a);};
struct s2 {int (*f) (double a);};
int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
int argc;
char **argv;
int
2086
2087
2088
2089
2090
2091
2092
2093
2094



2095
2096







2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
# HP-UX older versions	-Aa -D_HPUX_SOURCE
# SVR4			-Xc -D__EXTENSIONS__
for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
do
  CC="$ac_save_CC $ac_arg"
  rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_stdc=$ac_arg
break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext
done
rm -f conftest.$ac_ext conftest.$ac_objext
CC=$ac_save_CC

fi

case "x$ac_cv_prog_cc_stdc" in







|

>
>
>


>
>
>
>
>
>
>
|












|







2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
# HP-UX older versions	-Aa -D_HPUX_SOURCE
# SVR4			-Xc -D__EXTENSIONS__
for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
do
  CC="$ac_save_CC $ac_arg"
  rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_stdc=$ac_arg
break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext
done
rm -f conftest.$ac_ext conftest.$ac_objext
CC=$ac_save_CC

fi

case "x$ac_cv_prog_cc_stdc" in
2131
2132
2133
2134
2135
2136
2137
2138
2139



2140
2141







2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165

2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177



2178
2179







2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213



2214
2215







2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
cat >conftest.$ac_ext <<_ACEOF
#ifndef __cplusplus
  choke me
#endif
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  for ac_declaration in \
   ''\
   '#include <stdlib.h>' \
   'extern "C" void std::exit (int) throw (); using std::exit;' \
   'extern "C" void std::exit (int); using std::exit;' \
   'extern "C" void exit (int) throw ();' \
   'extern "C" void exit (int);' \
   'void exit (int);'
do
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
$ac_declaration

int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

continue
fi
rm -f conftest.$ac_objext conftest.$ac_ext
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_declaration
int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext conftest.$ac_ext
done
rm -f conftest*
if test -n "$ac_declaration"; then
  echo '#ifdef __cplusplus' >>confdefs.h
  echo $ac_declaration      >>confdefs.h
  echo '#endif'             >>confdefs.h
fi

else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext conftest.$ac_ext
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu


#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files.  Special notes:
#	- stdlib.h doesn't define strtol, strtoul, or
#	  strtod insome versions of SunOS
#	- some versions of string.h don't declare procedures such
#	  as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------


ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5







|

>
>
>


>
>
>
>
>
>
>
|






|
<







<





<

>










|

>
>
>


>
>
>
>
>
>
>
|












|

<
















|

>
>
>


>
>
>
>
>
>
>
|











|













|















<







2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236

2237
2238
2239
2240
2241
2242
2243

2244
2245
2246
2247
2248

2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289

2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361

2362
2363
2364
2365
2366
2367
2368
cat >conftest.$ac_ext <<_ACEOF
#ifndef __cplusplus
  choke me
#endif
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  for ac_declaration in \
   '' \

   'extern "C" void std::exit (int) throw (); using std::exit;' \
   'extern "C" void std::exit (int); using std::exit;' \
   'extern "C" void exit (int) throw ();' \
   'extern "C" void exit (int);' \
   'void exit (int);'
do
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

$ac_declaration
#include <stdlib.h>
int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

continue
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_declaration
int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
done
rm -f conftest*
if test -n "$ac_declaration"; then
  echo '#ifdef __cplusplus' >>confdefs.h
  echo $ac_declaration      >>confdefs.h
  echo '#endif'             >>confdefs.h
fi

else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu


#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files.  Special notes:
#	- stdlib.h doesn't define strtol, strtoul, or
#	  strtod insome versions of SunOS
#	- some versions of string.h don't declare procedures such
#	  as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------


ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310

2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348

2349
2350
2351
2352
2353
2354
2355
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
                     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then







<










|











>




















<

















>







2384
2385
2386
2387
2388
2389
2390

2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433

2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
		     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417

2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455

2456
2457
2458
2459
2460
2461
2462
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
                     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then







<










|











>




















<

















>







2491
2492
2493
2494
2495
2496
2497

2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540

2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
		     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538



2539
2540







2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566

echo "$as_me:$LINENO: checking for ANSI C header files" >&5
echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6
if test "${ac_cv_header_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_header_stdc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_header_stdc=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

if test $ac_cv_header_stdc = yes; then
  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>








<




















|

>
>
>


>
>
>
>
>
>
>
|












|




<







2612
2613
2614
2615
2616
2617
2618

2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670

2671
2672
2673
2674
2675
2676
2677

echo "$as_me:$LINENO: checking for ANSI C header files" >&5
echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6
if test "${ac_cv_header_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_header_stdc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_header_stdc=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

if test $ac_cv_header_stdc = yes; then
  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>

2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>








<







2685
2686
2687
2688
2689
2690
2691

2692
2693
2694
2695
2696
2697
2698
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638

if test $ac_cv_header_stdc = yes; then
  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
  if test "$cross_compiling" = yes; then
  :
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ctype.h>
#if ((' ' & 0x0FF) == 0x020)
# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#else
# define ISLOWER(c) \
                   (('a' <= (c) && (c) <= 'i') \
                     || ('j' <= (c) && (c) <= 'r') \
                     || ('s' <= (c) && (c) <= 'z'))
# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
#endif

#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int
main ()
{
  int i;
  for (i = 0; i < 256; i++)
    if (XOR (islower (i), ISLOWER (i))
        || toupper (i) != TOUPPER (i))
      exit(2);
  exit (0);
}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5







<











|
|
|










|







2709
2710
2711
2712
2713
2714
2715

2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747

if test $ac_cv_header_stdc = yes; then
  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
  if test "$cross_compiling" = yes; then
  :
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ctype.h>
#if ((' ' & 0x0FF) == 0x020)
# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#else
# define ISLOWER(c) \
		   (('a' <= (c) && (c) <= 'i') \
		     || ('j' <= (c) && (c) <= 'r') \
		     || ('s' <= (c) && (c) <= 'z'))
# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
#endif

#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int
main ()
{
  int i;
  for (i = 0; i < 256; i++)
    if (XOR (islower (i), ISLOWER (i))
	|| toupper (i) != TOUPPER (i))
      exit(2);
  exit (0);
}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_header_stdc=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
fi
echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
echo "${ECHO_T}$ac_cv_header_stdc" >&6
if test $ac_cv_header_stdc = yes; then








|







2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_header_stdc=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
fi
echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
echo "${ECHO_T}$ac_cv_header_stdc" >&6
if test $ac_cv_header_stdc = yes; then

2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703



2704
2705







2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735




2736
2737
2738
2739
2740
2741
2742
2743
2744






for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
                  inttypes.h stdint.h unistd.h
do
as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default

#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_Header=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_Header=no"
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF

fi

done



    echo "$as_me:$LINENO: checking dirent.h" >&5
echo $ECHO_N "checking dirent.h... $ECHO_C" >&6




    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <dirent.h>







|








<











|

>
>
>


>
>
>
>
>
>
>
|












|
















>
>
>
>
|
<







2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798

2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858

2859
2860
2861
2862
2863
2864
2865






for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
		  inttypes.h stdint.h unistd.h
do
as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default

#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_Header=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_Header=no"
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF

fi

done



    echo "$as_me:$LINENO: checking dirent.h" >&5
echo $ECHO_N "checking dirent.h... $ECHO_C" >&6
    if test "${tcl_cv_dirent_h+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <dirent.h>
2766
2767
2768
2769
2770
2771
2772
2773
2774



2775
2776







2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789

2790

2791

2792
2793
2794
2795
2796
2797
2798
2799

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_ok=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_ok=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext



    if test $tcl_ok = no; then

cat >>confdefs.h <<\_ACEOF
#define NO_DIRENT_H 1
_ACEOF

    fi








|

>
>
>


>
>
>
>
>
>
>
|





|




|

>
|
>

>
|







2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_dirent_h=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_dirent_h=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi


    if test $tcl_cv_dirent_h = no; then

cat >>confdefs.h <<\_ACEOF
#define NO_DIRENT_H 1
_ACEOF

    fi

2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827



2828
2829







2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868

2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901

2902
2903
2904
2905


2906
2907


2908
2909


2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5
echo "${ECHO_T}$ac_cv_header_errno_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking errno.h usability" >&5
echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <errno.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking errno.h presence" >&5
echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <errno.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for errno.h" >&5
echo $ECHO_N "checking for errno.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







2942
2943
2944
2945
2946
2947
2948

2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993

2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036








3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5
echo "${ECHO_T}$ac_cv_header_errno_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking errno.h usability" >&5
echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <errno.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking errno.h presence" >&5
echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <errno.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: errno.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: errno.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for errno.h" >&5
echo $ECHO_N "checking for errno.h... $ECHO_C" >&6
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967



2968
2969







2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008

3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041

3042
3043
3044
3045


3046
3047


3048
3049


3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5
echo "${ECHO_T}$ac_cv_header_float_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking float.h usability" >&5
echo $ECHO_N "checking float.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <float.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking float.h presence" >&5
echo $ECHO_N "checking float.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <float.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for float.h" >&5
echo $ECHO_N "checking for float.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







3090
3091
3092
3093
3094
3095
3096

3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141

3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184








3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5
echo "${ECHO_T}$ac_cv_header_float_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking float.h usability" >&5
echo $ECHO_N "checking float.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <float.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking float.h presence" >&5
echo $ECHO_N "checking float.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <float.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: float.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: float.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: float.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: float.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: float.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: float.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for float.h" >&5
echo $ECHO_N "checking for float.h... $ECHO_C" >&6
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107



3108
3109







3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148

3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181

3182
3183
3184
3185


3186
3187


3188
3189


3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5
echo "${ECHO_T}$ac_cv_header_values_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking values.h usability" >&5
echo $ECHO_N "checking values.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <values.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking values.h presence" >&5
echo $ECHO_N "checking values.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <values.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for values.h" >&5
echo $ECHO_N "checking for values.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







3238
3239
3240
3241
3242
3243
3244

3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289

3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332








3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5
echo "${ECHO_T}$ac_cv_header_values_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking values.h usability" >&5
echo $ECHO_N "checking values.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <values.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking values.h presence" >&5
echo $ECHO_N "checking values.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <values.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: values.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: values.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: values.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: values.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: values.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: values.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for values.h" >&5
echo $ECHO_N "checking for values.h... $ECHO_C" >&6
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247



3248
3249







3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288

3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321

3322
3323
3324
3325


3326
3327


3328
3329


3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
echo "$as_me:$LINENO: result: $ac_cv_header_limits_h" >&5
echo "${ECHO_T}$ac_cv_header_limits_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking limits.h usability" >&5
echo $ECHO_N "checking limits.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <limits.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking limits.h presence" >&5
echo $ECHO_N "checking limits.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <limits.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: limits.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: limits.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: limits.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: limits.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for limits.h" >&5
echo $ECHO_N "checking for limits.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







3386
3387
3388
3389
3390
3391
3392

3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437

3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480








3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
echo "$as_me:$LINENO: result: $ac_cv_header_limits_h" >&5
echo "${ECHO_T}$ac_cv_header_limits_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking limits.h usability" >&5
echo $ECHO_N "checking limits.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <limits.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking limits.h presence" >&5
echo $ECHO_N "checking limits.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <limits.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: limits.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: limits.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: limits.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: limits.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: limits.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: limits.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: limits.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: limits.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for limits.h" >&5
echo $ECHO_N "checking for limits.h... $ECHO_C" >&6
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391



3392
3393







3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432

3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465

3466
3467
3468
3469


3470
3471


3472
3473


3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5
echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking stdlib.h usability" >&5
echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <stdlib.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking stdlib.h presence" >&5
echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for stdlib.h" >&5
echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







3538
3539
3540
3541
3542
3543
3544

3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589

3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632








3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5
echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking stdlib.h usability" >&5
echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <stdlib.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking stdlib.h presence" >&5
echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: stdlib.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: stdlib.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for stdlib.h" >&5
echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
  tcl_ok=1
else
  tcl_ok=0
fi


    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "strtol" >/dev/null 2>&1; then
  :
else
  tcl_ok=0
fi
rm -f conftest*

    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "strtoul" >/dev/null 2>&1; then
  :
else
  tcl_ok=0
fi
rm -f conftest*

    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>








<

















<

















<







3670
3671
3672
3673
3674
3675
3676

3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693

3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710

3711
3712
3713
3714
3715
3716
3717
  tcl_ok=1
else
  tcl_ok=0
fi


    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "strtol" >/dev/null 2>&1; then
  :
else
  tcl_ok=0
fi
rm -f conftest*

    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "strtoul" >/dev/null 2>&1; then
  :
else
  tcl_ok=0
fi
rm -f conftest*

    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588



3589
3590







3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629

3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662

3663
3664
3665
3666


3667
3668


3669
3670


3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5
echo "${ECHO_T}$ac_cv_header_string_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking string.h usability" >&5
echo $ECHO_N "checking string.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <string.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking string.h presence" >&5
echo $ECHO_N "checking string.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for string.h" >&5
echo $ECHO_N "checking for string.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







3740
3741
3742
3743
3744
3745
3746

3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791

3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834








3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5
echo "${ECHO_T}$ac_cv_header_string_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking string.h usability" >&5
echo $ECHO_N "checking string.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <string.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking string.h presence" >&5
echo $ECHO_N "checking string.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: string.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: string.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: string.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: string.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: string.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: string.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for string.h" >&5
echo $ECHO_N "checking for string.h... $ECHO_C" >&6
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
  tcl_ok=1
else
  tcl_ok=0
fi


    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "strstr" >/dev/null 2>&1; then
  :
else
  tcl_ok=0
fi
rm -f conftest*

    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>








<

















<







3872
3873
3874
3875
3876
3877
3878

3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895

3896
3897
3898
3899
3900
3901
3902
  tcl_ok=1
else
  tcl_ok=0
fi


    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "strstr" >/dev/null 2>&1; then
  :
else
  tcl_ok=0
fi
rm -f conftest*

    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>

3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772



3773
3774







3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813

3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846

3847
3848
3849
3850


3851
3852


3853
3854


3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5
echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking sys/wait.h usability" >&5
echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <sys/wait.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking sys/wait.h presence" >&5
echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/wait.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for sys/wait.h" >&5
echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







3930
3931
3932
3933
3934
3935
3936

3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981

3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024








4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5
echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking sys/wait.h usability" >&5
echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <sys/wait.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking sys/wait.h presence" >&5
echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/wait.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: sys/wait.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: sys/wait.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: sys/wait.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: sys/wait.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for sys/wait.h" >&5
echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912



3913
3914







3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953

3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986

3987
3988
3989
3990


3991
3992


3993
3994


3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5
echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dlfcn.h usability" >&5
echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dlfcn.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dlfcn.h presence" >&5
echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dlfcn.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dlfcn.h" >&5
echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







4078
4079
4080
4081
4082
4083
4084

4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129

4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172








4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5
echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dlfcn.h usability" >&5
echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dlfcn.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dlfcn.h presence" >&5
echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dlfcn.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: dlfcn.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dlfcn.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: dlfcn.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: dlfcn.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dlfcn.h" >&5
echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058



4059
4060







4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099

4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132

4133
4134
4135
4136


4137
4138


4139
4140


4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|










|







4232
4233
4234
4235
4236
4237
4238

4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283

4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326








4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=\$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention

cat >>confdefs.h <<\_ACEOF
#define USE_THREAD_ALLOC 1
_ACEOF

	# USE_THREAD_STORAGE tells us to use the new generic thread
	# storage subsystem.

cat >>confdefs.h <<\_ACEOF
#define USE_THREAD_STORAGE 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define _REENTRANT 1
_ACEOF

	if test "`uname -s`" = "SunOS" ; then








<
<
<
<
<
<
<







4403
4404
4405
4406
4407
4408
4409







4410
4411
4412
4413
4414
4415
4416
	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention

cat >>confdefs.h <<\_ACEOF
#define USE_THREAD_ALLOC 1
_ACEOF









cat >>confdefs.h <<\_ACEOF
#define _REENTRANT 1
_ACEOF

	if test "`uname -s`" = "SunOS" ; then

4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6
if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







4428
4429
4430
4431
4432
4433
4434

4435
4436
4437
4438
4439
4440
4441
echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6
if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
4258
4259
4260
4261
4262
4263
4264
4265
4266



4267
4268







4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281

4282
4283
4284
4285
4286
4287
4288
4289
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_pthread_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_pthread_pthread_mutex_init=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6
if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then
  tcl_ok=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_pthread_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_pthread_pthread_mutex_init=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6
if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then
  tcl_ok=yes
else
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6
if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







4504
4505
4506
4507
4508
4509
4510

4511
4512
4513
4514
4515
4516
4517
echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6
if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
4324
4325
4326
4327
4328
4329
4330
4331
4332



4333
4334







4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347

4348
4349
4350
4351
4352
4353
4354
4355
__pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_pthread___pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_pthread___pthread_mutex_init=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6
if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then
  tcl_ok=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
__pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_pthread___pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_pthread___pthread_mutex_init=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6
if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then
  tcl_ok=yes
else
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6
if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthreads  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







4580
4581
4582
4583
4584
4585
4586

4587
4588
4589
4590
4591
4592
4593
echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6
if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthreads  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
4390
4391
4392
4393
4394
4395
4396
4397
4398



4399
4400







4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413

4414
4415
4416
4417
4418
4419
4420
4421
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_pthreads_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_pthreads_pthread_mutex_init=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6
if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then
  tcl_ok=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_pthreads_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_pthreads_pthread_mutex_init=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6
if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then
  tcl_ok=yes
else
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6
if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lc  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







4654
4655
4656
4657
4658
4659
4660

4661
4662
4663
4664
4665
4666
4667
echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6
if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lc  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
4454
4455
4456
4457
4458
4459
4460
4461
4462



4463
4464







4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477

4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_c_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_c_pthread_mutex_init=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6
if test $ac_cv_lib_c_pthread_mutex_init = yes; then
  tcl_ok=yes
else
  tcl_ok=no
fi

	    	if test "$tcl_ok" = "no"; then
		    echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5
echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6
if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lc_r  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|



















<







4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731

4732
4733
4734
4735
4736
4737
4738
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_c_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_c_pthread_mutex_init=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6
if test $ac_cv_lib_c_pthread_mutex_init = yes; then
  tcl_ok=yes
else
  tcl_ok=no
fi

	    	if test "$tcl_ok" = "no"; then
		    echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5
echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6
if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lc_r  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
4515
4516
4517
4518
4519
4520
4521
4522
4523



4524
4525







4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538

4539
4540
4541
4542
4543
4544
4545
4546
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_c_r_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_c_r_pthread_mutex_init=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6
if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then
  tcl_ok=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
pthread_mutex_init ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_c_r_pthread_mutex_init=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_c_r_pthread_mutex_init=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6
if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then
  tcl_ok=yes
else
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582




4583
4584
4585
4586

4587
4588
4589
4590
4591



4592
4593
4594
4595
4596
4597
4598
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







4814
4815
4816
4817
4818
4819
4820

4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
4615
4616
4617
4618
4619
4620
4621
4622
4623



4624
4625







4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638

4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662




4663
4664
4665
4666

4667
4668
4669
4670
4671



4672
4673
4674
4675
4676
4677
4678
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done

	echo "$as_me:$LINENO: checking for pthread_attr_get_np" >&5
echo $ECHO_N "checking for pthread_attr_get_np... $ECHO_C" >&6
if test "${ac_cv_func_pthread_attr_get_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char pthread_attr_get_np (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|

















<





>
>
>
>




>





>
>
>







4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918

4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done

	echo "$as_me:$LINENO: checking for pthread_attr_get_np" >&5
echo $ECHO_N "checking for pthread_attr_get_np... $ECHO_C" >&6
if test "${ac_cv_func_pthread_attr_get_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define pthread_attr_get_np to an innocuous variant, in case <limits.h> declares pthread_attr_get_np.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define pthread_attr_get_np innocuous_pthread_attr_get_np

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char pthread_attr_get_np (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef pthread_attr_get_np

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
4695
4696
4697
4698
4699
4700
4701
4702
4703



4704
4705







4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718

4719
4720
4721
4722
4723
4724
4725
4726
return f != pthread_attr_get_np;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_pthread_attr_get_np=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_pthread_attr_get_np=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_pthread_attr_get_np" >&5
echo "${ECHO_T}$ac_cv_func_pthread_attr_get_np" >&6
if test $ac_cv_func_pthread_attr_get_np = yes; then
  tcl_ok=yes
else
  tcl_ok=no







|

>
>
>


>
>
>
>
>
>
>
|












>
|







4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
return f != pthread_attr_get_np;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_pthread_attr_get_np=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_pthread_attr_get_np=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_pthread_attr_get_np" >&5
echo "${ECHO_T}$ac_cv_func_pthread_attr_get_np" >&6
if test $ac_cv_func_pthread_attr_get_np = yes; then
  tcl_ok=yes
else
  tcl_ok=no
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748

	    echo "$as_me:$LINENO: checking for pthread_attr_get_np declaration" >&5
echo $ECHO_N "checking for pthread_attr_get_np declaration... $ECHO_C" >&6
	    if test "${tcl_cv_grep_pthread_attr_get_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <pthread.h>








<







5014
5015
5016
5017
5018
5019
5020

5021
5022
5023
5024
5025
5026
5027

	    echo "$as_me:$LINENO: checking for pthread_attr_get_np declaration" >&5
echo $ECHO_N "checking for pthread_attr_get_np declaration... $ECHO_C" >&6
	    if test "${tcl_cv_grep_pthread_attr_get_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <pthread.h>

4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781




4782
4783
4784
4785

4786
4787
4788
4789
4790



4791
4792
4793
4794
4795
4796
4797
	else
	    echo "$as_me:$LINENO: checking for pthread_getattr_np" >&5
echo $ECHO_N "checking for pthread_getattr_np... $ECHO_C" >&6
if test "${ac_cv_func_pthread_getattr_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char pthread_getattr_np (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







5048
5049
5050
5051
5052
5053
5054

5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
	else
	    echo "$as_me:$LINENO: checking for pthread_getattr_np" >&5
echo $ECHO_N "checking for pthread_getattr_np... $ECHO_C" >&6
if test "${ac_cv_func_pthread_getattr_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define pthread_getattr_np to an innocuous variant, in case <limits.h> declares pthread_getattr_np.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define pthread_getattr_np innocuous_pthread_getattr_np

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char pthread_getattr_np (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef pthread_getattr_np

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
4814
4815
4816
4817
4818
4819
4820
4821
4822



4823
4824







4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837

4838
4839
4840
4841
4842
4843
4844
4845
return f != pthread_getattr_np;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_pthread_getattr_np=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_pthread_getattr_np=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_pthread_getattr_np" >&5
echo "${ECHO_T}$ac_cv_func_pthread_getattr_np" >&6
if test $ac_cv_func_pthread_getattr_np = yes; then
  tcl_ok=yes
else
  tcl_ok=no







|

>
>
>


>
>
>
>
>
>
>
|












>
|







5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
return f != pthread_getattr_np;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_pthread_getattr_np=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_pthread_getattr_np=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_pthread_getattr_np" >&5
echo "${ECHO_T}$ac_cv_func_pthread_getattr_np" >&6
if test $ac_cv_func_pthread_getattr_np = yes; then
  tcl_ok=yes
else
  tcl_ok=no
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867

		echo "$as_me:$LINENO: checking for pthread_getattr_np declaration" >&5
echo $ECHO_N "checking for pthread_getattr_np declaration... $ECHO_C" >&6
		if test "${tcl_cv_grep_pthread_getattr_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <pthread.h>








<







5150
5151
5152
5153
5154
5155
5156

5157
5158
5159
5160
5161
5162
5163

		echo "$as_me:$LINENO: checking for pthread_getattr_np declaration" >&5
echo $ECHO_N "checking for pthread_getattr_np declaration... $ECHO_C" >&6
		if test "${tcl_cv_grep_pthread_getattr_np+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <pthread.h>

4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
#define GETATTRNP_NOT_DECLARED 1
_ACEOF

		fi
	    fi
	fi
	LIBS=$ac_saved_libs

for ac_func in readdir_r
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char $ac_func ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
choke me
#else
char (*f) () = $ac_func;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done

	if test "x$ac_cv_func_readdir_r" = "xyes"; then
            echo "$as_me:$LINENO: checking how many args readdir_r takes" >&5
echo $ECHO_N "checking how many args readdir_r takes... $ECHO_C" >&6
	    # IRIX 5.3 has a 2 arg version of readdir_r
	    # while other systems have a 3 arg version.
	    if test "${tcl_cv_two_arg_readdir_r+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
#include <sys/types.h>
#ifdef NO_DIRENT_H
# include <sys/dir.h>  /* logic from tcl/compat/dirent.h *
# define dirent direct  *                                */
#else
# include <dirent.h>
#endif

int
main ()
{
readdir_r(NULL, NULL);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_two_arg_readdir_r=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_two_arg_readdir_r=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

	    if test "${tcl_cv_three_arg_readdir_r+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
#include <sys/types.h>
#ifdef NO_DIRENT_H
# include <sys/dir.h>  /* logic from tcl/compat/dirent.h *
# define dirent direct  *                                */
#else
# include <dirent.h>
#endif

int
main ()
{
readdir_r(NULL, NULL, NULL);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_three_arg_readdir_r=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_three_arg_readdir_r=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

	    if test "x$tcl_cv_two_arg_readdir_r" = "xyes" ; then
                echo "$as_me:$LINENO: result: 2" >&5
echo "${ECHO_T}2" >&6
	        cat >>confdefs.h <<\_ACEOF
#define HAVE_TWO_ARG_READDIR_R 1
_ACEOF

	    elif test "x$tcl_cv_three_arg_readdir_r" = "xyes" ; then
                echo "$as_me:$LINENO: result: 3" >&5
echo "${ECHO_T}3" >&6
	        cat >>confdefs.h <<\_ACEOF
#define HAVE_THREE_ARG_READDIR_R 1
_ACEOF

	    else
	        { { echo "$as_me:$LINENO: error: unknown number of args for readdir_r" >&5
echo "$as_me: error: unknown number of args for readdir_r" >&2;}
   { (exit 1); exit 1; }; }
	    fi
	fi
    else
	TCL_THREADS=0
	echo "$as_me:$LINENO: result: no (default)" >&5
echo "${ECHO_T}no (default)" >&6
    fi









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







5180
5181
5182
5183
5184
5185
5186















































































































































































































5187
5188
5189
5190
5191
5192
5193
#define GETATTRNP_NOT_DECLARED 1
_ACEOF

		fi
	    fi
	fi
	LIBS=$ac_saved_libs















































































































































































































    else
	TCL_THREADS=0
	echo "$as_me:$LINENO: result: no (default)" >&5
echo "${ECHO_T}no (default)" >&6
    fi


5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162



5163
5164







5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
if test -z "$no_pipe"; then
if test -n "$GCC"; then
  echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5
echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6
  OLDCC="$CC"
  CC="$CC -pipe"
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

CC="$OLDCC"
    echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
fi

#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
#--------------------------------------------------------------------








<
















|

>
>
>


>
>
>
>
>
>
>
|















|







5226
5227
5228
5229
5230
5231
5232

5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
if test -z "$no_pipe"; then
if test -n "$GCC"; then
  echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5
echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6
  OLDCC="$CC"
  CC="$CC -pipe"
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

CC="$OLDCC"
    echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
fi

#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
#--------------------------------------------------------------------

5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208




5209
5210
5211
5212

5213
5214
5215
5216
5217



5218
5219
5220
5221
5222
5223
5224

    echo "$as_me:$LINENO: checking for sin" >&5
echo $ECHO_N "checking for sin... $ECHO_C" >&6
if test "${ac_cv_func_sin+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char sin (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







5294
5295
5296
5297
5298
5299
5300

5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329

    echo "$as_me:$LINENO: checking for sin" >&5
echo $ECHO_N "checking for sin... $ECHO_C" >&6
if test "${ac_cv_func_sin+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define sin to an innocuous variant, in case <limits.h> declares sin.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define sin innocuous_sin

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char sin (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef sin

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
5241
5242
5243
5244
5245
5246
5247
5248
5249



5250
5251







5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264

5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302



5303
5304







5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317

5318
5319
5320
5321
5322
5323
5324
5325
return f != sin;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_sin=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_sin=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5
echo "${ECHO_T}$ac_cv_func_sin" >&6
if test $ac_cv_func_sin = yes; then
  MATH_LIBS=""
else
  MATH_LIBS="-lm"
fi

    echo "$as_me:$LINENO: checking for main in -lieee" >&5
echo $ECHO_N "checking for main in -lieee... $ECHO_C" >&6
if test "${ac_cv_lib_ieee_main+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lieee  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */


int
main ()
{
main ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_ieee_main=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_ieee_main=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_ieee_main" >&5
echo "${ECHO_T}$ac_cv_lib_ieee_main" >&6
if test $ac_cv_lib_ieee_main = yes; then
  MATH_LIBS="-lieee $MATH_LIBS"
fi







|

>
>
>


>
>
>
>
>
>
>
|












>
|

















<

















|

>
>
>


>
>
>
>
>
>
>
|












>
|







5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398

5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
return f != sin;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_sin=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_sin=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5
echo "${ECHO_T}$ac_cv_func_sin" >&6
if test $ac_cv_func_sin = yes; then
  MATH_LIBS=""
else
  MATH_LIBS="-lm"
fi

    echo "$as_me:$LINENO: checking for main in -lieee" >&5
echo $ECHO_N "checking for main in -lieee... $ECHO_C" >&6
if test "${ac_cv_lib_ieee_main+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lieee  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */


int
main ()
{
main ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_ieee_main=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_ieee_main=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_ieee_main" >&5
echo "${ECHO_T}$ac_cv_lib_ieee_main" >&6
if test $ac_cv_lib_ieee_main = yes; then
  MATH_LIBS="-lieee $MATH_LIBS"
fi
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360



5361
5362







5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375

5376
5377
5378
5379
5380
5381
5382
5383
echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6
if test "${ac_cv_lib_inet_main+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-linet  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */


int
main ()
{
main ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_inet_main=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_inet_main=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5
echo "${ECHO_T}$ac_cv_lib_inet_main" >&6
if test $ac_cv_lib_inet_main = yes; then
  LIBS="$LIBS -linet"
fi







<

















|

>
>
>


>
>
>
>
>
>
>
|












>
|







5460
5461
5462
5463
5464
5465
5466

5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6
if test "${ac_cv_lib_inet_main+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-linet  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */


int
main ()
{
main ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_inet_main=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_inet_main=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5
echo "${ECHO_T}$ac_cv_lib_inet_main" >&6
if test $ac_cv_lib_inet_main = yes; then
  LIBS="$LIBS -linet"
fi
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410



5411
5412







5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451

5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484

5485
5486
5487
5488


5489
5490


5491
5492


5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5
echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking net/errno.h usability" >&5
echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <net/errno.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking net/errno.h presence" >&5
echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <net/errno.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for net/errno.h" >&5
echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







5527
5528
5529
5530
5531
5532
5533

5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578

5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621








5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5
echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking net/errno.h usability" >&5
echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <net/errno.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking net/errno.h presence" >&5
echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <net/errno.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: net/errno.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: net/errno.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: net/errno.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: net/errno.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: net/errno.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: net/errno.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for net/errno.h" >&5
echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555




5556
5557
5558
5559

5560
5561
5562
5563
5564



5565
5566
5567
5568
5569
5570
5571
    tcl_checkBoth=0
    echo "$as_me:$LINENO: checking for connect" >&5
echo $ECHO_N "checking for connect... $ECHO_C" >&6
if test "${ac_cv_func_connect+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char connect (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







5687
5688
5689
5690
5691
5692
5693

5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
    tcl_checkBoth=0
    echo "$as_me:$LINENO: checking for connect" >&5
echo $ECHO_N "checking for connect... $ECHO_C" >&6
if test "${ac_cv_func_connect+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define connect to an innocuous variant, in case <limits.h> declares connect.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define connect innocuous_connect

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char connect (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef connect

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
5588
5589
5590
5591
5592
5593
5594
5595
5596



5597
5598







5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611

5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634




5635
5636
5637
5638

5639
5640
5641
5642
5643



5644
5645
5646
5647
5648
5649
5650
return f != connect;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_connect=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_connect=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5
echo "${ECHO_T}$ac_cv_func_connect" >&6
if test $ac_cv_func_connect = yes; then
  tcl_checkSocket=0
else
  tcl_checkSocket=1
fi

    if test "$tcl_checkSocket" = 1; then
	echo "$as_me:$LINENO: checking for setsockopt" >&5
echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6
if test "${ac_cv_func_setsockopt+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char setsockopt (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|
















<





>
>
>
>




>





>
>
>







5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790

5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
return f != connect;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_connect=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_connect=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5
echo "${ECHO_T}$ac_cv_func_connect" >&6
if test $ac_cv_func_connect = yes; then
  tcl_checkSocket=0
else
  tcl_checkSocket=1
fi

    if test "$tcl_checkSocket" = 1; then
	echo "$as_me:$LINENO: checking for setsockopt" >&5
echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6
if test "${ac_cv_func_setsockopt+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define setsockopt to an innocuous variant, in case <limits.h> declares setsockopt.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define setsockopt innocuous_setsockopt

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char setsockopt (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef setsockopt

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
5667
5668
5669
5670
5671
5672
5673
5674
5675



5676
5677







5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690

5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
return f != setsockopt;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_setsockopt=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_setsockopt=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5
echo "${ECHO_T}$ac_cv_func_setsockopt" >&6
if test $ac_cv_func_setsockopt = yes; then
  :
else
  echo "$as_me:$LINENO: checking for setsockopt in -lsocket" >&5
echo $ECHO_N "checking for setsockopt in -lsocket... $ECHO_C" >&6
if test "${ac_cv_lib_socket_setsockopt+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|














<







5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885

5886
5887
5888
5889
5890
5891
5892
return f != setsockopt;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_setsockopt=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_setsockopt=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5
echo "${ECHO_T}$ac_cv_func_setsockopt" >&6
if test $ac_cv_func_setsockopt = yes; then
  :
else
  echo "$as_me:$LINENO: checking for setsockopt in -lsocket" >&5
echo $ECHO_N "checking for setsockopt in -lsocket... $ECHO_C" >&6
if test "${ac_cv_lib_socket_setsockopt+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
5723
5724
5725
5726
5727
5728
5729
5730
5731



5732
5733







5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746

5747
5748
5749
5750
5751
5752
5753
5754
setsockopt ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_socket_setsockopt=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_socket_setsockopt=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5
echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6
if test $ac_cv_lib_socket_setsockopt = yes; then
  LIBS="$LIBS -lsocket"
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
setsockopt ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_socket_setsockopt=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_socket_setsockopt=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5
echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6
if test $ac_cv_lib_socket_setsockopt = yes; then
  LIBS="$LIBS -lsocket"
else
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775




5776
5777
5778
5779

5780
5781
5782
5783
5784



5785
5786
5787
5788
5789
5790
5791
	LIBS="$LIBS -lsocket -lnsl"
	echo "$as_me:$LINENO: checking for accept" >&5
echo $ECHO_N "checking for accept... $ECHO_C" >&6
if test "${ac_cv_func_accept+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char accept (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







5953
5954
5955
5956
5957
5958
5959

5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
	LIBS="$LIBS -lsocket -lnsl"
	echo "$as_me:$LINENO: checking for accept" >&5
echo $ECHO_N "checking for accept... $ECHO_C" >&6
if test "${ac_cv_func_accept+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define accept to an innocuous variant, in case <limits.h> declares accept.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define accept innocuous_accept

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char accept (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef accept

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
5808
5809
5810
5811
5812
5813
5814
5815
5816



5817
5818







5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831

5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854




5855
5856
5857
5858

5859
5860
5861
5862
5863



5864
5865
5866
5867
5868
5869
5870
return f != accept;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_accept=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_accept=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5
echo "${ECHO_T}$ac_cv_func_accept" >&6
if test $ac_cv_func_accept = yes; then
  tcl_checkNsl=0
else
  LIBS=$tk_oldLibs
fi

    fi
    echo "$as_me:$LINENO: checking for gethostbyname" >&5
echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6
if test "${ac_cv_func_gethostbyname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gethostbyname (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|
















<





>
>
>
>




>





>
>
>







6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056

6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
return f != accept;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_accept=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_accept=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5
echo "${ECHO_T}$ac_cv_func_accept" >&6
if test $ac_cv_func_accept = yes; then
  tcl_checkNsl=0
else
  LIBS=$tk_oldLibs
fi

    fi
    echo "$as_me:$LINENO: checking for gethostbyname" >&5
echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6
if test "${ac_cv_func_gethostbyname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define gethostbyname to an innocuous variant, in case <limits.h> declares gethostbyname.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define gethostbyname innocuous_gethostbyname

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gethostbyname (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef gethostbyname

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
5887
5888
5889
5890
5891
5892
5893
5894
5895



5896
5897







5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910

5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
return f != gethostbyname;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_gethostbyname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_gethostbyname=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5
echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6
if test $ac_cv_func_gethostbyname = yes; then
  :
else
  echo "$as_me:$LINENO: checking for gethostbyname in -lnsl" >&5
echo $ECHO_N "checking for gethostbyname in -lnsl... $ECHO_C" >&6
if test "${ac_cv_lib_nsl_gethostbyname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lnsl  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|














<







6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151

6152
6153
6154
6155
6156
6157
6158
return f != gethostbyname;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_gethostbyname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_gethostbyname=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5
echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6
if test $ac_cv_func_gethostbyname = yes; then
  :
else
  echo "$as_me:$LINENO: checking for gethostbyname in -lnsl" >&5
echo $ECHO_N "checking for gethostbyname in -lnsl... $ECHO_C" >&6
if test "${ac_cv_lib_nsl_gethostbyname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lnsl  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
5943
5944
5945
5946
5947
5948
5949
5950
5951



5952
5953







5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966

5967
5968
5969
5970
5971
5972
5973
5974
gethostbyname ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_nsl_gethostbyname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_nsl_gethostbyname=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5
echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6
if test $ac_cv_lib_nsl_gethostbyname = yes; then
  LIBS="$LIBS -lnsl"
fi







|

>
>
>


>
>
>
>
>
>
>
|












>
|







6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
gethostbyname ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_nsl_gethostbyname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_nsl_gethostbyname=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5
echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6
if test $ac_cv_lib_nsl_gethostbyname = yes; then
  LIBS="$LIBS -lnsl"
fi
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6
if test "${ac_cv_lib_dl_dlopen+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-ldl  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







6416
6417
6418
6419
6420
6421
6422

6423
6424
6425
6426
6427
6428
6429
echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6
if test "${ac_cv_lib_dl_dlopen+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-ldl  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
6204
6205
6206
6207
6208
6209
6210
6211
6212



6213
6214







6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227

6228
6229
6230
6231
6232
6233
6234
6235
dlopen ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_dl_dlopen=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_dl_dlopen=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5
echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6
if test $ac_cv_lib_dl_dlopen = yes; then
  have_dl=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
dlopen ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_dl_dlopen=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_dl_dlopen=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5
echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6
if test $ac_cv_lib_dl_dlopen = yes; then
  have_dl=yes
else
6303
6304
6305
6306
6307
6308
6309

6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
	{ { echo "$as_me:$LINENO: error: Required archive tool 'ar' not found on PATH." >&5
echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;}
   { (exit 1); exit 1; }; }
    fi
    STLIB_LD='${AR} cr'
    LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
    PLAT_OBJS=""

    case $system in
	AIX-5.*)
	    if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5
echo "${ECHO_T}Using $CC for compiling with threads" >&6
	    fi
	    LIBS="$LIBS -lc"
	    # AIX-5 uses ELF style dynamic libraries
	    SHLIB_CFLAGS=""
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    DL_OBJS="tclLoadDl.o"

	    LD_LIBRARY_PATH_VAR="LIBPATH"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;}
		else
		    do64bit_ok=yes
		    CFLAGS="$CFLAGS -q64"
		    LDFLAGS_ARCH="-q64"
		    RANLIB="${RANLIB} -X64"
		    AR="${AR} -X64"
		    SHLIB_LD_FLAGS="-b64"







>

|









<







<


|
|

|
|







6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567

6568
6569
6570
6571
6572
6573
6574

6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
	{ { echo "$as_me:$LINENO: error: Required archive tool 'ar' not found on PATH." >&5
echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;}
   { (exit 1); exit 1; }; }
    fi
    STLIB_LD='${AR} cr'
    LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
    PLAT_OBJS=""
    PLAT_SRCS=""
    case $system in
	AIX-*)
	    if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5
echo "${ECHO_T}Using $CC for compiling with threads" >&6
	    fi
	    LIBS="$LIBS -lc"

	    SHLIB_CFLAGS=""
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    DL_OBJS="tclLoadDl.o"

	    LD_LIBRARY_PATH_VAR="LIBPATH"

	    # Check to enable 64-bit flags for compiler/linker on AIX 4+
	    if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then
		if test "$GCC" = "yes" ; then
		    { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5
echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
		else
		    do64bit_ok=yes
		    CFLAGS="$CFLAGS -q64"
		    LDFLAGS_ARCH="-q64"
		    RANLIB="${RANLIB} -X64"
		    AR="${AR} -X64"
		    SHLIB_LD_FLAGS="-b64"
6352
6353
6354
6355
6356
6357
6358



6359


6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389





6390
6391
6392

6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
		if test "$GCC" = "yes" ; then
		    CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		else
		    CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
		fi
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    else



		SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}"


		DL_LIBS="-ldl"
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		TCL_NEEDS_EXP_FILE=1
		TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
	    fi
	    ;;
	AIX-*)
	    if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5
echo "${ECHO_T}Using $CC for compiling with threads" >&6
	    fi
	    LIBS="$LIBS -lc"
	    SHLIB_CFLAGS=""
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    LD_LIBRARY_PATH_VAR="LIBPATH"
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then





		LIBOBJS="$LIBOBJS tclLoadAix.$ac_objext"
		DL_LIBS="-lld"
	    fi


	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;}
		else
		    do64bit_ok=yes
		    CFLAGS="$CFLAGS -q64"
		    LDFLAGS_ARCH="-q64"
		    RANLIB="${RANLIB} -X64"
		    AR="${AR} -X64"
		    SHLIB_LD_FLAGS="-b64"
		fi
	    fi
	    SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}"

	    # On AIX <=v4 systems, libbsd.a has to be linked in to support
	    # non-blocking file IO.  This library has to be linked in after
	    # the MATH_LIBS or it breaks the pow() function.  The way to
	    # insure proper sequencing, is to add it to the tail of MATH_LIBS.
	    # This library also supplies gettimeofday.
	    #







>
>
>
|
>
>




|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



>
>
>
>
>
|
<
<
>

<
<
<
<
<
<
<
<
<
<
<
|
|
<
<







6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615





















6616
6617
6618
6619
6620
6621
6622
6623
6624


6625
6626











6627
6628


6629
6630
6631
6632
6633
6634
6635
		if test "$GCC" = "yes" ; then
		    CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		else
		    CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
		fi
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    else
		if test "$GCC" = "yes" ; then
		    SHLIB_LD="gcc -shared"
		else
		    SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
		fi
		SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}"
		DL_LIBS="-ldl"
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		TCL_NEEDS_EXP_FILE=1
		TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp'
	    fi






















	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		case $LIBOBJS in
    "tclLoadAix.$ac_objext"   | \
  *" tclLoadAix.$ac_objext"   | \
    "tclLoadAix.$ac_objext "* | \
  *" tclLoadAix.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS tclLoadAix.$ac_objext" ;;


esac












		DL_LIBS="-lld"
	    fi



	    # On AIX <=v4 systems, libbsd.a has to be linked in to support
	    # non-blocking file IO.  This library has to be linked in after
	    # the MATH_LIBS or it breaks the pow() function.  The way to
	    # insure proper sequencing, is to add it to the tail of MATH_LIBS.
	    # This library also supplies gettimeofday.
	    #
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
echo $ECHO_N "checking for gettimeofday in -lbsd... $ECHO_C" >&6
if test "${ac_cv_lib_bsd_gettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lbsd  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







6643
6644
6645
6646
6647
6648
6649

6650
6651
6652
6653
6654
6655
6656
echo $ECHO_N "checking for gettimeofday in -lbsd... $ECHO_C" >&6
if test "${ac_cv_lib_bsd_gettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lbsd  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
6447
6448
6449
6450
6451
6452
6453
6454
6455



6456
6457







6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470

6471
6472
6473
6474
6475
6476
6477
6478
gettimeofday ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_bsd_gettimeofday=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_bsd_gettimeofday=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_bsd_gettimeofday" >&5
echo "${ECHO_T}$ac_cv_lib_bsd_gettimeofday" >&6
if test $ac_cv_lib_bsd_gettimeofday = yes; then
  libbsd=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
gettimeofday ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_bsd_gettimeofday=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_bsd_gettimeofday=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_bsd_gettimeofday" >&5
echo "${ECHO_T}$ac_cv_lib_bsd_gettimeofday" >&6
if test $ac_cv_lib_bsd_gettimeofday = yes; then
  libbsd=yes
else
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6
if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lbind  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







6735
6736
6737
6738
6739
6740
6741

6742
6743
6744
6745
6746
6747
6748
echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6
if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lbind  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
6529
6530
6531
6532
6533
6534
6535
6536
6537



6538
6539







6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552

6553
6554
6555
6556
6557
6558
6559
6560
inet_ntoa ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_bind_inet_ntoa=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_bind_inet_ntoa=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5
echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6
if test $ac_cv_lib_bind_inet_ntoa = yes; then
  LIBS="$LIBS -lbind -lsocket"
fi







|

>
>
>


>
>
>
>
>
>
>
|












>
|







6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
inet_ntoa ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_bind_inet_ntoa=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_bind_inet_ntoa=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5
echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6
if test $ac_cv_lib_bind_inet_ntoa = yes; then
  LIBS="$LIBS -lbind -lsocket"
fi
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6
if test "${ac_cv_lib_dld_shl_load+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







6850
6851
6852
6853
6854
6855
6856

6857
6858
6859
6860
6861
6862
6863
echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6
if test "${ac_cv_lib_dld_shl_load+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
6634
6635
6636
6637
6638
6639
6640
6641
6642



6643
6644







6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657

6658
6659
6660
6661
6662
6663
6664
6665
shl_load ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_dld_shl_load=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_dld_shl_load=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5
echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6
if test $ac_cv_lib_dld_shl_load = yes; then
  tcl_ok=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
6906
6907
6908
6909
6910
6911
6912
6913
6914
6915
shl_load ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_dld_shl_load=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_dld_shl_load=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5
echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6
if test $ac_cv_lib_dld_shl_load = yes; then
  tcl_ok=yes
else
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="gcc -shared"
		SHLIB_LD_LIBS='${LIBS}'
		LD_SEARCH_FLAGS=''
		CC_SEARCH_FLAGS=''
	    fi

	    # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
	    #CFLAGS="$CFLAGS +DAportable"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    hpux_arch=`gcc -dumpmachine`
		    case $hpux_arch in
			hppa64*)
			    # 64-bit gcc in use.  Fix flags for GNU ld.
			    do64bit_ok=yes
			    SHLIB_LD="gcc -shared"
			    SHLIB_LD_LIBS='${LIBS}'
			    LD_SEARCH_FLAGS=''
			    CC_SEARCH_FLAGS=''
			    ;;
			*)
			    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;}
			    ;;
		    esac
		else







|
<















|
|







6926
6927
6928
6929
6930
6931
6932
6933

6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="gcc -shared"
		SHLIB_LD_LIBS='${LIBS}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    fi

	    # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
	    #CFLAGS="$CFLAGS +DAportable"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    hpux_arch=`gcc -dumpmachine`
		    case $hpux_arch in
			hppa64*)
			    # 64-bit gcc in use.  Fix flags for GNU ld.
			    do64bit_ok=yes
			    SHLIB_LD="gcc -shared"
			    SHLIB_LD_LIBS='${LIBS}'
			    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
			    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
			    ;;
			*)
			    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;}
			    ;;
		    esac
		else
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6
if test "${ac_cv_lib_dld_shl_load+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







<







6967
6968
6969
6970
6971
6972
6973

6974
6975
6976
6977
6978
6979
6980
echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6
if test "${ac_cv_lib_dld_shl_load+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
6742
6743
6744
6745
6746
6747
6748
6749
6750



6751
6752







6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765

6766
6767
6768
6769
6770
6771
6772
6773
shl_load ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_dld_shl_load=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_dld_shl_load=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5
echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6
if test $ac_cv_lib_dld_shl_load = yes; then
  tcl_ok=yes
else







|

>
>
>


>
>
>
>
>
>
>
|












>
|







6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028
7029
7030
7031
7032
shl_load ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_dld_shl_load=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_dld_shl_load=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5
echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6
if test $ac_cv_lib_dld_shl_load = yes; then
  tcl_ok=yes
else
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
		DL_LIBS="-ldld"
		LDFLAGS="$LDFLAGS -Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""







<
<
<
<
<
<
<
<
<
<
<
<







7041
7042
7043
7044
7045
7046
7047












7048
7049
7050
7051
7052
7053
7054
		DL_LIBS="-ldld"
		LDFLAGS="$LDFLAGS -Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    ;;












	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904



6905
6906







6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945

6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978

6979
6980
6981
6982


6983
6984


6985
6986


6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5
echo "${ECHO_T}$ac_cv_header_dld_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dld.h usability" >&5
echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dld.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dld.h presence" >&5
echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dld.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dld.h" >&5
echo $ECHO_N "checking for dld.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







7132
7133
7134
7135
7136
7137
7138

7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183

7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226








7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5
echo "${ECHO_T}$ac_cv_header_dld_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dld.h usability" >&5
echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dld.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dld.h presence" >&5
echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dld.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dld.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: dld.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: dld.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: dld.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dld.h" >&5
echo $ECHO_N "checking for dld.h... $ECHO_C" >&6
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080



7081
7082







7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121

7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154

7155
7156
7157
7158


7159
7160


7161
7162


7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5
echo "${ECHO_T}$ac_cv_header_dld_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dld.h usability" >&5
echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dld.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dld.h presence" >&5
echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dld.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dld.h" >&5
echo $ECHO_N "checking for dld.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







7316
7317
7318
7319
7320
7321
7322

7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
7365
7366
7367

7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410








7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5
echo "${ECHO_T}$ac_cv_header_dld_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dld.h usability" >&5
echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dld.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dld.h presence" >&5
echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dld.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dld.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: dld.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: dld.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: dld.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: dld.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dld.h" >&5
echo $ECHO_N "checking for dld.h... $ECHO_C" >&6
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362

















































7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -Wl,-Bexport"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[1-2].*)
	    # Not available on all versions:  check for include file.
	    if test "${ac_cv_header_dlfcn_h+set}" = set; then
  echo "$as_me:$LINENO: checking for dlfcn.h" >&5
echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6
if test "${ac_cv_header_dlfcn_h+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
fi
echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5
echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking dlfcn.h usability" >&5
echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <dlfcn.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking dlfcn.h presence" >&5
echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <dlfcn.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for dlfcn.h" >&5
echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6
if test "${ac_cv_header_dlfcn_h+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_cv_header_dlfcn_h=$ac_header_preproc
fi
echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5
echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6

fi
if test $ac_cv_header_dlfcn_h = yes; then

		# NetBSD/SPARC needs -fPIC, -fpic will not do.
		SHLIB_CFLAGS="-fPIC"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
		echo "$as_me:$LINENO: checking for ELF" >&5

















































echo $ECHO_N "checking for ELF... $ECHO_C" >&6
		cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#ifdef __ELF__
	yes
#endif

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "yes" >/dev/null 2>&1; then
  echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
else
  echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'

fi
rm -f conftest*


else

		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'

fi



	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	OpenBSD-*)
	    SHLIB_LD="${CC} -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    echo "$as_me:$LINENO: checking for ELF" >&5
echo $ECHO_N "checking for ELF... $ECHO_C" >&6
	    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#ifdef __ELF__
	yes
#endif

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "yes" >/dev/null 2>&1; then
  echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
else
  echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'

fi
rm -f conftest*


	    # OpenBSD doesn't do version numbers with dots.
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
<















|



<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




|







7477
7478
7479
7480
7481
7482
7483




































































































































7484
7485
7486
7487
7488
7489
7490
7491
7492
7493
7494
7495
7496
7497
7498
7499
7500
7501
7502
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
7525
7526
7527
7528
7529
7530
7531
7532
7533
7534
7535
7536
7537
7538
7539
7540
7541
7542
7543
7544

7545
7546
7547
7548
7549
7550
7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
7562
7563








7564








7565
7566










































7567
7568
7569
7570
7571
7572
7573
7574
7575
7576
7577
7578
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -Wl,-Bexport"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[1-2].*)




































































































































	    # NetBSD/SPARC needs -fPIC, -fpic will not do.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    echo "$as_me:$LINENO: checking for ELF" >&5
echo $ECHO_N "checking for ELF... $ECHO_C" >&6
	    cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#ifdef __ELF__
	yes
#endif

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "yes" >/dev/null 2>&1; then
  echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
else
  echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0'

fi
rm -f conftest*


	    # Ancient FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	OpenBSD-*)
	    # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do.
	    case `machine` in
	    sparc|sparc64)
		SHLIB_CFLAGS="-fPIC";;
	    *)
		SHLIB_CFLAGS="-fpic";;
	    esac
	    SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0'
	    echo "$as_me:$LINENO: checking for ELF" >&5
echo $ECHO_N "checking for ELF... $ECHO_C" >&6
	    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#ifdef __ELF__
	yes
#endif

_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  $EGREP "yes" >/dev/null 2>&1; then
  echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6
		 LDFLAGS=-Wl,-export-dynamic
else
  echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6








		LDFLAGS=""









fi










































rm -f conftest*


	    # OpenBSD doesn't do version numbers with dots.
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476
7477
7478
7479

7480
7481





7482








7483














































7484
7485
7486
7487
7488
7489





























































7490
7491
7492
7493



















7494























































7495
7496
7497
7498


7499




























































































































































































































































7500
7501
7502
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514










































































































7515
7516
7517
7518
7519
7520
7521
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS -pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Rhapsody-*|Darwin-*)

	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS}"





	    TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"








	    TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TK_LIB_FILE} -prebind -seg1addr 0xb000000"














































	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"
	    PLAT_OBJS=\$\(MAC\_OSX_OBJS\)
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -prebind"





























































	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    CFLAGS_OPTIMIZE="-Os"
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"











































































cat >>confdefs.h <<\_ACEOF
#define MAC_OSX_TCL 1
_ACEOF
































































































































































































































































cat >>confdefs.h <<\_ACEOF
#define HAVE_CFBUNDLE 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define USE_VFORK 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_DEFAULT_ENCODING "utf-8"
_ACEOF

	    LIBS="$LIBS -framework CoreFoundation"










































































































	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"







|
|




|
>


>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



<

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


<

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|


>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|












|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







7587
7588
7589
7590
7591
7592
7593
7594
7595
7596
7597
7598
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627
7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
7649
7650
7651
7652
7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667

7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732

7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
7802
7803
7804
7805
7806
7807
7808
7809
7810
7811
7812
7813
7814
7815
7816
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880
7881
7882
7883
7884
7885
7886
7887
7888
7889
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
7984
7985
7986
7987
7988
7989
7990
7991
7992
7993
7994
7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
8117
8118
8119
8120
8121
8122
8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164
8165
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS -pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Darwin-*)
	    CFLAGS_OPTIMIZE="-Os"
	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
	    echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5
echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6
if test "${tcl_cv_ld_single_module+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	        hold_ldflags=$LDFLAGS
	        LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
	        cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
int i;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_ld_single_module=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_ld_single_module=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
	        LDFLAGS=$hold_ldflags
fi
echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5
echo "${ECHO_T}$tcl_cv_ld_single_module" >&6
	    if test $tcl_cv_ld_single_module = yes; then
	        SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
	    fi
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"

	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -prebind -headerpad_max_install_names"
	    echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5
echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6
if test "${tcl_cv_ld_search_paths_first+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	        hold_ldflags=$LDFLAGS
	        LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
	        cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
int i;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_ld_search_paths_first=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_ld_search_paths_first=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
	        LDFLAGS=$hold_ldflags
fi
echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5
echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6
	    if test $tcl_cv_ld_search_paths_first = yes; then
	        LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
	    fi
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""

	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
	    PLAT_OBJS='${MAC_OSX_OBJS}'
	    PLAT_SRCS='${MAC_OSX_SRCS}'
            echo "$as_me:$LINENO: checking whether to use CoreFoundation" >&5
echo $ECHO_N "checking whether to use CoreFoundation... $ECHO_C" >&6
            # Check whether --enable-corefoundation or --disable-corefoundation was given.
if test "${enable_corefoundation+set}" = set; then
  enableval="$enable_corefoundation"
  tcl_corefoundation=$enableval
else
  tcl_corefoundation=yes
fi;
            echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5
echo "${ECHO_T}$tcl_corefoundation" >&6
            if test $tcl_corefoundation = yes; then
                echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5
echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6
if test "${tcl_cv_lib_corefoundation+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

                    hold_libs=$LIBS
                    LIBS="$LIBS -framework CoreFoundation"
                    cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <CoreFoundation/CoreFoundation.h>
int
main ()
{
CFBundleRef b = CFBundleGetMainBundle();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_lib_corefoundation=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_lib_corefoundation=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
                    LIBS=$hold_libs
fi
echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5
echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6
                if test $tcl_cv_lib_corefoundation = yes; then
                    LIBS="$LIBS -framework CoreFoundation"

cat >>confdefs.h <<\_ACEOF
#define HAVE_COREFOUNDATION 1
_ACEOF

                fi
	    fi

for ac_header in libkern/OSAtomic.h
do
as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=\$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF

fi

done


for ac_func in OSSpinLockLock
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char $ac_func ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
choke me
#else
char (*f) () = $ac_func;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done


cat >>confdefs.h <<\_ACEOF
#define MAC_OSX_TCL 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define USE_VFORK 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_DEFAULT_ENCODING "utf-8"
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define MODULE_SCOPE __private_extern__
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_LOAD_FROM_MEMORY 1
_ACEOF

	    # prior to Darwin 7, realpath is not threadsafe, so don't
	    # use it when threads are enabled, c.f. bug # 711232:
	    echo "$as_me:$LINENO: checking for realpath" >&5
echo $ECHO_N "checking for realpath... $ECHO_C" >&6
if test "${ac_cv_func_realpath+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define realpath to an innocuous variant, in case <limits.h> declares realpath.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define realpath innocuous_realpath

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char realpath (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef realpath

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char realpath ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_realpath) || defined (__stub___realpath)
choke me
#else
char (*f) () = realpath;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != realpath;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_realpath=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_realpath=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5
echo "${ECHO_T}$ac_cv_func_realpath" >&6

	    if test "$ac_cv_func_realpath" = yes -a "${TCL_THREADS}" = 1 \
	            -a `uname -r | awk -F. '{print $1}'` -lt 7 ; then
	        ac_cv_func_realpath=no
	    fi
	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"







<
<
<
<
<
<
<
<
<
<
<







8274
8275
8276
8277
8278
8279
8280











8281
8282
8283
8284
8285
8286
8287
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;











	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666

7667
7668
7669
7670
7671
7672
7673
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[0-6]*)


	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.


cat >>confdefs.h <<\_ACEOF
#define _REENTRANT 1







|
|


|
>







8318
8319
8320
8321
8322
8323
8324
8325
8326
8327
8328
8329
8330
8331
8332
8333
8334
8335
8336
8337
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[0-6])
	    # Careful to not let 5.10+ fall into this case

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.


cat >>confdefs.h <<\_ACEOF
#define _REENTRANT 1
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.


cat >>confdefs.h <<\_ACEOF
#define _REENTRANT 1
_ACEOF







<







8359
8360
8361
8362
8363
8364
8365

8366
8367
8368
8369
8370
8371
8372
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.


cat >>confdefs.h <<\_ACEOF
#define _REENTRANT 1
_ACEOF
7717
7718
7719
7720
7721
7722
7723

7724
7725






7726
7727
7728
7729
7730
7731
7732
7733
7734
7735




7736





7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752









7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
7802
7803
7804
7805



7806
7807







7808
7809
7810
7811
7812
7813
7814
7815
7816
7817
7818
7819
7820

7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880
7881
7882
7883
7884
7885
7886
7887
7888
7889
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
7984
7985
7986
7987
7988
7989
7990
7991
7992
7993
7994
7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
	    SHLIB_CFLAGS="-KPIC"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then

			    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;}






			else
			    do64bit_ok=yes
			    if test "$do64bitVIS" = "yes" ; then
				CFLAGS="$CFLAGS -xarch=v9a"
			    	LDFLAGS_ARCH="-xarch=v9a"
			    else
				CFLAGS="$CFLAGS -xarch=v9"
			    	LDFLAGS_ARCH="-xarch=v9"
			    fi
			fi




		else





		    { echo "$as_me:$LINENO: WARNING: \"64bit mode only supported sparcv9 system\"" >&5
echo "$as_me: WARNING: \"64bit mode only supported sparcv9 system\"" >&2;}
		fi
	    fi

	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}









	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    if test "$GCC" != "yes" ; then
		CFLAGS="$CFLAGS -DHAVE_TZSET -std1"
	    fi
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
	    # that don't grok the -Bexport option.  Test that it does.
	    hold_ldflags=$LDFLAGS
	    echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5
echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6
	    LDFLAGS="$LDFLAGS -Wl,-Bexport"
	    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
int i;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  found=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

LDFLAGS=$hold_ldflags found=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
	    echo "$as_me:$LINENO: result: $found" >&5
echo "${ECHO_T}$found" >&6
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
	{ echo "$as_me:$LINENO: WARNING: \"64bit support being disabled -- don\'t know magic for this platform\"" >&5
echo "$as_me: WARNING: \"64bit support being disabled -- don\'t know magic for this platform\"" >&2;}
    fi

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then

cat >>confdefs.h <<\_ACEOF
#define TCL_CFG_DO64BIT 1
_ACEOF

    fi

    # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic
    # Loading for Tcl -- What Became of It?".  Proc. 2nd Tcl/Tk Workshop,
    # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need
    # to determine which of several header files defines the a.out file
    # format (a.out.h, sys/exec.h, or sys/exec_aout.h).  At present, we
    # support only a file format that is more or less version-7-compatible.
    # In particular,
    #	- a.out files must begin with `struct exec'.
    #	- the N_TXTOFF on the `struct exec' must compute the seek address
    #	  of the text segment
    #	- The `struct exec' must contain a_magic, a_text, a_data, a_bss
    #	  and a_entry fields.
    # The following compilation should succeed if and only if either sys/exec.h
    # or a.out.h is usable for the purpose.
    #
    # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
    # `struct exec' includes a second header that contains information that
    # duplicates the v7 fields that are needed.

    if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
	echo "$as_me:$LINENO: checking sys/exec.h" >&5
echo $ECHO_N "checking sys/exec.h... $ECHO_C" >&6
	cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/exec.h>
int
main ()
{

	    struct exec foo;
	    unsigned long seek;
	    int flag;
#if defined(__mips) || defined(mips)
	    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
	    seek = N_TXTOFF (foo);
#endif
	    flag = (foo.a_magic == OMAGIC);
	    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_ok=usable
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_ok=unusable
fi
rm -f conftest.$ac_objext conftest.$ac_ext
	echo "$as_me:$LINENO: result: $tcl_ok" >&5
echo "${ECHO_T}$tcl_ok" >&6
	if test $tcl_ok = usable; then

cat >>confdefs.h <<\_ACEOF
#define USE_SYS_EXEC_H 1
_ACEOF

	else
	    echo "$as_me:$LINENO: checking a.out.h" >&5
echo $ECHO_N "checking a.out.h... $ECHO_C" >&6
	    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <a.out.h>
int
main ()
{

		struct exec foo;
		unsigned long seek;
		int flag;
#if defined(__mips) || defined(mips)
		seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		seek = N_TXTOFF (foo);
#endif
		flag = (foo.a_magic == OMAGIC);
		return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_ok=usable
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_ok=unusable
fi
rm -f conftest.$ac_objext conftest.$ac_ext
	    echo "$as_me:$LINENO: result: $tcl_ok" >&5
echo "${ECHO_T}$tcl_ok" >&6
	    if test $tcl_ok = usable; then

cat >>confdefs.h <<\_ACEOF
#define USE_A_OUT_H 1
_ACEOF

	    else
		echo "$as_me:$LINENO: checking sys/exec_aout.h" >&5
echo $ECHO_N "checking sys/exec_aout.h... $ECHO_C" >&6
		cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/exec_aout.h>
int
main ()
{

		    struct exec foo;
		    unsigned long seek;
		    int flag;
#if defined(__mips) || defined(mips)
		    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		    seek = N_TXTOFF (foo);
#endif
		    flag = (foo.a_midmag == OMAGIC);
		    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_ok=usable
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_ok=unusable
fi
rm -f conftest.$ac_objext conftest.$ac_ext
		echo "$as_me:$LINENO: result: $tcl_ok" >&5
echo "${ECHO_T}$tcl_ok" >&6
		if test $tcl_ok = usable; then

cat >>confdefs.h <<\_ACEOF
#define USE_SYS_EXEC_AOUT_H 1
_ACEOF

		else
		    DL_OBJS=""
		fi
	    fi
	fi
    fi

    # Step 5: disable dynamic loading if requested via a command-line switch.

    # Check whether --enable-load or --disable-load was given.
if test "${enable_load+set}" = set; then
  enableval="$enable_load"
  tcl_ok=$enableval
else
  tcl_ok=yes







>
|
|
>
>
>
>
>
>










>
>
>
>
|
>
>
>
>
>
|
|














>
>
>
>
>
>
>
>
>





<
<
<
<
<
<
<
<
<
<
<
<
<
<















<
















|

>
>
>


>
>
>
>
>
>
>
|












>
|








|
|










<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445














8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460

8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525








































































































































































































8526
8527
8528
8529
8530
8531
8532
8533
	    SHLIB_CFLAGS="-KPIC"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then
			    if test "`gcc -dumpversion | awk -F. '{print $1}'`" -lt "3" ; then
				{ echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5
echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;}
			    else
				do64bit_ok=yes
				CFLAGS="$CFLAGS -m64 -mcpu=v9"
				LDFLAGS="$LDFLAGS -m64 -mcpu=v9"
				SHLIB_CFLAGS="-fPIC"
			    fi
			else
			    do64bit_ok=yes
			    if test "$do64bitVIS" = "yes" ; then
				CFLAGS="$CFLAGS -xarch=v9a"
			    	LDFLAGS_ARCH="-xarch=v9a"
			    else
				CFLAGS="$CFLAGS -xarch=v9"
			    	LDFLAGS_ARCH="-xarch=v9"
			    fi
			fi
		elif test "$arch" = "amd64 i386" ; then
		    if test "$GCC" = "yes" ; then
			{ echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5
echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
		    else
			do64bit_ok=yes
			CFLAGS="$CFLAGS -xarch=amd64"
			LDFLAGS="$LDFLAGS -xarch=amd64"
		    fi
		else
		    { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5
echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;}
		fi
	    fi

	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		if test "$do64bit_ok" = "yes" ; then
		    # We need to specify -static-libgcc or we need to
		    # add the path to the sparv9 libgcc.
		    SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc"
		    # for finding sparcv9 libgcc, get the regular libgcc
		    # path, remove so name and append 'sparcv9'
		    #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..."
		    #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
		fi
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi














	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
	    # that don't grok the -Bexport option.  Test that it does.
	    hold_ldflags=$LDFLAGS
	    echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5
echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6
	    LDFLAGS="$LDFLAGS -Wl,-Bexport"
	    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
int i;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  found=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

LDFLAGS=$hold_ldflags found=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
	    echo "$as_me:$LINENO: result: $found" >&5
echo "${ECHO_T}$found" >&6
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
	{ echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5
echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;}
    fi

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then

cat >>confdefs.h <<\_ACEOF
#define TCL_CFG_DO64BIT 1
_ACEOF

    fi









































































































































































































    # Step 4: disable dynamic loading if requested via a command-line switch.

    # Check whether --enable-load or --disable-load was given.
if test "${enable_load+set}" = set; then
  enableval="$enable_load"
  tcl_ok=$enableval
else
  tcl_ok=yes
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
8117
8118
		    ;;
		BSD/OS*)
		    ;;
		IRIX*)
		    ;;
		NetBSD-*|FreeBSD-*)
		    ;;
		Rhapsody-*|Darwin-*)
		    ;;
		RISCos-*)
		    ;;
		SCO_SV-3.2*)
		    ;;
		ULTRIX-4.*)
		    ;;
		*)
		    SHLIB_CFLAGS="-fPIC"
		    ;;
	    esac
	fi
    fi

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi

    if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
        LIB_SUFFIX=${SHARED_LIB_SUFFIX}
        MAKE_LIB='${SHLIB_LD} -o $@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
        INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
    else
        LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}

        if test "$RANLIB" = "" ; then
            MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'







|















|


|




|







8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
		    ;;
		BSD/OS*)
		    ;;
		IRIX*)
		    ;;
		NetBSD-*|FreeBSD-*)
		    ;;
		Darwin-*)
		    ;;
		RISCos-*)
		    ;;
		SCO_SV-3.2*)
		    ;;
		ULTRIX-4.*)
		    ;;
		*)
		    SHLIB_CFLAGS="-fPIC"
		    ;;
	    esac
	fi
    fi

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}.a'
    fi

    if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
        LIB_SUFFIX=${SHARED_LIB_SUFFIX}
        MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
        INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
    else
        LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}

        if test "$RANLIB" = "" ; then
            MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
8188
8189
8190
8191
8192
8193
8194

8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216

8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
8240
8241
8242
8243
8244
8245
8246
8247
8248
8249
8250
8251
8252
8253
8254
8255
8256
8257
8258
8259
8260
8261
8262
8263
8264
8265
8266
8267
8268
8269
8270
8271
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288



8289
8290







8291
8292
8293
8294
8295
8296
8297
8298
8299
8300
8301
8302
8303
8304
8305
8306
8307
8308
8309
8310
8311
8312
8313
8314
8315
8316
8317
8318
8319
8320
8321
8322



8323
8324







8325
8326
8327
8328
8329
8330
8331
8332
8333
8334
8335
8336
8337
8338
8339
8340
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374



8375
8376







8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408



8409
8410







8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436








































































































8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473



8474
8475







8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514



8515
8516







8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
if test "${enable_symbols+set}" = set; then
  enableval="$enable_symbols"
  tcl_ok=$enableval
else
  tcl_ok=no
fi;
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.

    if test "$tcl_ok" = "no"; then
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
	DBGX=""
	echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6

cat >>confdefs.h <<\_ACEOF
#define TCL_CFG_OPTIMIZED 1
_ACEOF

    else
	CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
	LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
	DBGX=g
	if test "$tcl_ok" = "yes"; then
	    echo "$as_me:$LINENO: result: yes (standard debugging)" >&5
echo "${ECHO_T}yes (standard debugging)" >&6
	fi
    fi




cat >>confdefs.h <<\_ACEOF
#define TCL_CFG_DEBUG 1
_ACEOF


    if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then

cat >>confdefs.h <<\_ACEOF
#define TCL_MEM_DEBUG 1
_ACEOF

    fi

    if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then

cat >>confdefs.h <<\_ACEOF
#define TCL_COMPILE_DEBUG 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_COMPILE_STATS 1
_ACEOF

    fi

    if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
	if test "$tcl_ok" = "all"; then
	    echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5
echo "${ECHO_T}enabled symbols mem compile debugging" >&6
	else
	    echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5
echo "${ECHO_T}enabled $tcl_ok debugging" >&6
	fi
    fi


TCL_DBGX=${DBGX}

#--------------------------------------------------------------------
#	Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for required early compiler flags" >&5
echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6
    tcl_flags=""

    if test "${tcl_cv_flag__isoc99_source+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
int
main ()
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__isoc99_source=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int
main ()
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__isoc99_source=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__isoc99_source=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _ISOC99_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _ISOC99_SOURCE"
    fi

    if test "${tcl_cv_flag__largefile64_source+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
struct stat64 buf; int i = stat64("/", &buf);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile64_source=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int
main ()
{
struct stat64 buf; int i = stat64("/", &buf);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile64_source=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__largefile64_source=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE64_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
    fi








































































































    if test "x${tcl_flags}" = "x" ; then
	echo "$as_me:$LINENO: result: none" >&5
echo "${ECHO_T}none" >&6
    else
	echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
echo "${ECHO_T}${tcl_flags}" >&6
    fi


    echo "$as_me:$LINENO: checking for 64-bit integer type" >&5
echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6
    if test "${tcl_cv_type_64bit+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	tcl_cv_type_64bit=none
	# See if the compiler knows natively about __int64
	cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
__int64 value = (__int64) 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_type_64bit=__int64
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_type_64bit="long long"
fi
rm -f conftest.$ac_objext conftest.$ac_ext
	# See if we should use long anyway  Note that we substitute in the
	# type that is our current guess for a 64-bit type inside this check
	# program, so it should be modified only carefully...
        cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
switch (0) {
            case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ;
        }
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_type_64bit=${tcl_type_64bit}
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

    if test "${tcl_cv_type_64bit}" = none ; then

cat >>confdefs.h <<\_ACEOF
#define TCL_WIDE_INT_IS_LONG 1
_ACEOF







>



<










<







>














|










|












<
<













<
















|

>
>
>


>
>
>
>
>
>
>
|











<

















|

>
>
>


>
>
>
>
>
>
>
|












|

|















<
















|

>
>
>


>
>
>
>
>
>
>
|











<

















|

>
>
>


>
>
>
>
>
>
>
|












|

|










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


















<
















|

>
>
>


>
>
>
>
>
>
>
|












|




<


















|

>
>
>


>
>
>
>
>
>
>
|











|







8672
8673
8674
8675
8676
8677
8678
8679
8680
8681
8682

8683
8684
8685
8686
8687
8688
8689
8690
8691
8692

8693
8694
8695
8696
8697
8698
8699
8700
8701
8702
8703
8704
8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721
8722
8723
8724
8725
8726
8727
8728
8729
8730
8731
8732
8733
8734
8735
8736
8737
8738


8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750
8751

8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
8778
8779
8780
8781
8782
8783
8784
8785
8786
8787
8788
8789
8790
8791
8792
8793

8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
8823
8824
8825
8826
8827
8828
8829
8830
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
8847
8848
8849
8850
8851
8852
8853
8854
8855

8856
8857
8858
8859
8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880
8881
8882
8883
8884
8885
8886
8887
8888
8889
8890
8891
8892
8893
8894
8895
8896
8897

8898
8899
8900
8901
8902
8903
8904
8905
8906
8907
8908
8909
8910
8911
8912
8913
8914
8915
8916
8917
8918
8919
8920
8921
8922
8923
8924
8925
8926
8927
8928
8929
8930
8931
8932
8933
8934
8935
8936
8937
8938
8939
8940
8941
8942
8943
8944
8945
8946
8947
8948
8949
8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
9075
9076

9077
9078
9079
9080
9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
9093
9094
9095
9096
9097
9098
9099
9100
9101
9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124

9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
9143
9144
9145
9146
9147
9148
9149
9150
9151
9152
9153
9154
9155
9156
9157
9158
9159
9160
9161
9162
9163
9164
9165
9166
9167
9168
9169
9170
9171
9172
9173
9174
9175
9176
if test "${enable_symbols+set}" = set; then
  enableval="$enable_symbols"
  tcl_ok=$enableval
else
  tcl_ok=no
fi;
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
    DBGX=""
    if test "$tcl_ok" = "no"; then
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'

	echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6

cat >>confdefs.h <<\_ACEOF
#define TCL_CFG_OPTIMIZED 1
_ACEOF

    else
	CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
	LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'

	if test "$tcl_ok" = "yes"; then
	    echo "$as_me:$LINENO: result: yes (standard debugging)" >&5
echo "${ECHO_T}yes (standard debugging)" >&6
	fi
    fi


    ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging?

cat >>confdefs.h <<\_ACEOF
#define TCL_CFG_DEBUG 1
_ACEOF


    if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then

cat >>confdefs.h <<\_ACEOF
#define TCL_MEM_DEBUG 1
_ACEOF

    fi

    	if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then

cat >>confdefs.h <<\_ACEOF
#define TCL_COMPILE_DEBUG 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_COMPILE_STATS 1
_ACEOF

	fi

    if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
	if test "$tcl_ok" = "all"; then
	    echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5
echo "${ECHO_T}enabled symbols mem compile debugging" >&6
	else
	    echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5
echo "${ECHO_T}enabled $tcl_ok debugging" >&6
	fi
    fi




#--------------------------------------------------------------------
#	Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for required early compiler flags" >&5
echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6
    tcl_flags=""

    if test "${tcl_cv_flag__isoc99_source+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
int
main ()
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__isoc99_source=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int
main ()
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__isoc99_source=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__isoc99_source=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _ISOC99_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _ISOC99_SOURCE"
    fi

    if test "${tcl_cv_flag__largefile64_source+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
struct stat64 buf; int i = stat64("/", &buf);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile64_source=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int
main ()
{
struct stat64 buf; int i = stat64("/", &buf);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile64_source=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__largefile64_source=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE64_SOURCE 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
    fi

    if test "${tcl_cv_flag__largefile_source64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
char *p = (char *)open64;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile_source64=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#define _LARGEFILE_SOURCE64 1
#include <sys/stat.h>
int
main ()
{
char *p = (char *)open64;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_flag__largefile_source64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_flag__largefile_source64=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define _LARGEFILE_SOURCE64 1
_ACEOF

	tcl_flags="$tcl_flags _LARGEFILE_SOURCE64"
    fi
    if test "x${tcl_flags}" = "x" ; then
	echo "$as_me:$LINENO: result: none" >&5
echo "${ECHO_T}none" >&6
    else
	echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
echo "${ECHO_T}${tcl_flags}" >&6
    fi


    echo "$as_me:$LINENO: checking for 64-bit integer type" >&5
echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6
    if test "${tcl_cv_type_64bit+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	tcl_cv_type_64bit=none
	# See if the compiler knows natively about __int64
	cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
__int64 value = (__int64) 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_type_64bit=__int64
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_type_64bit="long long"
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
	# See if we should use long anyway  Note that we substitute in the
	# type that is our current guess for a 64-bit type inside this check
	# program, so it should be modified only carefully...
        cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
switch (0) {
            case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ;
        }
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_type_64bit=${tcl_type_64bit}
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    if test "${tcl_cv_type_64bit}" = none ; then

cat >>confdefs.h <<\_ACEOF
#define TCL_WIDE_INT_IS_LONG 1
_ACEOF
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576



8577
8578







8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
8603
8604
8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
8617
8618
8619
8620
8621
8622
8623
8624
8625
8626
8627
8628
8629
8630
8631



8632
8633







8634
8635
8636
8637
8638
8639
8640
8641
8642
8643
8644
8645
8646
8647
8648
8649
8650
8651
8652
8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
8678
8679
8680
8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699
8700
8701
8702
8703
8704
8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721




8722
8723
8724
8725

8726
8727
8728
8729
8730



8731
8732
8733
8734
8735
8736
8737
	echo "$as_me:$LINENO: checking for struct dirent64" >&5
echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6
	if test "${tcl_cv_struct_dirent64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/dirent.h>
int
main ()
{
struct dirent64 p;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_struct_dirent64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_struct_dirent64=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

	if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_STRUCT_DIRENT64 1
_ACEOF

	fi
	echo "$as_me:$LINENO: result: ${tcl_cv_struct_dirent64}" >&5
echo "${ECHO_T}${tcl_cv_struct_dirent64}" >&6

	echo "$as_me:$LINENO: checking for struct stat64" >&5
echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6
	if test "${tcl_cv_struct_stat64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
struct stat64 p;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_struct_stat64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_struct_stat64=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

	if test "x${tcl_cv_struct_stat64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_STRUCT_STAT64 1
_ACEOF

	fi
	echo "$as_me:$LINENO: result: ${tcl_cv_struct_stat64}" >&5
echo "${ECHO_T}${tcl_cv_struct_stat64}" >&6

	echo "$as_me:$LINENO: checking for off64_t" >&5
echo $ECHO_N "checking for off64_t... $ECHO_C" >&6
	if test "${tcl_cv_type_off64_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
int
main ()
{
off64_t offset;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_type_off64_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_type_off64_t=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi



for ac_func in open64 lseek64
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<

















|

>
>
>


>
>
>
>
>
>
>
|












|



















<

















|

>
>
>


>
>
>
>
>
>
>
|












|












<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<











<





>
>
>
>




>





>
>
>







9190
9191
9192
9193
9194
9195
9196

9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260

9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
9314
9315
9316
9317













































9318
9319
9320
9321
9322
9323
9324
9325
9326
9327
9328

9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
	echo "$as_me:$LINENO: checking for struct dirent64" >&5
echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6
	if test "${tcl_cv_struct_dirent64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/dirent.h>
int
main ()
{
struct dirent64 p;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_struct_dirent64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_struct_dirent64=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

	if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_STRUCT_DIRENT64 1
_ACEOF

	fi
	echo "$as_me:$LINENO: result: ${tcl_cv_struct_dirent64}" >&5
echo "${ECHO_T}${tcl_cv_struct_dirent64}" >&6

	echo "$as_me:$LINENO: checking for struct stat64" >&5
echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6
	if test "${tcl_cv_struct_stat64+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/stat.h>
int
main ()
{
struct stat64 p;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_struct_stat64=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_struct_stat64=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

	if test "x${tcl_cv_struct_stat64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_STRUCT_STAT64 1
_ACEOF

	fi
	echo "$as_me:$LINENO: result: ${tcl_cv_struct_stat64}" >&5
echo "${ECHO_T}${tcl_cv_struct_stat64}" >&6
















































for ac_func in open64 lseek64
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
8754
8755
8756
8757
8758
8759
8760
8761
8762



8763
8764







8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777

8778
8779
8780
8781
8782
8783
8784
8785
8786
8787
8788






















































8789
8790
8791
8792
8793
8794
8795
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done























































			if test "x${tcl_cv_type_off64_t}" = "xyes" && \
	        test "x${ac_cv_func_lseek64}" = "xyes" && \
	        test "x${ac_cv_func_open64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TYPE_OFF64_T 1







|

>
>
>


>
>
>
>
>
>
>
|












>
|










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
9399
9400
9401
9402
9403
9404
9405
9406
9407
9408
9409
9410
9411
9412
9413
9414
9415
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
9431
9432
9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450
9451
9452
9453
9454
9455
9456
9457
9458
9459
9460
9461
9462
9463
9464
9465
9466
9467
9468
9469
9470
9471
9472
9473
9474
9475
9476
9477
9478
9479
9480
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done

	echo "$as_me:$LINENO: checking for off64_t" >&5
echo $ECHO_N "checking for off64_t... $ECHO_C" >&6
	if test "${tcl_cv_type_off64_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
int
main ()
{
off64_t offset;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_type_off64_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_type_off64_t=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

			if test "x${tcl_cv_type_off64_t}" = "xyes" && \
	        test "x${ac_cv_func_lseek64}" = "xyes" && \
	        test "x${ac_cv_func_open64}" = "xyes" ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TYPE_OFF64_T 1
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
8823
8824
8825
echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5
echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6
if test "${ac_cv_c_bigendian+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  # See if sys/param.h defines the BYTE_ORDER macro.
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/param.h>







<







9496
9497
9498
9499
9500
9501
9502

9503
9504
9505
9506
9507
9508
9509
echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5
echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6
if test "${ac_cv_c_bigendian+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  # See if sys/param.h defines the BYTE_ORDER macro.
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/param.h>
8833
8834
8835
8836
8837
8838
8839
8840
8841



8842
8843







8844
8845
8846
8847
8848
8849
8850
8851
8852
8853
8854
8855
8856
8857
8858
8859

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  # It does; now see whether it defined to BIG_ENDIAN or not.
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/param.h>







|

>
>
>


>
>
>
>
>
>
>
|







<







9517
9518
9519
9520
9521
9522
9523
9524
9525
9526
9527
9528
9529
9530
9531
9532
9533
9534
9535
9536
9537
9538
9539
9540
9541
9542
9543
9544
9545

9546
9547
9548
9549
9550
9551
9552

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  # It does; now see whether it defined to BIG_ENDIAN or not.
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/param.h>
8867
8868
8869
8870
8871
8872
8873
8874
8875



8876
8877







8878
8879
8880
8881
8882
8883
8884
8885
8886
8887
8888
8889
8890
8891
8892
8893
8894
8895
8896
8897
8898
8899
8900
8901
8902
8903
8904
8905
8906
8907
8908

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_c_bigendian=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_c_bigendian=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

# It does not; compile a test program.
if test "$cross_compiling" = yes; then
  # try to guess the endianness by grepping values into an object file
  ac_cv_c_bigendian=unknown
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };







|

>
>
>


>
>
>
>
>
>
>
|












|









<







9560
9561
9562
9563
9564
9565
9566
9567
9568
9569
9570
9571
9572
9573
9574
9575
9576
9577
9578
9579
9580
9581
9582
9583
9584
9585
9586
9587
9588
9589
9590
9591
9592
9593
9594
9595
9596
9597
9598
9599
9600
9601
9602
9603

9604
9605
9606
9607
9608
9609
9610

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_c_bigendian=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_c_bigendian=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

# It does not; compile a test program.
if test "$cross_compiling" = yes; then
  # try to guess the endianness by grepping values into an object file
  ac_cv_c_bigendian=unknown
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };
8916
8917
8918
8919
8920
8921
8922
8923
8924



8925
8926







8927
8928
8929
8930
8931
8932
8933
8934
 _ascii (); _ebcdic ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then
  ac_cv_c_bigendian=yes







|

>
>
>


>
>
>
>
>
>
>
|







9618
9619
9620
9621
9622
9623
9624
9625
9626
9627
9628
9629
9630
9631
9632
9633
9634
9635
9636
9637
9638
9639
9640
9641
9642
9643
9644
9645
9646
 _ascii (); _ebcdic ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then
  ac_cv_c_bigendian=yes
8942
8943
8944
8945
8946
8947
8948
8949
8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
  fi
fi
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext conftest.$ac_ext
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
int
main ()







|


<







9654
9655
9656
9657
9658
9659
9660
9661
9662
9663

9664
9665
9666
9667
9668
9669
9670
  fi
fi
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
int
main ()
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_c_bigendian=yes
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5
echo "${ECHO_T}$ac_cv_c_bigendian" >&6
case $ac_cv_c_bigendian in
  yes)

cat >>confdefs.h <<\_ACEOF







|


|







9695
9696
9697
9698
9699
9700
9701
9702
9703
9704
9705
9706
9707
9708
9709
9710
9711
9712
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_c_bigendian=yes
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5
echo "${ECHO_T}$ac_cv_c_bigendian" >&6
case $ac_cv_c_bigendian in
  yes)

cat >>confdefs.h <<\_ACEOF
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037




9038
9039
9040
9041

9042
9043
9044
9045
9046



9047
9048
9049
9050
9051
9052
9053
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







9736
9737
9738
9739
9740
9741
9742

9743
9744
9745
9746
9747
9748
9749
9750
9751
9752
9753
9754
9755
9756
9757
9758
9759
9760
9761
9762
9763
9764
9765
9766
9767
9768
9769
9770
9771
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9070
9071
9072
9073
9074
9075
9076
9077
9078



9079
9080







9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
9093

9094
9095
9096
9097
9098
9099
9100
9101
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












>
|







9788
9789
9790
9791
9792
9793
9794
9795
9796
9797
9798
9799
9800
9801
9802
9803
9804
9805
9806
9807
9808
9809
9810
9811
9812
9813
9814
9815
9816
9817
9818
9819
9820
9821
9822
9823
9824
9825
9826
9827
9828
9829
9830
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
9110
9111
9112
9113
9114
9115
9116




9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131




9132
9133
9134
9135

9136
9137
9138
9139
9140



9141
9142
9143
9144
9145
9146
9147
done

# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?







for ac_func in opendir strstr
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







>
>
>
>
|








<





>
>
>
>




>





>
>
>







9839
9840
9841
9842
9843
9844
9845
9846
9847
9848
9849
9850
9851
9852
9853
9854
9855
9856
9857
9858

9859
9860
9861
9862
9863
9864
9865
9866
9867
9868
9869
9870
9871
9872
9873
9874
9875
9876
9877
9878
9879
9880
9881
9882
9883
9884
9885
9886
9887
done

# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?







for ac_func in opendir strtol strtoll strtoull tmpnam waitpid
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9164
9165
9166
9167
9168
9169
9170
9171
9172



9173
9174







9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187

9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306




9307
9308
9309
9310

9311
9312
9313
9314
9315



9316
9317
9318
9319
9320
9321
9322
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

else
  LIBOBJS="$LIBOBJS $ac_func.$ac_objext"
fi
done








for ac_func in strtol strtoll strtoull tmpnam waitpid
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char $ac_func ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
choke me
#else
char (*f) () = $ac_func;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

else
  LIBOBJS="$LIBOBJS $ac_func.$ac_objext"
fi
done


echo "$as_me:$LINENO: checking for strerror" >&5
echo $ECHO_N "checking for strerror... $ECHO_C" >&6
if test "${ac_cv_func_strerror+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strerror (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|









|
<
<
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<

<
<










<





>
>
>
>




>





>
>
>







9904
9905
9906
9907
9908
9909
9910
9911
9912
9913
9914
9915
9916
9917
9918
9919
9920
9921
9922
9923
9924
9925
9926
9927
9928
9929
9930
9931
9932
9933
9934
9935
9936
9937
9938
9939
9940
9941
9942
9943
9944
9945
9946
9947
9948
9949


9950
9951
9952




































9953











9954
























9955










9956


9957
9958
9959
9960
9961
9962
9963
9964
9965
9966

9967
9968
9969
9970
9971
9972
9973
9974
9975
9976
9977
9978
9979
9980
9981
9982
9983
9984
9985
9986
9987
9988
9989
9990
9991
9992
9993
9994
9995
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

else
  case $LIBOBJS in


    "$ac_func.$ac_objext"   | \
  *" $ac_func.$ac_objext"   | \
    "$ac_func.$ac_objext "* | \




































  *" $ac_func.$ac_objext "* ) ;;











  *) LIBOBJS="$LIBOBJS $ac_func.$ac_objext" ;;
























esac













fi
done


echo "$as_me:$LINENO: checking for strerror" >&5
echo $ECHO_N "checking for strerror... $ECHO_C" >&6
if test "${ac_cv_func_strerror+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define strerror to an innocuous variant, in case <limits.h> declares strerror.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define strerror innocuous_strerror

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strerror (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef strerror

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9339
9340
9341
9342
9343
9344
9345
9346
9347



9348
9349







9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362

9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388




9389
9390
9391
9392

9393
9394
9395
9396
9397



9398
9399
9400
9401
9402
9403
9404
return f != strerror;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strerror=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strerror=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strerror" >&5
echo "${ECHO_T}$ac_cv_func_strerror" >&6
if test $ac_cv_func_strerror = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_STRERROR 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for getwd" >&5
echo $ECHO_N "checking for getwd... $ECHO_C" >&6
if test "${ac_cv_func_getwd+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char getwd (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|



















<





>
>
>
>




>





>
>
>







10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
10022
10023
10024
10025
10026
10027
10028
10029
10030
10031
10032
10033
10034
10035
10036
10037
10038
10039
10040
10041
10042
10043
10044
10045
10046
10047
10048
10049
10050
10051
10052
10053
10054
10055
10056
10057
10058
10059
10060
10061
10062
10063
10064
10065
10066

10067
10068
10069
10070
10071
10072
10073
10074
10075
10076
10077
10078
10079
10080
10081
10082
10083
10084
10085
10086
10087
10088
10089
10090
10091
10092
10093
10094
10095
return f != strerror;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strerror=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strerror=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strerror" >&5
echo "${ECHO_T}$ac_cv_func_strerror" >&6
if test $ac_cv_func_strerror = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_STRERROR 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for getwd" >&5
echo $ECHO_N "checking for getwd... $ECHO_C" >&6
if test "${ac_cv_func_getwd+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define getwd to an innocuous variant, in case <limits.h> declares getwd.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define getwd innocuous_getwd

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char getwd (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef getwd

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9421
9422
9423
9424
9425
9426
9427
9428
9429



9430
9431







9432
9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444

9445
9446
9447
9448
9449
9450
9451
9452
9453
9454
9455
9456
9457
9458
9459
9460
9461
9462
9463
9464
9465
9466
9467
9468
9469
9470




9471
9472
9473
9474

9475
9476
9477
9478
9479



9480
9481
9482
9483
9484
9485
9486
return f != getwd;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_getwd=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_getwd=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_getwd" >&5
echo "${ECHO_T}$ac_cv_func_getwd" >&6
if test $ac_cv_func_getwd = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_GETWD 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for wait3" >&5
echo $ECHO_N "checking for wait3... $ECHO_C" >&6
if test "${ac_cv_func_wait3+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char wait3 (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|



















<





>
>
>
>




>





>
>
>







10112
10113
10114
10115
10116
10117
10118
10119
10120
10121
10122
10123
10124
10125
10126
10127
10128
10129
10130
10131
10132
10133
10134
10135
10136
10137
10138
10139
10140
10141
10142
10143
10144
10145
10146
10147
10148
10149
10150
10151
10152
10153
10154
10155
10156
10157
10158
10159
10160
10161
10162
10163
10164
10165
10166

10167
10168
10169
10170
10171
10172
10173
10174
10175
10176
10177
10178
10179
10180
10181
10182
10183
10184
10185
10186
10187
10188
10189
10190
10191
10192
10193
10194
10195
return f != getwd;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_getwd=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_getwd=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_getwd" >&5
echo "${ECHO_T}$ac_cv_func_getwd" >&6
if test $ac_cv_func_getwd = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_GETWD 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for wait3" >&5
echo $ECHO_N "checking for wait3... $ECHO_C" >&6
if test "${ac_cv_func_wait3+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define wait3 to an innocuous variant, in case <limits.h> declares wait3.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define wait3 innocuous_wait3

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char wait3 (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef wait3

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9503
9504
9505
9506
9507
9508
9509
9510
9511



9512
9513







9514
9515
9516
9517
9518
9519
9520
9521
9522
9523
9524
9525
9526

9527
9528
9529
9530
9531
9532
9533
9534
9535
9536
9537
9538
9539
9540
9541
9542
9543
9544
9545
9546
9547
9548
9549
9550
9551
9552




9553
9554
9555
9556

9557
9558
9559
9560
9561



9562
9563
9564
9565
9566
9567
9568
return f != wait3;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_wait3=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_wait3=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_wait3" >&5
echo "${ECHO_T}$ac_cv_func_wait3" >&6
if test $ac_cv_func_wait3 = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_WAIT3 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for uname" >&5
echo $ECHO_N "checking for uname... $ECHO_C" >&6
if test "${ac_cv_func_uname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char uname (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|



















<





>
>
>
>




>





>
>
>







10212
10213
10214
10215
10216
10217
10218
10219
10220
10221
10222
10223
10224
10225
10226
10227
10228
10229
10230
10231
10232
10233
10234
10235
10236
10237
10238
10239
10240
10241
10242
10243
10244
10245
10246
10247
10248
10249
10250
10251
10252
10253
10254
10255
10256
10257
10258
10259
10260
10261
10262
10263
10264
10265
10266

10267
10268
10269
10270
10271
10272
10273
10274
10275
10276
10277
10278
10279
10280
10281
10282
10283
10284
10285
10286
10287
10288
10289
10290
10291
10292
10293
10294
10295
return f != wait3;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_wait3=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_wait3=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_wait3" >&5
echo "${ECHO_T}$ac_cv_func_wait3" >&6
if test $ac_cv_func_wait3 = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_WAIT3 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for uname" >&5
echo $ECHO_N "checking for uname... $ECHO_C" >&6
if test "${ac_cv_func_uname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define uname to an innocuous variant, in case <limits.h> declares uname.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define uname innocuous_uname

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char uname (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef uname

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9585
9586
9587
9588
9589
9590
9591
9592
9593



9594
9595







9596
9597
9598
9599
9600
9601
9602
9603
9604
9605
9606
9607
9608

9609
9610
9611
9612
9613
9614
9615
9616
9617
9618
9619
9620
9621
9622
9623
9624
9625
9626
9627
9628
9629
9630
9631
9632
9633
9634




9635
9636
9637
9638

9639
9640
9641
9642
9643



9644
9645
9646
9647
9648
9649
9650
return f != uname;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_uname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_uname=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_uname" >&5
echo "${ECHO_T}$ac_cv_func_uname" >&6
if test $ac_cv_func_uname = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_UNAME 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for realpath" >&5
echo $ECHO_N "checking for realpath... $ECHO_C" >&6
if test "${ac_cv_func_realpath+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char realpath (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|



















<





>
>
>
>




>





>
>
>







10312
10313
10314
10315
10316
10317
10318
10319
10320
10321
10322
10323
10324
10325
10326
10327
10328
10329
10330
10331
10332
10333
10334
10335
10336
10337
10338
10339
10340
10341
10342
10343
10344
10345
10346
10347
10348
10349
10350
10351
10352
10353
10354
10355
10356
10357
10358
10359
10360
10361
10362
10363
10364
10365
10366

10367
10368
10369
10370
10371
10372
10373
10374
10375
10376
10377
10378
10379
10380
10381
10382
10383
10384
10385
10386
10387
10388
10389
10390
10391
10392
10393
10394
10395
return f != uname;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_uname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_uname=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_uname" >&5
echo "${ECHO_T}$ac_cv_func_uname" >&6
if test $ac_cv_func_uname = yes; then
  :
else

cat >>confdefs.h <<\_ACEOF
#define NO_UNAME 1
_ACEOF

fi

echo "$as_me:$LINENO: checking for realpath" >&5
echo $ECHO_N "checking for realpath... $ECHO_C" >&6
if test "${ac_cv_func_realpath+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define realpath to an innocuous variant, in case <limits.h> declares realpath.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define realpath innocuous_realpath

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char realpath (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef realpath

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
9667
9668
9669
9670
9671
9672
9673
9674
9675



9676
9677







9678
9679
9680
9681
9682
9683
9684
9685
9686
9687
9688
9689
9690

9691
9692
9693
9694
9695
9696
9697
9698
return f != realpath;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_realpath=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_realpath=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5
echo "${ECHO_T}$ac_cv_func_realpath" >&6
if test $ac_cv_func_realpath = yes; then
  :
else








|

>
>
>


>
>
>
>
>
>
>
|












>
|







10412
10413
10414
10415
10416
10417
10418
10419
10420
10421
10422
10423
10424
10425
10426
10427
10428
10429
10430
10431
10432
10433
10434
10435
10436
10437
10438
10439
10440
10441
10442
10443
10444
10445
10446
10447
10448
10449
10450
10451
10452
10453
10454
return f != realpath;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_realpath=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_realpath=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5
echo "${ECHO_T}$ac_cv_func_realpath" >&6
if test $ac_cv_func_realpath = yes; then
  :
else

9723
9724
9725
9726
9727
9728
9729
9730
9731
9732
9733
9734
9735
9736
9737
9738
9739
9740
9741
9742



9743
9744







9745
9746
9747
9748
9749
9750
9751
9752
9753
9754
9755
9756
9757
9758
9759
9760
9761
9762
9763
9764
9765
9766
9767
9768
9769
9770
9771
9772
9773
9774
9775
9776
9777
9778
9779
9780
9781
9782
9783

9784
9785
9786
9787
9788
9789
9790
9791
9792
9793
9794
9795
9796
9797
9798
9799
9800
9801
9802
9803
9804
9805
9806
9807
9808
9809
9810
9811
9812
9813
9814
9815
9816

9817
9818
9819
9820


9821
9822


9823
9824


9825
9826
9827
9828
9829
9830
9831
9832
9833
9834
9835
9836
9837
9838
9839
9840
9841
9842
9843
9844
9845
9846
9847
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|










|







10479
10480
10481
10482
10483
10484
10485

10486
10487
10488
10489
10490
10491
10492
10493
10494
10495
10496
10497
10498
10499
10500
10501
10502
10503
10504
10505
10506
10507
10508
10509
10510
10511
10512
10513
10514
10515
10516
10517
10518
10519
10520
10521
10522
10523
10524
10525
10526
10527
10528
10529
10530

10531
10532
10533
10534
10535
10536
10537
10538
10539
10540
10541
10542
10543
10544
10545
10546
10547
10548
10549
10550
10551
10552
10553
10554
10555
10556
10557
10558
10559
10560
10561
10562
10563
10564
10565
10566
10567
10568
10569
10570
10571
10572
10573








10574
10575
10576
10577
10578
10579
10580
10581
10582
10583
10584
10585
10586
10587
10588
10589
10590
10591
10592
10593
10594
10595
10596
10597
10598
10599
10600
10601
10602
10603
10604
10605
10606
10607
10608
10609
10610
10611
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=\$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
9858
9859
9860
9861
9862
9863
9864
9865
9866
9867
9868
9869
9870
9871
9872
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

    if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termios.h>







<







10622
10623
10624
10625
10626
10627
10628

10629
10630
10631
10632
10633
10634
10635
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

    if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termios.h>
9897
9898
9899
9900
9901
9902
9903
9904
9905
9906
9907
9908
9909
9910
9911
9912
9913
9914
9915
9916
9917
9918
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termio.h>







|






<







10660
10661
10662
10663
10664
10665
10666
10667
10668
10669
10670
10671
10672
10673

10674
10675
10676
10677
10678
10679
10680
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termio.h>
9942
9943
9944
9945
9946
9947
9948
9949
9950
9951
9952
9953
9954
9955
9956
9957
9958
9959
9960
9961
9962
9963
9964
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <sgtty.h>







|







<







10704
10705
10706
10707
10708
10709
10710
10711
10712
10713
10714
10715
10716
10717
10718

10719
10720
10721
10722
10723
10724
10725
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <sgtty.h>
9989
9990
9991
9992
9993
9994
9995
9996
9997
9998
9999
10000
10001
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termios.h>







|







<







10750
10751
10752
10753
10754
10755
10756
10757
10758
10759
10760
10761
10762
10763
10764

10765
10766
10767
10768
10769
10770
10771
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termios.h>
10038
10039
10040
10041
10042
10043
10044
10045
10046
10047
10048
10049
10050
10051
10052
10053
10054
10055
10056
10057
10058
10059
10060
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termio.h>







|







<







10798
10799
10800
10801
10802
10803
10804
10805
10806
10807
10808
10809
10810
10811
10812

10813
10814
10815
10816
10817
10818
10819
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <termio.h>
10086
10087
10088
10089
10090
10091
10092
10093
10094
10095
10096
10097
10098
10099
10100
10101
10102
10103
10104
10105
10106
10107
10108
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=none
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <sgtty.h>







|







<







10845
10846
10847
10848
10849
10850
10851
10852
10853
10854
10855
10856
10857
10858
10859

10860
10861
10862
10863
10864
10865
10866
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=none
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <sgtty.h>
10135
10136
10137
10138
10139
10140
10141
10142
10143
10144
10145
10146
10147
10148
10149
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=none
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
fi

    case $tcl_cv_api_serial in
	termios)
cat >>confdefs.h <<\_ACEOF







|







10893
10894
10895
10896
10897
10898
10899
10900
10901
10902
10903
10904
10905
10906
10907
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_api_serial=none
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
    fi
fi

    case $tcl_cv_api_serial in
	termios)
cat >>confdefs.h <<\_ACEOF
10177
10178
10179
10180
10181
10182
10183
10184
10185
10186
10187
10188
10189
10190
10191
10192
10193
10194
10195
10196
10197
10198
10199
10200
10201
10202



10203
10204







10205
10206
10207
10208
10209
10210
10211
10212
10213
10214
10215
10216
10217
10218
10219
10220
10221
10222
10223
10224
10225
10226
10227
10228
10229
10230
10231
10232
10233
10234
10235
10236
10237
10238

echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5
echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6
if test "${tcl_cv_type_fd_set+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
int
main ()
{
fd_set readMask, writeMask;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_type_fd_set=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_type_fd_set=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5
echo "${ECHO_T}$tcl_cv_type_fd_set" >&6
tk_ok=$tcl_cv_type_fd_set
if test $tcl_cv_type_fd_set = no; then
    echo "$as_me:$LINENO: checking for fd_mask in sys/select" >&5
echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6
    if test "${tcl_cv_grep_fd_mask+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/select.h>








<
















|

>
>
>


>
>
>
>
>
>
>
|












|












<







10935
10936
10937
10938
10939
10940
10941

10942
10943
10944
10945
10946
10947
10948
10949
10950
10951
10952
10953
10954
10955
10956
10957
10958
10959
10960
10961
10962
10963
10964
10965
10966
10967
10968
10969
10970
10971
10972
10973
10974
10975
10976
10977
10978
10979
10980
10981
10982
10983
10984
10985
10986
10987
10988
10989
10990
10991
10992
10993
10994
10995
10996
10997

10998
10999
11000
11001
11002
11003
11004

echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5
echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6
if test "${tcl_cv_type_fd_set+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
int
main ()
{
fd_set readMask, writeMask;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_type_fd_set=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_type_fd_set=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5
echo "${ECHO_T}$tcl_cv_type_fd_set" >&6
tk_ok=$tcl_cv_type_fd_set
if test $tcl_cv_type_fd_set = no; then
    echo "$as_me:$LINENO: checking for fd_mask in sys/select" >&5
echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6
    if test "${tcl_cv_grep_fd_mask+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/select.h>

10272
10273
10274
10275
10276
10277
10278
10279
10280
10281
10282
10283
10284
10285
10286
10287
10288
10289
10290
10291
10292
10293
10294
10295
10296
10297
10298
10299



10300
10301







10302
10303
10304
10305
10306
10307
10308
10309
10310
10311
10312
10313
10314
10315
10316
10317
10318
10319
10320
10321
10322

echo "$as_me:$LINENO: checking whether struct tm is in sys/time.h or time.h" >&5
echo $ECHO_N "checking whether struct tm is in sys/time.h or time.h... $ECHO_C" >&6
if test "${ac_cv_struct_tm+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <time.h>

int
main ()
{
struct tm *tp; tp->tm_sec;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_struct_tm=time.h
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_struct_tm=sys/time.h
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_struct_tm" >&5
echo "${ECHO_T}$ac_cv_struct_tm" >&6
if test $ac_cv_struct_tm = sys/time.h; then

cat >>confdefs.h <<\_ACEOF
#define TM_IN_SYS_TIME 1







<


















|

>
>
>


>
>
>
>
>
>
>
|












|







11038
11039
11040
11041
11042
11043
11044

11045
11046
11047
11048
11049
11050
11051
11052
11053
11054
11055
11056
11057
11058
11059
11060
11061
11062
11063
11064
11065
11066
11067
11068
11069
11070
11071
11072
11073
11074
11075
11076
11077
11078
11079
11080
11081
11082
11083
11084
11085
11086
11087
11088
11089
11090
11091
11092
11093
11094
11095
11096
11097

echo "$as_me:$LINENO: checking whether struct tm is in sys/time.h or time.h" >&5
echo $ECHO_N "checking whether struct tm is in sys/time.h or time.h... $ECHO_C" >&6
if test "${ac_cv_struct_tm+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <time.h>

int
main ()
{
struct tm *tp; tp->tm_sec;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_struct_tm=time.h
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_struct_tm=sys/time.h
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_struct_tm" >&5
echo "${ECHO_T}$ac_cv_struct_tm" >&6
if test $ac_cv_struct_tm = sys/time.h; then

cat >>confdefs.h <<\_ACEOF
#define TM_IN_SYS_TIME 1
10338
10339
10340
10341
10342
10343
10344
10345
10346
10347
10348
10349
10350
10351
10352
10353
10354
10355
10356
10357



10358
10359







10360
10361
10362
10363
10364
10365
10366
10367
10368
10369
10370
10371
10372
10373
10374
10375
10376
10377
10378
10379
10380
10381
10382
10383
10384
10385
10386
10387
10388
10389
10390
10391
10392
10393
10394
10395
10396
10397
10398

10399
10400
10401
10402
10403
10404
10405
10406
10407
10408
10409
10410
10411
10412
10413
10414
10415
10416
10417
10418
10419
10420
10421
10422
10423
10424
10425
10426
10427
10428
10429
10430
10431

10432
10433
10434
10435


10436
10437


10438
10439


10440
10441
10442
10443
10444
10445
10446
10447
10448
10449
10450
10451
10452
10453
10454
10455
10456
10457
10458
10459
10460
10461
10462
10463
10464
10465
10466
10467
10468
10469
10470
10471
10472
10473
10474
10475
10476
10477
10478
10479
10480
10481
10482
10483
10484
10485
10486
10487
10488
10489
10490
10491
10492
10493
10494
10495
10496
10497
10498



10499
10500







10501
10502
10503
10504
10505
10506
10507
10508
10509
10510
10511
10512
10513
10514
10515
10516
10517
10518
10519
10520
10521
10522
10523
10524
10525
10526
10527
10528
10529
10530
10531
10532
10533
10534
10535
10536
10537
10538
10539
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF

fi

done

    echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5
echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6
if test "${ac_cv_header_time+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/time.h>
#include <time.h>

int
main ()
{
if ((struct tm *) 0)
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_header_time=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_header_time=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5
echo "${ECHO_T}$ac_cv_header_time" >&6
if test $ac_cv_header_time = yes; then

cat >>confdefs.h <<\_ACEOF
#define TIME_WITH_SYS_TIME 1
_ACEOF

fi

    echo "$as_me:$LINENO: checking for struct tm.tm_zone" >&5
echo $ECHO_N "checking for struct tm.tm_zone... $ECHO_C" >&6
if test "${ac_cv_member_struct_tm_tm_zone+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <$ac_cv_struct_tm>







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|










|




















<




















|

>
>
>


>
>
>
>
>
>
>
|












|

















<







11113
11114
11115
11116
11117
11118
11119

11120
11121
11122
11123
11124
11125
11126
11127
11128
11129
11130
11131
11132
11133
11134
11135
11136
11137
11138
11139
11140
11141
11142
11143
11144
11145
11146
11147
11148
11149
11150
11151
11152
11153
11154
11155
11156
11157
11158
11159
11160
11161
11162
11163
11164

11165
11166
11167
11168
11169
11170
11171
11172
11173
11174
11175
11176
11177
11178
11179
11180
11181
11182
11183
11184
11185
11186
11187
11188
11189
11190
11191
11192
11193
11194
11195
11196
11197
11198
11199
11200
11201
11202
11203
11204
11205
11206
11207








11208
11209
11210
11211
11212
11213
11214
11215
11216
11217
11218
11219
11220
11221
11222
11223
11224
11225
11226
11227
11228
11229
11230
11231
11232
11233
11234
11235
11236
11237
11238
11239
11240
11241
11242
11243
11244
11245
11246
11247
11248
11249
11250
11251
11252
11253
11254
11255
11256
11257
11258

11259
11260
11261
11262
11263
11264
11265
11266
11267
11268
11269
11270
11271
11272
11273
11274
11275
11276
11277
11278
11279
11280
11281
11282
11283
11284
11285
11286
11287
11288
11289
11290
11291
11292
11293
11294
11295
11296
11297
11298
11299
11300
11301
11302
11303
11304
11305
11306
11307
11308
11309
11310
11311
11312
11313
11314
11315
11316
11317
11318
11319
11320
11321
11322
11323

11324
11325
11326
11327
11328
11329
11330
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=\$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF

fi

done

    echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5
echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6
if test "${ac_cv_header_time+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/time.h>
#include <time.h>

int
main ()
{
if ((struct tm *) 0)
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_header_time=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_header_time=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5
echo "${ECHO_T}$ac_cv_header_time" >&6
if test $ac_cv_header_time = yes; then

cat >>confdefs.h <<\_ACEOF
#define TIME_WITH_SYS_TIME 1
_ACEOF

fi

    echo "$as_me:$LINENO: checking for struct tm.tm_zone" >&5
echo $ECHO_N "checking for struct tm.tm_zone... $ECHO_C" >&6
if test "${ac_cv_member_struct_tm_tm_zone+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <$ac_cv_struct_tm>
10547
10548
10549
10550
10551
10552
10553
10554
10555



10556
10557







10558
10559
10560
10561
10562
10563
10564
10565
10566
10567
10568
10569
10570
10571
10572
10573
10574
10575
10576
10577
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_tm_tm_zone=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <$ac_cv_struct_tm>







|

>
>
>


>
>
>
>
>
>
>
|











<







11338
11339
11340
11341
11342
11343
11344
11345
11346
11347
11348
11349
11350
11351
11352
11353
11354
11355
11356
11357
11358
11359
11360
11361
11362
11363
11364
11365
11366
11367
11368
11369
11370

11371
11372
11373
11374
11375
11376
11377
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_tm_tm_zone=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <$ac_cv_struct_tm>
10585
10586
10587
10588
10589
10590
10591
10592
10593



10594
10595







10596
10597
10598
10599
10600
10601
10602
10603
10604
10605
10606
10607
10608
10609
10610
10611
10612
10613
10614
10615
10616
10617
10618
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_tm_tm_zone=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_member_struct_tm_tm_zone=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_member_struct_tm_tm_zone" >&5
echo "${ECHO_T}$ac_cv_member_struct_tm_tm_zone" >&6
if test $ac_cv_member_struct_tm_tm_zone = yes; then

cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_TM_TM_ZONE 1







|

>
>
>


>
>
>
>
>
>
>
|












|

|







11385
11386
11387
11388
11389
11390
11391
11392
11393
11394
11395
11396
11397
11398
11399
11400
11401
11402
11403
11404
11405
11406
11407
11408
11409
11410
11411
11412
11413
11414
11415
11416
11417
11418
11419
11420
11421
11422
11423
11424
11425
11426
11427
11428
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_tm_tm_zone=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_member_struct_tm_tm_zone=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_member_struct_tm_tm_zone" >&5
echo "${ECHO_T}$ac_cv_member_struct_tm_tm_zone" >&6
if test $ac_cv_member_struct_tm_tm_zone = yes; then

cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_TM_TM_ZONE 1
10630
10631
10632
10633
10634
10635
10636
10637
10638
10639
10640
10641
10642
10643
10644
10645
10646
10647
10648
10649
10650
10651
10652
10653
10654
10655
10656
10657
10658
10659



10660
10661







10662
10663
10664
10665
10666
10667
10668
10669
10670
10671
10672
10673
10674

10675
10676
10677
10678
10679
10680
10681
10682
else
  echo "$as_me:$LINENO: checking for tzname" >&5
echo $ECHO_N "checking for tzname... $ECHO_C" >&6
if test "${ac_cv_var_tzname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
#endif

int
main ()
{
atoi(*tzname);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_var_tzname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_var_tzname=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_var_tzname" >&5
echo "${ECHO_T}$ac_cv_var_tzname" >&6
  if test $ac_cv_var_tzname = yes; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TZNAME 1







<




















|

>
>
>


>
>
>
>
>
>
>
|












>
|







11440
11441
11442
11443
11444
11445
11446

11447
11448
11449
11450
11451
11452
11453
11454
11455
11456
11457
11458
11459
11460
11461
11462
11463
11464
11465
11466
11467
11468
11469
11470
11471
11472
11473
11474
11475
11476
11477
11478
11479
11480
11481
11482
11483
11484
11485
11486
11487
11488
11489
11490
11491
11492
11493
11494
11495
11496
11497
11498
11499
11500
11501
11502
else
  echo "$as_me:$LINENO: checking for tzname" >&5
echo $ECHO_N "checking for tzname... $ECHO_C" >&6
if test "${ac_cv_var_tzname+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
#endif

int
main ()
{
atoi(*tzname);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_var_tzname=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_var_tzname=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_var_tzname" >&5
echo "${ECHO_T}$ac_cv_var_tzname" >&6
  if test $ac_cv_var_tzname = yes; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TZNAME 1
10694
10695
10696
10697
10698
10699
10700
10701
10702
10703
10704
10705
10706




10707
10708
10709
10710

10711
10712
10713
10714
10715



10716
10717
10718
10719
10720
10721
10722
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







11514
11515
11516
11517
11518
11519
11520

11521
11522
11523
11524
11525
11526
11527
11528
11529
11530
11531
11532
11533
11534
11535
11536
11537
11538
11539
11540
11541
11542
11543
11544
11545
11546
11547
11548
11549
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
10739
10740
10741
10742
10743
10744
10745
10746
10747



10748
10749







10750
10751
10752
10753
10754
10755
10756
10757
10758
10759
10760
10761
10762

10763
10764
10765
10766
10767
10768
10769
10770
10771
10772
10773
10774
10775
10776
10777
10778
10779
10780
10781
10782
10783
10784
10785
10786
10787
10788
10789
10790
10791
10792
10793
10794
10795
10796
10797
10798
10799
10800



10801
10802







10803
10804
10805
10806
10807
10808
10809
10810
10811
10812
10813
10814
10815
10816
10817
10818
10819
10820
10821
10822
10823
10824
10825
10826
10827
10828
10829
10830
10831
10832
10833
10834
10835
10836
10837
10838
10839
10840
10841
10842
10843
10844
10845
10846
10847
10848
10849
10850
10851
10852
10853



10854
10855







10856
10857
10858
10859
10860
10861
10862
10863
10864
10865
10866
10867
10868
10869
10870
10871
10872
10873
10874
10875
10876
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done


    echo "$as_me:$LINENO: checking tm_tzadj in struct tm" >&5
echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6
    if test "${tcl_cv_member_tm_tzadj+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
struct tm tm; tm.tm_tzadj;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_member_tm_tzadj=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_member_tm_tzadj=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

    echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5
echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6
    if test $tcl_cv_member_tm_tzadj = yes ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TM_TZADJ 1
_ACEOF

    fi

    echo "$as_me:$LINENO: checking tm_gmtoff in struct tm" >&5
echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6
    if test "${tcl_cv_member_tm_gmtoff+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
struct tm tm; tm.tm_gmtoff;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_member_tm_gmtoff=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_member_tm_gmtoff=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

    echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5
echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6
    if test $tcl_cv_member_tm_gmtoff = yes ; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












>
|


















<
















|

>
>
>


>
>
>
>
>
>
>
|












|


















<
















|

>
>
>


>
>
>
>
>
>
>
|












|







11566
11567
11568
11569
11570
11571
11572
11573
11574
11575
11576
11577
11578
11579
11580
11581
11582
11583
11584
11585
11586
11587
11588
11589
11590
11591
11592
11593
11594
11595
11596
11597
11598
11599
11600
11601
11602
11603
11604
11605
11606
11607
11608
11609
11610
11611
11612
11613
11614
11615
11616
11617
11618
11619

11620
11621
11622
11623
11624
11625
11626
11627
11628
11629
11630
11631
11632
11633
11634
11635
11636
11637
11638
11639
11640
11641
11642
11643
11644
11645
11646
11647
11648
11649
11650
11651
11652
11653
11654
11655
11656
11657
11658
11659
11660
11661
11662
11663
11664
11665
11666
11667
11668
11669
11670
11671
11672
11673
11674
11675
11676
11677
11678
11679
11680
11681

11682
11683
11684
11685
11686
11687
11688
11689
11690
11691
11692
11693
11694
11695
11696
11697
11698
11699
11700
11701
11702
11703
11704
11705
11706
11707
11708
11709
11710
11711
11712
11713
11714
11715
11716
11717
11718
11719
11720
11721
11722
11723
11724
11725
11726
11727
11728
11729
11730
11731
11732
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done


    echo "$as_me:$LINENO: checking tm_tzadj in struct tm" >&5
echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6
    if test "${tcl_cv_member_tm_tzadj+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
struct tm tm; tm.tm_tzadj;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_member_tm_tzadj=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_member_tm_tzadj=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5
echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6
    if test $tcl_cv_member_tm_tzadj = yes ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TM_TZADJ 1
_ACEOF

    fi

    echo "$as_me:$LINENO: checking tm_gmtoff in struct tm" >&5
echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6
    if test "${tcl_cv_member_tm_gmtoff+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
struct tm tm; tm.tm_gmtoff;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_member_tm_gmtoff=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_member_tm_gmtoff=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5
echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6
    if test $tcl_cv_member_tm_gmtoff = yes ; then

cat >>confdefs.h <<\_ACEOF
10885
10886
10887
10888
10889
10890
10891
10892
10893
10894
10895
10896
10897
10898
10899
10900
10901
10902
10903
10904
10905
10906
10907
10908
10909
10910
10911
10912



10913
10914







10915
10916
10917
10918
10919
10920
10921
10922
10923
10924
10925
10926
10927
10928
10929
10930
10931
10932
10933
10934
10935
10936
10937
10938
10939
10940
10941
10942
10943
10944
10945
10946
10947
10948
10949
10950
10951
10952
10953
10954
10955
10956
10957
10958
10959
10960
10961
10962
10963
10964
10965
10966
10967
10968
10969



10970
10971







10972
10973
10974
10975
10976
10977
10978
10979
10980
10981
10982
10983
10984
10985
10986
10987
10988
10989
10990
10991
10992
    #
    echo "$as_me:$LINENO: checking long timezone variable" >&5
echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6
    if test "${tcl_cv_var_timezone+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
extern long timezone;
	    timezone += 1;
	    exit (0);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_timezone_long=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_timezone_long=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

    echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5
echo "${ECHO_T}$tcl_cv_timezone_long" >&6
    if test $tcl_cv_timezone_long = yes ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TIMEZONE_VAR 1
_ACEOF

    else
	#
	# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
	#
	echo "$as_me:$LINENO: checking time_t timezone variable" >&5
echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6
	if test "${tcl_cv_timezone_time+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
extern time_t timezone;
		timezone += 1;
		exit (0);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_timezone_time=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_timezone_time=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

	echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5
echo "${ECHO_T}$tcl_cv_timezone_time" >&6
	if test $tcl_cv_timezone_time = yes ; then

cat >>confdefs.h <<\_ACEOF







<


















|

>
>
>


>
>
>
>
>
>
>
|












|




















<


















|

>
>
>


>
>
>
>
>
>
>
|












|







11741
11742
11743
11744
11745
11746
11747

11748
11749
11750
11751
11752
11753
11754
11755
11756
11757
11758
11759
11760
11761
11762
11763
11764
11765
11766
11767
11768
11769
11770
11771
11772
11773
11774
11775
11776
11777
11778
11779
11780
11781
11782
11783
11784
11785
11786
11787
11788
11789
11790
11791
11792
11793
11794
11795
11796
11797
11798
11799
11800
11801
11802
11803
11804
11805
11806
11807
11808
11809
11810
11811
11812
11813

11814
11815
11816
11817
11818
11819
11820
11821
11822
11823
11824
11825
11826
11827
11828
11829
11830
11831
11832
11833
11834
11835
11836
11837
11838
11839
11840
11841
11842
11843
11844
11845
11846
11847
11848
11849
11850
11851
11852
11853
11854
11855
11856
11857
11858
11859
11860
11861
11862
11863
11864
11865
11866
    #
    echo "$as_me:$LINENO: checking long timezone variable" >&5
echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6
    if test "${tcl_cv_var_timezone+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
extern long timezone;
	    timezone += 1;
	    exit (0);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_timezone_long=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_timezone_long=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

    echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5
echo "${ECHO_T}$tcl_cv_timezone_long" >&6
    if test $tcl_cv_timezone_long = yes ; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_TIMEZONE_VAR 1
_ACEOF

    else
	#
	# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
	#
	echo "$as_me:$LINENO: checking time_t timezone variable" >&5
echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6
	if test "${tcl_cv_timezone_time+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <time.h>
int
main ()
{
extern time_t timezone;
		timezone += 1;
		exit (0);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_timezone_time=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_timezone_time=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

	echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5
echo "${ECHO_T}$tcl_cv_timezone_time" >&6
	if test $tcl_cv_timezone_time = yes ; then

cat >>confdefs.h <<\_ACEOF
11004
11005
11006
11007
11008
11009
11010
11011
11012
11013
11014
11015
11016
11017
11018
11019
11020
11021
11022
11023
11024
11025
11026
11027
11028
11029
11030
11031



11032
11033







11034
11035
11036
11037
11038
11039
11040
11041
11042
11043
11044
11045
11046
11047
11048
11049
11050
11051
11052
11053
11054
11055
11056
11057
11058
11059
11060
11061
11062
11063
11064
11065
11066



11067
11068







11069
11070
11071
11072
11073
11074
11075
11076
11077
11078
11079
11080
11081
11082
11083
11084
11085
11086
11087
11088
11089
11090
11091

echo "$as_me:$LINENO: checking for struct stat.st_blksize" >&5
echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6
if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
static struct stat ac_aggr;
if (ac_aggr.st_blksize)
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_stat_st_blksize=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
static struct stat ac_aggr;
if (sizeof ac_aggr.st_blksize)
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_stat_st_blksize=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_member_struct_stat_st_blksize=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blksize" >&5
echo "${ECHO_T}$ac_cv_member_struct_stat_st_blksize" >&6
if test $ac_cv_member_struct_stat_st_blksize = yes; then

cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_STAT_ST_BLKSIZE 1







<


















|

>
>
>


>
>
>
>
>
>
>
|











<


















|

>
>
>


>
>
>
>
>
>
>
|












|

|







11878
11879
11880
11881
11882
11883
11884

11885
11886
11887
11888
11889
11890
11891
11892
11893
11894
11895
11896
11897
11898
11899
11900
11901
11902
11903
11904
11905
11906
11907
11908
11909
11910
11911
11912
11913
11914
11915
11916
11917
11918
11919
11920
11921
11922
11923
11924
11925
11926
11927
11928

11929
11930
11931
11932
11933
11934
11935
11936
11937
11938
11939
11940
11941
11942
11943
11944
11945
11946
11947
11948
11949
11950
11951
11952
11953
11954
11955
11956
11957
11958
11959
11960
11961
11962
11963
11964
11965
11966
11967
11968
11969
11970
11971
11972
11973
11974
11975
11976
11977
11978
11979
11980
11981
11982
11983

echo "$as_me:$LINENO: checking for struct stat.st_blksize" >&5
echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6
if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
static struct stat ac_aggr;
if (ac_aggr.st_blksize)
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_stat_st_blksize=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
static struct stat ac_aggr;
if (sizeof ac_aggr.st_blksize)
return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_member_struct_stat_st_blksize=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_member_struct_stat_st_blksize=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blksize" >&5
echo "${ECHO_T}$ac_cv_member_struct_stat_st_blksize" >&6
if test $ac_cv_member_struct_stat_st_blksize = yes; then

cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_STAT_ST_BLKSIZE 1
11101
11102
11103
11104
11105
11106
11107
11108
11109
11110
11111
11112
11113




11114
11115
11116
11117

11118
11119
11120
11121
11122



11123
11124
11125
11126
11127
11128
11129

echo "$as_me:$LINENO: checking for fstatfs" >&5
echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6
if test "${ac_cv_func_fstatfs+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char fstatfs (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







11993
11994
11995
11996
11997
11998
11999

12000
12001
12002
12003
12004
12005
12006
12007
12008
12009
12010
12011
12012
12013
12014
12015
12016
12017
12018
12019
12020
12021
12022
12023
12024
12025
12026
12027
12028

echo "$as_me:$LINENO: checking for fstatfs" >&5
echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6
if test "${ac_cv_func_fstatfs+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define fstatfs to an innocuous variant, in case <limits.h> declares fstatfs.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define fstatfs innocuous_fstatfs

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char fstatfs (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef fstatfs

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
11146
11147
11148
11149
11150
11151
11152
11153
11154



11155
11156







11157
11158
11159
11160
11161
11162
11163
11164
11165
11166
11167
11168
11169

11170
11171
11172
11173
11174
11175
11176
11177
return f != fstatfs;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_fstatfs=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_fstatfs=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_fstatfs" >&5
echo "${ECHO_T}$ac_cv_func_fstatfs" >&6
if test $ac_cv_func_fstatfs = yes; then
  :
else








|

>
>
>


>
>
>
>
>
>
>
|












>
|







12045
12046
12047
12048
12049
12050
12051
12052
12053
12054
12055
12056
12057
12058
12059
12060
12061
12062
12063
12064
12065
12066
12067
12068
12069
12070
12071
12072
12073
12074
12075
12076
12077
12078
12079
12080
12081
12082
12083
12084
12085
12086
12087
return f != fstatfs;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_fstatfs=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_fstatfs=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_fstatfs" >&5
echo "${ECHO_T}$ac_cv_func_fstatfs" >&6
if test $ac_cv_func_fstatfs = yes; then
  :
else

11191
11192
11193
11194
11195
11196
11197
11198
11199
11200
11201
11202
11203
11204
11205
11206
11207
11208
11209
11210
11211
11212
11213
11214
11215
11216
11217
11218
11219
11220
11221
11222
11223
11224
11225
11226
11227
11228
11229
11230
11231
11232
11233
11234
11235
if test "${ac_cv_func_memcmp_working+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  ac_cv_func_memcmp_working=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  /* Some versions of memcmp are not 8-bit clean.  */
  char c0 = 0x40, c1 = 0x80, c2 = 0x81;
  if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0)
    exit (1);

  /* The Next x86 OpenStep bug shows up only when comparing 16 bytes
     or more and with at least one buffer not starting on a 4-byte boundary.
     William Lewis provided this test program.   */
  {
    char foo[21];
    char bar[21];
    int i;
    for (i = 0; i < 4; i++)
      {
        char *a = foo + i;
        char *b = bar + i;
        strcpy (a, "--------01111111");
        strcpy (b, "--------10000000");
        if (memcmp (a, b, 16) >= 0)
          exit (1);
      }
    exit (0);
  }

  ;
  return 0;
}







<





|


















|
|
|
|
|
|







12101
12102
12103
12104
12105
12106
12107

12108
12109
12110
12111
12112
12113
12114
12115
12116
12117
12118
12119
12120
12121
12122
12123
12124
12125
12126
12127
12128
12129
12130
12131
12132
12133
12134
12135
12136
12137
12138
12139
12140
12141
12142
12143
12144
if test "${ac_cv_func_memcmp_working+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  ac_cv_func_memcmp_working=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{

  /* Some versions of memcmp are not 8-bit clean.  */
  char c0 = 0x40, c1 = 0x80, c2 = 0x81;
  if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0)
    exit (1);

  /* The Next x86 OpenStep bug shows up only when comparing 16 bytes
     or more and with at least one buffer not starting on a 4-byte boundary.
     William Lewis provided this test program.   */
  {
    char foo[21];
    char bar[21];
    int i;
    for (i = 0; i < 4; i++)
      {
	char *a = foo + i;
	char *b = bar + i;
	strcpy (a, "--------01111111");
	strcpy (b, "--------10000000");
	if (memcmp (a, b, 16) >= 0)
	  exit (1);
      }
    exit (0);
  }

  ;
  return 0;
}
11250
11251
11252
11253
11254
11255
11256
11257
11258
11259
11260
11261
11262







11263
11264
11265
11266
11267
11268
11269
11270
11271
11272
11273
11274
11275
11276
11277
11278
11279
11280
11281




11282
11283
11284
11285

11286
11287
11288
11289
11290



11291
11292
11293
11294
11295
11296
11297
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_func_memcmp_working=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5
echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6
test $ac_cv_func_memcmp_working = no && LIBOBJS="$LIBOBJS memcmp.$ac_objext"









#--------------------------------------------------------------------
#       Some system like SunOS 4 and other BSD like systems
#       have no memmove (we assume they have bcopy instead).
#       {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo "$as_me:$LINENO: checking for memmove" >&5
echo $ECHO_N "checking for memmove... $ECHO_C" >&6
if test "${ac_cv_func_memmove+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char memmove (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|




|
>
>
>
>
>
>
>













<





>
>
>
>




>





>
>
>







12159
12160
12161
12162
12163
12164
12165
12166
12167
12168
12169
12170
12171
12172
12173
12174
12175
12176
12177
12178
12179
12180
12181
12182
12183
12184
12185
12186
12187
12188
12189
12190
12191

12192
12193
12194
12195
12196
12197
12198
12199
12200
12201
12202
12203
12204
12205
12206
12207
12208
12209
12210
12211
12212
12213
12214
12215
12216
12217
12218
12219
12220
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_func_memcmp_working=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5
echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6
test $ac_cv_func_memcmp_working = no && case $LIBOBJS in
    "memcmp.$ac_objext"   | \
  *" memcmp.$ac_objext"   | \
    "memcmp.$ac_objext "* | \
  *" memcmp.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;;
esac



#--------------------------------------------------------------------
#       Some system like SunOS 4 and other BSD like systems
#       have no memmove (we assume they have bcopy instead).
#       {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo "$as_me:$LINENO: checking for memmove" >&5
echo $ECHO_N "checking for memmove... $ECHO_C" >&6
if test "${ac_cv_func_memmove+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define memmove to an innocuous variant, in case <limits.h> declares memmove.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define memmove innocuous_memmove

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char memmove (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef memmove

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
11314
11315
11316
11317
11318
11319
11320
11321
11322



11323
11324







11325
11326
11327
11328
11329
11330
11331
11332
11333
11334
11335
11336
11337

11338
11339
11340
11341
11342
11343
11344
11345
return f != memmove;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_memmove=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_memmove=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_memmove" >&5
echo "${ECHO_T}$ac_cv_func_memmove" >&6
if test $ac_cv_func_memmove = yes; then
  :
else








|

>
>
>


>
>
>
>
>
>
>
|












>
|







12237
12238
12239
12240
12241
12242
12243
12244
12245
12246
12247
12248
12249
12250
12251
12252
12253
12254
12255
12256
12257
12258
12259
12260
12261
12262
12263
12264
12265
12266
12267
12268
12269
12270
12271
12272
12273
12274
12275
12276
12277
12278
12279
return f != memmove;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_memmove=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_memmove=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_memmove" >&5
echo "${ECHO_T}$ac_cv_func_memmove" >&6
if test $ac_cv_func_memmove = yes; then
  :
else

11357
11358
11359
11360
11361
11362
11363


































































































11364
11365



11366
11367
11368
11369
11370
11371
11372
11373
11374
11375
11376
11377
11378
11379
11380
11381
11382
11383
11384
11385
11386
11387
11388
11389
11390
11391
11392
11393
11394
11395
11396
11397
11398
11399
11400
11401
11402
11403
11404
11405

11406
11407
11408


11409
11410
11411









11412


11413
11414
11415
11416
11417
11418
11419
11420
11421

11422
11423
11424
11425
11426
11427
11428
11429
11430
11431
11432
11433




11434
11435
11436
11437

11438
11439
11440
11441
11442



11443
11444
11445
11446
11447
11448
11449


#--------------------------------------------------------------------
#	On some systems strstr is broken: it returns a pointer even
#	even if the original string is empty.
#--------------------------------------------------------------------



































































































echo "$as_me:$LINENO: checking proper strstr implementation" >&5
echo $ECHO_N "checking proper strstr implementation... $ECHO_C" >&6



if test "$cross_compiling" = yes; then
  tcl_ok=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

extern int strstr();
int main()
{
    exit(strstr("\0test", "test") ? 1 : 0);
}

_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_ok=yes
else
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_ok=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi

if test $tcl_ok = yes; then
    echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}yes" >&6


else
    echo "$as_me:$LINENO: result: broken, using substitute" >&5
echo "${ECHO_T}broken, using substitute" >&6









    LIBOBJS="$LIBOBJS strstr.$ac_objext"


    USE_COMPAT=1
fi

#--------------------------------------------------------------------
#	Check for strtoul function.  This is tricky because under some
#	versions of AIX strtoul returns an incorrect terminator
#	pointer for the string "0".
#--------------------------------------------------------------------


echo "$as_me:$LINENO: checking for strtoul" >&5
echo $ECHO_N "checking for strtoul... $ECHO_C" >&6
if test "${ac_cv_func_strtoul+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtoul (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

>
>
>
|
|


<





|
|
<
<


<












|






|

|

>
|
|
|
>
>
|
<
<
>
>
>
>
>
>
>
>
>
|
>
>
|
|







>
|





<





>
>
>
>




>





>
>
>







12291
12292
12293
12294
12295
12296
12297
12298
12299
12300
12301
12302
12303
12304
12305
12306
12307
12308
12309
12310
12311
12312
12313
12314
12315
12316
12317
12318
12319
12320
12321
12322
12323
12324
12325
12326
12327
12328
12329
12330
12331
12332
12333
12334
12335
12336
12337
12338
12339
12340
12341
12342
12343
12344
12345
12346
12347
12348
12349
12350
12351
12352
12353
12354
12355
12356
12357
12358
12359
12360
12361
12362
12363
12364
12365
12366
12367
12368
12369
12370
12371
12372
12373
12374
12375
12376
12377
12378
12379
12380
12381
12382
12383
12384
12385
12386
12387
12388
12389
12390
12391
12392
12393
12394
12395
12396
12397
12398
12399
12400
12401
12402
12403
12404

12405
12406
12407
12408
12409
12410
12411


12412
12413

12414
12415
12416
12417
12418
12419
12420
12421
12422
12423
12424
12425
12426
12427
12428
12429
12430
12431
12432
12433
12434
12435
12436
12437
12438
12439
12440
12441
12442
12443


12444
12445
12446
12447
12448
12449
12450
12451
12452
12453
12454
12455
12456
12457
12458
12459
12460
12461
12462
12463
12464
12465
12466
12467
12468
12469
12470
12471

12472
12473
12474
12475
12476
12477
12478
12479
12480
12481
12482
12483
12484
12485
12486
12487
12488
12489
12490
12491
12492
12493
12494
12495
12496
12497
12498
12499
12500


#--------------------------------------------------------------------
#	On some systems strstr is broken: it returns a pointer even
#	even if the original string is empty.
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for strstr" >&5
echo $ECHO_N "checking for strstr... $ECHO_C" >&6
if test "${ac_cv_func_strstr+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define strstr to an innocuous variant, in case <limits.h> declares strstr.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define strstr innocuous_strstr

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strstr (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef strstr

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char strstr ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_strstr) || defined (__stub___strstr)
choke me
#else
char (*f) () = strstr;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != strstr;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strstr=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strstr=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strstr" >&5
echo "${ECHO_T}$ac_cv_func_strstr" >&6
if test $ac_cv_func_strstr = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

    if test "$tcl_ok" = 1; then
	echo "$as_me:$LINENO: checking proper strstr implementation" >&5
echo $ECHO_N "checking proper strstr implementation... $ECHO_C" >&6
	if test "${tcl_cv_strstr_unbroken+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_strstr_unbroken=unknown
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
int main() {
    extern int strstr();


    exit(strstr("\0test", "test") ? 1 : 0);
}

_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_strstr_unbroken=ok
else
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_strstr_unbroken=broken
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi

	echo "$as_me:$LINENO: result: $tcl_cv_strstr_unbroken" >&5
echo "${ECHO_T}$tcl_cv_strstr_unbroken" >&6
	if test "$tcl_cv_strstr_unbroken" = "ok"; then
	    tcl_ok=1
	else


	    tcl_ok=0
	fi
    fi
    if test "$tcl_ok" = 0; then
	case $LIBOBJS in
    "strstr.$ac_objext"   | \
  *" strstr.$ac_objext"   | \
    "strstr.$ac_objext "* | \
  *" strstr.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strstr.$ac_objext" ;;
esac

	USE_COMPAT=1
    fi

#--------------------------------------------------------------------
#	Check for strtoul function.  This is tricky because under some
#	versions of AIX strtoul returns an incorrect terminator
#	pointer for the string "0".
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for strtoul" >&5
echo $ECHO_N "checking for strtoul... $ECHO_C" >&6
if test "${ac_cv_func_strtoul+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define strtoul to an innocuous variant, in case <limits.h> declares strtoul.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define strtoul innocuous_strtoul

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtoul (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef strtoul

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
11466
11467
11468
11469
11470
11471
11472
11473
11474



11475
11476







11477
11478
11479
11480
11481
11482
11483
11484
11485
11486
11487
11488
11489

11490
11491
11492
11493
11494
11495
11496
11497
11498
11499






11500
11501
11502
11503
11504
11505
11506
11507
11508
11509
11510
11511
11512
11513
11514
11515
11516
11517
11518
11519
11520
11521
11522
11523
11524
11525
11526
11527
11528
11529
11530
11531
11532
11533
11534
11535

11536
11537
11538
11539
11540
11541
11542
11543
11544
11545










11546


11547


11548


11549
11550
11551
11552
11553
11554
11555
11556

11557
11558
11559
11560
11561
11562
11563
11564
11565
11566
11567
11568




11569
11570
11571
11572

11573
11574
11575
11576
11577



11578
11579
11580
11581
11582
11583
11584
return f != strtoul;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strtoul=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strtoul=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strtoul" >&5
echo "${ECHO_T}$ac_cv_func_strtoul" >&6
if test $ac_cv_func_strtoul = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi







if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

extern int strtoul();
int main()
{
    char *string = "0";
    char *term;
    int value;
    value = strtoul(string, &term, 0);
    if ((value != 0) || (term != (string+1))) {
        exit(1);
    }
    exit(0);
}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  :

else
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_ok=0
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi










if test "$tcl_ok" = 0; then


    test -n "$verbose" && echo "	Adding strtoul.o."


    LIBOBJS="$LIBOBJS strtoul.$ac_objext"


    USE_COMPAT=1
fi

#--------------------------------------------------------------------
#	Check for the strtod function.  This is tricky because in some
#	versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------


echo "$as_me:$LINENO: checking for strtod" >&5
echo $ECHO_N "checking for strtod... $ECHO_C" >&6
if test "${ac_cv_func_strtod+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|









>
>
>
>
>
>
|
|


<





|
|
<
<
<
|
<
|
<
<
<
<













<
>






|

|

>
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
|
>
>
|
|






>
|





<





>
>
>
>




>





>
>
>







12517
12518
12519
12520
12521
12522
12523
12524
12525
12526
12527
12528
12529
12530
12531
12532
12533
12534
12535
12536
12537
12538
12539
12540
12541
12542
12543
12544
12545
12546
12547
12548
12549
12550
12551
12552
12553
12554
12555
12556
12557
12558
12559
12560
12561
12562
12563
12564
12565
12566
12567
12568
12569
12570
12571

12572
12573
12574
12575
12576
12577
12578



12579

12580




12581
12582
12583
12584
12585
12586
12587
12588
12589
12590
12591
12592
12593

12594
12595
12596
12597
12598
12599
12600
12601
12602
12603
12604
12605
12606
12607
12608
12609
12610
12611
12612
12613
12614
12615
12616
12617
12618
12619
12620
12621
12622
12623
12624
12625
12626
12627
12628
12629
12630
12631
12632
12633
12634
12635
12636
12637
12638

12639
12640
12641
12642
12643
12644
12645
12646
12647
12648
12649
12650
12651
12652
12653
12654
12655
12656
12657
12658
12659
12660
12661
12662
12663
12664
12665
12666
12667
return f != strtoul;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strtoul=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strtoul=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strtoul" >&5
echo "${ECHO_T}$ac_cv_func_strtoul" >&6
if test $ac_cv_func_strtoul = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

    if test "$tcl_ok" = 1; then
	echo "$as_me:$LINENO: checking proper strtoul implementation" >&5
echo $ECHO_N "checking proper strtoul implementation... $ECHO_C" >&6
	if test "${tcl_cv_strtoul_unbroken+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_strtoul_unbroken=unknown
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
int main() {
    extern int strtoul();



    char *term, *string = "0";

    exit(strtoul(string,&term,0) != 0 || term != string+1);




}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then

  tcl_cv_strtoul_unbroken=ok
else
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_strtoul_unbroken=broken
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi

	echo "$as_me:$LINENO: result: $tcl_cv_strtoul_unbroken" >&5
echo "${ECHO_T}$tcl_cv_strtoul_unbroken" >&6
	if test "$tcl_cv_strtoul_unbroken" = "ok"; then
	    tcl_ok=1
	else
	    tcl_ok=0
	fi
    fi
    if test "$tcl_ok" = 0; then
	case $LIBOBJS in
    "strtoul.$ac_objext"   | \
  *" strtoul.$ac_objext"   | \
    "strtoul.$ac_objext "* | \
  *" strtoul.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" ;;
esac

	USE_COMPAT=1
    fi

#--------------------------------------------------------------------
#	Check for the strtod function.  This is tricky because in some
#	versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for strtod" >&5
echo $ECHO_N "checking for strtod... $ECHO_C" >&6
if test "${ac_cv_func_strtod+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define strtod to an innocuous variant, in case <limits.h> declares strtod.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define strtod innocuous_strtod

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef strtod

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
11601
11602
11603
11604
11605
11606
11607
11608
11609



11610
11611







11612
11613
11614
11615
11616
11617
11618
11619
11620
11621
11622
11623
11624

11625
11626
11627
11628
11629
11630
11631
11632
11633
11634






11635
11636
11637
11638
11639
11640
11641
11642
11643
11644
11645
11646
11647
11648
11649
11650
11651
11652
11653
11654
11655
11656
11657
11658
11659
11660
11661
11662
11663
11664
11665
11666
11667
11668
11669
11670

11671
11672
11673
11674
11675
11676
11677
11678
11679
11680










11681


11682


11683


11684
11685
11686
11687
11688
11689
11690
11691
11692
11693
11694
11695
11696
11697
11698
11699
11700
11701
11702
11703
11704
11705
11706




11707
11708
11709
11710

11711
11712
11713
11714
11715



11716
11717
11718
11719
11720
11721
11722
return f != strtod;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strtod=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strtod=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5
echo "${ECHO_T}$ac_cv_func_strtod" >&6
if test $ac_cv_func_strtod = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi







if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

extern double strtod();
int main()
{
    char *string = " +69";
    char *term;
    double value;
    value = strtod(string, &term);
    if ((value != 69) || (term != (string+4))) {
	exit(1);
    }
    exit(0);
}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  :

else
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_ok=0
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi










if test "$tcl_ok" = 0; then


    test -n "$verbose" && echo "	Adding strtod.o."


    LIBOBJS="$LIBOBJS strtod.$ac_objext"


    USE_COMPAT=1
fi

#--------------------------------------------------------------------
#	Under Solaris 2.4, strtod returns the wrong value for the
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" that corrects the error.
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for strtod" >&5
echo $ECHO_N "checking for strtod... $ECHO_C" >&6
if test "${ac_cv_func_strtod+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|









>
>
>
>
>
>
|
|


<





|
|
<
<
<
|
<
|
<
<
<
<













<
>






|

|

>
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
|
>
>
|
|















<





>
>
>
>




>





>
>
>







12684
12685
12686
12687
12688
12689
12690
12691
12692
12693
12694
12695
12696
12697
12698
12699
12700
12701
12702
12703
12704
12705
12706
12707
12708
12709
12710
12711
12712
12713
12714
12715
12716
12717
12718
12719
12720
12721
12722
12723
12724
12725
12726
12727
12728
12729
12730
12731
12732
12733
12734
12735
12736
12737
12738

12739
12740
12741
12742
12743
12744
12745



12746

12747




12748
12749
12750
12751
12752
12753
12754
12755
12756
12757
12758
12759
12760

12761
12762
12763
12764
12765
12766
12767
12768
12769
12770
12771
12772
12773
12774
12775
12776
12777
12778
12779
12780
12781
12782
12783
12784
12785
12786
12787
12788
12789
12790
12791
12792
12793
12794
12795
12796
12797
12798
12799
12800
12801
12802
12803
12804
12805
12806
12807

12808
12809
12810
12811
12812
12813
12814
12815
12816
12817
12818
12819
12820
12821
12822
12823
12824
12825
12826
12827
12828
12829
12830
12831
12832
12833
12834
12835
12836
return f != strtod;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strtod=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strtod=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5
echo "${ECHO_T}$ac_cv_func_strtod" >&6
if test $ac_cv_func_strtod = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

    if test "$tcl_ok" = 1; then
	echo "$as_me:$LINENO: checking proper strtod implementation" >&5
echo $ECHO_N "checking proper strtod implementation... $ECHO_C" >&6
	if test "${tcl_cv_strtod_unbroken+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_strtod_unbroken=unknown
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
int main() {
    extern double strtod();



    char *term, *string = " +69";

    exit(strtod(string,&term) != 69 || term != string+4);




}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then

  tcl_cv_strtod_unbroken=ok
else
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_strtod_unbroken=broken
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi

	echo "$as_me:$LINENO: result: $tcl_cv_strtod_unbroken" >&5
echo "${ECHO_T}$tcl_cv_strtod_unbroken" >&6
	if test "$tcl_cv_strtod_unbroken" = "ok"; then
	    tcl_ok=1
	else
	    tcl_ok=0
	fi
    fi
    if test "$tcl_ok" = 0; then
	case $LIBOBJS in
    "strtod.$ac_objext"   | \
  *" strtod.$ac_objext"   | \
    "strtod.$ac_objext "* | \
  *" strtod.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strtod.$ac_objext" ;;
esac

	USE_COMPAT=1
    fi

#--------------------------------------------------------------------
#	Under Solaris 2.4, strtod returns the wrong value for the
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" that corrects the error.
#--------------------------------------------------------------------


    echo "$as_me:$LINENO: checking for strtod" >&5
echo $ECHO_N "checking for strtod... $ECHO_C" >&6
if test "${ac_cv_func_strtod+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define strtod to an innocuous variant, in case <limits.h> declares strtod.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define strtod innocuous_strtod

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef strtod

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
11739
11740
11741
11742
11743
11744
11745
11746
11747



11748
11749







11750
11751
11752
11753
11754
11755
11756
11757
11758
11759
11760
11761
11762

11763
11764
11765
11766
11767
11768
11769
11770
11771
11772
11773
11774
11775
11776
11777
11778
11779
11780
11781
11782
11783
11784
11785
11786
11787
11788
11789
11790
11791
return f != strtod;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strtod=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strtod=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5
echo "${ECHO_T}$ac_cv_func_strtod" >&6
if test $ac_cv_func_strtod = yes; then
  tcl_strtod=1
else
  tcl_strtod=0
fi

    if test "$tcl_strtod" = 1; then
	echo "$as_me:$LINENO: checking for Solaris2.4/Tru64 strtod bugs" >&5
echo $ECHO_N "checking for Solaris2.4/Tru64 strtod bugs... $ECHO_C" >&6
	if test "${tcl_cv_strtod_buggy+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    if test "$cross_compiling" = yes; then
  tcl_cv_strtod_buggy=0
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

		extern double strtod();







|

>
>
>


>
>
>
>
>
>
>
|












>
|




















<







12853
12854
12855
12856
12857
12858
12859
12860
12861
12862
12863
12864
12865
12866
12867
12868
12869
12870
12871
12872
12873
12874
12875
12876
12877
12878
12879
12880
12881
12882
12883
12884
12885
12886
12887
12888
12889
12890
12891
12892
12893
12894
12895
12896
12897
12898
12899
12900
12901
12902
12903
12904
12905
12906
12907
12908

12909
12910
12911
12912
12913
12914
12915
return f != strtod;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strtod=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strtod=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5
echo "${ECHO_T}$ac_cv_func_strtod" >&6
if test $ac_cv_func_strtod = yes; then
  tcl_strtod=1
else
  tcl_strtod=0
fi

    if test "$tcl_strtod" = 1; then
	echo "$as_me:$LINENO: checking for Solaris2.4/Tru64 strtod bugs" >&5
echo $ECHO_N "checking for Solaris2.4/Tru64 strtod bugs... $ECHO_C" >&6
	if test "${tcl_cv_strtod_buggy+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    if test "$cross_compiling" = yes; then
  tcl_cv_strtod_buggy=0
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

		extern double strtod();
11824
11825
11826
11827
11828
11829
11830
11831
11832
11833
11834
11835
11836
11837
11838
11839
11840





11841


11842
11843
11844
11845
11846
11847
11848
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_strtod_buggy=0
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi

	if test "$tcl_cv_strtod_buggy" = 1; then
	    echo "$as_me:$LINENO: result: ok" >&5
echo "${ECHO_T}ok" >&6
	else
	    echo "$as_me:$LINENO: result: buggy" >&5
echo "${ECHO_T}buggy" >&6





	    LIBOBJS="$LIBOBJS fixstrtod.$ac_objext"


	    USE_COMPAT=1

cat >>confdefs.h <<\_ACEOF
#define strtod fixstrtod
_ACEOF

	fi







|









>
>
>
>
>
|
>
>







12948
12949
12950
12951
12952
12953
12954
12955
12956
12957
12958
12959
12960
12961
12962
12963
12964
12965
12966
12967
12968
12969
12970
12971
12972
12973
12974
12975
12976
12977
12978
12979
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_strtod_buggy=0
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi

	if test "$tcl_cv_strtod_buggy" = 1; then
	    echo "$as_me:$LINENO: result: ok" >&5
echo "${ECHO_T}ok" >&6
	else
	    echo "$as_me:$LINENO: result: buggy" >&5
echo "${ECHO_T}buggy" >&6
	    case $LIBOBJS in
    "fixstrtod.$ac_objext"   | \
  *" fixstrtod.$ac_objext"   | \
    "fixstrtod.$ac_objext "* | \
  *" fixstrtod.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" ;;
esac

	    USE_COMPAT=1

cat >>confdefs.h <<\_ACEOF
#define strtod fixstrtod
_ACEOF

	fi
11856
11857
11858
11859
11860
11861
11862
11863
11864
11865
11866
11867
11868
11869
11870
11871
11872
11873
11874
11875
11876
11877
11878
11879
11880
11881
11882
11883
11884



11885
11886







11887
11888
11889
11890
11891
11892
11893
11894
11895
11896
11897
11898
11899
11900
11901
11902
11903
11904
11905
11906
11907
11908
11909
11910
11911
11912
11913
11914
11915
11916
11917
11918
11919
11920
11921
11922
11923
11924
11925
11926
11927
11928
11929
11930
11931
11932
11933
11934
11935
11936
11937
11938
11939
11940
11941



11942
11943







11944
11945
11946
11947
11948
11949
11950
11951
11952
11953
11954
11955
11956
11957
11958
11959
11960
11961
11962
11963
11964
11965
11966
11967
11968
11969
11970
11971
11972
11973
11974
11975
11976
11977
11978
11979
11980
11981
11982
11983
11984
11985
11986
11987
11988
11989
11990
11991
11992
11993
11994
11995
11996
11997
11998



11999
12000







12001
12002
12003
12004
12005
12006
12007
12008
12009
12010
12011
12012
12013
12014
12015
12016
12017
12018
12019
12020
12021
12022
12023
12024
12025
12026
12027
12028
12029
12030
12031
12032
12033
12034
12035
12036
12037
12038
12039
12040
12041

echo "$as_me:$LINENO: checking for mode_t" >&5
echo $ECHO_N "checking for mode_t... $ECHO_C" >&6
if test "${ac_cv_type_mode_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
if ((mode_t *) 0)
  return 0;
if (sizeof (mode_t))
  return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_type_mode_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_type_mode_t=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5
echo "${ECHO_T}$ac_cv_type_mode_t" >&6
if test $ac_cv_type_mode_t = yes; then
  :
else

cat >>confdefs.h <<_ACEOF
#define mode_t int
_ACEOF

fi

echo "$as_me:$LINENO: checking for pid_t" >&5
echo $ECHO_N "checking for pid_t... $ECHO_C" >&6
if test "${ac_cv_type_pid_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
if ((pid_t *) 0)
  return 0;
if (sizeof (pid_t))
  return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_type_pid_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_type_pid_t=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5
echo "${ECHO_T}$ac_cv_type_pid_t" >&6
if test $ac_cv_type_pid_t = yes; then
  :
else

cat >>confdefs.h <<_ACEOF
#define pid_t int
_ACEOF

fi

echo "$as_me:$LINENO: checking for size_t" >&5
echo $ECHO_N "checking for size_t... $ECHO_C" >&6
if test "${ac_cv_type_size_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
if ((size_t *) 0)
  return 0;
if (sizeof (size_t))
  return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_type_size_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_type_size_t=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5
echo "${ECHO_T}$ac_cv_type_size_t" >&6
if test $ac_cv_type_size_t = yes; then
  :
else

cat >>confdefs.h <<_ACEOF
#define size_t unsigned
_ACEOF

fi

echo "$as_me:$LINENO: checking for uid_t in sys/types.h" >&5
echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6
if test "${ac_cv_type_uid_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>








<



















|

>
>
>


>
>
>
>
>
>
>
|












|



















<



















|

>
>
>


>
>
>
>
>
>
>
|












|



















<



















|

>
>
>


>
>
>
>
>
>
>
|












|



















<







12987
12988
12989
12990
12991
12992
12993

12994
12995
12996
12997
12998
12999
13000
13001
13002
13003
13004
13005
13006
13007
13008
13009
13010
13011
13012
13013
13014
13015
13016
13017
13018
13019
13020
13021
13022
13023
13024
13025
13026
13027
13028
13029
13030
13031
13032
13033
13034
13035
13036
13037
13038
13039
13040
13041
13042
13043
13044
13045
13046
13047
13048
13049
13050
13051
13052
13053
13054
13055
13056
13057
13058
13059

13060
13061
13062
13063
13064
13065
13066
13067
13068
13069
13070
13071
13072
13073
13074
13075
13076
13077
13078
13079
13080
13081
13082
13083
13084
13085
13086
13087
13088
13089
13090
13091
13092
13093
13094
13095
13096
13097
13098
13099
13100
13101
13102
13103
13104
13105
13106
13107
13108
13109
13110
13111
13112
13113
13114
13115
13116
13117
13118
13119
13120
13121
13122
13123
13124
13125

13126
13127
13128
13129
13130
13131
13132
13133
13134
13135
13136
13137
13138
13139
13140
13141
13142
13143
13144
13145
13146
13147
13148
13149
13150
13151
13152
13153
13154
13155
13156
13157
13158
13159
13160
13161
13162
13163
13164
13165
13166
13167
13168
13169
13170
13171
13172
13173
13174
13175
13176
13177
13178
13179
13180
13181
13182
13183
13184
13185
13186
13187
13188
13189
13190
13191

13192
13193
13194
13195
13196
13197
13198

echo "$as_me:$LINENO: checking for mode_t" >&5
echo $ECHO_N "checking for mode_t... $ECHO_C" >&6
if test "${ac_cv_type_mode_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
if ((mode_t *) 0)
  return 0;
if (sizeof (mode_t))
  return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_type_mode_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_type_mode_t=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5
echo "${ECHO_T}$ac_cv_type_mode_t" >&6
if test $ac_cv_type_mode_t = yes; then
  :
else

cat >>confdefs.h <<_ACEOF
#define mode_t int
_ACEOF

fi

echo "$as_me:$LINENO: checking for pid_t" >&5
echo $ECHO_N "checking for pid_t... $ECHO_C" >&6
if test "${ac_cv_type_pid_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
if ((pid_t *) 0)
  return 0;
if (sizeof (pid_t))
  return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_type_pid_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_type_pid_t=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5
echo "${ECHO_T}$ac_cv_type_pid_t" >&6
if test $ac_cv_type_pid_t = yes; then
  :
else

cat >>confdefs.h <<_ACEOF
#define pid_t int
_ACEOF

fi

echo "$as_me:$LINENO: checking for size_t" >&5
echo $ECHO_N "checking for size_t... $ECHO_C" >&6
if test "${ac_cv_type_size_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
if ((size_t *) 0)
  return 0;
if (sizeof (size_t))
  return 0;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_type_size_t=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_type_size_t=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5
echo "${ECHO_T}$ac_cv_type_size_t" >&6
if test $ac_cv_type_size_t = yes; then
  :
else

cat >>confdefs.h <<_ACEOF
#define size_t unsigned
_ACEOF

fi

echo "$as_me:$LINENO: checking for uid_t in sys/types.h" >&5
echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6
if test "${ac_cv_type_uid_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>

12067
12068
12069
12070
12071
12072
12073
12074
12075
12076
12077
12078
12079
12080
12081

echo "$as_me:$LINENO: checking for socklen_t" >&5
echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6
if test "${ac_cv_type_socklen_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

    #include <sys/types.h>







<







13224
13225
13226
13227
13228
13229
13230

13231
13232
13233
13234
13235
13236
13237

echo "$as_me:$LINENO: checking for socklen_t" >&5
echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6
if test "${ac_cv_type_socklen_t+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

    #include <sys/types.h>
12115
12116
12117
12118
12119
12120
12121
12122
12123
12124
12125
12126
12127




12128
12129
12130
12131

12132
12133
12134
12135
12136



12137
12138
12139
12140
12141
12142
12143

echo "$as_me:$LINENO: checking for opendir" >&5
echo $ECHO_N "checking for opendir... $ECHO_C" >&6
if test "${ac_cv_func_opendir+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char opendir (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







13271
13272
13273
13274
13275
13276
13277

13278
13279
13280
13281
13282
13283
13284
13285
13286
13287
13288
13289
13290
13291
13292
13293
13294
13295
13296
13297
13298
13299
13300
13301
13302
13303
13304
13305
13306

echo "$as_me:$LINENO: checking for opendir" >&5
echo $ECHO_N "checking for opendir... $ECHO_C" >&6
if test "${ac_cv_func_opendir+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define opendir to an innocuous variant, in case <limits.h> declares opendir.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define opendir innocuous_opendir

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char opendir (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef opendir

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
12160
12161
12162
12163
12164
12165
12166
12167
12168



12169
12170







12171
12172
12173
12174
12175
12176
12177
12178
12179
12180
12181
12182
12183

12184
12185
12186
12187
12188
12189
12190
12191
return f != opendir;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_opendir=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_opendir=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_opendir" >&5
echo "${ECHO_T}$ac_cv_func_opendir" >&6
if test $ac_cv_func_opendir = yes; then
  :
else








|

>
>
>


>
>
>
>
>
>
>
|












>
|







13323
13324
13325
13326
13327
13328
13329
13330
13331
13332
13333
13334
13335
13336
13337
13338
13339
13340
13341
13342
13343
13344
13345
13346
13347
13348
13349
13350
13351
13352
13353
13354
13355
13356
13357
13358
13359
13360
13361
13362
13363
13364
13365
return f != opendir;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_opendir=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_opendir=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_opendir" >&5
echo "${ECHO_T}$ac_cv_func_opendir" >&6
if test $ac_cv_func_opendir = yes; then
  :
else

12206
12207
12208
12209
12210
12211
12212
12213
12214
12215
12216
12217
12218
12219
12220

echo "$as_me:$LINENO: checking union wait" >&5
echo $ECHO_N "checking union wait... $ECHO_C" >&6
if test "${tcl_cv_union_wait+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/wait.h>







<







13380
13381
13382
13383
13384
13385
13386

13387
13388
13389
13390
13391
13392
13393

echo "$as_me:$LINENO: checking union wait" >&5
echo $ECHO_N "checking union wait... $ECHO_C" >&6
if test "${tcl_cv_union_wait+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/types.h>
#include <sys/wait.h>
12228
12229
12230
12231
12232
12233
12234
12235
12236



12237
12238







12239
12240
12241
12242
12243
12244
12245
12246
12247
12248
12249
12250
12251

12252
12253
12254
12255
12256
12257
12258
12259

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_union_wait=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_union_wait=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi

echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5
echo "${ECHO_T}$tcl_cv_union_wait" >&6
if test $tcl_cv_union_wait = no; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












>
|







13401
13402
13403
13404
13405
13406
13407
13408
13409
13410
13411
13412
13413
13414
13415
13416
13417
13418
13419
13420
13421
13422
13423
13424
13425
13426
13427
13428
13429
13430
13431
13432
13433
13434
13435
13436
13437
13438
13439
13440
13441
13442
13443

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_union_wait=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_union_wait=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi

echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5
echo "${ECHO_T}$tcl_cv_union_wait" >&6
if test $tcl_cv_union_wait = no; then

cat >>confdefs.h <<\_ACEOF
12270
12271
12272
12273
12274
12275
12276
12277
12278
12279
12280
12281
12282




12283
12284
12285
12286

12287
12288
12289
12290
12291



12292
12293
12294
12295
12296
12297
12298

echo "$as_me:$LINENO: checking for strncasecmp" >&5
echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6
if test "${ac_cv_func_strncasecmp+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strncasecmp (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







<





>
>
>
>




>





>
>
>







13454
13455
13456
13457
13458
13459
13460

13461
13462
13463
13464
13465
13466
13467
13468
13469
13470
13471
13472
13473
13474
13475
13476
13477
13478
13479
13480
13481
13482
13483
13484
13485
13486
13487
13488
13489

echo "$as_me:$LINENO: checking for strncasecmp" >&5
echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6
if test "${ac_cv_func_strncasecmp+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define strncasecmp to an innocuous variant, in case <limits.h> declares strncasecmp.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define strncasecmp innocuous_strncasecmp

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strncasecmp (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef strncasecmp

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
12315
12316
12317
12318
12319
12320
12321
12322
12323



12324
12325







12326
12327
12328
12329
12330
12331
12332
12333
12334
12335
12336
12337
12338

12339
12340
12341
12342
12343
12344
12345
12346
12347
12348
12349
12350
12351
12352
12353
12354
12355
12356
12357
12358
12359
12360
12361
12362
12363
12364
12365
return f != strncasecmp;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strncasecmp=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strncasecmp=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strncasecmp" >&5
echo "${ECHO_T}$ac_cv_func_strncasecmp" >&6
if test $ac_cv_func_strncasecmp = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

if test "$tcl_ok" = 0; then
    echo "$as_me:$LINENO: checking for strncasecmp in -lsocket" >&5
echo $ECHO_N "checking for strncasecmp in -lsocket... $ECHO_C" >&6
if test "${ac_cv_lib_socket_strncasecmp+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|


















<







13506
13507
13508
13509
13510
13511
13512
13513
13514
13515
13516
13517
13518
13519
13520
13521
13522
13523
13524
13525
13526
13527
13528
13529
13530
13531
13532
13533
13534
13535
13536
13537
13538
13539
13540
13541
13542
13543
13544
13545
13546
13547
13548
13549
13550
13551
13552
13553
13554
13555
13556
13557
13558
13559

13560
13561
13562
13563
13564
13565
13566
return f != strncasecmp;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_strncasecmp=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_strncasecmp=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_strncasecmp" >&5
echo "${ECHO_T}$ac_cv_func_strncasecmp" >&6
if test $ac_cv_func_strncasecmp = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

if test "$tcl_ok" = 0; then
    echo "$as_me:$LINENO: checking for strncasecmp in -lsocket" >&5
echo $ECHO_N "checking for strncasecmp in -lsocket... $ECHO_C" >&6
if test "${ac_cv_lib_socket_strncasecmp+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
12375
12376
12377
12378
12379
12380
12381
12382
12383



12384
12385







12386
12387
12388
12389
12390
12391
12392
12393
12394
12395
12396
12397
12398

12399
12400
12401
12402
12403
12404
12405
12406
12407
12408
12409
12410
12411
12412
12413
12414
12415
12416
12417
12418
12419
12420
12421
12422
12423
12424
12425
12426
12427
strncasecmp ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_socket_strncasecmp=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_socket_strncasecmp=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_socket_strncasecmp" >&5
echo "${ECHO_T}$ac_cv_lib_socket_strncasecmp" >&6
if test $ac_cv_lib_socket_strncasecmp = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

fi
if test "$tcl_ok" = 0; then
    echo "$as_me:$LINENO: checking for strncasecmp in -linet" >&5
echo $ECHO_N "checking for strncasecmp in -linet... $ECHO_C" >&6
if test "${ac_cv_lib_inet_strncasecmp+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-linet  $LIBS"
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|




















<







13576
13577
13578
13579
13580
13581
13582
13583
13584
13585
13586
13587
13588
13589
13590
13591
13592
13593
13594
13595
13596
13597
13598
13599
13600
13601
13602
13603
13604
13605
13606
13607
13608
13609
13610
13611
13612
13613
13614
13615
13616
13617
13618
13619
13620
13621
13622
13623
13624
13625
13626
13627
13628
13629
13630
13631

13632
13633
13634
13635
13636
13637
13638
strncasecmp ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_socket_strncasecmp=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_socket_strncasecmp=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_socket_strncasecmp" >&5
echo "${ECHO_T}$ac_cv_lib_socket_strncasecmp" >&6
if test $ac_cv_lib_socket_strncasecmp = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

fi
if test "$tcl_ok" = 0; then
    echo "$as_me:$LINENO: checking for strncasecmp in -linet" >&5
echo $ECHO_N "checking for strncasecmp in -linet... $ECHO_C" >&6
if test "${ac_cv_lib_inet_strncasecmp+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_check_lib_save_LIBS=$LIBS
LIBS="-linet  $LIBS"
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

/* Override any gcc2 internal prototype to avoid an error.  */
12437
12438
12439
12440
12441
12442
12443
12444
12445



12446
12447







12448
12449
12450
12451
12452
12453
12454
12455
12456
12457
12458
12459
12460

12461
12462
12463
12464
12465
12466
12467
12468
12469
12470
12471
12472
12473





12474


12475
12476
12477
12478
12479
12480
12481
12482
12483
12484
12485
12486
12487
12488
12489
12490
12491
12492
12493
12494
12495
12496
12497
12498
12499
12500




12501
12502
12503
12504

12505
12506
12507
12508
12509



12510
12511
12512
12513
12514
12515
12516
strncasecmp ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_inet_strncasecmp=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_inet_strncasecmp=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_inet_strncasecmp" >&5
echo "${ECHO_T}$ac_cv_lib_inet_strncasecmp" >&6
if test $ac_cv_lib_inet_strncasecmp = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

fi
if test "$tcl_ok" = 0; then





    LIBOBJS="$LIBOBJS strncasecmp.$ac_objext"


    USE_COMPAT=1
fi

#--------------------------------------------------------------------
#	The code below deals with several issues related to gettimeofday:
#	1. Some systems don't provide a gettimeofday function at all
#	   (set NO_GETTOD if this is the case).
#	2. SGI systems don't use the BSD form of the gettimeofday function,
#	   but they have a BSDgettimeofday function that can be used instead.
#	3. See if gettimeofday is declared in the <sys/time.h> header file.
#	   if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can
#	   declare it.
#--------------------------------------------------------------------

echo "$as_me:$LINENO: checking for BSDgettimeofday" >&5
echo $ECHO_N "checking for BSDgettimeofday... $ECHO_C" >&6
if test "${ac_cv_func_BSDgettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char BSDgettimeofday (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|












>
>
>
>
>
|
>
>




















<





>
>
>
>




>





>
>
>







13648
13649
13650
13651
13652
13653
13654
13655
13656
13657
13658
13659
13660
13661
13662
13663
13664
13665
13666
13667
13668
13669
13670
13671
13672
13673
13674
13675
13676
13677
13678
13679
13680
13681
13682
13683
13684
13685
13686
13687
13688
13689
13690
13691
13692
13693
13694
13695
13696
13697
13698
13699
13700
13701
13702
13703
13704
13705
13706
13707
13708
13709
13710
13711
13712
13713
13714
13715
13716
13717
13718
13719
13720
13721
13722
13723

13724
13725
13726
13727
13728
13729
13730
13731
13732
13733
13734
13735
13736
13737
13738
13739
13740
13741
13742
13743
13744
13745
13746
13747
13748
13749
13750
13751
13752
strncasecmp ();
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_lib_inet_strncasecmp=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_lib_inet_strncasecmp=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
echo "$as_me:$LINENO: result: $ac_cv_lib_inet_strncasecmp" >&5
echo "${ECHO_T}$ac_cv_lib_inet_strncasecmp" >&6
if test $ac_cv_lib_inet_strncasecmp = yes; then
  tcl_ok=1
else
  tcl_ok=0
fi

fi
if test "$tcl_ok" = 0; then
    case $LIBOBJS in
    "strncasecmp.$ac_objext"   | \
  *" strncasecmp.$ac_objext"   | \
    "strncasecmp.$ac_objext "* | \
  *" strncasecmp.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" ;;
esac

    USE_COMPAT=1
fi

#--------------------------------------------------------------------
#	The code below deals with several issues related to gettimeofday:
#	1. Some systems don't provide a gettimeofday function at all
#	   (set NO_GETTOD if this is the case).
#	2. SGI systems don't use the BSD form of the gettimeofday function,
#	   but they have a BSDgettimeofday function that can be used instead.
#	3. See if gettimeofday is declared in the <sys/time.h> header file.
#	   if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can
#	   declare it.
#--------------------------------------------------------------------

echo "$as_me:$LINENO: checking for BSDgettimeofday" >&5
echo $ECHO_N "checking for BSDgettimeofday... $ECHO_C" >&6
if test "${ac_cv_func_BSDgettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define BSDgettimeofday to an innocuous variant, in case <limits.h> declares BSDgettimeofday.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define BSDgettimeofday innocuous_BSDgettimeofday

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char BSDgettimeofday (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef BSDgettimeofday

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
12533
12534
12535
12536
12537
12538
12539
12540
12541



12542
12543







12544
12545
12546
12547
12548
12549
12550
12551
12552
12553
12554
12555
12556

12557
12558
12559
12560
12561
12562
12563
12564
12565
12566
12567
12568
12569
12570
12571
12572
12573
12574
12575
12576
12577
12578
12579
12580




12581
12582
12583
12584

12585
12586
12587
12588
12589



12590
12591
12592
12593
12594
12595
12596
return f != BSDgettimeofday;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_BSDgettimeofday=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_BSDgettimeofday=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_BSDgettimeofday" >&5
echo "${ECHO_T}$ac_cv_func_BSDgettimeofday" >&6
if test $ac_cv_func_BSDgettimeofday = yes; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_BSDGETTIMEOFDAY 1
_ACEOF

else

    echo "$as_me:$LINENO: checking for gettimeofday" >&5
echo $ECHO_N "checking for gettimeofday... $ECHO_C" >&6
if test "${ac_cv_func_gettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gettimeofday (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







|

>
>
>


>
>
>
>
>
>
>
|












>
|

















<





>
>
>
>




>





>
>
>







13769
13770
13771
13772
13773
13774
13775
13776
13777
13778
13779
13780
13781
13782
13783
13784
13785
13786
13787
13788
13789
13790
13791
13792
13793
13794
13795
13796
13797
13798
13799
13800
13801
13802
13803
13804
13805
13806
13807
13808
13809
13810
13811
13812
13813
13814
13815
13816
13817
13818
13819
13820
13821

13822
13823
13824
13825
13826
13827
13828
13829
13830
13831
13832
13833
13834
13835
13836
13837
13838
13839
13840
13841
13842
13843
13844
13845
13846
13847
13848
13849
13850
return f != BSDgettimeofday;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_BSDgettimeofday=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_BSDgettimeofday=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_BSDgettimeofday" >&5
echo "${ECHO_T}$ac_cv_func_BSDgettimeofday" >&6
if test $ac_cv_func_BSDgettimeofday = yes; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_BSDGETTIMEOFDAY 1
_ACEOF

else

    echo "$as_me:$LINENO: checking for gettimeofday" >&5
echo $ECHO_N "checking for gettimeofday... $ECHO_C" >&6
if test "${ac_cv_func_gettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define gettimeofday to an innocuous variant, in case <limits.h> declares gettimeofday.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define gettimeofday innocuous_gettimeofday

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gettimeofday (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef gettimeofday

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
12613
12614
12615
12616
12617
12618
12619
12620
12621



12622
12623







12624
12625
12626
12627
12628
12629
12630
12631
12632
12633
12634
12635
12636

12637
12638
12639
12640
12641
12642
12643
12644
return f != gettimeofday;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_gettimeofday=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_gettimeofday=no
fi

rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_gettimeofday" >&5
echo "${ECHO_T}$ac_cv_func_gettimeofday" >&6
if test $ac_cv_func_gettimeofday = yes; then
  :
else








|

>
>
>


>
>
>
>
>
>
>
|












>
|







13867
13868
13869
13870
13871
13872
13873
13874
13875
13876
13877
13878
13879
13880
13881
13882
13883
13884
13885
13886
13887
13888
13889
13890
13891
13892
13893
13894
13895
13896
13897
13898
13899
13900
13901
13902
13903
13904
13905
13906
13907
13908
13909
return f != gettimeofday;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_func_gettimeofday=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_func_gettimeofday=no
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_func_gettimeofday" >&5
echo "${ECHO_T}$ac_cv_func_gettimeofday" >&6
if test $ac_cv_func_gettimeofday = yes; then
  :
else

12653
12654
12655
12656
12657
12658
12659
12660
12661
12662
12663
12664
12665
12666
12667

echo "$as_me:$LINENO: checking for gettimeofday declaration" >&5
echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6
if test "${tcl_cv_grep_gettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/time.h>








<







13918
13919
13920
13921
13922
13923
13924

13925
13926
13927
13928
13929
13930
13931

echo "$as_me:$LINENO: checking for gettimeofday declaration" >&5
echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6
if test "${tcl_cv_grep_gettimeofday+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <sys/time.h>

12695
12696
12697
12698
12699
12700
12701
12702
12703
12704
12705
12706
12707
12708
12709
12710
12711
12712
12713
12714
12715
12716
12717
12718
12719
12720
12721
12722



12723
12724







12725
12726
12727
12728
12729
12730
12731
12732
12733
12734
12735
12736
12737
12738
12739
12740
12741
12742
12743
12744
12745
12746
12747
12748
12749
12750
12751
12752
12753
12754
12755
12756
12757
12758
12759
12760
12761
12762
12763
12764
12765
12766
12767
12768
12769
12770
12771
12772
12773
12774
12775
12776



12777
12778







12779
12780
12781
12782
12783
12784
12785
12786
12787
12788
12789
12790
12791
12792
12793
12794
12795
12796
12797
12798
12799

echo "$as_me:$LINENO: checking whether char is unsigned" >&5
echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6
if test "${ac_cv_c_char_unsigned+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
static int test_array [1 - 2 * !(((char) -1) < 0)];
test_array [0] = 0

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_c_char_unsigned=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_c_char_unsigned=yes
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5
echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6
if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then
  cat >>confdefs.h <<\_ACEOF
#define __CHAR_UNSIGNED__ 1
_ACEOF

fi

echo "$as_me:$LINENO: checking signed char declarations" >&5
echo $ECHO_N "checking signed char declarations... $ECHO_C" >&6
if test "${tcl_cv_char_signed+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

	signed char *p;
	p = 0;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_char_signed=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_char_signed=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi

echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5
echo "${ECHO_T}$tcl_cv_char_signed" >&6
if test $tcl_cv_char_signed = yes; then

cat >>confdefs.h <<\_ACEOF







<


















|

>
>
>


>
>
>
>
>
>
>
|












|
















<



















|

>
>
>


>
>
>
>
>
>
>
|












|







13959
13960
13961
13962
13963
13964
13965

13966
13967
13968
13969
13970
13971
13972
13973
13974
13975
13976
13977
13978
13979
13980
13981
13982
13983
13984
13985
13986
13987
13988
13989
13990
13991
13992
13993
13994
13995
13996
13997
13998
13999
14000
14001
14002
14003
14004
14005
14006
14007
14008
14009
14010
14011
14012
14013
14014
14015
14016
14017
14018
14019
14020
14021
14022
14023
14024
14025
14026
14027

14028
14029
14030
14031
14032
14033
14034
14035
14036
14037
14038
14039
14040
14041
14042
14043
14044
14045
14046
14047
14048
14049
14050
14051
14052
14053
14054
14055
14056
14057
14058
14059
14060
14061
14062
14063
14064
14065
14066
14067
14068
14069
14070
14071
14072
14073
14074
14075
14076
14077
14078
14079
14080
14081

echo "$as_me:$LINENO: checking whether char is unsigned" >&5
echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6
if test "${ac_cv_c_char_unsigned+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
int
main ()
{
static int test_array [1 - 2 * !(((char) -1) < 0)];
test_array [0] = 0

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_c_char_unsigned=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_c_char_unsigned=yes
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5
echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6
if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then
  cat >>confdefs.h <<\_ACEOF
#define __CHAR_UNSIGNED__ 1
_ACEOF

fi

echo "$as_me:$LINENO: checking signed char declarations" >&5
echo $ECHO_N "checking signed char declarations... $ECHO_C" >&6
if test "${tcl_cv_char_signed+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

	signed char *p;
	p = 0;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_char_signed=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_char_signed=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi

echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5
echo "${ECHO_T}$tcl_cv_char_signed" >&6
if test $tcl_cv_char_signed = yes; then

cat >>confdefs.h <<\_ACEOF
12811
12812
12813
12814
12815
12816
12817
12818
12819
12820
12821
12822
12823
12824
12825
if test "${tcl_cv_putenv_copy+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_putenv_copy=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

	#include <stdlib.h>







<







14093
14094
14095
14096
14097
14098
14099

14100
14101
14102
14103
14104
14105
14106
if test "${tcl_cv_putenv_copy+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_putenv_copy=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

	#include <stdlib.h>
12857
12858
12859
12860
12861
12862
12863
12864
12865
12866
12867
12868
12869
12870
12871
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_putenv_copy=yes
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi

fi

echo "$as_me:$LINENO: result: $tcl_cv_putenv_copy" >&5
echo "${ECHO_T}$tcl_cv_putenv_copy" >&6
if test $tcl_cv_putenv_copy = yes; then







|







14138
14139
14140
14141
14142
14143
14144
14145
14146
14147
14148
14149
14150
14151
14152
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_putenv_copy=yes
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi

fi

echo "$as_me:$LINENO: result: $tcl_cv_putenv_copy" >&5
echo "${ECHO_T}$tcl_cv_putenv_copy" >&6
if test $tcl_cv_putenv_copy = yes; then
12901
12902
12903
12904
12905
12906
12907
12908
12909
12910
12911
12912
12913
12914
12915
12916
12917
12918
12919
12920



12921
12922







12923
12924
12925
12926
12927
12928
12929
12930
12931
12932
12933
12934
12935
12936
12937
12938
12939
12940
12941
12942
12943
12944
12945
12946
12947
12948
12949
12950
12951
12952
12953
12954
12955
12956
12957
12958
12959
12960
12961

12962
12963
12964
12965
12966
12967
12968
12969
12970
12971
12972
12973
12974
12975
12976
12977
12978
12979
12980
12981
12982
12983
12984
12985
12986
12987
12988
12989
12990
12991
12992
12993
12994

12995
12996
12997
12998


12999
13000


13001
13002


13003
13004
13005
13006
13007
13008
13009
13010
13011
13012
13013
13014
echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5
echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking langinfo.h usability" >&5
echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <langinfo.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking langinfo.h presence" >&5
echo $ECHO_N "checking langinfo.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <langinfo.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: langinfo.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: langinfo.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: langinfo.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: langinfo.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for langinfo.h" >&5
echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







14182
14183
14184
14185
14186
14187
14188

14189
14190
14191
14192
14193
14194
14195
14196
14197
14198
14199
14200
14201
14202
14203
14204
14205
14206
14207
14208
14209
14210
14211
14212
14213
14214
14215
14216
14217
14218
14219
14220
14221
14222
14223
14224
14225
14226
14227
14228
14229
14230
14231
14232
14233

14234
14235
14236
14237
14238
14239
14240
14241
14242
14243
14244
14245
14246
14247
14248
14249
14250
14251
14252
14253
14254
14255
14256
14257
14258
14259
14260
14261
14262
14263
14264
14265
14266
14267
14268
14269
14270
14271
14272
14273
14274
14275
14276








14277
14278
14279
14280
14281
14282
14283
14284
14285
14286
14287
14288
14289
14290
14291
14292
14293
14294
14295
14296
14297
14298
14299
14300
14301
14302
14303
echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5
echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking langinfo.h usability" >&5
echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <langinfo.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking langinfo.h presence" >&5
echo $ECHO_N "checking langinfo.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <langinfo.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: langinfo.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: langinfo.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: langinfo.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: langinfo.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: langinfo.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: langinfo.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: langinfo.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: langinfo.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for langinfo.h" >&5
echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6
13030
13031
13032
13033
13034
13035
13036
13037
13038
13039
13040
13041
13042
13043
13044
13045
13046
13047
13048
13049
13050
13051
13052
13053
13054
13055



13056
13057







13058
13059
13060
13061
13062
13063
13064
13065
13066
13067
13068
13069
13070
13071
13072
13073
13074
13075
13076
13077
13078

	fi
    fi
    echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5
echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6
    if test "$langinfo_ok" = "yes"; then
	cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <langinfo.h>
int
main ()
{
nl_langinfo(CODESET);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  langinfo_ok=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

langinfo_ok=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
	if test "$langinfo_ok" = "no"; then
	    langinfo_ok="no (could not compile with nl_langinfo)";
	fi
	if test "$langinfo_ok" = "yes"; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_LANGINFO 1







<
















|

>
>
>


>
>
>
>
>
>
>
|












|







14319
14320
14321
14322
14323
14324
14325

14326
14327
14328
14329
14330
14331
14332
14333
14334
14335
14336
14337
14338
14339
14340
14341
14342
14343
14344
14345
14346
14347
14348
14349
14350
14351
14352
14353
14354
14355
14356
14357
14358
14359
14360
14361
14362
14363
14364
14365
14366
14367
14368
14369
14370
14371
14372
14373
14374
14375
14376

	fi
    fi
    echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5
echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6
    if test "$langinfo_ok" = "yes"; then
	cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <langinfo.h>
int
main ()
{
nl_langinfo(CODESET);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  langinfo_ok=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

langinfo_ok=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
	if test "$langinfo_ok" = "no"; then
	    langinfo_ok="no (could not compile with nl_langinfo)";
	fi
	if test "$langinfo_ok" = "yes"; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_LANGINFO 1
13094
13095
13096
13097
13098
13099
13100








13101


































































































13102
13103
13104
13105
13106




13107
13108
13109
13110

13111
13112
13113
13114
13115



13116
13117
13118
13119
13120
13121
13122
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF








#line $LINENO "configure"


































































































/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */




/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif



/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */







>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





>
>
>
>




>





>
>
>







14392
14393
14394
14395
14396
14397
14398
14399
14400
14401
14402
14403
14404
14405
14406
14407
14408
14409
14410
14411
14412
14413
14414
14415
14416
14417
14418
14419
14420
14421
14422
14423
14424
14425
14426
14427
14428
14429
14430
14431
14432
14433
14434
14435
14436
14437
14438
14439
14440
14441
14442
14443
14444
14445
14446
14447
14448
14449
14450
14451
14452
14453
14454
14455
14456
14457
14458
14459
14460
14461
14462
14463
14464
14465
14466
14467
14468
14469
14470
14471
14472
14473
14474
14475
14476
14477
14478
14479
14480
14481
14482
14483
14484
14485
14486
14487
14488
14489
14490
14491
14492
14493
14494
14495
14496
14497
14498
14499
14500
14501
14502
14503
14504
14505
14506
14507
14508
14509
14510
14511
14512
14513
14514
14515
14516
14517
14518
14519
14520
14521
14522
14523
14524
14525
14526
14527
14528
14529
14530
14531
14532
14533
14534
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char $ac_func ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
choke me
#else
char (*f) () = $ac_func;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done


#--------------------------------------------------------------------
# Check for support of getattrlist function (Darwin, HFS+)
#--------------------------------------------------------------------


for ac_func in getattrlist
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
#define $ac_func innocuous_$ac_func

/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */

#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif

#undef $ac_func

/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
13139
13140
13141
13142
13143
13144
13145
13146
13147



13148
13149







13150
13151
13152
13153
13154
13155
13156
13157
13158
13159
13160
13161
13162
13163
13164
13165
13166
13167
13168
13169
13170
13171
13172
13173
13174
13175
13176
13177
13178
13179
13180
13181
13182
13183
13184
13185
13186
13187
13188
13189
13190
13191
13192
13193
13194
13195
13196
13197
13198
13199
13200
13201
13202
13203
13204
13205
13206
13207
13208
13209
13210
13211
13212
13213
13214
13215
13216
13217
13218
13219
13220
13221
13222
13223
13224
13225
13226
13227
13228
13229
13230
13231
13232
13233
13234
13235
13236
13237
13238
13239
13240
13241
13242
13243
13244
13245
13246
13247
13248
13249
13250
13251
13252
13253
13254
13255
13256
13257
13258
13259
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF

fi
done


#--------------------------------------------------------------------
# Check for support of getattrlist function (Darwin, HFS+)
#--------------------------------------------------------------------


for ac_func in getattrlist
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func (); below.
    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
    <limits.h> exists even on freestanding compilers.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
   builtin and then its argument prototype would still apply.  */
char $ac_func ();
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
choke me
#else
char (*f) () = $ac_func;
#endif
#ifdef __cplusplus
}
#endif

int
main ()
{
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
         { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi
rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







14551
14552
14553
14554
14555
14556
14557
14558
14559
14560
14561
14562
14563
14564
14565
14566
14567
14568
14569
14570
14571
14572
14573
14574
14575
14576
14577
14578
14579
14580
14581
14582
14583
14584


























14585






























































14586
14587
14588
14589
14590
14591
14592
14593
return f != $ac_func;
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest$ac_exeext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_var=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_var=no"
fi


























rm -f conftest.err conftest.$ac_objext \






























































      conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
13283
13284
13285
13286
13287
13288
13289
13290
13291
13292
13293
13294
13295
13296
13297
13298
13299
13300
13301
13302



13303
13304







13305
13306
13307
13308
13309
13310
13311
13312
13313
13314
13315
13316
13317
13318
13319
13320
13321
13322
13323
13324
13325
13326
13327
13328
13329
13330
13331
13332
13333
13334
13335
13336
13337
13338
13339
13340
13341
13342
13343

13344
13345
13346
13347
13348
13349
13350
13351
13352
13353
13354
13355
13356
13357
13358
13359
13360
13361
13362
13363
13364
13365
13366
13367
13368
13369
13370
13371
13372
13373
13374
13375
13376

13377
13378
13379
13380


13381
13382


13383
13384


13385
13386
13387
13388
13389
13390
13391
13392
13393
13394
13395
13396
13397
13398
13399
13400
13401
13402
13403
13404
13405
13406
13407
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|










|







14617
14618
14619
14620
14621
14622
14623

14624
14625
14626
14627
14628
14629
14630
14631
14632
14633
14634
14635
14636
14637
14638
14639
14640
14641
14642
14643
14644
14645
14646
14647
14648
14649
14650
14651
14652
14653
14654
14655
14656
14657
14658
14659
14660
14661
14662
14663
14664
14665
14666
14667
14668

14669
14670
14671
14672
14673
14674
14675
14676
14677
14678
14679
14680
14681
14682
14683
14684
14685
14686
14687
14688
14689
14690
14691
14692
14693
14694
14695
14696
14697
14698
14699
14700
14701
14702
14703
14704
14705
14706
14707
14708
14709
14710
14711








14712
14713
14714
14715
14716
14717
14718
14719
14720
14721
14722
14723
14724
14725
14726
14727
14728
14729
14730
14731
14732
14733
14734
14735
14736
14737
14738
14739
14740
14741
14742
14743
14744
14745
14746
14747
14748
14749
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=\$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
13425
13426
13427
13428
13429
13430
13431
13432
13433
13434
13435
13436
13437
13438
13439
13440
13441
13442
13443
13444



13445
13446







13447
13448
13449
13450
13451
13452
13453
13454
13455
13456
13457
13458
13459
13460
13461
13462
13463
13464
13465
13466
13467
13468
13469
13470
13471
13472
13473
13474
13475
13476
13477
13478
13479
13480
13481
13482
13483
13484
13485

13486
13487
13488
13489
13490
13491
13492
13493
13494
13495
13496
13497
13498
13499
13500
13501
13502
13503
13504
13505
13506
13507
13508
13509
13510
13511
13512
13513
13514
13515
13516
13517
13518

13519
13520
13521
13522


13523
13524


13525
13526


13527
13528
13529
13530
13531
13532
13533
13534
13535
13536
13537
13538
13539
13540
13541
13542
13543
13544
13545
13546
13547
13548
13549
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|










|







14767
14768
14769
14770
14771
14772
14773

14774
14775
14776
14777
14778
14779
14780
14781
14782
14783
14784
14785
14786
14787
14788
14789
14790
14791
14792
14793
14794
14795
14796
14797
14798
14799
14800
14801
14802
14803
14804
14805
14806
14807
14808
14809
14810
14811
14812
14813
14814
14815
14816
14817
14818

14819
14820
14821
14822
14823
14824
14825
14826
14827
14828
14829
14830
14831
14832
14833
14834
14835
14836
14837
14838
14839
14840
14841
14842
14843
14844
14845
14846
14847
14848
14849
14850
14851
14852
14853
14854
14855
14856
14857
14858
14859
14860
14861








14862
14863
14864
14865
14866
14867
14868
14869
14870
14871
14872
14873
14874
14875
14876
14877
14878
14879
14880
14881
14882
14883
14884
14885
14886
14887
14888
14889
14890
14891
14892
14893
14894
14895
14896
14897
14898
14899
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking $ac_header usability" >&5
echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking $ac_header presence" >&5
echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <$ac_header>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------ ##
## Report this to the tcl lists.  ##
## ------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  eval "$as_ac_Header=\$ac_header_preproc"
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6

fi
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
13609
13610
13611
13612
13613
13614
13615

















13616
13617
13618
13619
13620
13621
13622
13623
13624
13625
















13626
13627
13628
13629
13630
13631
13632
	    ;;
	*)
	    echo "$as_me:$LINENO: result: O_NONBLOCK" >&5
echo "${ECHO_T}O_NONBLOCK" >&6
	    ;;
    esac



















#--------------------------------------------------------------------
#	The statements below define a collection of symbols related to
#	building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------

TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"


















    echo "$as_me:$LINENO: checking how to package libraries" >&5
echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6
    # Check whether --enable-framework or --disable-framework was given.
if test "${enable_framework+set}" = set; then
  enableval="$enable_framework"
  tcl_ok=$enableval







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







14959
14960
14961
14962
14963
14964
14965
14966
14967
14968
14969
14970
14971
14972
14973
14974
14975
14976
14977
14978
14979
14980
14981
14982
14983
14984
14985
14986
14987
14988
14989
14990
14991
14992
14993
14994
14995
14996
14997
14998
14999
15000
15001
15002
15003
15004
15005
15006
15007
15008
15009
15010
15011
15012
15013
15014
15015
	    ;;
	*)
	    echo "$as_me:$LINENO: result: O_NONBLOCK" >&5
echo "${ECHO_T}O_NONBLOCK" >&6
	    ;;
    esac


#------------------------------------------------------------------------

# Check whether --enable-dll-unloading or --disable-dll-unloading was given.
if test "${enable_dll_unloading+set}" = set; then
  enableval="$enable_dll_unloading"
  tcl_ok=$enableval
else
  tcl_ok=yes
fi;
if test $tcl_ok = yes; then

cat >>confdefs.h <<\_ACEOF
#define TCL_UNLOAD_DLLS 1
_ACEOF

fi

#--------------------------------------------------------------------
#	The statements below define a collection of symbols related to
#	building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------

TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"

# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).

eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)'
PRIVATE_INCLUDE_DIR='$(includedir)'
HTML_DIR='$(DISTDIR)/html'

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "`uname -s`" = "Darwin" ; then

    echo "$as_me:$LINENO: checking how to package libraries" >&5
echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6
    # Check whether --enable-framework or --disable-framework was given.
if test "${enable_framework+set}" = set; then
  enableval="$enable_framework"
  tcl_ok=$enableval
13646
13647
13648
13649
13650
13651
13652





13653
13654
13655
13656
13657
13658
13659
13660
13661
13662
13663
13664
13665
13666
13667
13668
13669
13670
13671
13672
13673
13674
13675
13676
13677
13678
13679
13680

































13681
13682
13683
13684
13685
13686
13687
13688
13689
13690
13691
13692
13693
13694
13695
13696
13697
13698
13699
13700
13701

13702
13703
13704
13705
13706
13707
13708
13709
13710
13711
13712
13713
13714
13715
13716
13717
13718

13719
13720
13721
13722
13723







13724
13725
13726
13727
13728
13729
13730


13731
13732
13733

13734
13735
13736
13737
13738
13739
13740
13741
13742
13743
13744
13745
13746
13747
13748
13749
13750
13751
13752
13753
13754
13755
13756
13757
13758
13759
13760
13761
13762
13763
13764
13765
13766
13767
13768
13769
13770
13771
13772
echo "${ECHO_T}framework" >&6
	FRAMEWORK_BUILD=1
	if test "${SHARED_BUILD}" = "0" ; then
	    { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&5
echo "$as_me: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&2;}
	    FRAMEWORK_BUILD=0
	fi





    else
	echo "$as_me:$LINENO: result: standard shared library" >&5
echo "${ECHO_T}standard shared library" >&6
	FRAMEWORK_BUILD=0
    fi


# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.

# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-framework Tcl"
    TCL_LIB_FILE="Tcl"

cat >>confdefs.h <<\_ACEOF
#define TCL_FRAMEWORK 1
_ACEOF


































elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
    if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
        TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
    else
        TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
    fi
    TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
    TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
else
    TCL_BUILD_EXP_FILE="lib.exp"
    eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"

    # Replace DBGX with TCL_DBGX
    eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\""

    if test "$GCC" = "yes" ; then
	TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
	TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
    else
	TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
	TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"

    fi
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}"
VERSION=${TCL_VERSION}

#--------------------------------------------------------------------
#	The statements below define the symbol TCL_PACKAGE_PATH, which
#	gives a list of directories that may contain packages.  The list
#	consists of one directory for machine-dependent binaries and
#	another for platform-independent scripts.
#--------------------------------------------------------------------

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_PACKAGE_PATH="${libdir}/Resources/Scripts"

elif test "$prefix/lib" != "$libdir"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
    TCL_PACKAGE_PATH="${prefix}/lib"
fi








#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}


eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""


if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"

# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""

#------------------------------------------------------------------------

# Check whether --enable-dll-unloading or --disable-dll-unloading was given.
if test "${enable_dll_unloading+set}" = set; then
  enableval="$enable_dll_unloading"
  tcl_ok=$enableval
else
  tcl_ok=yes
fi;
if test $tcl_ok = yes; then

cat >>confdefs.h <<\_ACEOF
#define TCL_UNLOAD_DLLS 1
_ACEOF

fi

#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------

TCL_SHARED_BUILD=${SHARED_BUILD}









>
>
>
>
>






|
<
<
|
<
<
<
|
<
<
<
<


<
<
<





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|

<
<
<
|
|
|
|
|
|
>
















|
>





>
>
>
>
>
>
>







>
>

<

>


|

|



|

|




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







15029
15030
15031
15032
15033
15034
15035
15036
15037
15038
15039
15040
15041
15042
15043
15044
15045
15046
15047


15048



15049




15050
15051



15052
15053
15054
15055
15056
15057
15058
15059
15060
15061
15062
15063
15064
15065
15066
15067
15068
15069
15070
15071
15072
15073
15074
15075
15076
15077
15078
15079
15080
15081
15082
15083
15084
15085
15086
15087
15088
15089
15090
15091
15092
15093
15094
15095
15096
15097
15098
15099
15100
15101



15102
15103
15104
15105
15106
15107
15108
15109
15110
15111
15112
15113
15114
15115
15116
15117
15118
15119
15120
15121
15122
15123
15124
15125
15126
15127
15128
15129
15130
15131
15132
15133
15134
15135
15136
15137
15138
15139
15140
15141
15142
15143
15144
15145
15146
15147
15148

15149
15150
15151
15152
15153
15154
15155
15156
15157
15158
15159
15160
15161
15162
15163
15164
15165

















15166
15167
15168
15169
15170
15171
15172
echo "${ECHO_T}framework" >&6
	FRAMEWORK_BUILD=1
	if test "${SHARED_BUILD}" = "0" ; then
	    { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&5
echo "$as_me: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&2;}
	    FRAMEWORK_BUILD=0
	fi
	if test $tcl_corefoundation = no; then
	    { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be used when CoreFoundation is available\"" >&5
echo "$as_me: WARNING: \"Frameworks can only be used when CoreFoundation is available\"" >&2;}
	    FRAMEWORK_BUILD=0
	fi
    else
	echo "$as_me:$LINENO: result: standard shared library" >&5
echo "${ECHO_T}standard shared library" >&6
	FRAMEWORK_BUILD=0
    fi

    TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`"


    TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000'



fi





if test "$FRAMEWORK_BUILD" = "1" ; then




cat >>confdefs.h <<\_ACEOF
#define TCL_FRAMEWORK 1
_ACEOF

              ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in"

    # Construct a fake local framework structure to make linking with
    # '-framework Tcl' and running of tcltest work
              ac_config_commands="$ac_config_commands Tcl.framework"

    LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
    if test "${libdir}" = '${exec_prefix}/lib'; then
        # override libdir default
        libdir="/Library/Frameworks"
    fi
    TCL_LIB_FILE="Tcl"
    TCL_LIB_FLAG="-framework Tcl"
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-F${libdir} -framework Tcl"
    libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
    TCL_LIBRARY="${libdir}/Resources/Scripts"
    includedir="${libdir}/Headers"
    PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
    HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
    EXTRA_INSTALL="install-private-headers html-tcl"
    EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html'
    EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
    EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
    TCL_YEAR="`date +%Y`"
    # Don't use AC_DEFINE for the following as the framework version define
    # needs to go into the Makefile even when using autoheader, so that we
    # can pick up a potential make override of VERSION. Also, don't put this
    # into CFLAGS as it should not go into tclConfig.sh
    EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
    # libdir must be a fully qualified path and not ${exec_prefix}/lib
    eval libdir="$libdir"
    if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
        if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
            TCL_LIB_FLAG="-ltcl${TCL_VERSION}"
        else
            TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`"
        fi
        TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
        TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
    else
        TCL_BUILD_EXP_FILE="lib.exp"
        eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"




        if test "$GCC" = "yes" ; then
            TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
            TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
        else
            TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
            TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"
        fi
    fi
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}"
VERSION=${TCL_VERSION}

#--------------------------------------------------------------------
#	The statements below define the symbol TCL_PACKAGE_PATH, which
#	gives a list of directories that may contain packages.  The list
#	consists of one directory for machine-dependent binaries and
#	another for platform-independent scripts.
#--------------------------------------------------------------------

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks"
    TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
    TCL_PACKAGE_PATH="${prefix}/lib"
fi

# If a system share directory like /usr/local/share already exists, then add
# it to the package search path.

if test -d "${prefix}/share" ; then
    TCL_PACKAGE_PATH="${TCL_PACKAGE_PATH} ${prefix}/share"
fi

#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"

eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=${libdir}"

if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}"

# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""


















#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------

TCL_SHARED_BUILD=${SHARED_BUILD}


13784
13785
13786
13787
13788
13789
13790
13791
13792
13793






13794
13795
13796
13797
13798
13799
13800







cat >>confdefs.h <<_ACEOF
#define TCL_DBGX ${TCL_DBGX}
_ACEOF




















|
|
|
>
>
>
>
>
>







15184
15185
15186
15187
15188
15189
15190
15191
15192
15193
15194
15195
15196
15197
15198
15199
15200
15201
15202
15203
15204
15205
15206























13810
13811
13812
13813
13814
13815
13816

13817
13818
13819
13820
13821
13822
13823






                              ac_config_files="$ac_config_files Makefile dltest/Makefile tclConfig.sh"

cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs, see configure's option --config-cache.
# It is not useful on other systems.  If it contains results you don't
# want to keep, you may remove or edit it.
#







>







15216
15217
15218
15219
15220
15221
15222
15223
15224
15225
15226
15227
15228
15229
15230






                              ac_config_files="$ac_config_files Makefile dltest/Makefile tclConfig.sh"

cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs, see configure's option --config-cache.
# It is not useful on other systems.  If it contains results you don't
# want to keep, you may remove or edit it.
#
13838
13839
13840
13841
13842
13843
13844
13845
13846
13847
13848
13849
13850
13851
13852
13853
13854
13855
13856
13857
13858
{
  (set) 2>&1 |
    case `(ac_space=' '; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      # `set' does not quote correctly, so add quotes (double-quote
      # substitution turns \\\\ into \\, and sed turns \\ into \).
      sed -n \
        "s/'/'\\\\''/g;
    	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
      ;;
    *)
      # `set' quotes correctly as required by POSIX, so do not add quotes.
      sed -n \
        "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
} |
  sed '
     t clear
     : clear
     s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/







|
|




|







15245
15246
15247
15248
15249
15250
15251
15252
15253
15254
15255
15256
15257
15258
15259
15260
15261
15262
15263
15264
15265
{
  (set) 2>&1 |
    case `(ac_space=' '; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      # `set' does not quote correctly, so add quotes (double-quote
      # substitution turns \\\\ into \\, and sed turns \\ into \).
      sed -n \
	"s/'/'\\\\''/g;
	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
      ;;
    *)
      # `set' quotes correctly as required by POSIX, so do not add quotes.
      sed -n \
	"s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
} |
  sed '
     t clear
     : clear
     s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
13874
13875
13876
13877
13878
13879
13880
13881
13882
13883
13884
13885
13886
13887
13888
13889
13890
13891
13892
13893
13894
13895
13896
13897
13898
13899
13900
13901
13902
13903
13904
13905
13906
13907
13908
13909
13910
13911
13912
13913
13914
13915
13916
13917
13918
13919
13920
13921
13922
13923
13924
13925
13926
13927
13928
13929
13930
13931
13932
13933
13934
13935
13936
13937
13938
13939
13940
13941
13942
13943
13944
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'

# VPATH may cause trouble with some makes, so we remove $(srcdir),
# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
# trailing colons and then remove the whole line if VPATH becomes empty
# (actually we leave an empty line to preserve line numbers).
if test "x$srcdir" = x.; then
  ac_vpsub='/^[ 	]*VPATH[ 	]*=/{
s/:*\$(srcdir):*/:/;
s/:*\${srcdir}:*/:/;
s/:*@srcdir@:*/:/;
s/^\([^=]*=[ 	]*\):*/\1/;
s/:*$//;
s/^[^=]*=[ 	]*$//;
}'
fi

# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
#
# If the first sed substitution is executed (which looks for macros that
# take arguments), then we branch to the quote section.  Otherwise,
# look for a macro that doesn't take arguments.
cat >confdef2opt.sed <<\_ACEOF
t clear
: clear
s,^[ 	]*#[ 	]*define[ 	][ 	]*\([^ 	(][^ 	(]*([^)]*)\)[ 	]*\(.*\),-D\1=\2,g
t quote
s,^[ 	]*#[ 	]*define[ 	][ 	]*\([^ 	][^ 	]*\)[ 	]*\(.*\),-D\1=\2,g
t quote
d
: quote
s,[ 	`~#$^&*(){}\\|;'"<>?],\\&,g
s,\[,\\&,g
s,\],\\&,g
s,\$,$$,g
p
_ACEOF
# We use echo to avoid assuming a particular line-breaking character.
# The extra dot is to prevent the shell from consuming trailing
# line-breaks from the sub-command output.  A line-break within
# single-quotes doesn't work because, if this script is created in a
# platform that uses two characters for line-breaks (e.g., DOS), tr
# would break.
ac_LF_and_DOT=`echo; echo .`
DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
rm -f confdef2opt.sed


ac_libobjs=
ac_ltlibobjs=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
  # 1. Remove the extension, and $U if already installed.
  ac_i=`echo "$ac_i" |
         sed 's/\$U\././;s/\.o$//;s/\.obj$//'`
  # 2. Add them.
  ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext"
  ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs

LTLIBOBJS=$ac_ltlibobjs



: ${CONFIG_STATUS=./config.status}
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files $CONFIG_STATUS"
{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
echo "$as_me: creating $CONFIG_STATUS" >&6;}







|



|

|













|

|



|
















<
<
<
<
<
<
<
<
<
<
<
<
<
<







15281
15282
15283
15284
15285
15286
15287
15288
15289
15290
15291
15292
15293
15294
15295
15296
15297
15298
15299
15300
15301
15302
15303
15304
15305
15306
15307
15308
15309
15310
15311
15312
15313
15314
15315
15316
15317
15318
15319
15320
15321
15322
15323
15324
15325
15326
15327
15328
15329
15330














15331
15332
15333
15334
15335
15336
15337
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'

# VPATH may cause trouble with some makes, so we remove $(srcdir),
# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
# trailing colons and then remove the whole line if VPATH becomes empty
# (actually we leave an empty line to preserve line numbers).
if test "x$srcdir" = x.; then
  ac_vpsub='/^[	 ]*VPATH[	 ]*=/{
s/:*\$(srcdir):*/:/;
s/:*\${srcdir}:*/:/;
s/:*@srcdir@:*/:/;
s/^\([^=]*=[	 ]*\):*/\1/;
s/:*$//;
s/^[^=]*=[	 ]*$//;
}'
fi

# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
#
# If the first sed substitution is executed (which looks for macros that
# take arguments), then we branch to the quote section.  Otherwise,
# look for a macro that doesn't take arguments.
cat >confdef2opt.sed <<\_ACEOF
t clear
: clear
s,^[	 ]*#[	 ]*define[	 ][	 ]*\([^	 (][^	 (]*([^)]*)\)[	 ]*\(.*\),-D\1=\2,g
t quote
s,^[	 ]*#[	 ]*define[	 ][	 ]*\([^	 ][^	 ]*\)[	 ]*\(.*\),-D\1=\2,g
t quote
d
: quote
s,[	 `~#$^&*(){}\\|;'"<>?],\\&,g
s,\[,\\&,g
s,\],\\&,g
s,\$,$$,g
p
_ACEOF
# We use echo to avoid assuming a particular line-breaking character.
# The extra dot is to prevent the shell from consuming trailing
# line-breaks from the sub-command output.  A line-break within
# single-quotes doesn't work because, if this script is created in a
# platform that uses two characters for line-breaks (e.g., DOS), tr
# would break.
ac_LF_and_DOT=`echo; echo .`
DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
rm -f confdef2opt.sed


















: ${CONFIG_STATUS=./config.status}
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files $CONFIG_STATUS"
{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
echo "$as_me: creating $CONFIG_STATUS" >&6;}
13966
13967
13968
13969
13970
13971
13972

13973
13974
13975
13976
13977
13978
13979
13980
13981
13982
13983
13984
13985
13986
13987
13988
13989
13990
13991
13992
13993
13994
13995
13996
13997
13998
13999
14000
14001
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi


# Support unset when possible.
if (FOO=FOO; unset FOO) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.







>


|


















|







15359
15360
15361
15362
15363
15364
15365
15366
15367
15368
15369
15370
15371
15372
15373
15374
15375
15376
15377
15378
15379
15380
15381
15382
15383
15384
15385
15386
15387
15388
15389
15390
15391
15392
15393
15394
15395
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi
DUALCASE=1; export DUALCASE # for MKS sh

# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.
14166
14167
14168
14169
14170
14171
14172

14173
14174
14175
14176
14177
14178
14179
14180
14181
14182
14183
14184
14185
14186
14187
14188
14189
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else

  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"







>






|


|







15560
15561
15562
15563
15564
15565
15566
15567
15568
15569
15570
15571
15572
15573
15574
15575
15576
15577
15578
15579
15580
15581
15582
15583
15584
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else
  test -d ./-p && rmdir ./-p
  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"
14202
14203
14204
14205
14206
14207
14208
14209
14210
14211
14212
14213
14214
14215
14216
  sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
} >&5
cat >&5 <<_CSEOF

This file was extended by tcl $as_me 8.5, which was
generated by GNU Autoconf 2.57.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@








|







15597
15598
15599
15600
15601
15602
15603
15604
15605
15606
15607
15608
15609
15610
15611
  sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
} >&5
cat >&5 <<_CSEOF

This file was extended by tcl $as_me 8.5, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@

14246
14247
14248
14249
14250
14251
14252
14253
14254
14255
14256



14257
14258
14259
14260
14261
14262
14263
14264
14265
14266
14267
14268
14269
14270
14271
14272
14273
14274
14275

  -h, --help       print this help, then exit
  -V, --version    print version number, then exit
  -q, --quiet      do not print progress messages
  -d, --debug      don't remove temporary files
      --recheck    update $as_me by reconfiguring in the same conditions
  --file=FILE[:TEMPLATE]
                   instantiate the configuration file FILE

Configuration files:
$config_files




Report bugs to <[email protected]>."
_ACEOF

cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
tcl config.status 8.5
configured by $0, generated by GNU Autoconf 2.57,
  with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"

Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001
Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=$srcdir
_ACEOF

cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default







|



>
>
>







|


<
|







15641
15642
15643
15644
15645
15646
15647
15648
15649
15650
15651
15652
15653
15654
15655
15656
15657
15658
15659
15660
15661
15662
15663
15664

15665
15666
15667
15668
15669
15670
15671
15672

  -h, --help       print this help, then exit
  -V, --version    print version number, then exit
  -q, --quiet      do not print progress messages
  -d, --debug      don't remove temporary files
      --recheck    update $as_me by reconfiguring in the same conditions
  --file=FILE[:TEMPLATE]
		   instantiate the configuration file FILE

Configuration files:
$config_files

Configuration commands:
$config_commands

Report bugs to <[email protected]>."
_ACEOF

cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
tcl config.status 8.5
configured by $0, generated by GNU Autoconf 2.59,
  with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"


Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=$srcdir
_ACEOF

cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default
14350
14351
14352
14353
14354
14355
14356

14357






14358
14359
14360
14361
14362
14363
14364
14365

14366
14367
14368

14369
14370
14371
14372
14373
14374
14375
14376
14377
14378
14379
14380

14381
14382
14383
14384
14385
14386
14387
if \$ac_cs_recheck; then
  echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
  exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
fi

_ACEOF












cat >>$CONFIG_STATUS <<\_ACEOF
for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.

  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;
  "dltest/Makefile" ) CONFIG_FILES="$CONFIG_FILES dltest/Makefile" ;;
  "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;;

  *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
   { (exit 1); exit 1; }; };;
  esac
done

# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used.  Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
  test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files

fi

# Have a temporary directory for convenience.  Make it in the build tree
# simply because there is no reason to put it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# Create a temporary directory, and hook for its removal unless debugging.
$debug ||







>
|
>
>
>
>
>
>








>



>












>







15747
15748
15749
15750
15751
15752
15753
15754
15755
15756
15757
15758
15759
15760
15761
15762
15763
15764
15765
15766
15767
15768
15769
15770
15771
15772
15773
15774
15775
15776
15777
15778
15779
15780
15781
15782
15783
15784
15785
15786
15787
15788
15789
15790
15791
15792
15793
15794
if \$ac_cs_recheck; then
  echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
  exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
fi

_ACEOF

cat >>$CONFIG_STATUS <<_ACEOF
#
# INIT-COMMANDS section.
#

VERSION=${TCL_VERSION}

_ACEOF



cat >>$CONFIG_STATUS <<\_ACEOF
for ac_config_target in $ac_config_targets
do
  case "$ac_config_target" in
  # Handling of arguments.
  "Tcl-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;;
  "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;
  "dltest/Makefile" ) CONFIG_FILES="$CONFIG_FILES dltest/Makefile" ;;
  "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;;
  "Tcl.framework" ) CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;;
  *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
   { (exit 1); exit 1; }; };;
  esac
done

# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used.  Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
  test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
  test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands
fi

# Have a temporary directory for convenience.  Make it in the build tree
# simply because there is no reason to put it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# Create a temporary directory, and hook for its removal unless debugging.
$debug ||
14464
14465
14466
14467
14468
14469
14470

14471
14472
14473
14474
14475
14476
14477
14478
14479
14480
14481
14482
14483
14484
14485
14486
14487
14488
14489
14490
14491
14492
14493
14494
14495

14496
14497
14498
14499
14500
14501
14502
14503
14504
14505
14506
14507
14508
14509
14510
14511
14512
14513
14514
14515
14516
14517
14518
14519
14520
14521
14522



14523




14524
14525
14526
14527
14528
14529
14530
s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t
s,@AR@,$AR,;t t
s,@LIBOBJS@,$LIBOBJS,;t t
s,@TCL_LIBS@,$TCL_LIBS,;t t
s,@DL_LIBS@,$DL_LIBS,;t t
s,@DL_OBJS@,$DL_OBJS,;t t
s,@PLAT_OBJS@,$PLAT_OBJS,;t t

s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t
s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t
s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t
s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t
s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t
s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t
s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t
s,@STLIB_LD@,$STLIB_LD,;t t
s,@SHLIB_LD@,$SHLIB_LD,;t t
s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t
s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t
s,@SHLIB_LD_FLAGS@,$SHLIB_LD_FLAGS,;t t
s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t
s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t
s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t
s,@MAKE_LIB@,$MAKE_LIB,;t t
s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t
s,@INSTALL_LIB@,$INSTALL_LIB,;t t
s,@INSTALL_STUB_LIB@,$INSTALL_STUB_LIB,;t t
s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t
s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t
s,@TCL_VERSION@,$TCL_VERSION,;t t
s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t
s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t
s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t

s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t
s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t
s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t
s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t
s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t
s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t
s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t
s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t
s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t
s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t
s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t
s,@TCL_DBGX@,$TCL_DBGX,;t t
s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t
s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t
s,@CFG_TCL_EXPORT_FILE_SUFFIX@,$CFG_TCL_EXPORT_FILE_SUFFIX,;t t
s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t
s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t
s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t
s,@TCL_NEEDS_EXP_FILE@,$TCL_NEEDS_EXP_FILE,;t t
s,@TCL_BUILD_EXP_FILE@,$TCL_BUILD_EXP_FILE,;t t
s,@TCL_EXP_FILE@,$TCL_EXP_FILE,;t t
s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t
s,@TCL_SHARED_LIB_SUFFIX@,$TCL_SHARED_LIB_SUFFIX,;t t
s,@TCL_UNSHARED_LIB_SUFFIX@,$TCL_UNSHARED_LIB_SUFFIX,;t t
s,@TCL_HAS_LONGLONG@,$TCL_HAS_LONGLONG,;t t
s,@BUILD_DLTEST@,$BUILD_DLTEST,;t t
s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t



s,@LTLIBOBJS@,$LTLIBOBJS,;t t




CEOF

_ACEOF

  cat >>$CONFIG_STATUS <<\_ACEOF
  # Split the substitutions into bite-sized pieces for seds with
  # small command number limits, like on Digital OSF/1 and HP-UX.







>











<













>











<















>
>
>
|
>
>
>
>







15871
15872
15873
15874
15875
15876
15877
15878
15879
15880
15881
15882
15883
15884
15885
15886
15887
15888
15889

15890
15891
15892
15893
15894
15895
15896
15897
15898
15899
15900
15901
15902
15903
15904
15905
15906
15907
15908
15909
15910
15911
15912
15913
15914

15915
15916
15917
15918
15919
15920
15921
15922
15923
15924
15925
15926
15927
15928
15929
15930
15931
15932
15933
15934
15935
15936
15937
15938
15939
15940
15941
15942
15943
15944
s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t
s,@AR@,$AR,;t t
s,@LIBOBJS@,$LIBOBJS,;t t
s,@TCL_LIBS@,$TCL_LIBS,;t t
s,@DL_LIBS@,$DL_LIBS,;t t
s,@DL_OBJS@,$DL_OBJS,;t t
s,@PLAT_OBJS@,$PLAT_OBJS,;t t
s,@PLAT_SRCS@,$PLAT_SRCS,;t t
s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t
s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t
s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t
s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t
s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t
s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t
s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t
s,@STLIB_LD@,$STLIB_LD,;t t
s,@SHLIB_LD@,$SHLIB_LD,;t t
s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t
s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t

s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t
s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t
s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t
s,@MAKE_LIB@,$MAKE_LIB,;t t
s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t
s,@INSTALL_LIB@,$INSTALL_LIB,;t t
s,@INSTALL_STUB_LIB@,$INSTALL_STUB_LIB,;t t
s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t
s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t
s,@TCL_VERSION@,$TCL_VERSION,;t t
s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t
s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t
s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t
s,@TCL_YEAR@,$TCL_YEAR,;t t
s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t
s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t
s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t
s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t
s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t
s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t
s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t
s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t
s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t
s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t
s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t

s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t
s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t
s,@CFG_TCL_EXPORT_FILE_SUFFIX@,$CFG_TCL_EXPORT_FILE_SUFFIX,;t t
s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t
s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t
s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t
s,@TCL_NEEDS_EXP_FILE@,$TCL_NEEDS_EXP_FILE,;t t
s,@TCL_BUILD_EXP_FILE@,$TCL_BUILD_EXP_FILE,;t t
s,@TCL_EXP_FILE@,$TCL_EXP_FILE,;t t
s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t
s,@TCL_SHARED_LIB_SUFFIX@,$TCL_SHARED_LIB_SUFFIX,;t t
s,@TCL_UNSHARED_LIB_SUFFIX@,$TCL_UNSHARED_LIB_SUFFIX,;t t
s,@TCL_HAS_LONGLONG@,$TCL_HAS_LONGLONG,;t t
s,@BUILD_DLTEST@,$BUILD_DLTEST,;t t
s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t
s,@TCL_MODULE_PATH@,$TCL_MODULE_PATH,;t t
s,@TCL_LIBRARY@,$TCL_LIBRARY,;t t
s,@PRIVATE_INCLUDE_DIR@,$PRIVATE_INCLUDE_DIR,;t t
s,@HTML_DIR@,$HTML_DIR,;t t
s,@EXTRA_CC_SWITCHES@,$EXTRA_CC_SWITCHES,;t t
s,@EXTRA_INSTALL@,$EXTRA_INSTALL,;t t
s,@EXTRA_INSTALL_BINARIES@,$EXTRA_INSTALL_BINARIES,;t t
s,@EXTRA_BUILD_HTML@,$EXTRA_BUILD_HTML,;t t
CEOF

_ACEOF

  cat >>$CONFIG_STATUS <<\_ACEOF
  # Split the substitutions into bite-sized pieces for seds with
  # small command number limits, like on Digital OSF/1 and HP-UX.
14546
14547
14548
14549
14550
14551
14552
14553
14554
14555
14556
14557
14558
14559
14560
14561
14562
14563
14564
14565
14566
14567
14568
14569
14570
14571
14572
14573
14574
14575
14576
14577
14578
14579
14580
14581
14582
14583
14584
14585
14586
14587
14588
14589
14590
14591
14592
14593
14594
14595
14596
14597
14598
14599
14600
14601
14602
14603
14604
14605
14606























































































































































































14607
14608
14609
14610
14611
14612
14613
      # The purpose of the label and of the branching condition is to
      # speed up the sed processing (if there are no `@' at all, there
      # is no need to browse any of the substitutions).
      # These are the two extra sed commands mentioned above.
      (echo ':t
  /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed
      if test -z "$ac_sed_cmds"; then
  	ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed"
      else
  	ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed"
      fi
      ac_sed_frag=`expr $ac_sed_frag + 1`
      ac_beg=$ac_end
      ac_end=`expr $ac_end + $ac_max_sed_lines`
    fi
  done
  if test -z "$ac_sed_cmds"; then
    ac_sed_cmds=cat
  fi
fi # test -n "$CONFIG_FILES"

_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue
  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
  case $ac_file in
  - | *:- | *:-:* ) # input from stdin
        cat >$tmp/stdin
        ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
        ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
        ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  * )   ac_file_in=$ac_file.in ;;
  esac

  # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
  ac_dir=`(dirname "$ac_file") 2>/dev/null ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
         X"$ac_file" : 'X\(//\)[^/]' \| \
         X"$ac_file" : 'X\(//\)$' \| \
         X"$ac_file" : 'X\(/\)' \| \
         .     : '\(.\)' 2>/dev/null ||
echo X"$ac_file" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  { if $as_mkdir_p; then
    mkdir -p "$ac_dir"
  else
    as_dir="$ac_dir"
    as_dirs=
    while test ! -d "$as_dir"; do
      as_dirs="$as_dir $as_dirs"
      as_dir=`(dirname "$as_dir") 2>/dev/null ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
         X"$as_dir" : 'X\(//\)[^/]' \| \
         X"$as_dir" : 'X\(//\)$' \| \
         X"$as_dir" : 'X\(/\)' \| \
         .     : '\(.\)' 2>/dev/null ||























































































































































































echo X"$as_dir" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
    done







|

|

















|
|
|

|






|
|
|
|















|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







15960
15961
15962
15963
15964
15965
15966
15967
15968
15969
15970
15971
15972
15973
15974
15975
15976
15977
15978
15979
15980
15981
15982
15983
15984
15985
15986
15987
15988
15989
15990
15991
15992
15993
15994
15995
15996
15997
15998
15999
16000
16001
16002
16003
16004
16005
16006
16007
16008
16009
16010
16011
16012
16013
16014
16015
16016
16017
16018
16019
16020
16021
16022
16023
16024
16025
16026
16027
16028
16029
16030
16031
16032
16033
16034
16035
16036
16037
16038
16039
16040
16041
16042
16043
16044
16045
16046
16047
16048
16049
16050
16051
16052
16053
16054
16055
16056
16057
16058
16059
16060
16061
16062
16063
16064
16065
16066
16067
16068
16069
16070
16071
16072
16073
16074
16075
16076
16077
16078
16079
16080
16081
16082
16083
16084
16085
16086
16087
16088
16089
16090
16091
16092
16093
16094
16095
16096
16097
16098
16099
16100
16101
16102
16103
16104
16105
16106
16107
16108
16109
16110
16111
16112
16113
16114
16115
16116
16117
16118
16119
16120
16121
16122
16123
16124
16125
16126
16127
16128
16129
16130
16131
16132
16133
16134
16135
16136
16137
16138
16139
16140
16141
16142
16143
16144
16145
16146
16147
16148
16149
16150
16151
16152
16153
16154
16155
16156
16157
16158
16159
16160
16161
16162
16163
16164
16165
16166
16167
16168
16169
16170
16171
16172
16173
16174
16175
16176
16177
16178
16179
16180
16181
16182
16183
16184
16185
16186
16187
16188
16189
16190
16191
16192
16193
16194
16195
16196
16197
16198
16199
16200
16201
16202
16203
16204
16205
16206
16207
16208
16209
16210
      # The purpose of the label and of the branching condition is to
      # speed up the sed processing (if there are no `@' at all, there
      # is no need to browse any of the substitutions).
      # These are the two extra sed commands mentioned above.
      (echo ':t
  /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed
      if test -z "$ac_sed_cmds"; then
	ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed"
      else
	ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed"
      fi
      ac_sed_frag=`expr $ac_sed_frag + 1`
      ac_beg=$ac_end
      ac_end=`expr $ac_end + $ac_max_sed_lines`
    fi
  done
  if test -z "$ac_sed_cmds"; then
    ac_sed_cmds=cat
  fi
fi # test -n "$CONFIG_FILES"

_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue
  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
  case $ac_file in
  - | *:- | *:-:* ) # input from stdin
	cat >$tmp/stdin
	ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
	ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
	ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  * )   ac_file_in=$ac_file.in ;;
  esac

  # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
  ac_dir=`(dirname "$ac_file") 2>/dev/null ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$ac_file" : 'X\(//\)[^/]' \| \
	 X"$ac_file" : 'X\(//\)$' \| \
	 X"$ac_file" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$ac_file" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  { if $as_mkdir_p; then
    mkdir -p "$ac_dir"
  else
    as_dir="$ac_dir"
    as_dirs=
    while test ! -d "$as_dir"; do
      as_dirs="$as_dir $as_dirs"
      as_dir=`(dirname "$as_dir") 2>/dev/null ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$as_dir" : 'X\(//\)[^/]' \| \
	 X"$as_dir" : 'X\(//\)$' \| \
	 X"$as_dir" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$as_dir" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
    done
    test ! -n "$as_dirs" || mkdir $as_dirs
  fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5
echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;}
   { (exit 1); exit 1; }; }; }

  ac_builddir=.

if test "$ac_dir" != .; then
  ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
  # A "../" for each directory in $ac_dir_suffix.
  ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'`
else
  ac_dir_suffix= ac_top_builddir=
fi

case $srcdir in
  .)  # No --srcdir option.  We are building in place.
    ac_srcdir=.
    if test -z "$ac_top_builddir"; then
       ac_top_srcdir=.
    else
       ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'`
    fi ;;
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac

# Do not use `cd foo && pwd` to compute absolute paths, because
# the directories may not exist.
case `pwd` in
.) ac_abs_builddir="$ac_dir";;
*)
  case "$ac_dir" in
  .) ac_abs_builddir=`pwd`;;
  [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
  *) ac_abs_builddir=`pwd`/"$ac_dir";;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_builddir=${ac_top_builddir}.;;
*)
  case ${ac_top_builddir}. in
  .) ac_abs_top_builddir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
  *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_srcdir=$ac_srcdir;;
*)
  case $ac_srcdir in
  .) ac_abs_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
  *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_srcdir=$ac_top_srcdir;;
*)
  case $ac_top_srcdir in
  .) ac_abs_top_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
  *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
  esac;;
esac



  if test x"$ac_file" != x-; then
    { echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
    rm -f "$ac_file"
  fi
  # Let's still pretend it is `configure' which instantiates (i.e., don't
  # use $as_me), people would be surprised to read:
  #    /* config.h.  Generated by config.status.  */
  if test x"$ac_file" = x-; then
    configure_input=
  else
    configure_input="$ac_file.  "
  fi
  configure_input=$configure_input"Generated from `echo $ac_file_in |
				     sed 's,.*/,,'` by configure."

  # First look for the input files in the build tree, otherwise in the
  # src tree.
  ac_file_inputs=`IFS=:
    for f in $ac_file_in; do
      case $f in
      -) echo $tmp/stdin ;;
      [\\/$]*)
	 # Absolute (can't be DOS-style, as IFS=:)
	 test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
	 echo "$f";;
      *) # Relative
	 if test -f "$f"; then
	   # Build tree
	   echo "$f"
	 elif test -f "$srcdir/$f"; then
	   # Source tree
	   echo "$srcdir/$f"
	 else
	   # /dev/null tree
	   { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
	 fi;;
      esac
    done` || { (exit 1); exit 1; }
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
  sed "$ac_vpsub
$extrasub
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
:t
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
s,@configure_input@,$configure_input,;t t
s,@srcdir@,$ac_srcdir,;t t
s,@abs_srcdir@,$ac_abs_srcdir,;t t
s,@top_srcdir@,$ac_top_srcdir,;t t
s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t
s,@builddir@,$ac_builddir,;t t
s,@abs_builddir@,$ac_abs_builddir,;t t
s,@top_builddir@,$ac_top_builddir,;t t
s,@abs_top_builddir@,$ac_abs_top_builddir,;t t
" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out
  rm -f $tmp/stdin
  if test x"$ac_file" != x-; then
    mv $tmp/out $ac_file
  else
    cat $tmp/out
    rm -f $tmp/out
  fi

done
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF

#
# CONFIG_COMMANDS section.
#
for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue
  ac_dest=`echo "$ac_file" | sed 's,:.*,,'`
  ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'`
  ac_dir=`(dirname "$ac_dest") 2>/dev/null ||
$as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$ac_dest" : 'X\(//\)[^/]' \| \
	 X"$ac_dest" : 'X\(//\)$' \| \
	 X"$ac_dest" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$ac_dest" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  { if $as_mkdir_p; then
    mkdir -p "$ac_dir"
  else
    as_dir="$ac_dir"
    as_dirs=
    while test ! -d "$as_dir"; do
      as_dirs="$as_dir $as_dirs"
      as_dir=`(dirname "$as_dir") 2>/dev/null ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$as_dir" : 'X\(//\)[^/]' \| \
	 X"$as_dir" : 'X\(//\)$' \| \
	 X"$as_dir" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$as_dir" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
    done
14637
14638
14639
14640
14641
14642
14643
14644
14645


14646

14647
14648
14649
14650
14651
14652
14653
14654
14655
14656
14657
14658
14659
14660
14661
14662

14663
14664
14665
14666
14667
14668
14669
14670

14671
14672
14673
14674

14675
14676
14677
14678
14679
14680
14681
14682
14683
14684
14685
14686
14687
14688
14689
14690
14691
14692
14693
14694
14695
14696
14697
14698
14699
14700
14701
14702
14703
14704
14705
14706
14707

14708
14709
14710
14711
14712
14713
14714
14715
14716
14717
14718
14719
14720
14721











14722
14723
14724
14725
14726
14727
14728
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac
# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be
# absolute.


ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd`

ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd`
ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd`
ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd`



  if test x"$ac_file" != x-; then
    { echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
    rm -f "$ac_file"
  fi
  # Let's still pretend it is `configure' which instantiates (i.e., don't
  # use $as_me), people would be surprised to read:
  #    /* config.h.  Generated by config.status.  */
  if test x"$ac_file" = x-; then
    configure_input=

  else
    configure_input="$ac_file.  "
  fi
  configure_input=$configure_input"Generated from `echo $ac_file_in |
                                     sed 's,.*/,,'` by configure."

  # First look for the input files in the build tree, otherwise in the
  # src tree.

  ac_file_inputs=`IFS=:
    for f in $ac_file_in; do
      case $f in
      -) echo $tmp/stdin ;;

      [\\/$]*)
         # Absolute (can't be DOS-style, as IFS=:)
         test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
         echo $f;;
      *) # Relative
         if test -f "$f"; then
           # Build tree
           echo $f
         elif test -f "$srcdir/$f"; then
           # Source tree
           echo $srcdir/$f
         else
           # /dev/null tree
           { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
         fi;;
      esac
    done` || { (exit 1); exit 1; }
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
  sed "$ac_vpsub
$extrasub
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
:t
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
s,@configure_input@,$configure_input,;t t
s,@srcdir@,$ac_srcdir,;t t
s,@abs_srcdir@,$ac_abs_srcdir,;t t
s,@top_srcdir@,$ac_top_srcdir,;t t

s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t
s,@builddir@,$ac_builddir,;t t
s,@abs_builddir@,$ac_abs_builddir,;t t
s,@top_builddir@,$ac_top_builddir,;t t
s,@abs_top_builddir@,$ac_abs_top_builddir,;t t
" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out
  rm -f $tmp/stdin
  if test x"$ac_file" != x-; then
    mv $tmp/out $ac_file
  else
    cat $tmp/out
    rm -f $tmp/out
  fi












done
_ACEOF

cat >>$CONFIG_STATUS <<\_ACEOF

{ (exit 0); exit 0; }
_ACEOF







|
|
>
>
|
>
|
|
|
|
|
|
<
<
|
|
<
<
<
<
<
<
>
|
|
<
<
<
|
<
<
>
|
|
|
<
>
|
<
<
<
<
|
<
<
|
<
|
<
|
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
|
|
>
|
<
|
|
|
<
<
<
|
|
|
<
<

>
>
>
>
>
>
>
>
>
>
>







16234
16235
16236
16237
16238
16239
16240
16241
16242
16243
16244
16245
16246
16247
16248
16249
16250
16251
16252


16253
16254






16255
16256
16257



16258


16259
16260
16261
16262

16263
16264




16265


16266

16267

16268





16269
16270











16271
16272
16273
16274

16275
16276
16277



16278
16279
16280


16281
16282
16283
16284
16285
16286
16287
16288
16289
16290
16291
16292
16293
16294
16295
16296
16297
16298
16299
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac

# Do not use `cd foo && pwd` to compute absolute paths, because
# the directories may not exist.
case `pwd` in
.) ac_abs_builddir="$ac_dir";;
*)
  case "$ac_dir" in
  .) ac_abs_builddir=`pwd`;;
  [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
  *) ac_abs_builddir=`pwd`/"$ac_dir";;
  esac;;
esac


case $ac_abs_builddir in
.) ac_abs_top_builddir=${ac_top_builddir}.;;






*)
  case ${ac_top_builddir}. in
  .) ac_abs_top_builddir=$ac_abs_builddir;;



  [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;


  *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
  esac;;
esac
case $ac_abs_builddir in

.) ac_abs_srcdir=$ac_srcdir;;
*)




  case $ac_srcdir in


  .) ac_abs_srcdir=$ac_abs_builddir;;

  [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;

  *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;





  esac;;
esac











case $ac_abs_builddir in
.) ac_abs_top_srcdir=$ac_top_srcdir;;
*)
  case $ac_top_srcdir in

  .) ac_abs_top_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
  *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;



  esac;;
esac




  { echo "$as_me:$LINENO: executing $ac_dest commands" >&5
echo "$as_me: executing $ac_dest commands" >&6;}
  case $ac_dest in
    Tcl.framework ) n=Tcl &&
        f=$n.framework && v=Versions/$VERSION &&
        rm -rf $f && mkdir -p $f/$v/Resources &&
        ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v &&
        ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist &&
        unset n f v
     ;;
  esac
done
_ACEOF

cat >>$CONFIG_STATUS <<\_ACEOF

{ (exit 0); exit 0; }
_ACEOF

Changes to unix/configure.in.

1
2
3
4
5
6
7
8
9

10
11



12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
#! /bin/bash -norc
dnl	This file is an input file used by the GNU "autoconf" program to
dnl	generate the file "configure", which is run during Tcl installation
dnl	to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.123 2004/11/26 11:18:01 dkf Exp $

AC_INIT([tcl],[8.5])
AC_PREREQ(2.57)

dnl AC_CONFIG_HEADERS([tclConfig.h])
dnl AC_CONFIG_COMMANDS_PRE([DEFS=-DHAVE_TCL_CONFIG_H])




TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a2"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`

#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
SC_CONFIG_MANPAGES






|


|
>

|
>
>
>




|












<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32


33
34
35
36
37
38
39
#! /bin/bash -norc
dnl	This file is an input file used by the GNU "autoconf" program to
dnl	generate the file "configure", which is run during Tcl installation
dnl	to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.123.2.8 2005/08/25 15:47:07 dgp Exp $

AC_INIT([tcl],[8.5])
AC_PREREQ(2.59)

dnl AC_CONFIG_HEADERS([tclConfig.h])
dnl AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H  -imacros tclConfig.h"])
dnl AH_TOP([#ifndef _TCLCONFIG
dnl #define _TCLCONFIG])
dnl AH_BOTTOM([#endif /* _TCLCONFIG */])

TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a4"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi


TCL_SRC_DIR=`cd $srcdir/..; pwd`

#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
SC_CONFIG_MANPAGES

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
# The statements below define a collection of compile flags.  This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------

SC_CONFIG_CFLAGS

SC_ENABLE_SYMBOLS

TCL_DBGX=${DBGX}

#--------------------------------------------------------------------
#	Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------

SC_TCL_EARLY_FLAGS








|
<
<







104
105
106
107
108
109
110
111


112
113
114
115
116
117
118
# The statements below define a collection of compile flags.  This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------

SC_CONFIG_CFLAGS

SC_ENABLE_SYMBOLS(bccdebug)



#--------------------------------------------------------------------
#	Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------

SC_TCL_EARLY_FLAGS

424
425
426
427
428
429
430










431
432
433
434
435
436
437
438
439
440
441
442
443
444


445
446
447
448




449
450
451
452
453
454






455
456
457
458
459
460




461
462



463
464




465




























466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

498
499
500
501
502







503
504
505
506
507
508
509


510
511
512

513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546

547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582

583












584

#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.
#--------------------------------------------------------------------

SC_BLOCKING_STYLE











#--------------------------------------------------------------------
#	The statements below define a collection of symbols related to
#	building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------

TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"

SC_ENABLE_FRAMEWORK

# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.



# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"





# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.







if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-framework Tcl"
    TCL_LIB_FILE="Tcl"
    AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?])
elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then




    if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
        TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"



    else
        TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"




    fi




























    TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
    TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
else
    TCL_BUILD_EXP_FILE="lib.exp"
    eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"

    # Replace DBGX with TCL_DBGX
    eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\""
    
    if test "$GCC" = "yes" ; then
	TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
	TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
    else
	TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
	TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"

    fi
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}"
VERSION=${TCL_VERSION}

#--------------------------------------------------------------------
#	The statements below define the symbol TCL_PACKAGE_PATH, which
#	gives a list of directories that may contain packages.  The list
#	consists of one directory for machine-dependent binaries and
#	another for platform-independent scripts.
#--------------------------------------------------------------------

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_PACKAGE_PATH="${libdir}/Resources/Scripts"

elif test "$prefix/lib" != "$libdir"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
    TCL_PACKAGE_PATH="${prefix}/lib"
fi








#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}


eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""


if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"

# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""

#------------------------------------------------------------------------

AC_ARG_ENABLE(dll-unloading,
    [  --enable-dll-unloading  turn on the 'unload' command (default: on)],
    [tcl_ok=$enableval], [tcl_ok=yes])
if test $tcl_ok = yes; then
    AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi

#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------

TCL_SHARED_BUILD=${SHARED_BUILD}

AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)


AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
AC_SUBST(TCL_STUB_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_PATH)
AC_SUBST(TCL_INCLUDE_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_PATH)

AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_DBGX)
AC_DEFINE_UNQUOTED(TCL_DBGX,${TCL_DBGX},
    [What extra letters do we insert for debugging binary code?])
AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)

AC_SUBST(TCL_SHARED_BUILD)
AC_SUBST(LD_LIBRARY_PATH_VAR)

AC_SUBST(TCL_BUILD_LIB_SPEC)
AC_SUBST(TCL_NEEDS_EXP_FILE)
AC_SUBST(TCL_BUILD_EXP_FILE)
AC_SUBST(TCL_EXP_FILE)

AC_SUBST(TCL_LIB_VERSIONS_OK)
AC_SUBST(TCL_SHARED_LIB_SUFFIX)
AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)

AC_SUBST(TCL_HAS_LONGLONG)

AC_SUBST(BUILD_DLTEST)
AC_SUBST(TCL_PACKAGE_PATH)














AC_OUTPUT([Makefile dltest/Makefile tclConfig.sh])








>
>
>
>
>
>
>
>
>
>










<
<

<
>
>

<
<

>
>
>
>






>
>
>
>
>
>

<
<
<

<
>
>
>
>
|
<
>
>
>
|
|
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
<
<
<
|
|
|
|
|
|
>
















|
>





>
>
>
>
>
>
>







>
>

<

>


|

|



|

|




<
<
<
<
<
<
<
<
<










>













<
<
<




















>

>
>
>
>
>
>
>
>
>
>
>
>
|
>
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450


451

452
453
454


455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472



473

474
475
476
477
478

479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522



523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586









587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610



611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.
#--------------------------------------------------------------------

SC_BLOCKING_STYLE

#------------------------------------------------------------------------

AC_ARG_ENABLE(dll-unloading,
    AC_HELP_STRING([--enable-dll-unloading],
	[turn on the 'unload' command (default: on)]),
    [tcl_ok=$enableval], [tcl_ok=yes])
if test $tcl_ok = yes; then
    AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi

#--------------------------------------------------------------------
#	The statements below define a collection of symbols related to
#	building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------

TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"



# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed

# since on some platforms TCL_LIB_FILE contains shell escapes. 
# (See also: TCL_TRIM_DOTS).



eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)'
PRIVATE_INCLUDE_DIR='$(includedir)'
HTML_DIR='$(DISTDIR)/html'

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "`uname -s`" = "Darwin" ; then
    SC_ENABLE_FRAMEWORK
    TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`"
    TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000'
fi

if test "$FRAMEWORK_BUILD" = "1" ; then



    AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?])

    AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in])
    # Construct a fake local framework structure to make linking with
    # '-framework Tcl' and running of tcltest work
    AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl &&
        f=$n.framework && v=Versions/$VERSION &&

        rm -rf $f && mkdir -p $f/$v/Resources &&
        ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v &&
        ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist &&
        unset n f v
    ], VERSION=${TCL_VERSION})
    LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
    if test "${libdir}" = '${exec_prefix}/lib'; then
        # override libdir default
        libdir="/Library/Frameworks"
    fi
    TCL_LIB_FILE="Tcl"
    TCL_LIB_FLAG="-framework Tcl"
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-F${libdir} -framework Tcl"
    libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
    TCL_LIBRARY="${libdir}/Resources/Scripts"
    includedir="${libdir}/Headers"
    PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
    HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
    EXTRA_INSTALL="install-private-headers html-tcl"
    EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html' 
    EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
    EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
    TCL_YEAR="`date +%Y`"
    # Don't use AC_DEFINE for the following as the framework version define 
    # needs to go into the Makefile even when using autoheader, so that we  
    # can pick up a potential make override of VERSION. Also, don't put this
    # into CFLAGS as it should not go into tclConfig.sh
    EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
    # libdir must be a fully qualified path and not ${exec_prefix}/lib
    eval libdir="$libdir"
    if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
        if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
            TCL_LIB_FLAG="-ltcl${TCL_VERSION}"
        else
            TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`"
        fi
        TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
        TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
    else
        TCL_BUILD_EXP_FILE="lib.exp"
        eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"
    



        if test "$GCC" = "yes" ; then
            TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
            TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
        else
            TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
            TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"
        fi
    fi
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}"
VERSION=${TCL_VERSION}

#--------------------------------------------------------------------
#	The statements below define the symbol TCL_PACKAGE_PATH, which
#	gives a list of directories that may contain packages.  The list
#	consists of one directory for machine-dependent binaries and
#	another for platform-independent scripts.
#--------------------------------------------------------------------

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks"
    TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
    TCL_PACKAGE_PATH="${prefix}/lib"
fi

# If a system share directory like /usr/local/share already exists, then add
# it to the package search path.

if test -d "${prefix}/share" ; then
    TCL_PACKAGE_PATH="${TCL_PACKAGE_PATH} ${prefix}/share"
fi

#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"

eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=${libdir}"

if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}"

# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""










#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------

TCL_SHARED_BUILD=${SHARED_BUILD}

AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_YEAR)

AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
AC_SUBST(TCL_STUB_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_PATH)
AC_SUBST(TCL_INCLUDE_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_PATH)

AC_SUBST(TCL_SRC_DIR)



AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)

AC_SUBST(TCL_SHARED_BUILD)
AC_SUBST(LD_LIBRARY_PATH_VAR)

AC_SUBST(TCL_BUILD_LIB_SPEC)
AC_SUBST(TCL_NEEDS_EXP_FILE)
AC_SUBST(TCL_BUILD_EXP_FILE)
AC_SUBST(TCL_EXP_FILE)

AC_SUBST(TCL_LIB_VERSIONS_OK)
AC_SUBST(TCL_SHARED_LIB_SUFFIX)
AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)

AC_SUBST(TCL_HAS_LONGLONG)

AC_SUBST(BUILD_DLTEST)
AC_SUBST(TCL_PACKAGE_PATH)
AC_SUBST(TCL_MODULE_PATH)

AC_SUBST(TCL_LIBRARY)
AC_SUBST(PRIVATE_INCLUDE_DIR)
AC_SUBST(HTML_DIR)

AC_SUBST(EXTRA_CC_SWITCHES)
AC_SUBST(EXTRA_INSTALL)
AC_SUBST(EXTRA_INSTALL_BINARIES)
AC_SUBST(EXTRA_BUILD_HTML)

dnl	Disable the automake-friendly normalization of LIBOBJS
dnl	performed by autoconf 2.53 and later.  It's not correct for us.
define([_AC_LIBOBJS_NORMALIZE],[])
AC_CONFIG_FILES([Makefile dltest/Makefile tclConfig.sh])
AC_OUTPUT

Changes to unix/dltest/Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
# This Makefile is used to create several test cases for Tcl's load
# command.  It also illustrates how to take advantage of configuration
# exported by Tcl to set up Makefiles for shared libraries.
# RCS: @(#) $Id: Makefile.in,v 1.16 2004/11/12 20:27:29 das Exp $

TCL_DBGX =		@TCL_DBGX@
CC = @CC@
LIBS =			@TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@
AC_FLAGS =		@DEFS@
SHLIB_CFLAGS =		@SHLIB_CFLAGS@
SHLIB_LD =		@SHLIB_LD@
SHLIB_LD_LIBS =		@SHLIB_LD_LIBS@
SHLIB_SUFFIX =		@SHLIB_SUFFIX@



|

<







1
2
3
4
5

6
7
8
9
10
11
12
# This Makefile is used to create several test cases for Tcl's load
# command.  It also illustrates how to take advantage of configuration
# exported by Tcl to set up Makefiles for shared libraries.
# RCS: @(#) $Id: Makefile.in,v 1.16.2.1 2005/01/20 14:53:41 kennykb Exp $


CC = @CC@
LIBS =			@TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@
AC_FLAGS =		@DEFS@
SHLIB_CFLAGS =		@SHLIB_CFLAGS@
SHLIB_LD =		@SHLIB_LD@
SHLIB_LD_LIBS =		@SHLIB_LD_LIBS@
SHLIB_SUFFIX =		@SHLIB_SUFFIX@

Changes to unix/tcl.m4.

23
24
25
26
27
28
29


30

31
32
33
34
35







36
37
38
39
40
41
42
    # First, look for one uninstalled.
    # the alternative search directory is invoked by --with-tcl
    #

    if test x"${no_tcl}" = x ; then
	# we reset no_tcl in case something fails here
	no_tcl=true


	AC_ARG_WITH(tcl, [  --with-tcl              directory containing tcl configuration (tclConfig.sh)], with_tclconfig=${withval})

	AC_MSG_CHECKING([for Tcl configuration])
	AC_CACHE_VAL(ac_cv_c_tclconfig,[

	    # First check to see if --with-tcl was specified.
	    if test x"${with_tclconfig}" != x ; then







		if test -f "${with_tclconfig}/tclConfig.sh" ; then
		    ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)`
		else
		    AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh])
		fi
	    fi








>
>
|
>





>
>
>
>
>
>
>







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
    # First, look for one uninstalled.
    # the alternative search directory is invoked by --with-tcl
    #

    if test x"${no_tcl}" = x ; then
	# we reset no_tcl in case something fails here
	no_tcl=true
	AC_ARG_WITH(tcl,
	    AC_HELP_STRING([--with-tcl],
		[directory containing tcl configuration (tclConfig.sh)]),
	    with_tclconfig=${withval})
	AC_MSG_CHECKING([for Tcl configuration])
	AC_CACHE_VAL(ac_cv_c_tclconfig,[

	    # First check to see if --with-tcl was specified.
	    if test x"${with_tclconfig}" != x ; then
		case ${with_tclconfig} in
		    */tclConfig.sh )
			if test -f ${with_tclconfig}; then
			    AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself])
			    with_tclconfig=`echo ${with_tclconfig} | sed 's!/tclConfig\.sh$!!'`
			fi ;;
		esac
		if test -f "${with_tclconfig}/tclConfig.sh" ; then
		    ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)`
		else
		    AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh])
		fi
	    fi

127
128
129
130
131
132
133


134

135
136
137
138
139







140
141
142
143
144
145
146
    # First, look for one uninstalled.
    # the alternative search directory is invoked by --with-tk
    #

    if test x"${no_tk}" = x ; then
	# we reset no_tk in case something fails here
	no_tk=true


	AC_ARG_WITH(tk, [  --with-tk               directory containing tk configuration (tkConfig.sh)], with_tkconfig=${withval})

	AC_MSG_CHECKING([for Tk configuration])
	AC_CACHE_VAL(ac_cv_c_tkconfig,[

	    # First check to see if --with-tkconfig was specified.
	    if test x"${with_tkconfig}" != x ; then







		if test -f "${with_tkconfig}/tkConfig.sh" ; then
		    ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)`
		else
		    AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh])
		fi
	    fi








>
>
|
>





>
>
>
>
>
>
>







137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
    # First, look for one uninstalled.
    # the alternative search directory is invoked by --with-tk
    #

    if test x"${no_tk}" = x ; then
	# we reset no_tk in case something fails here
	no_tk=true
	AC_ARG_WITH(tk,
	    AC_HELP_STRING([--with-tk],
		[directory containing tk configuration (tkConfig.sh)]),
	    with_tkconfig=${withval})
	AC_MSG_CHECKING([for Tk configuration])
	AC_CACHE_VAL(ac_cv_c_tkconfig,[

	    # First check to see if --with-tkconfig was specified.
	    if test x"${with_tkconfig}" != x ; then
		case ${with_tkconfig} in
		    */tkConfig.sh )
			if test -f ${with_tkconfig}; then
			    AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself])
			    with_tkconfig=`echo ${with_tkconfig} | sed 's!/tkConfig\.sh$!!'`
			fi ;;
		esac
		if test -f "${with_tkconfig}/tkConfig.sh" ; then
		    ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)`
		else
		    AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh])
		fi
	    fi

247
248
249
250
251
252
253

254
255
256
257
258
259
260
        TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
        TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
        TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
    fi

    #
    # eval is required to do the TCL_DBGX substitution

    #

    eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
    eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
    eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""

    eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""







>







267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
        TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
        TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
        TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
    fi

    #
    # eval is required to do the TCL_DBGX substitution
    # (@@@ Is this still the case?)
    #

    eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
    eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
    eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""

    eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
301
302
303
304
305
306
307









































































308
309
310
311
312
313
314
    fi

    AC_SUBST(TK_VERSION)
    AC_SUBST(TK_BIN_DIR)
    AC_SUBST(TK_SRC_DIR)
    AC_SUBST(TK_LIB_FILE)
])










































































#------------------------------------------------------------------------
# SC_ENABLE_SHARED --
#
#	Allows the building of shared libraries
#
# Arguments:







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
    fi

    AC_SUBST(TK_VERSION)
    AC_SUBST(TK_BIN_DIR)
    AC_SUBST(TK_SRC_DIR)
    AC_SUBST(TK_LIB_FILE)
])

#------------------------------------------------------------------------
# SC_PROG_TCLSH
#	Locate a tclsh shell installed on the system path. This macro
#	will only find a Tcl shell that already exists on the system.
#	It will not find a Tcl shell in the Tcl build directory or
#	a Tcl shell that has been installed from the Tcl build directory.
#	If a Tcl shell can't be located on the PATH, then TCLSH_PROG will
#	be set to "". Extensions should take care not to create Makefile
#	rules that are run by default and depend on TCLSH_PROG. An
#	extension can't assume that an executable Tcl shell exists at
#	build time.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN(SC_PROG_TCLSH, [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [
	search_path=`echo ${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/tclsh[[8-9]]* 2> /dev/null` \
		    `ls -r $dir/tclsh* 2> /dev/null` ; do
		if test x"$ac_cv_path_tclsh" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_tclsh=$j
			break
		    fi
		fi
	    done
	done
    ])

    if test -f "$ac_cv_path_tclsh" ; then
	TCLSH_PROG="$ac_cv_path_tclsh"
	AC_MSG_RESULT($TCLSH_PROG)
    else
	# It is not an error if an installed version of Tcl can't be located.
	TCLSH_PROG=""
	AC_MSG_RESULT([No tclsh found on PATH])
    fi
    AC_SUBST(TCLSH_PROG)
])

#------------------------------------------------------------------------
# SC_BUILD_TCLSH
#	Determine the fully qualified path name of the tclsh executable
#	in the Tcl build directory. This macro will correctly determine
#	the name of the tclsh executable even if tclsh has not yet
#	been built in the build directory. The build tclsh must be used
#	when running tests from an extension build directory. It is not
#	correct to use the TCLSH_PROG in cases like this.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		BUILD_TCLSH
#------------------------------------------------------------------------

AC_DEFUN(SC_BUILD_TCLSH, [
    AC_MSG_CHECKING([for tclsh in Tcl build directory])
    BUILD_TCLSH=${TCL_BIN_DIR}/tclsh
    AC_MSG_RESULT($BUILD_TCLSH)
    AC_SUBST(BUILD_TCLSH)
])

#------------------------------------------------------------------------
# SC_ENABLE_SHARED --
#
#	Allows the building of shared libraries
#
# Arguments:
326
327
328
329
330
331
332

333
334
335
336
337
338
339
340
#	Sets the following vars:
#		SHARED_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_SHARED, [
    AC_MSG_CHECKING([how to build libraries])
    AC_ARG_ENABLE(shared,

	[  --enable-shared         build and link with shared libraries [--enable-shared]],
	[tcl_ok=$enableval], [tcl_ok=yes])

    if test "${enable_shared+set}" = set; then
	enableval="$enable_shared"
	tcl_ok=$enableval
    else
	tcl_ok=yes







>
|







420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
#	Sets the following vars:
#		SHARED_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_SHARED, [
    AC_MSG_CHECKING([how to build libraries])
    AC_ARG_ENABLE(shared,
	AC_HELP_STRING([--enable-shared],
	    [build and link with shared libraries (default: on)]),
	[tcl_ok=$enableval], [tcl_ok=yes])

    if test "${enable_shared+set}" = set; then
	enableval="$enable_shared"
	tcl_ok=$enableval
    else
	tcl_ok=yes
366
367
368
369
370
371
372

373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388




389
390
391
392
393
394
395
#	Sets the following vars:
#		FRAMEWORK_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_FRAMEWORK, [
    AC_MSG_CHECKING([how to package libraries])
    AC_ARG_ENABLE(framework,

	[  --enable-framework      package shared libraries in MacOSX frameworks [--disable-framework]],
	[tcl_ok=$enableval], [tcl_ok=no])

    if test "${enable_framework+set}" = set; then
	enableval="$enable_framework"
	tcl_ok=$enableval
    else
	tcl_ok=no
    fi

    if test "$tcl_ok" = "yes" ; then
	AC_MSG_RESULT([framework])
	FRAMEWORK_BUILD=1
	if test "${SHARED_BUILD}" = "0" ; then
	    AC_MSG_WARN("Frameworks can only be built if --enable-shared is yes")
	    FRAMEWORK_BUILD=0




	fi
    else
	AC_MSG_RESULT([standard shared library])
	FRAMEWORK_BUILD=0
    fi
])








>
|















>
>
>
>







461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
#	Sets the following vars:
#		FRAMEWORK_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_FRAMEWORK, [
    AC_MSG_CHECKING([how to package libraries])
    AC_ARG_ENABLE(framework,
	AC_HELP_STRING([--enable-framework],
	    [package shared libraries in MacOSX frameworks (default: off)]),
	[tcl_ok=$enableval], [tcl_ok=no])

    if test "${enable_framework+set}" = set; then
	enableval="$enable_framework"
	tcl_ok=$enableval
    else
	tcl_ok=no
    fi

    if test "$tcl_ok" = "yes" ; then
	AC_MSG_RESULT([framework])
	FRAMEWORK_BUILD=1
	if test "${SHARED_BUILD}" = "0" ; then
	    AC_MSG_WARN("Frameworks can only be built if --enable-shared is yes")
	    FRAMEWORK_BUILD=0
	fi
	if test $tcl_corefoundation = no; then
	    AC_MSG_WARN("Frameworks can only be used when CoreFoundation is available")
	    FRAMEWORK_BUILD=0
	fi
    else
	AC_MSG_RESULT([standard shared library])
	FRAMEWORK_BUILD=0
    fi
])

414
415
416
417
418
419
420
421


422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
#		_REENTRANT
#		_THREAD_SAFE
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_THREADS, [
    AC_MSG_CHECKING(for building with threads)
    AC_ARG_ENABLE(threads, [  --enable-threads        build with threads],


	[tcl_ok=$enableval], [tcl_ok=no])

    if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then
	if test "${TCL_THREADS}" = 1; then
	    AC_MSG_RESULT([yes (threaded core)])
	else
	    AC_MSG_RESULT([yes])
	fi
	TCL_THREADS=1
	AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?])
	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention
	AC_DEFINE(USE_THREAD_ALLOC, 1,
	    [Do we want to use the threaded memory allocator?])
	# USE_THREAD_STORAGE tells us to use the new generic thread 
	# storage subsystem. 
	AC_DEFINE(USE_THREAD_STORAGE, 1,
	    [Use the generic thread storage subsystem?])
	AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
	if test "`uname -s`" = "SunOS" ; then
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
		    [Do we really want to follow the standard? Yes we do!])
	fi
	AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?])
	AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)







|
>
>














<
<
<
<







514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537




538
539
540
541
542
543
544
#		_REENTRANT
#		_THREAD_SAFE
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_THREADS, [
    AC_MSG_CHECKING(for building with threads)
    AC_ARG_ENABLE(threads,
	AC_HELP_STRING([--enable-threads],
	    [build with threads (default: off)]),
	[tcl_ok=$enableval], [tcl_ok=no])

    if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then
	if test "${TCL_THREADS}" = 1; then
	    AC_MSG_RESULT([yes (threaded core)])
	else
	    AC_MSG_RESULT([yes])
	fi
	TCL_THREADS=1
	AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?])
	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention
	AC_DEFINE(USE_THREAD_ALLOC, 1,
	    [Do we want to use the threaded memory allocator?])




	AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
	if test "`uname -s`" = "SunOS" ; then
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
		    [Do we really want to follow the standard? Yes we do!])
	fi
	AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?])
	AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
		if test $tcl_cv_grep_pthread_getattr_np = missing ; then
		    AC_DEFINE(GETATTRNP_NOT_DECLARED, 1,
			[Is pthread_getattr_np declared in <pthread.h>?])
		fi
	    fi
	fi
	LIBS=$ac_saved_libs
	AC_CHECK_FUNCS(readdir_r)
	if test "x$ac_cv_func_readdir_r" = "xyes"; then
            AC_MSG_CHECKING([how many args readdir_r takes])
	    # IRIX 5.3 has a 2 arg version of readdir_r
	    # while other systems have a 3 arg version.
	    AC_CACHE_VAL(tcl_cv_two_arg_readdir_r,
	        AC_TRY_COMPILE([#include <stdlib.h>
#include <sys/types.h>
#ifdef NO_DIRENT_H
# include <sys/dir.h>  /* logic from tcl/compat/dirent.h *
# define dirent direct  *                                */
#else
# include <dirent.h>
#endif
], [readdir_r(NULL, NULL);],
	        tcl_cv_two_arg_readdir_r=yes, tcl_cv_two_arg_readdir_r=no))
	    AC_CACHE_VAL(tcl_cv_three_arg_readdir_r,
	        AC_TRY_COMPILE([#include <stdlib.h>
#include <sys/types.h>
#ifdef NO_DIRENT_H
# include <sys/dir.h>  /* logic from tcl/compat/dirent.h *
# define dirent direct  *                                */
#else
# include <dirent.h>
#endif
], [readdir_r(NULL, NULL, NULL);],
	        tcl_cv_three_arg_readdir_r=yes, tcl_cv_three_arg_readdir_r=no))
	    if test "x$tcl_cv_two_arg_readdir_r" = "xyes" ; then
                AC_MSG_RESULT([2])
	        AC_DEFINE(HAVE_TWO_ARG_READDIR_R)
	    elif test "x$tcl_cv_three_arg_readdir_r" = "xyes" ; then
                AC_MSG_RESULT([3])
	        AC_DEFINE(HAVE_THREE_ARG_READDIR_R)
	    else
	        AC_MSG_ERROR([unknown number of args for readdir_r])
	    fi
	fi
    else
	TCL_THREADS=0
	AC_MSG_RESULT([no (default)])
    fi
    AC_SUBST(TCL_THREADS)
])








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







608
609
610
611
612
613
614





































615
616
617
618
619
620
621
		if test $tcl_cv_grep_pthread_getattr_np = missing ; then
		    AC_DEFINE(GETATTRNP_NOT_DECLARED, 1,
			[Is pthread_getattr_np declared in <pthread.h>?])
		fi
	    fi
	fi
	LIBS=$ac_saved_libs





































    else
	TCL_THREADS=0
	AC_MSG_RESULT([no (default)])
    fi
    AC_SUBST(TCL_THREADS)
])

580
581
582
583
584
585
586
587

588
589
590
591
592
593



594

595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610

611
612
613
614
615
616

617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
#		--enable-symbols
#
#	Defines the following vars:
#		CFLAGS_DEFAULT	Sets to $(CFLAGS_DEBUG) if true
#				Sets to $(CFLAGS_OPTIMIZE) if false
#		LDFLAGS_DEFAULT	Sets to $(LDFLAGS_DEBUG) if true
#				Sets to $(LDFLAGS_OPTIMIZE) if false
#		DBGX		Debug library extension

#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_SYMBOLS, [
    AC_MSG_CHECKING([for build with symbols])
    AC_ARG_ENABLE(symbols, [  --enable-symbols        build with debugging symbols [--disable-symbols]],    [tcl_ok=$enableval], [tcl_ok=no])



# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.

    if test "$tcl_ok" = "no"; then
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
	DBGX=""
	AC_MSG_RESULT([no])
	AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?])
    else
	CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
	LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
	DBGX=g
	if test "$tcl_ok" = "yes"; then
	    AC_MSG_RESULT([yes (standard debugging)])
	fi
    fi
    AC_SUBST(CFLAGS_DEFAULT)
    AC_SUBST(LDFLAGS_DEFAULT)

    AC_DEFINE(TCL_CFG_DEBUG, 1, [Is debugging enabled?])

    if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
	AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?])
    fi


    if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
	AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?])
	AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?])
    fi

    if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
	if test "$tcl_ok" = "all"; then
	    AC_MSG_RESULT([enabled symbols mem compile debugging])
	else
	    AC_MSG_RESULT([enabled $tcl_ok debugging])
	fi
    fi
])

#------------------------------------------------------------------------







|
>





|
>
>
>

>



<





<






>






>
|
|
|
|



|







641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663

664
665
666
667
668

669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
#		--enable-symbols
#
#	Defines the following vars:
#		CFLAGS_DEFAULT	Sets to $(CFLAGS_DEBUG) if true
#				Sets to $(CFLAGS_OPTIMIZE) if false
#		LDFLAGS_DEFAULT	Sets to $(LDFLAGS_DEBUG) if true
#				Sets to $(LDFLAGS_OPTIMIZE) if false
#		DBGX		Formerly used as debug library extension;
#				always blank now.
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_SYMBOLS, [
    AC_MSG_CHECKING([for build with symbols])
    AC_ARG_ENABLE(symbols,
	AC_HELP_STRING([--enable-symbols],
	    [build with debugging symbols (default: off)]),
	[tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
    DBGX=""
    if test "$tcl_ok" = "no"; then
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'

	AC_MSG_RESULT([no])
	AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?])
    else
	CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
	LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'

	if test "$tcl_ok" = "yes"; then
	    AC_MSG_RESULT([yes (standard debugging)])
	fi
    fi
    AC_SUBST(CFLAGS_DEFAULT)
    AC_SUBST(LDFLAGS_DEFAULT)
    ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging?
    AC_DEFINE(TCL_CFG_DEBUG, 1, [Is debugging enabled?])

    if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
	AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?])
    fi

    ifelse($1,bccdebug,dnl Only enable 'compile' for the Tcl core itself
	if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
	    AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?])
	    AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?])
	fi)

    if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
	if test "$tcl_ok" = "all"; then
	    AC_MSG_RESULT([enabled symbols mem ]ifelse($1,bccdebug,[compile ])[debugging])
	else
	    AC_MSG_RESULT([enabled $tcl_ok debugging])
	fi
    fi
])

#------------------------------------------------------------------------
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
#	Defines the following vars:
#		HAVE_LANGINFO	Triggers use of nl_langinfo if defined.
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_LANGINFO, [
    AC_ARG_ENABLE(langinfo,
	[  --enable-langinfo	  use nl_langinfo if possible to determine
			  encoding at startup, otherwise use old heuristic],
	[langinfo_ok=$enableval], [langinfo_ok=yes])

    HAVE_LANGINFO=0
    if test "$langinfo_ok" = "yes"; then
	if test "$langinfo_ok" = "yes"; then
	    AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no])
	fi







|
|







711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
#	Defines the following vars:
#		HAVE_LANGINFO	Triggers use of nl_langinfo if defined.
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_LANGINFO, [
    AC_ARG_ENABLE(langinfo,
	AC_HELP_STRING([--enable-langinfo],
	    [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]),
	[langinfo_ok=$enableval], [langinfo_ok=yes])

    HAVE_LANGINFO=0
    if test "$langinfo_ok" = "yes"; then
	if test "$langinfo_ok" = "yes"; then
	    AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no])
	fi
695
696
697
698
699
700
701

702
703
704
705
706
707
708
709
710
711
712
713
714
715

716

717

718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733

734

735

736
737
738
739
740
741
742
743
744
745
746
#
#	Defines the following variable:
#
#	MAN_FLAGS -	The apropriate flags for installManPage
#			according to the user's selection.
#
#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_MANPAGES, [

	AC_MSG_CHECKING([whether to use symlinks for manpages])
	AC_ARG_ENABLE(man-symlinks,
		AC_HELP_STRING([--enable-man-symlinks],
			[use symlinks for the manpages]),
		test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks",
		enableval="no")
	AC_MSG_RESULT([$enableval])

	AC_MSG_CHECKING([whether to compress the manpages])
	AC_ARG_ENABLE(man-compression,
		AC_HELP_STRING([--enable-man-compression=PROG],
			[compress the manpages with PROG]),

		test "$enableval" = "yes" && AC_MSG_ERROR([missing argument to --enable-man-compression])

		test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --compress $enableval",

		enableval="no")
	AC_MSG_RESULT([$enableval])
	if test "$enableval" != "no"; then
		AC_MSG_CHECKING([for compressed file suffix])
		touch TeST
		$enableval TeST
		Z=`ls TeST* | sed 's/^....//'`
		rm -f TeST*
		MAN_FLAGS="$MAN_FLAGS --extension $Z"
		AC_MSG_RESULT([$Z])
	fi

	AC_MSG_CHECKING([whether to add a package name suffix for the manpages])
	AC_ARG_ENABLE(man-suffix,
		AC_HELP_STRING([--enable-man-suffix=STRING],
			  [use STRING as a suffix to manpage file names (default: AC_PACKAGE_NAME)]),

		test "$enableval" = "yes" && enableval="AC_PACKAGE_NAME"

		test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --suffix $enableval",

		enableval="no")
	AC_MSG_RESULT([$enableval])

	AC_SUBST(MAN_FLAGS)
])

#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
#	Try to determine the proper flags to pass to the compiler
#	for building shared libraries and other such nonsense.







>

<
|
|
|
|
|
|
|

|
|
|
|
>
|
>
|
>
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
>
|
>
|
>
|
|

|







761
762
763
764
765
766
767
768
769

770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
#
#	Defines the following variable:
#
#	MAN_FLAGS -	The apropriate flags for installManPage
#			according to the user's selection.
#
#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_MANPAGES, [

    AC_MSG_CHECKING([whether to use symlinks for manpages])
    AC_ARG_ENABLE(man-symlinks,
	AC_HELP_STRING([--enable-man-symlinks],
	    [use symlinks for the manpages (default: off)]),
	test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks",
	enableval="no")
    AC_MSG_RESULT([$enableval])

    AC_MSG_CHECKING([whether to compress the manpages])
    AC_ARG_ENABLE(man-compression,
	AC_HELP_STRING([--enable-man-compression=PROG],
	    [compress the manpages with PROG (default: off)]),
	[case $enableval in
	    yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);;
	    no)  ;;
	    *)   MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
	esac],
	enableval="no")
    AC_MSG_RESULT([$enableval])
    if test "$enableval" != "no"; then
	AC_MSG_CHECKING([for compressed file suffix])
	touch TeST
	$enableval TeST
	Z=`ls TeST* | sed 's/^....//'`
	rm -f TeST*
	MAN_FLAGS="$MAN_FLAGS --extension $Z"
	AC_MSG_RESULT([$Z])
    fi

    AC_MSG_CHECKING([whether to add a package name suffix for the manpages])
    AC_ARG_ENABLE(man-suffix,
	AC_HELP_STRING([--enable-man-suffix=STRING],
	    [use STRING as a suffix to manpage file names (default: no, AC_PACKAGE_NAME if enabled without specifying STRING)]),
	[case $enableval in
	    yes) enableval="AC_PACKAGE_NAME";;
	    no)  ;;
	    *)   MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
	esac],
	enableval="no")
    AC_MSG_RESULT([$enableval])

    AC_SUBST(MAN_FLAGS)
])

#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
#	Try to determine the proper flags to pass to the compiler
#	for building shared libraries and other such nonsense.
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
#       STLIB_LD -      Base command to use for combining object files
#                       into a static library.
#       SHLIB_CFLAGS -  Flags to pass to cc when compiling the components
#                       of a shared library (may request position-independent
#                       code, among other things).
#       SHLIB_LD -      Base command to use for combining object files
#                       into a shared library.
#       SHLIB_LD_FLAGS -Flags to pass when building a shared library. This
#                       differes from the SHLIB_CFLAGS as it is not used
#                       when building object files or executables.
#       SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
#                       creating shared libraries.  This symbol typically
#                       goes at the end of the "ld" commands that build
#                       shared libraries. The value of the symbol is
#                       "${LIBS}" if all of the dependent libraries should
#                       be specified when creating a shared library.  If
#                       dependent libraries should not be specified (as on







<
<
<







851
852
853
854
855
856
857



858
859
860
861
862
863
864
#       STLIB_LD -      Base command to use for combining object files
#                       into a static library.
#       SHLIB_CFLAGS -  Flags to pass to cc when compiling the components
#                       of a shared library (may request position-independent
#                       code, among other things).
#       SHLIB_LD -      Base command to use for combining object files
#                       into a shared library.



#       SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
#                       creating shared libraries.  This symbol typically
#                       goes at the end of the "ld" commands that build
#                       shared libraries. The value of the symbol is
#                       "${LIBS}" if all of the dependent libraries should
#                       be specified when creating a shared library.  If
#                       dependent libraries should not be specified (as on
839
840
841
842
843
844
845
846



847
848
849
850
851
852
853
854
855
856
857
858



859
860
861
862
863
864
865
#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_CFLAGS, [

    # Step 0.a: Enable 64 bit support?

    AC_MSG_CHECKING([if 64bit support is requested])
    AC_ARG_ENABLE(64bit,[  --enable-64bit          enable 64bit support (where applicable)],,enableval="no")




    if test "$enableval" = "yes"; then
	do64bit=yes
    else
	do64bit=no
    fi
    AC_MSG_RESULT($do64bit)

    # Step 0.b: Enable Solaris 64 bit VIS support?

    AC_MSG_CHECKING([if 64bit Sparc VIS support is requested])
    AC_ARG_ENABLE(64bit-vis,[  --enable-64bit-vis      enable 64bit Sparc VIS support],,enableval="no")




    if test "$enableval" = "yes"; then
	# Force 64bit on with VIS
	do64bit=yes
	do64bitVIS=yes
    else
	do64bitVIS=no







|
>
>
>











|
>
>
>







908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_CFLAGS, [

    # Step 0.a: Enable 64 bit support?

    AC_MSG_CHECKING([if 64bit support is requested])
    AC_ARG_ENABLE(64bit,
	AC_HELP_STRING([--enable-64bit],
	    [enable 64bit support (default: off)]),
	,enableval="no")

    if test "$enableval" = "yes"; then
	do64bit=yes
    else
	do64bit=no
    fi
    AC_MSG_RESULT($do64bit)

    # Step 0.b: Enable Solaris 64 bit VIS support?

    AC_MSG_CHECKING([if 64bit Sparc VIS support is requested])
    AC_ARG_ENABLE(64bit-vis,
	AC_HELP_STRING([--enable-64bit-vis],
	    [enable 64bit Sparc VIS support (default: off)]),
	,enableval="no")

    if test "$enableval" = "yes"; then
	# Force 64bit on with VIS
	do64bit=yes
	do64bitVIS=yes
    else
	do64bitVIS=no
929
930
931
932
933
934
935

936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
    AC_CHECK_PROG(AR, ar, ar)
    if test "${AR}" = "" ; then
	AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.])
    fi
    STLIB_LD='${AR} cr'
    LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
    PLAT_OBJS=""

    case $system in
	AIX-5.*)
	    if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		AC_MSG_RESULT(Using $CC for compiling with threads)
	    fi
	    LIBS="$LIBS -lc"
	    # AIX-5 uses ELF style dynamic libraries
	    SHLIB_CFLAGS=""
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    DL_OBJS="tclLoadDl.o"

	    LD_LIBRARY_PATH_VAR="LIBPATH"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		else 
		    do64bit_ok=yes
		    CFLAGS="$CFLAGS -q64"
		    LDFLAGS_ARCH="-q64"
		    RANLIB="${RANLIB} -X64"
		    AR="${AR} -X64"
		    SHLIB_LD_FLAGS="-b64"







>

|





|


<







<


|
|

|







1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021

1022
1023
1024
1025
1026
1027
1028

1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
    AC_CHECK_PROG(AR, ar, ar)
    if test "${AR}" = "" ; then
	AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.])
    fi
    STLIB_LD='${AR} cr'
    LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
    PLAT_OBJS=""
    PLAT_SRCS=""
    case $system in
	AIX-*)
	    if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		AC_MSG_RESULT([Using $CC for compiling with threads])
	    fi
	    LIBS="$LIBS -lc"

	    SHLIB_CFLAGS=""
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    DL_OBJS="tclLoadDl.o"

	    LD_LIBRARY_PATH_VAR="LIBPATH"

	    # Check to enable 64-bit flags for compiler/linker on AIX 4+
	    if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN([64bit mode not supported with GCC on $system])
		else 
		    do64bit_ok=yes
		    CFLAGS="$CFLAGS -q64"
		    LDFLAGS_ARCH="-q64"
		    RANLIB="${RANLIB} -X64"
		    AR="${AR} -X64"
		    SHLIB_LD_FLAGS="-b64"
976
977
978
979
980
981
982



983


984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
		if test "$GCC" = "yes" ; then
		    CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		else
		    CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
		fi
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    else



		SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}"


		DL_LIBS="-ldl"
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		TCL_NEEDS_EXP_FILE=1
		TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
	    fi
	    ;;
	AIX-*)
	    if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		AC_MSG_RESULT(Using $CC for compiling with threads)
	    fi
	    LIBS="$LIBS -lc"
	    SHLIB_CFLAGS=""
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    LD_LIBRARY_PATH_VAR="LIBPATH"
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		AC_LIBOBJ([tclLoadAix])
		DL_LIBS="-lld"
	    fi

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		else 
		    do64bit_ok=yes
		    CFLAGS="$CFLAGS -q64"
		    LDFLAGS_ARCH="-q64"
		    RANLIB="${RANLIB} -X64"
		    AR="${AR} -X64"
		    SHLIB_LD_FLAGS="-b64"
		fi
	    fi
	    SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}"

	    # On AIX <=v4 systems, libbsd.a has to be linked in to support
	    # non-blocking file IO.  This library has to be linked in after
	    # the MATH_LIBS or it breaks the pow() function.  The way to
	    # insure proper sequencing, is to add it to the tail of MATH_LIBS.
	    # This library also supplies gettimeofday.
	    #
	    # AIX does not have a timezone field in struct tm. When the AIX







>
>
>
|
>
>




|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068




















1069
1070
1071
1072
1073
1074
1075















1076
1077
1078
1079
1080
1081
1082
		if test "$GCC" = "yes" ; then
		    CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		else
		    CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
		fi
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    else
		if test "$GCC" = "yes" ; then
		    SHLIB_LD="gcc -shared"
		else
		    SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
		fi
		SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}"
		DL_LIBS="-ldl"
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		TCL_NEEDS_EXP_FILE=1
		TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp'
	    fi





















	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		AC_LIBOBJ([tclLoadAix])
		DL_LIBS="-lld"
	    fi
















	    # On AIX <=v4 systems, libbsd.a has to be linked in to support
	    # non-blocking file IO.  This library has to be linked in after
	    # the MATH_LIBS or it breaks the pow() function.  The way to
	    # insure proper sequencing, is to add it to the tail of MATH_LIBS.
	    # This library also supplies gettimeofday.
	    #
	    # AIX does not have a timezone field in struct tm. When the AIX
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="gcc -shared"
		SHLIB_LD_LIBS='${LIBS}'
		LD_SEARCH_FLAGS=''
		CC_SEARCH_FLAGS=''
	    fi

	    # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
	    #CFLAGS="$CFLAGS +DAportable"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    hpux_arch=`gcc -dumpmachine`
		    case $hpux_arch in
			hppa64*)
			    # 64-bit gcc in use.  Fix flags for GNU ld.
			    do64bit_ok=yes
			    SHLIB_LD="gcc -shared"
			    SHLIB_LD_LIBS='${LIBS}'
			    LD_SEARCH_FLAGS=''
			    CC_SEARCH_FLAGS=''
			    ;;
			*)
			    AC_MSG_WARN("64bit mode not supported with GCC on $system")
			    ;;
		    esac
		else
		    do64bit_ok=yes







|
<















|
|







1155
1156
1157
1158
1159
1160
1161
1162

1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="gcc -shared"
		SHLIB_LD_LIBS='${LIBS}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    fi

	    # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
	    #CFLAGS="$CFLAGS +DAportable"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    hpux_arch=`gcc -dumpmachine`
		    case $hpux_arch in
			hppa64*)
			    # 64-bit gcc in use.  Fix flags for GNU ld.
			    do64bit_ok=yes
			    SHLIB_LD="gcc -shared"
			    SHLIB_LD_LIBS='${LIBS}'
			    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
			    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
			    ;;
			*)
			    AC_MSG_WARN("64bit mode not supported with GCC on $system")
			    ;;
		    esac
		else
		    do64bit_ok=yes
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
		DL_LIBS="-ldld"
		LDFLAGS="$LDFLAGS -Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""







<
<
<
<
<
<
<
<
<
<
<
<







1200
1201
1202
1203
1204
1205
1206












1207
1208
1209
1210
1211
1212
1213
		DL_LIBS="-ldld"
		LDFLAGS="$LDFLAGS -Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
		LD_LIBRARY_PATH_VAR="SHLIB_PATH"
	    fi
	    ;;












	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364







1365
1366
1367
1368
1369
1370
1371

1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -Wl,-Bexport"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[[1-2]].*)
	    # Not available on all versions:  check for include file.
	    AC_CHECK_HEADER(dlfcn.h, [
		# NetBSD/SPARC needs -fPIC, -fpic will not do.
		SHLIB_CFLAGS="-fPIC"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
		AC_MSG_CHECKING(for ELF)
		AC_EGREP_CPP(yes, [
#ifdef __ELF__
	yes
#endif
		],
		    AC_MSG_RESULT(yes)
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so',
		    AC_MSG_RESULT(no)
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
		)
	    ], [
		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    ])

	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	OpenBSD-*)







	    SHLIB_LD="${CC} -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""

	    AC_MSG_CHECKING(for ELF)
	    AC_EGREP_CPP(yes, [
#ifdef __ELF__
	yes
#endif
	    ],
		[AC_MSG_RESULT(yes)
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'],
		[AC_MSG_RESULT(no)
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0']
	    )

	    # OpenBSD doesn't do version numbers with dots.
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'







<
<
|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<

|

|



>
>
>
>
>
>
>
|
|



|
|
>






|
|
|
|



|







1349
1350
1351
1352
1353
1354
1355


1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375











1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -Wl,-Bexport"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[[1-2]].*)


	    # NetBSD/SPARC needs -fPIC, -fpic will not do.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    AC_MSG_CHECKING(for ELF)
	    AC_EGREP_CPP(yes, [
#ifdef __ELF__
	yes
#endif
	    ],
		AC_MSG_RESULT(yes)
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so',
		AC_MSG_RESULT(no)
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0'
	    )












	    # Ancient FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	OpenBSD-*)
	    # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do.
	    case `machine` in
	    sparc|sparc64)
		SHLIB_CFLAGS="-fPIC";;
	    *)
		SHLIB_CFLAGS="-fpic";;
	    esac
	    SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0'
	    AC_MSG_CHECKING(for ELF)
	    AC_EGREP_CPP(yes, [
#ifdef __ELF__
	yes
#endif
	    ],
		AC_MSG_RESULT(yes)
		[ LDFLAGS=-Wl,-export-dynamic ],
		AC_MSG_RESULT(no)
		LDFLAGS=""
	    )

	    # OpenBSD doesn't do version numbers with dots.
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414

1415
1416
1417
1418







1419
1420
1421
1422
1423
1424








1425
1426
1427
1428


















1429
1430





1431
1432
1433
1434









1435
1436
1437
1438
1439
1440
1441
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS -pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Rhapsody-*|Darwin-*)

	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
	    TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
	    TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TK_LIB_FILE} -prebind -seg1addr 0xb000000"







	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"
	    PLAT_OBJS=\$\(MAC\_OSX_OBJS\)
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -prebind"








	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    CFLAGS_OPTIMIZE="-Os"
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"


















	    AC_DEFINE(MAC_OSX_TCL, 1, ["Is this a Mac I see before me?"])
	    AC_DEFINE(HAVE_CFBUNDLE, 1, [Do we have access to Mac bundles?])





	    AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?])
	    AC_DEFINE(TCL_DEFAULT_ENCODING,"utf-8",
		[Are we to override what our default encoding is?])
	    LIBS="$LIBS -framework CoreFoundation"









	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"







|
|




|
>


<
|
>
>
>
>
>
>
>



<

|
>
>
>
>
>
>
>
>


<

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>



<
>
>
>
>
>
>
>
>
>







1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443

1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454

1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466

1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495

1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
		LIBS=`echo $LIBS | sed s/-pthread//`
		CFLAGS="$CFLAGS -pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Darwin-*)
	    CFLAGS_OPTIMIZE="-Os"
	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS}"

	    AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [
	        hold_ldflags=$LDFLAGS
	        LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
	        AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no)
	        LDFLAGS=$hold_ldflags])
	    if test $tcl_cv_ld_single_module = yes; then
	        SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
	    fi
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"

	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -prebind -headerpad_max_install_names"
	    AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [
	        hold_ldflags=$LDFLAGS
	        LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
	        AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no)
	        LDFLAGS=$hold_ldflags])
	    if test $tcl_cv_ld_search_paths_first = yes; then
	        LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
	    fi
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""

	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
	    PLAT_OBJS='${MAC_OSX_OBJS}'
	    PLAT_SRCS='${MAC_OSX_SRCS}'
            AC_MSG_CHECKING([whether to use CoreFoundation])
            AC_ARG_ENABLE(corefoundation,
		AC_HELP_STRING([--enable-corefoundation],
		    [use CoreFoundation API on MacOSX (default: yes)]),
                [tcl_corefoundation=$enableval], [tcl_corefoundation=yes])
            AC_MSG_RESULT([$tcl_corefoundation])
            if test $tcl_corefoundation = yes; then
                AC_CACHE_CHECK([for CoreFoundation.framework], tcl_cv_lib_corefoundation, [
                    hold_libs=$LIBS
                    LIBS="$LIBS -framework CoreFoundation"
                    AC_TRY_LINK([#include <CoreFoundation/CoreFoundation.h>], 
                        [CFBundleRef b = CFBundleGetMainBundle();], 
                        tcl_cv_lib_corefoundation=yes, tcl_cv_lib_corefoundation=no)
                    LIBS=$hold_libs])
                if test $tcl_cv_lib_corefoundation = yes; then
                    LIBS="$LIBS -framework CoreFoundation"
                    AC_DEFINE(HAVE_COREFOUNDATION, 1, 
                        [Do we have access to Darwin CoreFoundation.framework ?])
                fi
	    fi
	    AC_CHECK_HEADERS(libkern/OSAtomic.h)
	    AC_CHECK_FUNCS(OSSpinLockLock)
	    AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?])
	    AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?])
	    AC_DEFINE(TCL_DEFAULT_ENCODING,"utf-8",
		[Are we to override what our default encoding is?])

	    AC_DEFINE(MODULE_SCOPE, __private_extern__, [Linker support for module scope symbols])
	    AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1, [Can this platform load code from memory?])
	    # prior to Darwin 7, realpath is not threadsafe, so don't
	    # use it when threads are enabled, c.f. bug # 711232:
	    AC_CHECK_FUNC(realpath)
	    if test "$ac_cv_func_realpath" = yes -a "${TCL_THREADS}" = 1 \
	            -a `uname -r | awk -F. '{print [$]1}'` -lt 7 ; then
	        ac_cv_func_realpath=no
	    fi
	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"







<
<
<
<
<
<
<
<
<
<
<







1587
1588
1589
1590
1591
1592
1593











1594
1595
1596
1597
1598
1599
1600
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;











	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583

1584
1585
1586
1587
1588
1589
1590
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[[0-6]]*)


	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
		[Do we really want to follow the standard? Yes we do!])







|
|


|
>







1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[[0-6]])
	    # Careful to not let 5.10+ fall into this case

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
		[Do we really want to follow the standard? Yes we do!])
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626

1627






1628
1629
1630
1631
1632
1633
1634
1635
1636
1637



1638





1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653









1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
		[Do we really want to follow the standard? Yes we do!])

	    SHLIB_CFLAGS="-KPIC"
    
	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then

			    AC_MSG_WARN("64bit mode not supported with GCC on $system")






			else
			    do64bit_ok=yes
			    if test "$do64bitVIS" = "yes" ; then
				CFLAGS="$CFLAGS -xarch=v9a"
			    	LDFLAGS_ARCH="-xarch=v9a"
			    else
				CFLAGS="$CFLAGS -xarch=v9"
			    	LDFLAGS_ARCH="-xarch=v9"
			    fi
			fi



		else





		    AC_MSG_WARN("64bit mode only supported sparcv9 system")
		fi
	    fi
	    
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}









	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="$LDFLAGS -Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    if test "$GCC" != "yes" ; then
		CFLAGS="$CFLAGS -DHAVE_TZSET -std1"
	    fi
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"







<








|





>
|
>
>
>
>
>
>










>
>
>
|
>
>
>
>
>
|














>
>
>
>
>
>
>
>
>





<
<
<
<
<
<
<
<
<
<
<
<
<
<







1665
1666
1667
1668
1669
1670
1671

1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741














1742
1743
1744
1745
1746
1747
1748
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
		[Do we really want to follow the standard? Yes we do!])

	    SHLIB_CFLAGS="-KPIC"

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then
			    if test "`gcc -dumpversion | awk -F. '{print [$]1}'`" -lt "3" ; then
				AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system])
			    else
				do64bit_ok=yes
				CFLAGS="$CFLAGS -m64 -mcpu=v9"
				LDFLAGS="$LDFLAGS -m64 -mcpu=v9"
				SHLIB_CFLAGS="-fPIC"
			    fi
			else
			    do64bit_ok=yes
			    if test "$do64bitVIS" = "yes" ; then
				CFLAGS="$CFLAGS -xarch=v9a"
			    	LDFLAGS_ARCH="-xarch=v9a"
			    else
				CFLAGS="$CFLAGS -xarch=v9"
			    	LDFLAGS_ARCH="-xarch=v9"
			    fi
			fi
		elif test "$arch" = "amd64 i386" ; then
		    if test "$GCC" = "yes" ; then
			AC_MSG_WARN([64bit mode not supported with GCC on $system])
		    else
			do64bit_ok=yes
			CFLAGS="$CFLAGS -xarch=amd64"
			LDFLAGS="$LDFLAGS -xarch=amd64"
		    fi
		else
		    AC_MSG_WARN([64bit mode not supported for $arch])
		fi
	    fi
	    
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		if test "$do64bit_ok" = "yes" ; then
		    # We need to specify -static-libgcc or we need to
		    # add the path to the sparv9 libgcc.
		    SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc"
		    # for finding sparcv9 libgcc, get the regular libgcc
		    # path, remove so name and append 'sparcv9'
		    #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..."
		    #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
		fi
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi














	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783


1784
1785
1786
1787
1788
1789
1790
1791
	    AC_MSG_RESULT($found)
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
	AC_MSG_WARN("64bit support being disabled -- don\'t know magic for this platform")
    fi

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then
	AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?])
    fi

    # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic
    # Loading for Tcl -- What Became of It?".  Proc. 2nd Tcl/Tk Workshop,
    # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need
    # to determine which of several header files defines the a.out file
    # format (a.out.h, sys/exec.h, or sys/exec_aout.h).  At present, we
    # support only a file format that is more or less version-7-compatible. 
    # In particular,
    #	- a.out files must begin with `struct exec'.
    #	- the N_TXTOFF on the `struct exec' must compute the seek address
    #	  of the text segment
    #	- The `struct exec' must contain a_magic, a_text, a_data, a_bss
    #	  and a_entry fields.
    # The following compilation should succeed if and only if either sys/exec.h
    # or a.out.h is usable for the purpose.
    #
    # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
    # `struct exec' includes a second header that contains information that
    # duplicates the v7 fields that are needed.

    if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
	AC_MSG_CHECKING(sys/exec.h)
	AC_TRY_COMPILE([#include <sys/exec.h>],[
	    struct exec foo;
	    unsigned long seek;
	    int flag;
#if defined(__mips) || defined(mips)
	    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
	    seek = N_TXTOFF (foo);
#endif
	    flag = (foo.a_magic == OMAGIC);
	    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
    ], tcl_ok=usable, tcl_ok=unusable)
	AC_MSG_RESULT($tcl_ok)
	if test $tcl_ok = usable; then
	    AC_DEFINE(USE_SYS_EXEC_H, 1,
		[Should we use <sys/exec.h> when doing dynamic loading?])
	else
	    AC_MSG_CHECKING(a.out.h)
	    AC_TRY_COMPILE([#include <a.out.h>],[
		struct exec foo;
		unsigned long seek;
		int flag;
#if defined(__mips) || defined(mips)
		seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		seek = N_TXTOFF (foo);
#endif
		flag = (foo.a_magic == OMAGIC);
		return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
	    ], tcl_ok=usable, tcl_ok=unusable)
	    AC_MSG_RESULT($tcl_ok)
	    if test $tcl_ok = usable; then
		AC_DEFINE(USE_A_OUT_H, 1,
		    [Should we use <a.out.h> when doing dynamic loading?])
	    else
		AC_MSG_CHECKING(sys/exec_aout.h)
		AC_TRY_COMPILE([#include <sys/exec_aout.h>],[
		    struct exec foo;
		    unsigned long seek;
		    int flag;
#if defined(__mips) || defined(mips)
		    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		    seek = N_TXTOFF (foo);
#endif
		    flag = (foo.a_midmag == OMAGIC);
		    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
		], tcl_ok=usable, tcl_ok=unusable)
		AC_MSG_RESULT($tcl_ok)
		if test $tcl_ok = usable; then
		    AC_DEFINE(USE_SYS_EXEC_AOUT_H, 1,
			[Should we use <sys/exec_aout.h> when doing dynamic loading?])
		else
		    DL_OBJS=""
		fi
	    fi
	fi
    fi

    # Step 5: disable dynamic loading if requested via a command-line switch.



    AC_ARG_ENABLE(load, [  --disable-load          disallow dynamic loading and "load" command],
	[tcl_ok=$enableval], [tcl_ok=yes])
    if test "$tcl_ok" = "no"; then
	DL_OBJS=""
    fi

    if test "x$DL_OBJS" != "x" ; then
	BUILD_DLTEST="\$(DLTEST_TARGETS)"







|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

>
>
|







1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
















































































1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
	    AC_MSG_RESULT($found)
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
	AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform])
    fi

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then
	AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?])
    fi

















































































    # Step 4: disable dynamic loading if requested via a command-line switch.

    AC_ARG_ENABLE(load,
	AC_HELP_STRING([--disable-load],
	    [disallow dynamic loading and "load" command (default: enabled)]),
	[tcl_ok=$enableval], [tcl_ok=yes])
    if test "$tcl_ok" = "no"; then
	DL_OBJS=""
    fi

    if test "x$DL_OBJS" != "x" ; then
	BUILD_DLTEST="\$(DLTEST_TARGETS)"
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
		    ;;
		BSD/OS*)
		    ;;
		IRIX*)
		    ;;
		NetBSD-*|FreeBSD-*)
		    ;;
		Rhapsody-*|Darwin-*)
		    ;;
		RISCos-*)
		    ;;
		SCO_SV-3.2*)
		    ;;
		ULTRIX-4.*)
		    ;;
		*)
		    SHLIB_CFLAGS="-fPIC"
		    ;;
	    esac
	fi
    fi

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi

    if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
        LIB_SUFFIX=${SHARED_LIB_SUFFIX}
        MAKE_LIB='${SHLIB_LD} -o [$]@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
        INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
    else
        LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}

        if test "$RANLIB" = "" ; then
            MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'







|















|


|




|







1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
		    ;;
		BSD/OS*)
		    ;;
		IRIX*)
		    ;;
		NetBSD-*|FreeBSD-*)
		    ;;
		Darwin-*)
		    ;;
		RISCos-*)
		    ;;
		SCO_SV-3.2*)
		    ;;
		ULTRIX-4.*)
		    ;;
		*)
		    SHLIB_CFLAGS="-fPIC"
		    ;;
	    esac
	fi
    fi

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}.a'
    fi

    if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
        LIB_SUFFIX=${SHARED_LIB_SUFFIX}
        MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
        INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
    else
        LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}

        if test "$RANLIB" = "" ; then
            MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
1893
1894
1895
1896
1897
1898
1899

1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
    # FIXME: This subst was left in only because the TCL_DL_LIBS
    # entry in tclConfig.sh uses it. It is not clear why someone
    # would use TCL_DL_LIBS instead of TCL_LIBS.
    AC_SUBST(DL_LIBS)

    AC_SUBST(DL_OBJS)
    AC_SUBST(PLAT_OBJS)

    AC_SUBST(CFLAGS)
    AC_SUBST(CFLAGS_DEBUG)
    AC_SUBST(CFLAGS_OPTIMIZE)
    AC_SUBST(CFLAGS_WARNING)

    AC_SUBST(LDFLAGS)
    AC_SUBST(LDFLAGS_DEBUG)
    AC_SUBST(LDFLAGS_OPTIMIZE)
    AC_SUBST(CC_SEARCH_FLAGS)
    AC_SUBST(LD_SEARCH_FLAGS)

    AC_SUBST(STLIB_LD)
    AC_SUBST(SHLIB_LD)
    AC_SUBST(TCL_SHLIB_LD_EXTRAS)
    AC_SUBST(TK_SHLIB_LD_EXTRAS)
    AC_SUBST(SHLIB_LD_FLAGS)
    AC_SUBST(SHLIB_LD_LIBS)
    AC_SUBST(SHLIB_CFLAGS)
    AC_SUBST(SHLIB_SUFFIX)
    AC_DEFINE_UNQUOTED(TCL_SHLIB_EXT,"${SHLIB_SUFFIX}",
	[What is the default extension for shared libraries?])

    AC_SUBST(MAKE_LIB)







>















<







1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906

1907
1908
1909
1910
1911
1912
1913
    # FIXME: This subst was left in only because the TCL_DL_LIBS
    # entry in tclConfig.sh uses it. It is not clear why someone
    # would use TCL_DL_LIBS instead of TCL_LIBS.
    AC_SUBST(DL_LIBS)

    AC_SUBST(DL_OBJS)
    AC_SUBST(PLAT_OBJS)
    AC_SUBST(PLAT_SRCS)
    AC_SUBST(CFLAGS)
    AC_SUBST(CFLAGS_DEBUG)
    AC_SUBST(CFLAGS_OPTIMIZE)
    AC_SUBST(CFLAGS_WARNING)

    AC_SUBST(LDFLAGS)
    AC_SUBST(LDFLAGS_DEBUG)
    AC_SUBST(LDFLAGS_OPTIMIZE)
    AC_SUBST(CC_SEARCH_FLAGS)
    AC_SUBST(LD_SEARCH_FLAGS)

    AC_SUBST(STLIB_LD)
    AC_SUBST(SHLIB_LD)
    AC_SUBST(TCL_SHLIB_LD_EXTRAS)
    AC_SUBST(TK_SHLIB_LD_EXTRAS)

    AC_SUBST(SHLIB_LD_LIBS)
    AC_SUBST(SHLIB_CFLAGS)
    AC_SUBST(SHLIB_SUFFIX)
    AC_DEFINE_UNQUOTED(TCL_SHLIB_EXT,"${SHLIB_SUFFIX}",
	[What is the default extension for shared libraries?])

    AC_SUBST(MAKE_LIB)
2074
2075
2076
2077
2078
2079
2080

2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
#
#		HAVE_STRING_H ?
#
#--------------------------------------------------------------------

AC_DEFUN(SC_MISSING_POSIX_HEADERS, [
    AC_MSG_CHECKING(dirent.h)

    AC_TRY_LINK([#include <sys/types.h>
#include <dirent.h>], [
#ifndef _POSIX_SOURCE
#   ifdef __Lynx__
	/*
	 * Generate compilation error to make the test fail:  Lynx headers
	 * are only valid if really in the POSIX environment.
	 */

	missing_procedure();
#   endif
#endif
DIR *d;
struct dirent *entryPtr;
char *p;
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
], tcl_ok=yes, tcl_ok=no)

    if test $tcl_ok = no; then
	AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
    fi

    AC_MSG_RESULT($tcl_ok)
    AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H, 1, [Do we have <errno.h>?])])
    AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have <float.h>?])])
    AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have <values.h>?])])







>



















|

|







2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
#
#		HAVE_STRING_H ?
#
#--------------------------------------------------------------------

AC_DEFUN(SC_MISSING_POSIX_HEADERS, [
    AC_MSG_CHECKING(dirent.h)
    AC_CACHE_VAL(tcl_cv_dirent_h,
    AC_TRY_LINK([#include <sys/types.h>
#include <dirent.h>], [
#ifndef _POSIX_SOURCE
#   ifdef __Lynx__
	/*
	 * Generate compilation error to make the test fail:  Lynx headers
	 * are only valid if really in the POSIX environment.
	 */

	missing_procedure();
#   endif
#endif
DIR *d;
struct dirent *entryPtr;
char *p;
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no))

    if test $tcl_cv_dirent_h = no; then
	AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
    fi

    AC_MSG_RESULT($tcl_ok)
    AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H, 1, [Do we have <errno.h>?])])
    AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have <float.h>?])])
    AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have <values.h>?])])
2216
2217
2218
2219
2220
2221
2222

2223
2224
2225
2226
2227
2228
2229
	AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow)
    fi
    if test "$XLIBSW" = nope ; then
	AC_MSG_RESULT(couldn't find any!  Using -lX11.)
	XLIBSW=-lX11
    fi
])

#--------------------------------------------------------------------
# SC_BLOCKING_STYLE
#
#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.







>







2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
	AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow)
    fi
    if test "$XLIBSW" = nope ; then
	AC_MSG_RESULT(couldn't find any!  Using -lX11.)
	XLIBSW=-lX11
    fi
])

#--------------------------------------------------------------------
# SC_BLOCKING_STYLE
#
#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.
2525
2526
2527
2528
2529
2530
2531


2532
2533
2534
2535
2536
2537
2538
AC_DEFUN(SC_TCL_EARLY_FLAGS,[
    AC_MSG_CHECKING([for required early compiler flags])
    tcl_flags=""
    SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
	[char *p = (char *)strtoll; char *q = (char *)strtoull;])
    SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
	[struct stat64 buf; int i = stat64("/", &buf);])


    if test "x${tcl_flags}" = "x" ; then
	AC_MSG_RESULT(none)
    else
	AC_MSG_RESULT(${tcl_flags})
    fi])

#--------------------------------------------------------------------







>
>







2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
AC_DEFUN(SC_TCL_EARLY_FLAGS,[
    AC_MSG_CHECKING([for required early compiler flags])
    tcl_flags=""
    SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
	[char *p = (char *)strtoll; char *q = (char *)strtoull;])
    SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
	[struct stat64 buf; int i = stat64("/", &buf);])
    SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include <sys/stat.h>],
	[char *p = (char *)open64;])
    if test "x${tcl_flags}" = "x" ; then
	AC_MSG_RESULT(none)
    else
	AC_MSG_RESULT(${tcl_flags})
    fi])

#--------------------------------------------------------------------
2628
2629
2630
2631
2632
2633
2634
2635



2636
2637
2638
2639
2640
2641
2642
#
#	Will define the following vars:
#		TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------

AC_DEFUN(SC_TCL_CFG_ENCODING, [
    AC_ARG_WITH(encoding, [  --with-encoding              encoding for configuration values], with_tcencoding=${withval})




    if test x"${with_tcencoding}" != x ; then
	AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}",
	    [What encoding should be used for embedded configuration info?])
    else
	AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1",
	    [What encoding should be used for embedded configuration info?])







|
>
>
>







2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
#
#	Will define the following vars:
#		TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------

AC_DEFUN(SC_TCL_CFG_ENCODING, [
    AC_ARG_WITH(encoding,
	AC_HELP_STRING([--with-encoding],
	    [encoding for configuration values (default: iso8859-1)]),
	with_tcencoding=${withval})

    if test x"${with_tcencoding}" != x ; then
	AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}",
	    [What encoding should be used for embedded configuration info?])
    else
	AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1",
	    [What encoding should be used for embedded configuration info?])

Changes to unix/tcl.spec.

1
2
3
4
5
6
7
8
9
10
11
# $Id: tcl.spec,v 1.20 2004/03/26 19:47:29 dgp Exp $
# This file is the basis for a binary Tcl RPM for Linux.

%define version 8.5a2
%define directory /usr/local

Summary: Tcl scripting language development environment
Name: tcl
Version: %{version}
Release: 1
Copyright: BSD
|


|







1
2
3
4
5
6
7
8
9
10
11
# $Id: tcl.spec,v 1.20.2.2 2005/07/12 20:37:29 kennykb Exp $
# This file is the basis for a binary Tcl RPM for Linux.

%define version 8.5a4
%define directory /usr/local

Summary: Tcl scripting language development environment
Name: tcl
Version: %{version}
Release: 1
Copyright: BSD

Changes to unix/tclAppInit.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclAppInit.c --
 *
 *	Provides a default version of the main program and Tcl_AppInit
 *	procedure for Tcl applications (without Tk).
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAppInit.c,v 1.15 2004/11/12 22:52:30 dgp Exp $
 */

#include "tcl.h"

#ifdef TCL_TEST

#include "tclInt.h"
|



|





|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclAppInit.c --
 *
 *	Provides a default version of the main program and Tcl_AppInit
 *	function for Tcl applications (without Tk).
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAppInit.c,v 1.15.2.1 2005/08/02 18:16:54 dgp Exp $
 */

#include "tcl.h"

#ifdef TCL_TEST

#include "tclInt.h"
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68
69
70
71
72
 *----------------------------------------------------------------------
 *
 * main --
 *
 *	This is the main program for the application.
 *
 * Results:
 *	None: Tcl_Main never returns here, so this procedure never
 *	returns either.
 *
 * Side effects:
 *	Whatever the application does.
 *
 *----------------------------------------------------------------------
 */

int
main(argc, argv)
    int argc;			/* Number of command-line arguments. */
    char **argv;		/* Values of command-line arguments. */
{
    /*
     * The following #if block allows you to change the AppInit
     * function by using a #define of TCL_LOCAL_APPINIT instead
     * of rewriting this entire file.  The #if checks for that
     * #define and uses Tcl_AppInit if it doesn't exist.

     */

#ifndef TCL_LOCAL_APPINIT
#define TCL_LOCAL_APPINIT Tcl_AppInit    
#endif
    extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));

    /*
     * The following #if block allows you to change how Tcl finds the startup
     * script, prime the library or encoding paths, fiddle with the argv,
     * etc., without needing to rewrite Tcl_Main()







|
|













|
|
<
|
>



|







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
67
68
69
70
71
72
 *----------------------------------------------------------------------
 *
 * main --
 *
 *	This is the main program for the application.
 *
 * Results:
 *	None: Tcl_Main never returns here, so this function never returns
 *	either.
 *
 * Side effects:
 *	Whatever the application does.
 *
 *----------------------------------------------------------------------
 */

int
main(argc, argv)
    int argc;			/* Number of command-line arguments. */
    char **argv;		/* Values of command-line arguments. */
{
    /*
     * The following #if block allows you to change the AppInit function by
     * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire

     * file. The #if checks for that #define and uses Tcl_AppInit if it does
     * not exist.
     */

#ifndef TCL_LOCAL_APPINIT
#define TCL_LOCAL_APPINIT Tcl_AppInit
#endif
    extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));

    /*
     * The following #if block allows you to change how Tcl finds the startup
     * script, prime the library or encoding paths, fiddle with the argv,
     * etc., without needing to rewrite Tcl_Main()
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

168
169








}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppInit --
 *
 *	This procedure performs application-specific initialization.
 *	Most applications, especially those that incorporate additional
 *	packages, will have their own version of this procedure.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error
 *	message in the interp's result if an error occurs.
 *
 * Side effects:
 *	Depends on the startup script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppInit(interp)
    Tcl_Interp *interp;		/* Interpreter for application. */
{
    if (Tcl_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

#ifdef TCL_TEST
#ifdef TCL_XT_TEST
     if (Tclxttest_Init(interp) == TCL_ERROR) {
	 return TCL_ERROR;
     }
#endif
    if (Tcltest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
            (Tcl_PackageInitProc *) NULL);
    if (TclObjTest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (Procbodytest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
            Procbodytest_SafeInit);
#endif /* TCL_TEST */

    /*
     * Call the init procedures for included packages.  Each call should
     * look like this:
     *
     * if (Mod_Init(interp) == TCL_ERROR) {
     *     return TCL_ERROR;
     * }
     *
     * where "Mod" is the name of the module.

     */

    /*
     * Call Tcl_CreateCommand for application-specific commands, if
     * they weren't already created by the init procedures called above.
     */

    /*
     * Specify a user-specific startup file to invoke if the application
     * is run interactively.  Typically the startup file is "~/.apprc"
     * where "app" is the name of the application.  If this line is deleted
     * then no user-specific startup file will be run under any conditions.
     */

#ifdef DJGPP
    Tcl_SetVar(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY);
#endif

    return TCL_OK;
}















|
|
|


|
|

















|
|
|





|







|



|
|





|
>



|
|



|
|
|
|







>


>
>
>
>
>
>
>
>
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppInit --
 *
 *	This function performs application-specific initialization. Most
 *	applications, especially those that incorporate additional packages,
 *	will have their own version of this function.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error message in
 *	the interp's result if an error occurs.
 *
 * Side effects:
 *	Depends on the startup script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppInit(interp)
    Tcl_Interp *interp;		/* Interpreter for application. */
{
    if (Tcl_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

#ifdef TCL_TEST
#ifdef TCL_XT_TEST
    if (Tclxttest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
#endif
    if (Tcltest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
	    (Tcl_PackageInitProc *) NULL);
    if (TclObjTest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (Procbodytest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
	    Procbodytest_SafeInit);
#endif /* TCL_TEST */

    /*
     * Call the init functions for included packages. Each call should look
     * like this:
     *
     * if (Mod_Init(interp) == TCL_ERROR) {
     *     return TCL_ERROR;
     * }
     *
     * where "Mod" is the name of the module. (Dynamically-loadable packages
     * should have the same entry-point name.)
     */

    /*
     * Call Tcl_CreateCommand for application-specific commands, if they
     * weren't already created by the init functions called above.
     */

    /*
     * Specify a user-specific startup file to invoke if the application is
     * run interactively. Typically the startup file is "~/.apprc" where "app"
     * is the name of the application. If this line is deleted then no user-
     * specific startup file will be run under any conditions.
     */

#ifdef DJGPP
    Tcl_SetVar(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY);
#endif

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclConfig.h.in.

1



2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35



36
37
38
39
40



41
42
43
44
45
46
47
48
49



50
51
52



53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
/* tclConfig.h.in.  Generated from configure.in by autoheader.  */




/* Is pthread_attr_get_np() declared in <pthread.h>? */
#undef ATTRGETNP_NOT_DECLARED

/* Is pthread_getattr_np declared in <pthread.h>? */
#undef GETATTRNP_NOT_DECLARED

/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED

/* Do we have BSDgettimeofday()? */
#undef HAVE_BSDGETTIMEOFDAY

/* Do we have access to Mac bundles? */
#undef HAVE_CFBUNDLE

/* Define to 1 if you have the `chflags' function. */
#undef HAVE_CHFLAGS

/* Define to 1 if you have the `getattrlist' function. */
#undef HAVE_GETATTRLIST

/* Define to 1 if you have the `getcwd' function. */
#undef HAVE_GETCWD

/* Define to 1 if you have the `gmtime_r' function. */
#undef HAVE_GMTIME_R

/* Define to 1 if you have the <inttypes.h> header file. */
#undef HAVE_INTTYPES_H

/* Do we have nl_langinfo()? */
#undef HAVE_LANGINFO




/* Do we have <limits.h>? */
#undef HAVE_LIMITS_H

/* Define to 1 if you have the `localtime_r' function. */
#undef HAVE_LOCALTIME_R




/* Define to 1 if you have the <memory.h> header file. */
#undef HAVE_MEMORY_H

/* Define to 1 if you have the `mktime' function. */
#undef HAVE_MKTIME

/* Do we have <net/errno.h>? */
#undef HAVE_NET_ERRNO_H




/* Define to 1 if you have the `opendir' function. */
#undef HAVE_OPENDIR




/* Do we want a BSD-like thread-attribute interface? */
#undef HAVE_PTHREAD_ATTR_GET_NP

/* Define to 1 if you have the `pthread_attr_setstacksize' function. */
#undef HAVE_PTHREAD_ATTR_SETSTACKSIZE

/* Do we want a Linux-like thread-attribute interface? */
#undef HAVE_PTHREAD_GETATTR_NP

/* Does putenv() copy strings or incorporate them by reference? */
#undef HAVE_PUTENV_THAT_COPIES

/* Define to 1 if you have the `readdir_r' function. */
#undef HAVE_READDIR_R

/* Are characters signed? */
#undef HAVE_SIGNED_CHAR

/* Define to 1 if you have the <stdint.h> header file. */
#undef HAVE_STDINT_H

/* Define to 1 if you have the <stdlib.h> header file. */
#undef HAVE_STDLIB_H

/* Define to 1 if you have the <strings.h> header file. */
#undef HAVE_STRINGS_H

/* Define to 1 if you have the <string.h> header file. */
#undef HAVE_STRING_H

/* Define to 1 if you have the `strstr' function. */
#undef HAVE_STRSTR

/* Define to 1 if you have the `strtol' function. */
#undef HAVE_STRTOL

/* Define to 1 if you have the `strtoll' function. */
#undef HAVE_STRTOLL

/* Define to 1 if you have the `strtoull' function. */

>
>
>













|
|

|
|
















>
>
>





>
>
>









>
>
>



>
>
>













<
<
<















<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80



81
82
83
84
85
86
87
88
89
90
91
92
93
94
95



96
97
98
99
100
101
102
/* tclConfig.h.in.  Generated from configure.in by autoheader.  */

#ifndef _TCLCONFIG
#define _TCLCONFIG

/* Is pthread_attr_get_np() declared in <pthread.h>? */
#undef ATTRGETNP_NOT_DECLARED

/* Is pthread_getattr_np declared in <pthread.h>? */
#undef GETATTRNP_NOT_DECLARED

/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED

/* Do we have BSDgettimeofday()? */
#undef HAVE_BSDGETTIMEOFDAY

/* Define to 1 if you have the `chflags' function. */
#undef HAVE_CHFLAGS

/* Do we have access to Darwin CoreFoundation.framework ? */
#undef HAVE_COREFOUNDATION

/* Define to 1 if you have the `getattrlist' function. */
#undef HAVE_GETATTRLIST

/* Define to 1 if you have the `getcwd' function. */
#undef HAVE_GETCWD

/* Define to 1 if you have the `gmtime_r' function. */
#undef HAVE_GMTIME_R

/* Define to 1 if you have the <inttypes.h> header file. */
#undef HAVE_INTTYPES_H

/* Do we have nl_langinfo()? */
#undef HAVE_LANGINFO

/* Define to 1 if you have the <libkern/OSAtomic.h> header file. */
#undef HAVE_LIBKERN_OSATOMIC_H

/* Do we have <limits.h>? */
#undef HAVE_LIMITS_H

/* Define to 1 if you have the `localtime_r' function. */
#undef HAVE_LOCALTIME_R

/* Define to 1 if you have the `lseek64' function. */
#undef HAVE_LSEEK64

/* Define to 1 if you have the <memory.h> header file. */
#undef HAVE_MEMORY_H

/* Define to 1 if you have the `mktime' function. */
#undef HAVE_MKTIME

/* Do we have <net/errno.h>? */
#undef HAVE_NET_ERRNO_H

/* Define to 1 if you have the `open64' function. */
#undef HAVE_OPEN64

/* Define to 1 if you have the `opendir' function. */
#undef HAVE_OPENDIR

/* Define to 1 if you have the `OSSpinLockLock' function. */
#undef HAVE_OSSPINLOCKLOCK

/* Do we want a BSD-like thread-attribute interface? */
#undef HAVE_PTHREAD_ATTR_GET_NP

/* Define to 1 if you have the `pthread_attr_setstacksize' function. */
#undef HAVE_PTHREAD_ATTR_SETSTACKSIZE

/* Do we want a Linux-like thread-attribute interface? */
#undef HAVE_PTHREAD_GETATTR_NP

/* Does putenv() copy strings or incorporate them by reference? */
#undef HAVE_PUTENV_THAT_COPIES




/* Are characters signed? */
#undef HAVE_SIGNED_CHAR

/* Define to 1 if you have the <stdint.h> header file. */
#undef HAVE_STDINT_H

/* Define to 1 if you have the <stdlib.h> header file. */
#undef HAVE_STDLIB_H

/* Define to 1 if you have the <strings.h> header file. */
#undef HAVE_STRINGS_H

/* Define to 1 if you have the <string.h> header file. */
#undef HAVE_STRING_H




/* Define to 1 if you have the `strtol' function. */
#undef HAVE_STRTOL

/* Define to 1 if you have the `strtoll' function. */
#undef HAVE_STRTOLL

/* Define to 1 if you have the `strtoull' function. */
158
159
160
161
162
163
164
165
166



167
168
169
170
171
172
173

/* Define to 1 if you have the <unistd.h> header file. */
#undef HAVE_UNISTD_H

/* Define to 1 if you have the `waitpid' function. */
#undef HAVE_WAITPID

/* "Is this a Mac I see before me?" */
#undef MAC_OSX_TCL




/* Do we have <dirent.h>? */
#undef NO_DIRENT_H

/* Do we have <dlfcn.h>? */
#undef NO_DLFCN_H








|

>
>
>







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

/* Define to 1 if you have the <unistd.h> header file. */
#undef HAVE_UNISTD_H

/* Define to 1 if you have the `waitpid' function. */
#undef HAVE_WAITPID

/* Is this a Mac I see before me? */
#undef MAC_OSX_TCL

/* Linker support for module scope symbols */
#undef MODULE_SCOPE

/* Do we have <dirent.h>? */
#undef NO_DIRENT_H

/* Do we have <dlfcn.h>? */
#undef NO_DLFCN_H

260
261
262
263
264
265
266
267
268
269
270
271
272
273
274



275
276
277
278
279
280
281

/* Is bytecode debugging enabled? */
#undef TCL_COMPILE_DEBUG

/* Are bytecode statistics enabled? */
#undef TCL_COMPILE_STATS

/* What extra letters do we insert for debugging binary code? */
#undef TCL_DBGX

/* Are we to override what our default encoding is? */
#undef TCL_DEFAULT_ENCODING

/* Is Tcl built as a framework? */
#undef TCL_FRAMEWORK




/* Is memory debugging enabled? */
#undef TCL_MEM_DEBUG

/* What is the default extension for shared libraries? */
#undef TCL_SHLIB_EXT








<
<
<





>
>
>







272
273
274
275
276
277
278



279
280
281
282
283
284
285
286
287
288
289
290
291
292
293

/* Is bytecode debugging enabled? */
#undef TCL_COMPILE_DEBUG

/* Are bytecode statistics enabled? */
#undef TCL_COMPILE_STATS




/* Are we to override what our default encoding is? */
#undef TCL_DEFAULT_ENCODING

/* Is Tcl built as a framework? */
#undef TCL_FRAMEWORK

/* Can this platform load code from memory? */
#undef TCL_LOAD_FROM_MEMORY

/* Is memory debugging enabled? */
#undef TCL_MEM_DEBUG

/* What is the default extension for shared libraries? */
#undef TCL_SHLIB_EXT

296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342

/* Define to 1 if your <sys/time.h> declares `struct tm'. */
#undef TM_IN_SYS_TIME

/* Is getcwd Posix-compliant? */
#undef USEGETWD

/* Should we use <a.out.h> when doing dynamic loading? */
#undef USE_A_OUT_H

/* Do we need a special AIX hack for timezones? */
#undef USE_DELTA_FOR_TZ

/* May we include <dirent2.h>? */
#undef USE_DIRENT2_H

/* Should we use FIONBIO? */
#undef USE_FIONBIO

/* Use the sgtty API for serial lines */
#undef USE_SGTTY

/* Should we use <sys/exec_aout.h> when doing dynamic loading? */
#undef USE_SYS_EXEC_AOUT_H

/* Should we use <sys/exec.h> when doing dynamic loading? */
#undef USE_SYS_EXEC_H

/* Use the termio API for serial lines */
#undef USE_TERMIO

/* Use the termios API for serial lines */
#undef USE_TERMIOS

/* Do we want to use the threaded memory allocator? */
#undef USE_THREAD_ALLOC

/* Use the generic thread storage subsystem? */
#undef USE_THREAD_STORAGE

/* Should we use vfork() instead of fork()? */
#undef USE_VFORK

/* Define to 1 if your processor stores words with the most significant byte
   first (like Motorola and SPARC, unlike Intel and VAX). */
#undef WORDS_BIGENDIAN








<
<
<












<
<
<
<
<
<









<
<
<







308
309
310
311
312
313
314



315
316
317
318
319
320
321
322
323
324
325
326






327
328
329
330
331
332
333
334
335



336
337
338
339
340
341
342

/* Define to 1 if your <sys/time.h> declares `struct tm'. */
#undef TM_IN_SYS_TIME

/* Is getcwd Posix-compliant? */
#undef USEGETWD




/* Do we need a special AIX hack for timezones? */
#undef USE_DELTA_FOR_TZ

/* May we include <dirent2.h>? */
#undef USE_DIRENT2_H

/* Should we use FIONBIO? */
#undef USE_FIONBIO

/* Use the sgtty API for serial lines */
#undef USE_SGTTY







/* Use the termio API for serial lines */
#undef USE_TERMIO

/* Use the termios API for serial lines */
#undef USE_TERMIOS

/* Do we want to use the threaded memory allocator? */
#undef USE_THREAD_ALLOC




/* Should we use vfork() instead of fork()? */
#undef USE_VFORK

/* Define to 1 if your processor stores words with the most significant byte
   first (like Motorola and SPARC, unlike Intel and VAX). */
#undef WORDS_BIGENDIAN

385
386
387
388
389
390
391


#undef socklen_t

/* Do we want to use the strtod() in compat? */
#undef strtod

/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t









>
>
385
386
387
388
389
390
391
392
393
#undef socklen_t

/* Do we want to use the strtod() in compat? */
#undef strtod

/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t

#endif /* _TCLCONFIG */

Changes to unix/tclConfig.sh.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# tclConfig.sh --
# 
# This shell script (for sh) is generated automatically by Tcl's
# configure script.  It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Tcl extensions so that they don't have to figure this all
# out for themselves.
#
# The information in this file is specific to a single platform.
#
# RCS: @(#) $Id: tclConfig.sh.in,v 1.19 2004/06/15 20:28:03 hobbs Exp $

# Tcl's version number.
TCL_VERSION='@TCL_VERSION@'
TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@'
TCL_MINOR_VERSION='@TCL_MINOR_VERSION@'
TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@'

# C compiler to use for compilation.
TCL_CC='@CC@'

# -D flags for use with the C compiler.
TCL_DEFS='@DEFS@'

# If TCL was built with debugging symbols, generated libraries contain
# this string at the end of the library name (before the extension).
TCL_DBGX=@TCL_DBGX@

# Default flags used in an optimized and debuggable build, respectively.
TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@'
TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@'

# Default linker flags used in an optimized and debuggable build, respectively.
TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@'











|













|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# tclConfig.sh --
# 
# This shell script (for sh) is generated automatically by Tcl's
# configure script.  It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Tcl extensions so that they don't have to figure this all
# out for themselves.
#
# The information in this file is specific to a single platform.
#
# RCS: @(#) $Id: tclConfig.sh.in,v 1.19.2.1 2005/01/20 14:53:40 kennykb Exp $

# Tcl's version number.
TCL_VERSION='@TCL_VERSION@'
TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@'
TCL_MINOR_VERSION='@TCL_MINOR_VERSION@'
TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@'

# C compiler to use for compilation.
TCL_CC='@CC@'

# -D flags for use with the C compiler.
TCL_DEFS='@DEFS@'

# TCL_DBGX used to be used to distinguish debug vs. non-debug builds.
# This was a righteous pain so the core doesn't do that any more.
TCL_DBGX=

# Default flags used in an optimized and debuggable build, respectively.
TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@'
TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@'

# Default linker flags used in an optimized and debuggable build, respectively.
TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@'

Changes to unix/tclLoadAix.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

81
82
83
84
85
86

87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
102
103
104

105
106

107

108
109

110
111
112

113
114
115
116
117


118

119
120
121
122
123

124
125

126
127
128
129

130

131
132
133
134
135
136

137
138
139
140
141

142
143

144
145
146
147
148
149
150

151
152

153
154

155
156
157

158

159
160
161
162
163
164

165
166
167
168

169
170

171
172
173
174
175
176
177
178
179


180
181
182













183
184
185
186
187
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202


203
204
205
206
207
208
209

210

211
212
213
214
215

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

245
246
247
248
249
250
251
252
253
254

255
256
257



258
259
260
261
262
263

264
265
266
267
268
269
270
271
272

273
274
275
276
277
278
279
280


281
282


283
284
285
286
287


288
289
290
291
292

293
294
295
296
297
298


299
300

301
302
303
304
305
306
307
308
309


310
311
312
313
314
315

316
317
318
319
320

321
322
323


324
325
326
327
328
329
330
331
332

333



334

335
336
337

338
339
340
341
342
343

344
345
346
347
348



349
350
351
352
353
354

355




356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376

377
378
379
380
381
382
383
384
385
386
387


388

389
390
391
392
393
394
395

396
397
398
399
400
401
402

403
404
405
406
407
408
409
410
411
412
413


414

415
416
417
418
419
420
421

422
423
424
425
426
427
428
429
430
431


432
433

434



435
436
437
438
439
440
441
442
443
444
445
446
447
448

449

450
451

452
453
454

455
456
457

458
459

460




461
462
463
464
465
466
467
468
469
470
471
472

473
474
475
476
477

478
479


480
481
482
483
484
485
486
487

488
489
490
491
492
493
494
495
496
497
498
499



500















501
502
503
504
505
506
507

508

509
510
511
512
513
514
515
516
517
518
519
520
521

522
523
524
525





















526
527
528
529
530
531
532
533
534
535
536
537
538
539

540
541


542
543
544
545
546
547
548
549
/* 
 * tclLoadAix.c --
 *
 *	This file implements the dlopen and dlsym APIs under the
 *	AIX operating system, to enable the Tcl "load" command to
 *	work.  This code was provided by Jens-Uwe Mager.
 *
 *	This file is subject to the following copyright notice, which is
 *	different from the notice used elsewhere in Tcl.  The file has
 *	been modified to incorporate the file dlfcn.h in-line.
 *
 *	Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH
 *	Not derived from licensed software.

 *	Permission is granted to freely use, copy, modify, and redistribute
 *	this software, provided that the author is not construed to be liable
 *	for any results of using the software, alterations are clearly marked
 *	as such, and this notice is not modified.
 *
 * RCS: @(#) $Id: tclLoadAix.c,v 1.3 1999/04/16 00:48:04 stanton Exp $
 *
 * Note:  this file has been altered from the original in a few
 * ways in order to work properly with Tcl.
 */

/*
 * @(#)dlfcn.c	1.7 revision of 95/08/14  19:08:38
 * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH
 * 30159 Hannover, Germany
 */

#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <stdlib.h>
#include <sys/types.h>
#include <sys/ldr.h>
#include <a.out.h>
#include <ldfcn.h>
#include "../compat/dlfcn.h"

/*
 * We simulate dlopen() et al. through a call to load. Because AIX has
 * no call to find an exported symbol we read the loader section of the
 * loaded module and build a list of exported symbols and their virtual
 * address.
 */

typedef struct {
	char		*name;		/* the symbols's name */
	void		*addr;		/* its relocated virtual address */
} Export, *ExportPtr;

/*
 * xlC uses the following structure to list its constructors and
 * destructors. This is gleaned from the output of munch.
 */

typedef struct {
	void (*init)(void);		/* call static constructors */
	void (*term)(void);		/* call static destructors */
} Cdtor, *CdtorPtr;

/*
 * The void * handle returned from dlopen is actually a ModulePtr.
 */

typedef struct Module {
	struct Module	*next;
	char		*name;		/* module name for refcounting */
	int		refCnt;		/* the number of references */
	void		*entry;		/* entry point from load */
	struct dl_info	*info;		/* optional init/terminate functions */
	CdtorPtr	cdtors;		/* optional C++ constructors */
	int		nExports;	/* the number of exports found */
	ExportPtr	exports;	/* the array of exports */
} Module, *ModulePtr;

/*
 * We keep a list of all loaded modules to be able to call the fini
 * handlers and destructors at atexit() time.
 */

static ModulePtr modList;

/*
 * The last error from one of the dl* routines is kept in static
 * variables here. Each error is returned only once to the caller.
 */

static char errbuf[BUFSIZ];
static int errvalid;

static void caterr(char *);
static int readExports(ModulePtr);
static void terminate(void);
static void *findMain(void);


VOID *dlopen(const char *path, int mode)
{
	register ModulePtr mp;
	static void *mainModule;

	/*
	 * Upon the first call register a terminate handler that will
	 * close all libraries. Also get a reference to the main module
	 * for use with loadbind.
	 */

	if (!mainModule) {
		if ((mainModule = findMain()) == NULL)

			return NULL;

		atexit(terminate);
	}

	/*
	 * Scan the list of modules if we have the module already loaded.
	 */

	for (mp = modList; mp; mp = mp->next)
		if (strcmp(mp->name, path) == 0) {
			mp->refCnt++;
			return (VOID *) mp;
		}


	if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) {

		errvalid++;
		strcpy(errbuf, "calloc: ");
		strcat(errbuf, strerror(errno));
		return (VOID *) NULL;
	}

	mp->name = malloc((unsigned) (strlen(path) + 1));
	strcpy(mp->name, path);

	/*
	 * load should be declared load(const char *...). Thus we
	 * cast the path to a normal char *. Ugly.
	 */

	if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) {

		free(mp->name);
		free(mp);
		errvalid++;
		strcpy(errbuf, "dlopen: ");
		strcat(errbuf, path);
		strcat(errbuf, ": ");

		/*
		 * If AIX says the file is not executable, the error
		 * can be further described by querying the loader about
		 * the last error.
		 */

		if (errno == ENOEXEC) {
			char *tmp[BUFSIZ/sizeof(char *)];

			if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1)
				strcpy(errbuf, strerror(errno));
			else {
				char **p;
				for (p = tmp; *p; p++)
					caterr(*p);
			}

		} else
			strcat(errbuf, strerror(errno));

		return (VOID *) NULL;
	}

	mp->refCnt = 1;
	mp->next = modList;
	modList = mp;

	if (loadbind(0, mainModule, mp->entry) == -1) {

		dlclose(mp);
		errvalid++;
		strcpy(errbuf, "loadbind: ");
		strcat(errbuf, strerror(errno));
		return (VOID *) NULL;
	}

	/*
	 * If the user wants global binding, loadbind against all other
	 * loaded modules.
	 */

	if (mode & RTLD_GLOBAL) {
		register ModulePtr mp1;

		for (mp1 = mp->next; mp1; mp1 = mp1->next)
			if (loadbind(0, mp1->entry, mp->entry) == -1) {
				dlclose(mp);
				errvalid++;
				strcpy(errbuf, "loadbind: ");
				strcat(errbuf, strerror(errno));
				return (VOID *) NULL;
			}
	}


	if (readExports(mp) == -1) {
		dlclose(mp);
		return (VOID *) NULL;













	}
	/*
	 * If there is a dl_info structure, call the init function.
	 */
	if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) {
		if (mp->info->init)
			(*mp->info->init)();
	} else
		errvalid = 0;
	/*
	 * If the shared object was compiled using xlC we will need
	 * to call static constructors (and later on dlclose destructors).
	 */

	if (mp->cdtors = (CdtorPtr)dlsym(mp, "__cdtors")) {
		while (mp->cdtors->init) {
			(*mp->cdtors->init)();
			mp->cdtors++;
		}
	} else
		errvalid = 0;


	return (VOID *) mp;
}

/*
 * Attempt to decipher an AIX loader error message and append it
 * to our static error message buffer.
 */

static void caterr(char *s)

{
	register char *p = s;

	while (*p >= '0' && *p <= '9')
		p++;

	switch(atoi(s)) {		/* INTL: "C", UTF safe. */
	case L_ERROR_TOOMANY:
		strcat(errbuf, "to many errors");
		break;
	case L_ERROR_NOLIB:
		strcat(errbuf, "can't load library");
		strcat(errbuf, p);
		break;
	case L_ERROR_UNDEF:
		strcat(errbuf, "can't find symbol");
		strcat(errbuf, p);
		break;
	case L_ERROR_RLDBAD:
		strcat(errbuf, "bad RLD");
		strcat(errbuf, p);
		break;
	case L_ERROR_FORMAT:
		strcat(errbuf, "bad exec format in");
		strcat(errbuf, p);
		break;
	case L_ERROR_ERRNO:
		strcat(errbuf, strerror(atoi(++p)));	/* INTL: "C", UTF safe. */
		break;
	default:
		strcat(errbuf, s);
		break;
	}
}


VOID *dlsym(void *handle, const char *symbol)
{
	register ModulePtr mp = (ModulePtr)handle;
	register ExportPtr ep;
	register int i;

	/*
	 * Could speed up the search, but I assume that one assigns
	 * the result to function pointers anyways.
	 */

	for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
		if (strcmp(ep->name, symbol) == 0)
			return ep->addr;



	errvalid++;
	strcpy(errbuf, "dlsym: undefined symbol ");
	strcat(errbuf, symbol);
	return NULL;
}


char *dlerror(void)
{
	if (errvalid) {
		errvalid = 0;
		return errbuf;
	}
	return NULL;
}


int dlclose(void *handle)
{
	register ModulePtr mp = (ModulePtr)handle;
	int result;
	register ModulePtr mp1;

	if (--mp->refCnt > 0)
		return 0;


	if (mp->info && mp->info->fini)
		(*mp->info->fini)();


	if (mp->cdtors)
		while (mp->cdtors->term) {
			(*mp->cdtors->term)();
			mp->cdtors++;
		}


	result = unload(mp->entry);
	if (result == -1) {
		errvalid++;
		strcpy(errbuf, strerror(errno));
	}

	if (mp->exports) {
		register ExportPtr ep;
		register int i;
		for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
			if (ep->name)
				free(ep->name);


		free(mp->exports);
	}

	if (mp == modList)
		modList = mp->next;
	else {
		for (mp1 = modList; mp1; mp1 = mp1->next)
			if (mp1->next == mp) {
				mp1->next = mp->next;
				break;
			}
	}


	free(mp->name);
	free(mp);
	return result;
}

static void terminate(void)

{
	while (modList)
		dlclose(modList);
}


/*
 * Build the export table from the XCOFF .loader section.
 */


static int readExports(ModulePtr mp)
{
	LDFILE *ldp = NULL;
	SCNHDR sh, shdata;
	LDHDR *lhp;
	char *ldbuf;
	LDSYM *ls;
	int i;
	ExportPtr ep;





	if ((ldp = ldopen(mp->name, ldp)) == NULL) {

		struct ld_info *lp;
		char *buf;
		int size = 4*1024;

		if (errno != ENOENT) {
			errvalid++;
			strcpy(errbuf, "readExports: ");
			strcat(errbuf, strerror(errno));
			return -1;
		}

		/*
		 * The module might be loaded due to the LIBPATH
		 * environment variable. Search for the loaded
		 * module using L_GETINFO.
		 */



		if ((buf = malloc(size)) == NULL) {
			errvalid++;
			strcpy(errbuf, "readExports: ");
			strcat(errbuf, strerror(errno));
			return -1;
		}

		while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) {




			free(buf);
			size += 4*1024;
			if ((buf = malloc(size)) == NULL) {
				errvalid++;
				strcpy(errbuf, "readExports: ");
				strcat(errbuf, strerror(errno));
				return -1;
			}
		}
		if (i == -1) {
			errvalid++;
			strcpy(errbuf, "readExports: ");
			strcat(errbuf, strerror(errno));
			free(buf);
			return -1;
		}
		/*
		 * Traverse the list of loaded modules. The entry point
		 * returned by load() does actually point to the data
		 * segment origin.
		 */

		lp = (struct ld_info *)buf;
		while (lp) {
			if (lp->ldinfo_dataorg == mp->entry) {
				ldp = ldopen(lp->ldinfo_filename, ldp);
				break;
			}
			if (lp->ldinfo_next == 0)
				lp = NULL;
			else
				lp = (struct ld_info *)((char *)lp + lp->ldinfo_next);
		}


		free(buf);

		if (!ldp) {
			errvalid++;
			strcpy(errbuf, "readExports: ");
			strcat(errbuf, strerror(errno));
			return -1;
		}
	}

	if (TYPE(ldp) != U802TOCMAGIC) {
		errvalid++;
		strcpy(errbuf, "readExports: bad magic");
		while(ldclose(ldp) == FAILURE)
			;
		return -1;
	}

	/*
	 * Get the padding for the data section. This is needed for
	 * AIX 4.1 compilers. This is used when building the final
	 * function pointer to the exported symbol.
	 */
	if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) {
		errvalid++;
		strcpy(errbuf, "readExports: cannot read data section header");
		while(ldclose(ldp) == FAILURE)
			;
		return -1;


	}

	if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) {
		errvalid++;
		strcpy(errbuf, "readExports: cannot read loader section header");
		while(ldclose(ldp) == FAILURE)
			;
		return -1;
	}

	/*
	 * We read the complete loader section in one chunk, this makes
	 * finding long symbol names residing in the string table easier.
	 */
	if ((ldbuf = (char *)malloc(sh.s_size)) == NULL) {
		errvalid++;
		strcpy(errbuf, "readExports: ");
		strcat(errbuf, strerror(errno));
		while(ldclose(ldp) == FAILURE)
			;


		return -1;
	}

	if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) {



		errvalid++;
		strcpy(errbuf, "readExports: cannot seek to loader section");
		free(ldbuf);
		while(ldclose(ldp) == FAILURE)
			;
		return -1;
	}
	if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) {
		errvalid++;
		strcpy(errbuf, "readExports: cannot read loader section");
		free(ldbuf);
		while(ldclose(ldp) == FAILURE)
			;
		return -1;

	}

	lhp = (LDHDR *)ldbuf;
	ls = (LDSYM *)(ldbuf+LDHDRSZ);

	/*
	 * Count the number of exports to include in our export table.
	 */

	for (i = lhp->l_nsyms; i; i--, ls++) {
		if (!LDR_EXPORT(*ls))
			continue;

		mp->nExports++;
	}

	if ((mp->exports = (ExportPtr)calloc(mp->nExports, sizeof(*mp->exports))) == NULL) {




		errvalid++;
		strcpy(errbuf, "readExports: ");
		strcat(errbuf, strerror(errno));
		free(ldbuf);
		while(ldclose(ldp) == FAILURE)
			;
		return -1;
	}
	/*
	 * Fill in the export table. All entries are relative to
	 * the entry point we got from load.
	 */

	ep = mp->exports;
	ls = (LDSYM *)(ldbuf+LDHDRSZ);
	for (i = lhp->l_nsyms; i; i--, ls++) {
		char *symname;
		char tmpsym[SYMNMLEN+1];

		if (!LDR_EXPORT(*ls))
			continue;


		if (ls->l_zeroes == 0)
			symname = ls->l_offset+lhp->l_stoff+ldbuf;
		else {
			/*
			 * The l_name member is not zero terminated, we
			 * must copy the first SYMNMLEN chars and make
			 * sure we have a zero byte at the end.
			 */

			strncpy(tmpsym, ls->l_name, SYMNMLEN);
			tmpsym[SYMNMLEN] = '\0';
			symname = tmpsym;
		}
		ep->name = malloc((unsigned) (strlen(symname) + 1));
		strcpy(ep->name, symname);
		ep->addr = (void *)((unsigned long)mp->entry +
					ls->l_value - shdata.s_vaddr);
		ep++;
	}
	free(ldbuf);
	while(ldclose(ldp) == FAILURE)



		;















	return 0;
}

/*
 * Find the main modules entry point. This is used as export pointer
 * for loadbind() to be able to resolve references to the main part.
 */

static void * findMain(void)

{
	struct ld_info *lp;
	char *buf;
	int size = 4*1024;
	int i;
	void *ret;

	if ((buf = malloc(size)) == NULL) {
		errvalid++;
		strcpy(errbuf, "findMain: ");
		strcat(errbuf, strerror(errno));
		return NULL;
	}

	while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) {
		free(buf);
		size += 4*1024;
		if ((buf = malloc(size)) == NULL) {





















			errvalid++;
			strcpy(errbuf, "findMain: ");
			strcat(errbuf, strerror(errno));
			return NULL;
		}
	}
	if (i == -1) {
		errvalid++;
		strcpy(errbuf, "findMain: ");
		strcat(errbuf, strerror(errno));
		free(buf);
		return NULL;
	}
	/*

	 * The first entry is the main module. The entry point
	 * returned by load() does actually point to the data


	 * segment origin.
	 */
	lp = (struct ld_info *)buf;
	ret = lp->ldinfo_dataorg;
	free(buf);
	return ret;
}




|
|
|


|
|



|





|

|
|



















|
|
|
<



|
|



|
|

>

|
|





>

|
|
|
|
|
|
|
|



|
|

>



|
|

>







|
>
|

|
|

|
|
|
|
|
>
|
|
>
|
>
|
|
>
|
|
|
>
|
|
|
|
|
>
>
|
>
|
|
|
|
|
>
|
|
>
|
|
|
|
>
|
>
|
|
|
|
|
|
>
|
|
|
<
|
>
|
|
>
|
|
|
<
|
|
|
>
|
|
>
|
|
>
|
|
|
>
|
>
|
|
|
|
|
|
>
|
|
|
|
>
|
|
>
|
|
<
<
|
<
<
|

>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<
<
<
<
<
<
<
<
|
|
|
>
|
|
|
|
|
|
|
>
>
|

|

|
|

>
|
>

|

|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
>
|

|
|
|

|
|
|
|
>
|
|
|
>
>
>
|
|
|
|

|
>
|

|
|
|
|
|

|
>
|

|
|
|

|
|
>
>
|
|
>
>
|
|
|
|
|
>
>
|
|
|
|
|
>
|
|
|
|
|
|
>
>
|
|
>
|
|
|
|
|
|
|
|

>
>
|
|
|

|
|
>

|
|
|
|
>



>
>
|

|
|
|
|
|
|
|
>

>
>
>
|
>
|
|
|
>
|
|
<
<
<
|
>
|
|
<
|
|
>
>
>
|
<
|
<
|
|
>
|
>
>
>
>
|
<
|
|
<
<
<
|
|
<
<
<
<
<
<
|
|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
|
|
>
>
|
>
|
|
<
<
<
|
|
>
|
<
|
<
<
<
|
>
|
|
|
|
|
<
<
<
<
|
<
>
>
|
>
|
<
|
<
<
<
|
>
|
|
|
|
<
<
<
<
<
|
>
>
|
|
>
|
>
>
>
<
<
<
<
|
<
<
|
<
<
|
<
<
<
>
|
>
|
|
>
|
|
|
>
|
|
|
>
|
|
>
|
>
>
>
>
<
<
<
<
<
|
<
<
|
|
|
|
>
|
|
|
|
|
>
|
|
>
>
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

|

|
|

>
|
>

|
|
|
|
|

|
<
|
|
<
|
>
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
<
<
<
<
<
<
<
|
>
|
<
>
>
|
|
<
<
<
<
<
<
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156

157
158
159
160
161
162
163
164

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197


198


199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220








221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402



403
404
405
406

407
408
409
410
411
412

413

414
415
416
417
418
419
420
421
422

423
424



425
426






427
428
429
430

431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449



450
451
452
453

454



455
456
457
458
459
460
461




462

463
464
465
466
467

468



469
470
471
472
473
474





475
476
477
478
479
480
481
482
483
484




485


486


487



488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509





510


511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583

584
585

586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618







619
620
621

622
623
624
625






/* 
 * tclLoadAix.c --
 *
 *	This file implements the dlopen and dlsym APIs under the AIX operating
 *	system, to enable the Tcl "load" command to work. This code was
 *	provided by Jens-Uwe Mager.
 *
 *	This file is subject to the following copyright notice, which is
 *	different from the notice used elsewhere in Tcl. The file has been
 *	modified to incorporate the file dlfcn.h in-line.
 *
 *	Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH
 *	Not derived from licensed software.
 *
 *	Permission is granted to freely use, copy, modify, and redistribute
 *	this software, provided that the author is not construed to be liable
 *	for any results of using the software, alterations are clearly marked
 *	as such, and this notice is not modified.
 *
 * RCS: @(#) $Id: tclLoadAix.c,v 1.3.38.1 2005/08/02 18:16:54 dgp Exp $
 *
 * Note: this file has been altered from the original in a few ways in order
 * to work properly with Tcl.
 */

/*
 * @(#)dlfcn.c	1.7 revision of 95/08/14  19:08:38
 * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH
 * 30159 Hannover, Germany
 */

#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <stdlib.h>
#include <sys/types.h>
#include <sys/ldr.h>
#include <a.out.h>
#include <ldfcn.h>
#include "../compat/dlfcn.h"

/*
 * We simulate dlopen() et al. through a call to load. Because AIX has no call
 * to find an exported symbol we read the loader section of the loaded module
 * and build a list of exported symbols and their virtual address.

 */

typedef struct {
    char *name;			/* The symbols's name. */
    void *addr;			/* Its relocated virtual address. */
} Export, *ExportPtr;

/*
 * xlC uses the following structure to list its constructors and destructors.
 * This is gleaned from the output of munch.
 */

typedef struct {
    void (*init)(void);		/* call static constructors */
    void (*term)(void);		/* call static destructors */
} Cdtor, *CdtorPtr;

/*
 * The void * handle returned from dlopen is actually a ModulePtr.
 */

typedef struct Module {
    struct Module *next;
    char *name;			/* module name for refcounting */
    int refCnt;			/* the number of references */
    void *entry;		/* entry point from load */
    struct dl_info *info;	/* optional init/terminate functions */
    CdtorPtr cdtors;		/* optional C++ constructors */
    int nExports;		/* the number of exports found */
    ExportPtr exports;		/* the array of exports */
} Module, *ModulePtr;

/*
 * We keep a list of all loaded modules to be able to call the fini handlers
 * and destructors at atexit() time.
 */

static ModulePtr modList;

/*
 * The last error from one of the dl* routines is kept in static variables
 * here. Each error is returned only once to the caller.
 */

static char errbuf[BUFSIZ];
static int errvalid;

static void caterr(char *);
static int readExports(ModulePtr);
static void terminate(void);
static void *findMain(void);

VOID *
dlopen(const char *path, int mode)
{
    register ModulePtr mp;
    static void *mainModule;

    /*
     * Upon the first call register a terminate handler that will close all
     * libraries. Also get a reference to the main module for use with
     * loadbind.
     */

    if (!mainModule) {
	mainModule = findMain();
	if (mainModule == NULL) {
	    return NULL;
	}
	atexit(terminate);
    }

    /*
     * Scan the list of modules if we have the module already loaded.
     */

    for (mp = modList; mp; mp = mp->next) {
	if (strcmp(mp->name, path) == 0) {
	    mp->refCnt++;
	    return (VOID *) mp;
	}
    }

    mp = (ModulePtr) calloc(1, sizeof(*mp));
    if (mp == NULL) {
	errvalid++;
	strcpy(errbuf, "calloc: ");
	strcat(errbuf, strerror(errno));
	return (VOID *) NULL;
    }

    mp->name = malloc((unsigned) (strlen(path) + 1));
    strcpy(mp->name, path);

    /*
     * load should be declared load(const char *...). Thus we cast the path to
     * a normal char *. Ugly.
     */

    mp->entry = (void *) load((char *)path, L_NOAUTODEFER, NULL);
    if (mp->entry == NULL) {
	free(mp->name);
	free(mp);
	errvalid++;
	strcpy(errbuf, "dlopen: ");
	strcat(errbuf, path);
	strcat(errbuf, ": ");

	/*
	 * If AIX says the file is not executable, the error can be further
	 * described by querying the loader about the last error.

	 */

	if (errno == ENOEXEC) {
	    char *tmp[BUFSIZ/sizeof(char *)], **p;

	    if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) {
		strcpy(errbuf, strerror(errno));
	    } else {

		for (p=tmp ; *p ; p++) {
		    caterr(*p);
		}
	    }
	} else {
	    strcat(errbuf, strerror(errno));
	}
	return (VOID *) NULL;
    }

    mp->refCnt = 1;
    mp->next = modList;
    modList = mp;

    if (loadbind(0, mainModule, mp->entry) == -1) {
    loadbindFailure:
	dlclose(mp);
	errvalid++;
	strcpy(errbuf, "loadbind: ");
	strcat(errbuf, strerror(errno));
	return (VOID *) NULL;
    }

    /*
     * If the user wants global binding, loadbind against all other loaded
     * modules.
     */

    if (mode & RTLD_GLOBAL) {
	register ModulePtr mp1;

	for (mp1 = mp->next; mp1; mp1 = mp1->next) {
	    if (loadbind(0, mp1->entry, mp->entry) == -1) {


		goto loadbindFailure;


	    }
	}
    }

    if (readExports(mp) == -1) {
	dlclose(mp);
	return (VOID *) NULL;
    }

    /*
     * If there is a dl_info structure, call the init function.
     */

    if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) {
	if (mp->info->init) {
	    (*mp->info->init)();
	}
    } else {
	errvalid = 0;
    }

    /*








     * If the shared object was compiled using xlC we will need to call static
     * constructors (and later on dlclose destructors).
     */

    if (mp->cdtors = (CdtorPtr) dlsym(mp, "__cdtors")) {
	while (mp->cdtors->init) {
	    (*mp->cdtors->init)();
	    mp->cdtors++;
	}
    } else {
	errvalid = 0;
    }

    return (VOID *) mp;
}

/*
 * Attempt to decipher an AIX loader error message and append it to our static
 * error message buffer.
 */

static void
caterr(char *s)
{
    register char *p = s;

    while (*p >= '0' && *p <= '9') {
	p++;
    }
    switch (atoi(s)) {		/* INTL: "C", UTF safe. */
    case L_ERROR_TOOMANY:
	strcat(errbuf, "to many errors");
	break;
    case L_ERROR_NOLIB:
	strcat(errbuf, "can't load library");
	strcat(errbuf, p);
	break;
    case L_ERROR_UNDEF:
	strcat(errbuf, "can't find symbol");
	strcat(errbuf, p);
	break;
    case L_ERROR_RLDBAD:
	strcat(errbuf, "bad RLD");
	strcat(errbuf, p);
	break;
    case L_ERROR_FORMAT:
	strcat(errbuf, "bad exec format in");
	strcat(errbuf, p);
	break;
    case L_ERROR_ERRNO:
	strcat(errbuf, strerror(atoi(++p)));	/* INTL: "C", UTF safe. */
	break;
    default:
	strcat(errbuf, s);
	break;
    }
}

VOID *
dlsym(void *handle, const char *symbol)
{
    register ModulePtr mp = (ModulePtr)handle;
    register ExportPtr ep;
    register int i;

    /*
     * Could speed up the search, but I assume that one assigns the result to
     * function pointers anyways.
     */

    for (ep = mp->exports, i = mp->nExports; i; i--, ep++) {
	if (strcmp(ep->name, symbol) == 0) {
	    return ep->addr;
	}
    }

    errvalid++;
    strcpy(errbuf, "dlsym: undefined symbol ");
    strcat(errbuf, symbol);
    return NULL;
}

char *
dlerror(void)
{
    if (errvalid) {
	errvalid = 0;
	return errbuf;
    }
    return NULL;
}

int
dlclose(void *handle)
{
    register ModulePtr mp = (ModulePtr)handle;
    int result;
    register ModulePtr mp1;

    if (--mp->refCnt > 0) {
	return 0;
    }

    if (mp->info && mp->info->fini) {
	(*mp->info->fini)();
    }

    if (mp->cdtors) {
	while (mp->cdtors->term) {
	    (*mp->cdtors->term)();
	    mp->cdtors++;
	}
    }

    result = unload(mp->entry);
    if (result == -1) {
	errvalid++;
	strcpy(errbuf, strerror(errno));
    }

    if (mp->exports) {
	register ExportPtr ep;
	register int i;
	for (ep = mp->exports, i = mp->nExports; i; i--, ep++) {
	    if (ep->name) {
		free(ep->name);
	    }
	}
	free(mp->exports);
    }

    if (mp == modList) {
	modList = mp->next;
    } else {
	for (mp1 = modList; mp1; mp1 = mp1->next) {
	    if (mp1->next == mp) {
		mp1->next = mp->next;
		break;
	    }
	}
    }

    free(mp->name);
    free(mp);
    return result;
}

static void
terminate(void)
{
    while (modList) {
	dlclose(modList);
    }
}

/*
 * Build the export table from the XCOFF .loader section.
 */

static int
readExports(ModulePtr mp)
{
    LDFILE *ldp = NULL;
    SCNHDR sh, shdata;
    LDHDR *lhp;
    char *ldbuf;
    LDSYM *ls;
    int i;
    ExportPtr ep;
    const char *errMsg;

#define Error(msg) do{errMsg=(msg);goto error;}while(0)
#define SysErr() Error(strerror(errno))

    ldp = ldopen(mp->name, ldp);
    if (ldp == NULL) {
	struct ld_info *lp;
	char *buf;
	int size = 0;

	if (errno != ENOENT) {
	    SysErr();



	}

	/*
	 * The module might be loaded due to the LIBPATH environment variable.

	 * Search for the loaded module using L_GETINFO.
	 */

	while (1) {
	    size += 4 * 1024;
	    buf = malloc(size);

	    if (buf == NULL) {

		SysErr();
	    }

	    i = loadquery(L_GETINFO, buf, size);

	    if (i != -1) {
		break;
	    }
	    free(buf);

	    if (errno != ENOMEM) {
		SysErr();



	    }
	}







	/*
	 * Traverse the list of loaded modules. The entry point returned by
	 * load() does actually point to the data segment origin.

	 */

	lp = (struct ld_info *) buf;
	while (lp) {
	    if (lp->ldinfo_dataorg == mp->entry) {
		ldp = ldopen(lp->ldinfo_filename, ldp);
		break;
	    }
	    if (lp->ldinfo_next == 0) {
		lp = NULL;
	    } else {
		lp = (struct ld_info *)((char *)lp + lp->ldinfo_next);
	    }
	}

	free(buf);

	if (!ldp) {
	    SysErr();



	}
    }

    if (TYPE(ldp) != U802TOCMAGIC) {

	Error("bad magic");



    }

    /*
     * Get the padding for the data section. This is needed for AIX 4.1
     * compilers. This is used when building the final function pointer to the
     * exported symbol.
     */






    if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) {
	Error("cannot read data section header");
    }

    if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) {

	Error("cannot read loader section header");



    }

    /*
     * We read the complete loader section in one chunk, this makes finding
     * long symbol names residing in the string table easier.
     */






    ldbuf = (char *) malloc(sh.s_size);
    if (ldbuf == NULL) {
	SysErr();
    }

    if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) {
	free(ldbuf);
	Error("cannot seek to loader section");
    }







    if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) {


	free(ldbuf);



	Error("cannot read loader section");
    }

    lhp = (LDHDR *) ldbuf;
    ls = (LDSYM *)(ldbuf + LDHDRSZ);

    /*
     * Count the number of exports to include in our export table.
     */

    for (i = lhp->l_nsyms; i; i--, ls++) {
	if (!LDR_EXPORT(*ls)) {
	    continue;
	}
	mp->nExports++;
    }

    mp->exports = (ExportPtr) calloc(mp->nExports, sizeof(*mp->exports));
    if (mp->exports == NULL) {
	free(ldbuf);
	SysErr();
    }








    /*
     * Fill in the export table. All entries are relative to the entry point
     * we got from load.
     */

    ep = mp->exports;
    ls = (LDSYM *)(ldbuf + LDHDRSZ);
    for (i=lhp->l_nsyms ; i!=0 ; i--,ls++) {
	char *symname;
	char tmpsym[SYMNMLEN+1];

	if (!LDR_EXPORT(*ls)) {
	    continue;
	}

	if (ls->l_zeroes == 0) {
	    symname = ls->l_offset + lhp->l_stoff + ldbuf;
	} else {
	    /*
	     * The l_name member is not zero terminated, we must copy the
	     * first SYMNMLEN chars and make sure we have a zero byte at the
	     * end.
	     */

	    strncpy(tmpsym, ls->l_name, SYMNMLEN);
	    tmpsym[SYMNMLEN] = '\0';
	    symname = tmpsym;
	}
	ep->name = malloc((unsigned) (strlen(symname) + 1));
	strcpy(ep->name, symname);
	ep->addr = (void *)((unsigned long)
		mp->entry + ls->l_value - shdata.s_vaddr);
	ep++;
    }
    free(ldbuf);
    while (ldclose(ldp) == FAILURE) {
	/* Empty body */
    }
    return 0;

    /*
     * This is a factoring out of the error-handling code to make the rest of
     * the function much simpler to read.
     */

  error:
    errvalid++;
    strcpy(errbuf, "readExports: ");
    strcat(errbuf, errMsg);

    if (ldp != NULL) {
	while (ldclose(ldp) == FAILURE) {
	    /* Empty body */
	}
    }
    return -1;
}

/*
 * Find the main modules entry point. This is used as export pointer for
 * loadbind() to be able to resolve references to the main part.
 */

static void *
findMain(void)
{
    struct ld_info *lp;
    char *buf;
    int size = 4*1024;
    int i;
    void *ret;

    buf = malloc(size);

    if (buf == NULL) {
	goto error;

    }

    while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) {
	free(buf);
	size += 4*1024;
	buf = malloc(size);
	if (buf == NULL) {
	    goto error;
	}
    }

    if (i == -1) {
	free(buf);
	goto error;
    }

    /*
     * The first entry is the main module. The entry point returned by load()
     * does actually point to the data segment origin.
     */

    lp = (struct ld_info *) buf;
    ret = lp->ldinfo_dataorg;
    free(buf);
    return ret;

  error:
    errvalid++;
    strcpy(errbuf, "findMain: ");
    strcat(errbuf, strerror(errno));
    return NULL;
}








/*
 * Local Variables:
 * mode: c

 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






Deleted unix/tclLoadAout.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
/* 
 * tclLoadAout.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	provides pseudo-static linking using version-7 compatible
 *	a.out files described in either sys/exec.h or sys/a.out.h.
 *
 * Copyright (c) 1995, by General Electric Company. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This work was supported in part by the ARPA Manufacturing Automation
 * and Design Engineering (MADE) Initiative through ARPA contract
 * F33615-94-C-4400.
 *
 * RCS: @(#) $Id: tclLoadAout.c,v 1.14 2002/10/10 12:25:53 vincentdarley Exp $
 */

#include "tclInt.h"
#include <fcntl.h>
#ifdef HAVE_EXEC_AOUT_H
#   include <sys/exec_aout.h>
#endif
#ifdef HAVE_UNISTD_H
#   include <unistd.h>
#else
#   include "../compat/unistd.h"
#endif

/*
 * Some systems describe the a.out header in sys/exec.h, and some in
 * a.out.h.
 */

#ifdef USE_SYS_EXEC_H
#include <sys/exec.h>
#endif
#ifdef USE_A_OUT_H
#include <a.out.h>
#endif
#ifdef USE_SYS_EXEC_AOUT_H
#include <sys/exec_aout.h>
#define a_magic a_midmag
#endif

/*
 * TCL_LOADSHIM is the amount by which to shim the break when loading
 */

#ifndef TCL_LOADSHIM
#define TCL_LOADSHIM 0x4000L
#endif

/*
 * TCL_LOADALIGN must be a power of 2, and is the alignment to which
 * to force the origin of load modules
 */

#ifndef TCL_LOADALIGN
#define TCL_LOADALIGN 0x4000L
#endif

/*
 * TCL_LOADMAX is the maximum size of a load module, and is used as
 * a sanity check when loading
 */

#ifndef TCL_LOADMAX
#define TCL_LOADMAX 2000000L
#endif

/*
 * Kernel calls that appear to be missing from the system .h files:
 */

extern char * brk _ANSI_ARGS_((char *));
extern char * sbrk _ANSI_ARGS_((size_t));

/*
 * The static variable SymbolTableFile contains the file name where the
 * result of the last link was stored.  The file is kept because doing so
 * allows one load module to use the symbols defined in another.
 */

static char * SymbolTableFile = NULL;

/*
 * Type of the dictionary function that begins each load module.
 */

typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((CONST char * symbol));

/*
 * Prototypes for procedures referenced only in this file:
 */

static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr,
				      Tcl_DString * buf));
static void UnlinkSymbolTable _ANSI_ARGS_((void));

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result. 
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *
 * Bugs:
 *	This function does not attempt to handle the case where the
 *	BSS segment is not executable.  It will therefore fail on
 *	Encore Multimax, Pyramid 90x, and similar machines.  The
 *	reason is that the mprotect() kernel call, which would
 *	otherwise be employed to mark the newly-loaded text segment
 *	executable, results in a system crash on BSD/386.
 *
 *	In an effort to make it fast, this function eschews the
 *	technique of linking the load module once, reading its header
 *	to determine its size, allocating memory for it, and linking
 *	it again.  Instead, it `shims out' memory allocation by
 *	placing the module TCL_LOADSHIM bytes beyond the break,
 *	and assuming that any malloc() calls required to run the
 *	linker will not advance the break beyond that point.  If
 *	the break is advanced beyonnd that point, the load will
 *	fail with an `inconsistent memory allocation' error.
 *	It perhaps ought to retry the link, but the failure has
 *	not been observed in two years of daily use of this function.
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    char * inputSymbolTable;	/* Name of the file containing the 
				 * symbol table from the last link. */
    Tcl_DString linkCommandBuf;	/* Command to do the run-time relocation
				 * of the module.*/
    char * linkCommand;
    char relocatedFileName [L_tmpnam];
				/* Name of the file holding the relocated */
				/* text of the module */
    int relocatedFd;		/* File descriptor of the file holding
				 * relocated text */
    struct exec relocatedHead;	/* Header of the relocated text */
    unsigned long relocatedSize;/* Size of the relocated text */
    char * startAddress;	/* Starting address of the module */
    int status;			/* Status return from Tcl_ calls */
    char * p;

    /* Find the file that contains the symbols for the run-time link. */
    
    if (SymbolTableFile != NULL) {
	inputSymbolTable = SymbolTableFile;
    } else if (tclExecutableName == NULL) {
	Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
	return TCL_ERROR;
    } else {
	inputSymbolTable = tclExecutableName;
    }
    
    /* Construct the `ld' command that builds the relocated module */
    
    tmpnam (relocatedFileName);
    Tcl_DStringInit (&linkCommandBuf);
    Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1);
    Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1);
#if defined(__mips) || defined(mips)
    Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1);
#endif
    Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1);
    TclGuessPackageName(Tcl_GetString(pathPtr), &linkCommandBuf);
    Tcl_DStringAppend (&linkCommandBuf, " -A ", -1);
    Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1);
    Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1);
    Tcl_DStringAppend (&linkCommandBuf, Tcl_GetString(pathPtr), -1);
    Tcl_DStringAppend (&linkCommandBuf, " ", -1);
    
    if (FindLibraries (interp, pathPtr, &linkCommandBuf) != TCL_OK) {
	Tcl_DStringFree (&linkCommandBuf);
	return TCL_ERROR;
    }
    
    linkCommand = Tcl_DStringValue (&linkCommandBuf);
    
    /* Determine the starting address, and plug it into the command */
    
    startAddress = (char *) (((unsigned long) sbrk (0)
			      + TCL_LOADSHIM + TCL_LOADALIGN - 1)
			     & (- TCL_LOADALIGN));
    p = strstr (linkCommand, "-T") + 3;
    sprintf (p, "%08lx", (long) startAddress);
    p [8] = ' ';
    
    /* Run the linker */
    
    status = Tcl_Eval (interp, linkCommand);
    Tcl_DStringFree (&linkCommandBuf);
    if (status != 0) {
	return TCL_ERROR;
    }
    
    /* Open the linker's result file and read the header */
    
    relocatedFd = open (relocatedFileName, O_RDONLY);
    if (relocatedFd < 0) {
	goto ioError;
    }
    status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead);
    if (status < sizeof relocatedHead) {
	goto ioError;
    }
    
    /* Check the magic number */
    
    if (relocatedHead.a_magic != OMAGIC) {
	Tcl_AppendResult (interp, "bad magic number in intermediate file \"",
			  relocatedFileName, "\"", (char *) NULL);
	goto failure;
    }
    
    /* Make sure that memory allocation is still consistent */
    
    if ((unsigned long) sbrk (0) > (unsigned long) startAddress) {
	Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.",
		       TCL_STATIC);
	goto failure;
    }
    
    /* Make sure that the relocated module's size is reasonable */
    
    relocatedSize = relocatedHead.a_text + relocatedHead.a_data
      + relocatedHead.a_bss;
    if (relocatedSize > TCL_LOADMAX) {
	Tcl_SetResult (interp, "module too big to load", TCL_STATIC);
	goto failure;
    }
    
    /* Advance the break to protect the loaded module */
    
    (void) brk (startAddress + relocatedSize);
    
    /*
     * Seek to the start of the module's text.
     *
     * Note that this does not really work with large files (i.e. where
     * lseek64 exists and is different to lseek), but anyone trying to
     * dynamically load a binary that is larger than what can fit in
     * addressable memory is in trouble anyway...
     */
    
#if defined(__mips) || defined(mips)
    status = lseek (relocatedFd,
		    (off_t) N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o),
		    SEEK_SET);
#else
    status = lseek (relocatedFd, (off_t) N_TXTOFF (relocatedHead), SEEK_SET);
#endif
    if (status < 0) {
	goto ioError;
    }
    
    /* Read in the module's text and data */
    
    relocatedSize = relocatedHead.a_text + relocatedHead.a_data;
    if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) {
	brk (startAddress);
      ioError:
	Tcl_AppendResult (interp, "error on intermediate file \"",
			  relocatedFileName, "\": ", Tcl_PosixError (interp),
			  (char *) NULL);
      failure:
	(void) unlink (relocatedFileName);
	return TCL_ERROR;
    }
    
    /* Close the intermediate file. */
    
    (void) close (relocatedFd);
    
    /* Arrange things so that intermediate symbol tables eventually get
    * deleted. */
    
    if (SymbolTableFile != NULL) {
	UnlinkSymbolTable ();
    } else {
	atexit (UnlinkSymbolTable);
    }
    SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
    strcpy (SymbolTableFile, relocatedFileName);
    
    *loadHandle = startAddress;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    /* Look up the entry point in the load module's dictionary. */
    DictFn dictionary = (DictFn) loadHandle;
    return (Tcl_PackageInitProc*) dictionary(sym1);
}


/*
 *------------------------------------------------------------------------
 *
 * FindLibraries --
 *
 *	Find the libraries needed to link a load module at run time.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs,
 *	an error message is left in the interp's result.  The -l and -L
 *	flags are concatenated onto the dynamic string `buf'.
 *
 *------------------------------------------------------------------------
 */

static int
FindLibraries (interp, pathPtr, buf)
    Tcl_Interp * interp;	/* Used for error reporting */
    Tcl_Obj * pathPtr;		/* Name of the load module */
    Tcl_DString * buf;		/* Buffer where the -l an -L flags */
{
    FILE * f;			/* The load module */
    int c = 0;			/* Byte from the load module */
    char * p;
    CONST char *native;

    char *fileName = Tcl_GetString(pathPtr);
  
    /* Open the load module */
    
    native = Tcl_FSGetNativePath(pathPtr);
    f = fopen(native, "rb");				/* INTL: Native. */
    
    if (f == NULL) {
	Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ",
			  Tcl_PosixError (interp), (char *) NULL);
	return TCL_ERROR;
    }
    
    /* Search for the library list in the load module */
    
    p = "@LIBS: ";
    while (*p != '\0' && (c = getc (f)) != EOF) {
	if (c == *p) {
	    ++p;
	}
	else {
	    p = "@LIBS: ";
	    if (c == *p) {
		++p;
	    }
	}
    }
    
    /* No library list -- this must be an ill-formed module */
    
    if (c == EOF) {
	Tcl_AppendResult (interp, "File \"", fileName,
			  "\" is not a Tcl load module.", (char *) NULL);
	(void) fclose (f);
	return TCL_ERROR;
    }
    
    /* Accumulate the library list */
    
    while ((c = getc (f)) != '\0' && c != EOF) {
	char cc = c;
	Tcl_DStringAppend (buf, &cc, 1);
    }
    (void) fclose (f);
    
    if (c == EOF) {
	Tcl_AppendResult (interp, "Library directory in \"", fileName,
			  "\" ends prematurely.", (char *) NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * UnlinkSymbolTable --
 *
 *	Remove the symbol table file from the last dynamic link.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The symbol table file from the last dynamic link is removed.
 *	This function is called when (a) a new symbol table is present
 *	because another dynamic link is complete, or (b) the process
 *	is exiting.
 *------------------------------------------------------------------------
 */

static void
UnlinkSymbolTable ()
{
    (void) unlink (SymbolTableFile);
    ckfree (SymbolTableFile);
    SymbolTableFile = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    CONST char *p, *q;
    char *r;

    if ((q = strrchr(fileName,'/'))) {
	q++;
    } else {
	q = fileName;
    }
    if (!strncmp(q,"lib",3)) {
	q+=3;
    }
    p = q;
    while ((*p) && (*p != '.') && ((*p<'0') || (*p>'9'))) {
	p++;
    }
    if ((p>q+2) && !strncmp(p-2,"_G0.",4)) {
	p-=2;
    }
    if (p<q) {
	return 0;
    }

    Tcl_DStringAppend(bufPtr,q, p-q);

    r = Tcl_DStringValue(bufPtr);
    r += strlen(r) - (p-q);

    /*
     * Capitalize the string and then recompute the length.
     */

    Tcl_UtfToTitle(r);
    Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));

    return 1;
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Changes to unix/tclLoadDl.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84

85
86

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118

119
120
121
122
123
124
125
126
127
128

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210








/* 
 * tclLoadDl.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the "dlopen" and "dlsym" library procedures for
 *	dynamic loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDl.c,v 1.13 2002/10/10 12:25:53 vincentdarley Exp $
 */

#include "tclInt.h"
#ifdef NO_DLFCN_H
#   include "../compat/dlfcn.h"
#else
#   include <dlfcn.h>
#endif

/*
 * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined
 * and this argument to dlopen must always be 1.  The RTLD_GLOBAL
 * flag is needed on some systems (e.g. SCO and UnixWare) but doesn't
 * exist on others;  if it doesn't exist, set it to 0 so it has no effect.
 */

#ifndef RTLD_NOW
#   define RTLD_NOW 1
#endif

#ifndef RTLD_GLOBAL
#   define RTLD_GLOBAL 0
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result. 
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *---------------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    VOID *handle;
    CONST char *native;

    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
    if (handle == NULL) {
	/* 
	 * Let the OS loader examine the binary search path for
	 * whatever string the user gave us which hopefully refers
	 * to a file on the binary path
	 */

	Tcl_DString ds;
	char *fileName = Tcl_GetString(pathPtr);

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
	Tcl_DStringFree(&ds);
    }
    
    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", dlerror(), (char *) NULL);
	return TCL_ERROR;
    }

    *unloadProcPtr = &TclpUnloadFile;
    *loadHandle = (Tcl_LoadHandle)handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    CONST char *native;
    Tcl_DString newName, ds;
    VOID *handle = (VOID*)loadHandle;
    Tcl_PackageInitProc *proc;

    /* 
     * Some platforms still add an underscore to the beginning of symbol
     * names.  If we can't find a name without an underscore, try again
     * with the underscore.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    proc = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
	    native);	
    if (proc == NULL) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	native = Tcl_DStringAppend(&newName, native, -1);
	proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
		native);
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);

    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    VOID *handle;

    handle = (VOID *) loadHandle;
    dlclose(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    return 0;
}








|


|
|
<



|
|

|










|
|
|
|















|
|


|
|













|

|

|
|




|
|
|
|

>



|
|
|
|

>


>




|

|
|
<













|
|


|
|
|



>

|
|
|
|





>
|

|
|




|


















|
|
|












|
|
|
<












|
|


|
|
|
|











|
|



>
>
>
>
>
>
>
>
1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
/*
 * tclLoadDl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	the "dlopen" and "dlsym" library procedures for dynamic loading.

 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDl.c,v 1.13.6.1 2005/08/02 18:16:54 dgp Exp $
 */

#include "tclInt.h"
#ifdef NO_DLFCN_H
#   include "../compat/dlfcn.h"
#else
#   include <dlfcn.h>
#endif

/*
 * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this
 * argument to dlopen must always be 1. The RTLD_GLOBAL flag is needed on some
 * systems (e.g. SCO and UnixWare) but doesn't exist on others; if it doesn't
 * exist, set it to 0 so it has no effect.
 */

#ifndef RTLD_NOW
#   define RTLD_NOW 1
#endif

#ifndef RTLD_GLOBAL
#   define RTLD_GLOBAL 0
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *---------------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    VOID *handle;
    CONST char *native;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
    if (handle == NULL) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;
	char *fileName = Tcl_GetString(pathPtr);

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
	Tcl_DStringFree(&ds);
    }

    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"",
		Tcl_GetString(pathPtr), "\": ", dlerror(), (char *) NULL);

	return TCL_ERROR;
    }

    *unloadProcPtr = &TclpUnloadFile;
    *loadHandle = (Tcl_LoadHandle)handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;		/* Place to put error messages. */
    Tcl_LoadHandle loadHandle;	/* Value from TcpDlopen(). */
    CONST char *symbol;		/* Symbol to look up. */
{
    CONST char *native;
    Tcl_DString newName, ds;
    VOID *handle = (VOID*)loadHandle;
    Tcl_PackageInitProc *proc;

    /*
     * Some platforms still add an underscore to the beginning of symbol
     * names. If we can't find a name without an underscore, try again with
     * the underscore.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    proc = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
	    native);
    if (proc == NULL) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	native = Tcl_DStringAppend(&newName, native, -1);
	proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
		native);
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);

    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */

{
    VOID *handle;

    handle = (VOID *) loadHandle;
    dlclose(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name. A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring. Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclLoadDld.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
/* 
 * tclLoadDld.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the "dld_link" and "dld_get_func" library procedures
 *	for dynamic loading.  It has been tested on Linux 1.1.95 and
 *	dld-3.2.7.  This file probably isn't needed anymore, since it
 *	makes more sense to use "dl_open" etc.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDld.c,v 1.12 2002/10/10 12:25:53 vincentdarley Exp $
 */

#include "tclInt.h"
#include "dld.h"

/*
 * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined
 * and this argument to dlopen must always be 1.
 */

#ifndef RTLD_NOW
#   define RTLD_NOW 1
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    static int firstTime = 1;
    int returnCode;
    char *fileName;
    CONST char *native;
    
    /*
     *  The dld package needs to know the pathname to the tcl binary.
     *  If that's not known, return an error.
     */

    if (firstTime) {
	if (tclExecutableName == NULL) {
	    Tcl_SetResult(interp,
		    "don't know name of application binary file, so can't initialize dynamic loader",
		    TCL_STATIC);
|


|
|
|
|
|



|
|

|






|
|











|
|


|
|













|

|

|
|





|

|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
/*
 * tclLoadDld.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	the "dld_link" and "dld_get_func" library procedures for dynamic
 *	loading. It has been tested on Linux 1.1.95 and dld-3.2.7. This file
 *	probably isn't needed anymore, since it makes more sense to use
 *	"dl_open" etc.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDld.c,v 1.12.6.1 2005/08/02 18:16:54 dgp Exp $
 */

#include "tclInt.h"
#include "dld.h"

/*
 * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this
 * argument to dlopen must always be 1.
 */

#ifndef RTLD_NOW
#   define RTLD_NOW 1
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    static int firstTime = 1;
    int returnCode;
    char *fileName;
    CONST char *native;

    /*
     *  The dld package needs to know the pathname to the tcl binary.  If
     *  that's not known, return an error.
     */

    if (firstTime) {
	if (tclExecutableName == NULL) {
	    Tcl_SetResult(interp,
		    "don't know name of application binary file, so can't initialize dynamic loader",
		    TCL_STATIC);
83
84
85
86
87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201








	    return TCL_ERROR;
	}
	firstTime = 0;
    }

    fileName = Tcl_GetString(pathPtr);

    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    returnCode = dld_link(native);
    
    if (returnCode != 0) {
	Tcl_DString ds;
	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	returnCode = dld_link(native);
	Tcl_DStringFree(&ds);
    }

    if (returnCode != 0) {
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 fileName, "\": ", 
			 dld_strerror(returnCode), (char *) NULL);
	return TCL_ERROR;
    }
    *loadHandle = (Tcl_LoadHandle) strcpy(
	    (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return (Tcl_PackageInitProc *) dld_get_func(symbol);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    char *fileName;

    handle = (char *) loadHandle;
    dld_unlink_by_file(handle, 0);
    ckfree(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    return 0;
}















|
|
|
|

>


|








|
<
|













|
|


|
|
|



>

|












|
|
|












|
|
|
<













|
|


|
|
|
|











|
|



>
>
>
>
>
>
>
>
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
	    return TCL_ERROR;
	}
	firstTime = 0;
    }

    fileName = Tcl_GetString(pathPtr);

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    returnCode = dld_link(native);

    if (returnCode != 0) {
	Tcl_DString ds;
	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	returnCode = dld_link(native);
	Tcl_DStringFree(&ds);
    }

    if (returnCode != 0) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",

		dld_strerror(returnCode), (char *) NULL);
	return TCL_ERROR;
    }
    *loadHandle = (Tcl_LoadHandle) strcpy(
	    (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return (Tcl_PackageInitProc *) dld_get_func(symbol);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen().  The loadHandle is a token
				 * that represents the loaded file. */

{
    char *fileName;

    handle = (char *) loadHandle;
    dld_unlink_by_file(handle, 0);
    ckfree(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name. A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring. Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclLoadDyld.c.

1
2
3
4
5

6
7
8
9

10
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29








30
31
32





































33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62


63
64
65
66
67
68
69

70
71
72
73
74
75







76
77
78
79
80

81
82

83
84
85
86
87


88










89

90






















91

92

93
94
95
96
97






98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140


141
142
143
144







145
146







147
148
149
150
151
152


153
154

155

156
157







158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

180
181
182
183
184
185
186
187
188
189
190
191
192


193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
















































































220
221
222
223
224





















225


















































226
227




228



229



230






231
232









/* 
 * tclLoadDyld.c --
 *
 *     This procedure provides a version of the TclLoadFile that
 *     works with Apple's dyld dynamic loading.  This file

 *     provided by Wilfredo Sanchez ([email protected]).
 *     This works on Mac OS X.
 *
 * Copyright (c) 1995 Apple Computer, Inc.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDyld.c,v 1.15 2004/04/06 22:25:56 dgp Exp $
 */

#include "tclInt.h"
#include <mach-o/dyld.h>


typedef struct Tcl_DyldModuleHandle {
    struct Tcl_DyldModuleHandle *nextModuleHandle;
    NSModule module;
} Tcl_DyldModuleHandle;

typedef struct Tcl_DyldLoadHandle {
    const struct mach_header *dyld_lib;
    Tcl_DyldModuleHandle *firstModuleHandle;
} Tcl_DyldLoadHandle;









/*
 *----------------------------------------------------------------------
 *





































 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *     A standard Tcl completion code.  If an error occurs, an error
 *     message is left in the interpreter's result. 
 *
 * Side effects:
 *     New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle;
    const struct mach_header *dyld_lib;


    CONST char *native;

    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    dyld_lib = NSAddImage(native, 
			  NSADDIMAGE_OPTION_WITH_SEARCHING | 
			  NSADDIMAGE_OPTION_RETURN_ON_ERROR);
    
    if (!dyld_lib) {







	/* 
	 * Let the OS loader examine the binary search path for
	 * whatever string the user gave us which hopefully refers
	 * to a file on the binary path
	 */

	Tcl_DString ds;
	char *fileName = Tcl_GetString(pathPtr);

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	dyld_lib = NSAddImage(native, 
			      NSADDIMAGE_OPTION_WITH_SEARCHING | 
			      NSADDIMAGE_OPTION_RETURN_ON_ERROR);
	Tcl_DStringFree(&ds);


    }










    

    if (!dyld_lib) {






















        NSLinkEditErrors editError;

        char *name, *msg;

        NSLinkEditError(&editError, &errno, &name, &msg);
        Tcl_AppendResult(interp, msg, (char *) NULL);
        return TCL_ERROR;
    }
    






    dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle));
    if (!dyldLoadHandle) return TCL_ERROR;
    dyldLoadHandle->dyld_lib = dyld_lib;
    dyldLoadHandle->firstModuleHandle = NULL;
    *loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    NSSymbol nsSymbol;
    CONST char *native;
    Tcl_DString newName, ds;
    Tcl_PackageInitProc* proc = NULL;
    Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;

    /* 
     * dyld adds an underscore to the beginning of symbol names.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    Tcl_DStringInit(&newName);
    Tcl_DStringAppend(&newName, "_", 1);
    native = Tcl_DStringAppend(&newName, native, -1);


    nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyld_lib, native, 
	NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | 
	NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
    if(nsSymbol) {







	Tcl_DyldModuleHandle *dyldModuleHandle;
	proc = NSAddressOfSymbol(nsSymbol);







	dyldModuleHandle = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
	if (dyldModuleHandle) {
	    dyldModuleHandle->module = NSModuleForSymbol(nsSymbol);
	    dyldModuleHandle->nextModuleHandle = dyldLoadHandle->firstModuleHandle;
	    dyldLoadHandle->firstModuleHandle = dyldModuleHandle;
	}


    } else {
        NSLinkEditErrors editError;

        char *name, *msg;

        NSLinkEditError(&editError, &errno, &name, &msg);
        Tcl_AppendResult(interp, msg, (char *) NULL);







    }
    Tcl_DStringFree(&newName);
    Tcl_DStringFree(&ds);
    
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *     Unloads a dynamically loaded binary code file from memory.
 *     Code pointers in the formerly loaded file are no longer valid
 *     after calling this function.
 *
 * Results:
 *     None.
 *
 * Side effects:
 *     Code dissapears from memory.
 *     Note that this is a no-op on older (OpenStep) versions of dyld.

 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
    Tcl_DyldModuleHandle *dyldModuleHandle = dyldLoadHandle->firstModuleHandle;


    void *ptr;

    while (dyldModuleHandle) {
	NSUnLinkModule(dyldModuleHandle->module, NSUNLINKMODULE_OPTION_NONE);
	ptr = dyldModuleHandle;
	dyldModuleHandle = dyldModuleHandle->nextModuleHandle;
	ckfree(ptr);
    }
    ckfree(dyldLoadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *     If the "load" command is invoked without providing a package
 *     name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *     Always returns 0 to indicate that we couldn't figure out a
 *     package name;  generic code will then try to guess the package
 *     from the file name.  A return value of 1 would have meant that
 *     we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *     None.
















































































 *
 *----------------------------------------------------------------------
 */

int





















TclGuessPackageName(fileName, bufPtr)


















































    CONST char *fileName;      /* Name of file containing package (already
				* translated to local form if needed). */




    Tcl_DString *bufPtr;       /* Initialized empty dstring.  Append



				* package name to this if possible. */



{






    return 0;
}









|


|
|
>
|
<


>

|
|

|




>


|




|
|


>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|


|
|


|




|





|

|

|
|


|
>
>


|
|
|
|

>

<
|
|
|
|
>
>
>
>
>
>
>
|
|
|
|
|
>
|
|
>
|
|
|
|
|
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
|
|
|
|
|
>
>
>
>
>
>
|
|
|
|










|
|


|
|
|



>
|
|
|
|
|






>
|







>
>
|
|
|
|
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
|
|
|
|
|
|
>
>
|
|
>
|
>
|
|
>
>
>
>
>
>
>



|


|





|
|
|


|


|
|
>




|

|
|
|
<


|
>
>
|

|
|
|
|


|

|





|
|


|
|
|
|


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
|
>
>
>
|
>
>
>
|
>
>
>
>
>
>
|

>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
/*
 * tclLoadDyld.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	Apple's dyld dynamic loading.
 *	Original version of his file (now superseded long ago) provided by
 *	Wilfredo Sanchez ([email protected]).

 *
 * Copyright (c) 1995 Apple Computer, Inc.
 * Copyright (c) 2005 Daniel A. Steffen <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDyld.c,v 1.15.2.3 2005/08/02 18:16:54 dgp Exp $
 */

#include "tclInt.h"
#include <mach-o/dyld.h>
#include <mach/mach.h>

typedef struct Tcl_DyldModuleHandle {
    struct Tcl_DyldModuleHandle *nextPtr;
    NSModule module;
} Tcl_DyldModuleHandle;

typedef struct Tcl_DyldLoadHandle {
    CONST struct mach_header *dyldLibHeader;
    Tcl_DyldModuleHandle *modulePtr;
} Tcl_DyldLoadHandle;

#ifdef TCL_LOAD_FROM_MEMORY
typedef struct ThreadSpecificData {
    int haveLoadMemory;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
#endif

/*
 *----------------------------------------------------------------------
 *
 * DyldOFIErrorMsg --
 *
 *	Converts a numerical NSObjectFileImage error into an error message
 *	string.
 *
 * Results:
 *	Error message string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static CONST char*
DyldOFIErrorMsg(int err) {
    switch(err) {
    case NSObjectFileImageSuccess:
	return NULL;
    case NSObjectFileImageFailure:
	return "object file setup failure";
    case NSObjectFileImageInappropriateFile:
	return "not a Mach-O MH_BUNDLE file";
    case NSObjectFileImageArch:
	return "no object for this architecture";
    case NSObjectFileImageFormat:
	return "bad object file format";
    case NSObjectFileImageAccess:
	return "can't read object file";
    default:
	return "unknown error";
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs, an error message
 *	is left in the interpreter's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle;
    CONST struct mach_header *dyldLibHeader;
    NSObjectFileImage dyldObjFileImage = NULL;
    Tcl_DyldModuleHandle *modulePtr = NULL;
    CONST char *native;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);

    dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING |
	    NSADDIMAGE_OPTION_RETURN_ON_ERROR);

    if (!dyldLibHeader) {
	NSLinkEditErrors editError;
	int errorNumber;
	CONST char *name, *msg, *objFileImageErrMsg = NULL;

	NSLinkEditError(&editError, &errorNumber, &name, &msg);

	if (editError == NSLinkEditFileAccessError) {
	    /*
	     * The requested file was not found. Let the OS loader examine the
	     * binary search path for whatever string the user gave us which
	     * hopefully refers to a file on the binary path.
	     */

	    Tcl_DString ds;
	    char *fileName = Tcl_GetString(pathPtr);
	    CONST char *native =
		    Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);

	    dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING
		    | NSADDIMAGE_OPTION_RETURN_ON_ERROR);
	    Tcl_DStringFree(&ds);
	    if (!dyldLibHeader) {
		NSLinkEditError(&editError, &errorNumber, &name, &msg);
	    }
	} else if ((editError==NSLinkEditFileFormatError && errorNumber==EBADMACHO)
		|| editError == NSLinkEditOtherError){
	    /*
	     * The requested file was found but was not of type MH_DYLIB,
	     * attempt to load it as a MH_BUNDLE.
	     */

	    NSObjectFileImageReturnCode err =
		    NSCreateObjectFileImageFromFile(native, &dyldObjFileImage);
	    objFileImageErrMsg = DyldOFIErrorMsg(err);
	}

	if (!dyldLibHeader && !dyldObjFileImage) {
	    Tcl_AppendResult(interp, msg, (char *) NULL);
	    if (msg && *msg) {
		Tcl_AppendResult(interp, "\n", (char *) NULL);
	    }
	    if (objFileImageErrMsg) {
		Tcl_AppendResult(interp,
			"NSCreateObjectFileImageFromFile() error: ",
			objFileImageErrMsg, (char *) NULL);
	    }
	    return TCL_ERROR;
	}
    }

    if (dyldObjFileImage) {
	NSModule module;

	module = NSLinkModule(dyldObjFileImage, native,
		NSLINKMODULE_OPTION_BINDNOW
		| NSLINKMODULE_OPTION_RETURN_ON_ERROR);
	NSDestroyObjectFileImage(dyldObjFileImage);

	if (!module) {
	    NSLinkEditErrors editError;
	    int errorNumber;
	    CONST char *name, *msg;

	    NSLinkEditError(&editError, &errorNumber, &name, &msg);
	    Tcl_AppendResult(interp, msg, (char *) NULL);
	    return TCL_ERROR;
	}

	modulePtr = (Tcl_DyldModuleHandle *)
		ckalloc(sizeof(Tcl_DyldModuleHandle));
	modulePtr->module = module;
	modulePtr->nextPtr = NULL;
    }

    dyldLoadHandle = (Tcl_DyldLoadHandle *)
	    ckalloc(sizeof(Tcl_DyldLoadHandle));
    dyldLoadHandle->dyldLibHeader = dyldLibHeader;
    dyldLoadHandle->modulePtr = modulePtr;
    *loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;		/* For error reporting. */
    Tcl_LoadHandle loadHandle;	/* Handle from TclpDlopen. */
    CONST char *symbol;		/* Symbol name to look up. */
{
    NSSymbol nsSymbol;
    CONST char *native;
    Tcl_DString newName, ds;
    Tcl_PackageInitProc* proc = NULL;
    Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;

    /*
     * dyld adds an underscore to the beginning of symbol names.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    Tcl_DStringInit(&newName);
    Tcl_DStringAppend(&newName, "_", 1);
    native = Tcl_DStringAppend(&newName, native, -1);

    if (dyldLoadHandle->dyldLibHeader) {
	nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader, native,
		NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
		NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
	if (nsSymbol) {
	    /*
	     * Until dyld supports unloading of MY_DYLIB binaries, the
	     * following is not needed.
	     */

#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING
	    NSModule module = NSModuleForSymbol(nsSymbol);
	    Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;

	    while (modulePtr != NULL) {
		if (module == modulePtr->module) {
		    break;
		}
		modulePtr = modulePtr->nextPtr;
	    }
	    if (modulePtr == NULL) {
		modulePtr = (Tcl_DyldModuleHandle *)
			ckalloc(sizeof(Tcl_DyldModuleHandle));
		modulePtr->module = module;
		modulePtr->nextPtr = dyldLoadHandle->modulePtr;
		dyldLoadHandle->modulePtr = modulePtr;
	    }
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */

	} else {
	    NSLinkEditErrors editError;
	    int errorNumber;
	    CONST char *name, *msg;

	    NSLinkEditError(&editError, &errorNumber, &name, &msg);
	    Tcl_AppendResult(interp, msg, (char *) NULL);
	}
    } else {
	nsSymbol = NSLookupSymbolInModule(dyldLoadHandle->modulePtr->module,
		native);
    }
    if (nsSymbol) {
	proc = NSAddressOfSymbol(nsSymbol);
    }
    Tcl_DStringFree(&newName);
    Tcl_DStringFree(&ds);

    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code dissapears from memory. Note that dyld currently only supports
 *	unloading of binaries of type MH_BUNDLE loaded with NSLinkModule() in
 *	TclpDlopen() above.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */

{
    Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
    Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;

    while (modulePtr != NULL) {
	void *ptr;

	NSUnLinkModule(modulePtr->module,
		NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
	ptr = modulePtr;
	modulePtr = modulePtr->nextPtr;
	ckfree(ptr);
    }
    ckfree((char*) dyldLoadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name. A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring. Append package
				 * name to this if possible. */
{
    return 0;
}

#ifdef TCL_LOAD_FROM_MEMORY
/*
 *----------------------------------------------------------------------
 *
 * TclpLoadMemoryGetBuffer --
 *
 *	Allocate a buffer that can be used with TclpLoadMemory() below.
 *
 * Results:
 *	Pointer to allocated buffer or NULL if an error occurs.
 *
 * Side effects:
 *	Buffer is allocated.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE void*
TclpLoadMemoryGetBuffer(interp, size)
    Tcl_Interp *interp;		/* Used for error reporting. */
    int size;			/* Size of desired buffer. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    void *buffer = NULL;

    if (!tsdPtr->haveLoadMemory) {
	/*
	 * NSCreateObjectFileImageFromMemory is available but always fails
	 * prior to Darwin 7.
	 */

	struct utsname name;

	if (!uname(&name)) {
	    long release = strtol(name.release, NULL, 10);
	    tsdPtr->haveLoadMemory = (release >= 7) ? 1 : -1;
	}
    }
    if (tsdPtr->haveLoadMemory > 0) {
	/*
	 * We must allocate the buffer using vm_allocate, because
	 * NSCreateObjectFileImageFromMemory will dispose of it using
	 * vm_deallocate.
	 */

	if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) {
	    buffer = NULL;
	}
    }
    return buffer;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadMemory --
 *
 *	Dynamically loads binary code file from memory and returns a handle to
 *	the new code.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs, an error message
 *	is left in the interpreter's result.
 *
 * Side effects:
 *	New code is loaded from memory.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE int
TclpLoadMemory(interp, buffer, size, codeSize, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    void *buffer;		/* Buffer containing the desired code
				 * (allocated with TclpLoadMemoryGetBuffer). */
    int size;			/* Allocation size of buffer. */
    int codeSize;		/* Size of code data read into buffer or -1 if
				 * an error occurred and the buffer should
				 * just be freed. */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle;
    NSObjectFileImage dyldObjFileImage = NULL;
    Tcl_DyldModuleHandle *modulePtr;
    NSModule module;
    CONST char *objFileImageErrMsg = NULL;

    /*
     * Try to create an object file image that we can load from.
     */

    if (codeSize >= 0) {
	NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;

#ifndef __LP64__
	struct mach_header *mh = buffer;
	if (codeSize < sizeof(struct mach_header) || mh->magic != MH_MAGIC
#else
	struct mach_header_64 *mh = buffer;
	if (codeSize < sizeof(struct mach_header_64) || mh->magic != MH_MAGIC_64
#endif
		|| mh->filetype != MH_BUNDLE) {
	    err = NSObjectFileImageInappropriateFile;
	}
	if (err == NSObjectFileImageSuccess) {
	    err = NSCreateObjectFileImageFromMemory(buffer, codeSize,
		    &dyldObjFileImage);
	}
	objFileImageErrMsg = DyldOFIErrorMsg(err);
    }

    /*
     * If it went wrong (or we were asked to just deallocate), get rid of the
     * memory block and create an error message.
     */

    if (dyldObjFileImage == NULL) {
	vm_deallocate(mach_task_self(), (vm_address_t) buffer, size);
	if (objFileImageErrMsg != NULL) {
	    Tcl_AppendResult(interp,
		    "NSCreateObjectFileImageFromFile() error: ",
		    objFileImageErrMsg, (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Extract the module we want from the image of the object file.
     */

    module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]",
	    NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR);
    NSDestroyObjectFileImage(dyldObjFileImage);

    if (!module) {
	NSLinkEditErrors editError;
	int errorNumber;
	CONST char *name, *msg;

	NSLinkEditError(&editError, &errorNumber, &name, &msg);
	Tcl_AppendResult(interp, msg, (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Stash the module reference within the load handle we create and return.
     */

    modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
    modulePtr->module = module;
    modulePtr->nextPtr = NULL;

    dyldLoadHandle = (Tcl_DyldLoadHandle *)
	    ckalloc(sizeof(Tcl_DyldLoadHandle));
    dyldLoadHandle->dyldLibHeader = NULL;
    dyldLoadHandle->modulePtr = modulePtr;
    *loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}
#endif

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclLoadNext.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73
74
75
76

77

78
79
80
81
82
83
84
85
86

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124



125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186








/* 
 * tclLoadNext.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with NeXTs rld_* dynamic loading.  This file provided
 *	by Pedja Bogdanovich.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadNext.c,v 1.11 2002/10/10 12:25:53 vincentdarley Exp $
 */

#include "tclInt.h"
#include <mach-o/rld.h>
#include <streams/streams.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    struct mach_header *header;
    char *fileName;
    char *files[2];
    CONST char *native;
    int result = 1;
    
    NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
    
    fileName = Tcl_GetString(pathPtr);

    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    files = {native,NULL};

    result = rld_load(errorStream, &header, files, NULL);
    
    if (!result) {
	/* 
	 * Let the OS loader examine the binary search path for
	 * whatever string the user gave us which hopefully refers
	 * to a file on the binary path
	 */

	Tcl_DString ds;

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	files = {native,NULL};
	result = rld_load(errorStream, &header, files, NULL);
	Tcl_DStringFree(&ds);
    }
    
    if (!result) {
	char *data;
	int len, maxlen;

	NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
	Tcl_AppendResult(interp, "couldn't load file \"",
			 fileName, "\": ", data, NULL);
	NXCloseMemory(errorStream, NX_FREEBUFFER);
	return TCL_ERROR;
    }
    NXCloseMemory(errorStream, NX_FREEBUFFER);
    
    *loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */
    *unloadProcPtr = &TclpUnloadFile;
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_PackageInitProc *proc=NULL;
    if(symbol) {
	char sym[strlen(symbol)+2];



	sym[0]='_'; sym[1]=0; strcat(sym,symbol);
	rld_lookup(NULL,sym,(unsigned long *)&proc);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    return 0;
}








|


|
|
<



|
|

|











|
|


|
|













|

|

|
|






|

|


|

|
|

>




|

|
|
|
|

>

>





|



>

|
|




|


|








|
|


|
|
|



>

|





|

>
>
>
|
|









|
|
|












|
|
|
<








|
|


|
|
|
|











|
|



>
>
>
>
>
>
>
>
1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
/*
 * tclLoadNext.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	NeXTs rld_* dynamic loading.  This file provided by Pedja Bogdanovich.

 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadNext.c,v 1.11.6.1 2005/08/02 18:16:55 dgp Exp $
 */

#include "tclInt.h"
#include <mach-o/rld.h>
#include <streams/streams.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    struct mach_header *header;
    char *fileName;
    char *files[2];
    CONST char *native;
    int result = 1;

    NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);

    fileName = Tcl_GetString(pathPtr);

    /*
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    files = {native,NULL};

    result = rld_load(errorStream, &header, files, NULL);

    if (!result) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path
	 */

	Tcl_DString ds;

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	files = {native,NULL};
	result = rld_load(errorStream, &header, files, NULL);
	Tcl_DStringFree(&ds);
    }

    if (!result) {
	char *data;
	int len, maxlen;

	NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		data, NULL);
	NXCloseMemory(errorStream, NX_FREEBUFFER);
	return TCL_ERROR;
    }
    NXCloseMemory(errorStream, NX_FREEBUFFER);

    *loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */
    *unloadProcPtr = &TclpUnloadFile;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found.  Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_PackageInitProc *proc=NULL;
    if (symbol) {
	char sym[strlen(symbol)+2];

	sym[0] = '_';
	sym[1] = 0;
	strcat(sym,symbol);
	rld_lookup(NULL, sym, (unsigned long *)&proc);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.  Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen().  The loadHandle is a token
				 * that represents the loaded file. */

{
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name.  A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclLoadOSF.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90

91

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202








/* 
 * tclLoadOSF.c --
 *
 *	This procedure provides a version of the TclLoadFile that works
 *	under OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1
 *	/sbin/loader and /usr/include/loader.h.  OSF/1 versions from 1.3 and
 *	on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h].
 *
 *	This is useful for:
 *		OSF/1 1.0, 1.1, 1.2 (from OSF)
 *			includes: MK4 and AD1 (from OSF RI)
 *		OSF/1 1.3 (from OSF) using ROSE
 *		HP OSF/1 1.0 ("Acorn") using COFF
 *
 *	This is likely to be useful for:
 *		Paragon OSF/1 (from Intel) 
 *		HI-OSF/1 (from Hitachi) 
 *
 *	This is NOT to be used on:
 *		Digitial Alpha OSF/1 systems
 *		OSF/1 1.3 or later (from OSF) using ELF
 *			includes: MK6, MK7, AD2, AD3 (from OSF RI)
 *
 *	This approach to things was utter @&^#; thankfully,
 * 	OSF/1 eventually supported dlopen().
 *
 *	John Robert LoVerso <[email protected]>
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadOSF.c,v 1.11 2002/10/10 12:25:53 vincentdarley Exp $
 */

#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    ldr_module_t lm;
    char *pkg;
    char *fileName = Tcl_GetString(pathPtr);
    CONST char *native;

    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);

    if (lm == LDR_NULL_MODULE) {
	/* 
	 * Let the OS loader examine the binary search path for
	 * whatever string the user gave us which hopefully refers
	 * to a file on the binary path
	 */

	Tcl_DString ds;

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
	Tcl_DStringFree(&ds);
    }
    
    if (lm == LDR_NULL_MODULE) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName,
	    "\": ", Tcl_PosixError (interp), (char *) NULL);
	return TCL_ERROR;
    }

    *clientDataPtr = NULL;
    
    /*
     * My convention is to use a [OSF loader] package name the same as shlib,
     * since the idiots never implemented ldr_lookup() and it is otherwise
     * impossible to get a package name given a module.
     *
     * I build loadable modules with a makefile rule like 
     *		ld ... -export $@: -o $@ $(OBJS)
     */

    if ((pkg = strrchr(fileName, '/')) == NULL) {
        pkg = fileName;
    } else {
	pkg++;
    }
    *loadHandle = pkg;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return ldr_lookup_package((char *)loadHandle, symbol);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    return 0;
}








|


|
|










|
|






|
|





|
|

|











|
|


|
|













|

|

|
|






|

|
|

>




|
|
|
|

>

>




|

|
|




|





|


>















|
|


|
|
|




|












|
|
|












|
|
|
<








|
|


|
|
|
|











|
|



>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
/*
 * tclLoadOSF.c --
 *
 *	This procedure provides a version of the TclLoadFile that works under
 *	OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1
 *	/sbin/loader and /usr/include/loader.h.  OSF/1 versions from 1.3 and
 *	on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h].
 *
 *	This is useful for:
 *		OSF/1 1.0, 1.1, 1.2 (from OSF)
 *			includes: MK4 and AD1 (from OSF RI)
 *		OSF/1 1.3 (from OSF) using ROSE
 *		HP OSF/1 1.0 ("Acorn") using COFF
 *
 *	This is likely to be useful for:
 *		Paragon OSF/1 (from Intel)
 *		HI-OSF/1 (from Hitachi)
 *
 *	This is NOT to be used on:
 *		Digitial Alpha OSF/1 systems
 *		OSF/1 1.3 or later (from OSF) using ELF
 *			includes: MK6, MK7, AD2, AD3 (from OSF RI)
 *
 *	This approach to things was utter @&^#; thankfully, OSF/1 eventually
 *	supported dlopen().
 *
 *	John Robert LoVerso <[email protected]>
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadOSF.c,v 1.11.6.1 2005/08/02 18:16:55 dgp Exp $
 */

#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    ldr_module_t lm;
    char *pkg;
    char *fileName = Tcl_GetString(pathPtr);
    CONST char *native;

    /*
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);

    if (lm == LDR_NULL_MODULE) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path
	 */

	Tcl_DString ds;

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
	Tcl_DStringFree(&ds);
    }

    if (lm == LDR_NULL_MODULE) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		Tcl_PosixError (interp), (char *) NULL);
	return TCL_ERROR;
    }

    *clientDataPtr = NULL;

    /*
     * My convention is to use a [OSF loader] package name the same as shlib,
     * since the idiots never implemented ldr_lookup() and it is otherwise
     * impossible to get a package name given a module.
     *
     * I build loadable modules with a makefile rule like
     *		ld ... -export $@: -o $@ $(OBJS)
     */

    if ((pkg = strrchr(fileName, '/')) == NULL) {
        pkg = fileName;
    } else {
	pkg++;
    }
    *loadHandle = pkg;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found.  Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return ldr_lookup_package((char *)loadHandle, symbol);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.  Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen().  The loadHandle is a token
				 * that represents the loaded file. */

{
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name.  A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclLoadShl.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78

79
80
81
82
83
84
85
86
87
88

89

90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209








/* 
 * tclLoadShl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works
 *	with the "shl_load" and "shl_findsym" library procedures for
 *	dynamic loading (e.g. for HP machines).
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadShl.c,v 1.13 2002/10/10 12:25:53 vincentdarley Exp $
 */

#include <dl.h>

/*
 * On some HP machines, dl.h defines EXTERN; remove that definition.
 */

#ifdef EXTERN
#   undef EXTERN
#endif

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    shl_t handle;
    CONST char *native;
    char *fileName = Tcl_GetString(pathPtr);

    /*
     * The flags below used to be BIND_IMMEDIATE; they were changed at
     * the suggestion of Wolfgang Kechel ([email protected]): "This
     * enables verbosity for missing symbols when loading a shared lib
     * and allows to load libtk8.0.sl into tclsh8.0 without problems.
     * In general, this delays resolving symbols until they are actually
     * needed.  Shared libs do no longer need all libraries linked in
     * when they are build."
     */


    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    handle = shl_load(native,
		      BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
    
    if (handle == NULL) {
	/* 
	 * Let the OS loader examine the binary search path for
	 * whatever string the user gave us which hopefully refers
	 * to a file on the binary path
	 */

	Tcl_DString ds;

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	handle = shl_load(native,
			  BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
	Tcl_DStringFree(&ds);
    }

    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName,
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }
    *loadHandle = (Tcl_LoadHandle) handle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_DString newName;
    Tcl_PackageInitProc *proc=NULL;
    shl_t handle = (shl_t)loadHandle;

    /*
     * Some versions of the HP system software still use "_" at the
     * beginning of exported symbols while others don't;  try both
     * forms of each name.
     */

    if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, (void *) &proc)
	    != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, symbol, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    shl_t handle;

    handle = (shl_t) loadHandle;
    shl_unload(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    return 0;
}








|


|
|
|



|
|

|



















|
|


|
|













|

|

|
|






|
|
|
|
|
|
<


<
|

|
|

>

|
<
|

|
|
|
|

>

>

|
<




|
|












|
|


|
|
|




|







>

|
|
<


|
|

















|
|
|












|
|
|
<












|
|


|
|
|
|











|
|



>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

70
71

72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
/*
 * tclLoadShl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	the "shl_load" and "shl_findsym" library procedures for dynamic
 *	loading (e.g. for HP machines).
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadShl.c,v 1.13.6.2 2005/10/08 13:45:04 dgp Exp $
 */

#include <dl.h>

/*
 * On some HP machines, dl.h defines EXTERN; remove that definition.
 */

#ifdef EXTERN
#   undef EXTERN
#endif

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    shl_t handle;
    CONST char *native;
    char *fileName = Tcl_GetString(pathPtr);

    /*
     * The flags below used to be BIND_IMMEDIATE; they were changed at the
     * suggestion of Wolfgang Kechel ([email protected]): "This enables
     * verbosity for missing symbols when loading a shared lib and allows to
     * load libtk8.0.sl into tclsh8.0 without problems.  In general, this
     * delays resolving symbols until they are actually needed.  Shared libs
     * do no longer need all libraries linked in when they are build."

     */


    /*
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    native = Tcl_FSGetNativePath(pathPtr);
    handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE, 0L);


    if (handle == NULL) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);

	Tcl_DStringFree(&ds);
    }

    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }
    *loadHandle = (Tcl_LoadHandle) handle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found.  Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_DString newName;
    Tcl_PackageInitProc *proc=NULL;
    shl_t handle = (shl_t)loadHandle;

    /*
     * Some versions of the HP system software still use "_" at the beginning
     * of exported symbols while others don't; try both forms of each name.

     */

    if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
	    (void *) &proc) != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, symbol, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.  Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen().  The loadHandle is a token
				 * that represents the loaded file. */

{
    shl_t handle;

    handle = (shl_t) loadHandle;
    shl_unload(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name.  A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixChan.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
/* 
 * tclUnixChan.c
 *
 *	Common channel driver for Unix channels based on files, command
 *	pipes and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixChan.c,v 1.53 2004/11/17 02:51:32 hobbs Exp $
 */

#include "tclInt.h"	/* Internal definitions for Tcl. */
#include "tclIO.h"	/* To get Channel type declaration. */

/*
 * sys/ioctl.h has already been included by tclPort.h.	Including termios.h
 * or termio.h causes a bunch of warning messages because some duplicate
 * (but not contradictory) #defines exist in termios.h and/or termio.h
 */

#undef NL0
#undef NL1
#undef CR0
#undef CR1
#undef CR2
#undef CR3
#undef TAB0
|


|
|




|
|

|






|
|
|

>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
/*
 * tclUnixChan.c
 *
 *	Common channel driver for Unix channels based on files, command pipes
 *	and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixChan.c,v 1.53.2.6 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"	/* Internal definitions for Tcl. */
#include "tclIO.h"	/* To get Channel type declaration. */

/*
 * sys/ioctl.h has already been included by tclPort.h. Including termios.h or
 * termio.h causes a bunch of warning messages because some duplicate (but not
 * contradictory) #defines exist in termios.h and/or termio.h
 */

#undef NL0
#undef NL1
#undef CR0
#undef CR1
#undef CR2
#undef CR3
#undef TAB0
39
40
41
42
43
44
45







46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
66
67
68

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

84
85
86
87

88
89
90
91
92
93
94
#undef NOFLSH
#undef TOSTOP
#undef FLUSHO
#undef PENDIN

#define SUPPORTS_TTY








#ifdef USE_TERMIOS
#   include <termios.h>
#   ifdef HAVE_SYS_IOCTL_H
#	include <sys/ioctl.h>
#   endif /* HAVE_SYS_IOCTL_H */
#   ifdef HAVE_SYS_MODEM_H
#	include <sys/modem.h>
#   endif /* HAVE_SYS_MODEM_H */
#   define IOSTATE			struct termios
#   define GETIOSTATE(fd, statePtr)	tcgetattr((fd), (statePtr))
#   define SETIOSTATE(fd, statePtr)	tcsetattr((fd), TCSADRAIN, (statePtr))
#   define GETCONTROL(fd, intPtr)	ioctl((fd), TIOCMGET, (intPtr))
#   define SETCONTROL(fd, intPtr)	ioctl((fd), TIOCMSET, (intPtr))

    /*
     * TIP #35 introduced a different on exit flush/close behavior that
     * doesn't work correctly with standard channels on all systems.
     * The problem is tcflush throws away waiting channel data.	 This may
     * be necessary for true serial channels that may block, but isn't
     * correct in the standard case.  This might be replaced with tcdrain
     * instead, but that can block.  For now, we revert to making this do
     * nothing, and TtyOutputProc being the same old FileOutputProc.
     * -- hobbs [Bug #525783]
     */

#   define BAD_TIP35_FLUSH 0
#   if BAD_TIP35_FLUSH
#	define TTYFLUSH(fd)		tcflush((fd), TCIOFLUSH);
#   else
#	define TTYFLUSH(fd)
#   endif /* BAD_TIP35_FLUSH */
#   ifdef FIONREAD
#	define GETREADQUEUE(fd, int)	ioctl((fd), FIONREAD, &(int))
#   elif defined(FIORDCHK)
#	define GETREADQUEUE(fd, int)	int = ioctl((fd), FIORDCHK, NULL)
#   endif /* FIONREAD */
#   ifdef TIOCOUTQ
#	define GETWRITEQUEUE(fd, int)	ioctl((fd), TIOCOUTQ, &(int))
#   endif /* TIOCOUTQ */
#   if defined(TIOCSBRK) && defined(TIOCCBRK)

/*
 * Can't use ?: operator below because that messes up types on either
 * Linux or Solaris (the two are mutually exclusive!)
 */

#	define SETBREAK(fd, flag) \
		if (flag) {				\
		    ioctl((fd), TIOCSBRK, NULL);	\
		} else {				\
		    ioctl((fd), TIOCCBRK, NULL);	\
		}
#   endif /* TIOCSBRK&TIOCCBRK */







>
>
>
>
>
>
>













>


|
|
|
|
|
|
<

>















>

|
|

>







40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
#undef NOFLSH
#undef TOSTOP
#undef FLUSHO
#undef PENDIN

#define SUPPORTS_TTY

#undef DIRECT_BAUD
#ifdef B4800
#   if (B4800 == 4800)
#	define DIRECT_BAUD
#   endif /* B4800 == 4800 */
#endif /* B4800 */

#ifdef USE_TERMIOS
#   include <termios.h>
#   ifdef HAVE_SYS_IOCTL_H
#	include <sys/ioctl.h>
#   endif /* HAVE_SYS_IOCTL_H */
#   ifdef HAVE_SYS_MODEM_H
#	include <sys/modem.h>
#   endif /* HAVE_SYS_MODEM_H */
#   define IOSTATE			struct termios
#   define GETIOSTATE(fd, statePtr)	tcgetattr((fd), (statePtr))
#   define SETIOSTATE(fd, statePtr)	tcsetattr((fd), TCSADRAIN, (statePtr))
#   define GETCONTROL(fd, intPtr)	ioctl((fd), TIOCMGET, (intPtr))
#   define SETCONTROL(fd, intPtr)	ioctl((fd), TIOCMSET, (intPtr))

    /*
     * TIP #35 introduced a different on exit flush/close behavior that
     * doesn't work correctly with standard channels on all systems. The
     * problem is tcflush throws away waiting channel data. This may be
     * necessary for true serial channels that may block, but isn't correct in
     * the standard case. This might be replaced with tcdrain instead, but
     * that can block. For now, we revert to making this do nothing, and
     * TtyOutputProc being the same old FileOutputProc. - hobbs [Bug #525783]

     */

#   define BAD_TIP35_FLUSH 0
#   if BAD_TIP35_FLUSH
#	define TTYFLUSH(fd)		tcflush((fd), TCIOFLUSH);
#   else
#	define TTYFLUSH(fd)
#   endif /* BAD_TIP35_FLUSH */
#   ifdef FIONREAD
#	define GETREADQUEUE(fd, int)	ioctl((fd), FIONREAD, &(int))
#   elif defined(FIORDCHK)
#	define GETREADQUEUE(fd, int)	int = ioctl((fd), FIORDCHK, NULL)
#   endif /* FIONREAD */
#   ifdef TIOCOUTQ
#	define GETWRITEQUEUE(fd, int)	ioctl((fd), TIOCOUTQ, &(int))
#   endif /* TIOCOUTQ */
#   if defined(TIOCSBRK) && defined(TIOCCBRK)

/*
 * Can't use ?: operator below because that messes up types on either Linux or
 * Solaris (the two are mutually exclusive!)
 */

#	define SETBREAK(fd, flag) \
		if (flag) {				\
		    ioctl((fd), TIOCSBRK, NULL);	\
		} else {				\
		    ioctl((fd), TIOCCBRK, NULL);	\
		}
#   endif /* TIOCSBRK&TIOCCBRK */
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214

/*
 * The following structure describes per-instance state of a tty-based
 * channel.
 */

typedef struct TtyState {
    FileState fs;		/* Per-instance state of the file
				 * descriptor.	Must be the first field. */
    int stateUpdated;		/* Flag to say if the state has been
				 * modified and needs resetting. */
    IOSTATE savedState;		/* Initial state of device.  Used to reset
				 * state when device closed. */
} TtyState;

/*
 * The following structure is used to set or get the serial port
 * attributes in a platform-independant manner.
 */

typedef struct TtyAttrs {
    int baud;
    int parity;
    int data;
    int stop;
} TtyAttrs;

#endif	/* !SUPPORTS_TTY */

#define UNSUPPORTED_OPTION(detail) \
	if (interp) {							\
	    Tcl_AppendResult(interp, (detail),				\
		    " not supported for this platform", (char *) NULL); \
	}

/*
 * This structure describes per-instance state of a tcp based channel.
 */

typedef struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    int fd;			/* The socket itself. */
    int flags;			/* ORed combination of the bitfields
				 * defined below. */
    Tcl_TcpAcceptProc *acceptProc;
				/* Proc to call on accept. */
    ClientData acceptProcData;	/* The data for the accept proc. */
} TcpState;

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_ASYNC_SOCKET	(1<<0)	/* Asynchronous socket. */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */

/*
 * The following defines the maximum length of the listen queue. This is
 * the number of outstanding yet-to-be-serviced requests for a connection
 * on a server socket, more than this number of outstanding requests and
 * the connection request will fail.
 */

#ifndef SOMAXCONN
#   define SOMAXCONN	100
#endif /* SOMAXCONN */

#if (SOMAXCONN < 100)
#   undef  SOMAXCONN
#   define SOMAXCONN	100
#endif /* SOMAXCONN < 100 */

/*
 * The following defines how much buffer space the kernel should maintain
 * for a socket.
 */

#define SOCKET_BUFSIZE	4096

/*
 * Static routines for this file:
 */







|
|
|
|
|




|
|












|
|
|
|








|
|














|
|
|
|












|
|







143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225

/*
 * The following structure describes per-instance state of a tty-based
 * channel.
 */

typedef struct TtyState {
    FileState fs;		/* Per-instance state of the file descriptor.
				 * Must be the first field. */
    int stateUpdated;		/* Flag to say if the state has been modified
				 * and needs resetting. */
    IOSTATE savedState;		/* Initial state of device. Used to reset
				 * state when device closed. */
} TtyState;

/*
 * The following structure is used to set or get the serial port attributes in
 * a platform-independant manner.
 */

typedef struct TtyAttrs {
    int baud;
    int parity;
    int data;
    int stop;
} TtyAttrs;

#endif	/* !SUPPORTS_TTY */

#define UNSUPPORTED_OPTION(detail) \
    if (interp) {							\
	Tcl_AppendResult(interp, (detail),				\
	    " not supported for this platform", (char *) NULL);		\
    }

/*
 * This structure describes per-instance state of a tcp based channel.
 */

typedef struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    int fd;			/* The socket itself. */
    int flags;			/* ORed combination of the bitfields defined
				 * below. */
    Tcl_TcpAcceptProc *acceptProc;
				/* Proc to call on accept. */
    ClientData acceptProcData;	/* The data for the accept proc. */
} TcpState;

/*
 * These bits may be ORed together into the "flags" field of a TcpState
 * structure.
 */

#define TCP_ASYNC_SOCKET	(1<<0)	/* Asynchronous socket. */
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */

/*
 * The following defines the maximum length of the listen queue. This is the
 * number of outstanding yet-to-be-serviced requests for a connection on a
 * server socket, more than this number of outstanding requests and the
 * connection request will fail.
 */

#ifndef SOMAXCONN
#   define SOMAXCONN	100
#endif /* SOMAXCONN */

#if (SOMAXCONN < 100)
#   undef  SOMAXCONN
#   define SOMAXCONN	100
#endif /* SOMAXCONN < 100 */

/*
 * The following defines how much buffer space the kernel should maintain for
 * a socket.
 */

#define SOCKET_BUFSIZE	4096

/*
 * Static routines for this file:
 */
228
229
230
231
232
233
234






235
236
237
238
239
240
241
static int		FileInputProc _ANSI_ARGS_((ClientData instanceData,
			    char *buf, int toRead, int *errorCode));
static int		FileOutputProc _ANSI_ARGS_((
			    ClientData instanceData, CONST char *buf,
			    int toWrite, int *errorCode));
static int		FileSeekProc _ANSI_ARGS_((ClientData instanceData,
			    long offset, int mode, int *errorCode));






static Tcl_WideInt	FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_WideInt offset, int mode, int *errorCode));
static void		FileWatchProc _ANSI_ARGS_((ClientData instanceData,
			    int mask));
static void		TcpAccept _ANSI_ARGS_((ClientData data, int mask));
static int		TcpBlockModeProc _ANSI_ARGS_((ClientData data,
			    int mode));







>
>
>
>
>
>







239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
static int		FileInputProc _ANSI_ARGS_((ClientData instanceData,
			    char *buf, int toRead, int *errorCode));
static int		FileOutputProc _ANSI_ARGS_((
			    ClientData instanceData, CONST char *buf,
			    int toWrite, int *errorCode));
static int		FileSeekProc _ANSI_ARGS_((ClientData instanceData,
			    long offset, int mode, int *errorCode));
#ifdef DEPRECATED
static void		FileThreadActionProc _ANSI_ARGS_ ((
			    ClientData instanceData, int action));
#endif
static int		FileTruncateProc _ANSI_ARGS_ ((ClientData instanceData,
			    Tcl_WideInt length));
static Tcl_WideInt	FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_WideInt offset, int mode, int *errorCode));
static void		FileWatchProc _ANSI_ARGS_((ClientData instanceData,
			    int mask));
static void		TcpAccept _ANSI_ARGS_((ClientData data, int mask));
static int		TcpBlockModeProc _ANSI_ARGS_((ClientData data,
			    int mode));
253
254
255
256
257
258
259

260

261
262
263

264

265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307






308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334



335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357



358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
static void		TcpWatchProc _ANSI_ARGS_((ClientData instanceData,
			    int mask));
#ifdef SUPPORTS_TTY
static int		TtyCloseProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp));
static void		TtyGetAttributes _ANSI_ARGS_((int fd,
			    TtyAttrs *ttyPtr));

static int		TtyGetBaud _ANSI_ARGS_((unsigned long speed));

static int		TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp, CONST char *optionName,
			    Tcl_DString *dsPtr));

static unsigned long	TtyGetSpeed _ANSI_ARGS_((int baud));

static FileState *	TtyInit _ANSI_ARGS_((int fd, int initialize));
static void		TtyModemStatusStr _ANSI_ARGS_((int status,
			    Tcl_DString *dsPtr));
#if BAD_TIP35_FLUSH
static int		TtyOutputProc _ANSI_ARGS_((ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode));
#endif /* BAD_TIP35_FLUSH */
static int		TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *mode, int *speedPtr, int *parityPtr,
			    int *dataPtr, int *stopPtr));
static void		TtySetAttributes _ANSI_ARGS_((int fd,
			    TtyAttrs *ttyPtr));
static int		TtySetOptionProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp, CONST char *optionName, 
			    CONST char *value));
#endif	/* SUPPORTS_TTY */
static int		WaitForConnect _ANSI_ARGS_((TcpState *statePtr,
			    int *errorCodePtr));
static Tcl_Channel	MakeTcpClientChannelMode _ANSI_ARGS_(
			    (ClientData tcpSocket,
			    int mode));


/*
 * This structure describes the channel type structure for file based IO:
 */

static Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_3,	/* v3 channel */
    FileCloseProc,		/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
    FileSeekProc,		/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* wide seek proc. */






};

#ifdef SUPPORTS_TTY
/*
 * This structure describes the channel type structure for serial IO.
 * Note that this type is a subclass of the "file" type.
 */

static Tcl_ChannelType ttyChannelType = {
    "tty",			/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* v2 channel */
    TtyCloseProc,		/* Close proc. */
    FileInputProc,		/* Input proc. */
#if BAD_TIP35_FLUSH
    TtyOutputProc,		/* Output proc. */
#else /* !BAD_TIP35_FLUSH */
    FileOutputProc,		/* Output proc. */
#endif /* BAD_TIP35_FLUSH */
    NULL,			/* Seek proc. */
    TtySetOptionProc,		/* Set option proc. */
    TtyGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */



};
#endif	/* SUPPORTS_TTY */

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static Tcl_ChannelType tcpChannelType = {
    "tcp",			/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* v2 channel */
    TcpCloseProc,		/* Close proc. */
    TcpInputProc,		/* Input proc. */
    TcpOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    TcpGetOptionProc,		/* Get option proc. */
    TcpWatchProc,		/* Initialize notifier. */
    TcpGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    TcpBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */



};


/*
 *----------------------------------------------------------------------
 *
 * FileBlockModeProc --
 *
 *	Helper procedure to set blocking and nonblocking modes on a
 *	file based channel. Invoked by generic IO level code.
 *
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
FileBlockModeProc(instanceData, mode)
    ClientData instanceData;		/* File state. */
    int mode;				/* The mode to set. Can be one of
					 * TCL_MODE_BLOCKING or
					 * TCL_MODE_NONBLOCKING. */
{
    FileState *fsPtr = (FileState *) instanceData;
    int curStatus;

#ifndef USE_FIONBIO
    curStatus = fcntl(fsPtr->fd, F_GETFL);
    if (mode == TCL_MODE_BLOCKING) {







>

>



>

>













|















|













>
>
>
>
>
>










|
















>
>
>










|












>
>
>

<






|
|













|
|
|
|







270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391

392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
static void		TcpWatchProc _ANSI_ARGS_((ClientData instanceData,
			    int mask));
#ifdef SUPPORTS_TTY
static int		TtyCloseProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp));
static void		TtyGetAttributes _ANSI_ARGS_((int fd,
			    TtyAttrs *ttyPtr));
#ifndef DIRECT_BAUD
static int		TtyGetBaud _ANSI_ARGS_((unsigned long speed));
#endif
static int		TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp, CONST char *optionName,
			    Tcl_DString *dsPtr));
#ifndef DIRECT_BAUD
static unsigned long	TtyGetSpeed _ANSI_ARGS_((int baud));
#endif
static FileState *	TtyInit _ANSI_ARGS_((int fd, int initialize));
static void		TtyModemStatusStr _ANSI_ARGS_((int status,
			    Tcl_DString *dsPtr));
#if BAD_TIP35_FLUSH
static int		TtyOutputProc _ANSI_ARGS_((ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode));
#endif /* BAD_TIP35_FLUSH */
static int		TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *mode, int *speedPtr, int *parityPtr,
			    int *dataPtr, int *stopPtr));
static void		TtySetAttributes _ANSI_ARGS_((int fd,
			    TtyAttrs *ttyPtr));
static int		TtySetOptionProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp, CONST char *optionName,
			    CONST char *value));
#endif	/* SUPPORTS_TTY */
static int		WaitForConnect _ANSI_ARGS_((TcpState *statePtr,
			    int *errorCodePtr));
static Tcl_Channel	MakeTcpClientChannelMode _ANSI_ARGS_(
			    (ClientData tcpSocket,
			    int mode));


/*
 * This structure describes the channel type structure for file based IO:
 */

static Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    FileCloseProc,		/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
    FileSeekProc,		/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* wide seek proc. */
#ifdef DEPRECATED
    FileThreadActionProc,	/* thread actions */
#else
    NULL,
#endif
    FileTruncateProc,		/* truncate proc. */
};

#ifdef SUPPORTS_TTY
/*
 * This structure describes the channel type structure for serial IO.
 * Note that this type is a subclass of the "file" type.
 */

static Tcl_ChannelType ttyChannelType = {
    "tty",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    TtyCloseProc,		/* Close proc. */
    FileInputProc,		/* Input proc. */
#if BAD_TIP35_FLUSH
    TtyOutputProc,		/* Output proc. */
#else /* !BAD_TIP35_FLUSH */
    FileOutputProc,		/* Output proc. */
#endif /* BAD_TIP35_FLUSH */
    NULL,			/* Seek proc. */
    TtySetOptionProc,		/* Set option proc. */
    TtyGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc. */
    NULL,			/* thread action proc. */
    NULL,			/* truncate proc. */
};
#endif	/* SUPPORTS_TTY */

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */

static Tcl_ChannelType tcpChannelType = {
    "tcp",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    TcpCloseProc,		/* Close proc. */
    TcpInputProc,		/* Input proc. */
    TcpOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    TcpGetOptionProc,		/* Get option proc. */
    TcpWatchProc,		/* Initialize notifier. */
    TcpGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    TcpBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc. */
    NULL,			/* thread action proc. */
    NULL,			/* truncate proc. */
};


/*
 *----------------------------------------------------------------------
 *
 * FileBlockModeProc --
 *
 *	Helper function to set blocking and nonblocking modes on a file based
 *	channel. Invoked by generic IO level code.
 *
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
FileBlockModeProc(instanceData, mode)
    ClientData instanceData;	/* File state. */
    int mode;			/* The mode to set. Can be one of
				 * TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    FileState *fsPtr = (FileState *) instanceData;
    int curStatus;

#ifndef USE_FIONBIO
    curStatus = fcntl(fsPtr->fd, F_GETFL);
    if (mode == TCL_MODE_BLOCKING) {
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
}

/*
 *----------------------------------------------------------------------
 *
 * FileInputProc --
 *
 *	This procedure is invoked from the generic IO level to read
 *	input from a file based channel.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurs, or zero.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;		/* File state. */
    char *buf;				/* Where to store data read. */
    int toRead;				/* How much space is available
					 * in the buffer? */
    int *errorCodePtr;			/* Where to store error code. */
{
    FileState *fsPtr = (FileState *) instanceData;
    int bytesRead;			/* How many bytes were actually
					 * read from the input device? */

    *errorCodePtr = 0;

    /*
     * Assume there is always enough input available. This will block
     * appropriately, and read will unblock as soon as a short read is
     * possible, if the channel is in blocking mode. If the channel is







|
|













|
|
|
|
|


|
|







443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
}

/*
 *----------------------------------------------------------------------
 *
 * FileInputProc --
 *
 *	This function is invoked from the generic IO level to read input from
 *	a file based channel.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurs, or zero.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;	/* File state. */
    char *buf;			/* Where to store data read. */
    int toRead;			/* How much space is available in the
				 * buffer? */
    int *errorCodePtr;		/* Where to store error code. */
{
    FileState *fsPtr = (FileState *) instanceData;
    int bytesRead;		/* How many bytes were actually read from the
				 * input device? */

    *errorCodePtr = 0;

    /*
     * Assume there is always enough input available. This will block
     * appropriately, and read will unblock as soon as a short read is
     * possible, if the channel is in blocking mode. If the channel is
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
}

/*
 *----------------------------------------------------------------------
 *
 * FileOutputProc--
 *
 *	This procedure is invoked from the generic IO level to write
 *	output to a file channel.
 *
 * Results:
 *	The number of bytes written is returned or -1 on error. An
 *	output argument contains a POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;		/* File state. */
    CONST char *buf;			/* The data buffer. */
    int toWrite;			/* How many bytes to write? */
    int *errorCodePtr;			/* Where to store error code. */
{
    FileState *fsPtr = (FileState *) instanceData;
    int written;

    *errorCodePtr = 0;

    if (toWrite == 0) {
	/*
	 * SF Tcl Bug 465765.
	 * Do not try to write nothing into a file. STREAM based
	 * implementations will considers this as EOF (if there is a
	 * pipe behind the file).
	 */

	return 0;
    }
    written = write(fsPtr->fd, buf, (size_t) toWrite);
    if (written > -1) {
	return written;
    }
    *errorCodePtr = errno;
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * FileCloseProc --
 *
 *	This procedure is called from the generic IO level to perform
 *	channel-type-specific cleanup when a file based channel is closed.
 *
 * Results:
 *	0 if successful, errno if failed.
 *
 * Side effects:
 *	Closes the device of the channel.







|
|


|
|
<









|
|
|
|








<
|
|


















|







490
491
492
493
494
495
496
497
498
499
500
501
502

503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523

524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
}

/*
 *----------------------------------------------------------------------
 *
 * FileOutputProc--
 *
 *	This function is invoked from the generic IO level to write output to
 *	a file channel.
 *
 * Results:
 *	The number of bytes written is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurred, or zero.

 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;	/* File state. */
    CONST char *buf;		/* The data buffer. */
    int toWrite;		/* How many bytes to write? */
    int *errorCodePtr;		/* Where to store error code. */
{
    FileState *fsPtr = (FileState *) instanceData;
    int written;

    *errorCodePtr = 0;

    if (toWrite == 0) {
	/*

	 * SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM
	 * based implementations will considers this as EOF (if there is a
	 * pipe behind the file).
	 */

	return 0;
    }
    written = write(fsPtr->fd, buf, (size_t) toWrite);
    if (written > -1) {
	return written;
    }
    *errorCodePtr = errno;
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * FileCloseProc --
 *
 *	This function is called from the generic IO level to perform
 *	channel-type-specific cleanup when a file based channel is closed.
 *
 * Results:
 *	0 if successful, errno if failed.
 *
 * Side effects:
 *	Closes the device of the channel.
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
}

/*
 *----------------------------------------------------------------------
 *
 * FileSeekProc --
 *
 *	This procedure is called by the generic IO level to move the
 *	access point in a file based channel.
 *
 * Results:
 *	-1 if failed, the new position if successful. An output
 *	argument contains the POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:







|
|







578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
}

/*
 *----------------------------------------------------------------------
 *
 * FileSeekProc --
 *
 *	This function is called by the generic IO level to move the access
 *	point in a file based channel.
 *
 * Results:
 *	-1 if failed, the new position if successful. An output
 *	argument contains the POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:
577
578
579
580
581
582
583

584
585
586
587
588

589
590
591
592
593
594
595
596
597

598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
{
    FileState *fsPtr = (FileState *) instanceData;
    Tcl_WideInt oldLoc, newLoc;

    /*
     * Save our current place in case we need to roll-back the seek.
     */

    oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
    if (oldLoc == Tcl_LongAsWide(-1)) {
	/*
	 * Bad things are happening.  Error out...
	 */

	*errorCodePtr = errno;
	return -1;
    }
 
    newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
 
    /*
     * Check for expressability in our return type, and roll-back otherwise.
     */

    if (newLoc > Tcl_LongAsWide(INT_MAX)) {
	*errorCodePtr = EOVERFLOW;
	TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
	return -1;
    } else {
	*errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
    }
    return (int) Tcl_WideAsLong(newLoc);
}

/*
 *----------------------------------------------------------------------
 *
 * FileWideSeekProc --
 *
 *	This procedure is called by the generic IO level to move the
 *	access point in a file based channel, with offsets expressed
 *	as wide integers.
 *
 * Results:
 *	-1 if failed, the new position if successful. An output
 *	argument contains the POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:







>





>



|

|



>















|
|
|







607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
{
    FileState *fsPtr = (FileState *) instanceData;
    Tcl_WideInt oldLoc, newLoc;

    /*
     * Save our current place in case we need to roll-back the seek.
     */

    oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
    if (oldLoc == Tcl_LongAsWide(-1)) {
	/*
	 * Bad things are happening.  Error out...
	 */

	*errorCodePtr = errno;
	return -1;
    }

    newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);

    /*
     * Check for expressability in our return type, and roll-back otherwise.
     */

    if (newLoc > Tcl_LongAsWide(INT_MAX)) {
	*errorCodePtr = EOVERFLOW;
	TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
	return -1;
    } else {
	*errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
    }
    return (int) Tcl_WideAsLong(newLoc);
}

/*
 *----------------------------------------------------------------------
 *
 * FileWideSeekProc --
 *
 *	This function is called by the generic IO level to move the access
 *	point in a file based channel, with offsets expressed as wide
 *	integers.
 *
 * Results:
 *	-1 if failed, the new position if successful. An output
 *	argument contains the POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
}

/*
 *----------------------------------------------------------------------
 *
 * FileGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from
 *	a file based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
}

/*
 *----------------------------------------------------------------------
 *
 * FileGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from a file
 *	based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747

748
749
750

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801

802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818

819
820
821
822
823
824
825
	*handlePtr = (ClientData) fsPtr->fd;
	return TCL_OK;
    } else {
	return TCL_ERROR;
    }
}

#ifdef SUPPORTS_TTY 

/*
 *----------------------------------------------------------------------
 *
 * TtyCloseProc --
 *
 *	This procedure is called from the generic IO level to perform
 *	channel-type-specific cleanup when a tty based channel is closed.
 *
 * Results:
 *	0 if successful, errno if failed.
 *
 * Side effects:
 *	Closes the device of the channel.
 *
 *----------------------------------------------------------------------
 */
static int
TtyCloseProc(instanceData, interp)
    ClientData instanceData;	/* Tty state. */
    Tcl_Interp *interp;		/* For error reporting - unused. */
{
#if BAD_TIP35_FLUSH
    TtyState *ttyPtr = (TtyState *) instanceData;
#endif /* BAD_TIP35_FLUSH */

#ifdef TTYFLUSH
    TTYFLUSH(ttyPtr->fs.fd);
#endif /* TTYFLUSH */

#if 0
    /*
     * TIP#35 agreed to remove the unsave so that TCL could be used as a 
     * simple stty. 
     * It would be cleaner to remove all the stuff related to 
     *	  TtyState.stateUpdated
     *	  TtyState.savedState
     * Then the structure TtyState would be the same as FileState.
     * IMO this cleanup could better be done for the final 8.4 release
     * after nobody complained about the missing unsave. -- schroedter
     */
    if (ttyPtr->stateUpdated) {
	SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState);
    }
#endif

    return FileCloseProc(instanceData, interp);
}

/*
 *----------------------------------------------------------------------
 *
 * TtyOutputProc--
 *
 *	This procedure is invoked from the generic IO level to write
 *	output to a TTY channel.
 *
 * Results:
 *	The number of bytes written is returned or -1 on error. An
 *	output argument contains a POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:
 *	Writes output on the output device of the channel
 *	if the channel is not designated to be closed.
 *
 *----------------------------------------------------------------------
 */

#if BAD_TIP35_FLUSH
static int
TtyOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;		/* File state. */
    CONST char *buf;			/* The data buffer. */
    int toWrite;			/* How many bytes to write? */
    int *errorCodePtr;			/* Where to store error code. */
{
    if (TclInExit()) {
	/*
	 * Do not write data during Tcl exit.
	 * Serial port may block preventing Tcl from exit.
	 */

	return toWrite;
    } else {
	return FileOutputProc(instanceData, buf, toWrite, errorCodePtr);
    }
}
#endif /* BAD_TIP35_FLUSH */

#ifdef USE_TERMIOS
/*
 *----------------------------------------------------------------------
 *
 * TtyModemStatusStr --
 *
 *  Converts a RS232 modem status list of readable flags
 *
 *----------------------------------------------------------------------
 */

static void
TtyModemStatusStr(status, dsPtr)
    int status;		   /* RS232 modem status */
    Tcl_DString *dsPtr;	   /* Where to store string */
{
#ifdef TIOCM_CTS
    Tcl_DStringAppendElement(dsPtr, "CTS");







|






|


















>



>


|
<
|


|
|
|





>








|
|


|
|
<


|
|







|
|
|
|



|
|

>













|



>







748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788

789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814

815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
	*handlePtr = (ClientData) fsPtr->fd;
	return TCL_OK;
    } else {
	return TCL_ERROR;
    }
}

#ifdef SUPPORTS_TTY

/*
 *----------------------------------------------------------------------
 *
 * TtyCloseProc --
 *
 *	This function is called from the generic IO level to perform
 *	channel-type-specific cleanup when a tty based channel is closed.
 *
 * Results:
 *	0 if successful, errno if failed.
 *
 * Side effects:
 *	Closes the device of the channel.
 *
 *----------------------------------------------------------------------
 */
static int
TtyCloseProc(instanceData, interp)
    ClientData instanceData;	/* Tty state. */
    Tcl_Interp *interp;		/* For error reporting - unused. */
{
#if BAD_TIP35_FLUSH
    TtyState *ttyPtr = (TtyState *) instanceData;
#endif /* BAD_TIP35_FLUSH */

#ifdef TTYFLUSH
    TTYFLUSH(ttyPtr->fs.fd);
#endif /* TTYFLUSH */

#if 0
    /*
     * TIP#35 agreed to remove the unsave so that TCL could be used as a

     * simple stty. It would be cleaner to remove all the stuff related to
     *	  TtyState.stateUpdated
     *	  TtyState.savedState
     * Then the structure TtyState would be the same as FileState. IMO this
     * cleanup could better be done for the final 8.4 release after nobody
     * complained about the missing unsave. - schroedter
     */
    if (ttyPtr->stateUpdated) {
	SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState);
    }
#endif

    return FileCloseProc(instanceData, interp);
}

/*
 *----------------------------------------------------------------------
 *
 * TtyOutputProc--
 *
 *	This function is invoked from the generic IO level to write output to
 *	a TTY channel.
 *
 * Results:
 *	The number of bytes written is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurred, or zero.

 *
 * Side effects:
 *	Writes output on the output device of the channel if the channel is
 *	not designated to be closed.
 *
 *----------------------------------------------------------------------
 */

#if BAD_TIP35_FLUSH
static int
TtyOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;	/* File state. */
    CONST char *buf;		/* The data buffer. */
    int toWrite;		/* How many bytes to write? */
    int *errorCodePtr;		/* Where to store error code. */
{
    if (TclInExit()) {
	/*
	 * Do not write data during Tcl exit.  Serial port may block
	 * preventing Tcl from exit.
	 */

	return toWrite;
    } else {
	return FileOutputProc(instanceData, buf, toWrite, errorCodePtr);
    }
}
#endif /* BAD_TIP35_FLUSH */

#ifdef USE_TERMIOS
/*
 *----------------------------------------------------------------------
 *
 * TtyModemStatusStr --
 *
 *	Converts a RS232 modem status list of readable flags
 *
 *----------------------------------------------------------------------
 */

static void
TtyModemStatusStr(status, dsPtr)
    int status;		   /* RS232 modem status */
    Tcl_DString *dsPtr;	   /* Where to store string */
{
#ifdef TIOCM_CTS
    Tcl_DStringAppendElement(dsPtr, "CTS");
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
 *	Sets an option on a channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the interp's result on error if
 *	interp is not NULL.
 *
 * Side effects:
 *	May modify an option on a device.
 *	Sets Error message if needed (by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int		
TtySetOptionProc(instanceData, interp, optionName, value)
    ClientData instanceData;	/* File state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL. */
    CONST char *optionName;	/* Which option to set? */
    CONST char *value;		/* New value for option. */
{
    FileState *fsPtr = (FileState *) instanceData;







|
|




|







884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
 *	Sets an option on a channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the interp's result on error if
 *	interp is not NULL.
 *
 * Side effects:
 *	May modify an option on a device.  Sets Error message if needed (by
 *	calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int
TtySetOptionProc(instanceData, interp, optionName, value)
    ClientData instanceData;	/* File state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL. */
    CONST char *optionName;	/* Which option to set? */
    CONST char *value;		/* New value for option. */
{
    FileState *fsPtr = (FileState *) instanceData;
881
882
883
884
885
886
887

888
889
890
891
892
893
894
895
896
897
898
899
900
901

902
903
904
905
906

907
908
909
910
911
912
913
     * Option -mode baud,parity,databits,stopbits
     */
    if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
	if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data,
		&tty.stop) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * system calls results should be checked there. -- dl
	 */

	TtySetAttributes(fsPtr->fd, &tty);
	((TtyState *) fsPtr)->stateUpdated = 1;
	return TCL_OK;
    }

#ifdef USE_TERMIOS

    /*
     * Option -handshake none|xonxoff|rtscts|dtrdsr
     */

    if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
	/*
	 * Reset all handshake options
	 * DTR and RTS are ON by default
	 */

	GETIOSTATE(fsPtr->fd, &iostate);
	iostate.c_iflag &= ~(IXON | IXOFF | IXANY);
#ifdef CRTSCTS
	iostate.c_cflag &= ~CRTSCTS;
#endif /* CRTSCTS */
	if (strncasecmp(value, "NONE", vlen) == 0) {
	    /* leave all handshake options disabled */







>

|












>


|
<

>







917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942

943
944
945
946
947
948
949
950
951
     * Option -mode baud,parity,databits,stopbits
     */
    if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
	if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data,
		&tty.stop) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * system calls results should be checked there. - dl
	 */

	TtySetAttributes(fsPtr->fd, &tty);
	((TtyState *) fsPtr)->stateUpdated = 1;
	return TCL_OK;
    }

#ifdef USE_TERMIOS

    /*
     * Option -handshake none|xonxoff|rtscts|dtrdsr
     */

    if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
	/*
	 * Reset all handshake options. DTR and RTS are ON by default.

	 */

	GETIOSTATE(fsPtr->fd, &iostate);
	iostate.c_iflag &= ~(IXON | IXOFF | IXANY);
#ifdef CRTSCTS
	iostate.c_cflag &= ~CRTSCTS;
#endif /* CRTSCTS */
	if (strncasecmp(value, "NONE", vlen) == 0) {
	    /* leave all handshake options disabled */
934
935
936
937
938
939
940

941
942
943
944
945
946
947
	SETIOSTATE(fsPtr->fd, &iostate);
	return TCL_OK;
    }

    /*
     * Option -xchar {\x11 \x13}
     */

    if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
	GETIOSTATE(fsPtr->fd, &iostate);
	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 2) {
	    iostate.c_cc[VSTART] = argv[0][0];







>







972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
	SETIOSTATE(fsPtr->fd, &iostate);
	return TCL_OK;
    }

    /*
     * Option -xchar {\x11 \x13}
     */

    if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
	GETIOSTATE(fsPtr->fd, &iostate);
	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 2) {
	    iostate.c_cc[VSTART] = argv[0][0];
959
960
961
962
963
964
965

966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981

982
983
984
985
986
987
988
	ckfree((char *) argv);
	return TCL_OK;
    }

    /*
     * Option -timeout msec
     */

    if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
	int msec;

	GETIOSTATE(fsPtr->fd, &iostate);
	if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
	    return TCL_ERROR;
	}
	iostate.c_cc[VMIN]  = 0;
	iostate.c_cc[VTIME] = (msec == 0) ? 0 : (msec < 100) ? 1 : (msec+50)/100;
	SETIOSTATE(fsPtr->fd, &iostate);
	return TCL_OK;
    }

    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
	int i;
	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp) {







>
















>







998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
	ckfree((char *) argv);
	return TCL_OK;
    }

    /*
     * Option -timeout msec
     */

    if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
	int msec;

	GETIOSTATE(fsPtr->fd, &iostate);
	if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
	    return TCL_ERROR;
	}
	iostate.c_cc[VMIN]  = 0;
	iostate.c_cc[VTIME] = (msec == 0) ? 0 : (msec < 100) ? 1 : (msec+50)/100;
	SETIOSTATE(fsPtr->fd, &iostate);
	return TCL_OK;
    }

    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
	int i;
	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp) {
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
}

/*
 *----------------------------------------------------------------------
 *
 * TtyGetOptionProc --
 *
 *	Gets a mode associated with an IO channel. If the optionName arg
 *	is non NULL, retrieves the value of that option. If the optionName
 *	arg is NULL, retrieves a list of alternating option names and
 *	values for the given channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the supplied DString to the
 *	string value of the option(s) returned.
 *
 * Side effects:
 *	The string returned by this function is in static storage and
 *	may be reused at any time subsequent to the call.
 *	Sets Error message if needed (by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int		
TtyGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	/* File state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL. */
    CONST char *optionName;	/* Option to get. */
    Tcl_DString *dsPtr;		/* Where to store value(s). */
{
    FileState *fsPtr = (FileState *) instanceData;







|
|
|
|


|
|


|
|
|




|







1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
}

/*
 *----------------------------------------------------------------------
 *
 * TtyGetOptionProc --
 *
 *	Gets a mode associated with an IO channel. If the optionName arg is
 *	non NULL, retrieves the value of that option. If the optionName arg is
 *	NULL, retrieves a list of alternating option names and values for the
 *	given channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the supplied DString to the string
 *	value of the option(s) returned.
 *
 * Side effects:
 *	The string returned by this function is in static storage and may be
 *	reused at any time subsequent to the call.  Sets Error message if
 *	needed (by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static int
TtyGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	/* File state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL. */
    CONST char *optionName;	/* Option to get. */
    Tcl_DString *dsPtr;		/* Where to store value(s). */
{
    FileState *fsPtr = (FileState *) instanceData;
1106
1107
1108
1109
1110
1111
1112

1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135

1136
1137
1138
1139
1140
1141
1142
	Tcl_DStringAppendElement(dsPtr, buf);
    }

#ifdef USE_TERMIOS
    /*
     * get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
	IOSTATE iostate;
	valid = 1;

	GETIOSTATE(fsPtr->fd, &iostate);
	sprintf(buf, "%c", iostate.c_cc[VSTART]);
	Tcl_DStringAppendElement(dsPtr, buf);
	sprintf(buf, "%c", iostate.c_cc[VSTOP]);
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * get option -queue
     * option is readonly and returned by [fconfigure chan -queue]
     * but not returned by unnamed [fconfigure chan]
     */

    if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
	int inQueue=0, outQueue=0;
	int inBuffered, outBuffered;
	valid = 1;
#ifdef GETREADQUEUE
	GETREADQUEUE(fsPtr->fd, inQueue);
#endif /* GETREADQUEUE */







>




















|
|

>







1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
	Tcl_DStringAppendElement(dsPtr, buf);
    }

#ifdef USE_TERMIOS
    /*
     * get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
	IOSTATE iostate;
	valid = 1;

	GETIOSTATE(fsPtr->fd, &iostate);
	sprintf(buf, "%c", iostate.c_cc[VSTART]);
	Tcl_DStringAppendElement(dsPtr, buf);
	sprintf(buf, "%c", iostate.c_cc[VSTOP]);
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * get option -queue
     * option is readonly and returned by [fconfigure chan -queue] but not
     * returned by unnamed [fconfigure chan]
     */

    if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
	int inQueue=0, outQueue=0;
	int inBuffered, outBuffered;
	valid = 1;
#ifdef GETREADQUEUE
	GETREADQUEUE(fsPtr->fd, inQueue);
#endif /* GETREADQUEUE */
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
	Tcl_DStringAppendElement(dsPtr, buf);
	sprintf(buf, "%d", outBuffered+outQueue);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * get option -ttystatus
     * option is readonly and returned by [fconfigure chan -ttystatus]
     * but not returned by unnamed [fconfigure chan]
     */
    if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
	int status;
	valid = 1;
	GETCONTROL(fsPtr->fd, &status);
	TtyModemStatusStr(status, dsPtr);
    }







|
|







1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
	Tcl_DStringAppendElement(dsPtr, buf);
	sprintf(buf, "%d", outBuffered+outQueue);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * get option -ttystatus
     * option is readonly and returned by [fconfigure chan -ttystatus] but not
     * returned by unnamed [fconfigure chan]
     */
    if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
	int status;
	valid = 1;
	GETCONTROL(fsPtr->fd, &status);
	TtyModemStatusStr(status, dsPtr);
    }
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
	    "mode queue ttystatus xchar");
#else /* !USE_TERMIOS */
	    "mode");
#endif /* USE_TERMIOS */
    }
}

#undef DIRECT_BAUD
#ifdef B4800
#   if (B4800 == 4800)
#	define DIRECT_BAUD
#   endif /* B4800 == 4800 */
#endif /* B4800 */

#ifdef DIRECT_BAUD
#   define TtyGetSpeed(baud)   ((unsigned) (baud))
#   define TtyGetBaud(speed)   ((int) (speed))
#else /* !DIRECT_BAUD */

static struct {int baud; unsigned long speed;} speeds[] = {
#ifdef B0







<
<
<
<
<
<
<







1216
1217
1218
1219
1220
1221
1222







1223
1224
1225
1226
1227
1228
1229
	    "mode queue ttystatus xchar");
#else /* !USE_TERMIOS */
	    "mode");
#endif /* USE_TERMIOS */
    }
}








#ifdef DIRECT_BAUD
#   define TtyGetSpeed(baud)   ((unsigned) (baud))
#   define TtyGetBaud(speed)   ((int) (speed))
#else /* !DIRECT_BAUD */

static struct {int baud; unsigned long speed;} speeds[] = {
#ifdef B0
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
};

/*
 *---------------------------------------------------------------------------
 *
 * TtyGetSpeed --
 *
 *	Given a baud rate, get the mask value that should be stored in
 *	the termios, termio, or sgttyb structure in order to select that
 *	baud rate.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *







|
|
|







1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
};

/*
 *---------------------------------------------------------------------------
 *
 * TtyGetSpeed --
 *
 *	Given a baud rate, get the mask value that should be stored in the
 *	termios, termio, or sgttyb structure in order to select that baud
 *	rate.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
    int bestIdx, bestDiff, i, diff;

    bestIdx = 0;
    bestDiff = 1000000;

    /*
     * If the baud rate does not correspond to one of the known mask values,
     * choose the mask value whose baud rate is closest to the specified
     * baud rate.
     */

    for (i = 0; speeds[i].baud >= 0; i++) {
	diff = speeds[i].baud - baud;
	if (diff < 0) {
	    diff = -diff;
	}
	if (diff < bestDiff) {
	    bestIdx = i;
	    bestDiff = diff;
	}
    }
    return speeds[bestIdx].speed;
}

/*
 *---------------------------------------------------------------------------
 *
 * TtyGetBaud --
 *
 *	Given a speed mask value from a termios, termio, or sgttyb
 *	structure, get the baus rate that corresponds to that mask value.
 *
 * Results:
 *	As above.  If the mask value was not recognized, 0 is returned.
 *
 * Side effects:
 *	None.
 *







|
|




















|
|







1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
    int bestIdx, bestDiff, i, diff;

    bestIdx = 0;
    bestDiff = 1000000;

    /*
     * If the baud rate does not correspond to one of the known mask values,
     * choose the mask value whose baud rate is closest to the specified baud
     * rate.
     */

    for (i = 0; speeds[i].baud >= 0; i++) {
	diff = speeds[i].baud - baud;
	if (diff < 0) {
	    diff = -diff;
	}
	if (diff < bestDiff) {
	    bestIdx = i;
	    bestDiff = diff;
	}
    }
    return speeds[bestIdx].speed;
}

/*
 *---------------------------------------------------------------------------
 *
 * TtyGetBaud --
 *
 *	Given a speed mask value from a termios, termio, or sgttyb structure,
 *	get the baus rate that corresponds to that mask value.
 *
 * Results:
 *	As above.  If the mask value was not recognized, 0 is returned.
 *
 * Side effects:
 *	None.
 *
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void
TtyGetAttributes(fd, ttyPtr)
    int fd;			/* Open file descriptor for serial port to
				 * be queried. */
    TtyAttrs *ttyPtr;		/* Buffer filled with serial port
				 * attributes. */
{
    IOSTATE iostate;
    int baud, parity, data, stop;

    GETIOSTATE(fd, &iostate);

#ifdef USE_TERMIOS
    baud = TtyGetBaud(cfgetospeed(&iostate));

    parity = 'n';
#ifdef PAREXT
    switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) {
	case PARENB		      : parity = 'e'; break;
	case PARENB | PARODD	      : parity = 'o'; break;
	case PARENB |	       PAREXT : parity = 's'; break;
	case PARENB | PARODD | PAREXT : parity = 'm'; break;
    }
#else /* !PAREXT */
    switch ((int) (iostate.c_cflag & (PARENB | PARODD))) {
	case PARENB		      : parity = 'e'; break;
	case PARENB | PARODD	      : parity = 'o'; break;
    }
#endif /* !PAREXT */

    data = iostate.c_cflag & CSIZE;
    data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8;

    stop = (iostate.c_cflag & CSTOPB) ? 2 : 1;
#endif /* USE_TERMIOS */

#ifdef USE_TERMIO
    baud = TtyGetBaud(iostate.c_cflag & CBAUD);

    parity = 'n';
    switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) {
	case PARENB		      : parity = 'e'; break;
	case PARENB | PARODD	      : parity = 'o'; break;
	case PARENB |	       PAREXT : parity = 's'; break;
	case PARENB | PARODD | PAREXT : parity = 'm'; break;
    }

    data = iostate.c_cflag & CSIZE;
    data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8;

    stop = (iostate.c_cflag & CSTOPB) ? 2 : 1;
#endif /* USE_TERMIO */







|
|














|
|
|
|



|
|














|
|
|
|







1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void
TtyGetAttributes(fd, ttyPtr)
    int fd;			/* Open file descriptor for serial port to be
				 * queried. */
    TtyAttrs *ttyPtr;		/* Buffer filled with serial port
				 * attributes. */
{
    IOSTATE iostate;
    int baud, parity, data, stop;

    GETIOSTATE(fd, &iostate);

#ifdef USE_TERMIOS
    baud = TtyGetBaud(cfgetospeed(&iostate));

    parity = 'n';
#ifdef PAREXT
    switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) {
    case PARENB			  : parity = 'e'; break;
    case PARENB | PARODD	  : parity = 'o'; break;
    case PARENB |	   PAREXT : parity = 's'; break;
    case PARENB | PARODD | PAREXT : parity = 'm'; break;
    }
#else /* !PAREXT */
    switch ((int) (iostate.c_cflag & (PARENB | PARODD))) {
    case PARENB		 : parity = 'e'; break;
    case PARENB | PARODD : parity = 'o'; break;
    }
#endif /* !PAREXT */

    data = iostate.c_cflag & CSIZE;
    data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8;

    stop = (iostate.c_cflag & CSTOPB) ? 2 : 1;
#endif /* USE_TERMIOS */

#ifdef USE_TERMIO
    baud = TtyGetBaud(iostate.c_cflag & CBAUD);

    parity = 'n';
    switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) {
    case PARENB			  : parity = 'e'; break;
    case PARENB | PARODD	  : parity = 'o'; break;
    case PARENB |	   PAREXT : parity = 's'; break;
    case PARENB | PARODD | PAREXT : parity = 'm'; break;
    }

    data = iostate.c_cflag & CSIZE;
    data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8;

    stop = (iostate.c_cflag & CSTOPB) ? 2 : 1;
#endif /* USE_TERMIO */
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
}

/*
 *---------------------------------------------------------------------------
 *
 * TtySetAttributes --
 *
 *	Set the current attributes of the specified serial device. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void
TtySetAttributes(fd, ttyPtr)
    int fd;			/* Open file descriptor for serial port to
				 * be modified. */
    TtyAttrs *ttyPtr;		/* Buffer containing new attributes for
				 * serial port. */
{
    IOSTATE iostate;

#ifdef USE_TERMIOS
    int parity, data, flag;

    GETIOSTATE(fd, &iostate);







|












|
|
|
|







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
}

/*
 *---------------------------------------------------------------------------
 *
 * TtySetAttributes --
 *
 *	Set the current attributes of the specified serial device.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void
TtySetAttributes(fd, ttyPtr)
    int fd;			/* Open file descriptor for serial port to be
				 * modified. */
    TtyAttrs *ttyPtr;		/* Buffer containing new attributes for serial
				 * port. */
{
    IOSTATE iostate;

#ifdef USE_TERMIOS
    int parity, data, flag;

    GETIOSTATE(fd, &iostate);
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
}

/*
 *---------------------------------------------------------------------------
 *
 * TtyParseMode --
 *
 *	Parse the "-mode" argument to the fconfigure command.  The argument
 *	is of the form baud,parity,data,stop.
 *
 * Results:
 *	The return value is TCL_OK if the argument was successfully
 *	parsed, TCL_ERROR otherwise.  If TCL_ERROR is returned, an
 *	error message is left in the interp's result (if interp is non-NULL).
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */








|
|


|
|
|







1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
}

/*
 *---------------------------------------------------------------------------
 *
 * TtyParseMode --
 *
 *	Parse the "-mode" argument to the fconfigure command. The argument is
 *	of the form baud,parity,data,stop.
 *
 * Results:
 *	The return value is TCL_OK if the argument was successfully parsed,
 *	TCL_ERROR otherwise. If TCL_ERROR is returned, an error message is
 *	left in the interp's result (if interp is non-NULL).
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

1593
1594
1595
1596
1597
1598
1599

1600
1601
1602
1603
1604

1605
1606
1607
1608
1609
1610
1611
    if ((i != 4) || (mode[end] != '\0')) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop",
		    NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Only allow setting mark/space parity on platforms that support it
     * Make sure to allow for the case where strchr is a macro.
     * [Bug: 5089]
     */

    if (
#if defined(PAREXT) || defined(USE_TERMIO)
	strchr("noems", parity) == NULL
#else
	strchr("noe", parity) == NULL
#endif /* PAREXT|USE_TERMIO */
	) {







>

|
|
<

>







1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639

1640
1641
1642
1643
1644
1645
1646
1647
1648
    if ((i != 4) || (mode[end] != '\0')) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop",
		    NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Only allow setting mark/space parity on platforms that support it Make
     * sure to allow for the case where strchr is a macro.  [Bug: 5089]

     */

    if (
#if defined(PAREXT) || defined(USE_TERMIO)
	strchr("noems", parity) == NULL
#else
	strchr("noe", parity) == NULL
#endif /* PAREXT|USE_TERMIO */
	) {
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
}

/*
 *---------------------------------------------------------------------------
 *
 * TtyInit --
 *
 *	Given file descriptor that refers to a serial port, 
 *	initialize the serial port to a set of sane values so that
 *	Tcl can talk to a device located on the serial port.
 *	Note that no initialization happens if the initialize flag
 *	is not set; this is necessary for the correct handling of
 *	UNIX console TTYs at startup.
 *
 * Results:
 *	A pointer to a FileState suitable for use with Tcl_CreateChannel
 *	and the ttyChannelType structure.
 *
 * Side effects:
 *	Serial device initialized to non-blocking raw mode, similar to
 *	sockets (if initialize flag is non-zero.)  All other modes can
 *	be simulated on top of this in Tcl.
 *
 *---------------------------------------------------------------------------
 */

static FileState *
TtyInit(fd, initialize)
    int fd;			/* Open file descriptor for serial port to
				 * be initialized. */
    int initialize;
{
    TtyState *ttyPtr;

    ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState));
    GETIOSTATE(fd, &ttyPtr->savedState);
    ttyPtr->stateUpdated = 0;







|
|
<
|
|
|


|
|


|
|
|






|
|







1675
1676
1677
1678
1679
1680
1681
1682
1683

1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
}

/*
 *---------------------------------------------------------------------------
 *
 * TtyInit --
 *
 *	Given file descriptor that refers to a serial port, initialize the
 *	serial port to a set of sane values so that Tcl can talk to a device

 *	located on the serial port.  Note that no initialization happens if
 *	the initialize flag is not set; this is necessary for the correct
 *	handling of UNIX console TTYs at startup.
 *
 * Results:
 *	A pointer to a FileState suitable for use with Tcl_CreateChannel and
 *	the ttyChannelType structure.
 *
 * Side effects:
 *	Serial device initialized to non-blocking raw mode, similar to sockets
 *	(if initialize flag is non-zero.)  All other modes can be simulated on
 *	top of this in Tcl.
 *
 *---------------------------------------------------------------------------
 */

static FileState *
TtyInit(fd, initialize)
    int fd;			/* Open file descriptor for serial port to be
				 * initialized. */
    int initialize;
{
    TtyState *ttyPtr;

    ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState));
    GETIOSTATE(fd, &ttyPtr->savedState);
    ttyPtr->stateUpdated = 0;
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707

1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
	    ttyPtr->stateUpdated = 1;
	}
	iostate.sg_flags &= (EVENP | ODDP);
	iostate.sg_flags |= RAW;
#endif	/* USE_SGTTY */

	/*
	 * Only update if we're changing anything to avoid possible
	 * blocking.
	 */

	if (ttyPtr->stateUpdated) {
	    SETIOSTATE(fd, &iostate);
	}
    }

    return &ttyPtr->fs;
}
#endif	/* SUPPORTS_TTY */

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open an file based channel on Unix systems.
 *
 * Results:
 *	The new channel or NULL. If NULL, the output argument
 *	errorCodePtr is set to a POSIX error and an error message is
 *	left in the interp's result if interp is not NULL.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
    Tcl_Interp *interp;			/* Interpreter for error reporting;







|
<

>

















|
|
|


|
|







1734
1735
1736
1737
1738
1739
1740
1741

1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
	    ttyPtr->stateUpdated = 1;
	}
	iostate.sg_flags &= (EVENP | ODDP);
	iostate.sg_flags |= RAW;
#endif	/* USE_SGTTY */

	/*
	 * Only update if we're changing anything to avoid possible blocking.

	 */

	if (ttyPtr->stateUpdated) {
	    SETIOSTATE(fd, &iostate);
	}
    }

    return &ttyPtr->fs;
}
#endif	/* SUPPORTS_TTY */

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open an file based channel on Unix systems.
 *
 * Results:
 *	The new channel or NULL. If NULL, the output argument errorCodePtr is
 *	set to a POSIX error and an error message is left in the interp's
 *	result if interp is not NULL.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the file
 *	system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
    Tcl_Interp *interp;			/* Interpreter for error reporting;
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768

1769
1770
1771
1772
1773
1774
1775
1776

1777
1778
1779

1780

1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823












1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_ChannelType *channelTypePtr;
#ifdef SUPPORTS_TTY
    int ctl_tty;
#endif /* SUPPORTS_TTY */

    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:
	    channelPermissions = TCL_READABLE;
	    break;
	case O_WRONLY:
	    channelPermissions = TCL_WRITABLE;
	    break;
	case O_RDWR:
	    channelPermissions = (TCL_READABLE | TCL_WRITABLE);
	    break;
	default:
	    /*
	     * This may occurr if modeString was "", for example.
	     */

	    Tcl_Panic("TclpOpenFileChannel: invalid mode value");
	    return NULL;
    }

    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	return NULL;
    }

#ifdef DJGPP
	mode |= O_BINARY;
#endif		

    fd = TclOSopen(native, mode, permissions);

#ifdef SUPPORTS_TTY
    ctl_tty = (strcmp (native, "/dev/tty") == 0);
#endif /* SUPPORTS_TTY */

    if (fd < 0) {
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"", 
		    Tcl_GetString(pathPtr), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }

    /*
     * Set close-on-exec flag on the fd so that child processes will not
     * inherit this fd.
     */

    fcntl(fd, F_SETFD, FD_CLOEXEC);

    sprintf(channelName, "file%d", fd);

#ifdef SUPPORTS_TTY
    if (!ctl_tty && isatty(fd)) {
	/*
	 * Initialize the serial port to a set of sane parameters.
	 * Especially important if the remote device is set to echo and
	 * the serial port driver was also set to echo -- as soon as a char
	 * were sent to the serial port, the remote device would echo it,
	 * then the serial driver would echo it back to the device, etc.
	 */

	translation = "auto crlf";
	channelTypePtr = &ttyChannelType;
	fsPtr = TtyInit(fd, 1);
    } else 
#endif	/* SUPPORTS_TTY */
    {
	translation = NULL;
	channelTypePtr = &fileChannelType;
	fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
    }













    fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
    fsPtr->fd = fd;

    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    (ClientData) fsPtr, channelPermissions);

    if (translation != NULL) {
	/*
	 * Gotcha.  Most modems need a "\r" at the end of the command
	 * sequence.  If you just send "at\n", the modem will not respond
	 * with "OK" because it never got a "\r" to actually invoke the
	 * command.  So, by default, newlines are translated to "\r\n" on
	 * output to avoid "bug" reports that the serial port isn't working.
	 */

	if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation",
		translation) != TCL_OK) {
	    Tcl_Close(NULL, fsPtr->channel);
	    return NULL;
	}







|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|






>

|
|
>

>






|


















|
|
|
|
|





|







>
>
>
>
>
>
>
>
>
>
>
>








|
|
|
|
|







1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_ChannelType *channelTypePtr;
#ifdef SUPPORTS_TTY
    int ctl_tty;
#endif /* SUPPORTS_TTY */

    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
    case O_RDONLY:
	channelPermissions = TCL_READABLE;
	break;
    case O_WRONLY:
	channelPermissions = TCL_WRITABLE;
	break;
    case O_RDWR:
	channelPermissions = (TCL_READABLE | TCL_WRITABLE);
	break;
    default:
	/*
	 * This may occurr if modeString was "", for example.
	 */

	Tcl_Panic("TclpOpenFileChannel: invalid mode value");
	return NULL;
    }

    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	return NULL;
    }

#ifdef DJGPP
    mode |= O_BINARY;
#endif

    fd = TclOSopen(native, mode, permissions);

#ifdef SUPPORTS_TTY
    ctl_tty = (strcmp (native, "/dev/tty") == 0);
#endif /* SUPPORTS_TTY */

    if (fd < 0) {
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"",
		    Tcl_GetString(pathPtr), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }

    /*
     * Set close-on-exec flag on the fd so that child processes will not
     * inherit this fd.
     */

    fcntl(fd, F_SETFD, FD_CLOEXEC);

    sprintf(channelName, "file%d", fd);

#ifdef SUPPORTS_TTY
    if (!ctl_tty && isatty(fd)) {
	/*
	 * Initialize the serial port to a set of sane parameters.  Especially
	 * important if the remote device is set to echo and the serial port
	 * driver was also set to echo -- as soon as a char were sent to the
	 * serial port, the remote device would echo it, then the serial
	 * driver would echo it back to the device, etc.
	 */

	translation = "auto crlf";
	channelTypePtr = &ttyChannelType;
	fsPtr = TtyInit(fd, 1);
    } else
#endif	/* SUPPORTS_TTY */
    {
	translation = NULL;
	channelTypePtr = &fileChannelType;
	fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
    }

#ifdef DEPRECATED
    if (channelTypePtr == &fileChannelType) {
	/*
	 * TIP #218. Removed the code inserting the new structure into the
	 * global list. This is now handled in the thread action callbacks,
	 * and only there.
	 */

	fsPtr->nextPtr = NULL;
    }
#endif /* DEPRECATED */

    fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
    fsPtr->fd = fd;

    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    (ClientData) fsPtr, channelPermissions);

    if (translation != NULL) {
	/*
	 * Gotcha. Most modems need a "\r" at the end of the command sequence.
	 * If you just send "at\n", the modem will not respond with "OK"
	 * because it never got a "\r" to actually invoke the command. So, by
	 * default, newlines are translated to "\r\n" on output to avoid "bug"
	 * reports that the serial port isn't working.
	 */

	if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation",
		translation) != TCL_OK) {
	    Tcl_Close(NULL, fsPtr->channel);
	    return NULL;
	}
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
    if (isatty(fd)) {
	fsPtr = TtyInit(fd, 0);
	channelTypePtr = &ttyChannelType;
	sprintf(channelName, "serial%d", fd);
    } else
#endif /* SUPPORTS_TTY */
    if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0
            && sockaddrLen > 0
            && sockaddr.sa_family == AF_INET) {
	return MakeTcpClientChannelMode((ClientData) fd, mode);
    } else {
	channelTypePtr = &fileChannelType;
	fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
	sprintf(channelName, "file%d", fd);
    }

    fsPtr->fd = fd;
    fsPtr->validMask = mode | TCL_EXCEPTION;
    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    (ClientData) fsPtr, mode);

    return fsPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpBlockModeProc --
 *
 *	This procedure is invoked by the generic IO level to set blocking
 *	and nonblocking mode on a TCP socket based channel.
 *
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or nonblocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpBlockModeProc(instanceData, mode)
    ClientData instanceData;		/* Socket state. */
    int mode;				/* The mode to set. Can be one of
					 * TCL_MODE_BLOCKING or
					 * TCL_MODE_NONBLOCKING. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    int setting;

#ifndef USE_FIONBIO
    setting = fcntl(statePtr->fd, F_GETFL);
    if (mode == TCL_MODE_BLOCKING) {







|
|




















|
|













|
|
|
|







1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
    if (isatty(fd)) {
	fsPtr = TtyInit(fd, 0);
	channelTypePtr = &ttyChannelType;
	sprintf(channelName, "serial%d", fd);
    } else
#endif /* SUPPORTS_TTY */
    if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0
	    && sockaddrLen > 0
	    && sockaddr.sa_family == AF_INET) {
	return MakeTcpClientChannelMode((ClientData) fd, mode);
    } else {
	channelTypePtr = &fileChannelType;
	fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
	sprintf(channelName, "file%d", fd);
    }

    fsPtr->fd = fd;
    fsPtr->validMask = mode | TCL_EXCEPTION;
    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    (ClientData) fsPtr, mode);

    return fsPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpBlockModeProc --
 *
 *	This function is invoked by the generic IO level to set blocking and
 *	nonblocking mode on a TCP socket based channel.
 *
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or nonblocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpBlockModeProc(instanceData, mode)
    ClientData instanceData;	/* Socket state. */
    int mode;			/* The mode to set. Can be one of
				 * TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    int setting;

#ifndef USE_FIONBIO
    setting = fcntl(statePtr->fd, F_GETFL);
    if (mode == TCL_MODE_BLOCKING) {
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Waits for a connection on an asynchronously opened socket to
 *	be completed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The socket is connected after this function returns.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForConnect(statePtr, errorCodePtr)
    TcpState *statePtr;		/* State of the socket. */
    int *errorCodePtr;		/* Where to store errors? */
{
    int timeOut;		/* How long to wait. */
    int state;			/* Of calling TclWaitForFile. */
    int flags;			/* fcntl flags for the socket. */

    /*
     * If an asynchronous connect is in progress, attempt to wait for it
     * to complete before reading.
     */

    if (statePtr->flags & TCP_ASYNC_CONNECT) {
	if (statePtr->flags & TCP_ASYNC_SOCKET) {
	    timeOut = 0;
	} else {
	    timeOut = -1;







|
|




















|
|







2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForConnect --
 *
 *	Waits for a connection on an asynchronously opened socket to be
 *	completed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The socket is connected after this function returns.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForConnect(statePtr, errorCodePtr)
    TcpState *statePtr;		/* State of the socket. */
    int *errorCodePtr;		/* Where to store errors? */
{
    int timeOut;		/* How long to wait. */
    int state;			/* Of calling TclWaitForFile. */
    int flags;			/* fcntl flags for the socket. */

    /*
     * If an asynchronous connect is in progress, attempt to wait for it to
     * complete before reading.
     */

    if (statePtr->flags & TCP_ASYNC_CONNECT) {
	if (statePtr->flags & TCP_ASYNC_SOCKET) {
	    timeOut = 0;
	} else {
	    timeOut = -1;
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
}

/*
 *----------------------------------------------------------------------
 *
 * TcpInputProc --
 *
 *	This procedure is invoked by the generic IO level to read input
 *	from a TCP socket based channel.
 *
 *	NOTE: We cannot share code with FilePipeInputProc because here
 *	we must use recv to obtain the input from the channel, not read.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains the POSIX error code on error, or zero if no
 *	error occurred.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpInputProc(instanceData, buf, bufSize, errorCodePtr)
    ClientData instanceData;		/* Socket state. */
    char *buf;				/* Where to store data read. */
    int bufSize;			/* How much space is available
					 * in the buffer? */
    int *errorCodePtr;			/* Where to store error code. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    int bytesRead, state;

    *errorCodePtr = 0;
    state = WaitForConnect(statePtr, errorCodePtr);







|
|

|
|



|
|












|
|







2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
}

/*
 *----------------------------------------------------------------------
 *
 * TcpInputProc --
 *
 *	This function is invoked by the generic IO level to read input from a
 *	TCP socket based channel.
 *
 *	NOTE: We cannot share code with FilePipeInputProc because here we must
 *	use recv to obtain the input from the channel, not read.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains the POSIX error code on error, or zero if no error
 *	occurred.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpInputProc(instanceData, buf, bufSize, errorCodePtr)
    ClientData instanceData;		/* Socket state. */
    char *buf;				/* Where to store data read. */
    int bufSize;			/* How much space is available in the
					 * buffer? */
    int *errorCodePtr;			/* Where to store error code. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    int bytesRead, state;

    *errorCodePtr = 0;
    state = WaitForConnect(statePtr, errorCodePtr);
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
}

/*
 *----------------------------------------------------------------------
 *
 * TcpOutputProc --
 *
 *	This procedure is invoked by the generic IO level to write output
 *	to a TCP socket based channel.
 *
 *	NOTE: We cannot share code with FilePipeOutputProc because here
 *	we must use send, not write, to get reliable error reporting.
 *
 * Results:
 *	The number of bytes written is returned. An output argument is
 *	set to a POSIX error code if an error occurred, or zero.
 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */








|
|

|
|


|
|







2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
}

/*
 *----------------------------------------------------------------------
 *
 * TcpOutputProc --
 *
 *	This function is invoked by the generic IO level to write output to a
 *	TCP socket based channel.
 *
 *	NOTE: We cannot share code with FilePipeOutputProc because here we
 *	must use send, not write, to get reliable error reporting.
 *
 * Results:
 *	The number of bytes written is returned. An output argument is set to
 *	a POSIX error code if an error occurred, or zero.
 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
}

/*
 *----------------------------------------------------------------------
 *
 * TcpCloseProc --
 *
 *	This procedure is invoked by the generic IO level to perform
 *	channel-type-specific cleanup when a TCP socket based channel
 *	is closed.
 *
 * Results:
 *	0 if successful, the value of errno if failed.
 *
 * Side effects:
 *	Closes the socket of the channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpCloseProc(instanceData, interp)
    ClientData instanceData;	/* The socket to close. */
    Tcl_Interp *interp;		/* For error reporting - unused. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    int errorCode = 0;

    /*
     * Delete a file handler that may be active for this socket if this
     * is a server socket - the file handler was created automatically
     * by Tcl as part of the mechanism to accept new client connections.
     * Channel handlers are already deleted in the generic IO channel
     * closing code that called this function, so we do not have to
     * delete them here.
     */

    Tcl_DeleteFileHandler(statePtr->fd);

    if (close(statePtr->fd) < 0) {
	errorCode = errno;
    }
    ckfree((char *) statePtr);

    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetOptionProc --
 *
 *	Computes an option value for a TCP socket based channel, or a
 *	list of all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a
 *	list of all options and their values is returned in the
 *	supplied DString. Sets Error message if needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	 /* Socket state. */
    Tcl_Interp *interp;		 /* For error reporting - can be NULL. */
    CONST char *optionName;	 /* Name of the option to
				  * retrieve the value for, or
				  * NULL to get all options and
				  * their values. */
    Tcl_DString *dsPtr;		 /* Where to store the computed
				  * value; initialized by caller. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    struct sockaddr_in sockname;
    struct sockaddr_in peername;
    struct hostent *hostEntPtr;
    socklen_t size = sizeof(struct sockaddr_in);
    size_t len = 0;







|
|
|




















|
|
|
|
|
<

















|
|




|
|
|











|
<
|
|
|
|







2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214

2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252

2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
}

/*
 *----------------------------------------------------------------------
 *
 * TcpCloseProc --
 *
 *	This function is invoked by the generic IO level to perform
 *	channel-type-specific cleanup when a TCP socket based channel is
 *	closed.
 *
 * Results:
 *	0 if successful, the value of errno if failed.
 *
 * Side effects:
 *	Closes the socket of the channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TcpCloseProc(instanceData, interp)
    ClientData instanceData;	/* The socket to close. */
    Tcl_Interp *interp;		/* For error reporting - unused. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    int errorCode = 0;

    /*
     * Delete a file handler that may be active for this socket if this is a
     * server socket - the file handler was created automatically by Tcl as
     * part of the mechanism to accept new client connections. Channel
     * handlers are already deleted in the generic IO channel closing code
     * that called this function, so we do not have to delete them here.

     */

    Tcl_DeleteFileHandler(statePtr->fd);

    if (close(statePtr->fd) < 0) {
	errorCode = errno;
    }
    ckfree((char *) statePtr);

    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetOptionProc --
 *
 *	Computes an option value for a TCP socket based channel, or a list of
 *	all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a list of
 *	all options and their values is returned in the supplied DString. Sets
 *	Error message if needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	 /* Socket state. */
    Tcl_Interp *interp;		 /* For error reporting - can be NULL. */
    CONST char *optionName;	 /* Name of the option to retrieve the value

				  * for, or NULL to get all options and their
				  * values. */
    Tcl_DString *dsPtr;		 /* Where to store the computed value;
				  * initialized by caller. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    struct sockaddr_in sockname;
    struct sockaddr_in peername;
    struct hostent *hostEntPtr;
    socklen_t size = sizeof(struct sockaddr_in);
    size_t len = 0;
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
		Tcl_DStringEndSublist(dsPtr);
	    } else {
		return TCL_OK;
	    }
	} else {
	    /*
	     * getpeername failed - but if we were asked for all the options
	     * (len==0), don't flag an error at that point because it could
	     * be an fconfigure request on a server socket. (which have
	     * no peer). same must be done on win&mac.
	     */

	    if (len) {
		if (interp) {
		    Tcl_AppendResult(interp, "can't get peername: ",
			    Tcl_PosixError(interp), (char *) NULL);
		}







|
|
|







2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
		Tcl_DStringEndSublist(dsPtr);
	    } else {
		return TCL_OK;
	    }
	} else {
	    /*
	     * getpeername failed - but if we were asked for all the options
	     * (len==0), don't flag an error at that point because it could be
	     * an fconfigure request on a server socket (which have no peer).
	     * Same must be done on win&mac.
	     */

	    if (len) {
		if (interp) {
		    Tcl_AppendResult(interp, "can't get peername: ",
			    Tcl_PosixError(interp), (char *) NULL);
		}
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
 *
 *	Initialize the notifier to watch the fd from this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will
 *	be seen by Tcl.
 *
 *----------------------------------------------------------------------
 */

static void
TcpWatchProc(instanceData, mask)
    ClientData instanceData;		/* The socket state. */







|
|







2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
 *
 *	Initialize the notifier to watch the fd from this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will be
 *	seen by Tcl.
 *
 *----------------------------------------------------------------------
 */

static void
TcpWatchProc(instanceData, mask)
    ClientData instanceData;		/* The socket state. */
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside
 *	a TCP socket based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
 *	TCP socket based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocket --
 *
 *	This function opens a new socket in client or server mode
 *	and initializes the TcpState structure.
 *
 * Results:
 *	Returns a new TcpState, or NULL with an error in the interp's
 *	result, if interp is not NULL.
 *
 * Side effects:
 *	Opens a socket.
 *
 *----------------------------------------------------------------------
 */

static TcpState *
CreateSocket(interp, port, host, server, myaddr, myport, async)
    Tcl_Interp *interp;		/* For error reporting; can be NULL. */
    int port;			/* Port number to open. */
    CONST char *host;		/* Name of host on which to open port.
				 * NULL implies INADDR_ANY */
    int server;			/* 1 if socket should be a server socket,
				 * else 0 for a client socket. */
    CONST char *myaddr;		/* Optional client-side address */
    int myport;			/* Optional client-side port */
    int async;			/* If nonzero and creating a client socket,
				 * attempt to do an async connect. Otherwise
				 * do a synchronous connect or bind. */
{
    int status, sock, asyncConnect, curState, origState;







|
|


|
|











|
|
|
|







2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocket --
 *
 *	This function opens a new socket in client or server mode and
 *	initializes the TcpState structure.
 *
 * Results:
 *	Returns a new TcpState, or NULL with an error in the interp's result,
 *	if interp is not NULL.
 *
 * Side effects:
 *	Opens a socket.
 *
 *----------------------------------------------------------------------
 */

static TcpState *
CreateSocket(interp, port, host, server, myaddr, myport, async)
    Tcl_Interp *interp;		/* For error reporting; can be NULL. */
    int port;			/* Port number to open. */
    CONST char *host;		/* Name of host on which to open port.  NULL
				 * implies INADDR_ANY */
    int server;			/* 1 if socket should be a server socket, else
				 * 0 for a client socket. */
    CONST char *myaddr;		/* Optional client-side address */
    int myport;			/* Optional client-side port */
    int async;			/* If nonzero and creating a client socket,
				 * attempt to do an async connect. Otherwise
				 * do a synchronous connect or bind. */
{
    int status, sock, asyncConnect, curState, origState;
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463

    sock = socket(AF_INET, SOCK_STREAM, 0);
    if (sock < 0) {
	goto addressError;
    }

    /*
     * Set the close-on-exec flag so that the socket will not get
     * inherited by child processes.
     */

    fcntl(sock, F_SETFD, FD_CLOEXEC);

    /*
     * Set kernel space buffering
     */







|
|







2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513

    sock = socket(AF_INET, SOCK_STREAM, 0);
    if (sock < 0) {
	goto addressError;
    }

    /*
     * Set the close-on-exec flag so that the socket will not get inherited by
     * child processes.
     */

    fcntl(sock, F_SETFD, FD_CLOEXEC);

    /*
     * Set kernel space buffering
     */
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
	status = 1;
	(void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status,
		sizeof(status));
	status = bind(sock, (struct sockaddr *) &sockaddr,
		sizeof(struct sockaddr));
	if (status != -1) {
	    status = listen(sock, SOMAXCONN);
	} 
    } else {
	if (myaddr != NULL || myport != 0) { 
	    curState = 1;
	    (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
		    (char *) &curState, sizeof(curState));
	    status = bind(sock, (struct sockaddr *) &mysockaddr,
		    sizeof(struct sockaddr));
	    if (status < 0) {
		goto bindError;
	    }
	}

	/*
	 * Attempt to connect. The connect may fail at present with an
	 * EINPROGRESS but at a later time it will complete. The caller
	 * will set up a file handler on the socket if she is interested in
	 * being informed when the connect completes.
	 */

	if (async) {
#ifndef USE_FIONBIO
	    origState = fcntl(sock, F_GETFL);
	    curState = origState | O_NONBLOCK;
	    status = fcntl(sock, F_SETFL, curState);







|

|












|
|
|







2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
	status = 1;
	(void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status,
		sizeof(status));
	status = bind(sock, (struct sockaddr *) &sockaddr,
		sizeof(struct sockaddr));
	if (status != -1) {
	    status = listen(sock, SOMAXCONN);
	}
    } else {
	if (myaddr != NULL || myport != 0) {
	    curState = 1;
	    (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
		    (char *) &curState, sizeof(curState));
	    status = bind(sock, (struct sockaddr *) &mysockaddr,
		    sizeof(struct sockaddr));
	    if (status < 0) {
		goto bindError;
	    }
	}

	/*
	 * Attempt to connect. The connect may fail at present with an
	 * EINPROGRESS but at a later time it will complete. The caller will
	 * set up a file handler on the socket if she is interested in being
	 * informed when the connect completes.
	 */

	if (async) {
#ifndef USE_FIONBIO
	    origState = fcntl(sock, F_GETFL);
	    curState = origState | O_NONBLOCK;
	    status = fcntl(sock, F_SETFL, curState);
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529

2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
		    asyncConnect = 1;
		    status = 0;
		}
	    } else {
		/*
		 * Here we are if the connect succeeds. In case of an
		 * asynchronous connect we have to reset the channel to
		 * blocking mode.  This appears to happen not very often,
		 * but e.g. on a HP 9000/800 under HP-UX B.11.00 we enter
		 * this stage. [Bug: 4388]
		 */

		if (async) {
#ifndef USE_FIONBIO
		    origState = fcntl(sock, F_GETFL);
		    curState = origState & ~(O_NONBLOCK);
		    status = fcntl(sock, F_SETFL, curState);
#else /* USE_FIONBIO */
		    curState = 0;
		    status = ioctl(sock, FIONBIO, &curState);
#endif /* !USE_FIONBIO */
		}
	    }
	}
    }

bindError:
    if (status < 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "couldn't open socket: ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	if (sock != -1) {
	    close(sock);







|
|
|

>














|







2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
		    asyncConnect = 1;
		    status = 0;
		}
	    } else {
		/*
		 * Here we are if the connect succeeds. In case of an
		 * asynchronous connect we have to reset the channel to
		 * blocking mode.  This appears to happen not very often, but
		 * e.g. on a HP 9000/800 under HP-UX B.11.00 we enter this
		 * stage. [Bug: 4388]
		 */

		if (async) {
#ifndef USE_FIONBIO
		    origState = fcntl(sock, F_GETFL);
		    curState = origState & ~(O_NONBLOCK);
		    status = fcntl(sock, F_SETFL, curState);
#else /* USE_FIONBIO */
		    curState = 0;
		    status = ioctl(sock, FIONBIO, &curState);
#endif /* !USE_FIONBIO */
		}
	    }
	}
    }

  bindError:
    if (status < 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "couldn't open socket: ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	if (sock != -1) {
	    close(sock);
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
    if (asyncConnect) {
	statePtr->flags = TCP_ASYNC_CONNECT;
    }
    statePtr->fd = sock;

    return statePtr;

addressError:
    if (sock != -1) {
	close(sock);
    }
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open socket: ",
		Tcl_PosixError(interp), (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocketAddress --
 *
 *	This function initializes a sockaddr structure for a host and port.
 *
 * Results:
 *	1 if the host was valid, 0 if the host could not be converted to
 *	an IP address.
 *
 * Side effects:
 *	Fills in the *sockaddrPtr structure.
 *
 *----------------------------------------------------------------------
 */








|


















|
|







2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
    if (asyncConnect) {
	statePtr->flags = TCP_ASYNC_CONNECT;
    }
    statePtr->fd = sock;

    return statePtr;

  addressError:
    if (sock != -1) {
	close(sock);
    }
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open socket: ",
		Tcl_PosixError(interp), (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocketAddress --
 *
 *	This function initializes a sockaddr structure for a host and port.
 *
 * Results:
 *	1 if the host was valid, 0 if the host could not be converted to an IP
 *	address.
 *
 * Side effects:
 *	Fills in the *sockaddrPtr structure.
 *
 *----------------------------------------------------------------------
 */

2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
	}
	if (native != NULL) {
	    Tcl_DStringFree(&ds);
	}
    }

    /*
     * NOTE: On 64 bit machines the assignment below is rumored to not
     * do the right thing. Please report errors related to this if you
     * observe incorrect behavior on 64 bit machines such as DEC Alphas.
     * Should we modify this code to do an explicit memcpy?
     */

    sockaddrPtr->sin_addr.s_addr = addr.s_addr;
    return 1;	/* Success. */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpClient --
 *
 *	Opens a TCP client socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed.	An error message is returned
 *	in the interpreter on failure.
 *
 * Side effects:
 *	Opens a client socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */








|
|
|
|














|
|







2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
	}
	if (native != NULL) {
	    Tcl_DStringFree(&ds);
	}
    }

    /*
     * NOTE: On 64 bit machines the assignment below is rumored to not do the
     * right thing. Please report errors related to this if you observe
     * incorrect behavior on 64 bit machines such as DEC Alphas.  Should we
     * modify this code to do an explicit memcpy?
     */

    sockaddrPtr->sin_addr.s_addr = addr.s_addr;
    return 1;	/* Success. */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpClient --
 *
 *	Opens a TCP client socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. An error message is returned in the
 *	interpreter on failure.
 *
 * Side effects:
 *	Opens a client socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
 *	Opens a TCP server socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. If an error occurred, an
 *	error message is left in the interp's result if interp is
 *	not NULL.
 *
 * Side effects:
 *	Opens a server socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */








|
|
<







2835
2836
2837
2838
2839
2840
2841
2842
2843

2844
2845
2846
2847
2848
2849
2850
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
 *	Opens a TCP server socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. If an error occurred, an error message
 *	is left in the interp's result if interp is not NULL.

 *
 * Side effects:
 *	Opens a server socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
	return NULL;
    }

    statePtr->acceptProc = acceptProc;
    statePtr->acceptProcData = acceptProcData;

    /*
     * Set up the callback mechanism for accepting connections
     * from new clients.
     */

    Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept,
	    (ClientData) statePtr);
    sprintf(channelName, "sock%d", statePtr->fd);
    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    (ClientData) statePtr, 0);
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAccept --
 *	Accept a TCP socket connection.	 This is called by the event loop.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new connection socket. Calls the registered callback
 *	for the connection acceptance mechanism.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TcpAccept(data, mask)
    ClientData data;			/* Callback token. */
    int mask;				/* Not used. */
{
    TcpState *sockState;		/* Client data of server socket. */
    int newsock;			/* The new client socket */
    TcpState *newSockState;		/* State for new socket. */
    struct sockaddr_in addr;		/* The remote address */
    socklen_t len;				/* For accept interface */
    char channelName[16 + TCL_INTEGER_SPACE];

    sockState = (TcpState *) data;

    len = sizeof(struct sockaddr_in);
    newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len);
    if (newsock < 0) {
	return;
    }

    /*
     * Set close-on-exec flag to prevent the newly accepted socket from
     * being inherited by child processes.
     */

    (void) fcntl(newsock, F_SETFD, FD_CLOEXEC);

    newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState));

    newSockState->flags = 0;







|
|




















|
|














|











|
|







2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
	return NULL;
    }

    statePtr->acceptProc = acceptProc;
    statePtr->acceptProcData = acceptProcData;

    /*
     * Set up the callback mechanism for accepting connections from new
     * clients.
     */

    Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept,
	    (ClientData) statePtr);
    sprintf(channelName, "sock%d", statePtr->fd);
    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    (ClientData) statePtr, 0);
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAccept --
 *	Accept a TCP socket connection.	 This is called by the event loop.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new connection socket. Calls the registered callback for the
 *	connection acceptance mechanism.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
TcpAccept(data, mask)
    ClientData data;			/* Callback token. */
    int mask;				/* Not used. */
{
    TcpState *sockState;		/* Client data of server socket. */
    int newsock;			/* The new client socket */
    TcpState *newSockState;		/* State for new socket. */
    struct sockaddr_in addr;		/* The remote address */
    socklen_t len;			/* For accept interface */
    char channelName[16 + TCL_INTEGER_SPACE];

    sockState = (TcpState *) data;

    len = sizeof(struct sockaddr_in);
    newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len);
    if (newsock < 0) {
	return;
    }

    /*
     * Set close-on-exec flag to prevent the newly accepted socket from being
     * inherited by child processes.
     */

    (void) fcntl(newsock, F_SETFD, FD_CLOEXEC);

    newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState));

    newSockState->flags = 0;
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933

2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDefaultStdChannel --
 *
 *	Creates channels for standard input, standard output or standard
 *	error output if they do not already exist.
 *
 * Results:
 *	Returns the specified default standard channel, or NULL.
 *
 * Side effects:
 *	May cause the creation of a standard channel and the underlying
 *	file.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpGetDefaultStdChannel(type)
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    Tcl_Channel channel = NULL;
    int fd = 0;			/* Initializations needed to prevent */
    int mode = 0;		/* compiler warning (used before set). */
    char *bufMode = NULL;

    /*
     * Some #def's to make the code a little clearer!
     */

#define ZERO_OFFSET	((Tcl_SeekOffset) 0)
#define ERROR_OFFSET	((Tcl_SeekOffset) -1)

    switch (type) {
	case TCL_STDIN:
	    if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		    && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 0;
	    mode = TCL_READABLE;
	    bufMode = "line";
	    break;
	case TCL_STDOUT:
	    if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		    && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 1;
	    mode = TCL_WRITABLE;
	    bufMode = "line";
	    break;
	case TCL_STDERR:
	    if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		    && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 2;
	    mode = TCL_WRITABLE;
	    bufMode = "none";
	    break;
	default:
	    Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type");
	    break;
    }

#undef ZERO_OFFSET
#undef ERROR_OFFSET

    channel = Tcl_MakeFileChannel((ClientData) fd, mode);
    if (channel == NULL) {







|
|





|
<
















>




|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966

2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDefaultStdChannel --
 *
 *	Creates channels for standard input, standard output or standard error
 *	output if they do not already exist.
 *
 * Results:
 *	Returns the specified default standard channel, or NULL.
 *
 * Side effects:
 *	May cause the creation of a standard channel and the underlying file.

 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpGetDefaultStdChannel(type)
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    Tcl_Channel channel = NULL;
    int fd = 0;			/* Initializations needed to prevent */
    int mode = 0;		/* compiler warning (used before set). */
    char *bufMode = NULL;

    /*
     * Some #def's to make the code a little clearer!
     */

#define ZERO_OFFSET	((Tcl_SeekOffset) 0)
#define ERROR_OFFSET	((Tcl_SeekOffset) -1)

    switch (type) {
    case TCL_STDIN:
	if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		&& (errno == EBADF)) {
	    return (Tcl_Channel) NULL;
	}
	fd = 0;
	mode = TCL_READABLE;
	bufMode = "line";
	break;
    case TCL_STDOUT:
	if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		&& (errno == EBADF)) {
	    return (Tcl_Channel) NULL;
	}
	fd = 1;
	mode = TCL_WRITABLE;
	bufMode = "line";
	break;
    case TCL_STDERR:
	if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		&& (errno == EBADF)) {
	    return (Tcl_Channel) NULL;
	}
	fd = 2;
	mode = TCL_WRITABLE;
	bufMode = "none";
	break;
    default:
	Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type");
	break;
    }

#undef ZERO_OFFSET
#undef ERROR_OFFSET

    channel = Tcl_MakeFileChannel((ClientData) fd, mode);
    if (channel == NULL) {
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetOpenFile --
 *
 *	Given a name of a channel registered in the given interpreter,
 *	returns a FILE * for it.
 *
 * Results:
 *	A standard Tcl result. If the channel is registered in the given
 *	interpreter and it is managed by the "file" channel driver, and
 *	it is open for the requested mode, then the output parameter
 *	filePtr is set to a FILE * for the underlying file. On error, the
 *	filePtr is not set, TCL_ERROR is returned and an error message is
 *	left in the interp's result.
 *
 * Side effects:
 *	May invoke fdopen to create the FILE * for the requested file.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find file. */
    CONST char *string;		/* String that identifies file. */
    int forWriting;		/* 1 means the file is going to be used
				 * for writing, 0 means for reading. */
    int checkUsage;		/* 1 means verify that the file was opened
				 * in a mode that allows the access specified
				 * by "forWriting". Ignored, we always
				 * check that the channel is open for the
				 * requested mode. */
    ClientData *filePtr;	/* Store pointer to FILE structure here. */
{
    Tcl_Channel chan;
    int chanMode;
    Tcl_ChannelType *chanTypePtr;
    ClientData data;
    int fd;
    FILE *f;

    chan = Tcl_GetChannel(interp, string, &chanMode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) {
	Tcl_AppendResult(interp,
		"\"", string, "\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) {
	Tcl_AppendResult(interp,
		"\"", string, "\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * We allow creating a FILE * out of file based, pipe based and socket
     * based channels. We currently do not allow any other channel types,
     * because it is likely that stdio will not know what to do with them.







|
|



|
|
|
|
|








|

|
|
|
|
|
|
|
|









|





|



|







3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetOpenFile --
 *
 *	Given a name of a channel registered in the given interpreter, returns
 *	a FILE * for it.
 *
 * Results:
 *	A standard Tcl result. If the channel is registered in the given
 *	interpreter and it is managed by the "file" channel driver, and it is
 *	open for the requested mode, then the output parameter filePtr is set
 *	to a FILE * for the underlying file. On error, the filePtr is not set,
 *	TCL_ERROR is returned and an error message is left in the interp's
 *	result.
 *
 * Side effects:
 *	May invoke fdopen to create the FILE * for the requested file.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find file. */
    CONST char *chanID;		/* String that identifies file. */
    int forWriting;		/* 1 means the file is going to be used for
				 * writing, 0 means for reading. */
    int checkUsage;		/* 1 means verify that the file was opened in
				 * a mode that allows the access specified by
				 * "forWriting". Ignored, we always check that
				 * the channel is open for the requested
				 * mode. */
    ClientData *filePtr;	/* Store pointer to FILE structure here. */
{
    Tcl_Channel chan;
    int chanMode;
    Tcl_ChannelType *chanTypePtr;
    ClientData data;
    int fd;
    FILE *f;

    chan = Tcl_GetChannel(interp, chanID, &chanMode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) {
	Tcl_AppendResult(interp,
		"\"", chanID, "\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) {
	Tcl_AppendResult(interp,
		"\"", chanID, "\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * We allow creating a FILE * out of file based, pipe based and socket
     * based channels. We currently do not allow any other channel types,
     * because it is likely that stdio will not know what to do with them.
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
	if (Tcl_GetChannelHandle(chan,
		(forWriting ? TCL_WRITABLE : TCL_READABLE),
		(ClientData*) &data) == TCL_OK) {
	    fd = (int) data;

	    /*
	     * The call to fdopen below is probably dangerous, since it will
	     * truncate an existing file if the file is being opened
	     * for writing....
	     */

	    f = fdopen(fd, (forWriting ? "w" : "r"));
	    if (f == NULL) {
		Tcl_AppendResult(interp, "cannot get a FILE * for \"", string,
			"\"", (char *) NULL);
		return TCL_ERROR;
	    }
	    *filePtr = (ClientData) f;
	    return TCL_OK;
	}
    }

    Tcl_AppendResult(interp, "\"", string,
	    "\" cannot be used to get a FILE *", (char *) NULL);
    return TCL_ERROR;	     
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnixWaitForFile --
 *
 *	This procedure waits synchronously for a file to become readable
 *	or writable, with an optional timeout.
 *
 * Results:
 *	The return value is an OR'ed combination of TCL_READABLE,
 *	TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions
 *	that are present on file at the time of the return.  This
 *	procedure will not return until either "timeout" milliseconds
 *	have elapsed or at least one of the conditions given by mask
 *	has occurred for file (a return value of 0 means that a timeout
 *	occurred).  No normal events will be serviced during the
 *	execution of this procedure.
 *
 * Side effects:
 *	Time passes.
 *
 *----------------------------------------------------------------------
 */

int
TclUnixWaitForFile(fd, mask, timeout)
    int fd;			/* Handle for file on which to wait. */
    int mask;			/* What to wait for: OR'ed combination of
				 * TCL_READABLE, TCL_WRITABLE, and
				 * TCL_EXCEPTION. */
    int timeout;		/* Maximum amount of time to wait for one
				 * of the conditions in mask to occur, in
				 * milliseconds.  A value of 0 means don't
				 * wait at all, and a value of -1 means
				 * wait forever. */
{
    Tcl_Time abortTime, now;
    struct timeval blockTime, *timeoutPtr;
    int index, bit, numFound, result = 0;
    fd_mask readyMasks[3*MASK_SIZE];
    fd_mask *maskp[3];
				/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */

    /*
     * If there is a non-zero finite timeout, compute the time when
     * we give up.
     */

    if (timeout > 0) {
	Tcl_GetTime(&now);
	abortTime.sec = now.sec + timeout/1000;
	abortTime.usec = now.usec + (timeout%1000)*1000;
	if (abortTime.usec >= 1000000) {







|
|




|








|

|







|
|



|
|
|
|
<
|
|













|
|

|
|











|
|







3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150

3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
	if (Tcl_GetChannelHandle(chan,
		(forWriting ? TCL_WRITABLE : TCL_READABLE),
		(ClientData*) &data) == TCL_OK) {
	    fd = (int) data;

	    /*
	     * The call to fdopen below is probably dangerous, since it will
	     * truncate an existing file if the file is being opened for
	     * writing....
	     */

	    f = fdopen(fd, (forWriting ? "w" : "r"));
	    if (f == NULL) {
		Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID,
			"\"", (char *) NULL);
		return TCL_ERROR;
	    }
	    *filePtr = (ClientData) f;
	    return TCL_OK;
	}
    }

    Tcl_AppendResult(interp, "\"", chanID,
	    "\" cannot be used to get a FILE *", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnixWaitForFile --
 *
 *	This function waits synchronously for a file to become readable or
 *	writable, with an optional timeout.
 *
 * Results:
 *	The return value is an OR'ed combination of TCL_READABLE,
 *	TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are
 *	present on file at the time of the return. This function will not
 *	return until either "timeout" milliseconds have elapsed or at least
 *	one of the conditions given by mask has occurred for file (a return

 *	value of 0 means that a timeout occurred).  No normal events will be
 *	serviced during the execution of this function.
 *
 * Side effects:
 *	Time passes.
 *
 *----------------------------------------------------------------------
 */

int
TclUnixWaitForFile(fd, mask, timeout)
    int fd;			/* Handle for file on which to wait. */
    int mask;			/* What to wait for: OR'ed combination of
				 * TCL_READABLE, TCL_WRITABLE, and
				 * TCL_EXCEPTION. */
    int timeout;		/* Maximum amount of time to wait for one of
				 * the conditions in mask to occur, in
				 * milliseconds.  A value of 0 means don't
				 * wait at all, and a value of -1 means wait
				 * forever. */
{
    Tcl_Time abortTime, now;
    struct timeval blockTime, *timeoutPtr;
    int index, bit, numFound, result = 0;
    fd_mask readyMasks[3*MASK_SIZE];
    fd_mask *maskp[3];
				/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */

    /*
     * If there is a non-zero finite timeout, compute the time when we give
     * up.
     */

    if (timeout > 0) {
	Tcl_GetTime(&now);
	abortTime.sec = now.sec + timeout/1000;
	abortTime.usec = now.usec + (timeout%1000)*1000;
	if (abortTime.usec >= 1000000) {
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
	Tcl_Panic("TclWaitForFile can't handle file id %d", fd);
    }
    memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
    index = fd/(NBBY*sizeof(fd_mask));
    bit = 1 << (fd%(NBBY*sizeof(fd_mask)));

    /*
     * Loop in a mini-event loop of our own, waiting for either the
     * file to become ready or a timeout to occur.
     */

    while (1) {
	if (timeout > 0) {
	    blockTime.tv_sec = abortTime.sec - now.sec;
	    blockTime.tv_usec = abortTime.usec - now.usec;
	    if (blockTime.tv_usec < 0) {







|
|







3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
	Tcl_Panic("TclWaitForFile can't handle file id %d", fd);
    }
    memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
    index = fd/(NBBY*sizeof(fd_mask));
    bit = 1 << (fd%(NBBY*sizeof(fd_mask)));

    /*
     * Loop in a mini-event loop of our own, waiting for either the file to
     * become ready or a timeout to occur.
     */

    while (1) {
	if (timeout > 0) {
	    blockTime.tv_sec = abortTime.sec - now.sec;
	    blockTime.tv_usec = abortTime.usec - now.usec;
	    if (blockTime.tv_usec < 0) {
3195
3196
3197
3198
3199
3200
3201

3202


3203
3204
3205
3206
3207
3208
3209
	    (readyMasks+2*(MASK_SIZE))[index] |= bit;
	}

	/*
	 * Wait for the event or a timeout.
	 */


       /* This is needed to satisfy GCC 3.3's strict aliasing rules */


	maskp[0] = &readyMasks[0];
	maskp[1] = &readyMasks[MASK_SIZE];
	maskp[2] = &readyMasks[2*MASK_SIZE];
	numFound = select(fd+1, (SELECT_MASK *) maskp[0],
		(SELECT_MASK *) maskp[1],
		(SELECT_MASK *) maskp[2], timeoutPtr);
	if (numFound == 1) {







>
|
>
>







3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
	    (readyMasks+2*(MASK_SIZE))[index] |= bit;
	}

	/*
	 * Wait for the event or a timeout.
	 */

	/*
	 * This is needed to satisfy GCC 3.3's strict aliasing rules.
	 */

	maskp[0] = &readyMasks[0];
	maskp[1] = &readyMasks[MASK_SIZE];
	maskp[2] = &readyMasks[2*MASK_SIZE];
	numFound = select(fd+1, (SELECT_MASK *) maskp[0],
		(SELECT_MASK *) maskp[1],
		(SELECT_MASK *) maskp[2], timeoutPtr);
	if (numFound == 1) {
3235
3236
3237
3238
3239
3240
3241

3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259






3260





3261
3262








3263





3264


3265



3266
3267
3268
3269
3270
3271
3272
3273
3274
3275

3276
3277
3278
3279


3280
3281
3282
3283
3284
3285

3286


3287
3288




3289






3290










		&& (abortTime.usec <= now.usec))) {
	    break;
	}
    }
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * TclpCutFileChannel --
 *
 *	Remove any thread local refs to this channel. See
 *	Tcl_CutChannel for more info.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None. This is a no-op under unix.
 *
 *----------------------------------------------------------------------
 */

void






TclpCutFileChannel(chan)





    Tcl_Channel chan;			/* The channel being removed. Must
                                         * not be referenced in any








                                         * interpreter. */





{


}




/*
 *----------------------------------------------------------------------
 *
 * TclpSpliceFileChannel --
 *
 *	Insert thread local ref for this channel.
 *	Tcl_SpliceChannel for more info.
 *
 * Results:

 *	None.
 *
 * Side effects:
 *	None. This is a no-op under unix.


 *
 *----------------------------------------------------------------------
 */

void
TclpSpliceFileChannel(chan)

    Tcl_Channel chan;			/* The channel being removed. Must


                                         * not be referenced in any
                                         * interpreter. */




{






}

















>



|

|
<










|
>
>
>
>
>
>
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|
>
>
|
>
>
>




|

|
<


>
|


|
>
>




|
|
>
|
>
>
|
|
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300

3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353

3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
		&& (abortTime.usec <= now.usec))) {
	    break;
	}
    }
    return result;
}

#ifdef DEPRECATED
/*
 *----------------------------------------------------------------------
 *
 * FileThreadActionProc --
 *
 *	Insert or remove any thread local refs to this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None. This is a no-op under unix.
 *
 *----------------------------------------------------------------------
 */

static void
FileThreadActionProc (instanceData, action)
     ClientData instanceData;
     int action;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    FileState *fsPtr = (FileState *) instanceData;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	fsPtr->nextPtr = tsdPtr->firstFilePtr;
	tsdPtr->firstFilePtr = fsPtr;
    } else {
	FileState **nextPtrPtr;
	int removed = 0;

	for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
		nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == fsPtr) {
		(*nextPtrPtr) = fsPtr->nextPtr;
		removed = 1;
		break;
	    }
	}

	/*
	 * This could happen if the channel was created in one thread and then
	 * moved to another without updating the thread local data in each
	 * thread.
	 */

	if (!removed) {
	    Tcl_Panic("file info ptr not on thread channel list");
	}
    }
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * FileTruncateProc --
 *
 *	Truncates a file to a given length.

 *
 * Results:
 *	0 if the operation succeeded, and -1 if it failed (in which case
 *	*errorCodePtr will be set to errno).
 *
 * Side effects:
 *	The underlying file is potentially truncated. This can have a wide
 *	variety of side effects, including moving file pointers that point at
 *	places later in the file than the truncate point.
 *
 *----------------------------------------------------------------------
 */

static int
FileTruncateProc(instanceData, length)
    ClientData instanceData;
    Tcl_WideInt length;
{
    FileState *fsPtr = (FileState *) instanceData;
    int result;

#ifdef HAVE_TYPE_OFF64_T
    /*
     * We assume this goes with the type for now...
     */

    result = ftruncate64(fsPtr->fd, (off64_t) length);
#else
    result = ftruncate(fsPtr->fd, (off_t) length);
#endif
    if (result) {
	return errno;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixEvent.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclUnixEvent.c --
 *
 *	This file implements Unix specific event related routines.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixEvent.c,v 1.5 2004/04/06 22:25:56 dgp Exp $
 */

#include "tclPort.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Sleep --
 *
 *	Delay execution for the specified number of milliseconds.







|
|

|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclUnixEvent.c --
 *
 *	This file implements Unix specific event related routines.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixEvent.c,v 1.5.2.2 2005/08/02 18:16:56 dgp Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Sleep --
 *
 *	Delay execution for the specified number of milliseconds.
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54



55

56

57
58
59
60
61







62
63
64
65
66
67
68
69
70
71
72
73
74
75








 */

void
Tcl_Sleep(ms)
    int ms;			/* Number of milliseconds to sleep. */
{
    struct timeval delay;
    Tcl_Time before, after;

    /*
     * The only trick here is that select appears to return early
     * under some conditions, so we have to check to make sure that
     * the right amount of time really has elapsed.  If it's too
     * early, go back to sleep again.
     */

    Tcl_GetTime(&before);
    after = before;
    after.sec += ms/1000;
    after.usec += (ms%1000)*1000;
    if (after.usec > 1000000) {
	after.usec -= 1000000;
	after.sec += 1;
    }
    while (1) {



	delay.tv_sec = after.sec - before.sec;

	delay.tv_usec = after.usec - before.usec;

	if (delay.tv_usec < 0) {
	    delay.tv_usec += 1000000;
	    delay.tv_sec -= 1;
	}








	/*
	 * Special note:  must convert delay.tv_sec to int before comparing
	 * to zero, since delay.tv_usec is unsigned on some platforms.
	 */

	if ((((int) delay.tv_sec) < 0)
		|| ((delay.tv_usec == 0) && (delay.tv_sec == 0))) {
	    break;
	}
	(void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
		(SELECT_MASK *) 0, &delay);
	Tcl_GetTime(&before);
    }
}















|


|
|
|
<











>
>
>
|
>
|
>
|
|
|


>
>
>
>
>
>
>

|
|











>
>
>
>
>
>
>
>
30
31
32
33
34
35
36
37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
 */

void
Tcl_Sleep(ms)
    int ms;			/* Number of milliseconds to sleep. */
{
    struct timeval delay;
    Tcl_Time before, after, vdelay;

    /*
     * The only trick here is that select appears to return early under some
     * conditions, so we have to check to make sure that the right amount of
     * time really has elapsed.  If it's too early, go back to sleep again.

     */

    Tcl_GetTime(&before);
    after = before;
    after.sec += ms/1000;
    after.usec += (ms%1000)*1000;
    if (after.usec > 1000000) {
	after.usec -= 1000000;
	after.sec += 1;
    }
    while (1) {
	/*
	 * TIP #233: Scale from virtual time to real-time for select.
	 */

	vdelay.sec  = after.sec  - before.sec;
	vdelay.usec = after.usec - before.usec;

	if (vdelay.usec < 0) {
	    vdelay.usec += 1000000;
	    vdelay.sec  -= 1;
	}

	if ((vdelay.sec != 0) || (vdelay.usec != 0)) {
	    (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
	}

	delay.tv_sec  = vdelay.sec;
	delay.tv_usec = vdelay.usec;

	/*
	 * Special note: must convert delay.tv_sec to int before comparing to
	 * zero, since delay.tv_usec is unsigned on some platforms.
	 */

	if ((((int) delay.tv_sec) < 0)
		|| ((delay.tv_usec == 0) && (delay.tv_sec == 0))) {
	    break;
	}
	(void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
		(SELECT_MASK *) 0, &delay);
	Tcl_GetTime(&before);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixFCmd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
/*
 * tclUnixFCmd.c
 *
 *      This file implements the unix specific portion of file manipulation 
 *      subcommands of the "file" command.  All filename arguments should
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40 2004/11/11 01:14:41 das Exp $
 *
 * Portions of this code were derived from NetBSD source code which has
 * the following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *      This product includes software developed by the University of
 *      California, Berkeley and its contributors.
 * 4. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#include "tclInt.h"
#include <utime.h>
#include <grp.h>
#ifndef HAVE_ST_BLKSIZE
#ifndef NO_FSTATFS
#include <sys/statfs.h>
#endif
#endif

/*
 * The following constants specify the type of callback when
 * TraverseUnixTree() calls the traverseProc()
 */

#define DOTREE_PRED   1     /* pre-order directory  */
#define DOTREE_POSTD  2     /* post-order directory */
#define DOTREE_F      3     /* regular file */

/*
 * Callbacks for file attributes code.
 */

static int		GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,



|
|




|
|

|

|
|





|
<
|
|







|
|


|
|
|
|
|
|
|
|

|
|
















|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
/*
 * tclUnixFCmd.c
 *
 *	This file implements the unix specific portion of file manipulation
 *	subcommands of the "file" command.  All filename arguments should
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.5 2005/10/08 13:45:04 dgp Exp $
 *
 * Portions of this code were derived from NetBSD source code which has the
 * following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:

 * 1. Redistributions of source code must retain the above copyright notice,
 *    this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *      This product includes software developed by the University of
 *      California, Berkeley and its contributors.
 * 4. Neither the name of the University nor the names of its contributors may
 *    be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY
 * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
 * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
 * DAMAGE.
 */

#include "tclInt.h"
#include <utime.h>
#include <grp.h>
#ifndef HAVE_ST_BLKSIZE
#ifndef NO_FSTATFS
#include <sys/statfs.h>
#endif
#endif

/*
 * The following constants specify the type of callback when
 * TraverseUnixTree() calls the traverseProc()
 */

#define DOTREE_PRED	1	/* pre-order directory  */
#define DOTREE_POSTD	2	/* post-order directory */
#define DOTREE_F	3	/* regular file */

/*
 * Callbacks for file attributes code.
 */

static int		GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

120


121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
















171
172
173
174
175
176
177

typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr,
	Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type,
	Tcl_DString *errorPtr));

/*
 * Constants and variables necessary for file attributes subcommand.
 * 
 * IMPORTANT: The permissions attribute is assumed to be the third
 * item (i.e. to be indexed with '2' in arrays) in code in tclIOUtil.c
 * and possibly elsewhere in Tcl's core.
 */

#ifdef DJGPP


/*See contrib/djgpp/tclDjgppFCmd.c for definitio*/


extern TclFileAttrProcs tclpFileAttrProcs[];
extern char *tclpFileAttrStrings[];

#else
enum {
    UNIX_GROUP_ATTRIBUTE,
    UNIX_OWNER_ATTRIBUTE,
    UNIX_PERMISSIONS_ATTRIBUTE,
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    UNIX_READONLY_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE,
    MACOSX_TYPE_ATTRIBUTE,
    MACOSX_HIDDEN_ATTRIBUTE,
    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif

};

CONST char *tclpFileAttrStrings[] = {
    "-group",
    "-owner",
    "-permissions",
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    "-readonly",
#endif
#ifdef MAC_OSX_TCL
    "-creator",
    "-type",
    "-hidden",
    "-rsrclength",
#endif
    (char *) NULL
};

CONST TclFileAttrProcs tclpFileAttrProcs[] = {
    {GetGroupAttribute,		SetGroupAttribute},
    {GetOwnerAttribute,		SetOwnerAttribute},
    {GetPermissionsAttribute,	SetPermissionsAttribute},
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    {GetReadOnlyAttribute,	SetReadOnlyAttribute},
#endif
#ifdef MAC_OSX_TCL
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
#endif
};
#endif
















/*
 * Declarations for local procedures defined in this file:
 */

static int		CopyFileAtts _ANSI_ARGS_((CONST char *src,
			    CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int		DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,







|
|
|
|




>
|
>
>





|
<
<




|
<
<


>



|
<
<




|
<
<
<





|
|
|

|









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128


129
130
131
132
133


134
135
136
137
138
139
140


141
142
143
144
145



146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr,
	Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type,
	Tcl_DString *errorPtr));

/*
 * Constants and variables necessary for file attributes subcommand.
 *
 * IMPORTANT: The permissions attribute is assumed to be the third item (i.e.
 * to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly
 * elsewhere in Tcl's core.
 */

#ifdef DJGPP

/*
 * See contrib/djgpp/tclDjgppFCmd.c for definition.
 */

extern TclFileAttrProcs tclpFileAttrProcs[];
extern char *tclpFileAttrStrings[];

#else
enum {
    UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE,


#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    UNIX_READONLY_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,


    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
    UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */
};

CONST char *tclpFileAttrStrings[] = {
    "-group", "-owner", "-permissions",


#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    "-readonly",
#endif
#ifdef MAC_OSX_TCL
    "-creator", "-type", "-hidden", "-rsrclength",



#endif
    (char *) NULL
};

CONST TclFileAttrProcs tclpFileAttrProcs[] = {
    {GetGroupAttribute, SetGroupAttribute},
    {GetOwnerAttribute, SetOwnerAttribute},
    {GetPermissionsAttribute, SetPermissionsAttribute},
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
    {GetReadOnlyAttribute, SetReadOnlyAttribute},
#endif
#ifdef MAC_OSX_TCL
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
#endif
};
#endif

/*
 * This is the maximum number of consecutive readdir/unlink calls that can be
 * made (with no intervening rewinddir or closedir/opendir) before triggering
 * a bug that makes readdir return NULL even though some directory entries
 * have not been processed.  The bug afflicts SunOS's readdir when applied to
 * ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+.  JH found the
 * Darwin readdir to reset at 172, so 150 is chosen to be conservative.  We
 * can't do a general rewind on failure as NFS can create special files that
 * recreate themselves when you try and delete them.  8.4.8 added a solution
 * that was affected by a single such NFS file, this solution should not be
 * affected by less than THRESHOLD such files. [Bug 1034337]
 */

#define MAX_READDIR_UNLINK_THRESHOLD 150

/*
 * Declarations for local procedures defined in this file:
 */

static int		CopyFileAtts _ANSI_ARGS_((CONST char *src,
			    CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int		DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,
190
191
192
193
194
195
196
197
198
199
200
201

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
static int		TraverseUnixTree _ANSI_ARGS_((
			    TraversalProc *traversalProc,
			    Tcl_DString *sourcePtr, Tcl_DString *destPtr,
			    Tcl_DString *errorPtr, int doRewind));

#ifdef PURIFY
/*
 * realpath and purify don't mix happily.  It has been noted that realpath
 * should not be used with purify because of bogus warnings, but just
 * memset'ing the resolved path will squelch those.  This assumes we are
 * passing the standard MAXPATHLEN size resolved arg.
 */

static char *		Realpath _ANSI_ARGS_((CONST char *path,
			    char *resolved));

char *
Realpath(path, resolved)
    CONST char *path;
    char *resolved;
{
    memset(resolved, 0, MAXPATHLEN);
    return realpath(path, resolved);
}
#else
#define Realpath realpath
#endif


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjRenameFile, DoRenameFile --
 *
 *      Changes the name of an existing file or directory, from src to dst.
 *	If src and dst refer to the same file or directory, does nothing
 *	and returns success.  Otherwise if dst already exists, it will be
 *	deleted and replaced by src subject to the following conditions:
 *	    If src is a directory, dst may be an empty directory.
 *	    If src is a file, dst may be a file.
 *	In any other situation where dst already exists, the rename will
 *	fail.  
 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR and errno is set to
 *	indicate the error.  Some possible values for errno are:
 *
 *	EACCES:     src or dst parent directory can't be read and/or written.
 *	EEXIST:	    dst is a non-empty directory.
 *	EINVAL:	    src is a root directory or dst is a subdirectory of src.
 *	EISDIR:	    dst is a directory, but src is not.
 *	ENOENT:	    src doesn't exist, or src or dst is "".
 *	ENOTDIR:    src is a directory, but dst is not.  
 *	EXDEV:	    src and dst are on different filesystems.
 *	
 * Side effects:
 *	The implementation of rename may allow cross-filesystem renames,
 *	but the caller should be prepared to emulate it with copy and
 *	delete if errno is EXDEV.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjRenameFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 
			Tcl_FSGetNativePath(destPathPtr));
}

static int
DoRenameFile(src, dst)
    CONST char *src;		/* Pathname of file or dir to be renamed
				 * (native). */
    CONST char *dst;		/* New pathname of file or directory
				 * (native). */
{
    if (rename(src, dst) == 0) {			/* INTL: Native. */
	return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
	errno = EEXIST;
    }

    /*
     * IRIX returns EIO when you attept to move a directory into
     * itself.  We just map EIO to EINVAL get the right message on SGI.
     * Most platforms don't return EIO except in really strange cases.
     */
    
    if (errno == EIO) {
	errno = EINVAL;
    }
    
#ifndef NO_REALPATH
    /*
     * SunOS 4.1.4 reports overwriting a non-empty directory with a
     * directory as EINVAL instead of EEXIST (first rule out the correct
     * EINVAL result code for moving a directory into itself).  Must be
     * conditionally compiled because realpath() not defined on all systems.
     */

    if (errno == EINVAL) {
	char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
	DIR *dirPtr;
	Tcl_DirEntry *dirEntPtr;

	if ((Realpath((char *) src, srcPath) != NULL)	/* INTL: Native. */
		&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
		&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
	    dirPtr = opendir(dst);			/* INTL: Native. */
	    if (dirPtr != NULL) {
		while (1) {
		    dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
		    if (dirEntPtr == NULL) {
			break;
		    }
		    if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
			    (strcmp(dirEntPtr->d_name, "..") != 0)) {
			errno = EEXIST;
			closedir(dirPtr);







|

|


>














<






|
|
|
|


|
<


|
|
|

|




|

|

|
|
|




|




|
|

















|
|
|

|



|


|
|
|
|








|




|







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226

227
228
229
230
231
232
233
234
235
236
237
238
239

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
static int		TraverseUnixTree _ANSI_ARGS_((
			    TraversalProc *traversalProc,
			    Tcl_DString *sourcePtr, Tcl_DString *destPtr,
			    Tcl_DString *errorPtr, int doRewind));

#ifdef PURIFY
/*
 * realpath and purify don't mix happily. It has been noted that realpath
 * should not be used with purify because of bogus warnings, but just
 * memset'ing the resolved path will squelch those. This assumes we are
 * passing the standard MAXPATHLEN size resolved arg.
 */

static char *		Realpath _ANSI_ARGS_((CONST char *path,
			    char *resolved));

char *
Realpath(path, resolved)
    CONST char *path;
    char *resolved;
{
    memset(resolved, 0, MAXPATHLEN);
    return realpath(path, resolved);
}
#else
#define Realpath realpath
#endif


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjRenameFile, DoRenameFile --
 *
 *	Changes the name of an existing file or directory, from src to dst.
 *	If src and dst refer to the same file or directory, does nothing and
 *	returns success. Otherwise if dst already exists, it will be deleted
 *	and replaced by src subject to the following conditions:
 *	    If src is a directory, dst may be an empty directory.
 *	    If src is a file, dst may be a file.
 *	In any other situation where dst already exists, the rename will fail.

 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK.  Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    src or dst parent directory can't be read and/or written.
 *	EEXIST:	    dst is a non-empty directory.
 *	EINVAL:	    src is a root directory or dst is a subdirectory of src.
 *	EISDIR:	    dst is a directory, but src is not.
 *	ENOENT:	    src doesn't exist, or src or dst is "".
 *	ENOTDIR:    src is a directory, but dst is not.
 *	EXDEV:	    src and dst are on different filesystems.
 *
 * Side effects:
 *	The implementation of rename may allow cross-filesystem renames, but
 *	the caller should be prepared to emulate it with copy and delete if
 *	errno is EXDEV.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjRenameFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
	    Tcl_FSGetNativePath(destPathPtr));
}

static int
DoRenameFile(src, dst)
    CONST char *src;		/* Pathname of file or dir to be renamed
				 * (native). */
    CONST char *dst;		/* New pathname of file or directory
				 * (native). */
{
    if (rename(src, dst) == 0) {			/* INTL: Native. */
	return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
	errno = EEXIST;
    }

    /*
     * IRIX returns EIO when you attept to move a directory into itself. We
     * just map EIO to EINVAL get the right message on SGI. Most platforms
     * don't return EIO except in really strange cases.
     */

    if (errno == EIO) {
	errno = EINVAL;
    }

#ifndef NO_REALPATH
    /*
     * SunOS 4.1.4 reports overwriting a non-empty directory with a directory
     * as EINVAL instead of EEXIST (first rule out the correct EINVAL result
     * code for moving a directory into itself). Must be conditionally
     * compiled because realpath() not defined on all systems.
     */

    if (errno == EINVAL) {
	char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
	DIR *dirPtr;
	Tcl_DirEntry *dirEntPtr;

	if ((Realpath((char *) src, srcPath) != NULL)	/* INTL: Native. */
		&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native */
		&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
	    dirPtr = opendir(dst);			/* INTL: Native. */
	    if (dirPtr != NULL) {
		while (1) {
		    dirEntPtr = TclOSreaddir(dirPtr);	/* INTL: Native. */
		    if (dirEntPtr == NULL) {
			break;
		    }
		    if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
			    (strcmp(dirEntPtr->d_name, "..") != 0)) {
			errno = EEXIST;
			closedir(dirPtr);
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500






501
502
503
504
505
506

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
#endif	/* !NO_REALPATH */

    if (strcmp(src, "/") == 0) {
	/*
	 * Alpha reports renaming / as EBUSY and Linux reports it as EACCES,
	 * instead of EINVAL.
	 */
	 
	errno = EINVAL;
    }

    /*
     * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a
     * file across filesystems and the parent directory of that file is
     * not writable.  Most other systems return EXDEV.  Does nothing to
     * correct this behavior.
     */

    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyFile, DoCopyFile --
 *
 *      Copy a single file (not a directory).  If dst already exists and
 *	is not a directory, it is removed.
 *
 * Results:
 *	If the file was successfully copied, returns TCL_OK.  Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the
 *	error.  Some possible values for errno are:
 *
 *	EACCES:     src or dst parent directory can't be read and/or written.
 *	EISDIR:	    src or dst is a directory.
 *	ENOENT:	    src doesn't exist.  src or dst is "".
 *
 * Side effects:
 *      This procedure will also copy symbolic links, block, and
 *      character devices, and fifos.  For symbolic links, the links 
 *      themselves will be copied and not what they point to.  For the
 *	other special file types, the directory entry will be copied and
 *	not the contents of the device that it refers to.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), 
		      Tcl_FSGetNativePath(destPathPtr));
}

static int
DoCopyFile(src, dst)
    CONST char *src;	/* Pathname of file to be copied (native). */
    CONST char *dst;	/* Pathname of file to copy to (native). */
{
    Tcl_StatBuf srcStatBuf, dstStatBuf;

    /*
     * Have to do a stat() to determine the filetype.
     */
    
    if (TclOSlstat(src, &srcStatBuf) != 0) {		/* INTL: Native. */
	return TCL_ERROR;
    }
    if (S_ISDIR(srcStatBuf.st_mode)) {
	errno = EISDIR;
	return TCL_ERROR;
    }

    /*
     * symlink, and some of the other calls will fail if the target 
     * exists, so we remove it first
     */
    
    if (TclOSlstat(dst, &dstStatBuf) == 0) {		/* INTL: Native. */
	if (S_ISDIR(dstStatBuf.st_mode)) {
	    errno = EISDIR;
	    return TCL_ERROR;
	}
    }
    if (unlink(dst) != 0) {				/* INTL: Native. */
	if (errno != ENOENT) {
	    return TCL_ERROR;
	} 
    }

    switch ((int) (srcStatBuf.st_mode & S_IFMT)) {
#ifndef DJGPP
        case S_IFLNK: {
	    char link[MAXPATHLEN];
	    int length;

	    length = readlink(src, link, sizeof(link)); /* INTL: Native. */
	    if (length == -1) {
		return TCL_ERROR;
	    }
	    link[length] = '\0';
	    if (symlink(link, dst) < 0) {		/* INTL: Native. */
		return TCL_ERROR;
	    }
	    break;
	}
#endif
        case S_IFBLK:
        case S_IFCHR: {
	    if (mknod(dst, srcStatBuf.st_mode,		/* INTL: Native. */
		    srcStatBuf.st_rdev) < 0) {
		return TCL_ERROR;
	    }
	    return CopyFileAtts(src, dst, &srcStatBuf);
	}
        case S_IFIFO: {
	    if (mkfifo(dst, srcStatBuf.st_mode) < 0) {	/* INTL: Native. */
		return TCL_ERROR;
	    }
	    return CopyFileAtts(src, dst, &srcStatBuf);
	}
        default: {
	    return TclUnixCopyFile(src, dst, &srcStatBuf, 0);
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnixCopyFile - 
 *
 *      Helper function for TclpCopyFile.  Copies one regular file,
 *	using read() and write().
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *      A file is copied.  Dst will be overwritten if it exists.
 *
 *----------------------------------------------------------------------
 */

int 
TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) 
    CONST char *src;		/* Pathname of file to copy (native). */
    CONST char *dst;		/* Pathname of file to create/overwrite
				 * (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Used to determine mode and blocksize. */
    int dontCopyAtts;		/* if flag set, don't copy attributes. */
{
    int srcFd;
    int dstFd;
    u_int blockSize;   /* Optimal I/O blocksize for filesystem */
    char *buffer;      /* Data buffer for copy */
    size_t nread;

#ifdef DJGPP
#define BINMODE |O_BINARY
#else
#define BINMODE
#endif

    if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) {	/* INTL: Native. */
	return TCL_ERROR;
    }

    dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE,	/* INTL: Native. */
	    statBufPtr->st_mode);
    if (dstFd < 0) {
	close(srcFd); 
	return TCL_ERROR;
    }







#ifdef HAVE_ST_BLKSIZE
    blockSize = statBufPtr->st_blksize;
#else
#ifndef NO_FSTATFS
    {
	struct statfs fs;

	if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) {
	    blockSize = fs.f_bsize;
	} else {
	    blockSize = 4096;
	}
    }
#else 
    blockSize = 4096;
#endif
#endif

    buffer = ckalloc(blockSize);
    while (1) {
	nread = read(srcFd, buffer, blockSize);
	if ((nread == -1) || (nread == 0)) {
	    break;
	}
	if (write(dstFd, buffer, nread) != nread) {
	    nread = (size_t) -1;
	    break;
	}
    }
	
    ckfree(buffer);
    close(srcFd);
    if ((close(dstFd) != 0) || (nread == -1)) {
	unlink(dst);					/* INTL: Native. */
	return TCL_ERROR;
    }
    if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
	/*
	 * The copy succeeded, but setting the permissions failed, so be in
	 * a consistent state, we remove the file that was created by the
	 * copy.
	 */

	unlink(dst);					/* INTL: Native. */
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjDeleteFile, TclpDeleteFile --
 *
 *      Removes a single file (not a directory).
 *
 * Results:
 *	If the file was successfully deleted, returns TCL_OK.  Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the
 *	error.  Some possible values for errno are:
 *
 *	EACCES:     a parent directory can't be read and/or written.
 *	EISDIR:	    path is a directory.
 *	ENOENT:	    path doesn't exist or is "".
 *
 * Side effects:
 *      The file is deleted, even if it is read-only.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjDeleteFile(pathPtr)
    Tcl_Obj *pathPtr;
{
    return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
}

int
TclpDeleteFile(path)
    CONST char *path;	/* Pathname of file to be removed (native). */
{
    if (unlink(path) != 0) {				/* INTL: Native. */
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpCreateDirectory, DoCreateDirectory --
 *
 *      Creates the specified directory.  All parent directories of the
 *	specified directory must already exist.  The directory is
 *	automatically created with permissions so that user can access
 *	the new directory and create new files or subdirectories in it.
 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR and errno is set to
 *	indicate the error.  Some possible values for errno are:
 *
 *	EACCES:     a parent directory can't be read and/or written.
 *	EEXIST:	    path already exists.
 *	ENOENT:	    a parent directory doesn't exist.
 *
 * Side effects:
 *      A directory is created with the current umask, except that
 *	permission for u+rwx will always be added.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCreateDirectory(pathPtr)
    Tcl_Obj *pathPtr;
{
    return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}

static int







|




|
|
|
|










|
|


|
|
|

|




|
|
|
|
|




|




|
|




|
|






|









|
|

|









|




|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
<
|
|
|
|
|
<
|
|
<







|

|
|





|




|
|





|

|
<
|
|








|



|


|



>
>
>
>
>
>






>






|















|








|
|
<













|


|
|
|

|




|




|








|












|
|
|
|


|
|
|

|




|
|




|







330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446

447
448
449
450
451

452
453

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484

485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551

552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
#endif	/* !NO_REALPATH */

    if (strcmp(src, "/") == 0) {
	/*
	 * Alpha reports renaming / as EBUSY and Linux reports it as EACCES,
	 * instead of EINVAL.
	 */

	errno = EINVAL;
    }

    /*
     * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a file
     * across filesystems and the parent directory of that file is not
     * writable. Most other systems return EXDEV. Does nothing to correct this
     * behavior.
     */

    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyFile, DoCopyFile --
 *
 *	Copy a single file (not a directory). If dst already exists and is not
 *	a directory, it is removed.
 *
 * Results:
 *	If the file was successfully copied, returns TCL_OK. Otherwise the
 *	return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    src or dst parent directory can't be read and/or written.
 *	EISDIR:	    src or dst is a directory.
 *	ENOENT:	    src doesn't exist.  src or dst is "".
 *
 * Side effects:
 *	This procedure will also copy symbolic links, block, and character
 *	devices, and fifos. For symbolic links, the links themselves will be
 *	copied and not what they point to. For the other special file types,
 *	the directory entry will be copied and not the contents of the device
 *	that it refers to.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
	    Tcl_FSGetNativePath(destPathPtr));
}

static int
DoCopyFile(src, dst)
    CONST char *src;		/* Pathname of file to be copied (native). */
    CONST char *dst;		/* Pathname of file to copy to (native). */
{
    Tcl_StatBuf srcStatBuf, dstStatBuf;

    /*
     * Have to do a stat() to determine the filetype.
     */

    if (TclOSlstat(src, &srcStatBuf) != 0) {		/* INTL: Native. */
	return TCL_ERROR;
    }
    if (S_ISDIR(srcStatBuf.st_mode)) {
	errno = EISDIR;
	return TCL_ERROR;
    }

    /*
     * symlink, and some of the other calls will fail if the target exists, so
     * we remove it first.
     */

    if (TclOSlstat(dst, &dstStatBuf) == 0) {		/* INTL: Native. */
	if (S_ISDIR(dstStatBuf.st_mode)) {
	    errno = EISDIR;
	    return TCL_ERROR;
	}
    }
    if (unlink(dst) != 0) {				/* INTL: Native. */
	if (errno != ENOENT) {
	    return TCL_ERROR;
	}
    }

    switch ((int) (srcStatBuf.st_mode & S_IFMT)) {
#ifndef DJGPP
    case S_IFLNK: {
	char link[MAXPATHLEN];
	int length;

	length = readlink(src, link, sizeof(link));	/* INTL: Native. */
	if (length == -1) {
	    return TCL_ERROR;
	}
	link[length] = '\0';
	if (symlink(link, dst) < 0) {			/* INTL: Native. */
	    return TCL_ERROR;
	}
	break;
    }
#endif
    case S_IFBLK:
    case S_IFCHR:
	if (mknod(dst, srcStatBuf.st_mode,		/* INTL: Native. */
		srcStatBuf.st_rdev) < 0) {
	    return TCL_ERROR;
	}
	return CopyFileAtts(src, dst, &srcStatBuf);

    case S_IFIFO:
	if (mkfifo(dst, srcStatBuf.st_mode) < 0) {	/* INTL: Native. */
	    return TCL_ERROR;
	}
	return CopyFileAtts(src, dst, &srcStatBuf);

    default:
	return TclUnixCopyFile(src, dst, &srcStatBuf, 0);

    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnixCopyFile -
 *
 *	Helper function for TclpCopyFile. Copies one regular file, using
 *	read() and write().
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	A file is copied.  Dst will be overwritten if it exists.
 *
 *----------------------------------------------------------------------
 */

int
TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts)
    CONST char *src;		/* Pathname of file to copy (native). */
    CONST char *dst;		/* Pathname of file to create/overwrite
				 * (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Used to determine mode and blocksize. */
    int dontCopyAtts;		/* If flag set, don't copy attributes. */
{
    int srcFd, dstFd;

    unsigned blockSize;		/* Optimal I/O blocksize for filesystem */
    char *buffer;		/* Data buffer for copy */
    size_t nread;

#ifdef DJGPP
#define BINMODE |O_BINARY
#else
#define BINMODE
#endif

    if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native */
	return TCL_ERROR;
    }

    dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native */
	    statBufPtr->st_mode);
    if (dstFd < 0) {
	close(srcFd);
	return TCL_ERROR;
    }

    /*
     * Try to work out the best size of buffer to use for copying. If we
     * can't, it's no big deal as we can just use a (32-bit) page, since
     * that's likely to be fairly efficient anyway.
     */

#ifdef HAVE_ST_BLKSIZE
    blockSize = statBufPtr->st_blksize;
#else
#ifndef NO_FSTATFS
    {
	struct statfs fs;

	if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) {
	    blockSize = fs.f_bsize;
	} else {
	    blockSize = 4096;
	}
    }
#else
    blockSize = 4096;
#endif
#endif

    buffer = ckalloc(blockSize);
    while (1) {
	nread = read(srcFd, buffer, blockSize);
	if ((nread == -1) || (nread == 0)) {
	    break;
	}
	if (write(dstFd, buffer, nread) != nread) {
	    nread = (size_t) -1;
	    break;
	}
    }

    ckfree(buffer);
    close(srcFd);
    if ((close(dstFd) != 0) || (nread == -1)) {
	unlink(dst);					/* INTL: Native. */
	return TCL_ERROR;
    }
    if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
	/*
	 * The copy succeeded, but setting the permissions failed, so be in a
	 * consistent state, we remove the file that was created by the copy.

	 */

	unlink(dst);					/* INTL: Native. */
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjDeleteFile, TclpDeleteFile --
 *
 *	Removes a single file (not a directory).
 *
 * Results:
 *	If the file was successfully deleted, returns TCL_OK. Otherwise the
 *	return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    a parent directory can't be read and/or written.
 *	EISDIR:	    path is a directory.
 *	ENOENT:	    path doesn't exist or is "".
 *
 * Side effects:
 *	The file is deleted, even if it is read-only.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjDeleteFile(pathPtr)
    Tcl_Obj *pathPtr;
{
    return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
}

int
TclpDeleteFile(path)
    CONST char *path;		/* Pathname of file to be removed (native). */
{
    if (unlink(path) != 0) {				/* INTL: Native. */
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpCreateDirectory, DoCreateDirectory --
 *
 *	Creates the specified directory. All parent directories of the
 *	specified directory must already exist. The directory is automatically
 *	created with permissions so that user can access the new directory and
 *	create new files or subdirectories in it.
 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    a parent directory can't be read and/or written.
 *	EEXIST:	    path already exists.
 *	ENOENT:	    a parent directory doesn't exist.
 *
 * Side effects:
 *	A directory is created with the current umask, except that permission
 *	for u+rwx will always be added.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCreateDirectory(pathPtr)
    Tcl_Obj *pathPtr;
{
    return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}

static int
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *      Recursively copies a directory.  The target directory dst must
 *	not already exist.  Note that this function does not merge two
 *	directory hierarchies, even if the target directory is an an
 *	empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR, errno is set to indicate
 *	the error, and the pathname of the file that caused the error
 *	is stored in errorPtr.  See TclpObjCreateDirectory and 
 *	TclpObjCopyFile for a description of possible values for errno.
 *
 * Side effects:
 *      An exact copy of the directory hierarchy src will be created
 *	with the name dst.  If an error occurs, the error will
 *      be returned immediately, and remaining files will not be
 *	processed.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_DString srcString, dstString;
    int ret;
    Tcl_Obj *transPtr;
    
    transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr);
    Tcl_UtfToExternalDString(NULL, 
			     (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), 
			     -1, &srcString);
    if (transPtr != NULL) {
	Tcl_DecrRefCount(transPtr);
    }
    transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr);
    Tcl_UtfToExternalDString(NULL, 
			     (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), 
			     -1, &dstString);
    if (transPtr != NULL) {
	Tcl_DecrRefCount(transPtr);
    }

    ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);

    Tcl_DStringFree(&srcString);







|
|
|
<


|
|
|
|
|


|
|
|
<




|









|

|
|
|




|
|
|







651
652
653
654
655
656
657
658
659
660

661
662
663
664
665
666
667
668
669
670
671
672

673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an an empty directory.

 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpObjCreateDirectory and TclpObjCopyFile for a description of
 *	possible values for errno.
 *
 * Side effects:
 *	An exact copy of the directory hierarchy src will be created with the
 *	name dst. If an error occurs, the error will be returned immediately,
 *	and remaining files will not be processed.

 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_DString srcString, dstString;
    int ret;
    Tcl_Obj *transPtr;

    transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr);
    Tcl_UtfToExternalDString(NULL,
	    (transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
	    -1, &srcString);
    if (transPtr != NULL) {
	Tcl_DecrRefCount(transPtr);
    }
    transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr);
    Tcl_UtfToExternalDString(NULL,
	    (transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
	    -1, &dstString);
    if (transPtr != NULL) {
	Tcl_DecrRefCount(transPtr);
    }

    ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);

    Tcl_DStringFree(&srcString);
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779

780


781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816

817


818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861

862
863
864
865
866
867
868
869
870
871
872
873
874
 *---------------------------------------------------------------------------
 *
 * TclpRemoveDirectory, DoRemoveDirectory --
 *
 *	Removes directory (and its contents, if the recursive flag is set).
 *
 * Results:
 *	If the directory was successfully removed, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR, errno is set to indicate
 *	the error, and the pathname of the file that caused the error
 *	is stored in errorPtr.  Some possible values for errno are:
 *
 *	EACCES:     path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is a root directory.
 *	ENOENT:	    path doesn't exist or is "".
 * 	ENOTDIR:    path is not a directory.
 *
 * Side effects:
 *	Directory removed.  If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *---------------------------------------------------------------------------
 */
 
int 
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_Obj *pathPtr;
    int recursive;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_DString pathString;
    int ret;
    Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);

    Tcl_UtfToExternalDString(NULL, 
			     (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), 
			     -1, &pathString);
    if (transPtr != NULL) {
	Tcl_DecrRefCount(transPtr);
    }
    ret = DoRemoveDirectory(&pathString, recursive, &ds);
    Tcl_DStringFree(&pathString);

    if (ret != TCL_OK) {
	*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	Tcl_DStringFree(&ds);
	Tcl_IncrRefCount(*errorPtr);
    }
    return ret;
}

static int
DoRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_DString *pathPtr;	/* Pathname of directory to be removed
				 * (native). */
    int recursive;		/* If non-zero, removes directories that
				 * are nonempty.  Otherwise, will only remove
				 * empty directories. */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    CONST char *path;
    mode_t oldPerm = 0;
    int result;
    
    path = Tcl_DStringValue(pathPtr);
    
    if (recursive != 0) {

	/* We should try to change permissions so this can be deleted */


	Tcl_StatBuf statBuf;
	int newPerm;

	if (TclOSstat(path, &statBuf) == 0) {
	    oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
	}
	
	newPerm = oldPerm | (64+128+256);
	chmod(path, (mode_t) newPerm);
    }
    
    if (rmdir(path) == 0) {				/* INTL: Native. */
	return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
	errno = EEXIST;
    }

    result = TCL_OK;
    if ((errno != EEXIST) || (recursive == 0)) {
	if (errorPtr != NULL) {
	    Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
	}
	result = TCL_ERROR;
    }
    
    /*
     * The directory is nonempty, but the recursive flag has been
     * specified, so we recursively remove all the files in the directory.
     */

    if (result == TCL_OK) {
	result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1);
    }
    
    if ((result != TCL_OK) && (recursive != 0)) {

        /* Try to restore permissions */


        chmod(path, oldPerm);
    }
    return result;
}
	
/*
 *---------------------------------------------------------------------------
 *
 * TraverseUnixTree --
 *
 *      Traverse directory tree specified by sourcePtr, calling the function 
 *	traverseProc for each file and directory encountered.  If destPtr 
 *	is non-null, each of name in the sourcePtr directory is appended to 
 *	the directory specified by destPtr and passed as the second argument 
 *	to traverseProc() .
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      None caused by TraverseUnixTree, however the user specified 
 *	traverseProc() may change state.  If an error occurs, the error will
 *      be returned immediately, and remaining files will not be processed.
 *
 *---------------------------------------------------------------------------
 */

static int 
TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind)
    TraversalProc *traverseProc;/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr;	/* Pathname of source directory to be
				 * traversed (native). */
    Tcl_DString *targetPtr;	/* Pathname of directory to traverse in
				 * parallel with source directory (native). */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
    int doRewind;		/* Flag indicating that to ensure complete
    				 * traversal of source hierarchy, the readdir
    				 * loop should be rewound whenever
    				 * traverseProc has returned TCL_OK; this is
    				 * required when traverseProc modifies the
    				 * source hierarchy, e.g. by deleting files. */ 

{
    Tcl_StatBuf statBuf;
    CONST char *source, *errfile;
    int result, sourceLen;
    int targetLen;
    int needRewind;
    Tcl_DirEntry *dirEntPtr;
    DIR *dirPtr;

    errfile = NULL;
    result = TCL_OK;
    targetLen = 0;		/* lint. */








|
|
|
|

|






|




|
|










|
|
|


















|
|
|
|
|
|




|

|

>
|
>
>






|



|














|

|
|





|

>
|
>
>
|



|





|
|
|
|
|


|


|
|
|




|







|
|
|





|
>





|







718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
 *---------------------------------------------------------------------------
 *
 * TclpRemoveDirectory, DoRemoveDirectory --
 *
 *	Removes directory (and its contents, if the recursive flag is set).
 *
 * Results:
 *	If the directory was successfully removed, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	Some possible values for errno are:
 *
 *	EACCES:	    path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is a root directory.
 *	ENOENT:	    path doesn't exist or is "".
 * 	ENOTDIR:    path is not a directory.
 *
 * Side effects:
 *	Directory removed. If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_Obj *pathPtr;
    int recursive;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_DString pathString;
    int ret;
    Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);

    Tcl_UtfToExternalDString(NULL,
	    (transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
	    -1, &pathString);
    if (transPtr != NULL) {
	Tcl_DecrRefCount(transPtr);
    }
    ret = DoRemoveDirectory(&pathString, recursive, &ds);
    Tcl_DStringFree(&pathString);

    if (ret != TCL_OK) {
	*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	Tcl_DStringFree(&ds);
	Tcl_IncrRefCount(*errorPtr);
    }
    return ret;
}

static int
DoRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_DString *pathPtr;	/* Pathname of directory to be removed
				 * (native). */
    int recursive;		/* If non-zero, removes directories that are
				 * nonempty. Otherwise, will only remove empty
				 * directories. */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    CONST char *path;
    mode_t oldPerm = 0;
    int result;

    path = Tcl_DStringValue(pathPtr);

    if (recursive != 0) {
	/*
	 * We should try to change permissions so this can be deleted.
	 */

	Tcl_StatBuf statBuf;
	int newPerm;

	if (TclOSstat(path, &statBuf) == 0) {
	    oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
	}

	newPerm = oldPerm | (64+128+256);
	chmod(path, (mode_t) newPerm);
    }

    if (rmdir(path) == 0) {				/* INTL: Native. */
	return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
	errno = EEXIST;
    }

    result = TCL_OK;
    if ((errno != EEXIST) || (recursive == 0)) {
	if (errorPtr != NULL) {
	    Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
	}
	result = TCL_ERROR;
    }

    /*
     * The directory is nonempty, but the recursive flag has been specified,
     * so we recursively remove all the files in the directory.
     */

    if (result == TCL_OK) {
	result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1);
    }

    if ((result != TCL_OK) && (recursive != 0)) {
	/*
	 * Try to restore permissions.
	 */

	chmod(path, oldPerm);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TraverseUnixTree --
 *
 *	Traverse directory tree specified by sourcePtr, calling the function
 *	traverseProc for each file and directory encountered. If destPtr is
 *	non-null, each of name in the sourcePtr directory is appended to the
 *	directory specified by destPtr and passed as the second argument to
 *	traverseProc().
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	None caused by TraverseUnixTree, however the user specified
 *	traverseProc() may change state. If an error occurs, the error will be
 *	returned immediately, and remaining files will not be processed.
 *
 *---------------------------------------------------------------------------
 */

static int
TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind)
    TraversalProc *traverseProc;/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr;	/* Pathname of source directory to be
				 * traversed (native). */
    Tcl_DString *targetPtr;	/* Pathname of directory to traverse in
				 * parallel with source directory (native). */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
    int doRewind;		/* Flag indicating that to ensure complete
    				 * traversal of source hierarchy, the readdir
    				 * loop should be rewound whenever
    				 * traverseProc has returned TCL_OK; this is
    				 * required when traverseProc modifies the
    				 * source hierarchy, e.g. by deleting
    				 * files. */
{
    Tcl_StatBuf statBuf;
    CONST char *source, *errfile;
    int result, sourceLen;
    int targetLen;
    int numProcessed = 0;
    Tcl_DirEntry *dirEntPtr;
    DIR *dirPtr;

    errfile = NULL;
    result = TCL_OK;
    targetLen = 0;		/* lint. */

883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947





948

949
950

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970

971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310


1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
	 */

	return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F,
		errorPtr);
    }
    dirPtr = opendir(source);				/* INTL: Native. */
    if (dirPtr == NULL) {
	/* 
	 * Can't read directory
	 */

	errfile = source;
	goto end;
    }
    result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
	    errorPtr);
    if (result != TCL_OK) {
	closedir(dirPtr);
	return result;
    }
    
    Tcl_DStringAppend(sourcePtr, "/", 1);
    sourceLen = Tcl_DStringLength(sourcePtr);	

    if (targetPtr != NULL) {
	Tcl_DStringAppend(targetPtr, "/", 1);
	targetLen = Tcl_DStringLength(targetPtr);
    }

    do {
	needRewind = 0;
	while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
	    if ((dirEntPtr->d_name[0] == '.')
		    && ((dirEntPtr->d_name[1] == '\0')
			    || (strcmp(dirEntPtr->d_name, "..") == 0))) {
		continue;
	    }
	    
	    /* 
	     * Append name after slash, and recurse on the file.
	     */
	    
	    Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1);
	    if (targetPtr != NULL) {
		Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1);
	    }
	    result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
		    errorPtr, doRewind);
	    if (result != TCL_OK) {
	    	needRewind = 0;
		break;
	    } else {
		needRewind = doRewind;
	    }
	    
	    /*
	     * Remove name after slash.
	     */
	    
	    Tcl_DStringSetLength(sourcePtr, sourceLen);
	    if (targetPtr != NULL) {
		Tcl_DStringSetLength(targetPtr, targetLen);
	    }
	}
	if (needRewind) {





	    rewinddir(dirPtr);

	}
    } while (needRewind);

    closedir(dirPtr);
    
    /*
     * Strip off the trailing slash we added
     */

    Tcl_DStringSetLength(sourcePtr, sourceLen - 1);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, targetLen - 1);
    }

    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the
	 * files in that directory.
	 */

	result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD,
		errorPtr);
    }

    end:
    if (errfile != NULL) {
	if (errorPtr != NULL) {
	    Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr);
	}
	result = TCL_ERROR;
    }
	    
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *      Called from TraverseUnixTree in order to execute a recursive copy
 *      of a directory.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      The file or directory src may be copied to dst, depending on 
 *      the value of type.
 *      
 *----------------------------------------------------------------------
 */

static int 
TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) 
    Tcl_DString *srcPtr;	/* Source pathname to copy (native). */
    Tcl_DString *dstPtr;	/* Destination pathname of copy (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for file specified by srcPtr. */
    int type;                   /* Reason for call - see TraverseUnixTree(). */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    switch (type) {
	case DOTREE_F:
	    if (DoCopyFile(Tcl_DStringValue(srcPtr), 
		    Tcl_DStringValue(dstPtr)) == TCL_OK) {
		return TCL_OK;
	    }
	    break;

	case DOTREE_PRED:
	    if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
		return TCL_OK;
	    }
	    break;

	case DOTREE_POSTD:
	    if (CopyFileAtts(Tcl_DStringValue(srcPtr),
		    Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) {
		return TCL_OK;
	    }
	    break;

    }

    /*
     * There shouldn't be a problem with src, because we already checked it
     * to get here.
     */

    if (errorPtr != NULL) {
	Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr),
		Tcl_DStringLength(dstPtr), errorPtr);
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TraversalDelete --
 *
 *      Called by procedure TraverseUnixTree for every file and directory
 *	that it encounters in a directory hierarchy. This procedure unlinks
 *      files, and removes directories after all the containing files 
 *      have been processed.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      Files or directory specified by src will be deleted.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) 
    Tcl_DString *srcPtr;	/* Source pathname (native). */
    Tcl_DString *ignore;	/* Destination pathname (not used). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for file specified by srcPtr. */
    int type;                   /* Reason for call - see TraverseUnixTree(). */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    switch (type) {
        case DOTREE_F: {
	    if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
		return TCL_OK;
	    }
	    break;
	}
        case DOTREE_PRED: {
	    return TCL_OK;
	}
        case DOTREE_POSTD: {
	    if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) {
		return TCL_OK;
	    }
	    break;
	}	    
    }
    if (errorPtr != NULL) {
	Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr),
		Tcl_DStringLength(srcPtr), errorPtr);
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * CopyFileAtts --
 *
 *	Copy the file attributes such as owner, group, permissions,
 *	and modification date from one file to another.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	user id, group id, permission bits, last modification time, and
 *	last access time are updated in the new file to reflect the
 *	old file.
 *
 *---------------------------------------------------------------------------
 */

static int
CopyFileAtts(src, dst, statBufPtr) 
    CONST char *src;		/* Path name of source file (native). */
    CONST char *dst;		/* Path name of target file (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for source file */
{
    struct utimbuf tval;
    mode_t newMode;
    
    newMode = statBufPtr->st_mode
	    & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO);
	
    /* 
     * Note that if you copy a setuid file that is owned by someone
     * else, and you are not root, then the copy will be setuid to you.
     * The most correct implementation would probably be to have the
     * copy not setuid to anyone if the original file was owned by 
     * someone else, but this corner case isn't currently handled.
     * It would require another lstat(), or getuid().
     */
    
    if (chmod(dst, newMode)) {				/* INTL: Native. */
	newMode &= ~(S_ISUID | S_ISGID);
	if (chmod(dst, newMode)) {			/* INTL: Native. */
	    return TCL_ERROR;
	}
    }

    tval.actime = statBufPtr->st_atime; 
    tval.modtime = statBufPtr->st_mtime; 

    if (utime(dst, &tval)) {				/* INTL: Native. */
	return TCL_ERROR;
    }
#ifdef MAC_OSX_TCL
    TclMacOSXCopyFileAttributes(src, dst, statBufPtr);
#endif
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * GetGroupAttribute
 *
 *      Gets the group attribute of a file.
 *
 * Results:
 *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *	if there is no error.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

static int
GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;  	/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    struct group *groupPtr;
    int result;

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"", 
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    groupPtr = getgrgid(statBuf.st_gid);		/* INTL: Native. */
    if (groupPtr == NULL) {
	*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
    } else {
	Tcl_DString ds;
	CONST char *utf;

	utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); 
	*attributePtrPtr = Tcl_NewStringObj(utf, -1);
	Tcl_DStringFree(&ds);
    }
    endgrent();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetOwnerAttribute
 *
 *      Gets the owner attribute of a file.
 *
 * Results:
 *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *	if there is no error.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

static int
GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;  	/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    struct passwd *pwPtr;
    int result;

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"", 
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    pwPtr = getpwuid(statBuf.st_uid);			/* INTL: Native. */
    if (pwPtr == NULL) {
	*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
    } else {
	Tcl_DString ds;
	CONST char *utf;

	utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); 
	*attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
    }
    endpwent();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetPermissionsAttribute
 *
 *      Gets the group attribute of a file.
 *
 * Results:
 *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *	if there is no error. The object will have ref count 0.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

static int
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    char returnString[7];
    int result;

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"", 
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));

    *attributePtrPtr = Tcl_NewStringObj(returnString, -1);


    
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetGroupAttribute --
 *
 *      Sets the group of the file to the specified group.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      As above.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetGroupAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		    /* The interp for error reporting. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;	            /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	    /* New group for file. */
{
    long gid;
    int result;
    CONST char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
	Tcl_DString ds;







|












|

|






<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
>
>
>
>

>

<
>

|











|
|





>
|






|








|
|


|


|
|
|



|
|




|
|
|
|


|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
|
|
<

|
|














|
|
|
|


|


|





|




|
|
|
|


|
|
|
|
|
<
|
|
<
|
|
|
|
|
<













|
|





|
|
<





|







|


|
|
|
|
|
|
<
|

|







|
|
















|


|
|


|
|















|


|













|












|


|
|


|
|















|


|













|












|


|
|


|
|











<



|


|






<
<
|
>
>
|








|


|


|
|





|
|
|
|







899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927


928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945

946
947
948
949
950
951
952
953
954
955
956
957
958

959
960
961
962
963
964
965
966
967

968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051

1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099

1100
1101

1102
1103
1104
1105
1106

1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128

1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306

1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319


1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
	 */

	return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F,
		errorPtr);
    }
    dirPtr = opendir(source);				/* INTL: Native. */
    if (dirPtr == NULL) {
	/*
	 * Can't read directory
	 */

	errfile = source;
	goto end;
    }
    result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
	    errorPtr);
    if (result != TCL_OK) {
	closedir(dirPtr);
	return result;
    }

    Tcl_DStringAppend(sourcePtr, "/", 1);
    sourceLen = Tcl_DStringLength(sourcePtr);

    if (targetPtr != NULL) {
	Tcl_DStringAppend(targetPtr, "/", 1);
	targetLen = Tcl_DStringLength(targetPtr);
    }



    while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
	if ((dirEntPtr->d_name[0] == '.')
		&& ((dirEntPtr->d_name[1] == '\0')
			|| (strcmp(dirEntPtr->d_name, "..") == 0))) {
	    continue;
	}

	/*
	 * Append name after slash, and recurse on the file.
	 */

	Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1);
	if (targetPtr != NULL) {
	    Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1);
	}
	result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
		errorPtr, doRewind);
	if (result != TCL_OK) {

	    break;
	} else {
	    numProcessed++;
	}

	/*
	 * Remove name after slash.
	 */

	Tcl_DStringSetLength(sourcePtr, sourceLen);
	if (targetPtr != NULL) {
	    Tcl_DStringSetLength(targetPtr, targetLen);
	}

	if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) {
	    /*
	     * Call rewinddir if we've called unlink or rmdir so many times
	     * (since the opendir or the previous rewinddir), to avoid
	     * a NULL-return that may a symptom of a buggy readdir.
	     */
	    rewinddir(dirPtr);
	    numProcessed = 0;
	}

    }
    closedir(dirPtr);

    /*
     * Strip off the trailing slash we added
     */

    Tcl_DStringSetLength(sourcePtr, sourceLen - 1);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, targetLen - 1);
    }

    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the files in
	 * that directory.
	 */

	result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD,
		errorPtr);
    }

  end:
    if (errfile != NULL) {
	if (errorPtr != NULL) {
	    Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr);
	}
	result = TCL_ERROR;
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *	Called from TraverseUnixTree in order to execute a recursive copy of a
 *	directory.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	The file or directory src may be copied to dst, depending on the value
 *	of type.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr)
    Tcl_DString *srcPtr;	/* Source pathname to copy (native). */
    Tcl_DString *dstPtr;	/* Destination pathname of copy (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for file specified by srcPtr. */
    int type;			/* Reason for call - see TraverseUnixTree(). */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    switch (type) {
    case DOTREE_F:
	if (DoCopyFile(Tcl_DStringValue(srcPtr),
		Tcl_DStringValue(dstPtr)) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    case DOTREE_PRED:
	if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    case DOTREE_POSTD:
	if (CopyFileAtts(Tcl_DStringValue(srcPtr),
		Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) {
	    return TCL_OK;
	}
	break;
    }


    /*
     * There shouldn't be a problem with src, because we already checked it to
     * get here.
     */

    if (errorPtr != NULL) {
	Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr),
		Tcl_DStringLength(dstPtr), errorPtr);
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TraversalDelete --
 *
 *	Called by procedure TraverseUnixTree for every file and directory that
 *	it encounters in a directory hierarchy. This procedure unlinks files,
 *	and removes directories after all the containing files have been
 *	processed.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Files or directory specified by src will be deleted.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr)
    Tcl_DString *srcPtr;	/* Source pathname (native). */
    Tcl_DString *ignore;	/* Destination pathname (not used). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for file specified by srcPtr. */
    int type;			/* Reason for call - see TraverseUnixTree(). */
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    switch (type) {
    case DOTREE_F:
	if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
	    return TCL_OK;
	}
	break;

    case DOTREE_PRED:
	return TCL_OK;

    case DOTREE_POSTD:
	if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) {
	    return TCL_OK;
	}
	break;

    }
    if (errorPtr != NULL) {
	Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr),
		Tcl_DStringLength(srcPtr), errorPtr);
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * CopyFileAtts --
 *
 *	Copy the file attributes such as owner, group, permissions, and
 *	modification date from one file to another.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	User id, group id, permission bits, last modification time, and last
 *	access time are updated in the new file to reflect the old file.

 *
 *---------------------------------------------------------------------------
 */

static int
CopyFileAtts(src, dst, statBufPtr)
    CONST char *src;		/* Path name of source file (native). */
    CONST char *dst;		/* Path name of target file (native). */
    CONST Tcl_StatBuf *statBufPtr;
				/* Stat info for source file */
{
    struct utimbuf tval;
    mode_t newMode;

    newMode = statBufPtr->st_mode
	    & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO);

    /*
     * Note that if you copy a setuid file that is owned by someone else, and
     * you are not root, then the copy will be setuid to you. The most correct
     * implementation would probably be to have the copy not setuid to anyone
     * if the original file was owned by someone else, but this corner case

     * isn't currently handled. It would require another lstat(), or getuid().
     */

    if (chmod(dst, newMode)) {				/* INTL: Native. */
	newMode &= ~(S_ISUID | S_ISGID);
	if (chmod(dst, newMode)) {			/* INTL: Native. */
	    return TCL_ERROR;
	}
    }

    tval.actime = statBufPtr->st_atime;
    tval.modtime = statBufPtr->st_mtime;

    if (utime(dst, &tval)) {				/* INTL: Native. */
	return TCL_ERROR;
    }
#ifdef MAC_OSX_TCL
    TclMacOSXCopyFileAttributes(src, dst, statBufPtr);
#endif
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * GetGroupAttribute
 *
 *	Gets the group attribute of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;  	/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    struct group *groupPtr;
    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    groupPtr = getgrgid(statBuf.st_gid);		/* INTL: Native. */
    if (groupPtr == NULL) {
	*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
    } else {
	Tcl_DString ds;
	CONST char *utf;

	utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds);
	*attributePtrPtr = Tcl_NewStringObj(utf, -1);
	Tcl_DStringFree(&ds);
    }
    endgrent();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetOwnerAttribute
 *
 *	Gets the owner attribute of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;  	/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    struct passwd *pwPtr;
    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }

    pwPtr = getpwuid(statBuf.st_uid);			/* INTL: Native. */
    if (pwPtr == NULL) {
	*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
    } else {
	Tcl_DString ds;
	CONST char *utf;

	utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
	*attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
    }
    endpwent();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetPermissionsAttribute
 *
 *	Gets the group attribute of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;

    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }



    *attributePtrPtr = Tcl_NewObj();
    TclObjPrintf(NULL, *attributePtrPtr, "%0#5lo",
	    (long) (statBuf.st_mode & 0x00007FFF));

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetGroupAttribute --
 *
 *	Sets the group of the file to the specified group.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	As above.
 *
 *---------------------------------------------------------------------------
 */

static int
SetGroupAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		/* The interp for error reporting. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	/* New group for file. */
{
    long gid;
    int result;
    CONST char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
	Tcl_DString ds;
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
	groupPtr = getgrnam(native);			/* INTL: Native. */
	Tcl_DStringFree(&ds);

	if (groupPtr == NULL) {
	    endgrent();
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "could not set group for file \"",
			Tcl_GetString(fileName), "\": group \"", 
			string, "\" does not exist",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	gid = groupPtr->gr_gid;
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chown(native, (uid_t) -1, (gid_t) gid);	/* INTL: Native. */

    endgrent();
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set group for file \"",
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), 
		    (char *) NULL);
	}
	return TCL_ERROR;
    }    
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetOwnerAttribute --
 *
 *      Sets the owner of the file to the specified owner.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      As above.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetOwnerAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		    /* The interp for error reporting. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;   	    /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	    /* New owner for file. */
{
    long uid;
    int result;
    CONST char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
	Tcl_DString ds;







|















|



|








|


|


|
|





|
|
|
|







1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
	groupPtr = getgrnam(native);			/* INTL: Native. */
	Tcl_DStringFree(&ds);

	if (groupPtr == NULL) {
	    endgrent();
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "could not set group for file \"",
			Tcl_GetString(fileName), "\": group \"",
			string, "\" does not exist",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	gid = groupPtr->gr_gid;
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chown(native, (uid_t) -1, (gid_t) gid);	/* INTL: Native. */

    endgrent();
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set group for file \"",
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetOwnerAttribute --
 *
 *	Sets the owner of the file to the specified owner.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	As above.
 *
 *---------------------------------------------------------------------------
 */

static int
SetOwnerAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		/* The interp for error reporting. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	/* New owner for file. */
{
    long uid;
    int result;
    CONST char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
	Tcl_DString ds;
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476

1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488

1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chown(native, (uid_t) uid, (gid_t) -1);   /* INTL: Native. */

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set owner for file \"", 
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetPermissionsAttribute
 *
 *      Sets the file to the given permission.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      The permission of the file is changed.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetPermissionsAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	    /* The attribute to set. */
{
    long mode;
    mode_t newMode;
    int result;
    CONST char *native;

    /*
     * First try if the string is a number
     */

    if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
        newMode = (mode_t) (mode & 0x00007FFF);
    } else {
	Tcl_StatBuf buf;
	char *modeStringPtr = Tcl_GetString(attributePtr);

	/*
	 * Try the forms "rwxrwxrwx" and "ugo=rwx"
	 *
	 * We get the current mode of the file, in order to allow for
	 * ug+-=rwx style chmod strings.
	 */

	result = TclpObjStat(fileName, &buf);
	if (result != 0) {
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "could not read \"", 
			Tcl_GetString(fileName), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
	    }
	    return TCL_ERROR;
	}
	newMode = (mode_t) (buf.st_mode & 0x00007FFF);

	if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "unknown permission string format \"",
			modeStringPtr, "\"", (char *) NULL);
	    }
	    return TCL_ERROR;
	}
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chmod(native, newMode);		/* INTL: Native. */
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set permissions for file \"", 
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}







|













|


|


|
|





|
|
|
|









>

|







|
|

>



|




















|







1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chown(native, (uid_t) uid, (gid_t) -1);   /* INTL: Native. */

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set owner for file \"",
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetPermissionsAttribute
 *
 *	Sets the file to the given permission.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The permission of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetPermissionsAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	/* The attribute to set. */
{
    long mode;
    mode_t newMode;
    int result;
    CONST char *native;

    /*
     * First try if the string is a number
     */

    if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
	newMode = (mode_t) (mode & 0x00007FFF);
    } else {
	Tcl_StatBuf buf;
	char *modeStringPtr = Tcl_GetString(attributePtr);

	/*
	 * Try the forms "rwxrwxrwx" and "ugo=rwx"
	 *
	 * We get the current mode of the file, in order to allow for ug+-=rwx
	 * style chmod strings.
	 */

	result = TclpObjStat(fileName, &buf);
	if (result != 0) {
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "could not read \"",
			Tcl_GetString(fileName), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
	    }
	    return TCL_ERROR;
	}
	newMode = (mode_t) (buf.st_mode & 0x00007FFF);

	if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "unknown permission string format \"",
			modeStringPtr, "\"", (char *) NULL);
	    }
	    return TCL_ERROR;
	}
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chmod(native, newMode);		/* INTL: Native. */
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set permissions for file \"",
		    Tcl_GetString(fileName), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581

1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755

1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770

1771
1772
1773
1774
1775

1776
1777
1778
1779
1780
1781

1782


1783
1784

1785
1786
1787
1788
1789
1790
1791
1792
1793


1794

1795
1796
1797
1798
1799

1800


1801
1802
1803
1804
1805
1806
1807
1808

1809

1810


1811
1812


1813


1814
1815

1816


1817
1818
1819
1820

1821
1822
1823
1824
1825
1826
1827

1828
1829
1830
1831
1832
1833
1834

1835

1836

1837
1838
1839

1840
1841
1842
1843

1844


1845

1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857

1858
1859
1860
1861
1862
1863
1864

1865
1866
1867
1868

1869


1870

1871
1872

1873
1874
1875
1876

1877
1878

1879


1880
1881

1882
1883
1884

1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999








#endif

/*
 *----------------------------------------------------------------------
 *
 * GetModeFromPermString --
 *
 *	This procedure is invoked to process the "file permissions"
 *	Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
GetModeFromPermString(interp, modeStringPtr, modePtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    char *modeStringPtr;	/* Permissions string */
    mode_t *modePtr;		/* pointer to the mode value */
{
    mode_t newMode;
    mode_t oldMode;		/* Storage for the value of the old mode
				 * (that is passed in), to allow for the
				 * chmod style manipulation */
    int i,n, who, op, what, op_found, who_found;

    /*
     * We start off checking for an "rwxrwxrwx" style permissions string
     */

    if (strlen(modeStringPtr) != 9) {
        goto chmodStyleCheck;
    }

    newMode = 0;
    for (i = 0; i < 9; i++) {
	switch (*(modeStringPtr+i)) {
	    case 'r':
		if ((i%3) != 0) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<(8-i));
		break;
	    case 'w':
		if ((i%3) != 1) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<(8-i));
		break;
	    case 'x':
		if ((i%3) != 2) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<(8-i));
		break;
	    case 's':
		if (((i%3) != 2) || (i > 5)) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<(8-i));
		newMode |= (1<<(11-(i/3)));
		break;
	    case 'S':
		if (((i%3) != 2) || (i > 5)) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<(11-(i/3)));
		break;
	    case 't':
		if (i != 8) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<(8-i));
		newMode |= (1<<9);
		break;
	    case 'T':
		if (i != 8) {
		    goto chmodStyleCheck;
		}
		newMode |= (1<<9);
		break;
	    case '-':
		break;
	    default:
		/*
		 * Oops, not what we thought it was, so go on
		 */
		goto chmodStyleCheck;
	}
    }
    *modePtr = newMode;
    return TCL_OK;

    chmodStyleCheck:
    /*
     * We now check for an "ugoa+-=rwxst" style permissions string
     */

    for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) {
	oldMode = *modePtr;
	who = op = what = op_found = who_found = 0;
	for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
	    if (!who_found) {
		/* who */
		switch (*(modeStringPtr+n+i)) {
		    case 'u' :
			who |= 0x9c0;
			continue;
		    case 'g' :
			who |= 0x438;
			continue;
		    case 'o' :
			who |= 0x207;
			continue;
		    case 'a' :
			who |= 0xfff;
			continue;
		}
	    }
	    who_found = 1;
	    if (who == 0) {
		who = 0xfff;
	    }
	    if (!op_found) {
		/* op */
		switch (*(modeStringPtr+n+i)) {
		    case '+' :
			op = 1;
			op_found = 1;
			continue;
		    case '-' :
			op = 2;
			op_found = 1;
			continue;
		    case '=' :
			op = 3;
			op_found = 1;
			continue;
		    default  :
			return TCL_ERROR;
		}
	    }
	    /* what */
	    switch (*(modeStringPtr+n+i)) {
		case 'r' :
		    what |= 0x124;
		    continue;
		case 'w' :
		    what |= 0x92;
		    continue;
		case 'x' :
		    what |= 0x49;
		    continue;
		case 's' :
		    what |= 0xc00;
		    continue;
		case 't' :
		    what |= 0x200;
		    continue;
		case ',' :
		    break;
		default  :
		    return TCL_ERROR;
	    }
	    if (*(modeStringPtr+n+i) == ',') {
		i++;
		break;
	    }
	}
	switch (op) {
	    case 1 :
		*modePtr = oldMode | (who & what);
		continue;
	    case 2 :
		*modePtr = oldMode & ~(who & what);
		continue;
	    case 3 :
		*modePtr = (oldMode & ~who) | (who & what);
		continue;
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces
 *	it, in place, with a normalized version.  A normalized version
 *	is one in which all symlinks in the path are replaced with
 *	their expanded form (except a symlink at the very end of the
 *	path).
 *
 * Results:
 *	The new 'nextCheckpoint' value, giving as far as we could
 *	understand in the path.
 *
 * Side effects:
 *	The pathPtr string, is modified.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
    Tcl_Interp *interp;
    Tcl_Obj *pathPtr;
    int nextCheckpoint;
{
    char *currentPathEndPosition;
    int pathLen;
    char cur;
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
#ifndef NO_REALPATH
    char normPath[MAXPATHLEN];
    Tcl_DString ds;
    CONST char *nativePath; 
#endif

    /* 
     * We add '1' here because if nextCheckpoint is zero we know
     * that '/' exists, and if it isn't zero, it must point at
     * a directory separator which we also know exists.
     */

    currentPathEndPosition = path + nextCheckpoint;
    if (*currentPathEndPosition == '/') {
	currentPathEndPosition++;
    }

#ifndef NO_REALPATH

    /* For speed, try to get the entire path in one go */


    if (nextCheckpoint == 0) {
        char *lastDir = strrchr(currentPathEndPosition, '/');

	if (lastDir != NULL) {
	    nativePath = Tcl_UtfToExternalDString(NULL, path, 
						  lastDir - path, &ds);
	    if (Realpath(nativePath, normPath) != NULL) {
		nextCheckpoint = lastDir - path;
		goto wholeStringOk;
	    }
	}
    }


    /* Else do it the slow way */

#endif
    
    while (1) {
	cur = *currentPathEndPosition;
	if ((cur == '/') && (path != currentPathEndPosition)) {

	    /* Reached directory separator */


	    Tcl_DString ds;
	    CONST char *nativePath;
	    int accessOk;

	    nativePath = Tcl_UtfToExternalDString(NULL, path, 
		    currentPathEndPosition - path, &ds);
	    accessOk = access(nativePath, F_OK);
	    Tcl_DStringFree(&ds);

	    if (accessOk != 0) {

		/* File doesn't exist */


		break;
	    }


	    /* Update the acceptable point */


	    nextCheckpoint = currentPathEndPosition - path;
	} else if (cur == 0) {

	    /* Reached end of string */


	    break;
	}
	currentPathEndPosition++;
    }

    /* 
     * We should really now convert this to a canonical path.  We do
     * that with 'realpath' if we have it available.  Otherwise we could
     * step through every single path component, checking whether it is a 
     * symlink, but that would be a lot of work, and most modern OSes 
     * have 'realpath'.
     */

#ifndef NO_REALPATH
    /* 
     * If we only had '/foo' or '/' then we never increment nextCheckpoint
     * and we don't need or want to go through 'Realpath'.  Also, on some
     * platforms, passing an empty string to 'Realpath' will give us the
     * normalized pwd, which is not what we want at all!
     */

    if (nextCheckpoint == 0) return 0;

    

    nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
    if (Realpath(nativePath, normPath) != NULL) {
	int newNormLen;

	wholeStringOk:
	newNormLen = strlen(normPath);
	if ((newNormLen == Tcl_DStringLength(&ds))
		&& (strcmp(normPath, nativePath) == 0)) {

	    /* String is unchanged */


	    Tcl_DStringFree(&ds);

	    /*
	     * Enable this to have the native FS claim normalization of
	     * the whole path for existing files.  That would permit the
	     * caller to declare normalization complete without calls to
	     * additional filesystems.  Saving lots of calls is probably
	     * worth the extra access() time here.  When no other FS's
	     * are registered though, things are less clear.
	     *
	    if (0 == access(normPath, F_OK)) {
		return pathLen;
	    }
	     */

	    return nextCheckpoint;
	}
	
	/* 
	 * Free up the native path and put in its place the
	 * converted, normalized path.
	 */

	Tcl_DStringFree(&ds);
	Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);

	if (path[nextCheckpoint] != '\0') {

	    /* not at end, append remaining path */


	    int normLen = Tcl_DStringLength(&ds);

	    Tcl_DStringAppend(&ds, path + nextCheckpoint,
		    pathLen - nextCheckpoint);

	    /* 
	     * We recognise up to and including the directory
	     * separator.
	     */	

	    nextCheckpoint = normLen + 1;
	} else {

	    /* We recognise the whole string */ 


	    nextCheckpoint = Tcl_DStringLength(&ds);
	}

	/* 
	 * Overwrite with the normalized path.
	 */

	Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
		Tcl_DStringLength(&ds));
    }
    Tcl_DStringFree(&ds);
#endif	/* !NO_REALPATH */

    return nextCheckpoint;
}

#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
 *----------------------------------------------------------------------
 *
 * GetReadOnlyAttribute
 *
 *      Gets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *	if there is no error. The object will have ref count 0.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

static int
GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	    /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    int result;

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"", 
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags & UF_IMMUTABLE) != 0);
    
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetReadOnlyAttribute
 *
 *      Sets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      The readonly attribute of the file is changed.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		    /* The interp we are using for errors. */
    int objIndex;		    /* The index of the attribute. */
    Tcl_Obj *fileName;  	    /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	    /* The attribute to set. */
{
    Tcl_StatBuf statBuf;
    int result;
    int readonly;
    CONST char *native;

    if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) {
        return TCL_ERROR;
    }

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"", 
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }

    if (readonly) {
        statBuf.st_flags |= UF_IMMUTABLE;
    } else {
        statBuf.st_flags &= ~UF_IMMUTABLE;
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chflags(native, statBuf.st_flags);		/* INTL: Native. */
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set flags for file \"", 
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}
#endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */















|
|
|

















|
|
|





>

|





|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|





|











|
|
|
|
|
|
|
|
|
|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







|
|
|
|
|
|
|
|
|










|
|
|
|
<


|
|






>













|

>
|
|
|
|

>






>
|
>
>

|
>

|
|






>
>
|
>

|



>
|
>
>




|



>

>
|
>
>


>
>
|
>
>


>
|
>
>




>
|
|
|
|
|
<

>

|
|
|



>
|
>
|
>



>
|



>
|
>
>

>

|
|
|
|
|
|





>


|
|
|
|

>




>
|
>
>

>


>
|
|
<
|
>


>
|
>
>


>
|


>















|


|
|


|
|





|
|
|
|





|


|






|
|








|


|


|
|





|
|
|
|







|



|


|







|

|






|








>
>
>
>
>
>
>
>
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759

1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864

1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928

1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
#endif

/*
 *----------------------------------------------------------------------
 *
 * GetModeFromPermString --
 *
 *	This procedure is invoked to process the "file permissions" Tcl
 *	command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
GetModeFromPermString(interp, modeStringPtr, modePtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    char *modeStringPtr;	/* Permissions string */
    mode_t *modePtr;		/* pointer to the mode value */
{
    mode_t newMode;
    mode_t oldMode;		/* Storage for the value of the old mode (that
				 * is passed in), to allow for the chmod style
				 * manipulation. */
    int i,n, who, op, what, op_found, who_found;

    /*
     * We start off checking for an "rwxrwxrwx" style permissions string
     */

    if (strlen(modeStringPtr) != 9) {
	goto chmodStyleCheck;
    }

    newMode = 0;
    for (i = 0; i < 9; i++) {
	switch (*(modeStringPtr+i)) {
	case 'r':
	    if ((i%3) != 0) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<(8-i));
	    break;
	case 'w':
	    if ((i%3) != 1) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<(8-i));
	    break;
	case 'x':
	    if ((i%3) != 2) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<(8-i));
	    break;
	case 's':
	    if (((i%3) != 2) || (i > 5)) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<(8-i));
	    newMode |= (1<<(11-(i/3)));
	    break;
	case 'S':
	    if (((i%3) != 2) || (i > 5)) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<(11-(i/3)));
	    break;
	case 't':
	    if (i != 8) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<(8-i));
	    newMode |= (1<<9);
	    break;
	case 'T':
	    if (i != 8) {
		goto chmodStyleCheck;
	    }
	    newMode |= (1<<9);
	    break;
	case '-':
	    break;
	default:
	    /*
	     * Oops, not what we thought it was, so go on
	     */
	    goto chmodStyleCheck;
	}
    }
    *modePtr = newMode;
    return TCL_OK;

  chmodStyleCheck:
    /*
     * We now check for an "ugoa+-=rwxst" style permissions string
     */

    for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) {
	oldMode = *modePtr;
	who = op = what = op_found = who_found = 0;
	for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
	    if (!who_found) {
		/* who */
		switch (*(modeStringPtr+n+i)) {
		case 'u':
		    who |= 0x9c0;
		    continue;
		case 'g':
		    who |= 0x438;
		    continue;
		case 'o':
		    who |= 0x207;
		    continue;
		case 'a':
		    who |= 0xfff;
		    continue;
		}
	    }
	    who_found = 1;
	    if (who == 0) {
		who = 0xfff;
	    }
	    if (!op_found) {
		/* op */
		switch (*(modeStringPtr+n+i)) {
		case '+':
		    op = 1;
		    op_found = 1;
		    continue;
		case '-':
		    op = 2;
		    op_found = 1;
		    continue;
		case '=':
		    op = 3;
		    op_found = 1;
		    continue;
		default:
		    return TCL_ERROR;
		}
	    }
	    /* what */
	    switch (*(modeStringPtr+n+i)) {
	    case 'r':
		what |= 0x124;
		continue;
	    case 'w':
		what |= 0x92;
		continue;
	    case 'x':
		what |= 0x49;
		continue;
	    case 's':
		what |= 0xc00;
		continue;
	    case 't':
		what |= 0x200;
		continue;
	    case ',':
		break;
	    default:
		return TCL_ERROR;
	    }
	    if (*(modeStringPtr+n+i) == ',') {
		i++;
		break;
	    }
	}
	switch (op) {
	case 1 :
	    *modePtr = oldMode | (who & what);
	    continue;
	case 2 :
	    *modePtr = oldMode & ~(who & what);
	    continue;
	case 3 :
	    *modePtr = (oldMode & ~who) | (who & what);
	    continue;
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces it, in
 *	place, with a normalized version. A normalized version is one in which
 *	all symlinks in the path are replaced with their expanded form (except
 *	a symlink at the very end of the path).

 *
 * Results:
 *	The new 'nextCheckpoint' value, giving as far as we could understand
 *	in the path.
 *
 * Side effects:
 *	The pathPtr string, is modified.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
    Tcl_Interp *interp;
    Tcl_Obj *pathPtr;
    int nextCheckpoint;
{
    char *currentPathEndPosition;
    int pathLen;
    char cur;
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
#ifndef NO_REALPATH
    char normPath[MAXPATHLEN];
    Tcl_DString ds;
    CONST char *nativePath;
#endif

    /*
     * We add '1' here because if nextCheckpoint is zero we know that '/'
     * exists, and if it isn't zero, it must point at a directory separator
     * which we also know exists.
     */

    currentPathEndPosition = path + nextCheckpoint;
    if (*currentPathEndPosition == '/') {
	currentPathEndPosition++;
    }

#ifndef NO_REALPATH
    /*
     * For speed, try to get the entire path in one go.
     */

    if (nextCheckpoint == 0) {
	char *lastDir = strrchr(currentPathEndPosition, '/');

	if (lastDir != NULL) {
	    nativePath = Tcl_UtfToExternalDString(NULL, path,
		    lastDir-path, &ds);
	    if (Realpath(nativePath, normPath) != NULL) {
		nextCheckpoint = lastDir - path;
		goto wholeStringOk;
	    }
	}
    }

    /*
     * Else do it the slow way.
     */
#endif

    while (1) {
	cur = *currentPathEndPosition;
	if ((cur == '/') && (path != currentPathEndPosition)) {
	    /*
	     * Reached directory separator.
	     */

	    Tcl_DString ds;
	    CONST char *nativePath;
	    int accessOk;

	    nativePath = Tcl_UtfToExternalDString(NULL, path,
		    currentPathEndPosition - path, &ds);
	    accessOk = access(nativePath, F_OK);
	    Tcl_DStringFree(&ds);

	    if (accessOk != 0) {
		/*
		 * File doesn't exist.
		 */

		break;
	    }

	    /*
	     * Update the acceptable point.
	     */

	    nextCheckpoint = currentPathEndPosition - path;
	} else if (cur == 0) {
	    /*
	     * Reached end of string.
	     */

	    break;
	}
	currentPathEndPosition++;
    }

    /*
     * We should really now convert this to a canonical path. We do that with
     * 'realpath' if we have it available. Otherwise we could step through
     * every single path component, checking whether it is a symlink, but that
     * would be a lot of work, and most modern OSes have 'realpath'.

     */

#ifndef NO_REALPATH
    /*
     * If we only had '/foo' or '/' then we never increment nextCheckpoint and
     * we don't need or want to go through 'Realpath'. Also, on some
     * platforms, passing an empty string to 'Realpath' will give us the
     * normalized pwd, which is not what we want at all!
     */

    if (nextCheckpoint == 0) {
	return 0;
    }

    nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
    if (Realpath(nativePath, normPath) != NULL) {
	int newNormLen;

    wholeStringOk:
	newNormLen = strlen(normPath);
	if ((newNormLen == Tcl_DStringLength(&ds))
		&& (strcmp(normPath, nativePath) == 0)) {
	    /*
	     * String is unchanged.
	     */

	    Tcl_DStringFree(&ds);

	    /*
	     * Enable this to have the native FS claim normalization of the
	     * whole path for existing files. That would permit the caller to
	     * declare normalization complete without calls to additional
	     * filesystems. Saving lots of calls is probably worth the extra
	     * access() time here. When no other FS's are registered though,
	     * things are less clear.
	     *
	    if (0 == access(normPath, F_OK)) {
		return pathLen;
	    }
	     */

	    return nextCheckpoint;
	}

	/*
	 * Free up the native path and put in its place the converted,
	 * normalized path.
	 */

	Tcl_DStringFree(&ds);
	Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);

	if (path[nextCheckpoint] != '\0') {
	    /*
	     * Not at end, append remaining path.
	     */

	    int normLen = Tcl_DStringLength(&ds);

	    Tcl_DStringAppend(&ds, path + nextCheckpoint,
		    pathLen - nextCheckpoint);

	    /*
	     * We recognise up to and including the directory separator.

	     */

	    nextCheckpoint = normLen + 1;
	} else {
	    /*
	     * We recognise the whole string.
	     */

	    nextCheckpoint = Tcl_DStringLength(&ds);
	}

	/*
	 * Overwrite with the normalized path.
	 */

	Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
		Tcl_DStringLength(&ds));
    }
    Tcl_DStringFree(&ds);
#endif	/* !NO_REALPATH */

    return nextCheckpoint;
}

#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
 *----------------------------------------------------------------------
 *
 * GetReadOnlyAttribute
 *
 *	Gets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    int result;

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0);

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetReadOnlyAttribute
 *
 *	Sets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The readonly attribute of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;		/* The interp we are using for errors. */
    int objIndex;		/* The index of the attribute. */
    Tcl_Obj *fileName;		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;	/* The attribute to set. */
{
    Tcl_StatBuf statBuf;
    int result;
    int readonly;
    CONST char *native;

    if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) {
	return TCL_ERROR;
    }

    result = TclpObjStat(fileName, &statBuf);

    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }

    if (readonly) {
	statBuf.st_flags |= UF_IMMUTABLE;
    } else {
	statBuf.st_flags &= ~UF_IMMUTABLE;
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chflags(native, statBuf.st_flags);		/* INTL: Native. */
    if (result != 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not set flags for file \"",
		    Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}
#endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixFile.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
/* 
 * tclUnixFile.c --
 *
 *      This file contains wrappers around UNIX file handling functions.
 *      These wrappers mask differences between Windows and UNIX.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFile.c,v 1.44 2004/12/01 23:18:55 dgp Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);


/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This procedure computes the absolute path name of the current
 *	application, given its argv[0] value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The computed path name is stored as a ProcessGlobalValue.
|


|
|



|
|

|






<






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
/*
 * tclUnixFile.c --
 *
 *	This file contains wrappers around UNIX file handling functions.
 *	These wrappers mask differences between Windows and UNIX.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFile.c,v 1.44.2.2 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);


/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current
 *	application, given its argv[0] value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The computed path name is stored as a ProcessGlobalValue.
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
    }
    Tcl_DStringInit(&buffer);

    name = argv0;
    for (p = name; *p != '\0'; p++) {
	if (*p == '/') {
	    /*
	     * The name contains a slash, so use the name directly
	     * without doing a path search.
	     */

	    goto gotName;
	}
    }

    p = getenv("PATH");					/* INTL: Native. */
    if (p == NULL) {
	/*
	 * There's no PATH environment variable; use the default that
	 * is used by sh.
	 */

	p = ":/bin:/usr/bin";
    } else if (*p == '\0') {
	/*
	 * An empty path is equivalent to ".".
	 */

	p = "./";
    }

    /*
     * Search through all the directories named in the PATH variable
     * to see if argv[0] is in one of them.  If so, use that file
     * name.
     */

    while (1) {
	while (isspace(UCHAR(*p))) {		/* INTL: BUG */
	    p++;
	}
	name = p;
	while ((*p != ':') && (*p != 0)) {
	    p++;
	}
	Tcl_DStringSetLength(&buffer, 0);







|
|









|
|












|
|
<



|







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

83
84
85
86
87
88
89
90
91
92
93
    }
    Tcl_DStringInit(&buffer);

    name = argv0;
    for (p = name; *p != '\0'; p++) {
	if (*p == '/') {
	    /*
	     * The name contains a slash, so use the name directly without
	     * doing a path search.
	     */

	    goto gotName;
	}
    }

    p = getenv("PATH");					/* INTL: Native. */
    if (p == NULL) {
	/*
	 * There's no PATH environment variable; use the default that is used
	 * by sh.
	 */

	p = ":/bin:/usr/bin";
    } else if (*p == '\0') {
	/*
	 * An empty path is equivalent to ".".
	 */

	p = "./";
    }

    /*
     * Search through all the directories named in the PATH variable to see if
     * argv[0] is in one of them. If so, use that file name.

     */

    while (1) {
	while (isspace(UCHAR(*p))) {			/* INTL: BUG */
	    p++;
	}
	name = p;
	while ((*p != ':') && (*p != 0)) {
	    p++;
	}
	Tcl_DStringSetLength(&buffer, 0);
123
124
125
126
127
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
    TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
    goto done;

    /*
     * If the name starts with "/" then just store it
     */

gotName:
#ifdef DJGPP
    if (name[1] == ':')  {
#else
    if (name[0] == '/')  {
#endif

	encoding = Tcl_GetEncoding(NULL, NULL);
	Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
	TclSetObjNameOfExecutable(
		Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
	Tcl_DStringFree(&utfName);
	goto done;
    }

    /*
     * The name is relative to the current working directory.  First
     * strip off a leading "./", if any, then add the full path name of
     * the current working directory.
     */

    if ((name[0] == '.') && (name[1] == '/')) {
	name += 2;
    }

    Tcl_DStringInit(&nameString);







|

|

|

>









|
|
|







121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
    TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
    goto done;

    /*
     * If the name starts with "/" then just store it
     */

  gotName:
#ifdef DJGPP
    if (name[1] == ':')
#else
    if (name[0] == '/')
#endif
    {
	encoding = Tcl_GetEncoding(NULL, NULL);
	Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
	TclSetObjNameOfExecutable(
		Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
	Tcl_DStringFree(&utfName);
	goto done;
    }

    /*
     * The name is relative to the current working directory. First strip off
     * a leading "./", if any, then add the full path name of the current
     * working directory.
     */

    if ((name[0] == '.') && (name[1] == '/')) {
	name += 2;
    }

    Tcl_DStringInit(&nameString);
164
165
166
167
168
169
170
171

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211

212


213
214
215
216
217
218
219
220
221

222


223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255


256


257
258
259
260
261
262
263
    }
    Tcl_DStringFree(&cwd);
    Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString),
	    Tcl_DStringLength(&nameString));
    Tcl_DStringFree(&nameString);

    encoding = Tcl_GetEncoding(NULL, NULL);
    Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, &utfName);

    TclSetObjNameOfExecutable(
	    Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
    Tcl_DStringFree(&utfName);
    
done:
    Tcl_DStringFree(&buffer);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a
 *	directory for all files which match a given pattern.
 *
 * Results: 
 *	The return value is a standard Tcl result indicating whether an
 *	error occurred in globbing.  Errors are left in interp, good
 *	results are lappended to resultPtr (which must be a valid object)
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------- */


int
TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive errors. */
    Tcl_Obj *resultPtr;		/* List object to lappend results. */
    Tcl_Obj *pathPtr;	        /* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    CONST char *native;
    Tcl_Obj *fileNamePtr;

    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {

	/* The native filesystem never adds mounts */


	return TCL_OK;
    }

    fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
    if (fileNamePtr == NULL) {
	return TCL_ERROR;
    }
    
    if (pattern == NULL || (*pattern == '\0')) {

	/* Match a file directly */


	native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
	if (NativeMatchType(native, types)) {
	    Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
	}
	Tcl_DecrRefCount(fileNamePtr);
	return TCL_OK;
    } else {
	DIR *d;
	Tcl_DirEntry *entryPtr;
	CONST char *dirName;
	int dirLength;
	int matchHidden;
	int nativeDirLen;
	Tcl_StatBuf statBuf;
	Tcl_DString ds;      /* native encoding of dir */
	Tcl_DString dsOrig;  /* utf-8 encoding of dir */

	Tcl_DStringInit(&dsOrig);
	dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
	Tcl_DStringAppend(&dsOrig, dirName, dirLength);
	
	/*
	 * Make sure that the directory part of the name really is a
	 * directory.  If the directory name is "", use the name "."
	 * instead, because some UNIX systems don't treat "" like "."
	 * automatically.  Keep the "" for use in generating file names,
	 * otherwise "glob foo.c" would return "./foo.c".
	 */

	if (dirLength == 0) {
	    dirName = ".";
	} else {
	    dirName = Tcl_DStringValue(&dsOrig);


	    /* Make sure we have a trailing directory delimiter */


	    if (dirName[dirLength-1] != '/') {
		dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
		dirLength++;
	    }
	}

	/*







|
>



|
|








|
|

|
|
|
|




|
>





|









>
|
>
>







|

>
|
>
>














|
|




|


|
|
|
|






>
>
|
>
>







163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    }
    Tcl_DStringFree(&cwd);
    Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString),
	    Tcl_DStringLength(&nameString));
    Tcl_DStringFree(&nameString);

    encoding = Tcl_GetEncoding(NULL, NULL);
    Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
	    &utfName);
    TclSetObjNameOfExecutable(
	    Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
    Tcl_DStringFree(&utfName);

  done:
    Tcl_DStringFree(&buffer);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a directory for
 *	all files which match a given pattern.
 *
 * Results:
 *	The return value is a standard Tcl result indicating whether an error
 *	occurred in globbing. Errors are left in interp, good results are
 *	[lappend]ed to resultPtr (which must be a valid object).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive errors. */
    Tcl_Obj *resultPtr;		/* List object to lappend results. */
    Tcl_Obj *pathPtr;		/* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    CONST char *native;
    Tcl_Obj *fileNamePtr;

    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
	/*
	 * The native filesystem never adds mounts.
	 */

	return TCL_OK;
    }

    fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
    if (fileNamePtr == NULL) {
	return TCL_ERROR;
    }

    if (pattern == NULL || (*pattern == '\0')) {
	/*
	 * Match a file directly.
	 */

	native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
	if (NativeMatchType(native, types)) {
	    Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
	}
	Tcl_DecrRefCount(fileNamePtr);
	return TCL_OK;
    } else {
	DIR *d;
	Tcl_DirEntry *entryPtr;
	CONST char *dirName;
	int dirLength;
	int matchHidden;
	int nativeDirLen;
	Tcl_StatBuf statBuf;
	Tcl_DString ds;		/* native encoding of dir */
	Tcl_DString dsOrig;	/* utf-8 encoding of dir */

	Tcl_DStringInit(&dsOrig);
	dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
	Tcl_DStringAppend(&dsOrig, dirName, dirLength);

	/*
	 * Make sure that the directory part of the name really is a
	 * directory.  If the directory name is "", use the name "." instead,
	 * because some UNIX systems don't treat "" like "." automatically.
	 * Keep the "" for use in generating file names, otherwise "glob
	 * foo.c" would return "./foo.c".
	 */

	if (dirLength == 0) {
	    dirName = ".";
	} else {
	    dirName = Tcl_DStringValue(&dsOrig);

	    /*
	     * Make sure we have a trailing directory delimiter.
	     */

	    if (dirName[dirLength-1] != '/') {
		dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
		dirLength++;
	    }
	}

	/*
273
274
275
276
277
278
279

280
281
282
283

284
285
286
287
288
289
290
291
292
293

294
295
296
297
298
299
300
301
302
303
304
305

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342

343
344
345
346
347
348
349
350
351
352
353
354
355

356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372

373
374
375
376
377
378
379
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397

398


399
400
401
402
403
404
405

406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434

435

436
437
438
439
440
441
442
	    Tcl_DecrRefCount(fileNamePtr);
	    return TCL_OK;
	}

	d = opendir(native);				/* INTL: Native. */
	if (d == NULL) {
	    Tcl_DStringFree(&ds);

	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "couldn't read directory \"",
		    Tcl_DStringValue(&dsOrig), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);

	    Tcl_DStringFree(&dsOrig);
	    Tcl_DecrRefCount(fileNamePtr);
	    return TCL_ERROR;
	}

	nativeDirLen = Tcl_DStringLength(&ds);

	/*
	 * Check to see if -type or the pattern requests hidden files.
	 */

	matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) ||
		((pattern[0] == '.')
			|| ((pattern[0] == '\\') && (pattern[1] == '.'))));

	while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */
	    Tcl_DString utfDs;
	    CONST char *utfname;

	    /* 
	     * Skip this file if it doesn't agree with the hidden
	     * parameters requested by the user (via -type or pattern).
	     */

	    if (*entryPtr->d_name == '.') {
		if (!matchHidden) continue;
	    } else {
		if (matchHidden) continue;
	    }

	    /*
	     * Now check to see if the file matches, according to both type
	     * and pattern.  If so, add the file to the result.
	     */

	    utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name,
		    -1, &utfDs);
	    if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
		int typeOk = 1;

		if (types != NULL) {
		    Tcl_DStringSetLength(&ds, nativeDirLen);
		    native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
		    typeOk = NativeMatchType(native, types);
		}
		if (typeOk) {
		    Tcl_ListObjAppendElement(interp, resultPtr, 
			    TclNewFSPathObj(pathPtr, utfname,
				    Tcl_DStringLength(&utfDs)));
		}
	    }
	    Tcl_DStringFree(&utfDs);
	}

	closedir(d);
	Tcl_DStringFree(&ds);
	Tcl_DStringFree(&dsOrig);
	Tcl_DecrRefCount(fileNamePtr);
	return TCL_OK;
    }
}

static int 
NativeMatchType(
    CONST char* nativeEntry,  /* Native path to check */
    Tcl_GlobTypeData *types)  /* Type description to match against */
{
    Tcl_StatBuf buf;
    if (types == NULL) {
	/* 
	 * Simply check for the file's existence, but do it
	 * with lstat, in case it is a link to a file which
	 * doesn't exist (since that case would not show up
	 * if we used 'access' or 'stat')
	 */

	if (TclOSlstat(nativeEntry, &buf) != 0) {
	    return 0;
	}
    } else {
	if (types->perm != 0) {
	    if (TclOSstat(nativeEntry, &buf) != 0) {
		/* 
		 * Either the file has disappeared between the
		 * 'readdir' call and the 'stat' call, or
		 * the file is a link to a file which doesn't
		 * exist (which we could ascertain with
		 * lstat), or there is some other strange
		 * problem.  In all these cases, we define this
		 * to mean the file does not match any defined
		 * permission, and therefore it is not 
		 * added to the list of files to return.
		 */

		return 0;
	    }
	    
	    /* 
	     * readonly means that there are NO write permissions
	     * (even for user), but execute is OK for anybody
	     * OR that the user immutable flag is set (where supported).
	     */

	    if (((types->perm & TCL_GLOB_PERM_RONLY) &&
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
			!(buf.st_flags & UF_IMMUTABLE) &&
#endif
			(buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
		((types->perm & TCL_GLOB_PERM_R) &&
			(access(nativeEntry, R_OK) != 0)) ||
		((types->perm & TCL_GLOB_PERM_W) &&
			(access(nativeEntry, W_OK) != 0)) ||
		((types->perm & TCL_GLOB_PERM_X) &&
			(access(nativeEntry, X_OK) != 0))
		) {
		return 0;
	    }
	}
	if (types->type != 0) {
	    if (types->perm == 0) {

		/* We haven't yet done a stat on the file */


		if (TclOSstat(nativeEntry, &buf) != 0) {
		    /* 
		     * Posix error occurred.  The only ok
		     * case is if this is a link to a nonexistent
		     * file, and the user did 'glob -l'. So
		     * we check that here:
		     */

		    if (types->type & TCL_GLOB_TYPE_LINK) {
			if (TclOSlstat(nativeEntry, &buf) == 0) {
			    if (S_ISLNK(buf.st_mode)) {
				return 1;
			    }
			}
		    }
		    return 0;
		}
	    }

	    /*
	     * In order bcdpfls as in 'find -t'
	     */
	    if (
		((types->type & TCL_GLOB_TYPE_BLOCK) &&
			S_ISBLK(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_CHAR) &&
			S_ISCHR(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_DIR) &&
			S_ISDIR(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_PIPE) &&
			S_ISFIFO(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_FILE) &&
			S_ISREG(buf.st_mode))
#ifdef S_ISSOCK
		|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
			S_ISSOCK(buf.st_mode))
#endif /* S_ISSOCK */
		) {

		/* Do nothing -- this file is ok */

	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    if (TclOSlstat(nativeEntry, &buf) == 0) {
			if (S_ISLNK(buf.st_mode)) {
			    return 1;
			}







>
|
|
|
|
>










>
|
|
|

|



|
|
|

>








|


|
|









|

|












>
|

|
|



|
|
|
<
|

>






|
|
<
|
|
|
<
|
|
|

>


|
|
|
|
|

>

















>
|
>
>

|
|
<
|
|

>










>



|
|
<
|
<
|
<
|
<
|
<

|
<


>
|
>







284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368

369
370
371
372
373
374
375
376
377
378
379

380
381
382

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420

421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

441

442

443

444

445
446

447
448
449
450
451
452
453
454
455
456
457
458
	    Tcl_DecrRefCount(fileNamePtr);
	    return TCL_OK;
	}

	d = opendir(native);				/* INTL: Native. */
	if (d == NULL) {
	    Tcl_DStringFree(&ds);
	    if (interp != NULL) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "couldn't read directory \"",
			Tcl_DStringValue(&dsOrig), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
	    }
	    Tcl_DStringFree(&dsOrig);
	    Tcl_DecrRefCount(fileNamePtr);
	    return TCL_ERROR;
	}

	nativeDirLen = Tcl_DStringLength(&ds);

	/*
	 * Check to see if -type or the pattern requests hidden files.
	 */

	matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN))
		|| ((pattern[0] == '.')
		|| ((pattern[0] == '\\') && (pattern[1] == '.'))));

	while ((entryPtr = TclOSreaddir(d)) != NULL) {	/* INTL: Native. */
	    Tcl_DString utfDs;
	    CONST char *utfname;

	    /*
	     * Skip this file if it doesn't agree with the hidden parameters
	     * requested by the user (via -type or pattern).
	     */

	    if (*entryPtr->d_name == '.') {
		if (!matchHidden) continue;
	    } else {
		if (matchHidden) continue;
	    }

	    /*
	     * Now check to see if the file matches, according to both type
	     * and pattern. If so, add the file to the result.
	     */

	    utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
		    &utfDs);
	    if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
		int typeOk = 1;

		if (types != NULL) {
		    Tcl_DStringSetLength(&ds, nativeDirLen);
		    native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
		    typeOk = NativeMatchType(native, types);
		}
		if (typeOk) {
		    Tcl_ListObjAppendElement(interp, resultPtr,
			    TclNewFSPathObj(pathPtr, utfname,
			    Tcl_DStringLength(&utfDs)));
		}
	    }
	    Tcl_DStringFree(&utfDs);
	}

	closedir(d);
	Tcl_DStringFree(&ds);
	Tcl_DStringFree(&dsOrig);
	Tcl_DecrRefCount(fileNamePtr);
	return TCL_OK;
    }
}

static int
NativeMatchType(
    CONST char* nativeEntry,  /* Native path to check. */
    Tcl_GlobTypeData *types)  /* Type description to match against. */
{
    Tcl_StatBuf buf;
    if (types == NULL) {
	/*
	 * Simply check for the file's existence, but do it with lstat, in
	 * case it is a link to a file which doesn't exist (since that case

	 * would not show up if we used 'access' or 'stat')
	 */

	if (TclOSlstat(nativeEntry, &buf) != 0) {
	    return 0;
	}
    } else {
	if (types->perm != 0) {
	    if (TclOSstat(nativeEntry, &buf) != 0) {
		/*
		 * Either the file has disappeared between the 'readdir' call

		 * and the 'stat' call, or the file is a link to a file which
		 * doesn't exist (which we could ascertain with lstat), or
		 * there is some other strange problem. In all these cases, we

		 * define this to mean the file does not match any defined
		 * permission, and therefore it is not added to the list of
		 * files to return.
		 */

		return 0;
	    }

	    /*
	     * readonly means that there are NO write permissions (even for
	     * user), but execute is OK for anybody OR that the user immutable
	     * flag is set (where supported).
	     */

	    if (((types->perm & TCL_GLOB_PERM_RONLY) &&
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
			!(buf.st_flags & UF_IMMUTABLE) &&
#endif
			(buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
		((types->perm & TCL_GLOB_PERM_R) &&
			(access(nativeEntry, R_OK) != 0)) ||
		((types->perm & TCL_GLOB_PERM_W) &&
			(access(nativeEntry, W_OK) != 0)) ||
		((types->perm & TCL_GLOB_PERM_X) &&
			(access(nativeEntry, X_OK) != 0))
		) {
		return 0;
	    }
	}
	if (types->type != 0) {
	    if (types->perm == 0) {
		/*
		 * We haven't yet done a stat on the file.
		 */

		if (TclOSstat(nativeEntry, &buf) != 0) {
		    /*
		     * Posix error occurred. The only ok case is if this is a

		     * link to a nonexistent file, and the user did 'glob -l'.
		     * So we check that here:
		     */

		    if (types->type & TCL_GLOB_TYPE_LINK) {
			if (TclOSlstat(nativeEntry, &buf) == 0) {
			    if (S_ISLNK(buf.st_mode)) {
				return 1;
			    }
			}
		    }
		    return 0;
		}
	    }

	    /*
	     * In order bcdpfls as in 'find -t'
	     */

	    if (((types->type & TCL_GLOB_TYPE_BLOCK)&& S_ISBLK(buf.st_mode)) ||

		((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) ||

		((types->type & TCL_GLOB_TYPE_DIR)  && S_ISDIR(buf.st_mode)) ||

		((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode))||

		((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))

#ifdef S_ISSOCK
		||((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode))

#endif /* S_ISSOCK */
		) {
		/*
		 * Do nothing - this file is ok.
		 */
	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    if (TclOSlstat(nativeEntry, &buf) == 0) {
			if (S_ISLNK(buf.st_mode)) {
			    return 1;
			}
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *
 *	This function takes the specified user name and finds their
 *	home directory.
 *
 * Results:
 *	The result is a pointer to a string specifying the user's home
 *	directory, or NULL if the user's home directory could not be
 *	determined.  Storage for the result string is allocated in
 *	bufferPtr; the caller must call Tcl_DStringFree() when the result
 *	is no longer needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclpGetUserHome(name, bufferPtr)
    CONST char *name;		/* User name for desired home directory. */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled
				 * with name of user's home directory. */
{
    struct passwd *pwPtr;
    Tcl_DString ds;
    CONST char *native;

    native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
    pwPtr = getpwnam(native);				/* INTL: Native. */
    Tcl_DStringFree(&ds);
    
    if (pwPtr == NULL) {
	endpwent();
	return NULL;
    }
    Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
    endpwent();
    return Tcl_DStringValue(bufferPtr);







|
|




|
|
|










|
|








|







467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *
 *	This function takes the specified user name and finds their home
 *	directory.
 *
 * Results:
 *	The result is a pointer to a string specifying the user's home
 *	directory, or NULL if the user's home directory could not be
 *	determined. Storage for the result string is allocated in bufferPtr;
 *	the caller must call Tcl_DStringFree() when the result is no longer
 *	needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclpGetUserHome(name, bufferPtr)
    CONST char *name;		/* User name for desired home directory. */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled with
				 * name of user's home directory. */
{
    struct passwd *pwPtr;
    Tcl_DString ds;
    CONST char *native;

    native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
    pwPtr = getpwnam(native);				/* INTL: Native. */
    Tcl_DStringFree(&ds);

    if (pwPtr == NULL) {
	endpwent();
	return NULL;
    }
    Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
    endpwent();
    return Tcl_DStringValue(bufferPtr);
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
 *
 * Side effects:
 *	See access() documentation.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;        /* Path of file to access */
    int mode;                /* Permission setting. */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return access(path, mode);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjChdir --
 *
 *	This function replaces the library version of chdir().
 *
 * Results:
 *	See chdir() documentation.
 *
 * Side effects:
 *	See chdir() documentation.  
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjChdir(pathPtr)
    Tcl_Obj *pathPtr;          /* Path to new working directory */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return chdir(path);
    }







|

|
|




















|




|

|







522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
 *
 * Side effects:
 *	See access() documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;		/* Path of file to access */
    int mode;			/* Permission setting. */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return access(path, mode);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjChdir --
 *
 *	This function replaces the library version of chdir().
 *
 * Results:
 *	See chdir() documentation.
 *
 * Side effects:
 *	See chdir() documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjChdir(pathPtr)
    Tcl_Obj *pathPtr;		/* Path to new working directory */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return chdir(path);
    }
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610

611
612
613

614


615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659

660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
 *
 * Side effects:
 *	See lstat() documentation.
 *
 *----------------------------------------------------------------------
 */

int 
TclpObjLstat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetNativeCwd --
 *
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form.  The
 *	result is either the given clientData, if the working directory
 *	hasn't changed, or a new clientData (owned by our caller),
 *	giving the new native path, or NULL if the current directory
 *	could not be determined.  If NULL is returned, the caller can
 *	examine the standard posix error codes to determine the cause of
 *	the problem.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
TclpGetNativeCwd(clientData)
    ClientData clientData;
{
    char buffer[MAXPATHLEN+1];

#ifdef USEGETWD
    if (getwd(buffer) == NULL) {			/* INTL: Native. */
#else
    if (getcwd(buffer, MAXPATHLEN + 1) == NULL) {	/* INTL: Native. */
#endif

	return NULL;
    }
    if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) {

	/* No change to pwd */


	return clientData;
    } else {
	char *newCd = (char *) ckalloc((unsigned) 
				       (strlen(buffer) + 1));
	strcpy(newCd, buffer);
	return (ClientData) newCd;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetCwd --
 *
 *	This function replaces the library version of getcwd().
 *      (Obsolete function, only retained for old extensions which
 *      may call it directly).
 *      
 * Results:
 *	The result is a pointer to a string specifying the current
 *	directory, or NULL if the current directory could not be
 *	determined.  If NULL is returned, an error message is left in the
 *	interp's result.  Storage for the result string is allocated in
 *	bufferPtr; the caller must call Tcl_DStringFree() when the result
 *	is no longer needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclpGetCwd(interp, bufferPtr)
    Tcl_Interp *interp;		/* If non-NULL, used for error reporting. */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled
				 * with name of current directory. */
{
    char buffer[MAXPATHLEN+1];

#ifdef USEGETWD
    if (getwd(buffer) == NULL) {			/* INTL: Native. */
#else
    if (getcwd(buffer, MAXPATHLEN + 1) == NULL) {	/* INTL: Native. */
#endif

	if (interp != NULL) {
	    Tcl_AppendResult(interp,
		    "error getting working directory name: ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }
    return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpReadlink --
 *
 *	This function replaces the library version of readlink().
 *
 * Results:
 *	The result is a pointer to a string specifying the contents
 *	of the symbolic link given by 'path', or NULL if the symbolic
 *	link could not be read.  Storage for the result string is
 *	allocated in bufferPtr; the caller must call Tcl_DStringFree()
 *	when the result is no longer needed.
 *
 * Side effects:
 *	See readlink() documentation.
 *
 *---------------------------------------------------------------------------
 */

char *
TclpReadlink(path, linkPtr)
    CONST char *path;		/* Path of file to readlink (UTF-8). */
    Tcl_DString *linkPtr;	/* Uninitialized or free DString filled
				 * with contents of link (UTF-8). */
{
#ifndef DJGPP
    char link[MAXPATHLEN];
    int length;
    CONST char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
    length = readlink(native, link, sizeof(link));	/* INTL: Native. */
    Tcl_DStringFree(&ds);
    
    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
#else







|















|
|
|
|
|
|
<














|

|

>



>
|
>
>


|
<










|
|
|
|

|
|
|
|
|
<










|
|




|

|

>


















|
|
|
|
|










|
|










|







579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607

608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636

637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656

657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
 *
 * Side effects:
 *	See lstat() documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclpObjLstat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetNativeCwd --
 *
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form. The result
 *	is either the given clientData, if the working directory hasn't
 *	changed, or a new clientData (owned by our caller), giving the new
 *	native path, or NULL if the current directory could not be determined.
 *	If NULL is returned, the caller can examine the standard posix error
 *	codes to determine the cause of the problem.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
TclpGetNativeCwd(clientData)
    ClientData clientData;
{
    char buffer[MAXPATHLEN+1];

#ifdef USEGETWD
    if (getwd(buffer) == NULL)				/* INTL: Native. */
#else
    if (getcwd(buffer, MAXPATHLEN+1) == NULL)		/* INTL: Native. */
#endif
    {
	return NULL;
    }
    if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) {
	/*
	 * No change to pwd.
	 */

	return clientData;
    } else {
	char *newCd = (char *) ckalloc((unsigned) (strlen(buffer) + 1));

	strcpy(newCd, buffer);
	return (ClientData) newCd;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetCwd --
 *
 *	This function replaces the library version of getcwd(). (Obsolete
 *	function, only retained for old extensions which may call it
 *	directly).
 *
 * Results:
 *	The result is a pointer to a string specifying the current directory,
 *	or NULL if the current directory could not be determined. If NULL is
 *	returned, an error message is left in the interp's result. Storage for
 *	the result string is allocated in bufferPtr; the caller must call
 *	Tcl_DStringFree() when the result is no longer needed.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclpGetCwd(interp, bufferPtr)
    Tcl_Interp *interp;		/* If non-NULL, used for error reporting. */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled with
				 * name of current directory. */
{
    char buffer[MAXPATHLEN+1];

#ifdef USEGETWD
    if (getwd(buffer) == NULL)				/* INTL: Native. */
#else
    if (getcwd(buffer, MAXPATHLEN+1) == NULL)		/* INTL: Native. */
#endif
    {
	if (interp != NULL) {
	    Tcl_AppendResult(interp,
		    "error getting working directory name: ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }
    return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpReadlink --
 *
 *	This function replaces the library version of readlink().
 *
 * Results:
 *	The result is a pointer to a string specifying the contents of the
 *	symbolic link given by 'path', or NULL if the symbolic link could not
 *	be read. Storage for the result string is allocated in bufferPtr; the
 *	caller must call Tcl_DStringFree() when the result is no longer
 *	needed.
 *
 * Side effects:
 *	See readlink() documentation.
 *
 *---------------------------------------------------------------------------
 */

char *
TclpReadlink(path, linkPtr)
    CONST char *path;		/* Path of file to readlink (UTF-8). */
    Tcl_DString *linkPtr;	/* Uninitialized or free DString filled with
				 * contents of link (UTF-8). */
{
#ifndef DJGPP
    char link[MAXPATHLEN];
    int length;
    CONST char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
    length = readlink(native, link, sizeof(link));	/* INTL: Native. */
    Tcl_DStringFree(&ds);

    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
#else
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768

769
770
771

772
773
774
775
776
777
778
779
780


781


782
783
784

785
786
787
788

789
790
791
792
793

794


795
796
797
798
799
800
801
802
803

804


805
806
807

808
809
810
811

812
813
814
815

816
817
818
819
820

821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892

893
894
895
896

897


898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921

922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956

957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973

974
975

976


977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007

1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018

1019


1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041

1042
1043
1044
1045
1046
1047
1048








 *
 * Side effects:
 *	See stat() documentation.
 *
 *----------------------------------------------------------------------
 */

int 
TclpObjStat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return TclOSstat(path, bufPtr);
    }
}


#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    if (toPtr != NULL) {
	CONST char *src = Tcl_FSGetNativePath(pathPtr);
	CONST char *target = NULL;
	if (src == NULL) return NULL;
	
	/* 
	 * If we're making a symbolic link and the path is relative,
	 * then we must check whether it exists _relative_ to the
	 * directory in which the src is found (not relative to the
	 * current cwd which is just not relevant in this case).
	 * 
	 * If we're making a hard link, then a relative path is
	 * just converted to absolute relative to the cwd.
	 */

	if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
	  && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
	    Tcl_Obj *dirPtr, *absPtr;

	    dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
	    if (dirPtr == NULL) {
	        return NULL;
	    }
	    absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
	    Tcl_IncrRefCount(absPtr);
	    if (Tcl_FSAccess(absPtr, F_OK) == -1) {
		Tcl_DecrRefCount(absPtr);
		Tcl_DecrRefCount(dirPtr);


		/* target doesn't exist */


		errno = ENOENT;
	        return NULL;
	    }

	    /* 
	     * Target exists; we'll construct the relative
	     * path we want below.
	     */

	    Tcl_DecrRefCount(absPtr);
	    Tcl_DecrRefCount(dirPtr);
	} else {
	    target = Tcl_FSGetNativePath(toPtr);
	    if (access(target, F_OK) == -1) {

		/* target doesn't exist */


		errno = ENOENT;
		return NULL;
	    }
	    if (target == NULL) {
		return NULL;
	    }
	}
	
	if (access(src, F_OK) != -1) {

	    /* src exists */


	    errno = EEXIST;
	    return NULL;
	}

	/* 
	 * Check symbolic link flag first, since we prefer to
	 * create these.
	 */

	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    int targetLen;
	    Tcl_DString ds;
	    Tcl_Obj *transPtr;

	    /* 
	     * Now we don't want to link to the absolute, normalized path.
	     * Relative links are quite acceptable (but links to ~user
	     * are not -- these must be expanded first).
	     */

	    transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
	    if (transPtr == NULL) {
		return NULL;
	    }
	    target = Tcl_GetStringFromObj(transPtr, &targetLen);
	    target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
	    Tcl_DecrRefCount(transPtr);
	    
	    if (symlink(target, src) != 0) {
	        toPtr = NULL;
	    }
	    Tcl_DStringFree(&ds);
	} else if (linkAction & TCL_CREATE_HARD_LINK) {
	    if (link(target, src) != 0) {
		return NULL;
	    }
	} else {
	    errno = ENODEV;
	    return NULL;
	}
	return toPtr;
    } else {
	Tcl_Obj* linkPtr = NULL;

	char link[MAXPATHLEN];
	int length;
	Tcl_DString ds;
	Tcl_Obj *transPtr;
	
	transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    return NULL;
	}
	Tcl_DecrRefCount(transPtr);

	length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
	if (length < 0) {
	    return NULL;
	}

	Tcl_ExternalToUtfDString(NULL, link, length, &ds);
	linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), 
				   Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	if (linkPtr != NULL) {
	    Tcl_IncrRefCount(linkPtr);
	}
	return linkPtr;
    }
}

#endif


/*
 *---------------------------------------------------------------------------
 *
 * TclpFilesystemPathType --
 *
 *      This function is part of the native filesystem support, and
 *      returns the path type of the given path.  Right now it simply
 *      returns NULL.  In the future it could return specific path
 *      types, like 'nfs', 'samba', 'FAT32', etc.
 *
 * Results:
 *      NULL at present.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpFilesystemPathType(pathPtr)
    Tcl_Obj* pathPtr;
{

    /* All native paths are of the same type */


    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeToNormalized --
 *
 *      Convert native format to a normalized path object, with refCount
 *      of zero.
 *      
 *      Currently assumes all native paths are actually normalized
 *      already, so if the path given is not normalized this will
 *      actually just convert to a valid string path, but not
 *      necessarily a normalized one.
 *
 * Results:
 *      A valid normalized path.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
TclpNativeToNormalized(clientData)
    ClientData clientData;
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;
    int len;
    
    CONST char *copy;
    Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
    
    copy = Tcl_DStringValue(&ds);
    len = Tcl_DStringLength(&ds);

    objPtr = Tcl_NewStringObj(copy,len);
    Tcl_DStringFree(&ds);
    
    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeCreateNativeRep --
 *
 *      Create a native representation for the given path.
 *
 * Results:
 *      The nativePath representation.
 *
 * Side effects:
 *	Memory will be allocated.  The path may need to be normalized.
 *
 *---------------------------------------------------------------------------
 */

ClientData 
TclNativeCreateNativeRep(pathPtr)
    Tcl_Obj* pathPtr;
{
    char *nativePathPtr;
    Tcl_DString ds;
    Tcl_Obj* validPathPtr;
    int len;
    char *str;

    if (TclFSCwdIsNative()) {
	/* 
	 * The cwd is native, which means we can use the translated
	 * path without worrying about normalization (this will also
	 * usually be shorter so the utf-to-external conversion will
	 * be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
    } else {

	/* Make sure the normalized path is set */


	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc((unsigned) len);
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
	  
    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --
 *
 *      Duplicate the native representation.
 *
 * Results:
 *      The copied native representation, or NULL if it is not possible
 *      to copy the representation.
 *
 * Side effects:
 *	Memory will be allocated for the copy.
 *
 *---------------------------------------------------------------------------
 */

ClientData 
TclNativeDupInternalRep(clientData)
    ClientData clientData;
{
    char *copy;
    size_t len;

    if (clientData == NULL) {
	return NULL;
    }


    /* ascii representation when running on Unix */


    len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
    
    copy = (char *) ckalloc(len);
    memcpy((VOID*)copy, (VOID*)clientData, len);
    return (ClientData)copy;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpUtime --
 *
 *	Set the modification date for a file.
 *
 * Results:
 *	0 on success, -1 on error.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpUtime(pathPtr, tval)
    Tcl_Obj *pathPtr;      /* File to modify */
    struct utimbuf *tval;  /* New modification date structure */
{
    return utime(Tcl_FSGetNativePath(pathPtr),tval);
}















|












<


|









|
|
|
|
|
|
|
|
|

>

|

>


|






>
>
|
>
>

|

>
|
|
<

>





>
|
>
>







|

>
|
>
>



>
|
|
<

>




>
|

|
|

>







|

|


















|












|
|







<
|
<






|
|
|
|


|






>




>
|
>
>








|
|
|
|
|
<
|


|






>
|






|


|





|








|


|






>
|










|
|
|
|
<

>


>
|
>
>










|









|


|
|






>
|










>
|
>
>
|
|

|


















>
|

|
|

|

>
>
>
>
>
>
>
>
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763

764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810

811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840

841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903

904

905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945

946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007

1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
 *
 * Side effects:
 *	See stat() documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclpObjStat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return TclOSstat(path, bufPtr);
    }
}


#ifdef S_IFLNK

Tcl_Obj*
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    if (toPtr != NULL) {
	CONST char *src = Tcl_FSGetNativePath(pathPtr);
	CONST char *target = NULL;
	if (src == NULL) return NULL;

	/*
	 * If we're making a symbolic link and the path is relative, then we
	 * must check whether it exists _relative_ to the directory in which
	 * the src is found (not relative to the current cwd which is just not
	 * relevant in this case).
	 *
	 * If we're making a hard link, then a relative path is just converted
	 * to absolute relative to the cwd.
	 */

	if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
		&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
	    Tcl_Obj *dirPtr, *absPtr;

	    dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
	    if (dirPtr == NULL) {
		return NULL;
	    }
	    absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
	    Tcl_IncrRefCount(absPtr);
	    if (Tcl_FSAccess(absPtr, F_OK) == -1) {
		Tcl_DecrRefCount(absPtr);
		Tcl_DecrRefCount(dirPtr);

		/*
		 * Target doesn't exist.
		 */

		errno = ENOENT;
		return NULL;
	    }

	    /*
	     * Target exists; we'll construct the relative path we want below.

	     */

	    Tcl_DecrRefCount(absPtr);
	    Tcl_DecrRefCount(dirPtr);
	} else {
	    target = Tcl_FSGetNativePath(toPtr);
	    if (access(target, F_OK) == -1) {
		/*
		 * Target doesn't exist.
		 */

		errno = ENOENT;
		return NULL;
	    }
	    if (target == NULL) {
		return NULL;
	    }
	}

	if (access(src, F_OK) != -1) {
	    /*
	     * Src exists.
	     */

	    errno = EEXIST;
	    return NULL;
	}

	/*
	 * Check symbolic link flag first, since we prefer to create these.

	 */

	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    int targetLen;
	    Tcl_DString ds;
	    Tcl_Obj *transPtr;

	    /*
	     * Now we don't want to link to the absolute, normalized path.
	     * Relative links are quite acceptable (but links to ~user are not
	     * -- these must be expanded first).
	     */

	    transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
	    if (transPtr == NULL) {
		return NULL;
	    }
	    target = Tcl_GetStringFromObj(transPtr, &targetLen);
	    target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
	    Tcl_DecrRefCount(transPtr);

	    if (symlink(target, src) != 0) {
		toPtr = NULL;
	    }
	    Tcl_DStringFree(&ds);
	} else if (linkAction & TCL_CREATE_HARD_LINK) {
	    if (link(target, src) != 0) {
		return NULL;
	    }
	} else {
	    errno = ENODEV;
	    return NULL;
	}
	return toPtr;
    } else {
	Tcl_Obj* linkPtr = NULL;

	char link[MAXPATHLEN];
	int length;
	Tcl_DString ds;
	Tcl_Obj *transPtr;

	transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    return NULL;
	}
	Tcl_DecrRefCount(transPtr);

	length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
	if (length < 0) {
	    return NULL;
	}

	Tcl_ExternalToUtfDString(NULL, link, length, &ds);
	linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
		Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	if (linkPtr != NULL) {
	    Tcl_IncrRefCount(linkPtr);
	}
	return linkPtr;
    }
}

#endif /* S_IFLNK */


/*
 *---------------------------------------------------------------------------
 *
 * TclpFilesystemPathType --
 *
 *	This function is part of the native filesystem support, and returns
 *	the path type of the given path. Right now it simply returns NULL. In
 *	the future it could return specific path types, like 'nfs', 'samba',
 *	'FAT32', etc.
 *
 * Results:
 *	NULL at present.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpFilesystemPathType(pathPtr)
    Tcl_Obj* pathPtr;
{
    /*
     * All native paths are of the same type.
     */

    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeToNormalized --
 *
 *	Convert native format to a normalized path object, with refCount of
 *	zero.
 *
 *	Currently assumes all native paths are actually normalized already, so
 *	if the path given is not normalized this will actually just convert to

 *	a valid string path, but not necessarily a normalized one.
 *
 * Results:
 *	A valid normalized path.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpNativeToNormalized(clientData)
    ClientData clientData;
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;
    int len;

    CONST char *copy;
    Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);

    copy = Tcl_DStringValue(&ds);
    len = Tcl_DStringLength(&ds);

    objPtr = Tcl_NewStringObj(copy,len);
    Tcl_DStringFree(&ds);

    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeCreateNativeRep --
 *
 *	Create a native representation for the given path.
 *
 * Results:
 *	The nativePath representation.
 *
 * Side effects:
 *	Memory will be allocated.  The path may need to be normalized.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeCreateNativeRep(pathPtr)
    Tcl_Obj* pathPtr;
{
    char *nativePathPtr;
    Tcl_DString ds;
    Tcl_Obj* validPathPtr;
    int len;
    char *str;

    if (TclFSCwdIsNative()) {
	/*
	 * The cwd is native, which means we can use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).

	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc((unsigned) len);
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --
 *
 *	Duplicate the native representation.
 *
 * Results:
 *	The copied native representation, or NULL if it is not possible to
 *	copy the representation.
 *
 * Side effects:
 *	Memory will be allocated for the copy.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeDupInternalRep(clientData)
    ClientData clientData;
{
    char *copy;
    size_t len;

    if (clientData == NULL) {
	return NULL;
    }

    /*
     * ASCII representation when running on Unix.
     */

    len = sizeof(char) + (strlen((CONST char*) clientData) * sizeof(char));

    copy = (char *) ckalloc(len);
    memcpy((VOID *) copy, (VOID *) clientData, len);
    return (ClientData)copy;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpUtime --
 *
 *	Set the modification date for a file.
 *
 * Results:
 *	0 on success, -1 on error.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclpUtime(pathPtr, tval)
    Tcl_Obj *pathPtr;		/* File to modify */
    struct utimbuf *tval;	/* New modification date structure */
{
    return utime(Tcl_FSGetNativePath(pathPtr), tval);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixInit.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
/*
 * tclUnixInit.c --
 *
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.53 2004/11/30 19:34:51 dgp Exp $
 */

#include "tclInt.h"
#include <stddef.h>
#include <locale.h>
#ifdef HAVE_LANGINFO
#include <langinfo.h>
#endif
#include <sys/resource.h>
#if defined(__FreeBSD__)
#   include <floatingpoint.h>
#endif
#if defined(__bsdi__)
#   include <sys/param.h>
#   if _BSDI_VERSION > 199501
#	include <dlfcn.h>
#   endif
#endif
#ifdef HAVE_CFBUNDLE
#include <CoreFoundation/CoreFoundation.h>
#endif

/*
 * Define this if you want to revert to the old behavior of
 * never checking the stack.
 */

#undef TCL_NO_STACK_CHECK

/*
 * Define this if you want to see a lot of output regarding
 * stack checking.
 */

#undef TCL_DEBUG_STACK_CHECK

/*
 * Values used to compute how much space is really available for Tcl's
 * use for the stack.
 *
 * NOTE: Now I have some idea why the maximum stack size must be
 * divided by 64 on FreeBSD with threads enabled to get a reasonably
 * correct value.
 *
 * The getrlimit() function is documented to return the maximum stack
 * size in bytes. However, with threads enabled, the pthread library
 * does bad things to the stack size limits.  First, the limits cannot
 * be changed. Second, they appear to be reported incorrectly by a
 * factor of about 64.
 *
 * The defines below may need to be adjusted if more platforms have
 * this broken behavior with threads enabled.
 */

#if defined(__FreeBSD__)
#   define TCL_MAGIC_STACK_DIVISOR	64
#   define TCL_RESERVED_STACK_PAGES	3
#endif










|


















|




|
|

>



|
<

>



|
|

|
|
<

|
|
|
|
<

|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51

52
53
54
55
56

57
58
59
60
61
62
63
64
65
66
/*
 * tclUnixInit.c --
 *
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.53.2.6 2005/08/15 18:14:14 dgp Exp $
 */

#include "tclInt.h"
#include <stddef.h>
#include <locale.h>
#ifdef HAVE_LANGINFO
#include <langinfo.h>
#endif
#include <sys/resource.h>
#if defined(__FreeBSD__)
#   include <floatingpoint.h>
#endif
#if defined(__bsdi__)
#   include <sys/param.h>
#   if _BSDI_VERSION > 199501
#	include <dlfcn.h>
#   endif
#endif
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#endif

/*
 * Define this if you want to revert to the old behavior of never checking the
 * stack.
 */

#undef TCL_NO_STACK_CHECK

/*
 * Define this if you want to see a lot of output regarding stack checking.

 */

#undef TCL_DEBUG_STACK_CHECK

/*
 * Values used to compute how much space is really available for Tcl's use for
 * the stack.
 *
 * NOTE: Now I have some idea why the maximum stack size must be divided by 64
 * on FreeBSD with threads enabled to get a reasonably correct value.

 *
 * The getrlimit() function is documented to return the maximum stack size in
 * bytes. However, with threads enabled, the pthread library does bad things
 * to the stack size limits.  First, the limits cannot be changed. Second,
 * they appear to be reported incorrectly by a factor of about 64.

 *
 * The defines below may need to be adjusted if more platforms have this
 * broken behavior with threads enabled.
 */

#if defined(__FreeBSD__)
#   define TCL_MAGIC_STACK_DIVISOR	64
#   define TCL_RESERVED_STACK_PAGES	3
#endif

90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133










134
135



136
137
138
139
140
141
142
#ifdef TCL_DEBUG_STACK_CHECK
#define STACK_DEBUG(args) printf args
#else
#define STACK_DEBUG(args) (void)0
#endif /* TCL_DEBUG_STACK_CHECK */

/*
 * Tcl tries to use standard and homebrew methods to guess the right
 * encoding on the platform.  However, there is always a final fallback,
 * and this value is it.  Make sure it is a real Tcl encoding.
 */

#ifndef TCL_DEFAULT_ENCODING
#define TCL_DEFAULT_ENCODING "iso8859-1"
#endif

/*
 * Default directory in which to look for Tcl library scripts.  The
 * symbol is defined by Makefile.
 */

static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY;

/*
 * Directory in which to look for packages (each package is typically
 * installed as a subdirectory of this directory).  The symbol is
 * defined by Makefile.
 */

static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH;

/*
 * The following table is used to map from Unix locale strings to
 * encoding files.  If HAVE_LANGINFO is defined, then this is a fallback
 * table when the result from nl_langinfo isn't a recognized encoding.
 * Otherwise this is the first list checked for a mapping from env
 * encoding to Tcl encoding name.
 */

typedef struct LocaleTable {
    CONST char *lang;
    CONST char *encoding;
} LocaleTable;











static CONST LocaleTable localeTable[] = {
	/* First list all the encoding files installed with Tcl */



    {"ascii",		"ascii"},
    {"big5",		"big5"},
    {"cp1250",		"cp1250"},
    {"cp1251",		"cp1251"},
    {"cp1252",		"cp1252"},
    {"cp1253",		"cp1253"},
    {"cp1254",		"cp1254"},







|
|
|







|
|






|
|





|
|
|
|
<







>
>
>
>
>
>
>
>
>
>

<
>
>
>







89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

143
144
145
146
147
148
149
150
151
152
#ifdef TCL_DEBUG_STACK_CHECK
#define STACK_DEBUG(args) printf args
#else
#define STACK_DEBUG(args) (void)0
#endif /* TCL_DEBUG_STACK_CHECK */

/*
 * Tcl tries to use standard and homebrew methods to guess the right encoding
 * on the platform. However, there is always a final fallback, and this value
 * is it. Make sure it is a real Tcl encoding.
 */

#ifndef TCL_DEFAULT_ENCODING
#define TCL_DEFAULT_ENCODING "iso8859-1"
#endif

/*
 * Default directory in which to look for Tcl library scripts. The symbol is
 * defined by Makefile.
 */

static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY;

/*
 * Directory in which to look for packages (each package is typically
 * installed as a subdirectory of this directory). The symbol is defined by
 * Makefile.
 */

static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH;

/*
 * The following table is used to map from Unix locale strings to encoding
 * files. If HAVE_LANGINFO is defined, then this is a fallback table when the
 * result from nl_langinfo isn't a recognized encoding. Otherwise this is the
 * first list checked for a mapping from env encoding to Tcl encoding name.

 */

typedef struct LocaleTable {
    CONST char *lang;
    CONST char *encoding;
} LocaleTable;

/*
 * The table below is sorted for the sake of doing binary searches on it. The
 * indenting reflects different categories of data. The leftmost data
 * represent the encoding names directly implemented by data files in Tcl's
 * default encoding directory. Indented by one TAB are the encoding names that
 * are common alternative spellings. Indented by two TABs are the accumulated
 * "bug fixes" that have been added to deal with the wide variability seen
 * among existing platforms.
 */

static CONST LocaleTable localeTable[] = {

	    {"",		"iso8859-1"},
		    {"ansi-1251",	"cp1251"},
	    {"ansi_x3.4-1968",	"iso8859-1"},
    {"ascii",		"ascii"},
    {"big5",		"big5"},
    {"cp1250",		"cp1250"},
    {"cp1251",		"cp1251"},
    {"cp1252",		"cp1252"},
    {"cp1253",		"cp1253"},
    {"cp1254",		"cp1254"},
165
166
167
168
169
170
171



172
173


174














175
















176
177














178


179
180
181
182
183
184
185
186
187
188
189
190
191
192






























193
194
195





196
197

198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
    {"cp949",		"cp949"},
    {"cp950",		"cp950"},
    {"dingbats",	"dingbats"},
    {"ebcdic",		"ebcdic"},
    {"euc-cn",		"euc-cn"},
    {"euc-jp",		"euc-jp"},
    {"euc-kr",		"euc-kr"},



    {"gb12345",		"gb12345"},
    {"gb1988",		"gb1988"},


    {"gb2312-raw",	"gb2312-raw"},














    {"gb2312",		"gb2312"},
















    {"iso2022-jp",	"iso2022-jp"},
    {"iso2022-kr",	"iso2022-kr"},














    {"iso2022",		"iso2022"},


    {"iso8859-1",	"iso8859-1"},
    {"iso8859-10",	"iso8859-10"},
    {"iso8859-13",	"iso8859-13"},
    {"iso8859-14",	"iso8859-14"},
    {"iso8859-15",	"iso8859-15"},
    {"iso8859-16",	"iso8859-16"},
    {"iso8859-2",	"iso8859-2"},
    {"iso8859-3",	"iso8859-3"},
    {"iso8859-4",	"iso8859-4"},
    {"iso8859-5",	"iso8859-5"},
    {"iso8859-6",	"iso8859-6"},
    {"iso8859-7",	"iso8859-7"},
    {"iso8859-8",	"iso8859-8"},
    {"iso8859-9",	"iso8859-9"},






























    {"jis0201",		"jis0201"},
    {"jis0208",		"jis0208"},
    {"jis0212",		"jis0212"},





    {"koi8-r",		"koi8-r"},
    {"koi8-u",		"koi8-u"},

    {"ksc5601",		"ksc5601"},
    {"macCentEuro",	"macCentEuro"},
    {"macCroatian",	"macCroatian"},
    {"macCyrillic",	"macCyrillic"},
    {"macDingbats",	"macDingbats"},
    {"macGreek",	"macGreek"},
    {"macIceland",	"macIceland"},
    {"macJapan",	"macJapan"},
    {"macRoman",	"macRoman"},
    {"macRomania",	"macRomania"},
    {"macThai",		"macThai"},
    {"macTurkish",	"macTurkish"},
    {"macUkraine",	"macUkraine"},
    {"shiftjis",	"shiftjis"},
    {"symbol",		"symbol"},
    {"tis-620",		"tis-620"},
	/* Next list a few common variants */
    {"maccenteuro",	"macCentEuro"},
    {"maccroatian",	"macCroatian"},
    {"maccyrillic",	"macCyrillic"},
    {"macdingbats",	"macDingbats"},
    {"macgreek",	"macGreek"},
    {"maciceland",	"macIceland"},
    {"macjapan",	"macJapan"},
    {"macroman",	"macRoman"},
    {"macromania",	"macRomania"},
    {"macthai",		"macThai"},
    {"macturkish",	"macTurkish"},
    {"macukraine",	"macUkraine"},
    {"iso-2022-jp",	"iso2022-jp"},
    {"iso-2022-kr",	"iso2022-kr"},
    {"iso-2022",	"iso2022"},
    {"iso-8859-1",	"iso8859-1"},
    {"iso-8859-10",	"iso8859-10"},
    {"iso-8859-13",	"iso8859-13"},
    {"iso-8859-14",	"iso8859-14"},
    {"iso-8859-15",	"iso8859-15"},
    {"iso-8859-16",	"iso8859-16"},
    {"iso-8859-2",	"iso8859-2"},
    {"iso-8859-3",	"iso8859-3"},
    {"iso-8859-4",	"iso8859-4"},
    {"iso-8859-5",	"iso8859-5"},
    {"iso-8859-6",	"iso8859-6"},
    {"iso-8859-7",	"iso8859-7"},
    {"iso-8859-8",	"iso8859-8"},
    {"iso-8859-9",	"iso8859-9"},
    {"ibm1250",		"cp1250"},
    {"ibm1251",		"cp1251"},
    {"ibm1252",		"cp1252"},
    {"ibm1253",		"cp1253"},
    {"ibm1254",		"cp1254"},
    {"ibm1255",		"cp1255"},
    {"ibm1256",		"cp1256"},
    {"ibm1257",		"cp1257"},
    {"ibm1258",		"cp1258"},
    {"ibm437",		"cp437"},
    {"ibm737",		"cp737"},
    {"ibm775",		"cp775"},
    {"ibm850",		"cp850"},
    {"ibm852",		"cp852"},
    {"ibm855",		"cp855"},
    {"ibm857",		"cp857"},
    {"ibm860",		"cp860"},
    {"ibm861",		"cp861"},
    {"ibm862",		"cp862"},
    {"ibm863",		"cp863"},
    {"ibm864",		"cp864"},
    {"ibm865",		"cp865"},
    {"ibm866",		"cp866"},
    {"ibm869",		"cp869"},
    {"ibm874",		"cp874"},
    {"ibm932",		"cp932"},
    {"ibm936",		"cp936"},
    {"ibm949",		"cp949"},
    {"ibm950",		"cp950"},
    {"",		"iso8859-1"},
    {"ansi_x3.4-1968",	"iso8859-1"},
	/* Finally, the accumulated bug fixes... */
#ifdef HAVE_LANGINFO
    {"gb2312-1980",	"gb2312"},
#ifdef __hpux
    {"SJIS",		"shiftjis"},
    {"eucjp",		"euc-jp"},
    {"euckr",		"euc-kr"},
    {"euctw",		"euc-cn"},

    {"greek8",		"cp869"},
    {"iso88591",	"iso8859-1"},
    {"iso88592",	"iso8859-2"},
    {"iso88595",	"iso8859-5"},
    {"iso88596",	"iso8859-6"},
    {"iso88597",	"iso8859-7"},
    {"iso88598",	"iso8859-8"},
    {"iso88599",	"iso8859-9"},
    {"iso885915",	"iso8859-15"},
    {"roman8",		"iso8859-1"},
    {"tis620",		"tis-620"},
    {"turkish8",	"cp857"},
    {"utf8",		"utf-8"},
#endif /* __hpux */
#endif /* HAVE_LANGINFO */

    {"ja_JP.SJIS",	"shiftjis"},
    {"ja_JP.EUC",	"euc-jp"},
    {"ja_JP.eucJP",     "euc-jp"},
    {"ja_JP.JIS",	"iso2022-jp"},
    {"ja_JP.mscode",	"shiftjis"},
    {"ja_JP.ujis",	"euc-jp"},
    {"ja_JP",		"euc-jp"},
    {"Ja_JP",		"shiftjis"},
    {"Jp_JP",		"shiftjis"},
    {"japan",		"euc-jp"},
#ifdef hpux
    {"japanese",	"shiftjis"},
    {"ja",		"shiftjis"},
#else
    {"japanese",	"euc-jp"},
    {"ja",		"euc-jp"},
#endif
    {"japanese.sjis",	"shiftjis"},
    {"japanese.euc",	"euc-jp"},
    {"japanese-sjis",	"shiftjis"},
    {"japanese-ujis",	"euc-jp"},

    {"ko",              "euc-kr"},
    {"ko_KR",           "euc-kr"},
    {"ko_KR.EUC",       "euc-kr"},
    {"ko_KR.euc",       "euc-kr"},
    {"ko_KR.eucKR",     "euc-kr"},
    {"korean",          "euc-kr"},

    {"ru",		"iso8859-5"},
    {"ru_RU",		"iso8859-5"},
    {"ru_SU",		"iso8859-5"},

    {"zh",		"cp936"},
    {"zh_CN.gb2312",	"euc-cn"},
    {"zh_CN.GB2312",	"euc-cn"},
    {"zh_CN.GBK",	"euc-cn"},
    {"zh_TW.Big5",	"big5"},
    {"zh_TW",		"euc-tw"},

    {NULL, NULL}
};

#ifndef TCL_NO_STACK_CHECK
static int		GetStackSize _ANSI_ARGS_((size_t *stackSizePtr));
#endif /* TCL_NO_STACK_CHECK */
#ifdef HAVE_CFBUNDLE
static int		MacOSXGetLibraryPath _ANSI_ARGS_((
			    Tcl_Interp *interp, int maxPathLen,
			    char *tclLibPath));
#endif /* HAVE_CFBUNDLE */


/*
 *---------------------------------------------------------------------------
 *
 * TclpInitPlatform --
 *







>
>
>


>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>














>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>
>
>
>


>

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












<
<
<
|
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
|
|
|
|
>
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
<
|
|
<





|



|







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
















296
297
298
299
300
301
302
303
304
305
306
307



308








309
310
































311



312

313
314
315
316
317












318




































319
320
321
322

323
324

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
    {"cp949",		"cp949"},
    {"cp950",		"cp950"},
    {"dingbats",	"dingbats"},
    {"ebcdic",		"ebcdic"},
    {"euc-cn",		"euc-cn"},
    {"euc-jp",		"euc-jp"},
    {"euc-kr",		"euc-kr"},
		    {"eucjp",		"euc-jp"},
		    {"euckr",		"euc-kr"},
		    {"euctw",		"euc-cn"},
    {"gb12345",		"gb12345"},
    {"gb1988",		"gb1988"},
    {"gb2312",		"gb2312"},
		    {"gb2312-1980",	"gb2312"},
    {"gb2312-raw",	"gb2312-raw"},
		    {"greek8",		"cp869"},
	    {"ibm1250",		"cp1250"},
	    {"ibm1251",		"cp1251"},
	    {"ibm1252",		"cp1252"},
	    {"ibm1253",		"cp1253"},
	    {"ibm1254",		"cp1254"},
	    {"ibm1255",		"cp1255"},
	    {"ibm1256",		"cp1256"},
	    {"ibm1257",		"cp1257"},
	    {"ibm1258",		"cp1258"},
	    {"ibm437",		"cp437"},
	    {"ibm737",		"cp737"},
	    {"ibm775",		"cp775"},
	    {"ibm850",		"cp850"},
	    {"ibm852",		"cp852"},
	    {"ibm855",		"cp855"},
	    {"ibm857",		"cp857"},
	    {"ibm860",		"cp860"},
	    {"ibm861",		"cp861"},
	    {"ibm862",		"cp862"},
	    {"ibm863",		"cp863"},
	    {"ibm864",		"cp864"},
	    {"ibm865",		"cp865"},
	    {"ibm866",		"cp866"},
	    {"ibm869",		"cp869"},
	    {"ibm874",		"cp874"},
	    {"ibm932",		"cp932"},
	    {"ibm936",		"cp936"},
	    {"ibm949",		"cp949"},
	    {"ibm950",		"cp950"},
	    {"iso-2022",	"iso2022"},
	    {"iso-2022-jp",	"iso2022-jp"},
	    {"iso-2022-kr",	"iso2022-kr"},
	    {"iso-8859-1",	"iso8859-1"},
	    {"iso-8859-10",	"iso8859-10"},
	    {"iso-8859-13",	"iso8859-13"},
	    {"iso-8859-14",	"iso8859-14"},
	    {"iso-8859-15",	"iso8859-15"},
	    {"iso-8859-16",	"iso8859-16"},
	    {"iso-8859-2",	"iso8859-2"},
	    {"iso-8859-3",	"iso8859-3"},
	    {"iso-8859-4",	"iso8859-4"},
	    {"iso-8859-5",	"iso8859-5"},
	    {"iso-8859-6",	"iso8859-6"},
	    {"iso-8859-7",	"iso8859-7"},
	    {"iso-8859-8",	"iso8859-8"},
	    {"iso-8859-9",	"iso8859-9"},
    {"iso2022",		"iso2022"},
    {"iso2022-jp",	"iso2022-jp"},
    {"iso2022-kr",	"iso2022-kr"},
    {"iso8859-1",	"iso8859-1"},
    {"iso8859-10",	"iso8859-10"},
    {"iso8859-13",	"iso8859-13"},
    {"iso8859-14",	"iso8859-14"},
    {"iso8859-15",	"iso8859-15"},
    {"iso8859-16",	"iso8859-16"},
    {"iso8859-2",	"iso8859-2"},
    {"iso8859-3",	"iso8859-3"},
    {"iso8859-4",	"iso8859-4"},
    {"iso8859-5",	"iso8859-5"},
    {"iso8859-6",	"iso8859-6"},
    {"iso8859-7",	"iso8859-7"},
    {"iso8859-8",	"iso8859-8"},
    {"iso8859-9",	"iso8859-9"},
		    {"iso88591",	"iso8859-1"},
		    {"iso885915",	"iso8859-15"},
		    {"iso88592",	"iso8859-2"},
		    {"iso88595",	"iso8859-5"},
		    {"iso88596",	"iso8859-6"},
		    {"iso88597",	"iso8859-7"},
		    {"iso88598",	"iso8859-8"},
		    {"iso88599",	"iso8859-9"},
#ifdef hpux
		    {"ja",		"shiftjis"},
#else
		    {"ja",		"euc-jp"},
#endif
		    {"ja_jp",		"euc-jp"},
		    {"ja_jp.euc",	"euc-jp"},
		    {"ja_jp.eucjp",	"euc-jp"},
		    {"ja_jp.jis",	"iso2022-jp"},
		    {"ja_jp.mscode",	"shiftjis"},
		    {"ja_jp.sjis",	"shiftjis"},
		    {"ja_jp.ujis",	"euc-jp"},
		    {"japan",		"euc-jp"},
#ifdef hpux
		    {"japanese",	"shiftjis"},
#else
		    {"japanese",	"euc-jp"},
#endif
		    {"japanese-sjis",	"shiftjis"},
		    {"japanese-ujis",	"euc-jp"},
		    {"japanese.euc",	"euc-jp"},
		    {"japanese.sjis",	"shiftjis"},
    {"jis0201",		"jis0201"},
    {"jis0208",		"jis0208"},
    {"jis0212",		"jis0212"},
		    {"jp_jp",		"shiftjis"},
		    {"ko",		"euc-kr"},
		    {"ko_kr",		"euc-kr"},
		    {"ko_kr.euc",	"euc-kr"},
		    {"ko_kw.euckw",	"euc-kr"},
    {"koi8-r",		"koi8-r"},
    {"koi8-u",		"koi8-u"},
		    {"korean",		"euc-kr"},
    {"ksc5601",		"ksc5601"},
















    {"maccenteuro",	"macCentEuro"},
    {"maccroatian",	"macCroatian"},
    {"maccyrillic",	"macCyrillic"},
    {"macdingbats",	"macDingbats"},
    {"macgreek",	"macGreek"},
    {"maciceland",	"macIceland"},
    {"macjapan",	"macJapan"},
    {"macroman",	"macRoman"},
    {"macromania",	"macRomania"},
    {"macthai",		"macThai"},
    {"macturkish",	"macTurkish"},
    {"macukraine",	"macUkraine"},



		    {"roman8",		"iso8859-1"},








		    {"ru",		"iso8859-5"},
		    {"ru_ru",		"iso8859-5"},
































		    {"ru_su",		"iso8859-5"},



    {"shiftjis",	"shiftjis"},

		    {"sjis",		"shiftjis"},
    {"symbol",		"symbol"},
    {"tis-620",		"tis-620"},
		    {"tis620",		"tis-620"},
		    {"turkish8",	"cp857"},












		    {"utf8",		"utf-8"},




































		    {"zh",		"cp936"},
		    {"zh_cn.gb2312",	"euc-cn"},
		    {"zh_cn.gbk",	"euc-cn"},
		    {"zh_cz.gb2312",	"euc-cn"},

		    {"zh_tw",		"euc-tw"},
		    {"zh_tw.big5",	"big5"},

};

#ifndef TCL_NO_STACK_CHECK
static int		GetStackSize _ANSI_ARGS_((size_t *stackSizePtr));
#endif /* TCL_NO_STACK_CHECK */
#ifdef HAVE_COREFOUNDATION
static int		MacOSXGetLibraryPath _ANSI_ARGS_((
			    Tcl_Interp *interp, int maxPathLen,
			    char *tclLibPath));
#endif /* HAVE_COREFOUNDATION */


/*
 *---------------------------------------------------------------------------
 *
 * TclpInitPlatform --
 *
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

536


537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584





























585
586
587
588
589
590
591
592
593
594
595
596
597
598
599

600
601
602
603

604


605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630

631
632
633
634
635
636
637
638
639
640
641
642
643
644

645

646
647

648

649
650
651
652
653
654
655
656
657
658

659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
	open("/dev/null", O_WRONLY);
    }
    if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
	open("/dev/null", O_WRONLY);
    }

    /*
     * The code below causes SIGPIPE (broken pipe) errors to
     * be ignored.  This is needed so that Tcl processes don't
     * die if they create child processes (e.g. using "exec" or
     * "open") that terminate prematurely.  The signal handler
     * is only set up when the first interpreter is created;
     * after this the application can override the handler with
     * a different one of its own, if it wants.
     */

#ifdef SIGPIPE
    (void) signal(SIGPIPE, SIG_IGN);
#endif /* SIGPIPE */

#ifdef __FreeBSD__
    fpsetround(FP_RN);
    (void) fpsetmask(0L);
#endif

#if defined(__bsdi__) && (_BSDI_VERSION > 199501)
    /*
     * Find local symbols. Don't report an error if we fail.
     */
    (void) dlopen (NULL, RTLD_NOW);			/* INTL: Native. */
#endif

    /*
     * Initialize the C library's locale subsystem.  This is required
     * for input methods to work properly on X11.  We only do this for
     * LC_CTYPE because that's the necessary one, and we don't want to
     * affect LC_TIME here.  The side effect of setting the default
     * locale should be to load any locale specific modules that are
     * needed by X.  [BUG: 5422 3345 4236 2522 2521].
     */

    setlocale(LC_CTYPE, "");

    /*
     * In case the initial locale is not "C", ensure that the numeric
     * processing is done in "C" locale regardless.  This is needed because
     * Tcl relies on routines like strtod, but should not have locale
     * dependent behavior.
     */

    setlocale(LC_NUMERIC, "C");
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpInitLibraryPath --
 *
 *      This is the fallback routine that sets the library path
 *      if the application has not set one by the first time
 *      it is needed.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Sets the library path to an initial value.  
 *
 *-------------------------------------------------------------------------
 */                   

void
TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr, *objPtr;
    CONST char *str;
    Tcl_DString buffer, ds;
    int pathc;
    CONST char **pathv;
    char installLib[LIBRARY_SIZE];

    Tcl_DStringInit(&ds);
    pathPtr = Tcl_NewObj();

    /*
     * Initialize the substrings used when locating an executable.  The
     * installLib variable computes the path as though the executable
     * is installed.
     */

    sprintf(installLib, "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable.
     * If the last dirname in the TCL_LIBRARY path does not match the
     * last dirname in the installLib variable, use the last dir name
     * of installLib in addition to the orginal TCL_LIBRARY path.
     */

    str = getenv("TCL_LIBRARY");			/* INTL: Native. */
    Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
    str = Tcl_DStringValue(&buffer);

    if ((str != NULL) && (str[0] != '\0')) {
	/*
	 * If TCL_LIBRARY is set, search there.
	 */

	objPtr = Tcl_NewStringObj(str, -1);
	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);

	Tcl_SplitPath(str, &pathc, &pathv);
	if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
	    /*
	     * If TCL_LIBRARY is set but refers to a different tcl
	     * installation than the current version, try fiddling with the
	     * specified directory to make it refer to this installation by
	     * removing the old "tclX.Y" and substituting the current
	     * version string.
	     */

	    pathv[pathc - 1] = installLib + 4;
	    str = Tcl_JoinPath(pathc, pathv, &ds);
	    objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	ckfree((char *) pathv);
    }

    /*
     * Finally, look for the library relative to the compiled-in path.
     * This is needed when users install Tcl with an exec-prefix that
     * is different from the prtefix.
     */

    {
#ifdef HAVE_CFBUNDLE
    char tclLibPath[MAXPATHLEN + 1];

    if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
        str = tclLibPath;
    } else
#endif /* HAVE_CFBUNDLE */
    {

	/* TODO: Pull this value from the TIP 59 table */


        str = defaultLibraryDir;
    }
    if (str[0] != '\0') {
        objPtr = Tcl_NewStringObj(str, -1);
        Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
    }
    }
    Tcl_DStringFree(&buffer);

    *encodingPtr = Tcl_GetEncoding(NULL, NULL);
    str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
    *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
    memcpy((VOID *) *valuePtr, (VOID *) str, (size_t)(*lengthPtr)+1);
    Tcl_DecrRefCount(pathPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetInitialEncodings --
 *
 *	Based on the locale, determine the encoding of the operating
 *	system and the default encoding for newly opened files.
 *
 *	Called at process initialization time, and part way through
 *	startup, we verify that the initial encodings were correctly
 *	setup.  Depending on Tcl's environment, there may not have been
 *	enough information first time through (above).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The Tcl library path is converted from native encoding to UTF-8,
 *	on the first call, and the encodings may be changed on first or
 *	second call.
 *
 *---------------------------------------------------------------------------
 */

void
TclpSetInitialEncodings()
{
    Tcl_DString encodingName;
    Tcl_SetSystemEncoding(NULL,
	    TclpGetEncodingNameFromEnvironment(&encodingName));
    Tcl_DStringFree(&encodingName);
}






























CONST char *
TclpGetEncodingNameFromEnvironment(bufPtr)
    Tcl_DString *bufPtr;
{
    CONST char *encoding;
    int i;

    Tcl_DStringInit(bufPtr);

    /*
     * Determine the current encoding from the LC_* or LANG environment
     * variables.  We previously used setlocale() to determine the locale,
     * but this does not work on some systems (e.g. Linux/i386 RH 5.0).
     */

#ifdef HAVE_LANGINFO
    if (setlocale(LC_CTYPE, "") != NULL) {
	Tcl_DString ds;


	/* Use a DString so we can modify case. */


	Tcl_DStringInit(&ds);
	encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
	Tcl_UtfToLower(Tcl_DStringValue(&ds));
	/* Check whether it's a known encoding... */
	if (NULL == Tcl_GetEncoding(NULL, encoding)) {
	    /* ... or in the table if encodings we *should* know */
	    for (i = 0; localeTable[i].lang != NULL; i++) {
		if (strcmp(localeTable[i].lang, encoding) == 0) {
		    Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1);
		    break;
		}
	    }
	} else {
	    Tcl_DStringAppend(bufPtr, encoding, -1);
	}
	Tcl_DStringFree(&ds);
	if (Tcl_DStringLength(bufPtr)) {
	    return Tcl_DStringValue(bufPtr);
	}
    }
#endif /* HAVE_LANGINFO */

    /*
     * Classic fallback check.  This tries a homebrew algorithm to
     * determine what encoding should be used based on env vars.
     */

    encoding = getenv("LC_ALL");

    if (encoding == NULL || encoding[0] == '\0') {
	encoding = getenv("LC_CTYPE");
    }
    if (encoding == NULL || encoding[0] == '\0') {
	encoding = getenv("LANG");
    }
    if (encoding == NULL || encoding[0] == '\0') {
	encoding = NULL;
    }

    if (encoding != NULL) {
	CONST char *p;



	/* Check whether it's a known encoding... */
	if (NULL == Tcl_GetEncoding(NULL, encoding)) {

	    /* ... or in the table if encodings we *should* know */

	    for (i = 0; localeTable[i].lang != NULL; i++) {
		if (strcmp(localeTable[i].lang, encoding) == 0) {
		    Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1);
		    break;
		}
	    }
	} else {
	    Tcl_DStringAppend(bufPtr, encoding, -1);
	}
	if (Tcl_DStringLength(bufPtr)) {

	    return Tcl_DStringValue(bufPtr);
	}

	/*
	 * We didn't recognize the full value as an encoding name.
	 * If there is an encoding subfield, we can try to guess from that.
	 */

	for (p = encoding; *p != '\0'; p++) {
	    if (*p == '.') {
		p++;
		break;
	    }
	}
	if (*p != '\0') {
	    Tcl_DString ds;
	    Tcl_DStringInit(&ds);
	    encoding = Tcl_DStringAppend(&ds, p, -1);
	    Tcl_UtfToLower(Tcl_DStringValue(&ds));

	    /* Check whether it's a known encoding... */
	    if (NULL == Tcl_GetEncoding(NULL, encoding)) {
		/* ... or in the table if encodings we *should* know */
		for (i = 0; localeTable[i].lang != NULL; i++) {
		    if (strcmp(localeTable[i].lang, encoding) == 0) {
			Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1);
			break;
		    }
		}
	    } else {
		Tcl_DStringAppend(bufPtr, encoding, -1);
	    }
	    Tcl_DStringFree(&ds);
	    if (Tcl_DStringLength(bufPtr)) {
		return Tcl_DStringValue(bufPtr);
	    }

	}
    }
    return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetVariables --
 *
 *	Performs platform-specific interpreter initialization related to
 *	the tcl_library and tcl_platform variables, and other platform-
 *	specific things.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets "tclDefaultLibrary", "tcl_pkgPath", and "tcl_platform" Tcl
 *	variables.







|
|
|
<
|
|
|

















>

|
|
|
|
|
|






|
|
|










|
|
<


|


|


|



















|
|
|





|
|
|
|




















|
|












|
|
|



|
|

|
|
|
|
|
>
|
>
>
|
|
|
|
|
|















|
|

|
|
|
|





|
|
|












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|





|
|

>




>
|
>
>



<
|
<
|
<
|
<
<
<
|










|
|

>














>

>
|
|
>
|
>
|
<
|
<
<
<
|



>




|
|









|
<
|
<
|
<
|
<
<
<
|
<
|
|
<
<
<
|
|
|
<
<










|
|
|







373
374
375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431

432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

628

629

630



631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668

669



670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690

691

692

693



694

695
696



697
698
699


700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
	open("/dev/null", O_WRONLY);
    }
    if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
	open("/dev/null", O_WRONLY);
    }

    /*
     * The code below causes SIGPIPE (broken pipe) errors to be ignored.  This
     * is needed so that Tcl processes don't die if they create child
     * processes (e.g. using "exec" or "open") that terminate prematurely.

     * The signal handler is only set up when the first interpreter is
     * created; after this the application can override the handler with a
     * different one of its own, if it wants.
     */

#ifdef SIGPIPE
    (void) signal(SIGPIPE, SIG_IGN);
#endif /* SIGPIPE */

#ifdef __FreeBSD__
    fpsetround(FP_RN);
    (void) fpsetmask(0L);
#endif

#if defined(__bsdi__) && (_BSDI_VERSION > 199501)
    /*
     * Find local symbols. Don't report an error if we fail.
     */
    (void) dlopen (NULL, RTLD_NOW);			/* INTL: Native. */
#endif

    /*
     * Initialize the C library's locale subsystem. This is required for input
     * methods to work properly on X11. We only do this for LC_CTYPE because
     * that's the necessary one, and we don't want to affect LC_TIME here.
     * The side effect of setting the default locale should be to load any
     * locale specific modules that are needed by X. [BUG: 5422 3345 4236 2522
     * 2521].
     */

    setlocale(LC_CTYPE, "");

    /*
     * In case the initial locale is not "C", ensure that the numeric
     * processing is done in "C" locale regardless. This is needed because Tcl
     * relies on routines like strtod, but should not have locale dependent
     * behavior.
     */

    setlocale(LC_NUMERIC, "C");
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpInitLibraryPath --
 *
 *	This is the fallback routine that sets the library path if the
 *	application has not set one by the first time it is needed.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the library path to an initial value.
 *
 *-------------------------------------------------------------------------
 */

void
TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr, *objPtr;
    CONST char *str;
    Tcl_DString buffer, ds;
    int pathc;
    CONST char **pathv;
    char installLib[LIBRARY_SIZE];

    Tcl_DStringInit(&ds);
    pathPtr = Tcl_NewObj();

    /*
     * Initialize the substrings used when locating an executable. The
     * installLib variable computes the path as though the executable is
     * installed.
     */

    sprintf(installLib, "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the orginal TCL_LIBRARY path.
     */

    str = getenv("TCL_LIBRARY");			/* INTL: Native. */
    Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
    str = Tcl_DStringValue(&buffer);

    if ((str != NULL) && (str[0] != '\0')) {
	/*
	 * If TCL_LIBRARY is set, search there.
	 */

	objPtr = Tcl_NewStringObj(str, -1);
	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);

	Tcl_SplitPath(str, &pathc, &pathv);
	if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
	    /*
	     * If TCL_LIBRARY is set but refers to a different tcl
	     * installation than the current version, try fiddling with the
	     * specified directory to make it refer to this installation by
	     * removing the old "tclX.Y" and substituting the current version
	     * string.
	     */

	    pathv[pathc - 1] = installLib + 4;
	    str = Tcl_JoinPath(pathc, pathv, &ds);
	    objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	ckfree((char *) pathv);
    }

    /*
     * Finally, look for the library relative to the compiled-in path. This is
     * needed when users install Tcl with an exec-prefix that is different
     * from the prtefix.
     */

    {
#ifdef HAVE_COREFOUNDATION
	char tclLibPath[MAXPATHLEN + 1];

	if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
	    str = tclLibPath;
	} else
#endif /* HAVE_COREFOUNDATION */
	{
	    /*
	     * TODO: Pull this value from the TIP 59 table.
	     */

	    str = defaultLibraryDir;
	}
	if (str[0] != '\0') {
	    objPtr = Tcl_NewStringObj(str, -1);
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	}
    }
    Tcl_DStringFree(&buffer);

    *encodingPtr = Tcl_GetEncoding(NULL, NULL);
    str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
    *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
    memcpy((VOID *) *valuePtr, (VOID *) str, (size_t)(*lengthPtr)+1);
    Tcl_DecrRefCount(pathPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetInitialEncodings --
 *
 *	Based on the locale, determine the encoding of the operating system
 *	and the default encoding for newly opened files.
 *
 *	Called at process initialization time, and part way through startup,
 *	we verify that the initial encodings were correctly setup. Depending
 *	on Tcl's environment, there may not have been enough information first
 *	time through (above).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The Tcl library path is converted from native encoding to UTF-8, on
 *	the first call, and the encodings may be changed on first or second
 *	call.
 *
 *---------------------------------------------------------------------------
 */

void
TclpSetInitialEncodings()
{
    Tcl_DString encodingName;
    Tcl_SetSystemEncoding(NULL,
	    TclpGetEncodingNameFromEnvironment(&encodingName));
    Tcl_DStringFree(&encodingName);
}

void
TclpSetInterfaces()
{
	/* do nothing */
}

static CONST char *
SearchKnownEncodings(encoding)
    CONST char *encoding;
{
    int left = 0;
    int right = sizeof(localeTable)/sizeof(LocaleTable);

    while (left <= right) {
	int test = (left + right)/2;
	int code = strcmp(localeTable[test].lang, encoding);

	if (code == 0) {
	    return localeTable[test].encoding;
	}
	if (code < 0) {
	    left = test+1;
	} else {
	    right = test-1;
	}
    }
    return NULL;
}

CONST char *
TclpGetEncodingNameFromEnvironment(bufPtr)
    Tcl_DString *bufPtr;
{
    CONST char *encoding;
    CONST char *knownEncoding;

    Tcl_DStringInit(bufPtr);

    /*
     * Determine the current encoding from the LC_* or LANG environment
     * variables.  We previously used setlocale() to determine the locale, but
     * this does not work on some systems (e.g. Linux/i386 RH 5.0).
     */

#ifdef HAVE_LANGINFO
    if (setlocale(LC_CTYPE, "") != NULL) {
	Tcl_DString ds;

	/*
	 * Use a DString so we can modify case.
	 */

	Tcl_DStringInit(&ds);
	encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
	Tcl_UtfToLower(Tcl_DStringValue(&ds));

	knownEncoding = SearchKnownEncodings(encoding);

	if (knownEncoding != NULL) {

	    Tcl_DStringAppend(bufPtr, knownEncoding, -1);



	} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
	    Tcl_DStringAppend(bufPtr, encoding, -1);
	}
	Tcl_DStringFree(&ds);
	if (Tcl_DStringLength(bufPtr)) {
	    return Tcl_DStringValue(bufPtr);
	}
    }
#endif /* HAVE_LANGINFO */

    /*
     * Classic fallback check. This tries a homebrew algorithm to determine
     * what encoding should be used based on env vars.
     */

    encoding = getenv("LC_ALL");

    if (encoding == NULL || encoding[0] == '\0') {
	encoding = getenv("LC_CTYPE");
    }
    if (encoding == NULL || encoding[0] == '\0') {
	encoding = getenv("LANG");
    }
    if (encoding == NULL || encoding[0] == '\0') {
	encoding = NULL;
    }

    if (encoding != NULL) {
	CONST char *p;
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	p = encoding;
	encoding = Tcl_DStringAppend(&ds, p, -1);
	Tcl_UtfToLower(Tcl_DStringValue(&ds));

	knownEncoding = SearchKnownEncodings(encoding);
	if (knownEncoding != NULL) {

	    Tcl_DStringAppend(bufPtr, knownEncoding, -1);



	} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
	    Tcl_DStringAppend(bufPtr, encoding, -1);
	}
	if (Tcl_DStringLength(bufPtr)) {
	    Tcl_DStringFree(&ds);
	    return Tcl_DStringValue(bufPtr);
	}

	/*
	 * We didn't recognize the full value as an encoding name. If there is
	 * an encoding subfield, we can try to guess from that.
	 */

	for (p = encoding; *p != '\0'; p++) {
	    if (*p == '.') {
		p++;
		break;
	    }
	}
	if (*p != '\0') {
	    knownEncoding = SearchKnownEncodings(p);

	    if (knownEncoding != NULL) {

		Tcl_DStringAppend(bufPtr, knownEncoding, -1);

	    } else if (NULL != Tcl_GetEncoding(NULL, p)) {



		Tcl_DStringAppend(bufPtr, p, -1);

	    }
	}



	Tcl_DStringFree(&ds);
	if (Tcl_DStringLength(bufPtr)) {
	    return Tcl_DStringValue(bufPtr);


	}
    }
    return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetVariables --
 *
 *	Performs platform-specific interpreter initialization related to the
 *	tcl_library and tcl_platform variables, and other platform-specific
 *	things.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets "tclDefaultLibrary", "tcl_pkgPath", and "tcl_platform" Tcl
 *	variables.
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744

745
746
747


748


749
750


751
752
753
754
755
756
757
758

759
760

761

762
763
764
765
766
767
768
769
770
771
772
773

774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798

799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823

824
825
826


827
828
829
830
831
832
833
#ifndef NO_UNAME
    struct utsname name;
#endif
    int unameOK;
    CONST char *user;
    Tcl_DString ds;

#ifdef HAVE_CFBUNDLE
    char tclLibPath[MAXPATHLEN + 1];

    if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
        CONST char *str;
        Tcl_DString ds;
        CFBundleRef bundleRef;

        Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath,
                TCL_GLOBAL_ONLY);
        Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
                TCL_GLOBAL_ONLY);
        Tcl_SetVar(interp, "tcl_pkgPath", " ",
                TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);

        str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
        if ((str != NULL) && (str[0] != '\0')) {
            char *p = Tcl_DStringValue(&ds);


            /* convert DYLD_FRAMEWORK_PATH from colon to space separated */


            do {
                if(*p == ':') *p = ' ';


            } while (*p++);
            Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
                    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
            Tcl_SetVar(interp, "tcl_pkgPath", " ",
                    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
            Tcl_DStringFree(&ds);
        }
        if ((bundleRef = CFBundleGetMainBundle())) {

            CFURLRef frameworksURL;
            Tcl_StatBuf statBuf;

            if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) {

                if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
                            tclLibPath, MAXPATHLEN) &&
                        ! TclOSstat(tclLibPath, &statBuf) &&
                        S_ISDIR(statBuf.st_mode)) {
                    Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
                            TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
                    Tcl_SetVar(interp, "tcl_pkgPath", " ",
                            TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
                }
                CFRelease(frameworksURL);
            }
            if((frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef))) {

                if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
                            tclLibPath, MAXPATHLEN) &&
                        ! TclOSstat(tclLibPath, &statBuf) &&
                        S_ISDIR(statBuf.st_mode)) {
                    Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
                            TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
                    Tcl_SetVar(interp, "tcl_pkgPath", " ",
                            TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
                }
                CFRelease(frameworksURL);
            }
        }
        Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
                TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
    } else
#endif /* HAVE_CFBUNDLE */
    {
        Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
    }

#ifdef DJGPP
    Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif

    unameOK = 0;
#ifndef NO_UNAME
    if (uname(&name) >= 0) {
	CONST char *native;

	unameOK = 1;

	native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds);
	Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
	Tcl_DStringFree(&ds);

	/*
	 * The following code is a special hack to handle differences in
	 * the way version information is returned by uname.  On most
	 * systems the full version number is available in name.release.
	 * However, under AIX the major version number is in
	 * name.version and the minor version number is in name.release.
	 */

	if ((strchr(name.release, '.') != NULL)
		|| !isdigit(UCHAR(name.version[0]))) {	/* INTL: digit */
	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
		    TCL_GLOBAL_ONLY);
	} else {
#ifdef DJGPP

		/* For some obscure reason DJGPP puts major version into
		 * name.release and minor into name.version. As of DJGPP 2.04
		 * this is documented in djgpp libc.info file*/


	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
		    TCL_GLOBAL_ONLY);
	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
		    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
		    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#else







|



|
|
|

|
<
|
<
|
|
>
|
|
|
>
>
|
>
>
|
|
>
>
|
|
|
|
|
|
|
|
>
|
|
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|







>












|
|
|
|
|








>
|
|
|
>
>







728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743

744

745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
#ifndef NO_UNAME
    struct utsname name;
#endif
    int unameOK;
    CONST char *user;
    Tcl_DString ds;

#ifdef HAVE_COREFOUNDATION
    char tclLibPath[MAXPATHLEN + 1];

    if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
	CONST char *str;
	Tcl_DString ds;
	CFBundleRef bundleRef;

	Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY);

	Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);

	Tcl_SetVar(interp, "tcl_pkgPath", " ",
		TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);

	str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
	if ((str != NULL) && (str[0] != '\0')) {
	    char *p = Tcl_DStringValue(&ds);

	    /*
	     * Convert DYLD_FRAMEWORK_PATH from colon to space separated.
	     */

	    do {
		if (*p == ':') {
		    *p = ' ';
		}
	    } while (*p++);
	    Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
		    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
	    Tcl_SetVar(interp, "tcl_pkgPath", " ",
		    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
	    Tcl_DStringFree(&ds);
	}
	bundleRef = CFBundleGetMainBundle();
	if (bundleRef) {
	    CFURLRef frameworksURL;
	    Tcl_StatBuf statBuf;

	    frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef);
	    if (frameworksURL) {
		if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
			(unsigned char*) tclLibPath, MAXPATHLEN) &&
			! TclOSstat(tclLibPath, &statBuf) &&
			S_ISDIR(statBuf.st_mode)) {
		    Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
			    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
		    Tcl_SetVar(interp, "tcl_pkgPath", " ",
			    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
		}
		CFRelease(frameworksURL);
	    }
	    frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef);
	    if (frameworksURL) {
		if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
			(unsigned char*) tclLibPath, MAXPATHLEN) &&
			! TclOSstat(tclLibPath, &statBuf) &&
			S_ISDIR(statBuf.st_mode)) {
		    Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
			    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
		    Tcl_SetVar(interp, "tcl_pkgPath", " ",
			    TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
		}
		CFRelease(frameworksURL);
	    }
	}
	Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
		TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
    } else
#endif /* HAVE_COREFOUNDATION */
    {
	Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
    }

#ifdef DJGPP
    Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif

    unameOK = 0;
#ifndef NO_UNAME
    if (uname(&name) >= 0) {
	CONST char *native;

	unameOK = 1;

	native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds);
	Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
	Tcl_DStringFree(&ds);

	/*
	 * The following code is a special hack to handle differences in the
	 * way version information is returned by uname. On most systems the
	 * full version number is available in name.release. However, under
	 * AIX the major version number is in name.version and the minor
	 * version number is in name.release.
	 */

	if ((strchr(name.release, '.') != NULL)
		|| !isdigit(UCHAR(name.version[0]))) {	/* INTL: digit */
	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
		    TCL_GLOBAL_ONLY);
	} else {
#ifdef DJGPP
	    /*
	     * For some obscure reason DJGPP puts major version into
	     * name.release and minor into name.version. As of DJGPP 2.04 this
	     * is documented in djgpp libc.info file.
	     */

	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
		    TCL_GLOBAL_ONLY);
	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
		    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
	    Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
		    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#else
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
    if (!unameOK) {
	Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY);
	Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY);
	Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY);
    }

    /*
     * Copy USER or LOGNAME environment variable into tcl_platform(user)
     */

    Tcl_DStringInit(&ds);
    user = TclGetEnv("USER", &ds);
    if (user == NULL) {
	user = TclGetEnv("LOGNAME", &ds);
	if (user == NULL) {
	    user = "";
	}
    }
    Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&ds);

}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name.  On Unix this
 *	routine is case sensetive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|












<







|
|


|
|
|
|
<







864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883

884
885
886
887
888
889
890
891
892
893
894
895
896
897
898

899
900
901
902
903
904
905
    if (!unameOK) {
	Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY);
	Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY);
	Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY);
    }

    /*
     * Copy USER or LOGNAME environment variable into tcl_platform(user).
     */

    Tcl_DStringInit(&ds);
    user = TclGetEnv("USER", &ds);
    if (user == NULL) {
	user = TclGetEnv("LOGNAME", &ds);
	if (user == NULL) {
	    user = "";
	}
    }
    Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&ds);

}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensetive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or -1 if there is no such entry.  The integer at *lengthPtr is
 *	filled in with the length of name (if a matching entry is found) or
 *	the length of the environ array (if no matching entry is found).

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968

969



970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
	}

	Tcl_DStringFree(&envString);
    }

    *lengthPtr = i;

    done:
    Tcl_DStringFree(&envString);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCheckStackSpace --
 *
 *	Detect if we are about to blow the stack.  Called before an
 *	evaluation can happen when nesting depth is checked.
 *
 * Results:
 *	1 if there is enough stack space to continue; 0 if not.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpCheckStackSpace()
{
#ifdef TCL_NO_STACK_CHECK

    /*
     * This function was normally unimplemented on Unix platforms and
     * this implements old behavior, i.e. no stack checking performed.
     */

    return 1;

#else

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
				/* Most variables are actually in a
				 * thread-specific data block to minimise the
				 * impact on the stack. */
    register ptrdiff_t stackUsed;
    int localVar;		/* Reference to somewhere on the local stack.
				 * This is declared last so it's as "deep" as
				 * possible. */

    if (tsdPtr == NULL) {

        /* this should probably be a panic(). */



        Tcl_Panic("failed to get thread specific stack check data");
    }

    /*
     * The first time through, we record the "outermost" stack frame.
     */

    if (tsdPtr->outerVarPtr == NULL) {
	tsdPtr->outerVarPtr = &localVar;
    }

    if (tsdPtr->initialised == 0) {
	/*
	 * We appear to have not computed the stack size before.
	 * Attempt to retrieve it from either the current thread or,
	 * failing that, the process accounting limit.  Note that we
	 * assume that stack sizes do not change throughout the
	 * lifespan of the thread/process; this is almost always true.
	 */

	tsdPtr->stackDetermineResult = GetStackSize(&tsdPtr->stackSize);
	tsdPtr->initialised = 1;
    }

    switch (tsdPtr->stackDetermineResult) {







|









|
|
















|
|
















>
|
>
>
>
|












|
|
|
|
|







931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
	}

	Tcl_DStringFree(&envString);
    }

    *lengthPtr = i;

  done:
    Tcl_DStringFree(&envString);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCheckStackSpace --
 *
 *	Detect if we are about to blow the stack. Called before an evaluation
 *	can happen when nesting depth is checked.
 *
 * Results:
 *	1 if there is enough stack space to continue; 0 if not.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpCheckStackSpace()
{
#ifdef TCL_NO_STACK_CHECK

    /*
     * This function was normally unimplemented on Unix platforms and this
     * implements old behavior, i.e. no stack checking performed.
     */

    return 1;

#else

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
				/* Most variables are actually in a
				 * thread-specific data block to minimise the
				 * impact on the stack. */
    register ptrdiff_t stackUsed;
    int localVar;		/* Reference to somewhere on the local stack.
				 * This is declared last so it's as "deep" as
				 * possible. */

    if (tsdPtr == NULL) {
	/*
	 * This should probably be a panic(); if we're out of stack, we might
	 * have virtually no room to manoeuver at all.
	 */

	Tcl_Panic("failed to get thread specific stack check data");
    }

    /*
     * The first time through, we record the "outermost" stack frame.
     */

    if (tsdPtr->outerVarPtr == NULL) {
	tsdPtr->outerVarPtr = &localVar;
    }

    if (tsdPtr->initialised == 0) {
	/*
	 * We appear to have not computed the stack size before. Attempt to
	 * retrieve it from either the current thread or, failing that, the
	 * process accounting limit. Note that we assume that stack sizes do
	 * not change throughout the lifespan of the thread/process; this is
	 * almost always true.
	 */

	tsdPtr->stackDetermineResult = GetStackSize(&tsdPtr->stackSize);
	tsdPtr->initialised = 1;
    }

    switch (tsdPtr->stackDetermineResult) {
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
    if (&localVar > tsdPtr->outerVarPtr) {
	stackUsed = (char *)&localVar - (char *)tsdPtr->outerVarPtr;
    } else {
	stackUsed = (char *)tsdPtr->outerVarPtr - (char *)&localVar;
    }

    /*
     * Now we perform the actual check.  Are we about to blow
     * our stack frame?
     */

    if (stackUsed < (ptrdiff_t) tsdPtr->stackSize) {
	STACK_DEBUG(("stack OK\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n",
		&localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize));
	return 1;
    } else {
	STACK_DEBUG(("stack OVERFLOW\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n",
		&localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize));
	return 0;
    }
#endif /* TCL_NO_STACK_CHECK */
}

/*
 *----------------------------------------------------------------------
 *
 * GetStackSize --
 *
 *	Discover what the stack size for the current thread/process
 *	actually is.  Expects to only ever be called once per thread
 *	and then only at a point when there is a reasonable amount of
 *	space left on the current stack; TclpCheckStackSpace is called
 *	sufficiently frequently that that is true.
 *
 * Results:
 *	TCL_OK if the stack space was discovered, TCL_BREAK if the
 *	stack space was undiscoverable in a way that stack checks
 *	should fail, and TCL_CONTINUE if the stack space was
 *	undiscoverable in a way that stack checks should succeed.
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */








|
<



















|
|
|
|
|


|
|
|
|







1027
1028
1029
1030
1031
1032
1033
1034

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
    if (&localVar > tsdPtr->outerVarPtr) {
	stackUsed = (char *)&localVar - (char *)tsdPtr->outerVarPtr;
    } else {
	stackUsed = (char *)tsdPtr->outerVarPtr - (char *)&localVar;
    }

    /*
     * Now we perform the actual check. Are we about to blow our stack frame?

     */

    if (stackUsed < (ptrdiff_t) tsdPtr->stackSize) {
	STACK_DEBUG(("stack OK\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n",
		&localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize));
	return 1;
    } else {
	STACK_DEBUG(("stack OVERFLOW\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n",
		&localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize));
	return 0;
    }
#endif /* TCL_NO_STACK_CHECK */
}

/*
 *----------------------------------------------------------------------
 *
 * GetStackSize --
 *
 *	Discover what the stack size for the current thread/process actually
 *	is. Expects to only ever be called once per thread and then only at a
 *	point when there is a reasonable amount of space left on the current
 *	stack; TclpCheckStackSpace is called sufficiently frequently that that
 *	is true.
 *
 * Results:
 *	TCL_OK if the stack space was discovered, TCL_BREAK if the stack space
 *	was undiscoverable in a way that stack checks should fail, and
 *	TCL_CONTINUE if the stack space was undiscoverable in a way that stack
 *	checks should succeed.
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
	return TCL_BREAK;
    }
    if (rawStackSize > 0) {
	goto finalSanityCheck;
    }

    /*
     * If we have zero or an error, try the system limits
     * instead. After all, the pthread documentation states that
     * threads should always be bound by the system stack size limit
     * in any case.
     */
#endif /* TCL_THREADS */

    if (getrlimit(RLIMIT_STACK, &rLimit) != 0) {
	/*
	 * getrlimit() failed, just fail the whole thing.
	 */
	return TCL_BREAK;
    }
    if (rLimit.rlim_cur == RLIM_INFINITY) {
	/*
	 * Limit is "infinite"; there is no stack limit.
	 */
	return TCL_CONTINUE;
    }
    rawStackSize = rLimit.rlim_cur;

    /*
     * Final sanity check on the determined stack size.  If we fail
     * this, assume there are bogus values about and that we can't
     * actually figure out what the stack size really is.
     */

#ifdef TCL_THREADS /* Stop warning... */
  finalSanityCheck:
#endif
    if (rawStackSize <= 0) {
	return TCL_CONTINUE;







|
|
|
<


















|
|
|







1086
1087
1088
1089
1090
1091
1092
1093
1094
1095

1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
	return TCL_BREAK;
    }
    if (rawStackSize > 0) {
	goto finalSanityCheck;
    }

    /*
     * If we have zero or an error, try the system limits instead. After all,
     * the pthread documentation states that threads should always be bound by
     * the system stack size limit in any case.

     */
#endif /* TCL_THREADS */

    if (getrlimit(RLIMIT_STACK, &rLimit) != 0) {
	/*
	 * getrlimit() failed, just fail the whole thing.
	 */
	return TCL_BREAK;
    }
    if (rLimit.rlim_cur == RLIM_INFINITY) {
	/*
	 * Limit is "infinite"; there is no stack limit.
	 */
	return TCL_CONTINUE;
    }
    rawStackSize = rLimit.rlim_cur;

    /*
     * Final sanity check on the determined stack size. If we fail this,
     * assume there are bogus values about and that we can't actually figure
     * out what the stack size really is.
     */

#ifdef TCL_THREADS /* Stop warning... */
  finalSanityCheck:
#endif
    if (rawStackSize <= 0) {
	return TCL_CONTINUE;
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142

1143
1144
1145

1146

1147
1148
1149








#endif /* TCL_NO_STACK_CHECK */

/*
 *----------------------------------------------------------------------
 *
 * MacOSXGetLibraryPath --
 *
 *	If we have a bundle structure for the Tcl installation,
 *	then check there first to see if we can find the libraries
 *	there.
 *
 * Results:
 *	TCL_OK if we have found the tcl library; TCL_ERROR otherwise.
 *
 * Side effects:
 *	Same as for Tcl_MacOSXOpenVersionedBundleResources.
 *
 *----------------------------------------------------------------------
 */

#ifdef HAVE_CFBUNDLE
static int
MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath)
{
    int foundInFramework = TCL_ERROR;

#ifdef TCL_FRAMEWORK
    foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, 
	"com.tcltk.tcllibrary", TCL_VERSION, 0, maxPathLen, tclLibPath);

#endif

    return foundInFramework;
}
#endif /* HAVE_CFBUNDLE */















|
|
<










|




>

|
|
>

>


|
>
>
>
>
>
>
>
>
1135
1136
1137
1138
1139
1140
1141
1142
1143

1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
#endif /* TCL_NO_STACK_CHECK */

/*
 *----------------------------------------------------------------------
 *
 * MacOSXGetLibraryPath --
 *
 *	If we have a bundle structure for the Tcl installation, then check
 *	there first to see if we can find the libraries there.

 *
 * Results:
 *	TCL_OK if we have found the tcl library; TCL_ERROR otherwise.
 *
 * Side effects:
 *	Same as for Tcl_MacOSXOpenVersionedBundleResources.
 *
 *----------------------------------------------------------------------
 */

#ifdef HAVE_COREFOUNDATION
static int
MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath)
{
    int foundInFramework = TCL_ERROR;

#ifdef TCL_FRAMEWORK
    foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp,
	    "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen,
	    tclLibPath);
#endif

    return foundInFramework;
}
#endif /* HAVE_COREFOUNDATION */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixNotfy.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16


17
18
19





20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

171
172
173
174
175
176

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
/*
 * tclUnixNotify.c --
 *
 *	This file contains the implementation of the select-based
 *	Unix-specific notifier, which is the lowest-level part of the
 *	Tcl event loop.  This file works together with
 *	../generic/tclNotify.c.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixNotfy.c,v 1.18 2004/11/24 20:12:19 kennykb Exp $
 */



#include "tclInt.h"
#include <signal.h> 






extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;

/*
 * This structure is used to keep track of the notifier info for a 
 * a registered file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE,
				 * etc. */
    int readyMask;		/* Mask of events that have been seen since the
				 * last time file handlers were invoked for
				 * this file. */
    Tcl_FileProc *proc;		/* Procedure to call, in the style of
				 * Tcl_CreateFileHandler. */
    ClientData clientData;	/* Argument to pass to proc. */
    struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;

/*
 * The following structure is what is added to the Tcl event queue when
 * file handlers are ready to fire.
 */

typedef struct FileHandlerEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    int fd;			/* File descriptor that is ready.  Used
				 * to find the FileHandler structure for
				 * the file (can't point directly to the
				 * FileHandler structure because it could
				 * go away while the event is queued). */
} FileHandlerEvent;

/*
 *
 * The following structure contains a set of select() masks to track
 * readable, writable, and exceptional conditions.
 */

typedef struct SelectMasks {
    fd_set readable;
    fd_set writable;
    fd_set exceptional;
} SelectMasks;

/*
 * The following static structure contains the state information for the
 * select based implementation of the Tcl notifier.  One of these structures
 * is created for each thread that is using the notifier.  
 */

typedef struct ThreadSpecificData {
    FileHandler *firstFileHandlerPtr;
				/* Pointer to head of file handler list. */
    
    SelectMasks checkMasks;	/* This structure is used to build up the masks
				 * to be used in the next call to select.
				 * Bits are set in response to calls to
				 * Tcl_CreateFileHandler. */
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks
				 * (one more than highest fd for which
				 * Tcl_WatchFile has been called). */
#ifdef TCL_THREADS
    int onList;			/* True if it is in this list */
    unsigned int pollState;	/* pollState is used to implement a polling 
				 * handshake between each thread and the
				 * notifier thread. Bits defined below. */
    struct ThreadSpecificData *nextPtr, *prevPtr;
                                /* All threads that are currently waiting on 
                                 * an event have their ThreadSpecificData
                                 * structure on a doubly-linked listed formed
                                 * from these pointers.  You must hold the
                                 * notifierMutex lock before accessing these
                                 * fields. */
    Tcl_Condition waitCV;     /* Any other thread alerts a notifier
				 * that an event is ready to be processed
				 * by signaling this condition variable. */
    int eventReady;           /* True if an event is ready to be processed.
                               * Used as condition flag together with
                               * waitCV above. */
#endif
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

#ifdef TCL_THREADS
/*
 * The following static indicates the number of threads that have
 * initialized notifiers.
 *
 * You must hold the notifierMutex lock before accessing this variable.
 */

static int notifierCount = 0;

/*
 * The following variable points to the head of a doubly-linked list of 
 * of ThreadSpecificData structures for all threads that are currently
 * waiting on an event.
 *
 * You must hold the notifierMutex lock before accessing this list.
 */

static ThreadSpecificData *waitingListPtr = NULL;

/*
 * The notifier thread spends all its time in select() waiting for a
 * file descriptor associated with one of the threads on the waitingListPtr
 * list to do something interesting.  But if the contents of the
 * waitingListPtr list ever changes, we need to wake up and restart
 * the select() system call.  You can wake up the notifier thread by
 * writing a single byte to the file descriptor defined below.  This
 * file descriptor is the input-end of a pipe and the notifier thread is
 * listening for data on the output-end of the same pipe.  Hence writing
 * to this file descriptor will cause the select() system call to return
 * and wake up the notifier thread.
 *
 * You must hold the notifierMutex lock before accessing this list.
 */

static int triggerPipe = -1;

/*
 * The notifierMutex locks access to all of the global notifier state. 
 */

TCL_DECLARE_MUTEX(notifierMutex)

/*
 * The notifier thread signals the notifierCV when it has finished
 * initializing the triggerPipe and right before the notifier
 * thread terminates.
 */

static Tcl_Condition notifierCV;

/*
 * The pollState bits
 *	POLL_WANT is set by each thread before it waits on its condition
 *		variable.  It is checked by the notifier before it does
 *		select.
 *	POLL_DONE is set by the notifier if it goes into select after
 *		seeing POLL_WANT.  The idea is to ensure it tries a select
 *		with the same bits the initial thread had set.
 */

#define POLL_WANT	0x1
#define POLL_DONE	0x2

/*
 * This is the thread ID of the notifier thread that does select.
 */

static Tcl_ThreadId notifierThread;

#endif

/*
 * Static routines defined in this file.
 */

#ifdef TCL_THREADS
static void	NotifierThreadProc _ANSI_ARGS_((ClientData clientData));
#endif
static int	FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
		    int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitNotifier --
 *
 *	Initializes the platform specific notifier state.



|
|
|
<



|
|

|


>
>



>
>
>
>
>




|
|






|
|
|
|






|
|



|
|
|
|
|
|
|




|
|










|
|





<
|
|
|
|



|
|



|



|
|
|
|
|
|
|
|
|
|
|
|







|
|







|
|
|







|
|
|
|
|
<
|
|
|
|







|






|
|





|

|
<
|
|
|

>






>









|

|
<







1
2
3
4
5
6

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141

142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

194
195
196
197
198
199
200
/*
 * tclUnixNotify.c --
 *
 *	This file contains the implementation of the select()-based
 *	Unix-specific notifier, which is the lowest-level part of the Tcl
 *	event loop. This file works together with generic/tclNotify.c.

 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixNotfy.c,v 1.18.2.6 2005/08/02 18:16:57 dgp Exp $
 */

#ifndef HAVE_COREFOUNDATION	/* Darwin/Mac OS X CoreFoundation notifier is
				 * in tclMacOSXNotify.c */
#include "tclInt.h"
#include <signal.h> 

/*
 * This code does deep stub magic to allow replacement of the notifier at
 * runtime.
 */

extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;

/*
 * This structure is used to keep track of the notifier info for a registered
 * file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE,
				 * etc. */
    int readyMask;		/* Mask of events that have been seen since
				 * the last time file handlers were invoked
				 * for this file. */
    Tcl_FileProc *proc;		/* Function to call, in the style of
				 * Tcl_CreateFileHandler. */
    ClientData clientData;	/* Argument to pass to proc. */
    struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;

/*
 * The following structure is what is added to the Tcl event queue when file
 * handlers are ready to fire.
 */

typedef struct FileHandlerEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    int fd;			/* File descriptor that is ready. Used to find
				 * the FileHandler structure for the file
				 * (can't point directly to the FileHandler
				 * structure because it could go away while
				 * the event is queued). */
} FileHandlerEvent;

/*
 *
 * The following structure contains a set of select() masks to track readable,
 * writable, and exceptional conditions.
 */

typedef struct SelectMasks {
    fd_set readable;
    fd_set writable;
    fd_set exceptional;
} SelectMasks;

/*
 * The following static structure contains the state information for the
 * select based implementation of the Tcl notifier. One of these structures is
 * created for each thread that is using the notifier.
 */

typedef struct ThreadSpecificData {
    FileHandler *firstFileHandlerPtr;
				/* Pointer to head of file handler list. */

    SelectMasks checkMasks;	/* This structure is used to build up the
				 * masks to be used in the next call to
				 * select. Bits are set in response to calls
				 * to Tcl_CreateFileHandler. */
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks (one
				 * more than highest fd for which
				 * Tcl_WatchFile has been called). */
#ifdef TCL_THREADS
    int onList;			/* True if it is in this list */
    unsigned int pollState;	/* pollState is used to implement a polling
				 * handshake between each thread and the
				 * notifier thread. Bits defined below. */
    struct ThreadSpecificData *nextPtr, *prevPtr;
				/* All threads that are currently waiting on
				 * an event have their ThreadSpecificData
				 * structure on a doubly-linked listed formed
				 * from these pointers.  You must hold the
				 * notifierMutex lock before accessing these
				 * fields. */
    Tcl_Condition waitCV;	/* Any other thread alerts a notifier that an
				 * event is ready to be processed by signaling
				 * this condition variable. */
    int eventReady;		/* True if an event is ready to be processed.
				 * Used as condition flag together with waitCV
				 * above. */
#endif
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

#ifdef TCL_THREADS
/*
 * The following static indicates the number of threads that have initialized
 * notifiers.
 *
 * You must hold the notifierMutex lock before accessing this variable.
 */

static int notifierCount = 0;

/*
 * The following variable points to the head of a doubly-linked list of
 * ThreadSpecificData structures for all threads that are currently waiting on
 * an event.
 *
 * You must hold the notifierMutex lock before accessing this list.
 */

static ThreadSpecificData *waitingListPtr = NULL;

/*
 * The notifier thread spends all its time in select() waiting for a file
 * descriptor associated with one of the threads on the waitingListPtr list to
 * do something interesting. But if the contents of the waitingListPtr list
 * ever changes, we need to wake up and restart the select() system call. You
 * can wake up the notifier thread by writing a single byte to the file

 * descriptor defined below. This file descriptor is the input-end of a pipe
 * and the notifier thread is listening for data on the output-end of the same
 * pipe. Hence writing to this file descriptor will cause the select() system
 * call to return and wake up the notifier thread.
 *
 * You must hold the notifierMutex lock before accessing this list.
 */

static int triggerPipe = -1;

/*
 * The notifierMutex locks access to all of the global notifier state.
 */

TCL_DECLARE_MUTEX(notifierMutex)

/*
 * The notifier thread signals the notifierCV when it has finished
 * initializing the triggerPipe and right before the notifier thread
 * terminates.
 */

static Tcl_Condition notifierCV;

/*
 * The pollState bits:
 *	POLL_WANT is set by each thread before it waits on its condition
 *		variable. It is checked by the notifier before it does select.

 *	POLL_DONE is set by the notifier if it goes into select after seeing
 *		POLL_WANT. The idea is to ensure it tries a select with the
 *		same bits the initial thread had set.
 */

#define POLL_WANT	0x1
#define POLL_DONE	0x2

/*
 * This is the thread ID of the notifier thread that does select.
 */

static Tcl_ThreadId notifierThread;

#endif

/*
 * Static routines defined in this file.
 */

#ifdef TCL_THREADS
static void	NotifierThreadProc(ClientData clientData);
#endif
static int	FileHandlerEventProc(Tcl_Event *evPtr, int flags);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitNotifier --
 *
 *	Initializes the platform specific notifier state.
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
    /*
     * Start the Notifier thread if necessary.
     */

    Tcl_MutexLock(&notifierMutex);
    if (notifierCount == 0) {
	if (TclpThreadCreate(&notifierThread, NotifierThreadProc, NULL,
		     TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) {
	    Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread");
	}
    }
    notifierCount++;

    /*
     * Wait for the notifier pipe to be created.







|







219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
    /*
     * Start the Notifier thread if necessary.
     */

    Tcl_MutexLock(&notifierMutex);
    if (notifierCount == 0) {
	if (TclpThreadCreate(&notifierThread, NotifierThreadProc, NULL,
		TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
	    Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread");
	}
    }
    notifierCount++;

    /*
     * Wait for the notifier pipe to be created.
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274

275
276
277
278
279
280
281
282
283
284
285
286
287

288

289
290
291
292





293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeNotifier --
 *
 *	This function is called to cleanup the notifier state before
 *	a thread is terminated.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May terminate the background notifier thread if this is the
 *	last notifier instance.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeNotifier(clientData)
    ClientData clientData;		/* Not used. */
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&notifierMutex);
    notifierCount--;

    /*
     * If this is the last thread to use the notifier, close the notifier
     * pipe and wait for the background thread to terminate.
     */

    if (notifierCount == 0) {

	if (triggerPipe < 0) {
	    Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized");
	}

        /*
	 * Send "q" message to the notifier thread so that it will
	 * terminate.  The notifier will return from its call to select()
	 * and notice that a "q" message has arrived, it will then close
	 * its side of the pipe and terminate its thread.  Note the we can
	 * not just close the pipe and check for EOF in the notifier
	 * thread because if a background child process was created with
	 * exec, select() would not register the EOF on the pipe until the
	 * child processes had terminated. [Bug: 4139]

	 */

	write(triggerPipe, "q", 1);
	close(triggerPipe);

	Tcl_ConditionWait(&notifierCV, &notifierMutex, NULL);





    }

    /*
     * Clean up any synchronization objects in the thread local storage.
     */

    Tcl_ConditionFinalize(&(tsdPtr->waitCV));

    Tcl_MutexUnlock(&notifierMutex);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AlertNotifier --
 *
 *	Wake up the specified notifier from any thread. This routine
 *	is called by the platform independent notifier code whenever
 *	the Tcl_ThreadAlert routine is called.  This routine is
 *	guaranteed not to be called on a given notifier after
 *	Tcl_FinalizeNotifier is called for that notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the notifier condition variable for the specified
 *	notifier.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AlertNotifier(clientData)
    ClientData clientData;







|
|





|
|















|
|



>




|
|
|
|
|
|
|
<
|
>

>


|
|
>
>
>
>
>

















|
|
<
|
|





|
<







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322

323
324
325
326
327
328
329
330

331
332
333
334
335
336
337
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeNotifier --
 *
 *	This function is called to cleanup the notifier state before a thread
 *	is terminated.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May terminate the background notifier thread if this is the last
 *	notifier instance.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeNotifier(clientData)
    ClientData clientData;		/* Not used. */
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&notifierMutex);
    notifierCount--;

    /*
     * If this is the last thread to use the notifier, close the notifier pipe
     * and wait for the background thread to terminate.
     */

    if (notifierCount == 0) {
	int result;
	if (triggerPipe < 0) {
	    Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized");
	}

	/*
	 * Send "q" message to the notifier thread so that it will terminate.
	 * The notifier will return from its call to select() and notice that
	 * a "q" message has arrived, it will then close its side of the pipe
	 * and terminate its thread. Note the we can not just close the pipe
	 * and check for EOF in the notifier thread because if a background
	 * child process was created with exec, select() would not register

	 * the EOF on the pipe until the child processes had terminated. [Bug:
	 * 4139] [Bug: 1222872]
	 */

	write(triggerPipe, "q", 1);
	close(triggerPipe);
	while(triggerPipe >= 0) {
	    Tcl_ConditionWait(&notifierCV, &notifierMutex, NULL);
	}
	result = Tcl_JoinThread(notifierThread, NULL);
	if (result) {
	    Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread");
	}
    }

    /*
     * Clean up any synchronization objects in the thread local storage.
     */

    Tcl_ConditionFinalize(&(tsdPtr->waitCV));

    Tcl_MutexUnlock(&notifierMutex);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AlertNotifier --
 *
 *	Wake up the specified notifier from any thread. This routine is called
 *	by the platform independent notifier code whenever the Tcl_ThreadAlert

 *	routine is called. This routine is guaranteed not to be called on a
 *	given notifier after Tcl_FinalizeNotifier is called for that notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the notifier condition variable for the specified notifier.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_AlertNotifier(clientData)
    ClientData clientData;
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimer --
 *
 *	This procedure sets the current notifier timer value.  This
 *	interface is not implemented in this notifier because we are
 *	always running inside of Tcl_DoOneEvent.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimer(timePtr)
    Tcl_Time *timePtr;		/* Timeout value, may be NULL. */
{
    /*
     * The interval timer doesn't do anything in this implementation,
     * because the only event loop is via Tcl_DoOneEvent, which passes
     * timeout values to Tcl_WaitForEvent.
     */

    if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
	tclStubs.tcl_SetTimer(timePtr);
    }
}








|
|
|















|
|
|







346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimer --
 *
 *	This function sets the current notifier timer value. This interface is
 *	not implemented in this notifier because we are always running inside
 *	of Tcl_DoOneEvent.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimer(timePtr)
    Tcl_Time *timePtr;		/* Timeout value, may be NULL. */
{
    /*
     * The interval timer doesn't do anything in this implementation, because
     * the only event loop is via Tcl_DoOneEvent, which passes timeout values
     * to Tcl_WaitForEvent.
     */

    if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
	tclStubs.tcl_SetTimer(timePtr);
    }
}

393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490

491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateFileHandler --
 *
 *	This procedure registers a file handler with the select notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new file handler structure.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateFileHandler(fd, mask, proc, clientData)
    int fd;			/* Handle of stream to watch. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION:
				 * indicates conditions under which
				 * proc should be called. */
    Tcl_FileProc *proc;		/* Procedure to call for each
				 * selected event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    FileHandler *filePtr;

    if (tclStubs.tcl_CreateFileHandler != tclOriginalNotifier.createFileHandlerProc) {
	tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData);
	return;
    }

    for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
	 filePtr = filePtr->nextPtr) {
	if (filePtr->fd == fd) {
	    break;
	}
    }
    if (filePtr == NULL) {
	filePtr = (FileHandler*) ckalloc(sizeof(FileHandler));
	filePtr->fd = fd;
	filePtr->readyMask = 0;
	filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
	tsdPtr->firstFileHandlerPtr = filePtr;
    }
    filePtr->proc = proc;
    filePtr->clientData = clientData;
    filePtr->mask = mask;

    /*
     * Update the check masks for this file.
     */

    if ( mask & TCL_READABLE ) {
	FD_SET( fd, &(tsdPtr->checkMasks.readable) );
    } else {
	FD_CLR( fd, &(tsdPtr->checkMasks.readable) );
    }
    if ( mask & TCL_WRITABLE ) {
	FD_SET( fd, &(tsdPtr->checkMasks.writable) );
    } else {
	FD_CLR( fd, &(tsdPtr->checkMasks.writable) );
    }
    if ( mask & TCL_EXCEPTION ) {
	FD_SET( fd, &(tsdPtr->checkMasks.exceptional) );
    } else {
	FD_CLR( fd, &(tsdPtr->checkMasks.exceptional) );
    }
    if (tsdPtr->numFdBits <= fd) {
	tsdPtr->numFdBits = fd+1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteFileHandler --
 *
 *	Cancel a previously-arranged callback arrangement for
 *	a file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered on file, remove it.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteFileHandler(fd)
    int fd;		/* Stream id for which to remove callback procedure. */

{
    FileHandler *filePtr, *prevPtr;
    int i;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tclStubs.tcl_DeleteFileHandler != tclOriginalNotifier.deleteFileHandlerProc) {
	tclStubs.tcl_DeleteFileHandler(fd);
	return;
    }

    /*
     * Find the entry for the given file (and return if there isn't one).
     */

    for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
	 prevPtr = filePtr, filePtr = filePtr->nextPtr) {
	if (filePtr == NULL) {
	    return;
	}
	if (filePtr->fd == fd) {
	    break;
	}
    }

    /*
     * Update the check masks for this file.
     */

    if (filePtr->mask & TCL_READABLE) {
	FD_CLR( fd, &(tsdPtr->checkMasks.readable) );
    }
    if (filePtr->mask & TCL_WRITABLE) {
	FD_CLR( fd, &(tsdPtr->checkMasks.writable) );
    }
    if (filePtr->mask & TCL_EXCEPTION) {
	FD_CLR( fd, &(tsdPtr->checkMasks.exceptional) );
    }

    /*
     * Find current max fd.
     */

    if (fd+1 == tsdPtr->numFdBits) {
	tsdPtr->numFdBits = 0;
	for (i = fd-1; i >= 0; i--) {
	    if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) )
		 || FD_ISSET( i, &(tsdPtr->checkMasks.writable) )
		 || FD_ISSET( i, &(tsdPtr->checkMasks.exceptional ) ) ) {
		tsdPtr->numFdBits = i+1;
		break;
	    }
	}
    }

    /*







|














|
|
|
|
|











|



















|
|

|

|
|

|

|
|

|











|
<












|
>















|













|


|


|









|
|
|







402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateFileHandler --
 *
 *	This function registers a file handler with the select notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new file handler structure.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateFileHandler(fd, mask, proc, clientData)
    int fd;			/* Handle of stream to watch. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION: indicates
				 * conditions under which proc should be
				 * called. */
    Tcl_FileProc *proc;		/* Function to call for each selected
				 * event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    FileHandler *filePtr;

    if (tclStubs.tcl_CreateFileHandler != tclOriginalNotifier.createFileHandlerProc) {
	tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData);
	return;
    }

    for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
	    filePtr = filePtr->nextPtr) {
	if (filePtr->fd == fd) {
	    break;
	}
    }
    if (filePtr == NULL) {
	filePtr = (FileHandler*) ckalloc(sizeof(FileHandler));
	filePtr->fd = fd;
	filePtr->readyMask = 0;
	filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
	tsdPtr->firstFileHandlerPtr = filePtr;
    }
    filePtr->proc = proc;
    filePtr->clientData = clientData;
    filePtr->mask = mask;

    /*
     * Update the check masks for this file.
     */

    if (mask & TCL_READABLE) {
	FD_SET(fd, &(tsdPtr->checkMasks.readable));
    } else {
	FD_CLR(fd, &(tsdPtr->checkMasks.readable));
    }
    if (mask & TCL_WRITABLE) {
	FD_SET(fd, &(tsdPtr->checkMasks.writable));
    } else {
	FD_CLR(fd, &(tsdPtr->checkMasks.writable));
    }
    if (mask & TCL_EXCEPTION) {
	FD_SET(fd, &(tsdPtr->checkMasks.exceptional));
    } else {
	FD_CLR(fd, &(tsdPtr->checkMasks.exceptional));
    }
    if (tsdPtr->numFdBits <= fd) {
	tsdPtr->numFdBits = fd+1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteFileHandler --
 *
 *	Cancel a previously-arranged callback arrangement for a file.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered on file, remove it.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteFileHandler(fd)
    int fd;			/* Stream id for which to remove callback
				 * function. */
{
    FileHandler *filePtr, *prevPtr;
    int i;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tclStubs.tcl_DeleteFileHandler != tclOriginalNotifier.deleteFileHandlerProc) {
	tclStubs.tcl_DeleteFileHandler(fd);
	return;
    }

    /*
     * Find the entry for the given file (and return if there isn't one).
     */

    for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
	    prevPtr = filePtr, filePtr = filePtr->nextPtr) {
	if (filePtr == NULL) {
	    return;
	}
	if (filePtr->fd == fd) {
	    break;
	}
    }

    /*
     * Update the check masks for this file.
     */

    if (filePtr->mask & TCL_READABLE) {
	FD_CLR(fd, &(tsdPtr->checkMasks.readable));
    }
    if (filePtr->mask & TCL_WRITABLE) {
	FD_CLR(fd, &(tsdPtr->checkMasks.writable));
    }
    if (filePtr->mask & TCL_EXCEPTION) {
	FD_CLR(fd, &(tsdPtr->checkMasks.exceptional));
    }

    /*
     * Find current max fd.
     */

    if (fd+1 == tsdPtr->numFdBits) {
	tsdPtr->numFdBits = 0;
	for (i = fd-1; i >= 0; i--) {
	    if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))
		    || FD_ISSET(i, &(tsdPtr->checkMasks.writable))
		    || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) {
		tsdPtr->numFdBits = i+1;
		break;
	    }
	}
    }

    /*
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617

618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656

657
658

659







660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
















675
676
677


678
679
680
681
682
683
684
685
686
687
688
689
690



691

692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
}

/*
 *----------------------------------------------------------------------
 *
 * FileHandlerEventProc --
 *
 *	This procedure is called by Tcl_ServiceEvent when a file event
 *	reaches the front of the event queue.  This procedure is
 *	responsible for actually handling the event by invoking the
 *	callback for the file handler.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the file handler's callback procedure does.
 *
 *----------------------------------------------------------------------
 */

static int
FileHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event.  We do this rather than keeping a pointer to the file
     * handler directly in the event, so that the handler can be deleted
     * while the event is queued without leaving a dangling pointer.
     */

    tsdPtr = TCL_TSD_INIT(&dataKey);
    for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
	 filePtr = filePtr->nextPtr) {
	if (filePtr->fd != fileEvPtr->fd) {
	    continue;
	}

	/*
	 * The code is tricky for two reasons:
	 * 1. The file handler's desired events could have changed
	 *    since the time when the event was queued, so AND the
	 *    ready mask with the desired mask.
	 * 2. The file could have been closed and re-opened since
	 *    the time when the event was queued.  This is why the
	 *    ready mask is stored in the file handler rather than
	 *    the queued event:  it will be zeroed when a new
	 *    file handler is created for the newly opened file.

	 */

	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    (*filePtr->proc)(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new
 *	events on the message queue.  If the block time is 0, then
 *	Tcl_WaitForEvent just polls without blocking.
 *
 * Results:
 *	Returns -1 if the select would block forever, otherwise
 *	returns 0.
 *
 * Side effects:
 *	Queues file events that are detected by the select.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WaitForEvent(timePtr)
    Tcl_Time *timePtr;		/* Maximum block time, or NULL. */
{
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr;
    struct timeval timeout, *timeoutPtr;
    int mask;

#ifdef TCL_THREADS
    int waitForFiles;

#else







    int numFound;
#endif
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
	return tclStubs.tcl_WaitForEvent(timePtr);
    }

    /*
     * Set up the timeout structure.  Note that if there are no events to
     * check for, we return with a negative result rather than blocking
     * forever.
     */

    if (timePtr) {
















	timeout.tv_sec = timePtr->sec;
	timeout.tv_usec = timePtr->usec;
	timeoutPtr = &timeout;


#ifndef TCL_THREADS
    } else if (tsdPtr->numFdBits == 0) {
	/*
	 * If there are no threads, no timeout, and no fds registered,
	 * then there are no events possible and we must avoid deadlock.
	 * Note that this is not entirely correct because there might
	 * be a signal that could interrupt the select call, but we
	 * don't handle that case if we aren't using threads.
	 */

	return -1;
#endif
    } else {



	timeoutPtr = NULL;

    }

#ifdef TCL_THREADS
    /*
     * Place this thread on the list of interested threads, signal the
     * notifier thread, and wait for a response or a timeout.
     */

    Tcl_MutexLock(&notifierMutex);

    waitForFiles = (tsdPtr->numFdBits > 0);
    if (timePtr != NULL && timePtr->sec == 0 && timePtr->usec == 0) {
	/*
	 * Cannot emulate a polling select with a polling condition variable.
	 * Instead, pretend to wait for files and tell the notifier
	 * thread what we are doing.  The notifier thread makes sure
	 * it goes through select with its select mask in the same state
	 * as ours currently is.  We block until that happens.
	 */

	waitForFiles = 1;
	tsdPtr->pollState = POLL_WANT;
	timePtr = NULL;
    } else {
	tsdPtr->pollState = 0;
    }

    if (waitForFiles) {
        /*
         * Add the ThreadSpecificData structure of this thread to the list
         * of ThreadSpecificData structures of all threads that are waiting
         * on file events.
         */


        tsdPtr->nextPtr = waitingListPtr;
        if (waitingListPtr) {
            waitingListPtr->prevPtr = tsdPtr;
        }
        tsdPtr->prevPtr = 0;
        waitingListPtr = tsdPtr;
	tsdPtr->onList = 1;
	
	write(triggerPipe, "", 1);
    }

    FD_ZERO( &(tsdPtr->readyMasks.readable) );
    FD_ZERO( &(tsdPtr->readyMasks.writable) );
    FD_ZERO( &(tsdPtr->readyMasks.exceptional) );

    if (!tsdPtr->eventReady) {
        Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, timePtr);
    }
    tsdPtr->eventReady = 0;

    if (waitForFiles && tsdPtr->onList) {
	/*
	 * Remove the ThreadSpecificData structure of this thread from the
	 * waiting list.  Alert the notifier thread to recompute its select
	 * masks - skipping this caused a hang when trying to close a pipe
	 * which the notifier thread was still doing a select on.
	 */

        if (tsdPtr->prevPtr) {
            tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
        } else {
            waitingListPtr = tsdPtr->nextPtr;
        }
        if (tsdPtr->nextPtr) {
            tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
        }
        tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	write(triggerPipe, "", 1);
    }

    
#else
    tsdPtr->readyMasks = tsdPtr->checkMasks;
    numFound = select( tsdPtr->numFdBits,
		       &(tsdPtr->readyMasks.readable),
		       &(tsdPtr->readyMasks.writable),
		       &(tsdPtr->readyMasks.exceptional),
		       timeoutPtr );

    /*
     * Some systems don't clear the masks after an error, so
     * we have to do it here.
     */

    if (numFound == -1) {
	FD_ZERO( &(tsdPtr->readyMasks.readable ) );
	FD_ZERO( &(tsdPtr->readyMasks.writable ) );
	FD_ZERO( &(tsdPtr->readyMasks.exceptional ) );
    }
#endif

    /*
     * Queue all detected file events before returning.
     */

    for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
	 filePtr = filePtr->nextPtr) {

	mask = 0;
	if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.readable) ) ) {
	    mask |= TCL_READABLE;
	}
	if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.writable) ) ) {
	    mask |= TCL_WRITABLE;
	}
	if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.exceptional) ) ) {
	    mask |= TCL_EXCEPTION;
	}

	if (!mask) {
	    continue;
	}

	/*
	 * Don't bother to queue an event if the mask was previously
	 * non-zero since an event must still be on the queue.
	 */

	if (filePtr->readyMask == 0) {
	    fileEvPtr = (FileHandlerEvent *) ckalloc(
		sizeof(FileHandlerEvent));
	    fileEvPtr->header.proc = FileHandlerEventProc;
	    fileEvPtr->fd = filePtr->fd;
	    Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
	}
	filePtr->readyMask = mask;
    }
#ifdef TCL_THREADS
    Tcl_MutexUnlock(&notifierMutex);
#endif
    return 0;
}

#ifdef TCL_THREADS
/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *
 *	This routine is the initial (and only) function executed by the
 *	special notifier thread.  Its job is to wait for file descriptors
 *	to become readable or writable or to have an exception condition
 *	and then to notify other threads who are interested in this
 *	information by signalling a condition variable.  Other threads
 *	can signal this notifier thread of a change in their interests
 *	by writing a single byte to a special pipe that the notifier
 *	thread is monitoring.
 *
 * Result:
 *	None.  Once started, this routine never exits.  It dies with
 *	the overall process.
 *
 * Side effects:
 *	The trigger pipe used to signal the notifier thread is created
 *	when the notifier thread first starts.
 *
 *----------------------------------------------------------------------
 */

static void
NotifierThreadProc(clientData)
    ClientData clientData;	/* Not used. */
{
    ThreadSpecificData *tsdPtr;
    fd_set readableMask;
    fd_set writableMask;
    fd_set exceptionalMask;
    int fds[2];
    int i, status, numFdBits, receivePipe;
    long found;
    struct timeval poll = {0., 0.}, *timePtr;
    char buf[2];

    if (pipe(fds) != 0) {
	Tcl_Panic("NotifierThreadProc: could not create trigger pipe.");
    }







|
|
|
|


|
|
|
|


|







|
|












|
|
|




|






|
|
|
|
|
|
<
|
>

















|
|
|


|
<













<

>


>

>
>
>
>
>
>
>

|







|
|
<


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|

>
>



|
|
|
|
|



|

>
>
>

>











|


|
|
|
|




|





|
|
|
|
|

<
|
|
|
|
|
|

|



|
|
|


|






|




|
|
|
|
|
|
|
|
|




<


<
|
|
<
|


|
|



|
|
|

|






|


|


|


|








|
|



|
<








|










|
|
|
|
|
|
<


|
|


|
|













|







564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624

625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649

650
651
652
653
654
655
656
657
658
659
660
661
662

663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686

687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762

763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803

804
805

806
807

808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850

851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875

876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
}

/*
 *----------------------------------------------------------------------
 *
 * FileHandlerEventProc --
 *
 *	This function is called by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This function is responsible for
 *	actually handling the event by invoking the callback for the file
 *	handler.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the file handler's callback function does.
 *
 *----------------------------------------------------------------------
 */

static int
FileHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.
     */

    tsdPtr = TCL_TSD_INIT(&dataKey);
    for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
	    filePtr = filePtr->nextPtr) {
	if (filePtr->fd != fileEvPtr->fd) {
	    continue;
	}

	/*
	 * The code is tricky for two reasons:
	 * 1. The file handler's desired events could have changed since the
	 *    time when the event was queued, so AND the ready mask with the
	 *    desired mask.
	 * 2. The file could have been closed and re-opened since the time
	 *    when the event was queued. This is why the ready mask is stored
	 *    in the file handler rather than the queued event: it will be

	 *    zeroed when a new file handler is created for the newly opened
	 *    file.
	 */

	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    (*filePtr->proc)(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just
 *	polls without blocking.
 *
 * Results:
 *	Returns -1 if the select would block forever, otherwise returns 0.

 *
 * Side effects:
 *	Queues file events that are detected by the select.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WaitForEvent(timePtr)
    Tcl_Time *timePtr;		/* Maximum block time, or NULL. */
{
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr;

    int mask;
    Tcl_Time myTime;
#ifdef TCL_THREADS
    int waitForFiles;
    Tcl_Time *myTimePtr;
#else
    /*
     * Impl. notes: timeout & timeoutPtr are used if, and only if threads are
     * not enabled. They are the arguments for the regular select() used when
     * the core is not thread-enabled.
     */

    struct timeval timeout, *timeoutPtr;
    int numFound;
#endif /* TCL_THREADS */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
	return tclStubs.tcl_WaitForEvent(timePtr);
    }

    /*
     * Set up the timeout structure. Note that if there are no events to check
     * for, we return with a negative result rather than blocking forever.

     */

    if (timePtr != NULL) {
	/*
	 * TIP #233 (Virtualized Time). Is virtual time in effect? And do we
	 * actually have something to scale? If yes to both then we call the
	 * handler to do this scaling.
	 */

	myTime.sec  = timePtr->sec;
	myTime.usec = timePtr->usec;

	if (myTime.sec != 0 || myTime.usec != 0) {
	    (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData);
	}

#ifdef TCL_THREADS
	myTimePtr = &myTime;
#else
	timeout.tv_sec = myTime.sec;
	timeout.tv_usec = myTime.usec;
	timeoutPtr = &timeout;
#endif /* TCL_THREADS */

#ifndef TCL_THREADS
    } else if (tsdPtr->numFdBits == 0) {
	/*
	 * If there are no threads, no timeout, and no fds registered, then
	 * there are no events possible and we must avoid deadlock. Note that
	 * this is not entirely correct because there might be a signal that
	 * could interrupt the select call, but we don't handle that case if
	 * we aren't using threads.
	 */

	return -1;
#endif /* !TCL_THREADS */
    } else {
#ifdef TCL_THREADS
	myTimePtr = NULL;
#else
	timeoutPtr = NULL;
#endif /* TCL_THREADS */
    }

#ifdef TCL_THREADS
    /*
     * Place this thread on the list of interested threads, signal the
     * notifier thread, and wait for a response or a timeout.
     */

    Tcl_MutexLock(&notifierMutex);

    waitForFiles = (tsdPtr->numFdBits > 0);
    if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) {
	/*
	 * Cannot emulate a polling select with a polling condition variable.
	 * Instead, pretend to wait for files and tell the notifier thread
	 * what we are doing. The notifier thread makes sure it goes through
	 * select with its select mask in the same state as ours currently is.
	 * We block until that happens.
	 */

	waitForFiles = 1;
	tsdPtr->pollState = POLL_WANT;
	myTimePtr = NULL;
    } else {
	tsdPtr->pollState = 0;
    }

    if (waitForFiles) {
	/*
	 * Add the ThreadSpecificData structure of this thread to the list of
	 * ThreadSpecificData structures of all threads that are waiting on
	 * file events.
	 */


	tsdPtr->nextPtr = waitingListPtr;
	if (waitingListPtr) {
	    waitingListPtr->prevPtr = tsdPtr;
	}
	tsdPtr->prevPtr = 0;
	waitingListPtr = tsdPtr;
	tsdPtr->onList = 1;

	write(triggerPipe, "", 1);
    }

    FD_ZERO(&(tsdPtr->readyMasks.readable));
    FD_ZERO(&(tsdPtr->readyMasks.writable));
    FD_ZERO(&(tsdPtr->readyMasks.exceptional));

    if (!tsdPtr->eventReady) {
	Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, myTimePtr);
    }
    tsdPtr->eventReady = 0;

    if (waitForFiles && tsdPtr->onList) {
	/*
	 * Remove the ThreadSpecificData structure of this thread from the
	 * waiting list. Alert the notifier thread to recompute its select
	 * masks - skipping this caused a hang when trying to close a pipe
	 * which the notifier thread was still doing a select on.
	 */

	if (tsdPtr->prevPtr) {
	    tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	write(triggerPipe, "", 1);
    }


#else
    tsdPtr->readyMasks = tsdPtr->checkMasks;

    numFound = select(tsdPtr->numFdBits, &(tsdPtr->readyMasks.readable),
	    &(tsdPtr->readyMasks.writable), &(tsdPtr->readyMasks.exceptional),

	    timeoutPtr);

    /*
     * Some systems don't clear the masks after an error, so we have to do it
     * here.
     */

    if (numFound == -1) {
	FD_ZERO(&(tsdPtr->readyMasks.readable));
	FD_ZERO(&(tsdPtr->readyMasks.writable));
	FD_ZERO(&(tsdPtr->readyMasks.exceptional));
    }
#endif /* TCL_THREADS */

    /*
     * Queue all detected file events before returning.
     */

    for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
	    filePtr = filePtr->nextPtr) {

	mask = 0;
	if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) {
	    mask |= TCL_READABLE;
	}
	if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) {
	    mask |= TCL_WRITABLE;
	}
	if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) {
	    mask |= TCL_EXCEPTION;
	}

	if (!mask) {
	    continue;
	}

	/*
	 * Don't bother to queue an event if the mask was previously non-zero
	 * since an event must still be on the queue.
	 */

	if (filePtr->readyMask == 0) {
	    fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));

	    fileEvPtr->header.proc = FileHandlerEventProc;
	    fileEvPtr->fd = filePtr->fd;
	    Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
	}
	filePtr->readyMask = mask;
    }
#ifdef TCL_THREADS
    Tcl_MutexUnlock(&notifierMutex);
#endif /* TCL_THREADS */
    return 0;
}

#ifdef TCL_THREADS
/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *
 *	This routine is the initial (and only) function executed by the
 *	special notifier thread. Its job is to wait for file descriptors to
 *	become readable or writable or to have an exception condition and then
 *	to notify other threads who are interested in this information by
 *	signalling a condition variable. Other threads can signal this
 *	notifier thread of a change in their interests by writing a single
 *	byte to a special pipe that the notifier thread is monitoring.

 *
 * Result:
 *	None. Once started, this routine never exits. It dies with the overall
 *	process.
 *
 * Side effects:
 *	The trigger pipe used to signal the notifier thread is created when
 *	the notifier thread first starts.
 *
 *----------------------------------------------------------------------
 */

static void
NotifierThreadProc(clientData)
    ClientData clientData;	/* Not used. */
{
    ThreadSpecificData *tsdPtr;
    fd_set readableMask;
    fd_set writableMask;
    fd_set exceptionalMask;
    int fds[2];
    int i, status, numFdBits = 0, receivePipe;
    long found;
    struct timeval poll = {0., 0.}, *timePtr;
    char buf[2];

    if (pipe(fds) != 0) {
	Tcl_Panic("NotifierThreadProc: could not create trigger pipe.");
    }
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060










#else
    if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) {
	Tcl_Panic("NotifierThreadProc: could not make receive pipe non blocking.");
    }
    if (ioctl(fds[1], (int) FIONBIO, &status) < 0) {
	Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking.");
    }
#endif

    /*
     * Install the write end of the pipe into the global variable.
     */

    Tcl_MutexLock(&notifierMutex);
    triggerPipe = fds[1];

    /*
     * Signal any threads that are waiting.
     */

    Tcl_ConditionNotify(&notifierCV);
    Tcl_MutexUnlock(&notifierMutex);

    /*
     * Look for file events and report them to interested threads.
     */

    while (1) {

	FD_ZERO( &readableMask );
	FD_ZERO( &writableMask );
	FD_ZERO( &exceptionalMask );

	/*
	 * Compute the logical OR of the select masks from all the
	 * waiting notifiers.
	 */

	Tcl_MutexLock(&notifierMutex);
	timePtr = NULL;
        for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    for ( i = tsdPtr->numFdBits-1; i >= 0; --i ) {
		if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) ) ) {
		    FD_SET( i, &readableMask );
		}
		if ( FD_ISSET( i, &(tsdPtr->checkMasks.writable) ) ) {
		    FD_SET( i, &writableMask );
		}
		if ( FD_ISSET( i, &(tsdPtr->checkMasks.exceptional) ) ) {
		    FD_SET( i, &exceptionalMask );
		}
	    }
	    if ( tsdPtr->numFdBits > numFdBits ) {
		numFdBits = tsdPtr->numFdBits;
	    }
	    if (tsdPtr->pollState & POLL_WANT) {
		/*
		 * Here we make sure we go through select() with the same
		 * mask bits that were present when the thread tried to poll.
		 */

		tsdPtr->pollState |= POLL_DONE;
		timePtr = &poll;
	    }
	}
	Tcl_MutexUnlock(&notifierMutex);

	/*
	 * Set up the select mask to include the receive pipe.
	 */

	if ( receivePipe >= numFdBits ) {
	    numFdBits = receivePipe + 1;
	}
	FD_SET( receivePipe, &readableMask );

	if ( select( numFdBits, &readableMask, &writableMask,
		     &exceptionalMask, timePtr) == -1 ) {
	    /*
	     * Try again immediately on an error.
	     */

	    continue;
        }

	/*
	 * Alert any threads that are waiting on a ready file descriptor.
	 */

	Tcl_MutexLock(&notifierMutex);
        for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    found = 0;

	    for ( i = tsdPtr->numFdBits-1; i >= 0; --i ) {
		if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) )
		     && FD_ISSET( i, &readableMask ) ) {
		    FD_SET( i, &(tsdPtr->readyMasks.readable) );
		    found = 1;
		}
		if ( FD_ISSET( i, &(tsdPtr->checkMasks.writable) )
		     && FD_ISSET( i, &writableMask ) ) {
		    FD_SET( i, &(tsdPtr->readyMasks.writable) );
		    found = 1;
		}
		if ( FD_ISSET( i, &(tsdPtr->checkMasks.exceptional) )
		     && FD_ISSET( i, &exceptionalMask ) ) {
		    FD_SET( i, &(tsdPtr->readyMasks.exceptional) );
		    found = 1;
		}
	    }
			       
            if (found || (tsdPtr->pollState & POLL_DONE)) {
                tsdPtr->eventReady = 1;
		if (tsdPtr->onList) {
		    /*
		     * Remove the ThreadSpecificData structure of this
		     * thread from the waiting list. This prevents us from
		     * continuously spining on select until the other
		     * threads runs and services the file event.
		     */
	    
		    if (tsdPtr->prevPtr) {
			tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
		    } else {
			waitingListPtr = tsdPtr->nextPtr;
		    }
		    if (tsdPtr->nextPtr) {
			tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
		    }
		    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
		    tsdPtr->onList = 0;
		    tsdPtr->pollState = 0;
		}
		Tcl_ConditionNotify(&tsdPtr->waitCV);
            }
        }
	Tcl_MutexUnlock(&notifierMutex);
	
	/*
	 * Consume the next byte from the notifier pipe if the pipe was
	 * readable.  Note that there may be multiple bytes pending, but
	 * to avoid a race condition we only read one at a time.
	 */

	if ( FD_ISSET( receivePipe, &readableMask ) ) {
	    i = read(receivePipe, buf, 1);

	    if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
		/*
		 * Someone closed the write end of the pipe or sent us a
		 * Quit message [Bug: 4139] and then closed the write end
		 * of the pipe so we need to shut down the notifier thread.
		 */

		break;
	    }
	}
    }

    /*
     * Clean up the read end of the pipe and signal any threads waiting on
     * termination of the notifier thread.
     */

    close(receivePipe);
    Tcl_MutexLock(&notifierMutex);
    triggerPipe = -1;
    Tcl_ConditionNotify(&notifierCV);
    Tcl_MutexUnlock(&notifierMutex);

    TclpThreadExit (0);
}
#endif

















|




















<
|
|
|


|
|




|
|
|
|

|
|

|
|


|




|
|












|


|

|
|





|






|


|
|
|
|


|
|
|


|
|
|



|
|
|


|
|
|
|

|













|
|

|


|
|


|




|
|
|




















|
>
>
>
>
>
>
>
>
>
>
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946

947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
#else
    if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) {
	Tcl_Panic("NotifierThreadProc: could not make receive pipe non blocking.");
    }
    if (ioctl(fds[1], (int) FIONBIO, &status) < 0) {
	Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking.");
    }
#endif /* FIONBIO */

    /*
     * Install the write end of the pipe into the global variable.
     */

    Tcl_MutexLock(&notifierMutex);
    triggerPipe = fds[1];

    /*
     * Signal any threads that are waiting.
     */

    Tcl_ConditionNotify(&notifierCV);
    Tcl_MutexUnlock(&notifierMutex);

    /*
     * Look for file events and report them to interested threads.
     */

    while (1) {

	FD_ZERO(&readableMask);
	FD_ZERO(&writableMask);
	FD_ZERO(&exceptionalMask);

	/*
	 * Compute the logical OR of the select masks from all the waiting
	 * notifiers.
	 */

	Tcl_MutexLock(&notifierMutex);
	timePtr = NULL;
	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
		if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) {
		    FD_SET(i, &readableMask);
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) {
		    FD_SET(i, &writableMask);
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) {
		    FD_SET(i, &exceptionalMask);
		}
	    }
	    if (tsdPtr->numFdBits > numFdBits) {
		numFdBits = tsdPtr->numFdBits;
	    }
	    if (tsdPtr->pollState & POLL_WANT) {
		/*
		 * Here we make sure we go through select() with the same mask
		 * bits that were present when the thread tried to poll.
		 */

		tsdPtr->pollState |= POLL_DONE;
		timePtr = &poll;
	    }
	}
	Tcl_MutexUnlock(&notifierMutex);

	/*
	 * Set up the select mask to include the receive pipe.
	 */

	if (receivePipe >= numFdBits) {
	    numFdBits = receivePipe + 1;
	}
	FD_SET(receivePipe, &readableMask);

	if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask,
		timePtr) == -1) {
	    /*
	     * Try again immediately on an error.
	     */

	    continue;
	}

	/*
	 * Alert any threads that are waiting on a ready file descriptor.
	 */

	Tcl_MutexLock(&notifierMutex);
	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    found = 0;

	    for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
		if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))
			&& FD_ISSET(i, &readableMask)) {
		    FD_SET(i, &(tsdPtr->readyMasks.readable));
		    found = 1;
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))
			&& FD_ISSET(i, &writableMask)) {
		    FD_SET(i, &(tsdPtr->readyMasks.writable));
		    found = 1;
		}
		if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))
			&& FD_ISSET(i, &exceptionalMask)) {
		    FD_SET(i, &(tsdPtr->readyMasks.exceptional));
		    found = 1;
		}
	    }

	    if (found || (tsdPtr->pollState & POLL_DONE)) {
		tsdPtr->eventReady = 1;
		if (tsdPtr->onList) {
		    /*
		     * Remove the ThreadSpecificData structure of this thread
		     * from the waiting list. This prevents us from
		     * continuously spining on select until the other threads
		     * runs and services the file event.
		     */

		    if (tsdPtr->prevPtr) {
			tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
		    } else {
			waitingListPtr = tsdPtr->nextPtr;
		    }
		    if (tsdPtr->nextPtr) {
			tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
		    }
		    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
		    tsdPtr->onList = 0;
		    tsdPtr->pollState = 0;
		}
		Tcl_ConditionNotify(&tsdPtr->waitCV);
	    }
	}
	Tcl_MutexUnlock(&notifierMutex);

	/*
	 * Consume the next byte from the notifier pipe if the pipe was
	 * readable. Note that there may be multiple bytes pending, but to
	 * avoid a race condition we only read one at a time.
	 */

	if (FD_ISSET(receivePipe, &readableMask)) {
	    i = read(receivePipe, buf, 1);

	    if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
		/*
		 * Someone closed the write end of the pipe or sent us a Quit
		 * message [Bug: 4139] and then closed the write end of the
		 * pipe so we need to shut down the notifier thread.
		 */

		break;
	    }
	}
    }

    /*
     * Clean up the read end of the pipe and signal any threads waiting on
     * termination of the notifier thread.
     */

    close(receivePipe);
    Tcl_MutexLock(&notifierMutex);
    triggerPipe = -1;
    Tcl_ConditionNotify(&notifierCV);
    Tcl_MutexUnlock(&notifierMutex);

    TclpThreadExit (0);
}
#endif /* TCL_THREADS */

#endif /* HAVE_COREFOUNDATION */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixPipe.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
/* 
 * tclUnixPipe.c --
 *
 *	This file implements the UNIX-specific exec pipeline functions,
 *	the "pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPipe.c,v 1.26 2004/10/06 16:08:57 dgp Exp $
 */

#include "tclInt.h"

#ifdef USE_VFORK
#define fork vfork
#endif

/*
 * The following macros convert between TclFile's and fd's.  The conversion
 * simple involves shifting fd's up by one to ensure that no valid fd is ever
 * the same as NULL.
 */

#define MakeFile(fd) ((TclFile)(((int)fd)+1))
#define GetFd(file) (((int)file)-1)

/*
 * This structure describes per-instance state of a pipe based channel.
 */

typedef struct PipeState {
    Tcl_Channel channel;/* Channel associated with this file. */
    TclFile inFile;	/* Output from pipe. */
    TclFile outFile;	/* Input to pipe. */
    TclFile errorFile;	/* Error output from pipe. */
    int numPids;	/* How many processes are attached to this pipe? */

    Tcl_Pid *pidPtr;	/* The process IDs themselves. Allocated by
                         * the creator of the pipe. */
    int isNonBlocking;	/* Nonzero when the pipe is in nonblocking mode.
                         * Used to decide whether to wait for the children
                         * at close time. */
} PipeState;

/*
 * Declarations for local procedures defined in this file:
 */

static int	PipeBlockModeProc _ANSI_ARGS_((ClientData instanceData,
|


|
|




|
|

|









|












|
|
|
|
|
>
|
|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
/*
 * tclUnixPipe.c --
 *
 *	This file implements the UNIX-specific exec pipeline functions, the
 *	"pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPipe.c,v 1.26.2.3 2005/08/02 18:16:57 dgp Exp $
 */

#include "tclInt.h"

#ifdef USE_VFORK
#define fork vfork
#endif

/*
 * The following macros convert between TclFile's and fd's. The conversion
 * simple involves shifting fd's up by one to ensure that no valid fd is ever
 * the same as NULL.
 */

#define MakeFile(fd) ((TclFile)(((int)fd)+1))
#define GetFd(file) (((int)file)-1)

/*
 * This structure describes per-instance state of a pipe based channel.
 */

typedef struct PipeState {
    Tcl_Channel channel;	/* Channel associated with this file. */
    TclFile inFile;		/* Output from pipe. */
    TclFile outFile;		/* Input to pipe. */
    TclFile errorFile;		/* Error output from pipe. */
    int numPids;		/* How many processes are attached to this
				 * pipe? */
    Tcl_Pid *pidPtr;		/* The process IDs themselves. Allocated by
				 * the creator of the pipe. */
    int isNonBlocking;		/* Nonzero when the pipe is in nonblocking
				 * mode. Used to decide whether to wait for
				 * the children at close time. */
} PipeState;

/*
 * Declarations for local procedures defined in this file:
 */

static int	PipeBlockModeProc _ANSI_ARGS_((ClientData instanceData,
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86


87
88
89
90
91
92
93
		    ClientData instanceData, CONST char *buf, int toWrite,
		    int *errorCode));
static void	PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
static void	RestoreSignals _ANSI_ARGS_((void));
static int	SetupStdFile _ANSI_ARGS_((TclFile file, int type));

/*
 * This structure describes the channel type structure for command pipe
 * based IO:
 */

static Tcl_ChannelType pipeChannelType = {
    "pipe",			/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* v2 channel */
    PipeCloseProc,		/* Close proc. */
    PipeInputProc,		/* Input proc. */
    PipeOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,		/* Initialize notifier. */
    PipeGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */


};

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeFile --
 *







|
|




|












>
>







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
		    ClientData instanceData, CONST char *buf, int toWrite,
		    int *errorCode));
static void	PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
static void	RestoreSignals _ANSI_ARGS_((void));
static int	SetupStdFile _ANSI_ARGS_((TclFile file, int type));

/*
 * This structure describes the channel type structure for command pipe based
 * I/O:
 */

static Tcl_ChannelType pipeChannelType = {
    "pipe",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    PipeCloseProc,		/* Close proc. */
    PipeInputProc,		/* Input proc. */
    PipeOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,		/* Initialize notifier. */
    PipeGetHandleProc,		/* Get OS handles out of channel. */
    NULL,			/* close2proc. */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    NULL,			/* thread action proc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeFile --
 *
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
TclFile
TclpMakeFile(channel, direction)
    Tcl_Channel channel;	/* Channel to get file from. */
    int direction;		/* Either TCL_READABLE or TCL_WRITABLE. */
{
    ClientData data;

    if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data)
	    == TCL_OK) {
	return MakeFile((int)data);
    } else {
	return (TclFile) NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFile --
 *
 *	Open a file for use in a pipeline.  
 *
 * Results:
 *	Returns a new TclFile handle or NULL on failure.
 *
 * Side effects:
 *	May cause a file to be created on the file system.
 *







|
|
|










|







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
TclFile
TclpMakeFile(channel, direction)
    Tcl_Channel channel;	/* Channel to get file from. */
    int direction;		/* Either TCL_READABLE or TCL_WRITABLE. */
{
    ClientData data;

    if (Tcl_GetChannelHandle(channel, direction,
	    (ClientData *) &data) == TCL_OK) {
	return MakeFile((int) data);
    } else {
	return (TclFile) NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFile --
 *
 *	Open a file for use in a pipeline.
 *
 * Results:
 *	Returns a new TclFile handle or NULL on failure.
 *
 * Side effects:
 *	May cause a file to be created on the file system.
 *
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
    CONST char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
    fd = TclOSopen(native, mode, 0666);			/* INTL: Native. */
    Tcl_DStringFree(&ds);
    if (fd != -1) {
        fcntl(fd, F_SETFD, FD_CLOEXEC);

	/*
	 * If the file is being opened for writing, seek to the end
	 * so we can append to any data already in the file.
	 */

	if (mode & O_WRONLY) {
	    TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
	}

	/*
	 * Increment the fd so it can't be 0, which would conflict with
	 * the NULL return for errors.
	 */

	return MakeFile(fd);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateTempFile --
 *
 *	This function creates a temporary file initialized with an
 *	optional string, and returns a file handle with the file pointer
 *	at the beginning of the file.
 *
 * Results:
 *	A handle to a file.
 *
 * Side effects:
 *	None.
 *







|


|
|


|




|
|












|
|
|







145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
    CONST char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
    fd = TclOSopen(native, mode, 0666);			/* INTL: Native. */
    Tcl_DStringFree(&ds);
    if (fd != -1) {
	fcntl(fd, F_SETFD, FD_CLOEXEC);

	/*
	 * If the file is being opened for writing, seek to the end so we can
	 * append to any data already in the file.
	 */

	if ((mode & O_WRONLY) && !(mode & O_APPEND)) {
	    TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
	}

	/*
	 * Increment the fd so it can't be 0, which would conflict with the
	 * NULL return for errors.
	 */

	return MakeFile(fd);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateTempFile --
 *
 *	This function creates a temporary file initialized with an optional
 *	string, and returns a file handle with the file pointer at the
 *	beginning of the file.
 *
 * Results:
 *	A handle to a file.
 *
 * Side effects:
 *	None.
 *
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj* 
TclpTempFileName()
{
    char fileName[L_tmpnam + 9];
    Tcl_Obj *result = NULL;
    int fd;

    /*







|







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclpTempFileName()
{
    char fileName[L_tmpnam + 9];
    Tcl_Obj *result = NULL;
    int fd;

    /*
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
    if (fd == -1) {
	return NULL;
    }
    fcntl(fd, F_SETFD, FD_CLOEXEC);
    unlink(fileName);			/* INTL: Native. */

    result = TclpNativeToNormalized((ClientData) fileName);
    close (fd);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreatePipe --
 *
 *      Creates a pipe - simply calls the pipe() function.
 *
 * Results:
 *      Returns 1 on success, 0 on failure. 
 *
 * Side effects:
 *      Creates a pipe.
 *
 *----------------------------------------------------------------------
 */

int
TclpCreatePipe(readPipe, writePipe)
    TclFile *readPipe;		/* Location to store file handle for
				 * read side of pipe. */
    TclFile *writePipe;		/* Location to store file handle for
				 * write side of pipe. */
{
    int pipeIds[2];

    if (pipe(pipeIds) != 0) {
	return 0;
    }








|








|


|


|






|
|
|
|







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
    if (fd == -1) {
	return NULL;
    }
    fcntl(fd, F_SETFD, FD_CLOEXEC);
    unlink(fileName);			/* INTL: Native. */

    result = TclpNativeToNormalized((ClientData) fileName);
    close(fd);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreatePipe --
 *
 *	Creates a pipe - simply calls the pipe() function.
 *
 * Results:
 *	Returns 1 on success, 0 on failure.
 *
 * Side effects:
 *	Creates a pipe.
 *
 *----------------------------------------------------------------------
 */

int
TclpCreatePipe(readPipe, writePipe)
    TclFile *readPipe;		/* Location to store file handle for read side
				 * of pipe. */
    TclFile *writePipe;		/* Location to store file handle for write
				 * side of pipe. */
{
    int pipeIds[2];

    if (pipe(pipeIds) != 0) {
	return 0;
    }

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464

465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
    TclFile file;	/* The file to close. */
{
    int fd = GetFd(file);

    /*
     * Refuse to close the fds for stdin, stdout and stderr.
     */
    
    if ((fd == 0) || (fd == 1) || (fd == 2)) {
        return 0;
    }
    
    Tcl_DeleteFileHandler(fd);
    return close(fd);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpCreateProcess --
 *
 *	Create a child process that has the specified files as its 
 *	standard input, output, and error.  The child process runs
 *	asynchronously and runs with the same environment variables
 *	as the creating process.
 *
 *	The path is searched to find the specified executable.  
 *
 * Results:
 *	The return value is TCL_ERROR and an error message is left in
 *	the interp's result if there was a problem creating the child 
 *	process.  Otherwise, the return value is TCL_OK and *pidPtr is
 *	filled with the process id of the child process.
 * 
 * Side effects:
 *	A process is created.
 *	
 *---------------------------------------------------------------------------
 */

    /* ARGSUSED */
int
TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, 
	pidPtr)
    Tcl_Interp *interp;		/* Interpreter in which to leave errors that
				 * occurred when creating the child process.
				 * Error messages from the child process
				 * itself are sent to errorFile. */
    int argc;			/* Number of arguments in following array. */
    CONST char **argv;		/* Array of argument strings in UTF-8.
				 * argv[0] contains the name of the executable
				 * translated using Tcl_TranslateFileName
				 * call).  Additional arguments have not been
				 * converted. */
    TclFile inputFile;		/* If non-NULL, gives the file to use as
				 * input for the child process.  If inputFile
				 * file is not readable or is NULL, the child
				 * will receive no standard input. */
    TclFile outputFile;		/* If non-NULL, gives the file that
				 * receives output from the child process.  If
				 * outputFile file is not writeable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile;		/* If non-NULL, gives the file that
				 * receives errors from the child process.  If
				 * errorFile file is not writeable or is NULL,
				 * errors from the child will be discarded.
				 * errorFile may be the same as outputFile. */
    Tcl_Pid *pidPtr;		/* If this procedure is successful, pidPtr
				 * is filled with the process id of the child
				 * process. */
{
    TclFile errPipeIn, errPipeOut;
    int joinThisError, count, status, fd;
    char errSpace[200 + TCL_INTEGER_SPACE];
    Tcl_DString *dsArray;
    char **newArgv;
    int pid, i;
    
    errPipeIn = NULL;
    errPipeOut = NULL;
    pid = -1;

    /*
     * Create a pipe that the child can use to return error
     * information if anything goes wrong.
     */

    if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
	Tcl_AppendResult(interp, "couldn't create pipe: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto error;
    }

    /*
     * We need to allocate and convert this before the fork
     * so it is properly deallocated later
     */

    dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString));
    newArgv = (char **) ckalloc((argc+1) * sizeof(char *));
    newArgv[argc] = NULL;
    for (i = 0; i < argc; i++) {
	newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
    }

    joinThisError = errorFile && (errorFile == outputFile);
    pid = fork();
    if (pid == 0) {
	fd = GetFd(errPipeOut);

	/*
	 * Set up stdio file handles for the child process.
	 */

	if (!SetupStdFile(inputFile, TCL_STDIN)
		|| !SetupStdFile(outputFile, TCL_STDOUT)
		|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
		|| (joinThisError &&
			((dup2(1,2) == -1) ||
			 (fcntl(2, F_SETFD, 0) != 0)))) {
	    sprintf(errSpace,
		    "%dforked process couldn't set up input/output: ", errno);
	    write(fd, errSpace, (size_t) strlen(errSpace));
	    _exit(1);
	}

	/*
	 * Close the input side of the error pipe.
	 */

	RestoreSignals();
	execvp(newArgv[0], newArgv);			/* INTL: Native. */
	sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]);
	write(fd, errSpace, (size_t) strlen(errSpace));
	_exit(1);
    }
    
    /*
     * Free the mem we used for the fork
     */

    for (i = 0; i < argc; i++) {
	Tcl_DStringFree(&dsArray[i]);
    }
    ckfree((char *) dsArray);
    ckfree((char *) newArgv);

    if (pid == -1) {
	Tcl_AppendResult(interp, "couldn't fork child process: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto error;
    }

    /*
     * Read back from the error pipe to see if the child started
     * up OK.  The info in the pipe (if any) consists of a decimal
     * errno value followed by an error message.
     */

    TclpCloseFile(errPipeOut);
    errPipeOut = NULL;

    fd = GetFd(errPipeIn);
    count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
    if (count > 0) {
	char *end;
	errSpace[count] = 0;
	errno = strtol(errSpace, &end, 10);
	Tcl_AppendResult(interp, end, Tcl_PosixError(interp),
		(char *) NULL);
	goto error;
    }
    
    TclpCloseFile(errPipeIn);
    *pidPtr = (Tcl_Pid) pid;
    return TCL_OK;

    error:
    if (pid != -1) {
	/*
	 * Reap the child process now if an error occurred during its
	 * startup.  We don't call this with WNOHANG because that can lead to
	 * defunct processes on an MP system.   We shouldn't have to worry
	 * about hanging here, since this is the error case.  [Bug: 6148]
	 */

	Tcl_WaitPid((Tcl_Pid) pid, &status, 0);
    }
    
    if (errPipeIn) {
	TclpCloseFile(errPipeIn);
    }
    if (errPipeOut) {
	TclpCloseFile(errPipeOut);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * RestoreSignals --
 *
 *      This procedure is invoked in a forked child process just before
 *      exec-ing a new program to restore all signals to their default
 *      settings.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Signal settings get changed.
 *
 *----------------------------------------------------------------------
 */
 
static void
RestoreSignals()
{
#ifdef SIGABRT
    signal(SIGABRT, SIG_DFL);
#endif
#ifdef SIGALRM







|

|

|









|
|
|
<

|


|
|
|
|
|


|





|









|

|
|
|
|
|
|



|
|
|
|
|
|
|








|





|
|









|
|

>




















|
<
















|



>













|
|
|















|




|


|
|
|
|




|














|
|
|


|


|



|







328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446

447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
    TclFile file;	/* The file to close. */
{
    int fd = GetFd(file);

    /*
     * Refuse to close the fds for stdin, stdout and stderr.
     */

    if ((fd == 0) || (fd == 1) || (fd == 2)) {
	return 0;
    }

    Tcl_DeleteFileHandler(fd);
    return close(fd);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpCreateProcess --
 *
 *	Create a child process that has the specified files as its standard
 *	input, output, and error. The child process runs asynchronously and
 *	runs with the same environment variables as the creating process.

 *
 *	The path is searched to find the specified executable.
 *
 * Results:
 *	The return value is TCL_ERROR and an error message is left in the
 *	interp's result if there was a problem creating the child process.
 *	Otherwise, the return value is TCL_OK and *pidPtr is filled with the
 *	process id of the child process.
 *
 * Side effects:
 *	A process is created.
 *
 *---------------------------------------------------------------------------
 */

    /* ARGSUSED */
int
TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
	pidPtr)
    Tcl_Interp *interp;		/* Interpreter in which to leave errors that
				 * occurred when creating the child process.
				 * Error messages from the child process
				 * itself are sent to errorFile. */
    int argc;			/* Number of arguments in following array. */
    CONST char **argv;		/* Array of argument strings in UTF-8.
				 * argv[0] contains the name of the executable
				 * translated using Tcl_TranslateFileName
				 * call). Additional arguments have not been
				 * converted. */
    TclFile inputFile;		/* If non-NULL, gives the file to use as input
				 * for the child process. If inputFile file is
				 * not readable or is NULL, the child will
				 * receive no standard input. */
    TclFile outputFile;		/* If non-NULL, gives the file that receives
				 * output from the child process. If
				 * outputFile file is not writeable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile;		/* If non-NULL, gives the file that receives
				 * errors from the child process. If errorFile
				 * file is not writeable or is NULL, errors
				 * from the child will be discarded. errorFile
				 * may be the same as outputFile. */
    Tcl_Pid *pidPtr;		/* If this procedure is successful, pidPtr is
				 * filled with the process id of the child
				 * process. */
{
    TclFile errPipeIn, errPipeOut;
    int joinThisError, count, status, fd;
    char errSpace[200 + TCL_INTEGER_SPACE];
    Tcl_DString *dsArray;
    char **newArgv;
    int pid, i;

    errPipeIn = NULL;
    errPipeOut = NULL;
    pid = -1;

    /*
     * Create a pipe that the child can use to return error information if
     * anything goes wrong.
     */

    if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
	Tcl_AppendResult(interp, "couldn't create pipe: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto error;
    }

    /*
     * We need to allocate and convert this before the fork so it is properly
     * deallocated later
     */

    dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString));
    newArgv = (char **) ckalloc((argc+1) * sizeof(char *));
    newArgv[argc] = NULL;
    for (i = 0; i < argc; i++) {
	newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
    }

    joinThisError = errorFile && (errorFile == outputFile);
    pid = fork();
    if (pid == 0) {
	fd = GetFd(errPipeOut);

	/*
	 * Set up stdio file handles for the child process.
	 */

	if (!SetupStdFile(inputFile, TCL_STDIN)
		|| !SetupStdFile(outputFile, TCL_STDOUT)
		|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
		|| (joinThisError &&
			((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {

	    sprintf(errSpace,
		    "%dforked process couldn't set up input/output: ", errno);
	    write(fd, errSpace, (size_t) strlen(errSpace));
	    _exit(1);
	}

	/*
	 * Close the input side of the error pipe.
	 */

	RestoreSignals();
	execvp(newArgv[0], newArgv);			/* INTL: Native. */
	sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]);
	write(fd, errSpace, (size_t) strlen(errSpace));
	_exit(1);
    }

    /*
     * Free the mem we used for the fork
     */

    for (i = 0; i < argc; i++) {
	Tcl_DStringFree(&dsArray[i]);
    }
    ckfree((char *) dsArray);
    ckfree((char *) newArgv);

    if (pid == -1) {
	Tcl_AppendResult(interp, "couldn't fork child process: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto error;
    }

    /*
     * Read back from the error pipe to see if the child started up OK. The
     * info in the pipe (if any) consists of a decimal errno value followed by
     * an error message.
     */

    TclpCloseFile(errPipeOut);
    errPipeOut = NULL;

    fd = GetFd(errPipeIn);
    count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
    if (count > 0) {
	char *end;
	errSpace[count] = 0;
	errno = strtol(errSpace, &end, 10);
	Tcl_AppendResult(interp, end, Tcl_PosixError(interp),
		(char *) NULL);
	goto error;
    }

    TclpCloseFile(errPipeIn);
    *pidPtr = (Tcl_Pid) pid;
    return TCL_OK;

  error:
    if (pid != -1) {
	/*
	 * Reap the child process now if an error occurred during its startup.
	 * We don't call this with WNOHANG because that can lead to defunct
	 * processes on an MP system. We shouldn't have to worry about hanging
	 * here, since this is the error case. [Bug: 6148]
	 */

	Tcl_WaitPid((Tcl_Pid) pid, &status, 0);
    }

    if (errPipeIn) {
	TclpCloseFile(errPipeIn);
    }
    if (errPipeOut) {
	TclpCloseFile(errPipeOut);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * RestoreSignals --
 *
 *	This procedure is invoked in a forked child process just before
 *	exec-ing a new program to restore all signals to their default
 *	settings.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signal settings get changed.
 *
 *----------------------------------------------------------------------
 */

static void
RestoreSignals()
{
#ifdef SIGABRT
    signal(SIGABRT, SIG_DFL);
#endif
#ifdef SIGALRM
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
}

/*
 *----------------------------------------------------------------------
 *
 * SetupStdFile --
 *
 *	Set up stdio file handles for the child process, using the
 *	current standard channels if no other files are specified.
 *	If no standard channel is defined, or if no file is associated
 *	with the channel, then the corresponding standard fd is closed.
 *
 * Results:
 *	Returns 1 on success, or 0 on failure.
 *
 * Side effects:
 *	Replaces stdio fds.
 *







|
|
|
|







597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
}

/*
 *----------------------------------------------------------------------
 *
 * SetupStdFile --
 *
 *	Set up stdio file handles for the child process, using the current
 *	standard channels if no other files are specified. If no standard
 *	channel is defined, or if no file is associated with the channel, then
 *	the corresponding standard fd is closed.
 *
 * Results:
 *	Returns 1 on success, or 0 on failure.
 *
 * Side effects:
 *	Replaces stdio fds.
 *
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
    Tcl_Channel channel;
    int fd;
    int targetFd = 0;		/* Initializations here needed only to */
    int direction = 0;		/* prevent warnings about using uninitialized
				 * variables. */

    switch (type) {
	case TCL_STDIN:
	    targetFd = 0;
	    direction = TCL_READABLE;
	    break;
	case TCL_STDOUT:
	    targetFd = 1;
	    direction = TCL_WRITABLE;
	    break;
	case TCL_STDERR:
	    targetFd = 2;
	    direction = TCL_WRITABLE;
	    break;
    }

    if (!file) {
	channel = Tcl_GetStdChannel(type);
	if (channel) {
	    file = TclpMakeFile(channel, direction);
	}
    }
    if (file) {
	fd = GetFd(file);
	if (fd != targetFd) {
	    if (dup2(fd, targetFd) == -1) {
		return 0;
	    }

            /*
             * Must clear the close-on-exec flag for the target FD, since
             * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on
             * the target FD.
             */
            
            fcntl(targetFd, F_SETFD, 0);
	} else {
	    /*
	     * Since we aren't dup'ing the file, we need to explicitly clear
	     * the close-on-exec flag.
	     */

	    fcntl(fd, F_SETFD, 0);
	}
    } else {
	close(targetFd);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateCommandChannel --
 *
 *	This function is called by the generic IO level to perform
 *	the platform specific channel initialization for a command
 *	channel.
 *
 * Results:
 *	Returns a new channel or NULL on failure.
 *
 * Side effects:
 *	Allocates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
    TclFile readFile;		/* If non-null, gives the file for reading. */
    TclFile writeFile;		/* If non-null, gives the file for writing. */
    TclFile errorFile;		/* If non-null, gives the file where errors
				 * can be read. */
    int numPids;		/* The number of pids in the pid array. */
    Tcl_Pid *pidPtr;		/* An array of process identifiers.
                                 * Allocated by the caller, freed when
                                 * the channel is closed or the processes
                                 * are detached (in a background exec). */
{
    char channelName[16 + TCL_INTEGER_SPACE];
    int channelId;
    PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState));
    int mode;

    statePtr->inFile = readFile;
    statePtr->outFile = writeFile;
    statePtr->errorFile = errorFile;
    statePtr->numPids = numPids;
    statePtr->pidPtr = pidPtr;
    statePtr->isNonBlocking = 0;

    mode = 0;
    if (readFile) {
        mode |= TCL_READABLE;
    }
    if (writeFile) {
        mode |= TCL_WRITABLE;
    }
    
    /*
     * Use one of the fds associated with the channel as the
     * channel id.
     */

    if (readFile) {
	channelId = GetFd(readFile);
    } else if (writeFile) {
	channelId = GetFd(writeFile);
    } else if (errorFile) {
	channelId = GetFd(errorFile);
    } else {
	channelId = 0;
    }

    /*
     * For backward compatibility with previous versions of Tcl, we
     * use "file%d" as the base name for pipes even though it would
     * be more natural to use "pipe%d".
     */

    sprintf(channelName, "file%d", channelId);
    statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
            (ClientData) statePtr, mode);
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetAndDetachPids --
 *
 *	This procedure is invoked in the generic implementation of a
 *	background "exec" (An exec when invoked with a terminating "&")
 *	to store a list of the PIDs for processes in a command pipeline
 *	in the interp's result and to detach the processes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the interp's result. Detaches processes.
 *
 *----------------------------------------------------------------------
 */

void
TclGetAndDetachPids(interp, chan)
    Tcl_Interp *interp;
    Tcl_Channel chan;
{
    PipeState *pipePtr;
    Tcl_ChannelType *chanTypePtr;
    int i;
    char buf[TCL_INTEGER_SPACE];

    /*
     * Punt if the channel is not a command channel.
     */

    chanTypePtr = Tcl_GetChannelType(chan);
    if (chanTypePtr != &pipeChannelType) {
        return;
    }

    pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
    for (i = 0; i < pipePtr->numPids; i++) {
        TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i]));
        Tcl_AppendElement(interp, buf);
        Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
    }
    if (pipePtr->numPids > 0) {
        ckfree((char *) pipePtr->pidPtr);
        pipePtr->numPids = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeBlockModeProc --
 *
 *	Helper procedure to set blocking and nonblocking modes on a
 *	pipe based channel. Invoked by generic IO level code.
 *
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
PipeBlockModeProc(instanceData, mode)
    ClientData instanceData;		/* Pipe state. */
    int mode;				/* The mode to set. Can be one of
                                         * TCL_MODE_BLOCKING or
                                         * TCL_MODE_NONBLOCKING. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int curStatus;
    int fd;

#ifndef	USE_FIONBIO    
    if (psPtr->inFile) {
        fd = GetFd(psPtr->inFile);
        curStatus = fcntl(fd, F_GETFL);
        if (mode == TCL_MODE_BLOCKING) {
            curStatus &= (~(O_NONBLOCK));
        } else {
            curStatus |= O_NONBLOCK;
        }
        if (fcntl(fd, F_SETFL, curStatus) < 0) {
            return errno;
        }
    }
    if (psPtr->outFile) {
        fd = GetFd(psPtr->outFile);
        curStatus = fcntl(fd, F_GETFL);
        if (mode == TCL_MODE_BLOCKING) {
            curStatus &= (~(O_NONBLOCK));
        } else {
            curStatus |= O_NONBLOCK;
        }
        if (fcntl(fd, F_SETFL, curStatus) < 0) {
            return errno;
        }
    }
#endif	/* !FIONBIO */

#ifdef	USE_FIONBIO
    if (psPtr->inFile) {
        fd = GetFd(psPtr->inFile);
        if (mode == TCL_MODE_BLOCKING) {
            curStatus = 0;
        } else {
            curStatus = 1;
        }
        if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) {
            return errno;
        }
    }
    if (psPtr->outFile != NULL) {
        fd = GetFd(psPtr->outFile);
        if (mode == TCL_MODE_BLOCKING) {
            curStatus = 0;
        } else {
            curStatus = 1;
        }
        if (ioctl(fd, (int) FIONBIO,  &curStatus) < 0) {
            return errno;
        }
    }
#endif	/* USE_FIONBIO */

    psPtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING);

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeCloseProc --
 *
 *	This procedure is invoked by the generic IO level to perform
 *	channel-type-specific cleanup when a command pipeline channel
 *	is closed.
 *
 * Results:
 *	0 on success, errno otherwise.
 *
 * Side effects:
 *	Closes the command pipeline channel.
 *







|
|
|
|
|
|
|
|
|
|
|
|















|
|
|
|
|
|
|



















|
|
<

















|
|
|
|















|


|

|

|
<













|
|
|




|









|
|
|












|
|












|




|
|
|


|
|








|
|













|
|
|
|





|

|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|
|
|





|
|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|
|














|
|







623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684

685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728

729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
    Tcl_Channel channel;
    int fd;
    int targetFd = 0;		/* Initializations here needed only to */
    int direction = 0;		/* prevent warnings about using uninitialized
				 * variables. */

    switch (type) {
    case TCL_STDIN:
	targetFd = 0;
	direction = TCL_READABLE;
	break;
    case TCL_STDOUT:
	targetFd = 1;
	direction = TCL_WRITABLE;
	break;
    case TCL_STDERR:
	targetFd = 2;
	direction = TCL_WRITABLE;
	break;
    }

    if (!file) {
	channel = Tcl_GetStdChannel(type);
	if (channel) {
	    file = TclpMakeFile(channel, direction);
	}
    }
    if (file) {
	fd = GetFd(file);
	if (fd != targetFd) {
	    if (dup2(fd, targetFd) == -1) {
		return 0;
	    }

	    /*
	     * Must clear the close-on-exec flag for the target FD, since some
	     * systems (e.g. Ultrix) do not clear the CLOEXEC flag on the
	     * target FD.
	     */

	    fcntl(targetFd, F_SETFD, 0);
	} else {
	    /*
	     * Since we aren't dup'ing the file, we need to explicitly clear
	     * the close-on-exec flag.
	     */

	    fcntl(fd, F_SETFD, 0);
	}
    } else {
	close(targetFd);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateCommandChannel --
 *
 *	This function is called by the generic IO level to perform the
 *	platform specific channel initialization for a command channel.

 *
 * Results:
 *	Returns a new channel or NULL on failure.
 *
 * Side effects:
 *	Allocates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
    TclFile readFile;		/* If non-null, gives the file for reading. */
    TclFile writeFile;		/* If non-null, gives the file for writing. */
    TclFile errorFile;		/* If non-null, gives the file where errors
				 * can be read. */
    int numPids;		/* The number of pids in the pid array. */
    Tcl_Pid *pidPtr;		/* An array of process identifiers. Allocated
				 * by the caller, freed when the channel is
				 * closed or the processes are detached (in a
				 * background exec). */
{
    char channelName[16 + TCL_INTEGER_SPACE];
    int channelId;
    PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState));
    int mode;

    statePtr->inFile = readFile;
    statePtr->outFile = writeFile;
    statePtr->errorFile = errorFile;
    statePtr->numPids = numPids;
    statePtr->pidPtr = pidPtr;
    statePtr->isNonBlocking = 0;

    mode = 0;
    if (readFile) {
	mode |= TCL_READABLE;
    }
    if (writeFile) {
	mode |= TCL_WRITABLE;
    }

    /*
     * Use one of the fds associated with the channel as the channel id.

     */

    if (readFile) {
	channelId = GetFd(readFile);
    } else if (writeFile) {
	channelId = GetFd(writeFile);
    } else if (errorFile) {
	channelId = GetFd(errorFile);
    } else {
	channelId = 0;
    }

    /*
     * For backward compatibility with previous versions of Tcl, we use
     * "file%d" as the base name for pipes even though it would be more
     * natural to use "pipe%d".
     */

    sprintf(channelName, "file%d", channelId);
    statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
	    (ClientData) statePtr, mode);
    return statePtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetAndDetachPids --
 *
 *	This procedure is invoked in the generic implementation of a
 *	background "exec" (an exec when invoked with a terminating "&") to
 *	store a list of the PIDs for processes in a command pipeline in the
 *	interp's result and to detach the processes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the interp's result. Detaches processes.
 *
 *----------------------------------------------------------------------
 */

void
TclGetAndDetachPids(interp, chan)
    Tcl_Interp *interp;		/* Interpreter to append the PIDs to. */
    Tcl_Channel chan;		/* Handle for the pipeline. */
{
    PipeState *pipePtr;
    Tcl_ChannelType *chanTypePtr;
    int i;
    char buf[TCL_INTEGER_SPACE];

    /*
     * Punt if the channel is not a command channel.
     */

    chanTypePtr = Tcl_GetChannelType(chan);
    if (chanTypePtr != &pipeChannelType) {
	return;
    }

    pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
    for (i = 0; i < pipePtr->numPids; i++) {
	TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i]));
	Tcl_AppendElement(interp, buf);
	Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
    }
    if (pipePtr->numPids > 0) {
	ckfree((char *) pipePtr->pidPtr);
	pipePtr->numPids = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeBlockModeProc --
 *
 *	Helper procedure to set blocking and nonblocking modes on a pipe based
 *	channel. Invoked by generic IO level code.
 *
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
PipeBlockModeProc(instanceData, mode)
    ClientData instanceData;	/* Pipe state. */
    int mode;			/* The mode to set. Can be one of
				 * TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int curStatus;
    int fd;

#ifndef	USE_FIONBIO
    if (psPtr->inFile) {
	fd = GetFd(psPtr->inFile);
	curStatus = fcntl(fd, F_GETFL);
	if (mode == TCL_MODE_BLOCKING) {
	    curStatus &= (~(O_NONBLOCK));
	} else {
	    curStatus |= O_NONBLOCK;
	}
	if (fcntl(fd, F_SETFL, curStatus) < 0) {
	    return errno;
	}
    }
    if (psPtr->outFile) {
	fd = GetFd(psPtr->outFile);
	curStatus = fcntl(fd, F_GETFL);
	if (mode == TCL_MODE_BLOCKING) {
	    curStatus &= (~(O_NONBLOCK));
	} else {
	    curStatus |= O_NONBLOCK;
	}
	if (fcntl(fd, F_SETFL, curStatus) < 0) {
	    return errno;
	}
    }
#endif	/* !FIONBIO */

#ifdef	USE_FIONBIO
    if (psPtr->inFile) {
	fd = GetFd(psPtr->inFile);
	if (mode == TCL_MODE_BLOCKING) {
	    curStatus = 0;
	} else {
	    curStatus = 1;
	}
	if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) {
	    return errno;
	}
    }
    if (psPtr->outFile != NULL) {
	fd = GetFd(psPtr->outFile);
	if (mode == TCL_MODE_BLOCKING) {
	    curStatus = 0;
	} else {
	    curStatus = 1;
	}
	if (ioctl(fd, (int) FIONBIO,  &curStatus) < 0) {
	    return errno;
	}
    }
#endif	/* USE_FIONBIO */

    psPtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING);

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeCloseProc --
 *
 *	This procedure is invoked by the generic IO level to perform
 *	channel-type-specific cleanup when a command pipeline channel is
 *	closed.
 *
 * Results:
 *	0 on success, errno otherwise.
 *
 * Side effects:
 *	Closes the command pipeline channel.
 *
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
    if (pipePtr->outFile) {
	if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) {
	    errorCode = errno;
	}
    }

    if (pipePtr->isNonBlocking || TclInExit()) {
    
	/*
         * If the channel is non-blocking or Tcl is being cleaned up, just
         * detach the children PIDs, reap them (important if we are in a
         * dynamic load module), and discard the errorFile.
         */
        
        Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
        Tcl_ReapDetachedProcs();

        if (pipePtr->errorFile) {
	    TclpCloseFile(pipePtr->errorFile);
        }
    } else {
        
	/*
         * Wrap the error file into a channel and give it to the cleanup
         * routine.
         */

        if (pipePtr->errorFile) {
	    errChan = Tcl_MakeFileChannel(
		(ClientData) GetFd(pipePtr->errorFile), TCL_READABLE);
        } else {
            errChan = NULL;
        }
        result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
                errChan);
    }

    if (pipePtr->numPids != 0) {
        ckfree((char *) pipePtr->pidPtr);
    }
    ckfree((char *) pipePtr);
    if (errorCode == 0) {
        return result;
    }
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeInputProc --
 *
 *	This procedure is invoked from the generic IO level to read
 *	input from a command pipeline based channel.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurs, or zero.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;		/* Pipe state. */
    char *buf;				/* Where to store data read. */
    int toRead;				/* How much space is available
                                         * in the buffer? */
    int *errorCodePtr;			/* Where to store error code. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int bytesRead;			/* How many bytes were actually
                                         * read from the input device? */

    *errorCodePtr = 0;
    
    /*
     * Assume there is always enough input available. This will block
     * appropriately, and read will unblock as soon as a short read is
     * possible, if the channel is in blocking mode. If the channel is
     * nonblocking, the read will never block.
     * Some OSes can throw an interrupt error, for which we should
     * immediately retry. [Bug #415131]
     */

    do {
	bytesRead = read (GetFd(psPtr->inFile), buf, (size_t) toRead);
    } while ((bytesRead < 0) && (errno == EINTR));

    if (bytesRead < 0) {
	*errorCodePtr = errno;
	return -1;
    } else {
	return bytesRead;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeOutputProc--
 *
 *	This procedure is invoked from the generic IO level to write
 *	output to a command pipeline based channel.
 *
 * Results:
 *	The number of bytes written is returned or -1 on error. An
 *	output argument	contains a POSIX error code if an error occurred,
 *	or zero.
 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;		/* Pipe state. */
    CONST char *buf;			/* The data buffer. */
    int toWrite;			/* How many bytes to write? */
    int *errorCodePtr;			/* Where to store error code. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int written;

    *errorCodePtr = 0;

    /*
     * Some OSes can throw an interrupt error, for which we should
     * immediately retry. [Bug #415131]
     */

    do {
	written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite);
    } while ((written < 0) && (errno == EINTR));

    if (written < 0) {







<

|
|
|
|
|
|
|

|

|

<

|
|
|

|


|
|
|
|
|



|



|









|
|













|
|
|
|
|


|
|


|




|
<
|



|















|
|


|
|
<









|
|
|
|







|
|







925
926
927
928
929
930
931

932
933
934
935
936
937
938
939
940
941
942
943
944

945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006

1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032

1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
    if (pipePtr->outFile) {
	if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) {
	    errorCode = errno;
	}
    }

    if (pipePtr->isNonBlocking || TclInExit()) {

	/*
	 * If the channel is non-blocking or Tcl is being cleaned up, just
	 * detach the children PIDs, reap them (important if we are in a
	 * dynamic load module), and discard the errorFile.
	 */

	Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
	Tcl_ReapDetachedProcs();

	if (pipePtr->errorFile) {
	    TclpCloseFile(pipePtr->errorFile);
	}
    } else {

	/*
	 * Wrap the error file into a channel and give it to the cleanup
	 * routine.
	 */

	if (pipePtr->errorFile) {
	    errChan = Tcl_MakeFileChannel(
		(ClientData) GetFd(pipePtr->errorFile), TCL_READABLE);
	} else {
	    errChan = NULL;
	}
	result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
		errChan);
    }

    if (pipePtr->numPids != 0) {
	ckfree((char *) pipePtr->pidPtr);
    }
    ckfree((char *) pipePtr);
    if (errorCode == 0) {
	return result;
    }
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeInputProc --
 *
 *	This procedure is invoked from the generic IO level to read input from
 *	a command pipeline based channel.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurs, or zero.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;	/* Pipe state. */
    char *buf;			/* Where to store data read. */
    int toRead;			/* How much space is available in the
				 * buffer? */
    int *errorCodePtr;		/* Where to store error code. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int bytesRead;		/* How many bytes were actually read from the
				 * input device? */

    *errorCodePtr = 0;

    /*
     * Assume there is always enough input available. This will block
     * appropriately, and read will unblock as soon as a short read is
     * possible, if the channel is in blocking mode. If the channel is
     * nonblocking, the read will never block. Some OSes can throw an

     * interrupt error, for which we should immediately retry. [Bug #415131]
     */

    do {
	bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead);
    } while ((bytesRead < 0) && (errno == EINTR));

    if (bytesRead < 0) {
	*errorCodePtr = errno;
	return -1;
    } else {
	return bytesRead;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeOutputProc--
 *
 *	This procedure is invoked from the generic IO level to write output to
 *	a command pipeline based channel.
 *
 * Results:
 *	The number of bytes written is returned or -1 on error. An output
 *	argument contains a POSIX error code if an error occurred, or zero.

 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;	/* Pipe state. */
    CONST char *buf;		/* The data buffer. */
    int toWrite;		/* How many bytes to write? */
    int *errorCodePtr;		/* Where to store error code. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int written;

    *errorCodePtr = 0;

    /*
     * Some OSes can throw an interrupt error, for which we should immediately
     * retry. [Bug #415131]
     */

    do {
	written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite);
    } while ((written < 0) && (errno == EINTR));

    if (written < 0) {
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
 *
 *	Initialize the notifier to watch the fds from this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will
 *	be seen by Tcl.
 *
 *----------------------------------------------------------------------
 */

static void
PipeWatchProc(instanceData, mask)
    ClientData instanceData;		/* The pipe state. */
    int mask;				/* Events of interest; an OR-ed
                                         * combination of TCL_READABLE,
                                         * TCL_WRITABEL and TCL_EXCEPTION. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int newmask;

    if (psPtr->inFile) {
	newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
	if (newmask) {







|
|






|
|
|
|







1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
 *
 *	Initialize the notifier to watch the fds from this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel will be
 *	seen by Tcl.
 *
 *----------------------------------------------------------------------
 */

static void
PipeWatchProc(instanceData, mask)
    ClientData instanceData;	/* The pipe state. */
    int mask;			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    PipeState *psPtr = (PipeState *) instanceData;
    int newmask;

    if (psPtr->inFile) {
	newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
	if (newmask) {
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
}

/*
 *----------------------------------------------------------------------
 *
 * PipeGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from
 *	inside a command pipeline based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
}

/*
 *----------------------------------------------------------------------
 *
 * PipeGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
 *	command pipeline based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229






1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247





























}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PidObjCmd --
 *
 *	This procedure is invoked to process the "pid" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PidObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST *objv;	/* Argument strings. */
{
    Tcl_Channel chan;
    Tcl_ChannelType *chanTypePtr;
    PipeState *pipePtr;
    int i;
    Tcl_Obj *resultPtr, *longObjPtr;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
    } else {






        chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
        if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
	chanTypePtr = Tcl_GetChannelType(chan);
	if (chanTypePtr != &pipeChannelType) {
	    return TCL_OK;
	}
        pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
	resultPtr = Tcl_NewObj();
        for (i = 0; i < pipePtr->numPids; i++) {
	    longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
	    Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
	}
	Tcl_SetObjResult(interp, resultPtr);
    }
    return TCL_OK;
}




































|
|


















<
<
<
<
<
<







>
>
>
>
>
>
|
|






|

|







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213






1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PidObjCmd --
 *
 *	This procedure is invoked to process the "pid" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PidObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST *objv;	/* Argument strings. */
{






    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
    } else {
	Tcl_Channel chan;
	Tcl_ChannelType *chanTypePtr;
	PipeState *pipePtr;
	int i;
	Tcl_Obj *resultPtr, *longObjPtr;

	chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
	chanTypePtr = Tcl_GetChannelType(chan);
	if (chanTypePtr != &pipeChannelType) {
	    return TCL_OK;
	}
	pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
	resultPtr = Tcl_NewObj();
	for (i = 0; i < pipePtr->numPids; i++) {
	    longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
	    Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
	}
	Tcl_SetObjResult(interp, resultPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizePipes --
 *
 *	Cleans up the pipe subsystem from Tcl_FinalizeThread
 *
 * Results:
 *	None.
 *
 * Notes:
 *	This procedure carries out no operation on Unix.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizePipes()
{
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixPort.h.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPort.h,v 1.39 2004/11/12 14:18:29 dkf Exp $
 */

#ifndef _TCLUNIXPORT
#define _TCLUNIXPORT

/*
 *---------------------------------------------------------------------------







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPort.h,v 1.39.2.2 2005/05/21 15:10:35 kennykb Exp $
 */

#ifndef _TCLUNIXPORT
#define _TCLUNIXPORT

/*
 *---------------------------------------------------------------------------
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
#   include <dirent.h>
#endif
#endif

#ifdef HAVE_STRUCT_DIRENT64
typedef struct dirent64	Tcl_DirEntry;
#   define TclOSreaddir		readdir64
#   define TclOSreaddir_r	readdir64_r
#else
typedef struct dirent	Tcl_DirEntry;
#   define TclOSreaddir		readdir
#   define TclOSreaddir_r	readdir_r
#endif

#ifdef HAVE_TYPE_OFF64_T
typedef off64_t		Tcl_SeekOffset;
#   define TclOSseek		lseek64
#   define TclOSopen		open64
#else







<



<







52
53
54
55
56
57
58

59
60
61

62
63
64
65
66
67
68
#   include <dirent.h>
#endif
#endif

#ifdef HAVE_STRUCT_DIRENT64
typedef struct dirent64	Tcl_DirEntry;
#   define TclOSreaddir		readdir64

#else
typedef struct dirent	Tcl_DirEntry;
#   define TclOSreaddir		readdir

#endif

#ifdef HAVE_TYPE_OFF64_T
typedef off64_t		Tcl_SeekOffset;
#   define TclOSseek		lseek64
#   define TclOSopen		open64
#else
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585

#ifdef TCL_THREADS
#   include <pthread.h>
typedef pthread_mutex_t TclpMutex;
EXTERN void	TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void	TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void	TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN Tcl_DirEntry * 	TclpReaddir(DIR *);
EXTERN struct tm *     	TclpLocaltime(CONST time_t *);
EXTERN struct tm *     	TclpGmtime(CONST time_t *);
EXTERN char *          	TclpInetNtoa(struct in_addr);
#   define readdir(x)	TclpReaddir(x)
/* #define localtime(x)	TclpLocaltime(x)
 * #define gmtime(x)	TclpGmtime(x)    */
#   undef inet_ntoa
#   define inet_ntoa(x)	TclpInetNtoa(x)
#   undef TclOSreaddir
#   define TclOSreaddir(x) TclpReaddir(x)
#   ifdef MAC_OSX_TCL
/* 
 * On Mac OS X, realpath is currently not
 * thread safe, c.f. SF bug # 711232.
 */
#	define NO_REALPATH
#   endif
#   ifdef HAVE_PTHREAD_ATTR_GET_NP
#	define TclpPthreadGetAttrs	pthread_attr_get_np
#	ifdef ATTRGETNP_NOT_DECLARED
/*
 * Assume it is in pthread_np.h if it isn't in pthread.h. [Bug 1064882]
 * We might need to revisit this in the future. :^(
 */







<



<




<
<
<
<
<
<
<
<
<







552
553
554
555
556
557
558

559
560
561

562
563
564
565









566
567
568
569
570
571
572

#ifdef TCL_THREADS
#   include <pthread.h>
typedef pthread_mutex_t TclpMutex;
EXTERN void	TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void	TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void	TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));

EXTERN struct tm *     	TclpLocaltime(CONST time_t *);
EXTERN struct tm *     	TclpGmtime(CONST time_t *);
EXTERN char *          	TclpInetNtoa(struct in_addr);

/* #define localtime(x)	TclpLocaltime(x)
 * #define gmtime(x)	TclpGmtime(x)    */
#   undef inet_ntoa
#   define inet_ntoa(x)	TclpInetNtoa(x)









#   ifdef HAVE_PTHREAD_ATTR_GET_NP
#	define TclpPthreadGetAttrs	pthread_attr_get_np
#	ifdef ATTRGETNP_NOT_DECLARED
/*
 * Assume it is in pthread_np.h if it isn't in pthread.h. [Bug 1064882]
 * We might need to revisit this in the future. :^(
 */

Changes to unix/tclUnixSock.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63






64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
/* 
 * tclUnixSock.c --
 *
 *	This file contains Unix-specific socket related code.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixSock.c,v 1.9 2004/04/06 22:25:57 dgp Exp $
 */

#include "tclInt.h"

/*
 * There is no portable macro for the maximum length
 * of host names returned by gethostbyname().  We should only
 * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS
 * host name limits.
 *
 * Note:  SYS_NMLN is a restriction on "uname" not on gethostbyname!
 *
 * For example HP-UX 10.20 has SYS_NMLN == 9,  while gethostbyname()
 * can return a fully qualified name from DNS of up to 255 bytes.
 *
 * Fix suggested by Viktor Dukhovni ([email protected])
 */

#if defined(SYS_NMLN) && SYS_NMLEN >= 256
#define TCL_HOSTNAME_LEN SYS_NMLEN
#else
#define TCL_HOSTNAME_LEN 256
#endif


/*
 * The following variable holds the network name of this host.
 */

static char hostname[TCL_HOSTNAME_LEN + 1];
static int  hostnameInited = 0;
TCL_DECLARE_MUTEX(hostMutex)



/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetHostName --
 *

 *	Returns the name of the local host.
 *
 * Results:
 *	A string containing the network name for this machine, or
 *	an empty string if we can't figure out the name.  The caller 
 *	must not modify or free this string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */







CONST char *
Tcl_GetHostName()
{
#ifndef NO_UNAME
    struct utsname u;
    struct hostent *hp;
#else
    char buffer[sizeof(hostname)];
#endif
    CONST char *native;

    Tcl_MutexLock(&hostMutex);
    if (hostnameInited) {
	Tcl_MutexUnlock(&hostMutex);
        return hostname;
    }

    native = NULL;
#ifndef NO_UNAME
    (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname));
    if (uname(&u) > -1) {				/* INTL: Native. */
        hp = gethostbyname(u.nodename);			/* INTL: Native. */
	if (hp == NULL) {
	    /*
	     * Sometimes the nodename is fully qualified, but gets truncated
	     * as it exceeds SYS_NMLN.  See if we can just get the immediate










|





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



|
|
<
>





|

>
|


<
<
<
<
<





>
>
>
>
>
>
|
<
|



<
<
<
<
<
<
<
<
<
<
<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16





















17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33





34
35
36
37
38
39
40
41
42
43
44
45

46
47
48
49













50
51
52
53
54
55
56
/* 
 * tclUnixSock.c --
 *
 *	This file contains Unix-specific socket related code.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixSock.c,v 1.9.2.3 2005/09/09 18:48:40 dgp Exp $
 */

#include "tclInt.h"

/*





















 * The following variable holds the network name of this host.
 */

static TclInitProcessGlobalValueProc	InitializeHostName;
static ProcessGlobalValue hostName =

	{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};


/*
 *----------------------------------------------------------------------
 *
 * InitializeHostName --
 *
 * 	This routine sets the process global value of the name of
 * 	the local host on which the process is running.
 *
 * Results:





 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
InitializeHostName(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
    CONST char *native = NULL;


#ifndef NO_UNAME
    struct utsname u;
    struct hostent *hp;













    (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname));
    if (uname(&u) > -1) {				/* INTL: Native. */
        hp = gethostbyname(u.nodename);			/* INTL: Native. */
	if (hp == NULL) {
	    /*
	     * Sometimes the nodename is fully qualified, but gets truncated
	     * as it exceeds SYS_NMLN.  See if we can just get the immediate
100
101
102
103
104
105
106



107
108
109












110





111
112
113
114
115
116

117
118
119
120
121
122
123

















124

125


126
127
128
129
130
131
132
	}
        if (hp != NULL) {
	    native = hp->h_name;
        } else {
	    native = u.nodename;
        }
    }



#else
    /*
     * Uname doesn't exist; try gethostname instead.












     */






    if (gethostname(buffer, sizeof(buffer)) > -1) {	/* INTL: Native. */
	native = buffer;
    }
#endif


    if (native == NULL) {
	hostname[0] = 0;
    } else {
	Tcl_ExternalToUtf(NULL, NULL, native, -1, 0, NULL, hostname,
		sizeof(hostname), NULL, NULL, NULL);
    }
    hostnameInited = 1;

















    Tcl_MutexUnlock(&hostMutex);

    return hostname;


}

/*
 *----------------------------------------------------------------------
 *
 * TclpHasSockets --
 *







>
>
>



>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>
>






>
|
<
|
|
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
	}
        if (hp != NULL) {
	    native = hp->h_name;
        } else {
	    native = u.nodename;
        }
    }
    if (native == NULL) {
	native = tclEmptyStringRep;
    }
#else
    /*
     * Uname doesn't exist; try gethostname instead.
     *
     * There is no portable macro for the maximum length
     * of host names returned by gethostbyname().  We should only
     * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS
     * host name limits.
     *
     * Note:  SYS_NMLN is a restriction on "uname" not on gethostbyname!
     *
     * For example HP-UX 10.20 has SYS_NMLN == 9,  while gethostbyname()
     * can return a fully qualified name from DNS of up to 255 bytes.
     *
     * Fix suggested by Viktor Dukhovni ([email protected])
     */
#    if defined(SYS_NMLN) && SYS_NMLEN >= 256
    char buffer[SYS_NMLEN];
#    else
    char buffer[256];
#    endif

    if (gethostname(buffer, sizeof(buffer)) > -1) {	/* INTL: Native. */
	native = buffer;
    }
#endif

    *encodingPtr = Tcl_GetEncoding(NULL, NULL);
    *lengthPtr = strlen(native);

    *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
    memcpy((VOID *) *valuePtr, (VOID *) native, (size_t)(*lengthPtr)+1);

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetHostName --
 *
 *	Returns the name of the local host.
 *
 * Results:
 *	A string containing the network name for this machine, or
 *	an empty string if we can't figure out the name.  The caller 
 *	must not modify or free this string.
 *
 * Side effects:
 *	Caches the name to return for future calls.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetHostName()
{
    return Tcl_GetString(TclGetProcessGlobalValue(&hostName));
}

/*
 *----------------------------------------------------------------------
 *
 * TclpHasSockets --
 *
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
 */

int
TclpHasSockets(interp)
    Tcl_Interp *interp;		/* Not used. */
{
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCutSockChannel --
 *
 *	Remove any thread local refs to this channel. See
 *	Tcl_CutChannel for more info. Dummy definition.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclpCutSockChannel(chan)
    Tcl_Channel chan;
{
}

/*
 *----------------------------------------------------------------------
 *
 * TclpSpliceSockChannel --
 *
 *	Insert thread local ref for this channel.
 *	Tcl_SpliceChannel for more info. Dummy definition.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclpSpliceSockChannel(chan)
    Tcl_Channel chan;
{
}








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
148
149
150
151
152
153
154
155














































 */

int
TclpHasSockets(interp)
    Tcl_Interp *interp;		/* Not used. */
{
    return TCL_OK;
}














































Changes to unix/tclUnixThrd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
/* 
 * tclUnixThrd.c --
 *
 *	This file implements the UNIX-specific thread support.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS:  @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12
 */

#include "tclInt.h"

#ifdef TCL_THREADS

#include "pthread.h"

typedef struct ThreadSpecificData {
    char	    	nabuf[16];
    struct {
	Tcl_DirEntry ent;
	char name[MAXNAMLEN+1];
    } rdbuf;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * masterLock is used to serialize creation of mutexes, condition
 * variables, and thread local storage.
 * This is the only place that can count on the ability to statically
 * initialize the mutex.
 */

static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * initLock is used to serialize initialization and finalization
 * of Tcl.  It cannot use any dyamically allocated storage.
 */

static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * allocLock is used by Tcl's version of malloc for synchronization.
 * For obvious reasons, cannot use any dyamically allocated storage.
 */

static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;

/*
 * These are for the critical sections inside this file.
 */

#define MASTER_LOCK	pthread_mutex_lock(&masterLock)
#define MASTER_UNLOCK	pthread_mutex_unlock(&masterLock)

#endif /* TCL_THREADS */


/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreaet --
 *
 *	This procedure creates a new thread.
 *
 * Results:
 *	TCL_OK if the thread could be created.  The thread ID is
 *	returned in a parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread */
    ClientData clientData;		/* The one argument to Main() */
    int stackSize;			/* Size of stack for the new thread */
    int flags;				/* Flags controlling behaviour of
					 * the new thread */
{
#ifdef TCL_THREADS
    pthread_attr_t attr;
    pthread_t theThread;
    int result;

    pthread_attr_init(&attr);
    pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);

#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
    if (stackSize != TCL_THREAD_STACK_DEFAULT) {
        pthread_attr_setstacksize(&attr, (size_t) stackSize);
#ifdef TCL_THREAD_STACK_MIN
    } else {
        /*
	 * Certain systems define a thread stack size that by default is
	 * too small for many operations.  The user has the option of
	 * defining TCL_THREAD_STACK_MIN to a value large enough to work
	 * for their needs.  This would look like (for 128K min stack):
	 *    make MEM_DEBUG_FLAGS=-DTCL_THREAD_STACK_MIN=131072L
	 *
	 * This solution is not optimal, as we should allow the user to
	 * specify a size at runtime, but we don't want to slow this function
	 * down, and that would still leave the main thread at the default.
	 */

        size_t size;
	result = pthread_attr_getstacksize(&attr, &size);
	if (!result && (size < TCL_THREAD_STACK_MIN)) {
	    pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN);
	}
#endif
    }
#endif
    if (! (flags & TCL_THREAD_JOINABLE)) {
        pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED);
    }


    if (pthread_create(&theThread, &attr,
	    (void * (*)(void *))proc, (void *)clientData) &&
	    pthread_create(&theThread, NULL,
		    (void * (*)(void *))proc, (void *)clientData)) {








|
|











|
<
<
<
<





|
<
|
|





|
|





|
|


















|




|
|













|
|











|


|
|
|
|
|







|








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22




23
24
25
26
27
28

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
/* 
 * tclUnixThrd.c --
 *
 *	This file implements the UNIX-specific thread support.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS:  @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12
 */

#include "tclInt.h"

#ifdef TCL_THREADS

#include "pthread.h"

typedef struct ThreadSpecificData {
    char nabuf[16];




} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * masterLock is used to serialize creation of mutexes, condition variables,

 * and thread local storage. This is the only place that can count on the
 * ability to statically initialize the mutex.
 */

static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * initLock is used to serialize initialization and finalization of Tcl. It
 * cannot use any dyamically allocated storage.
 */

static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dyamically allocated storage.
 */

static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;

/*
 * These are for the critical sections inside this file.
 */

#define MASTER_LOCK	pthread_mutex_lock(&masterLock)
#define MASTER_UNLOCK	pthread_mutex_unlock(&masterLock)

#endif /* TCL_THREADS */


/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
 *
 *	This procedure creates a new thread.
 *
 * Results:
 *	TCL_OK if the thread could be created. The thread ID is returned in a
 *	parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread */
    ClientData clientData;		/* The one argument to Main() */
    int stackSize;			/* Size of stack for the new thread */
    int flags;				/* Flags controlling behaviour of the
					 * new thread. */
{
#ifdef TCL_THREADS
    pthread_attr_t attr;
    pthread_t theThread;
    int result;

    pthread_attr_init(&attr);
    pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);

#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
    if (stackSize != TCL_THREAD_STACK_DEFAULT) {
	pthread_attr_setstacksize(&attr, (size_t) stackSize);
#ifdef TCL_THREAD_STACK_MIN
    } else {
	/*
	 * Certain systems define a thread stack size that by default is too
	 * small for many operations. The user has the option of defining
	 * TCL_THREAD_STACK_MIN to a value large enough to work for their
	 * needs. This would look like (for 128K min stack):
	 *    make MEM_DEBUG_FLAGS=-DTCL_THREAD_STACK_MIN=131072L
	 *
	 * This solution is not optimal, as we should allow the user to
	 * specify a size at runtime, but we don't want to slow this function
	 * down, and that would still leave the main thread at the default.
	 */

	size_t size;
	result = pthread_attr_getstacksize(&attr, &size);
	if (!result && (size < TCL_THREAD_STACK_MIN)) {
	    pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN);
	}
#endif
    }
#endif
    if (! (flags & TCL_THREAD_JOINABLE)) {
	pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED);
    }


    if (pthread_create(&theThread, &attr,
	    (void * (*)(void *))proc, (void *)clientData) &&
	    pthread_create(&theThread, NULL,
		    (void * (*)(void *))proc, (void *)clientData)) {
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
 *
 *	This procedure waits upon the exit of the specified thread.
 *
 * Results:
 *	TCL_OK if the wait was successful, TCL_ERROR else.
 *
 * Side effects:
 *	The result area is set to the exit code of the thread we
 *	waited upon.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_JoinThread(threadId, state)
    Tcl_ThreadId threadId; /* Id of the thread to wait upon */
    int*     state;        /* Reference to the storage the result
			    * of the thread we wait upon will be
			    * written into. */
{
#ifdef TCL_THREADS
    int result;

    result = pthread_join ((pthread_t) threadId, (VOID**) state);
    return (result == 0) ? TCL_OK : TCL_ERROR;
#else







|
<






|
|
|
|







144
145
146
147
148
149
150
151

152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
 *
 *	This procedure waits upon the exit of the specified thread.
 *
 * Results:
 *	TCL_OK if the wait was successful, TCL_ERROR else.
 *
 * Side effects:
 *	The result area is set to the exit code of the thread we waited upon.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_JoinThread(threadId, state)
    Tcl_ThreadId threadId;	/* Id of the thread to wait upon. */
    int *state;			/* Reference to the storage the result of the
				 * thread we wait upon will be written
				 * into. */
{
#ifdef TCL_THREADS
    int result;

    result = pthread_join ((pthread_t) threadId, (VOID**) state);
    return (result == 0) ? TCL_OK : TCL_ERROR;
#else
237
238
239
240
241
242
243
244
245
246
247

248
249
250
251
252
253
254
	pthread_attr_destroy(&threadAttr);
	return -1;
    }
    pthread_attr_destroy(&threadAttr);
    return (int) stackSize;
#else
    /*
     * Cannot determine the real stack size of this thread.  The
     * caller might want to try looking at the process accounting
     * limits instead.
     */

    return 0;
#endif
}
#endif /* TCL_THREADS */

/*
 *----------------------------------------------------------------------







|
|
<

>







231
232
233
234
235
236
237
238
239

240
241
242
243
244
245
246
247
248
	pthread_attr_destroy(&threadAttr);
	return -1;
    }
    pthread_attr_destroy(&threadAttr);
    return (int) stackSize;
#else
    /*
     * Cannot determine the real stack size of this thread. The caller might
     * want to try looking at the process accounting limits instead.

     */

    return 0;
#endif
}
#endif /* TCL_THREADS */

/*
 *----------------------------------------------------------------------
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295

/*
 *----------------------------------------------------------------------
 *
 * TclpInitLock
 *
 *	This procedure is used to grab a lock that serializes initialization
 *	and finalization of Tcl.  On some platforms this may also initialize
 *	the mutex used to serialize creation of more mutexes and thread
 *	local storage keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the initialization mutex.
 *







|
|
|







273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289

/*
 *----------------------------------------------------------------------
 *
 * TclpInitLock
 *
 *	This procedure is used to grab a lock that serializes initialization
 *	and finalization of Tcl. On some platforms this may also initialize
 *	the mutex used to serialize creation of more mutexes and thread local
 *	storage keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the initialization mutex.
 *
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeLock
 *
 *	This procedure is used to destroy all private resources used in
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys everything private.  TclpInitLock must be held
 *	entering this function.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock ()
{
#ifdef TCL_THREADS
    /*
     * You do not need to destroy mutexes that were created with the
     * PTHREAD_MUTEX_INITIALIZER macro.  These mutexes do not need
     * any destruction: masterLock, allocLock, and initLock.
     */

    pthread_mutex_unlock(&initLock);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclpInitUnlock
 *
 *	This procedure is used to release a lock that serializes initialization
 *	and finalization of Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the initialization mutex.
 *







|
|





|
|










|
|

>









|
|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeLock
 *
 *	This procedure is used to destroy all private resources used in this
 *	file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys everything private. TclpInitLock must be held entering this
 *	function.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock ()
{
#ifdef TCL_THREADS
    /*
     * You do not need to destroy mutexes that were created with the
     * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
     * destruction: masterLock, allocLock, and initLock.
     */

    pthread_mutex_unlock(&initLock);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclpInitUnlock
 *
 *	This procedure is used to release a lock that serializes
 *	initialization and finalization of Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the initialization mutex.
 *
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation
 *	and finalization of serialization objects.  This interface is
 *	only needed in finalization; it is hidden during
 *	creation of the objects.
 *
 *	This lock must be different than the initLock because the
 *	initLock is held during creation of syncronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *







|
|
|
<

|
|







356
357
358
359
360
361
362
363
364
365

366
367
368
369
370
371
372
373
374
375
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation and
 *	finalization of serialization objects. This interface is only needed
 *	in finalization; it is hidden during creation of the objects.

 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of syncronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407


/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation
 *	and finalization of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *







|
|







386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401


/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	finalization of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized
 *	mutex for use by the memory allocator.  The alloctor must
 *	use this lock, because all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to
 *	Tcl_MutexLock and Tcl_MutexUnlock.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|


|
|







412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432


/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The alloctor must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
#ifdef TCL_THREADS

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexLock --
 *
 *	This procedure is invoked to lock a mutex.  This procedure
 *	handles initializing the mutex, if necessary.  The caller
 *	can rely on the fact that Tcl_Mutex is an opaque pointer.
 *	This routine will change that pointer from NULL after first use.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread.  The mutex is aquired when
 *	this returns.  Will allocate memory for a pthread_mutex_t
 *	and initialize this the first time this Tcl_Mutex is used.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_MutexLock(mutexPtr)
    Tcl_Mutex *mutexPtr;	/* Really (pthread_mutex_t **) */







|
|
|
|





|
|
|







443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
#ifdef TCL_THREADS

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexLock --
 *
 *	This procedure is invoked to lock a mutex. This procedure handles
 *	initializing the mutex, if necessary. The caller can rely on the fact
 *	that Tcl_Mutex is an opaque pointer. This routine will change that
 *	pointer from NULL after first use.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread. The mutex is aquired when this returns.
 *	Will allocate memory for a pthread_mutex_t and initialize this the
 *	first time this Tcl_Mutex is used.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_MutexLock(mutexPtr)
    Tcl_Mutex *mutexPtr;	/* Really (pthread_mutex_t **) */
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509


/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexUnlock --
 *
 *	This procedure is invoked to unlock a mutex.  The mutex must
 *	have been locked by Tcl_MutexLock.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex is released when this returns.
 *







|
|







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503


/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexUnlock --
 *
 *	This procedure is invoked to unlock a mutex. The mutex must have been
 *	locked by Tcl_MutexLock.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex is released when this returns.
 *
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766


/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex.  This is only
 *	safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeMutex(mutexPtr)
    Tcl_Mutex *mutexPtr;
{
    pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr;
    if (pmutexPtr != NULL) {
        pthread_mutex_destroy(pmutexPtr);
	ckfree((char *)pmutexPtr);
	*mutexPtr = NULL;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeyInit --
 *
 *	This procedure initializes a thread specific data block key.
 *	Each thread has table of pointers to thread specific data.
 *	all threads agree on which table entry is used by each module.
 *	this is remembered in a "data key", that is just an index into
 *	this table.  To allow self initialization, the interface
 *	passes a pointer to this key and the first thread to use
 *	the key fills in the pointer to the key.  The key should be
 *	a process-wide static.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Will allocate memory the first time this process calls for
 *	this key.  In this case it modifies its argument
 *	to hold the pointer to information about the key.
 *
 *----------------------------------------------------------------------
 */

void
TclpThreadDataKeyInit(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
{
    pthread_key_t *pkeyPtr;

    MASTER_LOCK;
    if (*keyPtr == NULL) {
	pkeyPtr = (pthread_key_t *)ckalloc(sizeof(pthread_key_t));
	pthread_key_create(pkeyPtr, NULL);
	*keyPtr = (Tcl_ThreadDataKey)pkeyPtr;
	TclRememberDataKey(keyPtr);
    }
    MASTER_UNLOCK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeyGet --
 *
 *	This procedure returns a pointer to a block of thread local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure, or NULL
 *	if the memory has not been assigned to this key for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

VOID *
TclpThreadDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
{
    pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr;
    if (pkeyPtr == NULL) {
	return NULL;
    } else {
	return (VOID *)pthread_getspecific(*pkeyPtr);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeySet --
 *
 *	This procedure sets the pointer to a block of thread local storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the thread so future calls to TclpThreadDataKeyGet with
 *	this key will return the data pointer.
 *
 *----------------------------------------------------------------------
 */

void
TclpThreadDataKeySet(keyPtr, data)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
    VOID *data;			/* Thread local storage */
{
    pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr;
    pthread_setspecific(*pkeyPtr, data);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeThreadData --
 *
 *	This procedure cleans up the thread-local storage.  This is
 *	called once for each thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up all thread local storage.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeThreadData(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    VOID *result;
    pthread_key_t *pkeyPtr;

    if (*keyPtr != NULL) {
	pkeyPtr = *(pthread_key_t **)keyPtr;
	result = (VOID *)pthread_getspecific(*pkeyPtr);
	if (result != NULL) {
	    ckfree((char *)result);
	    pthread_setspecific(*pkeyPtr, (void *)NULL);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeThreadDataKey --
 *
 *	This procedure is invoked to clean up one key.  This is a
 *	process-wide storage identifier.  The thread finalization code
 *	cleans up the thread local storage itself.
 *
 *	This assumes the master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The key is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeThreadDataKey(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    pthread_key_t *pkeyPtr;
    if (*keyPtr != NULL) {
	pkeyPtr = *(pthread_key_t **)keyPtr;
	pthread_key_delete(*pkeyPtr);
	ckfree((char *)pkeyPtr);
	*keyPtr = NULL;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionWait --
 *
 *	This procedure is invoked to wait on a condition variable.
 *	The mutex is automically released as part of the wait, and
 *	automatically grabbed when the condition is signaled.
 *
 *	The mutex must be held when this procedure is called.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread.  The mutex is aquired when
 *	this returns.  Will allocate memory for a pthread_mutex_t
 *	and initialize this the first time this Tcl_Mutex is used.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
    Tcl_Condition *condPtr;	/* Really (pthread_cond_t **) */
    Tcl_Mutex *mutexPtr;	/* Really (pthread_mutex_t **) */
    Tcl_Time *timePtr;		/* Timeout on waiting period */
{
    pthread_cond_t *pcondPtr;
    pthread_mutex_t *pmutexPtr;
    struct timespec ptime;

    if (*condPtr == NULL) {
	MASTER_LOCK;

	/* 
	 * Double check inside mutex to avoid race,
	 * then initialize condition variable if necessary.
	 */

	if (*condPtr == NULL) {
	    pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t));
	    pthread_cond_init(pcondPtr, NULL);
	    *condPtr = (Tcl_Condition)pcondPtr;
	    TclRememberCondition(condPtr);







|
|


















|




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






|
|
|







|
|
|


















|
|







514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545









































































































































































546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591


/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex. This is only safe to
 *	call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeMutex(mutexPtr)
    Tcl_Mutex *mutexPtr;
{
    pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr;
    if (pmutexPtr != NULL) {
	pthread_mutex_destroy(pmutexPtr);
	ckfree((char *)pmutexPtr);
	*mutexPtr = NULL;
    }
}










































































































































































/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionWait --
 *
 *	This procedure is invoked to wait on a condition variable. The mutex
 *	is automically released as part of the wait, and automatically grabbed
 *	when the condition is signaled.
 *
 *	The mutex must be held when this procedure is called.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread. The mutex is aquired when this returns.
 *	Will allocate memory for a pthread_mutex_t and initialize this the
 *	first time this Tcl_Mutex is used.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
    Tcl_Condition *condPtr;	/* Really (pthread_cond_t **) */
    Tcl_Mutex *mutexPtr;	/* Really (pthread_mutex_t **) */
    Tcl_Time *timePtr;		/* Timeout on waiting period */
{
    pthread_cond_t *pcondPtr;
    pthread_mutex_t *pmutexPtr;
    struct timespec ptime;

    if (*condPtr == NULL) {
	MASTER_LOCK;

	/* 
	 * Double check inside mutex to avoid race, then initialize condition
	 * variable if necessary.
	 */

	if (*condPtr == NULL) {
	    pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t));
	    pthread_cond_init(pcondPtr, NULL);
	    *condPtr = (Tcl_Condition)pcondPtr;
	    TclRememberCondition(condPtr);
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionNotify --
 *
 *	This procedure is invoked to signal a condition variable.
 *
 *	The mutex must be held during this call to avoid races,
 *	but this interface does not enforce that.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May unblock another thread.
 *







|
|







615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionNotify --
 *
 *	This procedure is invoked to signal a condition variable.
 *
 *	The mutex must be held during this call to avoid races, but this
 *	interface does not enforce that.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May unblock another thread.
 *
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837


/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable.
 *	This is only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:







|
|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662


/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869




870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941

942
943
944
945
946
947
948
949
950
951
952
953
954
#endif /* TCL_THREADS */

/*
 *----------------------------------------------------------------------
 *
 * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
 *
 *	These procedures replace core C versions to be used in a
 *	threaded environment.
 *
 * Results:
 *	See documentation of C functions.
 *
 * Side effects:
 *	See documentation of C functions.
 *




 *----------------------------------------------------------------------
 */

#if defined(TCL_THREADS) && !defined(HAVE_READDIR_R)
TCL_DECLARE_MUTEX( rdMutex )
#undef readdir
#endif

Tcl_DirEntry *
TclpReaddir(DIR * dir)
{
    Tcl_DirEntry *ent;
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_READDIR_R
    ent = &tsdPtr->rdbuf.ent;
# ifdef HAVE_TWO_ARG_READDIR_R
    if (TclOSreaddir_r(dir, ent) != 0) {
# else /* HAVE_THREE_ARG_READDIR_R */
    if (TclOSreaddir_r(dir, ent, &ent) != 0) {
# endif /* HAVE_TWO_ARG_READDIR_R */
	ent = NULL;
    }

#else /* !HAVE_READDIR_R */

    Tcl_MutexLock(&rdMutex);
#   ifdef HAVE_STRUCT_DIRENT64
    ent = readdir64(dir);
#   else /* !HAVE_STRUCT_DIRENT64 */
    ent = readdir(dir);
#   endif /* HAVE_STRUCT_DIRENT64 */
    if (ent != NULL) {
	memcpy((VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent,
		sizeof(tsdPtr->rdbuf));
	ent = &tsdPtr->rdbuf.ent;
    }
    Tcl_MutexUnlock(&rdMutex);

#endif /* HAVE_READDIR_R */
#else
#   ifdef HAVE_STRUCT_DIRENT64
    ent = readdir64(dir);
#   else /* !HAVE_STRUCT_DIRENT64 */
    ent = readdir(dir);
#   endif /* HAVE_STRUCT_DIRENT64 */
#endif
    return ent;
}
char *
TclpInetNtoa(struct in_addr addr)
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    union {
    	unsigned long l;
    	unsigned char b[4];
    } u;
    
    u.l = (unsigned long) addr.s_addr;
    sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", u.b[0], u.b[1], u.b[2], u.b[3]);
    return tsdPtr->nabuf;
#else
    return inet_ntoa(addr);
#endif
}

#ifdef TCL_THREADS
/*
 * Additions by AOL for specialized thread memory allocator.
 */

#ifdef USE_THREAD_ALLOC
static volatile int initialized = 0;
static pthread_key_t	key;

typedef struct allocMutex {
    Tcl_Mutex       tlock;
    pthread_mutex_t plock;
} allocMutex;

Tcl_Mutex *
TclpNewAllocMutex(void)
{
    struct allocMutex *lockPtr;







|
|







>
>
>
>



<
<
<
<
<



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
|
<

<
<
<
<
<
<
<
<
<
<






|
|









|




>





|







679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701





702
703
704




















705





706

707










708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
#endif /* TCL_THREADS */

/*
 *----------------------------------------------------------------------
 *
 * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
 *
 *	These procedures replace core C versions to be used in a threaded
 *	environment.
 *
 * Results:
 *	See documentation of C functions.
 *
 * Side effects:
 *	See documentation of C functions.
 *
 * Notes:
 *	TclpReaddir is no longer used by the core (see 1095909), but it
 *	appears in the internal stubs table (see #589526).
 *
 *----------------------------------------------------------------------
 */






Tcl_DirEntry *
TclpReaddir(DIR * dir)
{




















    return TclOSreaddir(dir);





}












char *
TclpInetNtoa(struct in_addr addr)
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    union {
	unsigned long l;
	unsigned char b[4];
    } u;
    
    u.l = (unsigned long) addr.s_addr;
    sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", u.b[0], u.b[1], u.b[2], u.b[3]);
    return tsdPtr->nabuf;
#else
    return inet_ntoa(addr);
#endif
}

#ifdef TCL_THREADS
/*
 * Additions by AOL for specialized thread memory allocator.
 */

#ifdef USE_THREAD_ALLOC
static volatile int initialized = 0;
static pthread_key_t	key;

typedef struct allocMutex {
    Tcl_Mutex tlock;
    pthread_mutex_t plock;
} allocMutex;

Tcl_Mutex *
TclpNewAllocMutex(void)
{
    struct allocMutex *lockPtr;
963
964
965
966
967
968
969
970


971
972
973
974
975
976
977
978



979
980


981
982

983
984
985
986
987
988
989
990
991
992
993
}

void
TclpFreeAllocMutex(mutex)
    Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
    allocMutex* lockPtr = (allocMutex*) mutex;
    if (!lockPtr) return;


    pthread_mutex_destroy(&lockPtr->plock);
    free(lockPtr);
}

void TclpFreeAllocCache(ptr)
    void *ptr;
{
    extern void TclFreeAllocCache(void *);




    TclFreeAllocCache(ptr);


    /*
     * Perform proper cleanup of things done in TclpGetAllocCache.

     */
    if (initialized) {
        pthread_key_delete(key);
        initialized = 0;
    }
}

void *
TclpGetAllocCache(void)
{
    if (!initialized) {







|
>
>







|
>
>
>

|
>
>
|
|
>
|
|
|
|







752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
}

void
TclpFreeAllocMutex(mutex)
    Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
    allocMutex* lockPtr = (allocMutex*) mutex;
    if (!lockPtr) {
	return;
    }
    pthread_mutex_destroy(&lockPtr->plock);
    free(lockPtr);
}

void TclpFreeAllocCache(ptr)
    void *ptr;
{
    if (ptr != NULL) {
	/*
	 * Called by the pthread lib when a thread exits
	 */

	TclFreeAllocCache(ptr);

    } else if (initialized) {
	/*
	 * Called by us in TclFinalizeThreadAlloc() during the library
	 * finalization initiated from Tcl_Finalize()
	 */

	pthread_key_delete(key);
	initialized = 0;
    }
}

void *
TclpGetAllocCache(void)
{
    if (!initialized) {
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011








}

void
TclpSetAllocCache(void *arg)
{
    pthread_setspecific(key, arg);
}

#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */















<


>
>
>
>
>
>
>
>
799
800
801
802
803
804
805

806
807
808
809
810
811
812
813
814
815
}

void
TclpSetAllocCache(void *arg)
{
    pthread_setspecific(key, arg);
}

#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclUnixTime.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

44

45
46
47












48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
/* 
 * tclUnixTime.c --
 *
 *	Contains Unix specific versions of Tcl functions that
 *	obtain time values from the operating system.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixTime.c,v 1.22 2004/09/27 14:31:20 kennykb Exp $
 */

#include "tclInt.h"
#include <locale.h>
#define TM_YEAR_BASE 1900
#define IsLeapYear(x)   ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))

/*
 * TclpGetDate is coded to return a pointer to a 'struct tm'.  For
 * thread safety, this structure must be in thread-specific data.
 * The 'tmKey' variable is the key to this buffer.
 */

static Tcl_ThreadDataKey tmKey;
typedef struct ThreadSpecificData {
    struct tm gmtime_buf;
    struct tm localtime_buf;
} ThreadSpecificData;

/*
 * If we fall back on the thread-unsafe versions of gmtime and localtime,
 * use this mutex to try to protect them.
 */

TCL_DECLARE_MUTEX(tmMutex)

static char* lastTZ = NULL;	/* Holds the last setting of the
				 * TZ environment variable, or an
				 * empty string if the variable was
				 * not set. */


/* Static functions declared in this file */


static void SetTZIfNecessary _ANSI_ARGS_((void));
static void CleanupMemory _ANSI_ARGS_((ClientData));













/*
 *-----------------------------------------------------------------------------
 *
 * TclpGetSeconds --
 *
 *	This procedure returns the number of seconds from the epoch.  On
 *	most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
 *
 * Results:
 *	Number of seconds from the epoch.
 *
 * Side effects:
 *	None.
 *
|


|
|



|
|

|





|


|
|
|









|
|




|
|
|
<

>
|
>

|
|
>
>
>
>
>
>
>
>
>
>
>
>






|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
/*
 * tclUnixTime.c --
 *
 *	Contains Unix specific versions of Tcl functions that obtain time
 *	values from the operating system.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixTime.c,v 1.22.2.2 2005/08/02 18:16:58 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>
#define TM_YEAR_BASE 1900
#define IsLeapYear(x)	(((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0))

/*
 * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread
 * safety, this structure must be in thread-specific data. The 'tmKey'
 * variable is the key to this buffer.
 */

static Tcl_ThreadDataKey tmKey;
typedef struct ThreadSpecificData {
    struct tm gmtime_buf;
    struct tm localtime_buf;
} ThreadSpecificData;

/*
 * If we fall back on the thread-unsafe versions of gmtime and localtime, use
 * this mutex to try to protect them.
 */

TCL_DECLARE_MUTEX(tmMutex)

static char *lastTZ = NULL;	/* Holds the last setting of the TZ
				 * environment variable, or an empty string if
				 * the variable was not set. */


/*
 * Static functions declared in this file.
 */

static void		SetTZIfNecessary _ANSI_ARGS_((void));
static void		CleanupMemory _ANSI_ARGS_((ClientData));
static void		NativeScaleTime _ANSI_ARGS_((Tcl_Time *timebuf,
			    ClientData clientData));
static void		NativeGetTime _ANSI_ARGS_((Tcl_Time *timebuf,
			    ClientData clientData));

/*
 * TIP #233 (Virtualized Time): Data for the time hooks, if any.
 */

Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
ClientData tclTimeClientData = NULL;

/*
 *-----------------------------------------------------------------------------
 *
 * TclpGetSeconds --
 *
 *	This procedure returns the number of seconds from the epoch. On most
 *	Unix systems the epoch is Midnight Jan 1, 1970 GMT.
 *
 * Results:
 *	Number of seconds from the epoch.
 *
 * Side effects:
 *	None.
 *
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94

95


96


97



98
99
100
101
102
103

104

105

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134


135
136
137
138
139
140
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

209
210


211


212
213
214
215
216



217
218
219
220
221
222
223
224
225
226
227

228
229
230
231
232
233
234
235
236



237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273

/*
 *-----------------------------------------------------------------------------
 *
 * TclpGetClicks --
 *
 *	This procedure returns a value that represents the highest resolution
 *	clock available on the system.  There are no garantees on what the
 *	resolution will be.  In Tcl we will call this value a "click".  The
 *	start time is also system dependant.
 *
 * Results:
 *	Number of clicks from some start time.
 *
 * Side effects:
 *	None.
 *
 *-----------------------------------------------------------------------------
 */

unsigned long
TclpGetClicks()
{
    unsigned long now;

#ifdef NO_GETTOD


    struct tms dummy;


#else



    struct timeval date;
    struct timezone tz;
#endif

#ifdef NO_GETTOD
    now = (unsigned long) times(&dummy);

#else

    gettimeofday(&date, &tz);

    now = date.tv_sec*1000000 + date.tv_usec;
#endif

    return now;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTimeZone --
 *
 *	Determines the current timezone.  The method varies wildly
 *	between different platform implementations, so its hidden in
 *	this function.
 *
 * Results:
 *	The return value is the local time zone, measured in
 *	minutes away from GMT (-ve for east, +ve for west).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpGetTimeZone (currentTime)
    unsigned long  currentTime;
{


    /*
     * We prefer first to use the time zone in "struct tm" if the
     * structure contains such a member.  Following that, we try
     * to locate the external 'timezone' variable and use its value.
     * If both of those methods fail, we attempt to convert a known
     * time to local time and use the difference from UTC as the local
     * time zone.  In all cases, we need to undo any Daylight Saving Time
     * adjustment.
     */
    
#if defined(HAVE_TM_TZADJ)
#   define TCL_GOT_TIMEZONE

    /* Struct tm contains tm_tzadj - that value may be used. */


    time_t      curTime = (time_t) currentTime;
    struct tm  *timeDataPtr = TclpLocaltime(&curTime);
    int         timeZone;

    timeZone = timeDataPtr->tm_tzadj  / 60;
    if (timeDataPtr->tm_isdst) {
        timeZone += 60;
    }
    
    return timeZone;

#endif

#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
#   define TCL_GOT_TIMEZONE

    /* Struct tm contains tm_gmtoff - that value may be used. */


    time_t     curTime = (time_t) currentTime;
    struct tm *timeDataPtr = TclpLocaltime(&curTime);
    int        timeZone;

    timeZone = -(timeDataPtr->tm_gmtoff / 60);
    if (timeDataPtr->tm_isdst) {
        timeZone += 60;
    }
    
    return timeZone;

#endif

#if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ)
#   define TCL_GOT_TIMEZONE

    int         timeZone;

    /* The 'timezone' external var is present and may be used. */


    SetTZIfNecessary();

    /*
     * Note: this is not a typo in "timezone" below!  See tzset
     * documentation for details.
     */

    timeZone = timezone / 60;
    return timeZone;

#endif

#if !defined(TCL_GOT_TIMEZONE) 
#define TCL_GOT_TIMEZONE 1
    /*
     * Fallback - determine time zone with a known reference time.
     */

    int timeZone;
    time_t tt;
    struct tm *stm;

    tt = 849268800L;      /*    1996-11-29 12:00:00  GMT */
    stm = TclpLocaltime(&tt); /* eg 1996-11-29  6:00:00  CST6CDT */


    /* The calculation below assumes a max of +12 or -12 hours from GMT */


    timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min);
    if ( stm -> tm_isdst ) {
	timeZone += 60;
    }
    return timeZone;  /* eg +360 for CST6CDT */



#endif

#ifndef TCL_GOT_TIMEZONE
    /*
     * Cause compile error, we don't know how to get timezone.
     */

#error autoconf did not figure out how to determine the timezone. 

#endif


}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *
 *	Gets the current system time in seconds and microseconds
 *	since the beginning of the epoch: 00:00 UCT, January 1, 1970.



 *
 * Results:
 *	Returns the current time in timePtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetTime(timePtr)
    Tcl_Time *timePtr;		/* Location to store time information. */
{
    struct timeval tv;
    struct timezone tz;
    
    (void) gettimeofday(&tv, &tz);
    timePtr->sec = tv.tv_sec;
    timePtr->usec = tv.tv_usec;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDate --
 *
 *	This function converts between seconds and struct tm.  If
 *	useGMT is true, then the returned date will be in Greenwich
 *	Mean Time (GMT).  Otherwise, it will be in the local time zone.
 *
 * Results:
 *	Returns a static tm structure.
 *
 * Side effects:
 *	None.
 *







|
|















>

>
>
|
>
>
|
>
>
>
|
<
<

<
|
>

>
|
>
|










|
|
<


|
|








|
|

>
>

|
|
|
<
|
|
|

|

|
|
|
>

|
|
<



|

<
<
<



|
|
|
>

|

<



|

<
<
<



|
|
<
<
|
>




|
|



<
<


|
|




<


>
|
|
>
>
|
>
>

|


|
>
>
>




|


|
<


>







|
|
>
>
>














<
<
|
<
<
<







|
|
|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119


120

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178



179
180
181
182
183
184
185
186
187
188

189
190
191
192
193



194
195
196
197
198


199
200
201
202
203
204
205
206
207
208
209


210
211
212
213
214
215
216
217

218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243

244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272


273



274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290

/*
 *-----------------------------------------------------------------------------
 *
 * TclpGetClicks --
 *
 *	This procedure returns a value that represents the highest resolution
 *	clock available on the system. There are no garantees on what the
 *	resolution will be. In Tcl we will call this value a "click". The
 *	start time is also system dependant.
 *
 * Results:
 *	Number of clicks from some start time.
 *
 * Side effects:
 *	None.
 *
 *-----------------------------------------------------------------------------
 */

unsigned long
TclpGetClicks()
{
    unsigned long now;

#ifdef NO_GETTOD
    if (tclGetTimeProcPtr != NativeGetTime) {
	Tcl_Time time;

	(*tclGetTimeProcPtr) (&time, tclTimeClientData);
	now = time.sec*1000000 + time.usec;
    } else {
	/*
	 * A semi-NativeGetTime, specialized to clicks.
	 */
	struct tms dummy;




	now = (unsigned long) times(&dummy);
    }
#else
    Tcl_Time time;

    (*tclGetTimeProcPtr) (&time, tclTimeClientData);
    now = time.sec*1000000 + time.usec;
#endif

    return now;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTimeZone --
 *
 *	Determines the current timezone. The method varies wildly between
 *	different platform implementations, so its hidden in this function.

 *
 * Results:
 *	The return value is the local time zone, measured in minutes away from
 *	GMT (-ve for east, +ve for west).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpGetTimeZone(currentTime)
    unsigned long currentTime;
{
    int timeZone;

    /*
     * We prefer first to use the time zone in "struct tm" if the structure
     * contains such a member. Following that, we try to locate the external
     * 'timezone' variable and use its value. If both of those methods fail,

     * we attempt to convert a known time to local time and use the difference
     * from UTC as the local time zone. In all cases, we need to undo any
     * Daylight Saving Time adjustment.
     */

#if defined(HAVE_TM_TZADJ)
#define TCL_GOT_TIMEZONE
    /*
     * Struct tm contains tm_tzadj - that value may be used.
     */

    time_t curTime = (time_t) currentTime;
    struct tm *timeDataPtr = TclpLocaltime(&curTime);


    timeZone = timeDataPtr->tm_tzadj  / 60;
    if (timeDataPtr->tm_isdst) {
	timeZone += 60;
    }



#endif

#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
#define TCL_GOT_TIMEZONE
    /*
     * Struct tm contains tm_gmtoff - that value may be used.
     */

    time_t curTime = (time_t) currentTime;
    struct tm *timeDataPtr = TclpLocaltime(&curTime);


    timeZone = -(timeDataPtr->tm_gmtoff / 60);
    if (timeDataPtr->tm_isdst) {
	timeZone += 60;
    }



#endif

#if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ)
#define TCL_GOT_TIMEZONE
    /*


     * The 'timezone' external var is present and may be used.
     */

    SetTZIfNecessary();

    /*
     * Note: this is not a typo in "timezone" below! See tzset documentation
     * for details.
     */

    timeZone = timezone / 60;


#endif

#if !defined(TCL_GOT_TIMEZONE)
#define TCL_GOT_TIMEZONE
    /*
     * Fallback - determine time zone with a known reference time.
     */


    time_t tt;
    struct tm *stm;

    tt = 849268800L;		/* 1996-11-29 12:00:00  GMT */
    stm = TclpLocaltime(&tt);	/* eg 1996-11-29  6:00:00  CST6CDT */

    /*
     * The calculation below assumes a max of +12 or -12 hours from GMT.
     */

    timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min);
    if (stm->tm_isdst) {
	timeZone += 60;
    }

    /*
     * Now have offset for our known reference time, eg +360 for CST6CDT.
     */
#endif

#ifndef TCL_GOT_TIMEZONE
    /*
     * Cause fatal compile error, we don't know how to get timezone.
     */

#error autoconf did not figure out how to determine the timezone.

#endif

    return timeZone;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *
 *	Gets the current system time in seconds and microseconds since the
 *	beginning of the epoch: 00:00 UCT, January 1, 1970.
 *
 *	This function is hooked, allowing users to specify their own virtual
 *	system time.
 *
 * Results:
 *	Returns the current time in timePtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetTime(timePtr)
    Tcl_Time *timePtr;		/* Location to store time information. */
{


    (*tclGetTimeProcPtr) (timePtr, tclTimeClientData);



}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDate --
 *
 *	This function converts between seconds and struct tm. If useGMT is
 *	true, then the returned date will be in Greenwich Mean Time (GMT).
 *	Otherwise, it will be in the local time zone.
 *
 * Results:
 *	Returns a static tm structure.
 *
 * Side effects:
 *	None.
 *
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

317
318
319
320
321
322
323
324
325

326
327

328
329
330

331
332
333
334
335
336
337
338
339
340
341
342
 * Side effects:
 *	Invokes gmtime or gmtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpGmtime( timePtr )
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch */

{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey );

#ifdef HAVE_GMTIME_R
    gmtime_r(timePtr, &( tsdPtr->gmtime_buf ));
#else
    Tcl_MutexLock( &tmMutex );
    memcpy( (VOID *) &( tsdPtr->gmtime_buf ),
	    (VOID *) gmtime( timePtr ),
	    sizeof( struct tm ) );
    Tcl_MutexUnlock( &tmMutex );
#endif    

    return &( tsdPtr->gmtime_buf );
}

/*
 * Forwarder for obsolete item in Stubs
 */

struct tm*
TclpGmtime_unix( timePtr )
    CONST time_t* timePtr;
{
    return TclpGmtime( timePtr );
}

/*
 *----------------------------------------------------------------------
 *
 * TclpLocaltime --
 *







|
|
|
<





|
>

|

|
|
<
|
|
|
>
|

>



>

|
|

|







317
318
319
320
321
322
323
324
325
326

327
328
329
330
331
332
333
334
335
336
337
338

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
 * Side effects:
 *	Invokes gmtime or gmtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpGmtime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds since the
				 * local system's epoch */

{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey);

#ifdef HAVE_GMTIME_R
    gmtime_r(timePtr, &(tsdPtr->gmtime_buf));
#else
    Tcl_MutexLock(&tmMutex);
    memcpy((VOID *) &(tsdPtr->gmtime_buf), (VOID *) gmtime(timePtr),

	    sizeof(struct tm));
    Tcl_MutexUnlock(&tmMutex);
#endif

    return &(tsdPtr->gmtime_buf);
}

/*
 * Forwarder for obsolete item in Stubs
 */

struct tm*
TclpGmtime_unix(timePtr)
    CONST time_t *timePtr;
{
    return TclpGmtime(timePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpLocaltime --
 *
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

366
367
368
369
370
371
372
373
374
375

376
377
378
379
380
381
382
383
384
385
386
387



















































































































388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410

411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450








 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpLocaltime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch */

{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey );

    SetTZIfNecessary();
#ifdef HAVE_LOCALTIME_R
    localtime_r( timePtr, &( tsdPtr->localtime_buf ) );
#else
    Tcl_MutexLock( &tmMutex );
    memcpy( (VOID *) &( tsdPtr -> localtime_buf ),
	    (VOID *) localtime( timePtr ),
	    sizeof( struct tm ) );
    Tcl_MutexUnlock( &tmMutex );
#endif    

    return &( tsdPtr->localtime_buf );
}
/*
 * Forwarder for obsolete item in Stubs
 */
struct tm*
TclpLocaltime_unix( timePtr )
    CONST time_t* timePtr;
{
    return TclpLocaltime( timePtr );
}




















































































































/*
 *----------------------------------------------------------------------
 *
 * SetTZIfNecessary --
 *
 *	Determines whether a call to 'tzset' is needed prior to the
 *	next call to 'localtime' or examination of the 'timezone' variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If 'tzset' has never been called in the current process, or if
 *	the value of the environment variable TZ has changed since the
 *	last call to 'tzset', then 'tzset' is called again.
 *
 *----------------------------------------------------------------------
 */

static void
SetTZIfNecessary() {

    CONST char* newTZ = getenv( "TZ" );

    Tcl_MutexLock(&tmMutex);
    if ( newTZ == NULL ) {
	newTZ = "";
    }
    if ( lastTZ == NULL || strcmp( lastTZ, newTZ ) ) {
        tzset();
	if ( lastTZ == NULL ) {
	    Tcl_CreateExitHandler( CleanupMemory, (ClientData) NULL );
	} else {
	    Tcl_Free( lastTZ );
	}
	lastTZ = Tcl_Alloc( strlen( newTZ ) + 1 );
	strcpy( lastTZ, newTZ );
    }
    Tcl_MutexUnlock(&tmMutex);

}

/*
 *----------------------------------------------------------------------
 *
 * CleanupMemory --
 *
 *	Releases the private copy of the TZ environment variable
 *	upon exit from Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees allocated memory.
 *
 *----------------------------------------------------------------------
 */

static void
CleanupMemory( ClientData ignored )
{
    Tcl_Free( lastTZ );
}















|
|
<





|
>


|

|
|
<
|
|
|
>
|





|
|

|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|





|
|
|





|
|
|
>

|


|
|
|
|

|

|
|


|
|
<





|
|











|

|

>
>
>
>
>
>
>
>
369
370
371
372
373
374
375
376
377

378
379
380
381
382
383
384
385
386
387
388
389
390

391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562

563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpLocaltime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds since the
				 * local system's epoch */

{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey);

    SetTZIfNecessary();
#ifdef HAVE_LOCALTIME_R
    localtime_r(timePtr, &(tsdPtr->localtime_buf));
#else
    Tcl_MutexLock(&tmMutex);
    memcpy((VOID *) &(tsdPtr->localtime_buf), (VOID *) localtime(timePtr),

	    sizeof(struct tm));
    Tcl_MutexUnlock(&tmMutex);
#endif

    return &(tsdPtr->localtime_buf);
}
/*
 * Forwarder for obsolete item in Stubs
 */
struct tm*
TclpLocaltime_unix(timePtr)
    CONST time_t *timePtr;
{
    return TclpLocaltime(timePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimeProc --
 *
 *	TIP #233 (Virtualized Time): Registers two handlers for the
 *	virtualization of Tcl's access to time information.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remembers the handlers, alters core behaviour.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimeProc(getProc, scaleProc, clientData)
    Tcl_GetTimeProc *getProc;
    Tcl_ScaleTimeProc *scaleProc;
    ClientData clientData;
{
    tclGetTimeProcPtr = getProc;
    tclScaleTimeProcPtr = scaleProc;
    tclTimeClientData = clientData;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_QueryTimeProc --
 *
 *	TIP #233 (Virtualized Time): Query which time handlers are registered.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_QueryTimeProc(getProc, scaleProc, clientData)
    Tcl_GetTimeProc **getProc;
    Tcl_ScaleTimeProc **scaleProc;
    ClientData *clientData;
{
    if (getProc) {
	*getProc = tclGetTimeProcPtr;
    }
    if (scaleProc) {
	*scaleProc = tclScaleTimeProcPtr;
    }
    if (clientData) {
	*clientData = tclTimeClientData;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NativeScaleTime --
 *
 *	TIP #233: Scale from virtual time to the real-time. For native scaling
 *	the relationship is 1:1 and nothing has to be done.
 *
 * Results:
 *	Scales the time in timePtr.
 *
 * Side effects:
 *	See above.
 *
 *----------------------------------------------------------------------
 */

static void
NativeScaleTime(timePtr, clientData)
    Tcl_Time *timePtr;
    ClientData clientData;
{
    /* Native scale is 1:1. Nothing is done */
}

/*
 *----------------------------------------------------------------------
 *
 * NativeGetTime --
 *
 *	TIP #233: Gets the current system time in seconds and microseconds
 *	since the beginning of the epoch: 00:00 UCT, January 1, 1970.
 *
 * Results:
 *	Returns the current time in timePtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
NativeGetTime(timePtr, clientData)
    Tcl_Time *timePtr;
    ClientData clientData;
{
    struct timeval tv;
    struct timezone tz;

    (void) gettimeofday(&tv, &tz);
    timePtr->sec = tv.tv_sec;
    timePtr->usec = tv.tv_usec;
}
/*
 *----------------------------------------------------------------------
 *
 * SetTZIfNecessary --
 *
 *	Determines whether a call to 'tzset' is needed prior to the next call
 *	to 'localtime' or examination of the 'timezone' variable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If 'tzset' has never been called in the current process, or if the
 *	value of the environment variable TZ has changed since the last call
 *	to 'tzset', then 'tzset' is called again.
 *
 *----------------------------------------------------------------------
 */

static void
SetTZIfNecessary()
{
    CONST char *newTZ = getenv("TZ");

    Tcl_MutexLock(&tmMutex);
    if (newTZ == NULL) {
	newTZ = "";
    }
    if (lastTZ == NULL || strcmp(lastTZ, newTZ)) {
	tzset();
	if (lastTZ == NULL) {
	    Tcl_CreateExitHandler(CleanupMemory, (ClientData) NULL);
	} else {
	    Tcl_Free(lastTZ);
	}
	lastTZ = Tcl_Alloc(strlen(newTZ) + 1);
	strcpy(lastTZ, newTZ);
    }
    Tcl_MutexUnlock(&tmMutex);
}


/*
 *----------------------------------------------------------------------
 *
 * CleanupMemory --
 *
 *	Releases the private copy of the TZ environment variable upon exit
 *	from Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees allocated memory.
 *
 *----------------------------------------------------------------------
 */

static void
CleanupMemory(ClientData ignored)
{
    Tcl_Free(lastTZ);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/tclXtNotify.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
/* 
 * tclXtNotify.c --
 *
 *	This file contains the notifier driver implementation for the
 *	Xt intrinsics.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclXtNotify.c,v 1.6 2004/04/06 22:25:57 dgp Exp $
 */

#include <X11/Intrinsic.h>
#include "tclInt.h"

/*
 * This structure is used to keep track of the notifier info for a 
 * a registered file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE, etc. */

    int readyMask;		/* Events that have been seen since the
				   last time FileHandlerEventProc was called
				   for this file. */
    XtInputId read;		/* Xt read callback handle. */
    XtInputId write;		/* Xt write callback handle. */
    XtInputId except;		/* Xt exception callback handle. */
    Tcl_FileProc *proc;		/* Procedure to call, in the style of
				 * Tcl_CreateFileHandler. */
    ClientData clientData;	/* Argument to pass to proc. */
    struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;

/*
 * The following structure is what is added to the Tcl event queue when
 * file handlers are ready to fire.
 */

typedef struct FileHandlerEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    int fd;			/* File descriptor that is ready.  Used
				 * to find the FileHandler structure for
				 * the file (can't point directly to the
				 * FileHandler structure because it could
				 * go away while the event is queued). */
} FileHandlerEvent;

/*
 * The following static structure contains the state information for the
 * Xt based implementation of the Tcl notifier.
 */

static struct NotifierState {
    XtAppContext appContext;		/* The context used by the Xt
                                         * notifier. Can be set with
                                         * TclSetAppContext. */
    int appContextCreated;		/* Was it created by us? */
    XtIntervalId currentTimeout;	/* Handle of current timer. */
    FileHandler *firstFileHandlerPtr;	/* Pointer to head of file handler
					 * list. */
} notifier;

/*
 * The following static indicates whether this module has been initialized.
 */

static int initialized = 0;
|


|
|



|
|

|






|
|




|
>
|
|
|










|
|



|
|
|
|
|
|
|



|
|



|
<
|
|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

61
62
63
64
65
66
67
68
69
70
71
72
/*
 * tclXtNotify.c --
 *
 *	This file contains the notifier driver implementation for the Xt
 *	intrinsics.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclXtNotify.c,v 1.6.2.1 2005/08/02 18:16:58 dgp Exp $
 */

#include <X11/Intrinsic.h>
#include "tclInt.h"

/*
 * This structure is used to keep track of the notifier info for a a
 * registered file.
 */

typedef struct FileHandler {
    int fd;
    int mask;			/* Mask of desired events: TCL_READABLE,
				 * etc. */
    int readyMask;		/* Events that have been seen since the last
				 * time FileHandlerEventProc was called for
				 * this file. */
    XtInputId read;		/* Xt read callback handle. */
    XtInputId write;		/* Xt write callback handle. */
    XtInputId except;		/* Xt exception callback handle. */
    Tcl_FileProc *proc;		/* Procedure to call, in the style of
				 * Tcl_CreateFileHandler. */
    ClientData clientData;	/* Argument to pass to proc. */
    struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;

/*
 * The following structure is what is added to the Tcl event queue when file
 * handlers are ready to fire.
 */

typedef struct FileHandlerEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    int fd;			/* File descriptor that is ready. Used to find
				 * the FileHandler structure for the file
				 * (can't point directly to the FileHandler
				 * structure because it could go away while
				 * the event is queued). */
} FileHandlerEvent;

/*
 * The following static structure contains the state information for the Xt
 * based implementation of the Tcl notifier.
 */

static struct NotifierState {
    XtAppContext appContext;	/* The context used by the Xt notifier. Can be

				 * set with TclSetAppContext. */
    int appContextCreated;	/* Was it created by us? */
    XtIntervalId currentTimeout;/* Handle of current timer. */
    FileHandler *firstFileHandlerPtr;
				/* Pointer to head of file handler list. */
} notifier;

/*
 * The following static indicates whether this module has been initialized.
 */

static int initialized = 0;
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
static void		FileProc _ANSI_ARGS_((caddr_t clientData,
			    int *source, XtInputId *id));
void			InitNotifier _ANSI_ARGS_((void));
static void		NotifierExitHandler _ANSI_ARGS_((
			    ClientData clientData));
static void		TimerProc _ANSI_ARGS_((caddr_t clientData,
			    XtIntervalId *id));
static void		CreateFileHandler _ANSI_ARGS_((int fd, int mask, 
				Tcl_FileProc * proc, ClientData clientData));
static void		DeleteFileHandler _ANSI_ARGS_((int fd));
static void		SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
static int		WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr));

/*
 * Functions defined in this file for use by users of the Xt Notifier:







|







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
static void		FileProc _ANSI_ARGS_((caddr_t clientData,
			    int *source, XtInputId *id));
void			InitNotifier _ANSI_ARGS_((void));
static void		NotifierExitHandler _ANSI_ARGS_((
			    ClientData clientData));
static void		TimerProc _ANSI_ARGS_((caddr_t clientData,
			    XtIntervalId *id));
static void		CreateFileHandler _ANSI_ARGS_((int fd, int mask,
				Tcl_FileProc * proc, ClientData clientData));
static void		DeleteFileHandler _ANSI_ARGS_((int fd));
static void		SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
static int		WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr));

/*
 * Functions defined in this file for use by users of the Xt Notifier:
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
 *
 *	Set the notifier application context.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the application context used by the notifier. Panics if
 *	the context is already set when called.
 *
 *----------------------------------------------------------------------
 */

XtAppContext
TclSetAppContext(appContext)
    XtAppContext	appContext;
{
    if (!initialized) {
        InitNotifier();
    }

    /*
     * If we already have a context we check whether we were asked to set a
     * new context. If so, we panic because we try to prevent switching
     * contexts by mistake. Otherwise, we return the one we have.
     */
    
    if (notifier.appContext != NULL) {
        if (appContext != NULL) {

	    /*
             * We already have a context. We do not allow switching contexts
             * after initialization, so we panic.
             */
        
            Tcl_Panic("TclSetAppContext:  multiple application contexts");

        }
    } else {

        /*
         * If we get here we have not yet gotten a context, so either create
         * one or use the one supplied by our caller.
         */

        if (appContext == NULL) {

	    /*
             * We must create a new context and tell our caller what it is, so
             * she can use it too.
             */
    
            notifier.appContext = XtCreateApplicationContext();
            notifier.appContextCreated = 1;
        } else {

	    /*
             * Otherwise we remember the context that our caller gave us
             * and use it.
             */
    
            notifier.appContextCreated = 0;
            notifier.appContext = appContext;
        }
    }
    
    return notifier.appContext;
}

/*
 *----------------------------------------------------------------------
 *
 * InitNotifier --







|
|






|


|







|

|
<

|
|
|
|
|
|
<

<
|
|
|
|

|
<

|
|
|
|
|
|
|
<

|
|
|
|
|
|
|

|







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

132
133
134
135
136
137
138

139

140
141
142
143
144
145

146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
 *
 *	Set the notifier application context.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the application context used by the notifier. Panics if the
 *	context is already set when called.
 *
 *----------------------------------------------------------------------
 */

XtAppContext
TclSetAppContext(appContext)
    XtAppContext appContext;
{
    if (!initialized) {
	InitNotifier();
    }

    /*
     * If we already have a context we check whether we were asked to set a
     * new context. If so, we panic because we try to prevent switching
     * contexts by mistake. Otherwise, we return the one we have.
     */

    if (notifier.appContext != NULL) {
	if (appContext != NULL) {

	    /*
	     * We already have a context. We do not allow switching contexts
	     * after initialization, so we panic.
	     */

	    Tcl_Panic("TclSetAppContext:  multiple application contexts");
	}

    } else {

	/*
	 * If we get here we have not yet gotten a context, so either create
	 * one or use the one supplied by our caller.
	 */

	if (appContext == NULL) {

	    /*
	     * We must create a new context and tell our caller what it is, so
	     * she can use it too.
	     */

	    notifier.appContext = XtCreateApplicationContext();
	    notifier.appContextCreated = 1;
	} else {

	    /*
	     * Otherwise we remember the context that our caller gave us and
	     * use it.
	     */

	    notifier.appContextCreated = 0;
	    notifier.appContext = appContext;
	}
    }

    return notifier.appContext;
}

/*
 *----------------------------------------------------------------------
 *
 * InitNotifier --
185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
 *----------------------------------------------------------------------
 */

void
InitNotifier()
{
    Tcl_NotifierProcs notifier;

    /*
     * Only reinitialize if we are not in exit handling. The notifier
     * can get reinitialized after its own exit handler has run, because
     * of exit handlers for the I/O and timer sub-systems (order dependency).
     */

    if (TclInExit()) {
        return;
    }

    notifier.createFileHandlerProc = CreateFileHandler;
    notifier.deleteFileHandlerProc = DeleteFileHandler;
    notifier.setTimerProc = SetTimer;
    notifier.waitForEventProc = WaitForEvent;
    Tcl_SetNotifier(&notifier);

    /*
     * DO NOT create the application context yet; doing so would prevent
     * external applications from setting it for us to their own ones.
     */
    
    initialized = 1;
    memset(&notifier, 0, sizeof(notifier));
    Tcl_CreateExitHandler(NotifierExitHandler, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierExitHandler --
 *
 *	This function is called to cleanup the notifier state before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys the notifier window.
 *
 *----------------------------------------------------------------------
 */

static void
NotifierExitHandler(
    ClientData clientData)	/* Not used. */
{
    if (notifier.currentTimeout != 0) {
        XtRemoveTimeOut(notifier.currentTimeout);
    }
    for (; notifier.firstFileHandlerPtr != NULL; ) {
        Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
    }
    if (notifier.appContextCreated) {
        XtDestroyApplicationContext(notifier.appContext);
        notifier.appContextCreated = 0;
        notifier.appContext = NULL;
    }
    initialized = 0;
}

/*
 *----------------------------------------------------------------------
 *







>

|
|
|



|












|










|
|















|


|


|
|
|







180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
 *----------------------------------------------------------------------
 */

void
InitNotifier()
{
    Tcl_NotifierProcs notifier;

    /*
     * Only reinitialize if we are not in exit handling. The notifier can get
     * reinitialized after its own exit handler has run, because of exit
     * handlers for the I/O and timer sub-systems (order dependency).
     */

    if (TclInExit()) {
	return;
    }

    notifier.createFileHandlerProc = CreateFileHandler;
    notifier.deleteFileHandlerProc = DeleteFileHandler;
    notifier.setTimerProc = SetTimer;
    notifier.waitForEventProc = WaitForEvent;
    Tcl_SetNotifier(&notifier);

    /*
     * DO NOT create the application context yet; doing so would prevent
     * external applications from setting it for us to their own ones.
     */

    initialized = 1;
    memset(&notifier, 0, sizeof(notifier));
    Tcl_CreateExitHandler(NotifierExitHandler, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierExitHandler --
 *
 *	This function is called to cleanup the notifier state before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys the notifier window.
 *
 *----------------------------------------------------------------------
 */

static void
NotifierExitHandler(
    ClientData clientData)	/* Not used. */
{
    if (notifier.currentTimeout != 0) {
	XtRemoveTimeOut(notifier.currentTimeout);
    }
    for (; notifier.firstFileHandlerPtr != NULL; ) {
	Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
    }
    if (notifier.appContextCreated) {
	XtDestroyApplicationContext(notifier.appContext);
	notifier.appContextCreated = 0;
	notifier.appContext = NULL;
    }
    initialized = 0;
}

/*
 *----------------------------------------------------------------------
 *
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

    TclSetAppContext(NULL);
    if (notifier.currentTimeout != 0) {
	XtRemoveTimeOut(notifier.currentTimeout);
    }
    if (timePtr) {
	timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
	notifier.currentTimeout =
            XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout,
                    TimerProc, NULL);
    } else {
	notifier.currentTimeout = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TimerProc --
 *
 *	This procedure is the XtTimerCallbackProc used to handle
 *	timeouts.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *      Processes all queued events.
 *
 *----------------------------------------------------------------------
 */

static void
TimerProc(data, id)
    caddr_t data;		/* Not used. */







|
<
|










|
<





|







274
275
276
277
278
279
280
281

282
283
284
285
286
287
288
289
290
291
292
293

294
295
296
297
298
299
300
301
302
303
304
305
306

    TclSetAppContext(NULL);
    if (notifier.currentTimeout != 0) {
	XtRemoveTimeOut(notifier.currentTimeout);
    }
    if (timePtr) {
	timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
	notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext,

		(unsigned long) timeout, TimerProc, NULL);
    } else {
	notifier.currentTimeout = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TimerProc --
 *
 *	This procedure is the XtTimerCallbackProc used to handle timeouts.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Processes all queued events.
 *
 *----------------------------------------------------------------------
 */

static void
TimerProc(data, id)
    caddr_t data;		/* Not used. */
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
 *
 *	This procedure registers a file handler with the Xt notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new file handler structure and registers one or more
 *	input procedures with Xt.
 *
 *----------------------------------------------------------------------
 */

static void
CreateFileHandler(fd, mask, proc, clientData)
    int fd;			/* Handle of stream to watch. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION:
				 * indicates conditions under which
				 * proc should be called. */
    Tcl_FileProc *proc;		/* Procedure to call for each
				 * selected event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    FileHandler *filePtr;

    if (!initialized) {
	InitNotifier();
    }







|
|








|
|
|
|
|







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
 *
 *	This procedure registers a file handler with the Xt notifier.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new file handler structure and registers one or more input
 *	procedures with Xt.
 *
 *----------------------------------------------------------------------
 */

static void
CreateFileHandler(fd, mask, proc, clientData)
    int fd;			/* Handle of stream to watch. */
    int mask;			/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, and TCL_EXCEPTION: indicates
				 * conditions under which proc should be
				 * called. */
    Tcl_FileProc *proc;		/* Procedure to call for each selected
				 * event. */
    ClientData clientData;	/* Arbitrary data to pass to proc. */
{
    FileHandler *filePtr;

    if (!initialized) {
	InitNotifier();
    }
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458

    /*
     * Register the file with the Xt notifier, if it hasn't been done yet.
     */

    if (mask & TCL_READABLE) {
	if (!(filePtr->mask & TCL_READABLE)) {
	    filePtr->read =
                XtAppAddInput(notifier.appContext, fd, XtInputReadMask,
                        FileProc, filePtr);
	}
    } else {
	if (filePtr->mask & TCL_READABLE) {
	    XtRemoveInput(filePtr->read);
	}
    }
    if (mask & TCL_WRITABLE) {
	if (!(filePtr->mask & TCL_WRITABLE)) {
	    filePtr->write =
                XtAppAddInput(notifier.appContext, fd, XtInputWriteMask,
                        FileProc, filePtr);
	}
    } else {
	if (filePtr->mask & TCL_WRITABLE) {
	    XtRemoveInput(filePtr->write);
	}
    }
    if (mask & TCL_EXCEPTION) {
	if (!(filePtr->mask & TCL_EXCEPTION)) {
	    filePtr->except =
                XtAppAddInput(notifier.appContext, fd, XtInputExceptMask,
                        FileProc, filePtr);
	}
    } else {
	if (filePtr->mask & TCL_EXCEPTION) {
	    XtRemoveInput(filePtr->except);
	}
    }
    filePtr->mask = mask;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteFileHandler --
 *
 *	Cancel a previously-arranged callback arrangement for
 *	a file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered on file, remove it.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteFileHandler(fd)
    int fd;			/* Stream id for which to remove
				 * callback procedure. */
{
    FileHandler *filePtr, *prevPtr;

    if (!initialized) {
	InitNotifier();
    }

    TclSetAppContext(NULL);

    /*
     * Find the entry for the given file (and return if there
     * isn't one).
     */

    for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ;
	    prevPtr = filePtr, filePtr = filePtr->nextPtr) {
	if (filePtr == NULL) {
	    return;
	}







<
|
|








|
<
|








|
<
|














|
<












|
|










|
<







372
373
374
375
376
377
378

379
380
381
382
383
384
385
386
387
388
389

390
391
392
393
394
395
396
397
398
399

400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

441
442
443
444
445
446
447

    /*
     * Register the file with the Xt notifier, if it hasn't been done yet.
     */

    if (mask & TCL_READABLE) {
	if (!(filePtr->mask & TCL_READABLE)) {

	    filePtr->read = XtAppAddInput(notifier.appContext, fd,
		    XtInputReadMask, FileProc, filePtr);
	}
    } else {
	if (filePtr->mask & TCL_READABLE) {
	    XtRemoveInput(filePtr->read);
	}
    }
    if (mask & TCL_WRITABLE) {
	if (!(filePtr->mask & TCL_WRITABLE)) {
	    filePtr->write = XtAppAddInput(notifier.appContext, fd,

		    XtInputWriteMask, FileProc, filePtr);
	}
    } else {
	if (filePtr->mask & TCL_WRITABLE) {
	    XtRemoveInput(filePtr->write);
	}
    }
    if (mask & TCL_EXCEPTION) {
	if (!(filePtr->mask & TCL_EXCEPTION)) {
	    filePtr->except = XtAppAddInput(notifier.appContext, fd,

		    XtInputExceptMask, FileProc, filePtr);
	}
    } else {
	if (filePtr->mask & TCL_EXCEPTION) {
	    XtRemoveInput(filePtr->except);
	}
    }
    filePtr->mask = mask;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteFileHandler --
 *
 *	Cancel a previously-arranged callback arrangement for a file.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a callback was previously registered on file, remove it.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteFileHandler(fd)
    int fd;			/* Stream id for which to remove callback
				 * procedure. */
{
    FileHandler *filePtr, *prevPtr;

    if (!initialized) {
	InitNotifier();
    }

    TclSetAppContext(NULL);

    /*
     * Find the entry for the given file (and return if there isn't one).

     */

    for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ;
	    prevPtr = filePtr, filePtr = filePtr->nextPtr) {
	if (filePtr == NULL) {
	    return;
	}
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
 *	These procedures are called by Xt when a file becomes readable,
 *	writable, or has an exception.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Makes an entry on the Tcl event queue if the event is
 *	interesting.
 *
 *----------------------------------------------------------------------
 */

static void
FileProc(clientData, fd, id)
    caddr_t clientData;







|
<







479
480
481
482
483
484
485
486

487
488
489
490
491
492
493
 *	These procedures are called by Xt when a file becomes readable,
 *	writable, or has an exception.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Makes an entry on the Tcl event queue if the event is interesting.

 *
 *----------------------------------------------------------------------
 */

static void
FileProc(clientData, fd, id)
    caddr_t clientData;
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
    /*
     * Ignore unwanted or duplicate events.
     */

    if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) {
	return;
    }
    
    /*
     * This is an interesting event, so put it onto the event queue.
     */

    filePtr->readyMask |= mask;
    fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
    fileEvPtr->header.proc = FileHandlerEventProc;







|







513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
    /*
     * Ignore unwanted or duplicate events.
     */

    if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) {
	return;
    }

    /*
     * This is an interesting event, so put it onto the event queue.
     */

    filePtr->readyMask |= mask;
    fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
    fileEvPtr->header.proc = FileHandlerEventProc;
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608

609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664

665
666
667
668








}

/*
 *----------------------------------------------------------------------
 *
 * FileHandlerEventProc --
 *
 *	This procedure is called by Tcl_ServiceEvent when a file event
 *	reaches the front of the event queue.  This procedure is
 *	responsible for actually handling the event by invoking the
 *	callback for the file handler.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the file handler's callback procedure does.
 *
 *----------------------------------------------------------------------
 */

static int
FileHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    int mask;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event.  We do this rather than keeping a pointer to the file
     * handler directly in the event, so that the handler can be deleted
     * while the event is queued without leaving a dangling pointer.
     */

    for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
	    filePtr = filePtr->nextPtr) {
	if (filePtr->fd != fileEvPtr->fd) {
	    continue;
	}

	/*
	 * The code is tricky for two reasons:
	 * 1. The file handler's desired events could have changed
	 *    since the time when the event was queued, so AND the
	 *    ready mask with the desired mask.
	 * 2. The file could have been closed and re-opened since
	 *    the time when the event was queued.  This is why the
	 *    ready mask is stored in the file handler rather than
	 *    the queued event:  it will be zeroed when a new
	 *    file handler is created for the newly opened file.

	 */

	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    (*filePtr->proc)(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new
 *	events on the message queue.  If the block time is 0, then
 *	Tcl_WaitForEvent just polls without blocking.
 *
 * Results:
 *	Returns 1 if an event was found, else 0.  This ensures that
 *	Tcl_DoOneEvent will return 1, even if the event is handled
 *	by non-Tcl code.
 *
 * Side effects:
 *	Queues file events that are detected by the select.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForEvent(
    Tcl_Time *timePtr)		/* Maximum block time, or NULL. */
{
    int timeout;

    if (!initialized) {
	InitNotifier();
    }

    TclSetAppContext(NULL);

    if (timePtr) {
        timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
        if (timeout == 0) {
            if (XtAppPending(notifier.appContext)) {
                goto process;
            } else {
                return 0;
            }
        } else {
            Tcl_SetTimer(timePtr);
        }
    }

process:
    XtAppProcessEvent(notifier.appContext, XtIMAll);
    return 1;
}















|
|
|
|


|
|
|
|










|
|











|
|
|










|
|
|
|
|
|
<
|
>

















|
|
|


|
|
|




















|
|
|
|
|
|
|
|
|
|

>
|



>
>
>
>
>
>
>
>
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
}

/*
 *----------------------------------------------------------------------
 *
 * FileHandlerEventProc --
 *
 *	This procedure is called by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This procedure is responsible for
 *	actually handling the event by invoking the callback for the file
 *	handler.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the file handler's callback procedure does.
 *
 *----------------------------------------------------------------------
 */

static int
FileHandlerEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    int mask;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.
     */

    for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
	    filePtr = filePtr->nextPtr) {
	if (filePtr->fd != fileEvPtr->fd) {
	    continue;
	}

	/*
	 * The code is tricky for two reasons:
	 * 1. The file handler's desired events could have changed since the
	 *    time when the event was queued, so AND the ready mask with the
	 *    desired mask.
	 * 2. The file could have been closed and re-opened since the time
	 *    when the event was queued. This is why the ready mask is stored
	 *    in the file handler rather than the queued event: it will be

	 *    zeroed when a new file handler is created for the newly opened
	 *    file.
	 */

	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    (*filePtr->proc)(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just
 *	polls without blocking.
 *
 * Results:
 *	Returns 1 if an event was found, else 0. This ensures that
 *	Tcl_DoOneEvent will return 1, even if the event is handled by non-Tcl
 *	code.
 *
 * Side effects:
 *	Queues file events that are detected by the select.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForEvent(
    Tcl_Time *timePtr)		/* Maximum block time, or NULL. */
{
    int timeout;

    if (!initialized) {
	InitNotifier();
    }

    TclSetAppContext(NULL);

    if (timePtr) {
	timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
	if (timeout == 0) {
	    if (XtAppPending(notifier.appContext)) {
		goto process;
	    } else {
		return 0;
	    }
	} else {
	    Tcl_SetTimer(timePtr);
	}
    }

  process:
    XtAppProcessEvent(notifier.appContext, XtIMAll);
    return 1;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/.cvsignore.

9
10
11
12
13
14
15


*.i
*.asm
Makefile
tcl.hpj
tclConfig.sh
nmakehlp.exe
.#*









>
>
9
10
11
12
13
14
15
16
17
*.i
*.asm
Makefile
tcl.hpj
tclConfig.sh
nmakehlp.exe
.#*
tcl.sln
tcl.suo

Changes to win/Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.84 2004/11/29 22:41:58 andreas_kupries Exp $

VERSION = @TCL_VERSION@

#----------------------------------------------------------------
# Things you can change to personalize the Makefile for your own
# site (you can make these changes in either Makefile.in or
# Makefile, but changes to Makefile will get lost if you re-run







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.84.2.15 2005/09/23 16:47:35 dgp Exp $

VERSION = @TCL_VERSION@

#----------------------------------------------------------------
# Things you can change to personalize the Makefile for your own
# site (you can make these changes in either Makefile.in or
# Makefile, but changes to Makefile will get lost if you re-run
98
99
100
101
102
103
104

105
106
107
108
109
110
111

112
113
114
115
116
117
118
119
120

# Special compiler flags to use when building man2tcl on Windows.
MAN2TCLFLAGS =		@MAN2TCLFLAGS@

SRC_DIR			= @srcdir@
ROOT_DIR		= @srcdir@/..
GENERIC_DIR		= @srcdir@/../generic

WIN_DIR			= @srcdir@
COMPAT_DIR		= @srcdir@/../compat

# Converts a POSIX path to a Windows native path.
CYGPATH			= @CYGPATH@

GENERIC_DIR_NATIVE	= $(shell $(CYGPATH) '$(GENERIC_DIR)')

WIN_DIR_NATIVE		= $(shell $(CYGPATH) '$(WIN_DIR)')
ROOT_DIR_NATIVE		= $(shell $(CYGPATH) '$(ROOT_DIR)')

LIBRARY_DIR   = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' )

DLLSUFFIX		= @DLLSUFFIX@
LIBSUFFIX		= @LIBSUFFIX@
EXESUFFIX		= @EXESUFFIX@








>







>

|







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

# Special compiler flags to use when building man2tcl on Windows.
MAN2TCLFLAGS =		@MAN2TCLFLAGS@

SRC_DIR			= @srcdir@
ROOT_DIR		= @srcdir@/..
GENERIC_DIR		= @srcdir@/../generic
TOMMATH_DIR		= @srcdir@/../libtommath
WIN_DIR			= @srcdir@
COMPAT_DIR		= @srcdir@/../compat

# Converts a POSIX path to a Windows native path.
CYGPATH			= @CYGPATH@

GENERIC_DIR_NATIVE	= $(shell $(CYGPATH) '$(GENERIC_DIR)')
TOMMATH_DIR_NATIVE	= $(shell $(CYGPATH) '$(TOMMATH_DIR)')
WIN_DIR_NATIVE		= $(shell $(CYGPATH) '$(WIN_DIR)')
ROOT_DIR_NATIVE		= $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's/\\*$$//' )

LIBRARY_DIR   = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' )

DLLSUFFIX		= @DLLSUFFIX@
LIBSUFFIX		= @LIBSUFFIX@
EXESUFFIX		= @EXESUFFIX@

152
153
154
155
156
157
158
159
160
161
162
163
164
165
166

@SET_MAKE@

# Setting the VPATH variable to a list of paths will cause the 
# makefile to look into these paths when resolving .c to .obj
# dependencies.

VPATH = $(GENERIC_DIR):$(WIN_DIR):$(COMPAT_DIR)

AR		= @AR@
RANLIB		= @RANLIB@
CC		= @CC@
RC		= @RC@
RES		= @RES@
AC_FLAGS	= @EXTRA_CFLAGS@ @DEFS@







|







154
155
156
157
158
159
160
161
162
163
164
165
166
167
168

@SET_MAKE@

# Setting the VPATH variable to a list of paths will cause the 
# makefile to look into these paths when resolving .c to .obj
# dependencies.

VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR)

AR		= @AR@
RANLIB		= @RANLIB@
CC		= @CC@
RC		= @RC@
RES		= @RES@
AC_FLAGS	= @EXTRA_CFLAGS@ @DEFS@
182
183
184
185
186
187
188

189
190
191
192
193
194
195

196
197
198
199
200
201
202
203
RMDIR		= rm -rf
MKDIR		= mkdir -p
SHELL		= @SHELL@
RM		= rm -f
COPY		= cp

CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \

-I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
${COMPILE_DEBUG_FLAGS}

CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@

STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \

-I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
${COMPILE_DEBUG_FLAGS}

TCLTEST_OBJS = \
	tclTest.$(OBJEXT) \
	tclTestObj.$(OBJEXT) \
	tclTestProcBodyObj.$(OBJEXT) \
	tclThreadTest.$(OBJEXT) \







>
|






>
|







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
RMDIR		= rm -rf
MKDIR		= mkdir -p
SHELL		= @SHELL@
RM		= rm -f
COPY		= cp

CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \
-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
${COMPILE_DEBUG_FLAGS}

CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@

STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
${COMPILE_DEBUG_FLAGS}

TCLTEST_OBJS = \
	tclTest.$(OBJEXT) \
	tclTestObj.$(OBJEXT) \
	tclTestProcBodyObj.$(OBJEXT) \
	tclThreadTest.$(OBJEXT) \
234
235
236
237
238
239
240

241
242
243
244
245
246
247
	tclHash.$(OBJEXT) \
	tclHistory.$(OBJEXT) \
	tclIndexObj.$(OBJEXT) \
	tclInterp.$(OBJEXT) \
	tclIO.$(OBJEXT) \
	tclIOCmd.$(OBJEXT) \
	tclIOGT.$(OBJEXT) \

	tclIOSock.$(OBJEXT) \
	tclIOUtil.$(OBJEXT) \
	tclLink.$(OBJEXT) \
	tclLiteral.$(OBJEXT) \
	tclListObj.$(OBJEXT) \
	tclLoad.$(OBJEXT) \
	tclMain.$(OBJEXT) \







>







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
	tclHash.$(OBJEXT) \
	tclHistory.$(OBJEXT) \
	tclIndexObj.$(OBJEXT) \
	tclInterp.$(OBJEXT) \
	tclIO.$(OBJEXT) \
	tclIOCmd.$(OBJEXT) \
	tclIOGT.$(OBJEXT) \
	tclIORChan.$(OBJEXT) \
	tclIOSock.$(OBJEXT) \
	tclIOUtil.$(OBJEXT) \
	tclLink.$(OBJEXT) \
	tclLiteral.$(OBJEXT) \
	tclListObj.$(OBJEXT) \
	tclLoad.$(OBJEXT) \
	tclMain.$(OBJEXT) \
259
260
261
262
263
264
265

266
267
268
269
270
271
272

273
274
275
276
































































277
278
279
280
281
282
283
	tclPreserve.$(OBJEXT) \
	tclProc.$(OBJEXT) \
	tclRegexp.$(OBJEXT) \
	tclResolve.$(OBJEXT) \
	tclResult.$(OBJEXT) \
	tclScan.$(OBJEXT) \
	tclStringObj.$(OBJEXT) \

	tclStubInit.$(OBJEXT) \
	tclStubLib.$(OBJEXT) \
	tclThread.$(OBJEXT) \
	tclThreadAlloc.$(OBJEXT) \
	tclThreadJoin.$(OBJEXT) \
	tclThreadStorage.$(OBJEXT) \
	tclTimer.$(OBJEXT) \

	tclTrace.$(OBJEXT) \
	tclUtf.$(OBJEXT) \
	tclUtil.$(OBJEXT) \
	tclVar.$(OBJEXT)

































































WIN_OBJS = \
	tclWin32Dll.$(OBJEXT) \
	tclWinChan.$(OBJEXT) \
	tclWinConsole.$(OBJEXT) \
	tclWinSerial.$(OBJEXT) \
	tclWinError.$(OBJEXT) \







>







>




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
	tclPreserve.$(OBJEXT) \
	tclProc.$(OBJEXT) \
	tclRegexp.$(OBJEXT) \
	tclResolve.$(OBJEXT) \
	tclResult.$(OBJEXT) \
	tclScan.$(OBJEXT) \
	tclStringObj.$(OBJEXT) \
	tclStrToD.$(OBJEXT) \
	tclStubInit.$(OBJEXT) \
	tclStubLib.$(OBJEXT) \
	tclThread.$(OBJEXT) \
	tclThreadAlloc.$(OBJEXT) \
	tclThreadJoin.$(OBJEXT) \
	tclThreadStorage.$(OBJEXT) \
	tclTimer.$(OBJEXT) \
	tclTomMathInterface.$(OBJEXT) \
	tclTrace.$(OBJEXT) \
	tclUtf.$(OBJEXT) \
	tclUtil.$(OBJEXT) \
	tclVar.$(OBJEXT)

TOMMATH_OBJS = \
	bncore.${OBJEXT} \
	bn_reverse.${OBJEXT} \
	bn_fast_s_mp_mul_digs.${OBJEXT} \
	bn_fast_s_mp_sqr.${OBJEXT} \
	bn_mp_add.${OBJEXT} \
	bn_mp_add_d.${OBJEXT} \
	bn_mp_and.${OBJEXT} \
	bn_mp_clamp.${OBJEXT} \
	bn_mp_clear.${OBJEXT} \
	bn_mp_clear_multi.${OBJEXT} \
	bn_mp_cmp.${OBJEXT} \
	bn_mp_cmp_d.${OBJEXT} \
	bn_mp_cmp_mag.${OBJEXT} \
	bn_mp_copy.${OBJEXT} \
	bn_mp_count_bits.${OBJEXT} \
	bn_mp_div.${OBJEXT} \
	bn_mp_div_d.${OBJEXT} \
	bn_mp_div_2.${OBJEXT} \
	bn_mp_div_2d.${OBJEXT} \
	bn_mp_div_3.${OBJEXT} \
	bn_mp_exch.${OBJEXT} \
	bn_mp_expt_d.${OBJEXT} \
	bn_mp_grow.${OBJEXT} \
	bn_mp_init.${OBJEXT} \
	bn_mp_init_copy.${OBJEXT} \
	bn_mp_init_multi.${OBJEXT} \
	bn_mp_init_set.${OBJEXT} \
	bn_mp_init_size.${OBJEXT} \
	bn_mp_karatsuba_mul.${OBJEXT} \
	bn_mp_karatsuba_sqr.$(OBJEXT) \
	bn_mp_lshd.${OBJEXT} \
	bn_mp_mod.${OBJEXT} \
	bn_mp_mod_2d.${OBJEXT} \
	bn_mp_mul.${OBJEXT} \
	bn_mp_mul_2.${OBJEXT} \
	bn_mp_mul_2d.${OBJEXT} \
	bn_mp_mul_d.${OBJEXT} \
	bn_mp_neg.${OBJEXT} \
	bn_mp_or.${OBJEXT} \
	bn_mp_radix_size.${OBJEXT} \
	bn_mp_radix_smap.${OBJEXT} \
	bn_mp_read_radix.${OBJEXT} \
	bn_mp_rshd.${OBJEXT} \
	bn_mp_set.${OBJEXT} \
	bn_mp_shrink.${OBJEXT} \
	bn_mp_sqr.${OBJEXT} \
	bn_mp_sqrt.${OBJEXT} \
	bn_mp_sub.${OBJEXT} \
	bn_mp_sub_d.${OBJEXT} \
	bn_mp_to_unsigned_bin.${OBJEXT} \
	bn_mp_to_unsigned_bin_n.${OBJEXT} \
	bn_mp_toom_mul.${OBJEXT} \
	bn_mp_toom_sqr.${OBJEXT} \
	bn_mp_toradix_n.${OBJEXT} \
	bn_mp_unsigned_bin_size.${OBJEXT} \
	bn_mp_xor.${OBJEXT} \
	bn_mp_zero.${OBJEXT} \
	bn_s_mp_add.${OBJEXT} \
	bn_s_mp_mul_digs.${OBJEXT} \
	bn_s_mp_sqr.${OBJEXT} \
	bn_s_mp_sub.${OBJEXT}


WIN_OBJS = \
	tclWin32Dll.$(OBJEXT) \
	tclWinChan.$(OBJEXT) \
	tclWinConsole.$(OBJEXT) \
	tclWinSerial.$(OBJEXT) \
	tclWinError.$(OBJEXT) \
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314

REG_OBJS = tclWinReg.$(OBJEXT)

STUB_OBJS = tclStubLib.$(OBJEXT)

TCLSH_OBJS = tclAppInit.$(OBJEXT)

TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} ${COMPAT_OBJS}

TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]

all: binaries libraries doc

tcltest: $(TCLTEST)








|







371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

REG_OBJS = tclWinReg.$(OBJEXT)

STUB_OBJS = tclStubLib.$(OBJEXT)

TCLSH_OBJS = tclAppInit.$(OBJEXT)

TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${COMPAT_OBJS}

TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]

all: binaries libraries doc

tcltest: $(TCLTEST)

464
465
466
467
468
469
470

471









472
473
474
475
476
477
478
# only run by hand as yacc is not available in all environments.
# The name of the .c file is different than the name of the .y file
# so that make doesn't try to automatically regenerate the .c file.

gendate:
	bison --output-file=$(GENERIC_DIR)/tclDate.c \
	--name-prefix=TclDate \

	$(GENERIC_DIR)/tclGetDate.y










install: all install-binaries install-libraries install-doc

install-binaries: binaries
	@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \
	    do \
	    if [ ! -d $$i ] ; then \







>

>
>
>
>
>
>
>
>
>







535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
# only run by hand as yacc is not available in all environments.
# The name of the .c file is different than the name of the .y file
# so that make doesn't try to automatically regenerate the .c file.

gendate:
	bison --output-file=$(GENERIC_DIR)/tclDate.c \
	--name-prefix=TclDate \
	--no-lines \
	$(GENERIC_DIR)/tclGetDate.y

# The following target generates the file generic/tommath.h.
# It needs to be run (and the results checked) after updating
# to a new release of libtommath.

gentommath_h:
	$(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \
		"$(TOMMATH_DIR_NATIVE)\tommath.h" \
		> "$(GENERIC_DIR_NATIVE)\tommath.h"

install: all install-binaries install-libraries install-doc

install-binaries: binaries
	@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \
	    do \
	    if [ ! -d $$i ] ; then \
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
	    $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
	    done;
	@echo "Installing library http1.0 directory";
	@for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
	    done;
	@echo "Installing package http 2.5.0 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.0.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.4.1 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm;
	@echo "Installing package tcltest 2.2.7 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.7.tm;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

install-tzdata:
	@echo "Installing time zone data"







|
|







|
|







636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
	    $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
	    done;
	@echo "Installing library http1.0 directory";
	@for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
	    done;
	@echo "Installing package http 2.5.1 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.4.1 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm;
	@echo "Installing package tcltest 2.2.8 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

install-tzdata:
	@echo "Installing time zone data"
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
clean: cleanhelp
	$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
	$(RM) $(TCLSH) $(TCLTEST) $(CAT32)
	$(RM) *.pch *.ilk *.pdb

distclean: clean
	$(RM) Makefile config.status config.cache config.log tclConfig.sh \
		tcl.hpj

#
# Regenerate the stubs files.
#

$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
		$(GENERIC_DIR)/tclInt.decls







|







727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
clean: cleanhelp
	$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
	$(RM) $(TCLSH) $(TCLTEST) $(CAT32)
	$(RM) *.pch *.ilk *.pdb

distclean: clean
	$(RM) Makefile config.status config.cache config.log tclConfig.sh \
		tcl.hpj config.status.lineno

#
# Regenerate the stubs files.
#

$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
		$(GENERIC_DIR)/tclInt.decls

Changes to win/README.

1
2
3
4
5
6
7
8
9
10
Tcl 8.5 for Windows

RCS: @(#) $Id: README,v 1.32 2004/07/01 10:08:11 dkf Exp $

1. Introduction
---------------

This is the directory where you configure and compile the Windows
version of Tcl.  This directory also contains source files for Tcl
that are specific to Microsoft Windows.


|







1
2
3
4
5
6
7
8
9
10
Tcl 8.5 for Windows

RCS: @(#) $Id: README,v 1.32.2.1 2005/08/02 18:16:58 dgp Exp $

1. Introduction
---------------

This is the directory where you configure and compile the Windows
version of Tcl.  This directory also contains source files for Tcl
that are specific to Microsoft Windows.
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

	Visual C++ 5 or newer

	or

	Msys + Mingw

	http://prdownloads.sourceforge.net/tcl/msys_mingw6.zip

	This Msys + Mingw download is the minimal environment
	needed to build Tcl/Tk under Windows. It includes a
	shell environment and gcc. The release is designed to
	make it as easy a possible to build Tcl/Tk. To install,
	you just download the zip file and extract the files
	into a directory. The README.TXT file describes how
	to launch the msys shell, you then run the configure
	script in the tcl/win directory.

	or

	Cygwin 1.1 or newer (See http://sources.redhat.com/cygwin)

	Mingw 2.0 (http://prdownloads.sourceforge.net/mingw/MinGW-2.0.0-3.exe)

	Extract the contents of the archive file into /usr/local/mingw
	and place /usr/local/mingw/bin at the front of your PATH env var
	before running the configure script in the tcl/win directory.


In practice, this release is built with Visual C++ 6.0 and the TEA
Makefile.

If you are building with Visual C++, in the "win" subdirectory of the
source release, you will find "makefile.vc".  This is the makefile for
the Visual C++ compiler and uses the stock NMAKE tool.  Detailed







|









<
<
<
<
<
<
<
<
<
<
<







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42











43
44
45
46
47
48
49

	Visual C++ 5 or newer

	or

	Msys + Mingw

	http://prdownloads.sourceforge.net/tcl/msys_mingw8.zip

	This Msys + Mingw download is the minimal environment
	needed to build Tcl/Tk under Windows. It includes a
	shell environment and gcc. The release is designed to
	make it as easy a possible to build Tcl/Tk. To install,
	you just download the zip file and extract the files
	into a directory. The README.TXT file describes how
	to launch the msys shell, you then run the configure
	script in the tcl/win directory.












In practice, this release is built with Visual C++ 6.0 and the TEA
Makefile.

If you are building with Visual C++, in the "win" subdirectory of the
source release, you will find "makefile.vc".  This is the makefile for
the Visual C++ compiler and uses the stock NMAKE tool.  Detailed

Changes to win/README.binary.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Tcl/Tk 8.5 for Windows, Binary Distribution

RCS: @(#) $Id: README.binary,v 1.38 2004/07/01 10:08:11 dkf Exp $ 

1. Introduction
--------------- 

This directory contains the binary distribution of Tcl/Tk 8.5a2 for
Windows.  It was compiled with Microsoft Visual C++ 6.0 using Win32
API, so that it will run under Windows 98, NT, 2000 and XP.

Tcl provides a powerful platform for creating integration applications
that tie together diverse applications, protocols, devices, and
frameworks.  When paired with the Tk toolkit, Tcl provides the fastest
and most powerful way to create GUI applications that run on PCs, Unix,


|




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Tcl/Tk 8.5 for Windows, Binary Distribution

RCS: @(#) $Id: README.binary,v 1.38.2.2 2005/07/12 20:37:31 kennykb Exp $ 

1. Introduction
--------------- 

This directory contains the binary distribution of Tcl/Tk 8.5a4 for
Windows.  It was compiled with Microsoft Visual C++ 6.0 using Win32
API, so that it will run under Windows 98, NT, 2000 and XP.

Tcl provides a powerful platform for creating integration applications
that tie together diverse applications, protocols, devices, and
frameworks.  When paired with the Tk toolkit, Tcl provides the fastest
and most powerful way to create GUI applications that run on PCs, Unix,

Changes to win/configure.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.57.
#
# Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002
# Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization.  ##
## --------------------- ##

# Be Bourne compatible
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
  emulate sh
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi


# Support unset when possible.
if (FOO=FOO; unset FOO) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.


|

<
|
















>


|


















|







1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.59.
#

# Copyright (C) 2003 Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization.  ##
## --------------------- ##

# Be Bourne compatible
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
  emulate sh
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi
DUALCASE=1; export DUALCASE # for MKS sh

# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.
214
215
216
217
218
219
220

221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else

  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"







>






|


|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else
  test -d ./-p && rmdir ./-p
  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac
done

# Be sure to have absolute paths.
for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
              localstatedir libdir includedir oldincludedir infodir mandir
do
  eval ac_val=$`echo $ac_var`
  case $ac_val in
    [\\/$]* | ?:[\\/]* ) ;;
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac







|







664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac
done

# Be sure to have absolute paths.
for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
	      localstatedir libdir includedir oldincludedir infodir mandir
do
  eval ac_val=$`echo $ac_var`
  case $ac_val in
    [\\/$]* | ?:[\\/]* ) ;;
    *)  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
   { (exit 1); exit 1; }; };;
  esac
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720

# Find the source files, if location was not specified.
if test -z "$srcdir"; then
  ac_srcdir_defaulted=yes
  # Try the directory containing this script, then its parent.
  ac_confdir=`(dirname "$0") 2>/dev/null ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
         X"$0" : 'X\(//\)[^/]' \| \
         X"$0" : 'X\(//\)$' \| \
         X"$0" : 'X\(/\)' \| \
         .     : '\(.\)' 2>/dev/null ||
echo X"$0" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  srcdir=$ac_confdir







|
|
|
|







704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721

# Find the source files, if location was not specified.
if test -z "$srcdir"; then
  ac_srcdir_defaulted=yes
  # Try the directory containing this script, then its parent.
  ac_confdir=`(dirname "$0") 2>/dev/null ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$0" : 'X\(//\)[^/]' \| \
	 X"$0" : 'X\(//\)$' \| \
	 X"$0" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$0" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  srcdir=$ac_confdir
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
      --srcdir=DIR        find the sources in DIR [configure dir or \`..']

_ACEOF

  cat <<_ACEOF
Installation directories:
  --prefix=PREFIX         install architecture-independent files in PREFIX
                          [$ac_default_prefix]
  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
                          [PREFIX]

By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc.  You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.

For better control, use the options below.







|

|







799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
      --srcdir=DIR        find the sources in DIR [configure dir or \`..']

_ACEOF

  cat <<_ACEOF
Installation directories:
  --prefix=PREFIX         install architecture-independent files in PREFIX
			  [$ac_default_prefix]
  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
			  [PREFIX]

By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc.  You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.

For better control, use the options below.
890
891
892
893
894
895
896
897
898





899







900






901










902





903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac
# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be
# absolute.





ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd`







ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd`






ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd`










ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd`






    cd $ac_dir
    # Check for guested configure; otherwise get Cygnus style configure.
    if test -f $ac_srcdir/configure.gnu; then
      echo
      $SHELL $ac_srcdir/configure.gnu  --help=recursive
    elif test -f $ac_srcdir/configure; then
      echo
      $SHELL $ac_srcdir/configure  --help=recursive
    elif test -f $ac_srcdir/configure.ac ||
           test -f $ac_srcdir/configure.in; then
      echo
      $ac_configure --help
    else
      echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
    fi
    cd $ac_popdir
  done
fi

test -n "$ac_init_help" && exit 0
if $ac_init_version; then
  cat <<\_ACEOF

Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002
Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit 0
fi
exec 5>config.log
cat >&5 <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by $as_me, which was
generated by GNU Autoconf 2.57.  Invocation command line was

  $ $0 $@

_ACEOF
{
cat <<_ASUNAME
## --------- ##







|
|
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>










|













<
|











|







891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960

961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac

# Do not use `cd foo && pwd` to compute absolute paths, because
# the directories may not exist.
case `pwd` in
.) ac_abs_builddir="$ac_dir";;
*)
  case "$ac_dir" in
  .) ac_abs_builddir=`pwd`;;
  [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
  *) ac_abs_builddir=`pwd`/"$ac_dir";;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_builddir=${ac_top_builddir}.;;
*)
  case ${ac_top_builddir}. in
  .) ac_abs_top_builddir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
  *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_srcdir=$ac_srcdir;;
*)
  case $ac_srcdir in
  .) ac_abs_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
  *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_srcdir=$ac_top_srcdir;;
*)
  case $ac_top_srcdir in
  .) ac_abs_top_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
  *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
  esac;;
esac

    cd $ac_dir
    # Check for guested configure; otherwise get Cygnus style configure.
    if test -f $ac_srcdir/configure.gnu; then
      echo
      $SHELL $ac_srcdir/configure.gnu  --help=recursive
    elif test -f $ac_srcdir/configure; then
      echo
      $SHELL $ac_srcdir/configure  --help=recursive
    elif test -f $ac_srcdir/configure.ac ||
	   test -f $ac_srcdir/configure.in; then
      echo
      $ac_configure --help
    else
      echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
    fi
    cd $ac_popdir
  done
fi

test -n "$ac_init_help" && exit 0
if $ac_init_version; then
  cat <<\_ACEOF


Copyright (C) 2003 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit 0
fi
exec 5>config.log
cat >&5 <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by $as_me, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  $ $0 $@

_ACEOF
{
cat <<_ASUNAME
## --------- ##
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
      ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
    esac
    case $ac_pass in
    1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
    2)
      ac_configure_args1="$ac_configure_args1 '$ac_arg'"
      if test $ac_must_keep_next = true; then
        ac_must_keep_next=false # Got value, back to normal.
      else
        case $ac_arg in
          *=* | --config-cache | -C | -disable-* | --disable-* \
          | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
          | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
          | -with-* | --with-* | -without-* | --without-* | --x)
            case "$ac_configure_args0 " in
              "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
            esac
            ;;
          -* ) ac_must_keep_next=true ;;
        esac
      fi
      ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'"
      # Get rid of the leading space.
      ac_sep=" "
      ;;
    esac
  done







|

|
|
|
|
|
|
|
|
|
|
|







1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
      ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
    esac
    case $ac_pass in
    1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
    2)
      ac_configure_args1="$ac_configure_args1 '$ac_arg'"
      if test $ac_must_keep_next = true; then
	ac_must_keep_next=false # Got value, back to normal.
      else
	case $ac_arg in
	  *=* | --config-cache | -C | -disable-* | --disable-* \
	  | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
	  | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
	  | -with-* | --with-* | -without-* | --without-* | --x)
	    case "$ac_configure_args0 " in
	      "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
	    esac
	    ;;
	  -* ) ac_must_keep_next=true ;;
	esac
      fi
      ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'"
      # Get rid of the leading space.
      ac_sep=" "
      ;;
    esac
  done
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
    echo
    # The following way of writing the cache mishandles newlines in values,
{
  (set) 2>&1 |
    case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      sed -n \
        "s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
    	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
      ;;
    *)
      sed -n \
        "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
}
    echo

    cat <<\_ASBOX
## ----------------- ##







|
|



|







1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
    echo
    # The following way of writing the cache mishandles newlines in values,
{
  (set) 2>&1 |
    case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      sed -n \
	"s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
      ;;
    *)
      sed -n \
	"s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
}
    echo

    cat <<\_ASBOX
## ----------------- ##
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
## Output files. ##
## ------------- ##
_ASBOX
      echo
      for ac_var in $ac_subst_files
      do
	eval ac_val=$`echo $ac_var`
        echo "$ac_var='"'"'$ac_val'"'"'"
      done | sort
      echo
    fi

    if test -s confdefs.h; then
      cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
      echo
      sed "/^$/d" confdefs.h | sort
      echo
    fi
    test "$ac_signal" != 0 &&
      echo "$as_me: caught signal $ac_signal"
    echo "$as_me: exit $exit_status"
  } >&5
  rm -f core core.* *.core &&
  rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
    exit $exit_status
     ' 0
for ac_signal in 1 2 13 15; do
  trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0







|


















|







1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
## Output files. ##
## ------------- ##
_ASBOX
      echo
      for ac_var in $ac_subst_files
      do
	eval ac_val=$`echo $ac_var`
	echo "$ac_var='"'"'$ac_val'"'"'"
      done | sort
      echo
    fi

    if test -s confdefs.h; then
      cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
      echo
      sed "/^$/d" confdefs.h | sort
      echo
    fi
    test "$ac_signal" != 0 &&
      echo "$as_me: caught signal $ac_signal"
    echo "$as_me: exit $exit_status"
  } >&5
  rm -f core *.core &&
  rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
    exit $exit_status
     ' 0
for ac_signal in 1 2 13 15; do
  trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
  >$cache_file
fi

# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in `(set) 2>&1 |
               sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do
  eval ac_old_set=\$ac_cv_env_${ac_var}_set
  eval ac_new_set=\$ac_env_${ac_var}_set
  eval ac_old_val="\$ac_cv_env_${ac_var}_value"
  eval ac_new_val="\$ac_env_${ac_var}_value"
  case $ac_old_set,$ac_new_set in
    set,)
      { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,set)
      { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,);;
    *)
      if test "x$ac_old_val" != "x$ac_new_val"; then
        { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
        { echo "$as_me:$LINENO:   former value:  $ac_old_val" >&5
echo "$as_me:   former value:  $ac_old_val" >&2;}
        { echo "$as_me:$LINENO:   current value: $ac_new_val" >&5
echo "$as_me:   current value: $ac_new_val" >&2;}
        ac_cache_corrupted=:
      fi;;
  esac
  # Pass precious variables to config.status.
  if test "$ac_new_set" = set; then
    case $ac_new_val in
    *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
      ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;







|
















|

|

|

|







1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
  >$cache_file
fi

# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in `(set) 2>&1 |
	       sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do
  eval ac_old_set=\$ac_cv_env_${ac_var}_set
  eval ac_new_set=\$ac_env_${ac_var}_set
  eval ac_old_val="\$ac_cv_env_${ac_var}_value"
  eval ac_new_val="\$ac_env_${ac_var}_value"
  case $ac_old_set,$ac_new_set in
    set,)
      { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,set)
      { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
      ac_cache_corrupted=: ;;
    ,);;
    *)
      if test "x$ac_old_val" != "x$ac_new_val"; then
	{ echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
	{ echo "$as_me:$LINENO:   former value:  $ac_old_val" >&5
echo "$as_me:   former value:  $ac_old_val" >&2;}
	{ echo "$as_me:$LINENO:   current value: $ac_new_val" >&5
echo "$as_me:   current value: $ac_new_val" >&2;}
	ac_cache_corrupted=:
      fi;;
  esac
  # Pass precious variables to config.status.
  if test "$ac_new_set" = set; then
    case $ac_new_val in
    *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
      ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh

TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a2"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION







|







1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh

TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a4"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5
  (eval $ac_compiler -V </dev/null >&5) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files a.out a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
echo "$as_me:$LINENO: checking for C compiler default output" >&5
echo $ECHO_N "checking for C compiler default output... $ECHO_C" >&6
ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5
  (eval $ac_link_default) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; then
  # Find the output, starting from the most likely.  This scheme is
# not robust to junk in `.', hence go to wildcards (a.*) only as a last
# resort.

# Be careful to initialize this variable, since it used to be cached.
# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile.
ac_cv_exeext=
# b.out is created by i960 compilers.
for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out
do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj )
        ;;
    conftest.$ac_ext )
        # This is the source file.
        ;;
    [ab].out )
        # We found the default executable, but exeext='' is most
        # certainly right.
        break;;
    *.* )
        ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
        # FIXME: I believe we export ac_cv_exeext for Libtool,
        # but it would be cool to find out if it's true.  Does anybody
        # maintain Libtool? --akim.
        export ac_cv_exeext
        break;;
    * )
        break;;
  esac
done
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

{ { echo "$as_me:$LINENO: error: C compiler cannot create executables







<



















|
|



















|

|
|

|
|
|

|
|
|
|
|
|

|







1677
1678
1679
1680
1681
1682
1683

1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5
  (eval $ac_compiler -V </dev/null >&5) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files a.out a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
echo "$as_me:$LINENO: checking for C compiler default output file name" >&5
echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6
ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5
  (eval $ac_link_default) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; then
  # Find the output, starting from the most likely.  This scheme is
# not robust to junk in `.', hence go to wildcards (a.*) only as a last
# resort.

# Be careful to initialize this variable, since it used to be cached.
# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile.
ac_cv_exeext=
# b.out is created by i960 compilers.
for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out
do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj )
	;;
    conftest.$ac_ext )
	# This is the source file.
	;;
    [ab].out )
	# We found the default executable, but exeext='' is most
	# certainly right.
	break;;
    *.* )
	ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
	# FIXME: I believe we export ac_cv_exeext for Libtool,
	# but it would be cool to find out if it's true.  Does anybody
	# maintain Libtool? --akim.
	export ac_cv_exeext
	break;;
    * )
	break;;
  esac
done
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

{ { echo "$as_me:$LINENO: error: C compiler cannot create executables
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
# work properly (i.e., refer to `conftest.exe'), while it won't with
# `rm'.
for ac_file in conftest.exe conftest conftest.*; do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;;
    *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
          export ac_cv_exeext
          break;;
    * ) break;;
  esac
done
else
  { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
See \`config.log' for more details." >&5
echo "$as_me: error: cannot compute suffix of executables: cannot compile and link







|
|







1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
# work properly (i.e., refer to `conftest.exe'), while it won't with
# `rm'.
for ac_file in conftest.exe conftest conftest.*; do
  test -f "$ac_file" || continue
  case $ac_file in
    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;;
    *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
	  export ac_cv_exeext
	  break;;
    * ) break;;
  esac
done
else
  { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
See \`config.log' for more details." >&5
echo "$as_me: error: cannot compute suffix of executables: cannot compile and link
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
ac_exeext=$EXEEXT
echo "$as_me:$LINENO: checking for suffix of object files" >&5
echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6
if test "${ac_cv_objext+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int







<







1833
1834
1835
1836
1837
1838
1839

1840
1841
1842
1843
1844
1845
1846
ac_exeext=$EXEEXT
echo "$as_me:$LINENO: checking for suffix of object files" >&5
echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6
if test "${ac_cv_objext+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880



1881
1882







1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930



1931
1932







1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
ac_objext=$OBJEXT
echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6
if test "${ac_cv_c_compiler_gnu+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
#ifndef __GNUC__
       choke me
#endif

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_compiler_gnu=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_compiler_gnu=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu

fi
echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6
GCC=`test $ac_compiler_gnu = yes && echo yes`
ac_test_CFLAGS=${CFLAGS+set}
ac_save_CFLAGS=$CFLAGS
CFLAGS="-g"
echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6
if test "${ac_cv_prog_cc_g+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_g=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_prog_cc_g=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
if test "$ac_test_CFLAGS" = set; then
  CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
  if test "$GCC" = yes; then







<



















|

>
>
>


>
>
>
>
>
>
>
|












|















<
















|

>
>
>


>
>
>
>
>
>
>
|












|







1883
1884
1885
1886
1887
1888
1889

1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951

1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
ac_objext=$OBJEXT
echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6
if test "${ac_cv_c_compiler_gnu+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
#ifndef __GNUC__
       choke me
#endif

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_compiler_gnu=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_compiler_gnu=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu

fi
echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6
GCC=`test $ac_compiler_gnu = yes && echo yes`
ac_test_CFLAGS=${CFLAGS+set}
ac_save_CFLAGS=$CFLAGS
CFLAGS="-g"
echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6
if test "${ac_cv_prog_cc_g+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_g=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_prog_cc_g=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
if test "$ac_test_CFLAGS" = set; then
  CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
  if test "$GCC" = yes; then
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6
if test "${ac_cv_prog_cc_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_cv_prog_cc_stdc=no
ac_save_CC=$CC
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdarg.h>
#include <stdio.h>







<







2015
2016
2017
2018
2019
2020
2021

2022
2023
2024
2025
2026
2027
2028
echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6
if test "${ac_cv_prog_cc_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  ac_cv_prog_cc_stdc=no
ac_save_CC=$CC
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdarg.h>
#include <stdio.h>
1994
1995
1996
1997
1998
1999
2000










2001
2002
2003
2004
2005
2006
2007
  char *s;
  va_list v;
  va_start (v,p);
  s = g (p, va_arg (v,int));
  va_end (v);
  return s;
}










int test (int i, double x);
struct s1 {int (*f) (int a);};
struct s2 {int (*f) (double a);};
int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
int argc;
char **argv;
int







>
>
>
>
>
>
>
>
>
>







2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
  char *s;
  va_list v;
  va_start (v,p);
  s = g (p, va_arg (v,int));
  va_end (v);
  return s;
}

/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default.  It has
   function prototypes and stuff, but not '\xHH' hex character constants.
   These don't provoke an error unfortunately, instead are silently treated
   as 'x'.  The following induces an error, until -std1 is added to get
   proper ANSI mode.  Curiously '\x00'!='x' always comes out true, for an
   array size at least.  It's necessary to write '\x00'==0 to get something
   that's true only with -std1.  */
int osf4_cc_array ['\x00' == 0 ? 1 : -1];

int test (int i, double x);
struct s1 {int (*f) (int a);};
struct s2 {int (*f) (double a);};
int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
int argc;
char **argv;
int
2020
2021
2022
2023
2024
2025
2026
2027
2028



2029
2030







2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
# HP-UX older versions	-Aa -D_HPUX_SOURCE
# SVR4			-Xc -D__EXTENSIONS__
for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
do
  CC="$ac_save_CC $ac_arg"
  rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_stdc=$ac_arg
break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext
done
rm -f conftest.$ac_ext conftest.$ac_objext
CC=$ac_save_CC

fi

case "x$ac_cv_prog_cc_stdc" in







|

>
>
>


>
>
>
>
>
>
>
|












|







2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
# HP-UX older versions	-Aa -D_HPUX_SOURCE
# SVR4			-Xc -D__EXTENSIONS__
for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
do
  CC="$ac_save_CC $ac_arg"
  rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_prog_cc_stdc=$ac_arg
break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext
done
rm -f conftest.$ac_ext conftest.$ac_objext
CC=$ac_save_CC

fi

case "x$ac_cv_prog_cc_stdc" in
2065
2066
2067
2068
2069
2070
2071
2072
2073



2074
2075







2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099

2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111



2112
2113







2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147



2148
2149







2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
cat >conftest.$ac_ext <<_ACEOF
#ifndef __cplusplus
  choke me
#endif
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  for ac_declaration in \
   ''\
   '#include <stdlib.h>' \
   'extern "C" void std::exit (int) throw (); using std::exit;' \
   'extern "C" void std::exit (int); using std::exit;' \
   'extern "C" void exit (int) throw ();' \
   'extern "C" void exit (int);' \
   'void exit (int);'
do
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
$ac_declaration

int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

continue
fi
rm -f conftest.$ac_objext conftest.$ac_ext
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_declaration
int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext conftest.$ac_ext
done
rm -f conftest*
if test -n "$ac_declaration"; then
  echo '#ifdef __cplusplus' >>confdefs.h
  echo $ac_declaration      >>confdefs.h
  echo '#endif'             >>confdefs.h
fi

else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.$ac_objext conftest.$ac_ext
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu









|

>
>
>


>
>
>
>
>
>
>
|






|
<







<





<

>










|

>
>
>


>
>
>
>
>
>
>
|












|

<
















|

>
>
>


>
>
>
>
>
>
>
|











|













|







2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161

2162
2163
2164
2165
2166
2167
2168

2169
2170
2171
2172
2173

2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214

2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
cat >conftest.$ac_ext <<_ACEOF
#ifndef __cplusplus
  choke me
#endif
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  for ac_declaration in \
   '' \

   'extern "C" void std::exit (int) throw (); using std::exit;' \
   'extern "C" void std::exit (int); using std::exit;' \
   'extern "C" void exit (int) throw ();' \
   'extern "C" void exit (int);' \
   'void exit (int);'
do
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

$ac_declaration
#include <stdlib.h>
int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

continue
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_declaration
int
main ()
{
exit (42);
  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  break
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
done
rm -f conftest*
if test -n "$ac_declaration"; then
  echo '#ifdef __cplusplus' >>confdefs.h
  echo $ac_declaration      >>confdefs.h
  echo '#endif'             >>confdefs.h
fi

else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu


2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328

#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------

echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5
echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,./+-,__p_,'`
if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.make <<\_ACEOF
all:
	@echo 'ac_maketemp="$(MAKE)"'
_ACEOF







|







2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423

#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------

echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5
echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'`
if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.make <<\_ACEOF
all:
	@echo 'ac_maketemp="$(MAKE)"'
_ACEOF
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383



2384
2385







2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
if test "${ac_cv_cygwin+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#ifdef __CYGWIN__
#error cygwin
#endif

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_cygwin=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_cygwin=yes
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
echo "${ECHO_T}$ac_cv_cygwin" >&6
if test "$ac_cv_cygwin" = "yes" ; then
    { { echo "$as_me:$LINENO: error: Compiling under Cygwin is not currently supported.
A maintainer for the Cygwin port of Tcl/Tk is needed. See the README







<




















|

>
>
>


>
>
>
>
>
>
>
|












|







2449
2450
2451
2452
2453
2454
2455

2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
if test "${ac_cv_cygwin+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#ifdef __CYGWIN__
#error cygwin
#endif

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_cygwin=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_cygwin=yes
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
echo "${ECHO_T}$ac_cv_cygwin" >&6
if test "$ac_cv_cygwin" = "yes" ; then
    { { echo "$as_me:$LINENO: error: Compiling under Cygwin is not currently supported.
A maintainer for the Cygwin port of Tcl/Tk is needed. See the README
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
if test "${tcl_cv_seh+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_seh=no
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN







<







2521
2522
2523
2524
2525
2526
2527

2528
2529
2530
2531
2532
2533
2534
if test "${tcl_cv_seh+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_seh=no
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_seh=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi

fi
echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5
echo "${ECHO_T}$tcl_cv_seh" >&6
if test "$tcl_cv_seh" = "no" ; then








|







2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
tcl_cv_seh=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi

fi
echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5
echo "${ECHO_T}$tcl_cv_seh" >&6
if test "$tcl_cv_seh" = "no" ; then

2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
#
echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5
echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6
if test "${tcl_cv_eh_disposition+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN







<







2589
2590
2591
2592
2593
2594
2595

2596
2597
2598
2599
2600
2601
2602
#
echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5
echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6
if test "${tcl_cv_eh_disposition+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN
2509
2510
2511
2512
2513
2514
2515
2516
2517



2518
2519







2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_eh_disposition=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_eh_disposition=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5
echo "${ECHO_T}$tcl_cv_eh_disposition" >&6
if test "$tcl_cv_eh_disposition" = "no" ; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












|







2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_eh_disposition=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_eh_disposition=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5
echo "${ECHO_T}$tcl_cv_eh_disposition" >&6
if test "$tcl_cv_eh_disposition" = "no" ; then

cat >>confdefs.h <<\_ACEOF
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
#
echo "$as_me:$LINENO: checking for LPFN_ACCEPT support in winsock2.h" >&5
echo $ECHO_N "checking for LPFN_ACCEPT support in winsock2.h... $ECHO_C" >&6
if test "${tcl_cv_lpfn_decls+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN







<







2661
2662
2663
2664
2665
2666
2667

2668
2669
2670
2671
2672
2673
2674
#
echo "$as_me:$LINENO: checking for LPFN_ACCEPT support in winsock2.h" >&5
echo $ECHO_N "checking for LPFN_ACCEPT support in winsock2.h... $ECHO_C" >&6
if test "${tcl_cv_lpfn_decls+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN
2573
2574
2575
2576
2577
2578
2579
2580
2581



2582
2583







2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_lpfn_decls=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_lpfn_decls=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_lpfn_decls" >&5
echo "${ECHO_T}$tcl_cv_lpfn_decls" >&6
if test "$tcl_cv_lpfn_decls" = "no" ; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












|







2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_lpfn_decls=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_lpfn_decls=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_lpfn_decls" >&5
echo "${ECHO_T}$tcl_cv_lpfn_decls" >&6
if test "$tcl_cv_lpfn_decls" = "no" ; then

cat >>confdefs.h <<\_ACEOF
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627

echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5
echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6
if test "${tcl_cv_winnt_ignore_void+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define VOID void







<







2734
2735
2736
2737
2738
2739
2740

2741
2742
2743
2744
2745
2746
2747

echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5
echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6
if test "${tcl_cv_winnt_ignore_void+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define VOID void
2639
2640
2641
2642
2643
2644
2645
2646
2647



2648
2649







2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_winnt_ignore_void=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_winnt_ignore_void=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5
echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












|







2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_winnt_ignore_void=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_winnt_ignore_void=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5
echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then

cat >>confdefs.h <<\_ACEOF
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699

echo "$as_me:$LINENO: checking for alloca declaration in malloc.h" >&5
echo $ECHO_N "checking for alloca declaration in malloc.h... $ECHO_C" >&6
if test "${tcl_cv_malloc_decl_alloca+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <malloc.h>







<







2815
2816
2817
2818
2819
2820
2821

2822
2823
2824
2825
2826
2827
2828

echo "$as_me:$LINENO: checking for alloca declaration in malloc.h" >&5
echo $ECHO_N "checking for alloca declaration in malloc.h... $ECHO_C" >&6
if test "${tcl_cv_malloc_decl_alloca+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <malloc.h>
2709
2710
2711
2712
2713
2714
2715
2716
2717



2718
2719







2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_malloc_decl_alloca=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_malloc_decl_alloca=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_malloc_decl_alloca" >&5
echo "${ECHO_T}$tcl_cv_malloc_decl_alloca" >&6
if test "$tcl_cv_malloc_decl_alloca" = "no" &&
   test "${GCC}" = "yes" ; then








|

>
>
>


>
>
>
>
>
>
>
|












|







2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_malloc_decl_alloca=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_malloc_decl_alloca=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_malloc_decl_alloca" >&5
echo "${ECHO_T}$tcl_cv_malloc_decl_alloca" >&6
if test "$tcl_cv_malloc_decl_alloca" = "no" &&
   test "${GCC}" = "yes" ; then

2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778



2779
2780







2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801

echo "$as_me:$LINENO: checking for cast to union support" >&5
echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
if test "${tcl_cv_cast_to_union+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  union foo { int i; double d; };
  union foo f = (union foo) (int) 0;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_cast_to_union=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_cast_to_union=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
if test "$tcl_cv_cast_to_union" = "yes"; then

cat >>confdefs.h <<\_ACEOF







<



















|

>
>
>


>
>
>
>
>
>
>
|












|







2889
2890
2891
2892
2893
2894
2895

2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949

echo "$as_me:$LINENO: checking for cast to union support" >&5
echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
if test "${tcl_cv_cast_to_union+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{

  union foo { int i; double d; };
  union foo f = (union foo) (int) 0;

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_cast_to_union=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_cast_to_union=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
if test "$tcl_cv_cast_to_union" = "yes"; then

cat >>confdefs.h <<\_ACEOF
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825

echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
if test "${tcl_cv_findex_enums+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN







<







2959
2960
2961
2962
2963
2964
2965

2966
2967
2968
2969
2970
2971
2972

echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
if test "${tcl_cv_findex_enums+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN
2835
2836
2837
2838
2839
2840
2841
2842
2843



2844
2845







2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_findex_enums=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_findex_enums=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
echo "${ECHO_T}$tcl_cv_findex_enums" >&6
if test "$tcl_cv_findex_enums" = "no"; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












|







2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_findex_enums=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_findex_enums=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
echo "${ECHO_T}$tcl_cv_findex_enums" >&6
if test "$tcl_cv_findex_enums" = "no"; then

cat >>confdefs.h <<\_ACEOF
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888

echo "$as_me:$LINENO: checking for MWMO_ALERTABLE in winuser.h" >&5
echo $ECHO_N "checking for MWMO_ALERTABLE in winuser.h... $ECHO_C" >&6
if test "${tcl_cv_mwmo_alertable+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN







<







3031
3032
3033
3034
3035
3036
3037

3038
3039
3040
3041
3042
3043
3044

echo "$as_me:$LINENO: checking for MWMO_ALERTABLE in winuser.h" >&5
echo $ECHO_N "checking for MWMO_ALERTABLE in winuser.h... $ECHO_C" >&6
if test "${tcl_cv_mwmo_alertable+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#define WIN32_LEAN_AND_MEAN
2897
2898
2899
2900
2901
2902
2903
2904
2905



2906
2907







2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_mwmo_alertable=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_mwmo_alertable=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_mwmo_alertable" >&5
echo "${ECHO_T}$tcl_cv_mwmo_alertable" >&6
if test "$tcl_cv_mwmo_alertable" = "no"; then

cat >>confdefs.h <<\_ACEOF







|

>
>
>


>
>
>
>
>
>
>
|












|







3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_cv_mwmo_alertable=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_cv_mwmo_alertable=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

fi
echo "$as_me:$LINENO: result: $tcl_cv_mwmo_alertable" >&5
echo "${ECHO_T}$tcl_cv_mwmo_alertable" >&6
if test "$tcl_cv_mwmo_alertable" = "no"; then

cat >>confdefs.h <<\_ACEOF
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982

	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention
	cat >>confdefs.h <<\_ACEOF
#define USE_THREAD_ALLOC 1
_ACEOF

	# USE_THREAD_STORAGE tells us to use the new generic thread
	# storage subsystem.
	cat >>confdefs.h <<\_ACEOF
#define USE_THREAD_STORAGE 1
_ACEOF

    else
	TCL_THREADS=0
	echo "$as_me:$LINENO: result: no (default)" >&5
echo "${ECHO_T}no (default)" >&6
    fi









<
<
<
<
<
<







3129
3130
3131
3132
3133
3134
3135






3136
3137
3138
3139
3140
3141
3142

	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention
	cat >>confdefs.h <<\_ACEOF
#define USE_THREAD_ALLOC 1
_ACEOF







    else
	TCL_THREADS=0
	echo "$as_me:$LINENO: result: no (default)" >&5
echo "${ECHO_T}no (default)" >&6
    fi


3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
	if test "$do64bit" = "yes" ; then
	    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on Windows\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on Windows\"" >&2;}
	fi
	SHLIB_LD=""
	SHLIB_LD_LIBS=""
	LIBS=""
	LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32"
	STLIB_LD='${AR} cr'
	RC_OUT=-o
	RC_TYPE=
	RC_INCLUDE=--include
	RC_DEFINE=--define
	RES=res.o
	MAKE_LIB="\${STLIB_LD} \$@"







|







3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
	if test "$do64bit" = "yes" ; then
	    { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on Windows\"" >&5
echo "$as_me: WARNING: \"64bit mode not supported with GCC on Windows\"" >&2;}
	fi
	SHLIB_LD=""
	SHLIB_LD_LIBS=""
	LIBS=""
	LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -lole32 -loleaut32 -luuid"
	STLIB_LD='${AR} cr'
	RC_OUT=-o
	RC_TYPE=
	RC_INCLUDE=--include
	RC_DEFINE=--define
	RES=res.o
	MAKE_LIB="\${STLIB_LD} \$@"
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
	# users of tclConfig.sh that may build shared or static.
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE=-O
	CFLAGS_WARNING="-Wall -Wconversion"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \$@"
	CC_EXENAME="-o \$@"







|







3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
	# users of tclConfig.sh that may build shared or static.
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
	CFLAGS_WARNING="-Wall -Wconversion"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \$@"
	CC_EXENAME="-o \$@"
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319



3320
3321
3322
3323
3324
3325
3326

3327
3328
3329
3330
3331
3332
3333


3334

3335
3336
3337
3338
3339
3340
3341
3342



3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362

	# This is a 2-stage check to make sure we have the 64-bit SDK
	# We have to know where the SDK is installed.
	if test "$do64bit" = "yes" ; then
	    if test "x${MSSDK}x" = "xx" ; then
		MSSDK="C:/Progra~1/Microsoft SDK"
	    fi
	    # In order to work in the tortured autoconf environment,
	    # we need to ensure that this path has no spaces
	    MSSDK=$(cygpath -w -s "$MSSDK" | sed -e 's!\\!/!g')
	    if test ! -d "${MSSDK}/bin/win64" ; then
		{ echo "$as_me:$LINENO: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&5
echo "$as_me: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&2;}
		do64bit="no"
	    fi
	fi

	if test "$do64bit" = "yes" ; then
	    # All this magic is necessary for the Win64 SDK RC1 - hobbs



	    CC="${MSSDK}/Bin/Win64/cl.exe \
	-I${MSSDK}/Include/prerelease \
	-I${MSSDK}/Include/Win64/crt \
	-I${MSSDK}/Include/Win64/crt/sys \
	-I${MSSDK}/Include"
	    RC="${MSSDK}/bin/rc.exe"
	    CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"

	    CFLAGS_OPTIMIZE="-nologo -O2 -Gs ${runtime}"
	    lflags="-MACHINE:IA64 -LIBPATH:${MSSDK}/Lib/IA64 \
	-LIBPATH:${MSSDK}/Lib/Prerelease/IA64"
	    STLIB_LD="${MSSDK}/bin/win64/lib.exe -nologo ${lflags}"
	    LINKBIN="${MSSDK}/bin/win64/link.exe ${lflags}"
	else
	    RC="rc"


	    CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"

	    CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
	    STLIB_LD="lib -nologo"
	    LINKBIN="link -link50compat"
	fi

	SHLIB_LD="${LINKBIN} -dll -nologo -incremental:no"
	LIBS="user32.lib advapi32.lib"
	LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib"



	RC_OUT=-fo
	RC_TYPE=-r
	RC_INCLUDE=-i
	RC_DEFINE=-d
	RES=res
	MAKE_LIB="\${STLIB_LD} -out:\$@"
	POST_MAKE_LIB=
	MAKE_EXE="\${CC} -Fe\$@"
	LIBPREFIX=""

	EXTRA_CFLAGS="-YX"
	CFLAGS_WARNING="-W3"
	LDFLAGS_DEBUG="-debug:full -debugtype:both"
	LDFLAGS_OPTIMIZE="-release"

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-Fo\$@"
	CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\""

	# Specify linker flags depending on the type of app being







<
<
|









>
>
>
|
|
|
|
|
|

>
|
|
|
<
|


>
>

>
|
|
|


<

|
>
>
>










|

|







3461
3462
3463
3464
3465
3466
3467


3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491

3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503

3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528

	# This is a 2-stage check to make sure we have the 64-bit SDK
	# We have to know where the SDK is installed.
	if test "$do64bit" = "yes" ; then
	    if test "x${MSSDK}x" = "xx" ; then
		MSSDK="C:/Progra~1/Microsoft SDK"
	    fi


	    MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'`
	    if test ! -d "${MSSDK}/bin/win64" ; then
		{ echo "$as_me:$LINENO: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&5
echo "$as_me: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&2;}
		do64bit="no"
	    fi
	fi

	if test "$do64bit" = "yes" ; then
	    # All this magic is necessary for the Win64 SDK RC1 - hobbs
	    # The space-based-path will work for the Makefile, but will
	    # not work if AC_TRY_COMPILE is called.  TEA has the
	    # TEA_PATH_NOSPACE to avoid this issue.
	    CC="\"${MSSDK}/Bin/Win64/cl.exe\" \
		-I\"${MSSDK}/Include/prerelease\" \
		-I\"${MSSDK}/Include/Win64/crt\" \
		-I\"${MSSDK}/Include/Win64/crt/sys\" \
		-I\"${MSSDK}/Include\""
	    RC="\"${MSSDK}/bin/rc.exe\""
	    CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
	    # Do not use -O2 for Win64 - this has proved buggy in code gen.
	    CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}"
	    lflags="-MACHINE:IA64 -LIBPATH:\"${MSSDK}/Lib/IA64\" \
		-LIBPATH:\"${MSSDK}/Lib/Prerelease/IA64\" -nologo"

	    LINKBIN="\"${MSSDK}/bin/win64/link.exe\""
	else
	    RC="rc"
	    # -Od - no optimization
	    # -WX - warnings as errors
	    CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
	    # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy)
	    CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}"
	    lflags="-nologo"
	    LINKBIN="link"
	fi


	LIBS="user32.lib advapi32.lib"
	LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib"
	SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
	# link -lib only works when -lib is the first arg
	STLIB_LD="${LINKBIN} -lib ${lflags}"
	RC_OUT=-fo
	RC_TYPE=-r
	RC_INCLUDE=-i
	RC_DEFINE=-d
	RES=res
	MAKE_LIB="\${STLIB_LD} -out:\$@"
	POST_MAKE_LIB=
	MAKE_EXE="\${CC} -Fe\$@"
	LIBPREFIX=""

	EXTRA_CFLAGS=""
	CFLAGS_WARNING="-W3"
	LDFLAGS_DEBUG="-debug:full"
	LDFLAGS_OPTIMIZE="-release"

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-Fo\$@"
	CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\""

	# Specify linker flags depending on the type of app being
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511

3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549

3550
3551
3552
3553
3554
3555
3556
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
                     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then







<










|











>




















<

















>







3648
3649
3650
3651
3652
3653
3654

3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697

3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
		     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618

3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656

3657
3658
3659
3660
3661
3662
3663
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
                     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then







<










|











>




















<

















>







3755
3756
3757
3758
3759
3760
3761

3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804

3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
  # Use a header file that comes with gcc, so configuring glibc
  # with a fresh cross-compiler works.
  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
  # <limits.h> exists even on freestanding compilers.
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp. "Syntax error" is here to catch this case.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
		     Syntax error
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  :
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  # Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.$ac_ext

  # OK, works on sane cases.  Now check whether non-existent headers
  # can be detected and how.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ac_nonexistent.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739



3740
3741







3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767

echo "$as_me:$LINENO: checking for ANSI C header files" >&5
echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6
if test "${ac_cv_header_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_header_stdc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_header_stdc=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext

if test $ac_cv_header_stdc = yes; then
  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>








<




















|

>
>
>


>
>
>
>
>
>
>
|












|




<







3876
3877
3878
3879
3880
3881
3882

3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934

3935
3936
3937
3938
3939
3940
3941

echo "$as_me:$LINENO: checking for ANSI C header files" >&5
echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6
if test "${ac_cv_header_stdc+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_cv_header_stdc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_cv_header_stdc=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

if test $ac_cv_header_stdc = yes; then
  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <string.h>

3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>








<







3949
3950
3951
3952
3953
3954
3955

3956
3957
3958
3959
3960
3961
3962
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <stdlib.h>

3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839

if test $ac_cv_header_stdc = yes; then
  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
  if test "$cross_compiling" = yes; then
  :
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ctype.h>
#if ((' ' & 0x0FF) == 0x020)
# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#else
# define ISLOWER(c) \
                   (('a' <= (c) && (c) <= 'i') \
                     || ('j' <= (c) && (c) <= 'r') \
                     || ('s' <= (c) && (c) <= 'z'))
# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
#endif

#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int
main ()
{
  int i;
  for (i = 0; i < 256; i++)
    if (XOR (islower (i), ISLOWER (i))
        || toupper (i) != TOUPPER (i))
      exit(2);
  exit (0);
}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5







<











|
|
|










|







3973
3974
3975
3976
3977
3978
3979

3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011

if test $ac_cv_header_stdc = yes; then
  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
  if test "$cross_compiling" = yes; then
  :
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <ctype.h>
#if ((' ' & 0x0FF) == 0x020)
# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#else
# define ISLOWER(c) \
		   (('a' <= (c) && (c) <= 'i') \
		     || ('j' <= (c) && (c) <= 'r') \
		     || ('s' <= (c) && (c) <= 'z'))
# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
#endif

#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int
main ()
{
  int i;
  for (i = 0; i < 256; i++)
    if (XOR (islower (i), ISLOWER (i))
	|| toupper (i) != TOUPPER (i))
      exit(2);
  exit (0);
}
_ACEOF
rm -f conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
  (eval $ac_link) 2>&5
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_header_stdc=no
fi
rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
fi
echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
echo "${ECHO_T}$ac_cv_header_stdc" >&6
if test $ac_cv_header_stdc = yes; then








|







4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
  echo "$as_me: program exited with status $ac_status" >&5
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

( exit $ac_status )
ac_cv_header_stdc=no
fi
rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
fi
fi
fi
echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
echo "${ECHO_T}$ac_cv_header_stdc" >&6
if test $ac_cv_header_stdc = yes; then

3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904



3905
3906







3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927






for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
                  inttypes.h stdint.h unistd.h
do
as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default

#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_Header=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_Header=no"
fi
rm -f conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF







|








<











|

>
>
>


>
>
>
>
>
>
>
|












|







4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062

4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108






for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
		  inttypes.h stdint.h unistd.h
do
as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_header" >&5
echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
if eval "test \"\${$as_ac_Header+set}\" = set"; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default

#include <$ac_header>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  eval "$as_ac_Header=yes"
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

eval "$as_ac_Header=no"
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
if test `eval echo '${'$as_ac_Header'}'` = yes; then
  cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959



3960
3961







3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000

4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033

4034
4035
4036
4037


4038
4039


4040
4041


4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5
echo "${ECHO_T}$ac_cv_header_errno_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking errno.h usability" >&5
echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <errno.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>&5
  ac_status=$?



  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&







         { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking errno.h presence" >&5
echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF
#line $LINENO "configure"
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <errno.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag

  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc in
  yes:no )
    { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to [email protected]. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2

    ;;
  no:yes )
    { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;}


    { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;}


    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;}


    (
      cat <<\_ASBOX
## ------------------------------------ ##
## Report this to bug-autoconf@gnu.org. ##
## ------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for errno.h" >&5
echo $ECHO_N "checking for errno.h... $ECHO_C" >&6







<










|

>
>
>


>
>
>
>
>
>
>
|












|







<

















>



















|
|


|
|
<
<
<
<
<
<
<
<
>

|


>
>
|
|
>
>


>
>


|
|
|







4121
4122
4123
4124
4125
4126
4127

4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172

4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215








4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5
echo "${ECHO_T}$ac_cv_header_errno_h" >&6
else
  # Is the header compilable?
echo "$as_me:$LINENO: checking errno.h usability" >&5
echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
$ac_includes_default
#include <errno.h>
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  ac_header_compiler=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

ac_header_compiler=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
echo "${ECHO_T}$ac_header_compiler" >&6

# Is the header present?
echo "$as_me:$LINENO: checking errno.h presence" >&5
echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6
cat >conftest.$ac_ext <<_ACEOF

/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */
#include <errno.h>
_ACEOF
if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
  (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } >/dev/null; then
  if test -s conftest.err; then
    ac_cpp_err=$ac_c_preproc_warn_flag
    ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
  else
    ac_cpp_err=
  fi
else
  ac_cpp_err=yes
fi
if test -z "$ac_cpp_err"; then
  ac_header_preproc=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

  ac_header_preproc=no
fi
rm -f conftest.err conftest.$ac_ext
echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
echo "${ECHO_T}$ac_header_preproc" >&6

# So?  What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
  yes:no: )
    { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;}








    ac_header_preproc=yes
    ;;
  no:yes:* )
    { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5
echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h:     check for missing prerequisite headers?" >&5
echo "$as_me: WARNING: errno.h:     check for missing prerequisite headers?" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5
echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h:     section \"Present But Cannot Be Compiled\"" >&5
echo "$as_me: WARNING: errno.h:     section \"Present But Cannot Be Compiled\"" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5
echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;}
    { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5
echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;}
    (
      cat <<\_ASBOX
## ------------------------------------------ ##
## Report this to the AC_PACKAGE_NAME lists.  ##
## ------------------------------------------ ##
_ASBOX
    ) |
      sed "s/^/$as_me: WARNING:     /" >&2
    ;;
esac
echo "$as_me:$LINENO: checking for errno.h" >&5
echo $ECHO_N "checking for errno.h... $ECHO_C" >&6
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
{
  (set) 2>&1 |
    case `(ac_space=' '; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      # `set' does not quote correctly, so add quotes (double-quote
      # substitution turns \\\\ into \\, and sed turns \\ into \).
      sed -n \
        "s/'/'\\\\''/g;
    	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
      ;;
    *)
      # `set' quotes correctly as required by POSIX, so do not add quotes.
      sed -n \
        "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
} |
  sed '
     t clear
     : clear
     s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/







|
|




|







4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
{
  (set) 2>&1 |
    case `(ac_space=' '; set | grep ac_space) 2>&1` in
    *ac_space=\ *)
      # `set' does not quote correctly, so add quotes (double-quote
      # substitution turns \\\\ into \\, and sed turns \\ into \).
      sed -n \
	"s/'/'\\\\''/g;
	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
      ;;
    *)
      # `set' quotes correctly as required by POSIX, so do not add quotes.
      sed -n \
	"s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
      ;;
    esac;
} |
  sed '
     t clear
     : clear
     s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'

# VPATH may cause trouble with some makes, so we remove $(srcdir),
# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
# trailing colons and then remove the whole line if VPATH becomes empty
# (actually we leave an empty line to preserve line numbers).
if test "x$srcdir" = x.; then
  ac_vpsub='/^[ 	]*VPATH[ 	]*=/{
s/:*\$(srcdir):*/:/;
s/:*\${srcdir}:*/:/;
s/:*@srcdir@:*/:/;
s/^\([^=]*=[ 	]*\):*/\1/;
s/:*$//;
s/^[^=]*=[ 	]*$//;
}'
fi

# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
#
# If the first sed substitution is executed (which looks for macros that
# take arguments), then we branch to the quote section.  Otherwise,
# look for a macro that doesn't take arguments.
cat >confdef2opt.sed <<\_ACEOF
t clear
: clear
s,^[ 	]*#[ 	]*define[ 	][ 	]*\([^ 	(][^ 	(]*([^)]*)\)[ 	]*\(.*\),-D\1=\2,g
t quote
s,^[ 	]*#[ 	]*define[ 	][ 	]*\([^ 	][^ 	]*\)[ 	]*\(.*\),-D\1=\2,g
t quote
d
: quote
s,[ 	`~#$^&*(){}\\|;'"<>?],\\&,g
s,\[,\\&,g
s,\],\\&,g
s,\$,$$,g
p
_ACEOF
# We use echo to avoid assuming a particular line-breaking character.
# The extra dot is to prevent the shell from consuming trailing







|



|

|













|

|



|







4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'

# VPATH may cause trouble with some makes, so we remove $(srcdir),
# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
# trailing colons and then remove the whole line if VPATH becomes empty
# (actually we leave an empty line to preserve line numbers).
if test "x$srcdir" = x.; then
  ac_vpsub='/^[	 ]*VPATH[	 ]*=/{
s/:*\$(srcdir):*/:/;
s/:*\${srcdir}:*/:/;
s/:*@srcdir@:*/:/;
s/^\([^=]*=[	 ]*\):*/\1/;
s/:*$//;
s/^[^=]*=[	 ]*$//;
}'
fi

# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
#
# If the first sed substitution is executed (which looks for macros that
# take arguments), then we branch to the quote section.  Otherwise,
# look for a macro that doesn't take arguments.
cat >confdef2opt.sed <<\_ACEOF
t clear
: clear
s,^[	 ]*#[	 ]*define[	 ][	 ]*\([^	 (][^	 (]*([^)]*)\)[	 ]*\(.*\),-D\1=\2,g
t quote
s,^[	 ]*#[	 ]*define[	 ][	 ]*\([^	 ][^	 ]*\)[	 ]*\(.*\),-D\1=\2,g
t quote
d
: quote
s,[	 `~#$^&*(){}\\|;'"<>?],\\&,g
s,\[,\\&,g
s,\],\\&,g
s,\$,$$,g
p
_ACEOF
# We use echo to avoid assuming a particular line-breaking character.
# The extra dot is to prevent the shell from consuming trailing
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357


ac_libobjs=
ac_ltlibobjs=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
  # 1. Remove the extension, and $U if already installed.
  ac_i=`echo "$ac_i" |
         sed 's/\$U\././;s/\.o$//;s/\.obj$//'`
  # 2. Add them.
  ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext"
  ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs

LTLIBOBJS=$ac_ltlibobjs







|







4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546


ac_libobjs=
ac_ltlibobjs=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
  # 1. Remove the extension, and $U if already installed.
  ac_i=`echo "$ac_i" |
	 sed 's/\$U\././;s/\.o$//;s/\.obj$//'`
  # 2. Add them.
  ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext"
  ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs

LTLIBOBJS=$ac_ltlibobjs
4387
4388
4389
4390
4391
4392
4393

4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi


# Support unset when possible.
if (FOO=FOO; unset FOO) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.







>


|


















|







4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
  NULLCMD=:
  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
  # is contrary to our usage.  Disable this feature.
  alias -g '${1+"$@"}'='"$@"'
elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
  set -o posix
fi
DUALCASE=1; export DUALCASE # for MKS sh

# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
  as_unset=unset
else
  as_unset=false
fi


# Work around bugs in pre-3.0 UWIN ksh.
$as_unset ENV MAIL MAILPATH
PS1='$ '
PS2='> '
PS4='+ '

# NLS nuisances.
for as_var in \
  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
  LC_TELEPHONE LC_TIME
do
  if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
    eval $as_var=C; export $as_var
  else
    $as_unset $as_var
  fi
done

# Required to use basename.
4587
4588
4589
4590
4591
4592
4593

4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else

  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"







>






|


|







4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
  as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.file

if mkdir -p . 2>/dev/null; then
  as_mkdir_p=:
else
  test -d ./-p && rmdir ./-p
  as_mkdir_p=false
fi

as_executable_p="test -f"

# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"

# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"


# IFS
# We need space, tab and new line, in precisely that order.
as_nl='
'
IFS=" 	$as_nl"
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
  sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
} >&5
cat >&5 <<_CSEOF

This file was extended by $as_me, which was
generated by GNU Autoconf 2.57.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@








|







4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
  sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
} >&5
cat >&5 <<_CSEOF

This file was extended by $as_me, which was
generated by GNU Autoconf 2.59.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@

4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696

  -h, --help       print this help, then exit
  -V, --version    print version number, then exit
  -q, --quiet      do not print progress messages
  -d, --debug      don't remove temporary files
      --recheck    update $as_me by reconfiguring in the same conditions
  --file=FILE[:TEMPLATE]
                   instantiate the configuration file FILE

Configuration files:
$config_files

Report bugs to <[email protected]>."
_ACEOF

cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
config.status
configured by $0, generated by GNU Autoconf 2.57,
  with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"

Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001
Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=$srcdir
_ACEOF

cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default







|










|


<
|







4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878

4879
4880
4881
4882
4883
4884
4885
4886

  -h, --help       print this help, then exit
  -V, --version    print version number, then exit
  -q, --quiet      do not print progress messages
  -d, --debug      don't remove temporary files
      --recheck    update $as_me by reconfiguring in the same conditions
  --file=FILE[:TEMPLATE]
		   instantiate the configuration file FILE

Configuration files:
$config_files

Report bugs to <[email protected]>."
_ACEOF

cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
config.status
configured by $0, generated by GNU Autoconf 2.59,
  with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"


Copyright (C) 2003 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
srcdir=$srcdir
_ACEOF

cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
      # The purpose of the label and of the branching condition is to
      # speed up the sed processing (if there are no `@' at all, there
      # is no need to browse any of the substitutions).
      # These are the two extra sed commands mentioned above.
      (echo ':t
  /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed
      if test -z "$ac_sed_cmds"; then
  	ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed"
      else
  	ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed"
      fi
      ac_sed_frag=`expr $ac_sed_frag + 1`
      ac_beg=$ac_end
      ac_end=`expr $ac_end + $ac_max_sed_lines`
    fi
  done
  if test -z "$ac_sed_cmds"; then
    ac_sed_cmds=cat
  fi
fi # test -n "$CONFIG_FILES"

_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue
  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
  case $ac_file in
  - | *:- | *:-:* ) # input from stdin
        cat >$tmp/stdin
        ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
        ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
        ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  * )   ac_file_in=$ac_file.in ;;
  esac

  # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
  ac_dir=`(dirname "$ac_file") 2>/dev/null ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
         X"$ac_file" : 'X\(//\)[^/]' \| \
         X"$ac_file" : 'X\(//\)$' \| \
         X"$ac_file" : 'X\(/\)' \| \
         .     : '\(.\)' 2>/dev/null ||
echo X"$ac_file" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  { if $as_mkdir_p; then
    mkdir -p "$ac_dir"
  else
    as_dir="$ac_dir"
    as_dirs=
    while test ! -d "$as_dir"; do
      as_dirs="$as_dir $as_dirs"
      as_dir=`(dirname "$as_dir") 2>/dev/null ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
         X"$as_dir" : 'X\(//\)[^/]' \| \
         X"$as_dir" : 'X\(//\)$' \| \
         X"$as_dir" : 'X\(/\)' \| \
         .     : '\(.\)' 2>/dev/null ||
echo X"$as_dir" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
    done







|

|

















|
|
|

|






|
|
|
|















|
|
|
|







5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
      # The purpose of the label and of the branching condition is to
      # speed up the sed processing (if there are no `@' at all, there
      # is no need to browse any of the substitutions).
      # These are the two extra sed commands mentioned above.
      (echo ':t
  /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed
      if test -z "$ac_sed_cmds"; then
	ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed"
      else
	ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed"
      fi
      ac_sed_frag=`expr $ac_sed_frag + 1`
      ac_beg=$ac_end
      ac_end=`expr $ac_end + $ac_max_sed_lines`
    fi
  done
  if test -z "$ac_sed_cmds"; then
    ac_sed_cmds=cat
  fi
fi # test -n "$CONFIG_FILES"

_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue
  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
  case $ac_file in
  - | *:- | *:-:* ) # input from stdin
	cat >$tmp/stdin
	ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
	ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
	ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
  * )   ac_file_in=$ac_file.in ;;
  esac

  # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
  ac_dir=`(dirname "$ac_file") 2>/dev/null ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$ac_file" : 'X\(//\)[^/]' \| \
	 X"$ac_file" : 'X\(//\)$' \| \
	 X"$ac_file" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$ac_file" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
  { if $as_mkdir_p; then
    mkdir -p "$ac_dir"
  else
    as_dir="$ac_dir"
    as_dirs=
    while test ! -d "$as_dir"; do
      as_dirs="$as_dir $as_dirs"
      as_dir=`(dirname "$as_dir") 2>/dev/null ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
	 X"$as_dir" : 'X\(//\)[^/]' \| \
	 X"$as_dir" : 'X\(//\)$' \| \
	 X"$as_dir" : 'X\(/\)' \| \
	 .     : '\(.\)' 2>/dev/null ||
echo X"$as_dir" |
    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
  	  /^X\(\/\/\)[^/].*/{ s//\1/; q; }
  	  /^X\(\/\/\)$/{ s//\1/; q; }
  	  /^X\(\/\).*/{ s//\1/; q; }
  	  s/.*/./; q'`
    done
5076
5077
5078
5079
5080
5081
5082
5083
5084





5085







5086






5087










5088





5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac
# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be
# absolute.





ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd`







ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd`






ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd`










ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd`








  if test x"$ac_file" != x-; then
    { echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
    rm -f "$ac_file"
  fi
  # Let's still pretend it is `configure' which instantiates (i.e., don't
  # use $as_me), people would be surprised to read:
  #    /* config.h.  Generated by config.status.  */
  if test x"$ac_file" = x-; then
    configure_input=
  else
    configure_input="$ac_file.  "
  fi
  configure_input=$configure_input"Generated from `echo $ac_file_in |
                                     sed 's,.*/,,'` by configure."

  # First look for the input files in the build tree, otherwise in the
  # src tree.
  ac_file_inputs=`IFS=:
    for f in $ac_file_in; do
      case $f in
      -) echo $tmp/stdin ;;
      [\\/$]*)
         # Absolute (can't be DOS-style, as IFS=:)
         test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
         echo $f;;
      *) # Relative
         if test -f "$f"; then
           # Build tree
           echo $f
         elif test -f "$srcdir/$f"; then
           # Source tree
           echo $srcdir/$f
         else
           # /dev/null tree
           { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
         fi;;
      esac
    done` || { (exit 1); exit 1; }
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
  sed "$ac_vpsub
$extrasub
_ACEOF







|
|
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>

















|








|
|


|

|
|
|
|
|
|
|
|
|


|







5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
  [\\/]* | ?:[\\/]* )  # Absolute path.
    ac_srcdir=$srcdir$ac_dir_suffix;
    ac_top_srcdir=$srcdir ;;
  *) # Relative path.
    ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
    ac_top_srcdir=$ac_top_builddir$srcdir ;;
esac

# Do not use `cd foo && pwd` to compute absolute paths, because
# the directories may not exist.
case `pwd` in
.) ac_abs_builddir="$ac_dir";;
*)
  case "$ac_dir" in
  .) ac_abs_builddir=`pwd`;;
  [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
  *) ac_abs_builddir=`pwd`/"$ac_dir";;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_builddir=${ac_top_builddir}.;;
*)
  case ${ac_top_builddir}. in
  .) ac_abs_top_builddir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
  *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_srcdir=$ac_srcdir;;
*)
  case $ac_srcdir in
  .) ac_abs_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
  *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
  esac;;
esac
case $ac_abs_builddir in
.) ac_abs_top_srcdir=$ac_top_srcdir;;
*)
  case $ac_top_srcdir in
  .) ac_abs_top_srcdir=$ac_abs_builddir;;
  [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
  *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
  esac;;
esac



  if test x"$ac_file" != x-; then
    { echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
    rm -f "$ac_file"
  fi
  # Let's still pretend it is `configure' which instantiates (i.e., don't
  # use $as_me), people would be surprised to read:
  #    /* config.h.  Generated by config.status.  */
  if test x"$ac_file" = x-; then
    configure_input=
  else
    configure_input="$ac_file.  "
  fi
  configure_input=$configure_input"Generated from `echo $ac_file_in |
				     sed 's,.*/,,'` by configure."

  # First look for the input files in the build tree, otherwise in the
  # src tree.
  ac_file_inputs=`IFS=:
    for f in $ac_file_in; do
      case $f in
      -) echo $tmp/stdin ;;
      [\\/$]*)
	 # Absolute (can't be DOS-style, as IFS=:)
	 test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
	 echo "$f";;
      *) # Relative
	 if test -f "$f"; then
	   # Build tree
	   echo "$f"
	 elif test -f "$srcdir/$f"; then
	   # Source tree
	   echo "$srcdir/$f"
	 else
	   # /dev/null tree
	   { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
echo "$as_me: error: cannot find input file: $f" >&2;}
   { (exit 1); exit 1; }; }
	 fi;;
      esac
    done` || { (exit 1); exit 1; }
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
  sed "$ac_vpsub
$extrasub
_ACEOF

Changes to win/configure.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
#! /bin/bash -norc
# This file is an input file used by the GNU "autoconf" program to
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.81 2004/06/11 20:25:25 dgp Exp $

AC_INIT(../generic/tcl.h)
AC_PREREQ(2.57)

# The following define is needed when building with Cygwin since newer
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh

TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a2"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION





|


|









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
#! /bin/bash -norc
# This file is an input file used by the GNU "autoconf" program to
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.81.2.5 2005/08/25 15:47:07 dgp Exp $

AC_INIT(../generic/tcl.h)
AC_PREREQ(2.59)

# The following define is needed when building with Cygwin since newer
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh

TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL="a4"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION

Changes to win/makefile.bc.

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
	-@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
	@echo installing library files
	-@copy "$(GENERICDIR)\tcl.h"         "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclDecls.h"    "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\init.tcl"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\ldAout.tcl"  "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\parray.tcl"  "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\safe.tcl"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\tclIndex"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\word.tcl"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\auto.tcl"    "$(SCRIPT_INSTALL_DIR)"








<







452
453
454
455
456
457
458

459
460
461
462
463
464
465
	-@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
	@echo installing library files
	-@copy "$(GENERICDIR)\tcl.h"         "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclDecls.h"    "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\init.tcl"    "$(SCRIPT_INSTALL_DIR)"

	-@copy "$(ROOT)\library\parray.tcl"  "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\safe.tcl"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\tclIndex"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\word.tcl"    "$(SCRIPT_INSTALL_DIR)"
	-@copy "$(ROOT)\library\auto.tcl"    "$(SCRIPT_INSTALL_DIR)"

Changes to win/makefile.vc.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17


18
19
20
21

22
23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
#------------------------------------------------------------------------------
# makefile.vc --
#
#	Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
# Copyright (c) 2001 ActiveState Corporation.
# Copyright (c) 2001-2004 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: makefile.vc,v 1.135 2004/10/27 20:53:38 davygrvy Exp $
#------------------------------------------------------------------------------



!if !defined(MSDEVDIR) && !defined(MSVCDIR)
MSG = ^
You'll need to run vcvars32.bat from Developer Studio, first, to setup^
the environment.  Jump to this line to read the new instructions.

!error $(MSG)
!endif

#------------------------------------------------------------------------------
# HOW TO USE this makefile:
#
# 1)  It is now necessary to have %MSDevDir% set in the environment.  This is used
#     as a check to see if vcvars32.bat had been run prior to running nmake or
#     during the installation of Microsoft Visual C++, MSDevDir had been set
#     globally and the PATH adjusted.  Either way is valid.

#
#     You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin
#     directory to setup the proper environment, if needed, for your current
#     setup.  This is a needed bootstrap requirement and allows the swapping of
#     different environments to be easier.
#
# 2)  To use the Platform SDK (not expressly needed), run setenv.bat after
#     vcvars32.bat according to the instructions for it.  This can also turn on
#     the 64-bit compiler, if your SDK has it.
#
# 3)  Targets are:
#	release  -- Builds the core, the shell and the dlls. (default)
#	dlls     -- Just builds the windows extensions and the 16-bit DOS
#		    pipe/thunk helper app.
#	shell    -- Just builds the shell and the core.
#	core     -- Only builds the core [tclXX.(dll|lib)].










|



|


>
>
|

|
|
>






|
|
|
|
>


|
|
|


|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#------------------------------------------------------------------------------
# makefile.vc --
#
#	Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
# Copyright (c) 2001-2005 ActiveState Corporation.
# Copyright (c) 2001-2004 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: makefile.vc,v 1.135.2.11 2005/09/23 16:47:35 dgp Exp $
#------------------------------------------------------------------------------

# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR)
# or with the MS Platform SDK (MSSDK)
!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK)
MSG = ^
You need to run vcvars32.bat from Developer Studio or setenv.bat from the^
Platform SDK first to setup the environment.  Jump to this line to read^
the build instructions.
!error $(MSG)
!endif

#------------------------------------------------------------------------------
# HOW TO USE this makefile:
#
# 1)  It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the
#     environment.  This is used as a check to see if vcvars32.bat had been
#     run prior to running nmake or during the installation of Microsoft
#     Visual C++, MSVCDir had been set globally and the PATH adjusted.
#     Either way is valid.
#
#     You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin
#     directory to setup the proper environment, if needed, for your
#     current setup.  This is a needed bootstrap requirement and allows the
#     swapping of different environments to be easier.
#
# 2)  To use the Platform SDK (not expressly needed), run setenv.bat after
#     vcvars32.bat according to the instructions for it.  This can also
#     turn on the 64-bit compiler, if your SDK has it.
#
# 3)  Targets are:
#	release  -- Builds the core, the shell and the dlls. (default)
#	dlls     -- Just builds the windows extensions and the 16-bit DOS
#		    pipe/thunk helper app.
#	shell    -- Just builds the shell and the core.
#	core     -- Only builds the core [tclXX.(dll|lib)].
276
277
278
279
280
281
282

283
284
285
286
287
288
289
	$(TMP_DIR)\tclIndexObj.obj \
	$(TMP_DIR)\tclInterp.obj \
	$(TMP_DIR)\tclIO.obj \
	$(TMP_DIR)\tclIOCmd.obj \
	$(TMP_DIR)\tclIOGT.obj \
	$(TMP_DIR)\tclIOSock.obj \
	$(TMP_DIR)\tclIOUtil.obj \

	$(TMP_DIR)\tclLink.obj \
	$(TMP_DIR)\tclListObj.obj \
	$(TMP_DIR)\tclLiteral.obj \
	$(TMP_DIR)\tclLoad.obj \
	$(TMP_DIR)\tclMain.obj \
	$(TMP_DIR)\tclNamesp.obj \
	$(TMP_DIR)\tclNotify.obj \







>







280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
	$(TMP_DIR)\tclIndexObj.obj \
	$(TMP_DIR)\tclInterp.obj \
	$(TMP_DIR)\tclIO.obj \
	$(TMP_DIR)\tclIOCmd.obj \
	$(TMP_DIR)\tclIOGT.obj \
	$(TMP_DIR)\tclIOSock.obj \
	$(TMP_DIR)\tclIOUtil.obj \
	$(TMP_DIR)\tclIORChan.obj \
	$(TMP_DIR)\tclLink.obj \
	$(TMP_DIR)\tclListObj.obj \
	$(TMP_DIR)\tclLiteral.obj \
	$(TMP_DIR)\tclLoad.obj \
	$(TMP_DIR)\tclMain.obj \
	$(TMP_DIR)\tclNamesp.obj \
	$(TMP_DIR)\tclNotify.obj \
299
300
301
302
303
304
305

306
307
308
309
310
311
312

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330





























































331
332
333
334
335
336
337
338
339
340

341
342
343
344
345
346
347
	$(TMP_DIR)\tclPreserve.obj \
	$(TMP_DIR)\tclProc.obj \
	$(TMP_DIR)\tclRegexp.obj \
	$(TMP_DIR)\tclResolve.obj \
	$(TMP_DIR)\tclResult.obj \
	$(TMP_DIR)\tclScan.obj \
	$(TMP_DIR)\tclStringObj.obj \

	$(TMP_DIR)\tclStubInit.obj \
	$(TMP_DIR)\tclStubLib.obj \
	$(TMP_DIR)\tclThread.obj \
	$(TMP_DIR)\tclThreadAlloc.obj \
	$(TMP_DIR)\tclThreadJoin.obj \
	$(TMP_DIR)\tclThreadStorage.obj \
	$(TMP_DIR)\tclTimer.obj \

	$(TMP_DIR)\tclTrace.obj \
	$(TMP_DIR)\tclUtf.obj \
	$(TMP_DIR)\tclUtil.obj \
	$(TMP_DIR)\tclVar.obj \
	$(TMP_DIR)\tclWin32Dll.obj \
	$(TMP_DIR)\tclWinChan.obj \
	$(TMP_DIR)\tclWinConsole.obj \
	$(TMP_DIR)\tclWinSerial.obj \
	$(TMP_DIR)\tclWinError.obj \
	$(TMP_DIR)\tclWinFCmd.obj \
	$(TMP_DIR)\tclWinFile.obj \
	$(TMP_DIR)\tclWinInit.obj \
	$(TMP_DIR)\tclWinLoad.obj \
	$(TMP_DIR)\tclWinNotify.obj \
	$(TMP_DIR)\tclWinPipe.obj \
	$(TMP_DIR)\tclWinSock.obj \
	$(TMP_DIR)\tclWinThrd.obj \
	$(TMP_DIR)\tclWinTime.obj \





























































!if !$(STATIC_BUILD)
	$(TMP_DIR)\tcl.res
!endif

TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj

### The following paths CANNOT have spaces in them.
COMPATDIR	= $(ROOT)\compat
DOCDIR		= $(ROOT)\doc
GENERICDIR	= $(ROOT)\generic

TOOLSDIR	= $(ROOT)\tools
WINDIR		= $(ROOT)\win


#---------------------------------------------------------------------
# Compile flags
#---------------------------------------------------------------------







>







>


















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










>







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
	$(TMP_DIR)\tclPreserve.obj \
	$(TMP_DIR)\tclProc.obj \
	$(TMP_DIR)\tclRegexp.obj \
	$(TMP_DIR)\tclResolve.obj \
	$(TMP_DIR)\tclResult.obj \
	$(TMP_DIR)\tclScan.obj \
	$(TMP_DIR)\tclStringObj.obj \
	$(TMP_DIR)\tclStrToD.obj \
	$(TMP_DIR)\tclStubInit.obj \
	$(TMP_DIR)\tclStubLib.obj \
	$(TMP_DIR)\tclThread.obj \
	$(TMP_DIR)\tclThreadAlloc.obj \
	$(TMP_DIR)\tclThreadJoin.obj \
	$(TMP_DIR)\tclThreadStorage.obj \
	$(TMP_DIR)\tclTimer.obj \
	$(TMP_DIR)\tclTomMathInterface.obj \
	$(TMP_DIR)\tclTrace.obj \
	$(TMP_DIR)\tclUtf.obj \
	$(TMP_DIR)\tclUtil.obj \
	$(TMP_DIR)\tclVar.obj \
	$(TMP_DIR)\tclWin32Dll.obj \
	$(TMP_DIR)\tclWinChan.obj \
	$(TMP_DIR)\tclWinConsole.obj \
	$(TMP_DIR)\tclWinSerial.obj \
	$(TMP_DIR)\tclWinError.obj \
	$(TMP_DIR)\tclWinFCmd.obj \
	$(TMP_DIR)\tclWinFile.obj \
	$(TMP_DIR)\tclWinInit.obj \
	$(TMP_DIR)\tclWinLoad.obj \
	$(TMP_DIR)\tclWinNotify.obj \
	$(TMP_DIR)\tclWinPipe.obj \
	$(TMP_DIR)\tclWinSock.obj \
	$(TMP_DIR)\tclWinThrd.obj \
	$(TMP_DIR)\tclWinTime.obj \
	$(TMP_DIR)\bncore.obj \
	$(TMP_DIR)\bn_reverse.obj \
	$(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \
	$(TMP_DIR)\bn_fast_s_mp_sqr.obj \
	$(TMP_DIR)\bn_mp_add.obj \
	$(TMP_DIR)\bn_mp_add_d.obj \
	$(TMP_DIR)\bn_mp_and.obj \
	$(TMP_DIR)\bn_mp_clamp.obj \
	$(TMP_DIR)\bn_mp_clear.obj \
	$(TMP_DIR)\bn_mp_clear_multi.obj \
	$(TMP_DIR)\bn_mp_cmp.obj \
	$(TMP_DIR)\bn_mp_cmp_d.obj \
	$(TMP_DIR)\bn_mp_cmp_mag.obj \
	$(TMP_DIR)\bn_mp_copy.obj \
	$(TMP_DIR)\bn_mp_count_bits.obj \
	$(TMP_DIR)\bn_mp_div.obj \
	$(TMP_DIR)\bn_mp_div_d.obj \
	$(TMP_DIR)\bn_mp_div_2.obj \
	$(TMP_DIR)\bn_mp_div_2d.obj \
	$(TMP_DIR)\bn_mp_div_3.obj \
	$(TMP_DIR)\bn_mp_exch.obj \
	$(TMP_DIR)\bn_mp_expt_d.obj \
	$(TMP_DIR)\bn_mp_grow.obj \
	$(TMP_DIR)\bn_mp_init.obj \
	$(TMP_DIR)\bn_mp_init_copy.obj \
	$(TMP_DIR)\bn_mp_init_multi.obj \
	$(TMP_DIR)\bn_mp_init_set.obj \
	$(TMP_DIR)\bn_mp_init_size.obj \
	$(TMP_DIR)\bn_mp_karatsuba_mul.obj \
	$(TMP_DIR)\bn_mp_karatsuba_sqr.obj \
	$(TMP_DIR)\bn_mp_lshd.obj \
	$(TMP_DIR)\bn_mp_mod.obj \
	$(TMP_DIR)\bn_mp_mod_2d.obj \
	$(TMP_DIR)\bn_mp_mul.obj \
	$(TMP_DIR)\bn_mp_mul_2.obj \
	$(TMP_DIR)\bn_mp_mul_2d.obj \
	$(TMP_DIR)\bn_mp_mul_d.obj \
	$(TMP_DIR)\bn_mp_neg.obj \
	$(TMP_DIR)\bn_mp_or.obj \
	$(TMP_DIR)\bn_mp_radix_size.obj \
	$(TMP_DIR)\bn_mp_radix_smap.obj \
	$(TMP_DIR)\bn_mp_read_radix.obj \
	$(TMP_DIR)\bn_mp_rshd.obj \
	$(TMP_DIR)\bn_mp_set.obj \
	$(TMP_DIR)\bn_mp_shrink.obj \
	$(TMP_DIR)\bn_mp_sqr.obj \
	$(TMP_DIR)\bn_mp_sqrt.obj \
	$(TMP_DIR)\bn_mp_sub.obj \
	$(TMP_DIR)\bn_mp_sub_d.obj \
	$(TMP_DIR)\bn_mp_to_unsigned_bin.obj \
	$(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \
	$(TMP_DIR)\bn_mp_toom_mul.obj \
	$(TMP_DIR)\bn_mp_toom_sqr.obj \
	$(TMP_DIR)\bn_mp_toradix_n.obj \
	$(TMP_DIR)\bn_mp_unsigned_bin_size.obj \
	$(TMP_DIR)\bn_mp_xor.obj \
	$(TMP_DIR)\bn_mp_zero.obj \
	$(TMP_DIR)\bn_s_mp_add.obj \
	$(TMP_DIR)\bn_s_mp_mul_digs.obj \
	$(TMP_DIR)\bn_s_mp_sqr.obj \
	$(TMP_DIR)\bn_s_mp_sub.obj \
!if !$(STATIC_BUILD)
	$(TMP_DIR)\tcl.res
!endif

TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj

### The following paths CANNOT have spaces in them.
COMPATDIR	= $(ROOT)\compat
DOCDIR		= $(ROOT)\doc
GENERICDIR	= $(ROOT)\generic
TOMMATHDIR	= $(ROOT)\libtommath
TOOLSDIR	= $(ROOT)\tools
WINDIR		= $(ROOT)\win


#---------------------------------------------------------------------
# Compile flags
#---------------------------------------------------------------------
388
389
390
391
392
393
394
395
396
397

398
399
400
401
402
403
404
!if $(DEBUG) && !$(UNCHECKED)
crt = -MTd
!else
crt = -MT
!endif
!endif

TCL_INCLUDES	= -I"$(WINDIR)" -I"$(GENERICDIR)"
BASE_CFLAGS	= $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) \
			-DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\"

CON_CFLAGS	= $(cflags) $(cdebug) $(crt) -DCONSOLE
TCL_CFLAGS	= $(BASE_CFLAGS) $(OPTDEFINES)
STUB_CFLAGS     = $(cflags) $(cdebug) $(OPTDEFINES)


#---------------------------------------------------------------------
# Link flags







|

|
>







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
!if $(DEBUG) && !$(UNCHECKED)
crt = -MTd
!else
crt = -MT
!endif
!endif

TCL_INCLUDES	= -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)"
BASE_CFLAGS	= $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) \
			-DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH \
			-DMP_PREC=4
CON_CFLAGS	= $(cflags) $(cdebug) $(crt) -DCONSOLE
TCL_CFLAGS	= $(BASE_CFLAGS) $(OPTDEFINES)
STUB_CFLAGS     = $(cflags) $(cdebug) $(OPTDEFINES)


#---------------------------------------------------------------------
# Link flags
831
832
833
834
835
836
837





838
839
840
841
842
843
844
# Implicit rules
#---------------------------------------------------------------------

{$(WINDIR)}.c{$(TMP_DIR)}.obj::
    $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
$<
<<






{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
    $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
$<
<<

{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::







>
>
>
>
>







901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
# Implicit rules
#---------------------------------------------------------------------

{$(WINDIR)}.c{$(TMP_DIR)}.obj::
    $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
$<
<<

{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj::
    $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
$<
<<

{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
    $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
$<
<<

{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
	@$(CPY) "$(GENERICDIR)\tcl.h"          "$(INCLUDE_INSTALL_DIR)\"
	@$(CPY) "$(GENERICDIR)\tclDecls.h"     "$(INCLUDE_INSTALL_DIR)\"
	@$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\history.tcl"  "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\init.tcl"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\clock.tcl"    "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\tm.tcl"       "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\ldAout.tcl"   "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\parray.tcl"   "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\safe.tcl"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\tclIndex"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\package.tcl"  "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\word.tcl"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\auto.tcl"     "$(SCRIPT_INSTALL_DIR)\"








<







995
996
997
998
999
1000
1001

1002
1003
1004
1005
1006
1007
1008
	@$(CPY) "$(GENERICDIR)\tcl.h"          "$(INCLUDE_INSTALL_DIR)\"
	@$(CPY) "$(GENERICDIR)\tclDecls.h"     "$(INCLUDE_INSTALL_DIR)\"
	@$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\history.tcl"  "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\init.tcl"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\clock.tcl"    "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\tm.tcl"       "$(SCRIPT_INSTALL_DIR)\"

	@$(CPY) "$(ROOT)\library\parray.tcl"   "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\safe.tcl"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\tclIndex"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\package.tcl"  "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\word.tcl"     "$(SCRIPT_INSTALL_DIR)\"
	@$(CPY) "$(ROOT)\library\auto.tcl"     "$(SCRIPT_INSTALL_DIR)\"

Changes to win/rules.vc.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#------------------------------------------------------------------------------
# rules.vc --
#
#	Microsoft Visual C++ makefile include for decoding the commandline
#	macros.  This file does not need editing to build Tcl.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2001-2003 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: rules.vc,v 1.19 2004/06/24 01:29:07 mistachkin Exp $
#------------------------------------------------------------------------------

!ifndef _RULES_VC
_RULES_VC = 1

cc32		= $(CC)   # built-in default.
link32		= link












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#------------------------------------------------------------------------------
# rules.vc --
#
#	Microsoft Visual C++ makefile include for decoding the commandline
#	macros.  This file does not need editing to build Tcl.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2001-2003 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: rules.vc,v 1.19.2.3 2005/08/15 18:14:15 dgp Exp $
#------------------------------------------------------------------------------

!ifndef _RULES_VC
_RULES_VC = 1

cc32		= $(CC)   # built-in default.
link32		= link
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
!endif
!if [nmakehlp -f $(OPTS) "thrdalloc"]
!message *** Doing thrdalloc
USE_THREAD_ALLOC = 1
!else
USE_THREAD_ALLOC = 0
!endif
!if [nmakehlp -f $(OPTS) "thrdstorage"]
!message *** Doing thrdstorage
USE_THREAD_STORAGE = 1
!else
USE_THREAD_STORAGE = 0
!endif
!if [nmakehlp -f $(OPTS) "unchecked"]
!message *** Doing unchecked
UNCHECKED = 1
!else
UNCHECKED = 0
!endif
!endif







<
<
<
<
<
<







175
176
177
178
179
180
181






182
183
184
185
186
187
188
!endif
!if [nmakehlp -f $(OPTS) "thrdalloc"]
!message *** Doing thrdalloc
USE_THREAD_ALLOC = 1
!else
USE_THREAD_ALLOC = 0
!endif






!if [nmakehlp -f $(OPTS) "unchecked"]
!message *** Doing unchecked
UNCHECKED = 1
!else
UNCHECKED = 0
!endif
!endif
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
OPTDEFINES	= $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS)
OPTDEFINES	= $(OPTDEFINES) -DTCL_THREADS=1
!if $(USE_THREAD_ALLOC)
OPTDEFINES	= $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
!endif
!if $(USE_THREAD_STORAGE)
OPTDEFINES	= $(OPTDEFINES) -DUSE_THREAD_STORAGE=1
!endif
!endif
!if $(STATIC_BUILD)
OPTDEFINES	= $(OPTDEFINES) -DSTATIC_BUILD
!endif
!if $(TCL_NO_DEPRECATED)
OPTDEFINES	= $(OPTDEFINES) -DTCL_NO_DEPRECATED
!endif







<
<
<







319
320
321
322
323
324
325



326
327
328
329
330
331
332
OPTDEFINES	= $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS)
OPTDEFINES	= $(OPTDEFINES) -DTCL_THREADS=1
!if $(USE_THREAD_ALLOC)
OPTDEFINES	= $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
!endif



!endif
!if $(STATIC_BUILD)
OPTDEFINES	= $(OPTDEFINES) -DSTATIC_BUILD
!endif
!if $(TCL_NO_DEPRECATED)
OPTDEFINES	= $(OPTDEFINES) -DTCL_NO_DEPRECATED
!endif

Changes to win/tcl.m4.

253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
    if test "$tcl_ok" = "yes"; then
	AC_MSG_RESULT(yes)
	TCL_THREADS=1
	AC_DEFINE(TCL_THREADS)
	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention
	AC_DEFINE(USE_THREAD_ALLOC)
	# USE_THREAD_STORAGE tells us to use the new generic thread 
	# storage subsystem. 
	AC_DEFINE(USE_THREAD_STORAGE)
    else
	TCL_THREADS=0
	AC_MSG_RESULT([no (default)])
    fi
    AC_SUBST(TCL_THREADS)
])








<
<
<







253
254
255
256
257
258
259



260
261
262
263
264
265
266
    if test "$tcl_ok" = "yes"; then
	AC_MSG_RESULT(yes)
	TCL_THREADS=1
	AC_DEFINE(TCL_THREADS)
	# USE_THREAD_ALLOC tells us to try the special thread-based
	# allocator that significantly reduces lock contention
	AC_DEFINE(USE_THREAD_ALLOC)



    else
	TCL_THREADS=0
	AC_MSG_RESULT([no (default)])
    fi
    AC_SUBST(TCL_THREADS)
])

435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
    if test "${GCC}" = "yes" ; then
	if test "$do64bit" = "yes" ; then
	    AC_MSG_WARN("64bit mode not supported with GCC on Windows")
	fi
	SHLIB_LD=""
	SHLIB_LD_LIBS=""
	LIBS=""
	LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32"
	STLIB_LD='${AR} cr'
	RC_OUT=-o
	RC_TYPE=
	RC_INCLUDE=--include
	RC_DEFINE=--define
	RES=res.o
	MAKE_LIB="\${STLIB_LD} \[$]@"







|







432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
    if test "${GCC}" = "yes" ; then
	if test "$do64bit" = "yes" ; then
	    AC_MSG_WARN("64bit mode not supported with GCC on Windows")
	fi
	SHLIB_LD=""
	SHLIB_LD_LIBS=""
	LIBS=""
	LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -lole32 -loleaut32 -luuid"
	STLIB_LD='${AR} cr'
	RC_OUT=-o
	RC_TYPE=
	RC_INCLUDE=--include
	RC_DEFINE=--define
	RES=res.o
	MAKE_LIB="\${STLIB_LD} \[$]@"
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
	# users of tclConfig.sh that may build shared or static.
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE=-O
	CFLAGS_WARNING="-Wall -Wconversion"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \[$]@"
	CC_EXENAME="-o \[$]@"







|







512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
	# users of tclConfig.sh that may build shared or static.
	DLLSUFFIX="\${DBGX}.dll"
	SHLIB_SUFFIX=.dll

	EXTRA_CFLAGS="${extra_cflags}"

	CFLAGS_DEBUG=-g
	CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
	CFLAGS_WARNING="-Wall -Wconversion"
	LDFLAGS_DEBUG=
	LDFLAGS_OPTIMIZE=

	# Specify the CC output file names based on the target name
	CC_OBJNAME="-o \[$]@"
	CC_EXENAME="-o \[$]@"
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590



591
592
593
594
595
596
597

598
599
600
601
602
603
604


605

606
607
608
609
610
611
612
613



614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633

	# This is a 2-stage check to make sure we have the 64-bit SDK
	# We have to know where the SDK is installed.
	if test "$do64bit" = "yes" ; then
	    if test "x${MSSDK}x" = "xx" ; then
		MSSDK="C:/Progra~1/Microsoft SDK"
	    fi
	    # In order to work in the tortured autoconf environment,
	    # we need to ensure that this path has no spaces
	    MSSDK=$(cygpath -w -s "$MSSDK" | sed -e 's!\\!/!g')
	    if test ! -d "${MSSDK}/bin/win64" ; then
		AC_MSG_WARN("could not find 64-bit SDK to enable 64bit mode")
		do64bit="no"
	    fi
	fi

	if test "$do64bit" = "yes" ; then
	    # All this magic is necessary for the Win64 SDK RC1 - hobbs



	    CC="${MSSDK}/Bin/Win64/cl.exe \
	-I${MSSDK}/Include/prerelease \
	-I${MSSDK}/Include/Win64/crt \
	-I${MSSDK}/Include/Win64/crt/sys \
	-I${MSSDK}/Include"
	    RC="${MSSDK}/bin/rc.exe"
	    CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"

	    CFLAGS_OPTIMIZE="-nologo -O2 -Gs ${runtime}"
	    lflags="-MACHINE:IA64 -LIBPATH:${MSSDK}/Lib/IA64 \
	-LIBPATH:${MSSDK}/Lib/Prerelease/IA64"
	    STLIB_LD="${MSSDK}/bin/win64/lib.exe -nologo ${lflags}"
	    LINKBIN="${MSSDK}/bin/win64/link.exe ${lflags}"
	else
	    RC="rc"


	    CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"

	    CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
	    STLIB_LD="lib -nologo"
	    LINKBIN="link -link50compat"
	fi

	SHLIB_LD="${LINKBIN} -dll -nologo -incremental:no"
	LIBS="user32.lib advapi32.lib"
	LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib"



	RC_OUT=-fo
	RC_TYPE=-r
	RC_INCLUDE=-i
	RC_DEFINE=-d
	RES=res
	MAKE_LIB="\${STLIB_LD} -out:\[$]@"
	POST_MAKE_LIB=
	MAKE_EXE="\${CC} -Fe\[$]@"
	LIBPREFIX=""

	EXTRA_CFLAGS="-YX"
	CFLAGS_WARNING="-W3"
	LDFLAGS_DEBUG="-debug:full -debugtype:both"
	LDFLAGS_OPTIMIZE="-release"
	
	# Specify the CC output file names based on the target name
	CC_OBJNAME="-Fo\[$]@"
	CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\""

	# Specify linker flags depending on the type of app being 







<
<
|








>
>
>
|
|
|
|
|
|

>
|
|
|
<
|


>
>

>
|
|
|


<

|
>
>
>










|

|







570
571
572
573
574
575
576


577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599

600
601
602
603
604
605
606
607
608
609
610
611

612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636

	# This is a 2-stage check to make sure we have the 64-bit SDK
	# We have to know where the SDK is installed.
	if test "$do64bit" = "yes" ; then
	    if test "x${MSSDK}x" = "xx" ; then
		MSSDK="C:/Progra~1/Microsoft SDK"
	    fi


	    MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'`
	    if test ! -d "${MSSDK}/bin/win64" ; then
		AC_MSG_WARN("could not find 64-bit SDK to enable 64bit mode")
		do64bit="no"
	    fi
	fi

	if test "$do64bit" = "yes" ; then
	    # All this magic is necessary for the Win64 SDK RC1 - hobbs
	    # The space-based-path will work for the Makefile, but will
	    # not work if AC_TRY_COMPILE is called.  TEA has the
	    # TEA_PATH_NOSPACE to avoid this issue.
	    CC="\"${MSSDK}/Bin/Win64/cl.exe\" \
		-I\"${MSSDK}/Include/prerelease\" \
		-I\"${MSSDK}/Include/Win64/crt\" \
		-I\"${MSSDK}/Include/Win64/crt/sys\" \
		-I\"${MSSDK}/Include\""
	    RC="\"${MSSDK}/bin/rc.exe\""
	    CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
	    # Do not use -O2 for Win64 - this has proved buggy in code gen.
	    CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}"
	    lflags="-MACHINE:IA64 -LIBPATH:\"${MSSDK}/Lib/IA64\" \
		-LIBPATH:\"${MSSDK}/Lib/Prerelease/IA64\" -nologo"

	    LINKBIN="\"${MSSDK}/bin/win64/link.exe\""
	else
	    RC="rc"
	    # -Od - no optimization
	    # -WX - warnings as errors
	    CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
	    # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy)
	    CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}"
	    lflags="-nologo"
	    LINKBIN="link"
	fi


	LIBS="user32.lib advapi32.lib"
	LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib"
	SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
	# link -lib only works when -lib is the first arg
	STLIB_LD="${LINKBIN} -lib ${lflags}"
	RC_OUT=-fo
	RC_TYPE=-r
	RC_INCLUDE=-i
	RC_DEFINE=-d
	RES=res
	MAKE_LIB="\${STLIB_LD} -out:\[$]@"
	POST_MAKE_LIB=
	MAKE_EXE="\${CC} -Fe\[$]@"
	LIBPREFIX=""

	EXTRA_CFLAGS=""
	CFLAGS_WARNING="-W3"
	LDFLAGS_DEBUG="-debug:full"
	LDFLAGS_OPTIMIZE="-release"
	
	# Specify the CC output file names based on the target name
	CC_OBJNAME="-Fo\[$]@"
	CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\""

	# Specify linker flags depending on the type of app being 
680
681
682
683
684
685
686
687
688
689
690
691
692
693




694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
























739
740
741
742
743
744
745
	AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR:  perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
    else
	echo "building against Tcl binaries in: $TCL_BIN_DIR"
    fi
    AC_SUBST(TCL_BIN_DIR)
])

# FIXME : SC_PROG_TCLSH should really look for the installed tclsh and
# not the build version. If we want to use the build version in the
# tk script, it is better to hardcode that!

#------------------------------------------------------------------------
# SC_PROG_TCLSH
#	Locate a tclsh shell in the following directories:




#		${exec_prefix}/bin
#		${prefix}/bin
#		${TCL_BIN_DIR}
#		${TCL_BIN_DIR}/../bin
#		${PATH}
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN(SC_PROG_TCLSH, [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [
	search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \
		    `ls -r $dir/tclsh* 2> /dev/null` ; do
		if test x"$ac_cv_path_tclsh" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_tclsh=$j
			break
		    fi
		fi
	    done
	done
    ])

    if test -f "$ac_cv_path_tclsh" ; then
	TCLSH_PROG="$ac_cv_path_tclsh"
	AC_MSG_RESULT($TCLSH_PROG)
    elif test -f "$TCL_BIN_DIR/tclConfig.sh" ; then
	# One-tree build.
	ac_cv_path_tclsh="$TCL_BIN_DIR/tclsh"
	TCLSH_PROG="$ac_cv_path_tclsh"
	AC_MSG_RESULT($TCLSH_PROG)
    else
	AC_MSG_ERROR(No tclsh found in PATH:  $search_path)
    fi
    AC_SUBST(TCLSH_PROG)
])

























#--------------------------------------------------------------------
# SC_TCL_CFG_ENCODING	TIP #59
#
#	Declare the encoding to use for embedded configuration information.
#
# Arguments:







<
<
<
<


|
>
>
>
>
|
|
|
<
|













|
















|
|
<
|
|
<
<



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







683
684
685
686
687
688
689




690
691
692
693
694
695
696
697
698
699

700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732

733
734


735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
	AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR:  perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
    else
	echo "building against Tcl binaries in: $TCL_BIN_DIR"
    fi
    AC_SUBST(TCL_BIN_DIR)
])





#------------------------------------------------------------------------
# SC_PROG_TCLSH
#	Locate a tclsh shell installed on the system path. This macro
#	will only find a Tcl shell that already exists on the system.
#	It will not find a Tcl shell in the Tcl build directory or
#	a Tcl shell that has been installed from the Tcl build directory.
#	If a Tcl shell can't be located on the PATH, then TCLSH_PROG will
#	be set to "". Extensions should take care not to create Makefile
#	rules that are run by default and depend on TCLSH_PROG. An
#	extension can't assume that an executable Tcl shell exists at

#	build time.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN(SC_PROG_TCLSH, [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [
	search_path=`echo ${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \
		    `ls -r $dir/tclsh* 2> /dev/null` ; do
		if test x"$ac_cv_path_tclsh" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_tclsh=$j
			break
		    fi
		fi
	    done
	done
    ])

    if test -f "$ac_cv_path_tclsh" ; then
	TCLSH_PROG="$ac_cv_path_tclsh"
	AC_MSG_RESULT($TCLSH_PROG)
    else
	# It is not an error if an installed version of Tcl can't be located.

	TCLSH_PROG=""
	AC_MSG_RESULT([No tclsh found on PATH])


    fi
    AC_SUBST(TCLSH_PROG)
])

#------------------------------------------------------------------------
# SC_BUILD_TCLSH
#	Determine the fully qualified path name of the tclsh executable
#	in the Tcl build directory. This macro will correctly determine
#	the name of the tclsh executable even if tclsh has not yet
#	been built in the build directory. The build tclsh must be used
#	when running tests from an extension build directory. It is not
#	correct to use the TCLSH_PROG in cases like this.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		BUILD_TCLSH
#------------------------------------------------------------------------

AC_DEFUN(SC_BUILD_TCLSH, [
    AC_MSG_CHECKING([for tclsh in Tcl build directory])
    BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}
    AC_MSG_RESULT($BUILD_TCLSH)
    AC_SUBST(BUILD_TCLSH)
])

#--------------------------------------------------------------------
# SC_TCL_CFG_ENCODING	TIP #59
#
#	Declare the encoding to use for embedded configuration information.
#
# Arguments:

Changes to win/tclAppInit.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
/*
 * tclAppInit.c --
 *
 *	Provides a default version of the main program and Tcl_AppInit
 *	procedure for Tcl applications (without Tk).  Note that this
 *	program must be built in Win32 console mode to work properly.
 *
 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAppInit.c,v 1.21 2004/10/28 04:53:42 davygrvy Exp $
 */

#include "tcl.h"
#include <windows.h>
#include <locale.h>

#ifdef TCL_TEST
extern Tcl_PackageInitProc	Procbodytest_Init;
extern Tcl_PackageInitProc	Procbodytest_SafeInit;
extern Tcl_PackageInitProc	Tcltest_Init;
extern Tcl_PackageInitProc	TclObjTest_Init;
#endif /* TCL_TEST */

#if defined(__GNUC__)
static void		setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
#endif /* __GNUC__ */
static BOOL WINAPI	sigHandler (DWORD fdwCtrlType);
static Tcl_AsyncProc	asyncExit;
static void		AppInitExitHandler(ClientData clientData);

static Tcl_AsyncHandler exitToken = NULL;
static DWORD            exitErrorCode = 0;


/*
 *----------------------------------------------------------------------
 *
 * main --
 *
 *	This is the main program for the application.
 *
 * Results:
 *	None: Tcl_Main never returns here, so this procedure never
 *	returns either.
 *
 * Side effects:
 *	Whatever the application does.
 *
 *----------------------------------------------------------------------
 */

int
main (int argc, char *argv[])
{
    /*
     * The following #if block allows you to change the AppInit
     * function by using a #define of TCL_LOCAL_APPINIT instead
     * of rewriting this entire file.  The #if checks for that
     * #define and uses Tcl_AppInit if it doesn't exist.
     */

#ifndef TCL_LOCAL_APPINIT
#define TCL_LOCAL_APPINIT Tcl_AppInit
#endif
    extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));

    /*
     * The following #if block allows you to change how Tcl finds the startup
     * script, prime the library or encoding paths, fiddle with the argv,
     * etc., without needing to rewrite Tcl_Main()
     */

#ifdef TCL_LOCAL_MAIN_HOOK
    extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
#endif

    char *p;

    /*
     * Set up the default locale to be standard "C" locale so parsing
     * is performed correctly.
     */

#if defined(__GNUC__)
    setargv( &argc, &argv );
#endif
    setlocale(LC_ALL, "C");





|
|




|
|

|














|

|




|










|
|








|


|
|
|
|




















|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
/*
 * tclAppInit.c --
 *
 *	Provides a default version of the main program and Tcl_AppInit
 *	function for Tcl applications (without Tk). Note that this program
 *	must be built in Win32 console mode to work properly.
 *
 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAppInit.c,v 1.21.2.1 2005/08/02 18:17:00 dgp Exp $
 */

#include "tcl.h"
#include <windows.h>
#include <locale.h>

#ifdef TCL_TEST
extern Tcl_PackageInitProc	Procbodytest_Init;
extern Tcl_PackageInitProc	Procbodytest_SafeInit;
extern Tcl_PackageInitProc	Tcltest_Init;
extern Tcl_PackageInitProc	TclObjTest_Init;
#endif /* TCL_TEST */

#if defined(__GNUC__)
static void		setargv(int *argcPtr, char ***argvPtr);
#endif /* __GNUC__ */
static BOOL WINAPI	sigHandler(DWORD fdwCtrlType);
static Tcl_AsyncProc	asyncExit;
static void		AppInitExitHandler(ClientData clientData);

static Tcl_AsyncHandler exitToken = NULL;
static DWORD		exitErrorCode = 0;


/*
 *----------------------------------------------------------------------
 *
 * main --
 *
 *	This is the main program for the application.
 *
 * Results:
 *	None: Tcl_Main never returns here, so this function never returns
 *	either.
 *
 * Side effects:
 *	Whatever the application does.
 *
 *----------------------------------------------------------------------
 */

int
main(int argc, char *argv[])
{
    /*
     * The following #if block allows you to change the AppInit function by
     * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire
     * file. The #if checks for that #define and uses Tcl_AppInit if it
     * doesn't exist.
     */

#ifndef TCL_LOCAL_APPINIT
#define TCL_LOCAL_APPINIT Tcl_AppInit
#endif
    extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));

    /*
     * The following #if block allows you to change how Tcl finds the startup
     * script, prime the library or encoding paths, fiddle with the argv,
     * etc., without needing to rewrite Tcl_Main()
     */

#ifdef TCL_LOCAL_MAIN_HOOK
    extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
#endif

    char *p;

    /*
     * Set up the default locale to be standard "C" locale so parsing is
     * performed correctly.
     */

#if defined(__GNUC__)
    setargv( &argc, &argv );
#endif
    setlocale(LC_ALL, "C");

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141

142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppInit --
 *
 *	This procedure performs application-specific initialization.
 *	Most applications, especially those that incorporate additional
 *	packages, will have their own version of this procedure.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error
 *	message in the interp's result if an error occurs.
 *
 * Side effects:
 *	Depends on the startup script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppInit(interp)
    Tcl_Interp *interp;		/* Interpreter for application. */
{
    if (Tcl_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

    /*
     * Install a signal handler to the win32 console tclsh is running in.
     */

    SetConsoleCtrlHandler(sigHandler, TRUE);
    exitToken = Tcl_AsyncCreate(asyncExit, NULL);

    /*
     * This exit handler will be used to free the
     * resources allocated in this file.
     */

    Tcl_CreateExitHandler(AppInitExitHandler, NULL);

#ifdef TCL_TEST
    if (Tcltest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL);
    if (TclObjTest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (Procbodytest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
            Procbodytest_SafeInit);
#endif /* TCL_TEST */

#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
    {
	extern Tcl_PackageInitProc Registry_Init;
	extern Tcl_PackageInitProc Dde_Init;
	extern Tcl_PackageInitProc Dde_SafeInit;







|
|
|


|
|


















>




|
|

>














|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppInit --
 *
 *	This function performs application-specific initialization. Most
 *	applications, especially those that incorporate additional packages,
 *	will have their own version of this function.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error message in
 *	the interp's result if an error occurs.
 *
 * Side effects:
 *	Depends on the startup script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppInit(interp)
    Tcl_Interp *interp;		/* Interpreter for application. */
{
    if (Tcl_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

    /*
     * Install a signal handler to the win32 console tclsh is running in.
     */

    SetConsoleCtrlHandler(sigHandler, TRUE);
    exitToken = Tcl_AsyncCreate(asyncExit, NULL);

    /*
     * This exit handler will be used to free the resources allocated in this
     * file.
     */

    Tcl_CreateExitHandler(AppInitExitHandler, NULL);

#ifdef TCL_TEST
    if (Tcltest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL);
    if (TclObjTest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (Procbodytest_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
	    Procbodytest_SafeInit);
#endif /* TCL_TEST */

#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
    {
	extern Tcl_PackageInitProc Registry_Init;
	extern Tcl_PackageInitProc Dde_Init;
	extern Tcl_PackageInitProc Dde_SafeInit;
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
	    return TCL_ERROR;
	}
	Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit);
   }
#endif

    /*
     * Call the init procedures for included packages.  Each call should
     * look like this:
     *
     * if (Mod_Init(interp) == TCL_ERROR) {
     *     return TCL_ERROR;
     * }
     *
     * where "Mod" is the name of the module.
     */

    /*
     * Call Tcl_CreateCommand for application-specific commands, if
     * they weren't already created by the init procedures called above.
     */

    /*
     * Specify a user-specific startup file to invoke if the application
     * is run interactively.  Typically the startup file is "~/.apprc"
     * where "app" is the name of the application.  If this line is deleted
     * then no user-specific startup file will be run under any conditions.
     */

    Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppInitExitHandler --
 *
 *	This function is called to cleanup the app init resources before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees the saved argv and deletes the async exit handler.
 *
 *----------------------------------------------------------------------
 */

static void
AppInitExitHandler(
    ClientData clientData)	/* Not Used. */
{
    if (exitToken != NULL) {
        /*
         * This should be safe to do even if we
         * are in an async exit right now.
         */

        Tcl_AsyncDelete(exitToken);
        exitToken = NULL;
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * setargv --
 *
 *	Parse the Windows command line string into argc/argv.  Done here
 *	because we don't trust the builtin argument parser in crt0.
 *	Windows applications are responsible for breaking their command
 *	line into arguments.
 *
 *	2N backslashes + quote -> N backslashes + begin quoted string
 *	2N + 1 backslashes + quote -> literal
 *	N backslashes + non-quote -> literal
 *	quote + quote in a quoted string -> single quote
 *	quote + quote not in quoted string -> empty string
 *	quote -> begin quoted string
 *
 * Results:
 *	Fills argcPtr with the number of arguments and argvPtr with the
 *	array of arguments.
 *
 * Side effects:
 *	Memory allocated.
 *
 *--------------------------------------------------------------------------
 */

#if defined(__GNUC__)
static void
setargv(argcPtr, argvPtr)
    int *argcPtr;		/* Filled with number of argument strings. */
    char ***argvPtr;		/* Filled with argument strings (malloc'd). */
{
    char *cmdLine, *p, *arg, *argSpace;
    char **argv;
    int argc, size, inquote, copy, slashes;

    cmdLine = GetCommandLine();	/* INTL: BUG */

    /*
     * Precompute an overly pessimistic guess at the number of arguments
     * in the command line by counting non-space spans.
     */

    size = 2;
    for (p = cmdLine; *p != '\0'; p++) {
	if ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */
	    size++;
	    while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */







|
|









|
|



|
|
|
|











|
|















|
|
|
|
>
|
|








|
|
|
|









|
|




















|
|







180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
	    return TCL_ERROR;
	}
	Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit);
   }
#endif

    /*
     * Call the init functions for included packages. Each call should look
     * like this:
     *
     * if (Mod_Init(interp) == TCL_ERROR) {
     *     return TCL_ERROR;
     * }
     *
     * where "Mod" is the name of the module.
     */

    /*
     * Call Tcl_CreateCommand for application-specific commands, if they
     * weren't already created by the init functions called above.
     */

    /*
     * Specify a user-specific startup file to invoke if the application is
     * run interactively. Typically the startup file is "~/.apprc" where "app"
     * is the name of the application. If this line is deleted then no
     * user-specific startup file will be run under any conditions.
     */

    Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppInitExitHandler --
 *
 *	This function is called to cleanup the app init resources before Tcl
 *	is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees the saved argv and deletes the async exit handler.
 *
 *----------------------------------------------------------------------
 */

static void
AppInitExitHandler(
    ClientData clientData)	/* Not Used. */
{
    if (exitToken != NULL) {
	/*
	 * This should be safe to do even if we are in an async exit right
	 * now.
	 */

	Tcl_AsyncDelete(exitToken);
	exitToken = NULL;
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * setargv --
 *
 *	Parse the Windows command line string into argc/argv. Done here
 *	because we don't trust the builtin argument parser in crt0. Windows
 *	applications are responsible for breaking their command line into
 *	arguments.
 *
 *	2N backslashes + quote -> N backslashes + begin quoted string
 *	2N + 1 backslashes + quote -> literal
 *	N backslashes + non-quote -> literal
 *	quote + quote in a quoted string -> single quote
 *	quote + quote not in quoted string -> empty string
 *	quote -> begin quoted string
 *
 * Results:
 *	Fills argcPtr with the number of arguments and argvPtr with the array
 *	of arguments.
 *
 * Side effects:
 *	Memory allocated.
 *
 *--------------------------------------------------------------------------
 */

#if defined(__GNUC__)
static void
setargv(argcPtr, argvPtr)
    int *argcPtr;		/* Filled with number of argument strings. */
    char ***argvPtr;		/* Filled with argument strings (malloc'd). */
{
    char *cmdLine, *p, *arg, *argSpace;
    char **argv;
    int argc, size, inquote, copy, slashes;

    cmdLine = GetCommandLine();	/* INTL: BUG */

    /*
     * Precompute an overly pessimistic guess at the number of arguments in
     * the command line by counting non-space spans.
     */

    size = 2;
    for (p = cmdLine; *p != '\0'; p++) {
	if ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */
	    size++;
	    while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
		    copy = 0;
		    if ((inquote) && (p[1] == '"')) {
			p++;
			copy = 1;
		    } else {
			inquote = !inquote;
		    }
                }
                slashes >>= 1;
            }

            while (slashes) {
		*arg = '\\';
		arg++;
		slashes--;
	    }

	    if ((*p == '\0')
		    || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
		break;
	    }
	    if (copy != 0) {
		*arg = *p;
		arg++;
	    }
	    p++;
        }
	*arg = '\0';
	argSpace = arg + 1;
    }
    argv[argc] = NULL;

    *argcPtr = argc;
    *argvPtr = argv;







|
|
|

|





|
|







|







327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
		    copy = 0;
		    if ((inquote) && (p[1] == '"')) {
			p++;
			copy = 1;
		    } else {
			inquote = !inquote;
		    }
		}
		slashes >>= 1;
	    }

	    while (slashes) {
		*arg = '\\';
		arg++;
		slashes--;
	    }

	    if ((*p == '\0') || (!inquote &&
		    ((*p == ' ') || (*p == '\t')))) {	/* INTL: ISO space. */
		break;
	    }
	    if (copy != 0) {
		*arg = *p;
		arg++;
	    }
	    p++;
	}
	*arg = '\0';
	argSpace = arg + 1;
    }
    argv[argc] = NULL;

    *argcPtr = argc;
    *argvPtr = argv;
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415

416

417
418
419
420
421
422
423
424

425
426
427
428
429
430
431
432

433
434
435
436
437

438


439
440








 * Side effects:
 * 	tclsh cleanly exits.
 *
 *----------------------------------------------------------------------
 */

int
asyncExit (
    ClientData clientData,	/* Not Used. */
    Tcl_Interp *interp,		/* interp in context, if any. */
    int code)			/* result of last command, if any. */
{
    Tcl_Exit((int)exitErrorCode);

    /* NOTREACHED */
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * sigHandler --
 *
 *	Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
 *	other exits. This is needed so tclsh can do it's real clean-up
 *	and not an unclean crash terminate.
 *
 * Results:
 *	TRUE.
 *
 * Side effects:
 *	Effects the way the app exits from a signal. This is an
 *	operating system supplied thread and unsafe to call ANY
 *	Tcl commands except for Tcl_AsyncMark.
 *
 *----------------------------------------------------------------------
 */

BOOL WINAPI
sigHandler(
    DWORD fdwCtrlType)	    /* One of the CTRL_*_EVENT constants. */
{
    HANDLE hStdIn;

    if (!exitToken) {

	/* Async token must have been destroyed, punt gracefully. */

	return FALSE;
    }

    /*
     * If Tcl is currently executing some bytecode or in the eventloop,
     * this will cause Tcl to enter asyncExit at the next command
     * boundry.
     */

    exitErrorCode = fdwCtrlType;
    Tcl_AsyncMark(exitToken);

    /*
     * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
     * should it be blocked on input and our Tcl_AsyncMark didn't grab
     * the attention of the interpreter.
     */

    hStdIn = GetStdHandle(STD_INPUT_HANDLE);
    if (hStdIn) {
	CloseHandle(hStdIn);
    }


    /* indicate to the OS not to call the default terminator. */


    return TRUE;
}















|















|
|
|





|
|
|











>
|
>




|
|
<

>




|
|
|

>





>
|
>
>


>
>
>
>
>
>
>
>
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427

428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
 * Side effects:
 * 	tclsh cleanly exits.
 *
 *----------------------------------------------------------------------
 */

int
asyncExit(
    ClientData clientData,	/* Not Used. */
    Tcl_Interp *interp,		/* interp in context, if any. */
    int code)			/* result of last command, if any. */
{
    Tcl_Exit((int)exitErrorCode);

    /* NOTREACHED */
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * sigHandler --
 *
 *	Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and other
 *	exits. This is needed so tclsh can do it's real clean-up and not an
 *	unclean crash terminate.
 *
 * Results:
 *	TRUE.
 *
 * Side effects:
 *	Effects the way the app exits from a signal. This is an operating
 *	system supplied thread and unsafe to call ANY Tcl commands except for
 *	Tcl_AsyncMark.
 *
 *----------------------------------------------------------------------
 */

BOOL WINAPI
sigHandler(
    DWORD fdwCtrlType)	    /* One of the CTRL_*_EVENT constants. */
{
    HANDLE hStdIn;

    if (!exitToken) {
	/*
	 * Async token must have been destroyed, punt gracefully.
	 */
	return FALSE;
    }

    /*
     * If Tcl is currently executing some bytecode or in the eventloop, this
     * will cause Tcl to enter asyncExit at the next command boundry.

     */

    exitErrorCode = fdwCtrlType;
    Tcl_AsyncMark(exitToken);

    /*
     * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF> should
     * it be blocked on input and our Tcl_AsyncMark didn't grab the attention
     * of the interpreter.
     */

    hStdIn = GetStdHandle(STD_INPUT_HANDLE);
    if (hStdIn) {
	CloseHandle(hStdIn);
    }

    /*
     * Indicate to the OS not to call the default terminator.
     */

    return TRUE;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWin32Dll.c.

1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

55
56
57
58

59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84

85
86
87
88
89
90
91
92
93
/* 
 * tclWin32Dll.c --
 *
 *	This file contains the DLL entry point.

 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWin32Dll.c,v 1.40 2004/11/01 16:58:37 kennykb Exp $
 */

#include "tclWinInt.h"

/*
 * The following data structures are used when loading the thunking 
 * library for execing child processes under Win32s.
 */

typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
	LPVOID *lpTranslationList);

typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
	LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
	FARPROC UT32Callback, LPVOID Buff);

typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule);

/* 
 * The following variables keep track of information about this DLL
 * on a per-instance basis.  Each time this DLL is loaded, it gets its own 
 * new data segment with its own copy of all static and global information.
 */

static HINSTANCE hInstance;	/* HINSTANCE of this DLL. */
static int platformId;		/* Running under NT, or 95/98? */

#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG)
static void *INITIAL_ESP,
            *INITIAL_EBP,
            *INITIAL_HANDLER,
            *RESTORED_ESP,
            *RESTORED_EBP,
            *RESTORED_HANDLER;
#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */

#ifdef HAVE_NO_SEH

static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_dllmain_detach_handler(

    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext);



static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_checkstackspace_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext);

static
__attribute__((cdecl))
EXCEPTION_DISPOSITION
_except_TclWinCPUID_detach_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext);

#endif /* HAVE_NO_SEH */


/*
 * VC++ 5.x has no 'cpuid' assembler instruction, so we
 * must emulate it
 */

#if defined(_MSC_VER) && ( _MSC_VER <= 1100 )
#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif

/*
 * The following function tables are used to dispatch to either the
 * wide-character or multi-byte versions of the operating system calls,
 * depending on whether the Unicode calls are available.
 */



|
>




|
|

|





|
|












|
|
|





<
<
<
<
<
<
<
<
<

|
<
<
<
|
>
|
<
<
<
>

>
|
<
|
<
|
|
<
|
<
|
<
|
<
<
<
<
<
<
|

<

|
<

>
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40









41
42



43
44
45



46
47
48
49

50

51
52

53

54

55






56
57

58
59

60
61
62
63
64
65
66
67
68
69
70
/* 
 * tclWin32Dll.c --
 *
 *	This file contains the DLL entry point and other low-level bit bashing
 *	code that needs inline assembly.
 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWin32Dll.c,v 1.40.2.6 2005/08/02 18:17:00 dgp Exp $
 */

#include "tclWinInt.h"

/*
 * The following data structures are used when loading the thunking library
 * for execing child processes under Win32s.
 */

typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
	LPVOID *lpTranslationList);

typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
	LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
	FARPROC UT32Callback, LPVOID Buff);

typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule);

/* 
 * The following variables keep track of information about this DLL on a
 * per-instance basis. Each time this DLL is loaded, it gets its own new data
 * segment with its own copy of all static and global information.
 */

static HINSTANCE hInstance;	/* HINSTANCE of this DLL. */
static int platformId;		/* Running under NT, or 95/98? */










#ifdef HAVE_NO_SEH
/*



 * Unlike Borland and Microsoft, we don't register exception handlers by
 * pushing registration records onto the runtime stack. Instead, we register
 * them by creating an EXCEPTION_REGISTRATION within the activation record.



 */

typedef struct EXCEPTION_REGISTRATION {
    struct EXCEPTION_REGISTRATION *link;

    EXCEPTION_DISPOSITION (*handler)(

	    struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
    void *ebp;

    void *esp;

    int status;

} EXCEPTION_REGISTRATION;






#endif


/*
 * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it

 */

#if defined(_MSC_VER) && (_MSC_VER <= 1100)
#define cpuid	__asm __emit 0fh __asm __emit 0a2h
#endif

/*
 * The following function tables are used to dispatch to either the
 * wide-character or multi-byte versions of the operating system calls,
 * depending on whether the Unicode calls are available.
 */
123
124
125
126
127
128
129

130
131
132
133
134
135
136

137
138
139
140
141
142
143
    (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA,
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathA,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,

    /* 
     * The three NULL function pointers will only be set when
     * Tcl_FindExecutable is called.  If you don't ever call that
     * function, the application will crash whenever WinTcl tries to call
     * functions through these null pointers.  That is not a bug in Tcl
     * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
     */

    NULL,
    NULL,
    /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */
    NULL,
    NULL,
    /* Security SDK - not available on 95,98,ME */
    NULL, NULL, NULL, NULL, NULL, NULL







>


|
|
|
|

>







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
    (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA,
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathA,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,

    /* 
     * The three NULL function pointers will only be set when
     * Tcl_FindExecutable is called. If you don't ever call that function, the
     * application will crash whenever WinTcl tries to call functions through
     * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is
     * mandatory in recent Tcl releases.
     */

    NULL,
    NULL,
    /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */
    NULL,
    NULL,
    /* Security SDK - not available on 95,98,ME */
    NULL, NULL, NULL, NULL, NULL, NULL
174
175
176
177
178
179
180

181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227

228
229
230
231

232
233
234
235
236
237
238
239

240
241
242

243


244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
    (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathW,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,

    /* 
     * The three NULL function pointers will only be set when
     * Tcl_FindExecutable is called.  If you don't ever call that
     * function, the application will crash whenever WinTcl tries to call
     * functions through these null pointers.  That is not a bug in Tcl
     * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
     */

    NULL,
    NULL,
    /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */
    NULL,
    NULL,
    /* Security SDK - will be filled in on NT,XP,2000,2003 */
    NULL, NULL, NULL, NULL, NULL, NULL
};

TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;


#ifdef HAVE_NO_SEH

/* Need to add noinline flag to DllMain declaration so that gcc -O3
 * does not inline asm code into DllEntryPoint and cause a
 * compile time error because of redefined local labels.
 */

BOOL APIENTRY		DllMain(HINSTANCE hInst, DWORD reason, 
				LPVOID reserved)
                        __attribute__ ((noinline));

#else

/*
 * The following declaration is for the VC++ DLL entry point.
 */

BOOL APIENTRY		DllMain(HINSTANCE hInst, DWORD reason, 
				LPVOID reserved);
#endif /* HAVE_NO_SEH */


/*
 * The following structure and linked list is to allow us to map between
 * volume mount points and drive letters on the fly (no Win API exists
 * for this).
 */

typedef struct MountPointMap {
    CONST WCHAR* volumeName;       /* Native wide string volume name */
    char driveLetter;              /* Drive letter corresponding to
                                    * the volume name. */

    struct MountPointMap* nextPtr; /* Pointer to next structure in list,
                                    * or NULL */
} MountPointMap;

/* 
 * This is the head of the linked list, which is protected by the
 * mutex which follows, for thread-enabled builds.
 */

MountPointMap *driveLetterLookup = NULL;
TCL_DECLARE_MUTEX(mountPointMap)


/* We will need this below */


extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep;

#ifdef __WIN32__
#ifndef STATIC_BUILD


/*
 *----------------------------------------------------------------------
 *
 * DllEntryPoint --
 *
 *	This wrapper function is used by Borland to invoke the
 *	initialization code for Tcl.  It simply calls the DllMain
 *	routine.
 *
 * Results:
 *	See DllMain.
 *
 * Side effects:
 *	See DllMain.
 *







>


|
|
|
|

>












<

|
|
|
|



|
<
<

<





|

<



|
|

>

|
|
|
>
|
|



|
|

>



>
|
>
>




<






|
|
<







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180

181
182
183
184
185
186
187
188
189


190

191
192
193
194
195
196
197

198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

230
231
232
233
234
235
236
237

238
239
240
241
242
243
244
    (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathW,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,

    /* 
     * The three NULL function pointers will only be set when
     * Tcl_FindExecutable is called. If you don't ever call that function, the
     * application will crash whenever WinTcl tries to call functions through
     * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is
     * mandatory in recent Tcl releases.
     */

    NULL,
    NULL,
    /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */
    NULL,
    NULL,
    /* Security SDK - will be filled in on NT,XP,2000,2003 */
    NULL, NULL, NULL, NULL, NULL, NULL
};

TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;


#ifdef HAVE_NO_SEH
/*
 * Need to add noinline flag to DllMain declaration so that gcc -O3 does not
 * inline asm code into DllEntryPoint and cause a compile time error because
 * of redefined local labels.
 */

BOOL APIENTRY		DllMain(HINSTANCE hInst, DWORD reason, 
			    LPVOID reserved) __attribute__ ((noinline));


#else

/*
 * The following declaration is for the VC++ DLL entry point.
 */

BOOL APIENTRY		DllMain(HINSTANCE hInst, DWORD reason, 
			    LPVOID reserved);
#endif /* HAVE_NO_SEH */


/*
 * The following structure and linked list is to allow us to map between
 * volume mount points and drive letters on the fly (no Win API exists for
 * this).
 */

typedef struct MountPointMap {
    CONST WCHAR *volumeName;	/* Native wide string volume name. */
    char driveLetter;		/* Drive letter corresponding to the volume
				 * name. */
    struct MountPointMap *nextPtr;
				/* Pointer to next structure in list, or
				 * NULL. */
} MountPointMap;

/* 
 * This is the head of the linked list, which is protected by the mutex which
 * follows, for thread-enabled builds.
 */

MountPointMap *driveLetterLookup = NULL;
TCL_DECLARE_MUTEX(mountPointMap)

/*
 * We will need this below.
 */

extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep;

#ifdef __WIN32__
#ifndef STATIC_BUILD


/*
 *----------------------------------------------------------------------
 *
 * DllEntryPoint --
 *
 *	This wrapper function is used by Borland to invoke the initialization
 *	code for Tcl. It simply calls the DllMain routine.

 *
 * Results:
 *	See DllMain.
 *
 * Side effects:
 *	See DllMain.
 *
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296

297
298
299
300
301
302




303
304
305
306
307
308
309
310
311
312
313
314

315
316
317
318

319
320
321
322
323
324

325
326
327

328

329
330

331



332

333
334
335
336

337

338




339
340
341
342

343
344




345

346
347
348
349
350




351
352
353

354
355

356
357
358
359
360




361


362
363
364
365
366
367
368


369
370
371
372

373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
}

/*
 *----------------------------------------------------------------------
 *
 * DllMain --
 *
 *	This routine is called by the VC++ C run time library init
 *	code, or the DllEntryPoint routine.  It is responsible for
 *	initializing various dynamically loaded libraries.
 *
 * Results:
 *	TRUE on sucess, FALSE on failure.
 *
 * Side effects:
 *	Establishes 32-to-16 bit thunk and initializes sockets library.
 *	This might call some sycronization functions, but MSDN
 *	documentation states: "Waiting on synchronization objects in
 *	DllMain can cause a deadlock."
 *
 *----------------------------------------------------------------------
 */

BOOL APIENTRY
DllMain(hInst, reason, reserved)
    HINSTANCE hInst;		/* Library instance handle. */
    DWORD reason;		/* Reason this function is being called. */
    LPVOID reserved;		/* Not used. */
{




    switch (reason) {
    case DLL_PROCESS_ATTACH:
	DisableThreadLibraryCalls(hInst);
	TclWinInit(hInst);
	return TRUE;

    case DLL_PROCESS_DETACH:
	/*
	 * Protect the call to Tcl_Finalize.  The OS could be unloading
	 * us from an exception handler and the state of the stack might
	 * be unstable.
	 */

#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (
            "movl %%esp,  %0" "\n\t"

            "movl %%ebp,  %1" "\n\t"
            "movl %%fs:0, %2" "\n\t"
            : "=m"(INITIAL_ESP),
              "=m"(INITIAL_EBP),
              "=r"(INITIAL_HANDLER) );
# endif /* TCL_MEM_DEBUG */


    __asm__ __volatile__ (
            "pushl %%ebp" "\n\t"

            "pushl %0" "\n\t"

            "pushl %%fs:0" "\n\t"
            "movl  %%esp, %%fs:0"

            :



            : "r" (_except_dllmain_detach_handler) );

#else
	__try {
#endif /* HAVE_NO_SEH */
  	    Tcl_Finalize();

#ifdef HAVE_NO_SEH

    __asm__ __volatile__ (




            "jmp  dllmain_detach_pop" "\n"
        "dllmain_detach_reentry:" "\n\t"
            "movl %%fs:0, %%eax" "\n\t"
            "movl 0x8(%%eax), %%esp" "\n\t"

            "movl 0x8(%%esp), %%ebp" "\n"
        "dllmain_detach_pop:" "\n\t"




            "movl (%%esp), %%eax" "\n\t"

            "movl %%eax, %%fs:0" "\n\t"
            "add  $12, %%esp" "\n\t"
            :
            :
            : "%eax");





# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (

            "movl  %%esp,  %0" "\n\t"
            "movl  %%ebp,  %1" "\n\t"

            "movl  %%fs:0, %2" "\n\t"
            : "=m"(RESTORED_ESP),
              "=m"(RESTORED_EBP),
              "=r"(RESTORED_HANDLER) );





    if (INITIAL_ESP != RESTORED_ESP)


        Tcl_Panic("ESP restored incorrectly");
    if (INITIAL_EBP != RESTORED_EBP)
        Tcl_Panic("EBP restored incorrectly");
    if (INITIAL_HANDLER != RESTORED_HANDLER)
        Tcl_Panic("HANDLER restored incorrectly");
# endif /* TCL_MEM_DEBUG */
#else


	} __except (EXCEPTION_EXECUTE_HANDLER) {
	    /* empty handler body. */
	}
#endif /* HAVE_NO_SEH */

	break;
    }

    return TRUE; 
}

/*
 *----------------------------------------------------------------------
 *
 * _except_dllmain_detach_handler --
 *
 *	SEH exception handler for DllMain.
 *
 * Results:
 *	See DllMain.
 *
 * Side effects:
 *	See DllMain.
 *
 *----------------------------------------------------------------------
 */
#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_dllmain_detach_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext)
{
    __asm__ __volatile__ (
            "jmp dllmain_detach_reentry");
    return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */


#endif /* !STATIC_BUILD */
#endif /* __WIN32__ */

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetTclInstance --







|
|
|





|
|
|
|



>






>
>
>
>








|
|
<

>

<
|
|
>
|
<
<
<
<
|
>

|
|
>
|
>
|
|
>
|
>
>
>
|
>
|
<
|
|
>
|
>
|
>
>
>
>
|
<
|
|
>
|
|
>
>
>
>
|
>
|
|
|
|
<
>
>
>
>

<
<
>
|
|
>
|
|
<
<
|
>
>
>
>
|
>
>
|
|
<
<
<
<
|
>
>



|
>





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297

298
299
300

301
302
303
304




305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322

323
324
325
326
327
328
329
330
331
332
333

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348

349
350
351
352
353


354
355
356
357
358
359


360
361
362
363
364
365
366
367
368
369




370
371
372
373
374
375
376
377
378
379
380
381
382

































383
384
385
386
387
388
389
}

/*
 *----------------------------------------------------------------------
 *
 * DllMain --
 *
 *	This routine is called by the VC++ C run time library init code, or
 *	the DllEntryPoint routine. It is responsible for initializing various
 *	dynamically loaded libraries.
 *
 * Results:
 *	TRUE on sucess, FALSE on failure.
 *
 * Side effects:
 *	Establishes 32-to-16 bit thunk and initializes sockets library. This
 *	might call some sycronization functions, but MSDN documentation
 *	states: "Waiting on synchronization objects in DllMain can cause a
 *	deadlock."
 *
 *----------------------------------------------------------------------
 */

BOOL APIENTRY
DllMain(hInst, reason, reserved)
    HINSTANCE hInst;		/* Library instance handle. */
    DWORD reason;		/* Reason this function is being called. */
    LPVOID reserved;		/* Not used. */
{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif

    switch (reason) {
    case DLL_PROCESS_ATTACH:
	DisableThreadLibraryCalls(hInst);
	TclWinInit(hInst);
	return TRUE;

    case DLL_PROCESS_DETACH:
	/*
	 * Protect the call to Tcl_Finalize. The OS could be unloading us from
	 * an exception handler and the state of the stack might be unstable.

	 */

#ifdef HAVE_NO_SEH

	__asm__ __volatile__ (

	    /*
	     * Construct an EXCEPTION_REGISTRATION to protect the call to




	     * Tcl_Finalize
	     */

	    "leal	%[registration], %%edx"		"\n\t"
	    "movl	%%fs:0,		%%eax"		"\n\t"
	    "movl	%%eax,		0x0(%%edx)"	"\n\t" /* link */
	    "leal	1f,		%%eax"		"\n\t"
	    "movl	%%eax,		0x4(%%edx)"	"\n\t" /* handler */
	    "movl	%%ebp,		0x8(%%edx)"	"\n\t" /* ebp */
	    "movl	%%esp,		0xc(%%edx)"	"\n\t" /* esp */
	    "movl	%[error],	0x10(%%edx)"	"\n\t" /* status */

	    /*
	     * Link the EXCEPTION_REGISTRATION on the chain
	     */

	    "movl	%%edx,		%%fs:0"		"\n\t"


	    /*
	     * Call Tcl_Finalize
	     */

	    "call	_Tcl_Finalize"			"\n\t"

	    /*
	     * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
	     * and store a TCL_OK status
	     */


	    "movl	%%fs:0,		%%edx"		"\n\t"
	    "movl	%[ok],		%%eax"		"\n\t"
	    "movl	%%eax,		0x10(%%edx)"	"\n\t"
	    "jmp	2f"				"\n"

	    /*
	     * Come here on an exception. Get the EXCEPTION_REGISTRATION that
	     * we previously put on the chain.
	     */

	    "1:"					"\t"
	    "movl	%%fs:0,		%%edx"		"\n\t"
	    "movl	0x8(%%edx),	%%edx"		"\n"



	    /* 
	     * Come here however we exited. Restore context from the
	     * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	     */



	    "2:"					"\t"
	    "movl	0xc(%%edx),	%%esp"		"\n\t"
	    "movl	0x8(%%edx),	%%ebp"		"\n\t"
	    "movl	0x0(%%edx),	%%eax"		"\n\t"
	    "movl	%%eax,		%%fs:0"		"\n\t"



	    :
	    /* No outputs */
	    :
	    [registration]	"m"	(registration),
	    [ok]		"i"	(TCL_OK),
	    [error]		"i"	(TCL_ERROR)
	    :
	    "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
	    );





#else /* HAVE_NO_SEH */
	__try {
	    Tcl_Finalize();
	} __except (EXCEPTION_EXECUTE_HANDLER) {
	    /* empty handler body. */
	}
#endif

	break;
    }

    return TRUE; 
}

































#endif /* !STATIC_BUILD */
#endif /* __WIN32__ */

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetTclInstance --
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488

    hInstance = hInst;
    os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
    GetVersionEx(&os);
    platformId = os.dwPlatformId;

    /*
     * We no longer support Win32s, so just in case someone manages to
     * get a runtime there, make sure they know that.
     */

    if (platformId == VER_PLATFORM_WIN32s) {
	Tcl_Panic("Win32s is not a supported platform");	
    }

    tclWinProcs = &asciiProcs;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetPlatformId --
 *
 *	Determines whether running under NT, 95, or Win32s, to allow 
 *	runtime conditional code.
 *
 * Results:
 *	The return value is one of:
 *	    VER_PLATFORM_WIN32s		Win32s on Windows 3.1. (not supported)
 *	    VER_PLATFORM_WIN32_WINDOWS	Win32 on Windows 95, 98, ME.
 *	    VER_PLATFORM_WIN32_NT	Win32 on Windows NT, 2000, XP
 *







|
|














|
|







429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460

    hInstance = hInst;
    os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
    GetVersionEx(&os);
    platformId = os.dwPlatformId;

    /*
     * We no longer support Win32s, so just in case someone manages to get a
     * runtime there, make sure they know that.
     */

    if (platformId == VER_PLATFORM_WIN32s) {
	Tcl_Panic("Win32s is not a supported platform");	
    }

    tclWinProcs = &asciiProcs;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetPlatformId --
 *
 *	Determines whether running under NT, 95, or Win32s, to allow runtime
 *	conditional code.
 *
 * Results:
 *	The return value is one of:
 *	    VER_PLATFORM_WIN32s		Win32s on Windows 3.1. (not supported)
 *	    VER_PLATFORM_WIN32_WINDOWS	Win32 on Windows 95, 98, ME.
 *	    VER_PLATFORM_WIN32_NT	Win32 on Windows NT, 2000, XP
 *
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551




552
553
554
555
556
557
558
559
560
561
562
563
564



565








566



567

568




569



570









571




572

573

574




575





576
577










578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCheckStackSpace --
 *
 *	Detect if we are about to blow the stack.  Called before an 
 *	evaluation can happen when nesting depth is checked.
 *
 * Results:
 *	1 if there is enough stack space to continue; 0 if not.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpCheckStackSpace()
{




    int retval = 0;

    /*
     * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
     * bytes of stack space left.  alloca() is cheap on windows; basically
     * it just subtracts from the stack pointer causing the OS to throw an
     * exception if the stack pointer is set below the bottom of the stack.
     */

#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (
            "movl %%esp,  %0" "\n\t"



            "movl %%ebp,  %1" "\n\t"








            "movl %%fs:0, %2" "\n\t"



            : "=m"(INITIAL_ESP),

              "=m"(INITIAL_EBP),




              "=r"(INITIAL_HANDLER) );



# endif /* TCL_MEM_DEBUG */














    __asm__ __volatile__ (

            "pushl %%ebp" "\n\t"

            "pushl %0" "\n\t"




            "pushl %%fs:0" "\n\t"





            "movl  %%esp, %%fs:0"
            :










            : "r" (_except_checkstackspace_handler) );
#else
    __try {
#endif /* HAVE_NO_SEH */
#ifdef HAVE_ALLOCA_GCC_INLINE
    __asm__ __volatile__ (
            "movl  %0, %%eax" "\n\t"
            "call  __alloca" "\n\t"
            :
            : "i"(TCL_WIN_STACK_THRESHOLD)
            : "%eax");
#else
	alloca(TCL_WIN_STACK_THRESHOLD);
#endif /* HAVE_ALLOCA_GCC_INLINE */
	retval = 1;
#ifdef HAVE_NO_SEH
    __asm__ __volatile__ (
            "movl %%fs:0, %%esp" "\n\t"
            "jmp  checkstackspace_pop" "\n"
        "checkstackspace_reentry:" "\n\t"
            "movl %%fs:0, %%eax" "\n\t"
            "movl 0x8(%%eax), %%esp" "\n\t"
            "movl 0x8(%%esp), %%ebp" "\n"
        "checkstackspace_pop:" "\n\t"
            "movl (%%esp), %%eax" "\n\t"
            "movl %%eax, %%fs:0" "\n\t"
            "add  $12, %%esp" "\n\t"
            :
            :
            : "%eax");

# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (
            "movl  %%esp,  %0" "\n\t"
            "movl  %%ebp,  %1" "\n\t"
            "movl  %%fs:0, %2" "\n\t"
            : "=m"(RESTORED_ESP),
              "=m"(RESTORED_EBP),
              "=r"(RESTORED_HANDLER) );

    if (INITIAL_ESP != RESTORED_ESP)
        Tcl_Panic("ESP restored incorrectly");
    if (INITIAL_EBP != RESTORED_EBP)
        Tcl_Panic("EBP restored incorrectly");
    if (INITIAL_HANDLER != RESTORED_HANDLER)
        Tcl_Panic("HANDLER restored incorrectly");
# endif /* TCL_MEM_DEBUG */
#else
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */

    /*
     * Avoid using control flow statements in the SEH guarded block!
     */
    return retval;
}

/*
 *----------------------------------------------------------------------
 *
 * _except_checkstackspace_handler --
 *
 *	SEH exception handler for TclpCheckStackSpace.
 *
 * Results:
 *	See TclpCheckStackSpace.
 *
 * Side effects:
 *	See TclpCheckStackSpace.
 *
 *----------------------------------------------------------------------
 */
#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_checkstackspace_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext)
{
    __asm__ __volatile__ (
            "jmp checkstackspace_reentry");
    return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetPlatform --
 *
 *	This is a kludge that allows the test library to get access
 *	the internal tclPlatform variable.
 *
 * Results:
 *	Returns a pointer to the tclPlatform variable.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclPlatformType *
TclWinGetPlatform()
{
    return &tclPlatform;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinSetInterfaces --
 *
 *	A helper proc that allows the test library to change the
 *	tclWinProcs structure to dispatch to either the wide-character
 *	or multi-byte versions of the operating system calls, depending
 *	on whether Unicode is the system encoding.
 *	
 *	As well as this, we can also try to load in some additional
 *	procs which may/may not be present depending on the current
 *	Windows version (e.g. Win95 will not have the procs below).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|
|













>
>
>
>



|
|
|
|



<

|
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
>
|
>
|
>
>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>

>
>
>
>
|
>
|
>
|
>
>
>
>
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
|
|

<

|
|
|
|
|
|




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
<
<
<


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






|
|
|
|

|
|
|







502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537

538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611

612
613
614
615
616
617
618
619
620
621
622

































623
624
625



626
627






















































628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCheckStackSpace --
 *
 *	Detect if we are about to blow the stack. Called before an evaluation
 *	can happen when nesting depth is checked.
 *
 * Results:
 *	1 if there is enough stack space to continue; 0 if not.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpCheckStackSpace()
{

#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    int retval = 0;

    /*
     * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD bytes
     * of stack space left. alloca() is cheap on windows; basically it just
     * subtracts from the stack pointer causing the OS to throw an exception
     * if the stack pointer is set below the bottom of the stack.
     */

#ifdef HAVE_NO_SEH

    __asm__ __volatile__ (

	/*
	 * Construct an EXCEPTION_REGISTRATION to protect the call to __alloca
	 */

	"leal	%[registration], %%edx"		"\n\t"
	"movl	%%fs:0,		%%eax"		"\n\t"
	"movl	%%eax,		0x0(%%edx)"	"\n\t" /* link */
	"leal	1f,		%%eax"		"\n\t"
	"movl	%%eax,		0x4(%%edx)"	"\n\t" /* handler */
	"movl	%%ebp,		0x8(%%edx)"	"\n\t" /* ebp */
	"movl	%%esp,		0xc(%%edx)"	"\n\t" /* esp */
	"movl	%[error],	0x10(%%edx)"	"\n\t" /* status */
	
	/*
	 * Link the EXCEPTION_REGISTRATION on the chain
	 */

	"movl	%%edx,		%%fs:0"		"\n\t"

	/*
	 * Attempt a call to __alloca, to determine whether there's sufficient
	 * memory to be had.
	 */

	"movl	%[size],	%%eax"		"\n\t"
	"pushl	%%eax"				"\n\t"
	"call	__alloca"			"\n\t"

	/*
	 * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and
	 * store a TCL_OK status
	 */

	"movl	%%fs:0,		%%edx"		"\n\t"
	"movl	%[ok],		%%eax"		"\n\t"
	"movl	%%eax,		0x10(%%edx)"	"\n\t"
	"jmp	2f"				"\n"

	/*
	 * Come here on an exception. Get the EXCEPTION_REGISTRATION that we
	 * previously put on the chain.
	 */

	"1:"					"\t"
	"movl	%%fs:0,		%%edx"		"\n\t"
	"movl	0x8(%%edx),	%%edx"		"\n\t"
	
	/* 
	 * Come here however we exited. Restore context from the
	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	 */
	
	"2:"					"\t"
	"movl	0xc(%%edx),	%%esp"		"\n\t"
	"movl	0x8(%%edx),	%%ebp"		"\n\t"
	"movl	0x0(%%edx),	%%eax"		"\n\t"
	"movl	%%eax,		%%fs:0"		"\n\t"
	
	:
	/* No outputs */
	:
	[registration]	"m"	(registration),
	[ok]		"i"	(TCL_OK),
	[error]		"i"	(TCL_ERROR),
	[size]		"i"	(TCL_WIN_STACK_THRESHOLD)
	:
	"%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
	);
    retval = (registration.status == TCL_OK);

#else /* !HAVE_NO_SEH */
    __try {

#ifdef HAVE_ALLOCA_GCC_INLINE
	__asm__ __volatile__ (
	    "movl  %0, %%eax" "\n\t"
	    "call  __alloca" "\n\t"
	    :
	    : "i"(TCL_WIN_STACK_THRESHOLD)
	    : "%eax");
#else
	alloca(TCL_WIN_STACK_THRESHOLD);
#endif /* HAVE_ALLOCA_GCC_INLINE */
	retval = 1;

































    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */
    



    return retval;
}























































/*
 *---------------------------------------------------------------------------
 *
 * TclWinSetInterfaces --
 *
 *	A helper proc that allows the test library to change the tclWinProcs
 *	structure to dispatch to either the wide-character or multi-byte
 *	versions of the operating system calls, depending on whether Unicode
 *	is the system encoding.
 *	
 *	As well as this, we can also try to load in some additional procs
 *	which may/may not be present depending on the current Windows version
 *	(e.g. Win95 will not have the procs below).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
718
719
720
721
722
723
724
725
726
727

728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786

787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

836
837
838
839
840
841
842
843


844


845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893

894
895
896
897
898

899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921

922


923


924
925
926

927


928
929
930
931

932
933
934
935

936
937
938
939
940
941
942
943
944
945
946
947
948


949


950
951

952
953
954
955
956

957
958
959
960
961
962

963

964
965

966


967
968
969

970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985


986


987
988
989
990
991
992
993

994
995
996
997
998

999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105

1106
1107
1108
1109


1110
1111
1112
1113
1114


1115
1116
1117




1118

1119

1120


1121

1122



1123

1124


1125

1126







1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144


1145
1146
1147

1148



1149
1150

1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166

1167
1168
1169




1170


1171
1172
1173
1174

1175
1176
1177
1178
1179
1180
1181
1182
1183

1184

1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201

1202

1203
1204
1205
1206
1207
1208
1209
1210

1211
1212
1213

1214
1215

1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251

    if (wide) {
	tclWinProcs = &unicodeProcs;
	tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
	        tclWinProcs->getFileAttributesExProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, 
		  LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");

		tclWinProcs->createHardLinkProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, 
		  LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, 
		  "CreateHardLinkW");
	        tclWinProcs->findFirstFileExProc = 
		  (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
		  LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, 
		  "FindFirstFileExW");
	        tclWinProcs->getVolumeNameForVMPProc = 
		  (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, 
		  DWORD)) GetProcAddress(hInstance, 
		  "GetVolumeNameForVolumeMountPointW");
		tclWinProcs->getLongPathNameProc = 
		  (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, 
		  DWORD)) GetProcAddress(hInstance, 
		  "GetLongPathNameW");
		FreeLibrary(hInstance);
	    }
	    hInstance = LoadLibraryA("advapi32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)(
		  LPCTSTR lpFileName, 
		  SECURITY_INFORMATION RequestedInformation,
		  PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, 
		  LPDWORD lpnLengthNeeded)) GetProcAddress(hInstance, 
							   "GetFileSecurityW"); 
		tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) (
		  SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) 
		  GetProcAddress(hInstance, "ImpersonateSelf");
		tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) (
		  HANDLE ThreadHandle, DWORD DesiredAccess, BOOL OpenAsSelf,
		  PHANDLE TokenHandle)) GetProcAddress(hInstance, 
						       "OpenThreadToken");
		tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void)) 
		  GetProcAddress(hInstance, "RevertToSelf");
		tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) (
		  PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) 
		  GetProcAddress(hInstance, "MapGenericMask");
		tclWinProcs->accessCheckProc = (BOOL (WINAPI *)(
		  PSECURITY_DESCRIPTOR pSecurityDescriptor, 
	          HANDLE ClientToken, DWORD DesiredAccess,
	          PGENERIC_MAPPING GenericMapping,
		  PPRIVILEGE_SET PrivilegeSet,
		  LPDWORD PrivilegeSetLength,
		  LPDWORD GrantedAccess,
		  LPBOOL AccessStatus)) GetProcAddress(hInstance, 
		  "AccessCheck");
		FreeLibrary(hInstance);
	    }
	}
    } else {
	tclWinProcs = &asciiProcs;
	tclWinTCharEncoding = NULL;
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileAttributesExProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, 
		  LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");

		tclWinProcs->createHardLinkProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, 
		  LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, 
		  "CreateHardLinkA");
		tclWinProcs->findFirstFileExProc = NULL;
		tclWinProcs->getLongPathNameProc = NULL;
		/*
		 * The 'findFirstFileExProc' function exists on some
		 * of 95/98/ME, but it seems not to work as anticipated.
		 * Therefore we don't set this function pointer.  The
		 * relevant code will fall back on a slower approach
		 * using the normal findFirstFileProc.
		 * 
		 * (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
		 * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, 
		 * "FindFirstFileExA");
		 */
		tclWinProcs->getVolumeNameForVMPProc = 
		  (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, 
		  DWORD)) GetProcAddress(hInstance, 
		  "GetVolumeNameForVolumeMountPointA");
		FreeLibrary(hInstance);
	    }
	}
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinResetInterfaceEncodings --
 *
 *	Called during finalization to free up any encodings we use.
 *	The tclWinProcs-> look up table is still ok to use after
 *	this call, provided no encoding conversion is required.
 *
 *      We also clean up any memory allocated in our mount point
 *      map which is used to follow certain kinds of symlinks.
 *      That code should never be used once encodings are taken
 *      down.
 *      
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclWinResetInterfaceEncodings()
{
    MountPointMap *dlIter, *dlIter2;
    if (tclWinTCharEncoding != NULL) {
	Tcl_FreeEncoding(tclWinTCharEncoding);
	tclWinTCharEncoding = NULL;
    }


    /* Clean up the mount point map */


    Tcl_MutexLock(&mountPointMap);
    dlIter = driveLetterLookup; 
    while (dlIter != NULL) {
	dlIter2 = dlIter->nextPtr;
	ckfree((char*)dlIter->volumeName);
	ckfree((char*)dlIter);
	dlIter = dlIter2;
    }
    Tcl_MutexUnlock(&mountPointMap);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinResetInterfaces --
 *
 *	Called during finalization to reset us to a safe state for reuse.
 *	After this call, it is best not to use the tclWinProcs-> look
 *	up table since it is likely to be different to what is expected.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
void
TclWinResetInterfaces()
{
    tclWinProcs = &asciiProcs;
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinDriveLetterForVolMountPoint
 *
 * Unfortunately, Windows provides no easy way at all to get hold
 * of the drive letter for a volume mount point, but we need that
 * information to understand paths correctly.  So, we have to 
 * build an associated array to find these correctly, and allow
 * quick and easy lookup from volume mount points to drive letters.
 * 
 * We assume here that we are running on a system for which the wide
 * character interfaces are used, which is valid for Win 2000 and WinXP
 * which are the only systems on which this function will ever be called.
 * 

 * Result: the drive letter, or -1 if no drive letter corresponds to
 * the given mount point.
 * 
 *--------------------------------------------------------------------
 */

char 
TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint)
{
    MountPointMap *dlIter, *dlPtr2;
    WCHAR Target[55];         /* Target of mount at mount point */
    WCHAR drive[4] = { L'A', L':', L'\\', L'\0' };
    
    /* 
     * Detect the volume mounted there.  Unfortunately, there is no
     * simple way to map a unique volume name to a DOS drive letter.  
     * So, we have to build an associative array.
     */
    
    Tcl_MutexLock(&mountPointMap);
    dlIter = driveLetterLookup; 
    while (dlIter != NULL) {
	if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
	    /* 
	     * We need to check whether this information is
	     * still valid, since either the user or various
	     * programs could have adjusted the mount points on
	     * the fly.
	     */

	    drive[0] = L'A' + (dlIter->driveLetter - 'A');


	    /* Try to read the volume mount point and see where it points */


	    if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, 
					       (TCHAR*)Target, 55) != 0) {
		if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {

		    /* Nothing has changed */


		    Tcl_MutexUnlock(&mountPointMap);
		    return dlIter->driveLetter;
		}
	    }

	    /* 
	     * If we reach here, unfortunately, this mount point is
	     * no longer valid at all
	     */

	    if (driveLetterLookup == dlIter) {
		dlPtr2 = dlIter;
		driveLetterLookup = dlIter->nextPtr;
	    } else {
		for (dlPtr2 = driveLetterLookup; 
		     dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) {
		    if (dlPtr2->nextPtr == dlIter) {
			dlPtr2->nextPtr = dlIter->nextPtr;
			dlPtr2 = dlIter;
			break;
		    }
		}
	    }


	    /* Now dlPtr2 points to the structure to free */


	    ckfree((char*)dlPtr2->volumeName);
	    ckfree((char*)dlPtr2);

	    /* 
	     * Restart the loop --- we could try to be clever
	     * and continue half way through, but the logic is a 
	     * bit messy, so it's cleanest just to restart
	     */

	    dlIter = driveLetterLookup;
	    continue;
	}
	dlIter = dlIter->nextPtr;
    }
   

    /* We couldn't find it, so we must iterate over the letters */

    
    for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) {

	/* Try to read the volume mount point and see where it points */


	if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, 
					   (TCHAR*)Target, 55) != 0) {
	    int alreadyStored = 0;

	    for (dlIter = driveLetterLookup; dlIter != NULL; 
		 dlIter = dlIter->nextPtr) {
		if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
		    alreadyStored = 1;
		    break;
		}
	    }
	    if (!alreadyStored) {
		dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
		dlPtr2->volumeName = TclNativeDupInternalRep(Target);
		dlPtr2->driveLetter = 'A' + (drive[0] - L'A');
		dlPtr2->nextPtr = driveLetterLookup;
		driveLetterLookup  = dlPtr2;
	    }
	}
    }


    /* Try again */


    for (dlIter = driveLetterLookup; dlIter != NULL; 
					dlIter = dlIter->nextPtr) {
	if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
	    Tcl_MutexUnlock(&mountPointMap);
	    return dlIter->driveLetter;
	}
    }

    /* 
     * The volume doesn't appear to correspond to a drive letter -- we
     * remember that fact and store '-1' so we don't have to look it
     * up each time.
     */

    dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
    dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint);
    dlPtr2->driveLetter = -1;
    dlPtr2->nextPtr = driveLetterLookup;
    driveLetterLookup  = dlPtr2;
    Tcl_MutexUnlock(&mountPointMap);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
 *
 *	Convert between UTF-8 and Unicode when running Windows NT or 
 *	the current ANSI code page when running Windows 95.
 *
 *	On Mac, Unix, and Windows 95, all strings exchanged between Tcl
 *	and the OS are "char" oriented.  We need only one Tcl_Encoding to
 *	convert between UTF-8 and the system's native encoding.  We use
 *	NULL to represent that encoding.
 *
 *	On NT, some strings exchanged between Tcl and the OS are "char"
 *	oriented, while others are in Unicode.  We need two Tcl_Encoding
 *	APIs depending on whether we are targeting a "char" or Unicode
 *	interface.  
 *
 *	Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an
 *	encoding of NULL should always used to convert between UTF-8
 *	and the system's "char" oriented encoding.  The following two
 *	functions are used in Windows-specific code to convert between
 *	UTF-8 and Unicode strings (NT) or "char" strings(95).  This saves
 *	you the trouble of writing the following type of fragment over and
 *	over:
 *
 *		if (running NT) {
 *		    encoding <- Tcl_GetEncoding("unicode");
 *		    nativeBuffer <- UtfToExternal(encoding, utfBuffer);
 *		    Tcl_FreeEncoding(encoding);
 *		} else {
 *		    nativeBuffer <- UtfToExternal(NULL, utfBuffer);
 *		}
 *
 *	By convention, in Windows a TCHAR is a character in the ANSI code
 *	page on Windows 95, a Unicode character on Windows NT.  If you
 *	plan on targeting a Unicode interfaces when running on NT and a
 *	"char" oriented interface while running on 95, these functions
 *	should be used.  If you plan on targetting the same "char"
 *	oriented function on both 95 and NT, use Tcl_UtfToExternal()
 *	with an encoding of NULL.
 *
 * Results:
 *	The result is a pointer to the string in the desired target
 *	encoding.  Storage for the result string is allocated in
 *	dsPtr; the caller must call Tcl_DStringFree() when the result
 *	is no longer needed.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

TCHAR *
Tcl_WinUtfToTChar(string, len, dsPtr)
    CONST char *string;		/* Source string in UTF-8. */
    int len;			/* Source string length in bytes, or < 0 for
				 * strlen(). */
    Tcl_DString *dsPtr;		/* Uninitialized or free DString in which 
				 * the converted string is stored. */
{
    return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, 
	    string, len, dsPtr);
}

char *
Tcl_WinTCharToUtf(string, len, dsPtr)
    CONST TCHAR *string;	/* Source string in Unicode when running
				 * NT, ANSI when running 95. */
    int len;			/* Source string length in bytes, or < 0 for
				 * platform-specific string length. */
    Tcl_DString *dsPtr;		/* Uninitialized or free DString in which 
				 * the converted string is stored. */
{
    return Tcl_ExternalToUtfDString(tclWinTCharEncoding, 
	    (CONST char *) string, len, dsPtr);
}

/*
 *------------------------------------------------------------------------
 *
 * TclWinCPUID --
 *
 *	Get CPU ID information on an Intel box under Windows
 *
 * Results:
 *	Returns TCL_OK if successful, TCL_ERROR if CPUID is not
 *	supported or fails.
 *
 * Side effects:
 *	If successful, stores EAX, EBX, ECX and EDX registers after 
 *      the CPUID instruction in the four integers designated by 'regsPtr'
 *
 *----------------------------------------------------------------------
 */

int

TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve */
	     register unsigned int * regsPtr ) /* Registers after the CPUID */
{



    int status = TCL_ERROR;

#if defined(__GNUC__)

    /* Establish structured exception handling */



# ifdef HAVE_NO_SEH
    __asm__ __volatile__ (




	    "pushl %%ebp" "\n\t"

	    "pushl %0" "\n\t"

	    "pushl %%fs:0" "\n\t"


	    "movl  %%esp, %%fs:0"

            :



            : "r" (_except_TclWinCPUID_detach_handler) );

#  else


    __try {

#  endif








	/* 
	 * Execute the CPUID instruction with the given index, and
	 * store results off 'regPtr'.
	 */

	__asm__ __volatile__ (
	    "movl %4, %%eax" "\n\t"
            "cpuid" "\n\t"
	    "movl %%eax, %0" "\n\t"
	    "movl %%ebx, %1" "\n\t"
	    "movl %%ecx, %2" "\n\t"
	    "movl %%edx, %3"
	    : 
	    "=m"(regsPtr[0]),
	    "=m"(regsPtr[1]),
	    "=m"(regsPtr[2]),
	    "=m"(regsPtr[3])


	    : "m"(index)
	    : "%eax", "%ebx", "%ecx", "%edx" );
	status = TCL_OK;





	/* End the structured exception handler */


#  ifndef HAVE_NO_SEH
    } __except( EXCEPTION_EXECUTE_HANDLER ) {
	/* do nothing */
    }
#  else
    __asm __volatile__ (
	    "jmp  TclWinCPUID_detach_pop" "\n"
        "TclWinCPUID_detach_reentry:" "\n\t"
	    "movl %%fs:0, %%eax" "\n\t"
	    "movl 0x8(%%eax), %%esp" "\n\t"
	    "movl 0x8(%%esp), %%ebp" "\n"
	"TclWinCPUID_detach_pop:" "\n\t"
	    "movl (%%esp), %%eax" "\n\t"
	    "movl %%eax, %%fs:0" "\n\t"
	    "add  $12, %%esp" "\n\t"
	:

	:
	: "%eax");
#  endif








#elif defined(_MSC_VER) && !defined(_WIN64)

    /* Define a structure in the stack frame to hold the registers */


    struct {
	DWORD dw0;
	DWORD dw1;
	DWORD dw2;
	DWORD dw3;
    } regs;
    regs.dw0 = index;
    

    /* Execute the CPUID instruction and save regs in the stack frame */


    _try {
	_asm {
	    push    ebx
	    push    ecx
	    push    edx
	    mov     eax, regs.dw0
	    cpuid
	    mov     regs.dw0, eax
	    mov     regs.dw1, ebx
	    mov     regs.dw2, ecx
	    mov     regs.dw3, edx
            pop     edx
            pop     ecx
            pop     ebx
	}
	

	/* Copy regs back out to the caller */


	regsPtr[0]=regs.dw0;
	regsPtr[1]=regs.dw1;
	regsPtr[2]=regs.dw2;
	regsPtr[3]=regs.dw3;

	status = TCL_OK;
    } __except( EXCEPTION_EXECUTE_HANDLER ) {

    }

#else

				/* Don't know how to do assembly code for
				 * this compiler and/or architecture */

#endif
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * _except_TclWinCPUID_detach_handler --
 *
 *	SEH exception handler for TclWinCPUID.
 *
 * Results:
 *	See TclWinCPUID.
 *
 * Side effects:
 *	See TclWinCPUID.
 *
 *----------------------------------------------------------------------
 */

#if defined( HAVE_NO_SEH )
static
__attribute__((cdecl))
EXCEPTION_DISPOSITION
_except_TclWinCPUID_detach_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext)
{
    __asm__ __volatile__ (
	"jmp TclWinCPUID_detach_reentry" );
    return 0; /* Function does not return */
}
#endif








|
|
|
>

|
|
|
|
|
|
|
|
|
|
|

|
|
<





|
|
|
|
|

|
|

|
|
|

|

|
|

|
|
|
|
|
<
|
|










|
|
>

|
|
|



|
|
|
|
|






|
|
|











|
|
|

|
|
|
<
|








>








>
>
|
>
>

















|
|




















|
|
|
|
|

|
|
|

>
|
|



>




|



|
|
|







|
<
|
|

>

>
>
|
>
>

|

>
|
>
>




>

|
|

>





|







>
>
|
>
>


>

|
|
|

>






>
|
>


>
|
>
>

|

>

|






|







>
>
|
>
>

|





>

|
|
<

>














|
|

|
|
|
|


|
|
<

|
|
|
|
|
|
<









|
|
|
|
|
|
<


|
|
|
<












|
|







|
|


|
|













|
|


|
|





>
|
|

|
>
>


|
|
|
>
>
|
<
|
>
>
>
>
|
>
|
>
|
>
>
|
>
|
>
>
>
|
>
|
>
>
|
>
|
>
>
>
>
>
>
>

|
|
|


<
|
|
|
|
<
<
|
<
<
<
<
>
>
|
<
<
>

>
>
>
<
|
>
|
|
|
|
<
<
<
<
|
|
|
|
<
|
|
|
>
|
<
|
>
>
>
>
|
>
>


|
|
>









>
|
>






|

|
|
|
|
|
|
|


>
|
>

|
|
|
|


|
>



>
|
|
>





<
|
<
|
<
<
|
<
<
|
<
|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683

684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711

712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863

864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968

969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995

996
997
998
999
1000
1001
1002

1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017

1018
1019
1020
1021
1022

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088

1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127

1128
1129
1130
1131


1132




1133
1134
1135


1136
1137
1138
1139
1140

1141
1142
1143
1144
1145
1146




1147
1148
1149
1150

1151
1152
1153
1154
1155

1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221

1222

1223


1224


1225

1226

1227


















    if (wide) {
	tclWinProcs = &unicodeProcs;
	tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileAttributesExProc = 
			(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
			LPVOID)) GetProcAddress(hInstance,
			"GetFileAttributesExW");
		tclWinProcs->createHardLinkProc = 
			(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, 
			LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, 
			"CreateHardLinkW");
		tclWinProcs->findFirstFileExProc = 
			(HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT,
			LPVOID, DWORD)) GetProcAddress(hInstance, 
			"FindFirstFileExW");
		tclWinProcs->getVolumeNameForVMPProc = 
			(BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, 
			DWORD)) GetProcAddress(hInstance, 
			"GetVolumeNameForVolumeMountPointW");
		tclWinProcs->getLongPathNameProc = 
			(DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, 
			DWORD)) GetProcAddress(hInstance, "GetLongPathNameW");

		FreeLibrary(hInstance);
	    }
	    hInstance = LoadLibraryA("advapi32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)(
			LPCTSTR lpFileName, 
			SECURITY_INFORMATION RequestedInformation,
			PSECURITY_DESCRIPTOR pSecurityDescriptor,
			DWORD nLength, LPDWORD lpnLengthNeeded))
			GetProcAddress(hInstance, "GetFileSecurityW"); 
		tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) (
			SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) 
			GetProcAddress(hInstance, "ImpersonateSelf");
		tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) (
			HANDLE ThreadHandle, DWORD DesiredAccess,
			BOOL OpenAsSelf, PHANDLE TokenHandle))
			GetProcAddress(hInstance, "OpenThreadToken");
		tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void)) 
			GetProcAddress(hInstance, "RevertToSelf");
		tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) (
			PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) 
			GetProcAddress(hInstance, "MapGenericMask");
		tclWinProcs->accessCheckProc = (BOOL (WINAPI *)(
			PSECURITY_DESCRIPTOR pSecurityDescriptor, 
			HANDLE ClientToken, DWORD DesiredAccess,
			PGENERIC_MAPPING GenericMapping,
			PPRIVILEGE_SET PrivilegeSet,
			LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess,

			LPBOOL AccessStatus)) GetProcAddress(hInstance, 
			"AccessCheck");
		FreeLibrary(hInstance);
	    }
	}
    } else {
	tclWinProcs = &asciiProcs;
	tclWinTCharEncoding = NULL;
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileAttributesExProc = 
			(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
			LPVOID)) GetProcAddress(hInstance,
			"GetFileAttributesExA");
		tclWinProcs->createHardLinkProc = 
			(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, 
			LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, 
			"CreateHardLinkA");
		tclWinProcs->findFirstFileExProc = NULL;
		tclWinProcs->getLongPathNameProc = NULL;
		/*
		 * The 'findFirstFileExProc' function exists on some of
		 * 95/98/ME, but it seems not to work as anticipated.
		 * Therefore we don't set this function pointer. The relevant
		 * code will fall back on a slower approach using the normal
		 * findFirstFileProc.
		 * 
		 * (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
		 * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, 
		 * "FindFirstFileExA");
		 */
		tclWinProcs->getVolumeNameForVMPProc = 
			(BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, 
			DWORD)) GetProcAddress(hInstance, 
			"GetVolumeNameForVolumeMountPointA");
		FreeLibrary(hInstance);
	    }
	}
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinResetInterfaceEncodings --
 *
 *	Called during finalization to free up any encodings we use. The
 *	tclWinProcs-> look up table is still ok to use after this call,
 *	provided no encoding conversion is required.
 *
 *	We also clean up any memory allocated in our mount point map which is
 *	used to follow certain kinds of symlinks. That code should never be
 *	used once encodings are taken down.

 *	
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclWinResetInterfaceEncodings()
{
    MountPointMap *dlIter, *dlIter2;
    if (tclWinTCharEncoding != NULL) {
	Tcl_FreeEncoding(tclWinTCharEncoding);
	tclWinTCharEncoding = NULL;
    }

    /*
     * Clean up the mount point map.
     */

    Tcl_MutexLock(&mountPointMap);
    dlIter = driveLetterLookup; 
    while (dlIter != NULL) {
	dlIter2 = dlIter->nextPtr;
	ckfree((char*)dlIter->volumeName);
	ckfree((char*)dlIter);
	dlIter = dlIter2;
    }
    Tcl_MutexUnlock(&mountPointMap);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinResetInterfaces --
 *
 *	Called during finalization to reset us to a safe state for reuse.
 *	After this call, it is best not to use the tclWinProcs-> look up table
 *	since it is likely to be different to what is expected.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
void
TclWinResetInterfaces()
{
    tclWinProcs = &asciiProcs;
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinDriveLetterForVolMountPoint
 *
 *	Unfortunately, Windows provides no easy way at all to get hold of the
 *	drive letter for a volume mount point, but we need that information to
 *	understand paths correctly. So, we have to build an associated array
 *	to find these correctly, and allow quick and easy lookup from volume
 *	mount points to drive letters.
 * 
 *	We assume here that we are running on a system for which the wide
 *	character interfaces are used, which is valid for Win 2000 and WinXP
 *	which are the only systems on which this function will ever be called.
 * 
 * Result:
 *	The drive letter, or -1 if no drive letter corresponds to the given
 *	mount point.
 * 
 *--------------------------------------------------------------------
 */

char 
TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint)
{
    MountPointMap *dlIter, *dlPtr2;
    WCHAR Target[55];		/* Target of mount at mount point */
    WCHAR drive[4] = { L'A', L':', L'\\', L'\0' };
    
    /* 
     * Detect the volume mounted there. Unfortunately, there is no simple way
     * to map a unique volume name to a DOS drive letter. So, we have to build
     * an associative array.
     */
    
    Tcl_MutexLock(&mountPointMap);
    dlIter = driveLetterLookup; 
    while (dlIter != NULL) {
	if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
	    /* 
	     * We need to check whether this information is still valid, since

	     * either the user or various programs could have adjusted the
	     * mount points on the fly.
	     */

	    drive[0] = L'A' + (dlIter->driveLetter - 'A');

	    /*
	     * Try to read the volume mount point and see where it points.
	     */

	    if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, 
		    (TCHAR*)Target, 55) != 0) {
		if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
		    /*
		     * Nothing has changed.
		     */

		    Tcl_MutexUnlock(&mountPointMap);
		    return dlIter->driveLetter;
		}
	    }

	    /* 
	     * If we reach here, unfortunately, this mount point is no longer
	     * valid at all.
	     */

	    if (driveLetterLookup == dlIter) {
		dlPtr2 = dlIter;
		driveLetterLookup = dlIter->nextPtr;
	    } else {
		for (dlPtr2 = driveLetterLookup; 
			dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) {
		    if (dlPtr2->nextPtr == dlIter) {
			dlPtr2->nextPtr = dlIter->nextPtr;
			dlPtr2 = dlIter;
			break;
		    }
		}
	    }

	    /*
	     * Now dlPtr2 points to the structure to free.
	     */

	    ckfree((char*)dlPtr2->volumeName);
	    ckfree((char*)dlPtr2);

	    /* 
	     * Restart the loop - we could try to be clever and continue half
	     * way through, but the logic is a bit messy, so it's cleanest
	     * just to restart.
	     */

	    dlIter = driveLetterLookup;
	    continue;
	}
	dlIter = dlIter->nextPtr;
    }
   
    /*
     * We couldn't find it, so we must iterate over the letters.
     */
    
    for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) {
	/*
	 * Try to read the volume mount point and see where it points.
	 */

	if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, 
		(TCHAR*)Target, 55) != 0) {
	    int alreadyStored = 0;

	    for (dlIter = driveLetterLookup; dlIter != NULL; 
		    dlIter = dlIter->nextPtr) {
		if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
		    alreadyStored = 1;
		    break;
		}
	    }
	    if (!alreadyStored) {
		dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap));
		dlPtr2->volumeName = TclNativeDupInternalRep(Target);
		dlPtr2->driveLetter = 'A' + (drive[0] - L'A');
		dlPtr2->nextPtr = driveLetterLookup;
		driveLetterLookup  = dlPtr2;
	    }
	}
    }

    /*
     * Try again.
     */

    for (dlIter = driveLetterLookup; dlIter != NULL; 
	    dlIter = dlIter->nextPtr) {
	if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
	    Tcl_MutexUnlock(&mountPointMap);
	    return dlIter->driveLetter;
	}
    }

    /* 
     * The volume doesn't appear to correspond to a drive letter - we remember
     * that fact and store '-1' so we don't have to look it up each time.

     */

    dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
    dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint);
    dlPtr2->driveLetter = -1;
    dlPtr2->nextPtr = driveLetterLookup;
    driveLetterLookup  = dlPtr2;
    Tcl_MutexUnlock(&mountPointMap);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
 *
 *	Convert between UTF-8 and Unicode when running Windows NT or the
 *	current ANSI code page when running Windows 95.
 *
 *	On Mac, Unix, and Windows 95, all strings exchanged between Tcl and
 *	the OS are "char" oriented. We need only one Tcl_Encoding to convert
 *	between UTF-8 and the system's native encoding. We use NULL to
 *	represent that encoding.
 *
 *	On NT, some strings exchanged between Tcl and the OS are "char"
 *	oriented, while others are in Unicode. We need two Tcl_Encoding APIs
 *	depending on whether we are targeting a "char" or Unicode interface.

 *
 *	Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of
 *	NULL should always used to convert between UTF-8 and the system's
 *	"char" oriented encoding. The following two functions are used in
 *	Windows-specific code to convert between UTF-8 and Unicode strings
 *	(NT) or "char" strings(95). This saves you the trouble of writing the
 *	following type of fragment over and over:

 *
 *		if (running NT) {
 *		    encoding <- Tcl_GetEncoding("unicode");
 *		    nativeBuffer <- UtfToExternal(encoding, utfBuffer);
 *		    Tcl_FreeEncoding(encoding);
 *		} else {
 *		    nativeBuffer <- UtfToExternal(NULL, utfBuffer);
 *		}
 *
 *	By convention, in Windows a TCHAR is a character in the ANSI code page
 *	on Windows 95, a Unicode character on Windows NT. If you plan on
 *	targeting a Unicode interfaces when running on NT and a "char"
 *	oriented interface while running on 95, these functions should be
 *	used. If you plan on targetting the same "char" oriented function on
 *	both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL.

 *
 * Results:
 *	The result is a pointer to the string in the desired target encoding.
 *	Storage for the result string is allocated in dsPtr; the caller must
 *	call Tcl_DStringFree() when the result is no longer needed.

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

TCHAR *
Tcl_WinUtfToTChar(string, len, dsPtr)
    CONST char *string;		/* Source string in UTF-8. */
    int len;			/* Source string length in bytes, or < 0 for
				 * strlen(). */
    Tcl_DString *dsPtr;		/* Uninitialized or free DString in which the
				 * converted string is stored. */
{
    return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, 
	    string, len, dsPtr);
}

char *
Tcl_WinTCharToUtf(string, len, dsPtr)
    CONST TCHAR *string;	/* Source string in Unicode when running NT,
				 * ANSI when running 95. */
    int len;			/* Source string length in bytes, or < 0 for
				 * platform-specific string length. */
    Tcl_DString *dsPtr;		/* Uninitialized or free DString in which the
				 * converted string is stored. */
{
    return Tcl_ExternalToUtfDString(tclWinTCharEncoding, 
	    (CONST char *) string, len, dsPtr);
}

/*
 *------------------------------------------------------------------------
 *
 * TclWinCPUID --
 *
 *	Get CPU ID information on an Intel box under Windows
 *
 * Results:
 *	Returns TCL_OK if successful, TCL_ERROR if CPUID is not supported or
 *	fails.
 *
 * Side effects:
 *	If successful, stores EAX, EBX, ECX and EDX registers after the CPUID
 *	instruction in the four integers designated by 'regsPtr'
 *
 *----------------------------------------------------------------------
 */

int
TclWinCPUID(
    unsigned int index,		/* Which CPUID value to retrieve. */
    unsigned int *regsPtr)	/* Registers after the CPUID. */
{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    int status = TCL_ERROR;

#if defined(__GNUC__) && !defined(_WIN64)
    /* 
     * Execute the CPUID instruction with the given index, and store results
     * off 'regPtr'.
     */
    

    __asm__ __volatile__(
	/*
	 * Construct an EXCEPTION_REGISTRATION to protect the CPUID
	 * instruction (early 486's don't have CPUID)
	 */

	"leal	%[registration], %%edx"		"\n\t"
	"movl	%%fs:0,		%%eax"		"\n\t"
	"movl	%%eax,		0x0(%%edx)"	"\n\t" /* link */
	"leal	1f,		%%eax"		"\n\t"
	"movl	%%eax,		0x4(%%edx)"	"\n\t" /* handler */
	"movl	%%ebp,		0x8(%%edx)"	"\n\t" /* ebp */
	"movl	%%esp,		0xc(%%edx)"	"\n\t" /* esp */
	"movl	%[error],	0x10(%%edx)"	"\n\t" /* status */
	
	/*
	 * Link the EXCEPTION_REGISTRATION on the chain
	 */

	"movl	%%edx,		%%fs:0"		"\n\t"

	/*
	 * Do the CPUID instruction, and save the results in the 'regsPtr'
	 * area.
	 */

	"movl	%[rptr],	%%edi"		"\n\t"
	"movl	%[index],	%%eax"		"\n\t"
	"cpuid"					"\n\t"
	"movl	%%eax,		0x0(%%edi)"	"\n\t"
	"movl	%%ebx,		0x4(%%edi)"	"\n\t"
	"movl	%%ecx,		0x8(%%edi)"	"\n\t"
	"movl	%%edx,		0xc(%%edi)"	"\n\t"

	/*
	 * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and
	 * store a TCL_OK status.
	 */


	"movl	%%fs:0,		%%edx"		"\n\t"
	"movl	%[ok],		%%eax"		"\n\t"
	"movl	%%eax,		0x10(%%edx)"	"\n\t"
	"jmp	2f"				"\n"







	/*
	 * Come here on an exception. Get the EXCEPTION_REGISTRATION that we
	 * previously put on the chain.


	 */

	"1:"					"\t"
	"movl	%%fs:0,		%%edx"		"\n\t"
	"movl	0x8(%%edx),	%%edx"		"\n\t"

	
	/* 
	 * Come here however we exited. Restore context from the
	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	 */
	




	"2:"					"\t"
	"movl	0xc(%%edx),	%%esp"		"\n\t"
	"movl	0x8(%%edx),	%%ebp"		"\n\t"
	"movl	0x0(%%edx),	%%eax"		"\n\t"

	"movl	%%eax,		%%fs:0"		"\n\t"

	: 
	/* No outputs */
	: 

	[index]		"m"	(index),
	[rptr]		"m"	(regsPtr),
	[registration]	"m"	(registration),
	[ok]		"i"	(TCL_OK),
	[error]		"i"	(TCL_ERROR)
	:
	"%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory");
    status = registration.status;

#elif defined(_MSC_VER) && !defined(_WIN64)
    /*
     * Define a structure in the stack frame to hold the registers.
     */

    struct {
	DWORD dw0;
	DWORD dw1;
	DWORD dw2;
	DWORD dw3;
    } regs;
    regs.dw0 = index;
    
    /*
     * Execute the CPUID instruction and save regs in the stack frame.
     */

    _try {
	_asm {
	    push    ebx
	    push    ecx
	    push    edx
	    mov	    eax, regs.dw0
	    cpuid
	    mov	    regs.dw0, eax
	    mov	    regs.dw1, ebx
	    mov	    regs.dw2, ecx
	    mov	    regs.dw3, edx
	    pop	    edx
	    pop	    ecx
	    pop	    ebx
	}
	
	/*
	 * Copy regs back out to the caller.
	 */

	regsPtr[0] = regs.dw0;
	regsPtr[1] = regs.dw1;
	regsPtr[2] = regs.dw2;
	regsPtr[3] = regs.dw3;

	status = TCL_OK;
    } __except(EXCEPTION_EXECUTE_HANDLER) {
	/* do nothing */
    }

#else
    /*
     * Don't know how to do assembly code for this compiler and/or
     * architecture.
     */
#endif
    return status;
}

/*

 * Local Variables:

 * mode: c


 * c-basic-offset: 4


 * fill-column: 78

 * End:

 */

















Changes to win/tclWinChan.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclWinChan.c
 *
 *	Channel drivers for Windows channels based on files, command
 *	pipes and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinChan.c,v 1.37 2004/10/20 14:50:44 dkf Exp $
 */

#include "tclWinInt.h"
#include "tclIO.h"

/*
 * State flags used in the info structures below.



|
|



|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclWinChan.c
 *
 *	Channel drivers for Windows channels based on files, command pipes and
 *	TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinChan.c,v 1.37.2.4 2005/08/02 18:17:00 dgp Exp $
 */

#include "tclWinInt.h"
#include "tclIO.h"

/*
 * State flags used in the info structures below.
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97


98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121


122
123
124
125
126
127




128
129

130
131
132
133


134
135
136
137
138
139
140
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    HANDLE handle;		/* Input/output file. */
    struct FileInfo *nextPtr;	/* Pointer to next registered file. */
    int dirty;			/* Boolean flag. Set if the OS may have data
				 * pending on the channel */
} FileInfo;

typedef struct ThreadSpecificData {
    /*
     * List of all file channels currently open.
     */

    FileInfo *firstFilePtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when
 * file events are generated.
 */

typedef struct FileEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    FileInfo *infoPtr;		/* Pointer to file info structure.  Note
				 * that we still have to verify that the
				 * file exists before dereferencing this
				 * pointer. */
} FileEvent;

/*
 * Static routines for this file:
 */

static int		FileBlockProc _ANSI_ARGS_((ClientData instanceData,
			    int mode));
static void		FileChannelExitHandler _ANSI_ARGS_((
			    ClientData clientData));
static void		FileCheckProc _ANSI_ARGS_((ClientData clientData,
			    int flags));
static int		FileCloseProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_Interp *interp));
static int		FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
			    int flags));
static int		FileGetHandleProc _ANSI_ARGS_((ClientData instanceData,
			    int direction, ClientData *handlePtr));
static ThreadSpecificData *FileInit _ANSI_ARGS_((void));
static int		FileInputProc _ANSI_ARGS_((ClientData instanceData,
			    char *buf, int toRead, int *errorCode));
static int		FileOutputProc _ANSI_ARGS_((ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode));
static int		FileSeekProc _ANSI_ARGS_((ClientData instanceData,
			    long offset, int mode, int *errorCode));
static Tcl_WideInt	FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
			    Tcl_WideInt offset, int mode, int *errorCode));
static void		FileSetupProc _ANSI_ARGS_((ClientData clientData,


			    int flags));
static void		FileWatchProc _ANSI_ARGS_((ClientData instanceData,
			    int mask));

/*
 * This structure describes the channel type structure for file based IO.
 */

static Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_3,	/* v3 channel */
    FileCloseProc,		/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
    FileSeekProc,		/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    FileWatchProc,		/* Set up the notifier to watch the channel. */
    FileGetHandleProc,		/* Get an OS handle from channel. */
    NULL,			/* close2proc. */
    FileBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* Wide seek proc. */


};

#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG)
static void *INITIAL_ESP, *INITIAL_EBP, *INITIAL_HANDLER;
static void *RESTORED_ESP, *RESTORED_EBP, *RESTORED_HANDLER;
#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */





#ifdef HAVE_NO_SEH

static __attribute__ ((cdecl)) EXCEPTION_DISPOSITION
_except_makefilechannel_handler(struct _EXCEPTION_RECORD *ExceptionRecord,
	void *EstablisherFrame, struct _CONTEXT *ContextRecord,
	void *DispatcherContext);


#endif

/*
 *----------------------------------------------------------------------
 *
 * FileInit --
 *







|













|
|



|
|
|
|
|







|
<
|
|
<
<
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|







|













>
>


|
<
<
|
>
>
>
>

|
>
|
|
|
|
>
>







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

77
78


79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124


125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    HANDLE handle;		/* Input/output file. */
    struct FileInfo *nextPtr;	/* Pointer to next registered file. */
    int dirty;			/* Boolean flag. Set if the OS may have data
				 * pending on the channel. */
} FileInfo;

typedef struct ThreadSpecificData {
    /*
     * List of all file channels currently open.
     */

    FileInfo *firstFilePtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when file
 * events are generated.
 */

typedef struct FileEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    FileInfo *infoPtr;		/* Pointer to file info structure. Note that
				 * we still have to verify that the file
				 * exists before dereferencing this
				 * pointer. */
} FileEvent;

/*
 * Static routines for this file:
 */

static int		FileBlockProc(ClientData instanceData, int mode);

static void		FileChannelExitHandler(ClientData clientData);
static void		FileCheckProc(ClientData clientData, int flags);


static int		FileCloseProc(ClientData instanceData,
			    Tcl_Interp *interp);
static int		FileEventProc(Tcl_Event *evPtr, int flags);

static int		FileGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static ThreadSpecificData *FileInit(void);
static int		FileInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		FileOutputProc(ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode);
static int		FileSeekProc(ClientData instanceData, long offset,
			    int mode, int *errorCode);
static Tcl_WideInt	FileWideSeekProc(ClientData instanceData,
			    Tcl_WideInt offset, int mode, int *errorCode);
static void		FileSetupProc(ClientData clientData, int flags);
static void		FileWatchProc(ClientData instanceData, int mask);
static void		FileThreadActionProc(ClientData instanceData,
			    int action);
static int		FileTruncateProc(ClientData instanceData,
			    Tcl_WideInt length);

/*
 * This structure describes the channel type structure for file based IO.
 */

static Tcl_ChannelType fileChannelType = {
    "file",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    FileCloseProc,		/* Close proc. */
    FileInputProc,		/* Input proc. */
    FileOutputProc,		/* Output proc. */
    FileSeekProc,		/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    FileWatchProc,		/* Set up the notifier to watch the channel. */
    FileGetHandleProc,		/* Get an OS handle from channel. */
    NULL,			/* close2proc. */
    FileBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* Wide seek proc. */
    FileThreadActionProc,	/* Thread action proc. */
    FileTruncateProc,		/* Truncate proc. */
};

#ifdef HAVE_NO_SEH


/*
 * Unlike Borland and Microsoft, we don't register exception handlers by
 * pushing registration records onto the runtime stack. Instead, we register
 * them by creating an EXCEPTION_REGISTRATION within the activation record.
 */

typedef struct EXCEPTION_REGISTRATION {
    struct EXCEPTION_REGISTRATION* link;
    EXCEPTION_DISPOSITION (*handler)(
	    struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
    void* ebp;
    void* esp;
    int status;
} EXCEPTION_REGISTRATION;
#endif

/*
 *----------------------------------------------------------------------
 *
 * FileInit --
 *
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
}

/*
 *----------------------------------------------------------------------
 *
 * FileChannelExitHandler --
 *
 *	This function is called to cleanup the channel driver before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys the communication window.
 *







|
|







170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
}

/*
 *----------------------------------------------------------------------
 *
 * FileChannelExitHandler --
 *
 *	This function is called to cleanup the channel driver before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys the communication window.
 *
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
}

/*
 *----------------------------------------------------------------------
 *
 * FileSetupProc --
 *
 *	This procedure is invoked before Tcl_DoOneEvent blocks waiting
 *	for an event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
 *----------------------------------------------------------------------
 */

void
FileSetupProc(data, flags)
    ClientData data;			/* Not used. */
    int flags;				/* Event flags as passed to
					 * Tcl_DoOneEvent. */
{
    FileInfo *infoPtr;
    Tcl_Time blockTime = { 0, 0 };
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Check to see if there is a ready file.  If so, poll.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask) {
	    Tcl_SetMaxBlockTime(&blockTime);
	    break;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the file
 *	event source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
 *----------------------------------------------------------------------
 */

static void
FileCheckProc(data, flags)
    ClientData data;			/* Not used. */
    int flags;				/* Event flags as passed to
					 * Tcl_DoOneEvent. */
{
    FileEvent *evPtr;
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Queue events for any ready files that don't already have events
     * queued (caused by persistent states that won't generate WinSock
     * events).
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
	    infoPtr->flags |= FILE_PENDING;
	    evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
	    evPtr->header.proc = FileEventProc;
	    evPtr->infoPtr = infoPtr;
	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event
 *	reaches the front of the event queue.  This procedure invokes
 *	Tcl_NotifyChannel on the file.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

static int
FileEventProc(evPtr, flags)
    Tcl_Event *evPtr;			/* Event to service. */
    int flags;				/* Flags that indicate what events to
					 * handle, such as TCL_FILE_EVENTS. */
{
    FileEvent *fileEvPtr = (FileEvent *)evPtr;
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched files for the one whose handle
     * matches the event.  We do this rather than simply dereferencing
     * the handle in the event so that files can be deleted while the
     * event is in the queue.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (fileEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(FILE_PENDING);
	    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);







|
|












|
|
<










|
















|
|












|
|
<










|
|
<



















|
|
|


|
|
|
|









|
|
|











|
|
|







194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259

260
261
262
263
264
265
266
267
268
269
270
271

272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
}

/*
 *----------------------------------------------------------------------
 *
 * FileSetupProc --
 *
 *	This function is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
 *----------------------------------------------------------------------
 */

void
FileSetupProc(data, flags)
    ClientData data;		/* Not used. */
    int flags;			/* Event flags as passed to Tcl_DoOneEvent. */

{
    FileInfo *infoPtr;
    Tcl_Time blockTime = { 0, 0 };
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Check to see if there is a ready file. If so, poll.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask) {
	    Tcl_SetMaxBlockTime(&blockTime);
	    break;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the file event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
 *----------------------------------------------------------------------
 */

static void
FileCheckProc(data, flags)
    ClientData data;		/* Not used. */
    int flags;			/* Event flags as passed to Tcl_DoOneEvent. */

{
    FileEvent *evPtr;
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Queue events for any ready files that don't already have events queued
     * (caused by persistent states that won't generate WinSock events).

     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
	    infoPtr->flags |= FILE_PENDING;
	    evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
	    evPtr->header.proc = FileEventProc;
	    evPtr->infoPtr = infoPtr;
	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This function invokes Tcl_NotifyChannel
 *	on the file.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

static int
FileEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    FileEvent *fileEvPtr = (FileEvent *)evPtr;
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched files for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that files can be deleted while the event is in
     * the queue.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (fileEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(FILE_PENDING);
	    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

static int
FileBlockProc(instanceData, mode)
    ClientData instanceData;		/* Instance data for channel. */
    int mode;				/* TCL_MODE_BLOCKING or
					 * TCL_MODE_NONBLOCKING. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;

    /*
     * Files on Windows can not be switched between blocking and nonblocking,
     * hence we have to emulate the behavior. This is done in the input
     * function by checking against a bit in the state. We set or unset the







|
|
|







350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
 *	Sets the device into blocking or non-blocking mode.
 *
 *----------------------------------------------------------------------
 */

static int
FileBlockProc(instanceData, mode)
    ClientData instanceData;	/* Instance data for channel. */
    int mode;			/* TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;

    /*
     * Files on Windows can not be switched between blocking and nonblocking,
     * hence we have to emulate the behavior. This is done in the input
     * function by checking against a bit in the state. We set or unset the
387
388
389
390
391
392
393
394
395
396
397


398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421



















422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

467
468
469
470
471
472
473
 *	Closes the physical channel
 *
 *----------------------------------------------------------------------
 */

static int
FileCloseProc(instanceData, interp)
    ClientData instanceData;		/* Pointer to FileInfo structure. */
    Tcl_Interp *interp;			/* Not used. */
{
    FileInfo *fileInfoPtr = (FileInfo *) instanceData;


    int errorCode = 0;

    /*
     * Remove the file from the watch list.
     */

    FileWatchProc(instanceData, 0);

    /*
     * Don't close the Win32 handle if the handle is a standard channel
     * during the thread exit process.  Otherwise, one thread may kill
     * the stdio of another.
     */

    if (!TclInThreadExit()
	    || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle)
	    &&  (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle)
	    &&  (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
	if (CloseHandle(fileInfoPtr->handle) == FALSE) {
	    TclWinConvertError(GetLastError());
	    errorCode = errno;
	}
    }




















    ckfree((char *)fileInfoPtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * FileSeekProc --
 *
 *	Seeks on a file-based channel. Returns the new position.
 *
 * Results:
 *	-1 if failed, the new position if successful. If failed, it
 *	also sets *errorCodePtr to the error code.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in
 *	future operations.
 *
 *----------------------------------------------------------------------
 */

static int
FileSeekProc(instanceData, offset, mode, errorCodePtr)
    ClientData instanceData;		/* File state. */
    long offset;			/* Offset to seek to. */
    int mode;				/* Relative to where should we seek? */
    int *errorCodePtr;			/* To store error code. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    LONG newPos, newPosHigh, oldPos, oldPosHigh;
    DWORD moveMethod;

    *errorCodePtr = 0;
    if (mode == SEEK_SET) {
	moveMethod = FILE_BEGIN;
    } else if (mode == SEEK_CUR) {
	moveMethod = FILE_CURRENT;
    } else {
	moveMethod = FILE_END;
    }

    /*
     * Save our current place in case we need to roll-back the seek.
     */

    oldPosHigh = 0;
    oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
    if (oldPos == INVALID_SET_FILE_POINTER) {
	DWORD winError = GetLastError();

	if (winError != NO_ERROR) {
	    TclWinConvertError(winError);







|
|


>
>









|
|
|












>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












|
|


|
|






|
|
|
|

















>







389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
 *	Closes the physical channel
 *
 *----------------------------------------------------------------------
 */

static int
FileCloseProc(instanceData, interp)
    ClientData instanceData;	/* Pointer to FileInfo structure. */
    Tcl_Interp *interp;		/* Not used. */
{
    FileInfo *fileInfoPtr = (FileInfo *) instanceData;
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr;
    int errorCode = 0;

    /*
     * Remove the file from the watch list.
     */

    FileWatchProc(instanceData, 0);

    /*
     * Don't close the Win32 handle if the handle is a standard channel during
     * the thread exit process. Otherwise, one thread may kill the stdio of
     * another.
     */

    if (!TclInThreadExit()
	    || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle)
	    &&  (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle)
	    &&  (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
	if (CloseHandle(fileInfoPtr->handle) == FALSE) {
	    TclWinConvertError(GetLastError());
	    errorCode = errno;
	}
    }

    /*
     * See if this FileInfo* is still on the thread local list.
     */

    tsdPtr = TCL_TSD_INIT(&dataKey);
    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr == fileInfoPtr) {
	    /*
	     * This channel exists on the thread local list. It should have
	     * been removed by an earlier Threadaction call, but do that now
	     * since just deallocating fileInfoPtr would leave an deallocated
	     * pointer on the thread local list.
	     */

	    FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
	    break;
	}
    }
    ckfree((char *)fileInfoPtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * FileSeekProc --
 *
 *	Seeks on a file-based channel. Returns the new position.
 *
 * Results:
 *	-1 if failed, the new position if successful. If failed, it also sets
 *	*errorCodePtr to the error code.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in future
 *	operations.
 *
 *----------------------------------------------------------------------
 */

static int
FileSeekProc(instanceData, offset, mode, errorCodePtr)
    ClientData instanceData;	/* File state. */
    long offset;		/* Offset to seek to. */
    int mode;			/* Relative to where should we seek? */
    int *errorCodePtr;		/* To store error code. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    LONG newPos, newPosHigh, oldPos, oldPosHigh;
    DWORD moveMethod;

    *errorCodePtr = 0;
    if (mode == SEEK_SET) {
	moveMethod = FILE_BEGIN;
    } else if (mode == SEEK_CUR) {
	moveMethod = FILE_CURRENT;
    } else {
	moveMethod = FILE_END;
    }

    /*
     * Save our current place in case we need to roll-back the seek.
     */

    oldPosHigh = 0;
    oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
    if (oldPos == INVALID_SET_FILE_POINTER) {
	DWORD winError = GetLastError();

	if (winError != NO_ERROR) {
	    TclWinConvertError(winError);
487
488
489
490
491
492
493

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
	    return -1;
	}
    }

    /*
     * Check for expressability in our return type, and roll-back otherwise.
     */

    if (newPosHigh != 0) {
	*errorCodePtr = EOVERFLOW;
	SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
	return -1;
    }
    return (int) newPos;
}

/*
 *----------------------------------------------------------------------
 *
 * FileWideSeekProc --
 *
 *	Seeks on a file-based channel. Returns the new position.
 *
 * Results:
 *	-1 if failed, the new position if successful. If failed, it
 *	also sets *errorCodePtr to the error code.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in
 *	future operations.
 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
    ClientData instanceData;		/* File state. */
    Tcl_WideInt offset;			/* Offset to seek to. */
    int mode;				/* Relative to where should we seek? */
    int *errorCodePtr;			/* To store error code. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    DWORD moveMethod;
    LONG newPos, newPosHigh;

    *errorCodePtr = 0;
    if (mode == SEEK_SET) {







>
















|
|


|
|






|
|
|
|







511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
	    return -1;
	}
    }

    /*
     * Check for expressability in our return type, and roll-back otherwise.
     */

    if (newPosHigh != 0) {
	*errorCodePtr = EOVERFLOW;
	SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
	return -1;
    }
    return (int) newPos;
}

/*
 *----------------------------------------------------------------------
 *
 * FileWideSeekProc --
 *
 *	Seeks on a file-based channel. Returns the new position.
 *
 * Results:
 *	-1 if failed, the new position if successful. If failed, it also sets
 *	*errorCodePtr to the error code.
 *
 * Side effects:
 *	Moves the location at which the channel will be accessed in future
 *	operations.
 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
    ClientData instanceData;	/* File state. */
    Tcl_WideInt offset;		/* Offset to seek to. */
    int mode;			/* Relative to where should we seek? */
    int *errorCodePtr;		/* To store error code. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    DWORD moveMethod;
    LONG newPos, newPosHigh;

    *errorCodePtr = 0;
    if (mode == SEEK_SET) {
551
552
553
554
555
556
557








































































558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
    }
    return (Tcl_LongAsWide(newPos) | (Tcl_LongAsWide(newPosHigh) << 32));
}

/*
 *----------------------------------------------------------------------
 *








































































 * FileInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns
 *	count of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileInputProc(instanceData, buf, bufSize, errorCode)
    ClientData instanceData;		/* File state. */
    char *buf;				/* Where to store data read. */
    int bufSize;			/* Num bytes available in buffer. */
    int *errorCode;			/* Where to store error code. */
{
    FileInfo *infoPtr;
    DWORD bytesRead;

    *errorCode = 0;
    infoPtr = (FileInfo *) instanceData;

    /*
     * Note that we will block on reads from a console buffer until a
     * full line has been entered.  The only way I know of to get
     * around this is to write a console driver.  We should probably
     * do this at some point, but for now, we just block.  The same
     * problem exists for files being read over the network.
     */

    if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
	    (LPOVERLAPPED) NULL) != FALSE) {
	return bytesRead;
    }

    TclWinConvertError(GetLastError());
    *errorCode = errno;
    if (errno == EPIPE) {
	return 0;
    }
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * FileOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how
 *	many characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an
 *	error indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileOutputProc(instanceData, buf, toWrite, errorCode)
    ClientData instanceData;		/* File state. */
    CONST char *buf;			/* The data buffer. */
    int toWrite;			/* How many bytes to write? */
    int *errorCode;			/* Where to store error code. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    DWORD bytesWritten;

    *errorCode = 0;

    /*







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|













|
|
|
|








|
|
|
|
|




















|
|


|
|









|
|
|
|







576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
    }
    return (Tcl_LongAsWide(newPos) | (Tcl_LongAsWide(newPosHigh) << 32));
}

/*
 *----------------------------------------------------------------------
 *
 * FileTruncateProc --
 *
 *	Truncates a file-based channel. Returns the error code.
 *
 * Results:
 *	0 if successful, POSIX-y error code if it failed.
 *
 * Side effects:
 *	Truncates the file, may move file pointers too.
 *
 *----------------------------------------------------------------------
 */

static int
FileTruncateProc(instanceData, length)
    ClientData instanceData;	/* File state. */
    Tcl_WideInt length;		/* Length to truncate at. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    LONG newPos, newPosHigh, oldPos, oldPosHigh;

    /*
     * Save where we were...
     */

    oldPosHigh = 0;
    oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
    if (oldPos == INVALID_SET_FILE_POINTER) {
	DWORD winError = GetLastError();
	if (winError != NO_ERROR) {
	    TclWinConvertError(winError);
	    return errno;
	}
    }

    /*
     * Move to where we want to truncate
     */

    newPosHigh = Tcl_WideAsLong(length >> 32);
    newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length),
	    &newPosHigh, FILE_BEGIN);
    if (newPos == INVALID_SET_FILE_POINTER) {
	DWORD winError = GetLastError();
	if (winError != NO_ERROR) {
	    TclWinConvertError(winError);
	    return errno;
	}
    }

    /*
     * Perform the truncation (unlike POSIX ftruncate(), we needed to move to
     * the location to truncate at first).
     */

    if (!SetEndOfFile(infoPtr->handle)) {
	TclWinConvertError(GetLastError());
	return errno;
    }

    /*
     * Move back. If this last step fails, we don't care; it's just a "best
     * effort" attempt to restore our file pointer to where it was.
     */

    SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * FileInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns count
 *	of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileInputProc(instanceData, buf, bufSize, errorCode)
    ClientData instanceData;	/* File state. */
    char *buf;			/* Where to store data read. */
    int bufSize;		/* Num bytes available in buffer. */
    int *errorCode;		/* Where to store error code. */
{
    FileInfo *infoPtr;
    DWORD bytesRead;

    *errorCode = 0;
    infoPtr = (FileInfo *) instanceData;

    /*
     * Note that we will block on reads from a console buffer until a full
     * line has been entered. The only way I know of to get around this is to
     * write a console driver. We should probably do this at some point, but
     * for now, we just block. The same problem exists for files being read
     * over the network.
     */

    if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
	    (LPOVERLAPPED) NULL) != FALSE) {
	return bytesRead;
    }

    TclWinConvertError(GetLastError());
    *errorCode = errno;
    if (errno == EPIPE) {
	return 0;
    }
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * FileOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how many
 *	characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
FileOutputProc(instanceData, buf, toWrite, errorCode)
    ClientData instanceData;	/* File state. */
    CONST char *buf;		/* The data buffer. */
    int toWrite;		/* How many bytes to write? */
    int *errorCode;		/* Where to store error code. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    DWORD bytesWritten;

    *errorCode = 0;

    /*
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
}

/*
 *----------------------------------------------------------------------
 *
 * FileWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this
 *	channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FileWatchProc(instanceData, mask)
    ClientData instanceData;		/* File state. */
    int mask;				/* What events to watch for; OR-ed
					 * combination of TCL_READABLE,
					 * TCL_WRITABLE and TCL_EXCEPTION. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    Tcl_Time blockTime = { 0, 0 };

    /*
     * Since the file is always ready for events, we set the block time
     * to zero so we will poll.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_SetMaxBlockTime(&blockTime);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from
 *	a file based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
FileGetHandleProc(instanceData, direction, handlePtr)
    ClientData instanceData;		/* The file state. */
    int direction;			/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr;		/* Where to store the handle.  */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;

    if (direction & infoPtr->validMask) {
	*handlePtr = (ClientData) infoPtr->handle;
	return TCL_OK;
    } else {
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open an File based channel on Unix systems.
 *
 * Results:
 *	The new channel or NULL. If NULL, the output argument
 *	errorCodePtr is set to a POSIX error.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
    Tcl_Interp *interp;			/* Interpreter for error reporting;
					 * can be NULL. */
    Tcl_Obj *pathPtr;			/* Name of file to open. */
    int mode;				/* POSIX mode. */
    int permissions;			/* If the open involves creating a
					 * file, with what modes to create
					 * it? */
{
    Tcl_Channel channel = 0;
    int channelPermissions;
    DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
    CONST TCHAR *nativeName;
    HANDLE handle;
    char channelName[16 + TCL_INTEGER_SPACE];







|
<












|
|
|
|





|
|













|
|


|
|









|
|
|



















|
|


|
|






|
|
|
|
|
|
<







751
752
753
754
755
756
757
758

759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849

850
851
852
853
854
855
856
}

/*
 *----------------------------------------------------------------------
 *
 * FileWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FileWatchProc(instanceData, mask)
    ClientData instanceData;	/* File state. */
    int mask;			/* What events to watch for; OR-ed combination
				 * of TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;
    Tcl_Time blockTime = { 0, 0 };

    /*
     * Since the file is always ready for events, we set the block time to
     * zero so we will poll.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_SetMaxBlockTime(&blockTime);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from a file
 *	based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
FileGetHandleProc(instanceData, direction, handlePtr)
    ClientData instanceData;	/* The file state. */
    int direction;		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr;	/* Where to store the handle.  */
{
    FileInfo *infoPtr = (FileInfo *) instanceData;

    if (direction & infoPtr->validMask) {
	*handlePtr = (ClientData) infoPtr->handle;
	return TCL_OK;
    } else {
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open an File based channel on Unix systems.
 *
 * Results:
 *	The new channel or NULL. If NULL, the output argument errorCodePtr is
 *	set to a POSIX error.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the file
 *	system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
    Tcl_Interp *interp;		/* Interpreter for error reporting; can be
				 * NULL. */
    Tcl_Obj *pathPtr;		/* Name of file to open. */
    int mode;			/* POSIX mode. */
    int permissions;		/* If the open involves creating a file, with
				 * what modes to create it? */

{
    Tcl_Channel channel = 0;
    int channelPermissions;
    DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
    CONST TCHAR *nativeName;
    HANDLE handle;
    char channelName[16 + TCL_INTEGER_SPACE];
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884

885
886
887
888
889
890
891

    shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;

    /*
     * Now we get to create the file.
     */

    handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, 
	    shareMode, NULL, createMode, flags, (HANDLE) NULL);

    if (handle == INVALID_HANDLE_VALUE) {
	DWORD err = GetLastError();

	if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
	    err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
	}
	TclWinConvertError(err);
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
		    "\": ", Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }

    type = GetFileType(handle);

    /*
     * If the file is a character device, we need to try to figure out
     * whether it is a serial port, a console, or something else.  We
     * test for the console case first because this is more common.
     */

    if (type == FILE_TYPE_CHAR) {
	if (GetConsoleMode(handle, &consoleParams)) {
	    type = FILE_TYPE_CONSOLE;
	} else {
	    DCB dcb;

	    dcb.DCBlength = sizeof(DCB);
	    if (GetCommState(handle, &dcb)) {
		type = FILE_TYPE_SERIAL;
	    }
	}
    }

    channel = NULL;

    switch (type) {
    case FILE_TYPE_SERIAL:
	/*
	 * Reopen channel for OVERLAPPED operation
	 * Normally this shouldn't fail, because the channel exists
	 */

	handle = TclWinSerialReopen(handle, nativeName, accessMode);
	if (handle == INVALID_HANDLE_VALUE) {
	    TclWinConvertError(GetLastError());
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "couldn't reopen serial \"",
			TclGetString(pathPtr), "\": ",
			Tcl_PosixError(interp), (char *) NULL);







|



















|
|
|




















|
|

>







927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987

    shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;

    /*
     * Now we get to create the file.
     */

    handle = (*tclWinProcs->createFileProc)(nativeName, accessMode,
	    shareMode, NULL, createMode, flags, (HANDLE) NULL);

    if (handle == INVALID_HANDLE_VALUE) {
	DWORD err = GetLastError();

	if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
	    err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
	}
	TclWinConvertError(err);
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
		    "\": ", Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }

    type = GetFileType(handle);

    /*
     * If the file is a character device, we need to try to figure out whether
     * it is a serial port, a console, or something else. We test for the
     * console case first because this is more common.
     */

    if (type == FILE_TYPE_CHAR) {
	if (GetConsoleMode(handle, &consoleParams)) {
	    type = FILE_TYPE_CONSOLE;
	} else {
	    DCB dcb;

	    dcb.DCBlength = sizeof(DCB);
	    if (GetCommState(handle, &dcb)) {
		type = FILE_TYPE_SERIAL;
	    }
	}
    }

    channel = NULL;

    switch (type) {
    case FILE_TYPE_SERIAL:
	/*
	 * Reopen channel for OVERLAPPED operation. Normally this shouldn't
	 * fail, because the channel exists.
	 */

	handle = TclWinSerialReopen(handle, nativeName, accessMode);
	if (handle == INVALID_HANDLE_VALUE) {
	    TclWinConvertError(GetLastError());
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "couldn't reopen serial \"",
			TclGetString(pathPtr), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956



957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
    case FILE_TYPE_UNKNOWN:
	channel = TclWinOpenFileChannel(handle, channelName,
		channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0);
	break;

    default:
	/*
	 * The handle is of an unknown type, probably /dev/nul equivalent
	 * or possibly a closed handle.
	 */

	channel = NULL;
	Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
		"\": bad file type", (char *) NULL);
	break;
    }

    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeFileChannel --
 *
 *	Creates a Tcl_Channel from an existing platform specific file
 *	handle.
 *
 * Results:
 *	The Tcl_Channel created around the preexisting file.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeFileChannel(rawHandle, mode)
    ClientData rawHandle;		/* OS level handle */
    int mode;				/* ORed combination of TCL_READABLE
					 * and TCL_WRITABLE to indicate file
					 * mode. */
{



    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_Channel channel = NULL;
    HANDLE handle = (HANDLE) rawHandle;
    HANDLE dupedHandle;
    DWORD consoleParams, type;
    TclFile readFile = NULL, writeFile = NULL;
    BOOL result;

    if (mode == 0) {
	return NULL;
    }

    /*
     * GetFileType() returns FILE_TYPE_UNKNOWN for invalid handles.
     */

    type = GetFileType(handle);

    /*
     * If the file is a character device, we need to try to figure out
     * whether it is a serial port, a console, or something else.  We
     * test for the console case first because this is more common.
     */

    if (type == FILE_TYPE_CHAR) {
	if (GetConsoleMode(handle, &consoleParams)) {
	    type = FILE_TYPE_CONSOLE;
	} else {
	    DCB dcb;







|
|
















|
<












|
|
|
<

>
>
>



















|
|
|







1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049

1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
    case FILE_TYPE_UNKNOWN:
	channel = TclWinOpenFileChannel(handle, channelName,
		channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0);
	break;

    default:
	/*
	 * The handle is of an unknown type, probably /dev/nul equivalent or
	 * possibly a closed handle.
	 */

	channel = NULL;
	Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
		"\": bad file type", (char *) NULL);
	break;
    }

    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeFileChannel --
 *
 *	Creates a Tcl_Channel from an existing platform specific file handle.

 *
 * Results:
 *	The Tcl_Channel created around the preexisting file.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_MakeFileChannel(rawHandle, mode)
    ClientData rawHandle;	/* OS level handle */
    int mode;			/* ORed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */

{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_Channel channel = NULL;
    HANDLE handle = (HANDLE) rawHandle;
    HANDLE dupedHandle;
    DWORD consoleParams, type;
    TclFile readFile = NULL, writeFile = NULL;
    BOOL result;

    if (mode == 0) {
	return NULL;
    }

    /*
     * GetFileType() returns FILE_TYPE_UNKNOWN for invalid handles.
     */

    type = GetFileType(handle);

    /*
     * If the file is a character device, we need to try to figure out whether
     * it is a serial port, a console, or something else. We test for the
     * console case first because this is more common.
     */

    if (type == FILE_TYPE_CHAR) {
	if (GetConsoleMode(handle, &consoleParams)) {
	    type = FILE_TYPE_CONSOLE;
	} else {
	    DCB dcb;
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
    case FILE_TYPE_CHAR:
	channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
	break;

    case FILE_TYPE_UNKNOWN:
    default:
	/*
	 * The handle is of an unknown type.  Test the validity of this OS
	 * handle by duplicating it, then closing the dupe.  The Win32 API
	 * doesn't provide an IsValidHandle() function, so we have to emulate
	 * it here.  This test will not work on a console handle reliably,
	 * which is why we can't test every handle that comes into this
	 * function in this way.
	 */

	result = DuplicateHandle(GetCurrentProcess(), handle,
		GetCurrentProcess(), &dupedHandle, 0, FALSE,
		DUPLICATE_SAME_ACCESS);







|
|

|







1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
    case FILE_TYPE_CHAR:
	channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
	break;

    case FILE_TYPE_UNKNOWN:
    default:
	/*
	 * The handle is of an unknown type. Test the validity of this OS
	 * handle by duplicating it, then closing the dupe. The Win32 API
	 * doesn't provide an IsValidHandle() function, so we have to emulate
	 * it here. This test will not work on a console handle reliably,
	 * which is why we can't test every handle that comes into this
	 * function in this way.
	 */

	result = DuplicateHandle(GetCurrentProcess(), handle,
		GetCurrentProcess(), &dupedHandle, 0, FALSE,
		DUPLICATE_SAME_ACCESS);
1038
1039
1040
1041
1042
1043
1044

1045
1046
1047

1048
1049
1050
1051
1052
1053

1054




1055
1056
1057



1058
1059
1060
1061
1062


1063

1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077



1078
1079
1080



1081
1082
1083
1084
1085
1086
1087
1088

1089


1090
1091
1092




1093
1094
1095



1096
1097



1098
1099
1100
1101
1102


1103

1104
1105



1106
1107
1108
1109


1110
1111
1112
1113
1114
1115
1116






1117
1118
1119
1120

1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
	}

	/*
	 * Use structured exception handling (Win32 SEH) to protect the close
	 * of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
	 */


#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
	__asm__ __volatile__ (

	    "movl %%esp,  %0" "\n\t"
	    "movl %%ebp,  %1" "\n\t"
	    "movl %%fs:0, %2" "\n\t"
	    : "=m"(INITIAL_ESP),
	      "=m"(INITIAL_EBP),
	      "=r"(INITIAL_HANDLER) );

# endif /* TCL_MEM_DEBUG */





	__asm__ __volatile__ (
	    "pushl %%ebp" "\n\t"



	    "pushl %0" "\n\t"
	    "pushl %%fs:0" "\n\t"
	    "movl  %%esp, %%fs:0"
	    :
	    : "r" (_except_makefilechannel_handler) );


	result = CloseHandle(dupedHandle);

	__asm__ __volatile__ (
	    "jmp  makefilechannel_pop" "\n"
	"makefilechannel_reentry:" "\n\t"
	    "movl %%fs:0, %%eax" "\n\t"
	    "movl 0x8(%%eax), %%esp" "\n\t"
	    "movl 0x8(%%esp), %%ebp" "\n"
	    "movl $0, %0" "\n"
	"makefilechannel_pop:" "\n\t"
	    "movl (%%esp), %%eax" "\n\t"
	    "movl %%eax, %%fs:0" "\n\t"
	    "add  $12, %%esp" "\n\t"
	    : "=m"(result)
	    :
	    : "%eax");




# ifdef TCL_MEM_DEBUG
	__asm__ __volatile__ (



	    "movl  %%esp,  %0" "\n\t"
	    "movl  %%ebp,  %1" "\n\t"
	    "movl  %%fs:0, %2" "\n\t"
	    : "=m"(RESTORED_ESP),
	      "=m"(RESTORED_EBP),
	      "=r"(RESTORED_HANDLER) );

	if (INITIAL_ESP != RESTORED_ESP) {

	    Tcl_Panic("ESP restored incorrectly");


	}
	if (INITIAL_EBP != RESTORED_EBP) {
	    Tcl_Panic("EBP restored incorrectly");




	}
	if (INITIAL_HANDLER != RESTORED_HANDLER) {
	    Tcl_Panic("HANDLER restored incorrectly");



	}
# endif /* TCL_MEM_DEBUG */




	if (result == 0) {
	    /*
	     * The handle failed to close.  The original is therefore
	     * invalid.


	     */


	    return NULL;



	}

#else
	__try {


	    result = CloseHandle(dupedHandle);
	} __except (EXCEPTION_EXECUTE_HANDLER) {
	    /*
	     * Definately an invalid handle.  So, therefore, the original
	     * is invalid also.
	     */







	    return NULL;
	}
#endif /* HAVE_NO_SEH */


	/* Fall through, the handle is valid. */

	/*
	 * Create the undefined channel, anyways, because we know the handle
	 * is valid to something.
	 */

	channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
    }

    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * _except_makefilechannel_handler --
 *
 *	SEH exception handler for Tcl_MakeFileChannel.
 *
 * Results:
 *	See Tcl_MakeFileChannel.
 *
 * Side effects:
 *	See Tcl_MakeFileChannel.
 *
 *----------------------------------------------------------------------
 */
#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_makefilechannel_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext)
{
    __asm__ __volatile__ (
	    "jmp makefilechannel_reentry");
    return 0; /* Function does not return */
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDefaultStdChannel --
 *
 *	Constructs a channel for the specified standard OS handle.
 *
 * Results:
 *	Returns the specified default standard channel, or NULL.
 *
 * Side effects:
 *	May cause the creation of a standard channel and the underlying
 *	file.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpGetDefaultStdChannel(type)
    int type;				/* One of TCL_STDIN, TCL_STDOUT, or
					 * TCL_STDERR. */
{
    Tcl_Channel channel;
    HANDLE handle;
    int mode;
    char *bufMode;
    DWORD handleId;		/* Standard handle to retrieve. */








>
|
<
|
>
|
<
<
<
<
|
>
|
>
>
>
>


|
>
>
>
|
<
|
|
<
>
>
|
>
|
<
|
|
|
|
|
<
|
|
|
<
|
<
>
>
>

|
|
>
>
>
|
|
|
<
<
<

<
>
|
>
>
|
<
<
>
>
>
>
|
<
<
>
>
>
|
<
>
>
>

<

<
<
>
>

>
|
|
>
>
>
|
|
|
<
>
>
|
<
<
<
<
<
|
>
>
>
>
>
>


<

>
|
|
<













<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








|
<






|
|







1135
1136
1137
1138
1139
1140
1141
1142
1143

1144
1145
1146




1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160

1161
1162

1163
1164
1165
1166
1167

1168
1169
1170
1171
1172

1173
1174
1175

1176

1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188



1189

1190
1191
1192
1193
1194


1195
1196
1197
1198
1199


1200
1201
1202
1203

1204
1205
1206
1207

1208


1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220

1221
1222
1223





1224
1225
1226
1227
1228
1229
1230
1231
1232

1233
1234
1235
1236

1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249































1250
1251
1252
1253
1254
1255
1256
1257
1258

1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
	}

	/*
	 * Use structured exception handling (Win32 SEH) to protect the close
	 * of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
	 */

	result = 0;
#ifndef HAVE_NO_SEH

	__try {
	    CloseHandle(dupedHandle);
	    result = 1;




	} __except (EXCEPTION_EXECUTE_HANDLER) {}
#else
	/*
	 * Don't have SEH available, do things the hard way. Note that this
	 * needs to be one block of asm, to avoid stack imbalance; also, it is
	 * illegal for one asm block to contain a jump to another.
	 */

	__asm__ __volatile__ (

	    /*
	     * Pick up parameters before messing with the stack
	     */


	    "movl       %[dupedHandle], %%ebx"          "\n\t"


	    /*
	     * Construct an EXCEPTION_REGISTRATION to protect the call to
	     * CloseHandle.
	     */


	    "leal       %[registration], %%edx"         "\n\t"
	    "movl       %%fs:0,         %%eax"          "\n\t"
	    "movl       %%eax,          0x0(%%edx)"     "\n\t" /* link */
	    "leal       1f,             %%eax"          "\n\t"
	    "movl       %%eax,          0x4(%%edx)"     "\n\t" /* handler */

	    "movl       %%ebp,          0x8(%%edx)"     "\n\t" /* ebp */
	    "movl       %%esp,          0xc(%%edx)"     "\n\t" /* esp */
	    "movl       $0,             0x10(%%edx)"    "\n\t" /* status */



	    /*
	     * Link the EXCEPTION_REGISTRATION on the chain.
	     */

	    "movl       %%edx,          %%fs:0"         "\n\t"

	    /*
	     * Call CloseHandle(dupedHandle).
	     */

	    "pushl      %%ebx"                          "\n\t"
	    "call       _CloseHandle@4"                 "\n\t"





	    /*
	     * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
	     * and put a TRUE status return into it.
	     */



	    "movl       %%fs:0,         %%edx"          "\n\t"
	    "movl	$1,		%%eax"		"\n\t"
	    "movl       %%eax,          0x10(%%edx)"    "\n\t"
	    "jmp        2f"                             "\n"



	    /*
	     * Come here on an exception. Recover the EXCEPTION_REGISTRATION
	     */


	    "1:"                                        "\t"
	    "movl       %%fs:0,         %%edx"          "\n\t"
	    "movl       0x8(%%edx),     %%edx"          "\n\t"


	    /*


	     * Come here however we exited. Restore context from the
	     * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	     */

	    "2:"                                        "\t"
	    "movl       0xc(%%edx),     %%esp"          "\n\t"
	    "movl       0x8(%%edx),     %%ebp"          "\n\t"
	    "movl       0x0(%%edx),     %%eax"          "\n\t"
	    "movl       %%eax,          %%fs:0"         "\n\t"

	    :
	    /* No outputs */

	    :
	    [registration]  "m"     (registration),
	    [dupedHandle]   "m"	    (dupedHandle)





	    :
	    "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
	    );
	result = registration.status;

#endif
	if (result == FALSE) {
	    return NULL;
	}


	/*
	 * Fall through, the handle is valid.
	 *

	 * Create the undefined channel, anyways, because we know the handle
	 * is valid to something.
	 */

	channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
    }

    return channel;
}

/*
 *----------------------------------------------------------------------
 *































 * TclpGetDefaultStdChannel --
 *
 *	Constructs a channel for the specified standard OS handle.
 *
 * Results:
 *	Returns the specified default standard channel, or NULL.
 *
 * Side effects:
 *	May cause the creation of a standard channel and the underlying file.

 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpGetDefaultStdChannel(type)
    int type;			/* One of TCL_STDIN, TCL_STDOUT, or
				 * TCL_STDERR. */
{
    Tcl_Channel channel;
    HANDLE handle;
    int mode;
    char *bufMode;
    DWORD handleId;		/* Standard handle to retrieve. */

1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290







1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379





1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenFileChannel --
 *
 *	Constructs a File channel for the specified standard OS handle.
 *	This is a helper function to break up the construction of
 *	channels into File, Console, or Serial.
 *
 * Results:
 *	Returns the new channel, or NULL.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
    HANDLE handle;			/* Win32 HANDLE to swallow */
    char *channelName;			/* Buffer to receive channel name */
    int permissions;			/* OR'ed combination of TCL_READABLE,
					 * TCL_WRITABLE, or TCL_EXCEPTION,
					 * indicating which operations are
					 * valid on the file. */
    int appendMode;			/* OR'ed combination of bits indicating
					 * what additional configuration of the
					 * channel is present. */
{
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = FileInit();

    /*
     * See if a channel with this handle already exists.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->handle == (HANDLE) handle) {
	    return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
	}
    }

    infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));







    infoPtr->nextPtr = tsdPtr->firstFilePtr;
    tsdPtr->firstFilePtr = infoPtr;
    infoPtr->validMask = permissions;
    infoPtr->watchMask = 0;
    infoPtr->flags = appendMode;
    infoPtr->handle = handle;
    infoPtr->dirty = 0;
    wsprintfA(channelName, "file%lx", (int) infoPtr);

    infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
	    (ClientData) infoPtr, permissions);

    /*
     * Files have default translation of AUTO and ^Z eof char, which
     * means that a ^Z will be accepted as EOF when reading.
     */

    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinFlushDirtyChannels --
 *
 *	Flush all dirty channels to disk, so that requesting the
 *	size of any file returns the correct value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information is actually written to disk now, rather than
 *	later.  Don't call this too often, or there will be a
 *	performance hit (i.e. only call when we need to ask for
 *	the size of a file).
 *
 *----------------------------------------------------------------------
 */

void
TclWinFlushDirtyChannels ()
{
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = FileInit();

    /*
     * Flush all channels which are dirty, i.e. may have data pending
     * in the OS
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->dirty) {
	    FlushFileBuffers(infoPtr->handle);
	    infoPtr->dirty = 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCutFileChannel --
 *
 *	Remove any thread local refs to this channel. See
 *	See Tcl_CutChannel for more info.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

void
TclpCutFileChannel(chan)
    Tcl_Channel chan;			/* The channel being removed. Must
					 * not be referenced in any
					 * interpreter. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr = (Channel *) chan;
    FileInfo *infoPtr;





    FileInfo **nextPtrPtr;
    int removed = 0;

    if (chanPtr->typePtr != &fileChannelType) {
	return;
    }

    infoPtr = (FileInfo *) chanPtr->instanceData;

    for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
	    nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	if ((*nextPtrPtr) == infoPtr) {
	    (*nextPtrPtr) = infoPtr->nextPtr;
	    removed = 1;
	    break;
	}
    }

    /*
     * This could happen if the channel was created in one thread
     * and then moved to another without updating the thread
     * local data in each thread.
     */

    if (!removed) {
	Tcl_Panic("file info ptr not on thread channel list");
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpSpliceFileChannel --
 *
 *	Insert thread local ref for this channel.
 *	See Tcl_SpliceChannel for more info.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

void
TclpSpliceFileChannel(chan)
    Tcl_Channel chan;			/* The channel being removed. Must
					 * not be referenced in any
					 * interpreter. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr = (Channel *) chan;
    FileInfo *infoPtr;

    if (chanPtr->typePtr != &fileChannelType) {
	return;
    }

    infoPtr = (FileInfo *) chanPtr->instanceData;

    infoPtr->nextPtr = tsdPtr->firstFilePtr;
    tsdPtr->firstFilePtr = infoPtr;
}







|
|
|





|
|






|
|
|
|
<
|
|
|
|
















>
>
>
>
>
>
>
|
<











|
|













|
|





|
|
<
|





|





|
|














|

|
<










|
|
<
|
|


<
|
>
>
>
>
>
|
|
<
<
<
<
<
<

|
|
|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
|
<
<
<
<
|
<
<
<
|
<
|
<
<
<
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350

1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378

1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413

1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444

1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456

1457
1458
1459
1460

1461
1462
1463
1464
1465
1466
1467
1468






1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489


1490












1491
1492
1493



1494




1495



1496

1497



}

/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenFileChannel --
 *
 *	Constructs a File channel for the specified standard OS handle. This
 *	is a helper function to break up the construction of channels into
 *	File, Console, or Serial.
 *
 * Results:
 *	Returns the new channel, or NULL.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the file
 *	system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
    HANDLE handle;		/* Win32 HANDLE to swallow */
    char *channelName;		/* Buffer to receive channel name */
    int permissions;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION, indicating

				 * which operations are valid on the file. */
    int appendMode;		/* OR'ed combination of bits indicating what
				 * additional configuration of the channel is
				 * present. */
{
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = FileInit();

    /*
     * See if a channel with this handle already exists.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->handle == (HANDLE) handle) {
	    return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
	}
    }

    infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));

    /*
     * TIP #218. Removed the code inserting the new structure into the global
     * list. This is now handled in the thread action callbacks, and only
     * there.
     */

    infoPtr->nextPtr = NULL;

    infoPtr->validMask = permissions;
    infoPtr->watchMask = 0;
    infoPtr->flags = appendMode;
    infoPtr->handle = handle;
    infoPtr->dirty = 0;
    wsprintfA(channelName, "file%lx", (int) infoPtr);

    infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
	    (ClientData) infoPtr, permissions);

    /*
     * Files have default translation of AUTO and ^Z eof char, which means
     * that a ^Z will be accepted as EOF when reading.
     */

    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinFlushDirtyChannels --
 *
 *	Flush all dirty channels to disk, so that requesting the size of any
 *	file returns the correct value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information is actually written to disk now, rather than later. Don't
 *	call this too often, or there will be a performance hit (i.e. only

 *	call when we need to ask for the size of a file).
 *
 *----------------------------------------------------------------------
 */

void
TclWinFlushDirtyChannels()
{
    FileInfo *infoPtr;
    ThreadSpecificData *tsdPtr = FileInit();

    /*
     * Flush all channels which are dirty, i.e. may have data pending in the
     * OS.
     */

    for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->dirty) {
	    FlushFileBuffers(infoPtr->handle);
	    infoPtr->dirty = 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FileThreadActionProc --
 *
 *	Insert or remove any thread local refs to this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

static void
FileThreadActionProc(instanceData, action)

    ClientData instanceData;
    int action;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    FileInfo *infoPtr = (FileInfo *) instanceData;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	infoPtr->nextPtr = tsdPtr->firstFilePtr;
	tsdPtr->firstFilePtr = infoPtr;
    } else {
	FileInfo **nextPtrPtr;
	int removed = 0;







	for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
		nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == infoPtr) {
		(*nextPtrPtr) = infoPtr->nextPtr;
		removed = 1;
		break;
	    }
	}

	/*
	 * This could happen if the channel was created in one thread and then
	 * moved to another without updating the thread local data in each
	 * thread.
	 */

	if (!removed) {
	    Tcl_Panic("file info ptr not on thread channel list");
	}
    }
}















/*
 * Local Variables:
 * mode: c



 * c-basic-offset: 4




 * fill-column: 78



 * End:

 */



Changes to win/tclWinConsole.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWinConsole.c --
 *
 *	This file implements the Windows-specific console functions,
 *	and the "console" channel driver.
 *
 * Copyright (c) 1999 by Scriptics Corp.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinConsole.c,v 1.12 2004/09/10 01:52:17 davygrvy Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>



|
|



|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWinConsole.c --
 *
 *	This file implements the Windows-specific console functions, and the
 *	"console" channel driver.
 *
 * Copyright (c) 1999 by Scriptics Corp.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinConsole.c,v 1.12.2.2 2005/08/02 18:17:00 dgp Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>
41
42
43
44
45
46
47
48
49
50
51

52
53
54
55
56
57
58
#define CONSOLE_ASYNC	(1<<1)	/* Channel is non-blocking. */

/*
 * Bit masks used in the sharedFlags field of the ConsoleInfo structure below.
 */

#define CONSOLE_EOF	  (1<<2)  /* Console has reached EOF. */
#define CONSOLE_BUFFERED  (1<<3)  /* data was read into a buffer by the reader
				     thread */

#define CONSOLE_BUFFER_SIZE (8*1024)

/*
 * This structure describes per-instance data for a console based channel.
 */

typedef struct ConsoleInfo {
    HANDLE handle;
    int type;







|
|


>







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
#define CONSOLE_ASYNC	(1<<1)	/* Channel is non-blocking. */

/*
 * Bit masks used in the sharedFlags field of the ConsoleInfo structure below.
 */

#define CONSOLE_EOF	  (1<<2)  /* Console has reached EOF. */
#define CONSOLE_BUFFERED  (1<<3)  /* Data was read into a buffer by the reader
				   * thread. */

#define CONSOLE_BUFFER_SIZE (8*1024)

/*
 * This structure describes per-instance data for a console based channel.
 */

typedef struct ConsoleInfo {
    HANDLE handle;
    int type;
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161


162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182


183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
    int flags;			/* State flags, see above for a list. */
    Tcl_ThreadId threadId;	/* Thread to which events should be reported.
				 * This value is used by the reader/writer
				 * threads. */
    HANDLE writeThread;		/* Handle to writer thread. */
    HANDLE readThread;		/* Handle to reader thread. */
    HANDLE writable;		/* Manual-reset event to signal when the
				 * writer thread has finished waiting for
				 * the current buffer to be written. */
    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    HANDLE startWriter;		/* Auto-reset event used by the main thread to
				 * signal when the writer thread should attempt
				 * to write to the console. */
    HANDLE stopWriter;		/* Auto-reset event used by the main thread to
				 * signal when the writer thread should exit.
				 */
    HANDLE startReader;		/* Auto-reset event used by the main thread to
				 * signal when the reader thread should attempt
				 * to read from the console. */
    HANDLE stopReader;		/* Auto-reset event used by the main thread to
				 * signal when the reader thread should exit.
				 */
    DWORD writeError;		/* An error caused by the last background
				 * write.  Set to 0 if no error has been
				 * detected.  This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object.
				 */
    char *writeBuf;		/* Current background output buffer.
				 * Access is synchronized with the writable
				 * object. */
    int writeBufLen;		/* Size of write buffer.  Access is
				 * synchronized with the writable
				 * object. */
    int toWrite;		/* Current amount to be written.  Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
				 * thread.  Access is synchronized with the
				 * readable object.  */
    int bytesRead;              /* number of bytes in the buffer */
    int offset;                 /* number of bytes read out of the buffer */
    char buffer[CONSOLE_BUFFER_SIZE];
                                /* Data consumed by reader thread. */
} ConsoleInfo;

typedef struct ThreadSpecificData {
    /*
     * The following pointer refers to the head of the list of consoles
     * that are being watched for file events.
     */
    
    ConsoleInfo *firstConsolePtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when
 * console events are generated.
 */

typedef struct ConsoleEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    ConsoleInfo *infoPtr;	/* Pointer to console info structure.  Note
				 * that we still have to verify that the
				 * console exists before dereferencing this
				 * pointer. */
} ConsoleEvent;

/*
 * Declarations for functions used only in this file.
 */

static int		ConsoleBlockModeProc(ClientData instanceData, int mode);
static void		ConsoleCheckProc(ClientData clientData, int flags);
static int		ConsoleCloseProc(ClientData instanceData,
			    Tcl_Interp *interp);
static int		ConsoleEventProc(Tcl_Event *evPtr, int flags);
static void		ConsoleExitHandler(ClientData clientData);
static int		ConsoleGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static ThreadSpecificData *ConsoleInit(void);
static int		ConsoleInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		ConsoleOutputProc(ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI	ConsoleReaderThread(LPVOID arg);
static void		ConsoleSetupProc(ClientData clientData, int flags);
static void		ConsoleWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI	ConsoleWriterThread(LPVOID arg);
static void		ProcExitHandler(ClientData clientData);
static int		WaitForRead(ConsoleInfo *infoPtr, int blocking);



/*
 * This structure describes the channel type structure for command console
 * based IO.
 */

static Tcl_ChannelType consoleChannelType = {
    "console",			/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* v2 channel */
    ConsoleCloseProc,		/* Close proc. */
    ConsoleInputProc,		/* Input proc. */
    ConsoleOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    ConsoleWatchProc,		/* Set up notifier to watch the channel. */
    ConsoleGetHandleProc,	/* Get an OS handle from channel. */
    NULL,			/* close2proc. */
    ConsoleBlockModeProc,	/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */


};

/*
 *----------------------------------------------------------------------
 *
 * ConsoleInit --
 *
 *	This function initializes the static variables for this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new event source.
 *
 *----------------------------------------------------------------------
 */

static ThreadSpecificData *
ConsoleInit()
{
    ThreadSpecificData *tsdPtr;

    /*
     * Check the initialized flag first, then check again in the mutex.
     * This is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&consoleMutex);
	if (!initialized) {
	    initialized = 1;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	Tcl_MutexUnlock(&consoleMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->firstConsolePtr = NULL;
	Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
	Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
    }
    return tsdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleExitHandler --
 *
 *	This function is called to cleanup the console module before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the console event source.
 *







|
|




|
|




|
|




|
|



|
|
<
|
|
<
|


|
|
|
|

|




|
|













|
|
|

















|










>
>








|












>
>


















|





|
|


















<







|
|







68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

100
101

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
    int flags;			/* State flags, see above for a list. */
    Tcl_ThreadId threadId;	/* Thread to which events should be reported.
				 * This value is used by the reader/writer
				 * threads. */
    HANDLE writeThread;		/* Handle to writer thread. */
    HANDLE readThread;		/* Handle to reader thread. */
    HANDLE writable;		/* Manual-reset event to signal when the
				 * writer thread has finished waiting for the
				 * current buffer to be written. */
    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    HANDLE startWriter;		/* Auto-reset event used by the main thread to
				 * signal when the writer thread should
				 * attempt to write to the console. */
    HANDLE stopWriter;		/* Auto-reset event used by the main thread to
				 * signal when the writer thread should exit.
				 */
    HANDLE startReader;		/* Auto-reset event used by the main thread to
				 * signal when the reader thread should
				 * attempt to read from the console. */
    HANDLE stopReader;		/* Auto-reset event used by the main thread to
				 * signal when the reader thread should exit.
				 */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object.
				 */
    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the writable object. */

    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the writable object. */

    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
				 * thread. Access is synchronized with the
				 * readable object. */
    int bytesRead;		/* number of bytes in the buffer */
    int offset;			/* number of bytes read out of the buffer */
    char buffer[CONSOLE_BUFFER_SIZE];
				/* Data consumed by reader thread. */
} ConsoleInfo;

typedef struct ThreadSpecificData {
    /*
     * The following pointer refers to the head of the list of consoles that
     * are being watched for file events.
     */
    
    ConsoleInfo *firstConsolePtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when
 * console events are generated.
 */

typedef struct ConsoleEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    ConsoleInfo *infoPtr;	/* Pointer to console info structure. Note
				 * that we still have to verify that the
				 * console exists before dereferencing this
				 * pointer. */
} ConsoleEvent;

/*
 * Declarations for functions used only in this file.
 */

static int		ConsoleBlockModeProc(ClientData instanceData, int mode);
static void		ConsoleCheckProc(ClientData clientData, int flags);
static int		ConsoleCloseProc(ClientData instanceData,
			    Tcl_Interp *interp);
static int		ConsoleEventProc(Tcl_Event *evPtr, int flags);
static void		ConsoleExitHandler(ClientData clientData);
static int		ConsoleGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static void		ConsoleInit(void);
static int		ConsoleInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		ConsoleOutputProc(ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI	ConsoleReaderThread(LPVOID arg);
static void		ConsoleSetupProc(ClientData clientData, int flags);
static void		ConsoleWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI	ConsoleWriterThread(LPVOID arg);
static void		ProcExitHandler(ClientData clientData);
static int		WaitForRead(ConsoleInfo *infoPtr, int blocking);
static void		ConsoleThreadActionProc(ClientData instanceData,
			    int action);

/*
 * This structure describes the channel type structure for command console
 * based IO.
 */

static Tcl_ChannelType consoleChannelType = {
    "console",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    ConsoleCloseProc,		/* Close proc. */
    ConsoleInputProc,		/* Input proc. */
    ConsoleOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    ConsoleWatchProc,		/* Set up notifier to watch the channel. */
    ConsoleGetHandleProc,	/* Get an OS handle from channel. */
    NULL,			/* close2proc. */
    ConsoleBlockModeProc,	/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    ConsoleThreadActionProc,    /* thread action proc */
};

/*
 *----------------------------------------------------------------------
 *
 * ConsoleInit --
 *
 *	This function initializes the static variables for this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates a new event source.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleInit()
{
    ThreadSpecificData *tsdPtr;

    /*
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&consoleMutex);
	if (!initialized) {
	    initialized = 1;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	Tcl_MutexUnlock(&consoleMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->firstConsolePtr = NULL;
	Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
	Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
    }

}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleExitHandler --
 *
 *	This function is called to cleanup the console module before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the console event source.
 *
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
}

/*
 *----------------------------------------------------------------------
 *
 * ProcExitHandler --
 *
 *	This function is called to cleanup the process list before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the process list.
 *







|
|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
}

/*
 *----------------------------------------------------------------------
 *
 * ProcExitHandler --
 *
 *	This function is called to cleanup the process list before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the process list.
 *
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleSetupProc --
 *
 *	This procedure is invoked before Tcl_DoOneEvent blocks waiting
 *	for an event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *







|
|







280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleSetupProc --
 *
 *	This procedure is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }
    
    /*
     * Look to see if any events are already pending.  If they are, poll.
     */

    for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
		block = 0;







|







307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }
    
    /*
     * Look to see if any events are already pending. If they are, poll.
     */

    for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
		block = 0;
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the console
 *	event source for events. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *







|
|







333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the console event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431

432
433
434
435
436
437
438
 *----------------------------------------------------------------------
 */

static int
ConsoleBlockModeProc(
    ClientData instanceData,	/* Instance data for channel. */
    int mode)			/* TCL_MODE_BLOCKING or
                                 * TCL_MODE_NONBLOCKING. */
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    
    /*
     * Consoles on Windows can not be switched between blocking and nonblocking,
     * hence we have to emulate the behavior. This is done in the input
     * function by checking against a bit in the state. We set or unset the
     * bit here to cause the input function to emulate the correct behavior.

     */

    if (mode == TCL_MODE_NONBLOCKING) {
	infoPtr->flags |= CONSOLE_ASYNC;
    } else {
	infoPtr->flags &= ~(CONSOLE_ASYNC);
    }







|




|
|
|
|
>







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
 *----------------------------------------------------------------------
 */

static int
ConsoleBlockModeProc(
    ClientData instanceData,	/* Instance data for channel. */
    int mode)			/* TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    
    /*
     * Consoles on Windows can not be switched between blocking and
     * nonblocking, hence we have to emulate the behavior. This is done in the
     * input function by checking against a bit in the state. We set or unset
     * the bit here to cause the input function to emulate the correct
     * behavior.
     */

    if (mode == TCL_MODE_NONBLOCKING) {
	infoPtr->flags |= CONSOLE_ASYNC;
    } else {
	infoPtr->flags &= ~(CONSOLE_ASYNC);
    }
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537

538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
    ConsoleInfo *infoPtr, **nextPtrPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    DWORD exitCode;

    errorCode = 0;
    
    /*
     * Clean up the background thread if necessary.  Note that this
     * must be done before we can close the file, since the 
     * thread may be blocking trying to read from the console.
     */
    
    if (consolePtr->readThread) {

	/*
	 * The thread may already have closed on it's own.  Check it's
	 * exit code.
	 */

	GetExitCodeThread(consolePtr->readThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {

	    /*
	     * Set the stop event so that if the reader thread is blocked
	     * in ConsoleReaderThread on WaitForMultipleEvents, it will exit
	     * cleanly.
	     */

	    SetEvent(consolePtr->stopReader);

	    /*
	     * Wait at most 20 milliseconds for the reader thread to close.
	     */

	    if (WaitForSingleObject(consolePtr->readThread, 20)
		    == WAIT_TIMEOUT) {
		/*
		 * Forcibly terminate the background thread as a last
		 * resort.  Note that we need to guard against
		 * terminating the thread while it is in the middle of
		 * Tcl_ThreadAlert because it won't be able to release
		 * the notifier lock.
		 */

		Tcl_MutexLock(&consoleMutex);

		/* BUG: this leaks memory. */
		TerminateThread(consolePtr->readThread, 0);
		Tcl_MutexUnlock(&consoleMutex);
	    }
	}

	CloseHandle(consolePtr->readThread);
	CloseHandle(consolePtr->readable);
	CloseHandle(consolePtr->startReader);
	CloseHandle(consolePtr->stopReader);
	consolePtr->readThread = NULL;
    }
    consolePtr->validMask &= ~TCL_READABLE;

    /*
     * Wait for the writer thread to finish the current buffer, then
     * terminate the thread and close the handles.  If the channel is
     * nonblocking, there should be no pending write operations.
     */
    
    if (consolePtr->writeThread) {
	if (consolePtr->toWrite) {
	    /*
	     * We only need to wait if there is something to write.
	     * This may prevent infinite wait on exit. [python bug 216289]
	     */

	    WaitForSingleObject(consolePtr->writable, INFINITE);
	}

	/*
	 * The thread may already have closed on it's own.  Check it's
	 * exit code.
	 */

	GetExitCodeThread(consolePtr->writeThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {
	    /*
	     * Set the stop event so that if the reader thread is blocked
	     * in ConsoleWriterThread on WaitForMultipleEvents, it will
	     * exit cleanly.
	     */

	    SetEvent(consolePtr->stopWriter);

	    /*
	     * Wait at most 20 milliseconds for the writer thread to close.
	     */

	    if (WaitForSingleObject(consolePtr->writeThread, 20)
		    == WAIT_TIMEOUT) {
		/*
		 * Forcibly terminate the background thread as a last
		 * resort.  Note that we need to guard against
		 * terminating the thread while it is in the middle of
		 * Tcl_ThreadAlert because it won't be able to release
		 * the notifier lock.
		 */

		Tcl_MutexLock(&consoleMutex);

		/* BUG: this leaks memory. */
		TerminateThread(consolePtr->writeThread, 0);
		Tcl_MutexUnlock(&consoleMutex);
	    }
	}

	CloseHandle(consolePtr->writeThread);
	CloseHandle(consolePtr->writable);
	CloseHandle(consolePtr->startWriter);
	CloseHandle(consolePtr->stopWriter);
	consolePtr->writeThread = NULL;
    }
    consolePtr->validMask &= ~TCL_WRITABLE;


    /*
     * Don't close the Win32 handle if the handle is a standard channel
     * during the thread exit process.  Otherwise, one thread may kill
     * the stdio of another.
     */

    if (!TclInThreadExit() 
	    || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle)
		&& (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle)
		&& (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) {
	if (CloseHandle(consolePtr->handle) == FALSE) {







|
|
|



<

|
|





<

|
|












|
|
|
<
|



















|
|
|





|
|

>




|
|






|
|
|











|
|
|
<
|




















|
|
|







468
469
470
471
472
473
474
475
476
477
478
479
480

481
482
483
484
485
486
487
488

489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567

568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
    ConsoleInfo *infoPtr, **nextPtrPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    DWORD exitCode;

    errorCode = 0;
    
    /*
     * Clean up the background thread if necessary. Note that this must be
     * done before we can close the file, since the thread may be blocking
     * trying to read from the console.
     */
    
    if (consolePtr->readThread) {

	/*
	 * The thread may already have closed on it's own. Check it's exit
	 * code.
	 */

	GetExitCodeThread(consolePtr->readThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {

	    /*
	     * Set the stop event so that if the reader thread is blocked in
	     * ConsoleReaderThread on WaitForMultipleEvents, it will exit
	     * cleanly.
	     */

	    SetEvent(consolePtr->stopReader);

	    /*
	     * Wait at most 20 milliseconds for the reader thread to close.
	     */

	    if (WaitForSingleObject(consolePtr->readThread, 20)
		    == WAIT_TIMEOUT) {
		/*
		 * Forcibly terminate the background thread as a last resort.
		 * Note that we need to guard against terminating the thread
		 * while it is in the middle of Tcl_ThreadAlert because it

		 * won't be able to release the notifier lock.
		 */

		Tcl_MutexLock(&consoleMutex);

		/* BUG: this leaks memory. */
		TerminateThread(consolePtr->readThread, 0);
		Tcl_MutexUnlock(&consoleMutex);
	    }
	}

	CloseHandle(consolePtr->readThread);
	CloseHandle(consolePtr->readable);
	CloseHandle(consolePtr->startReader);
	CloseHandle(consolePtr->stopReader);
	consolePtr->readThread = NULL;
    }
    consolePtr->validMask &= ~TCL_READABLE;

    /*
     * Wait for the writer thread to finish the current buffer, then terminate
     * the thread and close the handles. If the channel is nonblocking, there
     * should be no pending write operations.
     */
    
    if (consolePtr->writeThread) {
	if (consolePtr->toWrite) {
	    /*
	     * We only need to wait if there is something to write. This may
	     * prevent infinite wait on exit. [python bug 216289]
	     */

	    WaitForSingleObject(consolePtr->writable, INFINITE);
	}

	/*
	 * The thread may already have closed on it's own. Check it's exit
	 * code.
	 */

	GetExitCodeThread(consolePtr->writeThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {
	    /*
	     * Set the stop event so that if the reader thread is blocked in
	     * ConsoleWriterThread on WaitForMultipleEvents, it will exit
	     * cleanly.
	     */

	    SetEvent(consolePtr->stopWriter);

	    /*
	     * Wait at most 20 milliseconds for the writer thread to close.
	     */

	    if (WaitForSingleObject(consolePtr->writeThread, 20)
		    == WAIT_TIMEOUT) {
		/*
		 * Forcibly terminate the background thread as a last resort.
		 * Note that we need to guard against terminating the thread
		 * while it is in the middle of Tcl_ThreadAlert because it

		 * won't be able to release the notifier lock.
		 */

		Tcl_MutexLock(&consoleMutex);

		/* BUG: this leaks memory. */
		TerminateThread(consolePtr->writeThread, 0);
		Tcl_MutexUnlock(&consoleMutex);
	    }
	}

	CloseHandle(consolePtr->writeThread);
	CloseHandle(consolePtr->writable);
	CloseHandle(consolePtr->startWriter);
	CloseHandle(consolePtr->stopWriter);
	consolePtr->writeThread = NULL;
    }
    consolePtr->validMask &= ~TCL_WRITABLE;


    /*
     * Don't close the Win32 handle if the handle is a standard channel during
     * the thread exit process. Otherwise, one thread may kill the stdio of
     * another.
     */

    if (!TclInThreadExit() 
	    || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle)
		&& (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle)
		&& (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) {
	if (CloseHandle(consolePtr->handle) == FALSE) {
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns
 *	count of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleInputProc(
    ClientData instanceData,		/* Console state. */
    char *buf,				/* Where to store data read. */
    int bufSize,			/* How much space is available
                                         * in the buffer? */
    int *errorCode)			/* Where to store error code. */
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    DWORD count, bytesRead = 0;
    int result;

    *errorCode = 0;








|
|













|
|
|
|
|







625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns count
 *	of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleInputProc(
    ClientData instanceData,	/* Console state. */
    char *buf,			/* Where to store data read. */
    int bufSize,		/* How much space is available in the
				 * buffer? */
    int *errorCode)		/* Where to store error code. */
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    DWORD count, bytesRead = 0;
    int result;

    *errorCode = 0;

692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
	    infoPtr->offset = 0;
	}

	return bytesRead;
    }
    
    /*
     * Attempt to read bufSize bytes.  The read will return immediately
     * if there is any data available.  Otherwise it will block until
     * at least one byte is available or an EOF occurs.
     */

    if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
		    (LPOVERLAPPED) NULL) == TRUE) {
	buf[count] = '\0';
	return count;
    }

    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how
 *	many characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an
 *	error indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */








|
|
|



|












|
|


|
|







692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
	    infoPtr->offset = 0;
	}

	return bytesRead;
    }
    
    /*
     * Attempt to read bufSize bytes. The read will return immediately if
     * there is any data available. Otherwise it will block until at least one
     * byte is available or an EOF occurs.
     */

    if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
	    (LPOVERLAPPED) NULL) == TRUE) {
	buf[count] = '\0';
	return count;
    }

    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how many
 *	characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    DWORD bytesWritten, timeout;

    *errorCode = 0;
    timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete
	 * and the channel is in non-blocking mode.
	 */

	errno = EAGAIN;
	goto error;
    }

    /*







|
|







738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    DWORD bytesWritten, timeout;

    *errorCode = 0;
    timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EAGAIN;
	goto error;
    }

    /*
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
	memcpy(infoPtr->writeBuf, buf, toWrite);
	infoPtr->toWrite = toWrite;
	ResetEvent(infoPtr->writable);
	SetEvent(infoPtr->startWriter);
	bytesWritten = toWrite;
    } else {
	/*
	 * In the blocking case, just try to write the buffer directly.
	 * This avoids an unnecessary copy.
	 */

	if (WriteConsole(infoPtr->handle, buf, toWrite, &bytesWritten,
		NULL) == FALSE) {
	    TclWinConvertError(GetLastError());
	    goto error;
	}
    }
    return bytesWritten;

error:
    *errorCode = errno;
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event
 *	reaches the front of the event queue.  This procedure invokes
 *	Tcl_NotifyChannel on the console.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleEventProc(
    Tcl_Event *evPtr,		/* Event to service. */
    int flags)			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr;
    ConsoleInfo *infoPtr;
    int mask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched consoles for the one whose handle
     * matches the event.  We do this rather than simply dereferencing
     * the handle in the event so that consoles can be deleted while the
     * event is in the queue.
     */

    for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (consoleEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(CONSOLE_PENDING);
	    break;
	}
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the console is readable.  Note
     * that we can't tell if a console is writable, so we always report it
     * as being writable unless we have detected EOF.
     */

    mask = 0;
    if (infoPtr->watchMask & TCL_WRITABLE) {
	if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
	    mask = TCL_WRITABLE;
	}







|
|










|









|
|
|


|
|
|
|










|
|












|
|
|



















|
|
|







780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
	memcpy(infoPtr->writeBuf, buf, toWrite);
	infoPtr->toWrite = toWrite;
	ResetEvent(infoPtr->writable);
	SetEvent(infoPtr->startWriter);
	bytesWritten = toWrite;
    } else {
	/*
	 * In the blocking case, just try to write the buffer directly. This
	 * avoids an unnecessary copy.
	 */

	if (WriteConsole(infoPtr->handle, buf, toWrite, &bytesWritten,
		NULL) == FALSE) {
	    TclWinConvertError(GetLastError());
	    goto error;
	}
    }
    return bytesWritten;

  error:
    *errorCode = errno;
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This procedure invokes Tcl_NotifyChannel
 *	on the console.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleEventProc(
    Tcl_Event *evPtr,		/* Event to service. */
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr;
    ConsoleInfo *infoPtr;
    int mask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched consoles for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that consoles can be deleted while the event is
     * in the queue.
     */

    for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (consoleEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(CONSOLE_PENDING);
	    break;
	}
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the console is readable. Note that we can't tell if a
     * console is writable, so we always report it as being writable unless we
     * have detected EOF.
     */

    mask = 0;
    if (infoPtr->watchMask & TCL_WRITABLE) {
	if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
	    mask = TCL_WRITABLE;
	}
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028

1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this
 *	channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleWatchProc(
    ClientData instanceData,		/* Console state. */
    int mask)				/* What events to watch for, OR-ed
                                         * combination of TCL_READABLE,
                                         * TCL_WRITABLE and TCL_EXCEPTION. */
{
    ConsoleInfo **nextPtrPtr, *ptr;
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    int oldMask = infoPtr->watchMask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Since most of the work is handled by the background threads,
     * we just need to update the watchMask and then force the notifier
     * to poll once. 
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };
	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstConsolePtr;
	    tsdPtr->firstConsolePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
	    /*
	     * Remove the console from the list of watched consoles.
	     */

	    for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr;
		 ptr != NULL;
		 nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
		if (infoPtr == ptr) {
		    *nextPtrPtr = ptr->nextPtr;
		    break;
		}
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from
 *	inside a command consoleline based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleGetHandleProc(
    ClientData instanceData,	/* The console state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr)	/* Where to store the handle.  */
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;

    *handlePtr = (ClientData) infoPtr->handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForRead --
 *
 *	Wait until some data is available, the console is at
 *	EOF or the reader thread is blocked waiting for data (if the
 *	channel is in non-blocking mode).
 *
 * Results:
 *	Returns 1 if console is readable.  Returns 0 if there is no data
 *	on the console, but there is buffered data.  Returns -1 if an
 *	error occurred.  If an error occurred, the threads may not
 *	be synchronized.
 *
 * Side effects:
 *	Updates the shared state flags.  If no error occurred,
 *      the reader thread is blocked waiting for a signal from the 
 *      main thread.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForRead(
    ConsoleInfo *infoPtr,		/* Console state. */
    int blocking)		/* Indicates whether call should be
				 * blocking or not. */
{
    DWORD timeout, count;
    HANDLE *handle = infoPtr->handle;
    INPUT_RECORD input;
    
    while (1) {
	/*
	 * Synchronize with the reader thread.
	 */
       
	timeout = blocking ? INFINITE : 0;
	if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
	    /*
	     * The reader thread is blocked waiting for data and the channel
	     * is in non-blocking mode.
	     */

	    errno = EAGAIN;
	    return -1;
	}
	
	/*
	 * At this point, the two threads are synchronized, so it is safe
	 * to access shared state.
	 */
	
	/*
	 * If the console has hit EOF, it is always readable.
	 */
	
	if (infoPtr->readFlags & CONSOLE_EOF) {
	    return 1;
	}
	
	if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) {
            /*
	     * Check to see if the peek failed because of EOF.
	     */
	    
	    TclWinConvertError(GetLastError());
	    
	    if (errno == EOF) {
		infoPtr->readFlags |= CONSOLE_EOF;







|
<












|
|
|
|







|
|
<










<
|
|
|
|

|
|
|
|
|
|
<










|
|


|
|











|












|
|
|


|
|
|
<


|
|
<






|


















>





|
|











|







892
893
894
895
896
897
898
899

900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924

925
926
927
928
929
930
931
932
933
934

935
936
937
938
939
940
941
942
943
944
945

946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993

994
995
996
997

998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleWatchProc(
    ClientData instanceData,	/* Console state. */
    int mask)			/* What events to watch for, OR-ed combination
				 * of TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    ConsoleInfo **nextPtrPtr, *ptr;
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
    int oldMask = infoPtr->watchMask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Since most of the work is handled by the background threads, we just
     * need to update the watchMask and then force the notifier to poll once.

     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };
	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstConsolePtr;
	    tsdPtr->firstConsolePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);

    } else if (oldMask) {
	/*
	 * Remove the console from the list of watched consoles.
	 */

	for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr;
		ptr != NULL;
		nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
	    if (infoPtr == ptr) {
		*nextPtrPtr = ptr->nextPtr;
		break;

	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
 *	command consoleline based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleGetHandleProc(
    ClientData instanceData,	/* The console state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr)	/* Where to store the handle. */
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;

    *handlePtr = (ClientData) infoPtr->handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForRead --
 *
 *	Wait until some data is available, the console is at EOF or the reader
 *	thread is blocked waiting for data (if the channel is in non-blocking
 *	mode).
 *
 * Results:
 *	Returns 1 if console is readable. Returns 0 if there is no data on the
 *	console, but there is buffered data. Returns -1 if an error occurred.
 *	If an error occurred, the threads may not be synchronized.

 *
 * Side effects:
 *	Updates the shared state flags. If no error occurred, the reader
 *	thread is blocked waiting for a signal from the main thread.

 *
 *----------------------------------------------------------------------
 */

static int
WaitForRead(
    ConsoleInfo *infoPtr,	/* Console state. */
    int blocking)		/* Indicates whether call should be
				 * blocking or not. */
{
    DWORD timeout, count;
    HANDLE *handle = infoPtr->handle;
    INPUT_RECORD input;
    
    while (1) {
	/*
	 * Synchronize with the reader thread.
	 */
       
	timeout = blocking ? INFINITE : 0;
	if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
	    /*
	     * The reader thread is blocked waiting for data and the channel
	     * is in non-blocking mode.
	     */

	    errno = EAGAIN;
	    return -1;
	}
	
	/*
	 * At this point, the two threads are synchronized, so it is safe to
	 * access shared state.
	 */
	
	/*
	 * If the console has hit EOF, it is always readable.
	 */
	
	if (infoPtr->readFlags & CONSOLE_EOF) {
	    return 1;
	}
	
	if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) {
	    /*
	     * Check to see if the peek failed because of EOF.
	     */
	    
	    TclWinConvertError(GetLastError());
	    
	    if (errno == EOF) {
		infoPtr->readFlags |= CONSOLE_EOF;
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
		return 0;
	    } else {
		return -1;
	    }
	}

	/*
	 * If there is data in the buffer, the console must be
	 * readable (since it is a line-oriented device).
	 */

	if (infoPtr->readFlags & CONSOLE_BUFFERED) {
	    return 1;
	}

	
	/*
	 * There wasn't any data available, so reset the thread and
	 * try again.
	 */
    
	ResetEvent(infoPtr->readable);
	SetEvent(infoPtr->startReader);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleReaderThread --
 *
 *	This function runs in a separate thread and waits for input
 *	to become available on a console.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the main thread when input become available.  May
 *	cause the main thread to wake up by posting a message.  May
 *	one line from the console for each wait operation.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
ConsoleReaderThread(LPVOID arg)
{







|
|






<

|
<












|
|





|
|
|







1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072

1073
1074

1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
		return 0;
	    } else {
		return -1;
	    }
	}

	/*
	 * If there is data in the buffer, the console must be readable (since
	 * it is a line-oriented device).
	 */

	if (infoPtr->readFlags & CONSOLE_BUFFERED) {
	    return 1;
	}


	/*
	 * There wasn't any data available, so reset the thread and try again.

	 */
    
	ResetEvent(infoPtr->readable);
	SetEvent(infoPtr->startReader);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleReaderThread --
 *
 *	This function runs in a separate thread and waits for input to become
 *	available on a console.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the main thread when input become available. May cause the
 *	main thread to wake up by posting a message. May one line from the
 *	console for each wait operation.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
ConsoleReaderThread(LPVOID arg)
{
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171





1172

1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190

1191
1192
1193
1194
1195
1196
1197
1198
1199
	 * Wait for the main thread to signal before attempting to wait.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled.  It must be the stop event
	     * or an error, so exit this thread.
	     */

	    break;
	}

	count = 0;

	/* 
	 * Look for data on the console, but first ignore any events
	 * that are not KEY_EVENTs 
	 */

	if (ReadConsoleA(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
		(LPDWORD) &infoPtr->bytesRead, NULL) != FALSE) {
	    /*
	     * Data was stored in the buffer.
	     */
	    
	    infoPtr->readFlags |= CONSOLE_BUFFERED;
	} else {
	    DWORD err;
	    err = GetLastError();
	    
	    if (err == EOF) {
		infoPtr->readFlags = CONSOLE_EOF;
	    }
	}

	/*
	 * Signal the main thread by signalling the readable event and
	 * then waking up the notifier thread.
	 */

	SetEvent(infoPtr->readable);

	/*
	 * Alert the foreground thread.  Note that we need to treat this like
	 * a critical section so the foreground thread does not terminate
	 * this thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&consoleMutex);





	Tcl_ThreadAlert(infoPtr->threadId);

	Tcl_MutexUnlock(&consoleMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWriterThread --
 *
 *	This function runs in a separate thread and writes data
 *	onto a console.
 *
 * Results:
 *	Always returns 0.
 *
 * Side effects:

 *	Signals the main thread when an output operation is completed.
 *	May cause the main thread to wake up by posting a message.  
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
ConsoleWriterThread(LPVOID arg)
{







|
|








|
|

>

















|
|





|
|
|



>
>
>
>
>
|
>











|
|





>
|
|







1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
	 * Wait for the main thread to signal before attempting to wait.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled. It must be the stop event or
	     * an error, so exit this thread.
	     */

	    break;
	}

	count = 0;

	/* 
	 * Look for data on the console, but first ignore any events that are
	 * not KEY_EVENTs.
	 */

	if (ReadConsoleA(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
		(LPDWORD) &infoPtr->bytesRead, NULL) != FALSE) {
	    /*
	     * Data was stored in the buffer.
	     */
	    
	    infoPtr->readFlags |= CONSOLE_BUFFERED;
	} else {
	    DWORD err;
	    err = GetLastError();
	    
	    if (err == EOF) {
		infoPtr->readFlags = CONSOLE_EOF;
	    }
	}

	/*
	 * Signal the main thread by signalling the readable event and then
	 * waking up the notifier thread.
	 */

	SetEvent(infoPtr->readable);

	/*
	 * Alert the foreground thread. Note that we need to treat this like a
	 * critical section so the foreground thread does not terminate this
	 * thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&consoleMutex);
	if (infoPtr->threadId != NULL) {
	    /*
	     * TIP #218. When in flight ignore the event, no one will receive
	     * it anyway.
	     */
	    Tcl_ThreadAlert(infoPtr->threadId);
	}
	Tcl_MutexUnlock(&consoleMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWriterThread --
 *
 *	This function runs in a separate thread and writes data onto a
 *	console.
 *
 * Results:
 *	Always returns 0.
 *
 * Side effects:

 *	Signals the main thread when an output operation is completed. May
 *	cause the main thread to wake up by posting a message.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
ConsoleWriterThread(LPVOID arg)
{
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
	 * Wait for the main thread to signal before attempting to write.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled.  It must be the stop event
	     * or an error, so exit this thread.
	     */

	    break;
	}

	buf = infoPtr->writeBuf;
	toWrite = infoPtr->toWrite;







|
|







1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
	 * Wait for the main thread to signal before attempting to write.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled. It must be the stop event or
	     * an error, so exit this thread.
	     */

	    break;
	}

	buf = infoPtr->writeBuf;
	toWrite = infoPtr->toWrite;
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257





1258

1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306

1307
1308
1309


1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329

1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362

























































	    } else {
		toWrite -= count;
		buf += count;
	    }
	}

	/*
	 * Signal the main thread by signalling the writable event and
	 * then waking up the notifier thread.
	 */
	
	SetEvent(infoPtr->writable);

	/*
	 * Alert the foreground thread.  Note that we need to treat this like
	 * a critical section so the foreground thread does not terminate
	 * this thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&consoleMutex);





	Tcl_ThreadAlert(infoPtr->threadId);

	Tcl_MutexUnlock(&consoleMutex);
    }

    return 0;
}



/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenConsoleChannel --
 *
 *	Constructs a Console channel for the specified standard OS handle.
 *      This is a helper function to break up the construction of 
 *      channels into File, Console, or Serial.
 *
 * Results:
 *	Returns the new channel, or NULL.
 *
 * Side effects:
 *	May open the channel
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclWinOpenConsoleChannel(handle, channelName, permissions)
    HANDLE handle;
    char *channelName;
    int permissions;
{
    char encoding[4 + TCL_INTEGER_SPACE];
    ConsoleInfo *infoPtr;
    ThreadSpecificData *tsdPtr;
    DWORD id, modes;

    tsdPtr = ConsoleInit();

    /*
     * See if a channel with this handle already exists.
     */
    
    infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
    memset(infoPtr, 0, sizeof(ConsoleInfo));

    infoPtr->validMask = permissions;
    infoPtr->handle = handle;


    wsprintfA(encoding, "cp%d", GetConsoleCP());



    /*
     * Use the pointer for the name of the result channel.
     * This keeps the channel names unique, since some may share
     * handles (stdin/stdout/stderr for instance).
     */

    wsprintfA(channelName, "file%lx", (int) infoPtr);
    
    infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
            (ClientData) infoPtr, permissions);

    infoPtr->threadId = Tcl_GetCurrentThread();

    if (permissions & TCL_READABLE) {
	/*
	 * Make sure the console input buffer is ready for only character
	 * input notifications and the buffer is set for line buffering.
	 * IOW, we only want to catch when complete lines are ready for
	 * reading.
	 */

	GetConsoleMode(infoPtr->handle, &modes);
	modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
	modes |= ENABLE_LINE_INPUT;
	SetConsoleMode(infoPtr->handle, modes);

	infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
	        infoPtr, 0, &id);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
    }

    if (permissions & TCL_WRITABLE) {
	infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
	        infoPtr, 0, &id);
	SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
    }

    /*
     * Files have default translation of AUTO and ^Z eof char, which
     * means that a ^Z will be accepted as EOF when reading.
     */
    
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);

    return infoPtr->channel;
}
































































|
|





|
|
|



>
>
>
>
>
|
>














|
|


















<


|










>



>
>

|
|
|





|
<
<




|
|
<

>









|








|




|
|








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299

1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328


1329
1330
1331
1332
1333
1334

1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
	    } else {
		toWrite -= count;
		buf += count;
	    }
	}

	/*
	 * Signal the main thread by signalling the writable event and then
	 * waking up the notifier thread.
	 */
	
	SetEvent(infoPtr->writable);

	/*
	 * Alert the foreground thread. Note that we need to treat this like a
	 * critical section so the foreground thread does not terminate this
	 * thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&consoleMutex);
	if (infoPtr->threadId != NULL) {
	    /*
	     * TIP #218. When in flight ignore the event, no one will receive
	     * it anyway.
	     */
	    Tcl_ThreadAlert(infoPtr->threadId);
	}
	Tcl_MutexUnlock(&consoleMutex);
    }

    return 0;
}



/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenConsoleChannel --
 *
 *	Constructs a Console channel for the specified standard OS handle.
 *	This is a helper function to break up the construction of channels
 *	into File, Console, or Serial.
 *
 * Results:
 *	Returns the new channel, or NULL.
 *
 * Side effects:
 *	May open the channel
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclWinOpenConsoleChannel(handle, channelName, permissions)
    HANDLE handle;
    char *channelName;
    int permissions;
{
    char encoding[4 + TCL_INTEGER_SPACE];
    ConsoleInfo *infoPtr;

    DWORD id, modes;

    ConsoleInit();

    /*
     * See if a channel with this handle already exists.
     */
    
    infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
    memset(infoPtr, 0, sizeof(ConsoleInfo));

    infoPtr->validMask = permissions;
    infoPtr->handle = handle;
    infoPtr->channel = (Tcl_Channel) NULL;

    wsprintfA(encoding, "cp%d", GetConsoleCP());

    infoPtr->threadId = Tcl_GetCurrentThread();

    /*
     * Use the pointer for the name of the result channel. This keeps the
     * channel names unique, since some may share handles (stdin/stdout/stderr
     * for instance).
     */

    wsprintfA(channelName, "file%lx", (int) infoPtr);
    
    infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
	    (ClientData) infoPtr, permissions);



    if (permissions & TCL_READABLE) {
	/*
	 * Make sure the console input buffer is ready for only character
	 * input notifications and the buffer is set for line buffering. IOW,
	 * we only want to catch when complete lines are ready for reading.

	 */

	GetConsoleMode(infoPtr->handle, &modes);
	modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
	modes |= ENABLE_LINE_INPUT;
	SetConsoleMode(infoPtr->handle, modes);

	infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
		infoPtr, 0, &id);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
    }

    if (permissions & TCL_WRITABLE) {
	infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
		infoPtr, 0, &id);
	SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
    }

    /*
     * Files have default translation of AUTO and ^Z eof char, which means
     * that a ^Z will be accepted as EOF when reading.
     */
    
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleThreadActionProc --
 *
 *	Insert or remove any thread local refs to this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleThreadActionProc (instanceData, action)
     ClientData instanceData;
     int action;
{
    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;

    /* We do not access firstConsolePtr in the thread structures. This is not
     * for all serials managed by the thread, but only those we are watching.
     * Removal of the filevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&consoleMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the
	 * channel is created. At this time the channel back pointer has not
	 * been set yet. However in that case the threadId has already been
	 * set by TclpCreateCommandChannel itself, so the structure is still
	 * good.
	 */

	ConsoleInit();
	if (infoPtr->channel != NULL) {
	    infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
	}
    } else {
	infoPtr->threadId = NULL;
    }
    Tcl_MutexUnlock(&consoleMutex);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinDde.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
/*
 * tclWinDde.c --
 *
 *	This file provides procedures that implement the "send"
 *	command, allowing commands to be passed from interpreter
 *	to interpreter.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinDde.c,v 1.26 2004/11/30 18:40:33 kennykb Exp $
 */

#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
#include <tchar.h>

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
 * Dde_Init declaration is in the source file itself, which is only
 * accessed when we are building a library. DO NOT MOVE BEFORE ANY
 * #include LINES. ONLY USE EXTERN TO INDICATE EXPORTED FUNCTIONS FROM
 * NOW ON.
 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

/*
 * The following structure is used to keep track of the interpreters



|
|
<



|
|

|








|
|
|
|
<







1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
/*
 * tclWinDde.c --
 *
 *	This file provides functions that implement the "send" command,
 *	allowing commands to be passed from interpreter to interpreter.

 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinDde.c,v 1.26.2.1 2005/08/02 18:17:01 dgp Exp $
 */

#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
#include <tchar.h>

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
 * declaration is in the source file itself, which is only accessed when we
 * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE
 * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON.

 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

/*
 * The following structure is used to keep track of the interpreters
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    ATOM service;
    ATOM topic;
    HWND hwnd;
};

typedef struct ThreadSpecificData {
    Conversation *currentConversations;
				/* A list of conversations currently
				 * being processed. */
    RegisteredInterp *interpListPtr;
				/* List of all interpreters registered
				 * in the current process. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

/*
 * The following variables cannot be placed in thread-local storage.
 * The Mutex ddeMutex guards access to the ddeInstance.
 */

static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance;       /* The application instance handle given
				 * to us by DdeInitialize. */
static int ddeIsServer = 0;

#define TCL_DDE_VERSION		"1.3.1"
#define TCL_DDE_PACKAGE_NAME	"dde"
#define TCL_DDE_SERVICE_NAME	"TclEval"
#define TCL_DDE_EXECUTE_RESULT	"$TCLEVAL$EXECUTE$RESULT"

TCL_DECLARE_MUTEX(ddeMutex)

/*
 * Forward declarations for procedures defined later in this file.
 */

static LRESULT CALLBACK	    DdeClientWindowProc _ANSI_ARGS_((
				HWND hwnd, UINT uMsg, WPARAM wParam,
				LPARAM lParam));
static int		    DdeCreateClient _ANSI_ARGS_((
				struct DdeEnumServices *es));
static BOOL CALLBACK	    DdeEnumWindowsCallback _ANSI_ARGS_((
				HWND hwndTarget, LPARAM lParam));
static void		    DdeExitProc _ANSI_ARGS_((ClientData clientData));
static int                  DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp,
				char *serviceName, char *topicName));
static HDDEDATA CALLBACK    DdeServerProc _ANSI_ARGS_((UINT uType,
				UINT uFmt, HCONV hConv, HSZ ddeTopic,
				HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
				DWORD dwData2));
static LRESULT		    DdeServicesOnAck _ANSI_ARGS_((HWND hwnd,
				WPARAM wParam, LPARAM lParam));







|
|

|
|




|
|



|
|










|










|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
    ATOM service;
    ATOM topic;
    HWND hwnd;
};

typedef struct ThreadSpecificData {
    Conversation *currentConversations;
				/* A list of conversations currently being
				 * processed. */
    RegisteredInterp *interpListPtr;
				/* List of all interpreters registered in the
				 * current process. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

/*
 * The following variables cannot be placed in thread-local storage. The Mutex
 * ddeMutex guards access to the ddeInstance.
 */

static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance;	/* The application instance handle given to us
				 * by DdeInitialize. */
static int ddeIsServer = 0;

#define TCL_DDE_VERSION		"1.3.1"
#define TCL_DDE_PACKAGE_NAME	"dde"
#define TCL_DDE_SERVICE_NAME	"TclEval"
#define TCL_DDE_EXECUTE_RESULT	"$TCLEVAL$EXECUTE$RESULT"

TCL_DECLARE_MUTEX(ddeMutex)

/*
 * Forward declarations for functions defined later in this file.
 */

static LRESULT CALLBACK	    DdeClientWindowProc _ANSI_ARGS_((
				HWND hwnd, UINT uMsg, WPARAM wParam,
				LPARAM lParam));
static int		    DdeCreateClient _ANSI_ARGS_((
				struct DdeEnumServices *es));
static BOOL CALLBACK	    DdeEnumWindowsCallback _ANSI_ARGS_((
				HWND hwndTarget, LPARAM lParam));
static void		    DdeExitProc _ANSI_ARGS_((ClientData clientData));
static int		    DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp,
				char *serviceName, char *topicName));
static HDDEDATA CALLBACK    DdeServerProc _ANSI_ARGS_((UINT uType,
				UINT uFmt, HCONV hConv, HSZ ddeTopic,
				HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
				DWORD dwData2));
static LRESULT		    DdeServicesOnAck _ANSI_ARGS_((HWND hwnd,
				WPARAM wParam, LPARAM lParam));
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
EXTERN int		    Dde_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));

/*
 *----------------------------------------------------------------------
 *
 * Dde_Init --
 *
 *	This procedure initializes the dde command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *







|







123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
EXTERN int		    Dde_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));

/*
 *----------------------------------------------------------------------
 *
 * Dde_Init --
 *
 *	This function initializes the dde command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
}

/*
 *----------------------------------------------------------------------
 *
 * Dde_SafeInit --
 *
 *	This procedure initializes the dde command within a safe interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *







|







155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
}

/*
 *----------------------------------------------------------------------
 *
 * Dde_SafeInit --
 *
 *	This function initializes the dde command within a safe interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
static void
Initialize(void)
{
    int nameFound = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its
     * current name from the registry. The deletion of the command
     * will take care of disposing of this entry.
     */

    if (tsdPtr->interpListPtr != NULL) {
	nameFound = 1;
    }

    /*
     * Make sure that the DDE server is there. This is done only once,
     * add an exit handler tear it down.
     */

    if (ddeInstance == 0) {
	Tcl_MutexLock(&ddeMutex);
	if (ddeInstance == 0) {
	    if (DdeInitialize(&ddeInstance, DdeServerProc,
		    CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS







|
|
|







|
|







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
static void
Initialize(void)
{
    int nameFound = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its current
     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

    if (tsdPtr->interpListPtr != NULL) {
	nameFound = 1;
    }

    /*
     * Make sure that the DDE server is there. This is done only once, add an
     * exit handler tear it down.
     */

    if (ddeInstance == 0) {
	Tcl_MutexLock(&ddeMutex);
	if (ddeInstance == 0) {
	    if (DdeInitialize(&ddeInstance, DdeServerProc,
		    CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372

373


374
375
376
377
378
379
380
}

/*
 *----------------------------------------------------------------------
 *
 * DdeSetServerName --
 *
 *	This procedure is called to associate an ASCII name with a Dde
 *	server.  If the interpreter has already been named, the
 *	name replaces the old one.
 *
 * Results:
 *	The return value is the name actually given to the interp.
 *	This will normally be the same as name, but if name was already
 *	in use for a Dde Server then a name of the form "name #2" will
 *	be chosen,  with a high enough number to make the name unique.
 *
 * Side effects:
 *	Registration info is saved, thereby allowing the "send" command
 *	to be used later to invoke commands in the application.  In
 *	addition, the "send" command is created in the application's
 *	interpreter.  The registration will be removed automatically
 *	if the interpreter is deleted or the "send" command is removed.
 *
 *----------------------------------------------------------------------
 */

static char *
DdeSetServerName(interp, name, exactName, handlerPtr)
    Tcl_Interp *interp;
    char *name;			/* The name that will be used to refer to the
				 * interpreter in later "send" commands.  Must
				 * be globally unique. */
    int exactName;		/* Should we make a unique name? 0 = unique */
    Tcl_Obj *handlerPtr;	/* Name of the optional proc/command to handle
				 * incoming Dde eval's */
{
    int suffix, offset;
    RegisteredInterp *riPtr, *prevPtr;
    Tcl_DString dString;
    char *actualName;
    Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
    int n, srvCount = 0, lastSuffix, r = TCL_OK;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its
     * current name from the registry. The deletion of the command
     * will take care of disposing of this entry.
     */

    for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
	if (riPtr->interp == interp) {
	    if (name != NULL) {
		if (prevPtr == NULL) {
		    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = riPtr->nextPtr;
		}
		break;
	    } else {
		/*
		 * the name was NULL, so the caller is asking for
		 * the name of the current interp.
		 */

		return riPtr->name;
	    }
	}
    }

    if (name == NULL) {
	/*
	 * the name was NULL, so the caller is asking for
	 * the name of the current interp, but it doesn't
	 * have a name.
	 */

	return "";
    }

    /*
     * Get the list of currently registered Tcl interpreters by calling
     * the internal implementation of the 'dde services' command.
     */

    Tcl_DStringInit(&dString);
    actualName = name;

    if (!exactName) {
	r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
	if (r == TCL_OK) {
	    srvListPtr = Tcl_GetObjResult(interp);
	}
	if (r == TCL_OK) {
	    r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
		    &srvPtrPtr);
	}
	if (r != TCL_OK) {
	    OutputDebugString(Tcl_GetStringResult(interp));
	    return NULL;
	}

	/*
	 * Pick a name to use for the application.  Use "name" if it's not
	 * already in use.  Otherwise add a suffix such as " #2", trying
	 * larger and larger numbers until we eventually find one that is
	 * unique.
	 */

	offset = lastSuffix = 0;
	suffix = 1;

	while (suffix != lastSuffix) {
	    lastSuffix = suffix;
	    if (suffix > 1) {
		if (suffix == 2) {
		    Tcl_DStringAppend(&dString, name, -1);
		    Tcl_DStringAppend(&dString, " #", 2);
		    offset = Tcl_DStringLength(&dString);
		    Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
		    actualName = Tcl_DStringValue(&dString);
		}
		sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
	    }


	    /* see if the name is already in use, if so increment suffix */


	    for (n = 0; n < srvCount; ++n) {
		Tcl_Obj* namePtr;

		Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
		if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
		    suffix++;
		    break;







|
|
|


|
|
|
|


|
|
|
|
|








|














|
|
|














|
|









|
|
<






|
|

>


















|
|
|
<


















>
|
>
>







245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320

321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
}

/*
 *----------------------------------------------------------------------
 *
 * DdeSetServerName --
 *
 *	This function is called to associate an ASCII name with a Dde server.
 *	If the interpreter has already been named, the name replaces the old
 *	one.
 *
 * Results:
 *	The return value is the name actually given to the interp. This will
 *	normally be the same as name, but if name was already in use for a Dde
 *	Server then a name of the form "name #2" will be chosen, with a high
 *	enough number to make the name unique.
 *
 * Side effects:
 *	Registration info is saved, thereby allowing the "send" command to be
 *	used later to invoke commands in the application. In addition, the
 *	"send" command is created in the application's interpreter. The
 *	registration will be removed automatically if the interpreter is
 *	deleted or the "send" command is removed.
 *
 *----------------------------------------------------------------------
 */

static char *
DdeSetServerName(interp, name, exactName, handlerPtr)
    Tcl_Interp *interp;
    char *name;			/* The name that will be used to refer to the
				 * interpreter in later "send" commands. Must
				 * be globally unique. */
    int exactName;		/* Should we make a unique name? 0 = unique */
    Tcl_Obj *handlerPtr;	/* Name of the optional proc/command to handle
				 * incoming Dde eval's */
{
    int suffix, offset;
    RegisteredInterp *riPtr, *prevPtr;
    Tcl_DString dString;
    char *actualName;
    Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
    int n, srvCount = 0, lastSuffix, r = TCL_OK;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its current
     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

    for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
	if (riPtr->interp == interp) {
	    if (name != NULL) {
		if (prevPtr == NULL) {
		    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = riPtr->nextPtr;
		}
		break;
	    } else {
		/*
		 * The name was NULL, so the caller is asking for the name of
		 * the current interp.
		 */

		return riPtr->name;
	    }
	}
    }

    if (name == NULL) {
	/*
	 * The name was NULL, so the caller is asking for the name of the
	 * current interp, but it doesn't have a name.

	 */

	return "";
    }

    /*
     * Get the list of currently registered Tcl interpreters by calling the
     * internal implementation of the 'dde services' command.
     */

    Tcl_DStringInit(&dString);
    actualName = name;

    if (!exactName) {
	r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
	if (r == TCL_OK) {
	    srvListPtr = Tcl_GetObjResult(interp);
	}
	if (r == TCL_OK) {
	    r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
		    &srvPtrPtr);
	}
	if (r != TCL_OK) {
	    OutputDebugString(Tcl_GetStringResult(interp));
	    return NULL;
	}

	/*
	 * Pick a name to use for the application. Use "name" if it's not
	 * already in use. Otherwise add a suffix such as " #2", trying larger
	 * and larger numbers until we eventually find one that is unique.

	 */

	offset = lastSuffix = 0;
	suffix = 1;

	while (suffix != lastSuffix) {
	    lastSuffix = suffix;
	    if (suffix > 1) {
		if (suffix == 2) {
		    Tcl_DStringAppend(&dString, name, -1);
		    Tcl_DStringAppend(&dString, " #", 2);
		    offset = Tcl_DStringLength(&dString);
		    Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
		    actualName = Tcl_DStringValue(&dString);
		}
		sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
	    }

	    /*
	     * See if the name is already in use, if so increment suffix.
	     */

	    for (n = 0; n < srvCount; ++n) {
		Tcl_Obj* namePtr;

		Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
		if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
		    suffix++;
		    break;
406
407
408
409
410
411
412
413
414

415
416
417
418
419
420
421
	    (ClientData) riPtr, DeleteProc);
    if (Tcl_IsSafe(interp)) {
	Tcl_HideCommand(interp, "dde", "dde");
    }
    Tcl_DStringFree(&dString);

    /*
     * re-initialize with the new name
     */

    Initialize();

    return riPtr->name;
}

/*
 *----------------------------------------------------------------------







|

>







406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
	    (ClientData) riPtr, DeleteProc);
    if (Tcl_IsSafe(interp)) {
	Tcl_HideCommand(interp, "dde", "dde");
    }
    Tcl_DStringFree(&dString);

    /*
     * Re-initialize with the new name.
     */

    Initialize();

    return riPtr->name;
}

/*
 *----------------------------------------------------------------------
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteProc
 *
 *	This procedure is called when the command "dde" is destroyed.
 *
 * Results:
 *	none
 *
 * Side effects:
 *	The interpreter given by riPtr is unregistered.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteProc(clientData)
    ClientData clientData;	/* The interp we are deleting passed
				 * as ClientData. */
{
    RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
    RegisteredInterp *searchPtr, *prevPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
	    searchPtr != NULL && searchPtr != riPtr;







|












|
|







451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteProc
 *
 *	This function is called when the command "dde" is destroyed.
 *
 * Results:
 *	none
 *
 * Side effects:
 *	The interpreter given by riPtr is unregistered.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteProc(clientData)
    ClientData clientData;	/* The interp we are deleting passed as
				 * ClientData. */
{
    RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
    RegisteredInterp *searchPtr, *prevPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
	    searchPtr != NULL && searchPtr != riPtr;
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538

539


540
541
542
543
544
545
546
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteRemoteObject --
 *
 *	Takes the package delivered by DDE and executes it in the
 *	server's interpreter.
 *
 * Results:
 *	A list Tcl_Obj * that describes what happened. The first
 *	element is the numerical return code (TCL_ERROR, etc.).  The
 *	second element is the result of the script. If the return
 *	result was TCL_ERROR, then the third element will be the value
 *	of the global "errorCode", and the fourth will be the value of
 *	the global "errorInfo".  The return result will have a
 *	refCount of 0.
 *
 * Side effects:
 *	A Tcl script is run, which can cause all kinds of other things
 *	to happen.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ExecuteRemoteObject(riPtr, ddeObjectPtr)
    RegisteredInterp *riPtr;	    /* Info about this server. */
    Tcl_Obj *ddeObjectPtr;	    /* The object to execute. */
{
    Tcl_Obj *returnPackagePtr;
    int result = TCL_OK;

    if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
	Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
		"a handler procedure must be defined for use in a safe "
		"interp", -1));
	result = TCL_ERROR;
    }

    if (riPtr->handlerPtr != NULL) {

	/* add the dde request data to the handler proc list */


	Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);

	result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr);
	if (result == TCL_OK) {
	    ddeObjectPtr = cmdPtr;
	}
    }







|
|


|
|
|
<
|
|
|


|
|




















>
|
>
>







498
499
500
501
502
503
504
505
506
507
508
509
510
511

512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteRemoteObject --
 *
 *	Takes the package delivered by DDE and executes it in the server's
 *	interpreter.
 *
 * Results:
 *	A list Tcl_Obj * that describes what happened. The first element is
 *	the numerical return code (TCL_ERROR, etc.). The second element is the
 *	result of the script. If the return result was TCL_ERROR, then the

 *	third element will be the value of the global "errorCode", and the
 *	fourth will be the value of the global "errorInfo". The return result
 *	will have a refCount of 0.
 *
 * Side effects:
 *	A Tcl script is run, which can cause all kinds of other things to
 *	happen.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ExecuteRemoteObject(riPtr, ddeObjectPtr)
    RegisteredInterp *riPtr;	    /* Info about this server. */
    Tcl_Obj *ddeObjectPtr;	    /* The object to execute. */
{
    Tcl_Obj *returnPackagePtr;
    int result = TCL_OK;

    if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
	Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
		"a handler procedure must be defined for use in a safe "
		"interp", -1));
	result = TCL_ERROR;
    }

    if (riPtr->handlerPtr != NULL) {
	/*
	 * Add the dde request data to the handler proc list.
	 */

	Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);

	result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr);
	if (result == TCL_OK) {
	    ddeObjectPtr = cmdPtr;
	}
    }
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
}

/*
 *----------------------------------------------------------------------
 *
 * DdeServerProc --
 *
 *	Handles all transactions for this server. Can handle execute,
 *	request, and connect protocols. Dde will call this routine
 *	when a client attempts to run a dde command using this server.
 *
 * Results:
 *	A DDE Handle with the result of the dde command.
 *
 * Side effects:
 *	Depending on which command is executed, arbitrary Tcl scripts
 *	can be run.
 *
 *----------------------------------------------------------------------
 */

static HDDEDATA CALLBACK
DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
    UINT uType;			/* The type of DDE transaction we are







|
|
|





|
|







575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
}

/*
 *----------------------------------------------------------------------
 *
 * DdeServerProc --
 *
 *	Handles all transactions for this server. Can handle execute, request,
 *	and connect protocols. Dde will call this routine when a client
 *	attempts to run a dde command using this server.
 *
 * Results:
 *	A DDE Handle with the result of the dde command.
 *
 * Side effects:
 *	Depending on which command is executed, arbitrary Tcl scripts can be
 *	run.
 *
 *----------------------------------------------------------------------
 */

static HDDEDATA CALLBACK
DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
    UINT uType;			/* The type of DDE transaction we are
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
    HDDEDATA ddeReturn = NULL;
    RegisteredInterp *riPtr;
    Conversation *convPtr, *prevConvPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    switch(uType) {
    case XTYP_CONNECT:

	/*
	 * Dde is trying to initialize a conversation with us. Check
	 * and make sure we have a valid topic.
	 */

	len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
	Tcl_DStringInit(&dString);
	Tcl_DStringSetLength(&dString, len);
	utilString = Tcl_DStringValue(&dString);
	DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,







<

|
|







613
614
615
616
617
618
619

620
621
622
623
624
625
626
627
628
629
    HDDEDATA ddeReturn = NULL;
    RegisteredInterp *riPtr;
    Conversation *convPtr, *prevConvPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    switch(uType) {
    case XTYP_CONNECT:

	/*
	 * Dde is trying to initialize a conversation with us. Check and make
	 * sure we have a valid topic.
	 */

	len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
	Tcl_DStringInit(&dString);
	Tcl_DStringSetLength(&dString, len);
	utilString = Tcl_DStringValue(&dString);
	DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
	    }
	}

	Tcl_DStringFree(&dString);
	return (HDDEDATA) FALSE;

    case XTYP_CONNECT_CONFIRM:

	/*
	 * Dde has decided that we can connect, so it gives us a
	 * conversation handle. We need to keep track of it
	 * so we know which execution result to return in an
	 * XTYP_REQUEST.
	 */

	len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
	Tcl_DStringInit(&dString);
	Tcl_DStringSetLength(&dString, len);
	utilString = Tcl_DStringValue(&dString);
	DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,







<

|
|
|
<







637
638
639
640
641
642
643

644
645
646
647

648
649
650
651
652
653
654
	    }
	}

	Tcl_DStringFree(&dString);
	return (HDDEDATA) FALSE;

    case XTYP_CONNECT_CONFIRM:

	/*
	 * Dde has decided that we can connect, so it gives us a conversation
	 * handle. We need to keep track of it so we know which execution
	 * result to return in an XTYP_REQUEST.

	 */

	len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
	Tcl_DStringInit(&dString);
	Tcl_DStringSetLength(&dString, len);
	utilString = Tcl_DStringValue(&dString);
	DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
		break;
	    }
	}
	Tcl_DStringFree(&dString);
	return (HDDEDATA) TRUE;

    case XTYP_DISCONNECT:

	/*
	 * The client has disconnected from our server. Forget this
	 * conversation.
	 */

	for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
		convPtr != NULL;







<







665
666
667
668
669
670
671

672
673
674
675
676
677
678
		break;
	    }
	}
	Tcl_DStringFree(&dString);
	return (HDDEDATA) TRUE;

    case XTYP_DISCONNECT:

	/*
	 * The client has disconnected from our server. Forget this
	 * conversation.
	 */

	for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
		convPtr != NULL;
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
		ckfree((char *) convPtr);
		break;
	    }
	}
	return (HDDEDATA) TRUE;

    case XTYP_REQUEST:

	/*
	 * This could be either a request for a value of a Tcl variable,
	 * or it could be the send command requesting the results of the
	 * last execute.
	 */

	if (uFmt != CF_TEXT) {
	    return (HDDEDATA) FALSE;
	}

	ddeReturn = (HDDEDATA) FALSE;







<

|
|
|







689
690
691
692
693
694
695

696
697
698
699
700
701
702
703
704
705
706
		ckfree((char *) convPtr);
		break;
	    }
	}
	return (HDDEDATA) TRUE;

    case XTYP_REQUEST:

	/*
	 * This could be either a request for a value of a Tcl variable, or it
	 * could be the send command requesting the results of the last
	 * execute.
	 */

	if (uFmt != CF_TEXT) {
	    return (HDDEDATA) FALSE;
	}

	ddeReturn = (HDDEDATA) FALSE;
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
		}
	    }
	    Tcl_DStringFree(&dString);
	}
	return ddeReturn;

    case XTYP_EXECUTE: {

	/*
	 * Execute this script. The results will be saved into
	 * a list object which will be retreived later. See
	 * ExecuteRemoteObject.
	 */

	Tcl_Obj *returnPackagePtr;

	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
		&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
	    /*







<

|
|
<







744
745
746
747
748
749
750

751
752
753

754
755
756
757
758
759
760
		}
	    }
	    Tcl_DStringFree(&dString);
	}
	return ddeReturn;

    case XTYP_EXECUTE: {

	/*
	 * Execute this script. The results will be saved into a list object
	 * which will be retreived later. See ExecuteRemoteObject.

	 */

	Tcl_Obj *returnPackagePtr;

	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
		&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
	    /*
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
	    return (HDDEDATA) DDE_FNOTPROCESSED;
	} else {
	    return (HDDEDATA) DDE_FACK;
	}
    }

    case XTYP_WILDCONNECT: {

	/*
	 * Dde wants a list of services and topics that we support.
	 */

	HSZPAIR *returnPtr;
	int i;
	int numItems;







<







793
794
795
796
797
798
799

800
801
802
803
804
805
806
	    return (HDDEDATA) DDE_FNOTPROCESSED;
	} else {
	    return (HDDEDATA) DDE_FACK;
	}
    }

    case XTYP_WILDCONNECT: {

	/*
	 * Dde wants a list of services and topics that we support.
	 */

	HSZPAIR *returnPtr;
	int i;
	int numItems;
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
}

/*
 *----------------------------------------------------------------------
 *
 * MakeDdeConnection --
 *
 *	This procedure is a utility used to connect to a DDE server
 *	when given a server name and a topic name.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Passes back a conversation through ddeConvPtr
 *







|
|







861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
}

/*
 *----------------------------------------------------------------------
 *
 * MakeDdeConnection --
 *
 *	This function is a utility used to connect to a DDE server when given
 *	a server name and a topic name.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Passes back a conversation through ddeConvPtr
 *
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
}

/*
 *----------------------------------------------------------------------
 *
 * DdeGetServicesList --
 *
 *	This procedure obtains the list of DDE services.
 *
 *	The functions between here and this procedure are all involved
 *	with handling the DDE callbacks for this.  They are:
 *	DdeCreateClient, DdeClientWindowProc, DdeServicesOnAck, and
 *	DdeEnumWindowsCallback
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets the services list into the interp result.
 *







|

|
|
|
<







906
907
908
909
910
911
912
913
914
915
916
917

918
919
920
921
922
923
924
}

/*
 *----------------------------------------------------------------------
 *
 * DdeGetServicesList --
 *
 *	This function obtains the list of DDE services.
 *
 *	The functions between here and this function are all involved with
 *	handling the DDE callbacks for this. They are: DdeCreateClient,
 *	DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback

 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets the services list into the interp result.
 *
941
942
943
944
945
946
947

948


949
950
951
952
953
954
955

    memset(&wc, 0, sizeof(wc));
    wc.cbSize = sizeof(wc);
    wc.lpfnWndProc = DdeClientWindowProc;
    wc.lpszClassName = szDdeClientClassName;
    wc.cbWndExtra = sizeof(struct DdeEnumServices *);


    /* register and create the callback window */


    RegisterClassEx(&wc);
    es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName,
	    WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
    return TCL_OK;
}

static LRESULT CALLBACK







>
|
>
>







935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952

    memset(&wc, 0, sizeof(wc));
    wc.cbSize = sizeof(wc);
    wc.lpfnWndProc = DdeClientWindowProc;
    wc.lpszClassName = szDdeClientClassName;
    wc.cbWndExtra = sizeof(struct DdeEnumServices *);

    /*
     * Register and create the callback window.
     */

    RegisterClassEx(&wc);
    es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName,
	    WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
    return TCL_OK;
}

static LRESULT CALLBACK
1026
1027
1028
1029
1030
1031
1032

1033


1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
	}
	if (Tcl_ListObjAppendElement(es->interp, resultPtr,
		matchPtr) == TCL_OK) {
	    Tcl_SetObjResult(es->interp, resultPtr);
	}
    }


    /* tell the server we are no longer interested */


    PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
    return 0L;
}

static BOOL CALLBACK
DdeEnumWindowsCallback(hwndTarget, lParam)
    HWND hwndTarget;
    LPARAM lParam;
{
    LRESULT dwResult = 0;
    struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;

    SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
	    MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
	    &dwResult);
    return TRUE;
}

static int
DdeGetServicesList(interp, serviceName, topicName)
    Tcl_Interp *interp;
    char *serviceName, *topicName;
{
    struct DdeEnumServices es;








>
|
>
>



|













|







1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
	}
	if (Tcl_ListObjAppendElement(es->interp, resultPtr,
		matchPtr) == TCL_OK) {
	    Tcl_SetObjResult(es->interp, resultPtr);
	}
    }

    /*
     * Tell the server we are no longer interested.
     */

    PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
    return 0L;
}

static BOOL CALLBACK
DdeEnumWindowsCallback(hwndTarget, lParam)
    HWND hwndTarget;
    LPARAM lParam;
{
    LRESULT dwResult = 0;
    struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;

    SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
	    MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
	    &dwResult);
    return TRUE;
}

static int
DdeGetServicesList(interp, serviceName, topicName)
    Tcl_Interp *interp;
    char *serviceName, *topicName;
{
    struct DdeEnumServices es;

1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
}

/*
 *----------------------------------------------------------------------
 *
 * SetDdeError --
 *
 *	Sets the interp result to a cogent error message describing
 *	the last DDE error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interp's result object is changed.
 *







|
|







1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
}

/*
 *----------------------------------------------------------------------
 *
 * SetDdeError --
 *
 *	Sets the interp result to a cogent error message describing the last
 *	DDE error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interp's result object is changed.
 *
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DdeObjCmd --
 *
 *	This procedure is invoked to process the "dde" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|
|







1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DdeObjCmd --
 *
 *	This function is invoked to process the "dde" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201

1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212

1213
1214
1215
1216
1217
1218
1219
    switch ((enum DdeSubcommands) index) {
    case DDE_SERVERNAME:
	for (i = 2; i < objc; i++) {
	    enum DdeSrvOptions argIndex;
	    if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
		    "option", 0, (int *) &argIndex) != TCL_OK) {
		/*
		 * If it is the last argument, it might be a server
		 * name instead of a bad argument.
		 */

		if (i != objc-1) {
		    return TCL_ERROR;
		}
		Tcl_ResetResult(interp);
		break;
	    }
	    if (argIndex == DDE_SERVERNAME_EXACT) {
		exact = 1;
	    } else if (argIndex == DDE_SERVERNAME_HANDLER) {
		if ((objc - i) == 1) { /* return current handler */
		    RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);

		    if (riPtr && riPtr->handlerPtr) {
			Tcl_SetObjResult(interp, riPtr->handlerPtr);
		    } else {
			Tcl_ResetResult(interp);
		    }
		    return TCL_OK;
		}







|
|

>









|

>







1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
    switch ((enum DdeSubcommands) index) {
    case DDE_SERVERNAME:
	for (i = 2; i < objc; i++) {
	    enum DdeSrvOptions argIndex;
	    if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
		    "option", 0, (int *) &argIndex) != TCL_OK) {
		/*
		 * If it is the last argument, it might be a server name
		 * instead of a bad argument.
		 */

		if (i != objc-1) {
		    return TCL_ERROR;
		}
		Tcl_ResetResult(interp);
		break;
	    }
	    if (argIndex == DDE_SERVERNAME_EXACT) {
		exact = 1;
	    } else if (argIndex == DDE_SERVERNAME_HANDLER) {
		if ((objc - i) == 1) {	/* return current handler */
		    RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);

		    if (riPtr && riPtr->handlerPtr) {
			Tcl_SetObjResult(interp, riPtr->handlerPtr);
		    } else {
			Tcl_ResetResult(interp);
		    }
		    return TCL_OK;
		}
1267
1268
1269
1270
1271
1272
1273


1274


1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291

1292
1293
1294
1295
1296
1297
1298
	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
		    &dummy) == TCL_OK) {
		binary = 1;
		firstArg = 3;
		break;
	    }
	}


	/* otherwise ... */


	Tcl_WrongNumArgs(interp, 2, objv,
		"?-binary? serviceName topicName value");
	return TCL_ERROR;
    case DDE_SERVICES:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName");
	    return TCL_ERROR;
	}
	firstArg = 2;
	break;
    case DDE_EVAL:
	if (objc < 4) {
	  wrongDdeEvalArgs:
	    Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
	    return TCL_ERROR;
	} else {
	    int dummy;

	    firstArg = 2;
	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
		    &dummy) == TCL_OK) {
		if (objc < 5) {
		    goto wrongDdeEvalArgs;
		}
		async = 1;







>
>
|
>
>












|




>







1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
		    &dummy) == TCL_OK) {
		binary = 1;
		firstArg = 3;
		break;
	    }
	}

	/*
	 * Otherwise ...
	 */

	Tcl_WrongNumArgs(interp, 2, objv,
		"?-binary? serviceName topicName value");
	return TCL_ERROR;
    case DDE_SERVICES:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName");
	    return TCL_ERROR;
	}
	firstArg = 2;
	break;
    case DDE_EVAL:
	if (objc < 4) {
	wrongDdeEvalArgs:
	    Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
	    return TCL_ERROR;
	} else {
	    int dummy;

	    firstArg = 2;
	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
		    &dummy) == TCL_OK) {
		if (objc < 5) {
		    goto wrongDdeEvalArgs;
		}
		async = 1;
1378
1379
1380
1381
1382
1383
1384

1385
1386
1387
1388
1389
1390
1391
	    SetDdeError(interp);
	    result = TCL_ERROR;
	}
	break;
    }
    case DDE_REQUEST: {
	char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);

	if (length == 0) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("cannot request value of null data", -1));
	    result = TCL_ERROR;
	    goto cleanup;
	}
	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);







>







1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
	    SetDdeError(interp);
	    result = TCL_ERROR;
	}
	break;
    }
    case DDE_REQUEST: {
	char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);

	if (length == 0) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("cannot request value of null data", -1));
	    result = TCL_ERROR;
	    goto cleanup;
	}
	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
	    goto cleanup;
	}

	objc -= (async + 3);
	((Tcl_Obj **) objv) += (async + 3);

	/*
	 * See if the target interpreter is local.  If so, execute
	 * the command directly without going through the DDE server.
	 * Don't exchange objects between interps.  The target interp could
	 * compile an object, producing a bytecode structure that refers to
	 * other objects owned by the target interp.  If the target interp
	 * is then deleted, the bytecode structure would be referring to
	 * deallocated objects.
	 */

	for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
		riPtr = riPtr->nextPtr) {
	    if (stricmp(serviceName, riPtr->name) == 0) {
		break;
	    }
	}

	if (riPtr != NULL) {
	    Tcl_Interp *sendInterp;

	    /*
	     * This command is to a local interp. No need to go through
	     * the server.
	     */

	    Tcl_Preserve((ClientData) riPtr);
	    sendInterp = riPtr->interp;
	    Tcl_Preserve((ClientData) sendInterp);

	    /*
	     * Don't exchange objects between interps.  The target interp
	     * would compile an object, producing a bytecode structure that
	     * refers to other objects owned by the target interp.  If the
	     * target interp is then deleted, the bytecode structure would
	     * be referring to deallocated objects.
	     */

	    if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
		Tcl_SetResult(riPtr->interp, "permission denied: "
			"a handler procedure must be defined for use in "
			"a safe interp", TCL_STATIC);
		result = TCL_ERROR;







|
|
|
|
|
|
<













|
|







|
|
|
|
|







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499

1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
	    goto cleanup;
	}

	objc -= (async + 3);
	((Tcl_Obj **) objv) += (async + 3);

	/*
	 * See if the target interpreter is local. If so, execute the command
	 * directly without going through the DDE server. Don't exchange
	 * objects between interps. The target interp could compile an object,
	 * producing a bytecode structure that refers to other objects owned
	 * by the target interp. If the target interp is then deleted, the
	 * bytecode structure would be referring to deallocated objects.

	 */

	for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
		riPtr = riPtr->nextPtr) {
	    if (stricmp(serviceName, riPtr->name) == 0) {
		break;
	    }
	}

	if (riPtr != NULL) {
	    Tcl_Interp *sendInterp;

	    /*
	     * This command is to a local interp. No need to go through the
	     * server.
	     */

	    Tcl_Preserve((ClientData) riPtr);
	    sendInterp = riPtr->interp;
	    Tcl_Preserve((ClientData) sendInterp);

	    /*
	     * Don't exchange objects between interps. The target interp would
	     * compile an object, producing a bytecode structure that refers
	     * to other objects owned by the target interp. If the target
	     * interp is then deleted, the bytecode structure would be
	     * referring to deallocated objects.
	     */

	    if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
		Tcl_SetResult(riPtr->interp, "permission denied: "
			"a handler procedure must be defined for use in "
			"a safe interp", TCL_STATIC);
		result = TCL_ERROR;
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
		Tcl_IncrRefCount(objPtr);
		result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
		Tcl_DecrRefCount(objPtr);
	    }
	    if (interp != sendInterp) {
		if (result == TCL_ERROR) {
		    /*
		     * An error occurred, so transfer error information
		     * from the destination interpreter back to our
		     * interpreter.
		     */

		    Tcl_ResetResult(interp);
		    objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
			    TCL_GLOBAL_ONLY);
		    if (objPtr) {
			string = Tcl_GetStringFromObj(objPtr, &length);







|
|
<







1557
1558
1559
1560
1561
1562
1563
1564
1565

1566
1567
1568
1569
1570
1571
1572
		Tcl_IncrRefCount(objPtr);
		result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
		Tcl_DecrRefCount(objPtr);
	    }
	    if (interp != sendInterp) {
		if (result == TCL_ERROR) {
		    /*
		     * An error occurred, so transfer error information from
		     * the destination interpreter back to our interpreter.

		     */

		    Tcl_ResetResult(interp);
		    objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
			    TCL_GLOBAL_ONLY);
		    if (objPtr) {
			string = Tcl_GetStringFromObj(objPtr, &length);
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
		}
		Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
	    }
	    Tcl_Release((ClientData) riPtr);
	    Tcl_Release((ClientData) sendInterp);
	} else {
	    /*
	     * This is a non-local request. Send the script to the server
	     * and poll it for a result.
	     */

	    if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
	      invalidServerResponse:
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("invalid data returned from server",
			-1));
		result = TCL_ERROR;
		goto cleanup;
	    }








|
|



|







1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
		}
		Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
	    }
	    Tcl_Release((ClientData) riPtr);
	    Tcl_Release((ClientData) sendInterp);
	} else {
	    /*
	     * This is a non-local request. Send the script to the server and
	     * poll it for a result.
	     */

	    if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
	    invalidServerResponse:
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("invalid data returned from server",
			-1));
		result = TCL_ERROR;
		goto cleanup;
	    }

1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
		result = TCL_ERROR;
	    }

	    if (async == 0) {
		Tcl_Obj *resultPtr;

		/*
		 * The return handle has a two or four element list in
		 * it. The first element is the return code (TCL_OK,
		 * TCL_ERROR, etc.). The second is the result of the
		 * script. If the return code is TCL_ERROR, then the third
		 * element is the value of the variable "errorCode", and
		 * the fourth is the value of the variable "errorInfo".
		 */

		resultPtr = Tcl_NewObj();
		length = DdeGetData(ddeData, NULL, 0, 0);
		Tcl_SetObjLength(resultPtr, length);
		string = Tcl_GetString(resultPtr);
		DdeGetData(ddeData, string, (DWORD) length, 0);







|
|
|
|
|
|







1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
		result = TCL_ERROR;
	    }

	    if (async == 0) {
		Tcl_Obj *resultPtr;

		/*
		 * The return handle has a two or four element list in it. The
		 * first element is the return code (TCL_OK, TCL_ERROR, etc.).
		 * The second is the result of the script. If the return code
		 * is TCL_ERROR, then the third element is the value of the
		 * variable "errorCode", and the fourth is the value of the
		 * variable "errorInfo".
		 */

		resultPtr = Tcl_NewObj();
		length = DdeGetData(ddeData, NULL, 0, 0);
		Tcl_SetObjLength(resultPtr, length);
		string = Tcl_GetString(resultPtr);
		DdeGetData(ddeData, string, (DWORD) length, 0);
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700


1701
1702
	DdeFreeDataHandle(ddeData);
    }
    if (hConv != NULL) {
	DdeDisconnect(hConv);
    }
    return result;
}

/*
 * Local variables:
 * mode: c
 * indent-tabs-mode: t
 * tab-width: 8


 * End:
 */







|





>
>


1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
	DdeFreeDataHandle(ddeData);
    }
    if (hConv != NULL) {
	DdeDisconnect(hConv);
    }
    return result;
}

/*
 * Local variables:
 * mode: c
 * indent-tabs-mode: t
 * tab-width: 8
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinFCmd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
/*
 * tclWinFCmd.c
 *
 *      This file implements the Windows specific portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFCmd.c,v 1.43 2004/10/06 16:37:18 dgp Exp $
 */

#include "tclWinInt.h"

/*
 * The following constants specify the type of callback when
 * TraverseWinTree() calls the traverseProc()
 */

#define DOTREE_PRED   1     /* pre-order directory  */
#define DOTREE_POSTD  2     /* post-order directory */
#define DOTREE_F      3     /* regular file */
#define DOTREE_LINK   4     /* symbolic link */

/*
 * Callbacks for file attributes code.
 */

static int		GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj **attributePtrPtr));
static int		GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj **attributePtrPtr));
static int		GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj **attributePtrPtr));
static int		SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj *attributePtr));
static int		CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj *attributePtr));

/*
 * Constants and variables necessary for file attributes subcommand.
 */

enum {
    WIN_ARCHIVE_ATTRIBUTE,



|
|



|
|

|









|
|
|
|





|
<
|
|
<
|
|
<
|
|
<
|
|
<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

32
33

34
35

36
37

38
39

40
41
42
43
44
45
46
47
/*
 * tclWinFCmd.c
 *
 *	This file implements the Windows specific portion of file manipulation
 *	subcommands of the "file" command.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFCmd.c,v 1.43.2.4 2005/08/15 18:14:15 dgp Exp $
 */

#include "tclWinInt.h"

/*
 * The following constants specify the type of callback when
 * TraverseWinTree() calls the traverseProc()
 */

#define DOTREE_PRED	1	/* pre-order directory  */
#define DOTREE_POSTD	2	/* post-order directory */
#define DOTREE_F	3	/* regular file */
#define DOTREE_LINK	4	/* symbolic link */

/*
 * Callbacks for file attributes code.
 */

static int		GetWinFileAttributes(Tcl_Interp *interp, int objIndex,

			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		GetWinFileLongName(Tcl_Interp *interp, int objIndex,

			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		GetWinFileShortName(Tcl_Interp *interp, int objIndex,

			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		SetWinFileAttributes(Tcl_Interp *interp, int objIndex,

			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
static int		CannotSetAttribute(Tcl_Interp *interp, int objIndex,

			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);

/*
 * Constants and variables necessary for file attributes subcommand.
 */

enum {
    WIN_ARCHIVE_ATTRIBUTE,
70
71
72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128

129
130
131

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195



196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239


240






241



242
243
244
245




246

247

248
249
250


251



252

253



254
255
256
257
258

259
260
261
262
263
264

265


266
267
268



269
270
271



272
273
274
275
276



277
278
279


280






















281
282
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297

298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333

334
335
336
337
338

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412

413
414
415
416
417
418
419
420
421
422
423
424
425
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileLongName, CannotSetAttribute},
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileShortName, CannotSetAttribute},
	{GetWinFileAttributes, SetWinFileAttributes}};

#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG)
static void *INITIAL_ESP,
            *INITIAL_EBP,

            *INITIAL_HANDLER,
            *RESTORED_ESP,
            *RESTORED_EBP,
            *RESTORED_HANDLER;
#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */

#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_dorenamefile_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext);

static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_docopyfile_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext);

#endif /* HAVE_NO_SEH */

/*
 * Prototype for the TraverseWinTree callback function.
 */

typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
	int type, Tcl_DString *errorPtr);

/*
 * Declarations for local procedures defined in this file:
 */

static void		StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
static int		ConvertFileNameFormat(Tcl_Interp *interp, 
			    int objIndex, Tcl_Obj *fileName, int longShort,
			    Tcl_Obj **attributePtrPtr);
static int		DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
static int		DoCreateDirectory(CONST TCHAR *pathPtr);
static int		DoRemoveJustDirectory(CONST TCHAR *nativeSrc, 
			    int ignoreError, Tcl_DString *errorPtr);
static int		DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, 
			    Tcl_DString *errorPtr);
static int		DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);

static int		TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
			    int type, Tcl_DString *errorPtr);
static int		TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 

			    int type, Tcl_DString *errorPtr);
static int		TraverseWinTree(TraversalProc *traverseProc,
			    Tcl_DString *sourcePtr, Tcl_DString *dstPtr, 
			    Tcl_DString *errorPtr);


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjRenameFile, DoRenameFile --
 *
 *      Changes the name of an existing file or directory, from src to dst.
 *	If src and dst refer to the same file or directory, does nothing
 *	and returns success.  Otherwise if dst already exists, it will be
 *	deleted and replaced by src subject to the following conditions:
 *	    If src is a directory, dst may be an empty directory.
 *	    If src is a file, dst may be a file.
 *	In any other situation where dst already exists, the rename will
 *	fail.  
 *
 * Results:
 *	If the file or directory was successfully renamed, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR and errno is set to
 *	indicate the error.  Some possible values for errno are:
 *
 *	ENAMETOOLONG: src or dst names are too long.
 *	EACCES:     src or dst parent directory can't be read and/or written.
 *	EEXIST:	    dst is a non-empty directory.
 *	EINVAL:	    src is a root directory or dst is a subdirectory of src.
 *	EISDIR:	    dst is a directory, but src is not.
 *	ENOENT:	    src doesn't exist.  src or dst is "".
 *	ENOTDIR:    src is a directory, but dst is not.  
 *	EXDEV:	    src and dst are on different filesystems.
 *
 *	EACCES:     exists an open file already referring to src or dst.
 *	EACCES:     src or dst specify the current working directory (NT).
 *	EACCES:	    src specifies a char device (nul:, com1:, etc.) 
 *	EEXIST:	    dst specifies a char device (nul:, com1:, etc.) (NT)
 *	EACCES:	    dst specifies a char device (nul:, com1:, etc.) (95)
 *	
 * Side effects:
 *	The implementation supports cross-filesystem renames of files,
 *	but the caller should be prepared to emulate cross-filesystem
 *	renames of directories if errno is EXDEV.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjRenameFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 
			Tcl_FSGetNativePath(destPathPtr));
}

static int
DoRenameFile(
    CONST TCHAR *nativeSrc,	/* Pathname of file or dir to be renamed
				 * (native). */ 
    CONST TCHAR *nativeDst)	/* New pathname for file or directory
				 * (native). */
{    



    DWORD srcAttr, dstAttr;
    int retval = -1;

    /*
     * The MoveFile API acts differently under Win95/98 and NT
     * WRT NULL and "". Avoid passing these values.
     */

    if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
	    nativeDst == NULL || nativeDst[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    /*
     * The MoveFile API would throw an exception under NT
     * if one of the arguments is a char block device.
     */

#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (
            "movl %%esp,  %0" "\n\t"
            "movl %%ebp,  %1" "\n\t"
            "movl %%fs:0, %2" "\n\t"
            : "=m"(INITIAL_ESP),
              "=m"(INITIAL_EBP),
              "=r"(INITIAL_HANDLER) );
# endif /* TCL_MEM_DEBUG */

    __asm__ __volatile__ (
            "pushl %%ebp" "\n\t"
            "pushl %0" "\n\t"
            "pushl %%fs:0" "\n\t"
            "movl  %%esp, %%fs:0"
            :
            : "r" (_except_dorenamefile_handler)
            );
#else
    __try {
#endif /* HAVE_NO_SEH */
	if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
	    retval = TCL_OK;
	}


#ifdef HAVE_NO_SEH






    __asm__ __volatile__ (



            "jmp  dorenamefile_pop" "\n"
        "dorenamefile_reentry:" "\n\t"
            "movl %%fs:0, %%eax" "\n\t"
            "movl 0x8(%%eax), %%esp" "\n\t"




            "movl 0x8(%%esp), %%ebp" "\n"

        "dorenamefile_pop:" "\n\t"

            "movl (%%esp), %%eax" "\n\t"
            "movl %%eax, %%fs:0" "\n\t"
            "add  $12, %%esp" "\n\t"


            :



            :

            : "%eax");




# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (
            "movl  %%esp,  %0" "\n\t"
            "movl  %%ebp,  %1" "\n\t"

            "movl  %%fs:0, %2" "\n\t"
            : "=m"(RESTORED_ESP),
              "=m"(RESTORED_EBP),
              "=r"(RESTORED_HANDLER) );

    if (INITIAL_ESP != RESTORED_ESP) {

        Tcl_Panic("ESP restored incorrectly");


    }
    if (INITIAL_EBP != RESTORED_EBP) {
        Tcl_Panic("EBP restored incorrectly");



    }
    if (INITIAL_HANDLER != RESTORED_HANDLER) {
        Tcl_Panic("HANDLER restored incorrectly");



    }
# endif /* TCL_MEM_DEBUG */
#else
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */




    /*
     * Avoid using control flow statements in the SEH guarded block!


     */






















    if (retval != -1) {
        return retval;
    }

    TclWinConvertError(GetLastError());

    srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
    dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
    if (srcAttr == 0xffffffff) {
	if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {

	    errno = ENAMETOOLONG;
	    return TCL_ERROR;
	}
	srcAttr = 0;
    }
    if (dstAttr == 0xffffffff) {
	if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {

	    errno = ENAMETOOLONG;
	    return TCL_ERROR;
	}
	dstAttr = 0;
    }

    if (errno == EBADF) {
	errno = EACCES;
	return TCL_ERROR;
    }
    if (errno == EACCES) {
	decode:
	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    TCHAR *nativeSrcRest, *nativeDstRest;
	    CONST char **srcArgv, **dstArgv;
	    int size, srcArgc, dstArgc;
	    WCHAR nativeSrcPath[MAX_PATH];
	    WCHAR nativeDstPath[MAX_PATH];
	    Tcl_DString srcString, dstString;
	    CONST char *src, *dst;

	    size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, 
		    nativeSrcPath, &nativeSrcRest);
	    if ((size == 0) || (size > MAX_PATH)) {
		return TCL_ERROR;
	    }
	    size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, 
		    nativeDstPath, &nativeDstRest);
	    if ((size == 0) || (size > MAX_PATH)) {
		return TCL_ERROR;
	    }
	    (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
	    (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);

	    src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
	    dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);

	    /*
	     * Check whether the destination path is actually inside the
	     * source path.  This is true if the prefix matches, and the next
	     * character is either end-of-string or a directory separator
	     */

	    if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) 
		    && (dst[Tcl_DStringLength(&srcString)] == '\\'
		    || dst[Tcl_DStringLength(&srcString)] == '/'
		    || dst[Tcl_DStringLength(&srcString)] == '\0')) {
		/*
		 * Trying to move a directory into itself.
		 */

		errno = EINVAL;
		Tcl_DStringFree(&srcString);
		Tcl_DStringFree(&dstString);
		return TCL_ERROR;
	    }
	    Tcl_SplitPath(src, &srcArgc, &srcArgv);
	    Tcl_SplitPath(dst, &dstArgc, &dstArgv);
	    Tcl_DStringFree(&srcString);
	    Tcl_DStringFree(&dstString);

	    if (srcArgc == 1) {
		/*
		 * They are trying to move a root directory.  Whether
		 * or not it is across filesystems, this cannot be
		 * done.
		 */

		Tcl_SetErrno(EINVAL);
	    } else if ((srcArgc > 0) && (dstArgc > 0) &&
		    (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
		/*
		 * If src is a directory and dst filesystem != src
		 * filesystem, errno should be EXDEV.  It is very
		 * important to get this behavior, so that the caller
		 * can respond to a cross filesystem rename by
		 * simulating it with copy and delete.  The MoveFile
		 * system call already handles the case of moving a
		 * file between filesystems.
		 */

		Tcl_SetErrno(EXDEV);
	    }

	    ckfree((char *) srcArgv);
	    ckfree((char *) dstArgv);
	}

	/*
	 * Other types of access failure is that dst is a read-only
	 * filesystem, that an open file referred to src or dest, or that
	 * src or dest specified the current working directory on the
	 * current filesystem.  EACCES is returned for those cases.
	 */

    } else if (Tcl_GetErrno() == EEXIST) {
	/*
	 * Reports EEXIST any time the target already exists.  If it makes
	 * sense, remove the old file and try renaming again.
	 */

	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
		/*
		 * Overwrite empty dst directory with src directory.  The
		 * following call will remove an empty directory.  If it
		 * fails, it's because it wasn't empty.
		 */

		if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
		    /*
		     * Now that that empty directory is gone, we can try
		     * renaming again.  If that fails, we'll put this empty
		     * directory back, for completeness.
		     */

		    if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {

			return TCL_OK;
		    }

		    /*
		     * Some new error has occurred.  Don't know what it
		     * could be, but report this one.
		     */

		    TclWinConvertError(GetLastError());
		    (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
		    (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
		    if (Tcl_GetErrno() == EACCES) {
			/*







|
|
<
>
|
|
|
|
<

|
|
<
|
<
|
|
<
|
<
|
<
|
<
<
<
<
<

|





|



|



|




|

|

|
>
|

|
>
|

|

<






|
|
|
|


|
<



|
|


|



|
|


|
|
|


|

|
|
|




|




|
|





|


|
>
>
>




|
|









|
|


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<



>
>
|
>
>
>
>
>
>

>
>
>
|
|
|
|
>
>
>
>
|
>
|
>
|
|
|
>
>
|
>
>
>
|
>
|
>
>
>

<
<
|
|
>
|
<
<
<

<
>
|
>
>
|
<
<
>
>
>
|
<
<
>
>
>
|
<
<
<
<
>
>
>

|
<
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|







|
>






|
>











|









|




|









>


|


>
|



















|
|
<






|
|
|
<
|
|
|











|
|
|




|






|
|
|





|



|
>




|
|







65
66
67
68
69
70
71
72
73

74
75
76
77
78

79
80
81

82

83
84

85

86

87





88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129
130
131
132
133
134

135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202



















203

204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247


248
249
250
251



252

253
254
255
256
257


258
259
260
261


262
263
264
265




266
267
268
269
270

271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379

380
381
382
383
384
385
386
387
388

389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileLongName, CannotSetAttribute},
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileShortName, CannotSetAttribute},
	{GetWinFileAttributes, SetWinFileAttributes}};

#ifdef HAVE_NO_SEH


/*
 * Unlike Borland and Microsoft, we don't register exception handlers by
 * pushing registration records onto the runtime stack. Instead, we register
 * them by creating an EXCEPTION_REGISTRATION within the activation record.
 */


typedef struct EXCEPTION_REGISTRATION {
    struct EXCEPTION_REGISTRATION *link;

    EXCEPTION_DISPOSITION (*handler)(

	    struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *);
    void *ebp;

    void *esp;

    int status;

} EXCEPTION_REGISTRATION;






#endif

/*
 * Prototype for the TraverseWinTree callback function.
 */

typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
	int type, Tcl_DString *errorPtr);

/*
 * Declarations for local functions defined in this file:
 */

static void		StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
static int		ConvertFileNameFormat(Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName, int longShort,
			    Tcl_Obj **attributePtrPtr);
static int		DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
static int		DoCreateDirectory(CONST TCHAR *pathPtr);
static int		DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
			    int ignoreError, Tcl_DString *errorPtr);
static int		DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
			    Tcl_DString *errorPtr);
static int		DoRenameFile(CONST TCHAR *nativeSrc,
			    CONST TCHAR *dstPtr);
static int		TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
			    int type, Tcl_DString *errorPtr);
static int		TraversalDelete(CONST TCHAR *srcPtr,
			    CONST TCHAR *dstPtr, int type,
			    Tcl_DString *errorPtr);
static int		TraverseWinTree(TraversalProc *traverseProc,
			    Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
			    Tcl_DString *errorPtr);


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjRenameFile, DoRenameFile --
 *
 *	Changes the name of an existing file or directory, from src to dst.
 *	If src and dst refer to the same file or directory, does nothing and
 *	returns success. Otherwise if dst already exists, it will be deleted
 *	and replaced by src subject to the following conditions:
 *	    If src is a directory, dst may be an empty directory.
 *	    If src is a file, dst may be a file.
 *	In any other situation where dst already exists, the rename will fail.

 *
 * Results:
 *	If the file or directory was successfully renamed, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR and errno is set to indicate
 *	the error. Some possible values for errno are:
 *
 *	ENAMETOOLONG: src or dst names are too long.
 *	EACCES:	    src or dst parent directory can't be read and/or written.
 *	EEXIST:	    dst is a non-empty directory.
 *	EINVAL:	    src is a root directory or dst is a subdirectory of src.
 *	EISDIR:	    dst is a directory, but src is not.
 *	ENOENT:	    src doesn't exist.	src or dst is "".
 *	ENOTDIR:    src is a directory, but dst is not.
 *	EXDEV:	    src and dst are on different filesystems.
 *
 *	EACCES:	    exists an open file already referring to src or dst.
 *	EACCES:	    src or dst specify the current working directory (NT).
 *	EACCES:	    src specifies a char device (nul:, com1:, etc.)
 *	EEXIST:	    dst specifies a char device (nul:, com1:, etc.) (NT)
 *	EACCES:	    dst specifies a char device (nul:, com1:, etc.) (95)
 *
 * Side effects:
 *	The implementation supports cross-filesystem renames of files, but the
 *	caller should be prepared to emulate cross-filesystem renames of
 *	directories if errno is EXDEV.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjRenameFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
	    Tcl_FSGetNativePath(destPathPtr));
}

static int
DoRenameFile(
    CONST TCHAR *nativeSrc,	/* Pathname of file or dir to be renamed
				 * (native). */
    CONST TCHAR *nativeDst)	/* New pathname for file or directory
				 * (native). */
{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    DWORD srcAttr, dstAttr;
    int retval = -1;

    /*
     * The MoveFile API acts differently under Win95/98 and NT WRT NULL and
     * "". Avoid passing these values.
     */

    if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
	    nativeDst == NULL || nativeDst[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    /*
     * The MoveFile API would throw an exception under NT if one of the
     * arguments is a char block device.
     */

#ifndef HAVE_NO_SEH



















    __try {

	if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
	    retval = TCL_OK;
	}
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#else

    /*
     * Don't have SEH available, do things the hard way. Note that this needs
     * to be one block of asm, to avoid stack imbalance; also, it is illegal
     * for one asm block to contain a jump to another.
     */

    __asm__ __volatile__ (
	/*
	 * Pick up params before messing with the stack.
	 */

	"movl	    %[nativeDst],   %%ebx"	    "\n\t"
	"movl	    %[nativeSrc],   %%ecx"	    "\n\t"

	/*
	 * Construct an EXCEPTION_REGISTRATION to protect the call to
	 * MoveFile.
	 */

	"leal	    %[registration], %%edx"	    "\n\t"
	"movl	    %%fs:0,	    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x0(%%edx)"	    "\n\t" /* link */
	"leal	    1f,		    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x4(%%edx)"	    "\n\t" /* handler */
	"movl	    %%ebp,	    0x8(%%edx)"	    "\n\t" /* ebp */
	"movl	    %%esp,	    0xc(%%edx)"	    "\n\t" /* esp */
	"movl	    $0,		    0x10(%%edx)"    "\n\t" /* status */

	/*
	 * Link the EXCEPTION_REGISTRATION on the chain.
	 */

	"movl	    %%edx,	    %%fs:0"	    "\n\t"

	/*
	 * Call MoveFile(nativeSrc, nativeDst)
	 */



	"pushl	    %%ebx"			    "\n\t"
	"pushl	    %%ecx"			    "\n\t"
	"movl	    %[moveFile],    %%eax"	    "\n\t"
	"call	    *%%eax"			    "\n\t"





	/*
	 * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and
	 * put the status return from MoveFile into it.
	 */



	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    %%eax,	    0x10(%%edx)"    "\n\t"
	"jmp	    2f"				    "\n"



	/*
	 * Come here on an exception. Recover the EXCEPTION_REGISTRATION
	 */





	"1:"					    "\t"
	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    0x8(%%edx),	    %%edx"	    "\n\t"

	/*

	 * Come here however we exited. Restore context from the
	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	 */

	"2:"					    "\t"
	"movl	    0xc(%%edx),	    %%esp"	    "\n\t"
	"movl	    0x8(%%edx),	    %%ebp"	    "\n\t"
	"movl	    0x0(%%edx),	    %%eax"	    "\n\t"
	"movl	    %%eax,	    %%fs:0"	    "\n\t"

	:
	/* No outputs */
	:
	[registration]	"m"	(registration),
	[nativeDst]	"m"	(nativeDst),
	[nativeSrc]	"m"	(nativeSrc),
	[moveFile]	"r"	(tclWinProcs->moveFileProc)
	:
	"%eax", "%ebx", "%ecx", "%edx", "memory"
	);
    if (registration.status != FALSE) {
	retval = TCL_OK;
    }
#endif

    if (retval != -1) {
	return retval;
    }

    TclWinConvertError(GetLastError());

    srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
    dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
    if (srcAttr == 0xffffffff) {
	if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL,
		NULL) >= MAX_PATH) {
	    errno = ENAMETOOLONG;
	    return TCL_ERROR;
	}
	srcAttr = 0;
    }
    if (dstAttr == 0xffffffff) {
	if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL,
		NULL) >= MAX_PATH) {
	    errno = ENAMETOOLONG;
	    return TCL_ERROR;
	}
	dstAttr = 0;
    }

    if (errno == EBADF) {
	errno = EACCES;
	return TCL_ERROR;
    }
    if (errno == EACCES) {
    decode:
	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    TCHAR *nativeSrcRest, *nativeDstRest;
	    CONST char **srcArgv, **dstArgv;
	    int size, srcArgc, dstArgc;
	    WCHAR nativeSrcPath[MAX_PATH];
	    WCHAR nativeDstPath[MAX_PATH];
	    Tcl_DString srcString, dstString;
	    CONST char *src, *dst;

	    size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
		    nativeSrcPath, &nativeSrcRest);
	    if ((size == 0) || (size > MAX_PATH)) {
		return TCL_ERROR;
	    }
	    size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
		    nativeDstPath, &nativeDstRest);
	    if ((size == 0) || (size > MAX_PATH)) {
		return TCL_ERROR;
	    }
	    (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
	    (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);

	    src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
	    dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);

	    /*
	     * Check whether the destination path is actually inside the
	     * source path. This is true if the prefix matches, and the next
	     * character is either end-of-string or a directory separator
	     */

	    if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0)
		    && (dst[Tcl_DStringLength(&srcString)] == '\\'
		    || dst[Tcl_DStringLength(&srcString)] == '/'
		    || dst[Tcl_DStringLength(&srcString)] == '\0')) {
		/*
		 * Trying to move a directory into itself.
		 */

		errno = EINVAL;
		Tcl_DStringFree(&srcString);
		Tcl_DStringFree(&dstString);
		return TCL_ERROR;
	    }
	    Tcl_SplitPath(src, &srcArgc, &srcArgv);
	    Tcl_SplitPath(dst, &dstArgc, &dstArgv);
	    Tcl_DStringFree(&srcString);
	    Tcl_DStringFree(&dstString);

	    if (srcArgc == 1) {
		/*
		 * They are trying to move a root directory. Whether or not it
		 * is across filesystems, this cannot be done.

		 */

		Tcl_SetErrno(EINVAL);
	    } else if ((srcArgc > 0) && (dstArgc > 0) &&
		    (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
		/*
		 * If src is a directory and dst filesystem != src filesystem,
		 * errno should be EXDEV. It is very important to get this
		 * behavior, so that the caller can respond to a cross

		 * filesystem rename by simulating it with copy and delete.
		 * The MoveFile system call already handles the case of moving
		 * a file between filesystems.
		 */

		Tcl_SetErrno(EXDEV);
	    }

	    ckfree((char *) srcArgv);
	    ckfree((char *) dstArgv);
	}

	/*
	 * Other types of access failure is that dst is a read-only
	 * filesystem, that an open file referred to src or dest, or that src
	 * or dest specified the current working directory on the current
	 * filesystem. EACCES is returned for those cases.
	 */

    } else if (Tcl_GetErrno() == EEXIST) {
	/*
	 * Reports EEXIST any time the target already exists. If it makes
	 * sense, remove the old file and try renaming again.
	 */

	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
		/*
		 * Overwrite empty dst directory with src directory. The
		 * following call will remove an empty directory. If it fails,
		 * it's because it wasn't empty.
		 */

		if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
		    /*
		     * Now that that empty directory is gone, we can try
		     * renaming again. If that fails, we'll put this empty
		     * directory back, for completeness.
		     */

		    if ((*tclWinProcs->moveFileProc)(nativeSrc,
			    nativeDst) != FALSE) {
			return TCL_OK;
		    }

		    /*
		     * Some new error has occurred. Don't know what it could
		     * be, but report this one.
		     */

		    TclWinConvertError(GetLastError());
		    (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
		    (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
		    if (Tcl_GetErrno() == EACCES) {
			/*
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475

476

477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579



580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622


623






624
625



626
627

628




629

630

631
632
633


634



635

636



637
638
639

640
641
642
643
644
645
646
647
648
649


650
651

652
653
654

655
656
657
658

659



660
661
662


663






















664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695

696
697

698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799

800

801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816

817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
	    }
	} else {    /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
		Tcl_SetErrno(EISDIR);
	    } else {
		/*
		 * Overwrite existing file by:
		 * 
		 * 1. Rename existing file to temp name.
		 * 2. Rename old file to new name.
		 * 3. If success, delete temp file.  If failure,
		 *    put temp file back to old name.
		 */

		TCHAR *nativeRest, *nativeTmp, *nativePrefix;
		int result, size;
		WCHAR tempBuf[MAX_PATH];
		
		size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, 
			tempBuf, &nativeRest);
		if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
		    return TCL_ERROR;
		}
		nativeTmp = (TCHAR *) tempBuf;
		((char *) nativeRest)[0] = '\0';
		((char *) nativeRest)[1] = '\0';    /* In case it's Unicode. */

		result = TCL_ERROR;
		nativePrefix = (tclWinProcs->useWide) 
			? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
		if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, 
			nativePrefix, 0, tempBuf) != 0) {
		    /*
		     * Strictly speaking, need the following DeleteFile and
		     * MoveFile to be joined as an atomic operation so no
		     * other app comes along in the meantime and creates the
		     * same temp file.
		     */
		     
		    nativeTmp = (TCHAR *) tempBuf;
		    (*tclWinProcs->deleteFileProc)(nativeTmp);
		    if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {

			if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {

			    (*tclWinProcs->setFileAttributesProc)(nativeTmp, 
				    FILE_ATTRIBUTE_NORMAL);
			    (*tclWinProcs->deleteFileProc)(nativeTmp);
			    return TCL_OK;
			} else {
			    (*tclWinProcs->deleteFileProc)(nativeDst);
			    (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
			}
		    } 

		    /*
		     * Can't backup dst file or move src file.  Return that
		     * error.  Could happen if an open file refers to dst.
		     */

		    TclWinConvertError(GetLastError());
		    if (Tcl_GetErrno() == EACCES) {
			/*
			 * Decode the EACCES to a more meaningful error.
			 */

			goto decode;
		    }
		}
		return result;
	    }
	}
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * _except_dorenamefile_handler --
 *
 *	SEH exception handler for DoRenameFile.
 *
 * Results:
 *	See DoRenameFile.
 *
 * Side effects:
 *	See DoRenameFile.
 *
 *----------------------------------------------------------------------
 */
#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_dorenamefile_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext)
{
    __asm__ __volatile__ (
            "jmp dorenamefile_reentry");
    return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyFile, DoCopyFile --
 *
 *      Copy a single file (not a directory).  If dst already exists and
 *	is not a directory, it is removed.
 *
 * Results:
 *	If the file was successfully copied, returns TCL_OK.  Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the
 *	error.  Some possible values for errno are:
 *
 *	EACCES:     src or dst parent directory can't be read and/or written.
 *	EISDIR:	    src or dst is a directory.
 *	ENOENT:	    src doesn't exist.  src or dst is "".
 *
 *	EACCES:     exists an open file already referring to dst (95).
 *	EACCES:	    src specifies a char device (nul:, com1:, etc.) (NT)
 *	ENOENT:	    src specifies a char device (nul:, com1:, etc.) (95)
 *
 * Side effects:
 *	It is not an error to copy to a char device.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
		      Tcl_FSGetNativePath(destPathPtr));
}

static int
DoCopyFile(
   CONST TCHAR *nativeSrc,	/* Pathname of file to be copied (native). */
   CONST TCHAR *nativeDst)	/* Pathname of file to copy to (native). */
{



    int retval = -1;

    /*
     * The CopyFile API acts differently under Win95/98 and NT
     * WRT NULL and "". Avoid passing these values.
     */

    if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
	    nativeDst == NULL || nativeDst[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }
    
    /*
     * The CopyFile API would throw an exception under NT if one
     * of the arguments is a char block device.
     */

#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (
            "movl %%esp,  %0" "\n\t"
            "movl %%ebp,  %1" "\n\t"
            "movl %%fs:0, %2" "\n\t"
            : "=m"(INITIAL_ESP),
              "=m"(INITIAL_EBP),
              "=r"(INITIAL_HANDLER) );
# endif /* TCL_MEM_DEBUG */

    __asm__ __volatile__ (
            "pushl %%ebp" "\n\t"
            "pushl %0" "\n\t"
            "pushl %%fs:0" "\n\t"
            "movl  %%esp, %%fs:0"
            :
            : "r" (_except_docopyfile_handler)
            );
#else
    __try {
#endif /* HAVE_NO_SEH */
	if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
	    retval = TCL_OK;
	}


#ifdef HAVE_NO_SEH






    __asm__ __volatile__ (
            "jmp  docopyfile_pop" "\n"



        "docopyfile_reentry:" "\n\t"
            "movl %%fs:0, %%eax" "\n\t"

            "movl 0x8(%%eax), %%esp" "\n\t"




            "movl 0x8(%%esp), %%ebp" "\n"

        "docopyfile_pop:" "\n\t"

            "movl (%%esp), %%eax" "\n\t"
            "movl %%eax, %%fs:0" "\n\t"
            "add  $12, %%esp" "\n\t"


            :



            :

            : "%eax");




# ifdef TCL_MEM_DEBUG
    __asm__ __volatile__ (

            "movl  %%esp,  %0" "\n\t"
            "movl  %%ebp,  %1" "\n\t"
            "movl  %%fs:0, %2" "\n\t"
            : "=m"(RESTORED_ESP),
              "=m"(RESTORED_EBP),
              "=r"(RESTORED_HANDLER) );

    if (INITIAL_ESP != RESTORED_ESP) {
        Tcl_Panic("ESP restored incorrectly");
    }


    if (INITIAL_EBP != RESTORED_EBP) {
        Tcl_Panic("EBP restored incorrectly");

    }
    if (INITIAL_HANDLER != RESTORED_HANDLER) {
        Tcl_Panic("HANDLER restored incorrectly");

    }
# endif /* TCL_MEM_DEBUG */
#else
    } __except (EXCEPTION_EXECUTE_HANDLER) {}

#endif /* HAVE_NO_SEH */




    /*
     * Avoid using control flow statements in the SEH guarded block!


     */






















    if (retval != -1) {
        return retval;
    }

    TclWinConvertError(GetLastError());
    if (Tcl_GetErrno() == EBADF) {
	Tcl_SetErrno(EACCES);
	return TCL_ERROR;
    }
    if (Tcl_GetErrno() == EACCES) {
	DWORD srcAttr, dstAttr;

	srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
	dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
	if (srcAttr != 0xffffffff) {
	    if (dstAttr == 0xffffffff) {
		dstAttr = 0;
	    }
	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
		if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /* Source is a symbolic link -- copy it */
		    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
		        return TCL_OK;
		    }
		}
		Tcl_SetErrno(EISDIR);
	    }
	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
		(*tclWinProcs->setFileAttributesProc)(nativeDst, 
			dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
		if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {

		    return TCL_OK;
		}

		/*
		 * Still can't copy onto dst.  Return that error, and
		 * restore attributes of dst.
		 */

		TclWinConvertError(GetLastError());
		(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
	    }
	}
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * _except_docopyfile_handler --
 *
 *	SEH exception handler for DoCopyFile.
 *
 * Results:
 *	See DoCopyFile.
 *
 * Side effects:
 *	See DoCopyFile.
 *
 *----------------------------------------------------------------------
 */
#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_docopyfile_handler(
    struct _EXCEPTION_RECORD *ExceptionRecord,
    void *EstablisherFrame,
    struct _CONTEXT *ContextRecord,
    void *DispatcherContext)
{
    __asm__ __volatile__ (
            "jmp docopyfile_reentry");
    return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjDeleteFile, TclpDeleteFile --
 *
 *      Removes a single file (not a directory).
 *
 * Results:
 *	If the file was successfully deleted, returns TCL_OK.  Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the
 *	error.  Some possible values for errno are:
 *
 *	EACCES:     a parent directory can't be read and/or written.
 *	EISDIR:	    path is a directory.
 *	ENOENT:	    path doesn't exist or is "".
 *
 *	EACCES:     exists an open file already referring to path.
 *	EACCES:	    path is a char device (nul:, com1:, etc.)
 *
 * Side effects:
 *      The file is deleted, even if it is read-only.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjDeleteFile(pathPtr)
    Tcl_Obj *pathPtr;
{
    return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
}

int
TclpDeleteFile(
    CONST TCHAR *nativePath)	/* Pathname of file to be removed (native). */
{
    DWORD attr;

    /*
     * The DeleteFile API acts differently under Win95/98 and NT
     * WRT NULL and "". Avoid passing these values.
     */

    if (nativePath == NULL || nativePath[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
	return TCL_OK;
    }
    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
		if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {

		    /* It is a symbolic link -- remove it */

		    if (TclWinSymLinkDelete(nativePath, 0) == 0) {
		        return TCL_OK;
		    }
		}
		
		/* 
		 * If we fall through here, it is a directory.
		 * 
		 * Windows NT reports removing a directory as EACCES instead
		 * of EISDIR.
		 */

		Tcl_SetErrno(EISDIR);
	    } else if (attr & FILE_ATTRIBUTE_READONLY) {
		int res = (*tclWinProcs->setFileAttributesProc)(nativePath, 
			attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));

		if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
			!= FALSE)) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
		if (res != 0) {
		    (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
		}
	    }
	}
    } else if (Tcl_GetErrno() == ENOENT) {
        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
	    	/*
		 * Windows 95 reports removing a directory as ENOENT instead 
		 * of EISDIR. 
		 */

		Tcl_SetErrno(EISDIR);
	    }
	}
    } else if (Tcl_GetErrno() == EINVAL) {
	/*







|


|
|





|
|









|

|







|


|
>
|
>
|







|


|
|


















<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|
|


|
|
|

|

|

|









|





|




|
|

>
>
>



|
|







|

|
|


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<



>
>
|
>
>
>
>
>
>

|
>
>
>
|
|
>
|
>
>
>
>
|
>
|
>
|
|
|
>
>
|
>
>
>
|
>
|
>
>
>

<
<
>
|
|
|
<
<
<
|
<
<
|
>
>
|
<
>
|
|
|
>
|
|
<
|
>
|
>
>
>

|
<
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|




















|
|





|

|
>


>

|
|










<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|


|
|
|

|



|



|




|













|
|













|



>
|
>

|


|
|

|






|

>











|


|
|
|







452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527































528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590



















591

592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636


637
638
639
640



641


642
643
644
645

646
647
648
649
650
651
652

653
654
655
656
657
658
659
660

661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734































735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
	    }
	} else {    /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
		Tcl_SetErrno(EISDIR);
	    } else {
		/*
		 * Overwrite existing file by:
		 *
		 * 1. Rename existing file to temp name.
		 * 2. Rename old file to new name.
		 * 3. If success, delete temp file. If failure, put temp file
		 *    back to old name.
		 */

		TCHAR *nativeRest, *nativeTmp, *nativePrefix;
		int result, size;
		WCHAR tempBuf[MAX_PATH];

		size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
			tempBuf, &nativeRest);
		if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
		    return TCL_ERROR;
		}
		nativeTmp = (TCHAR *) tempBuf;
		((char *) nativeRest)[0] = '\0';
		((char *) nativeRest)[1] = '\0';    /* In case it's Unicode. */

		result = TCL_ERROR;
		nativePrefix = (tclWinProcs->useWide)
			? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
		if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
			nativePrefix, 0, tempBuf) != 0) {
		    /*
		     * Strictly speaking, need the following DeleteFile and
		     * MoveFile to be joined as an atomic operation so no
		     * other app comes along in the meantime and creates the
		     * same temp file.
		     */

		    nativeTmp = (TCHAR *) tempBuf;
		    (*tclWinProcs->deleteFileProc)(nativeTmp);
		    if ((*tclWinProcs->moveFileProc)(nativeDst,
			    nativeTmp) != FALSE) {
			if ((*tclWinProcs->moveFileProc)(nativeSrc,
				nativeDst) != FALSE) {
			    (*tclWinProcs->setFileAttributesProc)(nativeTmp,
				    FILE_ATTRIBUTE_NORMAL);
			    (*tclWinProcs->deleteFileProc)(nativeTmp);
			    return TCL_OK;
			} else {
			    (*tclWinProcs->deleteFileProc)(nativeDst);
			    (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
			}
		    }

		    /*
		     * Can't backup dst file or move src file. Return that
		     * error. Could happen if an open file refers to dst.
		     */

		    TclWinConvertError(GetLastError());
		    if (Tcl_GetErrno() == EACCES) {
			/*
			 * Decode the EACCES to a more meaningful error.
			 */

			goto decode;
		    }
		}
		return result;
	    }
	}
    }
    return TCL_ERROR;
}
































/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyFile, DoCopyFile --
 *
 *	Copy a single file (not a directory). If dst already exists and is not
 *	a directory, it is removed.
 *
 * Results:
 *	If the file was successfully copied, returns TCL_OK. Otherwise the
 *	return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    src or dst parent directory can't be read and/or written.
 *	EISDIR:	    src or dst is a directory.
 *	ENOENT:	    src doesn't exist.	src or dst is "".
 *
 *	EACCES:	    exists an open file already referring to dst (95).
 *	EACCES:	    src specifies a char device (nul:, com1:, etc.) (NT)
 *	ENOENT:	    src specifies a char device (nul:, com1:, etc.) (95)
 *
 * Side effects:
 *	It is not an error to copy to a char device.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
	    Tcl_FSGetNativePath(destPathPtr));
}

static int
DoCopyFile(
    CONST TCHAR *nativeSrc,	/* Pathname of file to be copied (native). */
    CONST TCHAR *nativeDst)	/* Pathname of file to copy to (native). */
{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    int retval = -1;

    /*
     * The CopyFile API acts differently under Win95/98 and NT WRT NULL and
     * "". Avoid passing these values.
     */

    if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
	    nativeDst == NULL || nativeDst[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    /*
     * The CopyFile API would throw an exception under NT if one of the
     * arguments is a char block device.
     */

#ifndef HAVE_NO_SEH



















    __try {

	if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
	    retval = TCL_OK;
	}
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#else

    /*
     * Don't have SEH available, do things the hard way. Note that this needs
     * to be one block of asm, to avoid stack imbalance; also, it is illegal
     * for one asm block to contain a jump to another.
     */

    __asm__ __volatile__ (

	/*
	 * Pick up parameters before messing with the stack
	 */

	"movl	    %[nativeDst],   %%ebx"	    "\n\t"
	"movl	    %[nativeSrc],   %%ecx"	    "\n\t"

	/*
	 * Construct an EXCEPTION_REGISTRATION to protect the call to
	 * CopyFile.
	 */

	"leal	    %[registration], %%edx"	    "\n\t"
	"movl	    %%fs:0,	    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x0(%%edx)"	    "\n\t" /* link */
	"leal	    1f,		    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x4(%%edx)"	    "\n\t" /* handler */
	"movl	    %%ebp,	    0x8(%%edx)"	    "\n\t" /* ebp */
	"movl	    %%esp,	    0xc(%%edx)"	    "\n\t" /* esp */
	"movl	    $0,		    0x10(%%edx)"    "\n\t" /* status */

	/*
	 * Link the EXCEPTION_REGISTRATION on the chain.
	 */

	"movl	    %%edx,	    %%fs:0"	    "\n\t"

	/*
	 * Call CopyFile(nativeSrc, nativeDst, 0)
	 */



	"movl	    %[copyFile],    %%eax"	    "\n\t"
	"pushl	    $0"				    "\n\t"
	"pushl	    %%ebx"			    "\n\t"
	"pushl	    %%ecx"			    "\n\t"



	"call	    *%%eax"			    "\n\t"



	/*
	 * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and
	 * put the status return from CopyFile into it.

	 */

	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    %%eax,	    0x10(%%edx)"    "\n\t"
	"jmp	    2f"				    "\n"

	/*

	 * Come here on an exception. Recover the EXCEPTION_REGISTRATION
	 */

	"1:"					    "\t"
	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    0x8(%%edx),	    %%edx"	    "\n\t"

	/*

	 * Come here however we exited. Restore context from the
	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	 */

	"2:"					    "\t"
	"movl	    0xc(%%edx),	    %%esp"	    "\n\t"
	"movl	    0x8(%%edx),	    %%ebp"	    "\n\t"
	"movl	    0x0(%%edx),	    %%eax"	    "\n\t"
	"movl	    %%eax,	    %%fs:0"	    "\n\t"

	:
	/* No outputs */
	:
	[registration]	"m"	(registration),
	[nativeDst]	"m"	(nativeDst),
	[nativeSrc]	"m"	(nativeSrc),
	[copyFile]	"r"	(tclWinProcs->copyFileProc)
	:
	"%eax", "%ebx", "%ecx", "%edx", "memory"
	);
    if (registration.status != FALSE) {
	retval = TCL_OK;
    }
#endif

    if (retval != -1) {
	return retval;
    }

    TclWinConvertError(GetLastError());
    if (Tcl_GetErrno() == EBADF) {
	Tcl_SetErrno(EACCES);
	return TCL_ERROR;
    }
    if (Tcl_GetErrno() == EACCES) {
	DWORD srcAttr, dstAttr;

	srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
	dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
	if (srcAttr != 0xffffffff) {
	    if (dstAttr == 0xffffffff) {
		dstAttr = 0;
	    }
	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
		if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /* Source is a symbolic link -- copy it */
		    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
			return TCL_OK;
		    }
		}
		Tcl_SetErrno(EISDIR);
	    }
	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
		(*tclWinProcs->setFileAttributesProc)(nativeDst,
			dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
		if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst,
			0) != FALSE) {
		    return TCL_OK;
		}

		/*
		 * Still can't copy onto dst. Return that error, and restore
		 * attributes of dst.
		 */

		TclWinConvertError(GetLastError());
		(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
	    }
	}
    }
    return TCL_ERROR;
}
































/*
 *---------------------------------------------------------------------------
 *
 * TclpObjDeleteFile, TclpDeleteFile --
 *
 *	Removes a single file (not a directory).
 *
 * Results:
 *	If the file was successfully deleted, returns TCL_OK. Otherwise the
 *	return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    a parent directory can't be read and/or written.
 *	EISDIR:	    path is a directory.
 *	ENOENT:	    path doesn't exist or is "".
 *
 *	EACCES:	    exists an open file already referring to path.
 *	EACCES:	    path is a char device (nul:, com1:, etc.)
 *
 * Side effects:
 *	The file is deleted, even if it is read-only.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjDeleteFile(pathPtr)
    Tcl_Obj *pathPtr;
{
    return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
}

int
TclpDeleteFile(
    CONST TCHAR *nativePath)	/* Pathname of file to be removed (native). */
{
    DWORD attr;

    /*
     * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
     * "". Avoid passing these values.
     */

    if (nativePath == NULL || nativePath[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
	return TCL_OK;
    }
    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
	attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
		if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /*
		     * It is a symbolic link - remove it.
		     */
		    if (TclWinSymLinkDelete(nativePath, 0) == 0) {
			return TCL_OK;
		    }
		}

		/*
		 * If we fall through here, it is a directory.
		 *
		 * Windows NT reports removing a directory as EACCES instead
		 * of EISDIR.
		 */

		Tcl_SetErrno(EISDIR);
	    } else if (attr & FILE_ATTRIBUTE_READONLY) {
		int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
			attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));

		if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
			!= FALSE)) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
		if (res != 0) {
		    (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
		}
	    }
	}
    } else if (Tcl_GetErrno() == ENOENT) {
	attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
		/*
		 * Windows 95 reports removing a directory as ENOENT instead
		 * of EISDIR.
		 */

		Tcl_SetErrno(EISDIR);
	    }
	}
    } else if (Tcl_GetErrno() == EINVAL) {
	/*
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCreateDirectory --
 *
 *      Creates the specified directory.  All parent directories of the
 *	specified directory must already exist.  The directory is
 *	automatically created with permissions so that user can access
 *	the new directory and create new files or subdirectories in it.
 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR and errno is set to
 *	indicate the error.  Some possible values for errno are:
 *
 *	EACCES:     a parent directory can't be read and/or written.
 *	EEXIST:	    path already exists.
 *	ENOENT:	    a parent directory doesn't exist.
 *
 * Side effects:
 *      A directory is created.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCreateDirectory(pathPtr)
    Tcl_Obj *pathPtr;
{
    return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}

static int
DoCreateDirectory(
    CONST TCHAR *nativePath)	/* Pathname of directory to create (native). */
{
    DWORD error;
    if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
	error = GetLastError();
	TclWinConvertError(error);
	return TCL_ERROR;
    }   
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *      Recursively copies a directory.  The target directory dst must
 *	not already exist.  Note that this function does not merge two
 *	directory hierarchies, even if the target directory is an an
 *	empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR, errno is set to indicate
 *	the error, and the pathname of the file that caused the error
 *	is stored in errorPtr.  See TclpCreateDirectory and TclpCopyFile
 *	for a description of possible values for errno.
 *
 * Side effects:
 *      An exact copy of the directory hierarchy src will be created
 *	with the name dst.  If an error occurs, the error will
 *      be returned immediately, and remaining files will not be
 *	processed.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_DString srcString, dstString;







|
|
|
|


|
|
|

|




|




|















|








|
|
|
<


|
|
|
|
|


|
|
|
<




|







845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899

900
901
902
903
904
905
906
907
908
909
910
911

912
913
914
915
916
917
918
919
920
921
922
923
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCreateDirectory --
 *
 *	Creates the specified directory. All parent directories of the
 *	specified directory must already exist. The directory is automatically
 *	created with permissions so that user can access the new directory and
 *	create new files or subdirectories in it.
 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    a parent directory can't be read and/or written.
 *	EEXIST:	    path already exists.
 *	ENOENT:	    a parent directory doesn't exist.
 *
 * Side effects:
 *	A directory is created.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCreateDirectory(pathPtr)
    Tcl_Obj *pathPtr;
{
    return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}

static int
DoCreateDirectory(
    CONST TCHAR *nativePath)	/* Pathname of directory to create (native). */
{
    DWORD error;
    if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
	error = GetLastError();
	TclWinConvertError(error);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an an empty directory.

 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpCreateDirectory and TclpCopyFile for a description of possible
 *	values for errno.
 *
 * Side effects:
 *	An exact copy of the directory hierarchy src will be created with the
 *	name dst. If an error occurs, the error will be returned immediately,
 *	and remaining files will not be processed.

 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_DString srcString, dstString;
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994

995
996
997
998
999
1000

1001
1002
1003
1004
1005
1006
1007
1008
1009

1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037

1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050

1051

1052
1053
1054
1055

1056


1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077

1078


1079
1080
1081
1082
1083
1084
1085
1086

1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108

    ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);

    Tcl_DStringFree(&srcString);
    Tcl_DStringFree(&dstString);

    if (ret != TCL_OK) {
	if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) {
	    *errorPtr = srcPathPtr;
	} else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) {
	    *errorPtr = destPathPtr;
	} else {
	    *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	}
	Tcl_DStringFree(&ds);
	Tcl_IncrRefCount(*errorPtr);
    }
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjRemoveDirectory, DoRemoveDirectory -- 
 *
 *	Removes directory (and its contents, if the recursive flag is set).
 *
 * Results:
 *	If the directory was successfully removed, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR, errno is set to indicate
 *	the error, and the pathname of the file that caused the error
 *	is stored in errorPtr.  Some possible values for errno are:
 *
 *	EACCES:     path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is root directory or current directory.
 *	ENOENT:	    path doesn't exist or is "".
 * 	ENOTDIR:    path is not a directory.
 *
 *	EACCES:	    path is a char device (nul:, com1:, etc.) (95)
 *	EINVAL:	    path is a char device (nul:, com1:, etc.) (NT)
 *
 * Side effects:
 *	Directory removed.  If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *----------------------------------------------------------------------
 */

int 
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_Obj *pathPtr;
    int recursive;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_Obj *normPtr = NULL;
    int ret;

    if (recursive) {
	/* 
	 * In the recursive case, the string rep is used to construct a
	 * Tcl_DString which may be used extensively, so we can't
	 * optimize this case easily.
	 */

	Tcl_DString native;
	normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
	ret = DoRemoveDirectory(&native, recursive, &ds);
	Tcl_DStringFree(&native);
    } else {
	ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 
				    0, &ds);
    }

    if (ret != TCL_OK) {
	int len = Tcl_DStringLength(&ds);
	if (len > 0) {
	    if (normPtr != NULL &&
		    !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
		*errorPtr = pathPtr;
	    } else {
		*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	    }
	    Tcl_IncrRefCount(*errorPtr);
	}
	Tcl_DStringFree(&ds);
    }

    return ret;
}

static int
DoRemoveJustDirectory(
    CONST TCHAR *nativePath,	/* Pathname of directory to be removed
				 * (native). */
    int ignoreError,		/* If non-zero, don't initialize the
                  		 * errorPtr under some circumstances
                  		 * on return. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    DWORD attr;

    /*
     * The RemoveDirectory API acts differently under Win95/98 and NT
     * WRT NULL and "". Avoid passing these values.
     */

    if (nativePath == NULL || nativePath[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	goto end;
    }

    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);

    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {

	/* It is a symbolic link -- remove it */

	if (TclWinSymLinkDelete(nativePath, 0) == 0) {
	    return TCL_OK;
	}
    } else {

	/* Ordinary directory */


	if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
	    return TCL_OK;
	}
    }
    
    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
	attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
		/* 
		 * Windows 95 reports calling RemoveDirectory on a file as an 
		 * EACCES, not an ENOTDIR.
		 */
		
		Tcl_SetErrno(ENOTDIR);
		goto end;
	    }

	    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {

		/* It is a symbolic link -- remove it */


		if (TclWinSymLinkDelete(nativePath, 1) != 0) {
		    goto end;
		}
	    }
	    
	    if (attr & FILE_ATTRIBUTE_READONLY) {
		attr &= ~FILE_ATTRIBUTE_READONLY;
		if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {

		    goto end;
		}
		if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
		(*tclWinProcs->setFileAttributesProc)(nativePath, 
			attr | FILE_ATTRIBUTE_READONLY);
	    }

	    /* 
	     * Windows 95 and Win32s report removing a non-empty directory 
	     * as EACCES, not EEXIST.  If the directory is not empty,
	     * change errno so caller knows what's going on.

	     */

	    if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
		CONST char *path, *find;
		HANDLE handle;
		WIN32_FIND_DATAA data;
		Tcl_DString buffer;







|

|













|




|
|
|
|

|



|





|





|








>

|

|
|

>






|
<

>













>







|
|
<
|
|
|


>

|
|










>
|
>




>
|
>
>




|






|
|


|





>
|
>
>




|


|
>






|



|
|
|
|
<







931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003

1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028

1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106

1107
1108
1109
1110
1111
1112
1113

    ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);

    Tcl_DStringFree(&srcString);
    Tcl_DStringFree(&dstString);

    if (ret != TCL_OK) {
	if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
	    *errorPtr = srcPathPtr;
	} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
	    *errorPtr = destPathPtr;
	} else {
	    *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	}
	Tcl_DStringFree(&ds);
	Tcl_IncrRefCount(*errorPtr);
    }
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjRemoveDirectory, DoRemoveDirectory --
 *
 *	Removes directory (and its contents, if the recursive flag is set).
 *
 * Results:
 *	If the directory was successfully removed, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	Some possible values for errno are:
 *
 *	EACCES:	    path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is root directory or current directory.
 *	ENOENT:	    path doesn't exist or is "".
 *	ENOTDIR:    path is not a directory.
 *
 *	EACCES:	    path is a char device (nul:, com1:, etc.) (95)
 *	EINVAL:	    path is a char device (nul:, com1:, etc.) (NT)
 *
 * Side effects:
 *	Directory removed. If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *----------------------------------------------------------------------
 */

int
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
    Tcl_Obj *pathPtr;
    int recursive;
    Tcl_Obj **errorPtr;
{
    Tcl_DString ds;
    Tcl_Obj *normPtr = NULL;
    int ret;

    if (recursive) {
	/*
	 * In the recursive case, the string rep is used to construct a
	 * Tcl_DString which may be used extensively, so we can't optimize
	 * this case easily.
	 */

	Tcl_DString native;
	normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
	ret = DoRemoveDirectory(&native, recursive, &ds);
	Tcl_DStringFree(&native);
    } else {
	ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds);

    }

    if (ret != TCL_OK) {
	int len = Tcl_DStringLength(&ds);
	if (len > 0) {
	    if (normPtr != NULL &&
		    !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
		*errorPtr = pathPtr;
	    } else {
		*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	    }
	    Tcl_IncrRefCount(*errorPtr);
	}
	Tcl_DStringFree(&ds);
    }

    return ret;
}

static int
DoRemoveJustDirectory(
    CONST TCHAR *nativePath,	/* Pathname of directory to be removed
				 * (native). */
    int ignoreError,		/* If non-zero, don't initialize the errorPtr
				 * under some circumstances on return. */

    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    DWORD attr;

    /*
     * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL
     * and "". Avoid passing these values.
     */

    if (nativePath == NULL || nativePath[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	goto end;
    }

    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);

    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
	/*
	 * It is a symbolic link - remove it.
	 */
	if (TclWinSymLinkDelete(nativePath, 0) == 0) {
	    return TCL_OK;
	}
    } else {
	/*
	 * Ordinary directory.
	 */

	if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
	    return TCL_OK;
	}
    }

    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
	attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
		/*
		 * Windows 95 reports calling RemoveDirectory on a file as an
		 * EACCES, not an ENOTDIR.
		 */

		Tcl_SetErrno(ENOTDIR);
		goto end;
	    }

	    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
		/*
		 * It is a symbolic link - remove it.
		 */

		if (TclWinSymLinkDelete(nativePath, 1) != 0) {
		    goto end;
		}
	    }

	    if (attr & FILE_ATTRIBUTE_READONLY) {
		attr &= ~FILE_ATTRIBUTE_READONLY;
		if ((*tclWinProcs->setFileAttributesProc)(nativePath,
			attr) == FALSE) {
		    goto end;
		}
		if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
		(*tclWinProcs->setFileAttributesProc)(nativePath,
			attr | FILE_ATTRIBUTE_READONLY);
	    }

	    /*
	     * Windows 95 and Win32s report removing a non-empty directory as
	     * EACCES, not EEXIST. If the directory is not empty, change errno
	     * so caller knows what's going on.

	     */

	    if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
		CONST char *path, *find;
		HANDLE handle;
		WIN32_FIND_DATAA data;
		Tcl_DString buffer;
1135
1136
1137
1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149

1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185

1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270

1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285

1286
1287
1288
1289
1290
1291
1292
		    }
		    FindClose(handle);
		}
		Tcl_DStringFree(&buffer);
	    }
	}
    }

    if (Tcl_GetErrno() == ENOTEMPTY) {
	/* 
	 * The caller depends on EEXIST to signify that the directory is
	 * not empty, not ENOTEMPTY. 
	 */

	Tcl_SetErrno(EEXIST);
    }

    if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
	/* 
	 * If we're being recursive, this error may actually
	 * be ok, so we don't want to initialise the errorPtr
	 * yet.
	 */
	return TCL_ERROR;
    }

    end:
    if (errorPtr != NULL) {
	Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
    }
    return TCL_ERROR;

}

static int
DoRemoveDirectory(
    Tcl_DString *pathPtr,	/* Pathname of directory to be removed
				 * (native). */
    int recursive,		/* If non-zero, removes directories that
				 * are nonempty.  Otherwise, will only remove
				 * empty directories. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, 
				    errorPtr);
    
    if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
	/*
	 * The directory is nonempty, but the recursive flag has been
	 * specified, so we recursively remove all the files in the directory.
	 */

	return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
    } else {
	return res;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TraverseWinTree --
 *
 *      Traverse directory tree specified by sourcePtr, calling the function 
 *	traverseProc for each file and directory encountered.  If destPtr 
 *	is non-null, each of name in the sourcePtr directory is appended to 
 *	the directory specified by destPtr and passed as the second argument 
 *	to traverseProc() .
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      None caused by TraverseWinTree, however the user specified 
 *	traverseProc() may change state.  If an error occurs, the error will
 *      be returned immediately, and remaining files will not be processed.
 *
 *---------------------------------------------------------------------------
 */

static int 
TraverseWinTree(
    TraversalProc *traverseProc,/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr,	/* Pathname of source directory to be
				 * traversed (native). */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory (native),
				 * may be NULL. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    DWORD sourceAttr;
    TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
    int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
    HANDLE handle;
    WIN32_FIND_DATAT data;

    nativeErrfile = NULL;
    result = TCL_OK;
    oldTargetLen = 0;		/* lint. */

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    nativeTarget = (TCHAR *) (targetPtr == NULL 
			      ? NULL : Tcl_DStringValue(targetPtr));
    
    oldSourceLen = Tcl_DStringLength(sourcePtr);
    sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
    if (sourceAttr == 0xffffffff) {
	nativeErrfile = nativeSource;
	goto end;
    }
    
    if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
	/*
	 * Process the symbolic link
	 */

	return (*traverseProc)(nativeSource, nativeTarget, 
			       DOTREE_LINK, errorPtr);
    }
    
    if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * Process the regular file
	 */

	return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
    }

    if (tclWinProcs->useWide) {
	Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
    } else {
	Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
    }

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
    if (handle == INVALID_HANDLE_VALUE) {
	/* 
	 * Can't read directory
	 */

	TclWinConvertError(GetLastError());
	nativeErrfile = nativeSource;
	goto end;
    }

    nativeSource[oldSourceLen + 1] = '\0';
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);

    if (result != TCL_OK) {
	FindClose(handle);
	return result;
    }

    sourceLen = oldSourceLen;








>

|
|
|




>

|
|
|
<




|











|
|
|
|
|
|

|
|
|





>











|
|
|
|
|


|


|
|
|




|








|
|
|












|
|
|






|





|
|

|














>



|
|









|
>







1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160

1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
		    }
		    FindClose(handle);
		}
		Tcl_DStringFree(&buffer);
	    }
	}
    }

    if (Tcl_GetErrno() == ENOTEMPTY) {
	/*
	 * The caller depends on EEXIST to signify that the directory is not
	 * empty, not ENOTEMPTY.
	 */

	Tcl_SetErrno(EEXIST);
    }

    if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
	/*
	 * If we're being recursive, this error may actually be ok, so we
	 * don't want to initialise the errorPtr yet.

	 */
	return TCL_ERROR;
    }

  end:
    if (errorPtr != NULL) {
	Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
    }
    return TCL_ERROR;

}

static int
DoRemoveDirectory(
    Tcl_DString *pathPtr,	/* Pathname of directory to be removed
				 * (native). */
    int recursive,		/* If non-zero, removes directories that are
				 * nonempty. Otherwise, will only remove empty
				 * directories. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
	    errorPtr);

    if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
	/*
	 * The directory is nonempty, but the recursive flag has been
	 * specified, so we recursively remove all the files in the directory.
	 */

	return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
    } else {
	return res;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TraverseWinTree --
 *
 *	Traverse directory tree specified by sourcePtr, calling the function
 *	traverseProc for each file and directory encountered. If destPtr is
 *	non-null, each of name in the sourcePtr directory is appended to the
 *	directory specified by destPtr and passed as the second argument to
 *	traverseProc().
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	None caused by TraverseWinTree, however the user specified
 *	traverseProc() may change state. If an error occurs, the error will be
 *	returned immediately, and remaining files will not be processed.
 *
 *---------------------------------------------------------------------------
 */

static int
TraverseWinTree(
    TraversalProc *traverseProc,/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr,	/* Pathname of source directory to be
				 * traversed (native). */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory (native),
				 * may be NULL. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    DWORD sourceAttr;
    TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
    int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
    HANDLE handle;
    WIN32_FIND_DATAT data;

    nativeErrfile = NULL;
    result = TCL_OK;
    oldTargetLen = 0;		/* lint. */

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    nativeTarget = (TCHAR *)
	    (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));

    oldSourceLen = Tcl_DStringLength(sourcePtr);
    sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
    if (sourceAttr == 0xffffffff) {
	nativeErrfile = nativeSource;
	goto end;
    }

    if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
	/*
	 * Process the symbolic link
	 */

	return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK,
		errorPtr);
    }

    if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * Process the regular file
	 */

	return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
    }

    if (tclWinProcs->useWide) {
	Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
    } else {
	Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
    }

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
    if (handle == INVALID_HANDLE_VALUE) {
	/*
	 * Can't read directory.
	 */

	TclWinConvertError(GetLastError());
	nativeErrfile = nativeSource;
	goto end;
    }

    nativeSource[oldSourceLen + 1] = '\0';
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED,
	    errorPtr);
    if (result != TCL_OK) {
	FindClose(handle);
	return result;
    }

    sourceLen = oldSourceLen;

1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390

1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443

1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601

1602
1603

1604
1605
1606
1607
1608
1609
1610

1611


1612
1613
1614

1615


1616
1617
1618
1619

1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674

1675
1676
1677
1678
1679
1680

1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692

1693

1694
1695


1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709

1710
1711
1712
1713

1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778


1779


1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803

1804

1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845

1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874

1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
	} else {
	    targetLen += 1;
	    Tcl_DStringAppend(targetPtr, "\\", 1);
	}
    }

    found = 1;
    for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
	TCHAR *nativeName;
	int len;

	if (tclWinProcs->useWide) {
	    WCHAR *wp;

	    wp = data.w.cFileName;
	    if (*wp == '.') {
		wp++;
		if (*wp == '.') {
		    wp++;
		}
		if (*wp == '\0') {
		    continue;
		}
	    }
	    nativeName = (TCHAR *) data.w.cFileName;
	    len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
	} else {
	    if ((strcmp(data.a.cFileName, ".") == 0) 
		    || (strcmp(data.a.cFileName, "..") == 0)) {
		continue;
	    }
	    nativeName = (TCHAR *) data.a.cFileName;
	    len = strlen(data.a.cFileName);
	}

	/* 
	 * Append name after slash, and recurse on the file. 
	 */

	Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
	if (targetPtr != NULL) {
	    Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
	    Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
	}
	result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, 
		errorPtr);
	if (result != TCL_OK) {
	    break;
	}

	/*
	 * Remove name after slash.
	 */

	Tcl_DStringSetLength(sourcePtr, sourceLen);
	if (targetPtr != NULL) {
	    Tcl_DStringSetLength(targetPtr, targetLen);
	}
    }
    FindClose(handle);

    /*
     * Strip off the trailing slash we added
     */

    Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
	Tcl_DStringSetLength(targetPtr, oldTargetLen);
    }
    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the
	 * files in that directory.
	 */

	result = (*traverseProc)(Tcl_DStringValue(sourcePtr), 
			(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), 
			DOTREE_POSTD, errorPtr);
    }

    end:
    if (nativeErrfile != NULL) {
	TclWinConvertError(GetLastError());
	if (errorPtr != NULL) {
	    Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
	}
	result = TCL_ERROR;
    }
	    
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *      Called from TraverseUnixTree in order to execute a recursive
 *      copy of a directory.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      Depending on the value of type, src may be copied to dst.
 *      
 *----------------------------------------------------------------------
 */

static int 
TraversalCopy(
    CONST TCHAR *nativeSrc,	/* Source pathname to copy. */
    CONST TCHAR *nativeDst,	/* Destination pathname of copy. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    switch (type) {
	case DOTREE_F: {
	    if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
	case DOTREE_LINK: {
	    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
	case DOTREE_PRED: {
	    if (DoCreateDirectory(nativeDst) == TCL_OK) {
		DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);

		if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) 
			!= FALSE) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
	    }
	    break;
	}
        case DOTREE_POSTD: {
	    return TCL_OK;
	}
    }

    /*
     * There shouldn't be a problem with src, because we already
     * checked it to get here.
     */

    if (errorPtr != NULL) {
	Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalDelete --
 *
 *      Called by procedure TraverseWinTree for every file and
 *      directory that it encounters in a directory hierarchy. This
 *      procedure unlinks files, and removes directories after all the
 *      containing files have been processed.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      Files or directory specified by src will be deleted. If an
 *      error occurs, the windows error is converted to a Posix error
 *      and errno is set accordingly.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalDelete( 
    CONST TCHAR *nativeSrc,	/* Source pathname to delete. */
    CONST TCHAR *dstPtr,	/* Not used. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    switch (type) {
	case DOTREE_F: {
	    if (TclpDeleteFile(nativeSrc) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
	case DOTREE_LINK: {
	    if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
	case DOTREE_PRED: {
	    return TCL_OK;
	}
	case DOTREE_POSTD: {
	    if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
    }

    if (errorPtr != NULL) {
	Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * StatError --
 *
 *	Sets the object result with the appropriate error.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The interp's object result is set with an error message
 *	based on the objIndex, fileName and errno.
 *
 *----------------------------------------------------------------------
 */

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)	        /* The name of the file which caused the 
				 * error. */
{
    TclWinConvertError(GetLastError());
    Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), 
	    "\": ", Tcl_PosixError(interp), (char *) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileAttributes --
 *
 *      Returns a Tcl_Obj containing the value of a file attribute.
 *	This routine gets the -hidden, -readonly or -system attribute.
 *
 * Results:
 *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
 *	will have ref count 0. If the return value is not TCL_OK,
 *	attributePtrPtr is not touched.
 *
 * Side effects:
 *      A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,	        /* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    DWORD result;
    CONST TCHAR *nativeName;
    int attr;
    
    nativeName = Tcl_FSGetNativePath(fileName);
    result = (*tclWinProcs->getFileAttributesProc)(nativeName);

    if (result == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    attr = (int)(result & attributeArray[objIndex]);
    if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
	/* 
	 * It is hidden.  However there is a bug on some Windows
	 * OSes in which root volumes (drives) formatted as NTFS
	 * are declared hidden when they are not (and cannot be).
	 * 
	 * We test for, and fix that case, here.
	 */

	int len;
	char *str = Tcl_GetStringFromObj(fileName,&len);

	if (len < 4) {
	    if (len == 0) {
		/* 
		 * Not sure if this is possible, but we pass it on
		 * anyway 
		 */
	    } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {

		/* Path is pointing to the root volume */


		attr = 0;
	    } else if ((str[1] == ':') 
		    && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {

		/* Path is of the form 'x:' or 'x:/' or 'x:\' */


		attr = 0;
	    }
	}
    }

    *attributePtrPtr = Tcl_NewBooleanObj(attr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertFileNameFormat --
 *
 *      Returns a Tcl_Obj containing either the long or short version of the 
 *	file name.
 *
 * Results:
 *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
 *	will have ref count 0. If the return value is not TCL_OK,
 *	attributePtrPtr is not touched.
 *	
 *	Warning: if you pass this function a drive name like 'c:' it
 *	will actually return the current working directory on that
 *	drive.  To avoid this, make sure the drive name ends in a
 *	slash, like this 'c:/'.
 *
 * Side effects:
 *      A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertFileNameFormat(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,   	/* The name of the file. */
    int longShort,		/* 0 to short name, 1 to long name. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    int pathc, i;
    Tcl_Obj *splitPath;

    splitPath = Tcl_FSSplitPath(fileName, &pathc);
    
    if (splitPath == NULL || pathc == 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": no such file or directory", 
		    (char *) NULL);
	}
	goto cleanup;
    }
    
    /*
     * We will decrement this again at the end.  It is safer to
     * do this in case any of the calls below retain a reference
     * to splitPath.
     */

    Tcl_IncrRefCount(splitPath);

    for (i = 0; i < pathc; i++) {
	Tcl_Obj *elt;
	char *pathv;
	int pathLen;

	Tcl_ListObjIndex(NULL, splitPath, i, &elt);
	
	pathv = Tcl_GetStringFromObj(elt, &pathLen);
	if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':'))
		|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
	    /*
	     * Handle "/", "//machine/export", "c:/", "." or ".." by just
	     * copying the string literally.  Uppercase the drive letter,
	     * just because it looks better under Windows to do so.
	     */

	    simple:

	    /* Here we are modifying the string representation in place */

	    /* I believe this is legal, since this won't affect any 
	     * file representation this thing may have. */


	    pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
	} else {
	    Tcl_Obj *tempPath;
	    Tcl_DString ds;
	    Tcl_DString dsTemp;
	    TCHAR *nativeName;
	    char *tempString;
	    int tempLen;
	    WIN32_FIND_DATAT data;
	    HANDLE handle;
	    DWORD attr;

	    tempPath = Tcl_FSJoinPath(splitPath, i+1);
	    Tcl_IncrRefCount(tempPath);

	    /* 
	     * We'd like to call Tcl_FSGetNativePath(tempPath)
	     * but that is likely to lead to infinite loops 
	     */

	    Tcl_DStringInit(&ds);
	    tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
	    nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
	    Tcl_DecrRefCount(tempPath);
	    handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
	    if (handle == INVALID_HANDLE_VALUE) {
		/*
		 * FindFirstFile() doesn't like root directories.  We 
		 * would only get a root directory here if the caller
		 * specified "c:" or "c:." and the current directory on the
		 * drive was the root directory
		 */

		attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
		if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
		    Tcl_DStringFree(&ds);
		    goto simple;
		}
	    }

	    if (handle == INVALID_HANDLE_VALUE) {
		Tcl_DStringFree(&ds);
		if (interp != NULL) {
		    StatError(interp, fileName);
		}
		goto cleanup;
	    }
	    if (tclWinProcs->useWide) {
		nativeName = (TCHAR *) data.w.cAlternateFileName;
		if (longShort) {
		    if (data.w.cFileName[0] != '\0') {
			nativeName = (TCHAR *) data.w.cFileName;
		    } 
		} else {
		    if (data.w.cAlternateFileName[0] == '\0') {
			nativeName = (TCHAR *) data.w.cFileName;
		    }
		}
	    } else {
		nativeName = (TCHAR *) data.a.cAlternateFileName;
		if (longShort) {
		    if (data.a.cFileName[0] != '\0') {
			nativeName = (TCHAR *) data.a.cFileName;
		    } 
		} else {
		    if (data.a.cAlternateFileName[0] == '\0') {
			nativeName = (TCHAR *) data.a.cFileName;
		    }
		}
	    }

	    /*
	     * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying 
	     * to dereference nativeName as a Unicode string.  I have proven 
	     * to myself that purify is wrong by running the following 
	     * example when nativeName == data.w.cAlternateFileName and 
	     * noting that purify doesn't complain about the first line,
	     * but does complain about the second.
	     *
	     *	fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
	     *	fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
	     */

	    Tcl_DStringInit(&dsTemp);
	    Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);


	    /* Deal with issues of tildes being absolute */


	    if (Tcl_DStringValue(&dsTemp)[0] == '~') {
		tempPath = Tcl_NewStringObj("./",2);
		Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), 
				Tcl_DStringLength(&dsTemp));
	    } else {
		tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), 
					    Tcl_DStringLength(&dsTemp));
	    }
	    Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
	    Tcl_DStringFree(&ds);
	    Tcl_DStringFree(&dsTemp);
	    FindClose(handle);
	}
    }

    *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
    
    if (splitPath != NULL) {
	/* 
	 * Unfortunately, the object we will return may have its only
	 * refCount as part of the list splitPath.  This means if
	 * we free splitPath, the object will disappear.  So, we
	 * have to be very careful here.  Unfortunately this means
	 * we must manipulate the object's refCount directly.

	 */

	Tcl_IncrRefCount(*attributePtrPtr);
	Tcl_DecrRefCount(splitPath);
	--(*attributePtrPtr)->refCount;
    }
    return TCL_OK;

  cleanup:
    if (splitPath != NULL) {
	Tcl_DecrRefCount(splitPath);
    }
  
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileLongName --
 *
 *      Returns a Tcl_Obj containing the long version of the file
 *	name.
 *
 * Results:
 *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
 *	will have ref count 0. If the return value is not TCL_OK,
 *	attributePtrPtr is not touched.
 *
 * Side effects:
 *      A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileLongName(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,  	/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);

}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileShortName --
 *
 *      Returns a Tcl_Obj containing the short version of the file
 *	name.
 *
 * Results:
 *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
 *	will have ref count 0. If the return value is not TCL_OK,
 *	attributePtrPtr is not touched.
 *
 * Side effects:
 *      A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileShortName(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,  	/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);

}

/*
 *----------------------------------------------------------------------
 *
 * SetWinFileAttributes --
 *
 *	Set the file attributes to the value given by attributePtr.
 *	This routine sets the -hidden, -readonly, or -system attributes.
 *
 * Results:
 *      Standard TCL error.
 *
 * Side effects:
 *      The file's attribute is set.
 *
 *----------------------------------------------------------------------
 */

static int
SetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,  	/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    DWORD fileAttributes;
    int yesNo;
    int result;
    CONST TCHAR *nativeName;








|

















|

|







|
|








|

















|














|
|
|

>
|







|








|
|


|


|
|



|








|
|
|
|
|
<
|
|
|
|
|
<
|
|
|
>
|
|
|
|
|
|
|
<
|
|
|
|
<

|
|













|
|
|
|


|


|
|
|





|







|
|
|
|
|
<
|
|
|
|
|
<
|
|
<
|
|
|
|
|
<
















|


|
|







|



|








|
|


|
|
|


|








|





|










|
|
|
|
|


>


>


|
|
<


>
|
>
>

|

>
|
>
>




>









|



|
|
|
|
|
|
|
<


|








|







|



|




|

|
|
<

>






>

|





|
|


|
>
|
>
|
|
>
>














>
|
|
|

>







|
|
|
|



|

















|










|








|
|
|
|
|
|







>
>
|
>
>


|
|

|
|









|

|
|
|
<
|
|
>

>










|








|
<


|
|
|


|








|


|
>







|
<


|
|
|


|








|


|
>







|
|


|


|








|







1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443

1444
1445
1446
1447
1448

1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459

1460
1461
1462
1463

1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509

1510
1511
1512
1513
1514

1515
1516

1517
1518
1519
1520
1521

1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612

1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650

1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682

1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821

1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846

1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875

1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
	} else {
	    targetLen += 1;
	    Tcl_DStringAppend(targetPtr, "\\", 1);
	}
    }

    found = 1;
    for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
	TCHAR *nativeName;
	int len;

	if (tclWinProcs->useWide) {
	    WCHAR *wp;

	    wp = data.w.cFileName;
	    if (*wp == '.') {
		wp++;
		if (*wp == '.') {
		    wp++;
		}
		if (*wp == '\0') {
		    continue;
		}
	    }
	    nativeName = (TCHAR *) data.w.cFileName;
	    len = wcslen(data.w.cFileName) * sizeof(WCHAR);
	} else {
	    if ((strcmp(data.a.cFileName, ".") == 0)
		    || (strcmp(data.a.cFileName, "..") == 0)) {
		continue;
	    }
	    nativeName = (TCHAR *) data.a.cFileName;
	    len = strlen(data.a.cFileName);
	}

	/*
	 * Append name after slash, and recurse on the file.
	 */

	Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
	if (targetPtr != NULL) {
	    Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
	    Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
	}
	result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
		errorPtr);
	if (result != TCL_OK) {
	    break;
	}

	/*
	 * Remove name after slash.
	 */

	Tcl_DStringSetLength(sourcePtr, sourceLen);
	if (targetPtr != NULL) {
	    Tcl_DStringSetLength(targetPtr, targetLen);
	}
    }
    FindClose(handle);

    /*
     * Strip off the trailing slash we added.
     */

    Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
	Tcl_DStringSetLength(targetPtr, oldTargetLen);
    }
    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the
	 * files in that directory.
	 */

	result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
		(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
		DOTREE_POSTD, errorPtr);
    }

  end:
    if (nativeErrfile != NULL) {
	TclWinConvertError(GetLastError());
	if (errorPtr != NULL) {
	    Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
	}
	result = TCL_ERROR;
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *	Called from TraverseUnixTree in order to execute a recursive copy of a
 *	directory.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depending on the value of type, src may be copied to dst.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalCopy(
    CONST TCHAR *nativeSrc,	/* Source pathname to copy. */
    CONST TCHAR *nativeDst,	/* Destination pathname of copy. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    switch (type) {
    case DOTREE_F:
	if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    case DOTREE_LINK:
	if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    case DOTREE_PRED:
	if (DoCreateDirectory(nativeDst) == TCL_OK) {
	    DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);

	    if ((*tclWinProcs->setFileAttributesProc)(nativeDst,
		    attr) != FALSE) {
		return TCL_OK;
	    }
	    TclWinConvertError(GetLastError());
	}
	break;

    case DOTREE_POSTD:
	return TCL_OK;
    }


    /*
     * There shouldn't be a problem with src, because we already checked it to
     * get here.
     */

    if (errorPtr != NULL) {
	Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalDelete --
 *
 *	Called by function TraverseWinTree for every file and directory that
 *	it encounters in a directory hierarchy. This function unlinks files,
 *	and removes directories after all the containing files have been
 *	processed.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Files or directory specified by src will be deleted. If an error
 *	occurs, the windows error is converted to a Posix error and errno is
 *	set accordingly.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalDelete(
    CONST TCHAR *nativeSrc,	/* Source pathname to delete. */
    CONST TCHAR *dstPtr,	/* Not used. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    switch (type) {
    case DOTREE_F:
	if (TclpDeleteFile(nativeSrc) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    case DOTREE_LINK:
	if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    case DOTREE_PRED:
	return TCL_OK;

    case DOTREE_POSTD:
	if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
	    return TCL_OK;
	}
	break;

    }

    if (errorPtr != NULL) {
	Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * StatError --
 *
 *	Sets the object result with the appropriate error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interp's object result is set with an error message based on the
 *	objIndex, fileName and errno.
 *
 *----------------------------------------------------------------------
 */

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)		/* The name of the file which caused the
				 * error. */
{
    TclWinConvertError(GetLastError());
    Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
	    "\": ", Tcl_PosixError(interp), (char *) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileAttributes --
 *
 *	Returns a Tcl_Obj containing the value of a file attribute. This
 *	routine gets the -hidden, -readonly or -system attribute.
 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    DWORD result;
    CONST TCHAR *nativeName;
    int attr;

    nativeName = Tcl_FSGetNativePath(fileName);
    result = (*tclWinProcs->getFileAttributesProc)(nativeName);

    if (result == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    attr = (int)(result & attributeArray[objIndex]);
    if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
	/*
	 * It is hidden. However there is a bug on some Windows OSes in which
	 * root volumes (drives) formatted as NTFS are declared hidden when
	 * they are not (and cannot be).
	 *
	 * We test for, and fix that case, here.
	 */

	int len;
	char *str = Tcl_GetStringFromObj(fileName,&len);

	if (len < 4) {
	    if (len == 0) {
		/*
		 * Not sure if this is possible, but we pass it on anyway.

		 */
	    } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
		/*
		 * Path is pointing to the root volume.
		 */

		attr = 0;
	    } else if ((str[1] == ':')
		    && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
		/*
		 * Path is of the form 'x:' or 'x:/' or 'x:\'
		 */

		attr = 0;
	    }
	}
    }

    *attributePtrPtr = Tcl_NewBooleanObj(attr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertFileNameFormat --
 *
 *	Returns a Tcl_Obj containing either the long or short version of the
 *	file name.
 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 *	Warning: if you pass this function a drive name like 'c:' it will
 *	actually return the current working directory on that drive. To avoid
 *	this, make sure the drive name ends in a slash, like this 'c:/'.

 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertFileNameFormat(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    int longShort,		/* 0 to short name, 1 to long name. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    int pathc, i;
    Tcl_Obj *splitPath;

    splitPath = Tcl_FSSplitPath(fileName, &pathc);

    if (splitPath == NULL || pathc == 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": no such file or directory",
		    (char *) NULL);
	}
	goto cleanup;
    }

    /*
     * We will decrement this again at the end.	 It is safer to do this in
     * case any of the calls below retain a reference to splitPath.

     */

    Tcl_IncrRefCount(splitPath);

    for (i = 0; i < pathc; i++) {
	Tcl_Obj *elt;
	char *pathv;
	int pathLen;

	Tcl_ListObjIndex(NULL, splitPath, i, &elt);

	pathv = Tcl_GetStringFromObj(elt, &pathLen);
	if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':'))
		|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
	    /*
	     * Handle "/", "//machine/export", "c:/", "." or ".." by just
	     * copying the string literally.  Uppercase the drive letter, just
	     * because it looks better under Windows to do so.
	     */

	simple:
	    /*
	     * Here we are modifying the string representation in place.
	     *
	     * I believe this is legal, since this won't affect any file
	     * representation this thing may have.
	     */

	    pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
	} else {
	    Tcl_Obj *tempPath;
	    Tcl_DString ds;
	    Tcl_DString dsTemp;
	    TCHAR *nativeName;
	    char *tempString;
	    int tempLen;
	    WIN32_FIND_DATAT data;
	    HANDLE handle;
	    DWORD attr;

	    tempPath = Tcl_FSJoinPath(splitPath, i+1);
	    Tcl_IncrRefCount(tempPath);

	    /*
	     * We'd like to call Tcl_FSGetNativePath(tempPath) but that is
	     * likely to lead to infinite loops.
	     */

	    Tcl_DStringInit(&ds);
	    tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
	    nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
	    Tcl_DecrRefCount(tempPath);
	    handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
	    if (handle == INVALID_HANDLE_VALUE) {
		/*
		 * FindFirstFile() doesn't like root directories. We would
		 * only get a root directory here if the caller specified "c:"
		 * or "c:." and the current directory on the drive was the
		 * root directory
		 */

		attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
		if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
		    Tcl_DStringFree(&ds);
		    goto simple;
		}
	    }

	    if (handle == INVALID_HANDLE_VALUE) {
		Tcl_DStringFree(&ds);
		if (interp != NULL) {
		    StatError(interp, fileName);
		}
		goto cleanup;
	    }
	    if (tclWinProcs->useWide) {
		nativeName = (TCHAR *) data.w.cAlternateFileName;
		if (longShort) {
		    if (data.w.cFileName[0] != '\0') {
			nativeName = (TCHAR *) data.w.cFileName;
		    }
		} else {
		    if (data.w.cAlternateFileName[0] == '\0') {
			nativeName = (TCHAR *) data.w.cFileName;
		    }
		}
	    } else {
		nativeName = (TCHAR *) data.a.cAlternateFileName;
		if (longShort) {
		    if (data.a.cFileName[0] != '\0') {
			nativeName = (TCHAR *) data.a.cFileName;
		    }
		} else {
		    if (data.a.cAlternateFileName[0] == '\0') {
			nativeName = (TCHAR *) data.a.cFileName;
		    }
		}
	    }

	    /*
	     * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
	     * to dereference nativeName as a Unicode string. I have proven to
	     * myself that purify is wrong by running the following example
	     * when nativeName == data.w.cAlternateFileName and noting that
	     * purify doesn't complain about the first line, but does complain
	     * about the second.
	     *
	     *	fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
	     *	fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
	     */

	    Tcl_DStringInit(&dsTemp);
	    Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);

	    /*
	     * Deal with issues of tildes being absolute.
	     */

	    if (Tcl_DStringValue(&dsTemp)[0] == '~') {
		tempPath = Tcl_NewStringObj("./",2);
		Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
			Tcl_DStringLength(&dsTemp));
	    } else {
		tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
			Tcl_DStringLength(&dsTemp));
	    }
	    Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
	    Tcl_DStringFree(&ds);
	    Tcl_DStringFree(&dsTemp);
	    FindClose(handle);
	}
    }

    *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);

    if (splitPath != NULL) {
	/*
	 * Unfortunately, the object we will return may have its only refCount
	 * as part of the list splitPath. This means if we free splitPath, the

	 * object will disappear. So, we have to be very careful here.
	 * Unfortunately this means we must manipulate the object's refCount
	 * directly.
	 */

	Tcl_IncrRefCount(*attributePtrPtr);
	Tcl_DecrRefCount(splitPath);
	--(*attributePtrPtr)->refCount;
    }
    return TCL_OK;

  cleanup:
    if (splitPath != NULL) {
	Tcl_DecrRefCount(splitPath);
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileLongName --
 *
 *	Returns a Tcl_Obj containing the long version of the file name.

 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileLongName(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    return ConvertFileNameFormat(interp, objIndex, fileName, 1,
	    attributePtrPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileShortName --
 *
 *	Returns a Tcl_Obj containing the short version of the file name.

 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileShortName(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    return ConvertFileNameFormat(interp, objIndex, fileName, 0,
	    attributePtrPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * SetWinFileAttributes --
 *
 *	Set the file attributes to the value given by attributePtr. This
 *	routine sets the -hidden, -readonly, or -system attributes.
 *
 * Results:
 *	Standard TCL error.
 *
 * Side effects:
 *	The file's attribute is set.
 *
 *----------------------------------------------------------------------
 */

static int
SetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    DWORD fileAttributes;
    int yesNo;
    int result;
    CONST TCHAR *nativeName;

1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
}

/*
 *----------------------------------------------------------------------
 *
 * SetWinFileLongName --
 *
 *	The attribute in question is a readonly attribute and cannot
 *	be set.
 *
 * Results:
 *      TCL_ERROR
 *
 * Side effects:
 *      The object result is set to a pertinent error message.
 *
 *----------------------------------------------------------------------
 */

static int
CannotSetAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,	        /* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    Tcl_AppendResult(interp, "cannot set attribute \"",
	    tclpFileAttrStrings[objIndex], "\" for file \"",
	    Tcl_GetString(fileName), "\": attribute is readonly",
	    (char *) NULL);
    return TCL_ERROR;







|
<


|


|








|







1953
1954
1955
1956
1957
1958
1959
1960

1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
}

/*
 *----------------------------------------------------------------------
 *
 * SetWinFileLongName --
 *
 *	The attribute in question is a readonly attribute and cannot be set.

 *
 * Results:
 *	TCL_ERROR
 *
 * Side effects:
 *	The object result is set to a pertinent error message.
 *
 *----------------------------------------------------------------------
 */

static int
CannotSetAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    Tcl_AppendResult(interp, "cannot set attribute \"",
	    tclpFileAttrStrings[objIndex], "\" for file \"",
	    Tcl_GetString(fileName), "\": attribute is readonly",
	    (char *) NULL);
    return TCL_ERROR;
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
     * GetLogicalDriveStrings() isn't implemented.
     * GetLogicalDrives() returns incorrect information.
     */

    if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
	/*
	 * GetVolumeInformation() will detects all drives, but causes
	 * chattering on empty floppy drives.  We only do this if 
	 * GetLogicalDriveStrings() didn't work.  It has also been reported
	 * that on some laptops it takes a while for GetVolumeInformation()
	 * to return when pinging an empty floppy drive, another reason to 
	 * try to avoid calling it.
	 */

	buf[1] = ':';
	buf[2] = '/';
	buf[3] = '\0';

	for (i = 0; i < 26; i++) {







|
|
|
|
|







2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
     * GetLogicalDriveStrings() isn't implemented.
     * GetLogicalDrives() returns incorrect information.
     */

    if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
	/*
	 * GetVolumeInformation() will detects all drives, but causes
	 * chattering on empty floppy drives. We only do this if
	 * GetLogicalDriveStrings() didn't work. It has also been reported
	 * that on some laptops it takes a while for GetVolumeInformation() to
	 * return when pinging an empty floppy drive, another reason to try to
	 * avoid calling it.
	 */

	buf[1] = ':';
	buf[2] = '/';
	buf[3] = '\0';

	for (i = 0; i < 26; i++) {
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029








    } else {
	for (p = buf; *p != '\0'; p += 4) {
	    p[2] = '/';
	    elemPtr = Tcl_NewStringObj(p, -1);
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }
    
    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}















|



>
>
>
>
>
>
>
>
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
    } else {
	for (p = buf; *p != '\0'; p += 4) {
	    p[2] = '/';
	    elemPtr = Tcl_NewStringObj(p, -1);
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }

    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinFile.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73

74
75
76
77
78
79
80
81
82

83

84

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

162

163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

183
184
185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201
202
203
204

205
206

207
208
209
210
211
212
213
214
215
216

217


218
219

220

221
222
223
224

225


226
227
228
229
230
231

232


233
234

235


236
237
238


239


240
241

242


243
244

245

246


247
248
249
250

251
252

253
254
255
256

257

258


259
260
261
262
263
264
265
266
267

268

269


270
271
272
273
274
275
276
277
278
279
280
281
282
283
284

285
286

287
288
289
290
291
292
293
294

295


296
297

298


299
300
301
302

303


304
305

306


307
308

309

310


311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329


330
331

332
333
334
335
336
337
338
339
340
341
342

343


344
345
346
347

348
349
350
351
352

353
354
355
356
357
358
359

360


361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388


389
390

391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416


417
418

419
420
421
422
423

424


425
426
427
428

429
430
431
432
433

434
435
436
437

438


439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462

463
464
465
466
467

468
469

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501















502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519

520
521
522
523
524
525

526
527
528
529
530
531

532
533
534
535
536

537
538
539
540
541
542
543
544
545
546

547
548

549
550

551


552
553
554

555

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

573
574
575
576

577
578
579
580
581
582
583
584
585
586


587
588

589
590
591
592
593
594
595
596
597
598
599

600

601


602
603
604


605


606
607
608

609


610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630

631
632

633
634
635
636
637
638
639
640

641


642

643


644
645
646

647
648
649
650

651

652
653
654


655


656
657
658
659

660


661
662
663
664
665
666


667


668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
/* 
 * tclWinFile.c --
 *
 *      This file contains temporary wrappers around UNIX file handling
 *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *      files, which can be manipulated through the Win32 console redirection
 *      interfaces.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFile.c,v 1.72 2004/12/01 23:18:55 dgp Exp $
 */

//#define _WIN32_WINNT  0x0500

#include "tclWinInt.h"
#include "tclFileSystem.h"
#include <winioctl.h>
#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h>		/* For TclpGetUserHome(). */

/*
 * The number of 100-ns intervals between the Windows system epoch 
 * (1601-01-01 on the proleptic Gregorian calendar) and the
 * Posix epoch (1970-01-01).
 */

#define POSIX_EPOCH_AS_FILETIME 116444736000000000

/*
 * Declarations for 'link' related information.  This information
 * should come with VC++ 6.0, but is not in some older SDKs.
 * In any case it is not well documented.
 */

#ifndef IO_REPARSE_TAG_RESERVED_ONE
#  define IO_REPARSE_TAG_RESERVED_ONE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_RESERVED_RANGE
#  define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_VALID_VALUES
#  define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
#endif
#ifndef IO_REPARSE_TAG_HSM
#  define IO_REPARSE_TAG_HSM 0x0C0000004
#endif
#ifndef IO_REPARSE_TAG_NSS
#  define IO_REPARSE_TAG_NSS 0x080000005
#endif
#ifndef IO_REPARSE_TAG_NSSRECOVER
#  define IO_REPARSE_TAG_NSSRECOVER 0x080000006
#endif
#ifndef IO_REPARSE_TAG_SIS
#  define IO_REPARSE_TAG_SIS 0x080000007
#endif
#ifndef IO_REPARSE_TAG_DFS
#  define IO_REPARSE_TAG_DFS 0x080000008
#endif

#ifndef IO_REPARSE_TAG_RESERVED_ZERO
#  define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
#endif
#ifndef FILE_FLAG_OPEN_REPARSE_POINT
#  define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
#endif
#ifndef IO_REPARSE_TAG_MOUNT_POINT
#  define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
#endif
#ifndef IsReparseTagValid

#  define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
#endif
#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
#  define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
#endif
#ifndef FILE_SPECIAL_ACCESS
#  define FILE_SPECIAL_ACCESS         (FILE_ANY_ACCESS)
#endif
#ifndef FSCTL_SET_REPARSE_POINT

#  define FSCTL_SET_REPARSE_POINT    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)

#  define FSCTL_GET_REPARSE_POINT    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) 

#  define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) 
#endif

/* 
 * Maximum reparse buffer info size. The max user defined reparse
 * data is 16KB, plus there's a header.
 */

#define MAX_REPARSE_SIZE	17000

/*
 * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition.
 * This is found in winnt.h.
 * 
 * IMPORTANT: caution when using this structure, since the actual
 * structures used will want to store a full path in the 'PathBuffer'
 * field, but there isn't room (there's only a single WCHAR!).  Therefore
 * one must artificially create a larger space of memory and then cast it
 * to this type.  We use the 'DUMMY_REPARSE_BUFFER' struct just below to
 * deal with this problem.
 */

#define REPARSE_MOUNTPOINT_HEADER_SIZE   8
#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
typedef struct _REPARSE_DATA_BUFFER {
    DWORD  ReparseTag;
    WORD   ReparseDataLength;
    WORD   Reserved;
    union {
        struct {
            WORD   SubstituteNameOffset;
            WORD   SubstituteNameLength;
            WORD   PrintNameOffset;
            WORD   PrintNameLength;
            WCHAR PathBuffer[1];
        } SymbolicLinkReparseBuffer;
        struct {
            WORD   SubstituteNameOffset;
            WORD   SubstituteNameLength;
            WORD   PrintNameOffset;
            WORD   PrintNameLength;
            WCHAR PathBuffer[1];
        } MountPointReparseBuffer;
        struct {
            BYTE   DataBuffer[1];
        } GenericReparseBuffer;
    };
} REPARSE_DATA_BUFFER;
#endif

typedef struct {
    REPARSE_DATA_BUFFER dummy;
    WCHAR  dummyBuf[MAX_PATH*3];
} DUMMY_REPARSE_BUFFER;

#if defined(_MSC_VER) && ( _MSC_VER <= 1100 )
#undef  HAVE_NO_FINDEX_ENUMS
#define HAVE_NO_FINDEX_ENUMS
#elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400)
#undef  HAVE_NO_FINDEX_ENUMS
#define HAVE_NO_FINDEX_ENUMS
#endif

#ifdef HAVE_NO_FINDEX_ENUMS
/* These two aren't in VC++ 5.2 headers */
typedef enum _FINDEX_INFO_LEVELS {
	FindExInfoStandard,
	FindExInfoMaxInfoLevel
} FINDEX_INFO_LEVELS;
typedef enum _FINDEX_SEARCH_OPS {
	FindExSearchNameMatch,
	FindExSearchLimitToDirectories,
	FindExSearchLimitToDevices,
	FindExSearchMaxSearchOp
} FINDEX_SEARCH_OPS;
#endif /* HAVE_NO_FINDEX_ENUMS */


/* Other typedefs required by this code */


static time_t		ToCTime(FILETIME fileTime);
static void             FromCTime( time_t posixTime,
				   FILETIME* fileTime );

typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
	(LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);

typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
	(LPVOID Buffer);

typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
	(LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);

/*
 * Declarations for local procedures defined in this file:
 */

static int NativeAccess(CONST TCHAR *path, int mode);
static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks);

static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec);
static int NativeIsExec(CONST TCHAR *path);
static int NativeReadReparse(CONST TCHAR* LinkDirectory, 
			     REPARSE_DATA_BUFFER* buffer);
static int NativeWriteReparse(CONST TCHAR* LinkDirectory, 
			      REPARSE_DATA_BUFFER* buffer);
static int NativeMatchType(int isDrive, DWORD attr, CONST TCHAR* nativeName, 
			   Tcl_GlobTypeData *types);
static int WinIsDrive(CONST char *name, int nameLen);

static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource);
static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory);
static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget, 
		   int linkAction);
static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, 
			       CONST TCHAR* LinkTarget);

/*
 *--------------------------------------------------------------------
 *
 * WinLink
 *
 * Make a link from source to target. 

 *--------------------------------------------------------------------
 */

static int 
WinLink(LinkSource, LinkTarget, linkAction)
    CONST TCHAR* LinkSource;
    CONST TCHAR* LinkTarget;
    int linkAction;
{
    WCHAR	tempFileName[MAX_PATH];
    TCHAR*	tempFilePart;
    int         attr;
    

    /* Get the full path referenced by the target */


    if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, 
			  MAX_PATH, tempFileName, &tempFilePart)) {

	/* Invalid file */

	TclWinConvertError(GetLastError());
	return -1;
    }


    /* Make sure source file doesn't exist */


    attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
    if (attr != 0xffffffff) {
	Tcl_SetErrno(EEXIST);
	return -1;
    }


    /* Get the full path referenced by the source file/directory */


    if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, 
			  MAX_PATH, tempFileName, &tempFilePart)) {

	/* Invalid file */


	TclWinConvertError(GetLastError());
	return -1;
    }


    /* Check the target */


    attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
    if (attr == 0xffffffff) {

	/* The target doesn't exist */


	TclWinConvertError(GetLastError());
	return -1;

    } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {

	/* It is a file */


	if (tclWinProcs->createHardLinkProc == NULL) {
	    Tcl_SetErrno(ENOTDIR);
	    return -1;
	}

	if (linkAction & TCL_CREATE_HARD_LINK) {
	    if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {

		TclWinConvertError(GetLastError());
		return -1;
	    }
	    return 0;

	} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {

	    /* Can't symlink files */


	    Tcl_SetErrno(ENOTDIR);
	    return -1;
	} else {
	    Tcl_SetErrno(ENODEV);
	    return -1;
	}
    } else {
	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    return WinSymLinkDirectory(LinkSource, LinkTarget);

	} else if (linkAction & TCL_CREATE_HARD_LINK) {

	    /* Can't hard link directories */


	    Tcl_SetErrno(EISDIR);
	    return -1;
	} else {
	    Tcl_SetErrno(ENODEV);
	    return -1;
	}
    }
}

/*
 *--------------------------------------------------------------------
 *
 * WinReadLink
 *
 * What does 'LinkSource' point to? 

 *--------------------------------------------------------------------
 */

static Tcl_Obj* 
WinReadLink(LinkSource)
    CONST TCHAR* LinkSource;
{
    WCHAR	tempFileName[MAX_PATH];
    TCHAR*	tempFilePart;
    int         attr;
    

    /* Get the full path referenced by the target */


    if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, 
			  MAX_PATH, tempFileName, &tempFilePart)) {

	/* Invalid file */


	TclWinConvertError(GetLastError());
	return NULL;
    }


    /* Make sure source file does exist */


    attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
    if (attr == 0xffffffff) {

	/* The source doesn't exist */


	TclWinConvertError(GetLastError());
	return NULL;

    } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {

	/* It is a file - this is not yet supported */


	Tcl_SetErrno(ENOTDIR);
	return NULL;
    } else {
	return WinReadLinkDirectory(LinkSource);
    }
}

/*
 *--------------------------------------------------------------------
 *
 * WinSymLinkDirectory
 *
 * This routine creates a NTFS junction, using the undocumented
 * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points
 * and junctions.
 *
 * Assumption that LinkTarget is a valid, existing directory.
 * 
 * Returns zero on success.


 *--------------------------------------------------------------------
 */

static int 
WinSymLinkDirectory(LinkDirectory, LinkTarget)
    CONST TCHAR* LinkDirectory;
    CONST TCHAR* LinkTarget;
{
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    int         len;
    WCHAR       nativeTarget[MAX_PATH];
    WCHAR       *loop;
    

    /* Make the native target name */


    memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
    memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget, 
	   sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
    len = wcslen(nativeTarget);

    /* 
     * We must have backslashes only.  This is VERY IMPORTANT.
     * If we have any forward slashes everything appears to work,
     * but the resulting symlink is useless!
     */

    for (loop = nativeTarget; *loop != 0; loop++) {
	if (*loop == L'/') *loop = L'\\';
    }
    if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
	nativeTarget[len-1] = 0;
    }
    

    /* Build the reparse info */


    memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
    reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
    reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength = 
      wcslen(nativeTarget) * sizeof(WCHAR);
    reparseBuffer->Reserved = 0;
    reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
    reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset = 
      reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength 
      + sizeof(WCHAR);
    memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget, 
      sizeof(WCHAR) 
      + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
    reparseBuffer->ReparseDataLength = 
      reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
	
    return NativeWriteReparse(LinkDirectory, reparseBuffer);
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinSymLinkCopyDirectory
 *
 * Copy a Windows NTFS junction.  This function assumes that
 * LinkOriginal exists and is a valid junction point, and that
 * LinkCopy does not exist.
 * 
 * Returns zero on success.


 *--------------------------------------------------------------------
 */

int 
TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
    CONST TCHAR* LinkOriginal;  /* Existing junction - reparse point */
    CONST TCHAR* LinkCopy;      /* Will become a duplicate junction */
{
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    
    if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
	return -1;
    }
    return NativeWriteReparse(LinkCopy, reparseBuffer);
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinSymLinkDelete
 *
 * Delete a Windows NTFS junction.  Once the junction information
 * is deleted, the filesystem object becomes an ordinary directory.
 * Unless 'linkOnly' is given, that directory is also removed.
 * 
 * Assumption that LinkOriginal is a valid, existing junction.
 * 
 * Returns zero on success.


 *--------------------------------------------------------------------
 */

int 
TclWinSymLinkDelete(LinkOriginal, linkOnly)
    CONST TCHAR* LinkOriginal;
    int linkOnly;
{

    /* It is a symbolic link -- remove it */


    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    HANDLE hFile;
    DWORD returnedLength;

    memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
    reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
    hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
	NULL, OPEN_EXISTING, 
	FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile != INVALID_HANDLE_VALUE) {
	if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, 
			     REPARSE_MOUNTPOINT_HEADER_SIZE,
			     NULL, 0, &returnedLength, NULL)) {	

	    /* Error setting junction */


	    TclWinConvertError(GetLastError());
	    CloseHandle(hFile);
	} else {
	    CloseHandle(hFile);
	    if (!linkOnly) {
	        (*tclWinProcs->removeDirectoryProc)(LinkOriginal);
	    }
	    return 0;
	}
    }
    return -1;
}

/*
 *--------------------------------------------------------------------
 *
 * WinReadLinkDirectory
 *
 * This routine reads a NTFS junction, using the undocumented
 * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points
 * and junctions.
 *
 * Assumption that LinkDirectory is a valid, existing directory.
 * 

 * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller),
 * or NULL if anything went wrong.
 * 
 * In the future we should enhance this to return a path object
 * rather than a string.

 *--------------------------------------------------------------------
 */

static Tcl_Obj* 
WinReadLinkDirectory(LinkDirectory)
    CONST TCHAR* LinkDirectory;
{
    int attr;
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    
    attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
    if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	Tcl_SetErrno(EINVAL);
	return NULL;
    }
    if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
        return NULL;
    }
    
    switch (reparseBuffer->ReparseTag) {
	case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK: 
	case IO_REPARSE_TAG_SYMBOLIC_LINK: 
	case IO_REPARSE_TAG_MOUNT_POINT: {
	    Tcl_Obj *retVal;
	    Tcl_DString ds;
	    CONST char *copy;
	    int len;
	    int offset = 0;
	    
	    /* 
	     * Certain native path representations on Windows have a
	     * special prefix to indicate that they are to be treated
	     * specially.  For example extremely long paths, or symlinks,
	     * or volumes mounted inside directories.















	     * 
	     * There is an assumption in this code that 'wide' interfaces
	     * are being used (see tclWin32Dll.c), which is true for the
	     * only systems which support reparse tags at present.  If
	     * that changes in the future, this code will have to be
	     * generalised.
	     */
	    if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] 
		                                                 == L'\\') {
		/* Check whether this is a mounted volume */
		if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, 
			    L"\\??\\Volume{",11) == 0) {
		    char drive;
		    /* 
		     * There is some confusion between \??\ and \\?\ which
		     * we have to fix here.  It doesn't seem very well
		     * documented.
		     */

		    reparseBuffer->SymbolicLinkReparseBuffer
		                                      .PathBuffer[1] = L'\\';
		    /* 
		     * Check if a corresponding drive letter exists, and
		     * use that if it is found
		     */

		    drive = TclWinDriveLetterForVolMountPoint(reparseBuffer
					->SymbolicLinkReparseBuffer.PathBuffer);
		    if (drive != -1) {
			char driveSpec[3] = {
			    '\0', ':', '\0'
			};

			driveSpec[0] = drive;
			retVal = Tcl_NewStringObj(driveSpec,2);
			Tcl_IncrRefCount(retVal);
			return retVal;
		    }

		    /* 
		     * This is actually a mounted drive, which doesn't
		     * exists as a DOS drive letter.  This means the path
		     * isn't actually a link, although we partially treat
		     * it like one ('file type' will return 'link'), but
		     * then the link will actually just be treated like
		     * an ordinary directory.  I don't believe any
		     * serious inconsistency will arise from this, but it
		     * is something to be aware of.
		     */

		    Tcl_SetErrno(EINVAL);
		    return NULL;

		} else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
				   .PathBuffer, L"\\\\?\\",4) == 0) {

		    /* Strip off the prefix */


		    offset = 4;
		} else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
				   .PathBuffer, L"\\??\\",4) == 0) {

		    /* Strip off the prefix */

		    offset = 4;
		}
	    }
	    
	    Tcl_WinTCharToUtf(
		(CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, 
		(int)reparseBuffer->SymbolicLinkReparseBuffer
		.SubstituteNameLength, &ds);
	
	    copy = Tcl_DStringValue(&ds)+offset;
	    len = Tcl_DStringLength(&ds)-offset;
	    retVal = Tcl_NewStringObj(copy,len);
	    Tcl_IncrRefCount(retVal);
	    Tcl_DStringFree(&ds);
	    return retVal;
	}
    }

    Tcl_SetErrno(EINVAL);
    return NULL;
}


/*
 *--------------------------------------------------------------------
 *
 * NativeReadReparse
 *
 * Read the junction/reparse information from a given NTFS directory.
 *
 * Assumption that LinkDirectory is a valid, existing directory.
 * 
 * Returns zero on success.


 *--------------------------------------------------------------------
 */

static int 
NativeReadReparse(LinkDirectory, buffer)
    CONST TCHAR* LinkDirectory;   /* The junction to read */
    REPARSE_DATA_BUFFER* buffer;  /* Pointer to buffer. Cannot be NULL */
{
    HANDLE hFile;
    DWORD returnedLength;
   
    hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
	NULL, OPEN_EXISTING, 
	FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile == INVALID_HANDLE_VALUE) {

	/* Error creating directory */


	TclWinConvertError(GetLastError());
	return -1;
    }


    /* Get the link */


    if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, 
			 0, buffer, sizeof(DUMMY_REPARSE_BUFFER), 
			 &returnedLength, NULL)) {	

	/* Error setting junction */


	TclWinConvertError(GetLastError());
	CloseHandle(hFile);
	return -1;
    }
    CloseHandle(hFile);
    
    if (!IsReparseTagValid(buffer->ReparseTag)) {
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * NativeWriteReparse
 *
 * Write the reparse information for a given directory.
 * 
 * Assumption that LinkDirectory does not exist.

 *--------------------------------------------------------------------
 */

static int 
NativeWriteReparse(LinkDirectory, buffer)
    CONST TCHAR* LinkDirectory;
    REPARSE_DATA_BUFFER* buffer;
{
    HANDLE hFile;
    DWORD returnedLength;
    

    /* Create the directory - it must not already exist */


    if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {

	/* Error creating directory */


	TclWinConvertError(GetLastError());
	return -1;
    }

    hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
	NULL, OPEN_EXISTING, 
	FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
    if (hFile == INVALID_HANDLE_VALUE) {

	/* Error creating directory */

	TclWinConvertError(GetLastError());
	return -1;
    }


    /* Set the link */


    if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer, 
			 (DWORD) buffer->ReparseDataLength 
			 + REPARSE_MOUNTPOINT_HEADER_SIZE,
			 NULL, 0, &returnedLength, NULL)) {	

	/* Error setting junction */


	TclWinConvertError(GetLastError());
	CloseHandle(hFile);
	(*tclWinProcs->removeDirectoryProc)(LinkDirectory);
	return -1;
    }
    CloseHandle(hFile);


    /* We succeeded */


    return 0;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This procedure computes the absolute path name of the current
 *	application.
 *
 * Results:
 * 	None.
 *
 * Side effects:
 *	The computed path is stored.
 *
 *---------------------------------------------------------------------------
 */

|


|
|
|
|



|
|

|


|









|
|
<


|


|
|
|

>

|


|


|


|


|


|


|


|



|


|


|


>
|


|


|


>
|
>
|
>
|


|
|
|


|


|
|
|
|
|
|
|
|
<


|


|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|






|


|
|


|






|
|


|
|
|
|



>
|
>


|
<

|
|

|
<

|
|


|


|
|
>
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|




|

|
>


>
|

|
|


|
|
|
|
>
|
>
>
|
|
>
|
>




>
|
>
>






>
|
>
>
|
|
>
|
>
>



>
>
|
>
>


>
|
>
>


>

>
|
>
>




>

|
>




>

>
|
>
>









>

>
|
>
>












|

|
>


>
|

|

|
|
|
|
>
|
>
>
|
|
>
|
>
>




>
|
>
>


>
|
>
>


>

>
|
>
>










|

|
|
|

|
|
|
>
>


>
|

|
|



|
|
|
|
>
|
>
>

|


>
|
|
|
|

>






|
>
|
>
>


|
|


|
|
|
|
|
|
|
|
|






|

|
|
|
|
|
>
>


>
|

|
|


|
|









|

|
|
|
|
|
|
|
>
>


>
|

|


>
|
>
>

|


>



|
|
>

|
|
<
>
|
>
>





|










|

|
|
|

|
|
>
|
|
|
|
|
>


>
|

|




|






|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
|
>
|
|
|
|
|
|
>
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
|
<
|
|
|
|
|
>
|
|
>
|
|
>
|
>
>
|
|
|
>
|
>
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
<
>
|
|
|
|
>



|

|

|
|
|
>
>


>
|

|
|



|

|
|
>

>
|
>
>



>
>
|
>
>
|
<
|
>
|
>
>





|










|

|
|
|
>


>
|

|




|
>
|
>
>

>
|
>
>



>

|
|

>
|
>



>
>
|
>
>
|
|
<
|
>
|
>
>






>
>
|
>
>








|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

171
172
173
174
175

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604












605
606
607

608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633

634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670

671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717

718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785

786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
/*
 * tclWinFile.c --
 *
 *	This file contains temporary wrappers around UNIX file handling
 *	functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *	files, which can be manipulated through the Win32 console redirection
 *	interfaces.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFile.c,v 1.72.2.4 2005/09/09 18:48:41 dgp Exp $
 */

//#define _WIN32_WINNT	0x0500

#include "tclWinInt.h"
#include "tclFileSystem.h"
#include <winioctl.h>
#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h>		/* For TclpGetUserHome(). */

/*
 * The number of 100-ns intervals between the Windows system epoch (1601-01-01
 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01).

 */

#define POSIX_EPOCH_AS_FILETIME		116444736000000000

/*
 * Declarations for 'link' related information. This information should come
 * with VC++ 6.0, but is not in some older SDKs. In any case it is not well
 * documented.
 */

#ifndef IO_REPARSE_TAG_RESERVED_ONE
#  define IO_REPARSE_TAG_RESERVED_ONE	0x000000001
#endif
#ifndef IO_REPARSE_TAG_RESERVED_RANGE
#  define IO_REPARSE_TAG_RESERVED_RANGE	0x000000001
#endif
#ifndef IO_REPARSE_TAG_VALID_VALUES
#  define IO_REPARSE_TAG_VALID_VALUES	0x0E000FFFF
#endif
#ifndef IO_REPARSE_TAG_HSM
#  define IO_REPARSE_TAG_HSM		0x0C0000004
#endif
#ifndef IO_REPARSE_TAG_NSS
#  define IO_REPARSE_TAG_NSS		0x080000005
#endif
#ifndef IO_REPARSE_TAG_NSSRECOVER
#  define IO_REPARSE_TAG_NSSRECOVER	0x080000006
#endif
#ifndef IO_REPARSE_TAG_SIS
#  define IO_REPARSE_TAG_SIS		0x080000007
#endif
#ifndef IO_REPARSE_TAG_DFS
#  define IO_REPARSE_TAG_DFS		0x080000008
#endif

#ifndef IO_REPARSE_TAG_RESERVED_ZERO
#  define IO_REPARSE_TAG_RESERVED_ZERO	0x00000000
#endif
#ifndef FILE_FLAG_OPEN_REPARSE_POINT
#  define FILE_FLAG_OPEN_REPARSE_POINT	0x00200000
#endif
#ifndef IO_REPARSE_TAG_MOUNT_POINT
#  define IO_REPARSE_TAG_MOUNT_POINT	0xA0000003
#endif
#ifndef IsReparseTagValid
#  define IsReparseTagValid(x) \
    (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
#endif
#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
#  define IO_REPARSE_TAG_SYMBOLIC_LINK	IO_REPARSE_TAG_RESERVED_ZERO
#endif
#ifndef FILE_SPECIAL_ACCESS
#  define FILE_SPECIAL_ACCESS		(FILE_ANY_ACCESS)
#endif
#ifndef FSCTL_SET_REPARSE_POINT
#  define FSCTL_SET_REPARSE_POINT \
    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
#  define FSCTL_GET_REPARSE_POINT \
    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS)
#  define FSCTL_DELETE_REPARSE_POINT \
    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
#endif

/*
 * Maximum reparse buffer info size. The max user defined reparse data is
 * 16KB, plus there's a header.
 */

#define MAX_REPARSE_SIZE		17000

/*
 * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition. This is
 * found in winnt.h.
 *
 * IMPORTANT: caution when using this structure, since the actual structures
 * used will want to store a full path in the 'PathBuffer' field, but there
 * isn't room (there's only a single WCHAR!). Therefore one must artificially
 * create a larger space of memory and then cast it to this type. We use the
 * 'DUMMY_REPARSE_BUFFER' struct just below to deal with this problem.

 */

#define REPARSE_MOUNTPOINT_HEADER_SIZE	 8
#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
typedef struct _REPARSE_DATA_BUFFER {
    DWORD ReparseTag;
    WORD ReparseDataLength;
    WORD Reserved;
    union {
	struct {
	    WORD SubstituteNameOffset;
	    WORD SubstituteNameLength;
	    WORD PrintNameOffset;
	    WORD PrintNameLength;
	    WCHAR PathBuffer[1];
	} SymbolicLinkReparseBuffer;
	struct {
	    WORD SubstituteNameOffset;
	    WORD SubstituteNameLength;
	    WORD PrintNameOffset;
	    WORD PrintNameLength;
	    WCHAR PathBuffer[1];
	} MountPointReparseBuffer;
	struct {
	    BYTE DataBuffer[1];
	} GenericReparseBuffer;
    };
} REPARSE_DATA_BUFFER;
#endif

typedef struct {
    REPARSE_DATA_BUFFER dummy;
    WCHAR dummyBuf[MAX_PATH*3];
} DUMMY_REPARSE_BUFFER;

#if defined(_MSC_VER) && (_MSC_VER <= 1100)
#undef	HAVE_NO_FINDEX_ENUMS
#define HAVE_NO_FINDEX_ENUMS
#elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400)
#undef	HAVE_NO_FINDEX_ENUMS
#define HAVE_NO_FINDEX_ENUMS
#endif

#ifdef HAVE_NO_FINDEX_ENUMS
/* These two aren't in VC++ 5.2 headers */
typedef enum _FINDEX_INFO_LEVELS {
    FindExInfoStandard,
    FindExInfoMaxInfoLevel
} FINDEX_INFO_LEVELS;
typedef enum _FINDEX_SEARCH_OPS {
    FindExSearchNameMatch,
    FindExSearchLimitToDirectories,
    FindExSearchLimitToDevices,
    FindExSearchMaxSearchOp
} FINDEX_SEARCH_OPS;
#endif /* HAVE_NO_FINDEX_ENUMS */

/*
 * Other typedefs required by this code.
 */

static time_t		ToCTime(FILETIME fileTime);
static void		FromCTime(time_t posixTime, FILETIME *fileTime);


typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC(
	LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);

typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC(LPVOID Buffer);


typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC(
	LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);

/*
 * Declarations for local functions defined in this file:
 */

static int		NativeAccess(CONST TCHAR *path, int mode);
static int		NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr,
			    int checkLinks);
static unsigned short	NativeStatMode(DWORD attr, int checkLinks, int isExec);
static int		NativeIsExec(CONST TCHAR *path);
static int		NativeReadReparse(CONST TCHAR *LinkDirectory,
			    REPARSE_DATA_BUFFER* buffer);
static int		NativeWriteReparse(CONST TCHAR *LinkDirectory,
			    REPARSE_DATA_BUFFER* buffer);
static int		NativeMatchType(int isDrive, DWORD attr,
			    CONST TCHAR *nativeName, Tcl_GlobTypeData *types);
static int		WinIsDrive(CONST char *name, int nameLen);
static int		WinIsReserved(CONST char *path);
static Tcl_Obj *	WinReadLink(CONST TCHAR *LinkSource);
static Tcl_Obj *	WinReadLinkDirectory(CONST TCHAR *LinkDirectory);
static int		WinLink(CONST TCHAR *LinkSource,
			    CONST TCHAR *LinkTarget, int linkAction);
static int		WinSymLinkDirectory(CONST TCHAR *LinkDirectory,
			    CONST TCHAR *LinkTarget);

/*
 *--------------------------------------------------------------------
 *
 * WinLink --
 *
 *	Make a link from source to target.
 *
 *--------------------------------------------------------------------
 */

static int
WinLink(LinkSource, LinkTarget, linkAction)
    CONST TCHAR *LinkSource;
    CONST TCHAR *LinkTarget;
    int linkAction;
{
    WCHAR tempFileName[MAX_PATH];
    TCHAR *tempFilePart;
    int attr;

    /*
     * Get the full path referenced by the target.
     */

    if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, MAX_PATH,
	    tempFileName, &tempFilePart)) {
	/*
	 * Invalid file.
	 */
	TclWinConvertError(GetLastError());
	return -1;
    }

    /*
     * Make sure source file doesn't exist.
     */

    attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
    if (attr != 0xffffffff) {
	Tcl_SetErrno(EEXIST);
	return -1;
    }

    /*
     * Get the full path referenced by the source file/directory.
     */

    if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, MAX_PATH,
	    tempFileName, &tempFilePart)) {
	/*
	 * Invalid file.
	 */

	TclWinConvertError(GetLastError());
	return -1;
    }

    /*
     * Check the target.
     */

    attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
    if (attr == 0xffffffff) {
	/*
	 * The target doesn't exist.
	 */

	TclWinConvertError(GetLastError());
	return -1;

    } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * It is a file.
	 */

	if (tclWinProcs->createHardLinkProc == NULL) {
	    Tcl_SetErrno(ENOTDIR);
	    return -1;
	}

	if (linkAction & TCL_CREATE_HARD_LINK) {
	    if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget,
		    NULL)) {
		TclWinConvertError(GetLastError());
		return -1;
	    }
	    return 0;

	} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    /*
	     * Can't symlink files.
	     */

	    Tcl_SetErrno(ENOTDIR);
	    return -1;
	} else {
	    Tcl_SetErrno(ENODEV);
	    return -1;
	}
    } else {
	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    return WinSymLinkDirectory(LinkSource, LinkTarget);

	} else if (linkAction & TCL_CREATE_HARD_LINK) {
	    /*
	     * Can't hard link directories.
	     */

	    Tcl_SetErrno(EISDIR);
	    return -1;
	} else {
	    Tcl_SetErrno(ENODEV);
	    return -1;
	}
    }
}

/*
 *--------------------------------------------------------------------
 *
 * WinReadLink --
 *
 *	What does 'LinkSource' point to?
 *
 *--------------------------------------------------------------------
 */

static Tcl_Obj*
WinReadLink(LinkSource)
    CONST TCHAR *LinkSource;
{
    WCHAR tempFileName[MAX_PATH];
    TCHAR *tempFilePart;
    int attr;

    /*
     * Get the full path referenced by the target.
     */

    if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, MAX_PATH,
	    tempFileName, &tempFilePart)) {
	/*
	 * Invalid file.
	 */

	TclWinConvertError(GetLastError());
	return NULL;
    }

    /*
     * Make sure source file does exist.
     */

    attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
    if (attr == 0xffffffff) {
	/*
	 * The source doesn't exist.
	 */

	TclWinConvertError(GetLastError());
	return NULL;

    } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * It is a file - this is not yet supported.
	 */

	Tcl_SetErrno(ENOTDIR);
	return NULL;
    } else {
	return WinReadLinkDirectory(LinkSource);
    }
}

/*
 *--------------------------------------------------------------------
 *
 * WinSymLinkDirectory --
 *
 *	This routine creates a NTFS junction, using the undocumented
 *	FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points and
 *	junctions.
 *
 *	Assumption that LinkTarget is a valid, existing directory.
 *
 * Returns:
 *	Zero on success.
 *
 *--------------------------------------------------------------------
 */

static int
WinSymLinkDirectory(LinkDirectory, LinkTarget)
    CONST TCHAR *LinkDirectory;
    CONST TCHAR *LinkTarget;
{
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    int len;
    WCHAR nativeTarget[MAX_PATH];
    WCHAR *loop;

    /*
     * Make the native target name.
     */

    memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
    memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget,
	   sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
    len = wcslen(nativeTarget);

    /*
     * We must have backslashes only. This is VERY IMPORTANT. If we have any
     * forward slashes everything appears to work, but the resulting symlink
     * is useless!
     */

    for (loop = nativeTarget; *loop != 0; loop++) {
	if (*loop == L'/') *loop = L'\\';
    }
    if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
	nativeTarget[len-1] = 0;
    }

    /*
     * Build the reparse info.
     */

    memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
    reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
    reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength =
	    wcslen(nativeTarget) * sizeof(WCHAR);
    reparseBuffer->Reserved = 0;
    reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
    reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset =
	    reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength
	    + sizeof(WCHAR);
    memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget,
	    sizeof(WCHAR)
	    + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
    reparseBuffer->ReparseDataLength =
	    reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;

    return NativeWriteReparse(LinkDirectory, reparseBuffer);
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinSymLinkCopyDirectory --
 *
 *	Copy a Windows NTFS junction. This function assumes that LinkOriginal
 *	exists and is a valid junction point, and that LinkCopy does not
 *	exist.
 *
 * Returns:
 *	Zero on success.
 *
 *--------------------------------------------------------------------
 */

int
TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
    CONST TCHAR *LinkOriginal;	/* Existing junction - reparse point */
    CONST TCHAR *LinkCopy;	/* Will become a duplicate junction */
{
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;

    if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
	return -1;
    }
    return NativeWriteReparse(LinkCopy, reparseBuffer);
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinSymLinkDelete --
 *
 *	Delete a Windows NTFS junction. Once the junction information is
 *	deleted, the filesystem object becomes an ordinary directory. Unless
 *	'linkOnly' is given, that directory is also removed.
 *
 *	Assumption that LinkOriginal is a valid, existing junction.
 *
 * Returns:
 *	Zero on success.
 *
 *--------------------------------------------------------------------
 */

int
TclWinSymLinkDelete(LinkOriginal, linkOnly)
    CONST TCHAR *LinkOriginal;
    int linkOnly;
{
    /*
     * It is a symbolic link - remove it.
     */

    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
    HANDLE hFile;
    DWORD returnedLength;

    memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
    reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
    hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile != INVALID_HANDLE_VALUE) {
	if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
		REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) {

	    /*
	     * Error setting junction.
	     */

	    TclWinConvertError(GetLastError());
	    CloseHandle(hFile);
	} else {
	    CloseHandle(hFile);
	    if (!linkOnly) {
		(*tclWinProcs->removeDirectoryProc)(LinkOriginal);
	    }
	    return 0;
	}
    }
    return -1;
}

/*
 *--------------------------------------------------------------------
 *
 * WinReadLinkDirectory --
 *
 *	This routine reads a NTFS junction, using the undocumented
 *	FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points and
 *	junctions.
 *
 *	Assumption that LinkDirectory is a valid, existing directory.
 *
 * Returns:
 *	A Tcl_Obj with refCount of 1 (i.e. owned by the caller), or NULL if
 *	anything went wrong.
 *
 *	In the future we should enhance this to return a path object rather
 *	than a string.
 *
 *--------------------------------------------------------------------
 */

static Tcl_Obj*
WinReadLinkDirectory(LinkDirectory)
    CONST TCHAR *LinkDirectory;
{
    int attr;
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;

    attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
    if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	Tcl_SetErrno(EINVAL);
	return NULL;
    }
    if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
	return NULL;
    }

    switch (reparseBuffer->ReparseTag) {
    case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
    case IO_REPARSE_TAG_SYMBOLIC_LINK:
    case IO_REPARSE_TAG_MOUNT_POINT: {
	Tcl_Obj *retVal;
	Tcl_DString ds;
	CONST char *copy;
	int len;
	int offset = 0;

	/*
	 * Certain native path representations on Windows have a special
	 * prefix to indicate that they are to be treated specially. For
	 * example extremely long paths, or symlinks, or volumes mounted
	 * inside directories.
	 *
	 * There is an assumption in this code that 'wide' interfaces are
	 * being used (see tclWin32Dll.c), which is true for the only systems
	 * which support reparse tags at present. If that changes in the
	 * future, this code will have to be generalised.
	 */

	if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] == L'\\') {
	    /*
	     * Check whether this is a mounted volume.
	     */

	    if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
		    L"\\??\\Volume{",11) == 0) {
		char drive;













		/*
		 * There is some confusion between \??\ and \\?\ which we have
		 * to fix here. It doesn't seem very well documented.

		 */

		reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[1] = L'\\';

		/*
		 * Check if a corresponding drive letter exists, and use that
		 * if it is found
		 */

		drive = TclWinDriveLetterForVolMountPoint(
			reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer);
		if (drive != -1) {
		    char driveSpec[3] = {
			'\0', ':', '\0'
		    };

		    driveSpec[0] = drive;
		    retVal = Tcl_NewStringObj(driveSpec,2);
		    Tcl_IncrRefCount(retVal);
		    return retVal;
		}

		/*
		 * This is actually a mounted drive, which doesn't exists as a
		 * DOS drive letter. This means the path isn't actually a
		 * link, although we partially treat it like one ('file type'

		 * will return 'link'), but then the link will actually just
		 * be treated like an ordinary directory. I don't believe any
		 * serious inconsistency will arise from this, but it is
		 * something to be aware of.
		 */

		Tcl_SetErrno(EINVAL);
		return NULL;

	    } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
		    .PathBuffer, L"\\\\?\\",4) == 0) {
		/*
		 * Strip off the prefix.
		 */

		offset = 4;
	    } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
		    .PathBuffer, L"\\??\\",4) == 0) {
		/*
		 * Strip off the prefix.
		 */
		offset = 4;
	    }
	}

	Tcl_WinTCharToUtf((CONST char*)
		reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
		(int) reparseBuffer->SymbolicLinkReparseBuffer
		.SubstituteNameLength, &ds);

	copy = Tcl_DStringValue(&ds)+offset;
	len = Tcl_DStringLength(&ds)-offset;
	retVal = Tcl_NewStringObj(copy,len);
	Tcl_IncrRefCount(retVal);
	Tcl_DStringFree(&ds);
	return retVal;
    }

    default:
	Tcl_SetErrno(EINVAL);
	return NULL;
    }
}

/*
 *--------------------------------------------------------------------
 *
 * NativeReadReparse --
 *
 *	Read the junction/reparse information from a given NTFS directory.
 *
 *	Assumption that LinkDirectory is a valid, existing directory.
 *
 * Returns:
 *	Zero on success.
 *
 *--------------------------------------------------------------------
 */

static int
NativeReadReparse(LinkDirectory, buffer)
    CONST TCHAR *LinkDirectory;	/* The junction to read */
    REPARSE_DATA_BUFFER *buffer;/* Pointer to buffer. Cannot be NULL */
{
    HANDLE hFile;
    DWORD returnedLength;

    hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile == INVALID_HANDLE_VALUE) {
	/*
	 * Error creating directory.
	 */

	TclWinConvertError(GetLastError());
	return -1;
    }

    /*
     * Get the link.
     */

    if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer,

	    sizeof(DUMMY_REPARSE_BUFFER), &returnedLength, NULL)) {
	/*
	 * Error setting junction.
	 */

	TclWinConvertError(GetLastError());
	CloseHandle(hFile);
	return -1;
    }
    CloseHandle(hFile);

    if (!IsReparseTagValid(buffer->ReparseTag)) {
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * NativeWriteReparse --
 *
 *	Write the reparse information for a given directory.
 *
 *	Assumption that LinkDirectory does not exist.
 *
 *--------------------------------------------------------------------
 */

static int
NativeWriteReparse(LinkDirectory, buffer)
    CONST TCHAR *LinkDirectory;
    REPARSE_DATA_BUFFER* buffer;
{
    HANDLE hFile;
    DWORD returnedLength;

    /*
     * Create the directory - it must not already exist.
     */

    if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {
	/*
	 * Error creating directory.
	 */

	TclWinConvertError(GetLastError());
	return -1;
    }

    hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
    if (hFile == INVALID_HANDLE_VALUE) {
	/*
	 * Error creating directory.
	 */
	TclWinConvertError(GetLastError());
	return -1;
    }

    /*
     * Set the link.
     */

    if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer,
	    (DWORD) buffer->ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE,

	    NULL, 0, &returnedLength, NULL)) {
	/*
	 * Error setting junction.
	 */

	TclWinConvertError(GetLastError());
	CloseHandle(hFile);
	(*tclWinProcs->removeDirectoryProc)(LinkDirectory);
	return -1;
    }
    CloseHandle(hFile);

    /*
     * We succeeded.
     */

    return 0;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current
 *	application.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The computed path is stored.
 *
 *---------------------------------------------------------------------------
 */

696
697
698
699
700
701
702

703
704
705

706
707

708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730

731
732
733
734
735
736
737
738
739
740
741
742
743
744

745


746
747
748
749
750
751

752


753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771

772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805

806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843

844
845
846
847

848
849
850
851
852
853

854


855
856
857
858
859
860
861
862
863
864
865
866
867
868

869
870
871

872

873
874
875
876

877
878
879
880
881
882
883
884
885

886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925

926


927
928
929
930
931
932
933
934
935
936
937

938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976

977
978
979
980
981
982
983
984
985
986
987
988
989
990

991
992
993
994
995
996
997
998
999

1000


1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015

1016


1017
1018
1019
1020

1021
1022
1023
1024
1025
1026
1027

1028


1029
1030
1031

1032


1033
1034
1035

1036
1037
1038
1039
























































1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057

1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073

1074

1075
1076
1077
1078
1079

1080

1081
1082
1083
1084
1085

1086

1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108

1109


1110

1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135


1136

1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
    /*
     * Under Windows we ignore argv0, and return the path for the file used to
     * create this process.
     */

    if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) {
	GetModuleFileNameA(NULL, name, sizeof(name));

	/*
	 * Convert to WCHAR to get out of ANSI codepage
	 */

	MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH);
    }

    WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
    TclWinNoBackslash(name);
    TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a
 *	directory for all files which match a given pattern.
 *
 * Results: 
 *	
 *	The return value is a standard Tcl result indicating whether an
 *	error occurred in globbing.  Errors are left in interp, good
 *	results are lappended to resultPtr (which must be a valid object)
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------- */


int
TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive errors. */
    Tcl_Obj *resultPtr;		/* List object to lappend results. */
    Tcl_Obj *pathPtr;	        /* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    CONST TCHAR *native;

    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {

	/* The native filesystem never adds mounts */


	return TCL_OK;
    }

    if (pattern == NULL || (*pattern == '\0')) {
	Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (norm != NULL) {

	    /* Match a single file directly */


	    int len;
	    DWORD attr;
	    CONST char *str = Tcl_GetStringFromObj(norm,&len);

	    native = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr);
	    
	    if (tclWinProcs->getFileAttributesExProc == NULL) {
		attr = (*tclWinProcs->getFileAttributesProc)(native);
		if (attr == 0xffffffff) {
		    return TCL_OK;
		}
	    } else {
		WIN32_FILE_ATTRIBUTE_DATA data;
		if ((*tclWinProcs->getFileAttributesExProc)(native,
			GetFileExInfoStandard, &data) != TRUE) {
		    return TCL_OK;
		}
		attr = data.dwFileAttributes;
	    }

	    if (NativeMatchType(WinIsDrive(str,len), attr, 
				native, types)) {
		Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
	    }
	}
	return TCL_OK;
    } else {
	DWORD attr;
	HANDLE handle;
	WIN32_FIND_DATAT data;
	CONST char *dirName;   /* utf-8 dir name, later 
	                        * with pattern appended */
	int dirLength;
	int matchSpecialDots;
	Tcl_DString ds;        /* native encoding of dir, also used
	                        * temporarily for other things. */
	Tcl_DString dsOrig;    /* utf-8 encoding of dir */
	Tcl_Obj *fileNamePtr;
	char lastChar;

	/*
	 * Get the normalized path representation 
	 * (the main thing is we dont want any '~' sequences).
	 */

	fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
	if (fileNamePtr == NULL) {
	    return TCL_ERROR;
	}

	/*
	 * Verify that the specified path exists and 
	 * is actually a directory.
	 */

	native = Tcl_FSGetNativePath(pathPtr);
	if (native == NULL) {
	    return TCL_OK;
	}
	attr = (*tclWinProcs->getFileAttributesProc)(native);

	if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
	    return TCL_OK;
	}

	/* 
	 * Build up the directory name for searching, including
	 * a trailing directory separator.
	 */

	Tcl_DStringInit(&dsOrig);
	dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
	Tcl_DStringAppend(&dsOrig, dirName, dirLength);
	
	lastChar = dirName[dirLength -1];
	if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
	    Tcl_DStringAppend(&dsOrig, "/", 1);
	    dirLength++;
	}
	dirName = Tcl_DStringValue(&dsOrig);

	/*
	 * We need to check all files in the directory, so we append
	 * '*.*' to the path, unless the pattern we've been given is
	 * rather simple, when we can use that instead.
	 */

	if (strpbrk(pattern, "[]\\") == NULL) {
	    /* 
	     * The pattern is a simple one containing just '*' and/or '?'.
	     * This means we can get the OS to help us, by passing
	     * it the pattern.
	     */

	    dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
	} else {
	    dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3);
	}

	native = Tcl_WinUtfToTChar(dirName, -1, &ds);
	if (tclWinProcs->findFirstFileExProc == NULL 
	    || (types == NULL)
	    || (types->type != TCL_GLOB_TYPE_DIR)) {
	    handle = (*tclWinProcs->findFirstFileProc)(native, &data);
	} else {

	    /* We can be more efficient, for pure directory requests */


	    handle = (*tclWinProcs->findFirstFileExProc)(native, 
			FindExInfoStandard, &data, 
			FindExSearchLimitToDirectories, NULL, 0);
	}

	if (handle == INVALID_HANDLE_VALUE) {
	    DWORD err = GetLastError();
	    Tcl_DStringFree(&ds);
	    if (err == ERROR_FILE_NOT_FOUND) {
	        /* 
	         * We used our 'pattern' above, and matched nothing
	         * This means we just return TCL_OK, indicating
	         * no results found.
	         */

		Tcl_DStringFree(&dsOrig);
		return TCL_OK;
	    }

	    TclWinConvertError(err);

	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "couldn't read directory \"",
		    Tcl_DStringValue(&dsOrig), "\": ", 
		    Tcl_PosixError(interp), (char *) NULL);

	    Tcl_DStringFree(&dsOrig);
	    return TCL_ERROR;
	}
	Tcl_DStringFree(&ds);

	/* 
	 * We may use this later, so we must restore it to its
	 * length including the directory delimiter
	 */

	Tcl_DStringSetLength(&dsOrig, dirLength);

	/*
	 * Check to see if the pattern should match the special
	 * . and .. names, referring to the current directory,
	 * or the directory above.  We need a special check for
	 * this because paths beginning with a dot are not considered
	 * hidden on Windows, and so otherwise a relative glob like
	 * 'glob -join * *' will actually return './. ../..' etc.
	 */

	if ((pattern[0] == '.')
		|| ((pattern[0] == '\\') && (pattern[1] == '.'))) {
	    matchSpecialDots = 1;
	} else {
	    matchSpecialDots = 0;
	}

	/*
	 * Now iterate over all of the files in the directory, starting
	 * with the first one we found.
	 */

	do {
	    CONST char *utfname;
	    int checkDrive = 0;
	    int isDrive;
	    DWORD attr;
	    
	    if (tclWinProcs->useWide) {
		native = (CONST TCHAR *) data.w.cFileName;
		attr = data.w.dwFileAttributes;
	    } else {
		native = (CONST TCHAR *) data.a.cFileName;
		attr = data.a.dwFileAttributes;
	    }
	    
	    utfname = Tcl_WinTCharToUtf(native, -1, &ds);

	    if (!matchSpecialDots) {

		/* If it is exactly '.' or '..' then we ignore it */


		if ((utfname[0] == '.') && (utfname[1] == '\0' 
			|| (utfname[1] == '.' && utfname[2] == '\0'))) {
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    } else if (utfname[0] == '.' && utfname[1] == '.'
		    && utfname[2] == '\0') {
		/* 
		 * Have to check if this is a drive below, so we can
		 * correctly match 'hidden' and not hidden files.
		 */

		checkDrive = 1;
	    }
	    
	    /*
	     * Check to see if the file matches the pattern.  Note that
	     * we are ignoring the case sensitivity flag because Windows
	     * doesn't honor case even if the volume is case sensitive.
	     * If the volume also doesn't preserve case, then we
	     * previously returned the lower case form of the name.  This
	     * didn't seem quite right since there are
	     * non-case-preserving volumes that actually return mixed
	     * case.  So now we are returning exactly what we get from
	     * the system.
	     */

	    if (Tcl_StringCaseMatch(utfname, pattern, 1)) {
		/*
		 * If the file matches, then we need to process the remainder
		 * of the path.
		 */

		if (checkDrive) {
		    CONST char *fullname = Tcl_DStringAppend(&dsOrig, utfname,
			    Tcl_DStringLength(&ds));
		    isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig));
		    Tcl_DStringSetLength(&dsOrig, dirLength);
		} else {
		    isDrive = 0;
		}
		if (NativeMatchType(isDrive, attr, native, types)) {
		    Tcl_ListObjAppendElement(interp, resultPtr, 
			    TclNewFSPathObj(pathPtr, utfname,
				    Tcl_DStringLength(&ds)));
		}
	    }

	    /*
	     * Free ds here to ensure that native is valid above.
	     */

	    Tcl_DStringFree(&ds);
	} while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE);

	FindClose(handle);
	Tcl_DStringFree(&dsOrig);
	return TCL_OK;
    }
}

/* 
 * Does the given path represent a root volume?  We need this special
 * case because for NTFS root volumes, the getFileAttributesProc returns
 * a 'hidden' attribute when it should not.
 */

static int
WinIsDrive(
    CONST char *name,     /* Name (UTF-8) */
    int len)              /* Length of name */
{
    int remove = 0;
    while (len > 4) {
        if ((name[len-1] != '.' || name[len-2] != '.') 
	    || (name[len-3] != '/' && name[len-3] != '\\')) {

            /* We don't have '/..' at the end */


	    if (remove == 0) {
	        break;
	    }
	    remove--;
	    while (len > 0) {
		len--;
		if (name[len] == '/' || name[len] == '\\') {
		    break;
		}
	    }
	    if (len < 4) {
	        len++;
		break;
	    }
        } else {

	    /* We do have '/..' */


	    len -= 3;
	    remove++;
        }
    }

    if (len < 4) {
	if (len == 0) {
	    /* 
	     * Not sure if this is possible, but we pass it on
	     * anyway 
	     */
	} else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {

	    /* Path is pointing to the root volume */


	    return 1;
	} else if ((name[1] == ':') 
		   && (len == 2 || (name[2] == '/' || name[2] == '\\'))) {

	    /* Path is of the form 'x:' or 'x:/' or 'x:\' */


	    return 1;
	}
    }

    return 0;
}

/*
























































 *----------------------------------------------------------------------
 * 
 * NativeMatchType --
 * 
 * This function needs a special case for a path which is a root
 * volume, because for NTFS root volumes, the getFileAttributesProc
 * returns a 'hidden' attribute when it should not.
 * 
 * We never make any calss to a 'get attributes' routine here,
 * since we have arranged things so that our caller already knows
 * such information.
 * 
 * Results:
 *  0 = file doesn't match
 *  1 = file matches
 * 
 *----------------------------------------------------------------------
 */

static int 
NativeMatchType(
    int isDrive,              /* Is this a drive */
    DWORD attr,               /* We already know the attributes 
                               * for the file */
    CONST TCHAR* nativeName,  /* Native path to check */
    Tcl_GlobTypeData *types)  /* Type description to match against */
{
    /*
     * 'attr' represents the attributes of the file, but we only
     * want to retrieve this info if it is absolutely necessary
     * because it is an expensive call.  Unfortunately, to deal
     * with hidden files properly, we must always retrieve it.
     */

    if (types == NULL) {

	/* If invisible, don't return the file */

	if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
	    return 0;
	}
    } else {
	if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {

	    /* If invisible */

	    if ((types->perm == 0) || 
		    !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
		return 0;
	    }
	} else {

	    /* Visible */

	    if (types->perm & TCL_GLOB_PERM_HIDDEN) {
		return 0;
	    }
	}
	
	if (types->perm != 0) {
	    if (
		((types->perm & TCL_GLOB_PERM_RONLY) &&
			!(attr & FILE_ATTRIBUTE_READONLY)) ||
		((types->perm & TCL_GLOB_PERM_R) &&
			(0 /* File exists => R_OK on Windows */)) ||
		((types->perm & TCL_GLOB_PERM_W) &&
			(attr & FILE_ATTRIBUTE_READONLY)) ||
		((types->perm & TCL_GLOB_PERM_X) &&
			(!(attr & FILE_ATTRIBUTE_DIRECTORY)
			 && !NativeIsExec(nativeName)))
		) {
		return 0;
	    }
	}
	if ((types->type & TCL_GLOB_TYPE_DIR) 
	    && (attr & FILE_ATTRIBUTE_DIRECTORY)) {

	    /* Quicker test for directory, which is a common case */


	    return 1;

	} else if (types->type != 0) {
	    unsigned short st_mode;
	    int isExec = NativeIsExec(nativeName);
	    
	    st_mode = NativeStatMode(attr, 0, isExec);

	    /*
	     * In order bcdpfls as in 'find -t'
	     */
	    if (
		((types->type & TCL_GLOB_TYPE_BLOCK) &&
			S_ISBLK(st_mode)) ||
		((types->type & TCL_GLOB_TYPE_CHAR) &&
			S_ISCHR(st_mode)) ||
		((types->type & TCL_GLOB_TYPE_DIR) &&
			S_ISDIR(st_mode)) ||
		((types->type & TCL_GLOB_TYPE_PIPE) &&
			S_ISFIFO(st_mode)) ||
		((types->type & TCL_GLOB_TYPE_FILE) &&
			S_ISREG(st_mode))
#ifdef S_ISSOCK
		|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
			S_ISSOCK(st_mode))
#endif
		) {


		/* Do nothing -- this file is ok */

	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    st_mode = NativeStatMode(attr, 1, isExec);
		    if (S_ISLNK(st_mode)) {
			return 1;
		    }
		}
#endif
		return 0;
	    }
	}		
    } 
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *
 *	This function takes the passed in user name and finds the
 *	corresponding home directory specified in the password file.
 *
 * Results:
 *	The result is a pointer to a string specifying the user's home
 *	directory, or NULL if the user's home directory could not be
 *	determined.  Storage for the result string is allocated in
 *	bufferPtr; the caller must call Tcl_DStringFree() when the result
 *	is no longer needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








>



>


>










|
|

|
<
|
|
|




|
>





|








>
|
>
>






>
|
>
>




|
|













>
|
<








|
|


|
|
|




|
|








|
<

>










|
|
|





|








|
|
|



|

|
|

>




>

|
<
|


>
|
>
>
|
|
|






|
|
|
<
|
>



>

>
|
|
|
|
>





|
|
|

>



|
|
|
|
|
|










|
|







|







|



>
|
>
>
|






|
|
|

>


|

|
|
|
|
<
|
|
|


















|








>









|
|
|
|

>


|
|



|
|
>
|
>
>

|









|


|
>
|
>
>


|

>


|
|
<


>
|
>
>

|

>
|
>
>



>




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|

|
|
|
|
|
|
|
|
|

|
|
|


>
|

|
|
|
|
|


|
|
|
|



>
|
>





>
|
>
|
|



>
|
>




|

<
|

|

|

|

|
<



|
|
>
|
>
>

>



|





|
<
|
<
|
<
|
<
|
<
<

<
|

<
>
>
|
>











|
|














|
|
|







830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858

859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916

917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946

947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994

995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013

1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100

1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187

1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324

1325
1326
1327
1328
1329
1330
1331
1332
1333

1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354

1355

1356

1357

1358


1359

1360
1361

1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
    /*
     * Under Windows we ignore argv0, and return the path for the file used to
     * create this process.
     */

    if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) {
	GetModuleFileNameA(NULL, name, sizeof(name));

	/*
	 * Convert to WCHAR to get out of ANSI codepage
	 */

	MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH);
    }

    WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
    TclWinNoBackslash(name);
    TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a directory for
 *	all files which match a given pattern.
 *
 * Results:

 *	The return value is a standard Tcl result indicating whether an error
 *	occurred in globbing. Errors are left in interp, good results are
 *	lappended to resultPtr (which must be a valid object).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive errors. */
    Tcl_Obj *resultPtr;		/* List object to lappend results. */
    Tcl_Obj *pathPtr;		/* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    CONST TCHAR *native;

    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
	/*
	 * The native filesystem never adds mounts.
	 */

	return TCL_OK;
    }

    if (pattern == NULL || (*pattern == '\0')) {
	Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (norm != NULL) {
	    /*
	     * Match a single file directly.
	     */

	    int len;
	    DWORD attr;
	    CONST char *str = Tcl_GetStringFromObj(norm,&len);

	    native = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);

	    if (tclWinProcs->getFileAttributesExProc == NULL) {
		attr = (*tclWinProcs->getFileAttributesProc)(native);
		if (attr == 0xffffffff) {
		    return TCL_OK;
		}
	    } else {
		WIN32_FILE_ATTRIBUTE_DATA data;
		if ((*tclWinProcs->getFileAttributesExProc)(native,
			GetFileExInfoStandard, &data) != TRUE) {
		    return TCL_OK;
		}
		attr = data.dwFileAttributes;
	    }

	    if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) {

		Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
	    }
	}
	return TCL_OK;
    } else {
	DWORD attr;
	HANDLE handle;
	WIN32_FIND_DATAT data;
	CONST char *dirName;	/* UTF-8 dir name, later with pattern
				 * appended. */
	int dirLength;
	int matchSpecialDots;
	Tcl_DString ds;		/* Native encoding of dir, also used
				 * temporarily for other things. */
	Tcl_DString dsOrig;	/* UTF-8 encoding of dir. */
	Tcl_Obj *fileNamePtr;
	char lastChar;

	/*
	 * Get the normalized path representation (the main thing is we dont
	 * want any '~' sequences).
	 */

	fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
	if (fileNamePtr == NULL) {
	    return TCL_ERROR;
	}

	/*
	 * Verify that the specified path exists and is actually a directory.

	 */

	native = Tcl_FSGetNativePath(pathPtr);
	if (native == NULL) {
	    return TCL_OK;
	}
	attr = (*tclWinProcs->getFileAttributesProc)(native);

	if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
	    return TCL_OK;
	}

	/*
	 * Build up the directory name for searching, including a trailing
	 * directory separator.
	 */

	Tcl_DStringInit(&dsOrig);
	dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
	Tcl_DStringAppend(&dsOrig, dirName, dirLength);

	lastChar = dirName[dirLength -1];
	if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
	    Tcl_DStringAppend(&dsOrig, "/", 1);
	    dirLength++;
	}
	dirName = Tcl_DStringValue(&dsOrig);

	/*
	 * We need to check all files in the directory, so we append '*.*' to
	 * the path, unless the pattern we've been given is rather simple,
	 * when we can use that instead.
	 */

	if (strpbrk(pattern, "[]\\") == NULL) {
	    /*
	     * The pattern is a simple one containing just '*' and/or '?'.
	     * This means we can get the OS to help us, by passing it the
	     * pattern.
	     */

	    dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
	} else {
	    dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3);
	}

	native = Tcl_WinUtfToTChar(dirName, -1, &ds);
	if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL)

		|| (types->type != TCL_GLOB_TYPE_DIR)) {
	    handle = (*tclWinProcs->findFirstFileProc)(native, &data);
	} else {
	    /*
	     * We can be more efficient, for pure directory requests.
	     */

	    handle = (*tclWinProcs->findFirstFileExProc)(native,
		    FindExInfoStandard, &data,
		    FindExSearchLimitToDirectories, NULL, 0);
	}

	if (handle == INVALID_HANDLE_VALUE) {
	    DWORD err = GetLastError();
	    Tcl_DStringFree(&ds);
	    if (err == ERROR_FILE_NOT_FOUND) {
		/*
		 * We used our 'pattern' above, and matched nothing. This
		 * means we just return TCL_OK, indicating no results found.

		 */

		Tcl_DStringFree(&dsOrig);
		return TCL_OK;
	    }

	    TclWinConvertError(err);
	    if (interp != NULL) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "couldn't read directory \"",
			Tcl_DStringValue(&dsOrig), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
	    }
	    Tcl_DStringFree(&dsOrig);
	    return TCL_ERROR;
	}
	Tcl_DStringFree(&ds);

	/*
	 * We may use this later, so we must restore it to its length
	 * including the directory delimiter.
	 */

	Tcl_DStringSetLength(&dsOrig, dirLength);

	/*
	 * Check to see if the pattern should match the special . and
	 * .. names, referring to the current directory, or the directory
	 * above. We need a special check for this because paths beginning
	 * with a dot are not considered hidden on Windows, and so otherwise a
	 * relative glob like 'glob -join * *' will actually return
	 * './. ../..' etc.
	 */

	if ((pattern[0] == '.')
		|| ((pattern[0] == '\\') && (pattern[1] == '.'))) {
	    matchSpecialDots = 1;
	} else {
	    matchSpecialDots = 0;
	}

	/*
	 * Now iterate over all of the files in the directory, starting with
	 * the first one we found.
	 */

	do {
	    CONST char *utfname;
	    int checkDrive = 0;
	    int isDrive;
	    DWORD attr;

	    if (tclWinProcs->useWide) {
		native = (CONST TCHAR *) data.w.cFileName;
		attr = data.w.dwFileAttributes;
	    } else {
		native = (CONST TCHAR *) data.a.cFileName;
		attr = data.a.dwFileAttributes;
	    }

	    utfname = Tcl_WinTCharToUtf(native, -1, &ds);

	    if (!matchSpecialDots) {
		/*
		 * If it is exactly '.' or '..' then we ignore it.
		 */

		if ((utfname[0] == '.') && (utfname[1] == '\0'
			|| (utfname[1] == '.' && utfname[2] == '\0'))) {
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    } else if (utfname[0] == '.' && utfname[1] == '.'
		    && utfname[2] == '\0') {
		/*
		 * Have to check if this is a drive below, so we can correctly
		 * match 'hidden' and not hidden files.
		 */

		checkDrive = 1;
	    }

	    /*
	     * Check to see if the file matches the pattern. Note that we are
	     * ignoring the case sensitivity flag because Windows doesn't
	     * honor case even if the volume is case sensitive. If the volume
	     * also doesn't preserve case, then we previously returned the

	     * lower case form of the name. This didn't seem quite right since
	     * there are non-case-preserving volumes that actually return
	     * mixed case. So now we are returning exactly what we get from
	     * the system.
	     */

	    if (Tcl_StringCaseMatch(utfname, pattern, 1)) {
		/*
		 * If the file matches, then we need to process the remainder
		 * of the path.
		 */

		if (checkDrive) {
		    CONST char *fullname = Tcl_DStringAppend(&dsOrig, utfname,
			    Tcl_DStringLength(&ds));
		    isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig));
		    Tcl_DStringSetLength(&dsOrig, dirLength);
		} else {
		    isDrive = 0;
		}
		if (NativeMatchType(isDrive, attr, native, types)) {
		    Tcl_ListObjAppendElement(interp, resultPtr,
			    TclNewFSPathObj(pathPtr, utfname,
				    Tcl_DStringLength(&ds)));
		}
	    }

	    /*
	     * Free ds here to ensure that native is valid above.
	     */

	    Tcl_DStringFree(&ds);
	} while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE);

	FindClose(handle);
	Tcl_DStringFree(&dsOrig);
	return TCL_OK;
    }
}

/*
 * Does the given path represent a root volume? We need this special case
 * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden'
 * attribute when it should not.
 */

static int
WinIsDrive(
    CONST char *name,		/* Name (UTF-8) */
    int len)			/* Length of name */
{
    int remove = 0;
    while (len > 4) {
	if ((name[len-1] != '.' || name[len-2] != '.')
		|| (name[len-3] != '/' && name[len-3] != '\\')) {
	    /*
	     * We don't have '/..' at the end.
	     */

	    if (remove == 0) {
		break;
	    }
	    remove--;
	    while (len > 0) {
		len--;
		if (name[len] == '/' || name[len] == '\\') {
		    break;
		}
	    }
	    if (len < 4) {
		len++;
		break;
	    }
	} else {
	    /*
	     * We do have '/..'
	     */

	    len -= 3;
	    remove++;
	}
    }

    if (len < 4) {
	if (len == 0) {
	    /*
	     * Not sure if this is possible, but we pass it on anyway.

	     */
	} else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {
	    /*
	     * Path is pointing to the root volume.
	     */

	    return 1;
	} else if ((name[1] == ':')
		   && (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
	    /*
	     * Path is of the form 'x:' or 'x:/' or 'x:\'
	     */

	    return 1;
	}
    }

    return 0;
}

/*
 * Does the given path represent a reserved window path name? If not return 0,
 * if true, return the number of characters of the path that we actually want
 * (not any trailing :).
 */

static int WinIsReserved(
   CONST char *path)		/* Path in UTF-8 */
{
    if ((path[0] == 'c' || path[0] == 'C')
	    && (path[1] == 'o' || path[1] == 'O')) {
	if ((path[2] == 'm' || path[2] == 'M')
		&& path[3] >= '1' && path[3] <= '4') {
	    /*
	     * May have match for 'com[1-4]:?', which is a serial port.
	     */

	    if (path[4] == '\0') {
		return 4;
	    } else if (path [4] == ':' && path[5] == '\0') {
		return 4;
	    }
	} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
	    /*
	     * Have match for 'con'
	     */

	    return 3;
	}

    } else if ((path[0] == 'l' || path[0] == 'L')
	    && (path[1] == 'p' || path[1] == 'P')
	    && (path[2] == 't' || path[2] == 'T')) {
	if (path[3] >= '1' && path[3] <= '3') {
	    /*
	     * May have match for 'lpt[1-3]:?'
	     */

	    if (path[4] == '\0') {
		return 4;
	    } else if (path [4] == ':' && path[5] == '\0') {
		return 4;
	    }
	}

    } else if (!stricmp(path, "prn") || !stricmp(path, "nul")
	    || !stricmp(path, "aux")) {
	/*
	 * Have match for 'prn', 'nul' or 'aux'.
	 */

	return 3;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeMatchType --
 *
 *	This function needs a special case for a path which is a root volume,
 *	because for NTFS root volumes, the getFileAttributesProc returns a
 *	'hidden' attribute when it should not.
 *
 *	We never make any calss to a 'get attributes' routine here, since we
 *	have arranged things so that our caller already knows such
 *	information.
 *
 * Results:
 *	0 = file doesn't match
 *	1 = file matches
 *
 *----------------------------------------------------------------------
 */

static int
NativeMatchType(
    int isDrive,		/* Is this a drive. */
    DWORD attr,			/* We already know the attributes for the
				 * file. */
    CONST TCHAR *nativeName,	/* Native path to check. */
    Tcl_GlobTypeData *types)	/* Type description to match against. */
{
    /*
     * 'attr' represents the attributes of the file, but we only want to
     * retrieve this info if it is absolutely necessary because it is an
     * expensive call. Unfortunately, to deal with hidden files properly, we
     * must always retrieve it.
     */

    if (types == NULL) {
	/*
	 * If invisible, don't return the file.
	 */
	if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
	    return 0;
	}
    } else {
	if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
	    /*
	     * If invisible.
	     */

	    if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
		return 0;
	    }
	} else {
	    /*
	     * Visible.
	     */
	    if (types->perm & TCL_GLOB_PERM_HIDDEN) {
		return 0;
	    }
	}

	if (types->perm != 0) {

	    if (((types->perm & TCL_GLOB_PERM_RONLY) &&
			!(attr & FILE_ATTRIBUTE_READONLY)) ||
		    ((types->perm & TCL_GLOB_PERM_R) &&
			(0 /* File exists => R_OK on Windows */)) ||
		    ((types->perm & TCL_GLOB_PERM_W) &&
			(attr & FILE_ATTRIBUTE_READONLY)) ||
		    ((types->perm & TCL_GLOB_PERM_X) &&
			(!(attr & FILE_ATTRIBUTE_DIRECTORY)
			 && !NativeIsExec(nativeName)))) {

		return 0;
	    }
	}
	if ((types->type & TCL_GLOB_TYPE_DIR)
		&& (attr & FILE_ATTRIBUTE_DIRECTORY)) {
	    /*
	     * Quicker test for directory, which is a common case.
	     */

	    return 1;

	} else if (types->type != 0) {
	    unsigned short st_mode;
	    int isExec = NativeIsExec(nativeName);

	    st_mode = NativeStatMode(attr, 0, isExec);

	    /*
	     * In order bcdpfls as in 'find -t'
	     */


	    if (((types->type&TCL_GLOB_TYPE_BLOCK)    && S_ISBLK(st_mode)) ||

		    ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||

		    ((types->type&TCL_GLOB_TYPE_DIR)  && S_ISDIR(st_mode)) ||

		    ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||


#ifdef S_ISSOCK

		    ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
#endif

		    ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
		/*
		 * Do nothing - this file is ok.
		 */
	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    st_mode = NativeStatMode(attr, 1, isExec);
		    if (S_ISLNK(st_mode)) {
			return 1;
		    }
		}
#endif
		return 0;
	    }
	}
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *
 *	This function takes the passed in user name and finds the
 *	corresponding home directory specified in the password file.
 *
 * Results:
 *	The result is a pointer to a string specifying the user's home
 *	directory, or NULL if the user's home directory could not be
 *	determined. Storage for the result string is allocated in bufferPtr;
 *	the caller must call Tcl_DStringFree() when the result is no longer
 *	needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
    if (netapiInst != NULL) {
	NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
	NETGETDCNAMEPROC *netGetDCNameProc;
	NETUSERGETINFOPROC *netUserGetInfoProc;

	netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
		GetProcAddress(netapiInst, "NetApiBufferFree");
	netGetDCNameProc = (NETGETDCNAMEPROC *) 
		GetProcAddress(netapiInst, "NetGetDCName");
	netUserGetInfoProc = (NETUSERGETINFOPROC *) 
		GetProcAddress(netapiInst, "NetUserGetInfo");
	if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
		&& (netApiBufferFreeProc != NULL)) {
	    USER_INFO_1 *uiPtr;
	    Tcl_DString ds;
	    int nameLen, badDomain;
	    char *domain;







|

|







1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
    if (netapiInst != NULL) {
	NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
	NETGETDCNAMEPROC *netGetDCNameProc;
	NETUSERGETINFOPROC *netUserGetInfoProc;

	netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
		GetProcAddress(netapiInst, "NetApiBufferFree");
	netGetDCNameProc = (NETGETDCNAMEPROC *)
		GetProcAddress(netapiInst, "NetGetDCName");
	netUserGetInfoProc = (NETUSERGETINFOPROC *)
		GetProcAddress(netapiInst, "NetUserGetInfo");
	if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
		&& (netApiBufferFreeProc != NULL)) {
	    USER_INFO_1 *uiPtr;
	    Tcl_DString ds;
	    int nameLen, badDomain;
	    char *domain;
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319

1320
1321
1322
1323
1324
1325
1326
1327
1328
1329

1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362

1363
1364
1365
1366
1367
1368
1369
1370

1371
1372
1373
1374
1375
1376

1377
1378
1379
1380
1381
1382
1383

1384
1385
1386
1387
1388
1389
1390
1391
1392

1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426

1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440

1441
1442
1443
1444
1445
1446

1447
1448
1449
1450
1451
1452
1453
1454
1455
1456

1457
1458
1459

1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483

1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505

1506
1507
1508
1509
1510
1511
1512
1513

1514

1515
1516
1517
1518

1519
1520
1521
1522

1523
1524
1525
1526
1527
1528
1529
		if ((*netUserGetInfoProc)(wDomain, wName, 1,
			(LPBYTE *) &uiPtr) == 0) {
		    wHomeDir = uiPtr->usri1_home_dir;
		    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
			Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
				bufferPtr);
		    } else {
			/* 
			 * User exists but has no home dir.  Return
			 * "{Windows Drive}:/users/default".
			 */

			GetWindowsDirectoryW(buf, MAX_PATH);
			Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
			Tcl_DStringAppend(bufferPtr, "/users/default", -1);
		    }
		    result = Tcl_DStringValue(bufferPtr);
		    (*netApiBufferFreeProc)((void *) uiPtr);
		}
		Tcl_DStringFree(&ds);
	    }
	    if (wDomain != NULL) {
		(*netApiBufferFreeProc)((void *) wDomain);
	    }
	}
	FreeLibrary(netapiInst);
    }
    if (result == NULL) {
	/*
	 * Look in the "Password Lists" section of system.ini for the 
	 * local user.  There are also entries in that section that begin 
	 * with a "*" character that are used by Windows for other 
	 * purposes; ignore user names beginning with a "*".
	 */

	char buf[MAX_PATH];

	if (name[0] != '*') {
	    if (GetPrivateProfileStringA("Password Lists", name, "", buf, 
		    MAX_PATH, "system.ini") > 0) {
		/* 
		 * User exists, but there is no such thing as a home 
		 * directory in system.ini.  Return "{Windows drive}:/".
		 */

		GetWindowsDirectoryA(buf, MAX_PATH);
		Tcl_DStringAppend(bufferPtr, buf, 3);
		result = Tcl_DStringValue(bufferPtr);
	    }
	}
    }

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeAccess --
 *
 *	This function replaces the library version of access(), fixing the
 *	following bugs:
 * 
 *	1. access() returns that all files have execute permission.
 *
 * Results:
 *	See access documentation.
 *
 * Side effects:
 *	See access documentation.
 *
 *---------------------------------------------------------------------------
 */

static int
NativeAccess(nativePath, mode)
    CONST TCHAR *nativePath;	/* Path of file to access, native
                            	 * encoding. */
    int mode;			/* Permission setting. */
{
    DWORD attr;

    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);

    if (attr == 0xffffffff) {
	/*
	 * File doesn't exist. 
	 */

	TclWinConvertError(GetLastError());
	return -1;
    }

    if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	/*
	 * File is not writable.
	 */

	Tcl_SetErrno(EACCES);
	return -1;
    }

    if (mode & X_OK) {
	if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) {
	    /*
	     * It's not a directory and doesn't have the correct
	     * extension.  Therefore it can't be executable
	     */

	    Tcl_SetErrno(EACCES);
	    return -1;
	}
    }

    /* 
     * It looks as if the permissions are ok, but if we are on NT, 2000
     * or XP, we have a more complex permissions structure so we try to
     * check that.  The code below is remarkably complex for such a 
     * simple thing as finding what permissions the OS has set for a
     * file.
     * 
     * If we are simply checking for file existence, then we don't
     * need all these complications (which are really quite slow: 
     * with this code 'file readable' is 5-6 times slower than 'file
     * exists').
     */
    
    if ((mode != F_OK) && (tclWinProcs->getFileSecurityProc != NULL)) {
	SECURITY_DESCRIPTOR *sdPtr = NULL;
	unsigned long size;
	GENERIC_MAPPING genMap;
	HANDLE hToken = NULL;
	DWORD desiredAccess = 0;
	DWORD grantedAccess;
	BOOL accessYesNo;
	PRIVILEGE_SET privSet;
	DWORD privSetSize = sizeof(PRIVILEGE_SET);
	int error;
	
	/* 
	 * First find out how big the buffer needs to be 
	 */

	size = 0;
	(*tclWinProcs->getFileSecurityProc)(nativePath, 
		OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION 
		| DACL_SECURITY_INFORMATION, 0, 0, &size);

	/* 
	 * Should have failed with ERROR_INSUFFICIENT_BUFFER 
	 */

	error = GetLastError();
	if (error != ERROR_INSUFFICIENT_BUFFER) {
	    /* 
	     * Most likely case is ERROR_ACCESS_DENIED, which
	     * we will convert to EACCES - just what we want! 
	     */

	    TclWinConvertError(error);
	    return -1;
	}

	/* 
	 * Now size contains the size of buffer needed 
	 */

	sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);

	if (sdPtr == NULL) {
	    goto accessError;
	}

	/* 
	 * Call GetFileSecurity() for real 
	 */

	if (!(*tclWinProcs->getFileSecurityProc)(nativePath, 
		OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION 
		| DACL_SECURITY_INFORMATION, sdPtr, size, &size)) {
	    /* 
	     * Error getting owner SD
	     */
	    goto accessError;
	}

	/* 
	 * Perform security impersonation of the user and open the
	 * resulting thread token.
	 */
	if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) {
	    /* 
	     * Unable to perform security impersonation. 
	     */
	    goto accessError;
	}
	if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (), 
			TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) {
	    /* 
	     * Unable to get current thread's token. 
	     */
	    goto accessError;
	}
	(*tclWinProcs->revertToSelfProc)();
	
	memset (&genMap, 0x00, sizeof (GENERIC_MAPPING));
	
	/* 
	 * Setup desiredAccess according to the access priveleges we
	 * are checking.
	 */

	genMap.GenericAll = 0;
	if (mode & R_OK) {
	    desiredAccess |= FILE_GENERIC_READ;
	}
	if (mode & W_OK) {
	    desiredAccess |= FILE_GENERIC_WRITE;
	}
	if (mode & X_OK) {
	    desiredAccess |= FILE_GENERIC_EXECUTE;
	}

	/* 
	 * Perform access check using the token. 
	 */

	if (!(*tclWinProcs->accessCheckProc )(sdPtr, hToken, desiredAccess, 
		&genMap, &privSet, &privSetSize, &grantedAccess,
		&accessYesNo)) {
	    /* 
	     * Unable to perform access check. 
	     */

	  accessError:
	    TclWinConvertError(GetLastError());
	    if (sdPtr != NULL) {
	        HeapFree(GetProcessHeap(), 0, sdPtr);
	    }
	    if (hToken != NULL) {
	        CloseHandle(hToken);
	    }
	    return -1;
	}

	/* 
	 * Clean up. 
	 */

	HeapFree(GetProcessHeap (), 0, sdPtr);
	CloseHandle(hToken);
	if (!accessYesNo) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeIsExec --
 *
 *	Determines if a path is executable.  On windows this is 
 *	simply defined by whether the path ends in any of ".exe",
 *	".com", or ".bat"
 *
 * Results:
 *	1 = executable, 0 = not.
 *
 *----------------------------------------------------------------------
 */

static int
NativeIsExec(nativePath)
    CONST TCHAR *nativePath;
{
    if (tclWinProcs->useWide) {
	CONST WCHAR *path;
	int len;
	
	path = (CONST WCHAR*)nativePath;
	len = wcslen(path);
	
	if (len < 5) {
	    return 0;
	}
	
	if (path[len-4] != L'.') {
	    return 0;
	}
	
	/*
	 * Use wide-char case-insensitive comparison
	 */

	if ((_wcsicmp(path+len-3,L"exe") == 0)
	    || (_wcsicmp(path+len-3,L"com") == 0)
	    || (_wcsicmp(path+len-3,L"bat") == 0)) {
	    return 1;
	}
    } else {
	CONST char *p;
	

	/* We are only looking for pure ascii */

	
	p = strrchr((CONST char*)nativePath, '.');
	if (p != NULL) {
	    p++;

	    /* 
	     * Note: in the old code, stat considered '.pif' files as
	     * executable, whereas access did not.
	     */

	    if ((stricmp(p, "exe") == 0)
		    || (stricmp(p, "com") == 0)
		    || (stricmp(p, "bat") == 0)) {
		/*
		 * File that ends with .exe, .com, or .bat is executable.
		 */








|
|




















|
|
|
|





|

|
|
|



















|













|
<








|










>







|
|

>





|
|
|
|
|
<
|
|
|
|
<

|











|
|
|

>

|
|


|
|

>


|
|
|

>




|
|

>






|
|

>
|
|

|





|




|
|



|

|
|




|

|
|
|
|

>











|
|

>
|


|
|

>
|


|


|



>
|
|

>















|
|
<






>







|


|



|



|



>

|
|




|
>
|
>
|



>
|



>







1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528

1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569

1570
1571
1572
1573

1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714

1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
		if ((*netUserGetInfoProc)(wDomain, wName, 1,
			(LPBYTE *) &uiPtr) == 0) {
		    wHomeDir = uiPtr->usri1_home_dir;
		    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
			Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
				bufferPtr);
		    } else {
			/*
			 * User exists but has no home dir. Return
			 * "{Windows Drive}:/users/default".
			 */

			GetWindowsDirectoryW(buf, MAX_PATH);
			Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
			Tcl_DStringAppend(bufferPtr, "/users/default", -1);
		    }
		    result = Tcl_DStringValue(bufferPtr);
		    (*netApiBufferFreeProc)((void *) uiPtr);
		}
		Tcl_DStringFree(&ds);
	    }
	    if (wDomain != NULL) {
		(*netApiBufferFreeProc)((void *) wDomain);
	    }
	}
	FreeLibrary(netapiInst);
    }
    if (result == NULL) {
	/*
	 * Look in the "Password Lists" section of system.ini for the local
	 * user. There are also entries in that section that begin with a "*"
	 * character that are used by Windows for other purposes; ignore user
	 * names beginning with a "*".
	 */

	char buf[MAX_PATH];

	if (name[0] != '*') {
	    if (GetPrivateProfileStringA("Password Lists", name, "", buf,
		    MAX_PATH, "system.ini") > 0) {
		/*
		 * User exists, but there is no such thing as a home directory
		 * in system.ini. Return "{Windows drive}:/".
		 */

		GetWindowsDirectoryA(buf, MAX_PATH);
		Tcl_DStringAppend(bufferPtr, buf, 3);
		result = Tcl_DStringValue(bufferPtr);
	    }
	}
    }

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeAccess --
 *
 *	This function replaces the library version of access(), fixing the
 *	following bugs:
 *
 *	1. access() returns that all files have execute permission.
 *
 * Results:
 *	See access documentation.
 *
 * Side effects:
 *	See access documentation.
 *
 *---------------------------------------------------------------------------
 */

static int
NativeAccess(nativePath, mode)
    CONST TCHAR *nativePath;	/* Path of file to access, native encoding. */

    int mode;			/* Permission setting. */
{
    DWORD attr;

    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);

    if (attr == 0xffffffff) {
	/*
	 * File doesn't exist.
	 */

	TclWinConvertError(GetLastError());
	return -1;
    }

    if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	/*
	 * File is not writable.
	 */

	Tcl_SetErrno(EACCES);
	return -1;
    }

    if (mode & X_OK) {
	if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) {
	    /*
	     * It's not a directory and doesn't have the correct extension.
	     * Therefore it can't be executable
	     */

	    Tcl_SetErrno(EACCES);
	    return -1;
	}
    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.

     *
     * If we are simply checking for file existence, then we don't need all
     * these complications (which are really quite slow: with this code 'file
     * readable' is 5-6 times slower than 'file exists').

     */

    if ((mode != F_OK) && (tclWinProcs->getFileSecurityProc != NULL)) {
	SECURITY_DESCRIPTOR *sdPtr = NULL;
	unsigned long size;
	GENERIC_MAPPING genMap;
	HANDLE hToken = NULL;
	DWORD desiredAccess = 0;
	DWORD grantedAccess;
	BOOL accessYesNo;
	PRIVILEGE_SET privSet;
	DWORD privSetSize = sizeof(PRIVILEGE_SET);
	int error;

	/*
	 * First find out how big the buffer needs to be
	 */

	size = 0;
	(*tclWinProcs->getFileSecurityProc)(nativePath,
		OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
		| DACL_SECURITY_INFORMATION, 0, 0, &size);

	/*
	 * Should have failed with ERROR_INSUFFICIENT_BUFFER
	 */

	error = GetLastError();
	if (error != ERROR_INSUFFICIENT_BUFFER) {
	    /*
	     * Most likely case is ERROR_ACCESS_DENIED, which we will convert
	     * to EACCES - just what we want!
	     */

	    TclWinConvertError(error);
	    return -1;
	}

	/*
	 * Now size contains the size of buffer needed
	 */

	sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);

	if (sdPtr == NULL) {
	    goto accessError;
	}

	/*
	 * Call GetFileSecurity() for real
	 */

	if (!(*tclWinProcs->getFileSecurityProc)(nativePath,
		OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
		| DACL_SECURITY_INFORMATION, sdPtr, size, &size)) {
	    /*
	     * Error getting owner SD
	     */
	    goto accessError;
	}

	/*
	 * Perform security impersonation of the user and open the
	 * resulting thread token.
	 */
	if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) {
	    /*
	     * Unable to perform security impersonation.
	     */
	    goto accessError;
	}
	if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (),
			TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) {
	    /*
	     * Unable to get current thread's token.
	     */
	    goto accessError;
	}
	(*tclWinProcs->revertToSelfProc)();

	memset (&genMap, 0x00, sizeof (GENERIC_MAPPING));

	/*
	 * Setup desiredAccess according to the access priveleges we are
	 * checking.
	 */

	genMap.GenericAll = 0;
	if (mode & R_OK) {
	    desiredAccess |= FILE_GENERIC_READ;
	}
	if (mode & W_OK) {
	    desiredAccess |= FILE_GENERIC_WRITE;
	}
	if (mode & X_OK) {
	    desiredAccess |= FILE_GENERIC_EXECUTE;
	}

	/*
	 * Perform access check using the token.
	 */

	if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess,
		&genMap, &privSet, &privSetSize, &grantedAccess,
		&accessYesNo)) {
	    /*
	     * Unable to perform access check.
	     */

	accessError:
	    TclWinConvertError(GetLastError());
	    if (sdPtr != NULL) {
		HeapFree(GetProcessHeap(), 0, sdPtr);
	    }
	    if (hToken != NULL) {
		CloseHandle(hToken);
	    }
	    return -1;
	}

	/*
	 * Clean up.
	 */

	HeapFree(GetProcessHeap (), 0, sdPtr);
	CloseHandle(hToken);
	if (!accessYesNo) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeIsExec --
 *
 *	Determines if a path is executable. On windows this is simply defined
 *	by whether the path ends in any of ".exe", ".com", or ".bat"

 *
 * Results:
 *	1 = executable, 0 = not.
 *
 *----------------------------------------------------------------------
 */

static int
NativeIsExec(nativePath)
    CONST TCHAR *nativePath;
{
    if (tclWinProcs->useWide) {
	CONST WCHAR *path;
	int len;

	path = (CONST WCHAR*)nativePath;
	len = wcslen(path);

	if (len < 5) {
	    return 0;
	}

	if (path[len-4] != L'.') {
	    return 0;
	}

	/*
	 * Use wide-char case-insensitive comparison
	 */

	if ((_wcsicmp(path+len-3,L"exe") == 0)
		|| (_wcsicmp(path+len-3,L"com") == 0)
		|| (_wcsicmp(path+len-3,L"bat") == 0)) {
	    return 1;
	}
    } else {
	CONST char *p;

	/*
	 * We are only looking for pure ascii.
	 */

	p = strrchr((CONST char*)nativePath, '.');
	if (p != NULL) {
	    p++;

	    /*
	     * Note: in the old code, stat considered '.pif' files as
	     * executable, whereas access did not.
	     */

	    if ((stricmp(p, "exe") == 0)
		    || (stricmp(p, "com") == 0)
		    || (stricmp(p, "bat") == 0)) {
		/*
		 * File that ends with .exe, .com, or .bat is executable.
		 */

1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567

1568

1569


1570
1571
1572
1573
1574
1575
1576
 *
 *	This function replaces the library version of chdir().
 *
 * Results:
 *	See chdir() documentation.
 *
 * Side effects:
 *	See chdir() documentation.  
 *
 *----------------------------------------------------------------------
 */

int 
TclpObjChdir(pathPtr)
    Tcl_Obj *pathPtr; 	/* Path to new working directory. */
{
    int result;
    CONST TCHAR *nativePath;
#ifdef __CYGWIN__
    extern int cygwin_conv_to_posix_path 
	_ANSI_ARGS_((CONST char *, char *));
    char posixPath[MAX_PATH+1];
    CONST char *path;
    Tcl_DString ds;
#endif /* __CYGWIN__ */

    nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);

#ifdef __CYGWIN__

    /* Cygwin chdir only groks POSIX path. */


    path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
    cygwin_conv_to_posix_path(path, posixPath);
    result = (chdir(posixPath) == 0 ? 1 : 0);
    Tcl_DStringFree(&ds);
#else /* __CYGWIN__ */
    result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
#endif /* __CYGWIN__ */







|




|

|




|
<






>

>
|
>
>







1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803

1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
 *
 *	This function replaces the library version of chdir().
 *
 * Results:
 *	See chdir() documentation.
 *
 * Side effects:
 *	See chdir() documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclpObjChdir(pathPtr)
    Tcl_Obj *pathPtr;	/* Path to new working directory. */
{
    int result;
    CONST TCHAR *nativePath;
#ifdef __CYGWIN__
    extern int cygwin_conv_to_posix_path(CONST char *, char *);

    char posixPath[MAX_PATH+1];
    CONST char *path;
    Tcl_DString ds;
#endif /* __CYGWIN__ */

    nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);

#ifdef __CYGWIN__
    /*
     * Cygwin chdir only groks POSIX path.
     */

    path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
    cygwin_conv_to_posix_path(path, posixPath);
    result = (chdir(posixPath) == 0 ? 1 : 0);
    Tcl_DStringFree(&ds);
#else /* __CYGWIN__ */
    result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
#endif /* __CYGWIN__ */
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714

1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783

1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840

1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864

1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901

1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950

1951
1952
1953
1954
1955

1956

1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975

#ifdef __CYGWIN__
/*
 *---------------------------------------------------------------------------
 *
 * TclpReadlink --
 *
 *     This function replaces the library version of readlink().
 *
 * Results:
 *     The result is a pointer to a string specifying the contents
 *     of the symbolic link given by 'path', or NULL if the symbolic
 *     link could not be read.  Storage for the result string is
 *     allocated in bufferPtr; the caller must call Tcl_DStringFree()
 *     when the result is no longer needed.
 *
 * Side effects:
 *     See readlink() documentation.
 *
 *---------------------------------------------------------------------------
 */

char *
TclpReadlink(path, linkPtr)
    CONST char *path;          /* Path of file to readlink (UTF-8). */
    Tcl_DString *linkPtr;      /* Uninitialized or free DString filled
                                * with contents of link (UTF-8). */
{
    char link[MAXPATHLEN];
    int length;
    char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
    length = readlink(native, link, sizeof(link));     /* INTL: Native. */
    Tcl_DStringFree(&ds);
    
    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
}
#endif /* __CYGWIN__ */

/*
 *----------------------------------------------------------------------
 *
 * TclpGetCwd --
 *
 *	This function replaces the library version of getcwd().
 *      (Obsolete function, only retained for old extensions which
 *      may call it directly).
 *
 * Results:
 *	The result is a pointer to a string specifying the current
 *	directory, or NULL if the current directory could not be
 *	determined.  If NULL is returned, an error message is left in the
 *	interp's result.  Storage for the result string is allocated in
 *	bufferPtr; the caller must call Tcl_DStringFree() when the result
 *	is no longer needed.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclpGetCwd(interp, bufferPtr)
    Tcl_Interp *interp;		/* If non-NULL, used for error reporting. */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled
				 * with name of current directory. */
{
    WCHAR buffer[MAX_PATH];
    char *p;

    if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	if (interp != NULL) {
	    Tcl_AppendResult(interp,
		    "error getting working directory name: ",
		    Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }

    /*
     * Watch for the weird Windows c:\\UNC syntax.
     */

    if (tclWinProcs->useWide) {
	WCHAR *native;

	native = (WCHAR *) buffer;
	if ((native[0] != '\0') && (native[1] == ':') 
		&& (native[2] == '\\') && (native[3] == '\\')) {
	    native += 2;
	}
	Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
    } else {
	char *native;

	native = (char *) buffer;
	if ((native[0] != '\0') && (native[1] == ':') 
		&& (native[2] == '\\') && (native[3] == '\\')) {
	    native += 2;
	}
	Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
    }

    /*
     * Convert to forward slashes for easier use in scripts.
     */
	      
    for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
	if (*p == '\\') {
	    *p = '/';
	}
    }
    return Tcl_DStringValue(bufferPtr);
}

int 
TclpObjStat(pathPtr, statPtr)
    Tcl_Obj *pathPtr;          /* Path of file to stat */
    Tcl_StatBuf *statPtr;      /* Filled with results of stat call. */
{
#ifdef OLD_API
    Tcl_Obj *transPtr;

    /*
     * Eliminate file names containing wildcard characters, or subsequent 
     * call to FindFirstFile() will expand them, matching some other file.
     */

    transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
    if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) {
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
	Tcl_SetErrno(ENOENT);
	return -1;
    }
    Tcl_DecrRefCount(transPtr);
#endif
    
    /*
     * Ensure correct file sizes by forcing the OS to write any
     * pending data to disk. This is done only for channels which are
     * dirty, i.e. have been written to since the last flush here.
     */

    TclWinFlushDirtyChannels ();

    return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStat --
 *
 *	This function replaces the library version of stat(), fixing 
 *	the following bugs:
 *
 *	1. stat("c:") returns an error.
 *	2. Borland stat() return time in GMT instead of localtime.
 *	3. stat("\\server\mount") would return error.
 *	4. Accepts slashes or backslashes.
 *	5. st_dev and st_rdev were wrong for UNC paths.
 *
 * Results:
 *	See stat documentation.
 *
 * Side effects:
 *	See stat documentation.
 *
 *----------------------------------------------------------------------
 */

static int 
NativeStat(nativePath, statPtr, checkLinks)
    CONST TCHAR *nativePath;   /* Path of file to stat */
    Tcl_StatBuf *statPtr;      /* Filled with results of stat call. */
    int checkLinks;            /* If non-zero, behave like 'lstat' */
{
    Tcl_DString ds;
    DWORD attr;
    WCHAR nativeFullPath[MAX_PATH];
    TCHAR *nativePart;
    CONST char *fullPath;
    int dev;
    unsigned short mode;
    
    if (tclWinProcs->getFileAttributesExProc == NULL) {
        /* 
         * We don't have the faster attributes proc, so we're
         * probably running on Win95
         */

	WIN32_FIND_DATAT data;
	HANDLE handle;

	handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
	if (handle == INVALID_HANDLE_VALUE) {
	    /* 
	     * FindFirstFile() doesn't work on root directories, so call
	     * GetFileAttributes() to see if the specified file exists.
	     */

	    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	    if (attr == 0xffffffff) {
		Tcl_SetErrno(ENOENT);
		return -1;
	    }

	    /* 
	     * Make up some fake information for this file.  It has the 
	     * correct file attributes and a time of 0.
	     */

	    memset(&data, 0, sizeof(data));
	    data.a.dwFileAttributes = attr;
	} else {
	    FindClose(handle);
	}

    
	(*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
		&nativePart);

	fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);

	dev = -1;
	if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
	    CONST char *p;
	    DWORD dw;
	    CONST TCHAR *nativeVol;
	    Tcl_DString volString;

	    p = strchr(fullPath + 2, '\\');
	    p = strchr(p + 1, '\\');
	    if (p == NULL) {
		/*
		 * Add terminating backslash to fullpath or 
		 * GetVolumeInformation() won't work.
		 */

		fullPath = Tcl_DStringAppend(&ds, "\\", 1);
		p = fullPath + Tcl_DStringLength(&ds);
	    } else {
		p++;
	    }
	    nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
	    dw = (DWORD) -1;
	    (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
		    NULL, NULL, NULL, 0);

	    /*
	     * GetFullPathName() turns special devices like "NUL" into
	     * "\\.\NUL", but GetVolumeInformation() returns failure for
	     * "\\.\NUL".  This will cause "NUL" to get a drive number of
	     * -1, which makes about as much sense as anything since the
	     * special devices don't live on any drive.
	     */

	    dev = dw;
	    Tcl_DStringFree(&volString);
	} else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
	    dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
	}
	Tcl_DStringFree(&ds);
	
	attr = data.a.dwFileAttributes;

	statPtr->st_size  = ((Tcl_WideInt)data.a.nFileSizeLow) |
		(((Tcl_WideInt)data.a.nFileSizeHigh) << 32);
	statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
	statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
    } else {
	WIN32_FILE_ATTRIBUTE_DATA data;

	if((*tclWinProcs->getFileAttributesExProc)(nativePath,
						   GetFileExInfoStandard,
						   &data) != TRUE) {
	    Tcl_SetErrno(ENOENT);
	    return -1;
	}

    
	(*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, 
					    nativeFullPath, &nativePart);

	fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);

	dev = -1;
	if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
	    CONST char *p;
	    DWORD dw;
	    CONST TCHAR *nativeVol;
	    Tcl_DString volString;

	    p = strchr(fullPath + 2, '\\');
	    p = strchr(p + 1, '\\');
	    if (p == NULL) {
		/*
		 * Add terminating backslash to fullpath or 
		 * GetVolumeInformation() won't work.
		 */

		fullPath = Tcl_DStringAppend(&ds, "\\", 1);
		p = fullPath + Tcl_DStringLength(&ds);
	    } else {
		p++;
	    }
	    nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
	    dw = (DWORD) -1;
	    (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
		    NULL, NULL, NULL, 0);

	    /*
	     * GetFullPathName() turns special devices like "NUL" into
	     * "\\.\NUL", but GetVolumeInformation() returns failure for
	     * "\\.\NUL".  This will cause "NUL" to get a drive number of
	     * -1, which makes about as much sense as anything since the
	     * special devices don't live on any drive.
	     */

	    dev = dw;
	    Tcl_DStringFree(&volString);
	} else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
	    dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
	}
	Tcl_DStringFree(&ds);
	
	attr = data.dwFileAttributes;
	
	statPtr->st_size  = ((Tcl_WideInt)data.nFileSizeLow) |
		(((Tcl_WideInt)data.nFileSizeHigh) << 32);
	statPtr->st_atime = ToCTime(data.ftLastAccessTime);
	statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.ftCreationTime);
    }

    mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
    
    statPtr->st_dev	= (dev_t) dev;
    statPtr->st_ino	= 0;
    statPtr->st_mode	= mode;
    statPtr->st_nlink	= 1;
    statPtr->st_uid	= 0;
    statPtr->st_gid	= 0;
    statPtr->st_rdev	= (dev_t) dev;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStatMode --
 *
 *	Calculate just the 'st_mode' field of a 'stat' structure.
 *	
 *	In many places we don't need the full stat structure, and
 *	it's much faster just to calculate these pieces, if that's
 *	all we need.
 *
 *----------------------------------------------------------------------
 */

static unsigned short
NativeStatMode(DWORD attr, int checkLinks, int isExec) 
{
    int mode;
    if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {

	/* It is a link */

	mode = S_IFLNK;
    } else {
	mode  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
    }
    mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
    if (isExec) {
	mode |= S_IEXEC;
    }
    
    /*
     * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and 
     * other positions.
     */

    mode |= (mode & 0x0700) >> 3;
    mode |= (mode & 0x0700) >> 6;
    return (unsigned short)mode;
}








|


|
|
|
|
|


|






|
|
|







|

|














|
|
|


|
|
|
|
|
<










|
|







|
<













|








|









|








|

|
|



>

|
|












|

|
|
|


|









|
|
















|

|
|
|








|

|
|
|
|
>





|










|
|
|








<
|
|














|












>



|
|
|








|


|






>
|
|
<




<
|
|














|












>



|
|
|








|

|
|







|
















|
|
|
<



>

|



>
|
>


|





|

|
|







1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890

1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910

1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056

2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113

2114
2115
2116
2117

2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192

2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223

#ifdef __CYGWIN__
/*
 *---------------------------------------------------------------------------
 *
 * TclpReadlink --
 *
 *	This function replaces the library version of readlink().
 *
 * Results:
 *	The result is a pointer to a string specifying the contents of the
 *	symbolic link given by 'path', or NULL if the symbolic link could not
 *	be read. Storage for the result string is allocated in bufferPtr; the
 *	caller must call Tcl_DStringFree() when the result is no longer
 *	needed.
 *
 * Side effects:
 *	See readlink() documentation.
 *
 *---------------------------------------------------------------------------
 */

char *
TclpReadlink(path, linkPtr)
    CONST char *path;		/* Path of file to readlink (UTF-8). */
    Tcl_DString *linkPtr;	/* Uninitialized or free DString filled with
				 * contents of link (UTF-8). */
{
    char link[MAXPATHLEN];
    int length;
    char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
    length = readlink(native, link, sizeof(link));	/* INTL: Native. */
    Tcl_DStringFree(&ds);

    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
}
#endif /* __CYGWIN__ */

/*
 *----------------------------------------------------------------------
 *
 * TclpGetCwd --
 *
 *	This function replaces the library version of getcwd(). (Obsolete
 *	function, only retained for old extensions which may call it
 *	directly).
 *
 * Results:
 *	The result is a pointer to a string specifying the current directory,
 *	or NULL if the current directory could not be determined. If NULL is
 *	returned, an error message is left in the interp's result. Storage for
 *	the result string is allocated in bufferPtr; the caller must call
 *	Tcl_DStringFree() when the result is no longer needed.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
TclpGetCwd(interp, bufferPtr)
    Tcl_Interp *interp;		/* If non-NULL, used for error reporting. */
    Tcl_DString *bufferPtr;	/* Uninitialized or free DString filled with
				 * name of current directory. */
{
    WCHAR buffer[MAX_PATH];
    char *p;

    if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "error getting working directory name: ",

		    Tcl_PosixError(interp), (char *) NULL);
	}
	return NULL;
    }

    /*
     * Watch for the weird Windows c:\\UNC syntax.
     */

    if (tclWinProcs->useWide) {
	WCHAR *native;

	native = (WCHAR *) buffer;
	if ((native[0] != '\0') && (native[1] == ':')
		&& (native[2] == '\\') && (native[3] == '\\')) {
	    native += 2;
	}
	Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
    } else {
	char *native;

	native = (char *) buffer;
	if ((native[0] != '\0') && (native[1] == ':')
		&& (native[2] == '\\') && (native[3] == '\\')) {
	    native += 2;
	}
	Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
    }

    /*
     * Convert to forward slashes for easier use in scripts.
     */

    for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
	if (*p == '\\') {
	    *p = '/';
	}
    }
    return Tcl_DStringValue(bufferPtr);
}

int
TclpObjStat(pathPtr, statPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat. */
    Tcl_StatBuf *statPtr;	/* Filled with results of stat call. */
{
#ifdef OLD_API
    Tcl_Obj *transPtr;

    /*
     * Eliminate file names containing wildcard characters, or subsequent call
     * to FindFirstFile() will expand them, matching some other file.
     */

    transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
    if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) {
	if (transPtr != NULL) {
	    Tcl_DecrRefCount(transPtr);
	}
	Tcl_SetErrno(ENOENT);
	return -1;
    }
    Tcl_DecrRefCount(transPtr);
#endif

    /*
     * Ensure correct file sizes by forcing the OS to write any pending data
     * to disk. This is done only for channels which are dirty, i.e. have been
     * written to since the last flush here.
     */

    TclWinFlushDirtyChannels();

    return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStat --
 *
 *	This function replaces the library version of stat(), fixing the
 *	following bugs:
 *
 *	1. stat("c:") returns an error.
 *	2. Borland stat() return time in GMT instead of localtime.
 *	3. stat("\\server\mount") would return error.
 *	4. Accepts slashes or backslashes.
 *	5. st_dev and st_rdev were wrong for UNC paths.
 *
 * Results:
 *	See stat documentation.
 *
 * Side effects:
 *	See stat documentation.
 *
 *----------------------------------------------------------------------
 */

static int
NativeStat(nativePath, statPtr, checkLinks)
    CONST TCHAR *nativePath;	/* Path of file to stat */
    Tcl_StatBuf *statPtr;	/* Filled with results of stat call. */
    int checkLinks;		/* If non-zero, behave like 'lstat' */
{
    Tcl_DString ds;
    DWORD attr;
    WCHAR nativeFullPath[MAX_PATH];
    TCHAR *nativePart;
    CONST char *fullPath;
    int dev;
    unsigned short mode;

    if (tclWinProcs->getFileAttributesExProc == NULL) {
	/*
	 * We don't have the faster attributes proc, so we're probably running
	 * on Win95.
	 */

	WIN32_FIND_DATAT data;
	HANDLE handle;

	handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
	if (handle == INVALID_HANDLE_VALUE) {
	    /*
	     * FindFirstFile() doesn't work on root directories, so call
	     * GetFileAttributes() to see if the specified file exists.
	     */

	    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	    if (attr == 0xffffffff) {
		Tcl_SetErrno(ENOENT);
		return -1;
	    }

	    /*
	     * Make up some fake information for this file. It has the correct
	     * file attributes and a time of 0.
	     */

	    memset(&data, 0, sizeof(data));
	    data.a.dwFileAttributes = attr;
	} else {
	    FindClose(handle);
	}


	(*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
		nativeFullPath, &nativePart);

	fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);

	dev = -1;
	if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
	    CONST char *p;
	    DWORD dw;
	    CONST TCHAR *nativeVol;
	    Tcl_DString volString;

	    p = strchr(fullPath + 2, '\\');
	    p = strchr(p + 1, '\\');
	    if (p == NULL) {
		/*
		 * Add terminating backslash to fullpath or
		 * GetVolumeInformation() won't work.
		 */

		fullPath = Tcl_DStringAppend(&ds, "\\", 1);
		p = fullPath + Tcl_DStringLength(&ds);
	    } else {
		p++;
	    }
	    nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
	    dw = (DWORD) -1;
	    (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
		    NULL, NULL, NULL, 0);

	    /*
	     * GetFullPathName() turns special devices like "NUL" into
	     * "\\.\NUL", but GetVolumeInformation() returns failure for
	     * "\\.\NUL". This will cause "NUL" to get a drive number of -1,
	     * which makes about as much sense as anything since the special
	     * devices don't live on any drive.
	     */

	    dev = dw;
	    Tcl_DStringFree(&volString);
	} else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
	    dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
	}
	Tcl_DStringFree(&ds);

	attr = data.a.dwFileAttributes;

	statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) |
		(((Tcl_WideInt)data.a.nFileSizeHigh) << 32);
	statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
	statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
    } else {
	WIN32_FILE_ATTRIBUTE_DATA data;

	if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
		GetFileExInfoStandard, &data) != TRUE) {

	    Tcl_SetErrno(ENOENT);
	    return -1;
	}


	(*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
		nativeFullPath, &nativePart);

	fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);

	dev = -1;
	if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
	    CONST char *p;
	    DWORD dw;
	    CONST TCHAR *nativeVol;
	    Tcl_DString volString;

	    p = strchr(fullPath + 2, '\\');
	    p = strchr(p + 1, '\\');
	    if (p == NULL) {
		/*
		 * Add terminating backslash to fullpath or
		 * GetVolumeInformation() won't work.
		 */

		fullPath = Tcl_DStringAppend(&ds, "\\", 1);
		p = fullPath + Tcl_DStringLength(&ds);
	    } else {
		p++;
	    }
	    nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
	    dw = (DWORD) -1;
	    (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
		    NULL, NULL, NULL, 0);

	    /*
	     * GetFullPathName() turns special devices like "NUL" into
	     * "\\.\NUL", but GetVolumeInformation() returns failure for
	     * "\\.\NUL". This will cause "NUL" to get a drive number of -1,
	     * which makes about as much sense as anything since the special
	     * devices don't live on any drive.
	     */

	    dev = dw;
	    Tcl_DStringFree(&volString);
	} else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
	    dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
	}
	Tcl_DStringFree(&ds);

	attr = data.dwFileAttributes;

	statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) |
		(((Tcl_WideInt)data.nFileSizeHigh) << 32);
	statPtr->st_atime = ToCTime(data.ftLastAccessTime);
	statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.ftCreationTime);
    }

    mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));

    statPtr->st_dev	= (dev_t) dev;
    statPtr->st_ino	= 0;
    statPtr->st_mode	= mode;
    statPtr->st_nlink	= 1;
    statPtr->st_uid	= 0;
    statPtr->st_gid	= 0;
    statPtr->st_rdev	= (dev_t) dev;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStatMode --
 *
 *	Calculate just the 'st_mode' field of a 'stat' structure.
 *
 *	In many places we don't need the full stat structure, and it's much
 *	faster just to calculate these pieces, if that's all we need.

 *
 *----------------------------------------------------------------------
 */

static unsigned short
NativeStatMode(DWORD attr, int checkLinks, int isExec)
{
    int mode;
    if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	/*
	 * It is a link.
	 */
	mode = S_IFLNK;
    } else {
	mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
    }
    mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
    if (isExec) {
	mode |= S_IEXEC;
    }

    /*
     * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and other
     * positions.
     */

    mode |= (mode & 0x0700) >> 3;
    mode |= (mode & 0x0700) >> 6;
    return (unsigned short)mode;
}

1986
1987
1988
1989
1990
1991
1992

1993
1994

1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015

2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138

2139


2140
2141
2142
2143
2144

2145


2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192

2193
2194
2195

2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206

2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233

2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244

2245


2246
2247

2248

2249
2250
2251
2252
2253
2254
2255

2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270

2271
2272
2273
2274
2275

2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288

2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333

2334
2335
2336
2337
2338
2339
2340

2341
2342
2343

2344


2345
2346
2347
2348
2349
2350
2351
2352

2353
2354
2355

2356




















2357
2358
2359
2360
2361
2362
2363

2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378

2379
2380
2381
2382
2383
2384
2385

2386
2387
2388
2389

2390


2391
2392
2393
2394
2395
2396
2397

2398


2399
2400
2401


2402



2403
2404
2405

2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430

2431


2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442

2443


2444
2445
2446

2447
2448

2449
























2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467

2468
2469
2470

2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482

2483
2484


2485


2486
2487
2488
2489
2490
2491
2492
2493
2494


2495


2496
2497
2498
2499
2500
2501
2502

2503
2504
2505
2506
2507
2508

2509
2510
2511
2512
2513
2514
2515

2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530

2531
2532
2533
2534
2535
2536
2537

2538
2539
2540
2541
2542
2543

2544


2545
2546
2547
2548
2549

2550



2551
2552
2553
2554

2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573

2574
2575
2576
2577

2578
2579
2580
2581

2582
2583
2584
2585

2586
2587
2588
2589
2590
2591
2592
2593

2594


2595
2596
2597
2598
2599
2600
2601
2602


2603


2604
2605
2606
2607
2608
2609
2610
2611

2612

2613
2614
2615
2616

2617


2618
2619
2620

2621
2622
2623
2624
2625
2626
2627

2628


2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660

2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678

2679
2680
2681
2682
2683


2684

2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700

2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712

2713
2714
2715
2716
2717

2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730

2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761

2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781

2782
2783
2784
2785
2786
2787
2788
2789
2790

2791
2792
2793

2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820

2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837

2838
2839

2840


2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875

2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887

2888

2889

2890

2891

2892

2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931

2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946








 *------------------------------------------------------------------------
 */

static time_t
ToCTime(FILETIME fileTime)	/* UTC time */
{
    LARGE_INTEGER convertedTime;

    convertedTime.LowPart = fileTime.dwLowDateTime;
    convertedTime.HighPart = (LONG) fileTime.dwHighDateTime;

    return (time_t) ((convertedTime.QuadPart
		      - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME)
		      / (Tcl_WideInt) 10000000);
}


/*
 *------------------------------------------------------------------------
 *
 * FromCTime --
 *
 *	Converts a time_t to a Windows FILETIME
 *
 * Results:
 *	Returns the count of 100-ns ticks seconds from the Windows epoch.
 *
 *------------------------------------------------------------------------
 */

static void
FromCTime(time_t posixTime,

	  FILETIME* fileTime)	/* UTC Time */
{
    LARGE_INTEGER convertedTime;
    convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000 
	+ POSIX_EPOCH_AS_FILETIME;
    fileTime->dwLowDateTime = convertedTime.LowPart;
    fileTime->dwHighDateTime = convertedTime.HighPart;
}

#if 0
/*
 *-------------------------------------------------------------------------
 *
 * TclWinResolveShortcut --
 *
 *	Resolve a potential Windows shortcut to get the actual file or 
 *	directory in question.  
 *
 * Results:
 *	Returns 1 if the shortcut could be resolved, or 0 if there was
 *	an error or if the filename was not a shortcut.
 *	If bufferPtr did hold the name of a shortcut, it is modified to
 *	hold the resolved target of the shortcut instead.
 *
 * Side effects:
 *	Loads and unloads OLE package to determine if filename refers to
 *	a shortcut.
 *
 *-------------------------------------------------------------------------
 */

int
TclWinResolveShortcut(bufferPtr)
    Tcl_DString *bufferPtr;	/* Holds name of file to resolve.  On 
				 * return, holds resolved file name. */
{
    HRESULT hres; 
    IShellLink *psl; 
    IPersistFile *ppf; 
    WIN32_FIND_DATA wfd; 
    WCHAR wpath[MAX_PATH];
    char *path, *ext;
    char realFileName[MAX_PATH];

    /*
     * Windows system calls do not automatically resolve
     * shortcuts like UNIX automatically will with symbolic links.
     */

    path = Tcl_DStringValue(bufferPtr);
    ext = strrchr(path, '.');
    if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
	return 0;
    }

    CoInitialize(NULL);
    path = Tcl_DStringValue(bufferPtr);
    realFileName[0] = '\0';
    hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, 
	    &IID_IShellLink, &psl); 
    if (SUCCEEDED(hres)) { 
	hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
	if (SUCCEEDED(hres)) { 
	    MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
	    hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); 
	    if (SUCCEEDED(hres)) {
		hres = psl->lpVtbl->Resolve(psl, NULL, 
			SLR_ANY_MATCH | SLR_NO_UI); 
		if (SUCCEEDED(hres)) { 
		    hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, 
			    &wfd, 0);
		} 
	    } 
	    ppf->lpVtbl->Release(ppf); 
	} 
	psl->lpVtbl->Release(psl); 
    } 
    CoUninitialize();

    if (realFileName[0] != '\0') {
	Tcl_DStringSetLength(bufferPtr, 0);
	Tcl_DStringAppend(bufferPtr, realFileName, -1);
	return 1;
    }
    return 0;
}
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetNativeCwd --
 *
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form.  The
 *	result is either the given clientData, if the working directory
 *	hasn't changed, or a new clientData (owned by our caller),
 *	giving the new native path, or NULL if the current directory
 *	could not be determined.  If NULL is returned, the caller can
 *	examine the standard posix error codes to determine the cause of
 *	the problem.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
TclpGetNativeCwd(clientData)
    ClientData clientData;
{
    WCHAR buffer[MAX_PATH];
    
    if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	return NULL;
    }

    if (clientData != NULL) {
        if (tclWinProcs->useWide) {

	    /* unicode representation when running on NT/2K/XP */


	    if (wcscmp((CONST WCHAR*)clientData, 
		       (CONST WCHAR*)buffer) == 0) {
		return clientData;
	    }
	} else {

	    /* ansi representation when running on 95/98/ME */


	    if (strcmp((CONST char*)clientData, 
		       (CONST char*)buffer) == 0) {
		return clientData;
	    }
	}
    }
    
    return TclNativeDupInternalRep((ClientData)buffer);
}

int 
TclpObjAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;
    int mode;
{
    return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
}

int 
TclpObjLstat(pathPtr, statPtr)
    Tcl_Obj *pathPtr;
    Tcl_StatBuf *statPtr; 
{
    /*
     * Ensure correct file sizes by forcing the OS to write any
     * pending data to disk. This is done only for channels which are
     * dirty, i.e. have been written to since the last flush here.
     */

    TclWinFlushDirtyChannels ();

    return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}

#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    if (toPtr != NULL) {
	int res;
#if 0
	TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
#else

	TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(Tcl_FSGetNormalizedPath(NULL,toPtr));
#endif
	TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);

	if (LinkSource == NULL || LinkTarget == NULL) {
	    return NULL;
	}
	res = WinLink(LinkSource, LinkTarget, linkAction);
	if (res == 0) {
	    return toPtr;
	} else {
	    return NULL;
	}
    } else {
	TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);

	if (LinkSource == NULL) {
	    return NULL;
	}
	return WinReadLink(LinkSource);
    }
}

#endif


/*
 *---------------------------------------------------------------------------
 *
 * TclpFilesystemPathType --
 *
 *      This function is part of the native filesystem support, and
 *      returns the path type of the given path.  Returns NTFS or FAT
 *      or whatever is returned by the 'volume information' proc.
 *
 * Results:
 *      NULL at present.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpFilesystemPathType(pathPtr)
    Tcl_Obj* pathPtr;
{
#define VOL_BUF_SIZE 32
    int found;
    char volType[VOL_BUF_SIZE];
    char* firstSeparator;
    CONST char *path;
    
    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

    if (normPath == NULL) return NULL;


    path = Tcl_GetString(normPath);
    if (path == NULL) return NULL;

    

    firstSeparator = strchr(path, '/');
    if (firstSeparator == NULL) {
	found = tclWinProcs->getVolumeInformationProc(
		Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, 
		NULL, (WCHAR *)volType, VOL_BUF_SIZE);
    } else {
	Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);

	Tcl_IncrRefCount(driveName);
	found = tclWinProcs->getVolumeInformationProc(
		Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, 
		NULL, (WCHAR *)volType, VOL_BUF_SIZE);
	Tcl_DecrRefCount(driveName);
    }

    if (found == 0) {
	return NULL;
    } else {
	Tcl_DString ds;
	Tcl_Obj *objPtr;
	
	Tcl_WinTCharToUtf(volType, -1, &ds);
	objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));

	Tcl_DStringFree(&ds);
	return objPtr;
    }
#undef VOL_BUF_SIZE
}

/* 
 * This define can be turned on to experiment with a different way of
 * normalizing paths (using a different Windows API).  Unfortunately the
 * new path seems to take almost exactly the same amount of time as the
 * old path!  The primary time taken by normalization is in
 * GetFileAttributesEx/FindFirstFile or
 * GetFileAttributesEx/GetLongPathName.  Conversion to/from native is
 * not a significant factor at all.
 * 
 * Also, since we have to check for symbolic links (reparse points)
 * then we have to call GetFileAttributes on each path segment anyway,
 * so there's no benefit to doing anything clever there.
 */

/* #define TclNORM_LONG_PATH */

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces it,
 *	in place, with a normalized version.  This means using the
 *	'longname', and expanding any symbolic links contained within the
 *	path.
 *
 * Results:
 *	The new 'nextCheckpoint' value, giving as far as we could
 *	understand in the path.
 *
 * Side effects:
 *	The pathPtr string, which must contain a valid path, is
 *	possibly modified in place.
 *
 *---------------------------------------------------------------------------
 */
int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
    Tcl_Interp *interp;
    Tcl_Obj *pathPtr;
    int nextCheckpoint;
{
    char *lastValidPathEnd = NULL;
    /* This will hold the normalized string */
    Tcl_DString dsNorm;
    char *path;
    char *currentPathEndPosition;

    Tcl_DStringInit(&dsNorm);
    path = Tcl_GetString(pathPtr);

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
	/* 
	 * We're on Win95, 98 or ME.  There are two assumptions
	 * in this block of code.  First that the native (NULL)
	 * encoding is basically ascii, and second that symbolic
	 * links are not possible.  Both of these assumptions
	 * appear to be true of these operating systems.
	 */

	int isDrive = 1;
	Tcl_DString ds;

	currentPathEndPosition = path + nextCheckpoint;
        if (*currentPathEndPosition == '/') {
	    currentPathEndPosition++;
        }

	while (1) {
	    char cur = *currentPathEndPosition;
	    if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {

		/* Reached directory separator, or end of string */


		CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path, 
			    currentPathEndPosition - path, &ds);

		/*
		 * Now we convert the tail of the current path to its
		 * 'long form', and append it to 'dsNorm' which holds
		 * the current normalized path, if the file exists.
		 */

		if (isDrive) {
		    if (GetFileAttributesA(nativePath) 
			== 0xffffffff) {

			/* File doesn't exist */




















			Tcl_DStringFree(&ds);
			break;
		    }
		    if (nativePath[0] >= 'a') {
			((char*)nativePath)[0] -= ('a' - 'A');
		    }
		    Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));

		} else {
		    char *checkDots = NULL;
		    
		    if (lastValidPathEnd[1] == '.') {
			checkDots = lastValidPathEnd + 1;
			while (checkDots < currentPathEndPosition) {
			    if (*checkDots != '.') {
				checkDots = NULL;
				break;
			    }
			    checkDots++;
			}
		    }
		    if (checkDots != NULL) {
			int dotLen = currentPathEndPosition - lastValidPathEnd;

			/* 
			 * Path is just dots.  We shouldn't really
			 * ever see a path like that.  However, to be
			 * nice we at least don't mangle the path -- 
			 * we just add the dots as a path segment and
			 * continue
			 */

			Tcl_DStringAppend(&dsNorm, (TCHAR*)(nativePath 
						   + Tcl_DStringLength(&ds)
						   - dotLen), dotLen);
		    } else {

			/* Normal path */


			WIN32_FIND_DATA fData;
			HANDLE handle;
			
			handle = FindFirstFileA(nativePath, &fData);
			if (handle == INVALID_HANDLE_VALUE) {
			    if (GetFileAttributesA(nativePath) 
				== 0xffffffff) {

				/* File doesn't exist */


				Tcl_DStringFree(&ds);
				break;
			    }


			    /* This is usually the '/' in 'c:/' at end of string */



			    Tcl_DStringAppend(&dsNorm,"/", 1);
			} else {
			    char *nativeName;

			    if (fData.cFileName[0] != '\0') {
				nativeName = fData.cFileName;
			    } else {
				nativeName = fData.cAlternateFileName;
			    }
			    FindClose(handle);
			    Tcl_DStringAppend(&dsNorm,"/", 1);
			    Tcl_DStringAppend(&dsNorm,nativeName,-1);
			}
		    }
		}
		Tcl_DStringFree(&ds);
		lastValidPathEnd = currentPathEndPosition;
		if (cur == 0) {
		    break;
		}
		/* 
		 * If we get here, we've got past one directory
		 * delimiter, so we know it is no longer a drive 
		 */
		isDrive = 0;
	    }
	    currentPathEndPosition++;
	}
    } else {

	/* We're on WinNT or 2000 or XP */


	Tcl_Obj *temp = NULL;
	int isDrive = 1;
	Tcl_DString ds;
	
	currentPathEndPosition = path + nextCheckpoint;
	if (*currentPathEndPosition == '/') {
	    currentPathEndPosition++;
	}
	while (1) {
	    char cur = *currentPathEndPosition;
	    if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {

		/* Reached directory separator, or end of string */


		WIN32_FILE_ATTRIBUTE_DATA data;
		CONST char *nativePath = Tcl_WinUtfToTChar(path, 
			    currentPathEndPosition - path, &ds);

		if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
		    GetFileExInfoStandard, &data) != TRUE) {

		    /* File doesn't exist */
























		    Tcl_DStringFree(&ds);
		    break;
		}

		/* 
		 * File 'nativePath' does exist if we get here.  We
		 * now want to check if it is a symlink and otherwise
		 * continue with the rest of the path.
		 */
		
		/* 
		 * Check for symlinks, except at last component
		 * of path (we don't follow final symlinks). Also
		 * a drive (C:/) for example, may sometimes have
		 * the reparse flag set for some reason I don't
		 * understand.  We therefore don't perform this
		 * check for drives.
		 */

		if (cur != 0 && !isDrive 
		  && (data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT)) {
		    Tcl_Obj *to = WinReadLinkDirectory(nativePath);

		    if (to != NULL) {
			/* 
			 * Read the reparse point ok.  Now, reparse
			 * points need not be normalized, otherwise
			 * we could use: 
			 * 
			 * Tcl_GetStringFromObj(to, &pathLen); 
			 * nextCheckpoint = pathLen
			 * 
			 * So, instead we have to start from the
			 * beginning.
			 */

			nextCheckpoint = 0;
			Tcl_AppendToObj(to, currentPathEndPosition, -1);


			/* Convert link to forward slashes */


			for (path = Tcl_GetString(to); *path != 0; path++) {
			    if (*path == '\\') *path = '/';
			}
			path = Tcl_GetString(to);
			currentPathEndPosition = path + nextCheckpoint;
			if (temp != NULL) {
			    Tcl_DecrRefCount(temp);
			}
			temp = to;


			/* Reset variables so we can restart normalization */


			isDrive = 1;
			Tcl_DStringFree(&dsNorm);
			Tcl_DStringInit(&dsNorm);
			Tcl_DStringFree(&ds);
			continue;
		    }
		}

#ifndef TclNORM_LONG_PATH
		/*
		 * Now we convert the tail of the current path to its
		 * 'long form', and append it to 'dsNorm' which holds
		 * the current normalized path
		 */

		if (isDrive) {
		    WCHAR drive = ((WCHAR*)nativePath)[0];
		    if (drive >= L'a') {
		        drive -= (L'a' - L'A');
			((WCHAR*)nativePath)[0] = drive;
		    }
		    Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));

		} else {
		    char *checkDots = NULL;
		    
		    if (lastValidPathEnd[1] == '.') {
			checkDots = lastValidPathEnd + 1;
			while (checkDots < currentPathEndPosition) {
			    if (*checkDots != '.') {
				checkDots = NULL;
				break;
			    }
			    checkDots++;
			}
		    }
		    if (checkDots != NULL) {
			int dotLen = currentPathEndPosition - lastValidPathEnd;

			/* 
			 * Path is just dots.  We shouldn't really
			 * ever see a path like that.  However, to be
			 * nice we at least don't mangle the path -- 
			 * we just add the dots as a path segment and
			 * continue
			 */

			Tcl_DStringAppend(&dsNorm,
					  (TCHAR*)((WCHAR*)(nativePath 
						+ Tcl_DStringLength(&ds)) 
						- dotLen),
					  (int)(dotLen * sizeof(WCHAR)));
		    } else {

			/* Normal path */


			WIN32_FIND_DATAW fData;
			HANDLE handle;

			handle = FindFirstFileW((WCHAR*)nativePath, &fData);
			if (handle == INVALID_HANDLE_VALUE) {

			    /* This is usually the '/' in 'c:/' at end of string */



			    Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", 
					      sizeof(WCHAR));
			} else {
			    WCHAR *nativeName;

			    if (fData.cFileName[0] != '\0') {
				nativeName = fData.cFileName;
			    } else {
				nativeName = fData.cAlternateFileName;
			    }
			    FindClose(handle);
			    Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", 
					      sizeof(WCHAR));
			    Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName, 
					      (int) (wcslen(nativeName)*sizeof(WCHAR)));
			}
		    }
		}
#endif
		Tcl_DStringFree(&ds);
		lastValidPathEnd = currentPathEndPosition;
		if (cur == 0) {
		    break;
		}

		/* 
		 * If we get here, we've got past one directory
		 * delimiter, so we know it is no longer a drive 
		 */

		isDrive = 0;
	    }
	    currentPathEndPosition++;
	}

#ifdef TclNORM_LONG_PATH
	/* 
	 * Convert the entire known path to long form.
	 */

	if (1) {
	    WCHAR wpath[MAX_PATH];
	    DWORD wpathlen;
	    CONST char *nativePath = Tcl_WinUtfToTChar(path, 
					lastValidPathEnd - path, &ds);
	    wpathlen = (*tclWinProcs->getLongPathNameProc)(nativePath, 
							   (TCHAR*)wpath, 
							   MAX_PATH);

	    /* We have to make the drive letter uppercase */


	    if (wpath[0] >= L'a') {
		wpath[0] -= (L'a' - L'A');
	    }
	    Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR));
	    Tcl_DStringFree(&ds);
	}
#endif
    }


    /* Common code path for all Windows platforms */


    nextCheckpoint = currentPathEndPosition - path;
    if (lastValidPathEnd != NULL) {
	/* 
	 * Concatenate the normalized string in dsNorm with the
	 * tail of the path which we didn't recognise.  The
	 * string in dsNorm is in the native encoding, so we
	 * have to convert it to Utf.
	 */

	Tcl_DString dsTemp;

	Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm), 
			  Tcl_DStringLength(&dsNorm), &dsTemp);
	nextCheckpoint = Tcl_DStringLength(&dsTemp);
	if (*lastValidPathEnd != 0) {

	    /* Not the end of the string */


	    int len;
	    char *path;
	    Tcl_Obj *tmpPathPtr;

	    tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), 
					  nextCheckpoint);
	    Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
	    path = Tcl_GetStringFromObj(tmpPathPtr, &len);
	    Tcl_SetStringObj(pathPtr, path, len);
	    Tcl_DecrRefCount(tmpPathPtr);
	} else {

	    /* End of string was reached above */


	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
			     nextCheckpoint);
	}
	Tcl_DStringFree(&dsTemp);
    }
    Tcl_DStringFree(&dsNorm);
    return nextCheckpoint;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinVolumeRelativeNormalize --
 *
 *      Only Windows has volume-relative paths.  These paths are rather
 *      rare, but it is nice if Tcl can handle them.  It is much better
 *      if we can handle them here, rather than in the native fs code,
 *      because we really need to have a real absolute path just below.
 * 
 *      We do not let this block compile on non-Windows platforms
 *      because the test suite's manual forcing of tclPlatform can
 *      otherwise cause this code path to be executed, causing various
 *      errors because volume-relative paths really do not exist.
 *
 * Results:
 *      A valid normalized path.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr)
    Tcl_Interp *interp;
    CONST char *path;
    Tcl_Obj **useThisCwdPtr;
{
    Tcl_Obj *absolutePath, *useThisCwd;
    
    useThisCwd = Tcl_FSGetCwd(interp);
    if (useThisCwd == NULL) {
        return NULL;
    }
    
    if (path[0] == '/') {
	/* 
	 * Path of form /foo/bar which is a path in the
	 * root directory of the current volume.
	 */

	CONST char *drive = Tcl_GetString(useThisCwd);
	
	absolutePath = Tcl_NewStringObj(drive,2);
	Tcl_AppendToObj(absolutePath, path, -1);
	Tcl_IncrRefCount(absolutePath);


	/* We have a refCount on the cwd */

    } else {
	/* 
	 * Path of form C:foo/bar, but this only makes
	 * sense if the cwd is also on drive C.
	 */
	
	int cwdLen;
	CONST char *drive = 
	        Tcl_GetStringFromObj(useThisCwd, &cwdLen);
	char drive_cur = path[0];
	
	if (drive_cur >= 'a') {
	    drive_cur -= ('a' - 'A');
	}
	if (drive[0] == drive_cur) {
	    absolutePath = Tcl_DuplicateObj(useThisCwd);

	    /* 
	     * We have a refCount on the cwd, which we
	     * will release later.
	     */

	    if (drive[cwdLen-1] != '/' && (path[2] != '\0')) {
		/* 
		 * Only add a trailing '/' if needed, which
		 * is if there isn't one already, and if we
		 * are going to be adding some more
		 * characters.
		 */

		Tcl_AppendToObj(absolutePath, "/", 1);
	    }
	} else {
	    Tcl_DecrRefCount(useThisCwd);
	    useThisCwd = NULL;

	    /* 
	     * The path is not in the current drive, but
	     * is volume-relative.  The way Tcl 8.3 handles
	     * this is that it treats such a path as
	     * relative to the root of the drive.  We
	     * therefore behave the same here.  This
	     * behaviour is, however, different to that
	     * of the windows command-line.  If we want
	     * to fix this at some point in the future
	     * (at the expense of a behaviour change to
	     * Tcl), we could use the '_dgetdcwd' Win32
	     * API to get the drive's cwd.
	     */

	    absolutePath = Tcl_NewStringObj(path, 2);
	    Tcl_AppendToObj(absolutePath, "/", 1);
	}
	Tcl_IncrRefCount(absolutePath);
	Tcl_AppendToObj(absolutePath, path+2, -1);
    }
    *useThisCwdPtr = useThisCwd;
    return absolutePath;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeToNormalized --
 *
 *      Convert native format to a normalized path object, with refCount
 *      of zero.
 *      
 *      Currently assumes all native paths are actually normalized
 *      already, so if the path given is not normalized this will
 *      actually just convert to a valid string path, but not
 *      necessarily a normalized one.
 *
 * Results:
 *      A valid normalized path.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
TclpNativeToNormalized(clientData)
    ClientData clientData;
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;
    int len;
    
    char *copy;
    char *p;
    Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
    
    copy = Tcl_DStringValue(&ds);
    len = Tcl_DStringLength(&ds);

    /* 
     * Certain native path representations on Windows have this special
     * prefix to indicate that they are to be treated specially.  For
     * example extremely long paths, or symlinks 
     */

    if (*copy == '\\') {
	if (0 == strncmp(copy,"\\??\\",4)) {
	    copy += 4;
	    len -= 4;
	} else if (0 == strncmp(copy,"\\\\?\\",4)) {
	    copy += 4;
	    len -= 4;
	}
    }

    /* 
     * Ensure we are using forward slashes only.
     */

    for (p = copy; *p != '\0'; p++) {
	if (*p == '\\') {
	    *p = '/';
	}
    }

    objPtr = Tcl_NewStringObj(copy,len);
    Tcl_DStringFree(&ds);
    
    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeCreateNativeRep --
 *
 *      Create a native representation for the given path.
 *
 * Results:
 *      The nativePath representation.
 *
 * Side effects:
 *	Memory will be allocated.  The path may need to be normalized.
 *
 *---------------------------------------------------------------------------
 */

ClientData 
TclNativeCreateNativeRep(pathPtr)
    Tcl_Obj* pathPtr;
{
    char *nativePathPtr;
    Tcl_DString ds;
    Tcl_Obj* validPathPtr;
    int len;
    char *str;

    if (TclFSCwdIsNative()) {
	/* 
	 * The cwd is native, which means we can use the translated
	 * path without worrying about normalization (this will also
	 * usually be shorter so the utf-to-external conversion will
	 * be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
    } else {

	/* Make sure the normalized path is set */


	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_WinUtfToTChar(str, len, &ds);
    if (tclWinProcs->useWide) {
	len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
    } else {
	len = Tcl_DStringLength(&ds) + sizeof(char);
    }
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc((unsigned) len);
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
	  
    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --
 *
 *      Duplicate the native representation.
 *
 * Results:
 *      The copied native representation, or NULL if it is not possible
 *      to copy the representation.
 *
 * Side effects:
 *	Memory allocation for the copy.
 *
 *---------------------------------------------------------------------------
 */

ClientData 
TclNativeDupInternalRep(clientData)
    ClientData clientData;
{
    char *copy;
    size_t len;

    if (clientData == NULL) {
	return NULL;
    }

    if (tclWinProcs->useWide) {

	/* unicode representation when running on NT/2K/XP */

	len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));

    } else {

	/* ansi representation when running on 95/98/ME */

	len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));

    }
    
    copy = (char *) ckalloc(len);
    memcpy((VOID*)copy, (VOID*)clientData, len);
    return (ClientData)copy;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpUtime --
 *
 *	Set the modification date for a file.
 *
 * Results:
 *	0 on success, -1 on error.
 *
 * Side effects:
 *	Sets errno to a representation of any Windows problem that's
 *	observed in the process.
 *
 *---------------------------------------------------------------------------
 */
int
TclpUtime(pathPtr, tval)
    Tcl_Obj *pathPtr;      /* File to modify */
    struct utimbuf *tval;  /* New modification date structure */
{
    int res = 0;
    HANDLE fileHandle;
    FILETIME lastAccessTime, lastModTime;
    
    FromCTime(tval->actime, &lastAccessTime);
    FromCTime(tval->modtime, &lastModTime);
    
    /*
     * We use the native APIs (not 'utime') because there are
     * some daylight savings complications that utime gets wrong.
     */

    fileHandle = (tclWinProcs->createFileProc) (
         (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), 
	 FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, 
	 FILE_ATTRIBUTE_NORMAL, NULL);
    
    if (fileHandle == INVALID_HANDLE_VALUE
      || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
	TclWinConvertError(GetLastError());
	res = -1;
    }
    if (fileHandle != INVALID_HANDLE_VALUE) {
	CloseHandle(fileHandle);
    }
    return res;
}















>


>

|
<

<















|
>
|


|




|






|
|


|
|
|
|


|
|






|
|

|
|
|
|





|
|











|
|
|

|

|

|
<
|
|

|
|
|
|
|
|



















|
|
|
|
|
|
<












|






|
>
|
>
>
|
<



>
|
>
>
|
<




|


|
|




|

|
|


|


|
|
|






|

<
|








|

>
|

|
>










|
>






<

<






|
|
|


|






>






|


<

>
|
>
>

|
>
|
>



|
|


>


|
|








|
|
|
>





>
|

|
|
|
|
<
|
|
|
|
|

>







|
|
|
<


|
|


|
|










|
<







|
|
|
|
<
|

>




|

|
>



>
|
>
>
|
|


|
|
|

>

|
<
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
>


|












>
|
|
|
|
|
<

>
|
|
|

>
|
>
>


|


|
<
>
|
>
>



>
>
|
>
>
>



>
















|
|
|






>
|
>
>



|







>
|
>
>

|
|
>

|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|
|
|
|

|
|
|
|
|
<
|


>
|
|

>

|
|
|
<
|
|

|
|
<

>


>
>
|
>
>









>
>
|
>
>







>


|
|
|

>



|


|
>


|












>
|
|
|
|
|
<

>
|
<
|
<
|

>
|
>
>





>
|
>
>
>
|
|


>






|
|
|
|









>
|
|
|

>




>

|


>


<
|
|
|
|
|
>
|
>
>








>
>
|
>
>


|
|
|
<
|

>

>
|
|


>
|
>
>



>
|
|





>
|
>
>

|












|
|
|
|
|
|
|
|
|


|






>







|


|

|

|
|
|

>

|



>
>
|
>

|
|
|

|

|
|

|





>
|
|
<



|
|
<
|


>





>
|
|
<
|
|
<
|
|
<
|
|
<

>















|
|
|
|
|
<
|


|






>
|






|



|



|
|
|
|

>









>
|


>








|








|


|


|



>
|










|
|
|
|
<

>


>
|
>
>














|









|


|
|






>
|











>
|
>
|
>

>
|
>
|
>

|

|
|













|
|





|
|




|


|

|
|

>

|
|
|
|
|
|








>
>
>
>
>
>
>
>
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246

2247

2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331

2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365

2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390

2391
2392
2393
2394
2395
2396
2397
2398

2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431

2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465

2466

2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494

2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540

2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557

2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576

2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587

2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616

2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667

2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683

2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790

2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802

2803
2804
2805
2806
2807

2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874

2875
2876
2877

2878

2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936

2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963

2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071

3072
3073
3074
3075
3076

3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088

3089
3090

3091
3092

3093
3094

3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116

3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205

3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
 *------------------------------------------------------------------------
 */

static time_t
ToCTime(FILETIME fileTime)	/* UTC time */
{
    LARGE_INTEGER convertedTime;

    convertedTime.LowPart = fileTime.dwLowDateTime;
    convertedTime.HighPart = (LONG) fileTime.dwHighDateTime;

    return (time_t) ((convertedTime.QuadPart
	    - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000);

}


/*
 *------------------------------------------------------------------------
 *
 * FromCTime --
 *
 *	Converts a time_t to a Windows FILETIME
 *
 * Results:
 *	Returns the count of 100-ns ticks seconds from the Windows epoch.
 *
 *------------------------------------------------------------------------
 */

static void
FromCTime(
    time_t posixTime,
    FILETIME* fileTime)		/* UTC Time */
{
    LARGE_INTEGER convertedTime;
    convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000
	+ POSIX_EPOCH_AS_FILETIME;
    fileTime->dwLowDateTime = convertedTime.LowPart;
    fileTime->dwHighDateTime = convertedTime.HighPart;
}

#if 0
/*
 *-------------------------------------------------------------------------
 *
 * TclWinResolveShortcut --
 *
 *	Resolve a potential Windows shortcut to get the actual file or
 *	directory in question.
 *
 * Results:
 *	Returns 1 if the shortcut could be resolved, or 0 if there was an
 *	error or if the filename was not a shortcut. If bufferPtr did hold the
 *	name of a shortcut, it is modified to hold the resolved target of the
 *	shortcut instead.
 *
 * Side effects:
 *	Loads and unloads OLE package to determine if filename refers to a
 *	shortcut.
 *
 *-------------------------------------------------------------------------
 */

int
TclWinResolveShortcut(bufferPtr)
    Tcl_DString *bufferPtr;	/* Holds name of file to resolve. On return,
				 * holds resolved file name. */
{
    HRESULT hres;
    IShellLink *psl;
    IPersistFile *ppf;
    WIN32_FIND_DATA wfd;
    WCHAR wpath[MAX_PATH];
    char *path, *ext;
    char realFileName[MAX_PATH];

    /*
     * Windows system calls do not automatically resolve shortcuts like UNIX
     * automatically will with symbolic links.
     */

    path = Tcl_DStringValue(bufferPtr);
    ext = strrchr(path, '.');
    if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
	return 0;
    }

    CoInitialize(NULL);
    path = Tcl_DStringValue(bufferPtr);
    realFileName[0] = '\0';
    hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
	    &IID_IShellLink, &psl);
    if (SUCCEEDED(hres)) {
	hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
	if (SUCCEEDED(hres)) {
	    MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
	    hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
	    if (SUCCEEDED(hres)) {
		hres = psl->lpVtbl->Resolve(psl,NULL,SLR_ANY_MATCH|SLR_NO_UI);

		if (SUCCEEDED(hres)) {
		    hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
			    &wfd, 0);
		}
	    }
	    ppf->lpVtbl->Release(ppf);
	}
	psl->lpVtbl->Release(psl);
    }
    CoUninitialize();

    if (realFileName[0] != '\0') {
	Tcl_DStringSetLength(bufferPtr, 0);
	Tcl_DStringAppend(bufferPtr, realFileName, -1);
	return 1;
    }
    return 0;
}
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TclpGetNativeCwd --
 *
 *	This function replaces the library version of getcwd().
 *
 * Results:
 *	The input and output are filesystem paths in native form. The result
 *	is either the given clientData, if the working directory hasn't
 *	changed, or a new clientData (owned by our caller), giving the new
 *	native path, or NULL if the current directory could not be determined.
 *	If NULL is returned, the caller can examine the standard posix error
 *	codes to determine the cause of the problem.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
TclpGetNativeCwd(clientData)
    ClientData clientData;
{
    WCHAR buffer[MAX_PATH];

    if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	return NULL;
    }

    if (clientData != NULL) {
	if (tclWinProcs->useWide) {
	    /*
	     * Unicode representation when running on NT/2K/XP.
	     */

	    if (wcscmp((CONST WCHAR*)clientData, (CONST WCHAR*)buffer) == 0) {

		return clientData;
	    }
	} else {
	    /*
	     * ANSI representation when running on 95/98/ME.
	     */

	    if (strcmp((CONST char*)clientData, (CONST char*)buffer) == 0) {

		return clientData;
	    }
	}
    }

    return TclNativeDupInternalRep((ClientData)buffer);
}

int
TclpObjAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;
    int mode;
{
    return NativeAccess((CONST TCHAR *) Tcl_FSGetNativePath(pathPtr), mode);
}

int
TclpObjLstat(pathPtr, statPtr)
    Tcl_Obj *pathPtr;
    Tcl_StatBuf *statPtr;
{
    /*
     * Ensure correct file sizes by forcing the OS to write any pending data
     * to disk. This is done only for channels which are dirty, i.e. have been
     * written to since the last flush here.
     */

    TclWinFlushDirtyChannels ();

    return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}

#ifdef S_IFLNK

Tcl_Obj*
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    if (toPtr != NULL) {
	int res;
#if 0
	TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath(toPtr);
#else
	TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath(
		Tcl_FSGetNormalizedPath(NULL, toPtr));
#endif
	TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr);

	if (LinkSource == NULL || LinkTarget == NULL) {
	    return NULL;
	}
	res = WinLink(LinkSource, LinkTarget, linkAction);
	if (res == 0) {
	    return toPtr;
	} else {
	    return NULL;
	}
    } else {
	TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr);

	if (LinkSource == NULL) {
	    return NULL;
	}
	return WinReadLink(LinkSource);
    }
}

#endif


/*
 *---------------------------------------------------------------------------
 *
 * TclpFilesystemPathType --
 *
 *	This function is part of the native filesystem support, and returns
 *	the path type of the given path. Returns NTFS or FAT or whatever is
 *	returned by the 'volume information' proc.
 *
 * Results:
 *	NULL at present.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpFilesystemPathType(pathPtr)
    Tcl_Obj* pathPtr;
{
#define VOL_BUF_SIZE 32
    int found;
    WCHAR volType[VOL_BUF_SIZE];
    char* firstSeparator;
    CONST char *path;

    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

    if (normPath == NULL) {
	return NULL;
    }
    path = Tcl_GetString(normPath);
    if (path == NULL) {
	return NULL;
    }

    firstSeparator = strchr(path, '/');
    if (firstSeparator == NULL) {
	found = tclWinProcs->getVolumeInformationProc(
		Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL,
		(WCHAR *) volType, VOL_BUF_SIZE);
    } else {
	Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);

	Tcl_IncrRefCount(driveName);
	found = tclWinProcs->getVolumeInformationProc(
		Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL,
		(WCHAR *) volType, VOL_BUF_SIZE);
	Tcl_DecrRefCount(driveName);
    }

    if (found == 0) {
	return NULL;
    } else {
	Tcl_DString ds;
	Tcl_Obj *objPtr;

	Tcl_WinTCharToUtf((CONST char *)volType, -1, &ds);
	objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
		Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	return objPtr;
    }
#undef VOL_BUF_SIZE
}

/*
 * This define can be turned on to experiment with a different way of
 * normalizing paths (using a different Windows API). Unfortunately the new
 * path seems to take almost exactly the same amount of time as the old path!
 * The primary time taken by normalization is in
 * GetFileAttributesEx/FindFirstFile or GetFileAttributesEx/GetLongPathName.

 * Conversion to/from native is not a significant factor at all.
 *
 * Also, since we have to check for symbolic links (reparse points) then we
 * have to call GetFileAttributes on each path segment anyway, so there's no
 * benefit to doing anything clever there.
 */

/* #define TclNORM_LONG_PATH */

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces it, in
 *	place, with a normalized version. This means using the 'longname', and
 *	expanding any symbolic links contained within the path.

 *
 * Results:
 *	The new 'nextCheckpoint' value, giving as far as we could understand
 *	in the path.
 *
 * Side effects:
 *	The pathPtr string, which must contain a valid path, is possibly
 *	modified in place.
 *
 *---------------------------------------------------------------------------
 */
int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
    Tcl_Interp *interp;
    Tcl_Obj *pathPtr;
    int nextCheckpoint;
{
    char *lastValidPathEnd = NULL;
    Tcl_DString dsNorm;		/* This will hold the normalized string. */

    char *path;
    char *currentPathEndPosition;

    Tcl_DStringInit(&dsNorm);
    path = Tcl_GetString(pathPtr);

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
	/*
	 * We're on Win95, 98 or ME. There are two assumptions in this block
	 * of code. First that the native (NULL) encoding is basically ascii,
	 * and second that symbolic links are not possible. Both of these

	 * assumptions appear to be true of these operating systems.
	 */

	int isDrive = 1;
	Tcl_DString ds;

	currentPathEndPosition = path + nextCheckpoint;
	if (*currentPathEndPosition == '/') {
	    currentPathEndPosition++;
	}

	while (1) {
	    char cur = *currentPathEndPosition;
	    if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
		/*
		 * Reached directory separator, or end of string.
		 */

		CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
			currentPathEndPosition - path, &ds);

		/*
		 * Now we convert the tail of the current path to its 'long
		 * form', and append it to 'dsNorm' which holds the current
		 * normalized path, if the file exists.
		 */

		if (isDrive) {
		    if (GetFileAttributesA(nativePath) == 0xffffffff) {

			/*
			 * File doesn't exist.
			 */

			if (isDrive) {
			    int len = WinIsReserved(path);
			    if (len > 0) {
				/*
				 * Actually it does exist - COM1, etc.
				 */

				int i;

				for (i=0;i<len;i++) {
				    if (nativePath[i] >= 'a') {
					((char*)nativePath)[i] -= ('a' - 'A');
				    }
				}
				Tcl_DStringAppend(&dsNorm, nativePath, len);
				lastValidPathEnd = currentPathEndPosition;
			    }
			}
			Tcl_DStringFree(&ds);
			break;
		    }
		    if (nativePath[0] >= 'a') {
			((char*)nativePath)[0] -= ('a' - 'A');
		    }
		    Tcl_DStringAppend(&dsNorm, nativePath,
			    Tcl_DStringLength(&ds));
		} else {
		    char *checkDots = NULL;

		    if (lastValidPathEnd[1] == '.') {
			checkDots = lastValidPathEnd + 1;
			while (checkDots < currentPathEndPosition) {
			    if (*checkDots != '.') {
				checkDots = NULL;
				break;
			    }
			    checkDots++;
			}
		    }
		    if (checkDots != NULL) {
			int dotLen = currentPathEndPosition - lastValidPathEnd;

			/*
			 * Path is just dots. We shouldn't really ever see a
			 * path like that. However, to be nice we at least
			 * don't mangle the path - we just add the dots as a
			 * path segment and continue

			 */

			Tcl_DStringAppend(&dsNorm, (TCHAR *)
				(nativePath + Tcl_DStringLength(&ds) - dotLen),
				dotLen);
		    } else {
			/*
			 * Normal path.
			 */

			WIN32_FIND_DATA fData;
			HANDLE handle;

			handle = FindFirstFileA(nativePath, &fData);
			if (handle == INVALID_HANDLE_VALUE) {
			    if (GetFileAttributesA(nativePath) == 0xffffffff) {

				/*
				 * File doesn't exist.
				 */

				Tcl_DStringFree(&ds);
				break;
			    }

			    /*
			     * This is usually the '/' in 'c:/' at end of
			     * string.
			     */

			    Tcl_DStringAppend(&dsNorm,"/", 1);
			} else {
			    char *nativeName;

			    if (fData.cFileName[0] != '\0') {
				nativeName = fData.cFileName;
			    } else {
				nativeName = fData.cAlternateFileName;
			    }
			    FindClose(handle);
			    Tcl_DStringAppend(&dsNorm,"/", 1);
			    Tcl_DStringAppend(&dsNorm,nativeName,-1);
			}
		    }
		}
		Tcl_DStringFree(&ds);
		lastValidPathEnd = currentPathEndPosition;
		if (cur == 0) {
		    break;
		}
		/*
		 * If we get here, we've got past one directory delimiter, so
		 * we know it is no longer a drive.
		 */
		isDrive = 0;
	    }
	    currentPathEndPosition++;
	}
    } else {
	/*
	 * We're on WinNT (or 2000 or XP; something with an NT core).
	 */

	Tcl_Obj *temp = NULL;
	int isDrive = 1;
	Tcl_DString ds;

	currentPathEndPosition = path + nextCheckpoint;
	if (*currentPathEndPosition == '/') {
	    currentPathEndPosition++;
	}
	while (1) {
	    char cur = *currentPathEndPosition;
	    if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
		/*
		 * Reached directory separator, or end of string.
		 */

		WIN32_FILE_ATTRIBUTE_DATA data;
		CONST char *nativePath = Tcl_WinUtfToTChar(path,
			currentPathEndPosition - path, &ds);

		if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
			GetFileExInfoStandard, &data) != TRUE) {
		    /*
		     * File doesn't exist.
		     */

		    if (isDrive) {
			int len = WinIsReserved(path);

			if (len > 0) {
			    /*
			     * Actually it does exist - COM1, etc.
			     */

			    int i;

			    for (i=0;i<len;i++) {
				WCHAR wc = ((WCHAR*)nativePath)[i];
				if (wc >= L'a') {
				    wc -= (L'a' - L'A');
				    ((WCHAR*)nativePath)[i] = wc;
				}
			    }
			    Tcl_DStringAppend(&dsNorm, nativePath,
				    sizeof(WCHAR)*len);
			    lastValidPathEnd = currentPathEndPosition;
			}
		    }
		    Tcl_DStringFree(&ds);
		    break;
		}

		/*
		 * File 'nativePath' does exist if we get here. We now want to
		 * check if it is a symlink and otherwise continue with the
		 * rest of the path.
		 */

		/*
		 * Check for symlinks, except at last component of path (we
		 * don't follow final symlinks). Also a drive (C:/) for
		 * example, may sometimes have the reparse flag set for some

		 * reason I don't understand. We therefore don't perform this
		 * check for drives.
		 */

		if (cur != 0 && !isDrive &&
			(data.dwFileAttributes&FILE_ATTRIBUTE_REPARSE_POINT)) {
		    Tcl_Obj *to = WinReadLinkDirectory(nativePath);

		    if (to != NULL) {
			/*
			 * Read the reparse point ok. Now, reparse points need
			 * not be normalized, otherwise we could use:

			 *
			 * Tcl_GetStringFromObj(to, &pathLen);
			 * nextCheckpoint = pathLen
			 *
			 * So, instead we have to start from the beginning.

			 */

			nextCheckpoint = 0;
			Tcl_AppendToObj(to, currentPathEndPosition, -1);

			/*
			 * Convert link to forward slashes.
			 */

			for (path = Tcl_GetString(to); *path != 0; path++) {
			    if (*path == '\\') *path = '/';
			}
			path = Tcl_GetString(to);
			currentPathEndPosition = path + nextCheckpoint;
			if (temp != NULL) {
			    Tcl_DecrRefCount(temp);
			}
			temp = to;

			/*
			 * Reset variables so we can restart normalization.
			 */

			isDrive = 1;
			Tcl_DStringFree(&dsNorm);
			Tcl_DStringInit(&dsNorm);
			Tcl_DStringFree(&ds);
			continue;
		    }
		}

#ifndef TclNORM_LONG_PATH
		/*
		 * Now we convert the tail of the current path to its 'long
		 * form', and append it to 'dsNorm' which holds the current
		 * normalized path
		 */

		if (isDrive) {
		    WCHAR drive = ((WCHAR*)nativePath)[0];
		    if (drive >= L'a') {
			drive -= (L'a' - L'A');
			((WCHAR*)nativePath)[0] = drive;
		    }
		    Tcl_DStringAppend(&dsNorm, nativePath,
			    Tcl_DStringLength(&ds));
		} else {
		    char *checkDots = NULL;

		    if (lastValidPathEnd[1] == '.') {
			checkDots = lastValidPathEnd + 1;
			while (checkDots < currentPathEndPosition) {
			    if (*checkDots != '.') {
				checkDots = NULL;
				break;
			    }
			    checkDots++;
			}
		    }
		    if (checkDots != NULL) {
			int dotLen = currentPathEndPosition - lastValidPathEnd;

			/*
			 * Path is just dots. We shouldn't really ever see a
			 * path like that. However, to be nice we at least
			 * don't mangle the path - we just add the dots as a
			 * path segment and continue.

			 */

			Tcl_DStringAppend(&dsNorm, (TCHAR *)

				((WCHAR*)(nativePath + Tcl_DStringLength(&ds))

				- dotLen), (int)(dotLen * sizeof(WCHAR)));
		    } else {
			/*
			 * Normal path.
			 */

			WIN32_FIND_DATAW fData;
			HANDLE handle;

			handle = FindFirstFileW((WCHAR*)nativePath, &fData);
			if (handle == INVALID_HANDLE_VALUE) {
			    /*
			     * This is usually the '/' in 'c:/' at end of
			     * string.
			     */

			    Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
				    sizeof(WCHAR));
			} else {
			    WCHAR *nativeName;

			    if (fData.cFileName[0] != '\0') {
				nativeName = fData.cFileName;
			    } else {
				nativeName = fData.cAlternateFileName;
			    }
			    FindClose(handle);
			    Tcl_DStringAppend(&dsNorm, (CONST char*)L"/",
				    sizeof(WCHAR));
			    Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName,
				    (int) (wcslen(nativeName)*sizeof(WCHAR)));
			}
		    }
		}
#endif
		Tcl_DStringFree(&ds);
		lastValidPathEnd = currentPathEndPosition;
		if (cur == 0) {
		    break;
		}

		/*
		 * If we get here, we've got past one directory delimiter, so
		 * we know it is no longer a drive.
		 */

		isDrive = 0;
	    }
	    currentPathEndPosition++;
	}

#ifdef TclNORM_LONG_PATH
	/*
	 * Convert the entire known path to long form.
	 */

	if (1) {
	    WCHAR wpath[MAX_PATH];

	    CONST char *nativePath =
		    Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
	    DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)(
		    nativePath, (TCHAR *) wpath, MAX_PATH);

	    /*
	     * We have to make the drive letter uppercase.
	     */

	    if (wpath[0] >= L'a') {
		wpath[0] -= (L'a' - L'A');
	    }
	    Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR));
	    Tcl_DStringFree(&ds);
	}
#endif
    }

    /*
     * Common code path for all Windows platforms.
     */

    nextCheckpoint = currentPathEndPosition - path;
    if (lastValidPathEnd != NULL) {
	/*
	 * Concatenate the normalized string in dsNorm with the tail of the
	 * path which we didn't recognise. The string in dsNorm is in the

	 * native encoding, so we have to convert it to Utf.
	 */

	Tcl_DString dsTemp;

	Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
		Tcl_DStringLength(&dsNorm), &dsTemp);
	nextCheckpoint = Tcl_DStringLength(&dsTemp);
	if (*lastValidPathEnd != 0) {
	    /*
	     * Not the end of the string.
	     */

	    int len;
	    char *path;
	    Tcl_Obj *tmpPathPtr;

	    tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
		    nextCheckpoint);
	    Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
	    path = Tcl_GetStringFromObj(tmpPathPtr, &len);
	    Tcl_SetStringObj(pathPtr, path, len);
	    Tcl_DecrRefCount(tmpPathPtr);
	} else {
	    /*
	     * End of string was reached above.
	     */

	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
		    nextCheckpoint);
	}
	Tcl_DStringFree(&dsTemp);
    }
    Tcl_DStringFree(&dsNorm);
    return nextCheckpoint;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinVolumeRelativeNormalize --
 *
 *	Only Windows has volume-relative paths. These paths are rather rare,
 *	but it is nice if Tcl can handle them. It is much better if we can
 *	handle them here, rather than in the native fs code, because we really
 *	need to have a real absolute path just below.
 *
 *	We do not let this block compile on non-Windows platforms because the
 *	test suite's manual forcing of tclPlatform can otherwise cause this
 *	code path to be executed, causing various errors because
 *	volume-relative paths really do not exist.
 *
 * Results:
 *	A valid normalized path.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr)
    Tcl_Interp *interp;
    CONST char *path;
    Tcl_Obj **useThisCwdPtr;
{
    Tcl_Obj *absolutePath, *useThisCwd;

    useThisCwd = Tcl_FSGetCwd(interp);
    if (useThisCwd == NULL) {
	return NULL;
    }

    if (path[0] == '/') {
	/*
	 * Path of form /foo/bar which is a path in the root directory of the
	 * current volume.
	 */

	CONST char *drive = Tcl_GetString(useThisCwd);

	absolutePath = Tcl_NewStringObj(drive,2);
	Tcl_AppendToObj(absolutePath, path, -1);
	Tcl_IncrRefCount(absolutePath);

	/*
	 * We have a refCount on the cwd.
	 */
    } else {
	/*
	 * Path of form C:foo/bar, but this only makes sense if the cwd is
	 * also on drive C.
	 */

	int cwdLen;
	CONST char *drive =
		Tcl_GetStringFromObj(useThisCwd, &cwdLen);
	char drive_cur = path[0];

	if (drive_cur >= 'a') {
	    drive_cur -= ('a' - 'A');
	}
	if (drive[0] == drive_cur) {
	    absolutePath = Tcl_DuplicateObj(useThisCwd);

	    /*
	     * We have a refCount on the cwd, which we will release later.

	     */

	    if (drive[cwdLen-1] != '/' && (path[2] != '\0')) {
		/*
		 * Only add a trailing '/' if needed, which is if there isn't

		 * one already, and if we are going to be adding some more
		 * characters.
		 */

		Tcl_AppendToObj(absolutePath, "/", 1);
	    }
	} else {
	    Tcl_DecrRefCount(useThisCwd);
	    useThisCwd = NULL;

	    /*
	     * The path is not in the current drive, but is volume-relative.

	     * The way Tcl 8.3 handles this is that it treats such a path as
	     * relative to the root of the drive. We therefore behave the same

	     * here. This behaviour is, however, different to that of the
	     * windows command-line. If we want to fix this at some point in

	     * the future (at the expense of a behaviour change to Tcl), we
	     * could use the '_dgetdcwd' Win32 API to get the drive's cwd.

	     */

	    absolutePath = Tcl_NewStringObj(path, 2);
	    Tcl_AppendToObj(absolutePath, "/", 1);
	}
	Tcl_IncrRefCount(absolutePath);
	Tcl_AppendToObj(absolutePath, path+2, -1);
    }
    *useThisCwdPtr = useThisCwd;
    return absolutePath;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeToNormalized --
 *
 *	Convert native format to a normalized path object, with refCount of
 *	zero.
 *
 *	Currently assumes all native paths are actually normalized already, so
 *	if the path given is not normalized this will actually just convert to

 *	a valid string path, but not necessarily a normalized one.
 *
 * Results:
 *	A valid normalized path.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpNativeToNormalized(clientData)
    ClientData clientData;
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;
    int len;

    char *copy;
    char *p;
    Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);

    copy = Tcl_DStringValue(&ds);
    len = Tcl_DStringLength(&ds);

    /*
     * Certain native path representations on Windows have this special prefix
     * to indicate that they are to be treated specially. For example
     * extremely long paths, or symlinks.
     */

    if (*copy == '\\') {
	if (0 == strncmp(copy,"\\??\\",4)) {
	    copy += 4;
	    len -= 4;
	} else if (0 == strncmp(copy,"\\\\?\\",4)) {
	    copy += 4;
	    len -= 4;
	}
    }

    /*
     * Ensure we are using forward slashes only.
     */

    for (p = copy; *p != '\0'; p++) {
	if (*p == '\\') {
	    *p = '/';
	}
    }

    objPtr = Tcl_NewStringObj(copy,len);
    Tcl_DStringFree(&ds);

    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeCreateNativeRep --
 *
 *	Create a native representation for the given path.
 *
 * Results:
 *	The nativePath representation.
 *
 * Side effects:
 *	Memory will be allocated. The path may need to be normalized.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeCreateNativeRep(pathPtr)
    Tcl_Obj* pathPtr;
{
    char *nativePathPtr;
    Tcl_DString ds;
    Tcl_Obj* validPathPtr;
    int len;
    char *str;

    if (TclFSCwdIsNative()) {
	/*
	 * The cwd is native, which means we can use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).

	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_WinUtfToTChar(str, len, &ds);
    if (tclWinProcs->useWide) {
	len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
    } else {
	len = Tcl_DStringLength(&ds) + sizeof(char);
    }
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc((unsigned) len);
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --
 *
 *	Duplicate the native representation.
 *
 * Results:
 *	The copied native representation, or NULL if it is not possible to
 *	copy the representation.
 *
 * Side effects:
 *	Memory allocation for the copy.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeDupInternalRep(clientData)
    ClientData clientData;
{
    char *copy;
    size_t len;

    if (clientData == NULL) {
	return NULL;
    }

    if (tclWinProcs->useWide) {
	/*
	 * Unicode representation when running on NT/2K/XP.
	 */

	len = sizeof(WCHAR) * (wcslen((CONST WCHAR *) clientData) + 1);
    } else {
	/*
	 * ANSI representation when running on 95/98/ME.
	 */

	len = sizeof(char) * (strlen((CONST char *) clientData) + 1);
    }

    copy = (char *) ckalloc(len);
    memcpy((VOID *) copy, (VOID *) clientData, len);
    return (ClientData) copy;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpUtime --
 *
 *	Set the modification date for a file.
 *
 * Results:
 *	0 on success, -1 on error.
 *
 * Side effects:
 *	Sets errno to a representation of any Windows problem that's observed
 *	in the process.
 *
 *---------------------------------------------------------------------------
 */
int
TclpUtime(pathPtr, tval)
    Tcl_Obj *pathPtr;		/* File to modify */
    struct utimbuf *tval;	/* New modification date structure */
{
    int res = 0;
    HANDLE fileHandle;
    FILETIME lastAccessTime, lastModTime;

    FromCTime(tval->actime, &lastAccessTime);
    FromCTime(tval->modtime, &lastModTime);

    /*
     * We use the native APIs (not 'utime') because there are some daylight
     * savings complications that utime gets wrong.
     */

    fileHandle = (tclWinProcs->createFileProc) (
	    (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr),
	    FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING,
	    FILE_ATTRIBUTE_NORMAL, NULL);

    if (fileHandle == INVALID_HANDLE_VALUE ||
	    !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
	TclWinConvertError(GetLastError());
	res = -1;
    }
    if (fileHandle != INVALID_HANDLE_VALUE) {
	CloseHandle(fileHandle);
    }
    return res;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinInit.c.

1
2
3
4
5
6
7
8
9



10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
/* 
 * tclWinInit.c --
 *
 *	Contains the Windows-specific interpreter initialization functions.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *



 * RCS: @(#) $Id: tclWinInit.c,v 1.64 2004/11/30 19:34:52 dgp Exp $
 */

#include "tclWinInt.h"
#include <winnt.h>
#include <winbase.h>
#include <lmcons.h>

/*
 * GetUserName() is found in advapi32.dll
 */
#ifdef _MSC_VER
#   pragma comment(lib, "advapi32.lib")
#endif

/*
 * The following declaration is a workaround for some Microsoft brain damage.
 * The SYSTEM_INFO structure is different in various releases, even though the
 * layout is the same.  So we overlay our own structure on top of it so we
 * can access the interesting slots in a uniform way.
 */

typedef struct {
    WORD wProcessorArchitecture;
    WORD wReserved;
} OemId;

/*
 * The following macros are missing from some versions of winnt.h.
 */

#ifndef PROCESSOR_ARCHITECTURE_INTEL
#define PROCESSOR_ARCHITECTURE_INTEL 0
#endif
#ifndef PROCESSOR_ARCHITECTURE_MIPS
#define PROCESSOR_ARCHITECTURE_MIPS  1
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA
#define PROCESSOR_ARCHITECTURE_ALPHA 2
#endif
#ifndef PROCESSOR_ARCHITECTURE_PPC
#define PROCESSOR_ARCHITECTURE_PPC   3
#endif
#ifndef PROCESSOR_ARCHITECTURE_SHX
#define PROCESSOR_ARCHITECTURE_SHX   4
#endif
#ifndef PROCESSOR_ARCHITECTURE_ARM
#define PROCESSOR_ARCHITECTURE_ARM   5
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA64
#define PROCESSOR_ARCHITECTURE_IA64  6
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
#define PROCESSOR_ARCHITECTURE_ALPHA64 7
#endif
#ifndef PROCESSOR_ARCHITECTURE_MSIL
#define PROCESSOR_ARCHITECTURE_MSIL  8
#endif
#ifndef PROCESSOR_ARCHITECTURE_AMD64
#define PROCESSOR_ARCHITECTURE_AMD64 9
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
#endif

/*
 * The following arrays contain the human readable strings for the Windows
 * platform and processor values.
 */










>
>
>
|

















|
|












|


|


|


|


|


|


|


|


|


|


|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
/* 
 * tclWinInit.c --
 *
 *	Contains the Windows-specific interpreter initialization functions.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinInit.c,v 1.64.2.2 2005/08/02 18:17:17 dgp Exp $
 */

#include "tclWinInt.h"
#include <winnt.h>
#include <winbase.h>
#include <lmcons.h>

/*
 * GetUserName() is found in advapi32.dll
 */
#ifdef _MSC_VER
#   pragma comment(lib, "advapi32.lib")
#endif

/*
 * The following declaration is a workaround for some Microsoft brain damage.
 * The SYSTEM_INFO structure is different in various releases, even though the
 * layout is the same. So we overlay our own structure on top of it so we can
 * access the interesting slots in a uniform way.
 */

typedef struct {
    WORD wProcessorArchitecture;
    WORD wReserved;
} OemId;

/*
 * The following macros are missing from some versions of winnt.h.
 */

#ifndef PROCESSOR_ARCHITECTURE_INTEL
#define PROCESSOR_ARCHITECTURE_INTEL		0
#endif
#ifndef PROCESSOR_ARCHITECTURE_MIPS
#define PROCESSOR_ARCHITECTURE_MIPS		1
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA
#define PROCESSOR_ARCHITECTURE_ALPHA		2
#endif
#ifndef PROCESSOR_ARCHITECTURE_PPC
#define PROCESSOR_ARCHITECTURE_PPC		3
#endif
#ifndef PROCESSOR_ARCHITECTURE_SHX
#define PROCESSOR_ARCHITECTURE_SHX		4
#endif
#ifndef PROCESSOR_ARCHITECTURE_ARM
#define PROCESSOR_ARCHITECTURE_ARM		5
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA64
#define PROCESSOR_ARCHITECTURE_IA64		6
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
#define PROCESSOR_ARCHITECTURE_ALPHA64		7
#endif
#ifndef PROCESSOR_ARCHITECTURE_MSIL
#define PROCESSOR_ARCHITECTURE_MSIL		8
#endif
#ifndef PROCESSOR_ARCHITECTURE_AMD64
#define PROCESSOR_ARCHITECTURE_AMD64		9
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64	10
#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
#define PROCESSOR_ARCHITECTURE_UNKNOWN		0xFFFF
#endif

/*
 * The following arrays contain the human readable strings for the Windows
 * platform and processor values.
 */

91
92
93
94
95
96
97

98
99
100
101
102
103
104
    "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
    "amd64", "ia32_on_win64"
};

/*
 * The default directory in which the init.tcl file is expected to be found.
 */

static TclInitProcessGlobalValueProc	InitializeDefaultLibraryDir;
static ProcessGlobalValue defaultLibraryDir =
	{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};

static void		AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
static int		ToUtf(CONST WCHAR *wSrc, char *dst);








>







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
    "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
    "amd64", "ia32_on_win64"
};

/*
 * The default directory in which the init.tcl file is expected to be found.
 */

static TclInitProcessGlobalValueProc	InitializeDefaultLibraryDir;
static ProcessGlobalValue defaultLibraryDir =
	{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};

static void		AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
static int		ToUtf(CONST WCHAR *wSrc, char *dst);

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

void
TclpInitPlatform()
{
    tclPlatform = TCL_PLATFORM_WINDOWS;

    /*
     * The following code stops Windows 3.X and Windows NT 3.51 from 
     * automatically putting up Sharing Violation dialogs, e.g, when 
     * someone tries to access a file that is locked or a drive with no 
     * disk in it.  Tcl already returns the appropriate error to the 
     * caller, and they can decide to put up their own dialog in response 
     * to that failure.  
     *
     * Under 95 and NT 4.0, this is a NOOP because the system doesn't 
     * automatically put up dialogs when the above operations fail.
     */

    SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);

#ifdef STATIC_BUILD
    /*
     * If we are in a statically linked executable, then we need to
     * explicitly initialize the Windows function tables here since
     * DllMain() will not be invoked.
     */

    TclWinInit(GetModuleHandle(NULL));
#endif
}

/*
 *-------------------------------------------------------------------------
 *
 * TclpInitLibraryPath --
 *
 *      This is the fallback routine that sets the library path
 *      if the application has not set one by the first time
 *      it is needed.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Sets the library path to an initial value.  
 *
 *-------------------------------------------------------------------------
 */  

void
TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr;
    char installLib[LIBRARY_SIZE];
    char *bytes;

    pathPtr = Tcl_NewObj();

    /*
     * Initialize the substring used when locating the script library.  The
     * installLib variable computes the script library path relative to the
     * installed DLL.
     */

    sprintf(installLib, "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable.
     * If the last dirname in the TCL_LIBRARY path does not match the
     * last dirname in the installLib variable, use the last dir name
     * of installLib in addition to the orginal TCL_LIBRARY path.
     */

    AppendEnvironment(pathPtr, installLib);

    /*
     * Look for the library in its default location.
     */

    Tcl_ListObjAppendElement(NULL, pathPtr,
	    TclGetProcessGlobalValue(&defaultLibraryDir));

    *encodingPtr = NULL;
    bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
    *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1);
    memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t)(*lengthPtr)+1);
    Tcl_DecrRefCount(pathPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * AppendEnvironment --
 *
 *	Append the value of the TCL_LIBRARY environment variable onto the
 *	path pointer.  If the env variable points to another version of
 *	tcl (e.g. "tcl7.6") also append the path to this version (e.g.,
 *	"tcl7.6/../tcl8.2")
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.







|
|
|
|
|
<

|







|
|
|











|
|
<


|


|


















|







|
|
|
|







>















|
|
|







127
128
129
130
131
132
133
134
135
136
137
138

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

void
TclpInitPlatform()
{
    tclPlatform = TCL_PLATFORM_WINDOWS;

    /*
     * The following code stops Windows 3.X and Windows NT 3.51 from
     * automatically putting up Sharing Violation dialogs, e.g, when someone
     * tries to access a file that is locked or a drive with no disk in it.
     * Tcl already returns the appropriate error to the caller, and they can
     * decide to put up their own dialog in response to that failure.

     *
     * Under 95 and NT 4.0, this is a NOOP because the system doesn't
     * automatically put up dialogs when the above operations fail.
     */

    SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);

#ifdef STATIC_BUILD
    /*
     * If we are in a statically linked executable, then we need to explicitly
     * initialize the Windows function tables here since DllMain() will not be
     * invoked.
     */

    TclWinInit(GetModuleHandle(NULL));
#endif
}

/*
 *-------------------------------------------------------------------------
 *
 * TclpInitLibraryPath --
 *
 *	This is the fallback routine that sets the library path if the
 *	application has not set one by the first time it is needed.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the library path to an initial value.  
 *
 *-------------------------------------------------------------------------
 */  

void
TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr;
    char installLib[LIBRARY_SIZE];
    char *bytes;

    pathPtr = Tcl_NewObj();

    /*
     * Initialize the substring used when locating the script library. The
     * installLib variable computes the script library path relative to the
     * installed DLL.
     */

    sprintf(installLib, "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the orginal TCL_LIBRARY path.
     */

    AppendEnvironment(pathPtr, installLib);

    /*
     * Look for the library in its default location.
     */

    Tcl_ListObjAppendElement(NULL, pathPtr,
	    TclGetProcessGlobalValue(&defaultLibraryDir));

    *encodingPtr = NULL;
    bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
    *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1);
    memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t)(*lengthPtr)+1);
    Tcl_DecrRefCount(pathPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * AppendEnvironment --
 *
 *	Append the value of the TCL_LIBRARY environment variable onto the path
 *	pointer. If the env variable points to another version of tcl (e.g.
 *	"tcl7.6") also append the path to this version (e.g.,
 *	"tcl7.6/../tcl8.2")
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
241
242
243
244
245
246
247
248
249
250
251

252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
    char buf[MAX_PATH * TCL_UTF_MAX];
    Tcl_Obj *objPtr;
    Tcl_DString ds;
    CONST char **pathv;
    char *shortlib;

    /*
     * The shortlib value needs to be the tail component of the
     * lib path. For example, "lib/tcl8.4" -> "tcl8.4" while
     * "usr/share/tcl8.5" -> "tcl8.5".
     */

    for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) {
	if (*shortlib == '/') {
	    if ((unsigned)(shortlib - lib) == strlen(lib) - 1) {
		Tcl_Panic("last character in lib cannot be '/'");
	    }
	    shortlib++;
	    break;
	}
    }
    if (shortlib == lib) {
	Tcl_Panic("no '/' character found in lib");
    }

    /*
     * The "L" preceeding the TCL_LIBRARY string is used to tell VC++
     * that this is a unicode string.
     */

    if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
	buf[0] = '\0';
	GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
    } else {
	ToUtf(wBuf, buf);
    }

    if (buf[0] != '\0') {
	objPtr = Tcl_NewStringObj(buf, -1);
	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);

	TclWinNoBackslash(buf);
	Tcl_SplitPath(buf, &pathc, &pathv);

	/* 
	 * The lstrcmpi() will work even if pathv[pathc - 1] is random
	 * UTF-8 chars because I know shortlib is ascii.
	 */

	if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
	    CONST char *str;

	    /*
	     * TCL_LIBRARY is set but refers to a different tcl
	     * installation than the current version.  Try fiddling with the
	     * specified directory to make it refer to this installation by
	     * removing the old "tclX.Y" and substituting the current
	     * version string.
	     */

	    pathv[pathc - 1] = shortlib;
	    Tcl_DStringInit(&ds);
	    str = Tcl_JoinPath(pathc, pathv, &ds);
	    objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
	    Tcl_DStringFree(&ds);
	} else {
	    objPtr = Tcl_NewStringObj(buf, -1);
	}
	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	ckfree((char *) pathv);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * InitializeDefaultLibraryDir --
 *
 *	Locate the Tcl script library default location relative to
 *	the location of the Tcl DLL.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|
|
<

>














|
|

















|
|




>

|
|
|
|
<




















|
|







244
245
246
247
248
249
250
251
252

253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
    char buf[MAX_PATH * TCL_UTF_MAX];
    Tcl_Obj *objPtr;
    Tcl_DString ds;
    CONST char **pathv;
    char *shortlib;

    /*
     * The shortlib value needs to be the tail component of the lib path. For
     * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5".

     */

    for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) {
	if (*shortlib == '/') {
	    if ((unsigned)(shortlib - lib) == strlen(lib) - 1) {
		Tcl_Panic("last character in lib cannot be '/'");
	    }
	    shortlib++;
	    break;
	}
    }
    if (shortlib == lib) {
	Tcl_Panic("no '/' character found in lib");
    }

    /*
     * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that
     * this is a unicode string.
     */

    if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
	buf[0] = '\0';
	GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
    } else {
	ToUtf(wBuf, buf);
    }

    if (buf[0] != '\0') {
	objPtr = Tcl_NewStringObj(buf, -1);
	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);

	TclWinNoBackslash(buf);
	Tcl_SplitPath(buf, &pathc, &pathv);

	/* 
	 * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8
	 * chars because I know shortlib is ascii.
	 */

	if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
	    CONST char *str;

	    /*
	     * TCL_LIBRARY is set but refers to a different tcl installation
	     * than the current version. Try fiddling with the specified
	     * directory to make it refer to this installation by removing the
	     * old "tclX.Y" and substituting the current version string.

	     */

	    pathv[pathc - 1] = shortlib;
	    Tcl_DStringInit(&ds);
	    str = Tcl_JoinPath(pathc, pathv, &ds);
	    objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
	    Tcl_DStringFree(&ds);
	} else {
	    objPtr = Tcl_NewStringObj(buf, -1);
	}
	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	ckfree((char *) pathv);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * InitializeDefaultLibraryDir --
 *
 *	Locate the Tcl script library default location relative to the
 *	location of the Tcl DLL.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
338
339
340
341
342
343
344

345
346
347
348
349
350
351

352
353
354
355
356
357
358
    char *end, *p;

    if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
	GetModuleFileNameA(hModule, name, MAX_PATH);
    } else {
	ToUtf(wName, name);
    }

	end = strrchr(name, '\\');
	*end = '\0';
	p = strrchr(name, '\\');
	if (p != NULL) {
	    end = p;
	}
	*end = '\\';

    TclWinNoBackslash(name);
    sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
    *lengthPtr = strlen(name);
    *valuePtr = ckalloc((unsigned int) *lengthPtr + 1);
    *encodingPtr = NULL;
    memcpy((VOID *) *valuePtr, (VOID *) name, (size_t) *lengthPtr + 1);
}







>
|
|
|
|
|
|
|
>







341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
    char *end, *p;

    if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
	GetModuleFileNameA(hModule, name, MAX_PATH);
    } else {
	ToUtf(wName, name);
    }

    end = strrchr(name, '\\');
    *end = '\0';
    p = strrchr(name, '\\');
    if (p != NULL) {
	end = p;
    }
    *end = '\\';

    TclWinNoBackslash(name);
    sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
    *lengthPtr = strlen(name);
    *valuePtr = ckalloc((unsigned int) *lengthPtr + 1);
    *encodingPtr = NULL;
    memcpy((VOID *) *valuePtr, (VOID *) name, (size_t) *lengthPtr + 1);
}
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinEncodingsCleanup --
 *
 *	Reset information to its original state in finalization to
 *	allow for reinitialization to be possible.  This must not
 *	be called until after the filesystem has been finalised, or
 *	exit crashes may occur when using virtual filesystems.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Static information reset to startup state.
 *







|
|
|
|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
}

/*
 *---------------------------------------------------------------------------
 *
 * TclWinEncodingsCleanup --
 *
 *	Reset information to its original state in finalization to allow for
 *	reinitialization to be possible. This must not be called until after
 *	the filesystem has been finalised, or exit crashes may occur when
 *	using virtual filesystems.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Static information reset to startup state.
 *
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445











446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetInitialEncodings --
 *
 *	Based on the locale, determine the encoding of the operating
 *	system and the default encoding for newly opened files.
 *
 *	Called at process initialization time, and part way through
 *	startup, we verify that the initial encodings were correctly
 *	setup.  Depending on Tcl's environment, there may not have been
 *	enough information first time through (above).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The Tcl library path is converted from native encoding to UTF-8,
 *	on the first call, and the encodings may be changed on first or
 *	second call.
 *
 *---------------------------------------------------------------------------
 */

void
TclpSetInitialEncodings()
{
    int platformId, useWide;
    Tcl_DString encodingName;












    platformId = TclWinGetPlatformId();
    useWide = ((platformId == VER_PLATFORM_WIN32_NT)
	    || (platformId == VER_PLATFORM_WIN32_CE));
    TclWinSetInterfaces(useWide);

    Tcl_SetSystemEncoding(NULL,
	    TclpGetEncodingNameFromEnvironment(&encodingName));
    Tcl_DStringFree(&encodingName);
}

CONST char *
TclpGetEncodingNameFromEnvironment(bufPtr)
    Tcl_DString *bufPtr;
{
    Tcl_DStringInit(bufPtr);
    wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
    return Tcl_DStringValue(bufPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetVariables --
 *
 *	Performs platform-specific interpreter initialization related to
 *	the tcl_platform and env variables, and other platform-specific
 *	things.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets "tcl_platform", and "env(HOME)" Tcl variables.
 *







|
|

|
|
|
|





|
|
|







<

>
>
>
>
>
>
>
>
>
>
>





<
<
<
<
















|
|
<







420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465




466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483

484
485
486
487
488
489
490
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetInitialEncodings --
 *
 *	Based on the locale, determine the encoding of the operating system
 *	and the default encoding for newly opened files.
 *
 *	Called at process initialization time, and part way through startup,
 *	we verify that the initial encodings were correctly setup. Depending
 *	on Tcl's environment, there may not have been enough information first
 *	time through (above).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The Tcl library path is converted from native encoding to UTF-8, on
 *	the first call, and the encodings may be changed on first or second
 *	call.
 *
 *---------------------------------------------------------------------------
 */

void
TclpSetInitialEncodings()
{

    Tcl_DString encodingName;
    
    TclpSetInterfaces();
    Tcl_SetSystemEncoding(NULL,
	    TclpGetEncodingNameFromEnvironment(&encodingName));
    Tcl_DStringFree(&encodingName);
}

void
TclpSetInterfaces()
{
    int platformId, useWide;

    platformId = TclWinGetPlatformId();
    useWide = ((platformId == VER_PLATFORM_WIN32_NT)
	    || (platformId == VER_PLATFORM_WIN32_CE));
    TclWinSetInterfaces(useWide);




}

CONST char *
TclpGetEncodingNameFromEnvironment(bufPtr)
    Tcl_DString *bufPtr;
{
    Tcl_DStringInit(bufPtr);
    wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
    return Tcl_DStringValue(bufPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpSetVariables --
 *
 *	Performs platform-specific interpreter initialization related to the
 *	tcl_platform and env variables, and other platform-specific things.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets "tcl_platform", and "env(HOME)" Tcl variables.
 *
519
520
521
522
523
524
525
526
527
528
529

530
531
532
533
534
535
536
	Tcl_SetVar2(interp, "tcl_platform", "machine",
		processors[oemId->wProcessorArchitecture],
		TCL_GLOBAL_ONLY);
    }

#ifdef _DEBUG
    /*
     * The existence of the "debug" element of the tcl_platform array indicates
     * that this particular Tcl shell has been compiled with debug information.
     * Using "info exists tcl_platform(debug)" a Tcl script can direct the 
     * interpreter to load debug versions of DLLs with the load command.

     */

    Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
	    TCL_GLOBAL_ONLY);
#endif

    /*







|
|
|
|
>







529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
	Tcl_SetVar2(interp, "tcl_platform", "machine",
		processors[oemId->wProcessorArchitecture],
		TCL_GLOBAL_ONLY);
    }

#ifdef _DEBUG
    /*
     * The existence of the "debug" element of the tcl_platform array
     * indicates that this particular Tcl shell has been compiled with debug
     * information. Using "info exists tcl_platform(debug)" a Tcl script can
     * direct the interpreter to load debug versions of DLLs with the load
     * command.
     */

    Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
	    TCL_GLOBAL_ONLY);
#endif

    /*
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name.  On Unix this 
 *	routine is case sensetive, on Windows this matches mioxed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|
|
|
<







585
586
587
588
589
590
591
592
593
594
595
596
597
598
599

600
601
602
603
604
605
606
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensetive, on Windows this matches mioxed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or -1 if there is no such entry. The integer at *lengthPtr is
 *	filled in with the length of name (if a matching entry is found) or
 *	the length of the environ array (if no matching entry is found).

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
{
    int i, length, result = -1;
    register CONST char *env, *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive
     * comparison.
     */

    length = strlen(name);
    nameUpper = (char *) ckalloc((unsigned) length+1);
    memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1);
    Tcl_UtfToUpper(nameUpper);

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert
	 * the name to all upper case, so we do not have to convert
	 * all the characters after the equal sign.
	 */

	envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}







|
<










|
|
|







615
616
617
618
619
620
621
622

623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
{
    int i, length, result = -1;
    register CONST char *env, *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive comparison.

     */

    length = strlen(name);
    nameUpper = (char *) ckalloc((unsigned) length+1);
    memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1);
    Tcl_UtfToUpper(nameUpper);

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert the name
	 * to all upper case, so we do not have to convert all the characters
	 * after the equal sign.
	 */

	envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
647
648
649
650
651
652
653
654
655
656
657
658








	}

	Tcl_DStringFree(&envString);
    }

    *lengthPtr = i;

    done:
    Tcl_DStringFree(&envString);
    ckfree(nameUpper);
    return result;
}















|




>
>
>
>
>
>
>
>
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
	}

	Tcl_DStringFree(&envString);
    }

    *lengthPtr = i;

  done:
    Tcl_DStringFree(&envString);
    ckfree(nameUpper);
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinLoad.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

58
59
60
61
62
63
64
65

66
67

68
69
70
71
72
73
74
75
76

77
78
79
80
81

82
83
84

85
86
87
88
89
90

91
92

93
94
95
96
97
98

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232








/* 
 * tclWinLoad.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the Windows "LoadLibrary" and "GetProcAddress"
 *	API for dynamic loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinLoad.c,v 1.17 2003/09/08 20:12:07 davygrvy Exp $
 */

#include "tclWinInt.h"


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    HINSTANCE handle;
    CONST TCHAR *nativeName;

    /* 
     * First try the full path the user gave us.  This is particularly
     * important if the cwd is inside a vfs, and we are trying to load
     * using a relative path.
     */

    nativeName = Tcl_FSGetNativePath(pathPtr);
    handle = (*tclWinProcs->loadLibraryProc)(nativeName);
    if (handle == NULL) {
	/* 
	 * Let the OS loader examine the binary search path for
	 * whatever string the user gave us which hopefully refers
	 * to a file on the binary path
	 */

	Tcl_DString ds;
        char *fileName = Tcl_GetString(pathPtr);

	nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
	handle = (*tclWinProcs->loadLibraryProc)(nativeName);
	Tcl_DStringFree(&ds);
    }

    *loadHandle = (Tcl_LoadHandle) handle;
    
    if (handle == NULL) {
	DWORD lastError = GetLastError();

#if 0
	/*
	 * It would be ideal if the FormatMessage stuff worked better,
	 * but unfortunately it doesn't seem to want to...
	 */

	LPTSTR lpMsgBuf;
	char *buf;
	int size;

	size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
		FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
		(LPTSTR) &lpMsgBuf, 0, NULL);
	buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
	sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
#endif

	Tcl_AppendResult(interp, "couldn't load library \"",
			 Tcl_GetString(pathPtr), "\": ", (char *) NULL);

	/*
	 * Check for possible DLL errors.  This doesn't work quite right,
	 * because Windows seems to only return ERROR_MOD_NOT_FOUND for
	 * just about any problem, but it's better than nothing.  It'd be
	 * even better if there was a way to get what DLLs
	 */

	switch (lastError) {
	    case ERROR_MOD_NOT_FOUND:
	    case ERROR_DLL_NOT_FOUND:
		Tcl_AppendResult(interp, "this library or a dependent library",
			" could not be found in library path",
			(char *) NULL);
		break;
	    case ERROR_PROC_NOT_FOUND:
		Tcl_AppendResult(interp, "A function specified in the import",
			" table could not be resolved by the system.  Windows",
			" is not telling which one, I'm sorry.",
			(char *) NULL);
		break;
	    case ERROR_INVALID_DLL:
		Tcl_AppendResult(interp, "this library or a dependent library",
			" is damaged", (char *) NULL);
		break;
	    case ERROR_DLL_INIT_FAILED:
		Tcl_AppendResult(interp, "the library initialization",
			" routine failed", (char *) NULL);
		break;
	    default:
		TclWinConvertError(lastError);
		Tcl_AppendResult(interp, Tcl_PosixError(interp),
			(char *) NULL);
	}
	return TCL_ERROR;
    } else {
	*unloadProcPtr = &TclpUnloadFile;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_PackageInitProc *proc = NULL;
    HINSTANCE handle = (HINSTANCE)loadHandle;

    /*
     * For each symbol, check for both Symbol and _Symbol, since Borland
     * generates C symbols with a leading '_' by default.
     */

    proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
    if (proc == NULL) {
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, "_", 1);
	symbol = Tcl_DStringAppend(&ds, symbol, -1);
	proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
	Tcl_DStringFree(&ds);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    HINSTANCE handle;

    handle = (HINSTANCE) loadHandle;
    FreeLibrary(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
 *	name, this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a
 *	package name;  generic code will then try to guess the package
 *	from the file name.  A return value of 1 would have meant that
 *	we figured out the package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
				 * package name to this if possible. */
{
    return 0;
}








|


|
|
|



|
|

|










|
|


|
|













|

|

|
|




|
|
|
|

>



|
|
|
|

>

|
>






|


>


|
|

>



>






>

|
>

|
|
|
|

>

|
|
|
|
<
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<













|
|


|
|
|



>

|















>














|
|
|












|
|
|
<












|
|


|
|
|
|











|
|



>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

113
114
115
116
117

118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203

204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
/*
 * tclWinLoad.c --
 *
 *	This function provides a version of the TclLoadFile that works with
 *	the Windows "LoadLibrary" and "GetProcAddress" API for dynamic
 *	loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinLoad.c,v 1.17.2.1 2005/08/02 18:17:18 dgp Exp $
 */

#include "tclWinInt.h"


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    HINSTANCE handle;
    CONST TCHAR *nativeName;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    nativeName = Tcl_FSGetNativePath(pathPtr);
    handle = (*tclWinProcs->loadLibraryProc)(nativeName);
    if (handle == NULL) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;
	char *fileName = Tcl_GetString(pathPtr);

	nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
	handle = (*tclWinProcs->loadLibraryProc)(nativeName);
	Tcl_DStringFree(&ds);
    }

    *loadHandle = (Tcl_LoadHandle) handle;

    if (handle == NULL) {
	DWORD lastError = GetLastError();

#if 0
	/*
	 * It would be ideal if the FormatMessage stuff worked better, but
	 * unfortunately it doesn't seem to want to...
	 */

	LPTSTR lpMsgBuf;
	char *buf;
	int size;

	size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
		FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
		(LPTSTR) &lpMsgBuf, 0, NULL);
	buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
	sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
#endif

	Tcl_AppendResult(interp, "couldn't load library \"",
		Tcl_GetString(pathPtr), "\": ", (char *) NULL);

	/*
	 * Check for possible DLL errors. This doesn't work quite right,
	 * because Windows seems to only return ERROR_MOD_NOT_FOUND for just
	 * about any problem, but it's better than nothing. It'd be even
	 * better if there was a way to get what DLLs
	 */

	switch (lastError) {
	case ERROR_MOD_NOT_FOUND:
	case ERROR_DLL_NOT_FOUND:
	    Tcl_AppendResult(interp, "this library or a dependent library",
		    " could not be found in library path", (char *) NULL);

	    break;
	case ERROR_PROC_NOT_FOUND:
	    Tcl_AppendResult(interp, "A function specified in the import",
		    " table could not be resolved by the system.  Windows",
		    " is not telling which one, I'm sorry.", (char *) NULL);

	    break;
	case ERROR_INVALID_DLL:
	    Tcl_AppendResult(interp, "this library or a dependent library",
		    " is damaged", (char *) NULL);
	    break;
	case ERROR_DLL_INIT_FAILED:
	    Tcl_AppendResult(interp, "the library initialization",
		    " routine failed", (char *) NULL);
	    break;
	default:
	    TclWinConvertError(lastError);
	    Tcl_AppendResult(interp, Tcl_PosixError(interp), (char *) NULL);

	}
	return TCL_ERROR;
    } else {
	*unloadProcPtr = &TclpUnloadFile;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_PackageInitProc *proc = NULL;
    HINSTANCE handle = (HINSTANCE)loadHandle;

    /*
     * For each symbol, check for both Symbol and _Symbol, since Borland
     * generates C symbols with a leading '_' by default.
     */

    proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
    if (proc == NULL) {
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, "_", 1);
	symbol = Tcl_DStringAppend(&ds, symbol, -1);
	proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
	Tcl_DStringFree(&ds);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */

{
    HINSTANCE handle;

    handle = (HINSTANCE) loadHandle;
    FreeLibrary(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this function is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package
 *	name; generic code will then try to guess the package from the file
 *	name. A return value of 1 would have meant that we figured out the
 *	package name and put it in bufPtr.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGuessPackageName(fileName, bufPtr)
    CONST char *fileName;	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr;	/* Initialized empty dstring. Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinNotify.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
/* 
 * tclWinNotify.c --
 *
 *	This file contains Windows-specific procedures for the notifier,
 *	which is the lowest-level part of the Tcl event loop.  This file
 *	works together with ../generic/tclNotify.c.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinNotify.c,v 1.16 2004/04/06 22:25:58 dgp Exp $
 */

#include "tclInt.h"

/*
 * The follwing static indicates whether this module has been initialized.
 */

#define INTERVAL_TIMER 1	/* Handle of interval timer. */

#define WM_WAKEUP WM_USER	/* Message that is send by
				 * Tcl_AlertNotifier. */
/*
 * The following static structure contains the state information for the
 * Windows implementation of the Tcl notifier.  One of these structures
 * is created for each thread that is using the notifier.  
 */

typedef struct ThreadSpecificData {
    CRITICAL_SECTION crit;	/* Monitor for this notifier. */
    DWORD thread;		/* Identifier for thread associated with this
				 * notifier. */
    HANDLE event;		/* Event object used to wake up the notifier
				 * thread. */
    int pending;		/* Alert message pending, this field is
				 * locked by the notifierMutex. */
    HWND hwnd;			/* Messaging window. */
    int timeout;		/* Current timeout value. */
    int timerActive;		/* 1 if interval timer is running. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;

/*
 * The following static indicates the number of threads that have
 * initialized notifiers.  It controls the lifetime of the TclNotifier
 * window class.
 *
 * You must hold the notifierMutex lock before accessing this variable.
 */

static int notifierCount = 0;
TCL_DECLARE_MUTEX(notifierMutex)

/*
 * Static routines defined in this file.
 */

static LRESULT CALLBACK	NotifierProc(HWND hwnd, UINT message,
			    WPARAM wParam, LPARAM lParam);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitNotifier --
 *
 *	Initializes the platform specific notifier state.
|


|
|
|



|
|

|








|

|



|
|








|
|











|
|
<











|
|
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
/*
 * tclWinNotify.c --
 *
 *	This file contains Windows-specific procedures for the notifier, which
 *	is the lowest-level part of the Tcl event loop. This file works
 *	together with ../generic/tclNotify.c.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinNotify.c,v 1.16.2.3 2005/08/02 18:17:18 dgp Exp $
 */

#include "tclInt.h"

/*
 * The follwing static indicates whether this module has been initialized.
 */

#define INTERVAL_TIMER	1	/* Handle of interval timer. */

#define WM_WAKEUP	WM_USER	/* Message that is send by
				 * Tcl_AlertNotifier. */
/*
 * The following static structure contains the state information for the
 * Windows implementation of the Tcl notifier. One of these structures is
 * created for each thread that is using the notifier.
 */

typedef struct ThreadSpecificData {
    CRITICAL_SECTION crit;	/* Monitor for this notifier. */
    DWORD thread;		/* Identifier for thread associated with this
				 * notifier. */
    HANDLE event;		/* Event object used to wake up the notifier
				 * thread. */
    int pending;		/* Alert message pending, this field is locked
				 * by the notifierMutex. */
    HWND hwnd;			/* Messaging window. */
    int timeout;		/* Current timeout value. */
    int timerActive;		/* 1 if interval timer is running. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;

/*
 * The following static indicates the number of threads that have initialized
 * notifiers. It controls the lifetime of the TclNotifier window class.

 *
 * You must hold the notifierMutex lock before accessing this variable.
 */

static int notifierCount = 0;
TCL_DECLARE_MUTEX(notifierMutex)

/*
 * Static routines defined in this file.
 */

static LRESULT CALLBACK		NotifierProc(HWND hwnd, UINT message,
				    WPARAM wParam, LPARAM lParam);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitNotifier --
 *
 *	Initializes the platform specific notifier state.
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
ClientData
Tcl_InitNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    WNDCLASS class;

    /*
     * Register Notifier window class if this is the first thread to
     * use this module.
     */

    Tcl_MutexLock(&notifierMutex);
    if (notifierCount == 0) {
	class.style = 0;
	class.cbClsExtra = 0;
	class.cbWndExtra = 0;







|
|







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
ClientData
Tcl_InitNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    WNDCLASS class;

    /*
     * Register Notifier window class if this is the first thread to use this
     * module.
     */

    Tcl_MutexLock(&notifierMutex);
    if (notifierCount == 0) {
	class.style = 0;
	class.cbClsExtra = 0;
	class.cbWndExtra = 0;
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeNotifier --
 *
 *	This function is called to cleanup the notifier state before
 *	a thread is terminated.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May dispose of the notifier window and class.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeNotifier(clientData)
    ClientData clientData;	/* Pointer to notifier data. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

    /*
     * Only finalize the notifier if a notifier was installed in the
     * current thread; there is a route in which this is not
     * guaranteed to be true (when tclWin32Dll.c:DllMain() is called
     * with the flag DLL_PROCESS_DETACH by the OS, which could be
     * doing so from a thread that's never previously been involved
     * with Tcl, e.g. the task manager) so this check is important.
     *
     * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
     */

    if (tsdPtr == NULL) {
	return;
    }

    DeleteCriticalSection(&tsdPtr->crit);
    CloseHandle(tsdPtr->event);

    /*
     * Clean up the timer and messaging window for this thread.
     */

    if (tsdPtr->hwnd) {
	KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
	DestroyWindow(tsdPtr->hwnd);
    }

    /*
     * If this is the last thread to use the notifier, unregister
     * the notifier window class.
     */

    Tcl_MutexLock(&notifierMutex);
    notifierCount--;
    if (notifierCount == 0) {
	UnregisterClassA("TclNotifier", TclWinGetTclInstance());
    }
    Tcl_MutexUnlock(&notifierMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AlertNotifier --
 *
 *	Wake up the specified notifier from any thread. This routine
 *	is called by the platform independent notifier code whenever
 *	the Tcl_ThreadAlert routine is called.  This routine is
 *	guaranteed not to be called on a given notifier after
 *	Tcl_FinalizeNotifier is called for that notifier.  This routine
 *	is typically called from a thread other than the notifier's
 *	thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sends a message to the messaging window for the notifier
 *	if there isn't already one pending.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AlertNotifier(clientData)
    ClientData clientData;	/* Pointer to thread data. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

    /*
     * Note that we do not need to lock around access to the hwnd
     * because the race condition has no effect since any race condition
     * implies that the notifier thread is already awake.
     */

    if (tsdPtr->hwnd) {
	/*
	 * We do need to lock around access to the pending flag.
	 */








|
|

















|
|
|
|
|
|



>

















|
|















|
|
<
|
|
|
|





|
|











|
|
|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FinalizeNotifier --
 *
 *	This function is called to cleanup the notifier state before a thread
 *	is terminated.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May dispose of the notifier window and class.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FinalizeNotifier(clientData)
    ClientData clientData;	/* Pointer to notifier data. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

    /*
     * Only finalize the notifier if a notifier was installed in the current
     * thread; there is a route in which this is not guaranteed to be true
     * (when tclWin32Dll.c:DllMain() is called with the flag
     * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread
     * that's never previously been involved with Tcl, e.g. the task manager)
     * so this check is important.
     *
     * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
     */

    if (tsdPtr == NULL) {
	return;
    }

    DeleteCriticalSection(&tsdPtr->crit);
    CloseHandle(tsdPtr->event);

    /*
     * Clean up the timer and messaging window for this thread.
     */

    if (tsdPtr->hwnd) {
	KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
	DestroyWindow(tsdPtr->hwnd);
    }

    /*
     * If this is the last thread to use the notifier, unregister the notifier
     * window class.
     */

    Tcl_MutexLock(&notifierMutex);
    notifierCount--;
    if (notifierCount == 0) {
	UnregisterClassA("TclNotifier", TclWinGetTclInstance());
    }
    Tcl_MutexUnlock(&notifierMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AlertNotifier --
 *
 *	Wake up the specified notifier from any thread. This routine is called
 *	by the platform independent notifier code whenever the Tcl_ThreadAlert

 *	routine is called. This routine is guaranteed not to be called on a
 *	given notifier after Tcl_FinalizeNotifier is called for that notifier.
 *	This routine is typically called from a thread other than the
 *	notifier's thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sends a message to the messaging window for the notifier if there
 *	isn't already one pending.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AlertNotifier(clientData)
    ClientData clientData;	/* Pointer to thread data. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

    /*
     * Note that we do not need to lock around access to the hwnd because the
     * race condition has no effect since any race condition implies that the
     * notifier thread is already awake.
     */

    if (tsdPtr->hwnd) {
	/*
	 * We do need to lock around access to the pending flag.
	 */

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimer --
 *
 *	This procedure sets the current notifier timer value.  The
 *	notifier will ensure that Tcl_ServiceAll() is called after
 *	the specified interval, even if no events have occurred.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Replaces any previous timer.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimer(
    Tcl_Time *timePtr)		/* Maximum block time, or NULL. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    UINT timeout;

    /*
     * Allow the notifier to be hooked.  This may not make sense
     * on Windows, but mirrors the UNIX hook.
     */

    if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
	tclStubs.tcl_SetTimer(timePtr);
	return;
    }

    /*
     * We only need to set up an interval timer if we're being called
     * from an external event loop.  If we don't have a window handle
     * then we just return immediately and let Tcl_WaitForEvent handle
     * timeouts.
     */

    if (!tsdPtr->hwnd) {
	return;
    }

    if (!timePtr) {







|
|
|


















|
|








|
|
|
<







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278

279
280
281
282
283
284
285
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimer --
 *
 *	This procedure sets the current notifier timer value. The notifier
 *	will ensure that Tcl_ServiceAll() is called after the specified
 *	interval, even if no events have occurred.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Replaces any previous timer.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimer(
    Tcl_Time *timePtr)		/* Maximum block time, or NULL. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    UINT timeout;

    /*
     * Allow the notifier to be hooked. This may not make sense on Windows,
     * but mirrors the UNIX hook.
     */

    if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
	tclStubs.tcl_SetTimer(timePtr);
	return;
    }

    /*
     * We only need to set up an interval timer if we're being called from an
     * external event loop. If we don't have a window handle then we just
     * return immediately and let Tcl_WaitForEvent handle timeouts.

     */

    if (!tsdPtr->hwnd) {
	return;
    }

    if (!timePtr) {
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348

349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446







447







448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
	if (timeout == 0) {
	    timeout = 1;
	}
    }
    tsdPtr->timeout = timeout;
    if (timeout != 0) {
	tsdPtr->timerActive = 1;
	SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
		    (unsigned long) tsdPtr->timeout, NULL);
    } else {
	tsdPtr->timerActive = 0;
	KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceModeHook --
 *
 *	This function is invoked whenever the service mode changes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If this is the first time the notifier is set into
 *	TCL_SERVICE_ALL, then the communication window is created.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ServiceModeHook(mode)
    int mode;			/* Either TCL_SERVICE_ALL, or
				 * TCL_SERVICE_NONE. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * If this is the first time that the notifier has been used from a
     * modal loop, then create a communication window.  Note that after
     * this point, the application needs to service events in a timely
     * fashion or Windows will hang waiting for the window to respond
     * to synchronous system messages.  At some point, we may want to
     * consider destroying the window if we leave the modal loop, but
     * for now we'll leave it around.
     */

    if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
	tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
		0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);

	/*
	 * Send an initial message to the window to ensure that we wake up the
	 * notifier once we get into the modal loop.  This will force the
	 * notifier to recompute the timeout value and schedule a timer
	 * if one is needed.
	 */

	Tcl_AlertNotifier((ClientData)tsdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierProc --
 *
 *	This procedure is invoked by Windows to process events on
 *	the notifier window.  Messages will be sent to this window
 *	in response to external timer events or calls to
 *	TclpAlertTsdPtr->
 *
 * Results:
 *	A standard windows result.
 *
 * Side effects:
 *	Services any pending events.
 *
 *----------------------------------------------------------------------
 */

static LRESULT CALLBACK
NotifierProc(
    HWND hwnd,
    UINT message,
    WPARAM wParam,
    LPARAM lParam)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (message == WM_WAKEUP) {
	EnterCriticalSection(&tsdPtr->crit);
	tsdPtr->pending = 0;
	LeaveCriticalSection(&tsdPtr->crit);
    } else if (message != WM_TIMER) {
	return DefWindowProc(hwnd, message, wParam, lParam);
    }
	
    /*
     * Process all of the runnable events.
     */

    Tcl_ServiceAll();
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new
 *	events on the message queue.  If the block time is 0, then
 *	Tcl_WaitForEvent just polls the event queue without blocking.
 *
 * Results:
 *	Returns -1 if a WM_QUIT message is detected, returns 1 if
 *	a message was dispatched, otherwise returns 0.
 *
 * Side effects:
 *	Dispatches a message to a window procedure, which could do
 *	anything.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WaitForEvent(
    Tcl_Time *timePtr)		/* Maximum block time, or NULL. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    MSG msg;
    DWORD timeout, result;
    int status;

    /*
     * Allow the notifier to be hooked.  This may not make
     * sense on windows, but mirrors the UNIX hook.
     */

    if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
	return tclStubs.tcl_WaitForEvent(timePtr);
    }

    /*
     * Compute the timeout in milliseconds.
     */

    if (timePtr) {







	timeout = timePtr->sec * 1000 + timePtr->usec / 1000;







    } else {
	timeout = INFINITE;
    }

    /*
     * Check to see if there are any messages in the queue before waiting
     * because MsgWaitForMultipleObjects will not wake up if there are events
     * currently sitting in the queue.
     */

    if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
	/*
	 * Wait for something to happen (a signal from another thread, a
	 * message, or timeout) or loop servicing asynchronous procedure
	 * calls queued to this thread.
	 */

again:
	result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout,
		QS_ALLINPUT, MWMO_ALERTABLE);
	if (result == WAIT_IO_COMPLETION) {
	    goto again;
	} else if (result == WAIT_FAILED) {
	    status = -1;
	    goto end;







|
|

















|
|












|
|
|
|
<
|
|





>


|
|
|











|
|
<
|












|
|
|
|










|













|
|
|


|
|


|
<














|
|











>
>
>
>
>
>
>
|
>
>
>
>
>
>
>













|
|


|







294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414

415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
	if (timeout == 0) {
	    timeout = 1;
	}
    }
    tsdPtr->timeout = timeout;
    if (timeout != 0) {
	tsdPtr->timerActive = 1;
	SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, (unsigned long) tsdPtr->timeout,
		NULL);
    } else {
	tsdPtr->timerActive = 0;
	KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ServiceModeHook --
 *
 *	This function is invoked whenever the service mode changes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If this is the first time the notifier is set into TCL_SERVICE_ALL,
 *	then the communication window is created.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ServiceModeHook(mode)
    int mode;			/* Either TCL_SERVICE_ALL, or
				 * TCL_SERVICE_NONE. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * If this is the first time that the notifier has been used from a modal
     * loop, then create a communication window. Note that after this point,
     * the application needs to service events in a timely fashion or Windows
     * will hang waiting for the window to respond to synchronous system

     * messages. At some point, we may want to consider destroying the window
     * if we leave the modal loop, but for now we'll leave it around.
     */

    if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
	tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
		0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);

	/*
	 * Send an initial message to the window to ensure that we wake up the
	 * notifier once we get into the modal loop. This will force the
	 * notifier to recompute the timeout value and schedule a timer if one
	 * is needed.
	 */

	Tcl_AlertNotifier((ClientData)tsdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierProc --
 *
 *	This procedure is invoked by Windows to process events on the notifier
 *	window. Messages will be sent to this window in response to external

 *	timer events or calls to TclpAlertTsdPtr->
 *
 * Results:
 *	A standard windows result.
 *
 * Side effects:
 *	Services any pending events.
 *
 *----------------------------------------------------------------------
 */

static LRESULT CALLBACK
NotifierProc(
    HWND hwnd,			/* Passed on... */
    UINT message,		/* What messsage is this? */
    WPARAM wParam,		/* Passed on... */
    LPARAM lParam)		/* Passed on... */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (message == WM_WAKEUP) {
	EnterCriticalSection(&tsdPtr->crit);
	tsdPtr->pending = 0;
	LeaveCriticalSection(&tsdPtr->crit);
    } else if (message != WM_TIMER) {
	return DefWindowProc(hwnd, message, wParam, lParam);
    }

    /*
     * Process all of the runnable events.
     */

    Tcl_ServiceAll();
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just
 *	polls the event queue without blocking.
 *
 * Results:
 *	Returns -1 if a WM_QUIT message is detected, returns 1 if a message
 *	was dispatched, otherwise returns 0.
 *
 * Side effects:
 *	Dispatches a message to a window procedure, which could do anything.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_WaitForEvent(
    Tcl_Time *timePtr)		/* Maximum block time, or NULL. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    MSG msg;
    DWORD timeout, result;
    int status;

    /*
     * Allow the notifier to be hooked. This may not make sense on windows,
     * but mirrors the UNIX hook.
     */

    if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
	return tclStubs.tcl_WaitForEvent(timePtr);
    }

    /*
     * Compute the timeout in milliseconds.
     */

    if (timePtr) {
	/*
	 * TIP #233 (Virtualized Time). Convert virtual domain delay to
	 * real-time.
	 */

	Tcl_Time myTime;

	myTime.sec  = timePtr->sec;
	myTime.usec = timePtr->usec;

	if (myTime.sec != 0 || myTime.usec != 0) {
	    (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData);
	}

	timeout = myTime.sec * 1000 + myTime.usec / 1000;
    } else {
	timeout = INFINITE;
    }

    /*
     * Check to see if there are any messages in the queue before waiting
     * because MsgWaitForMultipleObjects will not wake up if there are events
     * currently sitting in the queue.
     */

    if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
	/*
	 * Wait for something to happen (a signal from another thread, a
	 * message, or timeout) or loop servicing asynchronous procedure calls
	 * queued to this thread.
	 */

    again:
	result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout,
		QS_ALLINPUT, MWMO_ALERTABLE);
	if (result == WAIT_IO_COMPLETION) {
	    goto again;
	} else if (result == WAIT_FAILED) {
	    status = -1;
	    goto end;
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
	     * propagate the quit message and start unwinding.
	     */

	    PostQuitMessage((int) msg.wParam);
	    status = -1;
	} else if (result == -1) {
	    /*
	     * We got an error from the system.  I have no idea why this would
	     * happen, so we'll just unwind.
	     */

	    status = -1;
	} else {
	    TranslateMessage(&msg);
	    DispatchMessage(&msg);
	    status = 1;
	}
    } else {
	status = 0;
    }

end:
    ResetEvent(tsdPtr->event);
    return status;
}

/*
 *----------------------------------------------------------------------
 *







|













|







498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
	     * propagate the quit message and start unwinding.
	     */

	    PostQuitMessage((int) msg.wParam);
	    status = -1;
	} else if (result == -1) {
	    /*
	     * We got an error from the system. I have no idea why this would
	     * happen, so we'll just unwind.
	     */

	    status = -1;
	} else {
	    TranslateMessage(&msg);
	    DispatchMessage(&msg);
	    status = 1;
	}
    } else {
	status = 0;
    }

  end:
    ResetEvent(tsdPtr->event);
    return status;
}

/*
 *----------------------------------------------------------------------
 *
529
530
531
532
533
534
535
536
537
538
539
540
541
542

543
544
545
546


547
548



549
550
551
552
553
554
555
556







557
558
559
560
561
562
563
564
565
566

567
568


569
570








 */

void
Tcl_Sleep(ms)
    int ms;			/* Number of milliseconds to sleep. */
{
    /*
     * Simply calling 'Sleep' for the requisite number of milliseconds
     * can make the process appear to wake up early because it isn't
     * synchronized with the CPU performance counter that is used in
     * tclWinTime.c.  This behavior is probably benign, but messes
     * up some of the corner cases in the test suite.  We get around
     * this problem by repeating the 'Sleep' call as many times
     * as necessary to make the clock advance by the requisite amount.

     */

    Tcl_Time now;		/* Current wall clock time */
    Tcl_Time desired;		/* Desired wakeup time */


    DWORD sleepTime = ms;	/* Time to sleep */




    Tcl_GetTime( &now );
    desired.sec = now.sec + ( ms / 1000 );
    desired.usec = now.usec + 1000 * ( ms % 1000 );
    if ( desired.usec > 1000000 ) {
	++desired.sec;
	desired.usec -= 1000000;
    }
	







    for ( ; ; ) {
	Sleep( sleepTime );
	Tcl_GetTime( &now );
	if ( now.sec > desired.sec ) {
	    break;
	} else if ( ( now.sec == desired.sec )
	     && ( now.usec >= desired.usec ) ) {
	    break;
	}
	sleepTime = ( ( 1000 * ( desired.sec - now.sec ) )

		      + ( ( desired.usec - now.usec ) / 1000 ) );
    }



}















|
|
|
|
<
|
|
>


|
|
>
>
|

>
>
>
|
|
|
|



|
>
>
>
>
>
>
>
|
|
|
|

<
|


|
>
|
|
>
>
|

>
>
>
>
>
>
>
>
538
539
540
541
542
543
544
545
546
547
548

549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582

583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
 */

void
Tcl_Sleep(ms)
    int ms;			/* Number of milliseconds to sleep. */
{
    /*
     * Simply calling 'Sleep' for the requisite number of milliseconds can
     * make the process appear to wake up early because it isn't synchronized
     * with the CPU performance counter that is used in tclWinTime.c. This
     * behavior is probably benign, but messes up some of the corner cases in

     * the test suite. We get around this problem by repeating the 'Sleep'
     * call as many times as necessary to make the clock advance by the
     * requisite amount.
     */

    Tcl_Time now;		/* Current wall clock time. */
    Tcl_Time desired;		/* Desired wakeup time. */
    Tcl_Time vdelay;		/* Time to sleep, for scaling virtual ->
				 * real. */
    DWORD sleepTime;		/* Time to sleep, real-time */

    vdelay.sec  = ms / 1000;
    vdelay.usec = (ms % 1000) * 1000;

    Tcl_GetTime(&now);
    desired.sec  = now.sec  + vdelay.sec;
    desired.usec = now.usec + vdelay.usec;
    if (desired.usec > 1000000) {
	++desired.sec;
	desired.usec -= 1000000;
    }

    /*
     * TIP #233: Scale delay from virtual to real-time.
     */

    (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
    sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;

    for (;;) {
	Sleep(sleepTime);
	Tcl_GetTime(&now);
	if (now.sec > desired.sec) {
	    break;

	} else if ((now.sec == desired.sec) && (now.usec >= desired.usec)) {
	    break;
	}

	vdelay.sec  = desired.sec  - now.sec;
	vdelay.usec = desired.usec - now.usec;

	(*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
	sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinPipe.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
/* 
 * tclWinPipe.c --
 *
 *	This file implements the Windows-specific exec pipeline functions,
 *	the "pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPipe.c,v 1.53 2004/12/01 23:18:55 dgp Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static int initialized = 0;

/*
 * The pipeMutex locks around access to the initialized and procList variables,
 * and it is used to protect background threads from being terminated while
 * they are using APIs that hold locks.
 */

TCL_DECLARE_MUTEX(pipeMutex)

/*
 * The following defines identify the various types of applications that 
 * run under windows.  There is special case code for the various types.
 */

#define APPL_NONE	0
#define APPL_DOS	1
#define APPL_WIN3X	2
#define APPL_WIN32	3

/*
 * The following constants and structures are used to encapsulate the state
 * of various types of files used in a pipeline.
 * This used to have a 1 && 2 that supported Win32s.
 */

#define WIN_FILE 3		/* Basic Win32 file. */

/*
 * This structure encapsulates the common state associated with all file
 * types used in a pipeline.
 */

typedef struct WinFile {
    int type;			/* One of the file types defined above. */
    HANDLE handle;		/* Open file handle. */
} WinFile;

|


|
|



|
|

|
















|
|
|





|
|








|
|
|


|


|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
/*
 * tclWinPipe.c --
 *
 *	This file implements the Windows-specific exec pipeline functions, the
 *	"pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPipe.c,v 1.53.2.3 2005/08/02 18:17:18 dgp Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static int initialized = 0;

/*
 * The pipeMutex locks around access to the initialized and procList
 * variables, and it is used to protect background threads from being
 * terminated while they are using APIs that hold locks.
 */

TCL_DECLARE_MUTEX(pipeMutex)

/*
 * The following defines identify the various types of applications that run
 * under windows. There is special case code for the various types.
 */

#define APPL_NONE	0
#define APPL_DOS	1
#define APPL_WIN3X	2
#define APPL_WIN32	3

/*
 * The following constants and structures are used to encapsulate the state of
 * various types of files used in a pipeline. This used to have a 1 && 2 that
 * supported Win32s.
 */

#define WIN_FILE	3	/* Basic Win32 file. */

/*
 * This structure encapsulates the common state associated with all file types
 * used in a pipeline.
 */

typedef struct WinFile {
    int type;			/* One of the file types defined above. */
    HANDLE handle;		/* Open file handle. */
} WinFile;

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206


207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227


228
229
230
231
232
233
234
    Tcl_Pid *pidPtr;		/* Pids of attached processes. */
    Tcl_ThreadId threadId;	/* Thread to which events should be reported.
				 * This value is used by the reader/writer
				 * threads. */
    HANDLE writeThread;		/* Handle to writer thread. */
    HANDLE readThread;		/* Handle to reader thread. */
    HANDLE writable;		/* Manual-reset event to signal when the
				 * writer thread has finished waiting for
				 * the current buffer to be written. */
    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    HANDLE startWriter;		/* Auto-reset event used by the main thread to
				 * signal when the writer thread should attempt
				 * to write to the pipe. */
    HANDLE stopWriter;		/* Manual-reset event used to alert the reader
				 * thread to fall-out and exit */
    HANDLE startReader;		/* Auto-reset event used by the main thread to
				 * signal when the reader thread should attempt
				 * to read from the pipe. */
    HANDLE stopReader;		/* Manual-reset event used to alert the reader
				 * thread to fall-out and exit */
    DWORD writeError;		/* An error caused by the last background
				 * write.  Set to 0 if no error has been
				 * detected.  This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object.
				 */
    char *writeBuf;		/* Current background output buffer.
				 * Access is synchronized with the writable
				 * object. */
    int writeBufLen;		/* Size of write buffer.  Access is
				 * synchronized with the writable
				 * object. */
    int toWrite;		/* Current amount to be written.  Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
				 * thread.  Access is synchronized with the
				 * readable object.  */
    char extraByte;		/* Buffer for extra character consumed by
				 * reader thread.  This byte is shared with
				 * the reader thread so access must be
				 * synchronized with the readable object. */
} PipeInfo;

typedef struct ThreadSpecificData {
    /*
     * The following pointer refers to the head of the list of pipes
     * that are being watched for file events.
     */
    
    PipeInfo *firstPipePtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when
 * pipe events are generated.
 */

typedef struct PipeEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    PipeInfo *infoPtr;		/* Pointer to pipe info structure.  Note
				 * that we still have to verify that the
				 * pipe exists before dereferencing this
				 * pointer. */
} PipeEvent;

/*
 * Declarations for functions used only in this file.
 */

static int		ApplicationType(Tcl_Interp *interp,
			    const char *fileName, char *fullName);
static void		BuildCommandLine(const char *executable, int argc, 
			    CONST char **argv, Tcl_DString *linePtr);
static BOOL		HasConsole(void);
static int		PipeBlockModeProc(ClientData instanceData, int mode);
static void		PipeCheckProc(ClientData clientData, int flags);
static int		PipeClose2Proc(ClientData instanceData,
			    Tcl_Interp *interp, int flags);
static int		PipeEventProc(Tcl_Event *evPtr, int flags);
static void		PipeExitHandler(ClientData clientData);
static int		PipeGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static void		PipeInit(void);
static int		PipeInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		PipeOutputProc(ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI	PipeReaderThread(LPVOID arg);
static void		PipeSetupProc(ClientData clientData, int flags);
static void		PipeWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI	PipeWriterThread(LPVOID arg);
static void		ProcExitHandler(ClientData clientData);
static int		TempFileName(WCHAR name[MAX_PATH]);
static int		WaitForRead(PipeInfo *infoPtr, int blocking);



/*
 * This structure describes the channel type structure for command pipe
 * based IO.
 */

static Tcl_ChannelType pipeChannelType = {
    "pipe",			/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* v2 channel */
    TCL_CLOSE2PROC,		/* Close proc. */
    PipeInputProc,		/* Input proc. */
    PipeOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,		/* Set up notifier to watch the channel. */
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */


};

/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *







|
|




|
|



|
|



|
|



|
|
<
|
|
<
|


|


|
|





|
|

|






|
|



|
|
|
|
|









|



















<


>
>


|
|




|












>
>







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

138
139

140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
    Tcl_Pid *pidPtr;		/* Pids of attached processes. */
    Tcl_ThreadId threadId;	/* Thread to which events should be reported.
				 * This value is used by the reader/writer
				 * threads. */
    HANDLE writeThread;		/* Handle to writer thread. */
    HANDLE readThread;		/* Handle to reader thread. */
    HANDLE writable;		/* Manual-reset event to signal when the
				 * writer thread has finished waiting for the
				 * current buffer to be written. */
    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    HANDLE startWriter;		/* Auto-reset event used by the main thread to
				 * signal when the writer thread should
				 * attempt to write to the pipe. */
    HANDLE stopWriter;		/* Manual-reset event used to alert the reader
				 * thread to fall-out and exit */
    HANDLE startReader;		/* Auto-reset event used by the main thread to
				 * signal when the reader thread should
				 * attempt to read from the pipe. */
    HANDLE stopReader;		/* Manual-reset event used to alert the reader
				 * thread to fall-out and exit */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object.
				 */
    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the writable object. */

    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the writable object. */

    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
				 * thread. Access is synchronized with the
				 * readable object.  */
    char extraByte;		/* Buffer for extra character consumed by
				 * reader thread. This byte is shared with the
				 * reader thread so access must be
				 * synchronized with the readable object. */
} PipeInfo;

typedef struct ThreadSpecificData {
    /*
     * The following pointer refers to the head of the list of pipes that are
     * being watched for file events.
     */

    PipeInfo *firstPipePtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when pipe
 * events are generated.
 */

typedef struct PipeEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    PipeInfo *infoPtr;		/* Pointer to pipe info structure. Note that
				 * we still have to verify that the pipe
				 * exists before dereferencing this
				 * pointer. */
} PipeEvent;

/*
 * Declarations for functions used only in this file.
 */

static int		ApplicationType(Tcl_Interp *interp,
			    const char *fileName, char *fullName);
static void		BuildCommandLine(const char *executable, int argc,
			    CONST char **argv, Tcl_DString *linePtr);
static BOOL		HasConsole(void);
static int		PipeBlockModeProc(ClientData instanceData, int mode);
static void		PipeCheckProc(ClientData clientData, int flags);
static int		PipeClose2Proc(ClientData instanceData,
			    Tcl_Interp *interp, int flags);
static int		PipeEventProc(Tcl_Event *evPtr, int flags);
static void		PipeExitHandler(ClientData clientData);
static int		PipeGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static void		PipeInit(void);
static int		PipeInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		PipeOutputProc(ClientData instanceData,
			    CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI	PipeReaderThread(LPVOID arg);
static void		PipeSetupProc(ClientData clientData, int flags);
static void		PipeWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI	PipeWriterThread(LPVOID arg);

static int		TempFileName(WCHAR name[MAX_PATH]);
static int		WaitForRead(PipeInfo *infoPtr, int blocking);
static void		PipeThreadActionProc(ClientData instanceData,
			    int action);

/*
 * This structure describes the channel type structure for command pipe based
 * I/O.
 */

static Tcl_ChannelType pipeChannelType = {
    "pipe",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    TCL_CLOSE2PROC,		/* Close proc. */
    PipeInputProc,		/* Input proc. */
    PipeOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    PipeWatchProc,		/* Set up notifier to watch the channel. */
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    PipeThreadActionProc,	/* thread action proc */
};

/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338

static void
PipeInit()
{
    ThreadSpecificData *tsdPtr;

    /*
     * Check the initialized flag first, then check again in the mutex.
     * This is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&pipeMutex);
	if (!initialized) {
	    initialized = 1;
	    procList = NULL;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	Tcl_MutexUnlock(&pipeMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->firstPipePtr = NULL;
	Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
	Tcl_CreateThreadExitHandler(PipeExitHandler, NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeExitHandler --
 *
 *	This function is called to cleanup the pipe module before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the pipe event source.
 *
 *----------------------------------------------------------------------
 */

static void
PipeExitHandler(
    ClientData clientData)	/* Old window proc */
{
    Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * ProcExitHandler --
 *
 *	This function is called to cleanup the process list before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the process list.
 *
 *----------------------------------------------------------------------
 */

static void
ProcExitHandler(
    ClientData clientData)	/* Old window proc */
{
    Tcl_MutexLock(&pipeMutex);
    initialized = 0;
    Tcl_MutexUnlock(&pipeMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * PipeSetupProc --
 *
 *	This procedure is invoked before Tcl_DoOneEvent blocks waiting
 *	for an event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *







|
|







<


















|
|




















|

|
|










|
|
<











|
|







246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261

262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317

318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

static void
PipeInit()
{
    ThreadSpecificData *tsdPtr;

    /*
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&pipeMutex);
	if (!initialized) {
	    initialized = 1;
	    procList = NULL;

	}
	Tcl_MutexUnlock(&pipeMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->firstPipePtr = NULL;
	Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
	Tcl_CreateThreadExitHandler(PipeExitHandler, NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeExitHandler --
 *
 *	This function is called to cleanup the pipe module before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the pipe event source.
 *
 *----------------------------------------------------------------------
 */

static void
PipeExitHandler(
    ClientData clientData)	/* Old window proc */
{
    Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizePipes --
 *
 *	This function is called to cleanup the process list before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the process list.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizePipes()

{
    Tcl_MutexLock(&pipeMutex);
    initialized = 0;
    Tcl_MutexUnlock(&pipeMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * PipeSetupProc --
 *
 *	This function is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
    int block = 1;
    WinFile *filePtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }
    
    /*
     * Look to see if any events are already pending.  If they are, poll.
     */

    for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    filePtr = (WinFile*) infoPtr->writeFile;
	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
		block = 0;
	    }
	}







|




|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
    int block = 1;
    WinFile *filePtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events are already pending.  If they are, poll.
     */

    for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    filePtr = (WinFile*) infoPtr->writeFile;
	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
		block = 0;
	    }
	}
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
}

/*
 *----------------------------------------------------------------------
 *
 * PipeCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the pipe
 *	event source for events. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *







|
|







378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
}

/*
 *----------------------------------------------------------------------
 *
 * PipeCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the pipe event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
    WinFile *filePtr;
    int needEvent;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }
    
    /*
     * Queue events for any ready pipes that don't already have events
     * queued.
     */

    for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->flags & PIPE_PENDING) {
	    continue;
	}
	
	/*
	 * Queue an event if the pipe is signaled for reading or writing.
	 */

	needEvent = 0;
	filePtr = (WinFile*) infoPtr->writeFile;
	if ((infoPtr->watchMask & TCL_WRITABLE) &&
		(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
	    needEvent = 1;
	}
	
	filePtr = (WinFile*) infoPtr->readFile;
	if ((infoPtr->watchMask & TCL_READABLE) &&
		(WaitForRead(infoPtr, 0) >= 0)) {
	    needEvent = 1;
	}

	if (needEvent) {







|

|
<


|




|










|







404
405
406
407
408
409
410
411
412
413

414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
    WinFile *filePtr;
    int needEvent;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Queue events for any ready pipes that don't already have events queued.

     */

    for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->flags & PIPE_PENDING) {
	    continue;
	}

	/*
	 * Queue an event if the pipe is signaled for reading or writing.
	 */

	needEvent = 0;
	filePtr = (WinFile*) infoPtr->writeFile;
	if ((infoPtr->watchMask & TCL_WRITABLE) &&
		(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
	    needEvent = 1;
	}

	filePtr = (WinFile*) infoPtr->readFile;
	if ((infoPtr->watchMask & TCL_READABLE) &&
		(WaitForRead(infoPtr, 0) >= 0)) {
	    needEvent = 1;
	}

	if (needEvent) {
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinMakeFile --
 *
 *	This function constructs a new TclFile from a given data and
 *	type value.
 *
 * Results:
 *	Returns a newly allocated WinFile as a TclFile.
 *
 * Side effects:
 *	None.
 *







|
|







447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinMakeFile --
 *
 *	This function constructs a new TclFile from a given data and type
 *	value.
 *
 * Results:
 *	Returns a newly allocated WinFile as a TclFile.
 *
 * Side effects:
 *	None.
 *
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
}

/*
 *----------------------------------------------------------------------
 *
 * TempFileName --
 *
 *	Gets a temporary file name and deals with the fact that the
 *	temporary file path provided by Windows may not actually exist
 *	if the TMP or TEMP environment variables refer to a 
 *	non-existent directory.
 *
 * Results:    
 *	0 if error, non-zero otherwise.  If non-zero is returned, the
 *	name buffer will be filled with a name that can be used to 
 *	construct a temporary file.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TempFileName(name)
    WCHAR name[MAX_PATH];	/* Buffer in which name for temporary 
				 * file gets stored. */
{
    TCHAR *prefix;

    prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL";
    if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) {
	if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, 
		name) != 0) {
	    return 1;
	}
    }
    if (tclWinProcs->useWide) {
	((WCHAR *) name)[0] = '.';
	((WCHAR *) name)[1] = '\0';
    } else {
	((char *) name)[0] = '.';
	((char *) name)[1] = '\0';
    }
    return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, 
	    name);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeFile --







|
|
|
<

|
|
|
|









|
|





|











|







477
478
479
480
481
482
483
484
485
486

487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
}

/*
 *----------------------------------------------------------------------
 *
 * TempFileName --
 *
 *	Gets a temporary file name and deals with the fact that the temporary
 *	file path provided by Windows may not actually exist if the TMP or
 *	TEMP environment variables refer to a non-existent directory.

 *
 * Results:
 *	0 if error, non-zero otherwise. If non-zero is returned, the name
 *	buffer will be filled with a name that can be used to construct a
 *	temporary file.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TempFileName(name)
    WCHAR name[MAX_PATH];	/* Buffer in which name for temporary file
				 * gets stored. */
{
    TCHAR *prefix;

    prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL";
    if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) {
	if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
		name) != 0) {
	    return 1;
	}
    }
    if (tclWinProcs->useWide) {
	((WCHAR *) name)[0] = '.';
	((WCHAR *) name)[1] = '\0';
    } else {
	((char *) name)[0] = '.';
	((char *) name)[1] = '\0';
    }
    return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
	    name);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMakeFile --
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
TclFile
TclpMakeFile(channel, direction)
    Tcl_Channel channel;	/* Channel to get file from. */
    int direction;		/* Either TCL_READABLE or TCL_WRITABLE. */
{
    HANDLE handle;

    if (Tcl_GetChannelHandle(channel, direction, 
	    (ClientData *) &handle) == TCL_OK) {
	return TclWinMakeFile(handle);
    } else {
	return (TclFile) NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFile --
 *
 *	This function opens files for use in a pipeline.
 *
 * Results:
 *	Returns a newly allocated TclFile structure containing the
 *	file handle.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclFile
TclpOpenFile(path, mode)
    CONST char *path;		/* The name of the file to open. */
    int mode;			/* In what mode to open the file? */
{
    HANDLE handle;
    DWORD accessMode, createMode, shareMode, flags;
    Tcl_DString ds;
    CONST TCHAR *nativePath;
    
    /*
     * Map the access bits to the NT access mode.
     */

    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:
	    accessMode = GENERIC_READ;
	    break;
	case O_WRONLY:
	    accessMode = GENERIC_WRITE;
	    break;
	case O_RDWR:
	    accessMode = (GENERIC_READ | GENERIC_WRITE);
	    break;
	default:
	    TclWinConvertError(ERROR_INVALID_FUNCTION);
	    return NULL;
    }

    /*
     * Map the creation flags to the NT create mode.
     */

    switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) {
	case (O_CREAT | O_EXCL):
	case (O_CREAT | O_EXCL | O_TRUNC):
	    createMode = CREATE_NEW;
	    break;
	case (O_CREAT | O_TRUNC):
	    createMode = CREATE_ALWAYS;
	    break;
	case O_CREAT:
	    createMode = OPEN_ALWAYS;
	    break;
	case O_TRUNC:
	case (O_TRUNC | O_EXCL):
	    createMode = TRUNCATE_EXISTING;
	    break;
	default:
	    createMode = OPEN_EXISTING;
	    break;
    }

    nativePath = Tcl_WinUtfToTChar(path, -1, &ds);

    /*
     * If the file is not being created, use the existing file attributes.
     */







|















|
|
















|





|
|
|
|
|
|
|
|
|
|
|
|







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
TclFile
TclpMakeFile(channel, direction)
    Tcl_Channel channel;	/* Channel to get file from. */
    int direction;		/* Either TCL_READABLE or TCL_WRITABLE. */
{
    HANDLE handle;

    if (Tcl_GetChannelHandle(channel, direction,
	    (ClientData *) &handle) == TCL_OK) {
	return TclWinMakeFile(handle);
    } else {
	return (TclFile) NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFile --
 *
 *	This function opens files for use in a pipeline.
 *
 * Results:
 *	Returns a newly allocated TclFile structure containing the file
 *	handle.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclFile
TclpOpenFile(path, mode)
    CONST char *path;		/* The name of the file to open. */
    int mode;			/* In what mode to open the file? */
{
    HANDLE handle;
    DWORD accessMode, createMode, shareMode, flags;
    Tcl_DString ds;
    CONST TCHAR *nativePath;

    /*
     * Map the access bits to the NT access mode.
     */

    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
    case O_RDONLY:
	accessMode = GENERIC_READ;
	break;
    case O_WRONLY:
	accessMode = GENERIC_WRITE;
	break;
    case O_RDWR:
	accessMode = (GENERIC_READ | GENERIC_WRITE);
	break;
    default:
	TclWinConvertError(ERROR_INVALID_FUNCTION);
	return NULL;
    }

    /*
     * Map the creation flags to the NT create mode.
     */

    switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) {
    case (O_CREAT | O_EXCL):
    case (O_CREAT | O_EXCL | O_TRUNC):
	createMode = CREATE_NEW;
	break;
    case (O_CREAT | O_TRUNC):
	createMode = CREATE_ALWAYS;
	break;
    case O_CREAT:
	createMode = OPEN_ALWAYS;
	break;
    case O_TRUNC:
    case (O_TRUNC | O_EXCL):
	createMode = TRUNCATE_EXISTING;
	break;
    default:
	createMode = OPEN_EXISTING;
	break;
    }

    nativePath = Tcl_WinUtfToTChar(path, -1, &ds);

    /*
     * If the file is not being created, use the existing file attributes.
     */
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692

    shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;

    /*
     * Now we get to create the file.
     */

    handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, 
	    shareMode, NULL, createMode, flags, NULL);
    Tcl_DStringFree(&ds);

    if (handle == INVALID_HANDLE_VALUE) {
	DWORD err;
	
	err = GetLastError();
	if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
	    err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
	}
        TclWinConvertError(err);
        return NULL;
    }

    /*
     * Seek to the end of file if we are writing.
     */

    if (mode & O_WRONLY) {
	SetFilePointer(handle, 0, NULL, FILE_END);
    }

    return TclWinMakeFile(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateTempFile --
 *
 *	This function opens a unique file with the property that it
 *	will be deleted when its file handle is closed.  The temporary
 *	file is created in the system temporary directory.
 *
 * Results:
 *	Returns a valid TclFile, or NULL on failure.
 *
 * Side effects:
 *	Creates a new temporary file.
 *







|





|




|
|






|











|
|
|







642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689

    shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;

    /*
     * Now we get to create the file.
     */

    handle = (*tclWinProcs->createFileProc)(nativePath, accessMode,
	    shareMode, NULL, createMode, flags, NULL);
    Tcl_DStringFree(&ds);

    if (handle == INVALID_HANDLE_VALUE) {
	DWORD err;

	err = GetLastError();
	if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
	    err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
	}
	TclWinConvertError(err);
	return NULL;
    }

    /*
     * Seek to the end of file if we are writing.
     */

    if (mode & (O_WRONLY|O_APPEND)) {
	SetFilePointer(handle, 0, NULL, FILE_END);
    }

    return TclWinMakeFile(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateTempFile --
 *
 *	This function opens a unique file with the property that it will be
 *	deleted when its file handle is closed. The temporary file is created
 *	in the system temporary directory.
 *
 * Results:
 *	Returns a valid TclFile, or NULL on failure.
 *
 * Side effects:
 *	Creates a new temporary file.
 *
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726

727
728
729
730
731
732
733
734
735
    Tcl_DString dstring;
    HANDLE handle;

    if (TempFileName(name) == 0) {
	return NULL;
    }

    handle = (*tclWinProcs->createFileProc)((TCHAR *) name, 
	    GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, 
	    FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
    if (handle == INVALID_HANDLE_VALUE) {
	goto error;
    }

    /*
     * Write the file out, doing line translations on the way.
     */

    if (contents != NULL) {
	DWORD result, length;
	CONST char *p;

	/*
	 * Convert the contents from UTF to native encoding
	 */

	native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
	
	for (p = native; *p != '\0'; p++) {
	    if (*p == '\n') {
		length = p - native;
		if (length > 0) {
		    if (!WriteFile(handle, native, length, &result, NULL)) {
			goto error;
		    }







|
|
















>

|







699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
    Tcl_DString dstring;
    HANDLE handle;

    if (TempFileName(name) == 0) {
	return NULL;
    }

    handle = (*tclWinProcs->createFileProc)((TCHAR *) name,
	    GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
	    FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
    if (handle == INVALID_HANDLE_VALUE) {
	goto error;
    }

    /*
     * Write the file out, doing line translations on the way.
     */

    if (contents != NULL) {
	DWORD result, length;
	CONST char *p;

	/*
	 * Convert the contents from UTF to native encoding
	 */

	native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);

	for (p = native; *p != '\0'; p++) {
	    if (*p == '\n') {
		length = p - native;
		if (length > 0) {
		    if (!WriteFile(handle, native, length, &result, NULL)) {
			goto error;
		    }
751
752
753
754
755
756
757

758


759
760
761
762
763
764
765
	    goto error;
	}
    }

    return TclWinMakeFile(handle);

  error:

    /* Free the native representation of the contents if necessary */


    if (contents != NULL) {
	Tcl_DStringFree(&dstring);
    }

    TclWinConvertError(GetLastError());
    CloseHandle(handle);
    (*tclWinProcs->deleteFileProc)((TCHAR *) name);







>
|
>
>







749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
	    goto error;
	}
    }

    return TclWinMakeFile(handle);

  error:
    /*
     * Free the native representation of the contents if necessary.
     */

    if (contents != NULL) {
	Tcl_DStringFree(&dstring);
    }

    TclWinConvertError(GetLastError());
    CloseHandle(handle);
    (*tclWinProcs->deleteFileProc)((TCHAR *) name);
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj* 
TclpTempFileName()
{
    WCHAR fileName[MAX_PATH];

    if (TempFileName(fileName) == 0) {
	return NULL;
    }

    return TclpNativeToNormalized((ClientData) fileName);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreatePipe --
 *
 *      Creates an anonymous pipe.
 *
 * Results:
 *      Returns 1 on success, 0 on failure. 
 *
 * Side effects:
 *      Creates a pipe.
 *
 *----------------------------------------------------------------------
 */

int
TclpCreatePipe(
    TclFile *readPipe,	/* Location to store file handle for
				 * read side of pipe. */
    TclFile *writePipe)	/* Location to store file handle for
				 * write side of pipe. */
{
    HANDLE readHandle, writeHandle;

    if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) {
	*readPipe = TclWinMakeFile(readHandle);
	*writePipe = TclWinMakeFile(writeHandle);
	return 1;
    }

    TclWinConvertError(GetLastError());
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCloseFile --
 *
 *	Closes a pipeline file handle.  These handles are created by
 *	TclpOpenFile, TclpCreatePipe, or TclpMakeFile.
 *
 * Results:
 *	0 on success, -1 on failure.
 *
 * Side effects:
 *	The file is closed and deallocated.
 *
 *----------------------------------------------------------------------
 */

int
TclpCloseFile(
    TclFile file)	/* The file to close. */
{
    WinFile *filePtr = (WinFile *) file;

    switch (filePtr->type) {
	case WIN_FILE:
	    /*
	     * Don't close the Win32 handle if the handle is a standard channel
	     * during the thread exit process.  Otherwise, one thread may kill
	     * the stdio of another.
	     */

	    if (!TclInThreadExit() 
		    || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
			    && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
			    && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
		if (filePtr->handle != NULL &&
			CloseHandle(filePtr->handle) == FALSE) {
		    TclWinConvertError(GetLastError());
		    ckfree((char *) filePtr);
		    return -1;
		}
	    }
	    break;

	default:
	    Tcl_Panic("TclpCloseFile: unexpected file type");
    }

    ckfree((char *) filePtr);
    return 0;
}

/*
 *--------------------------------------------------------------------------
 *
 * TclpGetPid --
 *
 *	Given a HANDLE to a child process, return the process id for that
 *	child process.
 *
 * Results:
 *	Returns the process id for the child process.  If the pid was not 
 *	known by Tcl, either because the pid was not created by Tcl or the 
 *	child process has already been reaped, -1 is returned.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------------------
 */








|
















|


|


|






|
|
|
|


















|













|




|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|















|
|
|







779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
TclpTempFileName()
{
    WCHAR fileName[MAX_PATH];

    if (TempFileName(fileName) == 0) {
	return NULL;
    }

    return TclpNativeToNormalized((ClientData) fileName);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreatePipe --
 *
 *	Creates an anonymous pipe.
 *
 * Results:
 *	Returns 1 on success, 0 on failure.
 *
 * Side effects:
 *	Creates a pipe.
 *
 *----------------------------------------------------------------------
 */

int
TclpCreatePipe(
    TclFile *readPipe,		/* Location to store file handle for read side
				 * of pipe. */
    TclFile *writePipe)		/* Location to store file handle for write
				 * side of pipe. */
{
    HANDLE readHandle, writeHandle;

    if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) {
	*readPipe = TclWinMakeFile(readHandle);
	*writePipe = TclWinMakeFile(writeHandle);
	return 1;
    }

    TclWinConvertError(GetLastError());
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCloseFile --
 *
 *	Closes a pipeline file handle. These handles are created by
 *	TclpOpenFile, TclpCreatePipe, or TclpMakeFile.
 *
 * Results:
 *	0 on success, -1 on failure.
 *
 * Side effects:
 *	The file is closed and deallocated.
 *
 *----------------------------------------------------------------------
 */

int
TclpCloseFile(
    TclFile file)		/* The file to close. */
{
    WinFile *filePtr = (WinFile *) file;

    switch (filePtr->type) {
    case WIN_FILE:
	/*
	 * Don't close the Win32 handle if the handle is a standard channel
	 * during the thread exit process. Otherwise, one thread may kill the
	 * stdio of another.
	 */

	if (!TclInThreadExit()
		|| ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
		    && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
		    && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
	    if (filePtr->handle != NULL &&
		    CloseHandle(filePtr->handle) == FALSE) {
		TclWinConvertError(GetLastError());
		ckfree((char *) filePtr);
		return -1;
	    }
	}
	break;

    default:
	Tcl_Panic("TclpCloseFile: unexpected file type");
    }

    ckfree((char *) filePtr);
    return 0;
}

/*
 *--------------------------------------------------------------------------
 *
 * TclpGetPid --
 *
 *	Given a HANDLE to a child process, return the process id for that
 *	child process.
 *
 * Results:
 *	Returns the process id for the child process. If the pid was not known
 *	by Tcl, either because the pid was not created by Tcl or the child
 *	process has already been reaped, -1 is returned.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------------------
 */

920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateProcess --
 *
 *	Create a child process that has the specified files as its 
 *	standard input, output, and error.  The child process runs
 *	asynchronously under Windows NT and Windows 9x, and runs
 *	with the same environment variables as the creating process.
 *
 *	The complete Windows search path is searched to find the specified 
 *	executable.  If an executable by the given name is not found, 
 *	automatically tries appending ".com", ".exe", and ".bat" to the 
 *	executable name.
 *
 * Results:
 *	The return value is TCL_ERROR and an error message is left in
 *	the interp's result if there was a problem creating the child 
 *	process.  Otherwise, the return value is TCL_OK and *pidPtr is
 *	filled with the process id of the child process.
 * 
 * Side effects:
 *	A process is created.
 *	
 *----------------------------------------------------------------------
 */

int
TclpCreateProcess(
    Tcl_Interp *interp,		/* Interpreter in which to leave errors that
				 * occurred when creating the child process.
				 * Error messages from the child process
				 * itself are sent to errorFile. */
    int argc,			/* Number of arguments in following array. */
    CONST char **argv,		/* Array of argument strings.  argv[0]
				 * contains the name of the executable
				 * converted to native format (using the
				 * Tcl_TranslateFileName call).  Additional
				 * arguments have not been converted. */
    TclFile inputFile,		/* If non-NULL, gives the file to use as
				 * input for the child process.  If inputFile
				 * file is not readable or is NULL, the child
				 * will receive no standard input. */
    TclFile outputFile,		/* If non-NULL, gives the file that
				 * receives output from the child process.  If
				 * outputFile file is not writeable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile,		/* If non-NULL, gives the file that
				 * receives errors from the child process.  If
				 * errorFile file is not writeable or is NULL,
				 * errors from the child will be discarded.
				 * errorFile may be the same as outputFile. */
    Tcl_Pid *pidPtr)		/* If this procedure is successful, pidPtr
				 * is filled with the process id of the child
				 * process. */
{
    int result, applType, createFlags;
    Tcl_DString cmdLine;	/* Complete command line (TCHAR). */
    STARTUPINFOA startInfo;
    PROCESS_INFORMATION procInfo;
    SECURITY_ATTRIBUTES secAtts;







|
|
|
|

|
|
|



|
|
|
|
|


|










|
|
|
|

|
|
|
|
|
|



|
|
|
|
|
|
|







921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateProcess --
 *
 *	Create a child process that has the specified files as its standard
 *	input, output, and error. The child process runs asynchronously under
 *	Windows NT and Windows 9x, and runs with the same environment
 *	variables as the creating process.
 *
 *	The complete Windows search path is searched to find the specified
 *	executable. If an executable by the given name is not found,
 *	automatically tries appending ".com", ".exe", and ".bat" to the
 *	executable name.
 *
 * Results:
 *	The return value is TCL_ERROR and an error message is left in the
 *	interp's result if there was a problem creating the child process.
 *	Otherwise, the return value is TCL_OK and *pidPtr is filled with the
 *	process id of the child process.
 *
 * Side effects:
 *	A process is created.
 *
 *----------------------------------------------------------------------
 */

int
TclpCreateProcess(
    Tcl_Interp *interp,		/* Interpreter in which to leave errors that
				 * occurred when creating the child process.
				 * Error messages from the child process
				 * itself are sent to errorFile. */
    int argc,			/* Number of arguments in following array. */
    CONST char **argv,		/* Array of argument strings. argv[0] contains
				 * the name of the executable converted to
				 * native format (using the
				 * Tcl_TranslateFileName call). Additional
				 * arguments have not been converted. */
    TclFile inputFile,		/* If non-NULL, gives the file to use as input
				 * for the child process. If inputFile file is
				 * not readable or is NULL, the child will
				 * receive no standard input. */
    TclFile outputFile,		/* If non-NULL, gives the file that receives
				 * output from the child process. If
				 * outputFile file is not writeable or is
				 * NULL, output from the child will be
				 * discarded. */
    TclFile errorFile,		/* If non-NULL, gives the file that receives
				 * errors from the child process. If errorFile
				 * file is not writeable or is NULL, errors
				 * from the child will be discarded. errorFile
				 * may be the same as outputFile. */
    Tcl_Pid *pidPtr)		/* If this function is successful, pidPtr is
				 * filled with the process id of the child
				 * process. */
{
    int result, applType, createFlags;
    Tcl_DString cmdLine;	/* Complete command line (TCHAR). */
    STARTUPINFOA startInfo;
    PROCESS_INFORMATION procInfo;
    SECURITY_ATTRIBUTES secAtts;
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

    result = TCL_ERROR;
    Tcl_DStringInit(&cmdLine);
    hProcess = GetCurrentProcess();

    /*
     * STARTF_USESTDHANDLES must be used to pass handles to child process.
     * Using SetStdHandle() and/or dup2() only works when a console mode 
     * parent process is spawning an attached console mode child process.
     */

    ZeroMemory(&startInfo, sizeof(startInfo));
    startInfo.cb = sizeof(startInfo);
    startInfo.dwFlags   = STARTF_USESTDHANDLES;
    startInfo.hStdInput	= INVALID_HANDLE_VALUE;
    startInfo.hStdOutput= INVALID_HANDLE_VALUE;
    startInfo.hStdError = INVALID_HANDLE_VALUE;

    secAtts.nLength = sizeof(SECURITY_ATTRIBUTES);
    secAtts.lpSecurityDescriptor = NULL;
    secAtts.bInheritHandle = TRUE;

    /*
     * We have to check the type of each file, since we cannot duplicate 
     * some file types.  
     */

    inputHandle = INVALID_HANDLE_VALUE;
    if (inputFile != NULL) {
	filePtr = (WinFile *)inputFile;
	if (filePtr->type == WIN_FILE) {
	    inputHandle = filePtr->handle;







|





|









|
|







995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

    result = TCL_ERROR;
    Tcl_DStringInit(&cmdLine);
    hProcess = GetCurrentProcess();

    /*
     * STARTF_USESTDHANDLES must be used to pass handles to child process.
     * Using SetStdHandle() and/or dup2() only works when a console mode
     * parent process is spawning an attached console mode child process.
     */

    ZeroMemory(&startInfo, sizeof(startInfo));
    startInfo.cb = sizeof(startInfo);
    startInfo.dwFlags	= STARTF_USESTDHANDLES;
    startInfo.hStdInput	= INVALID_HANDLE_VALUE;
    startInfo.hStdOutput= INVALID_HANDLE_VALUE;
    startInfo.hStdError = INVALID_HANDLE_VALUE;

    secAtts.nLength = sizeof(SECURITY_ATTRIBUTES);
    secAtts.lpSecurityDescriptor = NULL;
    secAtts.bInheritHandle = TRUE;

    /*
     * We have to check the type of each file, since we cannot duplicate some
     * file types.
     */

    inputHandle = INVALID_HANDLE_VALUE;
    if (inputFile != NULL) {
	filePtr = (WinFile *)inputFile;
	if (filePtr->type == WIN_FILE) {
	    inputHandle = filePtr->handle;
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130

1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195

1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211

1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289

1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403

1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
	filePtr = (WinFile *)errorFile;
	if (filePtr->type == WIN_FILE) {
	    errorHandle = filePtr->handle;
	}
    }

    /*
     * Duplicate all the handles which will be passed off as stdin, stdout
     * and stderr of the child process. The duplicate handles are set to
     * be inheritable, so the child process can use them.
     */

    if (inputHandle == INVALID_HANDLE_VALUE) {
	/* 
	 * If handle was not set, stdin should return immediate EOF.
	 * Under Windows95, some applications (both 16 and 32 bit!) 
	 * cannot read from the NUL device; they read from console
	 * instead.  When running tk, this is fatal because the child 
	 * process would hang forever waiting for EOF from the unmapped 
	 * console window used by the helper application.
	 *
	 * Fortunately, the helper application detects a closed pipe 
	 * as an immediate EOF and can pass that information to the 
	 * child process.
	 */

	if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) {
	    CloseHandle(h);
	}
    } else {
	DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput,
		0, TRUE, DUPLICATE_SAME_ACCESS);
    }
    if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't duplicate input handle: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    if (outputHandle == INVALID_HANDLE_VALUE) {
	/*
	 * If handle was not set, output should be sent to an infinitely 
	 * deep sink.  Under Windows 95, some 16 bit applications cannot
	 * have stdout redirected to NUL; they send their output to
	 * the console instead.  Some applications, like "more" or "dir /p", 
	 * when outputting multiple pages to the console, also then try and
	 * read from the console to go the next page.  When running tk, this
	 * is fatal because the child process would hang forever waiting
	 * for input from the unmapped console window used by the helper
	 * application.
	 *
	 * Fortunately, the helper application will detect a closed pipe
	 * as a sink.
	 */

	if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) 
		&& (applType == APPL_DOS)) {
	    if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) {
		CloseHandle(h);
	    }
	} else {
	    startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0,
		    &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
	}
    } else {
	DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, 
		0, TRUE, DUPLICATE_SAME_ACCESS);
    }
    if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't duplicate output handle: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    if (errorHandle == INVALID_HANDLE_VALUE) {
	/*
	 * If handle was not set, errors should be sent to an infinitely
	 * deep sink.
	 */

	startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0,
		&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
    } else {
	DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, 
		0, TRUE, DUPLICATE_SAME_ACCESS);
    } 
    if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't duplicate error handle: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    /* 
     * If we do not have a console window, then we must run DOS and
     * WIN32 console mode applications as detached processes. This tells
     * the loader that the child application should not inherit the
     * console, and that it should not create a new console window for
     * the child application.  The child application should get its stdio 
     * from the redirection handles provided by this application, and run
     * in the background.
     *
     * If we are starting a GUI process, they don't automatically get a 
     * console, so it doesn't matter if they are started as foreground or
     * detached processes.  The GUI window will still pop up to the
     * foreground.
     */

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
	if (HasConsole()) {
	    createFlags = 0;
	} else if (applType == APPL_DOS) {
	    /*
	     * Under NT, 16-bit DOS applications will not run unless they
	     * can be attached to a console.  If we are running without a
	     * console, run the 16-bit program as an normal process inside
	     * of a hidden console application, and then run that hidden
	     * console as a detached process.
	     */

	    startInfo.wShowWindow = SW_HIDE;
	    startInfo.dwFlags |= STARTF_USESHOWWINDOW;
	    createFlags = CREATE_NEW_CONSOLE;
	    Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1);
	} else {
	    createFlags = DETACHED_PROCESS;
	} 
    } else {
	if (HasConsole()) {
	    createFlags = 0;
	} else {
	    createFlags = DETACHED_PROCESS;
	}
	
	if (applType == APPL_DOS) {
	    /*
	     * Under Windows 95, 16-bit DOS applications do not work well 
	     * with pipes:
	     *
	     * 1. EOF on a pipe between a detached 16-bit DOS application 
	     * and another application is not seen at the other
	     * end of the pipe, so the listening process blocks forever on 
	     * reads.  This inablity to detect EOF happens when either a 
	     * 16-bit app or the 32-bit app is the listener.  
	     *
	     * 2. If a 16-bit DOS application (detached or not) blocks when 
	     * writing to a pipe, it will never wake up again, and it
	     * eventually brings the whole system down around it.
	     *
	     * The 16-bit application is run as a normal process inside
	     * of a hidden helper console app, and this helper may be run
	     * as a detached process.  If any of the stdio handles is
	     * a pipe, the helper application accumulates information 
	     * into temp files and forwards it to or from the DOS 
	     * application as appropriate.  This means that DOS apps 
	     * must receive EOF from a stdin pipe before they will actually
	     * begin, and must finish generating stdout or stderr before 
	     * the data will be sent to the next stage of the pipe.

	     *
	     * The helper app should be located in the same directory as
	     * the tcl dll.
	     */

	    if (createFlags != 0) {
		startInfo.wShowWindow = SW_HIDE;
		startInfo.dwFlags |= STARTF_USESHOWWINDOW;
		createFlags = CREATE_NEW_CONSOLE;
	    }

	    {
		Tcl_Obj *tclExePtr, *pipeDllPtr;
		int i, fileExists;
		char *start,*end;
		Tcl_DString pipeDll;

		Tcl_DStringInit(&pipeDll);
		Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1);
		tclExePtr = TclGetObjNameOfExecutable();
		start = Tcl_GetStringFromObj(tclExePtr, &i);
		for (end = start + (i-1); end > start; end--) {
		    if (*end == '/') {
		        break;
		    }
		}
		if (*end != '/') {
		    Tcl_Panic("no / in executable path name");
		}
		i = (end - start) + 1;
		pipeDllPtr = Tcl_NewStringObj(start, i);
		Tcl_AppendToObj(pipeDllPtr, Tcl_DStringValue(&pipeDll), -1);
		Tcl_IncrRefCount(pipeDllPtr);
		if (Tcl_FSConvertToPathType(interp, pipeDllPtr) != TCL_OK) {
		    Tcl_Panic("Tcl_FSConvertToPathType failed");
		}
		fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0);
		if (!fileExists) {
		    Tcl_Panic("Tcl pipe dll \"%s\" not found",
		        Tcl_DStringValue(&pipeDll));
		}
		Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1);
		Tcl_DecrRefCount(tclExePtr);
		Tcl_DecrRefCount(pipeDllPtr);
		Tcl_DStringFree(&pipeDll);
	    }
	}
    }
    
    /*
     * cmdLine gets the full command line used to invoke the executable,
     * including the name of the executable itself.  The command line
     * arguments in argv[] are stored in cmdLine separated by spaces. 
     * Special characters in individual arguments from argv[] must be 
     * quoted when being stored in cmdLine.
     *
     * When calling any application, bear in mind that arguments that 
     * specify a path name are not converted.  If an argument contains 
     * forward slashes as path separators, it may or may not be 
     * recognized as a path name, depending on the program.  In general,
     * most applications accept forward slashes only as option 
     * delimiters and backslashes only as paths.
     *
     * Additionally, when calling a 16-bit dos or windows application, 
     * all path names must use the short, cryptic, path format (e.g., 
     * using ab~1.def instead of "a b.default").  
     */

    BuildCommandLine(execPath, argc, argv, &cmdLine);

    if ((*tclWinProcs->createProcessProc)(NULL, 
	    (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, 
	    (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    /*
     * This wait is used to force the OS to give some time to the DOS
     * process.
     */

    if (applType == APPL_DOS) {
	WaitForSingleObject(procInfo.hProcess, 50);
    }

    /* 
     * "When an application spawns a process repeatedly, a new thread 
     * instance will be created for each process but the previous 
     * instances may not be cleaned up.  This results in a significant 
     * virtual memory loss each time the process is spawned.  If there 
     * is a WaitForInputIdle() call between CreateProcess() and
     * CloseHandle(), the problem does not occur." PSS ID Number: Q124121

     */

    WaitForInputIdle(procInfo.hProcess, 5000);
    CloseHandle(procInfo.hThread);

    *pidPtr = (Tcl_Pid) procInfo.hProcess;
    if (*pidPtr != 0) {
	TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
    }
    result = TCL_OK;

    end:
    Tcl_DStringFree(&cmdLine);
    if (startInfo.hStdInput != INVALID_HANDLE_VALUE) {
        CloseHandle(startInfo.hStdInput);
    }
    if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) {
        CloseHandle(startInfo.hStdOutput);
    }
    if (startInfo.hStdError != INVALID_HANDLE_VALUE) {
	CloseHandle(startInfo.hStdError);
    }
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * HasConsole --
 *
 *	Determines whether the current application is attached to a
 *	console.
 *
 * Results:
 *	Returns TRUE if this application has a console, else FALSE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static BOOL
HasConsole()
{
    HANDLE handle;
    
    handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
	    NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);

    if (handle != INVALID_HANDLE_VALUE) {
        CloseHandle(handle);
	return TRUE;
    } else {
        return FALSE;
    }
}

/*
 *--------------------------------------------------------------------
 *
 * ApplicationType --
 *
 *	Search for the specified program and identify if it refers to a DOS,
 *	Windows 3.X, or Win32 program.  Used to determine how to invoke 
 *	a program, or if it can even be invoked.
 *
 *	It is possible to almost positively identify DOS and Windows 
 *	applications that contain the appropriate magic numbers.  However, 
 *	DOS .com files do not seem to contain a magic number; if the program 
 *	name ends with .com and could not be identified as a Windows .com
 *	file, it will be assumed to be a DOS application, even if it was
 *	just random data.  If the program name does not end with .com, no 
 *	such assumption is made.
 *
 *	The Win32 procedure GetBinaryType incorrectly identifies any 
 *	junk file that ends with .exe as a dos executable and some 
 *	executables that don't end with .exe as not executable.  Plus it 
 *	doesn't exist under win95, so I won't feel bad about reimplementing
 *	functionality.
 *
 * Results:
 *	The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32
 *	if the filename referred to the corresponding application type.
 *	If the file name could not be found or did not refer to any known 
 *	application type, APPL_NONE is returned and an error message is 
 *	left in interp.  .bat files are identified as APPL_DOS.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ApplicationType(interp, originalName, fullName)
    Tcl_Interp *interp;		/* Interp, for error message. */
    const char *originalName;	/* Name of the application to find. */
    char fullName[];		/* Filled with complete path to 
				 * application. */
{
    int applType, i, nameLen, found;
    HANDLE hFile;
    TCHAR *rest;
    char *ext;
    char buf[2];
    DWORD attr, read;
    IMAGE_DOS_HEADER header;
    Tcl_DString nameBuf, ds;
    CONST TCHAR *nativeName;
    WCHAR nativeFullPath[MAX_PATH];
    static char extensions[][5] = {"", ".com", ".exe", ".bat"};


    /* Look for the program as an external program.  First try the name
     * as it is, then try adding .com, .exe, and .bat, in that order, to
     * the name, looking for an executable.
     *
     * Using the raw SearchPath() procedure doesn't do quite what is 
     * necessary.  If the name of the executable already contains a '.' 
     * character, it will not try appending the specified extension when
     * searching (in other words, SearchPath will not find the program 
     * "a.b.exe" if the arguments specified "a.b" and ".exe").   
     * So, first look for the file as it is named.  Then manually append 
     * the extensions, looking for a match.  
     */

    applType = APPL_NONE;
    Tcl_DStringInit(&nameBuf);
    Tcl_DStringAppend(&nameBuf, originalName, -1);
    nameLen = Tcl_DStringLength(&nameBuf);

    for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
	Tcl_DStringSetLength(&nameBuf, nameLen);
	Tcl_DStringAppend(&nameBuf, extensions[i], -1);
        nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), 
		Tcl_DStringLength(&nameBuf), &ds);
	found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, 
		MAX_PATH, nativeFullPath, &rest);
	Tcl_DStringFree(&ds);
	if (found == 0) {
	    continue;
	}

	/*
	 * Ignore matches on directories or data files, return if identified
	 * a known type.
	 */

	attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath);
	if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
	    continue;
	}
	strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
	Tcl_DStringFree(&ds);

	ext = strrchr(fullName, '.');
	if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) {
	    applType = APPL_DOS;
	    break;
	}
	
	hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, 
		GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, 
		FILE_ATTRIBUTE_NORMAL, NULL);
	if (hFile == INVALID_HANDLE_VALUE) {
	    continue;
	}

	header.e_magic = 0;
	ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL);
	if (header.e_magic != IMAGE_DOS_SIGNATURE) {
	    /* 
	     * Doesn't have the magic number for relocatable executables.  If 
	     * filename ends with .com, assume it's a DOS application anyhow.
	     * Note that we didn't make this assumption at first, because some
	     * supposed .com files are really 32-bit executables with all the
	     * magic numbers and everything.  
	     */

	    CloseHandle(hFile);
	    if ((ext != NULL) && (stricmp(ext, ".com") == 0)) {
		applType = APPL_DOS;
		break;
	    }
	    continue;
	}
	if (header.e_lfarlc != sizeof(header)) {
	    /* 
	     * All Windows 3.X and Win32 and some DOS programs have this value
	     * set here.  If it doesn't, assume that since it already had the 
	     * other magic number it was a DOS application.
	     */

	    CloseHandle(hFile);
	    applType = APPL_DOS;
	    break;
	}

	/* 
	 * The DWORD at header.e_lfanew points to yet another magic number.
	 */

	buf[0] = '\0';
	SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN);
	ReadFile(hFile, (void *) buf, 2, &read, NULL);
	CloseHandle(hFile);

	if ((buf[0] == 'N') && (buf[1] == 'E')) {
	    applType = APPL_WIN3X;
	} else if ((buf[0] == 'P') && (buf[1] == 'E')) {
	    applType = APPL_WIN32;
	} else {
	    /*
	     * Strictly speaking, there should be a test that there
	     * is an 'L' and 'E' at buf[0..1], to identify the type as 
	     * DOS, but of course we ran into a DOS executable that 
	     * _doesn't_ have the magic number -- specifically, one
	     * compiled using the Lahey Fortran90 compiler.
	     */

	    applType = APPL_DOS;
	}
	break;
    }
    Tcl_DStringFree(&nameBuf);

    if (applType == APPL_NONE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't execute \"", originalName,
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	return APPL_NONE;
    }

    if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) {
	/* 
	 * Replace long path name of executable with short path name for 
	 * 16-bit applications.  Otherwise the application may not be able
	 * to correctly parse its own command line to separate off the 
	 * application name from the arguments.
	 */

	(*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, 
		nativeFullPath, MAX_PATH);
	strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
	Tcl_DStringFree(&ds);
    }
    return applType;
}

/*    
 *----------------------------------------------------------------------
 *
 * BuildCommandLine --
 *
 *	The command line arguments are stored in linePtr separated
 *	by spaces, in a form that CreateProcess() understands.  Special 
 *	characters in individual arguments from argv[] must be quoted 
 *	when being stored in cmdLine.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
BuildCommandLine(
    CONST char *executable,	/* Full path of executable (including 
				 * extension).  Replacement for argv[0]. */
    int argc,			/* Number of arguments. */
    CONST char **argv,		/* Argument strings in UTF. */
    Tcl_DString *linePtr)	/* Initialized Tcl_DString that receives the
				 * command line (TCHAR). */
{
    CONST char *arg, *start, *special;
    int quote, i;
    Tcl_DString ds;

    Tcl_DStringInit(&ds);

    /*
     * Prime the path.  Add a space separator if we were primed with
     * something.
     */

    Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1);
    if (Tcl_DStringLength(linePtr) > 0) {
	Tcl_DStringAppend(&ds, " ", 1);
    }








|
|
|



|
|
|
|
|
|
|

|
|
<


















|
|
|
|
|
|
|
|
<

|
|


|









|
|










|
|





|

|






>
|
|
|
|
|
|
|
<

|

|
<







|
|
|
|
|








|






|


|
|

|
|
|
|
|

|



|
|
|
|
|
<
|
|
|
>

|
|













>






|















|








|


|
|
|
|

|
|
|
<
|
|

|
|
|




|
|








|
<






|
|
|
|
<
|
|
>











|


|


|













|
<














|




|


|









|
|

|
|
|
|
|
|
|

|
|
|
|
<


|
|
|
|
|











|














>
|
|
|

|
|
|
|
<
|
|










|

|







|
|














|
|
|








|
|



|










|

|








|














|
|
|
|
|
















|
|
|
|



|







|




|
|
|
|












|
|












|
<







1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060

1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086

1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137

1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189

1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252

1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273

1274
1275
1276
1277
1278
1279
1280
1281
1282
1283

1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318

1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365

1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407

1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570

1571
1572
1573
1574
1575
1576
1577
	filePtr = (WinFile *)errorFile;
	if (filePtr->type == WIN_FILE) {
	    errorHandle = filePtr->handle;
	}
    }

    /*
     * Duplicate all the handles which will be passed off as stdin, stdout and
     * stderr of the child process. The duplicate handles are set to be
     * inheritable, so the child process can use them.
     */

    if (inputHandle == INVALID_HANDLE_VALUE) {
	/*
	 * If handle was not set, stdin should return immediate EOF. Under
	 * Windows95, some applications (both 16 and 32 bit!) cannot read from
	 * the NUL device; they read from console instead. When running tk,
	 * this is fatal because the child process would hang forever waiting
	 * for EOF from the unmapped console window used by the helper
	 * application.
	 *
	 * Fortunately, the helper application detects a closed pipe as an
	 * immediate EOF and can pass that information to the child process.

	 */

	if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) {
	    CloseHandle(h);
	}
    } else {
	DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput,
		0, TRUE, DUPLICATE_SAME_ACCESS);
    }
    if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't duplicate input handle: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    if (outputHandle == INVALID_HANDLE_VALUE) {
	/*
	 * If handle was not set, output should be sent to an infinitely deep
	 * sink. Under Windows 95, some 16 bit applications cannot have stdout
	 * redirected to NUL; they send their output to the console instead.
	 * Some applications, like "more" or "dir /p", when outputting
	 * multiple pages to the console, also then try and read from the
	 * console to go the next page. When running tk, this is fatal because
	 * the child process would hang forever waiting for input from the
	 * unmapped console window used by the helper application.

	 *
	 * Fortunately, the helper application will detect a closed pipe as a
	 * sink.
	 */

	if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS)
		&& (applType == APPL_DOS)) {
	    if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) {
		CloseHandle(h);
	    }
	} else {
	    startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0,
		    &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
	}
    } else {
	DuplicateHandle(hProcess, outputHandle, hProcess,
		&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
    }
    if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't duplicate output handle: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    if (errorHandle == INVALID_HANDLE_VALUE) {
	/*
	 * If handle was not set, errors should be sent to an infinitely deep
	 * sink.
	 */

	startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0,
		&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
    } else {
	DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
		0, TRUE, DUPLICATE_SAME_ACCESS);
    }
    if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't duplicate error handle: ",
		Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    /*
     * If we do not have a console window, then we must run DOS and WIN32
     * console mode applications as detached processes. This tells the loader
     * that the child application should not inherit the console, and that it
     * should not create a new console window for the child application. The
     * child application should get its stdio from the redirection handles
     * provided by this application, and run in the background.

     *
     * If we are starting a GUI process, they don't automatically get a
     * console, so it doesn't matter if they are started as foreground or
     * detached processes. The GUI window will still pop up to the foreground.

     */

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
	if (HasConsole()) {
	    createFlags = 0;
	} else if (applType == APPL_DOS) {
	    /*
	     * Under NT, 16-bit DOS applications will not run unless they can
	     * be attached to a console. If we are running without a console,
	     * run the 16-bit program as an normal process inside of a hidden
	     * console application, and then run that hidden console as a
	     * detached process.
	     */

	    startInfo.wShowWindow = SW_HIDE;
	    startInfo.dwFlags |= STARTF_USESHOWWINDOW;
	    createFlags = CREATE_NEW_CONSOLE;
	    Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1);
	} else {
	    createFlags = DETACHED_PROCESS;
	}
    } else {
	if (HasConsole()) {
	    createFlags = 0;
	} else {
	    createFlags = DETACHED_PROCESS;
	}

	if (applType == APPL_DOS) {
	    /*
	     * Under Windows 95, 16-bit DOS applications do not work well with
	     * pipes:
	     *
	     * 1. EOF on a pipe between a detached 16-bit DOS application and
	     * another application is not seen at the other end of the pipe,
	     * so the listening process blocks forever on reads. This inablity
	     * to detect EOF happens when either a 16-bit app or the 32-bit
	     * app is the listener.
	     *
	     * 2. If a 16-bit DOS application (detached or not) blocks when
	     * writing to a pipe, it will never wake up again, and it
	     * eventually brings the whole system down around it.
	     *
	     * The 16-bit application is run as a normal process inside of a
	     * hidden helper console app, and this helper may be run as a
	     * detached process. If any of the stdio handles is a pipe, the
	     * helper application accumulates information into temp files and
	     * forwards it to or from the DOS application as appropriate.

	     * This means that DOS apps must receive EOF from a stdin pipe
	     * before they will actually begin, and must finish generating
	     * stdout or stderr before the data will be sent to the next stage
	     * of the pipe.
	     *
	     * The helper app should be located in the same directory as the
	     * tcl dll.
	     */

	    if (createFlags != 0) {
		startInfo.wShowWindow = SW_HIDE;
		startInfo.dwFlags |= STARTF_USESHOWWINDOW;
		createFlags = CREATE_NEW_CONSOLE;
	    }

	    {
		Tcl_Obj *tclExePtr, *pipeDllPtr;
		int i, fileExists;
		char *start,*end;
		Tcl_DString pipeDll;

		Tcl_DStringInit(&pipeDll);
		Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1);
		tclExePtr = TclGetObjNameOfExecutable();
		start = Tcl_GetStringFromObj(tclExePtr, &i);
		for (end = start + (i-1); end > start; end--) {
		    if (*end == '/') {
			break;
		    }
		}
		if (*end != '/') {
		    Tcl_Panic("no / in executable path name");
		}
		i = (end - start) + 1;
		pipeDllPtr = Tcl_NewStringObj(start, i);
		Tcl_AppendToObj(pipeDllPtr, Tcl_DStringValue(&pipeDll), -1);
		Tcl_IncrRefCount(pipeDllPtr);
		if (Tcl_FSConvertToPathType(interp, pipeDllPtr) != TCL_OK) {
		    Tcl_Panic("Tcl_FSConvertToPathType failed");
		}
		fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0);
		if (!fileExists) {
		    Tcl_Panic("Tcl pipe dll \"%s\" not found",
			Tcl_DStringValue(&pipeDll));
		}
		Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1);
		Tcl_DecrRefCount(tclExePtr);
		Tcl_DecrRefCount(pipeDllPtr);
		Tcl_DStringFree(&pipeDll);
	    }
	}
    }

    /*
     * cmdLine gets the full command line used to invoke the executable,
     * including the name of the executable itself. The command line arguments
     * in argv[] are stored in cmdLine separated by spaces. Special characters
     * in individual arguments from argv[] must be quoted when being stored in
     * cmdLine.
     *
     * When calling any application, bear in mind that arguments that specify
     * a path name are not converted. If an argument contains forward slashes
     * as path separators, it may or may not be recognized as a path name,

     * depending on the program. In general, most applications accept forward
     * slashes only as option delimiters and backslashes only as paths.
     *
     * Additionally, when calling a 16-bit dos or windows application, all
     * path names must use the short, cryptic, path format (e.g., using
     * ab~1.def instead of "a b.default").
     */

    BuildCommandLine(execPath, argc, argv, &cmdLine);

    if ((*tclWinProcs->createProcessProc)(NULL,
	    (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
	    (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	goto end;
    }

    /*
     * This wait is used to force the OS to give some time to the DOS process.

     */

    if (applType == APPL_DOS) {
	WaitForSingleObject(procInfo.hProcess, 50);
    }

    /*
     * "When an application spawns a process repeatedly, a new thread instance
     * will be created for each process but the previous instances may not be
     * cleaned up. This results in a significant virtual memory loss each time

     * the process is spawned. If there is a WaitForInputIdle() call between
     * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
     * Number: Q124121
     */

    WaitForInputIdle(procInfo.hProcess, 5000);
    CloseHandle(procInfo.hThread);

    *pidPtr = (Tcl_Pid) procInfo.hProcess;
    if (*pidPtr != 0) {
	TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
    }
    result = TCL_OK;

  end:
    Tcl_DStringFree(&cmdLine);
    if (startInfo.hStdInput != INVALID_HANDLE_VALUE) {
	CloseHandle(startInfo.hStdInput);
    }
    if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) {
	CloseHandle(startInfo.hStdOutput);
    }
    if (startInfo.hStdError != INVALID_HANDLE_VALUE) {
	CloseHandle(startInfo.hStdError);
    }
    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * HasConsole --
 *
 *	Determines whether the current application is attached to a console.

 *
 * Results:
 *	Returns TRUE if this application has a console, else FALSE.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static BOOL
HasConsole()
{
    HANDLE handle;

    handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
	    NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);

    if (handle != INVALID_HANDLE_VALUE) {
	CloseHandle(handle);
	return TRUE;
    } else {
	return FALSE;
    }
}

/*
 *--------------------------------------------------------------------
 *
 * ApplicationType --
 *
 *	Search for the specified program and identify if it refers to a DOS,
 *	Windows 3.X, or Win32 program.	Used to determine how to invoke a
 *	program, or if it can even be invoked.
 *
 *	It is possible to almost positively identify DOS and Windows
 *	applications that contain the appropriate magic numbers. However, DOS
 *	.com files do not seem to contain a magic number; if the program name
 *	ends with .com and could not be identified as a Windows .com file, it
 *	will be assumed to be a DOS application, even if it was just random
 *	data. If the program name does not end with .com, no such assumption
 *	is made.
 *
 *	The Win32 function GetBinaryType incorrectly identifies any junk file
 *	that ends with .exe as a dos executable and some executables that
 *	don't end with .exe as not executable. Plus it doesn't exist under
 *	win95, so I won't feel bad about reimplementing functionality.

 *
 * Results:
 *	The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 if the
 *	filename referred to the corresponding application type. If the file
 *	name could not be found or did not refer to any known application
 *	type, APPL_NONE is returned and an error message is left in interp.
 *	.bat files are identified as APPL_DOS.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ApplicationType(interp, originalName, fullName)
    Tcl_Interp *interp;		/* Interp, for error message. */
    const char *originalName;	/* Name of the application to find. */
    char fullName[];		/* Filled with complete path to
				 * application. */
{
    int applType, i, nameLen, found;
    HANDLE hFile;
    TCHAR *rest;
    char *ext;
    char buf[2];
    DWORD attr, read;
    IMAGE_DOS_HEADER header;
    Tcl_DString nameBuf, ds;
    CONST TCHAR *nativeName;
    WCHAR nativeFullPath[MAX_PATH];
    static char extensions[][5] = {"", ".com", ".exe", ".bat"};

    /*
     * Look for the program as an external program. First try the name as it
     * is, then try adding .com, .exe, and .bat, in that order, to the name,
     * looking for an executable.
     *
     * Using the raw SearchPath() function doesn't do quite what is necessary.
     * If the name of the executable already contains a '.' character, it will
     * not try appending the specified extension when searching (in other
     * words, SearchPath will not find the program "a.b.exe" if the arguments

     * specified "a.b" and ".exe"). So, first look for the file as it is
     * named. Then manually append the extensions, looking for a match.
     */

    applType = APPL_NONE;
    Tcl_DStringInit(&nameBuf);
    Tcl_DStringAppend(&nameBuf, originalName, -1);
    nameLen = Tcl_DStringLength(&nameBuf);

    for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
	Tcl_DStringSetLength(&nameBuf, nameLen);
	Tcl_DStringAppend(&nameBuf, extensions[i], -1);
	nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf),
		Tcl_DStringLength(&nameBuf), &ds);
	found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL,
		MAX_PATH, nativeFullPath, &rest);
	Tcl_DStringFree(&ds);
	if (found == 0) {
	    continue;
	}

	/*
	 * Ignore matches on directories or data files, return if identified a
	 * known type.
	 */

	attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath);
	if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
	    continue;
	}
	strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
	Tcl_DStringFree(&ds);

	ext = strrchr(fullName, '.');
	if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) {
	    applType = APPL_DOS;
	    break;
	}

	hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath,
		GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
		FILE_ATTRIBUTE_NORMAL, NULL);
	if (hFile == INVALID_HANDLE_VALUE) {
	    continue;
	}

	header.e_magic = 0;
	ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL);
	if (header.e_magic != IMAGE_DOS_SIGNATURE) {
	    /*
	     * Doesn't have the magic number for relocatable executables. If
	     * filename ends with .com, assume it's a DOS application anyhow.
	     * Note that we didn't make this assumption at first, because some
	     * supposed .com files are really 32-bit executables with all the
	     * magic numbers and everything.
	     */

	    CloseHandle(hFile);
	    if ((ext != NULL) && (stricmp(ext, ".com") == 0)) {
		applType = APPL_DOS;
		break;
	    }
	    continue;
	}
	if (header.e_lfarlc != sizeof(header)) {
	    /*
	     * All Windows 3.X and Win32 and some DOS programs have this value
	     * set here. If it doesn't, assume that since it already had the
	     * other magic number it was a DOS application.
	     */

	    CloseHandle(hFile);
	    applType = APPL_DOS;
	    break;
	}

	/*
	 * The DWORD at header.e_lfanew points to yet another magic number.
	 */

	buf[0] = '\0';
	SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN);
	ReadFile(hFile, (void *) buf, 2, &read, NULL);
	CloseHandle(hFile);

	if ((buf[0] == 'N') && (buf[1] == 'E')) {
	    applType = APPL_WIN3X;
	} else if ((buf[0] == 'P') && (buf[1] == 'E')) {
	    applType = APPL_WIN32;
	} else {
	    /*
	     * Strictly speaking, there should be a test that there is an 'L'
	     * and 'E' at buf[0..1], to identify the type as DOS, but of
	     * course we ran into a DOS executable that _doesn't_ have the
	     * magic number - specifically, one compiled using the Lahey
	     * Fortran90 compiler.
	     */

	    applType = APPL_DOS;
	}
	break;
    }
    Tcl_DStringFree(&nameBuf);

    if (applType == APPL_NONE) {
	TclWinConvertError(GetLastError());
	Tcl_AppendResult(interp, "couldn't execute \"", originalName,
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	return APPL_NONE;
    }

    if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) {
	/*
	 * Replace long path name of executable with short path name for
	 * 16-bit applications. Otherwise the application may not be able to
	 * correctly parse its own command line to separate off the
	 * application name from the arguments.
	 */

	(*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath,
		nativeFullPath, MAX_PATH);
	strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
	Tcl_DStringFree(&ds);
    }
    return applType;
}

/*
 *----------------------------------------------------------------------
 *
 * BuildCommandLine --
 *
 *	The command line arguments are stored in linePtr separated by spaces,
 *	in a form that CreateProcess() understands. Special characters in
 *	individual arguments from argv[] must be quoted when being stored in
 *	cmdLine.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
BuildCommandLine(
    CONST char *executable,	/* Full path of executable (including
				 * extension). Replacement for argv[0]. */
    int argc,			/* Number of arguments. */
    CONST char **argv,		/* Argument strings in UTF. */
    Tcl_DString *linePtr)	/* Initialized Tcl_DString that receives the
				 * command line (TCHAR). */
{
    CONST char *arg, *start, *special;
    int quote, i;
    Tcl_DString ds;

    Tcl_DStringInit(&ds);

    /*
     * Prime the path. Add a space separator if we were primed with something.

     */

    Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1);
    if (Tcl_DStringLength(linePtr) > 0) {
	Tcl_DStringAppend(&ds, " ", 1);
    }

1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
	quote = 0;
	if (arg[0] == '\0') {
	    quote = 1;
	} else {
	    int count;
	    Tcl_UniChar ch;
	    for (start = arg; *start != '\0'; start += count) {
	        count = Tcl_UtfToUniChar(start, &ch);
		if (Tcl_UniCharIsSpace(ch)) {	/* INTL: ISO space. */
		    quote = 1;
		    break;
		}
	    }
	}
	if (quote) {
	    Tcl_DStringAppend(&ds, "\"", 1);
	}
	start = arg;	    
	for (special = arg; ; ) {
	    if ((*special == '\\') && (special[1] == '\\' ||
		    special[1] == '"' || (quote && special[1] == '\0'))) {
		Tcl_DStringAppend(&ds, start, (int) (special - start));
		start = special;
		while (1) {
		    special++;
		    if (*special == '"' || (quote && *special == '\0')) {
			/* 
			 * N backslashes followed a quote -> insert 
			 * N * 2 + 1 backslashes then a quote.
			 */

			Tcl_DStringAppend(&ds, start,
				(int) (special - start));
			break;
		    }
		    if (*special != '\\') {







|









|








|
|
|







1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
	quote = 0;
	if (arg[0] == '\0') {
	    quote = 1;
	} else {
	    int count;
	    Tcl_UniChar ch;
	    for (start = arg; *start != '\0'; start += count) {
		count = Tcl_UtfToUniChar(start, &ch);
		if (Tcl_UniCharIsSpace(ch)) {	/* INTL: ISO space. */
		    quote = 1;
		    break;
		}
	    }
	}
	if (quote) {
	    Tcl_DStringAppend(&ds, "\"", 1);
	}
	start = arg;
	for (special = arg; ; ) {
	    if ((*special == '\\') && (special[1] == '\\' ||
		    special[1] == '"' || (quote && special[1] == '\0'))) {
		Tcl_DStringAppend(&ds, start, (int) (special - start));
		start = special;
		while (1) {
		    special++;
		    if (*special == '"' || (quote && *special == '\0')) {
			/*
			 * N backslashes followed a quote -> insert N * 2 + 1
			 * backslashes then a quote.
			 */

			Tcl_DStringAppend(&ds, start,
				(int) (special - start));
			break;
		    }
		    if (*special != '\\') {
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateCommandChannel --
 *
 *	This function is called by Tcl_OpenCommandChannel to perform
 *	the platform specific channel initialization for a command
 *	channel.
 *
 * Results:
 *	Returns a new channel or NULL on failure.
 *
 * Side effects:
 *	Allocates a new channel.
 *







|
|
<







1646
1647
1648
1649
1650
1651
1652
1653
1654

1655
1656
1657
1658
1659
1660
1661
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateCommandChannel --
 *
 *	This function is called by Tcl_OpenCommandChannel to perform the
 *	platform specific channel initialization for a command channel.

 *
 * Results:
 *	Returns a new channel or NULL on failure.
 *
 * Side effects:
 *	Allocates a new channel.
 *
1692
1693
1694
1695
1696
1697
1698

1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
    infoPtr->writeFile = writeFile;
    infoPtr->errorFile = errorFile;
    infoPtr->numPids = numPids;
    infoPtr->pidPtr = pidPtr;
    infoPtr->writeBuf = 0;
    infoPtr->writeBufLen = 0;
    infoPtr->writeError = 0;


    /*
     * Use one of the fds associated with the channel as the
     * channel id.
     */

    if (readFile) {
	channelId = (int) ((WinFile*)readFile)->handle;
    } else if (writeFile) {
	channelId = (int) ((WinFile*)writeFile)->handle;
    } else if (errorFile) {







>


|
<







1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695

1696
1697
1698
1699
1700
1701
1702
    infoPtr->writeFile = writeFile;
    infoPtr->errorFile = errorFile;
    infoPtr->numPids = numPids;
    infoPtr->pidPtr = pidPtr;
    infoPtr->writeBuf = 0;
    infoPtr->writeBufLen = 0;
    infoPtr->writeError = 0;
    infoPtr->channel = (Tcl_Channel) NULL;

    /*
     * Use one of the fds associated with the channel as the channel id.

     */

    if (readFile) {
	channelId = (int) ((WinFile*)readFile)->handle;
    } else if (writeFile) {
	channelId = (int) ((WinFile*)writeFile)->handle;
    } else if (errorFile) {
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
	 */

	infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
		infoPtr, 0, &id);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); 
        infoPtr->validMask |= TCL_READABLE;
    } else {
	infoPtr->readThread = 0;
    }
    if (writeFile != NULL) {
	/*
	 * Start the background writer thread.
	 */

	infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
		infoPtr, 0, &id);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); 
        infoPtr->validMask |= TCL_WRITABLE;
    }

    /*
     * For backward compatibility with previous versions of Tcl, we
     * use "file%d" as the base name for pipes even though it would
     * be more natural to use "pipe%d".
     * Use the pointer to keep the channel names unique, in case
     * channels share handles (stdin/stdout).
     */

    wsprintfA(channelName, "file%lx", infoPtr);
    infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
            (ClientData) infoPtr, infoPtr->validMask);

    /*
     * Pipes have AUTO translation mode on Windows and ^Z eof char, which
     * means that a ^Z will be appended to them at close. This is needed
     * for Windows programs that expect a ^Z at EOF.
     */

    Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
	    "-translation", "auto");
    Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
	    "-eofchar", "\032 {}");
    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetAndDetachPids --
 *
 *	Stores a list of the command PIDs for a command channel in
 *	the interp's result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the interp's result.
 *







|
|













|
|



|
|
<
|
|




|



|
|














|
|







1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743

1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
	 */

	infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
		infoPtr, 0, &id);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_READABLE;
    } else {
	infoPtr->readThread = 0;
    }
    if (writeFile != NULL) {
	/*
	 * Start the background writer thread.
	 */

	infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
		infoPtr, 0, &id);
	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_WRITABLE;
    }

    /*
     * For backward compatibility with previous versions of Tcl, we use
     * "file%d" as the base name for pipes even though it would be more

     * natural to use "pipe%d". Use the pointer to keep the channel names
     * unique, in case channels share handles (stdin/stdout).
     */

    wsprintfA(channelName, "file%lx", infoPtr);
    infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
	    (ClientData) infoPtr, infoPtr->validMask);

    /*
     * Pipes have AUTO translation mode on Windows and ^Z eof char, which
     * means that a ^Z will be appended to them at close. This is needed for
     * Windows programs that expect a ^Z at EOF.
     */

    Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
	    "-translation", "auto");
    Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
	    "-eofchar", "\032 {}");
    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetAndDetachPids --
 *
 *	Stores a list of the command PIDs for a command channel in the
 *	interp's result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the interp's result.
 *
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824

    /*
     * Punt if the channel is not a command channel.
     */

    chanTypePtr = Tcl_GetChannelType(chan);
    if (chanTypePtr != &pipeChannelType) {
        return;
    }

    pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
    for (i = 0; i < pipePtr->numPids; i++) {
        wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
        Tcl_AppendElement(interp, buf);
        Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
    }
    if (pipePtr->numPids > 0) {
        ckfree((char *) pipePtr->pidPtr);
        pipePtr->numPids = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeBlockModeProc --







|




|
|
|


|
|







1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816

    /*
     * Punt if the channel is not a command channel.
     */

    chanTypePtr = Tcl_GetChannelType(chan);
    if (chanTypePtr != &pipeChannelType) {
	return;
    }

    pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
    for (i = 0; i < pipePtr->numPids; i++) {
	wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
	Tcl_AppendElement(interp, buf);
	Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
    }
    if (pipePtr->numPids > 0) {
	ckfree((char *) pipePtr->pidPtr);
	pipePtr->numPids = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeBlockModeProc --
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
 *----------------------------------------------------------------------
 */

static int
PipeBlockModeProc(
    ClientData instanceData,	/* Instance data for channel. */
    int mode)			/* TCL_MODE_BLOCKING or
                                 * TCL_MODE_NONBLOCKING. */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    
    /*
     * Pipes on Windows can not be switched between blocking and nonblocking,
     * hence we have to emulate the behavior. This is done in the input
     * function by checking against a bit in the state. We set or unset the
     * bit here to cause the input function to emulate the correct behavior.
     */








|


|







1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
 *----------------------------------------------------------------------
 */

static int
PipeBlockModeProc(
    ClientData instanceData,	/* Instance data for channel. */
    int mode)			/* TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;

    /*
     * Pipes on Windows can not be switched between blocking and nonblocking,
     * hence we have to emulate the behavior. This is done in the input
     * function by checking against a bit in the state. We set or unset the
     * bit here to cause the input function to emulate the correct behavior.
     */

1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
    PipeInfo *infoPtr, **nextPtrPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    DWORD exitCode;

    errorCode = 0;
    result = 0;

    if ((!flags || flags == TCL_CLOSE_READ)
	    && (pipePtr->readFile != NULL)) {
	/*
	 * Clean up the background thread if necessary.  Note that this
	 * must be done before we can close the file, since the 
	 * thread may be blocking trying to read from the pipe.
	 */

	if (pipePtr->readThread) {
	    /*
	     * The thread may already have closed on its own.  Check
	     * its exit code.
	     */

	    GetExitCodeThread(pipePtr->readThread, &exitCode);

	    if (exitCode == STILL_ACTIVE) {
		/*
		 * Set the stop event so that if the reader thread is
		 * blocked in PipeReaderThread on WaitForMultipleEvents,
		 * it will exit cleanly.
		 */

		SetEvent(pipePtr->stopReader);

		/*
		 * Wait at most 20 milliseconds for the reader thread to
		 * close.
		 */

		if (WaitForSingleObject(pipePtr->readThread,
			20) == WAIT_TIMEOUT) {
		    /*
		     * The thread must be blocked waiting for the pipe to
		     * become readable in ReadFile().  There isn't a
		     * clean way to exit the thread from this condition.
		     * We should terminate the child process instead to
		     * get the reader thread to fall out of ReadFile with
		     * a FALSE.  (below) is not the correct way to do
		     * this, but will stay here until a better solution
		     * is found.
		     *
		     * Note that we need to guard against terminating the
		     * thread while it is in the middle of
		     * Tcl_ThreadAlert because it won't be able to
		     * release the notifier lock.
		     */

		    Tcl_MutexLock(&pipeMutex);

		    /* BUG: this leaks memory */
		    TerminateThread(pipePtr->readThread, 0);
		    Tcl_MutexUnlock(&pipeMutex);







|
<

|
|
|




|
|






|
|
|













|
|
|
|
|
|
<


|
<
|







1877
1878
1879
1880
1881
1882
1883
1884

1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922

1923
1924
1925

1926
1927
1928
1929
1930
1931
1932
1933
    PipeInfo *infoPtr, **nextPtrPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    DWORD exitCode;

    errorCode = 0;
    result = 0;

    if ((!flags || flags == TCL_CLOSE_READ) && (pipePtr->readFile != NULL)) {

	/*
	 * Clean up the background thread if necessary. Note that this must be
	 * done before we can close the file, since the thread may be blocking
	 * trying to read from the pipe.
	 */

	if (pipePtr->readThread) {
	    /*
	     * The thread may already have closed on its own. Check its exit
	     * code.
	     */

	    GetExitCodeThread(pipePtr->readThread, &exitCode);

	    if (exitCode == STILL_ACTIVE) {
		/*
		 * Set the stop event so that if the reader thread is blocked
		 * in PipeReaderThread on WaitForMultipleEvents, it will exit
		 * cleanly.
		 */

		SetEvent(pipePtr->stopReader);

		/*
		 * Wait at most 20 milliseconds for the reader thread to
		 * close.
		 */

		if (WaitForSingleObject(pipePtr->readThread,
			20) == WAIT_TIMEOUT) {
		    /*
		     * The thread must be blocked waiting for the pipe to
		     * become readable in ReadFile(). There isn't a clean way
		     * to exit the thread from this condition. We should
		     * terminate the child process instead to get the reader
		     * thread to fall out of ReadFile with a FALSE. (below) is
		     * not the correct way to do this, but will stay here
		     * until a better solution is found.

		     *
		     * Note that we need to guard against terminating the
		     * thread while it is in the middle of Tcl_ThreadAlert

		     * because it won't be able to release the notifier lock.
		     */

		    Tcl_MutexLock(&pipeMutex);

		    /* BUG: this leaks memory */
		    TerminateThread(pipePtr->readThread, 0);
		    Tcl_MutexUnlock(&pipeMutex);
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
	pipePtr->validMask &= ~TCL_READABLE;
	pipePtr->readFile = NULL;
    }
    if ((!flags || flags & TCL_CLOSE_WRITE)
	    && (pipePtr->writeFile != NULL)) {
	if (pipePtr->writeThread) {
	    /*
	     * Wait for the writer thread to finish the current buffer,
	     * then terminate the thread and close the handles.  If the
	     * channel is nonblocking, there should be no pending write
	     * operations.
	     */

	    WaitForSingleObject(pipePtr->writable, INFINITE);

	    /*
	     * The thread may already have closed on it's own.  Check
	     * its exit code.
	     */

	    GetExitCodeThread(pipePtr->writeThread, &exitCode);

	    if (exitCode == STILL_ACTIVE) {
		/*
		 * Set the stop event so that if the reader thread is
		 * blocked in PipeReaderThread on WaitForMultipleEvents,
		 * it will exit cleanly.
		 */

		SetEvent(pipePtr->stopWriter);

		/*
		 * Wait at most 20 milliseconds for the reader thread to
		 * close.
		 */

		if (WaitForSingleObject(pipePtr->writeThread,
			20) == WAIT_TIMEOUT) {
		    /*
		     * The thread must be blocked waiting for the pipe to
		     * consume input in WriteFile().  There isn't a clean
		     * way to exit the thread from this condition.  We
		     * should terminate the child process instead to get
		     * the writer thread to fall out of WriteFile with a
		     * FALSE.  (below) is not the correct way to do this,
		     * but will stay here until a better solution is
		     * found.
		     *
		     * Note that we need to guard against terminating the
		     * thread while it is in the middle of
		     * Tcl_ThreadAlert because it won't be able to
		     * release the notifier lock.
		     */

		    Tcl_MutexLock(&pipeMutex);

		    /* BUG: this leaks memory */
		    TerminateThread(pipePtr->writeThread, 0);
		    Tcl_MutexUnlock(&pipeMutex);







|
|
|
<





|
|






|
|
|













|
|
|
|
|
|
<


|
<
|







1946
1947
1948
1949
1950
1951
1952
1953
1954
1955

1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990

1991
1992
1993

1994
1995
1996
1997
1998
1999
2000
2001
	pipePtr->validMask &= ~TCL_READABLE;
	pipePtr->readFile = NULL;
    }
    if ((!flags || flags & TCL_CLOSE_WRITE)
	    && (pipePtr->writeFile != NULL)) {
	if (pipePtr->writeThread) {
	    /*
	     * Wait for the writer thread to finish the current buffer, then
	     * terminate the thread and close the handles. If the channel is
	     * nonblocking, there should be no pending write operations.

	     */

	    WaitForSingleObject(pipePtr->writable, INFINITE);

	    /*
	     * The thread may already have closed on it's own. Check its exit
	     * code.
	     */

	    GetExitCodeThread(pipePtr->writeThread, &exitCode);

	    if (exitCode == STILL_ACTIVE) {
		/*
		 * Set the stop event so that if the reader thread is blocked
		 * in PipeReaderThread on WaitForMultipleEvents, it will exit
		 * cleanly.
		 */

		SetEvent(pipePtr->stopWriter);

		/*
		 * Wait at most 20 milliseconds for the reader thread to
		 * close.
		 */

		if (WaitForSingleObject(pipePtr->writeThread,
			20) == WAIT_TIMEOUT) {
		    /*
		     * The thread must be blocked waiting for the pipe to
		     * consume input in WriteFile(). There isn't a clean way
		     * to exit the thread from this condition. We should
		     * terminate the child process instead to get the writer
		     * thread to fall out of WriteFile with a FALSE. (below)
		     * is not the correct way to do this, but will stay here
		     * until a better solution is found.

		     *
		     * Note that we need to guard against terminating the
		     * thread while it is in the middle of Tcl_ThreadAlert

		     * because it won't be able to release the notifier lock.
		     */

		    Tcl_MutexLock(&pipeMutex);

		    /* BUG: this leaks memory */
		    TerminateThread(pipePtr->writeThread, 0);
		    Tcl_MutexUnlock(&pipeMutex);
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068


2069



2070
2071
2072
2073
2074
2075
2076
	    *nextPtrPtr = infoPtr->nextPtr;
	    break;
	}
    }

    if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) {
	/*
	 * If the channel is non-blocking or Tcl is being cleaned up,
	 * just detach the children PIDs, reap them (important if we are
	 * in a dynamic load module), and discard the errorFile.
	 */

	Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
	Tcl_ReapDetachedProcs();

	if (pipePtr->errorFile) {
	    TclpCloseFile(pipePtr->errorFile);


	}



    } else {
	/*
	 * Wrap the error file into a channel and give it to the cleanup
	 * routine.
	 */

	if (pipePtr->errorFile) {







|
|
|






|
>
>
|
>
>
>







2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
	    *nextPtrPtr = infoPtr->nextPtr;
	    break;
	}
    }

    if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) {
	/*
	 * If the channel is non-blocking or Tcl is being cleaned up, just
	 * detach the children PIDs, reap them (important if we are in a
	 * dynamic load module), and discard the errorFile.
	 */

	Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
	Tcl_ReapDetachedProcs();

	if (pipePtr->errorFile) {
	    if (TclpCloseFile(pipePtr->errorFile) != 0) {
		if (errorCode == 0) {
		    errorCode = errno;
		}
	    }
	}
	result = 0;
    } else {
	/*
	 * Wrap the error file into a channel and give it to the cleanup
	 * routine.
	 */

	if (pipePtr->errorFile) {
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
}

/*
 *----------------------------------------------------------------------
 *
 * PipeInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns
 *	count of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeInputProc(
    ClientData instanceData,		/* Pipe state. */
    char *buf,				/* Where to store data read. */
    int bufSize,			/* How much space is available
                                         * in the buffer? */
    int *errorCode)			/* Where to store error code. */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->readFile;
    DWORD count, bytesRead = 0;
    int result;

    *errorCode = 0;







|
|













|
|
|
|
|







2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
}

/*
 *----------------------------------------------------------------------
 *
 * PipeInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns count
 *	of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeInputProc(
    ClientData instanceData,	/* Pipe state. */
    char *buf,			/* Where to store data read. */
    int bufSize,		/* How much space is available in the
				 * buffer? */
    int *errorCode)		/* Where to store error code. */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->readFile;
    DWORD count, bytesRead = 0;
    int result;

    *errorCode = 0;
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
    if (result == -1) {
	*errorCode = errno;
	return -1;
    }

    if (infoPtr->readFlags & PIPE_EXTRABYTE) {
	/*
	 * The reader thread consumed 1 byte as a side effect of
	 * waiting so we need to move it into the buffer.
	 */

	*buf = infoPtr->extraByte;
	infoPtr->readFlags &= ~PIPE_EXTRABYTE;
	buf++;
	bufSize--;
	bytesRead = 1;

	/*
	 * If further read attempts would block, return what we have.
	 */

	if (result == 0) {
	    return bytesRead;
	}
    }

    /*
     * Attempt to read bufSize bytes.  The read will return immediately
     * if there is any data available.  Otherwise it will block until
     * at least one byte is available or an EOF occurs.
     */

    if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
	    (LPOVERLAPPED) NULL) == TRUE) {
	return bytesRead + count;
    } else if (bytesRead) {
	/*







|
|


















|
|
|







2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
    if (result == -1) {
	*errorCode = errno;
	return -1;
    }

    if (infoPtr->readFlags & PIPE_EXTRABYTE) {
	/*
	 * The reader thread consumed 1 byte as a side effect of waiting so we
	 * need to move it into the buffer.
	 */

	*buf = infoPtr->extraByte;
	infoPtr->readFlags &= ~PIPE_EXTRABYTE;
	buf++;
	bufSize--;
	bytesRead = 1;

	/*
	 * If further read attempts would block, return what we have.
	 */

	if (result == 0) {
	    return bytesRead;
	}
    }

    /*
     * Attempt to read bufSize bytes. The read will return immediately if
     * there is any data available. Otherwise it will block until at least one
     * byte is available or an EOF occurs.
     */

    if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
	    (LPOVERLAPPED) NULL) == TRUE) {
	return bytesRead + count;
    } else if (bytesRead) {
	/*
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
}

/*
 *----------------------------------------------------------------------
 *
 * PipeOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how
 *	many characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an
 *	error indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeOutputProc(
    ClientData instanceData,		/* Pipe state. */
    CONST char *buf,			/* The data buffer. */
    int toWrite,			/* How many bytes to write? */
    int *errorCode)			/* Where to store error code. */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->writeFile;
    DWORD bytesWritten, timeout;
    
    *errorCode = 0;
    timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete
	 * and the channel is in non-blocking mode.
	 */

	errno = EAGAIN;
	goto error;
    }
    
    /*
     * Check for a background error on the last write.
     */

    if (infoPtr->writeError) {
	TclWinConvertError(infoPtr->writeError);
	infoPtr->writeError = 0;
	goto error;
    }

    if (infoPtr->flags & PIPE_ASYNC) {
	/*
	 * The pipe is non-blocking, so copy the data into the output
	 * buffer and restart the writer thread.
	 */

	if (toWrite > infoPtr->writeBufLen) {
	    /*
	     * Reallocate the buffer to be large enough to hold the data.
	     */

	    if (infoPtr->writeBuf) {
		ckfree(infoPtr->writeBuf);
	    }
	    infoPtr->writeBufLen = toWrite;
	    infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
	}
	memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
	infoPtr->toWrite = toWrite;
	ResetEvent(infoPtr->writable);
	SetEvent(infoPtr->startWriter);
	bytesWritten = toWrite;
    } else {
	/*
	 * In the blocking case, just try to write the buffer directly.
	 * This avoids an unnecessary copy.
	 */

	if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite,
		&bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
	    TclWinConvertError(GetLastError());
	    goto error;
	}
    }
    return bytesWritten;

    error:
    *errorCode = errno;
    return -1;

}

/*
 *----------------------------------------------------------------------
 *
 * PipeEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event
 *	reaches the front of the event queue.  This procedure invokes
 *	Tcl_NotifyChannel on the pipe.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|









|
|
|
|




|




|
|





|












|
|




















|
|










|










|
|
|


|
|
|
|







2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
}

/*
 *----------------------------------------------------------------------
 *
 * PipeOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how many
 *	characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
PipeOutputProc(
    ClientData instanceData,	/* Pipe state. */
    CONST char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCode)		/* Where to store error code. */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->writeFile;
    DWORD bytesWritten, timeout;

    *errorCode = 0;
    timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EAGAIN;
	goto error;
    }

    /*
     * Check for a background error on the last write.
     */

    if (infoPtr->writeError) {
	TclWinConvertError(infoPtr->writeError);
	infoPtr->writeError = 0;
	goto error;
    }

    if (infoPtr->flags & PIPE_ASYNC) {
	/*
	 * The pipe is non-blocking, so copy the data into the output buffer
	 * and restart the writer thread.
	 */

	if (toWrite > infoPtr->writeBufLen) {
	    /*
	     * Reallocate the buffer to be large enough to hold the data.
	     */

	    if (infoPtr->writeBuf) {
		ckfree(infoPtr->writeBuf);
	    }
	    infoPtr->writeBufLen = toWrite;
	    infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
	}
	memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
	infoPtr->toWrite = toWrite;
	ResetEvent(infoPtr->writable);
	SetEvent(infoPtr->startWriter);
	bytesWritten = toWrite;
    } else {
	/*
	 * In the blocking case, just try to write the buffer directly. This
	 * avoids an unnecessary copy.
	 */

	if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite,
		&bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
	    TclWinConvertError(GetLastError());
	    goto error;
	}
    }
    return bytesWritten;

  error:
    *errorCode = errno;
    return -1;

}

/*
 *----------------------------------------------------------------------
 *
 * PipeEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This function invokes Tcl_NotifyChannel
 *	on the pipe.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched pipes for the one whose handle
     * matches the event.  We do this rather than simply dereferencing
     * the handle in the event so that pipes can be deleted while the
     * event is in the queue.
     */

    for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (pipeEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(PIPE_PENDING);
	    break;
	}
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the pipe is readable.  Note
     * that we can't tell if a pipe is writable, so we always report it
     * as being writable unless we have detected EOF.
     */

    filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile;
    mask = 0;
    if ((infoPtr->watchMask & TCL_WRITABLE) &&
	    (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
	mask = TCL_WRITABLE;







|
|
|



















|
|
|







2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched pipes for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that pipes can be deleted while the event is in
     * the queue.
     */

    for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (pipeEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(PIPE_PENDING);
	    break;
	}
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the pipe is readable. Note that we can't tell if a pipe
     * is writable, so we always report it as being writable unless we have
     * detected EOF.
     */

    filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile;
    mask = 0;
    if ((infoPtr->watchMask & TCL_WRITABLE) &&
	    (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
	mask = TCL_WRITABLE;
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
}

/*
 *----------------------------------------------------------------------
 *
 * PipeWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this
 *	channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
PipeWatchProc(
    ClientData instanceData,		/* Pipe state. */
    int mask)				/* What events to watch for, OR-ed
                                         * combination of TCL_READABLE,
                                         * TCL_WRITABLE and TCL_EXCEPTION. */
{
    PipeInfo **nextPtrPtr, *ptr;
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    int oldMask = infoPtr->watchMask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Since most of the work is handled by the background threads,
     * we just need to update the watchMask and then force the notifier
     * to poll once. 
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };
	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
	    tsdPtr->firstPipePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
	    /*
	     * Remove the pipe from the list of watched pipes.
	     */

	    for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr;
		 ptr != NULL;
		 nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
		if (infoPtr == ptr) {
		    *nextPtrPtr = ptr->nextPtr;
		    break;
		}
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from
 *	inside a command pipeline based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
PipeGetHandleProc(
    ClientData instanceData,	/* The pipe state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr)	/* Where to store the handle.  */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr; 

    if (direction == TCL_READABLE && infoPtr->readFile) {
	filePtr = (WinFile*) infoPtr->readFile;
	*handlePtr = (ClientData) filePtr->handle;
	return TCL_OK;
    }
    if (direction == TCL_WRITABLE && infoPtr->writeFile) {







|
<












|
|
|
|







|
|
<

















|
|














|
|


|
|














|







2373
2374
2375
2376
2377
2378
2379
2380

2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405

2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
}

/*
 *----------------------------------------------------------------------
 *
 * PipeWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
PipeWatchProc(
    ClientData instanceData,	/* Pipe state. */
    int mask)			/* What events to watch for, OR-ed combination
				 * of TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    PipeInfo **nextPtrPtr, *ptr;
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    int oldMask = infoPtr->watchMask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Since most of the work is handled by the background threads, we just
     * need to update the watchMask and then force the notifier to poll once.

     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };
	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
	    tsdPtr->firstPipePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
	    /*
	     * Remove the pipe from the list of watched pipes.
	     */

	    for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr;
		    ptr != NULL;
		    nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
		if (infoPtr == ptr) {
		    *nextPtrPtr = ptr->nextPtr;
		    break;
		}
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
 *	command pipeline based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
PipeGetHandleProc(
    ClientData instanceData,	/* The pipe state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr)	/* Where to store the handle.  */
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr;

    if (direction == TCL_READABLE && infoPtr->readFile) {
	filePtr = (WinFile*) infoPtr->readFile;
	*handlePtr = (ClientData) filePtr->handle;
	return TCL_OK;
    }
    if (direction == TCL_WRITABLE && infoPtr->writeFile) {
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
 *----------------------------------------------------------------------
 *
 * Tcl_WaitPid --
 *
 *	Emulates the waitpid system call.
 *
 * Results:
 *	Returns 0 if the process is still alive, -1 on an error, or
 *	the pid on a clean close.  
 *
 * Side effects:
 *	Unless WNOHANG is set and the wait times out, the process
 *	information record will be deleted and the process handle
 *	will be closed.
 *
 *----------------------------------------------------------------------
 */

Tcl_Pid
Tcl_WaitPid(
    Tcl_Pid pid,
    int *statPtr,
    int options)
{
    ProcInfo *infoPtr = NULL, **prevPtrPtr;
    DWORD flags;
    Tcl_Pid result;
    DWORD ret, exitCode;

    PipeInit();

    /*
     * If no pid is specified, do nothing.
     */
    
    if (pid == 0) {
	*statPtr = 0;
	return 0;
    }

    /*
     * Find the process and cut it from the process list.







|
|


|
|
<




















|







2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487

2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
 *----------------------------------------------------------------------
 *
 * Tcl_WaitPid --
 *
 *	Emulates the waitpid system call.
 *
 * Results:
 *	Returns 0 if the process is still alive, -1 on an error, or the pid on
 *	a clean close.
 *
 * Side effects:
 *	Unless WNOHANG is set and the wait times out, the process information
 *	record will be deleted and the process handle will be closed.

 *
 *----------------------------------------------------------------------
 */

Tcl_Pid
Tcl_WaitPid(
    Tcl_Pid pid,
    int *statPtr,
    int options)
{
    ProcInfo *infoPtr = NULL, **prevPtrPtr;
    DWORD flags;
    Tcl_Pid result;
    DWORD ret, exitCode;

    PipeInit();

    /*
     * If no pid is specified, do nothing.
     */

    if (pid == 0) {
	*statPtr = 0;
	return 0;
    }

    /*
     * Find the process and cut it from the process list.
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567

2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634

2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
    }
    Tcl_MutexUnlock(&pipeMutex);

    /*
     * If the pid is not one of the processes we know about (we started it)
     * then do nothing.
     */
    		     
    if (infoPtr == NULL) {
        *statPtr = 0;
	return 0;
    }

    /*
     * Officially "wait" for it to finish. We either poll (WNOHANG) or
     * wait for an infinite amount of time.
     */
    
    if (options & WNOHANG) {
	flags = 0;
    } else {
	flags = INFINITE;
    }
    ret = WaitForSingleObject(infoPtr->hProcess, flags);
    if (ret == WAIT_TIMEOUT) {
	*statPtr = 0;
	if (options & WNOHANG) {
	    /*
	     * Re-insert this infoPtr back on the list.
	     */

	    Tcl_MutexLock(&pipeMutex);
	    infoPtr->nextPtr = procList;
	    procList = infoPtr;
	    Tcl_MutexUnlock(&pipeMutex);
	    return 0;
	} else {
	    result = 0;
	}
    } else if (ret == WAIT_OBJECT_0) {
	GetExitCodeProcess(infoPtr->hProcess, &exitCode);

	/*
	 * Does the exit code look like one of the exception codes?
	 */

	switch (exitCode) {
	    case EXCEPTION_FLT_DENORMAL_OPERAND:
	    case EXCEPTION_FLT_DIVIDE_BY_ZERO:
	    case EXCEPTION_FLT_INEXACT_RESULT:
	    case EXCEPTION_FLT_INVALID_OPERATION:
	    case EXCEPTION_FLT_OVERFLOW:
	    case EXCEPTION_FLT_STACK_CHECK:
	    case EXCEPTION_FLT_UNDERFLOW:
	    case EXCEPTION_INT_DIVIDE_BY_ZERO:
	    case EXCEPTION_INT_OVERFLOW:
		*statPtr = SIGFPE;
		break;

	    case EXCEPTION_PRIV_INSTRUCTION:
	    case EXCEPTION_ILLEGAL_INSTRUCTION:
		*statPtr = SIGILL;
		break;

	    case EXCEPTION_ACCESS_VIOLATION:
	    case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
	    case EXCEPTION_STACK_OVERFLOW:
	    case EXCEPTION_NONCONTINUABLE_EXCEPTION:
	    case EXCEPTION_INVALID_DISPOSITION:
	    case EXCEPTION_GUARD_PAGE:
	    case EXCEPTION_INVALID_HANDLE:
		*statPtr = SIGSEGV;
		break;

	    case EXCEPTION_DATATYPE_MISALIGNMENT:
		*statPtr = SIGBUS;
		break;
	    
	    case EXCEPTION_BREAKPOINT:
	    case EXCEPTION_SINGLE_STEP:
		*statPtr = SIGTRAP;
		break;

	    case CONTROL_C_EXIT:
		*statPtr = SIGINT;
		break;

	    default:
		/*
		 * Non-exceptional, normal, exit code.  Note that the
		 * exit code is truncated to a signed short range
		 * [-32768,32768) whether it fits into this range or not.
		 *
		 * BUG: Even though the exit code is a DWORD, it is
		 * understood by convention to be a signed integer, yet
		 * there isn't enough room to fit this into the POSIX
		 * style waitstatus mask without truncating it.
		 */

		*statPtr = (((int)(short) exitCode << 8) & 0xffff00);
		break;
	}
	result = pid;
    } else {
	errno = ECHILD;
        *statPtr = ECHILD;
	result = (Tcl_Pid) -1;
    }

    /*
     * Officially close the process handle.
     */

    CloseHandle(infoPtr->hProcess);
    ckfree((char*)infoPtr);

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinAddProcess --
 *
 *     Add a process to the process list so that we can use
 *     Tcl_WaitPid on the process.
 *
 * Results:
 *     None
 *
 * Side effects:
 *	Adds the specified process handle to the process list so
 *	Tcl_WaitPid knows about it.
 *
 *----------------------------------------------------------------------
 */

void
TclWinAddProcess(hProcess, id)
    HANDLE hProcess;           /* Handle to process */
    DWORD id;                  /* Global process identifier */
{
    ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));

    PipeInit();

    procPtr->hProcess = hProcess;
    procPtr->dwProcessId = id;
    Tcl_MutexLock(&pipeMutex);
    procPtr->nextPtr = procList;
    procList = procPtr;
    Tcl_MutexUnlock(&pipeMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PidObjCmd --
 *
 *	This procedure is invoked to process the "pid" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *







|

|




|
|

|












>
















|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
>
|
|




|


















|
|


|


|
|






|
|


















|
|







2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
    }
    Tcl_MutexUnlock(&pipeMutex);

    /*
     * If the pid is not one of the processes we know about (we started it)
     * then do nothing.
     */

    if (infoPtr == NULL) {
	*statPtr = 0;
	return 0;
    }

    /*
     * Officially "wait" for it to finish. We either poll (WNOHANG) or wait
     * for an infinite amount of time.
     */

    if (options & WNOHANG) {
	flags = 0;
    } else {
	flags = INFINITE;
    }
    ret = WaitForSingleObject(infoPtr->hProcess, flags);
    if (ret == WAIT_TIMEOUT) {
	*statPtr = 0;
	if (options & WNOHANG) {
	    /*
	     * Re-insert this infoPtr back on the list.
	     */

	    Tcl_MutexLock(&pipeMutex);
	    infoPtr->nextPtr = procList;
	    procList = infoPtr;
	    Tcl_MutexUnlock(&pipeMutex);
	    return 0;
	} else {
	    result = 0;
	}
    } else if (ret == WAIT_OBJECT_0) {
	GetExitCodeProcess(infoPtr->hProcess, &exitCode);

	/*
	 * Does the exit code look like one of the exception codes?
	 */

	switch (exitCode) {
	case EXCEPTION_FLT_DENORMAL_OPERAND:
	case EXCEPTION_FLT_DIVIDE_BY_ZERO:
	case EXCEPTION_FLT_INEXACT_RESULT:
	case EXCEPTION_FLT_INVALID_OPERATION:
	case EXCEPTION_FLT_OVERFLOW:
	case EXCEPTION_FLT_STACK_CHECK:
	case EXCEPTION_FLT_UNDERFLOW:
	case EXCEPTION_INT_DIVIDE_BY_ZERO:
	case EXCEPTION_INT_OVERFLOW:
	    *statPtr = SIGFPE;
	    break;

	case EXCEPTION_PRIV_INSTRUCTION:
	case EXCEPTION_ILLEGAL_INSTRUCTION:
	    *statPtr = SIGILL;
	    break;

	case EXCEPTION_ACCESS_VIOLATION:
	case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
	case EXCEPTION_STACK_OVERFLOW:
	case EXCEPTION_NONCONTINUABLE_EXCEPTION:
	case EXCEPTION_INVALID_DISPOSITION:
	case EXCEPTION_GUARD_PAGE:
	case EXCEPTION_INVALID_HANDLE:
	    *statPtr = SIGSEGV;
	    break;

	case EXCEPTION_DATATYPE_MISALIGNMENT:
	    *statPtr = SIGBUS;
	    break;

	case EXCEPTION_BREAKPOINT:
	case EXCEPTION_SINGLE_STEP:
	    *statPtr = SIGTRAP;
	    break;

	case CONTROL_C_EXIT:
	    *statPtr = SIGINT;
	    break;

	default:
	    /*
	     * Non-exceptional, normal, exit code. Note that the exit code is
	     * truncated to a signed short range [-32768,32768) whether it
	     * fits into this range or not.
	     *
	     * BUG: Even though the exit code is a DWORD, it is understood by
	     * convention to be a signed integer, yet there isn't enough room
	     * to fit this into the POSIX style waitstatus mask without
	     * truncating it.
	     */

	    *statPtr = (((int)(short) exitCode << 8) & 0xffff00);
	    break;
	}
	result = pid;
    } else {
	errno = ECHILD;
	*statPtr = ECHILD;
	result = (Tcl_Pid) -1;
    }

    /*
     * Officially close the process handle.
     */

    CloseHandle(infoPtr->hProcess);
    ckfree((char*)infoPtr);

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinAddProcess --
 *
 *	Add a process to the process list so that we can use Tcl_WaitPid on
 *	the process.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Adds the specified process handle to the process list so Tcl_WaitPid
 *	knows about it.
 *
 *----------------------------------------------------------------------
 */

void
TclWinAddProcess(hProcess, id)
    HANDLE hProcess;		/* Handle to process */
    DWORD id;			/* Global process identifier */
{
    ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));

    PipeInit();

    procPtr->hProcess = hProcess;
    procPtr->dwProcessId = id;
    Tcl_MutexLock(&pipeMutex);
    procPtr->nextPtr = procList;
    procList = procPtr;
    Tcl_MutexUnlock(&pipeMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PidObjCmd --
 *
 *	This function is invoked to process the "pid" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820

2821
2822
2823
2824
2825
2826
2827
	Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	wsprintfA(buf, "%lu", (unsigned long) getpid());
	Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
    } else {
        chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
		NULL);
        if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
	chanTypePtr = Tcl_GetChannelType(chan);
	if (chanTypePtr != &pipeChannelType) {
	    return TCL_OK;
	}

        pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
	resultPtr = Tcl_NewObj();
        for (i = 0; i < pipePtr->numPids; i++) {
	    wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
	    Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
		    Tcl_NewStringObj(buf, -1));
	}
	Tcl_SetObjResult(interp, resultPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForRead --
 *
 *	Wait until some data is available, the pipe is at
 *	EOF or the reader thread is blocked waiting for data (if the
 *	channel is in non-blocking mode).
 *
 * Results:
 *	Returns 1 if pipe is readable.  Returns 0 if there is no data
 *	on the pipe, but there is buffered data.  Returns -1 if an
 *	error occurred.  If an error occurred, the threads may not
 *	be synchronized.
 *
 * Side effects:
 *	Updates the shared state flags and may consume 1 byte of data
 *	from the pipe.  If no error occurred, the reader thread is
 *	blocked waiting for a signal from the main thread.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForRead(
    PipeInfo *infoPtr,		/* Pipe state. */
    int blocking)		/* Indicates whether call should be
				 * blocking or not. */
{
    DWORD timeout, count;
    HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;

    while (1) {
	/*
	 * Synchronize with the reader thread.
	 */
       
	timeout = blocking ? INFINITE : 0;
	if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
	    /*
	     * The reader thread is blocked waiting for data and the channel
	     * is in non-blocking mode.
	     */

	    errno = EAGAIN;
	    return -1;
	}

	/*
	 * At this point, the two threads are synchronized, so it is safe
	 * to access shared state.
	 */


	/*
	 * If the pipe has hit EOF, it is always readable.
	 */

	if (infoPtr->readFlags & PIPE_EOF) {
	    return 1;
	}
    
	/*
	 * Check to see if there is any data sitting in the pipe.
	 */

	if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0,
		(LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) {
	    TclWinConvertError(GetLastError());

	    /*
	     * Check to see if the peek failed because of EOF.
	     */

	    if (errno == EPIPE) {
		infoPtr->readFlags |= PIPE_EOF;
		return 1;







|

|







|

|














|
|
|


|
|
|
<


|
|
|







|
|








|












|
|

<








|







>







2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754

2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792

2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
	Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
	return TCL_ERROR;
    }
    if (objc == 1) {
	wsprintfA(buf, "%lu", (unsigned long) getpid());
	Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
    } else {
	chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
		NULL);
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
	chanTypePtr = Tcl_GetChannelType(chan);
	if (chanTypePtr != &pipeChannelType) {
	    return TCL_OK;
	}

	pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
	resultPtr = Tcl_NewObj();
	for (i = 0; i < pipePtr->numPids; i++) {
	    wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
	    Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
		    Tcl_NewStringObj(buf, -1));
	}
	Tcl_SetObjResult(interp, resultPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForRead --
 *
 *	Wait until some data is available, the pipe is at EOF or the reader
 *	thread is blocked waiting for data (if the channel is in non-blocking
 *	mode).
 *
 * Results:
 *	Returns 1 if pipe is readable. Returns 0 if there is no data on the
 *	pipe, but there is buffered data. Returns -1 if an error occurred. If
 *	an error occurred, the threads may not be synchronized.

 *
 * Side effects:
 *	Updates the shared state flags and may consume 1 byte of data from the
 *	pipe. If no error occurred, the reader thread is blocked waiting for a
 *	signal from the main thread.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForRead(
    PipeInfo *infoPtr,		/* Pipe state. */
    int blocking)		/* Indicates whether call should be blocking
				 * or not. */
{
    DWORD timeout, count;
    HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;

    while (1) {
	/*
	 * Synchronize with the reader thread.
	 */

	timeout = blocking ? INFINITE : 0;
	if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
	    /*
	     * The reader thread is blocked waiting for data and the channel
	     * is in non-blocking mode.
	     */

	    errno = EAGAIN;
	    return -1;
	}

	/*
	 * At this point, the two threads are synchronized, so it is safe to
	 * access shared state.
	 */


	/*
	 * If the pipe has hit EOF, it is always readable.
	 */

	if (infoPtr->readFlags & PIPE_EOF) {
	    return 1;
	}

	/*
	 * Check to see if there is any data sitting in the pipe.
	 */

	if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0,
		(LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) {
	    TclWinConvertError(GetLastError());

	    /*
	     * Check to see if the peek failed because of EOF.
	     */

	    if (errno == EPIPE) {
		infoPtr->readFlags |= PIPE_EOF;
		return 1;
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979






2980

2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067






3068

3069
3070
3071
3072
3073
3074

























































	 */

	if (count > 0) {
	    return 1;
	}

	/*
	 * The pipe isn't readable, but there is some data sitting
	 * in the buffer, so return immediately.
	 */

	if (infoPtr->readFlags & PIPE_EXTRABYTE) {
	    return 0;
	}

	/*
	 * There wasn't any data available, so reset the thread and
	 * try again.
	 */
    
	ResetEvent(infoPtr->readable);
	SetEvent(infoPtr->startReader);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeReaderThread --
 *
 *	This function runs in a separate thread and waits for input
 *	to become available on a pipe.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the main thread when input become available.  May
 *	cause the main thread to wake up by posting a message.  May
 *	consume one byte from the pipe for each wait operation.  Will
 *	cause a memory leak of ~4k, if forcefully terminated with
 *	TerminateThread().
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeReaderThread(LPVOID arg)
{
    PipeInfo *infoPtr = (PipeInfo *)arg;
    HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
    DWORD count, err;
    int done = 0;
    HANDLE wEvents[2];
    DWORD waitResult;

    wEvents[0] = infoPtr->stopReader;
    wEvents[1] = infoPtr->startReader;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to wait
	 * on the pipe becoming readable.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled.  It might be the stop event
	     * or an error, so exit.
	     */

	    break;
	}

	/*
	 * Try waiting for 0 bytes.  This will block until some data is
	 * available on NT, but will return immediately on Win 95.  So,
	 * if no data is available after the first read, we block until
	 * we can read a single byte off of the pipe.
	 */

	if (ReadFile(handle, NULL, 0, &count, NULL) == FALSE ||
		PeekNamedPipe(handle, NULL, 0, NULL, &count, NULL) == FALSE) {
	    /*
	     * The error is a result of an EOF condition, so set the
	     * EOF bit before signalling the main thread.
	     */

	    err = GetLastError();
	    if (err == ERROR_BROKEN_PIPE) {
		infoPtr->readFlags |= PIPE_EOF;
		done = 1;
	    } else if (err == ERROR_INVALID_HANDLE) {
		break;
	    }
	} else if (count == 0) {
	    if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
		    != FALSE) {
		/*
		 * One byte was consumed as a side effect of waiting
		 * for the pipe to become readable.
		 */

		infoPtr->readFlags |= PIPE_EXTRABYTE;
	    } else {
		err = GetLastError();
		if (err == ERROR_BROKEN_PIPE) {
		    /*
		     * The error is a result of an EOF condition, so set the
		     * EOF bit before signalling the main thread.
		     */

		    infoPtr->readFlags |= PIPE_EOF;
		    done = 1;
		} else if (err == ERROR_INVALID_HANDLE) {
		    break;
		}
	    }
	}

		
	/*
	 * Signal the main thread by signalling the readable event and
	 * then waking up the notifier thread.
	 */

	SetEvent(infoPtr->readable);
	
	/*
	 * Alert the foreground thread.  Note that we need to treat this like
	 * a critical section so the foreground thread does not terminate
	 * this thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&pipeMutex);






	Tcl_ThreadAlert(infoPtr->threadId);

	Tcl_MutexUnlock(&pipeMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeWriterThread --
 *
 *	This function runs in a separate thread and writes data
 *	onto a pipe.
 *
 * Results:
 *	Always returns 0.
 *
 * Side effects:
 *	Signals the main thread when an output operation is completed.
 *	May cause the main thread to wake up by posting a message.  
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeWriterThread(LPVOID arg)
{

    PipeInfo *infoPtr = (PipeInfo *)arg;
    HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle;
    DWORD count, toWrite;
    char *buf;
    int done = 0;
    HANDLE wEvents[2];
    DWORD waitResult;

    wEvents[0] = infoPtr->stopWriter;
    wEvents[1] = infoPtr->startWriter;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to write.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled.  It might be the stop event
	     * or an error, so exit.
	     */

	    break;
	}

	buf = infoPtr->writeBuf;
	toWrite = infoPtr->toWrite;

	/*
	 * Loop until all of the bytes are written or an error occurs.
	 */

	while (toWrite > 0) {
	    if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
		infoPtr->writeError = GetLastError();
		done = 1; 
		break;
	    } else {
		toWrite -= count;
		buf += count;
	    }
	}
	
	/*
	 * Signal the main thread by signalling the writable event and
	 * then waking up the notifier thread.
	 */

	SetEvent(infoPtr->writable);

	/*
	 * Alert the foreground thread.  Note that we need to treat this like
	 * a critical section so the foreground thread does not terminate
	 * this thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&pipeMutex);






	Tcl_ThreadAlert(infoPtr->threadId);

	Tcl_MutexUnlock(&pipeMutex);
    }

    return 0;
}

































































|
|







|
<

|










|
|





|
|
|
<
|



















|
|






|
|






|
|
|
|





|
|













|
|



















|

|
|



|

|
|
|



>
>
>
>
>
>
|
>











|
<





|
|







<




















|
|















|






|

|
|





|
|
|



>
>
>
>
>
>
|
>





|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848

2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870

2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986

2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000

3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
	 */

	if (count > 0) {
	    return 1;
	}

	/*
	 * The pipe isn't readable, but there is some data sitting in the
	 * buffer, so return immediately.
	 */

	if (infoPtr->readFlags & PIPE_EXTRABYTE) {
	    return 0;
	}

	/*
	 * There wasn't any data available, so reset the thread and try again.

	 */

	ResetEvent(infoPtr->readable);
	SetEvent(infoPtr->startReader);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * PipeReaderThread --
 *
 *	This function runs in a separate thread and waits for input to become
 *	available on a pipe.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Signals the main thread when input become available. May cause the
 *	main thread to wake up by posting a message. May consume one byte from
 *	the pipe for each wait operation. Will cause a memory leak of ~4k, if

 *	forcefully terminated with TerminateThread().
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeReaderThread(LPVOID arg)
{
    PipeInfo *infoPtr = (PipeInfo *)arg;
    HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
    DWORD count, err;
    int done = 0;
    HANDLE wEvents[2];
    DWORD waitResult;

    wEvents[0] = infoPtr->stopReader;
    wEvents[1] = infoPtr->startReader;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled. It might be the stop event or
	     * an error, so exit.
	     */

	    break;
	}

	/*
	 * Try waiting for 0 bytes. This will block until some data is
	 * available on NT, but will return immediately on Win 95. So, if no
	 * data is available after the first read, we block until we can read
	 * a single byte off of the pipe.
	 */

	if (ReadFile(handle, NULL, 0, &count, NULL) == FALSE ||
		PeekNamedPipe(handle, NULL, 0, NULL, &count, NULL) == FALSE) {
	    /*
	     * The error is a result of an EOF condition, so set the EOF bit
	     * before signalling the main thread.
	     */

	    err = GetLastError();
	    if (err == ERROR_BROKEN_PIPE) {
		infoPtr->readFlags |= PIPE_EOF;
		done = 1;
	    } else if (err == ERROR_INVALID_HANDLE) {
		break;
	    }
	} else if (count == 0) {
	    if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
		    != FALSE) {
		/*
		 * One byte was consumed as a side effect of waiting for the
		 * pipe to become readable.
		 */

		infoPtr->readFlags |= PIPE_EXTRABYTE;
	    } else {
		err = GetLastError();
		if (err == ERROR_BROKEN_PIPE) {
		    /*
		     * The error is a result of an EOF condition, so set the
		     * EOF bit before signalling the main thread.
		     */

		    infoPtr->readFlags |= PIPE_EOF;
		    done = 1;
		} else if (err == ERROR_INVALID_HANDLE) {
		    break;
		}
	    }
	}


	/*
	 * Signal the main thread by signalling the readable event and then
	 * waking up the notifier thread.
	 */

	SetEvent(infoPtr->readable);

	/*
	 * Alert the foreground thread. Note that we need to treat this like a
	 * critical section so the foreground thread does not terminate this
	 * thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&pipeMutex);
	if (infoPtr->threadId != NULL) {
	    /*
	     * TIP #218. When in flight ignore the event, no one will receive
	     * it anyway.
	     */

	    Tcl_ThreadAlert(infoPtr->threadId);
	}
	Tcl_MutexUnlock(&pipeMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeWriterThread --
 *
 *	This function runs in a separate thread and writes data onto a pipe.

 *
 * Results:
 *	Always returns 0.
 *
 * Side effects:
 *	Signals the main thread when an output operation is completed. May
 *	cause the main thread to wake up by posting a message.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeWriterThread(LPVOID arg)
{

    PipeInfo *infoPtr = (PipeInfo *)arg;
    HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle;
    DWORD count, toWrite;
    char *buf;
    int done = 0;
    HANDLE wEvents[2];
    DWORD waitResult;

    wEvents[0] = infoPtr->stopWriter;
    wEvents[1] = infoPtr->startWriter;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to write.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled. It might be the stop event or
	     * an error, so exit.
	     */

	    break;
	}

	buf = infoPtr->writeBuf;
	toWrite = infoPtr->toWrite;

	/*
	 * Loop until all of the bytes are written or an error occurs.
	 */

	while (toWrite > 0) {
	    if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
		infoPtr->writeError = GetLastError();
		done = 1;
		break;
	    } else {
		toWrite -= count;
		buf += count;
	    }
	}

	/*
	 * Signal the main thread by signalling the writable event and then
	 * waking up the notifier thread.
	 */

	SetEvent(infoPtr->writable);

	/*
	 * Alert the foreground thread. Note that we need to treat this like a
	 * critical section so the foreground thread does not terminate this
	 * thread while we are holding a mutex in the notifier code.
	 */

	Tcl_MutexLock(&pipeMutex);
	if (infoPtr->threadId != NULL) {
	    /*
	     * TIP #218. When in flight ignore the event, no one will receive
	     * it anyway.
	     */

	    Tcl_ThreadAlert(infoPtr->threadId);
	}
	Tcl_MutexUnlock(&pipeMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeThreadActionProc --
 *
 *	Insert or remove any thread local refs to this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

static void
PipeThreadActionProc(instanceData, action)
    ClientData instanceData;
    int action;
{
    PipeInfo *infoPtr = (PipeInfo *) instanceData;

    /*
     * We do not access firstPipePtr in the thread structures. This is not for
     * all pipes managed by the thread, but only those we are watching.
     * Removal of the filevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&pipeMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the
	 * channel is created. At this time the channel back pointer has not
	 * been set yet. However in that case the threadId has already been
	 * set by TclpCreateCommandChannel itself, so the structure is still
	 * good.
	 */

	PipeInit();
	if (infoPtr->channel != NULL) {
	    infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
	}
    } else {
	infoPtr->threadId = NULL;
    }
    Tcl_MutexUnlock(&pipeMutex);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinPort.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclWinPort.h --
 *
 *	This header file handles porting issues that occur because of
 *	differences between Windows and Unix. It should be the only
 *	file that contains #ifdefs to handle different flavors of OS.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPort.h,v 1.43 2004/11/03 21:07:01 davygrvy Exp $
 */

#ifndef _TCLWINPORT
#define _TCLWINPORT

#ifdef CHECK_UNICODE_CALLS
#   define _UNICODE












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclWinPort.h --
 *
 *	This header file handles porting issues that occur because of
 *	differences between Windows and Unix. It should be the only
 *	file that contains #ifdefs to handle different flavors of OS.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPort.h,v 1.43.2.2 2005/10/08 13:45:04 dgp Exp $
 */

#ifndef _TCLWINPORT
#define _TCLWINPORT

#ifdef CHECK_UNICODE_CALLS
#   define _UNICODE
40
41
42
43
44
45
46







47
48
49
50
51
52
53
#include <float.h>
#include <io.h>
#include <malloc.h>
#include <process.h>
#include <signal.h>
#include <string.h>








/*
 * Need to block out these includes for building extensions with MetroWerks
 * compiler for Win32.
 */

#ifndef __MWERKS__
#include <sys/stat.h>







>
>
>
>
>
>
>







40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
#include <float.h>
#include <io.h>
#include <malloc.h>
#include <process.h>
#include <signal.h>
#include <string.h>

/*
 * These string functions are not defined with the same names on Windows.
 */

#define strcasecmp stricmp
#define strncasecmp strnicmp

/*
 * Need to block out these includes for building extensions with MetroWerks
 * compiler for Win32.
 */

#ifndef __MWERKS__
#include <sys/stat.h>
434
435
436
437
438
439
440
441

442
443
444
445
446
447
448

/*
 * The following define ensures that we use the native putenv
 * implementation to modify the environment array.  This keeps
 * the C level environment in synch with the system level environment.
 */

#define USE_PUTENV	1


/*
 * Msvcrt's putenv() copies the string rather than takes ownership of it.
 */

#if defined(_MSC_VER) || defined(__MINGW32__)
#   define HAVE_PUTENV_THAT_COPIES 1







|
>







441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456

/*
 * The following define ensures that we use the native putenv
 * implementation to modify the environment array.  This keeps
 * the C level environment in synch with the system level environment.
 */

#define USE_PUTENV		1
#define USE_PUTENV_FOR_UNSET	1

/*
 * Msvcrt's putenv() copies the string rather than takes ownership of it.
 */

#if defined(_MSC_VER) || defined(__MINGW32__)
#   define HAVE_PUTENV_THAT_COPIES 1

Changes to win/tclWinReg.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinReg.c --
 *
 *	This file contains the implementation of the "registry" Tcl
 *	built-in command.  This command is built as a dynamically
 *	loadable extension in a separate DLL.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinReg.c,v 1.32 2004/10/07 00:55:36 dgp Exp $
 */

#include "tclInt.h"
#ifdef _MSC_VER
#   pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>



|
|
|




|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinReg.c --
 *
 *	This file contains the implementation of the "registry" Tcl built-in
 *	command. This command is built as a dynamically loadable extension in
 *	a separate DLL.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinReg.c,v 1.32.2.1 2005/08/02 18:17:18 dgp Exp $
 */

#include "tclInt.h"
#ifdef _MSC_VER
#   pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
 * The following macros convert between different endian ints.
 */

#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))

/*
 * The following flag is used in OpenKeys to indicate that the specified
 * key should be created if it doesn't currently exist.
 */

#define REG_CREATE 1

/*
 * The following tables contain the mapping from registry root names
 * to the system predefined keys.
 */

static CONST char *rootKeyNames[] = {
    "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
    "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
    "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
};

static HKEY rootKeys[] = {
    HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
    HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};

static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";

/*
 * The following table maps from registry types to strings.  Note that
 * the indices for this array are the same as the constants for the
 * known registry types so we don't need a separate table to hold the
 * mapping.
 */

static CONST char *typeNames[] = {
    "none", "sz", "expand_sz", "binary", "dword",
    "dword_big_endian", "link", "multi_sz", "resource_list", NULL
};

static DWORD lastType = REG_RESOURCE_LIST;

/*
 * The following structures allow us to select between the Unicode and ASCII
 * interfaces at run time based on whether Unicode APIs are available.  The
 * Unicode APIs are preferable because they will handle characters outside
 * of the current code page.
 */

typedef struct RegWinProcs {
    int useWide;

    LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
    LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); 
    LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
    LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *);
    LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *);







|
|





|
|
















|
|
|
<











|
|
|







|







33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
 * The following macros convert between different endian ints.
 */

#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))

/*
 * The following flag is used in OpenKeys to indicate that the specified key
 * should be created if it doesn't currently exist.
 */

#define REG_CREATE 1

/*
 * The following tables contain the mapping from registry root names to the
 * system predefined keys.
 */

static CONST char *rootKeyNames[] = {
    "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
    "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
    "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
};

static HKEY rootKeys[] = {
    HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
    HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};

static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";

/*
 * The following table maps from registry types to strings. Note that the
 * indices for this array are the same as the constants for the known registry
 * types so we don't need a separate table to hold the mapping.

 */

static CONST char *typeNames[] = {
    "none", "sz", "expand_sz", "binary", "dword",
    "dword_big_endian", "link", "multi_sz", "resource_list", NULL
};

static DWORD lastType = REG_RESOURCE_LIST;

/*
 * The following structures allow us to select between the Unicode and ASCII
 * interfaces at run time based on whether Unicode APIs are available. The
 * Unicode APIs are preferable because they will handle characters outside of
 * the current code page.
 */

typedef struct RegWinProcs {
    int useWide;

    LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
    LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
    LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
    LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *);
    LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *);
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124

static RegWinProcs asciiProcs = {
    0,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExA, 
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueA,







|







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123

static RegWinProcs asciiProcs = {
    0,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueA,
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

static RegWinProcs unicodeProcs = {
    1,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExW, 
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueW,







|







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148

static RegWinProcs unicodeProcs = {
    1,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueW,
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
EXTERN int Registry_Unload(Tcl_Interp *interp, int flags);

/*
 *----------------------------------------------------------------------
 *
 * Registry_Init --
 *
 *	This procedure initializes the registry command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *







|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
EXTERN int Registry_Unload(Tcl_Interp *interp, int flags);

/*
 *----------------------------------------------------------------------
 *
 * Registry_Init --
 *
 *	This function initializes the registry command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
}

/*
 *----------------------------------------------------------------------
 *
 * Registry_Unload --
 *
 *	This procedure removes the registry command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	The registry command is deleted and the dll may be unloaded.
 *
 *----------------------------------------------------------------------
 */

int
Registry_Unload(
    Tcl_Interp *interp,		/* Interpreter for unloading */
    int flags)			/* Flags passed by the unload system */
{
    Tcl_Command cmd;
    Tcl_Obj *objv[3];

    /* 
     * Unregister the registry package. There is no Tcl_PkgForget()
     */

    objv[0] = Tcl_NewStringObj("package", -1);
    objv[1] = Tcl_NewStringObj("forget", -1);
    objv[2] = Tcl_NewStringObj("registry", -1);
    Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);







|


















|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
}

/*
 *----------------------------------------------------------------------
 *
 * Registry_Unload --
 *
 *	This function removes the registry command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	The registry command is deleted and the dll may be unloaded.
 *
 *----------------------------------------------------------------------
 */

int
Registry_Unload(
    Tcl_Interp *interp,		/* Interpreter for unloading */
    int flags)			/* Flags passed by the unload system */
{
    Tcl_Command cmd;
    Tcl_Obj *objv[3];

    /*
     * Unregister the registry package. There is no Tcl_PkgForget()
     */

    objv[0] = Tcl_NewStringObj("package", -1);
    objv[1] = Tcl_NewStringObj("forget", -1);
    objv[2] = Tcl_NewStringObj("registry", -1);
    Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteCmd --
 *
 *	Cleanup the interp command token so that unloading doesn't try
 *	to re-delete the command (which will crash).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The unload command will not attempt to delete this command.
 *







|
|







287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteCmd --
 *
 *	Cleanup the interp command token so that unloading doesn't try to
 *	re-delete the command (which will crash).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The unload command will not attempt to delete this command.
 *
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424

    if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
	case BroadcastIdx:		/* broadcast */
	    return BroadcastValue(interp, objc, objv);
	    break;
	case DeleteIdx:			/* delete */
	    if (objc == 3) {
		return DeleteKey(interp, objv[2]);
	    } else if (objc == 4) {
		return DeleteValue(interp, objv[2], objv[3]);
	    }
	    errString = "keyName ?valueName?";
	    break;
	case GetIdx:			/* get */
	    if (objc == 4) {
		return GetValue(interp, objv[2], objv[3]);
	    }
	    errString = "keyName valueName";
	    break;
	case KeysIdx:			/* keys */
	    if (objc == 3) {
		return GetKeyNames(interp, objv[2], NULL);
	    } else if (objc == 4) {
		return GetKeyNames(interp, objv[2], objv[3]);
	    }
	    errString = "keyName ?pattern?";
	    break;
	case SetIdx:			/* set */
	    if (objc == 3) {
		HKEY key;

		/*
		 * Create the key and then close it immediately.
		 */

		if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
			!= TCL_OK) {
		    return TCL_ERROR;
		}
		RegCloseKey(key);
		return TCL_OK;
	    } else if (objc == 5 || objc == 6) {
		Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
		return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
	    }
	    errString = "keyName ?valueName data ?type??";
	    break;
	case TypeIdx:			/* type */
	    if (objc == 4) {
		return GetType(interp, objv[2], objv[3]);
	    }
	    errString = "keyName valueName";
	    break;
	case ValuesIdx:			/* values */
	    if (objc == 3) {
 		return GetValueNames(interp, objv[2], NULL);
	    } else if (objc == 4) {
 		return GetValueNames(interp, objv[2], objv[3]);
	    }
	    errString = "keyName ?pattern?";
	    break;
    }
    Tcl_WrongNumArgs(interp, 2, objv, errString);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391

392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422

    if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case BroadcastIdx:		/* broadcast */
	return BroadcastValue(interp, objc, objv);
	break;
    case DeleteIdx:		/* delete */
	if (objc == 3) {
	    return DeleteKey(interp, objv[2]);
	} else if (objc == 4) {
	    return DeleteValue(interp, objv[2], objv[3]);
	}
	errString = "keyName ?valueName?";
	break;
    case GetIdx:		/* get */
	if (objc == 4) {
	    return GetValue(interp, objv[2], objv[3]);
	}
	errString = "keyName valueName";
	break;
    case KeysIdx:		/* keys */
	if (objc == 3) {
	    return GetKeyNames(interp, objv[2], NULL);
	} else if (objc == 4) {
	    return GetKeyNames(interp, objv[2], objv[3]);
	}
	errString = "keyName ?pattern?";
	break;
    case SetIdx:		/* set */
	if (objc == 3) {
	    HKEY key;

	    /*
	     * Create the key and then close it immediately.
	     */

	    if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) {

		return TCL_ERROR;
	    }
	    RegCloseKey(key);
	    return TCL_OK;
	} else if (objc == 5 || objc == 6) {
	    Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
	    return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
	}
	errString = "keyName ?valueName data ?type??";
	break;
    case TypeIdx:		/* type */
	if (objc == 4) {
	    return GetType(interp, objv[2], objv[3]);
	}
	errString = "keyName valueName";
	break;
    case ValuesIdx:		/* values */
	if (objc == 3) {
	    return GetValueNames(interp, objv[2], NULL);
	} else if (objc == 4) {
	    return GetValueNames(interp, objv[2], objv[3]);
	}
	errString = "keyName ?pattern?";
	break;
    }
    Tcl_WrongNumArgs(interp, 2, objv, errString);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
     * Find the parent of the key being deleted and open it.
     */

    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc((unsigned int) length + 1);
    strcpy(buffer, keyName);

    if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
	    != TCL_OK) {
	ckfree(buffer);
	return TCL_ERROR;
    }

    if (*keyName == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad key: cannot delete root keys", -1));







|
|







450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
     * Find the parent of the key being deleted and open it.
     */

    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc((unsigned int) length + 1);
    strcpy(buffer, keyName);

    if (ParseKeyName(interp, buffer, &hostName, &rootKey,
	    &keyName) != TCL_OK) {
	ckfree(buffer);
	return TCL_ERROR;
    }

    if (*keyName == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad key: cannot delete root keys", -1));
479
480
481
482
483
484
485
486

487
488
489
490
491
492
493
494
495
496
497
498

    result = OpenSubKey(hostName, rootKey, keyName,
	    KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
    if (result != ERROR_SUCCESS) {
	ckfree(buffer);
	if (result == ERROR_FILE_NOT_FOUND) {
	    return TCL_OK;
	} else {

	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unable to delete key: ", -1));
	    AppendSystemError(interp, result);
	    return TCL_ERROR;
	}
    }

    /*
     * Now we recursively delete the key and everything below it.
     */

    nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf);







<
>
|
|
|
|
<







477
478
479
480
481
482
483

484
485
486
487
488

489
490
491
492
493
494
495

    result = OpenSubKey(hostName, rootKey, keyName,
	    KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
    if (result != ERROR_SUCCESS) {
	ckfree(buffer);
	if (result == ERROR_FILE_NOT_FOUND) {
	    return TCL_OK;

	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"unable to delete key: ", -1));
	AppendSystemError(interp, result);
	return TCL_ERROR;

    }

    /*
     * Now we recursively delete the key and everything below it.
     */

    nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf);
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
}

/*
 *----------------------------------------------------------------------
 *
 * GetKeyNames --
 *
 *	This function enumerates the subkeys of a given key.  If the
 *	optional pattern is supplied, then only keys that match the
 *	pattern will be returned.
 *
 * Results:
 *	Returns the list of subkeys in the result object of the
 *	interpreter, or an error message on failure.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|


|
|







565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
}

/*
 *----------------------------------------------------------------------
 *
 * GetKeyNames --
 *
 *	This function enumerates the subkeys of a given key. If the optional
 *	pattern is supplied, then only keys that match the pattern will be
 *	returned.
 *
 * Results:
 *	Returns the list of subkeys in the result object of the interpreter,
 *	or an error message on failure.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
    int result = TCL_OK;
    Tcl_DString ds;

    /*
     * Attempt to open the key for enumeration.
     */

    if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    if (patternObj) {
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
     * Enumerate over the subkeys until we get an error, indicating the
     * end of the list.
     */

    resultPtr = Tcl_NewObj();
    for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
	    MAX_PATH+1) == ERROR_SUCCESS; index++) {
	Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);
	name = Tcl_DStringValue(&ds);







|
|










|
|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
    int result = TCL_OK;
    Tcl_DString ds;

    /*
     * Attempt to open the key for enumeration.
     */

    if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0,
	    &key) != TCL_OK) {
	return TCL_ERROR;
    }

    if (patternObj) {
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
     * Enumerate over the subkeys until we get an error, indicating the end of
     * the list.
     */

    resultPtr = Tcl_NewObj();
    for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
	    MAX_PATH+1) == ERROR_SUCCESS; index++) {
	Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);
	name = Tcl_DStringValue(&ds);
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
}

/*
 *----------------------------------------------------------------------
 *
 * GetType --
 *
 *	This function gets the type of a given registry value and
 *	places it in the interpreter result.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	None.
 *







|
|







639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
}

/*
 *----------------------------------------------------------------------
 *
 * GetType --
 *
 *	This function gets the type of a given registry value and places it in
 *	the interpreter result.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	None.
 *
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }

    /*
     * Set the type into the result.  Watch out for unknown types.
     * If we don't know about the type, just use the numeric value.
     */

    if (type > lastType || type < 0) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetValue --
 *
 *	This function gets the contents of a registry value and places
 *	a list containing the data and the type in the interpreter
 *	result.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	None.
 *







|
|















|
|
<







694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719

720
721
722
723
724
725
726
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }

    /*
     * Set the type into the result. Watch out for unknown types. If we don't
     * know about the type, just use the numeric value.
     */

    if (type > lastType || type < 0) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetValue --
 *
 *	This function gets the contents of a registry value and places a list
 *	containing the data and the type in the interpreter result.

 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	None.
 *
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780

781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
    Tcl_DString data, buf;
    int nameLen;

    /*
     * Attempt to open the key for reading.
     */

    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Initialize a Dstring to maximum statically allocated size
     * we could get one more byte by avoiding Tcl_DStringSetLength()
     * and just setting length to TCL_DSTRING_STATIC_SIZE, but this
     * should be safer if the implementation of Dstrings changes.
     *
     * This allows short values to be read from the registy in one call.
     * Longer values need a second call with an expanded DString.
     */

    Tcl_DStringInit(&data);
    length = TCL_DSTRING_STATIC_SIZE - 1;
    Tcl_DStringSetLength(&data, (int) length);

    valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
    nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);

    result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
	    (BYTE *) Tcl_DStringValue(&data), &length);
    while (result == ERROR_MORE_DATA) {
	/*
	 * The Windows docs say that in this error case, we just need
	 * to expand our buffer and request more data.
	 * Required for HKEY_PERFORMANCE_DATA
	 */

	length *= 2;
        Tcl_DStringSetLength(&data, (int) length);
        result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
		NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
    }
    Tcl_DStringFree(&buf);
    RegCloseKey(key);
    if (result != ERROR_SUCCESS) {
	Tcl_AppendResult(interp, "unable to get value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	Tcl_DStringFree(&data);
	return TCL_ERROR;
    }

    /*
     * If the data is a 32-bit quantity, store it as an integer object.  If it
     * is a multi-string, store it as a list of strings.  For null-terminated
     * strings, append up the to first null.  Otherwise, store it as a binary
     * string.
     */

    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj(
		(int) ConvertDWORD(type, *((DWORD*) Tcl_DStringValue(&data)))));
    } else if (type == REG_MULTI_SZ) {
	char *p = Tcl_DStringValue(&data);
	char *end = Tcl_DStringValue(&data) + length;
	Tcl_Obj *resultPtr = Tcl_NewObj();

	/*
	 * Multistrings are stored as an array of null-terminated strings,
	 * terminated by two null characters.  Also do a bounds check in
	 * case we get bogus data.
	 */
 
	while (p < end 	&& ((regWinProcs->useWide) 
		? *((Tcl_UniChar *)p) : *p) != 0) {
	    Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
	    Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(Tcl_DStringValue(&buf),
			    Tcl_DStringLength(&buf)));
	    if (regWinProcs->useWide) {
		while (*((Tcl_UniChar *)p)++ != 0) {}







|
<




|
|
|
|
















|
|
|

>

|
|














|
|
|




|
|







|
|

|
|







740
741
742
743
744
745
746
747

748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
    Tcl_DString data, buf;
    int nameLen;

    /*
     * Attempt to open the key for reading.
     */

    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) {

	return TCL_ERROR;
    }

    /*
     * Initialize a Dstring to maximum statically allocated size we could get
     * one more byte by avoiding Tcl_DStringSetLength() and just setting
     * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
     * implementation of Dstrings changes.
     *
     * This allows short values to be read from the registy in one call.
     * Longer values need a second call with an expanded DString.
     */

    Tcl_DStringInit(&data);
    length = TCL_DSTRING_STATIC_SIZE - 1;
    Tcl_DStringSetLength(&data, (int) length);

    valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
    nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);

    result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
	    (BYTE *) Tcl_DStringValue(&data), &length);
    while (result == ERROR_MORE_DATA) {
	/*
	 * The Windows docs say that in this error case, we just need to
	 * expand our buffer and request more data. Required for
	 * HKEY_PERFORMANCE_DATA
	 */

	length *= 2;
	Tcl_DStringSetLength(&data, (int) length);
	result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
		NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
    }
    Tcl_DStringFree(&buf);
    RegCloseKey(key);
    if (result != ERROR_SUCCESS) {
	Tcl_AppendResult(interp, "unable to get value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	Tcl_DStringFree(&data);
	return TCL_ERROR;
    }

    /*
     * If the data is a 32-bit quantity, store it as an integer object. If it
     * is a multi-string, store it as a list of strings. For null-terminated
     * strings, append up the to first null. Otherwise, store it as a binary
     * string.
     */

    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
		*((DWORD*) Tcl_DStringValue(&data)))));
    } else if (type == REG_MULTI_SZ) {
	char *p = Tcl_DStringValue(&data);
	char *end = Tcl_DStringValue(&data) + length;
	Tcl_Obj *resultPtr = Tcl_NewObj();

	/*
	 * Multistrings are stored as an array of null-terminated strings,
	 * terminated by two null characters. Also do a bounds check in case
	 * we get bogus data.
	 */

	while (p < end 	&& ((regWinProcs->useWide)
		? *((Tcl_UniChar *)p) : *p) != 0) {
	    Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
	    Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(Tcl_DStringValue(&buf),
			    Tcl_DStringLength(&buf)));
	    if (regWinProcs->useWide) {
		while (*((Tcl_UniChar *)p)++ != 0) {}
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
}

/*
 *----------------------------------------------------------------------
 *
 * GetValueNames --
 *
 *	This function enumerates the values of the a given key.  If
 *	the optional pattern is supplied, then only value names that
 *	match the pattern will be returned.
 *
 * Results:
 *	Returns the list of value names in the result object of the
 *	interpreter, or an error message on failure.
 *
 * Side effects:
 *	None.







|
|
|







841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
}

/*
 *----------------------------------------------------------------------
 *
 * GetValueNames --
 *
 *	This function enumerates the values of the a given key. If the
 *	optional pattern is supplied, then only value names that match the
 *	pattern will be returned.
 *
 * Results:
 *	Returns the list of value names in the result object of the
 *	interpreter, or an error message on failure.
 *
 * Side effects:
 *	None.
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932

933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
     * Enumerate the values under the given subkey until we get an error,
     * indicating the end of the list.  Note that we need to reset size
     * after each iteration because RegEnumValue smashes the old value.
     */

    size = maxSize;
    while ((*regWinProcs->regEnumValueProc)(key, index,
	    Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
	    == ERROR_SUCCESS) {

	if (regWinProcs->useWide) {
	    size *= 2;
	}

	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds);

	name = Tcl_DStringValue(&ds);
	if (!pattern || Tcl_StringMatch(name, pattern)) {
	    result = Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
	    if (result != TCL_OK) {
		Tcl_DStringFree(&ds);
		break;
	    }
	}
	Tcl_DStringFree(&ds);

	index++;
	size = maxSize;
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DStringFree(&buffer);

    done:
    RegCloseKey(key);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * OpenKey --
 *
 *	This function opens the specified key.  This function is a
 *	simple wrapper around ParseKeyName and OpenSubKey.
 *
 * Results:
 *	Returns the opened key in the keyPtr argument and a Tcl
 *	result code.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|











|
>

















|









|
|


|
<







908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961

962
963
964
965
966
967
968
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
     * Enumerate the values under the given subkey until we get an error,
     * indicating the end of the list. Note that we need to reset size after
     * each iteration because RegEnumValue smashes the old value.
     */

    size = maxSize;
    while ((*regWinProcs->regEnumValueProc)(key, index,
	    Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
	    == ERROR_SUCCESS) {

	if (regWinProcs->useWide) {
	    size *= 2;
	}

	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size,
		&ds);
	name = Tcl_DStringValue(&ds);
	if (!pattern || Tcl_StringMatch(name, pattern)) {
	    result = Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
	    if (result != TCL_OK) {
		Tcl_DStringFree(&ds);
		break;
	    }
	}
	Tcl_DStringFree(&ds);

	index++;
	size = maxSize;
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DStringFree(&buffer);

  done:
    RegCloseKey(key);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * OpenKey --
 *
 *	This function opens the specified key. This function is a simple
 *	wrapper around ParseKeyName and OpenSubKey.
 *
 * Results:
 *	Returns the opened key in the keyPtr argument and a Tcl result code.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
}

/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
 *
 *	This function opens a given subkey of a root key on the
 *	specified host.
 *
 * Results:
 *	Returns the opened key in the keyPtr and a Windows error code
 *	as the return value.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|


|
|







1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
}

/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
 *
 *	This function opens a given subkey of a root key on the specified
 *	host.
 *
 * Results:
 *	Returns the opened key in the keyPtr and a Windows error code as the
 *	return value.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
	Tcl_DStringFree(&buf);
	if (result != ERROR_SUCCESS) {
	    return result;
	}
    }

    /*
     * Now open the specified key with the requested permissions.  Note
     * that this key must be closed by the caller.
     */

    keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
    if (flags & REG_CREATE) {
	DWORD create;
	result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
		REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
    } else {
	if (rootKey == HKEY_PERFORMANCE_DATA) {
	    /*
	     * Here we fudge it for this special root key.
	     * See MSDN for more info on HKEY_PERFORMANCE_DATA and
	     * the peculiarities surrounding it
	     */
	    *keyPtr = HKEY_PERFORMANCE_DATA;
	    result = ERROR_SUCCESS;
	} else {
	    result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0,
		    mode, keyPtr);
	}
    }
    Tcl_DStringFree(&buf);

    /*
     * Be sure to close the root key since we are done with it now.
     */

    if (hostName) {
	RegCloseKey(rootKey);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseKeyName --
 *
 *	This function parses a key name into the host, root, and subkey
 *	parts.
 *
 * Results:
 *	The pointers to the start of the host and subkey names are
 *	returned in the hostNamePtr and keyNamePtr variables.  The
 *	specified root HKEY is returned in rootKeyPtr.  Returns
 *	a standard Tcl result.
 *
 *
 * Side effects:
 *	Modifies the name string by inserting nulls.
 *
 *----------------------------------------------------------------------
 */








|
|







<
|
|
|
<
|
|
|
|
|
|
|
<


















|
<


|
|
<
|
<







1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056

1057
1058
1059

1060
1061
1062
1063
1064
1065
1066

1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085

1086
1087
1088
1089

1090

1091
1092
1093
1094
1095
1096
1097
	Tcl_DStringFree(&buf);
	if (result != ERROR_SUCCESS) {
	    return result;
	}
    }

    /*
     * Now open the specified key with the requested permissions. Note that
     * this key must be closed by the caller.
     */

    keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
    if (flags & REG_CREATE) {
	DWORD create;
	result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
		REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);

    } else if (rootKey == HKEY_PERFORMANCE_DATA) {
	/*
	 * Here we fudge it for this special root key. See MSDN for more info

	 * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
	 */
	*keyPtr = HKEY_PERFORMANCE_DATA;
	result = ERROR_SUCCESS;
    } else {
	result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
		keyPtr);

    }
    Tcl_DStringFree(&buf);

    /*
     * Be sure to close the root key since we are done with it now.
     */

    if (hostName) {
	RegCloseKey(rootKey);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseKeyName --
 *
 *	This function parses a key name into the host, root, and subkey parts.

 *
 * Results:
 *	The pointers to the start of the host and subkey names are returned in
 *	the hostNamePtr and keyNamePtr variables. The specified root HKEY is

 *	returned in rootKeyPtr. Returns a standard Tcl result.

 *
 * Side effects:
 *	Modifies the name string by inserting nulls.
 *
 *----------------------------------------------------------------------
 */

1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
}

/*
 *----------------------------------------------------------------------
 *
 * RecursiveDeleteKey --
 *
 *	This function recursively deletes all the keys below a starting
 *	key.  Although Windows 95 does this automatically, we still need
 *	to do this for Windows NT.
 *
 * Results:
 *	Returns a Windows error code.
 *
 * Side effects:
 *	Deletes all of the keys and values below the given key.
 *







|
|
|







1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
}

/*
 *----------------------------------------------------------------------
 *
 * RecursiveDeleteKey --
 *
 *	This function recursively deletes all the keys below a starting key.
 *	Although Windows 95 does this automatically, we still need to do this
 *	for Windows NT.
 *
 * Results:
 *	Returns a Windows error code.
 *
 * Side effects:
 *	Deletes all of the keys and values below the given key.
 *
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
}

/*
 *----------------------------------------------------------------------
 *
 * SetValue --
 *
 *	This function sets the contents of a registry value.  If
 *	the key or value does not exist, it will be created.  If it
 *	does exist, then the data and type will be replaced.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	May create new keys or values.
 *







|
|
|







1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
}

/*
 *----------------------------------------------------------------------
 *
 * SetValue --
 *
 *	This function sets the contents of a registry value. If the key or
 *	value does not exist, it will be created. If it does exist, then the
 *	data and type will be replaced.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	May create new keys or values.
 *
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
	if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	/*
	 * Append the elements as null terminated strings.  Note that
	 * we must not assume the length of the string in case there are
	 * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
	 */

	Tcl_DStringInit(&data);
	for (i = 0; i < objc; i++) {
	    Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);

	    /*
	     * Add a null character to separate this value from the next.
	     * We accomplish this by growing the string by one byte.  Since the
	     * DString always tacks on an extra null byte, the new byte will
	     * already be set to null.
	     */

	    Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
	}








|
|
|







|
|







1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
	if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	/*
	 * Append the elements as null terminated strings. Note that we must
	 * not assume the length of the string in case there are embedded
	 * nulls, which aren't allowed in REG_MULTI_SZ values.
	 */

	Tcl_DStringInit(&data);
	for (i = 0; i < objc; i++) {
	    Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);

	    /*
	     * Add a null character to separate this value from the next. We
	     * accomplish this by growing the string by one byte. Since the
	     * DString always tacks on an extra null byte, the new byte will
	     * already be set to null.
	     */

	    Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
	}

1362
1363
1364
1365
1366
1367
1368

1369
1370

1371

1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
	 * Store binary data in the registry.
	 */

	data = Tcl_GetByteArrayFromObj(dataObj, &length);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
		(BYTE *)data, (DWORD) length);
    }

    Tcl_DStringFree(&nameBuf);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {

	Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", -1));
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * BroadcastValue --
 *
 *	This function broadcasts a WM_SETTINGCHANGE message to indicate
 *	to other programs that we have changed the contents of a registry
 *	value.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	Will cause other programs to reload their system settings.
 *







>


>

>
|











|
|
<







1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378

1379
1380
1381
1382
1383
1384
1385
	 * Store binary data in the registry.
	 */

	data = Tcl_GetByteArrayFromObj(dataObj, &length);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
		(BYTE *)data, (DWORD) length);
    }

    Tcl_DStringFree(&nameBuf);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("unable to set value: ", -1));
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * BroadcastValue --
 *
 *	This function broadcasts a WM_SETTINGCHANGE message to indicate to
 *	other programs that we have changed the contents of a registry value.

 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	Will cause other programs to reload their system settings.
 *
1409
1410
1411
1412
1413
1414
1415
1416

1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432

1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
    if ((objc != 3) && (objc != 5)) {
	Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	return TCL_ERROR;
    }

    if (objc > 3) {
	str = Tcl_GetStringFromObj(objv[3], &len);
	if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) {

	    Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    str = Tcl_GetStringFromObj(objv[2], &len);
    if (len == 0) {
	str = NULL;
    }

    /*
     * Use the ignore the result.
     */

    result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
	    (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);

    objPtr = Tcl_NewObj();
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
    Tcl_SetObjResult(interp, objPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppendSystemError --
 *
 *	This routine formats a Windows system error message and places
 *	it into the interpreter result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *







|
>
















>
















|
|







1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
    if ((objc != 3) && (objc != 5)) {
	Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	return TCL_ERROR;
    }

    if (objc > 3) {
	str = Tcl_GetStringFromObj(objv[3], &len);
	if ((len < 2) || (*str != '-')
		|| strncmp(str, "-timeout", (size_t) len)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    str = Tcl_GetStringFromObj(objv[2], &len);
    if (len == 0) {
	str = NULL;
    }

    /*
     * Use the ignore the result.
     */

    result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
	    (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);

    objPtr = Tcl_NewObj();
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
    Tcl_SetObjResult(interp, objPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppendSystemError --
 *
 *	This routine formats a Windows system error message and places it into
 *	the interpreter result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
1508
1509
1510
1511
1512
1513
1514

1515
1516
1517
1518
1519
1520
1521

	msg = Tcl_DStringValue(&ds);
	length = Tcl_DStringLength(&ds);

	/*
	 * Trim the trailing CR/LF from the system message.
	 */

	if (msg[length-1] == '\n') {
	    msg[--length] = 0;
	}
	if (msg[length-1] == '\r') {
	    msg[--length] = 0;
	}
    }







>







1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516

	msg = Tcl_DStringValue(&ds);
	length = Tcl_DStringLength(&ds);

	/*
	 * Trim the trailing CR/LF from the system message.
	 */

	if (msg[length-1] == '\n') {
	    msg[--length] = 0;
	}
	if (msg[length-1] == '\r') {
	    msg[--length] = 0;
	}
    }
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertDWORD --
 *
 *	This function determines whether a DWORD needs to be byte
 *	swapped, and returns the appropriately swapped value.
 *
 * Results:
 *	Returns a converted DWORD.
 *
 * Side effects:
 *	None.
 *







|
|







1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertDWORD --
 *
 *	This function determines whether a DWORD needs to be byte swapped, and
 *	returns the appropriately swapped value.
 *
 * Results:
 *	Returns a converted DWORD.
 *
 * Side effects:
 *	None.
 *
1558
1559
1560
1561
1562
1563
1564








    /*
     * Check to see if the low bit is in the first byte.
     */

    localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
    return (type != localType) ? SWAPLONG(value) : value;
}















>
>
>
>
>
>
>
>
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
    /*
     * Check to see if the low bit is in the first byte.
     */

    localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
    return (type != localType) ? SWAPLONG(value) : value;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinSerial.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinSerial.c --
 *
 *  This file implements the Windows-specific serial port functions,
 *  and the "serial" channel driver.
 *
 * Copyright (c) 1999 by Scriptics Corp.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * Serial functionality implemented by [email protected]
 *
 * RCS: @(#) $Id: tclWinSerial.c,v 1.28 2003/08/19 19:39:56 patthoyts Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>



|
|



|
|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinSerial.c --
 *
 *	This file implements the Windows-specific serial port functions, and
 *	the "serial" channel driver.
 *
 * Copyright (c) 1999 by Scriptics Corp.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * Serial functionality implemented by [email protected]
 *
 * RCS: @(#) $Id: tclWinSerial.c,v 1.28.2.3 2005/10/08 13:45:04 dgp Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

TCL_DECLARE_MUTEX(serialMutex)

/*
 * Bit masks used in the flags field of the SerialInfo structure below.
 */

#define SERIAL_PENDING  (1<<0)  /* Message is pending in the queue. */
#define SERIAL_ASYNC    (1<<1)  /* Channel is non-blocking. */

/*
 * Bit masks used in the sharedFlags field of the SerialInfo structure below.
 */

#define SERIAL_EOF      (1<<2)  /* Serial has reached EOF. */
#define SERIAL_ERROR    (1<<4)

/*
 * Default time to block between checking status on the serial port.
 */

#define SERIAL_DEFAULT_BLOCKTIME    10  /* 10 msec */

/*
 * Define Win32 read/write error masks returned by ClearCommError()
 */

#define SERIAL_READ_ERRORS      ( CE_RXOVER | CE_OVERRUN | CE_RXPARITY \
				| CE_FRAME  | CE_BREAK )
#define SERIAL_WRITE_ERRORS     ( CE_TXFULL | CE_PTO )


/*
 * This structure describes per-instance data for a serial based channel.
 */

typedef struct SerialInfo {
    HANDLE handle;
    struct SerialInfo *nextPtr;	/* Pointer to next registered serial. */
    Tcl_Channel channel;	/* Pointer to channel structure. */
    int validMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which operations are valid on the file. */
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    int readable;		/* flag that the channel is readable */
    int writable;		/* flag that the channel is writable */
    int blockTime;		/* max. blocktime in msec */
    unsigned int lastEventTime;	/* Time in milliseconds since last readable
				 * event */
				/* Next readable event only after blockTime */
    DWORD error;		/* pending error code returned by
				 * ClearCommError() */
    DWORD lastError;		/* last error code, can be fetched with
				 * fconfigure chan -lasterror */
    DWORD sysBufRead;		/* Win32 system buffer size for read ops, 
				 * default=4096 */
    DWORD sysBufWrite;		/* Win32 system buffer size for write ops, 
				 * default=4096 */

    Tcl_ThreadId threadId;	/* Thread to which events should be reported.
				 * This value is used by the reader/writer
				 * threads. */
    OVERLAPPED osRead;		/* OVERLAPPED structure for read operations */
    OVERLAPPED osWrite;		/* OVERLAPPED structure for write operations */
    HANDLE writeThread;		/* Handle to writer thread. */
    CRITICAL_SECTION csWrite;	/* Writer thread synchronisation */
    HANDLE evWritable;		/* Manual-reset event to signal when the
				 * writer thread has finished waiting for
				 * the current buffer to be written. */
    HANDLE evStartWriter;	/* Auto-reset event used by the main thread to
				 * signal when the writer thread should attempt
				 * to write to the serial. */
    HANDLE evStopWriter;	/* Auto-reset event used by the main thread to
				 * signal when the writer thread should close.
				 */
    DWORD writeError;		/* An error caused by the last background
				 * write.  Set to 0 if no error has been
				 * detected.  This word is shared with the
				 * writer thread so access must be
				 * synchronized with the evWritable object.
				 */
    char *writeBuf;		/* Current background output buffer.
				 * Access is synchronized with the evWritable
				 * object. */
    int writeBufLen;		/* Size of write buffer.  Access is
				 * synchronized with the evWritable
				 * object. */
    int toWrite;		/* Current amount to be written.  Access is
				 * synchronized with the evWritable object. */
    int writeQueue;		/* Number of bytes pending in output queue.
				 * Offset to DCB.cbInQue.
				 * Used to query [fconfigure -queue] */
} SerialInfo;

typedef struct ThreadSpecificData {
    /*
     * The following pointer refers to the head of the list of serials
     * that are being watched for file events.
     */

    SerialInfo *firstSerialPtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when
 * serial events are generated.
 */

typedef struct SerialEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    SerialInfo *infoPtr;	/* Pointer to serial info structure.  Note
				 * that we still have to verify that the
				 * serial exists before dereferencing this
				 * pointer. */
} SerialEvent;

/*
 * We don't use timeouts.
 */








|
|





|
|





|





|
|
|
>
















|
|
|

|





|

|





|


|

|
|

|
|




|
|

|
<
|
|
<
|
|
<
|


|
|




|
|








|
|



|
|
|
|
|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

118
119

120
121

122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

TCL_DECLARE_MUTEX(serialMutex)

/*
 * Bit masks used in the flags field of the SerialInfo structure below.
 */

#define SERIAL_PENDING	(1<<0)	/* Message is pending in the queue. */
#define SERIAL_ASYNC	(1<<1)	/* Channel is non-blocking. */

/*
 * Bit masks used in the sharedFlags field of the SerialInfo structure below.
 */

#define SERIAL_EOF	(1<<2)	/* Serial has reached EOF. */
#define SERIAL_ERROR	(1<<4)

/*
 * Default time to block between checking status on the serial port.
 */

#define SERIAL_DEFAULT_BLOCKTIME 10	/* 10 msec */

/*
 * Define Win32 read/write error masks returned by ClearCommError()
 */

#define SERIAL_READ_ERRORS \
	(CE_RXOVER | CE_OVERRUN | CE_RXPARITY | CE_FRAME  | CE_BREAK)
#define SERIAL_WRITE_ERRORS \
	(CE_TXFULL | CE_PTO)

/*
 * This structure describes per-instance data for a serial based channel.
 */

typedef struct SerialInfo {
    HANDLE handle;
    struct SerialInfo *nextPtr;	/* Pointer to next registered serial. */
    Tcl_Channel channel;	/* Pointer to channel structure. */
    int validMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which operations are valid on the file. */
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    int readable;		/* Flag that the channel is readable. */
    int writable;		/* Flag that the channel is writable. */
    int blockTime;		/* Maximum blocktime in msec. */
    unsigned int lastEventTime;	/* Time in milliseconds since last readable
				 * event. */
				/* Next readable event only after blockTime */
    DWORD error;		/* pending error code returned by
				 * ClearCommError() */
    DWORD lastError;		/* last error code, can be fetched with
				 * fconfigure chan -lasterror */
    DWORD sysBufRead;		/* Win32 system buffer size for read ops,
				 * default=4096 */
    DWORD sysBufWrite;		/* Win32 system buffer size for write ops,
				 * default=4096 */

    Tcl_ThreadId threadId;	/* Thread to which events should be reported.
				 * This value is used by the reader/writer
				 * threads. */
    OVERLAPPED osRead;		/* OVERLAPPED structure for read operations. */
    OVERLAPPED osWrite;		/* OVERLAPPED structure for write operations */
    HANDLE writeThread;		/* Handle to writer thread. */
    CRITICAL_SECTION csWrite;	/* Writer thread synchronisation. */
    HANDLE evWritable;		/* Manual-reset event to signal when the
				 * writer thread has finished waiting for the
				 * current buffer to be written. */
    HANDLE evStartWriter;	/* Auto-reset event used by the main thread to
				 * signal when the writer thread should
				 * attempt to write to the serial. */
    HANDLE evStopWriter;	/* Auto-reset event used by the main thread to
				 * signal when the writer thread should close.
				 */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the evWritable object. */

    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the evWritable object. */

    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the evWritable object. */

    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the evWritable object. */
    int writeQueue;		/* Number of bytes pending in output queue.
				 * Offset to DCB.cbInQue. Used to query
				 * [fconfigure -queue] */
} SerialInfo;

typedef struct ThreadSpecificData {
    /*
     * The following pointer refers to the head of the list of serials that
     * are being watched for file events.
     */

    SerialInfo *firstSerialPtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following structure is what is added to the Tcl event queue when serial
 * events are generated.
 */

typedef struct SerialEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    SerialInfo *infoPtr;	/* Pointer to serial info structure. Note that
				 * we still have to verify that the serial
				 * exists before dereferencing this
				 * pointer. */
} SerialEvent;

/*
 * We don't use timeouts.
 */

186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201



202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222


223
224
225
226
227
228
229
				    CONST char *buf, int toWrite,
				    int *errorCode);
static void			SerialSetupProc(ClientData clientData,
				    int flags);
static void			SerialWatchProc(ClientData instanceData,
				    int mask);
static void			ProcExitHandler(ClientData clientData);
static int			SerialGetOptionProc _ANSI_ARGS_((
				    ClientData instanceData,
				    Tcl_Interp *interp, CONST char *optionName,
				    Tcl_DString *dsPtr));
static int			SerialSetOptionProc _ANSI_ARGS_((
				    ClientData instanceData,
				    Tcl_Interp *interp, CONST char *optionName,
				    CONST char *value));
static DWORD WINAPI		SerialWriterThread(LPVOID arg);




/*
 * This structure describes the channel type structure for command serial
 * based IO.
 */

static Tcl_ChannelType serialChannelType = {
    "serial",			/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* v2 channel */
    SerialCloseProc,		/* Close proc. */
    SerialInputProc,		/* Input proc. */
    SerialOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    SerialSetOptionProc,	/* Set option proc. */
    SerialGetOptionProc,	/* Get option proc. */
    SerialWatchProc,		/* Set up notifier to watch the channel. */
    SerialGetHandleProc,	/* Get an OS handle from channel. */
    NULL,			/* close2proc. */
    SerialBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */


};

/*
 *----------------------------------------------------------------------
 *
 * SerialInit --
 *







|
<

|
|
<

|

>
>
>








|












>
>







184
185
186
187
188
189
190
191

192
193
194

195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
				    CONST char *buf, int toWrite,
				    int *errorCode);
static void			SerialSetupProc(ClientData clientData,
				    int flags);
static void			SerialWatchProc(ClientData instanceData,
				    int mask);
static void			ProcExitHandler(ClientData clientData);
static int			SerialGetOptionProc(ClientData instanceData,

				    Tcl_Interp *interp, CONST char *optionName,
				    Tcl_DString *dsPtr);
static int			SerialSetOptionProc(ClientData instanceData,

				    Tcl_Interp *interp, CONST char *optionName,
				    CONST char *value);
static DWORD WINAPI		SerialWriterThread(LPVOID arg);

static void			SerialThreadActionProc(ClientData instanceData,
				    int action);

/*
 * This structure describes the channel type structure for command serial
 * based IO.
 */

static Tcl_ChannelType serialChannelType = {
    "serial",			/* Type name. */
    TCL_CHANNEL_VERSION_4,	/* v4 channel */
    SerialCloseProc,		/* Close proc. */
    SerialInputProc,		/* Input proc. */
    SerialOutputProc,		/* Output proc. */
    NULL,			/* Seek proc. */
    SerialSetOptionProc,	/* Set option proc. */
    SerialGetOptionProc,	/* Get option proc. */
    SerialWatchProc,		/* Set up notifier to watch the channel. */
    SerialGetHandleProc,	/* Get an OS handle from channel. */
    NULL,			/* close2proc. */
    SerialBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    SerialThreadActionProc,	/* thread action proc */
};

/*
 *----------------------------------------------------------------------
 *
 * SerialInit --
 *
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372

373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
}

/*
 *----------------------------------------------------------------------
 *
 * SerialExitHandler --
 *
 *	This function is called to cleanup the serial module before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the serial event source.
 *
 *----------------------------------------------------------------------
 */

static void
SerialExitHandler(
    ClientData clientData)  /* Old window proc */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    SerialInfo *infoPtr;

    /*
     * Clear all eventually pending output.
     * Otherwise Tcl's exit could totally block,
     * because it performs a blocking flush on all open channels.
     * Note that serial write operations may be blocked due to handshake.
     */

    for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	PurgeComm(infoPtr->handle,
		PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR);
    }
    Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * ProcExitHandler --
 *
 *	This function is called to cleanup the process list before
 *	Tcl is unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the process list.
 *
 *----------------------------------------------------------------------
 */

static void
ProcExitHandler(
    ClientData clientData)  /* Old window proc */
{
    Tcl_MutexLock(&serialMutex);
    initialized = 0;
    Tcl_MutexUnlock(&serialMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialBlockTime --
 *
 *	Wrapper to set Tcl's block time in msec
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Updates the maximum blocking time.

 *----------------------------------------------------------------------
 */

static void
SerialBlockTime(
    int msec)		/* milli-seconds */
{
    Tcl_Time blockTime;

    blockTime.sec  =  msec / 1000;
    blockTime.usec = (msec % 1000) * 1000;
    Tcl_SetMaxBlockTime(&blockTime);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialGetMilliseconds --
 *
 *	Get current time in milliseconds,ignoring integer overruns.
 *
 * Results:
 *	The current time.
 *
 * Side effects:
 *	None.

 *----------------------------------------------------------------------
 */

static unsigned int
SerialGetMilliseconds(void)
{
    Tcl_Time time;

    TclpGetTime(&time);

    return (time.sec * 1000 + time.usec / 1000);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialSetupProc --
 *
 *  This procedure is invoked before Tcl_DoOneEvent blocks waiting
 *  for an event.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Adjusts the block time if needed.
 *
 *----------------------------------------------------------------------
 */

void
SerialSetupProc(
    ClientData data,	/* Not used. */
    int flags)		/* Event flags as passed to Tcl_DoOneEvent. */
{
    SerialInfo *infoPtr;
    int block = 1;
    int msec = INT_MAX; /* min. found block time */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events handlers installed. If they are, do not block.

     */

    for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
	    infoPtr=infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
		block = 0;







|
|












|





|
<
|
|















|
|












|


















>





|




















>


















|
|


|


|






|
|



|







|
>







269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
}

/*
 *----------------------------------------------------------------------
 *
 * SerialExitHandler --
 *
 *	This function is called to cleanup the serial module before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the serial event source.
 *
 *----------------------------------------------------------------------
 */

static void
SerialExitHandler(
    ClientData clientData)	/* Old window proc */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    SerialInfo *infoPtr;

    /*
     * Clear all eventually pending output. Otherwise Tcl's exit could totally

     * block, because it performs a blocking flush on all open channels. Note
     * that serial write operations may be blocked due to handshake.
     */

    for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	PurgeComm(infoPtr->handle,
		PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR);
    }
    Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * ProcExitHandler --
 *
 *	This function is called to cleanup the process list before Tcl is
 *	unloaded.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the process list.
 *
 *----------------------------------------------------------------------
 */

static void
ProcExitHandler(
    ClientData clientData)	/* Old window proc */
{
    Tcl_MutexLock(&serialMutex);
    initialized = 0;
    Tcl_MutexUnlock(&serialMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialBlockTime --
 *
 *	Wrapper to set Tcl's block time in msec
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Updates the maximum blocking time.
 *
 *----------------------------------------------------------------------
 */

static void
SerialBlockTime(
    int msec)			/* milli-seconds */
{
    Tcl_Time blockTime;

    blockTime.sec  =  msec / 1000;
    blockTime.usec = (msec % 1000) * 1000;
    Tcl_SetMaxBlockTime(&blockTime);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialGetMilliseconds --
 *
 *	Get current time in milliseconds,ignoring integer overruns.
 *
 * Results:
 *	The current time.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static unsigned int
SerialGetMilliseconds(void)
{
    Tcl_Time time;

    TclpGetTime(&time);

    return (time.sec * 1000 + time.usec / 1000);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialSetupProc --
 *
 *	This procedure is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
 *----------------------------------------------------------------------
 */

void
SerialSetupProc(
    ClientData data,		/* Not used. */
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    SerialInfo *infoPtr;
    int block = 1;
    int msec = INT_MAX;		/* min. found block time */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events handlers installed. If they are, do not
     * block.
     */

    for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
	    infoPtr=infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
		block = 0;
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
}

/*
 *----------------------------------------------------------------------
 *
 * SerialCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the serial
 *	event source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
 *----------------------------------------------------------------------
 */

static void
SerialCheckProc(
    ClientData data,    /* Not used. */
    int flags)		/* Event flags as passed to Tcl_DoOneEvent. */
{
    SerialInfo *infoPtr;
    SerialEvent *evPtr;
    int needEvent;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    COMSTAT cStat;
    unsigned int time;







|
|












|
|







441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
}

/*
 *----------------------------------------------------------------------
 *
 * SerialCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the serial event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
 *----------------------------------------------------------------------
 */

static void
SerialCheckProc(
    ClientData data,		/* Not used. */
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    SerialInfo *infoPtr;
    SerialEvent *evPtr;
    int needEvent;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    COMSTAT cStat;
    unsigned int time;
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
	if (infoPtr->flags & SERIAL_PENDING) {
	    continue;
	}

	needEvent = 0;

	/*
	 * If WRITABLE watch mask is set look for infoPtr->evWritable
	 * object
	 */

	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
		infoPtr->writable = 1;
		needEvent = 1;
	    }
	}

	/*
	 * If READABLE watch mask is set call ClearCommError to poll
	 * cbInQue Window errors are ignored here
	 */

	if (infoPtr->watchMask & TCL_READABLE) {
	    if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) {
		/*
		 * Look for characters already pending in windows
		 * queue.  If they are, poll.
		 */

		if (infoPtr->watchMask & TCL_READABLE) {
		    /*
		     * force fileevent after serial read error
		     */

		    if ((cStat.cbInQue > 0) ||
			    (infoPtr->error & SERIAL_READ_ERRORS)) {
			infoPtr->readable = 1;
			time = SerialGetMilliseconds();
			if ((unsigned int) (time - infoPtr->lastEventTime)
				>= (unsigned int) infoPtr->blockTime) {
			    needEvent = 1;
			    infoPtr->lastEventTime = time;
			}
		    }
		}
	    }
	}

	/*
	 * Queue an event if the serial is signaled for reading or
	 * writing.
	 */

	if (needEvent) {
	    infoPtr->flags |= SERIAL_PENDING;
	    evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
	    evPtr->header.proc = SerialEventProc;
	    evPtr->infoPtr = infoPtr;







|
<


|
|
|
|
<



|
|





|
|




|

















|
<







483
484
485
486
487
488
489
490

491
492
493
494
495
496

497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531

532
533
534
535
536
537
538
	if (infoPtr->flags & SERIAL_PENDING) {
	    continue;
	}

	needEvent = 0;

	/*
	 * If WRITABLE watch mask is set look for infoPtr->evWritable object.

	 */

	if (infoPtr->watchMask & TCL_WRITABLE &&
		WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
	    infoPtr->writable = 1;
	    needEvent = 1;

	}

	/*
	 * If READABLE watch mask is set call ClearCommError to poll cbInQue.
	 * Window errors are ignored here.
	 */

	if (infoPtr->watchMask & TCL_READABLE) {
	    if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) {
		/*
		 * Look for characters already pending in windows queue. If
		 * they are, poll.
		 */

		if (infoPtr->watchMask & TCL_READABLE) {
		    /*
		     * Force fileevent after serial read error.
		     */

		    if ((cStat.cbInQue > 0) ||
			    (infoPtr->error & SERIAL_READ_ERRORS)) {
			infoPtr->readable = 1;
			time = SerialGetMilliseconds();
			if ((unsigned int) (time - infoPtr->lastEventTime)
				>= (unsigned int) infoPtr->blockTime) {
			    needEvent = 1;
			    infoPtr->lastEventTime = time;
			}
		    }
		}
	    }
	}

	/*
	 * Queue an event if the serial is signaled for reading or writing.

	 */

	if (needEvent) {
	    infoPtr->flags |= SERIAL_PENDING;
	    evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
	    evPtr->header.proc = SerialEventProc;
	    evPtr->infoPtr = infoPtr;
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
    int mode)			/* TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    int errorCode = 0;
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    /*
     * Only serial READ can be switched between blocking & nonblocking
     * using COMMTIMEOUTS.  Serial write emulates blocking &
     * nonblocking by the SerialWriterThread.
     */

    if (mode == TCL_MODE_NONBLOCKING) {
	infoPtr->flags |= SERIAL_ASYNC;
    } else {
	infoPtr->flags &= ~(SERIAL_ASYNC);
    }







|
|
|







563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
    int mode)			/* TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    int errorCode = 0;
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    /*
     * Only serial READ can be switched between blocking & nonblocking using
     * COMMTIMEOUTS. Serial write emulates blocking & nonblocking by the
     * SerialWriterThread.
     */

    if (mode == TCL_MODE_NONBLOCKING) {
	infoPtr->flags |= SERIAL_ASYNC;
    } else {
	infoPtr->flags &= ~(SERIAL_ASYNC);
    }
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
    if (serialPtr->validMask & TCL_READABLE) {
	PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
	CloseHandle(serialPtr->osRead.hEvent);
    }
    serialPtr->validMask &= ~TCL_READABLE;

    if (serialPtr->validMask & TCL_WRITABLE) {

	/*
	 * Generally we cannot wait for a pending write operation
	 * because it may hang due to handshake
	 *    WaitForSingleObject(serialPtr->evWritable, INFINITE);
	 */

	/*
	 * The thread may have already closed on it's own.  Check it's
	 * exit code.
	 */

	GetExitCodeThread(serialPtr->writeThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {
	    /*
	     * Set the stop event so that if the writer thread is
	     * blocked in SerialWriterThread on WaitForMultipleEvents, it
	     * will exit cleanly.
	     */

	    SetEvent(serialPtr->evStopWriter);

	    /*
	     * Wait at most 20 milliseconds for the writer thread to
	     * close.
	     */

	    if (WaitForSingleObject(serialPtr->writeThread, 20)
		    == WAIT_TIMEOUT) {
		/*
		 * Forcibly terminate the background thread as a last
		 * resort.  Note that we need to guard against
		 * terminating the thread while it is in the middle of
		 * Tcl_ThreadAlert because it won't be able to release
		 * the notifier lock.
		 */

		Tcl_MutexLock(&serialMutex);

		/* BUG: this leaks memory */
		TerminateThread(serialPtr->writeThread, 0);








<

|
|




|
|






|
|
|





|
<


|
|

|
|
|
<
|







612
613
614
615
616
617
618

619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642

643
644
645
646
647
648
649
650

651
652
653
654
655
656
657
658
    if (serialPtr->validMask & TCL_READABLE) {
	PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
	CloseHandle(serialPtr->osRead.hEvent);
    }
    serialPtr->validMask &= ~TCL_READABLE;

    if (serialPtr->validMask & TCL_WRITABLE) {

	/*
	 * Generally we cannot wait for a pending write operation because it
	 * may hang due to handshake
	 *    WaitForSingleObject(serialPtr->evWritable, INFINITE);
	 */

	/*
	 * The thread may have already closed on it's own. Check it's exit
	 * code.
	 */

	GetExitCodeThread(serialPtr->writeThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {
	    /*
	     * Set the stop event so that if the writer thread is blocked in
	     * SerialWriterThread on WaitForMultipleEvents, it will exit
	     * cleanly.
	     */

	    SetEvent(serialPtr->evStopWriter);

	    /*
	     * Wait at most 20 milliseconds for the writer thread to close.

	     */

	    if (WaitForSingleObject(serialPtr->writeThread,
		    20) == WAIT_TIMEOUT) {
		/*
		 * Forcibly terminate the background thread as a last resort.
		 * Note that we need to guard against terminating the thread
		 * while it is in the middle of Tcl_ThreadAlert because it

		 * won't be able to release the notifier lock.
		 */

		Tcl_MutexLock(&serialMutex);

		/* BUG: this leaks memory */
		TerminateThread(serialPtr->writeThread, 0);

672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
	serialPtr->writeThread = NULL;

	PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
    }
    serialPtr->validMask &= ~TCL_WRITABLE;

    /*
     * Don't close the Win32 handle if the handle is a standard
     * channel during the thread exit process.  Otherwise, one thread
     * may kill the stdio of another.
     */

    if (!TclInThreadExit()
	    || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle)
	    && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle)
	    && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) {
	if (CloseHandle(serialPtr->handle) == FALSE) {







|
|
|







669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
	serialPtr->writeThread = NULL;

	PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
    }
    serialPtr->validMask &= ~TCL_WRITABLE;

    /*
     * Don't close the Win32 handle if the handle is a standard channel during
     * the thread exit process. Otherwise, one thread may kill the stdio of
     * another.
     */

    if (!TclInThreadExit()
	    || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle)
	    && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle)
	    && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) {
	if (CloseHandle(serialPtr->handle) == FALSE) {
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766

767


768
769

770


771
772
773
774
775

776

777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823

824
825
826

827
828
829
830
831
832

833
834

835


836
837
838
839
840
841

842


843
844

845


846
847
848

849

850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951

952
953

954

955
956
957
958
959
960
961
962
963
964

965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016

1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
	if (infoPtr == (SerialInfo *)serialPtr) {
	    *nextPtrPtr = infoPtr->nextPtr;
	    break;
	}
    }

    /*
     * Wrap the error file into a channel and give it to the cleanup
     * routine.
     */

    if (serialPtr->writeBuf != NULL) {
	ckfree(serialPtr->writeBuf);
	serialPtr->writeBuf = NULL;
    }
    ckfree((char*) serialPtr);

    if (errorCode == 0) {
	return result;
    }
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * blockingRead --
 *
 *	Perform a blocking read into the buffer given. Returns count
 *	of how many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
blockingRead( 
    SerialInfo *infoPtr,	/* Serial info structure */
    LPVOID buf,			/* The input buffer pointer */
    DWORD  bufSize,		/* The number of bytes to read */
    LPDWORD  lpRead,		/* Returns number of bytes read */ 
    LPOVERLAPPED osPtr )	/* OVERLAPPED structure */
{
    /*
     *  Perform overlapped blocking read. 
     *  1. Reset the overlapped event
     *  2. Start overlapped read operation
     *  3. Wait for completion
     */

    /* 
     * Set Offset to ZERO, otherwise NT4.0 may report an error.
     */

    osPtr->Offset = osPtr->OffsetHigh = 0;
    ResetEvent(osPtr->hEvent);
    if (!ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr)) {
	if (GetLastError() != ERROR_IO_PENDING) {

	    /* ReadFile failed, but it isn't delayed. Report error. */


	    return FALSE;
	} else {   

	    /* Read is pending, wait for completion, timeout ? */


	    if (!GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE)) {
		return FALSE;
	    }
	}
    } else {

	/* ReadFile completed immediately. */

    }
    return TRUE;
}

/*
 *----------------------------------------------------------------------
 *
 * blockingWrite --
 *
 *	Perform a blocking write  from the buffer given. Returns count
 *	of  how  many  bytes  were  actually  written,  and  an  error
 *	indication.
 *
 * Results:
 *	A count of how many bytes were written is returned and an error
 *	indication is returned.
 *
 * Side effects:
 *	Writes output to the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
blockingWrite(
    SerialInfo *infoPtr,	/* Serial info structure */
    LPVOID  buf,		/* The output buffer pointer */
    DWORD   bufSize,		/* The number of bytes to write */
    LPDWORD lpWritten,		/* Returns number of bytes written */ 
    LPOVERLAPPED osPtr )	/* OVERLAPPED structure */
{
    int result;

    /*
     * Perform overlapped blocking write. 
     *  1. Reset the overlapped event
     *  2. Remove these bytes from the output queue counter
     *  3. Start overlapped write operation
     *  3. Remove these bytes from the output queue counter
     *  4. Wait for completion
     *  5. Adjust the output queue counter
     */

    ResetEvent(osPtr->hEvent);

    EnterCriticalSection(&infoPtr->csWrite);
    infoPtr->writeQueue -= bufSize;

    /* 
     * Set Offset to ZERO, otherwise NT4.0 may report an error 
     */

    osPtr->Offset = osPtr->OffsetHigh = 0;
    result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr);
    LeaveCriticalSection(&infoPtr->csWrite);

    if (result == FALSE) {
	int err = GetLastError();

	switch (err) {
	case ERROR_IO_PENDING:

	    /* Write is pending, wait for completion */


	    if (!GetOverlappedResult(infoPtr->handle, osPtr, lpWritten,
		    TRUE)) {
		return FALSE;
	    }
	    break;
	case ERROR_COUNTER_TIMEOUT:

	    /* Write timeout handled in SerialOutputProc */


	    break;
	default:

	    /* WriteFile failed, but it isn't delayed. Report error */


	    return FALSE;
	}
    } else {

	/* WriteFile completed immediately. */

    }

    EnterCriticalSection(&infoPtr->csWrite);
    infoPtr->writeQueue += (*lpWritten - bufSize);
    LeaveCriticalSection(&infoPtr->csWrite);

    return TRUE;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns
 *	count of how many bytes were actually read, and an error
 *	indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
SerialInputProc(
    ClientData instanceData,	/* Serial state. */
    char *buf,			/* Where to store data read. */
    int bufSize,		/* How much space is available
				 * in the buffer? */
    int *errorCode)		/* Where to store error code. */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    DWORD bytesRead = 0;
    COMSTAT cStat;

    *errorCode = 0;

    /*
     * Check if there is a CommError pending from SerialCheckProc
     */

    if (infoPtr->error & SERIAL_READ_ERRORS) {
	goto commError;
    }

    /*
     * Look for characters already pending in windows queue.
     * This is the mainly restored good old code from Tcl8.0
     */

    if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) {
	/*
	 * Check for errors here, but not in the evSetup/Check procedures
	 */

	if (infoPtr->error & SERIAL_READ_ERRORS) {
	    goto commError;
	}
	if (infoPtr->flags & SERIAL_ASYNC) {
	    /*
	     * NON_BLOCKING mode:
	     * Avoid blocking by reading more bytes than available
	     * in input buffer
	     */

	    if (cStat.cbInQue > 0) {
		if ((DWORD) bufSize > cStat.cbInQue) {
		    bufSize = cStat.cbInQue;
		}
	    } else {
		errno = *errorCode = EAGAIN;
		return -1;
	    }
	} else {
	    /*
	     * BLOCKING mode:
	     * Tcl trys to read a full buffer of 4 kBytes here
	     */

	    if (cStat.cbInQue > 0) {
		if ((DWORD) bufSize > cStat.cbInQue) {
		    bufSize = cStat.cbInQue;
		}
	    } else {
		bufSize = 1;
	    }
	}
    }

    if (bufSize == 0) {
	return bytesRead = 0;
    }

    /*
     * Perform blocking read. Doesn't block in non-blocking mode, 
     * because we checked the number of available bytes.
     */

    if (blockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
	    &infoPtr->osRead) == FALSE) {

	goto error;

    }
    return bytesRead;

  error:
    TclWinConvertError(GetLastError());
    *errorCode = errno;
    return -1;

  commError:
    infoPtr->lastError = infoPtr->error;/* save last error code */

    infoPtr->error = 0;			/* reset error code */
    *errorCode = EIO;			/* to return read-error only once */
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of
 *	how many characters were actually written, and an error
 *	indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an
 *	error indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
SerialOutputProc(
    ClientData instanceData,	/* Serial state. */
    CONST char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCode)		/* Where to store error code. */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /*
     * At EXIT Tcl trys to flush all open channels in blocking mode.
     * We avoid blocking output after ExitProc or CloseHandler(chan)
     * has been called by checking the corrresponding variables.
     */

    if (!initialized || TclInExit()) {
	return toWrite;
    }

    /*
     * Check if there is a CommError pending from SerialCheckProc
     */

    if (infoPtr->error & SERIAL_WRITE_ERRORS) {
	infoPtr->lastError = infoPtr->error;	/* save last error code */

	infoPtr->error = 0;			/* reset error code */
	errno = EIO;
	goto error;
    }

    timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete
	 * and the channel is in non-blocking mode.
	 */

	errno = EWOULDBLOCK;
	goto error1;
    }

    /*







|
<



















|
|












|



|



|





|







>
|
>
>

|
>
|
>
>





>
|
>









|
|
<
















|
|




|












>
|
|

>






>


>
|
>
>






>
|
>
>


>
|
>
>



>
|
>














|
|
<















|
|

















|
|




|







|
<
|












<
|

















|
|

>


>
|
>



<
<
<
<
<

|
>
|
|








|
|
<


|
|




















|
|
|











|
>
|







|
|







700
701
702
703
704
705
706
707

708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791

792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882

883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931

932
933
934
935
936
937
938
939
940
941
942
943
944

945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974





975
976
977
978
979
980
981
982
983
984
985
986
987
988
989

990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
	if (infoPtr == (SerialInfo *)serialPtr) {
	    *nextPtrPtr = infoPtr->nextPtr;
	    break;
	}
    }

    /*
     * Wrap the error file into a channel and give it to the cleanup routine.

     */

    if (serialPtr->writeBuf != NULL) {
	ckfree(serialPtr->writeBuf);
	serialPtr->writeBuf = NULL;
    }
    ckfree((char*) serialPtr);

    if (errorCode == 0) {
	return result;
    }
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * blockingRead --
 *
 *	Perform a blocking read into the buffer given. Returns count of how
 *	many bytes were actually read, and an error indication.
 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
blockingRead(
    SerialInfo *infoPtr,	/* Serial info structure */
    LPVOID buf,			/* The input buffer pointer */
    DWORD  bufSize,		/* The number of bytes to read */
    LPDWORD  lpRead,		/* Returns number of bytes read */
    LPOVERLAPPED osPtr )	/* OVERLAPPED structure */
{
    /*
     *  Perform overlapped blocking read.
     *  1. Reset the overlapped event
     *  2. Start overlapped read operation
     *  3. Wait for completion
     */

    /*
     * Set Offset to ZERO, otherwise NT4.0 may report an error.
     */

    osPtr->Offset = osPtr->OffsetHigh = 0;
    ResetEvent(osPtr->hEvent);
    if (!ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr)) {
	if (GetLastError() != ERROR_IO_PENDING) {
	    /*
	     * ReadFile failed, but it isn't delayed. Report error.
	     */

	    return FALSE;
	} else {
	    /*
	     * Read is pending, wait for completion, timeout?
	     */

	    if (!GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE)) {
		return FALSE;
	    }
	}
    } else {
	/*
	 * ReadFile completed immediately.
	 */
    }
    return TRUE;
}

/*
 *----------------------------------------------------------------------
 *
 * blockingWrite --
 *
 *	Perform a blocking write from the buffer given. Returns count of how
 *	many bytes were actually written, and an error indication.

 *
 * Results:
 *	A count of how many bytes were written is returned and an error
 *	indication is returned.
 *
 * Side effects:
 *	Writes output to the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
blockingWrite(
    SerialInfo *infoPtr,	/* Serial info structure */
    LPVOID  buf,		/* The output buffer pointer */
    DWORD   bufSize,		/* The number of bytes to write */
    LPDWORD lpWritten,		/* Returns number of bytes written */
    LPOVERLAPPED osPtr)		/* OVERLAPPED structure */
{
    int result;

    /*
     * Perform overlapped blocking write.
     *  1. Reset the overlapped event
     *  2. Remove these bytes from the output queue counter
     *  3. Start overlapped write operation
     *  3. Remove these bytes from the output queue counter
     *  4. Wait for completion
     *  5. Adjust the output queue counter
     */

    ResetEvent(osPtr->hEvent);

    EnterCriticalSection(&infoPtr->csWrite);
    infoPtr->writeQueue -= bufSize;

    /*
     * Set Offset to ZERO, otherwise NT4.0 may report an error
     */

    osPtr->Offset = osPtr->OffsetHigh = 0;
    result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr);
    LeaveCriticalSection(&infoPtr->csWrite);

    if (result == FALSE) {
	int err = GetLastError();

	switch (err) {
	case ERROR_IO_PENDING:
	    /*
	     * Write is pending, wait for completion.
	     */

	    if (!GetOverlappedResult(infoPtr->handle, osPtr, lpWritten,
		    TRUE)) {
		return FALSE;
	    }
	    break;
	case ERROR_COUNTER_TIMEOUT:
	    /*
	     * Write timeout handled in SerialOutputProc.
	     */

	    break;
	default:
	    /*
	     * WriteFile failed, but it isn't delayed. Report error.
	     */

	    return FALSE;
	}
    } else {
	/*
	 * WriteFile completed immediately.
	 */
    }

    EnterCriticalSection(&infoPtr->csWrite);
    infoPtr->writeQueue += (*lpWritten - bufSize);
    LeaveCriticalSection(&infoPtr->csWrite);

    return TRUE;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialInputProc --
 *
 *	Reads input from the IO channel into the buffer given. Returns count
 *	of how many bytes were actually read, and an error indication.

 *
 * Results:
 *	A count of how many bytes were read is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Reads input from the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
SerialInputProc(
    ClientData instanceData,	/* Serial state. */
    char *buf,			/* Where to store data read. */
    int bufSize,		/* How much space is available in the
				 * buffer? */
    int *errorCode)		/* Where to store error code. */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    DWORD bytesRead = 0;
    COMSTAT cStat;

    *errorCode = 0;

    /*
     * Check if there is a CommError pending from SerialCheckProc
     */

    if (infoPtr->error & SERIAL_READ_ERRORS) {
	goto commError;
    }

    /*
     * Look for characters already pending in windows queue. This is the
     * mainly restored good old code from Tcl8.0
     */

    if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) {
	/*
	 * Check for errors here, but not in the evSetup/Check procedures.
	 */

	if (infoPtr->error & SERIAL_READ_ERRORS) {
	    goto commError;
	}
	if (infoPtr->flags & SERIAL_ASYNC) {
	    /*
	     * NON_BLOCKING mode: Avoid blocking by reading more bytes than

	     * available in input buffer.
	     */

	    if (cStat.cbInQue > 0) {
		if ((DWORD) bufSize > cStat.cbInQue) {
		    bufSize = cStat.cbInQue;
		}
	    } else {
		errno = *errorCode = EAGAIN;
		return -1;
	    }
	} else {
	    /*

	     * BLOCKING mode: Tcl trys to read a full buffer of 4 kBytes here.
	     */

	    if (cStat.cbInQue > 0) {
		if ((DWORD) bufSize > cStat.cbInQue) {
		    bufSize = cStat.cbInQue;
		}
	    } else {
		bufSize = 1;
	    }
	}
    }

    if (bufSize == 0) {
	return bytesRead = 0;
    }

    /*
     * Perform blocking read. Doesn't block in non-blocking mode, because we
     * checked the number of available bytes.
     */

    if (blockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
	    &infoPtr->osRead) == FALSE) {
	TclWinConvertError(GetLastError());
	*errorCode = errno;
	return -1;
    }
    return bytesRead;






  commError:
    infoPtr->lastError = infoPtr->error;
				/* save last error code */
    infoPtr->error = 0;		/* reset error code */
    *errorCode = EIO;		/* to return read-error only once */
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialOutputProc --
 *
 *	Writes the given output on the IO channel. Returns count of how many
 *	characters were actually written, and an error indication.

 *
 * Results:
 *	A count of how many characters were written is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
SerialOutputProc(
    ClientData instanceData,	/* Serial state. */
    CONST char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCode)		/* Where to store error code. */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /*
     * At EXIT Tcl trys to flush all open channels in blocking mode. We avoid
     * blocking output after ExitProc or CloseHandler(chan) has been called by
     * checking the corrresponding variables.
     */

    if (!initialized || TclInExit()) {
	return toWrite;
    }

    /*
     * Check if there is a CommError pending from SerialCheckProc
     */

    if (infoPtr->error & SERIAL_WRITE_ERRORS) {
	infoPtr->lastError = infoPtr->error;
				/* save last error code */
	infoPtr->error = 0;	/* reset error code */
	errno = EIO;
	goto error;
    }

    timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EWOULDBLOCK;
	goto error1;
    }

    /*
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061

    EnterCriticalSection(&infoPtr->csWrite);
    infoPtr->writeQueue += toWrite;
    LeaveCriticalSection(&infoPtr->csWrite);

    if (infoPtr->flags & SERIAL_ASYNC) {
	/*
	 * The serial is non-blocking, so copy the data into the output
	 * buffer and restart the writer thread.
	 */

	if (toWrite > infoPtr->writeBufLen) {
	    /*
	     * Reallocate the buffer to be large enough to hold the data.
	     */








|
|







1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074

    EnterCriticalSection(&infoPtr->csWrite);
    infoPtr->writeQueue += toWrite;
    LeaveCriticalSection(&infoPtr->csWrite);

    if (infoPtr->flags & SERIAL_ASYNC) {
	/*
	 * The serial is non-blocking, so copy the data into the output buffer
	 * and restart the writer thread.
	 */

	if (toWrite > infoPtr->writeBufLen) {
	    /*
	     * Reallocate the buffer to be large enough to hold the data.
	     */

1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084

1085

1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
	infoPtr->toWrite = toWrite;
	ResetEvent(infoPtr->evWritable);
	SetEvent(infoPtr->evStartWriter);
	bytesWritten = (DWORD) toWrite;

    } else {
	/*
	 * In the blocking case, just try to write the buffer directly.
	 * This avoids an unnecessary copy.
	 */

	if (!blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
		&bytesWritten, &infoPtr->osWrite)) {
	    goto writeError;
	}
	if (bytesWritten != (DWORD) toWrite) {

	    /* Write timeout */

	    infoPtr->lastError |= CE_PTO;
	    errno = EIO;
	    goto error;
	}
    }

    return (int) bytesWritten;

  writeError:
    TclWinConvertError(GetLastError());

  error:
    /* 
     * Reset the output queue counter on error during blocking output 
     */

    /*
     * EnterCriticalSection(&infoPtr->csWrite);
     * infoPtr->writeQueue = 0;
     * LeaveCriticalSection(&infoPtr->csWrite);
     */
  error1: 
    *errorCode = errno;
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event
 *	reaches the front of the event queue.  This procedure invokes
 *	Tcl_NotifyChannel on the serial.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be
 *	removed from the queue.  Returns 0 if the event was not
 *	handled, meaning it should stay on the queue.  The only time
 *	the event isn't handled is if the TCL_FILE_EVENTS flag bit
 *	isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

static int
SerialEventProc(
    Tcl_Event *evPtr,	/* Event to service. */
    int flags)		/* Flags that indicate what events to
			 * handle, such as TCL_FILE_EVENTS. */
{
    SerialEvent *serialEvPtr = (SerialEvent *)evPtr;
    SerialInfo *infoPtr;
    int mask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched serials for the one whose handle
     * matches the event.  We do this rather than simply dereferencing
     * the handle in the event so that serials can be deleted while the
     * event is in the queue.
     */

    for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (serialEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(SERIAL_PENDING);
	    break;
	}
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the serial is readable.  Note
     * that we can't tell if a serial is writable, so we always report it
     * as being writable unless we have detected EOF.
     */

    mask = 0;
    if (infoPtr->watchMask & TCL_WRITABLE) {
	if (infoPtr->writable) {
	    mask |= TCL_WRITABLE;
	    infoPtr->writable = 0;







|
|







>
|
>












|
|







|









|
|
|


|
|
<
|
|










|
|












|
|
|



















|
|
|







1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138

1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
	infoPtr->toWrite = toWrite;
	ResetEvent(infoPtr->evWritable);
	SetEvent(infoPtr->evStartWriter);
	bytesWritten = (DWORD) toWrite;

    } else {
	/*
	 * In the blocking case, just try to write the buffer directly. This
	 * avoids an unnecessary copy.
	 */

	if (!blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
		&bytesWritten, &infoPtr->osWrite)) {
	    goto writeError;
	}
	if (bytesWritten != (DWORD) toWrite) {
	    /*
	     * Write timeout.
	     */
	    infoPtr->lastError |= CE_PTO;
	    errno = EIO;
	    goto error;
	}
    }

    return (int) bytesWritten;

  writeError:
    TclWinConvertError(GetLastError());

  error:
    /*
     * Reset the output queue counter on error during blocking output
     */

    /*
     * EnterCriticalSection(&infoPtr->csWrite);
     * infoPtr->writeQueue = 0;
     * LeaveCriticalSection(&infoPtr->csWrite);
     */
  error1:
    *errorCode = errno;
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialEventProc --
 *
 *	This function is invoked by Tcl_ServiceEvent when a file event reaches
 *	the front of the event queue. This procedure invokes Tcl_NotifyChannel
 *	on the serial.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should

 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the notifier callback does.
 *
 *----------------------------------------------------------------------
 */

static int
SerialEventProc(
    Tcl_Event *evPtr,	/* Event to service. */
    int flags)		/* Flags that indicate what events to handle, such as
			 * TCL_FILE_EVENTS. */
{
    SerialEvent *serialEvPtr = (SerialEvent *)evPtr;
    SerialInfo *infoPtr;
    int mask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched serials for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that serials can be deleted while the event is
     * in the queue.
     */

    for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (serialEvPtr->infoPtr == infoPtr) {
	    infoPtr->flags &= ~(SERIAL_PENDING);
	    break;
	}
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the serial is readable. Note that we can't tell if a
     * serial is writable, so we always report it as being writable unless we
     * have detected EOF.
     */

    mask = 0;
    if (infoPtr->watchMask & TCL_WRITABLE) {
	if (infoPtr->writable) {
	    mask |= TCL_WRITABLE;
	    infoPtr->writable = 0;
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
}

/*
 *----------------------------------------------------------------------
 *
 * SerialWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this
 *	channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
SerialWatchProc(
    ClientData instanceData,	/* Serial state. */
    int mask)			/* What events to watch for, OR-ed
				 * combination of TCL_READABLE,
				 * TCL_WRITABLE and TCL_EXCEPTION. */
{
    SerialInfo **nextPtrPtr, *ptr;
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    int oldMask = infoPtr->watchMask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Since the file is always ready for events, we set the block time
     * so we will poll.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstSerialPtr;
	    tsdPtr->firstSerialPtr = infoPtr;







|
<













|
|
|







|
|







1213
1214
1215
1216
1217
1218
1219
1220

1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
}

/*
 *----------------------------------------------------------------------
 *
 * SerialWatchProc --
 *
 *	Called by the notifier to set up to watch for events on this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
SerialWatchProc(
    ClientData instanceData,	/* Serial state. */
    int mask)			/* What events to watch for, OR-ed combination
				 * of TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    SerialInfo **nextPtrPtr, *ptr;
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    int oldMask = infoPtr->watchMask;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Since the file is always ready for events, we set the block time so we
     * will poll.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstSerialPtr;
	    tsdPtr->firstSerialPtr = infoPtr;
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318

1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361

1362


1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386






1387

1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470










1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
}

/*
 *----------------------------------------------------------------------
 *
 * SerialGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from
 *	inside a command serial port based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
 *	there is no handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
SerialGetHandleProc(
    ClientData instanceData,	/* The serial state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr)	/* Where to store the handle.  */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    *handlePtr = (ClientData) infoPtr->handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialWriterThread --
 *
 *      This function runs in a separate thread and writes data
 *      onto a serial.
 *
 * Results:
 *      Always returns 0.
 *
 * Side effects:
 *      Signals the main thread when an output operation is completed.
 *      May cause the main thread to wake up by posting a message.  
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
SerialWriterThread(LPVOID arg)
{

    SerialInfo *infoPtr = (SerialInfo *)arg;
    DWORD bytesWritten, toWrite, waitResult;
    char *buf;
    OVERLAPPED myWrite; /* have an own OVERLAPPED in this thread */
    HANDLE wEvents[2];

    /*
     * The stop event takes precedence by being first in the list.
     */

    wEvents[0] = infoPtr->evStopWriter;
    wEvents[1] = infoPtr->evStartWriter;

    for (;;) {
	/*
	 * Wait for the main thread to signal before attempting to write.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled.  It might be the stop event
	     * or an error, so exit.
	     */

	    break;
	}

	buf = infoPtr->writeBuf;
	toWrite = infoPtr->toWrite;

	myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);

	/*
	 * Loop until all of the bytes are written or an error occurs.
	 */

	while (toWrite > 0) {
	    /*
	     *  Check for pending writeError.  Ignore all write
	     *  operations until the user has been notified
	     */

	    if (infoPtr->writeError) {
		break;
	    }
	    if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, 
		    &bytesWritten, &myWrite) == FALSE) {
		infoPtr->writeError = GetLastError();
		break;
	    }
	    if (bytesWritten != toWrite) {

		/* Write timeout */


		infoPtr->writeError = ERROR_WRITE_FAULT;
		break;
	    }
	    toWrite -= bytesWritten;
	    buf += bytesWritten;
	}

	CloseHandle(myWrite.hEvent);

	/*
	 * Signal the main thread by signalling the evWritable event
	 * and then waking up the notifier thread.
	 */

	SetEvent(infoPtr->evWritable);

	/*
	 * Alert the foreground thread.  Note that we need to treat
	 * this like a critical section so the foreground thread does
	 * not terminate this thread while we are holding a mutex in
	 * the notifier code.
	 */

	Tcl_MutexLock(&serialMutex);






	Tcl_ThreadAlert(infoPtr->threadId);

	Tcl_MutexUnlock(&serialMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinSerialReopen --
 *
 *	Reopens the serial port with the OVERLAPPED FLAG set
 *
 * Results:
 *	Returns the new handle, or INVALID_HANDLE_VALUE.  Normally
 *	there shouldn't be any error, because the same channel has
 *	previously been succeesfully opened.
 *
 * Side effects:
 *	May close the original handle
 *
 *----------------------------------------------------------------------
 */

HANDLE
TclWinSerialReopen(handle, name, access)
    HANDLE handle;
    CONST TCHAR *name;
    DWORD access;
{
    ThreadSpecificData *tsdPtr;

    tsdPtr = SerialInit();

    /* 
     * Multithreaded I/O needs the overlapped flag set
     * otherwise ClearCommError blocks under Windows NT/2000 until serial
     * output is finished
     */

    if (CloseHandle(handle) == FALSE) {
	return INVALID_HANDLE_VALUE;
    }
    handle = (*tclWinProcs->createFileProc)(name, access, 0, 0,
	    OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
    return handle;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenSerialChannel --
 *
 *	Constructs a Serial port channel for the specified standard OS
 *	handle.  This is a helper function to break up the
 *	construction of channels into File, Console, or Serial.
 *
 * Results:
 *	Returns the new channel, or NULL.
 *
 * Side effects:
 *	May open the channel
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclWinOpenSerialChannel(handle, channelName, permissions)
    HANDLE handle;
    char *channelName;
    int permissions;
{
    SerialInfo *infoPtr;
    ThreadSpecificData *tsdPtr;
    DWORD id;

    tsdPtr = SerialInit();

    infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
    memset(infoPtr, 0, sizeof(SerialInfo));

    infoPtr->validMask = permissions;
    infoPtr->handle = handle;











    /*
     * Use the pointer to keep the channel names unique, in case
     * the handles are shared between multiple channels (stdin/stdout).
     */

    wsprintfA(channelName, "file%lx", (int) infoPtr);

    infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
	    (ClientData) infoPtr, permissions);

    infoPtr->readable = 0; 
    infoPtr->writable = 1;
    infoPtr->toWrite = infoPtr->writeQueue = 0;
    infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
    infoPtr->lastEventTime = 0;
    infoPtr->lastError = infoPtr->error = 0;
    infoPtr->threadId = Tcl_GetCurrentThread();
    infoPtr->sysBufRead = infoPtr->sysBufWrite = 4096;

    SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite);
    PurgeComm(handle,
	    PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR);

    /*
     * default is blocking
     */

    SetCommTimeouts(handle, &no_timeout);

    if (permissions & TCL_READABLE) {
	infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
    }
    if (permissions & TCL_WRITABLE) {
	/* 
	 * Initially the channel is writable
	 * and the writeThread is idle.
	 */

	infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
	infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->evStopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	InitializeCriticalSection(&infoPtr->csWrite);
	infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread,
		infoPtr, 0, &id);
    }

    /*
     * Files have default translation of AUTO and ^Z eof char, which
     * means that a ^Z will be accepted as EOF when reading.
     */

    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialErrorStr --
 *
 *	Converts a Win32 serial error code to a list of readable errors
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Generates readable errors in the supplied DString.
 *
 *----------------------------------------------------------------------
 */

static void
SerialErrorStr(error, dsPtr)
    DWORD error;		/* Win32 serial error code */
    Tcl_DString *dsPtr;		/* Where to store string */
{
    if (error & CE_RXOVER) {
	Tcl_DStringAppendElement(dsPtr, "RXOVER");
    }
    if (error & CE_OVERRUN) {
	Tcl_DStringAppendElement(dsPtr, "OVERRUN");
    }
    if (error & CE_RXPARITY) {
	Tcl_DStringAppendElement(dsPtr, "RXPARITY");
    }
    if (error & CE_FRAME) {
	Tcl_DStringAppendElement(dsPtr, "FRAME");
    }
    if (error & CE_BREAK) {
	Tcl_DStringAppendElement(dsPtr, "BREAK");
    }
    if (error & CE_TXFULL) {
	Tcl_DStringAppendElement(dsPtr, "TXFULL");
    }
    if (error & CE_PTO) {		/* PTO used to signal WRITE-TIMEOUT */
	Tcl_DStringAppendElement(dsPtr, "TIMEOUT");
    }
    if (error & ~((DWORD) (SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS))) {
	char buf[TCL_INTEGER_SPACE + 1];

	wsprintfA(buf, "%d", error);
	Tcl_DStringAppendElement(dsPtr, buf);







|
|


|
|











|












|
<


|


|
|







<



|





>












|
|
















|
|





|





>
|
>
>










|
|





|
|
|
<



>
>
>
>
>
>
|
>














|
|
|

















|
|
|
|















|
|
|

















<


|






>
>
>
>
>
>
>
>
>
>


|
|







<
<
<
<
<
<
<
<






|








|
|
<












|
|













|












|
|



















|







1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306

1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320

1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397

1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481

1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511








1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528

1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
}

/*
 *----------------------------------------------------------------------
 *
 * SerialGetHandleProc --
 *
 *	Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
 *	command serial port based channel.
 *
 * Results:
 *	Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
 *	handle for the specified direction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
SerialGetHandleProc(
    ClientData instanceData,	/* The serial state. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE */
    ClientData *handlePtr)	/* Where to store the handle. */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    *handlePtr = (ClientData) infoPtr->handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialWriterThread --
 *
 *	This function runs in a separate thread and writes data onto a serial.

 *
 * Results:
 *	Always returns 0.
 *
 * Side effects:
 *	Signals the main thread when an output operation is completed. May
 *	cause the main thread to wake up by posting a message.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
SerialWriterThread(LPVOID arg)
{

    SerialInfo *infoPtr = (SerialInfo *)arg;
    DWORD bytesWritten, toWrite, waitResult;
    char *buf;
    OVERLAPPED myWrite;		/* Have an own OVERLAPPED in this thread. */
    HANDLE wEvents[2];

    /*
     * The stop event takes precedence by being first in the list.
     */

    wEvents[0] = infoPtr->evStopWriter;
    wEvents[1] = infoPtr->evStartWriter;

    for (;;) {
	/*
	 * Wait for the main thread to signal before attempting to write.
	 */

	waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);

	if (waitResult != (WAIT_OBJECT_0 + 1)) {
	    /*
	     * The start event was not signaled. It might be the stop event or
	     * an error, so exit.
	     */

	    break;
	}

	buf = infoPtr->writeBuf;
	toWrite = infoPtr->toWrite;

	myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);

	/*
	 * Loop until all of the bytes are written or an error occurs.
	 */

	while (toWrite > 0) {
	    /*
	     * Check for pending writeError. Ignore all write operations until
	     * the user has been notified.
	     */

	    if (infoPtr->writeError) {
		break;
	    }
	    if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
		    &bytesWritten, &myWrite) == FALSE) {
		infoPtr->writeError = GetLastError();
		break;
	    }
	    if (bytesWritten != toWrite) {
		/*
		 * Write timeout.
		 */

		infoPtr->writeError = ERROR_WRITE_FAULT;
		break;
	    }
	    toWrite -= bytesWritten;
	    buf += bytesWritten;
	}

	CloseHandle(myWrite.hEvent);

	/*
	 * Signal the main thread by signalling the evWritable event and then
	 * waking up the notifier thread.
	 */

	SetEvent(infoPtr->evWritable);

	/*
	 * Alert the foreground thread. Note that we need to treat this like a
	 * critical section so the foreground thread does not terminate this
	 * thread while we are holding a mutex in the notifier code.

	 */

	Tcl_MutexLock(&serialMutex);
	if (infoPtr->threadId != NULL) {
	    /*
	     * TIP #218: When in flight ignore the event, no one will receive
	     * it anyway.
	     */

	    Tcl_ThreadAlert(infoPtr->threadId);
	}
	Tcl_MutexUnlock(&serialMutex);
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinSerialReopen --
 *
 *	Reopens the serial port with the OVERLAPPED FLAG set
 *
 * Results:
 *	Returns the new handle, or INVALID_HANDLE_VALUE. Normally there
 *	shouldn't be any error, because the same channel has previously been
 *	succeesfully opened.
 *
 * Side effects:
 *	May close the original handle
 *
 *----------------------------------------------------------------------
 */

HANDLE
TclWinSerialReopen(handle, name, access)
    HANDLE handle;
    CONST TCHAR *name;
    DWORD access;
{
    ThreadSpecificData *tsdPtr;

    tsdPtr = SerialInit();

    /*
     * Multithreaded I/O needs the overlapped flag set otherwise
     * ClearCommError blocks under Windows NT/2000 until serial output is
     * finished
     */

    if (CloseHandle(handle) == FALSE) {
	return INVALID_HANDLE_VALUE;
    }
    handle = (*tclWinProcs->createFileProc)(name, access, 0, 0,
	    OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
    return handle;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinOpenSerialChannel --
 *
 *	Constructs a Serial port channel for the specified standard OS handle.
 *	This is a helper function to break up the construction of channels
 *	into File, Console, or Serial.
 *
 * Results:
 *	Returns the new channel, or NULL.
 *
 * Side effects:
 *	May open the channel
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclWinOpenSerialChannel(handle, channelName, permissions)
    HANDLE handle;
    char *channelName;
    int permissions;
{
    SerialInfo *infoPtr;

    DWORD id;

    SerialInit();

    infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
    memset(infoPtr, 0, sizeof(SerialInfo));

    infoPtr->validMask = permissions;
    infoPtr->handle = handle;
    infoPtr->channel = (Tcl_Channel) NULL;
    infoPtr->readable = 0;
    infoPtr->writable = 1;
    infoPtr->toWrite = infoPtr->writeQueue = 0;
    infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
    infoPtr->lastEventTime = 0;
    infoPtr->lastError = infoPtr->error = 0;
    infoPtr->threadId = Tcl_GetCurrentThread();
    infoPtr->sysBufRead = 4096;
    infoPtr->sysBufWrite = 4096;

    /*
     * Use the pointer to keep the channel names unique, in case the handles
     * are shared between multiple channels (stdin/stdout).
     */

    wsprintfA(channelName, "file%lx", (int) infoPtr);

    infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
	    (ClientData) infoPtr, permissions);










    SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite);
    PurgeComm(handle,
	    PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR);

    /*
     * Default is blocking.
     */

    SetCommTimeouts(handle, &no_timeout);

    if (permissions & TCL_READABLE) {
	infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
    }
    if (permissions & TCL_WRITABLE) {
	/*
	 * Initially the channel is writable and the writeThread is idle.

	 */

	infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
	infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL);
	infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	infoPtr->evStopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
	InitializeCriticalSection(&infoPtr->csWrite);
	infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread,
		infoPtr, 0, &id);
    }

    /*
     * Files have default translation of AUTO and ^Z eof char, which means
     * that a ^Z will be accepted as EOF when reading.
     */

    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
    Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialErrorStr --
 *
 *	Converts a Win32 serial error code to a list of readable errors.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Generates readable errors in the supplied DString.
 *
 *----------------------------------------------------------------------
 */

static void
SerialErrorStr(error, dsPtr)
    DWORD error;		/* Win32 serial error code. */
    Tcl_DString *dsPtr;		/* Where to store string. */
{
    if (error & CE_RXOVER) {
	Tcl_DStringAppendElement(dsPtr, "RXOVER");
    }
    if (error & CE_OVERRUN) {
	Tcl_DStringAppendElement(dsPtr, "OVERRUN");
    }
    if (error & CE_RXPARITY) {
	Tcl_DStringAppendElement(dsPtr, "RXPARITY");
    }
    if (error & CE_FRAME) {
	Tcl_DStringAppendElement(dsPtr, "FRAME");
    }
    if (error & CE_BREAK) {
	Tcl_DStringAppendElement(dsPtr, "BREAK");
    }
    if (error & CE_TXFULL) {
	Tcl_DStringAppendElement(dsPtr, "TXFULL");
    }
    if (error & CE_PTO) {	/* PTO used to signal WRITE-TIMEOUT */
	Tcl_DStringAppendElement(dsPtr, "TIMEOUT");
    }
    if (error & ~((DWORD) (SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS))) {
	char buf[TCL_INTEGER_SPACE + 1];

	wsprintfA(buf, "%d", error);
	Tcl_DStringAppendElement(dsPtr, buf);
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
 *	Appends modem status flag strings to the given DString.
 *
 *----------------------------------------------------------------------
 */

static void
SerialModemStatusStr(status, dsPtr)
    DWORD status;		/* Win32 modem status */
    Tcl_DString *dsPtr;		/* Where to store string */
{
    Tcl_DStringAppendElement(dsPtr, "CTS");
    Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON)  ?  "1" : "0");
    Tcl_DStringAppendElement(dsPtr, "DSR");
    Tcl_DStringAppendElement(dsPtr, (status & MS_DSR_ON)   ? "1" : "0");
    Tcl_DStringAppendElement(dsPtr, "RING");
    Tcl_DStringAppendElement(dsPtr, (status & MS_RING_ON)  ? "1" : "0");
    Tcl_DStringAppendElement(dsPtr, "DCD");
    Tcl_DStringAppendElement(dsPtr, (status & MS_RLSD_ON)  ? "1" : "0");
}

/*
 *----------------------------------------------------------------------
 *
 * SerialSetOptionProc --
 *
 *	Sets an option on a channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the interp's result on error
 *	if interp is not NULL.
 *
 * Side effects:
 *	May modify an option on a device.
 *
 *----------------------------------------------------------------------
 */








|
|



















|
|







1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
 *	Appends modem status flag strings to the given DString.
 *
 *----------------------------------------------------------------------
 */

static void
SerialModemStatusStr(status, dsPtr)
    DWORD status;		/* Win32 modem status. */
    Tcl_DString *dsPtr;		/* Where to store string. */
{
    Tcl_DStringAppendElement(dsPtr, "CTS");
    Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON)  ?  "1" : "0");
    Tcl_DStringAppendElement(dsPtr, "DSR");
    Tcl_DStringAppendElement(dsPtr, (status & MS_DSR_ON)   ? "1" : "0");
    Tcl_DStringAppendElement(dsPtr, "RING");
    Tcl_DStringAppendElement(dsPtr, (status & MS_RING_ON)  ? "1" : "0");
    Tcl_DStringAppendElement(dsPtr, "DCD");
    Tcl_DStringAppendElement(dsPtr, (status & MS_RLSD_ON)  ? "1" : "0");
}

/*
 *----------------------------------------------------------------------
 *
 * SerialSetOptionProc --
 *
 *	Sets an option on a channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the interp's result on error if
 *	interp is not NULL.
 *
 * Side effects:
 *	May modify an option on a device.
 *
 *----------------------------------------------------------------------
 */

1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
    Tcl_DString ds;
    CONST TCHAR *native;
    int argc;
    CONST char **argv;

    infoPtr = (SerialInfo *) instanceData;

    /* 
     * Parse options.  This would be far easier if we had Tcl_Objs to
     * work with as that would let us use Tcl_GetIndexFromObj()...
     */

    len = strlen(optionName);
    vlen = strlen(value);

    /* 
     * Option -mode baud,parity,databits,stopbits
     */

    if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state", (char *)NULL);







|
|
|





|







1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
    Tcl_DString ds;
    CONST TCHAR *native;
    int argc;
    CONST char **argv;

    infoPtr = (SerialInfo *) instanceData;

    /*
     * Parse options. This would be far easier if we had Tcl_Objs to work with
     * as that would let us use Tcl_GetIndexFromObj()...
     */

    len = strlen(optionName);
    vlen = strlen(value);

    /*
     * Option -mode baud,parity,databits,stopbits
     */

    if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state", (char *)NULL);
1671
1672
1673
1674
1675
1676
1677

1678


1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724

1725

1726
1727
1728
1729
1730
1731
1732
		Tcl_AppendResult(interp,
			"bad value for -mode: should be baud,parity,data,stop",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}


	/* Default settings for serial communications */ 


	dcb.fBinary = TRUE;
	dcb.fErrorChar = FALSE;
	dcb.fNull = FALSE;
	dcb.fAbortOnError = FALSE;

	if (!SetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't set comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /* 
     * Option -handshake none|xonxoff|rtscts|dtrdsr
     */

    if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}

	/*
	 * Reset all handshake options
	 * DTR and RTS are ON by default
	 */

	dcb.fOutX = dcb.fInX = FALSE;
	dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE;
	dcb.fDtrControl = DTR_CONTROL_ENABLE;
	dcb.fRtsControl = RTS_CONTROL_ENABLE;
	dcb.fTXContinueOnXoff = FALSE;

	/*
	 * Adjust the handshake limits.
	 * Yes, the XonXoff limits seem to influence even hardware handshake
	 */

	dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
	dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);

	if (strnicmp(value, "NONE", vlen) == 0) {

	    /* leave all handshake options disabled */

	} else if (strnicmp(value, "XONXOFF", vlen) == 0) {
	    dcb.fOutX = dcb.fInX = TRUE;
	} else if (strnicmp(value, "RTSCTS", vlen) == 0) {
	    dcb.fOutxCtsFlow = TRUE;
	    dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
	} else if (strnicmp(value, "DTRDSR", vlen) == 0) {
	    dcb.fOutxDsrFlow = TRUE;







>
|
>
>














|












|
<









|
|






>
|
>







1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730

1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
		Tcl_AppendResult(interp,
			"bad value for -mode: should be baud,parity,data,stop",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}

	/*
	 * Default settings for serial communications.
	 */

	dcb.fBinary = TRUE;
	dcb.fErrorChar = FALSE;
	dcb.fNull = FALSE;
	dcb.fAbortOnError = FALSE;

	if (!SetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't set comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Option -handshake none|xonxoff|rtscts|dtrdsr
     */

    if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}

	/*
	 * Reset all handshake options. DTR and RTS are ON by default.

	 */

	dcb.fOutX = dcb.fInX = FALSE;
	dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE;
	dcb.fDtrControl = DTR_CONTROL_ENABLE;
	dcb.fRtsControl = RTS_CONTROL_ENABLE;
	dcb.fTXContinueOnXoff = FALSE;

	/*
	 * Adjust the handshake limits. Yes, the XonXoff limits seem to
	 * influence even hardware handshake.
	 */

	dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
	dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);

	if (strnicmp(value, "NONE", vlen) == 0) {
	    /*
	     * Leave all handshake options disabled.
	     */
	} else if (strnicmp(value, "XONXOFF", vlen) == 0) {
	    dcb.fOutX = dcb.fInX = TRUE;
	} else if (strnicmp(value, "RTSCTS", vlen) == 0) {
	    dcb.fOutxCtsFlow = TRUE;
	    dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
	} else if (strnicmp(value, "DTRDSR", vlen) == 0) {
	    dcb.fOutxDsrFlow = TRUE;
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769

1770
1771
1772
1773
1774
1775

1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792


1793
1794
1795
1796
1797
1798
1799
1800
1801

1802
1803
1804
1805
1806

1807
1808
1809
1810
1811
1812
1813
1814
1815

1816
1817
1818
1819
1820
1821
1822
1823
1824

1825
1826
1827
1828
1829
1830
1831
1832
1833

1834
1835
1836
1837
1838
1839
1840

1841
1842
1843
1844
1845


1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857

1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869

1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
		Tcl_AppendResult(interp, "can't set comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /* 
     * Option -xchar {\x11 \x13}
     */

    if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 2) {
	    dcb.XonChar  = argv[0][0];
	    dcb.XoffChar = argv[1][0];

	} else {
	    if (interp) {
		Tcl_AppendResult(interp,
			"bad value for -xchar: should be a list of two elements",
			(char *) NULL);
	    }

	    return TCL_ERROR;
	}

	if (!SetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't set comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /* 
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {


	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp) {
		Tcl_AppendResult(interp, "bad value for -ttycontrol: ",
			"should be a list of signal,value pairs",
			(char *) NULL);
	    }

	    return TCL_ERROR;
	}
	while (argc > 1) {
	    if (Tcl_GetBoolean(interp, argv[1], &flag) == TCL_ERROR) {
		return TCL_ERROR;

	    }
	    if (strnicmp(argv[0], "DTR", strlen(argv[0])) == 0) {
		if (!EscapeCommFunction(infoPtr->handle, flag ?
			(DWORD) SETDTR : (DWORD) CLRDTR)) {
		    if (interp) {
			Tcl_AppendResult(interp, "can't set DTR signal",
				(char *) NULL);
		    }
		    return TCL_ERROR;

		}
	    } else if (strnicmp(argv[0], "RTS", strlen(argv[0])) == 0) {
		if (!EscapeCommFunction(infoPtr->handle, flag ?
			(DWORD) SETRTS : (DWORD) CLRRTS)) {
		    if (interp) {
			Tcl_AppendResult(interp, "can't set RTS signal",
				(char *) NULL);
		    }
		    return TCL_ERROR;

		}
	    } else if (strnicmp(argv[0], "BREAK", strlen(argv[0])) == 0) {
		if (!EscapeCommFunction(infoPtr->handle, flag ?
			(DWORD) SETBREAK : (DWORD) CLRBREAK)) {
		    if (interp) {
			Tcl_AppendResult(interp, "can't set BREAK signal",
				(char *) NULL);
		    }
		    return TCL_ERROR;

		}
	    } else {
		if (interp) {
		    Tcl_AppendResult(interp, "bad signal for -ttycontrol: ",
			    "must be DTR, RTS or BREAK", (char *) NULL);
		}
		return TCL_ERROR;

	    }
	    argc -= 2;
	    argv += 2;
	} /* while (argc > 1) */



	return TCL_OK;
    }

    /* 
     * Option -sysbuffer {read_size write_size}
     * Option -sysbuffer read_size 
     */

    if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) {
	/*
	 * -sysbuffer 4096 or -sysbuffer {64536 4096}
	 */

	size_t inSize = (size_t) -1, outSize = (size_t) -1;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 1) {
	    inSize = atoi(argv[0]);
	    outSize = infoPtr->sysBufWrite;
	} else if (argc == 2) {
	    inSize  = atoi(argv[0]);
	    outSize = atoi(argv[1]);
	}

	if ((inSize <= 0) || (outSize <= 0)) {
	    if (interp) {
		Tcl_AppendResult(interp, "bad value for -sysbuffer: ",
			"should be a list of one or two integers > 0",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	if (!SetupComm(infoPtr->handle, inSize, outSize)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't setup comm buffers",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	infoPtr->sysBufRead  = inSize;
	infoPtr->sysBufWrite = outSize;

	/* 
	 * Adjust the handshake limits.  Yes, the XonXoff limits seem
	 * to influence even hardware handshake
	 */

	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state",
			(char *) NULL);
	    }







|

















>


|
|
<

>












|




>
>









>


|
|
|
>

|

|

|
|

|
>

|

|

|
|

|
>

|

|

|
|

|
>






|
>

<
<
<
|
>
>
|


|

|






>












>


















|
|
|







1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799

1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875



1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
		Tcl_AppendResult(interp, "can't set comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Option -xchar {\x11 \x13}
     */

    if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 2) {
	    dcb.XonChar  = argv[0][0];
	    dcb.XoffChar = argv[1][0];
	    ckfree((char *) argv);
	} else {
	    if (interp) {
		Tcl_AppendResult(interp, "bad value for -xchar: ",
			"should be a list of two elements", (char *) NULL);

	    }
	    ckfree((char *) argv);
	    return TCL_ERROR;
	}

	if (!SetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't set comm state", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
	int i, result = TCL_OK;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp) {
		Tcl_AppendResult(interp, "bad value for -ttycontrol: ",
			"should be a list of signal,value pairs",
			(char *) NULL);
	    }
	    ckfree((char *) argv);
	    return TCL_ERROR;
	}
	for (i = 0; i < argc - 1; i += 2) {
	    if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
		result = TCL_ERROR;
		break;
	    }
	    if (strnicmp(argv[i], "DTR", strlen(argv[i])) == 0) {
		if (!EscapeCommFunction(infoPtr->handle, flag ?
			    (DWORD) SETDTR : (DWORD) CLRDTR)) {
		    if (interp) {
			Tcl_AppendResult(interp,
				"can't set DTR signal", (char *) NULL);
		    }
		    result = TCL_ERROR;
		    break;
		}
	    } else if (strnicmp(argv[i], "RTS", strlen(argv[i])) == 0) {
		if (!EscapeCommFunction(infoPtr->handle, flag ?
			    (DWORD) SETRTS : (DWORD) CLRRTS)) {
		    if (interp) {
			Tcl_AppendResult(interp,
				"can't set RTS signal", (char *) NULL);
		    }
		    result = TCL_ERROR;
		    break;
		}
	    } else if (strnicmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
		if (!EscapeCommFunction(infoPtr->handle, flag ?
			    (DWORD) SETBREAK : (DWORD) CLRBREAK)) {
		    if (interp) {
			Tcl_AppendResult(interp,
				"can't set BREAK signal", (char *) NULL);
		    }
		    result = TCL_ERROR;
		    break;
		}
	    } else {
		if (interp) {
		    Tcl_AppendResult(interp, "bad signal for -ttycontrol: ",
			    "must be DTR, RTS or BREAK", (char *) NULL);
		}
		result = TCL_ERROR;
		break;
	    }



	}

	ckfree((char *) argv);
	return result;
    }

    /*
     * Option -sysbuffer {read_size write_size}
     * Option -sysbuffer read_size
     */

    if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) {
	/*
	 * -sysbuffer 4096 or -sysbuffer {64536 4096}
	 */

	size_t inSize = (size_t) -1, outSize = (size_t) -1;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (argc == 1) {
	    inSize = atoi(argv[0]);
	    outSize = infoPtr->sysBufWrite;
	} else if (argc == 2) {
	    inSize  = atoi(argv[0]);
	    outSize = atoi(argv[1]);
	}
	ckfree((char *) argv);
	if ((inSize <= 0) || (outSize <= 0)) {
	    if (interp) {
		Tcl_AppendResult(interp, "bad value for -sysbuffer: ",
			"should be a list of one or two integers > 0",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	if (!SetupComm(infoPtr->handle, inSize, outSize)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't setup comm buffers",
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	infoPtr->sysBufRead  = inSize;
	infoPtr->sysBufWrite = outSize;

	/*
	 * Adjust the handshake limits. Yes, the XonXoff limits seem to
	 * influence even hardware handshake.
	 */

	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp) {
		Tcl_AppendResult(interp, "can't get comm state",
			(char *) NULL);
	    }
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /* 
     * Option -pollinterval msec
     */

    if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) {
	if (Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) {
	    return TCL_ERROR;
	}







|







1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
			(char *) NULL);
	    }
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Option -pollinterval msec
     */

    if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) {
	if (Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) {
	    return TCL_ERROR;
	}
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
	    return TCL_ERROR;
	}

	return TCL_OK;
    }

    return Tcl_BadChannelOption(interp, optionName,
	"mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
}

/*
 *----------------------------------------------------------------------
 *
 * SerialGetOptionProc --
 *
 *	Gets a mode associated with an IO channel. If the optionName
 *	arg is non NULL, retrieves the value of that option. If the
 *	optionName arg is NULL, retrieves a list of alternating option
 *	names and values for the given channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the supplied DString to the
 *	string value of the option(s) returned.
 *
 * Side effects:
 *	The string returned by this function is in static storage and
 *	may be reused at any time subsequent to the call.
 *
 *----------------------------------------------------------------------
 */

static int
SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	/* File state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL. */
    CONST char *optionName;	/* Option to get. */
    Tcl_DString *dsPtr;		/* Where to store value(s). */
{
    SerialInfo *infoPtr;
    DCB dcb;
    size_t len;
    int valid = 0;  /* flag if valid option parsed */

    infoPtr = (SerialInfo *) instanceData;

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }

    /*
     * get option -mode
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-mode");
    }
    if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) {
	char parity;







|







|
|
|
|


|
|


|
|














|










|







1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
	    return TCL_ERROR;
	}

	return TCL_OK;
    }

    return Tcl_BadChannelOption(interp, optionName,
	    "mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
}

/*
 *----------------------------------------------------------------------
 *
 * SerialGetOptionProc --
 *
 *	Gets a mode associated with an IO channel. If the optionName arg is
 *	non NULL, retrieves the value of that option. If the optionName arg is
 *	NULL, retrieves a list of alternating option names and values for the
 *	given channel.
 *
 * Results:
 *	A standard Tcl result. Also sets the supplied DString to the string
 *	value of the option(s) returned.
 *
 * Side effects:
 *	The string returned by this function is in static storage and may be
 *	reused at any time subsequent to the call.
 *
 *----------------------------------------------------------------------
 */

static int
SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	/* File state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL. */
    CONST char *optionName;	/* Option to get. */
    Tcl_DString *dsPtr;		/* Where to store value(s). */
{
    SerialInfo *infoPtr;
    DCB dcb;
    size_t len;
    int valid = 0;		/* Flag if valid option parsed. */

    infoPtr = (SerialInfo *) instanceData;

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -mode
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-mode");
    }
    if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) {
	char parity;
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067

	wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity,
		dcb.ByteSize, stop);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * get option -pollinterval
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-pollinterval");
    }
    if (len==0 || (len>1 && strncmp(optionName, "-pollinterval", len)==0)) {
	char buf[TCL_INTEGER_SPACE + 1];

	valid = 1;
	wsprintfA(buf, "%d", infoPtr->blockTime);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * get option -sysbuffer
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-sysbuffer");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-sysbuffer", len) == 0)) {
	char buf[TCL_INTEGER_SPACE + 1];
	valid = 1;

	wsprintfA(buf, "%d", infoPtr->sysBufRead);
	Tcl_DStringAppendElement(dsPtr, buf);
	wsprintfA(buf, "%d", infoPtr->sysBufWrite);
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {







|














|




















|







2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102

	wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity,
		dcb.ByteSize, stop);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * Get option -pollinterval
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-pollinterval");
    }
    if (len==0 || (len>1 && strncmp(optionName, "-pollinterval", len)==0)) {
	char buf[TCL_INTEGER_SPACE + 1];

	valid = 1;
	wsprintfA(buf, "%d", infoPtr->blockTime);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * Get option -sysbuffer
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-sysbuffer");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-sysbuffer", len) == 0)) {
	char buf[TCL_INTEGER_SPACE + 1];
	valid = 1;

	wsprintfA(buf, "%d", infoPtr->sysBufRead);
	Tcl_DStringAppendElement(dsPtr, buf);
	wsprintfA(buf, "%d", infoPtr->sysBufWrite);
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * Get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
2080
2081
2082
2083
2084
2085
2086
2087

2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098

2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136

2137
2138
2139
2140
2141
2142
2143
2144
2145
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * get option -lasterror

     * option is readonly and returned by [fconfigure chan -lasterror]
     * but not returned by unnamed [fconfigure chan]
     */

    if (len>1 && strncmp(optionName, "-lasterror", len)==0) {
	valid = 1;
	SerialErrorStr(infoPtr->lastError, dsPtr);
    }

    /*
     * get option -queue

     * option is readonly and returned by [fconfigure chan -queue]
     */

    if (len>1 && strncmp(optionName, "-queue", len)==0) {
	char buf[TCL_INTEGER_SPACE + 1];
	COMSTAT cStat;
	DWORD error;
	int inBuffered, outBuffered, count;

	valid = 1;

	/*
	 * Query the pending data in Tcl's internal queues
	 */

	inBuffered  = Tcl_InputBuffered(infoPtr->channel);
	outBuffered = Tcl_OutputBuffered(infoPtr->channel);

	/*
	 * Query the number of bytes in our output queue:
	 *     1. The bytes pending in the output thread
	 *     2. The bytes in the system drivers buffer
	 * The writer thread should not interfere this action.
	 */

	EnterCriticalSection(&infoPtr->csWrite);
	ClearCommError( infoPtr->handle, &error, &cStat );
	count = (int)cStat.cbOutQue + infoPtr->writeQueue;
	LeaveCriticalSection(&infoPtr->csWrite);

	wsprintfA(buf, "%d", inBuffered + cStat.cbInQue); 
	Tcl_DStringAppendElement(dsPtr, buf);
	wsprintfA(buf, "%d", outBuffered + count); 
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * get option -ttystatus

     * option is readonly and returned by [fconfigure chan -ttystatus]
     * but not returned by unnamed [fconfigure chan]
     */

    if (len>4 && strncmp(optionName, "-ttystatus", len)==0) {
	DWORD status;

	if (!GetCommModemStatus(infoPtr->handle, &status)) {
	    if (interp) {







|
>
|
|









>
|











|

















|

|





>
|
|







2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * Get option -lasterror
     *
     * Option is readonly and returned by [fconfigure chan -lasterror] but not
     * returned by unnamed [fconfigure chan].
     */

    if (len>1 && strncmp(optionName, "-lasterror", len)==0) {
	valid = 1;
	SerialErrorStr(infoPtr->lastError, dsPtr);
    }

    /*
     * get option -queue
     *
     * Option is readonly and returned by [fconfigure chan -queue].
     */

    if (len>1 && strncmp(optionName, "-queue", len)==0) {
	char buf[TCL_INTEGER_SPACE + 1];
	COMSTAT cStat;
	DWORD error;
	int inBuffered, outBuffered, count;

	valid = 1;

	/*
	 * Query the pending data in Tcl's internal queues.
	 */

	inBuffered  = Tcl_InputBuffered(infoPtr->channel);
	outBuffered = Tcl_OutputBuffered(infoPtr->channel);

	/*
	 * Query the number of bytes in our output queue:
	 *     1. The bytes pending in the output thread
	 *     2. The bytes in the system drivers buffer
	 * The writer thread should not interfere this action.
	 */

	EnterCriticalSection(&infoPtr->csWrite);
	ClearCommError( infoPtr->handle, &error, &cStat );
	count = (int)cStat.cbOutQue + infoPtr->writeQueue;
	LeaveCriticalSection(&infoPtr->csWrite);

	wsprintfA(buf, "%d", inBuffered + cStat.cbInQue);
	Tcl_DStringAppendElement(dsPtr, buf);
	wsprintfA(buf, "%d", outBuffered + count);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * get option -ttystatus
     *
     * Option is readonly and returned by [fconfigure chan -ttystatus] but not
     * returned by unnamed [fconfigure chan].
     */

    if (len>4 && strncmp(optionName, "-ttystatus", len)==0) {
	DWORD status;

	if (!GetCommModemStatus(infoPtr->handle, &status)) {
	    if (interp) {
2154
2155
2156
2157
2158
2159
2160


























































    if (valid) {
	return TCL_OK;
    } else {
	return Tcl_BadChannelOption(interp, optionName,
		"mode pollinterval lasterror queue sysbuffer ttystatus xchar");
    }
}

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
    if (valid) {
	return TCL_OK;
    } else {
	return Tcl_BadChannelOption(interp, optionName,
		"mode pollinterval lasterror queue sysbuffer ttystatus xchar");
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SerialThreadActionProc --
 *
 *	Insert or remove any thread local refs to this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

static void
SerialThreadActionProc(instanceData, action)
    ClientData instanceData;
    int action;
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;

    /*
     * We do not access firstSerialPtr in the thread structures. This is not
     * for all serials managed by the thread, but only those we are watching.
     * Removal of the filevent handlers before transfer thus takes care of
     * this structure.
     */

    Tcl_MutexLock(&serialMutex);
    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * We can't copy the thread information from the channel when the
	 * channel is created. At this time the channel back pointer has not
	 * been set yet. However in that case the threadId has already been
	 * set by TclpCreateCommandChannel itself, so the structure is still
	 * good.
	 */

	SerialInit();
	if (infoPtr->channel != NULL) {
	    infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
	}
    } else {
	infoPtr->threadId = NULL;
    }
    Tcl_MutexUnlock(&serialMutex);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinSock.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30

31
32
33
34
35
36
37



38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
/* 
 * tclWinSock.c --
 *
 *	This file contains Windows-specific socket related code.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinSock.c,v 1.44 2004/10/06 14:39:20 dkf Exp $
 */

#include "tclWinInt.h"

/*
 * Make sure to remove the redirection defines set in tclWinPort.h
 * that is in use in other sections of the core, except for us.
 */

#undef getservbyname
#undef getsockopt
#undef ntohs
#undef setsockopt

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static int initialized = 0;


static int  hostnameInitialized = 0;
static char hostname[255];	/* This buffer should be big enough for
                                 * hostname plus domain name. */

TCL_DECLARE_MUTEX(socketMutex)





/*
 * Mingw, Cygwin and OpenWatcom may not have LPFN_* typedefs.
 */

#ifdef HAVE_NO_LPFN_DECLS
    typedef SOCKET (PASCAL FAR *LPFN_ACCEPT)(SOCKET s,
            struct sockaddr FAR * addr, int FAR * addrlen);
    typedef int (PASCAL FAR *LPFN_BIND)(SOCKET s,
            const struct sockaddr FAR *addr, int namelen);
    typedef int (PASCAL FAR *LPFN_CLOSESOCKET)(SOCKET s);
    typedef int (PASCAL FAR *LPFN_CONNECT)(SOCKET s,
            const struct sockaddr FAR *name, int namelen);
    typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYADDR)
            (const char FAR *addr, int addrlen, int addrtype);
    typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYNAME)
            (const char FAR * name);
    typedef int (PASCAL FAR *LPFN_GETHOSTNAME)(char FAR * name,
            int namelen);
    typedef int (PASCAL FAR *LPFN_GETPEERNAME)(SOCKET sock,
            struct sockaddr FAR *name, int FAR *namelen);
    typedef struct servent FAR * (PASCAL FAR *LPFN_GETSERVBYNAME)
            (const char FAR * name, const char FAR * proto);
    typedef int (PASCAL FAR *LPFN_GETSOCKNAME)(SOCKET sock,
            struct sockaddr FAR *name, int FAR *namelen);
    typedef int (PASCAL FAR *LPFN_GETSOCKOPT)(SOCKET s, int level,
            int optname, char FAR * optval, int FAR *optlen);
    typedef u_short (PASCAL FAR *LPFN_HTONS)(u_short hostshort);
    typedef unsigned long (PASCAL FAR *LPFN_INET_ADDR)
            (const char FAR * cp);
    typedef char FAR * (PASCAL FAR *LPFN_INET_NTOA)
            (struct in_addr in);
    typedef int (PASCAL FAR *LPFN_IOCTLSOCKET)(SOCKET s,
            long cmd, u_long FAR *argp);
    typedef int (PASCAL FAR *LPFN_LISTEN)(SOCKET s, int backlog);
    typedef u_short (PASCAL FAR *LPFN_NTOHS)(u_short netshort);
    typedef int (PASCAL FAR *LPFN_RECV)(SOCKET s, char FAR * buf,
            int len, int flags);
    typedef int (PASCAL FAR *LPFN_SELECT)(int nfds,
            fd_set FAR * readfds, fd_set FAR * writefds,
            fd_set FAR * exceptfds,
            const struct timeval FAR * timeout);
    typedef int (PASCAL FAR *LPFN_SEND)(SOCKET s,
            const char FAR * buf, int len, int flags);
    typedef int (PASCAL FAR *LPFN_SETSOCKOPT)(SOCKET s,
            int level, int optname, const char FAR * optval,
            int optlen);
    typedef SOCKET (PASCAL FAR *LPFN_SOCKET)(int af,
            int type, int protocol);
    typedef int (PASCAL FAR *LPFN_WSAASYNCSELECT)(SOCKET s,
            HWND hWnd, u_int wMsg, long lEvent);
    typedef int (PASCAL FAR *LPFN_WSACLEANUP)(void);
    typedef int (PASCAL FAR *LPFN_WSAGETLASTERROR)(void);
    typedef int (PASCAL FAR *LPFN_WSASTARTUP)(WORD wVersionRequired,
            LPWSADATA lpWSAData);
#endif


/*
 * The following structure contains pointers to all of the WinSock API
 * entry points used by Tcl.  It is initialized by InitSockets.  Since
 * we dynamically load the Winsock DLL on demand, we must use this
 * function table to refer to functions in the winsock API.
 */

static struct {
    HMODULE		    hModule;	/* Handle to WinSock library. */

    /* Winsock 1.1 functions */
    LPFN_ACCEPT		    accept;
|






|
|

|





|
|

>











>

<
|
|
|
<

>
>
>







|

|


|

|

|

|

|

|

|

|


|

|

|



|

|
|
|

|

|
|

|

|



|




|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
/*
 * tclWinSock.c --
 *
 *	This file contains Windows-specific socket related code.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinSock.c,v 1.44.2.2 2005/08/02 18:17:20 dgp Exp $
 */

#include "tclWinInt.h"

/*
 * Make sure to remove the redirection defines set in tclWinPort.h that is in
 * use in other sections of the core, except for us.
 */

#undef getservbyname
#undef getsockopt
#undef ntohs
#undef setsockopt

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static int initialized = 0;
TCL_DECLARE_MUTEX(socketMutex)


/*
 * The following variable holds the network name of this host.
 */


static TclInitProcessGlobalValueProc	InitializeHostName;
static ProcessGlobalValue hostName =
	{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};

/*
 * Mingw, Cygwin and OpenWatcom may not have LPFN_* typedefs.
 */

#ifdef HAVE_NO_LPFN_DECLS
    typedef SOCKET (PASCAL FAR *LPFN_ACCEPT)(SOCKET s,
	    struct sockaddr FAR * addr, int FAR * addrlen);
    typedef int (PASCAL FAR *LPFN_BIND)(SOCKET s,
	    const struct sockaddr FAR *addr, int namelen);
    typedef int (PASCAL FAR *LPFN_CLOSESOCKET)(SOCKET s);
    typedef int (PASCAL FAR *LPFN_CONNECT)(SOCKET s,
	    const struct sockaddr FAR *name, int namelen);
    typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYADDR)
	    (const char FAR *addr, int addrlen, int addrtype);
    typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYNAME)
	    (const char FAR * name);
    typedef int (PASCAL FAR *LPFN_GETHOSTNAME)(char FAR * name,
	    int namelen);
    typedef int (PASCAL FAR *LPFN_GETPEERNAME)(SOCKET sock,
	    struct sockaddr FAR *name, int FAR *namelen);
    typedef struct servent FAR * (PASCAL FAR *LPFN_GETSERVBYNAME)
	    (const char FAR * name, const char FAR * proto);
    typedef int (PASCAL FAR *LPFN_GETSOCKNAME)(SOCKET sock,
	    struct sockaddr FAR *name, int FAR *namelen);
    typedef int (PASCAL FAR *LPFN_GETSOCKOPT)(SOCKET s, int level,
	    int optname, char FAR * optval, int FAR *optlen);
    typedef u_short (PASCAL FAR *LPFN_HTONS)(u_short hostshort);
    typedef unsigned long (PASCAL FAR *LPFN_INET_ADDR)
	    (const char FAR * cp);
    typedef char FAR * (PASCAL FAR *LPFN_INET_NTOA)
	    (struct in_addr in);
    typedef int (PASCAL FAR *LPFN_IOCTLSOCKET)(SOCKET s,
	    long cmd, u_long FAR *argp);
    typedef int (PASCAL FAR *LPFN_LISTEN)(SOCKET s, int backlog);
    typedef u_short (PASCAL FAR *LPFN_NTOHS)(u_short netshort);
    typedef int (PASCAL FAR *LPFN_RECV)(SOCKET s, char FAR * buf,
	    int len, int flags);
    typedef int (PASCAL FAR *LPFN_SELECT)(int nfds,
	    fd_set FAR * readfds, fd_set FAR * writefds,
	    fd_set FAR * exceptfds,
	    const struct timeval FAR * timeout);
    typedef int (PASCAL FAR *LPFN_SEND)(SOCKET s,
	    const char FAR * buf, int len, int flags);
    typedef int (PASCAL FAR *LPFN_SETSOCKOPT)(SOCKET s,
	    int level, int optname, const char FAR * optval,
	    int optlen);
    typedef SOCKET (PASCAL FAR *LPFN_SOCKET)(int af,
	    int type, int protocol);
    typedef int (PASCAL FAR *LPFN_WSAASYNCSELECT)(SOCKET s,
	    HWND hWnd, u_int wMsg, long lEvent);
    typedef int (PASCAL FAR *LPFN_WSACLEANUP)(void);
    typedef int (PASCAL FAR *LPFN_WSAGETLASTERROR)(void);
    typedef int (PASCAL FAR *LPFN_WSASTARTUP)(WORD wVersionRequired,
	    LPWSADATA lpWSAData);
#endif


/*
 * The following structure contains pointers to all of the WinSock API entry
 * points used by Tcl. It is initialized by InitSockets. Since we dynamically
 * load the Winsock DLL on demand, we must use this function table to refer to
 * functions in the winsock API.
 */

static struct {
    HMODULE		    hModule;	/* Handle to WinSock library. */

    /* Winsock 1.1 functions */
    LPFN_ACCEPT		    accept;
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250










251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287


288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
    LPFN_SEND		    send;
    LPFN_SETSOCKOPT	    setsockopt;
    LPFN_SOCKET		    socket;
    LPFN_WSAASYNCSELECT	    WSAAsyncSelect;
    LPFN_WSACLEANUP	    WSACleanup;
    LPFN_WSAGETLASTERROR    WSAGetLastError;
    LPFN_WSASTARTUP	    WSAStartup;

} winSock;

/*
 * The following defines declare the messages used on socket windows.
 */

#define SOCKET_MESSAGE	    WM_USER+1
#define SOCKET_SELECT	    WM_USER+2
#define SOCKET_TERMINATE    WM_USER+3
#define SELECT		    TRUE
#define UNSELECT	    FALSE

/*
 * The following structure is used to store the data associated with
 * each socket.
 */

typedef struct SocketInfo {
    Tcl_Channel channel;	   /* Channel associated with this
				    * socket. */
    SOCKET socket;		   /* Windows SOCKET handle. */
    int flags;			   /* Bit field comprised of the flags
				    * described below.  */
    int watchEvents;		   /* OR'ed combination of FD_READ,
				    * FD_WRITE, FD_CLOSE, FD_ACCEPT and
				    * FD_CONNECT that indicate which
				    * events are interesting. */
    int readyEvents;		   /* OR'ed combination of FD_READ,
				    * FD_WRITE, FD_CLOSE, FD_ACCEPT and
				    * FD_CONNECT that indicate which
				    * events have occurred. */
    int selectEvents;		   /* OR'ed combination of FD_READ,
				    * FD_WRITE, FD_CLOSE, FD_ACCEPT and
				    * FD_CONNECT that indicate which
				    * events are currently being
				    * selected. */
    int acceptEventCount;          /* Count of the current number of
				    * FD_ACCEPTs that have arrived and
				    * not yet processed. */
    Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */

    ClientData acceptProcData;	   /* The data for the accept proc. */
    int lastError;		   /* Error code from last message. */
    struct SocketInfo *nextPtr;	   /* The next socket on the per-thread
				    * socket list. */
} SocketInfo;

/*
 * The following structure is what is added to the Tcl event queue when
 * a socket event occurs.
 */

typedef struct SocketEvent {
    Tcl_Event header;		/* Information that is standard for
				 * all events. */
    SOCKET socket;		/* Socket descriptor that is ready.  Used
				 * to find the SocketInfo structure for
				 * the file (can't point directly to the
				 * SocketInfo structure because it could
				 * go away while the event is queued). */
} SocketEvent;

/*
 * This defines the minimum buffersize maintained by the kernel.
 */

#define TCP_BUFFER_SIZE 4096

/*
 * The following macros may be used to set the flags field of
 * a SocketInfo structure.
 */

#define SOCKET_ASYNC		(1<<0)	/* The socket is in blocking
					 * mode. */
#define SOCKET_EOF		(1<<1)	/* A zero read happened on
					 * the socket. */
#define SOCKET_ASYNC_CONNECT	(1<<2)	/* This socket uses async
					 * connect. */
#define SOCKET_PENDING		(1<<3)	/* A message has been sent
					 * for this socket */

typedef struct ThreadSpecificData {
    HWND hwnd;		    /* Handle to window for socket messages. */
    HANDLE socketThread;    /* Thread handling the window */
    Tcl_ThreadId threadId;  /* Parent thread. */
    HANDLE readyEvent;      /* Event indicating that a socket event is
			     * ready.  Also used to indicate that the
			     * socketThread has been initialized and has
			     * started. */
    HANDLE socketListLock;  /* Win32 Event to lock the socketList */
    SocketInfo *socketList; /* Every open socket in this thread has an
			     * entry on this list. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
static WNDCLASS windowClass;

/*
 * Static functions defined in this file.
 */

static SocketInfo *	    CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
				    int port, CONST char *host,
				    int server, CONST char *myaddr,
				    int myport, int async));
static int		    CreateSocketAddress _ANSI_ARGS_(
				    (LPSOCKADDR_IN sockaddrPtr,
				    CONST char *host, int port));
static void		    InitSockets _ANSI_ARGS_((void));
static SocketInfo *	    NewSocketInfo _ANSI_ARGS_((SOCKET socket));
static Tcl_EventCheckProc   SocketCheckProc;
static Tcl_EventProc	    SocketEventProc;
static void		    SocketExitHandler _ANSI_ARGS_((
				    ClientData clientData));
static LRESULT CALLBACK	    SocketProc _ANSI_ARGS_((HWND hwnd,
				    UINT message, WPARAM wParam,
				    LPARAM lParam));










static Tcl_EventSetupProc   SocketSetupProc;
static Tcl_ExitProc	    SocketThreadExitHandler;
static int		    SocketsEnabled _ANSI_ARGS_((void));
static void		    TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr));
static Tcl_DriverBlockModeProc	TcpBlockProc;
static Tcl_DriverCloseProc	TcpCloseProc;
static Tcl_DriverSetOptionProc	TcpSetOptionProc;
static Tcl_DriverGetOptionProc	TcpGetOptionProc;
static Tcl_DriverInputProc	TcpInputProc;
static Tcl_DriverOutputProc	TcpOutputProc;
static Tcl_DriverWatchProc	TcpWatchProc;
static Tcl_DriverGetHandleProc	TcpGetHandleProc;
static int		    WaitForSocketEvent _ANSI_ARGS_((
				SocketInfo *infoPtr, int events,
				int *errorCodePtr));
static DWORD WINAPI	    SocketThread _ANSI_ARGS_((LPVOID arg));

/*
 * This structure describes the channel type structure for TCP socket
 * based IO.
 */

static Tcl_ChannelType tcpChannelType = {
    "tcp",		    /* Type name. */
    TCL_CHANNEL_VERSION_2,  /* v2 channel */
    TcpCloseProc,	    /* Close proc. */
    TcpInputProc,	    /* Input proc. */
    TcpOutputProc,	    /* Output proc. */
    NULL,		    /* Seek proc. */
    TcpSetOptionProc,	    /* Set option proc. */
    TcpGetOptionProc,	    /* Get option proc. */
    TcpWatchProc,	    /* Set up notifier to watch this channel. */
    TcpGetHandleProc,	    /* Get an OS handle from channel. */
    NULL,		    /* close2proc. */
    TcpBlockProc,	    /* Set socket into (non-)blocking mode. */
    NULL,		    /* flush proc. */
    NULL,		    /* handler proc. */


};


/*
 *----------------------------------------------------------------------
 *
 * InitSockets --
 *
 *	Initialize the socket module.  Attempts to load the wsock32.dll
 *	library and set up the winSock function table.  If successful,
 *	registers the event window for the socket notifier code.
 *
 *	Assumes Mutex is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Dynamically loads wsock32.dll, and registers a new window
 *	class and creates a window for use in asynchronous socket
 *	notification.
 *
 *----------------------------------------------------------------------
 */

static void
InitSockets()
{
    DWORD id;
    WSADATA wsaData;
    DWORD err;
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (!initialized) {
	initialized = 1;
	Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL);

	winSock.hModule = LoadLibraryA("wsock32.dll");

	if (winSock.hModule == NULL) {
	    return;
	}
    
	/*
	 * Initialize the function table.
	 */

	winSock.accept = (LPFN_ACCEPT)
		GetProcAddress(winSock.hModule, "accept");
	winSock.bind = (LPFN_BIND)







<













|
|



|
<
|
|
|
|
|
<
|
|
|
<
|
|
|
<
|
|
|
<
|
|
>
|
|
|
|



|
|



|
|
|
|
|
|
|









|
|


|
<
|
|
|
<
|
|


|
|
|
|
|
|
|
|
|
|









|
<
|
|
<
|
|
|
|
<
<
<
|
<
|
|
>
>
>
>
>
>
>
>
>
>
|
|
<
<








<
<
<
<








|












>
>








|
|
|







|
|
<










|
|










|







129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154

155
156
157
158
159

160
161
162

163
164
165

166
167
168

169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

205
206
207

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231

232
233

234
235
236
237



238

239
240
241
242
243
244
245
246
247
248
249
250
251
252


253
254
255
256
257
258
259
260




261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
    LPFN_SEND		    send;
    LPFN_SETSOCKOPT	    setsockopt;
    LPFN_SOCKET		    socket;
    LPFN_WSAASYNCSELECT	    WSAAsyncSelect;
    LPFN_WSACLEANUP	    WSACleanup;
    LPFN_WSAGETLASTERROR    WSAGetLastError;
    LPFN_WSASTARTUP	    WSAStartup;

} winSock;

/*
 * The following defines declare the messages used on socket windows.
 */

#define SOCKET_MESSAGE	    WM_USER+1
#define SOCKET_SELECT	    WM_USER+2
#define SOCKET_TERMINATE    WM_USER+3
#define SELECT		    TRUE
#define UNSELECT	    FALSE

/*
 * The following structure is used to store the data associated with each
 * socket.
 */

typedef struct SocketInfo {
    Tcl_Channel channel;	/* Channel associated with this socket. */

    SOCKET socket;		/* Windows SOCKET handle. */
    int flags;			/* Bit field comprised of the flags described
				 * below. */
    int watchEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that

				 * indicate which events are interesting. */
    int readyEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that

				 * indicate which events have occurred. */
    int selectEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that

				 * indicate which events are currently being
				 * selected. */
    int acceptEventCount;	/* Count of the current number of FD_ACCEPTs

				 * that have arrived and not yet processed. */
    Tcl_TcpAcceptProc *acceptProc;
				/* Proc to call on accept. */
    ClientData acceptProcData;	/* The data for the accept proc. */
    int lastError;		/* Error code from last message. */
    struct SocketInfo *nextPtr;	/* The next socket on the per-thread socket
				 * list. */
} SocketInfo;

/*
 * The following structure is what is added to the Tcl event queue when a
 * socket event occurs.
 */

typedef struct SocketEvent {
    Tcl_Event header;		/* Information that is standard for all
				 * events. */
    SOCKET socket;		/* Socket descriptor that is ready. Used to
				 * find the SocketInfo structure for the file
				 * (can't point directly to the SocketInfo
				 * structure because it could go away while
				 * the event is queued). */
} SocketEvent;

/*
 * This defines the minimum buffersize maintained by the kernel.
 */

#define TCP_BUFFER_SIZE 4096

/*
 * The following macros may be used to set the flags field of a SocketInfo
 * structure.
 */

#define SOCKET_ASYNC		(1<<0)	/* The socket is in blocking mode. */

#define SOCKET_EOF		(1<<1)	/* A zero read happened on the
					 * socket. */
#define SOCKET_ASYNC_CONNECT	(1<<2)	/* This socket uses async connect. */

#define SOCKET_PENDING		(1<<3)	/* A message has been sent for this
					 * socket */

typedef struct ThreadSpecificData {
    HWND hwnd;			/* Handle to window for socket messages. */
    HANDLE socketThread;	/* Thread handling the window */
    Tcl_ThreadId threadId;	/* Parent thread. */
    HANDLE readyEvent;		/* Event indicating that a socket event is
				 * ready. Also used to indicate that the
				 * socketThread has been initialized and has
				 * started. */
    HANDLE socketListLock;	/* Win32 Event to lock the socketList */
    SocketInfo *socketList;	/* Every open socket in this thread has an
				 * entry on this list. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;
static WNDCLASS windowClass;

/*
 * Static functions defined in this file.
 */

static SocketInfo *	CreateSocket(Tcl_Interp *interp, int port,

			    CONST char *host, int server, CONST char *myaddr,
			    int myport, int async);

static int		CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr,
			    CONST char *host, int port);
static void		InitSockets(void);
static SocketInfo *	NewSocketInfo(SOCKET socket);



static void		SocketExitHandler(ClientData clientData);

static LRESULT CALLBACK	SocketProc(HWND hwnd, UINT message, WPARAM wParam,
			    LPARAM lParam);
static int		SocketsEnabled(void);
static void		TcpAccept(SocketInfo *infoPtr);
static int		WaitForSocketEvent(SocketInfo *infoPtr, int events,
			    int *errorCodePtr);
static DWORD WINAPI	SocketThread(LPVOID arg);
static void		TcpThreadActionProc(ClientData instanceData,
			    int action);

static Tcl_EventCheckProc	SocketCheckProc;
static Tcl_EventProc		SocketEventProc;
static Tcl_EventSetupProc	SocketSetupProc;
static Tcl_ExitProc		SocketThreadExitHandler;


static Tcl_DriverBlockModeProc	TcpBlockProc;
static Tcl_DriverCloseProc	TcpCloseProc;
static Tcl_DriverSetOptionProc	TcpSetOptionProc;
static Tcl_DriverGetOptionProc	TcpGetOptionProc;
static Tcl_DriverInputProc	TcpInputProc;
static Tcl_DriverOutputProc	TcpOutputProc;
static Tcl_DriverWatchProc	TcpWatchProc;
static Tcl_DriverGetHandleProc	TcpGetHandleProc;





/*
 * This structure describes the channel type structure for TCP socket
 * based IO.
 */

static Tcl_ChannelType tcpChannelType = {
    "tcp",		    /* Type name. */
    TCL_CHANNEL_VERSION_4,  /* v4 channel */
    TcpCloseProc,	    /* Close proc. */
    TcpInputProc,	    /* Input proc. */
    TcpOutputProc,	    /* Output proc. */
    NULL,		    /* Seek proc. */
    TcpSetOptionProc,	    /* Set option proc. */
    TcpGetOptionProc,	    /* Get option proc. */
    TcpWatchProc,	    /* Set up notifier to watch this channel. */
    TcpGetHandleProc,	    /* Get an OS handle from channel. */
    NULL,		    /* close2proc. */
    TcpBlockProc,	    /* Set socket into (non-)blocking mode. */
    NULL,		    /* flush proc. */
    NULL,		    /* handler proc. */
    NULL,		    /* wide seek proc */
    TcpThreadActionProc,    /* thread action proc */
};


/*
 *----------------------------------------------------------------------
 *
 * InitSockets --
 *
 *	Initialize the socket module. Attempts to load the wsock32.dll library
 *	and set up the winSock function table. If successful, registers the
 *	event window for the socket notifier code.
 *
 *	Assumes Mutex is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Dynamically loads wsock32.dll, and registers a new window class and
 *	creates a window for use in asynchronous socket notification.

 *
 *----------------------------------------------------------------------
 */

static void
InitSockets()
{
    DWORD id;
    WSADATA wsaData;
    DWORD err;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    if (!initialized) {
	initialized = 1;
	Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL);

	winSock.hModule = LoadLibraryA("wsock32.dll");

	if (winSock.hModule == NULL) {
	    return;
	}

	/*
	 * Initialize the function table.
	 */

	winSock.accept = (LPFN_ACCEPT)
		GetProcAddress(winSock.hModule, "accept");
	winSock.bind = (LPFN_BIND)
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
		GetProcAddress(winSock.hModule, "WSAAsyncSelect");
	winSock.WSACleanup = (LPFN_WSACLEANUP)
		GetProcAddress(winSock.hModule, "WSACleanup");
	winSock.WSAGetLastError = (LPFN_WSAGETLASTERROR)
		GetProcAddress(winSock.hModule, "WSAGetLastError");
	winSock.WSAStartup = (LPFN_WSASTARTUP)
		GetProcAddress(winSock.hModule, "WSAStartup");
    
	/*
	 * Now check that all fields are properly initialized. If not,
	 * return zero to indicate that we failed to initialize
	 * properly.
	 */
    
	if ((winSock.accept == NULL) ||
		(winSock.bind == NULL) ||
		(winSock.closesocket == NULL) ||
		(winSock.connect == NULL) ||
		(winSock.gethostbyname == NULL) ||
		(winSock.gethostbyaddr == NULL) ||
		(winSock.gethostname == NULL) ||







|

|
|
<

|







376
377
378
379
380
381
382
383
384
385
386

387
388
389
390
391
392
393
394
395
		GetProcAddress(winSock.hModule, "WSAAsyncSelect");
	winSock.WSACleanup = (LPFN_WSACLEANUP)
		GetProcAddress(winSock.hModule, "WSACleanup");
	winSock.WSAGetLastError = (LPFN_WSAGETLASTERROR)
		GetProcAddress(winSock.hModule, "WSAGetLastError");
	winSock.WSAStartup = (LPFN_WSASTARTUP)
		GetProcAddress(winSock.hModule, "WSAStartup");

	/*
	 * Now check that all fields are properly initialized. If not, return
	 * zero to indicate that we failed to initialize properly.

	 */

	if ((winSock.accept == NULL) ||
		(winSock.bind == NULL) ||
		(winSock.closesocket == NULL) ||
		(winSock.connect == NULL) ||
		(winSock.gethostbyname == NULL) ||
		(winSock.gethostbyaddr == NULL) ||
		(winSock.gethostname == NULL) ||
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
		(winSock.select == NULL) ||
		(winSock.send == NULL) ||
		(winSock.setsockopt == NULL) ||
		(winSock.socket == NULL) ||
		(winSock.WSAAsyncSelect == NULL) ||
		(winSock.WSACleanup == NULL) ||
		(winSock.WSAGetLastError == NULL) ||
		(winSock.WSAStartup == NULL))
	{
	    goto unloadLibrary;
	}
	
	/*
	 * Create the async notification window with a new class.  We
	 * must create a new class to avoid a Windows 95 bug that causes
	 * us to get the wrong message number for socket events if the
	 * message window is a subclass of a static control.
	 */
    
	windowClass.style = 0;
	windowClass.cbClsExtra = 0;
	windowClass.cbWndExtra = 0;
	windowClass.hInstance = TclWinGetTclInstance();
	windowClass.hbrBackground = NULL;
	windowClass.lpszMenuName = NULL;
	windowClass.lpszClassName = "TclSocket";
	windowClass.lpfnWndProc = SocketProc;
	windowClass.hIcon = NULL;
	windowClass.hCursor = NULL;

	if (!RegisterClassA(&windowClass)) {
	    TclWinConvertError(GetLastError());
	    goto unloadLibrary;
	}

	/*
	 * Initialize the winsock library and check the interface
	 * version actually loaded. We only ask for the 1.1 interface
	 * and do require that it not be less than 1.1.
	 */

#define WSA_VERSION_MAJOR   1
#define WSA_VERSION_MINOR   1
#define WSA_VERSION_REQD    MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR)

	if ((err = winSock.WSAStartup(WSA_VERSION_REQD, &wsaData)) != 0) {
	    TclWinConvertWSAError(err);
	    goto unloadLibrary;
	}

	/*
	 * Note the byte positions are swapped for the comparison, so
	 * that 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101
	 * (1.1).  We want the comparison to be 0x0200 < 0x0101.
	 */

	if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion))
		< MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) {
	    TclWinConvertWSAError(WSAVERNOTSUPPORTED);
	    winSock.WSACleanup();
	    goto unloadLibrary;







|
<


|

|
|
|
|

|

















|
|
|


|
|
|







|
|
|







407
408
409
410
411
412
413
414

415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
		(winSock.select == NULL) ||
		(winSock.send == NULL) ||
		(winSock.setsockopt == NULL) ||
		(winSock.socket == NULL) ||
		(winSock.WSAAsyncSelect == NULL) ||
		(winSock.WSACleanup == NULL) ||
		(winSock.WSAGetLastError == NULL) ||
		(winSock.WSAStartup == NULL)) {

	    goto unloadLibrary;
	}

	/*
	 * Create the async notification window with a new class. We must
	 * create a new class to avoid a Windows 95 bug that causes us to get
	 * the wrong message number for socket events if the message window is
	 * a subclass of a static control.
	 */

	windowClass.style = 0;
	windowClass.cbClsExtra = 0;
	windowClass.cbWndExtra = 0;
	windowClass.hInstance = TclWinGetTclInstance();
	windowClass.hbrBackground = NULL;
	windowClass.lpszMenuName = NULL;
	windowClass.lpszClassName = "TclSocket";
	windowClass.lpfnWndProc = SocketProc;
	windowClass.hIcon = NULL;
	windowClass.hCursor = NULL;

	if (!RegisterClassA(&windowClass)) {
	    TclWinConvertError(GetLastError());
	    goto unloadLibrary;
	}

	/*
	 * Initialize the winsock library and check the interface version
	 * actually loaded. We only ask for the 1.1 interface and do require
	 * that it not be less than 1.1.
	 */

#define WSA_VERSION_MAJOR 1
#define WSA_VERSION_MINOR 1
#define WSA_VERSION_REQD  MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR)

	if ((err = winSock.WSAStartup(WSA_VERSION_REQD, &wsaData)) != 0) {
	    TclWinConvertWSAError(err);
	    goto unloadLibrary;
	}

	/*
	 * Note the byte positions are swapped for the comparison, so that
	 * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1).
	 * We want the comparison to be 0x0200 < 0x0101.
	 */

	if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion))
		< MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) {
	    TclWinConvertWSAError(WSAVERNOTSUPPORTED);
	    winSock.WSACleanup();
	    goto unloadLibrary;
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530

    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->socketList = NULL;
	tsdPtr->hwnd = NULL;

	tsdPtr->threadId = Tcl_GetCurrentThread();
	
	tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
	tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
	tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread,
		tsdPtr, 0, &id);
	SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);

	if (tsdPtr->socketThread == NULL) {
	    goto unloadLibrary;
	}
	

	/*
	 * Wait for the thread to signal that the window has
	 * been created and is ready to go.  Timeout after twenty
	 * seconds.
	 */
	
	if (WaitForSingleObject(tsdPtr->readyEvent, 20000)
		== WAIT_TIMEOUT) {
	    goto unloadLibrary;
	}

	if (tsdPtr->hwnd == NULL) {
	    goto unloadLibrary;
	}
	
	Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
	Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL);
    }
    return;

unloadLibrary:
    if (tsdPtr != NULL && tsdPtr->hwnd != NULL) {
	SocketThreadExitHandler(0);
    }
    FreeLibrary(winSock.hModule);
    winSock.hModule = NULL;
    return;
}







|









|


|
|
<

|
|
<






|





|







477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498

499
500
501

502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->socketList = NULL;
	tsdPtr->hwnd = NULL;

	tsdPtr->threadId = Tcl_GetCurrentThread();

	tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
	tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
	tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread,
		tsdPtr, 0, &id);
	SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);

	if (tsdPtr->socketThread == NULL) {
	    goto unloadLibrary;
	}


	/*
	 * Wait for the thread to signal that the window has been created and
	 * is ready to go. Timeout after twenty seconds.

	 */

	if (WaitForSingleObject(tsdPtr->readyEvent, 20000) == WAIT_TIMEOUT) {

	    goto unloadLibrary;
	}

	if (tsdPtr->hwnd == NULL) {
	    goto unloadLibrary;
	}

	Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
	Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL);
    }
    return;

  unloadLibrary:
    if (tsdPtr != NULL && tsdPtr->hwnd != NULL) {
	SocketThreadExitHandler(0);
    }
    FreeLibrary(winSock.hModule);
    winSock.hModule = NULL;
    return;
}
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587

588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629

630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
SocketExitHandler(clientData)
    ClientData clientData;              /* Not used. */
{
    Tcl_MutexLock(&socketMutex);
    if (winSock.hModule) {
	/*
	 * Make sure the socket event handling window is cleaned-up
	 * for, at most, this thread.
	 */

	SocketThreadExitHandler(clientData);
	UnregisterClass("TclSocket", TclWinGetTclInstance());
	winSock.WSACleanup();
	FreeLibrary(winSock.hModule);
	winSock.hModule = NULL;
    }
    initialized = 0;
    hostnameInitialized = 0;
    Tcl_MutexUnlock(&socketMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketThreadExitHandler --
 *
 *	Callback invoked during thread clean up to delete the socket
 *	event source.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Delete the event source.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
SocketThreadExitHandler(clientData)
    ClientData clientData;              /* Not used. */
{
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (tsdPtr != NULL && tsdPtr->socketThread != NULL) {
	DWORD exitCode;

	GetExitCodeThread(tsdPtr->socketThread, &exitCode);
	if (exitCode == STILL_ACTIVE) {
	    PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);

	    /*
	     * Wait for the thread to close.  This ensures that we are
	     * completely cleaned up before we leave this function.
	     * If Tcl_Finalize was called from DllMain, the thread
	     * is in a paused state so we need to timeout and continue.
	     */

	    WaitForSingleObject(tsdPtr->socketThread, 100);
	}
	CloseHandle(tsdPtr->socketThread);
	tsdPtr->socketThread = NULL;
	CloseHandle(tsdPtr->readyEvent);
	CloseHandle(tsdPtr->socketListLock);

	Tcl_DeleteThreadExitHandler(SocketThreadExitHandler, NULL);
	Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpHasSockets --
 *
 *	This function determines whether sockets are available on the
 *	current system and returns an error in interp if they are not.
 *	Note that interp may be NULL.
 *
 * Results:
 *	Returns TCL_OK if the system supports sockets, or TCL_ERROR with
 *	an error in interp.
 *
 * Side effects:
 *	If not already prepared, initializes the TSD structure and
 *	socket message handling thread associated to the calling thread
 *	for the subsystem of the driver.
 *
 *----------------------------------------------------------------------
 */

int
TclpHasSockets(interp)
    Tcl_Interp *interp;







|




|
|

>







<








|
|













|

|








>

|
|
|
|



















|
|
|


|
|


|
|
|







564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
SocketExitHandler(clientData)
    ClientData clientData;		/* Not used. */
{
    Tcl_MutexLock(&socketMutex);
    if (winSock.hModule) {
	/*
	 * Make sure the socket event handling window is cleaned-up for, at
	 * most, this thread.
	 */

	SocketThreadExitHandler(clientData);
	UnregisterClass("TclSocket", TclWinGetTclInstance());
	winSock.WSACleanup();
	FreeLibrary(winSock.hModule);
	winSock.hModule = NULL;
    }
    initialized = 0;

    Tcl_MutexUnlock(&socketMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketThreadExitHandler --
 *
 *	Callback invoked during thread clean up to delete the socket event
 *	source.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Delete the event source.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static void
SocketThreadExitHandler(clientData)
    ClientData clientData;		/* Not used. */
{
    ThreadSpecificData *tsdPtr =
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (tsdPtr != NULL && tsdPtr->socketThread != NULL) {
	DWORD exitCode;

	GetExitCodeThread(tsdPtr->socketThread, &exitCode);
	if (exitCode == STILL_ACTIVE) {
	    PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);

	    /*
	     * Wait for the thread to close. This ensures that we are
	     * completely cleaned up before we leave this function. If
	     * Tcl_Finalize was called from DllMain, the thread is in a paused
	     * state so we need to timeout and continue.
	     */

	    WaitForSingleObject(tsdPtr->socketThread, 100);
	}
	CloseHandle(tsdPtr->socketThread);
	tsdPtr->socketThread = NULL;
	CloseHandle(tsdPtr->readyEvent);
	CloseHandle(tsdPtr->socketListLock);

	Tcl_DeleteThreadExitHandler(SocketThreadExitHandler, NULL);
	Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpHasSockets --
 *
 *	This function determines whether sockets are available on the current
 *	system and returns an error in interp if they are not. Note that
 *	interp may be NULL.
 *
 * Results:
 *	Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
 *	error in interp (if non-NULL).
 *
 * Side effects:
 *	If not already prepared, initializes the TSD structure and socket
 *	message handling thread associated to the calling thread for the
 *	subsystem of the driver.
 *
 *----------------------------------------------------------------------
 */

int
TclpHasSockets(interp)
    Tcl_Interp *interp;
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
}

/*
 *----------------------------------------------------------------------
 *
 * SocketSetupProc --
 *
 *	This procedure is invoked before Tcl_DoOneEvent blocks waiting
 *	for an event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *







|
|







678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
}

/*
 *----------------------------------------------------------------------
 *
 * SocketSetupProc --
 *
 *	This function is invoked before Tcl_DoOneEvent blocks waiting for an
 *	event.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Adjusts the block time if needed.
 *
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
    SocketInfo *infoPtr;
    Tcl_Time blockTime = { 0, 0 };
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }
    
    /*
     * Check to see if there is a ready socket.  If so, poll.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->readyEvents & infoPtr->watchEvents) {
	    Tcl_SetMaxBlockTime(&blockTime);
	    break;
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketCheckProc --
 *
 *	This procedure is called by Tcl_DoOneEvent to check the socket
 *	event source for events. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *







|

|



|














|
|







702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
    SocketInfo *infoPtr;
    Tcl_Time blockTime = { 0, 0 };
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Check to see if there is a ready socket.	 If so, poll.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->readyEvents & infoPtr->watchEvents) {
	    Tcl_SetMaxBlockTime(&blockTime);
	    break;
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketCheckProc --
 *
 *	This function is called by Tcl_DoOneEvent to check the socket event
 *	source for events.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May queue an event.
 *
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
    SocketInfo *infoPtr;
    SocketEvent *evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }
    
    /*
     * Queue events for any ready sockets that don't already have events
     * queued (caused by persistent states that won't generate WinSock
     * events).
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if ((infoPtr->readyEvents & infoPtr->watchEvents)
		&& !(infoPtr->flags & SOCKET_PENDING)) {
	    infoPtr->flags |= SOCKET_PENDING;
	    evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent));
	    evPtr->header.proc = SocketEventProc;
	    evPtr->socket = infoPtr->socket;
	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketEventProc --
 *
 *	This procedure is called by Tcl_ServiceEvent when a socket event
 *	reaches the front of the event queue.  This procedure is
 *	responsible for notifying the generic channel code.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed
 *	from the queue.  Returns 0 if the event was not handled, meaning
 *	it should stay on the queue.  The only time the event isn't
 *	handled is if the TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the channel callback procedures do.
 *
 *----------------------------------------------------------------------
 */

static int
SocketEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    SocketInfo *infoPtr;
    SocketEvent *eventPtr = (SocketEvent *) evPtr;
    int mask = 0;
    int events;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Find the specified socket on the socket list.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL; 
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->socket == eventPtr->socket) {
	    break;
	}
    }
    SetEvent(tsdPtr->socketListLock);








|







|


















|
|
|


|
|
|
|


|







|
|
















|







747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
    SocketInfo *infoPtr;
    SocketEvent *evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Queue events for any ready sockets that don't already have events
     * queued (caused by persistent states that won't generate WinSock
     * events).
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if ((infoPtr->readyEvents & infoPtr->watchEvents)
		&& !(infoPtr->flags & SOCKET_PENDING)) {
	    infoPtr->flags |= SOCKET_PENDING;
	    evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent));
	    evPtr->header.proc = SocketEventProc;
	    evPtr->socket = infoPtr->socket;
	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
	}
    }
    SetEvent(tsdPtr->socketListLock);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketEventProc --
 *
 *	This function is called by Tcl_ServiceEvent when a socket event
 *	reaches the front of the event queue. This function is responsible for
 *	notifying the generic channel code.
 *
 * Results:
 *	Returns 1 if the event was handled, meaning it should be removed from
 *	the queue. Returns 0 if the event was not handled, meaning it should
 *	stay on the queue. The only time the event isn't handled is if the
 *	TCL_FILE_EVENTS flag bit isn't set.
 *
 * Side effects:
 *	Whatever the channel callback functions do.
 *
 *----------------------------------------------------------------------
 */

static int
SocketEventProc(evPtr, flags)
    Tcl_Event *evPtr;		/* Event to service. */
    int flags;			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    SocketInfo *infoPtr;
    SocketEvent *eventPtr = (SocketEvent *) evPtr;
    int mask = 0;
    int events;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Find the specified socket on the socket list.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->socket == eventPtr->socket) {
	    break;
	}
    }
    SetEvent(tsdPtr->socketListLock);

847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904

905


906
907
908
909
910
911
912

    if (infoPtr->readyEvents & FD_ACCEPT) {
	TcpAccept(infoPtr);
	return 1;
    }

    /*
     * Mask off unwanted events and compute the read/write mask so 
     * we can notify the channel.
     */

    events = infoPtr->readyEvents & infoPtr->watchEvents;

    if (events & FD_CLOSE) {
	/*
	 * If the socket was closed and the channel is still interested
	 * in read events, then we need to ensure that we keep polling
	 * for this event until someone does something with the channel.
	 * Note that we do this before calling Tcl_NotifyChannel so we don't
	 * have to watch out for the channel being deleted out from under
	 * us.  This may cause a redundant trip through the event loop, but
	 * it's simpler than trying to do unwind protection.
	 */

	Tcl_Time blockTime = { 0, 0 };
	Tcl_SetMaxBlockTime(&blockTime);
	mask |= TCL_READABLE|TCL_WRITABLE;
    } else if (events & FD_READ) {
	fd_set readFds;
	struct timeval timeout;

	/*
	 * We must check to see if data is really available, since someone
	 * could have consumed the data in the meantime.  Turn off async
	 * notification so select will work correctly.	If the socket is
	 * still readable, notify the channel driver, otherwise reset the
	 * async select handler and keep waiting.
	 */

	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);

	FD_ZERO(&readFds);
	FD_SET(infoPtr->socket, &readFds);
	timeout.tv_usec = 0;
	timeout.tv_sec = 0;
 
	if (winSock.select(0, &readFds, NULL, NULL, &timeout) != 0) {
	    mask |= TCL_READABLE;
	} else {
	    infoPtr->readyEvents &= ~(FD_READ);
	    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		    (WPARAM) SELECT, (LPARAM) infoPtr);
	}
    }
    if (events & (FD_WRITE | FD_CONNECT)) {
	mask |= TCL_WRITABLE;
	if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) {

	    /* connect errors should also fire the readable handler. */


	    mask |= TCL_READABLE;
	}
    }

    if (mask) {
	Tcl_NotifyChannel(infoPtr->channel, mask);
    }







|
|






|
|
|
|
|
|
|











|
|
|
|









|











>
|
>
>







839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907

    if (infoPtr->readyEvents & FD_ACCEPT) {
	TcpAccept(infoPtr);
	return 1;
    }

    /*
     * Mask off unwanted events and compute the read/write mask so we can
     * notify the channel.
     */

    events = infoPtr->readyEvents & infoPtr->watchEvents;

    if (events & FD_CLOSE) {
	/*
	 * If the socket was closed and the channel is still interested in
	 * read events, then we need to ensure that we keep polling for this
	 * event until someone does something with the channel. Note that we
	 * do this before calling Tcl_NotifyChannel so we don't have to watch
	 * out for the channel being deleted out from under us. This may cause
	 * a redundant trip through the event loop, but it's simpler than
	 * trying to do unwind protection.
	 */

	Tcl_Time blockTime = { 0, 0 };
	Tcl_SetMaxBlockTime(&blockTime);
	mask |= TCL_READABLE|TCL_WRITABLE;
    } else if (events & FD_READ) {
	fd_set readFds;
	struct timeval timeout;

	/*
	 * We must check to see if data is really available, since someone
	 * could have consumed the data in the meantime. Turn off async
	 * notification so select will work correctly. If the socket is still
	 * readable, notify the channel driver, otherwise reset the async
	 * select handler and keep waiting.
	 */

	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);

	FD_ZERO(&readFds);
	FD_SET(infoPtr->socket, &readFds);
	timeout.tv_usec = 0;
	timeout.tv_sec = 0;

	if (winSock.select(0, &readFds, NULL, NULL, &timeout) != 0) {
	    mask |= TCL_READABLE;
	} else {
	    infoPtr->readyEvents &= ~(FD_READ);
	    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		    (WPARAM) SELECT, (LPARAM) infoPtr);
	}
    }
    if (events & (FD_WRITE | FD_CONNECT)) {
	mask |= TCL_WRITABLE;
	if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) {
	    /*
	     * Connect errors should also fire the readable handler.
	     */

	    mask |= TCL_READABLE;
	}
    }

    if (mask) {
	Tcl_NotifyChannel(infoPtr->channel, mask);
    }
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998

999


1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
 *----------------------------------------------------------------------
 */

static int
TcpBlockProc(instanceData, mode)
    ClientData	instanceData;	/* The socket to block/un-block. */
    int mode;			/* TCL_MODE_BLOCKING or
                                 * TCL_MODE_NONBLOCKING. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
	infoPtr->flags |= SOCKET_ASYNC;
    } else {
	infoPtr->flags &= ~(SOCKET_ASYNC);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpCloseProc --
 *
 *	This procedure is called by the generic IO level to perform
 *	channel type specific cleanup on a socket based channel
 *	when the channel is closed.
 *
 * Results:
 *	0 if successful, the value of errno if failed.
 *
 * Side effects:
 *	Closes the socket.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static int
TcpCloseProc(instanceData, interp)
    ClientData instanceData;	/* The socket to close. */
    Tcl_Interp *interp;		/* Unused. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    SocketInfo **nextPtrPtr;
    int errorCode = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (SocketsEnabled()) {
        
	/*
         * Clean up the OS socket handle.  The default Windows setting
	 * for a socket is SO_DONTLINGER, which does a graceful shutdown
	 * in the background.
         */
    
        if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) {
            TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
            errorCode = Tcl_GetErrno();
        }
    }

    /*

     * Remove the socket from socketList.


     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
	 nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	if ((*nextPtrPtr) == infoPtr) {
	    (*nextPtrPtr) = infoPtr->nextPtr;
	    break;
	}
    }
    
    SetEvent(tsdPtr->socketListLock);
    ckfree((char *) infoPtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * NewSocketInfo --
 *
 *	This function allocates and initializes a new SocketInfo
 *	structure.
 *
 * Results:
 *	Returns a newly allocated SocketInfo.
 *
 * Side effects:
 *	Adds the socket to the global socket list.
 *
 *----------------------------------------------------------------------
 */

static SocketInfo *
NewSocketInfo(socket)
    SOCKET socket;







|
















|
|
|

















|




|
|
|
<



<

|
|
|
|
|
|
|
|
|



>
|
>
>


<
<
<
<
<
<
<
<
<
<









|
<





|







924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975

976
977
978

979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997










998
999
1000
1001
1002
1003
1004
1005
1006
1007

1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
 *----------------------------------------------------------------------
 */

static int
TcpBlockProc(instanceData, mode)
    ClientData	instanceData;	/* The socket to block/un-block. */
    int mode;			/* TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
	infoPtr->flags |= SOCKET_ASYNC;
    } else {
	infoPtr->flags &= ~(SOCKET_ASYNC);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpCloseProc --
 *
 *	This function is called by the generic IO level to perform channel
 *	type specific cleanup on a socket based channel when the channel is
 *	closed.
 *
 * Results:
 *	0 if successful, the value of errno if failed.
 *
 * Side effects:
 *	Closes the socket.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
static int
TcpCloseProc(instanceData, interp)
    ClientData instanceData;	/* The socket to close. */
    Tcl_Interp *interp;		/* Unused. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    /* TIP #218 */
    int errorCode = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (SocketsEnabled()) {

	/*
	 * Clean up the OS socket handle. The default Windows setting for a
	 * socket is SO_DONTLINGER, which does a graceful shutdown in the
	 * background.
	 */

	if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) {
	    TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
	    errorCode = Tcl_GetErrno();
	}
    }

    /*
     * TIP #218. Removed the code removing the structure from the global
     * socket list. This is now done by the thread action callbacks, and only
     * there. This happens before this code is called. We can free without
     * fear of damaging the list.
     */











    ckfree((char *) infoPtr);
    return errorCode;
}

/*
 *----------------------------------------------------------------------
 *
 * NewSocketInfo --
 *
 *	This function allocates and initializes a new SocketInfo structure.

 *
 * Results:
 *	Returns a newly allocated SocketInfo.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static SocketInfo *
NewSocketInfo(socket)
    SOCKET socket;
1045
1046
1047
1048
1049
1050
1051





1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194

1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
    infoPtr->readyEvents = 0;
    infoPtr->selectEvents = 0;
    infoPtr->acceptEventCount = 0;
    infoPtr->acceptProc = NULL;
    infoPtr->acceptProcData = NULL;
    infoPtr->lastError = 0;






    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    infoPtr->nextPtr = tsdPtr->socketList;
    tsdPtr->socketList = infoPtr;
    SetEvent(tsdPtr->socketListLock);
    
    return infoPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocket --
 *
 *	This function opens a new socket and initializes the
 *	SocketInfo structure.
 *
 * Results:
 *	Returns a new SocketInfo, or NULL with an error in interp.
 *
 * Side effects:
 *	Adds a new socket to the socketList.
 *
 *----------------------------------------------------------------------
 */

static SocketInfo *
CreateSocket(interp, port, host, server, myaddr, myport, async)
    Tcl_Interp *interp;		/* For error reporting; can be NULL. */
    int port;			/* Port number to open. */
    CONST char *host;		/* Name of host on which to open port. */
    int server;			/* 1 if socket should be a server socket,
				 * else 0 for a client socket. */
    CONST char *myaddr;		/* Optional client-side address */
    int myport;			/* Optional client-side port */
    int async;			/* If nonzero, connect client socket
				 * asynchronously. */
{
    u_long flag = 1;		/* Indicates nonblocking mode. */
    int asyncConnect = 0;	/* Will be 1 if async connect is
				 * in progress. */
    SOCKADDR_IN sockaddr;	/* Socket address */
    SOCKADDR_IN mysockaddr;	/* Socket address for client */
    SOCKET sock;
    SocketInfo *infoPtr;	/* The returned value. */
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        return NULL;
    }

    if (! CreateSocketAddress(&sockaddr, host, port)) {
	goto error;
    }
    if ((myaddr != NULL || myport != 0) &&
	    ! CreateSocketAddress(&mysockaddr, myaddr, myport)) {
	goto error;
    }

    sock = winSock.socket(AF_INET, SOCK_STREAM, 0);
    if (sock == INVALID_SOCKET) {
	goto error;
    }

    /*
     * Win-NT has a misfeature that sockets are inherited in child
     * processes by default.  Turn off the inherit bit.
     */

    SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 );
	
    /*
     * Set kernel space buffering
     */

    TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE);

    if (server) {
	/*
	 * Bind to the specified port.  Note that we must not call setsockopt
	 * with SO_REUSEADDR because Microsoft allows addresses to be reused
	 * even if they are still in use.
         *
         * Bind should not be affected by the socket having already been
         * set into nonblocking mode. If there is trouble, this is one place
         * to look for bugs.
	 */
    
	if (winSock.bind(sock, (SOCKADDR *) &sockaddr,
		sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
            goto error;
        }

        /*
         * Set the maximum number of pending connect requests to the
         * max value allowed on each platform (Win32 and Win32s may be
         * different, and there may be differences between TCP/IP stacks).
         */
        
	if (winSock.listen(sock, SOMAXCONN) == SOCKET_ERROR) {
	    goto error;
	}

	/*
	 * Add this socket to the global list of sockets.
	 */

	infoPtr = NewSocketInfo(sock);

	/*
	 * Set up the select mask for connection request events.
	 */

	infoPtr->selectEvents = FD_ACCEPT;
	infoPtr->watchEvents |= FD_ACCEPT;

    } else {

        /*
         * Try to bind to a local port, if specified.
         */
        
	if (myaddr != NULL || myport != 0) { 
	    if (winSock.bind(sock, (SOCKADDR *) &mysockaddr,
		    sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
		goto error;
	    }
	}            
    
	/*
	 * Set the socket into nonblocking mode if the connect should be
	 * done in the background.
	 */
    
	if (async) {
	    if (winSock.ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) {

		goto error;
	    }
	}

	/*
	 * Attempt to connect to the remote socket.
	 */

	if (winSock.connect(sock, (SOCKADDR *) &sockaddr,
		sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
            TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
	    if (Tcl_GetErrno() != EWOULDBLOCK) {
		goto error;
	    }

	    /*
	     * The connection is progressing in the background.
	     */

	    asyncConnect = 1;
        }

	/*
	 * Add this socket to the global list of sockets.
	 */

	infoPtr = NewSocketInfo(sock);

	/*
	 * Set up the select mask for read/write events.  If the connect
	 * attempt has not completed, include connect events.
	 */

	infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
	if (asyncConnect) {
	    infoPtr->flags |= SOCKET_ASYNC_CONNECT;
	    infoPtr->selectEvents |= FD_CONNECT;
	}
    }

    /*
     * Register for interest in events in the select mask.  Note that this
     * automatically places the socket into non-blocking mode.
     */

    winSock.ioctlsocket(sock, (long) FIONBIO, &flag);
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);

    return infoPtr;

error:
    TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open socket: ",
		Tcl_PosixError(interp), (char *) NULL);
    }
    if (sock != INVALID_SOCKET) {
	winSock.closesocket(sock);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocketAddress --
 *
 *	This function initializes a sockaddr structure for a host and port.
 *
 * Results:
 *	1 if the host was valid, 0 if the host could not be converted to
 *	an IP address.
 *
 * Side effects:
 *	Fills in the *sockaddrPtr structure.
 *
 *----------------------------------------------------------------------
 */

static int
CreateSocketAddress(sockaddrPtr, host, port)
    LPSOCKADDR_IN sockaddrPtr;		/* Socket address */
    CONST char *host;			/* Host.  NULL implies INADDR_ANY */
    int port;				/* Port number */
{
    struct hostent *hostent;		/* Host database entry */
    struct in_addr addr;		/* For 64/32 bit madness */

    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        Tcl_SetErrno(EFAULT);
        return 0;
    }

    ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN));
    sockaddrPtr->sin_family = AF_INET;
    sockaddrPtr->sin_port = winSock.htons((u_short) (port & 0xFFFF));
    if (host == NULL) {
	addr.s_addr = INADDR_ANY;
    } else {
        addr.s_addr = winSock.inet_addr(host);
        if (addr.s_addr == INADDR_NONE) {
            hostent = winSock.gethostbyname(host);
            if (hostent != NULL) {
                memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length);
            } else {
#ifdef	EHOSTUNREACH
                Tcl_SetErrno(EHOSTUNREACH);
#else
#ifdef ENXIO
                Tcl_SetErrno(ENXIO);
#endif
#endif
		return 0;	/* Error. */
	    }
	}
    }

    /*
     * NOTE: On 64 bit machines the assignment below is rumored to not
     * do the right thing. Please report errors related to this if you
     * observe incorrect behavior on 64 bit machines such as DEC Alphas.
     * Should we modify this code to do an explicit memcpy?
     */

    sockaddrPtr->sin_addr.s_addr = addr.s_addr;
    return 1;	/* Success. */
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForSocketEvent --
 *







>
>
>
>
>
|
|
<
<
|








|
|





|









|
|






|
|




|
|


|
|
|
<



|


|



|









|
|


|
|








|


|
|
|
|

|


|
|

|
|
|
|
|
|


















<
|
|
|
|
|




|
|

|
|

|

|
>










|









|








|











|









|



















|
|









|
|
|

|
|


|
|
|
<



|
|








|
|
|
|
|
|

|


|








|
|
|
|



|







1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043


1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090

1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162

1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274

1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
    infoPtr->readyEvents = 0;
    infoPtr->selectEvents = 0;
    infoPtr->acceptEventCount = 0;
    infoPtr->acceptProc = NULL;
    infoPtr->acceptProcData = NULL;
    infoPtr->lastError = 0;

    /*
     * TIP #218. Removed the code inserting the new structure into the global
     * list. This is now handled in the thread action callbacks, and only
     * there.
     */

    infoPtr->nextPtr = NULL;



    return infoPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocket --
 *
 *	This function opens a new socket and initializes the SocketInfo
 *	structure.
 *
 * Results:
 *	Returns a new SocketInfo, or NULL with an error in interp.
 *
 * Side effects:
 *	None, except for allocation of memory.
 *
 *----------------------------------------------------------------------
 */

static SocketInfo *
CreateSocket(interp, port, host, server, myaddr, myport, async)
    Tcl_Interp *interp;		/* For error reporting; can be NULL. */
    int port;			/* Port number to open. */
    CONST char *host;		/* Name of host on which to open port. */
    int server;			/* 1 if socket should be a server socket, else
				 * 0 for a client socket. */
    CONST char *myaddr;		/* Optional client-side address */
    int myport;			/* Optional client-side port */
    int async;			/* If nonzero, connect client socket
				 * asynchronously. */
{
    u_long flag = 1;		/* Indicates nonblocking mode. */
    int asyncConnect = 0;	/* Will be 1 if async connect is in
				 * progress. */
    SOCKADDR_IN sockaddr;	/* Socket address */
    SOCKADDR_IN mysockaddr;	/* Socket address for client */
    SOCKET sock;
    SocketInfo *infoPtr;	/* The returned value. */
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	return NULL;
    }

    if (!CreateSocketAddress(&sockaddr, host, port)) {
	goto error;
    }
    if ((myaddr != NULL || myport != 0) &&
	    !CreateSocketAddress(&mysockaddr, myaddr, myport)) {
	goto error;
    }

    sock = winSock.socket(AF_INET, SOCK_STREAM, 0);
    if (sock == INVALID_SOCKET) {
	goto error;
    }

    /*
     * Win-NT has a misfeature that sockets are inherited in child processes
     * by default. Turn off the inherit bit.
     */

    SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);

    /*
     * Set kernel space buffering
     */

    TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE);

    if (server) {
	/*
	 * Bind to the specified port. Note that we must not call setsockopt
	 * with SO_REUSEADDR because Microsoft allows addresses to be reused
	 * even if they are still in use.
	 *
	 * Bind should not be affected by the socket having already been set
	 * into nonblocking mode. If there is trouble, this is one place to
	 * look for bugs.
	 */

	if (winSock.bind(sock, (SOCKADDR *) &sockaddr,
		sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
	    goto error;
	}

	/*
	 * Set the maximum number of pending connect requests to the max value
	 * allowed on each platform (Win32 and Win32s may be different, and
	 * there may be differences between TCP/IP stacks).
	 */

	if (winSock.listen(sock, SOMAXCONN) == SOCKET_ERROR) {
	    goto error;
	}

	/*
	 * Add this socket to the global list of sockets.
	 */

	infoPtr = NewSocketInfo(sock);

	/*
	 * Set up the select mask for connection request events.
	 */

	infoPtr->selectEvents = FD_ACCEPT;
	infoPtr->watchEvents |= FD_ACCEPT;

    } else {

	/*
	 * Try to bind to a local port, if specified.
	 */

	if (myaddr != NULL || myport != 0) {
	    if (winSock.bind(sock, (SOCKADDR *) &mysockaddr,
		    sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
		goto error;
	    }
	}

	/*
	 * Set the socket into nonblocking mode if the connect should be done
	 * in the background.
	 */

	if (async) {
	    if (winSock.ioctlsocket(sock, (long) FIONBIO,
		    &flag) == SOCKET_ERROR) {
		goto error;
	    }
	}

	/*
	 * Attempt to connect to the remote socket.
	 */

	if (winSock.connect(sock, (SOCKADDR *) &sockaddr,
		sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
	    TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
	    if (Tcl_GetErrno() != EWOULDBLOCK) {
		goto error;
	    }

	    /*
	     * The connection is progressing in the background.
	     */

	    asyncConnect = 1;
	}

	/*
	 * Add this socket to the global list of sockets.
	 */

	infoPtr = NewSocketInfo(sock);

	/*
	 * Set up the select mask for read/write events. If the connect
	 * attempt has not completed, include connect events.
	 */

	infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
	if (asyncConnect) {
	    infoPtr->flags |= SOCKET_ASYNC_CONNECT;
	    infoPtr->selectEvents |= FD_CONNECT;
	}
    }

    /*
     * Register for interest in events in the select mask. Note that this
     * automatically places the socket into non-blocking mode.
     */

    winSock.ioctlsocket(sock, (long) FIONBIO, &flag);
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);

    return infoPtr;

  error:
    TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open socket: ",
		Tcl_PosixError(interp), (char *) NULL);
    }
    if (sock != INVALID_SOCKET) {
	winSock.closesocket(sock);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * CreateSocketAddress --
 *
 *	This function initializes a sockaddr structure for a host and port.
 *
 * Results:
 *	1 if the host was valid, 0 if the host could not be converted to an IP
 *	address.
 *
 * Side effects:
 *	Fills in the *sockaddrPtr structure.
 *
 *----------------------------------------------------------------------
 */

static int
CreateSocketAddress(sockaddrPtr, host, port)
    LPSOCKADDR_IN sockaddrPtr;	/* Socket address */
    CONST char *host;		/* Host. NULL implies INADDR_ANY */
    int port;			/* Port number */
{
    struct hostent *hostent;	/* Host database entry */
    struct in_addr addr;	/* For 64/32 bit madness */

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	Tcl_SetErrno(EFAULT);
	return 0;
    }

    ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN));
    sockaddrPtr->sin_family = AF_INET;
    sockaddrPtr->sin_port = winSock.htons((u_short) (port & 0xFFFF));
    if (host == NULL) {
	addr.s_addr = INADDR_ANY;
    } else {
	addr.s_addr = winSock.inet_addr(host);
	if (addr.s_addr == INADDR_NONE) {
	    hostent = winSock.gethostbyname(host);
	    if (hostent != NULL) {
		memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length);
	    } else {
#ifdef	EHOSTUNREACH
		Tcl_SetErrno(EHOSTUNREACH);
#else
#ifdef ENXIO
		Tcl_SetErrno(ENXIO);
#endif
#endif
		return 0;	/* Error. */
	    }
	}
    }

    /*
     * NOTE: On 64 bit machines the assignment below is rumored to not do the
     * right thing. Please report errors related to this if you observe
     * incorrect behavior on 64 bit machines such as DEC Alphas. Should we
     * modify this code to do an explicit memcpy?
     */

    sockaddrPtr->sin_addr.s_addr = addr.s_addr;
    return 1;			/* Success. */
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForSocketEvent --
 *
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391

1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
WaitForSocketEvent(infoPtr, events, errorCodePtr)
    SocketInfo *infoPtr;	/* Information about this socket. */
    int events;			/* Events to look for. */
    int *errorCodePtr;		/* Where to store errors? */
{
    int result = 1;
    int oldMode;
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    /*
     * Be sure to disable event servicing so we are truly modal.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
    
    /*
     * Reset WSAAsyncSelect so we have a fresh set of events pending.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) UNSELECT, (LPARAM) infoPtr);

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);

    while (1) {

	if (infoPtr->lastError) {
	    *errorCodePtr = infoPtr->lastError;
	    result = 0;
	    break;
	} else if (infoPtr->readyEvents & events) {
	    break;
	} else if (infoPtr->flags & SOCKET_ASYNC) {
	    *errorCodePtr = EWOULDBLOCK;
	    result = 0;
	    break;
	}

	/*
	 * Wait until something happens.
	 */

	WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
    }
    
    (void) Tcl_SetServiceMode(oldMode);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpClient --
 *
 *	Opens a TCP client socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed.  An error message is returned
 *	in the interpreter on failure.
 *
 * Side effects:
 *	Opens a client socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
    Tcl_Interp *interp;			/* For error reporting; can be NULL. */
    int port;				/* Port number to open. */
    CONST char *host;			/* Host on which to open port. */
    CONST char *myaddr;			/* Client-side address */
    int myport;				/* Client-side port */
    int async;				/* If nonzero, should connect
                                         * client socket asynchronously. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }







|
|






|











<















>


|












|
|









|
|
|
|
|
|
|







1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361

1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
WaitForSocketEvent(infoPtr, events, errorCodePtr)
    SocketInfo *infoPtr;	/* Information about this socket. */
    int events;			/* Events to look for. */
    int *errorCodePtr;		/* Where to store errors? */
{
    int result = 1;
    int oldMode;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    /*
     * Be sure to disable event servicing so we are truly modal.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);

    /*
     * Reset WSAAsyncSelect so we have a fresh set of events pending.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) UNSELECT, (LPARAM) infoPtr);

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);

    while (1) {

	if (infoPtr->lastError) {
	    *errorCodePtr = infoPtr->lastError;
	    result = 0;
	    break;
	} else if (infoPtr->readyEvents & events) {
	    break;
	} else if (infoPtr->flags & SOCKET_ASYNC) {
	    *errorCodePtr = EWOULDBLOCK;
	    result = 0;
	    break;
	}

	/*
	 * Wait until something happens.
	 */

	WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
    }

    (void) Tcl_SetServiceMode(oldMode);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpClient --
 *
 *	Opens a TCP client socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. An error message is returned in the
 *	interpreter on failure.
 *
 * Side effects:
 *	Opens a client socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
    Tcl_Interp *interp;		/* For error reporting; can be NULL. */
    int port;			/* Port number to open. */
    CONST char *host;		/* Host on which to open port. */
    CONST char *myaddr;		/* Client-side address */
    int myport;			/* Client-side port */
    int async;			/* If nonzero, should connect client socket
				 * asynchronously. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461

    wsprintfA(channelName, "sock%d", infoPtr->socket);

    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
        Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
        return (Tcl_Channel) NULL;
    }
    if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
        Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
        return (Tcl_Channel) NULL;
    }
    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *







|
|



|
|







1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447

    wsprintfA(channelName, "sock%d", infoPtr->socket);

    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
	return (Tcl_Channel) NULL;
    }
    if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
	return (Tcl_Channel) NULL;
    }
    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537

1538
1539
1540
1541
1542
1543
1544
1545
1546
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
 *	Opens a TCP server socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed.  An error message is returned
 *	in the interpreter on failure.
 *
 * Side effects:
 *	Opens a server socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
    Tcl_Interp *interp;			/* For error reporting - may be
                                         * NULL. */
    int port;				/* Port number to open. */
    CONST char *host;			/* Name of local host. */
    Tcl_TcpAcceptProc *acceptProc;	/* Callback for accepting connections

                                         * from new clients. */
    ClientData acceptProcData;		/* Data for the callback. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }







|
|









|
<
|
|
|
>
|
|







1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519

1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
 *	Opens a TCP server socket and creates a channel around it.
 *
 * Results:
 *	The channel or NULL if failed. An error message is returned in the
 *	interpreter on failure.
 *
 * Side effects:
 *	Opens a server socket and creates a new channel.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
    Tcl_Interp *interp;		/* For error reporting - may be NULL. */

    int port;			/* Port number to open. */
    CONST char *host;		/* Name of local host. */
    Tcl_TcpAcceptProc *acceptProc;
				/* Callback for accepting connections from new
				 * clients. */
    ClientData acceptProcData;	/* Data for the callback. */
{
    SocketInfo *infoPtr;
    char channelName[16 + TCL_INTEGER_SPACE];

    if (TclpHasSockets(interp) != TCL_OK) {
	return NULL;
    }
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576

1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647

    wsprintfA(channelName, "sock%d", infoPtr->socket);

    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    (ClientData) infoPtr, 0);
    if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
        Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
        return (Tcl_Channel) NULL;
    }

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAccept --

 *	Accept a TCP socket connection.  This is called by
 *	SocketEventProc and it in turns calls the registered accept
 *	procedure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invokes the accept proc which may invoke arbitrary Tcl code.
 *
 *----------------------------------------------------------------------
 */

static void
TcpAccept(infoPtr)
    SocketInfo *infoPtr;	/* Socket to accept. */
{
    SOCKET newSocket;
    SocketInfo *newInfoPtr;
    SOCKADDR_IN addr;
    int len;
    char channelName[16 + TCL_INTEGER_SPACE];
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    /*
     * Accept the incoming connection request.
     */

    len = sizeof(SOCKADDR_IN);

    newSocket = winSock.accept(infoPtr->socket, (SOCKADDR *)&addr,
	    &len);

    /*
     * Clear the ready mask so we can detect the next connection request.
     * Note that connection requests are level triggered, so if there is
     * a request already pending, a new event will be generated.
     */

    if (newSocket == INVALID_SOCKET) {
	infoPtr->acceptEventCount = 0;
	infoPtr->readyEvents &= ~(FD_ACCEPT);
	return;
    }

    /*
     * It is possible that more than one FD_ACCEPT has been sent, so an extra
     * count must be kept.  Decrement the count, and reset the readyEvent bit
     * if the count is no longer > 0.
     */

    infoPtr->acceptEventCount--;

    if (infoPtr->acceptEventCount <= 0) {
	infoPtr->readyEvents &= ~(FD_ACCEPT);
    }

    /*
     * Win-NT has a misfeature that sockets are inherited in child
     * processes by default.  Turn off the inherit bit.
     */

    SetHandleInformation( (HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0 );

    /*
     * Add this socket to the global list of sockets.
     */

    newInfoPtr = NewSocketInfo(newSocket);








|
|









>
|
|
<



















|
|












|
|










|










|
|


|







1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565

1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633

    wsprintfA(channelName, "sock%d", infoPtr->socket);

    infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    (ClientData) infoPtr, 0);
    if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
	return (Tcl_Channel) NULL;
    }

    return infoPtr->channel;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAccept --
 *
 *	Accept a TCP socket connection. This is called by SocketEventProc and
 *	it in turns calls the registered accept function.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invokes the accept proc which may invoke arbitrary Tcl code.
 *
 *----------------------------------------------------------------------
 */

static void
TcpAccept(infoPtr)
    SocketInfo *infoPtr;	/* Socket to accept. */
{
    SOCKET newSocket;
    SocketInfo *newInfoPtr;
    SOCKADDR_IN addr;
    int len;
    char channelName[16 + TCL_INTEGER_SPACE];
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    /*
     * Accept the incoming connection request.
     */

    len = sizeof(SOCKADDR_IN);

    newSocket = winSock.accept(infoPtr->socket, (SOCKADDR *)&addr,
	    &len);

    /*
     * Clear the ready mask so we can detect the next connection request.
     * Note that connection requests are level triggered, so if there is a
     * request already pending, a new event will be generated.
     */

    if (newSocket == INVALID_SOCKET) {
	infoPtr->acceptEventCount = 0;
	infoPtr->readyEvents &= ~(FD_ACCEPT);
	return;
    }

    /*
     * It is possible that more than one FD_ACCEPT has been sent, so an extra
     * count must be kept. Decrement the count, and reset the readyEvent bit
     * if the count is no longer > 0.
     */

    infoPtr->acceptEventCount--;

    if (infoPtr->acceptEventCount <= 0) {
	infoPtr->readyEvents &= ~(FD_ACCEPT);
    }

    /*
     * Win-NT has a misfeature that sockets are inherited in child processes
     * by default. Turn off the inherit bit.
     */

    SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);

    /*
     * Add this socket to the global list of sockets.
     */

    newInfoPtr = NewSocketInfo(newSocket);

1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
    if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
	return;
    }

    /*
     * Invoke the accept callback procedure.
     */

    if (infoPtr->acceptProc != NULL) {
	(infoPtr->acceptProc) (infoPtr->acceptProcData,
		newInfoPtr->channel,
		winSock.inet_ntoa(addr.sin_addr),
		winSock.ntohs(addr.sin_port));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpInputProc --
 *
 *	This procedure is called by the generic IO level to read data from
 *	a socket based channel.
 *
 * Results:
 *	The number of bytes read or -1 on error.
 *
 * Side effects:
 *	Consumes input from the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;		/* The socket state. */
    char *buf;				/* Where to store data. */
    int toRead;				/* Maximum number of bytes to read. */
    int *errorCodePtr;			/* Where to store error codes. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    int bytesRead;
    DWORD error;
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    
    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        *errorCodePtr = EFAULT;
        return -1;
    }

    /*
     * First check to see if EOF was already detected, to prevent
     * calling the socket stack after the first time EOF is detected.
     */

    if (infoPtr->flags & SOCKET_EOF) {
	return 0;
    }

    /*
     * Check to see if the socket is connected before trying to read.
     */

    if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
	    && ! WaitForSocketEvent(infoPtr,  FD_CONNECT, errorCodePtr)) {
	return -1;
    }
    
    /*
     * No EOF, and it is connected, so try to read more from the socket.
     * Note that we clear the FD_READ bit because read events are level
     * triggered so a new event will be generated if there is still data
     * available to be read.  We have to simulate blocking behavior here
     * since we are always using non-blocking sockets.
     */

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);
	bytesRead = winSock.recv(infoPtr->socket, buf, toRead, 0);
	infoPtr->readyEvents &= ~(FD_READ);
  
	/*
	 * Check for end-of-file condition or successful read.
	 */
  
	if (bytesRead == 0) {
	    infoPtr->flags |= SOCKET_EOF;
	}
	if (bytesRead != SOCKET_ERROR) {
	    break;
	}
  
	/*
	 * If an error occurs after the FD_CLOSE has arrived,
	 * then ignore the error and report an EOF.
	 */
  
	if (infoPtr->readyEvents & FD_CLOSE) {
	    infoPtr->flags |= SOCKET_EOF;
	    bytesRead = 0;
	    break;
	}
  
	/*
	 * Check for error condition or underflow in non-blocking case.
	 */
  
	error = winSock.WSAGetLastError();
	if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
	    TclWinConvertWSAError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesRead = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes readable
	 * or closed and try again.
	 */

	if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
	    bytesRead = -1;
	    break;
  	}
    }
    
    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);
    
    return bytesRead;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpOutputProc --
 *
 *	This procedure is called by the generic IO level to write data
 *	to a socket based channel.
 *
 * Results:
 *	The number of bytes written or -1 on failure.
 *
 * Side effects:
 *	Produces output on the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;		/* The socket state. */
    CONST char *buf;			/* Where to get data. */
    int toWrite;			/* Maximum number of bytes to write. */
    int *errorCodePtr;			/* Where to store error codes. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    int bytesWritten;
    DWORD error;
    ThreadSpecificData *tsdPtr = 
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        *errorCodePtr = EFAULT;
        return -1;
    }

    /*
     * Check to see if the socket is connected before trying to write.
     */
    
    if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
	    && ! WaitForSocketEvent(infoPtr,  FD_CONNECT, errorCodePtr)) {
	return -1;
    }

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);

	bytesWritten = winSock.send(infoPtr->socket, buf, toWrite, 0);
	if (bytesWritten != SOCKET_ERROR) {
	    /*
	     * Since Windows won't generate a new write event until we hit
	     * an overflow condition, we need to force the event loop to
	     * poll until the condition changes.
	     */

	    if (infoPtr->watchEvents & FD_WRITE) {
		Tcl_Time blockTime = { 0, 0 };
		Tcl_SetMaxBlockTime(&blockTime);
	    }		
	    break;
	}
	
	/*
	 * Check for error condition or overflow.  In the event of overflow, we
	 * need to clear the FD_WRITE flag so we can detect the next writable
	 * event.  Note that Windows only sends a new writable event after a
	 * send fails with WSAEWOULDBLOCK.
	 */

	error = winSock.WSAGetLastError();
	if (error == WSAEWOULDBLOCK) {
	    infoPtr->readyEvents &= ~(FD_WRITE);
	    if (infoPtr->flags & SOCKET_ASYNC) {
		*errorCodePtr = EWOULDBLOCK;
		bytesWritten = -1;
		break;
	    } 
	} else {
	    TclWinConvertWSAError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesWritten = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes writable
	 * or closed and try again.
	 */

	if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
	    bytesWritten = -1;
	    break;
	}
    }

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);
    
    return bytesWritten;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpSetOptionProc --







|



|
<










|
|












|
|
|
|




|

|



|
|
|
<



|
|



|
|














|

|
|
|
|
|







|



|






|

|
|

|





|



|









|
|





|

|


|








|
|












|
|
|
|




|





|
|
|
<



|
|





|












|
|
|





|


|

|

|










|








|
|










|







1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661

1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702

1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828

1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
    if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
	    == TCL_ERROR) {
	Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
	return;
    }

    /*
     * Invoke the accept callback function.
     */

    if (infoPtr->acceptProc != NULL) {
	(infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel,

		winSock.inet_ntoa(addr.sin_addr),
		winSock.ntohs(addr.sin_port));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpInputProc --
 *
 *	This function is called by the generic IO level to read data from a
 *	socket based channel.
 *
 * Results:
 *	The number of bytes read or -1 on error.
 *
 * Side effects:
 *	Consumes input from the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpInputProc(instanceData, buf, toRead, errorCodePtr)
    ClientData instanceData;	/* The socket state. */
    char *buf;			/* Where to store data. */
    int toRead;			/* Maximum number of bytes to read. */
    int *errorCodePtr;		/* Where to store error codes. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    int bytesRead;
    DWORD error;
    ThreadSpecificData *tsdPtr =
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	*errorCodePtr = EFAULT;
	return -1;
    }

    /*
     * First check to see if EOF was already detected, to prevent calling the
     * socket stack after the first time EOF is detected.
     */

    if (infoPtr->flags & SOCKET_EOF) {
	return 0;
    }

    /*
     * Check to see if the socket is connected before trying to read.
     */

    if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
	    && ! WaitForSocketEvent(infoPtr,  FD_CONNECT, errorCodePtr)) {
	return -1;
    }

    /*
     * No EOF, and it is connected, so try to read more from the socket. Note
     * that we clear the FD_READ bit because read events are level triggered
     * so a new event will be generated if there is still data available to be
     * read. We have to simulate blocking behavior here since we are always
     * using non-blocking sockets.
     */

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);
	bytesRead = winSock.recv(infoPtr->socket, buf, toRead, 0);
	infoPtr->readyEvents &= ~(FD_READ);

	/*
	 * Check for end-of-file condition or successful read.
	 */

	if (bytesRead == 0) {
	    infoPtr->flags |= SOCKET_EOF;
	}
	if (bytesRead != SOCKET_ERROR) {
	    break;
	}

	/*
	 * If an error occurs after the FD_CLOSE has arrived, then ignore the
	 * error and report an EOF.
	 */

	if (infoPtr->readyEvents & FD_CLOSE) {
	    infoPtr->flags |= SOCKET_EOF;
	    bytesRead = 0;
	    break;
	}

	/*
	 * Check for error condition or underflow in non-blocking case.
	 */

	error = winSock.WSAGetLastError();
	if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
	    TclWinConvertWSAError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesRead = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes readable or
	 * closed and try again.
	 */

	if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
	    bytesRead = -1;
	    break;
	}
    }

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);

    return bytesRead;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpOutputProc --
 *
 *	This function is called by the generic IO level to write data to a
 *	socket based channel.
 *
 * Results:
 *	The number of bytes written or -1 on failure.
 *
 * Side effects:
 *	Produces output on the socket.
 *
 *----------------------------------------------------------------------
 */

static int
TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
    ClientData instanceData;	/* The socket state. */
    CONST char *buf;		/* Where to get data. */
    int toWrite;		/* Maximum number of bytes to write. */
    int *errorCodePtr;		/* Where to store error codes. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    int bytesWritten;
    DWORD error;
    ThreadSpecificData *tsdPtr =
	(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    *errorCodePtr = 0;

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	*errorCodePtr = EFAULT;
	return -1;
    }

    /*
     * Check to see if the socket is connected before trying to write.
     */

    if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
	    && ! WaitForSocketEvent(infoPtr,  FD_CONNECT, errorCodePtr)) {
	return -1;
    }

    while (1) {
	SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);

	bytesWritten = winSock.send(infoPtr->socket, buf, toWrite, 0);
	if (bytesWritten != SOCKET_ERROR) {
	    /*
	     * Since Windows won't generate a new write event until we hit an
	     * overflow condition, we need to force the event loop to poll
	     * until the condition changes.
	     */

	    if (infoPtr->watchEvents & FD_WRITE) {
		Tcl_Time blockTime = { 0, 0 };
		Tcl_SetMaxBlockTime(&blockTime);
	    }
	    break;
	}

	/*
	 * Check for error condition or overflow. In the event of overflow, we
	 * need to clear the FD_WRITE flag so we can detect the next writable
	 * event. Note that Windows only sends a new writable event after a
	 * send fails with WSAEWOULDBLOCK.
	 */

	error = winSock.WSAGetLastError();
	if (error == WSAEWOULDBLOCK) {
	    infoPtr->readyEvents &= ~(FD_WRITE);
	    if (infoPtr->flags & SOCKET_ASYNC) {
		*errorCodePtr = EWOULDBLOCK;
		bytesWritten = -1;
		break;
	    }
	} else {
	    TclWinConvertWSAError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesWritten = -1;
	    break;
	}

	/*
	 * In the blocking case, wait until the file becomes writable or
	 * closed and try again.
	 */

	if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
	    bytesWritten = -1;
	    break;
	}
    }

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
	    (WPARAM) SELECT, (LPARAM) infoPtr);

    return bytesWritten;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpSetOptionProc --
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
    SocketInfo *infoPtr;
    SOCKET sock;
/*
    BOOL val = FALSE;
    int boolVar, rtn;
*/
    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_AppendResult(interp, "winsock is not initialized", NULL);
	}
        return TCL_ERROR;
    }

    infoPtr = (SocketInfo *) instanceData;
    sock = infoPtr->socket;

/*
    if (!stricmp(optionName, "-keepalive")) {







|
|
|
<






|







1926
1927
1928
1929
1930
1931
1932
1933
1934
1935

1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
    SocketInfo *infoPtr;
    SOCKET sock;
/*
    BOOL val = FALSE;
    int boolVar, rtn;
*/
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_AppendResult(interp, "winsock is not initialized", NULL);
	}
	return TCL_ERROR;
    }

    infoPtr = (SocketInfo *) instanceData;
    sock = infoPtr->socket;

/*
    if (!stricmp(optionName, "-keepalive")) {
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125

2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetOptionProc --
 *
 *	Computes an option value for a TCP socket based channel, or a
 *	list of all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a
 *	list of all options and	their values is returned in the
 *	supplied DString.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;		/* Socket state. */
    Tcl_Interp *interp;                 /* For error reporting - can be NULL */
    CONST char *optionName;		/* Name of the option to
                                         * retrieve the value for, or
                                         * NULL to get all options and
                                         * their values. */
    Tcl_DString *dsPtr;			/* Where to store the computed
                                         * value; initialized by caller. */
{
    SocketInfo *infoPtr;
    SOCKADDR_IN sockname;
    SOCKADDR_IN peername;
    struct hostent *hostEntPtr;
    SOCKET sock;
    int size = sizeof(SOCKADDR_IN);
    size_t len = 0;
    char buf[TCL_INTEGER_SPACE];

    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_AppendResult(interp, "winsock is not initialized", NULL);
	}
        return TCL_ERROR;
    }
    
    infoPtr = (SocketInfo *) instanceData;
    sock = (int) infoPtr->socket;
    if (optionName != (char *) NULL) {
        len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	int optlen;
	DWORD err;
	int ret;
    
	optlen = sizeof(int);
	ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
		(char *)&err, &optlen);
	if (ret == SOCKET_ERROR) {
	    err = winSock.WSAGetLastError();
	}
	if (err) {
	    TclWinConvertWSAError(err);
	    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
	}
	return TCL_OK;
    }

    if ((len == 0) ||
            ((len > 1) && (optionName[1] == 'p') &&
                    (strncmp(optionName, "-peername", len) == 0))) {
        if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size)
                == 0) {
            if (len == 0) {
                Tcl_DStringAppendElement(dsPtr, "-peername");
                Tcl_DStringStartSublist(dsPtr);
            }
            Tcl_DStringAppendElement(dsPtr,
                    winSock.inet_ntoa(peername.sin_addr));

	    if (peername.sin_addr.s_addr == 0) {
	        hostEntPtr = (struct hostent *) NULL;
	    } else {
	        hostEntPtr = winSock.gethostbyaddr(
                    (char *) &(peername.sin_addr), sizeof(peername.sin_addr),
		    AF_INET);
	    }
            if (hostEntPtr != (struct hostent *) NULL) {
                Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
            } else {
                Tcl_DStringAppendElement(dsPtr,
                        winSock.inet_ntoa(peername.sin_addr));
            }
	    TclFormatInt(buf, winSock.ntohs(peername.sin_port));
            Tcl_DStringAppendElement(dsPtr, buf);
            if (len == 0) {
                Tcl_DStringEndSublist(dsPtr);
            } else {
                return TCL_OK;
            }
        } else {
            /*
             * getpeername failed - but if we were asked for all the options
             * (len==0), don't flag an error at that point because it could
             * be an fconfigure request on a server socket. (which have
             * no peer). {copied from unix/tclUnixChan.c}
             */

            if (len) {
		TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
                if (interp) {
                    Tcl_AppendResult(interp, "can't get peername: ",
                                     Tcl_PosixError(interp),
                                     (char *) NULL);
                }
                return TCL_ERROR;
            }
        }
    }

    if ((len == 0) ||
            ((len > 1) && (optionName[1] == 's') &&
                    (strncmp(optionName, "-sockname", len) == 0))) {
        if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size)
                == 0) {
            if (len == 0) {
                Tcl_DStringAppendElement(dsPtr, "-sockname");
                Tcl_DStringStartSublist(dsPtr);
            }
            Tcl_DStringAppendElement(dsPtr,
                    winSock.inet_ntoa(sockname.sin_addr));
	    if (sockname.sin_addr.s_addr == 0) {
	        hostEntPtr = (struct hostent *) NULL;
	    } else {
	        hostEntPtr = winSock.gethostbyaddr(
                    (char *) &(sockname.sin_addr), sizeof(peername.sin_addr),
		    AF_INET);
	    }
            if (hostEntPtr != (struct hostent *) NULL) {
                Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
            } else {
                Tcl_DStringAppendElement(dsPtr,
                        winSock.inet_ntoa(sockname.sin_addr));
            }
            TclFormatInt(buf, winSock.ntohs(sockname.sin_port));
            Tcl_DStringAppendElement(dsPtr, buf);
            if (len == 0) {
                Tcl_DStringEndSublist(dsPtr);
            } else {
                return TCL_OK;
            }
        } else {
	    if (interp) {
		TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
		Tcl_AppendResult(interp, "can't get sockname: ",
				 Tcl_PosixError(interp),
				 (char *) NULL);
	    }
	    return TCL_ERROR;
	}
    }

/*
    if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
	int optlen;
	BOOL opt = FALSE;
    
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-keepalive");
        }
	optlen = sizeof(BOOL);
	winSock.getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt,
		&optlen);
	if (opt) {
	    Tcl_DStringAppendElement(dsPtr, "1");
	} else {
	    Tcl_DStringAppendElement(dsPtr, "0");
	}
	if (len > 0) {
	    return TCL_OK;
	}
    }

    if (len == 0 || !strncmp(optionName, "-nagle", len)) {
	int optlen;
	BOOL opt = FALSE;
    
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-nagle");
        }
	optlen = sizeof(BOOL);
	winSock.getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt,
		&optlen);
	if (opt) {
	    Tcl_DStringAppendElement(dsPtr, "0");
	} else {
	    Tcl_DStringAppendElement(dsPtr, "1");
	}
	if (len > 0) {
	    return TCL_OK;
	}
    }
*/

    if (len > 0) {
        /*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/
        return Tcl_BadChannelOption(interp, optionName, "peername sockname");
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpWatchProc --
 *
 *	Informs the channel driver of the events that the generic
 *	channel code wishes to receive on this socket.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May cause the notifier to poll if any of the specified 
 *	conditions are already true.
 *
 *----------------------------------------------------------------------
 */

static void
TcpWatchProc(instanceData, mask)
    ClientData instanceData;		/* The socket state. */
    int mask;				/* Events of interest; an OR-ed
                                         * combination of TCL_READABLE,
                                         * TCL_WRITABLE and TCL_EXCEPTION. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    
    /*
     * Update the watch events mask. Only if the socket is not a
     * server socket. Fix for SF Tcl Bug #557878.
     */

    if (!infoPtr->acceptProc) {    
        infoPtr->watchEvents = 0;
	if (mask & TCL_READABLE) {
	    infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
	}
	if (mask & TCL_WRITABLE) {
	    infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT);
	}
      
	/*
	 * If there are any conditions already set, then tell the notifier to poll
	 * rather than block.
	 */

	if (infoPtr->readyEvents & infoPtr->watchEvents) {
	    Tcl_Time blockTime = { 0, 0 };
	    Tcl_SetMaxBlockTime(&blockTime);
	}
    }







|
|




|
|
<









|
|
|
<
|
|
|
|











|
|
|
<






|

|



|







|













<
|
|
|
<
|
|
|
|
|
|


|

|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
>
|

|
|
|
<
|
|
|
|


<
|
|
|
<
|
|
|
|
|
|

|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|



|
<









|
|
|
|
















|
|
|
|















|
|










|
|





|
|






|
|
|
|


|

|
|


|
|






|

|
|







1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001

2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013

2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031

2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065

2066
2067
2068

2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108

2109
2110
2111
2112
2113
2114

2115
2116
2117

2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148

2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetOptionProc --
 *
 *	Computes an option value for a TCP socket based channel, or a list of
 *	all options and their values.
 *
 *	Note: This code is based on code contributed by John Haxby.
 *
 * Results:
 *	A standard Tcl result. The value of the specified option or a list of
 *	all options and their values is returned in the supplied DString.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
    ClientData instanceData;	/* Socket state. */
    Tcl_Interp *interp;		/* For error reporting - can be NULL */
    CONST char *optionName;	/* Name of the option to retrieve the value

				 * for, or NULL to get all options and their
				 * values. */
    Tcl_DString *dsPtr;		/* Where to store the computed value;
				 * initialized by caller. */
{
    SocketInfo *infoPtr;
    SOCKADDR_IN sockname;
    SOCKADDR_IN peername;
    struct hostent *hostEntPtr;
    SOCKET sock;
    int size = sizeof(SOCKADDR_IN);
    size_t len = 0;
    char buf[TCL_INTEGER_SPACE];

    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	if (interp) {
	    Tcl_AppendResult(interp, "winsock is not initialized", NULL);
	}
	return TCL_ERROR;
    }

    infoPtr = (SocketInfo *) instanceData;
    sock = (int) infoPtr->socket;
    if (optionName != (char *) NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	int optlen;
	DWORD err;
	int ret;

	optlen = sizeof(int);
	ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
		(char *)&err, &optlen);
	if (ret == SOCKET_ERROR) {
	    err = winSock.WSAGetLastError();
	}
	if (err) {
	    TclWinConvertWSAError(err);
	    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
	}
	return TCL_OK;
    }


    if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
	    (strncmp(optionName, "-peername", len) == 0))) {
	if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) {

	    if (len == 0) {
		Tcl_DStringAppendElement(dsPtr, "-peername");
		Tcl_DStringStartSublist(dsPtr);
	    }
	    Tcl_DStringAppendElement(dsPtr,
		    winSock.inet_ntoa(peername.sin_addr));

	    if (peername.sin_addr.s_addr == 0) {
		hostEntPtr = (struct hostent *) NULL;
	    } else {
		hostEntPtr = winSock.gethostbyaddr(
			(char *) &(peername.sin_addr),
			sizeof(peername.sin_addr), AF_INET);
	    }
	    if (hostEntPtr != (struct hostent *) NULL) {
		Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
	    } else {
		Tcl_DStringAppendElement(dsPtr,
			winSock.inet_ntoa(peername.sin_addr));
	    }
	    TclFormatInt(buf, winSock.ntohs(peername.sin_port));
	    Tcl_DStringAppendElement(dsPtr, buf);
	    if (len == 0) {
		Tcl_DStringEndSublist(dsPtr);
	    } else {
		return TCL_OK;
	    }
	} else {
	    /*
	     * getpeername failed - but if we were asked for all the options
	     * (len==0), don't flag an error at that point because it could be
	     * an fconfigure request on a server socket (which have no peer).
	     * {Copied from unix/tclUnixChan.c}
	     */

	    if (len) {
		TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
		if (interp) {
		    Tcl_AppendResult(interp, "can't get peername: ",
			    Tcl_PosixError(interp), (char *) NULL);

		}
		return TCL_ERROR;
	    }
	}
    }


    if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
	    (strncmp(optionName, "-sockname", len) == 0))) {
	if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) {

	    if (len == 0) {
		Tcl_DStringAppendElement(dsPtr, "-sockname");
		Tcl_DStringStartSublist(dsPtr);
	    }
	    Tcl_DStringAppendElement(dsPtr,
		    winSock.inet_ntoa(sockname.sin_addr));
	    if (sockname.sin_addr.s_addr == 0) {
		hostEntPtr = (struct hostent *) NULL;
	    } else {
		hostEntPtr = winSock.gethostbyaddr(
			(char *) &(sockname.sin_addr),
			sizeof(peername.sin_addr), AF_INET);
	    }
	    if (hostEntPtr != (struct hostent *) NULL) {
		Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
	    } else {
		Tcl_DStringAppendElement(dsPtr,
			winSock.inet_ntoa(sockname.sin_addr));
	    }
	    TclFormatInt(buf, winSock.ntohs(sockname.sin_port));
	    Tcl_DStringAppendElement(dsPtr, buf);
	    if (len == 0) {
		Tcl_DStringEndSublist(dsPtr);
	    } else {
		return TCL_OK;
	    }
	} else {
	    if (interp) {
		TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
		Tcl_AppendResult(interp, "can't get sockname: ",
			Tcl_PosixError(interp), (char *) NULL);

	    }
	    return TCL_ERROR;
	}
    }

/*
    if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
	int optlen;
	BOOL opt = FALSE;

	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-keepalive");
	}
	optlen = sizeof(BOOL);
	winSock.getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt,
		&optlen);
	if (opt) {
	    Tcl_DStringAppendElement(dsPtr, "1");
	} else {
	    Tcl_DStringAppendElement(dsPtr, "0");
	}
	if (len > 0) {
	    return TCL_OK;
	}
    }

    if (len == 0 || !strncmp(optionName, "-nagle", len)) {
	int optlen;
	BOOL opt = FALSE;

	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-nagle");
	}
	optlen = sizeof(BOOL);
	winSock.getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt,
		&optlen);
	if (opt) {
	    Tcl_DStringAppendElement(dsPtr, "0");
	} else {
	    Tcl_DStringAppendElement(dsPtr, "1");
	}
	if (len > 0) {
	    return TCL_OK;
	}
    }
*/

    if (len > 0) {
	/*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/
	return Tcl_BadChannelOption(interp, optionName, "peername sockname");
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpWatchProc --
 *
 *	Informs the channel driver of the events that the generic channel code
 *	wishes to receive on this socket.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May cause the notifier to poll if any of the specified conditions are
 *	already true.
 *
 *----------------------------------------------------------------------
 */

static void
TcpWatchProc(instanceData, mask)
    ClientData instanceData;	/* The socket state. */
    int mask;			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    SocketInfo *infoPtr = (SocketInfo *) instanceData;

    /*
     * Update the watch events mask. Only if the socket is not a server
     * socket. Fix for SF Tcl Bug #557878.
     */

    if (!infoPtr->acceptProc) {
	infoPtr->watchEvents = 0;
	if (mask & TCL_READABLE) {
	    infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
	}
	if (mask & TCL_WRITABLE) {
	    infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT);
	}

	/*
	 * If there are any conditions already set, then tell the notifier to
	 * poll rather than block.
	 */

	if (infoPtr->readyEvents & infoPtr->watchEvents) {
	    Tcl_Time blockTime = { 0, 0 };
	    Tcl_SetMaxBlockTime(&blockTime);
	}
    }
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350

static DWORD WINAPI
SocketThread(LPVOID arg)
{
    MSG msg;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg);

    tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket", 
	    WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);

    /*
     * Signal the main thread that the window has been created
     * and that the socket thread is ready to go.
     */
    
    SetEvent(tsdPtr->readyEvent);
    
    if (tsdPtr->hwnd == NULL) {
	return 1;
    }

    /*
     * Process all messages on the socket window until WM_QUIT.
     */







|



|
|

|

|







2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324

static DWORD WINAPI
SocketThread(LPVOID arg)
{
    MSG msg;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg);

    tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket",
	    WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);

    /*
     * Signal the main thread that the window has been created and that the
     * socket thread is ready to go.
     */

    SetEvent(tsdPtr->readyEvent);

    if (tsdPtr->hwnd == NULL) {
	return 1;
    }

    /*
     * Process all messages on the socket window until WM_QUIT.
     */
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381


/*
 *----------------------------------------------------------------------
 *
 * SocketProc --
 *
 *	This function is called when WSAAsyncSelect has been used
 *	to register interest in a socket event, and the event has
 *	occurred.
 *
 * Results:
 *	0 on success.
 *
 * Side effects:
 *	The flags for the given socket are updated to reflect the
 *	event that occured.
 *
 *----------------------------------------------------------------------
 */

static LRESULT CALLBACK
SocketProc(hwnd, message, wParam, lParam)
    HWND hwnd;







|
|
<





|
|







2332
2333
2334
2335
2336
2337
2338
2339
2340

2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354


/*
 *----------------------------------------------------------------------
 *
 * SocketProc --
 *
 *	This function is called when WSAAsyncSelect has been used to register
 *	interest in a socket event, and the event has occurred.

 *
 * Results:
 *	0 on success.
 *
 * Side effects:
 *	The flags for the given socket are updated to reflect the event that
 *	occured.
 *
 *----------------------------------------------------------------------
 */

static LRESULT CALLBACK
SocketProc(hwnd, message, wParam, lParam)
    HWND hwnd;
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529

2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541


2542
2543
2544


2545
2546
2547
2548
2549
2550
2551


2552
2553
2554
2555
2556






2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569




2570


2571
2572
2573
2574
2575


2576

2577

2578



2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628

2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661

2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695

2696





2697



2698

2699




2700




2701

2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720

2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744

2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
#ifdef _WIN64
	(ThreadSpecificData *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
	(ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA);
#endif

    switch (message) {

	default:
	    return DefWindowProc(hwnd, message, wParam, lParam);
	    break;

	case WM_CREATE:
	    /*
	     * store the initial tsdPtr, it's from a different thread, so it's
	     * not directly accessible, but needed.
	     */

#ifdef _WIN64
	    SetWindowLongPtr(hwnd, GWLP_USERDATA,
		    (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#else
	    SetWindowLong(hwnd, GWL_USERDATA,
		    (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#endif
	    break;

	case WM_DESTROY:
	    PostQuitMessage(0);
	    break;

	case SOCKET_MESSAGE:
	    event = WSAGETSELECTEVENT(lParam);
	    error = WSAGETSELECTERROR(lParam);
	    socket = (SOCKET) wParam;

	    /*
	     * Find the specified socket on the socket list and update its
	     * eventState flag.
	     */

	    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	    for (infoPtr = tsdPtr->socketList; infoPtr != NULL; 
		 infoPtr = infoPtr->nextPtr) {
		if (infoPtr->socket == socket) {
		    /*
		     * Update the socket state.
		     */

		    /*
		     * A count of FD_ACCEPTS is stored, so if an FD_CLOSE
		     * event happens, then clear the FD_ACCEPT count.
		     * Otherwise, increment the count if the current
		     * event is an FD_ACCEPT.
		     */

		    if (event & FD_CLOSE) {
			infoPtr->acceptEventCount = 0;
			infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
		    } else if (event & FD_ACCEPT) {
			infoPtr->acceptEventCount++;
		    }

		    if (event & FD_CONNECT) {
			/*
			 * The socket is now connected,
			 * clear the async connect flag.
			 */

			infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);

			/*
			 * Remember any error that occurred so we can report
			 * connection failures.
			 */

			if (error != ERROR_SUCCESS) {
			    TclWinConvertWSAError((DWORD) error);
			    infoPtr->lastError = Tcl_GetErrno();
			}

		    } 
		    if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
			infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
			if (error != ERROR_SUCCESS) {
			    TclWinConvertWSAError((DWORD) error);
			    infoPtr->lastError = Tcl_GetErrno();
			}
			infoPtr->readyEvents |= FD_WRITE;
		    }
		    infoPtr->readyEvents |= event;

		    /*
		     * Wake up the Main Thread.
		     */
		    SetEvent(tsdPtr->readyEvent);
		    Tcl_ThreadAlert(tsdPtr->threadId);
		    break;
		}
	    }
	    SetEvent(tsdPtr->socketListLock);
	    break;

	case SOCKET_SELECT:
	    infoPtr = (SocketInfo *) lParam;
	    if (wParam == SELECT) {

		winSock.WSAAsyncSelect(infoPtr->socket, hwnd,
			SOCKET_MESSAGE, infoPtr->selectEvents);
	    } else {
		/*
		 * Clear the selection mask
		 */

		winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0);
	    }
	    break;

	case SOCKET_TERMINATE:
	    DestroyWindow(hwnd);
	    break;
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetHostName --
 *
 *	Returns the name of the local host.
 *
 * Results:
 *	A string containing the network name for this machine, or
 *	an empty string if we can't figure out the name.  The caller 
 *	must not modify or free this string.
 *
 * Side effects:
 *	None.

 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetHostName()
{
    DWORD length;
    WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1];

    Tcl_MutexLock(&socketMutex);
    InitSockets();



    if (hostnameInitialized) {
	Tcl_MutexUnlock(&socketMutex);


        return hostname;
    }
    Tcl_MutexUnlock(&socketMutex);
	
    if (TclpHasSockets(NULL) == TCL_OK) {
	/*
	 * INTL: bug


	 */

	if (winSock.gethostname(hostname, sizeof(hostname)) == 0) {
	    Tcl_MutexLock(&socketMutex);
	    hostnameInitialized = 1;






	    Tcl_MutexUnlock(&socketMutex);
	    return hostname;
	}
    }
    Tcl_MutexLock(&socketMutex);
    length = sizeof(hostname);
    if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) {
	/*
	 * Convert string from native to UTF then change to lowercase.
	 */

	Tcl_DString ds;





	lstrcpynA(hostname, Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds),


		sizeof(hostname));
	Tcl_DStringFree(&ds);
	Tcl_UtfToLower(hostname);
    } else {
	hostname[0] = '\0';


    }

    hostnameInitialized = 1;

    Tcl_MutexUnlock(&socketMutex);



    return hostname;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetSockOpt, et al. --
 *
 *	These functions are wrappers that let us bind the WinSock
 *	API dynamically so we can run on systems that don't have
 *	the wsock32.dll.  We need wrappers for these interfaces
 *	because they are called from the generic Tcl code.
 *
 * Results:
 *	As defined for each function.
 *
 * Side effects:
 *	As defined for each function.
 *
 *----------------------------------------------------------------------
 */

int
TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval,
	int FAR *optlen)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        return SOCKET_ERROR;
    }
    
    return winSock.getsockopt(s, level, optname, optval, optlen);
}

int
TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval,
	int optlen)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        return SOCKET_ERROR;
    }

    return winSock.setsockopt(s, level, optname, optval, optlen);
}

u_short
TclWinNToHS(u_short netshort)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        return (u_short) -1;
    }

    return winSock.ntohs(netshort);
}

struct servent *
TclWinGetServByName(const char * name, const char * proto)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to
     * prevent system crashes. This can happen at exit time if the exit
     * handler for WinSock ran before other exit handlers that want to
     * use sockets.
     */

    if (!SocketsEnabled()) {
        return (struct servent *) NULL;
    }

    return winSock.getservbyname(name, proto);
}



/*
 *----------------------------------------------------------------------
 *
 * TclpCutSockChannel --
 *
 *	Remove any thread local refs to this channel. See
 *	Tcl_CutChannel for more info.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

void
TclpCutSockChannel(chan)
    Tcl_Channel chan;			/* The channel being removed. Must
                                         * not be referenced in any
                                         * interpreter. */
{
    ThreadSpecificData *tsdPtr;
    SocketInfo *infoPtr;

    SocketInfo **nextPtrPtr;





    int removed = 0;





    if (Tcl_GetChannelType(chan) != &tcpChannelType) {




        return;




    }


    /*
     * The initializtion of tsdPtr _after_ we have determined that we
     * are dealing with socket is necessary. Doing it before causes
     * the module to access th tdsPtr when it is not initialized yet,
     * causing a lockup.
     */

    tsdPtr  = TCL_TSD_INIT(&dataKey);
    infoPtr = (SocketInfo *) Tcl_GetChannelInstanceData (chan);

    for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
	 nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	if ((*nextPtrPtr) == infoPtr) {
	    (*nextPtrPtr) = infoPtr->nextPtr;
	    removed = 1;
	    break;
	}
    }


    /*
     * This could happen if the channel was created in one thread
     * and then moved to another without updating the thread
     * local data in each thread.
     */

    if (!removed) {
        Tcl_Panic("file info ptr not on thread channel list");
    }

    /*
     * Stop notifications for the socket to occur in this thread.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) UNSELECT, (LPARAM) infoPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpSpliceSockChannel --
 *

 *	Insert thread local ref for this channel.
 *	Tcl_SpliceChannel for more info.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

void
TclpSpliceSockChannel(chan)
    Tcl_Channel chan;			/* The channel being removed. Must
                                         * not be referenced in any
                                         * interpreter. */
{
    ThreadSpecificData *tsdPtr;
    SocketInfo *infoPtr;

    if (Tcl_GetChannelType(chan) != &tcpChannelType) {
        return;
    }

    /*
     * Ensure that socket subsystem is initialized in this thread, or
     * else sockets will not work.
     */

    Tcl_MutexLock(&socketMutex);
    InitSockets();
    Tcl_MutexUnlock(&socketMutex);

    /*
     * The initializtion of tsdPtr _after_ we have determined that we
     * are dealing with socket is necessary. Doing it before causes
     * the module to access th tdsPtr when it is not initialized yet,
     * causing a lockup.
     */

    tsdPtr  = TCL_TSD_INIT(&dataKey);
    infoPtr = (SocketInfo *) Tcl_GetChannelInstanceData (chan);

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    infoPtr->nextPtr = tsdPtr->socketList;
    tsdPtr->socketList = infoPtr;
    SetEvent(tsdPtr->socketListLock);

    /*
     * Ensure that notifications for the socket occur in this thread.
     */

    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
		(WPARAM) SELECT, (LPARAM) infoPtr);
}







<
|
|
|

|
|
|
|
|


|
|

|
|

|

|
|
|

|
|
|
|

|
|
|
|

|
|
|
|
|
|
|

|
|
|
|
<
|

|
|
|
|
|
|

|
|
|
|
|

|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
<
|
|
|
|
|
|

|
|
|

|
|
|













|
<
|


<
>







|
<
|
|
<
>
>
|
|
<
>
>
|
<
<
|
<
|
|
>
>
|

|
<
|
>
>
>
>
>
>
|
<
|
<
<
<





|

>
>
>
>
|
>
>
|
|
|
<
|
>
>
|
>
|
>
|
>
>
>
|







|
|
|
|















|
|
|
<



|

|








|
|
|
<

>

|









|
|
|
<



|









|
|
|
<

>

|




<
<




|

|
<










|
|
<
|
|


|
>
|
>
>
>
>
>
|
>
>
>

>
|
>
>
>
>
|
>
>
>
>
|
>

|
<
<
|
|
|

<
<
|
|
|
|
|
|
|
|
|
>

|
|
|
|
|

|
|
|

<
<
<
|
<
<
|
|
|
<
<
<
<
>
|
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
|
<
|
<
<
<
|
|
<
<
<
|
<
|
<
<
|
<
<
<
<
|
|
<
|
<
<
<
<
2363
2364
2365
2366
2367
2368
2369

2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414

2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466

2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494

2495
2496
2497

2498
2499
2500
2501
2502
2503
2504
2505
2506

2507
2508

2509
2510
2511
2512

2513
2514
2515


2516

2517
2518
2519
2520
2521
2522
2523

2524
2525
2526
2527
2528
2529
2530
2531

2532



2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549

2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590

2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607

2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623

2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639

2640
2641
2642
2643
2644
2645
2646
2647


2648
2649
2650
2651
2652
2653
2654

2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666

2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698


2699
2700
2701
2702


2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723



2724


2725
2726
2727




2728
2729









2730












2731
2732


2733

2734



2735
2736



2737

2738


2739




2740
2741

2742




#ifdef _WIN64
	(ThreadSpecificData *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
	(ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA);
#endif

    switch (message) {

    default:
	return DefWindowProc(hwnd, message, wParam, lParam);
	break;

    case WM_CREATE:
	/*
	 * store the initial tsdPtr, it's from a different thread, so it's not
	 * directly accessible, but needed.
	 */

#ifdef _WIN64
	SetWindowLongPtr(hwnd, GWLP_USERDATA,
		(LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#else
	SetWindowLong(hwnd, GWL_USERDATA,
		(LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#endif
	break;

    case WM_DESTROY:
	PostQuitMessage(0);
	break;

    case SOCKET_MESSAGE:
	event = WSAGETSELECTEVENT(lParam);
	error = WSAGETSELECTERROR(lParam);
	socket = (SOCKET) wParam;

	/*
	 * Find the specified socket on the socket list and update its
	 * eventState flag.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
		infoPtr = infoPtr->nextPtr) {
	    if (infoPtr->socket == socket) {
		/*
		 * Update the socket state.
		 */

		/*
		 * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
		 * happens, then clear the FD_ACCEPT count. Otherwise,
		 * increment the count if the current event is an FD_ACCEPT.

		 */

		if (event & FD_CLOSE) {
		    infoPtr->acceptEventCount = 0;
		    infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
		} else if (event & FD_ACCEPT) {
		    infoPtr->acceptEventCount++;
		}

		if (event & FD_CONNECT) {
		    /*
		     * The socket is now connected, clear the async connect
		     * flag.
		     */

		    infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);

		    /*
		     * Remember any error that occurred so we can report
		     * connection failures.
		     */

		    if (error != ERROR_SUCCESS) {
			TclWinConvertWSAError((DWORD) error);
			infoPtr->lastError = Tcl_GetErrno();
		    }
		}

		if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
		    infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
		    if (error != ERROR_SUCCESS) {
			TclWinConvertWSAError((DWORD) error);
			infoPtr->lastError = Tcl_GetErrno();
		    }
		    infoPtr->readyEvents |= FD_WRITE;
		}
		infoPtr->readyEvents |= event;

		/*
		 * Wake up the Main Thread.
		 */
		SetEvent(tsdPtr->readyEvent);
		Tcl_ThreadAlert(tsdPtr->threadId);
		break;
	    }
	}
	SetEvent(tsdPtr->socketListLock);
	break;

    case SOCKET_SELECT:
	infoPtr = (SocketInfo *) lParam;
	if (wParam == SELECT) {

	    winSock.WSAAsyncSelect(infoPtr->socket, hwnd,
		    SOCKET_MESSAGE, infoPtr->selectEvents);
	} else {
	    /*
	     * Clear the selection mask
	     */

	    winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0);
	}
	break;

    case SOCKET_TERMINATE:
	DestroyWindow(hwnd);
	break;
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetHostName --
 *
 *	Returns the name of the local host.
 *
 * Results:
 *	A string containing the network name for this machine. The caller must

 *	not modify or free this string.
 *
 * Side effects:

 *	Caches the name to return for future calls.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetHostName()
{
    return Tcl_GetString(TclGetProcessGlobalValue(&hostName));

}


/*
 *----------------------------------------------------------------------
 *
 * InitializeHostName --

 *
 *	This routine sets the process global value of the name of the local
 *	host on which the process is running.


 *

 * Results:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void

InitializeHostName(valuePtr, lengthPtr, encodingPtr)
    char **valuePtr;
    int *lengthPtr;
    Tcl_Encoding *encodingPtr;
{
    WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1];
    DWORD length = sizeof(wbuf) / sizeof(WCHAR);
    Tcl_DString ds;





    if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) {
	/*
	 * Convert string from native to UTF then change to lowercase.
	 */

	Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds));

    } else if (TclpHasSockets(NULL) == TCL_OK) {
	/*
	 * Buffer length of 255 copied slavishly from previous version of this
	 * routine. Presumably there's a more "correct" macro value for a
	 * properly sized buffer for a gethostname() call. Maintainers are
	 * welcome to supply it.
	 */

	Tcl_DStringInit(&ds);
	Tcl_DStringSetLength(&ds, 255);

	if (winSock.gethostname(Tcl_DStringValue(&ds),
		Tcl_DStringLength(&ds)) == 0) {
	    Tcl_DStringSetLength(&ds, 0);
	}
    }

    *encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
    *lengthPtr = Tcl_DStringLength(&ds);
    *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
    memcpy((VOID *) *valuePtr, (VOID *) Tcl_DStringValue(&ds),
	    (size_t)(*lengthPtr)+1);
    Tcl_DStringFree(&ds);
}

/*
 *----------------------------------------------------------------------
 *
 * TclWinGetSockOpt, et al. --
 *
 *	These functions are wrappers that let us bind the WinSock API
 *	dynamically so we can run on systems that don't have the wsock32.dll.
 *	We need wrappers for these interfaces because they are called from the
 *	generic Tcl code.
 *
 * Results:
 *	As defined for each function.
 *
 * Side effects:
 *	As defined for each function.
 *
 *----------------------------------------------------------------------
 */

int
TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval,
	int FAR *optlen)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	return SOCKET_ERROR;
    }

    return winSock.getsockopt(s, level, optname, optval, optlen);
}

int
TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval,
	int optlen)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	return SOCKET_ERROR;
    }

    return winSock.setsockopt(s, level, optname, optval, optlen);
}

u_short
TclWinNToHS(u_short netshort)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	return (u_short) -1;
    }

    return winSock.ntohs(netshort);
}

struct servent *
TclWinGetServByName(const char * name, const char * proto)
{
    /*
     * Check that WinSock is initialized; do not call it if not, to prevent
     * system crashes. This can happen at exit time if the exit handler for
     * WinSock ran before other exit handlers that want to use sockets.

     */

    if (!SocketsEnabled()) {
	return (struct servent *) NULL;
    }

    return winSock.getservbyname(name, proto);
}



/*
 *----------------------------------------------------------------------
 *
 * TcpThreadActionProc --
 *
 *	Insert or remove any thread local refs to this channel.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Changes thread local list of valid channels.
 *
 *----------------------------------------------------------------------
 */

static void
TcpThreadActionProc (instanceData, action)

     ClientData instanceData;
     int action;
{
    ThreadSpecificData *tsdPtr;
    SocketInfo *infoPtr = (SocketInfo *) instanceData;
    int notifyCmd;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	/*
	 * Ensure that socket subsystem is initialized in this thread, or else
	 * sockets will not work.
	 */

	Tcl_MutexLock(&socketMutex);
	InitSockets();
	Tcl_MutexUnlock(&socketMutex);

	tsdPtr = TCL_TSD_INIT(&dataKey);

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	infoPtr->nextPtr = tsdPtr->socketList;
	tsdPtr->socketList = infoPtr;
	SetEvent(tsdPtr->socketListLock);

	notifyCmd = SELECT;
    } else {
	SocketInfo **nextPtrPtr;
	int removed = 0;

	tsdPtr	= TCL_TSD_INIT(&dataKey);

	/*


	 * TIP #218, Bugfix: All access to socketList has to be protected by
	 * the lock.
	 */



	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
	     nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == infoPtr) {
		(*nextPtrPtr) = infoPtr->nextPtr;
		removed = 1;
		break;
	    }
	}
	SetEvent(tsdPtr->socketListLock);

	/*
	 * This could happen if the channel was created in one thread and then
	 * moved to another without updating the thread local data in each
	 * thread.
	 */

	if (!removed) {
	    Tcl_Panic("file info ptr not on thread channel list");
	}




	notifyCmd = UNSELECT;


    }

    /*




     * Ensure that, or stop, notifications for the socket occur in this
     * thread.









     */













    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,


	    (WPARAM) notifyCmd, (LPARAM) infoPtr);

}




/*



 * Local Variables:

 * mode: c


 * c-basic-offset: 4




 * fill-column: 78
 * End:

 */




Changes to win/tclWinThrd.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110

111
112
113
114













115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
/* 
 * tclWinThread.c --
 *
 *	This file implements the Windows-specific thread operations.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinThrd.c,v 1.34 2004/10/27 20:53:38 davygrvy Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>

/*
 * This is the master lock used to serialize access to other
 * serialization data structures.
 */

static CRITICAL_SECTION masterLock;
static int init = 0;
#define MASTER_LOCK TclpMasterLock()
#define MASTER_UNLOCK TclpMasterUnlock()


/*
 * This is the master lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization.
 * For obvious reasons, cannot use any dyamically allocated storage.
 */

#ifdef TCL_THREADS

static CRITICAL_SECTION allocLock;
static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock;
static int allocOnce = 0;

#endif /* TCL_THREADS */

/*
 * The joinLock serializes Create- and ExitThread. This is necessary to
 * prevent a race where a new joinable thread exits before the creating
 * thread had the time to create the necessary data structures in the
 * emulation layer.
 */

static CRITICAL_SECTION joinLock;

/*
 * Condition variables are implemented with a combination of a 
 * per-thread Windows Event and a per-condition waiting queue.
 * The idea is that each thread has its own Event that it waits
 * on when it is doing a ConditionWait; it uses the same event for
 * all condition variables because it only waits on one at a time.
 * Each condition variable has a queue of waiting threads, and a 
 * mutex used to serialize access to this queue.
 *
 * Special thanks to David Nichols and
 * Jim Davidson for advice on the Condition Variable implementation.
 */

/*
 * The per-thread event and queue pointers.
 */

#ifdef TCL_THREADS

typedef struct ThreadSpecificData {
    HANDLE condEvent;			/* Per-thread condition event */
    struct ThreadSpecificData *nextPtr;	/* Queue pointers */
    struct ThreadSpecificData *prevPtr;
    int flags;				/* See flags below */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#endif /* TCL_THREADS */

/*
 * State bits for the thread.
 * WIN_THREAD_UNINIT		Uninitialized.  Must be zero because
 *				of the way ThreadSpecificData is created.
 * WIN_THREAD_RUNNING		Running, not waiting.
 * WIN_THREAD_BLOCKED		Waiting, or trying to wait.
 * WIN_THREAD_DEAD		Dying - no per-thread event anymore.
 */ 

#define WIN_THREAD_UNINIT	0x0
#define WIN_THREAD_RUNNING	0x1
#define WIN_THREAD_BLOCKED	0x2
#define WIN_THREAD_DEAD		0x4

/*
 * The per condition queue pointers and the
 * Mutex used to serialize access to the queue.
 */

typedef struct WinCondition {
    CRITICAL_SECTION condLock;	/* Lock to serialize queuing on the condition */

    struct ThreadSpecificData *firstPtr;	/* Queue pointers */
    struct ThreadSpecificData *lastPtr;
} WinCondition;















/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
 *
 *	This procedure creates a new thread.
 *
 * Results:
 *	TCL_OK if the thread could be created.  The thread ID is
 *	returned in a parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread */
    ClientData clientData;		/* The one argument to Main() */
    int stackSize;			/* Size of stack for the new thread */
    int flags;				/* Flags controlling behaviour of
					 * the new thread */
{
    HANDLE tHandle;

    EnterCriticalSection(&joinLock);

#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
    tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc,
	clientData, 0, (unsigned *)idPtr);
#else
    tHandle = CreateThread(NULL, (DWORD) stackSize,
	    (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData,
	    (DWORD) 0, (LPDWORD)idPtr);
#endif

    if (tHandle == NULL) {
        LeaveCriticalSection(&joinLock);
	return TCL_ERROR;
    } else {
        if (flags & TCL_THREAD_JOINABLE) {
	    TclRememberJoinableThread (*idPtr);
	}

	/*
	 * The only purpose of this is to decrement the reference count so the
	 * OS resources will be reaquired when the thread closes.
	 */

|







|
|

|









|
|
















|
|












|
|
|





|
|
|
<
|
|
|

|
|




















|
|



|







|
|



|
>




>
>
>
>
>
>
>
>
>
>
>
>
>









|
|









|
|
|
|
|
|







|







|


|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
/*
 * tclWinThread.c --
 *
 *	This file implements the Windows-specific thread operations.
 *
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinThrd.c,v 1.34.2.6 2005/08/15 18:14:16 dgp Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>

/*
 * This is the master lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION masterLock;
static int init = 0;
#define MASTER_LOCK TclpMasterLock()
#define MASTER_UNLOCK TclpMasterUnlock()


/*
 * This is the master lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dyamically allocated storage.
 */

#ifdef TCL_THREADS

static CRITICAL_SECTION allocLock;
static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock;
static int allocOnce = 0;

#endif /* TCL_THREADS */

/*
 * The joinLock serializes Create- and ExitThread. This is necessary to
 * prevent a race where a new joinable thread exits before the creating thread
 * had the time to create the necessary data structures in the emulation
 * layer.
 */

static CRITICAL_SECTION joinLock;

/*
 * Condition variables are implemented with a combination of a per-thread
 * Windows Event and a per-condition waiting queue. The idea is that each
 * thread has its own Event that it waits on when it is doing a ConditionWait;

 * it uses the same event for all condition variables because it only waits on
 * one at a time. Each condition variable has a queue of waiting threads, and
 * a mutex used to serialize access to this queue.
 *
 * Special thanks to David Nichols and Jim Davidson for advice on the
 * Condition Variable implementation.
 */

/*
 * The per-thread event and queue pointers.
 */

#ifdef TCL_THREADS

typedef struct ThreadSpecificData {
    HANDLE condEvent;			/* Per-thread condition event */
    struct ThreadSpecificData *nextPtr;	/* Queue pointers */
    struct ThreadSpecificData *prevPtr;
    int flags;				/* See flags below */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#endif /* TCL_THREADS */

/*
 * State bits for the thread.
 * WIN_THREAD_UNINIT		Uninitialized. Must be zero because of the way
 *				ThreadSpecificData is created.
 * WIN_THREAD_RUNNING		Running, not waiting.
 * WIN_THREAD_BLOCKED		Waiting, or trying to wait.
 * WIN_THREAD_DEAD		Dying - no per-thread event anymore.
 */

#define WIN_THREAD_UNINIT	0x0
#define WIN_THREAD_RUNNING	0x1
#define WIN_THREAD_BLOCKED	0x2
#define WIN_THREAD_DEAD		0x4

/*
 * The per condition queue pointers and the Mutex used to serialize access to
 * the queue.
 */

typedef struct WinCondition {
    CRITICAL_SECTION condLock;	/* Lock to serialize queuing on the
				 * condition. */
    struct ThreadSpecificData *firstPtr;	/* Queue pointers */
    struct ThreadSpecificData *lastPtr;
} WinCondition;

/*
 * Additions by AOL for specialized thread memory allocator.
 */

#ifdef USE_THREAD_ALLOC
static int once;
static DWORD tlsKey;

typedef struct allocMutex {
    Tcl_Mutex	     tlock;
    CRITICAL_SECTION wlock;
} allocMutex;
#endif /* USE_THREAD_ALLOC */

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
 *
 *	This procedure creates a new thread.
 *
 * Results:
 *	TCL_OK if the thread could be created. The thread ID is returned in a
 *	parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread. */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread. */
    ClientData clientData;		/* The one argument to Main(). */
    int stackSize;			/* Size of stack for the new thread. */
    int flags;				/* Flags controlling behaviour of the
					 * new thread. */
{
    HANDLE tHandle;

    EnterCriticalSection(&joinLock);

#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
    tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc,
	    clientData, 0, (unsigned *)idPtr);
#else
    tHandle = CreateThread(NULL, (DWORD) stackSize,
	    (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData,
	    (DWORD) 0, (LPDWORD)idPtr);
#endif

    if (tHandle == NULL) {
	LeaveCriticalSection(&joinLock);
	return TCL_ERROR;
    } else {
	if (flags & TCL_THREAD_JOINABLE) {
	    TclRememberJoinableThread(*idPtr);
	}

	/*
	 * The only purpose of this is to decrement the reference count so the
	 * OS resources will be reaquired when the thread closes.
	 */

186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
 *	waited upon.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_JoinThread(threadId, result)
    Tcl_ThreadId threadId; /* Id of the thread to wait upon */
    int*     result;       /* Reference to the storage the result
			    * of the thread we wait upon will be
			    * written into. */
{
    return TclJoinThread (threadId, result);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadExit --
 *







|
|
|
<

|







199
200
201
202
203
204
205
206
207
208

209
210
211
212
213
214
215
216
217
 *	waited upon.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_JoinThread(threadId, result)
    Tcl_ThreadId threadId;	/* Id of the thread to wait upon */
    int *result;		/* Reference to the storage the result of the
				 * thread we wait upon will be written into. */

{
    return TclJoinThread(threadId, result);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadExit --
 *
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
 */

void
TclpThreadExit(status)
    int status;
{
    EnterCriticalSection(&joinLock);
    TclSignalExitThread (Tcl_GetCurrentThread (), status);
    LeaveCriticalSection(&joinLock);

#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
    _endthreadex((unsigned) status);
#else
    ExitThread((DWORD) status);
#endif







|







227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
 */

void
TclpThreadExit(status)
    int status;
{
    EnterCriticalSection(&joinLock);
    TclSignalExitThread(Tcl_GetCurrentThread(), status);
    LeaveCriticalSection(&joinLock);

#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
    _endthreadex((unsigned) status);
#else
    ExitThread((DWORD) status);
#endif
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadId
Tcl_GetCurrentThread()
{
    return (Tcl_ThreadId)GetCurrentThreadId();
}

/*
 *----------------------------------------------------------------------
 *
 * TclpInitLock
 *
 *	This procedure is used to grab a lock that serializes initialization
 *	and finalization of Tcl.  On some platforms this may also initialize
 *	the mutex used to serialize creation of more mutexes and thread
 *	local storage keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the initialization mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpInitLock()
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating
	 * the first Tcl interpreter in a single threaded environment.
	 * Once the interpreter has been created, it is safe to create
	 * more threads that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&initLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpInitUnlock
 *
 *	This procedure is used to release a lock that serializes initialization
 *	and finalization of Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the initialization mutex.
 *







|








|
|
|















|
|
|
|

>













|
|







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadId
Tcl_GetCurrentThread()
{
    return (Tcl_ThreadId) GetCurrentThreadId();
}

/*
 *----------------------------------------------------------------------
 *
 * TclpInitLock
 *
 *	This procedure is used to grab a lock that serializes initialization
 *	and finalization of Tcl. On some platforms this may also initialize
 *	the mutex used to serialize creation of more mutexes and thread local
 *	storage keys.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the initialization mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpInitLock()
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&initLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpInitUnlock
 *
 *	This procedure is used to release a lock that serializes
 *	initialization and finalization of Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the initialization mutex.
 *
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation
 *	of mutexes, condition variables, and thread local storage keys.
 *
 *	This lock must be different than the initLock because the
 *	initLock is held during creation of syncronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterLock()
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating
	 * the first Tcl interpreter in a single threaded environment.
	 * Once the interpreter has been created, it is safe to create
	 * more threads that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&masterLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation
 *	and deletion of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *







|
|

|
|















|
|
|
|

>













|
|







325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation of
 *	mutexes, condition variables, and thread local storage keys.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of syncronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterLock()
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&masterLock);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	deletion of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized
 *	mutex for use by the memory allocator.  The alloctor must
 *	use this lock, because all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to
 *	Tcl_MutexLock and Tcl_MutexUnlock.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|
|
|


|
|







387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The alloctor must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430


431


432
433

434
435
436
437
438
439

440


441


442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeLock
 *
 *	This procedure is used to destroy all private resources used in
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys everything private.  TclpInitLock must be held
 *	entering this function.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock ()
{
    MASTER_LOCK;
    DeleteCriticalSection(&joinLock);


    /* Destroy the critical section that we are holding! */


    DeleteCriticalSection(&masterLock);
    init = 0;

#ifdef TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock);
	allocOnce = 0;
    }
#endif

    LeaveCriticalSection(&initLock);


    /* Destroy the critical section that we were holding. */


    DeleteCriticalSection(&initLock);
}

#ifdef TCL_THREADS

/* locally used prototype */
static void FinalizeConditionEvent(ClientData data);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexLock --
 *
 *	This procedure is invoked to lock a mutex.  This is a self 
 *	initializing mutex that is automatically finalized during
 *	Tcl_Finalize.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread.  The mutex is aquired when
 *	this returns.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_MutexLock(mutexPtr)
    Tcl_Mutex *mutexPtr;	/* The lock */
{
    CRITICAL_SECTION *csPtr;
    if (*mutexPtr == NULL) {
	MASTER_LOCK;

	/* 
	 * Double inside master lock check to avoid a race.
	 */

	if (*mutexPtr == NULL) {
	    csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
	    InitializeCriticalSection(csPtr);
	    *mutexPtr = (Tcl_Mutex)csPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);







|
|





|
|





|



>
>
|
>
>


>






>

>
>
|
>
>







<






|
|
<





|
<












|




|







420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472

473
474
475
476
477
478
479
480

481
482
483
484
485
486

487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeLock
 *
 *	This procedure is used to destroy all private resources used in this
 *	file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Destroys everything private. TclpInitLock must be held entering this
 *	function.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock()
{
    MASTER_LOCK;
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&masterLock);
    init = 0;

#ifdef TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock);
	allocOnce = 0;
    }
#endif

    LeaveCriticalSection(&initLock);

    /*
     * Destroy the critical section that we were holding.
     */

    DeleteCriticalSection(&initLock);
}

#ifdef TCL_THREADS

/* locally used prototype */
static void FinalizeConditionEvent(ClientData data);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_MutexLock --
 *
 *	This procedure is invoked to lock a mutex. This is a self initializing
 *	mutex that is automatically finalized during Tcl_Finalize.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread. The mutex is aquired when this returns.

 *
 *----------------------------------------------------------------------
 */

void
Tcl_MutexLock(mutexPtr)
    Tcl_Mutex *mutexPtr;	/* The lock */
{
    CRITICAL_SECTION *csPtr;
    if (*mutexPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Double inside master lock check to avoid a race.
	 */

	if (*mutexPtr == NULL) {
	    csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION));
	    InitializeCriticalSection(csPtr);
	    *mutexPtr = (Tcl_Mutex)csPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex.  This is only
 *	safe to call at the end of time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *







|
|







537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex. This is only safe to
 *	call at the end of time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
	*mutexPtr = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeyInit --
 *
 *	This procedure initializes a thread specific data block key.
 *	Each thread has table of pointers to thread specific data.
 *	all threads agree on which table entry is used by each module.
 *	this is remembered in a "data key", that is just an index into
 *	this table.  To allow self initialization, the interface
 *	passes a pointer to this key and the first thread to use
 *	the key fills in the pointer to the key.  The key should be
 *	a process-wide static.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Will allocate memory the first time this process calls for
 *	this key.  In this case it modifies its argument
 *	to hold the pointer to information about the key.
 *
 *----------------------------------------------------------------------
 */

void
TclpThreadDataKeyInit(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (DWORD **) */
{
    DWORD *indexPtr;
    DWORD newKey;

    MASTER_LOCK;
    if (*keyPtr == NULL) {
	indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
	newKey = TlsAlloc();
        if (newKey != TLS_OUT_OF_INDEXES) {
            *indexPtr = newKey;
        } else {
            Tcl_Panic("TlsAlloc failed from TclpThreadDataKeyInit!"); /* this should be a fatal error */
        }
	*keyPtr = (Tcl_ThreadDataKey)indexPtr;
	TclRememberDataKey(keyPtr);
    }
    MASTER_UNLOCK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeyGet --
 *
 *	This procedure returns a pointer to a block of thread local storage.
 *
 * Results:
 *	A thread-specific pointer to the data structure, or NULL
 *	if the memory has not been assigned to this key for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

VOID *
TclpThreadDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (DWORD **) */
{
    DWORD *indexPtr = *(DWORD **)keyPtr;
    LPVOID result;
    if (indexPtr == NULL) {
	return NULL;
    } else {
        result = TlsGetValue(*indexPtr);
        if ((result == NULL) && (GetLastError() != NO_ERROR)) {
            Tcl_Panic("TlsGetValue failed from TclpThreadDataKeyGet!");
        }
	return result;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpThreadDataKeySet --
 *
 *	This procedure sets the pointer to a block of thread local storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the thread so future calls to TclpThreadDataKeyGet with
 *	this key will return the data pointer.
 *
 *----------------------------------------------------------------------
 */

void
TclpThreadDataKeySet(keyPtr, data)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
    VOID *data;			/* Thread local storage */
{
    DWORD *indexPtr = *(DWORD **)keyPtr;
    BOOL success;
    success = TlsSetValue(*indexPtr, (void *)data);
    if (!success) {
        Tcl_Panic("TlsSetValue failed from TclpThreadDataKeySet!");
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeThreadData --
 *
 *	This procedure cleans up the thread-local storage.  This is
 *	called once for each thread.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up the memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeThreadData(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    VOID *result;
    DWORD *indexPtr;
    BOOL success;

#ifdef USE_THREAD_ALLOC
    TclWinFreeAllocCache();
#endif
    if (*keyPtr != NULL) {
	indexPtr = *(DWORD **)keyPtr;
	result = (VOID *)TlsGetValue(*indexPtr);
	if (result != NULL) {
	    ckfree((char *)result);
	    success = TlsSetValue(*indexPtr, (void *)NULL);
            if (!success) {
                Tcl_Panic("TlsSetValue failed from TclpFinalizeThreadData!");
            }
	} else {
            if (GetLastError() != NO_ERROR) {
                Tcl_Panic("TlsGetValue failed from TclpFinalizeThreadData!");
            }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeThreadDataKey --
 *
 *	This procedure is invoked to clean up one key.  This is a
 *	process-wide storage identifier.  The thread finalization code
 *	cleans up the thread local storage itself.
 *
 *	This assumes the master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The key is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeThreadDataKey(keyPtr)
    Tcl_ThreadDataKey *keyPtr;
{
    DWORD *indexPtr;
    BOOL success;
    if (*keyPtr != NULL) {
	indexPtr = *(DWORD **)keyPtr;
	success = TlsFree(*indexPtr);
        if (!success) {
            Tcl_Panic("TlsFree failed from TclpFinalizeThreadDataKey!");
        }
	ckfree((char *)indexPtr);
	*keyPtr = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionWait --
 *
 *	This procedure is invoked to wait on a condition variable.
 *	The mutex is atomically released as part of the wait, and
 *	automatically grabbed when the condition is signaled.
 *
 *	The mutex must be held when this procedure is called.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread.  The mutex is aquired when
 *	this returns.  Will allocate memory for a HANDLE
 *	and initialize this the first time this Tcl_Condition is used.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
    Tcl_Condition *condPtr;	/* Really (WinCondition **) */







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|
|
|







|
|
|







564
565
566
567
568
569
570




































































































































































































571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
	*mutexPtr = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *




































































































































































































 * Tcl_ConditionWait --
 *
 *	This procedure is invoked to wait on a condition variable. The mutex
 *	is atomically released as part of the wait, and automatically grabbed
 *	when the condition is signaled.
 *
 *	The mutex must be held when this procedure is called.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May block the current thread. The mutex is aquired when this returns.
 *	Will allocate memory for a HANDLE and initialize this the first time
 *	this Tcl_Condition is used.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
    Tcl_Condition *condPtr;	/* Really (WinCondition **) */
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
	 * No more per-thread event on which to wait.
	 */

	return;
    }

    /*
     * Self initialize the two parts of the condition.
     * The per-condition and per-thread parts need to be
     * handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	MASTER_LOCK;

	/* 
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */,
			FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	MASTER_UNLOCK;

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent.
	     * We must be careful to do this outside the Master Lock
	     * because Tcl_CreateThreadExitHandler uses its own
	     * ThreadSpecificData, and initializing that may drop
	     * back into the Master Lock.
	     */
	    
	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent,
		    (ClientData) tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	MASTER_LOCK;







|
|
<





|





|









|
|
|
<
|

|







605
606
607
608
609
610
611
612
613

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637

638
639
640
641
642
643
644
645
646
647
	 * No more per-thread event on which to wait.
	 */

	return;
    }

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.

     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	MASTER_LOCK;

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	MASTER_UNLOCK;

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Master Lock because
	     * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,

	     * and initializing that may drop back into the Master Lock.
	     */

	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent,
		    (ClientData) tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	MASTER_LOCK;
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070

1071


1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086

1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118






1119
1120
1121
1122
1123
1124
1125


1126

1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139

1140
1141








    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
    }

    /*
     * Queue the thread on the condition, using
     * the per-condition lock for serialization.
     */

    tsdPtr->flags = WIN_THREAD_BLOCKED;
    tsdPtr->nextPtr = NULL;
    EnterCriticalSection(&winCondPtr->condLock);
    tsdPtr->prevPtr = winCondPtr->lastPtr;		/* A: */
    winCondPtr->lastPtr = tsdPtr;
    if (tsdPtr->prevPtr != NULL) {
        tsdPtr->prevPtr->nextPtr = tsdPtr;
    }
    if (winCondPtr->firstPtr == NULL) {
        winCondPtr->firstPtr = tsdPtr;
    }

    /*
     * Unlock the caller's mutex and wait for the condition, or a timeout.
     * There is a minor issue here in that we don't count down the
     * timeout if we get notified, but another thread grabs the condition
     * before we do.  In that race condition we'll wait again for the
     * full timeout.  Timed waits are dubious anyway.  Either you have
     * the locking protocol wrong and are masking a deadlock,
     * or you are using conditions to pause your thread.
     */
    
    LeaveCriticalSection(csPtr);
    timeout = 0;
    while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
	ResetEvent(tsdPtr->condEvent);
	LeaveCriticalSection(&winCondPtr->condLock);
	if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) {
	    timeout = 1;
	}
	EnterCriticalSection(&winCondPtr->condLock);
    }

    /*
     * Be careful on timeouts because the signal might arrive right around
     * the time limit and someone else could have taken us off the queue.
     */
    
    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = 0;
	} else {
	    /*
	     * When dequeuing, we can leave the tsdPtr->nextPtr
	     * and tsdPtr->prevPtr with dangling pointers because
	     * they are reinitialilzed w/out reading them when the
	     * thread is enqueued later.
	     */

            if (winCondPtr->firstPtr == tsdPtr) {
                winCondPtr->firstPtr = tsdPtr->nextPtr;
            } else {
                tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
            }
            if (winCondPtr->lastPtr == tsdPtr) {
                winCondPtr->lastPtr = tsdPtr->prevPtr;
            } else {
                tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
            }
            tsdPtr->flags = WIN_THREAD_RUNNING;
	}
    }

    LeaveCriticalSection(&winCondPtr->condLock);
    EnterCriticalSection(csPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionNotify --
 *
 *	This procedure is invoked to signal a condition variable.
 *
 *	The mutex must be held during this call to avoid races,
 *	but this interface does not enforce that.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May unblock another thread.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ConditionNotify(condPtr)
    Tcl_Condition *condPtr;
{
    WinCondition *winCondPtr;
    ThreadSpecificData *tsdPtr;
    if (*condPtr != NULL) {
	winCondPtr = *((WinCondition **)condPtr);

	/*
	 * Loop through all the threads waiting on the condition
	 * and notify them (i.e., broadcast semantics).  The queue
	 * manipulation is guarded by the per-condition coordinating mutex.
	 */

	EnterCriticalSection(&winCondPtr->condLock);
	while (winCondPtr->firstPtr != NULL) {
	    tsdPtr = winCondPtr->firstPtr;
	    winCondPtr->firstPtr = tsdPtr->nextPtr;
	    if (winCondPtr->lastPtr == tsdPtr) {
		winCondPtr->lastPtr = NULL;
	    }
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;	/* Not strictly necessary, see A: */
	    SetEvent(tsdPtr->condEvent);
	}
	LeaveCriticalSection(&winCondPtr->condLock);
    } else {
	/*
	 * Noone has used the condition variable, so there are no waiters.
	 */
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FinalizeConditionEvent --
 *
 *	This procedure is invoked to clean up the per-thread
 *	event used to implement condition waiting.
 *	This is only safe to call at the end of time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The per-thread event is closed.
 *
 *----------------------------------------------------------------------
 */

static void
FinalizeConditionEvent(data)
    ClientData data;
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
    tsdPtr->flags = WIN_THREAD_DEAD;
    CloseHandle(tsdPtr->condEvent);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable.
 *	This is only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeCondition(condPtr)
    Tcl_Condition *condPtr;
{
    WinCondition *winCondPtr = *(WinCondition **)condPtr;

    /*
     * Note - this is called long after the thread-local storage is
     * reclaimed.  The per-thread condition waiting event is
     * reclaimed earlier in a per-thread exit handler, which is
     * called before thread local storage is reclaimed.
     */

    if (winCondPtr != NULL) {
	DeleteCriticalSection(&winCondPtr->condLock);
	ckfree((char *)winCondPtr);
	*condPtr = NULL;
    }
}

/*
 * Additions by AOL for specialized thread memory allocator.
 */
#ifdef USE_THREAD_ALLOC
static int once;
static DWORD key;

typedef struct allocMutex {
    Tcl_Mutex        tlock;
    CRITICAL_SECTION wlock;
} allocMutex;

Tcl_Mutex *
TclpNewAllocMutex(void)
{
    struct allocMutex *lockPtr;

    lockPtr = malloc(sizeof(struct allocMutex));
    if (lockPtr == NULL) {
	Tcl_Panic("could not allocate lock");
    }
    lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock;
    InitializeCriticalSection(&lockPtr->wlock);
    return &lockPtr->tlock;
}

void
TclpFreeAllocMutex(mutex)
    Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
    allocMutex* lockPtr = (allocMutex*) mutex;

    if (!lockPtr) return;


    DeleteCriticalSection(&lockPtr->wlock);
    free(lockPtr);
}

void *
TclpGetAllocCache(void)
{
    VOID *result;

    if (!once) {
	/*
	 * We need to make sure that TclWinFreeAllocCache is called
	 * on each thread that calls this, but only on threads that
	 * call this.
	 */

    	key = TlsAlloc();
	once = 1;
	if (key == TLS_OUT_OF_INDEXES) {
	    Tcl_Panic("could not allocate thread local storage");
	}
    }

    result = TlsGetValue(key);
    if ((result == NULL) && (GetLastError() != NO_ERROR)) {
        Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!");
    }
    return result;
}

void
TclpSetAllocCache(void *ptr)
{
    BOOL success;
    success = TlsSetValue(key, ptr);
    if (!success) {
        Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!");
    }
}

void
TclWinFreeAllocCache(void)
{
    void *ptr;
    BOOL success;

    ptr = TlsGetValue(key);
    if (ptr != NULL) {






	success = TlsSetValue(key, NULL);
        if (!success) {
            Tcl_Panic("TlsSetValue failed from TclWinFreeAllocCache!");
        }
	TclFreeAllocCache(ptr);
    } else {
      if (GetLastError() != NO_ERROR) {


          Tcl_Panic("TlsGetValue failed from TclWinFreeAllocCache!");

      }
    }

    if (once) {    
        success = TlsFree(key);
        if (!success) {
            Tcl_Panic("TlsFree failed from TclWinFreeAllocCache!");
        }

        once = 0; /* reset for next time. */
    }
}


#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */















|
|








|


|




|
|
|
|
|
|

|












|
|

|





|
|
|
|


|
|
|
|
|
|
|
|
|
|
|














|
|




















|
|
|

















|









|
|
|














|









|
|



















|
|
|
|













<
<
<
<
<
<
<



















|
>
|
>
>











|
|
<

>
|

|




|

|








|

|




|

<


<

>
>
>
>
>
>
|
|
|
|
<
|
<
>
>
|
>
|
<
<
<
|
|
|
|
<
|

|
|
>


>
>
>
>
>
>
>
>
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866







867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903

904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932

933
934

935
936
937
938
939
940
941
942
943
944
945

946

947
948
949
950
951



952
953
954
955

956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
    }

    /*
     * Queue the thread on the condition, using the per-condition lock for
     * serialization.
     */

    tsdPtr->flags = WIN_THREAD_BLOCKED;
    tsdPtr->nextPtr = NULL;
    EnterCriticalSection(&winCondPtr->condLock);
    tsdPtr->prevPtr = winCondPtr->lastPtr;		/* A: */
    winCondPtr->lastPtr = tsdPtr;
    if (tsdPtr->prevPtr != NULL) {
	tsdPtr->prevPtr->nextPtr = tsdPtr;
    }
    if (winCondPtr->firstPtr == NULL) {
	winCondPtr->firstPtr = tsdPtr;
    }

    /*
     * Unlock the caller's mutex and wait for the condition, or a timeout.
     * There is a minor issue here in that we don't count down the timeout if
     * we get notified, but another thread grabs the condition before we do.
     * In that race condition we'll wait again for the full timeout. Timed
     * waits are dubious anyway. Either you have the locking protocol wrong
     * and are masking a deadlock, or you are using conditions to pause your
     * thread.
     */

    LeaveCriticalSection(csPtr);
    timeout = 0;
    while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
	ResetEvent(tsdPtr->condEvent);
	LeaveCriticalSection(&winCondPtr->condLock);
	if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) {
	    timeout = 1;
	}
	EnterCriticalSection(&winCondPtr->condLock);
    }

    /*
     * Be careful on timeouts because the signal might arrive right around the
     * time limit and someone else could have taken us off the queue.
     */

    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = 0;
	} else {
	    /*
	     * When dequeuing, we can leave the tsdPtr->nextPtr and
	     * tsdPtr->prevPtr with dangling pointers because they are
	     * reinitialilzed w/out reading them when the thread is enqueued
	     * later.
	     */

	    if (winCondPtr->firstPtr == tsdPtr) {
		winCondPtr->firstPtr = tsdPtr->nextPtr;
	    } else {
		tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	    }
	    if (winCondPtr->lastPtr == tsdPtr) {
		winCondPtr->lastPtr = tsdPtr->prevPtr;
	    } else {
		tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	    }
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	}
    }

    LeaveCriticalSection(&winCondPtr->condLock);
    EnterCriticalSection(csPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConditionNotify --
 *
 *	This procedure is invoked to signal a condition variable.
 *
 *	The mutex must be held during this call to avoid races, but this
 *	interface does not enforce that.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May unblock another thread.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ConditionNotify(condPtr)
    Tcl_Condition *condPtr;
{
    WinCondition *winCondPtr;
    ThreadSpecificData *tsdPtr;
    if (*condPtr != NULL) {
	winCondPtr = *((WinCondition **)condPtr);

	/*
	 * Loop through all the threads waiting on the condition and notify
	 * them (i.e., broadcast semantics). The queue manipulation is guarded
	 * by the per-condition coordinating mutex.
	 */

	EnterCriticalSection(&winCondPtr->condLock);
	while (winCondPtr->firstPtr != NULL) {
	    tsdPtr = winCondPtr->firstPtr;
	    winCondPtr->firstPtr = tsdPtr->nextPtr;
	    if (winCondPtr->lastPtr == tsdPtr) {
		winCondPtr->lastPtr = NULL;
	    }
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;	/* Not strictly necessary, see A: */
	    SetEvent(tsdPtr->condEvent);
	}
	LeaveCriticalSection(&winCondPtr->condLock);
    } else {
	/*
	 * No-one has used the condition variable, so there are no waiters.
	 */
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FinalizeConditionEvent --
 *
 *	This procedure is invoked to clean up the per-thread event used to
 *	implement condition waiting. This is only safe to call at the end of
 *	time.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The per-thread event is closed.
 *
 *----------------------------------------------------------------------
 */

static void
FinalizeConditionEvent(data)
    ClientData data;
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data;
    tsdPtr->flags = WIN_THREAD_DEAD;
    CloseHandle(tsdPtr->condEvent);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
 *----------------------------------------------------------------------
 */

void
TclpFinalizeCondition(condPtr)
    Tcl_Condition *condPtr;
{
    WinCondition *winCondPtr = *(WinCondition **)condPtr;

    /*
     * Note - this is called long after the thread-local storage is reclaimed.
     * The per-thread condition waiting event is reclaimed earlier in a
     * per-thread exit handler, which is called before thread local storage is
     * reclaimed.
     */

    if (winCondPtr != NULL) {
	DeleteCriticalSection(&winCondPtr->condLock);
	ckfree((char *)winCondPtr);
	*condPtr = NULL;
    }
}

/*
 * Additions by AOL for specialized thread memory allocator.
 */
#ifdef USE_THREAD_ALLOC








Tcl_Mutex *
TclpNewAllocMutex(void)
{
    struct allocMutex *lockPtr;

    lockPtr = malloc(sizeof(struct allocMutex));
    if (lockPtr == NULL) {
	Tcl_Panic("could not allocate lock");
    }
    lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock;
    InitializeCriticalSection(&lockPtr->wlock);
    return &lockPtr->tlock;
}

void
TclpFreeAllocMutex(mutex)
    Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
    allocMutex *lockPtr = (allocMutex *) mutex;

    if (!lockPtr) {
	return;
    }
    DeleteCriticalSection(&lockPtr->wlock);
    free(lockPtr);
}

void *
TclpGetAllocCache(void)
{
    VOID *result;

    if (!once) {
	/*
	 * We need to make sure that TclpFreeAllocCache is called on each
	 * thread that calls this, but only on threads that call this.

	 */

	tlsKey = TlsAlloc();
	once = 1;
	if (tlsKey == TLS_OUT_OF_INDEXES) {
	    Tcl_Panic("could not allocate thread local storage");
	}
    }

    result = TlsGetValue(tlsKey);
    if ((result == NULL) && (GetLastError() != NO_ERROR)) {
	Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!");
    }
    return result;
}

void
TclpSetAllocCache(void *ptr)
{
    BOOL success;
    success = TlsSetValue(tlsKey, ptr);
    if (!success) {
	Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!");
    }
}

void
TclpFreeAllocCache(void *ptr)
{

    BOOL success;


    if (ptr != NULL) {
	/*
	 * Called by us in TclpFinalizeThreadData when a thread exits and
	 * destroys the tsd key which stores allocator caches.
	 */

	TclFreeAllocCache(ptr);
	success = TlsSetValue(tlsKey, NULL);
	if (!success) {
	    panic("TlsSetValue failed from TclpFreeAllocCache!");
	}

    } else if (once) {

	/*
	 * Called by us in TclFinalizeThreadAlloc() during the library
	 * finalization initiated from Tcl_Finalize()
	 */




	success = TlsFree(tlsKey);
	if (!success) {
	    Tcl_Panic("TlsFree failed from TclpFreeAllocCache!");
	}

	once = 0; /* reset for next time. */
    }

}

#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinTime.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35
/* 
 * tclWinTime.c --
 *
 *	Contains Windows specific versions of Tcl functions that
 *	obtain time values from the operating system.
 *
 * Copyright 1995-1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinTime.c,v 1.28 2004/09/07 17:39:00 kennykb Exp $
 */

#include "tclInt.h"

#define SECSPERDAY (60L * 60L * 24L)
#define SECSPERYEAR (SECSPERDAY * 365L)
#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY)

/*
 * Number of samples over which to estimate the performance counter
 */

#define SAMPLES 64

/*
 * The following arrays contain the day of year for the last day of
 * each month, where index 1 is January.
 */

static int normalDays[] = {
    -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364
};

static int leapDays[] = {



|
|



|
|

|




|
|
|


|

>
|


|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
/* 
 * tclWinTime.c --
 *
 *	Contains Windows specific versions of Tcl functions that obtain time
 *	values from the operating system.
 *
 * Copyright 1995-1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinTime.c,v 1.28.2.2 2005/08/02 18:17:21 dgp Exp $
 */

#include "tclInt.h"

#define SECSPERDAY	(60L * 60L * 24L)
#define SECSPERYEAR	(SECSPERDAY * 365L)
#define SECSPER4YEAR	(SECSPERYEAR * 4L + SECSPERDAY)

/*
 * Number of samples over which to estimate the performance counter.
 */

#define SAMPLES		64

/*
 * The following arrays contain the day of year for the last day of each
 * month, where index 1 is January.
 */

static int normalDays[] = {
    -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364
};

static int leapDays[] = {
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91

92
93
94
95
96
97
98
99
100
101
102
103
104
105
static Tcl_ThreadDataKey dataKey;

/*
 * Data for managing high-resolution timers.
 */

typedef struct TimeInfo {

    CRITICAL_SECTION cs;	/* Mutex guarding this structure */

    int initialized;		/* Flag == 1 if this structure is
				 * initialized. */

    int perfCounterAvailable;	/* Flag == 1 if the hardware has a
				 * performance counter */

    HANDLE calibrationThread;	/* Handle to the thread that keeps the
				 * virtual clock calibrated. */

    HANDLE readyEvent;		/* System event used to
				 * trigger the requesting thread
				 * when the clock calibration procedure
				 * is initialized for the first time */

    HANDLE exitEvent; 		/* Event to signal out of an exit handler
				 * to tell the calibration loop to
				 * terminate */

    LARGE_INTEGER nominalFreq;	/* Nominal frequency of the system
				 * performance counter, that is, the value
				 * returned from QueryPerformanceFrequency. */

    /*
     * The following values are used for calculating virtual time.
     * Virtual time is always equal to:
     *    lastFileTime + (current perf counter - lastCounter) 
     *				* 10000000 / curCounterFreq
     * and lastFileTime and lastCounter are updated any time that
     * virtual time is returned to a caller.
     */

    ULARGE_INTEGER fileTimeLastCall;
    LARGE_INTEGER perfCounterLastCall;
    LARGE_INTEGER curCounterFreq;

    /*
     * Data used in developing the estimate of performance counter
     * frequency
     */

    Tcl_WideUInt fileTimeSample[SAMPLES];
				/* Last 64 samples of system time */
    Tcl_WideInt perfCounterSample[SAMPLES];
				/* Last 64 samples of performance counter */
    int sampleNo;		/* Current sample number */


} TimeInfo;

static TimeInfo timeInfo = {
    { NULL },
    0,
    0,
    (HANDLE) NULL,







<
|
<


<
|
|
<
|
|
<
|
<
|
|
<
|
|
<
<
|
|
|


|
|


|
|







|
<

>

|

|
|
<
<







44
45
46
47
48
49
50

51

52
53

54
55

56
57

58

59
60

61
62


63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88


89
90
91
92
93
94
95
static Tcl_ThreadDataKey dataKey;

/*
 * Data for managing high-resolution timers.
 */

typedef struct TimeInfo {

    CRITICAL_SECTION cs;	/* Mutex guarding this structure. */

    int initialized;		/* Flag == 1 if this structure is
				 * initialized. */

    int perfCounterAvailable;	/* Flag == 1 if the hardware has a performance
				 * counter. */

    HANDLE calibrationThread;	/* Handle to the thread that keeps the virtual
				 * clock calibrated. */

    HANDLE readyEvent;		/* System event used to trigger the requesting

				 * thread when the clock calibration procedure
				 * is initialized for the first time. */

    HANDLE exitEvent; 		/* Event to signal out of an exit handler to
				 * tell the calibration loop to terminate. */


    LARGE_INTEGER nominalFreq;	/* Nominal frequency of the system performance
				 * counter, that is, the value returned from
				 * QueryPerformanceFrequency. */

    /*
     * The following values are used for calculating virtual time. Virtual
     * time is always equal to:
     *    lastFileTime + (current perf counter - lastCounter) 
     *				* 10000000 / curCounterFreq
     * and lastFileTime and lastCounter are updated any time that virtual time
     * is returned to a caller.
     */

    ULARGE_INTEGER fileTimeLastCall;
    LARGE_INTEGER perfCounterLastCall;
    LARGE_INTEGER curCounterFreq;

    /*
     * Data used in developing the estimate of performance counter frequency

     */

    Tcl_WideUInt fileTimeSample[SAMPLES];
				/* Last 64 samples of system time. */
    Tcl_WideInt perfCounterSample[SAMPLES];
				/* Last 64 samples of performance counter. */
    int sampleNo;		/* Current sample number. */


} TimeInfo;

static TimeInfo timeInfo = {
    { NULL },
    0,
    0,
    (HANDLE) NULL,
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139




140







141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197

198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260

261























































262
263
264
265
266
267

268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326

327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442

443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472

473
474
475
476

477
478
479
480
481
482
483
484
485
486
    0
};

/*
 * Declarations for functions defined later in this file.
 */

static struct tm *	ComputeGMT _ANSI_ARGS_((const time_t *tp));
static void		StopCalibration _ANSI_ARGS_(( ClientData ));
static DWORD WINAPI     CalibrationThread _ANSI_ARGS_(( LPVOID arg ));
static void 		UpdateTimeEachSecond _ANSI_ARGS_(( void ));
static void		ResetCounterSamples _ANSI_ARGS_((
			    Tcl_WideUInt fileTime, 
                            Tcl_WideInt perfCounter,
			    Tcl_WideInt perfFreq
			));
static Tcl_WideInt		AccumulateSample _ANSI_ARGS_((
			    Tcl_WideInt perfCounter,
			    Tcl_WideUInt fileTime




			));








/*
 *----------------------------------------------------------------------
 *
 * TclpGetSeconds --
 *
 *	This procedure returns the number of seconds from the epoch.
 *	On most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
 *
 * Results:
 *	Number of seconds from the epoch.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetSeconds()
{
    Tcl_Time t;
    Tcl_GetTime( &t );

    return t.sec;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetClicks --
 *
 *	This procedure returns a value that represents the highest
 *	resolution clock available on the system.  There are no
 *	guarantees on what the resolution will be.  In Tcl we will
 *	call this value a "click".  The start time is also system
 *	dependant.
 *
 * Results:
 *	Number of clicks from some start time.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetClicks()
{
    /*
     * Use the Tcl_GetTime abstraction to get the time in microseconds,
     * as nearly as we can, and return it.
     */

    Tcl_Time now;		/* Current Tcl time */
    unsigned long retval;	/* Value to return */


    Tcl_GetTime( &now );
    retval = ( now.sec * 1000000 ) + now.usec;
    return retval;

}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTimeZone --
 *
 *	Determines the current timezone.  The method varies wildly
 *	between different Platform implementations, so its hidden in
 *	this function.
 *
 * Results:
 *	Minutes west of GMT.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpGetTimeZone (currentTime)
    unsigned long  currentTime;
{
    int timeZone;

    tzset();
    timeZone = timezone / 60;

    return timeZone;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *
 *	Gets the current system time in seconds and microseconds
 *	since the beginning of the epoch: 00:00 UCT, January 1, 1970.
 *
 * Results:
 *	Returns the current time in timePtr.
 *
 * Side effects:
 *	On the first call, initializes a set of static variables to
 *	keep track of the base value of the performance counter, the
 *	corresponding wall clock (obtained through ftime) and the
 *	frequency of the performance counter.  Also spins a thread
 *	whose function is to wake up periodically and monitor these
 *	values, adjusting them as necessary to correct for drift
 *	in the performance counter's oscillator.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetTime(timePtr)
    Tcl_Time *timePtr;		/* Location to store time information. */
{

	























































    struct timeb t;

    int useFtime = 1;		/* Flag == TRUE if we need to fall back
				 * on ftime rather than using the perf
				 * counter */


    /* Initialize static storage on the first trip through. */

    /*
     * Note: Outer check for 'initialized' is a performance win
     * since it avoids an extra mutex lock in the common case.
     */

    if ( !timeInfo.initialized ) { 
	TclpInitLock();
	if ( !timeInfo.initialized ) {
	    timeInfo.perfCounterAvailable
		= QueryPerformanceFrequency( &timeInfo.nominalFreq );

	    /*
	     * Some hardware abstraction layers use the CPU clock
	     * in place of the real-time clock as a performance counter
	     * reference.  This results in:
	     *    - inconsistent results among the processors on
	     *      multi-processor systems.
	     *    - unpredictable changes in performance counter frequency
	     *      on "gearshift" processors such as Transmeta and
	     *      SpeedStep.
	     *
	     * There seems to be no way to test whether the performance
	     * counter is reliable, but a useful heuristic is that
	     * if its frequency is 1.193182 MHz or 3.579545 MHz, it's
	     * derived from a colorburst crystal and is therefore
	     * the RTC rather than the TSC.
	     *
	     * A sloppier but serviceable heuristic is that the RTC crystal
	     * is normally less than 15 MHz while the TSC crystal is
	     * virtually assured to be greater than 100 MHz.  Since Win98SE
	     * appears to fiddle with the definition of the perf counter
	     * frequency (perhaps in an attempt to calibrate the clock?)
	     * we use the latter rule rather than an exact match.
	     *
	     * We also assume (perhaps questionably) that the vendors 
	     * have gotten their act together on Win64, so bypass all
	     * this rubbish on that platform.
	     */

#if !defined(_WIN64)
	    if ( timeInfo.perfCounterAvailable

		 /* The following lines would do an exact match on
		  * crystal frequency:
		  * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 1193182
		  * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 3579545
		  */
		 && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000 ) {

		/*
		 * As an exception, if every logical processor on the system
		 * is on the same chip, we use the performance counter anyway,
		 * presuming that everyone's TSC is locked to the same
		 * oscillator.
		 */

		SYSTEM_INFO systemInfo;
		unsigned int regs[4];

		GetSystemInfo( &systemInfo );
		if ( TclWinCPUID( 0, regs ) == TCL_OK

		     && regs[1] == 0x756e6547 /* "Genu" */
		     && regs[3] == 0x49656e69 /* "ineI" */
		     && regs[2] == 0x6c65746e /* "ntel" */

		     && TclWinCPUID( 1, regs ) == TCL_OK 

		     && ( (regs[0] & 0x00000F00) == 0x00000F00 /* Pentium 4 */
			  || ( (regs[0] & 0x00F00000)    /* Extended family */
			       && (regs[3] & 0x10000000) ) ) /* Hyperthread */
		     && ( ( ( regs[1] & 0x00FF0000 ) >> 16 ) /* CPU count */
			  == systemInfo.dwNumberOfProcessors ) 

		    ) {
		    timeInfo.perfCounterAvailable = TRUE;
		} else {
		    timeInfo.perfCounterAvailable = FALSE;
		}

	    }
#endif /* above code is Win32 only */

	    /*
	     * If the performance counter is available, start a thread to
	     * calibrate it.
	     */

	    if ( timeInfo.perfCounterAvailable ) {
		DWORD id;

		InitializeCriticalSection( &timeInfo.cs );
		timeInfo.readyEvent = CreateEvent( NULL, FALSE, FALSE, NULL );
		timeInfo.exitEvent = CreateEvent( NULL, FALSE, FALSE, NULL );
		timeInfo.calibrationThread = CreateThread( NULL,
							   256,
							   CalibrationThread,
							   (LPVOID) NULL,
							   0,
							   &id );
		SetThreadPriority( timeInfo.calibrationThread,
				   THREAD_PRIORITY_HIGHEST );

		/*
		 * Wait for the thread just launched to start running,
		 * and create an exit handler that kills it so that it
		 * doesn't outlive unloading tclXX.dll
		 */

		WaitForSingleObject( timeInfo.readyEvent, INFINITE );
		CloseHandle( timeInfo.readyEvent );
		Tcl_CreateExitHandler( StopCalibration, (ClientData) NULL );
	    }
	    timeInfo.initialized = TRUE;
	}
	TclpInitUnlock();
    }

    if ( timeInfo.perfCounterAvailable 
		&& timeInfo.curCounterFreq.QuadPart!=0 ) {
	
	/*
	 * Query the performance counter and use it to calculate the
	 * current time.
	 */

	LARGE_INTEGER curCounter;
				/* Current performance counter */

	Tcl_WideInt curFileTime;
				/* Current estimated time, expressed
				 * as 100-ns ticks since the Windows epoch */

	static LARGE_INTEGER posixEpoch;
				/* Posix epoch expressed as 100-ns ticks
				 * since the windows epoch */

	Tcl_WideInt usecSincePosixEpoch;
				/* Current microseconds since Posix epoch */

	posixEpoch.LowPart = 0xD53E8000;
	posixEpoch.HighPart = 0x019DB1DE;

	EnterCriticalSection( &timeInfo.cs );

	QueryPerformanceCounter( &curCounter );

	/* 
	 * If it appears to be more than 1.1 seconds since the last trip
	 * through the calibration loop, the performance counter may
	 * have jumped forward. (See MSDN Knowledge Base article
	 * Q274323 for a description of the hardware problem that makes
	 * this test necessary.) If the counter jumps, we don't want
	 * to use it directly. Instead, we must return system time.
	 * Eventually, the calibration loop should recover.
	 */

	if ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart
	     < 11 * timeInfo.curCounterFreq.QuadPart / 10 ) {
	    
	    curFileTime = timeInfo.fileTimeLastCall.QuadPart
		+ ( ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart )
		    * 10000000 / timeInfo.curCounterFreq.QuadPart );
	    timeInfo.fileTimeLastCall.QuadPart = curFileTime;
	    timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart;
	    usecSincePosixEpoch = ( curFileTime - posixEpoch.QuadPart ) / 10;
	    timePtr->sec = (time_t) ( usecSincePosixEpoch / 1000000 );
	    timePtr->usec = (unsigned long ) ( usecSincePosixEpoch % 1000000 );
	    useFtime = 0;
	}

	LeaveCriticalSection( &timeInfo.cs );
    }
	
    if ( useFtime ) {
	
	/* High resolution timer is not available.  Just use ftime */


	ftime(&t);
	timePtr->sec = t.time;
	timePtr->usec = t.millitm * 1000;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * StopCalibration --
 *
 *	Turns off the calibration thread in preparation for exiting the
 *	process.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the 'exitEvent' event in the 'timeInfo' structure to ask
 *	the thread in question to exit, and waits for it to do so.
 *
 *----------------------------------------------------------------------
 */

static void
StopCalibration( ClientData unused )
				/* Client data is unused */
{
    SetEvent( timeInfo.exitEvent );

    /*
     * If Tcl_Finalize was called from DllMain, the calibration thread
     * is in a paused state so we need to timeout and continue.
     */

    WaitForSingleObject( timeInfo.calibrationThread, 100 );
    CloseHandle( timeInfo.exitEvent );
    CloseHandle( timeInfo.calibrationThread );
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTZName --
 *







|
|
|
|
|
<
|
<
<
<
|
|
>
>
>
>
|
>
>
>
>
>
>
>






|
|














|
>








|
|
|
|
<














|
|





>
|
|









|
|
<











|
|














|
|





|
|
|
<
|
|
|








>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

<
|
|
<

>
|
|
<
|
|


|

|
|
|


|
|
|


|
|
<


|
|
|
|

|
|
|
|
|
|

|
|
|



|
>
|
|
|
|
|
|
<









>
|
|
<
|
|
|
<
|
<
|
|
|
|
|
<
<




<








|

>
|
|
|
|
<
|
<
<
<
|
|


|
|
|


|
|
|






<
|
<

|
|



|
<
|
<
|
<

|
|
<

|




|

|



|
|
|
|
|
|

>
|
|
<
|
|
|


|
|
|



|


|
|
|
>



















|
|





|


|
>

|
|

>
|
|
|







111
112
113
114
115
116
117
118
119
120
121
122

123



124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314

315
316

317
318
319
320

321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366

367
368
369
370
371
372
373
374
375
376
377
378

379
380
381

382

383
384
385
386
387


388
389
390
391

392
393
394
395
396
397
398
399
400
401
402
403
404
405
406

407



408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425

426

427
428
429
430
431
432
433

434

435

436
437
438

439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460

461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
    0
};

/*
 * Declarations for functions defined later in this file.
 */

static struct tm *	ComputeGMT(const time_t *tp);
static void		StopCalibration(ClientData clientData);
static DWORD WINAPI	CalibrationThread(LPVOID arg);
static void 		UpdateTimeEachSecond(void);
static void		ResetCounterSamples(Tcl_WideUInt fileTime, 

			    Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);



static Tcl_WideInt	AccumulateSample(Tcl_WideInt perfCounter,
			    Tcl_WideUInt fileTime);
static void		NativeScaleTime(Tcl_Time* timebuf,
			    ClientData clientData);
static void		NativeGetTime(Tcl_Time* timebuf,
			    ClientData clientData);

/*
 * TIP #233 (Virtualized Time): Data for the time hooks, if any.
 */

Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
ClientData tclTimeClientData = NULL;

/*
 *----------------------------------------------------------------------
 *
 * TclpGetSeconds --
 *
 *	This procedure returns the number of seconds from the epoch. On most
 *	Unix systems the epoch is Midnight Jan 1, 1970 GMT.
 *
 * Results:
 *	Number of seconds from the epoch.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetSeconds()
{
    Tcl_Time t;

    (*tclGetTimeProcPtr) (&t, tclTimeClientData);    /* Tcl_GetTime inlined. */
    return t.sec;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetClicks --
 *
 *	This procedure returns a value that represents the highest resolution
 *	clock available on the system. There are no guarantees on what the
 *	resolution will be. In Tcl we will call this value a "click". The
 *	start time is also system dependant.

 *
 * Results:
 *	Number of clicks from some start time.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetClicks()
{
    /*
     * Use the Tcl_GetTime abstraction to get the time in microseconds, as
     * nearly as we can, and return it.
     */

    Tcl_Time now;		/* Current Tcl time */
    unsigned long retval;	/* Value to return */

    (*tclGetTimeProcPtr) (&now, tclTimeClientData);   /* Tcl_GetTime inlined */

    retval = (now.sec * 1000000) + now.usec;
    return retval;

}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTimeZone --
 *
 *	Determines the current timezone. The method varies wildly between
 *	different Platform implementations, so its hidden in this function.

 *
 * Results:
 *	Minutes west of GMT.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpGetTimeZone(currentTime)
    unsigned long currentTime;
{
    int timeZone;

    tzset();
    timeZone = timezone / 60;

    return timeZone;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *
 *	Gets the current system time in seconds and microseconds since the
 *	beginning of the epoch: 00:00 UCT, January 1, 1970.
 *
 * Results:
 *	Returns the current time in timePtr.
 *
 * Side effects:
 *	On the first call, initializes a set of static variables to keep track
 *	of the base value of the performance counter, the corresponding wall
 *	clock (obtained through ftime) and the frequency of the performance

 *	counter. Also spins a thread whose function is to wake up periodically
 *	and monitor these values, adjusting them as necessary to correct for
 *	drift in the performance counter's oscillator.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_GetTime(timePtr)
    Tcl_Time *timePtr;		/* Location to store time information. */
{
    (*tclGetTimeProcPtr) (timePtr, tclTimeClientData);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeScaleTime --
 *
 *	TIP #233: Scale from virtual time to the real-time. For native scaling
 *	the relationship is 1:1 and nothing has to be done.
 *
 * Results:
 *	Scales the time in timePtr.
 *
 * Side effects:
 *	See above.
 *
 *----------------------------------------------------------------------
 */

static void
NativeScaleTime(timePtr, clientData)
    Tcl_Time *timePtr;
    ClientData clientData;
{
    /*
     * Native scale is 1:1. Nothing is done.
     */
}

/*
 *----------------------------------------------------------------------
 *
 * NativeGetTime --
 *
 *	TIP #233: Gets the current system time in seconds and microseconds
 *	since the beginning of the epoch: 00:00 UCT, January 1, 1970.
 *
 * Results:
 *	Returns the current time in timePtr.
 *
 * Side effects:
 *	On the first call, initializes a set of static variables to keep track
 *	of the base value of the performance counter, the corresponding wall
 *	clock (obtained through ftime) and the frequency of the performance
 *	counter. Also spins a thread whose function is to wake up periodically
 *	and monitor these values, adjusting them as necessary to correct for
 *	drift in the performance counter's oscillator.
 *
 *----------------------------------------------------------------------
 */

static void
NativeGetTime(timePtr, clientData)
    Tcl_Time *timePtr;
    ClientData clientData;
{
    struct timeb t;

    int useFtime = 1;		/* Flag == TRUE if we need to fall back on
				 * ftime rather than using the perf counter. */


    /*
     * Initialize static storage on the first trip through.
     *

     * Note: Outer check for 'initialized' is a performance win since it
     * avoids an extra mutex lock in the common case.
     */

    if (!timeInfo.initialized) { 
	TclpInitLock();
	if (!timeInfo.initialized) {
	    timeInfo.perfCounterAvailable =
		    QueryPerformanceFrequency(&timeInfo.nominalFreq);

	    /*
	     * Some hardware abstraction layers use the CPU clock in place of
	     * the real-time clock as a performance counter reference. This
	     * results in:
	     *    - inconsistent results among the processors on
	     *      multi-processor systems.
	     *    - unpredictable changes in performance counter frequency on
	     *      "gearshift" processors such as Transmeta and SpeedStep.

	     *
	     * There seems to be no way to test whether the performance
	     * counter is reliable, but a useful heuristic is that if its
	     * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a
	     * colorburst crystal and is therefore the RTC rather than the
	     * TSC.
	     *
	     * A sloppier but serviceable heuristic is that the RTC crystal is
	     * normally less than 15 MHz while the TSC crystal is virtually
	     * assured to be greater than 100 MHz. Since Win98SE appears to
	     * fiddle with the definition of the perf counter frequency
	     * (perhaps in an attempt to calibrate the clock?), we use the
	     * latter rule rather than an exact match.
	     *
	     * We also assume (perhaps questionably) that the vendors have
	     * gotten their act together on Win64, so bypass all this rubbish
	     * on that platform.
	     */

#if !defined(_WIN64)
	    if (timeInfo.perfCounterAvailable
		    /*
		     * The following lines would do an exact match on crystal
		     * frequency:
		     * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182
		     * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545
		     */
		    && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){

		/*
		 * As an exception, if every logical processor on the system
		 * is on the same chip, we use the performance counter anyway,
		 * presuming that everyone's TSC is locked to the same
		 * oscillator.
		 */

		SYSTEM_INFO systemInfo;
		unsigned int regs[4];

		GetSystemInfo(&systemInfo);
		if (TclWinCPUID(0, regs) == TCL_OK

			&& regs[1] == 0x756e6547	/* "Genu" */
			&& regs[3] == 0x49656e69	/* "ineI" */
			&& regs[2] == 0x6c65746e	/* "ntel" */

			&& TclWinCPUID(1, regs) == TCL_OK 

			&& ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
			|| ((regs[0] & 0x00F00000)	/* Extended family */
			&& (regs[3] & 0x10000000)))	/* Hyperthread */
			&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
			    == systemInfo.dwNumberOfProcessors)) {


		    timeInfo.perfCounterAvailable = TRUE;
		} else {
		    timeInfo.perfCounterAvailable = FALSE;
		}

	    }
#endif /* above code is Win32 only */

	    /*
	     * If the performance counter is available, start a thread to
	     * calibrate it.
	     */

	    if (timeInfo.perfCounterAvailable) {
		DWORD id;

		InitializeCriticalSection(&timeInfo.cs);
		timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
		timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
		timeInfo.calibrationThread = CreateThread(NULL, 256,

			CalibrationThread, (LPVOID) NULL, 0, &id);



		SetThreadPriority(timeInfo.calibrationThread,
			THREAD_PRIORITY_HIGHEST);

		/*
		 * Wait for the thread just launched to start running, and
		 * create an exit handler that kills it so that it doesn't
		 * outlive unloading tclXX.dll
		 */

		WaitForSingleObject(timeInfo.readyEvent, INFINITE);
		CloseHandle(timeInfo.readyEvent);
		Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL);
	    }
	    timeInfo.initialized = TRUE;
	}
	TclpInitUnlock();
    }


    if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) {

	/*
	 * Query the performance counter and use it to calculate the current
	 * time.
	 */

	LARGE_INTEGER curCounter;
				/* Current performance counter. */

	Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns

				 * ticks since the Windows epoch. */

	static LARGE_INTEGER posixEpoch;
				/* Posix epoch expressed as 100-ns ticks since
				 * the windows epoch. */

	Tcl_WideInt usecSincePosixEpoch;
				/* Current microseconds since Posix epoch. */

	posixEpoch.LowPart = 0xD53E8000;
	posixEpoch.HighPart = 0x019DB1DE;

	EnterCriticalSection(&timeInfo.cs);

	QueryPerformanceCounter(&curCounter);

	/* 
	 * If it appears to be more than 1.1 seconds since the last trip
	 * through the calibration loop, the performance counter may have
	 * jumped forward. (See MSDN Knowledge Base article Q274323 for a
	 * description of the hardware problem that makes this test
	 * necessary.) If the counter jumps, we don't want to use it directly.
	 * Instead, we must return system time. Eventually, the calibration
	 * loop should recover.
	 */

	if (curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart <
		11 * timeInfo.curCounterFreq.QuadPart / 10) {

	    curFileTime = timeInfo.fileTimeLastCall.QuadPart +
		 ((curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart)
		    * 10000000 / timeInfo.curCounterFreq.QuadPart);
	    timeInfo.fileTimeLastCall.QuadPart = curFileTime;
	    timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart;
	    usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10;
	    timePtr->sec = (time_t) (usecSincePosixEpoch / 1000000);
	    timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
	    useFtime = 0;
	}

	LeaveCriticalSection(&timeInfo.cs);
    }
	
    if (useFtime) {
	/*
	 * High resolution timer is not available. Just use ftime.
	 */

	ftime(&t);
	timePtr->sec = t.time;
	timePtr->usec = t.millitm * 1000;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * StopCalibration --
 *
 *	Turns off the calibration thread in preparation for exiting the
 *	process.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the 'exitEvent' event in the 'timeInfo' structure to ask the
 *	thread in question to exit, and waits for it to do so.
 *
 *----------------------------------------------------------------------
 */

static void
StopCalibration(ClientData unused)
				/* Client data is unused */
{
    SetEvent(timeInfo.exitEvent);

    /*
     * If Tcl_Finalize was called from DllMain, the calibration thread is in a
     * paused state so we need to timeout and continue.
     */

    WaitForSingleObject(timeInfo.calibrationThread, 100);
    CloseHandle(timeInfo.exitEvent);
    CloseHandle(timeInfo.calibrationThread);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetTZName --
 *
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    char *name = tsdPtr->tzName;

    /*
     * tzset() under Borland doesn't seem to set up tzname[] at all.
     * tzset() under MSVC has the following weird observed behavior:
     *	 First time we call "clock format [clock seconds] -format %Z -gmt 1"
     *	 we get "GMT", but on all subsequent calls we get the current time 
     *	 zone string, even though env(TZ) is GMT and the variable _timezone 
     *   is 0.
     */

    name[0] = '\0';

    zone = getenv("TZ");
    if (zone != NULL) {
	/*
	 * TZ is of form "NST-4:30NDT", where "NST" would be the
	 * name of the standard time zone for this area, "-4:30" is
	 * the offset from GMT in hours, and "NDT is the name of 
	 * the daylight savings time zone in this area.  The offset 
	 * and DST strings are optional.
	 */

	len = strlen(zone);
	if (len > 3) {
	    len = 3;
	}
	if (dst != 0) {







|
|
|







|
|
<
|
|







543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561

562
563
564
565
566
567
568
569
570
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    char *name = tsdPtr->tzName;

    /*
     * tzset() under Borland doesn't seem to set up tzname[] at all.
     * tzset() under MSVC has the following weird observed behavior:
     *	 First time we call "clock format [clock seconds] -format %Z -gmt 1"
     *	 we get "GMT", but on all subsequent calls we get the current time
     *	 ezone string, even though env(TZ) is GMT and the variable _timezone
     *	 is 0.
     */

    name[0] = '\0';

    zone = getenv("TZ");
    if (zone != NULL) {
	/*
	 * TZ is of form "NST-4:30NDT", where "NST" would be the name of the
	 * standard time zone for this area, "-4:30" is the offset from GMT in

	 * hours, and "NDT is the name of the daylight savings time zone in
	 * this area. The offset and DST strings are optional.
	 */

	len = strlen(zone);
	if (len > 3) {
	    len = 3;
	}
	if (dst != 0) {
547
548
549
550
551
552
553
554
555
556

557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
	}
	Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name,
		sizeof(tsdPtr->tzName), NULL, NULL, NULL);
    }
    if (name[0] == '\0') {
	if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
	    /*
	     * MSDN: On NT this is returned if DST is not used in
	     * the current TZ
	     */

	    dst = 0;
	}
	encoding = Tcl_GetEncoding(NULL, "unicode");
	Tcl_ExternalToUtf(NULL, encoding, 
		(char *) ((dst) ? tz.DaylightName : tz.StandardName), -1, 
		0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
	Tcl_FreeEncoding(encoding);
    } 
    return name;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDate --
 *
 *	This function converts between seconds and struct tm.  If
 *	useGMT is true, then the returned date will be in Greenwich
 *	Mean Time (GMT).  Otherwise, it will be in the local time zone.
 *
 * Results:
 *	Returns a static tm structure.
 *
 * Side effects:
 *	None.
 *







|
|

>
















|
|
|







584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
	}
	Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name,
		sizeof(tsdPtr->tzName), NULL, NULL, NULL);
    }
    if (name[0] == '\0') {
	if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
	    /*
	     * MSDN: On NT this is returned if DST is not used in the current
	     * TZ
	     */

	    dst = 0;
	}
	encoding = Tcl_GetEncoding(NULL, "unicode");
	Tcl_ExternalToUtf(NULL, encoding, 
		(char *) ((dst) ? tz.DaylightName : tz.StandardName), -1, 
		0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
	Tcl_FreeEncoding(encoding);
    } 
    return name;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetDate --
 *
 *	This function converts between seconds and struct tm. If useGMT is
 *	true, then the returned date will be in Greenwich Mean Time (GMT).
 *	Otherwise, it will be in the local time zone.
 *
 * Results:
 *	Returns a static tm structure.
 *
 * Side effects:
 *	None.
 *
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607

608
609
610
611

612
613
614
615

616


617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
    struct tm *tmPtr;
    time_t time;

    if (!useGMT) {
	tzset();

	/*
	 * If we are in the valid range, let the C run-time library
	 * handle it.  Otherwise we need to fake it.  Note that this
	 * algorithm ignores daylight savings time before the epoch.
	 */

	/*
	  Hm, Borland's localtime manages to return NULL under certain
	  circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
	  since 'localtime' isn't supposed to do this, possibly leading to
	  crashes.

	  Patch: We only call this function if we are at least one day into
	  the epoch, else we handle it ourselves (like we do for times < 0).
	  H. Giese, June 2003
	*/

#ifdef __BORLANDC__
	if (*t >= SECSPERDAY) {
#else
	if (*t >= 0) {

#endif


	    return TclpLocaltime(t);
	}

	time = *t - timezone;
	
	/*
	 * If we aren't near to overflowing the long, just add the bias and
	 * use the normal calculation.  Otherwise we will need to adjust
	 * the result at the end.
	 */

	if (*t < (LONG_MAX - 2 * SECSPERDAY)
		&& *t > (LONG_MIN + 2 * SECSPERDAY)) {
	    tmPtr = ComputeGMT(&time);
	} else {
	    tmPtr = ComputeGMT(t);

	    tzset();

	    /*







|
|
|



|
|
|
|
>
|
|
|
|
>

|

<
>

>
>







|
|


|
<







629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670

671
672
673
674
675
676
677
    struct tm *tmPtr;
    time_t time;

    if (!useGMT) {
	tzset();

	/*
	 * If we are in the valid range, let the C run-time library handle it.
	 * Otherwise we need to fake it. Note that this algorithm ignores
	 * daylight savings time before the epoch.
	 */

	/*
	 * Hm, Borland's localtime manages to return NULL under certain
	 * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
	 * since 'localtime' isn't supposed to do this, possibly leading to
	 * crashes.
	 *
	 * Patch: We only call this function if we are at least one day into
	 * the epoch, else we handle it ourselves (like we do for times < 0).
	 * H. Giese, June 2003
	 */

#ifdef __BORLANDC__
#define LOCALTIME_VALIDITY_BOUNDARY	SECSPERDAY
#else

#define LOCALTIME_VALIDITY_BOUNDARY	0
#endif

	if (*t >= LOCALTIME_VALIDITY_BOUNDARY) {
	    return TclpLocaltime(t);
	}

	time = *t - timezone;
	
	/*
	 * If we aren't near to overflowing the long, just add the bias and
	 * use the normal calculation. Otherwise we will need to adjust the
	 * result at the end.
	 */

	if (*t < (LONG_MAX - 2*SECSPERDAY) && *t > (LONG_MIN + 2*SECSPERDAY)) {

	    tmPtr = ComputeGMT(&time);
	} else {
	    tmPtr = ComputeGMT(t);

	    tzset();

	    /*
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
}

/*
 *----------------------------------------------------------------------
 *
 * ComputeGMT --
 *
 *	This function computes GMT given the number of seconds since
 *	the epoch (midnight Jan 1 1970).
 *
 * Results:
 *	Returns a (per thread) statically allocated struct tm.
 *
 * Side effects:
 *	Updates the values of the static struct tm.
 *







|
|







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
}

/*
 *----------------------------------------------------------------------
 *
 * ComputeGMT --
 *
 *	This function computes GMT given the number of seconds since the epoch
 *	(midnight Jan 1 1970).
 *
 * Results:
 *	Returns a (per thread) statically allocated struct tm.
 *
 * Side effects:
 *	Updates the values of the static struct tm.
 *
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728

    if (rem < 0) {
	tmp--;
	rem += SECSPER4YEAR;
    }

    /*
     * Compute the year after 1900 by taking the 4 year span and adjusting
     * for the remainder.  This works because 2000 is a leap year, and
     * 1900/2100 are out of the range.
     */

    tmp = (tmp * 4) + 70;
    isLeap = 0;
    if (rem >= SECSPERYEAR) {			  /* 1971, etc. */
	tmp++;
	rem -= SECSPERYEAR;







|
|
|







753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769

    if (rem < 0) {
	tmp--;
	rem += SECSPER4YEAR;
    }

    /*
     * Compute the year after 1900 by taking the 4 year span and adjusting for
     * the remainder. This works because 2000 is a leap year, and 1900/2100
     * are out of the range.
     */

    tmp = (tmp * 4) + 70;
    isLeap = 0;
    if (rem >= SECSPERYEAR) {			  /* 1971, etc. */
	tmp++;
	rem -= SECSPERYEAR;
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764

765
766
767
768
769
770
771
		isLeap = 1;
	    }
	}
    }
    tmPtr->tm_year = tmp;

    /*
     * Compute the day of year and leave the seconds in the current day in
     * the remainder.
     */

    tmPtr->tm_yday = rem / SECSPERDAY;
    rem %= SECSPERDAY;
    
    /*
     * Compute the time of day.
     */

    tmPtr->tm_hour = rem / 3600;
    rem %= 3600;
    tmPtr->tm_min = rem / 60;
    tmPtr->tm_sec = rem % 60;

    /*
     * Compute the month and day of month.
     */

    days = (isLeap) ? leapDays : normalDays;
    for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) {

    }
    tmPtr->tm_mon = --tmp;
    tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];

    /*
     * Compute day of week.  Epoch started on a Thursday.
     */







|
|




















>







777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
		isLeap = 1;
	    }
	}
    }
    tmPtr->tm_year = tmp;

    /*
     * Compute the day of year and leave the seconds in the current day in the
     * remainder.
     */

    tmPtr->tm_yday = rem / SECSPERDAY;
    rem %= SECSPERDAY;
    
    /*
     * Compute the time of day.
     */

    tmPtr->tm_hour = rem / 3600;
    rem %= 3600;
    tmPtr->tm_min = rem / 60;
    tmPtr->tm_sec = rem % 60;

    /*
     * Compute the month and day of month.
     */

    days = (isLeap) ? leapDays : normalDays;
    for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) {
	/* empty body */
    }
    tmPtr->tm_mon = --tmp;
    tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];

    /*
     * Compute day of week.  Epoch started on a Thursday.
     */
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816

817

818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

836

837
838
839
840

841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980

981
982
983
984
985
986

987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081

1082

1083
1084
1085
1086
1087
1088
1089
1090
1091
1092

1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105

1106
1107
1108
1109
1110
1111
1112
1113

1114

1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151

1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182

1183
1184





































































}

/*
 *----------------------------------------------------------------------
 *
 * CalibrationThread --
 *
 *	Thread that manages calibration of the hi-resolution time
 *	derived from the performance counter, to keep it synchronized
 *	with the system clock.
 *
 * Parameters:
 *	arg -- Client data from the CreateThread call.  This parameter
 *             points to the static TimeInfo structure.
 *
 * Return value:
 *	None.  This thread embeds an infinite loop.
 *
 * Side effects:
 *	At an interval of 1 s, this thread performs virtual time discipline.
 *
 * Note: When this thread is entered, TclpInitLock has been called
 * to safeguard the static storage.  There is therefore no synchronization
 * in the body of this procedure.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
CalibrationThread( LPVOID arg )
{
    FILETIME curFileTime;
    DWORD waitResult;


    /* Get initial system time and performance counter */


    GetSystemTimeAsFileTime( &curFileTime );
    QueryPerformanceCounter( &timeInfo.perfCounterLastCall );
    QueryPerformanceFrequency( &timeInfo.curCounterFreq );
    timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
    timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;

    ResetCounterSamples( timeInfo.fileTimeLastCall.QuadPart,
			 timeInfo.perfCounterLastCall.QuadPart,
			 timeInfo.curCounterFreq.QuadPart );

    /*
     * Wake up the calling thread.  When it wakes up, it will release the
     * initialization lock.
     */

    SetEvent( timeInfo.readyEvent );


    /* Run the calibration once a second */


    while (timeInfo.perfCounterAvailable) {

	/* If the exitEvent is set, break out of the loop. */


	waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
	if ( waitResult == WAIT_OBJECT_0 ) {
	    break;
	}
	UpdateTimeEachSecond();
    }

    /* lint */
    return (DWORD) 0;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateTimeEachSecond --
 *
 *	Callback from the waitable timer in the clock calibration thread
 *	that updates system time.
 *
 * Parameters:
 *	info -- Pointer to the static TimeInfo structure
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Performs virtual time calibration discipline.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateTimeEachSecond()
{

    LARGE_INTEGER curPerfCounter;
				/* Current value returned from
				 * QueryPerformanceCounter */

    FILETIME curSysTime;	/* Current system time */

    LARGE_INTEGER curFileTime;	/* File time at the time this callback
				 * was scheduled. */

    Tcl_WideInt estFreq;	/* Estimated perf counter frequency */

    Tcl_WideInt vt0;		/* Tcl time right now */
    Tcl_WideInt vt1;		/* Tcl time one second from now */

    Tcl_WideInt tdiff;		/* Difference between system clock and
				 * Tcl time. */

    Tcl_WideInt driftFreq;	/* Frequency needed to drift virtual time
				 * into step over 1 second */

    /*
     * Sample performance counter and system time.
     */

    QueryPerformanceCounter( &curPerfCounter );
    GetSystemTimeAsFileTime( &curSysTime );
    curFileTime.LowPart = curSysTime.dwLowDateTime;
    curFileTime.HighPart = curSysTime.dwHighDateTime;

    EnterCriticalSection( &timeInfo.cs );

    /*
     * We devide by timeInfo.curCounterFreq.QuadPart in several places.
     * That value should always be positive on a correctly functioning
     * system.  But it is good to be defensive about such matters.
     * So if something goes wrong and the value does goes to zero, we
     * clear the timeInfo.perfCounterAvailable in order to cause the
     * calibration thread to shut itself down, then return without additional
     * processing.
     */

    if( timeInfo.curCounterFreq.QuadPart==0 ){
	LeaveCriticalSection( &timeInfo.cs );
	timeInfo.perfCounterAvailable = 0;
	return;
    }

    /*
     * Several things may have gone wrong here that have to
     * be checked for.
     * (1) The performance counter may have jumped.
     * (2) The system clock may have been reset.
     *
     * In either case, we'll need to reinitialize the circular buffer
     * with samples relative to the current system time and the NOMINAL
     * performance frequency (not the actual, because the actual has
     * probably run slow in the first case). Our estimated frequency
     * will be the nominal frequency.
     */

    /*
     * Store the current sample into the circular buffer of samples,
     * and estimate the performance counter frequency.
     */

    estFreq = AccumulateSample( curPerfCounter.QuadPart,
				(Tcl_WideUInt) curFileTime.QuadPart );

    /*
     * We want to adjust things so that time appears to be continuous.
     * Virtual file time, right now, is 
     *
     * vt0 = 10000000 * ( curPerfCounter - perfCounterLastCall )
     *       / curCounterFreq
     *       + fileTimeLastCall
     *
     * Ideally, we would like to drift the clock into place over a
     * period of 2 sec, so that virtual time 2 sec from now will be
     *
     * vt1 = 20000000 + curFileTime
     * 
     * The frequency that we need to use to drift the counter back into
     * place is estFreq * 20000000 / ( vt1 - vt0 )
     */
    
    vt0 = 10000000 * ( curPerfCounter.QuadPart
		       - timeInfo.perfCounterLastCall.QuadPart )
	/ timeInfo.curCounterFreq.QuadPart
	+ timeInfo.fileTimeLastCall.QuadPart;
    vt1 = 20000000 + curFileTime.QuadPart;

    /*
     * If we've gotten more than a second away from system time,
     * then drifting the clock is going to be pretty hopeless.
     * Just let it jump. Otherwise, compute the drift frequency and
     * fill in everything.
     */

    tdiff = vt0 - curFileTime.QuadPart;
    if ( tdiff > 10000000 || tdiff < -10000000 ) {
	timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart;
	timeInfo.curCounterFreq.QuadPart = estFreq;
    } else {
	driftFreq = estFreq * 20000000 / ( vt1 - vt0 );

	if ( driftFreq > 1003 * estFreq / 1000 ) {
	    driftFreq = 1003 * estFreq / 1000;
	}
	if ( driftFreq < 997 * estFreq / 1000 ) {
	    driftFreq = 997 * estFreq / 1000;
	}

	timeInfo.fileTimeLastCall.QuadPart = vt0;
	timeInfo.curCounterFreq.QuadPart = driftFreq;
    }

    timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart;

    LeaveCriticalSection( &timeInfo.cs );

}

/*
 *----------------------------------------------------------------------
 *
 * ResetCounterSamples --
 *
 *	Fills the sample arrays in 'timeInfo' with dummy values that will
 *	yield the current performance counter and frequency.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The array of samples is filled in so that it appears that there
 *	are SAMPLES samples at one-second intervals, separated by precisely
 *	the given frequency.
 *
 *----------------------------------------------------------------------
 */

static void
ResetCounterSamples( Tcl_WideUInt fileTime,
				/* Current file time */
		     Tcl_WideInt perfCounter,
				/* Current performance counter */
		     Tcl_WideInt perfFreq )
				/* Target performance frequency */
{
    int i;
    for ( i = SAMPLES-1; i >= 0; --i ) {
	timeInfo.perfCounterSample[i] = perfCounter;
	timeInfo.fileTimeSample[i] = fileTime;
	perfCounter -= perfFreq;
	fileTime -= 10000000;
    }
    timeInfo.sampleNo = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * AccumulateSample --
 *
 *	Updates the circular buffer of performance counter and system
 *	time samples with a new data point.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The new data point replaces the oldest point in the circular
 *	buffer, and the descriptive statistics are updated to accumulate
 *	the new point.
 *
 * Several things may have gone wrong here that have to
 * be checked for.
 * (1) The performance counter may have jumped.
 * (2) The system clock may have been reset.
 *
 * In either case, we'll need to reinitialize the circular buffer
 * with samples relative to the current system time and the NOMINAL
 * performance frequency (not the actual, because the actual has
 * probably run slow in the first case).
 */

static Tcl_WideInt
AccumulateSample( Tcl_WideInt perfCounter,
		  Tcl_WideUInt fileTime )
{
    Tcl_WideUInt workFTSample;	/* File time sample being removed
				 * from or added to the circular buffer */

    Tcl_WideInt workPCSample;	/* Performance counter sample being
				 * removed from or added to the circular 
				 * buffer */

    Tcl_WideUInt lastFTSample;	/* Last file time sample recorded */

    Tcl_WideInt lastPCSample;	/* Last performance counter sample recorded */

    Tcl_WideInt FTdiff;		/* Difference between last FT and current */

    Tcl_WideInt PCdiff;		/* Difference between last PC and current */

    Tcl_WideInt estFreq;	/* Estimated performance counter frequency */


    /* Test for jumps and reset the samples if we have one. */


    if ( timeInfo.sampleNo == 0 ) {
	lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo
						   + SAMPLES - 1 ];
	lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo
						+ SAMPLES - 1 ];
    } else {
	lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo - 1 ];
	lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo - 1 ];
    }

    PCdiff = perfCounter - lastPCSample;
    FTdiff = fileTime - lastFTSample;
    if ( PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10
	 || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10
	 || FTdiff < 9000000
	 || FTdiff > 11000000 ) {
	ResetCounterSamples( fileTime, perfCounter,
			     timeInfo.nominalFreq.QuadPart );
	return timeInfo.nominalFreq.QuadPart;

    } else {
    
	/* Estimate the frequency */

	
	workPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo ];
	workFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo ];
	estFreq = 10000000 * ( perfCounter - workPCSample )
	    / ( fileTime - workFTSample );
	timeInfo.perfCounterSample[ timeInfo.sampleNo ] = perfCounter;
	timeInfo.fileTimeSample[ timeInfo.sampleNo ] = (Tcl_WideInt) fileTime;
	

	/* Advance the sample number */

	
	if ( ++timeInfo.sampleNo >= SAMPLES ) {
	    timeInfo.sampleNo = 0;
	} 
	
	return estFreq;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGmtime --
 *
 *	Wrapper around the 'gmtime' library function to make it thread
 *	safe.
 *
 * Results:
 *	Returns a pointer to a 'struct tm' in thread-specific data.
 *
 * Side effects:
 *	Invokes gmtime or gmtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpGmtime( timePtr )
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch */

{
    /*
     * The MS implementation of gmtime is thread safe because
     * it returns the time in a block of thread-local storage,
     * and Windows does not provide a Posix gmtime_r function.
     */

    return gmtime( timePtr );
}

/*
 *----------------------------------------------------------------------
 *
 * TclpLocaltime --
 *
 *	Wrapper around the 'localtime' library function to make it thread
 *	safe.
 *
 * Results:
 *	Returns a pointer to a 'struct tm' in thread-specific data.
 *
 * Side effects:
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpLocaltime( timePtr )
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch */

{
    /*
     * The MS implementation of localtime is thread safe because
     * it returns the time in a block of thread-local storage,
     * and Windows does not provide a Posix localtime_r function.
     */

    return localtime( timePtr );
}












































































|
|
|


|
|


|


|

|
|
|





|




>
|
>

|
|
|



|
|
|


|



|

>
|
>


|
|
>


|














|
|


|













<


|
<
|
<
|
|
<
|
<
|
|
<
|
|
<
|
|





|
|



|


|
|
|
|
|
|
<


|
|





|
<
|
|

|
|
|
|
<
<
|
<
|
|


|
|



|

|
|
|

|
|



|
|


|
|
|
|



|
|
|
<



|



|
>
|
|
<
|
|

>






|
|
|
<












|
|
|





|
|
|
<
|
<


|













|
|





|
|
|

|
<
|
|

|
|
|
|



<
|

|
|
<
|
|
<
<

<

<

<

<


>
|
>

|
|
|
|
|

|
|

>


|
|
|
<
|
|

<

|
|
>

|
|
|
|
|
|

>
|
>

|












|
<











|
|
|
|
<

|
|
|

>
|




















|
|
|



|
|
|

>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922

923
924
925

926

927
928

929

930
931

932
933

934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954

955
956
957
958
959
960
961
962
963
964

965
966
967
968
969
970
971


972

973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006

1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017

1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030

1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053

1054

1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082

1083
1084
1085
1086
1087
1088
1089
1090
1091
1092

1093
1094
1095
1096

1097
1098


1099

1100

1101

1102

1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123

1124
1125
1126

1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156

1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171

1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
}

/*
 *----------------------------------------------------------------------
 *
 * CalibrationThread --
 *
 *	Thread that manages calibration of the hi-resolution time derived from
 *	the performance counter, to keep it synchronized with the system
 *	clock.
 *
 * Parameters:
 *	arg - Client data from the CreateThread call. This parameter points to
 *	      the static TimeInfo structure.
 *
 * Return value:
 *	None. This thread embeds an infinite loop.
 *
 * Side effects:
 *	At an interval of 1s, this thread performs virtual time discipline.
 *
 * Note: When this thread is entered, TclpInitLock has been called to
 * safeguard the static storage. There is therefore no synchronization in the
 * body of this procedure.
 *
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
CalibrationThread(LPVOID arg)
{
    FILETIME curFileTime;
    DWORD waitResult;

    /*
     * Get initial system time and performance counter.
     */

    GetSystemTimeAsFileTime(&curFileTime);
    QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
    QueryPerformanceFrequency(&timeInfo.curCounterFreq);
    timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
    timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;

    ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
	    timeInfo.perfCounterLastCall.QuadPart,
	    timeInfo.curCounterFreq.QuadPart);

    /*
     * Wake up the calling thread. When it wakes up, it will release the
     * initialization lock.
     */

    SetEvent(timeInfo.readyEvent);

    /*
     * Run the calibration once a second.
     */

    while (timeInfo.perfCounterAvailable) {
	/*
	 * If the exitEvent is set, break out of the loop.
	 */

	waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
	if (waitResult == WAIT_OBJECT_0) {
	    break;
	}
	UpdateTimeEachSecond();
    }

    /* lint */
    return (DWORD) 0;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateTimeEachSecond --
 *
 *	Callback from the waitable timer in the clock calibration thread that
 *	updates system time.
 *
 * Parameters:
 *	info - Pointer to the static TimeInfo structure
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Performs virtual time calibration discipline.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateTimeEachSecond()
{

    LARGE_INTEGER curPerfCounter;
				/* Current value returned from
				 * QueryPerformanceCounter. */

    FILETIME curSysTime;	/* Current system time. */

    LARGE_INTEGER curFileTime;	/* File time at the time this callback was
				 * scheduled. */

    Tcl_WideInt estFreq;	/* Estimated perf counter frequency. */

    Tcl_WideInt vt0;		/* Tcl time right now. */
    Tcl_WideInt vt1;		/* Tcl time one second from now. */

    Tcl_WideInt tdiff;		/* Difference between system clock and Tcl
				 * time. */

    Tcl_WideInt driftFreq;	/* Frequency needed to drift virtual time into
				 * step over 1 second. */

    /*
     * Sample performance counter and system time.
     */

    QueryPerformanceCounter(&curPerfCounter);
    GetSystemTimeAsFileTime(&curSysTime);
    curFileTime.LowPart = curSysTime.dwLowDateTime;
    curFileTime.HighPart = curSysTime.dwHighDateTime;

    EnterCriticalSection(&timeInfo.cs);

    /*
     * We devide by timeInfo.curCounterFreq.QuadPart in several places. That
     * value should always be positive on a correctly functioning system. But
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.

     */

    if (timeInfo.curCounterFreq.QuadPart == 0){
	LeaveCriticalSection(&timeInfo.cs);
	timeInfo.perfCounterAvailable = 0;
	return;
    }

    /*
     * Several things may have gone wrong here that have to be checked for.

     *  (1) The performance counter may have jumped.
     *  (2) The system clock may have been reset.
     *
     * In either case, we'll need to reinitialize the circular buffer with
     * samples relative to the current system time and the NOMINAL performance
     * frequency (not the actual, because the actual has probably run slow in
     * the first case). Our estimated frequency will be the nominal frequency.


     *

     * Store the current sample into the circular buffer of samples, and
     * estimate the performance counter frequency.
     */

    estFreq = AccumulateSample(curPerfCounter.QuadPart,
	    (Tcl_WideUInt) curFileTime.QuadPart);

    /*
     * We want to adjust things so that time appears to be continuous.
     * Virtual file time, right now, is
     *
     * vt0 = 10000000 * (curPerfCounter - perfCounterLastCall)
     *	     / curCounterFreq
     *	     + fileTimeLastCall
     *
     * Ideally, we would like to drift the clock into place over a period of 2
     * sec, so that virtual time 2 sec from now will be
     *
     * vt1 = 20000000 + curFileTime
     * 
     * The frequency that we need to use to drift the counter back into place
     * is estFreq * 20000000 / (vt1 - vt0)
     */
    
    vt0 = 10000000 * (curPerfCounter.QuadPart
		- timeInfo.perfCounterLastCall.QuadPart)
	    / timeInfo.curCounterFreq.QuadPart
	    + timeInfo.fileTimeLastCall.QuadPart;
    vt1 = 20000000 + curFileTime.QuadPart;

    /*
     * If we've gotten more than a second away from system time, then drifting
     * the clock is going to be pretty hopeless. Just let it jump. Otherwise,
     * compute the drift frequency and fill in everything.

     */

    tdiff = vt0 - curFileTime.QuadPart;
    if (tdiff > 10000000 || tdiff < -10000000) {
	timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart;
	timeInfo.curCounterFreq.QuadPart = estFreq;
    } else {
	driftFreq = estFreq * 20000000 / (vt1 - vt0);

	if (driftFreq > 1003*estFreq/1000) {
	    driftFreq = 1003*estFreq/1000;

	} else if (driftFreq < 997*estFreq/1000) {
	    driftFreq = 997*estFreq/1000;
	}

	timeInfo.fileTimeLastCall.QuadPart = vt0;
	timeInfo.curCounterFreq.QuadPart = driftFreq;
    }

    timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart;

    LeaveCriticalSection(&timeInfo.cs);
}


/*
 *----------------------------------------------------------------------
 *
 * ResetCounterSamples --
 *
 *	Fills the sample arrays in 'timeInfo' with dummy values that will
 *	yield the current performance counter and frequency.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The array of samples is filled in so that it appears that there are
 *	SAMPLES samples at one-second intervals, separated by precisely the
 *	given frequency.
 *
 *----------------------------------------------------------------------
 */

static void
ResetCounterSamples(
    Tcl_WideUInt fileTime,	/* Current file time */
    Tcl_WideInt perfCounter,	/* Current performance counter */

    Tcl_WideInt perfFreq)	/* Target performance frequency */

{
    int i;
    for (i=SAMPLES-1 ; i>=0 ; --i) {
	timeInfo.perfCounterSample[i] = perfCounter;
	timeInfo.fileTimeSample[i] = fileTime;
	perfCounter -= perfFreq;
	fileTime -= 10000000;
    }
    timeInfo.sampleNo = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * AccumulateSample --
 *
 *	Updates the circular buffer of performance counter and system time
 *	samples with a new data point.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The new data point replaces the oldest point in the circular buffer,
 *	and the descriptive statistics are updated to accumulate the new
 *	point.
 *
 * Several things may have gone wrong here that have to be checked for.

 *  (1) The performance counter may have jumped.
 *  (2) The system clock may have been reset.
 *
 * In either case, we'll need to reinitialize the circular buffer with samples
 * relative to the current system time and the NOMINAL performance frequency
 * (not the actual, because the actual has probably run slow in the first
 * case).
 */

static Tcl_WideInt

AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime)
{
    Tcl_WideUInt workFTSample;	/* File time sample being removed from or
				 * added to the circular buffer. */

    Tcl_WideInt workPCSample;	/* Performance counter sample being removed
				 * from or added to the circular buffer. */


    Tcl_WideUInt lastFTSample;	/* Last file time sample recorded */

    Tcl_WideInt lastPCSample;	/* Last performance counter sample recorded */

    Tcl_WideInt FTdiff;		/* Difference between last FT and current */

    Tcl_WideInt PCdiff;		/* Difference between last PC and current */

    Tcl_WideInt estFreq;	/* Estimated performance counter frequency */

    /*
     * Test for jumps and reset the samples if we have one.
     */

    if (timeInfo.sampleNo == 0) {
	lastPCSample =
		timeInfo.perfCounterSample[timeInfo.sampleNo + SAMPLES - 1];
	lastFTSample =
		timeInfo.fileTimeSample[timeInfo.sampleNo + SAMPLES - 1];
    } else {
	lastPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo - 1];
	lastFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo - 1];
    }

    PCdiff = perfCounter - lastPCSample;
    FTdiff = fileTime - lastFTSample;
    if (PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10
	    || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10
	    || FTdiff < 9000000 || FTdiff > 11000000) {

	ResetCounterSamples(fileTime, perfCounter,
		timeInfo.nominalFreq.QuadPart);
	return timeInfo.nominalFreq.QuadPart;

    } else {
	/*
	 * Estimate the frequency.
	 */
	
	workPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo];
	workFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo];
	estFreq = 10000000 * (perfCounter - workPCSample)
		/ (fileTime - workFTSample);
	timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter;
	timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime;
	
	/*
	 * Advance the sample number.
	 */
	
	if (++timeInfo.sampleNo >= SAMPLES) {
	    timeInfo.sampleNo = 0;
	} 
	
	return estFreq;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGmtime --
 *
 *	Wrapper around the 'gmtime' library function to make it thread safe.

 *
 * Results:
 *	Returns a pointer to a 'struct tm' in thread-specific data.
 *
 * Side effects:
 *	Invokes gmtime or gmtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpGmtime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds since the
				 * local system's epoch */
{

    /*
     * The MS implementation of gmtime is thread safe because it returns the
     * time in a block of thread-local storage, and Windows does not provide a
     * Posix gmtime_r function.
     */

    return gmtime(timePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpLocaltime --
 *
 *	Wrapper around the 'localtime' library function to make it thread
 *	safe.
 *
 * Results:
 *	Returns a pointer to a 'struct tm' in thread-specific data.
 *
 * Side effects:
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

struct tm *
TclpLocaltime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds since the
				 * local system's epoch */

{
    /*
     * The MS implementation of localtime is thread safe because it returns
     * the time in a block of thread-local storage, and Windows does not
     * provide a Posix localtime_r function.
     */

    return localtime(timePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetTimeProc --
 *
 *	TIP #233 (Virtualized Time): Registers two handlers for the
 *	virtualization of Tcl's access to time information.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remembers the handlers, alters core behaviour.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetTimeProc(getProc, scaleProc, clientData)
    Tcl_GetTimeProc *getProc;
    Tcl_ScaleTimeProc *scaleProc;
    ClientData clientData;
{
    tclGetTimeProcPtr = getProc;
    tclScaleTimeProcPtr = scaleProc;
    tclTimeClientData = clientData;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_QueryTimeProc --
 *
 *	TIP #233 (Virtualized Time): Query which time handlers are registered.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_QueryTimeProc(getProc, scaleProc, clientData)
    Tcl_GetTimeProc ** getProc;
    Tcl_ScaleTimeProc **scaleProc;
    ClientData *clientData;
{
    if (getProc) {
	*getProc = tclGetTimeProcPtr;
    }
    if (scaleProc) {
	*scaleProc = tclScaleTimeProcPtr;
    }
    if (clientData) {
	*clientData = tclTimeClientData;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */